diff options
Diffstat (limited to 't/lib')
49 files changed, 3262 insertions, 338 deletions
diff --git a/t/lib/abbrev.t b/t/lib/abbrev.t new file mode 100755 index 0000000000..fb5a9841eb --- /dev/null +++ b/t/lib/abbrev.t @@ -0,0 +1,51 @@ +#!./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/t/lib/anydbm.t b/t/lib/anydbm.t index 11ac103a64..6ddbf25e2d 100755 --- a/t/lib/anydbm.t +++ b/t/lib/anydbm.t @@ -15,15 +15,21 @@ print "1..12\n"; unlink <Op.dbmx*>; umask(0); -print (tie(%h,AnyDBM_File,'Op.dbmx', O_RDWR|O_CREAT, 0640) ? "ok 1\n" : "not ok 1\n"); +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*>; } -($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"); +if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32') { + print "ok 2\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++; } @@ -80,7 +86,7 @@ delete $h{'goner3'}; 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 gt $value) { + if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { $key =~ y/a-z/A-Z/; $i++ if $key eq $value; } @@ -111,4 +117,5 @@ 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; diff --git a/t/lib/autoloader.t b/t/lib/autoloader.t new file mode 100755 index 0000000000..b1622a8ae2 --- /dev/null +++ b/t/lib/autoloader.t @@ -0,0 +1,100 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + $dir = "auto-$$"; + @INC = ("./$dir", "../lib"); +} + +print "1..9\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"; + +# 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"; +rmdir "$dir/auto/Foo"; +rmdir "$dir/auto"; +rmdir "$dir"; +} diff --git a/t/lib/basename.t b/t/lib/basename.t new file mode 100755 index 0000000000..860b3379b4 --- /dev/null +++ b/t/lib/basename.t @@ -0,0 +1,121 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use File::Basename qw(fileparse basename dirname); + +print "1..34\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:') eq 'arma:' ? '' : 'not '),"ok 27\n"; +print +(dirname(':') eq ':' ? '' : 'not '),"ok 28\n"; + + +# Check quoting of metacharacters in suffix arg by basename() +print +(basename(':arma:virumque:cano.trojae','.trojae') eq 'cano' ? + '' : 'not '),"ok 29\n"; +print +(basename(':arma:virumque:cano_trojae','.trojae') eq 'cano_trojae' ? + '' : 'not '),"ok 30\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 31\n"; +# perl5.003_18 gives C:\perl\ +print +(dirname('C:\\perl\\lib\\') eq 'C:\\perl' ? '' : 'not '), "ok 32\n"; + +File::Basename::fileparse_set_fstype 'UNIX'; +# perl5.003_18 gives '.' +print +(dirname('/perl/') eq '/' ? '' : 'not '), "ok 33\n"; +# perl5.003_18 gives '/perl/lib' +print +(dirname('/perl/lib//') eq '/perl' ? '' : 'not '), "ok 34\n"; diff --git a/t/lib/bigintpm.t b/t/lib/bigintpm.t index b229d7c67b..ebaecac21a 100755 --- a/t/lib/bigintpm.t +++ b/t/lib/bigintpm.t @@ -1,8 +1,11 @@ #!./perl -BEGIN { unshift @INC, './lib', '../lib'; - require Config; import Config; +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; } + +use Config; use Math::BigInt; $test = 0; diff --git a/t/lib/checktree.t b/t/lib/checktree.t new file mode 100755 index 0000000000..b5426ca261 --- /dev/null +++ b/t/lib/checktree.t @@ -0,0 +1,19 @@ +#!./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/t/lib/complex.t b/t/lib/complex.t new file mode 100755 index 0000000000..80a56254ba --- /dev/null +++ b/t/lib/complex.t @@ -0,0 +1,555 @@ +#!./perl + +# $RCSfile$ +# +# Regression tests for the Math::Complex pacakge +# -- Raphael Manfredi, September 1996 +# -- Jarkko Hietaniemi, March-April 1997 + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Math::Complex; + +$test = 0; +$| = 1; +@script = (); +my $eps = 1e-11; + +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); + } +} + +# test the divbyzeros + +sub test_dbz { + for my $op (@_) { + $test++; + +# push(@script, qq(print "# '$op'\n";)); + push(@script, qq(eval '$op';)); + push(@script, qq(print 'not ' unless (\$@ =~ /Division by zero/);)); + push(@script, qq(print "ok $test\n";)); + } +} + +test_dbz( + 'i/0', +# 'tan(pi/2)', # may succeed thanks to floating point inaccuracies +# 'sec(pi/2)', # may succeed thanks to floating point inaccuracies + 'csc(0)', + 'cot(0)', + 'atan(i)', + 'asec(0)', + 'acsc(0)', + 'acot(i)', +# 'tanh(pi/2)', # may succeed thanks to floating point inaccuracies +# 'sech(pi/2)', # may succeed thanks to floating point inaccuracies + 'csch(0)', + 'coth(0)', + 'atanh(1)', + 'asech(0)', + 'acsch(0)', + 'acoth(1)' + ); + +# test the 0**0 + +sub test_ztz { + $test++; + +# push(@script, qq(print "# 0**0\n";)); + push(@script, qq(eval 'cplx(0)**cplx(0)';)); + push(@script, qq(print 'not ' unless (\$@ =~ /zero raised to the/);)); + push(@script, qq(print "ok $test\n";)); +} + +test_ztz; + +# test the bad roots + +sub test_broot { + for my $op (@_) { + $test++; + +# push(@script, qq(print "# root(2, $op)\n";)); + push(@script, qq(eval 'root(2, $op)';)); + push(@script, qq(print 'not ' unless (\$@ =~ /root must be/);)); + push(@script, qq(print "ok $test\n";)); + } +} + +test_broot(qw(-3 -2.1 0 0.99)); + +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";); + 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*\[(.*),(.*)\]/) { + 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"; + } +} +__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) + +&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)' + +{ (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' +|'cos(z) ** 2 + sin(z) ** 2':1 +|'cos(z)':'cosh(i*z)' +|'cosh(z) ** 2 - sinh(z) ** 2':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' + +&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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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/t/lib/db-btree.t b/t/lib/db-btree.t index d90de6cd59..c90c9d7d98 100755 --- a/t/lib/db-btree.t +++ b/t/lib/db-btree.t @@ -1,7 +1,7 @@ -#!./perl +#!./perl -w BEGIN { - @INC = '../lib'; + @INC = '../lib' if -d '../lib' ; require Config; import Config; if ($Config{'extensions'} !~ /\bDB_File\b/) { print "1..0\n"; @@ -12,73 +12,99 @@ BEGIN { use DB_File; use Fcntl; -print "1..76\n"; +print "1..92\n"; -$Dfile = "Op.db-btree"; +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 ; +} + +$Dfile = "dbbtree.tmp"; unlink $Dfile; umask(0); # Check the interface to BTREEINFO -$dbh = TIEHASH DB_File::BTREEINFO ; -print (($dbh->{flags} == undef) ? "ok 1\n" : "not ok 1\n") ; -print (($dbh->{cachesize} == undef) ? "ok 2\n" : "not ok 2\n") ; -print (($dbh->{psize} == undef) ? "ok 3\n" : "not ok 3\n") ; -print (($dbh->{lorder} == undef) ? "ok 4\n" : "not ok 4\n") ; -print (($dbh->{minkeypage} == undef) ? "ok 5\n" : "not ok 5\n") ; -print (($dbh->{maxkeypage} == undef) ? "ok 6\n" : "not ok 6\n") ; -print (($dbh->{compare} == undef) ? "ok 7\n" : "not ok 7\n") ; -print (($dbh->{prefix} == undef) ? "ok 8\n" : "not ok 8\n") ; +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 ; -print ($dbh->{flags} == 3000 ? "ok 9\n" : "not ok 9\n") ; +ok(9, $dbh->{flags} == 3000) ; $dbh->{cachesize} = 9000 ; -print ($dbh->{cachesize} == 9000 ? "ok 10\n" : "not ok 10\n") ; -# +ok(10, $dbh->{cachesize} == 9000); + $dbh->{psize} = 400 ; -print (($dbh->{psize} == 400) ? "ok 11\n" : "not ok 11\n") ; +ok(11, $dbh->{psize} == 400) ; $dbh->{lorder} = 65 ; -print (($dbh->{lorder} == 65) ? "ok 12\n" : "not ok 12\n") ; +ok(12, $dbh->{lorder} == 65) ; $dbh->{minkeypage} = 123 ; -print (($dbh->{minkeypage} == 123) ? "ok 13\n" : "not ok 13\n") ; +ok(13, $dbh->{minkeypage} == 123) ; $dbh->{maxkeypage} = 1234 ; -print ($dbh->{maxkeypage} == 1234 ? "ok 14\n" : "not ok 14\n") ; +ok(14, $dbh->{maxkeypage} == 1234 ); $dbh->{compare} = 1234 ; -print ($dbh->{compare} == 1234 ? "ok 15\n" : "not ok 15\n") ; +ok(15, $dbh->{compare} == 1234) ; $dbh->{prefix} = 1234 ; -print ($dbh->{prefix} == 1234 ? "ok 16\n" : "not ok 16\n") ; +ok(16, $dbh->{prefix} == 1234 ); # Check that an invalid entry is caught both for store & fetch eval '$dbh->{fred} = 1234' ; -print ($@ eq '' ? "ok 17\n" : "not ok 17\n") ; +ok(17, $@ =~ /^DB_File::BTREEINFO::STORE - Unknown element 'fred' at/ ) ; eval '$q = $dbh->{fred}' ; -print ($@ eq '' ? "ok 18\n" : "not ok 18\n") ; +ok(18, $@ =~ /^DB_File::BTREEINFO::FETCH - Unknown element 'fred' at/ ) ; # Now check the interface to BTREE -print (($X = tie(%h, DB_File,$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ? "ok 19\n" : "not ok 19"); +ok(19, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ; ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); -print (($mode & 0777) == 0640 ? "ok 20\n" : "not ok 20\n"); +ok(20, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos'); while (($key,$value) = each(%h)) { $i++; } -print (!$i ? "ok 21\n" : "not ok 21\n"); +ok(21, !$i ) ; $h{'goner1'} = 'snork'; $h{'abc'} = 'ABC'; -print ($h{'abc'} == 'ABC' ? "ok 22\n" : "not ok 22\n") ; -print (defined $h{'jimmy'} ? "not ok 23\n" : "ok 23\n"); +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"; @@ -110,7 +136,7 @@ untie(%h); # tie to the same file again -print (($X = tie(%h,DB_File,$Dfile, O_RDWR, 0640, $DB_BTREE)) ? "ok 24\n" : "not ok 24\n"); +ok(26, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE)) ; # Modify an entry from the previous tie $h{'g'} = 'G'; @@ -141,48 +167,45 @@ $X->DELETE('goner3'); @keys = keys(%h); @values = values(%h); -if ($#keys == 29 && $#values == 29) {print "ok 25\n";} else {print "not ok 25\n";} +ok(27, $#keys == 29 && $#values == 29) ; +$i = 0 ; while (($key,$value) = each(%h)) { - if ($key eq $keys[$i] && $value eq $values[$i] && $key gt $value) { + 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 26\n";} else {print "not ok 26\n";} +ok(28, $i == 30) ; -@keys = ('blurfl', keys(h), 'dyick'); -if ($#keys == 31) {print "ok 27\n";} else {print "not ok 27\n";} +@keys = ('blurfl', keys(%h), 'dyick'); +ok(29, $#keys == 31) ; #Check that the keys can be retrieved in order -$ok = 1 ; -foreach (keys %h) -{ - ($ok = 0), last if defined $previous && $previous gt $_ ; - $previous = $_ ; -} -print ($ok ? "ok 28\n" : "not ok 28\n") ; +my @b = keys %h ; +my @c = sort lexical @b ; +ok(30, ArrayCompare(\@b, \@c)) ; $h{'foo'} = ''; -print ($h{'foo'} eq '' ? "ok 29\n" : "not ok 29\n") ; +ok(31, $h{'foo'} eq '' ) ; $h{''} = 'bar'; -print ($h{''} eq 'bar' ? "ok 30\n" : "not ok 30\n") ; +ok(32, $h{''} eq '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 31\n" : "not ok 31\n"); +ok(33, $ok); ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); -print ($size > 0 ? "ok 32\n" : "not ok 32\n"); +ok(34, $size > 0 ); @h{0..200} = 200..400; @foo = @h{0..200}; -print join(':',200..400) eq join(':',@foo) ? "ok 33\n" : "not ok 33\n"; +ok(35, join(':',200..400) eq join(':',@foo) ); # Now check all the non-tie specific stuff @@ -191,52 +214,53 @@ print join(':',200..400) eq join(':',@foo) ? "ok 33\n" : "not ok 33\n"; # an existing record. $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; -print ($status == 1 ? "ok 34\n" : "not ok 34\n") ; +ok(36, $status == 1 ); # check that the value of the key 'x' has not been changed by the # previous test -print ($h{'x'} eq 'X' ? "ok 35\n" : "not ok 35\n") ; +ok(37, $h{'x'} eq 'X' ); # standard put $status = $X->put('key', 'value') ; -print ($status == 0 ? "ok 36\n" : "not ok 36\n") ; +ok(38, $status == 0 ); #check that previous put can be retrieved +$value = 0 ; $status = $X->get('key', $value) ; -print ($status == 0 ? "ok 37\n" : "not ok 37\n") ; -print ($value eq 'value' ? "ok 38\n" : "not ok 38\n") ; +ok(39, $status == 0 ); +ok(40, $value eq 'value' ); # Attempting to delete an existing key should work $status = $X->del('q') ; -print ($status == 0 ? "ok 39\n" : "not ok 39\n") ; +ok(41, $status == 0 ); $status = $X->del('') ; -print ($status == 0 ? "ok 40\n" : "not ok 40\n") ; +ok(42, $status == 0 ); # Make sure that the key deleted, cannot be retrieved -print (($h{'q'} eq undef) ? "ok 41\n" : "not ok 41\n") ; -print (($h{''} eq undef) ? "ok 42\n" : "not ok 42\n") ; +ok(43, ! defined $h{'q'}) ; +ok(44, ! defined $h{''}) ; undef $X ; untie %h ; -print (($X = tie(%h, DB_File,$Dfile, O_RDWR, 0640, $DB_BTREE )) ? "ok 43\n" : "not ok 43"); +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') ; -print ($status == 1 ? "ok 44\n" : "not ok 44\n") ; +ok(46, $status == 1 ); # Check the get interface # First a non-existing key $status = $X->get('aaaa', $value) ; -print ($status == 1 ? "ok 45\n" : "not ok 45\n") ; +ok(47, $status == 1 ); # Next an existing key $status = $X->get('a', $value) ; -print ($status == 0 ? "ok 46\n" : "not ok 46\n") ; -print ($value eq 'A' ? "ok 47\n" : "not ok 47\n") ; +ok(48, $status == 0 ); +ok(49, $value eq 'A' ); # seq # ### @@ -245,15 +269,15 @@ print ($value eq 'A' ? "ok 47\n" : "not ok 47\n") ; $key = 'ke' ; $value = '' ; $status = $X->seq($key, $value, R_CURSOR) ; -print ($status == 0 ? "ok 48\n" : "not ok 48\n") ; -print ($key eq 'key' ? "ok 49\n" : "not ok 49\n") ; -print ($value eq 'value' ? "ok 50\n" : "not ok 50\n") ; +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) ; -print ($status == 1 ? "ok 51\n" : "not ok 51\n") ; +ok(53, $status == 1 ); # use seq to set the cursor, then delete the record @ the cursor. @@ -261,35 +285,35 @@ print ($status == 1 ? "ok 51\n" : "not ok 51\n") ; $key = 'x' ; $value = '' ; $status = $X->seq($key, $value, R_CURSOR) ; -print ($status == 0 ? "ok 52\n" : "not ok 52\n") ; -print ($key eq 'x' ? "ok 53\n" : "not ok 53\n") ; -print ($value eq 'X' ? "ok 54\n" : "not ok 54\n") ; +ok(54, $status == 0 ); +ok(55, $key eq 'x' ); +ok(56, $value eq 'X' ); $status = $X->del(0, R_CURSOR) ; -print ($status == 0 ? "ok 55\n" : "not ok 55\n") ; +ok(57, $status == 0 ); $status = $X->get('x', $value) ; -print ($status == 1 ? "ok 56\n" : "not ok 56\n") ; +ok(58, $status == 1 ); # ditto, but use put to replace the key/value pair. $key = 'y' ; $value = '' ; $status = $X->seq($key, $value, R_CURSOR) ; -print ($status == 0 ? "ok 57\n" : "not ok 57\n") ; -print ($key eq 'y' ? "ok 58\n" : "not ok 58\n") ; -print ($value eq 'Y' ? "ok 59\n" : "not ok 59\n") ; +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) ; -print ($status == 0 ? "ok 60\n" : "not ok 60\n") ; -print ($key eq 'replace key' ? "ok 61\n" : "not ok 61\n") ; -print ($value eq 'replace value' ? "ok 62\n" : "not ok 62\n") ; +ok(62, $status == 0 ); +ok(63, $key eq 'replace key' ); +ok(64, $value eq 'replace value' ); $status = $X->get('y', $value) ; -print ($status == 1 ? "ok 63\n" : "not ok 63\n") ; +ok(65, $status == 1 ); # use seq to walk forwards through a file $status = $X->seq($key, $value, R_FIRST) ; -print ($status == 0 ? "ok 64\n" : "not ok 64\n") ; +ok(66, $status == 0 ); $previous = $key ; $ok = 1 ; @@ -298,12 +322,12 @@ while (($status = $X->seq($key, $value, R_NEXT)) == 0) ($ok = 0), last if ($previous cmp $key) == 1 ; } -print ($status == 1 ? "ok 65\n" : "not ok 65\n") ; -print ($ok == 1 ? "ok 66\n" : "not ok 66\n") ; +ok(67, $status == 1 ); +ok(68, $ok == 1 ); # use seq to walk backwards through a file $status = $X->seq($key, $value, R_LAST) ; -print ($status == 0 ? "ok 67\n" : "not ok 67\n") ; +ok(69, $status == 0 ); $previous = $key ; $ok = 1 ; @@ -313,8 +337,8 @@ while (($status = $X->seq($key, $value, R_PREV)) == 0) #print "key = [$key] value = [$value]\n" ; } -print ($status == 1 ? "ok 68\n" : "not ok 68\n") ; -print ($ok == 1 ? "ok 69\n" : "not ok 69\n") ; +ok(70, $status == 1 ); +ok(71, $ok == 1 ); # check seq FIRST/LAST @@ -323,14 +347,14 @@ print ($ok == 1 ? "ok 69\n" : "not ok 69\n") ; # #### $status = $X->sync ; -print ($status == 0 ? "ok 70\n" : "not ok 70\n") ; +ok(72, $status == 0 ); # fd # ## $status = $X->fd ; -print ($status != 0 ? "ok 71\n" : "not ok 71\n") ; +ok(73, $status != 0 ); undef $X ; @@ -339,41 +363,92 @@ untie %h ; unlink $Dfile; # Now try an in memory file -print (($Y = tie(%h, DB_File,undef, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ? "ok 72\n" : "not ok 72"); +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 ; -print ($status == -1 ? "ok 73\n" : "not ok 73\n") ; +ok(75, $status == -1 ); + undef $Y ; untie %h ; +# Duplicate keys +my $bt = new DB_File::BTREEINFO ; +$bt->{flags} = R_DUP ; +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 $Dfile1 = "btree1" ; $Dfile2 = "btree2" ; $Dfile3 = "btree3" ; -$dbh1 = TIEHASH DB_File::BTREEINFO ; -$dbh1->{compare} = sub { $_[0] <=> $_[1] } ; +$dbh1 = new DB_File::BTREEINFO ; +{ local $^W = 0 ; + $dbh1->{compare} = sub { $_[0] <=> $_[1] } ; } -$dbh2 = TIEHASH DB_File::BTREEINFO ; +$dbh2 = new DB_File::BTREEINFO ; $dbh2->{compare} = sub { $_[0] cmp $_[1] } ; -$dbh3 = TIEHASH DB_File::BTREEINFO ; +$dbh3 = new DB_File::BTREEINFO ; $dbh3->{compare} = sub { length $_[0] <=> length $_[1] } ; -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 ) ; +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 ) ; @Keys = qw( 0123 12 -1234 9 987654321 def ) ; -@srt_1 = sort { $a <=> $b } @Keys ; +{ local $^W = 0 ; + @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 ; + { local $^W = 0 ; + $h{$_} = 1 ; } $g{$_} = 1 ; $k{$_} = 1 ; } @@ -392,13 +467,50 @@ sub ArrayCompare 1 ; } -print ( ArrayCompare (\@srt_1, [keys %h]) ? "ok 74\n" : "not ok 74\n") ; -print ( ArrayCompare (\@srt_2, [keys %g]) ? "ok 75\n" : "not ok 75\n") ; -print ( ArrayCompare (\@srt_3, [keys %k]) ? "ok 76\n" : "not ok 76\n") ; +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 ; +} + exit ; diff --git a/t/lib/db-hash.t b/t/lib/db-hash.t index 6c3ef55200..471ee0283b 100755 --- a/t/lib/db-hash.t +++ b/t/lib/db-hash.t @@ -1,7 +1,7 @@ -#!./perl +#!./perl -w BEGIN { - @INC = '../lib'; + @INC = '../lib' if -d '../lib' ; require Config; import Config; if ($Config{'extensions'} !~ /\bDB_File\b/) { print "1..0\n"; @@ -12,65 +12,78 @@ BEGIN { use DB_File; use Fcntl; -print "1..43\n"; +print "1..52\n"; -$Dfile = "Op.db-hash"; +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; +} + +$Dfile = "dbhash.tmp"; unlink $Dfile; umask(0); # Check the interface to HASHINFO -$dbh = TIEHASH DB_File::HASHINFO ; -print (($dbh->{bsize} == undef) ? "ok 1\n" : "not ok 1\n") ; -print (($dbh->{ffactor} == undef) ? "ok 2\n" : "not ok 2\n") ; -print (($dbh->{nelem} == undef) ? "ok 3\n" : "not ok 3\n") ; -print (($dbh->{cachesize} == undef) ? "ok 4\n" : "not ok 4\n") ; -print (($dbh->{hash} == undef) ? "ok 5\n" : "not ok 5\n") ; -print (($dbh->{lorder} == undef) ? "ok 6\n" : "not ok 6\n") ; +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 ; -print ($dbh->{bsize} == 3000 ? "ok 7\n" : "not ok 7\n") ; +ok(7, $dbh->{bsize} == 3000 ); $dbh->{ffactor} = 9000 ; -print ($dbh->{ffactor} == 9000 ? "ok 8\n" : "not ok 8\n") ; -# +ok(8, $dbh->{ffactor} == 9000 ); + $dbh->{nelem} = 400 ; -print (($dbh->{nelem} == 400) ? "ok 9\n" : "not ok 9\n") ; +ok(9, $dbh->{nelem} == 400 ); $dbh->{cachesize} = 65 ; -print (($dbh->{cachesize} == 65) ? "ok 10\n" : "not ok 10\n") ; +ok(10, $dbh->{cachesize} == 65 ); $dbh->{hash} = "abc" ; -print (($dbh->{hash} eq "abc") ? "ok 11\n" : "not ok 11\n") ; +ok(11, $dbh->{hash} eq "abc" ); $dbh->{lorder} = 1234 ; -print ($dbh->{lorder} == 1234 ? "ok 12\n" : "not ok 12\n") ; +ok(12, $dbh->{lorder} == 1234 ); # Check that an invalid entry is caught both for store & fetch eval '$dbh->{fred} = 1234' ; -print ($@ eq '' ? "ok 13\n" : "not ok 13\n") ; -eval '$q = $dbh->{fred}' ; -print ($@ eq '' ? "ok 14\n" : "not ok 14\n") ; +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 -print (($X = tie(%h, DB_File,$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH )) ? "ok 15\n" : "not ok 15"); +ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); -print (($mode & 0777) == 0640 ? "ok 16\n" : "not ok 16\n"); +ok(16, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos'); while (($key,$value) = each(%h)) { $i++; } -print (!$i ? "ok 17\n" : "not ok 17\n"); +ok(17, !$i ); $h{'goner1'} = 'snork'; $h{'abc'} = 'ABC'; -print ($h{'abc'} == 'ABC' ? "ok 18\n" : "not ok 18\n") ; -print (defined $h{'jimmy'} ? "not ok 19\n" : "ok 19\n"); +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"; @@ -102,7 +115,7 @@ untie(%h); # tie to the same file again, do not supply a type - should default to HASH -print (($X = tie(%h,DB_File,$Dfile, O_RDWR, 0640)) ? "ok 20\n" : "not ok 20: $!\n"); +ok(22, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640) ); # Modify an entry from the previous tie $h{'g'} = 'G'; @@ -133,39 +146,40 @@ $X->DELETE('goner3'); @keys = keys(%h); @values = values(%h); -if ($#keys == 29 && $#values == 29) {print "ok 21\n";} else {print "not ok 21\n";} +ok(23, $#keys == 29 && $#values == 29) ; -while (($key,$value) = each(h)) { - if ($key eq $keys[$i] && $value eq $values[$i] && $key gt $value) { +$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; } } -if ($i == 30) {print "ok 22\n";} else {print "not ok 22\n";} +ok(24, $i == 30) ; -@keys = ('blurfl', keys(h), 'dyick'); -if ($#keys == 31) {print "ok 23\n";} else {print "not ok 23\n";} +@keys = ('blurfl', keys(%h), 'dyick'); +ok(25, $#keys == 31) ; $h{'foo'} = ''; -print ($h{'foo'} eq '' ? "ok 24\n" : "not ok 24\n") ; +ok(26, $h{'foo'} eq '' ); $h{''} = 'bar'; -print ($h{''} eq 'bar' ? "ok 25\n" : "not ok 25\n") ; +ok(27, $h{''} eq '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 26\n" : "not ok 26\n"); +ok(28, $ok ); ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); -print ($size > 0 ? "ok 27\n" : "not ok 27\n"); +ok(29, $size > 0 ); @h{0..200} = 200..400; @foo = @h{0..200}; -print join(':',200..400) eq join(':',@foo) ? "ok 28\n" : "not ok 28\n"; +ok(30, join(':',200..400) eq join(':',@foo) ); # Now check all the non-tie specific stuff @@ -174,44 +188,47 @@ print join(':',200..400) eq join(':',@foo) ? "ok 28\n" : "not ok 28\n"; # an existing record. $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; -print ($status == 1 ? "ok 29\n" : "not ok 29\n") ; +ok(31, $status == 1 ); # check that the value of the key 'x' has not been changed by the # previous test -print ($h{'x'} eq 'X' ? "ok 30\n" : "not ok 30\n") ; +ok(32, $h{'x'} eq 'X' ); # standard put $status = $X->put('key', 'value') ; -print ($status == 0 ? "ok 31\n" : "not ok 31\n") ; +ok(33, $status == 0 ); #check that previous put can be retrieved +$value = 0 ; $status = $X->get('key', $value) ; -print ($status == 0 ? "ok 32\n" : "not ok 32\n") ; -print ($value eq 'value' ? "ok 33\n" : "not ok 33\n") ; +ok(34, $status == 0 ); +ok(35, $value eq 'value' ); # Attempting to delete an existing key should work $status = $X->del('q') ; -print ($status == 0 ? "ok 34\n" : "not ok 34\n") ; +ok(36, $status == 0 ); # Make sure that the key deleted, cannot be retrieved -print (($h{'q'} eq undef) ? "ok 35\n" : "not ok 35\n") ; +$^W = 0 ; +ok(37, $h{'q'} eq undef ); +$^W = 1 ; # Attempting to delete a non-existant key should fail $status = $X->del('joe') ; -print ($status == 1 ? "ok 36\n" : "not ok 36\n") ; +ok(38, $status == 1 ); # Check the get interface # First a non-existing key $status = $X->get('aaaa', $value) ; -print ($status == 1 ? "ok 37\n" : "not ok 37\n") ; +ok(39, $status == 1 ); # Next an existing key $status = $X->get('a', $value) ; -print ($status == 0 ? "ok 38\n" : "not ok 38\n") ; -print ($value eq 'A' ? "ok 39\n" : "not ok 39\n") ; +ok(40, $status == 0 ); +ok(41, $value eq 'A' ); # seq # ### @@ -226,28 +243,81 @@ print ($value eq 'A' ? "ok 39\n" : "not ok 39\n") ; # #### $status = $X->sync ; -print ($status == 0 ? "ok 40\n" : "not ok 40\n") ; +ok(42, $status == 0 ); # fd # ## $status = $X->fd ; -print ($status != 0 ? "ok 41\n" : "not ok 41\n") ; +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 -print (($X = tie(%h, DB_File,undef, O_RDWR|O_CREAT, 0640, $DB_HASH )) ? "ok 42\n" : "not ok 42"); +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 ; -print ($status == -1 ? "ok 43\n" : "not ok 43\n") ; +ok(48, $status == -1 ); -untie %h ; 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 ; +} exit ; diff --git a/t/lib/db-recno.t b/t/lib/db-recno.t index 64ad7b8a9e..338edd0db5 100755 --- a/t/lib/db-recno.t +++ b/t/lib/db-recno.t @@ -1,7 +1,7 @@ -#!./perl +#!./perl -w BEGIN { - @INC = '../lib'; + @INC = '../lib' if -d '../lib' ; require Config; import Config; if ($Config{'extensions'} !~ /\bDB_File\b/) { print "1..0\n"; @@ -11,126 +11,185 @@ BEGIN { use DB_File; use Fcntl; +use strict ; +use vars qw($dbh $Dfile $bad_ones) ; -print "1..30\n"; +sub ok +{ + my $no = shift ; + my $result = shift ; -$Dfile = "Op.db-recno"; -unlink $Dfile; + print "not " unless $result ; + print "ok $no\n" ; + + return $result ; +} + +sub bad_one +{ + print STDERR <<EOM unless $bad_ones++ ; +# +# Some older versions of Berkeley DB 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 upgrade Berkeley DB, the most recent version is 1.85. +# Check out http://www.bostic.com/db for more details. +# +EOM +} + +print "1..56\n"; + +my $Dfile = "recno.tmp"; +unlink $Dfile ; umask(0); # Check the interface to RECNOINFO -$dbh = TIEHASH DB_File::RECNOINFO ; -print (($dbh->{bval} == undef) ? "ok 1\n" : "not ok 1\n") ; -print (($dbh->{cachesize} == undef) ? "ok 2\n" : "not ok 2\n") ; -print (($dbh->{psize} == undef) ? "ok 3\n" : "not ok 3\n") ; -print (($dbh->{flags} == undef) ? "ok 4\n" : "not ok 4\n") ; -print (($dbh->{lorder} == undef) ? "ok 5\n" : "not ok 5\n") ; -print (($dbh->{reclen} == undef) ? "ok 6\n" : "not ok 6\n") ; -print (($dbh->{bfname} == undef) ? "ok 7\n" : "not ok 7\n") ; +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 ; -print ($dbh->{bval} == 3000 ? "ok 8\n" : "not ok 8\n") ; +ok(8, $dbh->{bval} == 3000 ); $dbh->{cachesize} = 9000 ; -print ($dbh->{cachesize} == 9000 ? "ok 9\n" : "not ok 9\n") ; +ok(9, $dbh->{cachesize} == 9000 ); $dbh->{psize} = 400 ; -print (($dbh->{psize} == 400) ? "ok 10\n" : "not ok 10\n") ; +ok(10, $dbh->{psize} == 400 ); $dbh->{flags} = 65 ; -print (($dbh->{flags} == 65) ? "ok 11\n" : "not ok 11\n") ; +ok(11, $dbh->{flags} == 65 ); $dbh->{lorder} = 123 ; -print (($dbh->{lorder} == 123) ? "ok 12\n" : "not ok 12\n") ; +ok(12, $dbh->{lorder} == 123 ); $dbh->{reclen} = 1234 ; -print ($dbh->{reclen} == 1234 ? "ok 13\n" : "not ok 13\n") ; +ok(13, $dbh->{reclen} == 1234 ); $dbh->{bfname} = 1234 ; -print ($dbh->{bfname} == 1234 ? "ok 14\n" : "not ok 14\n") ; +ok(14, $dbh->{bfname} == 1234 ); # Check that an invalid entry is caught both for store & fetch eval '$dbh->{fred} = 1234' ; -print ($@ eq '' ? "ok 15\n" : "not ok 15\n") ; -eval '$q = $dbh->{fred}' ; -print ($@ eq '' ? "ok 16\n" : "not ok 16\n") ; +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 -print (($X = tie(@h, DB_File,$Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO )) ? "ok 17\n" : "not ok 17"); +my $X ; +my @h ; +ok(17, $X = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ; -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); -print (($mode & 0777) == 0640 ? "ok 18\n" : "not ok 18\n"); +ok(18, ((stat($Dfile))[2] & 0777) == ($^O eq 'os2' ? 0666 : 0640) + || $^O eq 'amigaos') ; -#$l = @h ; -$l = $X->length ; -print (!$l ? "ok 19\n" : "not ok 19\n"); +#my $l = @h ; +my $l = $X->length ; +ok(19, !$l ); -@data = qw( a b c d ever f g h i j k longername m n o p) ; +my @data = qw( a b c d ever f g h i j k longername m n o p) ; $h[0] = shift @data ; -print ($h[0] eq 'a' ? "ok 20\n" : "not ok 20\n") ; +ok(20, $h[0] eq 'a' ); +my $ i; foreach (@data) { $h[++$i] = $_ } unshift (@data, 'a') ; -print (defined $h[1] ? "ok 21\n" : "not ok 21\n"); -print (! defined $h[16] ? "ok 22\n" : "not ok 22\n"); -print ($X->length == @data ? "ok 23\n" : "not ok 23\n") ; +ok(21, defined $h[1] ); +ok(22, ! defined $h[16] ); +ok(23, $X->length == @data ); # Overwrite an entry & check fetch it $h[3] = 'replaced' ; $data[3] = 'replaced' ; -print ($h[3] eq 'replaced' ? "ok 24\n" : "not ok 24\n"); +ok(24, $h[3] eq 'replaced' ); #PUSH -@push_data = qw(added to the end) ; -#push (@h, @push_data) ; +my @push_data = qw(added to the end) ; +#my push (@h, @push_data) ; $X->push(@push_data) ; push (@data, @push_data) ; -print ($h[++$i] eq 'added' ? "ok 25\n" : "not ok 25\n"); +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 -pop (@data) ; -#$value = pop(@h) ; -$value = $X->pop ; -print ($value eq 'end' ? "not ok 26\n" : "ok 26\n"); +my $popped = pop (@data) ; +#my $value = pop(@h) ; +my $value = $X->pop ; +ok(29, $value eq $popped) ; # SHIFT #$value = shift @h $value = $X->shift ; -print ($value eq shift @data ? "not ok 27\n" : "ok 27\n"); +my $shifted = shift @data ; +ok(30, $value eq $shifted ); # UNSHIFT # empty list $X->unshift ; -print ($X->length == @data ? "ok 28\n" : "not ok 28\n") ; +ok(31, $X->length == @data ); -@new_data = qw(add this to the start of the array) ; +my @new_data = qw(add this to the start of the array) ; #unshift @h, @new_data ; $X->unshift (@new_data) ; unshift (@data, @new_data) ; -print ($X->length == @data ? "ok 29\n" : "not ok 29\n") ; +ok(32, $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 -$ok = 1 ; -$j = 0 ; +my $ok = 1 ; +my $j = 0 ; foreach (@data) { $ok = 0, last if $_ ne $h[$j ++] ; } -print ($ok ? "ok 30\n" : "not ok 30\n") ; +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[$X->length -1] ); + +# get the first element using a negative subscript +eval '$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 + $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. @@ -139,4 +198,86 @@ 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 = `cat $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 = `cat $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 = `cat $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 = `cat $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 ; +} + exit ; diff --git a/t/lib/dirhand.t b/t/lib/dirhand.t index 8403609578..aa7be356df 100755 --- a/t/lib/dirhand.t +++ b/t/lib/dirhand.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require Config; import Config; - if ($Config{'extensions'} !~ /\bPOSIX\b/) { + if (not $Config{'d_readdir'}) { print "1..0\n"; exit 0; } @@ -17,7 +17,7 @@ print "1..5\n"; $dot = new DirHandle "."; print defined($dot) ? "ok" : "not ok", " 1\n"; -@a = <*>; +@a = sort <*>; do { $first = $dot->read } while defined($first) && $first =~ /^\./; print +(grep { $_ eq $first } @a) ? "ok" : "not ok", " 2\n"; diff --git a/t/lib/env.t b/t/lib/env.t new file mode 100755 index 0000000000..5a8220778a --- /dev/null +++ b/t/lib/env.t @@ -0,0 +1,18 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +BEGIN { + $ENV{FOO} = "foo"; +} + +use Env qw(FOO); + +$FOO .= "/bar"; + +print "1..1\n"; +print "not " if $FOO ne 'foo/bar'; +print "ok 1\n"; diff --git a/t/lib/filecache.t b/t/lib/filecache.t new file mode 100755 index 0000000000..a97fdd532c --- /dev/null +++ b/t/lib/filecache.t @@ -0,0 +1,25 @@ +#!./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/t/lib/filecopy.t b/t/lib/filecopy.t new file mode 100755 index 0000000000..b718215a1e --- /dev/null +++ b/t/lib/filecopy.t @@ -0,0 +1,88 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..11\n"; + +$| = 1; + +use File::Copy; + +# First we create a file +open(F, ">file-$$") or die; +print F "ok 3\n"; +close F; + +copy "file-$$", "copy-$$"; + +open(F, "copy-$$") or die; +$foo = <F>; +close(F); + +print "not " if -s "file-$$" != -s "copy-$$"; +print "ok 1\n"; + +print "not " unless $foo eq "ok 3\n"; +print "ok 2\n"; + +copy "copy-$$", \*STDOUT; +unlink "copy-$$" or die "unlink: $!"; + +open(F,"file-$$"); +copy(*F, "copy-$$"); +open(R, "copy-$$") or die "open copy-$$: $!"; $foo = <R>; close(R); +print "not " unless $foo eq "ok 3\n"; +print "ok 4\n"; +unlink "copy-$$" or die "unlink: $!"; +open(F,"file-$$"); +copy(\*F, "copy-$$"); +close(F) or die "close: $!"; +open(R, "copy-$$") or die; $foo = <R>; close(R) or die "close: $!"; +print "not " unless $foo eq "ok 3\n"; +print "ok 5\n"; +unlink "copy-$$" or die "unlink: $!"; + +require IO::File; +$fh = IO::File->new(">copy-$$") or die "Cannot open copy-$$:$!"; +binmode $fh or die; +copy("file-$$",$fh); +$fh->close or die "close: $!"; +open(R, "copy-$$") or die; $foo = <R>; close(R); +print "# foo=`$foo'\nnot " unless $foo eq "ok 3\n"; +print "ok 6\n"; +unlink "copy-$$" or die "unlink: $!"; +require FileHandle; +my $fh = FileHandle->new(">copy-$$") or die "Cannot open copy-$$:$!"; +binmode $fh or die; +copy("file-$$",$fh); +$fh->close; +open(R, "copy-$$") or die; $foo = <R>; close(R); +print "not " unless $foo eq "ok 3\n"; +print "ok 7\n"; +unlink "file-$$" or die "unlink: $!"; + +print "# moved missing file.\nnot " if move("file-$$", "copy-$$"); +print "# target disappeared.\nnot " if not -e "copy-$$"; +print "ok 8\n"; + +move "copy-$$", "file-$$" or print "# move did not succeed.\n"; +print "# not moved: $!\nnot " unless -e "file-$$" and not -e "copy-$$"; +open(R, "file-$$") or die; $foo = <R>; close(R); +print "# foo=`$foo'\nnot " unless $foo eq "ok 3\n"; +print "ok 9\n"; + +copy "file-$$", "lib"; +open(R, "lib/file-$$") or die; $foo = <R>; close(R); +print "not " unless $foo eq "ok 3\n"; +print "ok 10\n"; +unlink "lib/file-$$" or die "unlink: $!"; + +move "file-$$", "lib"; +open(R, "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R); +print "not " unless $foo eq "ok 3\n" and not -e "file-$$";; +print "ok 11\n"; +unlink "lib/file-$$" or die "unlink: $!"; + diff --git a/t/lib/filefind.t b/t/lib/filefind.t new file mode 100755 index 0000000000..21e29a2d7f --- /dev/null +++ b/t/lib/filefind.t @@ -0,0 +1,13 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..1\n"; + +use File::Find; + +# hope we will eventually find ourself +find(sub { print "ok 1\n" if $_ eq 'filefind.t'; }, "."); diff --git a/t/lib/filehand.t b/t/lib/filehand.t index fc43350212..c23a7e0475 100755 --- a/t/lib/filehand.t +++ b/t/lib/filehand.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require Config; import Config; - if ($Config{'extensions'} !~ /\bFileHandle\b/ && $^O ne 'VMS') { + if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { print "1..0\n"; exit 0; } @@ -13,23 +13,72 @@ BEGIN { use FileHandle; use strict subs; +autoflush STDOUT 1; + $mystdout = new_from_fd FileHandle 1,"w"; -autoflush STDOUT; +$| = 1; autoflush $mystdout; -print "1..4\n"; +print "1..11\n"; print $mystdout "ok ",fileno($mystdout),"\n"; -$fh = new FileHandle "TEST", O_RDONLY and print "ok 2\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"; -if ($^O eq 'VMS') { - ungetc $fh 65; - CORE::read($fh, $buf,1); + +ungetc $fh 65; +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 "not " 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"; + +($rd,$wr) = FileHandle::pipe; + +if ($^O eq 'VMS' || $^O eq 'os2' || $^O eq 'amigaos' || $^O eq 'MSWin32') { + $wr->autoflush; + $wr->printf("ok %d\n",11); + print $rd->getline; } else { - ungetc STDIN 65; - CORE::read(STDIN, $buf,1); + if (fork) { + $wr->close; + print $rd->getline; + } + else { + $rd->close; + $wr->printf("ok %d\n",11); + exit(0); + } } -print $buf eq 'A' ? "ok 4\n" : "not ok 4\n"; diff --git a/t/lib/filepath.t b/t/lib/filepath.t new file mode 100755 index 0000000000..c3bf4a4479 --- /dev/null +++ b/t/lib/filepath.t @@ -0,0 +1,28 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use File::Path; +use strict; + +my $count = 0; +$^W = 1; + +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/t/lib/findbin.t b/t/lib/findbin.t new file mode 100755 index 0000000000..3e742f9a4f --- /dev/null +++ b/t/lib/findbin.t @@ -0,0 +1,13 @@ +#!./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/t/lib/gdbm.t b/t/lib/gdbm.t index 0d2c1fe023..a0f081fa1e 100755 --- a/t/lib/gdbm.t +++ b/t/lib/gdbm.t @@ -24,9 +24,14 @@ $Dfile = "Op.dbmx.pag"; if (! -e $Dfile) { ($Dfile) = <Op.dbmx*>; } -($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"); +if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32') { + print "ok 2\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++; } @@ -83,7 +88,7 @@ delete $h{'goner3'}; 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 gt $value) { + if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { $key =~ y/a-z/A-Z/; $i++ if $key eq $value; } @@ -114,4 +119,5 @@ 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; diff --git a/t/lib/getopt.t b/t/lib/getopt.t new file mode 100755 index 0000000000..fb70f10aae --- /dev/null +++ b/t/lib/getopt.t @@ -0,0 +1,73 @@ +#!./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/t/lib/hostname.t b/t/lib/hostname.t new file mode 100755 index 0000000000..e4ac36521c --- /dev/null +++ b/t/lib/hostname.t @@ -0,0 +1,19 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Sys::Hostname; + +eval { + $host = hostname; +}; + +if ($@) { + print "1..0\n" if $@ =~ /Cannot get host name/; +} else { + print "1..1\n"; + print "ok 1\n"; +} diff --git a/t/lib/io_dup.t b/t/lib/io_dup.t new file mode 100755 index 0000000000..6b0caf14fa --- /dev/null +++ b/t/lib/io_dup.t @@ -0,0 +1,61 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { + print "1..0\n"; + exit 0; + } + } +} + +use IO::Handle; +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/t/lib/io_pipe.t b/t/lib/io_pipe.t new file mode 100755 index 0000000000..eee374149c --- /dev/null +++ b/t/lib/io_pipe.t @@ -0,0 +1,109 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if (! $Config{'d_fork'} || + ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS')) + { + print "1..0\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"; + +$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; + + +print "ok 10\n"; + diff --git a/t/lib/io_sel.t b/t/lib/io_sel.t new file mode 100755 index 0000000000..b9c1097404 --- /dev/null +++ b/t/lib/io_sel.t @@ -0,0 +1,116 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +select(STDERR); $| = 1; +select(STDOUT); $| = 1; + +print "1..21\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') { # 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"; diff --git a/t/lib/io_sock.t b/t/lib/io_sock.t new file mode 100755 index 0000000000..06a973cc70 --- /dev/null +++ b/t/lib/io_sock.t @@ -0,0 +1,77 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if (-d "lib" && -f "TEST") { + if (!$Config{'d_fork'} || + (($Config{'extensions'} !~ /\bSocket\b/ || + $Config{'extensions'} !~ /\bIO\b/) && + !(($^O eq 'VMS') && $Config{d_socket}))) { + print "1..0\n"; + exit 0; + } + } +} + +$| = 1; +print "1..5\n"; + +use IO::Socket; + +$listen = IO::Socket::INET->new(Listen => 2, + Proto => 'tcp', + ) or die "$!"; + +print "ok 1\n"; + +$port = $listen->sockport; + +if($pid = fork()) { + + $sock = $listen->accept(); + 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' + ) or die "$!"; + + $sock->autoflush(1); + + print $sock "ok 3\n"; + + print $sock->getline(); + + $sock->close; + + exit; +} else { + die; +} + + + + + + diff --git a/t/lib/io_taint.t b/t/lib/io_taint.t new file mode 100755 index 0000000000..0ef2cfd63f --- /dev/null +++ b/t/lib/io_taint.t @@ -0,0 +1,48 @@ +#!./perl -T + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { + print "1..0\n"; + exit 0; + } + } +} + +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/t/lib/io_tell.t b/t/lib/io_tell.t new file mode 100755 index 0000000000..d8ebae24fd --- /dev/null +++ b/t/lib/io_tell.t @@ -0,0 +1,64 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../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'; +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/t/lib/io_udp.t b/t/lib/io_udp.t new file mode 100755 index 0000000000..d8377f6446 --- /dev/null +++ b/t/lib/io_udp.t @@ -0,0 +1,40 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ( ($Config{'extensions'} !~ /\bSocket\b/ || + $Config{'extensions'} !~ /\bIO\b/ || + $^O eq 'os2') && + !(($^O eq 'VMS') && $Config{d_socket})) { + print "1..0\n"; + exit 0; + } + } +} + +$| = 1; +print "1..3\n"; + +use Socket; +use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY); + +$udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost'); +$udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost'); + +print "ok 1\n"; + +$udpa->send("ok 2\n",0,$udpb->sockname); +$udpb->recv($buf="",5); +print $buf; +$udpb->send("ok 3\n"); +$udpa->recv($buf="",5); +print $buf; diff --git a/t/lib/io_xs.t b/t/lib/io_xs.t new file mode 100755 index 0000000000..1a6fd381a3 --- /dev/null +++ b/t/lib/io_xs.t @@ -0,0 +1,42 @@ +#!./perl + +BEGIN { + unless(grep /blib/, @INC) { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + } +} + +use Config; + +BEGIN { + if(-d "lib" && -f "TEST") { + if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { + print "1..0\n"; + exit 0; + } + } +} + +use IO::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/t/lib/ndbm.t b/t/lib/ndbm.t index e3093dbcfb..b10d7c26d4 100755 --- a/t/lib/ndbm.t +++ b/t/lib/ndbm.t @@ -27,9 +27,14 @@ $Dfile = "Op.dbmx.pag"; if (! -e $Dfile) { ($Dfile) = <Op.dbmx*>; } -($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"); +if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32') { + print "ok 2\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++; } @@ -86,7 +91,7 @@ delete $h{'goner3'}; 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 gt $value) { + if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { $key =~ y/a-z/A-Z/; $i++ if $key eq $value; } @@ -117,4 +122,5 @@ 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; diff --git a/t/lib/odbm.t b/t/lib/odbm.t index b49aa91043..06ba844029 100755 --- a/t/lib/odbm.t +++ b/t/lib/odbm.t @@ -27,9 +27,14 @@ $Dfile = "Op.dbmx.pag"; if (! -e $Dfile) { ($Dfile) = <Op.dbmx*>; } -($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"); +if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32') { + print "ok 2\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++; } @@ -86,7 +91,7 @@ delete $h{'goner3'}; 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 gt $value) { + if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { $key =~ y/a-z/A-Z/; $i++ if $key eq $value; } @@ -117,4 +122,5 @@ 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; diff --git a/t/lib/opcode.t b/t/lib/opcode.t new file mode 100755 index 0000000000..a785fce48b --- /dev/null +++ b/t/lib/opcode.t @@ -0,0 +1,115 @@ +#!./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/t/lib/open2.t b/t/lib/open2.t new file mode 100755 index 0000000000..a2e6a07a7b --- /dev/null +++ b/t/lib/open2.t @@ -0,0 +1,46 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + unless ($Config{'d_fork'}) { + 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; + } +} + +my ($pid, $reaped_pid); +STDOUT->autoflush; +STDERR->autoflush; + +print "1..7\n"; + +ok 1, $pid = open2 'READ', 'WRITE', $perl, '-e', 'print scalar <STDIN>'; +ok 2, print WRITE "hi kid\n"; +ok 3, <READ> eq "hi kid\n"; +ok 4, close(WRITE), $!; +ok 5, close(READ), $!; +$reaped_pid = waitpid $pid, 0; +ok 6, $reaped_pid == $pid, $reaped_pid; +ok 7, $? == 0, $?; diff --git a/t/lib/open3.t b/t/lib/open3.t new file mode 100755 index 0000000000..4258eec401 --- /dev/null +++ b/t/lib/open3.t @@ -0,0 +1,121 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + unless ($Config{'d_fork'}) { + 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 = './perl'; + +sub ok { + my ($n, $result, $info) = @_; + if ($result) { + print "ok $n\n"; + } + else { + print "not ok $n\n"; + print "# $info\n" if $info; + } +} + +my ($pid, $reaped_pid); +STDOUT->autoflush; +STDERR->autoflush; + +print "1..21\n"; + +# basic +ok 1, $pid = open3 'WRITE', 'READ', 'ERROR', $perl, '-e', <<'EOF'; + $| = 1; + print scalar <STDIN>; + print STDERR "hi error\n"; +EOF +ok 2, print WRITE "hi kid\n"; +ok 3, <READ> eq "hi kid\n"; +ok 4, <ERROR> eq "hi error\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', <<'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', <<'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', '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', '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', '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', <<'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', <<'EOF'; + $| = 1; + print STDOUT scalar <STDIN>; + print STDERR scalar <STDIN>; +EOF +print WRITE "ok 20\n"; +print WRITE "ok 21\n"; +waitpid $pid, 0; diff --git a/t/lib/ops.t b/t/lib/ops.t new file mode 100755 index 0000000000..56b1bacabb --- /dev/null +++ b/t/lib/ops.t @@ -0,0 +1,29 @@ +#!./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/t/lib/parsewords.t b/t/lib/parsewords.t new file mode 100755 index 0000000000..47a75881dc --- /dev/null +++ b/t/lib/parsewords.t @@ -0,0 +1,28 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..4\n"; + +use Text::ParseWords; + +@words = shellwords(qq(foo "bar quiz" zoo)); +#print join(";", @words), "\n"; + +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"; + +# Test quotewords() with other parameters +@words = quotewords(":+", 1, qq(foo:::"bar:foo":zoo zoo:)); +#print join(";", @words), "\n"; +print "not " unless join(";", @words) eq qq(foo;"bar:foo";zoo zoo); +print "ok 4\n"; diff --git a/t/lib/posix.t b/t/lib/posix.t index 23007ff059..6ae88c0dd2 100755 --- a/t/lib/posix.t +++ b/t/lib/posix.t @@ -14,7 +14,7 @@ use POSIX qw(fcntl_h signal_h limits_h _exit getcwd open read write); use strict subs; $| = 1; -print "1..14\n"; +print "1..17\n"; $testfd = open("TEST", O_RDONLY, 0) and print "ok 1\n"; read($testfd, $buffer, 9) if $testfd > 2; @@ -58,8 +58,27 @@ 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'); + 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 14\n" : "not ok 14\n"; +print &POSIX::acos(1.0) == 0.0 ? "ok 17\n" : "not ok 17\n"; $| = 0; print '@#!*$@(!@#$'; diff --git a/t/lib/safe.t b/t/lib/safe.t deleted file mode 100755 index e59c81406b..0000000000 --- a/t/lib/safe.t +++ /dev/null @@ -1,96 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bSafe\b/ && $^O ne 'VMS') { - print "1..0\n"; - exit 0; - } -} - -use Safe qw(opname opcode ops_to_mask mask_to_ops); - -print "1..23\n"; - -# Set up a package namespace of things to be visible to the unsafe code -$Root::foo = "visible"; - -# Stop perl from moaning about identifies which are apparently only used once -$Root::foo .= ""; -$bar .= ""; - -$bar = "invisible"; -$cpt = new Safe "Root"; -$cpt->reval(q{ - system("echo not ok 1"); -}); -if ($@ =~ /^system trapped by operation mask/) { - print "ok 1\n"; -} else { - 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 = "o"; -push(@baz, "10"); # Two steps to prevent "Identifier used only once..." -$glob = "ok 11\n"; -@glob = qw(not ok 16); - -$" = 'k '; - -sub sayok12 { print "ok 12\n" } - -$cpt->share(qw($foo %bar @baz *glob &sayok12 $")); - -$cpt->reval(q{ - print $foo ? $foo : "not ok 8\n"; - print $bar{key} ? $bar{key} : "not ok 9\n"; - if (@baz) { - print "@baz\n"; - } else { - print "not ok 10\n"; - } - print $glob; - sayok12(); - $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"; - -print opname(23) eq "bless" ? "ok 19\n" : "not ok 19\n"; -print opcode("bless") == 23 ? "ok 20\n" : "not ok 20\n"; - -$m1 = $cpt->mask(); -$cpt->trap("negate"); -$m2 = $cpt->mask(); -@masked = mask_to_ops($m1); -print $m2 eq ops_to_mask("negate", @masked) ? "ok 21\n" : "not ok 21\n"; -$cpt->untrap(187); -substr($m2, 187, 1) = "\0"; -print $m2 eq $cpt->mask() ? "ok 22\n" : "not ok 22\n"; - -print $cpt->reval("2 + 2") == 4 ? "ok 23\n" : "not ok 23\n"; diff --git a/t/lib/safe1.t b/t/lib/safe1.t new file mode 100755 index 0000000000..27993d95c9 --- /dev/null +++ b/t/lib/safe1.t @@ -0,0 +1,68 @@ +#!./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/t/lib/safe2.t b/t/lib/safe2.t new file mode 100755 index 0000000000..feaab16956 --- /dev/null +++ b/t/lib/safe2.t @@ -0,0 +1,142 @@ +#!./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 + +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->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'); +print +(($! =~ /No such file/ || $! =~ /file specification syntax error/) || + $! =~ /A file or directory in the path name does not exist/ || + $! =~ /Device not configured/ ? + "ok $t\n" : "not ok $t # $!\n"); $t++; +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/t/lib/sdbm.t b/t/lib/sdbm.t index a754bb72a4..9928847b94 100755 --- a/t/lib/sdbm.t +++ b/t/lib/sdbm.t @@ -20,15 +20,21 @@ print "1..12\n"; unlink <Op.dbmx*>; umask(0); -print (tie(%h,SDBM_File,'Op.dbmx', O_RDWR|O_CREAT, 0640) ? "ok 1\n" : "not ok 1\n"); +print (tie(%h,SDBM_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*>; } -($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"); +if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32') { + print "ok 2\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++; } @@ -85,7 +91,7 @@ delete $h{'goner3'}; 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 gt $value) { + if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { $key =~ y/a-z/A-Z/; $i++ if $key eq $value; } @@ -116,4 +122,5 @@ 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; diff --git a/t/lib/searchdict.t b/t/lib/searchdict.t new file mode 100755 index 0000000000..447c425b27 --- /dev/null +++ b/t/lib/searchdict.t @@ -0,0 +1,65 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..3\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, "abash"; +chomp($word = <DICT>); +print "not " if $pos < 0 || $word ne "abash"; +print "ok 1\n"; + +$pos = look *DICT, "foo"; +chomp($word = <DICT>); + +print "not " if $pos != length($DICT); # will search to end of file +print "ok 2\n"; + +$pos = look *DICT, "aarhus", 1, 1; +chomp($word = <DICT>); + +print "not " if $pos < 0 || $word ne "Aarhus"; +print "ok 3\n"; + +close DICT or die "cannot close"; +unlink "dict-$$"; diff --git a/t/lib/selectsaver.t b/t/lib/selectsaver.t new file mode 100755 index 0000000000..3b58d709ab --- /dev/null +++ b/t/lib/selectsaver.t @@ -0,0 +1,28 @@ +#!./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/t/lib/socket.t b/t/lib/socket.t index afc2a5bb75..4e382958ce 100755 --- a/t/lib/socket.t +++ b/t/lib/socket.t @@ -5,7 +5,7 @@ BEGIN { @INC = '../lib' if -d '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bSocket\b/ && - !(($^O eq 'VMS') && $Config{d_has_socket})) { + !(($^O eq 'VMS') && $Config{d_socket})) { print "1..0\n"; exit 0; } @@ -26,6 +26,10 @@ if (socket(T,PF_INET,SOCK_STREAM,6)) { 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 { @@ -52,6 +56,10 @@ if( socket(S,PF_INET,SOCK_STREAM,6) ){ 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 { diff --git a/t/lib/symbol.t b/t/lib/symbol.t new file mode 100755 index 0000000000..03449a3ed7 --- /dev/null +++ b/t/lib/symbol.t @@ -0,0 +1,52 @@ +#!./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/t/lib/texttabs.t b/t/lib/texttabs.t new file mode 100755 index 0000000000..ea9012c652 --- /dev/null +++ b/t/lib/texttabs.t @@ -0,0 +1,28 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..3\n"; + +use Text::Tabs; + +$tabstop = 4; + +$s1 = "foo\tbar\tb\tb"; +$s2 = expand $s1; +$s3 = unexpand $s2; + +print "not " unless $s2 eq "foo bar b b"; +print "ok 1\n"; + +print "not " unless $s3 eq "foo bar b\tb"; +print "ok 2\n"; + + +$tabstop = 8; + +print "not " unless unexpand(" foo") eq "\t\t foo"; +print "ok 3\n"; diff --git a/t/lib/textwrap.t b/t/lib/textwrap.t new file mode 100755 index 0000000000..9c8d1b4975 --- /dev/null +++ b/t/lib/textwrap.t @@ -0,0 +1,40 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..5\n"; + +use Text::Wrap qw(wrap $columns); + +$columns = 30; + +$text = <<'EOT'; +Text::Wrap is a very simple paragraph formatter. It formats a +single paragraph at a time by breaking lines at word boundries. +Indentation is controlled for the first line ($initial_tab) and +all subsquent lines ($subsequent_tab) independently. $Text::Wrap::columns +should be set to the full width of your output device. +EOT + +$text =~ s/\n/ /g; +$_ = wrap "| ", "|", $text; + +#print "$_\n"; + +print "not " unless /^\| Text::Wrap is/; # start is ok +print "ok 1\n"; + +print "not " if /^.{31,}$/m; # no line longer than 30 chars +print "ok 2\n"; + +print "not " unless /^\|\w/m; # other lines start with +print "ok 3\n"; + +print "not " unless /\bsubsquent\b/; # look for a random word +print "ok 4\n"; + +print "not " unless /\bdevice\./; # look for last word +print "ok 5\n"; diff --git a/t/lib/timelocal.t b/t/lib/timelocal.t new file mode 100755 index 0000000000..adc1b1b061 --- /dev/null +++ b/t/lib/timelocal.t @@ -0,0 +1,87 @@ +#!./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, 1, 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], + ); + +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/t/lib/trig.t b/t/lib/trig.t new file mode 100755 index 0000000000..c2bc2a8b5b --- /dev/null +++ b/t/lib/trig.t @@ -0,0 +1,57 @@ +#!./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; + +sub near ($$;$) { + abs($_[0] - $_[1]) < (defined $_[2] ? $_[2] : $eps); +} + +print "1..7\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"; + +# eof |