diff options
Diffstat (limited to 'contrib/perl5/t/lib')
106 files changed, 6562 insertions, 489 deletions
diff --git a/contrib/perl5/t/lib/abbrev.t b/contrib/perl5/t/lib/abbrev.t index fb5a984..05e5c70 100755 --- a/contrib/perl5/t/lib/abbrev.t +++ b/contrib/perl5/t/lib/abbrev.t @@ -4,7 +4,7 @@ print "1..7\n"; BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use Text::Abbrev; diff --git a/contrib/perl5/t/lib/ansicolor.t b/contrib/perl5/t/lib/ansicolor.t new file mode 100755 index 0000000..3e16dce --- /dev/null +++ b/contrib/perl5/t/lib/ansicolor.t @@ -0,0 +1,73 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +# Test suite for the Term::ANSIColor Perl module. Before `make install' is +# performed this script should be runnable with `make test'. After `make +# install' it should work as `perl test.pl'. + +############################################################################ +# Ensure module can be loaded +############################################################################ + +BEGIN { $| = 1; print "1..7\n" } +END { print "not ok 1\n" unless $loaded } +use Term::ANSIColor qw(:constants color colored); +$loaded = 1; +print "ok 1\n"; + + +############################################################################ +# Test suite +############################################################################ + +# Test simple color attributes. +if (color ('blue on_green', 'bold') eq "\e[34;42;1m") { + print "ok 2\n"; +} else { + print "not ok 2\n"; +} + +# Test colored. +if (colored ("testing", 'blue', 'bold') eq "\e[34;1mtesting\e[0m") { + print "ok 3\n"; +} else { + print "not ok 3\n"; +} + +# Test the constants. +if (BLUE BOLD "testing" eq "\e[34m\e[1mtesting") { + print "ok 4\n"; +} else { + print "not ok 4\n"; +} + +# Test AUTORESET. +$Term::ANSIColor::AUTORESET = 1; +if (BLUE BOLD "testing" eq "\e[34m\e[1mtesting\e[0m\e[0m") { + print "ok 5\n"; +} else { + print "not ok 5\n"; +} + +# Test EACHLINE. +$Term::ANSIColor::EACHLINE = "\n"; +if (colored ("test\n\ntest", 'bold') + eq "\e[1mtest\e[0m\n\n\e[1mtest\e[0m") { + print "ok 6\n"; +} else { + print colored ("test\n\ntest", 'bold'), "\n"; + print "not ok 6\n"; +} + +# Test EACHLINE with multiple trailing delimiters. +$Term::ANSIColor::EACHLINE = "\r\n"; +if (colored ("test\ntest\r\r\n\r\n", 'bold') + eq "\e[1mtest\ntest\r\e[0m\r\n\r\n") { + print "ok 7\n"; +} else { + print "not ok 7\n"; +} diff --git a/contrib/perl5/t/lib/anydbm.t b/contrib/perl5/t/lib/anydbm.t index 0391b7b..e38c7e7 100755 --- a/contrib/perl5/t/lib/anydbm.t +++ b/contrib/perl5/t/lib/anydbm.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } require AnyDBM_File; #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT @@ -12,6 +12,9 @@ use Fcntl; print "1..12\n"; +$Is_Dosish = ($^O eq 'amigaos' || $^O eq 'MSWin32' or $^O eq 'dos' or + $^O eq 'os2' or $^O eq 'mint'); + unlink <Op_dbmx*>; umask(0); @@ -22,7 +25,7 @@ $Dfile = "Op_dbmx.pag"; if (! -e $Dfile) { ($Dfile) = <Op_dbmx*>; } -if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos') { +if ($Is_Dosish) { print "ok 2 # Skipped: different file permission semantics\n"; } else { @@ -115,7 +118,30 @@ print ($size > 0 ? "ok 9\n" : "not ok 9\n"); print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); -print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); +if ($h{''} eq 'bar') { + print "ok 12\n" ; +} +else { + if ($AnyDBM_File::ISA[0] eq 'DB_File' && $DB_File::db_ver >= 2.004010) { + ($major, $minor, $patch) = ($DB_File::db_ver =~ /^(\d+)\.(\d\d\d)(\d\d\d)/) ; + $major =~ s/^0+// ; + $minor =~ s/^0+// ; + $patch =~ s/^0+// ; + $compact = "$major.$minor.$patch" ; + # + # anydbm.t test 12 will fail when AnyDBM_File uses the combination of + # DB_File and Berkeley DB 2.4.10 (or greater). + # You are using DB_File $DB_File::VERSION and Berkeley DB $compact + # + # Berkeley DB 2 from version 2.4.10 onwards does not allow null keys. + # This feature will be reenabled in a future version of Berkeley DB. + # + print "ok 12 # skipped: db v$compact, no null key support\n" ; + } + else { + print "not ok 12\n" ; + } +} untie %h; if ($^O eq 'VMS') { diff --git a/contrib/perl5/t/lib/attrs.t b/contrib/perl5/t/lib/attrs.t new file mode 100755 index 0000000..eb8c8c4 --- /dev/null +++ b/contrib/perl5/t/lib/attrs.t @@ -0,0 +1,138 @@ +#!./perl + +# Regression tests for attrs.pm and the C<sub x : attrs> syntax. + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + eval 'require attrs; 1' or do { + print "1..0\n"; + exit 0; + } +} + +sub NTESTS () ; + +my $test, $ntests; +BEGIN {$ntests=0} +$test=0; +my $failed = 0; + +print "1..".NTESTS."\n"; + +eval 'sub t1 ($) { use attrs "locked"; $_[0]++ }'; +(print "not "), $failed=1 if $@; +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +eval 'sub t2 { use attrs "locked"; $_[0]++ }'; +(print "not "), $failed=1 if $@; +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +eval 'sub t3 ($) : locked ;'; +(print "not "), $failed=1 if $@; +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +eval 'sub t4 : locked ;'; +(print "not "), $failed=1 if $@; +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +my $anon1; +eval '$anon1 = sub ($) { use attrs qw(locked method); $_[0]++ }'; +(print "not "), $failed=1 if $@; +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +my $anon2; +eval '$anon2 = sub { use attrs qw(locked method); $_[0]++ }'; +(print "not "), $failed=1 if $@; +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +my $anon3; +eval '$anon3 = sub { use attrs "method"; $_[0]->[1] }'; +(print "not "), $failed=1 if $@; +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +my @attrs = attrs::get($anon3 ? $anon3 : \&ns); +(print "not "), $failed=1 unless "@attrs" eq "method"; +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +@attrs = sort +attrs::get($anon2 ? $anon2 : \&ns); +(print "not "), $failed=1 unless "@attrs" eq "locked method"; +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +@attrs = sort +attrs::get($anon1 ? $anon1 : \&ns); +(print "not "), $failed=1 unless "@attrs" eq "locked method"; +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +eval 'sub e1 ($) : plugh ;'; +unless ($@ && $@ =~ m/^Invalid CODE attribute: ["']?plugh["']? at/) { + my $x = $@; + $x =~ s/\n.*\z//s; + print "# $x\n"; + print "not "; + $failed = 1; +} +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +eval 'sub e2 ($) : plugh(0,0) xyzzy ;'; +unless ($@ && $@ =~ m/^Invalid CODE attributes: ["']?plugh\(0,0\)["']? /) { + my $x = $@; + $x =~ s/\n.*\z//s; + print "# $x\n"; + print "not "; + $failed = 1; +} +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +eval 'sub e3 ($) : plugh(0,0 xyzzy ;'; +unless ($@ && $@ =~ m/Unterminated attribute parameter in attribute list at/) { + my $x = $@; + $x =~ s/\n.*\z//s; + print "# $x\n"; + print "not "; + $failed = 1; +} +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +eval 'sub e4 ($) : plugh + xyzzy ;'; +unless ($@ && $@ =~ m/Invalid separator character '[+]' in attribute list at/) { + my $x = $@; + $x =~ s/\n.*\z//s; + print "# $x\n"; + print "not "; + $failed = 1; +} +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +{ + my $w = "" ; + local $SIG{__WARN__} = sub {$w = @_[0]} ; + eval 'sub w1 ($) { use warnings "deprecated"; use attrs "locked"; $_[0]++ }'; + (print "not "), $failed=1 if $@; + print "ok ",++$test,"\n"; + BEGIN {++$ntests} + (print "not "), $failed=1 + if $w !~ /^pragma "attrs" is deprecated, use "sub NAME : ATTRS" instead at/; + print "ok ",++$test,"\n"; + BEGIN {++$ntests} +} + + +# Other tests should be added above this line + +sub NTESTS () { $ntests } + +exit $failed; diff --git a/contrib/perl5/t/lib/autoloader.t b/contrib/perl5/t/lib/autoloader.t index b1622a8..3bf690b 100755 --- a/contrib/perl5/t/lib/autoloader.t +++ b/contrib/perl5/t/lib/autoloader.t @@ -3,10 +3,10 @@ BEGIN { chdir 't' if -d 't'; $dir = "auto-$$"; - @INC = ("./$dir", "../lib"); + unshift @INC, ("./$dir", "../lib"); } -print "1..9\n"; +print "1..11\n"; # First we must set up some autoloader files mkdir $dir, 0755 or die "Can't mkdir $dir: $!"; @@ -88,12 +88,33 @@ print "ok 8\n"; print "not " unless $foo->bazmarkhianish($1) eq 'foo'; print "ok 9\n"; +# test recursive autoloads +open(F, ">$dir/auto/Foo/a.al") or die; +print F <<'EOT'; +package Foo; +BEGIN { b() } +sub a { print "ok 11\n"; } +1; +EOT +close(F); + +open(F, ">$dir/auto/Foo/b.al") or die; +print F <<'EOT'; +package Foo; +sub b { print "ok 10\n"; } +1; +EOT +close(F); +Foo::a(); + # cleanup END { return unless $dir && -d $dir; unlink "$dir/auto/Foo/foo.al"; unlink "$dir/auto/Foo/bar.al"; unlink "$dir/auto/Foo/bazmarkhian.al"; +unlink "$dir/auto/Foo/a.al"; +unlink "$dir/auto/Foo/b.al"; rmdir "$dir/auto/Foo"; rmdir "$dir/auto"; rmdir "$dir"; diff --git a/contrib/perl5/t/lib/basename.t b/contrib/perl5/t/lib/basename.t index a02aa32..478e26a 100755 --- a/contrib/perl5/t/lib/basename.t +++ b/contrib/perl5/t/lib/basename.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use File::Basename qw(fileparse basename dirname); diff --git a/contrib/perl5/t/lib/bigfloat.t b/contrib/perl5/t/lib/bigfloat.t new file mode 100755 index 0000000..8e0a0ef --- /dev/null +++ b/contrib/perl5/t/lib/bigfloat.t @@ -0,0 +1,408 @@ +#!./perl + +BEGIN { @INC = '../lib' } +require "bigfloat.pl"; + +$test = 0; +$| = 1; +print "1..355\n"; +while (<DATA>) { + chop; + if (/^&/) { + $f = $_; + } elsif (/^\$.*/) { + eval "$_;"; + } else { + ++$test; + @args = split(/:/,$_,99); + $ans = pop(@args); + $try = "$f('" . join("','", @args) . "');"; + if (($ans1 = eval($try)) eq $ans) { + print "ok $test\n"; + } else { + print "not ok $test\n"; + print "# '$try' expected: '$ans' got: '$ans1'\n"; + } + } +} +__END__ +&fnorm +abc:NaN + 1 a:NaN +1bcd2:NaN +11111b:NaN ++1z:NaN +-1z:NaN +0:+0E+0 ++0:+0E+0 ++00:+0E+0 ++0 0 0:+0E+0 +000000 0000000 00000:+0E+0 +-0:+0E+0 +-0000:+0E+0 ++1:+1E+0 ++01:+1E+0 ++001:+1E+0 ++00000100000:+1E+5 +123456789:+123456789E+0 +-1:-1E+0 +-01:-1E+0 +-001:-1E+0 +-123456789:-123456789E+0 +-00000100000:-1E+5 +123.456a:NaN +123.456:+123456E-3 +0.01:+1E-2 +.002:+2E-3 +-0.0003:-3E-4 +-.0000000004:-4E-10 +123456E2:+123456E+2 +123456E-2:+123456E-2 +-123456E2:-123456E+2 +-123456E-2:-123456E-2 +1e1:+1E+1 +2e-11:+2E-11 +-3e111:-3E+111 +-4e-1111:-4E-1111 +&fneg +abd:NaN ++0:+0E+0 ++1:-1E+0 +-1:+1E+0 ++123456789:-123456789E+0 +-123456789:+123456789E+0 ++123.456789:-123456789E-6 +-123456.789:+123456789E-3 +&fabs +abc:NaN ++0:+0E+0 ++1:+1E+0 +-1:+1E+0 ++123456789:+123456789E+0 +-123456789:+123456789E+0 ++123.456789:+123456789E-6 +-123456.789:+123456789E-3 +&fround +$bigfloat::rnd_mode = 'trunc' ++10123456789:5:+10123E+6 +-10123456789:5:-10123E+6 ++10123456789:9:+101234567E+2 +-10123456789:9:-101234567E+2 ++101234500:6:+101234E+3 +-101234500:6:-101234E+3 +$bigfloat::rnd_mode = 'zero' ++20123456789:5:+20123E+6 +-20123456789:5:-20123E+6 ++20123456789:9:+201234568E+2 +-20123456789:9:-201234568E+2 ++201234500:6:+201234E+3 +-201234500:6:-201234E+3 +$bigfloat::rnd_mode = '+inf' ++30123456789:5:+30123E+6 +-30123456789:5:-30123E+6 ++30123456789:9:+301234568E+2 +-30123456789:9:-301234568E+2 ++301234500:6:+301235E+3 +-301234500:6:-301234E+3 +$bigfloat::rnd_mode = '-inf' ++40123456789:5:+40123E+6 +-40123456789:5:-40123E+6 ++40123456789:9:+401234568E+2 +-40123456789:9:-401234568E+2 ++401234500:6:+401234E+3 +-401234500:6:-401235E+3 +$bigfloat::rnd_mode = 'odd' ++50123456789:5:+50123E+6 +-50123456789:5:-50123E+6 ++50123456789:9:+501234568E+2 +-50123456789:9:-501234568E+2 ++501234500:6:+501235E+3 +-501234500:6:-501235E+3 +$bigfloat::rnd_mode = 'even' ++60123456789:5:+60123E+6 +-60123456789:5:-60123E+6 ++60123456789:9:+601234568E+2 +-60123456789:9:-601234568E+2 ++601234500:6:+601234E+3 +-601234500:6:-601234E+3 +&ffround +$bigfloat::rnd_mode = 'trunc' ++1.23:-1:+12E-1 +-1.23:-1:-12E-1 ++1.27:-1:+12E-1 +-1.27:-1:-12E-1 ++1.25:-1:+12E-1 +-1.25:-1:-12E-1 ++1.35:-1:+13E-1 +-1.35:-1:-13E-1 +-0.006:-1:+0E+0 +-0.006:-2:+0E+0 +$bigfloat::rnd_mode = 'zero' ++2.23:-1:+22E-1 +-2.23:-1:-22E-1 ++2.27:-1:+23E-1 +-2.27:-1:-23E-1 ++2.25:-1:+22E-1 +-2.25:-1:-22E-1 ++2.35:-1:+23E-1 +-2.35:-1:-23E-1 +-0.0065:-1:+0E+0 +-0.0065:-2:-1E-2 +-0.0065:-3:-6E-3 +-0.0065:-4:-65E-4 +-0.0065:-5:-65E-4 +$bigfloat::rnd_mode = '+inf' ++3.23:-1:+32E-1 +-3.23:-1:-32E-1 ++3.27:-1:+33E-1 +-3.27:-1:-33E-1 ++3.25:-1:+33E-1 +-3.25:-1:-32E-1 ++3.35:-1:+34E-1 +-3.35:-1:-33E-1 +-0.0065:-1:+0E+0 +-0.0065:-2:-1E-2 +-0.0065:-3:-6E-3 +-0.0065:-4:-65E-4 +-0.0065:-5:-65E-4 +$bigfloat::rnd_mode = '-inf' ++4.23:-1:+42E-1 +-4.23:-1:-42E-1 ++4.27:-1:+43E-1 +-4.27:-1:-43E-1 ++4.25:-1:+42E-1 +-4.25:-1:-43E-1 ++4.35:-1:+43E-1 +-4.35:-1:-44E-1 +-0.0065:-1:+0E+0 +-0.0065:-2:-1E-2 +-0.0065:-3:-7E-3 +-0.0065:-4:-65E-4 +-0.0065:-5:-65E-4 +$bigfloat::rnd_mode = 'odd' ++5.23:-1:+52E-1 +-5.23:-1:-52E-1 ++5.27:-1:+53E-1 +-5.27:-1:-53E-1 ++5.25:-1:+53E-1 +-5.25:-1:-53E-1 ++5.35:-1:+53E-1 +-5.35:-1:-53E-1 +-0.0065:-1:+0E+0 +-0.0065:-2:-1E-2 +-0.0065:-3:-7E-3 +-0.0065:-4:-65E-4 +-0.0065:-5:-65E-4 +$bigfloat::rnd_mode = 'even' ++6.23:-1:+62E-1 +-6.23:-1:-62E-1 ++6.27:-1:+63E-1 +-6.27:-1:-63E-1 ++6.25:-1:+62E-1 +-6.25:-1:-62E-1 ++6.35:-1:+64E-1 +-6.35:-1:-64E-1 +-0.0065:-1:+0E+0 +-0.0065:-2:-1E-2 +-0.0065:-3:-6E-3 +-0.0065:-4:-65E-4 +-0.0065:-5:-65E-4 +&fcmp +abc:abc: +abc:+0: ++0:abc: ++0:+0:0 +-1:+0:-1 ++0:-1:1 ++1:+0:1 ++0:+1:-1 +-1:+1:-1 ++1:-1:1 +-1:-1:0 ++1:+1:0 ++123:+123:0 ++123:+12:1 ++12:+123:-1 +-123:-123:0 +-123:-12:-1 +-12:-123:1 ++123:+124:-1 ++124:+123:1 +-123:-124:1 +-124:-123:-1 +&fadd +abc:abc:NaN +abc:+0:NaN ++0:abc:NaN ++0:+0:+0E+0 ++1:+0:+1E+0 ++0:+1:+1E+0 ++1:+1:+2E+0 +-1:+0:-1E+0 ++0:-1:-1E+0 +-1:-1:-2E+0 +-1:+1:+0E+0 ++1:-1:+0E+0 ++9:+1:+1E+1 ++99:+1:+1E+2 ++999:+1:+1E+3 ++9999:+1:+1E+4 ++99999:+1:+1E+5 ++999999:+1:+1E+6 ++9999999:+1:+1E+7 ++99999999:+1:+1E+8 ++999999999:+1:+1E+9 ++9999999999:+1:+1E+10 ++99999999999:+1:+1E+11 ++10:-1:+9E+0 ++100:-1:+99E+0 ++1000:-1:+999E+0 ++10000:-1:+9999E+0 ++100000:-1:+99999E+0 ++1000000:-1:+999999E+0 ++10000000:-1:+9999999E+0 ++100000000:-1:+99999999E+0 ++1000000000:-1:+999999999E+0 ++10000000000:-1:+9999999999E+0 ++123456789:+987654321:+111111111E+1 +-123456789:+987654321:+864197532E+0 +-123456789:-987654321:-111111111E+1 ++123456789:-987654321:-864197532E+0 +&fsub +abc:abc:NaN +abc:+0:NaN ++0:abc:NaN ++0:+0:+0E+0 ++1:+0:+1E+0 ++0:+1:-1E+0 ++1:+1:+0E+0 +-1:+0:-1E+0 ++0:-1:+1E+0 +-1:-1:+0E+0 +-1:+1:-2E+0 ++1:-1:+2E+0 ++9:+1:+8E+0 ++99:+1:+98E+0 ++999:+1:+998E+0 ++9999:+1:+9998E+0 ++99999:+1:+99998E+0 ++999999:+1:+999998E+0 ++9999999:+1:+9999998E+0 ++99999999:+1:+99999998E+0 ++999999999:+1:+999999998E+0 ++9999999999:+1:+9999999998E+0 ++99999999999:+1:+99999999998E+0 ++10:-1:+11E+0 ++100:-1:+101E+0 ++1000:-1:+1001E+0 ++10000:-1:+10001E+0 ++100000:-1:+100001E+0 ++1000000:-1:+1000001E+0 ++10000000:-1:+10000001E+0 ++100000000:-1:+100000001E+0 ++1000000000:-1:+1000000001E+0 ++10000000000:-1:+10000000001E+0 ++123456789:+987654321:-864197532E+0 +-123456789:+987654321:-111111111E+1 +-123456789:-987654321:+864197532E+0 ++123456789:-987654321:+111111111E+1 +&fmul +abc:abc:NaN +abc:+0:NaN ++0:abc:NaN ++0:+0:+0E+0 ++0:+1:+0E+0 ++1:+0:+0E+0 ++0:-1:+0E+0 +-1:+0:+0E+0 ++123456789123456789:+0:+0E+0 ++0:+123456789123456789:+0E+0 +-1:-1:+1E+0 +-1:+1:-1E+0 ++1:-1:-1E+0 ++1:+1:+1E+0 ++2:+3:+6E+0 +-2:+3:-6E+0 ++2:-3:-6E+0 +-2:-3:+6E+0 ++111:+111:+12321E+0 ++10101:+10101:+102030201E+0 ++1001001:+1001001:+1002003002001E+0 ++100010001:+100010001:+10002000300020001E+0 ++10000100001:+10000100001:+100002000030000200001E+0 ++11111111111:+9:+99999999999E+0 ++22222222222:+9:+199999999998E+0 ++33333333333:+9:+299999999997E+0 ++44444444444:+9:+399999999996E+0 ++55555555555:+9:+499999999995E+0 ++66666666666:+9:+599999999994E+0 ++77777777777:+9:+699999999993E+0 ++88888888888:+9:+799999999992E+0 ++99999999999:+9:+899999999991E+0 +&fdiv +abc:abc:NaN +abc:+1:abc:NaN ++1:abc:NaN ++0:+0:NaN ++0:+1:+0E+0 ++1:+0:NaN ++0:-1:+0E+0 +-1:+0:NaN ++1:+1:+1E+0 +-1:-1:+1E+0 ++1:-1:-1E+0 +-1:+1:-1E+0 ++1:+2:+5E-1 ++2:+1:+2E+0 ++10:+5:+2E+0 ++100:+4:+25E+0 ++1000:+8:+125E+0 ++10000:+16:+625E+0 ++10000:-16:-625E+0 ++999999999999:+9:+111111111111E+0 ++999999999999:+99:+10101010101E+0 ++999999999999:+999:+1001001001E+0 ++999999999999:+9999:+100010001E+0 ++999999999999999:+99999:+10000100001E+0 ++1000000000:+9:+1111111111111111111111111111111111111111E-31 ++2000000000:+9:+2222222222222222222222222222222222222222E-31 ++3000000000:+9:+3333333333333333333333333333333333333333E-31 ++4000000000:+9:+4444444444444444444444444444444444444444E-31 ++5000000000:+9:+5555555555555555555555555555555555555556E-31 ++6000000000:+9:+6666666666666666666666666666666666666667E-31 ++7000000000:+9:+7777777777777777777777777777777777777778E-31 ++8000000000:+9:+8888888888888888888888888888888888888889E-31 ++9000000000:+9:+1E+9 ++35500000:+113:+3141592920353982300884955752212389380531E-34 ++71000000:+226:+3141592920353982300884955752212389380531E-34 ++106500000:+339:+3141592920353982300884955752212389380531E-34 ++1000000000:+3:+3333333333333333333333333333333333333333E-31 +$bigfloat::div_scale = 20 ++1000000000:+9:+11111111111111111111E-11 ++2000000000:+9:+22222222222222222222E-11 ++3000000000:+9:+33333333333333333333E-11 ++4000000000:+9:+44444444444444444444E-11 ++5000000000:+9:+55555555555555555556E-11 ++6000000000:+9:+66666666666666666667E-11 ++7000000000:+9:+77777777777777777778E-11 ++8000000000:+9:+88888888888888888889E-11 ++9000000000:+9:+1E+9 ++35500000:+113:+314159292035398230088E-15 ++71000000:+226:+314159292035398230088E-15 ++106500000:+339:+31415929203539823009E-14 ++1000000000:+3:+33333333333333333333E-11 +$bigfloat::div_scale = 40 +&fsqrt ++0:+0E+0 +-1:NaN +-2:NaN +-16:NaN +-123.456:NaN ++1:+1E+0 ++1.44:+12E-1 ++2:+141421356237309504880168872420969807857E-38 ++4:+2E+0 ++16:+4E+0 ++100:+1E+1 ++123.456:+1111107555549866648462149404118219234119E-38 ++15241.383936:+123456E-3 diff --git a/contrib/perl5/t/lib/bigfltpm.t b/contrib/perl5/t/lib/bigfltpm.t new file mode 100755 index 0000000..5d97f1b --- /dev/null +++ b/contrib/perl5/t/lib/bigfltpm.t @@ -0,0 +1,463 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Math::BigFloat; + +$test = 0; +$| = 1; +print "1..362\n"; +while (<DATA>) { + chop; + if (s/^&//) { + $f = $_; + } elsif (/^\$.*/) { + eval "$_;"; + } else { + ++$test; + if (m|^(.*?):(/.+)$|) { + $ans = $2; + @args = split(/:/,$1,99); + } + else { + @args = split(/:/,$_,99); + $ans = pop(@args); + } + $try = "\$x = new Math::BigFloat \"$args[0]\";"; + if ($f eq "fnorm"){ + $try .= "\$x+0;"; + } elsif ($f eq "fneg") { + $try .= "-\$x;"; + } elsif ($f eq "fabs") { + $try .= "abs \$x;"; + } elsif ($f eq "fround") { + $try .= "0+\$x->fround($args[1]);"; + } elsif ($f eq "ffround") { + $try .= "0+\$x->ffround($args[1]);"; + } elsif ($f eq "fsqrt") { + $try .= "0+\$x->fsqrt;"; + } else { + $try .= "\$y = new Math::BigFloat \"$args[1]\";"; + if ($f eq "fcmp") { + $try .= "\$x <=> \$y;"; + } elsif ($f eq "fadd") { + $try .= "\$x + \$y;"; + } elsif ($f eq "fsub") { + $try .= "\$x - \$y;"; + } elsif ($f eq "fmul") { + $try .= "\$x * \$y;"; + } elsif ($f eq "fdiv") { + $try .= "\$x / \$y;"; + } else { warn "Unknown op"; } + } + #print ">>>",$try,"<<<\n"; + $ans1 = eval $try; + if ($ans =~ m|^/(.*)$|) { + my $pat = $1; + if ($ans1 =~ /$pat/) { + print "ok $test\n"; + } + else { + print "not ok $test\n"; + print "# '$try' expected: /$pat/ got: '$ans1'\n"; + } + } + elsif ("$ans1" eq $ans) { #bug! + print "ok $test\n"; + } else { + print "not ok $test\n"; + print "# '$try' expected: '$ans' got: '$ans1'\n"; + } + } +} +__END__ +&fnorm +abc:NaN. + 1 a:NaN. +1bcd2:NaN. +11111b:NaN. ++1z:NaN. +-1z:NaN. +0:0. ++0:0. ++00:0. ++0 0 0:0. +000000 0000000 00000:0. +-0:0. +-0000:0. ++1:1. ++01:1. ++001:1. ++00000100000:100000. +123456789:123456789. +-1:-1. +-01:-1. +-001:-1. +-123456789:-123456789. +-00000100000:-100000. +123.456a:NaN. +123.456:123.456 +0.01:.01 +.002:.002 +-0.0003:-.0003 +-.0000000004:-.0000000004 +123456E2:12345600. +123456E-2:1234.56 +-123456E2:-12345600. +-123456E-2:-1234.56 +1e1:10. +2e-11:.00000000002 +-3e111:-3000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000. +-4e-1111:-.0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000004 +&fneg +abd:NaN. ++0:0. ++1:-1. +-1:1. ++123456789:-123456789. +-123456789:123456789. ++123.456789:-123.456789 +-123456.789:123456.789 +&fabs +abc:NaN. ++0:0. ++1:1. +-1:1. ++123456789:123456789. +-123456789:123456789. ++123.456789:123.456789 +-123456.789:123456.789 +&fround +$Math::BigFloat::rnd_mode = 'trunc' ++10123456789:5:10123000000 +-10123456789:5:-10123000000 ++10123456789:9:10123456700 +-10123456789:9:-10123456700 ++101234500:6:101234000 +-101234500:6:-101234000 +$Math::BigFloat::rnd_mode = 'zero' ++20123456789:5:20123000000 +-20123456789:5:-20123000000 ++20123456789:9:20123456800 +-20123456789:9:-20123456800 ++201234500:6:201234000 +-201234500:6:-201234000 +$Math::BigFloat::rnd_mode = '+inf' ++30123456789:5:30123000000 +-30123456789:5:-30123000000 ++30123456789:9:30123456800 +-30123456789:9:-30123456800 ++301234500:6:301235000 +-301234500:6:-301234000 +$Math::BigFloat::rnd_mode = '-inf' ++40123456789:5:40123000000 +-40123456789:5:-40123000000 ++40123456789:9:40123456800 +-40123456789:9:-40123456800 ++401234500:6:401234000 +-401234500:6:-401235000 +$Math::BigFloat::rnd_mode = 'odd' ++50123456789:5:50123000000 +-50123456789:5:-50123000000 ++50123456789:9:50123456800 +-50123456789:9:-50123456800 ++501234500:6:501235000 +-501234500:6:-501235000 +$Math::BigFloat::rnd_mode = 'even' ++60123456789:5:60123000000 +-60123456789:5:-60123000000 ++60123456789:9:60123456800 +-60123456789:9:-60123456800 ++601234500:6:601234000 +-601234500:6:-601234000 +&ffround +$Math::BigFloat::rnd_mode = 'trunc' ++1.23:-1:1.2 +-1.23:-1:-1.2 ++1.27:-1:1.2 +-1.27:-1:-1.2 ++1.25:-1:1.2 +-1.25:-1:-1.2 ++1.35:-1:1.3 +-1.35:-1:-1.3 +-0.006:-1:0 +-0.006:-2:0 +-0.0065:-3:/-0\.006|-6e-03 +-0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 +-0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 +$Math::BigFloat::rnd_mode = 'zero' ++2.23:-1:/2.2(?:0{5}\d+)? +-2.23:-1:/-2.2(?:0{5}\d+)? ++2.27:-1:/2.(?:3|29{5}\d+) +-2.27:-1:/-2.(?:3|29{5}\d+) ++2.25:-1:/2.2(?:0{5}\d+)? +-2.25:-1:/-2.2(?:0{5}\d+)? ++2.35:-1:/2.(?:3|29{5}\d+) +-2.35:-1:/-2.(?:3|29{5}\d+) +-0.0065:-1:0 +-0.0065:-2:/-0\.01|-1e-02 +-0.0065:-3:/-0\.006|-6e-03 +-0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 +-0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 +$Math::BigFloat::rnd_mode = '+inf' ++3.23:-1:/3.2(?:0{5}\d+)? +-3.23:-1:/-3.2(?:0{5}\d+)? ++3.27:-1:/3.(?:3|29{5}\d+) +-3.27:-1:/-3.(?:3|29{5}\d+) ++3.25:-1:/3.(?:3|29{5}\d+) +-3.25:-1:/-3.2(?:0{5}\d+)? ++3.35:-1:/3.(?:4|39{5}\d+) +-3.35:-1:/-3.(?:3|29{5}\d+) +-0.0065:-1:0 +-0.0065:-2:/-0\.01|-1e-02 +-0.0065:-3:/-0\.006|-6e-03 +-0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 +-0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 +$Math::BigFloat::rnd_mode = '-inf' ++4.23:-1:/4.2(?:0{5}\d+)? +-4.23:-1:/-4.2(?:0{5}\d+)? ++4.27:-1:/4.(?:3|29{5}\d+) +-4.27:-1:/-4.(?:3|29{5}\d+) ++4.25:-1:/4.2(?:0{5}\d+)? +-4.25:-1:/-4.(?:3|29{5}\d+) ++4.35:-1:/4.(?:3|29{5}\d+) +-4.35:-1:/-4.(?:4|39{5}\d+) +-0.0065:-1:0 +-0.0065:-2:/-0\.01|-1e-02 +-0.0065:-3:/-0\.007|-7e-03 +-0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 +-0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 +$Math::BigFloat::rnd_mode = 'odd' ++5.23:-1:/5.2(?:0{5}\d+)? +-5.23:-1:/-5.2(?:0{5}\d+)? ++5.27:-1:/5.(?:3|29{5}\d+) +-5.27:-1:/-5.(?:3|29{5}\d+) ++5.25:-1:/5.(?:3|29{5}\d+) +-5.25:-1:/-5.(?:3|29{5}\d+) ++5.35:-1:/5.(?:3|29{5}\d+) +-5.35:-1:/-5.(?:3|29{5}\d+) +-0.0065:-1:0 +-0.0065:-2:/-0\.01|-1e-02 +-0.0065:-3:/-0\.007|-7e-03 +-0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 +-0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 +$Math::BigFloat::rnd_mode = 'even' ++6.23:-1:/6.2(?:0{5}\d+)? +-6.23:-1:/-6.2(?:0{5}\d+)? ++6.27:-1:/6.(?:3|29{5}\d+) +-6.27:-1:/-6.(?:3|29{5}\d+) ++6.25:-1:/6.2(?:0{5}\d+)? +-6.25:-1:/-6.2(?:0{5}\d+)? ++6.35:-1:/6.(?:4|39{5}\d+) +-6.35:-1:/-6.(?:4|39{5}\d+) +-0.0065:-1:0 +-0.0065:-2:/-0\.01|-1e-02 +-0.0065:-3:/-0\.006|-6e-03 +-0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 +-0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 +&fcmp +abc:abc: +abc:+0: ++0:abc: ++0:+0:0 +-1:+0:-1 ++0:-1:1 ++1:+0:1 ++0:+1:-1 +-1:+1:-1 ++1:-1:1 +-1:-1:0 ++1:+1:0 +-1.1:0:-1 ++0:-1.1:1 ++1.1:+0:1 ++0:+1.1:-1 ++123:+123:0 ++123:+12:1 ++12:+123:-1 +-123:-123:0 +-123:-12:-1 +-12:-123:1 ++123:+124:-1 ++124:+123:1 +-123:-124:1 +-124:-123:-1 +&fadd +abc:abc:NaN. +abc:+0:NaN. ++0:abc:NaN. ++0:+0:0. ++1:+0:1. ++0:+1:1. ++1:+1:2. +-1:+0:-1. ++0:-1:-1. +-1:-1:-2. +-1:+1:0. ++1:-1:0. ++9:+1:10. ++99:+1:100. ++999:+1:1000. ++9999:+1:10000. ++99999:+1:100000. ++999999:+1:1000000. ++9999999:+1:10000000. ++99999999:+1:100000000. ++999999999:+1:1000000000. ++9999999999:+1:10000000000. ++99999999999:+1:100000000000. ++10:-1:9. ++100:-1:99. ++1000:-1:999. ++10000:-1:9999. ++100000:-1:99999. ++1000000:-1:999999. ++10000000:-1:9999999. ++100000000:-1:99999999. ++1000000000:-1:999999999. ++10000000000:-1:9999999999. ++123456789:+987654321:1111111110. +-123456789:+987654321:864197532. +-123456789:-987654321:-1111111110. ++123456789:-987654321:-864197532. +&fsub +abc:abc:NaN. +abc:+0:NaN. ++0:abc:NaN. ++0:+0:0. ++1:+0:1. ++0:+1:-1. ++1:+1:0. +-1:+0:-1. ++0:-1:1. +-1:-1:0. +-1:+1:-2. ++1:-1:2. ++9:+1:8. ++99:+1:98. ++999:+1:998. ++9999:+1:9998. ++99999:+1:99998. ++999999:+1:999998. ++9999999:+1:9999998. ++99999999:+1:99999998. ++999999999:+1:999999998. ++9999999999:+1:9999999998. ++99999999999:+1:99999999998. ++10:-1:11. ++100:-1:101. ++1000:-1:1001. ++10000:-1:10001. ++100000:-1:100001. ++1000000:-1:1000001. ++10000000:-1:10000001. ++100000000:-1:100000001. ++1000000000:-1:1000000001. ++10000000000:-1:10000000001. ++123456789:+987654321:-864197532. +-123456789:+987654321:-1111111110. +-123456789:-987654321:864197532. ++123456789:-987654321:1111111110. +&fmul +abc:abc:NaN. +abc:+0:NaN. ++0:abc:NaN. ++0:+0:0. ++0:+1:0. ++1:+0:0. ++0:-1:0. +-1:+0:0. ++123456789123456789:+0:0. ++0:+123456789123456789:0. +-1:-1:1. +-1:+1:-1. ++1:-1:-1. ++1:+1:1. ++2:+3:6. +-2:+3:-6. ++2:-3:-6. +-2:-3:6. ++111:+111:12321. ++10101:+10101:102030201. ++1001001:+1001001:1002003002001. ++100010001:+100010001:10002000300020001. ++10000100001:+10000100001:100002000030000200001. ++11111111111:+9:99999999999. ++22222222222:+9:199999999998. ++33333333333:+9:299999999997. ++44444444444:+9:399999999996. ++55555555555:+9:499999999995. ++66666666666:+9:599999999994. ++77777777777:+9:699999999993. ++88888888888:+9:799999999992. ++99999999999:+9:899999999991. +&fdiv +abc:abc:NaN. +abc:+1:abc:NaN. ++1:abc:NaN. ++0:+0:NaN. ++0:+1:0. ++1:+0:NaN. ++0:-1:0. +-1:+0:NaN. ++1:+1:1. +-1:-1:1. ++1:-1:-1. +-1:+1:-1. ++1:+2:.5 ++2:+1:2. ++10:+5:2. ++100:+4:25. ++1000:+8:125. ++10000:+16:625. ++10000:-16:-625. ++999999999999:+9:111111111111. ++999999999999:+99:10101010101. ++999999999999:+999:1001001001. ++999999999999:+9999:100010001. ++999999999999999:+99999:10000100001. ++1000000000:+9:111111111.1111111111111111111111111111111 ++2000000000:+9:222222222.2222222222222222222222222222222 ++3000000000:+9:333333333.3333333333333333333333333333333 ++4000000000:+9:444444444.4444444444444444444444444444444 ++5000000000:+9:555555555.5555555555555555555555555555556 ++6000000000:+9:666666666.6666666666666666666666666666667 ++7000000000:+9:777777777.7777777777777777777777777777778 ++8000000000:+9:888888888.8888888888888888888888888888889 ++9000000000:+9:1000000000. ++35500000:+113:314159.2920353982300884955752212389380531 ++71000000:+226:314159.2920353982300884955752212389380531 ++106500000:+339:314159.2920353982300884955752212389380531 ++1000000000:+3:333333333.3333333333333333333333333333333 +$Math::BigFloat::div_scale = 20 ++1000000000:+9:111111111.11111111111 ++2000000000:+9:222222222.22222222222 ++3000000000:+9:333333333.33333333333 ++4000000000:+9:444444444.44444444444 ++5000000000:+9:555555555.55555555556 ++6000000000:+9:666666666.66666666667 ++7000000000:+9:777777777.77777777778 ++8000000000:+9:888888888.88888888889 ++9000000000:+9:1000000000. ++35500000:+113:314159.292035398230088 ++71000000:+226:314159.292035398230088 ++106500000:+339:314159.29203539823009 ++1000000000:+3:333333333.33333333333 +$Math::BigFloat::div_scale = 40 +&fsqrt ++0:0 +-1:/^(?i:0|\?|NaNQ?)$ +-2:/^(?i:0|\?|NaNQ?)$ +-16:/^(?i:0|\?|NaNQ?)$ +-123.456:/^(?i:0|\?|NaNQ?)$ ++1:1. ++1.44:1.2 ++2:1.41421356237309504880168872420969807857 ++4:2. ++16:4. ++100:10. ++123.456:11.11107555549866648462149404118219234119 ++15241.383936:123.456 diff --git a/contrib/perl5/t/lib/bigint.t b/contrib/perl5/t/lib/bigint.t index 034c5c6..d2d520e 100755 --- a/contrib/perl5/t/lib/bigint.t +++ b/contrib/perl5/t/lib/bigint.t @@ -1,6 +1,6 @@ #!./perl -BEGIN { @INC = '../lib' } +BEGIN { unshift @INC, '../lib' } require "bigint.pl"; $test = 0; diff --git a/contrib/perl5/t/lib/bigintpm.t b/contrib/perl5/t/lib/bigintpm.t index e7cac26..ae362e2 100755 --- a/contrib/perl5/t/lib/bigintpm.t +++ b/contrib/perl5/t/lib/bigintpm.t @@ -2,14 +2,14 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use Math::BigInt; $test = 0; $| = 1; -print "1..247\n"; +print "1..278\n"; while (<DATA>) { chop; if (s/^&//) { @@ -27,20 +27,32 @@ while (<DATA>) { $try .= "abs \$x;"; } else { $try .= "\$y = new Math::BigInt \"$args[1]\";"; - if ($f eq bcmp){ + if ($f eq "bcmp"){ $try .= "\$x <=> \$y;"; - }elsif ($f eq badd){ + }elsif ($f eq "badd"){ $try .= "\$x + \$y;"; - }elsif ($f eq bsub){ + }elsif ($f eq "bsub"){ $try .= "\$x - \$y;"; - }elsif ($f eq bmul){ + }elsif ($f eq "bmul"){ $try .= "\$x * \$y;"; - }elsif ($f eq bdiv){ + }elsif ($f eq "bdiv"){ $try .= "\$x / \$y;"; - }elsif ($f eq bmod){ + }elsif ($f eq "bmod"){ $try .= "\$x % \$y;"; - }elsif ($f eq bgcd){ + }elsif ($f eq "bgcd"){ $try .= "Math::BigInt::bgcd(\$x, \$y);"; + }elsif ($f eq "blsft"){ + $try .= "\$x << \$y;"; + }elsif ($f eq "brsft"){ + $try .= "\$x >> \$y;"; + }elsif ($f eq "band"){ + $try .= "\$x & \$y;"; + }elsif ($f eq "bior"){ + $try .= "\$x | \$y;"; + }elsif ($f eq "bxor"){ + $try .= "\$x ^ \$y;"; + }elsif ($f eq "bnot"){ + $try .= "~\$x;"; } else { warn "Unknown op"; } } #print ">>>",$try,"<<<\n"; @@ -52,7 +64,24 @@ while (<DATA>) { print "# '$try' expected: '$ans' got: '$ans1'\n"; } } -} +} + +{ + use Math::BigInt ':constant'; + + $test++; + print "not " + unless 2**150 eq "+1427247692705959881058285969449495136382746624"; + print "ok $test\n"; + $test++; + @a = (); + for ($i = 1; $i < 10; $i++) { + push @a, $i; + } + print "not " unless "@a" eq "+1 +2 +3 +4 +5 +6 +7 +8 +9"; + print "ok $test\n"; +} + __END__ &bnorm abc:NaN @@ -93,29 +122,29 @@ abc:NaN +123456789:+123456789 -123456789:+123456789 &bcmp -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:+0 +abc:abc: +abc:+0: ++0:abc: ++0:+0:0 -1:+0:-1 -+0:-1:+1 -+1:+0:+1 ++0:-1:1 ++1:+0:1 +0:+1:-1 -1:+1:-1 -+1:-1:+1 --1:-1:+0 -+1:+1:+0 -+123:+123:+0 -+123:+12:+1 ++1:-1:1 +-1:-1:0 ++1:+1:0 ++123:+123:0 ++123:+12:1 +12:+123:-1 --123:-123:+0 +-123:-123:0 -123:-12:-1 --12:-123:+1 +-12:-123:1 +123:+124:-1 -+124:+123:+1 --123:-124:+1 ++124:+123:1 +-123:-124:1 -124:-123:-1 -+100:+5:+1 ++100:+5:1 &badd abc:abc:NaN abc:+0:NaN @@ -311,3 +340,38 @@ abc:+0:NaN +3:+2:+1 +100:+625:+25 +4096:+81:+1 +&blsft +abc:abc:NaN ++2:+2:+8 ++1:+32:+4294967296 ++1:+48:+281474976710656 ++8:-2:NaN +&brsft +abc:abc:NaN ++8:+2:+2 ++4294967296:+32:+1 ++281474976710656:+48:+1 ++2:-2:NaN +&band +abc:abc:NaN ++8:+2:+0 ++281474976710656:+0:+0 ++281474976710656:+1:+0 ++281474976710656:+281474976710656:+281474976710656 +&bior +abc:abc:NaN ++8:+2:+10 ++281474976710656:+0:+281474976710656 ++281474976710656:+1:+281474976710657 ++281474976710656:+281474976710656:+281474976710656 +&bxor +abc:abc:NaN ++8:+2:+10 ++281474976710656:+0:+281474976710656 ++281474976710656:+1:+281474976710657 ++281474976710656:+281474976710656:+0 +&bnot +abc:NaN ++0:-1 ++8:-9 ++281474976710656:-281474976710657 diff --git a/contrib/perl5/t/lib/cgi-form.t b/contrib/perl5/t/lib/cgi-form.t index 86df161..e3cba5f 100755 --- a/contrib/perl5/t/lib/cgi-form.t +++ b/contrib/perl5/t/lib/cgi-form.t @@ -5,7 +5,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } BEGIN {$| = 1; print "1..17\n"; } @@ -44,16 +44,16 @@ test(6,textfield(-name=>'weather') eq qq(<INPUT TYPE="text" NAME="weather" VALUE test(7,textfield(-name=>'weather',-value=>'nice') eq qq(<INPUT TYPE="text" NAME="weather" VALUE="dull">),"textfield({-name,-value})"); test(8,textfield(-name=>'weather',-value=>'nice',-override=>1) eq qq(<INPUT TYPE="text" NAME="weather" VALUE="nice">), "textfield({-name,-value,-override})"); -test(9,checkbox(-name=>'weather',-value=>'nice') eq qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="nice">weather\n), +test(9,checkbox(-name=>'weather',-value=>'nice') eq qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="nice">weather), "checkbox()"); test(10,checkbox(-name=>'weather',-value=>'nice',-label=>'forecast') eq - qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="nice">forecast\n), + qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="nice">forecast), "checkbox()"); test(11,checkbox(-name=>'weather',-value=>'nice',-label=>'forecast',-checked=>1,-override=>1) eq - qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="nice" CHECKED>forecast\n), + qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="nice" CHECKED>forecast), "checkbox()"); test(12,checkbox(-name=>'weather',-value=>'dull',-label=>'forecast') eq - qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="dull" CHECKED>forecast\n), + qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="dull" CHECKED>forecast), "checkbox()"); test(13,radio_group(-name=>'game') eq diff --git a/contrib/perl5/t/lib/cgi-function.t b/contrib/perl5/t/lib/cgi-function.t index ad8b968..b4cd568 100755 --- a/contrib/perl5/t/lib/cgi-function.t +++ b/contrib/perl5/t/lib/cgi-function.t @@ -5,7 +5,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } BEGIN {$| = 1; print "1..24\n"; } diff --git a/contrib/perl5/t/lib/cgi-html.t b/contrib/perl5/t/lib/cgi-html.t index 6a7ff1e..43d41ec 100755 --- a/contrib/perl5/t/lib/cgi-html.t +++ b/contrib/perl5/t/lib/cgi-html.t @@ -5,12 +5,11 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; + require Config; import Config; } BEGIN {$| = 1; print "1..20\n"; } -BEGIN {$eol = $^O eq 'VMS' ? "\n" : "\cM\cJ"; - $eol = "\r\n" if $^O eq 'os390'; } END {print "not ok 1\n" unless $loaded;} use CGI (':standard','-no_debug','*h3','start_table'); $loaded = 1; @@ -18,6 +17,9 @@ print "ok 1\n"; ######################### End of black magic. +my $Is_EBCDIC = $Config{'ebcdic'} eq 'define'; +my $crlf = $CGI::CRLF; + # util sub test { local($^W) = 0; @@ -38,10 +40,11 @@ test(7,h1({-align=>'CENTER'},['fred','agnes']) eq local($") = '-'; test(8,h1('fred','agnes','maura') eq '<H1>fred-agnes-maura</H1>',"open/close tag \$\" interpolation"); } -test(9,header() eq "Content-Type: text/html${eol}${eol}","header()"); -test(10,header(-type=>'image/gif') eq "Content-Type: image/gif${eol}${eol}","header()"); -test(11,header(-type=>'image/gif',-status=>'500 Sucks') eq "Status: 500 Sucks${eol}Content-Type: image/gif${eol}${eol}","header()"); -test(12,header(-nph=>1) eq "HTTP/1.0 200 OK${eol}Content-Type: text/html${eol}${eol}","header()"); + +test(9,header() eq "Content-Type: text/html$crlf$crlf","header()"); +test(10,header(-type=>'image/gif') eq "Content-Type: image/gif$crlf$crlf","header()"); +test(11,header(-type=>'image/gif',-status=>'500 Sucks') eq "Status: 500 Sucks${crlf}Content-Type: image/gif$crlf$crlf","header()"); +test(12,header(-nph=>1) eq "HTTP/1.0 200 OK${crlf}Content-Type: text/html$crlf$crlf","header()"); test(13,start_html() ."\n" eq <<END,"start_html()"); <!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN"> <HTML><HEAD><TITLE>Untitled Document</TITLE> @@ -62,8 +65,11 @@ END ; test(16,($cookie=cookie(-name=>'fred',-value=>['chocolate','chip'],-path=>'/')) eq 'fred=chocolate&chip; path=/',"cookie()"); -test(17,header(-Cookie=>$cookie) =~ m!^Set-Cookie: fred=chocolate&chip\; path=/${eol}Date:.*${eol}Content-Type: text/html${eol}${eol}!s, +test(17,header(-Cookie=>$cookie) =~ m!^Set-Cookie: fred=chocolate&chip\; path=/${crlf}Date:.*${crlf}Content-Type: text/html$crlf$crlf!s, "header(-cookie)"); test(18,start_h3 eq '<H3>'); test(19,end_h3 eq '</H3>'); test(20,start_table({-border=>undef}) eq '<TABLE BORDER>'); + + + diff --git a/contrib/perl5/t/lib/cgi-request.t b/contrib/perl5/t/lib/cgi-request.t index 8c70c40..9e8cdc2 100755 --- a/contrib/perl5/t/lib/cgi-request.t +++ b/contrib/perl5/t/lib/cgi-request.t @@ -5,7 +5,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } BEGIN {$| = 1; print "1..31\n"; } @@ -25,15 +25,16 @@ sub test { } # Set up a CGI environment -$ENV{REQUEST_METHOD}='GET'; -$ENV{QUERY_STRING} ='game=chess&game=checkers&weather=dull'; -$ENV{PATH_INFO} ='/somewhere/else'; -$ENV{PATH_TRANSLATED} ='/usr/local/somewhere/else'; -$ENV{SCRIPT_NAME} ='/cgi-bin/foo.cgi'; +$ENV{REQUEST_METHOD} = 'GET'; +$ENV{QUERY_STRING} = 'game=chess&game=checkers&weather=dull'; +$ENV{PATH_INFO} = '/somewhere/else'; +$ENV{PATH_TRANSLATED} = '/usr/local/somewhere/else'; +$ENV{SCRIPT_NAME} = '/cgi-bin/foo.cgi'; $ENV{SERVER_PROTOCOL} = 'HTTP/1.0'; -$ENV{SERVER_PORT} = 8080; -$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com'; -$ENV{HTTP_LOVE} = 'true'; +$ENV{SERVER_PORT} = 8080; +$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com'; +$ENV{REQUEST_URI} = "$ENV{SCRIPT_NAME}$ENV{PATH_INFO}?$ENV{QUERY_STRING}"; +$ENV{HTTP_LOVE} = 'true'; $q = new CGI; test(2,$q,"CGI::new()"); diff --git a/contrib/perl5/t/lib/charnames.t b/contrib/perl5/t/lib/charnames.t new file mode 100755 index 0000000..7643390 --- /dev/null +++ b/contrib/perl5/t/lib/charnames.t @@ -0,0 +1,74 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + unshift @INC, '../lib' if -d '../lib'; + } +} + +$| = 1; +print "1..12\n"; + +use charnames ':full'; + +print "not " unless "Here\N{EXCLAMATION MARK}?" eq "Here\041?"; +print "ok 1\n"; + +{ + use bytes; # UTEST can switch utf8 on + + print "# \$res=$res \$\@='$@'\nnot " + if $res = eval <<'EOE' +use charnames ":full"; +"Here: \N{CYRILLIC SMALL LETTER BE}!"; +1 +EOE + or $@ !~ /above 0xFF/; + print "ok 2\n"; + # print "# \$res=$res \$\@='$@'\n"; + + print "# \$res=$res \$\@='$@'\nnot " + if $res = eval <<'EOE' +use charnames 'cyrillic'; +"Here: \N{Be}!"; +1 +EOE + or $@ !~ /CYRILLIC CAPITAL LETTER BE.*above 0xFF/; + print "ok 3\n"; +} + +# If octal representation of unicode char is \0xyzt, then the utf8 is \3xy\2zt +$encoded_be = "\320\261"; +$encoded_alpha = "\316\261"; +$encoded_bet = "\327\221"; +{ + use charnames ':full'; + + print "not " unless "\N{CYRILLIC SMALL LETTER BE}" eq $encoded_be; + print "ok 4\n"; + + use charnames qw(cyrillic greek :short); + + print "not " unless "\N{be},\N{alpha},\N{hebrew:bet}" + eq "$encoded_be,$encoded_alpha,$encoded_bet"; + print "ok 5\n"; +} + +{ + use charnames ':full'; + print "not " unless "\x{263a}" eq "\N{WHITE SMILING FACE}"; + print "ok 6\n"; + print "not " unless length("\x{263a}") == 1; + print "ok 7\n"; + print "not " unless length("\N{WHITE SMILING FACE}") == 1; + print "ok 8\n"; + print "not " unless sprintf("%vx", "\x{263a}") eq "263a"; + print "ok 9\n"; + print "not " unless sprintf("%vx", "\N{WHITE SMILING FACE}") eq "263a"; + print "ok 10\n"; + print "not " unless sprintf("%vx", "\xFF\N{WHITE SMILING FACE}") eq "ff.263a"; + print "ok 11\n"; + print "not " unless sprintf("%vx", "\x{ff}\N{WHITE SMILING FACE}") eq "ff.263a"; + print "ok 12\n"; +} diff --git a/contrib/perl5/t/lib/checktree.t b/contrib/perl5/t/lib/checktree.t index b5426ca..7603575 100755 --- a/contrib/perl5/t/lib/checktree.t +++ b/contrib/perl5/t/lib/checktree.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } print "1..1\n"; diff --git a/contrib/perl5/t/lib/complex.t b/contrib/perl5/t/lib/complex.t index c073f50..a636ff0 100755 --- a/contrib/perl5/t/lib/complex.t +++ b/contrib/perl5/t/lib/complex.t @@ -9,7 +9,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use Math::Complex; @@ -73,6 +73,7 @@ push(@script, <<'EOT'); my $z = cplx( 1, 1); $z->Re(2); $z->Im(3); + print "# $test Re(z) = ",$z->Re(), " Im(z) = ", $z->Im(), " z = $z\n"; print 'not ' unless Re($z) == 2 and Im($z) == 3; EOT push(@script, qq(print "ok $test\\n"}\n)); @@ -82,6 +83,7 @@ push(@script, <<'EOT'); { my $z = cplx( 1, 1); $z->abs(3 * sqrt(2)); + print "# $test Re(z) = ",$z->Re(), " Im(z) = ", $z->Im(), " z = $z\n"; print 'not ' unless (abs($z) - 3 * sqrt(2)) < $eps and (arg($z) - pi / 4 ) < $eps and (Re($z) - 3 ) < $eps and @@ -94,6 +96,7 @@ push(@script, <<'EOT'); { my $z = cplx( 1, 1); $z->arg(-3 / 4 * pi); + print "# $test Re(z) = ",$z->Re(), " Im(z) = ", $z->Im(), " z = $z\n"; print 'not ' unless (arg($z) + 3 / 4 * pi) < $eps and (abs($z) - sqrt(2) ) < $eps and (Re($z) + 1 ) < $eps and @@ -120,10 +123,11 @@ push(@script, $constants); sub test_dbz { for my $op (@_) { $test++; - push(@script, <<EOT); -eval '$op'; -print 'not ' unless (\$@ =~ /Division by zero/); + eval '$op'; + (\$bad) = (\$@ =~ /(.+)/); + print "# $test op = $op divbyzero? \$bad...\n"; + print 'not ' unless (\$@ =~ /Division by zero/); EOT push(@script, qq(print "ok $test\\n";\n)); } @@ -134,10 +138,11 @@ EOT sub test_loz { for my $op (@_) { $test++; - push(@script, <<EOT); -eval '$op'; -print 'not ' unless (\$@ =~ /Logarithm of zero/); + eval '$op'; + (\$bad) = (\$@ =~ /(.+)/); + print "# $test op = $op logofzero? \$bad...\n"; + print 'not ' unless (\$@ =~ /Logarithm of zero/); EOT push(@script, qq(print "ok $test\\n";\n)); } @@ -178,10 +183,11 @@ test_loz( sub test_broot { for my $op (@_) { $test++; - push(@script, <<EOT); -eval 'root(2, $op)'; -print 'not ' unless (\$@ =~ /root must be/); + eval 'root(2, $op)'; + (\$bad) = (\$@ =~ /(.+)/); + print "# $test op = $op badroot? \$bad...\n"; + print 'not ' unless (\$@ =~ /root must be/); EOT push(@script, qq(print "ok $test\\n";\n)); } @@ -189,6 +195,99 @@ EOT test_broot(qw(-3 -2.1 0 0.99)); +sub test_display_format { + push @script, <<EOS; + my \$j = (root(1,3))[1]; + + \$j->display_format('polar'); +EOS + + $test++; + push @script, <<EOS; + print "# display_format polar?\n"; + print "not " unless \$j->display_format eq 'polar'; + print "ok $test\n"; +EOS + + $test++; + push @script, <<EOS; + print "# j = \$j\n"; + print "not " unless "\$j" eq "[1,2pi/3]"; + print "ok $test\n"; + + my %display_format; + + %display_format = \$j->display_format; +EOS + + $test++; + push @script, <<EOS; + print "# display_format{style} polar?\n"; + print "not " unless \$display_format{style} eq 'polar'; + print "ok $test\n"; +EOS + + $test++; + push @script, <<EOS; + print "# keys %display_format == 2?\n"; + print "not " unless keys %display_format == 2; + print "ok $test\n"; + + \$j->display_format('style' => 'cartesian', 'format' => '%.5f'); +EOS + + $test++; + push @script, <<EOS; + print "# j = \$j\n"; + print "not " unless "\$j" eq "-0.50000+0.86603i"; + print "ok $test\n"; + + %display_format = \$j->display_format; +EOS + + $test++; + push @script, <<EOS; + print "# display_format{format} %.5f?\n"; + print "not " unless \$display_format{format} eq '%.5f'; + print "ok $test\n"; +EOS + + $test++; + push @script, <<EOS; + print "# keys %display_format == 3?\n"; + print "not " unless keys %display_format == 3; + print "ok $test\n"; + + \$j->display_format('format' => undef); +EOS + + $test++; + push @script, <<EOS; + print "# j = \$j\n"; + print "not " unless "\$j" =~ /^-0\\.5\\+0.86602540\\d+i\$/; + print "ok $test\n"; + + \$j->display_format('style' => 'polar', 'polar_pretty_print' => 0); +EOS + + $test++; + push @script, <<EOS; + print "# j = \$j\n"; + print "not " unless "\$j" =~ /^\\[1,2\\.09439510\\d+\\]\$/; + print "ok $test\n"; + + \$j->display_format('style' => 'cartesian', 'format' => '(%.5g)'); +EOS + $test++; + push @script, <<EOS; + print "# j = \$j\n"; + print "not " unless "\$j" eq "(-0.5)+(0.86603)i"; + print "ok $test\n"; +EOS +} + +test_display_format(); + print "1..$test\n"; eval join '', @script; die $@ if $@; @@ -294,7 +393,7 @@ sub value { sub check { my ($test, $try, $got, $expected, @z) = @_; -# print "# @_\n"; + print "# @_\n"; if ("$got" eq "$expected" || diff --git a/contrib/perl5/t/lib/db-btree.t b/contrib/perl5/t/lib/db-btree.t index bf739c8..b13e50ea 100755 --- a/contrib/perl5/t/lib/db-btree.t +++ b/contrib/perl5/t/lib/db-btree.t @@ -1,10 +1,10 @@ #!./perl -w BEGIN { - @INC = '../lib' if -d '../lib' ; + unshift @INC, '../lib' if -d '../lib' ; require Config; import Config; if ($Config{'extensions'} !~ /\bDB_File\b/) { - print "1..0\n"; + print "1..0 # Skip: DB_File was not built\n"; exit 0; } } @@ -12,7 +12,7 @@ BEGIN { use DB_File; use Fcntl; -print "1..102\n"; +print "1..155\n"; sub ok { @@ -38,7 +38,53 @@ sub lexical return @a - @b ; } -$Dfile = "dbbtree.tmp"; +{ + package Redirect ; + use Symbol ; + + sub new + { + my $class = shift ; + my $filename = shift ; + my $fh = gensym ; + open ($fh, ">$filename") || die "Cannot open $filename: $!" ; + my $real_stdout = select($fh) ; + return bless [$fh, $real_stdout ] ; + + } + sub DESTROY + { + my $self = shift ; + close $self->[0] ; + select($self->[1]) ; + } +} + +sub docat +{ + my $file = shift; + #local $/ = undef unless wantarray ; + open(CAT,$file) || die "Cannot open $file: $!"; + my @result = <CAT>; + close(CAT); + wantarray ? @result : join("", @result) ; +} + +sub docat_del +{ + my $file = shift; + #local $/ = undef unless wantarray ; + open(CAT,$file) || die "Cannot open $file: $!"; + my @result = <CAT>; + close(CAT); + unlink $file ; + wantarray ? @result : join("", @result) ; +} + + +$db185mode = ($DB_File::db_version == 1 && ! $DB_File::db_185_compat) ; + +my $Dfile = "dbbtree.tmp"; unlink $Dfile; umask(0); @@ -134,7 +180,6 @@ delete $h{'goner2'}; undef $X ; untie(%h); - # tie to the same file again ok(26, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE)) ; @@ -609,4 +654,567 @@ EOM } +{ + # DBM Filter tests + use strict ; + my (%h, $db) ; + my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + unlink $Dfile; + + sub checkOutput + { + my($fk, $sk, $fv, $sv) = @_ ; + return + $fetch_key eq $fk && $store_key eq $sk && + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; + } + + ok(103, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); + + $db->filter_fetch_key (sub { $fetch_key = $_ }) ; + $db->filter_store_key (sub { $store_key = $_ }) ; + $db->filter_fetch_value (sub { $fetch_value = $_}) ; + $db->filter_store_value (sub { $store_value = $_ }) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + # fk sk fv sv + ok(104, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(105, $h{"fred"} eq "joe"); + # fk sk fv sv + ok(106, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(107, $db->FIRSTKEY() eq "fred") ; + # fk sk fv sv + ok(108, checkOutput( "fred", "", "", "")) ; + + # replace the filters, but remember the previous set + my ($old_fk) = $db->filter_fetch_key + (sub { $_ = uc $_ ; $fetch_key = $_ }) ; + my ($old_sk) = $db->filter_store_key + (sub { $_ = lc $_ ; $store_key = $_ }) ; + my ($old_fv) = $db->filter_fetch_value + (sub { $_ = "[$_]"; $fetch_value = $_ }) ; + my ($old_sv) = $db->filter_store_value + (sub { s/o/x/g; $store_value = $_ }) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"Fred"} = "Joe" ; + # fk sk fv sv + ok(109, checkOutput( "", "fred", "", "Jxe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(110, $h{"Fred"} eq "[Jxe]"); + # fk sk fv sv + ok(111, checkOutput( "", "fred", "[Jxe]", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(112, $db->FIRSTKEY() eq "FRED") ; + # fk sk fv sv + ok(113, checkOutput( "FRED", "", "", "")) ; + + # put the original filters back + $db->filter_fetch_key ($old_fk); + $db->filter_store_key ($old_sk); + $db->filter_fetch_value ($old_fv); + $db->filter_store_value ($old_sv); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(114, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(115, $h{"fred"} eq "joe"); + ok(116, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(117, $db->FIRSTKEY() eq "fred") ; + ok(118, checkOutput( "fred", "", "", "")) ; + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(119, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(120, $h{"fred"} eq "joe"); + ok(121, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(122, $db->FIRSTKEY() eq "fred") ; + ok(123, checkOutput( "", "", "", "")) ; + + undef $db ; + untie %h; + unlink $Dfile; +} + +{ + # DBM Filter with a closure + + use strict ; + my (%h, $db) ; + + unlink $Dfile; + ok(124, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); + + my %result = () ; + + sub Closure + { + my ($name) = @_ ; + my $count = 0 ; + my @kept = () ; + + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } + } + + $db->filter_store_key(Closure("store key")) ; + $db->filter_store_value(Closure("store value")) ; + $db->filter_fetch_key(Closure("fetch key")) ; + $db->filter_fetch_value(Closure("fetch value")) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + ok(125, $result{"store key"} eq "store key - 1: [fred]"); + ok(126, $result{"store value"} eq "store value - 1: [joe]"); + ok(127, ! defined $result{"fetch key"} ); + ok(128, ! defined $result{"fetch value"} ); + ok(129, $_ eq "original") ; + + ok(130, $db->FIRSTKEY() eq "fred") ; + ok(131, $result{"store key"} eq "store key - 1: [fred]"); + ok(132, $result{"store value"} eq "store value - 1: [joe]"); + ok(133, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(134, ! defined $result{"fetch value"} ); + ok(135, $_ eq "original") ; + + $h{"jim"} = "john" ; + ok(136, $result{"store key"} eq "store key - 2: [fred jim]"); + ok(137, $result{"store value"} eq "store value - 2: [joe john]"); + ok(138, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(139, ! defined $result{"fetch value"} ); + ok(140, $_ eq "original") ; + + ok(141, $h{"fred"} eq "joe"); + ok(142, $result{"store key"} eq "store key - 3: [fred jim fred]"); + ok(143, $result{"store value"} eq "store value - 2: [joe john]"); + ok(144, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(145, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(146, $_ eq "original") ; + + undef $db ; + untie %h; + unlink $Dfile; +} + +{ + # DBM Filter recursion detection + use strict ; + my (%h, $db) ; + unlink $Dfile; + + ok(147, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); + + $db->filter_store_key (sub { $_ = $h{$_} }) ; + + eval '$h{1} = 1234' ; + ok(148, $@ =~ /^recursion detected in filter_store_key at/ ); + + undef $db ; + untie %h; + unlink $Dfile; +} + + +{ + # Examples from the POD + + + my $file = "xyzt" ; + { + my $redirect = new Redirect $file ; + + # BTREE example 1 + ### + + use strict ; + use DB_File ; + + my %h ; + + sub Compare + { + my ($key1, $key2) = @_ ; + "\L$key1" cmp "\L$key2" ; + } + + # specify the Perl sub that will do the comparison + $DB_BTREE->{'compare'} = \&Compare ; + + unlink "tree" ; + tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open file 'tree': $!\n" ; + + # Add a key/value pair to the file + $h{'Wall'} = 'Larry' ; + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + $h{'duck'} = 'donald' ; + + # Delete + delete $h{"duck"} ; + + # Cycle through the keys printing them in order. + # Note it is not necessary to sort the keys as + # the btree will have kept them in order automatically. + foreach (keys %h) + { print "$_\n" } + + untie %h ; + + unlink "tree" ; + } + + delete $DB_BTREE->{'compare'} ; + + ok(149, docat_del($file) eq <<'EOM') ; +mouse +Smith +Wall +EOM + + { + my $redirect = new Redirect $file ; + + # BTREE example 2 + ### + + use strict ; + use DB_File ; + + use vars qw($filename %h ) ; + + $filename = "tree" ; + unlink $filename ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + # Add some key/value pairs to the file + $h{'Wall'} = 'Larry' ; + $h{'Wall'} = 'Brick' ; # Note the duplicate key + $h{'Wall'} = 'Brick' ; # Note the duplicate key and value + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + + # iterate through the associative array + # and print each key/value pair. + foreach (keys %h) + { print "$_ -> $h{$_}\n" } + + untie %h ; + + unlink $filename ; + } + + ok(150, docat_del($file) eq ($db185mode ? <<'EOM' : <<'EOM') ) ; +Smith -> John +Wall -> Brick +Wall -> Brick +Wall -> Brick +mouse -> mickey +EOM +Smith -> John +Wall -> Larry +Wall -> Larry +Wall -> Larry +mouse -> mickey +EOM + + { + my $redirect = new Redirect $file ; + + # BTREE example 3 + ### + + use strict ; + use DB_File ; + + use vars qw($filename $x %h $status $key $value) ; + + $filename = "tree" ; + unlink $filename ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + # Add some key/value pairs to the file + $h{'Wall'} = 'Larry' ; + $h{'Wall'} = 'Brick' ; # Note the duplicate key + $h{'Wall'} = 'Brick' ; # Note the duplicate key and value + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + + # iterate through the btree using seq + # and print each key/value pair. + $key = $value = 0 ; + for ($status = $x->seq($key, $value, R_FIRST) ; + $status == 0 ; + $status = $x->seq($key, $value, R_NEXT) ) + { print "$key -> $value\n" } + + + undef $x ; + untie %h ; + } + + ok(151, docat_del($file) eq ($db185mode == 1 ? <<'EOM' : <<'EOM') ) ; +Smith -> John +Wall -> Brick +Wall -> Brick +Wall -> Larry +mouse -> mickey +EOM +Smith -> John +Wall -> Larry +Wall -> Brick +Wall -> Brick +mouse -> mickey +EOM + + + { + my $redirect = new Redirect $file ; + + # BTREE example 4 + ### + + use strict ; + use DB_File ; + + use vars qw($filename $x %h ) ; + + $filename = "tree" ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + my $cnt = $x->get_dup("Wall") ; + print "Wall occurred $cnt times\n" ; + + my %hash = $x->get_dup("Wall", 1) ; + print "Larry is there\n" if $hash{'Larry'} ; + print "There are $hash{'Brick'} Brick Walls\n" ; + + my @list = sort $x->get_dup("Wall") ; + print "Wall => [@list]\n" ; + + @list = $x->get_dup("Smith") ; + print "Smith => [@list]\n" ; + + @list = $x->get_dup("Dog") ; + print "Dog => [@list]\n" ; + + undef $x ; + untie %h ; + } + + ok(152, docat_del($file) eq <<'EOM') ; +Wall occurred 3 times +Larry is there +There are 2 Brick Walls +Wall => [Brick Brick Larry] +Smith => [John] +Dog => [] +EOM + + { + my $redirect = new Redirect $file ; + + # BTREE example 5 + ### + + use strict ; + use DB_File ; + + use vars qw($filename $x %h $found) ; + + my $filename = "tree" ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; + print "Larry Wall is $found there\n" ; + + $found = ( $x->find_dup("Wall", "Harry") == 0 ? "" : "not") ; + print "Harry Wall is $found there\n" ; + + undef $x ; + untie %h ; + } + + ok(153, docat_del($file) eq <<'EOM') ; +Larry Wall is there +Harry Wall is not there +EOM + + { + my $redirect = new Redirect $file ; + + # BTREE example 6 + ### + + use strict ; + use DB_File ; + + use vars qw($filename $x %h $found) ; + + my $filename = "tree" ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + $x->del_dup("Wall", "Larry") ; + + $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; + print "Larry Wall is $found there\n" ; + + undef $x ; + untie %h ; + + unlink $filename ; + } + + ok(154, docat_del($file) eq <<'EOM') ; +Larry Wall is not there +EOM + + { + my $redirect = new Redirect $file ; + + # BTREE example 7 + ### + + use strict ; + use DB_File ; + use Fcntl ; + + use vars qw($filename $x %h $st $key $value) ; + + sub match + { + my $key = shift ; + my $value = 0; + my $orig_key = $key ; + $x->seq($key, $value, R_CURSOR) ; + print "$orig_key\t-> $key\t-> $value\n" ; + } + + $filename = "tree" ; + unlink $filename ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + # Add some key/value pairs to the file + $h{'mouse'} = 'mickey' ; + $h{'Wall'} = 'Larry' ; + $h{'Walls'} = 'Brick' ; + $h{'Smith'} = 'John' ; + + + $key = $value = 0 ; + print "IN ORDER\n" ; + for ($st = $x->seq($key, $value, R_FIRST) ; + $st == 0 ; + $st = $x->seq($key, $value, R_NEXT) ) + + { print "$key -> $value\n" } + + print "\nPARTIAL MATCH\n" ; + + match "Wa" ; + match "A" ; + match "a" ; + + undef $x ; + untie %h ; + + unlink $filename ; + + } + + ok(155, docat_del($file) eq <<'EOM') ; +IN ORDER +Smith -> John +Wall -> Larry +Walls -> Brick +mouse -> mickey + +PARTIAL MATCH +Wa -> Wall -> Larry +A -> Smith -> John +a -> mouse -> mickey +EOM + +} + +#{ +# # R_SETCURSOR +# use strict ; +# my (%h, $db) ; +# unlink $Dfile; +# +# ok(156, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); +# +# $h{abc} = 33 ; +# my $k = "newest" ; +# my $v = 44 ; +# my $status = $db->put($k, $v, R_SETCURSOR) ; +# print "status = [$status]\n" ; +# ok(157, $status == 0) ; +# $status = $db->del($k, R_CURSOR) ; +# print "status = [$status]\n" ; +# ok(158, $status == 0) ; +# $k = "newest" ; +# ok(159, $db->get($k, $v, R_CURSOR)) ; +# +# ok(160, keys %h == 1) ; +# +# undef $db ; +# untie %h; +# unlink $Dfile; +#} + exit ; diff --git a/contrib/perl5/t/lib/db-hash.t b/contrib/perl5/t/lib/db-hash.t index e748472..c52d8ae 100755 --- a/contrib/perl5/t/lib/db-hash.t +++ b/contrib/perl5/t/lib/db-hash.t @@ -1,10 +1,10 @@ #!./perl -w BEGIN { - @INC = '../lib' if -d '../lib' ; + unshift @INC, '../lib' if -d '../lib' ; require Config; import Config; if ($Config{'extensions'} !~ /\bDB_File\b/) { - print "1..0\n"; + print "1..0 # Skip: DB_File was not built\n"; exit 0; } } @@ -12,7 +12,7 @@ BEGIN { use DB_File; use Fcntl; -print "1..62\n"; +print "1..109\n"; sub ok { @@ -23,7 +23,40 @@ sub ok print "ok $no\n" ; } -$Dfile = "dbhash.tmp"; +{ + package Redirect ; + use Symbol ; + + sub new + { + my $class = shift ; + my $filename = shift ; + my $fh = gensym ; + open ($fh, ">$filename") || die "Cannot open $filename: $!" ; + my $real_stdout = select($fh) ; + return bless [$fh, $real_stdout ] ; + + } + sub DESTROY + { + my $self = shift ; + close $self->[0] ; + select($self->[1]) ; + } +} + +sub docat_del +{ + my $file = shift; + local $/ = undef; + open(CAT,$file) || die "Cannot open $file: $!"; + my $result = <CAT>; + close(CAT); + unlink $file ; + return $result; +} + +my $Dfile = "dbhash.tmp"; unlink $Dfile; umask(0); @@ -164,6 +197,8 @@ ok(25, $#keys == 31) ; $h{'foo'} = ''; ok(26, $h{'foo'} eq '' ); +# Berkeley DB 2 from version 2.4.10 onwards does not allow null keys. +# This feature will be reenabled in a future version of Berkeley DB. #$h{''} = 'bar'; #ok(27, $h{''} eq 'bar' ); ok(27,1) ; @@ -413,4 +448,238 @@ EOM unlink "SubDB.pm", "dbhash.tmp" ; } + +{ + # DBM Filter tests + use strict ; + my (%h, $db) ; + my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + unlink $Dfile; + + sub checkOutput + { + my($fk, $sk, $fv, $sv) = @_ ; + return + $fetch_key eq $fk && $store_key eq $sk && + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; + } + + ok(63, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + + $db->filter_fetch_key (sub { $fetch_key = $_ }) ; + $db->filter_store_key (sub { $store_key = $_ }) ; + $db->filter_fetch_value (sub { $fetch_value = $_}) ; + $db->filter_store_value (sub { $store_value = $_ }) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + # fk sk fv sv + ok(64, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(65, $h{"fred"} eq "joe"); + # fk sk fv sv + ok(66, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(67, $db->FIRSTKEY() eq "fred") ; + # fk sk fv sv + ok(68, checkOutput( "fred", "", "", "")) ; + + # replace the filters, but remember the previous set + my ($old_fk) = $db->filter_fetch_key + (sub { $_ = uc $_ ; $fetch_key = $_ }) ; + my ($old_sk) = $db->filter_store_key + (sub { $_ = lc $_ ; $store_key = $_ }) ; + my ($old_fv) = $db->filter_fetch_value + (sub { $_ = "[$_]"; $fetch_value = $_ }) ; + my ($old_sv) = $db->filter_store_value + (sub { s/o/x/g; $store_value = $_ }) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"Fred"} = "Joe" ; + # fk sk fv sv + ok(69, checkOutput( "", "fred", "", "Jxe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(70, $h{"Fred"} eq "[Jxe]"); + # fk sk fv sv + ok(71, checkOutput( "", "fred", "[Jxe]", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(72, $db->FIRSTKEY() eq "FRED") ; + # fk sk fv sv + ok(73, checkOutput( "FRED", "", "", "")) ; + + # put the original filters back + $db->filter_fetch_key ($old_fk); + $db->filter_store_key ($old_sk); + $db->filter_fetch_value ($old_fv); + $db->filter_store_value ($old_sv); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(74, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(75, $h{"fred"} eq "joe"); + ok(76, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(77, $db->FIRSTKEY() eq "fred") ; + ok(78, checkOutput( "fred", "", "", "")) ; + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(79, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(80, $h{"fred"} eq "joe"); + ok(81, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(82, $db->FIRSTKEY() eq "fred") ; + ok(83, checkOutput( "", "", "", "")) ; + + undef $db ; + untie %h; + unlink $Dfile; +} + +{ + # DBM Filter with a closure + + use strict ; + my (%h, $db) ; + + unlink $Dfile; + ok(84, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + + my %result = () ; + + sub Closure + { + my ($name) = @_ ; + my $count = 0 ; + my @kept = () ; + + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } + } + + $db->filter_store_key(Closure("store key")) ; + $db->filter_store_value(Closure("store value")) ; + $db->filter_fetch_key(Closure("fetch key")) ; + $db->filter_fetch_value(Closure("fetch value")) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + ok(85, $result{"store key"} eq "store key - 1: [fred]"); + ok(86, $result{"store value"} eq "store value - 1: [joe]"); + ok(87, ! defined $result{"fetch key"} ); + ok(88, ! defined $result{"fetch value"} ); + ok(89, $_ eq "original") ; + + ok(90, $db->FIRSTKEY() eq "fred") ; + ok(91, $result{"store key"} eq "store key - 1: [fred]"); + ok(92, $result{"store value"} eq "store value - 1: [joe]"); + ok(93, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(94, ! defined $result{"fetch value"} ); + ok(95, $_ eq "original") ; + + $h{"jim"} = "john" ; + ok(96, $result{"store key"} eq "store key - 2: [fred jim]"); + ok(97, $result{"store value"} eq "store value - 2: [joe john]"); + ok(98, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(99, ! defined $result{"fetch value"} ); + ok(100, $_ eq "original") ; + + ok(101, $h{"fred"} eq "joe"); + ok(102, $result{"store key"} eq "store key - 3: [fred jim fred]"); + ok(103, $result{"store value"} eq "store value - 2: [joe john]"); + ok(104, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(105, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(106, $_ eq "original") ; + + undef $db ; + untie %h; + unlink $Dfile; +} + +{ + # DBM Filter recursion detection + use strict ; + my (%h, $db) ; + unlink $Dfile; + + ok(107, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + + $db->filter_store_key (sub { $_ = $h{$_} }) ; + + eval '$h{1} = 1234' ; + ok(108, $@ =~ /^recursion detected in filter_store_key at/ ); + + undef $db ; + untie %h; + unlink $Dfile; +} + + +{ + # Examples from the POD + + my $file = "xyzt" ; + { + my $redirect = new Redirect $file ; + + use strict ; + use DB_File ; + use vars qw( %h $k $v ) ; + + unlink "fruit" ; + tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH + or die "Cannot open file 'fruit': $!\n"; + + # Add a few key/value pairs to the file + $h{"apple"} = "red" ; + $h{"orange"} = "orange" ; + $h{"banana"} = "yellow" ; + $h{"tomato"} = "red" ; + + # Check for existence of a key + print "Banana Exists\n\n" if $h{"banana"} ; + + # Delete a key/value pair. + delete $h{"apple"} ; + + # print the contents of the file + while (($k, $v) = each %h) + { print "$k -> $v\n" } + + untie %h ; + + unlink "fruit" ; + } + + ok(109, docat_del($file) eq <<'EOM') ; +Banana Exists + +orange -> orange +tomato -> red +banana -> yellow +EOM + +} + exit ; diff --git a/contrib/perl5/t/lib/db-recno.t b/contrib/perl5/t/lib/db-recno.t index da703c9..276f38b 100755 --- a/contrib/perl5/t/lib/db-recno.t +++ b/contrib/perl5/t/lib/db-recno.t @@ -1,10 +1,10 @@ #!./perl -w BEGIN { - @INC = '../lib' if -d '../lib' ; + unshift @INC, '../lib' if -d '../lib' ; require Config; import Config; if ($Config{'extensions'} !~ /\bDB_File\b/) { - print "1..0\n"; + print "1..0 # Skip: DB_File was not built\n"; exit 0; } } @@ -38,6 +38,49 @@ sub ok return $result ; } +{ + package Redirect ; + use Symbol ; + + sub new + { + my $class = shift ; + my $filename = shift ; + my $fh = gensym ; + open ($fh, ">$filename") || die "Cannot open $filename: $!" ; + my $real_stdout = select($fh) ; + return bless [$fh, $real_stdout ] ; + + } + sub DESTROY + { + my $self = shift ; + close $self->[0] ; + select($self->[1]) ; + } +} + +sub docat +{ + my $file = shift; + local $/ = undef; + open(CAT,$file) || die "Cannot open $file:$!"; + my $result = <CAT>; + close(CAT); + return $result; +} + +sub docat_del +{ + my $file = shift; + local $/ = undef; + open(CAT,$file) || die "Cannot open $file: $!"; + my $result = <CAT>; + close(CAT); + unlink $file ; + return $result; +} + sub bad_one { print STDERR <<EOM unless $bad_ones++ ; @@ -46,7 +89,7 @@ sub bad_one # 53 and 55. # # You can safely ignore the errors if you're never going to use the -# broken functionality (recno databases with a modified bval). +# broken functionality (recno databases with a modified bval). # Otherwise you'll have to upgrade your DB library. # # If you want to use Berkeley DB version 1, then 1.85 and 1.86 are the @@ -56,7 +99,7 @@ sub bad_one EOM } -print "1..78\n"; +print "1..126\n"; my $Dfile = "recno.tmp"; unlink $Dfile ; @@ -209,16 +252,6 @@ untie(@h); unlink $Dfile; -sub docat -{ - my $file = shift; - local $/ = undef; - open(CAT,$file) || die "Cannot open $file:$!"; - my $result = <CAT>; - close(CAT); - return $result; -} - { # Check bval defaults to \n @@ -452,4 +485,355 @@ EOM } +{ + # DBM Filter tests + use strict ; + my (@h, $db) ; + my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + unlink $Dfile; + + sub checkOutput + { + my($fk, $sk, $fv, $sv) = @_ ; + return + $fetch_key eq $fk && $store_key eq $sk && + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; + } + + ok(79, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); + + $db->filter_fetch_key (sub { $fetch_key = $_ }) ; + $db->filter_store_key (sub { $store_key = $_ }) ; + $db->filter_fetch_value (sub { $fetch_value = $_}) ; + $db->filter_store_value (sub { $store_value = $_ }) ; + + $_ = "original" ; + + $h[0] = "joe" ; + # fk sk fv sv + ok(80, checkOutput( "", 0, "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(81, $h[0] eq "joe"); + # fk sk fv sv + ok(82, checkOutput( "", 0, "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(83, $db->FIRSTKEY() == 0) ; + # fk sk fv sv + ok(84, checkOutput( 0, "", "", "")) ; + + # replace the filters, but remember the previous set + my ($old_fk) = $db->filter_fetch_key + (sub { ++ $_ ; $fetch_key = $_ }) ; + my ($old_sk) = $db->filter_store_key + (sub { $_ *= 2 ; $store_key = $_ }) ; + my ($old_fv) = $db->filter_fetch_value + (sub { $_ = "[$_]"; $fetch_value = $_ }) ; + my ($old_sv) = $db->filter_store_value + (sub { s/o/x/g; $store_value = $_ }) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h[1] = "Joe" ; + # fk sk fv sv + ok(85, checkOutput( "", 2, "", "Jxe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(86, $h[1] eq "[Jxe]"); + # fk sk fv sv + ok(87, checkOutput( "", 2, "[Jxe]", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(88, $db->FIRSTKEY() == 1) ; + # fk sk fv sv + ok(89, checkOutput( 1, "", "", "")) ; + + # put the original filters back + $db->filter_fetch_key ($old_fk); + $db->filter_store_key ($old_sk); + $db->filter_fetch_value ($old_fv); + $db->filter_store_value ($old_sv); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h[0] = "joe" ; + ok(90, checkOutput( "", 0, "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(91, $h[0] eq "joe"); + ok(92, checkOutput( "", 0, "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(93, $db->FIRSTKEY() == 0) ; + ok(94, checkOutput( 0, "", "", "")) ; + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h[0] = "joe" ; + ok(95, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(96, $h[0] eq "joe"); + ok(97, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(98, $db->FIRSTKEY() == 0) ; + ok(99, checkOutput( "", "", "", "")) ; + + undef $db ; + untie @h; + unlink $Dfile; +} + +{ + # DBM Filter with a closure + + use strict ; + my (@h, $db) ; + + unlink $Dfile; + ok(100, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); + + my %result = () ; + + sub Closure + { + my ($name) = @_ ; + my $count = 0 ; + my @kept = () ; + + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } + } + + $db->filter_store_key(Closure("store key")) ; + $db->filter_store_value(Closure("store value")) ; + $db->filter_fetch_key(Closure("fetch key")) ; + $db->filter_fetch_value(Closure("fetch value")) ; + + $_ = "original" ; + + $h[0] = "joe" ; + ok(101, $result{"store key"} eq "store key - 1: [0]"); + ok(102, $result{"store value"} eq "store value - 1: [joe]"); + ok(103, ! defined $result{"fetch key"} ); + ok(104, ! defined $result{"fetch value"} ); + ok(105, $_ eq "original") ; + + ok(106, $db->FIRSTKEY() == 0 ) ; + ok(107, $result{"store key"} eq "store key - 1: [0]"); + ok(108, $result{"store value"} eq "store value - 1: [joe]"); + ok(109, $result{"fetch key"} eq "fetch key - 1: [0]"); + ok(110, ! defined $result{"fetch value"} ); + ok(111, $_ eq "original") ; + + $h[7] = "john" ; + ok(112, $result{"store key"} eq "store key - 2: [0 7]"); + ok(113, $result{"store value"} eq "store value - 2: [joe john]"); + ok(114, $result{"fetch key"} eq "fetch key - 1: [0]"); + ok(115, ! defined $result{"fetch value"} ); + ok(116, $_ eq "original") ; + + ok(117, $h[0] eq "joe"); + ok(118, $result{"store key"} eq "store key - 3: [0 7 0]"); + ok(119, $result{"store value"} eq "store value - 2: [joe john]"); + ok(120, $result{"fetch key"} eq "fetch key - 1: [0]"); + ok(121, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(122, $_ eq "original") ; + + undef $db ; + untie @h; + unlink $Dfile; +} + +{ + # DBM Filter recursion detection + use strict ; + my (@h, $db) ; + unlink $Dfile; + + ok(123, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); + + $db->filter_store_key (sub { $_ = $h[0] }) ; + + eval '$h[1] = 1234' ; + ok(124, $@ =~ /^recursion detected in filter_store_key at/ ); + + undef $db ; + untie @h; + unlink $Dfile; +} + + +{ + # Examples from the POD + + my $file = "xyzt" ; + { + my $redirect = new Redirect $file ; + + use strict ; + use DB_File ; + + my $filename = "text" ; + unlink $filename ; + + my @h ; + my $x = tie @h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO + or die "Cannot open file 'text': $!\n" ; + + # Add a few key/value pairs to the file + $h[0] = "orange" ; + $h[1] = "blue" ; + $h[2] = "yellow" ; + + $FA ? push @h, "green", "black" + : $x->push("green", "black") ; + + my $elements = $FA ? scalar @h : $x->length ; + print "The array contains $elements entries\n" ; + + my $last = $FA ? pop @h : $x->pop ; + print "popped $last\n" ; + + $FA ? unshift @h, "white" + : $x->unshift("white") ; + my $first = $FA ? shift @h : $x->shift ; + print "shifted $first\n" ; + + # Check for existence of a key + print "Element 1 Exists with value $h[1]\n" if $h[1] ; + + # use a negative index + print "The last element is $h[-1]\n" ; + print "The 2nd last element is $h[-2]\n" ; + + undef $x ; + untie @h ; + + unlink $filename ; + } + + ok(125, docat_del($file) eq <<'EOM') ; +The array contains 5 entries +popped black +shifted white +Element 1 Exists with value blue +The last element is green +The 2nd last element is yellow +EOM + + my $save_output = "xyzt" ; + { + my $redirect = new Redirect $save_output ; + + use strict ; + use vars qw(@h $H $file $i) ; + use DB_File ; + use Fcntl ; + + $file = "text" ; + + unlink $file ; + + $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0640, $DB_RECNO + or die "Cannot open file $file: $!\n" ; + + # first create a text file to play with + $h[0] = "zero" ; + $h[1] = "one" ; + $h[2] = "two" ; + $h[3] = "three" ; + $h[4] = "four" ; + + + # Print the records in order. + # + # The length method is needed here because evaluating a tied + # array in a scalar context does not return the number of + # elements in the array. + + print "\nORIGINAL\n" ; + foreach $i (0 .. $H->length - 1) { + print "$i: $h[$i]\n" ; + } + + # use the push & pop methods + $a = $H->pop ; + $H->push("last") ; + print "\nThe last record was [$a]\n" ; + + # and the shift & unshift methods + $a = $H->shift ; + $H->unshift("first") ; + print "The first record was [$a]\n" ; + + # Use the API to add a new record after record 2. + $i = 2 ; + $H->put($i, "Newbie", R_IAFTER) ; + + # and a new record before record 1. + $i = 1 ; + $H->put($i, "New One", R_IBEFORE) ; + + # delete record 3 + $H->del(3) ; + + # now print the records in reverse order + print "\nREVERSE\n" ; + for ($i = $H->length - 1 ; $i >= 0 ; -- $i) + { print "$i: $h[$i]\n" } + + # same again, but use the API functions instead + print "\nREVERSE again\n" ; + my ($s, $k, $v) = (0, 0, 0) ; + for ($s = $H->seq($k, $v, R_LAST) ; + $s == 0 ; + $s = $H->seq($k, $v, R_PREV)) + { print "$k: $v\n" } + + undef $H ; + untie @h ; + + unlink $file ; + } + + ok(126, docat_del($save_output) eq <<'EOM') ; + +ORIGINAL +0: zero +1: one +2: two +3: three +4: four + +The last record was [four] +The first record was [zero] + +REVERSE +5: last +4: three +3: Newbie +2: one +1: New One +0: first + +REVERSE again +5: last +4: three +3: Newbie +2: one +1: New One +0: first +EOM + +} + exit ; diff --git a/contrib/perl5/t/lib/dirhand.t b/contrib/perl5/t/lib/dirhand.t index aa7be35..a8683c7 100755 --- a/contrib/perl5/t/lib/dirhand.t +++ b/contrib/perl5/t/lib/dirhand.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; require Config; import Config; if (not $Config{'d_readdir'}) { print "1..0\n"; diff --git a/contrib/perl5/t/lib/dosglob.t b/contrib/perl5/t/lib/dosglob.t index 577d4ea..ea537bf 100755 --- a/contrib/perl5/t/lib/dosglob.t +++ b/contrib/perl5/t/lib/dosglob.t @@ -6,7 +6,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } print "1..10\n"; diff --git a/contrib/perl5/t/lib/dprof.t b/contrib/perl5/t/lib/dprof.t new file mode 100755 index 0000000..4d6f782 --- /dev/null +++ b/contrib/perl5/t/lib/dprof.t @@ -0,0 +1,80 @@ +#!perl + +BEGIN { + chdir( 't' ) if -d 't'; + unshift @INC, '../lib'; +} + +END { + unlink 'tmon.out', 'err'; +} + +use Benchmark qw( timediff timestr ); +use Getopt::Std 'getopts'; +use Config '%Config'; +getopts('vI:p:'); + +# -v Verbose +# -I Add to @INC +# -p Name of perl binary + +@tests = @ARGV ? @ARGV : sort <lib/dprof/*_t lib/dprof/*_v>; # glob-sort, for OS/2 + +$path_sep = $Config{path_sep} || ':'; +$perl5lib = $opt_I || join( $path_sep, @INC ); +$perl = $opt_p || $^X; + +if( $opt_v ){ + print "tests: @tests\n"; + print "perl: $perl\n"; + print "perl5lib: $perl5lib\n"; +} +if( $perl =~ m|^\./| ){ + # turn ./perl into ../perl, because of chdir(t) above. + $perl = ".$perl"; +} +if( ! -f $perl ){ die "Where's Perl?" } + +sub profile { + my $test = shift; + my @results; + local $ENV{PERL5LIB} = $perl5lib; + my $opt_d = '-d:DProf'; + + my $t_start = new Benchmark; + open( R, "$perl $opt_d $test |" ) || warn "$0: Can't run. $!\n"; + @results = <R>; + close R; + my $t_total = timediff( new Benchmark, $t_start ); + + if( $opt_v ){ + print "\n"; + print @results + } + + print timestr( $t_total, 'nop' ), "\n"; +} + + +sub verify { + my $test = shift; + + system $perl, '-I../lib', '-I./lib/dprof', $test, + $opt_v?'-v':'', '-p', $perl; +} + + +$| = 1; +print "1..18\n"; +while( @tests ){ + $test = shift @tests; + if( $test =~ /_t$/i ){ + print "# $test" . '.' x (20 - length $test); + profile $test; + } + else{ + verify $test; + } +} + +unlink("tmon.out"); diff --git a/contrib/perl5/t/lib/dprof/V.pm b/contrib/perl5/t/lib/dprof/V.pm new file mode 100644 index 0000000..7e34da5 --- /dev/null +++ b/contrib/perl5/t/lib/dprof/V.pm @@ -0,0 +1,59 @@ +package V; + +use Getopt::Std 'getopts'; +getopts('vp:d:'); + +require Exporter; +@ISA = 'Exporter'; + +@EXPORT = qw( dprofpp $opt_v $results $expected report @results ); +@EXPORT_OK = qw( notok ok $num ); + +$num = 0; +$results = $expected = ''; +$perl = $opt_p || $^X; +$dpp = $opt_d || '../utils/dprofpp'; + +print "\nperl: $perl\n" if $opt_v; +if( ! -f $perl ){ die "Where's Perl?" } +if( ! -f $dpp ){ die "Where's dprofpp?" } + +sub dprofpp { + my $switches = shift; + + open( D, "$perl -I../lib $dpp $switches 2> err |" ) || warn "$0: Can't run. $!\n"; + @results = <D>; + close D; + + open( D, "<err" ) || warn "$0: Can't open: $!\n"; + @err = <D>; + close D; + push( @results, @err ) if @err; + + $results = qq{@results}; + # ignore Loader (Dyna/Auto etc), leave newline + $results =~ s/^\w+Loader::import//; + $results =~ s/\n /\n/gm; + $results; +} + +sub report { + $num = shift; + my $sub = shift; + my $x; + + $x = &$sub; + $x ? &ok : ¬ok; +} + +sub ok { + print "ok $num\n"; +} + +sub notok { + print "not ok $num\n"; + print "\nResult\n{$results}\n"; + print "Expected\n{$expected}\n"; +} + +1; diff --git a/contrib/perl5/t/lib/dprof/test1_t b/contrib/perl5/t/lib/dprof/test1_t new file mode 100644 index 0000000..d504cd5 --- /dev/null +++ b/contrib/perl5/t/lib/dprof/test1_t @@ -0,0 +1,18 @@ +sub foo { + print "in sub foo\n"; + bar(); +} + +sub bar { + print "in sub bar\n"; +} + +sub baz { + print "in sub baz\n"; + bar(); + foo(); +} + +bar(); +baz(); +foo(); diff --git a/contrib/perl5/t/lib/dprof/test1_v b/contrib/perl5/t/lib/dprof/test1_v new file mode 100644 index 0000000..542a503 --- /dev/null +++ b/contrib/perl5/t/lib/dprof/test1_v @@ -0,0 +1,24 @@ +# perl + +use V; + +dprofpp( '-T' ); +$expected = +qq{main::bar +main::baz + main::bar + main::foo + main::bar +main::foo + main::bar +}; +report 1, sub { $expected eq $results }; + +dprofpp('-TF'); +report 2, sub { $expected eq $results }; + +dprofpp( '-t' ); +report 3, sub { $expected eq $results }; + +dprofpp('-tF'); +report 4, sub { $expected eq $results }; diff --git a/contrib/perl5/t/lib/dprof/test2_t b/contrib/perl5/t/lib/dprof/test2_t new file mode 100644 index 0000000..edc46c5 --- /dev/null +++ b/contrib/perl5/t/lib/dprof/test2_t @@ -0,0 +1,21 @@ +sub foo { + print "in sub foo\n"; + bar(); +} + +sub bar { + print "in sub bar\n"; +} + +sub baz { + print "in sub baz\n"; + bar(); + bar(); + bar(); + foo(); +} + +bar(); +bar(); +baz(); +foo(); diff --git a/contrib/perl5/t/lib/dprof/test2_v b/contrib/perl5/t/lib/dprof/test2_v new file mode 100644 index 0000000..8b775b3 --- /dev/null +++ b/contrib/perl5/t/lib/dprof/test2_v @@ -0,0 +1,36 @@ +# perl + +use V; + +dprofpp( '-T' ); +$expected = +qq{main::bar +main::bar +main::baz + main::bar + main::bar + main::bar + main::foo + main::bar +main::foo + main::bar +}; +report 5, sub { $expected eq $results }; + +dprofpp('-TF'); +report 6, sub { $expected eq $results }; + +dprofpp( '-t' ); +$expected = +qq{main::bar (2x) +main::baz + main::bar (3x) + main::foo + main::bar +main::foo + main::bar +}; +report 7, sub { $expected eq $results }; + +dprofpp('-tF'); +report 8, sub { $expected eq $results }; diff --git a/contrib/perl5/t/lib/dprof/test3_t b/contrib/perl5/t/lib/dprof/test3_t new file mode 100644 index 0000000..a5327f4 --- /dev/null +++ b/contrib/perl5/t/lib/dprof/test3_t @@ -0,0 +1,19 @@ +sub foo { + print "in sub foo\n"; + exit(0); + bar(); +} + +sub bar { + print "in sub bar\n"; +} + +sub baz { + print "in sub baz\n"; + bar(); + foo(); +} + +bar(); +baz(); +foo(); diff --git a/contrib/perl5/t/lib/dprof/test3_v b/contrib/perl5/t/lib/dprof/test3_v new file mode 100644 index 0000000..df7543e --- /dev/null +++ b/contrib/perl5/t/lib/dprof/test3_v @@ -0,0 +1,29 @@ +# perl + +use V; + +dprofpp( '-T' ); +$e1 = $expected = +qq{main::bar +main::baz + main::bar + main::foo +}; +report 9, sub { $expected eq $results }; + +dprofpp('-TF'); +$e2 = $expected = +qq{main::bar +main::baz + main::bar + main::foo +}; +report 10, sub { $expected eq $results }; + +dprofpp( '-t' ); +$expected = $e1; +report 11, sub { 1 }; + +dprofpp('-tF'); +$expected = $e2; +report 12, sub { $expected eq $results }; diff --git a/contrib/perl5/t/lib/dprof/test4_t b/contrib/perl5/t/lib/dprof/test4_t new file mode 100644 index 0000000..7299682 --- /dev/null +++ b/contrib/perl5/t/lib/dprof/test4_t @@ -0,0 +1,24 @@ +sub foo { + print "in sub foo\n"; + bar(); +} + +sub bar { + print "in sub bar\n"; +} + +sub baz { + print "in sub baz\n"; + bar(); + bar(); + bar(); + foo(); +} + +bar(); + +eval { fork }; + +bar(); +baz(); +foo(); diff --git a/contrib/perl5/t/lib/dprof/test4_v b/contrib/perl5/t/lib/dprof/test4_v new file mode 100644 index 0000000..d9677ff --- /dev/null +++ b/contrib/perl5/t/lib/dprof/test4_v @@ -0,0 +1,36 @@ +# perl + +use V; + +dprofpp( '-T' ); +$expected = +qq{main::bar +main::bar +main::baz + main::bar + main::bar + main::bar + main::foo + main::bar +main::foo + main::bar +}; +report 13, sub { $expected eq $results }; + +dprofpp('-TF'); +report 14, sub { $expected eq $results }; + +dprofpp( '-t' ); +$expected = +qq{main::bar (2x) +main::baz + main::bar (3x) + main::foo + main::bar +main::foo + main::bar +}; +report 15, sub { $expected eq $results }; + +dprofpp('-tF'); +report 16, sub { $expected eq $results }; diff --git a/contrib/perl5/t/lib/dprof/test5_t b/contrib/perl5/t/lib/dprof/test5_t new file mode 100644 index 0000000..0b11137 --- /dev/null +++ b/contrib/perl5/t/lib/dprof/test5_t @@ -0,0 +1,25 @@ +# Test that dprof doesn't break +# &bar; used as &bar(@_); + +sub foo1 { + print "in foo1(@_)\n"; + bar(@_); +} +sub foo2 { + print "in foo2(@_)\n"; + &bar; +} +sub bar { + print "in bar(@_)\n"; + if( @_ > 0 ){ + &yeppers; + } +} +sub yeppers { + print "rest easy\n"; +} + + +&foo1( A ); +&foo2( B ); + diff --git a/contrib/perl5/t/lib/dprof/test5_v b/contrib/perl5/t/lib/dprof/test5_v new file mode 100644 index 0000000..9e9298c --- /dev/null +++ b/contrib/perl5/t/lib/dprof/test5_v @@ -0,0 +1,15 @@ +# perl + +use V; + +dprofpp( '-T' ); +$expected = +qq{main::foo1 + main::bar + main::yeppers +main::foo2 + main::bar + main::yeppers +}; +report 17, sub { $expected eq $results }; + diff --git a/contrib/perl5/t/lib/dprof/test6_t b/contrib/perl5/t/lib/dprof/test6_t new file mode 100644 index 0000000..7b8bf4a --- /dev/null +++ b/contrib/perl5/t/lib/dprof/test6_t @@ -0,0 +1,29 @@ +sub foo { + my $x; + my $y; + print "in sub foo\n"; + for( $x = 1; $x < 100; ++$x ){ + bar(); + for( $y = 1; $y < 100; ++$y ){ + } + } +} + +sub bar { + my $x; + print "in sub bar\n"; + for( $x = 1; $x < 100; ++$x ){ + } + die "bar exiting"; +} + +sub baz { + print "in sub baz\n"; + eval { bar(); }; + eval { foo(); }; +} + +eval { bar(); }; +baz(); +eval { foo(); }; + diff --git a/contrib/perl5/t/lib/dprof/test6_v b/contrib/perl5/t/lib/dprof/test6_v new file mode 100644 index 0000000..2f651ea --- /dev/null +++ b/contrib/perl5/t/lib/dprof/test6_v @@ -0,0 +1,16 @@ +# perl + +use V; + +dprofpp( '-T' ); +$expected = +qq{main::bar +main::baz + main::bar + main::foo + main::bar +main::foo + main::bar +}; +report 18, sub { $expected eq $results }; + diff --git a/contrib/perl5/t/lib/dumper-ovl.t b/contrib/perl5/t/lib/dumper-ovl.t index db4a5d9..8c095e5 100755 --- a/contrib/perl5/t/lib/dumper-ovl.t +++ b/contrib/perl5/t/lib/dumper-ovl.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } use Data::Dumper; diff --git a/contrib/perl5/t/lib/dumper.t b/contrib/perl5/t/lib/dumper.t index 8c8dc40..3167535 100755 --- a/contrib/perl5/t/lib/dumper.t +++ b/contrib/perl5/t/lib/dumper.t @@ -5,7 +5,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } use Data::Dumper; @@ -22,6 +22,16 @@ sub TEST { my $string = shift; my $t = eval $string; ++$TNUM; + $t =~ s/([A-Z]+)\(0x[0-9a-f]+\)/$1(0xdeadbeef)/g + if ($WANT =~ /deadbeef/); + if ($Is_ebcdic) { + # these data need massaging with non ascii character sets + # because of hashing order differences + $WANT = join("\n",sort(split(/\n/,$WANT))); + $WANT =~ s/\,$//mg; + $t = join("\n",sort(split(/\n/,$t))); + $t =~ s/\,$//mg; + } print( ($t eq $WANT and not $@) ? "ok $TNUM\n" : "not ok $TNUM\n--Expected--\n$WANT\n--Got--\n$@$t\n"); @@ -31,17 +41,26 @@ sub TEST { $t = eval $string; ++$TNUM; + $t =~ s/([A-Z]+)\(0x[0-9a-f]+\)/$1(0xdeadbeef)/g + if ($WANT =~ /deadbeef/); + if ($Is_ebcdic) { + # here too there are hashing order differences + $WANT = join("\n",sort(split(/\n/,$WANT))); + $WANT =~ s/\,$//mg; + $t = join("\n",sort(split(/\n/,$t))); + $t =~ s/\,$//mg; + } print( ($t eq $WANT and not $@) ? "ok $TNUM\n" : "not ok $TNUM\n--Expected--\n$WANT\n--Got--\n$@$t\n"); } if (defined &Data::Dumper::Dumpxs) { print "### XS extension loaded, will run XS tests\n"; - $TMAX = 162; $XS = 1; + $TMAX = 186; $XS = 1; } else { print "### XS extensions not loaded, will NOT run XS tests\n"; - $TMAX = 81; $XS = 0; + $TMAX = 93; $XS = 0; } print "1..$TMAX\n"; @@ -236,20 +255,11 @@ EOT ############# 43 ## -if (!$Is_ebcdic) { $WANT = <<'EOT'; #$VAR1 = { # "abc\0'\efg" => "mno\0" #}; EOT -} -else { -$WANT = <<'EOT'; -#$VAR1 = { -# "\201\202\203\340\360'\340\205\206\207" => "\224\225\226\340\360" -#}; -EOT -} $foo = { "abc\000\'\efg" => "mno\000" }; { @@ -291,11 +301,11 @@ EOT # #0 # 10, # #1 -# '', +# do{my $o}, # #2 # { # 'a' => 1, -# 'b' => '', +# 'b' => do{my $o}, # 'c' => [], # 'd' => {} # } @@ -321,10 +331,10 @@ EOT #*::foo = \5; #*::foo = [ # 10, -# '', +# do{my $o}, # { # 'a' => 1, -# 'b' => '', +# 'b' => do{my $o}, # 'c' => [], # 'd' => {} # } @@ -354,7 +364,7 @@ EOT #*::foo = \@bar; #*::foo = { # 'a' => 1, -# 'b' => '', +# 'b' => do{my $o}, # 'c' => [], # 'd' => {} #}; @@ -381,7 +391,7 @@ EOT #*::foo = $bar; #*::foo = { # 'a' => 1, -# 'b' => '', +# 'b' => do{my $o}, # 'c' => [], # 'd' => {} #}; @@ -455,7 +465,6 @@ EOT ############# 85 ## -if (!$Is_ebcdic) { $WANT = <<'EOT'; #%kennels = ( # First => \'Fido', @@ -468,21 +477,6 @@ if (!$Is_ebcdic) { #); #%mutts = %kennels; EOT -} -else { - $WANT = <<'EOT'; -#%kennels = ( -# Second => \'Wags', -# First => \'Fido' -#); -#@dogs = ( -# ${$kennels{First}}, -# ${$kennels{Second}}, -# \%kennels -#); -#%mutts = %kennels; -EOT -} TEST q( $d = Data::Dumper->new([\\%kennel, \\@dogs, $mutts], @@ -510,7 +504,6 @@ EOT ############# 97 ## -if (!$Is_ebcdic) { $WANT = <<'EOT'; #%kennels = ( # First => \'Fido', @@ -523,21 +516,7 @@ if (!$Is_ebcdic) { #); #%mutts = %kennels; EOT -} -else { - $WANT = <<'EOT'; -#%kennels = ( -# Second => \'Wags', -# First => \'Fido' -#); -#@dogs = ( -# ${$kennels{First}}, -# ${$kennels{Second}}, -# \%kennels -#); -#%mutts = %kennels; -EOT -} + TEST q($d->Reset; $d->Dump); if ($XS) { @@ -546,8 +525,7 @@ EOT ############# 103 ## -if (!$Is_ebcdic) { - $WANT = <<'EOT'; + $WANT = <<'EOT'; #@dogs = ( # 'Fido', # 'Wags', @@ -559,21 +537,6 @@ if (!$Is_ebcdic) { #%kennels = %{$dogs[2]}; #%mutts = %{$dogs[2]}; EOT -} -else { - $WANT = <<'EOT'; -#@dogs = ( -# 'Fido', -# 'Wags', -# { -# Second => \$dogs[1], -# First => \$dogs[0] -# } -#); -#%kennels = %{$dogs[2]}; -#%mutts = %{$dogs[2]}; -EOT -} TEST q( $d = Data::Dumper->new([\\@dogs, \\%kennel, $mutts], @@ -597,7 +560,6 @@ EOT ############# 115 ## -if (!$Is_ebcdic) { $WANT = <<'EOT'; #@dogs = ( # 'Fido', @@ -612,23 +574,6 @@ if (!$Is_ebcdic) { # Second => \'Wags' #); EOT -} -else { - $WANT = <<'EOT'; -#@dogs = ( -# 'Fido', -# 'Wags', -# { -# Second => \'Wags', -# First => \'Fido' -# } -#); -#%kennels = ( -# Second => \'Wags', -# First => \'Fido' -#); -EOT -} TEST q( $d = Data::Dumper->new( [\@dogs, \%kennel], [qw(*dogs *kennels)] ); @@ -695,7 +640,7 @@ TEST q(Data::Dumper->new([\&z,$c],['*a','*c'])->Seen({'*b' => \&z})->Dumpxs;) $WANT = <<'EOT'; #@a = ( # undef, -# '' +# do{my $o} #); #$a[1] = \$a[0]; EOT @@ -732,7 +677,7 @@ TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dumpxs;) # { # a => \[ # { -# c => '' +# c => do{my $o} # }, # { # d => \[] @@ -778,3 +723,79 @@ TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Purity(1)->Dump;); TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Purity(1)->Dumpxs;) if $XS; } + +{ + $f = "pearl"; + $e = [ $f ]; + $d = { 'e' => $e }; + $c = [ $d ]; + $b = { 'c' => $c }; + $a = { 'b' => $b }; + +############# 163 +## + $WANT = <<'EOT'; +#$a = { +# b => { +# c => [ +# { +# e => 'ARRAY(0xdeadbeef)' +# } +# ] +# } +#}; +#$b = $a->{b}; +#$c = $a->{b}{c}; +EOT + +TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(4)->Dump;); +TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(4)->Dumpxs;) + if $XS; + +############# 169 +## + $WANT = <<'EOT'; +#$a = { +# b => 'HASH(0xdeadbeef)' +#}; +#$b = $a->{b}; +#$c = [ +# 'HASH(0xdeadbeef)' +#]; +EOT + +TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(1)->Dump;); +TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(1)->Dumpxs;) + if $XS; +} + +{ + $a = \$a; + $b = [$a]; + +############# 175 +## + $WANT = <<'EOT'; +#$b = [ +# \$b->[0] +#]; +EOT + +TEST q(Data::Dumper->new([$b],['b'])->Purity(0)->Dump;); +TEST q(Data::Dumper->new([$b],['b'])->Purity(0)->Dumpxs;) + if $XS; + +############# 181 +## + $WANT = <<'EOT'; +#$b = [ +# \do{my $o} +#]; +#${$b->[0]} = $b->[0]; +EOT + + +TEST q(Data::Dumper->new([$b],['b'])->Purity(1)->Dump;); +TEST q(Data::Dumper->new([$b],['b'])->Purity(1)->Dumpxs;) + if $XS; +} diff --git a/contrib/perl5/t/lib/english.t b/contrib/perl5/t/lib/english.t index 9691229..dba68db 100755 --- a/contrib/perl5/t/lib/english.t +++ b/contrib/perl5/t/lib/english.t @@ -2,10 +2,10 @@ print "1..16\n"; -BEGIN { @INC = '../lib' } +BEGIN { unshift @INC, '../lib' } use English; use Config; -my $threads = $Config{'usethreads'} || 0; +my $threads = $Config{'use5005threads'} || 0; print $PID == $$ ? "ok 1\n" : "not ok 1\n"; diff --git a/contrib/perl5/t/lib/env-array.t b/contrib/perl5/t/lib/env-array.t new file mode 100755 index 0000000..d90d892 --- /dev/null +++ b/contrib/perl5/t/lib/env-array.t @@ -0,0 +1,100 @@ +#!./perl + +$| = 1; + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +if ($^O eq 'VMS') { + print "1..11\n"; + foreach (1..11) { print "ok $_ # skipped for VMS\n"; } + exit 0; +} + +use Env qw(@FOO); +use vars qw(@BAR); + +sub array_equal +{ + my ($a, $b) = @_; + return 0 unless scalar(@$a) == scalar(@$b); + for my $i (0..scalar(@$a) - 1) { + return 0 unless $a->[$i] eq $b->[$i]; + } + return 1; +} + +sub test +{ + my ($desc, $code) = @_; + + &$code; + + print "# $desc...\n"; + print "# FOO = (", join(", ", @FOO), ")\n"; + print "# BAR = (", join(", ", @BAR), ")\n"; + + if (defined $check) { print "not " unless &$check; } + else { print "not " unless array_equal(\@FOO, \@BAR); } + + print "ok ", ++$i, "\n"; +} + +print "1..11\n"; + +test "Assignment", sub { + @FOO = qw(a B c); + @BAR = qw(a B c); +}; + +test "Storing", sub { + $FOO[1] = 'b'; + $BAR[1] = 'b'; +}; + +test "Truncation", sub { + $#FOO = 0; + $#BAR = 0; +}; + +test "Push", sub { + push @FOO, 'b', 'c'; + push @BAR, 'b', 'c'; +}; + +test "Pop", sub { + pop @FOO; + pop @BAR; +}; + +test "Shift", sub { + shift @FOO; + shift @BAR; +}; + +test "Push", sub { + push @FOO, 'c'; + push @BAR, 'c'; +}; + +test "Unshift", sub { + unshift @FOO, 'a'; + unshift @BAR, 'a'; +}; + +test "Reverse", sub { + @FOO = reverse @FOO; + @BAR = reverse @BAR; +}; + +test "Sort", sub { + @FOO = sort @FOO; + @BAR = sort @BAR; +}; + +test "Splice", sub { + splice @FOO, 1, 1, 'B'; + splice @BAR, 1, 1, 'B'; +}; diff --git a/contrib/perl5/t/lib/env.t b/contrib/perl5/t/lib/env.t index 5a82207..2573164 100755 --- a/contrib/perl5/t/lib/env.t +++ b/contrib/perl5/t/lib/env.t @@ -2,17 +2,24 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } BEGIN { $ENV{FOO} = "foo"; + $ENV{BAR} = "bar"; } -use Env qw(FOO); +use Env qw(FOO $BAR); $FOO .= "/bar"; +$BAR .= "/baz"; + +print "1..2\n"; -print "1..1\n"; print "not " if $FOO ne 'foo/bar'; print "ok 1\n"; + +print "not " if $BAR ne 'bar/baz'; +print "ok 2\n"; + diff --git a/contrib/perl5/t/lib/errno.t b/contrib/perl5/t/lib/errno.t index 361723f..6320f6b 100755 --- a/contrib/perl5/t/lib/errno.t +++ b/contrib/perl5/t/lib/errno.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } } diff --git a/contrib/perl5/t/lib/fatal.t b/contrib/perl5/t/lib/fatal.t index fb3757f..4013fbd 100755 --- a/contrib/perl5/t/lib/fatal.t +++ b/contrib/perl5/t/lib/fatal.t @@ -3,11 +3,11 @@ BEGIN { chdir 't' if -d 't'; unshift @INC, '../lib'; - print "1..9\n"; + print "1..15\n"; } use strict; -use Fatal qw(open); +use Fatal qw(open close :void opendir); my $i = 1; eval { open FOO, '<lkjqweriuapofukndajsdlfjnvcvn' }; @@ -20,8 +20,17 @@ for ('$foo', "'$foo'", "*$foo", "\\*$foo") { print "not " if $@; print "ok $i\n"; ++$i; - print "not " unless scalar(<FOO>) =~ m|^#!./perl|; + print "not " if $@ or scalar(<$foo>) !~ m|^#!./perl|; + print "ok $i\n"; ++$i; + eval qq{ close FOO }; print "not " if $@; print "ok $i\n"; ++$i; - close FOO; } + +eval { opendir FOO, 'lkjqweriuapofukndajsdlfjnvcvn' }; +print "not " unless $@ =~ /^Can't open/; +print "ok $i\n"; ++$i; + +eval { my $a = opendir FOO, 'lkjqweriuapofukndajsdlfjnvcvn' }; +print "not " if $@ =~ /^Can't open/; +print "ok $i\n"; ++$i; diff --git a/contrib/perl5/t/lib/fields.t b/contrib/perl5/t/lib/fields.t index 139e469..7709ee5 100755 --- a/contrib/perl5/t/lib/fields.t +++ b/contrib/perl5/t/lib/fields.t @@ -4,7 +4,7 @@ my $w; BEGIN { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; $SIG{__WARN__} = sub { if ($_[0] =~ /^Hides field 'b1' in base class/) { $w++; @@ -15,6 +15,7 @@ BEGIN { } use strict; +use warnings; use vars qw($DEBUG); package B1; @@ -56,10 +57,17 @@ package Foo::Bar::Baz; use base 'Foo::Bar'; use fields qw(foo bar baz); +# Test repeatability for when modules get reloaded. +package B1; +use fields qw(b1 b2 b3); + +package D3; +use base 'B2'; +use fields qw(b1 d1 _b1 _d1); # hide b1 + package main; -sub fstr -{ +sub fstr { my $h = shift; my @tmp; for my $k (sort {$h->{$a} <=> $h->{$b}} keys %$h) { @@ -82,7 +90,7 @@ my %expect = ( 'Foo::Bar::Baz' => 'b1:1,b2:2,b3:3,foo:4,bar:5,baz:6', ); -print "1..", int(keys %expect)+3, "\n"; +print "1..", int(keys %expect)+13, "\n"; my $testno = 0; while (my($class, $exp) = each %expect) { no strict 'refs'; @@ -106,7 +114,59 @@ print "ok ", ++$testno, "\n"; # We should get compile time failures field name typos eval q(my D3 $obj3 = $obj2; $obj3->{notthere} = ""); -print "not " unless $@ && $@ =~ /^No such field "notthere"/; +print "not " unless $@ && $@ =~ /^No such pseudo-hash field "notthere"/; +print "ok ", ++$testno, "\n"; + +# Slices +@$obj1{"_b1", "b1"} = (17, 29); +print "not " unless "@$obj1[1,2]" eq "17 29"; +print "ok ", ++$testno, "\n"; +@$obj1[1,2] = (44,28); +print "not " unless "@$obj1{'b1','_b1','b1'}" eq "28 44 28"; +print "ok ", ++$testno, "\n"; + +my $ph = fields::phash(a => 1, b => 2, c => 3); +print "not " unless fstr($ph) eq 'a:1,b:2,c:3'; +print "ok ", ++$testno, "\n"; + +$ph = fields::phash([qw/a b c/], [1, 2, 3]); +print "not " unless fstr($ph) eq 'a:1,b:2,c:3'; +print "ok ", ++$testno, "\n"; + +$ph = fields::phash([qw/a b c/], [1]); +print "not " if exists $ph->{b} or exists $ph->{c} or !exists $ph->{a}; +print "ok ", ++$testno, "\n"; + +eval '$ph = fields::phash("odd")'; +print "not " unless $@ && $@ =~ /^Odd number of/; print "ok ", ++$testno, "\n"; #fields::_dump(); + +# check if fields autovivify +{ + package Foo; + use fields qw(foo bar); + sub new { bless [], $_[0]; } + + package main; + my Foo $a = Foo->new(); + $a->{foo} = ['a', 'ok ' . ++$testno, 'c']; + $a->{bar} = { A => 'ok ' . ++$testno }; + print $a->{foo}[1], "\n"; + print $a->{bar}->{A}, "\n"; +} + +# check if fields autovivify +{ + package Bar; + use fields qw(foo bar); + sub new { return fields::new($_[0]) } + + package main; + my Bar $a = Bar::->new(); + $a->{foo} = ['a', 'ok ' . ++$testno, 'c']; + $a->{bar} = { A => 'ok ' . ++$testno }; + print $a->{foo}[1], "\n"; + print $a->{bar}->{A}, "\n"; +} diff --git a/contrib/perl5/t/lib/filecache.t b/contrib/perl5/t/lib/filecache.t index a97fdd5..019f374 100755 --- a/contrib/perl5/t/lib/filecache.t +++ b/contrib/perl5/t/lib/filecache.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } print "1..1\n"; diff --git a/contrib/perl5/t/lib/filecopy.t b/contrib/perl5/t/lib/filecopy.t index 329931f..b6fcbea 100755 --- a/contrib/perl5/t/lib/filecopy.t +++ b/contrib/perl5/t/lib/filecopy.t @@ -2,89 +2,108 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } -print "1..11\n"; - $| = 1; +my @pass = (0,1); +my $tests = 11; +printf "1..%d\n", $tests * scalar(@pass); + use File::Copy; -# First we create a file -open(F, ">file-$$") or die; -binmode F; # for DOSISH platforms, because test 3 copies to stdout -print F "ok 3\n"; -close F; - -copy "file-$$", "copy-$$"; - -open(F, "copy-$$") or die; -$foo = <F>; -close(F); - -print "not " if -s "file-$$" != -s "copy-$$"; -print "ok 1\n"; - -print "not " unless $foo eq "ok 3\n"; -print "ok 2\n"; - -binmode STDOUT unless $^O eq 'VMS'; # Copy::copy works in binary mode -copy "copy-$$", \*STDOUT; -unlink "copy-$$" or die "unlink: $!"; - -open(F,"file-$$"); -copy(*F, "copy-$$"); -open(R, "copy-$$") or die "open copy-$$: $!"; $foo = <R>; close(R); -print "not " unless $foo eq "ok 3\n"; -print "ok 4\n"; -unlink "copy-$$" or die "unlink: $!"; -open(F,"file-$$"); -copy(\*F, "copy-$$"); -close(F) or die "close: $!"; -open(R, "copy-$$") or die; $foo = <R>; close(R) or die "close: $!"; -print "not " unless $foo eq "ok 3\n"; -print "ok 5\n"; -unlink "copy-$$" or die "unlink: $!"; - -require IO::File; -$fh = IO::File->new(">copy-$$") or die "Cannot open copy-$$:$!"; -binmode $fh or die; -copy("file-$$",$fh); -$fh->close or die "close: $!"; -open(R, "copy-$$") or die; $foo = <R>; close(R); -print "# foo=`$foo'\nnot " unless $foo eq "ok 3\n"; -print "ok 6\n"; -unlink "copy-$$" or die "unlink: $!"; -require FileHandle; -my $fh = FileHandle->new(">copy-$$") or die "Cannot open copy-$$:$!"; -binmode $fh or die; -copy("file-$$",$fh); -$fh->close; -open(R, "copy-$$") or die; $foo = <R>; close(R); -print "not " unless $foo eq "ok 3\n"; -print "ok 7\n"; -unlink "file-$$" or die "unlink: $!"; - -print "# moved missing file.\nnot " if move("file-$$", "copy-$$"); -print "# target disappeared.\nnot " if not -e "copy-$$"; -print "ok 8\n"; - -move "copy-$$", "file-$$" or print "# move did not succeed.\n"; -print "# not moved: $!\nnot " unless -e "file-$$" and not -e "copy-$$"; -open(R, "file-$$") or die; $foo = <R>; close(R); -print "# foo=`$foo'\nnot " unless $foo eq "ok 3\n"; -print "ok 9\n"; - -copy "file-$$", "lib"; -open(R, "lib/file-$$") or die; $foo = <R>; close(R); -print "not " unless $foo eq "ok 3\n"; -print "ok 10\n"; -unlink "lib/file-$$" or die "unlink: $!"; - -move "file-$$", "lib"; -open(R, "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R); -print "not " unless $foo eq "ok 3\n" and not -e "file-$$";; -print "ok 11\n"; -unlink "lib/file-$$" or die "unlink: $!"; +for my $pass (@pass) { + + require File::Copy; + + my $loopconst = $pass*$tests; + + # First we create a file + open(F, ">file-$$") or die; + binmode F; # for DOSISH platforms, because test 3 copies to stdout + printf F "ok %d\n", 3 + $loopconst; + close F; + + copy "file-$$", "copy-$$"; + + open(F, "copy-$$") or die; + $foo = <F>; + close(F); + + print "not " if -s "file-$$" != -s "copy-$$"; + printf "ok %d\n", 1 + $loopconst; + + print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; + printf "ok %d\n", 2+$loopconst; + + binmode STDOUT unless $^O eq 'VMS'; # Copy::copy works in binary mode + copy "copy-$$", \*STDOUT; + unlink "copy-$$" or die "unlink: $!"; + + open(F,"file-$$"); + copy(*F, "copy-$$"); + open(R, "copy-$$") or die "open copy-$$: $!"; $foo = <R>; close(R); + print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; + printf "ok %d\n", 4+$loopconst; + unlink "copy-$$" or die "unlink: $!"; + open(F,"file-$$"); + copy(\*F, "copy-$$"); + close(F) or die "close: $!"; + open(R, "copy-$$") or die; $foo = <R>; close(R) or die "close: $!"; + print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; + printf "ok %d\n", 5+$loopconst; + unlink "copy-$$" or die "unlink: $!"; + + require IO::File; + $fh = IO::File->new(">copy-$$") or die "Cannot open copy-$$:$!"; + binmode $fh or die; + copy("file-$$",$fh); + $fh->close or die "close: $!"; + open(R, "copy-$$") or die; $foo = <R>; close(R); + print "# foo=`$foo'\nnot " unless $foo eq sprintf "ok %d\n", 3+$loopconst; + printf "ok %d\n", 6+$loopconst; + unlink "copy-$$" or die "unlink: $!"; + require FileHandle; + my $fh = FileHandle->new(">copy-$$") or die "Cannot open copy-$$:$!"; + binmode $fh or die; + copy("file-$$",$fh); + $fh->close; + open(R, "copy-$$") or die; $foo = <R>; close(R); + print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; + printf "ok %d\n", 7+$loopconst; + unlink "file-$$" or die "unlink: $!"; + + print "# moved missing file.\nnot " if move("file-$$", "copy-$$"); + print "# target disappeared.\nnot " if not -e "copy-$$"; + printf "ok %d\n", 8+$loopconst; + + move "copy-$$", "file-$$" or print "# move did not succeed.\n"; + print "# not moved: $!\nnot " unless -e "file-$$" and not -e "copy-$$"; + open(R, "file-$$") or die; $foo = <R>; close(R); + print "# foo=`$foo'\nnot " unless $foo eq sprintf "ok %d\n", 3+$loopconst; + printf "ok %d\n", 9+$loopconst; + + copy "file-$$", "lib"; + open(R, "lib/file-$$") or die; $foo = <R>; close(R); + print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; + printf "ok %d\n", 10+$loopconst; + unlink "lib/file-$$" or die "unlink: $!"; + + move "file-$$", "lib"; + open(R, "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R); + print "not " unless $foo eq sprintf("ok %d\n", 3+$loopconst) + and not -e "file-$$";; + printf "ok %d\n", 11+$loopconst; + unlink "lib/file-$$" or die "unlink: $!"; + + # warn sprintf "INC->".$INC{"File/Copy.pm"}; + delete $INC{"File/Copy.pm"}; + +} + +END { + 1 while unlink "file-$$"; + 1 while unlink "lib/file-$$"; +} diff --git a/contrib/perl5/t/lib/filefind.t b/contrib/perl5/t/lib/filefind.t index cd2e977..e9a2916 100755 --- a/contrib/perl5/t/lib/filefind.t +++ b/contrib/perl5/t/lib/filefind.t @@ -1,14 +1,168 @@ -#!./perl +####!./perl + + +my %Expect; +my $symlink_exists = eval { symlink("",""); 1 }; BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } -print "1..2\n"; +if ( $symlink_exists ) { print "1..117\n"; } +else { print "1..61\n"; } use File::Find; -# hope we will eventually find ourself find(sub { print "ok 1\n" if $_ eq 'filefind.t'; }, "."); finddepth(sub { print "ok 2\n" if $_ eq 'filefind.t'; }, "."); + + +my $case = 2; + +END { + unlink 'fa/fa_ord','fa/fsl','fa/faa/faa_ord', + 'fa/fab/fab_ord','fa/fab/faba/faba_ord','fb/fb_ord','fb/fba/fba_ord'; + rmdir 'fa/faa'; + rmdir 'fa/fab/faba'; + rmdir 'fa/fab'; + rmdir 'fa'; + rmdir 'fb/fba'; + rmdir 'fb'; + chdir '..'; + rmdir 'for_find'; +} + +sub Check($) { + $case++; + if ($_[0]) { print "ok $case\n"; } + else { print "not ok $case\n"; } +} + +sub CheckDie($) { + $case++; + if ($_[0]) { print "ok $case\n"; } + else { print "not ok $case\n $!\n"; exit 0; } +} + +sub touch { + CheckDie( open(my $T,'>',$_[0]) ); +} + +sub MkDir($$) { + CheckDie( mkdir($_[0],$_[1]) ); +} + +sub wanted { + print "# '$_' => 1\n"; + s#\.$## if ($^O eq 'VMS' && $_ ne '.'); + Check( $Expect{$_} ); + delete $Expect{$_}; + $File::Find::prune=1 if $_ eq 'faba'; +} + +sub dn_wanted { + my $n = $File::Find::name; + $n =~ s#\.$## if ($^O eq 'VMS' && $n ne '.'); + print "# '$n' => 1\n"; + my $i = rindex($n,'/'); + my $OK = exists($Expect{$n}); + if ( $OK ) { + $OK= exists($Expect{substr($n,0,$i)}) if $i >= 0; + } + Check($OK); + delete $Expect{$n}; +} + +sub d_wanted { + print "# '$_' => 1\n"; + s#\.$## if ($^O eq 'VMS' && $_ ne '.'); + my $i = rindex($_,'/'); + my $OK = exists($Expect{$_}); + if ( $OK ) { + $OK= exists($Expect{substr($_,0,$i)}) if $i >= 0; + } + Check($OK); + delete $Expect{$_}; +} + +MkDir( 'for_find',0770 ); +CheckDie(chdir(for_find)); +MkDir( 'fa',0770 ); +MkDir( 'fb',0770 ); +touch('fb/fb_ord'); +MkDir( 'fb/fba',0770 ); +touch('fb/fba/fba_ord'); +CheckDie( symlink('../fb','fa/fsl') ) if $symlink_exists; +touch('fa/fa_ord'); + +MkDir( 'fa/faa',0770 ); +touch('fa/faa/faa_ord'); +MkDir( 'fa/fab',0770 ); +touch('fa/fab/fab_ord'); +MkDir( 'fa/fab/faba',0770 ); +touch('fa/fab/faba/faba_ord'); + +%Expect = ('.' => 1, 'fsl' => 1, 'fa_ord' => 1, 'fab' => 1, 'fab_ord' => 1, + 'faba' => 1, 'faa' => 1, 'faa_ord' => 1); +delete $Expect{'fsl'} unless $symlink_exists; +File::Find::find( {wanted => \&wanted, },'fa' ); +Check( scalar(keys %Expect) == 0 ); + +%Expect=('fa' => 1, 'fa/fsl' => 1, 'fa/fa_ord' => 1, 'fa/fab' => 1, + 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, + 'fa/fab/faba/faba_ord' => 1, 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); +delete $Expect{'fa/fsl'} unless $symlink_exists; +File::Find::find( {wanted => \&wanted, no_chdir => 1},'fa' ); + +Check( scalar(keys %Expect) == 0 ); + +%Expect=('.' => 1, './fa' => 1, './fa/fsl' => 1, './fa/fa_ord' => 1, './fa/fab' => 1, + './fa/fab/fab_ord' => 1, './fa/fab/faba' => 1, + './fa/fab/faba/faba_ord' => 1, './fa/faa' => 1, './fa/faa/faa_ord' => 1, + './fb' => 1, './fb/fba' => 1, './fb/fba/fba_ord' => 1, './fb/fb_ord' => 1); +delete $Expect{'./fa/fsl'} unless $symlink_exists; +File::Find::finddepth( {wanted => \&dn_wanted },'.' ); +Check( scalar(keys %Expect) == 0 ); + +%Expect=('.' => 1, './fa' => 1, './fa/fsl' => 1, './fa/fa_ord' => 1, './fa/fab' => 1, + './fa/fab/fab_ord' => 1, './fa/fab/faba' => 1, + './fa/fab/faba/faba_ord' => 1, './fa/faa' => 1, './fa/faa/faa_ord' => 1, + './fb' => 1, './fb/fba' => 1, './fb/fba/fba_ord' => 1, './fb/fb_ord' => 1); +delete $Expect{'./fa/fsl'} unless $symlink_exists; +File::Find::finddepth( {wanted => \&d_wanted, no_chdir => 1 },'.' ); +Check( scalar(keys %Expect) == 0 ); + +if ( $symlink_exists ) { + %Expect=('.' => 1, 'fa_ord' => 1, 'fsl' => 1, 'fb_ord' => 1, 'fba' => 1, + 'fba_ord' => 1, 'fab' => 1, 'fab_ord' => 1, 'faba' => 1, 'faa' => 1, + 'faa_ord' => 1); + + File::Find::find( {wanted => \&wanted, follow_fast => 1},'fa' ); + Check( scalar(keys %Expect) == 0 ); + + %Expect=('fa' => 1, 'fa/fa_ord' => 1, 'fa/fsl' => 1, 'fa/fsl/fb_ord' => 1, + 'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1, + 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1, + 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); + File::Find::find( {wanted => \&wanted, follow_fast => 1, no_chdir => 1},'fa' ); + Check( scalar(keys %Expect) == 0 ); + + %Expect=('fa' => 1, 'fa/fa_ord' => 1, 'fa/fsl' => 1, 'fa/fsl/fb_ord' => 1, + 'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1, + 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1, + 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); + + File::Find::finddepth( {wanted => \&dn_wanted, follow_fast => 1},'fa' ); + Check( scalar(keys %Expect) == 0 ); + + %Expect=('fa' => 1, 'fa/fa_ord' => 1, 'fa/fsl' => 1, 'fa/fsl/fb_ord' => 1, + 'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1, + 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1, + 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); + + File::Find::finddepth( {wanted => \&d_wanted, follow_fast => 1, no_chdir => 1},'fa' ); + Check( scalar(keys %Expect) == 0 ); +} + +print "# of cases: $case\n"; diff --git a/contrib/perl5/t/lib/filefunc.t b/contrib/perl5/t/lib/filefunc.t new file mode 100755 index 0000000..46a1e35 --- /dev/null +++ b/contrib/perl5/t/lib/filefunc.t @@ -0,0 +1,17 @@ +#!./perl + +BEGIN { + $^O = ''; + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +print "1..1\n"; + +use File::Spec::Functions; + +if (catfile('a','b','c') eq 'a/b/c') { + print "ok 1\n"; +} else { + print "not ok 1\n"; +} diff --git a/contrib/perl5/t/lib/filehand.t b/contrib/perl5/t/lib/filehand.t index b8ec95f..22cff0e 100755 --- a/contrib/perl5/t/lib/filehand.t +++ b/contrib/perl5/t/lib/filehand.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { print "1..0\n"; @@ -72,7 +72,8 @@ if ($^O eq 'dos') ($rd,$wr) = FileHandle::pipe; -if ($^O eq 'VMS' || $^O eq 'os2' || $^O eq 'amigaos' || $^O eq 'MSWin32') { +if ($^O eq 'VMS' || $^O eq 'os2' || $^O eq 'amigaos' || $^O eq 'MSWin32' || + $Config{d_fork} ne 'define') { $wr->autoflush; $wr->printf("ok %d\n",11); print $rd->getline; diff --git a/contrib/perl5/t/lib/filepath.t b/contrib/perl5/t/lib/filepath.t index c3bf4a4..5628d0c 100755 --- a/contrib/perl5/t/lib/filepath.t +++ b/contrib/perl5/t/lib/filepath.t @@ -2,14 +2,14 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use File::Path; use strict; my $count = 0; -$^W = 1; +use warnings; print "1..4\n"; diff --git a/contrib/perl5/t/lib/filespec.t b/contrib/perl5/t/lib/filespec.t index ca22d3e..da52ec5 100755 --- a/contrib/perl5/t/lib/filespec.t +++ b/contrib/perl5/t/lib/filespec.t @@ -3,41 +3,377 @@ BEGIN { $^O = ''; chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } -print "1..4\n"; +# Each element in this array is a single test. Storing them this way makes +# maintenance easy, and should be OK since perl should be pretty functional +# before these tests are run. -use File::Spec; +@tests = ( +# Function Expected +[ "Unix->catfile('a','b','c')", 'a/b/c' ], +[ "Unix->splitpath('file')", ',,file' ], +[ "Unix->splitpath('/d1/d2/d3/')", ',/d1/d2/d3/,' ], +[ "Unix->splitpath('d1/d2/d3/')", ',d1/d2/d3/,' ], +[ "Unix->splitpath('/d1/d2/d3/.')", ',/d1/d2/d3/.,' ], +[ "Unix->splitpath('/d1/d2/d3/..')", ',/d1/d2/d3/..,' ], +[ "Unix->splitpath('/d1/d2/d3/.file')", ',/d1/d2/d3/,.file' ], +[ "Unix->splitpath('d1/d2/d3/file')", ',d1/d2/d3/,file' ], +[ "Unix->splitpath('/../../d1/')", ',/../../d1/,' ], +[ "Unix->splitpath('/././d1/')", ',/././d1/,' ], -if (File::Spec->catfile('a','b','c') eq 'a/b/c') { - print "ok 1\n"; -} else { - print "not ok 1\n"; -} +[ "Unix->catpath('','','file')", 'file' ], +[ "Unix->catpath('','/d1/d2/d3/','')", '/d1/d2/d3/' ], +[ "Unix->catpath('','d1/d2/d3/','')", 'd1/d2/d3/' ], +[ "Unix->catpath('','/d1/d2/d3/.','')", '/d1/d2/d3/.' ], +[ "Unix->catpath('','/d1/d2/d3/..','')", '/d1/d2/d3/..' ], +[ "Unix->catpath('','/d1/d2/d3/','.file')", '/d1/d2/d3/.file' ], +[ "Unix->catpath('','d1/d2/d3/','file')", 'd1/d2/d3/file' ], +[ "Unix->catpath('','/../../d1/','')", '/../../d1/' ], +[ "Unix->catpath('','/././d1/','')", '/././d1/' ], +[ "Unix->catpath('d1','d2/d3/','')", 'd2/d3/' ], +[ "Unix->catpath('d1','d2','d3/')", 'd2/d3/' ], -use File::Spec::OS2; +[ "Unix->splitdir('')", '' ], +[ "Unix->splitdir('/d1/d2/d3/')", ',d1,d2,d3,' ], +[ "Unix->splitdir('d1/d2/d3/')", 'd1,d2,d3,' ], +[ "Unix->splitdir('/d1/d2/d3')", ',d1,d2,d3' ], +[ "Unix->splitdir('d1/d2/d3')", 'd1,d2,d3' ], -if (File::Spec::OS2->catfile('a','b','c') eq 'a/b/c') { - print "ok 2\n"; -} else { - print "not ok 2\n"; -} +[ "Unix->catdir()", '' ], +[ "Unix->catdir('/')", '/' ], +[ "Unix->catdir('','d1','d2','d3','')", '/d1/d2/d3' ], +[ "Unix->catdir('d1','d2','d3','')", 'd1/d2/d3' ], +[ "Unix->catdir('','d1','d2','d3')", '/d1/d2/d3' ], +[ "Unix->catdir('d1','d2','d3')", 'd1/d2/d3' ], + +[ "Unix->catfile('a','b','c')", 'a/b/c' ], + +[ "Unix->canonpath('')", '' ], +[ "Unix->canonpath('///../../..//./././a//b/.././c/././')", '/a/b/../c' ], +[ "Unix->canonpath('/.')", '/.' ], + +[ "Unix->abs2rel('/t1/t2/t3','/t1/t2/t3')", '' ], +[ "Unix->abs2rel('/t1/t2/t4','/t1/t2/t3')", '../t4' ], +[ "Unix->abs2rel('/t1/t2','/t1/t2/t3')", '..' ], +[ "Unix->abs2rel('/t1/t2/t3/t4','/t1/t2/t3')", 't4' ], +[ "Unix->abs2rel('/t4/t5/t6','/t1/t2/t3')", '../../../t4/t5/t6' ], +#[ "Unix->abs2rel('../t4','/t1/t2/t3')", '../t4' ], +[ "Unix->abs2rel('/','/t1/t2/t3')", '../../..' ], +[ "Unix->abs2rel('///','/t1/t2/t3')", '../../..' ], +[ "Unix->abs2rel('/.','/t1/t2/t3')", '../../../.' ], +[ "Unix->abs2rel('/./','/t1/t2/t3')", '../../..' ], +#[ "Unix->abs2rel('../t4','/t1/t2/t3')", '../t4' ], + +[ "Unix->rel2abs('t4','/t1/t2/t3')", '/t1/t2/t3/t4' ], +[ "Unix->rel2abs('t4/t5','/t1/t2/t3')", '/t1/t2/t3/t4/t5' ], +[ "Unix->rel2abs('.','/t1/t2/t3')", '/t1/t2/t3' ], +[ "Unix->rel2abs('..','/t1/t2/t3')", '/t1/t2/t3/..' ], +[ "Unix->rel2abs('../t4','/t1/t2/t3')", '/t1/t2/t3/../t4' ], +[ "Unix->rel2abs('/t1','/t1/t2/t3')", '/t1' ], + +[ "Win32->splitpath('file')", ',,file' ], +[ "Win32->splitpath('\\d1/d2\\d3/')", ',\\d1/d2\\d3/,' ], +[ "Win32->splitpath('d1/d2\\d3/')", ',d1/d2\\d3/,' ], +[ "Win32->splitpath('\\d1/d2\\d3/.')", ',\\d1/d2\\d3/.,' ], +[ "Win32->splitpath('\\d1/d2\\d3/..')", ',\\d1/d2\\d3/..,' ], +[ "Win32->splitpath('\\d1/d2\\d3/.file')", ',\\d1/d2\\d3/,.file' ], +[ "Win32->splitpath('\\d1/d2\\d3/file')", ',\\d1/d2\\d3/,file' ], +[ "Win32->splitpath('d1/d2\\d3/file')", ',d1/d2\\d3/,file' ], +[ "Win32->splitpath('C:\\d1/d2\\d3/')", 'C:,\\d1/d2\\d3/,' ], +[ "Win32->splitpath('C:d1/d2\\d3/')", 'C:,d1/d2\\d3/,' ], +[ "Win32->splitpath('C:\\d1/d2\\d3/file')", 'C:,\\d1/d2\\d3/,file' ], +[ "Win32->splitpath('C:d1/d2\\d3/file')", 'C:,d1/d2\\d3/,file' ], +[ "Win32->splitpath('C:\\../d2\\d3/file')", 'C:,\\../d2\\d3/,file' ], +[ "Win32->splitpath('C:../d2\\d3/file')", 'C:,../d2\\d3/,file' ], +[ "Win32->splitpath('\\../..\\d1/')", ',\\../..\\d1/,' ], +[ "Win32->splitpath('\\./.\\d1/')", ',\\./.\\d1/,' ], +[ "Win32->splitpath('\\\\node\\share\\d1/d2\\d3/')", '\\\\node\\share,\\d1/d2\\d3/,' ], +[ "Win32->splitpath('\\\\node\\share\\d1/d2\\d3/file')", '\\\\node\\share,\\d1/d2\\d3/,file' ], +[ "Win32->splitpath('\\\\node\\share\\d1/d2\\file')", '\\\\node\\share,\\d1/d2\\,file' ], +[ "Win32->splitpath('file',1)", ',file,' ], +[ "Win32->splitpath('\\d1/d2\\d3/',1)", ',\\d1/d2\\d3/,' ], +[ "Win32->splitpath('d1/d2\\d3/',1)", ',d1/d2\\d3/,' ], +[ "Win32->splitpath('\\\\node\\share\\d1/d2\\d3/',1)", '\\\\node\\share,\\d1/d2\\d3/,' ], + +[ "Win32->catpath('','','file')", 'file' ], +[ "Win32->catpath('','\\d1/d2\\d3/','')", '\\d1/d2\\d3/' ], +[ "Win32->catpath('','d1/d2\\d3/','')", 'd1/d2\\d3/' ], +[ "Win32->catpath('','\\d1/d2\\d3/.','')", '\\d1/d2\\d3/.' ], +[ "Win32->catpath('','\\d1/d2\\d3/..','')", '\\d1/d2\\d3/..' ], +[ "Win32->catpath('','\\d1/d2\\d3/','.file')", '\\d1/d2\\d3/.file' ], +[ "Win32->catpath('','\\d1/d2\\d3/','file')", '\\d1/d2\\d3/file' ], +[ "Win32->catpath('','d1/d2\\d3/','file')", 'd1/d2\\d3/file' ], +[ "Win32->catpath('C:','\\d1/d2\\d3/','')", 'C:\\d1/d2\\d3/' ], +[ "Win32->catpath('C:','d1/d2\\d3/','')", 'C:d1/d2\\d3/' ], +[ "Win32->catpath('C:','\\d1/d2\\d3/','file')", 'C:\\d1/d2\\d3/file' ], +[ "Win32->catpath('C:','d1/d2\\d3/','file')", 'C:d1/d2\\d3/file' ], +[ "Win32->catpath('C:','\\../d2\\d3/','file')", 'C:\\../d2\\d3/file' ], +[ "Win32->catpath('C:','../d2\\d3/','file')", 'C:../d2\\d3/file' ], +[ "Win32->catpath('','\\../..\\d1/','')", '\\../..\\d1/' ], +[ "Win32->catpath('','\\./.\\d1/','')", '\\./.\\d1/' ], +[ "Win32->catpath('\\\\node\\share','\\d1/d2\\d3/','')", '\\\\node\\share\\d1/d2\\d3/' ], +[ "Win32->catpath('\\\\node\\share','\\d1/d2\\d3/','file')", '\\\\node\\share\\d1/d2\\d3/file' ], +[ "Win32->catpath('\\\\node\\share','\\d1/d2\\','file')", '\\\\node\\share\\d1/d2\\file' ], + +[ "Win32->splitdir('')", '' ], +[ "Win32->splitdir('\\d1/d2\\d3/')", ',d1,d2,d3,' ], +[ "Win32->splitdir('d1/d2\\d3/')", 'd1,d2,d3,' ], +[ "Win32->splitdir('\\d1/d2\\d3')", ',d1,d2,d3' ], +[ "Win32->splitdir('d1/d2\\d3')", 'd1,d2,d3' ], + +[ "Win32->catdir()", '' ], +[ "Win32->catdir('')", '\\' ], +[ "Win32->catdir('/')", '\\' ], +[ "Win32->catdir('//d1','d2')", '\\\\d1\\d2' ], +[ "Win32->catdir('','/d1','d2')", '\\\\d1\\d2' ], +[ "Win32->catdir('','','/d1','d2')", '\\\\\\d1\\d2' ], +[ "Win32->catdir('','//d1','d2')", '\\\\\\d1\\d2' ], +[ "Win32->catdir('','','//d1','d2')", '\\\\\\\\d1\\d2' ], +[ "Win32->catdir('','d1','','d2','')", '\\d1\\d2' ], +[ "Win32->catdir('','d1','d2','d3','')", '\\d1\\d2\\d3' ], +[ "Win32->catdir('d1','d2','d3','')", 'd1\\d2\\d3' ], +[ "Win32->catdir('','d1','d2','d3')", '\\d1\\d2\\d3' ], +[ "Win32->catdir('d1','d2','d3')", 'd1\\d2\\d3' ], +[ "Win32->catdir('A:/d1','d2','d3')", 'A:\\d1\\d2\\d3' ], +[ "Win32->catdir('A:/d1','d2','d3','')", 'A:\\d1\\d2\\d3' ], +#[ "Win32->catdir('A:/d1','B:/d2','d3','')", 'A:\\d1\\d2\\d3' ], +[ "Win32->catdir('A:/d1','B:/d2','d3','')", 'A:\\d1\\B:\\d2\\d3' ], +[ "Win32->catdir('A:/')", 'A:\\' ], + +[ "Win32->catfile('a','b','c')", 'a\\b\\c' ], + +[ "Win32->canonpath('')", '' ], +[ "Win32->canonpath('a:')", 'A:' ], +[ "Win32->canonpath('A:f')", 'A:f' ], +[ "Win32->canonpath('//a\\b//c')", '\\\\a\\b\\c' ], +[ "Win32->canonpath('/a/..../c')", '\\a\\....\\c' ], +[ "Win32->canonpath('//a/b\\c')", '\\\\a\\b\\c' ], +[ "Win32->canonpath('////')", '\\\\\\' ], +[ "Win32->canonpath('//')", '\\' ], +[ "Win32->canonpath('/.')", '\\.' ], +[ "Win32->canonpath('//a/b/../../c')", '\\\\a\\b\\..\\..\\c' ], +[ "Win32->canonpath('//a/../../c')", '\\\\a\\..\\..\\c' ], + +[ "Win32->abs2rel('/t1/t2/t3','/t1/t2/t3')", '' ], +[ "Win32->abs2rel('/t1/t2/t4','/t1/t2/t3')", '..\\t4' ], +[ "Win32->abs2rel('/t1/t2','/t1/t2/t3')", '..' ], +[ "Win32->abs2rel('/t1/t2/t3/t4','/t1/t2/t3')", 't4' ], +[ "Win32->abs2rel('/t4/t5/t6','/t1/t2/t3')", '..\\..\\..\\t4\\t5\\t6' ], +#[ "Win32->abs2rel('../t4','/t1/t2/t3')", '\\t1\\t2\\t3\\..\\t4' ], +[ "Win32->abs2rel('/','/t1/t2/t3')", '..\\..\\..' ], +[ "Win32->abs2rel('///','/t1/t2/t3')", '..\\..\\..' ], +[ "Win32->abs2rel('/.','/t1/t2/t3')", '..\\..\\..\\.' ], +[ "Win32->abs2rel('/./','/t1/t2/t3')", '..\\..\\..' ], +[ "Win32->abs2rel('\\\\a/t1/t2/t4','/t2/t3')", '..\\t4' ], +[ "Win32->abs2rel('//a/t1/t2/t4','/t2/t3')", '..\\t4' ], + +[ "Win32->rel2abs('temp','C:/')", 'C:\\temp' ], +[ "Win32->rel2abs('temp','C:/a')", 'C:\\a\\temp' ], +[ "Win32->rel2abs('temp','C:/a/')", 'C:\\a\\temp' ], +[ "Win32->rel2abs('../','C:/')", 'C:\\..' ], +[ "Win32->rel2abs('../','C:/a')", 'C:\\a\\..' ], +[ "Win32->rel2abs('temp','//prague_main/work/')", '\\\\prague_main\\work\\temp' ], +[ "Win32->rel2abs('../temp','//prague_main/work/')", '\\\\prague_main\\work\\..\\temp' ], +[ "Win32->rel2abs('temp','//prague_main/work')", '\\\\prague_main\\work\\temp' ], +[ "Win32->rel2abs('../','//prague_main/work')", '\\\\prague_main\\work\\..' ], + +[ "VMS->splitpath('file')", ',,file' ], +[ "VMS->splitpath('[d1.d2.d3]')", ',[d1.d2.d3],' ], +[ "VMS->splitpath('[.d1.d2.d3]')", ',[.d1.d2.d3],' ], +[ "VMS->splitpath('[d1.d2.d3]file')", ',[d1.d2.d3],file' ], +[ "VMS->splitpath('d1/d2/d3/file')", ',[.d1.d2.d3],file' ], +[ "VMS->splitpath('/d1/d2/d3/file')", 'd1:,[d2.d3],file' ], +[ "VMS->splitpath('[.d1.d2.d3]file')", ',[.d1.d2.d3],file' ], +[ "VMS->splitpath('node::volume:[d1.d2.d3]')", 'node::volume:,[d1.d2.d3],' ], +[ "VMS->splitpath('node::volume:[d1.d2.d3]file')", 'node::volume:,[d1.d2.d3],file' ], +[ "VMS->splitpath('node\"access_spec\"::volume:[d1.d2.d3]')", 'node"access_spec"::volume:,[d1.d2.d3],' ], +[ "VMS->splitpath('node\"access_spec\"::volume:[d1.d2.d3]file')", 'node"access_spec"::volume:,[d1.d2.d3],file' ], + +[ "VMS->catpath('','','file')", 'file' ], +[ "VMS->catpath('','[d1.d2.d3]','')", '[d1.d2.d3]' ], +[ "VMS->catpath('','[.d1.d2.d3]','')", '[.d1.d2.d3]' ], +[ "VMS->catpath('','[d1.d2.d3]','file')", '[d1.d2.d3]file' ], +[ "VMS->catpath('','[.d1.d2.d3]','file')", '[.d1.d2.d3]file' ], +[ "VMS->catpath('','d1/d2/d3','file')", '[.d1.d2.d3]file' ], +[ "VMS->catpath('v','d1/d2/d3','file')", 'v:[.d1.d2.d3]file' ], +[ "VMS->catpath('node::volume:','[d1.d2.d3]','')", 'node::volume:[d1.d2.d3]' ], +[ "VMS->catpath('node::volume:','[d1.d2.d3]','file')", 'node::volume:[d1.d2.d3]file' ], +[ "VMS->catpath('node\"access_spec\"::volume:','[d1.d2.d3]','')", 'node"access_spec"::volume:[d1.d2.d3]' ], +[ "VMS->catpath('node\"access_spec\"::volume:','[d1.d2.d3]','file')", 'node"access_spec"::volume:[d1.d2.d3]file' ], + +[ "VMS->canonpath('')", '' ], +[ "VMS->canonpath('volume:[d1]file')", 'volume:[d1]file' ], +[ "VMS->canonpath('volume:[d1.-.d2.][d3.d4.-]')", 'volume:[d2.d3]' ], +[ "VMS->canonpath('volume:[000000.d1]d2.dir;1')", 'volume:[d1]d2.dir;1' ], + +[ "VMS->splitdir('')", '' ], +[ "VMS->splitdir('[]')", '' ], +[ "VMS->splitdir('d1.d2.d3')", 'd1,d2,d3' ], +[ "VMS->splitdir('[d1.d2.d3]')", 'd1,d2,d3' ], +[ "VMS->splitdir('.d1.d2.d3')", ',d1,d2,d3' ], +[ "VMS->splitdir('[.d1.d2.d3]')", ',d1,d2,d3' ], +[ "VMS->splitdir('.-.d2.d3')", ',-,d2,d3' ], +[ "VMS->splitdir('[.-.d2.d3]')", ',-,d2,d3' ], + +[ "VMS->catdir('')", '' ], +[ "VMS->catdir('d1','d2','d3')", '[.d1.d2.d3]' ], +[ "VMS->catdir('d1','d2/','d3')", '[.d1.d2.d3]' ], +[ "VMS->catdir('','d1','d2','d3')", '[.d1.d2.d3]' ], +[ "VMS->catdir('','-','d2','d3')", '[-.d2.d3]' ], +[ "VMS->catdir('','-','','d3')", '[-.d3]' ], +[ "VMS->catdir('dir.dir','d2.dir','d3.dir')", '[.dir.d2.d3]' ], +[ "VMS->catdir('[.name]')", '[.name]' ], +[ "VMS->catdir('[.name]','[.name]')", '[.name.name]'], + +[ "VMS->abs2rel('node::volume:[t1.t2.t3]','[t1.t2.t3]')", '' ], +[ "VMS->abs2rel('node::volume:[t1.t2.t4]','[t1.t2.t3]')", '[-.t4]' ], +[ "VMS->abs2rel('[t1.t2.t3]','[t1.t2.t3]')", '' ], +[ "VMS->abs2rel('[t1.t2.t3]file','[t1.t2.t3]')", 'file' ], +[ "VMS->abs2rel('[t1.t2.t4]','[t1.t2.t3]')", '[-.t4]' ], +[ "VMS->abs2rel('[t1.t2]file','[t1.t2.t3]')", '[-]file' ], +[ "VMS->abs2rel('[t1.t2.t3.t4]','[t1.t2.t3]')", '[t4]' ], +[ "VMS->abs2rel('[t4.t5.t6]','[t1.t2.t3]')", '[---.t4.t5.t6]' ], +[ "VMS->abs2rel('[000000]','[t1.t2.t3]')", '[---.000000]' ], +[ "VMS->abs2rel('a:[t1.t2.t4]','[t1.t2.t3]')", '[-.t4]' ], +[ "VMS->abs2rel('[a.-.b.c.-]','[t1.t2.t3]')", '[---.b]' ], -use File::Spec::Win32; +[ "VMS->rel2abs('[.t4]','[t1.t2.t3]')", '[t1.t2.t3.t4]' ], +[ "VMS->rel2abs('[.t4.t5]','[t1.t2.t3]')", '[t1.t2.t3.t4.t5]' ], +[ "VMS->rel2abs('[]','[t1.t2.t3]')", '[t1.t2.t3]' ], +[ "VMS->rel2abs('[-]','[t1.t2.t3]')", '[t1.t2]' ], +[ "VMS->rel2abs('[-.t4]','[t1.t2.t3]')", '[t1.t2.t4]' ], +[ "VMS->rel2abs('[t1]','[t1.t2.t3]')", '[t1]' ], -if (File::Spec::Win32->catfile('a','b','c') eq 'a\b\c') { - print "ok 3\n"; -} else { - print "not ok 3\n"; +[ "OS2->catdir('A:/d1','B:/d2','d3','')", 'A:/d1/B:/d2/d3' ], +[ "OS2->catfile('a','b','c')", 'a/b/c' ], + +[ "Mac->splitpath('file')", ',,file' ], +[ "Mac->splitpath(':file')", ',:,file' ], +[ "Mac->splitpath(':d1',1)", ',:d1:,' ], +[ "Mac->splitpath('d1',1)", 'd1:,,' ], +[ "Mac->splitpath('d1:d2:d3:')", 'd1:,d2:d3:,' ], +[ "Mac->splitpath('d1:d2:d3',1)", 'd1:,d2:d3:,' ], +[ "Mac->splitpath(':d1:d2:d3:')", ',:d1:d2:d3:,' ], +[ "Mac->splitpath(':d1:d2:d3:',1)", ',:d1:d2:d3:,' ], +[ "Mac->splitpath('d1:d2:d3:file')", 'd1:,d2:d3:,file' ], +[ "Mac->splitpath('d1:d2:d3',1)", 'd1:,d2:d3:,' ], + +[ "Mac->catdir('')", ':' ], +[ "Mac->catdir('d1','d2','d3')", 'd1:d2:d3:' ], +[ "Mac->catdir('d1','d2/','d3')", 'd1:d2/:d3:' ], +[ "Mac->catdir('','d1','d2','d3')", ':d1:d2:d3:' ], +[ "Mac->catdir('','','d2','d3')", '::d2:d3:' ], +[ "Mac->catdir('','','','d3')", ':::d3:' ], +[ "Mac->catdir(':name')", ':name:' ], +[ "Mac->catdir(':name',':name')", ':name:name:' ], + +[ "Mac->catfile('a','b','c')", 'a:b:c' ], + +[ "Mac->canonpath('')", '' ], +[ "Mac->canonpath(':')", ':' ], +[ "Mac->canonpath('::')", '::' ], +[ "Mac->canonpath('a::')", 'a::' ], +[ "Mac->canonpath(':a::')", ':a::' ], + +[ "Mac->abs2rel('t1:t2:t3','t1:t2:t3')", ':' ], +[ "Mac->abs2rel('t1:t2','t1:t2:t3')", '::' ], +[ "Mac->abs2rel('t1:t4','t1:t2:t3')", ':::t4' ], +[ "Mac->abs2rel('t1:t2:t4','t1:t2:t3')", '::t4' ], +[ "Mac->abs2rel('t1:t2:t3:t4','t1:t2:t3')", ':t4' ], +[ "Mac->abs2rel('t4:t5:t6','t1:t2:t3')", '::::t4:t5:t6' ], +[ "Mac->abs2rel('t1','t1:t2:t3')", ':::' ], + +[ "Mac->rel2abs(':t4','t1:t2:t3')", 't1:t2:t3:t4' ], +[ "Mac->rel2abs(':t4:t5','t1:t2:t3')", 't1:t2:t3:t4:t5' ], +[ "Mac->rel2abs('','t1:t2:t3')", '' ], +[ "Mac->rel2abs('::','t1:t2:t3')", 't1:t2:t3::' ], +[ "Mac->rel2abs('::t4','t1:t2:t3')", 't1:t2:t3::t4' ], +[ "Mac->rel2abs('t1','t1:t2:t3')", 't1' ], +) ; + +# Grab all of the plain routines from File::Spec +use File::Spec @File::Spec::EXPORT_OK ; + +require File::Spec::Unix ; +require File::Spec::Win32 ; + +eval { + require VMS::Filespec ; +} ; + +my $skip_exception = "Install VMS::Filespec (from vms/ext)" ; + +if ( $@ ) { + # Not pretty, but it allows testing of things not implemented soley + # on VMS. It might be better to change File::Spec::VMS to do this, + # making it more usable when running on (say) Unix but working with + # VMS paths. + eval qq- + sub File::Spec::VMS::vmsify { die "$skip_exception" } + sub File::Spec::VMS::unixify { die "$skip_exception" } + sub File::Spec::VMS::vmspath { die "$skip_exception" } + - ; + $INC{"VMS/Filespec.pm"} = 1 ; } +require File::Spec::VMS ; + +require File::Spec::OS2 ; +require File::Spec::Mac ; + +print "1..", scalar( @tests ), "\n" ; -use File::Spec::Mac; +my $current_test= 1 ; -if (File::Spec::Mac->catfile('a','b','c') eq 'a:b:c') { - print "ok 4\n"; -} else { - print "not ok 4\n"; +# Test out the class methods +for ( @tests ) { + tryfunc( @$_ ) ; } + + +# +# Tries a named function with the given args and compares the result against +# an expected result. Works with functions that return scalars or arrays. +# +sub tryfunc { + my $function = shift ; + my $expected = shift ; + my $platform = shift ; + + if ($platform && $^O ne $platform) { + print "ok $current_test # skipped: $function\n" ; + ++$current_test ; + return; + } + + $function =~ s#\\#\\\\#g ; + + my $got ; + if ( $function =~ /^[^\$].*->/ ) { + $got = eval( "join( ',', File::Spec::$function )" ) ; + } + else { + $got = eval( "join( ',', $function )" ) ; + } + + if ( $@ ) { + if ( substr( $@, 0, length $skip_exception ) eq $skip_exception ) { + chomp $@ ; + print "ok $current_test # skip $function: $@\n" ; + } + else { + chomp $@ ; + print "not ok $current_test # $function: $@\n" ; + } + } + elsif ( !defined( $got ) || $got ne $expected ) { + print "not ok $current_test # $function: got '$got', expected '$expected'\n" ; + } + else { + print "ok $current_test # $function\n" ; + } + ++$current_test ; +} diff --git a/contrib/perl5/t/lib/findbin.t b/contrib/perl5/t/lib/findbin.t index 3e742f9..f0939e9 100755 --- a/contrib/perl5/t/lib/findbin.t +++ b/contrib/perl5/t/lib/findbin.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } print "1..1\n"; diff --git a/contrib/perl5/t/lib/gdbm.t b/contrib/perl5/t/lib/gdbm.t index 2395611..dc4e96e 100755 --- a/contrib/perl5/t/lib/gdbm.t +++ b/contrib/perl5/t/lib/gdbm.t @@ -3,17 +3,17 @@ # $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ BEGIN { - @INC = '../lib'; + unshift @INC, '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bGDBM_File\b/) { - print "1..0\n"; + print "1..0 # Skip: GDBM_File was not built\n"; exit 0; } } use GDBM_File; -print "1..20\n"; +print "1..66\n"; unlink <Op.dbmx*>; @@ -206,3 +206,189 @@ EOM unlink "SubDB.pm", <dbhash.tmp*> ; } + +{ + # DBM Filter tests + use strict ; + my (%h, $db) ; + my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + + sub checkOutput + { + my($fk, $sk, $fv, $sv) = @_ ; + return + $fetch_key eq $fk && $store_key eq $sk && + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; + } + + unlink <Op.dbmx*>; + ok(21, $db = tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)) ; + + $db->filter_fetch_key (sub { $fetch_key = $_ }) ; + $db->filter_store_key (sub { $store_key = $_ }) ; + $db->filter_fetch_value (sub { $fetch_value = $_}) ; + $db->filter_store_value (sub { $store_value = $_ }) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + # fk sk fv sv + ok(22, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(23, $h{"fred"} eq "joe"); + # fk sk fv sv + ok(24, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(25, $db->FIRSTKEY() eq "fred") ; + # fk sk fv sv + ok(26, checkOutput( "fred", "", "", "")) ; + + # replace the filters, but remember the previous set + my ($old_fk) = $db->filter_fetch_key + (sub { $_ = uc $_ ; $fetch_key = $_ }) ; + my ($old_sk) = $db->filter_store_key + (sub { $_ = lc $_ ; $store_key = $_ }) ; + my ($old_fv) = $db->filter_fetch_value + (sub { $_ = "[$_]"; $fetch_value = $_ }) ; + my ($old_sv) = $db->filter_store_value + (sub { s/o/x/g; $store_value = $_ }) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"Fred"} = "Joe" ; + # fk sk fv sv + ok(27, checkOutput( "", "fred", "", "Jxe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(28, $h{"Fred"} eq "[Jxe]"); + # fk sk fv sv + ok(29, checkOutput( "", "fred", "[Jxe]", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(30, $db->FIRSTKEY() eq "FRED") ; + # fk sk fv sv + ok(31, checkOutput( "FRED", "", "", "")) ; + + # put the original filters back + $db->filter_fetch_key ($old_fk); + $db->filter_store_key ($old_sk); + $db->filter_fetch_value ($old_fv); + $db->filter_store_value ($old_sv); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(32, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(33, $h{"fred"} eq "joe"); + ok(34, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(35, $db->FIRSTKEY() eq "fred") ; + ok(36, checkOutput( "fred", "", "", "")) ; + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(37, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(38, $h{"fred"} eq "joe"); + ok(39, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(40, $db->FIRSTKEY() eq "fred") ; + ok(41, checkOutput( "", "", "", "")) ; + + undef $db ; + untie %h; + unlink <Op.dbmx*>; +} + +{ + # DBM Filter with a closure + + use strict ; + my (%h, $db) ; + + unlink <Op.dbmx*>; + ok(42, $db = tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)) ; + + my %result = () ; + + sub Closure + { + my ($name) = @_ ; + my $count = 0 ; + my @kept = () ; + + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } + } + + $db->filter_store_key(Closure("store key")) ; + $db->filter_store_value(Closure("store value")) ; + $db->filter_fetch_key(Closure("fetch key")) ; + $db->filter_fetch_value(Closure("fetch value")) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + ok(43, $result{"store key"} eq "store key - 1: [fred]"); + ok(44, $result{"store value"} eq "store value - 1: [joe]"); + ok(45, !defined $result{"fetch key"} ); + ok(46, !defined $result{"fetch value"} ); + ok(47, $_ eq "original") ; + + ok(48, $db->FIRSTKEY() eq "fred") ; + ok(49, $result{"store key"} eq "store key - 1: [fred]"); + ok(50, $result{"store value"} eq "store value - 1: [joe]"); + ok(51, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(52, ! defined $result{"fetch value"} ); + ok(53, $_ eq "original") ; + + $h{"jim"} = "john" ; + ok(54, $result{"store key"} eq "store key - 2: [fred jim]"); + ok(55, $result{"store value"} eq "store value - 2: [joe john]"); + ok(56, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(57, $result{"fetch value"} eq ""); + ok(58, $_ eq "original") ; + + ok(59, $h{"fred"} eq "joe"); + ok(60, $result{"store key"} eq "store key - 3: [fred jim fred]"); + ok(61, $result{"store value"} eq "store value - 2: [joe john]"); + ok(62, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(63, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(64, $_ eq "original") ; + + undef $db ; + untie %h; + unlink <Op.dbmx*>; +} + +{ + # DBM Filter recursion detection + use strict ; + my (%h, $db) ; + unlink <Op.dbmx*>; + + ok(65, $db = tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)) ; + + $db->filter_store_key (sub { $_ = $h{$_} }) ; + + eval '$h{1} = 1234' ; + ok(66, $@ =~ /^recursion detected in filter_store_key at/ ); + + undef $db ; + untie %h; + unlink <Op.dbmx*>; +} diff --git a/contrib/perl5/t/lib/getopt.t b/contrib/perl5/t/lib/getopt.t index fb70f10..0354627 100755 --- a/contrib/perl5/t/lib/getopt.t +++ b/contrib/perl5/t/lib/getopt.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } print "1..11\n"; diff --git a/contrib/perl5/t/lib/glob-basic.t b/contrib/perl5/t/lib/glob-basic.t new file mode 100755 index 0000000..4728083 --- /dev/null +++ b/contrib/perl5/t/lib/glob-basic.t @@ -0,0 +1,119 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) { + print "1..0\n"; + exit 0; + } + print "1..9\n"; +} +END { + print "not ok 1\n" unless $loaded; +} +use File::Glob ':glob'; +use Cwd (); +$loaded = 1; +print "ok 1\n"; + +sub array { + return '(', join(", ", map {defined $_ ? "\"$_\"" : "undef"} @a), ")\n"; +} + +# look for the contents of the current directory +$ENV{PATH} = "/bin"; +delete @ENV{BASH_ENV, CDPATH, ENV, IFS}; +@correct = (); +if (opendir(D, ".")) { + @correct = grep { !/^\.\.?$/ } sort readdir(D); + closedir D; +} +@a = File::Glob::glob("*", 0); +@a = sort @a; +if ("@a" ne "@correct" || GLOB_ERROR) { + print "# |@a| ne |@correct|\nnot "; +} +print "ok 2\n"; + +# look up the user's home directory +# should return a list with one item, and not set ERROR +if ($^O ne 'MSWin32' || $^O ne 'VMS') { + eval { + ($name, $home) = (getpwuid($>))[0,7]; + 1; + } and do { + @a = File::Glob::glob("~$name", GLOB_TILDE); + if (scalar(@a) != 1 || $a[0] ne $home || GLOB_ERROR) { + print "not "; + } + }; +} +print "ok 3\n"; + +# check backslashing +# should return a list with one item, and not set ERROR +@a = File::Glob::glob('TEST', GLOB_QUOTE); +if (scalar @a != 1 || $a[0] ne 'TEST' || GLOB_ERROR) { + local $/ = "]["; + print "# [@a]\n"; + print "not "; +} +print "ok 4\n"; + +# check nonexistent checks +# should return an empty list +# XXX since errfunc is NULL on win32, this test is not valid there +@a = File::Glob::glob("asdfasdf", 0); +if ($^O ne 'MSWin32' and scalar @a != 0) { + print "# |@a|\nnot "; +} +print "ok 5\n"; + +# check bad protections +# should return an empty list, and set ERROR +if ($^O eq 'mpeix' or $^O eq 'MSWin32' or $^O eq 'os2' or $^O eq 'VMS' + or $^O eq 'cygwin' or Cwd::cwd() =~ m#^/afs#s or not $>) +{ + print "ok 6 # skipped\n"; +} +else { + $dir = "PtEeRsLt.dir"; + mkdir $dir, 0; + @a = File::Glob::glob("$dir/*", GLOB_ERR); + #print "\@a = ", array(@a); + rmdir $dir; + if (scalar(@a) != 0 || GLOB_ERROR == 0) { + print "not "; + } + print "ok 6\n"; +} + +# check for csh style globbing +@a = File::Glob::glob('{a,b}', GLOB_BRACE | GLOB_NOMAGIC); +unless (@a == 2 and $a[0] eq 'a' and $a[1] eq 'b') { + print "not "; +} +print "ok 7\n"; + +@a = File::Glob::glob( + '{TES*,doesntexist*,a,b}', + GLOB_BRACE | GLOB_NOMAGIC +); +unless (@a == 3 + and $a[0] eq ($^O eq 'VMS'? 'test.' : 'TEST') + and $a[1] eq 'a' + and $a[2] eq 'b') +{ + print "not "; +} +print "ok 8\n"; + +# "~" should expand to $ENV{HOME} +$ENV{HOME} = "sweet home"; +@a = File::Glob::glob('~', GLOB_TILDE | GLOB_NOMAGIC); +unless (@a == 1 and $a[0] eq $ENV{HOME}) { + print "not "; +} +print "ok 9\n"; diff --git a/contrib/perl5/t/lib/glob-case.t b/contrib/perl5/t/lib/glob-case.t new file mode 100755 index 0000000..32719b2 --- /dev/null +++ b/contrib/perl5/t/lib/glob-case.t @@ -0,0 +1,53 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) { + print "1..0\n"; + exit 0; + } + print "1..7\n"; +} +END { + print "not ok 1\n" unless $loaded; +} +use File::Glob qw(:glob csh_glob); +$loaded = 1; +print "ok 1\n"; + +# Test the actual use of the case sensitivity tags, via csh_glob() +import File::Glob ':nocase'; +@a = csh_glob("lib/G*.t"); # At least glob-basic.t glob-case.t glob-global.t +print "not " unless @a >= 3; +print "ok 2\n"; + +# This may fail on systems which are not case-PRESERVING +import File::Glob ':case'; +@a = csh_glob("lib/G*.t"); # None should be uppercase +print "not " unless @a == 0; +print "ok 3\n"; + +# Test the explicit use of the GLOB_NOCASE flag +@a = File::Glob::glob("lib/G*.t", GLOB_NOCASE); +print "not " unless @a >= 3; +print "ok 4\n"; + +# Test Win32 backslash nastiness... +if ($^O ne 'MSWin32') { + print "ok 5\nok 6\nok 7\n"; +} +else { + @a = File::Glob::glob("lib\\g*.t"); + print "not " unless @a >= 3; + print "ok 5\n"; + mkdir "[]", 0; + @a = File::Glob::glob("\\[\\]", GLOB_QUOTE); + rmdir "[]"; + print "# returned @a\nnot " unless @a == 1; + print "ok 6\n"; + @a = File::Glob::glob("lib\\*", GLOB_QUOTE); + print "not " if @a == 0; + print "ok 7\n"; +} diff --git a/contrib/perl5/t/lib/glob-global.t b/contrib/perl5/t/lib/glob-global.t new file mode 100755 index 0000000..9d273bd --- /dev/null +++ b/contrib/perl5/t/lib/glob-global.t @@ -0,0 +1,110 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) { + print "1..0\n"; + exit 0; + } + print "1..10\n"; +} +END { + print "not ok 1\n" unless $loaded; +} + +BEGIN { + *CORE::GLOBAL::glob = sub { "Just another Perl hacker," }; +} + +BEGIN { + if ("Just another Perl hacker," ne (<*>)[0]) { + die <<EOMessage; +Your version of perl ($]) doesn't seem to allow extensions to override +the core glob operator. +EOMessage + } +} + +use File::Glob ':globally'; +$loaded = 1; +print "ok 1\n"; + +$_ = "lib/*.t"; +my @r = glob; +print "not " if $_ ne 'lib/*.t'; +print "ok 2\n"; + +# we should have at least basic.t, global.t, taint.t +print "# |@r|\nnot " if @r < 3; +print "ok 3\n"; + +# check if <*/*> works +@r = <*/*.t>; +# at least t/global.t t/basic.t, t/taint.t +print "not " if @r < 3; +print "ok 4\n"; +my $r = scalar @r; + +# check if scalar context works +@r = (); +while (defined($_ = <*/*.t>)) { + #print "# $_\n"; + push @r, $_; +} +print "not " if @r != $r; +print "ok 5\n"; + +# check if array context works +@r = (); +for (<*/*.t>) { + #print "# $_\n"; + push @r, $_; +} +print "not " if @r != $r; +print "ok 6\n"; + +# test if implicit assign to $_ in while() works +@r = (); +while (<*/*.t>) { + #print "# $_\n"; + push @r, $_; +} +print "not " if @r != $r; +print "ok 7\n"; + +# test if explicit glob() gets assign magic too +my @s = (); +while (glob '*/*.t') { + #print "# $_\n"; + push @s, $_; +} +print "not " if "@r" ne "@s"; +print "ok 8\n"; + +# how about in a different package, like? +package Foo; +use File::Glob ':globally'; +@s = (); +while (glob '*/*.t') { + #print "# $_\n"; + push @s, $_; +} +print "not " if "@r" ne "@s"; +print "ok 9\n"; + +# test if different glob ops maintain independent contexts +@s = (); +my $i = 0; +while (<*/*.t>) { + #print "# $_ <"; + push @s, $_; + while (<bas*/*.t>) { + #print " $_"; + $i++; + } + #print " >\n"; +} +print "not " if "@r" ne "@s" or not $i; +print "ok 10\n"; diff --git a/contrib/perl5/t/lib/glob-taint.t b/contrib/perl5/t/lib/glob-taint.t new file mode 100755 index 0000000..a8dc213 --- /dev/null +++ b/contrib/perl5/t/lib/glob-taint.t @@ -0,0 +1,26 @@ +#!./perl -T + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) { + print "1..0\n"; + exit 0; + } + print "1..2\n"; +} +END { + print "not ok 1\n" unless $loaded; +} +use File::Glob; +$loaded = 1; +print "ok 1\n"; + +# all filenames should be tainted +@a = File::Glob::glob("*"); +eval { $a = join("",@a), kill 0; 1 }; +unless ($@ =~ /Insecure dependency/) { + print "not "; +} +print "ok 2\n"; diff --git a/contrib/perl5/t/lib/gol-basic.t b/contrib/perl5/t/lib/gol-basic.t new file mode 100755 index 0000000..4b25322 --- /dev/null +++ b/contrib/perl5/t/lib/gol-basic.t @@ -0,0 +1,24 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +use Getopt::Long 2.17; + +print "1..9\n"; + +@ARGV = qw(-Foo -baR --foo bar); +Getopt::Long::Configure ("no_ignore_case"); +undef $opt_baR; +undef $opt_bar; +print "ok 1\n" if GetOptions ("foo", "Foo=s"); +print ((defined $opt_foo) ? "" : "not ", "ok 2\n"); +print (($opt_foo == 1) ? "" : "not ", "ok 3\n"); +print ((defined $opt_Foo) ? "" : "not ", "ok 4\n"); +print (($opt_Foo eq "-baR") ? "" : "not ", "ok 5\n"); +print ((@ARGV == 1) ? "" : "not ", "ok 6\n"); +print (($ARGV[0] eq "bar") ? "" : "not ", "ok 7\n"); +print (!(defined $opt_baR) ? "" : "not ", "ok 8\n"); +print (!(defined $opt_bar) ? "" : "not ", "ok 9\n"); diff --git a/contrib/perl5/t/lib/gol-compat.t b/contrib/perl5/t/lib/gol-compat.t new file mode 100755 index 0000000..a4f807c --- /dev/null +++ b/contrib/perl5/t/lib/gol-compat.t @@ -0,0 +1,25 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +require "newgetopt.pl"; + +print "1..9\n"; + +@ARGV = qw(-Foo -baR --foo bar); +$newgetopt::ignorecase = 0; +$newgetopt::ignorecase = 0; +undef $opt_baR; +undef $opt_bar; +print "ok 1\n" if NGetOpt ("foo", "Foo=s"); +print ((defined $opt_foo) ? "" : "not ", "ok 2\n"); +print (($opt_foo == 1) ? "" : "not ", "ok 3\n"); +print ((defined $opt_Foo) ? "" : "not ", "ok 4\n"); +print (($opt_Foo eq "-baR") ? "" : "not ", "ok 5\n"); +print ((@ARGV == 1) ? "" : "not ", "ok 6\n"); +print (($ARGV[0] eq "bar") ? "" : "not ", "ok 7\n"); +print (!(defined $opt_baR) ? "" : "not ", "ok 8\n"); +print (!(defined $opt_bar) ? "" : "not ", "ok 9\n"); diff --git a/contrib/perl5/t/lib/gol-linkage.t b/contrib/perl5/t/lib/gol-linkage.t new file mode 100755 index 0000000..a1b2c05 --- /dev/null +++ b/contrib/perl5/t/lib/gol-linkage.t @@ -0,0 +1,37 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +use Getopt::Long; + +print "1..18\n"; + +@ARGV = qw(-Foo -baR --foo bar); +Getopt::Long::Configure ("no_ignore_case"); +%lnk = (); +print "ok 1\n" if GetOptions (\%lnk, "foo", "Foo=s"); +print ((defined $lnk{foo}) ? "" : "not ", "ok 2\n"); +print (($lnk{foo} == 1) ? "" : "not ", "ok 3\n"); +print ((defined $lnk{Foo}) ? "" : "not ", "ok 4\n"); +print (($lnk{Foo} eq "-baR") ? "" : "not ", "ok 5\n"); +print ((@ARGV == 1) ? "" : "not ", "ok 6\n"); +print (($ARGV[0] eq "bar") ? "" : "not ", "ok 7\n"); +print (!(exists $lnk{baR}) ? "" : "not ", "ok 8\n"); + +@ARGV = qw(-Foo -baR --foo bar); +Getopt::Long::Configure ("default","no_ignore_case"); +%lnk = (); +my $foo; +print "ok 9\n" if GetOptions (\%lnk, "foo" => \$foo, "Foo=s"); +print ((defined $foo) ? "" : "not ", "ok 10\n"); +print (($foo == 1) ? "" : "not ", "ok 11\n"); +print ((defined $lnk{Foo}) ? "" : "not ", "ok 12\n"); +print (($lnk{Foo} eq "-baR") ? "" : "not ", "ok 13\n"); +print ((@ARGV == 1) ? "" : "not ", "ok 14\n"); +print (($ARGV[0] eq "bar") ? "" : "not ", "ok 15\n"); +print (!(exists $lnk{foo}) ? "" : "not ", "ok 16\n"); +print (!(exists $lnk{baR}) ? "" : "not ", "ok 17\n"); +print (!(exists $lnk{bar}) ? "" : "not ", "ok 18\n"); diff --git a/contrib/perl5/t/lib/h2ph.t b/contrib/perl5/t/lib/h2ph.t index 1fa7f63..acb150d 100755 --- a/contrib/perl5/t/lib/h2ph.t +++ b/contrib/perl5/t/lib/h2ph.t @@ -5,7 +5,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } print "1..2\n"; @@ -31,4 +31,5 @@ unless(-e '../utils/h2ph') { # cleanup - should this be in an END block? unlink("lib/h2ph.ph"); + unlink("_h2ph_pre.ph"); } diff --git a/contrib/perl5/t/lib/hostname.t b/contrib/perl5/t/lib/hostname.t index e4ac365..6f61fb9 100755 --- a/contrib/perl5/t/lib/hostname.t +++ b/contrib/perl5/t/lib/hostname.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use Sys::Hostname; @@ -15,5 +15,6 @@ if ($@) { print "1..0\n" if $@ =~ /Cannot get host name/; } else { print "1..1\n"; + print "# \$host = `$host'\n"; print "ok 1\n"; } diff --git a/contrib/perl5/t/lib/io_const.t b/contrib/perl5/t/lib/io_const.t new file mode 100755 index 0000000..48cb6b5 --- /dev/null +++ b/contrib/perl5/t/lib/io_const.t @@ -0,0 +1,33 @@ + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + unshift @INC, '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { + print "1..0\n"; + exit 0; + } + } +} + +use IO::Handle; + +print "1..6\n"; +my $i = 1; +foreach (qw(SEEK_SET SEEK_CUR SEEK_END _IOFBF _IOLBF _IONBF)) { + my $d1 = defined(&{"IO::Handle::" . $_}) ? 1 : 0; + my $v1 = $d1 ? &{"IO::Handle::" . $_}() : undef; + my $v2 = IO::Handle::constant($_); + my $d2 = defined($v2); + + print "not " + if($d1 != $d2 || ($d1 && ($v1 != $v2))); + print "ok ",$i++,"\n"; +} diff --git a/contrib/perl5/t/lib/io_dir.t b/contrib/perl5/t/lib/io_dir.t new file mode 100755 index 0000000..11ec8bc --- /dev/null +++ b/contrib/perl5/t/lib/io_dir.t @@ -0,0 +1,66 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + unshift @INC, '../lib' if -d '../lib'; + } + require Config; import Config; + if ($] < 5.00326 || not $Config{'d_readdir'}) { + print "1..0\n"; + exit 0; + } +} + +select(STDERR); $| = 1; +select(STDOUT); $| = 1; + +use IO::Dir qw(DIR_UNLINK); + +print "1..10\n"; + +$dot = new IO::Dir "."; +print defined($dot) ? "ok" : "not ok", " 1\n"; + +@a = sort <*>; +do { $first = $dot->read } while defined($first) && $first =~ /^\./; +print +(grep { $_ eq $first } @a) ? "ok" : "not ok", " 2\n"; + +@b = sort($first, (grep {/^[^.]/} $dot->read)); +print +(join("\0", @a) eq join("\0", @b)) ? "ok" : "not ok", " 3\n"; + +$dot->rewind; +@c = sort grep {/^[^.]/} $dot->read; +print +(join("\0", @b) eq join("\0", @c)) ? "ok" : "not ok", " 4\n"; + +$dot->close; +$dot->rewind; +print defined($dot->read) ? "not ok" : "ok", " 5\n"; + +open(FH,'>X') || die "Can't create x"; +print FH "X"; +close(FH); + +tie %dir, IO::Dir, "."; +my @files = keys %dir; + +# I hope we do not have an empty dir :-) +print @files ? "ok" : "not ok", " 6\n"; + +my $stat = $dir{'X'}; +print defined($stat) && UNIVERSAL::isa($stat,'File::stat') && $stat->size == 1 + ? "ok" : "not ok", " 7\n"; + +delete $dir{'X'}; + +print -f 'X' ? "ok" : "not ok", " 8\n"; + +tie %dirx, IO::Dir, ".", DIR_UNLINK; + +my $statx = $dirx{'X'}; +print defined($statx) && UNIVERSAL::isa($statx,'File::stat') && $statx->size == 1 + ? "ok" : "not ok", " 9\n"; + +delete $dirx{'X'}; + +print -f 'X' ? "not ok" : "ok", " 10\n"; diff --git a/contrib/perl5/t/lib/io_dup.t b/contrib/perl5/t/lib/io_dup.t index 6b0caf1..c895fb4 100755 --- a/contrib/perl5/t/lib/io_dup.t +++ b/contrib/perl5/t/lib/io_dup.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } } diff --git a/contrib/perl5/t/lib/io_linenum.t b/contrib/perl5/t/lib/io_linenum.t new file mode 100755 index 0000000..3503215 --- /dev/null +++ b/contrib/perl5/t/lib/io_linenum.t @@ -0,0 +1,80 @@ +#!./perl + +# test added 29th April 1999 by Paul Johnson (pjcj@transeda.com) +# updated 28th May 1999 by Paul Johnson + +my $File; + +BEGIN +{ + $File = __FILE__; + if (-d 't') + { + chdir 't'; + $File =~ s/^t\W+//; # Remove first directory + } + unshift @INC, '../lib' if -d '../lib'; + require strict; import strict; +} + +use Test; + +BEGIN { plan tests => 12 } + +use IO::File; + +sub lineno +{ + my ($f) = @_; + my $l; + $l .= "$. "; + $l .= $f->input_line_number; + $l .= " $."; # check $. before and after input_line_number + $l; +} + +my $t; + +open (F, $File) or die $!; +my $io = IO::File->new($File) or die $!; + +<F> for (1 .. 10); +ok(lineno($io), "10 0 10"); + +$io->getline for (1 .. 5); +ok(lineno($io), "5 5 5"); + +<F>; +ok(lineno($io), "11 5 11"); + +$io->getline; +ok(lineno($io), "6 6 6"); + +$t = tell F; # tell F; provokes a warning +ok(lineno($io), "11 6 11"); + +<F>; +ok(lineno($io), "12 6 12"); + +select F; +ok(lineno($io), "12 6 12"); + +<F> for (1 .. 10); +ok(lineno($io), "22 6 22"); + +$io->getline for (1 .. 5); +ok(lineno($io), "11 11 11"); + +$t = tell F; +# We used to have problems here before local $. worked. +# input_line_number() used to use select and tell. When we did the +# same, that mechanism broke. It should work now. +ok(lineno($io), "22 11 22"); + +{ + local $.; + $io->getline for (1 .. 5); + ok(lineno($io), "16 16 16"); +} + +ok(lineno($io), "22 16 22"); diff --git a/contrib/perl5/t/lib/io_multihomed.t b/contrib/perl5/t/lib/io_multihomed.t new file mode 100755 index 0000000..7337a5f --- /dev/null +++ b/contrib/perl5/t/lib/io_multihomed.t @@ -0,0 +1,124 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + unshift @INC, '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + my $reason; + if (! $Config{'d_fork'}) { + $reason = 'no fork'; + } + elsif ($Config{'extensions'} !~ /\bSocket\b/) { + $reason = 'Socket extension unavailable'; + } + elsif ($Config{'extensions'} !~ /\bIO\b/) { + $reason = 'IO extension unavailable'; + } + if ($reason) { + print "1..0 # Skip: $reason\n"; + exit 0; + } + } +} + +$| = 1; + +print "1..8\n"; + + +package Multi; +require IO::Socket::INET; +@ISA=qw(IO::Socket::INET); + +use Socket qw(inet_aton inet_ntoa unpack_sockaddr_in); + +sub _get_addr +{ + my($sock,$addr_str, $multi) = @_; + #print "_get_addr($sock, $addr_str, $multi)\n"; + + print "not " unless $multi; + print "ok 2\n"; + + ( + # private IP-addresses which I hope does not work anywhere :-) + inet_aton("10.250.230.10"), + inet_aton("10.250.230.12"), + inet_aton("127.0.0.1") # loopback + ) +} + +sub connect +{ + my $self = shift; + if (@_ == 1) { + my($port, $addr) = unpack_sockaddr_in($_[0]); + $addr = inet_ntoa($addr); + #print "connect($self, $port, $addr)\n"; + if($addr eq "10.250.230.10") { + print "ok 3\n"; + return 0; + } + if($addr eq "10.250.230.12") { + print "ok 4\n"; + return 0; + } + } + $self->SUPER::connect(@_); +} + + + +package main; + +use IO::Socket; + +$listen = IO::Socket::INET->new(Listen => 2, + Proto => 'tcp', + Timeout => 5, + ) or die "$!"; + +print "ok 1\n"; + +$port = $listen->sockport; + +if($pid = fork()) { + + $sock = $listen->accept() or die "$!"; + print "ok 5\n"; + + print $sock->getline(); + print $sock "ok 7\n"; + + waitpid($pid,0); + + $sock->close; + + print "ok 8\n"; + +} elsif(defined $pid) { + + $sock = Multi->new(PeerPort => $port, + Proto => 'tcp', + PeerAddr => 'localhost', + MultiHomed => 1, + Timeout => 1, + ) or die "$!"; + + print $sock "ok 6\n"; + sleep(1); # race condition + print $sock->getline(); + + $sock->close; + + exit; +} else { + die; +} diff --git a/contrib/perl5/t/lib/io_pipe.t b/contrib/perl5/t/lib/io_pipe.t index e617c92..bcb89a0 100755 --- a/contrib/perl5/t/lib/io_pipe.t +++ b/contrib/perl5/t/lib/io_pipe.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } } @@ -11,10 +11,16 @@ use Config; BEGIN { if(-d "lib" && -f "TEST") { - if (! $Config{'d_fork'} || - ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS')) - { - print "1..0\n"; + my $reason; + if (! $Config{'d_fork'}) { + $reason = 'no fork'; + } + elsif ($Config{'extensions'} !~ /\bIO\b/) { + $reason = 'IO extension unavailable'; + } + undef $reason if $^O eq 'VMS'; + if ($reason) { + print "1..0 # Skip: $reason\n"; exit 0; } } diff --git a/contrib/perl5/t/lib/io_poll.t b/contrib/perl5/t/lib/io_poll.t new file mode 100755 index 0000000..68ad7b7 --- /dev/null +++ b/contrib/perl5/t/lib/io_poll.t @@ -0,0 +1,77 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + unshift @INC, '../lib' if -d '../lib'; + } +} + +if ($^O eq 'mpeix') { + print "1..0 # Skip: broken on MPE/iX\n"; + exit 0; +} + +select(STDERR); $| = 1; +select(STDOUT); $| = 1; + +print "1..8\n"; + +use IO::Handle; +use IO::Poll qw(/POLL/); + +my $poll = new IO::Poll; + +my $stdout = \*STDOUT; +my $dupout = IO::Handle->new_from_fd(fileno($stdout),"w"); + +$poll->mask($stdout => POLLOUT); + +print "not " + unless $poll->mask($stdout) == POLLOUT; +print "ok 1\n"; + +$poll->mask($dupout => POLLPRI); + +print "not " + unless $poll->mask($dupout) == POLLPRI; +print "ok 2\n"; + +$poll->poll(0.1); + +if ($^O eq 'MSWin32') { +print "ok 3 # skipped, doesn't work on non-socket fds\n"; +print "ok 4 # skipped, doesn't work on non-socket fds\n"; +} +else { +print "not " + unless $poll->events($stdout) == POLLOUT; +print "ok 3\n"; + +print "not " + if $poll->events($dupout); +print "ok 4\n"; +} + +my @h = $poll->handles; +print "not " + unless @h == 2; +print "ok 5\n"; + +$poll->remove($stdout); + +@h = $poll->handles; + +print "not " + unless @h == 1; +print "ok 6\n"; + +print "not " + if $poll->mask($stdout); +print "ok 7\n"; + +$poll->poll(0.1); + +print "not " + if $poll->events($stdout); +print "ok 8\n"; diff --git a/contrib/perl5/t/lib/io_sel.t b/contrib/perl5/t/lib/io_sel.t index 3dc651b..85e14ab 100755 --- a/contrib/perl5/t/lib/io_sel.t +++ b/contrib/perl5/t/lib/io_sel.t @@ -3,14 +3,14 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } } select(STDERR); $| = 1; select(STDOUT); $| = 1; -print "1..21\n"; +print "1..23\n"; use IO::Select 1.09; @@ -114,3 +114,19 @@ print "ok 20\n"; $sel->remove($sel->handles); print "not " unless $sel->count == 0 && !defined($sel->bits); print "ok 21\n"; + +# check warnings +$SIG{__WARN__} = sub { + ++ $w + if $_[0] =~ /^Call to depreciated method 'has_error', use 'has_exception'/ + } ; +$w = 0 ; +IO::Select::has_error(); +print "not " unless $w == 0 ; +$w = 0 ; +print "ok 22\n" ; +use warnings 'IO::Select' ; +IO::Select::has_error(); +print "not " unless $w == 1 ; +$w = 0 ; +print "ok 23\n" ; diff --git a/contrib/perl5/t/lib/io_sock.t b/contrib/perl5/t/lib/io_sock.t index 8fc52e4..056d131f 100755 --- a/contrib/perl5/t/lib/io_sock.t +++ b/contrib/perl5/t/lib/io_sock.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } } @@ -11,23 +11,34 @@ use Config; BEGIN { if (-d "lib" && -f "TEST") { - if (!$Config{'d_fork'} || - (($Config{'extensions'} !~ /\bSocket\b/ || - $Config{'extensions'} !~ /\bIO\b/) && - !(($^O eq 'VMS') && $Config{d_socket}))) { - print "1..0\n"; + my $reason; + if (! $Config{'d_fork'}) { + $reason = 'no fork'; + } + elsif ($Config{'extensions'} !~ /\bSocket\b/) { + $reason = 'Socket extension unavailable'; + } + elsif ($Config{'extensions'} !~ /\bIO\b/) { + $reason = 'IO extension unavailable'; + } + undef $reason if $^O eq 'VMS' and $Config{d_socket}; + if ($reason) { + print "1..0 # Skip: $reason\n"; exit 0; } } } $| = 1; -print "1..5\n"; +print "1..14\n"; use IO::Socket; $listen = IO::Socket::INET->new(Listen => 2, Proto => 'tcp', + # some systems seem to need as much as 10, + # so be generous with the timeout + Timeout => 15, ) or die "$!"; print "ok 1\n"; @@ -43,7 +54,7 @@ $port = $listen->sockport; if($pid = fork()) { - $sock = $listen->accept(); + $sock = $listen->accept() or die "accept failed: $!"; print "ok 2\n"; $sock->autoflush(1); @@ -69,7 +80,7 @@ if($pid = fork()) { Proto => 'tcp', PeerAddr => 'localhost' ) - or die "$! (maybe your system does not have the 'localhost' address defined)"; + or die "$! (maybe your system does not have the 'localhost' address defined)"; $sock->autoflush(1); @@ -84,8 +95,103 @@ if($pid = fork()) { die; } +# Test various other ways to create INET sockets that should +# also work. +$listen = IO::Socket::INET->new(Listen => '', Timeout => 15) or die "$!"; +$port = $listen->sockport; + +if($pid = fork()) { + SERVER_LOOP: + while (1) { + last SERVER_LOOP unless $sock = $listen->accept; + while (<$sock>) { + last SERVER_LOOP if /^quit/; + last if /^done/; + print; + } + $sock = undef; + } + $listen->close; +} elsif (defined $pid) { + # child, try various ways to connect + $sock = IO::Socket::INET->new("localhost:$port"); + if ($sock) { + print "not " unless $sock->connected; + print "ok 6\n"; + $sock->print("ok 7\n"); + sleep(1); + print "ok 8\n"; + $sock->print("ok 9\n"); + $sock->print("done\n"); + $sock->close; + } + else { + print "# $@\n"; + print "not ok 6\n"; + print "not ok 7\n"; + print "not ok 8\n"; + print "not ok 9\n"; + } + + # some machines seem to suffer from a race condition here + sleep(2); + + $sock = IO::Socket::INET->new("127.0.0.1:$port"); + if ($sock) { + $sock->print("ok 10\n"); + $sock->print("done\n"); + $sock->close; + } + else { + print "# $@\n"; + print "not ok 10\n"; + } + # some machines seem to suffer from a race condition here + sleep(1); + $sock = IO::Socket->new(Domain => AF_INET, + PeerAddr => "localhost:$port"); + if ($sock) { + $sock->print("ok 11\n"); + $sock->print("quit\n"); + } + $sock = undef; + sleep(1); + exit; +} else { + die; +} +# Then test UDP sockets +$server = IO::Socket->new(Domain => AF_INET, + Proto => 'udp', + LocalAddr => 'localhost'); +$port = $server->sockport; + +if ($^O eq 'mpeix') { + print("ok 12 # skipped\n") +} else { + if ($pid = fork()) { + my $buf; + $server->recv($buf, 100); + print $buf; + } elsif (defined($pid)) { + #child + $sock = IO::Socket::INET->new(Proto => 'udp', + PeerAddr => "localhost:$port"); + $sock->send("ok 12\n"); + sleep(1); + $sock->send("ok 12\n"); # send another one to be sure + exit; + } else { + die; + } +} +print "not " unless $server->blocking; +print "ok 13\n"; +$server->blocking(0); +print "not " if $server->blocking; +print "ok 14\n"; diff --git a/contrib/perl5/t/lib/io_taint.t b/contrib/perl5/t/lib/io_taint.t index 0ef2cfd..deaa6c7 100755 --- a/contrib/perl5/t/lib/io_taint.t +++ b/contrib/perl5/t/lib/io_taint.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } } diff --git a/contrib/perl5/t/lib/io_tell.t b/contrib/perl5/t/lib/io_tell.t index 2009d61..8d75242 100755 --- a/contrib/perl5/t/lib/io_tell.t +++ b/contrib/perl5/t/lib/io_tell.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; $tell_file = "TEST"; } else { diff --git a/contrib/perl5/t/lib/io_udp.t b/contrib/perl5/t/lib/io_udp.t index ad2632d..3d5145e 100755 --- a/contrib/perl5/t/lib/io_udp.t +++ b/contrib/perl5/t/lib/io_udp.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } } @@ -11,18 +11,48 @@ use Config; BEGIN { if(-d "lib" && -f "TEST") { - if ( ($Config{'extensions'} !~ /\bSocket\b/ || - $Config{'extensions'} !~ /\bIO\b/ || - ($^O eq 'os2') || $^O eq 'apollo') && - !(($^O eq 'VMS') && $Config{d_socket})) { - print "1..0\n"; + my $reason; + + if ($Config{'extensions'} !~ /\bSocket\b/) { + $reason = 'Socket was not built'; + } + elsif ($Config{'extensions'} !~ /\bIO\b/) { + $reason = 'IO was not built'; + } + elsif ($^O eq 'apollo') { + $reason = "unknown *FIXME*"; + } + undef $reason if $^O eq 'VMS' and $Config{d_socket}; + if ($reason) { + print "1..0 # Skip: $reason\n"; exit 0; - } + } + } +} + +sub compare_addr { + no utf8; + my $a = shift; + my $b = shift; + if (length($a) != length $b) { + my $min = (length($a) < length $b) ? length($a) : length $b; + if ($min and substr($a, 0, $min) eq substr($b, 0, $min)) { + printf "# Apparently: %d bytes junk at the end of %s\n# %s\n", + abs(length($a) - length ($b)), + $_[length($a) < length ($b) ? 1 : 0], + "consider decreasing bufsize of recfrom."; + substr($a, $min) = ""; + substr($b, $min) = ""; + } + return 0; } + my @a = unpack_sockaddr_in($a); + my @b = unpack_sockaddr_in($b); + "$a[0]$a[1]" eq "$b[0]$b[1]"; } $| = 1; -print "1..3\n"; +print "1..7\n"; use Socket; use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY); @@ -35,14 +65,34 @@ use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY); $udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost') or die "$! (maybe your system does not have the 'localhost' address defined)"; + +print "ok 1\n"; + $udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost') or die "$! (maybe your system does not have the 'localhost' address defined)"; -print "ok 1\n"; +print "ok 2\n"; -$udpa->send("ok 2\n",0,$udpb->sockname); -$udpb->recv($buf="",5); +$udpa->send("ok 4\n",0,$udpb->sockname); + +print "not " + unless compare_addr($udpa->peername,$udpb->sockname, 'peername', 'sockname'); +print "ok 3\n"; + +my $where = $udpb->recv($buf="",5); print $buf; -$udpb->send("ok 3\n"); + +my @xtra = (); + +unless(compare_addr($where,$udpa->sockname, 'recv name', 'sockname')) { + print "not "; + @xtra = (0,$udpa->sockname); +} +print "ok 5\n"; + +$udpb->send("ok 6\n",@xtra); $udpa->recv($buf="",5); print $buf; + +print "not " if $udpa->connected; +print "ok 7\n"; diff --git a/contrib/perl5/t/lib/io_unix.t b/contrib/perl5/t/lib/io_unix.t new file mode 100755 index 0000000..247647a --- /dev/null +++ b/contrib/perl5/t/lib/io_unix.t @@ -0,0 +1,89 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + unshift @INC, '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + my $reason; + if (! $Config{'d_fork'}) { + $reason = 'no fork'; + } + elsif ($Config{'extensions'} !~ /\bSocket\b/) { + $reason = 'Socket extension unavailable'; + } + elsif ($Config{'extensions'} !~ /\bIO\b/) { + $reason = 'IO extension unavailable'; + } + elsif ($^O eq 'os2') { + require IO::Socket; + + eval {IO::Socket::pack_sockaddr_un('/tmp/foo') || 1} + or $@ !~ /not implemented/ or + $reason = 'compiled without TCP/IP stack v4'; + } elsif ($^O eq 'qnx') { + $reason = 'Not implemented'; + } + undef $reason if $^O eq 'VMS' and $Config{d_socket}; + if ($reason) { + print "1..0 # Skip: $reason\n"; + exit 0; + } + } +} + +$PATH = "/tmp/sock-$$"; + +# Test if we can create the file within the tmp directory +if (-e $PATH or not open(TEST, ">$PATH") and $^O ne 'os2') { + print "1..0 # Skip: cannot open '$PATH' for write\n"; + exit 0; +} +close(TEST); +unlink($PATH) or $^O eq 'os2' or die "Can't unlink $PATH: $!"; + +# Start testing +$| = 1; +print "1..5\n"; + +use IO::Socket; + +$listen = IO::Socket::UNIX->new(Local=>$PATH, Listen=>0) || die "$!"; +print "ok 1\n"; + +if($pid = fork()) { + + $sock = $listen->accept(); + print "ok 2\n"; + + print $sock->getline(); + + print $sock "ok 4\n"; + + $sock->close; + + waitpid($pid,0); + unlink($PATH) || $^O eq 'os2' || warn "Can't unlink $PATH: $!"; + + print "ok 5\n"; + +} elsif(defined $pid) { + + $sock = IO::Socket::UNIX->new(Peer => $PATH) or die "$!"; + + print $sock "ok 3\n"; + + print $sock->getline(); + + $sock->close; + + exit; +} else { + die; +} diff --git a/contrib/perl5/t/lib/io_xs.t b/contrib/perl5/t/lib/io_xs.t index 1a6fd38..6bbba16 100755 --- a/contrib/perl5/t/lib/io_xs.t +++ b/contrib/perl5/t/lib/io_xs.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } } diff --git a/contrib/perl5/t/lib/ipc_sysv.t b/contrib/perl5/t/lib/ipc_sysv.t index 30ea48d..a4f3e3f 100755 --- a/contrib/perl5/t/lib/ipc_sysv.t +++ b/contrib/perl5/t/lib/ipc_sysv.t @@ -3,22 +3,27 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; require Config; import Config; - unless ($Config{'d_msg'} eq 'define' && - $Config{'d_sem'} eq 'define') { - print "1..0\n"; - exit; + my $reason; + + if ($Config{'d_sem'} ne 'define') { + $reason = '$Config{d_sem} undefined'; + } elsif ($Config{'d_msg'} ne 'define') { + $reason = '$Config{d_msg} undefined'; + } + if ($reason) { + print "1..0 # Skip: $reason\n"; + exit 0; } } # These constants are common to all tests. # Later the sem* tests will import more for themselves. -use IPC::SysV qw(IPC_PRIVATE IPC_NOWAIT IPC_STAT IPC_RMID - S_IRWXU S_IRWXG S_IRWXO); +use IPC::SysV qw(IPC_PRIVATE IPC_NOWAIT IPC_STAT IPC_RMID S_IRWXU); use strict; print "1..16\n"; @@ -49,11 +54,14 @@ EOM exit(1); }; +my $perm = S_IRWXU; + if ($Config{'d_msgget'} eq 'define' && $Config{'d_msgctl'} eq 'define' && $Config{'d_msgsnd'} eq 'define' && $Config{'d_msgrcv'} eq 'define') { - $msg = msgget(IPC_PRIVATE, S_IRWXU | S_IRWXG | S_IRWXO); + + $msg = msgget(IPC_PRIVATE, $perm); # Very first time called after machine is booted value may be 0 die "msgget failed: $!\n" unless defined($msg) && $msg >= 0; @@ -63,8 +71,34 @@ if ($Config{'d_msgget'} eq 'define' && my $msgtype = 1; my $msgtext = "hello"; - msgsnd($msg,pack("L a*",$msgtype,$msgtext),0) or print "not "; + my $test2bad; + my $test5bad; + my $test6bad; + + unless (msgsnd($msg,pack("L! a*",$msgtype,$msgtext),IPC_NOWAIT)) { + print "not "; + $test2bad = 1; + } print "ok 2\n"; + if ($test2bad) { + print <<EOM; +# +# The failure of the subtest #2 may indicate that the message queue +# resource limits either of the system or of the testing account +# have been reached. Error message "Operating would block" is +# usually indicative of this situation. The error message was now: +# "$!" +# +# You can check the message queues with the 'ipcs' command and +# you can remove unneeded queues with the 'ipcrm -q id' command. +# You may also consider configuring your system or account +# to have more message queue resources. +# +# Because of the subtest #2 failing also the substests #5 and #6 will +# very probably also fail. +# +EOM + } my $data; msgctl($msg,IPC_STAT,$data) or print "not "; @@ -74,13 +108,33 @@ if ($Config{'d_msgget'} eq 'define' && print "ok 4\n"; my $msgbuf; - msgrcv($msg,$msgbuf,256,0,IPC_NOWAIT) or print "not "; + unless (msgrcv($msg,$msgbuf,256,0,IPC_NOWAIT)) { + print "not "; + $test5bad = 1; + } print "ok 5\n"; + if ($test5bad && $test2bad) { + print <<EOM; +# +# This failure was to be expected because the subtest #2 failed. +# +EOM + } - my($rmsgtype,$rmsgtext) = unpack("L a*",$msgbuf); - - print "not " unless($rmsgtype == $msgtype && $rmsgtext eq $msgtext); + my($rmsgtype,$rmsgtext); + ($rmsgtype,$rmsgtext) = unpack("L! a*",$msgbuf); + unless ($rmsgtype == $msgtype && $rmsgtext eq $msgtext) { + print "not "; + $test6bad = 1; + } print "ok 6\n"; + if ($test6bad && $test2bad) { + print <<EOM; +# +# This failure was to be expected because the subtest #2 failed. +# +EOM + } } else { for (1..6) { print "ok $_\n"; # fake it @@ -90,80 +144,64 @@ if ($Config{'d_msgget'} eq 'define' && if($Config{'d_semget'} eq 'define' && $Config{'d_semctl'} eq 'define') { - use IPC::SysV qw(IPC_CREAT GETALL SETALL); + if ($Config{'d_semctl_semid_ds'} eq 'define' || + $Config{'d_semctl_semun'} eq 'define') { - $sem = semget(IPC_PRIVATE, 10, S_IRWXU | S_IRWXG | S_IRWXO | IPC_CREAT); - # Very first time called after machine is booted value may be 0 - die "semget: $!\n" unless defined($sem) && $sem >= 0; + use IPC::SysV qw(IPC_CREAT GETALL SETALL); - print "ok 7\n"; + $sem = semget(IPC_PRIVATE, 10, $perm | IPC_CREAT); + # Very first time called after machine is booted value may be 0 + die "semget: $!\n" unless defined($sem) && $sem >= 0; - my $data; - semctl($sem,0,IPC_STAT,$data) or print "not "; - print "ok 8\n"; + print "ok 7\n"; - print "not " unless length($data); - print "ok 9\n"; - - my $template; - - # Find the pack/unpack template capable of handling native C shorts. - - if ($Config{shortsize} == 2) { - $template = "s"; - } elsif ($Config{shortsize} == 4) { - $template = "l"; - } elsif ($Config{shortsize} == 8) { - # Try quad last because not supported everywhere. - foreach my $t (qw(i q)) { - # We could trap the unsupported quad template with eval - # but if we get this far we should have quad support anyway. - if (length(pack($t, 0)) == 8) { - $template = $t; - last; - } - } - } - - die "$0: cannot pack native shorts\n" unless defined $template; - - $template .= "*"; + my $data; + semctl($sem,0,IPC_STAT,$data) or print "not "; + print "ok 8\n"; + + print "not " unless length($data); + print "ok 9\n"; - my $nsem = 10; + my $nsem = 10; - semctl($sem,0,SETALL,pack($template,(0) x $nsem)) or print "not "; - print "ok 10\n"; + semctl($sem,0,SETALL,pack("s!*",(0) x $nsem)) or print "not "; + print "ok 10\n"; - $data = ""; - semctl($sem,0,GETALL,$data) or print "not "; - print "ok 11\n"; + $data = ""; + semctl($sem,0,GETALL,$data) or print "not "; + print "ok 11\n"; - print "not " unless length($data) == length(pack($template,(0) x $nsem)); - print "ok 12\n"; + print "not " unless length($data) == length(pack("s!*",(0) x $nsem)); + print "ok 12\n"; - my @data = unpack($template,$data); + my @data = unpack("s!*",$data); - my $adata = "0" x $nsem; + my $adata = "0" x $nsem; - print "not " unless @data == $nsem and join("",@data) eq $adata; - print "ok 13\n"; + print "not " unless @data == $nsem and join("",@data) eq $adata; + print "ok 13\n"; - my $poke = 2; + my $poke = 2; - $data[$poke] = 1; - semctl($sem,0,SETALL,pack($template,@data)) or print "not "; - print "ok 14\n"; + $data[$poke] = 1; + semctl($sem,0,SETALL,pack("s!*",@data)) or print "not "; + print "ok 14\n"; - $data = ""; - semctl($sem,0,GETALL,$data) or print "not "; - print "ok 15\n"; + $data = ""; + semctl($sem,0,GETALL,$data) or print "not "; + print "ok 15\n"; - @data = unpack($template,$data); + @data = unpack("s!*",$data); - my $bdata = "0" x $poke . "1" . "0" x ($nsem-$poke-1); + my $bdata = "0" x $poke . "1" . "0" x ($nsem-$poke-1); - print "not " unless join("",@data) eq $bdata; - print "ok 16\n"; + print "not " unless join("",@data) eq $bdata; + print "ok 16\n"; + } else { + for (7..16) { + print "ok $_ # skipped, no semctl possible\n"; + } + } } else { for (7..16) { print "ok $_\n"; # fake it diff --git a/contrib/perl5/t/lib/ndbm.t b/contrib/perl5/t/lib/ndbm.t index a97dbd1..39c3f40 100755 --- a/contrib/perl5/t/lib/ndbm.t +++ b/contrib/perl5/t/lib/ndbm.t @@ -4,10 +4,10 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bNDBM_File\b/) { - print "1..0\n"; + print "1..0 # Skip: NDBM_File was not built\n"; exit 0; } } @@ -16,7 +16,7 @@ require NDBM_File; #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT use Fcntl; -print "1..18\n"; +print "1..64\n"; unlink <Op.dbmx*>; @@ -205,3 +205,189 @@ EOM unlink "SubDB.pm", <dbhash.tmp*> ; } + +{ + # DBM Filter tests + use strict ; + my (%h, $db) ; + my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + + sub checkOutput + { + my($fk, $sk, $fv, $sv) = @_ ; + return + $fetch_key eq $fk && $store_key eq $sk && + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; + } + + unlink <Op.dbmx*>; + ok(19, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ; + + $db->filter_fetch_key (sub { $fetch_key = $_ }) ; + $db->filter_store_key (sub { $store_key = $_ }) ; + $db->filter_fetch_value (sub { $fetch_value = $_}) ; + $db->filter_store_value (sub { $store_value = $_ }) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + # fk sk fv sv + ok(20, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(21, $h{"fred"} eq "joe"); + # fk sk fv sv + ok(22, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(23, $db->FIRSTKEY() eq "fred") ; + # fk sk fv sv + ok(24, checkOutput( "fred", "", "", "")) ; + + # replace the filters, but remember the previous set + my ($old_fk) = $db->filter_fetch_key + (sub { $_ = uc $_ ; $fetch_key = $_ }) ; + my ($old_sk) = $db->filter_store_key + (sub { $_ = lc $_ ; $store_key = $_ }) ; + my ($old_fv) = $db->filter_fetch_value + (sub { $_ = "[$_]"; $fetch_value = $_ }) ; + my ($old_sv) = $db->filter_store_value + (sub { s/o/x/g; $store_value = $_ }) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"Fred"} = "Joe" ; + # fk sk fv sv + ok(25, checkOutput( "", "fred", "", "Jxe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(26, $h{"Fred"} eq "[Jxe]"); + # fk sk fv sv + ok(27, checkOutput( "", "fred", "[Jxe]", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(28, $db->FIRSTKEY() eq "FRED") ; + # fk sk fv sv + ok(29, checkOutput( "FRED", "", "", "")) ; + + # put the original filters back + $db->filter_fetch_key ($old_fk); + $db->filter_store_key ($old_sk); + $db->filter_fetch_value ($old_fv); + $db->filter_store_value ($old_sv); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(30, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(31, $h{"fred"} eq "joe"); + ok(32, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(33, $db->FIRSTKEY() eq "fred") ; + ok(34, checkOutput( "fred", "", "", "")) ; + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(35, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(36, $h{"fred"} eq "joe"); + ok(37, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(38, $db->FIRSTKEY() eq "fred") ; + ok(39, checkOutput( "", "", "", "")) ; + + undef $db ; + untie %h; + unlink <Op.dbmx*>; +} + +{ + # DBM Filter with a closure + + use strict ; + my (%h, $db) ; + + unlink <Op.dbmx*>; + ok(40, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ; + + my %result = () ; + + sub Closure + { + my ($name) = @_ ; + my $count = 0 ; + my @kept = () ; + + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } + } + + $db->filter_store_key(Closure("store key")) ; + $db->filter_store_value(Closure("store value")) ; + $db->filter_fetch_key(Closure("fetch key")) ; + $db->filter_fetch_value(Closure("fetch value")) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + ok(41, $result{"store key"} eq "store key - 1: [fred]"); + ok(42, $result{"store value"} eq "store value - 1: [joe]"); + ok(43, !defined $result{"fetch key"} ); + ok(44, !defined $result{"fetch value"} ); + ok(45, $_ eq "original") ; + + ok(46, $db->FIRSTKEY() eq "fred") ; + ok(47, $result{"store key"} eq "store key - 1: [fred]"); + ok(48, $result{"store value"} eq "store value - 1: [joe]"); + ok(49, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(50, ! defined $result{"fetch value"} ); + ok(51, $_ eq "original") ; + + $h{"jim"} = "john" ; + ok(52, $result{"store key"} eq "store key - 2: [fred jim]"); + ok(53, $result{"store value"} eq "store value - 2: [joe john]"); + ok(54, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(55, $result{"fetch value"} eq ""); + ok(56, $_ eq "original") ; + + ok(57, $h{"fred"} eq "joe"); + ok(58, $result{"store key"} eq "store key - 3: [fred jim fred]"); + ok(59, $result{"store value"} eq "store value - 2: [joe john]"); + ok(60, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(61, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(62, $_ eq "original") ; + + undef $db ; + untie %h; + unlink <Op.dbmx*>; +} + +{ + # DBM Filter recursion detection + use strict ; + my (%h, $db) ; + unlink <Op.dbmx*>; + + ok(63, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ; + + $db->filter_store_key (sub { $_ = $h{$_} }) ; + + eval '$h{1} = 1234' ; + ok(64, $@ =~ /^recursion detected in filter_store_key at/ ); + + undef $db ; + untie %h; + unlink <Op.dbmx*>; +} diff --git a/contrib/perl5/t/lib/odbm.t b/contrib/perl5/t/lib/odbm.t index 8ba9bcf..f8b8a11 100755 --- a/contrib/perl5/t/lib/odbm.t +++ b/contrib/perl5/t/lib/odbm.t @@ -4,10 +4,10 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bODBM_File\b/) { - print "1..0\n"; + print "1..0 # Skip: ODBM_File was not built\n"; exit 0; } } @@ -16,7 +16,7 @@ require ODBM_File; #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT use Fcntl; -print "1..18\n"; +print "1..64\n"; unlink <Op.dbmx*>; @@ -205,3 +205,202 @@ EOM unlink "SubDB.pm", <dbhash.tmp*> ; } + +{ + # DBM Filter tests + use strict ; + my (%h, $db) ; + my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + + sub checkOutput + { + my($fk, $sk, $fv, $sv) = @_ ; + print "# ", join('|', $fetch_key, $fk, $store_key, $sk, + $fetch_value, $fv, $store_value, $sv, $_), "\n"; + return + $fetch_key eq $fk && $store_key eq $sk && + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; + } + + unlink <Op.dbmx*>; + ok(19, $db = tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ; + + $db->filter_fetch_key (sub { $fetch_key = $_ }) ; + $db->filter_store_key (sub { $store_key = $_ }) ; + $db->filter_fetch_value (sub { $fetch_value = $_}) ; + $db->filter_store_value (sub { $store_value = $_ }) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + # fk sk fv sv + ok(20, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(21, $h{"fred"} eq "joe"); + # fk sk fv sv + ok(22, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(23, $db->FIRSTKEY() eq "fred") ; + # fk sk fv sv + ok(24, checkOutput( "fred", "", "", "")) ; + + # replace the filters, but remember the previous set + my ($old_fk) = $db->filter_fetch_key + (sub { $_ = uc $_ ; $fetch_key = $_ }) ; + my ($old_sk) = $db->filter_store_key + (sub { $_ = lc $_ ; $store_key = $_ }) ; + my ($old_fv) = $db->filter_fetch_value + (sub { $_ = "[$_]"; $fetch_value = $_ }) ; + my ($old_sv) = $db->filter_store_value + (sub { s/o/x/g; $store_value = $_ }) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"Fred"} = "Joe" ; + # fk sk fv sv + ok(25, checkOutput( "", "fred", "", "Jxe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(26, $h{"Fred"} eq "[Jxe]"); + # fk sk fv sv + ok(27, checkOutput( "", "fred", "[Jxe]", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(28, $db->FIRSTKEY() eq "FRED") ; + # fk sk fv sv + ok(29, checkOutput( "FRED", "", "", "")) ; + + # put the original filters back + $db->filter_fetch_key ($old_fk); + $db->filter_store_key ($old_sk); + $db->filter_fetch_value ($old_fv); + $db->filter_store_value ($old_sv); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(30, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(31, $h{"fred"} eq "joe"); + ok(32, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(33, $db->FIRSTKEY() eq "fred") ; + ok(34, checkOutput( "fred", "", "", "")) ; + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(35, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(36, $h{"fred"} eq "joe"); + ok(37, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(38, $db->FIRSTKEY() eq "fred") ; + ok(39, checkOutput( "", "", "", "")) ; + + undef $db ; + untie %h; + unlink <Op.dbmx*>; +} + +{ + # DBM Filter with a closure + + use strict ; + my (%h, $db) ; + + unlink <Op.dbmx*>; + ok(40, $db = tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ; + + my %result = () ; + + sub Closure + { + my ($name) = @_ ; + my $count = 0 ; + my @kept = () ; + + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } + } + + $db->filter_store_key(Closure("store key")) ; + $db->filter_store_value(Closure("store value")) ; + $db->filter_fetch_key(Closure("fetch key")) ; + $db->filter_fetch_value(Closure("fetch value")) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + ok(41, $result{"store key"} eq "store key - 1: [fred]"); + ok(42, $result{"store value"} eq "store value - 1: [joe]"); + ok(43, !defined $result{"fetch key"} ); + ok(44, !defined $result{"fetch value"} ); + ok(45, $_ eq "original") ; + + ok(46, $db->FIRSTKEY() eq "fred") ; + ok(47, $result{"store key"} eq "store key - 1: [fred]"); + ok(48, $result{"store value"} eq "store value - 1: [joe]"); + ok(49, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(50, ! defined $result{"fetch value"} ); + ok(51, $_ eq "original") ; + + $h{"jim"} = "john" ; + ok(52, $result{"store key"} eq "store key - 2: [fred jim]"); + ok(53, $result{"store value"} eq "store value - 2: [joe john]"); + ok(54, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(55, $result{"fetch value"} eq ""); + ok(56, $_ eq "original") ; + + ok(57, $h{"fred"} eq "joe"); + ok(58, $result{"store key"} eq "store key - 3: [fred jim fred]"); + ok(59, $result{"store value"} eq "store value - 2: [joe john]"); + ok(60, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(61, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(62, $_ eq "original") ; + + undef $db ; + untie %h; + unlink <Op.dbmx*>; +} + +{ + # DBM Filter recursion detection + use strict ; + my (%h, $db) ; + unlink <Op.dbmx*>; + + ok(63, $db = tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ; + + $db->filter_store_key (sub { $_ = $h{$_} }) ; + + eval '$h{1} = 1234' ; + ok(64, $@ =~ /^recursion detected in filter_store_key at/ ); + + undef $db ; + untie %h; + unlink <Op.dbmx*>; +} + +if ($^O eq 'hpux') { + print <<EOM; +# +# If you experience failures with the odbm test in HP-UX, +# this is a well-known bug that's unfortunately very hard to fix. +# The suggested course of action is to avoid using the ODBM_File, +# but to use instead the NDBM_File extension. +# +EOM +} diff --git a/contrib/perl5/t/lib/opcode.t b/contrib/perl5/t/lib/opcode.t index a785fce..f83a689 100755 --- a/contrib/perl5/t/lib/opcode.t +++ b/contrib/perl5/t/lib/opcode.t @@ -4,7 +4,7 @@ $|=1; BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { print "1..0\n"; diff --git a/contrib/perl5/t/lib/open2.t b/contrib/perl5/t/lib/open2.t index 85b807c..6443112 100755 --- a/contrib/perl5/t/lib/open2.t +++ b/contrib/perl5/t/lib/open2.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; require Config; import Config; if (!$Config{'d_fork'} # open2/3 supported on win32 (but not Borland due to CRT bugs) diff --git a/contrib/perl5/t/lib/open3.t b/contrib/perl5/t/lib/open3.t index b84dac9..7cd0ca3 100755 --- a/contrib/perl5/t/lib/open3.t +++ b/contrib/perl5/t/lib/open3.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; require Config; import Config; if (!$Config{'d_fork'} # open2/3 supported on win32 (but not Borland due to CRT bugs) @@ -49,7 +49,7 @@ my ($pid, $reaped_pid); STDOUT->autoflush; STDERR->autoflush; -print "1..21\n"; +print "1..22\n"; # basic ok 1, $pid = open3 'WRITE', 'READ', 'ERROR', $perl, '-e', cmd_line(<<'EOF'); @@ -134,3 +134,17 @@ EOF print WRITE "ok 20\n"; print WRITE "ok 21\n"; waitpid $pid, 0; + +# command line in single parameter variant of open3 +# for understanding of Config{'sh'} test see exec description in camel book +my $cmd = 'print(scalar(<STDIN>))'; +$cmd = $Config{'sh'} =~ /sh/ ? "'$cmd'" : cmd_line($cmd); +eval{$pid = open3 'WRITE', '>&STDOUT', 'ERROR', "$perl -e " . $cmd; }; +if ($@) { + print "error $@\n"; + print "not ok 22\n"; +} +else { + print WRITE "ok 22\n"; + waitpid $pid, 0; +} diff --git a/contrib/perl5/t/lib/ops.t b/contrib/perl5/t/lib/ops.t index 56b1bac..ce8b6d0 100755 --- a/contrib/perl5/t/lib/ops.t +++ b/contrib/perl5/t/lib/ops.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { print "1..0\n"; diff --git a/contrib/perl5/t/lib/parsewords.t b/contrib/perl5/t/lib/parsewords.t index 3c5e75b..2c936f1 100755 --- a/contrib/perl5/t/lib/parsewords.t +++ b/contrib/perl5/t/lib/parsewords.t @@ -2,9 +2,10 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } +use warnings; use Text::ParseWords; print "1..18\n"; @@ -17,15 +18,15 @@ print "ok 2\n"; print "not " if $words[2] ne 'zoo'; print "ok 3\n"; -# Gonna get some undefined things back -local($^W) = 0; +{ + # Gonna get some undefined things back + no warnings 'uninitialized' ; -# Test quotewords() with other parameters and null last field -@words = quotewords(':+', 1, 'foo:::"bar:foo":zoo zoo:'); -print "not " unless join(";", @words) eq qq(foo;"bar:foo";zoo zoo;); -print "ok 4\n"; - -$^W = 1; + # Test quotewords() with other parameters and null last field + @words = quotewords(':+', 1, 'foo:::"bar:foo":zoo zoo:'); + print "not " unless join(";", @words) eq qq(foo;"bar:foo";zoo zoo;); + print "ok 4\n"; +} # Test $keep eq 'delimiters' and last field zero @words = quotewords('\s+', 'delimiters', '4 3 2 1 0'); @@ -71,29 +72,30 @@ print "ok 11\n"; print "not " if (@words); print "ok 12\n"; -# Gonna get some more undefined things back -$^W = 0; +{ + # Gonna get some more undefined things back + no warnings 'uninitialized' ; -@words = nested_quotewords('s+', 0, $string); -print "not " if (@words); -print "ok 13\n"; + @words = nested_quotewords('s+', 0, $string); + print "not " if (@words); + print "ok 13\n"; -# Now test empty fields -$result = join('|', parse_line(':', 0, 'foo::0:"":::')); -print "not " unless ($result eq 'foo||0||||'); -print "ok 14\n"; + # Now test empty fields + $result = join('|', parse_line(':', 0, 'foo::0:"":::')); + print "not " unless ($result eq 'foo||0||||'); + print "ok 14\n"; -# Test for 0 in quotes without $keep -$result = join('|', parse_line(':', 0, ':"0":')); -print "not " unless ($result eq '|0|'); -print "ok 15\n"; + # Test for 0 in quotes without $keep + $result = join('|', parse_line(':', 0, ':"0":')); + print "not " unless ($result eq '|0|'); + print "ok 15\n"; -# Test for \001 in quoted string -$result = join('|', parse_line(':', 0, ':"' . "\001" . '":')); -print "not " unless ($result eq "|\1|"); -print "ok 16\n"; + # Test for \001 in quoted string + $result = join('|', parse_line(':', 0, ':"' . "\001" . '":')); + print "not " unless ($result eq "|\1|"); + print "ok 16\n"; -$^W = 1; +} # Now test perlish single quote behavior $Text::ParseWords::PERL_SINGLE_QUOTE = 1; diff --git a/contrib/perl5/t/lib/ph.t b/contrib/perl5/t/lib/ph.t index de27dee..dd24c79 100755 --- a/contrib/perl5/t/lib/ph.t +++ b/contrib/perl5/t/lib/ph.t @@ -6,7 +6,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } # All the constants which Socket.pm tries to make available: diff --git a/contrib/perl5/t/lib/posix.t b/contrib/perl5/t/lib/posix.t index f6d8e92..abc4563 100755 --- a/contrib/perl5/t/lib/posix.t +++ b/contrib/perl5/t/lib/posix.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; require Config; import Config; if ($^O ne 'VMS' and $Config{'extensions'} !~ /\bPOSIX\b/) { print "1..0\n"; @@ -14,7 +14,7 @@ use POSIX qw(fcntl_h signal_h limits_h _exit getcwd open read strftime write); use strict subs; $| = 1; -print "1..18\n"; +print "1..27\n"; $Is_W32 = $^O eq 'MSWin32'; @@ -72,6 +72,9 @@ print getcwd() =~ m#/t$# ? "ok 13\n" : "not ok 13\n"; if ($Config{d_strtod}) { $lc = &POSIX::setlocale(&POSIX::LC_NUMERIC, 'C') if $Config{d_setlocale}; ($n, $x) = &POSIX::strtod('3.14159_OR_SO'); +# Using long double NVs may introduce greater accuracy than wanted. + $n =~ s/^3.14158999\d*$/3.14159/ + if $Config{uselongdouble} eq 'define'; print (($n == 3.14159) && ($x == 6) ? "ok 14\n" : "not ok 14\n"); &POSIX::setlocale(&POSIX::LC_NUMERIC, $lc) if $Config{d_setlocale}; } else { print "# strtod not present\n", "ok 14\n"; } @@ -95,6 +98,32 @@ print &POSIX::acos(1.0) == 0.0 ? "ok 17\n" : "not ok 17\n"; # See ext/POSIX/hints/sunos_4.pl and ext/POSIX/hints/linux.pl print POSIX::strftime("ok 18 # %H:%M, on %D\n", localtime()); +# If that worked, validate the mini_mktime() routine's normalisation of +# input fields to strftime(). +sub try_strftime { + my $num = shift; + my $expect = shift; + my $got = POSIX::strftime("%a %b %d %H:%M:%S %Y %j", @_); + if ($got eq $expect) { + print "ok $num\n"; + } + else { + print "# expected: $expect\n# got: $got\nnot ok $num\n"; + } +} + +$lc = &POSIX::setlocale(&POSIX::LC_TIME, 'C') if $Config{d_setlocale}; +try_strftime(19, "Wed Feb 28 00:00:00 1996 059", 0,0,0, 28,1,96); +try_strftime(20, "Thu Feb 29 00:00:60 1996 060", 60,0,-24, 30,1,96); +try_strftime(21, "Fri Mar 01 00:00:00 1996 061", 0,0,-24, 31,1,96); +try_strftime(22, "Sun Feb 28 00:00:00 1999 059", 0,0,0, 28,1,99); +try_strftime(23, "Mon Mar 01 00:00:00 1999 060", 0,0,24, 28,1,99); +try_strftime(24, "Mon Feb 28 00:00:00 2000 059", 0,0,0, 28,1,100); +try_strftime(25, "Tue Feb 29 00:00:00 2000 060", 0,0,0, 0,2,100); +try_strftime(26, "Wed Mar 01 00:00:00 2000 061", 0,0,0, 1,2,100); +try_strftime(27, "Fri Mar 31 00:00:00 2000 091", 0,0,0, 31,2,100); +&POSIX::setlocale(&POSIX::LC_TIME, $lc) if $Config{d_setlocale}; + $| = 0; # The following line assumes buffered output, which may be not true with EMX: print '@#!*$@(!@#$' unless ($^O eq 'os2' || $^O eq 'uwin' || $^O eq 'os390'); diff --git a/contrib/perl5/t/lib/safe1.t b/contrib/perl5/t/lib/safe1.t index 27993d9..6e12873 100755 --- a/contrib/perl5/t/lib/safe1.t +++ b/contrib/perl5/t/lib/safe1.t @@ -2,7 +2,7 @@ $|=1; BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { print "1..0\n"; diff --git a/contrib/perl5/t/lib/safe2.t b/contrib/perl5/t/lib/safe2.t index 6afc117..293b515 100755 --- a/contrib/perl5/t/lib/safe2.t +++ b/contrib/perl5/t/lib/safe2.t @@ -2,7 +2,7 @@ $|=1; BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { print "1..0\n"; @@ -10,6 +10,7 @@ BEGIN { } # test 30 rather naughtily expects English error messages $ENV{'LC_ALL'} = 'C'; + $ENV{LANGUAGE} = 'C'; # GNU locale extension } # Tests Todo: @@ -65,7 +66,7 @@ $glob = "ok 11\n"; sub sayok { print "ok @_\n" } $cpt->share(qw($foo %bar @baz *glob sayok)); -$cpt->share('$"') unless $Config{archname} =~ /-thread$/; +$cpt->share('$"') unless $Config{use5005threads}; $cpt->reval(q{ package other; @@ -123,7 +124,7 @@ print $@ =~ /foo bar/ ? "ok 29\n" : "not ok 29\n"; my $t = 30; $cpt->rdo('/non/existant/file.name'); # The regexp is getting rather baroque. -print $! =~ /No such file|file specification syntax error|A file or directory in the path name does not exist|Invalid argument|Device not configured|file not found/i ? "ok $t\n" : "not ok $t # $!\n"; $t++; +print $! =~ /cannot find|No such file|file specification syntax error|A file or directory in the path name does not exist|Invalid argument|Device not configured|file not found|File or directory doesn't exist/i ? "ok $t\n" : "not ok $t # $!\n"; $t++; # test #31 is gone. print 1 ? "ok $t\n" : "not ok $t\n#$@/$!\n"; $t++; diff --git a/contrib/perl5/t/lib/sdbm.t b/contrib/perl5/t/lib/sdbm.t index 591fe14..2689d19 100755 --- a/contrib/perl5/t/lib/sdbm.t +++ b/contrib/perl5/t/lib/sdbm.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; require Config; import Config; if (($Config{'extensions'} !~ /\bSDBM_File\b/) && ($^O ne 'VMS')){ print "1..0\n"; @@ -15,7 +15,7 @@ require SDBM_File; #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT use Fcntl; -print "1..18\n"; +print "1..66\n"; unlink <Op_dbmx.*>; @@ -122,13 +122,6 @@ print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); -untie %h; -if ($^O eq 'VMS') { - unlink 'Op_dbmx.sdbm_dir', $Dfile; -} else { - unlink 'Op_dbmx.dir', $Dfile; -} - sub ok { @@ -210,3 +203,196 @@ EOM unlink "SubDB.pm", <dbhash_tmp.*> ; } + +ok(19, !exists $h{'goner1'}); +ok(20, exists $h{'foo'}); + +untie %h; +unlink <Op_dbmx*>, $Dfile; + +{ + # DBM Filter tests + use strict ; + my (%h, $db) ; + my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + + sub checkOutput + { + my($fk, $sk, $fv, $sv) = @_ ; + return + $fetch_key eq $fk && $store_key eq $sk && + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; + } + + unlink <Op_dbmx*>; + ok(21, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ; + + $db->filter_fetch_key (sub { $fetch_key = $_ }) ; + $db->filter_store_key (sub { $store_key = $_ }) ; + $db->filter_fetch_value (sub { $fetch_value = $_}) ; + $db->filter_store_value (sub { $store_value = $_ }) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + # fk sk fv sv + ok(22, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(23, $h{"fred"} eq "joe"); + # fk sk fv sv + ok(24, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(25, $db->FIRSTKEY() eq "fred") ; + # fk sk fv sv + ok(26, checkOutput( "fred", "", "", "")) ; + + # replace the filters, but remember the previous set + my ($old_fk) = $db->filter_fetch_key + (sub { $_ = uc $_ ; $fetch_key = $_ }) ; + my ($old_sk) = $db->filter_store_key + (sub { $_ = lc $_ ; $store_key = $_ }) ; + my ($old_fv) = $db->filter_fetch_value + (sub { $_ = "[$_]"; $fetch_value = $_ }) ; + my ($old_sv) = $db->filter_store_value + (sub { s/o/x/g; $store_value = $_ }) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"Fred"} = "Joe" ; + # fk sk fv sv + ok(27, checkOutput( "", "fred", "", "Jxe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(28, $h{"Fred"} eq "[Jxe]"); + # fk sk fv sv + ok(29, checkOutput( "", "fred", "[Jxe]", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(30, $db->FIRSTKEY() eq "FRED") ; + # fk sk fv sv + ok(31, checkOutput( "FRED", "", "", "")) ; + + # put the original filters back + $db->filter_fetch_key ($old_fk); + $db->filter_store_key ($old_sk); + $db->filter_fetch_value ($old_fv); + $db->filter_store_value ($old_sv); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(32, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(33, $h{"fred"} eq "joe"); + ok(34, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(35, $db->FIRSTKEY() eq "fred") ; + ok(36, checkOutput( "fred", "", "", "")) ; + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(37, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(38, $h{"fred"} eq "joe"); + ok(39, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(40, $db->FIRSTKEY() eq "fred") ; + ok(41, checkOutput( "", "", "", "")) ; + + undef $db ; + untie %h; + unlink <Op_dbmx*>; +} + +{ + # DBM Filter with a closure + + use strict ; + my (%h, $db) ; + + unlink <Op_dbmx*>; + ok(42, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ; + + my %result = () ; + + sub Closure + { + my ($name) = @_ ; + my $count = 0 ; + my @kept = () ; + + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } + } + + $db->filter_store_key(Closure("store key")) ; + $db->filter_store_value(Closure("store value")) ; + $db->filter_fetch_key(Closure("fetch key")) ; + $db->filter_fetch_value(Closure("fetch value")) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + ok(43, $result{"store key"} eq "store key - 1: [fred]"); + ok(44, $result{"store value"} eq "store value - 1: [joe]"); + ok(45, !defined $result{"fetch key"} ); + ok(46, !defined $result{"fetch value"} ); + ok(47, $_ eq "original") ; + + ok(48, $db->FIRSTKEY() eq "fred") ; + ok(49, $result{"store key"} eq "store key - 1: [fred]"); + ok(50, $result{"store value"} eq "store value - 1: [joe]"); + ok(51, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(52, ! defined $result{"fetch value"} ); + ok(53, $_ eq "original") ; + + $h{"jim"} = "john" ; + ok(54, $result{"store key"} eq "store key - 2: [fred jim]"); + ok(55, $result{"store value"} eq "store value - 2: [joe john]"); + ok(56, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(57, $result{"fetch value"} eq ""); + ok(58, $_ eq "original") ; + + ok(59, $h{"fred"} eq "joe"); + ok(60, $result{"store key"} eq "store key - 3: [fred jim fred]"); + ok(61, $result{"store value"} eq "store value - 2: [joe john]"); + ok(62, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(63, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(64, $_ eq "original") ; + + undef $db ; + untie %h; + unlink <Op_dbmx*>; +} + +{ + # DBM Filter recursion detection + use strict ; + my (%h, $db) ; + unlink <Op_dbmx*>; + + ok(65, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ; + + $db->filter_store_key (sub { $_ = $h{$_} }) ; + + eval '$h{1} = 1234' ; + ok(66, $@ =~ /^recursion detected in filter_store_key at/ ); + + undef $db ; + untie %h; + unlink <Op_dbmx*>; +} + diff --git a/contrib/perl5/t/lib/searchdict.t b/contrib/perl5/t/lib/searchdict.t index c36fdb8..46cea39 100755 --- a/contrib/perl5/t/lib/searchdict.t +++ b/contrib/perl5/t/lib/searchdict.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } print "1..4\n"; diff --git a/contrib/perl5/t/lib/selectsaver.t b/contrib/perl5/t/lib/selectsaver.t index 3b58d70..677caec 100755 --- a/contrib/perl5/t/lib/selectsaver.t +++ b/contrib/perl5/t/lib/selectsaver.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } print "1..3\n"; diff --git a/contrib/perl5/t/lib/socket.t b/contrib/perl5/t/lib/socket.t index 4e38295..d5e1848 100755 --- a/contrib/perl5/t/lib/socket.t +++ b/contrib/perl5/t/lib/socket.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bSocket\b/ && !(($^O eq 'VMS') && $Config{d_socket})) { @@ -13,7 +13,7 @@ BEGIN { use Socket; -print "1..6\n"; +print "1..8\n"; if (socket(T,PF_INET,SOCK_STREAM,6)) { print "ok 1\n"; @@ -74,3 +74,14 @@ else { print "# $!\n"; print "not ok 4\n"; } + +# warnings +$SIG{__WARN__} = sub { + ++ $w if $_[0] =~ /^6-ARG sockaddr_in call is deprecated/ ; +} ; +$w = 0 ; +sockaddr_in(1,2,3,4,5,6) ; +print ($w == 1 ? "not ok 7\n" : "ok 7\n") ; +use warnings 'Socket' ; +sockaddr_in(1,2,3,4,5,6) ; +print ($w == 1 ? "ok 8\n" : "not ok 8\n") ; diff --git a/contrib/perl5/t/lib/soundex.t b/contrib/perl5/t/lib/soundex.t index d35f264..a04cccd 100755 --- a/contrib/perl5/t/lib/soundex.t +++ b/contrib/perl5/t/lib/soundex.t @@ -18,7 +18,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use Text::Soundex; diff --git a/contrib/perl5/t/lib/symbol.t b/contrib/perl5/t/lib/symbol.t index 03449a3..14c919c 100755 --- a/contrib/perl5/t/lib/symbol.t +++ b/contrib/perl5/t/lib/symbol.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } print "1..8\n"; diff --git a/contrib/perl5/t/lib/syslfs.t b/contrib/perl5/t/lib/syslfs.t new file mode 100755 index 0000000..2857120 --- /dev/null +++ b/contrib/perl5/t/lib/syslfs.t @@ -0,0 +1,221 @@ +# NOTE: this file tests how large files (>2GB) work with raw system IO. +# stdio: open(), tell(), seek(), print(), read() is tested in t/op/lfs.t. +# If you modify/add tests here, remember to update also t/op/lfs.t. + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + require Config; import Config; + # Don't bother if there are no quad offsets. + if ($Config{lseeksize} < 8) { + print "1..0\n# no 64-bit file offsets\n"; + exit(0); + } + require Fcntl; import Fcntl qw(/^O_/ /^SEEK_/); +} + +sub zap { + close(BIG); + unlink("big"); + unlink("big1"); + unlink("big2"); +} + +sub bye { + zap(); + exit(0); +} + +sub explain { + print <<EOM; +# +# If the lfs (large file support: large meaning larger than two gigabytes) +# tests are skipped or fail, it may mean either that your process +# (or process group) is not allowed to write large files (resource +# limits) or that the file system you are running the tests on doesn't +# let your user/group have large files (quota) or the filesystem simply +# doesn't support large files. You may even need to reconfigure your kernel. +# (This is all very operating system and site-dependent.) +# +# Perl may still be able to support large files, once you have +# such a process, enough quota, and such a (file) system. +# +EOM +} + +print "# checking whether we have sparse files...\n"; + +# Known have-nots. +if ($^O eq 'win32' || $^O eq 'vms') { + print "1..0\n# no sparse files (because this is $^O) \n"; + bye(); +} + +# Known haves that have problems running this test +# (for example because they do not support sparse files, like UNICOS) +if ($^O eq 'unicos') { + print "1..0\n# large files known to work but unable to test them here ($^O)\n"; + bye(); +} + +# Then try heuristically to deduce whether we have sparse files. + +# We'll start off by creating a one megabyte file which has +# only three "true" bytes. If we have sparseness, we should +# consume less blocks than one megabyte (assuming nobody has +# one megabyte blocks...) + +sysopen(BIG, "big1", O_WRONLY|O_CREAT|O_TRUNC) or + do { warn "sysopen big1 failed: $!\n"; bye }; +sysseek(BIG, 1_000_000, SEEK_SET) or + do { warn "sysseek big1 failed: $!\n"; bye }; +syswrite(BIG, "big") or + do { warn "syswrite big1 failed; $!\n"; bye }; +close(BIG) or + do { warn "close big1 failed: $!\n"; bye }; + +my @s1 = stat("big1"); + +print "# s1 = @s1\n"; + +sysopen(BIG, "big2", O_WRONLY|O_CREAT|O_TRUNC) or + do { warn "sysopen big2 failed: $!\n"; bye }; +sysseek(BIG, 2_000_000, SEEK_SET) or + do { warn "sysseek big2 failed: $!\n"; bye }; +syswrite(BIG, "big") or + do { warn "syswrite big2 failed; $!\n"; bye }; +close(BIG) or + do { warn "close big2 failed: $!\n"; bye }; + +my @s2 = stat("big2"); + +print "# s2 = @s2\n"; + +zap(); + +unless ($s1[7] == 1_000_003 && $s2[7] == 2_000_003 && + $s1[11] == $s2[11] && $s1[12] == $s2[12]) { + print "1..0\n#no sparse files?\n"; + bye; +} + +print "# we seem to have sparse files...\n"; + +# By now we better be sure that we do have sparse files: +# if we are not, the following will hog 5 gigabytes of disk. Ooops. + +$ENV{LC_ALL} = "C"; + +sysopen(BIG, "big", O_WRONLY|O_CREAT|O_TRUNC) or + do { warn "sysopen 'big' failed: $!\n"; bye }; +my $sysseek = sysseek(BIG, 5_000_000_000, SEEK_SET); +unless (defined $sysseek && $sysseek == 5_000_000_000) { + print "1..0\n# seeking past 2GB failed: $! (sysseek returned ", + defined $sysseek ? $sysseek : 'undef', ")\n"; + explain(); + bye(); +} + +# The syswrite will fail if there are are filesize limitations (process or fs). +my $syswrite = syswrite(BIG, "big"); +print "# syswrite failed: $! (syswrite returned ", + defined $syswrite ? $syswrite : 'undef', ")\n" + unless defined $syswrite && $syswrite == 3; +my $close = close BIG; +print "# close failed: $!\n" unless $close; +unless($syswrite && $close) { + if ($! =~/too large/i) { + print "1..0\n# writing past 2GB failed: process limits?\n"; + } elsif ($! =~ /quota/i) { + print "1..0\n# filesystem quota limits?\n"; + } + explain(); + bye(); +} + +@s = stat("big"); + +print "# @s\n"; + +unless ($s[7] == 5_000_000_003) { + print "1..0\n# not configured to use large files?\n"; + explain(); + bye(); +} + +sub fail () { + print "not "; + $fail++; +} + +print "1..17\n"; + +my $fail = 0; + +fail unless $s[7] == 5_000_000_003; # exercizes pp_stat +print "ok 1\n"; + +fail unless -s "big" == 5_000_000_003; # exercizes pp_ftsize +print "ok 2\n"; + +fail unless -e "big"; +print "ok 3\n"; + +fail unless -f "big"; +print "ok 4\n"; + +sysopen(BIG, "big", O_RDONLY) or do { warn "sysopen failed: $!\n"; bye }; + +fail unless sysseek(BIG, 4_500_000_000, SEEK_SET) == 4_500_000_000; +print "ok 5\n"; + +fail unless sysseek(BIG, 0, SEEK_CUR) == 4_500_000_000; +print "ok 6\n"; + +fail unless sysseek(BIG, 1, SEEK_CUR) == 4_500_000_001; +print "ok 7\n"; + +fail unless sysseek(BIG, 0, SEEK_CUR) == 4_500_000_001; +print "ok 8\n"; + +fail unless sysseek(BIG, -1, SEEK_CUR) == 4_500_000_000; +print "ok 9\n"; + +fail unless sysseek(BIG, 0, SEEK_CUR) == 4_500_000_000; +print "ok 10\n"; + +fail unless sysseek(BIG, -3, SEEK_END) == 5_000_000_000; +print "ok 11\n"; + +fail unless sysseek(BIG, 0, SEEK_CUR) == 5_000_000_000; +print "ok 12\n"; + +my $big; + +fail unless sysread(BIG, $big, 3) == 3; +print "ok 13\n"; + +fail unless $big eq "big"; +print "ok 14\n"; + +# 705_032_704 = (I32)5_000_000_000 +fail unless seek(BIG, 705_032_704, SEEK_SET); +print "ok 15\n"; + +my $zero; + +fail unless read(BIG, $zero, 3) == 3; +print "ok 16\n"; + +fail unless $zero eq "\0\0\0"; +print "ok 17\n"; + +explain if $fail; + +bye(); # does the necessary cleanup + +END { + unlink "big"; # be paranoid about leaving 5 gig files lying around +} + +# eof diff --git a/contrib/perl5/t/lib/textfill.t b/contrib/perl5/t/lib/textfill.t index 19add69..daeee23 100755 --- a/contrib/perl5/t/lib/textfill.t +++ b/contrib/perl5/t/lib/textfill.t @@ -2,9 +2,11 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } +use Text::Wrap qw(&fill); + @tests = (split(/\nEND\n/s, <<DONE)); TEST1 Cyberdog Information diff --git a/contrib/perl5/t/lib/texttabs.t b/contrib/perl5/t/lib/texttabs.t index ea9012c..80395f4 100755 --- a/contrib/perl5/t/lib/texttabs.t +++ b/contrib/perl5/t/lib/texttabs.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } print "1..3\n"; diff --git a/contrib/perl5/t/lib/textwrap.t b/contrib/perl5/t/lib/textwrap.t index c3a455b..bb1d5ca 100755 --- a/contrib/perl5/t/lib/textwrap.t +++ b/contrib/perl5/t/lib/textwrap.t @@ -2,8 +2,9 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } +use Text::Wrap qw(&wrap); @tests = (split(/\nEND\n/s, <<DONE)); TEST1 diff --git a/contrib/perl5/t/lib/thr5005.t b/contrib/perl5/t/lib/thr5005.t new file mode 100755 index 0000000..6b3c800 --- /dev/null +++ b/contrib/perl5/t/lib/thr5005.t @@ -0,0 +1,118 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + require Config; import Config; + if (! $Config{'use5005threads'}) { + print "1..0 # Skip: not use5005threads\n"; + exit 0; + } + + # XXX known trouble with global destruction + $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; +} +$| = 1; +print "1..21\n"; +use Thread 'yield'; +print "ok 1\n"; + +sub content +{ + print shift; + return shift; +} + +# create a thread passing args and immedaietly wait for it. +my $t = new Thread \&content,("ok 2\n","ok 3\n", 1..1000); +print $t->join; + +# check that lock works ... +{lock $foo; + $t = new Thread sub { lock $foo; print "ok 5\n" }; + print "ok 4\n"; +} +$t->join; + +sub dorecurse +{ + my $val = shift; + my $ret; + print $val; + if (@_) + { + $ret = Thread->new(\&dorecurse, @_); + $ret->join; + } +} + +$t = new Thread \&dorecurse, map { "ok $_\n" } 6..10; +$t->join; + +# test that sleep lets other thread run +$t = new Thread \&dorecurse,"ok 11\n"; +sleep 6; +print "ok 12\n"; +$t->join; + +sub islocked : locked { + my $val = shift; + my $ret; + print $val; + if (@_) + { + $ret = Thread->new(\&islocked, shift); + } + $ret; +} + +$t = Thread->new(\&islocked, "ok 13\n", "ok 14\n"); +$t->join->join; + +{ + package Loch::Ness; + sub new { bless [], shift } + sub monster : locked : method { + my($s, $m) = @_; + print "ok $m\n"; + } + sub gollum { &monster } +} +Loch::Ness->monster(15); +Loch::Ness->new->monster(16); +Loch::Ness->gollum(17); +Loch::Ness->new->gollum(18); + +my $short = "This is a long string that goes on and on."; +my $shorte = " a long string that goes on and on."; +my $long = "This is short."; +my $longe = " short."; +my $thr1 = new Thread \&threaded, $short, $shorte, "19"; +my $thr2 = new Thread \&threaded, $long, $longe, "20"; + +sub threaded { + my ($string, $string_end, $testno) = @_; + + # Do the match, saving the output in appropriate variables + $string =~ /(.*)(is)(.*)/; + # Yield control, allowing the other thread to fill in the match variables + yield(); + # Examine the match variable contents; on broken perls this fails + if ($3 eq $string_end) { + print "ok $testno\n"; + } + else { + warn <<EOT; + +# +# This is a KNOWN FAILURE, and one of the reasons why threading +# is still an experimental feature. It is here to stop people +# from deploying threads in production. ;-) +# +EOT + print "not ok $testno # other thread filled in match variables\n"; + } +} +$thr1->join; +$thr2->join; +print "ok 21\n"; diff --git a/contrib/perl5/t/lib/tie-push.t b/contrib/perl5/t/lib/tie-push.t index dd718de..23a0a94 100755 --- a/contrib/perl5/t/lib/tie-push.t +++ b/contrib/perl5/t/lib/tie-push.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } { @@ -21,4 +21,4 @@ tie @x,Basic; tie @get,Basic; tie @got,Basic; tie @tests,Basic; -require "../t/op/push.t" +require "op/push.t" diff --git a/contrib/perl5/t/lib/tie-stdarray.t b/contrib/perl5/t/lib/tie-stdarray.t index 7ca4d76..5a678a5 100755 --- a/contrib/perl5/t/lib/tie-stdarray.t +++ b/contrib/perl5/t/lib/tie-stdarray.t @@ -2,11 +2,11 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use Tie::Array; tie @foo,Tie::StdArray; tie @ary,Tie::StdArray; tie @bar,Tie::StdArray; -require "../t/op/array.t" +require "op/array.t" diff --git a/contrib/perl5/t/lib/tie-stdhandle.t b/contrib/perl5/t/lib/tie-stdhandle.t new file mode 100755 index 0000000..cf3a183 --- /dev/null +++ b/contrib/perl5/t/lib/tie-stdhandle.t @@ -0,0 +1,47 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +use Tie::Handle; +tie *tst,Tie::StdHandle; + +$f = 'tst'; + +print "1..13\n"; + +# my $file tests + +unlink("afile.new") if -f "afile"; +print "$!\nnot " unless open($f,"+>afile"); +print "ok 1\n"; +print "$!\nnot " unless binmode($f); +print "ok 2\n"; +print "not " unless -f "afile"; +print "ok 3\n"; +print "not " unless print $f "SomeData\n"; +print "ok 4\n"; +print "not " unless tell($f) == 9; +print "ok 5\n"; +print "not " unless printf $f "Some %d value\n",1234; +print "ok 6\n"; +print "not " unless seek($f,0,0); +print "ok 7\n"; +$b = <$f>; +print "not " unless $b eq "SomeData\n"; +print "ok 8\n"; +print "not " if eof($f); +print "ok 9\n"; +read($f,($b=''),4); +print "'$b' not " unless $b eq 'Some'; +print "ok 10\n"; +print "not " unless getc($f) eq ' '; +print "ok 11\n"; +$b = <$f>; +print "not " unless eof($f); +print "ok 12\n"; +print "not " unless close($f); +print "ok 13\n"; +unlink("afile"); diff --git a/contrib/perl5/t/lib/tie-stdpush.t b/contrib/perl5/t/lib/tie-stdpush.t index 34a6947..35ae1b8 100755 --- a/contrib/perl5/t/lib/tie-stdpush.t +++ b/contrib/perl5/t/lib/tie-stdpush.t @@ -2,9 +2,9 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use Tie::Array; tie @x,Tie::StdArray; -require "../t/op/push.t" +require "op/push.t" diff --git a/contrib/perl5/t/lib/timelocal.t b/contrib/perl5/t/lib/timelocal.t index 100e076..359d71e 100755 --- a/contrib/perl5/t/lib/timelocal.t +++ b/contrib/perl5/t/lib/timelocal.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use Time::Local; diff --git a/contrib/perl5/t/lib/trig.t b/contrib/perl5/t/lib/trig.t index 3114176..20669f0 100755 --- a/contrib/perl5/t/lib/trig.t +++ b/contrib/perl5/t/lib/trig.t @@ -10,7 +10,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use Math::Trig; |
