--- /dev/null
+#!./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 <Op_dbmx*>;
+
+umask(0);
+print (tie(%h,AnyDBM_File,'Op_dbmx', O_RDWR|O_CREAT, 0640)
+ ? "ok 1\n" : "not ok 1\n");
+
+$Dfile = "Op_dbmx.pag";
+if (! -e $Dfile) {
+ ($Dfile) = <Op_dbmx*>;
+}
+if ($Is_Dosish || $^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;
+}
--- /dev/null
+#!./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++;
+}
+
--- /dev/null
- #!./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 (<DATA>) {
- 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 (<DATA>)
++ {
++ 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
--- /dev/null
- #!./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 (<DATA>) {
- chop;
- if (s/^&//) {
- $f = $_;
- } else {
- ++$test;
- @args = split(/:/,$_,99);
- $ans = pop(@args);
- $try = "\$x = new Math::BigInt \"$args[0]\";";
- if ($f eq "bnorm"){
- $try .= "\$x+0;";
- } elsif ($f eq "bneg") {
- $try .= "-\$x;";
- } elsif ($f eq "babs") {
- $try .= "abs \$x;";
- } 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 (<DATA>)
++ {
++ 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
--- /dev/null
+#!./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";
+}
--- /dev/null
+#!./perl -w
+
+BEGIN {
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bDB_File\b/) {
+ print "1..0 # Skip: DB_File was not built\n";
+ exit 0;
+ }
+}
+
+use warnings;
+use strict;
+use DB_File;
+use Fcntl;
+
+print "1..157\n";
+
+sub ok
+{
+ my $no = shift ;
+ my $result = shift ;
+
+ print "not " unless $result ;
+ print "ok $no\n" ;
+}
+
+sub lexical
+{
+ my(@a) = unpack ("C*", $a) ;
+ my(@b) = unpack ("C*", $b) ;
+
+ my $len = (@a > @b ? @b : @a) ;
+ my $i = 0 ;
+
+ foreach $i ( 0 .. $len -1) {
+ return $a[$i] - $b[$i] if $a[$i] != $b[$i] ;
+ }
+
+ return @a - @b ;
+}
+
+{
+ package Redirect ;
+ use Symbol ;
+
+ sub new
+ {
+ my $class = shift ;
+ my $filename = shift ;
+ my $fh = gensym ;
+ open ($fh, ">$filename") || die "Cannot open $filename: $!" ;
+ my $real_stdout = select($fh) ;
+ return bless [$fh, $real_stdout ] ;
+
+ }
+ sub DESTROY
+ {
+ my $self = shift ;
+ close $self->[0] ;
+ select($self->[1]) ;
+ }
+}
+
+sub docat
+{
+ my $file = shift;
+ #local $/ = undef unless wantarray ;
+ open(CAT,$file) || die "Cannot open $file: $!";
+ my @result = <CAT>;
+ close(CAT);
+ wantarray ? @result : join("", @result) ;
+}
+
+sub docat_del
+{
+ my $file = shift;
+ #local $/ = undef unless wantarray ;
+ open(CAT,$file) || die "Cannot open $file: $!";
+ my @result = <CAT>;
+ close(CAT);
+ unlink $file ;
+ wantarray ? @result : join("", @result) ;
+}
+
+
+my $db185mode = ($DB_File::db_version == 1 && ! $DB_File::db_185_compat) ;
+my $null_keys_allowed = ($DB_File::db_ver < 2.004010
+ || $DB_File::db_ver >= 3.1 );
+
+my $Dfile = "dbbtree.tmp";
+unlink $Dfile;
+
+umask(0);
+
+# Check the interface to BTREEINFO
+
+my $dbh = new DB_File::BTREEINFO ;
+ok(1, ! defined $dbh->{flags}) ;
+ok(2, ! defined $dbh->{cachesize}) ;
+ok(3, ! defined $dbh->{psize}) ;
+ok(4, ! defined $dbh->{lorder}) ;
+ok(5, ! defined $dbh->{minkeypage}) ;
+ok(6, ! defined $dbh->{maxkeypage}) ;
+ok(7, ! defined $dbh->{compare}) ;
+ok(8, ! defined $dbh->{prefix}) ;
+
+$dbh->{flags} = 3000 ;
+ok(9, $dbh->{flags} == 3000) ;
+
+$dbh->{cachesize} = 9000 ;
+ok(10, $dbh->{cachesize} == 9000);
+
+$dbh->{psize} = 400 ;
+ok(11, $dbh->{psize} == 400) ;
+
+$dbh->{lorder} = 65 ;
+ok(12, $dbh->{lorder} == 65) ;
+
+$dbh->{minkeypage} = 123 ;
+ok(13, $dbh->{minkeypage} == 123) ;
+
+$dbh->{maxkeypage} = 1234 ;
+ok(14, $dbh->{maxkeypage} == 1234 );
+
+$dbh->{compare} = 1234 ;
+ok(15, $dbh->{compare} == 1234) ;
+
+$dbh->{prefix} = 1234 ;
+ok(16, $dbh->{prefix} == 1234 );
+
+# Check that an invalid entry is caught both for store & fetch
+eval '$dbh->{fred} = 1234' ;
+ok(17, $@ =~ /^DB_File::BTREEINFO::STORE - Unknown element 'fred' at/ ) ;
+eval 'my $q = $dbh->{fred}' ;
+ok(18, $@ =~ /^DB_File::BTREEINFO::FETCH - Unknown element 'fred' at/ ) ;
+
+# Now check the interface to BTREE
+
+my ($X, %h) ;
+ok(19, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ;
+
+my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
- ok(20, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32');
++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 ;
--- /dev/null
+#!./perl -w
+
+BEGIN {
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bDB_File\b/) {
+ print "1..0 # Skip: DB_File was not built\n";
+ exit 0;
+ }
+}
+
+use strict;
+use warnings;
+use DB_File;
+use Fcntl;
+
+print "1..111\n";
+
+sub ok
+{
+ my $no = shift ;
+ my $result = shift ;
+
+ print "not " unless $result ;
+ print "ok $no\n" ;
+}
+
+{
+ package Redirect ;
+ use Symbol ;
+
+ sub new
+ {
+ my $class = shift ;
+ my $filename = shift ;
+ my $fh = gensym ;
+ open ($fh, ">$filename") || die "Cannot open $filename: $!" ;
+ my $real_stdout = select($fh) ;
+ return bless [$fh, $real_stdout ] ;
+
+ }
+ sub DESTROY
+ {
+ my $self = shift ;
+ close $self->[0] ;
+ select($self->[1]) ;
+ }
+}
+
+sub docat_del
+{
+ my $file = shift;
+ local $/ = undef;
+ open(CAT,$file) || die "Cannot open $file: $!";
+ my $result = <CAT>;
+ close(CAT);
+ unlink $file ;
+ return $result;
+}
+
+my $Dfile = "dbhash.tmp";
+my $null_keys_allowed = ($DB_File::db_ver < 2.004010
+ || $DB_File::db_ver >= 3.1 );
+
+unlink $Dfile;
+
+umask(0);
+
+# Check the interface to HASHINFO
+
+my $dbh = new DB_File::HASHINFO ;
+
+ok(1, ! defined $dbh->{bsize}) ;
+ok(2, ! defined $dbh->{ffactor}) ;
+ok(3, ! defined $dbh->{nelem}) ;
+ok(4, ! defined $dbh->{cachesize}) ;
+ok(5, ! defined $dbh->{hash}) ;
+ok(6, ! defined $dbh->{lorder}) ;
+
+$dbh->{bsize} = 3000 ;
+ok(7, $dbh->{bsize} == 3000 );
+
+$dbh->{ffactor} = 9000 ;
+ok(8, $dbh->{ffactor} == 9000 );
+
+$dbh->{nelem} = 400 ;
+ok(9, $dbh->{nelem} == 400 );
+
+$dbh->{cachesize} = 65 ;
+ok(10, $dbh->{cachesize} == 65 );
+
+$dbh->{hash} = "abc" ;
+ok(11, $dbh->{hash} eq "abc" );
+
+$dbh->{lorder} = 1234 ;
+ok(12, $dbh->{lorder} == 1234 );
+
+# Check that an invalid entry is caught both for store & fetch
+eval '$dbh->{fred} = 1234' ;
+ok(13, $@ =~ /^DB_File::HASHINFO::STORE - Unknown element 'fred' at/ );
+eval 'my $q = $dbh->{fred}' ;
+ok(14, $@ =~ /^DB_File::HASHINFO::FETCH - Unknown element 'fred' at/ );
+
+
+# Now check the interface to HASH
+my ($X, %h);
+ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+
+my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
- ok(16, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32');
++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 ;
--- /dev/null
+#!./perl -w
+
+BEGIN {
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bDB_File\b/) {
+ print "1..0 # Skip: DB_File was not built\n";
+ exit 0;
+ }
+}
+
+use DB_File;
+use Fcntl;
+use strict ;
+use warnings;
+use vars qw($dbh $Dfile $bad_ones $FA) ;
+
+# full tied array support started in Perl 5.004_57
+# Double check to see if it is available.
+
+{
+ sub try::TIEARRAY { bless [], "try" }
+ sub try::FETCHSIZE { $FA = 1 }
+ $FA = 0 ;
+ my @a ;
+ tie @a, 'try' ;
+ my $a = @a ;
+}
+
+
+sub ok
+{
+ my $no = shift ;
+ my $result = shift ;
+
+ print "not " unless $result ;
+ print "ok $no\n" ;
+
+ return $result ;
+}
+
+{
+ package Redirect ;
+ use Symbol ;
+
+ sub new
+ {
+ my $class = shift ;
+ my $filename = shift ;
+ my $fh = gensym ;
+ open ($fh, ">$filename") || die "Cannot open $filename: $!" ;
+ my $real_stdout = select($fh) ;
+ return bless [$fh, $real_stdout ] ;
+
+ }
+ sub DESTROY
+ {
+ my $self = shift ;
+ close $self->[0] ;
+ select($self->[1]) ;
+ }
+}
+
+sub docat
+{
+ my $file = shift;
+ local $/ = undef;
+ open(CAT,$file) || die "Cannot open $file:$!";
+ my $result = <CAT>;
+ close(CAT);
+ return $result;
+}
+
+sub docat_del
+{
+ my $file = shift;
+ local $/ = undef;
+ open(CAT,$file) || die "Cannot open $file: $!";
+ my $result = <CAT>;
+ close(CAT);
+ unlink $file ;
+ return $result;
+}
+
+sub bad_one
+{
+ print STDERR <<EOM unless $bad_ones++ ;
+#
+# Some older versions of Berkeley DB version 1 will fail tests 51,
+# 53 and 55.
+#
+# You can safely ignore the errors if you're never going to use the
+# broken functionality (recno databases with a modified bval).
+# Otherwise you'll have to upgrade your DB library.
+#
+# If you want to use Berkeley DB version 1, then 1.85 and 1.86 are the
+# last versions that were released. Berkeley DB version 2 is continually
+# being updated -- Check out http://www.sleepycat.com/ for more details.
+#
+EOM
+}
+
+print "1..128\n";
+
+my $Dfile = "recno.tmp";
+unlink $Dfile ;
+
+umask(0);
+
+# Check the interface to RECNOINFO
+
+my $dbh = new DB_File::RECNOINFO ;
+ok(1, ! defined $dbh->{bval}) ;
+ok(2, ! defined $dbh->{cachesize}) ;
+ok(3, ! defined $dbh->{psize}) ;
+ok(4, ! defined $dbh->{flags}) ;
+ok(5, ! defined $dbh->{lorder}) ;
+ok(6, ! defined $dbh->{reclen}) ;
+ok(7, ! defined $dbh->{bfname}) ;
+
+$dbh->{bval} = 3000 ;
+ok(8, $dbh->{bval} == 3000 );
+
+$dbh->{cachesize} = 9000 ;
+ok(9, $dbh->{cachesize} == 9000 );
+
+$dbh->{psize} = 400 ;
+ok(10, $dbh->{psize} == 400 );
+
+$dbh->{flags} = 65 ;
+ok(11, $dbh->{flags} == 65 );
+
+$dbh->{lorder} = 123 ;
+ok(12, $dbh->{lorder} == 123 );
+
+$dbh->{reclen} = 1234 ;
+ok(13, $dbh->{reclen} == 1234 );
+
+$dbh->{bfname} = 1234 ;
+ok(14, $dbh->{bfname} == 1234 );
+
+
+# Check that an invalid entry is caught both for store & fetch
+eval '$dbh->{fred} = 1234' ;
+ok(15, $@ =~ /^DB_File::RECNOINFO::STORE - Unknown element 'fred' at/ );
+eval 'my $q = $dbh->{fred}' ;
+ok(16, $@ =~ /^DB_File::RECNOINFO::FETCH - Unknown element 'fred' at/ );
+
+# Now check the interface to RECNOINFO
+
+my $X ;
+my @h ;
+ok(17, $X = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ;
+
+ok(18, ((stat($Dfile))[2] & 0777) == ($^O eq 'os2' ? 0666 : 0640)
- || $^O eq 'MSWin32' || $^O eq 'amigaos') ;
++ || $^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 ;
--- /dev/null
+#!./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";
+}
--- /dev/null
- #!./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";
--- /dev/null
+#!./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);
+ }
+}
--- /dev/null
+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", <<EOM) ;
+package ${module} ;
+
+use Filter::Util::Call ;
+
+sub import { filter_add(bless []) }
+
+1 ;
+EOM
+
+my $a = `$Perl "-I." $Inc -e "use ${module} ;" 2>&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", <<EOM) ;
+package ${module} ;
+
+use Filter::Util::Call ;
+
+sub import { filter_add() }
+
+1 ;
+EOM
+
+$a = `$Perl "-I." $Inc -e "use ${module} ;" 2>&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", <<EOM, <<'EOM') ;
+package ${module} ;
+
+EOM
+use Filter::Util::Call ;
+sub import {
+ filter_add(
+ sub {
+
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+ s/ABC/DEF/g
+ }
+ $status ;
+ } ) ;
+}
+
+1 ;
+EOM
+
+writeFile($filename, <<EOM, <<'EOM') ;
+
+use $module ;
+EOM
+
+use Cwd ;
+$here = getcwd ;
+print "I am $here\n" ;
+print "some letters ABC\n" ;
+$y = "ABCDEF" ;
+print <<EOF ;
+Alphabetti Spagetti ($y)
+EOF
+
+EOM
+
+$a = `$Perl "-I." $Inc $filename 2>&1` ;
+ok(5, ($? >>8) == 0) ;
+ok(6, $a eq <<EOM) ;
+I am $here
+some letters DEF
+Alphabetti Spagetti (DEFDEF)
+EOM
+
+# a simple filter, not using a closure
+#################
+
+writeFile("${module}.pm", <<EOM, <<'EOM') ;
+package ${module} ;
+
+EOM
+use Filter::Util::Call ;
+sub import { filter_add(bless []) }
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+ s/ABC/DEF/g
+ }
+ $status ;
+}
+
+
+1 ;
+EOM
+
+writeFile($filename, <<EOM, <<'EOM') ;
+
+use $module ;
+EOM
+
+use Cwd ;
+$here = getcwd ;
+print "I am $here\n" ;
+print "some letters ABC\n" ;
+$y = "ABCDEF" ;
+print <<EOF ;
+Alphabetti Spagetti ($y)
+EOF
+
+EOM
+
+$a = `$Perl "-I." $Inc $filename 2>&1` ;
+ok(7, ($? >>8) == 0) ;
+ok(8, $a eq <<EOM) ;
+I am $here
+some letters DEF
+Alphabetti Spagetti (DEFDEF)
+EOM
+
+
+# nested filters
+################
+
+
+writeFile("${module2}.pm", <<EOM, <<'EOM') ;
+package ${module2} ;
+use Filter::Util::Call ;
+
+EOM
+sub import { filter_add(bless []) }
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+ s/XYZ/PQR/g
+ }
+ $status ;
+}
+
+1 ;
+EOM
+
+writeFile("${module3}.pm", <<EOM, <<'EOM') ;
+package ${module3} ;
+use Filter::Util::Call ;
+
+EOM
+sub import { filter_add(
+
+ sub
+ {
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+ s/Fred/Joe/g
+ }
+ $status ;
+ } ) ;
+}
+
+1 ;
+EOM
+
+writeFile("${module4}.pm", <<EOM) ;
+package ${module4} ;
+
+use $module5 ;
+
+print "I'm feeling used!\n" ;
+print "Fred Joe ABC DEF PQR XYZ\n" ;
+print "See you Today\n" ;
+1;
+EOM
+
+writeFile("${module5}.pm", <<EOM, <<'EOM') ;
+package ${module5} ;
+use Filter::Util::Call ;
+
+EOM
+sub import { filter_add(bless []) }
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+ s/Today/Tomorrow/g
+ }
+ $status ;
+}
+
+1 ;
+EOM
+
+writeFile($filename, <<EOM, <<'EOM') ;
+
+# two filters for this file
+use $module ;
+use $module2 ;
+require "$nested" ;
+use $module4 ;
+EOM
+
+print "some letters ABCXYZ\n" ;
+$y = "ABCDEFXYZ" ;
+print <<EOF ;
+Fred likes Alphabetti Spagetti ($y)
+EOF
+
+EOM
+
+writeFile($nested, <<EOM, <<'EOM') ;
+use $module3 ;
+EOM
+
+print "This is another file XYZ\n" ;
+print <<EOF ;
+Where is Fred?
+EOF
+
+EOM
+
+$a = `$Perl "-I." $Inc $filename 2>&1` ;
+ok(9, ($? >>8) == 0) ;
+ok(10, $a eq <<EOM) ;
+I'm feeling used!
+Fred Joe ABC DEF PQR XYZ
+See you Tomorrow
+This is another file XYZ
+Where is Joe?
+some letters DEFPQR
+Fred likes Alphabetti Spagetti (DEFDEFPQR)
+EOM
+
+# using the module context (with a closure)
+###########################################
+
+
+writeFile("${module2}.pm", <<EOM, <<'EOM') ;
+package ${module2} ;
+use Filter::Util::Call ;
+
+EOM
+sub import
+{
+ my ($type) = shift ;
+ my (@strings) = @_ ;
+
+
+ filter_add (
+
+ sub
+ {
+ my ($status) ;
+ my ($pattern) ;
+
+ if (($status = filter_read()) > 0) {
+ foreach $pattern (@strings)
+ { s/$pattern/PQR/g }
+ }
+
+ $status ;
+ }
+ )
+
+}
+1 ;
+EOM
+
+
+writeFile($filename, <<EOM, <<'EOM') ;
+
+use $module2 qw( XYZ KLM) ;
+use $module2 qw( ABC NMO) ;
+EOM
+
+print "some letters ABCXYZ KLM NMO\n" ;
+$y = "ABCDEFXYZKLMNMO" ;
+print <<EOF ;
+Alphabetti Spagetti ($y)
+EOF
+
+EOM
+
+$a = `$Perl "-I." $Inc $filename 2>&1` ;
+ok(11, ($? >>8) == 0) ;
+ok(12, $a eq <<EOM) ;
+some letters PQRPQR PQR PQR
+Alphabetti Spagetti (PQRDEFPQRPQRPQR)
+EOM
+
+
+
+# using the module context (without a closure)
+##############################################
+
+
+writeFile("${module2}.pm", <<EOM, <<'EOM') ;
+package ${module2} ;
+use Filter::Util::Call ;
+
+EOM
+sub import
+{
+ my ($type) = shift ;
+ my (@strings) = @_ ;
+
+
+ filter_add (bless [@strings])
+}
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+ my ($pattern) ;
+
+ if (($status = filter_read()) > 0) {
+ foreach $pattern (@$self)
+ { s/$pattern/PQR/g }
+ }
+
+ $status ;
+}
+
+1 ;
+EOM
+
+
+writeFile($filename, <<EOM, <<'EOM') ;
+
+use $module2 qw( XYZ KLM) ;
+use $module2 qw( ABC NMO) ;
+EOM
+
+print "some letters ABCXYZ KLM NMO\n" ;
+$y = "ABCDEFXYZKLMNMO" ;
+print <<EOF ;
+Alphabetti Spagetti ($y)
+EOF
+
+EOM
+
+$a = `$Perl "-I." $Inc $filename 2>&1` ;
+ok(13, ($? >>8) == 0) ;
+ok(14, $a eq <<EOM) ;
+some letters PQRPQR PQR PQR
+Alphabetti Spagetti (PQRDEFPQRPQRPQR)
+EOM
+
+# multi line test
+#################
+
+
+writeFile("${module2}.pm", <<EOM, <<'EOM') ;
+package ${module2} ;
+use Filter::Util::Call ;
+
+EOM
+sub import
+{
+ my ($type) = shift ;
+ my (@strings) = @_ ;
+
+
+ filter_add(bless [])
+}
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+
+ # read first line
+ if (($status = filter_read()) > 0) {
+ chop ;
+ s/\r$//;
+ # and now the second line (it will append)
+ $status = filter_read() ;
+ }
+
+ $status ;
+}
+
+1 ;
+EOM
+
+
+writeFile($filename, <<EOM, <<'EOM') ;
+
+use $module2 ;
+EOM
+print "don't cut me
+in half\n" ;
+print
+<<EOF ;
+appen
+ded
+EO
+F
+
+EOM
+
+$a = `$Perl "-I." $Inc $filename 2>&1` ;
+ok(15, ($? >>8) == 0) ;
+ok(16, $a eq <<EOM) ;
+don't cut me in half
+appended
+EOM
+
+# Block test
+#############
+
+writeFile("${block}.pm", <<EOM, <<'EOM') ;
+package ${block} ;
+use Filter::Util::Call ;
+
+EOM
+sub import
+{
+ my ($type) = shift ;
+ my (@strings) = @_ ;
+
+
+ filter_add (bless [@strings] )
+}
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+ my ($pattern) ;
+
+ filter_read(20) ;
+}
+
+1 ;
+EOM
+
+my $string = <<'EOM' ;
+print "hello mum\n" ;
+$x = 'me ' x 3 ;
+print "Who wants it?\n$x\n" ;
+EOM
+
+
+writeFile($filename, <<EOM, $string ) ;
+use $block ;
+EOM
+
+$a = `$Perl "-I." $Inc $filename 2>&1` ;
+ok(17, ($? >>8) == 0) ;
+ok(18, $a eq <<EOM) ;
+hello mum
+Who wants it?
+me me me
+EOM
+
+# use in the filter
+####################
+
+writeFile("${block}.pm", <<EOM, <<'EOM') ;
+package ${block} ;
+use Filter::Util::Call ;
+
+EOM
+use Cwd ;
+
+sub import
+{
+ my ($type) = shift ;
+ my (@strings) = @_ ;
+
+
+ filter_add(bless [@strings] )
+}
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+ my ($here) = quotemeta getcwd ;
+
+ if (($status = filter_read()) > 0) {
+ s/DIR/$here/g
+ }
+ $status ;
+}
+
+1 ;
+EOM
+
+writeFile($filename, <<EOM, <<'EOM') ;
+use $block ;
+EOM
+print "We are in DIR\n" ;
+EOM
+
+$a = `$Perl "-I." $Inc $filename 2>&1` ;
+ok(19, ($? >>8) == 0) ;
+ok(20, $a eq <<EOM) ;
+We are in $here
+EOM
+
+
+# filter_del
+#############
+
+writeFile("${block}.pm", <<EOM, <<'EOM') ;
+package ${block} ;
+use Filter::Util::Call ;
+
+EOM
+
+sub import
+{
+ my ($type) = shift ;
+ my ($count) = @_ ;
+
+
+ filter_add(bless \$count )
+}
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+
+ s/HERE/THERE/g
+ if ($status = filter_read()) > 0 ;
+
+ -- $$self ;
+ filter_del() if $$self <= 0 ;
+
+ $status ;
+}
+
+1 ;
+EOM
+
+writeFile($filename, <<EOM, <<'EOM') ;
+use $block (3) ;
+EOM
+print "
+HERE I am
+I am HERE
+HERE today gone tomorrow\n" ;
+EOM
+
+$a = `$Perl "-I." $Inc $filename 2>&1` ;
+ok(21, ($? >>8) == 0) ;
+ok(22, $a eq <<EOM) ;
+
+THERE I am
+I am THERE
+HERE today gone tomorrow
+EOM
+
+
+# filter_read_exact
+####################
+
+writeFile("${block}.pm", <<EOM, <<'EOM') ;
+package ${block} ;
+use Filter::Util::Call ;
+
+EOM
+
+sub import
+{
+ my ($type) = shift ;
+
+ filter_add(bless [] )
+}
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+
+ if (($status = filter_read_exact(9)) > 0) {
+ s/HERE/THERE/g
+ }
+
+ $status ;
+}
+
+1 ;
+EOM
+
+writeFile($filenamebin, <<EOM, <<'EOM') ;
+use $block ;
+EOM
+print "
+HERE I am
+I'm HERE
+HERE today gone tomorrow\n" ;
+EOM
+
+$a = `$Perl "-I." $Inc $filenamebin 2>&1` ;
+ok(23, ($? >>8) == 0) ;
+ok(24, $a eq <<EOM) ;
+
+HERE I am
+I'm THERE
+THERE today gone tomorrow
+EOM
+
+{
+
+# Check __DATA__
+####################
+
+writeFile("${block}.pm", <<EOM, <<'EOM') ;
+package ${block} ;
+use Filter::Util::Call ;
+
+EOM
+
+sub import
+{
+ my ($type) = shift ;
+
+ filter_add(bless [] )
+}
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+ s/HERE/THERE/g
+ }
+
+ $status ;
+}
+
+1 ;
+EOM
+
+writeFile($filename, <<EOM, <<'EOM') ;
+use $block ;
+EOM
+print "HERE HERE\n";
+@a = <DATA>;
+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 <<EOM) ;
+THERE THERE
+HERE I am
+I'm HERE
+HERE today gone tomorrow
+EOM
+
+}
+
+{
+
+# Check __END__
+####################
+
+writeFile("${block}.pm", <<EOM, <<'EOM') ;
+package ${block} ;
+use Filter::Util::Call ;
+
+EOM
+
+sub import
+{
+ my ($type) = shift ;
+
+ filter_add(bless [] )
+}
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+ s/HERE/THERE/g
+ }
+
+ $status ;
+}
+
+1 ;
+EOM
+
+writeFile($filename, <<EOM, <<'EOM') ;
+use $block ;
+EOM
+print "HERE HERE\n";
+@a = <DATA>;
+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 <<EOM) ;
+THERE THERE
+HERE I am
+I'm HERE
+HERE today gone tomorrow
+EOM
+
+}
+
+END {
+ 1 while unlink $filename ;
+ 1 while unlink $filenamebin ;
+ 1 while unlink "${module}.pm" ;
+ 1 while unlink "${module2}.pm" ;
+ 1 while unlink "${module3}.pm" ;
+ 1 while unlink "${module4}.pm" ;
+ 1 while unlink "${module5}.pm" ;
+ 1 while unlink $nested ;
+ 1 while unlink "${block}.pm" ;
+}
+
+
--- /dev/null
--- /dev/null
++#!./perl -T
++
++
++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 $cwd;
++my $cwd_untainted;
++
++BEGIN {
++ chdir 't' if -d 't';
++ unshift @INC => '../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);
++
++}
++
--- /dev/null
+#!/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);
+ }
+
+}
--- /dev/null
+#!./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 <Op.dbmx*>;
+
+umask(0);
+my %h ;
+print (tie(%h,'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640) ? "ok 1\n" : "not ok 1\n");
+
+my $Dfile = "Op.dbmx.pag";
+if (! -e $Dfile) {
+ ($Dfile) = <Op.dbmx*>;
+}
- if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos') {
++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 <dbhash.tmp*> ;
+
+ eval 'use SubDB ; ';
+ main::ok(13, $@ eq "") ;
+ my %h ;
+ my $X ;
+ eval '
+ $X = tie(%h, "SubDB","dbhash.tmp", &GDBM_WRCREAT, 0640 );
+ ' ;
+
+ main::ok(14, $@ eq "") ;
+
+ my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
+ main::ok(15, $@ eq "") ;
+ main::ok(16, $ret == 5) ;
+
+ $ret = eval ' &GDBM_WRCREAT eq &main::GDBM_WRCREAT ' ;
+ main::ok(17, $@ eq "" ) ;
+ main::ok(18, $ret == 1) ;
+
+ $ret = eval '$X->A_new_method("fred") ' ;
+ main::ok(19, $@ eq "") ;
+ main::ok(20, $ret eq "[[5]]") ;
+
+ undef $X;
+ untie(%h);
+ unlink "SubDB.pm", <dbhash.tmp*> ;
+
+}
+
+{
+ # DBM Filter tests
+ use strict ;
+ use warnings ;
+ my (%h, $db) ;
+ my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+
+ sub checkOutput
+ {
+ my($fk, $sk, $fv, $sv) = @_ ;
+ return
+ $fetch_key eq $fk && $store_key eq $sk &&
+ $fetch_value eq $fv && $store_value eq $sv &&
+ $_ eq 'original' ;
+ }
+
+ unlink <Op.dbmx*>;
+ ok(21, $db = tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)) ;
+
+ $db->filter_fetch_key (sub { $fetch_key = $_ }) ;
+ $db->filter_store_key (sub { $store_key = $_ }) ;
+ $db->filter_fetch_value (sub { $fetch_value = $_}) ;
+ $db->filter_store_value (sub { $store_value = $_ }) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ # fk sk fv sv
+ ok(22, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(23, $h{"fred"} eq "joe");
+ # fk sk fv sv
+ ok(24, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(25, $db->FIRSTKEY() eq "fred") ;
+ # fk sk fv sv
+ ok(26, checkOutput( "fred", "", "", "")) ;
+
+ # replace the filters, but remember the previous set
+ my ($old_fk) = $db->filter_fetch_key
+ (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
+ my ($old_sk) = $db->filter_store_key
+ (sub { $_ = lc $_ ; $store_key = $_ }) ;
+ my ($old_fv) = $db->filter_fetch_value
+ (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+ my ($old_sv) = $db->filter_store_value
+ (sub { s/o/x/g; $store_value = $_ }) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"Fred"} = "Joe" ;
+ # fk sk fv sv
+ ok(27, checkOutput( "", "fred", "", "Jxe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(28, $h{"Fred"} eq "[Jxe]");
+ # fk sk fv sv
+ ok(29, checkOutput( "", "fred", "[Jxe]", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(30, $db->FIRSTKEY() eq "FRED") ;
+ # fk sk fv sv
+ ok(31, checkOutput( "FRED", "", "", "")) ;
+
+ # put the original filters back
+ $db->filter_fetch_key ($old_fk);
+ $db->filter_store_key ($old_sk);
+ $db->filter_fetch_value ($old_fv);
+ $db->filter_store_value ($old_sv);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(32, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(33, $h{"fred"} eq "joe");
+ ok(34, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(35, $db->FIRSTKEY() eq "fred") ;
+ ok(36, checkOutput( "fred", "", "", "")) ;
+
+ # delete the filters
+ $db->filter_fetch_key (undef);
+ $db->filter_store_key (undef);
+ $db->filter_fetch_value (undef);
+ $db->filter_store_value (undef);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(37, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(38, $h{"fred"} eq "joe");
+ ok(39, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(40, $db->FIRSTKEY() eq "fred") ;
+ ok(41, checkOutput( "", "", "", "")) ;
+
+ undef $db ;
+ untie %h;
+ unlink <Op.dbmx*>;
+}
+
+{
+ # DBM Filter with a closure
+
+ use strict ;
+ use warnings ;
+ my (%h, $db) ;
+
+ unlink <Op.dbmx*>;
+ ok(42, $db = tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)) ;
+
+ my %result = () ;
+
+ sub Closure
+ {
+ my ($name) = @_ ;
+ my $count = 0 ;
+ my @kept = () ;
+
+ return sub { ++$count ;
+ push @kept, $_ ;
+ $result{$name} = "$name - $count: [@kept]" ;
+ }
+ }
+
+ $db->filter_store_key(Closure("store key")) ;
+ $db->filter_store_value(Closure("store value")) ;
+ $db->filter_fetch_key(Closure("fetch key")) ;
+ $db->filter_fetch_value(Closure("fetch value")) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ ok(43, $result{"store key"} eq "store key - 1: [fred]");
+ ok(44, $result{"store value"} eq "store value - 1: [joe]");
+ ok(45, !defined $result{"fetch key"} );
+ ok(46, !defined $result{"fetch value"} );
+ ok(47, $_ eq "original") ;
+
+ ok(48, $db->FIRSTKEY() eq "fred") ;
+ ok(49, $result{"store key"} eq "store key - 1: [fred]");
+ ok(50, $result{"store value"} eq "store value - 1: [joe]");
+ ok(51, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(52, ! defined $result{"fetch value"} );
+ ok(53, $_ eq "original") ;
+
+ $h{"jim"} = "john" ;
+ ok(54, $result{"store key"} eq "store key - 2: [fred jim]");
+ ok(55, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(56, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(57, ! defined $result{"fetch value"} );
+ ok(58, $_ eq "original") ;
+
+ ok(59, $h{"fred"} eq "joe");
+ ok(60, $result{"store key"} eq "store key - 3: [fred jim fred]");
+ ok(61, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(62, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(63, $result{"fetch value"} eq "fetch value - 1: [joe]");
+ ok(64, $_ eq "original") ;
+
+ undef $db ;
+ untie %h;
+ unlink <Op.dbmx*>;
+}
+
+{
+ # DBM Filter recursion detection
+ use strict ;
+ use warnings ;
+ my (%h, $db) ;
+ unlink <Op.dbmx*>;
+
+ ok(65, $db = tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)) ;
+
+ $db->filter_store_key (sub { $_ = $h{$_} }) ;
+
+ eval '$h{1} = 1234' ;
+ ok(66, $@ =~ /^recursion detected in filter_store_key at/ );
+
+ undef $db ;
+ untie %h;
+ unlink <Op.dbmx*>;
+}
+
+{
+ # Bug ID 20001013.009
+ #
+ # test that $hash{KEY} = undef doesn't produce the warning
+ # Use of uninitialized value in null operation
+ use warnings ;
+ use strict ;
+ use GDBM_File ;
+
+ unlink <Op.dbmx*>;
+ my %h ;
+ my $a = "";
+ local $SIG{__WARN__} = sub {$a = $_[0]} ;
+
+ ok(67, tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640));
+ $h{ABC} = undef;
+ ok(68, $a eq "") ;
+ untie %h;
+ unlink <Op.dbmx*>;
+}
--- /dev/null
+#!./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";
--- /dev/null
+#!./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";
+}
--- /dev/null
+#!./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";
--- /dev/null
+#!./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";
--- /dev/null
+#!./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" ;
--- /dev/null
+#!./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;
--- /dev/null
--- /dev/null
++#!/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');
++ }
++
--- /dev/null
+#!./perl
+
+# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bNDBM_File\b/) {
+ print "1..0 # Skip: NDBM_File was not built\n";
+ exit 0;
+ }
+}
+
+use strict;
+use warnings;
+
+sub ok
+{
+ my $no = shift ;
+ my $result = shift ;
+
+ print "not " unless $result ;
+ print "ok $no\n" ;
+}
+
+require NDBM_File;
+#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
+use Fcntl;
+
+print "1..65\n";
+
+unlink <Op.dbmx*>;
+
+umask(0);
+my %h;
+ok(1, tie(%h,'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640));
+
+my $Dfile = "Op.dbmx.pag";
+if (! -e $Dfile) {
+ ($Dfile) = <Op.dbmx*>;
+}
- if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32') {
++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", <dbhash.tmp*> ;
+
+}
+
+{
+ # DBM Filter tests
+ use strict ;
+ use warnings ;
+ my (%h, $db) ;
+ my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+
+ sub checkOutput
+ {
+ my($fk, $sk, $fv, $sv) = @_ ;
+ return
+ $fetch_key eq $fk && $store_key eq $sk &&
+ $fetch_value eq $fv && $store_value eq $sv &&
+ $_ eq 'original' ;
+ }
+
+ unlink <Op.dbmx*>;
+ ok(19, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+ $db->filter_fetch_key (sub { $fetch_key = $_ }) ;
+ $db->filter_store_key (sub { $store_key = $_ }) ;
+ $db->filter_fetch_value (sub { $fetch_value = $_}) ;
+ $db->filter_store_value (sub { $store_value = $_ }) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ # fk sk fv sv
+ ok(20, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(21, $h{"fred"} eq "joe");
+ # fk sk fv sv
+ ok(22, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(23, $db->FIRSTKEY() eq "fred") ;
+ # fk sk fv sv
+ ok(24, checkOutput( "fred", "", "", "")) ;
+
+ # replace the filters, but remember the previous set
+ my ($old_fk) = $db->filter_fetch_key
+ (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
+ my ($old_sk) = $db->filter_store_key
+ (sub { $_ = lc $_ ; $store_key = $_ }) ;
+ my ($old_fv) = $db->filter_fetch_value
+ (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+ my ($old_sv) = $db->filter_store_value
+ (sub { s/o/x/g; $store_value = $_ }) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"Fred"} = "Joe" ;
+ # fk sk fv sv
+ ok(25, checkOutput( "", "fred", "", "Jxe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(26, $h{"Fred"} eq "[Jxe]");
+ # fk sk fv sv
+ ok(27, checkOutput( "", "fred", "[Jxe]", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(28, $db->FIRSTKEY() eq "FRED") ;
+ # fk sk fv sv
+ ok(29, checkOutput( "FRED", "", "", "")) ;
+
+ # put the original filters back
+ $db->filter_fetch_key ($old_fk);
+ $db->filter_store_key ($old_sk);
+ $db->filter_fetch_value ($old_fv);
+ $db->filter_store_value ($old_sv);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(30, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(31, $h{"fred"} eq "joe");
+ ok(32, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(33, $db->FIRSTKEY() eq "fred") ;
+ ok(34, checkOutput( "fred", "", "", "")) ;
+
+ # delete the filters
+ $db->filter_fetch_key (undef);
+ $db->filter_store_key (undef);
+ $db->filter_fetch_value (undef);
+ $db->filter_store_value (undef);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(35, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(36, $h{"fred"} eq "joe");
+ ok(37, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(38, $db->FIRSTKEY() eq "fred") ;
+ ok(39, checkOutput( "", "", "", "")) ;
+
+ undef $db ;
+ untie %h;
+ unlink <Op.dbmx*>;
+}
+
+{
+ # DBM Filter with a closure
+
+ use strict ;
+ use warnings ;
+ my (%h, $db) ;
+
+ unlink <Op.dbmx*>;
+ ok(40, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+ my %result = () ;
+
+ sub Closure
+ {
+ my ($name) = @_ ;
+ my $count = 0 ;
+ my @kept = () ;
+
+ return sub { ++$count ;
+ push @kept, $_ ;
+ $result{$name} = "$name - $count: [@kept]" ;
+ }
+ }
+
+ $db->filter_store_key(Closure("store key")) ;
+ $db->filter_store_value(Closure("store value")) ;
+ $db->filter_fetch_key(Closure("fetch key")) ;
+ $db->filter_fetch_value(Closure("fetch value")) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ ok(41, $result{"store key"} eq "store key - 1: [fred]");
+ ok(42, $result{"store value"} eq "store value - 1: [joe]");
+ ok(43, !defined $result{"fetch key"} );
+ ok(44, !defined $result{"fetch value"} );
+ ok(45, $_ eq "original") ;
+
+ ok(46, $db->FIRSTKEY() eq "fred") ;
+ ok(47, $result{"store key"} eq "store key - 1: [fred]");
+ ok(48, $result{"store value"} eq "store value - 1: [joe]");
+ ok(49, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(50, ! defined $result{"fetch value"} );
+ ok(51, $_ eq "original") ;
+
+ $h{"jim"} = "john" ;
+ ok(52, $result{"store key"} eq "store key - 2: [fred jim]");
+ ok(53, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(54, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(55, ! defined $result{"fetch value"} );
+ ok(56, $_ eq "original") ;
+
+ ok(57, $h{"fred"} eq "joe");
+ ok(58, $result{"store key"} eq "store key - 3: [fred jim fred]");
+ ok(59, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(60, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(61, $result{"fetch value"} eq "fetch value - 1: [joe]");
+ ok(62, $_ eq "original") ;
+
+ undef $db ;
+ untie %h;
+ unlink <Op.dbmx*>;
+}
+
+{
+ # DBM Filter recursion detection
+ use strict ;
+ use warnings ;
+ my (%h, $db) ;
+ unlink <Op.dbmx*>;
+
+ ok(63, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+ $db->filter_store_key (sub { $_ = $h{$_} }) ;
+
+ eval '$h{1} = 1234' ;
+ ok(64, $@ =~ /^recursion detected in filter_store_key at/ );
+
+ undef $db ;
+ untie %h;
+ unlink <Op.dbmx*>;
+}
+
+{
+ # Bug ID 20001013.009
+ #
+ # test that $hash{KEY} = undef doesn't produce the warning
+ # Use of uninitialized value in null operation
+ use warnings ;
+ use strict ;
+ use NDBM_File ;
+
+ unlink <Op.dbmx*>;
+ my %h ;
+ my $a = "";
+ local $SIG{__WARN__} = sub {$a = $_[0]} ;
+
+ ok(65, tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
+}
--- /dev/null
+#!./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";
+}
--- /dev/null
+#!./perl
+
+# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bODBM_File\b/) {
+ print "1..0 # Skip: ODBM_File was not built\n";
+ exit 0;
+ }
+}
+
+use strict;
+use warnings;
+
+sub ok
+{
+ my $no = shift ;
+ my $result = shift ;
+
+ print "not " unless $result ;
+ print "ok $no\n" ;
+}
+
+require ODBM_File;
+#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
+use Fcntl;
+
+print "1..66\n";
+
+unlink <Op.dbmx*>;
+
+umask(0);
+my %h;
+ok(1, tie(%h,'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640));
+
+my $Dfile = "Op.dbmx.pag";
+if (! -e $Dfile) {
+ ($Dfile) = <Op.dbmx*>;
+}
- if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32') {
++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", <dbhash.tmp*> ;
+
+}
+
+{
+ # DBM Filter tests
+ use strict ;
+ use warnings ;
+ my (%h, $db) ;
+ my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+
+ sub checkOutput
+ {
+ my($fk, $sk, $fv, $sv) = @_ ;
+ print "# ", join('|', $fetch_key, $fk, $store_key, $sk,
+ $fetch_value, $fv, $store_value, $sv, $_), "\n";
+ return
+ $fetch_key eq $fk && $store_key eq $sk &&
+ $fetch_value eq $fv && $store_value eq $sv &&
+ $_ eq 'original' ;
+ }
+
+ unlink <Op.dbmx*>;
+ ok(19, $db = tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+ $db->filter_fetch_key (sub { $fetch_key = $_ }) ;
+ $db->filter_store_key (sub { $store_key = $_ }) ;
+ $db->filter_fetch_value (sub { $fetch_value = $_}) ;
+ $db->filter_store_value (sub { $store_value = $_ }) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ # fk sk fv sv
+ ok(20, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(21, $h{"fred"} eq "joe");
+ # fk sk fv sv
+ ok(22, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(23, $db->FIRSTKEY() eq "fred") ;
+ # fk sk fv sv
+ ok(24, checkOutput( "fred", "", "", "")) ;
+
+ # replace the filters, but remember the previous set
+ my ($old_fk) = $db->filter_fetch_key
+ (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
+ my ($old_sk) = $db->filter_store_key
+ (sub { $_ = lc $_ ; $store_key = $_ }) ;
+ my ($old_fv) = $db->filter_fetch_value
+ (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+ my ($old_sv) = $db->filter_store_value
+ (sub { s/o/x/g; $store_value = $_ }) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"Fred"} = "Joe" ;
+ # fk sk fv sv
+ ok(25, checkOutput( "", "fred", "", "Jxe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(26, $h{"Fred"} eq "[Jxe]");
+ # fk sk fv sv
+ ok(27, checkOutput( "", "fred", "[Jxe]", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(28, $db->FIRSTKEY() eq "FRED") ;
+ # fk sk fv sv
+ ok(29, checkOutput( "FRED", "", "", "")) ;
+
+ # put the original filters back
+ $db->filter_fetch_key ($old_fk);
+ $db->filter_store_key ($old_sk);
+ $db->filter_fetch_value ($old_fv);
+ $db->filter_store_value ($old_sv);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(30, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(31, $h{"fred"} eq "joe");
+ ok(32, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(33, $db->FIRSTKEY() eq "fred") ;
+ ok(34, checkOutput( "fred", "", "", "")) ;
+
+ # delete the filters
+ $db->filter_fetch_key (undef);
+ $db->filter_store_key (undef);
+ $db->filter_fetch_value (undef);
+ $db->filter_store_value (undef);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(35, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(36, $h{"fred"} eq "joe");
+ ok(37, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(38, $db->FIRSTKEY() eq "fred") ;
+ ok(39, checkOutput( "", "", "", "")) ;
+
+ undef $db ;
+ untie %h;
+ unlink <Op.dbmx*>;
+}
+
+{
+ # DBM Filter with a closure
+
+ use strict ;
+ use warnings ;
+ my (%h, $db) ;
+
+ unlink <Op.dbmx*>;
+ ok(40, $db = tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+ my %result = () ;
+
+ sub Closure
+ {
+ my ($name) = @_ ;
+ my $count = 0 ;
+ my @kept = () ;
+
+ return sub { ++$count ;
+ push @kept, $_ ;
+ $result{$name} = "$name - $count: [@kept]" ;
+ }
+ }
+
+ $db->filter_store_key(Closure("store key")) ;
+ $db->filter_store_value(Closure("store value")) ;
+ $db->filter_fetch_key(Closure("fetch key")) ;
+ $db->filter_fetch_value(Closure("fetch value")) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ ok(41, $result{"store key"} eq "store key - 1: [fred]");
+ ok(42, $result{"store value"} eq "store value - 1: [joe]");
+ ok(43, !defined $result{"fetch key"} );
+ ok(44, !defined $result{"fetch value"} );
+ ok(45, $_ eq "original") ;
+
+ ok(46, $db->FIRSTKEY() eq "fred") ;
+ ok(47, $result{"store key"} eq "store key - 1: [fred]");
+ ok(48, $result{"store value"} eq "store value - 1: [joe]");
+ ok(49, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(50, ! defined $result{"fetch value"} );
+ ok(51, $_ eq "original") ;
+
+ $h{"jim"} = "john" ;
+ ok(52, $result{"store key"} eq "store key - 2: [fred jim]");
+ ok(53, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(54, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(55, ! defined $result{"fetch value"} );
+ ok(56, $_ eq "original") ;
+
+ ok(57, $h{"fred"} eq "joe");
+ ok(58, $result{"store key"} eq "store key - 3: [fred jim fred]");
+ ok(59, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(60, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(61, $result{"fetch value"} eq "fetch value - 1: [joe]");
+ ok(62, $_ eq "original") ;
+
+ undef $db ;
+ untie %h;
+ unlink <Op.dbmx*>;
+}
+
+{
+ # DBM Filter recursion detection
+ use strict ;
+ use warnings ;
+ my (%h, $db) ;
+ unlink <Op.dbmx*>;
+
+ ok(63, $db = tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+ $db->filter_store_key (sub { $_ = $h{$_} }) ;
+
+ eval '$h{1} = 1234' ;
+ ok(64, $@ =~ /^recursion detected in filter_store_key at/ );
+
+ undef $db ;
+ untie %h;
+ unlink <Op.dbmx*>;
+}
+
+{
+ # Bug ID 20001013.009
+ #
+ # test that $hash{KEY} = undef doesn't produce the warning
+ # Use of uninitialized value in null operation
+ use warnings ;
+ use strict ;
+ use ODBM_File ;
+
+ unlink <Op.dbmx*>;
+ my %h ;
+ my $a = "";
+ local $SIG{__WARN__} = sub {$a = $_[0]} ;
+
+ ok(65, tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
+ $h{ABC} = undef;
+ ok(66, $a eq "") ;
+ untie %h;
+ unlink <Op.dbmx*>;
+}
+
+if ($^O eq 'hpux') {
+ print <<EOM;
+#
+# If you experience failures with the odbm test in HP-UX,
+# this is a well-known bug that's unfortunately very hard to fix.
+# The suggested course of action is to avoid using the ODBM_File,
+# but to use instead the NDBM_File extension.
+#
+EOM
+}
--- /dev/null
+#!./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::Open2;
+#require 'open2.pl'; use subs 'open2';
+
+my $perl = './perl';
+
+sub ok {
+ my ($n, $result, $info) = @_;
+ if ($result) {
+ print "ok $n\n";
+ }
+ else {
+ print "not ok $n\n";
+ print "# $info\n" if $info;
+ }
+}
+
+sub cmd_line {
- if ($^O eq 'MSWin32') {
++ if ($^O eq 'MSWin32' || $^O eq 'NetWare') {
+ return qq/"$_[0]"/;
+ }
+ else {
+ return $_[0];
+ }
+}
+
+my ($pid, $reaped_pid);
+STDOUT->autoflush;
+STDERR->autoflush;
+
+print "1..7\n";
+
+ok 1, $pid = open2 'READ', 'WRITE', $perl, '-e',
+ cmd_line('print scalar <STDIN>');
+ok 2, print WRITE "hi kid\n";
+ok 3, <READ> =~ /^hi kid\r?\n$/;
+ok 4, close(WRITE), $!;
+ok 5, close(READ), $!;
+$reaped_pid = waitpid $pid, 0;
+ok 6, $reaped_pid == $pid, $reaped_pid;
+ok 7, $? == 0, $?;
--- /dev/null
+#!./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 <STDIN>;
+ print STDERR "hi error\n";
+EOF
+ok 2, print WRITE "hi kid\n";
+ok 3, <READ> =~ /^hi kid\r?\n$/;
+ok 4, <ERROR> =~ /^hi error\r?\n$/;
+ok 5, close(WRITE), $!;
+ok 6, close(READ), $!;
+ok 7, close(ERROR), $!;
+$reaped_pid = waitpid $pid, 0;
+ok 8, $reaped_pid == $pid, $reaped_pid;
+ok 9, $? == 0, $?;
+
+# read and error together, both named
+$pid = open3 'WRITE', 'READ', 'READ', $perl, '-e', cmd_line(<<'EOF');
+ $| = 1;
+ print scalar <STDIN>;
+ print STDERR scalar <STDIN>;
+EOF
+print WRITE "ok 10\n";
+print scalar <READ>;
+print WRITE "ok 11\n";
+print scalar <READ>;
+waitpid $pid, 0;
+
+# read and error together, error empty
+$pid = open3 'WRITE', 'READ', '', $perl, '-e', cmd_line(<<'EOF');
+ $| = 1;
+ print scalar <STDIN>;
+ print STDERR scalar <STDIN>;
+EOF
+print WRITE "ok 12\n";
+print scalar <READ>;
+print WRITE "ok 13\n";
+print scalar <READ>;
+waitpid $pid, 0;
+
+# dup writer
+ok 14, pipe PIPE_READ, PIPE_WRITE;
+$pid = open3 '<&PIPE_READ', 'READ', '',
+ $perl, '-e', cmd_line('print scalar <STDIN>');
+close PIPE_READ;
+print PIPE_WRITE "ok 15\n";
+close PIPE_WRITE;
+print scalar <READ>;
+waitpid $pid, 0;
+
+# dup reader
+$pid = open3 'WRITE', '>&STDOUT', 'ERROR',
+ $perl, '-e', cmd_line('print scalar <STDIN>');
+print WRITE "ok 16\n";
+waitpid $pid, 0;
+
+# dup error: This particular case, duping stderr onto the existing
+# stdout but putting stdout somewhere else, is a good case because it
+# used not to work.
+$pid = open3 'WRITE', 'READ', '>&STDOUT',
+ $perl, '-e', cmd_line('print STDERR scalar <STDIN>');
+print WRITE "ok 17\n";
+waitpid $pid, 0;
+
+# dup reader and error together, both named
+$pid = open3 'WRITE', '>&STDOUT', '>&STDOUT', $perl, '-e', cmd_line(<<'EOF');
+ $| = 1;
+ print STDOUT scalar <STDIN>;
+ print STDERR scalar <STDIN>;
+EOF
+print WRITE "ok 18\n";
+print WRITE "ok 19\n";
+waitpid $pid, 0;
+
+# dup reader and error together, error empty
+$pid = open3 'WRITE', '>&STDOUT', '', $perl, '-e', cmd_line(<<'EOF');
+ $| = 1;
+ print STDOUT scalar <STDIN>;
+ print STDERR scalar <STDIN>;
+EOF
+print WRITE "ok 20\n";
+print WRITE "ok 21\n";
+waitpid $pid, 0;
+
+# command line in single parameter variant of open3
+# for understanding of Config{'sh'} test see exec description in camel book
+my $cmd = 'print(scalar(<STDIN>))';
+$cmd = $Config{'sh'} =~ /sh/ ? "'$cmd'" : cmd_line($cmd);
+eval{$pid = open3 'WRITE', '>&STDOUT', 'ERROR', "$perl -e " . $cmd; };
+if ($@) {
+ print "error $@\n";
+ print "not ok 22\n";
+}
+else {
+ print WRITE "ok 22\n";
+ waitpid $pid, 0;
+}
--- /dev/null
+#!./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);
--- /dev/null
+#!./perl
+
+# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if (($Config{'extensions'} !~ /\bSDBM_File\b/) && ($^O ne 'VMS')){
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+use strict;
+use warnings;
+
+sub ok
+{
+ my $no = shift ;
+ my $result = shift ;
+
+ print "not " unless $result ;
+ print "ok $no\n" ;
+}
+
+require SDBM_File;
+#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
+use Fcntl;
+
+print "1..68\n";
+
+unlink <Op_dbmx.*>;
+
+umask(0);
+my %h ;
+ok(1, tie %h,'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640);
+
+my $Dfile = "Op_dbmx.pag";
+if (! -e $Dfile) {
+ ($Dfile) = <Op_dbmx.*>;
+}
- if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos') {
++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", <dbhash_tmp.*> ;
+
+}
+
+ok(19, !exists $h{'goner1'});
+ok(20, exists $h{'foo'});
+
+untie %h;
+unlink <Op_dbmx*>, $Dfile;
+
+{
+ # DBM Filter tests
+ use strict ;
+ use warnings ;
+ my (%h, $db) ;
+ my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+
+ sub checkOutput
+ {
+ my($fk, $sk, $fv, $sv) = @_ ;
+ return
+ $fetch_key eq $fk && $store_key eq $sk &&
+ $fetch_value eq $fv && $store_value eq $sv &&
+ $_ eq 'original' ;
+ }
+
+ unlink <Op_dbmx*>;
+ ok(21, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+ $db->filter_fetch_key (sub { $fetch_key = $_ }) ;
+ $db->filter_store_key (sub { $store_key = $_ }) ;
+ $db->filter_fetch_value (sub { $fetch_value = $_}) ;
+ $db->filter_store_value (sub { $store_value = $_ }) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ # fk sk fv sv
+ ok(22, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(23, $h{"fred"} eq "joe");
+ # fk sk fv sv
+ ok(24, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(25, $db->FIRSTKEY() eq "fred") ;
+ # fk sk fv sv
+ ok(26, checkOutput( "fred", "", "", "")) ;
+
+ # replace the filters, but remember the previous set
+ my ($old_fk) = $db->filter_fetch_key
+ (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
+ my ($old_sk) = $db->filter_store_key
+ (sub { $_ = lc $_ ; $store_key = $_ }) ;
+ my ($old_fv) = $db->filter_fetch_value
+ (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
+ my ($old_sv) = $db->filter_store_value
+ (sub { s/o/x/g; $store_value = $_ }) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"Fred"} = "Joe" ;
+ # fk sk fv sv
+ ok(27, checkOutput( "", "fred", "", "Jxe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(28, $h{"Fred"} eq "[Jxe]");
+ # fk sk fv sv
+ ok(29, checkOutput( "", "fred", "[Jxe]", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(30, $db->FIRSTKEY() eq "FRED") ;
+ # fk sk fv sv
+ ok(31, checkOutput( "FRED", "", "", "")) ;
+
+ # put the original filters back
+ $db->filter_fetch_key ($old_fk);
+ $db->filter_store_key ($old_sk);
+ $db->filter_fetch_value ($old_fv);
+ $db->filter_store_value ($old_sv);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(32, checkOutput( "", "fred", "", "joe")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(33, $h{"fred"} eq "joe");
+ ok(34, checkOutput( "", "fred", "joe", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(35, $db->FIRSTKEY() eq "fred") ;
+ ok(36, checkOutput( "fred", "", "", "")) ;
+
+ # delete the filters
+ $db->filter_fetch_key (undef);
+ $db->filter_store_key (undef);
+ $db->filter_fetch_value (undef);
+ $db->filter_store_value (undef);
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ $h{"fred"} = "joe" ;
+ ok(37, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(38, $h{"fred"} eq "joe");
+ ok(39, checkOutput( "", "", "", "")) ;
+
+ ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
+ ok(40, $db->FIRSTKEY() eq "fred") ;
+ ok(41, checkOutput( "", "", "", "")) ;
+
+ undef $db ;
+ untie %h;
+ unlink <Op_dbmx*>;
+}
+
+{
+ # DBM Filter with a closure
+
+ use strict ;
+ use warnings ;
+ my (%h, $db) ;
+
+ unlink <Op_dbmx*>;
+ ok(42, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+ my %result = () ;
+
+ sub Closure
+ {
+ my ($name) = @_ ;
+ my $count = 0 ;
+ my @kept = () ;
+
+ return sub { ++$count ;
+ push @kept, $_ ;
+ $result{$name} = "$name - $count: [@kept]" ;
+ }
+ }
+
+ $db->filter_store_key(Closure("store key")) ;
+ $db->filter_store_value(Closure("store value")) ;
+ $db->filter_fetch_key(Closure("fetch key")) ;
+ $db->filter_fetch_value(Closure("fetch value")) ;
+
+ $_ = "original" ;
+
+ $h{"fred"} = "joe" ;
+ ok(43, $result{"store key"} eq "store key - 1: [fred]");
+ ok(44, $result{"store value"} eq "store value - 1: [joe]");
+ ok(45, !defined $result{"fetch key"} );
+ ok(46, !defined $result{"fetch value"} );
+ ok(47, $_ eq "original") ;
+
+ ok(48, $db->FIRSTKEY() eq "fred") ;
+ ok(49, $result{"store key"} eq "store key - 1: [fred]");
+ ok(50, $result{"store value"} eq "store value - 1: [joe]");
+ ok(51, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(52, ! defined $result{"fetch value"} );
+ ok(53, $_ eq "original") ;
+
+ $h{"jim"} = "john" ;
+ ok(54, $result{"store key"} eq "store key - 2: [fred jim]");
+ ok(55, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(56, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(57, ! defined $result{"fetch value"} );
+ ok(58, $_ eq "original") ;
+
+ ok(59, $h{"fred"} eq "joe");
+ ok(60, $result{"store key"} eq "store key - 3: [fred jim fred]");
+ ok(61, $result{"store value"} eq "store value - 2: [joe john]");
+ ok(62, $result{"fetch key"} eq "fetch key - 1: [fred]");
+ ok(63, $result{"fetch value"} eq "fetch value - 1: [joe]");
+ ok(64, $_ eq "original") ;
+
+ undef $db ;
+ untie %h;
+ unlink <Op_dbmx*>;
+}
+
+{
+ # DBM Filter recursion detection
+ use strict ;
+ use warnings ;
+ my (%h, $db) ;
+ unlink <Op_dbmx*>;
+
+ ok(65, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ;
+
+ $db->filter_store_key (sub { $_ = $h{$_} }) ;
+
+ eval '$h{1} = 1234' ;
+ ok(66, $@ =~ /^recursion detected in filter_store_key at/ );
+
+ undef $db ;
+ untie %h;
+ unlink <Op_dbmx*>;
+}
+
+{
+ # Bug ID 20001013.009
+ #
+ # test that $hash{KEY} = undef doesn't produce the warning
+ # Use of uninitialized value in null operation
+ use warnings ;
+ use strict ;
+ use SDBM_File ;
+
+ unlink <Op_dbmx*>;
+ my %h ;
+ my $a = "";
+ local $SIG{__WARN__} = sub {$a = $_[0]} ;
+
+ ok(67, tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ;
+ $h{ABC} = undef;
+ ok(68, $a eq "") ;
+
+ untie %h;
+ unlink <Op_dbmx*>;
+}
--- /dev/null
+#!./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";
+
--- /dev/null
+# 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 <<EOM;
+#
+# If the lfs (large file support: large meaning larger than two
+# gigabytes) tests are skipped or fail, it may mean either that your
+# process (or process group) is not allowed to write large files
+# (resource limits) or that the file system (the network filesystem?)
+# you are running the tests on doesn't let your user/group have large
+# files (quota) or the filesystem simply doesn't support large files.
+# You may even need to reconfigure your kernel. (This is all very
+# operating system and site-dependent.)
+#
+# Perl may still be able to support large files, once you have
+# such a process, enough quota, and such a (file) system.
+# It is just that the test failed now.
+#
+EOM
+ }
+ print "1..0 # Skip: @_\n" if @_;
+}
+
+print "# checking whether we have sparse files...\n";
+
+# Known have-nots.
- if ($^O eq 'MSWin32' || $^O eq 'VMS') {
++if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') {
+ print "1..0 # Skip: no sparse files in $^O\n";
+ bye();
+}
+
+# Known haves that have problems running this test
+# (for example because they do not support sparse files, like UNICOS)
+if ($^O eq 'unicos') {
+ print "1..0 # Skip: no sparse files in $^0, unable to test large files\n";
+ bye();
+}
+
+# Then try heuristically to deduce whether we have sparse files.
+
+# We'll start off by creating a one megabyte file which has
+# only three "true" bytes. If we have sparseness, we should
+# consume less blocks than one megabyte (assuming nobody has
+# one megabyte blocks...)
+
+sysopen(BIG, "big1", O_WRONLY|O_CREAT|O_TRUNC) or
+ do { warn "sysopen big1 failed: $!\n"; bye };
+sysseek(BIG, 1_000_000, SEEK_SET) or
+ do { warn "sysseek big1 failed: $!\n"; bye };
+syswrite(BIG, "big") or
+ do { warn "syswrite big1 failed; $!\n"; bye };
+close(BIG) or
+ do { warn "close big1 failed: $!\n"; bye };
+
+my @s1 = stat("big1");
+
+print "# s1 = @s1\n";
+
+sysopen(BIG, "big2", O_WRONLY|O_CREAT|O_TRUNC) or
+ do { warn "sysopen big2 failed: $!\n"; bye };
+sysseek(BIG, 2_000_000, SEEK_SET) or
+ do { warn "sysseek big2 failed: $!\n"; bye };
+syswrite(BIG, "big") or
+ do { warn "syswrite big2 failed; $!\n"; bye };
+close(BIG) or
+ do { warn "close big2 failed: $!\n"; bye };
+
+my @s2 = stat("big2");
+
+print "# s2 = @s2\n";
+
+zap();
+
+unless ($s1[7] == 1_000_003 && $s2[7] == 2_000_003 &&
+ $s1[11] == $s2[11] && $s1[12] == $s2[12]) {
+ print "1..0 # Skip: no sparse files?\n";
+ bye;
+}
+
+print "# we seem to have sparse files...\n";
+
+# By now we better be sure that we do have sparse files:
+# if we are not, the following will hog 5 gigabytes of disk. Ooops.
+# This may fail by producing some signal; run in a subprocess first for safety
+
+$ENV{LC_ALL} = "C";
+
+my $r = system '../perl', '-I../lib', '-e', <<'EOF';
+use Fcntl qw(/^O_/ /^SEEK_/);
+sysopen(BIG, "big", O_WRONLY|O_CREAT|O_TRUNC) or die $!;
+my $sysseek = sysseek(BIG, 5_000_000_000, SEEK_SET);
+my $syswrite = syswrite(BIG, "big");
+exit 0;
+EOF
+
+sysopen(BIG, "big", O_WRONLY|O_CREAT|O_TRUNC) or
+ do { warn "sysopen 'big' failed: $!\n"; bye };
+my $sysseek = sysseek(BIG, 5_000_000_000, SEEK_SET);
+unless (! $r && defined $sysseek && $sysseek == 5_000_000_000) {
+ $sysseek = 'undef' unless defined $sysseek;
+ explain("seeking past 2GB failed: ",
+ $r ? 'signal '.($r & 0x7f) : "$! (sysseek returned $sysseek)");
+ bye();
+}
+
+# The syswrite will fail if there are are filesize limitations (process or fs).
+my $syswrite = syswrite(BIG, "big");
+print "# syswrite failed: $! (syswrite returned ",
+ defined $syswrite ? $syswrite : 'undef', ")\n"
+ unless defined $syswrite && $syswrite == 3;
+my $close = close BIG;
+print "# close failed: $!\n" unless $close;
+unless($syswrite && $close) {
+ if ($! =~/too large/i) {
+ explain("writing past 2GB failed: process limits?");
+ } elsif ($! =~ /quota/i) {
+ explain("filesystem quota limits?");
+ } else {
+ explain("error: $!");
+ }
+ bye();
+}
+
+@s = stat("big");
+
+print "# @s\n";
+
+unless ($s[7] == 5_000_000_003) {
+ explain("kernel/fs not configured to use large files?");
+ bye();
+}
+
+sub fail () {
+ print "not ";
+ $fail++;
+}
+
+sub offset ($$) {
+ my ($offset_will_be, $offset_want) = @_;
+ my $offset_is = eval $offset_will_be;
+ unless ($offset_is == $offset_want) {
+ print "# bad offset $offset_is, want $offset_want\n";
+ my ($offset_func) = ($offset_will_be =~ /^(\w+)/);
+ if (unpack("L", pack("L", $offset_want)) == $offset_is) {
+ print "# 32-bit wraparound suspected in $offset_func() since\n";
+ print "# $offset_want cast into 32 bits equals $offset_is.\n";
+ } elsif ($offset_want - unpack("L", pack("L", $offset_want)) - 1
+ == $offset_is) {
+ print "# 32-bit wraparound suspected in $offset_func() since\n";
+ printf "# %s - unpack('L', pack('L', %s)) - 1 equals %s.\n",
+ $offset_want,
+ $offset_want,
+ $offset_is;
+ }
+ fail;
+ }
+}
+
+print "1..17\n";
+
+$fail = 0;
+
+fail unless $s[7] == 5_000_000_003; # exercizes pp_stat
+print "ok 1\n";
+
+fail unless -s "big" == 5_000_000_003; # exercizes pp_ftsize
+print "ok 2\n";
+
+fail unless -e "big";
+print "ok 3\n";
+
+fail unless -f "big";
+print "ok 4\n";
+
+sysopen(BIG, "big", O_RDONLY) or do { warn "sysopen failed: $!\n"; bye };
+
+offset('sysseek(BIG, 4_500_000_000, SEEK_SET)', 4_500_000_000);
+print "ok 5\n";
+
+offset('sysseek(BIG, 0, SEEK_CUR)', 4_500_000_000);
+print "ok 6\n";
+
+offset('sysseek(BIG, 1, SEEK_CUR)', 4_500_000_001);
+print "ok 7\n";
+
+offset('sysseek(BIG, 0, SEEK_CUR)', 4_500_000_001);
+print "ok 8\n";
+
+offset('sysseek(BIG, -1, SEEK_CUR)', 4_500_000_000);
+print "ok 9\n";
+
+offset('sysseek(BIG, 0, SEEK_CUR)', 4_500_000_000);
+print "ok 10\n";
+
+offset('sysseek(BIG, -3, SEEK_END)', 5_000_000_000);
+print "ok 11\n";
+
+offset('sysseek(BIG, 0, SEEK_CUR)', 5_000_000_000);
+print "ok 12\n";
+
+my $big;
+
+fail unless sysread(BIG, $big, 3) == 3;
+print "ok 13\n";
+
+fail unless $big eq "big";
+print "ok 14\n";
+
+# 705_032_704 = (I32)5_000_000_000
+# See that we don't have "big" in the 705_... spot:
+# that would mean that we have a wraparound.
+fail unless sysseek(BIG, 705_032_704, SEEK_SET);
+print "ok 15\n";
+
+my $zero;
+
+fail unless read(BIG, $zero, 3) == 3;
+print "ok 16\n";
+
+fail unless $zero eq "\0\0\0";
+print "ok 17\n";
+
+explain() if $fail;
+
+bye(); # does the necessary cleanup
+
+END {
+ unlink "big"; # be paranoid about leaving 5 gig files lying around
+}
+
+# eof
--- /dev/null
+#!./perl -wT
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ unshift @INC, '.';
+ require Config; import Config;
+ if (!$Config{d_setlocale} || $Config{ccflags} =~ /\bD?NO_LOCALE\b/) {
+ print "1..0\n";
+ exit;
+ }
+ $| = 1;
+}
+
+use strict;
+
+my $debug = 1;
+
+use Dumpvalue;
+
+my $dumper = Dumpvalue->new(
+ tick => qq{"},
+ quoteHighBit => 0,
+ unctrl => "quote"
+ );
+sub debug {
+ return unless $debug;
+ my($mess) = join "", @_;
+ chop $mess;
+ print $dumper->stringify($mess,1), "\n";
+}
+
+sub debugf {
+ printf @_ if $debug;
+}
+
+my $have_setlocale = 0;
+eval {
+ require POSIX;
+ import POSIX ':locale_h';
+ $have_setlocale++;
+};
+
+# Visual C's CRT goes silly on strings of the form "en_US.ISO8859-1"
+# and mingw32 uses said silly CRT
- $have_setlocale = 0 if $^O eq 'MSWin32' && $Config{cc} =~ /^(cl|gcc)/i;
++$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 = <<EOF;
+Afrikaans:af:za:1 15
+Arabic:ar:dz eg sa:6 arabic8
+Brezhoneg Breton:br:fr:1 15
+Bulgarski Bulgarian:bg:bg:5
+Chinese:zh:cn tw:cn.EUC eucCN eucTW euc.CN euc.TW Big5 GB2312 tw.EUC
+Hrvatski Croatian:hr:hr:2
+Cymraeg Welsh:cy:cy:1 14 15
+Czech:cs:cz:2
+Dansk Danish:dk:da:1 15
+Nederlands Dutch:nl:be nl:1 15
+English American British:en:au ca gb ie nz us uk zw:1 15 cp850
+Esperanto:eo:eo:3
+Eesti Estonian:et:ee:4 6 13
+Suomi Finnish:fi:fi:1 15
+Flamish::fl:1 15
+Deutsch German:de:at be ch de lu:1 15
+Euskaraz Basque:eu:es fr:1 15
+Galego Galician:gl:es:1 15
+Ellada Greek:el:gr:7 g8
+Frysk:fy:nl:1 15
+Greenlandic:kl:gl:4 6
+Hebrew:iw:il:8 hebrew8
+Hungarian:hu:hu:2
+Indonesian:in:id:1 15
+Gaeilge Irish:ga:IE:1 14 15
+Italiano Italian:it:ch it:1 15
+Nihongo Japanese:ja:jp:euc eucJP jp.EUC sjis
+Korean:ko:kr:
+Latine Latin:la:va:1 15
+Latvian:lv:lv:4 6 13
+Lithuanian:lt:lt:4 6 13
+Macedonian:mk:mk:1 15
+Maltese:mt:mt:3
+Moldovan:mo:mo:2
+Norsk Norwegian:no no\@nynorsk:no:1 15
+Occitan:oc:es:1 15
+Polski Polish:pl:pl:2
+Rumanian:ro:ro:2
+Russki Russian:ru:ru su ua:5 koi8 koi8r KOI8-R koi8u cp1251 cp866
+Serbski Serbian:sr:yu:5
+Slovak:sk:sk:2
+Slovene Slovenian:sl:si:2
+Sqhip Albanian:sq:sq:1 15
+Svenska Swedish:sv:fi se:1 15
+Thai:th:th:11 tis620
+Turkish:tr:tr:9 turkish8
+Yiddish:yi::1 15
+EOF
+
+if ($^O eq 'os390') {
+ # These cause heartburn. Broken locales?
+ $locales =~ s/Svenska Swedish:sv:fi se:1 15\n//;
+ $locales =~ s/Thai:th:th:11 tis620\n//;
+}
+
+sub in_utf8 () { $^H & 0x08 }
+
+if (in_utf8) {
+ require "pragma/locale/utf8";
+} else {
+ require "pragma/locale/latin1";
+}
+
+my @Locale;
+my $Locale;
+my @Alnum_;
+
+my @utf8locale;
+my %utf8skip;
+
+sub getalnum_ {
+ sort grep /\w/, map { chr } 0..255
+}
+
+sub trylocale {
+ my $locale = shift;
+ if (setlocale(LC_ALL, $locale)) {
+ push @Locale, $locale;
+ }
+}
+
+sub decode_encodings {
+ my @enc;
+
+ foreach (split(/ /, shift)) {
+ if (/^(\d+)$/) {
+ push @enc, "ISO8859-$1";
+ push @enc, "iso8859$1"; # HP
+ if ($1 eq '1') {
+ push @enc, "roman8"; # HP
+ }
+ } else {
+ push @enc, $_;
+ push @enc, "$_.UTF-8";
+ }
+ }
+ if ($^O eq 'os390') {
+ push @enc, qw(IBM-037 IBM-819 IBM-1047);
+ }
+
+ return @enc;
+}
+
+trylocale("C");
+trylocale("POSIX");
+foreach (0..15) {
+ trylocale("ISO8859-$_");
+ trylocale("iso8859$_");
+ trylocale("iso8859-$_");
+ trylocale("iso_8859_$_");
+ trylocale("isolatin$_");
+ trylocale("isolatin-$_");
+ trylocale("iso_latin_$_");
+}
+
+# Sanitize the environment so that we can run the external 'locale'
+# program without the taint mode getting grumpy.
+
+# $ENV{PATH} is special in VMS.
+delete $ENV{PATH} if $^O ne 'VMS' or $Config{d_setenv};
+
+# Other subversive stuff.
+delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
+
+if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a 2>/dev/null|")) {
+ while (<LOCALES>) {
+ chomp;
+ trylocale($_);
+ }
+ close(LOCALES);
+} elsif ($^O eq 'VMS' && defined($ENV{'SYS$I18N_LOCALE'}) && -d 'SYS$I18N_LOCALE') {
+# The SYS$I18N_LOCALE logical name search list was not present on
+# VAX VMS V5.5-12, but was on AXP && VAX VMS V6.2 as well as later versions.
+ opendir(LOCALES, "SYS\$I18N_LOCALE:");
+ while ($_ = readdir(LOCALES)) {
+ chomp;
+ trylocale($_);
+ }
+ close(LOCALES);
+} else {
+
+ # This is going to be slow.
+
+ foreach my $locale (split(/\n/, $locales)) {
+ my ($locale_name, $language_codes, $country_codes, $encodings) =
+ split(/:/, $locale);
+ my @enc = decode_encodings($encodings);
+ foreach my $loc (split(/ /, $locale_name)) {
+ trylocale($loc);
+ foreach my $enc (@enc) {
+ trylocale("$loc.$enc");
+ }
+ $loc = lc $loc;
+ foreach my $enc (@enc) {
+ trylocale("$loc.$enc");
+ }
+ }
+ foreach my $lang (split(/ /, $language_codes)) {
+ trylocale($lang);
+ foreach my $country (split(/ /, $country_codes)) {
+ my $lc = "${lang}_${country}";
+ trylocale($lc);
+ foreach my $enc (@enc) {
+ trylocale("$lc.$enc");
+ }
+ my $lC = "${lang}_\U${country}";
+ trylocale($lC);
+ foreach my $enc (@enc) {
+ trylocale("$lC.$enc");
+ }
+ }
+ }
+ }
+}
+
+setlocale(LC_ALL, "C");
+
+sub utf8locale { $_[0] =~ /utf-?8/i }
+
+@Locale = sort @Locale;
+
+debug "# Locales = @Locale\n";
+
+my %Problem;
+my %Okay;
+my %Testing;
+my @Neoalpha;
+my %Neoalpha;
+
+sub tryneoalpha {
+ my ($Locale, $i, $test) = @_;
+ unless ($test) {
+ $Problem{$i}{$Locale} = 1;
+ debug "# failed $i with locale '$Locale'\n";
+ } else {
+ push @{$Okay{$i}}, $Locale;
+ }
+}
+
+foreach $Locale (@Locale) {
+ debug "# Locale = $Locale\n";
+ @Alnum_ = getalnum_();
+ debug "# w = ", join("",@Alnum_), "\n";
+
+ unless (setlocale(LC_ALL, $Locale)) {
+ foreach (99..103) {
+ $Problem{$_}{$Locale} = -1;
+ }
+ next;
+ }
+
+ # Sieve the uppercase and the lowercase.
+
+ my %UPPER = ();
+ my %lower = ();
+ my %BoThCaSe = ();
+ for (@Alnum_) {
+ if (/[^\d_]/) { # skip digits and the _
+ if (uc($_) eq $_) {
+ $UPPER{$_} = $_;
+ }
+ if (lc($_) eq $_) {
+ $lower{$_} = $_;
+ }
+ }
+ }
+ foreach (keys %UPPER) {
+ $BoThCaSe{$_}++ if exists $lower{$_};
+ }
+ foreach (keys %lower) {
+ $BoThCaSe{$_}++ if exists $UPPER{$_};
+ }
+ foreach (keys %BoThCaSe) {
+ delete $UPPER{$_};
+ delete $lower{$_};
+ }
+
+ debug "# UPPER = ", join("", sort keys %UPPER ), "\n";
+ debug "# lower = ", join("", sort keys %lower ), "\n";
+ debug "# BoThCaSe = ", join("", sort keys %BoThCaSe), "\n";
+
+ # Find the alphabets that are not alphabets in the default locale.
+
+ {
+ no locale;
+
+ @Neoalpha = ();
+ for (keys %UPPER, keys %lower) {
+ push(@Neoalpha, $_) if (/\W/);
+ $Neoalpha{$_} = $_;
+ }
+ }
+
+ @Neoalpha = sort @Neoalpha;
+
+ debug "# Neoalpha = ", join("",@Neoalpha), "\n";
+
+ if (@Neoalpha == 0) {
+ # If we have no Neoalphas the remaining tests are no-ops.
+ debug "# no Neoalpha, skipping tests 99..102 for locale '$Locale'\n";
+ foreach (99..102) {
+ push @{$Okay{$_}}, $Locale;
+ }
+ } else {
+
+ # Test \w.
+
+ if (utf8locale($Locale)) {
+ # 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 <<EOW;
+#
+# If your users are not using these locales you are safe for the moment,
+# but please report this failure first to perlbug\@perl.com using the
+# perlbug script (as described in the INSTALL file) so that the exact
+# details of the failures can be sorted out first and then your operating
+# system supplier can be alerted about these anomalies.
+#
+EOW
+ $didwarn = 1;
+ }
+}
+
+# Tell which locales were okay and which were not.
+
+if ($didwarn) {
+ my (@s, @F);
+
+ foreach my $l (@Locale) {
+ my $p = 0;
+ foreach my $t (102..$last) {
+ $p++ if $Problem{$t}{$l};
+ }
+ push @s, $l if $p == 0;
+ push @F, $l unless $p == 0;
+ }
+
+ if (@s) {
+ my $s = join(" ", @s);
+ $s =~ s/(.{50,60}) /$1\n#\t/g;
+
+ warn
+ "# The following locales\n#\n",
+ "#\t", $s, "\n#\n",
+ "# tested okay.\n#\n",
+ } else {
+ warn "# None of your locales were fully okay.\n";
+ }
+
+ if (@F) {
+ my $F = join(" ", @F);
+ $F =~ s/(.{50,60}) /$1\n#\t/g;
+
+ warn
+ "# The following locales\n#\n",
+ "#\t", $F, "\n#\n",
+ "# had problems.\n#\n",
+ } else {
+ warn "# None of your locales were broken.\n";
+ }
+
+ if (@utf8locale) {
+ my $S = join(" ", @utf8locale);
+ $S =~ s/(.{50,60}) /$1\n#\t/g;
+
+ warn "#\n# The following locales\n#\n",
+ "#\t", $S, "\n#\n",
+ "# were skipped for the tests ",
+ join(" ", sort {$a<=>$b} keys %utf8skip), "\n",
+ "# because UTF-8 and locales do not work together in Perl.\n#\n";
+ }
+}
+
+sub last { 117 }
+
+# eof
--- /dev/null
+#!./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 (<F>) {
+ last if /^__END__/ ;
+ }
+
+ {
+ local $/ = undef;
+ @prgs = (@prgs, split "\n########\n", <F>) ;
+ }
+ close F ;
+}
+
+undef $/;
+
+print "1..", scalar @prgs, "\n";
+
+
+for (@prgs){
+ my $switch = "";
+ my @temps = () ;
+ if (s/^\s*-\w+//){
+ $switch = $&;
+ }
+ my($prog,$expected) = split(/\nEXPECT\n/, $_);
+ if ( $prog =~ /--FILE--/) {
+ my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ;
+ shift @files ;
+ die "Internal error test $i didn't split into pairs, got " .
+ scalar(@files) . "[" . join("%%%%", @files) ."]\n"
+ if @files % 2 ;
+ while (@files > 2) {
+ my $filename = shift @files ;
+ my $code = shift @files ;
+ $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 $_ }
+}
--- /dev/null
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ $ENV{PERL5LIB} = '../lib';
+}
+
+$| = 1;
+undef $/;
+my @prgs = split "\n########\n", <DATA>;
+print "1..", scalar @prgs, "\n";
+
+my $Is_VMS = $^O eq 'VMS';
+my $Is_MSWin32 = $^O eq 'MSWin32';
++my $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
--- /dev/null
+ 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
+
--- /dev/null
+#!./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 (<F>) {
+ $line++;
+ last if /^__END__/ ;
+ }
+
+ {
+ local $/ = undef;
+ $files++;
+ @prgs = (@prgs, $file, split "\n########\n", <F>) ;
+ }
+ 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 $_ }
+}
projects / p5sagit/p5-mst-13.2.git / commitdiff