diff options
Diffstat (limited to 'contrib/perl5/t/lib')
123 files changed, 0 insertions, 17663 deletions
diff --git a/contrib/perl5/t/lib/abbrev.t b/contrib/perl5/t/lib/abbrev.t deleted file mode 100755 index fb5a984..0000000 --- a/contrib/perl5/t/lib/abbrev.t +++ /dev/null @@ -1,51 +0,0 @@ -#!./perl - -print "1..7\n"; - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Text::Abbrev; - -print "ok 1\n"; - -# old style as reference -local(%x); -my @z = qw(list edit send abort gripe listen); -abbrev(*x, @z); -my $r = join ':', sort keys %x; -print "not " if exists $x{'l'} || - exists $x{'li'} || - exists $x{'lis'}; -print "ok 2\n"; - -print "not " unless $x{'list'} eq 'list' && - $x{'liste'} eq 'listen' && - $x{'listen'} eq 'listen'; -print "ok 3\n"; - -print "not " unless $x{'a'} eq 'abort' && - $x{'ab'} eq 'abort' && - $x{'abo'} eq 'abort' && - $x{'abor'} eq 'abort' && - $x{'abort'} eq 'abort'; -print "ok 4\n"; - -my $test = 5; - -# wantarray -my %y = abbrev @z; -my $s = join ':', sort keys %y; -print (($r eq $s)?"ok $test\n":"not ok $test\n"); $test++; - -my $y = abbrev @z; -$s = join ':', sort keys %$y; -print (($r eq $s)?"ok $test\n":"not ok $test\n"); $test++; - -%y = (); -abbrev \%y, @z; - -$s = join ':', sort keys %y; -print (($r eq $s)?"ok $test\n":"not ok $test\n"); $test++; diff --git a/contrib/perl5/t/lib/ansicolor.t b/contrib/perl5/t/lib/ansicolor.t deleted file mode 100755 index f38e905..0000000 --- a/contrib/perl5/t/lib/ansicolor.t +++ /dev/null @@ -1,81 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -# Test suite for the Term::ANSIColor Perl module. Before `make install' is -# performed this script should be runnable with `make test'. After `make -# install' it should work as `perl test.pl'. - -############################################################################ -# Ensure module can be loaded -############################################################################ - -BEGIN { $| = 1; print "1..8\n" } -END { print "not ok 1\n" unless $loaded } -use Term::ANSIColor qw(:constants color colored); -$loaded = 1; -print "ok 1\n"; - - -############################################################################ -# Test suite -############################################################################ - -# Test simple color attributes. -if (color ('blue on_green', 'bold') eq "\e[34;42;1m") { - print "ok 2\n"; -} else { - print "not ok 2\n"; -} - -# Test colored. -if (colored ("testing", 'blue', 'bold') eq "\e[34;1mtesting\e[0m") { - print "ok 3\n"; -} else { - print "not ok 3\n"; -} - -# Test the constants. -if (BLUE BOLD "testing" eq "\e[34m\e[1mtesting") { - print "ok 4\n"; -} else { - print "not ok 4\n"; -} - -# Test AUTORESET. -$Term::ANSIColor::AUTORESET = 1; -if (BLUE BOLD "testing" eq "\e[34m\e[1mtesting\e[0m\e[0m") { - print "ok 5\n"; -} else { - print "not ok 5\n"; -} - -# Test EACHLINE. -$Term::ANSIColor::EACHLINE = "\n"; -if (colored ("test\n\ntest", 'bold') - eq "\e[1mtest\e[0m\n\n\e[1mtest\e[0m") { - print "ok 6\n"; -} else { - print colored ("test\n\ntest", 'bold'), "\n"; - print "not ok 6\n"; -} - -# Test EACHLINE with multiple trailing delimiters. -$Term::ANSIColor::EACHLINE = "\r\n"; -if (colored ("test\ntest\r\r\n\r\n", 'bold') - eq "\e[1mtest\ntest\r\e[0m\r\n\r\n") { - print "ok 7\n"; -} else { - print "not ok 7\n"; -} - -# Test the array ref form. -$Term::ANSIColor::EACHLINE = "\n"; -if (colored (['bold', 'on_green'], "test\n", "\n", "test") - eq "\e[1;42mtest\e[0m\n\n\e[1;42mtest\e[0m") { - print "ok 8\n"; -} else { - print colored (['bold', 'on_green'], "test\n", "\n", "test"); - print "not ok 8\n"; -} diff --git a/contrib/perl5/t/lib/anydbm.t b/contrib/perl5/t/lib/anydbm.t deleted file mode 100755 index 40c4366..0000000 --- a/contrib/perl5/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' 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) { - 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/contrib/perl5/t/lib/attrs.t b/contrib/perl5/t/lib/attrs.t deleted file mode 100755 index 440122c..0000000 --- a/contrib/perl5/t/lib/attrs.t +++ /dev/null @@ -1,138 +0,0 @@ -#!./perl - -# Regression tests for attrs.pm and the C<sub x : attrs> syntax. - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - eval 'require attrs; 1' or do { - print "1..0\n"; - exit 0; - } -} - -sub NTESTS () ; - -my $test, $ntests; -BEGIN {$ntests=0} -$test=0; -my $failed = 0; - -print "1..".NTESTS."\n"; - -eval 'sub t1 ($) { use attrs "locked"; $_[0]++ }'; -(print "not "), $failed=1 if $@; -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -eval 'sub t2 { use attrs "locked"; $_[0]++ }'; -(print "not "), $failed=1 if $@; -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -eval 'sub t3 ($) : locked ;'; -(print "not "), $failed=1 if $@; -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -eval 'sub t4 : locked ;'; -(print "not "), $failed=1 if $@; -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -my $anon1; -eval '$anon1 = sub ($) { use attrs qw(locked method); $_[0]++ }'; -(print "not "), $failed=1 if $@; -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -my $anon2; -eval '$anon2 = sub { use attrs qw(locked method); $_[0]++ }'; -(print "not "), $failed=1 if $@; -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -my $anon3; -eval '$anon3 = sub { use attrs "method"; $_[0]->[1] }'; -(print "not "), $failed=1 if $@; -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -my @attrs = attrs::get($anon3 ? $anon3 : \&ns); -(print "not "), $failed=1 unless "@attrs" eq "method"; -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -@attrs = sort +attrs::get($anon2 ? $anon2 : \&ns); -(print "not "), $failed=1 unless "@attrs" eq "locked method"; -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -@attrs = sort +attrs::get($anon1 ? $anon1 : \&ns); -(print "not "), $failed=1 unless "@attrs" eq "locked method"; -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -eval 'sub e1 ($) : plugh ;'; -unless ($@ && $@ =~ m/^Invalid CODE attribute: ["']?plugh["']? at/) { - my $x = $@; - $x =~ s/\n.*\z//s; - print "# $x\n"; - print "not "; - $failed = 1; -} -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -eval 'sub e2 ($) : plugh(0,0) xyzzy ;'; -unless ($@ && $@ =~ m/^Invalid CODE attributes: ["']?plugh\(0,0\)["']? /) { - my $x = $@; - $x =~ s/\n.*\z//s; - print "# $x\n"; - print "not "; - $failed = 1; -} -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -eval 'sub e3 ($) : plugh(0,0 xyzzy ;'; -unless ($@ && $@ =~ m/Unterminated attribute parameter in attribute list at/) { - my $x = $@; - $x =~ s/\n.*\z//s; - print "# $x\n"; - print "not "; - $failed = 1; -} -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -eval 'sub e4 ($) : plugh + xyzzy ;'; -unless ($@ && $@ =~ m/Invalid separator character '[+]' in attribute list at/) { - my $x = $@; - $x =~ s/\n.*\z//s; - print "# $x\n"; - print "not "; - $failed = 1; -} -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -{ - my $w = "" ; - local $SIG{__WARN__} = sub {$w = @_[0]} ; - eval 'sub w1 ($) { use warnings "deprecated"; use attrs "locked"; $_[0]++ }'; - (print "not "), $failed=1 if $@; - print "ok ",++$test,"\n"; - BEGIN {++$ntests} - (print "not "), $failed=1 - if $w !~ /^pragma "attrs" is deprecated, use "sub NAME : ATTRS" instead at/; - print "ok ",++$test,"\n"; - BEGIN {++$ntests} -} - - -# Other tests should be added above this line - -sub NTESTS () { $ntests } - -exit $failed; diff --git a/contrib/perl5/t/lib/autoloader.t b/contrib/perl5/t/lib/autoloader.t deleted file mode 100755 index b53b9fe..0000000 --- a/contrib/perl5/t/lib/autoloader.t +++ /dev/null @@ -1,122 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - $dir = "auto-$$"; - @INC = $dir; - push @INC, '../lib'; -} - -print "1..11\n"; - -# First we must set up some autoloader files -mkdir $dir, 0755 or die "Can't mkdir $dir: $!"; -mkdir "$dir/auto", 0755 or die "Can't mkdir: $!"; -mkdir "$dir/auto/Foo", 0755 or die "Can't mkdir: $!"; - -open(FOO, ">$dir/auto/Foo/foo.al") or die; -print FOO <<'EOT'; -package Foo; -sub foo { shift; shift || "foo" } -1; -EOT -close(FOO); - -open(BAR, ">$dir/auto/Foo/bar.al") or die; -print BAR <<'EOT'; -package Foo; -sub bar { shift; shift || "bar" } -1; -EOT -close(BAR); - -open(BAZ, ">$dir/auto/Foo/bazmarkhian.al") or die; -print BAZ <<'EOT'; -package Foo; -sub bazmarkhianish { shift; shift || "baz" } -1; -EOT -close(BAZ); - -# Let's define the package -package Foo; -require AutoLoader; -@ISA=qw(AutoLoader); - -sub new { bless {}, shift }; - -package main; - -$foo = new Foo; - -print "not " unless $foo->foo eq 'foo'; # autoloaded first time -print "ok 1\n"; - -print "not " unless $foo->foo eq 'foo'; # regular call -print "ok 2\n"; - -# Try an undefined method -eval { - $foo->will_fail; -}; -print "not " unless $@ =~ /^Can't locate/; -print "ok 3\n"; - -# Used to be trouble with this -eval { - my $foo = new Foo; - die "oops"; -}; -print "not " unless $@ =~ /oops/; -print "ok 4\n"; - -# Pass regular expression variable to autoloaded function. This used -# to go wrong because AutoLoader used regular expressions to generate -# autoloaded filename. -"foo" =~ /(\w+)/; -print "not " unless $1 eq 'foo'; -print "ok 5\n"; - -print "not " unless $foo->bar($1) eq 'foo'; -print "ok 6\n"; - -print "not " unless $foo->bar($1) eq 'foo'; -print "ok 7\n"; - -print "not " unless $foo->bazmarkhianish($1) eq 'foo'; -print "ok 8\n"; - -print "not " unless $foo->bazmarkhianish($1) eq 'foo'; -print "ok 9\n"; - -# test recursive autoloads -open(F, ">$dir/auto/Foo/a.al") or die; -print F <<'EOT'; -package Foo; -BEGIN { b() } -sub a { print "ok 11\n"; } -1; -EOT -close(F); - -open(F, ">$dir/auto/Foo/b.al") or die; -print F <<'EOT'; -package Foo; -sub b { print "ok 10\n"; } -1; -EOT -close(F); -Foo::a(); - -# cleanup -END { -return unless $dir && -d $dir; -unlink "$dir/auto/Foo/foo.al"; -unlink "$dir/auto/Foo/bar.al"; -unlink "$dir/auto/Foo/bazmarkhian.al"; -unlink "$dir/auto/Foo/a.al"; -unlink "$dir/auto/Foo/b.al"; -rmdir "$dir/auto/Foo"; -rmdir "$dir/auto"; -rmdir "$dir"; -} diff --git a/contrib/perl5/t/lib/b.t b/contrib/perl5/t/lib/b.t deleted file mode 100755 index 22156c2..0000000 --- a/contrib/perl5/t/lib/b.t +++ /dev/null @@ -1,163 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - if ($^O eq 'MacOS') { - @INC = qw(: ::lib ::macos:lib); - } else { - @INC = '.'; - push @INC, '../lib'; - } -} - -$| = 1; -use warnings; -use strict; -use Config; - -print "1..15\n"; - -my $test = 1; - -sub ok { print "ok $test\n"; $test++ } - -use B::Deparse; -my $deparse = B::Deparse->new() or print "not "; -ok; - -print "not " if "{\n 1;\n}" ne $deparse->coderef2text(sub {1}); -ok; - -print "not " if "{\n '???';\n 2;\n}" ne - $deparse->coderef2text(sub {1;2}); -ok; - -print "not " if "{\n \$test /= 2 if ++\$test;\n}" ne - $deparse->coderef2text(sub {++$test and $test/=2;}); -ok; -{ -my $a = <<'EOF'; -{ - $test = sub : lvalue { - my $x; - } - ; -} -EOF -chomp $a; -print "not " if $deparse->coderef2text(sub{$test = sub : lvalue{my $x}}) ne $a; -ok; - -$a =~ s/lvalue/method/; -print "not " if $deparse->coderef2text(sub{$test = sub : method{my $x}}) ne $a; -ok; - -$a =~ s/method/locked method/; -print "not " if $deparse->coderef2text(sub{$test = sub : method locked {my $x}}) - ne $a; -ok; -} - -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"; - -$a = `$^X $path "-MO=Deparse" -anle 1 $redir`; -$a =~ s/-e syntax OK\n//g; -$a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037 -$a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc' -$b = <<'EOF'; - -LINE: while (defined($_ = <ARGV>)) { - chomp $_; - @F = split(/\s+/, $_, 0); - '???'; -} - -EOF -print "# [$a]\n\# vs\n# [$b]\nnot " if $a ne $b; -ok; - -#6 -$a = `$^X $path "-MO=Debug" -e 1 $redir`; -print "not " unless $a =~ -/\bLISTOP\b.*\bOP\b.*\bCOP\b.*\bOP\b/s; -ok; - -#7 -$a = `$^X $path "-MO=Terse" -e 1 $redir`; -print "not " unless $a =~ -/\bLISTOP\b.*leave.*\n OP\b.*enter.*\n COP\b.*nextstate.*\n OP\b.*null/s; -ok; - -$a = `$^X $path "-MO=Terse" -ane "s/foo/bar/" $redir`; -$a =~ s/\(0x[^)]+\)//g; -$a =~ s/\[[^\]]+\]//g; -$a =~ s/-e syntax OK//; -$a =~ s/[^a-z ]+//g; -$a =~ s/\s+/ /g; -$a =~ s/\b(s|foo|bar|ullsv)\b\s?//g; -$a =~ s/^\s+//; -$a =~ s/\s+$//; -my $is_thread = $Config{use5005threads} && $Config{use5005threads} eq 'define'; -if ($is_thread) { - $b=<<EOF; -leave enter nextstate label leaveloop enterloop null and defined null -threadsv readline gv lineseq nextstate aassign null pushmark split pushre -threadsv const null pushmark rvav gv nextstate subst const unstack nextstate -EOF -} else { - $b=<<EOF; -leave enter nextstate label leaveloop enterloop null and defined null -null gvsv readline gv lineseq nextstate aassign null pushmark split pushre -null gvsv const null pushmark rvav gv nextstate subst const unstack nextstate -EOF -} -$b=~s/\n/ /g;$b=~s/\s+/ /g; -$b =~ s/\s+$//; -print "# [$a]\n# vs\n# [$b]\nnot " if $a ne $b; -ok; - -chomp($a = `$^X $path "-MB::Stash" "-Mwarnings" -e1`); -$a = join ',', sort split /,/, $a; -$a =~ s/-uWin32,// if $^O eq 'MSWin32'; -$a =~ s/-u(Cwd|File|File::Copy|OS2),//g if $^O eq 'os2'; -$a =~ s/-uCwd,// if $^O eq 'cygwin'; -if ($Config{static_ext} eq ' ') { - $b = '-uCarp,-uCarp::Heavy,-uDB,-uExporter,-uExporter::Heavy,-uattributes,' - . '-umain,-uwarnings'; - if (ord('A') == 193) { # EBCDIC sort order is qw(a A) not qw(A a) - $b = join ',', sort split /,/, $b; - } - print "# [$a] vs [$b]\nnot " if $a ne $b; - ok; -} else { - print "ok $test # skipped: one or more static extensions\n"; $test++; -} - -if ($is_thread) { - print "# use5005threads: test $test skipped\n"; -} else { - $a = `$^X $path "-MO=Showlex" -e "my %one" $redir`; - if (ord('A') != 193) { # ASCIIish - print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%one.*sv_undef.*HV/s; - } - else { # EBCDICish C<1: PVNV (0x1a7ede34) "%\226\225\205"> - print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%\\[0-9].*sv_undef.*HV/s; - } -} -ok; - -# Bug 20001204.07 -{ -my $foo = $deparse->coderef2text(sub { { 234; }}); -# Constants don't get optimised here. -print "not " unless $foo =~ /{.*{.*234;.*}.*}/sm; -ok; -$foo = $deparse->coderef2text(sub { { 234; } continue { 123; } }); -print "not " unless $foo =~ /{.*{.*234;.*}.*continue.*{.*123.*}/sm; -ok; -} diff --git a/contrib/perl5/t/lib/basename.t b/contrib/perl5/t/lib/basename.t deleted file mode 100755 index 9bee1bf..0000000 --- a/contrib/perl5/t/lib/basename.t +++ /dev/null @@ -1,144 +0,0 @@ -#!./perl -T - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use File::Basename qw(fileparse basename dirname); - -print "1..41\n"; - -# import correctly? -print +(defined(&basename) && !defined(&fileparse_set_fstype) ? - '' : 'not '),"ok 1\n"; - -# set fstype -- should replace non-null default -print +(length(File::Basename::fileparse_set_fstype('unix')) ? - '' : 'not '),"ok 2\n"; - -# Unix syntax tests -($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7','\.book\d+'); -if ($base eq 'draft' and $path eq '/virgil/aeneid/' and $type eq '.book7') { - print "ok 3\n"; -} -else { - print "not ok 3 |$base|$path|$type|\n"; -} -print +(basename('/arma/virumque.cano') eq 'virumque.cano' ? - '' : 'not '),"ok 4\n"; -print +(dirname('/arma/virumque.cano') eq '/arma' ? '' : 'not '),"ok 5\n"; -print +(dirname('arma/') eq '.' ? '' : 'not '),"ok 6\n"; -print +(dirname('/') eq '/' ? '' : 'not '),"ok 7\n"; - - -# set fstype -- should replace non-null default -print +(File::Basename::fileparse_set_fstype('VMS') eq 'unix' ? - '' : 'not '),"ok 8\n"; - -# VMS syntax tests -($base,$path,$type) = fileparse('virgil:[aeneid]draft.book7','\.book\d+'); -if ($base eq 'draft' and $path eq 'virgil:[aeneid]' and $type eq '.book7') { - print "ok 9\n"; -} -else { - print "not ok 9 |$base|$path|$type|\n"; -} -print +(basename('arma:[virumque]cano.trojae') eq 'cano.trojae' ? - '' : 'not '),"ok 10\n"; -print +(dirname('arma:[virumque]cano.trojae') eq 'arma:[virumque]' ? - '' : 'not '),"ok 11\n"; -print +(dirname('arma:<virumque>cano.trojae') eq 'arma:<virumque>' ? - '' : 'not '),"ok 12\n"; -print +(dirname('arma:virumque.cano') eq 'arma:' ? '' : 'not '),"ok 13\n"; -$ENV{DEFAULT} = '' unless exists $ENV{DEFAULT}; -print +(dirname('virumque.cano') eq $ENV{DEFAULT} ? '' : 'not '),"ok 14\n"; -print +(dirname('arma/') eq '.' ? '' : 'not '),"ok 15\n"; - -# set fstype -- should replace non-null default -print +(File::Basename::fileparse_set_fstype('MSDOS') eq 'VMS' ? - '' : 'not '),"ok 16\n"; - -# MSDOS syntax tests -($base,$path,$type) = fileparse('C:\\virgil\\aeneid\\draft.book7','\.book\d+'); -if ($base eq 'draft' and $path eq 'C:\\virgil\\aeneid\\' and $type eq '.book7') { - print "ok 17\n"; -} -else { - print "not ok 17 |$base|$path|$type|\n"; -} -print +(basename('A:virumque\\cano.trojae') eq 'cano.trojae' ? - '' : 'not '),"ok 18\n"; -print +(dirname('A:\\virumque\\cano.trojae') eq 'A:\\virumque' ? - '' : 'not '),"ok 19\n"; -print +(dirname('A:\\') eq 'A:\\' ? '' : 'not '),"ok 20\n"; -print +(dirname('arma\\') eq '.' ? '' : 'not '),"ok 21\n"; - -# Yes "/" is a legal path separator under MSDOS -basename("lib/File/Basename.pm") eq "Basename.pm" or print "not "; -print "ok 22\n"; - - - -# set fstype -- should replace non-null default -print +(File::Basename::fileparse_set_fstype('MacOS') eq 'MSDOS' ? - '' : 'not '),"ok 23\n"; - -# MacOS syntax tests -($base,$path,$type) = fileparse('virgil:aeneid:draft.book7','\.book\d+'); -if ($base eq 'draft' and $path eq 'virgil:aeneid:' and $type eq '.book7') { - print "ok 24\n"; -} -else { - print "not ok 24 |$base|$path|$type|\n"; -} -print +(basename(':arma:virumque:cano.trojae') eq 'cano.trojae' ? - '' : 'not '),"ok 25\n"; -print +(dirname(':arma:virumque:cano.trojae') eq ':arma:virumque:' ? - '' : 'not '),"ok 26\n"; -print +(dirname(':arma:virumque:') eq ':arma:' ? '' : 'not '),"ok 27\n"; -print +(dirname(':arma:virumque') eq ':arma:' ? '' : 'not '),"ok 28\n"; -print +(dirname(':arma:') eq ':' ? '' : 'not '),"ok 29\n"; -print +(dirname(':arma') eq ':' ? '' : 'not '),"ok 30\n"; -print +(dirname('arma:') eq 'arma:' ? '' : 'not '),"ok 31\n"; -print +(dirname('arma') eq ':' ? '' : 'not '),"ok 32\n"; -print +(dirname(':') eq ':' ? '' : 'not '),"ok 33\n"; - - -# Check quoting of metacharacters in suffix arg by basename() -print +(basename(':arma:virumque:cano.trojae','.trojae') eq 'cano' ? - '' : 'not '),"ok 34\n"; -print +(basename(':arma:virumque:cano_trojae','.trojae') eq 'cano_trojae' ? - '' : 'not '),"ok 35\n"; - -# extra tests for a few specific bugs - -File::Basename::fileparse_set_fstype 'MSDOS'; -# perl5.003_18 gives C:/perl/.\ -print +((fileparse 'C:/perl/lib')[1] eq 'C:/perl/' ? '' : 'not '), "ok 36\n"; -# perl5.003_18 gives C:\perl\ -print +(dirname('C:\\perl\\lib\\') eq 'C:\\perl' ? '' : 'not '), "ok 37\n"; - -File::Basename::fileparse_set_fstype 'UNIX'; -# perl5.003_18 gives '.' -print +(dirname('/perl/') eq '/' ? '' : 'not '), "ok 38\n"; -# perl5.003_18 gives '/perl/lib' -print +(dirname('/perl/lib//') eq '/perl' ? '' : 'not '), "ok 39\n"; - -# The empty tainted value, for tainting strings -my $TAINT = substr($^X, 0, 0); -# How to identify taint when you see it -sub any_tainted (@) { - not eval { join("",@_), kill 0; 1 }; -} -sub tainted ($) { - any_tainted @_; -} -sub all_tainted (@) { - for (@_) { return 0 unless tainted $_ } - 1; -} - -print +(tainted(dirname($TAINT.'/perl/lib//')) ? '' : 'not '), "ok 40\n"; -print +(all_tainted(fileparse($TAINT.'/dir/draft.book7','\.book\d+')) - ? '' : 'not '), "ok 41\n"; diff --git a/contrib/perl5/t/lib/bigfloat.t b/contrib/perl5/t/lib/bigfloat.t deleted file mode 100755 index 8e0a0ef..0000000 --- a/contrib/perl5/t/lib/bigfloat.t +++ /dev/null @@ -1,408 +0,0 @@ -#!./perl - -BEGIN { @INC = '../lib' } -require "bigfloat.pl"; - -$test = 0; -$| = 1; -print "1..355\n"; -while (<DATA>) { - chop; - if (/^&/) { - $f = $_; - } elsif (/^\$.*/) { - eval "$_;"; - } else { - ++$test; - @args = split(/:/,$_,99); - $ans = pop(@args); - $try = "$f('" . join("','", @args) . "');"; - if (($ans1 = eval($try)) eq $ans) { - print "ok $test\n"; - } else { - print "not ok $test\n"; - print "# '$try' expected: '$ans' got: '$ans1'\n"; - } - } -} -__END__ -&fnorm -abc:NaN - 1 a:NaN -1bcd2:NaN -11111b:NaN -+1z:NaN --1z:NaN -0:+0E+0 -+0:+0E+0 -+00:+0E+0 -+0 0 0:+0E+0 -000000 0000000 00000:+0E+0 --0:+0E+0 --0000:+0E+0 -+1:+1E+0 -+01:+1E+0 -+001:+1E+0 -+00000100000:+1E+5 -123456789:+123456789E+0 --1:-1E+0 --01:-1E+0 --001:-1E+0 --123456789:-123456789E+0 --00000100000:-1E+5 -123.456a:NaN -123.456:+123456E-3 -0.01:+1E-2 -.002:+2E-3 --0.0003:-3E-4 --.0000000004:-4E-10 -123456E2:+123456E+2 -123456E-2:+123456E-2 --123456E2:-123456E+2 --123456E-2:-123456E-2 -1e1:+1E+1 -2e-11:+2E-11 --3e111:-3E+111 --4e-1111:-4E-1111 -&fneg -abd:NaN -+0:+0E+0 -+1:-1E+0 --1:+1E+0 -+123456789:-123456789E+0 --123456789:+123456789E+0 -+123.456789:-123456789E-6 --123456.789:+123456789E-3 -&fabs -abc:NaN -+0:+0E+0 -+1:+1E+0 --1:+1E+0 -+123456789:+123456789E+0 --123456789:+123456789E+0 -+123.456789:+123456789E-6 --123456.789:+123456789E-3 -&fround -$bigfloat::rnd_mode = 'trunc' -+10123456789:5:+10123E+6 --10123456789:5:-10123E+6 -+10123456789:9:+101234567E+2 --10123456789:9:-101234567E+2 -+101234500:6:+101234E+3 --101234500:6:-101234E+3 -$bigfloat::rnd_mode = 'zero' -+20123456789:5:+20123E+6 --20123456789:5:-20123E+6 -+20123456789:9:+201234568E+2 --20123456789:9:-201234568E+2 -+201234500:6:+201234E+3 --201234500:6:-201234E+3 -$bigfloat::rnd_mode = '+inf' -+30123456789:5:+30123E+6 --30123456789:5:-30123E+6 -+30123456789:9:+301234568E+2 --30123456789:9:-301234568E+2 -+301234500:6:+301235E+3 --301234500:6:-301234E+3 -$bigfloat::rnd_mode = '-inf' -+40123456789:5:+40123E+6 --40123456789:5:-40123E+6 -+40123456789:9:+401234568E+2 --40123456789:9:-401234568E+2 -+401234500:6:+401234E+3 --401234500:6:-401235E+3 -$bigfloat::rnd_mode = 'odd' -+50123456789:5:+50123E+6 --50123456789:5:-50123E+6 -+50123456789:9:+501234568E+2 --50123456789:9:-501234568E+2 -+501234500:6:+501235E+3 --501234500:6:-501235E+3 -$bigfloat::rnd_mode = 'even' -+60123456789:5:+60123E+6 --60123456789:5:-60123E+6 -+60123456789:9:+601234568E+2 --60123456789:9:-601234568E+2 -+601234500:6:+601234E+3 --601234500:6:-601234E+3 -&ffround -$bigfloat::rnd_mode = 'trunc' -+1.23:-1:+12E-1 --1.23:-1:-12E-1 -+1.27:-1:+12E-1 --1.27:-1:-12E-1 -+1.25:-1:+12E-1 --1.25:-1:-12E-1 -+1.35:-1:+13E-1 --1.35:-1:-13E-1 --0.006:-1:+0E+0 --0.006:-2:+0E+0 -$bigfloat::rnd_mode = 'zero' -+2.23:-1:+22E-1 --2.23:-1:-22E-1 -+2.27:-1:+23E-1 --2.27:-1:-23E-1 -+2.25:-1:+22E-1 --2.25:-1:-22E-1 -+2.35:-1:+23E-1 --2.35:-1:-23E-1 --0.0065:-1:+0E+0 --0.0065:-2:-1E-2 --0.0065:-3:-6E-3 --0.0065:-4:-65E-4 --0.0065:-5:-65E-4 -$bigfloat::rnd_mode = '+inf' -+3.23:-1:+32E-1 --3.23:-1:-32E-1 -+3.27:-1:+33E-1 --3.27:-1:-33E-1 -+3.25:-1:+33E-1 --3.25:-1:-32E-1 -+3.35:-1:+34E-1 --3.35:-1:-33E-1 --0.0065:-1:+0E+0 --0.0065:-2:-1E-2 --0.0065:-3:-6E-3 --0.0065:-4:-65E-4 --0.0065:-5:-65E-4 -$bigfloat::rnd_mode = '-inf' -+4.23:-1:+42E-1 --4.23:-1:-42E-1 -+4.27:-1:+43E-1 --4.27:-1:-43E-1 -+4.25:-1:+42E-1 --4.25:-1:-43E-1 -+4.35:-1:+43E-1 --4.35:-1:-44E-1 --0.0065:-1:+0E+0 --0.0065:-2:-1E-2 --0.0065:-3:-7E-3 --0.0065:-4:-65E-4 --0.0065:-5:-65E-4 -$bigfloat::rnd_mode = 'odd' -+5.23:-1:+52E-1 --5.23:-1:-52E-1 -+5.27:-1:+53E-1 --5.27:-1:-53E-1 -+5.25:-1:+53E-1 --5.25:-1:-53E-1 -+5.35:-1:+53E-1 --5.35:-1:-53E-1 --0.0065:-1:+0E+0 --0.0065:-2:-1E-2 --0.0065:-3:-7E-3 --0.0065:-4:-65E-4 --0.0065:-5:-65E-4 -$bigfloat::rnd_mode = 'even' -+6.23:-1:+62E-1 --6.23:-1:-62E-1 -+6.27:-1:+63E-1 --6.27:-1:-63E-1 -+6.25:-1:+62E-1 --6.25:-1:-62E-1 -+6.35:-1:+64E-1 --6.35:-1:-64E-1 --0.0065:-1:+0E+0 --0.0065:-2:-1E-2 --0.0065:-3:-6E-3 --0.0065:-4:-65E-4 --0.0065:-5:-65E-4 -&fcmp -abc:abc: -abc:+0: -+0:abc: -+0:+0:0 --1:+0:-1 -+0:-1:1 -+1:+0:1 -+0:+1:-1 --1:+1:-1 -+1:-1:1 --1:-1:0 -+1:+1:0 -+123:+123:0 -+123:+12:1 -+12:+123:-1 --123:-123:0 --123:-12:-1 --12:-123:1 -+123:+124:-1 -+124:+123:1 --123:-124:1 --124:-123:-1 -&fadd -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:+0E+0 -+1:+0:+1E+0 -+0:+1:+1E+0 -+1:+1:+2E+0 --1:+0:-1E+0 -+0:-1:-1E+0 --1:-1:-2E+0 --1:+1:+0E+0 -+1:-1:+0E+0 -+9:+1:+1E+1 -+99:+1:+1E+2 -+999:+1:+1E+3 -+9999:+1:+1E+4 -+99999:+1:+1E+5 -+999999:+1:+1E+6 -+9999999:+1:+1E+7 -+99999999:+1:+1E+8 -+999999999:+1:+1E+9 -+9999999999:+1:+1E+10 -+99999999999:+1:+1E+11 -+10:-1:+9E+0 -+100:-1:+99E+0 -+1000:-1:+999E+0 -+10000:-1:+9999E+0 -+100000:-1:+99999E+0 -+1000000:-1:+999999E+0 -+10000000:-1:+9999999E+0 -+100000000:-1:+99999999E+0 -+1000000000:-1:+999999999E+0 -+10000000000:-1:+9999999999E+0 -+123456789:+987654321:+111111111E+1 --123456789:+987654321:+864197532E+0 --123456789:-987654321:-111111111E+1 -+123456789:-987654321:-864197532E+0 -&fsub -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:+0E+0 -+1:+0:+1E+0 -+0:+1:-1E+0 -+1:+1:+0E+0 --1:+0:-1E+0 -+0:-1:+1E+0 --1:-1:+0E+0 --1:+1:-2E+0 -+1:-1:+2E+0 -+9:+1:+8E+0 -+99:+1:+98E+0 -+999:+1:+998E+0 -+9999:+1:+9998E+0 -+99999:+1:+99998E+0 -+999999:+1:+999998E+0 -+9999999:+1:+9999998E+0 -+99999999:+1:+99999998E+0 -+999999999:+1:+999999998E+0 -+9999999999:+1:+9999999998E+0 -+99999999999:+1:+99999999998E+0 -+10:-1:+11E+0 -+100:-1:+101E+0 -+1000:-1:+1001E+0 -+10000:-1:+10001E+0 -+100000:-1:+100001E+0 -+1000000:-1:+1000001E+0 -+10000000:-1:+10000001E+0 -+100000000:-1:+100000001E+0 -+1000000000:-1:+1000000001E+0 -+10000000000:-1:+10000000001E+0 -+123456789:+987654321:-864197532E+0 --123456789:+987654321:-111111111E+1 --123456789:-987654321:+864197532E+0 -+123456789:-987654321:+111111111E+1 -&fmul -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:+0E+0 -+0:+1:+0E+0 -+1:+0:+0E+0 -+0:-1:+0E+0 --1:+0:+0E+0 -+123456789123456789:+0:+0E+0 -+0:+123456789123456789:+0E+0 --1:-1:+1E+0 --1:+1:-1E+0 -+1:-1:-1E+0 -+1:+1:+1E+0 -+2:+3:+6E+0 --2:+3:-6E+0 -+2:-3:-6E+0 --2:-3:+6E+0 -+111:+111:+12321E+0 -+10101:+10101:+102030201E+0 -+1001001:+1001001:+1002003002001E+0 -+100010001:+100010001:+10002000300020001E+0 -+10000100001:+10000100001:+100002000030000200001E+0 -+11111111111:+9:+99999999999E+0 -+22222222222:+9:+199999999998E+0 -+33333333333:+9:+299999999997E+0 -+44444444444:+9:+399999999996E+0 -+55555555555:+9:+499999999995E+0 -+66666666666:+9:+599999999994E+0 -+77777777777:+9:+699999999993E+0 -+88888888888:+9:+799999999992E+0 -+99999999999:+9:+899999999991E+0 -&fdiv -abc:abc:NaN -abc:+1:abc:NaN -+1:abc:NaN -+0:+0:NaN -+0:+1:+0E+0 -+1:+0:NaN -+0:-1:+0E+0 --1:+0:NaN -+1:+1:+1E+0 --1:-1:+1E+0 -+1:-1:-1E+0 --1:+1:-1E+0 -+1:+2:+5E-1 -+2:+1:+2E+0 -+10:+5:+2E+0 -+100:+4:+25E+0 -+1000:+8:+125E+0 -+10000:+16:+625E+0 -+10000:-16:-625E+0 -+999999999999:+9:+111111111111E+0 -+999999999999:+99:+10101010101E+0 -+999999999999:+999:+1001001001E+0 -+999999999999:+9999:+100010001E+0 -+999999999999999:+99999:+10000100001E+0 -+1000000000:+9:+1111111111111111111111111111111111111111E-31 -+2000000000:+9:+2222222222222222222222222222222222222222E-31 -+3000000000:+9:+3333333333333333333333333333333333333333E-31 -+4000000000:+9:+4444444444444444444444444444444444444444E-31 -+5000000000:+9:+5555555555555555555555555555555555555556E-31 -+6000000000:+9:+6666666666666666666666666666666666666667E-31 -+7000000000:+9:+7777777777777777777777777777777777777778E-31 -+8000000000:+9:+8888888888888888888888888888888888888889E-31 -+9000000000:+9:+1E+9 -+35500000:+113:+3141592920353982300884955752212389380531E-34 -+71000000:+226:+3141592920353982300884955752212389380531E-34 -+106500000:+339:+3141592920353982300884955752212389380531E-34 -+1000000000:+3:+3333333333333333333333333333333333333333E-31 -$bigfloat::div_scale = 20 -+1000000000:+9:+11111111111111111111E-11 -+2000000000:+9:+22222222222222222222E-11 -+3000000000:+9:+33333333333333333333E-11 -+4000000000:+9:+44444444444444444444E-11 -+5000000000:+9:+55555555555555555556E-11 -+6000000000:+9:+66666666666666666667E-11 -+7000000000:+9:+77777777777777777778E-11 -+8000000000:+9:+88888888888888888889E-11 -+9000000000:+9:+1E+9 -+35500000:+113:+314159292035398230088E-15 -+71000000:+226:+314159292035398230088E-15 -+106500000:+339:+31415929203539823009E-14 -+1000000000:+3:+33333333333333333333E-11 -$bigfloat::div_scale = 40 -&fsqrt -+0:+0E+0 --1:NaN --2:NaN --16:NaN --123.456:NaN -+1:+1E+0 -+1.44:+12E-1 -+2:+141421356237309504880168872420969807857E-38 -+4:+2E+0 -+16:+4E+0 -+100:+1E+1 -+123.456:+1111107555549866648462149404118219234119E-38 -+15241.383936:+123456E-3 diff --git a/contrib/perl5/t/lib/bigfltpm.t b/contrib/perl5/t/lib/bigfltpm.t deleted file mode 100755 index aa45651..0000000 --- a/contrib/perl5/t/lib/bigfltpm.t +++ /dev/null @@ -1,478 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Math::BigFloat; - -$test = 0; -$| = 1; -print "1..370\n"; -while (<DATA>) { - chop; - if (s/^&//) { - $f = $_; - } elsif (/^\$.*/) { - eval "$_;"; - } else { - ++$test; - if (m|^(.*?):(/.+)$|) { - $ans = $2; - @args = split(/:/,$1,99); - } - else { - @args = split(/:/,$_,99); - $ans = pop(@args); - } - $try = "\$x = new Math::BigFloat \"$args[0]\";"; - if ($f eq "fnorm"){ - $try .= "\$x+0;"; - } elsif ($f eq "fneg") { - $try .= "-\$x;"; - } elsif ($f eq "fabs") { - $try .= "abs \$x;"; - } elsif ($f eq "fround") { - $try .= "0+\$x->fround($args[1]);"; - } elsif ($f eq "ffround") { - $try .= "0+\$x->ffround($args[1]);"; - } elsif ($f eq "fsqrt") { - $try .= "0+\$x->fsqrt;"; - } else { - $try .= "\$y = new Math::BigFloat \"$args[1]\";"; - if ($f eq "fcmp") { - $try .= "\$x <=> \$y;"; - } elsif ($f eq "fadd") { - $try .= "\$x + \$y;"; - } elsif ($f eq "fsub") { - $try .= "\$x - \$y;"; - } elsif ($f eq "fmul") { - $try .= "\$x * \$y;"; - } elsif ($f eq "fdiv") { - $try .= "\$x / \$y;"; - } elsif ($f eq "fmod") { - $try .= "\$x % \$y;"; - } else { warn "Unknown op"; } - } - #print ">>>",$try,"<<<\n"; - $ans1 = eval $try; - if ($ans =~ m|^/(.*)$|) { - my $pat = $1; - if ($ans1 =~ /$pat/) { - print "ok $test\n"; - } - else { - print "not ok $test\n"; - print "# '$try' expected: /$pat/ got: '$ans1'\n"; - } - } - else { - - $ans1_str = defined $ans1? "$ans1" : ""; - if ($ans1_str eq $ans) { #bug! - print "ok $test\n"; - } else { - print "not ok $test\n"; - print "# '$try' expected: '$ans' got: '$ans1'\n"; - } - } - } -} -__END__ -&fnorm -abc:NaN - 1 a:NaN -1bcd2:NaN -11111b:NaN -+1z:NaN --1z:NaN -0:0. -+0:0. -+00:0. -+0 0 0:0. -000000 0000000 00000:0. --0:0. --0000:0. -+1:1. -+01:1. -+001:1. -+00000100000:100000. -123456789:123456789. --1:-1. --01:-1. --001:-1. --123456789:-123456789. --00000100000:-100000. -123.456a:NaN -123.456:123.456 -0.01:.01 -.002:.002 --0.0003:-.0003 --.0000000004:-.0000000004 -123456E2:12345600. -123456E-2:1234.56 --123456E2:-12345600. --123456E-2:-1234.56 -1e1:10. -2e-11:.00000000002 --3e111:-3000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000. --4e-1111:-.0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000004 -&fneg -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 -$Math::BigFloat::rnd_mode = 'trunc' -+10123456789:5:10123000000 --10123456789:5:-10123000000 -+10123456789:9:10123456700 --10123456789:9:-10123456700 -+101234500:6:101234000 --101234500:6:-101234000 -$Math::BigFloat::rnd_mode = 'zero' -+20123456789:5:20123000000 --20123456789:5:-20123000000 -+20123456789:9:20123456800 --20123456789:9:-20123456800 -+201234500:6:201234000 --201234500:6:-201234000 -$Math::BigFloat::rnd_mode = '+inf' -+30123456789:5:30123000000 --30123456789:5:-30123000000 -+30123456789:9:30123456800 --30123456789:9:-30123456800 -+301234500:6:301235000 --301234500:6:-301234000 -$Math::BigFloat::rnd_mode = '-inf' -+40123456789:5:40123000000 --40123456789:5:-40123000000 -+40123456789:9:40123456800 --40123456789:9:-40123456800 -+401234500:6:401234000 --401234500:6:-401235000 -$Math::BigFloat::rnd_mode = 'odd' -+50123456789:5:50123000000 --50123456789:5:-50123000000 -+50123456789:9:50123456800 --50123456789:9:-50123456800 -+501234500:6:501235000 --501234500:6:-501235000 -$Math::BigFloat::rnd_mode = 'even' -+60123456789:5:60123000000 --60123456789:5:-60123000000 -+60123456789:9:60123456800 --60123456789:9:-60123456800 -+601234500:6:601234000 --601234500:6:-601234000 -&ffround -$Math::BigFloat::rnd_mode = 'trunc' -+1.23:-1:1.2 --1.23:-1:-1.2 -+1.27:-1:1.2 --1.27:-1:-1.2 -+1.25:-1:1.2 --1.25:-1:-1.2 -+1.35:-1:1.3 --1.35:-1:-1.3 --0.006:-1:0 --0.006:-2:0 --0.0065:-3:/-0\.006|-6e-03 --0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 --0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 -$Math::BigFloat::rnd_mode = 'zero' -+2.23:-1:/2.2(?:0{5}\d+)? --2.23:-1:/-2.2(?:0{5}\d+)? -+2.27:-1:/2.(?:3|29{5}\d+) --2.27:-1:/-2.(?:3|29{5}\d+) -+2.25:-1:/2.2(?:0{5}\d+)? --2.25:-1:/-2.2(?:0{5}\d+)? -+2.35:-1:/2.(?:3|29{5}\d+) --2.35:-1:/-2.(?:3|29{5}\d+) --0.0065:-1:0 --0.0065:-2:/-0\.01|-1e-02 --0.0065:-3:/-0\.006|-6e-03 --0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 --0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 -$Math::BigFloat::rnd_mode = '+inf' -+3.23:-1:/3.2(?:0{5}\d+)? --3.23:-1:/-3.2(?:0{5}\d+)? -+3.27:-1:/3.(?:3|29{5}\d+) --3.27:-1:/-3.(?:3|29{5}\d+) -+3.25:-1:/3.(?:3|29{5}\d+) --3.25:-1:/-3.2(?:0{5}\d+)? -+3.35:-1:/3.(?:4|39{5}\d+) --3.35:-1:/-3.(?:3|29{5}\d+) --0.0065:-1:0 --0.0065:-2:/-0\.01|-1e-02 --0.0065:-3:/-0\.006|-6e-03 --0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 --0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 -$Math::BigFloat::rnd_mode = '-inf' -+4.23:-1:/4.2(?:0{5}\d+)? --4.23:-1:/-4.2(?:0{5}\d+)? -+4.27:-1:/4.(?:3|29{5}\d+) --4.27:-1:/-4.(?:3|29{5}\d+) -+4.25:-1:/4.2(?:0{5}\d+)? --4.25:-1:/-4.(?:3|29{5}\d+) -+4.35:-1:/4.(?:3|29{5}\d+) --4.35:-1:/-4.(?:4|39{5}\d+) --0.0065:-1:0 --0.0065:-2:/-0\.01|-1e-02 --0.0065:-3:/-0\.007|-7e-03 --0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 --0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 -$Math::BigFloat::rnd_mode = 'odd' -+5.23:-1:/5.2(?:0{5}\d+)? --5.23:-1:/-5.2(?:0{5}\d+)? -+5.27:-1:/5.(?:3|29{5}\d+) --5.27:-1:/-5.(?:3|29{5}\d+) -+5.25:-1:/5.(?:3|29{5}\d+) --5.25:-1:/-5.(?:3|29{5}\d+) -+5.35:-1:/5.(?:3|29{5}\d+) --5.35:-1:/-5.(?:3|29{5}\d+) --0.0065:-1:0 --0.0065:-2:/-0\.01|-1e-02 --0.0065:-3:/-0\.007|-7e-03 --0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 --0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 -$Math::BigFloat::rnd_mode = 'even' -+6.23:-1:/6.2(?:0{5}\d+)? --6.23:-1:/-6.2(?:0{5}\d+)? -+6.27:-1:/6.(?:3|29{5}\d+) --6.27:-1:/-6.(?:3|29{5}\d+) -+6.25:-1:/6.(?:2(?:0{5}\d+)?|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 -&fcmp -abc:abc: -abc:+0: -+0:abc: -+0:+0:0 --1:+0:-1 -+0:-1:1 -+1:+0:1 -+0:+1:-1 --1:+1:-1 -+1:-1:1 --1:-1:0 -+1:+1:0 --1.1:0:-1 -+0:-1.1:1 -+1.1:+0:1 -+0:+1.1:-1 -+123:+123:0 -+123:+12:1 -+12:+123:-1 --123:-123:0 --123:-12:-1 --12:-123:1 -+123:+124:-1 -+124:+123:1 --123:-124:1 --124:-123:-1 -&fadd -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:0. -+1:+0:1. -+0:+1:1. -+1:+1:2. --1:+0:-1. -+0:-1:-1. --1:-1:-2. --1:+1:0. -+1:-1:0. -+9:+1:10. -+99:+1:100. -+999:+1:1000. -+9999:+1:10000. -+99999:+1:100000. -+999999:+1:1000000. -+9999999:+1:10000000. -+99999999:+1:100000000. -+999999999:+1:1000000000. -+9999999999:+1:10000000000. -+99999999999:+1:100000000000. -+10:-1:9. -+100:-1:99. -+1000:-1:999. -+10000:-1:9999. -+100000:-1:99999. -+1000000:-1:999999. -+10000000:-1:9999999. -+100000000:-1:99999999. -+1000000000:-1:999999999. -+10000000000:-1:9999999999. -+123456789:+987654321:1111111110. --123456789:+987654321:864197532. --123456789:-987654321:-1111111110. -+123456789:-987654321:-864197532. -&fsub -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:0. -+1:+0:1. -+0:+1:-1. -+1:+1:0. --1:+0:-1. -+0:-1:1. --1:-1:0. --1:+1:-2. -+1:-1:2. -+9:+1:8. -+99:+1:98. -+999:+1:998. -+9999:+1:9998. -+99999:+1:99998. -+999999:+1:999998. -+9999999:+1:9999998. -+99999999:+1:99999998. -+999999999:+1:999999998. -+9999999999:+1:9999999998. -+99999999999:+1:99999999998. -+10:-1:11. -+100:-1:101. -+1000:-1:1001. -+10000:-1:10001. -+100000:-1:100001. -+1000000:-1:1000001. -+10000000:-1:10000001. -+100000000:-1:100000001. -+1000000000:-1:1000000001. -+10000000000:-1:10000000001. -+123456789:+987654321:-864197532. --123456789:+987654321:-1111111110. --123456789:-987654321:864197532. -+123456789:-987654321:1111111110. -&fmul -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:0. -+0:+1:0. -+1:+0:0. -+0:-1:0. --1:+0:0. -+123456789123456789:+0:0. -+0:+123456789123456789:0. --1:-1:1. --1:+1:-1. -+1:-1:-1. -+1:+1:1. -+2:+3:6. --2:+3:-6. -+2:-3:-6. --2:-3:6. -+111:+111:12321. -+10101:+10101:102030201. -+1001001:+1001001:1002003002001. -+100010001:+100010001:10002000300020001. -+10000100001:+10000100001:100002000030000200001. -+11111111111:+9:99999999999. -+22222222222:+9:199999999998. -+33333333333:+9:299999999997. -+44444444444:+9:399999999996. -+55555555555:+9:499999999995. -+66666666666:+9:599999999994. -+77777777777:+9:699999999993. -+88888888888:+9:799999999992. -+99999999999:+9:899999999991. -&fdiv -abc:abc:NaN -abc:+1:abc:NaN -+1:abc:NaN -+0:+0:NaN -+0:+1:0. -+1:+0:NaN -+0:-1:0. --1:+0:NaN -+1:+1:1. --1:-1:1. -+1:-1:-1. --1:+1:-1. -+1:+2:.5 -+2:+1:2. -+10:+5:2. -+100:+4:25. -+1000:+8:125. -+10000:+16:625. -+10000:-16:-625. -+999999999999:+9:111111111111. -+999999999999:+99:10101010101. -+999999999999:+999:1001001001. -+999999999999:+9999:100010001. -+999999999999999:+99999:10000100001. -+1000000000:+9:111111111.1111111111111111111111111111111 -+2000000000:+9:222222222.2222222222222222222222222222222 -+3000000000:+9:333333333.3333333333333333333333333333333 -+4000000000:+9:444444444.4444444444444444444444444444444 -+5000000000:+9:555555555.5555555555555555555555555555556 -+6000000000:+9:666666666.6666666666666666666666666666667 -+7000000000:+9:777777777.7777777777777777777777777777778 -+8000000000:+9:888888888.8888888888888888888888888888889 -+9000000000:+9:1000000000. -+35500000:+113:314159.2920353982300884955752212389380531 -+71000000:+226:314159.2920353982300884955752212389380531 -+106500000:+339:314159.2920353982300884955752212389380531 -+1000000000:+3:333333333.3333333333333333333333333333333 -$Math::BigFloat::div_scale = 20 -+1000000000:+9:111111111.11111111111 -+2000000000:+9:222222222.22222222222 -+3000000000:+9:333333333.33333333333 -+4000000000:+9:444444444.44444444444 -+5000000000:+9:555555555.55555555556 -+6000000000:+9:666666666.66666666667 -+7000000000:+9:777777777.77777777778 -+8000000000:+9:888888888.88888888889 -+9000000000:+9:1000000000. -+35500000:+113:314159.292035398230088 -+71000000:+226:314159.292035398230088 -+106500000:+339:314159.29203539823009 -+1000000000:+3:333333333.33333333333 -$Math::BigFloat::div_scale = 40 -&fsqrt -+0:0 --1:/^(?i:0|\?|NaNQ?)$ --2:/^(?i:0|\?|NaNQ?)$ --16:/^(?i:0|\?|NaNQ?)$ --123.456:/^(?i:0|\?|NaNQ?)$ -+1:1. -+1.44:1.2 -+2:1.41421356237309504880168872420969807857 -+4:2. -+16:4. -+100:10. -+123.456:11.11107555549866648462149404118219234119 -+15241.383936:123.456 -&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. diff --git a/contrib/perl5/t/lib/bigint.t b/contrib/perl5/t/lib/bigint.t deleted file mode 100755 index 034c5c6..0000000 --- a/contrib/perl5/t/lib/bigint.t +++ /dev/null @@ -1,282 +0,0 @@ -#!./perl - -BEGIN { @INC = '../lib' } -require "bigint.pl"; - -$test = 0; -$| = 1; -print "1..246\n"; -while (<DATA>) { - chop; - if (/^&/) { - $f = $_; - } else { - ++$test; - @args = split(/:/,$_,99); - $ans = pop(@args); - $try = "$f('" . join("','", @args) . "');"; - if (($ans1 = eval($try)) eq $ans) { - print "ok $test\n"; - } else { - print "not ok $test\n"; - print "# '$try' expected: '$ans' got: '$ans1'\n"; - } - } -} -__END__ -&bnorm -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 -&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 -&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 -&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 -+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 -&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 -&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 -+100:+625:+25 -+4096:+81:+1 diff --git a/contrib/perl5/t/lib/bigintpm.t b/contrib/perl5/t/lib/bigintpm.t deleted file mode 100755 index e76f246..0000000 --- a/contrib/perl5/t/lib/bigintpm.t +++ /dev/null @@ -1,377 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Math::BigInt; - -$test = 0; -$| = 1; -print "1..278\n"; -while (<DATA>) { - chop; - if (s/^&//) { - $f = $_; - } else { - ++$test; - @args = split(/:/,$_,99); - $ans = pop(@args); - $try = "\$x = new Math::BigInt \"$args[0]\";"; - if ($f eq "bnorm"){ - $try .= "\$x+0;"; - } elsif ($f eq "bneg") { - $try .= "-\$x;"; - } elsif ($f eq "babs") { - $try .= "abs \$x;"; - } else { - $try .= "\$y = new Math::BigInt \"$args[1]\";"; - if ($f eq "bcmp"){ - $try .= "\$x <=> \$y;"; - }elsif ($f eq "badd"){ - $try .= "\$x + \$y;"; - }elsif ($f eq "bsub"){ - $try .= "\$x - \$y;"; - }elsif ($f eq "bmul"){ - $try .= "\$x * \$y;"; - }elsif ($f eq "bdiv"){ - $try .= "\$x / \$y;"; - }elsif ($f eq "bmod"){ - $try .= "\$x % \$y;"; - }elsif ($f eq "bgcd"){ - $try .= "Math::BigInt::bgcd(\$x, \$y);"; - }elsif ($f eq "blsft"){ - $try .= "\$x << \$y;"; - }elsif ($f eq "brsft"){ - $try .= "\$x >> \$y;"; - }elsif ($f eq "band"){ - $try .= "\$x & \$y;"; - }elsif ($f eq "bior"){ - $try .= "\$x | \$y;"; - }elsif ($f eq "bxor"){ - $try .= "\$x ^ \$y;"; - }elsif ($f eq "bnot"){ - $try .= "~\$x;"; - } else { warn "Unknown op"; } - } - #print ">>>",$try,"<<<\n"; - $ans1 = eval $try; - if ("$ans1" eq $ans) { #bug! - print "ok $test\n"; - } else { - print "not ok $test\n"; - print "# '$try' expected: '$ans' got: '$ans1'\n"; - } - } -} - -{ - use Math::BigInt ':constant'; - - $test++; - print "not " - unless 2**150 eq "+1427247692705959881058285969449495136382746624"; - print "ok $test\n"; - $test++; - @a = (); - for ($i = 1; $i < 10; $i++) { - push @a, $i; - } - print "not " unless "@a" eq "+1 +2 +3 +4 +5 +6 +7 +8 +9"; - print "ok $test\n"; -} - -__END__ -&bnorm -abc:NaN - 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 -&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 -&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 -&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 -+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 -&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 -&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 -+100:+625:+25 -+4096:+81:+1 -&blsft -abc:abc:NaN -+2:+2:+8 -+1:+32:+4294967296 -+1:+48:+281474976710656 -+8:-2:NaN -&brsft -abc:abc:NaN -+8:+2:+2 -+4294967296:+32:+1 -+281474976710656:+48:+1 -+2:-2:NaN -&band -abc:abc:NaN -+8:+2:+0 -+281474976710656:+0:+0 -+281474976710656:+1:+0 -+281474976710656:+281474976710656:+281474976710656 -&bior -abc:abc:NaN -+8:+2:+10 -+281474976710656:+0:+281474976710656 -+281474976710656:+1:+281474976710657 -+281474976710656:+281474976710656:+281474976710656 -&bxor -abc:abc:NaN -+8:+2:+10 -+281474976710656:+0:+281474976710656 -+281474976710656:+1:+281474976710657 -+281474976710656:+281474976710656:+0 -&bnot -abc:NaN -+0:-1 -+8:-9 -+281474976710656:-281474976710657 diff --git a/contrib/perl5/t/lib/cgi-esc.t b/contrib/perl5/t/lib/cgi-esc.t deleted file mode 100755 index f0471cf..0000000 --- a/contrib/perl5/t/lib/cgi-esc.t +++ /dev/null @@ -1,56 +0,0 @@ -#!/usr/local/bin/perl -w - -BEGIN { - chdir('t') if -d 't'; - @INC = '../lib'; -} - -# Test ability to escape() and unescape() punctuation characters -# except for qw(- . _). -######################### We start with some black magic to print on failure. -use lib '../blib/lib','../blib/arch'; - -BEGIN {$| = 1; print "1..59\n"; } -END {print "not ok 1\n" unless $loaded;} -use Config; -use CGI::Util qw(escape unescape); -$loaded = 1; -print "ok 1\n"; - -######################### End of black magic. - -# util -sub test { - local($^W) = 0; - my($num, $true,$msg) = @_; - print($true ? "ok $num\n" : "not ok $num $msg\n"); -} - -# ASCII order, ASCII codepoints, ASCII repertoire - -my %punct = ( - ' ' => '20', '!' => '21', '"' => '22', '#' => '23', - '$' => '24', '%' => '25', '&' => '26', '\'' => '27', - '(' => '28', ')' => '29', '*' => '2A', '+' => '2B', - ',' => '2C', '/' => '2F', # '-' => '2D', '.' => '2E' - ':' => '3A', ';' => '3B', '<' => '3C', '=' => '3D', - '>' => '3E', '?' => '3F', '[' => '5B', '\\' => '5C', - ']' => '5D', '^' => '5E', '`' => '60', # '_' => '5F', - '{' => '7B', '|' => '7C', '}' => '7D', '~' => '7E', - ); - -# The sort order may not be ASCII on EBCDIC machines: - -my $i = 1; - -foreach(sort(keys(%punct))) { - $i++; - my $escape = "AbC\%$punct{$_}dEF"; - my $cgi_escape = escape("AbC$_" . "dEF"); - test($i, $escape eq $cgi_escape , "# $escape ne $cgi_escape"); - $i++; - my $unescape = "AbC$_" . "dEF"; - my $cgi_unescape = unescape("AbC\%$punct{$_}dEF"); - test($i, $unescape eq $cgi_unescape , "# $unescape ne $cgi_unescape"); -} - diff --git a/contrib/perl5/t/lib/cgi-form.t b/contrib/perl5/t/lib/cgi-form.t deleted file mode 100755 index 2922903..0000000 --- a/contrib/perl5/t/lib/cgi-form.t +++ /dev/null @@ -1,90 +0,0 @@ -#!/usr/local/bin/perl -w - -BEGIN { - chdir('t') if -d 't'; - @INC = '../lib'; -} - -# Test ability to retrieve HTTP request info -######################### We start with some black magic to print on failure. -use lib '../blib/lib','../blib/arch'; - -BEGIN {$| = 1; print "1..17\n"; } -END {print "not ok 1\n" unless $loaded;} -use CGI (':standard','-no_debug'); -$loaded = 1; -print "ok 1\n"; - -######################### End of black magic. - -# util -sub test { - local($^W) = 0; - my($num, $true,$msg) = @_; - print($true ? "ok $num\n" : "not ok $num $msg\n"); -} - -my $CRLF = "\015\012"; -if ($^O eq 'VMS') { - $CRLF = "\n"; # via web server carriage is inserted automatically -} -if (ord("\t") != 9) { # EBCDIC? - $CRLF = "\r\n"; -} - - -# Set up a CGI environment -$ENV{REQUEST_METHOD}='GET'; -$ENV{QUERY_STRING} ='game=chess&game=checkers&weather=dull'; -$ENV{PATH_INFO} ='/somewhere/else'; -$ENV{PATH_TRANSLATED} ='/usr/local/somewhere/else'; -$ENV{SCRIPT_NAME} ='/cgi-bin/foo.cgi'; -$ENV{SERVER_PROTOCOL} = 'HTTP/1.0'; -$ENV{SERVER_PORT} = 8080; -$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com'; - -test(2,start_form(-action=>'foobar',-method=>'get') eq - qq(<form method="get" action="foobar" enctype="application/x-www-form-urlencoded">\n), - "start_form()"); - -test(3,submit() eq qq(<input type="submit" name=".submit" />),"submit()"); -test(4,submit(-name=>'foo',-value=>'bar') eq qq(<input type="submit" name="foo" value="bar" />),"submit(-name,-value)"); -test(5,submit({-name=>'foo',-value=>'bar'}) eq qq(<input type="submit" name="foo" value="bar" />),"submit({-name,-value})"); -test(6,textfield(-name=>'weather') eq qq(<input type="text" name="weather" value="dull" />),"textfield({-name})"); -test(7,textfield(-name=>'weather',-value=>'nice') eq qq(<input type="text" name="weather" value="dull" />),"textfield({-name,-value})"); -test(8,textfield(-name=>'weather',-value=>'nice',-override=>1) eq qq(<input type="text" name="weather" value="nice" />), - "textfield({-name,-value,-override})"); -test(9,checkbox(-name=>'weather',-value=>'nice') eq qq(<input type="checkbox" name="weather" value="nice" />weather), - "checkbox()"); -test(10,checkbox(-name=>'weather',-value=>'nice',-label=>'forecast') eq - qq(<input type="checkbox" name="weather" value="nice" />forecast), - "checkbox()"); -test(11,checkbox(-name=>'weather',-value=>'nice',-label=>'forecast',-checked=>1,-override=>1) eq - qq(<input type="checkbox" name="weather" value="nice" checked />forecast), - "checkbox()"); -test(12,checkbox(-name=>'weather',-value=>'dull',-label=>'forecast') eq - qq(<input type="checkbox" name="weather" value="dull" checked />forecast), - "checkbox()"); - -test(13,radio_group(-name=>'game') eq - qq(<input type="radio" name="game" value="chess" checked />chess <input type="radio" name="game" value="checkers" />checkers), - 'radio_group()'); -test(14,radio_group(-name=>'game',-labels=>{'chess'=>'ping pong'}) eq - qq(<input type="radio" name="game" value="chess" checked />ping pong <input type="radio" name="game" value="checkers" />checkers), - 'radio_group()'); - -test(15, checkbox_group(-name=>'game',-Values=>[qw/checkers chess cribbage/]) eq - qq(<input type="checkbox" name="game" value="checkers" checked />checkers <input type="checkbox" name="game" value="chess" checked />chess <input type="checkbox" name="game" value="cribbage" />cribbage), - 'checkbox_group()'); - -test(16, checkbox_group(-name=>'game',-values=>[qw/checkers chess cribbage/],-defaults=>['cribbage'],-override=>1) eq - qq(<input type="checkbox" name="game" value="checkers" />checkers <input type="checkbox" name="game" value="chess" />chess <input type="checkbox" name="game" value="cribbage" checked />cribbage), - 'checkbox_group()'); -test(17, popup_menu(-name=>'game',-values=>[qw/checkers chess cribbage/],-default=>'cribbage',-override=>1) eq <<END,'checkbox_group()'); -<select name="game"> -<option value="checkers">checkers</option> -<option value="chess">chess</option> -<option selected value="cribbage">cribbage</option> -</select> -END - diff --git a/contrib/perl5/t/lib/cgi-function.t b/contrib/perl5/t/lib/cgi-function.t deleted file mode 100755 index 3b9722e..0000000 --- a/contrib/perl5/t/lib/cgi-function.t +++ /dev/null @@ -1,106 +0,0 @@ -#!/usr/local/bin/perl -w - -BEGIN { - chdir('t') if -d 't'; - @INC = '../lib'; -} - -# Test ability to retrieve HTTP request info -######################### We start with some black magic to print on failure. -use lib '../blib/lib','../blib/arch'; - -BEGIN {$| = 1; print "1..27\n"; } -END {print "not ok 1\n" unless $loaded;} -use Config; -use CGI (':standard','keywords'); -$loaded = 1; -print "ok 1\n"; - -######################### End of black magic. - -# util -sub test { - local($^W) = 0; - my($num, $true,$msg) = @_; - print($true ? "ok $num\n" : "not ok $num $msg\n"); -} - -my $CRLF = "\015\012"; - -# A peculiarity of sending "\n" through MBX|Socket|web-server on VMS -# is that a CR character gets inserted automatically in the web server -# case but not internal to perl's double quoted strings "\n". This -# test would need to be modified to use the "\015\012" on VMS if it -# were actually run through a web server. -# Thanks to Peter Prymmer for this - -if ($^O eq 'VMS') { $CRLF = "\n"; } - -# Web servers on EBCDIC hosts are typically set up to do an EBCDIC -> ASCII -# translation hence CRLF is used as \r\n within CGI.pm on such machines. - -if (ord("\t") != 9) { $CRLF = "\r\n"; } - -# Set up a CGI environment -$ENV{REQUEST_METHOD}='GET'; -$ENV{QUERY_STRING} ='game=chess&game=checkers&weather=dull'; -$ENV{PATH_INFO} ='/somewhere/else'; -$ENV{PATH_TRANSLATED} ='/usr/local/somewhere/else'; -$ENV{SCRIPT_NAME} ='/cgi-bin/foo.cgi'; -$ENV{SERVER_PROTOCOL} = 'HTTP/1.0'; -$ENV{SERVER_PORT} = 8080; -$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com'; -$ENV{HTTP_LOVE} = 'true'; - -test(2,request_method() eq 'GET',"CGI::request_method()"); -test(3,query_string() eq 'game=chess;game=checkers;weather=dull',"CGI::query_string()"); -test(4,param() == 2,"CGI::param()"); -test(5,join(' ',sort {$a cmp $b} param()) eq 'game weather',"CGI::param()"); -test(6,param('game') eq 'chess',"CGI::param()"); -test(7,param('weather') eq 'dull',"CGI::param()"); -test(8,join(' ',param('game')) eq 'chess checkers',"CGI::param()"); -test(9,param(-name=>'foo',-value=>'bar'),'CGI::param() put'); -test(10,param(-name=>'foo') eq 'bar','CGI::param() get'); -test(11,query_string() eq 'game=chess;game=checkers;weather=dull;foo=bar',"CGI::query_string() redux"); -test(12,http('love') eq 'true',"CGI::http()"); -test(13,script_name() eq '/cgi-bin/foo.cgi',"CGI::script_name()"); -test(14,url() eq 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi',"CGI::url()"); -test(15,self_url() eq - 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', - "CGI::url()"); -test(16,url(-absolute=>1) eq '/cgi-bin/foo.cgi','CGI::url(-absolute=>1)'); -test(17,url(-relative=>1) eq 'foo.cgi','CGI::url(-relative=>1)'); -test(18,url(-relative=>1,-path=>1) eq 'foo.cgi/somewhere/else','CGI::url(-relative=>1,-path=>1)'); -test(19,url(-relative=>1,-path=>1,-query=>1) eq - 'foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', - 'CGI::url(-relative=>1,-path=>1,-query=>1)'); -Delete('foo'); -test(20,!param('foo'),'CGI::delete()'); - -CGI::_reset_globals(); -$ENV{QUERY_STRING}='mary+had+a+little+lamb'; -test(21,join(' ',keywords()) eq 'mary had a little lamb','CGI::keywords'); -test(22,join(' ',param('keywords')) eq 'mary had a little lamb','CGI::keywords'); - -CGI::_reset_globals; -if ($Config{d_fork}) { - $test_string = 'game=soccer&game=baseball&weather=nice'; - $ENV{REQUEST_METHOD}='POST'; - $ENV{CONTENT_LENGTH}=length($test_string); - $ENV{QUERY_STRING}='big_balls=basketball&small_balls=golf'; - if (open(CHILD,"|-")) { # cparent - print CHILD $test_string; - close CHILD; - exit 0; - } - # at this point, we're in a new (child) process - test(23,param('weather') eq 'nice',"CGI::param() from POST"); - test(24,(url_param('big_balls') eq 'basketball'),"CGI::url_param()"); -} else { - print "ok 23 # Skip\n"; - print "ok 24 # Skip\n"; -} -test(25,redirect('http://somewhere.else') eq "Status: 302 Moved${CRLF}location: http://somewhere.else${CRLF}${CRLF}","CGI::redirect() 1"); -my $h = redirect(-Location=>'http://somewhere.else',-Type=>'text/html'); -test(26,$h eq "Status: 302 Moved${CRLF}location: http://somewhere.else${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","CGI::redirect() 2"); -test(27,redirect(-Location=>'http://somewhere.else/bin/foo&bar',-Type=>'text/html') eq "Status: 302 Moved${CRLF}location: http://somewhere.else/bin/foo&bar${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","CGI::redirect() 2"); diff --git a/contrib/perl5/t/lib/cgi-html.t b/contrib/perl5/t/lib/cgi-html.t deleted file mode 100755 index 93e5dac..0000000 --- a/contrib/perl5/t/lib/cgi-html.t +++ /dev/null @@ -1,95 +0,0 @@ -#!/usr/local/bin/perl -w - -BEGIN { - chdir('t') if -d 't'; - @INC = '../lib'; -} - -# Test ability to retrieve HTTP request info -######################### We start with some black magic to print on failure. -use lib '../blib/lib','../blib/arch'; - -BEGIN {$| = 1; print "1..24\n"; } -END {print "not ok 1\n" unless $loaded;} -use CGI (':standard','-no_debug','*h3','start_table'); -$loaded = 1; -print "ok 1\n"; - -######################### End of black magic. - -my $CRLF = "\015\012"; -if ($^O eq 'VMS') { - $CRLF = "\n"; # via web server carriage is inserted automatically -} -if (ord("\t") != 9) { # EBCDIC? - $CRLF = "\r\n"; -} - - -# util -sub test { - local($^W) = 0; - my($num, $true,$msg) = @_; - print($true ? "ok $num\n" : "not ok $num $msg\n"); -} - -# all the automatic tags -test(2,h1() eq '<h1 />',"single tag"); -test(3,h1('fred') eq '<h1>fred</h1>',"open/close tag"); -test(4,h1('fred','agnes','maura') eq '<h1>fred agnes maura</h1>',"open/close tag multiple"); -test(5,h1({-align=>'CENTER'},'fred') eq '<h1 align="CENTER">fred</h1>',"open/close tag with attribute"); -test(6,h1({-align=>undef},'fred') eq '<h1 align>fred</h1>',"open/close tag with orphan attribute"); -test(7,h1({-align=>'CENTER'},['fred','agnes']) eq - '<h1 align="CENTER">fred</h1> <h1 align="CENTER">agnes</h1>', - "distributive tag with attribute"); -{ - local($") = '-'; - test(8,h1('fred','agnes','maura') eq '<h1>fred-agnes-maura</h1>',"open/close tag \$\" interpolation"); -} -test(9,header() eq "Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","header()"); -test(10,header(-type=>'image/gif') eq "Content-Type: image/gif${CRLF}${CRLF}","header()"); -test(11,header(-type=>'image/gif',-status=>'500 Sucks') eq "Status: 500 Sucks${CRLF}Content-Type: image/gif${CRLF}${CRLF}","header()"); -test(12,header(-nph=>1) =~ m!HTTP/1.0 200 OK${CRLF}Server: cmdline${CRLF}Date:.+${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}!,"header()"); -test(13,start_html() ."\n" eq <<END,"start_html()"); -<?xml version="1.0" encoding="utf-8"?> -<!DOCTYPE html - PUBLIC "-//W3C//DTD XHTML Basic 1.0//EN" - "http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd"> -<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US"><head><title>Untitled Document</title> -</head><body> -END - ; -test(14,start_html(-dtd=>"-//IETF//DTD HTML 3.2//FR") ."\n" eq <<END,"start_html()"); -<!DOCTYPE html - PUBLIC "-//IETF//DTD HTML 3.2//FR"> -<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US"><head><title>Untitled Document</title> -</head><body> -END - ; -test(15,start_html(-Title=>'The world of foo') ."\n" eq <<END,"start_html()"); -<?xml version="1.0" encoding="utf-8"?> -<!DOCTYPE html - PUBLIC "-//W3C//DTD XHTML Basic 1.0//EN" - "http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd"> -<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US"><head><title>The world of foo</title> -</head><body> -END - ; -test(16,($cookie=cookie(-name=>'fred',-value=>['chocolate','chip'],-path=>'/')) eq 'fred=chocolate&chip; path=/',"cookie()"); -my $h = header(-Cookie=>$cookie); -test(17,$h =~ m!^Set-Cookie: fred=chocolate&chip\; path=/${CRLF}Date:.*${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}!s, - "header(-cookie)"); -test(18,start_h3 eq '<h3>'); -test(19,end_h3 eq '</h3>'); -test(20,start_table({-border=>undef}) eq '<table border>'); -test(21,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is <not> ‹right›</h1>'); -charset('utf-8'); -if (ord("\t") == 9) { -test(22,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is <not> ‹right›</h1>'); -} -else { -test(22,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is <not> »rightº</h1>'); -} -test(23,i(p('hello there')) eq '<i><p>hello there</p></i>'); -my $q = new CGI; -test(24,$q->h1('hi') eq '<h1>hi</h1>'); diff --git a/contrib/perl5/t/lib/cgi-pretty.t b/contrib/perl5/t/lib/cgi-pretty.t deleted file mode 100755 index 14f6447..0000000 --- a/contrib/perl5/t/lib/cgi-pretty.t +++ /dev/null @@ -1,41 +0,0 @@ -#!/usr/local/bin/perl -w - -BEGIN { - chdir('t') if -d 't'; - @INC = '../lib'; -} - -# Test ability to retrieve HTTP request info -######################### We start with some black magic to print on failure. -use lib '../blib/lib','../blib/arch'; - -BEGIN {$| = 1; print "1..5\n"; } -END {print "not ok 1\n" unless $loaded;} -use CGI::Pretty (':standard','-no_debug','*h3','start_table'); -$loaded = 1; -print "ok 1\n"; - -######################### End of black magic. - -# util -sub test { - local($^W) = 0; - my($num, $true,$msg) = @_; - print($true ? "ok $num\n" : "not ok $num $msg\n"); -} - -# all the automatic tags -test(2,h1() eq '<h1>',"single tag"); -test(3,ol(li('fred'),li('ethel')) eq "<ol>\n\t<li>\n\t\tfred\n\t</li>\n\t <li>\n\t\tethel\n\t</li>\n</ol>\n","basic indentation"); -test(4,p('hi',pre('there'),'frog') eq -'<p> - hi <pre>there</pre> - frog -</p> -',"<pre> tags"); -test(5,p('hi',a({-href=>'frog'},'there'),'frog') eq -'<p> - hi <a href="frog">there</a> - frog -</p> -',"as-is"); diff --git a/contrib/perl5/t/lib/cgi-request.t b/contrib/perl5/t/lib/cgi-request.t deleted file mode 100755 index fde3fd0..0000000 --- a/contrib/perl5/t/lib/cgi-request.t +++ /dev/null @@ -1,103 +0,0 @@ -#!/usr/local/bin/perl -w - -BEGIN { - chdir('t') if -d 't'; - @INC = '../lib'; -} - -# Test ability to retrieve HTTP request info -######################### We start with some black magic to print on failure. -use lib '../blib/lib','../blib/arch'; - -BEGIN {$| = 1; print "1..33\n"; } -END {print "not ok 1\n" unless $loaded;} -use CGI (); -use Config; -$loaded = 1; -print "ok 1\n"; - -######################### End of black magic. - -# util -sub test { - local($^W) = 0; - my($num, $true,$msg) = @_; - print($true ? "ok $num\n" : "not ok $num $msg\n"); -} - -# Set up a CGI environment -$ENV{REQUEST_METHOD} = 'GET'; -$ENV{QUERY_STRING} = 'game=chess&game=checkers&weather=dull'; -$ENV{PATH_INFO} = '/somewhere/else'; -$ENV{PATH_TRANSLATED} = '/usr/local/somewhere/else'; -$ENV{SCRIPT_NAME} = '/cgi-bin/foo.cgi'; -$ENV{SERVER_PROTOCOL} = 'HTTP/1.0'; -$ENV{SERVER_PORT} = 8080; -$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com'; -$ENV{REQUEST_URI} = "$ENV{SCRIPT_NAME}$ENV{PATH_INFO}?$ENV{QUERY_STRING}"; -$ENV{HTTP_LOVE} = 'true'; - -$q = new CGI; -test(2,$q,"CGI::new()"); -test(3,$q->request_method eq 'GET',"CGI::request_method()"); -test(4,$q->query_string eq 'game=chess;game=checkers;weather=dull',"CGI::query_string()"); -test(5,$q->param() == 2,"CGI::param()"); -test(6,join(' ',sort $q->param()) eq 'game weather',"CGI::param()"); -test(7,$q->param('game') eq 'chess',"CGI::param()"); -test(8,$q->param('weather') eq 'dull',"CGI::param()"); -test(9,join(' ',$q->param('game')) eq 'chess checkers',"CGI::param()"); -test(10,$q->param(-name=>'foo',-value=>'bar'),'CGI::param() put'); -test(11,$q->param(-name=>'foo') eq 'bar','CGI::param() get'); -test(12,$q->query_string eq 'game=chess;game=checkers;weather=dull;foo=bar',"CGI::query_string() redux"); -test(13,$q->http('love') eq 'true',"CGI::http()"); -test(14,$q->script_name eq '/cgi-bin/foo.cgi',"CGI::script_name()"); -test(15,$q->url eq 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi',"CGI::url()"); -test(16,$q->self_url eq - 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', - "CGI::url()"); -test(17,$q->url(-absolute=>1) eq '/cgi-bin/foo.cgi','CGI::url(-absolute=>1)'); -test(18,$q->url(-relative=>1) eq 'foo.cgi','CGI::url(-relative=>1)'); -test(19,$q->url(-relative=>1,-path=>1) eq 'foo.cgi/somewhere/else','CGI::url(-relative=>1,-path=>1)'); -test(20,$q->url(-relative=>1,-path=>1,-query=>1) eq - 'foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', - 'CGI::url(-relative=>1,-path=>1,-query=>1)'); -$q->delete('foo'); -test(21,!$q->param('foo'),'CGI::delete()'); - -$q->_reset_globals; -$ENV{QUERY_STRING}='mary+had+a+little+lamb'; -test(22,$q=new CGI,"CGI::new() redux"); -test(23,join(' ',$q->keywords) eq 'mary had a little lamb','CGI::keywords'); -test(24,join(' ',$q->param('keywords')) eq 'mary had a little lamb','CGI::keywords'); -test(25,$q=new CGI('foo=bar&foo=baz'),"CGI::new() redux"); -test(26,$q->param('foo') eq 'bar','CGI::param() redux'); -test(27,$q=new CGI({'foo'=>'bar','bar'=>'froz'}),"CGI::new() redux 2"); -test(28,$q->param('bar') eq 'froz',"CGI::param() redux 2"); - -# test tied interface -my $p = $q->Vars; -test(29,$p->{bar} eq 'froz',"tied interface fetch"); -$p->{bar} = join("\0",qw(foo bar baz)); -test(30,join(' ',$q->param('bar')) eq 'foo bar baz','tied interface store'); - -# test posting -$q->_reset_globals; -if ($Config{d_fork}) { - $test_string = 'game=soccer&game=baseball&weather=nice'; - $ENV{REQUEST_METHOD}='POST'; - $ENV{CONTENT_LENGTH}=length($test_string); - $ENV{QUERY_STRING}='big_balls=basketball&small_balls=golf'; - if (open(CHILD,"|-")) { # cparent - print CHILD $test_string; - close CHILD; - exit 0; - } - # at this point, we're in a new (child) process - test(31,$q=new CGI,"CGI::new() from POST"); - test(32,$q->param('weather') eq 'nice',"CGI::param() from POST"); - test(33,$q->url_param('big_balls') eq 'basketball',"CGI::url_param()"); -} else { - print "ok 31 # Skip\n"; - print "ok 32 # Skip\n"; - print "ok 33 # Skip\n"; -} diff --git a/contrib/perl5/t/lib/charnames.t b/contrib/perl5/t/lib/charnames.t deleted file mode 100755 index 2731136..0000000 --- a/contrib/perl5/t/lib/charnames.t +++ /dev/null @@ -1,110 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib'; - } -} - -$| = 1; -print "1..15\n"; - -use charnames ':full'; - -print "not " unless "Here\N{EXCLAMATION MARK}?" eq "Here\041?"; -print "ok 1\n"; - -{ - use bytes; # UTEST can switch utf8 on - - print "# \$res=$res \$\@='$@'\nnot " - if $res = eval <<'EOE' -use charnames ":full"; -"Here: \N{CYRILLIC SMALL LETTER BE}!"; -1 -EOE - or $@ !~ /above 0xFF/; - print "ok 2\n"; - # print "# \$res=$res \$\@='$@'\n"; - - print "# \$res=$res \$\@='$@'\nnot " - if $res = eval <<'EOE' -use charnames 'cyrillic'; -"Here: \N{Be}!"; -1 -EOE - or $@ !~ /CYRILLIC CAPITAL LETTER BE.*above 0xFF/; - print "ok 3\n"; -} - -# If octal representation of unicode char is \0xyzt, then the utf8 is \3xy\2zt -$encoded_be = "\320\261"; -$encoded_alpha = "\316\261"; -$encoded_bet = "\327\221"; -$encoded_deseng = "\360\220\221\215"; - -sub to_bytes { - pack"a*", shift; -} - -{ - use charnames ':full'; - - print "not " unless to_bytes("\N{CYRILLIC SMALL LETTER BE}") eq $encoded_be; - print "ok 4\n"; - - use charnames qw(cyrillic greek :short); - - print "not " unless to_bytes("\N{be},\N{alpha},\N{hebrew:bet}") - eq "$encoded_be,$encoded_alpha,$encoded_bet"; - print "ok 5\n"; -} - -{ - use charnames ':full'; - print "not " unless "\x{263a}" eq "\N{WHITE SMILING FACE}"; - print "ok 6\n"; - print "not " unless length("\x{263a}") == 1; - print "ok 7\n"; - print "not " unless length("\N{WHITE SMILING FACE}") == 1; - print "ok 8\n"; - print "not " unless sprintf("%vx", "\x{263a}") eq "263a"; - print "ok 9\n"; - print "not " unless sprintf("%vx", "\N{WHITE SMILING FACE}") eq "263a"; - print "ok 10\n"; - print "not " unless sprintf("%vx", "\xFF\N{WHITE SMILING FACE}") eq "ff.263a"; - print "ok 11\n"; - print "not " unless sprintf("%vx", "\x{ff}\N{WHITE SMILING FACE}") eq "ff.263a"; - print "ok 12\n"; -} - -{ - use charnames qw(:full); - use utf8; - - my $x = "\x{221b}"; - my $named = "\N{CUBE ROOT}"; - - print "not " unless ord($x) == ord($named); - print "ok 13\n"; -} - -{ - use charnames qw(:full); - use utf8; - print "not " unless "\x{100}\N{CENT SIGN}" eq "\x{100}"."\N{CENT SIGN}"; - print "ok 14\n"; -} - -{ - use charnames ':full'; - -# XXX this test breaks in 5.6.x because the Unicode database is missing -# "DESERET SMALL LETTER ENG". Uncomment after updating to Unicode 3.1 -# print "not " -# unless to_bytes("\N{DESERET SMALL LETTER ENG}") eq $encoded_deseng; - print "ok 15\n"; - -} - diff --git a/contrib/perl5/t/lib/checktree.t b/contrib/perl5/t/lib/checktree.t deleted file mode 100755 index b5426ca..0000000 --- a/contrib/perl5/t/lib/checktree.t +++ /dev/null @@ -1,19 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..1\n"; - -use File::CheckTree; - -# We assume that we run from the perl "t" directory. - -validate q{ - lib -d || die - lib/checktree.t -f || die -}; - -print "ok 1\n"; diff --git a/contrib/perl5/t/lib/class-struct.t b/contrib/perl5/t/lib/class-struct.t deleted file mode 100755 index 26505ba..0000000 --- a/contrib/perl5/t/lib/class-struct.t +++ /dev/null @@ -1,66 +0,0 @@ -#!./perl -w - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..8\n"; - -package aClass; - -sub new { bless {}, shift } - -sub meth { 42 } - -package MyObj; - -use Class::Struct; -use Class::Struct 'struct'; # test out both forms - -use Class::Struct SomeClass => { SomeElem => '$' }; - -struct( s => '$', a => '@', h => '%', c => 'aClass' ); - -my $obj = MyObj->new; - -$obj->s('foo'); - -print "not " unless $obj->s() eq 'foo'; -print "ok 1\n"; - -my $arf = $obj->a; - -print "not " unless ref $arf eq 'ARRAY'; -print "ok 2\n"; - -$obj->a(2, 'secundus'); - -print "not " unless $obj->a(2) eq 'secundus'; -print "ok 3\n"; - -my $hrf = $obj->h; - -print "not " unless ref $hrf eq 'HASH'; -print "ok 4\n"; - -$obj->h('x', 10); - -print "not " unless $obj->h('x') == 10; -print "ok 5\n"; - -my $orf = $obj->c; - -print "not " unless ref $orf eq 'aClass'; -print "ok 6\n"; - -print "not " unless $obj->c->meth() == 42; -print "ok 7\n"; - -my $obk = SomeClass->new(); - -$obk->SomeElem(123); - -print "not " unless $obk->SomeElem() == 123; -print "ok 8\n"; - diff --git a/contrib/perl5/t/lib/complex.t b/contrib/perl5/t/lib/complex.t deleted file mode 100755 index 334374d..0000000 --- a/contrib/perl5/t/lib/complex.t +++ /dev/null @@ -1,979 +0,0 @@ -#!./perl - -# $RCSfile: complex.t,v $ -# -# Regression tests for the Math::Complex pacakge -# -- Raphael Manfredi since Sep 1996 -# -- Jarkko Hietaniemi since Mar 1997 -# -- Daniel S. Lewart since Sep 1997 - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Math::Complex; - -use vars qw($VERSION); - -$VERSION = 1.91; - -my ($args, $op, $target, $test, $test_set, $try, $val, $zvalue, @set, @val); - -$test = 0; -$| = 1; -my @script = ( - 'my ($res, $s0,$s1,$s2,$s3,$s4,$s5,$s6,$s7,$s8,$s9,$s10, $z0,$z1,$z2);' . - "\n\n" -); -my $eps = 1e-13; - -if ($^O eq 'unicos') { # For some reason root() produces very inaccurate - $eps = 1e-10; # results in Cray UNICOS, and occasionally also -} # cos(), sin(), cosh(), sinh(). The division - # of doubles is the current suspect. - -while (<DATA>) { - s/^\s+//; - next if $_ eq '' || /^\#/; - chomp; - $test_set = 0; # Assume not a test over a set of values - if (/^&(.+)/) { - $op = $1; - next; - } - elsif (/^\{(.+)\}/) { - set($1, \@set, \@val); - next; - } - elsif (s/^\|//) { - $test_set = 1; # Requests we loop over the set... - } - my @args = split(/:/); - if ($test_set == 1) { - my $i; - for ($i = 0; $i < @set; $i++) { - # complex number - $target = $set[$i]; - # textual value as found in set definition - $zvalue = $val[$i]; - test($zvalue, $target, @args); - } - } else { - test($op, undef, @args); - } -} - -# - -sub test_mutators { - my $op; - - $test++; -push(@script, <<'EOT'); -{ - my $z = cplx( 1, 1); - $z->Re(2); - $z->Im(3); - print "# $test Re(z) = ",$z->Re(), " Im(z) = ", $z->Im(), " z = $z\n"; - print 'not ' unless Re($z) == 2 and Im($z) == 3; -EOT - push(@script, qq(print "ok $test\\n"}\n)); - - $test++; -push(@script, <<'EOT'); -{ - my $z = cplx( 1, 1); - $z->abs(3 * sqrt(2)); - print "# $test Re(z) = ",$z->Re(), " Im(z) = ", $z->Im(), " z = $z\n"; - print 'not ' unless (abs($z) - 3 * sqrt(2)) < $eps and - (arg($z) - pi / 4 ) < $eps and - (Re($z) - 3 ) < $eps and - (Im($z) - 3 ) < $eps; -EOT - push(@script, qq(print "ok $test\\n"}\n)); - - $test++; -push(@script, <<'EOT'); -{ - my $z = cplx( 1, 1); - $z->arg(-3 / 4 * pi); - print "# $test Re(z) = ",$z->Re(), " Im(z) = ", $z->Im(), " z = $z\n"; - print 'not ' unless (arg($z) + 3 / 4 * pi) < $eps and - (abs($z) - sqrt(2) ) < $eps and - (Re($z) + 1 ) < $eps and - (Im($z) + 1 ) < $eps; -EOT - push(@script, qq(print "ok $test\\n"}\n)); -} - -test_mutators(); - -my $constants = ' -my $i = cplx(0, 1); -my $pi = cplx(pi, 0); -my $pii = cplx(0, pi); -my $pip2 = cplx(pi/2, 0); -my $zero = cplx(0, 0); -'; - -push(@script, $constants); - - -# test the divbyzeros - -sub test_dbz { - for my $op (@_) { - $test++; - push(@script, <<EOT); - eval '$op'; - (\$bad) = (\$@ =~ /(.+)/); - print "# $test op = $op divbyzero? \$bad...\n"; - print 'not ' unless (\$@ =~ /Division by zero/); -EOT - push(@script, qq(print "ok $test\\n";\n)); - } -} - -# test the logofzeros - -sub test_loz { - for my $op (@_) { - $test++; - push(@script, <<EOT); - eval '$op'; - (\$bad) = (\$@ =~ /(.+)/); - print "# $test op = $op logofzero? \$bad...\n"; - print 'not ' unless (\$@ =~ /Logarithm of zero/); -EOT - push(@script, qq(print "ok $test\\n";\n)); - } -} - -test_dbz( - 'i/0', - 'acot(0)', - 'acot(+$i)', -# 'acoth(-1)', # Log of zero. - 'acoth(0)', - 'acoth(+1)', - 'acsc(0)', - 'acsch(0)', - 'asec(0)', - 'asech(0)', - 'atan($i)', -# 'atanh(-1)', # Log of zero. - 'atanh(+1)', - 'cot(0)', - 'coth(0)', - 'csc(0)', - 'csch(0)', - ); - -test_loz( - 'log($zero)', - 'atan(-$i)', - 'acot(-$i)', - 'atanh(-1)', - 'acoth(-1)', - ); - -# test the bad roots - -sub test_broot { - for my $op (@_) { - $test++; - push(@script, <<EOT); - eval 'root(2, $op)'; - (\$bad) = (\$@ =~ /(.+)/); - print "# $test op = $op badroot? \$bad...\n"; - print 'not ' unless (\$@ =~ /root rank must be/); -EOT - push(@script, qq(print "ok $test\\n";\n)); - } -} - -test_broot(qw(-3 -2.1 0 0.99)); - -sub test_display_format { - $test++; - push @script, <<EOS; - print "# package display_format cartesian?\n"; - print "not " unless Math::Complex->display_format eq 'cartesian'; - print "ok $test\n"; -EOS - - push @script, <<EOS; - my \$j = (root(1,3))[1]; - - \$j->display_format('polar'); -EOS - - $test++; - push @script, <<EOS; - print "# j display_format polar?\n"; - print "not " unless \$j->display_format eq 'polar'; - print "ok $test\n"; -EOS - - $test++; - push @script, <<EOS; - print "# j = \$j\n"; - print "not " unless "\$j" eq "[1,2pi/3]"; - print "ok $test\n"; - - my %display_format; - - %display_format = \$j->display_format; -EOS - - $test++; - push @script, <<EOS; - print "# display_format{style} polar?\n"; - print "not " unless \$display_format{style} eq 'polar'; - print "ok $test\n"; -EOS - - $test++; - push @script, <<EOS; - print "# keys %display_format == 2?\n"; - print "not " unless keys %display_format == 2; - print "ok $test\n"; - - \$j->display_format('style' => 'cartesian', 'format' => '%.5f'); -EOS - - $test++; - push @script, <<EOS; - print "# j = \$j\n"; - print "not " unless "\$j" eq "-0.50000+0.86603i"; - print "ok $test\n"; - - %display_format = \$j->display_format; -EOS - - $test++; - push @script, <<EOS; - print "# display_format{format} %.5f?\n"; - print "not " unless \$display_format{format} eq '%.5f'; - print "ok $test\n"; -EOS - - $test++; - push @script, <<EOS; - print "# keys %display_format == 3?\n"; - print "not " unless keys %display_format == 3; - print "ok $test\n"; - - \$j->display_format('format' => undef); -EOS - - $test++; - push @script, <<EOS; - print "# j = \$j\n"; - print "not " unless "\$j" =~ /^-0(?:\\.5(?:0000\\d+)?|\\.49999\\d+)\\+0.86602540\\d+i\$/; - print "ok $test\n"; - - \$j->display_format('style' => 'polar', 'polar_pretty_print' => 0); -EOS - - $test++; - push @script, <<EOS; - print "# j = \$j\n"; - print "not " unless "\$j" =~ /^\\[1,2\\.09439510\\d+\\]\$/; - print "ok $test\n"; - - \$j->display_format('style' => 'cartesian', 'format' => '(%.5g)'); -EOS - - $test++; - push @script, <<EOS; - print "# j = \$j\n"; - print "not " unless "\$j" eq "(-0.5)+(0.86603)i"; - print "ok $test\n"; -EOS - - $test++; - push @script, <<EOS; - print "# j display_format cartesian?\n"; - print "not " unless \$j->display_format eq 'cartesian'; - print "ok $test\n"; -EOS -} - -test_display_format(); - -print "1..$test\n"; -eval join '', @script; -die $@ if $@; - -sub abop { - my ($op) = @_; - - push(@script, qq(print "# $op=\n";)); -} - -sub test { - my ($op, $z, @args) = @_; - my ($baop) = 0; - $test++; - my $i; - $baop = 1 if ($op =~ s/;=$//); - for ($i = 0; $i < @args; $i++) { - $val = value($args[$i]); - push @script, "\$z$i = $val;\n"; - } - if (defined $z) { - $args = "'$op'"; # Really the value - $try = "abs(\$z0 - \$z1) <= $eps ? \$z1 : \$z0"; - push @script, "\$res = $try; "; - push @script, "check($test, $args[0], \$res, \$z$#args, $args);\n"; - } else { - my ($try, $args); - if (@args == 2) { - $try = "$op \$z0"; - $args = "'$args[0]'"; - } else { - $try = ($op =~ /^\w/) ? "$op(\$z0, \$z1)" : "\$z0 $op \$z1"; - $args = "'$args[0]', '$args[1]'"; - } - push @script, "\$res = $try; "; - push @script, "check($test, '$try', \$res, \$z$#args, $args);\n"; - if (@args > 2 and $baop) { # binary assignment ops - $test++; - # check the op= works - push @script, <<EOB; -{ - my \$za = cplx(ref \$z0 ? \@{\$z0->cartesian} : (\$z0, 0)); - - my (\$z1r, \$z1i) = ref \$z1 ? \@{\$z1->cartesian} : (\$z1, 0); - - my \$zb = cplx(\$z1r, \$z1i); - - \$za $op= \$zb; - my (\$zbr, \$zbi) = \@{\$zb->cartesian}; - - check($test, '\$z0 $op= \$z1', \$za, \$z$#args, $args); -EOB - $test++; - # check that the rhs has not changed - push @script, qq(print "not " unless (\$zbr == \$z1r and \$zbi == \$z1i);); - push @script, qq(print "ok $test\\n";\n); - push @script, "}\n"; - } - } -} - -sub set { - my ($set, $setref, $valref) = @_; - @{$setref} = (); - @{$valref} = (); - my @set = split(/;\s*/, $set); - my @res; - my $i; - for ($i = 0; $i < @set; $i++) { - push(@{$valref}, $set[$i]); - my $val = value($set[$i]); - push @script, "\$s$i = $val;\n"; - push @{$setref}, "\$s$i"; - } -} - -sub value { - local ($_) = @_; - if (/^\s*\((.*),(.*)\)/) { - return "cplx($1,$2)"; - } - elsif (/^\s*([\-\+]?(?:\d+(\.\d+)?|\.\d+)(?:[e[\-\+]\d+])?)/) { - return "cplx($1,0)"; - } - elsif (/^\s*\[(.*),(.*)\]/) { - return "cplxe($1,$2)"; - } - elsif (/^\s*'(.*)'/) { - my $ex = $1; - $ex =~ s/\bz\b/$target/g; - $ex =~ s/\br\b/abs($target)/g; - $ex =~ s/\bt\b/arg($target)/g; - $ex =~ s/\ba\b/Re($target)/g; - $ex =~ s/\bb\b/Im($target)/g; - return $ex; - } - elsif (/^\s*"(.*)"/) { - return "\"$1\""; - } - return $_; -} - -sub check { - my ($test, $try, $got, $expected, @z) = @_; - - print "# @_\n"; - - if ("$got" eq "$expected" - || - ($expected =~ /^-?\d/ && $got == $expected) - || - (abs($got - $expected) < $eps) - ) { - print "ok $test\n"; - } else { - print "not ok $test\n"; - my $args = (@z == 1) ? "z = $z[0]" : "z0 = $z[0], z1 = $z[1]"; - print "# '$try' expected: '$expected' got: '$got' for $args\n"; - } -} - -sub addsq { - my ($z1, $z2) = @_; - return ($z1 + i*$z2) * ($z1 - i*$z2); -} - -sub subsq { - my ($z1, $z2) = @_; - return ($z1 + $z2) * ($z1 - $z2); -} - -__END__ -&+;= -(3,4):(3,4):(6,8) -(-3,4):(3,-4):(0,0) -(3,4):-3:(0,4) -1:(4,2):(5,2) -[2,0]:[2,pi]:(0,0) - -&++ -(2,1):(3,1) - -&-;= -(2,3):(-2,-3) -[2,pi/2]:[2,-(pi)/2] -2:[2,0]:(0,0) -[3,0]:2:(1,0) -3:(4,5):(-1,-5) -(4,5):3:(1,5) -(2,1):(3,5):(-1,-4) - -&-- -(1,2):(0,2) -[2,pi]:[3,pi] - -&*;= -(0,1):(0,1):(-1,0) -(4,5):(1,0):(4,5) -[2,2*pi/3]:(1,0):[2,2*pi/3] -2:(0,1):(0,2) -(0,1):3:(0,3) -(0,1):(4,1):(-1,4) -(2,1):(4,-1):(9,2) - -&/;= -(3,4):(3,4):(1,0) -(4,-5):1:(4,-5) -1:(0,1):(0,-1) -(0,6):(0,2):(3,0) -(9,2):(4,-1):(2,1) -[4,pi]:[2,pi/2]:[2,pi/2] -[2,pi/2]:[4,pi]:[0.5,-(pi)/2] - -&**;= -(2,0):(3,0):(8,0) -(3,0):(2,0):(9,0) -(2,3):(4,0):(-119,-120) -(0,0):(1,0):(0,0) -(0,0):(2,3):(0,0) -(1,0):(0,0):(1,0) -(1,0):(1,0):(1,0) -(1,0):(2,3):(1,0) -(2,3):(0,0):(1,0) -(2,3):(1,0):(2,3) -(0,0):(0,0):(1,0) - -&Re -(3,4):3 -(-3,4):-3 -[1,pi/2]:0 - -&Im -(3,4):4 -(3,-4):-4 -[1,pi/2]:1 - -&abs -(3,4):5 -(-3,4):5 - -&arg -[2,0]:0 -[-2,0]:pi - -&~ -(4,5):(4,-5) -(-3,4):(-3,-4) -[2,pi/2]:[2,-(pi)/2] - -&< -(3,4):(1,2):0 -(3,4):(3,2):0 -(3,4):(3,8):1 -(4,4):(5,129):1 - -&== -(3,4):(4,5):0 -(3,4):(3,5):0 -(3,4):(2,4):0 -(3,4):(3,4):1 - -&sqrt --9:(0,3) -(-100,0):(0,10) -(16,-30):(5,-3) - -&stringify_cartesian -(-100,0):"-100" -(0,1):"i" -(4,-3):"4-3i" -(4,0):"4" -(-4,0):"-4" -(-2,4):"-2+4i" -(-2,-1):"-2-i" - -&stringify_polar -[-1, 0]:"[1,pi]" -[1, pi/3]:"[1,pi/3]" -[6, -2*pi/3]:"[6,-2pi/3]" -[0.5, -9*pi/11]:"[0.5,-9pi/11]" - -{ (4,3); [3,2]; (-3,4); (0,2); [2,1] } - -|'z + ~z':'2*Re(z)' -|'z - ~z':'2*i*Im(z)' -|'z * ~z':'abs(z) * abs(z)' - -{ (0.5, 0); (-0.5, 0); (2,3); [3,2]; (-3,2); (0,2); 3; 1.2; (-3, 0); (-2, -1); [2,1] } - -|'(root(z, 4))[1] ** 4':'z' -|'(root(z, 5))[3] ** 5':'z' -|'(root(z, 8))[7] ** 8':'z' -|'abs(z)':'r' -|'acot(z)':'acotan(z)' -|'acsc(z)':'acosec(z)' -|'acsc(z)':'asin(1 / z)' -|'asec(z)':'acos(1 / z)' -|'cbrt(z)':'cbrt(r) * exp(i * t/3)' -|'cos(acos(z))':'z' -|'addsq(cos(z), sin(z))':1 -|'cos(z)':'cosh(i*z)' -|'subsq(cosh(z), sinh(z))':1 -|'cot(acot(z))':'z' -|'cot(z)':'1 / tan(z)' -|'cot(z)':'cotan(z)' -|'csc(acsc(z))':'z' -|'csc(z)':'1 / sin(z)' -|'csc(z)':'cosec(z)' -|'exp(log(z))':'z' -|'exp(z)':'exp(a) * exp(i * b)' -|'ln(z)':'log(z)' -|'log(exp(z))':'z' -|'log(z)':'log(r) + i*t' -|'log10(z)':'log(z) / log(10)' -|'logn(z, 2)':'log(z) / log(2)' -|'logn(z, 3)':'log(z) / log(3)' -|'sec(asec(z))':'z' -|'sec(z)':'1 / cos(z)' -|'sin(asin(z))':'z' -|'sin(i * z)':'i * sinh(z)' -|'sqrt(z) * sqrt(z)':'z' -|'sqrt(z)':'sqrt(r) * exp(i * t/2)' -|'tan(atan(z))':'z' -|'z**z':'exp(z * log(z))' - -{ (1,1); [1,0.5]; (-2, -1); 2; -3; (-1,0.5); (0,0.5); 0.5; (2, 0); (-1, -2) } - -|'cosh(acosh(z))':'z' -|'coth(acoth(z))':'z' -|'coth(z)':'1 / tanh(z)' -|'coth(z)':'cotanh(z)' -|'csch(acsch(z))':'z' -|'csch(z)':'1 / sinh(z)' -|'csch(z)':'cosech(z)' -|'sech(asech(z))':'z' -|'sech(z)':'1 / cosh(z)' -|'sinh(asinh(z))':'z' -|'tanh(atanh(z))':'z' - -{ (0.2,-0.4); [1,0.5]; -1.2; (-1,0.5); 0.5; (1.1, 0) } - -|'acos(cos(z)) ** 2':'z * z' -|'acosh(cosh(z)) ** 2':'z * z' -|'acoth(z)':'acotanh(z)' -|'acoth(z)':'atanh(1 / z)' -|'acsch(z)':'acosech(z)' -|'acsch(z)':'asinh(1 / z)' -|'asech(z)':'acosh(1 / z)' -|'asin(sin(z))':'z' -|'asinh(sinh(z))':'z' -|'atan(tan(z))':'z' -|'atanh(tanh(z))':'z' - -&log -(-2.0,0):( 0.69314718055995, 3.14159265358979) -(-1.0,0):( 0 , 3.14159265358979) -(-0.5,0):( -0.69314718055995, 3.14159265358979) -( 0.5,0):( -0.69314718055995, 0 ) -( 1.0,0):( 0 , 0 ) -( 2.0,0):( 0.69314718055995, 0 ) - -&log -( 2, 3):( 1.28247467873077, 0.98279372324733) -(-2, 3):( 1.28247467873077, 2.15879893034246) -(-2,-3):( 1.28247467873077, -2.15879893034246) -( 2,-3):( 1.28247467873077, -0.98279372324733) - -&sin -(-2.0,0):( -0.90929742682568, 0 ) -(-1.0,0):( -0.84147098480790, 0 ) -(-0.5,0):( -0.47942553860420, 0 ) -( 0.0,0):( 0 , 0 ) -( 0.5,0):( 0.47942553860420, 0 ) -( 1.0,0):( 0.84147098480790, 0 ) -( 2.0,0):( 0.90929742682568, 0 ) - -&sin -( 2, 3):( 9.15449914691143, -4.16890695996656) -(-2, 3):( -9.15449914691143, -4.16890695996656) -(-2,-3):( -9.15449914691143, 4.16890695996656) -( 2,-3):( 9.15449914691143, 4.16890695996656) - -&cos -(-2.0,0):( -0.41614683654714, 0 ) -(-1.0,0):( 0.54030230586814, 0 ) -(-0.5,0):( 0.87758256189037, 0 ) -( 0.0,0):( 1 , 0 ) -( 0.5,0):( 0.87758256189037, 0 ) -( 1.0,0):( 0.54030230586814, 0 ) -( 2.0,0):( -0.41614683654714, 0 ) - -&cos -( 2, 3):( -4.18962569096881, -9.10922789375534) -(-2, 3):( -4.18962569096881, 9.10922789375534) -(-2,-3):( -4.18962569096881, -9.10922789375534) -( 2,-3):( -4.18962569096881, 9.10922789375534) - -&tan -(-2.0,0):( 2.18503986326152, 0 ) -(-1.0,0):( -1.55740772465490, 0 ) -(-0.5,0):( -0.54630248984379, 0 ) -( 0.0,0):( 0 , 0 ) -( 0.5,0):( 0.54630248984379, 0 ) -( 1.0,0):( 1.55740772465490, 0 ) -( 2.0,0):( -2.18503986326152, 0 ) - -&tan -( 2, 3):( -0.00376402564150, 1.00323862735361) -(-2, 3):( 0.00376402564150, 1.00323862735361) -(-2,-3):( 0.00376402564150, -1.00323862735361) -( 2,-3):( -0.00376402564150, -1.00323862735361) - -&sec -(-2.0,0):( -2.40299796172238, 0 ) -(-1.0,0):( 1.85081571768093, 0 ) -(-0.5,0):( 1.13949392732455, 0 ) -( 0.0,0):( 1 , 0 ) -( 0.5,0):( 1.13949392732455, 0 ) -( 1.0,0):( 1.85081571768093, 0 ) -( 2.0,0):( -2.40299796172238, 0 ) - -&sec -( 2, 3):( -0.04167496441114, 0.09061113719624) -(-2, 3):( -0.04167496441114, -0.09061113719624) -(-2,-3):( -0.04167496441114, 0.09061113719624) -( 2,-3):( -0.04167496441114, -0.09061113719624) - -&csc -(-2.0,0):( -1.09975017029462, 0 ) -(-1.0,0):( -1.18839510577812, 0 ) -(-0.5,0):( -2.08582964293349, 0 ) -( 0.5,0):( 2.08582964293349, 0 ) -( 1.0,0):( 1.18839510577812, 0 ) -( 2.0,0):( 1.09975017029462, 0 ) - -&csc -( 2, 3):( 0.09047320975321, 0.04120098628857) -(-2, 3):( -0.09047320975321, 0.04120098628857) -(-2,-3):( -0.09047320975321, -0.04120098628857) -( 2,-3):( 0.09047320975321, -0.04120098628857) - -&cot -(-2.0,0):( 0.45765755436029, 0 ) -(-1.0,0):( -0.64209261593433, 0 ) -(-0.5,0):( -1.83048772171245, 0 ) -( 0.5,0):( 1.83048772171245, 0 ) -( 1.0,0):( 0.64209261593433, 0 ) -( 2.0,0):( -0.45765755436029, 0 ) - -&cot -( 2, 3):( -0.00373971037634, -0.99675779656936) -(-2, 3):( 0.00373971037634, -0.99675779656936) -(-2,-3):( 0.00373971037634, 0.99675779656936) -( 2,-3):( -0.00373971037634, 0.99675779656936) - -&asin -(-2.0,0):( -1.57079632679490, 1.31695789692482) -(-1.0,0):( -1.57079632679490, 0 ) -(-0.5,0):( -0.52359877559830, 0 ) -( 0.0,0):( 0 , 0 ) -( 0.5,0):( 0.52359877559830, 0 ) -( 1.0,0):( 1.57079632679490, 0 ) -( 2.0,0):( 1.57079632679490, -1.31695789692482) - -&asin -( 2, 3):( 0.57065278432110, 1.98338702991654) -(-2, 3):( -0.57065278432110, 1.98338702991654) -(-2,-3):( -0.57065278432110, -1.98338702991654) -( 2,-3):( 0.57065278432110, -1.98338702991654) - -&acos -(-2.0,0):( 3.14159265358979, -1.31695789692482) -(-1.0,0):( 3.14159265358979, 0 ) -(-0.5,0):( 2.09439510239320, 0 ) -( 0.0,0):( 1.57079632679490, 0 ) -( 0.5,0):( 1.04719755119660, 0 ) -( 1.0,0):( 0 , 0 ) -( 2.0,0):( 0 , 1.31695789692482) - -&acos -( 2, 3):( 1.00014354247380, -1.98338702991654) -(-2, 3):( 2.14144911111600, -1.98338702991654) -(-2,-3):( 2.14144911111600, 1.98338702991654) -( 2,-3):( 1.00014354247380, 1.98338702991654) - -&atan -(-2.0,0):( -1.10714871779409, 0 ) -(-1.0,0):( -0.78539816339745, 0 ) -(-0.5,0):( -0.46364760900081, 0 ) -( 0.0,0):( 0 , 0 ) -( 0.5,0):( 0.46364760900081, 0 ) -( 1.0,0):( 0.78539816339745, 0 ) -( 2.0,0):( 1.10714871779409, 0 ) - -&atan -( 2, 3):( 1.40992104959658, 0.22907268296854) -(-2, 3):( -1.40992104959658, 0.22907268296854) -(-2,-3):( -1.40992104959658, -0.22907268296854) -( 2,-3):( 1.40992104959658, -0.22907268296854) - -&asec -(-2.0,0):( 2.09439510239320, 0 ) -(-1.0,0):( 3.14159265358979, 0 ) -(-0.5,0):( 3.14159265358979, -1.31695789692482) -( 0.5,0):( 0 , 1.31695789692482) -( 1.0,0):( 0 , 0 ) -( 2.0,0):( 1.04719755119660, 0 ) - -&asec -( 2, 3):( 1.42041072246703, 0.23133469857397) -(-2, 3):( 1.72118193112276, 0.23133469857397) -(-2,-3):( 1.72118193112276, -0.23133469857397) -( 2,-3):( 1.42041072246703, -0.23133469857397) - -&acsc -(-2.0,0):( -0.52359877559830, 0 ) -(-1.0,0):( -1.57079632679490, 0 ) -(-0.5,0):( -1.57079632679490, 1.31695789692482) -( 0.5,0):( 1.57079632679490, -1.31695789692482) -( 1.0,0):( 1.57079632679490, 0 ) -( 2.0,0):( 0.52359877559830, 0 ) - -&acsc -( 2, 3):( 0.15038560432786, -0.23133469857397) -(-2, 3):( -0.15038560432786, -0.23133469857397) -(-2,-3):( -0.15038560432786, 0.23133469857397) -( 2,-3):( 0.15038560432786, 0.23133469857397) - -&acot -(-2.0,0):( -0.46364760900081, 0 ) -(-1.0,0):( -0.78539816339745, 0 ) -(-0.5,0):( -1.10714871779409, 0 ) -( 0.5,0):( 1.10714871779409, 0 ) -( 1.0,0):( 0.78539816339745, 0 ) -( 2.0,0):( 0.46364760900081, 0 ) - -&acot -( 2, 3):( 0.16087527719832, -0.22907268296854) -(-2, 3):( -0.16087527719832, -0.22907268296854) -(-2,-3):( -0.16087527719832, 0.22907268296854) -( 2,-3):( 0.16087527719832, 0.22907268296854) - -&sinh -(-2.0,0):( -3.62686040784702, 0 ) -(-1.0,0):( -1.17520119364380, 0 ) -(-0.5,0):( -0.52109530549375, 0 ) -( 0.0,0):( 0 , 0 ) -( 0.5,0):( 0.52109530549375, 0 ) -( 1.0,0):( 1.17520119364380, 0 ) -( 2.0,0):( 3.62686040784702, 0 ) - -&sinh -( 2, 3):( -3.59056458998578, 0.53092108624852) -(-2, 3):( 3.59056458998578, 0.53092108624852) -(-2,-3):( 3.59056458998578, -0.53092108624852) -( 2,-3):( -3.59056458998578, -0.53092108624852) - -&cosh -(-2.0,0):( 3.76219569108363, 0 ) -(-1.0,0):( 1.54308063481524, 0 ) -(-0.5,0):( 1.12762596520638, 0 ) -( 0.0,0):( 1 , 0 ) -( 0.5,0):( 1.12762596520638, 0 ) -( 1.0,0):( 1.54308063481524, 0 ) -( 2.0,0):( 3.76219569108363, 0 ) - -&cosh -( 2, 3):( -3.72454550491532, 0.51182256998738) -(-2, 3):( -3.72454550491532, -0.51182256998738) -(-2,-3):( -3.72454550491532, 0.51182256998738) -( 2,-3):( -3.72454550491532, -0.51182256998738) - -&tanh -(-2.0,0):( -0.96402758007582, 0 ) -(-1.0,0):( -0.76159415595576, 0 ) -(-0.5,0):( -0.46211715726001, 0 ) -( 0.0,0):( 0 , 0 ) -( 0.5,0):( 0.46211715726001, 0 ) -( 1.0,0):( 0.76159415595576, 0 ) -( 2.0,0):( 0.96402758007582, 0 ) - -&tanh -( 2, 3):( 0.96538587902213, -0.00988437503832) -(-2, 3):( -0.96538587902213, -0.00988437503832) -(-2,-3):( -0.96538587902213, 0.00988437503832) -( 2,-3):( 0.96538587902213, 0.00988437503832) - -&sech -(-2.0,0):( 0.26580222883408, 0 ) -(-1.0,0):( 0.64805427366389, 0 ) -(-0.5,0):( 0.88681888397007, 0 ) -( 0.0,0):( 1 , 0 ) -( 0.5,0):( 0.88681888397007, 0 ) -( 1.0,0):( 0.64805427366389, 0 ) -( 2.0,0):( 0.26580222883408, 0 ) - -&sech -( 2, 3):( -0.26351297515839, -0.03621163655877) -(-2, 3):( -0.26351297515839, 0.03621163655877) -(-2,-3):( -0.26351297515839, -0.03621163655877) -( 2,-3):( -0.26351297515839, 0.03621163655877) - -&csch -(-2.0,0):( -0.27572056477178, 0 ) -(-1.0,0):( -0.85091812823932, 0 ) -(-0.5,0):( -1.91903475133494, 0 ) -( 0.5,0):( 1.91903475133494, 0 ) -( 1.0,0):( 0.85091812823932, 0 ) -( 2.0,0):( 0.27572056477178, 0 ) - -&csch -( 2, 3):( -0.27254866146294, -0.04030057885689) -(-2, 3):( 0.27254866146294, -0.04030057885689) -(-2,-3):( 0.27254866146294, 0.04030057885689) -( 2,-3):( -0.27254866146294, 0.04030057885689) - -&coth -(-2.0,0):( -1.03731472072755, 0 ) -(-1.0,0):( -1.31303528549933, 0 ) -(-0.5,0):( -2.16395341373865, 0 ) -( 0.5,0):( 2.16395341373865, 0 ) -( 1.0,0):( 1.31303528549933, 0 ) -( 2.0,0):( 1.03731472072755, 0 ) - -&coth -( 2, 3):( 1.03574663776500, 0.01060478347034) -(-2, 3):( -1.03574663776500, 0.01060478347034) -(-2,-3):( -1.03574663776500, -0.01060478347034) -( 2,-3):( 1.03574663776500, -0.01060478347034) - -&asinh -(-2.0,0):( -1.44363547517881, 0 ) -(-1.0,0):( -0.88137358701954, 0 ) -(-0.5,0):( -0.48121182505960, 0 ) -( 0.0,0):( 0 , 0 ) -( 0.5,0):( 0.48121182505960, 0 ) -( 1.0,0):( 0.88137358701954, 0 ) -( 2.0,0):( 1.44363547517881, 0 ) - -&asinh -( 2, 3):( 1.96863792579310, 0.96465850440760) -(-2, 3):( -1.96863792579310, 0.96465850440761) -(-2,-3):( -1.96863792579310, -0.96465850440761) -( 2,-3):( 1.96863792579310, -0.96465850440760) - -&acosh -(-2.0,0):( 1.31695789692482, 3.14159265358979) -(-1.0,0):( 0, 3.14159265358979) -(-0.5,0):( 0, 2.09439510239320) -( 0.0,0):( 0, 1.57079632679490) -( 0.5,0):( 0, 1.04719755119660) -( 1.0,0):( 0 , 0 ) -( 2.0,0):( 1.31695789692482, 0 ) - -&acosh -( 2, 3):( 1.98338702991654, 1.00014354247380) -(-2, 3):( 1.98338702991653, 2.14144911111600) -(-2,-3):( 1.98338702991653, -2.14144911111600) -( 2,-3):( 1.98338702991654, -1.00014354247380) - -&atanh -(-2.0,0):( -0.54930614433405, 1.57079632679490) -(-0.5,0):( -0.54930614433405, 0 ) -( 0.0,0):( 0 , 0 ) -( 0.5,0):( 0.54930614433405, 0 ) -( 2.0,0):( 0.54930614433405, 1.57079632679490) - -&atanh -( 2, 3):( 0.14694666622553, 1.33897252229449) -(-2, 3):( -0.14694666622553, 1.33897252229449) -(-2,-3):( -0.14694666622553, -1.33897252229449) -( 2,-3):( 0.14694666622553, -1.33897252229449) - -&asech -(-2.0,0):( 0 , 2.09439510239320) -(-1.0,0):( 0 , 3.14159265358979) -(-0.5,0):( 1.31695789692482, 3.14159265358979) -( 0.5,0):( 1.31695789692482, 0 ) -( 1.0,0):( 0 , 0 ) -( 2.0,0):( 0 , 1.04719755119660) - -&asech -( 2, 3):( 0.23133469857397, -1.42041072246703) -(-2, 3):( 0.23133469857397, -1.72118193112276) -(-2,-3):( 0.23133469857397, 1.72118193112276) -( 2,-3):( 0.23133469857397, 1.42041072246703) - -&acsch -(-2.0,0):( -0.48121182505960, 0 ) -(-1.0,0):( -0.88137358701954, 0 ) -(-0.5,0):( -1.44363547517881, 0 ) -( 0.5,0):( 1.44363547517881, 0 ) -( 1.0,0):( 0.88137358701954, 0 ) -( 2.0,0):( 0.48121182505960, 0 ) - -&acsch -( 2, 3):( 0.15735549884499, -0.22996290237721) -(-2, 3):( -0.15735549884499, -0.22996290237721) -(-2,-3):( -0.15735549884499, 0.22996290237721) -( 2,-3):( 0.15735549884499, 0.22996290237721) - -&acoth -(-2.0,0):( -0.54930614433405, 0 ) -(-0.5,0):( -0.54930614433405, 1.57079632679490) -( 0.5,0):( 0.54930614433405, 1.57079632679490) -( 2.0,0):( 0.54930614433405, 0 ) - -&acoth -( 2, 3):( 0.14694666622553, -0.23182380450040) -(-2, 3):( -0.14694666622553, -0.23182380450040) -(-2,-3):( -0.14694666622553, 0.23182380450040) -( 2,-3):( 0.14694666622553, 0.23182380450040) - -# eof diff --git a/contrib/perl5/t/lib/db-btree.t b/contrib/perl5/t/lib/db-btree.t deleted file mode 100755 index 1822823..0000000 --- a/contrib/perl5/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'); - -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/contrib/perl5/t/lib/db-hash.t b/contrib/perl5/t/lib/db-hash.t deleted file mode 100755 index effc60b..0000000 --- a/contrib/perl5/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'); - -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/contrib/perl5/t/lib/db-recno.t b/contrib/perl5/t/lib/db-recno.t deleted file mode 100755 index 8b5a88c..0000000 --- a/contrib/perl5/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 '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/contrib/perl5/t/lib/dirhand.t b/contrib/perl5/t/lib/dirhand.t deleted file mode 100755 index aa7be35..0000000 --- a/contrib/perl5/t/lib/dirhand.t +++ /dev/null @@ -1,33 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if (not $Config{'d_readdir'}) { - print "1..0\n"; - exit 0; - } -} - -use DirHandle; - -print "1..5\n"; - -$dot = new DirHandle "."; -print defined($dot) ? "ok" : "not ok", " 1\n"; - -@a = sort <*>; -do { $first = $dot->read } while defined($first) && $first =~ /^\./; -print +(grep { $_ eq $first } @a) ? "ok" : "not ok", " 2\n"; - -@b = sort($first, (grep {/^[^.]/} $dot->read)); -print +(join("\0", @a) eq join("\0", @b)) ? "ok" : "not ok", " 3\n"; - -$dot->rewind; -@c = sort grep {/^[^.]/} $dot->read; -print +(join("\0", @b) eq join("\0", @c)) ? "ok" : "not ok", " 4\n"; - -$dot->close; -$dot->rewind; -print defined($dot->read) ? "not ok" : "ok", " 5\n"; diff --git a/contrib/perl5/t/lib/dosglob.t b/contrib/perl5/t/lib/dosglob.t deleted file mode 100755 index fd9bb1d..0000000 --- a/contrib/perl5/t/lib/dosglob.t +++ /dev/null @@ -1,112 +0,0 @@ -#!./perl - -# -# test glob() in File::DosGlob -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..10\n"; - -# override it in main:: -use File::DosGlob 'glob'; - -# test if $_ takes as the default -$_ = "lib/a*.t"; -my @r = glob; -print "not " if $_ ne 'lib/a*.t'; -print "ok 1\n"; -# we should have at least abbrev.t, anydbm.t, autoloader.t -print "# |@r|\nnot " if @r < 3; -print "ok 2\n"; - -# check if <*/*> works -@r = <*/a*.t>; -# atleast {argv,abbrev,anydbm,autoloader,append,arith,array,assignwarn,auto}.t -print "not " if @r < 9; -print "ok 3\n"; -my $r = scalar @r; - -# check if scalar context works -@r = (); -while (defined($_ = <*/a*.t>)) { - print "# $_\n"; - push @r, $_; -} -print "not " if @r != $r; -print "ok 4\n"; - -# check if list context works -@r = (); -for (<*/a*.t>) { - print "# $_\n"; - push @r, $_; -} -print "not " if @r != $r; -print "ok 5\n"; - -# test if implicit assign to $_ in while() works -@r = (); -while (<*/a*.t>) { - print "# $_\n"; - push @r, $_; -} -print "not " if @r != $r; -print "ok 6\n"; - -# test if explicit glob() gets assign magic too -my @s = (); -while (glob '*/a*.t') { - print "# $_\n"; - push @s, $_; -} -print "not " if "@r" ne "@s"; -print "ok 7\n"; - -# how about in a different package, like? -package Foo; -use File::DosGlob 'glob'; -@s = (); -while (glob '*/a*.t') { - print "# $_\n"; - push @s, $_; -} -print "not " if "@r" ne "@s"; -print "ok 8\n"; - -# test if different glob ops maintain independent contexts -@s = (); -while (<*/a*.t>) { - my $i = 0; - print "# $_ <"; - push @s, $_; - while (<*/b*.t>) { - print " $_"; - $i++; - } - print " >\n"; -} -print "not " if "@r" ne "@s"; -print "ok 9\n"; - -# how about a global override, hm? -eval <<'EOT'; -use File::DosGlob 'GLOBAL_glob'; -package Bar; -@s = (); -while (<*/a*.t>) { - my $i = 0; - print "# $_ <"; - push @s, $_; - while (glob '*/b*.t') { - print " $_"; - $i++; - } - print " >\n"; -} -print "not " if "@r" ne "@s"; -print "ok 10\n"; -EOT diff --git a/contrib/perl5/t/lib/dprof.t b/contrib/perl5/t/lib/dprof.t deleted file mode 100755 index be711f1..0000000 --- a/contrib/perl5/t/lib/dprof.t +++ /dev/null @@ -1,88 +0,0 @@ -#!perl - -BEGIN { - chdir( 't' ) if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bDevel\/DProf\b/){ - print "1..0 # Skip: Devel::DProf was not built\n"; - exit 0; - } -} - -END { - while(-e 'tmon.out' && unlink 'tmon.out') {} - while(-e 'err' && unlink 'err') {} -} - -use Benchmark qw( timediff timestr ); -use Getopt::Std 'getopts'; -getopts('vI:p:'); - -# -v Verbose -# -I Add to @INC -# -p Name of perl binary - -@tests = @ARGV ? @ARGV : sort (<lib/dprof/*_t>, <lib/dprof/*_v>); # glob-sort, for OS/2 - -$path_sep = $Config{path_sep} || ':'; -$perl5lib = $opt_I || join( $path_sep, @INC ); -$perl = $opt_p || $^X; - -if( $opt_v ){ - print "tests: @tests\n"; - print "perl: $perl\n"; - print "perl5lib: $perl5lib\n"; -} -if( $perl =~ m|^\./| ){ - # turn ./perl into ../perl, because of chdir(t) above. - $perl = ".$perl"; -} -if( ! -f $perl ){ die "Where's Perl?" } - -sub profile { - my $test = shift; - my @results; - local $ENV{PERL5LIB} = $perl5lib; - my $opt_d = '-d:DProf'; - - my $t_start = new Benchmark; - open( R, "$perl \"$opt_d\" $test |" ) || warn "$0: Can't run. $!\n"; - @results = <R>; - close R; - my $t_total = timediff( new Benchmark, $t_start ); - - if( $opt_v ){ - print "\n"; - print @results - } - - print '# ',timestr( $t_total, 'nop' ), "\n"; -} - - -sub verify { - my $test = shift; - - my $command = $perl.' "-I../lib" "-I./lib/dprof" '.$test; - $command .= ' -v' if $opt_v; - $command .= ' -p '. $perl; - system $command; -} - - -$| = 1; -print "1..18\n"; -while( @tests ){ - $test = shift @tests; - $test =~ s/\.$// if $^O eq 'VMS'; - if( $test =~ /_t$/i ){ - print "# $test" . '.' x (20 - length $test); - profile $test; - } - else{ - verify $test; - } -} - -unlink("tmon.out"); diff --git a/contrib/perl5/t/lib/dprof/V.pm b/contrib/perl5/t/lib/dprof/V.pm deleted file mode 100644 index 152cddc..0000000 --- a/contrib/perl5/t/lib/dprof/V.pm +++ /dev/null @@ -1,63 +0,0 @@ -package V; - -use Getopt::Std 'getopts'; -getopts('vp:d:'); - -require Exporter; -@ISA = 'Exporter'; - -@EXPORT = qw( dprofpp $opt_v $results $expected report @results ); -@EXPORT_OK = qw( notok ok $num ); - -$num = 0; -$results = $expected = ''; -$perl = $opt_p || $^X; -$dpp = $opt_d || '../utils/dprofpp'; -$dpp .= '.com' if $^O eq 'VMS'; - -print "\nperl: $perl\n" if $opt_v; -if( ! -f $perl ){ die "Where's Perl?" } -if( ! -f $dpp ) { - ($dpp = $^X) =~ s@(^.*)[/|\\].*@$1/dprofpp@; - die "Where's dprofpp?" if( ! -f $dpp ); -} - -sub dprofpp { - my $switches = shift; - - open( D, "$perl \"-I../lib\" $dpp \"$switches\" 2> err |" ) || warn "$0: Can't run. $!\n"; - @results = <D>; - close D; - - open( D, "<err" ) || warn "$0: Can't open: $!\n"; - @err = <D>; - close D; - push( @results, @err ) if @err; - - $results = qq{@results}; - # ignore Loader (Dyna/Auto etc), leave newline - $results =~ s/^\w+Loader::import//; - $results =~ s/\n /\n/gm; - $results; -} - -sub report { - $num = shift; - my $sub = shift; - my $x; - - $x = &$sub; - $x ? &ok : ¬ok; -} - -sub ok { - print "ok $num\n"; -} - -sub notok { - print "not ok $num\n"; - print "\nResult\n{$results}\n"; - print "Expected\n{$expected}\n"; -} - -1; diff --git a/contrib/perl5/t/lib/dprof/test1_t b/contrib/perl5/t/lib/dprof/test1_t deleted file mode 100644 index d504cd5..0000000 --- a/contrib/perl5/t/lib/dprof/test1_t +++ /dev/null @@ -1,18 +0,0 @@ -sub foo { - print "in sub foo\n"; - bar(); -} - -sub bar { - print "in sub bar\n"; -} - -sub baz { - print "in sub baz\n"; - bar(); - foo(); -} - -bar(); -baz(); -foo(); diff --git a/contrib/perl5/t/lib/dprof/test1_v b/contrib/perl5/t/lib/dprof/test1_v deleted file mode 100644 index 542a503..0000000 --- a/contrib/perl5/t/lib/dprof/test1_v +++ /dev/null @@ -1,24 +0,0 @@ -# perl - -use V; - -dprofpp( '-T' ); -$expected = -qq{main::bar -main::baz - main::bar - main::foo - main::bar -main::foo - main::bar -}; -report 1, sub { $expected eq $results }; - -dprofpp('-TF'); -report 2, sub { $expected eq $results }; - -dprofpp( '-t' ); -report 3, sub { $expected eq $results }; - -dprofpp('-tF'); -report 4, sub { $expected eq $results }; diff --git a/contrib/perl5/t/lib/dprof/test2_t b/contrib/perl5/t/lib/dprof/test2_t deleted file mode 100644 index edc46c5..0000000 --- a/contrib/perl5/t/lib/dprof/test2_t +++ /dev/null @@ -1,21 +0,0 @@ -sub foo { - print "in sub foo\n"; - bar(); -} - -sub bar { - print "in sub bar\n"; -} - -sub baz { - print "in sub baz\n"; - bar(); - bar(); - bar(); - foo(); -} - -bar(); -bar(); -baz(); -foo(); diff --git a/contrib/perl5/t/lib/dprof/test2_v b/contrib/perl5/t/lib/dprof/test2_v deleted file mode 100644 index 8b775b3..0000000 --- a/contrib/perl5/t/lib/dprof/test2_v +++ /dev/null @@ -1,36 +0,0 @@ -# perl - -use V; - -dprofpp( '-T' ); -$expected = -qq{main::bar -main::bar -main::baz - main::bar - main::bar - main::bar - main::foo - main::bar -main::foo - main::bar -}; -report 5, sub { $expected eq $results }; - -dprofpp('-TF'); -report 6, sub { $expected eq $results }; - -dprofpp( '-t' ); -$expected = -qq{main::bar (2x) -main::baz - main::bar (3x) - main::foo - main::bar -main::foo - main::bar -}; -report 7, sub { $expected eq $results }; - -dprofpp('-tF'); -report 8, sub { $expected eq $results }; diff --git a/contrib/perl5/t/lib/dprof/test3_t b/contrib/perl5/t/lib/dprof/test3_t deleted file mode 100644 index a5327f4..0000000 --- a/contrib/perl5/t/lib/dprof/test3_t +++ /dev/null @@ -1,19 +0,0 @@ -sub foo { - print "in sub foo\n"; - exit(0); - bar(); -} - -sub bar { - print "in sub bar\n"; -} - -sub baz { - print "in sub baz\n"; - bar(); - foo(); -} - -bar(); -baz(); -foo(); diff --git a/contrib/perl5/t/lib/dprof/test3_v b/contrib/perl5/t/lib/dprof/test3_v deleted file mode 100644 index df7543e..0000000 --- a/contrib/perl5/t/lib/dprof/test3_v +++ /dev/null @@ -1,29 +0,0 @@ -# perl - -use V; - -dprofpp( '-T' ); -$e1 = $expected = -qq{main::bar -main::baz - main::bar - main::foo -}; -report 9, sub { $expected eq $results }; - -dprofpp('-TF'); -$e2 = $expected = -qq{main::bar -main::baz - main::bar - main::foo -}; -report 10, sub { $expected eq $results }; - -dprofpp( '-t' ); -$expected = $e1; -report 11, sub { 1 }; - -dprofpp('-tF'); -$expected = $e2; -report 12, sub { $expected eq $results }; diff --git a/contrib/perl5/t/lib/dprof/test4_t b/contrib/perl5/t/lib/dprof/test4_t deleted file mode 100644 index 7299682..0000000 --- a/contrib/perl5/t/lib/dprof/test4_t +++ /dev/null @@ -1,24 +0,0 @@ -sub foo { - print "in sub foo\n"; - bar(); -} - -sub bar { - print "in sub bar\n"; -} - -sub baz { - print "in sub baz\n"; - bar(); - bar(); - bar(); - foo(); -} - -bar(); - -eval { fork }; - -bar(); -baz(); -foo(); diff --git a/contrib/perl5/t/lib/dprof/test4_v b/contrib/perl5/t/lib/dprof/test4_v deleted file mode 100644 index d9677ff..0000000 --- a/contrib/perl5/t/lib/dprof/test4_v +++ /dev/null @@ -1,36 +0,0 @@ -# perl - -use V; - -dprofpp( '-T' ); -$expected = -qq{main::bar -main::bar -main::baz - main::bar - main::bar - main::bar - main::foo - main::bar -main::foo - main::bar -}; -report 13, sub { $expected eq $results }; - -dprofpp('-TF'); -report 14, sub { $expected eq $results }; - -dprofpp( '-t' ); -$expected = -qq{main::bar (2x) -main::baz - main::bar (3x) - main::foo - main::bar -main::foo - main::bar -}; -report 15, sub { $expected eq $results }; - -dprofpp('-tF'); -report 16, sub { $expected eq $results }; diff --git a/contrib/perl5/t/lib/dprof/test5_t b/contrib/perl5/t/lib/dprof/test5_t deleted file mode 100644 index 0b11137..0000000 --- a/contrib/perl5/t/lib/dprof/test5_t +++ /dev/null @@ -1,25 +0,0 @@ -# Test that dprof doesn't break -# &bar; used as &bar(@_); - -sub foo1 { - print "in foo1(@_)\n"; - bar(@_); -} -sub foo2 { - print "in foo2(@_)\n"; - &bar; -} -sub bar { - print "in bar(@_)\n"; - if( @_ > 0 ){ - &yeppers; - } -} -sub yeppers { - print "rest easy\n"; -} - - -&foo1( A ); -&foo2( B ); - diff --git a/contrib/perl5/t/lib/dprof/test5_v b/contrib/perl5/t/lib/dprof/test5_v deleted file mode 100644 index 9e9298c..0000000 --- a/contrib/perl5/t/lib/dprof/test5_v +++ /dev/null @@ -1,15 +0,0 @@ -# perl - -use V; - -dprofpp( '-T' ); -$expected = -qq{main::foo1 - main::bar - main::yeppers -main::foo2 - main::bar - main::yeppers -}; -report 17, sub { $expected eq $results }; - diff --git a/contrib/perl5/t/lib/dprof/test6_t b/contrib/perl5/t/lib/dprof/test6_t deleted file mode 100644 index 7b8bf4a..0000000 --- a/contrib/perl5/t/lib/dprof/test6_t +++ /dev/null @@ -1,29 +0,0 @@ -sub foo { - my $x; - my $y; - print "in sub foo\n"; - for( $x = 1; $x < 100; ++$x ){ - bar(); - for( $y = 1; $y < 100; ++$y ){ - } - } -} - -sub bar { - my $x; - print "in sub bar\n"; - for( $x = 1; $x < 100; ++$x ){ - } - die "bar exiting"; -} - -sub baz { - print "in sub baz\n"; - eval { bar(); }; - eval { foo(); }; -} - -eval { bar(); }; -baz(); -eval { foo(); }; - diff --git a/contrib/perl5/t/lib/dprof/test6_v b/contrib/perl5/t/lib/dprof/test6_v deleted file mode 100644 index 2f651ea..0000000 --- a/contrib/perl5/t/lib/dprof/test6_v +++ /dev/null @@ -1,16 +0,0 @@ -# perl - -use V; - -dprofpp( '-T' ); -$expected = -qq{main::bar -main::baz - main::bar - main::foo - main::bar -main::foo - main::bar -}; -report 18, sub { $expected eq $results }; - diff --git a/contrib/perl5/t/lib/dumper-ovl.t b/contrib/perl5/t/lib/dumper-ovl.t deleted file mode 100755 index d4b3a92..0000000 --- a/contrib/perl5/t/lib/dumper-ovl.t +++ /dev/null @@ -1,35 +0,0 @@ -#!./perl -w - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { - print "1..0 # Skip: Data::Dumper was not built\n"; - exit 0; - } -} - -use Data::Dumper; - -print "1..1\n"; - -package Foo; -use overload '""' => 'as_string'; - -sub new { bless { foo => "bar" }, shift } -sub as_string { "%%%%" } - -package main; - -my $f = Foo->new; - -print "#\$f=$f\n"; - -$_ = Dumper($f); -s/^/#/mg; -print $_; - -print "not " unless /bar/ && /Foo/; -print "ok 1\n"; - diff --git a/contrib/perl5/t/lib/dumper.t b/contrib/perl5/t/lib/dumper.t deleted file mode 100755 index be9732f..0000000 --- a/contrib/perl5/t/lib/dumper.t +++ /dev/null @@ -1,810 +0,0 @@ -#!./perl -w -# -# testsuite for Data::Dumper -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { - print "1..0 # Skip: Data::Dumper was not built\n"; - exit 0; - } -} - -use Data::Dumper; -use Config; -my $Is_ebcdic = defined($Config{'ebcdic'}) && $Config{'ebcdic'} eq 'define'; - -$Data::Dumper::Pad = "#"; -my $TMAX; -my $XS; -my $TNUM = 0; -my $WANT = ''; - -sub TEST { - my $string = shift; - my $t = eval $string; - ++$TNUM; - $t =~ s/([A-Z]+)\(0x[0-9a-f]+\)/$1(0xdeadbeef)/g - if ($WANT =~ /deadbeef/); - if ($Is_ebcdic) { - # these data need massaging with non ascii character sets - # because of hashing order differences - $WANT = join("\n",sort(split(/\n/,$WANT))); - $WANT =~ s/\,$//mg; - $t = join("\n",sort(split(/\n/,$t))); - $t =~ s/\,$//mg; - } - print( ($t eq $WANT and not $@) ? "ok $TNUM\n" - : "not ok $TNUM\n--Expected--\n$WANT\n--Got--\n$@$t\n"); - - ++$TNUM; - eval "$t"; - print $@ ? "not ok $TNUM\n# \$@ says: $@\n" : "ok $TNUM\n"; - - $t = eval $string; - ++$TNUM; - $t =~ s/([A-Z]+)\(0x[0-9a-f]+\)/$1(0xdeadbeef)/g - if ($WANT =~ /deadbeef/); - if ($Is_ebcdic) { - # here too there are hashing order differences - $WANT = join("\n",sort(split(/\n/,$WANT))); - $WANT =~ s/\,$//mg; - $t = join("\n",sort(split(/\n/,$t))); - $t =~ s/\,$//mg; - } - print( ($t eq $WANT and not $@) ? "ok $TNUM\n" - : "not ok $TNUM\n--Expected--\n$WANT\n--Got--\n$@$t\n"); -} - -if (defined &Data::Dumper::Dumpxs) { - print "### XS extension loaded, will run XS tests\n"; - $TMAX = 186; $XS = 1; -} -else { - print "### XS extensions not loaded, will NOT run XS tests\n"; - $TMAX = 93; $XS = 0; -} - -print "1..$TMAX\n"; - -############# -############# - -@c = ('c'); -$c = \@c; -$b = {}; -$a = [1, $b, $c]; -$b->{a} = $a; -$b->{b} = $a->[1]; -$b->{c} = $a->[2]; - -############# 1 -## -$WANT = <<'EOT'; -#$a = [ -# 1, -# { -# 'a' => $a, -# 'b' => $a->[1], -# 'c' => [ -# 'c' -# ] -# }, -# $a->[1]{'c'} -# ]; -#$b = $a->[1]; -#$c = $a->[1]{'c'}; -EOT - -TEST q(Data::Dumper->Dump([$a,$b,$c], [qw(a b c)])); -TEST q(Data::Dumper->Dumpxs([$a,$b,$c], [qw(a b c)])) if $XS; - - -############# 7 -## -$WANT = <<'EOT'; -#@a = ( -# 1, -# { -# 'a' => [], -# 'b' => {}, -# 'c' => [ -# 'c' -# ] -# }, -# [] -# ); -#$a[1]{'a'} = \@a; -#$a[1]{'b'} = $a[1]; -#$a[2] = $a[1]{'c'}; -#$b = $a[1]; -EOT - -$Data::Dumper::Purity = 1; # fill in the holes for eval -TEST q(Data::Dumper->Dump([$a, $b], [qw(*a b)])); # print as @a -TEST q(Data::Dumper->Dumpxs([$a, $b], [qw(*a b)])) if $XS; - -############# 13 -## -$WANT = <<'EOT'; -#%b = ( -# 'a' => [ -# 1, -# {}, -# [ -# 'c' -# ] -# ], -# 'b' => {}, -# 'c' => [] -# ); -#$b{'a'}[1] = \%b; -#$b{'b'} = \%b; -#$b{'c'} = $b{'a'}[2]; -#$a = $b{'a'}; -EOT - -TEST q(Data::Dumper->Dump([$b, $a], [qw(*b a)])); # print as %b -TEST q(Data::Dumper->Dumpxs([$b, $a], [qw(*b a)])) if $XS; - -############# 19 -## -$WANT = <<'EOT'; -#$a = [ -# 1, -# { -# 'a' => [], -# 'b' => {}, -# 'c' => [] -# }, -# [] -#]; -#$a->[1]{'a'} = $a; -#$a->[1]{'b'} = $a->[1]; -#$a->[1]{'c'} = \@c; -#$a->[2] = \@c; -#$b = $a->[1]; -EOT - -$Data::Dumper::Indent = 1; -TEST q( - $d = Data::Dumper->new([$a,$b], [qw(a b)]); - $d->Seen({'*c' => $c}); - $d->Dump; - ); -if ($XS) { - TEST q( - $d = Data::Dumper->new([$a,$b], [qw(a b)]); - $d->Seen({'*c' => $c}); - $d->Dumpxs; - ); -} - - -############# 25 -## -$WANT = <<'EOT'; -#$a = [ -# #0 -# 1, -# #1 -# { -# a => $a, -# b => $a->[1], -# c => [ -# #0 -# 'c' -# ] -# }, -# #2 -# $a->[1]{c} -# ]; -#$b = $a->[1]; -EOT - -$d->Indent(3); -$d->Purity(0)->Quotekeys(0); -TEST q( $d->Reset; $d->Dump ); - -TEST q( $d->Reset; $d->Dumpxs ) if $XS; - -############# 31 -## -$WANT = <<'EOT'; -#$VAR1 = [ -# 1, -# { -# 'a' => [], -# 'b' => {}, -# 'c' => [ -# 'c' -# ] -# }, -# [] -#]; -#$VAR1->[1]{'a'} = $VAR1; -#$VAR1->[1]{'b'} = $VAR1->[1]; -#$VAR1->[2] = $VAR1->[1]{'c'}; -EOT - -TEST q(Dumper($a)); -TEST q(Data::Dumper::DumperX($a)) if $XS; - -############# 37 -## -$WANT = <<'EOT'; -#[ -# 1, -# { -# a => $VAR1, -# b => $VAR1->[1], -# c => [ -# 'c' -# ] -# }, -# $VAR1->[1]{c} -#] -EOT - -{ - local $Data::Dumper::Purity = 0; - local $Data::Dumper::Quotekeys = 0; - local $Data::Dumper::Terse = 1; - TEST q(Dumper($a)); - TEST q(Data::Dumper::DumperX($a)) if $XS; -} - - -############# 43 -## -$WANT = <<'EOT'; -#$VAR1 = { -# "abc\0'\efg" => "mno\0", -# "reftest" => \\1 -#}; -EOT - -$foo = { "abc\000\'\efg" => "mno\000", - "reftest" => \\1, - }; -{ - local $Data::Dumper::Useqq = 1; - TEST q(Dumper($foo)); -} - - $WANT = <<"EOT"; -#\$VAR1 = { -# 'abc\0\\'\efg' => 'mno\0', -# 'reftest' => \\\\1 -#}; -EOT - - { - local $Data::Dumper::Useqq = 1; - TEST q(Data::Dumper::DumperX($foo)) if $XS; # cheat - } - - - -############# -############# - -{ - package main; - use Data::Dumper; - $foo = 5; - @foo = (-10,\*foo); - %foo = (a=>1,b=>\$foo,c=>\@foo); - $foo{d} = \%foo; - $foo[2] = \%foo; - -############# 49 -## - $WANT = <<'EOT'; -#$foo = \*::foo; -#*::foo = \5; -#*::foo = [ -# #0 -# -10, -# #1 -# do{my $o}, -# #2 -# { -# 'a' => 1, -# 'b' => do{my $o}, -# 'c' => [], -# 'd' => {} -# } -# ]; -#*::foo{ARRAY}->[1] = $foo; -#*::foo{ARRAY}->[2]{'b'} = *::foo{SCALAR}; -#*::foo{ARRAY}->[2]{'c'} = *::foo{ARRAY}; -#*::foo{ARRAY}->[2]{'d'} = *::foo{ARRAY}->[2]; -#*::foo = *::foo{ARRAY}->[2]; -#@bar = @{*::foo{ARRAY}}; -#%baz = %{*::foo{ARRAY}->[2]}; -EOT - - $Data::Dumper::Purity = 1; - $Data::Dumper::Indent = 3; - TEST q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])); - TEST q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])) if $XS; - -############# 55 -## - $WANT = <<'EOT'; -#$foo = \*::foo; -#*::foo = \5; -#*::foo = [ -# -10, -# do{my $o}, -# { -# 'a' => 1, -# 'b' => do{my $o}, -# 'c' => [], -# 'd' => {} -# } -#]; -#*::foo{ARRAY}->[1] = $foo; -#*::foo{ARRAY}->[2]{'b'} = *::foo{SCALAR}; -#*::foo{ARRAY}->[2]{'c'} = *::foo{ARRAY}; -#*::foo{ARRAY}->[2]{'d'} = *::foo{ARRAY}->[2]; -#*::foo = *::foo{ARRAY}->[2]; -#$bar = *::foo{ARRAY}; -#$baz = *::foo{ARRAY}->[2]; -EOT - - $Data::Dumper::Indent = 1; - TEST q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])); - TEST q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])) if $XS; - -############# 61 -## - $WANT = <<'EOT'; -#@bar = ( -# -10, -# \*::foo, -# {} -#); -#*::foo = \5; -#*::foo = \@bar; -#*::foo = { -# 'a' => 1, -# 'b' => do{my $o}, -# 'c' => [], -# 'd' => {} -#}; -#*::foo{HASH}->{'b'} = *::foo{SCALAR}; -#*::foo{HASH}->{'c'} = \@bar; -#*::foo{HASH}->{'d'} = *::foo{HASH}; -#$bar[2] = *::foo{HASH}; -#%baz = %{*::foo{HASH}}; -#$foo = $bar[1]; -EOT - - TEST q(Data::Dumper->Dump([\\@foo, \\%foo, \\*foo], ['*bar', '*baz', '*foo'])); - TEST q(Data::Dumper->Dumpxs([\\@foo, \\%foo, \\*foo], ['*bar', '*baz', '*foo'])) if $XS; - -############# 67 -## - $WANT = <<'EOT'; -#$bar = [ -# -10, -# \*::foo, -# {} -#]; -#*::foo = \5; -#*::foo = $bar; -#*::foo = { -# 'a' => 1, -# 'b' => do{my $o}, -# 'c' => [], -# 'd' => {} -#}; -#*::foo{HASH}->{'b'} = *::foo{SCALAR}; -#*::foo{HASH}->{'c'} = $bar; -#*::foo{HASH}->{'d'} = *::foo{HASH}; -#$bar->[2] = *::foo{HASH}; -#$baz = *::foo{HASH}; -#$foo = $bar->[1]; -EOT - - TEST q(Data::Dumper->Dump([\\@foo, \\%foo, \\*foo], ['bar', 'baz', 'foo'])); - TEST q(Data::Dumper->Dumpxs([\\@foo, \\%foo, \\*foo], ['bar', 'baz', 'foo'])) if $XS; - -############# 73 -## - $WANT = <<'EOT'; -#$foo = \*::foo; -#@bar = ( -# -10, -# $foo, -# { -# a => 1, -# b => \5, -# c => \@bar, -# d => $bar[2] -# } -#); -#%baz = %{$bar[2]}; -EOT - - $Data::Dumper::Purity = 0; - $Data::Dumper::Quotekeys = 0; - TEST q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])); - TEST q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])) if $XS; - -############# 79 -## - $WANT = <<'EOT'; -#$foo = \*::foo; -#$bar = [ -# -10, -# $foo, -# { -# a => 1, -# b => \5, -# c => $bar, -# d => $bar->[2] -# } -#]; -#$baz = $bar->[2]; -EOT - - TEST q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])); - TEST q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])) if $XS; - -} - -############# -############# -{ - package main; - @dogs = ( 'Fido', 'Wags' ); - %kennel = ( - First => \$dogs[0], - Second => \$dogs[1], - ); - $dogs[2] = \%kennel; - $mutts = \%kennel; - $mutts = $mutts; # avoid warning - -############# 85 -## - $WANT = <<'EOT'; -#%kennels = ( -# First => \'Fido', -# Second => \'Wags' -#); -#@dogs = ( -# ${$kennels{First}}, -# ${$kennels{Second}}, -# \%kennels -#); -#%mutts = %kennels; -EOT - - TEST q( - $d = Data::Dumper->new([\\%kennel, \\@dogs, $mutts], - [qw(*kennels *dogs *mutts)] ); - $d->Dump; - ); - if ($XS) { - TEST q( - $d = Data::Dumper->new([\\%kennel, \\@dogs, $mutts], - [qw(*kennels *dogs *mutts)] ); - $d->Dumpxs; - ); - } - -############# 91 -## - $WANT = <<'EOT'; -#%kennels = %kennels; -#@dogs = @dogs; -#%mutts = %kennels; -EOT - - TEST q($d->Dump); - TEST q($d->Dumpxs) if $XS; - -############# 97 -## - $WANT = <<'EOT'; -#%kennels = ( -# First => \'Fido', -# Second => \'Wags' -#); -#@dogs = ( -# ${$kennels{First}}, -# ${$kennels{Second}}, -# \%kennels -#); -#%mutts = %kennels; -EOT - - - TEST q($d->Reset; $d->Dump); - if ($XS) { - TEST q($d->Reset; $d->Dumpxs); - } - -############# 103 -## - $WANT = <<'EOT'; -#@dogs = ( -# 'Fido', -# 'Wags', -# { -# First => \$dogs[0], -# Second => \$dogs[1] -# } -#); -#%kennels = %{$dogs[2]}; -#%mutts = %{$dogs[2]}; -EOT - - TEST q( - $d = Data::Dumper->new([\\@dogs, \\%kennel, $mutts], - [qw(*dogs *kennels *mutts)] ); - $d->Dump; - ); - if ($XS) { - TEST q( - $d = Data::Dumper->new([\\@dogs, \\%kennel, $mutts], - [qw(*dogs *kennels *mutts)] ); - $d->Dumpxs; - ); - } - -############# 109 -## - TEST q($d->Reset->Dump); - if ($XS) { - TEST q($d->Reset->Dumpxs); - } - -############# 115 -## - $WANT = <<'EOT'; -#@dogs = ( -# 'Fido', -# 'Wags', -# { -# First => \'Fido', -# Second => \'Wags' -# } -#); -#%kennels = ( -# First => \'Fido', -# Second => \'Wags' -#); -EOT - - TEST q( - $d = Data::Dumper->new( [\@dogs, \%kennel], [qw(*dogs *kennels)] ); - $d->Deepcopy(1)->Dump; - ); - if ($XS) { - TEST q($d->Reset->Dumpxs); - } - -} - -{ - -sub z { print "foo\n" } -$c = [ \&z ]; - -############# 121 -## - $WANT = <<'EOT'; -#$a = $b; -#$c = [ -# $b -#]; -EOT - -TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'b' => \&z})->Dump;); -TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'b' => \&z})->Dumpxs;) - if $XS; - -############# 127 -## - $WANT = <<'EOT'; -#$a = \&b; -#$c = [ -# \&b -#]; -EOT - -TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'*b' => \&z})->Dump;); -TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'*b' => \&z})->Dumpxs;) - if $XS; - -############# 133 -## - $WANT = <<'EOT'; -#*a = \&b; -#@c = ( -# \&b -#); -EOT - -TEST q(Data::Dumper->new([\&z,$c],['*a','*c'])->Seen({'*b' => \&z})->Dump;); -TEST q(Data::Dumper->new([\&z,$c],['*a','*c'])->Seen({'*b' => \&z})->Dumpxs;) - if $XS; - -} - -{ - $a = []; - $a->[1] = \$a->[0]; - -############# 139 -## - $WANT = <<'EOT'; -#@a = ( -# undef, -# do{my $o} -#); -#$a[1] = \$a[0]; -EOT - -TEST q(Data::Dumper->new([$a],['*a'])->Purity(1)->Dump;); -TEST q(Data::Dumper->new([$a],['*a'])->Purity(1)->Dumpxs;) - if $XS; -} - -{ - $a = \\\\\'foo'; - $b = $$$a; - -############# 145 -## - $WANT = <<'EOT'; -#$a = \\\\\'foo'; -#$b = ${${$a}}; -EOT - -TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dump;); -TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dumpxs;) - if $XS; -} - -{ - $a = [{ a => \$b }, { b => undef }]; - $b = [{ c => \$b }, { d => \$a }]; - -############# 151 -## - $WANT = <<'EOT'; -#$a = [ -# { -# a => \[ -# { -# c => do{my $o} -# }, -# { -# d => \[] -# } -# ] -# }, -# { -# b => undef -# } -#]; -#${$a->[0]{a}}->[0]->{c} = $a->[0]{a}; -#${${$a->[0]{a}}->[1]->{d}} = $a; -#$b = ${$a->[0]{a}}; -EOT - -TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dump;); -TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dumpxs;) - if $XS; -} - -{ - $a = [[[[\\\\\'foo']]]]; - $b = $a->[0][0]; - $c = $${$b->[0][0]}; - -############# 157 -## - $WANT = <<'EOT'; -#$a = [ -# [ -# [ -# [ -# \\\\\'foo' -# ] -# ] -# ] -#]; -#$b = $a->[0][0]; -#$c = ${${$a->[0][0][0][0]}}; -EOT - -TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Purity(1)->Dump;); -TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Purity(1)->Dumpxs;) - if $XS; -} - -{ - $f = "pearl"; - $e = [ $f ]; - $d = { 'e' => $e }; - $c = [ $d ]; - $b = { 'c' => $c }; - $a = { 'b' => $b }; - -############# 163 -## - $WANT = <<'EOT'; -#$a = { -# b => { -# c => [ -# { -# e => 'ARRAY(0xdeadbeef)' -# } -# ] -# } -#}; -#$b = $a->{b}; -#$c = $a->{b}{c}; -EOT - -TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(4)->Dump;); -TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(4)->Dumpxs;) - if $XS; - -############# 169 -## - $WANT = <<'EOT'; -#$a = { -# b => 'HASH(0xdeadbeef)' -#}; -#$b = $a->{b}; -#$c = [ -# 'HASH(0xdeadbeef)' -#]; -EOT - -TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(1)->Dump;); -TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(1)->Dumpxs;) - if $XS; -} - -{ - $a = \$a; - $b = [$a]; - -############# 175 -## - $WANT = <<'EOT'; -#$b = [ -# \$b->[0] -#]; -EOT - -TEST q(Data::Dumper->new([$b],['b'])->Purity(0)->Dump;); -TEST q(Data::Dumper->new([$b],['b'])->Purity(0)->Dumpxs;) - if $XS; - -############# 181 -## - $WANT = <<'EOT'; -#$b = [ -# \do{my $o} -#]; -#${$b->[0]} = $b->[0]; -EOT - - -TEST q(Data::Dumper->new([$b],['b'])->Purity(1)->Dump;); -TEST q(Data::Dumper->new([$b],['b'])->Purity(1)->Dumpxs;) - if $XS; -} diff --git a/contrib/perl5/t/lib/english.t b/contrib/perl5/t/lib/english.t deleted file mode 100755 index 0cbbdbf..0000000 --- a/contrib/perl5/t/lib/english.t +++ /dev/null @@ -1,47 +0,0 @@ -#!./perl - -print "1..16\n"; - -BEGIN { @INC = '../lib' } -use English; -use Config; -my $threads = $Config{'use5005threads'} || 0; - -print $PID == $$ ? "ok 1\n" : "not ok 1\n"; - -$_ = 1; -print $ARG == $_ || $threads ? "ok 2\n" : "not ok 2\n"; - -sub foo { - print $ARG[0] == $_[0] || $threads ? "ok 3\n" : "not ok 3\n"; -} -&foo(1); - -if ($threads) { - $_ = "ok 4\nok 5\nok 6\n"; -} else { - $ARG = "ok 4\nok 5\nok 6\n"; -} -/ok 5\n/; -print $PREMATCH, $MATCH, $POSTMATCH; - -$OFS = " "; -$ORS = "\n"; -print 'ok',7; -undef $OUTPUT_FIELD_SEPARATOR; - -if ($threads) { $" = "\n" } else { $LIST_SEPARATOR = "\n" }; -@foo = ("ok 8", "ok 9"); -print "@foo"; -undef $OUTPUT_RECORD_SEPARATOR; - -eval 'NO SUCH FUNCTION'; -print "ok 10\n" if $EVAL_ERROR =~ /method/ || $threads; - -print $UID == $< ? "ok 11\n" : "not ok 11\n"; -print $GID == $( ? "ok 12\n" : "not ok 12\n"; -print $EUID == $> ? "ok 13\n" : "not ok 13\n"; -print $EGID == $) ? "ok 14\n" : "not ok 14\n"; - -print $PROGRAM_NAME eq $0 ? "ok 15\n" : "not ok 15\n"; -print $BASETIME == $^T ? "ok 16\n" : "not ok 16\n"; diff --git a/contrib/perl5/t/lib/env-array.t b/contrib/perl5/t/lib/env-array.t deleted file mode 100755 index c5068fd..0000000 --- a/contrib/perl5/t/lib/env-array.t +++ /dev/null @@ -1,100 +0,0 @@ -#!./perl - -$| = 1; - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -if ($^O eq 'VMS') { - print "1..11\n"; - foreach (1..11) { print "ok $_ # skipped for VMS\n"; } - exit 0; -} - -use Env qw(@FOO); -use vars qw(@BAR); - -sub array_equal -{ - my ($a, $b) = @_; - return 0 unless scalar(@$a) == scalar(@$b); - for my $i (0..scalar(@$a) - 1) { - return 0 unless $a->[$i] eq $b->[$i]; - } - return 1; -} - -sub test -{ - my ($desc, $code) = @_; - - &$code; - - print "# $desc...\n"; - print "# FOO = (", join(", ", @FOO), ")\n"; - print "# BAR = (", join(", ", @BAR), ")\n"; - - if (defined $check) { print "not " unless &$check; } - else { print "not " unless array_equal(\@FOO, \@BAR); } - - print "ok ", ++$i, "\n"; -} - -print "1..11\n"; - -test "Assignment", sub { - @FOO = qw(a B c); - @BAR = qw(a B c); -}; - -test "Storing", sub { - $FOO[1] = 'b'; - $BAR[1] = 'b'; -}; - -test "Truncation", sub { - $#FOO = 0; - $#BAR = 0; -}; - -test "Push", sub { - push @FOO, 'b', 'c'; - push @BAR, 'b', 'c'; -}; - -test "Pop", sub { - pop @FOO; - pop @BAR; -}; - -test "Shift", sub { - shift @FOO; - shift @BAR; -}; - -test "Push", sub { - push @FOO, 'c'; - push @BAR, 'c'; -}; - -test "Unshift", sub { - unshift @FOO, 'a'; - unshift @BAR, 'a'; -}; - -test "Reverse", sub { - @FOO = reverse @FOO; - @BAR = reverse @BAR; -}; - -test "Sort", sub { - @FOO = sort @FOO; - @BAR = sort @BAR; -}; - -test "Splice", sub { - splice @FOO, 1, 1, 'B'; - splice @BAR, 1, 1, 'B'; -}; diff --git a/contrib/perl5/t/lib/env.t b/contrib/perl5/t/lib/env.t deleted file mode 100755 index ff6af2e..0000000 --- a/contrib/perl5/t/lib/env.t +++ /dev/null @@ -1,25 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -BEGIN { - $ENV{FOO} = "foo"; - $ENV{BAR} = "bar"; -} - -use Env qw(FOO $BAR); - -$FOO .= "/bar"; -$BAR .= "/baz"; - -print "1..2\n"; - -print "not " if $FOO ne 'foo/bar'; -print "ok 1\n"; - -print "not " if $BAR ne 'bar/baz'; -print "ok 2\n"; - diff --git a/contrib/perl5/t/lib/errno.t b/contrib/perl5/t/lib/errno.t deleted file mode 100755 index 02f5ce2..0000000 --- a/contrib/perl5/t/lib/errno.t +++ /dev/null @@ -1,54 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - if ($^O eq 'MacOS') { - @INC = qw(: ::lib ::macos:lib); - } else { - @INC = '../lib'; - } - } -} - -use Errno; - -print "1..5\n"; - -print "not " unless @Errno::EXPORT_OK; -print "ok 1\n"; -die unless @Errno::EXPORT_OK; - -$err = $Errno::EXPORT_OK[0]; -$num = &{"Errno::$err"}; - -print "not " unless &{"Errno::$err"} == $num; -print "ok 2\n"; - -$! = $num; -print "not " unless $!{$err}; -print "ok 3\n"; - -$! = 0; -print "not " if $!{$err}; -print "ok 4\n"; - -$s1 = join(",",sort keys(%!)); -$s2 = join(",",sort @Errno::EXPORT_OK); - -if($s1 ne $s2) { - my @s1 = keys(%!); - my @s2 = @Errno::EXPORT_OK; - my(%s1,%s2); - @s1{@s1} = (); - @s2{@s2} = (); - delete @s2{@s1}; - delete @s1{@s2}; - print "# These are only in \%!\n"; - print "# ",join(" ",map { "'$_'" } keys %s1),"\n"; - print "# These are only in \@EXPORT_OK\n"; - print "# ",join(" ",map { "'$_'" } keys %s2),"\n"; - print "not "; -} - -print "ok 5\n"; diff --git a/contrib/perl5/t/lib/fatal.t b/contrib/perl5/t/lib/fatal.t deleted file mode 100755 index f00b876..0000000 --- a/contrib/perl5/t/lib/fatal.t +++ /dev/null @@ -1,36 +0,0 @@ -#!./perl -w - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - print "1..15\n"; -} - -use strict; -use Fatal qw(open close :void opendir); - -my $i = 1; -eval { open FOO, '<lkjqweriuapofukndajsdlfjnvcvn' }; -print "not " unless $@ =~ /^Can't open/; -print "ok $i\n"; ++$i; - -my $foo = 'FOO'; -for ('$foo', "'$foo'", "*$foo", "\\*$foo") { - eval qq{ open $_, '<$0' }; - print "not " if $@; - print "ok $i\n"; ++$i; - - print "not " if $@ or scalar(<$foo>) !~ m|^#!./perl|; - print "ok $i\n"; ++$i; - eval qq{ close FOO }; - print "not " if $@; - print "ok $i\n"; ++$i; -} - -eval { opendir FOO, 'lkjqweriuapofukndajsdlfjnvcvn' }; -print "not " unless $@ =~ /^Can't open/; -print "ok $i\n"; ++$i; - -eval { my $a = opendir FOO, 'lkjqweriuapofukndajsdlfjnvcvn' }; -print "not " if $@ =~ /^Can't open/; -print "ok $i\n"; ++$i; diff --git a/contrib/perl5/t/lib/fields.t b/contrib/perl5/t/lib/fields.t deleted file mode 100755 index a3f591a..0000000 --- a/contrib/perl5/t/lib/fields.t +++ /dev/null @@ -1,172 +0,0 @@ -#!./perl -w - -my $w; - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - $SIG{__WARN__} = sub { - if ($_[0] =~ /^Hides field 'b1' in base class/) { - $w++; - return; - } - print $_[0]; - }; -} - -use strict; -use warnings; -use vars qw($DEBUG); - -package B1; -use fields qw(b1 b2 b3); - -package B2; -use fields '_b1'; -use fields qw(b1 _b2 b2); - -sub new { bless [], shift } - -package D1; -use base 'B1'; -use fields qw(d1 d2 d3); - -package D2; -use base 'B1'; -use fields qw(_d1 _d2); -use fields qw(d1 d2); - -package D3; -use base 'B2'; -use fields qw(b1 d1 _b1 _d1); # hide b1 - -package D4; -use base 'D3'; -use fields qw(_d3 d3); - -package M; -sub m {} - -package D5; -use base qw(M B2); - -package Foo::Bar; -use base 'B1'; - -package Foo::Bar::Baz; -use base 'Foo::Bar'; -use fields qw(foo bar baz); - -# Test repeatability for when modules get reloaded. -package B1; -use fields qw(b1 b2 b3); - -package D3; -use base 'B2'; -use fields qw(b1 d1 _b1 _d1); # hide b1 - -package main; - -sub fstr { - my $h = shift; - my @tmp; - for my $k (sort {$h->{$a} <=> $h->{$b}} keys %$h) { - my $v = $h->{$k}; - push(@tmp, "$k:$v"); - } - my $str = join(",", @tmp); - print "$h => $str\n" if $DEBUG; - $str; -} - -my %expect = ( - B1 => "b1:1,b2:2,b3:3", - B2 => "_b1:1,b1:2,_b2:3,b2:4", - D1 => "b1:1,b2:2,b3:3,d1:4,d2:5,d3:6", - D2 => "b1:1,b2:2,b3:3,_d1:4,_d2:5,d1:6,d2:7", - D3 => "b2:4,b1:5,d1:6,_b1:7,_d1:8", - D4 => "b2:4,b1:5,d1:6,_d3:9,d3:10", - D5 => "b1:2,b2:4", - 'Foo::Bar::Baz' => 'b1:1,b2:2,b3:3,foo:4,bar:5,baz:6', -); - -print "1..", int(keys %expect)+13, "\n"; -my $testno = 0; -while (my($class, $exp) = each %expect) { - no strict 'refs'; - my $fstr = fstr(\%{$class."::FIELDS"}); - print "EXP: $exp\nGOT: $fstr\nnot " unless $fstr eq $exp; - print "ok ", ++$testno, "\n"; -} - -# Did we get the appropriate amount of warnings? -print "not " unless $w == 1; -print "ok ", ++$testno, "\n"; - -# A simple object creation and AVHV attribute access test -my B2 $obj1 = D3->new; -$obj1->{b1} = "B2"; -my D3 $obj2 = $obj1; -$obj2->{b1} = "D3"; - -print "not " unless $obj1->[2] eq "B2" && $obj1->[5] eq "D3"; -print "ok ", ++$testno, "\n"; - -# We should get compile time failures field name typos -eval q(my D3 $obj3 = $obj2; $obj3->{notthere} = ""); -print "not " unless $@ && $@ =~ /^No such pseudo-hash field "notthere"/; -print "ok ", ++$testno, "\n"; - -# Slices -@$obj1{"_b1", "b1"} = (17, 29); -print "not " unless "@$obj1[1,2]" eq "17 29"; -print "ok ", ++$testno, "\n"; -@$obj1[1,2] = (44,28); -print "not " unless "@$obj1{'b1','_b1','b1'}" eq "28 44 28"; -print "ok ", ++$testno, "\n"; - -my $ph = fields::phash(a => 1, b => 2, c => 3); -print "not " unless fstr($ph) eq 'a:1,b:2,c:3'; -print "ok ", ++$testno, "\n"; - -$ph = fields::phash([qw/a b c/], [1, 2, 3]); -print "not " unless fstr($ph) eq 'a:1,b:2,c:3'; -print "ok ", ++$testno, "\n"; - -$ph = fields::phash([qw/a b c/], [1]); -print "not " if exists $ph->{b} or exists $ph->{c} or !exists $ph->{a}; -print "ok ", ++$testno, "\n"; - -eval '$ph = fields::phash("odd")'; -print "not " unless $@ && $@ =~ /^Odd number of/; -print "ok ", ++$testno, "\n"; - -#fields::_dump(); - -# check if fields autovivify -{ - package Foo; - use fields qw(foo bar); - sub new { bless [], $_[0]; } - - package main; - my Foo $a = Foo->new(); - $a->{foo} = ['a', 'ok ' . ++$testno, 'c']; - $a->{bar} = { A => 'ok ' . ++$testno }; - print $a->{foo}[1], "\n"; - print $a->{bar}->{A}, "\n"; -} - -# check if fields autovivify -{ - package Bar; - use fields qw(foo bar); - sub new { return fields::new($_[0]) } - - package main; - my Bar $a = Bar::->new(); - $a->{foo} = ['a', 'ok ' . ++$testno, 'c']; - $a->{bar} = { A => 'ok ' . ++$testno }; - print $a->{foo}[1], "\n"; - print $a->{bar}->{A}, "\n"; -} diff --git a/contrib/perl5/t/lib/filecache.t b/contrib/perl5/t/lib/filecache.t deleted file mode 100755 index a97fdd5..0000000 --- a/contrib/perl5/t/lib/filecache.t +++ /dev/null @@ -1,25 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..1\n"; - -use FileCache; - -# This is really not a complete test as I don't bother to open enough -# files to make real swapping of open filedescriptor happen. - -$path = "foo"; -cacheout $path; - -print $path "\n"; - -close $path; - -print "not " unless -f $path; -print "ok 1\n"; - -unlink $path; diff --git a/contrib/perl5/t/lib/filecopy.t b/contrib/perl5/t/lib/filecopy.t deleted file mode 100755 index 3072c54..0000000 --- a/contrib/perl5/t/lib/filecopy.t +++ /dev/null @@ -1,109 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -$| = 1; - -my @pass = (0,1); -my $tests = 11; -printf "1..%d\n", $tests * scalar(@pass); - -use File::Copy; - -for my $pass (@pass) { - - require File::Copy; - - my $loopconst = $pass*$tests; - - # First we create a file - open(F, ">file-$$") or die; - binmode F; # for DOSISH platforms, because test 3 copies to stdout - printf F "ok %d\n", 3 + $loopconst; - close F; - - copy "file-$$", "copy-$$"; - - open(F, "copy-$$") or die; - $foo = <F>; - close(F); - - print "not " if -s "file-$$" != -s "copy-$$"; - printf "ok %d\n", 1 + $loopconst; - - print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; - printf "ok %d\n", 2+$loopconst; - - binmode STDOUT unless $^O eq 'VMS'; # Copy::copy works in binary mode - copy "copy-$$", \*STDOUT; - unlink "copy-$$" or die "unlink: $!"; - - open(F,"file-$$"); - copy(*F, "copy-$$"); - open(R, "copy-$$") or die "open copy-$$: $!"; $foo = <R>; close(R); - print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; - printf "ok %d\n", 4+$loopconst; - unlink "copy-$$" or die "unlink: $!"; - open(F,"file-$$"); - copy(\*F, "copy-$$"); - close(F) or die "close: $!"; - open(R, "copy-$$") or die; $foo = <R>; close(R) or die "close: $!"; - print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; - printf "ok %d\n", 5+$loopconst; - unlink "copy-$$" or die "unlink: $!"; - - require IO::File; - $fh = IO::File->new(">copy-$$") or die "Cannot open copy-$$:$!"; - binmode $fh or die; - copy("file-$$",$fh); - $fh->close or die "close: $!"; - open(R, "copy-$$") or die; $foo = <R>; close(R); - print "# foo=`$foo'\nnot " unless $foo eq sprintf "ok %d\n", 3+$loopconst; - printf "ok %d\n", 6+$loopconst; - unlink "copy-$$" or die "unlink: $!"; - require FileHandle; - my $fh = FileHandle->new(">copy-$$") or die "Cannot open copy-$$:$!"; - binmode $fh or die; - copy("file-$$",$fh); - $fh->close; - open(R, "copy-$$") or die; $foo = <R>; close(R); - print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; - printf "ok %d\n", 7+$loopconst; - unlink "file-$$" or die "unlink: $!"; - - print "# moved missing file.\nnot " if move("file-$$", "copy-$$"); - print "# target disappeared.\nnot " if not -e "copy-$$"; - printf "ok %d\n", 8+$loopconst; - - move "copy-$$", "file-$$" or print "# move did not succeed.\n"; - print "# not moved: $!\nnot " unless -e "file-$$" and not -e "copy-$$"; - open(R, "file-$$") or die; $foo = <R>; close(R); - print "# foo=`$foo'\nnot " unless $foo eq sprintf "ok %d\n", 3+$loopconst; - printf "ok %d\n", 9+$loopconst; - - copy "file-$$", "lib"; - open(R, "lib/file-$$") or die; $foo = <R>; close(R); - print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; - printf "ok %d\n", 10+$loopconst; - unlink "lib/file-$$" or die "unlink: $!"; - - move "file-$$", "lib"; - open(R, "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R); - print "not " unless $foo eq sprintf("ok %d\n", 3+$loopconst) - and not -e "file-$$";; - printf "ok %d\n", 11+$loopconst; - unlink "lib/file-$$" or die "unlink: $!"; - - # warn sprintf "INC->".$INC{"File/Copy.pm"}; - delete $INC{"File/Copy.pm"}; - -} - - -END { - 1 while unlink "file-$$"; - 1 while unlink "lib/file-$$"; -} diff --git a/contrib/perl5/t/lib/filefind.t b/contrib/perl5/t/lib/filefind.t deleted file mode 100755 index 362c1eb..0000000 --- a/contrib/perl5/t/lib/filefind.t +++ /dev/null @@ -1,197 +0,0 @@ -####!./perl - - -my %Expect; -my $symlink_exists = eval { symlink("",""); 1 }; - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -if ( $symlink_exists ) { print "1..117\n"; } -else { print "1..61\n"; } - -use File::Find; - -find(sub { print "ok 1\n" if $_ eq 'filefind.t'; }, "."); -finddepth(sub { print "ok 2\n" if $_ eq 'filefind.t'; }, "."); - - -my $case = 2; -my $FastFileTests_OK = 0; - -END { - unlink 'fa/fa_ord','fa/fsl','fa/faa/faa_ord', - 'fa/fab/fab_ord','fa/fab/faba/faba_ord','fb/fb_ord','fb/fba/fba_ord'; - rmdir 'fa/faa'; - rmdir 'fa/fab/faba'; - rmdir 'fa/fab'; - rmdir 'fa'; - rmdir 'fb/fba'; - rmdir 'fb'; - chdir '..'; - rmdir 'for_find'; -} - -sub Check($) { - $case++; - if ($_[0]) { print "ok $case\n"; } - else { print "not ok $case\n"; } -} - -sub CheckDie($) { - $case++; - if ($_[0]) { print "ok $case\n"; } - else { print "not ok $case\n $!\n"; exit 0; } -} - -sub touch { - CheckDie( open(my $T,'>',$_[0]) ); -} - -sub MkDir($$) { - CheckDie( mkdir($_[0],$_[1]) ); -} - -sub wanted { - print "# '$_' => 1\n"; - s#\.$## if ($^O eq 'VMS' && $_ ne '.'); - Check( $Expect{$_} ); - if ( $FastFileTests_OK ) { - delete $Expect{$_} - unless ( $Expect_Dir{$_} && ! -d _ ); - } else { - delete $Expect{$_} - unless ( $Expect_Dir{$_} && ! -d $_ ); - } - $File::Find::prune=1 if $_ eq 'faba'; - -} - -sub dn_wanted { - my $n = $File::Find::name; - $n =~ s#\.$## if ($^O eq 'VMS' && $n ne '.'); - print "# '$n' => 1\n"; - my $i = rindex($n,'/'); - my $OK = exists($Expect{$n}); - if ( $OK ) { - $OK= exists($Expect{substr($n,0,$i)}) if $i >= 0; - } - Check($OK); - delete $Expect{$n}; -} - -sub d_wanted { - print "# '$_' => 1\n"; - s#\.$## if ($^O eq 'VMS' && $_ ne '.'); - my $i = rindex($_,'/'); - my $OK = exists($Expect{$_}); - if ( $OK ) { - $OK= exists($Expect{substr($_,0,$i)}) if $i >= 0; - } - Check($OK); - delete $Expect{$_}; -} - -MkDir( 'for_find',0770 ); -CheckDie(chdir(for_find)); -MkDir( 'fa',0770 ); -MkDir( 'fb',0770 ); -touch('fb/fb_ord'); -MkDir( 'fb/fba',0770 ); -touch('fb/fba/fba_ord'); -CheckDie( symlink('../fb','fa/fsl') ) if $symlink_exists; -touch('fa/fa_ord'); - -MkDir( 'fa/faa',0770 ); -touch('fa/faa/faa_ord'); -MkDir( 'fa/fab',0770 ); -touch('fa/fab/fab_ord'); -MkDir( 'fa/fab/faba',0770 ); -touch('fa/fab/faba/faba_ord'); - -%Expect = ('.' => 1, 'fsl' => 1, 'fa_ord' => 1, 'fab' => 1, 'fab_ord' => 1, - 'faba' => 1, 'faa' => 1, 'faa_ord' => 1); -delete $Expect{'fsl'} unless $symlink_exists; -%Expect_Dir = ('fa' => 1, 'faa' => 1, 'fab' => 1, 'faba' => 1, - 'fb' => 1, 'fba' => 1); -delete @Expect_Dir{'fb','fba'} unless $symlink_exists; -File::Find::find( {wanted => \&wanted, },'fa' ); -Check( scalar(keys %Expect) == 0 ); - -%Expect=('fa' => 1, 'fa/fsl' => 1, 'fa/fa_ord' => 1, 'fa/fab' => 1, - 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, - 'fa/fab/faba/faba_ord' => 1, 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); -delete $Expect{'fa/fsl'} unless $symlink_exists; -%Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, - 'fb' => 1, 'fb/fba' => 1); -delete @Expect_Dir{'fb','fb/fba'} unless $symlink_exists; -File::Find::find( {wanted => \&wanted, no_chdir => 1},'fa' ); - -Check( scalar(keys %Expect) == 0 ); - -%Expect=('.' => 1, './fa' => 1, './fa/fsl' => 1, './fa/fa_ord' => 1, './fa/fab' => 1, - './fa/fab/fab_ord' => 1, './fa/fab/faba' => 1, - './fa/fab/faba/faba_ord' => 1, './fa/faa' => 1, './fa/faa/faa_ord' => 1, - './fb' => 1, './fb/fba' => 1, './fb/fba/fba_ord' => 1, './fb/fb_ord' => 1); -delete $Expect{'./fa/fsl'} unless $symlink_exists; -%Expect_Dir = ('./fa' => 1, './fa/faa' => 1, '/fa/fab' => 1, './fa/fab/faba' => 1, - './fb' => 1, './fb/fba' => 1); -delete @Expect_Dir{'./fb','./fb/fba'} unless $symlink_exists; -File::Find::finddepth( {wanted => \&dn_wanted },'.' ); -Check( scalar(keys %Expect) == 0 ); - -%Expect=('.' => 1, './fa' => 1, './fa/fsl' => 1, './fa/fa_ord' => 1, './fa/fab' => 1, - './fa/fab/fab_ord' => 1, './fa/fab/faba' => 1, - './fa/fab/faba/faba_ord' => 1, './fa/faa' => 1, './fa/faa/faa_ord' => 1, - './fb' => 1, './fb/fba' => 1, './fb/fba/fba_ord' => 1, './fb/fb_ord' => 1); -delete $Expect{'./fa/fsl'} unless $symlink_exists; -%Expect_Dir = ('./fa' => 1, './fa/faa' => 1, '/fa/fab' => 1, './fa/fab/faba' => 1, - './fb' => 1, './fb/fba' => 1); -delete @Expect_Dir{'./fb','./fb/fba'} unless $symlink_exists; -File::Find::finddepth( {wanted => \&d_wanted, no_chdir => 1 },'.' ); -Check( scalar(keys %Expect) == 0 ); - -if ( $symlink_exists ) { - $FastFileTests_OK= 1; - %Expect=('.' => 1, 'fa_ord' => 1, 'fsl' => 1, 'fb_ord' => 1, 'fba' => 1, - 'fba_ord' => 1, 'fab' => 1, 'fab_ord' => 1, 'faba' => 1, 'faa' => 1, - 'faa_ord' => 1); - %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, - 'fb' => 1, 'fb/fba' => 1); - - File::Find::find( {wanted => \&wanted, follow_fast => 1},'fa' ); - Check( scalar(keys %Expect) == 0 ); - - %Expect=('fa' => 1, 'fa/fa_ord' => 1, 'fa/fsl' => 1, 'fa/fsl/fb_ord' => 1, - 'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1, - 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1, - 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); - %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, - 'fb' => 1, 'fb/fba' => 1); - File::Find::find( {wanted => \&wanted, follow_fast => 1, no_chdir => 1},'fa' ); - Check( scalar(keys %Expect) == 0 ); - - %Expect=('fa' => 1, 'fa/fa_ord' => 1, 'fa/fsl' => 1, 'fa/fsl/fb_ord' => 1, - 'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1, - 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1, - 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); - %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, - 'fb' => 1, 'fb/fba' => 1); - - File::Find::finddepth( {wanted => \&dn_wanted, follow_fast => 1},'fa' ); - Check( scalar(keys %Expect) == 0 ); - - %Expect=('fa' => 1, 'fa/fa_ord' => 1, 'fa/fsl' => 1, 'fa/fsl/fb_ord' => 1, - 'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1, - 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1, - 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); - %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, - 'fb' => 1, 'fb/fba' => 1); - - File::Find::finddepth( {wanted => \&d_wanted, follow_fast => 1, no_chdir => 1},'fa' ); - Check( scalar(keys %Expect) == 0 ); -} - -print "# of cases: $case\n"; diff --git a/contrib/perl5/t/lib/filefunc.t b/contrib/perl5/t/lib/filefunc.t deleted file mode 100755 index 9268122..0000000 --- a/contrib/perl5/t/lib/filefunc.t +++ /dev/null @@ -1,17 +0,0 @@ -#!./perl - -BEGIN { - $^O = ''; - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..1\n"; - -use File::Spec::Functions; - -if (catfile('a','b','c') eq 'a/b/c') { - print "ok 1\n"; -} else { - print "not ok 1\n"; -} diff --git a/contrib/perl5/t/lib/filehand.t b/contrib/perl5/t/lib/filehand.t deleted file mode 100755 index 0f3e177..0000000 --- a/contrib/perl5/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' || - $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/contrib/perl5/t/lib/filepath.t b/contrib/perl5/t/lib/filepath.t deleted file mode 100755 index 42e0ae9..0000000 --- a/contrib/perl5/t/lib/filepath.t +++ /dev/null @@ -1,28 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use File::Path; -use strict; - -my $count = 0; -use warnings; - -print "1..4\n"; - -# first check for stupid permissions second for full, so we clean up -# behind ourselves -for my $perm (0111,0777) { - mkpath("foo/bar"); - chmod $perm, "foo", "foo/bar"; - - print "not " unless -d "foo" && -d "foo/bar"; - print "ok ", ++$count, "\n"; - - rmtree("foo"); - print "not " if -e "foo"; - print "ok ", ++$count, "\n"; -} diff --git a/contrib/perl5/t/lib/filespec.t b/contrib/perl5/t/lib/filespec.t deleted file mode 100755 index c6d155f..0000000 --- a/contrib/perl5/t/lib/filespec.t +++ /dev/null @@ -1,379 +0,0 @@ -#!./perl - -BEGIN { - $^O = ''; - chdir 't' if -d 't'; - @INC = '../lib'; -} - -# Each element in this array is a single test. Storing them this way makes -# maintenance easy, and should be OK since perl should be pretty functional -# before these tests are run. - -@tests = ( -# Function Expected -[ "Unix->catfile('a','b','c')", 'a/b/c' ], - -[ "Unix->splitpath('file')", ',,file' ], -[ "Unix->splitpath('/d1/d2/d3/')", ',/d1/d2/d3/,' ], -[ "Unix->splitpath('d1/d2/d3/')", ',d1/d2/d3/,' ], -[ "Unix->splitpath('/d1/d2/d3/.')", ',/d1/d2/d3/.,' ], -[ "Unix->splitpath('/d1/d2/d3/..')", ',/d1/d2/d3/..,' ], -[ "Unix->splitpath('/d1/d2/d3/.file')", ',/d1/d2/d3/,.file' ], -[ "Unix->splitpath('d1/d2/d3/file')", ',d1/d2/d3/,file' ], -[ "Unix->splitpath('/../../d1/')", ',/../../d1/,' ], -[ "Unix->splitpath('/././d1/')", ',/././d1/,' ], - -[ "Unix->catpath('','','file')", 'file' ], -[ "Unix->catpath('','/d1/d2/d3/','')", '/d1/d2/d3/' ], -[ "Unix->catpath('','d1/d2/d3/','')", 'd1/d2/d3/' ], -[ "Unix->catpath('','/d1/d2/d3/.','')", '/d1/d2/d3/.' ], -[ "Unix->catpath('','/d1/d2/d3/..','')", '/d1/d2/d3/..' ], -[ "Unix->catpath('','/d1/d2/d3/','.file')", '/d1/d2/d3/.file' ], -[ "Unix->catpath('','d1/d2/d3/','file')", 'd1/d2/d3/file' ], -[ "Unix->catpath('','/../../d1/','')", '/../../d1/' ], -[ "Unix->catpath('','/././d1/','')", '/././d1/' ], -[ "Unix->catpath('d1','d2/d3/','')", 'd2/d3/' ], -[ "Unix->catpath('d1','d2','d3/')", 'd2/d3/' ], - -[ "Unix->splitdir('')", '' ], -[ "Unix->splitdir('/d1/d2/d3/')", ',d1,d2,d3,' ], -[ "Unix->splitdir('d1/d2/d3/')", 'd1,d2,d3,' ], -[ "Unix->splitdir('/d1/d2/d3')", ',d1,d2,d3' ], -[ "Unix->splitdir('d1/d2/d3')", 'd1,d2,d3' ], - -[ "Unix->catdir()", '' ], -[ "Unix->catdir('/')", '/' ], -[ "Unix->catdir('','d1','d2','d3','')", '/d1/d2/d3' ], -[ "Unix->catdir('d1','d2','d3','')", 'd1/d2/d3' ], -[ "Unix->catdir('','d1','d2','d3')", '/d1/d2/d3' ], -[ "Unix->catdir('d1','d2','d3')", 'd1/d2/d3' ], - -[ "Unix->catfile('a','b','c')", 'a/b/c' ], - -[ "Unix->canonpath('')", '' ], -[ "Unix->canonpath('///../../..//./././a//b/.././c/././')", '/a/b/../c' ], -[ "Unix->canonpath('/.')", '/.' ], - -[ "Unix->abs2rel('/t1/t2/t3','/t1/t2/t3')", '' ], -[ "Unix->abs2rel('/t1/t2/t4','/t1/t2/t3')", '../t4' ], -[ "Unix->abs2rel('/t1/t2','/t1/t2/t3')", '..' ], -[ "Unix->abs2rel('/t1/t2/t3/t4','/t1/t2/t3')", 't4' ], -[ "Unix->abs2rel('/t4/t5/t6','/t1/t2/t3')", '../../../t4/t5/t6' ], -#[ "Unix->abs2rel('../t4','/t1/t2/t3')", '../t4' ], -[ "Unix->abs2rel('/','/t1/t2/t3')", '../../..' ], -[ "Unix->abs2rel('///','/t1/t2/t3')", '../../..' ], -[ "Unix->abs2rel('/.','/t1/t2/t3')", '../../../.' ], -[ "Unix->abs2rel('/./','/t1/t2/t3')", '../../..' ], -#[ "Unix->abs2rel('../t4','/t1/t2/t3')", '../t4' ], - -[ "Unix->rel2abs('t4','/t1/t2/t3')", '/t1/t2/t3/t4' ], -[ "Unix->rel2abs('t4/t5','/t1/t2/t3')", '/t1/t2/t3/t4/t5' ], -[ "Unix->rel2abs('.','/t1/t2/t3')", '/t1/t2/t3' ], -[ "Unix->rel2abs('..','/t1/t2/t3')", '/t1/t2/t3/..' ], -[ "Unix->rel2abs('../t4','/t1/t2/t3')", '/t1/t2/t3/../t4' ], -[ "Unix->rel2abs('/t1','/t1/t2/t3')", '/t1' ], - -[ "Win32->splitpath('file')", ',,file' ], -[ "Win32->splitpath('\\d1/d2\\d3/')", ',\\d1/d2\\d3/,' ], -[ "Win32->splitpath('d1/d2\\d3/')", ',d1/d2\\d3/,' ], -[ "Win32->splitpath('\\d1/d2\\d3/.')", ',\\d1/d2\\d3/.,' ], -[ "Win32->splitpath('\\d1/d2\\d3/..')", ',\\d1/d2\\d3/..,' ], -[ "Win32->splitpath('\\d1/d2\\d3/.file')", ',\\d1/d2\\d3/,.file' ], -[ "Win32->splitpath('\\d1/d2\\d3/file')", ',\\d1/d2\\d3/,file' ], -[ "Win32->splitpath('d1/d2\\d3/file')", ',d1/d2\\d3/,file' ], -[ "Win32->splitpath('C:\\d1/d2\\d3/')", 'C:,\\d1/d2\\d3/,' ], -[ "Win32->splitpath('C:d1/d2\\d3/')", 'C:,d1/d2\\d3/,' ], -[ "Win32->splitpath('C:\\d1/d2\\d3/file')", 'C:,\\d1/d2\\d3/,file' ], -[ "Win32->splitpath('C:d1/d2\\d3/file')", 'C:,d1/d2\\d3/,file' ], -[ "Win32->splitpath('C:\\../d2\\d3/file')", 'C:,\\../d2\\d3/,file' ], -[ "Win32->splitpath('C:../d2\\d3/file')", 'C:,../d2\\d3/,file' ], -[ "Win32->splitpath('\\../..\\d1/')", ',\\../..\\d1/,' ], -[ "Win32->splitpath('\\./.\\d1/')", ',\\./.\\d1/,' ], -[ "Win32->splitpath('\\\\node\\share\\d1/d2\\d3/')", '\\\\node\\share,\\d1/d2\\d3/,' ], -[ "Win32->splitpath('\\\\node\\share\\d1/d2\\d3/file')", '\\\\node\\share,\\d1/d2\\d3/,file' ], -[ "Win32->splitpath('\\\\node\\share\\d1/d2\\file')", '\\\\node\\share,\\d1/d2\\,file' ], -[ "Win32->splitpath('file',1)", ',file,' ], -[ "Win32->splitpath('\\d1/d2\\d3/',1)", ',\\d1/d2\\d3/,' ], -[ "Win32->splitpath('d1/d2\\d3/',1)", ',d1/d2\\d3/,' ], -[ "Win32->splitpath('\\\\node\\share\\d1/d2\\d3/',1)", '\\\\node\\share,\\d1/d2\\d3/,' ], - -[ "Win32->catpath('','','file')", 'file' ], -[ "Win32->catpath('','\\d1/d2\\d3/','')", '\\d1/d2\\d3/' ], -[ "Win32->catpath('','d1/d2\\d3/','')", 'd1/d2\\d3/' ], -[ "Win32->catpath('','\\d1/d2\\d3/.','')", '\\d1/d2\\d3/.' ], -[ "Win32->catpath('','\\d1/d2\\d3/..','')", '\\d1/d2\\d3/..' ], -[ "Win32->catpath('','\\d1/d2\\d3/','.file')", '\\d1/d2\\d3/.file' ], -[ "Win32->catpath('','\\d1/d2\\d3/','file')", '\\d1/d2\\d3/file' ], -[ "Win32->catpath('','d1/d2\\d3/','file')", 'd1/d2\\d3/file' ], -[ "Win32->catpath('C:','\\d1/d2\\d3/','')", 'C:\\d1/d2\\d3/' ], -[ "Win32->catpath('C:','d1/d2\\d3/','')", 'C:d1/d2\\d3/' ], -[ "Win32->catpath('C:','\\d1/d2\\d3/','file')", 'C:\\d1/d2\\d3/file' ], -[ "Win32->catpath('C:','d1/d2\\d3/','file')", 'C:d1/d2\\d3/file' ], -[ "Win32->catpath('C:','\\../d2\\d3/','file')", 'C:\\../d2\\d3/file' ], -[ "Win32->catpath('C:','../d2\\d3/','file')", 'C:../d2\\d3/file' ], -[ "Win32->catpath('','\\../..\\d1/','')", '\\../..\\d1/' ], -[ "Win32->catpath('','\\./.\\d1/','')", '\\./.\\d1/' ], -[ "Win32->catpath('\\\\node\\share','\\d1/d2\\d3/','')", '\\\\node\\share\\d1/d2\\d3/' ], -[ "Win32->catpath('\\\\node\\share','\\d1/d2\\d3/','file')", '\\\\node\\share\\d1/d2\\d3/file' ], -[ "Win32->catpath('\\\\node\\share','\\d1/d2\\','file')", '\\\\node\\share\\d1/d2\\file' ], - -[ "Win32->splitdir('')", '' ], -[ "Win32->splitdir('\\d1/d2\\d3/')", ',d1,d2,d3,' ], -[ "Win32->splitdir('d1/d2\\d3/')", 'd1,d2,d3,' ], -[ "Win32->splitdir('\\d1/d2\\d3')", ',d1,d2,d3' ], -[ "Win32->splitdir('d1/d2\\d3')", 'd1,d2,d3' ], - -[ "Win32->catdir()", '' ], -[ "Win32->catdir('')", '\\' ], -[ "Win32->catdir('/')", '\\' ], -[ "Win32->catdir('//d1','d2')", '\\\\d1\\d2' ], -[ "Win32->catdir('','/d1','d2')", '\\\\d1\\d2' ], -[ "Win32->catdir('','','/d1','d2')", '\\\\\\d1\\d2' ], -[ "Win32->catdir('','//d1','d2')", '\\\\\\d1\\d2' ], -[ "Win32->catdir('','','//d1','d2')", '\\\\\\\\d1\\d2' ], -[ "Win32->catdir('','d1','','d2','')", '\\d1\\d2' ], -[ "Win32->catdir('','d1','d2','d3','')", '\\d1\\d2\\d3' ], -[ "Win32->catdir('d1','d2','d3','')", 'd1\\d2\\d3' ], -[ "Win32->catdir('','d1','d2','d3')", '\\d1\\d2\\d3' ], -[ "Win32->catdir('d1','d2','d3')", 'd1\\d2\\d3' ], -[ "Win32->catdir('A:/d1','d2','d3')", 'A:\\d1\\d2\\d3' ], -[ "Win32->catdir('A:/d1','d2','d3','')", 'A:\\d1\\d2\\d3' ], -#[ "Win32->catdir('A:/d1','B:/d2','d3','')", 'A:\\d1\\d2\\d3' ], -[ "Win32->catdir('A:/d1','B:/d2','d3','')", 'A:\\d1\\B:\\d2\\d3' ], -[ "Win32->catdir('A:/')", 'A:\\' ], - -[ "Win32->catfile('a','b','c')", 'a\\b\\c' ], - -[ "Win32->canonpath('')", '' ], -[ "Win32->canonpath('a:')", 'A:' ], -[ "Win32->canonpath('A:f')", 'A:f' ], -[ "Win32->canonpath('//a\\b//c')", '\\\\a\\b\\c' ], -[ "Win32->canonpath('/a/..../c')", '\\a\\....\\c' ], -[ "Win32->canonpath('//a/b\\c')", '\\\\a\\b\\c' ], -[ "Win32->canonpath('////')", '\\\\\\' ], -[ "Win32->canonpath('//')", '\\' ], -[ "Win32->canonpath('/.')", '\\.' ], -[ "Win32->canonpath('//a/b/../../c')", '\\\\a\\b\\..\\..\\c' ], -[ "Win32->canonpath('//a/../../c')", '\\\\a\\..\\..\\c' ], - -[ "Win32->abs2rel('/t1/t2/t3','/t1/t2/t3')", '' ], -[ "Win32->abs2rel('/t1/t2/t4','/t1/t2/t3')", '..\\t4' ], -[ "Win32->abs2rel('/t1/t2','/t1/t2/t3')", '..' ], -[ "Win32->abs2rel('/t1/t2/t3/t4','/t1/t2/t3')", 't4' ], -[ "Win32->abs2rel('/t4/t5/t6','/t1/t2/t3')", '..\\..\\..\\t4\\t5\\t6' ], -#[ "Win32->abs2rel('../t4','/t1/t2/t3')", '\\t1\\t2\\t3\\..\\t4' ], -[ "Win32->abs2rel('/','/t1/t2/t3')", '..\\..\\..' ], -[ "Win32->abs2rel('///','/t1/t2/t3')", '..\\..\\..' ], -[ "Win32->abs2rel('/.','/t1/t2/t3')", '..\\..\\..\\.' ], -[ "Win32->abs2rel('/./','/t1/t2/t3')", '..\\..\\..' ], -[ "Win32->abs2rel('\\\\a/t1/t2/t4','/t2/t3')", '..\\t4' ], -[ "Win32->abs2rel('//a/t1/t2/t4','/t2/t3')", '..\\t4' ], - -[ "Win32->rel2abs('temp','C:/')", 'C:\\temp' ], -[ "Win32->rel2abs('temp','C:/a')", 'C:\\a\\temp' ], -[ "Win32->rel2abs('temp','C:/a/')", 'C:\\a\\temp' ], -[ "Win32->rel2abs('../','C:/')", 'C:\\..' ], -[ "Win32->rel2abs('../','C:/a')", 'C:\\a\\..' ], -[ "Win32->rel2abs('temp','//prague_main/work/')", '\\\\prague_main\\work\\temp' ], -[ "Win32->rel2abs('../temp','//prague_main/work/')", '\\\\prague_main\\work\\..\\temp' ], -[ "Win32->rel2abs('temp','//prague_main/work')", '\\\\prague_main\\work\\temp' ], -[ "Win32->rel2abs('../','//prague_main/work')", '\\\\prague_main\\work\\..' ], - -[ "VMS->splitpath('file')", ',,file' ], -[ "VMS->splitpath('[d1.d2.d3]')", ',[d1.d2.d3],' ], -[ "VMS->splitpath('[.d1.d2.d3]')", ',[.d1.d2.d3],' ], -[ "VMS->splitpath('[d1.d2.d3]file')", ',[d1.d2.d3],file' ], -[ "VMS->splitpath('d1/d2/d3/file')", ',[.d1.d2.d3],file' ], -[ "VMS->splitpath('/d1/d2/d3/file')", 'd1:,[d2.d3],file' ], -[ "VMS->splitpath('[.d1.d2.d3]file')", ',[.d1.d2.d3],file' ], -[ "VMS->splitpath('node::volume:[d1.d2.d3]')", 'node::volume:,[d1.d2.d3],' ], -[ "VMS->splitpath('node::volume:[d1.d2.d3]file')", 'node::volume:,[d1.d2.d3],file' ], -[ "VMS->splitpath('node\"access_spec\"::volume:[d1.d2.d3]')", 'node"access_spec"::volume:,[d1.d2.d3],' ], -[ "VMS->splitpath('node\"access_spec\"::volume:[d1.d2.d3]file')", 'node"access_spec"::volume:,[d1.d2.d3],file' ], - -[ "VMS->catpath('','','file')", 'file' ], -[ "VMS->catpath('','[d1.d2.d3]','')", '[d1.d2.d3]' ], -[ "VMS->catpath('','[.d1.d2.d3]','')", '[.d1.d2.d3]' ], -[ "VMS->catpath('','[d1.d2.d3]','file')", '[d1.d2.d3]file' ], -[ "VMS->catpath('','[.d1.d2.d3]','file')", '[.d1.d2.d3]file' ], -[ "VMS->catpath('','d1/d2/d3','file')", '[.d1.d2.d3]file' ], -[ "VMS->catpath('v','d1/d2/d3','file')", 'v:[.d1.d2.d3]file' ], -[ "VMS->catpath('node::volume:','[d1.d2.d3]','')", 'node::volume:[d1.d2.d3]' ], -[ "VMS->catpath('node::volume:','[d1.d2.d3]','file')", 'node::volume:[d1.d2.d3]file' ], -[ "VMS->catpath('node\"access_spec\"::volume:','[d1.d2.d3]','')", 'node"access_spec"::volume:[d1.d2.d3]' ], -[ "VMS->catpath('node\"access_spec\"::volume:','[d1.d2.d3]','file')", 'node"access_spec"::volume:[d1.d2.d3]file' ], - -[ "VMS->canonpath('')", '' ], -[ "VMS->canonpath('volume:[d1]file')", 'volume:[d1]file' ], -[ "VMS->canonpath('volume:[d1.-.d2.][d3.d4.-]')", 'volume:[d2.d3]' ], -[ "VMS->canonpath('volume:[000000.d1]d2.dir;1')", 'volume:[d1]d2.dir;1' ], - -[ "VMS->splitdir('')", '' ], -[ "VMS->splitdir('[]')", '' ], -[ "VMS->splitdir('d1.d2.d3')", 'd1,d2,d3' ], -[ "VMS->splitdir('[d1.d2.d3]')", 'd1,d2,d3' ], -[ "VMS->splitdir('.d1.d2.d3')", ',d1,d2,d3' ], -[ "VMS->splitdir('[.d1.d2.d3]')", ',d1,d2,d3' ], -[ "VMS->splitdir('.-.d2.d3')", ',-,d2,d3' ], -[ "VMS->splitdir('[.-.d2.d3]')", ',-,d2,d3' ], - -[ "VMS->catdir('')", '' ], -[ "VMS->catdir('d1','d2','d3')", '[.d1.d2.d3]' ], -[ "VMS->catdir('d1','d2/','d3')", '[.d1.d2.d3]' ], -[ "VMS->catdir('','d1','d2','d3')", '[.d1.d2.d3]' ], -[ "VMS->catdir('','-','d2','d3')", '[-.d2.d3]' ], -[ "VMS->catdir('','-','','d3')", '[-.d3]' ], -[ "VMS->catdir('dir.dir','d2.dir','d3.dir')", '[.dir.d2.d3]' ], -[ "VMS->catdir('[.name]')", '[.name]' ], -[ "VMS->catdir('[.name]','[.name]')", '[.name.name]'], - -[ "VMS->abs2rel('node::volume:[t1.t2.t3]','[t1.t2.t3]')", '' ], -[ "VMS->abs2rel('node::volume:[t1.t2.t4]','[t1.t2.t3]')", '[-.t4]' ], -[ "VMS->abs2rel('[t1.t2.t3]','[t1.t2.t3]')", '' ], -[ "VMS->abs2rel('[t1.t2.t3]file','[t1.t2.t3]')", 'file' ], -[ "VMS->abs2rel('[t1.t2.t4]','[t1.t2.t3]')", '[-.t4]' ], -[ "VMS->abs2rel('[t1.t2]file','[t1.t2.t3]')", '[-]file' ], -[ "VMS->abs2rel('[t1.t2.t3.t4]','[t1.t2.t3]')", '[t4]' ], -[ "VMS->abs2rel('[t4.t5.t6]','[t1.t2.t3]')", '[---.t4.t5.t6]' ], -[ "VMS->abs2rel('[000000]','[t1.t2.t3]')", '[---.000000]' ], -[ "VMS->abs2rel('a:[t1.t2.t4]','[t1.t2.t3]')", '[-.t4]' ], -[ "VMS->abs2rel('[a.-.b.c.-]','[t1.t2.t3]')", '[---.b]' ], - -[ "VMS->rel2abs('[.t4]','[t1.t2.t3]')", '[t1.t2.t3.t4]' ], -[ "VMS->rel2abs('[.t4.t5]','[t1.t2.t3]')", '[t1.t2.t3.t4.t5]' ], -[ "VMS->rel2abs('[]','[t1.t2.t3]')", '[t1.t2.t3]' ], -[ "VMS->rel2abs('[-]','[t1.t2.t3]')", '[t1.t2]' ], -[ "VMS->rel2abs('[-.t4]','[t1.t2.t3]')", '[t1.t2.t4]' ], -[ "VMS->rel2abs('[t1]','[t1.t2.t3]')", '[t1]' ], - -[ "OS2->catdir('A:/d1','B:/d2','d3','')", 'A:/d1/B:/d2/d3' ], -[ "OS2->catfile('a','b','c')", 'a/b/c' ], - -[ "Mac->splitpath('file')", ',,file' ], -[ "Mac->splitpath(':file')", ',:,file' ], -[ "Mac->splitpath(':d1',1)", ',:d1:,' ], -[ "Mac->splitpath('d1',1)", 'd1:,,' ], -[ "Mac->splitpath('d1:d2:d3:')", 'd1:,d2:d3:,' ], -[ "Mac->splitpath('d1:d2:d3',1)", 'd1:,d2:d3:,' ], -[ "Mac->splitpath(':d1:d2:d3:')", ',:d1:d2:d3:,' ], -[ "Mac->splitpath(':d1:d2:d3:',1)", ',:d1:d2:d3:,' ], -[ "Mac->splitpath('d1:d2:d3:file')", 'd1:,d2:d3:,file' ], -[ "Mac->splitpath('d1:d2:d3',1)", 'd1:,d2:d3:,' ], - -[ "Mac->catdir('')", ':' ], -[ "Mac->catdir('d1','d2','d3')", 'd1:d2:d3:' ], -[ "Mac->catdir('d1','d2/','d3')", 'd1:d2/:d3:' ], -[ "Mac->catdir('','d1','d2','d3')", ':d1:d2:d3:' ], -[ "Mac->catdir('','','d2','d3')", '::d2:d3:' ], -[ "Mac->catdir('','','','d3')", ':::d3:' ], -[ "Mac->catdir(':name')", ':name:' ], -[ "Mac->catdir(':name',':name')", ':name:name:' ], - -[ "Mac->catfile('a','b','c')", 'a:b:c' ], - -[ "Mac->canonpath('')", '' ], -[ "Mac->canonpath(':')", ':' ], -[ "Mac->canonpath('::')", '::' ], -[ "Mac->canonpath('a::')", 'a::' ], -[ "Mac->canonpath(':a::')", ':a::' ], - -[ "Mac->abs2rel('t1:t2:t3','t1:t2:t3')", ':' ], -[ "Mac->abs2rel('t1:t2','t1:t2:t3')", '::' ], -[ "Mac->abs2rel('t1:t4','t1:t2:t3')", ':::t4' ], -[ "Mac->abs2rel('t1:t2:t4','t1:t2:t3')", '::t4' ], -[ "Mac->abs2rel('t1:t2:t3:t4','t1:t2:t3')", ':t4' ], -[ "Mac->abs2rel('t4:t5:t6','t1:t2:t3')", '::::t4:t5:t6' ], -[ "Mac->abs2rel('t1','t1:t2:t3')", ':::' ], - -[ "Mac->rel2abs(':t4','t1:t2:t3')", 't1:t2:t3:t4' ], -[ "Mac->rel2abs(':t4:t5','t1:t2:t3')", 't1:t2:t3:t4:t5' ], -[ "Mac->rel2abs('','t1:t2:t3')", '' ], -[ "Mac->rel2abs('::','t1:t2:t3')", 't1:t2:t3::' ], -[ "Mac->rel2abs('::t4','t1:t2:t3')", 't1:t2:t3::t4' ], -[ "Mac->rel2abs('t1','t1:t2:t3')", 't1' ], -) ; - -# Grab all of the plain routines from File::Spec -use File::Spec @File::Spec::EXPORT_OK ; - -require File::Spec::Unix ; -require File::Spec::Win32 ; - -eval { - require VMS::Filespec ; -} ; - -my $skip_exception = "Install VMS::Filespec (from vms/ext)" ; - -if ( $@ ) { - # Not pretty, but it allows testing of things not implemented soley - # on VMS. It might be better to change File::Spec::VMS to do this, - # making it more usable when running on (say) Unix but working with - # VMS paths. - eval qq- - sub File::Spec::VMS::vmsify { die "$skip_exception" } - sub File::Spec::VMS::unixify { die "$skip_exception" } - sub File::Spec::VMS::vmspath { die "$skip_exception" } - - ; - $INC{"VMS/Filespec.pm"} = 1 ; -} -require File::Spec::VMS ; - -require File::Spec::OS2 ; -require File::Spec::Mac ; - -print "1..", scalar( @tests ), "\n" ; - -my $current_test= 1 ; - -# Test out the class methods -for ( @tests ) { - tryfunc( @$_ ) ; -} - - - -# -# Tries a named function with the given args and compares the result against -# an expected result. Works with functions that return scalars or arrays. -# -sub tryfunc { - my $function = shift ; - my $expected = shift ; - my $platform = shift ; - - if ($platform && $^O ne $platform) { - print "ok $current_test # skipped: $function\n" ; - ++$current_test ; - return; - } - - $function =~ s#\\#\\\\#g ; - - my $got ; - if ( $function =~ /^[^\$].*->/ ) { - $got = eval( "join( ',', File::Spec::$function )" ) ; - } - else { - $got = eval( "join( ',', $function )" ) ; - } - - if ( $@ ) { - if ( substr( $@, 0, length $skip_exception ) eq $skip_exception ) { - chomp $@ ; - print "ok $current_test # skip $function: $@\n" ; - } - else { - chomp $@ ; - print "not ok $current_test # $function: $@\n" ; - } - } - elsif ( !defined( $got ) || $got ne $expected ) { - print "not ok $current_test # $function: got '$got', expected '$expected'\n" ; - } - else { - print "ok $current_test # $function\n" ; - } - ++$current_test ; -} diff --git a/contrib/perl5/t/lib/findbin.t b/contrib/perl5/t/lib/findbin.t deleted file mode 100755 index 3e742f9..0000000 --- a/contrib/perl5/t/lib/findbin.t +++ /dev/null @@ -1,13 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..1\n"; - -use FindBin qw($Bin); - -print "not " unless $Bin =~ m,t[/.]lib\]?$,; -print "ok 1\n"; diff --git a/contrib/perl5/t/lib/ftmp-mktemp.t b/contrib/perl5/t/lib/ftmp-mktemp.t deleted file mode 100755 index b0a7872..0000000 --- a/contrib/perl5/t/lib/ftmp-mktemp.t +++ /dev/null @@ -1,114 +0,0 @@ -#!/usr/bin/perl -w - -# Test for mktemp family of commands in File::Temp -# Use STANDARD safe level for these tests - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Test; import Test; - plan(tests => 9); -} - -use strict; - -use File::Spec; -use File::Path; -use File::Temp qw/ :mktemp unlink0 /; - -ok(1); - -# MKSTEMP - test - -# Create file in temp directory -my $template = File::Spec->catfile(File::Spec->tmpdir, 'wowserXXXX'); - -(my $fh, $template) = mkstemp($template); - -print "# MKSTEMP: FH is $fh File is $template fileno=".fileno($fh)."\n"; -# Check if the file exists -ok( (-e $template) ); - -# Autoflush -$fh->autoflush(1) if $] >= 5.006; - -# Try printing something to the file -my $string = "woohoo\n"; -print $fh $string; - -# rewind the file -ok(seek( $fh, 0, 0)); - -# Read from the file -my $line = <$fh>; - -# compare with previous string -ok($string, $line); - -# Tidy up -# This test fails on Windows NT since it seems that the size returned by -# stat(filehandle) does not always equal the size of the stat(filename) -# This must be due to caching. In particular this test writes 7 bytes -# to the file which are not recognised by stat(filename) -# Simply waiting 3 seconds seems to be enough for the system to update - -if ($^O eq 'MSWin32') { - sleep 3; -} -my $status = unlink0($fh, $template); -if ($status) { - ok( $status ); -} else { - skip("Skip test failed probably due to \$TMPDIR being on NFS",1); -} - -# MKSTEMPS -# File with suffix. This is created in the current directory so -# may be problematic on NFS - -$template = "suffixXXXXXX"; -my $suffix = ".dat"; - -($fh, my $fname) = mkstemps($template, $suffix); - -print "# MKSTEMPS: File is $template -> $fname fileno=".fileno($fh)."\n"; -# Check if the file exists -ok( (-e $fname) ); - -# This fails if you are running on NFS -# If this test fails simply skip it rather than doing a hard failure -$status = unlink0($fh, $fname); - -if ($status) { - ok($status); -} else { - skip("Skip test failed probably due to cwd being on NFS",1) -} - -# MKDTEMP -# Temp directory - -$template = File::Spec->catdir(File::Spec->tmpdir, 'tmpdirXXXXXX'); - -my $tmpdir = mkdtemp($template); - -print "# MKDTEMP: Name is $tmpdir from template $template\n"; - -ok( (-d $tmpdir ) ); - -# Need to tidy up after myself -rmtree($tmpdir); - -# MKTEMP -# Just a filename, not opened - -$template = File::Spec->catfile(File::Spec->tmpdir, 'mytestXXXXXX'); - -my $tmpfile = mktemp($template); - -print "# MKTEMP: Tempfile is $template -> $tmpfile\n"; - -# Okay if template no longer has XXXXX in - - -ok( ($tmpfile !~ /XXXXX$/) ); diff --git a/contrib/perl5/t/lib/ftmp-posix.t b/contrib/perl5/t/lib/ftmp-posix.t deleted file mode 100755 index 79496d8..0000000 --- a/contrib/perl5/t/lib/ftmp-posix.t +++ /dev/null @@ -1,81 +0,0 @@ -#!/usr/bin/perl -w -# Test for File::Temp - POSIX functions - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Test; import Test; - plan(tests => 7); -} - -use strict; - -use File::Temp qw/ :POSIX unlink0 /; -ok(1); - -# TMPNAM - scalar - -print "# TMPNAM: in a scalar context: \n"; -my $tmpnam = tmpnam(); - -# simply check that the file does not exist -# Not a 100% water tight test though if another program -# has managed to create one in the meantime. -ok( !(-e $tmpnam )); - -print "# TMPNAM file name: $tmpnam\n"; - -# TMPNAM list context -# Not strict posix behaviour -(my $fh, $tmpnam) = tmpnam(); - -print "# TMPNAM: in list context: $fh $tmpnam\n"; - -# File is opened - make sure it exists -ok( (-e $tmpnam )); - -# Unlink it - a possible NFS issue again if TMPDIR is not a local disk -my $status = unlink0($fh, $tmpnam); -if ($status) { - ok( $status ); -} else { - skip("Skip test failed probably due to \$TMPDIR being on NFS",1); -} - -# TMPFILE - -$fh = tmpfile(); - -if (defined $fh) { - ok( $fh ); - print "# TMPFILE: tmpfile got FH $fh\n"; - - $fh->autoflush(1) if $] >= 5.006; - - # print something to it - my $original = "Hello a test\n"; - print "# TMPFILE: Wrote line: $original"; - print $fh $original - or die "Error printing to tempfile\n"; - - # rewind it - ok( seek($fh,0,0) ); - - # Read from it - my $line = <$fh>; - - print "# TMPFILE: Read line: $line"; - ok( $original, $line); - - close($fh); - -} else { - # Skip all the remaining tests - foreach (1..3) { - skip("Skip test failed probably due to \$TMPDIR being on NFS",1); - } -} - - - - diff --git a/contrib/perl5/t/lib/ftmp-security.t b/contrib/perl5/t/lib/ftmp-security.t deleted file mode 100755 index 96b2c42..0000000 --- a/contrib/perl5/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 '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/contrib/perl5/t/lib/ftmp-tempfile.t b/contrib/perl5/t/lib/ftmp-tempfile.t deleted file mode 100755 index ed59765..0000000 --- a/contrib/perl5/t/lib/ftmp-tempfile.t +++ /dev/null @@ -1,145 +0,0 @@ -#!/usr/local/bin/perl -w -# Test for File::Temp - tempfile function - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Test; import Test; - plan(tests => 20); -} - -use strict; -use File::Spec; - -# Will need to check that all files were unlinked correctly -# Set up an END block here to do it - -# Arrays containing list of dirs/files to test -my (@files, @dirs, @still_there); - -# And a test for files that should still be around -# These are tidied up -END { - foreach (@still_there) { - ok( -f $_ ); - ok( unlink( $_ ) ); - ok( !(-f $_) ); - } -} - -# Loop over an array hoping that the files dont exist -END { foreach (@files) { ok( !(-e $_) )} } - -# And a test for directories -END { foreach (@dirs) { ok( !(-d $_) )} } - -# Need to make sure that the END blocks are setup before -# the ones that File::Temp configures since END blocks are evaluated -# in revers order and we need to check the files *after* File::Temp -# removes them -use File::Temp qw/ tempfile tempdir/; - -# Now we start the tests properly -ok(1); - - -# Tempfile -# Open tempfile in some directory, unlink at end -my ($fh, $tempfile) = tempfile( - UNLINK => 1, - SUFFIX => '.txt', - ); - -ok( (-f $tempfile) ); -# Should still be around after closing -ok( close( $fh ) ); -ok( (-f $tempfile) ); -# Check again at exit -push(@files, $tempfile); - -# TEMPDIR test -# Create temp directory in current dir -my $template = 'tmpdirXXXXXX'; -print "# Template: $template\n"; -my $tempdir = tempdir( $template , - DIR => File::Spec->curdir, - CLEANUP => 1, - ); - -print "# TEMPDIR: $tempdir\n"; - -ok( (-d $tempdir) ); -push(@dirs, $tempdir); - -# Create file in the temp dir -($fh, $tempfile) = tempfile( - DIR => $tempdir, - UNLINK => 1, - SUFFIX => '.dat', - ); - -print "# TEMPFILE: Created $tempfile\n"; - -ok( (-f $tempfile)); -push(@files, $tempfile); - -# Test tempfile -# ..and again -($fh, $tempfile) = tempfile( - DIR => $tempdir, - ); - - -ok( (-f $tempfile )); -push(@files, $tempfile); - -print "# TEMPFILE: Created $tempfile\n"; - -# and another (with template) - -($fh, $tempfile) = tempfile( 'helloXXXXXXX', - DIR => $tempdir, - UNLINK => 1, - SUFFIX => '.dat', - ); - -print "# TEMPFILE: Created $tempfile\n"; - -ok( (-f $tempfile) ); -push(@files, $tempfile); - - -# Create a temporary file that should stay around after -# it has been closed -($fh, $tempfile) = tempfile( 'permXXXXXXX', UNLINK => 0 ); -print "# TEMPFILE: Created $tempfile\n"; -ok( -f $tempfile ); -ok( close( $fh ) ); -push( @still_there, $tempfile); # check at END - -# Would like to create a temp file and just retrieve the handle -# but the test is problematic since: -# - We dont know the filename so we cant check that it is tidied -# correctly -# - The unlink0 required on unix for tempfile creation will fail -# on NFS -# Try to do what we can. -# Tempfile croaks on error so we need an eval -$fh = eval { tempfile( 'ftmpXXXXX', DIR => File::Spec->tmpdir ) }; - -if ($fh) { - - # print something to it to make sure something is there - ok( print $fh "Test\n" ); - - # Close it - can not check it is gone since we dont know the name - ok( close($fh) ); - -} else { - skip "Skip Failed probably due to NFS", 1; - skip "Skip Failed probably due to NFS", 1; -} - -# Now END block will execute to test the removal of directories -print "# End of tests. Execute END blocks\n"; - diff --git a/contrib/perl5/t/lib/gdbm.t b/contrib/perl5/t/lib/gdbm.t deleted file mode 100755 index ecbd662..0000000 --- a/contrib/perl5/t/lib/gdbm.t +++ /dev/null @@ -1,426 +0,0 @@ -#!./perl - -# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ - -BEGIN { - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bGDBM_File\b/) { - print "1..0 # Skip: GDBM_File was not built\n"; - exit 0; - } -} - -use strict; -use warnings; - - -use GDBM_File; - -print "1..68\n"; - -unlink <Op.dbmx*>; - -umask(0); -my %h ; -print (tie(%h,'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640) ? "ok 1\n" : "not ok 1\n"); - -my $Dfile = "Op.dbmx.pag"; -if (! -e $Dfile) { - ($Dfile) = <Op.dbmx*>; -} -if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos') { - 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/contrib/perl5/t/lib/getopt.t b/contrib/perl5/t/lib/getopt.t deleted file mode 100755 index fb70f10..0000000 --- a/contrib/perl5/t/lib/getopt.t +++ /dev/null @@ -1,73 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..11\n"; - -use Getopt::Std; - -# First we test the getopt function -@ARGV = qw(-xo -f foo -y file); -getopt('f'); - -print "not " if "@ARGV" ne 'file'; -print "ok 1\n"; - -print "not " unless $opt_x && $opt_o && opt_y; -print "ok 2\n"; - -print "not " unless $opt_f eq 'foo'; -print "ok 3\n"; - - -# Then we try the getopts -$opt_o = $opt_i = $opt_f = undef; -@ARGV = qw(-foi -i file); -getopts('oif:') or print "not "; -print "ok 4\n"; - -print "not " unless "@ARGV" eq 'file'; -print "ok 5\n"; - -print "not " unless $opt_i and $opt_f eq 'oi'; -print "ok 6\n"; - -print "not " if $opt_o; -print "ok 7\n"; - -# Try illegal options, but avoid printing of the error message - -open(STDERR, ">stderr") || die; - -@ARGV = qw(-h help); - -!getopts("xf:y") or print "not "; -print "ok 8\n"; - - -# Then try the Getopt::Long module - -use Getopt::Long; - -@ARGV = qw(--help --file foo --foo --nobar --num=5 -- file); - -GetOptions( - 'help' => \$HELP, - 'file:s' => \$FILE, - 'foo!' => \$FOO, - 'bar!' => \$BAR, - 'num:i' => \$NO, -) || print "not "; -print "ok 9\n"; - -print "not " unless $HELP && $FOO && !$BAR && $FILE eq 'foo' && $NO == 5; -print "ok 10\n"; - -print "not " unless "@ARGV" eq "file"; -print "ok 11\n"; - -close STDERR; -unlink "stderr"; diff --git a/contrib/perl5/t/lib/glob-basic.t b/contrib/perl5/t/lib/glob-basic.t deleted file mode 100755 index a014bfd..0000000 --- a/contrib/perl5/t/lib/glob-basic.t +++ /dev/null @@ -1,129 +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..9\n"; -} -END { - print "not ok 1\n" unless $loaded; -} -use File::Glob ':glob'; -use Cwd (); -$loaded = 1; -print "ok 1\n"; - -sub array { - return '(', join(", ", map {defined $_ ? "\"$_\"" : "undef"} @a), ")\n"; -} - -# look for the contents of the current directory -$ENV{PATH} = "/bin"; -delete @ENV{BASH_ENV, CDPATH, ENV, IFS}; -@correct = (); -if (opendir(D, $^O eq "MacOS" ? ":" : ".")) { - @correct = grep { !/^\./ } sort readdir(D); - closedir D; -} -@a = File::Glob::glob("*", 0); -@a = sort @a; -if ("@a" ne "@correct" || GLOB_ERROR) { - print "# |@a| ne |@correct|\nnot "; -} -print "ok 2\n"; - -# look up the user's home directory -# should return a list with one item, and not set ERROR -if ($^O ne 'MSWin32' && $^O ne 'VMS') { - eval { - ($name, $home) = (getpwuid($>))[0,7]; - 1; - } and do { - @a = bsd_glob("~$name", GLOB_TILDE); - if (scalar(@a) != 1 || $a[0] ne $home || GLOB_ERROR) { - print "not "; - } - }; -} -print "ok 3\n"; - -# check backslashing -# should return a list with one item, and not set ERROR -@a = bsd_glob('TEST', GLOB_QUOTE); -if (scalar @a != 1 || $a[0] ne 'TEST' || GLOB_ERROR) { - local $/ = "]["; - print "# [@a]\n"; - print "not "; -} -print "ok 4\n"; - -# check nonexistent checks -# should return an empty list -# XXX since errfunc is NULL on win32, this test is not valid there -@a = bsd_glob("asdfasdf", 0); -if ($^O ne 'MSWin32' and scalar @a != 0) { - print "# |@a|\nnot "; -} -print "ok 5\n"; - -# check bad protections -# should return an empty list, and set ERROR -if ($^O eq 'mpeix' or $^O eq 'MSWin32' or $^O eq 'os2' or $^O eq 'VMS' - or $^O eq 'cygwin' or Cwd::cwd() =~ m#^/afs#s or not $>) -{ - print "ok 6 # skipped\n"; -} -else { - $dir = "PtEeRsLt.dir"; - mkdir $dir, 0; - @a = 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 temp -# and RCS files. Filter them out, and .pm files too. -@a = grep !/(,v$|~$|\.pm$)/, @a; - -unless (@a == 3 - and $a[0] eq ($^O eq 'VMS'? 'test.' : 'TEST') - and $a[1] eq 'a' - and $a[2] eq 'b') -{ - print "not "; -} -print "ok 8\n"; - -# "~" should expand to $ENV{HOME} -$ENV{HOME} = "sweet home"; -@a = bsd_glob('~', GLOB_TILDE | GLOB_NOMAGIC); -unless ($^O eq "MacOS" || (@a == 1 and $a[0] eq $ENV{HOME})) { - print "not "; -} -print "ok 9\n"; diff --git a/contrib/perl5/t/lib/glob-case.t b/contrib/perl5/t/lib/glob-case.t deleted file mode 100755 index 881470c..0000000 --- a/contrib/perl5/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') { - 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/contrib/perl5/t/lib/glob-global.t b/contrib/perl5/t/lib/glob-global.t deleted file mode 100755 index 1d79032..0000000 --- a/contrib/perl5/t/lib/glob-global.t +++ /dev/null @@ -1,152 +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..10\n"; -} -END { - print "not ok 1\n" unless $loaded; -} - -BEGIN { - *CORE::GLOBAL::glob = sub { "Just another Perl hacker," }; -} - -BEGIN { - if ("Just another Perl hacker," ne (<*>)[0]) { - die <<EOMessage; -Your version of perl ($]) doesn't seem to allow extensions to override -the core glob operator. -EOMessage - } -} - -use File::Glob ':globally'; -$loaded = 1; -print "ok 1\n"; - -$_ = $^O eq "MacOS" ? ":lib:*.t" : "lib/*.t"; -my @r = glob; -print "not " if $_ ne ($^O eq "MacOS" ? ":lib:*.t" : "lib/*.t"); -print "ok 2\n"; - -# we should have at least basic.t, global.t, taint.t -print "# |@r|\nnot " if @r < 3; -print "ok 3\n"; - -# check if <*/*> works -if ($^O eq "MacOS") { - @r = <:*:*.t>; -} else { - @r = <*/*.t>; -} -# at least t/global.t t/basic.t, t/taint.t -print "not " if @r < 3; -print "ok 4\n"; -my $r = scalar @r; - -# check if scalar context works -@r = (); -if ($^O eq "MacOS") { - while (defined($_ = <:*:*.t>)) { - #print "# $_\n"; - push @r, $_; - } -} else { - while (defined($_ = <*/*.t>)) { - #print "# $_\n"; - push @r, $_; - } -} -print "not " if @r != $r; -print "ok 5\n"; - -# check if list context works -@r = (); -if ($^O eq "MacOS") { - for (<:*:*.t>) { - #print "# $_\n"; - push @r, $_; - } -} else { - for (<*/*.t>) { - #print "# $_\n"; - push @r, $_; - } -} -print "not " if @r != $r; -print "ok 6\n"; - -# test if implicit assign to $_ in while() works -@r = (); -if ($^O eq "MacOS") { - while (<:*:*.t>) { - #print "# $_\n"; - push @r, $_; - } -} else { - while (<*/*.t>) { - #print "# $_\n"; - push @r, $_; - } -} -print "not " if @r != $r; -print "ok 7\n"; - -# test if explicit glob() gets assign magic too -my @s = (); -while (glob($^O eq 'MacOS' ? ':*:*.t' : '*/*.t')) { - #print "# $_\n"; - push @s, $_; -} -print "not " if "@r" ne "@s"; -print "ok 8\n"; - -# how about in a different package, like? -package Foo; -use File::Glob ':globally'; -@s = (); -while (glob($^O eq 'MacOS' ? ':*:*.t' : '*/*.t')) { - #print "# $_\n"; - push @s, $_; -} -print "not " if "@r" ne "@s"; -print "ok 9\n"; - -# test if different glob ops maintain independent contexts -@s = (); -my $i = 0; -if ($^O eq "MacOS") { - while (<:*:*.t>) { - #print "# $_ <"; - push @s, $_; - while (<:bas*:*.t>) { - #print " $_"; - $i++; - } - #print " >\n"; - } -} else { - while (<*/*.t>) { - #print "# $_ <"; - push @s, $_; - while (<bas*/*.t>) { - #print " $_"; - $i++; - } - #print " >\n"; - } -} -print "not " if "@r" ne "@s" or not $i; -print "ok 10\n"; diff --git a/contrib/perl5/t/lib/glob-taint.t b/contrib/perl5/t/lib/glob-taint.t deleted file mode 100755 index 4c09903..0000000 --- a/contrib/perl5/t/lib/glob-taint.t +++ /dev/null @@ -1,31 +0,0 @@ -#!./perl -T - -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..2\n"; -} -END { - print "not ok 1\n" unless $loaded; -} -use File::Glob; -$loaded = 1; -print "ok 1\n"; - -# all filenames should be tainted -@a = File::Glob::bsd_glob("*"); -eval { $a = join("",@a), kill 0; 1 }; -unless ($@ =~ /Insecure dependency/) { - print "not "; -} -print "ok 2\n"; diff --git a/contrib/perl5/t/lib/gol-basic.t b/contrib/perl5/t/lib/gol-basic.t deleted file mode 100755 index c5d857d..0000000 --- a/contrib/perl5/t/lib/gol-basic.t +++ /dev/null @@ -1,26 +0,0 @@ -#!./perl -w - -BEGIN { - chdir('t') if -d 't'; - @INC = '../lib'; -} - -use Getopt::Long qw(:config no_ignore_case); -die("Getopt::Long version 2.24 required--this is only version ". - $Getopt::Long::VERSION) - unless $Getopt::Long::VERSION >= 2.24; - -print "1..9\n"; - -@ARGV = qw(-Foo -baR --foo bar); -undef $opt_baR; -undef $opt_bar; -print "ok 1\n" if GetOptions ("foo", "Foo=s"); -print ((defined $opt_foo) ? "" : "not ", "ok 2\n"); -print (($opt_foo == 1) ? "" : "not ", "ok 3\n"); -print ((defined $opt_Foo) ? "" : "not ", "ok 4\n"); -print (($opt_Foo eq "-baR") ? "" : "not ", "ok 5\n"); -print ((@ARGV == 1) ? "" : "not ", "ok 6\n"); -print (($ARGV[0] eq "bar") ? "" : "not ", "ok 7\n"); -print (!(defined $opt_baR) ? "" : "not ", "ok 8\n"); -print (!(defined $opt_bar) ? "" : "not ", "ok 9\n"); diff --git a/contrib/perl5/t/lib/gol-compat.t b/contrib/perl5/t/lib/gol-compat.t deleted file mode 100755 index 0bbe386..0000000 --- a/contrib/perl5/t/lib/gol-compat.t +++ /dev/null @@ -1,25 +0,0 @@ -#!./perl -w - -BEGIN { - chdir('t') if -d 't'; - @INC = '../lib'; -} - -require "newgetopt.pl"; - -print "1..9\n"; - -@ARGV = qw(-Foo -baR --foo bar); -$newgetopt::ignorecase = 0; -$newgetopt::ignorecase = 0; -undef $opt_baR; -undef $opt_bar; -print "ok 1\n" if NGetOpt ("foo", "Foo=s"); -print ((defined $opt_foo) ? "" : "not ", "ok 2\n"); -print (($opt_foo == 1) ? "" : "not ", "ok 3\n"); -print ((defined $opt_Foo) ? "" : "not ", "ok 4\n"); -print (($opt_Foo eq "-baR") ? "" : "not ", "ok 5\n"); -print ((@ARGV == 1) ? "" : "not ", "ok 6\n"); -print (($ARGV[0] eq "bar") ? "" : "not ", "ok 7\n"); -print (!(defined $opt_baR) ? "" : "not ", "ok 8\n"); -print (!(defined $opt_bar) ? "" : "not ", "ok 9\n"); diff --git a/contrib/perl5/t/lib/gol-linkage.t b/contrib/perl5/t/lib/gol-linkage.t deleted file mode 100755 index 3bd81a3..0000000 --- a/contrib/perl5/t/lib/gol-linkage.t +++ /dev/null @@ -1,37 +0,0 @@ -#!./perl -w - -BEGIN { - chdir('t') if -d 't'; - @INC = '../lib'; -} - -use Getopt::Long; - -print "1..18\n"; - -@ARGV = qw(-Foo -baR --foo bar); -Getopt::Long::Configure ("no_ignore_case"); -%lnk = (); -print "ok 1\n" if GetOptions (\%lnk, "foo", "Foo=s"); -print ((defined $lnk{foo}) ? "" : "not ", "ok 2\n"); -print (($lnk{foo} == 1) ? "" : "not ", "ok 3\n"); -print ((defined $lnk{Foo}) ? "" : "not ", "ok 4\n"); -print (($lnk{Foo} eq "-baR") ? "" : "not ", "ok 5\n"); -print ((@ARGV == 1) ? "" : "not ", "ok 6\n"); -print (($ARGV[0] eq "bar") ? "" : "not ", "ok 7\n"); -print (!(exists $lnk{baR}) ? "" : "not ", "ok 8\n"); - -@ARGV = qw(-Foo -baR --foo bar); -Getopt::Long::Configure ("default","no_ignore_case"); -%lnk = (); -my $foo; -print "ok 9\n" if GetOptions (\%lnk, "foo" => \$foo, "Foo=s"); -print ((defined $foo) ? "" : "not ", "ok 10\n"); -print (($foo == 1) ? "" : "not ", "ok 11\n"); -print ((defined $lnk{Foo}) ? "" : "not ", "ok 12\n"); -print (($lnk{Foo} eq "-baR") ? "" : "not ", "ok 13\n"); -print ((@ARGV == 1) ? "" : "not ", "ok 14\n"); -print (($ARGV[0] eq "bar") ? "" : "not ", "ok 15\n"); -print (!(exists $lnk{foo}) ? "" : "not ", "ok 16\n"); -print (!(exists $lnk{baR}) ? "" : "not ", "ok 17\n"); -print (!(exists $lnk{bar}) ? "" : "not ", "ok 18\n"); diff --git a/contrib/perl5/t/lib/gol-oo.t b/contrib/perl5/t/lib/gol-oo.t deleted file mode 100755 index 98f3eaa..0000000 --- a/contrib/perl5/t/lib/gol-oo.t +++ /dev/null @@ -1,26 +0,0 @@ -#!./perl -w - -BEGIN { - chdir('t') if -d 't'; - @INC = '../lib'; -} - -use Getopt::Long; -die("Getopt::Long version 2.24 required--this is only version ". - $Getopt::Long::VERSION) - unless $Getopt::Long::VERSION >= 2.24; -print "1..9\n"; - -@ARGV = qw(-Foo -baR --foo bar); -my $p = new Getopt::Long::Parser (config => ["no_ignore_case"]); -undef $opt_baR; -undef $opt_bar; -print "ok 1\n" if $p->getoptions ("foo", "Foo=s"); -print ((defined $opt_foo) ? "" : "not ", "ok 2\n"); -print (($opt_foo == 1) ? "" : "not ", "ok 3\n"); -print ((defined $opt_Foo) ? "" : "not ", "ok 4\n"); -print (($opt_Foo eq "-baR") ? "" : "not ", "ok 5\n"); -print ((@ARGV == 1) ? "" : "not ", "ok 6\n"); -print (($ARGV[0] eq "bar") ? "" : "not ", "ok 7\n"); -print (!(defined $opt_baR) ? "" : "not ", "ok 8\n"); -print (!(defined $opt_bar) ? "" : "not ", "ok 9\n"); diff --git a/contrib/perl5/t/lib/h2ph.h b/contrib/perl5/t/lib/h2ph.h deleted file mode 100644 index cddf0a7..0000000 --- a/contrib/perl5/t/lib/h2ph.h +++ /dev/null @@ -1,85 +0,0 @@ -/* - * Test header file for h2ph - * - * Try to test as many constructs as possible - * For example, the multi-line comment :) - */ - -/* And here's a single line comment :) */ - -/* Test #define with no indenting, over multiple lines */ -#define SQUARE(x) \ -((x)*(x)) - -/* Test #ifndef and parameter interpretation*/ -#ifndef ERROR -#define ERROR(x) fprintf(stderr, "%s\n", x[2][3][0]) -#endif /* ERROR */ - -#ifndef _H2PH_H_ -#define _H2PH_H_ - -/* #ident - doesn't really do anything, but I think it always gets included anyway */ -#ident "$Revision h2ph.h,v 1.0 98/05/04 20:42:14 billy $" - -/* Test #undef */ -#undef MAX -#define MAX(a,b) ((a) > (b) ? (a) : (b)) - -/* Test #ifdef */ -#ifdef __SOME_UNIMPORTANT_PROPERTY -#define MIN(a,b) ((a) < (b) ? (a) : (b)) -#endif /* __SOME_UNIMPORTANT_PROPERTY */ - -/* - * Test #if, #elif, #else, #endif, #warn and #error, and `!' - * Also test whitespace between the `#' and the command - */ -#if !(defined __SOMETHING_MORE_IMPORTANT) -# warn Be careful... -#elif !(defined __SOMETHING_REALLY_REALLY_IMPORTANT) -# error Nup, can't go on /* ' /* stupid font-lock-mode */ -#else /* defined __SOMETHING_MORE_IMPORTANT && defined __SOMETHING_REALLY_REALLY_IMPORTANT */ -# define EVERYTHING_IS_OK -#endif - -/* Test && and || */ -#undef WHATEVER -#if (!((defined __SOMETHING_TRIVIAL && defined __SOMETHING_LESS_SO)) \ - || defined __SOMETHING_OVERPOWERING) -# define WHATEVER 6 -#elif !(defined __SOMETHING_TRIVIAL) /* defined __SOMETHING_LESS_SO */ -# define WHATEVER 7 -#elif !(defined __SOMETHING_LESS_SO) /* defined __SOMETHING_TRIVIAL */ -# define WHATEVER 8 -#else /* defined __SOMETHING_TRIVIAL && defined __SOMETHING_LESS_SO */ -# define WHATEVER 1000 -#endif - -/* - * Test #include, #import and #include_next - * #include_next is difficult to test, it really depends on the actual - * circumstances - for example, `#include_next <limits.h>' on a Linux system - * with `use lib qw(/opt/perl5/lib/site_perl/i586-linux/linux);' or whatever - * your equivalent is... - */ -#include <sys/socket.h> -#import "sys/ioctl.h" -#include_next <sys/fcntl.h> - -/* typedefs should be ignored */ -typedef struct a_struct { - int typedefs_should; - char be_ignored; - long as_well; -} a_typedef; - -/* - * however, typedefs of enums and just plain enums should end up being treated - * like a bunch of #defines... - */ - -typedef enum _days_of_week { sun, mon, tue, wed, thu, fri, sat, Sun=0, Mon, - Tue, Wed, Thu, Fri, Sat } days_of_week; - -#endif /* _H2PH_H_ */ diff --git a/contrib/perl5/t/lib/h2ph.pht b/contrib/perl5/t/lib/h2ph.pht deleted file mode 100644 index e5b2932..0000000 --- a/contrib/perl5/t/lib/h2ph.pht +++ /dev/null @@ -1,71 +0,0 @@ -require '_h2ph_pre.ph'; - -unless(defined(&SQUARE)) { - sub SQUARE { - local($x) = @_; - eval q((($x)*($x))); - } -} -unless(defined(&ERROR)) { - eval 'sub ERROR { - local($x) = @_; - eval q( &fprintf( &stderr, \\"%s\\\\n\\", $x->[2][3][0])); - }' unless defined(&ERROR); -} -unless(defined(&_H2PH_H_)) { - eval 'sub _H2PH_H_ () {1;}' unless defined(&_H2PH_H_); - # "$Revision h2ph.h,v 1.0 98/05/04 20:42:14 billy $" - undef(&MAX) if defined(&MAX); - eval 'sub MAX { - local($a,$b) = @_; - eval q((($a) > ($b) ? ($a) : ($b))); - }' unless defined(&MAX); - if(defined(&__SOME_UNIMPORTANT_PROPERTY)) { - eval 'sub MIN { - local($a,$b) = @_; - eval q((($a) < ($b) ? ($a) : ($b))); - }' unless defined(&MIN); - } - if(!(defined (defined(&__SOMETHING_MORE_IMPORTANT) ? &__SOMETHING_MORE_IMPORTANT : 0))) { - } - elsif(!(defined (defined(&__SOMETHING_REALLY_REALLY_IMPORTANT) ? &__SOMETHING_REALLY_REALLY_IMPORTANT : 0))) { - die("Nup\,\ can\'t\ go\ on\ "); - } else { - eval 'sub EVERYTHING_IS_OK () {1;}' unless defined(&EVERYTHING_IS_OK); - } - undef(&WHATEVER) if defined(&WHATEVER); - if((!((defined (defined(&__SOMETHING_TRIVIAL) ? &__SOMETHING_TRIVIAL : 0) && defined (defined(&__SOMETHING_LESS_SO) ? &__SOMETHING_LESS_SO : 0))) || defined (defined(&__SOMETHING_OVERPOWERING) ? &__SOMETHING_OVERPOWERING : 0))) { - eval 'sub WHATEVER () {6;}' unless defined(&WHATEVER); - } - elsif(!(defined (defined(&__SOMETHING_TRIVIAL) ? &__SOMETHING_TRIVIAL : 0)) ) { - eval 'sub WHATEVER () {7;}' unless defined(&WHATEVER); - } - elsif(!(defined (defined(&__SOMETHING_LESS_SO) ? &__SOMETHING_LESS_SO : 0)) ) { - eval 'sub WHATEVER () {8;}' unless defined(&WHATEVER); - } else { - eval 'sub WHATEVER () {1000;}' unless defined(&WHATEVER); - } - require 'sys/socket.ph'; - require 'sys/ioctl.ph'; - eval { - my(%INCD) = map { $INC{$_} => 1 } (grep { $_ eq "sys/fcntl.ph" } keys(%INC)); - my(@REM) = map { "$_/sys/fcntl.ph" } (grep { not exists($INCD{"$_/sys/fcntl.ph"})and -f "$_/sys/fcntl.ph" } @INC); - require "$REM[0]" if @REM; - }; - warn($@) if $@; - eval("sub sun () { 0; }") unless defined(&sun); - eval("sub mon () { 1; }") unless defined(&mon); - eval("sub tue () { 2; }") unless defined(&tue); - eval("sub wed () { 3; }") unless defined(&wed); - eval("sub thu () { 4; }") unless defined(&thu); - eval("sub fri () { 5; }") unless defined(&fri); - eval("sub sat () { 6; }") unless defined(&sat); - eval("sub Sun () { 0; }") unless defined(&Sun); - eval("sub Mon () { 1; }") unless defined(&Mon); - eval("sub Tue () { 2; }") unless defined(&Tue); - eval("sub Wed () { 3; }") unless defined(&Wed); - eval("sub Thu () { 4; }") unless defined(&Thu); - eval("sub Fri () { 5; }") unless defined(&Fri); - eval("sub Sat () { 6; }") unless defined(&Sat); -} -1; diff --git a/contrib/perl5/t/lib/h2ph.t b/contrib/perl5/t/lib/h2ph.t deleted file mode 100755 index 15dc2b5..0000000 --- a/contrib/perl5/t/lib/h2ph.t +++ /dev/null @@ -1,35 +0,0 @@ -#!./perl - -# quickie tests to see if h2ph actually runs and does more or less what is -# expected - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..2\n"; - -# quickly compare two text files -sub txt_compare { - local ($/, $A, $B); - for (($A,$B) = @_) { open(_,"<$_") ? $_ = <_> : die "$_ : $!"; close _ } - $A cmp $B; -} - -unless(-e '../utils/h2ph') { - print("ok 1\nok 2\n"); - # i'll probably get in trouble for this :) -} else { - # does it run? - $ok = system("./perl -I../lib ../utils/h2ph -d. -Q lib/h2ph.h"); - print(($ok == 0 ? "" : "not "), "ok 1\n"); - - # does it work? well, does it do what we expect? :-) - $ok = txt_compare("lib/h2ph.ph", "lib/h2ph.pht"); - print(($ok == 0 ? "" : "not "), "ok 2\n"); - - # cleanup - should this be in an END block? - unlink("lib/h2ph.ph"); - unlink("_h2ph_pre.ph"); -} diff --git a/contrib/perl5/t/lib/hostname.t b/contrib/perl5/t/lib/hostname.t deleted file mode 100755 index 85a04cd..0000000 --- a/contrib/perl5/t/lib/hostname.t +++ /dev/null @@ -1,25 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bSys\/Hostname\b/) { - print "1..0 # Skip: Sys::Hostname was not built\n"; - exit 0; - } -} - -use Sys::Hostname; - -eval { - $host = hostname; -}; - -if ($@) { - print "1..0\n" if $@ =~ /Cannot get host name/; -} else { - print "1..1\n"; - print "# \$host = `$host'\n"; - print "ok 1\n"; -} diff --git a/contrib/perl5/t/lib/io_const.t b/contrib/perl5/t/lib/io_const.t deleted file mode 100755 index db1a322..0000000 --- a/contrib/perl5/t/lib/io_const.t +++ /dev/null @@ -1,33 +0,0 @@ - -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; - -print "1..6\n"; -my $i = 1; -foreach (qw(SEEK_SET SEEK_CUR SEEK_END _IOFBF _IOLBF _IONBF)) { - my $d1 = defined(&{"IO::Handle::" . $_}) ? 1 : 0; - my $v1 = $d1 ? &{"IO::Handle::" . $_}() : undef; - my $v2 = IO::Handle::constant($_); - my $d2 = defined($v2); - - print "not " - if($d1 != $d2 || ($d1 && ($v1 != $v2))); - print "ok ",$i++,"\n"; -} diff --git a/contrib/perl5/t/lib/io_dir.t b/contrib/perl5/t/lib/io_dir.t deleted file mode 100755 index 3689871..0000000 --- a/contrib/perl5/t/lib/io_dir.t +++ /dev/null @@ -1,66 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib'; - } - require Config; import Config; - if ($] < 5.00326 || not $Config{'d_readdir'}) { - print "1..0\n"; - exit 0; - } -} - -select(STDERR); $| = 1; -select(STDOUT); $| = 1; - -use IO::Dir qw(DIR_UNLINK); - -print "1..10\n"; - -$dot = new IO::Dir "."; -print defined($dot) ? "ok" : "not ok", " 1\n"; - -@a = sort <*>; -do { $first = $dot->read } while defined($first) && $first =~ /^\./; -print +(grep { $_ eq $first } @a) ? "ok" : "not ok", " 2\n"; - -@b = sort($first, (grep {/^[^.]/} $dot->read)); -print +(join("\0", @a) eq join("\0", @b)) ? "ok" : "not ok", " 3\n"; - -$dot->rewind; -@c = sort grep {/^[^.]/} $dot->read; -print +(join("\0", @b) eq join("\0", @c)) ? "ok" : "not ok", " 4\n"; - -$dot->close; -$dot->rewind; -print defined($dot->read) ? "not ok" : "ok", " 5\n"; - -open(FH,'>X') || die "Can't create x"; -print FH "X"; -close(FH); - -tie %dir, IO::Dir, "."; -my @files = keys %dir; - -# I hope we do not have an empty dir :-) -print @files ? "ok" : "not ok", " 6\n"; - -my $stat = $dir{'X'}; -print defined($stat) && UNIVERSAL::isa($stat,'File::stat') && $stat->size == 1 - ? "ok" : "not ok", " 7\n"; - -delete $dir{'X'}; - -print -f 'X' ? "ok" : "not ok", " 8\n"; - -tie %dirx, IO::Dir, ".", DIR_UNLINK; - -my $statx = $dirx{'X'}; -print defined($statx) && UNIVERSAL::isa($statx,'File::stat') && $statx->size == 1 - ? "ok" : "not ok", " 9\n"; - -delete $dirx{'X'}; - -print -f 'X' ? "not ok" : "ok", " 10\n"; diff --git a/contrib/perl5/t/lib/io_dup.t b/contrib/perl5/t/lib/io_dup.t deleted file mode 100755 index 0f17264..0000000 --- a/contrib/perl5/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') { - print `echo ok 4`; - print `echo ok 5 1>&2`; # does this *really* work? -} -else { - system 'echo ok 4'; - system 'echo ok 5 1>&2'; -} - -$stderr->close; -$stdout->close; - -$stdout->fdopen($dupout,"w"); -$stderr->fdopen($duperr,"w"); - -if ($^O eq 'MSWin32') { print `type Io.dup` } -else { system 'cat Io.dup' } -unlink 'Io.dup'; - -print STDOUT "ok 6\n"; diff --git a/contrib/perl5/t/lib/io_linenum.t b/contrib/perl5/t/lib/io_linenum.t deleted file mode 100755 index cf55c98..0000000 --- a/contrib/perl5/t/lib/io_linenum.t +++ /dev/null @@ -1,80 +0,0 @@ -#!./perl - -# test added 29th April 1999 by Paul Johnson (pjcj@transeda.com) -# updated 28th May 1999 by Paul Johnson - -my $File; - -BEGIN -{ - $File = __FILE__; - if (-d 't') - { - chdir 't'; - $File =~ s/^t\W+//; # Remove first directory - } - @INC = '../lib'; - require strict; import strict; -} - -use Test; - -BEGIN { plan tests => 12 } - -use IO::File; - -sub lineno -{ - my ($f) = @_; - my $l; - $l .= "$. "; - $l .= $f->input_line_number; - $l .= " $."; # check $. before and after input_line_number - $l; -} - -my $t; - -open (F, $File) or die $!; -my $io = IO::File->new($File) or die $!; - -<F> for (1 .. 10); -ok(lineno($io), "10 0 10"); - -$io->getline for (1 .. 5); -ok(lineno($io), "5 5 5"); - -<F>; -ok(lineno($io), "11 5 11"); - -$io->getline; -ok(lineno($io), "6 6 6"); - -$t = tell F; # tell F; provokes a warning -ok(lineno($io), "11 6 11"); - -<F>; -ok(lineno($io), "12 6 12"); - -select F; -ok(lineno($io), "12 6 12"); - -<F> for (1 .. 10); -ok(lineno($io), "22 6 22"); - -$io->getline for (1 .. 5); -ok(lineno($io), "11 11 11"); - -$t = tell F; -# We used to have problems here before local $. worked. -# input_line_number() used to use select and tell. When we did the -# same, that mechanism broke. It should work now. -ok(lineno($io), "22 11 22"); - -{ - local $.; - $io->getline for (1 .. 5); - ok(lineno($io), "16 16 16"); -} - -ok(lineno($io), "22 16 22"); diff --git a/contrib/perl5/t/lib/io_multihomed.t b/contrib/perl5/t/lib/io_multihomed.t deleted file mode 100755 index 55030b5..0000000 --- a/contrib/perl5/t/lib/io_multihomed.t +++ /dev/null @@ -1,124 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib'; - } -} - -use Config; - -BEGIN { - if(-d "lib" && -f "TEST") { - my $reason; - if (! $Config{'d_fork'}) { - $reason = 'no fork'; - } - elsif ($Config{'extensions'} !~ /\bSocket\b/) { - $reason = 'Socket extension unavailable'; - } - elsif ($Config{'extensions'} !~ /\bIO\b/) { - $reason = 'IO extension unavailable'; - } - if ($reason) { - print "1..0 # Skip: $reason\n"; - exit 0; - } - } -} - -$| = 1; - -print "1..8\n"; - - -package Multi; -require IO::Socket::INET; -@ISA=qw(IO::Socket::INET); - -use Socket qw(inet_aton inet_ntoa unpack_sockaddr_in); - -sub _get_addr -{ - my($sock,$addr_str, $multi) = @_; - #print "_get_addr($sock, $addr_str, $multi)\n"; - - print "not " unless $multi; - print "ok 2\n"; - - ( - # private IP-addresses which I hope does not work anywhere :-) - inet_aton("10.250.230.10"), - inet_aton("10.250.230.12"), - inet_aton("127.0.0.1") # loopback - ) -} - -sub connect -{ - my $self = shift; - if (@_ == 1) { - my($port, $addr) = unpack_sockaddr_in($_[0]); - $addr = inet_ntoa($addr); - #print "connect($self, $port, $addr)\n"; - if($addr eq "10.250.230.10") { - print "ok 3\n"; - return 0; - } - if($addr eq "10.250.230.12") { - print "ok 4\n"; - return 0; - } - } - $self->SUPER::connect(@_); -} - - - -package main; - -use IO::Socket; - -$listen = IO::Socket::INET->new(Listen => 2, - Proto => 'tcp', - Timeout => 5, - ) or die "$!"; - -print "ok 1\n"; - -$port = $listen->sockport; - -if($pid = fork()) { - - $sock = $listen->accept() or die "$!"; - print "ok 5\n"; - - print $sock->getline(); - print $sock "ok 7\n"; - - waitpid($pid,0); - - $sock->close; - - print "ok 8\n"; - -} elsif(defined $pid) { - - $sock = Multi->new(PeerPort => $port, - Proto => 'tcp', - PeerAddr => 'localhost', - MultiHomed => 1, - Timeout => 1, - ) or die "$!"; - - print $sock "ok 6\n"; - sleep(1); # race condition - print $sock->getline(); - - $sock->close; - - exit; -} else { - die; -} diff --git a/contrib/perl5/t/lib/io_pipe.t b/contrib/perl5/t/lib/io_pipe.t deleted file mode 100755 index ae18224..0000000 --- a/contrib/perl5/t/lib/io_pipe.t +++ /dev/null @@ -1,123 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib'; - } -} - -use Config; - -BEGIN { - if(-d "lib" && -f "TEST") { - my $reason; - if (! $Config{'d_fork'}) { - $reason = 'no fork'; - } - elsif ($Config{'extensions'} !~ /\bIO\b/) { - $reason = 'IO extension unavailable'; - } - undef $reason if $^O eq 'VMS'; - if ($reason) { - print "1..0 # Skip: $reason\n"; - exit 0; - } - } -} - -use IO::Pipe; - -my $perl = './perl'; - -$| = 1; -print "1..10\n"; - -$pipe = new IO::Pipe->reader($perl, '-e', 'print "not ok 1\n"'); -while (<$pipe>) { - s/^not //; - print; -} -$pipe->close or print "# \$!=$!\nnot "; -print "ok 2\n"; - -$cmd = 'BEGIN{$SIG{ALRM} = sub {print "not ok 4\n"; exit}; alarm 10} s/not //'; -$pipe = new IO::Pipe->writer($perl, '-pe', $cmd); -print $pipe "not ok 3\n" ; -$pipe->close or print "# \$!=$!\nnot "; -print "ok 4\n"; - -# Check if can fork with dynamic extensions (bug in CRT): -if ($^O eq 'os2' and - system "$^X -I../lib -MOpcode -e 'defined fork or die' > /dev/null 2>&1") { - print "ok $_ # skipped: broken fork\n" for 5..10; - exit 0; -} - -$pipe = new IO::Pipe; - -$pid = fork(); - -if($pid) - { - $pipe->writer; - print $pipe "Xk 5\n"; - print $pipe "oY 6\n"; - $pipe->close; - wait; - } -elsif(defined $pid) - { - $pipe->reader; - $stdin = bless \*STDIN, "IO::Handle"; - $stdin->fdopen($pipe,"r"); - exec 'tr', 'YX', 'ko'; - } -else - { - die "# error = $!"; - } - -$pipe = new IO::Pipe; -$pid = fork(); - -if($pid) - { - $pipe->reader; - while(<$pipe>) { - s/^not //; - print; - } - $pipe->close; - wait; - } -elsif(defined $pid) - { - $pipe->writer; - - $stdout = bless \*STDOUT, "IO::Handle"; - $stdout->fdopen($pipe,"w"); - print STDOUT "not ok 7\n"; - exec 'echo', 'not ok 8'; - } -else - { - die; - } - -$pipe = new IO::Pipe; -$pipe->writer; - -$SIG{'PIPE'} = 'broken_pipe'; - -sub broken_pipe { - print "ok 9\n"; -} - -print $pipe "not ok 9\n"; -$pipe->close; - -sleep 1; - -print "ok 10\n"; - diff --git a/contrib/perl5/t/lib/io_poll.t b/contrib/perl5/t/lib/io_poll.t deleted file mode 100755 index d391566..0000000 --- a/contrib/perl5/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') { -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/contrib/perl5/t/lib/io_sel.t b/contrib/perl5/t/lib/io_sel.t deleted file mode 100755 index 5d1dce3..0000000 --- a/contrib/perl5/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 '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/contrib/perl5/t/lib/io_sock.t b/contrib/perl5/t/lib/io_sock.t deleted file mode 100755 index 45c16c2..0000000 --- a/contrib/perl5/t/lib/io_sock.t +++ /dev/null @@ -1,203 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib'; - } -} - -use Config; - -BEGIN { - if (-d "lib" && -f "TEST") { - my $reason; - if (! $Config{'d_fork'}) { - $reason = 'no fork'; - } - elsif ($Config{'extensions'} !~ /\bSocket\b/) { - $reason = 'Socket extension unavailable'; - } - elsif ($Config{'extensions'} !~ /\bIO\b/) { - $reason = 'IO extension unavailable'; - } - undef $reason if $^O eq 'VMS' and $Config{d_socket}; - if ($reason) { - print "1..0 # Skip: $reason\n"; - exit 0; - } - } -} - -$| = 1; -print "1..14\n"; - -use IO::Socket; - -$listen = IO::Socket::INET->new(Listen => 2, - Proto => 'tcp', - # some systems seem to need as much as 10, - # so be generous with the timeout - Timeout => 15, - ) or die "$!"; - -print "ok 1\n"; - -# Check if can fork with dynamic extensions (bug in CRT): -if ($^O eq 'os2' and - system "$^X -I../lib -MOpcode -e 'defined fork or die' > /dev/null 2>&1") { - print "ok $_ # skipped: broken fork\n" for 2..5; - exit 0; -} - -$port = $listen->sockport; - -if($pid = fork()) { - - $sock = $listen->accept() or die "accept failed: $!"; - print "ok 2\n"; - - $sock->autoflush(1); - print $sock->getline(); - - print $sock "ok 4\n"; - - $sock->close; - - waitpid($pid,0); - - print "ok 5\n"; - -} elsif(defined $pid) { - - $sock = IO::Socket::INET->new(PeerPort => $port, - Proto => 'tcp', - PeerAddr => 'localhost' - ) - || IO::Socket::INET->new(PeerPort => $port, - Proto => 'tcp', - PeerAddr => '127.0.0.1' - ) - or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)"; - - $sock->autoflush(1); - - print $sock "ok 3\n"; - - print $sock->getline(); - - $sock->close; - - exit; -} else { - die; -} - -# Test various other ways to create INET sockets that should -# also work. -$listen = IO::Socket::INET->new(Listen => '', Timeout => 15) or die "$!"; -$port = $listen->sockport; - -if($pid = fork()) { - SERVER_LOOP: - while (1) { - last SERVER_LOOP unless $sock = $listen->accept; - while (<$sock>) { - last SERVER_LOOP if /^quit/; - last if /^done/; - print; - } - $sock = undef; - } - $listen->close; -} elsif (defined $pid) { - # child, try various ways to connect - $sock = IO::Socket::INET->new("localhost:$port") - || IO::Socket::INET->new("127.0.0.1:$port"); - if ($sock) { - print "not " unless $sock->connected; - print "ok 6\n"; - $sock->print("ok 7\n"); - sleep(1); - print "ok 8\n"; - $sock->print("ok 9\n"); - $sock->print("done\n"); - $sock->close; - } - else { - print "# $@\n"; - print "not ok 6\n"; - print "not ok 7\n"; - print "not ok 8\n"; - print "not ok 9\n"; - } - - # some machines seem to suffer from a race condition here - sleep(2); - - $sock = IO::Socket::INET->new("127.0.0.1:$port"); - if ($sock) { - $sock->print("ok 10\n"); - $sock->print("done\n"); - $sock->close; - } - else { - print "# $@\n"; - print "not ok 10\n"; - } - - # some machines seem to suffer from a race condition here - sleep(1); - - $sock = IO::Socket->new(Domain => AF_INET, - PeerAddr => "localhost:$port") - || IO::Socket->new(Domain => AF_INET, - PeerAddr => "127.0.0.1:$port"); - if ($sock) { - $sock->print("ok 11\n"); - $sock->print("quit\n"); - } - $sock = undef; - sleep(1); - exit; -} else { - die; -} - -# Then test UDP sockets -$server = IO::Socket->new(Domain => AF_INET, - Proto => 'udp', - LocalAddr => 'localhost') - || IO::Socket->new(Domain => AF_INET, - Proto => 'udp', - LocalAddr => '127.0.0.1'); -$port = $server->sockport; - -if ($^O eq 'mpeix') { - print("ok 12 # skipped\n") -} else { - if ($pid = fork()) { - my $buf; - $server->recv($buf, 100); - print $buf; - } elsif (defined($pid)) { - #child - $sock = IO::Socket::INET->new(Proto => 'udp', - PeerAddr => "localhost:$port") - || IO::Socket::INET->new(Proto => 'udp', - PeerAddr => "127.0.0.1:$port"); - $sock->send("ok 12\n"); - sleep(1); - $sock->send("ok 12\n"); # send another one to be sure - exit; - } else { - die; - } -} - -print "not " unless $server->blocking; -print "ok 13\n"; - -$server->blocking(0); -print "not " if $server->blocking; -print "ok 14\n"; diff --git a/contrib/perl5/t/lib/io_taint.t b/contrib/perl5/t/lib/io_taint.t deleted file mode 100755 index 19afa2f..0000000 --- a/contrib/perl5/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' 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/contrib/perl5/t/lib/io_tell.t b/contrib/perl5/t/lib/io_tell.t deleted file mode 100755 index 3aa4b03..0000000 --- a/contrib/perl5/t/lib/io_tell.t +++ /dev/null @@ -1,64 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib'; - $tell_file = "TEST"; - } - else { - $tell_file = "Makefile"; - } -} - -use Config; - -BEGIN { - if(-d "lib" && -f "TEST") { - if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { - print "1..0\n"; - exit 0; - } - } -} - -print "1..13\n"; - -use IO::File; - -$tst = IO::File->new("$tell_file","r") || die("Can't open $tell_file"); -binmode $tst if ($^O eq 'MSWin32' or $^O eq 'dos'); -if ($tst->eof) { print "not ok 1\n"; } else { print "ok 1\n"; } - -$firstline = <$tst>; -$secondpos = tell; - -$x = 0; -while (<$tst>) { - if (eof) {$x++;} -} -if ($x == 1) { print "ok 2\n"; } else { print "not ok 2\n"; } - -$lastpos = tell; - -unless (eof) { print "not ok 3\n"; } else { print "ok 3\n"; } - -if ($tst->seek(0,0)) { print "ok 4\n"; } else { print "not ok 4\n"; } - -if (eof) { print "not ok 5\n"; } else { print "ok 5\n"; } - -if ($firstline eq <$tst>) { print "ok 6\n"; } else { print "not ok 6\n"; } - -if ($secondpos == tell) { print "ok 7\n"; } else { print "not ok 7\n"; } - -if ($tst->seek(0,1)) { print "ok 8\n"; } else { print "not ok 8\n"; } - -if ($tst->eof) { print "not ok 9\n"; } else { print "ok 9\n"; } - -if ($secondpos == tell) { print "ok 10\n"; } else { print "not ok 10\n"; } - -if ($tst->seek(0,2)) { print "ok 11\n"; } else { print "not ok 11\n"; } - -if ($lastpos == $tst->tell) { print "ok 12\n"; } else { print "not ok 12\n"; } - -unless (eof) { print "not ok 13\n"; } else { print "ok 13\n"; } diff --git a/contrib/perl5/t/lib/io_udp.t b/contrib/perl5/t/lib/io_udp.t deleted file mode 100755 index d63a5dc..0000000 --- a/contrib/perl5/t/lib/io_udp.t +++ /dev/null @@ -1,94 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib'; - } -} - -use Config; - -BEGIN { - if(-d "lib" && -f "TEST") { - my $reason; - - if ($Config{'extensions'} !~ /\bSocket\b/) { - $reason = 'Socket was not built'; - } - elsif ($Config{'extensions'} !~ /\bIO\b/) { - $reason = 'IO was not built'; - } - elsif ($^O eq 'apollo') { - $reason = "unknown *FIXME*"; - } - undef $reason if $^O eq 'VMS' and $Config{d_socket}; - if ($reason) { - print "1..0 # Skip: $reason\n"; - exit 0; - } - } -} - -sub compare_addr { - no utf8; - my $a = shift; - my $b = shift; - if (length($a) != length $b) { - my $min = (length($a) < length $b) ? length($a) : length $b; - if ($min and substr($a, 0, $min) eq substr($b, 0, $min)) { - printf "# Apparently: %d bytes junk at the end of %s\n# %s\n", - abs(length($a) - length ($b)), - $_[length($a) < length ($b) ? 1 : 0], - "consider decreasing bufsize of recfrom."; - substr($a, $min) = ""; - substr($b, $min) = ""; - } - return 0; - } - my @a = unpack_sockaddr_in($a); - my @b = unpack_sockaddr_in($b); - "$a[0]$a[1]" eq "$b[0]$b[1]"; -} - -$| = 1; -print "1..7\n"; - -use Socket; -use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY); - -$udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost') - || IO::Socket::INET->new(Proto => 'udp', LocalAddr => '127.0.0.1') - or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)"; - -print "ok 1\n"; - -$udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost') - || IO::Socket::INET->new(Proto => 'udp', LocalAddr => '127.0.0.1') - or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)"; - -print "ok 2\n"; - -$udpa->send("ok 4\n",0,$udpb->sockname); - -print "not " - unless compare_addr($udpa->peername,$udpb->sockname, 'peername', 'sockname'); -print "ok 3\n"; - -my $where = $udpb->recv($buf="",5); -print $buf; - -my @xtra = (); - -unless(compare_addr($where,$udpa->sockname, 'recv name', 'sockname')) { - print "not "; - @xtra = (0,$udpa->sockname); -} -print "ok 5\n"; - -$udpb->send("ok 6\n",@xtra); -$udpa->recv($buf="",5); -print $buf; - -print "not " if $udpa->connected; -print "ok 7\n"; diff --git a/contrib/perl5/t/lib/io_unix.t b/contrib/perl5/t/lib/io_unix.t deleted file mode 100755 index 2f6def0..0000000 --- a/contrib/perl5/t/lib/io_unix.t +++ /dev/null @@ -1,89 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib'; - } -} - -use Config; - -BEGIN { - if(-d "lib" && -f "TEST") { - my $reason; - if (! $Config{'d_fork'}) { - $reason = 'no fork'; - } - elsif ($Config{'extensions'} !~ /\bSocket\b/) { - $reason = 'Socket extension unavailable'; - } - elsif ($Config{'extensions'} !~ /\bIO\b/) { - $reason = 'IO extension unavailable'; - } - elsif ($^O eq 'os2') { - require IO::Socket; - - eval {IO::Socket::pack_sockaddr_un('/tmp/foo') || 1} - or $@ !~ /not implemented/ or - $reason = 'compiled without TCP/IP stack v4'; - } elsif ($^O eq 'qnx') { - $reason = 'Not implemented'; - } - undef $reason if $^O eq 'VMS' and $Config{d_socket}; - if ($reason) { - print "1..0 # Skip: $reason\n"; - exit 0; - } - } -} - -$PATH = "/tmp/sock-$$"; - -# Test if we can create the file within the tmp directory -if (-e $PATH or not open(TEST, ">$PATH") and $^O ne 'os2') { - print "1..0 # Skip: cannot open '$PATH' for write\n"; - exit 0; -} -close(TEST); -unlink($PATH) or $^O eq 'os2' or die "Can't unlink $PATH: $!"; - -# Start testing -$| = 1; -print "1..5\n"; - -use IO::Socket; - -$listen = IO::Socket::UNIX->new(Local=>$PATH, Listen=>0) || die "$!"; -print "ok 1\n"; - -if($pid = fork()) { - - $sock = $listen->accept(); - print "ok 2\n"; - - print $sock->getline(); - - print $sock "ok 4\n"; - - $sock->close; - - waitpid($pid,0); - unlink($PATH) || $^O eq 'os2' || warn "Can't unlink $PATH: $!"; - - print "ok 5\n"; - -} elsif(defined $pid) { - - $sock = IO::Socket::UNIX->new(Peer => $PATH) or die "$!"; - - print $sock "ok 3\n"; - - print $sock->getline(); - - $sock->close; - - exit; -} else { - die; -} diff --git a/contrib/perl5/t/lib/io_xs.t b/contrib/perl5/t/lib/io_xs.t deleted file mode 100755 index 2449fc4..0000000 --- a/contrib/perl5/t/lib/io_xs.t +++ /dev/null @@ -1,43 +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::File; -use IO::Seekable; - -print "1..4\n"; - -$x = new_tmpfile IO::File or print "not "; -print "ok 1\n"; -print $x "ok 2\n"; -$x->seek(0,SEEK_SET); -print <$x>; - -$x->seek(0,SEEK_SET); -print $x "not ok 3\n"; -$p = $x->getpos; -print $x "ok 3\n"; -$x->flush; -$x->setpos($p); -print scalar <$x>; - -$! = 0; -$x->setpos(undef); -print $! ? "ok 4 # $!\n" : "not ok 4\n"; - diff --git a/contrib/perl5/t/lib/ipc_sysv.t b/contrib/perl5/t/lib/ipc_sysv.t deleted file mode 100755 index 795ad5d..0000000 --- a/contrib/perl5/t/lib/ipc_sysv.t +++ /dev/null @@ -1,218 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - - @INC = '../lib'; - - require Config; import Config; - - my $reason; - - if ($Config{'extensions'} !~ /\bIPC\/SysV\b/) { - $reason = 'IPC::SysV was not built'; - } elsif ($Config{'d_sem'} ne 'define') { - $reason = '$Config{d_sem} undefined'; - } elsif ($Config{'d_msg'} ne 'define') { - $reason = '$Config{d_msg} undefined'; - } - if ($reason) { - print "1..0 # Skip: $reason\n"; - exit 0; - } -} - -# These constants are common to all tests. -# Later the sem* tests will import more for themselves. - -use IPC::SysV qw(IPC_PRIVATE IPC_NOWAIT IPC_STAT IPC_RMID S_IRWXU); -use strict; - -print "1..16\n"; - -my $msg; -my $sem; - -$SIG{__DIE__} = 'cleanup'; # will cleanup $msg and $sem if needed - -# FreeBSD is known to throw this if there's no SysV IPC in the kernel. -$SIG{SYS} = sub { - print STDERR <<EOM; -SIGSYS caught. -It may be that your kernel does not have SysV IPC configured. - -EOM - if ($^O eq 'freebsd') { - print STDERR <<EOM; -You must have following options in your kernel: - -options SYSVSHM -options SYSVSEM -options SYSVMSG - -See config(8). -EOM - } - exit(1); -}; - -my $perm = S_IRWXU; - -if ($Config{'d_msgget'} eq 'define' && - $Config{'d_msgctl'} eq 'define' && - $Config{'d_msgsnd'} eq 'define' && - $Config{'d_msgrcv'} eq 'define') { - - $msg = msgget(IPC_PRIVATE, $perm); - # Very first time called after machine is booted value may be 0 - die "msgget failed: $!\n" unless defined($msg) && $msg >= 0; - - print "ok 1\n"; - - #Putting a message on the queue - my $msgtype = 1; - my $msgtext = "hello"; - - my $test2bad; - my $test5bad; - my $test6bad; - - unless (msgsnd($msg,pack("L! a*",$msgtype,$msgtext),IPC_NOWAIT)) { - print "not "; - $test2bad = 1; - } - print "ok 2\n"; - if ($test2bad) { - print <<EOM; -# -# The failure of the subtest #2 may indicate that the message queue -# resource limits either of the system or of the testing account -# have been reached. Error message "Operating would block" is -# usually indicative of this situation. The error message was now: -# "$!" -# -# You can check the message queues with the 'ipcs' command and -# you can remove unneeded queues with the 'ipcrm -q id' command. -# You may also consider configuring your system or account -# to have more message queue resources. -# -# Because of the subtest #2 failing also the substests #5 and #6 will -# very probably also fail. -# -EOM - } - - my $data; - msgctl($msg,IPC_STAT,$data) or print "not "; - print "ok 3\n"; - - print "not " unless length($data); - print "ok 4\n"; - - my $msgbuf; - unless (msgrcv($msg,$msgbuf,256,0,IPC_NOWAIT)) { - print "not "; - $test5bad = 1; - } - print "ok 5\n"; - if ($test5bad && $test2bad) { - print <<EOM; -# -# This failure was to be expected because the subtest #2 failed. -# -EOM - } - - my($rmsgtype,$rmsgtext); - ($rmsgtype,$rmsgtext) = unpack("L! a*",$msgbuf); - unless ($rmsgtype == $msgtype && $rmsgtext eq $msgtext) { - print "not "; - $test6bad = 1; - } - print "ok 6\n"; - if ($test6bad && $test2bad) { - print <<EOM; -# -# This failure was to be expected because the subtest #2 failed. -# -EOM - } -} else { - for (1..6) { - print "ok $_\n"; # fake it - } -} - -if($Config{'d_semget'} eq 'define' && - $Config{'d_semctl'} eq 'define') { - - if ($Config{'d_semctl_semid_ds'} eq 'define' || - $Config{'d_semctl_semun'} eq 'define') { - - use IPC::SysV qw(IPC_CREAT GETALL SETALL); - - $sem = semget(IPC_PRIVATE, 10, $perm | IPC_CREAT); - # Very first time called after machine is booted value may be 0 - die "semget: $!\n" unless defined($sem) && $sem >= 0; - - print "ok 7\n"; - - my $data; - semctl($sem,0,IPC_STAT,$data) or print "not "; - print "ok 8\n"; - - print "not " unless length($data); - print "ok 9\n"; - - my $nsem = 10; - - semctl($sem,0,SETALL,pack("s!*",(0) x $nsem)) or print "not "; - print "ok 10\n"; - - $data = ""; - semctl($sem,0,GETALL,$data) or print "not "; - print "ok 11\n"; - - print "not " unless length($data) == length(pack("s!*",(0) x $nsem)); - print "ok 12\n"; - - my @data = unpack("s!*",$data); - - my $adata = "0" x $nsem; - - print "not " unless @data == $nsem and join("",@data) eq $adata; - print "ok 13\n"; - - my $poke = 2; - - $data[$poke] = 1; - semctl($sem,0,SETALL,pack("s!*",@data)) or print "not "; - print "ok 14\n"; - - $data = ""; - semctl($sem,0,GETALL,$data) or print "not "; - print "ok 15\n"; - - @data = unpack("s!*",$data); - - my $bdata = "0" x $poke . "1" . "0" x ($nsem-$poke-1); - - print "not " unless join("",@data) eq $bdata; - print "ok 16\n"; - } else { - for (7..16) { - print "ok $_ # skipped, no semctl possible\n"; - } - } -} else { - for (7..16) { - print "ok $_\n"; # fake it - } -} - -sub cleanup { - msgctl($msg,IPC_RMID,0) if defined $msg; - semctl($sem,0,IPC_RMID,undef) if defined $sem; -} - -cleanup; diff --git a/contrib/perl5/t/lib/ndbm.t b/contrib/perl5/t/lib/ndbm.t deleted file mode 100755 index e56fcd9..0000000 --- a/contrib/perl5/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') { - 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/contrib/perl5/t/lib/odbm.t b/contrib/perl5/t/lib/odbm.t deleted file mode 100755 index b935d04..0000000 --- a/contrib/perl5/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') { - 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/contrib/perl5/t/lib/opcode.t b/contrib/perl5/t/lib/opcode.t deleted file mode 100755 index a785fce..0000000 --- a/contrib/perl5/t/lib/opcode.t +++ /dev/null @@ -1,115 +0,0 @@ -#!./perl -w - -$|=1; - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { - print "1..0\n"; - exit 0; - } -} - -use Opcode qw( - opcodes opdesc opmask verify_opset - opset opset_to_ops opset_to_hex invert_opset - opmask_add full_opset empty_opset define_optag -); - -use strict; - -my $t = 1; -my $last_test; # initalised at end -print "1..$last_test\n"; - -my($s1, $s2, $s3); -my(@o1, @o2, @o3); - -# --- opset_to_ops and opset - -my @empty_l = opset_to_ops(empty_opset); -print @empty_l == 0 ? "ok $t\n" : "not ok $t\n"; $t++; - -my @full_l1 = opset_to_ops(full_opset); -print @full_l1 == opcodes() ? "ok $t\n" : "not ok $t\n"; $t++; -my @full_l2 = @full_l1; # = opcodes(); # XXX to be fixed -print "@full_l1" eq "@full_l2" ? "ok $t\n" : "not ok $t\n"; $t++; - -@empty_l = opset_to_ops(opset(':none')); -print @empty_l == 0 ? "ok $t\n" : "not ok $t\n"; $t++; - -my @full_l3 = opset_to_ops(opset(':all')); -print @full_l1 == @full_l3 ? "ok $t\n" : "not ok $t\n"; $t++; -print "@full_l1" eq "@full_l3" ? "ok $t\n" : "not ok $t\n"; $t++; - -die $t unless $t == 7; -$s1 = opset( 'padsv'); -$s2 = opset($s1, 'padav'); -$s3 = opset($s2, '!padav'); -print $s1 eq $s2 ? "not ok $t\n" : "ok $t\n"; ++$t; -print $s1 eq $s3 ? "ok $t\n" : "not ok $t\n"; ++$t; - -# --- define_optag - -print eval { opset(':_tst_') } ? "not ok $t\n" : "ok $t\n"; ++$t; -define_optag(":_tst_", opset(qw(padsv padav padhv))); -print eval { opset(':_tst_') } ? "ok $t\n" : "not ok $t\n"; ++$t; - -# --- opdesc and opcodes - -die $t unless $t == 11; -print opdesc("gv") eq "glob value" ? "ok $t\n" : "not ok $t\n"; $t++; -my @desc = opdesc(':_tst_','stub'); -print "@desc" eq "private variable private array private hash stub" - ? "ok $t\n" : "not ok $t\n#@desc\n"; $t++; -print opcodes() ? "ok $t\n" : "not ok $t\n"; $t++; -print "ok $t\n"; ++$t; - -# --- invert_opset - -$s1 = opset(qw(fileno padsv padav)); -@o2 = opset_to_ops(invert_opset($s1)); -print @o2 == opcodes-3 ? "ok $t\n" : "not ok $t\n"; $t++; - -# --- opmask - -die $t unless $t == 16; -print opmask() eq empty_opset() ? "ok $t\n" : "not ok $t\n"; $t++; # work -print length opmask() == int((opcodes()+7)/8) ? "ok $t\n" : "not ok $t\n"; $t++; - -# --- verify_opset - -print verify_opset($s1) && !verify_opset(42) ? "ok $t\n":"not ok $t\n"; $t++; - -# --- opmask_add - -opmask_add(opset(qw(fileno))); # add to global op_mask -print eval 'fileno STDOUT' ? "not ok $t\n" : "ok $t\n"; $t++; # fail -print $@ =~ /fileno trapped/ ? "ok $t\n" : "not ok $t\n# $@\n"; $t++; - -# --- check use of bit vector ops on opsets - -$s1 = opset('padsv'); -$s2 = opset('padav'); -$s3 = opset('padsv', 'padav', 'padhv'); - -# Non-negated -print (($s1 | $s2) eq opset($s1,$s2) ? "ok $t\n":"not ok $t\n"); $t++; -print (($s2 & $s3) eq opset($s2) ? "ok $t\n":"not ok $t\n"); $t++; -print (($s2 ^ $s3) eq opset('padsv','padhv') ? "ok $t\n":"not ok $t\n"); $t++; - -# Negated, e.g., with possible extra bits in last byte beyond last op bit. -# The extra bits mean we can't just say ~mask eq invert_opset(mask). - -@o1 = opset_to_ops( ~ $s3); -@o2 = opset_to_ops(invert_opset $s3); -print "@o1" eq "@o2" ? "ok $t\n":"not ok $t\n"; $t++; - -# --- finally, check some opname assertions - -foreach(@full_l1) { die "bad opname: $_" if /\W/ or /^\d/ } - -print "ok $last_test\n"; -BEGIN { $last_test = 25 } diff --git a/contrib/perl5/t/lib/open2.t b/contrib/perl5/t/lib/open2.t deleted file mode 100755 index 85b807c..0000000 --- a/contrib/perl5/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' || $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') { - 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/contrib/perl5/t/lib/open3.t b/contrib/perl5/t/lib/open3.t deleted file mode 100755 index a0da34f..0000000 --- a/contrib/perl5/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' || $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') { - 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/contrib/perl5/t/lib/ops.t b/contrib/perl5/t/lib/ops.t deleted file mode 100755 index 56b1bac..0000000 --- a/contrib/perl5/t/lib/ops.t +++ /dev/null @@ -1,29 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { - print "1..0\n"; - exit 0; - } -} - -print "1..2\n"; - -eval <<'EOP'; - no ops 'fileno'; # equiv to "perl -M-ops=fileno" - $a = fileno STDIN; -EOP - -print $@ =~ /trapped/ ? "ok 1\n" : "not ok 1\n# $@\n"; - -eval <<'EOP'; - use ops ':default'; # equiv to "perl -M(as above) -Mops=:default" - eval 1; -EOP - -print $@ =~ /trapped/ ? "ok 2\n" : "not ok 2\n# $@\n"; - -1; diff --git a/contrib/perl5/t/lib/parsewords.t b/contrib/perl5/t/lib/parsewords.t deleted file mode 100755 index 261d81f..0000000 --- a/contrib/perl5/t/lib/parsewords.t +++ /dev/null @@ -1,110 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use warnings; -use Text::ParseWords; - -print "1..18\n"; - -@words = shellwords(qq(foo "bar quiz" zoo)); -print "not " if $words[0] ne 'foo'; -print "ok 1\n"; -print "not " if $words[1] ne 'bar quiz'; -print "ok 2\n"; -print "not " if $words[2] ne 'zoo'; -print "ok 3\n"; - -{ - # Gonna get some undefined things back - no warnings 'uninitialized' ; - - # Test quotewords() with other parameters and null last field - @words = quotewords(':+', 1, 'foo:::"bar:foo":zoo zoo:'); - print "not " unless join(";", @words) eq qq(foo;"bar:foo";zoo zoo;); - print "ok 4\n"; -} - -# Test $keep eq 'delimiters' and last field zero -@words = quotewords('\s+', 'delimiters', '4 3 2 1 0'); -print "not " unless join(";", @words) eq qq(4; ;3; ;2; ;1; ;0); -print "ok 5\n"; - -# Big ol' nasty test (thanks, Joerk!) -$string = 'aaaa"bbbbb" cc\\ cc \\\\\\"dddd" eee\\\\\\"ffff" "gg"'; - -# First with $keep == 1 -$result = join('|', parse_line('\s+', 1, $string)); -print "not " unless $result eq 'aaaa"bbbbb"|cc\\ cc|\\\\\\"dddd" eee\\\\\\"ffff"|"gg"'; -print "ok 6\n"; - -# Now, $keep == 0 -$result = join('|', parse_line('\s+', 0, $string)); -print "not " unless $result eq 'aaaabbbbb|cc cc|\\"dddd eee\\"ffff|gg'; -print "ok 7\n"; - -# Now test single quote behavior -$string = 'aaaa"bbbbb" cc\\ cc \\\\\\"dddd\' eee\\\\\\"ffff\' gg'; -$result = join('|', parse_line('\s+', 0, $string)); -print "not " unless $result eq 'aaaabbbbb|cc cc|\\"dddd eee\\\\\\"ffff|gg'; -print "ok 8\n"; - -# Make sure @nested_quotewords does the right thing -@lists = nested_quotewords('\s+', 0, 'a b c', '1 2 3', 'x y z'); -print "not " unless (@lists == 3 && @{$lists[0]} == 3 && @{$lists[1]} == 3 && @{$lists[2]} == 3); -print "ok 9\n"; - -# Now test error return -$string = 'foo bar baz"bach blech boop'; - -@words = shellwords($string); -print "not " if (@words); -print "ok 10\n"; - -@words = parse_line('s+', 0, $string); -print "not " if (@words); -print "ok 11\n"; - -@words = quotewords('s+', 0, $string); -print "not " if (@words); -print "ok 12\n"; - -{ - # Gonna get some more undefined things back - no warnings 'uninitialized' ; - - @words = nested_quotewords('s+', 0, $string); - print "not " if (@words); - print "ok 13\n"; - - # Now test empty fields - $result = join('|', parse_line(':', 0, 'foo::0:"":::')); - print "not " unless ($result eq 'foo||0||||'); - print "ok 14\n"; - - # Test for 0 in quotes without $keep - $result = join('|', parse_line(':', 0, ':"0":')); - print "not " unless ($result eq '|0|'); - print "ok 15\n"; - - # Test for \001 in quoted string - $result = join('|', parse_line(':', 0, ':"' . "\001" . '":')); - print "not " unless ($result eq "|\1|"); - print "ok 16\n"; - -} - -# Now test perlish single quote behavior -$Text::ParseWords::PERL_SINGLE_QUOTE = 1; -$string = 'aaaa"bbbbb" cc\ cc \\\\\"dddd\' eee\\\\\"\\\'ffff\' gg'; -$result = join('|', parse_line('\s+', 0, $string)); -print "not " unless $result eq 'aaaabbbbb|cc cc|\"dddd eee\\\\"\'ffff|gg'; -print "ok 17\n"; - -# test whitespace in the delimiters -@words = quotewords(' ', 1, '4 3 2 1 0'); -print "not " unless join(";", @words) eq qq(4;3;2;1;0); -print "ok 18\n"; diff --git a/contrib/perl5/t/lib/peek.t b/contrib/perl5/t/lib/peek.t deleted file mode 100755 index fe9cb2c..0000000 --- a/contrib/perl5/t/lib/peek.t +++ /dev/null @@ -1,312 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bPeek\b/) { - print "1..0 # Skip: Devel::Peek was not built\n"; - exit 0; - } -} - -use Devel::Peek; - -print "1..17\n"; - -our $DEBUG = 0; -open(SAVERR, ">&STDERR") or die "Can't dup STDERR: $!"; - -sub do_test { - my $pattern = pop; - if (open(OUT,">peek$$")) { - open(STDERR, ">&OUT") or die "Can't dup OUT: $!"; - Dump($_[1]); - open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!"; - close(OUT); - if (open(IN, "peek$$")) { - local $/; - $pattern =~ s/\$ADDR/0x[[:xdigit:]]+/g; - print $pattern, "\n" if $DEBUG; - my $dump = <IN>; - print $dump, "\n" if $DEBUG; - print "[$dump] vs [$pattern]\nnot " unless $dump =~ /$pattern/ms; - print "ok $_[0]\n"; - close(IN); - } else { - die "$0: failed to open peek$$: !\n"; - } - } else { - die "$0: failed to create peek$$: $!\n"; - } -} - -our $a; -our $b; -my $c; -local $d = 0; - -do_test( 1, - $a = "foo", -'SV = PV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(POK,pPOK\\) - PV = $ADDR "foo"\\\0 - CUR = 3 - LEN = 4' - ); - -do_test( 2, - "bar", -'SV = PV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(.*POK,READONLY,pPOK\\) - PV = $ADDR "bar"\\\0 - CUR = 3 - LEN = 4'); - -do_test( 3, - $b = 123, -'SV = IV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(IOK,pIOK\\) - IV = 123'); - -do_test( 4, - 456, -'SV = IV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(.*IOK,READONLY,pIOK\\) - IV = 456'); - -do_test( 5, - $c = 456, -'SV = IV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(PADBUSY,PADMY,IOK,pIOK\\) - IV = 456'); - -do_test( 6, - $c + $d, -'SV = NV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(PADTMP,NOK,pNOK\\) - NV = 456'); - -($d = "789") += 0.1; - -do_test( 7, - $d, -'SV = PVNV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(NOK,pNOK\\) - IV = 0 - NV = 789\\.(?:1(?:000+\d+)?|0999+\d+) - PV = $ADDR "789"\\\0 - CUR = 3 - LEN = 4'); - -do_test( 8, - 0xabcd, -'SV = IV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(.*IOK,READONLY,pIOK,IsUV\\) - UV = 43981'); - -do_test( 9, - undef, -'SV = NULL\\(0x0\\) at $ADDR - REFCNT = 1 - FLAGS = \\(\\)'); - -do_test(10, - \$a, -'SV = RV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(ROK\\) - RV = $ADDR - SV = PV\\($ADDR\\) at $ADDR - REFCNT = 2 - FLAGS = \\(POK,pPOK\\) - PV = $ADDR "foo"\\\0 - CUR = 3 - LEN = 4'); - -do_test(11, - [$b,$c], -'SV = RV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(ROK\\) - RV = $ADDR - SV = PVAV\\($ADDR\\) at $ADDR - REFCNT = 2 - FLAGS = \\(\\) - IV = 0 - NV = 0 - ARRAY = $ADDR - FILL = 1 - MAX = 1 - ARYLEN = 0x0 - FLAGS = \\(REAL\\) - Elt No. 0 - SV = IV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(IOK,pIOK\\) - IV = 123 - Elt No. 1 - SV = PVNV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(IOK,NOK,pIOK,pNOK\\) - IV = 456 - NV = 456 - PV = 0'); - -do_test(12, - {$b=>$c}, -'SV = RV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(ROK\\) - RV = $ADDR - SV = PVHV\\($ADDR\\) at $ADDR - REFCNT = 2 - FLAGS = \\(SHAREKEYS\\) - IV = 1 - NV = 0 - ARRAY = $ADDR \\(0:7, 1:1\\) - hash quality = 150.0% - KEYS = 1 - FILL = 1 - MAX = 7 - RITER = -1 - EITER = 0x0 - Elt "123" HASH = $ADDR - SV = PVNV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(IOK,NOK,pIOK,pNOK\\) - IV = 456 - NV = 456 - PV = 0'); - -do_test(13, - sub(){@_}, -'SV = RV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(ROK\\) - RV = $ADDR - SV = PVCV\\($ADDR\\) at $ADDR - REFCNT = 2 - FLAGS = \\(PADBUSY,PADMY,POK,pPOK,ANON\\) - IV = 0 - NV = 0 - PROTOTYPE = "" - COMP_STASH = $ADDR\\t"main" - START = $ADDR ===> \\d+ - ROOT = $ADDR - XSUB = 0x0 - XSUBANY = 0 - GVGV::GV = $ADDR\\t"main" :: "__ANON__[^"]*" - FILE = ".*\\b(?i:peek\\.t)" - DEPTH = 0 -(?: MUTEXP = $ADDR - OWNER = $ADDR -)? FLAGS = 0x4 - PADLIST = $ADDR - OUTSIDE = $ADDR \\(MAIN\\)'); - -do_test(14, - \&do_test, -'SV = RV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(ROK\\) - RV = $ADDR - SV = PVCV\\($ADDR\\) at $ADDR - REFCNT = (3|4) - FLAGS = \\(\\) - IV = 0 - NV = 0 - COMP_STASH = $ADDR\\t"main" - START = $ADDR ===> \\d+ - ROOT = $ADDR - XSUB = 0x0 - XSUBANY = 0 - GVGV::GV = $ADDR\\t"main" :: "do_test" - FILE = ".*\\b(?i:peek\\.t)" - DEPTH = 1 -(?: MUTEXP = $ADDR - OWNER = $ADDR -)? FLAGS = 0x0 - PADLIST = $ADDR - \\d+\\. $ADDR \\("\\$pattern" \\d+-\\d+\\) - \\d+\\. $ADDR \\(FAKE "\\$DEBUG" 0-\\d+\\) - \\d+\\. $ADDR \\("\\$dump" \\d+-\\d+\\) - OUTSIDE = $ADDR \\(MAIN\\)'); - -do_test(15, - qr(tic), -'SV = RV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(ROK\\) - RV = $ADDR - SV = PVMG\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(OBJECT,RMG\\) - IV = 0 - NV = 0 - PV = 0 - MAGIC = $ADDR - MG_VIRTUAL = $ADDR - MG_TYPE = \'r\' - MG_OBJ = $ADDR - STASH = $ADDR\\t"Regexp"'); - -do_test(16, - (bless {}, "Tac"), -'SV = RV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(ROK\\) - RV = $ADDR - SV = PVHV\\($ADDR\\) at $ADDR - REFCNT = 2 - FLAGS = \\(OBJECT,SHAREKEYS\\) - IV = 0 - NV = 0 - STASH = $ADDR\\t"Tac" - ARRAY = 0x0 - KEYS = 0 - FILL = 0 - MAX = 7 - RITER = -1 - EITER = 0x0'); - -do_test(17, - *a, -'SV = PVGV\\($ADDR\\) at $ADDR - REFCNT = 5 - FLAGS = \\(GMG,SMG,MULTI(?:,IN_PAD)?\\) - IV = 0 - NV = 0 - MAGIC = $ADDR - MG_VIRTUAL = &PL_vtbl_glob - MG_TYPE = \'\\*\' - MG_OBJ = $ADDR - NAME = "a" - NAMELEN = 1 - GvSTASH = $ADDR\\t"main" - GP = $ADDR - SV = $ADDR - REFCNT = 1 - IO = 0x0 - FORM = 0x0 - AV = 0x0 - HV = 0x0 - CV = 0x0 - CVGEN = 0x0 - GPFLAGS = 0x0 - LINE = \\d+ - FILE = ".*\\b(?i:peek\\.t)" - FLAGS = $ADDR - EGV = $ADDR\\t"a"'); - -END { - 1 while unlink("peek$$"); -} diff --git a/contrib/perl5/t/lib/ph.t b/contrib/perl5/t/lib/ph.t deleted file mode 100755 index de27dee..0000000 --- a/contrib/perl5/t/lib/ph.t +++ /dev/null @@ -1,96 +0,0 @@ -#!./perl - -# Check for presence and correctness of .ph files; for now, -# just socket.ph and pals. -# -- Kurt Starsinic <kstar@isinet.com> - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -# All the constants which Socket.pm tries to make available: -my @possibly_defined = qw( - INADDR_ANY INADDR_LOOPBACK INADDR_NONE AF_802 AF_APPLETALK AF_CCITT - AF_CHAOS AF_DATAKIT AF_DECnet AF_DLI AF_ECMA AF_GOSIP AF_HYLINK AF_IMPLINK - AF_INET AF_LAT AF_MAX AF_NBS AF_NIT AF_NS AF_OSI AF_OSINET AF_PUP - AF_SNA AF_UNIX AF_UNSPEC AF_X25 MSG_DONTROUTE MSG_MAXIOVLEN MSG_OOB - MSG_PEEK PF_802 PF_APPLETALK PF_CCITT PF_CHAOS PF_DATAKIT PF_DECnet PF_DLI - PF_ECMA PF_GOSIP PF_HYLINK PF_IMPLINK PF_INET PF_LAT PF_MAX PF_NBS PF_NIT - PF_NS PF_OSI PF_OSINET PF_PUP PF_SNA PF_UNIX PF_UNSPEC PF_X25 SOCK_DGRAM - SOCK_RAW SOCK_RDM SOCK_SEQPACKET SOCK_STREAM SOL_SOCKET SOMAXCONN - SO_ACCEPTCONN SO_BROADCAST SO_DEBUG SO_DONTLINGER SO_DONTROUTE SO_ERROR - SO_KEEPALIVE SO_LINGER SO_OOBINLINE SO_RCVBUF SO_RCVLOWAT SO_RCVTIMEO - SO_REUSEADDR SO_SNDBUF SO_SNDLOWAT SO_SNDTIMEO SO_TYPE SO_USELOOPBACK -); - - -# The libraries which I'm going to require: -my @libs = qw(Socket "sys/types.ph" "sys/socket.ph" "netinet/in.ph"); - - -# These are defined by Socket.pm even if the C header files don't define them: -my %ok_to_miss = ( - INADDR_NONE => 1, - INADDR_LOOPBACK => 1, -); - - -my $total_tests = scalar @libs + scalar @possibly_defined; -my $i = 0; - -print "1..$total_tests\n"; - - -foreach (@libs) { - $i++; - - if (eval "require $_" ) { - print "ok $i\n"; - } else { - print "# Skipping tests; $_ may be missing\n"; - foreach ($i .. $total_tests) { print "ok $_\n" } - exit; - } -} - - -foreach (@possibly_defined) { - $i++; - - $pm_val = eval "Socket::$_()"; - $ph_val = eval "main::$_()"; - - if (defined $pm_val and !defined $ph_val) { - if ($ok_to_miss{$_}) { print "ok $i\n" } - else { print "not ok $i\n" } - next; - } elsif (defined $ph_val and !defined $pm_val) { - print "not ok $i\n"; - next; - } - - # Socket.pm converts these to network byte order, so we convert the - # socket.ph version to match; note that these cases skip the following - # `elsif', which is only applied to _numeric_ values, not literal - # bitmasks. - if ($_ eq 'INADDR_ANY' - or $_ eq 'INADDR_LOOPBACK' - or $_ eq 'INADDR_NONE') { - $ph_val = pack("N*", $ph_val); # htonl(3) equivalent - } - - # Since Socket.pm and socket.ph wave their hands over macros differently, - # they could return functionally equivalent bitmaps with different numeric - # interpretations (due to sign extension). The only apparent case of this - # is SO_DONTLINGER (only on Solaris, and deprecated, at that): - elsif ($pm_val != $ph_val) { - $pm_val = oct(sprintf "0x%lx", $pm_val); - $ph_val = oct(sprintf "0x%lx", $ph_val); - } - - if ($pm_val == $ph_val) { print "ok $i\n" } - else { print "not ok $i\n" } -} - - diff --git a/contrib/perl5/t/lib/posix.t b/contrib/perl5/t/lib/posix.t deleted file mode 100755 index 994704a..0000000 --- a/contrib/perl5/t/lib/posix.t +++ /dev/null @@ -1,137 +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_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.14158999\d*$/3.14159/ - if $Config{uselongdouble} eq 'define'; - print (($n == 3.14159) && ($x == 6) ? "ok 14\n" : "not ok 14\n"); - &POSIX::setlocale(&POSIX::LC_NUMERIC, $lc) if $Config{d_setlocale}; -} else { print "# strtod not present\n", "ok 14\n"; } - -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/contrib/perl5/t/lib/safe1.t b/contrib/perl5/t/lib/safe1.t deleted file mode 100755 index 27993d9..0000000 --- a/contrib/perl5/t/lib/safe1.t +++ /dev/null @@ -1,68 +0,0 @@ -#!./perl -w -$|=1; -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { - print "1..0\n"; - exit 0; - } -} - -# Tests Todo: -# 'main' as root - -package test; # test from somewhere other than main - -use vars qw($bar); - -use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex - opmask_add full_opset empty_opset opcodes opmask define_optag); - -use Safe 1.00; - -my $last_test; # initalised at end -print "1..$last_test\n"; - -my $t = 1; -my $cpt; -# create and destroy some automatic Safe compartments first -$cpt = new Safe or die; -$cpt = new Safe or die; -$cpt = new Safe or die; - -$cpt = new Safe "Root" or die; - -foreach(1..3) { - $foo = 42; - - $cpt->share(qw($foo)); - - print ${$cpt->varglob('foo')} == 42 ? "ok $t\n" : "not ok $t\n"; $t++; - - ${$cpt->varglob('foo')} = 9; - - print $foo == 9 ? "ok $t\n" : "not ok $t\n"; $t++; - - print $cpt->reval('$foo') == 9 ? "ok $t\n" : "not ok $t\n"; $t++; - # check 'main' has been changed: - print $cpt->reval('$::foo') == 9 ? "ok $t\n" : "not ok $t\n"; $t++; - print $cpt->reval('$main::foo') == 9 ? "ok $t\n" : "not ok $t\n"; $t++; - # check we can't see our test package: - print $cpt->reval('$test::foo') ? "not ok $t\n" : "ok $t\n"; $t++; - print $cpt->reval('${"test::foo"}') ? "not ok $t\n" : "ok $t\n"; $t++; - - $cpt->erase; # erase the compartment, e.g., delete all variables - - print $cpt->reval('$foo') ? "not ok $t\n" : "ok $t\n"; $t++; - - # Note that we *must* use $cpt->varglob here because if we used - # $Root::foo etc we would still see the original values! - # This seems to be because the compiler has created an extra ref. - - print ${$cpt->varglob('foo')} ? "not ok $t\n" : "ok $t\n"; $t++; -} - -print "ok $last_test\n"; -BEGIN { $last_test = 28 } diff --git a/contrib/perl5/t/lib/safe2.t b/contrib/perl5/t/lib/safe2.t deleted file mode 100755 index 4d6c84a..0000000 --- a/contrib/perl5/t/lib/safe2.t +++ /dev/null @@ -1,145 +0,0 @@ -#!./perl -w -$|=1; -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { - print "1..0\n"; - exit 0; - } - # test 30 rather naughtily expects English error messages - $ENV{'LC_ALL'} = 'C'; - $ENV{LANGUAGE} = 'C'; # GNU locale extension -} - -# Tests Todo: -# 'main' as root - -use vars qw($bar); - -use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex - opmask_add full_opset empty_opset opcodes opmask define_optag); - -use Safe 1.00; - -my $last_test; # initalised at end -print "1..$last_test\n"; - -# Set up a package namespace of things to be visible to the unsafe code -$Root::foo = "visible"; -$bar = "invisible"; - -# Stop perl from moaning about identifies which are apparently only used once -$Root::foo .= ""; - -my $cpt; -# create and destroy a couple of automatic Safe compartments first -$cpt = new Safe or die; -$cpt = new Safe or die; - -$cpt = new Safe "Root"; - -$cpt->reval(q{ system("echo not ok 1"); }); -if ($@ =~ /^system trapped by operation mask/) { - print "ok 1\n"; -} else { - print "#$@" if $@; - print "not ok 1\n"; -} - -$cpt->reval(q{ - print $foo eq 'visible' ? "ok 2\n" : "not ok 2\n"; - print $main::foo eq 'visible' ? "ok 3\n" : "not ok 3\n"; - print defined($bar) ? "not ok 4\n" : "ok 4\n"; - print defined($::bar) ? "not ok 5\n" : "ok 5\n"; - print defined($main::bar) ? "not ok 6\n" : "ok 6\n"; -}); -print $@ ? "not ok 7\n#$@" : "ok 7\n"; - -$foo = "ok 8\n"; -%bar = (key => "ok 9\n"); -@baz = (); push(@baz, "o", "10"); $" = 'k '; -$glob = "ok 11\n"; -@glob = qw(not ok 16); - -sub sayok { print "ok @_\n" } - -$cpt->share(qw($foo %bar @baz *glob sayok)); -$cpt->share('$"') unless $Config{use5005threads}; - -$cpt->reval(q{ - package other; - sub other_sayok { print "ok @_\n" } - package main; - print $foo ? $foo : "not ok 8\n"; - print $bar{key} ? $bar{key} : "not ok 9\n"; - (@baz) ? print "@baz\n" : print "not ok 10\n"; - print $glob; - other::other_sayok(12); - $foo =~ s/8/14/; - $bar{new} = "ok 15\n"; - @glob = qw(ok 16); -}); -print $@ ? "not ok 13\n#$@" : "ok 13\n"; -$" = ' '; -print $foo, $bar{new}, "@glob\n"; - -$Root::foo = "not ok 17"; -@{$cpt->varglob('bar')} = qw(not ok 18); -${$cpt->varglob('foo')} = "ok 17"; -@Root::bar = "ok"; -push(@Root::bar, "18"); # Two steps to prevent "Identifier used only once..." - -print "$Root::foo\n"; -print "@{$cpt->varglob('bar')}\n"; - -use strict; - -print 1 ? "ok 19\n" : "not ok 19\n"; -print 1 ? "ok 20\n" : "not ok 20\n"; - -my $m1 = $cpt->mask; -$cpt->trap("negate"); -my $m2 = $cpt->mask; -my @masked = opset_to_ops($m1); -print $m2 eq opset("negate", @masked) ? "ok 21\n" : "not ok 21\n"; - -print eval { $cpt->mask("a bad mask") } ? "not ok 22\n" : "ok 22\n"; - -print $cpt->reval("2 + 2") == 4 ? "ok 23\n" : "not ok 23\n"; - -$cpt->mask(empty_opset); -my $t_scalar = $cpt->reval('print wantarray ? "not ok 24\n" : "ok 24\n"'); -print $cpt->reval('@ary=(6,7,8);@ary') == 3 ? "ok 25\n" : "not ok 25\n"; -my @t_array = $cpt->reval('print wantarray ? "ok 26\n" : "not ok 26\n"; (2,3,4)'); -print $t_array[2] == 4 ? "ok 27\n" : "not ok 27\n"; - -my $t_scalar2 = $cpt->reval('die "foo bar"; 1'); -print defined $t_scalar2 ? "not ok 28\n" : "ok 28\n"; -print $@ =~ /foo bar/ ? "ok 29\n" : "not ok 29\n"; - -# --- rdo - -my $t = 30; -$cpt->rdo('/non/existant/file.name'); -# The regexp is getting rather baroque. -print $! =~ /cannot find|No such file|file specification syntax error|A file or directory in the path name does not exist|Invalid argument|Device not configured|file not found|File or directory doesn't exist/i ? "ok $t\n" : "not ok $t # $!\n"; $t++; -# test #31 is gone. -print 1 ? "ok $t\n" : "not ok $t\n#$@/$!\n"; $t++; - -#my $rdo_file = "tmp_rdo.tpl"; -#if (open X,">$rdo_file") { -# print X "999\n"; -# close X; -# $cpt->permit_only('const', 'leaveeval'); -# print $cpt->rdo($rdo_file) == 999 ? "ok $t\n" : "not ok $t\n"; $t++; -# unlink $rdo_file; -#} -#else { -# print "# test $t skipped, can't open file: $!\nok $t\n"; $t++; -#} - - -print "ok $last_test\n"; -BEGIN { $last_test = 32 } diff --git a/contrib/perl5/t/lib/sdbm.t b/contrib/perl5/t/lib/sdbm.t deleted file mode 100755 index 3221ca4..0000000 --- a/contrib/perl5/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 '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/contrib/perl5/t/lib/searchdict.t b/contrib/perl5/t/lib/searchdict.t deleted file mode 100755 index c36fdb8..0000000 --- a/contrib/perl5/t/lib/searchdict.t +++ /dev/null @@ -1,87 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..4\n"; - -$DICT = <<EOT; -Aarhus -Aaron -Ababa -aback -abaft -abandon -abandoned -abandoning -abandonment -abandons -abase -abased -abasement -abasements -abases -abash -abashed -abashes -abashing -abasing -abate -abated -abatement -abatements -abater -abates -abating -Abba -EOT - -use Search::Dict; - -open(DICT, "+>dict-$$") or die "Can't create dict-$$: $!"; -binmode DICT; # To make length expected one. -print DICT $DICT; - -my $pos = look *DICT, "Ababa"; -chomp($word = <DICT>); -print "not " if $pos < 0 || $word ne "Ababa"; -print "ok 1\n"; - -if (ord('a') > ord('A') ) { # ASCII - - $pos = look *DICT, "foo"; - chomp($word = <DICT>); - - print "not " if $pos != length($DICT); # will search to end of file - print "ok 2\n"; - - my $pos = look *DICT, "abash"; - chomp($word = <DICT>); - print "not " if $pos < 0 || $word ne "abash"; - print "ok 3\n"; - -} -else { # EBCDIC systems e.g. os390 - - $pos = look *DICT, "FOO"; - chomp($word = <DICT>); - - print "not " if $pos != length($DICT); # will search to end of file - print "ok 2\n"; - - my $pos = look *DICT, "Abba"; - chomp($word = <DICT>); - print "not " if $pos < 0 || $word ne "Abba"; - print "ok 3\n"; -} - -$pos = look *DICT, "aarhus", 1, 1; -chomp($word = <DICT>); - -print "not " if $pos < 0 || $word ne "Aarhus"; -print "ok 4\n"; - -close DICT or die "cannot close"; -unlink "dict-$$"; diff --git a/contrib/perl5/t/lib/selectsaver.t b/contrib/perl5/t/lib/selectsaver.t deleted file mode 100755 index 3b58d70..0000000 --- a/contrib/perl5/t/lib/selectsaver.t +++ /dev/null @@ -1,28 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..3\n"; - -use SelectSaver; - -open(FOO, ">foo-$$") || die; - -print "ok 1\n"; -{ - my $saver = new SelectSaver(FOO); - print "foo\n"; -} - -# Get data written to file -open(FOO, "foo-$$") || die; -chomp($foo = <FOO>); -close FOO; -unlink "foo-$$"; - -print "ok 2\n" if $foo eq "foo"; - -print "ok 3\n"; diff --git a/contrib/perl5/t/lib/selfloader.t b/contrib/perl5/t/lib/selfloader.t deleted file mode 100755 index 6b9c244..0000000 --- a/contrib/perl5/t/lib/selfloader.t +++ /dev/null @@ -1,201 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - $dir = "self-$$"; - @INC = $dir; - push @INC, '../lib'; - - print "1..19\n"; - - # First we must set up some selfloader files - mkdir $dir, 0755 or die "Can't mkdir $dir: $!"; - - open(FOO, ">$dir/Foo.pm") or die; - print FOO <<'EOT'; -package Foo; -use SelfLoader; - -sub new { bless {}, shift } -sub foo; -sub bar; -sub bazmarkhianish; -sub a; -sub never; # declared but definition should never be read -1; -__DATA__ - -sub foo { shift; shift || "foo" }; - -sub bar { shift; shift || "bar" } - -sub bazmarkhianish { shift; shift || "baz" } - -package sheep; -sub bleat { shift; shift || "baa" } - -__END__ -sub never { die "D'oh" } -EOT - - close(FOO); - - open(BAR, ">$dir/Bar.pm") or die; - print BAR <<'EOT'; -package Bar; -use SelfLoader; - -@ISA = 'Baz'; - -sub new { bless {}, shift } -sub a; - -1; -__DATA__ - -sub a { 'a Bar'; } -sub b { 'b Bar' } - -__END__ DATA -sub never { die "D'oh" } -EOT - - close(BAR); -}; - - -package Baz; - -sub a { 'a Baz' } -sub b { 'b Baz' } -sub c { 'c Baz' } - - -package main; -use Foo; -use Bar; - -$foo = new Foo; - -print "not " unless $foo->foo eq 'foo'; # selfloaded first time -print "ok 1\n"; - -print "not " unless $foo->foo eq 'foo'; # regular call -print "ok 2\n"; - -# Try an undefined method -eval { - $foo->will_fail; -}; -if ($@ =~ /^Undefined subroutine/) { - print "ok 3\n"; -} else { - print "not ok 3 $@\n"; -} - -# Used to be trouble with this -eval { - my $foo = new Foo; - die "oops"; -}; -if ($@ =~ /oops/) { - print "ok 4\n"; -} else { - print "not ok 4 $@\n"; -} - -# Pass regular expression variable to autoloaded function. This used -# to go wrong in AutoLoader because it used regular expressions to generate -# autoloaded filename. -"foo" =~ /(\w+)/; -print "not " unless $1 eq 'foo'; -print "ok 5\n"; - -print "not " unless $foo->bar($1) eq 'foo'; -print "ok 6\n"; - -print "not " unless $foo->bar($1) eq 'foo'; -print "ok 7\n"; - -print "not " unless $foo->bazmarkhianish($1) eq 'foo'; -print "ok 8\n"; - -print "not " unless $foo->bazmarkhianish($1) eq 'foo'; -print "ok 9\n"; - -# Check nested packages inside __DATA__ -print "not " unless sheep::bleat() eq 'baa'; -print "ok 10\n"; - -# Now check inheritance: - -$bar = new Bar; - -# Before anything is SelfLoaded there is no declaration of Foo::b so we should -# get Baz::b -print "not " unless $bar->b() eq 'b Baz'; -print "ok 11\n"; - -# There is no Bar::c so we should get Baz::c -print "not " unless $bar->c() eq 'c Baz'; -print "ok 12\n"; - -# This selfloads Bar::a because it is stubbed. It also stubs Bar::b as a side -# effect -print "not " unless $bar->a() eq 'a Bar'; -print "ok 13\n"; - -print "not " unless $bar->b() eq 'b Bar'; -print "ok 14\n"; - -print "not " unless $bar->c() eq 'c Baz'; -print "ok 15\n"; - - - -# Check that __END__ is honoured -# Try an subroutine that should never be noticed by selfloader -eval { - $foo->never; -}; -if ($@ =~ /^Undefined subroutine/) { - print "ok 16\n"; -} else { - print "not ok 16 $@\n"; -} - -# Try to read from the data file handle -my $foodata = <Foo::DATA>; -close Foo::DATA; -if (defined $foodata) { - print "not ok 17 # $foodata\n"; -} else { - print "ok 17\n"; -} - -# Check that __END__ DATA is honoured -# Try an subroutine that should never be noticed by selfloader -eval { - $bar->never; -}; -if ($@ =~ /^Undefined subroutine/) { - print "ok 18\n"; -} else { - print "not ok 18 $@\n"; -} - -# Try to read from the data file handle -my $bardata = <Bar::DATA>; -close Bar::DATA; -if ($bardata ne "sub never { die \"D'oh\" }\n") { - print "not ok 19 # $bardata\n"; -} else { - print "ok 19\n"; -} - -# cleanup -END { -return unless $dir && -d $dir; -unlink "$dir/Foo.pm", "$dir/Bar.pm"; -rmdir "$dir"; -} diff --git a/contrib/perl5/t/lib/socket.t b/contrib/perl5/t/lib/socket.t deleted file mode 100755 index 481fd8f..0000000 --- a/contrib/perl5/t/lib/socket.t +++ /dev/null @@ -1,87 +0,0 @@ -#!./perl - -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\n"; - exit 0; - } -} - -use Socket; - -print "1..8\n"; - -if (socket(T,PF_INET,SOCK_STREAM,6)) { - print "ok 1\n"; - - if (connect(T,pack_sockaddr_in(7,inet_aton("localhost")))){ - print "ok 2\n"; - - print "# Connected to " . - inet_ntoa((unpack_sockaddr_in(getpeername(T)))[1])."\n"; - - syswrite(T,"hello",5); - $read = sysread(T,$buff,10); # Connection may be granted, then closed! - while ($read > 0 && length($buff) < 5) { - # adjust for fact that TCP doesn't guarantee size of reads/writes - $read = sysread(T,$buff,10,length($buff)); - } - print(($read == 0 || $buff eq "hello") ? "ok 3\n" : "not ok 3\n"); - } - else { - print "# You're allowed to fail tests 2 and 3 if.\n"; - print "# The echo service has been disabled.\n"; - print "# $!\n"; - print "ok 2\n"; - print "ok 3\n"; - } -} -else { - print "# $!\n"; - print "not ok 1\n"; -} - -if( socket(S,PF_INET,SOCK_STREAM,6) ){ - print "ok 4\n"; - - if (connect(S,pack_sockaddr_in(7,INADDR_LOOPBACK))){ - print "ok 5\n"; - - print "# Connected to " . - inet_ntoa((unpack_sockaddr_in(getpeername(S)))[1])."\n"; - - syswrite(S,"olleh",5); - $read = sysread(S,$buff,10); # Connection may be granted, then closed! - while ($read > 0 && length($buff) < 5) { - # adjust for fact that TCP doesn't guarantee size of reads/writes - $read = sysread(S,$buff,10,length($buff)); - } - print(($read == 0 || $buff eq "olleh") ? "ok 6\n" : "not ok 6\n"); - } - else { - print "# You're allowed to fail tests 5 and 6 if.\n"; - print "# The echo service has been disabled.\n"; - print "# $!\n"; - print "ok 5\n"; - print "ok 6\n"; - } -} -else { - print "# $!\n"; - print "not ok 4\n"; -} - -# warnings -$SIG{__WARN__} = sub { - ++ $w if $_[0] =~ /^6-ARG sockaddr_in call is deprecated/ ; -} ; -$w = 0 ; -sockaddr_in(1,2,3,4,5,6) ; -print ($w == 1 ? "not ok 7\n" : "ok 7\n") ; -use warnings 'Socket' ; -sockaddr_in(1,2,3,4,5,6) ; -print ($w == 1 ? "ok 8\n" : "not ok 8\n") ; diff --git a/contrib/perl5/t/lib/soundex.t b/contrib/perl5/t/lib/soundex.t deleted file mode 100755 index d35f264..0000000 --- a/contrib/perl5/t/lib/soundex.t +++ /dev/null @@ -1,143 +0,0 @@ -#!./perl -# -# $Id: soundex.t,v 1.2 1994/03/24 00:30:27 mike Exp $ -# -# test module for soundex.pl -# -# $Log: soundex.t,v $ -# Revision 1.2 1994/03/24 00:30:27 mike -# Subtle bug (any excuse :-) spotted by Rich Pinder <rpinder@hsc.usc.edu> -# in the way I handles leasing characters which were different but had -# the same soundex code. This showed up comparing it with Oracle's -# soundex output. -# -# Revision 1.1 1994/03/02 13:03:02 mike -# Initial revision -# -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Text::Soundex; - -$test = 0; -print "1..13\n"; - -while (<DATA>) -{ - chop; - next if /^\s*;?#/; - next if /^\s*$/; - - ++$test; - $bad = 0; - - if (/^eval\s+/) - { - ($try = $_) =~ s/^eval\s+//; - - eval ($try); - if ($@) - { - $bad++; - print "not ok $test\n"; - print "# eval '$try' returned $@"; - } - } - elsif (/^\(/) - { - ($in, $out) = split (':'); - - $try = "\@expect = $out; \@got = &soundex $in;"; - eval ($try); - - if (@expect != @got) - { - $bad++; - print "not ok $test\n"; - print "# expected ", scalar @expect, " results, got ", scalar @got, "\n"; - print "# expected (", join (', ', @expect), - ") got (", join (', ', @got), ")\n"; - } - else - { - while (@got) - { - $expect = shift @expect; - $got = shift @got; - - if ($expect ne $got) - { - $bad++; - print "not ok $test\n"; - print "# expected $expect, got $got\n"; - } - } - } - } - else - { - ($in, $out) = split (':'); - - $try = "\$expect = $out; \$got = &soundex ($in);"; - eval ($try); - - if ($expect ne $got) - { - $bad++; - print "not ok $test\n"; - print "# expected $expect, got $got\n"; - } - } - - print "ok $test\n" unless $bad; -} - -__END__ -# -# 1..6 -# -# Knuth's test cases, scalar in, scalar out -# -'Euler':'E460' -'Gauss':'G200' -'Hilbert':'H416' -'Knuth':'K530' -'Lloyd':'L300' -'Lukasiewicz':'L222' -# -# 7..8 -# -# check default bad code -# -'2 + 2 = 4':undef -undef:undef -# -# 9 -# -# check array in, array out -# -('Ellery', 'Ghosh', 'Heilbronn', 'Kant', 'Ladd', 'Lissajous'):('E460', 'G200', 'H416', 'K530', 'L300', 'L222') -# -# 10 -# -# check array with explicit undef -# -('Mike', undef, 'Stok'):('M200', undef, 'S320') -# -# 11..12 -# -# check setting $Text::Soundex::noCode -# -eval $soundex_nocode = 'Z000'; -('Mike', undef, 'Stok'):('M200', 'Z000', 'S320') -# -# 13 -# -# a subtle difference between me & oracle, spotted by Rich Pinder -# <rpinder@hsc.usc.edu> -# -CZARKOWSKA:C622 diff --git a/contrib/perl5/t/lib/symbol.t b/contrib/perl5/t/lib/symbol.t deleted file mode 100755 index 03449a3..0000000 --- a/contrib/perl5/t/lib/symbol.t +++ /dev/null @@ -1,52 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..8\n"; - -BEGIN { $_ = 'foo'; } # because Symbol used to clobber $_ - -use Symbol; - -# First check $_ clobbering -print "not " if $_ ne 'foo'; -print "ok 1\n"; - - -# First test gensym() -$sym1 = gensym; -print "not " if ref($sym1) ne 'GLOB'; -print "ok 2\n"; - -$sym2 = gensym; - -print "not " if $sym1 eq $sym2; -print "ok 3\n"; - -ungensym $sym1; - -$sym1 = $sym2 = undef; - - -# Test qualify() -package foo; - -use Symbol qw(qualify); # must import into this package too - -qualify("x") eq "foo::x" or print "not "; -print "ok 4\n"; - -qualify("x", "FOO") eq "FOO::x" or print "not "; -print "ok 5\n"; - -qualify("BAR::x") eq "BAR::x" or print "not "; -print "ok 6\n"; - -qualify("STDOUT") eq "main::STDOUT" or print "not "; -print "ok 7\n"; - -qualify("ARGV", "FOO") eq "main::ARGV" or print "not "; -print "ok 8\n"; diff --git a/contrib/perl5/t/lib/syslfs.t b/contrib/perl5/t/lib/syslfs.t deleted file mode 100755 index 2bdb69d..0000000 --- a/contrib/perl5/t/lib/syslfs.t +++ /dev/null @@ -1,265 +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; - -our @s; -our $fail; - -sub zap { - close(BIG); - unlink("big"); - unlink("big1"); - unlink("big2"); -} - -sub bye { - zap(); - exit(0); -} - -my $explained; - -sub explain { - unless ($explained++) { - print <<EOM; -# -# If the lfs (large file support: large meaning larger than two -# gigabytes) tests are skipped or fail, it may mean either that your -# process (or process group) is not allowed to write large files -# (resource limits) or that the file system (the network filesystem?) -# you are running the tests on doesn't let your user/group have large -# files (quota) or the filesystem simply doesn't support large files. -# You may even need to reconfigure your kernel. (This is all very -# operating system and site-dependent.) -# -# Perl may still be able to support large files, once you have -# such a process, enough quota, and such a (file) system. -# It is just that the test failed now. -# -EOM - } - print "1..0 # Skip: @_\n" if @_; -} - -print "# checking whether we have sparse files...\n"; - -# Known have-nots. -if ($^O eq 'MSWin32' || $^O eq 'VMS') { - 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/contrib/perl5/t/lib/syslog.t b/contrib/perl5/t/lib/syslog.t deleted file mode 100755 index cd2fad7..0000000 --- a/contrib/perl5/t/lib/syslog.t +++ /dev/null @@ -1,59 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bSyslog\b/) { - print "1..0 # Skip: Sys::Syslog was not built\n"; - exit 0; - } - - require Socket; - - # This code inspired by Sys::Syslog::connect(): - require Sys::Hostname; - my ($host_uniq) = Sys::Hostname::hostname(); - my ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; - - if (! defined Socket::inet_aton($host)) { - print "1..0 # Skip: Can't lookup $host\n"; - exit 0; - } -} - -BEGIN { - eval {require Sys::Syslog} or do { - if ($@ =~ /Your vendor has not/) { - print "1..0 # Skipped: missing macros\n"; - exit 0; - } - } -} - -use Sys::Syslog qw(:DEFAULT setlogsock); - -print "1..6\n"; - -if (Sys::Syslog::_PATH_LOG()) { - if (-e Sys::Syslog::_PATH_LOG()) { - print defined(eval { setlogsock('unix') }) ? "ok 1\n" : "not ok 1\n"; - print defined(eval { openlog('perl', 'ndelay', 'local0') }) ? "ok 2\n" : "not ok 2\n"; - print defined(eval { syslog('info', 'test') }) ? "ok 3\n" : "not ok 3\n"; - } - else { - for (1..3) { - print - "ok $_ # skipping, file ", - Sys::Syslog::_PATH_LOG(), - " does not exist\n"; - } - } -} -else { - for (1..3) { print "ok $_ # skipping, _PATH_LOG unavailable\n" } -} - -print defined(eval { setlogsock('inet') }) ? "ok 4\n" : "not ok 4\n"; -print defined(eval { openlog('perl', 'ndelay', 'local0') }) ? "ok 5\n" : "not ok 5\n"; -print defined(eval { syslog('info', 'test') }) ? "ok 6\n" : "not ok 6\n"; diff --git a/contrib/perl5/t/lib/textfill.t b/contrib/perl5/t/lib/textfill.t deleted file mode 100755 index 5ff3850..0000000 --- a/contrib/perl5/t/lib/textfill.t +++ /dev/null @@ -1,98 +0,0 @@ -#!./perl -w - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Text::Wrap qw(&fill); - -@tests = (split(/\nEND\n/s, <<DONE)); -TEST1 -Cyberdog Information - -Cyberdog & Netscape in the news -Important Press Release regarding Cyberdog and Netscape. Check it out! - -Cyberdog Plug-in Support! -Cyberdog support for Netscape Plug-ins is now available to download! Go -to the Cyberdog Beta Download page and download it now! - -Cyberdog Book -Check out Jesse Feiler's way-cool book about Cyberdog. You can find -details out about the book as well as ordering information at Philmont -Software Mill site. - -Java! -Looking to view Java applets in Cyberdog 1.1 Beta 3? Download and install -the Mac OS Runtime for Java and try it out! - -Cyberdog 1.1 Beta 3 -We hope that Cyberdog and OpenDoc 1.1 will be available within the next -two weeks. In the meantime, we have released another version of -Cyberdog, Cyberdog 1.1 Beta 3. This version fixes several bugs that were -reported to us during out public beta period. You can check out our release -notes to see what we fixed! -END - Cyberdog Information - Cyberdog & Netscape in the news Important Press Release regarding - Cyberdog and Netscape. Check it out! - Cyberdog Plug-in Support! Cyberdog support for Netscape Plug-ins is now - available to download! Go to the Cyberdog Beta Download page and download - it now! - Cyberdog Book Check out Jesse Feiler's way-cool book about Cyberdog. - You can find details out about the book as well as ordering information at - Philmont Software Mill site. - Java! Looking to view Java applets in Cyberdog 1.1 Beta 3? Download and - install the Mac OS Runtime for Java and try it out! - Cyberdog 1.1 Beta 3 We hope that Cyberdog and OpenDoc 1.1 will be - available within the next two weeks. In the meantime, we have released - another version of Cyberdog, Cyberdog 1.1 Beta 3. This version fixes - several bugs that were reported to us during out public beta period. You - can check out our release notes to see what we fixed! -END -DONE - - -$| = 1; - -print "1..", @tests/2, "\n"; - -use Text::Wrap; - -$rerun = $ENV{'PERL_DL_NONLAZY'} ? 0 : 1; - -$tn = 1; -while (@tests) { - my $in = shift(@tests); - my $out = shift(@tests); - - $in =~ s/^TEST(\d+)?\n//; - - my $back = fill(' ', ' ', $in); - - if ($back eq $out) { - print "ok $tn\n"; - } elsif ($rerun) { - my $oi = $in; - open(F,">#o") and do { print F $back; close(F) }; - open(F,">#e") and do { print F $out; close(F) }; - foreach ($in, $back, $out) { - s/\t/^I\t/gs; - s/\n/\$\n/gs; - } - print "------------ input ------------\n"; - print $in; - print "\n------------ output -----------\n"; - print $back; - print "\n------------ expected ---------\n"; - print $out; - print "\n-------------------------------\n"; - $Text::Wrap::debug = 1; - fill(' ', ' ', $oi); - exit(1); - } else { - print "not ok $tn\n"; - } - $tn++; -} diff --git a/contrib/perl5/t/lib/texttabs.t b/contrib/perl5/t/lib/texttabs.t deleted file mode 100755 index c6ca123..0000000 --- a/contrib/perl5/t/lib/texttabs.t +++ /dev/null @@ -1,139 +0,0 @@ -#!./perl -w - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -@tests = (split(/\nEND\n/s, <<DONE)); -TEST 1 u - x -END - x -END -TEST 2 e - x -END - x -END -TEST 3 e - x - y - z -END - x - y - z -END -TEST 4 u - x - y - z -END - x - y - z -END -TEST 5 u -This Is a test of a line with many embedded tabs -END -This Is a test of a line with many embedded tabs -END -TEST 6 e -This Is a test of a line with many embedded tabs -END -This Is a test of a line with many embedded tabs -END -TEST 7 u - x -END - x -END -TEST 8 e - - - - - -END - - - - - -END -TEST 9 u - -END - -END -TEST 10 u - - - - - -END - - - - - -END -TEST 11 u -foobar IN A 140.174.82.12 - -END -foobar IN A 140.174.82.12 - -END -DONE - -$| = 1; - -print "1..".scalar(@tests/2)."\n"; - -use Text::Tabs; - -$rerun = $ENV{'PERL_DL_NONLAZY'} ? 0 : 1; - -$tn = 1; -while (@tests) { - my $in = shift(@tests); - my $out = shift(@tests); - - $in =~ s/^TEST\s*(\d+)?\s*(\S+)?\n//; - - if ($2 eq 'e') { - $f = \&expand; - $fn = 'expand'; - } else { - $f = \&unexpand; - $fn = 'unexpand'; - } - - my $back = &$f($in); - - if ($back eq $out) { - print "ok $tn\n"; - } elsif ($rerun) { - my $oi = $in; - foreach ($in, $back, $out) { - s/\t/^I\t/gs; - s/\n/\$\n/gs; - } - print "------------ input ------------\n"; - print $in; - print "\$\n------------ $fn -----------\n"; - print $back; - print "\$\n------------ expected ---------\n"; - print $out; - print "\$\n-------------------------------\n"; - $Text::Tabs::debug = 1; - my $back = &$f($in); - exit(1); - } else { - print "not ok $tn\n"; - } - $tn++; -} diff --git a/contrib/perl5/t/lib/textwrap.t b/contrib/perl5/t/lib/textwrap.t deleted file mode 100755 index fee6ce0..0000000 --- a/contrib/perl5/t/lib/textwrap.t +++ /dev/null @@ -1,209 +0,0 @@ -#!./perl -w - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -@tests = (split(/\nEND\n/s, <<DONE)); -TEST1 -This -is -a -test -END - This - is - a - test -END -TEST2 -This is a test of a very long line. It should be broken up and put onto multiple lines. -This is a test of a very long line. It should be broken up and put onto multiple lines. - -This is a test of a very long line. It should be broken up and put onto multiple lines. -END - This is a test of a very long line. It should be broken up and put onto - multiple lines. - This is a test of a very long line. It should be broken up and put onto - multiple lines. - - This is a test of a very long line. It should be broken up and put onto - multiple lines. -END -TEST3 -This is a test of a very long line. It should be broken up and put onto multiple lines. -END - This is a test of a very long line. It should be broken up and put onto - multiple lines. -END -TEST4 -This is a test of a very long line. It should be broken up and put onto multiple lines. - -END - This is a test of a very long line. It should be broken up and put onto - multiple lines. - -END -TEST5 -This is a test of a very long line. It should be broken up and put onto multiple This is a test of a very long line. It should be broken up and put -END - This is a test of a very long line. It should be broken up and put onto - multiple This is a test of a very long line. It should be broken up and - put -END -TEST6 -11111111 22222222 33333333 44444444 55555555 66666666 77777777 888888888 999999999 aaaaaaaaa bbbbbbbbb ccccccccc ddddddddd eeeeeeeee ffffffff gggggggg hhhhhhhh iiiiiiii jjjjjjjj kkkkkkkk llllllll mmmmmmmmm nnnnnnnnn ooooooooo ppppppppp qqqqqqqqq rrrrrrrrr sssssssss -END - 11111111 22222222 33333333 44444444 55555555 66666666 77777777 888888888 - 999999999 aaaaaaaaa bbbbbbbbb ccccccccc ddddddddd eeeeeeeee ffffffff - gggggggg hhhhhhhh iiiiiiii jjjjjjjj kkkkkkkk llllllll mmmmmmmmm nnnnnnnnn - ooooooooo ppppppppp qqqqqqqqq rrrrrrrrr sssssssss -END -TEST7 -c3t1d0s6 c4t1d0s6 c5t1d0s6 c6t1d0s6 c7t1d0s6 c8t1d0s6 c9t1d0s6 c10t1d0s6 c11t1d0s6 c12t1d0s6 c13t1d0s6 c14t1d0s6 c15t1d0s6 c16t1d0s6 c3t1d0s0 c4t1d0s0 c5t1d0s0 c6t1d0s0 c7t1d0s0 c8t1d0s0 c9t1d0s0 c10t1d0s0 c11t1d0s0 c12t1d0s0 c13t1d0s0 c14t1d0s0 c15t1d0s0 c16t1d0s0 -END - c3t1d0s6 c4t1d0s6 c5t1d0s6 c6t1d0s6 c7t1d0s6 c8t1d0s6 c9t1d0s6 c10t1d0s6 - c11t1d0s6 c12t1d0s6 c13t1d0s6 c14t1d0s6 c15t1d0s6 c16t1d0s6 c3t1d0s0 - c4t1d0s0 c5t1d0s0 c6t1d0s0 c7t1d0s0 c8t1d0s0 c9t1d0s0 c10t1d0s0 c11t1d0s0 - c12t1d0s0 c13t1d0s0 c14t1d0s0 c15t1d0s0 c16t1d0s0 -END -TEST8 -A test of a very very long word. -a123456789b123456789c123456789d123456789e123456789f123456789g123456789g1234567 -END - A test of a very very long word. - a123456789b123456789c123456789d123456789e123456789f123456789g123456789g123 - 4567 -END -TEST9 -A test of a very very long word. a123456789b123456789c123456789d123456789e123456789f123456789g123456789g1234567 -END - A test of a very very long word. - a123456789b123456789c123456789d123456789e123456789f123456789g123456789g123 - 4567 -END -TEST10 -my mother once said -"never eat paste my darling" -would that I heeded -END - my mother once said - "never eat paste my darling" - would that I heeded -END -TEST11 -This_is_a_word_that_is_too_long_to_wrap_we_want_to_make_sure_that_the_program_does_not_crash_and_burn -END - This_is_a_word_that_is_too_long_to_wrap_we_want_to_make_sure_that_the_pr - ogram_does_not_crash_and_burn -END -TEST12 -This - -Has - -Blank - -Lines - -END - This - - Has - - Blank - - Lines - -END -DONE - - -$| = 1; - -print "1..", 1 +@tests, "\n"; - -use Text::Wrap; - -$rerun = $ENV{'PERL_DL_NONLAZY'} ? 0 : 1; - -$tn = 1; - -@st = @tests; -while (@st) { - my $in = shift(@st); - my $out = shift(@st); - - $in =~ s/^TEST(\d+)?\n//; - - my $back = wrap(' ', ' ', $in); - - if ($back eq $out) { - print "ok $tn\n"; - } elsif ($rerun) { - my $oi = $in; - foreach ($in, $back, $out) { - s/\t/^I\t/gs; - s/\n/\$\n/gs; - } - print "------------ input ------------\n"; - print $in; - print "\n------------ output -----------\n"; - print $back; - print "\n------------ expected ---------\n"; - print $out; - print "\n-------------------------------\n"; - $Text::Wrap::debug = 1; - wrap(' ', ' ', $oi); - exit(1); - } else { - print "not ok $tn\n"; - } - $tn++; - -} - -@st = @tests; -while(@st) { - my $in = shift(@st); - my $out = shift(@st); - - $in =~ s/^TEST(\d+)?\n//; - - my @in = split("\n", $in, -1); - @in = ((map { "$_\n" } @in[0..$#in-1]), $in[-1]); - - my $back = wrap(' ', ' ', @in); - - if ($back eq $out) { - print "ok $tn\n"; - } elsif ($rerun) { - my $oi = $in; - foreach ($in, $back, $out) { - s/\t/^I\t/gs; - s/\n/\$\n/gs; - } - print "------------ input2 ------------\n"; - print $in; - print "\n------------ output2 -----------\n"; - print $back; - print "\n------------ expected2 ---------\n"; - print $out; - print "\n-------------------------------\n"; - $Text::Wrap::debug = 1; - wrap(' ', ' ', $oi); - exit(1); - } else { - print "not ok $tn\n"; - } - $tn++; -} - -$Text::Wrap::huge = 'overflow'; - -my $tw = 'This_is_a_word_that_is_too_long_to_wrap_we_want_to_make_sure_that_the_program_does_not_crash_and_burn'; -my $w = wrap('zzz','yyy',$tw); -print (($w eq "zzz$tw") ? "ok $tn\n" : "not ok $tn"); -$tn++; - diff --git a/contrib/perl5/t/lib/thr5005.t b/contrib/perl5/t/lib/thr5005.t deleted file mode 100755 index 680e1af..0000000 --- a/contrib/perl5/t/lib/thr5005.t +++ /dev/null @@ -1,131 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if (! $Config{'use5005threads'}) { - print "1..0 # Skip: not use5005threads\n"; - exit 0; - } - - # XXX known trouble with global destruction - $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; -} -$| = 1; -print "1..22\n"; -use Thread 'yield'; -print "ok 1\n"; - -sub content -{ - print shift; - return shift; -} - -# create a thread passing args and immedaietly wait for it. -my $t = new Thread \&content,("ok 2\n","ok 3\n", 1..1000); -print $t->join; - -# check that lock works ... -{lock $foo; - $t = new Thread sub { lock $foo; print "ok 5\n" }; - print "ok 4\n"; -} -$t->join; - -sub dorecurse -{ - my $val = shift; - my $ret; - print $val; - if (@_) - { - $ret = Thread->new(\&dorecurse, @_); - $ret->join; - } -} - -$t = new Thread \&dorecurse, map { "ok $_\n" } 6..10; -$t->join; - -# test that sleep lets other thread run -$t = new Thread \&dorecurse,"ok 11\n"; -sleep 6; -print "ok 12\n"; -$t->join; - -sub islocked : locked { - my $val = shift; - my $ret; - print $val; - if (@_) - { - $ret = Thread->new(\&islocked, shift); - } - $ret; -} - -$t = Thread->new(\&islocked, "ok 13\n", "ok 14\n"); -$t->join->join; - -{ - package Loch::Ness; - sub new { bless [], shift } - sub monster : locked : method { - my($s, $m) = @_; - print "ok $m\n"; - } - sub gollum { &monster } -} -Loch::Ness->monster(15); -Loch::Ness->new->monster(16); -Loch::Ness->gollum(17); -Loch::Ness->new->gollum(18); - -my $short = "This is a long string that goes on and on."; -my $shorte = " a long string that goes on and on."; -my $long = "This is short."; -my $longe = " short."; -my $thr1 = new Thread \&threaded, $short, $shorte, "19"; -my $thr2 = new Thread \&threaded, $long, $longe, "20"; -my $thr3 = new Thread \&testsprintf, "21"; - -sub testsprintf { - my $testno = shift; - # this may coredump if thread vars are not properly initialised - my $same = sprintf "%.0f", $testno; - if ($testno eq $same) { - print "ok $testno\n"; - } else { - print "not ok $testno\t# '$testno' ne '$same'\n"; - } -} - -sub threaded { - my ($string, $string_end, $testno) = @_; - - # Do the match, saving the output in appropriate variables - $string =~ /(.*)(is)(.*)/; - # Yield control, allowing the other thread to fill in the match variables - yield(); - # Examine the match variable contents; on broken perls this fails - if ($3 eq $string_end) { - print "ok $testno\n"; - } - else { - warn <<EOT; - -# -# This is a KNOWN FAILURE, and one of the reasons why threading -# is still an experimental feature. It is here to stop people -# from deploying threads in production. ;-) -# -EOT - print "not ok $testno # other thread filled in match variables\n"; - } -} -$thr1->join; -$thr2->join; -$thr3->join; -print "ok 22\n"; diff --git a/contrib/perl5/t/lib/tie-push.t b/contrib/perl5/t/lib/tie-push.t deleted file mode 100755 index b19aa0d..0000000 --- a/contrib/perl5/t/lib/tie-push.t +++ /dev/null @@ -1,25 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '.'; - push @INC, '../lib'; -} - -{ - package Basic; - use Tie::Array; - @ISA = qw(Tie::Array); - - sub TIEARRAY { return bless [], shift } - sub FETCH { $_[0]->[$_[1]] } - sub STORE { $_[0]->[$_[1]] = $_[2] } - sub FETCHSIZE { scalar(@{$_[0]}) } - sub STORESIZE { $#{$_[0]} = $_[1]-1 } -} - -tie @x,Basic; -tie @get,Basic; -tie @got,Basic; -tie @tests,Basic; -require "op/push.t" diff --git a/contrib/perl5/t/lib/tie-refhash.t b/contrib/perl5/t/lib/tie-refhash.t deleted file mode 100755 index d80b2e1..0000000 --- a/contrib/perl5/t/lib/tie-refhash.t +++ /dev/null @@ -1,305 +0,0 @@ -#!/usr/bin/perl -w -# -# Basic test suite for Tie::RefHash and Tie::RefHash::Nestable. -# -# The testing is in two parts: first, run lots of tests on both a tied -# hash and an ordinary un-tied hash, and check they give the same -# answer. Then there are tests for those cases where the tied hashes -# should behave differently to normal hashes, that is, when using -# references as keys. -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '.'; - push @INC, '../lib'; -} - -use strict; -use Tie::RefHash; -use Data::Dumper; -my $numtests = 34; -my $currtest = 1; -print "1..$numtests\n"; - -my $ref = []; my $ref1 = []; - -# Test standard hash functionality, by performing the same operations -# on a tied hash and on a normal hash, and checking that the results -# are the same. This does of course assume that Perl hashes are not -# buggy :-) -# -my @tests = standard_hash_tests(); - -my @ordinary_results = runtests(\@tests, undef); -foreach my $class ('Tie::RefHash', 'Tie::RefHash::Nestable') { - my @tied_results = runtests(\@tests, $class); - my $all_ok = 1; - - die if @ordinary_results != @tied_results; - foreach my $i (0 .. $#ordinary_results) { - my ($or, $ow, $oe) = @{$ordinary_results[$i]}; - my ($tr, $tw, $te) = @{$tied_results[$i]}; - - my $ok = 1; - local $^W = 0; - $ok = 0 if (defined($or) != defined($tr)) or ($or ne $tr); - $ok = 0 if (defined($ow) != defined($tw)) or ($ow ne $tw); - $ok = 0 if (defined($oe) != defined($te)) or ($oe ne $te); - - if (not $ok) { - print STDERR - "failed for $class: $tests[$i]\n", - "ordinary hash gave:\n", - defined $or ? "\tresult: $or\n" : "\tundef result\n", - defined $ow ? "\twarning: $ow\n" : "\tno warning\n", - defined $oe ? "\texception: $oe\n" : "\tno exception\n", - "tied $class hash gave:\n", - defined $tr ? "\tresult: $tr\n" : "\tundef result\n", - defined $tw ? "\twarning: $tw\n" : "\tno warning\n", - defined $te ? "\texception: $te\n" : "\tno exception\n", - "\n"; - $all_ok = 0; - } - } - test($all_ok); -} - -# Now test Tie::RefHash's special powers -my (%h, $h); -$h = eval { tie %h, 'Tie::RefHash' }; -warn $@ if $@; -test(not $@); -test(ref($h) eq 'Tie::RefHash'); -test(defined(tied(%h)) and tied(%h) =~ /^Tie::RefHash/); -$h{$ref} = 'cholet'; -test($h{$ref} eq 'cholet'); -test(exists $h{$ref}); -test((keys %h) == 1); -test(ref((keys %h)[0]) eq 'ARRAY'); -test((keys %h)[0] eq $ref); -test((values %h) == 1); -test((values %h)[0] eq 'cholet'); -my $count = 0; -while (my ($k, $v) = each %h) { - if ($count++ == 0) { - test(ref($k) eq 'ARRAY'); - test($k eq $ref); - } -} -test($count == 1); -delete $h{$ref}; -test(not defined $h{$ref}); -test(not exists($h{$ref})); -test((keys %h) == 0); -test((values %h) == 0); -undef $h; -untie %h; - -# And now Tie::RefHash::Nestable's differences from Tie::RefHash. -$h = eval { tie %h, 'Tie::RefHash::Nestable' }; -warn $@ if $@; -test(not $@); -test(ref($h) eq 'Tie::RefHash::Nestable'); -test(defined(tied(%h)) and tied(%h) =~ /^Tie::RefHash::Nestable/); -$h{$ref}->{$ref1} = 'bungo'; -test($h{$ref}->{$ref1} eq 'bungo'); - -# Test that the nested hash is also tied (for current implementation) -test(defined(tied(%{$h{$ref}})) - and tied(%{$h{$ref}}) =~ /^Tie::RefHash::Nestable=/ ); - -test((keys %h) == 1); -test((keys %h)[0] eq $ref); -test((keys %{$h{$ref}}) == 1); -test((keys %{$h{$ref}})[0] eq $ref1); - - -die "expected to run $numtests tests, but ran ", $currtest - 1 - if $currtest - 1 != $numtests; - -@tests = (); -undef $ref; -undef $ref1; - -exit(); - - -# Print 'ok X' if true, 'not ok X' if false -# Uses global $currtest. -# -sub test { - my $t = shift; - print 'not ' if not $t; - print 'ok ', $currtest++, "\n"; -} - - -# Wrapper for Data::Dumper to 'dump' a scalar as an EXPR string. -sub dumped { - my $s = shift; - my $d = Dumper($s); - $d =~ s/^\$VAR1 =\s*//; - $d =~ s/;$//; - chomp $d; - return $d; -} - -# Crudely dump a hash into a canonical string representation (because -# hash keys can appear in any order, Data::Dumper may give different -# strings for the same hash). -# -sub dumph { - my $h = shift; - my $r = ''; - foreach (sort keys %$h) { - $r = dumped($_) . ' => ' . dumped($h->{$_}) . "\n"; - } - return $r; -} - -# Run the tests and give results. -# -# Parameters: reference to list of tests to run -# name of class to use for tied hash, or undef if not tied -# -# Returns: list of [R, W, E] tuples, one for each test. -# R is the return value from running the test, W any warnings it gave, -# and E any exception raised with 'die'. E and W will be tidied up a -# little to remove irrelevant details like line numbers :-) -# -# Will also run a few of its own 'ok N' tests. -# -sub runtests { - my ($tests, $class) = @_; - my @r; - - my (%h, $h); - if (defined $class) { - $h = eval { tie %h, $class }; - warn $@ if $@; - test(not $@); - test(ref($h) eq $class); - test(defined(tied(%h)) and tied(%h) =~ /^\Q$class\E/); - } - - foreach (@$tests) { - my ($result, $warning, $exception); - local $SIG{__WARN__} = sub { $warning .= $_[0] }; - $result = scalar(eval $_); - if ($@) - { - die "$@:$_" unless defined $class; - $exception = $@; - } - - foreach ($warning, $exception) { - next if not defined; - s/ at .+ line \d+\.$//mg; - s/ at .+ line \d+, at .*//mg; - s/ at .+ line \d+, near .*//mg; - } - - my (@warnings, %seen); - foreach (split /\n/, $warning) { - push @warnings, $_ unless $seen{$_}++; - } - $warning = join("\n", @warnings); - - push @r, [ $result, $warning, $exception ]; - } - - return @r; -} - - -# Things that should work just the same for an ordinary hash and a -# Tie::RefHash. -# -# Each test is a code string to be eval'd, it should do something with -# %h and give a scalar return value. The global $ref and $ref1 may -# also be used. -# -# One thing we don't test is that the ordering from 'keys', 'values' -# and 'each' is the same. You can't reasonably expect that. -# -sub standard_hash_tests { - my @r; - - # Library of standard tests on keys, values and each - my $STD_TESTS = <<'END' - join $;, sort keys %h; - join $;, sort values %h; - { my ($v, %tmp); $tmp{$v}++ while (defined($v = each %h)); dumph(\%tmp) } - { my ($k, $v, %tmp); $tmp{"$k$;$v"}++ while (($k, $v) = each %h); dumph(\%tmp) } -END - ; - - # Tests on the existence of the element 'foo' - my $FOO_TESTS = <<'END' - defined $h{foo}; - exists $h{foo}; - $h{foo}; -END - ; - - # Test storing and deleting 'foo' - push @r, split /\n/, <<"END" - $STD_TESTS; - $FOO_TESTS; - \$h{foo} = undef; - $STD_TESTS; - $FOO_TESTS; - \$h{foo} = 'hello'; - $STD_TESTS; - $FOO_TESTS; - delete \$h{foo}; - $STD_TESTS; - $FOO_TESTS; -END - ; - - # Test storing and removing under ordinary keys - my @things = ('boink', 0, 1, '', undef); - foreach my $key (map { dumped($_) } @things) { - foreach my $value ((map { dumped($_) } @things), '$ref') { - push @r, split /\n/, <<"END" - \$h{$key} = $value; - $STD_TESTS; - defined \$h{$key}; - exists \$h{$key}; - \$h{$key}; - delete \$h{$key}; - $STD_TESTS; - defined \$h{$key}; - exists \$h{$key}; - \$h{$key}; -END - ; - } - } - - # Test hash slices - my @slicetests; - @slicetests = split /\n/, <<'END' - @h{'b'} = (); - @h{'c'} = ('d'); - @h{'e'} = ('f', 'g'); - @h{'h', 'i'} = (); - @h{'j', 'k'} = ('l'); - @h{'m', 'n'} = ('o', 'p'); - @h{'q', 'r'} = ('s', 't', 'u'); -END - ; - my @aaa = @slicetests; - foreach (@slicetests) { - push @r, $_; - push @r, split(/\n/, $STD_TESTS); - } - - # Test CLEAR - push @r, '%h = ();', split(/\n/, $STD_TESTS); - - return @r; -} - diff --git a/contrib/perl5/t/lib/tie-splice.t b/contrib/perl5/t/lib/tie-splice.t deleted file mode 100755 index d7ea6cc..0000000 --- a/contrib/perl5/t/lib/tie-splice.t +++ /dev/null @@ -1,17 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '.'; - push @INC, '../lib'; -} - -# bug id 20001020.002 -# -dlc 20001021 - -use Tie::Array; -tie @a,Tie::StdArray; -undef *Tie::StdArray::SPLICE; -require "op/splice.t" - -# Pre-fix, this failed tests 6-9 diff --git a/contrib/perl5/t/lib/tie-stdarray.t b/contrib/perl5/t/lib/tie-stdarray.t deleted file mode 100755 index c4ae071..0000000 --- a/contrib/perl5/t/lib/tie-stdarray.t +++ /dev/null @@ -1,13 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '.'; - push @INC, '../lib'; -} - -use Tie::Array; -tie @foo,Tie::StdArray; -tie @ary,Tie::StdArray; -tie @bar,Tie::StdArray; -require "op/array.t" diff --git a/contrib/perl5/t/lib/tie-stdhandle.t b/contrib/perl5/t/lib/tie-stdhandle.t deleted file mode 100755 index f03f5d9..0000000 --- a/contrib/perl5/t/lib/tie-stdhandle.t +++ /dev/null @@ -1,47 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Tie::Handle; -tie *tst,Tie::StdHandle; - -$f = 'tst'; - -print "1..13\n"; - -# my $file tests - -unlink("afile.new") if -f "afile"; -print "$!\nnot " unless open($f,"+>afile") && open($f, "+<", "afile"); -print "ok 1\n"; -print "$!\nnot " unless binmode($f); -print "ok 2\n"; -print "not " unless -f "afile"; -print "ok 3\n"; -print "not " unless print $f "SomeData\n"; -print "ok 4\n"; -print "not " unless tell($f) == 9; -print "ok 5\n"; -print "not " unless printf $f "Some %d value\n",1234; -print "ok 6\n"; -print "not " unless seek($f,0,0); -print "ok 7\n"; -$b = <$f>; -print "not " unless $b eq "SomeData\n"; -print "ok 8\n"; -print "not " if eof($f); -print "ok 9\n"; -read($f,($b=''),4); -print "'$b' not " unless $b eq 'Some'; -print "ok 10\n"; -print "not " unless getc($f) eq ' '; -print "ok 11\n"; -$b = <$f>; -print "not " unless eof($f); -print "ok 12\n"; -print "not " unless close($f); -print "ok 13\n"; -unlink("afile"); diff --git a/contrib/perl5/t/lib/tie-stdpush.t b/contrib/perl5/t/lib/tie-stdpush.t deleted file mode 100755 index 31af30c..0000000 --- a/contrib/perl5/t/lib/tie-stdpush.t +++ /dev/null @@ -1,11 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '.'; - push @INC, '../lib'; -} - -use Tie::Array; -tie @x,Tie::StdArray; -require "op/push.t" diff --git a/contrib/perl5/t/lib/tie-substrhash.t b/contrib/perl5/t/lib/tie-substrhash.t deleted file mode 100755 index 8256db7..0000000 --- a/contrib/perl5/t/lib/tie-substrhash.t +++ /dev/null @@ -1,111 +0,0 @@ -#!/usr/bin/perl -w -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '.'; - push @INC, '../lib'; -} - -print "1..20\n"; - -use strict; - -require Tie::SubstrHash; - -my %a; - -tie %a, 'Tie::SubstrHash', 3, 3, 3; - -$a{abc} = 123; -$a{bcd} = 234; - -print "not " unless $a{abc} == 123; -print "ok 1\n"; - -print "not " unless keys %a == 2; -print "ok 2\n"; - -delete $a{abc}; - -print "not " unless $a{bcd} == 234; -print "ok 3\n"; - -print "not " unless (values %a)[0] == 234; -print "ok 4\n"; - -eval { $a{abcd} = 123 }; -print "not " unless $@ =~ /Key "abcd" is not 3 characters long/; -print "ok 5\n"; - -eval { $a{abc} = 1234 }; -print "not " unless $@ =~ /Value "1234" is not 3 characters long/; -print "ok 6\n"; - -eval { $a = $a{abcd}; $a++ }; -print "not " unless $@ =~ /Key "abcd" is not 3 characters long/; -print "ok 7\n"; - -@a{qw(abc cde)} = qw(123 345); - -print "not " unless $a{cde} == 345; -print "ok 8\n"; - -eval { $a{def} = 456 }; -print "not " unless $@ =~ /Table is full \(3 elements\)/; -print "ok 9\n"; - -%a = (); - -print "not " unless keys %a == 0; -print "ok 10\n"; - -# Tests 11..16 by Linc Madison. - -my $hashsize = 119; # arbitrary values from my data -my %test; -tie %test, "Tie::SubstrHash", 13, 86, $hashsize; - -for (my $i = 1; $i <= $hashsize; $i++) { - my $key1 = $i + 100_000; # fix to uniform 6-digit numbers - my $key2 = "abcdefg$key1"; - $test{$key2} = ("abcdefgh" x 10) . "$key1"; -} - -for (my $i = 1; $i <= $hashsize; $i++) { - my $key1 = $i + 100_000; - my $key2 = "abcdefg$key1"; - unless ($test{$key2}) { - print "not "; - last; - } -} -print "ok 11\n"; - -print "not " unless Tie::SubstrHash::findgteprime(1) == 2; -print "ok 12\n"; - -print "not " unless Tie::SubstrHash::findgteprime(2) == 2; -print "ok 13\n"; - -print "not " unless Tie::SubstrHash::findgteprime(5.5) == 7; -print "ok 14\n"; - -print "not " unless Tie::SubstrHash::findgteprime(13) == 13; -print "ok 15\n"; - -print "not " unless Tie::SubstrHash::findgteprime(13.000001) == 17; -print "ok 16\n"; - -print "not " unless Tie::SubstrHash::findgteprime(114) == 127; -print "ok 17\n"; - -print "not " unless Tie::SubstrHash::findgteprime(1000) == 1009; -print "ok 18\n"; - -print "not " unless Tie::SubstrHash::findgteprime(1024) == 1031; -print "ok 19\n"; - -print "not " unless Tie::SubstrHash::findgteprime(10000) == 10007; -print "ok 20\n"; - diff --git a/contrib/perl5/t/lib/timelocal.t b/contrib/perl5/t/lib/timelocal.t deleted file mode 100755 index 100e076..0000000 --- a/contrib/perl5/t/lib/timelocal.t +++ /dev/null @@ -1,90 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Time::Local; - -# Set up time values to test -@time = - ( - #year,mon,day,hour,min,sec - [1970, 1, 2, 00, 00, 00], - [1980, 2, 28, 12, 00, 00], - [1980, 2, 29, 12, 00, 00], - [1999, 12, 31, 23, 59, 59], - [2000, 1, 1, 00, 00, 00], - [2010, 10, 12, 14, 13, 12], - ); - -# use vmsish 'time' makes for oddness around the Unix epoch -if ($^O eq 'VMS') { $time[0][2]++ } - -print "1..", @time * 2 + 5, "\n"; - -$count = 1; -for (@time) { - my($year, $mon, $mday, $hour, $min, $sec) = @$_; - $year -= 1900; - $mon --; - my $time = timelocal($sec,$min,$hour,$mday,$mon,$year); - # print scalar(localtime($time)), "\n"; - my($s,$m,$h,$D,$M,$Y) = localtime($time); - - if ($s == $sec && - $m == $min && - $h == $hour && - $D == $mday && - $M == $mon && - $Y == $year - ) { - print "ok $count\n"; - } else { - print "not ok $count\n"; - } - $count++; - - # Test gmtime function - $time = timegm($sec,$min,$hour,$mday,$mon,$year); - ($s,$m,$h,$D,$M,$Y) = gmtime($time); - - if ($s == $sec && - $m == $min && - $h == $hour && - $D == $mday && - $M == $mon && - $Y == $year - ) { - print "ok $count\n"; - } else { - print "not ok $count\n"; - } - $count++; -} - -#print "Testing that the differences between a few dates makes sence...\n"; - -timelocal(0,0,1,1,0,90) - timelocal(0,0,0,1,0,90) == 3600 - or print "not "; -print "ok ", $count++, "\n"; - -timelocal(1,2,3,1,0,100) - timelocal(1,2,3,31,11,99) == 24 * 3600 - or print "not "; -print "ok ", $count++, "\n"; - -# Diff beween Jan 1, 1970 and Mar 1, 1970 = (31 + 28 = 59 days) -timegm(0,0,0, 1, 2, 70) - timegm(0,0,0, 1, 0, 70) == 59 * 24 * 3600 - or print "not "; -print "ok ", $count++, "\n"; - - -#print "Testing timelocal.pl module too...\n"; -package test; -require 'timelocal.pl'; -timegm(0,0,0,1,0,70) == main::timegm(0,0,0,1,0,70) or print "not "; -print "ok ", $main::count++, "\n"; - -timelocal(1,2,3,4,5,78) == main::timelocal(1,2,3,4,5,78) or print "not "; -print "ok ", $main::count++, "\n"; diff --git a/contrib/perl5/t/lib/trig.t b/contrib/perl5/t/lib/trig.t deleted file mode 100755 index 6949622..0000000 --- a/contrib/perl5/t/lib/trig.t +++ /dev/null @@ -1,179 +0,0 @@ -#!./perl - -# -# Regression tests for the Math::Trig package -# -# The tests are quite modest as the Math::Complex tests exercise -# these quite vigorously. -# -# -- Jarkko Hietaniemi, April 1997 - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Math::Trig; - -use strict; - -use vars qw($x $y $z); - -my $eps = 1e-11; - -if ($^O eq 'unicos') { # See lib/Math/Complex.pm and t/lib/complex.t. - $eps = 1e-10; -} - -sub near ($$;$) { - my $e = defined $_[2] ? $_[2] : $eps; - $_[1] ? (abs($_[0]/$_[1] - 1) < $e) : abs($_[0]) < $e; -} - -print "1..23\n"; - -$x = 0.9; -print 'not ' unless (near(tan($x), sin($x) / cos($x))); -print "ok 1\n"; - -print 'not ' unless (near(sinh(2), 3.62686040784702)); -print "ok 2\n"; - -print 'not ' unless (near(acsch(0.1), 2.99822295029797)); -print "ok 3\n"; - -$x = asin(2); -print 'not ' unless (ref $x eq 'Math::Complex'); -print "ok 4\n"; - -# avoid using Math::Complex here -$x =~ /^([^-]+)(-[^i]+)i$/; -($y, $z) = ($1, $2); -print 'not ' unless (near($y, 1.5707963267949) and - near($z, -1.31695789692482)); -print "ok 5\n"; - -print 'not ' unless (near(deg2rad(90), pi/2)); -print "ok 6\n"; - -print 'not ' unless (near(rad2deg(pi), 180)); -print "ok 7\n"; - -use Math::Trig ':radial'; - -{ - my ($r,$t,$z) = cartesian_to_cylindrical(1,1,1); - - print 'not ' unless (near($r, sqrt(2))) and - (near($t, deg2rad(45))) and - (near($z, 1)); - print "ok 8\n"; - - ($x,$y,$z) = cylindrical_to_cartesian($r, $t, $z); - - print 'not ' unless (near($x, 1)) and - (near($y, 1)) and - (near($z, 1)); - print "ok 9\n"; - - ($r,$t,$z) = cartesian_to_cylindrical(1,1,0); - - print 'not ' unless (near($r, sqrt(2))) and - (near($t, deg2rad(45))) and - (near($z, 0)); - print "ok 10\n"; - - ($x,$y,$z) = cylindrical_to_cartesian($r, $t, $z); - - print 'not ' unless (near($x, 1)) and - (near($y, 1)) and - (near($z, 0)); - print "ok 11\n"; -} - -{ - my ($r,$t,$f) = cartesian_to_spherical(1,1,1); - - print 'not ' unless (near($r, sqrt(3))) and - (near($t, deg2rad(45))) and - (near($f, atan2(sqrt(2), 1))); - print "ok 12\n"; - - ($x,$y,$z) = spherical_to_cartesian($r, $t, $f); - - print 'not ' unless (near($x, 1)) and - (near($y, 1)) and - (near($z, 1)); - print "ok 13\n"; - - ($r,$t,$f) = cartesian_to_spherical(1,1,0); - - print 'not ' unless (near($r, sqrt(2))) and - (near($t, deg2rad(45))) and - (near($f, deg2rad(90))); - print "ok 14\n"; - - ($x,$y,$z) = spherical_to_cartesian($r, $t, $f); - - print 'not ' unless (near($x, 1)) and - (near($y, 1)) and - (near($z, 0)); - print "ok 15\n"; -} - -{ - my ($r,$t,$z) = cylindrical_to_spherical(spherical_to_cylindrical(1,1,1)); - - print 'not ' unless (near($r, 1)) and - (near($t, 1)) and - (near($z, 1)); - print "ok 16\n"; - - ($r,$t,$z) = spherical_to_cylindrical(cylindrical_to_spherical(1,1,1)); - - print 'not ' unless (near($r, 1)) and - (near($t, 1)) and - (near($z, 1)); - print "ok 17\n"; -} - -{ - use Math::Trig 'great_circle_distance'; - - print 'not ' - unless (near(great_circle_distance(0, 0, 0, pi/2), pi/2)); - print "ok 18\n"; - - print 'not ' - unless (near(great_circle_distance(0, 0, pi, pi), pi)); - print "ok 19\n"; - - # London to Tokyo. - my @L = (deg2rad(-0.5), deg2rad(90 - 51.3)); - my @T = (deg2rad(139.8),deg2rad(90 - 35.7)); - - my $km = great_circle_distance(@L, @T, 6378); - - print 'not ' unless (near($km, 9605.26637021388)); - print "ok 20\n"; -} - -{ - my $R2D = 57.295779513082320876798154814169; - - sub frac { $_[0] - int($_[0]) } - - my $lotta_radians = deg2rad(1E+20, 1); - print "not " unless near($lotta_radians, 1E+20/$R2D); - print "ok 21\n"; - - my $negat_degrees = rad2deg(-1E20, 1); - print "not " unless near($negat_degrees, -1E+20*$R2D); - print "ok 22\n"; - - my $posit_degrees = rad2deg(-10000, 1); - print "not " unless near($posit_degrees, -10000*$R2D); - print "ok 23\n"; -} - -# eof |
