From ff6b7ba98e8d4aab04cbe2bfdffdfc9171c1812b Mon Sep 17 00:00:00 2001 From: Mark Murray Date: Wed, 9 Sep 1998 07:00:04 +0000 Subject: Initial import of Perl5. The king is dead; long live the king! --- contrib/perl5/t/lib/abbrev.t | 51 +++ contrib/perl5/t/lib/anydbm.t | 125 ++++++ contrib/perl5/t/lib/autoloader.t | 100 +++++ contrib/perl5/t/lib/basename.t | 139 ++++++ contrib/perl5/t/lib/bigint.t | 282 ++++++++++++ contrib/perl5/t/lib/bigintpm.t | 313 +++++++++++++ contrib/perl5/t/lib/cgi-form.t | 81 ++++ contrib/perl5/t/lib/cgi-function.t | 85 ++++ contrib/perl5/t/lib/cgi-html.t | 66 +++ contrib/perl5/t/lib/cgi-request.t | 93 ++++ contrib/perl5/t/lib/checktree.t | 19 + contrib/perl5/t/lib/complex.t | 879 +++++++++++++++++++++++++++++++++++++ contrib/perl5/t/lib/db-btree.t | 612 ++++++++++++++++++++++++++ contrib/perl5/t/lib/db-hash.t | 416 ++++++++++++++++++ contrib/perl5/t/lib/db-recno.t | 453 +++++++++++++++++++ contrib/perl5/t/lib/dirhand.t | 33 ++ contrib/perl5/t/lib/dosglob.t | 112 +++++ contrib/perl5/t/lib/dumper-ovl.t | 30 ++ contrib/perl5/t/lib/dumper.t | 611 ++++++++++++++++++++++++++ contrib/perl5/t/lib/english.t | 47 ++ contrib/perl5/t/lib/env.t | 18 + contrib/perl5/t/lib/errno.t | 50 +++ contrib/perl5/t/lib/fields.t | 112 +++++ contrib/perl5/t/lib/filecache.t | 25 ++ contrib/perl5/t/lib/filecopy.t | 90 ++++ contrib/perl5/t/lib/filefind.t | 14 + contrib/perl5/t/lib/filehand.t | 90 ++++ contrib/perl5/t/lib/filepath.t | 28 ++ contrib/perl5/t/lib/filespec.t | 43 ++ contrib/perl5/t/lib/findbin.t | 13 + contrib/perl5/t/lib/gdbm.t | 208 +++++++++ contrib/perl5/t/lib/getopt.t | 73 +++ contrib/perl5/t/lib/h2ph.h | 85 ++++ contrib/perl5/t/lib/h2ph.pht | 69 +++ contrib/perl5/t/lib/h2ph.t | 34 ++ contrib/perl5/t/lib/hostname.t | 19 + contrib/perl5/t/lib/io_dup.t | 61 +++ contrib/perl5/t/lib/io_pipe.t | 117 +++++ contrib/perl5/t/lib/io_sel.t | 116 +++++ contrib/perl5/t/lib/io_sock.t | 91 ++++ contrib/perl5/t/lib/io_taint.t | 48 ++ contrib/perl5/t/lib/io_tell.t | 64 +++ contrib/perl5/t/lib/io_udp.t | 48 ++ contrib/perl5/t/lib/io_xs.t | 42 ++ contrib/perl5/t/lib/ipc_sysv.t | 178 ++++++++ contrib/perl5/t/lib/ndbm.t | 207 +++++++++ contrib/perl5/t/lib/odbm.t | 207 +++++++++ contrib/perl5/t/lib/opcode.t | 115 +++++ contrib/perl5/t/lib/open2.t | 59 +++ contrib/perl5/t/lib/open3.t | 136 ++++++ contrib/perl5/t/lib/ops.t | 29 ++ contrib/perl5/t/lib/parsewords.t | 103 +++++ contrib/perl5/t/lib/ph.t | 96 ++++ contrib/perl5/t/lib/posix.t | 101 +++++ contrib/perl5/t/lib/safe1.t | 68 +++ contrib/perl5/t/lib/safe2.t | 146 ++++++ contrib/perl5/t/lib/sdbm.t | 212 +++++++++ contrib/perl5/t/lib/searchdict.t | 65 +++ contrib/perl5/t/lib/selectsaver.t | 28 ++ contrib/perl5/t/lib/socket.t | 76 ++++ contrib/perl5/t/lib/soundex.t | 143 ++++++ contrib/perl5/t/lib/symbol.t | 52 +++ contrib/perl5/t/lib/texttabs.t | 28 ++ contrib/perl5/t/lib/textwrap.t | 40 ++ contrib/perl5/t/lib/thread.t | 73 +++ contrib/perl5/t/lib/tie-push.t | 24 + contrib/perl5/t/lib/tie-stdarray.t | 12 + contrib/perl5/t/lib/tie-stdpush.t | 10 + contrib/perl5/t/lib/timelocal.t | 90 ++++ contrib/perl5/t/lib/trig.t | 160 +++++++ 70 files changed, 8563 insertions(+) create mode 100755 contrib/perl5/t/lib/abbrev.t create mode 100755 contrib/perl5/t/lib/anydbm.t create mode 100755 contrib/perl5/t/lib/autoloader.t create mode 100755 contrib/perl5/t/lib/basename.t create mode 100755 contrib/perl5/t/lib/bigint.t create mode 100755 contrib/perl5/t/lib/bigintpm.t create mode 100755 contrib/perl5/t/lib/cgi-form.t create mode 100755 contrib/perl5/t/lib/cgi-function.t create mode 100755 contrib/perl5/t/lib/cgi-html.t create mode 100755 contrib/perl5/t/lib/cgi-request.t create mode 100755 contrib/perl5/t/lib/checktree.t create mode 100755 contrib/perl5/t/lib/complex.t create mode 100755 contrib/perl5/t/lib/db-btree.t create mode 100755 contrib/perl5/t/lib/db-hash.t create mode 100755 contrib/perl5/t/lib/db-recno.t create mode 100755 contrib/perl5/t/lib/dirhand.t create mode 100755 contrib/perl5/t/lib/dosglob.t create mode 100755 contrib/perl5/t/lib/dumper-ovl.t create mode 100755 contrib/perl5/t/lib/dumper.t create mode 100755 contrib/perl5/t/lib/english.t create mode 100755 contrib/perl5/t/lib/env.t create mode 100755 contrib/perl5/t/lib/errno.t create mode 100755 contrib/perl5/t/lib/fields.t create mode 100755 contrib/perl5/t/lib/filecache.t create mode 100755 contrib/perl5/t/lib/filecopy.t create mode 100755 contrib/perl5/t/lib/filefind.t create mode 100755 contrib/perl5/t/lib/filehand.t create mode 100755 contrib/perl5/t/lib/filepath.t create mode 100755 contrib/perl5/t/lib/filespec.t create mode 100755 contrib/perl5/t/lib/findbin.t create mode 100755 contrib/perl5/t/lib/gdbm.t create mode 100755 contrib/perl5/t/lib/getopt.t create mode 100644 contrib/perl5/t/lib/h2ph.h create mode 100644 contrib/perl5/t/lib/h2ph.pht create mode 100755 contrib/perl5/t/lib/h2ph.t create mode 100755 contrib/perl5/t/lib/hostname.t create mode 100755 contrib/perl5/t/lib/io_dup.t create mode 100755 contrib/perl5/t/lib/io_pipe.t create mode 100755 contrib/perl5/t/lib/io_sel.t create mode 100755 contrib/perl5/t/lib/io_sock.t create mode 100755 contrib/perl5/t/lib/io_taint.t create mode 100755 contrib/perl5/t/lib/io_tell.t create mode 100755 contrib/perl5/t/lib/io_udp.t create mode 100755 contrib/perl5/t/lib/io_xs.t create mode 100755 contrib/perl5/t/lib/ipc_sysv.t create mode 100755 contrib/perl5/t/lib/ndbm.t create mode 100755 contrib/perl5/t/lib/odbm.t create mode 100755 contrib/perl5/t/lib/opcode.t create mode 100755 contrib/perl5/t/lib/open2.t create mode 100755 contrib/perl5/t/lib/open3.t create mode 100755 contrib/perl5/t/lib/ops.t create mode 100755 contrib/perl5/t/lib/parsewords.t create mode 100755 contrib/perl5/t/lib/ph.t create mode 100755 contrib/perl5/t/lib/posix.t create mode 100755 contrib/perl5/t/lib/safe1.t create mode 100755 contrib/perl5/t/lib/safe2.t create mode 100755 contrib/perl5/t/lib/sdbm.t create mode 100755 contrib/perl5/t/lib/searchdict.t create mode 100755 contrib/perl5/t/lib/selectsaver.t create mode 100755 contrib/perl5/t/lib/socket.t create mode 100755 contrib/perl5/t/lib/soundex.t create mode 100755 contrib/perl5/t/lib/symbol.t create mode 100755 contrib/perl5/t/lib/texttabs.t create mode 100755 contrib/perl5/t/lib/textwrap.t create mode 100755 contrib/perl5/t/lib/thread.t create mode 100755 contrib/perl5/t/lib/tie-push.t create mode 100755 contrib/perl5/t/lib/tie-stdarray.t create mode 100755 contrib/perl5/t/lib/tie-stdpush.t create mode 100755 contrib/perl5/t/lib/timelocal.t create mode 100755 contrib/perl5/t/lib/trig.t (limited to 'contrib/perl5/t/lib') diff --git a/contrib/perl5/t/lib/abbrev.t b/contrib/perl5/t/lib/abbrev.t new file mode 100755 index 000000000000..fb5a9841eb1b --- /dev/null +++ b/contrib/perl5/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/contrib/perl5/t/lib/anydbm.t b/contrib/perl5/t/lib/anydbm.t new file mode 100755 index 000000000000..0391b7b4900c --- /dev/null +++ b/contrib/perl5/t/lib/anydbm.t @@ -0,0 +1,125 @@ +#!./perl + +# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} +require AnyDBM_File; +#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT +use Fcntl; + +print "1..12\n"; + +unlink ; + +umask(0); +print (tie(%h,AnyDBM_File,'Op_dbmx', O_RDWR|O_CREAT, 0640) + ? "ok 1\n" : "not ok 1\n"); + +$Dfile = "Op_dbmx.pag"; +if (! -e $Dfile) { + ($Dfile) = ; +} +if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos') { + print "ok 2 # Skipped: different file permission semantics\n"; +} +else { + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); + print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); +} +while (($key,$value) = each(%h)) { + $i++; +} +print (!$i ? "ok 3\n" : "not ok 3 # i=$i\n\n"); + +$h{'goner1'} = 'snork'; + +$h{'abc'} = 'ABC'; +$h{'def'} = 'DEF'; +$h{'jkl','mno'} = "JKL\034MNO"; +$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); +$h{'a'} = 'A'; +$h{'b'} = 'B'; +$h{'c'} = 'C'; +$h{'d'} = 'D'; +$h{'e'} = 'E'; +$h{'f'} = 'F'; +$h{'g'} = 'G'; +$h{'h'} = 'H'; +$h{'i'} = 'I'; + +$h{'goner2'} = 'snork'; +delete $h{'goner2'}; + +untie(%h); +print (tie(%h,AnyDBM_File,'Op_dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); + +$h{'j'} = 'J'; +$h{'k'} = 'K'; +$h{'l'} = 'L'; +$h{'m'} = 'M'; +$h{'n'} = 'N'; +$h{'o'} = 'O'; +$h{'p'} = 'P'; +$h{'q'} = 'Q'; +$h{'r'} = 'R'; +$h{'s'} = 'S'; +$h{'t'} = 'T'; +$h{'u'} = 'U'; +$h{'v'} = 'V'; +$h{'w'} = 'W'; +$h{'x'} = 'X'; +$h{'y'} = 'Y'; +$h{'z'} = 'Z'; + +$h{'goner3'} = 'snork'; + +delete $h{'goner1'}; +delete $h{'goner3'}; + +@keys = keys(%h); +@values = values(%h); + +if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} + +while (($key,$value) = each(%h)) { + if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { + $key =~ y/a-z/A-Z/; + $i++ if $key eq $value; + } +} + +if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";} + +@keys = ('blurfl', keys(%h), 'dyick'); +if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";} + +$h{'foo'} = ''; +$h{''} = 'bar'; + +# check cache overflow and numeric keys and contents +$ok = 1; +for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } +for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } +print ($ok ? "ok 8\n" : "not ok 8\n"); + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat($Dfile); +print ($size > 0 ? "ok 9\n" : "not ok 9\n"); + +@h{0..200} = 200..400; +@foo = @h{0..200}; +print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; + +print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); +print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); + +untie %h; +if ($^O eq 'VMS') { + unlink 'Op_dbmx.sdbm_dir', $Dfile; +} else { + unlink 'Op_dbmx.dir', $Dfile; +} diff --git a/contrib/perl5/t/lib/autoloader.t b/contrib/perl5/t/lib/autoloader.t new file mode 100755 index 000000000000..b1622a8ae2e2 --- /dev/null +++ b/contrib/perl5/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/contrib/perl5/t/lib/basename.t b/contrib/perl5/t/lib/basename.t new file mode 100755 index 000000000000..a02aa32cb7a7 --- /dev/null +++ b/contrib/perl5/t/lib/basename.t @@ -0,0 +1,139 @@ +#!./perl -T + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use File::Basename qw(fileparse basename dirname); + +print "1..36\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:cano.trojae') eq 'arma:' ? + '' : '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"; + +# The empty tainted value, for tainting strings +my $TAINT = substr($^X, 0, 0); +# How to identify taint when you see it +sub any_tainted (@) { + not eval { join("",@_), kill 0; 1 }; +} +sub tainted ($) { + any_tainted @_; +} +sub all_tainted (@) { + for (@_) { return 0 unless tainted $_ } + 1; +} + +print +(tainted(dirname($TAINT.'/perl/lib//')) ? '' : 'not '), "ok 35\n"; +print +(all_tainted(fileparse($TAINT.'/dir/draft.book7','\.book\d+')) + ? '' : 'not '), "ok 36\n"; diff --git a/contrib/perl5/t/lib/bigint.t b/contrib/perl5/t/lib/bigint.t new file mode 100755 index 000000000000..034c5c645710 --- /dev/null +++ b/contrib/perl5/t/lib/bigint.t @@ -0,0 +1,282 @@ +#!./perl + +BEGIN { @INC = '../lib' } +require "bigint.pl"; + +$test = 0; +$| = 1; +print "1..246\n"; +while () { + chop; + if (/^&/) { + $f = $_; + } else { + ++$test; + @args = split(/:/,$_,99); + $ans = pop(@args); + $try = "$f('" . join("','", @args) . "');"; + if (($ans1 = eval($try)) eq $ans) { + print "ok $test\n"; + } else { + print "not ok $test\n"; + print "# '$try' expected: '$ans' got: '$ans1'\n"; + } + } +} +__END__ +&bnorm +abc:NaN + 1 a:NaN +1bcd2:NaN +11111b:NaN ++1z:NaN +-1z:NaN +0:+0 ++0:+0 ++00:+0 ++0 0 0:+0 +000000 0000000 00000:+0 +-0:+0 +-0000:+0 ++1:+1 ++01:+1 ++001:+1 ++00000100000:+100000 +123456789:+123456789 +-1:-1 +-01:-1 +-001:-1 +-123456789:-123456789 +-00000100000:-100000 +&bneg +abd:NaN ++0:+0 ++1:-1 +-1:+1 ++123456789:-123456789 +-123456789:+123456789 +&babs +abc:NaN ++0:+0 ++1:+1 +-1:+1 ++123456789:+123456789 +-123456789:+123456789 +&bcmp +abc:abc: +abc:+0: ++0:abc: ++0:+0:0 +-1:+0:-1 ++0:-1:1 ++1:+0:1 ++0:+1:-1 +-1:+1:-1 ++1:-1:1 +-1:-1:0 ++1:+1:0 ++123:+123:0 ++123:+12:1 ++12:+123:-1 +-123:-123:0 +-123:-12:-1 +-12:-123:1 ++123:+124:-1 ++124:+123:1 +-123:-124:1 +-124:-123:-1 +&badd +abc:abc:NaN +abc:+0:NaN ++0:abc:NaN ++0:+0:+0 ++1:+0:+1 ++0:+1:+1 ++1:+1:+2 +-1:+0:-1 ++0:-1:-1 +-1:-1:-2 +-1:+1:+0 ++1:-1:+0 ++9:+1:+10 ++99:+1:+100 ++999:+1:+1000 ++9999:+1:+10000 ++99999:+1:+100000 ++999999:+1:+1000000 ++9999999:+1:+10000000 ++99999999:+1:+100000000 ++999999999:+1:+1000000000 ++9999999999:+1:+10000000000 ++99999999999:+1:+100000000000 ++10:-1:+9 ++100:-1:+99 ++1000:-1:+999 ++10000:-1:+9999 ++100000:-1:+99999 ++1000000:-1:+999999 ++10000000:-1:+9999999 ++100000000:-1:+99999999 ++1000000000:-1:+999999999 ++10000000000:-1:+9999999999 ++123456789:+987654321:+1111111110 +-123456789:+987654321:+864197532 +-123456789:-987654321:-1111111110 ++123456789:-987654321:-864197532 +&bsub +abc:abc:NaN +abc:+0:NaN ++0:abc:NaN ++0:+0:+0 ++1:+0:+1 ++0:+1:-1 ++1:+1:+0 +-1:+0:-1 ++0:-1:+1 +-1:-1:+0 +-1:+1:-2 ++1:-1:+2 ++9:+1:+8 ++99:+1:+98 ++999:+1:+998 ++9999:+1:+9998 ++99999:+1:+99998 ++999999:+1:+999998 ++9999999:+1:+9999998 ++99999999:+1:+99999998 ++999999999:+1:+999999998 ++9999999999:+1:+9999999998 ++99999999999:+1:+99999999998 ++10:-1:+11 ++100:-1:+101 ++1000:-1:+1001 ++10000:-1:+10001 ++100000:-1:+100001 ++1000000:-1:+1000001 ++10000000:-1:+10000001 ++100000000:-1:+100000001 ++1000000000:-1:+1000000001 ++10000000000:-1:+10000000001 ++123456789:+987654321:-864197532 +-123456789:+987654321:-1111111110 +-123456789:-987654321:+864197532 ++123456789:-987654321:+1111111110 +&bmul +abc:abc:NaN +abc:+0:NaN ++0:abc:NaN ++0:+0:+0 ++0:+1:+0 ++1:+0:+0 ++0:-1:+0 +-1:+0:+0 ++123456789123456789:+0:+0 ++0:+123456789123456789:+0 +-1:-1:+1 +-1:+1:-1 ++1:-1:-1 ++1:+1:+1 ++2:+3:+6 +-2:+3:-6 ++2:-3:-6 +-2:-3:+6 ++111:+111:+12321 ++10101:+10101:+102030201 ++1001001:+1001001:+1002003002001 ++100010001:+100010001:+10002000300020001 ++10000100001:+10000100001:+100002000030000200001 ++11111111111:+9:+99999999999 ++22222222222:+9:+199999999998 ++33333333333:+9:+299999999997 ++44444444444:+9:+399999999996 ++55555555555:+9:+499999999995 ++66666666666:+9:+599999999994 ++77777777777:+9:+699999999993 ++88888888888:+9:+799999999992 ++99999999999:+9:+899999999991 +&bdiv +abc:abc:NaN +abc:+1:abc:NaN ++1:abc:NaN ++0:+0:NaN ++0:+1:+0 ++1:+0:NaN ++0:-1:+0 +-1:+0:NaN ++1:+1:+1 +-1:-1:+1 ++1:-1:-1 +-1:+1:-1 ++1:+2:+0 ++2:+1:+2 ++1000000000:+9:+111111111 ++2000000000:+9:+222222222 ++3000000000:+9:+333333333 ++4000000000:+9:+444444444 ++5000000000:+9:+555555555 ++6000000000:+9:+666666666 ++7000000000:+9:+777777777 ++8000000000:+9:+888888888 ++9000000000:+9:+1000000000 ++35500000:+113:+314159 ++71000000:+226:+314159 ++106500000:+339:+314159 ++1000000000:+3:+333333333 ++10:+5:+2 ++100:+4:+25 ++1000:+8:+125 ++10000:+16:+625 ++999999999999:+9:+111111111111 ++999999999999:+99:+10101010101 ++999999999999:+999:+1001001001 ++999999999999:+9999:+100010001 ++999999999999999:+99999:+10000100001 +&bmod +abc:abc:NaN +abc:+1:abc:NaN ++1:abc:NaN ++0:+0:NaN ++0:+1:+0 ++1:+0:NaN ++0:-1:+0 +-1:+0:NaN ++1:+1:+0 +-1:-1:+0 ++1:-1:+0 +-1:+1:+0 ++1:+2:+1 ++2:+1:+0 ++1000000000:+9:+1 ++2000000000:+9:+2 ++3000000000:+9:+3 ++4000000000:+9:+4 ++5000000000:+9:+5 ++6000000000:+9:+6 ++7000000000:+9:+7 ++8000000000:+9:+8 ++9000000000:+9:+0 ++35500000:+113:+33 ++71000000:+226:+66 ++106500000:+339:+99 ++1000000000:+3:+1 ++10:+5:+0 ++100:+4:+0 ++1000:+8:+0 ++10000:+16:+0 ++999999999999:+9:+0 ++999999999999:+99:+0 ++999999999999:+999:+0 ++999999999999:+9999:+0 ++999999999999999:+99999:+0 +&bgcd +abc:abc:NaN +abc:+0:NaN ++0:abc:NaN ++0:+0:+0 ++0:+1:+1 ++1:+0:+1 ++1:+1:+1 ++2:+3:+1 ++3:+2:+1 ++100:+625:+25 ++4096:+81:+1 diff --git a/contrib/perl5/t/lib/bigintpm.t b/contrib/perl5/t/lib/bigintpm.t new file mode 100755 index 000000000000..e7cac26323d0 --- /dev/null +++ b/contrib/perl5/t/lib/bigintpm.t @@ -0,0 +1,313 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Math::BigInt; + +$test = 0; +$| = 1; +print "1..247\n"; +while () { + chop; + if (s/^&//) { + $f = $_; + } else { + ++$test; + @args = split(/:/,$_,99); + $ans = pop(@args); + $try = "\$x = new Math::BigInt \"$args[0]\";"; + if ($f eq "bnorm"){ + $try .= "\$x+0;"; + } elsif ($f eq "bneg") { + $try .= "-\$x;"; + } elsif ($f eq "babs") { + $try .= "abs \$x;"; + } else { + $try .= "\$y = new Math::BigInt \"$args[1]\";"; + if ($f eq bcmp){ + $try .= "\$x <=> \$y;"; + }elsif ($f eq badd){ + $try .= "\$x + \$y;"; + }elsif ($f eq bsub){ + $try .= "\$x - \$y;"; + }elsif ($f eq bmul){ + $try .= "\$x * \$y;"; + }elsif ($f eq bdiv){ + $try .= "\$x / \$y;"; + }elsif ($f eq bmod){ + $try .= "\$x % \$y;"; + }elsif ($f eq bgcd){ + $try .= "Math::BigInt::bgcd(\$x, \$y);"; + } else { warn "Unknown op"; } + } + #print ">>>",$try,"<<<\n"; + $ans1 = eval $try; + if ("$ans1" eq $ans) { #bug! + print "ok $test\n"; + } else { + print "not ok $test\n"; + print "# '$try' expected: '$ans' got: '$ans1'\n"; + } + } +} +__END__ +&bnorm +abc:NaN + 1 a:NaN +1bcd2:NaN +11111b:NaN ++1z:NaN +-1z:NaN +0:+0 ++0:+0 ++00:+0 ++0 0 0:+0 +000000 0000000 00000:+0 +-0:+0 +-0000:+0 ++1:+1 ++01:+1 ++001:+1 ++00000100000:+100000 +123456789:+123456789 +-1:-1 +-01:-1 +-001:-1 +-123456789:-123456789 +-00000100000:-100000 +&bneg +abd:NaN ++0:+0 ++1:-1 +-1:+1 ++123456789:-123456789 +-123456789:+123456789 +&babs +abc:NaN ++0:+0 ++1:+1 +-1:+1 ++123456789:+123456789 +-123456789:+123456789 +&bcmp +abc:abc:NaN +abc:+0:NaN ++0:abc:NaN ++0:+0:+0 +-1:+0:-1 ++0:-1:+1 ++1:+0:+1 ++0:+1:-1 +-1:+1:-1 ++1:-1:+1 +-1:-1:+0 ++1:+1:+0 ++123:+123:+0 ++123:+12:+1 ++12:+123:-1 +-123:-123:+0 +-123:-12:-1 +-12:-123:+1 ++123:+124:-1 ++124:+123:+1 +-123:-124:+1 +-124:-123:-1 ++100:+5:+1 +&badd +abc:abc:NaN +abc:+0:NaN ++0:abc:NaN ++0:+0:+0 ++1:+0:+1 ++0:+1:+1 ++1:+1:+2 +-1:+0:-1 ++0:-1:-1 +-1:-1:-2 +-1:+1:+0 ++1:-1:+0 ++9:+1:+10 ++99:+1:+100 ++999:+1:+1000 ++9999:+1:+10000 ++99999:+1:+100000 ++999999:+1:+1000000 ++9999999:+1:+10000000 ++99999999:+1:+100000000 ++999999999:+1:+1000000000 ++9999999999:+1:+10000000000 ++99999999999:+1:+100000000000 ++10:-1:+9 ++100:-1:+99 ++1000:-1:+999 ++10000:-1:+9999 ++100000:-1:+99999 ++1000000:-1:+999999 ++10000000:-1:+9999999 ++100000000:-1:+99999999 ++1000000000:-1:+999999999 ++10000000000:-1:+9999999999 ++123456789:+987654321:+1111111110 +-123456789:+987654321:+864197532 +-123456789:-987654321:-1111111110 ++123456789:-987654321:-864197532 +&bsub +abc:abc:NaN +abc:+0:NaN ++0:abc:NaN ++0:+0:+0 ++1:+0:+1 ++0:+1:-1 ++1:+1:+0 +-1:+0:-1 ++0:-1:+1 +-1:-1:+0 +-1:+1:-2 ++1:-1:+2 ++9:+1:+8 ++99:+1:+98 ++999:+1:+998 ++9999:+1:+9998 ++99999:+1:+99998 ++999999:+1:+999998 ++9999999:+1:+9999998 ++99999999:+1:+99999998 ++999999999:+1:+999999998 ++9999999999:+1:+9999999998 ++99999999999:+1:+99999999998 ++10:-1:+11 ++100:-1:+101 ++1000:-1:+1001 ++10000:-1:+10001 ++100000:-1:+100001 ++1000000:-1:+1000001 ++10000000:-1:+10000001 ++100000000:-1:+100000001 ++1000000000:-1:+1000000001 ++10000000000:-1:+10000000001 ++123456789:+987654321:-864197532 +-123456789:+987654321:-1111111110 +-123456789:-987654321:+864197532 ++123456789:-987654321:+1111111110 +&bmul +abc:abc:NaN +abc:+0:NaN ++0:abc:NaN ++0:+0:+0 ++0:+1:+0 ++1:+0:+0 ++0:-1:+0 +-1:+0:+0 ++123456789123456789:+0:+0 ++0:+123456789123456789:+0 +-1:-1:+1 +-1:+1:-1 ++1:-1:-1 ++1:+1:+1 ++2:+3:+6 +-2:+3:-6 ++2:-3:-6 +-2:-3:+6 ++111:+111:+12321 ++10101:+10101:+102030201 ++1001001:+1001001:+1002003002001 ++100010001:+100010001:+10002000300020001 ++10000100001:+10000100001:+100002000030000200001 ++11111111111:+9:+99999999999 ++22222222222:+9:+199999999998 ++33333333333:+9:+299999999997 ++44444444444:+9:+399999999996 ++55555555555:+9:+499999999995 ++66666666666:+9:+599999999994 ++77777777777:+9:+699999999993 ++88888888888:+9:+799999999992 ++99999999999:+9:+899999999991 +&bdiv +abc:abc:NaN +abc:+1:abc:NaN ++1:abc:NaN ++0:+0:NaN ++0:+1:+0 ++1:+0:NaN ++0:-1:+0 +-1:+0:NaN ++1:+1:+1 +-1:-1:+1 ++1:-1:-1 +-1:+1:-1 ++1:+2:+0 ++2:+1:+2 ++1000000000:+9:+111111111 ++2000000000:+9:+222222222 ++3000000000:+9:+333333333 ++4000000000:+9:+444444444 ++5000000000:+9:+555555555 ++6000000000:+9:+666666666 ++7000000000:+9:+777777777 ++8000000000:+9:+888888888 ++9000000000:+9:+1000000000 ++35500000:+113:+314159 ++71000000:+226:+314159 ++106500000:+339:+314159 ++1000000000:+3:+333333333 ++10:+5:+2 ++100:+4:+25 ++1000:+8:+125 ++10000:+16:+625 ++999999999999:+9:+111111111111 ++999999999999:+99:+10101010101 ++999999999999:+999:+1001001001 ++999999999999:+9999:+100010001 ++999999999999999:+99999:+10000100001 +&bmod +abc:abc:NaN +abc:+1:abc:NaN ++1:abc:NaN ++0:+0:NaN ++0:+1:+0 ++1:+0:NaN ++0:-1:+0 +-1:+0:NaN ++1:+1:+0 +-1:-1:+0 ++1:-1:+0 +-1:+1:+0 ++1:+2:+1 ++2:+1:+0 ++1000000000:+9:+1 ++2000000000:+9:+2 ++3000000000:+9:+3 ++4000000000:+9:+4 ++5000000000:+9:+5 ++6000000000:+9:+6 ++7000000000:+9:+7 ++8000000000:+9:+8 ++9000000000:+9:+0 ++35500000:+113:+33 ++71000000:+226:+66 ++106500000:+339:+99 ++1000000000:+3:+1 ++10:+5:+0 ++100:+4:+0 ++1000:+8:+0 ++10000:+16:+0 ++999999999999:+9:+0 ++999999999999:+99:+0 ++999999999999:+999:+0 ++999999999999:+9999:+0 ++999999999999999:+99999:+0 +&bgcd +abc:abc:NaN +abc:+0:NaN ++0:abc:NaN ++0:+0:+0 ++0:+1:+1 ++1:+0:+1 ++1:+1:+1 ++2:+3:+1 ++3:+2:+1 ++100:+625:+25 ++4096:+81:+1 diff --git a/contrib/perl5/t/lib/cgi-form.t b/contrib/perl5/t/lib/cgi-form.t new file mode 100755 index 000000000000..86df161b02e4 --- /dev/null +++ b/contrib/perl5/t/lib/cgi-form.t @@ -0,0 +1,81 @@ +#!./perl + +# Test ability to retrieve HTTP request info +######################### We start with some black magic to print on failure. + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; +} + +BEGIN {$| = 1; print "1..17\n"; } +END {print "not ok 1\n" unless $loaded;} +use CGI (':standard','-no_debug'); +$loaded = 1; +print "ok 1\n"; + +######################### End of black magic. + +# util +sub test { + local($^W) = 0; + my($num, $true,$msg) = @_; + print($true ? "ok $num\n" : "not ok $num $msg\n"); +} + +# Set up a CGI environment +$ENV{REQUEST_METHOD}='GET'; +$ENV{QUERY_STRING} ='game=chess&game=checkers&weather=dull'; +$ENV{PATH_INFO} ='/somewhere/else'; +$ENV{PATH_TRANSLATED} ='/usr/local/somewhere/else'; +$ENV{SCRIPT_NAME} ='/cgi-bin/foo.cgi'; +$ENV{SERVER_PROTOCOL} = 'HTTP/1.0'; +$ENV{SERVER_PORT} = 8080; +$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com'; + +test(2,start_form(-action=>'foobar',-method=>GET) eq + qq(
\n), + "start_form()"); + +test(3,submit() eq qq(),"submit()"); +test(4,submit(-name=>'foo',-value=>'bar') eq qq(),"submit(-name,-value)"); +test(5,submit({-name=>'foo',-value=>'bar'}) eq qq(),"submit({-name,-value})"); +test(6,textfield(-name=>'weather') eq qq(),"textfield({-name})"); +test(7,textfield(-name=>'weather',-value=>'nice') eq qq(),"textfield({-name,-value})"); +test(8,textfield(-name=>'weather',-value=>'nice',-override=>1) eq qq(), + "textfield({-name,-value,-override})"); +test(9,checkbox(-name=>'weather',-value=>'nice') eq qq(weather\n), + "checkbox()"); +test(10,checkbox(-name=>'weather',-value=>'nice',-label=>'forecast') eq + qq(forecast\n), + "checkbox()"); +test(11,checkbox(-name=>'weather',-value=>'nice',-label=>'forecast',-checked=>1,-override=>1) eq + qq(forecast\n), + "checkbox()"); +test(12,checkbox(-name=>'weather',-value=>'dull',-label=>'forecast') eq + qq(forecast\n), + "checkbox()"); + +test(13,radio_group(-name=>'game') eq + qq(chess checkers), + 'radio_group()'); +test(14,radio_group(-name=>'game',-labels=>{'chess'=>'ping pong'}) eq + qq(ping pong checkers), + 'radio_group()'); + +test(15, checkbox_group(-name=>'game',-Values=>[qw/checkers chess cribbage/]) eq + qq(checkers chess cribbage), + 'checkbox_group()'); + +test(16, checkbox_group(-name=>'game',-Values=>[qw/checkers chess cribbage/],-Defaults=>['cribbage'],-override=>1) eq + qq(checkers chess cribbage), + 'checkbox_group()'); + +test(17, popup_menu(-name=>'game',-Values=>[qw/checkers chess cribbage/],-Default=>'cribbage',-override=>1) eq < +