From: Nick Ing-Simmons Date: Mon, 18 Jun 2001 08:04:44 +0000 (+0000) Subject: Integrate mainline (part1) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=370a0481ecee92d75bbc6f38ccbbfa820fff9abb;p=p5sagit%2Fp5-mst-13.2.git Integrate mainline (part1) p4raw-id: //depot/perlio@10677 --- 370a0481ecee92d75bbc6f38ccbbfa820fff9abb diff --cc lib/Text/Abbrev/t/abbrev.t index fb5a984,0000000..fb5a984 mode 100755,000000..100755 --- a/lib/Text/Abbrev/t/abbrev.t +++ b/lib/Text/Abbrev/t/abbrev.t diff --cc t/lib/anydbm.t index 08d1f7c,0000000..30b3c7a mode 100755,000000..100755 --- a/t/lib/anydbm.t +++ b/t/lib/anydbm.t @@@ -1,155 -1,0 +1,155 @@@ +#!./perl + +# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if (($Config{'extensions'} !~ /\b(DB|[A-Z]DBM)_File\b/) ){ + print "1..0 # Skipping (no DB_File or [A-Z]DBM_File)\n"; + exit 0; + } +} +require AnyDBM_File; +use Fcntl; + +print "1..12\n"; + - $Is_Dosish = ($^O eq 'amigaos' || $^O eq 'MSWin32' or $^O eq 'dos' or ++$Is_Dosish = ($^O eq 'amigaos' || $^O eq 'MSWin32' || $^O eq 'NetWare' or $^O eq 'dos' or + $^O eq 'os2' or $^O eq 'mint'); + +unlink ; + +umask(0); +print (tie(%h,AnyDBM_File,'Op_dbmx', O_RDWR|O_CREAT, 0640) + ? "ok 1\n" : "not ok 1\n"); + +$Dfile = "Op_dbmx.pag"; +if (! -e $Dfile) { + ($Dfile) = ; +} +if ($Is_Dosish || $^O eq 'MacOS') { + print "ok 2 # Skipped: different file permission semantics\n"; +} +else { + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); + print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); +} +while (($key,$value) = each(%h)) { + $i++; +} +print (!$i ? "ok 3\n" : "not ok 3 # i=$i\n\n"); + +$h{'goner1'} = 'snork'; + +$h{'abc'} = 'ABC'; +$h{'def'} = 'DEF'; +$h{'jkl','mno'} = "JKL\034MNO"; +$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); +$h{'a'} = 'A'; +$h{'b'} = 'B'; +$h{'c'} = 'C'; +$h{'d'} = 'D'; +$h{'e'} = 'E'; +$h{'f'} = 'F'; +$h{'g'} = 'G'; +$h{'h'} = 'H'; +$h{'i'} = 'I'; + +$h{'goner2'} = 'snork'; +delete $h{'goner2'}; + +untie(%h); +print (tie(%h,AnyDBM_File,'Op_dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); + +$h{'j'} = 'J'; +$h{'k'} = 'K'; +$h{'l'} = 'L'; +$h{'m'} = 'M'; +$h{'n'} = 'N'; +$h{'o'} = 'O'; +$h{'p'} = 'P'; +$h{'q'} = 'Q'; +$h{'r'} = 'R'; +$h{'s'} = 'S'; +$h{'t'} = 'T'; +$h{'u'} = 'U'; +$h{'v'} = 'V'; +$h{'w'} = 'W'; +$h{'x'} = 'X'; +$h{'y'} = 'Y'; +$h{'z'} = 'Z'; + +$h{'goner3'} = 'snork'; + +delete $h{'goner1'}; +delete $h{'goner3'}; + +@keys = keys(%h); +@values = values(%h); + +if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} + +while (($key,$value) = each(%h)) { + if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { + $key =~ y/a-z/A-Z/; + $i++ if $key eq $value; + } +} + +if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";} + +@keys = ('blurfl', keys(%h), 'dyick'); +if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";} + +$h{'foo'} = ''; +$h{''} = 'bar'; + +# check cache overflow and numeric keys and contents +$ok = 1; +for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } +for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } +print ($ok ? "ok 8\n" : "not ok 8\n"); + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); +print ($size > 0 ? "ok 9\n" : "not ok 9\n"); + +@h{0..200} = 200..400; +@foo = @h{0..200}; +print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; + +print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); +if ($h{''} eq 'bar') { + print "ok 12\n" ; +} +else { + if ($AnyDBM_File::ISA[0] eq 'DB_File' && $DB_File::db_ver >= 2.004010) { + ($major, $minor, $patch) = ($DB_File::db_ver =~ /^(\d+)\.(\d\d\d)(\d\d\d)/) ; + $major =~ s/^0+// ; + $minor =~ s/^0+// ; + $patch =~ s/^0+// ; + $compact = "$major.$minor.$patch" ; + # + # anydbm.t test 12 will fail when AnyDBM_File uses the combination of + # DB_File and Berkeley DB 2.4.10 (or greater). + # You are using DB_File $DB_File::VERSION and Berkeley DB $compact + # + # Berkeley DB 2 from version 2.4.10 onwards does not allow null keys. + # This feature will be reenabled in a future version of Berkeley DB. + # + print "ok 12 # skipped: db v$compact, no null key support\n" ; + } + else { + print "not ok 12\n" ; + } +} + +untie %h; +if ($^O eq 'VMS') { + unlink 'Op_dbmx.sdbm_dir', $Dfile; +} else { + unlink 'Op_dbmx.dir', $Dfile; +} diff --cc t/lib/b-stash.t index 7f523b5,0000000..bc9d896 mode 100644,000000..100644 --- a/t/lib/b-stash.t +++ b/t/lib/b-stash.t @@@ -1,59 -1,0 +1,60 @@@ +#!./perl + +BEGIN { + if ($^O eq 'MacOS') { + @INC = qw(: ::lib ::macos:lib); + } +} + +$| = 1; +use warnings; +use strict; +use Config; + +print "1..1\n"; + +my $test = 1; + +sub ok { print "ok $test\n"; $test++ } + + +my $a; +my $Is_VMS = $^O eq 'VMS'; +my $Is_MacOS = $^O eq 'MacOS'; + +my $path = join " ", map { qq["-I$_"] } @INC; +my $redir = $Is_MacOS ? "" : "2>&1"; + + +chomp($a = `$^X $path "-MB::Stash" "-Mwarnings" -e1`); +$a = join ',', sort split /,/, $a; +$a =~ s/-u(PerlIO|open)(?:::\w+)?,//g if defined $Config{'useperlio'} and $Config{'useperlio'} eq 'define'; +$a =~ s/-uWin32,// if $^O eq 'MSWin32'; ++$a =~ s/-uNetWare,// if $^O eq 'NetWare'; +$a =~ s/-u(Cwd|File|File::Copy|OS2),//g if $^O eq 'os2'; +$a =~ s/-uCwd,// if $^O eq 'cygwin'; + $b = '-uCarp,-uCarp::Heavy,-uDB,-uExporter,-uExporter::Heavy,-uattributes,' + . '-umain,-ustrict,-uutf8,-uwarnings'; +if ($Is_VMS) { + $a =~ s/-uFile,-uFile::Copy,//; + $a =~ s/-uVMS,-uVMS::Filespec,//; + $a =~ s/-uSocket,//; # Socket is optional/compiler version dependent +} + +{ + no strict 'vars'; + use vars '$OS2::is_aout'; +} +if (($Config{static_ext} eq ' ' || + ($Config{static_ext} eq 'Socket' && $Is_VMS)) + && !($^O eq 'os2' and $OS2::is_aout) + ) { + if (ord('A') == 193) { # EBCDIC sort order is qw(a A) not qw(A a) + $b = join ',', sort split /,/, $b; + } + print "# [$a]\n# vs.\n# [$b]\nnot " if $a ne $b; + ok; +} else { + print "ok $test # skipped: one or more static extensions\n"; $test++; +} + diff --cc t/lib/bigfltpm.t index 8247e42,0000000..e8de58d mode 100755,000000..100755 --- a/t/lib/bigfltpm.t +++ b/t/lib/bigfltpm.t @@@ -1,542 -1,0 +1,708 @@@ - #!./perl ++#!/usr/bin/perl -w + - BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - } ++use Test; ++use strict; ++ ++BEGIN ++ { ++ $| = 1; ++ unshift @INC, '../lib'; # for running manually ++ # chdir 't' if -d 't'; ++ plan tests => 514; ++ } + +use Math::BigFloat; ++use Math::BigInt; + - $test = 0; - $| = 1; - print "1..414\n"; - while () { - chomp; - 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 "fint") { - $try .= "int \$x;"; - } elsif ($f eq "fround") { - $try .= "0+\$x->fround($args[1]);"; - } elsif ($f eq "ffround") { - $try .= "0+\$x->ffround($args[1]);"; - } elsif ($f eq "fsqrt") { - $try .= "0+\$x->fsqrt;"; - } else { - $try .= "\$y = new Math::BigFloat \"$args[1]\";"; - if ($f eq "fcmp") { - $try .= "\$x <=> \$y;"; - } elsif ($f eq "fadd") { - $try .= "\$x + \$y;"; - } elsif ($f eq "fsub") { - $try .= "\$x - \$y;"; - } elsif ($f eq "fmul") { - $try .= "\$x * \$y;"; - } elsif ($f eq "fdiv") { - $try .= "\$x / \$y;"; - } elsif ($f eq "fmod") { - $try .= "\$x % \$y;"; - } else { warn "Unknown op"; } - } - #print ">>>",$try,"<<<\n"; - $ans1 = eval $try; - if ($ans =~ m|^/(.*)$|) { - my $pat = $1; - if ($ans1 =~ /$pat/) { - print "ok $test\n"; - } - else { - print "not ok $test\n"; - print "# '$try' expected: /$pat/ got: '$ans1'\n"; - } - } - else { ++my ($x,$y,$f,@args,$ans,$try,$ans1,$ans1_str,$setup); ++while () ++ { ++ chop; ++ $_ =~ s/#.*$//; # remove comments ++ $_ =~ s/\s+$//; # trailing spaces ++ next if /^$/; # skip empty lines & comments ++ if (s/^&//) ++ { ++ $f = $_; ++ } ++ elsif (/^\$/) ++ { ++ $setup = $_; $setup =~ s/^\$/\$Math::BigFloat::/; # rnd_mode, div_scale ++ # print "$setup\n"; ++ } ++ else ++ { ++ 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;"; ++ } elsif ($f eq "binf") { ++ $try .= "\$x->binf('$args[1]');"; ++ } elsif ($f eq "bsstr") { ++ $try .= "\$x->bsstr();"; ++ } elsif ($f eq "_set") { ++ $try .= "\$x->_set('$args[1]'); \$x;"; ++ } elsif ($f eq "fneg") { ++ $try .= "-\$x;"; ++ } elsif ($f eq "bfloor") { ++ $try .= "\$x->bfloor();"; ++ } elsif ($f eq "bceil") { ++ $try .= "\$x->bceil();"; ++ } elsif ($f eq "is_zero") { ++ $try .= "\$x->is_zero()+0;"; ++ } elsif ($f eq "is_one") { ++ $try .= "\$x->is_one()+0;"; ++ } elsif ($f eq "is_odd") { ++ $try .= "\$x->is_odd()+0;"; ++ } elsif ($f eq "is_even") { ++ $try .= "\$x->is_even()+0;"; ++ } elsif ($f eq "as_number") { ++ $try .= "\$x->as_number();"; ++ } elsif ($f eq "fpow") { ++ $try .= "\$x ** $args[1];"; ++ } elsif ($f eq "fabs") { ++ $try .= "abs \$x;"; ++ }elsif ($f eq "fround") { ++ $try .= "$setup; \$x->fround($args[1]);"; ++ } elsif ($f eq "ffround") { ++ $try .= "$setup; \$x->ffround($args[1]);"; ++ } elsif ($f eq "fsqrt") { ++ $try .= "$setup; \$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 .= "$setup; \$x / \$y;"; ++ } elsif ($f eq "fmod") { ++ $try .= "\$x % \$y;"; ++ } else { warn "Unknown op '$f'"; } ++ } ++ $ans1 = eval $try; ++ if ($ans =~ m|^/(.*)$|) ++ { ++ my $pat = $1; ++ if ($ans1 =~ /$pat/) ++ { ++ ok (1,1); ++ } ++ else ++ { ++ print "# '$try' expected: /$pat/ got: '$ans1'\n" if !ok(1,0); ++ } ++ } ++ else ++ { ++ if ($ans eq "") ++ { ++ ok_undef ($ans1); ++ } ++ else ++ { ++ print "# Tried: '$try'\n" if !ok ($ans1, $ans); ++ } ++ } # end pattern or string ++ } ++ } # end while + - $ans1_str = defined $ans1? "$ans1" : ""; - if ($ans1_str eq $ans) { #bug! - print "ok $test\n"; - } else { - print "not ok $test\n"; - print "# '$try' expected: '$ans' got: '$ans1'\n"; - } - } - } - } ++# all done + - { - use Math::BigFloat ':constant'; ++############################################################################### ++# Perl 5.005 does not like ok ($x,undef) + - $test++; - # print "# " . 2. * '1427247692705959881058285969449495136382746624' . "\n"; - print "not " - unless 2. * '1427247692705959881058285969449495136382746624' - == "2854495385411919762116571938898990272765493248."; - 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"; - } ++sub ok_undef ++ { ++ my $x = shift; + ++ ok (1,1) and return if !defined $x; ++ ok ($x,'undef'); ++ } ++ +__END__ ++&as_number ++0:0 ++1:1 ++1.2:1 ++2.345:2 ++-2:-2 ++-123.456:-123 ++-200:-200 ++&binf ++1:+:+inf ++2:-:-inf ++3:abc:+inf ++&bsstr +++inf:+inf ++-inf:-inf ++abc:NaN +&fnorm +++inf:+inf ++-inf:-inf +++infinity:NaN +++-inf:NaN +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. ++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. ++0.01:0.01 ++.002:0.002 +++.2:0.2 ++-0.0003:-0.0003 ++-.0000000004:-0.0000000004 ++123456E2:12345600 +123456E-2:1234.56 - -123456E2:-12345600. ++-123456E2:-12345600 +-123456E-2:-1234.56 - 1e1:10. - 2e-11:.00000000002 - -3e111:-3000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000. - -4e-1111:-.0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000004 ++1e1:10 ++2e-11:0.00000000002 ++-3e111:-3000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 ++-4e-1111:-0.0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000004 ++&fpow ++2:2:4 ++1:2:1 ++1:3:1 ++-1:2:1 ++-1:3:-1 ++123.456:2:15241.383936 ++2:-2:0.25 ++2:-3:0.125 ++128:-2:0.00006103515625 +&fneg +abc:NaN - +0:0. - +1:-1. - -1:1. - +123456789:-123456789. - -123456789:123456789. +++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. +++0:0 +++1:1 ++-1:1 +++123456789:123456789 ++-123456789:123456789 ++123.456789:123.456789 +-123456.789:123456.789 +&fround - $Math::BigFloat::rnd_mode = 'trunc' ++$rnd_mode = "trunc" ++10123456789:5:10123000000 +-10123456789:5:-10123000000 +++10123456789.123:5:10123000000 ++-10123456789.123:5:-10123000000 ++10123456789:9:10123456700 +-10123456789:9:-10123456700 ++101234500:6:101234000 +-101234500:6:-101234000 - $Math::BigFloat::rnd_mode = 'zero' ++$rnd_mode = "zero" ++20123456789:5:20123000000 +-20123456789:5:-20123000000 +++20123456789.123:5:20123000000 ++-20123456789.123:5:-20123000000 ++20123456789:9:20123456800 +-20123456789:9:-20123456800 ++201234500:6:201234000 +-201234500:6:-201234000 - $Math::BigFloat::rnd_mode = '+inf' ++$rnd_mode = "+inf" ++30123456789:5:30123000000 +-30123456789:5:-30123000000 +++30123456789.123:5:30123000000 ++-30123456789.123:5:-30123000000 ++30123456789:9:30123456800 +-30123456789:9:-30123456800 ++301234500:6:301235000 +-301234500:6:-301234000 - $Math::BigFloat::rnd_mode = '-inf' ++$rnd_mode = "-inf" ++40123456789:5:40123000000 +-40123456789:5:-40123000000 +++40123456789.123:5:40123000000 ++-40123456789.123:5:-40123000000 ++40123456789:9:40123456800 +-40123456789:9:-40123456800 ++401234500:6:401234000 +-401234500:6:-401235000 - $Math::BigFloat::rnd_mode = 'odd' ++$rnd_mode = "odd" ++50123456789:5:50123000000 +-50123456789:5:-50123000000 +++50123456789.123:5:50123000000 ++-50123456789.123:5:-50123000000 ++50123456789:9:50123456800 +-50123456789:9:-50123456800 ++501234500:6:501235000 +-501234500:6:-501235000 - $Math::BigFloat::rnd_mode = 'even' ++$rnd_mode = "even" ++60123456789:5:60123000000 +-60123456789:5:-60123000000 ++60123456789:9:60123456800 +-60123456789:9:-60123456800 ++601234500:6:601234000 +-601234500:6:-601234000 +++60123456789.0123:5:60123000000 ++-60123456789.0123:5:-60123000000 +&ffround - $Math::BigFloat::rnd_mode = 'trunc' ++$rnd_mode = "trunc" ++1.23:-1:1.2 +++1.234:-1:1.2 +++1.2345:-1:1.2 +++1.23:-2:1.23 +++1.234:-2:1.23 +++1.2345:-2:1.23 +++1.23:-3:1.23 +++1.234:-3:1.234 +++1.2345:-3:1.234 +-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.0061234567890:-1:0 ++-0.0061:-1:0 ++-0.00612:-1:0 ++-0.00612:-2:0 +-0.006:-1:0 +-0.006:-2:0 ++-0.0006:-2:0 ++-0.0006:-3: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' ++0.05:0:0 ++0.5:0:0 ++0.51:0:0 ++0.41:0:0 ++$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' ++0.05:0:0 ++0.5:0:0 ++0.51:0:1 ++0.41:0:0 ++$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' ++0.05:0:0 ++0.5:0:1 ++0.51:0:1 ++0.41:0:0 ++$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' ++0.05:0:0 ++0.5:0:0 ++0.51:0:1 ++0.41:0:0 ++$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' ++0.05:0:0 ++0.5:0:1 ++0.51:0:1 ++0.41:0:0 ++$rnd_mode = "even" ++6.23:-1:/6.2(?:0{5}\d+)? +-6.23:-1:/-6.2(?:0{5}\d+)? ++6.27:-1:/6.(?:3|29{5}\d+) +-6.27:-1:/-6.(?:3|29{5}\d+) ++6.25:-1:/6.(?:2(?:0{5}\d+)?|29{5}\d+) +-6.25:-1:/-6.(?:2(?:0{5}\d+)?|29{5}\d+) ++6.35:-1:/6.(?:4|39{5}\d+|29{8}\d+) +-6.35:-1:/-6.(?:4|39{5}\d+|29{8}\d+) +-0.0065:-1:0 +-0.0065:-2:/-0\.01|-1e-02 - -0.0065:-3:/-0\.006|-7e-03|-6e-03 ++-0.0065:-3:/-0\.006|-7e-03 +-0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 +-0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 ++0.05:0:0 ++0.5:0:0 ++0.51:0:1 ++0.41:0:0 ++0.01234567:-3:0.012 ++0.01234567:-4:0.0123 ++0.01234567:-5:0.01235 ++0.01234567:-6:0.012346 ++0.01234567:-7:0.0123457 ++0.01234567:-8:0.01234567 ++0.01234567:-9:0.01234567 ++0.01234567:-12:0.01234567 +&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 ++0:0.01:-1 ++0:0.0001:-1 ++0:-0.0001:1 ++0:-0.1:1 ++0.1:0:1 ++0.00001:0:1 ++-0.0001:0:-1 ++-0.1:0:-1 ++0:0.0001234:-1 ++0:-0.0001234:1 ++0.0001234:0:1 ++-0.0001234:0:-1 ++0.0001:0.0005:-1 ++0.0005:0.0001:1 ++0.005:0.0001:1 ++0.001:0.0005:1 ++0.000001:0.0005:-2 # <0, but can't test this ++0.00000123:0.0005:-2 # <0, but can't test this ++0.00512:0.0001:1 ++0.005:0.000112:1 ++0.00123:0.0005: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. +++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. +++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. +++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 ++$div_scale = 40; $Math::BigFloat::rnd_mode = 'even' +abc:abc:NaN +abc:+1:abc:NaN ++1:abc:NaN ++0:+0:NaN - +0:+1:0. +++0:+1:0 ++1:+0:NaN - +0:-1:0. +++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. +++1:+1:1 ++-1:-1:1 +++1:-1:-1 ++-1:+1:-1 +++1:+2:0.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. +++9000000000:+9:1000000000 ++35500000:+113:314159.2920353982300884955752212389380531 ++71000000:+226:314159.2920353982300884955752212389380531 ++106500000:+339:314159.2920353982300884955752212389380531 ++1000000000:+3:333333333.3333333333333333333333333333333 - $Math::BigFloat::div_scale = 20 ++$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 +++9000000000:+9:1000000000 ++# following two cases are the "old" behaviour, but are now (>v0.01) different ++#+35500000:+113:314159.292035398230088 ++#+71000000:+226:314159.292035398230088 +++35500000:+113:314159.29203539823009 +++71000000:+226:314159.29203539823009 ++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 - &fint - +0:+0 - +1:+1 - +11111111111111111234:+11111111111111111234 - -1:-1 - -11111111111111111234:-11111111111111111234 - +0.3:+0 - +1.3:+1 - +23.3:+23 - +12345678901234567890:+12345678901234567890 - +12345678901234567.890:+12345678901234567 - +12345678901234567890E13:+123456789012345678900000000000000 - +12345678901234567.890E13:+123456789012345678900000000000 - +12345678901234567890E-3:+12345678901234567 - +12345678901234567.890E-3:+12345678901234 - +12345678901234567890E-13:+1234567 - +12345678901234567.890E-13:+1234 - +12345678901234567890E-17:+123 - +12345678901234567.890E-16:+1 - +12345678901234567.890E-17:+0 - +12345678901234567890E-19:+1 - +12345678901234567890E-20:+0 - +12345678901234567890E-21:+0 - +12345678901234567890E-225:+0 - -0:+0 - -0.3:+0 - -1.3:-1 - -23.3:-23 - -12345678901234567890:-12345678901234567890 - -12345678901234567.890:-12345678901234567 - -12345678901234567890E13:-123456789012345678900000000000000 - -12345678901234567.890E13:-123456789012345678900000000000 - -12345678901234567890E-3:-12345678901234567 - -12345678901234567.890E-3:-12345678901234 - -12345678901234567890E-13:-1234567 - -12345678901234567.890E-13:-1234 - -12345678901234567890E-17:-123 - -12345678901234567.890E-16:-1 - -12345678901234567.890E-17:+0 - -12345678901234567890E-19:-1 - -12345678901234567890E-20:+0 - -12345678901234567890E-21:+0 - -12345678901234567890E-225:+0 ++$div_scale = 1 ++# div_scale will be 3 since $x has 3 digits +++124:+3:41.3 ++# reset scale for further tests ++$div_scale = 40 +&fmod ++0:0:NaN - +0:1:0. - +3:1:0. - +5:2:1. - +9:4:1. - +9:5:4. - +9000:56:40. - +56:9000:56. +++0:1:0 +++3:1:0 ++#+5:2:1 ++#+9:4:1 ++#+9:5:4 ++#+9000:56:40 ++#+56:9000:56 ++&fsqrt +++0:0 ++-1:NaN ++-2:NaN ++-16:NaN ++-123.45:NaN +++1:1 ++#+1.44:1.2 ++#+2:1.41421356237309504880168872420969807857 ++#+4:2 ++#+16:4 ++#+100:10 ++#+123.456:11.11107555549866648462149404118219234119 ++#+15241.38393:123.456 ++&is_odd ++abc:0 ++0:0 ++-1:1 ++-3:1 ++1:1 ++3:1 ++1000001:1 ++1000002:0 ++2:0 ++&is_even ++abc:0 ++0:1 ++-1:0 ++-3:0 ++1:0 ++3:0 ++1000001:0 ++1000002:1 ++2:1 ++&is_zero ++NaNzero:0 ++0:1 ++-1:0 ++1:0 ++&is_one ++0:0 ++2:0 ++1:1 ++-1:0 ++-2:0 ++&_set ++NaN:2:2 ++2:abc:NaN ++1:-1:-1 ++2:1:1 ++-2:0:0 ++128:-2:-2 ++&bfloor ++0:0 ++abc:NaN +++inf:+inf ++-inf:-inf ++1:1 ++-51:-51 ++-51.2:-52 ++12.2:12 ++&bceil ++0:0 ++abc:NaN +++inf:+inf ++-inf:-inf ++1:1 ++-51:-51 ++-51.2:-51 ++12.2:13 diff --cc t/lib/bigintpm.t index 6904c2d,0000000..f819104 mode 100755,000000..100755 --- a/t/lib/bigintpm.t +++ b/t/lib/bigintpm.t @@@ -1,385 -1,0 +1,1238 @@@ - #!./perl ++#!/usr/bin/perl -w + - BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - } ++use strict; ++use Test; ++ ++BEGIN ++ { ++ $| = 1; ++ # chdir 't' if -d 't'; ++ unshift @INC, '../lib'; # for running manually ++ plan tests => 1190; ++ } ++ ++############################################################################## ++# for testing inheritance of _swap ++ ++package Math::Foo; ++ ++use Math::BigInt; ++use vars qw/@ISA/; ++@ISA = (qw/Math::BigInt/); ++ ++use overload ++# customized overload for sub, since original does not use swap there ++'-' => sub { my @a = ref($_[0])->_swap(@_); ++ $a[0]->bsub($a[1])}; ++ ++sub _swap ++ { ++ # a fake _swap, which reverses the params ++ my $self = shift; # for override in subclass ++ if ($_[2]) ++ { ++ my $c = ref ($_[0] ) || 'Math::Foo'; ++ return ( $_[0]->copy(), $_[1] ); ++ } ++ else ++ { ++ return ( Math::Foo->new($_[1]), $_[0] ); ++ } ++ } ++ ++############################################################################## ++package main; + +use Math::BigInt; + - $test = 0; - $| = 1; - print "1..283\n"; - while () { - chop; - if (s/^&//) { - $f = $_; - } else { - ++$test; - @args = split(/:/,$_,99); - $ans = pop(@args); - $try = "\$x = new Math::BigInt \"$args[0]\";"; - if ($f eq "bnorm"){ - $try .= "\$x+0;"; - } elsif ($f eq "bneg") { - $try .= "-\$x;"; - } elsif ($f eq "babs") { - $try .= "abs \$x;"; - } elsif ($f eq "bint") { - $try .= "int \$x;"; - } else { - $try .= "\$y = new Math::BigInt \"$args[1]\";"; - if ($f eq "bcmp"){ - $try .= "\$x <=> \$y;"; - }elsif ($f eq "badd"){ - $try .= "\$x + \$y;"; - }elsif ($f eq "bsub"){ - $try .= "\$x - \$y;"; - }elsif ($f eq "bmul"){ - $try .= "\$x * \$y;"; - }elsif ($f eq "bdiv"){ - $try .= "\$x / \$y;"; - }elsif ($f eq "bmod"){ - $try .= "\$x % \$y;"; - }elsif ($f eq "bgcd"){ - $try .= "Math::BigInt::bgcd(\$x, \$y);"; - }elsif ($f eq "blsft"){ - $try .= "\$x << \$y;"; - }elsif ($f eq "brsft"){ - $try .= "\$x >> \$y;"; - }elsif ($f eq "band"){ - $try .= "\$x & \$y;"; - }elsif ($f eq "bior"){ - $try .= "\$x | \$y;"; - }elsif ($f eq "bxor"){ - $try .= "\$x ^ \$y;"; - }elsif ($f eq "bnot"){ - $try .= "~\$x;"; - } else { warn "Unknown op"; } - } - #print ">>>",$try,"<<<\n"; - $ans1 = eval $try; - if ("$ans1" eq $ans) { #bug! - print "ok $test\n"; - } else { - print "not ok $test\n"; - print "# '$try' expected: '$ans' got: '$ans1'\n"; - } - } - } - - { - use Math::BigInt(0.02,':constant'); - - $test++; - print "not " - unless 2**150 eq "+1427247692705959881058285969449495136382746624"; - print "ok $test\n"; - $test++; - @a = (); - for ($i = 1; $i < 10; $i++) { - push @a, $i; ++my (@args,$f,$try,$x,$y,$z,$a,$exp,$ans,$ans1,@a,$m,$e,$round_mode); ++ ++while () ++ { ++ chop; ++ next if /^#/; # skip comments ++ if (s/^&//) ++ { ++ $f = $_; ++ } ++ elsif (/^\$/) ++ { ++ $round_mode = $_; ++ $round_mode =~ s/^\$/Math::BigInt->/; ++ # print "$round_mode\n"; ++ } ++ else ++ { ++ @args = split(/:/,$_,99); ++ $ans = pop(@args); ++ $try = "\$x = Math::BigInt->new(\"$args[0]\");"; ++ if ($f eq "bnorm"){ ++ # $try .= '$x+0;'; ++ } elsif ($f eq "_set") { ++ $try .= '$x->_set($args[1]); "$x";'; ++ } elsif ($f eq "is_zero") { ++ $try .= '$x->is_zero()+0;'; ++ } elsif ($f eq "is_one") { ++ $try .= '$x->is_one()+0;'; ++ } elsif ($f eq "is_odd") { ++ $try .= '$x->is_odd()+0;'; ++ } elsif ($f eq "is_even") { ++ $try .= '$x->is_even()+0;'; ++ } elsif ($f eq "binf") { ++ $try .= "\$x->binf('$args[1]');"; ++ } elsif ($f eq "bfloor") { ++ $try .= '$x->bfloor();'; ++ } elsif ($f eq "bceil") { ++ $try .= '$x->bceil();'; ++ } elsif ($f eq "is_inf") { ++ $try .= "\$x->is_inf('$args[1]')+0;"; ++ } elsif ($f eq "bsstr") { ++ $try .= '$x->bsstr();'; ++ } elsif ($f eq "bneg") { ++ $try .= '-$x;'; ++ } elsif ($f eq "babs") { ++ $try .= 'abs $x;'; ++ } elsif ($f eq "binc") { ++ $try .= '++$x;'; ++ } elsif ($f eq "bdec") { ++ $try .= '--$x;'; ++ }elsif ($f eq "bnot") { ++ $try .= '~$x;'; ++ }elsif ($f eq "bsqrt") { ++ $try .= '$x->bsqrt();'; ++ }elsif ($f eq "length") { ++ $try .= "\$x->length();"; ++ }elsif ($f eq "bround") { ++ $try .= "$round_mode; \$x->bround($args[1]);"; ++ }elsif ($f eq "exponent"){ ++ $try .= '$x = $x->exponent()->bstr();'; ++ }elsif ($f eq "mantissa"){ ++ $try .= '$x = $x->mantissa()->bstr();'; ++ }elsif ($f eq "parts"){ ++ $try .= "(\$m,\$e) = \$x->parts();"; ++ $try .= '$m = $m->bstr(); $m = "NaN" if !defined $m;'; ++ $try .= '$e = $e->bstr(); $e = "NaN" if !defined $e;'; ++ $try .= '"$m,$e";'; ++ } else { ++ $try .= "\$y = new Math::BigInt \"$args[1]\";"; ++ if ($f eq "bcmp"){ ++ $try .= '$x <=> $y;'; ++ }elsif ($f eq "bacmp"){ ++ $try .= '$x->bacmp($y);'; ++ }elsif ($f eq "badd"){ ++ $try .= "\$x + \$y;"; ++ }elsif ($f eq "bsub"){ ++ $try .= "\$x - \$y;"; ++ }elsif ($f eq "bmul"){ ++ $try .= "\$x * \$y;"; ++ }elsif ($f eq "bdiv"){ ++ $try .= "\$x / \$y;"; ++ }elsif ($f eq "bmod"){ ++ $try .= "\$x % \$y;"; ++ }elsif ($f eq "bgcd") ++ { ++ if (defined $args[2]) ++ { ++ $try .= " \$z = new Math::BigInt \"$args[2]\"; "; ++ } ++ $try .= "Math::BigInt::bgcd(\$x, \$y"; ++ $try .= ", \$z" if (defined $args[2]); ++ $try .= " );"; ++ } ++ elsif ($f eq "blcm") ++ { ++ if (defined $args[2]) ++ { ++ $try .= " \$z = new Math::BigInt \"$args[2]\"; "; ++ } ++ $try .= "Math::BigInt::blcm(\$x, \$y"; ++ $try .= ", \$z" if (defined $args[2]); ++ $try .= " );"; ++ }elsif ($f eq "blsft"){ ++ if (defined $args[2]) ++ { ++ $try .= "\$x->blsft(\$y,$args[2]);"; ++ } ++ else ++ { ++ $try .= "\$x << \$y;"; ++ } ++ }elsif ($f eq "brsft"){ ++ if (defined $args[2]) ++ { ++ $try .= "\$x->brsft(\$y,$args[2]);"; ++ } ++ else ++ { ++ $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 "bpow"){ ++ $try .= "\$x ** \$y;"; ++ }elsif ($f eq "digit"){ ++ $try = "\$x = Math::BigInt->new(\"$args[0]\"); \$x->digit($args[1]);"; ++ } else { warn "Unknown op '$f'"; } ++ } ++ # print "trying $try\n"; ++ $ans1 = eval $try; ++ $ans =~ s/^[+]([0-9])/$1/; # remove leading '+' ++ if ($ans eq "") ++ { ++ ok_undef ($ans1); ++ } ++ else ++ { ++ #print "try: $try ans: $ans1 $ans\n"; ++ print "# Tried: '$try'\n" if !ok ($ans1, $ans); ++ } ++ # check internal state of number objects ++ is_valid($ans1) if ref $ans1; ++ } ++ } # endwhile data tests ++close DATA; ++ ++# test whether constant works or not ++$try = "use Math::BigInt (1.31,'babs',':constant');"; ++$try .= ' $x = 2**150; babs($x); $x = "$x";'; ++$ans1 = eval $try; ++ ++ok ( $ans1, "1427247692705959881058285969449495136382746624"); ++ ++# test some more ++@a = (); ++for (my $i = 1; $i < 10; $i++) ++ { ++ push @a, $i; ++ } ++ok "@a", "1 2 3 4 5 6 7 8 9"; ++ ++# test whether selfmultiplication works correctly (result is 2**64) ++$try = '$x = new Math::BigInt "+4294967296";'; ++$try .= '$a = $x->bmul($x);'; ++$ans1 = eval $try; ++print "# Tried: '$try'\n" if !ok ($ans1, Math::BigInt->new(2) ** 64); ++ ++# test whether op detroys args or not (should better not) ++ ++$x = new Math::BigInt (3); ++$y = new Math::BigInt (4); ++$z = $x & $y; ++ok ($x,3); ++ok ($y,4); ++ok ($z,0); ++$z = $x | $y; ++ok ($x,3); ++ok ($y,4); ++ok ($z,7); ++$x = new Math::BigInt (1); ++$y = new Math::BigInt (2); ++$z = $x | $y; ++ok ($x,1); ++ok ($y,2); ++ok ($z,3); ++ ++$x = new Math::BigInt (5); ++$y = new Math::BigInt (4); ++$z = $x ^ $y; ++ok ($x,5); ++ok ($y,4); ++ok ($z,1); ++ ++$x = new Math::BigInt (-5); $y = -$x; ++ok ($x, -5); ++ ++$x = new Math::BigInt (-5); $y = abs($x); ++ok ($x, -5); ++ ++# check whether overloading cmp works ++$try = "\$x = Math::BigInt->new(0);"; ++$try .= "\$y = 10;"; ++$try .= "'false' if \$x ne \$y;"; ++$ans = eval $try; ++print "# For '$try'\n" if (!ok "$ans" , "false" ); ++ ++# we cant test for working cmpt with other objects here, we would need a dummy ++# object with stringify overload for this. see Math::String tests ++ ++############################################################################### ++# check shortcuts ++$try = "\$x = Math::BigInt->new(1); \$x += 9;"; ++$try .= "'ok' if \$x == 10;"; ++$ans = eval $try; ++print "# For '$try'\n" if (!ok "$ans" , "ok" ); ++ ++$try = "\$x = Math::BigInt->new(1); \$x -= 9;"; ++$try .= "'ok' if \$x == -8;"; ++$ans = eval $try; ++print "# For '$try'\n" if (!ok "$ans" , "ok" ); ++ ++$try = "\$x = Math::BigInt->new(1); \$x *= 9;"; ++$try .= "'ok' if \$x == 9;"; ++$ans = eval $try; ++print "# For '$try'\n" if (!ok "$ans" , "ok" ); ++ ++$try = "\$x = Math::BigInt->new(10); \$x /= 2;"; ++$try .= "'ok' if \$x == 5;"; ++$ans = eval $try; ++print "# For '$try'\n" if (!ok "$ans" , "ok" ); ++ ++############################################################################### ++# check reversed order of arguments ++$try = "\$x = Math::BigInt->new(10); \$x = 2 ** \$x;"; ++$try .= "'ok' if \$x == 1024;"; $ans = eval $try; ++print "# For '$try'\n" if (!ok "$ans" , "ok" ); ++ ++$try = "\$x = Math::BigInt->new(10); \$x = 2 * \$x;"; ++$try .= "'ok' if \$x == 20;"; $ans = eval $try; ++print "# For '$try'\n" if (!ok "$ans" , "ok" ); ++ ++$try = "\$x = Math::BigInt->new(10); \$x = 2 + \$x;"; ++$try .= "'ok' if \$x == 12;"; $ans = eval $try; ++print "# For '$try'\n" if (!ok "$ans" , "ok" ); ++ ++$try = "\$x = Math::BigInt->new(10); \$x = 2 - \$x;"; ++$try .= "'ok' if \$x == -8;"; $ans = eval $try; ++print "# For '$try'\n" if (!ok "$ans" , "ok" ); ++ ++$try = "\$x = Math::BigInt->new(10); \$x = 20 / \$x;"; ++$try .= "'ok' if \$x == 2;"; $ans = eval $try; ++print "# For '$try'\n" if (!ok "$ans" , "ok" ); ++ ++############################################################################### ++# check badd(4,5) form ++ ++$try = "\$x = Math::BigInt::badd(4,5);"; ++$try .= "'ok' if \$x == 9;"; ++$ans = eval $try; ++print "# For '$try'\n" if (!ok "$ans" , "ok" ); ++ ++$try = "\$x = Math::BigInt->badd(4,5);"; ++$try .= "'ok' if \$x == 9;"; ++$ans = eval $try; ++print "# For '$try'\n" if (!ok "$ans" , "ok" ); ++ ++############################################################################### ++# check proper length of internal arrays ++ ++$x = Math::BigInt->new(99999); ++ok ($x,99999); ++ok (scalar @{$x->{value}}, 1); ++$x += 1; ++ok ($x,100000); ++ok (scalar @{$x->{value}}, 2); ++$x -= 1; ++ok ($x,99999); ++ok (scalar @{$x->{value}}, 1); ++ ++############################################################################### ++# check numify ++ ++my $BASE = int(1e5); ++$x = Math::BigInt->new($BASE-1); ok ($x->numify(),$BASE-1); ++$x = Math::BigInt->new(-($BASE-1)); ok ($x->numify(),-($BASE-1)); ++$x = Math::BigInt->new($BASE); ok ($x->numify(),$BASE); ++$x = Math::BigInt->new(-$BASE); ok ($x->numify(),-$BASE); ++$x = Math::BigInt->new( -($BASE*$BASE*1+$BASE*1+1) ); ++ok($x->numify(),-($BASE*$BASE*1+$BASE*1+1)); ++ ++############################################################################### ++# test bug in _digits with length($c[-1]) where $c[-1] was "00001" instead of 1 ++ ++$x = Math::BigInt->new(99998); $x++; $x++; $x++; $x++; ++if ($x > 100000) { ok (1,1) } else { ok ("$x < 100000","$x > 100000"); } ++ ++$x = Math::BigInt->new(100003); $x++; ++$y = Math::BigInt->new(1000000); ++if ($x < 1000000) { ok (1,1) } else { ok ("$x > 1000000","$x < 1000000"); } ++ ++############################################################################### ++# bug in sub where number with at least 6 trailing zeros after any op failed ++ ++$x = Math::BigInt->new(123456); $z = Math::BigInt->new(10000); $z *= 10; ++$x -= $z; ++ok ($z, 100000); ++ok ($x, 23456); ++ ++############################################################################### ++# bug with rest "-0" in div, causing further div()s to fail ++ ++$x = Math::BigInt->new(-322056000); ($x,$y) = $x->bdiv('-12882240'); ++ ++ok ($y,'0'); # not '-0' ++is_valid($y); ++ ++############################################################################### ++# check undefs: NOT DONE YET ++ ++############################################################################### ++# bool ++ ++$x = Math::BigInt->new(1); if ($x) { ok (1,1); } else { ok($x,'to be true') } ++$x = Math::BigInt->new(0); if (!$x) { ok (1,1); } else { ok($x,'to be false') } ++ ++############################################################################### ++# objectify() ++ ++@args = Math::BigInt::objectify(2,4,5); ++ok (scalar @args,3); # 'Math::BigInt', 4, 5 ++ok ($args[0],'Math::BigInt'); ++ok ($args[1],4); ++ok ($args[2],5); ++ ++@args = Math::BigInt::objectify(0,4,5); ++ok (scalar @args,3); # 'Math::BigInt', 4, 5 ++ok ($args[0],'Math::BigInt'); ++ok ($args[1],4); ++ok ($args[2],5); ++ ++@args = Math::BigInt::objectify(2,4,5); ++ok (scalar @args,3); # 'Math::BigInt', 4, 5 ++ok ($args[0],'Math::BigInt'); ++ok ($args[1],4); ++ok ($args[2],5); ++ ++@args = Math::BigInt::objectify(2,4,5,6,7); ++ok (scalar @args,5); # 'Math::BigInt', 4, 5, 6, 7 ++ok ($args[0],'Math::BigInt'); ++ok ($args[1],4); ok (ref($args[1]),$args[0]); ++ok ($args[2],5); ok (ref($args[2]),$args[0]); ++ok ($args[3],6); ok (ref($args[3]),''); ++ok ($args[4],7); ok (ref($args[4]),''); ++ ++@args = Math::BigInt::objectify(2,'Math::BigInt',4,5,6,7); ++ok (scalar @args,5); # 'Math::BigInt', 4, 5, 6, 7 ++ok ($args[0],'Math::BigInt'); ++ok ($args[1],4); ok (ref($args[1]),$args[0]); ++ok ($args[2],5); ok (ref($args[2]),$args[0]); ++ok ($args[3],6); ok (ref($args[3]),''); ++ok ($args[4],7); ok (ref($args[4]),''); ++ ++############################################################################### ++# test for flaoting-point input (other tests in bnorm() below) ++ ++$z = 1050000000000000; # may be int on systems with 64bit? ++$x = Math::BigInt->new($z); ok ($x->bsstr(),'105e+13'); # not 1.03e+15? ++$z = 1e+129; # definitely a float ++$x = Math::BigInt->new($z); ok ($x->bsstr(),$z); ++ ++############################################################################### ++# prime number tests, also test for **= and length() ++# found on: http://www.utm.edu/research/primes/notes/by_year.html ++ ++# ((2^148)-1)/17 ++$x = Math::BigInt->new(2); $x **= 148; $x++; $x = $x / 17; ++ok ($x,"20988936657440586486151264256610222593863921"); ++ok ($x->length(),length "20988936657440586486151264256610222593863921"); ++ ++# MM7 = 2^127-1 ++$x = Math::BigInt->new(2); $x **= 127; $x--; ++ok ($x,"170141183460469231731687303715884105727"); ++ ++# I am afraid the following is not yet possible due to slowness ++# Also, testing for 2 meg output is a bit hard ;) ++#$x = new Math::BigInt(2); $x **= 6972593; $x--; ++ ++# 593573509*2^332162+1 has exactly 100.000 digits ++# takes over 16 mins and still not complete, so can not be done yet ;) ++#$x = Math::BigInt->new(2); $x **= 332162; $x *= "593573509"; $x++; ++#ok ($x->digits(),100000); ++ ++############################################################################### ++# inheritance and overriding of _swap ++ ++$x = Math::Foo->new(5); ++$x = $x - 8; # 8 - 5 instead of 5-8 ++ok ($x,3); ++ok (ref($x),'Math::Foo'); ++ ++$x = Math::Foo->new(5); ++$x = 8 - $x; # 5 - 8 instead of 8 - 5 ++ok ($x,-3); ++ok (ref($x),'Math::Foo'); ++ ++############################################################################### ++# all tests done ++ ++# devel test, see whether valid catches errors ++#$x = Math::BigInt->new(0); ++#$x->{sign} = '-'; ++#is_valid($x); # nok ++# ++#$x->{sign} = 'e'; ++#is_valid($x); # nok ++# ++#$x->{value}->[0] = undef; ++#is_valid($x); # nok ++# ++#$x->{value}->[0] = 1e6; ++#is_valid($x); # nok ++# ++#$x->{value}->[0] = -2; ++#is_valid($x); # nok ++# ++#$x->{sign} = '+'; ++#is_valid($x); # ok ++ ++############################################################################### ++# Perl 5.005 does not like ok ($x,undef) ++ ++sub ok_undef ++ { ++ my $x = shift; ++ ++ ok (1,1) and return if !defined $x; ++ ok ($x,'undef'); ++ } ++ ++############################################################################### ++# sub to check validity of a BigInt internally, to ensure that no op leaves a ++# number object in an invalid state (f.i. "-0") ++ ++sub is_valid ++ { ++ my $x = shift; ++ ++ my $error = ["",]; ++ ++ # ok as reference? ++ is_okay('ref($x)','Math::BigInt',ref($x),$error); ++ ++ # has ok sign? ++ is_okay('$x->{sign}',"'+', '-', '-inf', '+inf' or 'NaN'",$x->{sign},$error) ++ if $x->{sign} !~ /^(\+|-|\+inf|-inf|NaN)$/; ++ ++ # is not -0? ++ if (($x->{sign} eq '-') && (@{$x->{value}} == 1) && ($x->{value}->[0] == 0)) ++ { ++ is_okay("\$x ne '-0'","0",$x,$error); ++ } ++ # all parts are valid? ++ my $i = 0; my $j = scalar @{$x->{value}}; my $e; my $try; ++ while ($i < $j) ++ { ++ $e = $x->{value}->[$i]; $e = 'undef' unless defined $e; ++ $try = '=~ /^[\+]?[0-9]+\$/; '."($f, $x, $e)"; ++ last if $e !~ /^[+]?[0-9]+$/; ++ $try = ' < 0 || >= 1e5; '."($f, $x, $e)"; ++ last if $e <0 || $e >= 1e5; ++ # this test is disabled, since new/bnorm and certain ops (like early out ++ # in add/sub) are allowed/expected to leave '00000' in some elements ++ #$try = '=~ /^00+/; '."($f, $x, $e)"; ++ #last if $e =~ /^00+/; ++ $i++; ++ } ++ is_okay("\$x->{value}->[$i] $try","not $e",$e,$error) ++ if $i < $j; # trough all? ++ ++ # see whether errors crop up ++ $error->[1] = 'undef' unless defined $error->[1]; ++ if ($error->[0] ne "") ++ { ++ ok ($error->[1],$error->[2]); ++ print "# Tried: $error->[0]\n"; ++ } ++ else ++ { ++ ok (1,1); ++ } ++ } ++ ++sub is_okay ++ { ++ my ($tried,$expected,$try,$error) = @_; ++ ++ return if $error->[0] ne ""; # error, no further testing ++ ++ @$error = ( $tried, $try, $expected ) if $try ne $expected; + } - print "not " unless "@a" eq "+1 +2 +3 +4 +5 +6 +7 +8 +9"; - print "ok $test\n"; - } - ++ +__END__ +&bnorm ++# binary input ++0babc:NaN ++0b123:NaN ++0b0:0 ++-0b0:0 ++-0b1:-1 ++0b0001:1 ++0b001:1 ++0b011:3 ++0b101:5 ++0b1000000000000000000000000000000:1073741824 ++# hex input ++-0x0:0 ++0xabcdefgh:NaN ++0x1234:4660 ++0xabcdef:11259375 ++-0xABCDEF:-11259375 ++-0x1234:-4660 ++0x12345678:305419896 ++# inf input +++inf:+inf ++-inf:-inf ++0inf:NaN ++# normal input ++:NaN +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 ++0:0 +++0:0 +++00:0 +++000:0 ++000000000000000000: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 ++1_2_3:123 ++_123:NaN ++_123_:NaN ++_123_:NaN ++1__23:NaN ++10000000000E-1_0:1 ++1E2:100 ++1E1:10 ++1E0:1 ++E1:NaN ++E23:NaN ++1.23E2:123 ++1.23E1:NaN ++1.23E-1:NaN ++100E-1:10 ++# floating point input ++1.01E2:101 ++1010E-1:101 ++-1010E0:-1010 ++-1010E1:-10100 ++-1010E-2:NaN ++-1.01E+1:NaN ++-1.01E-1:NaN ++&binf ++1:+:+inf ++2:-:-inf ++3:abc:+inf ++&is_inf +++inf::1 ++-inf::1 ++abc::0 ++1::0 ++NaN::0 ++-1::0 +++inf:-:0 +++inf:+:1 ++-inf:-:1 ++-inf:+:0 ++&blsft ++abc:abc:NaN +++2:+2:+8 +++1:+32:+4294967296 +++1:+48:+281474976710656 +++8:-2:NaN ++# excercise base 10 +++12345:4:10:123450000 ++-1234:0:10:-1234 +++1234:0:10:+1234 +++2:2:10:200 +++12:2:10:1200 +++1234:-3:10:NaN ++1234567890123:12:10:1234567890123000000000000 ++&brsft ++abc:abc:NaN +++8:+2:+2 +++4294967296:+32:+1 +++281474976710656:+48:+1 +++2:-2:NaN ++# excercise base 10 ++-1234:0:10:-1234 +++1234:0:10:+1234 +++200:2:10:2 +++1234:3:10:1 +++1234:2:10:12 +++1234:-3:10:NaN ++310000:4:10:31 ++12300000:5:10:123 ++1230000000000:10:10:123 ++09876123456789067890:12:10:9876123 ++1234561234567890123:13:10:123456 ++&bsstr ++1e+34:1e+34 ++123.456E3:123456e+0 ++100:1e+2 ++abc:NaN +&bneg +abd:NaN ++0:+0 ++1:-1 +-1:+1 ++123456789:-123456789 +-123456789:+123456789 +&babs +abc:NaN ++0:+0 ++1:+1 +-1:+1 ++123456789:+123456789 +-123456789:+123456789 +&bcmp +abc:abc: +abc:+0: ++0:abc: ++0:+0:0 +-1:+0:-1 ++0:-1:1 ++1:+0:1 ++0:+1:-1 +-1:+1:-1 ++1:-1:1 +-1:-1:0 ++1:+1:0 ++123:+123:0 ++123:+12:1 ++12:+123:-1 +-123:-123:0 +-123:-12:-1 +-12:-123:1 ++123:+124:-1 ++124:+123:1 +-123:-124:1 +-124:-123:-1 ++100:+5:1 ++-123456789:+987654321:-1 +++123456789:-987654321:1 ++-987654321:+123456789:-1 ++&bacmp +++0:-0:0 +++0:+1:-1 ++-1:+1:0 +++1:-1:0 ++-1:+2:-1 +++2:-1:1 ++-123456789:+987654321:-1 +++123456789:-987654321:-1 ++-987654321:+123456789:1 ++&binc ++abc:NaN +++0:+1 +++1:+2 ++-1:+0 ++&bdec ++abc:NaN +++0:-1 +++1:+0 ++-1:-2 +&badd +abc:abc:NaN +abc:+0:NaN ++0:abc:NaN ++0:+0:+0 ++1:+0:+1 ++0:+1:+1 ++1:+1:+2 +-1:+0:-1 ++0:-1:-1 +-1:-1:-2 +-1:+1:+0 ++1:-1:+0 ++9:+1:+10 ++99:+1:+100 ++999:+1:+1000 ++9999:+1:+10000 ++99999:+1:+100000 ++999999:+1:+1000000 ++9999999:+1:+10000000 ++99999999:+1:+100000000 ++999999999:+1:+1000000000 ++9999999999:+1:+10000000000 ++99999999999:+1:+100000000000 ++10:-1:+9 ++100:-1:+99 ++1000:-1:+999 ++10000:-1:+9999 ++100000:-1:+99999 ++1000000:-1:+999999 ++10000000:-1:+9999999 ++100000000:-1:+99999999 ++1000000000:-1:+999999999 ++10000000000:-1:+9999999999 ++123456789:+987654321:+1111111110 +-123456789:+987654321:+864197532 +-123456789:-987654321:-1111111110 ++123456789:-987654321:-864197532 +&bsub +abc:abc:NaN +abc:+0:NaN ++0:abc:NaN ++0:+0:+0 ++1:+0:+1 ++0:+1:-1 ++1:+1:+0 +-1:+0:-1 ++0:-1:+1 +-1:-1:+0 +-1:+1:-2 ++1:-1:+2 ++9:+1:+8 ++99:+1:+98 ++999:+1:+998 ++9999:+1:+9998 ++99999:+1:+99998 ++999999:+1:+999998 ++9999999:+1:+9999998 ++99999999:+1:+99999998 ++999999999:+1:+999999998 ++9999999999:+1:+9999999998 ++99999999999:+1:+99999999998 ++10:-1:+11 ++100:-1:+101 ++1000:-1:+1001 ++10000:-1:+10001 ++100000:-1:+100001 ++1000000:-1:+1000001 ++10000000:-1:+10000001 ++100000000:-1:+100000001 ++1000000000:-1:+1000000001 ++10000000000:-1:+10000000001 ++123456789:+987654321:-864197532 +-123456789:+987654321:-1111111110 +-123456789:-987654321:+864197532 ++123456789:-987654321:+1111111110 +&bmul +abc:abc:NaN +abc:+0:NaN ++0:abc:NaN ++0:+0:+0 ++0:+1:+0 ++1:+0:+0 ++0:-1:+0 +-1:+0:+0 ++123456789123456789:+0:+0 ++0:+123456789123456789:+0 +-1:-1:+1 +-1:+1:-1 ++1:-1:-1 ++1:+1:+1 ++2:+3:+6 +-2:+3:-6 ++2:-3:-6 +-2:-3:+6 ++111:+111:+12321 ++10101:+10101:+102030201 ++1001001:+1001001:+1002003002001 ++100010001:+100010001:+10002000300020001 ++10000100001:+10000100001:+100002000030000200001 ++11111111111:+9:+99999999999 ++22222222222:+9:+199999999998 ++33333333333:+9:+299999999997 ++44444444444:+9:+399999999996 ++55555555555:+9:+499999999995 ++66666666666:+9:+599999999994 ++77777777777:+9:+699999999993 ++88888888888:+9:+799999999992 ++99999999999:+9:+899999999991 +++25:+25:+625 +++12345:+12345:+152399025 +++99999:+11111:+1111088889 +&bdiv +abc:abc:NaN +abc:+1:abc:NaN ++1:abc:NaN ++0:+0:NaN ++0:+1:+0 ++1:+0:NaN ++0:-1:+0 +-1:+0:NaN ++1:+1:+1 +-1:-1:+1 ++1:-1:-1 +-1:+1:-1 ++1:+2:+0 ++2:+1:+2 +++1:+26:+0 ++1000000000:+9:+111111111 ++2000000000:+9:+222222222 ++3000000000:+9:+333333333 ++4000000000:+9:+444444444 ++5000000000:+9:+555555555 ++6000000000:+9:+666666666 ++7000000000:+9:+777777777 ++8000000000:+9:+888888888 ++9000000000:+9:+1000000000 ++35500000:+113:+314159 ++71000000:+226:+314159 ++106500000:+339:+314159 ++1000000000:+3:+333333333 ++10:+5:+2 ++100:+4:+25 ++1000:+8:+125 ++10000:+16:+625 ++999999999999:+9:+111111111111 ++999999999999:+99:+10101010101 ++999999999999:+999:+1001001001 ++999999999999:+9999:+100010001 ++999999999999999:+99999:+10000100001 +++1111088889:+99999:+11111 ++-5:-3:1 ++4:3:1 ++1:3:0 ++-2:-3:0 ++-2:3:-1 ++1:-3:-1 ++-5:3:-2 ++4:-3:-2 +&bmod +abc:abc:NaN +abc:+1:abc:NaN ++1:abc:NaN ++0:+0:NaN ++0:+1:+0 ++1:+0:NaN ++0:-1:+0 +-1:+0:NaN ++1:+1:+0 +-1:-1:+0 ++1:-1:+0 +-1:+1:+0 ++1:+2:+1 ++2:+1:+0 ++1000000000:+9:+1 ++2000000000:+9:+2 ++3000000000:+9:+3 ++4000000000:+9:+4 ++5000000000:+9:+5 ++6000000000:+9:+6 ++7000000000:+9:+7 ++8000000000:+9:+8 ++9000000000:+9:+0 ++35500000:+113:+33 ++71000000:+226:+66 ++106500000:+339:+99 ++1000000000:+3:+1 ++10:+5:+0 ++100:+4:+0 ++1000:+8:+0 ++10000:+16:+0 ++999999999999:+9:+0 ++999999999999:+99:+0 ++999999999999:+999:+0 ++999999999999:+9999:+0 ++999999999999999:+99999:+0 ++-9:+5:+1 +++9:-5:-1 ++-9:-5:-4 ++-5:3:1 ++-2:3:1 ++4:3:1 ++1:3:1 ++-5:-3:-2 ++-2:-3:-2 ++4:-3:-2 ++1:-3:-2 +&bgcd +abc:abc:NaN +abc:+0:NaN ++0:abc:NaN ++0:+0:+0 ++0:+1:+1 ++1:+0:+1 ++1:+1:+1 ++2:+3:+1 ++3:+2:+1 ++-3:+2:+1 ++100:+625:+25 ++4096:+81:+1 - &blsft +++1034:+804:+2 +++27:+90:+56:+1 +++27:+90:+54:+9 ++&blcm +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 ++abc:+0:NaN +++0:abc:NaN +++0:+0:NaN +++1:+0:+0 +++0:+1:+0 +++27:+90:+270 +++1034:+804:+415668 +&band +abc:abc:NaN ++abc:0:NaN ++0:abc:NaN ++8:+2:+0 ++281474976710656:+0:+0 ++281474976710656:+1:+0 ++281474976710656:+281474976710656:+281474976710656 +&bior +abc:abc:NaN ++abc:0:NaN ++0:abc:NaN ++8:+2:+10 ++281474976710656:+0:+281474976710656 ++281474976710656:+1:+281474976710657 ++281474976710656:+281474976710656:+281474976710656 +&bxor +abc:abc:NaN ++abc:0:NaN ++0:abc:NaN ++8:+2:+10 ++281474976710656:+0:+281474976710656 ++281474976710656:+1:+281474976710657 ++281474976710656:+281474976710656:+0 +&bnot +abc:NaN ++0:-1 ++8:-9 ++281474976710656:-281474976710657 - &bint - +0:+0 - +1:+1 - +11111111111111111234:+11111111111111111234 ++&digit ++0:0:0 ++12:0:2 ++12:1:1 ++123:0:3 ++123:1:2 ++123:2:1 ++123:-1:1 ++123:-2:2 ++123:-3:3 ++123456:0:6 ++123456:1:5 ++123456:2:4 ++123456:3:3 ++123456:4:2 ++123456:5:1 ++123456:-1:1 ++123456:-2:2 ++123456:-3:3 ++100000:-3:0 ++100000:0:0 ++100000:1:0 ++&mantissa ++abc:NaN ++1e4:1 ++2e0:2 ++123:123 ++-1:-1 ++-2:-2 ++&exponent ++abc:NaN ++1e4:4 ++2e0:0 ++123:0 ++-1:0 ++-2:0 ++0:1 ++&parts ++abc:NaN,NaN ++1e4:1,4 ++2e0:2,0 ++123:123,0 ++-1:-1,0 ++-2:-2,0 ++0:0,1 ++&bpow ++0:0:1 ++0:1:0 ++0:2:0 ++0:-1:NaN ++0:-2:NaN ++1:0:1 ++1:1:1 ++1:2:1 ++1:3:1 ++1:-1:1 ++1:-2:1 ++1:-3:1 ++2:0:1 ++2:1:2 ++2:2:4 ++2:3:8 ++3:3:27 ++2:-1:NaN ++-2:-1:NaN ++2:-2:NaN ++-2:-2:NaN ++# 1 ** -x => 1 / (1 ** x) ++-1:0:1 ++-2:0:1 ++-1:1:-1 ++-1:2:1 ++-1:3:-1 ++-1:4:1 ++-1:5:-1 ++-1:-1:-1 ++-1:-2:1 ++-1:-3:-1 ++-1:-4:1 ++10:2:100 ++10:3:1000 ++10:4:10000 ++10:5:100000 ++10:6:1000000 ++10:7:10000000 ++10:8:100000000 ++10:9:1000000000 ++10:20:100000000000000000000 ++123456:2:15241383936 ++&length ++100:3 ++10:2 ++1:1 ++0:1 ++12345:5 ++10000000000000000:17 ++-123:3 ++&bsqrt ++144:12 ++16:4 ++4:2 ++2:1 ++12:3 ++256:16 ++100000000:10000 ++4000000000000:2000000 ++1:1 ++0:0 ++-2:NaN ++Nan:NaN ++&bround ++$round_mode('trunc') ++1234:0:1234 ++1234:2:1200 ++123456:4:123400 ++123456:5:123450 ++123456:6:123456 +++10123456789:5:+10123000000 ++-10123456789:5:-10123000000 +++10123456789:9:+10123456700 ++-10123456789:9:-10123456700 +++101234500:6:+101234000 ++-101234500:6:-101234000 ++#+101234500:-4:+101234000 ++#-101234500:-4:-101234000 ++$round_mode('zero') +++20123456789:5:+20123000000 ++-20123456789:5:-20123000000 +++20123456789:9:+20123456800 ++-20123456789:9:-20123456800 +++201234500:6:+201234000 ++-201234500:6:-201234000 ++#+201234500:-4:+201234000 ++#-201234500:-4:-201234000 +++12345000:4:12340000 ++-12345000:4:-12340000 ++$round_mode('+inf') +++30123456789:5:+30123000000 ++-30123456789:5:-30123000000 +++30123456789:9:+30123456800 ++-30123456789:9:-30123456800 +++301234500:6:+301235000 ++-301234500:6:-301234000 ++#+301234500:-4:+301235000 ++#-301234500:-4:-301234000 +++12345000:4:12350000 ++-12345000:4:-12340000 ++$round_mode('-inf') +++40123456789:5:+40123000000 ++-40123456789:5:-40123000000 +++40123456789:9:+40123456800 ++-40123456789:9:-40123456800 +++401234500:6:+401234000 +++401234500:6:+401234000 ++#-401234500:-4:-401235000 ++#-401234500:-4:-401235000 +++12345000:4:12340000 ++-12345000:4:-12350000 ++$round_mode('odd') +++50123456789:5:+50123000000 ++-50123456789:5:-50123000000 +++50123456789:9:+50123456800 ++-50123456789:9:-50123456800 +++501234500:6:+501235000 ++-501234500:6:-501235000 ++#+501234500:-4:+501235000 ++#-501234500:-4:-501235000 +++12345000:4:12350000 ++-12345000:4:-12350000 ++$round_mode('even') +++60123456789:5:+60123000000 ++-60123456789:5:-60123000000 +++60123456789:9:+60123456800 ++-60123456789:9:-60123456800 +++601234500:6:+601234000 ++-601234500:6:-601234000 ++#+601234500:-4:+601234000 ++#-601234500:-4:-601234000 ++#-601234500:-9:0 ++#-501234500:-9:0 ++#-601234500:-8:0 ++#-501234500:-8:0 +++1234567:7:1234567 +++1234567:6:1234570 +++12345000:4:12340000 ++-12345000:4:-12340000 ++&is_odd ++abc:0 ++0:0 ++1:1 ++3:1 ++-1:1 ++-3:1 ++10000001:1 ++10000002:0 ++2:0 ++&is_even ++abc:0 ++0:1 ++1:0 ++3:0 ++-1:0 ++-3:0 ++10000001:0 ++10000002:1 ++2:1 ++&is_zero ++0:1 ++NaNzero:0 ++123:0 ++-1:0 ++1:0 ++&_set ++2:-1:-1 ++-2:1:1 ++NaN:2:2 ++2:abc:NaN ++&is_one ++0:0 ++1:1 ++2:0 ++-1:0 ++-2:0 ++# floor and ceil tests are pretty pointless in integer space...but play safe ++&bfloor ++0:0 +-1:-1 - -11111111111111111234:-11111111111111111234 ++-2:-2 ++2:2 ++3:3 ++abc:NaN ++&bceil ++0:0 ++-1:-1 ++-2:-2 ++2:2 ++3:3 ++abc:NaN diff --cc t/lib/cwd.t index 5a3ecae,0000000..09b45d6 mode 100644,000000..100644 --- a/t/lib/cwd.t +++ b/t/lib/cwd.t @@@ -1,134 -1,0 +1,134 @@@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Config; +use Cwd; +use strict; +use warnings; + +print "1..14\n"; + +# check imports +print +(defined(&cwd) && + defined(&getcwd) && + defined(&fastcwd) && + defined(&fastgetcwd) ? + "" : "not "), "ok 1\n"; +print +(!defined(&chdir) && + !defined(&abs_path) && + !defined(&fast_abs_path) ? + "" : "not "), "ok 2\n"; + +# XXX force Cwd to bootsrap its XSUBs since we have set @INC = "../lib" +# XXX and subsequent chdir()s can make them impossible to find +eval { fastcwd }; + +# Must find an external pwd (or equivalent) command. + +my $pwd_cmd = - ($^O eq "MSWin32") ? "cd" : (grep { -x && -f } map { "$_/pwd" } ++ ($^O eq "MSWin32" || $^O eq "NetWare") ? "cd" : (grep { -x && -f } map { "$_/pwd" } + split m/$Config{path_sep}/, $ENV{PATH})[0]; + +if ($^O eq 'VMS') { $pwd_cmd = 'SHOW DEFAULT'; } + +if (defined $pwd_cmd) { + chomp(my $start = `$pwd_cmd`); + # Win32's cd returns native C:\ style - $start =~ s,\\,/,g if $^O eq 'MSWin32'; ++ $start =~ s,\\,/,g if ($^O eq 'MSWin32' || $^O eq "NetWare"); + # DCL SHOW DEFAULT has leading spaces + $start =~ s/^\s+// if $^O eq 'VMS'; + if ($?) { + for (3..6) { + print "ok $_ # Skip: '$pwd_cmd' failed\n"; + } + } else { + my $cwd = cwd; + my $getcwd = getcwd; + my $fastcwd = fastcwd; + my $fastgetcwd = fastgetcwd; + print +($cwd eq $start ? "" : "not "), "ok 3\n"; + print +($getcwd eq $start ? "" : "not "), "ok 4\n"; + print +($fastcwd eq $start ? "" : "not "), "ok 5\n"; + print +($fastgetcwd eq $start ? "" : "not "), "ok 6\n"; + } +} else { + for (3..6) { + print "ok $_ # Skip: no pwd command found\n"; + } +} + +mkdir "pteerslt", 0777; +mkdir "pteerslt/path", 0777; +mkdir "pteerslt/path/to", 0777; +mkdir "pteerslt/path/to/a", 0777; +mkdir "pteerslt/path/to/a/dir", 0777; +Cwd::chdir "pteerslt/path/to/a/dir"; +my $cwd = cwd; +my $getcwd = getcwd; +my $fastcwd = fastcwd; +my $fastgetcwd = fastgetcwd; +my $want = "t/pteerslt/path/to/a/dir"; +print "# cwd = '$cwd'\n"; +print "# getcwd = '$getcwd'\n"; +print "# fastcwd = '$fastcwd'\n"; +print "# fastgetcwd = '$fastgetcwd'\n"; +# This checked out OK on ODS-2 and ODS-5: +$want = "T\.PTEERSLT\.PATH\.TO\.A\.DIR\]" if $^O eq 'VMS'; +print +($cwd =~ m|$want$| ? "" : "not "), "ok 7\n"; +print +($getcwd =~ m|$want$| ? "" : "not "), "ok 8\n"; +print +($fastcwd =~ m|$want$| ? "" : "not "), "ok 9\n"; +print +($fastgetcwd =~ m|$want$| ? "" : "not "), "ok 10\n"; + +# Cwd::chdir should also update $ENV{PWD} +print "#$ENV{PWD}\n"; +print +($ENV{PWD} =~ m|$want$| ? "" : "not "), "ok 11\n"; +Cwd::chdir ".."; rmdir "dir"; +print "#$ENV{PWD}\n"; +Cwd::chdir ".."; rmdir "a"; +print "#$ENV{PWD}\n"; +Cwd::chdir ".."; rmdir "to"; +print "#$ENV{PWD}\n"; +Cwd::chdir ".."; rmdir "path"; +print "#$ENV{PWD}\n"; +Cwd::chdir ".."; rmdir "pteerslt"; +print "#$ENV{PWD}\n"; +if ($^O eq 'VMS') { + # This checked out OK on ODS-2 and ODS-5: + print +($ENV{PWD} =~ m|\bT\]$| ? "" : "not "), "ok 12\n"; +} +else { + print +($ENV{PWD} =~ m|\bt$| ? "" : "not "), "ok 12\n"; +} + +if ($Config{d_symlink}) { + mkdir "pteerslt", 0777; + mkdir "pteerslt/path", 0777; + mkdir "pteerslt/path/to", 0777; + mkdir "pteerslt/path/to/a", 0777; + mkdir "pteerslt/path/to/a/dir", 0777; + symlink "pteerslt/path/to/a/dir" => "linktest"; + + my $abs_path = Cwd::abs_path("linktest"); + my $fast_abs_path = Cwd::fast_abs_path("linktest"); + my $want = "t/pteerslt/path/to/a/dir"; + + print "# abs_path $abs_path\n"; + print "# fast_abs_path $fast_abs_path\n"; + print "# want $want\n"; + print +($abs_path =~ m|$want$| ? "" : "not "), "ok 13\n"; + print +($fast_abs_path =~ m|$want$| ? "" : "not "), "ok 14\n"; + + rmdir "pteerslt/path/to/a/dir"; + rmdir "pteerslt/path/to/a"; + rmdir "pteerslt/path/to"; + rmdir "pteerslt/path"; + rmdir "pteerslt"; + unlink "linktest"; +} else { + print "ok 13 # skipped\n"; + print "ok 14 # skipped\n"; +} diff --cc t/lib/db-btree.t index 1822823,0000000..4b4a796 mode 100755,000000..100755 --- a/t/lib/db-btree.t +++ b/t/lib/db-btree.t @@@ -1,1296 -1,0 +1,1296 @@@ +#!./perl -w + +BEGIN { + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bDB_File\b/) { + print "1..0 # Skip: DB_File was not built\n"; + exit 0; + } +} + +use warnings; +use strict; +use DB_File; +use Fcntl; + +print "1..157\n"; + +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; +} + +sub lexical +{ + my(@a) = unpack ("C*", $a) ; + my(@b) = unpack ("C*", $b) ; + + my $len = (@a > @b ? @b : @a) ; + my $i = 0 ; + + foreach $i ( 0 .. $len -1) { + return $a[$i] - $b[$i] if $a[$i] != $b[$i] ; + } + + return @a - @b ; +} + +{ + package Redirect ; + use Symbol ; + + sub new + { + my $class = shift ; + my $filename = shift ; + my $fh = gensym ; + open ($fh, ">$filename") || die "Cannot open $filename: $!" ; + my $real_stdout = select($fh) ; + return bless [$fh, $real_stdout ] ; + + } + sub DESTROY + { + my $self = shift ; + close $self->[0] ; + select($self->[1]) ; + } +} + +sub docat +{ + my $file = shift; + #local $/ = undef unless wantarray ; + open(CAT,$file) || die "Cannot open $file: $!"; + my @result = ; + 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 = ; + close(CAT); + unlink $file ; + wantarray ? @result : join("", @result) ; +} + + +my $db185mode = ($DB_File::db_version == 1 && ! $DB_File::db_185_compat) ; +my $null_keys_allowed = ($DB_File::db_ver < 2.004010 + || $DB_File::db_ver >= 3.1 ); + +my $Dfile = "dbbtree.tmp"; +unlink $Dfile; + +umask(0); + +# Check the interface to BTREEINFO + +my $dbh = new DB_File::BTREEINFO ; +ok(1, ! defined $dbh->{flags}) ; +ok(2, ! defined $dbh->{cachesize}) ; +ok(3, ! defined $dbh->{psize}) ; +ok(4, ! defined $dbh->{lorder}) ; +ok(5, ! defined $dbh->{minkeypage}) ; +ok(6, ! defined $dbh->{maxkeypage}) ; +ok(7, ! defined $dbh->{compare}) ; +ok(8, ! defined $dbh->{prefix}) ; + +$dbh->{flags} = 3000 ; +ok(9, $dbh->{flags} == 3000) ; + +$dbh->{cachesize} = 9000 ; +ok(10, $dbh->{cachesize} == 9000); + +$dbh->{psize} = 400 ; +ok(11, $dbh->{psize} == 400) ; + +$dbh->{lorder} = 65 ; +ok(12, $dbh->{lorder} == 65) ; + +$dbh->{minkeypage} = 123 ; +ok(13, $dbh->{minkeypage} == 123) ; + +$dbh->{maxkeypage} = 1234 ; +ok(14, $dbh->{maxkeypage} == 1234 ); + +$dbh->{compare} = 1234 ; +ok(15, $dbh->{compare} == 1234) ; + +$dbh->{prefix} = 1234 ; +ok(16, $dbh->{prefix} == 1234 ); + +# Check that an invalid entry is caught both for store & fetch +eval '$dbh->{fred} = 1234' ; +ok(17, $@ =~ /^DB_File::BTREEINFO::STORE - Unknown element 'fred' at/ ) ; +eval 'my $q = $dbh->{fred}' ; +ok(18, $@ =~ /^DB_File::BTREEINFO::FETCH - Unknown element 'fred' at/ ) ; + +# Now check the interface to BTREE + +my ($X, %h) ; +ok(19, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ; + +my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); - ok(20, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32'); ++ok(20, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32' || $^O eq 'NetWare'); + +my ($key, $value, $i); +while (($key,$value) = each(%h)) { + $i++; +} +ok(21, !$i ) ; + +$h{'goner1'} = 'snork'; + +$h{'abc'} = 'ABC'; +ok(22, $h{'abc'} eq 'ABC' ); +ok(23, ! defined $h{'jimmy'} ) ; +ok(24, ! exists $h{'jimmy'} ) ; +ok(25, defined $h{'abc'} ) ; + +$h{'def'} = 'DEF'; +$h{'jkl','mno'} = "JKL\034MNO"; +$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); +$h{'a'} = 'A'; + +#$h{'b'} = 'B'; +$X->STORE('b', 'B') ; + +$h{'c'} = 'C'; + +#$h{'d'} = 'D'; +$X->put('d', 'D') ; + +$h{'e'} = 'E'; +$h{'f'} = 'F'; +$h{'g'} = 'X'; +$h{'h'} = 'H'; +$h{'i'} = 'I'; + +$h{'goner2'} = 'snork'; +delete $h{'goner2'}; + + +# IMPORTANT - $X must be undefined before the untie otherwise the +# underlying DB close routine will not get called. +undef $X ; +untie(%h); + +# tie to the same file again +ok(26, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE)) ; + +# Modify an entry from the previous tie +$h{'g'} = 'G'; + +$h{'j'} = 'J'; +$h{'k'} = 'K'; +$h{'l'} = 'L'; +$h{'m'} = 'M'; +$h{'n'} = 'N'; +$h{'o'} = 'O'; +$h{'p'} = 'P'; +$h{'q'} = 'Q'; +$h{'r'} = 'R'; +$h{'s'} = 'S'; +$h{'t'} = 'T'; +$h{'u'} = 'U'; +$h{'v'} = 'V'; +$h{'w'} = 'W'; +$h{'x'} = 'X'; +$h{'y'} = 'Y'; +$h{'z'} = 'Z'; + +$h{'goner3'} = 'snork'; + +delete $h{'goner1'}; +$X->DELETE('goner3'); + +my @keys = keys(%h); +my @values = values(%h); + +ok(27, $#keys == 29 && $#values == 29) ; + +$i = 0 ; +while (($key,$value) = each(%h)) { + if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { + $key =~ y/a-z/A-Z/; + $i++ if $key eq $value; + } +} + +ok(28, $i == 30) ; + +@keys = ('blurfl', keys(%h), 'dyick'); +ok(29, $#keys == 31) ; + +#Check that the keys can be retrieved in order +my @b = keys %h ; +my @c = sort lexical @b ; +ok(30, ArrayCompare(\@b, \@c)) ; + +$h{'foo'} = ''; +ok(31, $h{'foo'} eq '' ) ; + +# Berkeley DB from version 2.4.10 to 3.0 does not allow null keys. +# This feature was reenabled in version 3.1 of Berkeley DB. +my $result = 0 ; +if ($null_keys_allowed) { + $h{''} = 'bar'; + $result = ( $h{''} eq 'bar' ); +} +else + { $result = 1 } +ok(32, $result) ; + +# check cache overflow and numeric keys and contents +my $ok = 1; +for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } +for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } +ok(33, $ok); + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); +ok(34, $size > 0 ); + +@h{0..200} = 200..400; +my @foo = @h{0..200}; +ok(35, join(':',200..400) eq join(':',@foo) ); + +# Now check all the non-tie specific stuff + + +# Check R_NOOVERWRITE flag will make put fail when attempting to overwrite +# an existing record. + +my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; +ok(36, $status == 1 ); + +# check that the value of the key 'x' has not been changed by the +# previous test +ok(37, $h{'x'} eq 'X' ); + +# standard put +$status = $X->put('key', 'value') ; +ok(38, $status == 0 ); + +#check that previous put can be retrieved +$value = 0 ; +$status = $X->get('key', $value) ; +ok(39, $status == 0 ); +ok(40, $value eq 'value' ); + +# Attempting to delete an existing key should work + +$status = $X->del('q') ; +ok(41, $status == 0 ); +if ($null_keys_allowed) { + $status = $X->del('') ; +} else { + $status = 0 ; +} +ok(42, $status == 0 ); + +# Make sure that the key deleted, cannot be retrieved +ok(43, ! defined $h{'q'}) ; +ok(44, ! defined $h{''}) ; + +undef $X ; +untie %h ; + +ok(45, $X = tie(%h, 'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE )); + +# Attempting to delete a non-existant key should fail + +$status = $X->del('joe') ; +ok(46, $status == 1 ); + +# Check the get interface + +# First a non-existing key +$status = $X->get('aaaa', $value) ; +ok(47, $status == 1 ); + +# Next an existing key +$status = $X->get('a', $value) ; +ok(48, $status == 0 ); +ok(49, $value eq 'A' ); + +# seq +# ### + +# use seq to find an approximate match +$key = 'ke' ; +$value = '' ; +$status = $X->seq($key, $value, R_CURSOR) ; +ok(50, $status == 0 ); +ok(51, $key eq 'key' ); +ok(52, $value eq 'value' ); + +# seq when the key does not match +$key = 'zzz' ; +$value = '' ; +$status = $X->seq($key, $value, R_CURSOR) ; +ok(53, $status == 1 ); + + +# use seq to set the cursor, then delete the record @ the cursor. + +$key = 'x' ; +$value = '' ; +$status = $X->seq($key, $value, R_CURSOR) ; +ok(54, $status == 0 ); +ok(55, $key eq 'x' ); +ok(56, $value eq 'X' ); +$status = $X->del(0, R_CURSOR) ; +ok(57, $status == 0 ); +$status = $X->get('x', $value) ; +ok(58, $status == 1 ); + +# ditto, but use put to replace the key/value pair. +$key = 'y' ; +$value = '' ; +$status = $X->seq($key, $value, R_CURSOR) ; +ok(59, $status == 0 ); +ok(60, $key eq 'y' ); +ok(61, $value eq 'Y' ); + +$key = "replace key" ; +$value = "replace value" ; +$status = $X->put($key, $value, R_CURSOR) ; +ok(62, $status == 0 ); +ok(63, $key eq 'replace key' ); +ok(64, $value eq 'replace value' ); +$status = $X->get('y', $value) ; +ok(65, 1) ; # hard-wire to always pass. the previous test ($status == 1) + # only worked because of a bug in 1.85/6 + +# use seq to walk forwards through a file + +$status = $X->seq($key, $value, R_FIRST) ; +ok(66, $status == 0 ); +my $previous = $key ; + +$ok = 1 ; +while (($status = $X->seq($key, $value, R_NEXT)) == 0) +{ + ($ok = 0), last if ($previous cmp $key) == 1 ; +} + +ok(67, $status == 1 ); +ok(68, $ok == 1 ); + +# use seq to walk backwards through a file +$status = $X->seq($key, $value, R_LAST) ; +ok(69, $status == 0 ); +$previous = $key ; + +$ok = 1 ; +while (($status = $X->seq($key, $value, R_PREV)) == 0) +{ + ($ok = 0), last if ($previous cmp $key) == -1 ; + #print "key = [$key] value = [$value]\n" ; +} + +ok(70, $status == 1 ); +ok(71, $ok == 1 ); + + +# check seq FIRST/LAST + +# sync +# #### + +$status = $X->sync ; +ok(72, $status == 0 ); + + +# fd +# ## + +$status = $X->fd ; +ok(73, $status != 0 ); + + +undef $X ; +untie %h ; + +unlink $Dfile; + +# Now try an in memory file +my $Y; +ok(74, $Y = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_BTREE )); + +# fd with an in memory file should return failure +$status = $Y->fd ; +ok(75, $status == -1 ); + + +undef $Y ; +untie %h ; + +# Duplicate keys +my $bt = new DB_File::BTREEINFO ; +$bt->{flags} = R_DUP ; +my ($YY, %hh); +ok(76, $YY = tie(%hh, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $bt )) ; + +$hh{'Wall'} = 'Larry' ; +$hh{'Wall'} = 'Stone' ; # Note the duplicate key +$hh{'Wall'} = 'Brick' ; # Note the duplicate key +$hh{'Wall'} = 'Brick' ; # Note the duplicate key and value +$hh{'Smith'} = 'John' ; +$hh{'mouse'} = 'mickey' ; + +# first work in scalar context +ok(77, scalar $YY->get_dup('Unknown') == 0 ); +ok(78, scalar $YY->get_dup('Smith') == 1 ); +ok(79, scalar $YY->get_dup('Wall') == 4 ); + +# now in list context +my @unknown = $YY->get_dup('Unknown') ; +ok(80, "@unknown" eq "" ); + +my @smith = $YY->get_dup('Smith') ; +ok(81, "@smith" eq "John" ); + +{ +my @wall = $YY->get_dup('Wall') ; +my %wall ; +@wall{@wall} = @wall ; +ok(82, (@wall == 4 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) ); +} + +# hash +my %unknown = $YY->get_dup('Unknown', 1) ; +ok(83, keys %unknown == 0 ); + +my %smith = $YY->get_dup('Smith', 1) ; +ok(84, keys %smith == 1 && $smith{'John'}) ; + +my %wall = $YY->get_dup('Wall', 1) ; +ok(85, keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1 + && $wall{'Brick'} == 2); + +undef $YY ; +untie %hh ; +unlink $Dfile; + + +# test multiple callbacks +my $Dfile1 = "btree1" ; +my $Dfile2 = "btree2" ; +my $Dfile3 = "btree3" ; + +my $dbh1 = new DB_File::BTREEINFO ; +$dbh1->{compare} = sub { + no warnings 'numeric' ; + $_[0] <=> $_[1] } ; + +my $dbh2 = new DB_File::BTREEINFO ; +$dbh2->{compare} = sub { $_[0] cmp $_[1] } ; + +my $dbh3 = new DB_File::BTREEINFO ; +$dbh3->{compare} = sub { length $_[0] <=> length $_[1] } ; + + +my (%g, %k); +tie(%h, 'DB_File',$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) ; +tie(%g, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ; +tie(%k, 'DB_File',$Dfile3, O_RDWR|O_CREAT, 0640, $dbh3 ) ; + +my @Keys = qw( 0123 12 -1234 9 987654321 def ) ; +my (@srt_1, @srt_2, @srt_3); +{ + no warnings 'numeric' ; + @srt_1 = sort { $a <=> $b } @Keys ; +} +@srt_2 = sort { $a cmp $b } @Keys ; +@srt_3 = sort { length $a <=> length $b } @Keys ; + +foreach (@Keys) { + $h{$_} = 1 ; + $g{$_} = 1 ; + $k{$_} = 1 ; +} + +sub ArrayCompare +{ + my($a, $b) = @_ ; + + return 0 if @$a != @$b ; + + foreach (1 .. length @$a) + { + return 0 unless $$a[$_] eq $$b[$_] ; + } + + 1 ; +} + +ok(86, ArrayCompare (\@srt_1, [keys %h]) ); +ok(87, ArrayCompare (\@srt_2, [keys %g]) ); +ok(88, ArrayCompare (\@srt_3, [keys %k]) ); + +untie %h ; +untie %g ; +untie %k ; +unlink $Dfile1, $Dfile2, $Dfile3 ; + +# clear +# ##### + +ok(89, tie(%h, 'DB_File', $Dfile1, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); +foreach (1 .. 10) + { $h{$_} = $_ * 100 } + +# check that there are 10 elements in the hash +$i = 0 ; +while (($key,$value) = each(%h)) { + $i++; +} +ok(90, $i == 10); + +# now clear the hash +%h = () ; + +# check it is empty +$i = 0 ; +while (($key,$value) = each(%h)) { + $i++; +} +ok(91, $i == 0); + +untie %h ; +unlink $Dfile1 ; + +{ + # check that attempting to tie an array to a DB_BTREE will fail + + my $filename = "xyz" ; + my @x ; + eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE ; } ; + ok(92, $@ =~ /^DB_File can only tie an associative array to a DB_BTREE database/) ; + unlink $filename ; +} + +{ + # sub-class test + + package Another ; + + use warnings ; + use strict ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use warnings ; + use strict ; + use vars qw( @ISA @EXPORT) ; + + require Exporter ; + use DB_File; + @ISA=qw(DB_File); + @EXPORT = @DB_File::EXPORT ; + + sub STORE { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::STORE($key, $value * 2) ; + } + + sub FETCH { + my $self = shift ; + my $key = shift ; + $self->SUPER::FETCH($key) - 1 ; + } + + sub put { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::put($key, $value * 3) ; + } + + sub get { + my $self = shift ; + $self->SUPER::get($_[0], $_[1]) ; + $_[1] -= 2 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; +EOM + + close FILE ; + + BEGIN { push @INC, '.'; } + eval 'use SubDB ; '; + main::ok(93, $@ eq "") ; + my %h ; + my $X ; + eval ' + $X = tie(%h, "SubDB","dbbtree.tmp", O_RDWR|O_CREAT, 0640, $DB_BTREE ); + ' ; + + main::ok(94, $@ eq "") ; + + my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; + main::ok(95, $@ eq "") ; + main::ok(96, $ret == 5) ; + + my $value = 0; + $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ; + main::ok(97, $@ eq "") ; + main::ok(98, $ret == 10) ; + + $ret = eval ' R_NEXT eq main::R_NEXT ' ; + main::ok(99, $@ eq "" ) ; + main::ok(100, $ret == 1) ; + + $ret = eval '$X->A_new_method("joe") ' ; + main::ok(101, $@ eq "") ; + main::ok(102, $ret eq "[[11]]") ; + + undef $X; + untie(%h); + unlink "SubDB.pm", "dbbtree.tmp" ; + +} + +{ + # DBM Filter tests + use warnings ; + use strict ; + my (%h, $db) ; + my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + unlink $Dfile; + + sub checkOutput + { + my($fk, $sk, $fv, $sv) = @_ ; + return + $fetch_key eq $fk && $store_key eq $sk && + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; + } + + ok(103, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); + + $db->filter_fetch_key (sub { $fetch_key = $_ }) ; + $db->filter_store_key (sub { $store_key = $_ }) ; + $db->filter_fetch_value (sub { $fetch_value = $_}) ; + $db->filter_store_value (sub { $store_value = $_ }) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + # fk sk fv sv + ok(104, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(105, $h{"fred"} eq "joe"); + # fk sk fv sv + ok(106, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(107, $db->FIRSTKEY() eq "fred") ; + # fk sk fv sv + ok(108, checkOutput( "fred", "", "", "")) ; + + # replace the filters, but remember the previous set + my ($old_fk) = $db->filter_fetch_key + (sub { $_ = uc $_ ; $fetch_key = $_ }) ; + my ($old_sk) = $db->filter_store_key + (sub { $_ = lc $_ ; $store_key = $_ }) ; + my ($old_fv) = $db->filter_fetch_value + (sub { $_ = "[$_]"; $fetch_value = $_ }) ; + my ($old_sv) = $db->filter_store_value + (sub { s/o/x/g; $store_value = $_ }) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"Fred"} = "Joe" ; + # fk sk fv sv + ok(109, checkOutput( "", "fred", "", "Jxe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(110, $h{"Fred"} eq "[Jxe]"); + # fk sk fv sv + ok(111, checkOutput( "", "fred", "[Jxe]", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(112, $db->FIRSTKEY() eq "FRED") ; + # fk sk fv sv + ok(113, checkOutput( "FRED", "", "", "")) ; + + # put the original filters back + $db->filter_fetch_key ($old_fk); + $db->filter_store_key ($old_sk); + $db->filter_fetch_value ($old_fv); + $db->filter_store_value ($old_sv); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(114, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(115, $h{"fred"} eq "joe"); + ok(116, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(117, $db->FIRSTKEY() eq "fred") ; + ok(118, checkOutput( "fred", "", "", "")) ; + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(119, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(120, $h{"fred"} eq "joe"); + ok(121, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(122, $db->FIRSTKEY() eq "fred") ; + ok(123, checkOutput( "", "", "", "")) ; + + undef $db ; + untie %h; + unlink $Dfile; +} + +{ + # DBM Filter with a closure + + use warnings ; + use strict ; + my (%h, $db) ; + + unlink $Dfile; + ok(124, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); + + my %result = () ; + + sub Closure + { + my ($name) = @_ ; + my $count = 0 ; + my @kept = () ; + + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } + } + + $db->filter_store_key(Closure("store key")) ; + $db->filter_store_value(Closure("store value")) ; + $db->filter_fetch_key(Closure("fetch key")) ; + $db->filter_fetch_value(Closure("fetch value")) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + ok(125, $result{"store key"} eq "store key - 1: [fred]"); + ok(126, $result{"store value"} eq "store value - 1: [joe]"); + ok(127, ! defined $result{"fetch key"} ); + ok(128, ! defined $result{"fetch value"} ); + ok(129, $_ eq "original") ; + + ok(130, $db->FIRSTKEY() eq "fred") ; + ok(131, $result{"store key"} eq "store key - 1: [fred]"); + ok(132, $result{"store value"} eq "store value - 1: [joe]"); + ok(133, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(134, ! defined $result{"fetch value"} ); + ok(135, $_ eq "original") ; + + $h{"jim"} = "john" ; + ok(136, $result{"store key"} eq "store key - 2: [fred jim]"); + ok(137, $result{"store value"} eq "store value - 2: [joe john]"); + ok(138, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(139, ! defined $result{"fetch value"} ); + ok(140, $_ eq "original") ; + + ok(141, $h{"fred"} eq "joe"); + ok(142, $result{"store key"} eq "store key - 3: [fred jim fred]"); + ok(143, $result{"store value"} eq "store value - 2: [joe john]"); + ok(144, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(145, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(146, $_ eq "original") ; + + undef $db ; + untie %h; + unlink $Dfile; +} + +{ + # DBM Filter recursion detection + use warnings ; + use strict ; + my (%h, $db) ; + unlink $Dfile; + + ok(147, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); + + $db->filter_store_key (sub { $_ = $h{$_} }) ; + + eval '$h{1} = 1234' ; + ok(148, $@ =~ /^recursion detected in filter_store_key at/ ); + + undef $db ; + untie %h; + unlink $Dfile; +} + + +{ + # Examples from the POD + + + my $file = "xyzt" ; + { + my $redirect = new Redirect $file ; + + # BTREE example 1 + ### + + use warnings FATAL => qw(all) ; + use strict ; + use DB_File ; + + my %h ; + + sub Compare + { + my ($key1, $key2) = @_ ; + "\L$key1" cmp "\L$key2" ; + } + + # specify the Perl sub that will do the comparison + $DB_BTREE->{'compare'} = \&Compare ; + + unlink "tree" ; + tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open file 'tree': $!\n" ; + + # Add a key/value pair to the file + $h{'Wall'} = 'Larry' ; + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + $h{'duck'} = 'donald' ; + + # Delete + delete $h{"duck"} ; + + # Cycle through the keys printing them in order. + # Note it is not necessary to sort the keys as + # the btree will have kept them in order automatically. + foreach (keys %h) + { print "$_\n" } + + untie %h ; + + unlink "tree" ; + } + + delete $DB_BTREE->{'compare'} ; + + ok(149, docat_del($file) eq <<'EOM') ; +mouse +Smith +Wall +EOM + + { + my $redirect = new Redirect $file ; + + # BTREE example 2 + ### + + use warnings FATAL => qw(all) ; + use strict ; + use DB_File ; + + use vars qw($filename %h ) ; + + $filename = "tree" ; + unlink $filename ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + # Add some key/value pairs to the file + $h{'Wall'} = 'Larry' ; + $h{'Wall'} = 'Brick' ; # Note the duplicate key + $h{'Wall'} = 'Brick' ; # Note the duplicate key and value + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + + # iterate through the associative array + # and print each key/value pair. + foreach (keys %h) + { print "$_ -> $h{$_}\n" } + + untie %h ; + + unlink $filename ; + } + + ok(150, docat_del($file) eq ($db185mode ? <<'EOM' : <<'EOM') ) ; +Smith -> John +Wall -> Brick +Wall -> Brick +Wall -> Brick +mouse -> mickey +EOM +Smith -> John +Wall -> Larry +Wall -> Larry +Wall -> Larry +mouse -> mickey +EOM + + { + my $redirect = new Redirect $file ; + + # BTREE example 3 + ### + + use warnings FATAL => qw(all) ; + use strict ; + use DB_File ; + + use vars qw($filename $x %h $status $key $value) ; + + $filename = "tree" ; + unlink $filename ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + # Add some key/value pairs to the file + $h{'Wall'} = 'Larry' ; + $h{'Wall'} = 'Brick' ; # Note the duplicate key + $h{'Wall'} = 'Brick' ; # Note the duplicate key and value + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + + # iterate through the btree using seq + # and print each key/value pair. + $key = $value = 0 ; + for ($status = $x->seq($key, $value, R_FIRST) ; + $status == 0 ; + $status = $x->seq($key, $value, R_NEXT) ) + { print "$key -> $value\n" } + + + undef $x ; + untie %h ; + } + + ok(151, docat_del($file) eq ($db185mode == 1 ? <<'EOM' : <<'EOM') ) ; +Smith -> John +Wall -> Brick +Wall -> Brick +Wall -> Larry +mouse -> mickey +EOM +Smith -> John +Wall -> Larry +Wall -> Brick +Wall -> Brick +mouse -> mickey +EOM + + + { + my $redirect = new Redirect $file ; + + # BTREE example 4 + ### + + use warnings FATAL => qw(all) ; + use strict ; + use DB_File ; + + use vars qw($filename $x %h ) ; + + $filename = "tree" ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + my $cnt = $x->get_dup("Wall") ; + print "Wall occurred $cnt times\n" ; + + my %hash = $x->get_dup("Wall", 1) ; + print "Larry is there\n" if $hash{'Larry'} ; + print "There are $hash{'Brick'} Brick Walls\n" ; + + my @list = sort $x->get_dup("Wall") ; + print "Wall => [@list]\n" ; + + @list = $x->get_dup("Smith") ; + print "Smith => [@list]\n" ; + + @list = $x->get_dup("Dog") ; + print "Dog => [@list]\n" ; + + undef $x ; + untie %h ; + } + + ok(152, docat_del($file) eq <<'EOM') ; +Wall occurred 3 times +Larry is there +There are 2 Brick Walls +Wall => [Brick Brick Larry] +Smith => [John] +Dog => [] +EOM + + { + my $redirect = new Redirect $file ; + + # BTREE example 5 + ### + + use warnings FATAL => qw(all) ; + use strict ; + use DB_File ; + + use vars qw($filename $x %h $found) ; + + my $filename = "tree" ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; + print "Larry Wall is $found there\n" ; + + $found = ( $x->find_dup("Wall", "Harry") == 0 ? "" : "not") ; + print "Harry Wall is $found there\n" ; + + undef $x ; + untie %h ; + } + + ok(153, docat_del($file) eq <<'EOM') ; +Larry Wall is there +Harry Wall is not there +EOM + + { + my $redirect = new Redirect $file ; + + # BTREE example 6 + ### + + use warnings FATAL => qw(all) ; + use strict ; + use DB_File ; + + use vars qw($filename $x %h $found) ; + + my $filename = "tree" ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + $x->del_dup("Wall", "Larry") ; + + $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; + print "Larry Wall is $found there\n" ; + + undef $x ; + untie %h ; + + unlink $filename ; + } + + ok(154, docat_del($file) eq <<'EOM') ; +Larry Wall is not there +EOM + + { + my $redirect = new Redirect $file ; + + # BTREE example 7 + ### + + use warnings FATAL => qw(all) ; + use strict ; + use DB_File ; + use Fcntl ; + + use vars qw($filename $x %h $st $key $value) ; + + sub match + { + my $key = shift ; + my $value = 0; + my $orig_key = $key ; + $x->seq($key, $value, R_CURSOR) ; + print "$orig_key\t-> $key\t-> $value\n" ; + } + + $filename = "tree" ; + unlink $filename ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + # Add some key/value pairs to the file + $h{'mouse'} = 'mickey' ; + $h{'Wall'} = 'Larry' ; + $h{'Walls'} = 'Brick' ; + $h{'Smith'} = 'John' ; + + + $key = $value = 0 ; + print "IN ORDER\n" ; + for ($st = $x->seq($key, $value, R_FIRST) ; + $st == 0 ; + $st = $x->seq($key, $value, R_NEXT) ) + + { print "$key -> $value\n" } + + print "\nPARTIAL MATCH\n" ; + + match "Wa" ; + match "A" ; + match "a" ; + + undef $x ; + untie %h ; + + unlink $filename ; + + } + + ok(155, docat_del($file) eq <<'EOM') ; +IN ORDER +Smith -> John +Wall -> Larry +Walls -> Brick +mouse -> mickey + +PARTIAL MATCH +Wa -> Wall -> Larry +A -> Smith -> John +a -> mouse -> mickey +EOM + +} + +#{ +# # R_SETCURSOR +# use strict ; +# my (%h, $db) ; +# unlink $Dfile; +# +# ok(156, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); +# +# $h{abc} = 33 ; +# my $k = "newest" ; +# my $v = 44 ; +# my $status = $db->put($k, $v, R_SETCURSOR) ; +# print "status = [$status]\n" ; +# ok(157, $status == 0) ; +# $status = $db->del($k, R_CURSOR) ; +# print "status = [$status]\n" ; +# ok(158, $status == 0) ; +# $k = "newest" ; +# ok(159, $db->get($k, $v, R_CURSOR)) ; +# +# ok(160, keys %h == 1) ; +# +# undef $db ; +# untie %h; +# unlink $Dfile; +#} + +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE + or die "Can't open file: $!\n" ; + $h{ABC} = undef; + ok(156, $a eq "") ; + untie %h ; + unlink $Dfile; +} + +{ + # test that %hash = () doesn't produce the warning + # Argument "" isn't numeric in entersub + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE + or die "Can't open file: $!\n" ; + %h = (); ; + ok(157, $a eq "") ; + untie %h ; + unlink $Dfile; +} + +exit ; diff --cc t/lib/db-hash.t index effc60b,0000000..6f2ef37 mode 100755,000000..100755 --- a/t/lib/db-hash.t +++ b/t/lib/db-hash.t @@@ -1,743 -1,0 +1,743 @@@ +#!./perl -w + +BEGIN { + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bDB_File\b/) { + print "1..0 # Skip: DB_File was not built\n"; + exit 0; + } +} + +use strict; +use warnings; +use DB_File; +use Fcntl; + +print "1..111\n"; + +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; +} + +{ + package Redirect ; + use Symbol ; + + sub new + { + my $class = shift ; + my $filename = shift ; + my $fh = gensym ; + open ($fh, ">$filename") || die "Cannot open $filename: $!" ; + my $real_stdout = select($fh) ; + return bless [$fh, $real_stdout ] ; + + } + sub DESTROY + { + my $self = shift ; + close $self->[0] ; + select($self->[1]) ; + } +} + +sub docat_del +{ + my $file = shift; + local $/ = undef; + open(CAT,$file) || die "Cannot open $file: $!"; + my $result = ; + close(CAT); + unlink $file ; + return $result; +} + +my $Dfile = "dbhash.tmp"; +my $null_keys_allowed = ($DB_File::db_ver < 2.004010 + || $DB_File::db_ver >= 3.1 ); + +unlink $Dfile; + +umask(0); + +# Check the interface to HASHINFO + +my $dbh = new DB_File::HASHINFO ; + +ok(1, ! defined $dbh->{bsize}) ; +ok(2, ! defined $dbh->{ffactor}) ; +ok(3, ! defined $dbh->{nelem}) ; +ok(4, ! defined $dbh->{cachesize}) ; +ok(5, ! defined $dbh->{hash}) ; +ok(6, ! defined $dbh->{lorder}) ; + +$dbh->{bsize} = 3000 ; +ok(7, $dbh->{bsize} == 3000 ); + +$dbh->{ffactor} = 9000 ; +ok(8, $dbh->{ffactor} == 9000 ); + +$dbh->{nelem} = 400 ; +ok(9, $dbh->{nelem} == 400 ); + +$dbh->{cachesize} = 65 ; +ok(10, $dbh->{cachesize} == 65 ); + +$dbh->{hash} = "abc" ; +ok(11, $dbh->{hash} eq "abc" ); + +$dbh->{lorder} = 1234 ; +ok(12, $dbh->{lorder} == 1234 ); + +# Check that an invalid entry is caught both for store & fetch +eval '$dbh->{fred} = 1234' ; +ok(13, $@ =~ /^DB_File::HASHINFO::STORE - Unknown element 'fred' at/ ); +eval 'my $q = $dbh->{fred}' ; +ok(14, $@ =~ /^DB_File::HASHINFO::FETCH - Unknown element 'fred' at/ ); + + +# Now check the interface to HASH +my ($X, %h); +ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + +my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); - ok(16, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32'); ++ok(16, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32' || $^O eq 'NetWare'); + +my ($key, $value, $i); +while (($key,$value) = each(%h)) { + $i++; +} +ok(17, !$i ); + +$h{'goner1'} = 'snork'; + +$h{'abc'} = 'ABC'; +ok(18, $h{'abc'} eq 'ABC' ); +ok(19, !defined $h{'jimmy'} ); +ok(20, !exists $h{'jimmy'} ); +ok(21, exists $h{'abc'} ); + +$h{'def'} = 'DEF'; +$h{'jkl','mno'} = "JKL\034MNO"; +$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); +$h{'a'} = 'A'; + +#$h{'b'} = 'B'; +$X->STORE('b', 'B') ; + +$h{'c'} = 'C'; + +#$h{'d'} = 'D'; +$X->put('d', 'D') ; + +$h{'e'} = 'E'; +$h{'f'} = 'F'; +$h{'g'} = 'X'; +$h{'h'} = 'H'; +$h{'i'} = 'I'; + +$h{'goner2'} = 'snork'; +delete $h{'goner2'}; + + +# IMPORTANT - $X must be undefined before the untie otherwise the +# underlying DB close routine will not get called. +undef $X ; +untie(%h); + + +# tie to the same file again, do not supply a type - should default to HASH +ok(22, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640) ); + +# Modify an entry from the previous tie +$h{'g'} = 'G'; + +$h{'j'} = 'J'; +$h{'k'} = 'K'; +$h{'l'} = 'L'; +$h{'m'} = 'M'; +$h{'n'} = 'N'; +$h{'o'} = 'O'; +$h{'p'} = 'P'; +$h{'q'} = 'Q'; +$h{'r'} = 'R'; +$h{'s'} = 'S'; +$h{'t'} = 'T'; +$h{'u'} = 'U'; +$h{'v'} = 'V'; +$h{'w'} = 'W'; +$h{'x'} = 'X'; +$h{'y'} = 'Y'; +$h{'z'} = 'Z'; + +$h{'goner3'} = 'snork'; + +delete $h{'goner1'}; +$X->DELETE('goner3'); + +my @keys = keys(%h); +my @values = values(%h); + +ok(23, $#keys == 29 && $#values == 29) ; + +$i = 0 ; +while (($key,$value) = each(%h)) { + if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { + $key =~ y/a-z/A-Z/; + $i++ if $key eq $value; + } +} + +ok(24, $i == 30) ; + +@keys = ('blurfl', keys(%h), 'dyick'); +ok(25, $#keys == 31) ; + +$h{'foo'} = ''; +ok(26, $h{'foo'} eq '' ); + +# Berkeley DB from version 2.4.10 to 3.0 does not allow null keys. +# This feature was reenabled in version 3.1 of Berkeley DB. +my $result = 0 ; +if ($null_keys_allowed) { + $h{''} = 'bar'; + $result = ( $h{''} eq 'bar' ); +} +else + { $result = 1 } +ok(27, $result) ; + +# check cache overflow and numeric keys and contents +my $ok = 1; +for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } +for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } +ok(28, $ok ); + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); +ok(29, $size > 0 ); + +@h{0..200} = 200..400; +my @foo = @h{0..200}; +ok(30, join(':',200..400) eq join(':',@foo) ); + + +# Now check all the non-tie specific stuff + +# Check NOOVERWRITE will make put fail when attempting to overwrite +# an existing record. + +my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; +ok(31, $status == 1 ); + +# check that the value of the key 'x' has not been changed by the +# previous test +ok(32, $h{'x'} eq 'X' ); + +# standard put +$status = $X->put('key', 'value') ; +ok(33, $status == 0 ); + +#check that previous put can be retrieved +$value = 0 ; +$status = $X->get('key', $value) ; +ok(34, $status == 0 ); +ok(35, $value eq 'value' ); + +# Attempting to delete an existing key should work + +$status = $X->del('q') ; +ok(36, $status == 0 ); + +# Make sure that the key deleted, cannot be retrieved +{ + no warnings 'uninitialized' ; + ok(37, $h{'q'} eq undef ); +} + +# Attempting to delete a non-existant key should fail + +$status = $X->del('joe') ; +ok(38, $status == 1 ); + +# Check the get interface + +# First a non-existing key +$status = $X->get('aaaa', $value) ; +ok(39, $status == 1 ); + +# Next an existing key +$status = $X->get('a', $value) ; +ok(40, $status == 0 ); +ok(41, $value eq 'A' ); + +# seq +# ### + +# ditto, but use put to replace the key/value pair. + +# use seq to walk backwards through a file - check that this reversed is + +# check seq FIRST/LAST + +# sync +# #### + +$status = $X->sync ; +ok(42, $status == 0 ); + + +# fd +# ## + +$status = $X->fd ; +ok(43, $status != 0 ); + +undef $X ; +untie %h ; + +unlink $Dfile; + +# clear +# ##### + +ok(44, tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); +foreach (1 .. 10) + { $h{$_} = $_ * 100 } + +# check that there are 10 elements in the hash +$i = 0 ; +while (($key,$value) = each(%h)) { + $i++; +} +ok(45, $i == 10); + +# now clear the hash +%h = () ; + +# check it is empty +$i = 0 ; +while (($key,$value) = each(%h)) { + $i++; +} +ok(46, $i == 0); + +untie %h ; +unlink $Dfile ; + + +# Now try an in memory file +ok(47, $X = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + +# fd with an in memory file should return fail +$status = $X->fd ; +ok(48, $status == -1 ); + +undef $X ; +untie %h ; + +{ + # check ability to override the default hashing + my %x ; + my $filename = "xyz" ; + my $hi = new DB_File::HASHINFO ; + $::count = 0 ; + $hi->{hash} = sub { ++$::count ; length $_[0] } ; + ok(49, tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $hi ) ; + $h{"abc"} = 123 ; + ok(50, $h{"abc"} == 123) ; + untie %x ; + unlink $filename ; + ok(51, $::count >0) ; +} + +{ + # check that attempting to tie an array to a DB_HASH will fail + + my $filename = "xyz" ; + my @x ; + eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_HASH ; } ; + ok(52, $@ =~ /^DB_File can only tie an associative array to a DB_HASH database/) ; + unlink $filename ; +} + +{ + # sub-class test + + package Another ; + + use warnings ; + use strict ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use warnings ; + use strict ; + use vars qw( @ISA @EXPORT) ; + + require Exporter ; + use DB_File; + @ISA=qw(DB_File); + @EXPORT = @DB_File::EXPORT ; + + sub STORE { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::STORE($key, $value * 2) ; + } + + sub FETCH { + my $self = shift ; + my $key = shift ; + $self->SUPER::FETCH($key) - 1 ; + } + + sub put { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::put($key, $value * 3) ; + } + + sub get { + my $self = shift ; + $self->SUPER::get($_[0], $_[1]) ; + $_[1] -= 2 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; +EOM + + close FILE ; + + BEGIN { push @INC, '.'; } + eval 'use SubDB ; '; + main::ok(53, $@ eq "") ; + my %h ; + my $X ; + eval ' + $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640, $DB_HASH ); + ' ; + + main::ok(54, $@ eq "") ; + + my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; + main::ok(55, $@ eq "") ; + main::ok(56, $ret == 5) ; + + my $value = 0; + $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ; + main::ok(57, $@ eq "") ; + main::ok(58, $ret == 10) ; + + $ret = eval ' R_NEXT eq main::R_NEXT ' ; + main::ok(59, $@ eq "" ) ; + main::ok(60, $ret == 1) ; + + $ret = eval '$X->A_new_method("joe") ' ; + main::ok(61, $@ eq "") ; + main::ok(62, $ret eq "[[11]]") ; + + undef $X; + untie(%h); + unlink "SubDB.pm", "dbhash.tmp" ; + +} + +{ + # DBM Filter tests + use warnings ; + use strict ; + my (%h, $db) ; + my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + unlink $Dfile; + + sub checkOutput + { + my($fk, $sk, $fv, $sv) = @_ ; + return + $fetch_key eq $fk && $store_key eq $sk && + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; + } + + ok(63, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + + $db->filter_fetch_key (sub { $fetch_key = $_ }) ; + $db->filter_store_key (sub { $store_key = $_ }) ; + $db->filter_fetch_value (sub { $fetch_value = $_}) ; + $db->filter_store_value (sub { $store_value = $_ }) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + # fk sk fv sv + ok(64, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(65, $h{"fred"} eq "joe"); + # fk sk fv sv + ok(66, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(67, $db->FIRSTKEY() eq "fred") ; + # fk sk fv sv + ok(68, checkOutput( "fred", "", "", "")) ; + + # replace the filters, but remember the previous set + my ($old_fk) = $db->filter_fetch_key + (sub { $_ = uc $_ ; $fetch_key = $_ }) ; + my ($old_sk) = $db->filter_store_key + (sub { $_ = lc $_ ; $store_key = $_ }) ; + my ($old_fv) = $db->filter_fetch_value + (sub { $_ = "[$_]"; $fetch_value = $_ }) ; + my ($old_sv) = $db->filter_store_value + (sub { s/o/x/g; $store_value = $_ }) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"Fred"} = "Joe" ; + # fk sk fv sv + ok(69, checkOutput( "", "fred", "", "Jxe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(70, $h{"Fred"} eq "[Jxe]"); + # fk sk fv sv + ok(71, checkOutput( "", "fred", "[Jxe]", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(72, $db->FIRSTKEY() eq "FRED") ; + # fk sk fv sv + ok(73, checkOutput( "FRED", "", "", "")) ; + + # put the original filters back + $db->filter_fetch_key ($old_fk); + $db->filter_store_key ($old_sk); + $db->filter_fetch_value ($old_fv); + $db->filter_store_value ($old_sv); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(74, checkOutput( "", "fred", "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(75, $h{"fred"} eq "joe"); + ok(76, checkOutput( "", "fred", "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(77, $db->FIRSTKEY() eq "fred") ; + ok(78, checkOutput( "fred", "", "", "")) ; + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h{"fred"} = "joe" ; + ok(79, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(80, $h{"fred"} eq "joe"); + ok(81, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(82, $db->FIRSTKEY() eq "fred") ; + ok(83, checkOutput( "", "", "", "")) ; + + undef $db ; + untie %h; + unlink $Dfile; +} + +{ + # DBM Filter with a closure + + use warnings ; + use strict ; + my (%h, $db) ; + + unlink $Dfile; + ok(84, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + + my %result = () ; + + sub Closure + { + my ($name) = @_ ; + my $count = 0 ; + my @kept = () ; + + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } + } + + $db->filter_store_key(Closure("store key")) ; + $db->filter_store_value(Closure("store value")) ; + $db->filter_fetch_key(Closure("fetch key")) ; + $db->filter_fetch_value(Closure("fetch value")) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + ok(85, $result{"store key"} eq "store key - 1: [fred]"); + ok(86, $result{"store value"} eq "store value - 1: [joe]"); + ok(87, ! defined $result{"fetch key"} ); + ok(88, ! defined $result{"fetch value"} ); + ok(89, $_ eq "original") ; + + ok(90, $db->FIRSTKEY() eq "fred") ; + ok(91, $result{"store key"} eq "store key - 1: [fred]"); + ok(92, $result{"store value"} eq "store value - 1: [joe]"); + ok(93, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(94, ! defined $result{"fetch value"} ); + ok(95, $_ eq "original") ; + + $h{"jim"} = "john" ; + ok(96, $result{"store key"} eq "store key - 2: [fred jim]"); + ok(97, $result{"store value"} eq "store value - 2: [joe john]"); + ok(98, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(99, ! defined $result{"fetch value"} ); + ok(100, $_ eq "original") ; + + ok(101, $h{"fred"} eq "joe"); + ok(102, $result{"store key"} eq "store key - 3: [fred jim fred]"); + ok(103, $result{"store value"} eq "store value - 2: [joe john]"); + ok(104, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(105, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(106, $_ eq "original") ; + + undef $db ; + untie %h; + unlink $Dfile; +} + +{ + # DBM Filter recursion detection + use warnings ; + use strict ; + my (%h, $db) ; + unlink $Dfile; + + ok(107, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); + + $db->filter_store_key (sub { $_ = $h{$_} }) ; + + eval '$h{1} = 1234' ; + ok(108, $@ =~ /^recursion detected in filter_store_key at/ ); + + undef $db ; + untie %h; + unlink $Dfile; +} + + +{ + # Examples from the POD + + my $file = "xyzt" ; + { + my $redirect = new Redirect $file ; + + use warnings FATAL => qw(all); + use strict ; + use DB_File ; + use vars qw( %h $k $v ) ; + + unlink "fruit" ; + tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH + or die "Cannot open file 'fruit': $!\n"; + + # Add a few key/value pairs to the file + $h{"apple"} = "red" ; + $h{"orange"} = "orange" ; + $h{"banana"} = "yellow" ; + $h{"tomato"} = "red" ; + + # Check for existence of a key + print "Banana Exists\n\n" if $h{"banana"} ; + + # Delete a key/value pair. + delete $h{"apple"} ; + + # print the contents of the file + while (($k, $v) = each %h) + { print "$k -> $v\n" } + + untie %h ; + + unlink "fruit" ; + } + + ok(109, docat_del($file) eq <<'EOM') ; +Banana Exists + +orange -> orange +tomato -> red +banana -> yellow +EOM + +} + +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ; + $h{ABC} = undef; + ok(110, $a eq "") ; + untie %h ; + unlink $Dfile; +} + +{ + # test that %hash = () doesn't produce the warning + # Argument "" isn't numeric in entersub + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ; + %h = (); ; + ok(111, $a eq "") ; + untie %h ; + unlink $Dfile; +} + +exit ; diff --cc t/lib/db-recno.t index 4ca547f,0000000..6dd913c mode 100755,000000..100755 --- a/t/lib/db-recno.t +++ b/t/lib/db-recno.t @@@ -1,889 -1,0 +1,889 @@@ +#!./perl -w + +BEGIN { + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bDB_File\b/) { + print "1..0 # Skip: DB_File was not built\n"; + exit 0; + } +} + +use DB_File; +use Fcntl; +use strict ; +use warnings; +use vars qw($dbh $Dfile $bad_ones $FA) ; + +# full tied array support started in Perl 5.004_57 +# Double check to see if it is available. + +{ + sub try::TIEARRAY { bless [], "try" } + sub try::FETCHSIZE { $FA = 1 } + $FA = 0 ; + my @a ; + tie @a, 'try' ; + my $a = @a ; +} + + +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; + + return $result ; +} + +{ + package Redirect ; + use Symbol ; + + sub new + { + my $class = shift ; + my $filename = shift ; + my $fh = gensym ; + open ($fh, ">$filename") || die "Cannot open $filename: $!" ; + my $real_stdout = select($fh) ; + return bless [$fh, $real_stdout ] ; + + } + sub DESTROY + { + my $self = shift ; + close $self->[0] ; + select($self->[1]) ; + } +} + +sub docat +{ + my $file = shift; + local $/ = undef; + open(CAT,$file) || die "Cannot open $file:$!"; + my $result = ; + close(CAT); + return $result; +} + +sub docat_del +{ + my $file = shift; + local $/ = undef; + open(CAT,$file) || die "Cannot open $file: $!"; + my $result = ; + close(CAT); + unlink $file ; + return $result; +} + +sub bad_one +{ + print STDERR <{bval}) ; +ok(2, ! defined $dbh->{cachesize}) ; +ok(3, ! defined $dbh->{psize}) ; +ok(4, ! defined $dbh->{flags}) ; +ok(5, ! defined $dbh->{lorder}) ; +ok(6, ! defined $dbh->{reclen}) ; +ok(7, ! defined $dbh->{bfname}) ; + +$dbh->{bval} = 3000 ; +ok(8, $dbh->{bval} == 3000 ); + +$dbh->{cachesize} = 9000 ; +ok(9, $dbh->{cachesize} == 9000 ); + +$dbh->{psize} = 400 ; +ok(10, $dbh->{psize} == 400 ); + +$dbh->{flags} = 65 ; +ok(11, $dbh->{flags} == 65 ); + +$dbh->{lorder} = 123 ; +ok(12, $dbh->{lorder} == 123 ); + +$dbh->{reclen} = 1234 ; +ok(13, $dbh->{reclen} == 1234 ); + +$dbh->{bfname} = 1234 ; +ok(14, $dbh->{bfname} == 1234 ); + + +# Check that an invalid entry is caught both for store & fetch +eval '$dbh->{fred} = 1234' ; +ok(15, $@ =~ /^DB_File::RECNOINFO::STORE - Unknown element 'fred' at/ ); +eval 'my $q = $dbh->{fred}' ; +ok(16, $@ =~ /^DB_File::RECNOINFO::FETCH - Unknown element 'fred' at/ ); + +# Now check the interface to RECNOINFO + +my $X ; +my @h ; +ok(17, $X = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ; + +ok(18, ((stat($Dfile))[2] & 0777) == ($^O eq 'os2' ? 0666 : 0640) - || $^O eq 'MSWin32' || $^O eq 'amigaos') ; ++ || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'amigaos') ; + +#my $l = @h ; +my $l = $X->length ; +ok(19, ($FA ? @h == 0 : !$l) ); + +my @data = qw( a b c d ever f g h i j k longername m n o p) ; + +$h[0] = shift @data ; +ok(20, $h[0] eq 'a' ); + +my $ i; +foreach (@data) + { $h[++$i] = $_ } + +unshift (@data, 'a') ; + +ok(21, defined $h[1] ); +ok(22, ! defined $h[16] ); +ok(23, $FA ? @h == @data : $X->length == @data ); + + +# Overwrite an entry & check fetch it +$h[3] = 'replaced' ; +$data[3] = 'replaced' ; +ok(24, $h[3] eq 'replaced' ); + +#PUSH +my @push_data = qw(added to the end) ; +($FA ? push(@h, @push_data) : $X->push(@push_data)) ; +push (@data, @push_data) ; +ok(25, $h[++$i] eq 'added' ); +ok(26, $h[++$i] eq 'to' ); +ok(27, $h[++$i] eq 'the' ); +ok(28, $h[++$i] eq 'end' ); + +# POP +my $popped = pop (@data) ; +my $value = ($FA ? pop @h : $X->pop) ; +ok(29, $value eq $popped) ; + +# SHIFT +$value = ($FA ? shift @h : $X->shift) ; +my $shifted = shift @data ; +ok(30, $value eq $shifted ); + +# UNSHIFT + +# empty list +($FA ? unshift @h,() : $X->unshift) ; +ok(31, ($FA ? @h == @data : $X->length == @data )); + +my @new_data = qw(add this to the start of the array) ; +$FA ? unshift (@h, @new_data) : $X->unshift (@new_data) ; +unshift (@data, @new_data) ; +ok(32, $FA ? @h == @data : $X->length == @data ); +ok(33, $h[0] eq "add") ; +ok(34, $h[1] eq "this") ; +ok(35, $h[2] eq "to") ; +ok(36, $h[3] eq "the") ; +ok(37, $h[4] eq "start") ; +ok(38, $h[5] eq "of") ; +ok(39, $h[6] eq "the") ; +ok(40, $h[7] eq "array") ; +ok(41, $h[8] eq $data[8]) ; + +# SPLICE + +# Now both arrays should be identical + +my $ok = 1 ; +my $j = 0 ; +foreach (@data) +{ + $ok = 0, last if $_ ne $h[$j ++] ; +} +ok(42, $ok ); + +# Neagtive subscripts + +# get the last element of the array +ok(43, $h[-1] eq $data[-1] ); +ok(44, $h[-1] eq $h[ ($FA ? @h : $X->length) -1] ); + +# get the first element using a negative subscript +eval '$h[ - ( $FA ? @h : $X->length)] = "abcd"' ; +ok(45, $@ eq "" ); +ok(46, $h[0] eq "abcd" ); + +# now try to read before the start of the array +eval '$h[ - (1 + ($FA ? @h : $X->length))] = 1234' ; +ok(47, $@ =~ '^Modification of non-creatable array value attempted' ); + +# IMPORTANT - $X must be undefined before the untie otherwise the +# underlying DB close routine will not get called. +undef $X ; +untie(@h); + +unlink $Dfile; + + +{ + # Check bval defaults to \n + + my @h = () ; + my $dbh = new DB_File::RECNOINFO ; + ok(48, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; + $h[0] = "abc" ; + $h[1] = "def" ; + $h[3] = "ghi" ; + untie @h ; + my $x = docat($Dfile) ; + unlink $Dfile; + ok(49, $x eq "abc\ndef\n\nghi\n") ; +} + +{ + # Change bval + + my @h = () ; + my $dbh = new DB_File::RECNOINFO ; + $dbh->{bval} = "-" ; + ok(50, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; + $h[0] = "abc" ; + $h[1] = "def" ; + $h[3] = "ghi" ; + untie @h ; + my $x = docat($Dfile) ; + unlink $Dfile; + my $ok = ($x eq "abc-def--ghi-") ; + bad_one() unless $ok ; + ok(51, $ok) ; +} + +{ + # Check R_FIXEDLEN with default bval (space) + + my @h = () ; + my $dbh = new DB_File::RECNOINFO ; + $dbh->{flags} = R_FIXEDLEN ; + $dbh->{reclen} = 5 ; + ok(52, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; + $h[0] = "abc" ; + $h[1] = "def" ; + $h[3] = "ghi" ; + untie @h ; + my $x = docat($Dfile) ; + unlink $Dfile; + my $ok = ($x eq "abc def ghi ") ; + bad_one() unless $ok ; + ok(53, $ok) ; +} + +{ + # Check R_FIXEDLEN with user-defined bval + + my @h = () ; + my $dbh = new DB_File::RECNOINFO ; + $dbh->{flags} = R_FIXEDLEN ; + $dbh->{bval} = "-" ; + $dbh->{reclen} = 5 ; + ok(54, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; + $h[0] = "abc" ; + $h[1] = "def" ; + $h[3] = "ghi" ; + untie @h ; + my $x = docat($Dfile) ; + unlink $Dfile; + my $ok = ($x eq "abc--def-------ghi--") ; + bad_one() unless $ok ; + ok(55, $ok) ; +} + +{ + # check that attempting to tie an associative array to a DB_RECNO will fail + + my $filename = "xyz" ; + my %x ; + eval { tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO ; } ; + ok(56, $@ =~ /^DB_File can only tie an array to a DB_RECNO database/) ; + unlink $filename ; +} + +{ + # sub-class test + + package Another ; + + use warnings ; + use strict ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use warnings ; + use strict ; + use vars qw( @ISA @EXPORT) ; + + require Exporter ; + use DB_File; + @ISA=qw(DB_File); + @EXPORT = @DB_File::EXPORT ; + + sub STORE { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::STORE($key, $value * 2) ; + } + + sub FETCH { + my $self = shift ; + my $key = shift ; + $self->SUPER::FETCH($key) - 1 ; + } + + sub put { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::put($key, $value * 3) ; + } + + sub get { + my $self = shift ; + $self->SUPER::get($_[0], $_[1]) ; + $_[1] -= 2 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; +EOM + + close FILE ; + + BEGIN { push @INC, '.'; } + eval 'use SubDB ; '; + main::ok(57, $@ eq "") ; + my @h ; + my $X ; + eval ' + $X = tie(@h, "SubDB","recno.tmp", O_RDWR|O_CREAT, 0640, $DB_RECNO ); + ' ; + + main::ok(58, $@ eq "") ; + + my $ret = eval '$h[3] = 3 ; return $h[3] ' ; + main::ok(59, $@ eq "") ; + main::ok(60, $ret == 5) ; + + my $value = 0; + $ret = eval '$X->put(1, 4) ; $X->get(1, $value) ; return $value' ; + main::ok(61, $@ eq "") ; + main::ok(62, $ret == 10) ; + + $ret = eval ' R_NEXT eq main::R_NEXT ' ; + main::ok(63, $@ eq "" ) ; + main::ok(64, $ret == 1) ; + + $ret = eval '$X->A_new_method(1) ' ; + main::ok(65, $@ eq "") ; + main::ok(66, $ret eq "[[11]]") ; + + undef $X; + untie(@h); + unlink "SubDB.pm", "recno.tmp" ; + +} + +{ + + # test $# + my $self ; + unlink $Dfile; + ok(67, $self = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ; + $h[0] = "abc" ; + $h[1] = "def" ; + $h[2] = "ghi" ; + $h[3] = "jkl" ; + ok(68, $FA ? $#h == 3 : $self->length() == 4) ; + undef $self ; + untie @h ; + my $x = docat($Dfile) ; + ok(69, $x eq "abc\ndef\nghi\njkl\n") ; + + # $# sets array to same length + ok(70, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; + if ($FA) + { $#h = 3 } + else + { $self->STORESIZE(4) } + ok(71, $FA ? $#h == 3 : $self->length() == 4) ; + undef $self ; + untie @h ; + $x = docat($Dfile) ; + ok(72, $x eq "abc\ndef\nghi\njkl\n") ; + + # $# sets array to bigger + ok(73, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; + if ($FA) + { $#h = 6 } + else + { $self->STORESIZE(7) } + ok(74, $FA ? $#h == 6 : $self->length() == 7) ; + undef $self ; + untie @h ; + $x = docat($Dfile) ; + ok(75, $x eq "abc\ndef\nghi\njkl\n\n\n\n") ; + + # $# sets array smaller + ok(76, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; + if ($FA) + { $#h = 2 } + else + { $self->STORESIZE(3) } + ok(77, $FA ? $#h == 2 : $self->length() == 3) ; + undef $self ; + untie @h ; + $x = docat($Dfile) ; + ok(78, $x eq "abc\ndef\nghi\n") ; + + unlink $Dfile; + + +} + +{ + # DBM Filter tests + use warnings ; + use strict ; + my (@h, $db) ; + my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + unlink $Dfile; + + sub checkOutput + { + my($fk, $sk, $fv, $sv) = @_ ; + return + $fetch_key eq $fk && $store_key eq $sk && + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; + } + + ok(79, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); + + $db->filter_fetch_key (sub { $fetch_key = $_ }) ; + $db->filter_store_key (sub { $store_key = $_ }) ; + $db->filter_fetch_value (sub { $fetch_value = $_}) ; + $db->filter_store_value (sub { $store_value = $_ }) ; + + $_ = "original" ; + + $h[0] = "joe" ; + # fk sk fv sv + ok(80, checkOutput( "", 0, "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(81, $h[0] eq "joe"); + # fk sk fv sv + ok(82, checkOutput( "", 0, "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(83, $db->FIRSTKEY() == 0) ; + # fk sk fv sv + ok(84, checkOutput( 0, "", "", "")) ; + + # replace the filters, but remember the previous set + my ($old_fk) = $db->filter_fetch_key + (sub { ++ $_ ; $fetch_key = $_ }) ; + my ($old_sk) = $db->filter_store_key + (sub { $_ *= 2 ; $store_key = $_ }) ; + my ($old_fv) = $db->filter_fetch_value + (sub { $_ = "[$_]"; $fetch_value = $_ }) ; + my ($old_sv) = $db->filter_store_value + (sub { s/o/x/g; $store_value = $_ }) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h[1] = "Joe" ; + # fk sk fv sv + ok(85, checkOutput( "", 2, "", "Jxe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(86, $h[1] eq "[Jxe]"); + # fk sk fv sv + ok(87, checkOutput( "", 2, "[Jxe]", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(88, $db->FIRSTKEY() == 1) ; + # fk sk fv sv + ok(89, checkOutput( 1, "", "", "")) ; + + # put the original filters back + $db->filter_fetch_key ($old_fk); + $db->filter_store_key ($old_sk); + $db->filter_fetch_value ($old_fv); + $db->filter_store_value ($old_sv); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h[0] = "joe" ; + ok(90, checkOutput( "", 0, "", "joe")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(91, $h[0] eq "joe"); + ok(92, checkOutput( "", 0, "joe", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(93, $db->FIRSTKEY() == 0) ; + ok(94, checkOutput( 0, "", "", "")) ; + + # delete the filters + $db->filter_fetch_key (undef); + $db->filter_store_key (undef); + $db->filter_fetch_value (undef); + $db->filter_store_value (undef); + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + $h[0] = "joe" ; + ok(95, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(96, $h[0] eq "joe"); + ok(97, checkOutput( "", "", "", "")) ; + + ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + ok(98, $db->FIRSTKEY() == 0) ; + ok(99, checkOutput( "", "", "", "")) ; + + undef $db ; + untie @h; + unlink $Dfile; +} + +{ + # DBM Filter with a closure + + use warnings ; + use strict ; + my (@h, $db) ; + + unlink $Dfile; + ok(100, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); + + my %result = () ; + + sub Closure + { + my ($name) = @_ ; + my $count = 0 ; + my @kept = () ; + + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } + } + + $db->filter_store_key(Closure("store key")) ; + $db->filter_store_value(Closure("store value")) ; + $db->filter_fetch_key(Closure("fetch key")) ; + $db->filter_fetch_value(Closure("fetch value")) ; + + $_ = "original" ; + + $h[0] = "joe" ; + ok(101, $result{"store key"} eq "store key - 1: [0]"); + ok(102, $result{"store value"} eq "store value - 1: [joe]"); + ok(103, ! defined $result{"fetch key"} ); + ok(104, ! defined $result{"fetch value"} ); + ok(105, $_ eq "original") ; + + ok(106, $db->FIRSTKEY() == 0 ) ; + ok(107, $result{"store key"} eq "store key - 1: [0]"); + ok(108, $result{"store value"} eq "store value - 1: [joe]"); + ok(109, $result{"fetch key"} eq "fetch key - 1: [0]"); + ok(110, ! defined $result{"fetch value"} ); + ok(111, $_ eq "original") ; + + $h[7] = "john" ; + ok(112, $result{"store key"} eq "store key - 2: [0 7]"); + ok(113, $result{"store value"} eq "store value - 2: [joe john]"); + ok(114, $result{"fetch key"} eq "fetch key - 1: [0]"); + ok(115, ! defined $result{"fetch value"} ); + ok(116, $_ eq "original") ; + + ok(117, $h[0] eq "joe"); + ok(118, $result{"store key"} eq "store key - 3: [0 7 0]"); + ok(119, $result{"store value"} eq "store value - 2: [joe john]"); + ok(120, $result{"fetch key"} eq "fetch key - 1: [0]"); + ok(121, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(122, $_ eq "original") ; + + undef $db ; + untie @h; + unlink $Dfile; +} + +{ + # DBM Filter recursion detection + use warnings ; + use strict ; + my (@h, $db) ; + unlink $Dfile; + + ok(123, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); + + $db->filter_store_key (sub { $_ = $h[0] }) ; + + eval '$h[1] = 1234' ; + ok(124, $@ =~ /^recursion detected in filter_store_key at/ ); + + undef $db ; + untie @h; + unlink $Dfile; +} + + +{ + # Examples from the POD + + my $file = "xyzt" ; + { + my $redirect = new Redirect $file ; + + use warnings FATAL => qw(all); + use strict ; + use DB_File ; + + my $filename = "text" ; + unlink $filename ; + + my @h ; + my $x = tie @h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO + or die "Cannot open file 'text': $!\n" ; + + # Add a few key/value pairs to the file + $h[0] = "orange" ; + $h[1] = "blue" ; + $h[2] = "yellow" ; + + $FA ? push @h, "green", "black" + : $x->push("green", "black") ; + + my $elements = $FA ? scalar @h : $x->length ; + print "The array contains $elements entries\n" ; + + my $last = $FA ? pop @h : $x->pop ; + print "popped $last\n" ; + + $FA ? unshift @h, "white" + : $x->unshift("white") ; + my $first = $FA ? shift @h : $x->shift ; + print "shifted $first\n" ; + + # Check for existence of a key + print "Element 1 Exists with value $h[1]\n" if $h[1] ; + + # use a negative index + print "The last element is $h[-1]\n" ; + print "The 2nd last element is $h[-2]\n" ; + + undef $x ; + untie @h ; + + unlink $filename ; + } + + ok(125, docat_del($file) eq <<'EOM') ; +The array contains 5 entries +popped black +shifted white +Element 1 Exists with value blue +The last element is green +The 2nd last element is yellow +EOM + + my $save_output = "xyzt" ; + { + my $redirect = new Redirect $save_output ; + + use warnings FATAL => qw(all); + use strict ; + use vars qw(@h $H $file $i) ; + use DB_File ; + use Fcntl ; + + $file = "text" ; + + unlink $file ; + + $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0640, $DB_RECNO + or die "Cannot open file $file: $!\n" ; + + # first create a text file to play with + $h[0] = "zero" ; + $h[1] = "one" ; + $h[2] = "two" ; + $h[3] = "three" ; + $h[4] = "four" ; + + + # Print the records in order. + # + # The length method is needed here because evaluating a tied + # array in a scalar context does not return the number of + # elements in the array. + + print "\nORIGINAL\n" ; + foreach $i (0 .. $H->length - 1) { + print "$i: $h[$i]\n" ; + } + + # use the push & pop methods + $a = $H->pop ; + $H->push("last") ; + print "\nThe last record was [$a]\n" ; + + # and the shift & unshift methods + $a = $H->shift ; + $H->unshift("first") ; + print "The first record was [$a]\n" ; + + # Use the API to add a new record after record 2. + $i = 2 ; + $H->put($i, "Newbie", R_IAFTER) ; + + # and a new record before record 1. + $i = 1 ; + $H->put($i, "New One", R_IBEFORE) ; + + # delete record 3 + $H->del(3) ; + + # now print the records in reverse order + print "\nREVERSE\n" ; + for ($i = $H->length - 1 ; $i >= 0 ; -- $i) + { print "$i: $h[$i]\n" } + + # same again, but use the API functions instead + print "\nREVERSE again\n" ; + my ($s, $k, $v) = (0, 0, 0) ; + for ($s = $H->seq($k, $v, R_LAST) ; + $s == 0 ; + $s = $H->seq($k, $v, R_PREV)) + { print "$k: $v\n" } + + undef $H ; + untie @h ; + + unlink $file ; + } + + ok(126, docat_del($save_output) eq <<'EOM') ; + +ORIGINAL +0: zero +1: one +2: two +3: three +4: four + +The last record was [four] +The first record was [zero] + +REVERSE +5: last +4: three +3: Newbie +2: one +1: New One +0: first + +REVERSE again +5: last +4: three +3: Newbie +2: one +1: New One +0: first +EOM + +} + +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my @h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO + or die "Can't open file: $!\n" ; + $h[0] = undef; + ok(127, $a eq "") ; + untie @h ; + unlink $Dfile; +} + +{ + # test that %hash = () doesn't produce the warning + # Argument "" isn't numeric in entersub + use warnings ; + use strict ; + use DB_File ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + unlink $Dfile; + my @h ; + + tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO + or die "Can't open file: $!\n" ; + @h = (); ; + ok(128, $a eq "") ; + untie @h ; + unlink $Dfile; +} + +exit ; diff --cc t/lib/extutils.t index be03cb1,0000000..50a9fe4 mode 100644,000000..100644 --- a/t/lib/extutils.t +++ b/t/lib/extutils.t @@@ -1,473 -1,0 +1,483 @@@ +#!./perl -w + - print "1..26\n"; ++print "1..27\n"; + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use warnings; +use strict; +use ExtUtils::MakeMaker; +use ExtUtils::Constant qw (constant_types C_constant XS_constant autoload); +use Config; +use File::Spec::Functions; +use File::Spec; +# Because were are going to be changing directory before running Makefile.PL +my $perl = File::Spec->rel2abs( $^X ); +# ExtUtils::Constant::C_constant uses $^X inside a comment, and we want to +# compare output to ensure that it is the same. We were probably run as ./perl +# whereas we will run the child with the full path in $perl. So make $^X for +# us the same as our child will see. +$^X = $perl; + +print "# perl=$perl\n"; +my $runperl = "$perl -x \"-I../../lib\""; + +$| = 1; + +my $dir = "ext-$$"; +my @files; + +print "# $dir being created...\n"; +mkdir $dir, 0777 or die "mkdir: $!\n"; + + +END { + use File::Path; + print "# $dir being removed...\n"; + rmtree($dir); +} + +my $package = "ExtTest"; + +# Test the code that generates 1 and 2 letter name comparisons. +my %compass = ( +N => 0, NE => 45, E => 90, SE => 135, S => 180, SW => 225, W => 270, NW => 315 +); + +my $parent_rfc1149 = + 'A Standard for the Transmission of IP Datagrams on Avian Carriers'; + +my @names = ("FIVE", {name=>"OK6", type=>"PV",}, + {name=>"OK7", type=>"PVN", + value=>['"not ok 7\\n\\0ok 7\\n"', 15]}, + {name => "FARTHING", type=>"NV"}, + {name => "NOT_ZERO", type=>"UV", value=>"~(UV)0"}, - {name => "OPEN", type=>"PV", value=>'"/*"', - macro=>["#if 1\n", "#endif\n"]}, ++ {name => "OPEN", type=>"PV", value=>'"/*"', macro=>1}, + {name => "CLOSE", type=>"PV", value=>'"*/"', + macro=>["#if 1\n", "#endif\n"]}, + {name => "ANSWER", default=>["UV", 42]}, "NOTDEF", + {name => "Yes", type=>"YES"}, + {name => "No", type=>"NO"}, + {name => "Undef", type=>"UNDEF"}, +# OK. It wasn't really designed to allow the creation of dual valued constants. +# It was more for INADDR_ANY INADDR_BROADCAST INADDR_LOOPBACK INADDR_NONE + {name=>"RFC1149", type=>"SV", value=>"sv_2mortal(temp_sv)", + pre=>"SV *temp_sv = newSVpv(RFC1149, 0); " + . "(void) SvUPGRADE(temp_sv,SVt_PVIV); SvIOK_on(temp_sv); " + . "SvIVX(temp_sv) = 1149;"}, +); + +push @names, $_ foreach keys %compass; + +my @names_only = map {(ref $_) ? $_->{name} : $_} @names; + +my $types = {}; +my $constant_types = constant_types(); # macro defs +my $C_constant = join "\n", + C_constant ($package, undef, "IV", $types, undef, undef, @names); +my $XS_constant = XS_constant ($package, $types); # XS for ExtTest::constant + +################ Header +my $header = catfile($dir, "test.h"); +push @files, "test.h"; +open FH, ">$header" or die "open >$header: $!\n"; +print FH <<"EOT"; +#define FIVE 5 - #define OK6 "ok 6\n" ++#define OK6 "ok 6\\n" +#define OK7 1 +#define FARTHING 0.25 +#define NOT_ZERO 1 +#define Yes 0 +#define No 1 +#define Undef 1 +#define RFC1149 "$parent_rfc1149" +#undef NOTDEF + +EOT + +while (my ($point, $bearing) = each %compass) { + print FH "#define $point $bearing\n" +} +close FH or die "close $header: $!\n"; + +################ XS +my $xs = catfile($dir, "$package.xs"); +push @files, "$package.xs"; +open FH, ">$xs" or die "open >$xs: $!\n"; + +print FH <<'EOT'; +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +EOT + +print FH "#include \"test.h\"\n\n"; +print FH $constant_types; +print FH $C_constant, "\n"; +print FH "MODULE = $package PACKAGE = $package\n"; +print FH "PROTOTYPES: ENABLE\n"; +print FH $XS_constant; +close FH or die "close $xs: $!\n"; + +################ PM +my $pm = catfile($dir, "$package.pm"); +push @files, "$package.pm"; +open FH, ">$pm" or die "open >$pm: $!\n"; +print FH "package $package;\n"; +print FH "use $];\n"; + +print FH <<'EOT'; + +use strict; +use warnings; +use Carp; + +require Exporter; +require DynaLoader; +use vars qw ($VERSION @ISA @EXPORT_OK); + +$VERSION = '0.01'; +@ISA = qw(Exporter DynaLoader); +@EXPORT_OK = qw( +EOT + +print FH "\t$_\n" foreach (@names_only); +print FH ");\n"; +print FH autoload ($package, $]); +print FH "bootstrap $package \$VERSION;\n1;\n__END__\n"; +close FH or die "close $pm: $!\n"; + +################ test.pl +my $testpl = catfile($dir, "test.pl"); +push @files, "test.pl"; +open FH, ">$testpl" or die "open >$testpl: $!\n"; + +print FH "use strict;\n"; +print FH "use $package qw(@names_only);\n"; +print FH <<'EOT'; + +# IV +my $five = FIVE; +if ($five == 5) { + print "ok 5\n"; +} else { + print "not ok 5 # $five\n"; +} + +# PV +print OK6; + +# PVN containing embedded \0s +$_ = OK7; +s/.*\0//s; +print; + +# NV +my $farthing = FARTHING; +if ($farthing == 0.25) { + print "ok 8\n"; +} else { + print "not ok 8 # $farthing\n"; +} + +# UV +my $not_zero = NOT_ZERO; +if ($not_zero > 0 && $not_zero == ~0) { + print "ok 9\n"; +} else { + print "not ok 9 # \$not_zero=$not_zero ~0=" . (~0) . "\n"; +} + +# Value includes a "*/" in an attempt to bust out of a C comment. +# Also tests custom cpp #if clauses +my $close = CLOSE; +if ($close eq '*/') { + print "ok 10\n"; +} else { + print "not ok 10 # \$close='$close'\n"; +} + +# Default values if macro not defined. +my $answer = ANSWER; +if ($answer == 42) { + print "ok 11\n"; +} else { + print "not ok 11 # What do you get if you multiply six by nine? '$answer'\n"; +} + +# not defined macro +my $notdef = eval { NOTDEF; }; +if (defined $notdef) { + print "not ok 12 # \$notdef='$notdef'\n"; +} elsif ($@ !~ /Your vendor has not defined ExtTest macro NOTDEF/) { + print "not ok 12 # \$@='$@'\n"; +} else { + print "ok 12\n"; +} + +# not a macro +my $notthere = eval { &ExtTest::NOTTHERE; }; +if (defined $notthere) { + print "not ok 13 # \$notthere='$notthere'\n"; +} elsif ($@ !~ /NOTTHERE is not a valid ExtTest macro/) { + chomp $@; + print "not ok 13 # \$@='$@'\n"; +} else { + print "ok 13\n"; +} + +# Truth +my $yes = Yes; +if ($yes) { + print "ok 14\n"; +} else { + print "not ok 14 # $yes='\$yes'\n"; +} + +# Falsehood +my $no = No; +if (defined $no and !$no) { + print "ok 15\n"; +} else { + print "not ok 15 # \$no=" . defined ($no) ? "'$no'\n" : "undef\n"; +} + +# Undef +my $undef = Undef; +unless (defined $undef) { + print "ok 16\n"; +} else { + print "not ok 16 # \$undef='$undef'\n"; +} + + +# invalid macro (chosen to look like a mix up between No and SW) +$notdef = eval { &ExtTest::So }; +if (defined $notdef) { + print "not ok 17 # \$notdef='$notdef'\n"; +} elsif ($@ !~ /^So is not a valid ExtTest macro/) { + print "not ok 17 # \$@='$@'\n"; +} else { + print "ok 17\n"; +} + +# invalid defined macro +$notdef = eval { &ExtTest::EW }; +if (defined $notdef) { + print "not ok 18 # \$notdef='$notdef'\n"; +} elsif ($@ !~ /^EW is not a valid ExtTest macro/) { + print "not ok 18 # \$@='$@'\n"; +} else { + print "ok 18\n"; +} + +my %compass = ( +EOT + +while (my ($point, $bearing) = each %compass) { + print FH "$point => $bearing, " +} + +print FH <<'EOT'; + +); + +my $fail; +while (my ($point, $bearing) = each %compass) { + my $val = eval $point; + if ($@) { + print "# $point: \$@='$@'\n"; + $fail = 1; + } elsif (!defined $bearing) { + print "# $point: \$val=undef\n"; + $fail = 1; + } elsif ($val != $bearing) { + print "# $point: \$val=$val, not $bearing\n"; + $fail = 1; + } +} +if ($fail) { + print "not ok 19\n"; +} else { + print "ok 19\n"; +} + +EOT + +print FH <<"EOT"; +my \$rfc1149 = RFC1149; +if (\$rfc1149 ne "$parent_rfc1149") { + print "not ok 20 # '\$rfc1149' ne '$parent_rfc1149'\n"; +} else { + print "ok 20\n"; +} + +if (\$rfc1149 != 1149) { + printf "not ok 21 # %d != 1149\n", \$rfc1149; +} else { + print "ok 21\n"; +} ++ ++EOT ++ ++print FH <<'EOT'; ++# test macro=>1 ++my $open = OPEN; ++if ($open eq '/*') { ++ print "ok 22\n"; ++} else { ++ print "not ok 22 # \$open='$open'\n"; ++} +EOT +close FH or die "close $testpl: $!\n"; + +################ Makefile.PL +# We really need a Makefile.PL because make test for a no dynamic linking perl +# will run Makefile.PL again as part of the "make perl" target. +my $makefilePL = catfile($dir, "Makefile.PL"); +push @files, "Makefile.PL"; +open FH, ">$makefilePL" or die "open >$makefilePL: $!\n"; +print FH <<"EOT"; +#!$perl -w +use ExtUtils::MakeMaker; +WriteMakefile( + 'NAME' => "$package", + 'VERSION_FROM' => "$package.pm", # finds \$VERSION + (\$] >= 5.005 ? + (#ABSTRACT_FROM => "$package.pm", # XXX add this + AUTHOR => "$0") : ()) + ); +EOT + +close FH or die "close $makefilePL: $!\n"; + +chdir $dir or die $!; push @INC, '../../lib'; +END {chdir ".." or warn $!}; + +my @perlout = `$runperl Makefile.PL`; +if ($?) { + print "not ok 1 # $runperl Makefile.PL failed: $?\n"; + print "# $_" foreach @perlout; + exit($?); +} else { + print "ok 1\n"; +} + + +my $makefile = ($^O eq 'VMS' ? 'descrip' : 'Makefile'); +my $makefile_ext = ($^O eq 'VMS' ? '.mms' : ''); +if (-f "$makefile$makefile_ext") { + print "ok 2\n"; +} else { + print "not ok 2\n"; +} +my $makefile_rename = ($^O eq 'VMS' ? '.mms' : '.old'); +push @files, "$makefile$makefile_rename"; # Renamed by make clean + +my $make = $Config{make}; + +$make = $ENV{MAKE} if exists $ENV{MAKE}; + +my $makeout; + +print "# make = '$make'\n"; +$makeout = `$make`; +if ($?) { + print "not ok 3 # $make failed: $?\n"; + exit($?); +} else { + print "ok 3\n"; +} + +if ($Config{usedl}) { + print "ok 4\n"; +} else { + push @files, "perl$Config{exe_ext}"; + my $makeperl = "$make perl"; + print "# make = '$makeperl'\n"; + $makeout = `$makeperl`; + if ($?) { + print "not ok 4 # $makeperl failed: $?\n"; + exit($?); + } else { + print "ok 4\n"; + } +} + - my $test = 22; ++my $test = 23; +my $maketest = "$make test"; +print "# make = '$maketest'\n"; +$makeout = `$maketest`; + +# echo of running the test script +$makeout =~ s/^\s*PERL_DL_NONLAZY=.+?\n//m; +$makeout =~ s/^MCR.+test.pl\n//mig if $^O eq 'VMS'; + +# GNU make babblings +$makeout =~ s/^\w*?make.+?(?:entering|leaving) directory.+?\n//mig; + +# Hopefully gets most make's babblings +# make -f Makefile.aperl perl +$makeout =~ s/^\w*?make.+\sperl[^A-Za-z0-9]*\n//mig; +# make[1]: `perl' is up to date. +$makeout =~ s/^\w*?make.+perl.+?is up to date.*?\n//mig; + +print $makeout; + +if ($?) { + print "not ok $test # $maketest failed: $?\n"; +} else { + print "ok $test\n"; +} +$test++; + +my $regen = `$runperl $package.xs`; +if ($?) { + print "not ok $test # $runperl $package.xs failed: $?\n"; +} else { + print "ok $test\n"; +} +$test++; + +my $expect = $constant_types . $C_constant . + "\n#### XS Section:\n" . $XS_constant; + +if ($expect eq $regen) { + print "ok $test\n"; +} else { + print "not ok $test\n"; + # open FOO, ">expect"; print FOO $expect; + # open FOO, ">regen"; print FOO $regen; close FOO; +} +$test++; + +my $makeclean = "$make clean"; +print "# make = '$makeclean'\n"; +$makeout = `$makeclean`; +if ($?) { + print "not ok $test # $make failed: $?\n"; +} else { + print "ok $test\n"; +} +$test++; + +foreach (@files) { + unlink $_ or warn "unlink $_: $!"; +} + +my $fail; +opendir DIR, "." or die "opendir '.': $!"; +while (defined (my $entry = readdir DIR)) { + next if $entry =~ /^\.\.?$/; + print "# Extra file '$entry'\n"; + $fail = 1; +} +closedir DIR or warn "closedir '.': $!"; +if ($fail) { + print "not ok $test\n"; +} else { + print "ok $test\n"; +} diff --cc t/lib/filefind.t index 5bd8324,0000000..51e3ed8 mode 100755,000000..100755 --- a/t/lib/filefind.t +++ b/t/lib/filefind.t @@@ -1,721 -1,0 +1,734 @@@ - #!./perl -T ++#!./perl + + - my %Expect; ++my %Expect_File = (); # what we expect for $_ ++my %Expect_Name = (); # what we expect for $File::Find::name/fullname ++my %Expect_Dir = (); # what we expect for $File::Find::dir +my $symlink_exists = eval { symlink("",""); 1 }; +my $warn_msg; - my $cwd; - my $cwd_untainted; ++ + +BEGIN { + chdir 't' if -d 't'; + unshift @INC => '../lib'; + - for (keys %ENV) { # untaint ENV - ($ENV{$_}) = $ENV{$_} =~ /(.*)/; - } - - $SIG{'__WARN__'} = sub { $warn_msg = $_[0]; warn "# Warn: $_[0]"; } ++ $SIG{'__WARN__'} = sub { $warn_msg = $_[0]; warn "# $_[0]"; } +} + - if ( $symlink_exists ) { print "1..193\n"; } - else { print "1..75\n"; } ++if ( $symlink_exists ) { print "1..188\n"; } ++else { print "1..78\n"; } + +use File::Find; - use Cwd; - - # Remove insecure directories from PATH - my @path; - my $sep = ($^O eq 'MSWin32') ? ';' : ':'; - foreach my $dir (split(/$sep/,$ENV{'PATH'})) - { - push(@path,$dir) unless -w $dir; - } - $ENV{'PATH'} = join($sep,@path); ++use File::Spec; + +cleanup(); + - if ($^O eq 'MacOS') { - find({wanted => sub { print "ok 1\n" if $_ eq 'filefind.t'; }, untaint => 1}, ':'); - finddepth({wanted => sub { print "ok 2\n" if $_ eq 'filefind.t'; }, untaint => 1}, ':'); - } else { - find({wanted => sub { print "ok 1\n" if $_ eq 'filefind.t'; }, untaint => 1, - untaint_pattern => qr|^(.+)$|}, '.'); - finddepth({wanted => sub { print "ok 2\n" if $_ eq 'filefind.t'; }, - untaint => 1, untaint_pattern => qr|^(.+)$|}, '.'); - } ++find({wanted => sub { print "ok 1\n" if $_ eq 'filefind.t'; } }, ++ File::Spec->curdir); ++ ++finddepth({wanted => sub { print "ok 2\n" if $_ eq 'filefind.t'; } }, ++ File::Spec->curdir); + +my $case = 2; +my $FastFileTests_OK = 0; + +sub cleanup { - if ($^O eq 'MacOS') { - if (-d ':for_find') { - chdir(':for_find'); - } - if (-d ':fa') { - 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'; - } - } else { - if (-d 'for_find') { - chdir('for_find'); - } - if (-d 'fa') { - 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'; - } ++ if (-d dir_path('for_find')) { ++ chdir(dir_path('for_find')); ++ } ++ if (-d dir_path('fa')) { ++ unlink file_path('fa', 'fa_ord'), ++ file_path('fa', 'fsl'), ++ file_path('fa', 'faa', 'faa_ord'), ++ file_path('fa', 'fab', 'fab_ord'), ++ file_path('fa', 'fab', 'faba', 'faba_ord'), ++ file_path('fb', 'fb_ord'), ++ file_path('fb', 'fba', 'fba_ord'); ++ rmdir dir_path('fa', 'faa'); ++ rmdir dir_path('fa', 'fab', 'faba'); ++ rmdir dir_path('fa', 'fab'); ++ rmdir dir_path('fa'); ++ rmdir dir_path('fb', 'fba'); ++ rmdir dir_path('fb'); ++ chdir File::Spec->updir; ++ rmdir dir_path('for_find'); + } +} + +END { + cleanup(); +} + +sub Check($) { - $case++; - if ($_[0]) { print "ok $case\n"; } - else { print "not ok $case\n"; } ++ $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; } ++ $case++; ++ if ($_[0]) { print "ok $case\n"; } ++ else { print "not ok $case\n $!\n"; exit 0; } +} + +sub touch { - CheckDie( open(my $T,'>',$_[0]) ); ++ CheckDie( open(my $T,'>',$_[0]) ); +} + +sub MkDir($$) { - CheckDie( mkdir($_[0],$_[1]) ); ++ CheckDie( mkdir($_[0],$_[1]) ); +} + - sub wanted { - print "# '$_' => 1\n"; - s#\.$## if ($^O eq 'VMS' && $_ ne '.'); - Check( $Expect{$_} ); - if ( $FastFileTests_OK ) { - delete $Expect{$_} - unless ( $Expect_Dir{$_} && ! -d _ ); - } else { - delete $Expect{$_} - unless ( $Expect_Dir{$_} && ! -d $_ ); - } - $File::Find::prune=1 if $_ eq 'faba'; ++sub wanted_File_Dir { ++ print "# \$File::Find::dir => '$File::Find::dir'\n"; ++ print "# \$_ => '$_'\n"; ++ s#\.$## if ($^O eq 'VMS' && $_ ne '.'); ++ Check( $Expect_File{$_} ); ++ if ( $FastFileTests_OK ) { ++ delete $Expect_File{ $_} ++ unless ( $Expect_Dir{$_} && ! -d _ ); ++ } else { ++ delete $Expect_File{$_} ++ unless ( $Expect_Dir{$_} && ! -d $_ ); ++ } ++} + ++sub wanted_File_Dir_prune { ++ &wanted_File_Dir; ++ $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}); - unless ($^O eq 'MacOS') { - if ( $OK ) { - $OK= exists($Expect{substr($n,0,$i)}) if $i >= 0; ++sub wanted_Name { ++ my $n = $File::Find::name; ++ $n =~ s#\.$## if ($^O eq 'VMS' && $n ne '.'); ++ print "# \$File::Find::name => '$n'\n"; ++ my $i = rindex($n,'/'); ++ my $OK = exists($Expect_Name{$n}); ++ unless ($^O eq 'MacOS') { ++ if ( $OK ) { ++ $OK= exists($Expect_Name{substr($n,0,$i)}) if $i >= 0; ++ } + } - } - Check($OK); - delete $Expect{$n}; ++ Check($OK); ++ delete $Expect_Name{$n}; +} + - sub d_wanted { - print "# '$_' => 1\n"; - s#\.$## if ($^O eq 'VMS' && $_ ne '.'); - my $i = rindex($_,'/'); - my $OK = exists($Expect{$_}); - unless ($^O eq 'MacOS') { - if ( $OK ) { - $OK= exists($Expect{substr($_,0,$i)}) if $i >= 0; ++sub wanted_File { ++ print "# \$_ => '$_'\n"; ++ s#\.$## if ($^O eq 'VMS' && $_ ne '.'); ++ my $i = rindex($_,'/'); ++ my $OK = exists($Expect_File{ $_}); ++ unless ($^O eq 'MacOS') { ++ if ( $OK ) { ++ $OK= exists($Expect_File{ substr($_,0,$i)}) if $i >= 0; ++ } + } - } - Check($OK); - delete $Expect{$_}; ++ Check($OK); ++ delete $Expect_File{ $_}; +} + +sub simple_wanted { - print "# \$File::Find::dir => '$File::Find::dir'\n"; - print "# \$_ => '$_'\n"; ++ print "# \$File::Find::dir => '$File::Find::dir'\n"; ++ print "# \$_ => '$_'\n"; +} + +sub noop_wanted {} + +sub my_preprocess { - @files = @_; - print "# --PREPROCESS--\n"; - print "# \$File::Find::dir => '$File::Find::dir' \n"; - foreach $file (@files) { - print "# $file \n"; - delete $Expect{$File::Find::dir}->{$file}; - } - print "# --END PREPROCESS--\n"; - Check(scalar(keys %{$Expect{$File::Find::dir}}) == 0); - if (scalar(keys %{$Expect{$File::Find::dir}}) == 0) { - delete $Expect{$File::Find::dir} - } - return @files; ++ @files = @_; ++ print "# --preprocess--\n"; ++ print "# \$File::Find::dir => '$File::Find::dir' \n"; ++ foreach $file (@files) { ++ print "# $file \n"; ++ delete $Expect_Dir{ $File::Find::dir }->{$file}; ++ } ++ print "# --end preprocess--\n"; ++ Check(scalar(keys %{$Expect_Dir{ $File::Find::dir }}) == 0); ++ if (scalar(keys %{$Expect_Dir{ $File::Find::dir }}) == 0) { ++ delete $Expect_Dir{ $File::Find::dir } ++ } ++ return @files; +} + +sub my_postprocess { - print "# POSTPROCESS: \$File::Find::dir => '$File::Find::dir' \n"; - delete $Expect{$File::Find::dir}; ++ print "# postprocess: \$File::Find::dir => '$File::Find::dir' \n"; ++ delete $Expect_Dir{ $File::Find::dir}; ++} ++ ++ ++# Use dir_path() to specify a directory path that's expected for ++# $File::Find::dir (%Expect_Dir). Also use it in file operations like ++# chdir, rmdir etc. ++# ++# dir_path() concatenates directory names to form a _relative_ ++# directory path, independant from the platform it's run on, although ++# there are limitations. Don't try to create an absolute path, ++# because that may fail on operating systems that have the concept of ++# volume names (e.g. Mac OS). Be careful when you want to create an ++# updir path like ../fa (Unix) or ::fa: (Mac OS). Plain directory ++# names will work best. As a special case, you can pass it a "." as ++# first argument, to create a directory path like "./fa/dir" on ++# operating systems other than Mac OS (actually, Mac OS will ignore ++# the ".", if it's the first argument). If there's no second argument, ++# this function will return the empty string on Mac OS and the string ++# "./" otherwise. ++ ++sub dir_path { ++ my $first_item = shift @_; ++ ++ if ($first_item eq '.') { ++ if ($^O eq 'MacOS') { ++ return '' unless @_; ++ # ignore first argument; return a relative path ++ # with leading ":" and with trailing ":" ++ return File::Spec->catdir("", @_); ++ } else { # other OS ++ return './' unless @_; ++ my $path = File::Spec->catdir(@_); ++ # add leading "./" ++ $path = "./$path"; ++ return $path; ++ } ++ ++ } else { # $first_item ne '.' ++ return $first_item unless @_; # return plain filename ++ if ($^O eq 'MacOS') { ++ # relative path with leading ":" and with trailing ":" ++ return File::Spec->catdir("", $first_item, @_); ++ } else { # other OS ++ return File::Spec->catdir($first_item, @_); ++ } ++ } ++} ++ ++ ++# Use topdir() to specify a directory path that you want to pass to ++#find/finddepth Basically, topdir() does the same as dir_path() (see ++#above), except that there's no trailing ":" on Mac OS. ++ ++sub topdir { ++ my $path = dir_path(@_); ++ $path =~ s/:$// if ($^O eq 'MacOS'); ++ return $path; ++} ++ ++ ++# Use file_path() to specify a file path that's expected for $_ ++# (%Expect_File). Also suitable for file operations like unlink etc. ++# ++# file_path() concatenates directory names (if any) and a filename to ++# form a _relative_ file path (the last argument is assumed to be a ++# file). It's independant from the platform it's run on, although ++# there are limitations (see the warnings for dir_path() above). As a ++# special case, you can pass it a "." as first argument, to create a ++# file path like "./fa/file" on operating systems other than Mac OS ++# (actually, Mac OS will ignore the ".", if it's the first ++# argument). If there's no second argument, this function will return ++# the empty string on Mac OS and the string "./" otherwise. ++ ++sub file_path { ++ my $first_item = shift @_; ++ ++ if ($first_item eq '.') { ++ if ($^O eq 'MacOS') { ++ return '' unless @_; ++ # ignore first argument; return a relative path ++ # with leading ":", but without trailing ":" ++ return File::Spec->catfile("", @_); ++ } else { # other OS ++ return './' unless @_; ++ my $path = File::Spec->catfile(@_); ++ # add leading "./" ++ $path = "./$path"; ++ return $path; ++ } ++ ++ } else { # $first_item ne '.' ++ return $first_item unless @_; # return plain filename ++ if ($^O eq 'MacOS') { ++ # relative path with leading ":", but without trailing ":" ++ return File::Spec->catfile("", $first_item, @_); ++ } else { # other OS ++ return File::Spec->catfile($first_item, @_); ++ } ++ } +} + + ++# Use file_path_name() to specify a file path that's expected for ++# $File::Find::Name (%Expect_Name). Note: When the no_chdir => 1 ++# option is in effect, $_ is the same as $File::Find::Name. In that ++# case, also use this function to specify a file path that's expected ++# for $_. ++# ++# Basically, file_path_name() does the same as file_path() (see ++# above), except that there's always a leading ":" on Mac OS, even for ++# plain file/directory names. ++ ++sub file_path_name { ++ my $path = file_path(@_); ++ $path = ":$path" if (($^O eq 'MacOS') && ($path !~ /:/)); ++ return $path; ++} ++ ++ ++ ++MkDir( dir_path('for_find'), 0770 ); ++CheckDie(chdir( dir_path('for_find'))); ++MkDir( dir_path('fa'), 0770 ); ++MkDir( dir_path('fb'), 0770 ); ++touch( file_path('fb', 'fb_ord') ); ++MkDir( dir_path('fb', 'fba'), 0770 ); ++touch( file_path('fb', 'fba', 'fba_ord') ); +if ($^O eq 'MacOS') { ++ CheckDie( symlink(':fb',':fa:fsl') ) if $symlink_exists; ++} else { ++ CheckDie( symlink('../fb','fa/fsl') ) if $symlink_exists; ++} ++touch( file_path('fa', 'fa_ord') ); + - MkDir( 'for_find',0770 ); - CheckDie(chdir(for_find)); - - $cwd = cwd(); # save cwd - ( $cwd_untainted ) = $cwd =~ m|^(.+)$|; # untaint it - - MkDir( 'fa',0770 ); - MkDir( 'fb',0770 ); - touch(':fb:fb_ord'); - MkDir( ':fb:fba',0770 ); - touch(':fb:fba:fba_ord'); - CheckDie( symlink(':fb',':fa:fsl') ) if $symlink_exists; - touch(':fa:fa_ord'); - - MkDir( ':fa:faa',0770 ); - touch(':fa:faa:faa_ord'); - MkDir( ':fa:fab',0770 ); - touch(':fa:fab:fab_ord'); - MkDir( ':fa:fab:faba',0770 ); - touch(':fa:fab:faba:faba_ord'); - - %Expect = (':' => 1, 'fsl' => 1, 'fa_ord' => 1, 'fab' => 1, 'fab_ord' => 1, - 'faba' => 1, 'faa' => 1, 'faa_ord' => 1); - delete $Expect{'fsl'} unless $symlink_exists; - %Expect_Dir = (':' => 1, 'fa' => 1, 'faa' => 1, 'fab' => 1, 'faba' => 1, - 'fb' => 1, 'fba' => 1); - delete @Expect_Dir{'fb','fba'} unless $symlink_exists; - File::Find::find( {wanted => \&wanted, untaint => 1},':fa' ); - Check( scalar(keys %Expect) == 0 ); - - print "# check re-entancy\n"; - %Expect = (':' => 1, 'fsl' => 1, 'fa_ord' => 1, 'fab' => 1, 'fab_ord' => 1, - 'faba' => 1, 'faa' => 1, 'faa_ord' => 1); - delete $Expect{'fsl'} unless $symlink_exists; - %Expect_Dir = (':' => 1, 'fa' => 1, 'faa' => 1, 'fab' => 1, 'faba' => 1, - 'fb' => 1, 'fba' => 1); - delete @Expect_Dir{'fb','fba'} unless $symlink_exists; - File::Find::find( {wanted => sub { - wanted(); - File::Find::find( {wanted => sub {} , untaint => 1 },':' ); - }, untaint => 1 }, ':fa' ); - Check( scalar(keys %Expect) == 0 ); - - %Expect=(':fa' => 1, ':fa:fsl' => 1, ':fa:fa_ord' => 1, ':fa:fab' => 1, - ':fa:fab:fab_ord' => 1, ':fa:fab:faba' => 1, - ':fa:fab:faba:faba_ord' => 1, ':fa:faa' => 1, ':fa:faa:faa_ord' => 1); - delete $Expect{':fa:fsl'} unless $symlink_exists; - %Expect_Dir = (':fa' => 1, ':fa:faa' => 1, ':fa:fab' => 1, ':fa:fab:faba' => 1, - ':fb' => 1, ':fb:fba' => 1); - delete @Expect_Dir{':fb',':fb:fba'} unless $symlink_exists; - File::Find::find( {wanted => \&wanted, no_chdir => 1, untaint => 1},':fa' ); - Check( scalar(keys %Expect) == 0 ); - - %Expect=(':' => 1, ':fa' => 1, ':fa:fsl' => 1, ':fa:fa_ord' => 1, ':fa:fab' => 1, - ':fa:fab:fab_ord' => 1, ':fa:fab:faba' => 1, - ':fa:fab:faba:faba_ord' => 1, ':fa:faa' => 1, ':fa:faa:faa_ord' => 1, - ':fb' => 1, ':fb:fba' => 1, ':fb:fba:fba_ord' => 1, ':fb:fb_ord' => 1); - delete $Expect{':fa:fsl'} unless $symlink_exists; - %Expect_Dir = (':' => 1, ':fa' => 1, ':fa:faa' => 1, ':fa:fab' => 1, ':fa:fab:faba' => 1, - ':fb' => 1, ':fb:fba' => 1); - delete @Expect_Dir{':fb',':fb:fba'} unless $symlink_exists; - File::Find::finddepth( {wanted => \&dn_wanted, untaint => 1 },':' ); - Check( scalar(keys %Expect) == 0 ); - - %Expect=(':' => 1, ':fa' => 1, ':fa:fsl' => 1, ':fa:fa_ord' => 1, ':fa:fab' => 1, - ':fa:fab:fab_ord' => 1, ':fa:fab:faba' => 1, - ':fa:fab:faba:faba_ord' => 1, ':fa:faa' => 1, ':fa:faa:faa_ord' => 1, - ':fb' => 1, ':fb:fba' => 1, ':fb:fba:fba_ord' => 1, ':fb:fb_ord' => 1); - delete $Expect{':fa:fsl'} unless $symlink_exists; - %Expect_Dir = (':' => 1, ':fa' => 1, ':fa:faa' => 1, ':fa:fab' => 1, ':fa:fab:faba' => 1, - ':fb' => 1, ':fb:fba' => 1); - delete @Expect_Dir{':fb',':fb:fba'} unless $symlink_exists; - File::Find::finddepth( {wanted => \&d_wanted, no_chdir => 1, untaint => 1 },':' ); - Check( scalar(keys %Expect) == 0 ); - - # untaint, preprocess and postprocess tests below added by Thomas Wegner, 17-05-2001 - - print "# check untainting (no follow)\n"; - # don't untaint at all - undef $@; - eval {File::Find::find( {wanted => \&simple_wanted},':fa' );}; - print "# Died: $@"; - Check( $@ =~ m|Insecure dependency| ); - chdir($cwd_untainted); ++MkDir( dir_path('fa', 'faa'), 0770 ); ++touch( file_path('fa', 'faa', 'faa_ord') ); ++MkDir( dir_path('fa', 'fab'), 0770 ); ++touch( file_path('fa', 'fab', 'fab_ord') ); ++MkDir( dir_path('fa', 'fab', 'faba'), 0770 ); ++touch( file_path('fa', 'fab', 'faba', 'faba_ord') ); + - undef $@; - eval {File::Find::find( {wanted => \&simple_wanted, untaint => 1, - untaint_pattern => qr|^(NO_MATCH)$|},':fa' );}; - print "# Died: $@"; - Check( $@ =~ m|is still tainted| ); - chdir($cwd_untainted); + - print "# check untaint_skip (no follow)\n"; - undef $@; - eval {File::Find::find( {wanted => \&simple_wanted, untaint => 1, untaint_skip => 1, - untaint_pattern => qr|^(NO_MATCH)$|}, ':fa' );}; - print "# Died: $@"; - Check( $@ =~ m|insecure cwd| ); - chdir($cwd_untainted); - - print "# check preprocess\n"; - %Expect=( - ':' => {fa => 1, fb => 1}, - ':fa:' => {faa => 1, fab => 1, fa_ord => 1}, - ':fa:faa:' => {faa_ord => 1}, - ':fa:fab:' => {faba => 1, fab_ord => 1}, - ':fa:fab:faba:' => {faba_ord => 1}, - ':fb:' => {fba => 1, fb_ord => 1}, - ':fb:fba:' => {fba_ord => 1} - ); - File::Find::find( {wanted => \&noop_wanted, untaint => 1, preprocess => \&my_preprocess}, ':' ); - Check( scalar(keys %Expect) == 0 ); - - print "# check postprocess\n"; - %Expect=(':' => 1, ':fa:' => 1, ':fa:faa:' => 1, ':fa:fab:' => 1, ':fa:fab:faba:' => 1, ':fb:' => 1, - ':fb:fba:' => 1 ); - File::Find::find( {wanted => \&noop_wanted, untaint => 1, postprocess => \&my_postprocess}, ':' ); - Check( scalar(keys %Expect) == 0 ); ++%Expect_File = (File::Spec->curdir => 1, file_path('fsl') => 1, ++ file_path('fa_ord') => 1, file_path('fab') => 1, ++ file_path('fab_ord') => 1, file_path('faba') => 1, ++ file_path('faa') => 1, file_path('faa_ord') => 1); ++ ++delete $Expect_File{ file_path('fsl') } unless $symlink_exists; ++%Expect_Name = (); ++ ++%Expect_Dir = ( dir_path('fa') => 1, dir_path('faa') => 1, ++ dir_path('fab') => 1, dir_path('faba') => 1, ++ dir_path('fb') => 1, dir_path('fba') => 1); ++ ++delete @Expect_Dir{ dir_path('fb'), dir_path('fba') } unless $symlink_exists; ++File::Find::find( {wanted => \&wanted_File_Dir_prune}, topdir('fa') ); ++Check( scalar(keys %Expect_File) == 0 ); ++ ++ ++print "# check re-entrancy\n"; ++ ++%Expect_File = (File::Spec->curdir => 1, file_path('fsl') => 1, ++ file_path('fa_ord') => 1, file_path('fab') => 1, ++ file_path('fab_ord') => 1, file_path('faba') => 1, ++ file_path('faa') => 1, file_path('faa_ord') => 1); ++ ++delete $Expect_File{ file_path('fsl') } unless $symlink_exists; ++%Expect_Name = (); ++ ++%Expect_Dir = ( dir_path('fa') => 1, dir_path('faa') => 1, ++ dir_path('fab') => 1, dir_path('faba') => 1, ++ dir_path('fb') => 1, dir_path('fba') => 1); ++ ++delete @Expect_Dir{ dir_path('fb'), dir_path('fba') } unless $symlink_exists; ++ ++File::Find::find( {wanted => sub { wanted_File_Dir_prune(); ++ File::Find::find( {wanted => sub ++ {} }, File::Spec->curdir ); } }, ++ topdir('fa') ); ++ ++Check( scalar(keys %Expect_File) == 0 ); ++ ++ ++# no_chdir is in effect, hence we use file_path_name to specify the expected paths for %Expect_File ++ ++%Expect_File = (file_path_name('fa') => 1, ++ file_path_name('fa', 'fsl') => 1, ++ file_path_name('fa', 'fa_ord') => 1, ++ file_path_name('fa', 'fab') => 1, ++ file_path_name('fa', 'fab', 'fab_ord') => 1, ++ file_path_name('fa', 'fab', 'faba') => 1, ++ file_path_name('fa', 'fab', 'faba', 'faba_ord') => 1, ++ file_path_name('fa', 'faa') => 1, ++ file_path_name('fa', 'faa', 'faa_ord') => 1,); ++ ++delete $Expect_File{ file_path_name('fa', 'fsl') } unless $symlink_exists; ++%Expect_Name = (); ++ ++%Expect_Dir = (dir_path('fa') => 1, ++ dir_path('fa', 'faa') => 1, ++ dir_path('fa', 'fab') => 1, ++ dir_path('fa', 'fab', 'faba') => 1, ++ dir_path('fb') => 1, ++ dir_path('fb', 'fba') => 1); ++ ++delete @Expect_Dir{ dir_path('fb'), dir_path('fb', 'fba') } ++ unless $symlink_exists; ++ ++File::Find::find( {wanted => \&wanted_File_Dir, no_chdir => 1}, ++ topdir('fa') ); Check( scalar(keys %Expect_File) == 0 ); ++ ++ ++%Expect_File = (); ++ ++%Expect_Name = (File::Spec->curdir => 1, ++ file_path_name('.', 'fa') => 1, ++ file_path_name('.', 'fa', 'fsl') => 1, ++ file_path_name('.', 'fa', 'fa_ord') => 1, ++ file_path_name('.', 'fa', 'fab') => 1, ++ file_path_name('.', 'fa', 'fab', 'fab_ord') => 1, ++ file_path_name('.', 'fa', 'fab', 'faba') => 1, ++ file_path_name('.', 'fa', 'fab', 'faba', 'faba_ord') => 1, ++ file_path_name('.', 'fa', 'faa') => 1, ++ file_path_name('.', 'fa', 'faa', 'faa_ord') => 1, ++ file_path_name('.', 'fb') => 1, ++ file_path_name('.', 'fb', 'fba') => 1, ++ file_path_name('.', 'fb', 'fba', 'fba_ord') => 1, ++ file_path_name('.', 'fb', 'fb_ord') => 1); ++ ++delete $Expect_Name{ file_path('.', 'fa', 'fsl') } unless $symlink_exists; ++%Expect_Dir = (); ++File::Find::finddepth( {wanted => \&wanted_Name}, File::Spec->curdir ); ++Check( scalar(keys %Expect_Name) == 0 ); ++ ++ ++# no_chdir is in effect, hence we use file_path_name to specify the ++# expected paths for %Expect_File ++ ++%Expect_File = (File::Spec->curdir => 1, ++ file_path_name('.', 'fa') => 1, ++ file_path_name('.', 'fa', 'fsl') => 1, ++ file_path_name('.', 'fa', 'fa_ord') => 1, ++ file_path_name('.', 'fa', 'fab') => 1, ++ file_path_name('.', 'fa', 'fab', 'fab_ord') => 1, ++ file_path_name('.', 'fa', 'fab', 'faba') => 1, ++ file_path_name('.', 'fa', 'fab', 'faba', 'faba_ord') => 1, ++ file_path_name('.', 'fa', 'faa') => 1, ++ file_path_name('.', 'fa', 'faa', 'faa_ord') => 1, ++ file_path_name('.', 'fb') => 1, ++ file_path_name('.', 'fb', 'fba') => 1, ++ file_path_name('.', 'fb', 'fba', 'fba_ord') => 1, ++ file_path_name('.', 'fb', 'fb_ord') => 1); ++ ++delete $Expect_File{ file_path_name('.', 'fa', 'fsl') } unless $symlink_exists; ++%Expect_Name = (); ++%Expect_Dir = (); ++ ++File::Find::finddepth( {wanted => \&wanted_File, no_chdir => 1}, ++ File::Spec->curdir ); ++ ++Check( scalar(keys %Expect_File) == 0 ); ++ ++ ++print "# check preprocess\n"; ++%Expect_File = (); ++%Expect_Name = (); ++%Expect_Dir = ( ++ File::Spec->curdir => {fa => 1, fb => 1}, ++ dir_path('.', 'fa') => {faa => 1, fab => 1, fa_ord => 1}, ++ dir_path('.', 'fa', 'faa') => {faa_ord => 1}, ++ dir_path('.', 'fa', 'fab') => {faba => 1, fab_ord => 1}, ++ dir_path('.', 'fa', 'fab', 'faba') => {faba_ord => 1}, ++ dir_path('.', 'fb') => {fba => 1, fb_ord => 1}, ++ dir_path('.', 'fb', 'fba') => {fba_ord => 1} ++ ); ++ ++File::Find::find( {wanted => \&noop_wanted, ++ preprocess => \&my_preprocess}, File::Spec->curdir ); ++ ++Check( scalar(keys %Expect_Dir) == 0 ); ++ ++ ++print "# check postprocess\n"; ++%Expect_File = (); ++%Expect_Name = (); ++%Expect_Dir = ( ++ File::Spec->curdir => 1, ++ dir_path('.', 'fa') => 1, ++ dir_path('.', 'fa', 'faa') => 1, ++ dir_path('.', 'fa', 'fab') => 1, ++ dir_path('.', 'fa', 'fab', 'faba') => 1, ++ dir_path('.', 'fb') => 1, ++ dir_path('.', 'fb', 'fba') => 1 ++ ); ++ ++File::Find::find( {wanted => \&noop_wanted, ++ postprocess => \&my_postprocess}, File::Spec->curdir ); ++ ++Check( scalar(keys %Expect_Dir) == 0 ); ++ ++ ++if ( $symlink_exists ) { ++ print "# --- symbolic link tests --- \n"; ++ $FastFileTests_OK= 1; ++ + + # Verify that File::Find::find will call wanted even if the topdir of - # is a symlink to a directory, and it shouldn't follow the link - # unless follow is set, which it isn't in this case - %Expect = ('fsl' => 1); ++ # is a symlink to a directory, and it shouldn't follow the link ++ # unless follow is set, which it isn't in this case ++ %Expect_File = ( file_path('fsl') => 1 ); ++ %Expect_Name = (); ++ %Expect_Dir = (); ++ File::Find::find( {wanted => \&wanted_File_Dir}, topdir('fa', 'fsl') ); ++ Check( scalar(keys %Expect_File) == 0 ); ++ ++ ++ %Expect_File = (File::Spec->curdir => 1, file_path('fa_ord') => 1, ++ file_path('fsl') => 1, file_path('fb_ord') => 1, ++ file_path('fba') => 1, file_path('fba_ord') => 1, ++ file_path('fab') => 1, file_path('fab_ord') => 1, ++ file_path('faba') => 1, file_path('faa') => 1, ++ file_path('faa_ord') => 1); ++ ++ %Expect_Name = (); ++ ++ %Expect_Dir = (File::Spec->curdir => 1, dir_path('fa') => 1, ++ dir_path('faa') => 1, dir_path('fab') => 1, ++ dir_path('faba') => 1, dir_path('fb') => 1, ++ dir_path('fba') => 1); ++ ++ File::Find::find( {wanted => \&wanted_File_Dir_prune, ++ follow_fast => 1}, topdir('fa') ); ++ ++ Check( scalar(keys %Expect_File) == 0 ); ++ ++ ++ # no_chdir is in effect, hence we use file_path_name to specify ++ # the expected paths for %Expect_File ++ ++ %Expect_File = (file_path_name('fa') => 1, ++ file_path_name('fa', 'fa_ord') => 1, ++ file_path_name('fa', 'fsl') => 1, ++ file_path_name('fa', 'fsl', 'fb_ord') => 1, ++ file_path_name('fa', 'fsl', 'fba') => 1, ++ file_path_name('fa', 'fsl', 'fba', 'fba_ord') => 1, ++ file_path_name('fa', 'fab') => 1, ++ file_path_name('fa', 'fab', 'fab_ord') => 1, ++ file_path_name('fa', 'fab', 'faba') => 1, ++ file_path_name('fa', 'fab', 'faba', 'faba_ord') => 1, ++ file_path_name('fa', 'faa') => 1, ++ file_path_name('fa', 'faa', 'faa_ord') => 1); ++ ++ %Expect_Name = (); ++ ++ %Expect_Dir = (dir_path('fa') => 1, ++ dir_path('fa', 'faa') => 1, ++ dir_path('fa', 'fab') => 1, ++ dir_path('fa', 'fab', 'faba') => 1, ++ dir_path('fb') => 1, ++ dir_path('fb', 'fba') => 1); ++ ++ File::Find::find( {wanted => \&wanted_File_Dir, follow_fast => 1, ++ no_chdir => 1}, topdir('fa') ); ++ ++ Check( scalar(keys %Expect_File) == 0 ); ++ ++ %Expect_File = (); ++ ++ %Expect_Name = (file_path_name('fa') => 1, ++ file_path_name('fa', 'fa_ord') => 1, ++ file_path_name('fa', 'fsl') => 1, ++ file_path_name('fa', 'fsl', 'fb_ord') => 1, ++ file_path_name('fa', 'fsl', 'fba') => 1, ++ file_path_name('fa', 'fsl', 'fba', 'fba_ord') => 1, ++ file_path_name('fa', 'fab') => 1, ++ file_path_name('fa', 'fab', 'fab_ord') => 1, ++ file_path_name('fa', 'fab', 'faba') => 1, ++ file_path_name('fa', 'fab', 'faba', 'faba_ord') => 1, ++ file_path_name('fa', 'faa') => 1, ++ file_path_name('fa', 'faa', 'faa_ord') => 1); ++ + %Expect_Dir = (); - File::Find::find( {wanted => \&wanted, untaint => 1},':fa:fsl' ); - Check( scalar(keys %Expect) == 0 ); - - if ( $symlink_exists ) { - $FastFileTests_OK= 1; - %Expect=(':' => 1, 'fa_ord' => 1, 'fsl' => 1, 'fb_ord' => 1, 'fba' => 1, - 'fba_ord' => 1, 'fab' => 1, 'fab_ord' => 1, 'faba' => 1, 'faa' => 1, - 'faa_ord' => 1); - %Expect_Dir = (':' => 1, 'fa' => 1, 'faa' => 1, 'fab' => 1, 'faba' => 1, - 'fb' => 1, 'fba' => 1); - File::Find::find( {wanted => \&wanted, follow_fast => 1, untaint => 1},':fa' ); - Check( scalar(keys %Expect) == 0 ); - - %Expect=(':fa' => 1, ':fa:fa_ord' => 1, ':fa:fsl' => 1, ':fa:fsl:fb_ord' => 1, - ':fa:fsl:fba' => 1, ':fa:fsl:fba:fba_ord' => 1, ':fa:fab' => 1, - ':fa:fab:fab_ord' => 1, ':fa:fab:faba' => 1, ':fa:fab:faba:faba_ord' => 1, - ':fa:faa' => 1, ':fa:faa:faa_ord' => 1); - %Expect_Dir = (':fa' => 1, ':fa:faa' => 1, ':fa:fab' => 1, ':fa:fab:faba' => 1, - ':fb' => 1, ':fb:fba' => 1); - File::Find::find( {wanted => \&wanted, follow_fast => 1, no_chdir => 1, untaint => 1 },':fa' ); - Check( scalar(keys %Expect) == 0 ); - - %Expect=(':fa' => 1, ':fa:fa_ord' => 1, ':fa:fsl' => 1, ':fa:fsl:fb_ord' => 1, - ':fa:fsl:fba' => 1, ':fa:fsl:fba:fba_ord' => 1, ':fa:fab' => 1, - ':fa:fab:fab_ord' => 1, ':fa:fab:faba' => 1, ':fa:fab:faba:faba_ord' => 1, - ':fa:faa' => 1, ':fa:faa:faa_ord' => 1); - %Expect_Dir = (':fa' => 1, ':fa:faa' => 1, ':fa:fab' => 1, ':fa:fab:faba' => 1, - ':fb' => 1, ':fb:fba' => 1); - File::Find::finddepth( {wanted => \&dn_wanted, follow_fast => 1, untaint => 1 },':fa' ); - Check( scalar(keys %Expect) == 0 ); - - %Expect=(':fa' => 1, ':fa:fa_ord' => 1, ':fa:fsl' => 1, ':fa:fsl:fb_ord' => 1, - ':fa:fsl:fba' => 1, ':fa:fsl:fba:fba_ord' => 1, ':fa:fab' => 1, - ':fa:fab:fab_ord' => 1, ':fa:fab:faba' => 1, ':fa:fab:faba:faba_ord' => 1, - ':fa:faa' => 1, ':fa:faa:faa_ord' => 1); - %Expect_Dir = (':fa' => 1, ':fa:faa' => 1, ':fa:fab' => 1, ':fa:fab:faba' => 1, - ':fb' => 1, ':fb:fba' => 1); - File::Find::finddepth( {wanted => \&d_wanted, follow_fast => 1, no_chdir => 1, untaint => 1 },':fa' ); - Check( scalar(keys %Expect) == 0 ); - - # tests below added by Thomas Wegner, 17-05-2001 - - print "# check dangling symbolic links\n"; - MkDir( 'dangling_dir',0770 ); - CheckDie( symlink('dangling_dir','dangling_dir_sl') ); - rmdir 'dangling_dir'; - touch('dangling_file'); - CheckDie( symlink('dangling_file',':fa:dangling_file_sl') ); - unlink 'dangling_file'; - - %Expect=(':' => 1, 'fa_ord' => 1, 'fsl' => 1, 'fb_ord' => 1, 'fba' => 1, - 'fba_ord' => 1, 'fab' => 1, 'fab_ord' => 1, 'faba' => 1, 'faba_ord' => 1, - 'faa' => 1, 'faa_ord' => 1); - %Expect_Dir = (':' => 1, 'fa' => 1, 'faa' => 1, 'fab' => 1, 'faba' => 1, - 'fb' => 1, 'fba' => 1); - undef $warn_msg; - File::Find::find( {wanted => \&d_wanted, follow => 1, untaint => 1 }, 'dangling_dir_sl', ':fa' ); - Check( $warn_msg =~ m|dangling_dir_sl is a dangling symbolic link| ); - unlink ':fa:dangling_file_sl', 'dangling_dir_sl'; - - print "# check recursion\n"; - CheckDie( symlink(':fa:faa',':fa:faa:faa_sl') ); - undef $@; - eval {File::Find::find( {wanted => \&simple_wanted, follow => 1, no_chdir => 1, untaint => 1 },':fa' ); }; - print "# Died: $@"; - Check( $@ =~ m|:for_find:fa:faa:faa_sl is a recursive symbolic link| ); - unlink ':fa:faa:faa_sl'; - - print "# check follow_skip (file)\n"; - CheckDie( symlink(':fa:fa_ord',':fa:fa_ord_sl') ); # symlink to a file - undef $@; - eval {File::Find::finddepth( {wanted => \&simple_wanted, follow => 1,follow_skip => 0, - no_chdir => 1, untaint => 1 },':fa' );}; - print "# Died: $@"; - Check( $@ =~ m|:for_find:fa:fa_ord encountered a second time| ); - - %Expect=(':fa' => 1, ':fa:fa_ord' => 1, ':fa:fsl' => 1, ':fa:fsl:fb_ord' => 1, - ':fa:fsl:fba' => 1, ':fa:fsl:fba:fba_ord' => 1, ':fa:fab' => 1, - ':fa:fab:fab_ord' => 1, ':fa:fab:faba' => 1, ':fa:fab:faba:faba_ord' => 1, - ':fa:faa' => 1, ':fa:faa:faa_ord' => 1); - %Expect_Dir = (':fa' => 1, ':fa:faa' => 1, ':fa:fab' => 1, ':fa:fab:faba' => 1, - ':fb' => 1, ':fb:fba' => 1); - File::Find::finddepth( {wanted => \&wanted, follow => 1, follow_skip => 1, no_chdir => 1, - untaint => 1 },':fa' ); - Check( scalar(keys %Expect) == 0 ); - unlink ':fa:fa_ord_sl'; - - print "# check follow_skip (directory)\n"; - CheckDie( symlink(':fa:faa',':fa:faa_sl') ); # symlink to a directory - undef $@; - eval {File::Find::find( {wanted => \&simple_wanted, follow => 1, follow_skip => 0, - no_chdir => 1, untaint => 1 },':fa' );}; - print "# Died: $@"; - Check( $@ =~ m|:for_find:fa:faa: encountered a second time| ); - - undef $@; - eval {File::Find::find( {wanted => \&simple_wanted, follow => 1, follow_skip => 1, - no_chdir => 1, untaint => 1 },':fa' );}; - print "# Died: $@"; - Check( $@ =~ m|:for_find:fa:faa: encountered a second time| ); - - %Expect=(':fa' => 1, ':fa:fa_ord' => 1, ':fa:fsl' => 1, ':fa:fsl:fb_ord' => 1, - ':fa:fsl:fba' => 1, ':fa:fsl:fba:fba_ord' => 1, ':fa:fab' => 1, - ':fa:fab:fab_ord' => 1, ':fa:fab:faba' => 1, ':fa:fab:faba:faba_ord' => 1, - ':fa:faa' => 1, ':fa:faa:faa_ord' => 1); - %Expect_Dir = (':fa' => 1, ':fa:faa' => 1, ':fa:fab' => 1, ':fa:fab:faba' => 1, - ':fb' => 1, ':fb:fba' => 1); - File::Find::find( {wanted => \&wanted, follow => 1, follow_skip => 2, no_chdir => 1, - untaint => 1},':fa' ); - Check( scalar(keys %Expect) == 0 ); - unlink ':fa:faa_sl'; - - print "# check untainting (follow)\n"; - # don't untaint at all - undef $@; - eval {File::Find::find( {wanted => \&simple_wanted, follow => 1},':fa' );}; - print "# Died: $@"; - Check( $@ =~ m|Insecure dependency| ); - chdir($cwd_untainted); - - undef $@; - eval {File::Find::find( {wanted => \&simple_wanted, follow => 1, untaint => 1, - untaint_pattern => qr|^(NO_MATCH)$|},':fa' );}; - print "# Died: $@"; - Check( $@ =~ m|is still tainted| ); - chdir($cwd_untainted); - - print "# check untaint_skip (follow)\n"; - undef $@; - eval {File::Find::find( {wanted => \&simple_wanted, untaint => 1, untaint_skip => 1, - untaint_pattern => qr|^(NO_MATCH)$|}, ':fa' );}; - print "# Died: $@"; - Check( $@ =~ m|insecure cwd| ); - chdir($cwd_untainted); ++ ++ File::Find::finddepth( {wanted => \&wanted_Name, ++ follow_fast => 1}, topdir('fa') ); ++ ++ Check( scalar(keys %Expect_Name) == 0 ); ++ ++ # no_chdir is in effect, hence we use file_path_name to specify ++ # the expected paths for %Expect_File ++ ++ %Expect_File = (file_path_name('fa') => 1, ++ file_path_name('fa', 'fa_ord') => 1, ++ file_path_name('fa', 'fsl') => 1, ++ file_path_name('fa', 'fsl', 'fb_ord') => 1, ++ file_path_name('fa', 'fsl', 'fba') => 1, ++ file_path_name('fa', 'fsl', 'fba', 'fba_ord') => 1, ++ file_path_name('fa', 'fab') => 1, ++ file_path_name('fa', 'fab', 'fab_ord') => 1, ++ file_path_name('fa', 'fab', 'faba') => 1, ++ file_path_name('fa', 'fab', 'faba', 'faba_ord') => 1, ++ file_path_name('fa', 'faa') => 1, ++ file_path_name('fa', 'faa', 'faa_ord') => 1); ++ ++ %Expect_Name = (); ++ %Expect_Dir = (); ++ ++ File::Find::finddepth( {wanted => \&wanted_File, follow_fast => 1, ++ no_chdir => 1}, topdir('fa') ); ++ ++ Check( scalar(keys %Expect_File) == 0 ); ++ ++ ++ print "# check dangling symbolic links\n"; ++ MkDir( dir_path('dangling_dir'), 0770 ); ++ CheckDie( symlink( dir_path('dangling_dir'), ++ file_path('dangling_dir_sl') ) ); ++ rmdir dir_path('dangling_dir'); ++ touch(file_path('dangling_file')); ++ if ($^O eq 'MacOS') { ++ CheckDie( symlink('dangling_file', ':fa:dangling_file_sl') ); ++ } else { ++ CheckDie( symlink('../dangling_file','fa/dangling_file_sl') ); ++ } ++ unlink file_path('dangling_file'); ++ ++ { ++ # these tests should also emit a warning ++ use warnings; ++ ++ %Expect_File = (File::Spec->curdir => 1, ++ file_path('fa_ord') => 1, ++ file_path('fsl') => 1, ++ file_path('fb_ord') => 1, ++ file_path('fba') => 1, ++ file_path('fba_ord') => 1, ++ file_path('fab') => 1, ++ file_path('fab_ord') => 1, ++ file_path('faba') => 1, ++ file_path('faba_ord') => 1, ++ file_path('faa') => 1, ++ file_path('faa_ord') => 1); ++ ++ %Expect_Name = (); ++ %Expect_Dir = (); ++ undef $warn_msg; ++ ++ File::Find::find( {wanted => \&wanted_File, follow => 1, ++ dangling_symlinks => ++ sub { $warn_msg = "$_[0] is a dangling symbolic link" } ++ }, ++ topdir('dangling_dir_sl'), topdir('fa') ); ++ ++ Check( scalar(keys %Expect_File) == 0 ); ++ Check( $warn_msg =~ m|dangling_dir_sl is a dangling symbolic link| ); ++ unlink file_path('fa', 'dangling_file_sl'), ++ file_path('dangling_dir_sl'); + + } + - } else { + - MkDir( 'for_find',0770 ); - CheckDie(chdir(for_find)); - - $cwd = cwd(); # save cwd - ( $cwd_untainted ) = $cwd =~ m|^(.+)$|; # untaint it - - MkDir( 'fa',0770 ); - MkDir( 'fb',0770 ); - touch('fb/fb_ord'); - MkDir( 'fb/fba',0770 ); - touch('fb/fba/fba_ord'); - CheckDie( symlink('../fb','fa/fsl') ) if $symlink_exists; - touch('fa/fa_ord'); - - MkDir( 'fa/faa',0770 ); - touch('fa/faa/faa_ord'); - MkDir( 'fa/fab',0770 ); - touch('fa/fab/fab_ord'); - MkDir( 'fa/fab/faba',0770 ); - touch('fa/fab/faba/faba_ord'); - - %Expect = ('.' => 1, 'fsl' => 1, 'fa_ord' => 1, 'fab' => 1, 'fab_ord' => 1, - 'faba' => 1, 'faa' => 1, 'faa_ord' => 1); - delete $Expect{'fsl'} unless $symlink_exists; - %Expect_Dir = ('fa' => 1, 'faa' => 1, 'fab' => 1, 'faba' => 1, - 'fb' => 1, 'fba' => 1); - delete @Expect_Dir{'fb','fba'} unless $symlink_exists; - File::Find::find( {wanted => \&wanted, untaint => 1, untaint_pattern => qr|^(.+)$|},'fa' ); - Check( scalar(keys %Expect) == 0 ); - - print "# check re-entancy\n"; - %Expect = ('.' => 1, 'fsl' => 1, 'fa_ord' => 1, 'fab' => 1, 'fab_ord' => 1, - 'faba' => 1, 'faa' => 1, 'faa_ord' => 1); - delete $Expect{'fsl'} unless $symlink_exists; - %Expect_Dir = ('fa' => 1, 'faa' => 1, 'fab' => 1, 'faba' => 1, - 'fb' => 1, 'fba' => 1); - delete @Expect_Dir{'fb','fba'} unless $symlink_exists; - File::Find::find( {wanted => sub { - wanted(); - File::Find::find( {wanted => sub {} , untaint => 1, untaint_pattern => qr|^(.+)$|},'.' ); - }, untaint => 1, untaint_pattern => qr|^(.+)$|},'fa' ); - Check( scalar(keys %Expect) == 0 ); - - %Expect=('fa' => 1, 'fa/fsl' => 1, 'fa/fa_ord' => 1, 'fa/fab' => 1, - 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, - 'fa/fab/faba/faba_ord' => 1, 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); - delete $Expect{'fa/fsl'} unless $symlink_exists; - %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, - 'fb' => 1, 'fb/fba' => 1); - delete @Expect_Dir{'fb','fb/fba'} unless $symlink_exists; - File::Find::find( {wanted => \&wanted, no_chdir => 1, untaint => 1, untaint_pattern => qr|^(.+)$|},'fa' ); - Check( scalar(keys %Expect) == 0 ); - - %Expect=('.' => 1, './fa' => 1, './fa/fsl' => 1, './fa/fa_ord' => 1, './fa/fab' => 1, - './fa/fab/fab_ord' => 1, './fa/fab/faba' => 1, - './fa/fab/faba/faba_ord' => 1, './fa/faa' => 1, './fa/faa/faa_ord' => 1, - './fb' => 1, './fb/fba' => 1, './fb/fba/fba_ord' => 1, './fb/fb_ord' => 1); - delete $Expect{'./fa/fsl'} unless $symlink_exists; - %Expect_Dir = ('./fa' => 1, './fa/faa' => 1, '/fa/fab' => 1, './fa/fab/faba' => 1, - './fb' => 1, './fb/fba' => 1); - delete @Expect_Dir{'./fb','./fb/fba'} unless $symlink_exists; - File::Find::finddepth( {wanted => \&dn_wanted , untaint => 1, untaint_pattern => qr|^(.+)$|},'.' ); - Check( scalar(keys %Expect) == 0 ); - - %Expect=('.' => 1, './fa' => 1, './fa/fsl' => 1, './fa/fa_ord' => 1, './fa/fab' => 1, - './fa/fab/fab_ord' => 1, './fa/fab/faba' => 1, - './fa/fab/faba/faba_ord' => 1, './fa/faa' => 1, './fa/faa/faa_ord' => 1, - './fb' => 1, './fb/fba' => 1, './fb/fba/fba_ord' => 1, './fb/fb_ord' => 1); - delete $Expect{'./fa/fsl'} unless $symlink_exists; - %Expect_Dir = ('./fa' => 1, './fa/faa' => 1, '/fa/fab' => 1, './fa/fab/faba' => 1, - './fb' => 1, './fb/fba' => 1); - delete @Expect_Dir{'./fb','./fb/fba'} unless $symlink_exists; - File::Find::finddepth( {wanted => \&d_wanted, no_chdir => 1, untaint => 1, untaint_pattern => qr|^(.+)$| },'.' ); - Check( scalar(keys %Expect) == 0 ); - - # untaint, preprocess and postprocess tests below added by Thomas Wegner, 17-05-2001 - - print "# check untainting (no follow)\n"; - # don't untaint at all ++ print "# check recursion\n"; ++ if ($^O eq 'MacOS') { ++ CheckDie( symlink(':fa:faa',':fa:faa:faa_sl') ); ++ } else { ++ CheckDie( symlink('../faa','fa/faa/faa_sl') ); ++ } + undef $@; - eval {File::Find::find( {wanted => \&simple_wanted},'fa' );}; - print "# Died: $@"; - Check( $@ =~ m|Insecure dependency| ); - chdir($cwd_untainted); ++ eval {File::Find::find( {wanted => \&simple_wanted, follow => 1, ++ no_chdir => 1}, topdir('fa') ); }; ++ Check( $@ =~ m|for_find[:/]fa[:/]faa[:/]faa_sl is a recursive symbolic link| ); ++ unlink file_path('fa', 'faa', 'faa_sl'); + - undef $@; - eval {File::Find::find( {wanted => \&simple_wanted, untaint => 1, - untaint_pattern => qr|^(NO_MATCH)$|},'fa' );}; - print "# Died: $@"; - Check( $@ =~ m|is still tainted| ); - chdir($cwd_untainted); + - print "# check untaint_skip (no follow)\n"; ++ print "# check follow_skip (file)\n"; ++ if ($^O eq 'MacOS') { ++ CheckDie( symlink(':fa:fa_ord',':fa:fa_ord_sl') ); # symlink to a file ++ } else { ++ CheckDie( symlink('./fa_ord','fa/fa_ord_sl') ); # symlink to a file ++ } + undef $@; - eval {File::Find::find( {wanted => \&simple_wanted, untaint => 1, untaint_skip => 1, - untaint_pattern => qr|^(NO_MATCH)$|}, 'fa' );}; - print "# Died: $@"; - Check( $@ =~ m|insecure cwd| ); - chdir($cwd_untainted); - - print "# check preprocess\n"; - %Expect=( - '.' => {fa => 1, fb => 1}, - './fa' => {faa => 1, fab => 1, fa_ord => 1}, - './fa/faa' => {faa_ord => 1}, - './fa/fab' => {faba => 1, fab_ord => 1}, - './fa/fab/faba' => {faba_ord => 1}, - './fb' => {fba => 1, fb_ord => 1}, - './fb/fba' => {fba_ord => 1} - ); - - File::Find::find( {wanted => \&noop_wanted, preprocess => \&my_preprocess, untaint => 1, - untaint_pattern => qr|^(.+)$|}, '.' ); - Check( scalar(keys %Expect) == 0 ); - - print "# check postprocess\n"; - %Expect=('.' => 1, './fa' => 1, './fa/faa' => 1, './fa/fab' => 1, './fa/fab/faba' => 1, './fb' => 1, - './fb/fba' => 1 ); - File::Find::find( {wanted => \&noop_wanted, postprocess => \&my_postprocess, untaint => 1, - untaint_pattern => qr|^(.+)$|}, '.' ); - Check( scalar(keys %Expect) == 0 ); + - # Verify that File::Find::find will call wanted even if the topdir of - # is a symlink to a directory, and it shouldn't follow the link - # unless follow is set, which it isn't in this case - %Expect = ('fsl' => 1); - %Expect_Dir = (); - File::Find::find( {wanted => \&wanted, untaint => 1},'fa/fsl' ); - Check( scalar(keys %Expect) == 0 ); - - if ( $symlink_exists ) { - $FastFileTests_OK= 1; - %Expect=('.' => 1, 'fa_ord' => 1, 'fsl' => 1, 'fb_ord' => 1, 'fba' => 1, - 'fba_ord' => 1, 'fab' => 1, 'fab_ord' => 1, 'faba' => 1, 'faa' => 1, - 'faa_ord' => 1); - %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, - 'fb' => 1, 'fb/fba' => 1); - File::Find::find( {wanted => \&wanted, follow_fast => 1, untaint => 1, untaint_pattern => qr|^(.+)$|},'fa' ); - Check( scalar(keys %Expect) == 0 ); - - %Expect=('fa' => 1, 'fa/fa_ord' => 1, 'fa/fsl' => 1, 'fa/fsl/fb_ord' => 1, - 'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1, - 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1, - 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); - %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, - 'fb' => 1, 'fb/fba' => 1); - File::Find::find( {wanted => \&wanted, follow_fast => 1, no_chdir => 1, untaint => 1, - untaint_pattern => qr|^(.+)$|},'fa' ); - Check( scalar(keys %Expect) == 0 ); - - %Expect=('fa' => 1, 'fa/fa_ord' => 1, 'fa/fsl' => 1, 'fa/fsl/fb_ord' => 1, - 'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1, - 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1, - 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); - %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, - 'fb' => 1, 'fb/fba' => 1); - File::Find::finddepth( {wanted => \&dn_wanted, follow_fast => 1, untaint => 1, - untaint_pattern => qr|^(.+)$|},'fa' ); - Check( scalar(keys %Expect) == 0 ); - - %Expect=('fa' => 1, 'fa/fa_ord' => 1, 'fa/fsl' => 1, 'fa/fsl/fb_ord' => 1, - 'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1, - 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1, - 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); - %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, - 'fb' => 1, 'fb/fba' => 1); - File::Find::finddepth( {wanted => \&d_wanted, follow_fast => 1, no_chdir => 1, - untaint => 1, untaint_pattern => qr|^(.+)$|},'fa' ); - Check( scalar(keys %Expect) == 0 ); - - # tests below added by Thomas Wegner, 17-05-2001 - - print "# check dangling symbolic links\n"; - MkDir( 'dangling_dir',0770 ); - CheckDie( symlink('dangling_dir','dangling_dir_sl') ); - rmdir 'dangling_dir'; - touch('dangling_file'); - CheckDie( symlink('../dangling_file','fa/dangling_file_sl') ); - unlink 'dangling_file'; - - %Expect=('.' => 1, 'fa_ord' => 1, 'fsl' => 1, 'fb_ord' => 1, 'fba' => 1, - 'fba_ord' => 1, 'fab' => 1, 'fab_ord' => 1, 'faba' => 1, 'faba_ord' => 1, - 'faa' => 1, 'faa_ord' => 1); - %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, 'fa/fab' => 1, 'fa/fab/faba' => 1, - 'fb' => 1, 'fb/fba' => 1); - undef $warn_msg; - File::Find::find( {wanted => \&d_wanted, follow => 1, untaint => 1, - untaint_pattern => qr|^(.+)$|}, 'dangling_dir_sl', 'fa' ); - Check( $warn_msg =~ m|dangling_dir_sl is a dangling symbolic link| ); - unlink 'fa/dangling_file_sl', 'dangling_dir_sl'; - - print "# check recursion\n"; - CheckDie( symlink('../faa','fa/faa/faa_sl') ); - undef $@; - eval {File::Find::find( {wanted => \&simple_wanted, follow => 1, no_chdir => 1, - untaint => 1, untaint_pattern => qr|^(.+)$|},'fa' ); }; - print "# Died: $@"; - Check( $@ =~ m|for_find/fa/faa/faa_sl is a recursive symbolic link| ); - unlink 'fa/faa/faa_sl'; - - print "# check follow_skip (file)\n"; - CheckDie( symlink('./fa_ord','fa/fa_ord_sl') ); # symlink to a file - undef $@; - eval {File::Find::finddepth( {wanted => \&simple_wanted, follow => 1, follow_skip => 0, no_chdir => 1, - untaint => 1, untaint_pattern => qr|^(.+)$|},'fa' );}; - print "# Died: $@"; - Check( $@ =~ m|for_find/fa/fa_ord encountered a second time| ); - - %Expect=('fa' => 1, 'fa/fa_ord' => 1, 'fa/fsl' => 1, 'fa/fsl/fb_ord' => 1, - 'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1, - 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1, - 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); - %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, - 'fb' => 1, 'fb/fba' => 1); - File::Find::finddepth( {wanted => \&wanted, follow => 1, follow_skip => 1, no_chdir => 1, - untaint => 1, untaint_pattern => qr|^(.+)$|},'fa' ); - Check( scalar(keys %Expect) == 0 ); - unlink 'fa/fa_ord_sl'; - - print "# check follow_skip (directory)\n"; - CheckDie( symlink('./faa','fa/faa_sl') ); # symlink to a directory - undef $@; - eval {File::Find::find( {wanted => \&simple_wanted, follow => 1, follow_skip => 0, no_chdir => 1, - untaint => 1, untaint_pattern => qr|^(.+)$|},'fa' );}; - print "# Died: $@"; - Check( $@ =~ m|for_find/fa/faa encountered a second time| ); - - undef $@; - eval {File::Find::find( {wanted => \&simple_wanted, follow => 1, follow_skip => 1, no_chdir => 1, - untaint => 1, untaint_pattern => qr|^(.+)$|},'fa' );}; - print "# Died: $@"; - Check( $@ =~ m|for_find/fa/faa encountered a second time| ); - - %Expect=('fa' => 1, 'fa/fa_ord' => 1, 'fa/fsl' => 1, 'fa/fsl/fb_ord' => 1, - 'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1, - 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1, - 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); - %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, - 'fb' => 1, 'fb/fba' => 1); - File::Find::find( {wanted => \&wanted, follow => 1, follow_skip => 2, no_chdir => 1, - untaint => 1, untaint_pattern => qr|^(.+)$|},'fa' ); - Check( scalar(keys %Expect) == 0 ); - unlink 'fa/faa_sl'; - - print "# check untainting (follow)\n"; - # don't untaint at all - undef $@; - eval {File::Find::find( {wanted => \&simple_wanted, follow => 1},'fa' );}; - print "# Died: $@"; - Check( $@ =~ m|Insecure dependency| ); - chdir($cwd_untainted); - - undef $@; - eval {File::Find::find( {wanted => \&simple_wanted, follow => 1, untaint => 1, - untaint_pattern => qr|^(NO_MATCH)$|},'fa' );}; - print "# Died: $@"; - Check( $@ =~ m|is still tainted| ); - chdir($cwd_untainted); - - print "# check untaint_skip (follow)\n"; - undef $@; - eval {File::Find::find( {wanted => \&simple_wanted, untaint => 1, untaint_skip => 1, - untaint_pattern => qr|^(NO_MATCH)$|}, 'fa' );}; - print "# Died: $@"; - Check( $@ =~ m|insecure cwd| ); - chdir($cwd_untainted); ++ eval {File::Find::finddepth( {wanted => \&simple_wanted, ++ follow => 1, ++ follow_skip => 0, no_chdir => 1}, ++ topdir('fa') );}; ++ ++ Check( $@ =~ m|for_find[:/]fa[:/]fa_ord encountered a second time| ); + ++ ++ # no_chdir is in effect, hence we use file_path_name to specify ++ # the expected paths for %Expect_File ++ ++ %Expect_File = (file_path_name('fa') => 1, ++ file_path_name('fa', 'fa_ord') => 1, ++ file_path_name('fa', 'fsl') => 1, ++ file_path_name('fa', 'fsl', 'fb_ord') => 1, ++ file_path_name('fa', 'fsl', 'fba') => 1, ++ file_path_name('fa', 'fsl', 'fba', 'fba_ord') => 1, ++ file_path_name('fa', 'fab') => 1, ++ file_path_name('fa', 'fab', 'fab_ord') => 1, ++ file_path_name('fa', 'fab', 'faba') => 1, ++ file_path_name('fa', 'fab', 'faba', 'faba_ord') => 1, ++ file_path_name('fa', 'faa') => 1, ++ file_path_name('fa', 'faa', 'faa_ord') => 1); ++ ++ %Expect_Name = (); ++ ++ %Expect_Dir = (dir_path('fa') => 1, ++ dir_path('fa', 'faa') => 1, ++ dir_path('fa', 'fab') => 1, ++ dir_path('fa', 'fab', 'faba') => 1, ++ dir_path('fb') => 1, ++ dir_path('fb','fba') => 1); ++ ++ File::Find::finddepth( {wanted => \&wanted_File_Dir, follow => 1, ++ follow_skip => 1, no_chdir => 1}, ++ topdir('fa') ); ++ ++ Check( scalar(keys %Expect_File) == 0 ); ++ unlink file_path('fa', 'fa_ord_sl'); ++ ++ ++ print "# check follow_skip (directory)\n"; ++ if ($^O eq 'MacOS') { ++ CheckDie( symlink(':fa:faa',':fa:faa_sl') ); # symlink to a directory ++ } else { ++ CheckDie( symlink('./faa','fa/faa_sl') ); # symlink to a directory + } - } ++ undef $@; ++ ++ eval {File::Find::find( {wanted => \&simple_wanted, follow => 1, ++ follow_skip => 0, no_chdir => 1}, ++ topdir('fa') );}; ++ ++ Check( $@ =~ m|for_find[:/]fa[:/]faa[:/]? encountered a second time| ); ++ ++ ++ undef $@; ++ ++ eval {File::Find::find( {wanted => \&simple_wanted, follow => 1, ++ follow_skip => 1, no_chdir => 1}, ++ topdir('fa') );}; ++ ++ Check( $@ =~ m|for_find[:/]fa[:/]faa[:/]? encountered a second time| ); ++ ++ # no_chdir is in effect, hence we use file_path_name to specify ++ # the expected paths for %Expect_File ++ ++ %Expect_File = (file_path_name('fa') => 1, ++ file_path_name('fa', 'fa_ord') => 1, ++ file_path_name('fa', 'fsl') => 1, ++ file_path_name('fa', 'fsl', 'fb_ord') => 1, ++ file_path_name('fa', 'fsl', 'fba') => 1, ++ file_path_name('fa', 'fsl', 'fba', 'fba_ord') => 1, ++ file_path_name('fa', 'fab') => 1, ++ file_path_name('fa', 'fab', 'fab_ord') => 1, ++ file_path_name('fa', 'fab', 'faba') => 1, ++ file_path_name('fa', 'fab', 'faba', 'faba_ord') => 1, ++ file_path_name('fa', 'faa') => 1, ++ file_path_name('fa', 'faa', 'faa_ord') => 1); ++ ++ %Expect_Name = (); ++ ++ %Expect_Dir = (dir_path('fa') => 1, ++ dir_path('fa', 'faa') => 1, ++ dir_path('fa', 'fab') => 1, ++ dir_path('fa', 'fab', 'faba') => 1, ++ dir_path('fb') => 1, ++ dir_path('fb', 'fba') => 1); ++ ++ File::Find::find( {wanted => \&wanted_File_Dir, follow => 1, ++ follow_skip => 2, no_chdir => 1}, topdir('fa') ); ++ ++ Check( scalar(keys %Expect_File) == 0 ); ++ unlink file_path('fa', 'faa_sl'); ++ ++} + - print "# of cases: $case\n"; diff --cc t/lib/filehand.t index 0f3e177,0000000..eaddf49 mode 100755,000000..100755 --- a/t/lib/filehand.t +++ b/t/lib/filehand.t @@@ -1,91 -1,0 +1,91 @@@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { + print "1..0\n"; + exit 0; + } +} + +use FileHandle; +use strict subs; + +autoflush STDOUT 1; + +$mystdout = new_from_fd FileHandle 1,"w"; +$| = 1; +autoflush $mystdout; +print "1..11\n"; + +print $mystdout "ok ".fileno($mystdout)."\n"; + +$fh = (new FileHandle "./TEST", O_RDONLY + or new FileHandle "TEST", O_RDONLY) + and print "ok 2\n"; + + +$buffer = <$fh>; +print $buffer eq "#!./perl\n" ? "ok 3\n" : "not ok 3\n"; + + +ungetc $fh ord 'A'; +CORE::read($fh, $buf,1); +print $buf eq 'A' ? "ok 4\n" : "not ok 4\n"; + +close $fh; + +$fh = new FileHandle; + +print "not " unless ($fh->open("< TEST") && <$fh> eq $buffer); +print "ok 5\n"; + +$fh->seek(0,0); +print "#possible mixed CRLF/LF in t/TEST\nnot " unless (<$fh> eq $buffer); +print "ok 6\n"; + +$fh->seek(0,2); +$line = <$fh>; +print "not " if (defined($line) || !$fh->eof); +print "ok 7\n"; + +print "not " unless ($fh->open("TEST","r") && !$fh->tell && $fh->close); +print "ok 8\n"; + +autoflush STDOUT 0; + +print "not " if ($|); +print "ok 9\n"; + +autoflush STDOUT 1; + +print "not " unless ($|); +print "ok 10\n"; + +if ($^O eq 'dos') +{ + printf("ok %d\n",11); + exit(0); +} + +($rd,$wr) = FileHandle::pipe; + - if ($^O eq 'VMS' || $^O eq 'os2' || $^O eq 'amigaos' || $^O eq 'MSWin32' || ++if ($^O eq 'VMS' || $^O eq 'os2' || $^O eq 'amigaos' || $^O eq 'MSWin32' || $^O eq 'NetWare' || + $Config{d_fork} ne 'define') { + $wr->autoflush; + $wr->printf("ok %d\n",11); + print $rd->getline; +} +else { + if (fork) { + $wr->close; + print $rd->getline; + } + else { + $rd->close; + $wr->printf("ok %d\n",11); + exit(0); + } +} diff --cc t/lib/filter-util.t index 4c40463,0000000..dc667c9 mode 100644,000000..100644 --- a/t/lib/filter-util.t +++ b/t/lib/filter-util.t @@@ -1,795 -1,0 +1,795 @@@ +BEGIN { + chdir('t') if -d 't'; + @INC = '.'; + push @INC, '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ m{\bFilter/Util/Call\b}) { + print "1..0 # Skip: Filter::Util::Call was not built\n"; + exit 0; + } + require 'lib/filter-util.pl'; +} + +use strict; +use warnings; + +use vars qw($Inc $Perl); + +print "1..28\n" ; + +$Perl = "$Perl -w" ; + +use Cwd ; +my $here = getcwd ; + + +my $filename = "call.tst" ; +my $filenamebin = "call.bin" ; +my $module = "MyTest" ; +my $module2 = "MyTest2" ; +my $module3 = "MyTest3" ; +my $module4 = "MyTest4" ; +my $module5 = "MyTest5" ; +my $nested = "nested" ; +my $block = "block" ; + +# Test error cases +################## + +# no filter function in module +############################### + +writeFile("${module}.pm", <&1` ; - ok(1, (($? >>8) != 0 or ($^O eq 'MSWin32' && $? != 0))) ; ++ok(1, (($? >>8) != 0 or (($^O eq 'MSWin32' || $^O eq 'NetWare') && $? != 0))) ; +ok(2, $a =~ /^Can't locate object method "filter" via package "MyTest"/) ; + +# no reference parameter in filter_add +###################################### + +writeFile("${module}.pm", <&1` ; - ok(3, (($? >>8) != 0 or ($^O eq 'MSWin32' && $? != 0))) ; ++ok(3, (($? >>8) != 0 or (($^O eq 'MSWin32' || $^O eq 'NetWare') && $? != 0))) ; +#ok(4, $a =~ /^usage: filter_add\(ref\) at ${module}.pm/) ; +ok(4, $a =~ /^Not enough arguments for Filter::Util::Call::filter_add/) ; + + + + +# non-error cases +################# + + +# a simple filter, using a closure +################# + +writeFile("${module}.pm", < 0) { + s/ABC/DEF/g + } + $status ; + } ) ; +} + +1 ; +EOM + +writeFile($filename, <&1` ; +ok(5, ($? >>8) == 0) ; +ok(6, $a eq < 0) { + s/ABC/DEF/g + } + $status ; +} + + +1 ; +EOM + +writeFile($filename, <&1` ; +ok(7, ($? >>8) == 0) ; +ok(8, $a eq < 0) { + s/XYZ/PQR/g + } + $status ; +} + +1 ; +EOM + +writeFile("${module3}.pm", < 0) { + s/Fred/Joe/g + } + $status ; + } ) ; +} + +1 ; +EOM + +writeFile("${module4}.pm", < 0) { + s/Today/Tomorrow/g + } + $status ; +} + +1 ; +EOM + +writeFile($filename, <&1` ; +ok(9, ($? >>8) == 0) ; +ok(10, $a eq < 0) { + foreach $pattern (@strings) + { s/$pattern/PQR/g } + } + + $status ; + } + ) + +} +1 ; +EOM + + +writeFile($filename, <&1` ; +ok(11, ($? >>8) == 0) ; +ok(12, $a eq < 0) { + foreach $pattern (@$self) + { s/$pattern/PQR/g } + } + + $status ; +} + +1 ; +EOM + + +writeFile($filename, <&1` ; +ok(13, ($? >>8) == 0) ; +ok(14, $a eq < 0) { + chop ; + s/\r$//; + # and now the second line (it will append) + $status = filter_read() ; + } + + $status ; +} + +1 ; +EOM + + +writeFile($filename, <&1` ; +ok(15, ($? >>8) == 0) ; +ok(16, $a eq <&1` ; +ok(17, ($? >>8) == 0) ; +ok(18, $a eq < 0) { + s/DIR/$here/g + } + $status ; +} + +1 ; +EOM + +writeFile($filename, <&1` ; +ok(19, ($? >>8) == 0) ; +ok(20, $a eq < 0 ; + + -- $$self ; + filter_del() if $$self <= 0 ; + + $status ; +} + +1 ; +EOM + +writeFile($filename, <&1` ; +ok(21, ($? >>8) == 0) ; +ok(22, $a eq < 0) { + s/HERE/THERE/g + } + + $status ; +} + +1 ; +EOM + +writeFile($filenamebin, <&1` ; +ok(23, ($? >>8) == 0) ; +ok(24, $a eq < 0) { + s/HERE/THERE/g + } + + $status ; +} + +1 ; +EOM + +writeFile($filename, <; +print @a; +__DATA__ +HERE I am +I'm HERE +HERE today gone tomorrow +EOM + +$a = `$Perl "-I." $Inc $filename 2>&1` ; +ok(25, ($? >>8) == 0) ; +ok(26, $a eq < 0) { + s/HERE/THERE/g + } + + $status ; +} + +1 ; +EOM + +writeFile($filename, <; +print @a; +__END__ +HERE I am +I'm HERE +HERE today gone tomorrow +EOM + +$a = `$Perl "-I." $Inc $filename 2>&1` ; +ok(27, ($? >>8) == 0) ; +ok(28, $a eq < '../lib'; ++ ++ for (keys %ENV) { # untaint ENV ++ ($ENV{$_}) = $ENV{$_} =~ /(.*)/; ++ } ++} ++ ++if ( $symlink_exists ) { print "1..45\n"; } ++else { print "1..27\n"; } ++ ++use File::Find; ++use File::Spec; ++use Cwd; ++ ++# Remove insecure directories from PATH ++my @path; ++my $sep = ($^O eq 'MSWin32') ? ';' : ':'; ++foreach my $dir (split(/$sep/,$ENV{'PATH'})) ++ { ++ push(@path,$dir) unless -w $dir; ++ } ++$ENV{'PATH'} = join($sep,@path); ++ ++cleanup(); ++ ++find({wanted => sub { print "ok 1\n" if $_ eq 'filefind.t'; }, ++ untaint => 1, untaint_pattern => qr|^(.+)$|}, File::Spec->curdir); ++ ++finddepth({wanted => sub { print "ok 2\n" if $_ eq 'filefind.t'; }, ++ untaint => 1, untaint_pattern => qr|^(.+)$|}, ++ File::Spec->curdir); ++ ++my $case = 2; ++my $FastFileTests_OK = 0; ++ ++sub cleanup { ++ if (-d dir_path('for_find')) { ++ chdir(dir_path('for_find')); ++ } ++ if (-d dir_path('fa')) { ++ unlink file_path('fa', 'fa_ord'), ++ file_path('fa', 'fsl'), ++ file_path('fa', 'faa', 'faa_ord'), ++ file_path('fa', 'fab', 'fab_ord'), ++ file_path('fa', 'fab', 'faba', 'faba_ord'), ++ file_path('fb', 'fb_ord'), ++ file_path('fb', 'fba', 'fba_ord'); ++ rmdir dir_path('fa', 'faa'); ++ rmdir dir_path('fa', 'fab', 'faba'); ++ rmdir dir_path('fa', 'fab'); ++ rmdir dir_path('fa'); ++ rmdir dir_path('fb', 'fba'); ++ rmdir dir_path('fb'); ++ chdir File::Spec->updir; ++ rmdir dir_path('for_find'); ++ } ++} ++ ++END { ++ cleanup(); ++} ++ ++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_File_Dir { ++ print "# \$File::Find::dir => '$File::Find::dir'\n"; ++ print "# \$_ => '$_'\n"; ++ s#\.$## if ($^O eq 'VMS' && $_ ne '.'); ++ Check( $Expect_File{$_} ); ++ if ( $FastFileTests_OK ) { ++ delete $Expect_File{ $_} ++ unless ( $Expect_Dir{$_} && ! -d _ ); ++ } else { ++ delete $Expect_File{$_} ++ unless ( $Expect_Dir{$_} && ! -d $_ ); ++ } ++} ++ ++sub wanted_File_Dir_prune { ++ &wanted_File_Dir; ++ $File::Find::prune=1 if $_ eq 'faba'; ++} ++ ++ ++sub simple_wanted { ++ print "# \$File::Find::dir => '$File::Find::dir'\n"; ++ print "# \$_ => '$_'\n"; ++} ++ ++ ++# Use dir_path() to specify a directory path that's expected for ++# $File::Find::dir (%Expect_Dir). Also use it in file operations like ++# chdir, rmdir etc. ++# ++# dir_path() concatenates directory names to form a _relative_ ++# directory path, independant from the platform it's run on, although ++# there are limitations. Don't try to create an absolute path, ++# because that may fail on operating systems that have the concept of ++# volume names (e.g. Mac OS). Be careful when you want to create an ++# updir path like ../fa (Unix) or ::fa: (Mac OS). Plain directory ++# names will work best. As a special case, you can pass it a "." as ++# first argument, to create a directory path like "./fa/dir" on ++# operating systems other than Mac OS (actually, Mac OS will ignore ++# the ".", if it's the first argument). If there's no second argument, ++# this function will return the empty string on Mac OS and the string ++# "./" otherwise. ++ ++sub dir_path { ++ my $first_item = shift @_; ++ ++ if ($first_item eq '.') { ++ if ($^O eq 'MacOS') { ++ return '' unless @_; ++ # ignore first argument; return a relative path ++ # with leading ":" and with trailing ":" ++ return File::Spec->catdir("", @_); ++ } else { # other OS ++ return './' unless @_; ++ my $path = File::Spec->catdir(@_); ++ # add leading "./" ++ $path = "./$path"; ++ return $path; ++ } ++ ++ } else { # $first_item ne '.' ++ return $first_item unless @_; # return plain filename ++ if ($^O eq 'MacOS') { ++ # relative path with leading ":" and with trailing ":" ++ return File::Spec->catdir("", $first_item, @_); ++ } else { # other OS ++ return File::Spec->catdir($first_item, @_); ++ } ++ } ++} ++ ++ ++# Use topdir() to specify a directory path that you want to pass to ++#find/finddepth Basically, topdir() does the same as dir_path() (see ++#above), except that there's no trailing ":" on Mac OS. ++ ++sub topdir { ++ my $path = dir_path(@_); ++ $path =~ s/:$// if ($^O eq 'MacOS'); ++ return $path; ++} ++ ++ ++# Use file_path() to specify a file path that's expected for $_ (%Expect_File). ++# Also suitable for file operations like unlink etc. ++ ++# file_path() concatenates directory names (if any) and a filename to ++# form a _relative_ file path (the last argument is assumed to be a ++# file). It's independant from the platform it's run on, although ++# there are limitations (see the warnings for dir_path() above). As a ++# special case, you can pass it a "." as first argument, to create a ++# file path like "./fa/file" on operating systems other than Mac OS ++# (actually, Mac OS will ignore the ".", if it's the first ++# argument). If there's no second argument, this function will return ++# the empty string on Mac OS and the string "./" otherwise. ++ ++sub file_path { ++ my $first_item = shift @_; ++ ++ if ($first_item eq '.') { ++ if ($^O eq 'MacOS') { ++ return '' unless @_; ++ # ignore first argument; return a relative path ++ # with leading ":", but without trailing ":" ++ return File::Spec->catfile("", @_); ++ } else { # other OS ++ return './' unless @_; ++ my $path = File::Spec->catfile(@_); ++ # add leading "./" ++ $path = "./$path"; ++ return $path; ++ } ++ ++ } else { # $first_item ne '.' ++ return $first_item unless @_; # return plain filename ++ if ($^O eq 'MacOS') { ++ # relative path with leading ":", but without trailing ":" ++ return File::Spec->catfile("", $first_item, @_); ++ } else { # other OS ++ return File::Spec->catfile($first_item, @_); ++ } ++ } ++} ++ ++ ++# Use file_path_name() to specify a file path that's expected for ++# $File::Find::Name (%Expect_Name). Note: When the no_chdir => 1 ++# option is in effect, $_ is the same as $File::Find::Name. In that ++# case, also use this function to specify a file path that's expected ++# for $_. ++# ++# Basically, file_path_name() does the same as file_path() (see ++# above), except that there's always a leading ":" on Mac OS, even for ++# plain file/directory names. ++ ++sub file_path_name { ++ my $path = file_path(@_); ++ $path = ":$path" if (($^O eq 'MacOS') && ($path !~ /:/)); ++ return $path; ++} ++ ++ ++ ++MkDir( dir_path('for_find'), 0770 ); ++CheckDie(chdir( dir_path('for_find'))); ++ ++$cwd = cwd(); # save cwd ++( $cwd_untainted ) = $cwd =~ m|^(.+)$|; # untaint it ++ ++MkDir( dir_path('fa'), 0770 ); ++MkDir( dir_path('fb'), 0770 ); ++touch( file_path('fb', 'fb_ord') ); ++MkDir( dir_path('fb', 'fba'), 0770 ); ++touch( file_path('fb', 'fba', 'fba_ord') ); ++if ($^O eq 'MacOS') { ++ CheckDie( symlink(':fb',':fa:fsl') ) if $symlink_exists; ++} else { ++ CheckDie( symlink('../fb','fa/fsl') ) if $symlink_exists; ++} ++touch( file_path('fa', 'fa_ord') ); ++ ++MkDir( dir_path('fa', 'faa'), 0770 ); ++touch( file_path('fa', 'faa', 'faa_ord') ); ++MkDir( dir_path('fa', 'fab'), 0770 ); ++touch( file_path('fa', 'fab', 'fab_ord') ); ++MkDir( dir_path('fa', 'fab', 'faba'), 0770 ); ++touch( file_path('fa', 'fab', 'faba', 'faba_ord') ); ++ ++print "# check untainting (no follow)\n"; ++ ++# untainting here should work correctly ++ ++%Expect_File = (File::Spec->curdir => 1, file_path('fsl') => ++ 1,file_path('fa_ord') => 1, file_path('fab') => 1, ++ file_path('fab_ord') => 1, file_path('faba') => 1, ++ file_path('faa') => 1, file_path('faa_ord') => 1); ++delete $Expect_File{ file_path('fsl') } unless $symlink_exists; ++%Expect_Name = (); ++ ++%Expect_Dir = ( dir_path('fa') => 1, dir_path('faa') => 1, ++ dir_path('fab') => 1, dir_path('faba') => 1, ++ dir_path('fb') => 1, dir_path('fba') => 1); ++ ++delete @Expect_Dir{ dir_path('fb'), dir_path('fba') } unless $symlink_exists; ++ ++File::Find::find( {wanted => \&wanted_File_Dir_prune, untaint => 1, ++ untaint_pattern => qr|^(.+)$|}, topdir('fa') ); ++ ++Check( scalar(keys %Expect_File) == 0 ); ++ ++ ++# don't untaint at all, should die ++%Expect_File = (); ++%Expect_Name = (); ++%Expect_Dir = (); ++undef $@; ++eval {File::Find::find( {wanted => \&simple_wanted}, topdir('fa') );}; ++Check( $@ =~ m|Insecure dependency| ); ++chdir($cwd_untainted); ++ ++ ++# untaint pattern doesn't match, should die ++undef $@; ++ ++eval {File::Find::find( {wanted => \&simple_wanted, untaint => 1, ++ untaint_pattern => qr|^(NO_MATCH)$|}, ++ topdir('fa') );}; ++ ++Check( $@ =~ m|is still tainted| ); ++chdir($cwd_untainted); ++ ++ ++# untaint pattern doesn't match, should die when we chdir to cwd ++print "# check untaint_skip (no follow)\n"; ++undef $@; ++ ++eval {File::Find::find( {wanted => \&simple_wanted, untaint => 1, ++ untaint_skip => 1, untaint_pattern => ++ qr|^(NO_MATCH)$|}, topdir('fa') );}; ++ ++Check( $@ =~ m|insecure cwd| ); ++chdir($cwd_untainted); ++ ++ ++if ( $symlink_exists ) { ++ print "# --- symbolic link tests --- \n"; ++ $FastFileTests_OK= 1; ++ ++ print "# check untainting (follow)\n"; ++ ++ # untainting here should work correctly ++ # no_chdir is in effect, hence we use file_path_name to specify the expected paths for %Expect_File ++ ++ %Expect_File = (file_path_name('fa') => 1, ++ file_path_name('fa','fa_ord') => 1, ++ file_path_name('fa', 'fsl') => 1, ++ file_path_name('fa', 'fsl', 'fb_ord') => 1, ++ file_path_name('fa', 'fsl', 'fba') => 1, ++ file_path_name('fa', 'fsl', 'fba', 'fba_ord') => 1, ++ file_path_name('fa', 'fab') => 1, ++ file_path_name('fa', 'fab', 'fab_ord') => 1, ++ file_path_name('fa', 'fab', 'faba') => 1, ++ file_path_name('fa', 'fab', 'faba', 'faba_ord') => 1, ++ file_path_name('fa', 'faa') => 1, ++ file_path_name('fa', 'faa', 'faa_ord') => 1); ++ ++ %Expect_Name = (); ++ ++ %Expect_Dir = (dir_path('fa') => 1, ++ dir_path('fa', 'faa') => 1, ++ dir_path('fa', 'fab') => 1, ++ dir_path('fa', 'fab', 'faba') => 1, ++ dir_path('fb') => 1, ++ dir_path('fb', 'fba') => 1); ++ ++ File::Find::find( {wanted => \&wanted_File_Dir, follow_fast => 1, ++ no_chdir => 1, untaint => 1, untaint_pattern => ++ qr|^(.+)$| }, topdir('fa') ); ++ ++ Check( scalar(keys %Expect_File) == 0 ); ++ ++ ++ # don't untaint at all, should die ++ undef $@; ++ ++ eval {File::Find::find( {wanted => \&simple_wanted, follow => 1}, ++ topdir('fa') );}; ++ ++ Check( $@ =~ m|Insecure dependency| ); ++ chdir($cwd_untainted); ++ ++ # untaint pattern doesn't match, should die ++ undef $@; ++ ++ eval {File::Find::find( {wanted => \&simple_wanted, follow => 1, ++ untaint => 1, untaint_pattern => ++ qr|^(NO_MATCH)$|}, topdir('fa') );}; ++ ++ Check( $@ =~ m|is still tainted| ); ++ chdir($cwd_untainted); ++ ++ # untaint pattern doesn't match, should die when we chdir to cwd ++ print "# check untaint_skip (follow)\n"; ++ undef $@; ++ ++ eval {File::Find::find( {wanted => \&simple_wanted, untaint => 1, ++ untaint_skip => 1, untaint_pattern => ++ qr|^(NO_MATCH)$|}, topdir('fa') );}; ++ ++ Check( $@ =~ m|insecure cwd| ); ++ chdir($cwd_untainted); ++ ++} ++ diff --cc t/lib/ftmp-security.t index 96b2c42,0000000..f9be237 mode 100755,000000..100755 --- a/t/lib/ftmp-security.t +++ b/t/lib/ftmp-security.t @@@ -1,140 -1,0 +1,140 @@@ +#!/usr/bin/perl -w +# Test for File::Temp - Security levels + +# Some of the security checking will not work on all platforms +# Test a simple open in the cwd and tmpdir foreach of the +# security levels + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Test; import Test; + plan(tests => 13); +} + +use strict; +use File::Spec; + +# Set up END block - this needs to happen before we load +# File::Temp since this END block must be evaluated after the +# END block configured by File::Temp +my @files; # list of files to remove +END { foreach (@files) { ok( !(-e $_) )} } + +use File::Temp qw/ tempfile unlink0 /; +ok(1); + +# The high security tests must currently be skipped on some platforms +my $skipplat = ( ( + # No sticky bits. - $^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'dos' ++ $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'os2' || $^O eq 'dos' + ) ? 1 : 0 ); + +# Can not run high security tests in perls before 5.6.0 +my $skipperl = ($] < 5.006 ? 1 : 0 ); + +# Determine whether we need to skip things and why +my $skip = 0; +if ($skipplat) { + $skip = "Skip Not supported on this platform"; +} elsif ($skipperl) { + $skip = "Skip Perl version must be v5.6.0 for these tests"; + +} + +print "# We will be skipping some tests : $skip\n" if $skip; + +# start off with basic checking + +File::Temp->safe_level( File::Temp::STANDARD ); + +print "# Testing with STANDARD security...\n"; + +&test_security(0); + +# Try medium + +File::Temp->safe_level( File::Temp::MEDIUM ) + unless $skip; + +print "# Testing with MEDIUM security...\n"; + +# Now we need to start skipping tests +&test_security($skip); + +# Try HIGH + +File::Temp->safe_level( File::Temp::HIGH ) + unless $skip; + +print "# Testing with HIGH security...\n"; + +&test_security($skip); + +exit; + +# Subroutine to open two temporary files. +# one is opened in the current dir and the other in the temp dir + +sub test_security { + + # Read in the skip flag + my $skip = shift; + + # If we are skipping we need to simply fake the correct number + # of tests -- we dont use skip since the tempfile() commands will + # fail with MEDIUM/HIGH security before the skip() command would be run + if ($skip) { + + skip($skip,1); + skip($skip,1); + + # plus we need an end block so the tests come out in the right order + eval q{ END { skip($skip,1); skip($skip,1) } 1; } || die; + + return; + } + + # Create the tempfile + my $template = "tmpXXXXX"; + my ($fh1, $fname1) = eval { tempfile ( $template, + DIR => File::Spec->tmpdir, + UNLINK => 1, + ); + }; + + if (defined $fname1) { + print "# fname1 = $fname1\n"; + ok( (-e $fname1) ); + push(@files, $fname1); # store for end block + } elsif (File::Temp->safe_level() != File::Temp::STANDARD) { + my $skip2 = "Skip system possibly insecure, see INSTALL, section 'make test'"; + skip($skip2, 1); + # plus we need an end block so the tests come out in the right order + eval q{ END { skip($skip2,1); } 1; } || die; + } else { + ok(0); + } + + # Explicitly + if ( $< < File::Temp->top_system_uid() ){ + skip("Skip Test inappropriate for root", 1); + eval q{ END { skip($skip,1); } 1; } || die; + return; + } + my ($fh2, $fname2) = eval { tempfile ($template, UNLINK => 1 ); }; + if (defined $fname2) { + print "# fname2 = $fname2\n"; + ok( (-e $fname2) ); + push(@files, $fname2); # store for end block + close($fh2); + } elsif (File::Temp->safe_level() != File::Temp::STANDARD) { + my $skip2 = "Skip system possibly insecure, see INSTALL, section 'make test'"; + skip($skip2, 1); + # plus we need an end block so the tests come out in the right order + eval q{ END { skip($skip2,1); } 1; } || die; + } else { + ok(0); + } + +} diff --cc t/lib/gdbm.t index 951804c,0000000..0f5cfa0 mode 100755,000000..100755 --- a/t/lib/gdbm.t +++ b/t/lib/gdbm.t @@@ -1,427 -1,0 +1,427 @@@ +#!./perl + +# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bGDBM_File\b/) { + print "1..0 # Skip: GDBM_File was not built\n"; + exit 0; + } +} + +use strict; +use warnings; + + +use GDBM_File; + +print "1..68\n"; + +unlink ; + +umask(0); +my %h ; +print (tie(%h,'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640) ? "ok 1\n" : "not ok 1\n"); + +my $Dfile = "Op.dbmx.pag"; +if (! -e $Dfile) { + ($Dfile) = ; +} - if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos') { ++if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'dos') { + print "ok 2 # Skipped: different file permission semantics\n"; +} +else { + my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); + print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); +} +my $i = 0; +while (my ($key,$value) = each(%h)) { + $i++; +} +print (!$i ? "ok 3\n" : "not ok 3\n"); + +$h{'goner1'} = 'snork'; + +$h{'abc'} = 'ABC'; +$h{'def'} = 'DEF'; +$h{'jkl','mno'} = "JKL\034MNO"; +$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); +$h{'a'} = 'A'; +$h{'b'} = 'B'; +$h{'c'} = 'C'; +$h{'d'} = 'D'; +$h{'e'} = 'E'; +$h{'f'} = 'F'; +$h{'g'} = 'G'; +$h{'h'} = 'H'; +$h{'i'} = 'I'; + +$h{'goner2'} = 'snork'; +delete $h{'goner2'}; + +untie(%h); +print (tie(%h,'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640) ? "ok 4\n" : "not ok 4\n"); + +$h{'j'} = 'J'; +$h{'k'} = 'K'; +$h{'l'} = 'L'; +$h{'m'} = 'M'; +$h{'n'} = 'N'; +$h{'o'} = 'O'; +$h{'p'} = 'P'; +$h{'q'} = 'Q'; +$h{'r'} = 'R'; +$h{'s'} = 'S'; +$h{'t'} = 'T'; +$h{'u'} = 'U'; +$h{'v'} = 'V'; +$h{'w'} = 'W'; +$h{'x'} = 'X'; +$h{'y'} = 'Y'; +$h{'z'} = 'Z'; + +$h{'goner3'} = 'snork'; + +delete $h{'goner1'}; +delete $h{'goner3'}; + +my @keys = keys(%h); +my @values = values(%h); + +if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} + +while (my ($key,$value) = each(%h)) { + if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { + $key =~ y/a-z/A-Z/; + $i++ if $key eq $value; + } +} + +if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";} + +@keys = ('blurfl', keys(%h), 'dyick'); +if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";} + +$h{'foo'} = ''; +$h{''} = 'bar'; + +# check cache overflow and numeric keys and contents +my $ok = 1; +for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } +for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } +print ($ok ? "ok 8\n" : "not ok 8\n"); + +my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); +print ($size > 0 ? "ok 9\n" : "not ok 9\n"); + +@h{0..200} = 200..400; +my @foo = @h{0..200}; +print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; + +print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); +print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); + +untie %h; +unlink 'Op.dbmx.dir', $Dfile; + +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; +} + +{ + # sub-class test + + package Another ; + + use strict ; + use warnings ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use strict ; + use vars qw(@ISA @EXPORT) ; + + require Exporter ; + use GDBM_File; + @ISA=qw(GDBM_File); + @EXPORT = @GDBM_File::EXPORT ; + + sub STORE { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::STORE($key, $value * 2) ; + } + + sub FETCH { + my $self = shift ; + my $key = shift ; + $self->SUPER::FETCH($key) - 1 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; +EOM + + close FILE ; + + BEGIN { push @INC, '.'; } + unlink ; + + eval 'use SubDB ; '; + main::ok(13, $@ eq "") ; + my %h ; + my $X ; + eval ' + $X = tie(%h, "SubDB","dbhash.tmp", &GDBM_WRCREAT, 0640 ); + ' ; + + main::ok(14, $@ eq "") ; + + my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; + main::ok(15, $@ eq "") ; + main::ok(16, $ret == 5) ; + + $ret = eval ' &GDBM_WRCREAT eq &main::GDBM_WRCREAT ' ; + main::ok(17, $@ eq "" ) ; + main::ok(18, $ret == 1) ; + + $ret = eval '$X->A_new_method("fred") ' ; + main::ok(19, $@ eq "") ; + main::ok(20, $ret eq "[[5]]") ; + + undef $X; + untie(%h); + unlink "SubDB.pm", ; + +} + +{ + # DBM Filter tests + use strict ; + use warnings ; + my (%h, $db) ; + my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + + sub checkOutput + { + my($fk, $sk, $fv, $sv) = @_ ; + return + $fetch_key eq $fk && $store_key eq $sk && + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; + } + + unlink ; + 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 ; +} + +{ + # DBM Filter with a closure + + use strict ; + use warnings ; + my (%h, $db) ; + + unlink ; + ok(42, $db = tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)) ; + + my %result = () ; + + sub Closure + { + my ($name) = @_ ; + my $count = 0 ; + my @kept = () ; + + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } + } + + $db->filter_store_key(Closure("store key")) ; + $db->filter_store_value(Closure("store value")) ; + $db->filter_fetch_key(Closure("fetch key")) ; + $db->filter_fetch_value(Closure("fetch value")) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + ok(43, $result{"store key"} eq "store key - 1: [fred]"); + ok(44, $result{"store value"} eq "store value - 1: [joe]"); + ok(45, !defined $result{"fetch key"} ); + ok(46, !defined $result{"fetch value"} ); + ok(47, $_ eq "original") ; + + ok(48, $db->FIRSTKEY() eq "fred") ; + ok(49, $result{"store key"} eq "store key - 1: [fred]"); + ok(50, $result{"store value"} eq "store value - 1: [joe]"); + ok(51, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(52, ! defined $result{"fetch value"} ); + ok(53, $_ eq "original") ; + + $h{"jim"} = "john" ; + ok(54, $result{"store key"} eq "store key - 2: [fred jim]"); + ok(55, $result{"store value"} eq "store value - 2: [joe john]"); + ok(56, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(57, ! defined $result{"fetch value"} ); + ok(58, $_ eq "original") ; + + ok(59, $h{"fred"} eq "joe"); + ok(60, $result{"store key"} eq "store key - 3: [fred jim fred]"); + ok(61, $result{"store value"} eq "store value - 2: [joe john]"); + ok(62, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(63, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(64, $_ eq "original") ; + + undef $db ; + untie %h; + unlink ; +} + +{ + # DBM Filter recursion detection + use strict ; + use warnings ; + my (%h, $db) ; + unlink ; + + 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 ; +} + +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use GDBM_File ; + + unlink ; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + ok(67, tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)); + $h{ABC} = undef; + ok(68, $a eq "") ; + untie %h; + unlink ; +} diff --cc t/lib/glob-basic.t index e8aef85,0000000..ef9dd96 mode 100755,000000..100755 --- a/t/lib/glob-basic.t +++ b/t/lib/glob-basic.t @@@ -1,175 -1,0 +1,175 @@@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + if ($^O eq 'MacOS') { + @INC = qw(: ::lib ::macos:lib); + } else { + @INC = '.'; + push @INC, '../lib'; + } + require Config; import Config; + if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) { + print "1..0\n"; + exit 0; + } + print "1..11\n"; +} +END { + print "not ok 1\n" unless $loaded; +} +use File::Glob ':glob'; +use Cwd (); +$loaded = 1; +print "ok 1\n"; + +sub array { + return '(', join(", ", map {defined $_ ? "\"$_\"" : "undef"} @a), ")\n"; +} + +# look for the contents of the current directory +$ENV{PATH} = "/bin"; +delete @ENV{BASH_ENV, CDPATH, ENV, IFS}; +@correct = (); +if (opendir(D, $^O eq "MacOS" ? ":" : ".")) { + @correct = grep { !/^\./ } sort readdir(D); + closedir D; +} +@a = File::Glob::glob("*", 0); +@a = sort @a; +if ("@a" ne "@correct" || GLOB_ERROR) { + print "# |@a| ne |@correct|\nnot "; +} +print "ok 2\n"; + +# look up the user's home directory +# should return a list with one item, and not set ERROR - if ($^O ne 'MSWin32' && $^O ne 'VMS') { ++if ($^O ne 'MSWin32' && $^O ne 'NetWare' && $^O ne 'VMS') { + eval { + ($name, $home) = (getpwuid($>))[0,7]; + 1; + } and do { + @a = bsd_glob("~$name", GLOB_TILDE); + if (scalar(@a) != 1 || $a[0] ne $home || GLOB_ERROR) { + print "not "; + } + }; +} +print "ok 3\n"; + +# check backslashing +# should return a list with one item, and not set ERROR +@a = bsd_glob('TEST', GLOB_QUOTE); +if (scalar @a != 1 || $a[0] ne 'TEST' || GLOB_ERROR) { + local $/ = "]["; + print "# [@a]\n"; + print "not "; +} +print "ok 4\n"; + +# check nonexistent checks +# should return an empty list +# XXX since errfunc is NULL on win32, this test is not valid there +@a = bsd_glob("asdfasdf", 0); - if ($^O ne 'MSWin32' and scalar @a != 0) { ++if (($^O ne 'MSWin32' && $^O ne 'NetWare') 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' ++if ($^O eq 'mpeix' or $^O eq 'MSWin32' or $^O eq 'NetWare' or $^O eq 'os2' or $^O eq 'VMS' + or $^O eq 'cygwin' or Cwd::cwd() =~ m#^$Config{'afsroot'}#s or not $>) +{ + print "ok 6 # skipped\n"; +} +else { + $dir = "pteerslt"; + mkdir $dir, 0; + @a = bsd_glob("$dir/*", GLOB_ERR); + #print "\@a = ", array(@a); + rmdir $dir; + if (scalar(@a) != 0 || GLOB_ERROR == 0) { + print "not "; + } + print "ok 6\n"; +} + +# check for csh style globbing +@a = bsd_glob('{a,b}', GLOB_BRACE | GLOB_NOMAGIC); +unless (@a == 2 and $a[0] eq 'a' and $a[1] eq 'b') { + print "not "; +} +print "ok 7\n"; + +@a = bsd_glob( + '{TES*,doesntexist*,a,b}', + GLOB_BRACE | GLOB_NOMAGIC | ($^O eq 'VMS' ? GLOB_NOCASE : 0) +); + +# Working on t/TEST often causes this test to fail because it sees Emacs temp +# and RCS files. Filter them out, and .pm files too, and patch temp files. +@a = grep !/(,v$|~$|\.(pm|ori?g|rej)$)/, @a; + +print "# @a\n"; + +unless (@a == 3 + and $a[0] eq ($^O eq 'VMS'? 'test.' : 'TEST') + and $a[1] eq 'a' + and $a[2] eq 'b') +{ + print "not ok 8 # @a"; +} else { + print "ok 8\n"; +} + +# "~" should expand to $ENV{HOME} +$ENV{HOME} = "sweet home"; +@a = bsd_glob('~', GLOB_TILDE | GLOB_NOMAGIC); +unless ($^O eq "MacOS" || (@a == 1 and $a[0] eq $ENV{HOME})) { + print "not "; +} +print "ok 9\n"; + +# GLOB_ALPHASORT (default) should sort alphabetically regardless of case +mkdir "pteerslt", 0777; +chdir "pteerslt"; + +@f_names = qw(Ax.pl Bx.pl Cx.pl aY.pl bY.pl cY.pl); +@f_alpha = qw(Ax.pl aY.pl Bx.pl bY.pl Cx.pl cY.pl); +if ('a' lt 'A') { # EBCDIC char sets sort lower case before UPPER + @f_names = sort(@f_names); +} +if ($^O eq 'VMS') { # VMS is happily caseignorant + @f_alpha = qw(ax.pl ay.pl bx.pl by.pl cx.pl cy.pl); + @f_names = @f_alpha; +} + +for (@f_names) { + open T, "> $_"; + close T; +} + +$pat = "*.pl"; + +$ok = 1; +@g_names = bsd_glob($pat, 0); +print "# f_names = @f_names\n"; +print "# g_names = @g_names\n"; +for (@f_names) { + $ok = 0 unless $_ eq shift @g_names; +} +print $ok ? "ok 10\n" : "not ok 10\n"; + +$ok = 1; +@g_alpha = bsd_glob($pat); +print "# f_alpha = @f_alpha\n"; +print "# g_alpha = @g_alpha\n"; +for (@f_alpha) { + $ok = 0 unless $_ eq shift @g_alpha; +} +print $ok ? "ok 11\n" : "not ok 11\n"; + +unlink @f_names; +chdir ".."; +rmdir "pteerslt"; diff --cc t/lib/glob-case.t index 881470c,0000000..3c3980c mode 100755,000000..100755 --- a/t/lib/glob-case.t +++ b/t/lib/glob-case.t @@@ -1,60 -1,0 +1,60 @@@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + if ($^O eq 'MacOS') { + @INC = qw(: ::lib ::macos:lib); + } else { + @INC = '.'; + push @INC, '../lib'; + } + require Config; import Config; + if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) { + print "1..0\n"; + exit 0; + } + print "1..7\n"; +} +END { + print "not ok 1\n" unless $loaded; +} +use File::Glob qw(:glob csh_glob); +$loaded = 1; +print "ok 1\n"; + +my $pat = $^O eq "MacOS" ? ":lib:G*.t" : "lib/G*.t"; + +# Test the actual use of the case sensitivity tags, via csh_glob() +import File::Glob ':nocase'; +@a = csh_glob($pat); # At least glob-basic.t glob-case.t glob-global.t +print "not " unless @a >= 3; +print "ok 2\n"; + +# This may fail on systems which are not case-PRESERVING +import File::Glob ':case'; +@a = csh_glob($pat); # None should be uppercase +print "not " unless @a == 0; +print "ok 3\n"; + +# Test the explicit use of the GLOB_NOCASE flag +@a = bsd_glob($pat, GLOB_NOCASE); +print "not " unless @a >= 3; +print "ok 4\n"; + +# Test Win32 backslash nastiness... - if ($^O ne 'MSWin32') { ++if ($^O ne 'MSWin32' && $^O ne 'NetWare') { + print "ok 5\nok 6\nok 7\n"; +} +else { + @a = File::Glob::glob("lib\\g*.t"); + print "not " unless @a >= 3; + print "ok 5\n"; + mkdir "[]", 0; + @a = File::Glob::glob("\\[\\]", GLOB_QUOTE); + rmdir "[]"; + print "# returned @a\nnot " unless @a == 1; + print "ok 6\n"; + @a = bsd_glob("lib\\*", GLOB_QUOTE); + print "not " if @a == 0; + print "ok 7\n"; +} diff --cc t/lib/io_dup.t index 0f17264,0000000..8983a56 mode 100755,000000..100755 --- a/t/lib/io_dup.t +++ b/t/lib/io_dup.t @@@ -1,61 -1,0 +1,61 @@@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { + print "1..0\n"; + exit 0; + } + } +} + +use IO::Handle; +use IO::File; + +select(STDERR); $| = 1; +select(STDOUT); $| = 1; + +print "1..6\n"; + +print "ok 1\n"; + +$dupout = IO::Handle->new->fdopen( \*STDOUT ,"w"); +$duperr = IO::Handle->new->fdopen( \*STDERR ,"w"); + +$stdout = \*STDOUT; bless $stdout, "IO::File"; # "IO::Handle"; +$stderr = \*STDERR; bless $stderr, "IO::Handle"; + +$stdout->open( "Io.dup","w") || die "Can't open stdout"; +$stderr->fdopen($stdout,"w"); + +print $stdout "ok 2\n"; +print $stderr "ok 3\n"; - if ($^O eq 'MSWin32') { ++if ($^O eq 'MSWin32' || $^O eq 'NetWare') { + print `echo ok 4`; + print `echo ok 5 1>&2`; # does this *really* work? +} +else { + system 'echo ok 4'; + system 'echo ok 5 1>&2'; +} + +$stderr->close; +$stdout->close; + +$stdout->fdopen($dupout,"w"); +$stderr->fdopen($duperr,"w"); + - if ($^O eq 'MSWin32') { print `type Io.dup` } ++if ($^O eq 'MSWin32' || $^O eq 'NetWare') { print `type Io.dup` } +else { system 'cat Io.dup' } +unlink 'Io.dup'; + +print STDOUT "ok 6\n"; diff --cc t/lib/io_poll.t index d391566,0000000..d31ea47 mode 100755,000000..100755 --- a/t/lib/io_poll.t +++ b/t/lib/io_poll.t @@@ -1,82 -1,0 +1,82 @@@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib'; + } +} + +if ($^O eq 'mpeix') { + print "1..0 # Skip: broken on MPE/iX\n"; + exit 0; +} + +select(STDERR); $| = 1; +select(STDOUT); $| = 1; + +print "1..9\n"; + +use IO::Handle; +use IO::Poll qw(/POLL/); + +my $poll = new IO::Poll; + +my $stdout = \*STDOUT; +my $dupout = IO::Handle->new_from_fd(fileno($stdout),"w"); + +$poll->mask($stdout => POLLOUT); + +print "not " + unless $poll->mask($stdout) == POLLOUT; +print "ok 1\n"; + +$poll->mask($dupout => POLLPRI); + +print "not " + unless $poll->mask($dupout) == POLLPRI; +print "ok 2\n"; + +$poll->poll(0.1); + - if ($^O eq 'MSWin32') { ++if ($^O eq 'MSWin32' || $^O eq 'NetWare') { +print "ok 3 # skipped, doesn't work on non-socket fds\n"; +print "ok 4 # skipped, doesn't work on non-socket fds\n"; +} +else { +print "not " + unless $poll->events($stdout) == POLLOUT; +print "ok 3\n"; + +print "not " + if $poll->events($dupout); +print "ok 4\n"; +} + +my @h = $poll->handles; +print "not " + unless @h == 2; +print "ok 5\n"; + +$poll->remove($stdout); + +@h = $poll->handles; + +print "not " + unless @h == 1; +print "ok 6\n"; + +print "not " + if $poll->mask($stdout); +print "ok 7\n"; + +$poll->poll(0.1); + +print "not " + if $poll->events($stdout); +print "ok 8\n"; + +$poll->remove($dupout); +print "not " + if $poll->handles; +print "ok 9\n"; diff --cc t/lib/io_sel.t index 5d1dce3,0000000..84660db mode 100755,000000..100755 --- a/t/lib/io_sel.t +++ b/t/lib/io_sel.t @@@ -1,132 -1,0 +1,132 @@@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib'; + } +} + +select(STDERR); $| = 1; +select(STDOUT); $| = 1; + +print "1..23\n"; + +use IO::Select 1.09; + +my $sel = new IO::Select(\*STDIN); +$sel->add(4, 5) == 2 or print "not "; +print "ok 1\n"; + +$sel->add([\*STDOUT, 'foo']) == 1 or print "not "; +print "ok 2\n"; + +@handles = $sel->handles; +print "not " unless $sel->count == 4 && @handles == 4; +print "ok 3\n"; +#print $sel->as_string, "\n"; + +$sel->remove(\*STDIN) == 1 or print "not "; +print "ok 4\n", +; +$sel->remove(\*STDIN, 5, 6) == 1 # two of there are not present + or print "not "; +print "ok 5\n"; + +print "not " unless $sel->count == 2; +print "ok 6\n"; +#print $sel->as_string, "\n"; + +$sel->remove(1, 4); +print "not " unless $sel->count == 0 && !defined($sel->bits); +print "ok 7\n"; + +$sel = new IO::Select; +print "not " unless $sel->count == 0 && !defined($sel->bits); +print "ok 8\n"; + +$sel->remove([\*STDOUT, 5]); +print "not " unless $sel->count == 0 && !defined($sel->bits); +print "ok 9\n"; + - if ($^O eq 'MSWin32' || $^O eq 'dos') { # 4-arg select is only valid on sockets ++if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'dos') { # 4-arg select is only valid on sockets + print "# skipping tests 10..15\n"; + for (10 .. 15) { print "ok $_\n" } + $sel->add(\*STDOUT); # update + goto POST_SOCKET; +} + +@a = $sel->can_read(); # should return imediately +print "not " unless @a == 0; +print "ok 10\n"; + +# we assume that we can write to STDOUT :-) +$sel->add([\*STDOUT, "ok 12\n"]); + +@a = $sel->can_write; +print "not " unless @a == 1; +print "ok 11\n"; + +my($fd, $msg) = @{shift @a}; +print $fd $msg; + +$sel->add(\*STDOUT); # update + +@a = IO::Select::select(undef, $sel, undef, 1); +print "not " unless @a == 3; +print "ok 13\n"; + +($r, $w, $e) = @a; + +print "not " unless @$r == 0 && @$w == 1 && @$e == 0; +print "ok 14\n"; + +$fd = $w->[0]; +print $fd "ok 15\n"; + +POST_SOCKET: +# Test new exists() method +$sel->exists(\*STDIN) and print "not "; +print "ok 16\n"; + +($sel->exists(0) || $sel->exists([\*STDERR])) and print "not "; +print "ok 17\n"; + +$fd = $sel->exists(\*STDOUT); +if ($fd) { + print $fd "ok 18\n"; +} else { + print "not ok 18\n"; +} + +$fd = $sel->exists([1, 'foo']); +if ($fd) { + print $fd "ok 19\n"; +} else { + print "not ok 19\n"; +} + +# Try self clearing +$sel->add(5,6,7,8,9,10); +print "not " unless $sel->count == 7; +print "ok 20\n"; + +$sel->remove($sel->handles); +print "not " unless $sel->count == 0 && !defined($sel->bits); +print "ok 21\n"; + +# check warnings +$SIG{__WARN__} = sub { + ++ $w + if $_[0] =~ /^Call to depreciated method 'has_error', use 'has_exception'/ + } ; +$w = 0 ; +IO::Select::has_error(); +print "not " unless $w == 0 ; +$w = 0 ; +print "ok 22\n" ; +use warnings 'IO::Select' ; +IO::Select::has_error(); +print "not " unless $w == 1 ; +$w = 0 ; +print "ok 23\n" ; diff --cc t/lib/io_taint.t index 19afa2f,0000000..c98d701 mode 100755,000000..100755 --- a/t/lib/io_taint.t +++ b/t/lib/io_taint.t @@@ -1,48 -1,0 +1,48 @@@ +#!./perl -T + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { + print "1..0\n"; + exit 0; + } + } +} + +END { unlink "./__taint__$$" } + +print "1..3\n"; +use IO::File; +$x = new IO::File "> ./__taint__$$" || die("Cannot open ./__taint__$$\n"); +print $x "$$\n"; +$x->close; + +$x = new IO::File "< ./__taint__$$" || die("Cannot open ./__taint__$$\n"); +chop($unsafe = <$x>); +eval { kill 0 * $unsafe }; - print "not " if $^O ne 'MSWin32' and ($@ !~ /^Insecure/o); ++print "not " if ((($^O ne 'MSWin32') && ($^O ne 'NetWare')) and ($@ !~ /^Insecure/o)); +print "ok 1\n"; +$x->close; + +# We could have just done a seek on $x, but technically we haven't tested +# seek yet... +$x = new IO::File "< ./__taint__$$" || die("Cannot open ./__taint__$$\n"); +$x->untaint; +print "not " if ($?); +print "ok 2\n"; # Calling the method worked +chop($unsafe = <$x>); +eval { kill 0 * $unsafe }; +print "not " if ($@ =~ /^Insecure/o); +print "ok 3\n"; # No Insecure message from using the data +$x->close; + +exit 0; diff --cc t/lib/mbimbf.t index 0000000,0000000..3948102 new file mode 100644 --- /dev/null +++ b/t/lib/mbimbf.t @@@ -1,0 -1,0 +1,214 @@@ ++#!/usr/bin/perl -w ++ ++# test accuracy, precicion and fallback, round_mode ++ ++use strict; ++use Test; ++ ++BEGIN ++ { ++ $| = 1; ++ # chdir 't' if -d 't'; ++ unshift @INC, '../lib'; # for running manually ++ plan tests => 103; ++ } ++ ++use Math::BigInt; ++use Math::BigFloat; ++ ++my ($x,$y,$z,$u); ++ ++############################################################################### ++# test defaults and set/get ++ ++ok_undef ($Math::BigInt::accuracy); ++ok_undef ($Math::BigInt::precision); ++ok ($Math::BigInt::div_scale,40); ++ok (Math::BigInt::round_mode(),'even'); ++ok ($Math::BigInt::rnd_mode,'even'); ++ ++ok_undef ($Math::BigFloat::accuracy); ++ok_undef ($Math::BigFloat::precision); ++ok ($Math::BigFloat::div_scale,40); ++ok ($Math::BigFloat::rnd_mode,'even'); ++ ++# accuracy ++foreach (qw/5 42 -1 0/) ++ { ++ ok ($Math::BigFloat::accuracy = $_,$_); ++ ok ($Math::BigInt::accuracy = $_,$_); ++ } ++ok_undef ($Math::BigFloat::accuracy = undef); ++ok_undef ($Math::BigInt::accuracy = undef); ++ ++# precision ++foreach (qw/5 42 -1 0/) ++ { ++ ok ($Math::BigFloat::precision = $_,$_); ++ ok ($Math::BigInt::precision = $_,$_); ++ } ++ok_undef ($Math::BigFloat::precision = undef); ++ok_undef ($Math::BigInt::precision = undef); ++ ++# fallback ++foreach (qw/5 42 1/) ++ { ++ ok ($Math::BigFloat::div_scale = $_,$_); ++ ok ($Math::BigInt::div_scale = $_,$_); ++ } ++# illegal values are possible for fallback due to no accessor ++ ++# round_mode ++foreach (qw/odd even zero trunc +inf -inf/) ++ { ++ ok ($Math::BigFloat::rnd_mode = $_,$_); ++ ok ($Math::BigInt::rnd_mode = $_,$_); ++ } ++$Math::BigFloat::rnd_mode = 4; ++ok ($Math::BigFloat::rnd_mode,4); ++ok ($Math::BigInt::rnd_mode,'-inf'); # from above ++ ++$Math::BigInt::accuracy = undef; ++$Math::BigInt::precision = undef; ++# local copies ++$x = Math::BigFloat->new(123.456); ++ok_undef ($x->accuracy()); ++ok ($x->accuracy(5),5); ++ok_undef ($x->accuracy(undef),undef); ++ok_undef ($x->precision()); ++ok ($x->precision(5),5); ++ok_undef ($x->precision(undef),undef); ++ ++# see if MBF changes MBIs values ++ok ($Math::BigInt::accuracy = 42,42); ++ok ($Math::BigFloat::accuracy = 64,64); ++ok ($Math::BigInt::accuracy,42); # should be still 42 ++ok ($Math::BigFloat::accuracy,64); # should be still 64 ++ ++############################################################################### ++# see if creating a number under set A or P will round it ++ ++$Math::BigInt::accuracy = 4; ++$Math::BigInt::precision = 3; ++ ++ok (Math::BigInt->new(123456),123500); # with A ++$Math::BigInt::accuracy = undef; ++ok (Math::BigInt->new(123456),123000); # with P ++ ++$Math::BigFloat::accuracy = 4; ++$Math::BigFloat::precision = -1; ++$Math::BigInt::precision = undef; ++ ++ok (Math::BigFloat->new(123.456),123.5); # with A ++$Math::BigFloat::accuracy = undef; ++ok (Math::BigFloat->new(123.456),123.5); # with P from MBF, not MBI! ++ ++$Math::BigFloat::precision = undef; ++ ++############################################################################### ++# see if setting accuracy/precision actually rounds the number ++ ++$x = Math::BigFloat->new(123.456); $x->accuracy(4); ok ($x,123.5); ++$x = Math::BigFloat->new(123.456); $x->precision(-2); ok ($x,123.46); ++ ++$x = Math::BigInt->new(123456); $x->accuracy(4); ok ($x,123500); ++$x = Math::BigInt->new(123456); $x->precision(2); ok ($x,123500); ++ ++############################################################################### ++# test actual rounding via round() ++ ++$x = Math::BigFloat->new(123.456); ++ok ($x->copy()->round(5,2),123.46); ++ok ($x->copy()->round(4,2),123.5); ++ok ($x->copy()->round(undef,-2),123.46); ++ok ($x->copy()->round(undef,2),100); ++ ++$x = Math::BigFloat->new(123.45000); ++ok ($x->copy()->round(undef,-1,'odd'),123.5); ++ ++# see if rounding is 'sticky' ++$x = Math::BigFloat->new(123.4567); ++$y = $x->copy()->bround(); # no-op since nowhere A or P defined ++ ++ok ($y,123.4567); ++$y = $x->copy()->round(5,2); ++ok ($y->accuracy(),5); ++ok_undef ($y->precision()); # A has precedence, so P still unset ++$y = $x->copy()->round(undef,2); ++ok ($y->precision(),2); ++ok_undef ($y->accuracy()); # P has precedence, so A still unset ++ ++# does copy work? ++$x = Math::BigFloat->new(123.456); $x->accuracy(4); $x->precision(2); ++$z = $x->copy(); ok ($z->accuracy(),4); ok ($z->precision(),2); ++ ++############################################################################### ++# test wether operations round properly afterwards ++# These tests are not complete, since they do not excercise every "return" ++# statement in the op's. But heh, it's better than nothing... ++ ++$x = Math::BigFloat->new(123.456); ++$y = Math::BigFloat->new(654.321); ++$x->{_a} = 5; # $x->accuracy(5) would round $x straightaway ++$y->{_a} = 4; # $y->accuracy(4) would round $x straightaway ++ ++$z = $x + $y; ok ($z,777.8); ++$z = $y - $x; ok ($z,530.9); ++$z = $y * $x; ok ($z,80780); ++$z = $x ** 2; ok ($z,15241); ++$z = $x * $x; ok ($z,15241); ++# not yet: $z = -$x; ok ($z,-123.46); ok ($x,123.456); ++$z = $x->copy(); $z->{_a} = 2; $z = $z / 2; ok ($z,62); ++$x = Math::BigFloat->new(123456); $x->{_a} = 4; ++$z = $x->copy; $z++; ok ($z,123500); ++ ++$x = Math::BigInt->new(123456); ++$y = Math::BigInt->new(654321); ++$x->{_a} = 5; # $x->accuracy(5) would round $x straightaway ++$y->{_a} = 4; # $y->accuracy(4) would round $x straightaway ++ ++$z = $x + $y; ok ($z,777800); ++$z = $y - $x; ok ($z,530900); ++$z = $y * $x; ok ($z,80780000000); ++$z = $x ** 2; ok ($z,15241000000); ++# not yet: $z = -$x; ok ($z,-123460); ok ($x,123456); ++$z = $x->copy; $z++; ok ($z,123460); ++$z = $x->copy(); $z->{_a} = 2; $z = $z / 2; ok ($z,62000); ++ ++############################################################################### ++# test mixed arguments ++ ++$x = Math::BigFloat->new(10); ++$u = Math::BigFloat->new(2.5); ++$y = Math::BigInt->new(2); ++ ++$z = $x + $y; ok ($z,12); ok (ref($z),'Math::BigFloat'); ++$z = $x / $y; ok ($z,5); ok (ref($z),'Math::BigFloat'); ++$z = $u * $y; ok ($z,5); ok (ref($z),'Math::BigFloat'); ++ ++$y = Math::BigInt->new(12345); ++$z = $u->copy()->bmul($y,2,0,'odd'); ok ($z,31000); ++$z = $u->copy()->bmul($y,3,0,'odd'); ok ($z,30900); ++$z = $u->copy()->bmul($y,undef,0,'odd'); ok ($z,30863); ++$z = $u->copy()->bmul($y,undef,1,'odd'); ok ($z,30860); ++$z = $u->copy()->bmul($y,undef,-1,'odd'); ok ($z,30862.5); ++ ++# breakage: ++# $z = $y->copy()->bmul($u,2,0,'odd'); ok ($z,31000); ++# $z = $y * $u; ok ($z,5); ok (ref($z),'Math::BigInt'); ++# $z = $y + $x; ok ($z,12); ok (ref($z),'Math::BigInt'); ++# $z = $y / $x; ok ($z,0); ok (ref($z),'Math::BigInt'); ++ ++# all done ++ ++############################################################################### ++# Perl 5.005 does not like ok ($x,undef) ++ ++sub ok_undef ++ { ++ my $x = shift; ++ ++ ok (1,1) and return if !defined $x; ++ ok ($x,'undef'); ++ } ++ diff --cc t/lib/ndbm.t index e56fcd9,0000000..cb975e0 mode 100755,000000..100755 --- a/t/lib/ndbm.t +++ b/t/lib/ndbm.t @@@ -1,420 -1,0 +1,420 @@@ +#!./perl + +# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bNDBM_File\b/) { + print "1..0 # Skip: NDBM_File was not built\n"; + exit 0; + } +} + +use strict; +use warnings; + +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; +} + +require NDBM_File; +#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT +use Fcntl; + +print "1..65\n"; + +unlink ; + +umask(0); +my %h; +ok(1, tie(%h,'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)); + +my $Dfile = "Op.dbmx.pag"; +if (! -e $Dfile) { + ($Dfile) = ; +} - if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32') { ++if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare') { + print "ok 2 # Skipped: different file permission semantics\n"; +} +else { + my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); + print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); +} +my $i = 0; +while (my ($key,$value) = each(%h)) { + $i++; +} +print (!$i ? "ok 3\n" : "not ok 3\n"); + +$h{'goner1'} = 'snork'; + +$h{'abc'} = 'ABC'; +$h{'def'} = 'DEF'; +$h{'jkl','mno'} = "JKL\034MNO"; +$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); +$h{'a'} = 'A'; +$h{'b'} = 'B'; +$h{'c'} = 'C'; +$h{'d'} = 'D'; +$h{'e'} = 'E'; +$h{'f'} = 'F'; +$h{'g'} = 'G'; +$h{'h'} = 'H'; +$h{'i'} = 'I'; + +$h{'goner2'} = 'snork'; +delete $h{'goner2'}; + +untie(%h); +print (tie(%h,'NDBM_File','Op.dbmx', &O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); + +$h{'j'} = 'J'; +$h{'k'} = 'K'; +$h{'l'} = 'L'; +$h{'m'} = 'M'; +$h{'n'} = 'N'; +$h{'o'} = 'O'; +$h{'p'} = 'P'; +$h{'q'} = 'Q'; +$h{'r'} = 'R'; +$h{'s'} = 'S'; +$h{'t'} = 'T'; +$h{'u'} = 'U'; +$h{'v'} = 'V'; +$h{'w'} = 'W'; +$h{'x'} = 'X'; +$h{'y'} = 'Y'; +$h{'z'} = 'Z'; + +$h{'goner3'} = 'snork'; + +delete $h{'goner1'}; +delete $h{'goner3'}; + +my @keys = keys(%h); +my @values = values(%h); + +if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} + +while (my ($key,$value) = each(%h)) { + if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { + $key =~ y/a-z/A-Z/; + $i++ if $key eq $value; + } +} + +if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";} + +@keys = ('blurfl', keys(%h), 'dyick'); +if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";} + +$h{'foo'} = ''; +$h{''} = 'bar'; + +# check cache overflow and numeric keys and contents +my $ok = 1; +for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } +for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } +print ($ok ? "ok 8\n" : "not ok 8\n"); + +my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); +print ($size > 0 ? "ok 9\n" : "not ok 9\n"); + +@h{0..200} = 200..400; +my @foo = @h{0..200}; +print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; + +print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); +print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); + +untie %h; +unlink 'Op.dbmx.dir', $Dfile; + +{ + # sub-class test + + package Another ; + + use strict ; + use warnings ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use strict ; + use warnings ; + use vars qw(@ISA @EXPORT) ; + + require Exporter ; + use NDBM_File; + @ISA=qw(NDBM_File); + @EXPORT = @NDBM_File::EXPORT if defined @NDBM_File::EXPORT ; + + sub STORE { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::STORE($key, $value * 2) ; + } + + sub FETCH { + my $self = shift ; + my $key = shift ; + $self->SUPER::FETCH($key) - 1 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; +EOM + + close FILE ; + + BEGIN { push @INC, '.'; } + + eval 'use SubDB ; use Fcntl ; '; + main::ok(13, $@ eq "") ; + my %h ; + my $X ; + eval ' + $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640 ); + ' ; + + main::ok(14, $@ eq "") ; + + my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; + main::ok(15, $@ eq "") ; + main::ok(16, $ret == 5) ; + + $ret = eval '$X->A_new_method("fred") ' ; + main::ok(17, $@ eq "") ; + main::ok(18, $ret eq "[[5]]") ; + + undef $X; + untie(%h); + unlink "SubDB.pm", ; + +} + +{ + # DBM Filter tests + use strict ; + use warnings ; + my (%h, $db) ; + my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + + sub checkOutput + { + my($fk, $sk, $fv, $sv) = @_ ; + return + $fetch_key eq $fk && $store_key eq $sk && + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; + } + + unlink ; + 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 ; +} + +{ + # DBM Filter with a closure + + use strict ; + use warnings ; + my (%h, $db) ; + + unlink ; + ok(40, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ; + + my %result = () ; + + sub Closure + { + my ($name) = @_ ; + my $count = 0 ; + my @kept = () ; + + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } + } + + $db->filter_store_key(Closure("store key")) ; + $db->filter_store_value(Closure("store value")) ; + $db->filter_fetch_key(Closure("fetch key")) ; + $db->filter_fetch_value(Closure("fetch value")) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + ok(41, $result{"store key"} eq "store key - 1: [fred]"); + ok(42, $result{"store value"} eq "store value - 1: [joe]"); + ok(43, !defined $result{"fetch key"} ); + ok(44, !defined $result{"fetch value"} ); + ok(45, $_ eq "original") ; + + ok(46, $db->FIRSTKEY() eq "fred") ; + ok(47, $result{"store key"} eq "store key - 1: [fred]"); + ok(48, $result{"store value"} eq "store value - 1: [joe]"); + ok(49, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(50, ! defined $result{"fetch value"} ); + ok(51, $_ eq "original") ; + + $h{"jim"} = "john" ; + ok(52, $result{"store key"} eq "store key - 2: [fred jim]"); + ok(53, $result{"store value"} eq "store value - 2: [joe john]"); + ok(54, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(55, ! defined $result{"fetch value"} ); + ok(56, $_ eq "original") ; + + ok(57, $h{"fred"} eq "joe"); + ok(58, $result{"store key"} eq "store key - 3: [fred jim fred]"); + ok(59, $result{"store value"} eq "store value - 2: [joe john]"); + ok(60, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(61, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(62, $_ eq "original") ; + + undef $db ; + untie %h; + unlink ; +} + +{ + # DBM Filter recursion detection + use strict ; + use warnings ; + my (%h, $db) ; + unlink ; + + 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 ; +} + +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use NDBM_File ; + + unlink ; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + ok(65, tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ; +} diff --cc t/lib/net-hostent.t index abc5b92,0000000..c3a1219 mode 100644,000000..100644 --- a/t/lib/net-hostent.t +++ b/t/lib/net-hostent.t @@@ -1,72 -1,0 +1,72 @@@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bSocket\b/ && + !(($^O eq 'VMS') && $Config{d_socket})) { + print "1..0 # Test uses Socket, Socket not built\n"; + exit 0; + } +} + +BEGIN { $| = 1; print "1..7\n"; } + +END {print "not ok 1\n" unless $loaded;} + +use Net::hostent; + +$loaded = 1; +print "ok 1\n"; + +# test basic resolution of localhost <-> 127.0.0.1 +use Socket; + +my $h = gethost('localhost'); +print +(defined $h ? '' : 'not ') . "ok 2\n"; +my $i = gethostbyaddr(inet_aton("127.0.0.1")); +print +(!defined $i ? 'not ' : '') . "ok 3\n"; + +print "not " if inet_ntoa($h->addr) ne "127.0.0.1"; +print "ok 4\n"; + +print "not " if inet_ntoa($i->addr) ne "127.0.0.1"; +print "ok 5\n"; + +# need to skip the name comparisons on Win32 because windows will +# return the name of the machine instead of "localhost" when resolving +# 127.0.0.1 or even "localhost" + +# VMS returns "LOCALHOST" under tcp/ip services V4.1 ECO 2, possibly others +# OS/390 returns localhost.YADDA.YADDA + - if ($^O eq 'MSWin32' or $^O eq 'cygwin') { ++if ($^O eq 'MSWin32' or $^O eq 'NetWare' or $^O eq 'cygwin') { + print "ok $_ # skipped on win32\n" for (6,7); +} else { + my $in_alias; + unless ($h->name =~ /^localhost(?:\..+)?$/i) { + foreach (@{$h->aliases}) { + if (/^localhost(?:\..+)?$/i) { + $in_alias = 1; + last; + } + } + print "not " unless $in_alias; + } # Else we found it as the hostname + print "ok 6 # ",$h->name, " ", join (",", @{$h->aliases}), "\n"; + + if ($in_alias) { + # If we found it in the aliases before, expect to find it there again. + foreach (@{$h->aliases}) { + if (/^localhost(?:\..+)?$/i) { + undef $in_alias; # This time, clear the flag if we see "localhost" + last; + } + } + print "not " if $in_alias; + } else { + print "not " unless $i->name =~ /^localhost(?:\..+)?$/i; + } + print "ok 7 # ",$h->name, " ", join (",", @{$h->aliases}), "\n"; +} diff --cc t/lib/odbm.t index b935d04,0000000..a43e70b mode 100755,000000..100755 --- a/t/lib/odbm.t +++ b/t/lib/odbm.t @@@ -1,437 -1,0 +1,437 @@@ +#!./perl + +# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bODBM_File\b/) { + print "1..0 # Skip: ODBM_File was not built\n"; + exit 0; + } +} + +use strict; +use warnings; + +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; +} + +require ODBM_File; +#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT +use Fcntl; + +print "1..66\n"; + +unlink ; + +umask(0); +my %h; +ok(1, tie(%h,'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)); + +my $Dfile = "Op.dbmx.pag"; +if (! -e $Dfile) { + ($Dfile) = ; +} - if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32') { ++if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare') { + print "ok 2 # Skipped: different file permission semantics\n"; +} +else { + my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); + print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); +} +my $i = 0; +while (my ($key,$value) = each(%h)) { + $i++; +} +print (!$i ? "ok 3\n" : "not ok 3\n"); + +$h{'goner1'} = 'snork'; + +$h{'abc'} = 'ABC'; +$h{'def'} = 'DEF'; +$h{'jkl','mno'} = "JKL\034MNO"; +$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); +$h{'a'} = 'A'; +$h{'b'} = 'B'; +$h{'c'} = 'C'; +$h{'d'} = 'D'; +$h{'e'} = 'E'; +$h{'f'} = 'F'; +$h{'g'} = 'G'; +$h{'h'} = 'H'; +$h{'i'} = 'I'; + +$h{'goner2'} = 'snork'; +delete $h{'goner2'}; + +untie(%h); +print (tie(%h,'ODBM_File','Op.dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); + +$h{'j'} = 'J'; +$h{'k'} = 'K'; +$h{'l'} = 'L'; +$h{'m'} = 'M'; +$h{'n'} = 'N'; +$h{'o'} = 'O'; +$h{'p'} = 'P'; +$h{'q'} = 'Q'; +$h{'r'} = 'R'; +$h{'s'} = 'S'; +$h{'t'} = 'T'; +$h{'u'} = 'U'; +$h{'v'} = 'V'; +$h{'w'} = 'W'; +$h{'x'} = 'X'; +$h{'y'} = 'Y'; +$h{'z'} = 'Z'; + +$h{'goner3'} = 'snork'; + +delete $h{'goner1'}; +delete $h{'goner3'}; + +my @keys = keys(%h); +my @values = values(%h); + +if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} + +while (my ($key,$value) = each(%h)) { + if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { + $key =~ y/a-z/A-Z/; + $i++ if $key eq $value; + } +} + +if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";} + +@keys = ('blurfl', keys(%h), 'dyick'); +if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";} + +$h{'foo'} = ''; +$h{''} = 'bar'; + +# check cache overflow and numeric keys and contents +my $ok = 1; +for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } +for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } +print ($ok ? "ok 8\n" : "not ok 8\n"); + +my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); +print ($size > 0 ? "ok 9\n" : "not ok 9\n"); + +@h{0..200} = 200..400; +my @foo = @h{0..200}; +print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; + +print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); +print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); + +untie %h; +unlink 'Op.dbmx.dir', $Dfile; + +{ + # sub-class test + + package Another ; + + use strict ; + use warnings ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use strict ; + use warnings ; + use vars qw(@ISA @EXPORT) ; + + require Exporter ; + use ODBM_File; + @ISA=qw(ODBM_File); + @EXPORT = @ODBM_File::EXPORT ; + + sub STORE { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::STORE($key, $value * 2) ; + } + + sub FETCH { + my $self = shift ; + my $key = shift ; + $self->SUPER::FETCH($key) - 1 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; +EOM + + close FILE ; + + BEGIN { push @INC, '.'; } + + eval 'use SubDB ; use Fcntl ;'; + main::ok(13, $@ eq "") ; + my %h ; + my $X ; + eval ' + $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640 ); + ' ; + + main::ok(14, $@ eq "") ; + + my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; + main::ok(15, $@ eq "") ; + main::ok(16, $ret == 5) ; + + $ret = eval '$X->A_new_method("fred") ' ; + main::ok(17, $@ eq "") ; + main::ok(18, $ret eq "[[5]]") ; + + undef $X; + untie(%h); + unlink "SubDB.pm", ; + +} + +{ + # DBM Filter tests + use strict ; + use warnings ; + my (%h, $db) ; + my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + + sub checkOutput + { + my($fk, $sk, $fv, $sv) = @_ ; + print "# ", join('|', $fetch_key, $fk, $store_key, $sk, + $fetch_value, $fv, $store_value, $sv, $_), "\n"; + return + $fetch_key eq $fk && $store_key eq $sk && + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; + } + + unlink ; + 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 ; +} + +{ + # DBM Filter with a closure + + use strict ; + use warnings ; + my (%h, $db) ; + + unlink ; + ok(40, $db = tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ; + + my %result = () ; + + sub Closure + { + my ($name) = @_ ; + my $count = 0 ; + my @kept = () ; + + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } + } + + $db->filter_store_key(Closure("store key")) ; + $db->filter_store_value(Closure("store value")) ; + $db->filter_fetch_key(Closure("fetch key")) ; + $db->filter_fetch_value(Closure("fetch value")) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + ok(41, $result{"store key"} eq "store key - 1: [fred]"); + ok(42, $result{"store value"} eq "store value - 1: [joe]"); + ok(43, !defined $result{"fetch key"} ); + ok(44, !defined $result{"fetch value"} ); + ok(45, $_ eq "original") ; + + ok(46, $db->FIRSTKEY() eq "fred") ; + ok(47, $result{"store key"} eq "store key - 1: [fred]"); + ok(48, $result{"store value"} eq "store value - 1: [joe]"); + ok(49, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(50, ! defined $result{"fetch value"} ); + ok(51, $_ eq "original") ; + + $h{"jim"} = "john" ; + ok(52, $result{"store key"} eq "store key - 2: [fred jim]"); + ok(53, $result{"store value"} eq "store value - 2: [joe john]"); + ok(54, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(55, ! defined $result{"fetch value"} ); + ok(56, $_ eq "original") ; + + ok(57, $h{"fred"} eq "joe"); + ok(58, $result{"store key"} eq "store key - 3: [fred jim fred]"); + ok(59, $result{"store value"} eq "store value - 2: [joe john]"); + ok(60, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(61, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(62, $_ eq "original") ; + + undef $db ; + untie %h; + unlink ; +} + +{ + # DBM Filter recursion detection + use strict ; + use warnings ; + my (%h, $db) ; + unlink ; + + 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 ; +} + +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use ODBM_File ; + + unlink ; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + ok(65, tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ; + $h{ABC} = undef; + ok(66, $a eq "") ; + untie %h; + unlink ; +} + +if ($^O eq 'hpux') { + print <autoflush; +STDERR->autoflush; + +print "1..7\n"; + +ok 1, $pid = open2 'READ', 'WRITE', $perl, '-e', + cmd_line('print scalar '); +ok 2, print WRITE "hi kid\n"; +ok 3, =~ /^hi kid\r?\n$/; +ok 4, close(WRITE), $!; +ok 5, close(READ), $!; +$reaped_pid = waitpid $pid, 0; +ok 6, $reaped_pid == $pid, $reaped_pid; +ok 7, $? == 0, $?; diff --cc t/lib/open3.t index a0da34f,0000000..7d2d411 mode 100755,000000..100755 --- a/t/lib/open3.t +++ b/t/lib/open3.t @@@ -1,150 -1,0 +1,150 @@@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if (!$Config{'d_fork'} + # open2/3 supported on win32 (but not Borland due to CRT bugs) - && ($^O ne 'MSWin32' || $Config{'cc'} =~ /^bcc/i)) ++ && (($^O ne 'MSWin32' && $^O ne 'NetWare') || $Config{'cc'} =~ /^bcc/i)) + { + print "1..0\n"; + exit 0; + } + # make warnings fatal + $SIG{__WARN__} = sub { die @_ }; +} + +use strict; +use IO::Handle; +use IPC::Open3; +#require 'open3.pl'; use subs 'open3'; + +my $perl = $^X; + +sub ok { + my ($n, $result, $info) = @_; + if ($result) { + print "ok $n\n"; + } + else { + print "not ok $n\n"; + print "# $info\n" if $info; + } +} + +sub cmd_line { - if ($^O eq 'MSWin32') { ++ if ($^O eq 'MSWin32' || $^O eq 'NetWare') { + my $cmd = shift; + $cmd =~ tr/\r\n//d; + $cmd =~ s/"/\\"/g; + return qq/"$cmd"/; + } + else { + return $_[0]; + } +} + +my ($pid, $reaped_pid); +STDOUT->autoflush; +STDERR->autoflush; + +print "1..22\n"; + +# basic +ok 1, $pid = open3 'WRITE', 'READ', 'ERROR', $perl, '-e', cmd_line(<<'EOF'); + $| = 1; + print scalar ; + print STDERR "hi error\n"; +EOF +ok 2, print WRITE "hi kid\n"; +ok 3, =~ /^hi kid\r?\n$/; +ok 4, =~ /^hi error\r?\n$/; +ok 5, close(WRITE), $!; +ok 6, close(READ), $!; +ok 7, close(ERROR), $!; +$reaped_pid = waitpid $pid, 0; +ok 8, $reaped_pid == $pid, $reaped_pid; +ok 9, $? == 0, $?; + +# read and error together, both named +$pid = open3 'WRITE', 'READ', 'READ', $perl, '-e', cmd_line(<<'EOF'); + $| = 1; + print scalar ; + print STDERR scalar ; +EOF +print WRITE "ok 10\n"; +print scalar ; +print WRITE "ok 11\n"; +print scalar ; +waitpid $pid, 0; + +# read and error together, error empty +$pid = open3 'WRITE', 'READ', '', $perl, '-e', cmd_line(<<'EOF'); + $| = 1; + print scalar ; + print STDERR scalar ; +EOF +print WRITE "ok 12\n"; +print scalar ; +print WRITE "ok 13\n"; +print scalar ; +waitpid $pid, 0; + +# dup writer +ok 14, pipe PIPE_READ, PIPE_WRITE; +$pid = open3 '<&PIPE_READ', 'READ', '', + $perl, '-e', cmd_line('print scalar '); +close PIPE_READ; +print PIPE_WRITE "ok 15\n"; +close PIPE_WRITE; +print scalar ; +waitpid $pid, 0; + +# dup reader +$pid = open3 'WRITE', '>&STDOUT', 'ERROR', + $perl, '-e', cmd_line('print scalar '); +print WRITE "ok 16\n"; +waitpid $pid, 0; + +# dup error: This particular case, duping stderr onto the existing +# stdout but putting stdout somewhere else, is a good case because it +# used not to work. +$pid = open3 'WRITE', 'READ', '>&STDOUT', + $perl, '-e', cmd_line('print STDERR scalar '); +print WRITE "ok 17\n"; +waitpid $pid, 0; + +# dup reader and error together, both named +$pid = open3 'WRITE', '>&STDOUT', '>&STDOUT', $perl, '-e', cmd_line(<<'EOF'); + $| = 1; + print STDOUT scalar ; + print STDERR scalar ; +EOF +print WRITE "ok 18\n"; +print WRITE "ok 19\n"; +waitpid $pid, 0; + +# dup reader and error together, error empty +$pid = open3 'WRITE', '>&STDOUT', '', $perl, '-e', cmd_line(<<'EOF'); + $| = 1; + print STDOUT scalar ; + print STDERR scalar ; +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())'; +$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 --cc t/lib/posix.t index 33ab944,0000000..09bd88c mode 100755,000000..100755 --- a/t/lib/posix.t +++ b/t/lib/posix.t @@@ -1,138 -1,0 +1,139 @@@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if ($^O ne 'VMS' and $Config{'extensions'} !~ /\bPOSIX\b/) { + print "1..0\n"; + exit 0; + } +} + +use POSIX qw(fcntl_h signal_h limits_h _exit getcwd open read strftime write); +use strict subs; + +$| = 1; +print "1..27\n"; + +$Is_W32 = $^O eq 'MSWin32'; ++$Is_NetWare = $^O eq 'NetWare'; +$Is_Dos = $^O eq 'dos'; + +$testfd = open("TEST", O_RDONLY, 0) and print "ok 1\n"; +read($testfd, $buffer, 9) if $testfd > 2; +print $buffer eq "#!./perl\n" ? "ok 2\n" : "not ok 2\n"; + +write(1,"ok 3\nnot ok 3\n", 5); + +if ($Is_Dos) { + for (4..5) { + print "ok $_ # skipped, no pipe() support on dos\n"; + } +} else { +@fds = POSIX::pipe(); +print $fds[0] > $testfd ? "ok 4\n" : "not ok 4\n"; +CORE::open($reader = \*READER, "<&=".$fds[0]); +CORE::open($writer = \*WRITER, ">&=".$fds[1]); +print $writer "ok 5\n"; +close $writer; +print <$reader>; +close $reader; +} + +if ($Is_W32 || $Is_Dos) { + for (6..11) { + print "ok $_ # skipped, no sigaction support on win32/dos\n"; + } +} +else { +$sigset = new POSIX::SigSet 1,3; +delset $sigset 1; +if (!ismember $sigset 1) { print "ok 6\n" } +if (ismember $sigset 3) { print "ok 7\n" } +$mask = new POSIX::SigSet &SIGINT; +$action = new POSIX::SigAction 'main::SigHUP', $mask, 0; +sigaction(&SIGHUP, $action); +$SIG{'INT'} = 'SigINT'; +kill 'HUP', $$; +sleep 1; +print "ok 11\n"; + +sub SigHUP { + print "ok 8\n"; + kill 'INT', $$; + sleep 2; + print "ok 9\n"; +} + +sub SigINT { + print "ok 10\n"; +} +} + +print &_POSIX_OPEN_MAX > $fds[1] ? "ok 12\n" : "not ok 12\n"; + +print getcwd() =~ m#/t$# ? "ok 13\n" : "not ok 13\n"; + +# Check string conversion functions. + +if ($Config{d_strtod}) { + $lc = &POSIX::setlocale(&POSIX::LC_NUMERIC, 'C') if $Config{d_setlocale}; + ($n, $x) = &POSIX::strtod('3.14159_OR_SO'); +# Using long double NVs may introduce greater accuracy than wanted. + $n =~ s/^3.1415(8999|9000)\d*$/3.14159/ + if $Config{uselongdouble} eq 'define'; + print (($n == 3.14159) && ($x == 6) ? + "ok 14\n" : "not ok 14\n"); + &POSIX::setlocale(&POSIX::LC_NUMERIC, $lc) if $Config{d_setlocale}; +} else { print "# strtod not present\n", "ok 14\n"; } + +if ($Config{d_strtol}) { + ($n, $x) = &POSIX::strtol('21_PENGUINS'); + print (($n == 21) && ($x == 9) ? "ok 15\n" : "not ok 15\n"); +} else { print "# strtol not present\n", "ok 15\n"; } + +if ($Config{d_strtoul}) { + ($n, $x) = &POSIX::strtoul('88_TEARS'); + print (($n == 88) && ($x == 6) ? "ok 16\n" : "not ok 16\n"); +} else { print "# strtoul not present\n", "ok 16\n"; } + +# Pick up whether we're really able to dynamically load everything. +print &POSIX::acos(1.0) == 0.0 ? "ok 17\n" : "not ok 17\n"; + +# This can coredump if struct tm has a timezone field and we +# didn't detect it. If this fails, try adding +# -DSTRUCT_TM_HASZONE to your cflags when compiling ext/POSIX/POSIX.c. +# See ext/POSIX/hints/sunos_4.pl and ext/POSIX/hints/linux.pl +print POSIX::strftime("ok 18 # %H:%M, on %D\n", localtime()); + +# If that worked, validate the mini_mktime() routine's normalisation of +# input fields to strftime(). +sub try_strftime { + my $num = shift; + my $expect = shift; + my $got = POSIX::strftime("%a %b %d %H:%M:%S %Y %j", @_); + if ($got eq $expect) { + print "ok $num\n"; + } + else { + print "# expected: $expect\n# got: $got\nnot ok $num\n"; + } +} + +$lc = &POSIX::setlocale(&POSIX::LC_TIME, 'C') if $Config{d_setlocale}; +try_strftime(19, "Wed Feb 28 00:00:00 1996 059", 0,0,0, 28,1,96); +try_strftime(20, "Thu Feb 29 00:00:60 1996 060", 60,0,-24, 30,1,96); +try_strftime(21, "Fri Mar 01 00:00:00 1996 061", 0,0,-24, 31,1,96); +try_strftime(22, "Sun Feb 28 00:00:00 1999 059", 0,0,0, 28,1,99); +try_strftime(23, "Mon Mar 01 00:00:00 1999 060", 0,0,24, 28,1,99); +try_strftime(24, "Mon Feb 28 00:00:00 2000 059", 0,0,0, 28,1,100); +try_strftime(25, "Tue Feb 29 00:00:00 2000 060", 0,0,0, 0,2,100); +try_strftime(26, "Wed Mar 01 00:00:00 2000 061", 0,0,0, 1,2,100); +try_strftime(27, "Fri Mar 31 00:00:00 2000 091", 0,0,0, 31,2,100); +&POSIX::setlocale(&POSIX::LC_TIME, $lc) if $Config{d_setlocale}; + +$| = 0; +# The following line assumes buffered output, which may be not true with EMX: +print '@#!*$@(!@#$' unless ($^O eq 'os2' || $^O eq 'uwin' || $^O eq 'os390'); +_exit(0); diff --cc t/lib/sdbm.t index 3221ca4,0000000..57928e0 mode 100755,000000..100755 --- a/t/lib/sdbm.t +++ b/t/lib/sdbm.t @@@ -1,429 -1,0 +1,429 @@@ +#!./perl + +# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if (($Config{'extensions'} !~ /\bSDBM_File\b/) && ($^O ne 'VMS')){ + print "1..0\n"; + exit 0; + } +} + +use strict; +use warnings; + +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; +} + +require SDBM_File; +#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT +use Fcntl; + +print "1..68\n"; + +unlink ; + +umask(0); +my %h ; +ok(1, tie %h,'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640); + +my $Dfile = "Op_dbmx.pag"; +if (! -e $Dfile) { + ($Dfile) = ; +} - if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos') { ++if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'dos') { + print "ok 2 # Skipped: different file permission semantics\n"; +} +else { + my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); + print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); +} +my $i = 0; +while (my ($key,$value) = each(%h)) { + $i++; +} +print (!$i ? "ok 3\n" : "not ok 3\n"); + +$h{'goner1'} = 'snork'; + +$h{'abc'} = 'ABC'; +$h{'def'} = 'DEF'; +$h{'jkl','mno'} = "JKL\034MNO"; +$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); +$h{'a'} = 'A'; +$h{'b'} = 'B'; +$h{'c'} = 'C'; +$h{'d'} = 'D'; +$h{'e'} = 'E'; +$h{'f'} = 'F'; +$h{'g'} = 'G'; +$h{'h'} = 'H'; +$h{'i'} = 'I'; + +$h{'goner2'} = 'snork'; +delete $h{'goner2'}; + +untie(%h); +print (tie(%h,'SDBM_File','Op_dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); + +$h{'j'} = 'J'; +$h{'k'} = 'K'; +$h{'l'} = 'L'; +$h{'m'} = 'M'; +$h{'n'} = 'N'; +$h{'o'} = 'O'; +$h{'p'} = 'P'; +$h{'q'} = 'Q'; +$h{'r'} = 'R'; +$h{'s'} = 'S'; +$h{'t'} = 'T'; +$h{'u'} = 'U'; +$h{'v'} = 'V'; +$h{'w'} = 'W'; +$h{'x'} = 'X'; +$h{'y'} = 'Y'; +$h{'z'} = 'Z'; + +$h{'goner3'} = 'snork'; + +delete $h{'goner1'}; +delete $h{'goner3'}; + +my @keys = keys(%h); +my @values = values(%h); + +if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} + +while (my ($key,$value) = each(%h)) { + if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { + $key =~ y/a-z/A-Z/; + $i++ if $key eq $value; + } +} + +if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";} + +@keys = ('blurfl', keys(%h), 'dyick'); +if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";} + +$h{'foo'} = ''; +$h{''} = 'bar'; + +# check cache overflow and numeric keys and contents +my $ok = 1; +for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } +for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } +print ($ok ? "ok 8\n" : "not ok 8\n"); + +my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); +print ($size > 0 ? "ok 9\n" : "not ok 9\n"); + +@h{0..200} = 200..400; +my @foo = @h{0..200}; +print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; + +print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); +print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); + + +{ + # sub-class test + + package Another ; + + use strict ; + use warnings ; + + open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; + print FILE <<'EOM' ; + + package SubDB ; + + use strict ; + use warnings ; + use vars qw( @ISA @EXPORT) ; + + require Exporter ; + use SDBM_File; + @ISA=qw(SDBM_File); + @EXPORT = @SDBM_File::EXPORT if defined @SDBM_File::EXPORT ; + + sub STORE { + my $self = shift ; + my $key = shift ; + my $value = shift ; + $self->SUPER::STORE($key, $value * 2) ; + } + + sub FETCH { + my $self = shift ; + my $key = shift ; + $self->SUPER::FETCH($key) - 1 ; + } + + sub A_new_method + { + my $self = shift ; + my $key = shift ; + my $value = $self->FETCH($key) ; + return "[[$value]]" ; + } + + 1 ; +EOM + + close FILE ; + + BEGIN { push @INC, '.'; } + + eval 'use SubDB ; use Fcntl ;'; + main::ok(13, $@ eq "") ; + my %h ; + my $X ; + eval ' + $X = tie(%h, "SubDB","dbhash_tmp", O_RDWR|O_CREAT, 0640 ); + ' ; + + main::ok(14, $@ eq "") ; + + my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; + main::ok(15, $@ eq "") ; + main::ok(16, $ret == 5) ; + + $ret = eval '$X->A_new_method("fred") ' ; + main::ok(17, $@ eq "") ; + main::ok(18, $ret eq "[[5]]") ; + + undef $X; + untie(%h); + unlink "SubDB.pm", ; + +} + +ok(19, !exists $h{'goner1'}); +ok(20, exists $h{'foo'}); + +untie %h; +unlink , $Dfile; + +{ + # DBM Filter tests + use strict ; + use warnings ; + my (%h, $db) ; + my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; + + sub checkOutput + { + my($fk, $sk, $fv, $sv) = @_ ; + return + $fetch_key eq $fk && $store_key eq $sk && + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; + } + + unlink ; + 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 ; +} + +{ + # DBM Filter with a closure + + use strict ; + use warnings ; + my (%h, $db) ; + + unlink ; + ok(42, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ; + + my %result = () ; + + sub Closure + { + my ($name) = @_ ; + my $count = 0 ; + my @kept = () ; + + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } + } + + $db->filter_store_key(Closure("store key")) ; + $db->filter_store_value(Closure("store value")) ; + $db->filter_fetch_key(Closure("fetch key")) ; + $db->filter_fetch_value(Closure("fetch value")) ; + + $_ = "original" ; + + $h{"fred"} = "joe" ; + ok(43, $result{"store key"} eq "store key - 1: [fred]"); + ok(44, $result{"store value"} eq "store value - 1: [joe]"); + ok(45, !defined $result{"fetch key"} ); + ok(46, !defined $result{"fetch value"} ); + ok(47, $_ eq "original") ; + + ok(48, $db->FIRSTKEY() eq "fred") ; + ok(49, $result{"store key"} eq "store key - 1: [fred]"); + ok(50, $result{"store value"} eq "store value - 1: [joe]"); + ok(51, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(52, ! defined $result{"fetch value"} ); + ok(53, $_ eq "original") ; + + $h{"jim"} = "john" ; + ok(54, $result{"store key"} eq "store key - 2: [fred jim]"); + ok(55, $result{"store value"} eq "store value - 2: [joe john]"); + ok(56, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(57, ! defined $result{"fetch value"} ); + ok(58, $_ eq "original") ; + + ok(59, $h{"fred"} eq "joe"); + ok(60, $result{"store key"} eq "store key - 3: [fred jim fred]"); + ok(61, $result{"store value"} eq "store value - 2: [joe john]"); + ok(62, $result{"fetch key"} eq "fetch key - 1: [fred]"); + ok(63, $result{"fetch value"} eq "fetch value - 1: [joe]"); + ok(64, $_ eq "original") ; + + undef $db ; + untie %h; + unlink ; +} + +{ + # DBM Filter recursion detection + use strict ; + use warnings ; + my (%h, $db) ; + unlink ; + + 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 ; +} + +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use SDBM_File ; + + unlink ; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + ok(67, tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ; + $h{ABC} = undef; + ok(68, $a eq "") ; + + untie %h; + unlink ; +} diff --cc t/lib/sigaction.t index 1815b19,0000000..c38b122 mode 100644,000000..100644 --- a/t/lib/sigaction.t +++ b/t/lib/sigaction.t @@@ -1,127 -1,0 +1,127 @@@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +BEGIN{ + # Don't do anything if POSIX is missing, or sigaction missing. + eval { use POSIX; }; - if($@ || $^O eq 'MSWin32') { ++ if($@ || $^O eq 'MSWin32' || $^O eq 'NetWare') { + print "1..0\n"; + exit 0; + } +} + +use strict; +use vars qw/$bad7 $ok10 $bad18 $ok/; + +$^W=1; + +print "1..18\n"; + +sub IGNORE { + $bad7=1; +} + +sub DEFAULT { + $bad18=1; +} + +sub foo { + $ok=1; +} + +my $newaction=POSIX::SigAction->new('::foo', new POSIX::SigSet(SIGUSR1), 0); +my $oldaction=POSIX::SigAction->new('::bar', new POSIX::SigSet(), 0); + +{ + my $bad; + local($SIG{__WARN__})=sub { $bad=1; }; + sigaction(SIGHUP, $newaction, $oldaction); + if($bad) { print "not ok 1\n" } else { print "ok 1\n"} +} + +if($oldaction->{HANDLER} eq 'DEFAULT' || + $oldaction->{HANDLER} eq 'IGNORE') + { print "ok 2\n" } else { print "not ok 2 # ", $oldaction->{HANDLER}, "\n"} +print $SIG{HUP} eq '::foo' ? "ok 3\n" : "not ok 3\n"; + +sigaction(SIGHUP, $newaction, $oldaction); +if($oldaction->{HANDLER} eq '::foo') + { print "ok 4\n" } else { print "not ok 4\n"} +if($oldaction->{MASK}->ismember(SIGUSR1)) + { print "ok 5\n" } else { print "not ok 5\n"} +if($oldaction->{FLAGS}) { + if ($^O eq 'linux') { + print "ok 6 # Skip: sigaction() broken in $^O\n"; + } else { + print "not ok 6\n"; + } +} else { + print "ok 6\n"; +} + +$newaction=POSIX::SigAction->new('IGNORE'); +sigaction(SIGHUP, $newaction); +kill 'HUP', $$; +print $bad7 ? "not ok 7\n" : "ok 7\n"; + +print $SIG{HUP} eq 'IGNORE' ? "ok 8\n" : "not ok 8\n"; +sigaction(SIGHUP, POSIX::SigAction->new('DEFAULT')); +print $SIG{HUP} eq 'DEFAULT' ? "ok 9\n" : "not ok 9\n"; + +$newaction=POSIX::SigAction->new(sub { $ok10=1; }); +sigaction(SIGHUP, $newaction); +{ + local($^W)=0; + kill 'HUP', $$; +} +print $ok10 ? "ok 10\n" : "not ok 10\n"; + +print ref($SIG{HUP}) eq 'CODE' ? "ok 11\n" : "not ok 11\n"; + +sigaction(SIGHUP, POSIX::SigAction->new('::foo')); +# Make sure the signal mask gets restored after sigaction croak()s. +eval { + my $act=POSIX::SigAction->new('::foo'); + delete $act->{HANDLER}; + sigaction(SIGINT, $act); +}; +kill 'HUP', $$; +print $ok ? "ok 12\n" : "not ok 12\n"; + +undef $ok; +# Make sure the signal mask gets restored after sigaction returns early. +my $x=defined sigaction(SIGKILL, $newaction, $oldaction); +kill 'HUP', $$; +print !$x && $ok ? "ok 13\n" : "not ok 13\n"; + +$SIG{HUP}=sub {}; +sigaction(SIGHUP, $newaction, $oldaction); +print ref($oldaction->{HANDLER}) eq 'CODE' ? "ok 14\n" : "not ok 14\n"; + +eval { + sigaction(SIGHUP, undef, $oldaction); +}; +print $@ ? "not ok 15\n" : "ok 15\n"; + +eval { + sigaction(SIGHUP, 0, $oldaction); +}; +print $@ ? "not ok 16\n" : "ok 16\n"; + +eval { + sigaction(SIGHUP, bless({},'Class'), $oldaction); +}; +print $@ ? "ok 17\n" : "not ok 17\n"; + +$newaction=POSIX::SigAction->new(sub { $ok10=1; }); +sigaction(SIGCONT, POSIX::SigAction->new('DEFAULT')); +{ + local($^W)=0; + kill 'CONT', $$; +} +print $bad18 ? "not ok 18\n" : "ok 18\n"; + diff --cc t/lib/syslfs.t index 6a5d9b7,0000000..8d9769f mode 100644,000000..100644 --- a/t/lib/syslfs.t +++ b/t/lib/syslfs.t @@@ -1,267 -1,0 +1,267 @@@ +# NOTE: this file tests how large files (>2GB) work with raw system IO. +# stdio: open(), tell(), seek(), print(), read() is tested in t/op/lfs.t. +# If you modify/add tests here, remember to update also t/op/lfs.t. + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + # Don't bother if there are no quad offsets. + if ($Config{lseeksize} < 8) { + print "1..0 # Skip: no 64-bit file offsets\n"; + exit(0); + } + require Fcntl; import Fcntl qw(/^O_/ /^SEEK_/); +} + +use strict; + +$| = 1; + +our @s; +our $fail; + +sub zap { + close(BIG); + unlink("big"); + unlink("big1"); + unlink("big2"); +} + +sub bye { + zap(); + exit(0); +} + +my $explained; + +sub explain { + unless ($explained++) { + print <new( + tick => qq{"}, + quoteHighBit => 0, + unctrl => "quote" + ); +sub debug { + return unless $debug; + my($mess) = join "", @_; + chop $mess; + print $dumper->stringify($mess,1), "\n"; +} + +sub debugf { + printf @_ if $debug; +} + +my $have_setlocale = 0; +eval { + require POSIX; + import POSIX ':locale_h'; + $have_setlocale++; +}; + +# Visual C's CRT goes silly on strings of the form "en_US.ISO8859-1" +# and mingw32 uses said silly CRT - $have_setlocale = 0 if $^O eq 'MSWin32' && $Config{cc} =~ /^(cl|gcc)/i; ++$have_setlocale = 0 if (($^O eq 'MSWin32' || $^O eq 'NetWare') && $Config{cc} =~ /^(cl|gcc)/i); + +my $last = $have_setlocale ? &last : &last_without_setlocale; + +print "1..$last\n"; + +use vars qw(&LC_ALL); + +$a = 'abc %'; + +sub ok { + my ($n, $result) = @_; + + print 'not ' unless ($result); + print "ok $n\n"; +} + +# First we'll do a lot of taint checking for locales. +# This is the easiest to test, actually, as any locale, +# even the default locale will taint under 'use locale'. + +sub is_tainted { # hello, camel two. + no warnings 'uninitialized' ; + my $dummy; + not eval { $dummy = join("", @_), kill 0; 1 } +} + +sub check_taint ($$) { + ok $_[0], is_tainted($_[1]); +} + +sub check_taint_not ($$) { + ok $_[0], not is_tainted($_[1]); +} + +use locale; # engage locale and therefore locale taint. + +check_taint_not 1, $a; + +check_taint 2, uc($a); +check_taint 3, "\U$a"; +check_taint 4, ucfirst($a); +check_taint 5, "\u$a"; +check_taint 6, lc($a); +check_taint 7, "\L$a"; +check_taint 8, lcfirst($a); +check_taint 9, "\l$a"; + +check_taint_not 10, sprintf('%e', 123.456); +check_taint_not 11, sprintf('%f', 123.456); +check_taint_not 12, sprintf('%g', 123.456); +check_taint_not 13, sprintf('%d', 123.456); +check_taint_not 14, sprintf('%x', 123.456); + +$_ = $a; # untaint $_ + +$_ = uc($a); # taint $_ + +check_taint 15, $_; + +/(\w)/; # taint $&, $`, $', $+, $1. +check_taint 16, $&; +check_taint 17, $`; +check_taint 18, $'; +check_taint 19, $+; +check_taint 20, $1; +check_taint_not 21, $2; + +/(.)/; # untaint $&, $`, $', $+, $1. +check_taint_not 22, $&; +check_taint_not 23, $`; +check_taint_not 24, $'; +check_taint_not 25, $+; +check_taint_not 26, $1; +check_taint_not 27, $2; + +/(\W)/; # taint $&, $`, $', $+, $1. +check_taint 28, $&; +check_taint 29, $`; +check_taint 30, $'; +check_taint 31, $+; +check_taint 32, $1; +check_taint_not 33, $2; + +/(\s)/; # taint $&, $`, $', $+, $1. +check_taint 34, $&; +check_taint 35, $`; +check_taint 36, $'; +check_taint 37, $+; +check_taint 38, $1; +check_taint_not 39, $2; + +/(\S)/; # taint $&, $`, $', $+, $1. +check_taint 40, $&; +check_taint 41, $`; +check_taint 42, $'; +check_taint 43, $+; +check_taint 44, $1; +check_taint_not 45, $2; + +$_ = $a; # untaint $_ + +check_taint_not 46, $_; + +/(b)/; # this must not taint +check_taint_not 47, $&; +check_taint_not 48, $`; +check_taint_not 49, $'; +check_taint_not 50, $+; +check_taint_not 51, $1; +check_taint_not 52, $2; + +$_ = $a; # untaint $_ + +check_taint_not 53, $_; + +$b = uc($a); # taint $b +s/(.+)/$b/; # this must taint only the $_ + +check_taint 54, $_; +check_taint_not 55, $&; +check_taint_not 56, $`; +check_taint_not 57, $'; +check_taint_not 58, $+; +check_taint_not 59, $1; +check_taint_not 60, $2; + +$_ = $a; # untaint $_ + +s/(.+)/b/; # this must not taint +check_taint_not 61, $_; +check_taint_not 62, $&; +check_taint_not 63, $`; +check_taint_not 64, $'; +check_taint_not 65, $+; +check_taint_not 66, $1; +check_taint_not 67, $2; + +$b = $a; # untaint $b + +($b = $a) =~ s/\w/$&/; +check_taint 68, $b; # $b should be tainted. +check_taint_not 69, $a; # $a should be not. + +$_ = $a; # untaint $_ + +s/(\w)/\l$1/; # this must taint +check_taint 70, $_; +check_taint 71, $&; +check_taint 72, $`; +check_taint 73, $'; +check_taint 74, $+; +check_taint 75, $1; +check_taint_not 76, $2; + +$_ = $a; # untaint $_ + +s/(\w)/\L$1/; # this must taint +check_taint 77, $_; +check_taint 78, $&; +check_taint 79, $`; +check_taint 80, $'; +check_taint 81, $+; +check_taint 82, $1; +check_taint_not 83, $2; + +$_ = $a; # untaint $_ + +s/(\w)/\u$1/; # this must taint +check_taint 84, $_; +check_taint 85, $&; +check_taint 86, $`; +check_taint 87, $'; +check_taint 88, $+; +check_taint 89, $1; +check_taint_not 90, $2; + +$_ = $a; # untaint $_ + +s/(\w)/\U$1/; # this must taint +check_taint 91, $_; +check_taint 92, $&; +check_taint 93, $`; +check_taint 94, $'; +check_taint 95, $+; +check_taint 96, $1; +check_taint_not 97, $2; + +# After all this tainting $a should be cool. + +check_taint_not 98, $a; + +sub last_without_setlocale { 98 } + +# I think we've seen quite enough of taint. +# Let us do some *real* locale work now, +# unless setlocale() is missing (i.e. minitest). + +exit unless $have_setlocale; + +# Find locales. + +debug "# Scanning for locales...\n"; + +# Note that it's okay that some languages have their native names +# capitalized here even though that's not "right". They are lowercased +# anyway later during the scanning process (and besides, some clueless +# vendor might have them capitalized errorneously anyway). + +my $locales = </dev/null|")) { + while () { + chomp; + trylocale($_); + } + close(LOCALES); +} elsif ($^O eq 'VMS' && defined($ENV{'SYS$I18N_LOCALE'}) && -d 'SYS$I18N_LOCALE') { +# The SYS$I18N_LOCALE logical name search list was not present on +# VAX VMS V5.5-12, but was on AXP && VAX VMS V6.2 as well as later versions. + opendir(LOCALES, "SYS\$I18N_LOCALE:"); + while ($_ = readdir(LOCALES)) { + chomp; + trylocale($_); + } + close(LOCALES); +} else { + + # This is going to be slow. + + foreach my $locale (split(/\n/, $locales)) { + my ($locale_name, $language_codes, $country_codes, $encodings) = + split(/:/, $locale); + my @enc = decode_encodings($encodings); + foreach my $loc (split(/ /, $locale_name)) { + trylocale($loc); + foreach my $enc (@enc) { + trylocale("$loc.$enc"); + } + $loc = lc $loc; + foreach my $enc (@enc) { + trylocale("$loc.$enc"); + } + } + foreach my $lang (split(/ /, $language_codes)) { + trylocale($lang); + foreach my $country (split(/ /, $country_codes)) { + my $lc = "${lang}_${country}"; + trylocale($lc); + foreach my $enc (@enc) { + trylocale("$lc.$enc"); + } + my $lC = "${lang}_\U${country}"; + trylocale($lC); + foreach my $enc (@enc) { + trylocale("$lC.$enc"); + } + } + } + } +} + +setlocale(LC_ALL, "C"); + +sub utf8locale { $_[0] =~ /utf-?8/i } + +@Locale = sort @Locale; + +debug "# Locales = @Locale\n"; + +my %Problem; +my %Okay; +my %Testing; +my @Neoalpha; +my %Neoalpha; + +sub tryneoalpha { + my ($Locale, $i, $test) = @_; + unless ($test) { + $Problem{$i}{$Locale} = 1; + debug "# failed $i with locale '$Locale'\n"; + } else { + push @{$Okay{$i}}, $Locale; + } +} + +foreach $Locale (@Locale) { + debug "# Locale = $Locale\n"; + @Alnum_ = getalnum_(); + debug "# w = ", join("",@Alnum_), "\n"; + + unless (setlocale(LC_ALL, $Locale)) { + foreach (99..103) { + $Problem{$_}{$Locale} = -1; + } + next; + } + + # Sieve the uppercase and the lowercase. + + my %UPPER = (); + my %lower = (); + my %BoThCaSe = (); + for (@Alnum_) { + if (/[^\d_]/) { # skip digits and the _ + if (uc($_) eq $_) { + $UPPER{$_} = $_; + } + if (lc($_) eq $_) { + $lower{$_} = $_; + } + } + } + foreach (keys %UPPER) { + $BoThCaSe{$_}++ if exists $lower{$_}; + } + foreach (keys %lower) { + $BoThCaSe{$_}++ if exists $UPPER{$_}; + } + foreach (keys %BoThCaSe) { + delete $UPPER{$_}; + delete $lower{$_}; + } + + debug "# UPPER = ", join("", sort keys %UPPER ), "\n"; + debug "# lower = ", join("", sort keys %lower ), "\n"; + debug "# BoThCaSe = ", join("", sort keys %BoThCaSe), "\n"; + + # Find the alphabets that are not alphabets in the default locale. + + { + no locale; + + @Neoalpha = (); + for (keys %UPPER, keys %lower) { + push(@Neoalpha, $_) if (/\W/); + $Neoalpha{$_} = $_; + } + } + + @Neoalpha = sort @Neoalpha; + + debug "# Neoalpha = ", join("",@Neoalpha), "\n"; + + if (@Neoalpha == 0) { + # If we have no Neoalphas the remaining tests are no-ops. + debug "# no Neoalpha, skipping tests 99..102 for locale '$Locale'\n"; + foreach (99..102) { + push @{$Okay{$_}}, $Locale; + } + } else { + + # Test \w. + + if (utf8locale($Locale)) { + # utf8 and locales do not mix. + debug "# skipping UTF-8 locale '$Locale'\n"; + push @utf8locale, $Locale; + @utf8skip{99..102} = (); + } else { + my $word = join('', @Neoalpha); + + $word =~ /^(\w+)$/; + + tryneoalpha($Locale, 99, $1 eq $word); + } + # Cross-check the whole 8-bit character set. + + for (map { chr } 0..255) { + tryneoalpha($Locale, 100, + (/\w/ xor /\W/) || + (/\d/ xor /\D/) || + (/\s/ xor /\S/)); + } + + # Test for read-only scalars' locale vs non-locale comparisons. + + { + no locale; + $a = "qwerty"; + { + use locale; + tryneoalpha($Locale, 101, ($a cmp "qwerty") == 0); + } + } + + { + my ($from, $to, $lesser, $greater, + @test, %test, $test, $yes, $no, $sign); + + for (0..9) { + # Select a slice. + $from = int(($_*@Alnum_)/10); + $to = $from + int(@Alnum_/10); + $to = $#Alnum_ if ($to > $#Alnum_); + $lesser = join('', @Alnum_[$from..$to]); + # Select a slice one character on. + $from++; $to++; + $to = $#Alnum_ if ($to > $#Alnum_); + $greater = join('', @Alnum_[$from..$to]); + ($yes, $no, $sign) = ($lesser lt $greater + ? (" ", "not ", 1) + : ("not ", " ", -1)); + # all these tests should FAIL (return 0). + # Exact lt or gt cannot be tested because + # in some locales, say, eacute and E may test equal. + @test = + ( + $no.' ($lesser le $greater)', # 1 + 'not ($lesser ne $greater)', # 2 + ' ($lesser eq $greater)', # 3 + $yes.' ($lesser ge $greater)', # 4 + $yes.' ($lesser ge $greater)', # 5 + $yes.' ($greater le $lesser )', # 7 + 'not ($greater ne $lesser )', # 8 + ' ($greater eq $lesser )', # 9 + $no.' ($greater ge $lesser )', # 10 + 'not (($lesser cmp $greater) == -($sign))' # 11 + ); + @test{@test} = 0 x @test; + $test = 0; + for my $ti (@test) { + $test{$ti} = eval $ti; + $test ||= $test{$ti} + } + tryneoalpha($Locale, 102, $test == 0); + if ($test) { + debug "# lesser = '$lesser'\n"; + debug "# greater = '$greater'\n"; + debug "# lesser cmp greater = ", + $lesser cmp $greater, "\n"; + debug "# greater cmp lesser = ", + $greater cmp $lesser, "\n"; + debug "# (greater) from = $from, to = $to\n"; + for my $ti (@test) { + debugf("# %-40s %-4s", $ti, + $test{$ti} ? 'FAIL' : 'ok'); + if ($ti =~ /\(\.*(\$.+ +cmp +\$[^\)]+)\.*\)/) { + debugf("(%s == %4d)", $1, eval $1); + } + debug "\n#"; + } + + last; + } + } + } + } + + use locale; + + my ($x, $y) = (1.23, 1.23); + + $a = "$x"; + printf ''; # printf used to reset locale to "C" + $b = "$y"; + + debug "# 103..107: a = $a, b = $b, Locale = $Locale\n"; + + tryneoalpha($Locale, 103, $a eq $b); + + my $c = "$x"; + my $z = sprintf ''; # sprintf used to reset locale to "C" + my $d = "$y"; + + debug "# 104..107: c = $c, d = $d, Locale = $Locale\n"; + + tryneoalpha($Locale, 104, $c eq $d); + + { + use warnings; + my $w = 0; + local $SIG{__WARN__} = + sub { + print "# @_\n"; + $w++; + }; + + # The == (among other ops) used to warn for locales + # that had something else than "." as the radix character. + + tryneoalpha($Locale, 105, $c == 1.23); + + tryneoalpha($Locale, 106, $c == $x); + + tryneoalpha($Locale, 107, $c == $d); + + { +# no locale; # XXX did this ever work correctly? + + my $e = "$x"; + + debug "# 108..110: e = $e, Locale = $Locale\n"; + + tryneoalpha($Locale, 108, $e == 1.23); + + tryneoalpha($Locale, 109, $e == $x); + + tryneoalpha($Locale, 110, $e == $c); + } + + my $f = "1.23"; + my $g = 2.34; + + debug "# 111..115: f = $f, g = $g, locale = $Locale\n"; + + tryneoalpha($Locale, 111, $f == 1.23); + + tryneoalpha($Locale, 112, $f == $x); + + tryneoalpha($Locale, 113, $f == $c); + + tryneoalpha($Locale, 114, abs(($f + $g) - 3.57) < 0.01); + + tryneoalpha($Locale, 115, $w == 0); + } + + # Does taking lc separately differ from taking + # the lc "in-line"? (This was the bug 19990704.002, change #3568.) + # The bug was in the caching of the 'o'-magic. + { + use locale; + + sub lcA { + my $lc0 = lc $_[0]; + my $lc1 = lc $_[1]; + return $lc0 cmp $lc1; + } + + sub lcB { + return lc($_[0]) cmp lc($_[1]); + } + + my $x = "ab"; + my $y = "aa"; + my $z = "AB"; + + tryneoalpha($Locale, 116, + lcA($x, $y) == 1 && lcB($x, $y) == 1 || + lcA($x, $z) == 0 && lcB($x, $z) == 0); + } + + # Does lc of an UPPER (if different from the UPPER) match + # case-insensitively the UPPER, and does the UPPER match + # case-insensitively the lc of the UPPER. And vice versa. + { + if (utf8locale($Locale)) { + # utf8 and locales do not mix. + debug "# skipping UTF-8 locale '$Locale'\n"; + push @utf8locale, $Locale; + $utf8skip{117}++; + } else { + use locale; + use locale; + no utf8; # so that the native 8-bit characters work + + my @f = (); + foreach my $x (keys %UPPER) { + my $y = lc $x; + next unless uc $y eq $x; + push @f, $x unless $x =~ /$y/i && $y =~ /$x/i; + } + foreach my $x (keys %lower) { + my $y = uc $x; + next unless lc $y eq $x; + push @f, $x unless $x =~ /$y/i && $y =~ /$x/i; + } + tryneoalpha($Locale, 117, @f == 0); + if (@f) { + print "# failed 117 locale '$Locale' characters @f\n" + } + } + } +} + +# Recount the errors. + +foreach (&last_without_setlocale()+1..$last) { + if ($Problem{$_} || !defined $Okay{$_} || !@{$Okay{$_}}) { + if ($_ == 102) { + print "# The failure of test 102 is not necessarily fatal.\n"; + print "# It usually indicates a problem in the enviroment,\n"; + print "# not in Perl itself.\n"; + } + print "not "; + } + print "ok $_\n"; +} + +# Give final advice. + +my $didwarn = 0; + +foreach (99..$last) { + if ($Problem{$_}) { + my @f = sort keys %{ $Problem{$_} }; + my $f = join(" ", @f); + $f =~ s/(.{50,60}) /$1\n#\t/g; + print + "#\n", + "# The locale ", (@f == 1 ? "definition" : "definitions"), "\n#\n", + "#\t", $f, "\n#\n", + "# on your system may have errors because the locale test $_\n", + "# failed in ", (@f == 1 ? "that locale" : "those locales"), + ".\n"; + print <$b} keys %utf8skip), "\n", + "# because UTF-8 and locales do not work together in Perl.\n#\n"; + } +} + +sub last { 117 } + +# eof diff --cc t/pragma/strict.t index bbfb8ab,0000000..8b9083f mode 100755,000000..100755 --- a/t/pragma/strict.t +++ b/t/pragma/strict.t @@@ -1,97 -1,0 +1,100 @@@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + $ENV{PERL5LIB} = '../lib'; +} + +$| = 1; + +my $Is_VMS = $^O eq 'VMS'; +my $Is_MSWin32 = $^O eq 'MSWin32'; ++my $Is_NetWare = $^O eq 'NetWare'; +my $tmpfile = "tmp0000"; +my $i = 0 ; +1 while -f ++$tmpfile; +END { if ($tmpfile) { 1 while unlink $tmpfile; } } + +my @prgs = () ; + +foreach (sort glob($^O eq 'MacOS' ? ":pragma:strict-*" : "pragma/strict-*")) { + + next if /(~|\.orig|,v)$/; + + open F, "<$_" or die "Cannot open $_: $!\n" ; + while () { + last if /^__END__/ ; + } + + { + local $/ = undef; + @prgs = (@prgs, split "\n########\n", ) ; + } + close F ; +} + +undef $/; + +print "1..", scalar @prgs, "\n"; + + +for (@prgs){ + my $switch = ""; + my @temps = () ; + if (s/^\s*-\w+//){ + $switch = $&; + } + my($prog,$expected) = split(/\nEXPECT\n/, $_); + if ( $prog =~ /--FILE--/) { + my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; + shift @files ; + die "Internal error test $i didn't split into pairs, got " . + scalar(@files) . "[" . join("%%%%", @files) ."]\n" + if @files % 2 ; + while (@files > 2) { + my $filename = shift @files ; + my $code = shift @files ; + $code =~ s|\./abc|:abc|g if $^O eq 'MacOS'; + push @temps, $filename ; + open F, ">$filename" or die "Cannot open $filename: $!\n" ; + print F $code ; + close F ; + } + shift @files ; + $prog = shift @files ; + $prog =~ s|\./abc|:abc|g if $^O eq 'MacOS'; + } + open TEST, ">$tmpfile"; + print TEST $prog,"\n"; + close TEST; + my $results = $Is_MSWin32 ? + `.\\perl -I../lib $switch $tmpfile 2>&1` : + $^O eq 'MacOS' ? + `$^X -I::lib $switch $tmpfile` : ++ $^O eq 'NetWare' ? ++ `perl -I../lib $switch $tmpfile 2>&1` : + `./perl $switch $tmpfile 2>&1`; + my $status = $?; + $results =~ s/\n+$//; + # allow expected output to be written as if $prog is on STDIN + $results =~ s/tmp\d+/-/g; + $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg + $expected =~ s/\n+$//; + $expected =~ s|(\./)?abc\.pm|:abc.pm|g if $^O eq 'MacOS'; + $expected =~ s|./abc|:abc|g if $^O eq 'MacOS'; + my $prefix = ($results =~ s/^PREFIX\n//) ; + if ( $results =~ s/^SKIPPED\n//) { + print "$results\n" ; + } + elsif (($prefix and $results !~ /^\Q$expected/) or + (!$prefix and $results ne $expected)){ + print STDERR "PROG: $switch\n$prog\n"; + print STDERR "EXPECTED:\n$expected\n"; + print STDERR "GOT:\n$results\n"; + print "not "; + } + print "ok ", ++$i, "\n"; + foreach (@temps) + { unlink $_ if $_ } +} diff --cc t/pragma/subs.t index 7e48e20,0000000..2f684b4 mode 100755,000000..100755 --- a/t/pragma/subs.t +++ b/t/pragma/subs.t @@@ -1,159 -1,0 +1,162 @@@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + $ENV{PERL5LIB} = '../lib'; +} + +$| = 1; +undef $/; +my @prgs = split "\n########\n", ; +print "1..", scalar @prgs, "\n"; + +my $Is_VMS = $^O eq 'VMS'; +my $Is_MSWin32 = $^O eq 'MSWin32'; ++my $Is_NetWare = $^O eq 'NetWare'; +my $tmpfile = "tmp0000"; +my $i = 0 ; +1 while -f ++$tmpfile; +END { if ($tmpfile) { 1 while unlink $tmpfile} } + +for (@prgs){ + my $switch = ""; + my @temps = () ; + if (s/^\s*-\w+//){ + $switch = $&; + } + my($prog,$expected) = split(/\nEXPECT\n/, $_); + if ( $prog =~ /--FILE--/) { + my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; + shift @files ; + die "Internal error test $i didn't split into pairs, got " . + scalar(@files) . "[" . join("%%%%", @files) ."]\n" + if @files % 2 ; + while (@files > 2) { + my $filename = shift @files ; + my $code = shift @files ; + push @temps, $filename ; + open F, ">$filename" or die "Cannot open $filename: $!\n" ; + print F $code ; + close F ; + } + shift @files ; + $prog = shift @files ; + } + open TEST, ">$tmpfile"; + print TEST $prog,"\n"; + close TEST; + my $results = $Is_VMS ? + `./perl $switch $tmpfile 2>&1` : + $Is_MSWin32 ? + `.\\perl -I../lib $switch $tmpfile 2>&1` : ++ $Is_NetWare ? ++ `perl -I../lib $switch $tmpfile 2>&1` : + `./perl $switch $tmpfile 2>&1`; + my $status = $?; + $results =~ s/\n+$//; + # allow expected output to be written as if $prog is on STDIN + $results =~ s/tmp\d+/-/g; + $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg +# bison says 'parse error' instead of 'syntax error', +# various yaccs may or may not capitalize 'syntax'. + $results =~ s/^(syntax|parse) error/syntax error/mig; + $expected =~ s/\n+$//; + my $prefix = ($results =~ s/^PREFIX\n//) ; + if ( $results =~ s/^SKIPPED\n//) { + print "$results\n" ; + } + elsif (($prefix and $results !~ /^\Q$expected/) or + (!$prefix and $results ne $expected)){ + print STDERR "PROG: $switch\n$prog\n"; + print STDERR "EXPECTED:\n$expected\n"; + print STDERR "GOT:\n$results\n"; + print "not "; + } + print "ok ", ++$i, "\n"; + foreach (@temps) + { unlink $_ if $_ } +} + +__END__ + +# Error - not predeclaring a sub +Fred 1,2 ; +sub Fred {} +EXPECT +Number found where operator expected at - line 3, near "Fred 1" + (Do you need to predeclare Fred?) +syntax error at - line 3, near "Fred 1" +Execution of - aborted due to compilation errors. +######## + +# Error - not predeclaring a sub in time +Fred 1,2 ; +use subs qw( Fred ) ; +sub Fred {} +EXPECT +Number found where operator expected at - line 3, near "Fred 1" + (Do you need to predeclare Fred?) +syntax error at - line 3, near "Fred 1" +BEGIN not safe after errors--compilation aborted at - line 4. +######## + +# AOK +use subs qw( Fred) ; +Fred 1,2 ; +sub Fred { print $_[0] + $_[1], "\n" } +EXPECT +3 +######## + +# override a built-in function +use subs qw( open ) ; +open 1,2 ; +sub open { print $_[0] + $_[1], "\n" } +EXPECT +3 +######## + +# override a built-in function, call after definition +use subs qw( open ) ; +sub open { print $_[0] + $_[1], "\n" } +open 1,2 ; +EXPECT +3 +######## + +# override a built-in function, call with () +use subs qw( open ) ; +open (1,2) ; +sub open { print $_[0] + $_[1], "\n" } +EXPECT +3 +######## + +# override a built-in function, call with () after definition +use subs qw( open ) ; +sub open { print $_[0] + $_[1], "\n" } +open (1,2) ; +EXPECT +3 +######## + +--FILE-- abc +Fred 1,2 ; +1; +--FILE-- +use subs qw( Fred ) ; +require "./abc" ; +sub Fred { print $_[0] + $_[1], "\n" } +EXPECT +3 +######## + +# check that it isn't affected by block scope +{ + use subs qw( Fred ) ; +} +Fred 1, 2; +sub Fred { print $_[0] + $_[1], "\n" } +EXPECT +3 diff --cc t/pragma/warn/mg index a8f9dbc,0000000..f224335 mode 100644,000000..100644 --- a/t/pragma/warn/mg +++ b/t/pragma/warn/mg @@@ -1,44 -1,0 +1,44 @@@ + mg.c AOK + + No such signal: SIG%s + $SIG{FRED} = sub {} + + SIG%s handler \"%s\" not defined. + $SIG{"INT"} = "ok3"; kill "INT",$$; + + Mandatory Warnings TODO + ------------------ + Can't break at that line [magic_setdbline] + +__END__ +# mg.c +use warnings 'signal' ; +$SIG{FRED} = sub {}; +EXPECT +No such signal: SIGFRED at - line 3. +######## +# mg.c +no warnings 'signal' ; +$SIG{FRED} = sub {}; +EXPECT + +######## +# mg.c +use warnings 'signal' ; - if ($^O eq 'MSWin32' || $^O eq 'VMS') { ++if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') { + print "SKIPPED\n# $^O, can't kill() to raise()\n"; exit; +} +$|=1; +$SIG{"INT"} = "fred"; kill "INT",$$; +EXPECT +SIGINT handler "fred" not defined. +######## +# mg.c +no warnings 'signal' ; - if ($^O eq 'MSWin32' || $^O eq 'VMS') { ++if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') { + print "SKIPPED\n# win32, can't kill() to raise()\n"; exit; +} +$|=1; +$SIG{"INT"} = "fred"; kill "INT",$$; +EXPECT + diff --cc t/pragma/warnings.t index 591f039,0000000..09b41fb mode 100644,000000..100644 --- a/t/pragma/warnings.t +++ b/t/pragma/warnings.t @@@ -1,128 -1,0 +1,131 @@@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + $ENV{PERL5LIB} = '../lib'; + require Config; import Config; +} + +$| = 1; + +my $Is_VMS = $^O eq 'VMS'; +my $Is_MSWin32 = $^O eq 'MSWin32'; ++my $Is_NetWare = $^O eq 'NetWare'; +my $tmpfile = "tmp0000"; +my $i = 0 ; +1 while -f ++$tmpfile; +END { if ($tmpfile) { 1 while unlink $tmpfile} } + +my @prgs = () ; +my @w_files = () ; + +if (@ARGV) + { print "ARGV = [@ARGV]\n" ; @w_files = map { s#^#./pragma/warn/#; $_ } @ARGV } +else + { @w_files = sort glob("pragma/warn/*") } + +my $files = 0; +foreach my $file (@w_files) { + + next if $file =~ /(~|\.orig|,v)$/; + + open F, "<$file" or die "Cannot open $file: $!\n" ; + my $line = 0; + while () { + $line++; + last if /^__END__/ ; + } + + { + local $/ = undef; + $files++; + @prgs = (@prgs, $file, split "\n########\n", ) ; + } + close F ; +} + +undef $/; + +print "1..", scalar(@prgs)-$files, "\n"; + + +for (@prgs){ + unless (/\n/) + { + print "# From $_\n"; + next; + } + my $switch = ""; + my @temps = () ; + if (s/^\s*-\w+//){ + $switch = $&; + $switch =~ s/(-\S*[A-Z]\S*)/"$1"/ if $Is_VMS; # protect uc switches + } + my($prog,$expected) = split(/\nEXPECT\n/, $_); + if ( $prog =~ /--FILE--/) { + my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; + shift @files ; + die "Internal error test $i didn't split into pairs, got " . + scalar(@files) . "[" . join("%%%%", @files) ."]\n" + if @files % 2 ; + while (@files > 2) { + my $filename = shift @files ; + my $code = shift @files ; + push @temps, $filename ; + open F, ">$filename" or die "Cannot open $filename: $!\n" ; + print F $code ; + close F ; + } + shift @files ; + $prog = shift @files ; + } + open TEST, ">$tmpfile"; + print TEST $prog,"\n"; + close TEST; + my $results = $Is_VMS ? + `./perl "-I../lib" $switch $tmpfile 2>&1` : + $Is_MSWin32 ? + `.\\perl -I../lib $switch $tmpfile 2>&1` : ++ $Is_NetWare ? ++ `perl -I../lib $switch $tmpfile 2>&1` : + `./perl -I../lib $switch $tmpfile 2>&1`; + my $status = $?; + $results =~ s/\n+$//; + # allow expected output to be written as if $prog is on STDIN + $results =~ s/tmp\d+/-/g; + $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg +# bison says 'parse error' instead of 'syntax error', +# various yaccs may or may not capitalize 'syntax'. + $results =~ s/^(syntax|parse) error/syntax error/mig; + # allow all tests to run when there are leaks + $results =~ s/Scalars leaked: \d+\n//g; + $expected =~ s/\n+$//; + my $prefix = ($results =~ s#^PREFIX(\n|$)##) ; + # any special options? (OPTIONS foo bar zap) + my $option_regex = 0; + if ($expected =~ s/^OPTIONS? (.+)\n//) { + foreach my $option (split(' ', $1)) { + if ($option eq 'regex') { # allow regular expressions + $option_regex = 1; + } else { + die "$0: Unknown OPTION '$option'\n"; + } + } + } + if ( $results =~ s/^SKIPPED\n//) { + print "$results\n" ; + } + elsif (($prefix && (( $option_regex && $results !~ /^$expected/) || + (!$option_regex && $results !~ /^\Q$expected/))) or + (!$prefix && (( $option_regex && $results !~ /^$expected/) || + (!$option_regex && $results ne $expected)))) { + print STDERR "PROG: $switch\n$prog\n"; + print STDERR "EXPECTED:\n$expected\n"; + print STDERR "GOT:\n$results\n"; + print "not "; + } + print "ok ", ++$i, "\n"; + foreach (@temps) + { unlink $_ if $_ } +}