diff options
| author | Nick Ing-Simmons <nik@tiuk.ti.com> | 2001-06-18 08:05:29 +0000 |
|---|---|---|
| committer | Nick Ing-Simmons <nik@tiuk.ti.com> | 2001-06-18 08:05:29 +0000 |
| commit | a76697bcbef23e3bb9e08f95279d83f8e0a826a6 (patch) | |
| tree | 54a8aefd6e8b9c378f35167456a90786449cac22 /t | |
| parent | 370a0481ecee92d75bbc6f38ccbbfa820fff9abb (diff) | |
| parent | b695f709e8a342e35e482b0437eb6cdacdc58b6b (diff) | |
| download | perl-a76697bcbef23e3bb9e08f95279d83f8e0a826a6.tar.gz | |
Integrate mainline (part2 - the deletes)
p4raw-id: //depot/perlio@10678
Diffstat (limited to 't')
36 files changed, 0 insertions, 12429 deletions
diff --git a/t/lib/anydbm.t b/t/lib/anydbm.t deleted file mode 100755 index 30b3c7ac14..0000000000 --- a/t/lib/anydbm.t +++ /dev/null @@ -1,155 +0,0 @@ -#!./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' || $^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; -} diff --git a/t/lib/b-stash.t b/t/lib/b-stash.t deleted file mode 100644 index bc9d896927..0000000000 --- a/t/lib/b-stash.t +++ /dev/null @@ -1,60 +0,0 @@ -#!./perl - -BEGIN { - if ($^O eq 'MacOS') { - @INC = qw(: ::lib ::macos:lib); - } -} - -$| = 1; -use warnings; -use strict; -use Config; - -print "1..1\n"; - -my $test = 1; - -sub ok { print "ok $test\n"; $test++ } - - -my $a; -my $Is_VMS = $^O eq 'VMS'; -my $Is_MacOS = $^O eq 'MacOS'; - -my $path = join " ", map { qq["-I$_"] } @INC; -my $redir = $Is_MacOS ? "" : "2>&1"; - - -chomp($a = `$^X $path "-MB::Stash" "-Mwarnings" -e1`); -$a = join ',', sort split /,/, $a; -$a =~ s/-u(PerlIO|open)(?:::\w+)?,//g if defined $Config{'useperlio'} and $Config{'useperlio'} eq 'define'; -$a =~ s/-uWin32,// if $^O eq 'MSWin32'; -$a =~ s/-uNetWare,// if $^O eq 'NetWare'; -$a =~ s/-u(Cwd|File|File::Copy|OS2),//g if $^O eq 'os2'; -$a =~ s/-uCwd,// if $^O eq 'cygwin'; - $b = '-uCarp,-uCarp::Heavy,-uDB,-uExporter,-uExporter::Heavy,-uattributes,' - . '-umain,-ustrict,-uutf8,-uwarnings'; -if ($Is_VMS) { - $a =~ s/-uFile,-uFile::Copy,//; - $a =~ s/-uVMS,-uVMS::Filespec,//; - $a =~ s/-uSocket,//; # Socket is optional/compiler version dependent -} - -{ - no strict 'vars'; - use vars '$OS2::is_aout'; -} -if (($Config{static_ext} eq ' ' || - ($Config{static_ext} eq 'Socket' && $Is_VMS)) - && !($^O eq 'os2' and $OS2::is_aout) - ) { - if (ord('A') == 193) { # EBCDIC sort order is qw(a A) not qw(A a) - $b = join ',', sort split /,/, $b; - } - print "# [$a]\n# vs.\n# [$b]\nnot " if $a ne $b; - ok; -} else { - print "ok $test # skipped: one or more static extensions\n"; $test++; -} - diff --git a/t/lib/bigfltpm.t b/t/lib/bigfltpm.t deleted file mode 100755 index e8de58d871..0000000000 --- a/t/lib/bigfltpm.t +++ /dev/null @@ -1,708 +0,0 @@ -#!/usr/bin/perl -w - -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; - -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 - -# 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'); - } - -__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 -123.456a:NaN -123.456:123.456 -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 --123456E-2:-1234.56 -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 -+123.456789:-123.456789 --123456.789:123456.789 -&fabs -abc:NaN -+0:0 -+1:1 --1:1 -+123456789:123456789 --123456789:123456789 -+123.456789:123.456789 --123456.789:123456.789 -&fround -$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 -$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 -$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 -$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 -$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 -$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 -$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 -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 -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 -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 -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 -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 --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 -&fsub -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:0 -+1:+0:1 -+0:+1:-1 -+1:+1:0 --1:+0:-1 -+0:-1:1 --1:-1:0 --1:+1:-2 -+1:-1:2 -+9:+1:8 -+99:+1:98 -+999:+1:998 -+9999:+1:9998 -+99999:+1:99998 -+999999:+1:999998 -+9999999:+1:9999998 -+99999999:+1:99999998 -+999999999:+1:999999998 -+9999999999:+1:9999999998 -+99999999999:+1:99999999998 -+10:-1:11 -+100:-1:101 -+1000:-1:1001 -+10000:-1:10001 -+100000:-1:100001 -+1000000:-1:1000001 -+10000000:-1:10000001 -+100000000:-1:100000001 -+1000000000:-1:1000000001 -+10000000000:-1:10000000001 -+123456789:+987654321:-864197532 --123456789:+987654321:-1111111110 --123456789:-987654321:864197532 -+123456789:-987654321:1111111110 -&fmul -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:0 -+0:+1:0 -+1:+0:0 -+0:-1:0 --1:+0:0 -+123456789123456789:+0:0 -+0:+123456789123456789:0 --1:-1:1 --1:+1:-1 -+1:-1:-1 -+1:+1:1 -+2:+3:6 --2:+3:-6 -+2:-3:-6 --2:-3:6 -+111:+111:12321 -+10101:+10101:102030201 -+1001001:+1001001:1002003002001 -+100010001:+100010001:10002000300020001 -+10000100001:+10000100001:100002000030000200001 -+11111111111:+9:99999999999 -+22222222222:+9:199999999998 -+33333333333:+9:299999999997 -+44444444444:+9:399999999996 -+55555555555:+9:499999999995 -+66666666666:+9:599999999994 -+77777777777:+9:699999999993 -+88888888888:+9:799999999992 -+99999999999:+9:899999999991 -&fdiv -$div_scale = 40; $Math::BigFloat::rnd_mode = 'even' -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.5 -+2:+1:2 -+10:+5:2 -+100:+4:25 -+1000:+8:125 -+10000:+16:625 -+10000:-16:-625 -+999999999999:+9:111111111111 -+999999999999:+99:10101010101 -+999999999999:+999:1001001001 -+999999999999:+9999:100010001 -+999999999999999:+99999:10000100001 -+1000000000:+9:111111111.1111111111111111111111111111111 -+2000000000:+9:222222222.2222222222222222222222222222222 -+3000000000:+9:333333333.3333333333333333333333333333333 -+4000000000:+9:444444444.4444444444444444444444444444444 -+5000000000:+9:555555555.5555555555555555555555555555556 -+6000000000:+9:666666666.6666666666666666666666666666667 -+7000000000:+9:777777777.7777777777777777777777777777778 -+8000000000:+9:888888888.8888888888888888888888888888889 -+9000000000:+9:1000000000 -+35500000:+113:314159.2920353982300884955752212389380531 -+71000000:+226:314159.2920353982300884955752212389380531 -+106500000:+339:314159.2920353982300884955752212389380531 -+1000000000:+3:333333333.3333333333333333333333333333333 -$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 -# 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 -$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 -&fsqrt -+0:0 --1:NaN --2:NaN --16:NaN --123.45:NaN -+1:1 -#+1.44:1.2 -#+2:1.41421356237309504880168872420969807857 -#+4:2 -#+16:4 -#+100:10 -#+123.456:11.11107555549866648462149404118219234119 -#+15241.38393:123.456 -&is_odd -abc:0 -0:0 --1:1 --3:1 -1:1 -3:1 -1000001:1 -1000002:0 -2:0 -&is_even -abc:0 -0:1 --1:0 --3:0 -1:0 -3:0 -1000001:0 -1000002:1 -2:1 -&is_zero -NaNzero:0 -0:1 --1:0 -1:0 -&is_one -0:0 -2:0 -1:1 --1:0 --2:0 -&_set -NaN:2:2 -2:abc:NaN -1:-1:-1 -2:1:1 --2:0:0 -128:-2:-2 -&bfloor -0:0 -abc:NaN -+inf:+inf --inf:-inf -1:1 --51:-51 --51.2:-52 -12.2:12 -&bceil -0:0 -abc:NaN -+inf:+inf --inf:-inf -1:1 --51:-51 --51.2:-51 -12.2:13 diff --git a/t/lib/bigintpm.t b/t/lib/bigintpm.t deleted file mode 100755 index f819104885..0000000000 --- a/t/lib/bigintpm.t +++ /dev/null @@ -1,1238 +0,0 @@ -#!/usr/bin/perl -w - -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; - -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; - } - -__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 -+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 -+1034:+804:+2 -+27:+90:+56:+1 -+27:+90:+54:+9 -&blcm -abc:abc: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 -&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 --2:-2 -2:2 -3:3 -abc:NaN -&bceil -0:0 --1:-1 --2:-2 -2:2 -3:3 -abc:NaN diff --git a/t/lib/cwd.t b/t/lib/cwd.t deleted file mode 100644 index 09b45d6004..0000000000 --- a/t/lib/cwd.t +++ /dev/null @@ -1,134 +0,0 @@ -#!./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" || $^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' || $^O eq "NetWare"); - # DCL SHOW DEFAULT has leading spaces - $start =~ s/^\s+// if $^O eq 'VMS'; - if ($?) { - for (3..6) { - print "ok $_ # Skip: '$pwd_cmd' failed\n"; - } - } else { - my $cwd = cwd; - my $getcwd = getcwd; - my $fastcwd = fastcwd; - my $fastgetcwd = fastgetcwd; - print +($cwd eq $start ? "" : "not "), "ok 3\n"; - print +($getcwd eq $start ? "" : "not "), "ok 4\n"; - print +($fastcwd eq $start ? "" : "not "), "ok 5\n"; - print +($fastgetcwd eq $start ? "" : "not "), "ok 6\n"; - } -} else { - for (3..6) { - print "ok $_ # Skip: no pwd command found\n"; - } -} - -mkdir "pteerslt", 0777; -mkdir "pteerslt/path", 0777; -mkdir "pteerslt/path/to", 0777; -mkdir "pteerslt/path/to/a", 0777; -mkdir "pteerslt/path/to/a/dir", 0777; -Cwd::chdir "pteerslt/path/to/a/dir"; -my $cwd = cwd; -my $getcwd = getcwd; -my $fastcwd = fastcwd; -my $fastgetcwd = fastgetcwd; -my $want = "t/pteerslt/path/to/a/dir"; -print "# cwd = '$cwd'\n"; -print "# getcwd = '$getcwd'\n"; -print "# fastcwd = '$fastcwd'\n"; -print "# fastgetcwd = '$fastgetcwd'\n"; -# This checked out OK on ODS-2 and ODS-5: -$want = "T\.PTEERSLT\.PATH\.TO\.A\.DIR\]" if $^O eq 'VMS'; -print +($cwd =~ m|$want$| ? "" : "not "), "ok 7\n"; -print +($getcwd =~ m|$want$| ? "" : "not "), "ok 8\n"; -print +($fastcwd =~ m|$want$| ? "" : "not "), "ok 9\n"; -print +($fastgetcwd =~ m|$want$| ? "" : "not "), "ok 10\n"; - -# Cwd::chdir should also update $ENV{PWD} -print "#$ENV{PWD}\n"; -print +($ENV{PWD} =~ m|$want$| ? "" : "not "), "ok 11\n"; -Cwd::chdir ".."; rmdir "dir"; -print "#$ENV{PWD}\n"; -Cwd::chdir ".."; rmdir "a"; -print "#$ENV{PWD}\n"; -Cwd::chdir ".."; rmdir "to"; -print "#$ENV{PWD}\n"; -Cwd::chdir ".."; rmdir "path"; -print "#$ENV{PWD}\n"; -Cwd::chdir ".."; rmdir "pteerslt"; -print "#$ENV{PWD}\n"; -if ($^O eq 'VMS') { - # This checked out OK on ODS-2 and ODS-5: - print +($ENV{PWD} =~ m|\bT\]$| ? "" : "not "), "ok 12\n"; -} -else { - print +($ENV{PWD} =~ m|\bt$| ? "" : "not "), "ok 12\n"; -} - -if ($Config{d_symlink}) { - mkdir "pteerslt", 0777; - mkdir "pteerslt/path", 0777; - mkdir "pteerslt/path/to", 0777; - mkdir "pteerslt/path/to/a", 0777; - mkdir "pteerslt/path/to/a/dir", 0777; - symlink "pteerslt/path/to/a/dir" => "linktest"; - - my $abs_path = Cwd::abs_path("linktest"); - my $fast_abs_path = Cwd::fast_abs_path("linktest"); - my $want = "t/pteerslt/path/to/a/dir"; - - print "# abs_path $abs_path\n"; - print "# fast_abs_path $fast_abs_path\n"; - print "# want $want\n"; - print +($abs_path =~ m|$want$| ? "" : "not "), "ok 13\n"; - print +($fast_abs_path =~ m|$want$| ? "" : "not "), "ok 14\n"; - - rmdir "pteerslt/path/to/a/dir"; - rmdir "pteerslt/path/to/a"; - rmdir "pteerslt/path/to"; - rmdir "pteerslt/path"; - rmdir "pteerslt"; - unlink "linktest"; -} else { - print "ok 13 # skipped\n"; - print "ok 14 # skipped\n"; -} diff --git a/t/lib/db-btree.t b/t/lib/db-btree.t deleted file mode 100755 index 4b4a7967ee..0000000000 --- a/t/lib/db-btree.t +++ /dev/null @@ -1,1296 +0,0 @@ -#!./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' || $^O eq 'NetWare'); - -my ($key, $value, $i); -while (($key,$value) = each(%h)) { - $i++; -} -ok(21, !$i ) ; - -$h{'goner1'} = 'snork'; - -$h{'abc'} = 'ABC'; -ok(22, $h{'abc'} eq 'ABC' ); -ok(23, ! defined $h{'jimmy'} ) ; -ok(24, ! exists $h{'jimmy'} ) ; -ok(25, defined $h{'abc'} ) ; - -$h{'def'} = 'DEF'; -$h{'jkl','mno'} = "JKL\034MNO"; -$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); -$h{'a'} = 'A'; - -#$h{'b'} = 'B'; -$X->STORE('b', 'B') ; - -$h{'c'} = 'C'; - -#$h{'d'} = 'D'; -$X->put('d', 'D') ; - -$h{'e'} = 'E'; -$h{'f'} = 'F'; -$h{'g'} = 'X'; -$h{'h'} = 'H'; -$h{'i'} = 'I'; - -$h{'goner2'} = 'snork'; -delete $h{'goner2'}; - - -# IMPORTANT - $X must be undefined before the untie otherwise the -# underlying DB close routine will not get called. -undef $X ; -untie(%h); - -# tie to the same file again -ok(26, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE)) ; - -# Modify an entry from the previous tie -$h{'g'} = 'G'; - -$h{'j'} = 'J'; -$h{'k'} = 'K'; -$h{'l'} = 'L'; -$h{'m'} = 'M'; -$h{'n'} = 'N'; -$h{'o'} = 'O'; -$h{'p'} = 'P'; -$h{'q'} = 'Q'; -$h{'r'} = 'R'; -$h{'s'} = 'S'; -$h{'t'} = 'T'; -$h{'u'} = 'U'; -$h{'v'} = 'V'; -$h{'w'} = 'W'; -$h{'x'} = 'X'; -$h{'y'} = 'Y'; -$h{'z'} = 'Z'; - -$h{'goner3'} = 'snork'; - -delete $h{'goner1'}; -$X->DELETE('goner3'); - -my @keys = keys(%h); -my @values = values(%h); - -ok(27, $#keys == 29 && $#values == 29) ; - -$i = 0 ; -while (($key,$value) = each(%h)) { - if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { - $key =~ y/a-z/A-Z/; - $i++ if $key eq $value; - } -} - -ok(28, $i == 30) ; - -@keys = ('blurfl', keys(%h), 'dyick'); -ok(29, $#keys == 31) ; - -#Check that the keys can be retrieved in order -my @b = keys %h ; -my @c = sort lexical @b ; -ok(30, ArrayCompare(\@b, \@c)) ; - -$h{'foo'} = ''; -ok(31, $h{'foo'} eq '' ) ; - -# Berkeley DB from version 2.4.10 to 3.0 does not allow null keys. -# This feature was reenabled in version 3.1 of Berkeley DB. -my $result = 0 ; -if ($null_keys_allowed) { - $h{''} = 'bar'; - $result = ( $h{''} eq 'bar' ); -} -else - { $result = 1 } -ok(32, $result) ; - -# check cache overflow and numeric keys and contents -my $ok = 1; -for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } -for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } -ok(33, $ok); - -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); -ok(34, $size > 0 ); - -@h{0..200} = 200..400; -my @foo = @h{0..200}; -ok(35, join(':',200..400) eq join(':',@foo) ); - -# Now check all the non-tie specific stuff - - -# Check R_NOOVERWRITE flag will make put fail when attempting to overwrite -# an existing record. - -my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; -ok(36, $status == 1 ); - -# check that the value of the key 'x' has not been changed by the -# previous test -ok(37, $h{'x'} eq 'X' ); - -# standard put -$status = $X->put('key', 'value') ; -ok(38, $status == 0 ); - -#check that previous put can be retrieved -$value = 0 ; -$status = $X->get('key', $value) ; -ok(39, $status == 0 ); -ok(40, $value eq 'value' ); - -# Attempting to delete an existing key should work - -$status = $X->del('q') ; -ok(41, $status == 0 ); -if ($null_keys_allowed) { - $status = $X->del('') ; -} else { - $status = 0 ; -} -ok(42, $status == 0 ); - -# Make sure that the key deleted, cannot be retrieved -ok(43, ! defined $h{'q'}) ; -ok(44, ! defined $h{''}) ; - -undef $X ; -untie %h ; - -ok(45, $X = tie(%h, 'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE )); - -# Attempting to delete a non-existant key should fail - -$status = $X->del('joe') ; -ok(46, $status == 1 ); - -# Check the get interface - -# First a non-existing key -$status = $X->get('aaaa', $value) ; -ok(47, $status == 1 ); - -# Next an existing key -$status = $X->get('a', $value) ; -ok(48, $status == 0 ); -ok(49, $value eq 'A' ); - -# seq -# ### - -# use seq to find an approximate match -$key = 'ke' ; -$value = '' ; -$status = $X->seq($key, $value, R_CURSOR) ; -ok(50, $status == 0 ); -ok(51, $key eq 'key' ); -ok(52, $value eq 'value' ); - -# seq when the key does not match -$key = 'zzz' ; -$value = '' ; -$status = $X->seq($key, $value, R_CURSOR) ; -ok(53, $status == 1 ); - - -# use seq to set the cursor, then delete the record @ the cursor. - -$key = 'x' ; -$value = '' ; -$status = $X->seq($key, $value, R_CURSOR) ; -ok(54, $status == 0 ); -ok(55, $key eq 'x' ); -ok(56, $value eq 'X' ); -$status = $X->del(0, R_CURSOR) ; -ok(57, $status == 0 ); -$status = $X->get('x', $value) ; -ok(58, $status == 1 ); - -# ditto, but use put to replace the key/value pair. -$key = 'y' ; -$value = '' ; -$status = $X->seq($key, $value, R_CURSOR) ; -ok(59, $status == 0 ); -ok(60, $key eq 'y' ); -ok(61, $value eq 'Y' ); - -$key = "replace key" ; -$value = "replace value" ; -$status = $X->put($key, $value, R_CURSOR) ; -ok(62, $status == 0 ); -ok(63, $key eq 'replace key' ); -ok(64, $value eq 'replace value' ); -$status = $X->get('y', $value) ; -ok(65, 1) ; # hard-wire to always pass. the previous test ($status == 1) - # only worked because of a bug in 1.85/6 - -# use seq to walk forwards through a file - -$status = $X->seq($key, $value, R_FIRST) ; -ok(66, $status == 0 ); -my $previous = $key ; - -$ok = 1 ; -while (($status = $X->seq($key, $value, R_NEXT)) == 0) -{ - ($ok = 0), last if ($previous cmp $key) == 1 ; -} - -ok(67, $status == 1 ); -ok(68, $ok == 1 ); - -# use seq to walk backwards through a file -$status = $X->seq($key, $value, R_LAST) ; -ok(69, $status == 0 ); -$previous = $key ; - -$ok = 1 ; -while (($status = $X->seq($key, $value, R_PREV)) == 0) -{ - ($ok = 0), last if ($previous cmp $key) == -1 ; - #print "key = [$key] value = [$value]\n" ; -} - -ok(70, $status == 1 ); -ok(71, $ok == 1 ); - - -# check seq FIRST/LAST - -# sync -# #### - -$status = $X->sync ; -ok(72, $status == 0 ); - - -# fd -# ## - -$status = $X->fd ; -ok(73, $status != 0 ); - - -undef $X ; -untie %h ; - -unlink $Dfile; - -# Now try an in memory file -my $Y; -ok(74, $Y = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_BTREE )); - -# fd with an in memory file should return failure -$status = $Y->fd ; -ok(75, $status == -1 ); - - -undef $Y ; -untie %h ; - -# Duplicate keys -my $bt = new DB_File::BTREEINFO ; -$bt->{flags} = R_DUP ; -my ($YY, %hh); -ok(76, $YY = tie(%hh, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $bt )) ; - -$hh{'Wall'} = 'Larry' ; -$hh{'Wall'} = 'Stone' ; # Note the duplicate key -$hh{'Wall'} = 'Brick' ; # Note the duplicate key -$hh{'Wall'} = 'Brick' ; # Note the duplicate key and value -$hh{'Smith'} = 'John' ; -$hh{'mouse'} = 'mickey' ; - -# first work in scalar context -ok(77, scalar $YY->get_dup('Unknown') == 0 ); -ok(78, scalar $YY->get_dup('Smith') == 1 ); -ok(79, scalar $YY->get_dup('Wall') == 4 ); - -# now in list context -my @unknown = $YY->get_dup('Unknown') ; -ok(80, "@unknown" eq "" ); - -my @smith = $YY->get_dup('Smith') ; -ok(81, "@smith" eq "John" ); - -{ -my @wall = $YY->get_dup('Wall') ; -my %wall ; -@wall{@wall} = @wall ; -ok(82, (@wall == 4 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) ); -} - -# hash -my %unknown = $YY->get_dup('Unknown', 1) ; -ok(83, keys %unknown == 0 ); - -my %smith = $YY->get_dup('Smith', 1) ; -ok(84, keys %smith == 1 && $smith{'John'}) ; - -my %wall = $YY->get_dup('Wall', 1) ; -ok(85, keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1 - && $wall{'Brick'} == 2); - -undef $YY ; -untie %hh ; -unlink $Dfile; - - -# test multiple callbacks -my $Dfile1 = "btree1" ; -my $Dfile2 = "btree2" ; -my $Dfile3 = "btree3" ; - -my $dbh1 = new DB_File::BTREEINFO ; -$dbh1->{compare} = sub { - no warnings 'numeric' ; - $_[0] <=> $_[1] } ; - -my $dbh2 = new DB_File::BTREEINFO ; -$dbh2->{compare} = sub { $_[0] cmp $_[1] } ; - -my $dbh3 = new DB_File::BTREEINFO ; -$dbh3->{compare} = sub { length $_[0] <=> length $_[1] } ; - - -my (%g, %k); -tie(%h, 'DB_File',$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) ; -tie(%g, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ; -tie(%k, 'DB_File',$Dfile3, O_RDWR|O_CREAT, 0640, $dbh3 ) ; - -my @Keys = qw( 0123 12 -1234 9 987654321 def ) ; -my (@srt_1, @srt_2, @srt_3); -{ - no warnings 'numeric' ; - @srt_1 = sort { $a <=> $b } @Keys ; -} -@srt_2 = sort { $a cmp $b } @Keys ; -@srt_3 = sort { length $a <=> length $b } @Keys ; - -foreach (@Keys) { - $h{$_} = 1 ; - $g{$_} = 1 ; - $k{$_} = 1 ; -} - -sub ArrayCompare -{ - my($a, $b) = @_ ; - - return 0 if @$a != @$b ; - - foreach (1 .. length @$a) - { - return 0 unless $$a[$_] eq $$b[$_] ; - } - - 1 ; -} - -ok(86, ArrayCompare (\@srt_1, [keys %h]) ); -ok(87, ArrayCompare (\@srt_2, [keys %g]) ); -ok(88, ArrayCompare (\@srt_3, [keys %k]) ); - -untie %h ; -untie %g ; -untie %k ; -unlink $Dfile1, $Dfile2, $Dfile3 ; - -# clear -# ##### - -ok(89, tie(%h, 'DB_File', $Dfile1, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); -foreach (1 .. 10) - { $h{$_} = $_ * 100 } - -# check that there are 10 elements in the hash -$i = 0 ; -while (($key,$value) = each(%h)) { - $i++; -} -ok(90, $i == 10); - -# now clear the hash -%h = () ; - -# check it is empty -$i = 0 ; -while (($key,$value) = each(%h)) { - $i++; -} -ok(91, $i == 0); - -untie %h ; -unlink $Dfile1 ; - -{ - # check that attempting to tie an array to a DB_BTREE will fail - - my $filename = "xyz" ; - my @x ; - eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE ; } ; - ok(92, $@ =~ /^DB_File can only tie an associative array to a DB_BTREE database/) ; - unlink $filename ; -} - -{ - # sub-class test - - package Another ; - - use warnings ; - use strict ; - - open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; - print FILE <<'EOM' ; - - package SubDB ; - - use warnings ; - use strict ; - use vars qw( @ISA @EXPORT) ; - - require Exporter ; - use DB_File; - @ISA=qw(DB_File); - @EXPORT = @DB_File::EXPORT ; - - sub STORE { - my $self = shift ; - my $key = shift ; - my $value = shift ; - $self->SUPER::STORE($key, $value * 2) ; - } - - sub FETCH { - my $self = shift ; - my $key = shift ; - $self->SUPER::FETCH($key) - 1 ; - } - - sub put { - my $self = shift ; - my $key = shift ; - my $value = shift ; - $self->SUPER::put($key, $value * 3) ; - } - - sub get { - my $self = shift ; - $self->SUPER::get($_[0], $_[1]) ; - $_[1] -= 2 ; - } - - sub A_new_method - { - my $self = shift ; - my $key = shift ; - my $value = $self->FETCH($key) ; - return "[[$value]]" ; - } - - 1 ; -EOM - - close FILE ; - - BEGIN { push @INC, '.'; } - eval 'use SubDB ; '; - main::ok(93, $@ eq "") ; - my %h ; - my $X ; - eval ' - $X = tie(%h, "SubDB","dbbtree.tmp", O_RDWR|O_CREAT, 0640, $DB_BTREE ); - ' ; - - main::ok(94, $@ eq "") ; - - my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; - main::ok(95, $@ eq "") ; - main::ok(96, $ret == 5) ; - - my $value = 0; - $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ; - main::ok(97, $@ eq "") ; - main::ok(98, $ret == 10) ; - - $ret = eval ' R_NEXT eq main::R_NEXT ' ; - main::ok(99, $@ eq "" ) ; - main::ok(100, $ret == 1) ; - - $ret = eval '$X->A_new_method("joe") ' ; - main::ok(101, $@ eq "") ; - main::ok(102, $ret eq "[[11]]") ; - - undef $X; - untie(%h); - unlink "SubDB.pm", "dbbtree.tmp" ; - -} - -{ - # DBM Filter tests - use warnings ; - use strict ; - my (%h, $db) ; - my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - unlink $Dfile; - - sub checkOutput - { - my($fk, $sk, $fv, $sv) = @_ ; - return - $fetch_key eq $fk && $store_key eq $sk && - $fetch_value eq $fv && $store_value eq $sv && - $_ eq 'original' ; - } - - ok(103, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); - - $db->filter_fetch_key (sub { $fetch_key = $_ }) ; - $db->filter_store_key (sub { $store_key = $_ }) ; - $db->filter_fetch_value (sub { $fetch_value = $_}) ; - $db->filter_store_value (sub { $store_value = $_ }) ; - - $_ = "original" ; - - $h{"fred"} = "joe" ; - # fk sk fv sv - ok(104, checkOutput( "", "fred", "", "joe")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(105, $h{"fred"} eq "joe"); - # fk sk fv sv - ok(106, checkOutput( "", "fred", "joe", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(107, $db->FIRSTKEY() eq "fred") ; - # fk sk fv sv - ok(108, checkOutput( "fred", "", "", "")) ; - - # replace the filters, but remember the previous set - my ($old_fk) = $db->filter_fetch_key - (sub { $_ = uc $_ ; $fetch_key = $_ }) ; - my ($old_sk) = $db->filter_store_key - (sub { $_ = lc $_ ; $store_key = $_ }) ; - my ($old_fv) = $db->filter_fetch_value - (sub { $_ = "[$_]"; $fetch_value = $_ }) ; - my ($old_sv) = $db->filter_store_value - (sub { s/o/x/g; $store_value = $_ }) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - $h{"Fred"} = "Joe" ; - # fk sk fv sv - ok(109, checkOutput( "", "fred", "", "Jxe")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(110, $h{"Fred"} eq "[Jxe]"); - # fk sk fv sv - ok(111, checkOutput( "", "fred", "[Jxe]", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(112, $db->FIRSTKEY() eq "FRED") ; - # fk sk fv sv - ok(113, checkOutput( "FRED", "", "", "")) ; - - # put the original filters back - $db->filter_fetch_key ($old_fk); - $db->filter_store_key ($old_sk); - $db->filter_fetch_value ($old_fv); - $db->filter_store_value ($old_sv); - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - $h{"fred"} = "joe" ; - ok(114, checkOutput( "", "fred", "", "joe")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(115, $h{"fred"} eq "joe"); - ok(116, checkOutput( "", "fred", "joe", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(117, $db->FIRSTKEY() eq "fred") ; - ok(118, checkOutput( "fred", "", "", "")) ; - - # delete the filters - $db->filter_fetch_key (undef); - $db->filter_store_key (undef); - $db->filter_fetch_value (undef); - $db->filter_store_value (undef); - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - $h{"fred"} = "joe" ; - ok(119, checkOutput( "", "", "", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(120, $h{"fred"} eq "joe"); - ok(121, checkOutput( "", "", "", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(122, $db->FIRSTKEY() eq "fred") ; - ok(123, checkOutput( "", "", "", "")) ; - - undef $db ; - untie %h; - unlink $Dfile; -} - -{ - # DBM Filter with a closure - - use warnings ; - use strict ; - my (%h, $db) ; - - unlink $Dfile; - ok(124, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); - - my %result = () ; - - sub Closure - { - my ($name) = @_ ; - my $count = 0 ; - my @kept = () ; - - return sub { ++$count ; - push @kept, $_ ; - $result{$name} = "$name - $count: [@kept]" ; - } - } - - $db->filter_store_key(Closure("store key")) ; - $db->filter_store_value(Closure("store value")) ; - $db->filter_fetch_key(Closure("fetch key")) ; - $db->filter_fetch_value(Closure("fetch value")) ; - - $_ = "original" ; - - $h{"fred"} = "joe" ; - ok(125, $result{"store key"} eq "store key - 1: [fred]"); - ok(126, $result{"store value"} eq "store value - 1: [joe]"); - ok(127, ! defined $result{"fetch key"} ); - ok(128, ! defined $result{"fetch value"} ); - ok(129, $_ eq "original") ; - - ok(130, $db->FIRSTKEY() eq "fred") ; - ok(131, $result{"store key"} eq "store key - 1: [fred]"); - ok(132, $result{"store value"} eq "store value - 1: [joe]"); - ok(133, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(134, ! defined $result{"fetch value"} ); - ok(135, $_ eq "original") ; - - $h{"jim"} = "john" ; - ok(136, $result{"store key"} eq "store key - 2: [fred jim]"); - ok(137, $result{"store value"} eq "store value - 2: [joe john]"); - ok(138, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(139, ! defined $result{"fetch value"} ); - ok(140, $_ eq "original") ; - - ok(141, $h{"fred"} eq "joe"); - ok(142, $result{"store key"} eq "store key - 3: [fred jim fred]"); - ok(143, $result{"store value"} eq "store value - 2: [joe john]"); - ok(144, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(145, $result{"fetch value"} eq "fetch value - 1: [joe]"); - ok(146, $_ eq "original") ; - - undef $db ; - untie %h; - unlink $Dfile; -} - -{ - # DBM Filter recursion detection - use warnings ; - use strict ; - my (%h, $db) ; - unlink $Dfile; - - ok(147, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); - - $db->filter_store_key (sub { $_ = $h{$_} }) ; - - eval '$h{1} = 1234' ; - ok(148, $@ =~ /^recursion detected in filter_store_key at/ ); - - undef $db ; - untie %h; - unlink $Dfile; -} - - -{ - # Examples from the POD - - - my $file = "xyzt" ; - { - my $redirect = new Redirect $file ; - - # BTREE example 1 - ### - - use warnings FATAL => qw(all) ; - use strict ; - use DB_File ; - - my %h ; - - sub Compare - { - my ($key1, $key2) = @_ ; - "\L$key1" cmp "\L$key2" ; - } - - # specify the Perl sub that will do the comparison - $DB_BTREE->{'compare'} = \&Compare ; - - unlink "tree" ; - tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0640, $DB_BTREE - or die "Cannot open file 'tree': $!\n" ; - - # Add a key/value pair to the file - $h{'Wall'} = 'Larry' ; - $h{'Smith'} = 'John' ; - $h{'mouse'} = 'mickey' ; - $h{'duck'} = 'donald' ; - - # Delete - delete $h{"duck"} ; - - # Cycle through the keys printing them in order. - # Note it is not necessary to sort the keys as - # the btree will have kept them in order automatically. - foreach (keys %h) - { print "$_\n" } - - untie %h ; - - unlink "tree" ; - } - - delete $DB_BTREE->{'compare'} ; - - ok(149, docat_del($file) eq <<'EOM') ; -mouse -Smith -Wall -EOM - - { - my $redirect = new Redirect $file ; - - # BTREE example 2 - ### - - use warnings FATAL => qw(all) ; - use strict ; - use DB_File ; - - use vars qw($filename %h ) ; - - $filename = "tree" ; - unlink $filename ; - - # Enable duplicate records - $DB_BTREE->{'flags'} = R_DUP ; - - tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE - or die "Cannot open $filename: $!\n"; - - # Add some key/value pairs to the file - $h{'Wall'} = 'Larry' ; - $h{'Wall'} = 'Brick' ; # Note the duplicate key - $h{'Wall'} = 'Brick' ; # Note the duplicate key and value - $h{'Smith'} = 'John' ; - $h{'mouse'} = 'mickey' ; - - # iterate through the associative array - # and print each key/value pair. - foreach (keys %h) - { print "$_ -> $h{$_}\n" } - - untie %h ; - - unlink $filename ; - } - - ok(150, docat_del($file) eq ($db185mode ? <<'EOM' : <<'EOM') ) ; -Smith -> John -Wall -> Brick -Wall -> Brick -Wall -> Brick -mouse -> mickey -EOM -Smith -> John -Wall -> Larry -Wall -> Larry -Wall -> Larry -mouse -> mickey -EOM - - { - my $redirect = new Redirect $file ; - - # BTREE example 3 - ### - - use warnings FATAL => qw(all) ; - use strict ; - use DB_File ; - - use vars qw($filename $x %h $status $key $value) ; - - $filename = "tree" ; - unlink $filename ; - - # Enable duplicate records - $DB_BTREE->{'flags'} = R_DUP ; - - $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE - or die "Cannot open $filename: $!\n"; - - # Add some key/value pairs to the file - $h{'Wall'} = 'Larry' ; - $h{'Wall'} = 'Brick' ; # Note the duplicate key - $h{'Wall'} = 'Brick' ; # Note the duplicate key and value - $h{'Smith'} = 'John' ; - $h{'mouse'} = 'mickey' ; - - # iterate through the btree using seq - # and print each key/value pair. - $key = $value = 0 ; - for ($status = $x->seq($key, $value, R_FIRST) ; - $status == 0 ; - $status = $x->seq($key, $value, R_NEXT) ) - { print "$key -> $value\n" } - - - undef $x ; - untie %h ; - } - - ok(151, docat_del($file) eq ($db185mode == 1 ? <<'EOM' : <<'EOM') ) ; -Smith -> John -Wall -> Brick -Wall -> Brick -Wall -> Larry -mouse -> mickey -EOM -Smith -> John -Wall -> Larry -Wall -> Brick -Wall -> Brick -mouse -> mickey -EOM - - - { - my $redirect = new Redirect $file ; - - # BTREE example 4 - ### - - use warnings FATAL => qw(all) ; - use strict ; - use DB_File ; - - use vars qw($filename $x %h ) ; - - $filename = "tree" ; - - # Enable duplicate records - $DB_BTREE->{'flags'} = R_DUP ; - - $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE - or die "Cannot open $filename: $!\n"; - - my $cnt = $x->get_dup("Wall") ; - print "Wall occurred $cnt times\n" ; - - my %hash = $x->get_dup("Wall", 1) ; - print "Larry is there\n" if $hash{'Larry'} ; - print "There are $hash{'Brick'} Brick Walls\n" ; - - my @list = sort $x->get_dup("Wall") ; - print "Wall => [@list]\n" ; - - @list = $x->get_dup("Smith") ; - print "Smith => [@list]\n" ; - - @list = $x->get_dup("Dog") ; - print "Dog => [@list]\n" ; - - undef $x ; - untie %h ; - } - - ok(152, docat_del($file) eq <<'EOM') ; -Wall occurred 3 times -Larry is there -There are 2 Brick Walls -Wall => [Brick Brick Larry] -Smith => [John] -Dog => [] -EOM - - { - my $redirect = new Redirect $file ; - - # BTREE example 5 - ### - - use warnings FATAL => qw(all) ; - use strict ; - use DB_File ; - - use vars qw($filename $x %h $found) ; - - my $filename = "tree" ; - - # Enable duplicate records - $DB_BTREE->{'flags'} = R_DUP ; - - $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE - or die "Cannot open $filename: $!\n"; - - $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; - print "Larry Wall is $found there\n" ; - - $found = ( $x->find_dup("Wall", "Harry") == 0 ? "" : "not") ; - print "Harry Wall is $found there\n" ; - - undef $x ; - untie %h ; - } - - ok(153, docat_del($file) eq <<'EOM') ; -Larry Wall is there -Harry Wall is not there -EOM - - { - my $redirect = new Redirect $file ; - - # BTREE example 6 - ### - - use warnings FATAL => qw(all) ; - use strict ; - use DB_File ; - - use vars qw($filename $x %h $found) ; - - my $filename = "tree" ; - - # Enable duplicate records - $DB_BTREE->{'flags'} = R_DUP ; - - $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE - or die "Cannot open $filename: $!\n"; - - $x->del_dup("Wall", "Larry") ; - - $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; - print "Larry Wall is $found there\n" ; - - undef $x ; - untie %h ; - - unlink $filename ; - } - - ok(154, docat_del($file) eq <<'EOM') ; -Larry Wall is not there -EOM - - { - my $redirect = new Redirect $file ; - - # BTREE example 7 - ### - - use warnings FATAL => qw(all) ; - use strict ; - use DB_File ; - use Fcntl ; - - use vars qw($filename $x %h $st $key $value) ; - - sub match - { - my $key = shift ; - my $value = 0; - my $orig_key = $key ; - $x->seq($key, $value, R_CURSOR) ; - print "$orig_key\t-> $key\t-> $value\n" ; - } - - $filename = "tree" ; - unlink $filename ; - - $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE - or die "Cannot open $filename: $!\n"; - - # Add some key/value pairs to the file - $h{'mouse'} = 'mickey' ; - $h{'Wall'} = 'Larry' ; - $h{'Walls'} = 'Brick' ; - $h{'Smith'} = 'John' ; - - - $key = $value = 0 ; - print "IN ORDER\n" ; - for ($st = $x->seq($key, $value, R_FIRST) ; - $st == 0 ; - $st = $x->seq($key, $value, R_NEXT) ) - - { print "$key -> $value\n" } - - print "\nPARTIAL MATCH\n" ; - - match "Wa" ; - match "A" ; - match "a" ; - - undef $x ; - untie %h ; - - unlink $filename ; - - } - - ok(155, docat_del($file) eq <<'EOM') ; -IN ORDER -Smith -> John -Wall -> Larry -Walls -> Brick -mouse -> mickey - -PARTIAL MATCH -Wa -> Wall -> Larry -A -> Smith -> John -a -> mouse -> mickey -EOM - -} - -#{ -# # R_SETCURSOR -# use strict ; -# my (%h, $db) ; -# unlink $Dfile; -# -# ok(156, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); -# -# $h{abc} = 33 ; -# my $k = "newest" ; -# my $v = 44 ; -# my $status = $db->put($k, $v, R_SETCURSOR) ; -# print "status = [$status]\n" ; -# ok(157, $status == 0) ; -# $status = $db->del($k, R_CURSOR) ; -# print "status = [$status]\n" ; -# ok(158, $status == 0) ; -# $k = "newest" ; -# ok(159, $db->get($k, $v, R_CURSOR)) ; -# -# ok(160, keys %h == 1) ; -# -# undef $db ; -# untie %h; -# unlink $Dfile; -#} - -{ - # Bug ID 20001013.009 - # - # test that $hash{KEY} = undef doesn't produce the warning - # Use of uninitialized value in null operation - use warnings ; - use strict ; - use DB_File ; - - unlink $Dfile; - my %h ; - my $a = ""; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - - tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE - or die "Can't open file: $!\n" ; - $h{ABC} = undef; - ok(156, $a eq "") ; - untie %h ; - unlink $Dfile; -} - -{ - # test that %hash = () doesn't produce the warning - # Argument "" isn't numeric in entersub - use warnings ; - use strict ; - use DB_File ; - - unlink $Dfile; - my %h ; - my $a = ""; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - - tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE - or die "Can't open file: $!\n" ; - %h = (); ; - ok(157, $a eq "") ; - untie %h ; - unlink $Dfile; -} - -exit ; diff --git a/t/lib/db-hash.t b/t/lib/db-hash.t deleted file mode 100755 index 6f2ef37b61..0000000000 --- a/t/lib/db-hash.t +++ /dev/null @@ -1,743 +0,0 @@ -#!./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' || $^O eq 'NetWare'); - -my ($key, $value, $i); -while (($key,$value) = each(%h)) { - $i++; -} -ok(17, !$i ); - -$h{'goner1'} = 'snork'; - -$h{'abc'} = 'ABC'; -ok(18, $h{'abc'} eq 'ABC' ); -ok(19, !defined $h{'jimmy'} ); -ok(20, !exists $h{'jimmy'} ); -ok(21, exists $h{'abc'} ); - -$h{'def'} = 'DEF'; -$h{'jkl','mno'} = "JKL\034MNO"; -$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); -$h{'a'} = 'A'; - -#$h{'b'} = 'B'; -$X->STORE('b', 'B') ; - -$h{'c'} = 'C'; - -#$h{'d'} = 'D'; -$X->put('d', 'D') ; - -$h{'e'} = 'E'; -$h{'f'} = 'F'; -$h{'g'} = 'X'; -$h{'h'} = 'H'; -$h{'i'} = 'I'; - -$h{'goner2'} = 'snork'; -delete $h{'goner2'}; - - -# IMPORTANT - $X must be undefined before the untie otherwise the -# underlying DB close routine will not get called. -undef $X ; -untie(%h); - - -# tie to the same file again, do not supply a type - should default to HASH -ok(22, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640) ); - -# Modify an entry from the previous tie -$h{'g'} = 'G'; - -$h{'j'} = 'J'; -$h{'k'} = 'K'; -$h{'l'} = 'L'; -$h{'m'} = 'M'; -$h{'n'} = 'N'; -$h{'o'} = 'O'; -$h{'p'} = 'P'; -$h{'q'} = 'Q'; -$h{'r'} = 'R'; -$h{'s'} = 'S'; -$h{'t'} = 'T'; -$h{'u'} = 'U'; -$h{'v'} = 'V'; -$h{'w'} = 'W'; -$h{'x'} = 'X'; -$h{'y'} = 'Y'; -$h{'z'} = 'Z'; - -$h{'goner3'} = 'snork'; - -delete $h{'goner1'}; -$X->DELETE('goner3'); - -my @keys = keys(%h); -my @values = values(%h); - -ok(23, $#keys == 29 && $#values == 29) ; - -$i = 0 ; -while (($key,$value) = each(%h)) { - if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { - $key =~ y/a-z/A-Z/; - $i++ if $key eq $value; - } -} - -ok(24, $i == 30) ; - -@keys = ('blurfl', keys(%h), 'dyick'); -ok(25, $#keys == 31) ; - -$h{'foo'} = ''; -ok(26, $h{'foo'} eq '' ); - -# Berkeley DB from version 2.4.10 to 3.0 does not allow null keys. -# This feature was reenabled in version 3.1 of Berkeley DB. -my $result = 0 ; -if ($null_keys_allowed) { - $h{''} = 'bar'; - $result = ( $h{''} eq 'bar' ); -} -else - { $result = 1 } -ok(27, $result) ; - -# check cache overflow and numeric keys and contents -my $ok = 1; -for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } -for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } -ok(28, $ok ); - -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); -ok(29, $size > 0 ); - -@h{0..200} = 200..400; -my @foo = @h{0..200}; -ok(30, join(':',200..400) eq join(':',@foo) ); - - -# Now check all the non-tie specific stuff - -# Check NOOVERWRITE will make put fail when attempting to overwrite -# an existing record. - -my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; -ok(31, $status == 1 ); - -# check that the value of the key 'x' has not been changed by the -# previous test -ok(32, $h{'x'} eq 'X' ); - -# standard put -$status = $X->put('key', 'value') ; -ok(33, $status == 0 ); - -#check that previous put can be retrieved -$value = 0 ; -$status = $X->get('key', $value) ; -ok(34, $status == 0 ); -ok(35, $value eq 'value' ); - -# Attempting to delete an existing key should work - -$status = $X->del('q') ; -ok(36, $status == 0 ); - -# Make sure that the key deleted, cannot be retrieved -{ - no warnings 'uninitialized' ; - ok(37, $h{'q'} eq undef ); -} - -# Attempting to delete a non-existant key should fail - -$status = $X->del('joe') ; -ok(38, $status == 1 ); - -# Check the get interface - -# First a non-existing key -$status = $X->get('aaaa', $value) ; -ok(39, $status == 1 ); - -# Next an existing key -$status = $X->get('a', $value) ; -ok(40, $status == 0 ); -ok(41, $value eq 'A' ); - -# seq -# ### - -# ditto, but use put to replace the key/value pair. - -# use seq to walk backwards through a file - check that this reversed is - -# check seq FIRST/LAST - -# sync -# #### - -$status = $X->sync ; -ok(42, $status == 0 ); - - -# fd -# ## - -$status = $X->fd ; -ok(43, $status != 0 ); - -undef $X ; -untie %h ; - -unlink $Dfile; - -# clear -# ##### - -ok(44, tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); -foreach (1 .. 10) - { $h{$_} = $_ * 100 } - -# check that there are 10 elements in the hash -$i = 0 ; -while (($key,$value) = each(%h)) { - $i++; -} -ok(45, $i == 10); - -# now clear the hash -%h = () ; - -# check it is empty -$i = 0 ; -while (($key,$value) = each(%h)) { - $i++; -} -ok(46, $i == 0); - -untie %h ; -unlink $Dfile ; - - -# Now try an in memory file -ok(47, $X = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); - -# fd with an in memory file should return fail -$status = $X->fd ; -ok(48, $status == -1 ); - -undef $X ; -untie %h ; - -{ - # check ability to override the default hashing - my %x ; - my $filename = "xyz" ; - my $hi = new DB_File::HASHINFO ; - $::count = 0 ; - $hi->{hash} = sub { ++$::count ; length $_[0] } ; - ok(49, tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $hi ) ; - $h{"abc"} = 123 ; - ok(50, $h{"abc"} == 123) ; - untie %x ; - unlink $filename ; - ok(51, $::count >0) ; -} - -{ - # check that attempting to tie an array to a DB_HASH will fail - - my $filename = "xyz" ; - my @x ; - eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_HASH ; } ; - ok(52, $@ =~ /^DB_File can only tie an associative array to a DB_HASH database/) ; - unlink $filename ; -} - -{ - # sub-class test - - package Another ; - - use warnings ; - use strict ; - - open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; - print FILE <<'EOM' ; - - package SubDB ; - - use warnings ; - use strict ; - use vars qw( @ISA @EXPORT) ; - - require Exporter ; - use DB_File; - @ISA=qw(DB_File); - @EXPORT = @DB_File::EXPORT ; - - sub STORE { - my $self = shift ; - my $key = shift ; - my $value = shift ; - $self->SUPER::STORE($key, $value * 2) ; - } - - sub FETCH { - my $self = shift ; - my $key = shift ; - $self->SUPER::FETCH($key) - 1 ; - } - - sub put { - my $self = shift ; - my $key = shift ; - my $value = shift ; - $self->SUPER::put($key, $value * 3) ; - } - - sub get { - my $self = shift ; - $self->SUPER::get($_[0], $_[1]) ; - $_[1] -= 2 ; - } - - sub A_new_method - { - my $self = shift ; - my $key = shift ; - my $value = $self->FETCH($key) ; - return "[[$value]]" ; - } - - 1 ; -EOM - - close FILE ; - - BEGIN { push @INC, '.'; } - eval 'use SubDB ; '; - main::ok(53, $@ eq "") ; - my %h ; - my $X ; - eval ' - $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640, $DB_HASH ); - ' ; - - main::ok(54, $@ eq "") ; - - my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; - main::ok(55, $@ eq "") ; - main::ok(56, $ret == 5) ; - - my $value = 0; - $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ; - main::ok(57, $@ eq "") ; - main::ok(58, $ret == 10) ; - - $ret = eval ' R_NEXT eq main::R_NEXT ' ; - main::ok(59, $@ eq "" ) ; - main::ok(60, $ret == 1) ; - - $ret = eval '$X->A_new_method("joe") ' ; - main::ok(61, $@ eq "") ; - main::ok(62, $ret eq "[[11]]") ; - - undef $X; - untie(%h); - unlink "SubDB.pm", "dbhash.tmp" ; - -} - -{ - # DBM Filter tests - use warnings ; - use strict ; - my (%h, $db) ; - my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - unlink $Dfile; - - sub checkOutput - { - my($fk, $sk, $fv, $sv) = @_ ; - return - $fetch_key eq $fk && $store_key eq $sk && - $fetch_value eq $fv && $store_value eq $sv && - $_ eq 'original' ; - } - - ok(63, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); - - $db->filter_fetch_key (sub { $fetch_key = $_ }) ; - $db->filter_store_key (sub { $store_key = $_ }) ; - $db->filter_fetch_value (sub { $fetch_value = $_}) ; - $db->filter_store_value (sub { $store_value = $_ }) ; - - $_ = "original" ; - - $h{"fred"} = "joe" ; - # fk sk fv sv - ok(64, checkOutput( "", "fred", "", "joe")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(65, $h{"fred"} eq "joe"); - # fk sk fv sv - ok(66, checkOutput( "", "fred", "joe", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(67, $db->FIRSTKEY() eq "fred") ; - # fk sk fv sv - ok(68, checkOutput( "fred", "", "", "")) ; - - # replace the filters, but remember the previous set - my ($old_fk) = $db->filter_fetch_key - (sub { $_ = uc $_ ; $fetch_key = $_ }) ; - my ($old_sk) = $db->filter_store_key - (sub { $_ = lc $_ ; $store_key = $_ }) ; - my ($old_fv) = $db->filter_fetch_value - (sub { $_ = "[$_]"; $fetch_value = $_ }) ; - my ($old_sv) = $db->filter_store_value - (sub { s/o/x/g; $store_value = $_ }) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - $h{"Fred"} = "Joe" ; - # fk sk fv sv - ok(69, checkOutput( "", "fred", "", "Jxe")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(70, $h{"Fred"} eq "[Jxe]"); - # fk sk fv sv - ok(71, checkOutput( "", "fred", "[Jxe]", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(72, $db->FIRSTKEY() eq "FRED") ; - # fk sk fv sv - ok(73, checkOutput( "FRED", "", "", "")) ; - - # put the original filters back - $db->filter_fetch_key ($old_fk); - $db->filter_store_key ($old_sk); - $db->filter_fetch_value ($old_fv); - $db->filter_store_value ($old_sv); - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - $h{"fred"} = "joe" ; - ok(74, checkOutput( "", "fred", "", "joe")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(75, $h{"fred"} eq "joe"); - ok(76, checkOutput( "", "fred", "joe", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(77, $db->FIRSTKEY() eq "fred") ; - ok(78, checkOutput( "fred", "", "", "")) ; - - # delete the filters - $db->filter_fetch_key (undef); - $db->filter_store_key (undef); - $db->filter_fetch_value (undef); - $db->filter_store_value (undef); - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - $h{"fred"} = "joe" ; - ok(79, checkOutput( "", "", "", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(80, $h{"fred"} eq "joe"); - ok(81, checkOutput( "", "", "", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(82, $db->FIRSTKEY() eq "fred") ; - ok(83, checkOutput( "", "", "", "")) ; - - undef $db ; - untie %h; - unlink $Dfile; -} - -{ - # DBM Filter with a closure - - use warnings ; - use strict ; - my (%h, $db) ; - - unlink $Dfile; - ok(84, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); - - my %result = () ; - - sub Closure - { - my ($name) = @_ ; - my $count = 0 ; - my @kept = () ; - - return sub { ++$count ; - push @kept, $_ ; - $result{$name} = "$name - $count: [@kept]" ; - } - } - - $db->filter_store_key(Closure("store key")) ; - $db->filter_store_value(Closure("store value")) ; - $db->filter_fetch_key(Closure("fetch key")) ; - $db->filter_fetch_value(Closure("fetch value")) ; - - $_ = "original" ; - - $h{"fred"} = "joe" ; - ok(85, $result{"store key"} eq "store key - 1: [fred]"); - ok(86, $result{"store value"} eq "store value - 1: [joe]"); - ok(87, ! defined $result{"fetch key"} ); - ok(88, ! defined $result{"fetch value"} ); - ok(89, $_ eq "original") ; - - ok(90, $db->FIRSTKEY() eq "fred") ; - ok(91, $result{"store key"} eq "store key - 1: [fred]"); - ok(92, $result{"store value"} eq "store value - 1: [joe]"); - ok(93, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(94, ! defined $result{"fetch value"} ); - ok(95, $_ eq "original") ; - - $h{"jim"} = "john" ; - ok(96, $result{"store key"} eq "store key - 2: [fred jim]"); - ok(97, $result{"store value"} eq "store value - 2: [joe john]"); - ok(98, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(99, ! defined $result{"fetch value"} ); - ok(100, $_ eq "original") ; - - ok(101, $h{"fred"} eq "joe"); - ok(102, $result{"store key"} eq "store key - 3: [fred jim fred]"); - ok(103, $result{"store value"} eq "store value - 2: [joe john]"); - ok(104, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(105, $result{"fetch value"} eq "fetch value - 1: [joe]"); - ok(106, $_ eq "original") ; - - undef $db ; - untie %h; - unlink $Dfile; -} - -{ - # DBM Filter recursion detection - use warnings ; - use strict ; - my (%h, $db) ; - unlink $Dfile; - - ok(107, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); - - $db->filter_store_key (sub { $_ = $h{$_} }) ; - - eval '$h{1} = 1234' ; - ok(108, $@ =~ /^recursion detected in filter_store_key at/ ); - - undef $db ; - untie %h; - unlink $Dfile; -} - - -{ - # Examples from the POD - - my $file = "xyzt" ; - { - my $redirect = new Redirect $file ; - - use warnings FATAL => qw(all); - use strict ; - use DB_File ; - use vars qw( %h $k $v ) ; - - unlink "fruit" ; - tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH - or die "Cannot open file 'fruit': $!\n"; - - # Add a few key/value pairs to the file - $h{"apple"} = "red" ; - $h{"orange"} = "orange" ; - $h{"banana"} = "yellow" ; - $h{"tomato"} = "red" ; - - # Check for existence of a key - print "Banana Exists\n\n" if $h{"banana"} ; - - # Delete a key/value pair. - delete $h{"apple"} ; - - # print the contents of the file - while (($k, $v) = each %h) - { print "$k -> $v\n" } - - untie %h ; - - unlink "fruit" ; - } - - ok(109, docat_del($file) eq <<'EOM') ; -Banana Exists - -orange -> orange -tomato -> red -banana -> yellow -EOM - -} - -{ - # Bug ID 20001013.009 - # - # test that $hash{KEY} = undef doesn't produce the warning - # Use of uninitialized value in null operation - use warnings ; - use strict ; - use DB_File ; - - unlink $Dfile; - my %h ; - my $a = ""; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - - tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ; - $h{ABC} = undef; - ok(110, $a eq "") ; - untie %h ; - unlink $Dfile; -} - -{ - # test that %hash = () doesn't produce the warning - # Argument "" isn't numeric in entersub - use warnings ; - use strict ; - use DB_File ; - - unlink $Dfile; - my %h ; - my $a = ""; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - - tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ; - %h = (); ; - ok(111, $a eq "") ; - untie %h ; - unlink $Dfile; -} - -exit ; diff --git a/t/lib/db-recno.t b/t/lib/db-recno.t deleted file mode 100755 index 6dd913cfc2..0000000000 --- a/t/lib/db-recno.t +++ /dev/null @@ -1,889 +0,0 @@ -#!./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 'NetWare' || $^O eq 'amigaos') ; - -#my $l = @h ; -my $l = $X->length ; -ok(19, ($FA ? @h == 0 : !$l) ); - -my @data = qw( a b c d ever f g h i j k longername m n o p) ; - -$h[0] = shift @data ; -ok(20, $h[0] eq 'a' ); - -my $ i; -foreach (@data) - { $h[++$i] = $_ } - -unshift (@data, 'a') ; - -ok(21, defined $h[1] ); -ok(22, ! defined $h[16] ); -ok(23, $FA ? @h == @data : $X->length == @data ); - - -# Overwrite an entry & check fetch it -$h[3] = 'replaced' ; -$data[3] = 'replaced' ; -ok(24, $h[3] eq 'replaced' ); - -#PUSH -my @push_data = qw(added to the end) ; -($FA ? push(@h, @push_data) : $X->push(@push_data)) ; -push (@data, @push_data) ; -ok(25, $h[++$i] eq 'added' ); -ok(26, $h[++$i] eq 'to' ); -ok(27, $h[++$i] eq 'the' ); -ok(28, $h[++$i] eq 'end' ); - -# POP -my $popped = pop (@data) ; -my $value = ($FA ? pop @h : $X->pop) ; -ok(29, $value eq $popped) ; - -# SHIFT -$value = ($FA ? shift @h : $X->shift) ; -my $shifted = shift @data ; -ok(30, $value eq $shifted ); - -# UNSHIFT - -# empty list -($FA ? unshift @h,() : $X->unshift) ; -ok(31, ($FA ? @h == @data : $X->length == @data )); - -my @new_data = qw(add this to the start of the array) ; -$FA ? unshift (@h, @new_data) : $X->unshift (@new_data) ; -unshift (@data, @new_data) ; -ok(32, $FA ? @h == @data : $X->length == @data ); -ok(33, $h[0] eq "add") ; -ok(34, $h[1] eq "this") ; -ok(35, $h[2] eq "to") ; -ok(36, $h[3] eq "the") ; -ok(37, $h[4] eq "start") ; -ok(38, $h[5] eq "of") ; -ok(39, $h[6] eq "the") ; -ok(40, $h[7] eq "array") ; -ok(41, $h[8] eq $data[8]) ; - -# SPLICE - -# Now both arrays should be identical - -my $ok = 1 ; -my $j = 0 ; -foreach (@data) -{ - $ok = 0, last if $_ ne $h[$j ++] ; -} -ok(42, $ok ); - -# Neagtive subscripts - -# get the last element of the array -ok(43, $h[-1] eq $data[-1] ); -ok(44, $h[-1] eq $h[ ($FA ? @h : $X->length) -1] ); - -# get the first element using a negative subscript -eval '$h[ - ( $FA ? @h : $X->length)] = "abcd"' ; -ok(45, $@ eq "" ); -ok(46, $h[0] eq "abcd" ); - -# now try to read before the start of the array -eval '$h[ - (1 + ($FA ? @h : $X->length))] = 1234' ; -ok(47, $@ =~ '^Modification of non-creatable array value attempted' ); - -# IMPORTANT - $X must be undefined before the untie otherwise the -# underlying DB close routine will not get called. -undef $X ; -untie(@h); - -unlink $Dfile; - - -{ - # Check bval defaults to \n - - my @h = () ; - my $dbh = new DB_File::RECNOINFO ; - ok(48, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; - $h[0] = "abc" ; - $h[1] = "def" ; - $h[3] = "ghi" ; - untie @h ; - my $x = docat($Dfile) ; - unlink $Dfile; - ok(49, $x eq "abc\ndef\n\nghi\n") ; -} - -{ - # Change bval - - my @h = () ; - my $dbh = new DB_File::RECNOINFO ; - $dbh->{bval} = "-" ; - ok(50, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; - $h[0] = "abc" ; - $h[1] = "def" ; - $h[3] = "ghi" ; - untie @h ; - my $x = docat($Dfile) ; - unlink $Dfile; - my $ok = ($x eq "abc-def--ghi-") ; - bad_one() unless $ok ; - ok(51, $ok) ; -} - -{ - # Check R_FIXEDLEN with default bval (space) - - my @h = () ; - my $dbh = new DB_File::RECNOINFO ; - $dbh->{flags} = R_FIXEDLEN ; - $dbh->{reclen} = 5 ; - ok(52, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; - $h[0] = "abc" ; - $h[1] = "def" ; - $h[3] = "ghi" ; - untie @h ; - my $x = docat($Dfile) ; - unlink $Dfile; - my $ok = ($x eq "abc def ghi ") ; - bad_one() unless $ok ; - ok(53, $ok) ; -} - -{ - # Check R_FIXEDLEN with user-defined bval - - my @h = () ; - my $dbh = new DB_File::RECNOINFO ; - $dbh->{flags} = R_FIXEDLEN ; - $dbh->{bval} = "-" ; - $dbh->{reclen} = 5 ; - ok(54, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; - $h[0] = "abc" ; - $h[1] = "def" ; - $h[3] = "ghi" ; - untie @h ; - my $x = docat($Dfile) ; - unlink $Dfile; - my $ok = ($x eq "abc--def-------ghi--") ; - bad_one() unless $ok ; - ok(55, $ok) ; -} - -{ - # check that attempting to tie an associative array to a DB_RECNO will fail - - my $filename = "xyz" ; - my %x ; - eval { tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO ; } ; - ok(56, $@ =~ /^DB_File can only tie an array to a DB_RECNO database/) ; - unlink $filename ; -} - -{ - # sub-class test - - package Another ; - - use warnings ; - use strict ; - - open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; - print FILE <<'EOM' ; - - package SubDB ; - - use warnings ; - use strict ; - use vars qw( @ISA @EXPORT) ; - - require Exporter ; - use DB_File; - @ISA=qw(DB_File); - @EXPORT = @DB_File::EXPORT ; - - sub STORE { - my $self = shift ; - my $key = shift ; - my $value = shift ; - $self->SUPER::STORE($key, $value * 2) ; - } - - sub FETCH { - my $self = shift ; - my $key = shift ; - $self->SUPER::FETCH($key) - 1 ; - } - - sub put { - my $self = shift ; - my $key = shift ; - my $value = shift ; - $self->SUPER::put($key, $value * 3) ; - } - - sub get { - my $self = shift ; - $self->SUPER::get($_[0], $_[1]) ; - $_[1] -= 2 ; - } - - sub A_new_method - { - my $self = shift ; - my $key = shift ; - my $value = $self->FETCH($key) ; - return "[[$value]]" ; - } - - 1 ; -EOM - - close FILE ; - - BEGIN { push @INC, '.'; } - eval 'use SubDB ; '; - main::ok(57, $@ eq "") ; - my @h ; - my $X ; - eval ' - $X = tie(@h, "SubDB","recno.tmp", O_RDWR|O_CREAT, 0640, $DB_RECNO ); - ' ; - - main::ok(58, $@ eq "") ; - - my $ret = eval '$h[3] = 3 ; return $h[3] ' ; - main::ok(59, $@ eq "") ; - main::ok(60, $ret == 5) ; - - my $value = 0; - $ret = eval '$X->put(1, 4) ; $X->get(1, $value) ; return $value' ; - main::ok(61, $@ eq "") ; - main::ok(62, $ret == 10) ; - - $ret = eval ' R_NEXT eq main::R_NEXT ' ; - main::ok(63, $@ eq "" ) ; - main::ok(64, $ret == 1) ; - - $ret = eval '$X->A_new_method(1) ' ; - main::ok(65, $@ eq "") ; - main::ok(66, $ret eq "[[11]]") ; - - undef $X; - untie(@h); - unlink "SubDB.pm", "recno.tmp" ; - -} - -{ - - # test $# - my $self ; - unlink $Dfile; - ok(67, $self = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ; - $h[0] = "abc" ; - $h[1] = "def" ; - $h[2] = "ghi" ; - $h[3] = "jkl" ; - ok(68, $FA ? $#h == 3 : $self->length() == 4) ; - undef $self ; - untie @h ; - my $x = docat($Dfile) ; - ok(69, $x eq "abc\ndef\nghi\njkl\n") ; - - # $# sets array to same length - ok(70, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; - if ($FA) - { $#h = 3 } - else - { $self->STORESIZE(4) } - ok(71, $FA ? $#h == 3 : $self->length() == 4) ; - undef $self ; - untie @h ; - $x = docat($Dfile) ; - ok(72, $x eq "abc\ndef\nghi\njkl\n") ; - - # $# sets array to bigger - ok(73, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; - if ($FA) - { $#h = 6 } - else - { $self->STORESIZE(7) } - ok(74, $FA ? $#h == 6 : $self->length() == 7) ; - undef $self ; - untie @h ; - $x = docat($Dfile) ; - ok(75, $x eq "abc\ndef\nghi\njkl\n\n\n\n") ; - - # $# sets array smaller - ok(76, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; - if ($FA) - { $#h = 2 } - else - { $self->STORESIZE(3) } - ok(77, $FA ? $#h == 2 : $self->length() == 3) ; - undef $self ; - untie @h ; - $x = docat($Dfile) ; - ok(78, $x eq "abc\ndef\nghi\n") ; - - unlink $Dfile; - - -} - -{ - # DBM Filter tests - use warnings ; - use strict ; - my (@h, $db) ; - my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - unlink $Dfile; - - sub checkOutput - { - my($fk, $sk, $fv, $sv) = @_ ; - return - $fetch_key eq $fk && $store_key eq $sk && - $fetch_value eq $fv && $store_value eq $sv && - $_ eq 'original' ; - } - - ok(79, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); - - $db->filter_fetch_key (sub { $fetch_key = $_ }) ; - $db->filter_store_key (sub { $store_key = $_ }) ; - $db->filter_fetch_value (sub { $fetch_value = $_}) ; - $db->filter_store_value (sub { $store_value = $_ }) ; - - $_ = "original" ; - - $h[0] = "joe" ; - # fk sk fv sv - ok(80, checkOutput( "", 0, "", "joe")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(81, $h[0] eq "joe"); - # fk sk fv sv - ok(82, checkOutput( "", 0, "joe", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(83, $db->FIRSTKEY() == 0) ; - # fk sk fv sv - ok(84, checkOutput( 0, "", "", "")) ; - - # replace the filters, but remember the previous set - my ($old_fk) = $db->filter_fetch_key - (sub { ++ $_ ; $fetch_key = $_ }) ; - my ($old_sk) = $db->filter_store_key - (sub { $_ *= 2 ; $store_key = $_ }) ; - my ($old_fv) = $db->filter_fetch_value - (sub { $_ = "[$_]"; $fetch_value = $_ }) ; - my ($old_sv) = $db->filter_store_value - (sub { s/o/x/g; $store_value = $_ }) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - $h[1] = "Joe" ; - # fk sk fv sv - ok(85, checkOutput( "", 2, "", "Jxe")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(86, $h[1] eq "[Jxe]"); - # fk sk fv sv - ok(87, checkOutput( "", 2, "[Jxe]", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(88, $db->FIRSTKEY() == 1) ; - # fk sk fv sv - ok(89, checkOutput( 1, "", "", "")) ; - - # put the original filters back - $db->filter_fetch_key ($old_fk); - $db->filter_store_key ($old_sk); - $db->filter_fetch_value ($old_fv); - $db->filter_store_value ($old_sv); - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - $h[0] = "joe" ; - ok(90, checkOutput( "", 0, "", "joe")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(91, $h[0] eq "joe"); - ok(92, checkOutput( "", 0, "joe", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(93, $db->FIRSTKEY() == 0) ; - ok(94, checkOutput( 0, "", "", "")) ; - - # delete the filters - $db->filter_fetch_key (undef); - $db->filter_store_key (undef); - $db->filter_fetch_value (undef); - $db->filter_store_value (undef); - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - $h[0] = "joe" ; - ok(95, checkOutput( "", "", "", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(96, $h[0] eq "joe"); - ok(97, checkOutput( "", "", "", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(98, $db->FIRSTKEY() == 0) ; - ok(99, checkOutput( "", "", "", "")) ; - - undef $db ; - untie @h; - unlink $Dfile; -} - -{ - # DBM Filter with a closure - - use warnings ; - use strict ; - my (@h, $db) ; - - unlink $Dfile; - ok(100, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); - - my %result = () ; - - sub Closure - { - my ($name) = @_ ; - my $count = 0 ; - my @kept = () ; - - return sub { ++$count ; - push @kept, $_ ; - $result{$name} = "$name - $count: [@kept]" ; - } - } - - $db->filter_store_key(Closure("store key")) ; - $db->filter_store_value(Closure("store value")) ; - $db->filter_fetch_key(Closure("fetch key")) ; - $db->filter_fetch_value(Closure("fetch value")) ; - - $_ = "original" ; - - $h[0] = "joe" ; - ok(101, $result{"store key"} eq "store key - 1: [0]"); - ok(102, $result{"store value"} eq "store value - 1: [joe]"); - ok(103, ! defined $result{"fetch key"} ); - ok(104, ! defined $result{"fetch value"} ); - ok(105, $_ eq "original") ; - - ok(106, $db->FIRSTKEY() == 0 ) ; - ok(107, $result{"store key"} eq "store key - 1: [0]"); - ok(108, $result{"store value"} eq "store value - 1: [joe]"); - ok(109, $result{"fetch key"} eq "fetch key - 1: [0]"); - ok(110, ! defined $result{"fetch value"} ); - ok(111, $_ eq "original") ; - - $h[7] = "john" ; - ok(112, $result{"store key"} eq "store key - 2: [0 7]"); - ok(113, $result{"store value"} eq "store value - 2: [joe john]"); - ok(114, $result{"fetch key"} eq "fetch key - 1: [0]"); - ok(115, ! defined $result{"fetch value"} ); - ok(116, $_ eq "original") ; - - ok(117, $h[0] eq "joe"); - ok(118, $result{"store key"} eq "store key - 3: [0 7 0]"); - ok(119, $result{"store value"} eq "store value - 2: [joe john]"); - ok(120, $result{"fetch key"} eq "fetch key - 1: [0]"); - ok(121, $result{"fetch value"} eq "fetch value - 1: [joe]"); - ok(122, $_ eq "original") ; - - undef $db ; - untie @h; - unlink $Dfile; -} - -{ - # DBM Filter recursion detection - use warnings ; - use strict ; - my (@h, $db) ; - unlink $Dfile; - - ok(123, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); - - $db->filter_store_key (sub { $_ = $h[0] }) ; - - eval '$h[1] = 1234' ; - ok(124, $@ =~ /^recursion detected in filter_store_key at/ ); - - undef $db ; - untie @h; - unlink $Dfile; -} - - -{ - # Examples from the POD - - my $file = "xyzt" ; - { - my $redirect = new Redirect $file ; - - use warnings FATAL => qw(all); - use strict ; - use DB_File ; - - my $filename = "text" ; - unlink $filename ; - - my @h ; - my $x = tie @h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO - or die "Cannot open file 'text': $!\n" ; - - # Add a few key/value pairs to the file - $h[0] = "orange" ; - $h[1] = "blue" ; - $h[2] = "yellow" ; - - $FA ? push @h, "green", "black" - : $x->push("green", "black") ; - - my $elements = $FA ? scalar @h : $x->length ; - print "The array contains $elements entries\n" ; - - my $last = $FA ? pop @h : $x->pop ; - print "popped $last\n" ; - - $FA ? unshift @h, "white" - : $x->unshift("white") ; - my $first = $FA ? shift @h : $x->shift ; - print "shifted $first\n" ; - - # Check for existence of a key - print "Element 1 Exists with value $h[1]\n" if $h[1] ; - - # use a negative index - print "The last element is $h[-1]\n" ; - print "The 2nd last element is $h[-2]\n" ; - - undef $x ; - untie @h ; - - unlink $filename ; - } - - ok(125, docat_del($file) eq <<'EOM') ; -The array contains 5 entries -popped black -shifted white -Element 1 Exists with value blue -The last element is green -The 2nd last element is yellow -EOM - - my $save_output = "xyzt" ; - { - my $redirect = new Redirect $save_output ; - - use warnings FATAL => qw(all); - use strict ; - use vars qw(@h $H $file $i) ; - use DB_File ; - use Fcntl ; - - $file = "text" ; - - unlink $file ; - - $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0640, $DB_RECNO - or die "Cannot open file $file: $!\n" ; - - # first create a text file to play with - $h[0] = "zero" ; - $h[1] = "one" ; - $h[2] = "two" ; - $h[3] = "three" ; - $h[4] = "four" ; - - - # Print the records in order. - # - # The length method is needed here because evaluating a tied - # array in a scalar context does not return the number of - # elements in the array. - - print "\nORIGINAL\n" ; - foreach $i (0 .. $H->length - 1) { - print "$i: $h[$i]\n" ; - } - - # use the push & pop methods - $a = $H->pop ; - $H->push("last") ; - print "\nThe last record was [$a]\n" ; - - # and the shift & unshift methods - $a = $H->shift ; - $H->unshift("first") ; - print "The first record was [$a]\n" ; - - # Use the API to add a new record after record 2. - $i = 2 ; - $H->put($i, "Newbie", R_IAFTER) ; - - # and a new record before record 1. - $i = 1 ; - $H->put($i, "New One", R_IBEFORE) ; - - # delete record 3 - $H->del(3) ; - - # now print the records in reverse order - print "\nREVERSE\n" ; - for ($i = $H->length - 1 ; $i >= 0 ; -- $i) - { print "$i: $h[$i]\n" } - - # same again, but use the API functions instead - print "\nREVERSE again\n" ; - my ($s, $k, $v) = (0, 0, 0) ; - for ($s = $H->seq($k, $v, R_LAST) ; - $s == 0 ; - $s = $H->seq($k, $v, R_PREV)) - { print "$k: $v\n" } - - undef $H ; - untie @h ; - - unlink $file ; - } - - ok(126, docat_del($save_output) eq <<'EOM') ; - -ORIGINAL -0: zero -1: one -2: two -3: three -4: four - -The last record was [four] -The first record was [zero] - -REVERSE -5: last -4: three -3: Newbie -2: one -1: New One -0: first - -REVERSE again -5: last -4: three -3: Newbie -2: one -1: New One -0: first -EOM - -} - -{ - # Bug ID 20001013.009 - # - # test that $hash{KEY} = undef doesn't produce the warning - # Use of uninitialized value in null operation - use warnings ; - use strict ; - use DB_File ; - - unlink $Dfile; - my @h ; - my $a = ""; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - - tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO - or die "Can't open file: $!\n" ; - $h[0] = undef; - ok(127, $a eq "") ; - untie @h ; - unlink $Dfile; -} - -{ - # test that %hash = () doesn't produce the warning - # Argument "" isn't numeric in entersub - use warnings ; - use strict ; - use DB_File ; - my $a = ""; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - - unlink $Dfile; - my @h ; - - tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO - or die "Can't open file: $!\n" ; - @h = (); ; - ok(128, $a eq "") ; - untie @h ; - unlink $Dfile; -} - -exit ; diff --git a/t/lib/extutils.t b/t/lib/extutils.t deleted file mode 100644 index 50a9fe44f0..0000000000 --- a/t/lib/extutils.t +++ /dev/null @@ -1,483 +0,0 @@ -#!./perl -w - -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=>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 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 = 23; -my $maketest = "$make test"; -print "# make = '$maketest'\n"; -$makeout = `$maketest`; - -# echo of running the test script -$makeout =~ s/^\s*PERL_DL_NONLAZY=.+?\n//m; -$makeout =~ s/^MCR.+test.pl\n//mig if $^O eq 'VMS'; - -# GNU make babblings -$makeout =~ s/^\w*?make.+?(?:entering|leaving) directory.+?\n//mig; - -# Hopefully gets most make's babblings -# make -f Makefile.aperl perl -$makeout =~ s/^\w*?make.+\sperl[^A-Za-z0-9]*\n//mig; -# make[1]: `perl' is up to date. -$makeout =~ s/^\w*?make.+perl.+?is up to date.*?\n//mig; - -print $makeout; - -if ($?) { - print "not ok $test # $maketest failed: $?\n"; -} else { - print "ok $test\n"; -} -$test++; - -my $regen = `$runperl $package.xs`; -if ($?) { - print "not ok $test # $runperl $package.xs failed: $?\n"; -} else { - print "ok $test\n"; -} -$test++; - -my $expect = $constant_types . $C_constant . - "\n#### XS Section:\n" . $XS_constant; - -if ($expect eq $regen) { - print "ok $test\n"; -} else { - print "not ok $test\n"; - # open FOO, ">expect"; print FOO $expect; - # open FOO, ">regen"; print FOO $regen; close FOO; -} -$test++; - -my $makeclean = "$make clean"; -print "# make = '$makeclean'\n"; -$makeout = `$makeclean`; -if ($?) { - print "not ok $test # $make failed: $?\n"; -} else { - print "ok $test\n"; -} -$test++; - -foreach (@files) { - unlink $_ or warn "unlink $_: $!"; -} - -my $fail; -opendir DIR, "." or die "opendir '.': $!"; -while (defined (my $entry = readdir DIR)) { - next if $entry =~ /^\.\.?$/; - print "# Extra file '$entry'\n"; - $fail = 1; -} -closedir DIR or warn "closedir '.': $!"; -if ($fail) { - print "not ok $test\n"; -} else { - print "ok $test\n"; -} diff --git a/t/lib/filefind.t b/t/lib/filefind.t deleted file mode 100755 index 51e3ed8190..0000000000 --- a/t/lib/filefind.t +++ /dev/null @@ -1,734 +0,0 @@ -#!./perl - - -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; - - -BEGIN { - chdir 't' if -d 't'; - unshift @INC => '../lib'; - - $SIG{'__WARN__'} = sub { $warn_msg = $_[0]; warn "# $_[0]"; } -} - -if ( $symlink_exists ) { print "1..188\n"; } -else { print "1..78\n"; } - -use File::Find; -use File::Spec; - -cleanup(); - -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 (-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 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_Name{$n}; -} - -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_File{ $_}; -} - -sub simple_wanted { - 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_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_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( 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') ); - - -%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_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::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'); - - } - - - 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, 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'); - - - 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::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'); - -} - diff --git a/t/lib/filehand.t b/t/lib/filehand.t deleted file mode 100755 index eaddf496db..0000000000 --- a/t/lib/filehand.t +++ /dev/null @@ -1,91 +0,0 @@ -#!./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' || $^O eq 'NetWare' || - $Config{d_fork} ne 'define') { - $wr->autoflush; - $wr->printf("ok %d\n",11); - print $rd->getline; -} -else { - if (fork) { - $wr->close; - print $rd->getline; - } - else { - $rd->close; - $wr->printf("ok %d\n",11); - exit(0); - } -} diff --git a/t/lib/filter-util.t b/t/lib/filter-util.t deleted file mode 100644 index dc667c98ee..0000000000 --- a/t/lib/filter-util.t +++ /dev/null @@ -1,795 +0,0 @@ -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' || $^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' || $^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" ; -} - - diff --git a/t/lib/findtaint.t b/t/lib/findtaint.t deleted file mode 100644 index b2c33c4b4f..0000000000 --- a/t/lib/findtaint.t +++ /dev/null @@ -1,388 +0,0 @@ -#!./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); - -} - diff --git a/t/lib/ftmp-security.t b/t/lib/ftmp-security.t deleted file mode 100755 index f9be237dd3..0000000000 --- a/t/lib/ftmp-security.t +++ /dev/null @@ -1,140 +0,0 @@ -#!/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 'NetWare' || $^O eq 'os2' || $^O eq 'dos' - ) ? 1 : 0 ); - -# Can not run high security tests in perls before 5.6.0 -my $skipperl = ($] < 5.006 ? 1 : 0 ); - -# Determine whether we need to skip things and why -my $skip = 0; -if ($skipplat) { - $skip = "Skip Not supported on this platform"; -} elsif ($skipperl) { - $skip = "Skip Perl version must be v5.6.0 for these tests"; - -} - -print "# We will be skipping some tests : $skip\n" if $skip; - -# start off with basic checking - -File::Temp->safe_level( File::Temp::STANDARD ); - -print "# Testing with STANDARD security...\n"; - -&test_security(0); - -# Try medium - -File::Temp->safe_level( File::Temp::MEDIUM ) - unless $skip; - -print "# Testing with MEDIUM security...\n"; - -# Now we need to start skipping tests -&test_security($skip); - -# Try HIGH - -File::Temp->safe_level( File::Temp::HIGH ) - unless $skip; - -print "# Testing with HIGH security...\n"; - -&test_security($skip); - -exit; - -# Subroutine to open two temporary files. -# one is opened in the current dir and the other in the temp dir - -sub test_security { - - # Read in the skip flag - my $skip = shift; - - # If we are skipping we need to simply fake the correct number - # of tests -- we dont use skip since the tempfile() commands will - # fail with MEDIUM/HIGH security before the skip() command would be run - if ($skip) { - - skip($skip,1); - skip($skip,1); - - # plus we need an end block so the tests come out in the right order - eval q{ END { skip($skip,1); skip($skip,1) } 1; } || die; - - return; - } - - # Create the tempfile - my $template = "tmpXXXXX"; - my ($fh1, $fname1) = eval { tempfile ( $template, - DIR => File::Spec->tmpdir, - UNLINK => 1, - ); - }; - - if (defined $fname1) { - print "# fname1 = $fname1\n"; - ok( (-e $fname1) ); - push(@files, $fname1); # store for end block - } elsif (File::Temp->safe_level() != File::Temp::STANDARD) { - my $skip2 = "Skip system possibly insecure, see INSTALL, section 'make test'"; - skip($skip2, 1); - # plus we need an end block so the tests come out in the right order - eval q{ END { skip($skip2,1); } 1; } || die; - } else { - ok(0); - } - - # Explicitly - if ( $< < File::Temp->top_system_uid() ){ - skip("Skip Test inappropriate for root", 1); - eval q{ END { skip($skip,1); } 1; } || die; - return; - } - my ($fh2, $fname2) = eval { tempfile ($template, UNLINK => 1 ); }; - if (defined $fname2) { - print "# fname2 = $fname2\n"; - ok( (-e $fname2) ); - push(@files, $fname2); # store for end block - close($fh2); - } elsif (File::Temp->safe_level() != File::Temp::STANDARD) { - my $skip2 = "Skip system possibly insecure, see INSTALL, section 'make test'"; - skip($skip2, 1); - # plus we need an end block so the tests come out in the right order - eval q{ END { skip($skip2,1); } 1; } || die; - } else { - ok(0); - } - -} diff --git a/t/lib/gdbm.t b/t/lib/gdbm.t deleted file mode 100755 index 0f5cfa0186..0000000000 --- a/t/lib/gdbm.t +++ /dev/null @@ -1,427 +0,0 @@ -#!./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 '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*>; -} diff --git a/t/lib/glob-basic.t b/t/lib/glob-basic.t deleted file mode 100755 index ef9dd96495..0000000000 --- a/t/lib/glob-basic.t +++ /dev/null @@ -1,175 +0,0 @@ -#!./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 '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' && $^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 'NetWare' or $^O eq 'os2' or $^O eq 'VMS' - or $^O eq 'cygwin' or Cwd::cwd() =~ m#^$Config{'afsroot'}#s or not $>) -{ - print "ok 6 # skipped\n"; -} -else { - $dir = "pteerslt"; - mkdir $dir, 0; - @a = bsd_glob("$dir/*", GLOB_ERR); - #print "\@a = ", array(@a); - rmdir $dir; - if (scalar(@a) != 0 || GLOB_ERROR == 0) { - print "not "; - } - print "ok 6\n"; -} - -# check for csh style globbing -@a = bsd_glob('{a,b}', GLOB_BRACE | GLOB_NOMAGIC); -unless (@a == 2 and $a[0] eq 'a' and $a[1] eq 'b') { - print "not "; -} -print "ok 7\n"; - -@a = bsd_glob( - '{TES*,doesntexist*,a,b}', - GLOB_BRACE | GLOB_NOMAGIC | ($^O eq 'VMS' ? GLOB_NOCASE : 0) -); - -# Working on t/TEST often causes this test to fail because it sees Emacs temp -# and RCS files. Filter them out, and .pm files too, and patch temp files. -@a = grep !/(,v$|~$|\.(pm|ori?g|rej)$)/, @a; - -print "# @a\n"; - -unless (@a == 3 - and $a[0] eq ($^O eq 'VMS'? 'test.' : 'TEST') - and $a[1] eq 'a' - and $a[2] eq 'b') -{ - print "not ok 8 # @a"; -} else { - print "ok 8\n"; -} - -# "~" should expand to $ENV{HOME} -$ENV{HOME} = "sweet home"; -@a = bsd_glob('~', GLOB_TILDE | GLOB_NOMAGIC); -unless ($^O eq "MacOS" || (@a == 1 and $a[0] eq $ENV{HOME})) { - print "not "; -} -print "ok 9\n"; - -# GLOB_ALPHASORT (default) should sort alphabetically regardless of case -mkdir "pteerslt", 0777; -chdir "pteerslt"; - -@f_names = qw(Ax.pl Bx.pl Cx.pl aY.pl bY.pl cY.pl); -@f_alpha = qw(Ax.pl aY.pl Bx.pl bY.pl Cx.pl cY.pl); -if ('a' lt 'A') { # EBCDIC char sets sort lower case before UPPER - @f_names = sort(@f_names); -} -if ($^O eq 'VMS') { # VMS is happily caseignorant - @f_alpha = qw(ax.pl ay.pl bx.pl by.pl cx.pl cy.pl); - @f_names = @f_alpha; -} - -for (@f_names) { - open T, "> $_"; - close T; -} - -$pat = "*.pl"; - -$ok = 1; -@g_names = bsd_glob($pat, 0); -print "# f_names = @f_names\n"; -print "# g_names = @g_names\n"; -for (@f_names) { - $ok = 0 unless $_ eq shift @g_names; -} -print $ok ? "ok 10\n" : "not ok 10\n"; - -$ok = 1; -@g_alpha = bsd_glob($pat); -print "# f_alpha = @f_alpha\n"; -print "# g_alpha = @g_alpha\n"; -for (@f_alpha) { - $ok = 0 unless $_ eq shift @g_alpha; -} -print $ok ? "ok 11\n" : "not ok 11\n"; - -unlink @f_names; -chdir ".."; -rmdir "pteerslt"; diff --git a/t/lib/glob-case.t b/t/lib/glob-case.t deleted file mode 100755 index 3c3980c880..0000000000 --- a/t/lib/glob-case.t +++ /dev/null @@ -1,60 +0,0 @@ -#!./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' && $^O ne 'NetWare') { - print "ok 5\nok 6\nok 7\n"; -} -else { - @a = File::Glob::glob("lib\\g*.t"); - print "not " unless @a >= 3; - print "ok 5\n"; - mkdir "[]", 0; - @a = File::Glob::glob("\\[\\]", GLOB_QUOTE); - rmdir "[]"; - print "# returned @a\nnot " unless @a == 1; - print "ok 6\n"; - @a = bsd_glob("lib\\*", GLOB_QUOTE); - print "not " if @a == 0; - print "ok 7\n"; -} diff --git a/t/lib/io_dup.t b/t/lib/io_dup.t deleted file mode 100755 index 8983a56f36..0000000000 --- a/t/lib/io_dup.t +++ /dev/null @@ -1,61 +0,0 @@ -#!./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' || $^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' || $^O eq 'NetWare') { print `type Io.dup` } -else { system 'cat Io.dup' } -unlink 'Io.dup'; - -print STDOUT "ok 6\n"; diff --git a/t/lib/io_poll.t b/t/lib/io_poll.t deleted file mode 100755 index d31ea47f53..0000000000 --- a/t/lib/io_poll.t +++ /dev/null @@ -1,82 +0,0 @@ -#!./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' || $^O eq 'NetWare') { -print "ok 3 # skipped, doesn't work on non-socket fds\n"; -print "ok 4 # skipped, doesn't work on non-socket fds\n"; -} -else { -print "not " - unless $poll->events($stdout) == POLLOUT; -print "ok 3\n"; - -print "not " - if $poll->events($dupout); -print "ok 4\n"; -} - -my @h = $poll->handles; -print "not " - unless @h == 2; -print "ok 5\n"; - -$poll->remove($stdout); - -@h = $poll->handles; - -print "not " - unless @h == 1; -print "ok 6\n"; - -print "not " - if $poll->mask($stdout); -print "ok 7\n"; - -$poll->poll(0.1); - -print "not " - if $poll->events($stdout); -print "ok 8\n"; - -$poll->remove($dupout); -print "not " - if $poll->handles; -print "ok 9\n"; diff --git a/t/lib/io_sel.t b/t/lib/io_sel.t deleted file mode 100755 index 84660db183..0000000000 --- a/t/lib/io_sel.t +++ /dev/null @@ -1,132 +0,0 @@ -#!./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 'NetWare' || $^O eq 'dos') { # 4-arg select is only valid on sockets - print "# skipping tests 10..15\n"; - for (10 .. 15) { print "ok $_\n" } - $sel->add(\*STDOUT); # update - goto POST_SOCKET; -} - -@a = $sel->can_read(); # should return imediately -print "not " unless @a == 0; -print "ok 10\n"; - -# we assume that we can write to STDOUT :-) -$sel->add([\*STDOUT, "ok 12\n"]); - -@a = $sel->can_write; -print "not " unless @a == 1; -print "ok 11\n"; - -my($fd, $msg) = @{shift @a}; -print $fd $msg; - -$sel->add(\*STDOUT); # update - -@a = IO::Select::select(undef, $sel, undef, 1); -print "not " unless @a == 3; -print "ok 13\n"; - -($r, $w, $e) = @a; - -print "not " unless @$r == 0 && @$w == 1 && @$e == 0; -print "ok 14\n"; - -$fd = $w->[0]; -print $fd "ok 15\n"; - -POST_SOCKET: -# Test new exists() method -$sel->exists(\*STDIN) and print "not "; -print "ok 16\n"; - -($sel->exists(0) || $sel->exists([\*STDERR])) and print "not "; -print "ok 17\n"; - -$fd = $sel->exists(\*STDOUT); -if ($fd) { - print $fd "ok 18\n"; -} else { - print "not ok 18\n"; -} - -$fd = $sel->exists([1, 'foo']); -if ($fd) { - print $fd "ok 19\n"; -} else { - print "not ok 19\n"; -} - -# Try self clearing -$sel->add(5,6,7,8,9,10); -print "not " unless $sel->count == 7; -print "ok 20\n"; - -$sel->remove($sel->handles); -print "not " unless $sel->count == 0 && !defined($sel->bits); -print "ok 21\n"; - -# check warnings -$SIG{__WARN__} = sub { - ++ $w - if $_[0] =~ /^Call to depreciated method 'has_error', use 'has_exception'/ - } ; -$w = 0 ; -IO::Select::has_error(); -print "not " unless $w == 0 ; -$w = 0 ; -print "ok 22\n" ; -use warnings 'IO::Select' ; -IO::Select::has_error(); -print "not " unless $w == 1 ; -$w = 0 ; -print "ok 23\n" ; diff --git a/t/lib/io_taint.t b/t/lib/io_taint.t deleted file mode 100755 index c98d70151f..0000000000 --- a/t/lib/io_taint.t +++ /dev/null @@ -1,48 +0,0 @@ -#!./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') && ($^O ne 'NetWare')) and ($@ !~ /^Insecure/o)); -print "ok 1\n"; -$x->close; - -# We could have just done a seek on $x, but technically we haven't tested -# seek yet... -$x = new IO::File "< ./__taint__$$" || die("Cannot open ./__taint__$$\n"); -$x->untaint; -print "not " if ($?); -print "ok 2\n"; # Calling the method worked -chop($unsafe = <$x>); -eval { kill 0 * $unsafe }; -print "not " if ($@ =~ /^Insecure/o); -print "ok 3\n"; # No Insecure message from using the data -$x->close; - -exit 0; diff --git a/t/lib/mbimbf.t b/t/lib/mbimbf.t deleted file mode 100644 index 3948102f0e..0000000000 --- a/t/lib/mbimbf.t +++ /dev/null @@ -1,214 +0,0 @@ -#!/usr/bin/perl -w - -# test accuracy, precicion and fallback, round_mode - -use strict; -use Test; - -BEGIN - { - $| = 1; - # chdir 't' if -d 't'; - unshift @INC, '../lib'; # for running manually - plan tests => 103; - } - -use Math::BigInt; -use Math::BigFloat; - -my ($x,$y,$z,$u); - -############################################################################### -# test defaults and set/get - -ok_undef ($Math::BigInt::accuracy); -ok_undef ($Math::BigInt::precision); -ok ($Math::BigInt::div_scale,40); -ok (Math::BigInt::round_mode(),'even'); -ok ($Math::BigInt::rnd_mode,'even'); - -ok_undef ($Math::BigFloat::accuracy); -ok_undef ($Math::BigFloat::precision); -ok ($Math::BigFloat::div_scale,40); -ok ($Math::BigFloat::rnd_mode,'even'); - -# accuracy -foreach (qw/5 42 -1 0/) - { - ok ($Math::BigFloat::accuracy = $_,$_); - ok ($Math::BigInt::accuracy = $_,$_); - } -ok_undef ($Math::BigFloat::accuracy = undef); -ok_undef ($Math::BigInt::accuracy = undef); - -# precision -foreach (qw/5 42 -1 0/) - { - ok ($Math::BigFloat::precision = $_,$_); - ok ($Math::BigInt::precision = $_,$_); - } -ok_undef ($Math::BigFloat::precision = undef); -ok_undef ($Math::BigInt::precision = undef); - -# fallback -foreach (qw/5 42 1/) - { - ok ($Math::BigFloat::div_scale = $_,$_); - ok ($Math::BigInt::div_scale = $_,$_); - } -# illegal values are possible for fallback due to no accessor - -# round_mode -foreach (qw/odd even zero trunc +inf -inf/) - { - ok ($Math::BigFloat::rnd_mode = $_,$_); - ok ($Math::BigInt::rnd_mode = $_,$_); - } -$Math::BigFloat::rnd_mode = 4; -ok ($Math::BigFloat::rnd_mode,4); -ok ($Math::BigInt::rnd_mode,'-inf'); # from above - -$Math::BigInt::accuracy = undef; -$Math::BigInt::precision = undef; -# local copies -$x = Math::BigFloat->new(123.456); -ok_undef ($x->accuracy()); -ok ($x->accuracy(5),5); -ok_undef ($x->accuracy(undef),undef); -ok_undef ($x->precision()); -ok ($x->precision(5),5); -ok_undef ($x->precision(undef),undef); - -# see if MBF changes MBIs values -ok ($Math::BigInt::accuracy = 42,42); -ok ($Math::BigFloat::accuracy = 64,64); -ok ($Math::BigInt::accuracy,42); # should be still 42 -ok ($Math::BigFloat::accuracy,64); # should be still 64 - -############################################################################### -# see if creating a number under set A or P will round it - -$Math::BigInt::accuracy = 4; -$Math::BigInt::precision = 3; - -ok (Math::BigInt->new(123456),123500); # with A -$Math::BigInt::accuracy = undef; -ok (Math::BigInt->new(123456),123000); # with P - -$Math::BigFloat::accuracy = 4; -$Math::BigFloat::precision = -1; -$Math::BigInt::precision = undef; - -ok (Math::BigFloat->new(123.456),123.5); # with A -$Math::BigFloat::accuracy = undef; -ok (Math::BigFloat->new(123.456),123.5); # with P from MBF, not MBI! - -$Math::BigFloat::precision = undef; - -############################################################################### -# see if setting accuracy/precision actually rounds the number - -$x = Math::BigFloat->new(123.456); $x->accuracy(4); ok ($x,123.5); -$x = Math::BigFloat->new(123.456); $x->precision(-2); ok ($x,123.46); - -$x = Math::BigInt->new(123456); $x->accuracy(4); ok ($x,123500); -$x = Math::BigInt->new(123456); $x->precision(2); ok ($x,123500); - -############################################################################### -# test actual rounding via round() - -$x = Math::BigFloat->new(123.456); -ok ($x->copy()->round(5,2),123.46); -ok ($x->copy()->round(4,2),123.5); -ok ($x->copy()->round(undef,-2),123.46); -ok ($x->copy()->round(undef,2),100); - -$x = Math::BigFloat->new(123.45000); -ok ($x->copy()->round(undef,-1,'odd'),123.5); - -# see if rounding is 'sticky' -$x = Math::BigFloat->new(123.4567); -$y = $x->copy()->bround(); # no-op since nowhere A or P defined - -ok ($y,123.4567); -$y = $x->copy()->round(5,2); -ok ($y->accuracy(),5); -ok_undef ($y->precision()); # A has precedence, so P still unset -$y = $x->copy()->round(undef,2); -ok ($y->precision(),2); -ok_undef ($y->accuracy()); # P has precedence, so A still unset - -# does copy work? -$x = Math::BigFloat->new(123.456); $x->accuracy(4); $x->precision(2); -$z = $x->copy(); ok ($z->accuracy(),4); ok ($z->precision(),2); - -############################################################################### -# test wether operations round properly afterwards -# These tests are not complete, since they do not excercise every "return" -# statement in the op's. But heh, it's better than nothing... - -$x = Math::BigFloat->new(123.456); -$y = Math::BigFloat->new(654.321); -$x->{_a} = 5; # $x->accuracy(5) would round $x straightaway -$y->{_a} = 4; # $y->accuracy(4) would round $x straightaway - -$z = $x + $y; ok ($z,777.8); -$z = $y - $x; ok ($z,530.9); -$z = $y * $x; ok ($z,80780); -$z = $x ** 2; ok ($z,15241); -$z = $x * $x; ok ($z,15241); -# not yet: $z = -$x; ok ($z,-123.46); ok ($x,123.456); -$z = $x->copy(); $z->{_a} = 2; $z = $z / 2; ok ($z,62); -$x = Math::BigFloat->new(123456); $x->{_a} = 4; -$z = $x->copy; $z++; ok ($z,123500); - -$x = Math::BigInt->new(123456); -$y = Math::BigInt->new(654321); -$x->{_a} = 5; # $x->accuracy(5) would round $x straightaway -$y->{_a} = 4; # $y->accuracy(4) would round $x straightaway - -$z = $x + $y; ok ($z,777800); -$z = $y - $x; ok ($z,530900); -$z = $y * $x; ok ($z,80780000000); -$z = $x ** 2; ok ($z,15241000000); -# not yet: $z = -$x; ok ($z,-123460); ok ($x,123456); -$z = $x->copy; $z++; ok ($z,123460); -$z = $x->copy(); $z->{_a} = 2; $z = $z / 2; ok ($z,62000); - -############################################################################### -# test mixed arguments - -$x = Math::BigFloat->new(10); -$u = Math::BigFloat->new(2.5); -$y = Math::BigInt->new(2); - -$z = $x + $y; ok ($z,12); ok (ref($z),'Math::BigFloat'); -$z = $x / $y; ok ($z,5); ok (ref($z),'Math::BigFloat'); -$z = $u * $y; ok ($z,5); ok (ref($z),'Math::BigFloat'); - -$y = Math::BigInt->new(12345); -$z = $u->copy()->bmul($y,2,0,'odd'); ok ($z,31000); -$z = $u->copy()->bmul($y,3,0,'odd'); ok ($z,30900); -$z = $u->copy()->bmul($y,undef,0,'odd'); ok ($z,30863); -$z = $u->copy()->bmul($y,undef,1,'odd'); ok ($z,30860); -$z = $u->copy()->bmul($y,undef,-1,'odd'); ok ($z,30862.5); - -# breakage: -# $z = $y->copy()->bmul($u,2,0,'odd'); ok ($z,31000); -# $z = $y * $u; ok ($z,5); ok (ref($z),'Math::BigInt'); -# $z = $y + $x; ok ($z,12); ok (ref($z),'Math::BigInt'); -# $z = $y / $x; ok ($z,0); ok (ref($z),'Math::BigInt'); - -# all done - -############################################################################### -# Perl 5.005 does not like ok ($x,undef) - -sub ok_undef - { - my $x = shift; - - ok (1,1) and return if !defined $x; - ok ($x,'undef'); - } - diff --git a/t/lib/ndbm.t b/t/lib/ndbm.t deleted file mode 100755 index cb975e0047..0000000000 --- a/t/lib/ndbm.t +++ /dev/null @@ -1,420 +0,0 @@ -#!./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' || $^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)) ; -} diff --git a/t/lib/net-hostent.t b/t/lib/net-hostent.t deleted file mode 100644 index c3a12194ec..0000000000 --- a/t/lib/net-hostent.t +++ /dev/null @@ -1,72 +0,0 @@ -#!./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 'NetWare' or $^O eq 'cygwin') { - print "ok $_ # skipped on win32\n" for (6,7); -} else { - my $in_alias; - unless ($h->name =~ /^localhost(?:\..+)?$/i) { - foreach (@{$h->aliases}) { - if (/^localhost(?:\..+)?$/i) { - $in_alias = 1; - last; - } - } - print "not " unless $in_alias; - } # Else we found it as the hostname - print "ok 6 # ",$h->name, " ", join (",", @{$h->aliases}), "\n"; - - if ($in_alias) { - # If we found it in the aliases before, expect to find it there again. - foreach (@{$h->aliases}) { - if (/^localhost(?:\..+)?$/i) { - undef $in_alias; # This time, clear the flag if we see "localhost" - last; - } - } - print "not " if $in_alias; - } else { - print "not " unless $i->name =~ /^localhost(?:\..+)?$/i; - } - print "ok 7 # ",$h->name, " ", join (",", @{$h->aliases}), "\n"; -} diff --git a/t/lib/odbm.t b/t/lib/odbm.t deleted file mode 100755 index a43e70bd99..0000000000 --- a/t/lib/odbm.t +++ /dev/null @@ -1,437 +0,0 @@ -#!./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' || $^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 -} diff --git a/t/lib/open2.t b/t/lib/open2.t deleted file mode 100755 index fe49189d83..0000000000 --- a/t/lib/open2.t +++ /dev/null @@ -1,59 +0,0 @@ -#!./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' && $^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' || $^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, $?; diff --git a/t/lib/open3.t b/t/lib/open3.t deleted file mode 100755 index 7d2d4113df..0000000000 --- a/t/lib/open3.t +++ /dev/null @@ -1,150 +0,0 @@ -#!./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' && $^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' || $^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; -} diff --git a/t/lib/posix.t b/t/lib/posix.t deleted file mode 100755 index 09bd88c2a9..0000000000 --- a/t/lib/posix.t +++ /dev/null @@ -1,139 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($^O ne 'VMS' and $Config{'extensions'} !~ /\bPOSIX\b/) { - print "1..0\n"; - exit 0; - } -} - -use POSIX qw(fcntl_h signal_h limits_h _exit getcwd open read strftime write); -use strict subs; - -$| = 1; -print "1..27\n"; - -$Is_W32 = $^O eq 'MSWin32'; -$Is_NetWare = $^O eq 'NetWare'; -$Is_Dos = $^O eq 'dos'; - -$testfd = open("TEST", O_RDONLY, 0) and print "ok 1\n"; -read($testfd, $buffer, 9) if $testfd > 2; -print $buffer eq "#!./perl\n" ? "ok 2\n" : "not ok 2\n"; - -write(1,"ok 3\nnot ok 3\n", 5); - -if ($Is_Dos) { - for (4..5) { - print "ok $_ # skipped, no pipe() support on dos\n"; - } -} else { -@fds = POSIX::pipe(); -print $fds[0] > $testfd ? "ok 4\n" : "not ok 4\n"; -CORE::open($reader = \*READER, "<&=".$fds[0]); -CORE::open($writer = \*WRITER, ">&=".$fds[1]); -print $writer "ok 5\n"; -close $writer; -print <$reader>; -close $reader; -} - -if ($Is_W32 || $Is_Dos) { - for (6..11) { - print "ok $_ # skipped, no sigaction support on win32/dos\n"; - } -} -else { -$sigset = new POSIX::SigSet 1,3; -delset $sigset 1; -if (!ismember $sigset 1) { print "ok 6\n" } -if (ismember $sigset 3) { print "ok 7\n" } -$mask = new POSIX::SigSet &SIGINT; -$action = new POSIX::SigAction 'main::SigHUP', $mask, 0; -sigaction(&SIGHUP, $action); -$SIG{'INT'} = 'SigINT'; -kill 'HUP', $$; -sleep 1; -print "ok 11\n"; - -sub SigHUP { - print "ok 8\n"; - kill 'INT', $$; - sleep 2; - print "ok 9\n"; -} - -sub SigINT { - print "ok 10\n"; -} -} - -print &_POSIX_OPEN_MAX > $fds[1] ? "ok 12\n" : "not ok 12\n"; - -print getcwd() =~ m#/t$# ? "ok 13\n" : "not ok 13\n"; - -# Check string conversion functions. - -if ($Config{d_strtod}) { - $lc = &POSIX::setlocale(&POSIX::LC_NUMERIC, 'C') if $Config{d_setlocale}; - ($n, $x) = &POSIX::strtod('3.14159_OR_SO'); -# Using long double NVs may introduce greater accuracy than wanted. - $n =~ s/^3.1415(8999|9000)\d*$/3.14159/ - if $Config{uselongdouble} eq 'define'; - print (($n == 3.14159) && ($x == 6) ? - "ok 14\n" : "not ok 14\n"); - &POSIX::setlocale(&POSIX::LC_NUMERIC, $lc) if $Config{d_setlocale}; -} else { print "# strtod not present\n", "ok 14\n"; } - -if ($Config{d_strtol}) { - ($n, $x) = &POSIX::strtol('21_PENGUINS'); - print (($n == 21) && ($x == 9) ? "ok 15\n" : "not ok 15\n"); -} else { print "# strtol not present\n", "ok 15\n"; } - -if ($Config{d_strtoul}) { - ($n, $x) = &POSIX::strtoul('88_TEARS'); - print (($n == 88) && ($x == 6) ? "ok 16\n" : "not ok 16\n"); -} else { print "# strtoul not present\n", "ok 16\n"; } - -# Pick up whether we're really able to dynamically load everything. -print &POSIX::acos(1.0) == 0.0 ? "ok 17\n" : "not ok 17\n"; - -# This can coredump if struct tm has a timezone field and we -# didn't detect it. If this fails, try adding -# -DSTRUCT_TM_HASZONE to your cflags when compiling ext/POSIX/POSIX.c. -# See ext/POSIX/hints/sunos_4.pl and ext/POSIX/hints/linux.pl -print POSIX::strftime("ok 18 # %H:%M, on %D\n", localtime()); - -# If that worked, validate the mini_mktime() routine's normalisation of -# input fields to strftime(). -sub try_strftime { - my $num = shift; - my $expect = shift; - my $got = POSIX::strftime("%a %b %d %H:%M:%S %Y %j", @_); - if ($got eq $expect) { - print "ok $num\n"; - } - else { - print "# expected: $expect\n# got: $got\nnot ok $num\n"; - } -} - -$lc = &POSIX::setlocale(&POSIX::LC_TIME, 'C') if $Config{d_setlocale}; -try_strftime(19, "Wed Feb 28 00:00:00 1996 059", 0,0,0, 28,1,96); -try_strftime(20, "Thu Feb 29 00:00:60 1996 060", 60,0,-24, 30,1,96); -try_strftime(21, "Fri Mar 01 00:00:00 1996 061", 0,0,-24, 31,1,96); -try_strftime(22, "Sun Feb 28 00:00:00 1999 059", 0,0,0, 28,1,99); -try_strftime(23, "Mon Mar 01 00:00:00 1999 060", 0,0,24, 28,1,99); -try_strftime(24, "Mon Feb 28 00:00:00 2000 059", 0,0,0, 28,1,100); -try_strftime(25, "Tue Feb 29 00:00:00 2000 060", 0,0,0, 0,2,100); -try_strftime(26, "Wed Mar 01 00:00:00 2000 061", 0,0,0, 1,2,100); -try_strftime(27, "Fri Mar 31 00:00:00 2000 091", 0,0,0, 31,2,100); -&POSIX::setlocale(&POSIX::LC_TIME, $lc) if $Config{d_setlocale}; - -$| = 0; -# The following line assumes buffered output, which may be not true with EMX: -print '@#!*$@(!@#$' unless ($^O eq 'os2' || $^O eq 'uwin' || $^O eq 'os390'); -_exit(0); diff --git a/t/lib/sdbm.t b/t/lib/sdbm.t deleted file mode 100755 index 57928e0e51..0000000000 --- a/t/lib/sdbm.t +++ /dev/null @@ -1,429 +0,0 @@ -#!./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 '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*>; -} diff --git a/t/lib/sigaction.t b/t/lib/sigaction.t deleted file mode 100644 index c38b122775..0000000000 --- a/t/lib/sigaction.t +++ /dev/null @@ -1,127 +0,0 @@ -#!./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' || $^O eq 'NetWare') { - print "1..0\n"; - exit 0; - } -} - -use strict; -use vars qw/$bad7 $ok10 $bad18 $ok/; - -$^W=1; - -print "1..18\n"; - -sub IGNORE { - $bad7=1; -} - -sub DEFAULT { - $bad18=1; -} - -sub foo { - $ok=1; -} - -my $newaction=POSIX::SigAction->new('::foo', new POSIX::SigSet(SIGUSR1), 0); -my $oldaction=POSIX::SigAction->new('::bar', new POSIX::SigSet(), 0); - -{ - my $bad; - local($SIG{__WARN__})=sub { $bad=1; }; - sigaction(SIGHUP, $newaction, $oldaction); - if($bad) { print "not ok 1\n" } else { print "ok 1\n"} -} - -if($oldaction->{HANDLER} eq 'DEFAULT' || - $oldaction->{HANDLER} eq 'IGNORE') - { print "ok 2\n" } else { print "not ok 2 # ", $oldaction->{HANDLER}, "\n"} -print $SIG{HUP} eq '::foo' ? "ok 3\n" : "not ok 3\n"; - -sigaction(SIGHUP, $newaction, $oldaction); -if($oldaction->{HANDLER} eq '::foo') - { print "ok 4\n" } else { print "not ok 4\n"} -if($oldaction->{MASK}->ismember(SIGUSR1)) - { print "ok 5\n" } else { print "not ok 5\n"} -if($oldaction->{FLAGS}) { - if ($^O eq 'linux') { - print "ok 6 # Skip: sigaction() broken in $^O\n"; - } else { - print "not ok 6\n"; - } -} else { - print "ok 6\n"; -} - -$newaction=POSIX::SigAction->new('IGNORE'); -sigaction(SIGHUP, $newaction); -kill 'HUP', $$; -print $bad7 ? "not ok 7\n" : "ok 7\n"; - -print $SIG{HUP} eq 'IGNORE' ? "ok 8\n" : "not ok 8\n"; -sigaction(SIGHUP, POSIX::SigAction->new('DEFAULT')); -print $SIG{HUP} eq 'DEFAULT' ? "ok 9\n" : "not ok 9\n"; - -$newaction=POSIX::SigAction->new(sub { $ok10=1; }); -sigaction(SIGHUP, $newaction); -{ - local($^W)=0; - kill 'HUP', $$; -} -print $ok10 ? "ok 10\n" : "not ok 10\n"; - -print ref($SIG{HUP}) eq 'CODE' ? "ok 11\n" : "not ok 11\n"; - -sigaction(SIGHUP, POSIX::SigAction->new('::foo')); -# Make sure the signal mask gets restored after sigaction croak()s. -eval { - my $act=POSIX::SigAction->new('::foo'); - delete $act->{HANDLER}; - sigaction(SIGINT, $act); -}; -kill 'HUP', $$; -print $ok ? "ok 12\n" : "not ok 12\n"; - -undef $ok; -# Make sure the signal mask gets restored after sigaction returns early. -my $x=defined sigaction(SIGKILL, $newaction, $oldaction); -kill 'HUP', $$; -print !$x && $ok ? "ok 13\n" : "not ok 13\n"; - -$SIG{HUP}=sub {}; -sigaction(SIGHUP, $newaction, $oldaction); -print ref($oldaction->{HANDLER}) eq 'CODE' ? "ok 14\n" : "not ok 14\n"; - -eval { - sigaction(SIGHUP, undef, $oldaction); -}; -print $@ ? "not ok 15\n" : "ok 15\n"; - -eval { - sigaction(SIGHUP, 0, $oldaction); -}; -print $@ ? "not ok 16\n" : "ok 16\n"; - -eval { - sigaction(SIGHUP, bless({},'Class'), $oldaction); -}; -print $@ ? "ok 17\n" : "not ok 17\n"; - -$newaction=POSIX::SigAction->new(sub { $ok10=1; }); -sigaction(SIGCONT, POSIX::SigAction->new('DEFAULT')); -{ - local($^W)=0; - kill 'CONT', $$; -} -print $bad18 ? "not ok 18\n" : "ok 18\n"; - diff --git a/t/lib/syslfs.t b/t/lib/syslfs.t deleted file mode 100644 index 8d9769fded..0000000000 --- a/t/lib/syslfs.t +++ /dev/null @@ -1,267 +0,0 @@ -# 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 '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 diff --git a/t/pragma/locale.t b/t/pragma/locale.t deleted file mode 100755 index e58616cbef..0000000000 --- a/t/pragma/locale.t +++ /dev/null @@ -1,839 +0,0 @@ -#!./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' || $^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 diff --git a/t/pragma/strict.t b/t/pragma/strict.t deleted file mode 100755 index 8b9083f4fc..0000000000 --- a/t/pragma/strict.t +++ /dev/null @@ -1,100 +0,0 @@ -#!./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 $_ } -} diff --git a/t/pragma/subs.t b/t/pragma/subs.t deleted file mode 100755 index 2f684b41ed..0000000000 --- a/t/pragma/subs.t +++ /dev/null @@ -1,162 +0,0 @@ -#!./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 diff --git a/t/pragma/warn/mg b/t/pragma/warn/mg deleted file mode 100644 index f2243357b3..0000000000 --- a/t/pragma/warn/mg +++ /dev/null @@ -1,44 +0,0 @@ - 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 '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 'NetWare' || $^O eq 'VMS') { - print "SKIPPED\n# win32, can't kill() to raise()\n"; exit; -} -$|=1; -$SIG{"INT"} = "fred"; kill "INT",$$; -EXPECT - diff --git a/t/pragma/warnings.t b/t/pragma/warnings.t deleted file mode 100644 index 09b41fbd64..0000000000 --- a/t/pragma/warnings.t +++ /dev/null @@ -1,131 +0,0 @@ -#!./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 $_ } -} |