diff options
Diffstat (limited to 'contrib/perl5/t/lib')
93 files changed, 1446 insertions, 581 deletions
diff --git a/contrib/perl5/t/lib/abbrev.t b/contrib/perl5/t/lib/abbrev.t index 05e5c70..fb5a984 100755 --- a/contrib/perl5/t/lib/abbrev.t +++ b/contrib/perl5/t/lib/abbrev.t @@ -4,7 +4,7 @@ print "1..7\n"; BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Text::Abbrev; diff --git a/contrib/perl5/t/lib/ansicolor.t b/contrib/perl5/t/lib/ansicolor.t index 3e16dce..f38e905 100755 --- a/contrib/perl5/t/lib/ansicolor.t +++ b/contrib/perl5/t/lib/ansicolor.t @@ -1,8 +1,6 @@ -#!./perl - BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } # Test suite for the Term::ANSIColor Perl module. Before `make install' is @@ -13,7 +11,7 @@ BEGIN { # Ensure module can be loaded ############################################################################ -BEGIN { $| = 1; print "1..7\n" } +BEGIN { $| = 1; print "1..8\n" } END { print "not ok 1\n" unless $loaded } use Term::ANSIColor qw(:constants color colored); $loaded = 1; @@ -71,3 +69,13 @@ if (colored ("test\ntest\r\r\n\r\n", 'bold') } else { print "not ok 7\n"; } + +# Test the array ref form. +$Term::ANSIColor::EACHLINE = "\n"; +if (colored (['bold', 'on_green'], "test\n", "\n", "test") + eq "\e[1;42mtest\e[0m\n\n\e[1;42mtest\e[0m") { + print "ok 8\n"; +} else { + print colored (['bold', 'on_green'], "test\n", "\n", "test"); + print "not ok 8\n"; +} diff --git a/contrib/perl5/t/lib/anydbm.t b/contrib/perl5/t/lib/anydbm.t index e38c7e7..40c4366 100755 --- a/contrib/perl5/t/lib/anydbm.t +++ b/contrib/perl5/t/lib/anydbm.t @@ -4,10 +4,14 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; + require Config; import Config; + if (($Config{'extensions'} !~ /\b(DB|[A-Z]DBM)_File\b/) ){ + print "1..0 # Skipping (no DB_File or [A-Z]DBM_File)\n"; + exit 0; + } } require AnyDBM_File; -#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT use Fcntl; print "1..12\n"; diff --git a/contrib/perl5/t/lib/attrs.t b/contrib/perl5/t/lib/attrs.t index eb8c8c4..440122c 100755 --- a/contrib/perl5/t/lib/attrs.t +++ b/contrib/perl5/t/lib/attrs.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; eval 'require attrs; 1' or do { print "1..0\n"; exit 0; diff --git a/contrib/perl5/t/lib/autoloader.t b/contrib/perl5/t/lib/autoloader.t index 3bf690b..b53b9fe 100755 --- a/contrib/perl5/t/lib/autoloader.t +++ b/contrib/perl5/t/lib/autoloader.t @@ -3,7 +3,8 @@ BEGIN { chdir 't' if -d 't'; $dir = "auto-$$"; - unshift @INC, ("./$dir", "../lib"); + @INC = $dir; + push @INC, '../lib'; } print "1..11\n"; diff --git a/contrib/perl5/t/lib/basename.t b/contrib/perl5/t/lib/basename.t index 478e26a..9bee1bf 100755 --- a/contrib/perl5/t/lib/basename.t +++ b/contrib/perl5/t/lib/basename.t @@ -2,12 +2,12 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use File::Basename qw(fileparse basename dirname); -print "1..36\n"; +print "1..41\n"; # import correctly? print +(defined(&basename) && !defined(&fileparse_set_fstype) ? @@ -96,29 +96,34 @@ 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"; +print +(dirname(':arma:virumque:') eq ':arma:' ? '' : 'not '),"ok 27\n"; +print +(dirname(':arma:virumque') eq ':arma:' ? '' : 'not '),"ok 28\n"; +print +(dirname(':arma:') eq ':' ? '' : 'not '),"ok 29\n"; +print +(dirname(':arma') eq ':' ? '' : 'not '),"ok 30\n"; +print +(dirname('arma:') eq 'arma:' ? '' : 'not '),"ok 31\n"; +print +(dirname('arma') eq ':' ? '' : 'not '),"ok 32\n"; +print +(dirname(':') eq ':' ? '' : 'not '),"ok 33\n"; # Check quoting of metacharacters in suffix arg by basename() print +(basename(':arma:virumque:cano.trojae','.trojae') eq 'cano' ? - '' : 'not '),"ok 29\n"; + '' : 'not '),"ok 34\n"; print +(basename(':arma:virumque:cano_trojae','.trojae') eq 'cano_trojae' ? - '' : 'not '),"ok 30\n"; + '' : 'not '),"ok 35\n"; # extra tests for a few specific bugs File::Basename::fileparse_set_fstype 'MSDOS'; # perl5.003_18 gives C:/perl/.\ -print +((fileparse 'C:/perl/lib')[1] eq 'C:/perl/' ? '' : 'not '), "ok 31\n"; +print +((fileparse 'C:/perl/lib')[1] eq 'C:/perl/' ? '' : 'not '), "ok 36\n"; # perl5.003_18 gives C:\perl\ -print +(dirname('C:\\perl\\lib\\') eq 'C:\\perl' ? '' : 'not '), "ok 32\n"; +print +(dirname('C:\\perl\\lib\\') eq 'C:\\perl' ? '' : 'not '), "ok 37\n"; File::Basename::fileparse_set_fstype 'UNIX'; # perl5.003_18 gives '.' -print +(dirname('/perl/') eq '/' ? '' : 'not '), "ok 33\n"; +print +(dirname('/perl/') eq '/' ? '' : 'not '), "ok 38\n"; # perl5.003_18 gives '/perl/lib' -print +(dirname('/perl/lib//') eq '/perl' ? '' : 'not '), "ok 34\n"; +print +(dirname('/perl/lib//') eq '/perl' ? '' : 'not '), "ok 39\n"; # The empty tainted value, for tainting strings my $TAINT = substr($^X, 0, 0); @@ -134,6 +139,6 @@ sub all_tainted (@) { 1; } -print +(tainted(dirname($TAINT.'/perl/lib//')) ? '' : 'not '), "ok 35\n"; +print +(tainted(dirname($TAINT.'/perl/lib//')) ? '' : 'not '), "ok 40\n"; print +(all_tainted(fileparse($TAINT.'/dir/draft.book7','\.book\d+')) - ? '' : 'not '), "ok 36\n"; + ? '' : 'not '), "ok 41\n"; diff --git a/contrib/perl5/t/lib/bigfltpm.t b/contrib/perl5/t/lib/bigfltpm.t index 5d97f1b..aa45651 100755 --- a/contrib/perl5/t/lib/bigfltpm.t +++ b/contrib/perl5/t/lib/bigfltpm.t @@ -9,7 +9,7 @@ use Math::BigFloat; $test = 0; $| = 1; -print "1..362\n"; +print "1..370\n"; while (<DATA>) { chop; if (s/^&//) { @@ -51,6 +51,8 @@ while (<DATA>) { $try .= "\$x * \$y;"; } elsif ($f eq "fdiv") { $try .= "\$x / \$y;"; + } elsif ($f eq "fmod") { + $try .= "\$x % \$y;"; } else { warn "Unknown op"; } } #print ">>>",$try,"<<<\n"; @@ -65,22 +67,26 @@ while (<DATA>) { print "# '$try' expected: /$pat/ got: '$ans1'\n"; } } - elsif ("$ans1" eq $ans) { #bug! - print "ok $test\n"; - } else { - print "not ok $test\n"; - print "# '$try' expected: '$ans' got: '$ans1'\n"; - } + else { + + $ans1_str = defined $ans1? "$ans1" : ""; + if ($ans1_str eq $ans) { #bug! + print "ok $test\n"; + } else { + print "not ok $test\n"; + print "# '$try' expected: '$ans' got: '$ans1'\n"; + } + } } -} +} __END__ &fnorm -abc:NaN. - 1 a:NaN. -1bcd2:NaN. -11111b:NaN. -+1z:NaN. --1z:NaN. +abc:NaN + 1 a:NaN +1bcd2:NaN +11111b:NaN ++1z:NaN +-1z:NaN 0:0. +0:0. +00:0. @@ -98,7 +104,7 @@ abc:NaN. -001:-1. -123456789:-123456789. -00000100000:-100000. -123.456a:NaN. +123.456a:NaN 123.456:123.456 0.01:.01 .002:.002 @@ -113,7 +119,7 @@ abc:NaN. -3e111:-3000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000. -4e-1111:-.0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000004 &fneg -abd:NaN. +abc:NaN +0:0. +1:-1. -1:1. @@ -122,7 +128,7 @@ abd:NaN. +123.456789:-123.456789 -123456.789:123456.789 &fabs -abc:NaN. +abc:NaN +0:0. +1:1. -1:1. @@ -249,13 +255,13 @@ $Math::BigFloat::rnd_mode = 'even' -6.23:-1:/-6.2(?:0{5}\d+)? +6.27:-1:/6.(?:3|29{5}\d+) -6.27:-1:/-6.(?:3|29{5}\d+) -+6.25:-1:/6.2(?:0{5}\d+)? --6.25:-1:/-6.2(?:0{5}\d+)? -+6.35:-1:/6.(?:4|39{5}\d+) --6.35:-1:/-6.(?:4|39{5}\d+) ++6.25:-1:/6.(?:2(?:0{5}\d+)?|29{5}\d+) +-6.25:-1:/-6.(?:2(?:0{5}\d+)?|29{5}\d+) ++6.35:-1:/6.(?:4|39{5}\d+|29{8}\d+) +-6.35:-1:/-6.(?:4|39{5}\d+|29{8}\d+) -0.0065:-1:0 -0.0065:-2:/-0\.01|-1e-02 --0.0065:-3:/-0\.006|-6e-03 +-0.0065:-3:/-0\.006|-7e-03 -0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 -0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 &fcmp @@ -286,9 +292,9 @@ abc:+0: -123:-124:1 -124:-123:-1 &fadd -abc:abc:NaN. -abc:+0:NaN. -+0:abc:NaN. +abc:abc:NaN +abc:+0:NaN ++0:abc:NaN +0:+0:0. +1:+0:1. +0:+1:1. @@ -324,9 +330,9 @@ abc:+0:NaN. -123456789:-987654321:-1111111110. +123456789:-987654321:-864197532. &fsub -abc:abc:NaN. -abc:+0:NaN. -+0:abc:NaN. +abc:abc:NaN +abc:+0:NaN ++0:abc:NaN +0:+0:0. +1:+0:1. +0:+1:-1. @@ -362,9 +368,9 @@ abc:+0:NaN. -123456789:-987654321:864197532. +123456789:-987654321:1111111110. &fmul -abc:abc:NaN. -abc:+0:NaN. -+0:abc:NaN. +abc:abc:NaN +abc:+0:NaN ++0:abc:NaN +0:+0:0. +0:+1:0. +1:+0:0. @@ -395,14 +401,14 @@ abc:+0:NaN. +88888888888:+9:799999999992. +99999999999:+9:899999999991. &fdiv -abc:abc:NaN. -abc:+1:abc:NaN. -+1:abc:NaN. -+0:+0:NaN. +abc:abc:NaN +abc:+1:abc:NaN ++1:abc:NaN ++0:+0:NaN +0:+1:0. -+1:+0:NaN. ++1:+0:NaN +0:-1:0. --1:+0:NaN. +-1:+0:NaN +1:+1:1. -1:-1:1. +1:-1:-1. @@ -461,3 +467,12 @@ $Math::BigFloat::div_scale = 40 +100:10. +123.456:11.11107555549866648462149404118219234119 +15241.383936:123.456 +&fmod ++0:0:NaN ++0:1:0. ++3:1:0. ++5:2:1. ++9:4:1. ++9:5:4. ++9000:56:40. ++56:9000:56. diff --git a/contrib/perl5/t/lib/bigint.t b/contrib/perl5/t/lib/bigint.t index d2d520e..034c5c6 100755 --- a/contrib/perl5/t/lib/bigint.t +++ b/contrib/perl5/t/lib/bigint.t @@ -1,6 +1,6 @@ #!./perl -BEGIN { unshift @INC, '../lib' } +BEGIN { @INC = '../lib' } require "bigint.pl"; $test = 0; diff --git a/contrib/perl5/t/lib/bigintpm.t b/contrib/perl5/t/lib/bigintpm.t index ae362e2..e76f246 100755 --- a/contrib/perl5/t/lib/bigintpm.t +++ b/contrib/perl5/t/lib/bigintpm.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Math::BigInt; diff --git a/contrib/perl5/t/lib/cgi-form.t b/contrib/perl5/t/lib/cgi-form.t index e3cba5f..2922903 100755 --- a/contrib/perl5/t/lib/cgi-form.t +++ b/contrib/perl5/t/lib/cgi-form.t @@ -1,13 +1,14 @@ -#!./perl - -# Test ability to retrieve HTTP request info -######################### We start with some black magic to print on failure. +#!/usr/local/bin/perl -w BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + chdir('t') if -d 't'; + @INC = '../lib'; } +# Test ability to retrieve HTTP request info +######################### We start with some black magic to print on failure. +use lib '../blib/lib','../blib/arch'; + BEGIN {$| = 1; print "1..17\n"; } END {print "not ok 1\n" unless $loaded;} use CGI (':standard','-no_debug'); @@ -23,6 +24,15 @@ sub test { print($true ? "ok $num\n" : "not ok $num $msg\n"); } +my $CRLF = "\015\012"; +if ($^O eq 'VMS') { + $CRLF = "\n"; # via web server carriage is inserted automatically +} +if (ord("\t") != 9) { # EBCDIC? + $CRLF = "\r\n"; +} + + # Set up a CGI environment $ENV{REQUEST_METHOD}='GET'; $ENV{QUERY_STRING} ='game=chess&game=checkers&weather=dull'; @@ -33,49 +43,48 @@ $ENV{SERVER_PROTOCOL} = 'HTTP/1.0'; $ENV{SERVER_PORT} = 8080; $ENV{SERVER_NAME} = 'the.good.ship.lollypop.com'; -test(2,start_form(-action=>'foobar',-method=>GET) eq - qq(<FORM METHOD="GET" ACTION="foobar" ENCTYPE="application/x-www-form-urlencoded">\n), +test(2,start_form(-action=>'foobar',-method=>'get') eq + qq(<form method="get" action="foobar" enctype="application/x-www-form-urlencoded">\n), "start_form()"); -test(3,submit() eq qq(<INPUT TYPE="submit" NAME=".submit">),"submit()"); -test(4,submit(-name=>'foo',-value=>'bar') eq qq(<INPUT TYPE="submit" NAME="foo" VALUE="bar">),"submit(-name,-value)"); -test(5,submit({-name=>'foo',-value=>'bar'}) eq qq(<INPUT TYPE="submit" NAME="foo" VALUE="bar">),"submit({-name,-value})"); -test(6,textfield(-name=>'weather') eq qq(<INPUT TYPE="text" NAME="weather" VALUE="dull">),"textfield({-name})"); -test(7,textfield(-name=>'weather',-value=>'nice') eq qq(<INPUT TYPE="text" NAME="weather" VALUE="dull">),"textfield({-name,-value})"); -test(8,textfield(-name=>'weather',-value=>'nice',-override=>1) eq qq(<INPUT TYPE="text" NAME="weather" VALUE="nice">), +test(3,submit() eq qq(<input type="submit" name=".submit" />),"submit()"); +test(4,submit(-name=>'foo',-value=>'bar') eq qq(<input type="submit" name="foo" value="bar" />),"submit(-name,-value)"); +test(5,submit({-name=>'foo',-value=>'bar'}) eq qq(<input type="submit" name="foo" value="bar" />),"submit({-name,-value})"); +test(6,textfield(-name=>'weather') eq qq(<input type="text" name="weather" value="dull" />),"textfield({-name})"); +test(7,textfield(-name=>'weather',-value=>'nice') eq qq(<input type="text" name="weather" value="dull" />),"textfield({-name,-value})"); +test(8,textfield(-name=>'weather',-value=>'nice',-override=>1) eq qq(<input type="text" name="weather" value="nice" />), "textfield({-name,-value,-override})"); -test(9,checkbox(-name=>'weather',-value=>'nice') eq qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="nice">weather), +test(9,checkbox(-name=>'weather',-value=>'nice') eq qq(<input type="checkbox" name="weather" value="nice" />weather), "checkbox()"); test(10,checkbox(-name=>'weather',-value=>'nice',-label=>'forecast') eq - qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="nice">forecast), + qq(<input type="checkbox" name="weather" value="nice" />forecast), "checkbox()"); test(11,checkbox(-name=>'weather',-value=>'nice',-label=>'forecast',-checked=>1,-override=>1) eq - qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="nice" CHECKED>forecast), + qq(<input type="checkbox" name="weather" value="nice" checked />forecast), "checkbox()"); test(12,checkbox(-name=>'weather',-value=>'dull',-label=>'forecast') eq - qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="dull" CHECKED>forecast), + qq(<input type="checkbox" name="weather" value="dull" checked />forecast), "checkbox()"); test(13,radio_group(-name=>'game') eq - qq(<INPUT TYPE="radio" NAME="game" VALUE="chess" CHECKED>chess <INPUT TYPE="radio" NAME="game" VALUE="checkers">checkers), + qq(<input type="radio" name="game" value="chess" checked />chess <input type="radio" name="game" value="checkers" />checkers), 'radio_group()'); test(14,radio_group(-name=>'game',-labels=>{'chess'=>'ping pong'}) eq - qq(<INPUT TYPE="radio" NAME="game" VALUE="chess" CHECKED>ping pong <INPUT TYPE="radio" NAME="game" VALUE="checkers">checkers), + qq(<input type="radio" name="game" value="chess" checked />ping pong <input type="radio" name="game" value="checkers" />checkers), 'radio_group()'); test(15, checkbox_group(-name=>'game',-Values=>[qw/checkers chess cribbage/]) eq - qq(<INPUT TYPE="checkbox" NAME="game" VALUE="checkers" CHECKED>checkers <INPUT TYPE="checkbox" NAME="game" VALUE="chess" CHECKED>chess <INPUT TYPE="checkbox" NAME="game" VALUE="cribbage">cribbage), + qq(<input type="checkbox" name="game" value="checkers" checked />checkers <input type="checkbox" name="game" value="chess" checked />chess <input type="checkbox" name="game" value="cribbage" />cribbage), 'checkbox_group()'); -test(16, checkbox_group(-name=>'game',-Values=>[qw/checkers chess cribbage/],-Defaults=>['cribbage'],-override=>1) eq - qq(<INPUT TYPE="checkbox" NAME="game" VALUE="checkers">checkers <INPUT TYPE="checkbox" NAME="game" VALUE="chess">chess <INPUT TYPE="checkbox" NAME="game" VALUE="cribbage" CHECKED>cribbage), +test(16, checkbox_group(-name=>'game',-values=>[qw/checkers chess cribbage/],-defaults=>['cribbage'],-override=>1) eq + qq(<input type="checkbox" name="game" value="checkers" />checkers <input type="checkbox" name="game" value="chess" />chess <input type="checkbox" name="game" value="cribbage" checked />cribbage), 'checkbox_group()'); - -test(17, popup_menu(-name=>'game',-Values=>[qw/checkers chess cribbage/],-Default=>'cribbage',-override=>1) eq <<END,'checkbox_group()'); -<SELECT NAME="game"> -<OPTION VALUE="checkers">checkers -<OPTION VALUE="chess">chess -<OPTION SELECTED VALUE="cribbage">cribbage -</SELECT> +test(17, popup_menu(-name=>'game',-values=>[qw/checkers chess cribbage/],-default=>'cribbage',-override=>1) eq <<END,'checkbox_group()'); +<select name="game"> +<option value="checkers">checkers</option> +<option value="chess">chess</option> +<option selected value="cribbage">cribbage</option> +</select> END diff --git a/contrib/perl5/t/lib/cgi-function.t b/contrib/perl5/t/lib/cgi-function.t index b4cd568..3b9722e 100755 --- a/contrib/perl5/t/lib/cgi-function.t +++ b/contrib/perl5/t/lib/cgi-function.t @@ -1,14 +1,15 @@ -#!./perl - -# Test ability to retrieve HTTP request info -######################### We start with some black magic to print on failure. +#!/usr/local/bin/perl -w BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + chdir('t') if -d 't'; + @INC = '../lib'; } -BEGIN {$| = 1; print "1..24\n"; } +# Test ability to retrieve HTTP request info +######################### We start with some black magic to print on failure. +use lib '../blib/lib','../blib/arch'; + +BEGIN {$| = 1; print "1..27\n"; } END {print "not ok 1\n" unless $loaded;} use Config; use CGI (':standard','keywords'); @@ -24,6 +25,22 @@ sub test { print($true ? "ok $num\n" : "not ok $num $msg\n"); } +my $CRLF = "\015\012"; + +# A peculiarity of sending "\n" through MBX|Socket|web-server on VMS +# is that a CR character gets inserted automatically in the web server +# case but not internal to perl's double quoted strings "\n". This +# test would need to be modified to use the "\015\012" on VMS if it +# were actually run through a web server. +# Thanks to Peter Prymmer for this + +if ($^O eq 'VMS') { $CRLF = "\n"; } + +# Web servers on EBCDIC hosts are typically set up to do an EBCDIC -> ASCII +# translation hence CRLF is used as \r\n within CGI.pm on such machines. + +if (ord("\t") != 9) { $CRLF = "\r\n"; } + # Set up a CGI environment $ENV{REQUEST_METHOD}='GET'; $ENV{QUERY_STRING} ='game=chess&game=checkers&weather=dull'; @@ -36,7 +53,7 @@ $ENV{SERVER_NAME} = 'the.good.ship.lollypop.com'; $ENV{HTTP_LOVE} = 'true'; test(2,request_method() eq 'GET',"CGI::request_method()"); -test(3,query_string() eq 'game=chess&game=checkers&weather=dull',"CGI::query_string()"); +test(3,query_string() eq 'game=chess;game=checkers;weather=dull',"CGI::query_string()"); test(4,param() == 2,"CGI::param()"); test(5,join(' ',sort {$a cmp $b} param()) eq 'game weather',"CGI::param()"); test(6,param('game') eq 'chess',"CGI::param()"); @@ -44,18 +61,18 @@ test(7,param('weather') eq 'dull',"CGI::param()"); test(8,join(' ',param('game')) eq 'chess checkers',"CGI::param()"); test(9,param(-name=>'foo',-value=>'bar'),'CGI::param() put'); test(10,param(-name=>'foo') eq 'bar','CGI::param() get'); -test(11,query_string() eq 'game=chess&game=checkers&weather=dull&foo=bar',"CGI::query_string() redux"); +test(11,query_string() eq 'game=chess;game=checkers;weather=dull;foo=bar',"CGI::query_string() redux"); test(12,http('love') eq 'true',"CGI::http()"); test(13,script_name() eq '/cgi-bin/foo.cgi',"CGI::script_name()"); test(14,url() eq 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi',"CGI::url()"); test(15,self_url() eq - 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess&game=checkers&weather=dull&foo=bar', + 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', "CGI::url()"); test(16,url(-absolute=>1) eq '/cgi-bin/foo.cgi','CGI::url(-absolute=>1)'); test(17,url(-relative=>1) eq 'foo.cgi','CGI::url(-relative=>1)'); test(18,url(-relative=>1,-path=>1) eq 'foo.cgi/somewhere/else','CGI::url(-relative=>1,-path=>1)'); test(19,url(-relative=>1,-path=>1,-query=>1) eq - 'foo.cgi/somewhere/else?game=chess&game=checkers&weather=dull&foo=bar', + 'foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', 'CGI::url(-relative=>1,-path=>1,-query=>1)'); Delete('foo'); test(20,!param('foo'),'CGI::delete()'); @@ -65,21 +82,25 @@ $ENV{QUERY_STRING}='mary+had+a+little+lamb'; test(21,join(' ',keywords()) eq 'mary had a little lamb','CGI::keywords'); test(22,join(' ',param('keywords')) eq 'mary had a little lamb','CGI::keywords'); -if (!$Config{d_fork} or $^O eq 'MSWin32' or $^O eq 'VMS') { - for (23,24) { print "ok $_ # Skipped: fork n/a\n" } -} -else { - CGI::_reset_globals; - $test_string = 'game=soccer&game=baseball&weather=nice'; - $ENV{REQUEST_METHOD}='POST'; - $ENV{CONTENT_LENGTH}=length($test_string); - $ENV{QUERY_STRING}='big_balls=basketball&small_balls=golf'; - if (open(CHILD,"|-")) { # cparent - print CHILD $test_string; - close CHILD; - exit 0; - } - # at this point, we're in a new (child) process - test(23,param('weather') eq 'nice',"CGI::param() from POST"); - test(24,url_param('big_balls') eq 'basketball',"CGI::url_param()"); +CGI::_reset_globals; +if ($Config{d_fork}) { + $test_string = 'game=soccer&game=baseball&weather=nice'; + $ENV{REQUEST_METHOD}='POST'; + $ENV{CONTENT_LENGTH}=length($test_string); + $ENV{QUERY_STRING}='big_balls=basketball&small_balls=golf'; + if (open(CHILD,"|-")) { # cparent + print CHILD $test_string; + close CHILD; + exit 0; + } + # at this point, we're in a new (child) process + test(23,param('weather') eq 'nice',"CGI::param() from POST"); + test(24,(url_param('big_balls') eq 'basketball'),"CGI::url_param()"); +} else { + print "ok 23 # Skip\n"; + print "ok 24 # Skip\n"; } +test(25,redirect('http://somewhere.else') eq "Status: 302 Moved${CRLF}location: http://somewhere.else${CRLF}${CRLF}","CGI::redirect() 1"); +my $h = redirect(-Location=>'http://somewhere.else',-Type=>'text/html'); +test(26,$h eq "Status: 302 Moved${CRLF}location: http://somewhere.else${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","CGI::redirect() 2"); +test(27,redirect(-Location=>'http://somewhere.else/bin/foo&bar',-Type=>'text/html') eq "Status: 302 Moved${CRLF}location: http://somewhere.else/bin/foo&bar${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","CGI::redirect() 2"); diff --git a/contrib/perl5/t/lib/cgi-html.t b/contrib/perl5/t/lib/cgi-html.t index 43d41ec..93e5dac 100755 --- a/contrib/perl5/t/lib/cgi-html.t +++ b/contrib/perl5/t/lib/cgi-html.t @@ -1,15 +1,15 @@ -#!./perl - -# Test ability to retrieve HTTP request info -######################### We start with some black magic to print on failure. +#!/usr/local/bin/perl -w BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; - require Config; import Config; + chdir('t') if -d 't'; + @INC = '../lib'; } -BEGIN {$| = 1; print "1..20\n"; } +# Test ability to retrieve HTTP request info +######################### We start with some black magic to print on failure. +use lib '../blib/lib','../blib/arch'; + +BEGIN {$| = 1; print "1..24\n"; } END {print "not ok 1\n" unless $loaded;} use CGI (':standard','-no_debug','*h3','start_table'); $loaded = 1; @@ -17,8 +17,14 @@ print "ok 1\n"; ######################### End of black magic. -my $Is_EBCDIC = $Config{'ebcdic'} eq 'define'; -my $crlf = $CGI::CRLF; +my $CRLF = "\015\012"; +if ($^O eq 'VMS') { + $CRLF = "\n"; # via web server carriage is inserted automatically +} +if (ord("\t") != 9) { # EBCDIC? + $CRLF = "\r\n"; +} + # util sub test { @@ -28,48 +34,62 @@ sub test { } # all the automatic tags -test(2,h1() eq '<H1>',"single tag"); -test(3,h1('fred') eq '<H1>fred</H1>',"open/close tag"); -test(4,h1('fred','agnes','maura') eq '<H1>fred agnes maura</H1>',"open/close tag multiple"); -test(5,h1({-align=>'CENTER'},'fred') eq '<H1 ALIGN="CENTER">fred</H1>',"open/close tag with attribute"); -test(6,h1({-align=>undef},'fred') eq '<H1 ALIGN>fred</H1>',"open/close tag with orphan attribute"); +test(2,h1() eq '<h1 />',"single tag"); +test(3,h1('fred') eq '<h1>fred</h1>',"open/close tag"); +test(4,h1('fred','agnes','maura') eq '<h1>fred agnes maura</h1>',"open/close tag multiple"); +test(5,h1({-align=>'CENTER'},'fred') eq '<h1 align="CENTER">fred</h1>',"open/close tag with attribute"); +test(6,h1({-align=>undef},'fred') eq '<h1 align>fred</h1>',"open/close tag with orphan attribute"); test(7,h1({-align=>'CENTER'},['fred','agnes']) eq - '<H1 ALIGN="CENTER">fred</H1> <H1 ALIGN="CENTER">agnes</H1>', + '<h1 align="CENTER">fred</h1> <h1 align="CENTER">agnes</h1>', "distributive tag with attribute"); { local($") = '-'; - test(8,h1('fred','agnes','maura') eq '<H1>fred-agnes-maura</H1>',"open/close tag \$\" interpolation"); + test(8,h1('fred','agnes','maura') eq '<h1>fred-agnes-maura</h1>',"open/close tag \$\" interpolation"); } - -test(9,header() eq "Content-Type: text/html$crlf$crlf","header()"); -test(10,header(-type=>'image/gif') eq "Content-Type: image/gif$crlf$crlf","header()"); -test(11,header(-type=>'image/gif',-status=>'500 Sucks') eq "Status: 500 Sucks${crlf}Content-Type: image/gif$crlf$crlf","header()"); -test(12,header(-nph=>1) eq "HTTP/1.0 200 OK${crlf}Content-Type: text/html$crlf$crlf","header()"); +test(9,header() eq "Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","header()"); +test(10,header(-type=>'image/gif') eq "Content-Type: image/gif${CRLF}${CRLF}","header()"); +test(11,header(-type=>'image/gif',-status=>'500 Sucks') eq "Status: 500 Sucks${CRLF}Content-Type: image/gif${CRLF}${CRLF}","header()"); +test(12,header(-nph=>1) =~ m!HTTP/1.0 200 OK${CRLF}Server: cmdline${CRLF}Date:.+${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}!,"header()"); test(13,start_html() ."\n" eq <<END,"start_html()"); -<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN"> -<HTML><HEAD><TITLE>Untitled Document</TITLE> -</HEAD><BODY> +<?xml version="1.0" encoding="utf-8"?> +<!DOCTYPE html + PUBLIC "-//W3C//DTD XHTML Basic 1.0//EN" + "http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US"><head><title>Untitled Document</title> +</head><body> END ; test(14,start_html(-dtd=>"-//IETF//DTD HTML 3.2//FR") ."\n" eq <<END,"start_html()"); -<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 3.2//FR"> -<HTML><HEAD><TITLE>Untitled Document</TITLE> -</HEAD><BODY> +<!DOCTYPE html + PUBLIC "-//IETF//DTD HTML 3.2//FR"> +<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US"><head><title>Untitled Document</title> +</head><body> END ; test(15,start_html(-Title=>'The world of foo') ."\n" eq <<END,"start_html()"); -<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN"> -<HTML><HEAD><TITLE>The world of foo</TITLE> -</HEAD><BODY> +<?xml version="1.0" encoding="utf-8"?> +<!DOCTYPE html + PUBLIC "-//W3C//DTD XHTML Basic 1.0//EN" + "http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US"><head><title>The world of foo</title> +</head><body> END ; -test(16,($cookie=cookie(-name=>'fred',-value=>['chocolate','chip'],-path=>'/')) eq - 'fred=chocolate&chip; path=/',"cookie()"); -test(17,header(-Cookie=>$cookie) =~ m!^Set-Cookie: fred=chocolate&chip\; path=/${crlf}Date:.*${crlf}Content-Type: text/html$crlf$crlf!s, - "header(-cookie)"); -test(18,start_h3 eq '<H3>'); -test(19,end_h3 eq '</H3>'); -test(20,start_table({-border=>undef}) eq '<TABLE BORDER>'); - - - +test(16,($cookie=cookie(-name=>'fred',-value=>['chocolate','chip'],-path=>'/')) eq 'fred=chocolate&chip; path=/',"cookie()"); +my $h = header(-Cookie=>$cookie); +test(17,$h =~ m!^Set-Cookie: fred=chocolate&chip\; path=/${CRLF}Date:.*${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}!s, + "header(-cookie)"); +test(18,start_h3 eq '<h3>'); +test(19,end_h3 eq '</h3>'); +test(20,start_table({-border=>undef}) eq '<table border>'); +test(21,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is <not> ‹right›</h1>'); +charset('utf-8'); +if (ord("\t") == 9) { +test(22,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is <not> ‹right›</h1>'); +} +else { +test(22,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is <not> »rightº</h1>'); +} +test(23,i(p('hello there')) eq '<i><p>hello there</p></i>'); +my $q = new CGI; +test(24,$q->h1('hi') eq '<h1>hi</h1>'); diff --git a/contrib/perl5/t/lib/cgi-request.t b/contrib/perl5/t/lib/cgi-request.t index 9e8cdc2..fde3fd0 100755 --- a/contrib/perl5/t/lib/cgi-request.t +++ b/contrib/perl5/t/lib/cgi-request.t @@ -1,17 +1,18 @@ -#!./perl - -# Test ability to retrieve HTTP request info -######################### We start with some black magic to print on failure. +#!/usr/local/bin/perl -w BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + chdir('t') if -d 't'; + @INC = '../lib'; } -BEGIN {$| = 1; print "1..31\n"; } +# Test ability to retrieve HTTP request info +######################### We start with some black magic to print on failure. +use lib '../blib/lib','../blib/arch'; + +BEGIN {$| = 1; print "1..33\n"; } END {print "not ok 1\n" unless $loaded;} -use Config; use CGI (); +use Config; $loaded = 1; print "ok 1\n"; @@ -39,7 +40,7 @@ $ENV{HTTP_LOVE} = 'true'; $q = new CGI; test(2,$q,"CGI::new()"); test(3,$q->request_method eq 'GET',"CGI::request_method()"); -test(4,$q->query_string eq 'game=chess&game=checkers&weather=dull',"CGI::query_string()"); +test(4,$q->query_string eq 'game=chess;game=checkers;weather=dull',"CGI::query_string()"); test(5,$q->param() == 2,"CGI::param()"); test(6,join(' ',sort $q->param()) eq 'game weather',"CGI::param()"); test(7,$q->param('game') eq 'chess',"CGI::param()"); @@ -47,18 +48,18 @@ test(8,$q->param('weather') eq 'dull',"CGI::param()"); test(9,join(' ',$q->param('game')) eq 'chess checkers',"CGI::param()"); test(10,$q->param(-name=>'foo',-value=>'bar'),'CGI::param() put'); test(11,$q->param(-name=>'foo') eq 'bar','CGI::param() get'); -test(12,$q->query_string eq 'game=chess&game=checkers&weather=dull&foo=bar',"CGI::query_string() redux"); +test(12,$q->query_string eq 'game=chess;game=checkers;weather=dull;foo=bar',"CGI::query_string() redux"); test(13,$q->http('love') eq 'true',"CGI::http()"); test(14,$q->script_name eq '/cgi-bin/foo.cgi',"CGI::script_name()"); test(15,$q->url eq 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi',"CGI::url()"); test(16,$q->self_url eq - 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess&game=checkers&weather=dull&foo=bar', + 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', "CGI::url()"); test(17,$q->url(-absolute=>1) eq '/cgi-bin/foo.cgi','CGI::url(-absolute=>1)'); test(18,$q->url(-relative=>1) eq 'foo.cgi','CGI::url(-relative=>1)'); test(19,$q->url(-relative=>1,-path=>1) eq 'foo.cgi/somewhere/else','CGI::url(-relative=>1,-path=>1)'); test(20,$q->url(-relative=>1,-path=>1,-query=>1) eq - 'foo.cgi/somewhere/else?game=chess&game=checkers&weather=dull&foo=bar', + 'foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', 'CGI::url(-relative=>1,-path=>1,-query=>1)'); $q->delete('foo'); test(21,!$q->param('foo'),'CGI::delete()'); @@ -73,22 +74,30 @@ test(26,$q->param('foo') eq 'bar','CGI::param() redux'); test(27,$q=new CGI({'foo'=>'bar','bar'=>'froz'}),"CGI::new() redux 2"); test(28,$q->param('bar') eq 'froz',"CGI::param() redux 2"); -if (!$Config{d_fork} or $^O eq 'MSWin32' or $^O eq 'VMS') { - for (29..31) { print "ok $_ # Skipped: fork n/a\n" } -} -else { - $q->_reset_globals; - $test_string = 'game=soccer&game=baseball&weather=nice'; - $ENV{REQUEST_METHOD}='POST'; - $ENV{CONTENT_LENGTH}=length($test_string); - $ENV{QUERY_STRING}='big_balls=basketball&small_balls=golf'; - if (open(CHILD,"|-")) { # cparent - print CHILD $test_string; - close CHILD; - exit 0; - } - # at this point, we're in a new (child) process - test(29,$q=new CGI,"CGI::new() from POST"); - test(30,$q->param('weather') eq 'nice',"CGI::param() from POST"); - test(31,$q->url_param('big_balls') eq 'basketball',"CGI::url_param()"); +# test tied interface +my $p = $q->Vars; +test(29,$p->{bar} eq 'froz',"tied interface fetch"); +$p->{bar} = join("\0",qw(foo bar baz)); +test(30,join(' ',$q->param('bar')) eq 'foo bar baz','tied interface store'); + +# test posting +$q->_reset_globals; +if ($Config{d_fork}) { + $test_string = 'game=soccer&game=baseball&weather=nice'; + $ENV{REQUEST_METHOD}='POST'; + $ENV{CONTENT_LENGTH}=length($test_string); + $ENV{QUERY_STRING}='big_balls=basketball&small_balls=golf'; + if (open(CHILD,"|-")) { # cparent + print CHILD $test_string; + close CHILD; + exit 0; + } + # at this point, we're in a new (child) process + test(31,$q=new CGI,"CGI::new() from POST"); + test(32,$q->param('weather') eq 'nice',"CGI::param() from POST"); + test(33,$q->url_param('big_balls') eq 'basketball',"CGI::url_param()"); +} else { + print "ok 31 # Skip\n"; + print "ok 32 # Skip\n"; + print "ok 33 # Skip\n"; } diff --git a/contrib/perl5/t/lib/charnames.t b/contrib/perl5/t/lib/charnames.t index 7643390..2731136 100755 --- a/contrib/perl5/t/lib/charnames.t +++ b/contrib/perl5/t/lib/charnames.t @@ -3,12 +3,12 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } $| = 1; -print "1..12\n"; +print "1..15\n"; use charnames ':full'; @@ -42,15 +42,21 @@ EOE $encoded_be = "\320\261"; $encoded_alpha = "\316\261"; $encoded_bet = "\327\221"; +$encoded_deseng = "\360\220\221\215"; + +sub to_bytes { + pack"a*", shift; +} + { use charnames ':full'; - print "not " unless "\N{CYRILLIC SMALL LETTER BE}" eq $encoded_be; + print "not " unless to_bytes("\N{CYRILLIC SMALL LETTER BE}") eq $encoded_be; print "ok 4\n"; use charnames qw(cyrillic greek :short); - print "not " unless "\N{be},\N{alpha},\N{hebrew:bet}" + print "not " unless to_bytes("\N{be},\N{alpha},\N{hebrew:bet}") eq "$encoded_be,$encoded_alpha,$encoded_bet"; print "ok 5\n"; } @@ -72,3 +78,33 @@ $encoded_bet = "\327\221"; print "not " unless sprintf("%vx", "\x{ff}\N{WHITE SMILING FACE}") eq "ff.263a"; print "ok 12\n"; } + +{ + use charnames qw(:full); + use utf8; + + my $x = "\x{221b}"; + my $named = "\N{CUBE ROOT}"; + + print "not " unless ord($x) == ord($named); + print "ok 13\n"; +} + +{ + use charnames qw(:full); + use utf8; + print "not " unless "\x{100}\N{CENT SIGN}" eq "\x{100}"."\N{CENT SIGN}"; + print "ok 14\n"; +} + +{ + use charnames ':full'; + +# XXX this test breaks in 5.6.x because the Unicode database is missing +# "DESERET SMALL LETTER ENG". Uncomment after updating to Unicode 3.1 +# print "not " +# unless to_bytes("\N{DESERET SMALL LETTER ENG}") eq $encoded_deseng; + print "ok 15\n"; + +} + diff --git a/contrib/perl5/t/lib/checktree.t b/contrib/perl5/t/lib/checktree.t index 7603575..b5426ca 100755 --- a/contrib/perl5/t/lib/checktree.t +++ b/contrib/perl5/t/lib/checktree.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..1\n"; diff --git a/contrib/perl5/t/lib/complex.t b/contrib/perl5/t/lib/complex.t index a636ff0..334374d 100755 --- a/contrib/perl5/t/lib/complex.t +++ b/contrib/perl5/t/lib/complex.t @@ -9,12 +9,14 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Math::Complex; -my $VERSION = sprintf("%s", q$Id: complex.t,v 1.9 1998/11/01 00:00:00 dsl Exp $ =~ /(\d+\.d+)/); +use vars qw($VERSION); + +$VERSION = 1.91; my ($args, $op, $target, $test, $test_set, $try, $val, $zvalue, @set, @val); @@ -27,7 +29,7 @@ my @script = ( my $eps = 1e-13; if ($^O eq 'unicos') { # For some reason root() produces very inaccurate - $eps = 1e-11; # results in Cray UNICOS, and occasionally also + $eps = 1e-10; # results in Cray UNICOS, and occasionally also } # cos(), sin(), cosh(), sinh(). The division # of doubles is the current suspect. @@ -159,20 +161,18 @@ test_dbz( 'acsch(0)', 'asec(0)', 'asech(0)', - 'atan(-$i)', 'atan($i)', # 'atanh(-1)', # Log of zero. 'atanh(+1)', 'cot(0)', 'coth(0)', 'csc(0)', - 'tan($pip2)', 'csch(0)', - 'tan($pip2)', ); test_loz( 'log($zero)', + 'atan(-$i)', 'acot(-$i)', 'atanh(-1)', 'acoth(-1)', @@ -187,7 +187,7 @@ sub test_broot { eval 'root(2, $op)'; (\$bad) = (\$@ =~ /(.+)/); print "# $test op = $op badroot? \$bad...\n"; - print 'not ' unless (\$@ =~ /root must be/); + print 'not ' unless (\$@ =~ /root rank must be/); EOT push(@script, qq(print "ok $test\\n";\n)); } @@ -196,6 +196,13 @@ EOT test_broot(qw(-3 -2.1 0 0.99)); sub test_display_format { + $test++; + push @script, <<EOS; + print "# package display_format cartesian?\n"; + print "not " unless Math::Complex->display_format eq 'cartesian'; + print "ok $test\n"; +EOS + push @script, <<EOS; my \$j = (root(1,3))[1]; @@ -204,7 +211,7 @@ EOS $test++; push @script, <<EOS; - print "# display_format polar?\n"; + print "# j display_format polar?\n"; print "not " unless \$j->display_format eq 'polar'; print "ok $test\n"; EOS @@ -264,7 +271,7 @@ EOS $test++; push @script, <<EOS; print "# j = \$j\n"; - print "not " unless "\$j" =~ /^-0\\.5\\+0.86602540\\d+i\$/; + print "not " unless "\$j" =~ /^-0(?:\\.5(?:0000\\d+)?|\\.49999\\d+)\\+0.86602540\\d+i\$/; print "ok $test\n"; \$j->display_format('style' => 'polar', 'polar_pretty_print' => 0); @@ -278,12 +285,20 @@ EOS \$j->display_format('style' => 'cartesian', 'format' => '(%.5g)'); EOS + $test++; push @script, <<EOS; print "# j = \$j\n"; print "not " unless "\$j" eq "(-0.5)+(0.86603)i"; print "ok $test\n"; EOS + + $test++; + push @script, <<EOS; + print "# j display_format cartesian?\n"; + print "not " unless \$j->display_format eq 'cartesian'; + print "ok $test\n"; +EOS } test_display_format(); @@ -894,7 +909,7 @@ __END__ ( 2,-3):( 1.96863792579310, -0.96465850440760) &acosh -(-2.0,0):( -1.31695789692482, 3.14159265358979) +(-2.0,0):( 1.31695789692482, 3.14159265358979) (-1.0,0):( 0, 3.14159265358979) (-0.5,0):( 0, 2.09439510239320) ( 0.0,0):( 0, 1.57079632679490) @@ -904,8 +919,8 @@ __END__ &acosh ( 2, 3):( 1.98338702991654, 1.00014354247380) -(-2, 3):( -1.98338702991653, -2.14144911111600) -(-2,-3):( -1.98338702991653, 2.14144911111600) +(-2, 3):( 1.98338702991653, 2.14144911111600) +(-2,-3):( 1.98338702991653, -2.14144911111600) ( 2,-3):( 1.98338702991654, -1.00014354247380) &atanh @@ -924,15 +939,15 @@ __END__ &asech (-2.0,0):( 0 , 2.09439510239320) (-1.0,0):( 0 , 3.14159265358979) -(-0.5,0):( -1.31695789692482, 3.14159265358979) +(-0.5,0):( 1.31695789692482, 3.14159265358979) ( 0.5,0):( 1.31695789692482, 0 ) ( 1.0,0):( 0 , 0 ) ( 2.0,0):( 0 , 1.04719755119660) &asech ( 2, 3):( 0.23133469857397, -1.42041072246703) -(-2, 3):( -0.23133469857397, 1.72118193112276) -(-2,-3):( -0.23133469857397, -1.72118193112276) +(-2, 3):( 0.23133469857397, -1.72118193112276) +(-2,-3):( 0.23133469857397, 1.72118193112276) ( 2,-3):( 0.23133469857397, 1.42041072246703) &acsch diff --git a/contrib/perl5/t/lib/db-btree.t b/contrib/perl5/t/lib/db-btree.t index b13e50ea..1822823 100755 --- a/contrib/perl5/t/lib/db-btree.t +++ b/contrib/perl5/t/lib/db-btree.t @@ -1,7 +1,7 @@ #!./perl -w BEGIN { - unshift @INC, '../lib' if -d '../lib' ; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bDB_File\b/) { print "1..0 # Skip: DB_File was not built\n"; @@ -9,10 +9,12 @@ BEGIN { } } +use warnings; +use strict; use DB_File; use Fcntl; -print "1..155\n"; +print "1..157\n"; sub ok { @@ -82,7 +84,9 @@ sub docat_del } -$db185mode = ($DB_File::db_version == 1 && ! $DB_File::db_185_compat) ; +my $db185mode = ($DB_File::db_version == 1 && ! $DB_File::db_185_compat) ; +my $null_keys_allowed = ($DB_File::db_ver < 2.004010 + || $DB_File::db_ver >= 3.1 ); my $Dfile = "dbbtree.tmp"; unlink $Dfile; @@ -128,17 +132,19 @@ ok(16, $dbh->{prefix} == 1234 ); # Check that an invalid entry is caught both for store & fetch eval '$dbh->{fred} = 1234' ; ok(17, $@ =~ /^DB_File::BTREEINFO::STORE - Unknown element 'fred' at/ ) ; -eval '$q = $dbh->{fred}' ; +eval 'my $q = $dbh->{fred}' ; ok(18, $@ =~ /^DB_File::BTREEINFO::FETCH - Unknown element 'fred' at/ ) ; # Now check the interface to BTREE +my ($X, %h) ; ok(19, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ; -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, +my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); ok(20, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32'); +my ($key, $value, $i); while (($key,$value) = each(%h)) { $i++; } @@ -209,8 +215,8 @@ $h{'goner3'} = 'snork'; delete $h{'goner1'}; $X->DELETE('goner3'); -@keys = keys(%h); -@values = values(%h); +my @keys = keys(%h); +my @values = values(%h); ok(27, $#keys == 29 && $#values == 29) ; @@ -235,12 +241,19 @@ ok(30, ArrayCompare(\@b, \@c)) ; $h{'foo'} = ''; ok(31, $h{'foo'} eq '' ) ; -#$h{''} = 'bar'; -#ok(32, $h{''} eq 'bar' ); -ok(32,1) ; +# Berkeley DB from version 2.4.10 to 3.0 does not allow null keys. +# This feature was reenabled in version 3.1 of Berkeley DB. +my $result = 0 ; +if ($null_keys_allowed) { + $h{''} = 'bar'; + $result = ( $h{''} eq 'bar' ); +} +else + { $result = 1 } +ok(32, $result) ; # check cache overflow and numeric keys and contents -$ok = 1; +my $ok = 1; for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } ok(33, $ok); @@ -250,7 +263,7 @@ ok(33, $ok); ok(34, $size > 0 ); @h{0..200} = 200..400; -@foo = @h{0..200}; +my @foo = @h{0..200}; ok(35, join(':',200..400) eq join(':',@foo) ); # Now check all the non-tie specific stuff @@ -259,7 +272,7 @@ ok(35, join(':',200..400) eq join(':',@foo) ); # Check R_NOOVERWRITE flag will make put fail when attempting to overwrite # an existing record. -$status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; +my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; ok(36, $status == 1 ); # check that the value of the key 'x' has not been changed by the @@ -280,9 +293,12 @@ ok(40, $value eq 'value' ); $status = $X->del('q') ; ok(41, $status == 0 ); -#$status = $X->del('') ; -#ok(42, $status == 0 ); -ok(42,1) ; +if ($null_keys_allowed) { + $status = $X->del('') ; +} else { + $status = 0 ; +} +ok(42, $status == 0 ); # Make sure that the key deleted, cannot be retrieved ok(43, ! defined $h{'q'}) ; @@ -362,7 +378,7 @@ ok(65, 1) ; # hard-wire to always pass. the previous test ($status == 1) $status = $X->seq($key, $value, R_FIRST) ; ok(66, $status == 0 ); -$previous = $key ; +my $previous = $key ; $ok = 1 ; while (($status = $X->seq($key, $value, R_NEXT)) == 0) @@ -411,6 +427,7 @@ untie %h ; unlink $Dfile; # Now try an in memory file +my $Y; ok(74, $Y = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_BTREE )); # fd with an in memory file should return failure @@ -424,6 +441,7 @@ untie %h ; # Duplicate keys my $bt = new DB_File::BTREEINFO ; $bt->{flags} = R_DUP ; +my ($YY, %hh); ok(76, $YY = tie(%hh, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $bt )) ; $hh{'Wall'} = 'Larry' ; @@ -469,34 +487,38 @@ unlink $Dfile; # test multiple callbacks -$Dfile1 = "btree1" ; -$Dfile2 = "btree2" ; -$Dfile3 = "btree3" ; +my $Dfile1 = "btree1" ; +my $Dfile2 = "btree2" ; +my $Dfile3 = "btree3" ; -$dbh1 = new DB_File::BTREEINFO ; -{ local $^W = 0 ; - $dbh1->{compare} = sub { $_[0] <=> $_[1] } ; } +my $dbh1 = new DB_File::BTREEINFO ; +$dbh1->{compare} = sub { + no warnings 'numeric' ; + $_[0] <=> $_[1] } ; -$dbh2 = new DB_File::BTREEINFO ; +my $dbh2 = new DB_File::BTREEINFO ; $dbh2->{compare} = sub { $_[0] cmp $_[1] } ; -$dbh3 = new DB_File::BTREEINFO ; +my $dbh3 = new DB_File::BTREEINFO ; $dbh3->{compare} = sub { length $_[0] <=> length $_[1] } ; -tie(%h, 'DB_File',$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) ; +my (%g, %k); +tie(%h, 'DB_File',$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) ; tie(%g, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ; tie(%k, 'DB_File',$Dfile3, O_RDWR|O_CREAT, 0640, $dbh3 ) ; -@Keys = qw( 0123 12 -1234 9 987654321 def ) ; -{ local $^W = 0 ; - @srt_1 = sort { $a <=> $b } @Keys ; } +my @Keys = qw( 0123 12 -1234 9 987654321 def ) ; +my (@srt_1, @srt_2, @srt_3); +{ + no warnings 'numeric' ; + @srt_1 = sort { $a <=> $b } @Keys ; +} @srt_2 = sort { $a cmp $b } @Keys ; @srt_3 = sort { length $a <=> length $b } @Keys ; foreach (@Keys) { - { local $^W = 0 ; - $h{$_} = 1 ; } + $h{$_} = 1 ; $g{$_} = 1 ; $k{$_} = 1 ; } @@ -566,6 +588,7 @@ unlink $Dfile1 ; package Another ; + use warnings ; use strict ; open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; @@ -573,6 +596,7 @@ unlink $Dfile1 ; package SubDB ; + use warnings ; use strict ; use vars qw( @ISA @EXPORT) ; @@ -656,6 +680,7 @@ EOM { # DBM Filter tests + use warnings ; use strict ; my (%h, $db) ; my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; @@ -762,6 +787,7 @@ EOM { # DBM Filter with a closure + use warnings ; use strict ; my (%h, $db) ; @@ -824,6 +850,7 @@ EOM { # DBM Filter recursion detection + use warnings ; use strict ; my (%h, $db) ; unlink $Dfile; @@ -852,6 +879,7 @@ EOM # BTREE example 1 ### + use warnings FATAL => qw(all) ; use strict ; use DB_File ; @@ -904,6 +932,7 @@ EOM # BTREE example 2 ### + use warnings FATAL => qw(all) ; use strict ; use DB_File ; @@ -955,6 +984,7 @@ EOM # BTREE example 3 ### + use warnings FATAL => qw(all) ; use strict ; use DB_File ; @@ -1010,6 +1040,7 @@ EOM # BTREE example 4 ### + use warnings FATAL => qw(all) ; use strict ; use DB_File ; @@ -1058,6 +1089,7 @@ EOM # BTREE example 5 ### + use warnings FATAL => qw(all) ; use strict ; use DB_File ; @@ -1092,6 +1124,7 @@ EOM # BTREE example 6 ### + use warnings FATAL => qw(all) ; use strict ; use DB_File ; @@ -1126,6 +1159,7 @@ EOM # BTREE example 7 ### + use warnings FATAL => qw(all) ; use strict ; use DB_File ; use Fcntl ; @@ -1217,4 +1251,46 @@ EOM # unlink $Dfile; #} +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE + or die "Can't open file: $!\n" ; + $h{ABC} = undef; + ok(156, $a eq "") ; + untie %h ; + unlink $Dfile; +} + +{ + # test that %hash = () doesn't produce the warning + # Argument "" isn't numeric in entersub + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE + or die "Can't open file: $!\n" ; + %h = (); ; + ok(157, $a eq "") ; + untie %h ; + unlink $Dfile; +} + exit ; diff --git a/contrib/perl5/t/lib/db-hash.t b/contrib/perl5/t/lib/db-hash.t index c52d8ae..effc60b 100755 --- a/contrib/perl5/t/lib/db-hash.t +++ b/contrib/perl5/t/lib/db-hash.t @@ -1,7 +1,7 @@ #!./perl -w BEGIN { - unshift @INC, '../lib' if -d '../lib' ; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bDB_File\b/) { print "1..0 # Skip: DB_File was not built\n"; @@ -9,10 +9,12 @@ BEGIN { } } +use strict; +use warnings; use DB_File; use Fcntl; -print "1..109\n"; +print "1..111\n"; sub ok { @@ -57,6 +59,9 @@ sub docat_del } my $Dfile = "dbhash.tmp"; +my $null_keys_allowed = ($DB_File::db_ver < 2.004010 + || $DB_File::db_ver >= 3.1 ); + unlink $Dfile; umask(0); @@ -98,13 +103,14 @@ ok(14, $@ =~ /^DB_File::HASHINFO::FETCH - Unknown element 'fred' at/ ); # Now check the interface to HASH - +my ($X, %h); ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, +my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); ok(16, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32'); +my ($key, $value, $i); while (($key,$value) = each(%h)) { $i++; } @@ -176,8 +182,8 @@ $h{'goner3'} = 'snork'; delete $h{'goner1'}; $X->DELETE('goner3'); -@keys = keys(%h); -@values = values(%h); +my @keys = keys(%h); +my @values = values(%h); ok(23, $#keys == 29 && $#values == 29) ; @@ -197,14 +203,19 @@ ok(25, $#keys == 31) ; $h{'foo'} = ''; ok(26, $h{'foo'} eq '' ); -# Berkeley DB 2 from version 2.4.10 onwards does not allow null keys. -# This feature will be reenabled in a future version of Berkeley DB. -#$h{''} = 'bar'; -#ok(27, $h{''} eq 'bar' ); -ok(27,1) ; +# Berkeley DB from version 2.4.10 to 3.0 does not allow null keys. +# This feature was reenabled in version 3.1 of Berkeley DB. +my $result = 0 ; +if ($null_keys_allowed) { + $h{''} = 'bar'; + $result = ( $h{''} eq 'bar' ); +} +else + { $result = 1 } +ok(27, $result) ; # check cache overflow and numeric keys and contents -$ok = 1; +my $ok = 1; for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } ok(28, $ok ); @@ -214,7 +225,7 @@ ok(28, $ok ); ok(29, $size > 0 ); @h{0..200} = 200..400; -@foo = @h{0..200}; +my @foo = @h{0..200}; ok(30, join(':',200..400) eq join(':',@foo) ); @@ -223,7 +234,7 @@ ok(30, join(':',200..400) eq join(':',@foo) ); # Check NOOVERWRITE will make put fail when attempting to overwrite # an existing record. -$status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; +my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; ok(31, $status == 1 ); # check that the value of the key 'x' has not been changed by the @@ -246,9 +257,10 @@ $status = $X->del('q') ; ok(36, $status == 0 ); # Make sure that the key deleted, cannot be retrieved -$^W = 0 ; -ok(37, $h{'q'} eq undef ); -$^W = 1 ; +{ + no warnings 'uninitialized' ; + ok(37, $h{'q'} eq undef ); +} # Attempting to delete a non-existant key should fail @@ -361,6 +373,7 @@ untie %h ; package Another ; + use warnings ; use strict ; open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; @@ -368,6 +381,7 @@ untie %h ; package SubDB ; + use warnings ; use strict ; use vars qw( @ISA @EXPORT) ; @@ -451,6 +465,7 @@ EOM { # DBM Filter tests + use warnings ; use strict ; my (%h, $db) ; my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; @@ -557,6 +572,7 @@ EOM { # DBM Filter with a closure + use warnings ; use strict ; my (%h, $db) ; @@ -619,6 +635,7 @@ EOM { # DBM Filter recursion detection + use warnings ; use strict ; my (%h, $db) ; unlink $Dfile; @@ -643,6 +660,7 @@ EOM { my $redirect = new Redirect $file ; + use warnings FATAL => qw(all); use strict ; use DB_File ; use vars qw( %h $k $v ) ; @@ -682,4 +700,44 @@ EOM } +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ; + $h{ABC} = undef; + ok(110, $a eq "") ; + untie %h ; + unlink $Dfile; +} + +{ + # test that %hash = () doesn't produce the warning + # Argument "" isn't numeric in entersub + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ; + %h = (); ; + ok(111, $a eq "") ; + untie %h ; + unlink $Dfile; +} + exit ; diff --git a/contrib/perl5/t/lib/db-recno.t b/contrib/perl5/t/lib/db-recno.t index 276f38b..8b5a88c 100755 --- a/contrib/perl5/t/lib/db-recno.t +++ b/contrib/perl5/t/lib/db-recno.t @@ -1,7 +1,7 @@ #!./perl -w BEGIN { - unshift @INC, '../lib' if -d '../lib' ; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bDB_File\b/) { print "1..0 # Skip: DB_File was not built\n"; @@ -12,6 +12,7 @@ BEGIN { use DB_File; use Fcntl; use strict ; +use warnings; use vars qw($dbh $Dfile $bad_ones $FA) ; # full tied array support started in Perl 5.004_57 @@ -99,7 +100,7 @@ sub bad_one EOM } -print "1..126\n"; +print "1..128\n"; my $Dfile = "recno.tmp"; unlink $Dfile ; @@ -340,6 +341,7 @@ unlink $Dfile; package Another ; + use warnings ; use strict ; open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; @@ -347,6 +349,7 @@ unlink $Dfile; package SubDB ; + use warnings ; use strict ; use vars qw( @ISA @EXPORT) ; @@ -487,6 +490,7 @@ EOM { # DBM Filter tests + use warnings ; use strict ; my (@h, $db) ; my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; @@ -593,6 +597,7 @@ EOM { # DBM Filter with a closure + use warnings ; use strict ; my (@h, $db) ; @@ -655,6 +660,7 @@ EOM { # DBM Filter recursion detection + use warnings ; use strict ; my (@h, $db) ; unlink $Dfile; @@ -679,6 +685,7 @@ EOM { my $redirect = new Redirect $file ; + use warnings FATAL => qw(all); use strict ; use DB_File ; @@ -734,6 +741,7 @@ EOM { my $redirect = new Redirect $save_output ; + use warnings FATAL => qw(all); use strict ; use vars qw(@h $H $file $i) ; use DB_File ; @@ -836,4 +844,46 @@ EOM } +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use DB_File ; + + unlink $Dfile; + my @h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO + or die "Can't open file: $!\n" ; + $h[0] = undef; + ok(127, $a eq "") ; + untie @h ; + unlink $Dfile; +} + +{ + # test that %hash = () doesn't produce the warning + # Argument "" isn't numeric in entersub + use warnings ; + use strict ; + use DB_File ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + unlink $Dfile; + my @h ; + + tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO + or die "Can't open file: $!\n" ; + @h = (); ; + ok(128, $a eq "") ; + untie @h ; + unlink $Dfile; +} + exit ; diff --git a/contrib/perl5/t/lib/dirhand.t b/contrib/perl5/t/lib/dirhand.t index a8683c7..aa7be35 100755 --- a/contrib/perl5/t/lib/dirhand.t +++ b/contrib/perl5/t/lib/dirhand.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if (not $Config{'d_readdir'}) { print "1..0\n"; diff --git a/contrib/perl5/t/lib/dosglob.t b/contrib/perl5/t/lib/dosglob.t index ea537bf..fd9bb1d 100755 --- a/contrib/perl5/t/lib/dosglob.t +++ b/contrib/perl5/t/lib/dosglob.t @@ -6,7 +6,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..10\n"; @@ -39,7 +39,7 @@ while (defined($_ = <*/a*.t>)) { print "not " if @r != $r; print "ok 4\n"; -# check if array context works +# check if list context works @r = (); for (<*/a*.t>) { print "# $_\n"; diff --git a/contrib/perl5/t/lib/dprof.t b/contrib/perl5/t/lib/dprof.t index 4d6f782..be711f1 100755 --- a/contrib/perl5/t/lib/dprof.t +++ b/contrib/perl5/t/lib/dprof.t @@ -2,23 +2,28 @@ BEGIN { chdir( 't' ) if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bDevel\/DProf\b/){ + print "1..0 # Skip: Devel::DProf was not built\n"; + exit 0; + } } END { - unlink 'tmon.out', 'err'; + while(-e 'tmon.out' && unlink 'tmon.out') {} + while(-e 'err' && unlink 'err') {} } use Benchmark qw( timediff timestr ); use Getopt::Std 'getopts'; -use Config '%Config'; getopts('vI:p:'); # -v Verbose # -I Add to @INC # -p Name of perl binary -@tests = @ARGV ? @ARGV : sort <lib/dprof/*_t lib/dprof/*_v>; # glob-sort, for OS/2 +@tests = @ARGV ? @ARGV : sort (<lib/dprof/*_t>, <lib/dprof/*_v>); # glob-sort, for OS/2 $path_sep = $Config{path_sep} || ':'; $perl5lib = $opt_I || join( $path_sep, @INC ); @@ -42,7 +47,7 @@ sub profile { my $opt_d = '-d:DProf'; my $t_start = new Benchmark; - open( R, "$perl $opt_d $test |" ) || warn "$0: Can't run. $!\n"; + open( R, "$perl \"$opt_d\" $test |" ) || warn "$0: Can't run. $!\n"; @results = <R>; close R; my $t_total = timediff( new Benchmark, $t_start ); @@ -52,15 +57,17 @@ sub profile { print @results } - print timestr( $t_total, 'nop' ), "\n"; + print '# ',timestr( $t_total, 'nop' ), "\n"; } sub verify { my $test = shift; - system $perl, '-I../lib', '-I./lib/dprof', $test, - $opt_v?'-v':'', '-p', $perl; + my $command = $perl.' "-I../lib" "-I./lib/dprof" '.$test; + $command .= ' -v' if $opt_v; + $command .= ' -p '. $perl; + system $command; } @@ -68,6 +75,7 @@ $| = 1; print "1..18\n"; while( @tests ){ $test = shift @tests; + $test =~ s/\.$// if $^O eq 'VMS'; if( $test =~ /_t$/i ){ print "# $test" . '.' x (20 - length $test); profile $test; diff --git a/contrib/perl5/t/lib/dprof/V.pm b/contrib/perl5/t/lib/dprof/V.pm index 7e34da5..152cddc 100644 --- a/contrib/perl5/t/lib/dprof/V.pm +++ b/contrib/perl5/t/lib/dprof/V.pm @@ -13,15 +13,19 @@ $num = 0; $results = $expected = ''; $perl = $opt_p || $^X; $dpp = $opt_d || '../utils/dprofpp'; +$dpp .= '.com' if $^O eq 'VMS'; print "\nperl: $perl\n" if $opt_v; if( ! -f $perl ){ die "Where's Perl?" } -if( ! -f $dpp ){ die "Where's dprofpp?" } +if( ! -f $dpp ) { + ($dpp = $^X) =~ s@(^.*)[/|\\].*@$1/dprofpp@; + die "Where's dprofpp?" if( ! -f $dpp ); +} sub dprofpp { my $switches = shift; - open( D, "$perl -I../lib $dpp $switches 2> err |" ) || warn "$0: Can't run. $!\n"; + open( D, "$perl \"-I../lib\" $dpp \"$switches\" 2> err |" ) || warn "$0: Can't run. $!\n"; @results = <D>; close D; diff --git a/contrib/perl5/t/lib/dumper-ovl.t b/contrib/perl5/t/lib/dumper-ovl.t index 8c095e5..d4b3a92 100755 --- a/contrib/perl5/t/lib/dumper-ovl.t +++ b/contrib/perl5/t/lib/dumper-ovl.t @@ -2,7 +2,12 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { + print "1..0 # Skip: Data::Dumper was not built\n"; + exit 0; + } } use Data::Dumper; diff --git a/contrib/perl5/t/lib/dumper.t b/contrib/perl5/t/lib/dumper.t index 3167535..be9732f 100755 --- a/contrib/perl5/t/lib/dumper.t +++ b/contrib/perl5/t/lib/dumper.t @@ -5,7 +5,12 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { + print "1..0 # Skip: Data::Dumper was not built\n"; + exit 0; + } } use Data::Dumper; @@ -257,11 +262,14 @@ EOT ## $WANT = <<'EOT'; #$VAR1 = { -# "abc\0'\efg" => "mno\0" +# "abc\0'\efg" => "mno\0", +# "reftest" => \\1 #}; EOT -$foo = { "abc\000\'\efg" => "mno\000" }; +$foo = { "abc\000\'\efg" => "mno\000", + "reftest" => \\1, + }; { local $Data::Dumper::Useqq = 1; TEST q(Dumper($foo)); @@ -269,7 +277,8 @@ $foo = { "abc\000\'\efg" => "mno\000" }; $WANT = <<"EOT"; #\$VAR1 = { -# 'abc\0\\'\efg' => 'mno\0' +# 'abc\0\\'\efg' => 'mno\0', +# 'reftest' => \\\\1 #}; EOT @@ -287,7 +296,7 @@ EOT package main; use Data::Dumper; $foo = 5; - @foo = (10,\*foo); + @foo = (-10,\*foo); %foo = (a=>1,b=>\$foo,c=>\@foo); $foo{d} = \%foo; $foo[2] = \%foo; @@ -299,7 +308,7 @@ EOT #*::foo = \5; #*::foo = [ # #0 -# 10, +# -10, # #1 # do{my $o}, # #2 @@ -330,7 +339,7 @@ EOT #$foo = \*::foo; #*::foo = \5; #*::foo = [ -# 10, +# -10, # do{my $o}, # { # 'a' => 1, @@ -356,7 +365,7 @@ EOT ## $WANT = <<'EOT'; #@bar = ( -# 10, +# -10, # \*::foo, # {} #); @@ -383,7 +392,7 @@ EOT ## $WANT = <<'EOT'; #$bar = [ -# 10, +# -10, # \*::foo, # {} #]; @@ -411,7 +420,7 @@ EOT $WANT = <<'EOT'; #$foo = \*::foo; #@bar = ( -# 10, +# -10, # $foo, # { # a => 1, @@ -433,7 +442,7 @@ EOT $WANT = <<'EOT'; #$foo = \*::foo; #$bar = [ -# 10, +# -10, # $foo, # { # a => 1, diff --git a/contrib/perl5/t/lib/english.t b/contrib/perl5/t/lib/english.t index dba68db..0cbbdbf 100755 --- a/contrib/perl5/t/lib/english.t +++ b/contrib/perl5/t/lib/english.t @@ -2,7 +2,7 @@ print "1..16\n"; -BEGIN { unshift @INC, '../lib' } +BEGIN { @INC = '../lib' } use English; use Config; my $threads = $Config{'use5005threads'} || 0; @@ -43,5 +43,5 @@ print $GID == $( ? "ok 12\n" : "not ok 12\n"; print $EUID == $> ? "ok 13\n" : "not ok 13\n"; print $EGID == $) ? "ok 14\n" : "not ok 14\n"; -print $PROGRAM_NAME == $0 ? "ok 15\n" : "not ok 15\n"; +print $PROGRAM_NAME eq $0 ? "ok 15\n" : "not ok 15\n"; print $BASETIME == $^T ? "ok 16\n" : "not ok 16\n"; diff --git a/contrib/perl5/t/lib/env-array.t b/contrib/perl5/t/lib/env-array.t index d90d892..c5068fd 100755 --- a/contrib/perl5/t/lib/env-array.t +++ b/contrib/perl5/t/lib/env-array.t @@ -4,7 +4,7 @@ $| = 1; BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } if ($^O eq 'VMS') { diff --git a/contrib/perl5/t/lib/env.t b/contrib/perl5/t/lib/env.t index 2573164..ff6af2e 100755 --- a/contrib/perl5/t/lib/env.t +++ b/contrib/perl5/t/lib/env.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } BEGIN { diff --git a/contrib/perl5/t/lib/errno.t b/contrib/perl5/t/lib/errno.t index 6320f6b..02f5ce2 100755 --- a/contrib/perl5/t/lib/errno.t +++ b/contrib/perl5/t/lib/errno.t @@ -3,7 +3,11 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + if ($^O eq 'MacOS') { + @INC = qw(: ::lib ::macos:lib); + } else { + @INC = '../lib'; + } } } diff --git a/contrib/perl5/t/lib/fatal.t b/contrib/perl5/t/lib/fatal.t index 4013fbd..f00b876 100755 --- a/contrib/perl5/t/lib/fatal.t +++ b/contrib/perl5/t/lib/fatal.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; print "1..15\n"; } diff --git a/contrib/perl5/t/lib/fields.t b/contrib/perl5/t/lib/fields.t index 7709ee5..a3f591a 100755 --- a/contrib/perl5/t/lib/fields.t +++ b/contrib/perl5/t/lib/fields.t @@ -4,7 +4,7 @@ my $w; BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; $SIG{__WARN__} = sub { if ($_[0] =~ /^Hides field 'b1' in base class/) { $w++; diff --git a/contrib/perl5/t/lib/filecache.t b/contrib/perl5/t/lib/filecache.t index 019f374..a97fdd5 100755 --- a/contrib/perl5/t/lib/filecache.t +++ b/contrib/perl5/t/lib/filecache.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..1\n"; diff --git a/contrib/perl5/t/lib/filecopy.t b/contrib/perl5/t/lib/filecopy.t index b6fcbea..3072c54 100755 --- a/contrib/perl5/t/lib/filecopy.t +++ b/contrib/perl5/t/lib/filecopy.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } $| = 1; diff --git a/contrib/perl5/t/lib/filefind.t b/contrib/perl5/t/lib/filefind.t index e9a2916..362c1eb 100755 --- a/contrib/perl5/t/lib/filefind.t +++ b/contrib/perl5/t/lib/filefind.t @@ -6,7 +6,7 @@ my $symlink_exists = eval { symlink("",""); 1 }; BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } if ( $symlink_exists ) { print "1..117\n"; } @@ -19,6 +19,7 @@ finddepth(sub { print "ok 2\n" if $_ eq 'filefind.t'; }, "."); my $case = 2; +my $FastFileTests_OK = 0; END { unlink 'fa/fa_ord','fa/fsl','fa/faa/faa_ord', @@ -57,8 +58,15 @@ sub wanted { print "# '$_' => 1\n"; s#\.$## if ($^O eq 'VMS' && $_ ne '.'); Check( $Expect{$_} ); - delete $Expect{$_}; + if ( $FastFileTests_OK ) { + delete $Expect{$_} + unless ( $Expect_Dir{$_} && ! -d _ ); + } else { + delete $Expect{$_} + unless ( $Expect_Dir{$_} && ! -d $_ ); + } $File::Find::prune=1 if $_ eq 'faba'; + } sub dn_wanted { @@ -106,6 +114,9 @@ touch('fa/fab/faba/faba_ord'); %Expect = ('.' => 1, 'fsl' => 1, 'fa_ord' => 1, 'fab' => 1, 'fab_ord' => 1, 'faba' => 1, 'faa' => 1, 'faa_ord' => 1); delete $Expect{'fsl'} unless $symlink_exists; +%Expect_Dir = ('fa' => 1, 'faa' => 1, 'fab' => 1, 'faba' => 1, + 'fb' => 1, 'fba' => 1); +delete @Expect_Dir{'fb','fba'} unless $symlink_exists; File::Find::find( {wanted => \&wanted, },'fa' ); Check( scalar(keys %Expect) == 0 ); @@ -113,6 +124,9 @@ Check( scalar(keys %Expect) == 0 ); 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1, 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); delete $Expect{'fa/fsl'} unless $symlink_exists; +%Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, + 'fb' => 1, 'fb/fba' => 1); +delete @Expect_Dir{'fb','fb/fba'} unless $symlink_exists; File::Find::find( {wanted => \&wanted, no_chdir => 1},'fa' ); Check( scalar(keys %Expect) == 0 ); @@ -122,6 +136,9 @@ Check( scalar(keys %Expect) == 0 ); './fa/fab/faba/faba_ord' => 1, './fa/faa' => 1, './fa/faa/faa_ord' => 1, './fb' => 1, './fb/fba' => 1, './fb/fba/fba_ord' => 1, './fb/fb_ord' => 1); delete $Expect{'./fa/fsl'} unless $symlink_exists; +%Expect_Dir = ('./fa' => 1, './fa/faa' => 1, '/fa/fab' => 1, './fa/fab/faba' => 1, + './fb' => 1, './fb/fba' => 1); +delete @Expect_Dir{'./fb','./fb/fba'} unless $symlink_exists; File::Find::finddepth( {wanted => \&dn_wanted },'.' ); Check( scalar(keys %Expect) == 0 ); @@ -130,13 +147,19 @@ Check( scalar(keys %Expect) == 0 ); './fa/fab/faba/faba_ord' => 1, './fa/faa' => 1, './fa/faa/faa_ord' => 1, './fb' => 1, './fb/fba' => 1, './fb/fba/fba_ord' => 1, './fb/fb_ord' => 1); delete $Expect{'./fa/fsl'} unless $symlink_exists; +%Expect_Dir = ('./fa' => 1, './fa/faa' => 1, '/fa/fab' => 1, './fa/fab/faba' => 1, + './fb' => 1, './fb/fba' => 1); +delete @Expect_Dir{'./fb','./fb/fba'} unless $symlink_exists; File::Find::finddepth( {wanted => \&d_wanted, no_chdir => 1 },'.' ); Check( scalar(keys %Expect) == 0 ); if ( $symlink_exists ) { + $FastFileTests_OK= 1; %Expect=('.' => 1, 'fa_ord' => 1, 'fsl' => 1, 'fb_ord' => 1, 'fba' => 1, 'fba_ord' => 1, 'fab' => 1, 'fab_ord' => 1, 'faba' => 1, 'faa' => 1, 'faa_ord' => 1); + %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, + 'fb' => 1, 'fb/fba' => 1); File::Find::find( {wanted => \&wanted, follow_fast => 1},'fa' ); Check( scalar(keys %Expect) == 0 ); @@ -145,6 +168,8 @@ if ( $symlink_exists ) { 'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1, 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1, 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); + %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, + 'fb' => 1, 'fb/fba' => 1); File::Find::find( {wanted => \&wanted, follow_fast => 1, no_chdir => 1},'fa' ); Check( scalar(keys %Expect) == 0 ); @@ -152,6 +177,8 @@ if ( $symlink_exists ) { 'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1, 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1, 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); + %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, + 'fb' => 1, 'fb/fba' => 1); File::Find::finddepth( {wanted => \&dn_wanted, follow_fast => 1},'fa' ); Check( scalar(keys %Expect) == 0 ); @@ -160,6 +187,8 @@ if ( $symlink_exists ) { 'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1, 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1, 'fa/faa' => 1, 'fa/faa/faa_ord' => 1); + %Expect_Dir = ('fa' => 1, 'fa/faa' => 1, '/fa/fab' => 1, 'fa/fab/faba' => 1, + 'fb' => 1, 'fb/fba' => 1); File::Find::finddepth( {wanted => \&d_wanted, follow_fast => 1, no_chdir => 1},'fa' ); Check( scalar(keys %Expect) == 0 ); diff --git a/contrib/perl5/t/lib/filefunc.t b/contrib/perl5/t/lib/filefunc.t index 46a1e35..9268122 100755 --- a/contrib/perl5/t/lib/filefunc.t +++ b/contrib/perl5/t/lib/filefunc.t @@ -3,7 +3,7 @@ BEGIN { $^O = ''; chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..1\n"; diff --git a/contrib/perl5/t/lib/filehand.t b/contrib/perl5/t/lib/filehand.t index 22cff0e..0f3e177 100755 --- a/contrib/perl5/t/lib/filehand.t +++ b/contrib/perl5/t/lib/filehand.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { print "1..0\n"; @@ -20,7 +20,7 @@ $| = 1; autoflush $mystdout; print "1..11\n"; -print $mystdout "ok ",fileno($mystdout),"\n"; +print $mystdout "ok ".fileno($mystdout)."\n"; $fh = (new FileHandle "./TEST", O_RDONLY or new FileHandle "TEST", O_RDONLY) diff --git a/contrib/perl5/t/lib/filepath.t b/contrib/perl5/t/lib/filepath.t index 5628d0c..42e0ae9 100755 --- a/contrib/perl5/t/lib/filepath.t +++ b/contrib/perl5/t/lib/filepath.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use File::Path; diff --git a/contrib/perl5/t/lib/filespec.t b/contrib/perl5/t/lib/filespec.t index da52ec5..c6d155f 100755 --- a/contrib/perl5/t/lib/filespec.t +++ b/contrib/perl5/t/lib/filespec.t @@ -3,7 +3,7 @@ BEGIN { $^O = ''; chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } # Each element in this array is a single test. Storing them this way makes diff --git a/contrib/perl5/t/lib/findbin.t b/contrib/perl5/t/lib/findbin.t index f0939e9..3e742f9 100755 --- a/contrib/perl5/t/lib/findbin.t +++ b/contrib/perl5/t/lib/findbin.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..1\n"; diff --git a/contrib/perl5/t/lib/gdbm.t b/contrib/perl5/t/lib/gdbm.t index dc4e96e..ecbd662 100755 --- a/contrib/perl5/t/lib/gdbm.t +++ b/contrib/perl5/t/lib/gdbm.t @@ -3,7 +3,7 @@ # $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ BEGIN { - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bGDBM_File\b/) { print "1..0 # Skip: GDBM_File was not built\n"; @@ -11,16 +11,21 @@ BEGIN { } } +use strict; +use warnings; + + use GDBM_File; -print "1..66\n"; +print "1..68\n"; unlink <Op.dbmx*>; umask(0); -print (tie(%h,GDBM_File,'Op.dbmx', &GDBM_WRCREAT, 0640) ? "ok 1\n" : "not ok 1\n"); +my %h ; +print (tie(%h,'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640) ? "ok 1\n" : "not ok 1\n"); -$Dfile = "Op.dbmx.pag"; +my $Dfile = "Op.dbmx.pag"; if (! -e $Dfile) { ($Dfile) = <Op.dbmx*>; } @@ -28,11 +33,12 @@ 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, + my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); } -while (($key,$value) = each(%h)) { +my $i = 0; +while (my ($key,$value) = each(%h)) { $i++; } print (!$i ? "ok 3\n" : "not ok 3\n"); @@ -57,7 +63,7 @@ $h{'goner2'} = 'snork'; delete $h{'goner2'}; untie(%h); -print (tie(%h,GDBM_File,'Op.dbmx', &GDBM_WRCREAT, 0640) ? "ok 4\n" : "not ok 4\n"); +print (tie(%h,'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640) ? "ok 4\n" : "not ok 4\n"); $h{'j'} = 'J'; $h{'k'} = 'K'; @@ -82,12 +88,12 @@ $h{'goner3'} = 'snork'; delete $h{'goner1'}; delete $h{'goner3'}; -@keys = keys(%h); -@values = values(%h); +my @keys = keys(%h); +my @values = values(%h); if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} -while (($key,$value) = each(%h)) { +while (my ($key,$value) = each(%h)) { if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { $key =~ y/a-z/A-Z/; $i++ if $key eq $value; @@ -103,17 +109,17 @@ $h{'foo'} = ''; $h{''} = 'bar'; # check cache overflow and numeric keys and contents -$ok = 1; +my $ok = 1; for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } print ($ok ? "ok 8\n" : "not ok 8\n"); -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, +my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); print ($size > 0 ? "ok 9\n" : "not ok 9\n"); @h{0..200} = 200..400; -@foo = @h{0..200}; +my @foo = @h{0..200}; print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); @@ -137,6 +143,7 @@ sub ok package Another ; use strict ; + use warnings ; open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; print FILE <<'EOM' ; @@ -178,6 +185,7 @@ EOM close FILE ; BEGIN { push @INC, '.'; } + unlink <dbhash.tmp*> ; eval 'use SubDB ; '; main::ok(13, $@ eq "") ; @@ -210,6 +218,7 @@ EOM { # DBM Filter tests use strict ; + use warnings ; my (%h, $db) ; my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; @@ -316,6 +325,7 @@ EOM # DBM Filter with a closure use strict ; + use warnings ; my (%h, $db) ; unlink <Op.dbmx*>; @@ -360,7 +370,7 @@ EOM ok(54, $result{"store key"} eq "store key - 2: [fred jim]"); ok(55, $result{"store value"} eq "store value - 2: [joe john]"); ok(56, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(57, $result{"fetch value"} eq ""); + ok(57, ! defined $result{"fetch value"} ); ok(58, $_ eq "original") ; ok(59, $h{"fred"} eq "joe"); @@ -378,6 +388,7 @@ EOM { # DBM Filter recursion detection use strict ; + use warnings ; my (%h, $db) ; unlink <Op.dbmx*>; @@ -392,3 +403,24 @@ EOM untie %h; unlink <Op.dbmx*>; } + +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use GDBM_File ; + + unlink <Op.dbmx*>; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + ok(67, tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)); + $h{ABC} = undef; + ok(68, $a eq "") ; + untie %h; + unlink <Op.dbmx*>; +} diff --git a/contrib/perl5/t/lib/getopt.t b/contrib/perl5/t/lib/getopt.t index 0354627..fb70f10 100755 --- a/contrib/perl5/t/lib/getopt.t +++ b/contrib/perl5/t/lib/getopt.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..11\n"; diff --git a/contrib/perl5/t/lib/glob-basic.t b/contrib/perl5/t/lib/glob-basic.t index 4728083..a014bfd 100755 --- a/contrib/perl5/t/lib/glob-basic.t +++ b/contrib/perl5/t/lib/glob-basic.t @@ -2,7 +2,12 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + if ($^O eq 'MacOS') { + @INC = qw(: ::lib ::macos:lib); + } else { + @INC = '.'; + push @INC, '../lib'; + } require Config; import Config; if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) { print "1..0\n"; @@ -26,8 +31,8 @@ sub array { $ENV{PATH} = "/bin"; delete @ENV{BASH_ENV, CDPATH, ENV, IFS}; @correct = (); -if (opendir(D, ".")) { - @correct = grep { !/^\.\.?$/ } sort readdir(D); +if (opendir(D, $^O eq "MacOS" ? ":" : ".")) { + @correct = grep { !/^\./ } sort readdir(D); closedir D; } @a = File::Glob::glob("*", 0); @@ -39,12 +44,12 @@ print "ok 2\n"; # look up the user's home directory # should return a list with one item, and not set ERROR -if ($^O ne 'MSWin32' || $^O ne 'VMS') { +if ($^O ne 'MSWin32' && $^O ne 'VMS') { eval { ($name, $home) = (getpwuid($>))[0,7]; 1; } and do { - @a = File::Glob::glob("~$name", GLOB_TILDE); + @a = bsd_glob("~$name", GLOB_TILDE); if (scalar(@a) != 1 || $a[0] ne $home || GLOB_ERROR) { print "not "; } @@ -54,7 +59,7 @@ print "ok 3\n"; # check backslashing # should return a list with one item, and not set ERROR -@a = File::Glob::glob('TEST', GLOB_QUOTE); +@a = bsd_glob('TEST', GLOB_QUOTE); if (scalar @a != 1 || $a[0] ne 'TEST' || GLOB_ERROR) { local $/ = "]["; print "# [@a]\n"; @@ -65,7 +70,7 @@ print "ok 4\n"; # check nonexistent checks # should return an empty list # XXX since errfunc is NULL on win32, this test is not valid there -@a = File::Glob::glob("asdfasdf", 0); +@a = bsd_glob("asdfasdf", 0); if ($^O ne 'MSWin32' and scalar @a != 0) { print "# |@a|\nnot "; } @@ -81,7 +86,7 @@ if ($^O eq 'mpeix' or $^O eq 'MSWin32' or $^O eq 'os2' or $^O eq 'VMS' else { $dir = "PtEeRsLt.dir"; mkdir $dir, 0; - @a = File::Glob::glob("$dir/*", GLOB_ERR); + @a = bsd_glob("$dir/*", GLOB_ERR); #print "\@a = ", array(@a); rmdir $dir; if (scalar(@a) != 0 || GLOB_ERROR == 0) { @@ -91,16 +96,21 @@ else { } # check for csh style globbing -@a = File::Glob::glob('{a,b}', GLOB_BRACE | GLOB_NOMAGIC); +@a = bsd_glob('{a,b}', GLOB_BRACE | GLOB_NOMAGIC); unless (@a == 2 and $a[0] eq 'a' and $a[1] eq 'b') { print "not "; } print "ok 7\n"; -@a = File::Glob::glob( +@a = bsd_glob( '{TES*,doesntexist*,a,b}', - GLOB_BRACE | GLOB_NOMAGIC + GLOB_BRACE | GLOB_NOMAGIC | ($^O eq 'VMS' ? GLOB_NOCASE : 0) ); + +# Working on t/TEST often causes this test to fail because it sees temp +# and RCS files. Filter them out, and .pm files too. +@a = grep !/(,v$|~$|\.pm$)/, @a; + unless (@a == 3 and $a[0] eq ($^O eq 'VMS'? 'test.' : 'TEST') and $a[1] eq 'a' @@ -112,8 +122,8 @@ print "ok 8\n"; # "~" should expand to $ENV{HOME} $ENV{HOME} = "sweet home"; -@a = File::Glob::glob('~', GLOB_TILDE | GLOB_NOMAGIC); -unless (@a == 1 and $a[0] eq $ENV{HOME}) { +@a = bsd_glob('~', GLOB_TILDE | GLOB_NOMAGIC); +unless ($^O eq "MacOS" || (@a == 1 and $a[0] eq $ENV{HOME})) { print "not "; } print "ok 9\n"; diff --git a/contrib/perl5/t/lib/glob-case.t b/contrib/perl5/t/lib/glob-case.t index 32719b2..881470c 100755 --- a/contrib/perl5/t/lib/glob-case.t +++ b/contrib/perl5/t/lib/glob-case.t @@ -2,7 +2,12 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + if ($^O eq 'MacOS') { + @INC = qw(: ::lib ::macos:lib); + } else { + @INC = '.'; + push @INC, '../lib'; + } require Config; import Config; if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) { print "1..0\n"; @@ -17,20 +22,22 @@ use File::Glob qw(:glob csh_glob); $loaded = 1; print "ok 1\n"; +my $pat = $^O eq "MacOS" ? ":lib:G*.t" : "lib/G*.t"; + # Test the actual use of the case sensitivity tags, via csh_glob() import File::Glob ':nocase'; -@a = csh_glob("lib/G*.t"); # At least glob-basic.t glob-case.t glob-global.t +@a = csh_glob($pat); # At least glob-basic.t glob-case.t glob-global.t print "not " unless @a >= 3; print "ok 2\n"; # This may fail on systems which are not case-PRESERVING import File::Glob ':case'; -@a = csh_glob("lib/G*.t"); # None should be uppercase +@a = csh_glob($pat); # None should be uppercase print "not " unless @a == 0; print "ok 3\n"; # Test the explicit use of the GLOB_NOCASE flag -@a = File::Glob::glob("lib/G*.t", GLOB_NOCASE); +@a = bsd_glob($pat, GLOB_NOCASE); print "not " unless @a >= 3; print "ok 4\n"; @@ -47,7 +54,7 @@ else { rmdir "[]"; print "# returned @a\nnot " unless @a == 1; print "ok 6\n"; - @a = File::Glob::glob("lib\\*", GLOB_QUOTE); + @a = bsd_glob("lib\\*", GLOB_QUOTE); print "not " if @a == 0; print "ok 7\n"; } diff --git a/contrib/perl5/t/lib/glob-global.t b/contrib/perl5/t/lib/glob-global.t index 9d273bd..1d79032 100755 --- a/contrib/perl5/t/lib/glob-global.t +++ b/contrib/perl5/t/lib/glob-global.t @@ -2,7 +2,12 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + if ($^O eq 'MacOS') { + @INC = qw(: ::lib ::macos:lib); + } else { + @INC = '.'; + push @INC, '../lib'; + } require Config; import Config; if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) { print "1..0\n"; @@ -31,9 +36,9 @@ use File::Glob ':globally'; $loaded = 1; print "ok 1\n"; -$_ = "lib/*.t"; +$_ = $^O eq "MacOS" ? ":lib:*.t" : "lib/*.t"; my @r = glob; -print "not " if $_ ne 'lib/*.t'; +print "not " if $_ ne ($^O eq "MacOS" ? ":lib:*.t" : "lib/*.t"); print "ok 2\n"; # we should have at least basic.t, global.t, taint.t @@ -41,7 +46,11 @@ print "# |@r|\nnot " if @r < 3; print "ok 3\n"; # check if <*/*> works -@r = <*/*.t>; +if ($^O eq "MacOS") { + @r = <:*:*.t>; +} else { + @r = <*/*.t>; +} # at least t/global.t t/basic.t, t/taint.t print "not " if @r < 3; print "ok 4\n"; @@ -49,34 +58,55 @@ my $r = scalar @r; # check if scalar context works @r = (); -while (defined($_ = <*/*.t>)) { - #print "# $_\n"; - push @r, $_; +if ($^O eq "MacOS") { + while (defined($_ = <:*:*.t>)) { + #print "# $_\n"; + push @r, $_; + } +} else { + while (defined($_ = <*/*.t>)) { + #print "# $_\n"; + push @r, $_; + } } print "not " if @r != $r; print "ok 5\n"; -# check if array context works +# check if list context works @r = (); -for (<*/*.t>) { - #print "# $_\n"; - push @r, $_; +if ($^O eq "MacOS") { + for (<:*:*.t>) { + #print "# $_\n"; + push @r, $_; + } +} else { + for (<*/*.t>) { + #print "# $_\n"; + push @r, $_; + } } print "not " if @r != $r; print "ok 6\n"; # test if implicit assign to $_ in while() works @r = (); -while (<*/*.t>) { - #print "# $_\n"; - push @r, $_; +if ($^O eq "MacOS") { + while (<:*:*.t>) { + #print "# $_\n"; + push @r, $_; + } +} else { + while (<*/*.t>) { + #print "# $_\n"; + push @r, $_; + } } print "not " if @r != $r; print "ok 7\n"; # test if explicit glob() gets assign magic too my @s = (); -while (glob '*/*.t') { +while (glob($^O eq 'MacOS' ? ':*:*.t' : '*/*.t')) { #print "# $_\n"; push @s, $_; } @@ -87,7 +117,7 @@ print "ok 8\n"; package Foo; use File::Glob ':globally'; @s = (); -while (glob '*/*.t') { +while (glob($^O eq 'MacOS' ? ':*:*.t' : '*/*.t')) { #print "# $_\n"; push @s, $_; } @@ -97,14 +127,26 @@ print "ok 9\n"; # test if different glob ops maintain independent contexts @s = (); my $i = 0; -while (<*/*.t>) { - #print "# $_ <"; - push @s, $_; - while (<bas*/*.t>) { - #print " $_"; - $i++; +if ($^O eq "MacOS") { + while (<:*:*.t>) { + #print "# $_ <"; + push @s, $_; + while (<:bas*:*.t>) { + #print " $_"; + $i++; + } + #print " >\n"; + } +} else { + while (<*/*.t>) { + #print "# $_ <"; + push @s, $_; + while (<bas*/*.t>) { + #print " $_"; + $i++; + } + #print " >\n"; } - #print " >\n"; } print "not " if "@r" ne "@s" or not $i; print "ok 10\n"; diff --git a/contrib/perl5/t/lib/glob-taint.t b/contrib/perl5/t/lib/glob-taint.t index a8dc213..4c09903 100755 --- a/contrib/perl5/t/lib/glob-taint.t +++ b/contrib/perl5/t/lib/glob-taint.t @@ -2,7 +2,12 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + if ($^O eq 'MacOS') { + @INC = qw(: ::lib ::macos:lib); + } else { + @INC = '.'; + push @INC, '../lib'; + } require Config; import Config; if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) { print "1..0\n"; @@ -18,7 +23,7 @@ $loaded = 1; print "ok 1\n"; # all filenames should be tainted -@a = File::Glob::glob("*"); +@a = File::Glob::bsd_glob("*"); eval { $a = join("",@a), kill 0; 1 }; unless ($@ =~ /Insecure dependency/) { print "not "; diff --git a/contrib/perl5/t/lib/gol-basic.t b/contrib/perl5/t/lib/gol-basic.t index 4b25322..c5d857d 100755 --- a/contrib/perl5/t/lib/gol-basic.t +++ b/contrib/perl5/t/lib/gol-basic.t @@ -1,16 +1,18 @@ #!./perl -w BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib'; + chdir('t') if -d 't'; + @INC = '../lib'; } -use Getopt::Long 2.17; +use Getopt::Long qw(:config no_ignore_case); +die("Getopt::Long version 2.24 required--this is only version ". + $Getopt::Long::VERSION) + unless $Getopt::Long::VERSION >= 2.24; print "1..9\n"; @ARGV = qw(-Foo -baR --foo bar); -Getopt::Long::Configure ("no_ignore_case"); undef $opt_baR; undef $opt_bar; print "ok 1\n" if GetOptions ("foo", "Foo=s"); diff --git a/contrib/perl5/t/lib/gol-compat.t b/contrib/perl5/t/lib/gol-compat.t index a4f807c..0bbe386 100755 --- a/contrib/perl5/t/lib/gol-compat.t +++ b/contrib/perl5/t/lib/gol-compat.t @@ -1,8 +1,8 @@ #!./perl -w BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib'; + chdir('t') if -d 't'; + @INC = '../lib'; } require "newgetopt.pl"; diff --git a/contrib/perl5/t/lib/gol-linkage.t b/contrib/perl5/t/lib/gol-linkage.t index a1b2c05..3bd81a3 100755 --- a/contrib/perl5/t/lib/gol-linkage.t +++ b/contrib/perl5/t/lib/gol-linkage.t @@ -1,8 +1,8 @@ #!./perl -w BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib'; + chdir('t') if -d 't'; + @INC = '../lib'; } use Getopt::Long; diff --git a/contrib/perl5/t/lib/h2ph.t b/contrib/perl5/t/lib/h2ph.t index acb150d..15dc2b5 100755 --- a/contrib/perl5/t/lib/h2ph.t +++ b/contrib/perl5/t/lib/h2ph.t @@ -5,7 +5,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..2\n"; diff --git a/contrib/perl5/t/lib/hostname.t b/contrib/perl5/t/lib/hostname.t index 6f61fb9..85a04cd 100755 --- a/contrib/perl5/t/lib/hostname.t +++ b/contrib/perl5/t/lib/hostname.t @@ -2,7 +2,12 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bSys\/Hostname\b/) { + print "1..0 # Skip: Sys::Hostname was not built\n"; + exit 0; + } } use Sys::Hostname; diff --git a/contrib/perl5/t/lib/io_const.t b/contrib/perl5/t/lib/io_const.t index 48cb6b5..db1a322 100755 --- a/contrib/perl5/t/lib/io_const.t +++ b/contrib/perl5/t/lib/io_const.t @@ -2,7 +2,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } diff --git a/contrib/perl5/t/lib/io_dir.t b/contrib/perl5/t/lib/io_dir.t index 11ec8bc..3689871 100755 --- a/contrib/perl5/t/lib/io_dir.t +++ b/contrib/perl5/t/lib/io_dir.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } require Config; import Config; if ($] < 5.00326 || not $Config{'d_readdir'}) { diff --git a/contrib/perl5/t/lib/io_dup.t b/contrib/perl5/t/lib/io_dup.t index c895fb4..0f17264 100755 --- a/contrib/perl5/t/lib/io_dup.t +++ b/contrib/perl5/t/lib/io_dup.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } diff --git a/contrib/perl5/t/lib/io_linenum.t b/contrib/perl5/t/lib/io_linenum.t index 3503215..cf55c98 100755 --- a/contrib/perl5/t/lib/io_linenum.t +++ b/contrib/perl5/t/lib/io_linenum.t @@ -13,7 +13,7 @@ BEGIN chdir 't'; $File =~ s/^t\W+//; # Remove first directory } - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; require strict; import strict; } diff --git a/contrib/perl5/t/lib/io_multihomed.t b/contrib/perl5/t/lib/io_multihomed.t index 7337a5f..55030b5 100755 --- a/contrib/perl5/t/lib/io_multihomed.t +++ b/contrib/perl5/t/lib/io_multihomed.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } diff --git a/contrib/perl5/t/lib/io_pipe.t b/contrib/perl5/t/lib/io_pipe.t index bcb89a0..ae18224 100755 --- a/contrib/perl5/t/lib/io_pipe.t +++ b/contrib/perl5/t/lib/io_pipe.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } diff --git a/contrib/perl5/t/lib/io_poll.t b/contrib/perl5/t/lib/io_poll.t index 68ad7b7..d391566 100755 --- a/contrib/perl5/t/lib/io_poll.t +++ b/contrib/perl5/t/lib/io_poll.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } @@ -15,7 +15,7 @@ if ($^O eq 'mpeix') { select(STDERR); $| = 1; select(STDOUT); $| = 1; -print "1..8\n"; +print "1..9\n"; use IO::Handle; use IO::Poll qw(/POLL/); @@ -75,3 +75,8 @@ $poll->poll(0.1); print "not " if $poll->events($stdout); print "ok 8\n"; + +$poll->remove($dupout); +print "not " + if $poll->handles; +print "ok 9\n"; diff --git a/contrib/perl5/t/lib/io_sel.t b/contrib/perl5/t/lib/io_sel.t index 85e14ab..5d1dce3 100755 --- a/contrib/perl5/t/lib/io_sel.t +++ b/contrib/perl5/t/lib/io_sel.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } diff --git a/contrib/perl5/t/lib/io_sock.t b/contrib/perl5/t/lib/io_sock.t index 056d131f..45c16c2 100755 --- a/contrib/perl5/t/lib/io_sock.t +++ b/contrib/perl5/t/lib/io_sock.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } @@ -70,17 +70,15 @@ if($pid = fork()) { } elsif(defined $pid) { - # This can fail if localhost is undefined or the - # special 'loopback' address 127.0.0.1 is not configured - # on your system. (/etc/rc.config.d/netconfig on HP-UX.) - # As a shortcut (not recommended) you could change 'localhost' - # here to be the name of this machine eg 'myhost.mycompany.com'. - $sock = IO::Socket::INET->new(PeerPort => $port, Proto => 'tcp', PeerAddr => 'localhost' ) - or die "$! (maybe your system does not have the 'localhost' address defined)"; + || IO::Socket::INET->new(PeerPort => $port, + Proto => 'tcp', + PeerAddr => '127.0.0.1' + ) + or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)"; $sock->autoflush(1); @@ -114,7 +112,8 @@ if($pid = fork()) { $listen->close; } elsif (defined $pid) { # child, try various ways to connect - $sock = IO::Socket::INET->new("localhost:$port"); + $sock = IO::Socket::INET->new("localhost:$port") + || IO::Socket::INET->new("127.0.0.1:$port"); if ($sock) { print "not " unless $sock->connected; print "ok 6\n"; @@ -151,7 +150,9 @@ if($pid = fork()) { sleep(1); $sock = IO::Socket->new(Domain => AF_INET, - PeerAddr => "localhost:$port"); + PeerAddr => "localhost:$port") + || IO::Socket->new(Domain => AF_INET, + PeerAddr => "127.0.0.1:$port"); if ($sock) { $sock->print("ok 11\n"); $sock->print("quit\n"); @@ -166,7 +167,10 @@ if($pid = fork()) { # Then test UDP sockets $server = IO::Socket->new(Domain => AF_INET, Proto => 'udp', - LocalAddr => 'localhost'); + LocalAddr => 'localhost') + || IO::Socket->new(Domain => AF_INET, + Proto => 'udp', + LocalAddr => '127.0.0.1'); $port = $server->sockport; if ($^O eq 'mpeix') { @@ -179,7 +183,9 @@ if ($^O eq 'mpeix') { } elsif (defined($pid)) { #child $sock = IO::Socket::INET->new(Proto => 'udp', - PeerAddr => "localhost:$port"); + PeerAddr => "localhost:$port") + || IO::Socket::INET->new(Proto => 'udp', + PeerAddr => "127.0.0.1:$port"); $sock->send("ok 12\n"); sleep(1); $sock->send("ok 12\n"); # send another one to be sure diff --git a/contrib/perl5/t/lib/io_taint.t b/contrib/perl5/t/lib/io_taint.t index deaa6c7..19afa2f 100755 --- a/contrib/perl5/t/lib/io_taint.t +++ b/contrib/perl5/t/lib/io_taint.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } diff --git a/contrib/perl5/t/lib/io_tell.t b/contrib/perl5/t/lib/io_tell.t index 8d75242..3aa4b03 100755 --- a/contrib/perl5/t/lib/io_tell.t +++ b/contrib/perl5/t/lib/io_tell.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; $tell_file = "TEST"; } else { diff --git a/contrib/perl5/t/lib/io_udp.t b/contrib/perl5/t/lib/io_udp.t index 3d5145e..d63a5dc 100755 --- a/contrib/perl5/t/lib/io_udp.t +++ b/contrib/perl5/t/lib/io_udp.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } @@ -57,19 +57,15 @@ print "1..7\n"; use Socket; use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY); - # This can fail if localhost is undefined or the - # special 'loopback' address 127.0.0.1 is not configured - # on your system. (/etc/rc.config.d/netconfig on HP-UX.) - # As a shortcut (not recommended) you could change 'localhost' - # here to be the name of this machine eg 'myhost.mycompany.com'. - $udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost') - or die "$! (maybe your system does not have the 'localhost' address defined)"; + || IO::Socket::INET->new(Proto => 'udp', LocalAddr => '127.0.0.1') + or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)"; print "ok 1\n"; $udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost') - or die "$! (maybe your system does not have the 'localhost' address defined)"; + || IO::Socket::INET->new(Proto => 'udp', LocalAddr => '127.0.0.1') + or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)"; print "ok 2\n"; diff --git a/contrib/perl5/t/lib/io_unix.t b/contrib/perl5/t/lib/io_unix.t index 247647a..2f6def0 100755 --- a/contrib/perl5/t/lib/io_unix.t +++ b/contrib/perl5/t/lib/io_unix.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } diff --git a/contrib/perl5/t/lib/io_xs.t b/contrib/perl5/t/lib/io_xs.t index 6bbba16..2449fc4 100755 --- a/contrib/perl5/t/lib/io_xs.t +++ b/contrib/perl5/t/lib/io_xs.t @@ -3,7 +3,7 @@ BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } } @@ -40,3 +40,4 @@ print scalar <$x>; $! = 0; $x->setpos(undef); print $! ? "ok 4 # $!\n" : "not ok 4\n"; + diff --git a/contrib/perl5/t/lib/ipc_sysv.t b/contrib/perl5/t/lib/ipc_sysv.t index a4f3e3f..795ad5d 100755 --- a/contrib/perl5/t/lib/ipc_sysv.t +++ b/contrib/perl5/t/lib/ipc_sysv.t @@ -3,13 +3,15 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; my $reason; - if ($Config{'d_sem'} ne 'define') { + if ($Config{'extensions'} !~ /\bIPC\/SysV\b/) { + $reason = 'IPC::SysV was not built'; + } elsif ($Config{'d_sem'} ne 'define') { $reason = '$Config{d_sem} undefined'; } elsif ($Config{'d_msg'} ne 'define') { $reason = '$Config{d_msg} undefined'; diff --git a/contrib/perl5/t/lib/ndbm.t b/contrib/perl5/t/lib/ndbm.t index 39c3f40..e56fcd9 100755 --- a/contrib/perl5/t/lib/ndbm.t +++ b/contrib/perl5/t/lib/ndbm.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bNDBM_File\b/) { print "1..0 # Skip: NDBM_File was not built\n"; @@ -12,18 +12,31 @@ BEGIN { } } +use strict; +use warnings; + +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; +} + require NDBM_File; #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT use Fcntl; -print "1..64\n"; +print "1..65\n"; unlink <Op.dbmx*>; umask(0); -print (tie(%h,NDBM_File,'Op.dbmx', O_RDWR|O_CREAT, 0640) ? "ok 1\n" : "not ok 1\n"); +my %h; +ok(1, tie(%h,'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)); -$Dfile = "Op.dbmx.pag"; +my $Dfile = "Op.dbmx.pag"; if (! -e $Dfile) { ($Dfile) = <Op.dbmx*>; } @@ -31,11 +44,12 @@ if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32') { print "ok 2 # Skipped: different file permission semantics\n"; } else { - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); } -while (($key,$value) = each(%h)) { +my $i = 0; +while (my ($key,$value) = each(%h)) { $i++; } print (!$i ? "ok 3\n" : "not ok 3\n"); @@ -60,7 +74,7 @@ $h{'goner2'} = 'snork'; delete $h{'goner2'}; untie(%h); -print (tie(%h,NDBM_File,'Op.dbmx', &O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); +print (tie(%h,'NDBM_File','Op.dbmx', &O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); $h{'j'} = 'J'; $h{'k'} = 'K'; @@ -85,12 +99,12 @@ $h{'goner3'} = 'snork'; delete $h{'goner1'}; delete $h{'goner3'}; -@keys = keys(%h); -@values = values(%h); +my @keys = keys(%h); +my @values = values(%h); if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} -while (($key,$value) = each(%h)) { +while (my ($key,$value) = each(%h)) { if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { $key =~ y/a-z/A-Z/; $i++ if $key eq $value; @@ -106,17 +120,17 @@ $h{'foo'} = ''; $h{''} = 'bar'; # check cache overflow and numeric keys and contents -$ok = 1; +my $ok = 1; for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } print ($ok ? "ok 8\n" : "not ok 8\n"); -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, +my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); print ($size > 0 ? "ok 9\n" : "not ok 9\n"); @h{0..200} = 200..400; -@foo = @h{0..200}; +my @foo = @h{0..200}; print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); @@ -125,21 +139,13 @@ print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); untie %h; unlink 'Op.dbmx.dir', $Dfile; -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - { # sub-class test package Another ; use strict ; + use warnings ; open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; print FILE <<'EOM' ; @@ -147,6 +153,7 @@ sub ok package SubDB ; use strict ; + use warnings ; use vars qw(@ISA @EXPORT) ; require Exporter ; @@ -209,6 +216,7 @@ EOM { # DBM Filter tests use strict ; + use warnings ; my (%h, $db) ; my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; @@ -315,6 +323,7 @@ EOM # DBM Filter with a closure use strict ; + use warnings ; my (%h, $db) ; unlink <Op.dbmx*>; @@ -359,7 +368,7 @@ EOM ok(52, $result{"store key"} eq "store key - 2: [fred jim]"); ok(53, $result{"store value"} eq "store value - 2: [joe john]"); ok(54, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(55, $result{"fetch value"} eq ""); + ok(55, ! defined $result{"fetch value"} ); ok(56, $_ eq "original") ; ok(57, $h{"fred"} eq "joe"); @@ -377,6 +386,7 @@ EOM { # DBM Filter recursion detection use strict ; + use warnings ; my (%h, $db) ; unlink <Op.dbmx*>; @@ -391,3 +401,20 @@ EOM untie %h; unlink <Op.dbmx*>; } + +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use NDBM_File ; + + unlink <Op.dbmx*>; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + ok(65, tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ; +} diff --git a/contrib/perl5/t/lib/odbm.t b/contrib/perl5/t/lib/odbm.t index f8b8a11..b935d04 100755 --- a/contrib/perl5/t/lib/odbm.t +++ b/contrib/perl5/t/lib/odbm.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bODBM_File\b/) { print "1..0 # Skip: ODBM_File was not built\n"; @@ -12,18 +12,31 @@ BEGIN { } } +use strict; +use warnings; + +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; +} + require ODBM_File; #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT use Fcntl; -print "1..64\n"; +print "1..66\n"; unlink <Op.dbmx*>; umask(0); -print (tie(%h,ODBM_File,'Op.dbmx', O_RDWR|O_CREAT, 0640) ? "ok 1\n" : "not ok 1\n"); +my %h; +ok(1, tie(%h,'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)); -$Dfile = "Op.dbmx.pag"; +my $Dfile = "Op.dbmx.pag"; if (! -e $Dfile) { ($Dfile) = <Op.dbmx*>; } @@ -31,11 +44,12 @@ if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32') { print "ok 2 # Skipped: different file permission semantics\n"; } else { - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); } -while (($key,$value) = each(%h)) { +my $i = 0; +while (my ($key,$value) = each(%h)) { $i++; } print (!$i ? "ok 3\n" : "not ok 3\n"); @@ -60,7 +74,7 @@ $h{'goner2'} = 'snork'; delete $h{'goner2'}; untie(%h); -print (tie(%h,ODBM_File,'Op.dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); +print (tie(%h,'ODBM_File','Op.dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); $h{'j'} = 'J'; $h{'k'} = 'K'; @@ -85,12 +99,12 @@ $h{'goner3'} = 'snork'; delete $h{'goner1'}; delete $h{'goner3'}; -@keys = keys(%h); -@values = values(%h); +my @keys = keys(%h); +my @values = values(%h); if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} -while (($key,$value) = each(%h)) { +while (my ($key,$value) = each(%h)) { if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { $key =~ y/a-z/A-Z/; $i++ if $key eq $value; @@ -106,17 +120,17 @@ $h{'foo'} = ''; $h{''} = 'bar'; # check cache overflow and numeric keys and contents -$ok = 1; +my $ok = 1; for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } print ($ok ? "ok 8\n" : "not ok 8\n"); -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, +my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); print ($size > 0 ? "ok 9\n" : "not ok 9\n"); @h{0..200} = 200..400; -@foo = @h{0..200}; +my @foo = @h{0..200}; print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); @@ -125,21 +139,13 @@ print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); untie %h; unlink 'Op.dbmx.dir', $Dfile; -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - { # sub-class test package Another ; use strict ; + use warnings ; open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; print FILE <<'EOM' ; @@ -147,6 +153,7 @@ sub ok package SubDB ; use strict ; + use warnings ; use vars qw(@ISA @EXPORT) ; require Exporter ; @@ -209,6 +216,7 @@ EOM { # DBM Filter tests use strict ; + use warnings ; my (%h, $db) ; my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; @@ -317,6 +325,7 @@ EOM # DBM Filter with a closure use strict ; + use warnings ; my (%h, $db) ; unlink <Op.dbmx*>; @@ -361,7 +370,7 @@ EOM ok(52, $result{"store key"} eq "store key - 2: [fred jim]"); ok(53, $result{"store value"} eq "store value - 2: [joe john]"); ok(54, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(55, $result{"fetch value"} eq ""); + ok(55, ! defined $result{"fetch value"} ); ok(56, $_ eq "original") ; ok(57, $h{"fred"} eq "joe"); @@ -379,6 +388,7 @@ EOM { # DBM Filter recursion detection use strict ; + use warnings ; my (%h, $db) ; unlink <Op.dbmx*>; @@ -394,6 +404,27 @@ EOM unlink <Op.dbmx*>; } +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use ODBM_File ; + + unlink <Op.dbmx*>; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + ok(65, tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ; + $h{ABC} = undef; + ok(66, $a eq "") ; + untie %h; + unlink <Op.dbmx*>; +} + if ($^O eq 'hpux') { print <<EOM; # diff --git a/contrib/perl5/t/lib/opcode.t b/contrib/perl5/t/lib/opcode.t index f83a689..a785fce 100755 --- a/contrib/perl5/t/lib/opcode.t +++ b/contrib/perl5/t/lib/opcode.t @@ -4,7 +4,7 @@ $|=1; BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { print "1..0\n"; diff --git a/contrib/perl5/t/lib/open2.t b/contrib/perl5/t/lib/open2.t index 6443112..85b807c 100755 --- a/contrib/perl5/t/lib/open2.t +++ b/contrib/perl5/t/lib/open2.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if (!$Config{'d_fork'} # open2/3 supported on win32 (but not Borland due to CRT bugs) diff --git a/contrib/perl5/t/lib/open3.t b/contrib/perl5/t/lib/open3.t index 7cd0ca3..a0da34f 100755 --- a/contrib/perl5/t/lib/open3.t +++ b/contrib/perl5/t/lib/open3.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if (!$Config{'d_fork'} # open2/3 supported on win32 (but not Borland due to CRT bugs) @@ -20,7 +20,7 @@ use IO::Handle; use IPC::Open3; #require 'open3.pl'; use subs 'open3'; -my $perl = './perl'; +my $perl = $^X; sub ok { my ($n, $result, $info) = @_; diff --git a/contrib/perl5/t/lib/ops.t b/contrib/perl5/t/lib/ops.t index ce8b6d0..56b1bac 100755 --- a/contrib/perl5/t/lib/ops.t +++ b/contrib/perl5/t/lib/ops.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { print "1..0\n"; diff --git a/contrib/perl5/t/lib/parsewords.t b/contrib/perl5/t/lib/parsewords.t index 2c936f1..261d81f 100755 --- a/contrib/perl5/t/lib/parsewords.t +++ b/contrib/perl5/t/lib/parsewords.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use warnings; diff --git a/contrib/perl5/t/lib/ph.t b/contrib/perl5/t/lib/ph.t index dd24c79..de27dee 100755 --- a/contrib/perl5/t/lib/ph.t +++ b/contrib/perl5/t/lib/ph.t @@ -6,7 +6,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } # All the constants which Socket.pm tries to make available: diff --git a/contrib/perl5/t/lib/posix.t b/contrib/perl5/t/lib/posix.t index abc4563..994704a 100755 --- a/contrib/perl5/t/lib/posix.t +++ b/contrib/perl5/t/lib/posix.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if ($^O ne 'VMS' and $Config{'extensions'} !~ /\bPOSIX\b/) { print "1..0\n"; @@ -17,6 +17,7 @@ $| = 1; print "1..27\n"; $Is_W32 = $^O eq 'MSWin32'; +$Is_Dos = $^O eq 'dos'; $testfd = open("TEST", O_RDONLY, 0) and print "ok 1\n"; read($testfd, $buffer, 9) if $testfd > 2; @@ -24,6 +25,11 @@ print $buffer eq "#!./perl\n" ? "ok 2\n" : "not ok 2\n"; write(1,"ok 3\nnot ok 3\n", 5); +if ($Is_Dos) { + for (4..5) { + print "ok $_ # skipped, no pipe() support on dos\n"; + } +} else { @fds = POSIX::pipe(); print $fds[0] > $testfd ? "ok 4\n" : "not ok 4\n"; CORE::open($reader = \*READER, "<&=".$fds[0]); @@ -32,10 +38,11 @@ print $writer "ok 5\n"; close $writer; print <$reader>; close $reader; +} -if ($Is_W32) { +if ($Is_W32 || $Is_Dos) { for (6..11) { - print "ok $_ # skipped, no sigaction support on win32\n"; + print "ok $_ # skipped, no sigaction support on win32/dos\n"; } } else { diff --git a/contrib/perl5/t/lib/safe1.t b/contrib/perl5/t/lib/safe1.t index 6e12873..27993d9 100755 --- a/contrib/perl5/t/lib/safe1.t +++ b/contrib/perl5/t/lib/safe1.t @@ -2,7 +2,7 @@ $|=1; BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { print "1..0\n"; diff --git a/contrib/perl5/t/lib/safe2.t b/contrib/perl5/t/lib/safe2.t index 293b515..4d6c84a 100755 --- a/contrib/perl5/t/lib/safe2.t +++ b/contrib/perl5/t/lib/safe2.t @@ -2,7 +2,7 @@ $|=1; BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { print "1..0\n"; diff --git a/contrib/perl5/t/lib/sdbm.t b/contrib/perl5/t/lib/sdbm.t index 2689d19..3221ca4 100755 --- a/contrib/perl5/t/lib/sdbm.t +++ b/contrib/perl5/t/lib/sdbm.t @@ -4,26 +4,39 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if (($Config{'extensions'} !~ /\bSDBM_File\b/) && ($^O ne 'VMS')){ print "1..0\n"; exit 0; } } + +use strict; +use warnings; + +sub ok +{ + my $no = shift ; + my $result = shift ; + + print "not " unless $result ; + print "ok $no\n" ; +} + require SDBM_File; #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT use Fcntl; -print "1..66\n"; +print "1..68\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"); +my %h ; +ok(1, tie %h,'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640); -$Dfile = "Op_dbmx.pag"; +my $Dfile = "Op_dbmx.pag"; if (! -e $Dfile) { ($Dfile) = <Op_dbmx.*>; } @@ -31,11 +44,12 @@ 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, + my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); } -while (($key,$value) = each(%h)) { +my $i = 0; +while (my ($key,$value) = each(%h)) { $i++; } print (!$i ? "ok 3\n" : "not ok 3\n"); @@ -60,7 +74,7 @@ $h{'goner2'} = 'snork'; delete $h{'goner2'}; untie(%h); -print (tie(%h,SDBM_File,'Op_dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); +print (tie(%h,'SDBM_File','Op_dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); $h{'j'} = 'J'; $h{'k'} = 'K'; @@ -85,12 +99,12 @@ $h{'goner3'} = 'snork'; delete $h{'goner1'}; delete $h{'goner3'}; -@keys = keys(%h); -@values = values(%h); +my @keys = keys(%h); +my @values = values(%h); if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} -while (($key,$value) = each(%h)) { +while (my ($key,$value) = each(%h)) { if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { $key =~ y/a-z/A-Z/; $i++ if $key eq $value; @@ -106,38 +120,30 @@ $h{'foo'} = ''; $h{''} = 'bar'; # check cache overflow and numeric keys and contents -$ok = 1; +my $ok = 1; for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } print ($ok ? "ok 8\n" : "not ok 8\n"); -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, +my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat($Dfile); print ($size > 0 ? "ok 9\n" : "not ok 9\n"); @h{0..200} = 200..400; -@foo = @h{0..200}; +my @foo = @h{0..200}; print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - { # sub-class test package Another ; use strict ; + use warnings ; open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; print FILE <<'EOM' ; @@ -145,6 +151,7 @@ sub ok package SubDB ; use strict ; + use warnings ; use vars qw( @ISA @EXPORT) ; require Exporter ; @@ -213,6 +220,7 @@ unlink <Op_dbmx*>, $Dfile; { # DBM Filter tests use strict ; + use warnings ; my (%h, $db) ; my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; @@ -319,6 +327,7 @@ unlink <Op_dbmx*>, $Dfile; # DBM Filter with a closure use strict ; + use warnings ; my (%h, $db) ; unlink <Op_dbmx*>; @@ -363,7 +372,7 @@ unlink <Op_dbmx*>, $Dfile; ok(54, $result{"store key"} eq "store key - 2: [fred jim]"); ok(55, $result{"store value"} eq "store value - 2: [joe john]"); ok(56, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(57, $result{"fetch value"} eq ""); + ok(57, ! defined $result{"fetch value"} ); ok(58, $_ eq "original") ; ok(59, $h{"fred"} eq "joe"); @@ -381,6 +390,7 @@ unlink <Op_dbmx*>, $Dfile; { # DBM Filter recursion detection use strict ; + use warnings ; my (%h, $db) ; unlink <Op_dbmx*>; @@ -396,3 +406,24 @@ unlink <Op_dbmx*>, $Dfile; unlink <Op_dbmx*>; } +{ + # Bug ID 20001013.009 + # + # test that $hash{KEY} = undef doesn't produce the warning + # Use of uninitialized value in null operation + use warnings ; + use strict ; + use SDBM_File ; + + unlink <Op_dbmx*>; + my %h ; + my $a = ""; + local $SIG{__WARN__} = sub {$a = $_[0]} ; + + ok(67, tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ; + $h{ABC} = undef; + ok(68, $a eq "") ; + + untie %h; + unlink <Op_dbmx*>; +} diff --git a/contrib/perl5/t/lib/searchdict.t b/contrib/perl5/t/lib/searchdict.t index 46cea39..c36fdb8 100755 --- a/contrib/perl5/t/lib/searchdict.t +++ b/contrib/perl5/t/lib/searchdict.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..4\n"; diff --git a/contrib/perl5/t/lib/selectsaver.t b/contrib/perl5/t/lib/selectsaver.t index 677caec..3b58d70 100755 --- a/contrib/perl5/t/lib/selectsaver.t +++ b/contrib/perl5/t/lib/selectsaver.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..3\n"; diff --git a/contrib/perl5/t/lib/socket.t b/contrib/perl5/t/lib/socket.t index d5e1848..481fd8f 100755 --- a/contrib/perl5/t/lib/socket.t +++ b/contrib/perl5/t/lib/socket.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; require Config; import Config; if ($Config{'extensions'} !~ /\bSocket\b/ && !(($^O eq 'VMS') && $Config{d_socket})) { @@ -21,8 +21,8 @@ if (socket(T,PF_INET,SOCK_STREAM,6)) { if (connect(T,pack_sockaddr_in(7,inet_aton("localhost")))){ print "ok 2\n"; - print "# Connected to ", - inet_ntoa((unpack_sockaddr_in(getpeername(T)))[1]),"\n"; + print "# Connected to " . + inet_ntoa((unpack_sockaddr_in(getpeername(T)))[1])."\n"; syswrite(T,"hello",5); $read = sysread(T,$buff,10); # Connection may be granted, then closed! @@ -51,8 +51,8 @@ if( socket(S,PF_INET,SOCK_STREAM,6) ){ if (connect(S,pack_sockaddr_in(7,INADDR_LOOPBACK))){ print "ok 5\n"; - print "# Connected to ", - inet_ntoa((unpack_sockaddr_in(getpeername(S)))[1]),"\n"; + print "# Connected to " . + inet_ntoa((unpack_sockaddr_in(getpeername(S)))[1])."\n"; syswrite(S,"olleh",5); $read = sysread(S,$buff,10); # Connection may be granted, then closed! diff --git a/contrib/perl5/t/lib/soundex.t b/contrib/perl5/t/lib/soundex.t index a04cccd..d35f264 100755 --- a/contrib/perl5/t/lib/soundex.t +++ b/contrib/perl5/t/lib/soundex.t @@ -18,7 +18,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Text::Soundex; diff --git a/contrib/perl5/t/lib/symbol.t b/contrib/perl5/t/lib/symbol.t index 14c919c..03449a3 100755 --- a/contrib/perl5/t/lib/symbol.t +++ b/contrib/perl5/t/lib/symbol.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..8\n"; diff --git a/contrib/perl5/t/lib/syslfs.t b/contrib/perl5/t/lib/syslfs.t index 2857120..2bdb69d 100755 --- a/contrib/perl5/t/lib/syslfs.t +++ b/contrib/perl5/t/lib/syslfs.t @@ -4,16 +4,21 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; # Don't bother if there are no quad offsets. if ($Config{lseeksize} < 8) { - print "1..0\n# no 64-bit file offsets\n"; + print "1..0 # Skip: no 64-bit file offsets\n"; exit(0); } require Fcntl; import Fcntl qw(/^O_/ /^SEEK_/); } +use strict; + +our @s; +our $fail; + sub zap { close(BIG); unlink("big"); @@ -26,35 +31,42 @@ sub bye { exit(0); } +my $explained; + sub explain { - print <<EOM; + unless ($explained++) { + print <<EOM; # -# If the lfs (large file support: large meaning larger than two gigabytes) -# tests are skipped or fail, it may mean either that your process -# (or process group) is not allowed to write large files (resource -# limits) or that the file system you are running the tests on doesn't -# let your user/group have large files (quota) or the filesystem simply -# doesn't support large files. You may even need to reconfigure your kernel. -# (This is all very operating system and site-dependent.) +# If the lfs (large file support: large meaning larger than two +# gigabytes) tests are skipped or fail, it may mean either that your +# process (or process group) is not allowed to write large files +# (resource limits) or that the file system (the network filesystem?) +# you are running the tests on doesn't let your user/group have large +# files (quota) or the filesystem simply doesn't support large files. +# You may even need to reconfigure your kernel. (This is all very +# operating system and site-dependent.) # # Perl may still be able to support large files, once you have # such a process, enough quota, and such a (file) system. +# It is just that the test failed now. # EOM + } + print "1..0 # Skip: @_\n" if @_; } print "# checking whether we have sparse files...\n"; # Known have-nots. -if ($^O eq 'win32' || $^O eq 'vms') { - print "1..0\n# no sparse files (because this is $^O) \n"; +if ($^O eq 'MSWin32' || $^O eq 'VMS') { + print "1..0 # Skip: no sparse files in $^O\n"; bye(); } # Known haves that have problems running this test # (for example because they do not support sparse files, like UNICOS) if ($^O eq 'unicos') { - print "1..0\n# large files known to work but unable to test them here ($^O)\n"; + print "1..0 # Skip: no sparse files in $^0, unable to test large files\n"; bye(); } @@ -95,7 +107,7 @@ zap(); unless ($s1[7] == 1_000_003 && $s2[7] == 2_000_003 && $s1[11] == $s2[11] && $s1[12] == $s2[12]) { - print "1..0\n#no sparse files?\n"; + print "1..0 # Skip: no sparse files?\n"; bye; } @@ -103,16 +115,25 @@ print "# we seem to have sparse files...\n"; # By now we better be sure that we do have sparse files: # if we are not, the following will hog 5 gigabytes of disk. Ooops. +# This may fail by producing some signal; run in a subprocess first for safety $ENV{LC_ALL} = "C"; +my $r = system '../perl', '-I../lib', '-e', <<'EOF'; +use Fcntl qw(/^O_/ /^SEEK_/); +sysopen(BIG, "big", O_WRONLY|O_CREAT|O_TRUNC) or die $!; +my $sysseek = sysseek(BIG, 5_000_000_000, SEEK_SET); +my $syswrite = syswrite(BIG, "big"); +exit 0; +EOF + sysopen(BIG, "big", O_WRONLY|O_CREAT|O_TRUNC) or do { warn "sysopen 'big' failed: $!\n"; bye }; my $sysseek = sysseek(BIG, 5_000_000_000, SEEK_SET); -unless (defined $sysseek && $sysseek == 5_000_000_000) { - print "1..0\n# seeking past 2GB failed: $! (sysseek returned ", - defined $sysseek ? $sysseek : 'undef', ")\n"; - explain(); +unless (! $r && defined $sysseek && $sysseek == 5_000_000_000) { + $sysseek = 'undef' unless defined $sysseek; + explain("seeking past 2GB failed: ", + $r ? 'signal '.($r & 0x7f) : "$! (sysseek returned $sysseek)"); bye(); } @@ -125,11 +146,12 @@ my $close = close BIG; print "# close failed: $!\n" unless $close; unless($syswrite && $close) { if ($! =~/too large/i) { - print "1..0\n# writing past 2GB failed: process limits?\n"; + explain("writing past 2GB failed: process limits?"); } elsif ($! =~ /quota/i) { - print "1..0\n# filesystem quota limits?\n"; + explain("filesystem quota limits?"); + } else { + explain("error: $!"); } - explain(); bye(); } @@ -138,8 +160,7 @@ unless($syswrite && $close) { print "# @s\n"; unless ($s[7] == 5_000_000_003) { - print "1..0\n# not configured to use large files?\n"; - explain(); + explain("kernel/fs not configured to use large files?"); bye(); } @@ -148,9 +169,30 @@ sub fail () { $fail++; } +sub offset ($$) { + my ($offset_will_be, $offset_want) = @_; + my $offset_is = eval $offset_will_be; + unless ($offset_is == $offset_want) { + print "# bad offset $offset_is, want $offset_want\n"; + my ($offset_func) = ($offset_will_be =~ /^(\w+)/); + if (unpack("L", pack("L", $offset_want)) == $offset_is) { + print "# 32-bit wraparound suspected in $offset_func() since\n"; + print "# $offset_want cast into 32 bits equals $offset_is.\n"; + } elsif ($offset_want - unpack("L", pack("L", $offset_want)) - 1 + == $offset_is) { + print "# 32-bit wraparound suspected in $offset_func() since\n"; + printf "# %s - unpack('L', pack('L', %s)) - 1 equals %s.\n", + $offset_want, + $offset_want, + $offset_is; + } + fail; + } +} + print "1..17\n"; -my $fail = 0; +$fail = 0; fail unless $s[7] == 5_000_000_003; # exercizes pp_stat print "ok 1\n"; @@ -166,28 +208,28 @@ print "ok 4\n"; sysopen(BIG, "big", O_RDONLY) or do { warn "sysopen failed: $!\n"; bye }; -fail unless sysseek(BIG, 4_500_000_000, SEEK_SET) == 4_500_000_000; +offset('sysseek(BIG, 4_500_000_000, SEEK_SET)', 4_500_000_000); print "ok 5\n"; -fail unless sysseek(BIG, 0, SEEK_CUR) == 4_500_000_000; +offset('sysseek(BIG, 0, SEEK_CUR)', 4_500_000_000); print "ok 6\n"; -fail unless sysseek(BIG, 1, SEEK_CUR) == 4_500_000_001; +offset('sysseek(BIG, 1, SEEK_CUR)', 4_500_000_001); print "ok 7\n"; -fail unless sysseek(BIG, 0, SEEK_CUR) == 4_500_000_001; +offset('sysseek(BIG, 0, SEEK_CUR)', 4_500_000_001); print "ok 8\n"; -fail unless sysseek(BIG, -1, SEEK_CUR) == 4_500_000_000; +offset('sysseek(BIG, -1, SEEK_CUR)', 4_500_000_000); print "ok 9\n"; -fail unless sysseek(BIG, 0, SEEK_CUR) == 4_500_000_000; +offset('sysseek(BIG, 0, SEEK_CUR)', 4_500_000_000); print "ok 10\n"; -fail unless sysseek(BIG, -3, SEEK_END) == 5_000_000_000; +offset('sysseek(BIG, -3, SEEK_END)', 5_000_000_000); print "ok 11\n"; -fail unless sysseek(BIG, 0, SEEK_CUR) == 5_000_000_000; +offset('sysseek(BIG, 0, SEEK_CUR)', 5_000_000_000); print "ok 12\n"; my $big; @@ -199,7 +241,9 @@ fail unless $big eq "big"; print "ok 14\n"; # 705_032_704 = (I32)5_000_000_000 -fail unless seek(BIG, 705_032_704, SEEK_SET); +# See that we don't have "big" in the 705_... spot: +# that would mean that we have a wraparound. +fail unless sysseek(BIG, 705_032_704, SEEK_SET); print "ok 15\n"; my $zero; @@ -210,7 +254,7 @@ print "ok 16\n"; fail unless $zero eq "\0\0\0"; print "ok 17\n"; -explain if $fail; +explain() if $fail; bye(); # does the necessary cleanup diff --git a/contrib/perl5/t/lib/textfill.t b/contrib/perl5/t/lib/textfill.t index daeee23..5ff3850 100755 --- a/contrib/perl5/t/lib/textfill.t +++ b/contrib/perl5/t/lib/textfill.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Text::Wrap qw(&fill); diff --git a/contrib/perl5/t/lib/texttabs.t b/contrib/perl5/t/lib/texttabs.t index 80395f4..c6ca123 100755 --- a/contrib/perl5/t/lib/texttabs.t +++ b/contrib/perl5/t/lib/texttabs.t @@ -1,28 +1,139 @@ -#!./perl +#!./perl -w BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } -print "1..3\n"; +@tests = (split(/\nEND\n/s, <<DONE)); +TEST 1 u + x +END + x +END +TEST 2 e + x +END + x +END +TEST 3 e + x + y + z +END + x + y + z +END +TEST 4 u + x + y + z +END + x + y + z +END +TEST 5 u +This Is a test of a line with many embedded tabs +END +This Is a test of a line with many embedded tabs +END +TEST 6 e +This Is a test of a line with many embedded tabs +END +This Is a test of a line with many embedded tabs +END +TEST 7 u + x +END + x +END +TEST 8 e + + + -use Text::Tabs; + +END + + + + + +END +TEST 9 u + +END + +END +TEST 10 u + + + + + +END + + + + + +END +TEST 11 u +foobar IN A 140.174.82.12 + +END +foobar IN A 140.174.82.12 -$tabstop = 4; +END +DONE -$s1 = "foo\tbar\tb\tb"; -$s2 = expand $s1; -$s3 = unexpand $s2; +$| = 1; -print "not " unless $s2 eq "foo bar b b"; -print "ok 1\n"; +print "1..".scalar(@tests/2)."\n"; -print "not " unless $s3 eq "foo bar b\tb"; -print "ok 2\n"; +use Text::Tabs; + +$rerun = $ENV{'PERL_DL_NONLAZY'} ? 0 : 1; + +$tn = 1; +while (@tests) { + my $in = shift(@tests); + my $out = shift(@tests); + $in =~ s/^TEST\s*(\d+)?\s*(\S+)?\n//; -$tabstop = 8; + if ($2 eq 'e') { + $f = \&expand; + $fn = 'expand'; + } else { + $f = \&unexpand; + $fn = 'unexpand'; + } -print "not " unless unexpand(" foo") eq "\t\t foo"; -print "ok 3\n"; + my $back = &$f($in); + + if ($back eq $out) { + print "ok $tn\n"; + } elsif ($rerun) { + my $oi = $in; + foreach ($in, $back, $out) { + s/\t/^I\t/gs; + s/\n/\$\n/gs; + } + print "------------ input ------------\n"; + print $in; + print "\$\n------------ $fn -----------\n"; + print $back; + print "\$\n------------ expected ---------\n"; + print $out; + print "\$\n-------------------------------\n"; + $Text::Tabs::debug = 1; + my $back = &$f($in); + exit(1); + } else { + print "not ok $tn\n"; + } + $tn++; +} diff --git a/contrib/perl5/t/lib/textwrap.t b/contrib/perl5/t/lib/textwrap.t index bb1d5ca..fee6ce0 100755 --- a/contrib/perl5/t/lib/textwrap.t +++ b/contrib/perl5/t/lib/textwrap.t @@ -2,9 +2,8 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } -use Text::Wrap qw(&wrap); @tests = (split(/\nEND\n/s, <<DONE)); TEST1 @@ -84,21 +83,57 @@ END a123456789b123456789c123456789d123456789e123456789f123456789g123456789g123 4567 END +TEST10 +my mother once said +"never eat paste my darling" +would that I heeded +END + my mother once said + "never eat paste my darling" + would that I heeded +END +TEST11 +This_is_a_word_that_is_too_long_to_wrap_we_want_to_make_sure_that_the_program_does_not_crash_and_burn +END + This_is_a_word_that_is_too_long_to_wrap_we_want_to_make_sure_that_the_pr + ogram_does_not_crash_and_burn +END +TEST12 +This + +Has + +Blank + +Lines + +END + This + + Has + + Blank + + Lines + +END DONE $| = 1; -print "1..", @tests/2, "\n"; +print "1..", 1 +@tests, "\n"; use Text::Wrap; $rerun = $ENV{'PERL_DL_NONLAZY'} ? 0 : 1; $tn = 1; -while (@tests) { - my $in = shift(@tests); - my $out = shift(@tests); + +@st = @tests; +while (@st) { + my $in = shift(@st); + my $out = shift(@st); $in =~ s/^TEST(\d+)?\n//; @@ -126,4 +161,49 @@ while (@tests) { print "not ok $tn\n"; } $tn++; + +} + +@st = @tests; +while(@st) { + my $in = shift(@st); + my $out = shift(@st); + + $in =~ s/^TEST(\d+)?\n//; + + my @in = split("\n", $in, -1); + @in = ((map { "$_\n" } @in[0..$#in-1]), $in[-1]); + + my $back = wrap(' ', ' ', @in); + + if ($back eq $out) { + print "ok $tn\n"; + } elsif ($rerun) { + my $oi = $in; + foreach ($in, $back, $out) { + s/\t/^I\t/gs; + s/\n/\$\n/gs; + } + print "------------ input2 ------------\n"; + print $in; + print "\n------------ output2 -----------\n"; + print $back; + print "\n------------ expected2 ---------\n"; + print $out; + print "\n-------------------------------\n"; + $Text::Wrap::debug = 1; + wrap(' ', ' ', $oi); + exit(1); + } else { + print "not ok $tn\n"; + } + $tn++; } + +$Text::Wrap::huge = 'overflow'; + +my $tw = 'This_is_a_word_that_is_too_long_to_wrap_we_want_to_make_sure_that_the_program_does_not_crash_and_burn'; +my $w = wrap('zzz','yyy',$tw); +print (($w eq "zzz$tw") ? "ok $tn\n" : "not ok $tn"); +$tn++; + diff --git a/contrib/perl5/t/lib/thr5005.t b/contrib/perl5/t/lib/thr5005.t index 6b3c800..680e1af 100755 --- a/contrib/perl5/t/lib/thr5005.t +++ b/contrib/perl5/t/lib/thr5005.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; if (! $Config{'use5005threads'}) { print "1..0 # Skip: not use5005threads\n"; @@ -13,7 +13,7 @@ BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; } $| = 1; -print "1..21\n"; +print "1..22\n"; use Thread 'yield'; print "ok 1\n"; @@ -89,6 +89,18 @@ my $long = "This is short."; my $longe = " short."; my $thr1 = new Thread \&threaded, $short, $shorte, "19"; my $thr2 = new Thread \&threaded, $long, $longe, "20"; +my $thr3 = new Thread \&testsprintf, "21"; + +sub testsprintf { + my $testno = shift; + # this may coredump if thread vars are not properly initialised + my $same = sprintf "%.0f", $testno; + if ($testno eq $same) { + print "ok $testno\n"; + } else { + print "not ok $testno\t# '$testno' ne '$same'\n"; + } +} sub threaded { my ($string, $string_end, $testno) = @_; @@ -115,4 +127,5 @@ EOT } $thr1->join; $thr2->join; -print "ok 21\n"; +$thr3->join; +print "ok 22\n"; diff --git a/contrib/perl5/t/lib/tie-push.t b/contrib/perl5/t/lib/tie-push.t index 23a0a94..b19aa0d 100755 --- a/contrib/perl5/t/lib/tie-push.t +++ b/contrib/perl5/t/lib/tie-push.t @@ -2,7 +2,8 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '.'; + push @INC, '../lib'; } { diff --git a/contrib/perl5/t/lib/tie-stdarray.t b/contrib/perl5/t/lib/tie-stdarray.t index 5a678a5..c4ae071 100755 --- a/contrib/perl5/t/lib/tie-stdarray.t +++ b/contrib/perl5/t/lib/tie-stdarray.t @@ -2,7 +2,8 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '.'; + push @INC, '../lib'; } use Tie::Array; diff --git a/contrib/perl5/t/lib/tie-stdhandle.t b/contrib/perl5/t/lib/tie-stdhandle.t index cf3a183..f03f5d9 100755 --- a/contrib/perl5/t/lib/tie-stdhandle.t +++ b/contrib/perl5/t/lib/tie-stdhandle.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Tie::Handle; @@ -10,16 +10,16 @@ tie *tst,Tie::StdHandle; $f = 'tst'; -print "1..13\n"; +print "1..13\n"; # my $file tests -unlink("afile.new") if -f "afile"; -print "$!\nnot " unless open($f,"+>afile"); +unlink("afile.new") if -f "afile"; +print "$!\nnot " unless open($f,"+>afile") && open($f, "+<", "afile"); print "ok 1\n"; print "$!\nnot " unless binmode($f); print "ok 2\n"; -print "not " unless -f "afile"; +print "not " unless -f "afile"; print "ok 3\n"; print "not " unless print $f "SomeData\n"; print "ok 4\n"; @@ -44,4 +44,4 @@ print "not " unless eof($f); print "ok 12\n"; print "not " unless close($f); print "ok 13\n"; -unlink("afile"); +unlink("afile"); diff --git a/contrib/perl5/t/lib/tie-stdpush.t b/contrib/perl5/t/lib/tie-stdpush.t index 35ae1b8..31af30c 100755 --- a/contrib/perl5/t/lib/tie-stdpush.t +++ b/contrib/perl5/t/lib/tie-stdpush.t @@ -2,7 +2,8 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '.'; + push @INC, '../lib'; } use Tie::Array; diff --git a/contrib/perl5/t/lib/timelocal.t b/contrib/perl5/t/lib/timelocal.t index 359d71e..100e076 100755 --- a/contrib/perl5/t/lib/timelocal.t +++ b/contrib/perl5/t/lib/timelocal.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Time::Local; diff --git a/contrib/perl5/t/lib/trig.t b/contrib/perl5/t/lib/trig.t index 20669f0..6949622 100755 --- a/contrib/perl5/t/lib/trig.t +++ b/contrib/perl5/t/lib/trig.t @@ -10,7 +10,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Math::Trig; @@ -26,10 +26,11 @@ if ($^O eq 'unicos') { # See lib/Math/Complex.pm and t/lib/complex.t. } sub near ($$;$) { - abs($_[0] - $_[1]) < (defined $_[2] ? $_[2] : $eps); + my $e = defined $_[2] ? $_[2] : $eps; + $_[1] ? (abs($_[0]/$_[1] - 1) < $e) : abs($_[0]) < $e; } -print "1..20\n"; +print "1..23\n"; $x = 0.9; print 'not ' unless (near(tan($x), sin($x) / cos($x))); @@ -137,24 +138,42 @@ use Math::Trig ':radial'; } { - use Math::Trig 'great_circle_distance'; + use Math::Trig 'great_circle_distance'; - print 'not ' - unless (near(great_circle_distance(0, 0, 0, pi/2), pi/2)); - print "ok 18\n"; + print 'not ' + unless (near(great_circle_distance(0, 0, 0, pi/2), pi/2)); + print "ok 18\n"; - print 'not ' - unless (near(great_circle_distance(0, 0, pi, pi), pi)); - print "ok 19\n"; + print 'not ' + unless (near(great_circle_distance(0, 0, pi, pi), pi)); + print "ok 19\n"; - # London to Tokyo. - my @L = (deg2rad(-0.5), deg2rad(90 - 51.3)); - my @T = (deg2rad(139.8),deg2rad(90 - 35.7)); + # London to Tokyo. + my @L = (deg2rad(-0.5), deg2rad(90 - 51.3)); + my @T = (deg2rad(139.8),deg2rad(90 - 35.7)); - my $km = great_circle_distance(@L, @T, 6378); + my $km = great_circle_distance(@L, @T, 6378); - print 'not ' unless (near($km, 9605.26637021388)); - print "ok 20\n"; + print 'not ' unless (near($km, 9605.26637021388)); + print "ok 20\n"; +} + +{ + my $R2D = 57.295779513082320876798154814169; + + sub frac { $_[0] - int($_[0]) } + + my $lotta_radians = deg2rad(1E+20, 1); + print "not " unless near($lotta_radians, 1E+20/$R2D); + print "ok 21\n"; + + my $negat_degrees = rad2deg(-1E20, 1); + print "not " unless near($negat_degrees, -1E+20*$R2D); + print "ok 22\n"; + + my $posit_degrees = rad2deg(-10000, 1); + print "not " unless near($posit_degrees, -10000*$R2D); + print "ok 23\n"; } # eof |
