diff options
| author | Jarkko Hietaniemi <jhi@iki.fi> | 2001-06-18 04:17:15 +0000 |
|---|---|---|
| committer | Jarkko Hietaniemi <jhi@iki.fi> | 2001-06-18 04:17:15 +0000 |
| commit | b695f709e8a342e35e482b0437eb6cdacdc58b6b (patch) | |
| tree | 2d16192636e6ba806ff7a907f682c74f7705a920 /t | |
| parent | d780cd7a0195e946e636d3ee546f6ef4f21d6acc (diff) | |
| download | perl-b695f709e8a342e35e482b0437eb6cdacdc58b6b.tar.gz | |
The Grand Trek: move the *.t files from t/ to lib/ and ext/.
No doubt I made some mistakes like missed some files or
misnamed some files. The naming rules were more or less:
(1) if the module is from CPAN, follows its ways, be it
t/*.t or test.pl.
(2) otherwise if there are multiple tests for a module
put them in a t/
(3) otherwise if there's only one test put it in Module.t
(4) helper files go to module/ (locale, strict, warnings)
(5) use longer filenames now that we can (but e.g. the
compat-0.6.t and the Text::Balanced test files still
were renamed to be more civil against the 8.3 people)
installperl was updated appropriately not to install the
*.t files or the help files from under lib.
TODO: some helper files still remain under t/ that could
follow their 'masters'. UPDATE: On second thoughts, why
should they. They can continue to live under t/lib, and
in fact the locale/strict/warnings helpers that were moved
could be moved back. This way the amount of non-installable
stuff under lib/ stays smaller.
p4raw-id: //depot/perl@10676
Diffstat (limited to 't')
256 files changed, 17 insertions, 41541 deletions
@@ -64,13 +64,13 @@ sub _find_tests { } unless (@ARGV) { - foreach my $dir (qw(base comp cmd run io op pragma lib pod)) { + foreach my $dir (qw(base comp cmd run io op lib)) { _find_tests($dir); } my $mani = File::Spec->catdir($updir, "MANIFEST"); if (open(MANI, $mani)) { while (<MANI>) { # similar code in t/harness - if (m!^(ext/.+/([^/]+\.t|test\.pl)|lib/.+(\.t|test\.pl))\s!) { + if (m!^(ext/\S+/([^/]+\.t|test\.pl)|lib/\S+?(\.t|test\.pl))\s!) { push @ARGV, $1; $OVER{$1} = File::Spec->catdir($updir, $1); } @@ -78,6 +78,7 @@ unless (@ARGV) { } else { warn "$0: cannot open $mani: $!\n"; } + _find_tests('pod'); } # Tests known to cause infinite loops for the perlcc tests. @@ -146,7 +147,7 @@ EOT } } $te = $test; - chop($te); + $te =~ s/\.\w+$/./; print "$te" . '.' x ($dotdotdot - length($te)); $test = $OVER{$test} if exists $OVER{$test}; @@ -29,7 +29,6 @@ $Test::Harness::verbose = shift if @ARGV && $ARGV[0] eq '-v'; op/runlevel.t 1 op/tie.t 1 op/lex_assign.t 1 - pragma/subs.t 1 ); foreach (keys %datahandle) { @@ -39,18 +38,21 @@ foreach (keys %datahandle) { if (@ARGV) { @tests = @ARGV; } else { - @tests = <base/*.t comp/*.t cmd/*.t io/*.t op/*.t pragma/*.t lib/*.t pod/*.t> unless @tests; - use File::Spec; - my $updir = File::Spec->updir; - my $mani = File::Spec->catdir(File::Spec->updir, "MANIFEST"); - if (open(MANI, $mani)) { - while (<MANI>) { # similar code in t/TEST - if (m!^(ext/.+/([^/]+\.t|test\.pl)|lib/.+(\.t|test\.pl))\s!) { - push @tests, File::Spec->catdir($updir, $1); + unless (@tests) { + @tests = <base/*.t comp/*.t cmd/*.t io/*.t op/*.t lib/*.t>; + use File::Spec; + my $updir = File::Spec->updir; + my $mani = File::Spec->catdir(File::Spec->updir, "MANIFEST"); + if (open(MANI, $mani)) { + while (<MANI>) { # similar code in t/TEST + if (m!^(ext/\S+/([^/]+\.t|test\.pl)|lib/\S+?(\.t|test\.pl))\s!) { + push @tests, File::Spec->catdir($updir, $1); + } } + } else { + warn "$0: cannot open $mani: $!\n"; } - } else { - warn "$0: cannot open $mani: $!\n"; + push @tests, <pod/*.t>; } } diff --git a/t/lib/Test/fail.t b/t/lib/Test/fail.t deleted file mode 100644 index b431502b8a..0000000000 --- a/t/lib/Test/fail.t +++ /dev/null @@ -1,93 +0,0 @@ -# -*-perl-*- -use strict; -use vars qw($Expect); -use Test qw($TESTOUT $ntest ok skip plan); -plan tests => 14; - -open F, ">fails"; -$TESTOUT = *F{IO}; - -my $r=0; -{ - # Shut up deprecated usage warning. - local $^W = 0; - $r |= skip(0,0); -} -$r |= ok(0); -$r |= ok(0,1); -$r |= ok(sub { 1+1 }, 3); -$r |= ok(sub { 1+1 }, sub { 2 * 0}); - -my @list = (0,0); -$r |= ok @list, 1, "\@list=".join(',',@list); -$r |= ok @list, 1, sub { "\@list=".join ',',@list }; -$r |= ok 'segmentation fault', '/bongo/'; - -for (1..2) { $r |= ok(0); } - -$r |= ok(1, undef); -$r |= ok(undef, 1); - -ok($r); # (failure==success :-) - -close F; -$TESTOUT = *STDOUT{IO}; -$ntest = 1; - -open F, "fails"; -my $O; -while (<F>) { $O .= $_; } -close F; -unlink "fails"; - -ok join(' ', map { m/(\d+)/; $1 } grep /^not ok/, split /\n+/, $O), - join(' ', 1..13); - -my @got = split /not ok \d+\n/, $O; -shift @got; - -$Expect =~ s/\n+$//; -my @expect = split /\n\n/, $Expect; - -for (my $x=0; $x < @got; $x++) { - ok $got[$x], $expect[$x]."\n"; -} - - -BEGIN { - $Expect = <<"EXPECT"; -# Failed test 1 in $0 at line 14 - -# Failed test 2 in $0 at line 16 - -# Test 3 got: '0' ($0 at line 17) -# Expected: '1' - -# Test 4 got: '2' ($0 at line 18) -# Expected: '3' - -# Test 5 got: '2' ($0 at line 19) -# Expected: '0' - -# Test 6 got: '2' ($0 at line 22) -# Expected: '1' (\@list=0,0) - -# Test 7 got: '2' ($0 at line 23) -# Expected: '1' (\@list=0,0) - -# Test 8 got: 'segmentation fault' ($0 at line 24) -# Expected: qr{bongo} - -# Failed test 9 in $0 at line 26 - -# Failed test 10 in $0 at line 26 fail #2 - -# Failed test 11 in $0 at line 28 - -# Test 12 got: <UNDEF> ($0 at line 29) -# Expected: '1' - -# Failed test 13 in $0 at line 31 -EXPECT - -} diff --git a/t/lib/Test/mix.t b/t/lib/Test/mix.t deleted file mode 100644 index d911689845..0000000000 --- a/t/lib/Test/mix.t +++ /dev/null @@ -1,17 +0,0 @@ -# -*-perl-*- -use strict; -use Test; -BEGIN { plan tests => 4, todo => [2,3] } - -ok(sub { - my $r = 0; - for (my $x=0; $x < 10; $x++) { - $r += $x*($r+1); - } - $r - }, 3628799); - -ok(0); -ok(1); - -skip(1,0); diff --git a/t/lib/Test/onfail.t b/t/lib/Test/onfail.t deleted file mode 100644 index dce4373401..0000000000 --- a/t/lib/Test/onfail.t +++ /dev/null @@ -1,31 +0,0 @@ -# -*-perl-*- - -use strict; -use Test qw($ntest plan ok $TESTOUT); -use vars qw($mycnt); - -BEGIN { plan test => 6, onfail => \&myfail } - -$mycnt = 0; - -my $why = "zero != one"; -# sneak in a test that Test::Harness wont see -open J, ">junk"; -$TESTOUT = *J{IO}; -ok(0, 1, $why); -$TESTOUT = *STDOUT{IO}; -close J; -unlink "junk"; -$ntest = 1; - -sub myfail { - my ($f) = @_; - ok(@$f, 1); - - my $t = $$f[0]; - ok($$t{diagnostic}, $why); - ok($$t{'package'}, 'main'); - ok($$t{repetition}, 1); - ok($$t{result}, 0); - ok($$t{expected}, 1); -} diff --git a/t/lib/Test/qr.t b/t/lib/Test/qr.t deleted file mode 100644 index ea40f87308..0000000000 --- a/t/lib/Test/qr.t +++ /dev/null @@ -1,13 +0,0 @@ -#!./perl -w - -use strict; -BEGIN { - if ($] < 5.005) { - print "1..0\n"; - print "ok 1 # skipped; this test requires at least perl 5.005\n"; - exit; - } -} -use Test; plan tests => 1; - -ok 'abc', qr/b/; diff --git a/t/lib/Test/skip.t b/t/lib/Test/skip.t deleted file mode 100644 index 7db35e65dc..0000000000 --- a/t/lib/Test/skip.t +++ /dev/null @@ -1,40 +0,0 @@ -# -*-perl-*- -use strict; -use Test qw($TESTOUT $ntest plan ok skip); plan tests => 6; - -open F, ">skips" or die "open skips: $!"; -$TESTOUT = *F{IO}; - -skip(1, 0); #should skip - -my $skipped=1; -skip('hop', sub { $skipped = 0 }); -skip(sub {'jump'}, sub { $skipped = 0 }); -skip('skipping stones is more fun', sub { $skipped = 0 }); - -close F; - -$TESTOUT = *STDOUT{IO}; -$ntest = 1; -open F, "skips" or die "open skips: $!"; - -ok $skipped, 1, 'not skipped?'; - -my @T = <F>; -chop @T; -my @expect = split /\n+/, join('',<DATA>); -ok @T, 4; -for (my $x=0; $x < @T; $x++) { - ok $T[$x], $expect[$x]; -} - -END { close F; unlink "skips" } - -__DATA__ -ok 1 # skip - -ok 2 # skip hop - -ok 3 # skip jump - -ok 4 # skip skipping stones is more fun diff --git a/t/lib/Test/success.t b/t/lib/Test/success.t deleted file mode 100644 index a580f0a567..0000000000 --- a/t/lib/Test/success.t +++ /dev/null @@ -1,11 +0,0 @@ -# -*-perl-*- -use strict; -use Test; -BEGIN { plan tests => 11 } - -ok(ok(1)); -ok(ok('fixed', 'fixed')); -ok(skip(1,0)); -ok(undef, undef); -ok(ok 'the brown fox jumped over the lazy dog', '/lazy/'); -ok(ok 'the brown fox jumped over the lazy dog', 'm,fox,'); diff --git a/t/lib/Test/todo.t b/t/lib/Test/todo.t deleted file mode 100644 index ae02a04f6b..0000000000 --- a/t/lib/Test/todo.t +++ /dev/null @@ -1,13 +0,0 @@ -# -*-perl-*- -use strict; -use Test; -BEGIN { - my $tests = 5; - plan tests => $tests, todo => [1..$tests]; -} - -ok(0); -ok(1); -ok(0,1); -ok(0,1,"need more tuits"); -ok(1,1); diff --git a/t/lib/ansicolor.t b/t/lib/ansicolor.t deleted file mode 100755 index f38e905cdd..0000000000 --- a/t/lib/ansicolor.t +++ /dev/null @@ -1,81 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -# Test suite for the Term::ANSIColor Perl module. Before `make install' is -# performed this script should be runnable with `make test'. After `make -# install' it should work as `perl test.pl'. - -############################################################################ -# Ensure module can be loaded -############################################################################ - -BEGIN { $| = 1; print "1..8\n" } -END { print "not ok 1\n" unless $loaded } -use Term::ANSIColor qw(:constants color colored); -$loaded = 1; -print "ok 1\n"; - - -############################################################################ -# Test suite -############################################################################ - -# Test simple color attributes. -if (color ('blue on_green', 'bold') eq "\e[34;42;1m") { - print "ok 2\n"; -} else { - print "not ok 2\n"; -} - -# Test colored. -if (colored ("testing", 'blue', 'bold') eq "\e[34;1mtesting\e[0m") { - print "ok 3\n"; -} else { - print "not ok 3\n"; -} - -# Test the constants. -if (BLUE BOLD "testing" eq "\e[34m\e[1mtesting") { - print "ok 4\n"; -} else { - print "not ok 4\n"; -} - -# Test AUTORESET. -$Term::ANSIColor::AUTORESET = 1; -if (BLUE BOLD "testing" eq "\e[34m\e[1mtesting\e[0m\e[0m") { - print "ok 5\n"; -} else { - print "not ok 5\n"; -} - -# Test EACHLINE. -$Term::ANSIColor::EACHLINE = "\n"; -if (colored ("test\n\ntest", 'bold') - eq "\e[1mtest\e[0m\n\n\e[1mtest\e[0m") { - print "ok 6\n"; -} else { - print colored ("test\n\ntest", 'bold'), "\n"; - print "not ok 6\n"; -} - -# Test EACHLINE with multiple trailing delimiters. -$Term::ANSIColor::EACHLINE = "\r\n"; -if (colored ("test\ntest\r\r\n\r\n", 'bold') - eq "\e[1mtest\ntest\r\e[0m\r\n\r\n") { - print "ok 7\n"; -} else { - print "not ok 7\n"; -} - -# Test the array ref form. -$Term::ANSIColor::EACHLINE = "\n"; -if (colored (['bold', 'on_green'], "test\n", "\n", "test") - eq "\e[1;42mtest\e[0m\n\n\e[1;42mtest\e[0m") { - print "ok 8\n"; -} else { - print colored (['bold', 'on_green'], "test\n", "\n", "test"); - print "not ok 8\n"; -} diff --git a/t/lib/anydbm.t b/t/lib/anydbm.t deleted file mode 100755 index 30b3c7ac14..0000000000 --- a/t/lib/anydbm.t +++ /dev/null @@ -1,155 +0,0 @@ -#!./perl - -# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if (($Config{'extensions'} !~ /\b(DB|[A-Z]DBM)_File\b/) ){ - print "1..0 # Skipping (no DB_File or [A-Z]DBM_File)\n"; - exit 0; - } -} -require AnyDBM_File; -use Fcntl; - -print "1..12\n"; - -$Is_Dosish = ($^O eq 'amigaos' || $^O eq 'MSWin32' || $^O eq 'NetWare' or $^O eq 'dos' or - $^O eq 'os2' or $^O eq 'mint'); - -unlink <Op_dbmx*>; - -umask(0); -print (tie(%h,AnyDBM_File,'Op_dbmx', O_RDWR|O_CREAT, 0640) - ? "ok 1\n" : "not ok 1\n"); - -$Dfile = "Op_dbmx.pag"; -if (! -e $Dfile) { - ($Dfile) = <Op_dbmx*>; -} -if ($Is_Dosish || $^O eq 'MacOS') { - print "ok 2 # Skipped: different file permission semantics\n"; -} -else { - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); - print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); -} -while (($key,$value) = each(%h)) { - $i++; -} -print (!$i ? "ok 3\n" : "not ok 3 # i=$i\n\n"); - -$h{'goner1'} = 'snork'; - -$h{'abc'} = 'ABC'; -$h{'def'} = 'DEF'; -$h{'jkl','mno'} = "JKL\034MNO"; -$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); -$h{'a'} = 'A'; -$h{'b'} = 'B'; -$h{'c'} = 'C'; -$h{'d'} = 'D'; -$h{'e'} = 'E'; -$h{'f'} = 'F'; -$h{'g'} = 'G'; -$h{'h'} = 'H'; -$h{'i'} = 'I'; - -$h{'goner2'} = 'snork'; -delete $h{'goner2'}; - -untie(%h); -print (tie(%h,AnyDBM_File,'Op_dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); - -$h{'j'} = 'J'; -$h{'k'} = 'K'; -$h{'l'} = 'L'; -$h{'m'} = 'M'; -$h{'n'} = 'N'; -$h{'o'} = 'O'; -$h{'p'} = 'P'; -$h{'q'} = 'Q'; -$h{'r'} = 'R'; -$h{'s'} = 'S'; -$h{'t'} = 'T'; -$h{'u'} = 'U'; -$h{'v'} = 'V'; -$h{'w'} = 'W'; -$h{'x'} = 'X'; -$h{'y'} = 'Y'; -$h{'z'} = 'Z'; - -$h{'goner3'} = 'snork'; - -delete $h{'goner1'}; -delete $h{'goner3'}; - -@keys = keys(%h); -@values = values(%h); - -if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} - -while (($key,$value) = each(%h)) { - if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { - $key =~ y/a-z/A-Z/; - $i++ if $key eq $value; - } -} - -if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";} - -@keys = ('blurfl', keys(%h), 'dyick'); -if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";} - -$h{'foo'} = ''; -$h{''} = 'bar'; - -# check cache overflow and numeric keys and contents -$ok = 1; -for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } -for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } -print ($ok ? "ok 8\n" : "not ok 8\n"); - -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); -print ($size > 0 ? "ok 9\n" : "not ok 9\n"); - -@h{0..200} = 200..400; -@foo = @h{0..200}; -print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; - -print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); -if ($h{''} eq 'bar') { - print "ok 12\n" ; -} -else { - if ($AnyDBM_File::ISA[0] eq 'DB_File' && $DB_File::db_ver >= 2.004010) { - ($major, $minor, $patch) = ($DB_File::db_ver =~ /^(\d+)\.(\d\d\d)(\d\d\d)/) ; - $major =~ s/^0+// ; - $minor =~ s/^0+// ; - $patch =~ s/^0+// ; - $compact = "$major.$minor.$patch" ; - # - # anydbm.t test 12 will fail when AnyDBM_File uses the combination of - # DB_File and Berkeley DB 2.4.10 (or greater). - # You are using DB_File $DB_File::VERSION and Berkeley DB $compact - # - # Berkeley DB 2 from version 2.4.10 onwards does not allow null keys. - # This feature will be reenabled in a future version of Berkeley DB. - # - print "ok 12 # skipped: db v$compact, no null key support\n" ; - } - else { - print "not ok 12\n" ; - } -} - -untie %h; -if ($^O eq 'VMS') { - unlink 'Op_dbmx.sdbm_dir', $Dfile; -} else { - unlink 'Op_dbmx.dir', $Dfile; -} diff --git a/t/lib/attrhand.t b/t/lib/attrhand.t deleted file mode 100644 index 5056fa833f..0000000000 --- a/t/lib/attrhand.t +++ /dev/null @@ -1,130 +0,0 @@ -# Before `make install' is performed this script should be runnable with -# `make test'. After `make install' it should work as `perl test.pl' - -######################### We start with some black magic to print on failure. - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -# Change 1..1 below to 1..last_test_to_print . -# (It may become useful if the test is moved to ./t subdirectory.) - -END {print "not ok 1\n" unless $loaded;} -use v5.6.0; -use Attribute::Handlers; -$loaded = 1; - -######################### End of black magic. - -# Insert your test code below (better if it prints "ok 13" -# (correspondingly "not ok 13") depending on the success of chunk 13 -# of the test code): - -sub ok { $::count++; push @::results, [$_[1], $_[0]?"":"not "]; } - -END { print "1..$::count\n"; - print map "$_->[1]ok $_->[0]\n", sort {$a->[0]<=>$b->[0]} @::results } - -package Test; -use warnings; -no warnings 'redefine'; - -sub UNIVERSAL::Okay :ATTR { ::ok @{$_[4]} } - -sub Dokay :ATTR(SCALAR) { ::ok @{$_[4]} } -sub Dokay :ATTR(HASH) { ::ok @{$_[4]} } -sub Dokay :ATTR(ARRAY) { ::ok @{$_[4]} } -sub Dokay :ATTR(CODE) { ::ok @{$_[4]} } - -sub Vokay :ATTR(VAR) { ::ok @{$_[4]} } - -sub Aokay :ATTR(ANY) { ::ok @{$_[4]} } - -package main; -use warnings; - -my $x1 :Okay(1,1); -my @x1 :Okay(1=>2); -my %x1 :Okay(1,3); -sub x1 :Okay(1,4) {} - -my Test $x2 :Dokay(1,5); - -package Test; -my $x3 :Dokay(1,6); -my Test $x4 :Dokay(1,7); -sub x3 :Dokay(1,8) {} - -my $y1 :Okay(1,9); -my @y1 :Okay(1,10); -my %y1 :Okay(1,11); -sub y1 :Okay(1,12) {} - -my $y2 :Vokay(1,13); -my @y2 :Vokay(1,14); -my %y2 :Vokay(1,15); -# BEGIN {eval 'sub y2 :Vokay(0,16) {}; 1' or -::ok(1,16); -# } - -my $z :Aokay(1,17); -my @z :Aokay(1,18); -my %z :Aokay(1,19); -sub z :Aokay(1,20) {}; - -package DerTest; -use base 'Test'; -use warnings; - -my $x5 :Dokay(1,21); -my Test $x6 :Dokay(1,22); -sub x5 :Dokay(1,23); - -my $y3 :Okay(1,24); -my @y3 :Okay(1,25); -my %y3 :Okay(1,26); -sub y3 :Okay(1,27) {} - -package Unrelated; - -BEGIN { eval 'my $x7 :Dokay(0,28)' or ::ok(1,28); } -my Test $x8 :Dokay(1,29); -eval 'sub x7 :Dokay(0,30) {}' or ::ok(1,30); - - -package Tie::Loud; - -sub TIESCALAR { ::ok(1,31); bless {}, $_[0] } -sub FETCH { ::ok(1,32); return 1 } -sub STORE { ::ok(1,33); return 1 } - -package Tie::Noisy; - -sub TIEARRAY { ::ok(1,$_[1]); bless {}, $_[0] } -sub FETCH { ::ok(1,35); return 1 } -sub STORE { ::ok(1,36); return 1 } -sub FETCHSIZE { 100 } - -package Tie::Rowdy; - -sub TIEHASH { ::ok(1,$_[1]); bless {}, $_[0] } -sub FETCH { ::ok(1,38); return 1 } -sub STORE { ::ok(1,39); return 1 } - -package main; - -use Attribute::Handlers autotie => { Other::Loud => Tie::Loud, - Noisy => Tie::Noisy, - UNIVERSAL::Rowdy => Tie::Rowdy, - }; - -my Other $loud : Loud; -$loud++; - -my @noisy : Noisy(34); -$noisy[0]++; - -my %rowdy : Rowdy(37); -$rowdy{key}++; diff --git a/t/lib/attrs.t b/t/lib/attrs.t deleted file mode 100644 index 18a02aba84..0000000000 --- a/t/lib/attrs.t +++ /dev/null @@ -1,141 +0,0 @@ -#!./perl - -# Regression tests for attrs.pm and the C<sub x : attrs> syntax. - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - eval 'require attrs; 1' or do { - print "1..0\n"; - exit 0; - } -} - -use warnings; -no warnings qw(deprecated); # else attrs cries. - -sub NTESTS () ; - -my ($test, $ntests); -BEGIN {$ntests=0} -$test=0; -my $failed = 0; - -print "1..".NTESTS."\n"; - -eval 'sub t1 ($) { use attrs "locked"; $_[0]++ }'; -(print "not "), $failed=1 if $@; -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -eval 'sub t2 { use attrs "locked"; $_[0]++ }'; -(print "not "), $failed=1 if $@; -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -eval 'sub t3 ($) : locked ;'; -(print "not "), $failed=1 if $@; -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -eval 'sub t4 : locked ;'; -(print "not "), $failed=1 if $@; -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -my $anon1; -eval '$anon1 = sub ($) { use attrs qw(locked method); $_[0]++ }'; -(print "not "), $failed=1 if $@; -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -my $anon2; -eval '$anon2 = sub { use attrs qw(locked method); $_[0]++ }'; -(print "not "), $failed=1 if $@; -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -my $anon3; -eval '$anon3 = sub { use attrs "method"; $_[0]->[1] }'; -(print "not "), $failed=1 if $@; -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -my @attrs = attrs::get($anon3 ? $anon3 : \&ns); -(print "not "), $failed=1 unless "@attrs" eq "method"; -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -@attrs = sort +attrs::get($anon2 ? $anon2 : \&ns); -(print "not "), $failed=1 unless "@attrs" eq "locked method"; -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -@attrs = sort +attrs::get($anon1 ? $anon1 : \&ns); -(print "not "), $failed=1 unless "@attrs" eq "locked method"; -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -eval 'sub e1 ($) : plugh ;'; -unless ($@ && $@ =~ m/^Invalid CODE attribute: ["']?plugh["']? at/) { - my $x = $@; - $x =~ s/\n.*\z//s; - print "# $x\n"; - print "not "; - $failed = 1; -} -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -eval 'sub e2 ($) : plugh(0,0) xyzzy ;'; -unless ($@ && $@ =~ m/^Invalid CODE attributes: ["']?plugh\(0,0\)["']? /) { - my $x = $@; - $x =~ s/\n.*\z//s; - print "# $x\n"; - print "not "; - $failed = 1; -} -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -eval 'sub e3 ($) : plugh(0,0 xyzzy ;'; -unless ($@ && $@ =~ m/Unterminated attribute parameter in attribute list at/) { - my $x = $@; - $x =~ s/\n.*\z//s; - print "# $x\n"; - print "not "; - $failed = 1; -} -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -eval 'sub e4 ($) : plugh + xyzzy ;'; -unless ($@ && $@ =~ m/Invalid separator character '[+]' in attribute list at/) { - my $x = $@; - $x =~ s/\n.*\z//s; - print "# $x\n"; - print "not "; - $failed = 1; -} -print "ok ",++$test,"\n"; -BEGIN {++$ntests} - -{ - my $w = "" ; - local $SIG{__WARN__} = sub {$w = shift} ; - eval 'sub w1 ($) { use warnings "deprecated"; use attrs "locked"; $_[0]++ }'; - (print "not "), $failed=1 if $@; - print "ok ",++$test,"\n"; - BEGIN {++$ntests} - (print "not "), $failed=1 - if $w !~ /^pragma "attrs" is deprecated, use "sub NAME : ATTRS" instead at/; - print "ok ",++$test,"\n"; - BEGIN {++$ntests} -} - - -# Other tests should be added above this line - -sub NTESTS () { $ntests } - -exit $failed; diff --git a/t/lib/autoloader.t b/t/lib/autoloader.t deleted file mode 100755 index f2fae7f309..0000000000 --- a/t/lib/autoloader.t +++ /dev/null @@ -1,128 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - if ($^O eq 'MacOS') { - $dir = ":auto-$$"; - $sep = ":"; - } else { - $dir = "auto-$$"; - $sep = "/"; - } - @INC = $dir; - push @INC, '../lib'; -} - -print "1..11\n"; - -# First we must set up some autoloader files -mkdir $dir, 0755 or die "Can't mkdir $dir: $!"; -mkdir "$dir${sep}auto", 0755 or die "Can't mkdir: $!"; -mkdir "$dir${sep}auto${sep}Foo", 0755 or die "Can't mkdir: $!"; - -open(FOO, ">$dir${sep}auto${sep}Foo${sep}foo.al") or die; -print FOO <<'EOT'; -package Foo; -sub foo { shift; shift || "foo" } -1; -EOT -close(FOO); - -open(BAR, ">$dir${sep}auto${sep}Foo${sep}bar.al") or die; -print BAR <<'EOT'; -package Foo; -sub bar { shift; shift || "bar" } -1; -EOT -close(BAR); - -open(BAZ, ">$dir${sep}auto${sep}Foo${sep}bazmarkhian.al") or die; -print BAZ <<'EOT'; -package Foo; -sub bazmarkhianish { shift; shift || "baz" } -1; -EOT -close(BAZ); - -# Let's define the package -package Foo; -require AutoLoader; -@ISA=qw(AutoLoader); - -sub new { bless {}, shift }; - -package main; - -$foo = new Foo; - -print "not " unless $foo->foo eq 'foo'; # autoloaded first time -print "ok 1\n"; - -print "not " unless $foo->foo eq 'foo'; # regular call -print "ok 2\n"; - -# Try an undefined method -eval { - $foo->will_fail; -}; -print "not " unless $@ =~ /^Can't locate/; -print "ok 3\n"; - -# Used to be trouble with this -eval { - my $foo = new Foo; - die "oops"; -}; -print "not " unless $@ =~ /oops/; -print "ok 4\n"; - -# Pass regular expression variable to autoloaded function. This used -# to go wrong because AutoLoader used regular expressions to generate -# autoloaded filename. -"foo" =~ /(\w+)/; -print "not " unless $1 eq 'foo'; -print "ok 5\n"; - -print "not " unless $foo->bar($1) eq 'foo'; -print "ok 6\n"; - -print "not " unless $foo->bar($1) eq 'foo'; -print "ok 7\n"; - -print "not " unless $foo->bazmarkhianish($1) eq 'foo'; -print "ok 8\n"; - -print "not " unless $foo->bazmarkhianish($1) eq 'foo'; -print "ok 9\n"; - -# test recursive autoloads -open(F, ">$dir${sep}auto${sep}Foo${sep}a.al") or die; -print F <<'EOT'; -package Foo; -BEGIN { b() } -sub a { print "ok 11\n"; } -1; -EOT -close(F); - -open(F, ">$dir${sep}auto${sep}Foo${sep}b.al") or die; -print F <<'EOT'; -package Foo; -sub b { print "ok 10\n"; } -1; -EOT -close(F); -Foo::a(); - -# cleanup -END { -return unless $dir && -d $dir; -unlink "$dir${sep}auto${sep}Foo${sep}foo.al"; -unlink "$dir${sep}auto${sep}Foo${sep}bar.al"; -unlink "$dir${sep}auto${sep}Foo${sep}bazmarkhian.al"; -unlink "$dir${sep}auto${sep}Foo${sep}a.al"; -unlink "$dir${sep}auto${sep}Foo${sep}b.al"; -rmdir "$dir${sep}auto${sep}Foo"; -rmdir "$dir${sep}auto"; -rmdir "$dir"; -} diff --git a/t/lib/b-debug.t b/t/lib/b-debug.t deleted file mode 100644 index 286dac3574..0000000000 --- a/t/lib/b-debug.t +++ /dev/null @@ -1,70 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - if ($^O eq 'MacOS') { - @INC = qw(: ::lib ::macos:lib); - } else { - @INC = '.'; - push @INC, '../lib'; - } -} - -$| = 1; -use warnings; -use strict; -use Config; - -print "1..3\n"; - -my $test = 1; - -sub ok { print "ok $test\n"; $test++ } - - -my $a; -my $Is_VMS = $^O eq 'VMS'; -my $Is_MacOS = $^O eq 'MacOS'; - -my $path = join " ", map { qq["-I$_"] } @INC; -my $redir = $Is_MacOS ? "" : "2>&1"; - -$a = `$^X $path "-MO=Debug" -e 1 $redir`; -print "not " unless $a =~ -/\bLISTOP\b.*\bOP\b.*\bCOP\b.*\bOP\b/s; -ok; - - -$a = `$^X $path "-MO=Terse" -e 1 $redir`; -print "not " unless $a =~ -/\bLISTOP\b.*leave.*\n OP\b.*enter.*\n COP\b.*nextstate.*\n OP\b.*null/s; -ok; - -$a = `$^X $path "-MO=Terse" -ane "s/foo/bar/" $redir`; -$a =~ s/\(0x[^)]+\)//g; -$a =~ s/\[[^\]]+\]//g; -$a =~ s/-e syntax OK//; -$a =~ s/[^a-z ]+//g; -$a =~ s/\s+/ /g; -$a =~ s/\b(s|foo|bar|ullsv)\b\s?//g; -$a =~ s/^\s+//; -$a =~ s/\s+$//; -my $is_thread = $Config{use5005threads} && $Config{use5005threads} eq 'define'; -if ($is_thread) { - $b=<<EOF; -leave enter nextstate label leaveloop enterloop null and defined null -threadsv readline gv lineseq nextstate aassign null pushmark split pushre -threadsv const null pushmark rvav gv nextstate subst const unstack nextstate -EOF -} else { - $b=<<EOF; -leave enter nextstate label leaveloop enterloop null and defined null -null gvsv readline gv lineseq nextstate aassign null pushmark split pushre -null gvsv const null pushmark rvav gv nextstate subst const unstack nextstate -EOF -} -$b=~s/\n/ /g;$b=~s/\s+/ /g; -$b =~ s/\s+$//; -print "# [$a]\n# vs\n# [$b]\nnot " if $a ne $b; -ok; - diff --git a/t/lib/b-deparse.t b/t/lib/b-deparse.t deleted file mode 100644 index 048ce31eef..0000000000 --- a/t/lib/b-deparse.t +++ /dev/null @@ -1,176 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - if ($^O eq 'MacOS') { - @INC = qw(: ::lib ::macos:lib); - } else { - @INC = '.'; - push @INC, '../lib'; - } -} - -$| = 1; -use warnings; -use strict; -use Config; - -print "1..14\n"; - -use B::Deparse; -my $deparse = B::Deparse->new() or print "not "; -my $i=1; -print "ok ", $i++, "\n"; - - -# Tell B::Deparse about our ambient pragmas -{ my ($hint_bits, $warning_bits); - BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})} - $deparse->ambient_pragmas ( - hint_bits => $hint_bits, - warning_bits => $warning_bits, - '$[' => 0 + $[ - ); -} - -$/ = "\n####\n"; -while (<DATA>) { - chomp; - s/#.*$//mg; - - my ($input, $expected); - if (/(.*)\n>>>>\n(.*)/s) { - ($input, $expected) = ($1, $2); - } - else { - ($input, $expected) = ($_, $_); - } - - my $coderef = eval "sub {$input}"; - - if ($@) { - print "not ok ", $i++, "\n"; - print "# $@"; - } - else { - my $deparsed = $deparse->coderef2text( $coderef ); - my $regex = quotemeta($expected); - do { - no warnings 'misc'; - $regex =~ s/\s+/\s+/g; - }; - - my $ok = ($deparsed =~ /^\{\s*$regex\s*\}$/); - print ($ok ? "ok " : "not ok "); - print $i++, "\n"; - if (!$ok) { - print "# EXPECTED:\n"; - $regex =~ s/^/# /mg; - print "$regex\n"; - - print "\n# GOT: \n"; - $deparsed =~ s/^/# /mg; - print "$deparsed\n"; - } - } -} - -use constant 'c', 'stuff'; -print "not " if (eval "sub ".$deparse->coderef2text(\&c))->() ne 'stuff'; -print "ok ", $i++, "\n"; - -$a = 0; -print "not " if "{\n (-1) ** \$a;\n}" - ne $deparse->coderef2text(sub{(-1) ** $a }); -print "ok ", $i++, "\n"; - -# XXX ToDo - constsub that returns a reference -#use constant cr => ['hello']; -#my $string = "sub " . $deparse->coderef2text(\&cr); -#my $val = (eval $string)->(); -#print "not " if ref($val) ne 'ARRAY' || $val->[0] ne 'hello'; -#print "ok ", $i++, "\n"; - -my $a; -my $Is_VMS = $^O eq 'VMS'; -my $Is_MacOS = $^O eq 'MacOS'; - -my $path = join " ", map { qq["-I$_"] } @INC; -my $redir = $Is_MacOS ? "" : "2>&1"; - -$a = `$^X $path "-MO=Deparse" -anle 1 $redir`; -$a =~ s/-e syntax OK\n//g; -$a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037 -$a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc' -$b = <<'EOF'; - -LINE: while (defined($_ = <ARGV>)) { - chomp $_; - @F = split(" ", $_, 0); - '???'; -} - -EOF -print "# [$a]\n\# vs expected\n# [$b]\nnot " if $a ne $b; -print "ok ", $i++, "\n"; - -__DATA__ -# 1 -1; -#### -# 2 -{ - no warnings; - '???'; - 2; -} -#### -# 3 -my $test; -++$test and $test /= 2; ->>>> -my $test; -$test /= 2 if ++$test; -#### -# 4 --((1, 2) x 2); -#### -# 5 -{ - my $test = sub : lvalue { - my $x; - } - ; -} -#### -# 6 -{ - my $test = sub : method { - my $x; - } - ; -} -#### -# 7 -{ - my $test = sub : locked method { - my $x; - } - ; -} -#### -# 8 -{ - 234; -} -continue { - 123; -} -#### -# 9 -my $x; -print $main::x; -#### -# 10 -my @x; -print $main::x[1]; diff --git a/t/lib/b-showlex.t b/t/lib/b-showlex.t deleted file mode 100644 index a21f03bb15..0000000000 --- a/t/lib/b-showlex.t +++ /dev/null @@ -1,39 +0,0 @@ -#!./perl - -BEGIN { - if ($^O eq 'MacOS') { - @INC = qw(: ::lib ::macos:lib); - } -} - -$| = 1; -use warnings; -use strict; -use Config; - -print "1..1\n"; - -my $test = 1; - -sub ok { print "ok $test\n"; $test++ } - -my $a; -my $Is_VMS = $^O eq 'VMS'; -my $Is_MacOS = $^O eq 'MacOS'; - -my $path = join " ", map { qq["-I$_"] } @INC; -my $redir = $Is_MacOS ? "" : "2>&1"; -my $is_thread = $Config{use5005threads} && $Config{use5005threads} eq 'define'; - -if ($is_thread) { - print "# use5005threads: test $test skipped\n"; -} else { - $a = `$^X $path "-MO=Showlex" -e "my %one" $redir`; - if (ord('A') != 193) { # ASCIIish - print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%one.*sv_undef.*HV/s; - } - else { # EBCDICish C<1: PVNV (0x1a7ede34) "%\226\225\205"> - print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%\\[0-9].*sv_undef.*HV/s; - } -} -ok; diff --git a/t/lib/b-stash.t b/t/lib/b-stash.t deleted file mode 100644 index bc9d896927..0000000000 --- a/t/lib/b-stash.t +++ /dev/null @@ -1,60 +0,0 @@ -#!./perl - -BEGIN { - if ($^O eq 'MacOS') { - @INC = qw(: ::lib ::macos:lib); - } -} - -$| = 1; -use warnings; -use strict; -use Config; - -print "1..1\n"; - -my $test = 1; - -sub ok { print "ok $test\n"; $test++ } - - -my $a; -my $Is_VMS = $^O eq 'VMS'; -my $Is_MacOS = $^O eq 'MacOS'; - -my $path = join " ", map { qq["-I$_"] } @INC; -my $redir = $Is_MacOS ? "" : "2>&1"; - - -chomp($a = `$^X $path "-MB::Stash" "-Mwarnings" -e1`); -$a = join ',', sort split /,/, $a; -$a =~ s/-u(PerlIO|open)(?:::\w+)?,//g if defined $Config{'useperlio'} and $Config{'useperlio'} eq 'define'; -$a =~ s/-uWin32,// if $^O eq 'MSWin32'; -$a =~ s/-uNetWare,// if $^O eq 'NetWare'; -$a =~ s/-u(Cwd|File|File::Copy|OS2),//g if $^O eq 'os2'; -$a =~ s/-uCwd,// if $^O eq 'cygwin'; - $b = '-uCarp,-uCarp::Heavy,-uDB,-uExporter,-uExporter::Heavy,-uattributes,' - . '-umain,-ustrict,-uutf8,-uwarnings'; -if ($Is_VMS) { - $a =~ s/-uFile,-uFile::Copy,//; - $a =~ s/-uVMS,-uVMS::Filespec,//; - $a =~ s/-uSocket,//; # Socket is optional/compiler version dependent -} - -{ - no strict 'vars'; - use vars '$OS2::is_aout'; -} -if (($Config{static_ext} eq ' ' || - ($Config{static_ext} eq 'Socket' && $Is_VMS)) - && !($^O eq 'os2' and $OS2::is_aout) - ) { - if (ord('A') == 193) { # EBCDIC sort order is qw(a A) not qw(A a) - $b = join ',', sort split /,/, $b; - } - print "# [$a]\n# vs.\n# [$b]\nnot " if $a ne $b; - ok; -} else { - print "ok $test # skipped: one or more static extensions\n"; $test++; -} - diff --git a/t/lib/b.t b/t/lib/b.t deleted file mode 100755 index f21f4891e4..0000000000 --- a/t/lib/b.t +++ /dev/null @@ -1,63 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - if ($^O eq 'MacOS') { - @INC = qw(: ::lib ::macos:lib); - } else { - @INC = '.'; - push @INC, '../lib'; - } -} - -$| = 1; -use warnings; -use strict; -use Config; - -print "1..2\n"; - -my $test = 1; - -sub ok { print "ok $test\n"; $test++ } - -use B; - - -package Testing::Symtable; -use vars qw($This @That %wibble $moo %moo); -my $not_a_sym = 'moo'; - -sub moo { 42 } -sub car { 23 } - - -package Testing::Symtable::Foo; -sub yarrow { "Hock" } - -package Testing::Symtable::Bar; -sub hock { "yarrow" } - -package main; -use vars qw(%Subs); -local %Subs = (); -B::walksymtable(\%Testing::Symtable::, 'find_syms', sub { $_[0] =~ /Foo/ }, - 'Testing::Symtable::'); - -sub B::GV::find_syms { - my($symbol) = @_; - - $main::Subs{$symbol->STASH->NAME . '::' . $symbol->NAME}++; -} - -my @syms = map { 'Testing::Symtable::'.$_ } qw(This That wibble moo car - BEGIN); -push @syms, "Testing::Symtable::Foo::yarrow"; - -# Make sure we hit all the expected symbols. -print "not " unless join('', sort @syms) eq join('', sort keys %Subs); -ok; - -# Make sure we only hit them each once. -print "not " unless !grep $_ != 1, values %Subs; -ok; diff --git a/t/lib/basename.t b/t/lib/basename.t deleted file mode 100755 index 9bee1bfb8b..0000000000 --- a/t/lib/basename.t +++ /dev/null @@ -1,144 +0,0 @@ -#!./perl -T - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use File::Basename qw(fileparse basename dirname); - -print "1..41\n"; - -# import correctly? -print +(defined(&basename) && !defined(&fileparse_set_fstype) ? - '' : 'not '),"ok 1\n"; - -# set fstype -- should replace non-null default -print +(length(File::Basename::fileparse_set_fstype('unix')) ? - '' : 'not '),"ok 2\n"; - -# Unix syntax tests -($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7','\.book\d+'); -if ($base eq 'draft' and $path eq '/virgil/aeneid/' and $type eq '.book7') { - print "ok 3\n"; -} -else { - print "not ok 3 |$base|$path|$type|\n"; -} -print +(basename('/arma/virumque.cano') eq 'virumque.cano' ? - '' : 'not '),"ok 4\n"; -print +(dirname('/arma/virumque.cano') eq '/arma' ? '' : 'not '),"ok 5\n"; -print +(dirname('arma/') eq '.' ? '' : 'not '),"ok 6\n"; -print +(dirname('/') eq '/' ? '' : 'not '),"ok 7\n"; - - -# set fstype -- should replace non-null default -print +(File::Basename::fileparse_set_fstype('VMS') eq 'unix' ? - '' : 'not '),"ok 8\n"; - -# VMS syntax tests -($base,$path,$type) = fileparse('virgil:[aeneid]draft.book7','\.book\d+'); -if ($base eq 'draft' and $path eq 'virgil:[aeneid]' and $type eq '.book7') { - print "ok 9\n"; -} -else { - print "not ok 9 |$base|$path|$type|\n"; -} -print +(basename('arma:[virumque]cano.trojae') eq 'cano.trojae' ? - '' : 'not '),"ok 10\n"; -print +(dirname('arma:[virumque]cano.trojae') eq 'arma:[virumque]' ? - '' : 'not '),"ok 11\n"; -print +(dirname('arma:<virumque>cano.trojae') eq 'arma:<virumque>' ? - '' : 'not '),"ok 12\n"; -print +(dirname('arma:virumque.cano') eq 'arma:' ? '' : 'not '),"ok 13\n"; -$ENV{DEFAULT} = '' unless exists $ENV{DEFAULT}; -print +(dirname('virumque.cano') eq $ENV{DEFAULT} ? '' : 'not '),"ok 14\n"; -print +(dirname('arma/') eq '.' ? '' : 'not '),"ok 15\n"; - -# set fstype -- should replace non-null default -print +(File::Basename::fileparse_set_fstype('MSDOS') eq 'VMS' ? - '' : 'not '),"ok 16\n"; - -# MSDOS syntax tests -($base,$path,$type) = fileparse('C:\\virgil\\aeneid\\draft.book7','\.book\d+'); -if ($base eq 'draft' and $path eq 'C:\\virgil\\aeneid\\' and $type eq '.book7') { - print "ok 17\n"; -} -else { - print "not ok 17 |$base|$path|$type|\n"; -} -print +(basename('A:virumque\\cano.trojae') eq 'cano.trojae' ? - '' : 'not '),"ok 18\n"; -print +(dirname('A:\\virumque\\cano.trojae') eq 'A:\\virumque' ? - '' : 'not '),"ok 19\n"; -print +(dirname('A:\\') eq 'A:\\' ? '' : 'not '),"ok 20\n"; -print +(dirname('arma\\') eq '.' ? '' : 'not '),"ok 21\n"; - -# Yes "/" is a legal path separator under MSDOS -basename("lib/File/Basename.pm") eq "Basename.pm" or print "not "; -print "ok 22\n"; - - - -# set fstype -- should replace non-null default -print +(File::Basename::fileparse_set_fstype('MacOS') eq 'MSDOS' ? - '' : 'not '),"ok 23\n"; - -# MacOS syntax tests -($base,$path,$type) = fileparse('virgil:aeneid:draft.book7','\.book\d+'); -if ($base eq 'draft' and $path eq 'virgil:aeneid:' and $type eq '.book7') { - print "ok 24\n"; -} -else { - print "not ok 24 |$base|$path|$type|\n"; -} -print +(basename(':arma:virumque:cano.trojae') eq 'cano.trojae' ? - '' : 'not '),"ok 25\n"; -print +(dirname(':arma:virumque:cano.trojae') eq ':arma:virumque:' ? - '' : 'not '),"ok 26\n"; -print +(dirname(':arma:virumque:') eq ':arma:' ? '' : 'not '),"ok 27\n"; -print +(dirname(':arma:virumque') eq ':arma:' ? '' : 'not '),"ok 28\n"; -print +(dirname(':arma:') eq ':' ? '' : 'not '),"ok 29\n"; -print +(dirname(':arma') eq ':' ? '' : 'not '),"ok 30\n"; -print +(dirname('arma:') eq 'arma:' ? '' : 'not '),"ok 31\n"; -print +(dirname('arma') eq ':' ? '' : 'not '),"ok 32\n"; -print +(dirname(':') eq ':' ? '' : 'not '),"ok 33\n"; - - -# Check quoting of metacharacters in suffix arg by basename() -print +(basename(':arma:virumque:cano.trojae','.trojae') eq 'cano' ? - '' : 'not '),"ok 34\n"; -print +(basename(':arma:virumque:cano_trojae','.trojae') eq 'cano_trojae' ? - '' : 'not '),"ok 35\n"; - -# extra tests for a few specific bugs - -File::Basename::fileparse_set_fstype 'MSDOS'; -# perl5.003_18 gives C:/perl/.\ -print +((fileparse 'C:/perl/lib')[1] eq 'C:/perl/' ? '' : 'not '), "ok 36\n"; -# perl5.003_18 gives C:\perl\ -print +(dirname('C:\\perl\\lib\\') eq 'C:\\perl' ? '' : 'not '), "ok 37\n"; - -File::Basename::fileparse_set_fstype 'UNIX'; -# perl5.003_18 gives '.' -print +(dirname('/perl/') eq '/' ? '' : 'not '), "ok 38\n"; -# perl5.003_18 gives '/perl/lib' -print +(dirname('/perl/lib//') eq '/perl' ? '' : 'not '), "ok 39\n"; - -# The empty tainted value, for tainting strings -my $TAINT = substr($^X, 0, 0); -# How to identify taint when you see it -sub any_tainted (@) { - not eval { join("",@_), kill 0; 1 }; -} -sub tainted ($) { - any_tainted @_; -} -sub all_tainted (@) { - for (@_) { return 0 unless tainted $_ } - 1; -} - -print +(tainted(dirname($TAINT.'/perl/lib//')) ? '' : 'not '), "ok 40\n"; -print +(all_tainted(fileparse($TAINT.'/dir/draft.book7','\.book\d+')) - ? '' : 'not '), "ok 41\n"; diff --git a/t/lib/bigfloat.t b/t/lib/bigfloat.t deleted file mode 100755 index 8e0a0ef724..0000000000 --- a/t/lib/bigfloat.t +++ /dev/null @@ -1,408 +0,0 @@ -#!./perl - -BEGIN { @INC = '../lib' } -require "bigfloat.pl"; - -$test = 0; -$| = 1; -print "1..355\n"; -while (<DATA>) { - chop; - if (/^&/) { - $f = $_; - } elsif (/^\$.*/) { - eval "$_;"; - } else { - ++$test; - @args = split(/:/,$_,99); - $ans = pop(@args); - $try = "$f('" . join("','", @args) . "');"; - if (($ans1 = eval($try)) eq $ans) { - print "ok $test\n"; - } else { - print "not ok $test\n"; - print "# '$try' expected: '$ans' got: '$ans1'\n"; - } - } -} -__END__ -&fnorm -abc:NaN - 1 a:NaN -1bcd2:NaN -11111b:NaN -+1z:NaN --1z:NaN -0:+0E+0 -+0:+0E+0 -+00:+0E+0 -+0 0 0:+0E+0 -000000 0000000 00000:+0E+0 --0:+0E+0 --0000:+0E+0 -+1:+1E+0 -+01:+1E+0 -+001:+1E+0 -+00000100000:+1E+5 -123456789:+123456789E+0 --1:-1E+0 --01:-1E+0 --001:-1E+0 --123456789:-123456789E+0 --00000100000:-1E+5 -123.456a:NaN -123.456:+123456E-3 -0.01:+1E-2 -.002:+2E-3 --0.0003:-3E-4 --.0000000004:-4E-10 -123456E2:+123456E+2 -123456E-2:+123456E-2 --123456E2:-123456E+2 --123456E-2:-123456E-2 -1e1:+1E+1 -2e-11:+2E-11 --3e111:-3E+111 --4e-1111:-4E-1111 -&fneg -abd:NaN -+0:+0E+0 -+1:-1E+0 --1:+1E+0 -+123456789:-123456789E+0 --123456789:+123456789E+0 -+123.456789:-123456789E-6 --123456.789:+123456789E-3 -&fabs -abc:NaN -+0:+0E+0 -+1:+1E+0 --1:+1E+0 -+123456789:+123456789E+0 --123456789:+123456789E+0 -+123.456789:+123456789E-6 --123456.789:+123456789E-3 -&fround -$bigfloat::rnd_mode = 'trunc' -+10123456789:5:+10123E+6 --10123456789:5:-10123E+6 -+10123456789:9:+101234567E+2 --10123456789:9:-101234567E+2 -+101234500:6:+101234E+3 --101234500:6:-101234E+3 -$bigfloat::rnd_mode = 'zero' -+20123456789:5:+20123E+6 --20123456789:5:-20123E+6 -+20123456789:9:+201234568E+2 --20123456789:9:-201234568E+2 -+201234500:6:+201234E+3 --201234500:6:-201234E+3 -$bigfloat::rnd_mode = '+inf' -+30123456789:5:+30123E+6 --30123456789:5:-30123E+6 -+30123456789:9:+301234568E+2 --30123456789:9:-301234568E+2 -+301234500:6:+301235E+3 --301234500:6:-301234E+3 -$bigfloat::rnd_mode = '-inf' -+40123456789:5:+40123E+6 --40123456789:5:-40123E+6 -+40123456789:9:+401234568E+2 --40123456789:9:-401234568E+2 -+401234500:6:+401234E+3 --401234500:6:-401235E+3 -$bigfloat::rnd_mode = 'odd' -+50123456789:5:+50123E+6 --50123456789:5:-50123E+6 -+50123456789:9:+501234568E+2 --50123456789:9:-501234568E+2 -+501234500:6:+501235E+3 --501234500:6:-501235E+3 -$bigfloat::rnd_mode = 'even' -+60123456789:5:+60123E+6 --60123456789:5:-60123E+6 -+60123456789:9:+601234568E+2 --60123456789:9:-601234568E+2 -+601234500:6:+601234E+3 --601234500:6:-601234E+3 -&ffround -$bigfloat::rnd_mode = 'trunc' -+1.23:-1:+12E-1 --1.23:-1:-12E-1 -+1.27:-1:+12E-1 --1.27:-1:-12E-1 -+1.25:-1:+12E-1 --1.25:-1:-12E-1 -+1.35:-1:+13E-1 --1.35:-1:-13E-1 --0.006:-1:+0E+0 --0.006:-2:+0E+0 -$bigfloat::rnd_mode = 'zero' -+2.23:-1:+22E-1 --2.23:-1:-22E-1 -+2.27:-1:+23E-1 --2.27:-1:-23E-1 -+2.25:-1:+22E-1 --2.25:-1:-22E-1 -+2.35:-1:+23E-1 --2.35:-1:-23E-1 --0.0065:-1:+0E+0 --0.0065:-2:-1E-2 --0.0065:-3:-6E-3 --0.0065:-4:-65E-4 --0.0065:-5:-65E-4 -$bigfloat::rnd_mode = '+inf' -+3.23:-1:+32E-1 --3.23:-1:-32E-1 -+3.27:-1:+33E-1 --3.27:-1:-33E-1 -+3.25:-1:+33E-1 --3.25:-1:-32E-1 -+3.35:-1:+34E-1 --3.35:-1:-33E-1 --0.0065:-1:+0E+0 --0.0065:-2:-1E-2 --0.0065:-3:-6E-3 --0.0065:-4:-65E-4 --0.0065:-5:-65E-4 -$bigfloat::rnd_mode = '-inf' -+4.23:-1:+42E-1 --4.23:-1:-42E-1 -+4.27:-1:+43E-1 --4.27:-1:-43E-1 -+4.25:-1:+42E-1 --4.25:-1:-43E-1 -+4.35:-1:+43E-1 --4.35:-1:-44E-1 --0.0065:-1:+0E+0 --0.0065:-2:-1E-2 --0.0065:-3:-7E-3 --0.0065:-4:-65E-4 --0.0065:-5:-65E-4 -$bigfloat::rnd_mode = 'odd' -+5.23:-1:+52E-1 --5.23:-1:-52E-1 -+5.27:-1:+53E-1 --5.27:-1:-53E-1 -+5.25:-1:+53E-1 --5.25:-1:-53E-1 -+5.35:-1:+53E-1 --5.35:-1:-53E-1 --0.0065:-1:+0E+0 --0.0065:-2:-1E-2 --0.0065:-3:-7E-3 --0.0065:-4:-65E-4 --0.0065:-5:-65E-4 -$bigfloat::rnd_mode = 'even' -+6.23:-1:+62E-1 --6.23:-1:-62E-1 -+6.27:-1:+63E-1 --6.27:-1:-63E-1 -+6.25:-1:+62E-1 --6.25:-1:-62E-1 -+6.35:-1:+64E-1 --6.35:-1:-64E-1 --0.0065:-1:+0E+0 --0.0065:-2:-1E-2 --0.0065:-3:-6E-3 --0.0065:-4:-65E-4 --0.0065:-5:-65E-4 -&fcmp -abc:abc: -abc:+0: -+0:abc: -+0:+0:0 --1:+0:-1 -+0:-1:1 -+1:+0:1 -+0:+1:-1 --1:+1:-1 -+1:-1:1 --1:-1:0 -+1:+1:0 -+123:+123:0 -+123:+12:1 -+12:+123:-1 --123:-123:0 --123:-12:-1 --12:-123:1 -+123:+124:-1 -+124:+123:1 --123:-124:1 --124:-123:-1 -&fadd -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:+0E+0 -+1:+0:+1E+0 -+0:+1:+1E+0 -+1:+1:+2E+0 --1:+0:-1E+0 -+0:-1:-1E+0 --1:-1:-2E+0 --1:+1:+0E+0 -+1:-1:+0E+0 -+9:+1:+1E+1 -+99:+1:+1E+2 -+999:+1:+1E+3 -+9999:+1:+1E+4 -+99999:+1:+1E+5 -+999999:+1:+1E+6 -+9999999:+1:+1E+7 -+99999999:+1:+1E+8 -+999999999:+1:+1E+9 -+9999999999:+1:+1E+10 -+99999999999:+1:+1E+11 -+10:-1:+9E+0 -+100:-1:+99E+0 -+1000:-1:+999E+0 -+10000:-1:+9999E+0 -+100000:-1:+99999E+0 -+1000000:-1:+999999E+0 -+10000000:-1:+9999999E+0 -+100000000:-1:+99999999E+0 -+1000000000:-1:+999999999E+0 -+10000000000:-1:+9999999999E+0 -+123456789:+987654321:+111111111E+1 --123456789:+987654321:+864197532E+0 --123456789:-987654321:-111111111E+1 -+123456789:-987654321:-864197532E+0 -&fsub -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:+0E+0 -+1:+0:+1E+0 -+0:+1:-1E+0 -+1:+1:+0E+0 --1:+0:-1E+0 -+0:-1:+1E+0 --1:-1:+0E+0 --1:+1:-2E+0 -+1:-1:+2E+0 -+9:+1:+8E+0 -+99:+1:+98E+0 -+999:+1:+998E+0 -+9999:+1:+9998E+0 -+99999:+1:+99998E+0 -+999999:+1:+999998E+0 -+9999999:+1:+9999998E+0 -+99999999:+1:+99999998E+0 -+999999999:+1:+999999998E+0 -+9999999999:+1:+9999999998E+0 -+99999999999:+1:+99999999998E+0 -+10:-1:+11E+0 -+100:-1:+101E+0 -+1000:-1:+1001E+0 -+10000:-1:+10001E+0 -+100000:-1:+100001E+0 -+1000000:-1:+1000001E+0 -+10000000:-1:+10000001E+0 -+100000000:-1:+100000001E+0 -+1000000000:-1:+1000000001E+0 -+10000000000:-1:+10000000001E+0 -+123456789:+987654321:-864197532E+0 --123456789:+987654321:-111111111E+1 --123456789:-987654321:+864197532E+0 -+123456789:-987654321:+111111111E+1 -&fmul -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:+0E+0 -+0:+1:+0E+0 -+1:+0:+0E+0 -+0:-1:+0E+0 --1:+0:+0E+0 -+123456789123456789:+0:+0E+0 -+0:+123456789123456789:+0E+0 --1:-1:+1E+0 --1:+1:-1E+0 -+1:-1:-1E+0 -+1:+1:+1E+0 -+2:+3:+6E+0 --2:+3:-6E+0 -+2:-3:-6E+0 --2:-3:+6E+0 -+111:+111:+12321E+0 -+10101:+10101:+102030201E+0 -+1001001:+1001001:+1002003002001E+0 -+100010001:+100010001:+10002000300020001E+0 -+10000100001:+10000100001:+100002000030000200001E+0 -+11111111111:+9:+99999999999E+0 -+22222222222:+9:+199999999998E+0 -+33333333333:+9:+299999999997E+0 -+44444444444:+9:+399999999996E+0 -+55555555555:+9:+499999999995E+0 -+66666666666:+9:+599999999994E+0 -+77777777777:+9:+699999999993E+0 -+88888888888:+9:+799999999992E+0 -+99999999999:+9:+899999999991E+0 -&fdiv -abc:abc:NaN -abc:+1:abc:NaN -+1:abc:NaN -+0:+0:NaN -+0:+1:+0E+0 -+1:+0:NaN -+0:-1:+0E+0 --1:+0:NaN -+1:+1:+1E+0 --1:-1:+1E+0 -+1:-1:-1E+0 --1:+1:-1E+0 -+1:+2:+5E-1 -+2:+1:+2E+0 -+10:+5:+2E+0 -+100:+4:+25E+0 -+1000:+8:+125E+0 -+10000:+16:+625E+0 -+10000:-16:-625E+0 -+999999999999:+9:+111111111111E+0 -+999999999999:+99:+10101010101E+0 -+999999999999:+999:+1001001001E+0 -+999999999999:+9999:+100010001E+0 -+999999999999999:+99999:+10000100001E+0 -+1000000000:+9:+1111111111111111111111111111111111111111E-31 -+2000000000:+9:+2222222222222222222222222222222222222222E-31 -+3000000000:+9:+3333333333333333333333333333333333333333E-31 -+4000000000:+9:+4444444444444444444444444444444444444444E-31 -+5000000000:+9:+5555555555555555555555555555555555555556E-31 -+6000000000:+9:+6666666666666666666666666666666666666667E-31 -+7000000000:+9:+7777777777777777777777777777777777777778E-31 -+8000000000:+9:+8888888888888888888888888888888888888889E-31 -+9000000000:+9:+1E+9 -+35500000:+113:+3141592920353982300884955752212389380531E-34 -+71000000:+226:+3141592920353982300884955752212389380531E-34 -+106500000:+339:+3141592920353982300884955752212389380531E-34 -+1000000000:+3:+3333333333333333333333333333333333333333E-31 -$bigfloat::div_scale = 20 -+1000000000:+9:+11111111111111111111E-11 -+2000000000:+9:+22222222222222222222E-11 -+3000000000:+9:+33333333333333333333E-11 -+4000000000:+9:+44444444444444444444E-11 -+5000000000:+9:+55555555555555555556E-11 -+6000000000:+9:+66666666666666666667E-11 -+7000000000:+9:+77777777777777777778E-11 -+8000000000:+9:+88888888888888888889E-11 -+9000000000:+9:+1E+9 -+35500000:+113:+314159292035398230088E-15 -+71000000:+226:+314159292035398230088E-15 -+106500000:+339:+31415929203539823009E-14 -+1000000000:+3:+33333333333333333333E-11 -$bigfloat::div_scale = 40 -&fsqrt -+0:+0E+0 --1:NaN --2:NaN --16:NaN --123.456:NaN -+1:+1E+0 -+1.44:+12E-1 -+2:+141421356237309504880168872420969807857E-38 -+4:+2E+0 -+16:+4E+0 -+100:+1E+1 -+123.456:+1111107555549866648462149404118219234119E-38 -+15241.383936:+123456E-3 diff --git a/t/lib/bigfltpm.t b/t/lib/bigfltpm.t deleted file mode 100755 index e8de58d871..0000000000 --- a/t/lib/bigfltpm.t +++ /dev/null @@ -1,708 +0,0 @@ -#!/usr/bin/perl -w - -use Test; -use strict; - -BEGIN - { - $| = 1; - unshift @INC, '../lib'; # for running manually - # chdir 't' if -d 't'; - plan tests => 514; - } - -use Math::BigFloat; -use Math::BigInt; - -my ($x,$y,$f,@args,$ans,$try,$ans1,$ans1_str,$setup); -while (<DATA>) - { - chop; - $_ =~ s/#.*$//; # remove comments - $_ =~ s/\s+$//; # trailing spaces - next if /^$/; # skip empty lines & comments - if (s/^&//) - { - $f = $_; - } - elsif (/^\$/) - { - $setup = $_; $setup =~ s/^\$/\$Math::BigFloat::/; # rnd_mode, div_scale - # print "$setup\n"; - } - else - { - if (m|^(.*?):(/.+)$|) - { - $ans = $2; - @args = split(/:/,$1,99); - } - else - { - @args = split(/:/,$_,99); $ans = pop(@args); - } - $try = "\$x = new Math::BigFloat \"$args[0]\";"; - if ($f eq "fnorm") - { - $try .= "\$x;"; - } elsif ($f eq "binf") { - $try .= "\$x->binf('$args[1]');"; - } elsif ($f eq "bsstr") { - $try .= "\$x->bsstr();"; - } elsif ($f eq "_set") { - $try .= "\$x->_set('$args[1]'); \$x;"; - } elsif ($f eq "fneg") { - $try .= "-\$x;"; - } elsif ($f eq "bfloor") { - $try .= "\$x->bfloor();"; - } elsif ($f eq "bceil") { - $try .= "\$x->bceil();"; - } elsif ($f eq "is_zero") { - $try .= "\$x->is_zero()+0;"; - } elsif ($f eq "is_one") { - $try .= "\$x->is_one()+0;"; - } elsif ($f eq "is_odd") { - $try .= "\$x->is_odd()+0;"; - } elsif ($f eq "is_even") { - $try .= "\$x->is_even()+0;"; - } elsif ($f eq "as_number") { - $try .= "\$x->as_number();"; - } elsif ($f eq "fpow") { - $try .= "\$x ** $args[1];"; - } elsif ($f eq "fabs") { - $try .= "abs \$x;"; - }elsif ($f eq "fround") { - $try .= "$setup; \$x->fround($args[1]);"; - } elsif ($f eq "ffround") { - $try .= "$setup; \$x->ffround($args[1]);"; - } elsif ($f eq "fsqrt") { - $try .= "$setup; \$x->fsqrt();"; - } - else - { - $try .= "\$y = new Math::BigFloat \"$args[1]\";"; - if ($f eq "fcmp") { - $try .= "\$x <=> \$y;"; - } elsif ($f eq "fadd") { - $try .= "\$x + \$y;"; - } elsif ($f eq "fsub") { - $try .= "\$x - \$y;"; - } elsif ($f eq "fmul") { - $try .= "\$x * \$y;"; - } elsif ($f eq "fdiv") { - $try .= "$setup; \$x / \$y;"; - } elsif ($f eq "fmod") { - $try .= "\$x % \$y;"; - } else { warn "Unknown op '$f'"; } - } - $ans1 = eval $try; - if ($ans =~ m|^/(.*)$|) - { - my $pat = $1; - if ($ans1 =~ /$pat/) - { - ok (1,1); - } - else - { - print "# '$try' expected: /$pat/ got: '$ans1'\n" if !ok(1,0); - } - } - else - { - if ($ans eq "") - { - ok_undef ($ans1); - } - else - { - print "# Tried: '$try'\n" if !ok ($ans1, $ans); - } - } # end pattern or string - } - } # end while - -# all done - -############################################################################### -# Perl 5.005 does not like ok ($x,undef) - -sub ok_undef - { - my $x = shift; - - ok (1,1) and return if !defined $x; - ok ($x,'undef'); - } - -__END__ -&as_number -0:0 -1:1 -1.2:1 -2.345:2 --2:-2 --123.456:-123 --200:-200 -&binf -1:+:+inf -2:-:-inf -3:abc:+inf -&bsstr -+inf:+inf --inf:-inf -abc:NaN -&fnorm -+inf:+inf --inf:-inf -+infinity:NaN -+-inf:NaN -abc:NaN - 1 a:NaN -1bcd2:NaN -11111b:NaN -+1z:NaN --1z:NaN -0:0 -+0:0 -+00:0 -+0_0_0:0 -000000_0000000_00000:0 --0:0 --0000:0 -+1:1 -+01:1 -+001:1 -+00000100000:100000 -123456789:123456789 --1:-1 --01:-1 --001:-1 --123456789:-123456789 --00000100000:-100000 -123.456a:NaN -123.456:123.456 -0.01:0.01 -.002:0.002 -+.2:0.2 --0.0003:-0.0003 --.0000000004:-0.0000000004 -123456E2:12345600 -123456E-2:1234.56 --123456E2:-12345600 --123456E-2:-1234.56 -1e1:10 -2e-11:0.00000000002 --3e111:-3000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 --4e-1111:-0.0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000004 -&fpow -2:2:4 -1:2:1 -1:3:1 --1:2:1 --1:3:-1 -123.456:2:15241.383936 -2:-2:0.25 -2:-3:0.125 -128:-2:0.00006103515625 -&fneg -abc:NaN -+0:0 -+1:-1 --1:1 -+123456789:-123456789 --123456789:123456789 -+123.456789:-123.456789 --123456.789:123456.789 -&fabs -abc:NaN -+0:0 -+1:1 --1:1 -+123456789:123456789 --123456789:123456789 -+123.456789:123.456789 --123456.789:123456.789 -&fround -$rnd_mode = "trunc" -+10123456789:5:10123000000 --10123456789:5:-10123000000 -+10123456789.123:5:10123000000 --10123456789.123:5:-10123000000 -+10123456789:9:10123456700 --10123456789:9:-10123456700 -+101234500:6:101234000 --101234500:6:-101234000 -$rnd_mode = "zero" -+20123456789:5:20123000000 --20123456789:5:-20123000000 -+20123456789.123:5:20123000000 --20123456789.123:5:-20123000000 -+20123456789:9:20123456800 --20123456789:9:-20123456800 -+201234500:6:201234000 --201234500:6:-201234000 -$rnd_mode = "+inf" -+30123456789:5:30123000000 --30123456789:5:-30123000000 -+30123456789.123:5:30123000000 --30123456789.123:5:-30123000000 -+30123456789:9:30123456800 --30123456789:9:-30123456800 -+301234500:6:301235000 --301234500:6:-301234000 -$rnd_mode = "-inf" -+40123456789:5:40123000000 --40123456789:5:-40123000000 -+40123456789.123:5:40123000000 --40123456789.123:5:-40123000000 -+40123456789:9:40123456800 --40123456789:9:-40123456800 -+401234500:6:401234000 --401234500:6:-401235000 -$rnd_mode = "odd" -+50123456789:5:50123000000 --50123456789:5:-50123000000 -+50123456789.123:5:50123000000 --50123456789.123:5:-50123000000 -+50123456789:9:50123456800 --50123456789:9:-50123456800 -+501234500:6:501235000 --501234500:6:-501235000 -$rnd_mode = "even" -+60123456789:5:60123000000 --60123456789:5:-60123000000 -+60123456789:9:60123456800 --60123456789:9:-60123456800 -+601234500:6:601234000 --601234500:6:-601234000 -+60123456789.0123:5:60123000000 --60123456789.0123:5:-60123000000 -&ffround -$rnd_mode = "trunc" -+1.23:-1:1.2 -+1.234:-1:1.2 -+1.2345:-1:1.2 -+1.23:-2:1.23 -+1.234:-2:1.23 -+1.2345:-2:1.23 -+1.23:-3:1.23 -+1.234:-3:1.234 -+1.2345:-3:1.234 --1.23:-1:-1.2 -+1.27:-1:1.2 --1.27:-1:-1.2 -+1.25:-1:1.2 --1.25:-1:-1.2 -+1.35:-1:1.3 --1.35:-1:-1.3 --0.0061234567890:-1:0 --0.0061:-1:0 --0.00612:-1:0 --0.00612:-2:0 --0.006:-1:0 --0.006:-2:0 --0.0006:-2:0 --0.0006:-3:0 --0.0065:-3:/-0\.006|-6e-03 --0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 --0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 -0.05:0:0 -0.5:0:0 -0.51:0:0 -0.41:0:0 -$rnd_mode = "zero" -+2.23:-1:/2.2(?:0{5}\d+)? --2.23:-1:/-2.2(?:0{5}\d+)? -+2.27:-1:/2.(?:3|29{5}\d+) --2.27:-1:/-2.(?:3|29{5}\d+) -+2.25:-1:/2.2(?:0{5}\d+)? --2.25:-1:/-2.2(?:0{5}\d+)? -+2.35:-1:/2.(?:3|29{5}\d+) --2.35:-1:/-2.(?:3|29{5}\d+) --0.0065:-1:0 --0.0065:-2:/-0\.01|-1e-02 --0.0065:-3:/-0\.006|-6e-03 --0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 --0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 -0.05:0:0 -0.5:0:0 -0.51:0:1 -0.41:0:0 -$rnd_mode = "+inf" -+3.23:-1:/3.2(?:0{5}\d+)? --3.23:-1:/-3.2(?:0{5}\d+)? -+3.27:-1:/3.(?:3|29{5}\d+) --3.27:-1:/-3.(?:3|29{5}\d+) -+3.25:-1:/3.(?:3|29{5}\d+) --3.25:-1:/-3.2(?:0{5}\d+)? -+3.35:-1:/3.(?:4|39{5}\d+) --3.35:-1:/-3.(?:3|29{5}\d+) --0.0065:-1:0 --0.0065:-2:/-0\.01|-1e-02 --0.0065:-3:/-0\.006|-6e-03 --0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 --0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 -0.05:0:0 -0.5:0:1 -0.51:0:1 -0.41:0:0 -$rnd_mode = "-inf" -+4.23:-1:/4.2(?:0{5}\d+)? --4.23:-1:/-4.2(?:0{5}\d+)? -+4.27:-1:/4.(?:3|29{5}\d+) --4.27:-1:/-4.(?:3|29{5}\d+) -+4.25:-1:/4.2(?:0{5}\d+)? --4.25:-1:/-4.(?:3|29{5}\d+) -+4.35:-1:/4.(?:3|29{5}\d+) --4.35:-1:/-4.(?:4|39{5}\d+) --0.0065:-1:0 --0.0065:-2:/-0\.01|-1e-02 --0.0065:-3:/-0\.007|-7e-03 --0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 --0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 -0.05:0:0 -0.5:0:0 -0.51:0:1 -0.41:0:0 -$rnd_mode = "odd" -+5.23:-1:/5.2(?:0{5}\d+)? --5.23:-1:/-5.2(?:0{5}\d+)? -+5.27:-1:/5.(?:3|29{5}\d+) --5.27:-1:/-5.(?:3|29{5}\d+) -+5.25:-1:/5.(?:3|29{5}\d+) --5.25:-1:/-5.(?:3|29{5}\d+) -+5.35:-1:/5.(?:3|29{5}\d+) --5.35:-1:/-5.(?:3|29{5}\d+) --0.0065:-1:0 --0.0065:-2:/-0\.01|-1e-02 --0.0065:-3:/-0\.007|-7e-03 --0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 --0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 -0.05:0:0 -0.5:0:1 -0.51:0:1 -0.41:0:0 -$rnd_mode = "even" -+6.23:-1:/6.2(?:0{5}\d+)? --6.23:-1:/-6.2(?:0{5}\d+)? -+6.27:-1:/6.(?:3|29{5}\d+) --6.27:-1:/-6.(?:3|29{5}\d+) -+6.25:-1:/6.(?:2(?:0{5}\d+)?|29{5}\d+) --6.25:-1:/-6.(?:2(?:0{5}\d+)?|29{5}\d+) -+6.35:-1:/6.(?:4|39{5}\d+|29{8}\d+) --6.35:-1:/-6.(?:4|39{5}\d+|29{8}\d+) --0.0065:-1:0 --0.0065:-2:/-0\.01|-1e-02 --0.0065:-3:/-0\.006|-7e-03 --0.0065:-4:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 --0.0065:-5:/-0\.006(?:5|49{5}\d+)|-6\.5e-03 -0.05:0:0 -0.5:0:0 -0.51:0:1 -0.41:0:0 -0.01234567:-3:0.012 -0.01234567:-4:0.0123 -0.01234567:-5:0.01235 -0.01234567:-6:0.012346 -0.01234567:-7:0.0123457 -0.01234567:-8:0.01234567 -0.01234567:-9:0.01234567 -0.01234567:-12:0.01234567 -&fcmp -abc:abc: -abc:+0: -+0:abc: -+0:+0:0 --1:+0:-1 -+0:-1:1 -+1:+0:1 -+0:+1:-1 --1:+1:-1 -+1:-1:1 --1:-1:0 -+1:+1:0 --1.1:0:-1 -+0:-1.1:1 -+1.1:+0:1 -+0:+1.1:-1 -+123:+123:0 -+123:+12:1 -+12:+123:-1 --123:-123:0 --123:-12:-1 --12:-123:1 -+123:+124:-1 -+124:+123:1 --123:-124:1 --124:-123:-1 -0:0.01:-1 -0:0.0001:-1 -0:-0.0001:1 -0:-0.1:1 -0.1:0:1 -0.00001:0:1 --0.0001:0:-1 --0.1:0:-1 -0:0.0001234:-1 -0:-0.0001234:1 -0.0001234:0:1 --0.0001234:0:-1 -0.0001:0.0005:-1 -0.0005:0.0001:1 -0.005:0.0001:1 -0.001:0.0005:1 -0.000001:0.0005:-2 # <0, but can't test this -0.00000123:0.0005:-2 # <0, but can't test this -0.00512:0.0001:1 -0.005:0.000112:1 -0.00123:0.0005:1 -&fadd -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:0 -+1:+0:1 -+0:+1:1 -+1:+1:2 --1:+0:-1 -+0:-1:-1 --1:-1:-2 --1:+1:0 -+1:-1:0 -+9:+1:10 -+99:+1:100 -+999:+1:1000 -+9999:+1:10000 -+99999:+1:100000 -+999999:+1:1000000 -+9999999:+1:10000000 -+99999999:+1:100000000 -+999999999:+1:1000000000 -+9999999999:+1:10000000000 -+99999999999:+1:100000000000 -+10:-1:9 -+100:-1:99 -+1000:-1:999 -+10000:-1:9999 -+100000:-1:99999 -+1000000:-1:999999 -+10000000:-1:9999999 -+100000000:-1:99999999 -+1000000000:-1:999999999 -+10000000000:-1:9999999999 -+123456789:+987654321:1111111110 --123456789:+987654321:864197532 --123456789:-987654321:-1111111110 -+123456789:-987654321:-864197532 -&fsub -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:0 -+1:+0:1 -+0:+1:-1 -+1:+1:0 --1:+0:-1 -+0:-1:1 --1:-1:0 --1:+1:-2 -+1:-1:2 -+9:+1:8 -+99:+1:98 -+999:+1:998 -+9999:+1:9998 -+99999:+1:99998 -+999999:+1:999998 -+9999999:+1:9999998 -+99999999:+1:99999998 -+999999999:+1:999999998 -+9999999999:+1:9999999998 -+99999999999:+1:99999999998 -+10:-1:11 -+100:-1:101 -+1000:-1:1001 -+10000:-1:10001 -+100000:-1:100001 -+1000000:-1:1000001 -+10000000:-1:10000001 -+100000000:-1:100000001 -+1000000000:-1:1000000001 -+10000000000:-1:10000000001 -+123456789:+987654321:-864197532 --123456789:+987654321:-1111111110 --123456789:-987654321:864197532 -+123456789:-987654321:1111111110 -&fmul -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:0 -+0:+1:0 -+1:+0:0 -+0:-1:0 --1:+0:0 -+123456789123456789:+0:0 -+0:+123456789123456789:0 --1:-1:1 --1:+1:-1 -+1:-1:-1 -+1:+1:1 -+2:+3:6 --2:+3:-6 -+2:-3:-6 --2:-3:6 -+111:+111:12321 -+10101:+10101:102030201 -+1001001:+1001001:1002003002001 -+100010001:+100010001:10002000300020001 -+10000100001:+10000100001:100002000030000200001 -+11111111111:+9:99999999999 -+22222222222:+9:199999999998 -+33333333333:+9:299999999997 -+44444444444:+9:399999999996 -+55555555555:+9:499999999995 -+66666666666:+9:599999999994 -+77777777777:+9:699999999993 -+88888888888:+9:799999999992 -+99999999999:+9:899999999991 -&fdiv -$div_scale = 40; $Math::BigFloat::rnd_mode = 'even' -abc:abc:NaN -abc:+1:abc:NaN -+1:abc:NaN -+0:+0:NaN -+0:+1:0 -+1:+0:NaN -+0:-1:0 --1:+0:NaN -+1:+1:1 --1:-1:1 -+1:-1:-1 --1:+1:-1 -+1:+2:0.5 -+2:+1:2 -+10:+5:2 -+100:+4:25 -+1000:+8:125 -+10000:+16:625 -+10000:-16:-625 -+999999999999:+9:111111111111 -+999999999999:+99:10101010101 -+999999999999:+999:1001001001 -+999999999999:+9999:100010001 -+999999999999999:+99999:10000100001 -+1000000000:+9:111111111.1111111111111111111111111111111 -+2000000000:+9:222222222.2222222222222222222222222222222 -+3000000000:+9:333333333.3333333333333333333333333333333 -+4000000000:+9:444444444.4444444444444444444444444444444 -+5000000000:+9:555555555.5555555555555555555555555555556 -+6000000000:+9:666666666.6666666666666666666666666666667 -+7000000000:+9:777777777.7777777777777777777777777777778 -+8000000000:+9:888888888.8888888888888888888888888888889 -+9000000000:+9:1000000000 -+35500000:+113:314159.2920353982300884955752212389380531 -+71000000:+226:314159.2920353982300884955752212389380531 -+106500000:+339:314159.2920353982300884955752212389380531 -+1000000000:+3:333333333.3333333333333333333333333333333 -$div_scale = 20 -+1000000000:+9:111111111.11111111111 -+2000000000:+9:222222222.22222222222 -+3000000000:+9:333333333.33333333333 -+4000000000:+9:444444444.44444444444 -+5000000000:+9:555555555.55555555556 -+6000000000:+9:666666666.66666666667 -+7000000000:+9:777777777.77777777778 -+8000000000:+9:888888888.88888888889 -+9000000000:+9:1000000000 -# following two cases are the "old" behaviour, but are now (>v0.01) different -#+35500000:+113:314159.292035398230088 -#+71000000:+226:314159.292035398230088 -+35500000:+113:314159.29203539823009 -+71000000:+226:314159.29203539823009 -+106500000:+339:314159.29203539823009 -+1000000000:+3:333333333.33333333333 -$div_scale = 1 -# div_scale will be 3 since $x has 3 digits -+124:+3:41.3 -# reset scale for further tests -$div_scale = 40 -&fmod -+0:0:NaN -+0:1:0 -+3:1:0 -#+5:2:1 -#+9:4:1 -#+9:5:4 -#+9000:56:40 -#+56:9000:56 -&fsqrt -+0:0 --1:NaN --2:NaN --16:NaN --123.45:NaN -+1:1 -#+1.44:1.2 -#+2:1.41421356237309504880168872420969807857 -#+4:2 -#+16:4 -#+100:10 -#+123.456:11.11107555549866648462149404118219234119 -#+15241.38393:123.456 -&is_odd -abc:0 -0:0 --1:1 --3:1 -1:1 -3:1 -1000001:1 -1000002:0 -2:0 -&is_even -abc:0 -0:1 --1:0 --3:0 -1:0 -3:0 -1000001:0 -1000002:1 -2:1 -&is_zero -NaNzero:0 -0:1 --1:0 -1:0 -&is_one -0:0 -2:0 -1:1 --1:0 --2:0 -&_set -NaN:2:2 -2:abc:NaN -1:-1:-1 -2:1:1 --2:0:0 -128:-2:-2 -&bfloor -0:0 -abc:NaN -+inf:+inf --inf:-inf -1:1 --51:-51 --51.2:-52 -12.2:12 -&bceil -0:0 -abc:NaN -+inf:+inf --inf:-inf -1:1 --51:-51 --51.2:-51 -12.2:13 diff --git a/t/lib/bigint.t b/t/lib/bigint.t deleted file mode 100755 index 034c5c6457..0000000000 --- a/t/lib/bigint.t +++ /dev/null @@ -1,282 +0,0 @@ -#!./perl - -BEGIN { @INC = '../lib' } -require "bigint.pl"; - -$test = 0; -$| = 1; -print "1..246\n"; -while (<DATA>) { - chop; - if (/^&/) { - $f = $_; - } else { - ++$test; - @args = split(/:/,$_,99); - $ans = pop(@args); - $try = "$f('" . join("','", @args) . "');"; - if (($ans1 = eval($try)) eq $ans) { - print "ok $test\n"; - } else { - print "not ok $test\n"; - print "# '$try' expected: '$ans' got: '$ans1'\n"; - } - } -} -__END__ -&bnorm -abc:NaN - 1 a:NaN -1bcd2:NaN -11111b:NaN -+1z:NaN --1z:NaN -0:+0 -+0:+0 -+00:+0 -+0 0 0:+0 -000000 0000000 00000:+0 --0:+0 --0000:+0 -+1:+1 -+01:+1 -+001:+1 -+00000100000:+100000 -123456789:+123456789 --1:-1 --01:-1 --001:-1 --123456789:-123456789 --00000100000:-100000 -&bneg -abd:NaN -+0:+0 -+1:-1 --1:+1 -+123456789:-123456789 --123456789:+123456789 -&babs -abc:NaN -+0:+0 -+1:+1 --1:+1 -+123456789:+123456789 --123456789:+123456789 -&bcmp -abc:abc: -abc:+0: -+0:abc: -+0:+0:0 --1:+0:-1 -+0:-1:1 -+1:+0:1 -+0:+1:-1 --1:+1:-1 -+1:-1:1 --1:-1:0 -+1:+1:0 -+123:+123:0 -+123:+12:1 -+12:+123:-1 --123:-123:0 --123:-12:-1 --12:-123:1 -+123:+124:-1 -+124:+123:1 --123:-124:1 --124:-123:-1 -&badd -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:+0 -+1:+0:+1 -+0:+1:+1 -+1:+1:+2 --1:+0:-1 -+0:-1:-1 --1:-1:-2 --1:+1:+0 -+1:-1:+0 -+9:+1:+10 -+99:+1:+100 -+999:+1:+1000 -+9999:+1:+10000 -+99999:+1:+100000 -+999999:+1:+1000000 -+9999999:+1:+10000000 -+99999999:+1:+100000000 -+999999999:+1:+1000000000 -+9999999999:+1:+10000000000 -+99999999999:+1:+100000000000 -+10:-1:+9 -+100:-1:+99 -+1000:-1:+999 -+10000:-1:+9999 -+100000:-1:+99999 -+1000000:-1:+999999 -+10000000:-1:+9999999 -+100000000:-1:+99999999 -+1000000000:-1:+999999999 -+10000000000:-1:+9999999999 -+123456789:+987654321:+1111111110 --123456789:+987654321:+864197532 --123456789:-987654321:-1111111110 -+123456789:-987654321:-864197532 -&bsub -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:+0 -+1:+0:+1 -+0:+1:-1 -+1:+1:+0 --1:+0:-1 -+0:-1:+1 --1:-1:+0 --1:+1:-2 -+1:-1:+2 -+9:+1:+8 -+99:+1:+98 -+999:+1:+998 -+9999:+1:+9998 -+99999:+1:+99998 -+999999:+1:+999998 -+9999999:+1:+9999998 -+99999999:+1:+99999998 -+999999999:+1:+999999998 -+9999999999:+1:+9999999998 -+99999999999:+1:+99999999998 -+10:-1:+11 -+100:-1:+101 -+1000:-1:+1001 -+10000:-1:+10001 -+100000:-1:+100001 -+1000000:-1:+1000001 -+10000000:-1:+10000001 -+100000000:-1:+100000001 -+1000000000:-1:+1000000001 -+10000000000:-1:+10000000001 -+123456789:+987654321:-864197532 --123456789:+987654321:-1111111110 --123456789:-987654321:+864197532 -+123456789:-987654321:+1111111110 -&bmul -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:+0 -+0:+1:+0 -+1:+0:+0 -+0:-1:+0 --1:+0:+0 -+123456789123456789:+0:+0 -+0:+123456789123456789:+0 --1:-1:+1 --1:+1:-1 -+1:-1:-1 -+1:+1:+1 -+2:+3:+6 --2:+3:-6 -+2:-3:-6 --2:-3:+6 -+111:+111:+12321 -+10101:+10101:+102030201 -+1001001:+1001001:+1002003002001 -+100010001:+100010001:+10002000300020001 -+10000100001:+10000100001:+100002000030000200001 -+11111111111:+9:+99999999999 -+22222222222:+9:+199999999998 -+33333333333:+9:+299999999997 -+44444444444:+9:+399999999996 -+55555555555:+9:+499999999995 -+66666666666:+9:+599999999994 -+77777777777:+9:+699999999993 -+88888888888:+9:+799999999992 -+99999999999:+9:+899999999991 -&bdiv -abc:abc:NaN -abc:+1:abc:NaN -+1:abc:NaN -+0:+0:NaN -+0:+1:+0 -+1:+0:NaN -+0:-1:+0 --1:+0:NaN -+1:+1:+1 --1:-1:+1 -+1:-1:-1 --1:+1:-1 -+1:+2:+0 -+2:+1:+2 -+1000000000:+9:+111111111 -+2000000000:+9:+222222222 -+3000000000:+9:+333333333 -+4000000000:+9:+444444444 -+5000000000:+9:+555555555 -+6000000000:+9:+666666666 -+7000000000:+9:+777777777 -+8000000000:+9:+888888888 -+9000000000:+9:+1000000000 -+35500000:+113:+314159 -+71000000:+226:+314159 -+106500000:+339:+314159 -+1000000000:+3:+333333333 -+10:+5:+2 -+100:+4:+25 -+1000:+8:+125 -+10000:+16:+625 -+999999999999:+9:+111111111111 -+999999999999:+99:+10101010101 -+999999999999:+999:+1001001001 -+999999999999:+9999:+100010001 -+999999999999999:+99999:+10000100001 -&bmod -abc:abc:NaN -abc:+1:abc:NaN -+1:abc:NaN -+0:+0:NaN -+0:+1:+0 -+1:+0:NaN -+0:-1:+0 --1:+0:NaN -+1:+1:+0 --1:-1:+0 -+1:-1:+0 --1:+1:+0 -+1:+2:+1 -+2:+1:+0 -+1000000000:+9:+1 -+2000000000:+9:+2 -+3000000000:+9:+3 -+4000000000:+9:+4 -+5000000000:+9:+5 -+6000000000:+9:+6 -+7000000000:+9:+7 -+8000000000:+9:+8 -+9000000000:+9:+0 -+35500000:+113:+33 -+71000000:+226:+66 -+106500000:+339:+99 -+1000000000:+3:+1 -+10:+5:+0 -+100:+4:+0 -+1000:+8:+0 -+10000:+16:+0 -+999999999999:+9:+0 -+999999999999:+99:+0 -+999999999999:+999:+0 -+999999999999:+9999:+0 -+999999999999999:+99999:+0 -&bgcd -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:+0 -+0:+1:+1 -+1:+0:+1 -+1:+1:+1 -+2:+3:+1 -+3:+2:+1 -+100:+625:+25 -+4096:+81:+1 diff --git a/t/lib/bigintpm.t b/t/lib/bigintpm.t deleted file mode 100755 index f819104885..0000000000 --- a/t/lib/bigintpm.t +++ /dev/null @@ -1,1238 +0,0 @@ -#!/usr/bin/perl -w - -use strict; -use Test; - -BEGIN - { - $| = 1; - # chdir 't' if -d 't'; - unshift @INC, '../lib'; # for running manually - plan tests => 1190; - } - -############################################################################## -# for testing inheritance of _swap - -package Math::Foo; - -use Math::BigInt; -use vars qw/@ISA/; -@ISA = (qw/Math::BigInt/); - -use overload -# customized overload for sub, since original does not use swap there -'-' => sub { my @a = ref($_[0])->_swap(@_); - $a[0]->bsub($a[1])}; - -sub _swap - { - # a fake _swap, which reverses the params - my $self = shift; # for override in subclass - if ($_[2]) - { - my $c = ref ($_[0] ) || 'Math::Foo'; - return ( $_[0]->copy(), $_[1] ); - } - else - { - return ( Math::Foo->new($_[1]), $_[0] ); - } - } - -############################################################################## -package main; - -use Math::BigInt; - -my (@args,$f,$try,$x,$y,$z,$a,$exp,$ans,$ans1,@a,$m,$e,$round_mode); - -while (<DATA>) - { - chop; - next if /^#/; # skip comments - if (s/^&//) - { - $f = $_; - } - elsif (/^\$/) - { - $round_mode = $_; - $round_mode =~ s/^\$/Math::BigInt->/; - # print "$round_mode\n"; - } - else - { - @args = split(/:/,$_,99); - $ans = pop(@args); - $try = "\$x = Math::BigInt->new(\"$args[0]\");"; - if ($f eq "bnorm"){ - # $try .= '$x+0;'; - } elsif ($f eq "_set") { - $try .= '$x->_set($args[1]); "$x";'; - } elsif ($f eq "is_zero") { - $try .= '$x->is_zero()+0;'; - } elsif ($f eq "is_one") { - $try .= '$x->is_one()+0;'; - } elsif ($f eq "is_odd") { - $try .= '$x->is_odd()+0;'; - } elsif ($f eq "is_even") { - $try .= '$x->is_even()+0;'; - } elsif ($f eq "binf") { - $try .= "\$x->binf('$args[1]');"; - } elsif ($f eq "bfloor") { - $try .= '$x->bfloor();'; - } elsif ($f eq "bceil") { - $try .= '$x->bceil();'; - } elsif ($f eq "is_inf") { - $try .= "\$x->is_inf('$args[1]')+0;"; - } elsif ($f eq "bsstr") { - $try .= '$x->bsstr();'; - } elsif ($f eq "bneg") { - $try .= '-$x;'; - } elsif ($f eq "babs") { - $try .= 'abs $x;'; - } elsif ($f eq "binc") { - $try .= '++$x;'; - } elsif ($f eq "bdec") { - $try .= '--$x;'; - }elsif ($f eq "bnot") { - $try .= '~$x;'; - }elsif ($f eq "bsqrt") { - $try .= '$x->bsqrt();'; - }elsif ($f eq "length") { - $try .= "\$x->length();"; - }elsif ($f eq "bround") { - $try .= "$round_mode; \$x->bround($args[1]);"; - }elsif ($f eq "exponent"){ - $try .= '$x = $x->exponent()->bstr();'; - }elsif ($f eq "mantissa"){ - $try .= '$x = $x->mantissa()->bstr();'; - }elsif ($f eq "parts"){ - $try .= "(\$m,\$e) = \$x->parts();"; - $try .= '$m = $m->bstr(); $m = "NaN" if !defined $m;'; - $try .= '$e = $e->bstr(); $e = "NaN" if !defined $e;'; - $try .= '"$m,$e";'; - } else { - $try .= "\$y = new Math::BigInt \"$args[1]\";"; - if ($f eq "bcmp"){ - $try .= '$x <=> $y;'; - }elsif ($f eq "bacmp"){ - $try .= '$x->bacmp($y);'; - }elsif ($f eq "badd"){ - $try .= "\$x + \$y;"; - }elsif ($f eq "bsub"){ - $try .= "\$x - \$y;"; - }elsif ($f eq "bmul"){ - $try .= "\$x * \$y;"; - }elsif ($f eq "bdiv"){ - $try .= "\$x / \$y;"; - }elsif ($f eq "bmod"){ - $try .= "\$x % \$y;"; - }elsif ($f eq "bgcd") - { - if (defined $args[2]) - { - $try .= " \$z = new Math::BigInt \"$args[2]\"; "; - } - $try .= "Math::BigInt::bgcd(\$x, \$y"; - $try .= ", \$z" if (defined $args[2]); - $try .= " );"; - } - elsif ($f eq "blcm") - { - if (defined $args[2]) - { - $try .= " \$z = new Math::BigInt \"$args[2]\"; "; - } - $try .= "Math::BigInt::blcm(\$x, \$y"; - $try .= ", \$z" if (defined $args[2]); - $try .= " );"; - }elsif ($f eq "blsft"){ - if (defined $args[2]) - { - $try .= "\$x->blsft(\$y,$args[2]);"; - } - else - { - $try .= "\$x << \$y;"; - } - }elsif ($f eq "brsft"){ - if (defined $args[2]) - { - $try .= "\$x->brsft(\$y,$args[2]);"; - } - else - { - $try .= "\$x >> \$y;"; - } - }elsif ($f eq "band"){ - $try .= "\$x & \$y;"; - }elsif ($f eq "bior"){ - $try .= "\$x | \$y;"; - }elsif ($f eq "bxor"){ - $try .= "\$x ^ \$y;"; - }elsif ($f eq "bpow"){ - $try .= "\$x ** \$y;"; - }elsif ($f eq "digit"){ - $try = "\$x = Math::BigInt->new(\"$args[0]\"); \$x->digit($args[1]);"; - } else { warn "Unknown op '$f'"; } - } - # print "trying $try\n"; - $ans1 = eval $try; - $ans =~ s/^[+]([0-9])/$1/; # remove leading '+' - if ($ans eq "") - { - ok_undef ($ans1); - } - else - { - #print "try: $try ans: $ans1 $ans\n"; - print "# Tried: '$try'\n" if !ok ($ans1, $ans); - } - # check internal state of number objects - is_valid($ans1) if ref $ans1; - } - } # endwhile data tests -close DATA; - -# test whether constant works or not -$try = "use Math::BigInt (1.31,'babs',':constant');"; -$try .= ' $x = 2**150; babs($x); $x = "$x";'; -$ans1 = eval $try; - -ok ( $ans1, "1427247692705959881058285969449495136382746624"); - -# test some more -@a = (); -for (my $i = 1; $i < 10; $i++) - { - push @a, $i; - } -ok "@a", "1 2 3 4 5 6 7 8 9"; - -# test whether selfmultiplication works correctly (result is 2**64) -$try = '$x = new Math::BigInt "+4294967296";'; -$try .= '$a = $x->bmul($x);'; -$ans1 = eval $try; -print "# Tried: '$try'\n" if !ok ($ans1, Math::BigInt->new(2) ** 64); - -# test whether op detroys args or not (should better not) - -$x = new Math::BigInt (3); -$y = new Math::BigInt (4); -$z = $x & $y; -ok ($x,3); -ok ($y,4); -ok ($z,0); -$z = $x | $y; -ok ($x,3); -ok ($y,4); -ok ($z,7); -$x = new Math::BigInt (1); -$y = new Math::BigInt (2); -$z = $x | $y; -ok ($x,1); -ok ($y,2); -ok ($z,3); - -$x = new Math::BigInt (5); -$y = new Math::BigInt (4); -$z = $x ^ $y; -ok ($x,5); -ok ($y,4); -ok ($z,1); - -$x = new Math::BigInt (-5); $y = -$x; -ok ($x, -5); - -$x = new Math::BigInt (-5); $y = abs($x); -ok ($x, -5); - -# check whether overloading cmp works -$try = "\$x = Math::BigInt->new(0);"; -$try .= "\$y = 10;"; -$try .= "'false' if \$x ne \$y;"; -$ans = eval $try; -print "# For '$try'\n" if (!ok "$ans" , "false" ); - -# we cant test for working cmpt with other objects here, we would need a dummy -# object with stringify overload for this. see Math::String tests - -############################################################################### -# check shortcuts -$try = "\$x = Math::BigInt->new(1); \$x += 9;"; -$try .= "'ok' if \$x == 10;"; -$ans = eval $try; -print "# For '$try'\n" if (!ok "$ans" , "ok" ); - -$try = "\$x = Math::BigInt->new(1); \$x -= 9;"; -$try .= "'ok' if \$x == -8;"; -$ans = eval $try; -print "# For '$try'\n" if (!ok "$ans" , "ok" ); - -$try = "\$x = Math::BigInt->new(1); \$x *= 9;"; -$try .= "'ok' if \$x == 9;"; -$ans = eval $try; -print "# For '$try'\n" if (!ok "$ans" , "ok" ); - -$try = "\$x = Math::BigInt->new(10); \$x /= 2;"; -$try .= "'ok' if \$x == 5;"; -$ans = eval $try; -print "# For '$try'\n" if (!ok "$ans" , "ok" ); - -############################################################################### -# check reversed order of arguments -$try = "\$x = Math::BigInt->new(10); \$x = 2 ** \$x;"; -$try .= "'ok' if \$x == 1024;"; $ans = eval $try; -print "# For '$try'\n" if (!ok "$ans" , "ok" ); - -$try = "\$x = Math::BigInt->new(10); \$x = 2 * \$x;"; -$try .= "'ok' if \$x == 20;"; $ans = eval $try; -print "# For '$try'\n" if (!ok "$ans" , "ok" ); - -$try = "\$x = Math::BigInt->new(10); \$x = 2 + \$x;"; -$try .= "'ok' if \$x == 12;"; $ans = eval $try; -print "# For '$try'\n" if (!ok "$ans" , "ok" ); - -$try = "\$x = Math::BigInt->new(10); \$x = 2 - \$x;"; -$try .= "'ok' if \$x == -8;"; $ans = eval $try; -print "# For '$try'\n" if (!ok "$ans" , "ok" ); - -$try = "\$x = Math::BigInt->new(10); \$x = 20 / \$x;"; -$try .= "'ok' if \$x == 2;"; $ans = eval $try; -print "# For '$try'\n" if (!ok "$ans" , "ok" ); - -############################################################################### -# check badd(4,5) form - -$try = "\$x = Math::BigInt::badd(4,5);"; -$try .= "'ok' if \$x == 9;"; -$ans = eval $try; -print "# For '$try'\n" if (!ok "$ans" , "ok" ); - -$try = "\$x = Math::BigInt->badd(4,5);"; -$try .= "'ok' if \$x == 9;"; -$ans = eval $try; -print "# For '$try'\n" if (!ok "$ans" , "ok" ); - -############################################################################### -# check proper length of internal arrays - -$x = Math::BigInt->new(99999); -ok ($x,99999); -ok (scalar @{$x->{value}}, 1); -$x += 1; -ok ($x,100000); -ok (scalar @{$x->{value}}, 2); -$x -= 1; -ok ($x,99999); -ok (scalar @{$x->{value}}, 1); - -############################################################################### -# check numify - -my $BASE = int(1e5); -$x = Math::BigInt->new($BASE-1); ok ($x->numify(),$BASE-1); -$x = Math::BigInt->new(-($BASE-1)); ok ($x->numify(),-($BASE-1)); -$x = Math::BigInt->new($BASE); ok ($x->numify(),$BASE); -$x = Math::BigInt->new(-$BASE); ok ($x->numify(),-$BASE); -$x = Math::BigInt->new( -($BASE*$BASE*1+$BASE*1+1) ); -ok($x->numify(),-($BASE*$BASE*1+$BASE*1+1)); - -############################################################################### -# test bug in _digits with length($c[-1]) where $c[-1] was "00001" instead of 1 - -$x = Math::BigInt->new(99998); $x++; $x++; $x++; $x++; -if ($x > 100000) { ok (1,1) } else { ok ("$x < 100000","$x > 100000"); } - -$x = Math::BigInt->new(100003); $x++; -$y = Math::BigInt->new(1000000); -if ($x < 1000000) { ok (1,1) } else { ok ("$x > 1000000","$x < 1000000"); } - -############################################################################### -# bug in sub where number with at least 6 trailing zeros after any op failed - -$x = Math::BigInt->new(123456); $z = Math::BigInt->new(10000); $z *= 10; -$x -= $z; -ok ($z, 100000); -ok ($x, 23456); - -############################################################################### -# bug with rest "-0" in div, causing further div()s to fail - -$x = Math::BigInt->new(-322056000); ($x,$y) = $x->bdiv('-12882240'); - -ok ($y,'0'); # not '-0' -is_valid($y); - -############################################################################### -# check undefs: NOT DONE YET - -############################################################################### -# bool - -$x = Math::BigInt->new(1); if ($x) { ok (1,1); } else { ok($x,'to be true') } -$x = Math::BigInt->new(0); if (!$x) { ok (1,1); } else { ok($x,'to be false') } - -############################################################################### -# objectify() - -@args = Math::BigInt::objectify(2,4,5); -ok (scalar @args,3); # 'Math::BigInt', 4, 5 -ok ($args[0],'Math::BigInt'); -ok ($args[1],4); -ok ($args[2],5); - -@args = Math::BigInt::objectify(0,4,5); -ok (scalar @args,3); # 'Math::BigInt', 4, 5 -ok ($args[0],'Math::BigInt'); -ok ($args[1],4); -ok ($args[2],5); - -@args = Math::BigInt::objectify(2,4,5); -ok (scalar @args,3); # 'Math::BigInt', 4, 5 -ok ($args[0],'Math::BigInt'); -ok ($args[1],4); -ok ($args[2],5); - -@args = Math::BigInt::objectify(2,4,5,6,7); -ok (scalar @args,5); # 'Math::BigInt', 4, 5, 6, 7 -ok ($args[0],'Math::BigInt'); -ok ($args[1],4); ok (ref($args[1]),$args[0]); -ok ($args[2],5); ok (ref($args[2]),$args[0]); -ok ($args[3],6); ok (ref($args[3]),''); -ok ($args[4],7); ok (ref($args[4]),''); - -@args = Math::BigInt::objectify(2,'Math::BigInt',4,5,6,7); -ok (scalar @args,5); # 'Math::BigInt', 4, 5, 6, 7 -ok ($args[0],'Math::BigInt'); -ok ($args[1],4); ok (ref($args[1]),$args[0]); -ok ($args[2],5); ok (ref($args[2]),$args[0]); -ok ($args[3],6); ok (ref($args[3]),''); -ok ($args[4],7); ok (ref($args[4]),''); - -############################################################################### -# test for flaoting-point input (other tests in bnorm() below) - -$z = 1050000000000000; # may be int on systems with 64bit? -$x = Math::BigInt->new($z); ok ($x->bsstr(),'105e+13'); # not 1.03e+15? -$z = 1e+129; # definitely a float -$x = Math::BigInt->new($z); ok ($x->bsstr(),$z); - -############################################################################### -# prime number tests, also test for **= and length() -# found on: http://www.utm.edu/research/primes/notes/by_year.html - -# ((2^148)-1)/17 -$x = Math::BigInt->new(2); $x **= 148; $x++; $x = $x / 17; -ok ($x,"20988936657440586486151264256610222593863921"); -ok ($x->length(),length "20988936657440586486151264256610222593863921"); - -# MM7 = 2^127-1 -$x = Math::BigInt->new(2); $x **= 127; $x--; -ok ($x,"170141183460469231731687303715884105727"); - -# I am afraid the following is not yet possible due to slowness -# Also, testing for 2 meg output is a bit hard ;) -#$x = new Math::BigInt(2); $x **= 6972593; $x--; - -# 593573509*2^332162+1 has exactly 100.000 digits -# takes over 16 mins and still not complete, so can not be done yet ;) -#$x = Math::BigInt->new(2); $x **= 332162; $x *= "593573509"; $x++; -#ok ($x->digits(),100000); - -############################################################################### -# inheritance and overriding of _swap - -$x = Math::Foo->new(5); -$x = $x - 8; # 8 - 5 instead of 5-8 -ok ($x,3); -ok (ref($x),'Math::Foo'); - -$x = Math::Foo->new(5); -$x = 8 - $x; # 5 - 8 instead of 8 - 5 -ok ($x,-3); -ok (ref($x),'Math::Foo'); - -############################################################################### -# all tests done - -# devel test, see whether valid catches errors -#$x = Math::BigInt->new(0); -#$x->{sign} = '-'; -#is_valid($x); # nok -# -#$x->{sign} = 'e'; -#is_valid($x); # nok -# -#$x->{value}->[0] = undef; -#is_valid($x); # nok -# -#$x->{value}->[0] = 1e6; -#is_valid($x); # nok -# -#$x->{value}->[0] = -2; -#is_valid($x); # nok -# -#$x->{sign} = '+'; -#is_valid($x); # ok - -############################################################################### -# Perl 5.005 does not like ok ($x,undef) - -sub ok_undef - { - my $x = shift; - - ok (1,1) and return if !defined $x; - ok ($x,'undef'); - } - -############################################################################### -# sub to check validity of a BigInt internally, to ensure that no op leaves a -# number object in an invalid state (f.i. "-0") - -sub is_valid - { - my $x = shift; - - my $error = ["",]; - - # ok as reference? - is_okay('ref($x)','Math::BigInt',ref($x),$error); - - # has ok sign? - is_okay('$x->{sign}',"'+', '-', '-inf', '+inf' or 'NaN'",$x->{sign},$error) - if $x->{sign} !~ /^(\+|-|\+inf|-inf|NaN)$/; - - # is not -0? - if (($x->{sign} eq '-') && (@{$x->{value}} == 1) && ($x->{value}->[0] == 0)) - { - is_okay("\$x ne '-0'","0",$x,$error); - } - # all parts are valid? - my $i = 0; my $j = scalar @{$x->{value}}; my $e; my $try; - while ($i < $j) - { - $e = $x->{value}->[$i]; $e = 'undef' unless defined $e; - $try = '=~ /^[\+]?[0-9]+\$/; '."($f, $x, $e)"; - last if $e !~ /^[+]?[0-9]+$/; - $try = ' < 0 || >= 1e5; '."($f, $x, $e)"; - last if $e <0 || $e >= 1e5; - # this test is disabled, since new/bnorm and certain ops (like early out - # in add/sub) are allowed/expected to leave '00000' in some elements - #$try = '=~ /^00+/; '."($f, $x, $e)"; - #last if $e =~ /^00+/; - $i++; - } - is_okay("\$x->{value}->[$i] $try","not $e",$e,$error) - if $i < $j; # trough all? - - # see whether errors crop up - $error->[1] = 'undef' unless defined $error->[1]; - if ($error->[0] ne "") - { - ok ($error->[1],$error->[2]); - print "# Tried: $error->[0]\n"; - } - else - { - ok (1,1); - } - } - -sub is_okay - { - my ($tried,$expected,$try,$error) = @_; - - return if $error->[0] ne ""; # error, no further testing - - @$error = ( $tried, $try, $expected ) if $try ne $expected; - } - -__END__ -&bnorm -# binary input -0babc:NaN -0b123:NaN -0b0:0 --0b0:0 --0b1:-1 -0b0001:1 -0b001:1 -0b011:3 -0b101:5 -0b1000000000000000000000000000000:1073741824 -# hex input --0x0:0 -0xabcdefgh:NaN -0x1234:4660 -0xabcdef:11259375 --0xABCDEF:-11259375 --0x1234:-4660 -0x12345678:305419896 -# inf input -+inf:+inf --inf:-inf -0inf:NaN -# normal input -:NaN -abc:NaN - 1 a:NaN -1bcd2:NaN -11111b:NaN -+1z:NaN --1z:NaN -0:0 -+0:0 -+00:0 -+000:0 -000000000000000000:0 --0:0 --0000:0 -+1:1 -+01:1 -+001:1 -+00000100000:100000 -123456789:123456789 --1:-1 --01:-1 --001:-1 --123456789:-123456789 --00000100000:-100000 -1_2_3:123 -_123:NaN -_123_:NaN -_123_:NaN -1__23:NaN -10000000000E-1_0:1 -1E2:100 -1E1:10 -1E0:1 -E1:NaN -E23:NaN -1.23E2:123 -1.23E1:NaN -1.23E-1:NaN -100E-1:10 -# floating point input -1.01E2:101 -1010E-1:101 --1010E0:-1010 --1010E1:-10100 --1010E-2:NaN --1.01E+1:NaN --1.01E-1:NaN -&binf -1:+:+inf -2:-:-inf -3:abc:+inf -&is_inf -+inf::1 --inf::1 -abc::0 -1::0 -NaN::0 --1::0 -+inf:-:0 -+inf:+:1 --inf:-:1 --inf:+:0 -&blsft -abc:abc:NaN -+2:+2:+8 -+1:+32:+4294967296 -+1:+48:+281474976710656 -+8:-2:NaN -# excercise base 10 -+12345:4:10:123450000 --1234:0:10:-1234 -+1234:0:10:+1234 -+2:2:10:200 -+12:2:10:1200 -+1234:-3:10:NaN -1234567890123:12:10:1234567890123000000000000 -&brsft -abc:abc:NaN -+8:+2:+2 -+4294967296:+32:+1 -+281474976710656:+48:+1 -+2:-2:NaN -# excercise base 10 --1234:0:10:-1234 -+1234:0:10:+1234 -+200:2:10:2 -+1234:3:10:1 -+1234:2:10:12 -+1234:-3:10:NaN -310000:4:10:31 -12300000:5:10:123 -1230000000000:10:10:123 -09876123456789067890:12:10:9876123 -1234561234567890123:13:10:123456 -&bsstr -1e+34:1e+34 -123.456E3:123456e+0 -100:1e+2 -abc:NaN -&bneg -abd:NaN -+0:+0 -+1:-1 --1:+1 -+123456789:-123456789 --123456789:+123456789 -&babs -abc:NaN -+0:+0 -+1:+1 --1:+1 -+123456789:+123456789 --123456789:+123456789 -&bcmp -abc:abc: -abc:+0: -+0:abc: -+0:+0:0 --1:+0:-1 -+0:-1:1 -+1:+0:1 -+0:+1:-1 --1:+1:-1 -+1:-1:1 --1:-1:0 -+1:+1:0 -+123:+123:0 -+123:+12:1 -+12:+123:-1 --123:-123:0 --123:-12:-1 --12:-123:1 -+123:+124:-1 -+124:+123:1 --123:-124:1 --124:-123:-1 -+100:+5:1 --123456789:+987654321:-1 -+123456789:-987654321:1 --987654321:+123456789:-1 -&bacmp -+0:-0:0 -+0:+1:-1 --1:+1:0 -+1:-1:0 --1:+2:-1 -+2:-1:1 --123456789:+987654321:-1 -+123456789:-987654321:-1 --987654321:+123456789:1 -&binc -abc:NaN -+0:+1 -+1:+2 --1:+0 -&bdec -abc:NaN -+0:-1 -+1:+0 --1:-2 -&badd -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:+0 -+1:+0:+1 -+0:+1:+1 -+1:+1:+2 --1:+0:-1 -+0:-1:-1 --1:-1:-2 --1:+1:+0 -+1:-1:+0 -+9:+1:+10 -+99:+1:+100 -+999:+1:+1000 -+9999:+1:+10000 -+99999:+1:+100000 -+999999:+1:+1000000 -+9999999:+1:+10000000 -+99999999:+1:+100000000 -+999999999:+1:+1000000000 -+9999999999:+1:+10000000000 -+99999999999:+1:+100000000000 -+10:-1:+9 -+100:-1:+99 -+1000:-1:+999 -+10000:-1:+9999 -+100000:-1:+99999 -+1000000:-1:+999999 -+10000000:-1:+9999999 -+100000000:-1:+99999999 -+1000000000:-1:+999999999 -+10000000000:-1:+9999999999 -+123456789:+987654321:+1111111110 --123456789:+987654321:+864197532 --123456789:-987654321:-1111111110 -+123456789:-987654321:-864197532 -&bsub -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:+0 -+1:+0:+1 -+0:+1:-1 -+1:+1:+0 --1:+0:-1 -+0:-1:+1 --1:-1:+0 --1:+1:-2 -+1:-1:+2 -+9:+1:+8 -+99:+1:+98 -+999:+1:+998 -+9999:+1:+9998 -+99999:+1:+99998 -+999999:+1:+999998 -+9999999:+1:+9999998 -+99999999:+1:+99999998 -+999999999:+1:+999999998 -+9999999999:+1:+9999999998 -+99999999999:+1:+99999999998 -+10:-1:+11 -+100:-1:+101 -+1000:-1:+1001 -+10000:-1:+10001 -+100000:-1:+100001 -+1000000:-1:+1000001 -+10000000:-1:+10000001 -+100000000:-1:+100000001 -+1000000000:-1:+1000000001 -+10000000000:-1:+10000000001 -+123456789:+987654321:-864197532 --123456789:+987654321:-1111111110 --123456789:-987654321:+864197532 -+123456789:-987654321:+1111111110 -&bmul -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:+0 -+0:+1:+0 -+1:+0:+0 -+0:-1:+0 --1:+0:+0 -+123456789123456789:+0:+0 -+0:+123456789123456789:+0 --1:-1:+1 --1:+1:-1 -+1:-1:-1 -+1:+1:+1 -+2:+3:+6 --2:+3:-6 -+2:-3:-6 --2:-3:+6 -+111:+111:+12321 -+10101:+10101:+102030201 -+1001001:+1001001:+1002003002001 -+100010001:+100010001:+10002000300020001 -+10000100001:+10000100001:+100002000030000200001 -+11111111111:+9:+99999999999 -+22222222222:+9:+199999999998 -+33333333333:+9:+299999999997 -+44444444444:+9:+399999999996 -+55555555555:+9:+499999999995 -+66666666666:+9:+599999999994 -+77777777777:+9:+699999999993 -+88888888888:+9:+799999999992 -+99999999999:+9:+899999999991 -+25:+25:+625 -+12345:+12345:+152399025 -+99999:+11111:+1111088889 -&bdiv -abc:abc:NaN -abc:+1:abc:NaN -+1:abc:NaN -+0:+0:NaN -+0:+1:+0 -+1:+0:NaN -+0:-1:+0 --1:+0:NaN -+1:+1:+1 --1:-1:+1 -+1:-1:-1 --1:+1:-1 -+1:+2:+0 -+2:+1:+2 -+1:+26:+0 -+1000000000:+9:+111111111 -+2000000000:+9:+222222222 -+3000000000:+9:+333333333 -+4000000000:+9:+444444444 -+5000000000:+9:+555555555 -+6000000000:+9:+666666666 -+7000000000:+9:+777777777 -+8000000000:+9:+888888888 -+9000000000:+9:+1000000000 -+35500000:+113:+314159 -+71000000:+226:+314159 -+106500000:+339:+314159 -+1000000000:+3:+333333333 -+10:+5:+2 -+100:+4:+25 -+1000:+8:+125 -+10000:+16:+625 -+999999999999:+9:+111111111111 -+999999999999:+99:+10101010101 -+999999999999:+999:+1001001001 -+999999999999:+9999:+100010001 -+999999999999999:+99999:+10000100001 -+1111088889:+99999:+11111 --5:-3:1 -4:3:1 -1:3:0 --2:-3:0 --2:3:-1 -1:-3:-1 --5:3:-2 -4:-3:-2 -&bmod -abc:abc:NaN -abc:+1:abc:NaN -+1:abc:NaN -+0:+0:NaN -+0:+1:+0 -+1:+0:NaN -+0:-1:+0 --1:+0:NaN -+1:+1:+0 --1:-1:+0 -+1:-1:+0 --1:+1:+0 -+1:+2:+1 -+2:+1:+0 -+1000000000:+9:+1 -+2000000000:+9:+2 -+3000000000:+9:+3 -+4000000000:+9:+4 -+5000000000:+9:+5 -+6000000000:+9:+6 -+7000000000:+9:+7 -+8000000000:+9:+8 -+9000000000:+9:+0 -+35500000:+113:+33 -+71000000:+226:+66 -+106500000:+339:+99 -+1000000000:+3:+1 -+10:+5:+0 -+100:+4:+0 -+1000:+8:+0 -+10000:+16:+0 -+999999999999:+9:+0 -+999999999999:+99:+0 -+999999999999:+999:+0 -+999999999999:+9999:+0 -+999999999999999:+99999:+0 --9:+5:+1 -+9:-5:-1 --9:-5:-4 --5:3:1 --2:3:1 -4:3:1 -1:3:1 --5:-3:-2 --2:-3:-2 -4:-3:-2 -1:-3:-2 -&bgcd -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:+0 -+0:+1:+1 -+1:+0:+1 -+1:+1:+1 -+2:+3:+1 -+3:+2:+1 --3:+2:+1 -+100:+625:+25 -+4096:+81:+1 -+1034:+804:+2 -+27:+90:+56:+1 -+27:+90:+54:+9 -&blcm -abc:abc:NaN -abc:+0:NaN -+0:abc:NaN -+0:+0:NaN -+1:+0:+0 -+0:+1:+0 -+27:+90:+270 -+1034:+804:+415668 -&band -abc:abc:NaN -abc:0:NaN -0:abc:NaN -+8:+2:+0 -+281474976710656:+0:+0 -+281474976710656:+1:+0 -+281474976710656:+281474976710656:+281474976710656 -&bior -abc:abc:NaN -abc:0:NaN -0:abc:NaN -+8:+2:+10 -+281474976710656:+0:+281474976710656 -+281474976710656:+1:+281474976710657 -+281474976710656:+281474976710656:+281474976710656 -&bxor -abc:abc:NaN -abc:0:NaN -0:abc:NaN -+8:+2:+10 -+281474976710656:+0:+281474976710656 -+281474976710656:+1:+281474976710657 -+281474976710656:+281474976710656:+0 -&bnot -abc:NaN -+0:-1 -+8:-9 -+281474976710656:-281474976710657 -&digit -0:0:0 -12:0:2 -12:1:1 -123:0:3 -123:1:2 -123:2:1 -123:-1:1 -123:-2:2 -123:-3:3 -123456:0:6 -123456:1:5 -123456:2:4 -123456:3:3 -123456:4:2 -123456:5:1 -123456:-1:1 -123456:-2:2 -123456:-3:3 -100000:-3:0 -100000:0:0 -100000:1:0 -&mantissa -abc:NaN -1e4:1 -2e0:2 -123:123 --1:-1 --2:-2 -&exponent -abc:NaN -1e4:4 -2e0:0 -123:0 --1:0 --2:0 -0:1 -&parts -abc:NaN,NaN -1e4:1,4 -2e0:2,0 -123:123,0 --1:-1,0 --2:-2,0 -0:0,1 -&bpow -0:0:1 -0:1:0 -0:2:0 -0:-1:NaN -0:-2:NaN -1:0:1 -1:1:1 -1:2:1 -1:3:1 -1:-1:1 -1:-2:1 -1:-3:1 -2:0:1 -2:1:2 -2:2:4 -2:3:8 -3:3:27 -2:-1:NaN --2:-1:NaN -2:-2:NaN --2:-2:NaN -# 1 ** -x => 1 / (1 ** x) --1:0:1 --2:0:1 --1:1:-1 --1:2:1 --1:3:-1 --1:4:1 --1:5:-1 --1:-1:-1 --1:-2:1 --1:-3:-1 --1:-4:1 -10:2:100 -10:3:1000 -10:4:10000 -10:5:100000 -10:6:1000000 -10:7:10000000 -10:8:100000000 -10:9:1000000000 -10:20:100000000000000000000 -123456:2:15241383936 -&length -100:3 -10:2 -1:1 -0:1 -12345:5 -10000000000000000:17 --123:3 -&bsqrt -144:12 -16:4 -4:2 -2:1 -12:3 -256:16 -100000000:10000 -4000000000000:2000000 -1:1 -0:0 --2:NaN -Nan:NaN -&bround -$round_mode('trunc') -1234:0:1234 -1234:2:1200 -123456:4:123400 -123456:5:123450 -123456:6:123456 -+10123456789:5:+10123000000 --10123456789:5:-10123000000 -+10123456789:9:+10123456700 --10123456789:9:-10123456700 -+101234500:6:+101234000 --101234500:6:-101234000 -#+101234500:-4:+101234000 -#-101234500:-4:-101234000 -$round_mode('zero') -+20123456789:5:+20123000000 --20123456789:5:-20123000000 -+20123456789:9:+20123456800 --20123456789:9:-20123456800 -+201234500:6:+201234000 --201234500:6:-201234000 -#+201234500:-4:+201234000 -#-201234500:-4:-201234000 -+12345000:4:12340000 --12345000:4:-12340000 -$round_mode('+inf') -+30123456789:5:+30123000000 --30123456789:5:-30123000000 -+30123456789:9:+30123456800 --30123456789:9:-30123456800 -+301234500:6:+301235000 --301234500:6:-301234000 -#+301234500:-4:+301235000 -#-301234500:-4:-301234000 -+12345000:4:12350000 --12345000:4:-12340000 -$round_mode('-inf') -+40123456789:5:+40123000000 --40123456789:5:-40123000000 -+40123456789:9:+40123456800 --40123456789:9:-40123456800 -+401234500:6:+401234000 -+401234500:6:+401234000 -#-401234500:-4:-401235000 -#-401234500:-4:-401235000 -+12345000:4:12340000 --12345000:4:-12350000 -$round_mode('odd') -+50123456789:5:+50123000000 --50123456789:5:-50123000000 -+50123456789:9:+50123456800 --50123456789:9:-50123456800 -+501234500:6:+501235000 --501234500:6:-501235000 -#+501234500:-4:+501235000 -#-501234500:-4:-501235000 -+12345000:4:12350000 --12345000:4:-12350000 -$round_mode('even') -+60123456789:5:+60123000000 --60123456789:5:-60123000000 -+60123456789:9:+60123456800 --60123456789:9:-60123456800 -+601234500:6:+601234000 --601234500:6:-601234000 -#+601234500:-4:+601234000 -#-601234500:-4:-601234000 -#-601234500:-9:0 -#-501234500:-9:0 -#-601234500:-8:0 -#-501234500:-8:0 -+1234567:7:1234567 -+1234567:6:1234570 -+12345000:4:12340000 --12345000:4:-12340000 -&is_odd -abc:0 -0:0 -1:1 -3:1 --1:1 --3:1 -10000001:1 -10000002:0 -2:0 -&is_even -abc:0 -0:1 -1:0 -3:0 --1:0 --3:0 -10000001:0 -10000002:1 -2:1 -&is_zero -0:1 -NaNzero:0 -123:0 --1:0 -1:0 -&_set -2:-1:-1 --2:1:1 -NaN:2:2 -2:abc:NaN -&is_one -0:0 -1:1 -2:0 --1:0 --2:0 -# floor and ceil tests are pretty pointless in integer space...but play safe -&bfloor -0:0 --1:-1 --2:-2 -2:2 -3:3 -abc:NaN -&bceil -0:0 --1:-1 --2:-2 -2:2 -3:3 -abc:NaN diff --git a/t/lib/carp.t b/t/lib/carp.t deleted file mode 100644 index a318c19751..0000000000 --- a/t/lib/carp.t +++ /dev/null @@ -1,53 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Carp qw(carp cluck croak confess); - -print "1..7\n"; - -print "ok 1\n"; - -$SIG{__WARN__} = sub { - print "ok $1\n" - if $_[0] =~ m!ok (\d+)$! }; - -carp "ok 2\n"; - -$SIG{__WARN__} = sub { - print "ok $1\n" - if $_[0] =~ m!(\d+) at .+\b(?i:carp\.t) line \d+$! }; - -carp 3; - -sub sub_4 { - -$SIG{__WARN__} = sub { - print "ok $1\n" - if $_[0] =~ m!^(\d+) at .+\b(?i:carp\.t) line \d+\n\tmain::sub_4\(\) called at .+\b(?i:carp\.t) line \d+$! }; - -cluck 4; - -} - -sub_4; - -$SIG{__DIE__} = sub { - print "ok $1\n" - if $_[0] =~ m!^(\d+) at .+\b(?i:carp\.t) line \d+\n\teval \Q{...}\E called at .+\b(?i:carp\.t) line \d+$! }; - -eval { croak 5 }; - -sub sub_6 { - $SIG{__DIE__} = sub { - print "ok $1\n" - if $_[0] =~ m!^(\d+) at .+\b(?i:carp\.t) line \d+\n\teval \Q{...}\E called at .+\b(?i:carp\.t) line \d+\n\tmain::sub_6\(\) called at .+\b(?i:carp\.t) line \d+$! }; - - eval { confess 6 }; -} - -sub_6; - -print "ok 7\n"; - diff --git a/t/lib/cgi-esc.t b/t/lib/cgi-esc.t deleted file mode 100644 index f0471cfed3..0000000000 --- a/t/lib/cgi-esc.t +++ /dev/null @@ -1,56 +0,0 @@ -#!/usr/local/bin/perl -w - -BEGIN { - chdir('t') if -d 't'; - @INC = '../lib'; -} - -# Test ability to escape() and unescape() punctuation characters -# except for qw(- . _). -######################### We start with some black magic to print on failure. -use lib '../blib/lib','../blib/arch'; - -BEGIN {$| = 1; print "1..59\n"; } -END {print "not ok 1\n" unless $loaded;} -use Config; -use CGI::Util qw(escape unescape); -$loaded = 1; -print "ok 1\n"; - -######################### End of black magic. - -# util -sub test { - local($^W) = 0; - my($num, $true,$msg) = @_; - print($true ? "ok $num\n" : "not ok $num $msg\n"); -} - -# ASCII order, ASCII codepoints, ASCII repertoire - -my %punct = ( - ' ' => '20', '!' => '21', '"' => '22', '#' => '23', - '$' => '24', '%' => '25', '&' => '26', '\'' => '27', - '(' => '28', ')' => '29', '*' => '2A', '+' => '2B', - ',' => '2C', '/' => '2F', # '-' => '2D', '.' => '2E' - ':' => '3A', ';' => '3B', '<' => '3C', '=' => '3D', - '>' => '3E', '?' => '3F', '[' => '5B', '\\' => '5C', - ']' => '5D', '^' => '5E', '`' => '60', # '_' => '5F', - '{' => '7B', '|' => '7C', '}' => '7D', '~' => '7E', - ); - -# The sort order may not be ASCII on EBCDIC machines: - -my $i = 1; - -foreach(sort(keys(%punct))) { - $i++; - my $escape = "AbC\%$punct{$_}dEF"; - my $cgi_escape = escape("AbC$_" . "dEF"); - test($i, $escape eq $cgi_escape , "# $escape ne $cgi_escape"); - $i++; - my $unescape = "AbC$_" . "dEF"; - my $cgi_unescape = unescape("AbC\%$punct{$_}dEF"); - test($i, $unescape eq $cgi_unescape , "# $unescape ne $cgi_unescape"); -} - diff --git a/t/lib/cgi-form.t b/t/lib/cgi-form.t deleted file mode 100755 index 2922903499..0000000000 --- a/t/lib/cgi-form.t +++ /dev/null @@ -1,90 +0,0 @@ -#!/usr/local/bin/perl -w - -BEGIN { - chdir('t') if -d 't'; - @INC = '../lib'; -} - -# Test ability to retrieve HTTP request info -######################### We start with some black magic to print on failure. -use lib '../blib/lib','../blib/arch'; - -BEGIN {$| = 1; print "1..17\n"; } -END {print "not ok 1\n" unless $loaded;} -use CGI (':standard','-no_debug'); -$loaded = 1; -print "ok 1\n"; - -######################### End of black magic. - -# util -sub test { - local($^W) = 0; - my($num, $true,$msg) = @_; - print($true ? "ok $num\n" : "not ok $num $msg\n"); -} - -my $CRLF = "\015\012"; -if ($^O eq 'VMS') { - $CRLF = "\n"; # via web server carriage is inserted automatically -} -if (ord("\t") != 9) { # EBCDIC? - $CRLF = "\r\n"; -} - - -# Set up a CGI environment -$ENV{REQUEST_METHOD}='GET'; -$ENV{QUERY_STRING} ='game=chess&game=checkers&weather=dull'; -$ENV{PATH_INFO} ='/somewhere/else'; -$ENV{PATH_TRANSLATED} ='/usr/local/somewhere/else'; -$ENV{SCRIPT_NAME} ='/cgi-bin/foo.cgi'; -$ENV{SERVER_PROTOCOL} = 'HTTP/1.0'; -$ENV{SERVER_PORT} = 8080; -$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com'; - -test(2,start_form(-action=>'foobar',-method=>'get') eq - qq(<form method="get" action="foobar" enctype="application/x-www-form-urlencoded">\n), - "start_form()"); - -test(3,submit() eq qq(<input type="submit" name=".submit" />),"submit()"); -test(4,submit(-name=>'foo',-value=>'bar') eq qq(<input type="submit" name="foo" value="bar" />),"submit(-name,-value)"); -test(5,submit({-name=>'foo',-value=>'bar'}) eq qq(<input type="submit" name="foo" value="bar" />),"submit({-name,-value})"); -test(6,textfield(-name=>'weather') eq qq(<input type="text" name="weather" value="dull" />),"textfield({-name})"); -test(7,textfield(-name=>'weather',-value=>'nice') eq qq(<input type="text" name="weather" value="dull" />),"textfield({-name,-value})"); -test(8,textfield(-name=>'weather',-value=>'nice',-override=>1) eq qq(<input type="text" name="weather" value="nice" />), - "textfield({-name,-value,-override})"); -test(9,checkbox(-name=>'weather',-value=>'nice') eq qq(<input type="checkbox" name="weather" value="nice" />weather), - "checkbox()"); -test(10,checkbox(-name=>'weather',-value=>'nice',-label=>'forecast') eq - qq(<input type="checkbox" name="weather" value="nice" />forecast), - "checkbox()"); -test(11,checkbox(-name=>'weather',-value=>'nice',-label=>'forecast',-checked=>1,-override=>1) eq - qq(<input type="checkbox" name="weather" value="nice" checked />forecast), - "checkbox()"); -test(12,checkbox(-name=>'weather',-value=>'dull',-label=>'forecast') eq - qq(<input type="checkbox" name="weather" value="dull" checked />forecast), - "checkbox()"); - -test(13,radio_group(-name=>'game') eq - qq(<input type="radio" name="game" value="chess" checked />chess <input type="radio" name="game" value="checkers" />checkers), - 'radio_group()'); -test(14,radio_group(-name=>'game',-labels=>{'chess'=>'ping pong'}) eq - qq(<input type="radio" name="game" value="chess" checked />ping pong <input type="radio" name="game" value="checkers" />checkers), - 'radio_group()'); - -test(15, checkbox_group(-name=>'game',-Values=>[qw/checkers chess cribbage/]) eq - qq(<input type="checkbox" name="game" value="checkers" checked />checkers <input type="checkbox" name="game" value="chess" checked />chess <input type="checkbox" name="game" value="cribbage" />cribbage), - 'checkbox_group()'); - -test(16, checkbox_group(-name=>'game',-values=>[qw/checkers chess cribbage/],-defaults=>['cribbage'],-override=>1) eq - qq(<input type="checkbox" name="game" value="checkers" />checkers <input type="checkbox" name="game" value="chess" />chess <input type="checkbox" name="game" value="cribbage" checked />cribbage), - 'checkbox_group()'); -test(17, popup_menu(-name=>'game',-values=>[qw/checkers chess cribbage/],-default=>'cribbage',-override=>1) eq <<END,'checkbox_group()'); -<select name="game"> -<option value="checkers">checkers</option> -<option value="chess">chess</option> -<option selected value="cribbage">cribbage</option> -</select> -END - diff --git a/t/lib/cgi-function.t b/t/lib/cgi-function.t deleted file mode 100755 index b670e33cd7..0000000000 --- a/t/lib/cgi-function.t +++ /dev/null @@ -1,111 +0,0 @@ -#!/usr/local/bin/perl -w - -BEGIN { - chdir('t') if -d 't'; - @INC = '../lib'; -} - -# Test ability to retrieve HTTP request info -######################### We start with some black magic to print on failure. -use lib '../blib/lib','../blib/arch'; - -BEGIN {$| = 1; print "1..27\n"; } -END {print "not ok 1\n" unless $loaded;} -use Config; -use CGI (':standard','keywords'); -$loaded = 1; -print "ok 1\n"; - -######################### End of black magic. - -# util -sub test { - local($^W) = 0; - my($num, $true,$msg) = @_; - print($true ? "ok $num\n" : "not ok $num $msg\n"); -} - -my $CRLF = "\015\012"; - -# A peculiarity of sending "\n" through MBX|Socket|web-server on VMS -# is that a CR character gets inserted automatically in the web server -# case but not internal to perl's double quoted strings "\n". This -# test would need to be modified to use the "\015\012" on VMS if it -# were actually run through a web server. -# Thanks to Peter Prymmer for this - -if ($^O eq 'VMS') { $CRLF = "\n"; } - -# Web servers on EBCDIC hosts are typically set up to do an EBCDIC -> ASCII -# translation hence CRLF is used as \r\n within CGI.pm on such machines. - -if (ord("\t") != 9) { $CRLF = "\r\n"; } - -# Web servers on EBCDIC hosts are typically set up to do an EBCDIC -> ASCII -# translation hence CRLF is used as \r\n within CGI.pm on such machines. - -if (ord("\t") != 9) { $CRLF = "\r\n"; } - -# Set up a CGI environment -$ENV{REQUEST_METHOD}='GET'; -$ENV{QUERY_STRING} ='game=chess&game=checkers&weather=dull'; -$ENV{PATH_INFO} ='/somewhere/else'; -$ENV{PATH_TRANSLATED} ='/usr/local/somewhere/else'; -$ENV{SCRIPT_NAME} ='/cgi-bin/foo.cgi'; -$ENV{SERVER_PROTOCOL} = 'HTTP/1.0'; -$ENV{SERVER_PORT} = 8080; -$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com'; -$ENV{HTTP_LOVE} = 'true'; - -test(2,request_method() eq 'GET',"CGI::request_method()"); -test(3,query_string() eq 'game=chess;game=checkers;weather=dull',"CGI::query_string()"); -test(4,param() == 2,"CGI::param()"); -test(5,join(' ',sort {$a cmp $b} param()) eq 'game weather',"CGI::param()"); -test(6,param('game') eq 'chess',"CGI::param()"); -test(7,param('weather') eq 'dull',"CGI::param()"); -test(8,join(' ',param('game')) eq 'chess checkers',"CGI::param()"); -test(9,param(-name=>'foo',-value=>'bar'),'CGI::param() put'); -test(10,param(-name=>'foo') eq 'bar','CGI::param() get'); -test(11,query_string() eq 'game=chess;game=checkers;weather=dull;foo=bar',"CGI::query_string() redux"); -test(12,http('love') eq 'true',"CGI::http()"); -test(13,script_name() eq '/cgi-bin/foo.cgi',"CGI::script_name()"); -test(14,url() eq 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi',"CGI::url()"); -test(15,self_url() eq - 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', - "CGI::url()"); -test(16,url(-absolute=>1) eq '/cgi-bin/foo.cgi','CGI::url(-absolute=>1)'); -test(17,url(-relative=>1) eq 'foo.cgi','CGI::url(-relative=>1)'); -test(18,url(-relative=>1,-path=>1) eq 'foo.cgi/somewhere/else','CGI::url(-relative=>1,-path=>1)'); -test(19,url(-relative=>1,-path=>1,-query=>1) eq - 'foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', - 'CGI::url(-relative=>1,-path=>1,-query=>1)'); -Delete('foo'); -test(20,!param('foo'),'CGI::delete()'); - -CGI::_reset_globals(); -$ENV{QUERY_STRING}='mary+had+a+little+lamb'; -test(21,join(' ',keywords()) eq 'mary had a little lamb','CGI::keywords'); -test(22,join(' ',param('keywords')) eq 'mary had a little lamb','CGI::keywords'); - -CGI::_reset_globals; -if ($Config{d_fork}) { - $test_string = 'game=soccer&game=baseball&weather=nice'; - $ENV{REQUEST_METHOD}='POST'; - $ENV{CONTENT_LENGTH}=length($test_string); - $ENV{QUERY_STRING}='big_balls=basketball&small_balls=golf'; - if (open(CHILD,"|-")) { # cparent - print CHILD $test_string; - close CHILD; - exit 0; - } - # at this point, we're in a new (child) process - test(23,param('weather') eq 'nice',"CGI::param() from POST"); - test(24,(url_param('big_balls') eq 'basketball'),"CGI::url_param()"); -} else { - print "ok 23 # Skip\n"; - print "ok 24 # Skip\n"; -} -test(25,redirect('http://somewhere.else') eq "Status: 302 Moved${CRLF}location: http://somewhere.else${CRLF}${CRLF}","CGI::redirect() 1"); -my $h = redirect(-Location=>'http://somewhere.else',-Type=>'text/html'); -test(26,$h eq "Status: 302 Moved${CRLF}location: http://somewhere.else${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","CGI::redirect() 2"); -test(27,redirect(-Location=>'http://somewhere.else/bin/foo&bar',-Type=>'text/html') eq "Status: 302 Moved${CRLF}location: http://somewhere.else/bin/foo&bar${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","CGI::redirect() 2"); diff --git a/t/lib/cgi-html.t b/t/lib/cgi-html.t deleted file mode 100755 index 93e5dac648..0000000000 --- a/t/lib/cgi-html.t +++ /dev/null @@ -1,95 +0,0 @@ -#!/usr/local/bin/perl -w - -BEGIN { - chdir('t') if -d 't'; - @INC = '../lib'; -} - -# Test ability to retrieve HTTP request info -######################### We start with some black magic to print on failure. -use lib '../blib/lib','../blib/arch'; - -BEGIN {$| = 1; print "1..24\n"; } -END {print "not ok 1\n" unless $loaded;} -use CGI (':standard','-no_debug','*h3','start_table'); -$loaded = 1; -print "ok 1\n"; - -######################### End of black magic. - -my $CRLF = "\015\012"; -if ($^O eq 'VMS') { - $CRLF = "\n"; # via web server carriage is inserted automatically -} -if (ord("\t") != 9) { # EBCDIC? - $CRLF = "\r\n"; -} - - -# util -sub test { - local($^W) = 0; - my($num, $true,$msg) = @_; - print($true ? "ok $num\n" : "not ok $num $msg\n"); -} - -# all the automatic tags -test(2,h1() eq '<h1 />',"single tag"); -test(3,h1('fred') eq '<h1>fred</h1>',"open/close tag"); -test(4,h1('fred','agnes','maura') eq '<h1>fred agnes maura</h1>',"open/close tag multiple"); -test(5,h1({-align=>'CENTER'},'fred') eq '<h1 align="CENTER">fred</h1>',"open/close tag with attribute"); -test(6,h1({-align=>undef},'fred') eq '<h1 align>fred</h1>',"open/close tag with orphan attribute"); -test(7,h1({-align=>'CENTER'},['fred','agnes']) eq - '<h1 align="CENTER">fred</h1> <h1 align="CENTER">agnes</h1>', - "distributive tag with attribute"); -{ - local($") = '-'; - test(8,h1('fred','agnes','maura') eq '<h1>fred-agnes-maura</h1>',"open/close tag \$\" interpolation"); -} -test(9,header() eq "Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}","header()"); -test(10,header(-type=>'image/gif') eq "Content-Type: image/gif${CRLF}${CRLF}","header()"); -test(11,header(-type=>'image/gif',-status=>'500 Sucks') eq "Status: 500 Sucks${CRLF}Content-Type: image/gif${CRLF}${CRLF}","header()"); -test(12,header(-nph=>1) =~ m!HTTP/1.0 200 OK${CRLF}Server: cmdline${CRLF}Date:.+${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}!,"header()"); -test(13,start_html() ."\n" eq <<END,"start_html()"); -<?xml version="1.0" encoding="utf-8"?> -<!DOCTYPE html - PUBLIC "-//W3C//DTD XHTML Basic 1.0//EN" - "http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd"> -<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US"><head><title>Untitled Document</title> -</head><body> -END - ; -test(14,start_html(-dtd=>"-//IETF//DTD HTML 3.2//FR") ."\n" eq <<END,"start_html()"); -<!DOCTYPE html - PUBLIC "-//IETF//DTD HTML 3.2//FR"> -<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US"><head><title>Untitled Document</title> -</head><body> -END - ; -test(15,start_html(-Title=>'The world of foo') ."\n" eq <<END,"start_html()"); -<?xml version="1.0" encoding="utf-8"?> -<!DOCTYPE html - PUBLIC "-//W3C//DTD XHTML Basic 1.0//EN" - "http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd"> -<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US"><head><title>The world of foo</title> -</head><body> -END - ; -test(16,($cookie=cookie(-name=>'fred',-value=>['chocolate','chip'],-path=>'/')) eq 'fred=chocolate&chip; path=/',"cookie()"); -my $h = header(-Cookie=>$cookie); -test(17,$h =~ m!^Set-Cookie: fred=chocolate&chip\; path=/${CRLF}Date:.*${CRLF}Content-Type: text/html; charset=ISO-8859-1${CRLF}${CRLF}!s, - "header(-cookie)"); -test(18,start_h3 eq '<h3>'); -test(19,end_h3 eq '</h3>'); -test(20,start_table({-border=>undef}) eq '<table border>'); -test(21,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is <not> ‹right›</h1>'); -charset('utf-8'); -if (ord("\t") == 9) { -test(22,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is <not> right</h1>'); -} -else { -test(22,h1(escapeHTML("this is <not> \x8bright\x9b")) eq '<h1>this is <not> right</h1>'); -} -test(23,i(p('hello there')) eq '<i><p>hello there</p></i>'); -my $q = new CGI; -test(24,$q->h1('hi') eq '<h1>hi</h1>'); diff --git a/t/lib/cgi-pretty.t b/t/lib/cgi-pretty.t deleted file mode 100755 index 14f6447033..0000000000 --- a/t/lib/cgi-pretty.t +++ /dev/null @@ -1,41 +0,0 @@ -#!/usr/local/bin/perl -w - -BEGIN { - chdir('t') if -d 't'; - @INC = '../lib'; -} - -# Test ability to retrieve HTTP request info -######################### We start with some black magic to print on failure. -use lib '../blib/lib','../blib/arch'; - -BEGIN {$| = 1; print "1..5\n"; } -END {print "not ok 1\n" unless $loaded;} -use CGI::Pretty (':standard','-no_debug','*h3','start_table'); -$loaded = 1; -print "ok 1\n"; - -######################### End of black magic. - -# util -sub test { - local($^W) = 0; - my($num, $true,$msg) = @_; - print($true ? "ok $num\n" : "not ok $num $msg\n"); -} - -# all the automatic tags -test(2,h1() eq '<h1>',"single tag"); -test(3,ol(li('fred'),li('ethel')) eq "<ol>\n\t<li>\n\t\tfred\n\t</li>\n\t <li>\n\t\tethel\n\t</li>\n</ol>\n","basic indentation"); -test(4,p('hi',pre('there'),'frog') eq -'<p> - hi <pre>there</pre> - frog -</p> -',"<pre> tags"); -test(5,p('hi',a({-href=>'frog'},'there'),'frog') eq -'<p> - hi <a href="frog">there</a> - frog -</p> -',"as-is"); diff --git a/t/lib/cgi-request.t b/t/lib/cgi-request.t deleted file mode 100755 index fde3fd04cf..0000000000 --- a/t/lib/cgi-request.t +++ /dev/null @@ -1,103 +0,0 @@ -#!/usr/local/bin/perl -w - -BEGIN { - chdir('t') if -d 't'; - @INC = '../lib'; -} - -# Test ability to retrieve HTTP request info -######################### We start with some black magic to print on failure. -use lib '../blib/lib','../blib/arch'; - -BEGIN {$| = 1; print "1..33\n"; } -END {print "not ok 1\n" unless $loaded;} -use CGI (); -use Config; -$loaded = 1; -print "ok 1\n"; - -######################### End of black magic. - -# util -sub test { - local($^W) = 0; - my($num, $true,$msg) = @_; - print($true ? "ok $num\n" : "not ok $num $msg\n"); -} - -# Set up a CGI environment -$ENV{REQUEST_METHOD} = 'GET'; -$ENV{QUERY_STRING} = 'game=chess&game=checkers&weather=dull'; -$ENV{PATH_INFO} = '/somewhere/else'; -$ENV{PATH_TRANSLATED} = '/usr/local/somewhere/else'; -$ENV{SCRIPT_NAME} = '/cgi-bin/foo.cgi'; -$ENV{SERVER_PROTOCOL} = 'HTTP/1.0'; -$ENV{SERVER_PORT} = 8080; -$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com'; -$ENV{REQUEST_URI} = "$ENV{SCRIPT_NAME}$ENV{PATH_INFO}?$ENV{QUERY_STRING}"; -$ENV{HTTP_LOVE} = 'true'; - -$q = new CGI; -test(2,$q,"CGI::new()"); -test(3,$q->request_method eq 'GET',"CGI::request_method()"); -test(4,$q->query_string eq 'game=chess;game=checkers;weather=dull',"CGI::query_string()"); -test(5,$q->param() == 2,"CGI::param()"); -test(6,join(' ',sort $q->param()) eq 'game weather',"CGI::param()"); -test(7,$q->param('game') eq 'chess',"CGI::param()"); -test(8,$q->param('weather') eq 'dull',"CGI::param()"); -test(9,join(' ',$q->param('game')) eq 'chess checkers',"CGI::param()"); -test(10,$q->param(-name=>'foo',-value=>'bar'),'CGI::param() put'); -test(11,$q->param(-name=>'foo') eq 'bar','CGI::param() get'); -test(12,$q->query_string eq 'game=chess;game=checkers;weather=dull;foo=bar',"CGI::query_string() redux"); -test(13,$q->http('love') eq 'true',"CGI::http()"); -test(14,$q->script_name eq '/cgi-bin/foo.cgi',"CGI::script_name()"); -test(15,$q->url eq 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi',"CGI::url()"); -test(16,$q->self_url eq - 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', - "CGI::url()"); -test(17,$q->url(-absolute=>1) eq '/cgi-bin/foo.cgi','CGI::url(-absolute=>1)'); -test(18,$q->url(-relative=>1) eq 'foo.cgi','CGI::url(-relative=>1)'); -test(19,$q->url(-relative=>1,-path=>1) eq 'foo.cgi/somewhere/else','CGI::url(-relative=>1,-path=>1)'); -test(20,$q->url(-relative=>1,-path=>1,-query=>1) eq - 'foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', - 'CGI::url(-relative=>1,-path=>1,-query=>1)'); -$q->delete('foo'); -test(21,!$q->param('foo'),'CGI::delete()'); - -$q->_reset_globals; -$ENV{QUERY_STRING}='mary+had+a+little+lamb'; -test(22,$q=new CGI,"CGI::new() redux"); -test(23,join(' ',$q->keywords) eq 'mary had a little lamb','CGI::keywords'); -test(24,join(' ',$q->param('keywords')) eq 'mary had a little lamb','CGI::keywords'); -test(25,$q=new CGI('foo=bar&foo=baz'),"CGI::new() redux"); -test(26,$q->param('foo') eq 'bar','CGI::param() redux'); -test(27,$q=new CGI({'foo'=>'bar','bar'=>'froz'}),"CGI::new() redux 2"); -test(28,$q->param('bar') eq 'froz',"CGI::param() redux 2"); - -# test tied interface -my $p = $q->Vars; -test(29,$p->{bar} eq 'froz',"tied interface fetch"); -$p->{bar} = join("\0",qw(foo bar baz)); -test(30,join(' ',$q->param('bar')) eq 'foo bar baz','tied interface store'); - -# test posting -$q->_reset_globals; -if ($Config{d_fork}) { - $test_string = 'game=soccer&game=baseball&weather=nice'; - $ENV{REQUEST_METHOD}='POST'; - $ENV{CONTENT_LENGTH}=length($test_string); - $ENV{QUERY_STRING}='big_balls=basketball&small_balls=golf'; - if (open(CHILD,"|-")) { # cparent - print CHILD $test_string; - close CHILD; - exit 0; - } - # at this point, we're in a new (child) process - test(31,$q=new CGI,"CGI::new() from POST"); - test(32,$q->param('weather') eq 'nice',"CGI::param() from POST"); - test(33,$q->url_param('big_balls') eq 'basketball',"CGI::url_param()"); -} else { - print "ok 31 # Skip\n"; - print "ok 32 # Skip\n"; - print "ok 33 # Skip\n"; -} diff --git a/t/lib/charnames.t b/t/lib/charnames.t deleted file mode 100644 index 124dad0971..0000000000 --- a/t/lib/charnames.t +++ /dev/null @@ -1,131 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib'; - } -} - -$| = 1; -print "1..16\n"; - -use charnames ':full'; - -print "not " unless "Here\N{EXCLAMATION MARK}?" eq "Here\041?"; -print "ok 1\n"; - -{ - use bytes; # TEST -utf8 can switch utf8 on - - print "# \$res=$res \$\@='$@'\nnot " - if $res = eval <<'EOE' -use charnames ":full"; -"Here: \N{CYRILLIC SMALL LETTER BE}!"; -1 -EOE - or $@ !~ /above 0xFF/; - print "ok 2\n"; - # print "# \$res=$res \$\@='$@'\n"; - - print "# \$res=$res \$\@='$@'\nnot " - if $res = eval <<'EOE' -use charnames 'cyrillic'; -"Here: \N{Be}!"; -1 -EOE - or $@ !~ /CYRILLIC CAPITAL LETTER BE.*above 0xFF/; - print "ok 3\n"; -} - -# If octal representation of unicode char is \0xyzt, then the utf8 is \3xy\2zt -if (ord('A') == 65) { # as on ASCII or UTF-8 machines - $encoded_be = "\320\261"; - $encoded_alpha = "\316\261"; - $encoded_bet = "\327\221"; - $encoded_deseng = "\360\220\221\215"; -} -else { # EBCDIC where UTF-EBCDIC may be used (this may be 1047 specific since - # UTF-EBCDIC is codepage specific) - $encoded_be = "\270\102\130"; - $encoded_alpha = "\264\130"; - $encoded_bet = "\270\125\130"; - $encoded_deseng = "\336\102\103\124"; -} - -sub to_bytes { - pack"a*", shift; -} - -{ - use charnames ':full'; - - print "not " unless to_bytes("\N{CYRILLIC SMALL LETTER BE}") eq $encoded_be; - print "ok 4\n"; - - use charnames qw(cyrillic greek :short); - - print "not " unless to_bytes("\N{be},\N{alpha},\N{hebrew:bet}") - eq "$encoded_be,$encoded_alpha,$encoded_bet"; - print "ok 5\n"; -} - -{ - use charnames ':full'; - print "not " unless "\x{263a}" eq "\N{WHITE SMILING FACE}"; - print "ok 6\n"; - print "not " unless length("\x{263a}") == 1; - print "ok 7\n"; - print "not " unless length("\N{WHITE SMILING FACE}") == 1; - print "ok 8\n"; - print "not " unless sprintf("%vx", "\x{263a}") eq "263a"; - print "ok 9\n"; - print "not " unless sprintf("%vx", "\N{WHITE SMILING FACE}") eq "263a"; - print "ok 10\n"; - print "not " unless sprintf("%vx", "\xFF\N{WHITE SMILING FACE}") eq "ff.263a"; - print "ok 11\n"; - print "not " unless sprintf("%vx", "\x{ff}\N{WHITE SMILING FACE}") eq "ff.263a"; - print "ok 12\n"; -} - -{ - use charnames qw(:full); - use utf8; - - my $x = "\x{221b}"; - my $named = "\N{CUBE ROOT}"; - - print "not " unless ord($x) == ord($named); - print "ok 13\n"; -} - -{ - use charnames qw(:full); - use utf8; - print "not " unless "\x{100}\N{CENT SIGN}" eq "\x{100}"."\N{CENT SIGN}"; - print "ok 14\n"; -} - -{ - use charnames ':full'; - - print "not " - unless to_bytes("\N{DESERET SMALL LETTER ENG}") eq $encoded_deseng; - print "ok 15\n"; -} - -{ - # 20001114.001 - - no utf8; # so that the naked 8-bit character won't gripe under use utf8 - - if (ord("") == 0xc4) { # Try to do this only on Latin-1. - use charnames ':full'; - my $text = "\N{LATIN CAPITAL LETTER A WITH DIAERESIS}"; - print "not " unless $text eq "\xc4" && ord($text) == 0xc4; - print "ok 16\n"; - } else { - print "ok 16 # Skip: not Latin-1\n"; - } -} - diff --git a/t/lib/checktree.t b/t/lib/checktree.t deleted file mode 100755 index b5426ca261..0000000000 --- a/t/lib/checktree.t +++ /dev/null @@ -1,19 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..1\n"; - -use File::CheckTree; - -# We assume that we run from the perl "t" directory. - -validate q{ - lib -d || die - lib/checktree.t -f || die -}; - -print "ok 1\n"; diff --git a/t/lib/class-isa.t b/t/lib/class-isa.t deleted file mode 100644 index b09e2a94a9..0000000000 --- a/t/lib/class-isa.t +++ /dev/null @@ -1,40 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -# Before `make install' is performed this script should be runnable with -# `make test'. After `make install' it should work as `perl test.pl' - -######################### We start with some black magic to print on failure. - -# Change 1..1 below to 1..last_test_to_print . -# (It may become useful if the test is moved to ./t subdirectory.) - -BEGIN { $| = 1; print "1..2\n"; } -END {print "not ok 1\n" unless $loaded;} -use Class::ISA; -$loaded = 1; -print "ok 1\n"; - -######################### End of black magic. - -# Insert your test code below (better if it prints "ok 13" -# (correspondingly "not ok 13") depending on the success of chunk 13 -# of the test code): - - @Food::Fishstick::ISA = qw(Food::Fish Life::Fungus Chemicals); - @Food::Fish::ISA = qw(Food); - @Food::ISA = qw(Matter); - @Life::Fungus::ISA = qw(Life); - @Chemicals::ISA = qw(Matter); - @Life::ISA = qw(Matter); - @Matter::ISA = qw(); - - use Class::ISA; - my @path = Class::ISA::super_path('Food::Fishstick'); - my $flat_path = join ' ', @path; - print "# Food::Fishstick path is:\n# $flat_path\n"; - print "not " unless - "Food::Fish Food Matter Life::Fungus Life Chemicals" eq $flat_path; - print "ok 2\n"; diff --git a/t/lib/class-struct.t b/t/lib/class-struct.t deleted file mode 100644 index 2dfaf85e6d..0000000000 --- a/t/lib/class-struct.t +++ /dev/null @@ -1,76 +0,0 @@ -#!./perl -w - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..10\n"; - -package aClass; - -sub new { bless {}, shift } - -sub meth { 42 } - -package MyObj; - -use Class::Struct; -use Class::Struct 'struct'; # test out both forms - -use Class::Struct SomeClass => { SomeElem => '$' }; - -struct( s => '$', a => '@', h => '%', c => 'aClass' ); - -my $obj = MyObj->new; - -$obj->s('foo'); - -print "not " unless $obj->s() eq 'foo'; -print "ok 1\n"; - -my $arf = $obj->a; - -print "not " unless ref $arf eq 'ARRAY'; -print "ok 2\n"; - -$obj->a(2, 'secundus'); - -print "not " unless $obj->a(2) eq 'secundus'; -print "ok 3\n"; - -my $hrf = $obj->h; - -print "not " unless ref $hrf eq 'HASH'; -print "ok 4\n"; - -$obj->h('x', 10); - -print "not " unless $obj->h('x') == 10; -print "ok 5\n"; - -my $orf = $obj->c; - -print "not " unless ref $orf eq 'aClass'; -print "ok 6\n"; - -print "not " unless $obj->c->meth() == 42; -print "ok 7\n"; - -my $obk = SomeClass->new(); - -$obk->SomeElem(123); - -print "not " unless $obk->SomeElem() == 123; -print "ok 8\n"; - -$obj->a([4,5,6]); - -print "not " unless $obj->a(1) == 5; -print "ok 9\n"; - -$obj->h({h=>7,r=>8,f=>9}); - -print "not " unless $obj->h('r') == 8; -print "ok 10\n"; - diff --git a/t/lib/complex.t b/t/lib/complex.t deleted file mode 100755 index 334374d519..0000000000 --- a/t/lib/complex.t +++ /dev/null @@ -1,979 +0,0 @@ -#!./perl - -# $RCSfile: complex.t,v $ -# -# Regression tests for the Math::Complex pacakge -# -- Raphael Manfredi since Sep 1996 -# -- Jarkko Hietaniemi since Mar 1997 -# -- Daniel S. Lewart since Sep 1997 - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Math::Complex; - -use vars qw($VERSION); - -$VERSION = 1.91; - -my ($args, $op, $target, $test, $test_set, $try, $val, $zvalue, @set, @val); - -$test = 0; -$| = 1; -my @script = ( - 'my ($res, $s0,$s1,$s2,$s3,$s4,$s5,$s6,$s7,$s8,$s9,$s10, $z0,$z1,$z2);' . - "\n\n" -); -my $eps = 1e-13; - -if ($^O eq 'unicos') { # For some reason root() produces very inaccurate - $eps = 1e-10; # results in Cray UNICOS, and occasionally also -} # cos(), sin(), cosh(), sinh(). The division - # of doubles is the current suspect. - -while (<DATA>) { - s/^\s+//; - next if $_ eq '' || /^\#/; - chomp; - $test_set = 0; # Assume not a test over a set of values - if (/^&(.+)/) { - $op = $1; - next; - } - elsif (/^\{(.+)\}/) { - set($1, \@set, \@val); - next; - } - elsif (s/^\|//) { - $test_set = 1; # Requests we loop over the set... - } - my @args = split(/:/); - if ($test_set == 1) { - my $i; - for ($i = 0; $i < @set; $i++) { - # complex number - $target = $set[$i]; - # textual value as found in set definition - $zvalue = $val[$i]; - test($zvalue, $target, @args); - } - } else { - test($op, undef, @args); - } -} - -# - -sub test_mutators { - my $op; - - $test++; -push(@script, <<'EOT'); -{ - my $z = cplx( 1, 1); - $z->Re(2); - $z->Im(3); - print "# $test Re(z) = ",$z->Re(), " Im(z) = ", $z->Im(), " z = $z\n"; - print 'not ' unless Re($z) == 2 and Im($z) == 3; -EOT - push(@script, qq(print "ok $test\\n"}\n)); - - $test++; -push(@script, <<'EOT'); -{ - my $z = cplx( 1, 1); - $z->abs(3 * sqrt(2)); - print "# $test Re(z) = ",$z->Re(), " Im(z) = ", $z->Im(), " z = $z\n"; - print 'not ' unless (abs($z) - 3 * sqrt(2)) < $eps and - (arg($z) - pi / 4 ) < $eps and - (Re($z) - 3 ) < $eps and - (Im($z) - 3 ) < $eps; -EOT - push(@script, qq(print "ok $test\\n"}\n)); - - $test++; -push(@script, <<'EOT'); -{ - my $z = cplx( 1, 1); - $z->arg(-3 / 4 * pi); - print "# $test Re(z) = ",$z->Re(), " Im(z) = ", $z->Im(), " z = $z\n"; - print 'not ' unless (arg($z) + 3 / 4 * pi) < $eps and - (abs($z) - sqrt(2) ) < $eps and - (Re($z) + 1 ) < $eps and - (Im($z) + 1 ) < $eps; -EOT - push(@script, qq(print "ok $test\\n"}\n)); -} - -test_mutators(); - -my $constants = ' -my $i = cplx(0, 1); -my $pi = cplx(pi, 0); -my $pii = cplx(0, pi); -my $pip2 = cplx(pi/2, 0); -my $zero = cplx(0, 0); -'; - -push(@script, $constants); - - -# test the divbyzeros - -sub test_dbz { - for my $op (@_) { - $test++; - push(@script, <<EOT); - eval '$op'; - (\$bad) = (\$@ =~ /(.+)/); - print "# $test op = $op divbyzero? \$bad...\n"; - print 'not ' unless (\$@ =~ /Division by zero/); -EOT - push(@script, qq(print "ok $test\\n";\n)); - } -} - -# test the logofzeros - -sub test_loz { - for my $op (@_) { - $test++; - push(@script, <<EOT); - eval '$op'; - (\$bad) = (\$@ =~ /(.+)/); - print "# $test op = $op logofzero? \$bad...\n"; - print 'not ' unless (\$@ =~ /Logarithm of zero/); -EOT - push(@script, qq(print "ok $test\\n";\n)); - } -} - -test_dbz( - 'i/0', - 'acot(0)', - 'acot(+$i)', -# 'acoth(-1)', # Log of zero. - 'acoth(0)', - 'acoth(+1)', - 'acsc(0)', - 'acsch(0)', - 'asec(0)', - 'asech(0)', - 'atan($i)', -# 'atanh(-1)', # Log of zero. - 'atanh(+1)', - 'cot(0)', - 'coth(0)', - 'csc(0)', - 'csch(0)', - ); - -test_loz( - 'log($zero)', - 'atan(-$i)', - 'acot(-$i)', - 'atanh(-1)', - 'acoth(-1)', - ); - -# test the bad roots - -sub test_broot { - for my $op (@_) { - $test++; - push(@script, <<EOT); - eval 'root(2, $op)'; - (\$bad) = (\$@ =~ /(.+)/); - print "# $test op = $op badroot? \$bad...\n"; - print 'not ' unless (\$@ =~ /root rank must be/); -EOT - push(@script, qq(print "ok $test\\n";\n)); - } -} - -test_broot(qw(-3 -2.1 0 0.99)); - -sub test_display_format { - $test++; - push @script, <<EOS; - print "# package display_format cartesian?\n"; - print "not " unless Math::Complex->display_format eq 'cartesian'; - print "ok $test\n"; -EOS - - push @script, <<EOS; - my \$j = (root(1,3))[1]; - - \$j->display_format('polar'); -EOS - - $test++; - push @script, <<EOS; - print "# j display_format polar?\n"; - print "not " unless \$j->display_format eq 'polar'; - print "ok $test\n"; -EOS - - $test++; - push @script, <<EOS; - print "# j = \$j\n"; - print "not " unless "\$j" eq "[1,2pi/3]"; - print "ok $test\n"; - - my %display_format; - - %display_format = \$j->display_format; -EOS - - $test++; - push @script, <<EOS; - print "# display_format{style} polar?\n"; - print "not " unless \$display_format{style} eq 'polar'; - print "ok $test\n"; -EOS - - $test++; - push @script, <<EOS; - print "# keys %display_format == 2?\n"; - print "not " unless keys %display_format == 2; - print "ok $test\n"; - - \$j->display_format('style' => 'cartesian', 'format' => '%.5f'); -EOS - - $test++; - push @script, <<EOS; - print "# j = \$j\n"; - print "not " unless "\$j" eq "-0.50000+0.86603i"; - print "ok $test\n"; - - %display_format = \$j->display_format; -EOS - - $test++; - push @script, <<EOS; - print "# display_format{format} %.5f?\n"; - print "not " unless \$display_format{format} eq '%.5f'; - print "ok $test\n"; -EOS - - $test++; - push @script, <<EOS; - print "# keys %display_format == 3?\n"; - print "not " unless keys %display_format == 3; - print "ok $test\n"; - - \$j->display_format('format' => undef); -EOS - - $test++; - push @script, <<EOS; - print "# j = \$j\n"; - print "not " unless "\$j" =~ /^-0(?:\\.5(?:0000\\d+)?|\\.49999\\d+)\\+0.86602540\\d+i\$/; - print "ok $test\n"; - - \$j->display_format('style' => 'polar', 'polar_pretty_print' => 0); -EOS - - $test++; - push @script, <<EOS; - print "# j = \$j\n"; - print "not " unless "\$j" =~ /^\\[1,2\\.09439510\\d+\\]\$/; - print "ok $test\n"; - - \$j->display_format('style' => 'cartesian', 'format' => '(%.5g)'); -EOS - - $test++; - push @script, <<EOS; - print "# j = \$j\n"; - print "not " unless "\$j" eq "(-0.5)+(0.86603)i"; - print "ok $test\n"; -EOS - - $test++; - push @script, <<EOS; - print "# j display_format cartesian?\n"; - print "not " unless \$j->display_format eq 'cartesian'; - print "ok $test\n"; -EOS -} - -test_display_format(); - -print "1..$test\n"; -eval join '', @script; -die $@ if $@; - -sub abop { - my ($op) = @_; - - push(@script, qq(print "# $op=\n";)); -} - -sub test { - my ($op, $z, @args) = @_; - my ($baop) = 0; - $test++; - my $i; - $baop = 1 if ($op =~ s/;=$//); - for ($i = 0; $i < @args; $i++) { - $val = value($args[$i]); - push @script, "\$z$i = $val;\n"; - } - if (defined $z) { - $args = "'$op'"; # Really the value - $try = "abs(\$z0 - \$z1) <= $eps ? \$z1 : \$z0"; - push @script, "\$res = $try; "; - push @script, "check($test, $args[0], \$res, \$z$#args, $args);\n"; - } else { - my ($try, $args); - if (@args == 2) { - $try = "$op \$z0"; - $args = "'$args[0]'"; - } else { - $try = ($op =~ /^\w/) ? "$op(\$z0, \$z1)" : "\$z0 $op \$z1"; - $args = "'$args[0]', '$args[1]'"; - } - push @script, "\$res = $try; "; - push @script, "check($test, '$try', \$res, \$z$#args, $args);\n"; - if (@args > 2 and $baop) { # binary assignment ops - $test++; - # check the op= works - push @script, <<EOB; -{ - my \$za = cplx(ref \$z0 ? \@{\$z0->cartesian} : (\$z0, 0)); - - my (\$z1r, \$z1i) = ref \$z1 ? \@{\$z1->cartesian} : (\$z1, 0); - - my \$zb = cplx(\$z1r, \$z1i); - - \$za $op= \$zb; - my (\$zbr, \$zbi) = \@{\$zb->cartesian}; - - check($test, '\$z0 $op= \$z1', \$za, \$z$#args, $args); -EOB - $test++; - # check that the rhs has not changed - push @script, qq(print "not " unless (\$zbr == \$z1r and \$zbi == \$z1i);); - push @script, qq(print "ok $test\\n";\n); - push @script, "}\n"; - } - } -} - -sub set { - my ($set, $setref, $valref) = @_; - @{$setref} = (); - @{$valref} = (); - my @set = split(/;\s*/, $set); - my @res; - my $i; - for ($i = 0; $i < @set; $i++) { - push(@{$valref}, $set[$i]); - my $val = value($set[$i]); - push @script, "\$s$i = $val;\n"; - push @{$setref}, "\$s$i"; - } -} - -sub value { - local ($_) = @_; - if (/^\s*\((.*),(.*)\)/) { - return "cplx($1,$2)"; - } - elsif (/^\s*([\-\+]?(?:\d+(\.\d+)?|\.\d+)(?:[e[\-\+]\d+])?)/) { - return "cplx($1,0)"; - } - elsif (/^\s*\[(.*),(.*)\]/) { - return "cplxe($1,$2)"; - } - elsif (/^\s*'(.*)'/) { - my $ex = $1; - $ex =~ s/\bz\b/$target/g; - $ex =~ s/\br\b/abs($target)/g; - $ex =~ s/\bt\b/arg($target)/g; - $ex =~ s/\ba\b/Re($target)/g; - $ex =~ s/\bb\b/Im($target)/g; - return $ex; - } - elsif (/^\s*"(.*)"/) { - return "\"$1\""; - } - return $_; -} - -sub check { - my ($test, $try, $got, $expected, @z) = @_; - - print "# @_\n"; - - if ("$got" eq "$expected" - || - ($expected =~ /^-?\d/ && $got == $expected) - || - (abs($got - $expected) < $eps) - ) { - print "ok $test\n"; - } else { - print "not ok $test\n"; - my $args = (@z == 1) ? "z = $z[0]" : "z0 = $z[0], z1 = $z[1]"; - print "# '$try' expected: '$expected' got: '$got' for $args\n"; - } -} - -sub addsq { - my ($z1, $z2) = @_; - return ($z1 + i*$z2) * ($z1 - i*$z2); -} - -sub subsq { - my ($z1, $z2) = @_; - return ($z1 + $z2) * ($z1 - $z2); -} - -__END__ -&+;= -(3,4):(3,4):(6,8) -(-3,4):(3,-4):(0,0) -(3,4):-3:(0,4) -1:(4,2):(5,2) -[2,0]:[2,pi]:(0,0) - -&++ -(2,1):(3,1) - -&-;= -(2,3):(-2,-3) -[2,pi/2]:[2,-(pi)/2] -2:[2,0]:(0,0) -[3,0]:2:(1,0) -3:(4,5):(-1,-5) -(4,5):3:(1,5) -(2,1):(3,5):(-1,-4) - -&-- -(1,2):(0,2) -[2,pi]:[3,pi] - -&*;= -(0,1):(0,1):(-1,0) -(4,5):(1,0):(4,5) -[2,2*pi/3]:(1,0):[2,2*pi/3] -2:(0,1):(0,2) -(0,1):3:(0,3) -(0,1):(4,1):(-1,4) -(2,1):(4,-1):(9,2) - -&/;= -(3,4):(3,4):(1,0) -(4,-5):1:(4,-5) -1:(0,1):(0,-1) -(0,6):(0,2):(3,0) -(9,2):(4,-1):(2,1) -[4,pi]:[2,pi/2]:[2,pi/2] -[2,pi/2]:[4,pi]:[0.5,-(pi)/2] - -&**;= -(2,0):(3,0):(8,0) -(3,0):(2,0):(9,0) -(2,3):(4,0):(-119,-120) -(0,0):(1,0):(0,0) -(0,0):(2,3):(0,0) -(1,0):(0,0):(1,0) -(1,0):(1,0):(1,0) -(1,0):(2,3):(1,0) -(2,3):(0,0):(1,0) -(2,3):(1,0):(2,3) -(0,0):(0,0):(1,0) - -&Re -(3,4):3 -(-3,4):-3 -[1,pi/2]:0 - -&Im -(3,4):4 -(3,-4):-4 -[1,pi/2]:1 - -&abs -(3,4):5 -(-3,4):5 - -&arg -[2,0]:0 -[-2,0]:pi - -&~ -(4,5):(4,-5) -(-3,4):(-3,-4) -[2,pi/2]:[2,-(pi)/2] - -&< -(3,4):(1,2):0 -(3,4):(3,2):0 -(3,4):(3,8):1 -(4,4):(5,129):1 - -&== -(3,4):(4,5):0 -(3,4):(3,5):0 -(3,4):(2,4):0 -(3,4):(3,4):1 - -&sqrt --9:(0,3) -(-100,0):(0,10) -(16,-30):(5,-3) - -&stringify_cartesian -(-100,0):"-100" -(0,1):"i" -(4,-3):"4-3i" -(4,0):"4" -(-4,0):"-4" -(-2,4):"-2+4i" -(-2,-1):"-2-i" - -&stringify_polar -[-1, 0]:"[1,pi]" -[1, pi/3]:"[1,pi/3]" -[6, -2*pi/3]:"[6,-2pi/3]" -[0.5, -9*pi/11]:"[0.5,-9pi/11]" - -{ (4,3); [3,2]; (-3,4); (0,2); [2,1] } - -|'z + ~z':'2*Re(z)' -|'z - ~z':'2*i*Im(z)' -|'z * ~z':'abs(z) * abs(z)' - -{ (0.5, 0); (-0.5, 0); (2,3); [3,2]; (-3,2); (0,2); 3; 1.2; (-3, 0); (-2, -1); [2,1] } - -|'(root(z, 4))[1] ** 4':'z' -|'(root(z, 5))[3] ** 5':'z' -|'(root(z, 8))[7] ** 8':'z' -|'abs(z)':'r' -|'acot(z)':'acotan(z)' -|'acsc(z)':'acosec(z)' -|'acsc(z)':'asin(1 / z)' -|'asec(z)':'acos(1 / z)' -|'cbrt(z)':'cbrt(r) * exp(i * t/3)' -|'cos(acos(z))':'z' -|'addsq(cos(z), sin(z))':1 -|'cos(z)':'cosh(i*z)' -|'subsq(cosh(z), sinh(z))':1 -|'cot(acot(z))':'z' -|'cot(z)':'1 / tan(z)' -|'cot(z)':'cotan(z)' -|'csc(acsc(z))':'z' -|'csc(z)':'1 / sin(z)' -|'csc(z)':'cosec(z)' -|'exp(log(z))':'z' -|'exp(z)':'exp(a) * exp(i * b)' -|'ln(z)':'log(z)' -|'log(exp(z))':'z' -|'log(z)':'log(r) + i*t' -|'log10(z)':'log(z) / log(10)' -|'logn(z, 2)':'log(z) / log(2)' -|'logn(z, 3)':'log(z) / log(3)' -|'sec(asec(z))':'z' -|'sec(z)':'1 / cos(z)' -|'sin(asin(z))':'z' -|'sin(i * z)':'i * sinh(z)' -|'sqrt(z) * sqrt(z)':'z' -|'sqrt(z)':'sqrt(r) * exp(i * t/2)' -|'tan(atan(z))':'z' -|'z**z':'exp(z * log(z))' - -{ (1,1); [1,0.5]; (-2, -1); 2; -3; (-1,0.5); (0,0.5); 0.5; (2, 0); (-1, -2) } - -|'cosh(acosh(z))':'z' -|'coth(acoth(z))':'z' -|'coth(z)':'1 / tanh(z)' -|'coth(z)':'cotanh(z)' -|'csch(acsch(z))':'z' -|'csch(z)':'1 / sinh(z)' -|'csch(z)':'cosech(z)' -|'sech(asech(z))':'z' -|'sech(z)':'1 / cosh(z)' -|'sinh(asinh(z))':'z' -|'tanh(atanh(z))':'z' - -{ (0.2,-0.4); [1,0.5]; -1.2; (-1,0.5); 0.5; (1.1, 0) } - -|'acos(cos(z)) ** 2':'z * z' -|'acosh(cosh(z)) ** 2':'z * z' -|'acoth(z)':'acotanh(z)' -|'acoth(z)':'atanh(1 / z)' -|'acsch(z)':'acosech(z)' -|'acsch(z)':'asinh(1 / z)' -|'asech(z)':'acosh(1 / z)' -|'asin(sin(z))':'z' -|'asinh(sinh(z))':'z' -|'atan(tan(z))':'z' -|'atanh(tanh(z))':'z' - -&log -(-2.0,0):( 0.69314718055995, 3.14159265358979) -(-1.0,0):( 0 , 3.14159265358979) -(-0.5,0):( -0.69314718055995, 3.14159265358979) -( 0.5,0):( -0.69314718055995, 0 ) -( 1.0,0):( 0 , 0 ) -( 2.0,0):( 0.69314718055995, 0 ) - -&log -( 2, 3):( 1.28247467873077, 0.98279372324733) -(-2, 3):( 1.28247467873077, 2.15879893034246) -(-2,-3):( 1.28247467873077, -2.15879893034246) -( 2,-3):( 1.28247467873077, -0.98279372324733) - -&sin -(-2.0,0):( -0.90929742682568, 0 ) -(-1.0,0):( -0.84147098480790, 0 ) -(-0.5,0):( -0.47942553860420, 0 ) -( 0.0,0):( 0 , 0 ) -( 0.5,0):( 0.47942553860420, 0 ) -( 1.0,0):( 0.84147098480790, 0 ) -( 2.0,0):( 0.90929742682568, 0 ) - -&sin -( 2, 3):( 9.15449914691143, -4.16890695996656) -(-2, 3):( -9.15449914691143, -4.16890695996656) -(-2,-3):( -9.15449914691143, 4.16890695996656) -( 2,-3):( 9.15449914691143, 4.16890695996656) - -&cos -(-2.0,0):( -0.41614683654714, 0 ) -(-1.0,0):( 0.54030230586814, 0 ) -(-0.5,0):( 0.87758256189037, 0 ) -( 0.0,0):( 1 , 0 ) -( 0.5,0):( 0.87758256189037, 0 ) -( 1.0,0):( 0.54030230586814, 0 ) -( 2.0,0):( -0.41614683654714, 0 ) - -&cos -( 2, 3):( -4.18962569096881, -9.10922789375534) -(-2, 3):( -4.18962569096881, 9.10922789375534) -(-2,-3):( -4.18962569096881, -9.10922789375534) -( 2,-3):( -4.18962569096881, 9.10922789375534) - -&tan -(-2.0,0):( 2.18503986326152, 0 ) -(-1.0,0):( -1.55740772465490, 0 ) -(-0.5,0):( -0.54630248984379, 0 ) -( 0.0,0):( 0 , 0 ) -( 0.5,0):( 0.54630248984379, 0 ) -( 1.0,0):( 1.55740772465490, 0 ) -( 2.0,0):( -2.18503986326152, 0 ) - -&tan -( 2, 3):( -0.00376402564150, 1.00323862735361) -(-2, 3):( 0.00376402564150, 1.00323862735361) -(-2,-3):( 0.00376402564150, -1.00323862735361) -( 2,-3):( -0.00376402564150, -1.00323862735361) - -&sec -(-2.0,0):( -2.40299796172238, 0 ) -(-1.0,0):( 1.85081571768093, 0 ) -(-0.5,0):( 1.13949392732455, 0 ) -( 0.0,0):( 1 , 0 ) -( 0.5,0):( 1.13949392732455, 0 ) -( 1.0,0):( 1.85081571768093, 0 ) -( 2.0,0):( -2.40299796172238, 0 ) - -&sec -( 2, 3):( -0.04167496441114, 0.09061113719624) -(-2, 3):( -0.04167496441114, -0.09061113719624) -(-2,-3):( -0.04167496441114, 0.09061113719624) -( 2,-3):( -0.04167496441114, -0.09061113719624) - -&csc -(-2.0,0):( -1.09975017029462, 0 ) -(-1.0,0):( -1.18839510577812, 0 ) -(-0.5,0):( -2.08582964293349, 0 ) -( 0.5,0):( 2.08582964293349, 0 ) -( 1.0,0):( 1.18839510577812, 0 ) -( 2.0,0):( 1.09975017029462, 0 ) - -&csc -( 2, 3):( 0.09047320975321, 0.04120098628857) -(-2, 3):( -0.09047320975321, 0.04120098628857) -(-2,-3):( -0.09047320975321, -0.04120098628857) -( 2,-3):( 0.09047320975321, -0.04120098628857) - -&cot -(-2.0,0):( 0.45765755436029, 0 ) -(-1.0,0):( -0.64209261593433, 0 ) -(-0.5,0):( -1.83048772171245, 0 ) -( 0.5,0):( 1.83048772171245, 0 ) -( 1.0,0):( 0.64209261593433, 0 ) -( 2.0,0):( -0.45765755436029, 0 ) - -&cot -( 2, 3):( -0.00373971037634, -0.99675779656936) -(-2, 3):( 0.00373971037634, -0.99675779656936) -(-2,-3):( 0.00373971037634, 0.99675779656936) -( 2,-3):( -0.00373971037634, 0.99675779656936) - -&asin -(-2.0,0):( -1.57079632679490, 1.31695789692482) -(-1.0,0):( -1.57079632679490, 0 ) -(-0.5,0):( -0.52359877559830, 0 ) -( 0.0,0):( 0 , 0 ) -( 0.5,0):( 0.52359877559830, 0 ) -( 1.0,0):( 1.57079632679490, 0 ) -( 2.0,0):( 1.57079632679490, -1.31695789692482) - -&asin -( 2, 3):( 0.57065278432110, 1.98338702991654) -(-2, 3):( -0.57065278432110, 1.98338702991654) -(-2,-3):( -0.57065278432110, -1.98338702991654) -( 2,-3):( 0.57065278432110, -1.98338702991654) - -&acos -(-2.0,0):( 3.14159265358979, -1.31695789692482) -(-1.0,0):( 3.14159265358979, 0 ) -(-0.5,0):( 2.09439510239320, 0 ) -( 0.0,0):( 1.57079632679490, 0 ) -( 0.5,0):( 1.04719755119660, 0 ) -( 1.0,0):( 0 , 0 ) -( 2.0,0):( 0 , 1.31695789692482) - -&acos -( 2, 3):( 1.00014354247380, -1.98338702991654) -(-2, 3):( 2.14144911111600, -1.98338702991654) -(-2,-3):( 2.14144911111600, 1.98338702991654) -( 2,-3):( 1.00014354247380, 1.98338702991654) - -&atan -(-2.0,0):( -1.10714871779409, 0 ) -(-1.0,0):( -0.78539816339745, 0 ) -(-0.5,0):( -0.46364760900081, 0 ) -( 0.0,0):( 0 , 0 ) -( 0.5,0):( 0.46364760900081, 0 ) -( 1.0,0):( 0.78539816339745, 0 ) -( 2.0,0):( 1.10714871779409, 0 ) - -&atan -( 2, 3):( 1.40992104959658, 0.22907268296854) -(-2, 3):( -1.40992104959658, 0.22907268296854) -(-2,-3):( -1.40992104959658, -0.22907268296854) -( 2,-3):( 1.40992104959658, -0.22907268296854) - -&asec -(-2.0,0):( 2.09439510239320, 0 ) -(-1.0,0):( 3.14159265358979, 0 ) -(-0.5,0):( 3.14159265358979, -1.31695789692482) -( 0.5,0):( 0 , 1.31695789692482) -( 1.0,0):( 0 , 0 ) -( 2.0,0):( 1.04719755119660, 0 ) - -&asec -( 2, 3):( 1.42041072246703, 0.23133469857397) -(-2, 3):( 1.72118193112276, 0.23133469857397) -(-2,-3):( 1.72118193112276, -0.23133469857397) -( 2,-3):( 1.42041072246703, -0.23133469857397) - -&acsc -(-2.0,0):( -0.52359877559830, 0 ) -(-1.0,0):( -1.57079632679490, 0 ) -(-0.5,0):( -1.57079632679490, 1.31695789692482) -( 0.5,0):( 1.57079632679490, -1.31695789692482) -( 1.0,0):( 1.57079632679490, 0 ) -( 2.0,0):( 0.52359877559830, 0 ) - -&acsc -( 2, 3):( 0.15038560432786, -0.23133469857397) -(-2, 3):( -0.15038560432786, -0.23133469857397) -(-2,-3):( -0.15038560432786, 0.23133469857397) -( 2,-3):( 0.15038560432786, 0.23133469857397) - -&acot -(-2.0,0):( -0.46364760900081, 0 ) -(-1.0,0):( -0.78539816339745, 0 ) -(-0.5,0):( -1.10714871779409, 0 ) -( 0.5,0):( 1.10714871779409, 0 ) -( 1.0,0):( 0.78539816339745, 0 ) -( 2.0,0):( 0.46364760900081, 0 ) - -&acot -( 2, 3):( 0.16087527719832, -0.22907268296854) -(-2, 3):( -0.16087527719832, -0.22907268296854) -(-2,-3):( -0.16087527719832, 0.22907268296854) -( 2,-3):( 0.16087527719832, 0.22907268296854) - -&sinh -(-2.0,0):( -3.62686040784702, 0 ) -(-1.0,0):( -1.17520119364380, 0 ) -(-0.5,0):( -0.52109530549375, 0 ) -( 0.0,0):( 0 , 0 ) -( 0.5,0):( 0.52109530549375, 0 ) -( 1.0,0):( 1.17520119364380, 0 ) -( 2.0,0):( 3.62686040784702, 0 ) - -&sinh -( 2, 3):( -3.59056458998578, 0.53092108624852) -(-2, 3):( 3.59056458998578, 0.53092108624852) -(-2,-3):( 3.59056458998578, -0.53092108624852) -( 2,-3):( -3.59056458998578, -0.53092108624852) - -&cosh -(-2.0,0):( 3.76219569108363, 0 ) -(-1.0,0):( 1.54308063481524, 0 ) -(-0.5,0):( 1.12762596520638, 0 ) -( 0.0,0):( 1 , 0 ) -( 0.5,0):( 1.12762596520638, 0 ) -( 1.0,0):( 1.54308063481524, 0 ) -( 2.0,0):( 3.76219569108363, 0 ) - -&cosh -( 2, 3):( -3.72454550491532, 0.51182256998738) -(-2, 3):( -3.72454550491532, -0.51182256998738) -(-2,-3):( -3.72454550491532, 0.51182256998738) -( 2,-3):( -3.72454550491532, -0.51182256998738) - -&tanh -(-2.0,0):( -0.96402758007582, 0 ) -(-1.0,0):( -0.76159415595576, 0 ) -(-0.5,0):( -0.46211715726001, 0 ) -( 0.0,0):( 0 , 0 ) -( 0.5,0):( 0.46211715726001, 0 ) -( 1.0,0):( 0.76159415595576, 0 ) -( 2.0,0):( 0.96402758007582, 0 ) - -&tanh -( 2, 3):( 0.96538587902213, -0.00988437503832) -(-2, 3):( -0.96538587902213, -0.00988437503832) -(-2,-3):( -0.96538587902213, 0.00988437503832) -( 2,-3):( 0.96538587902213, 0.00988437503832) - -&sech -(-2.0,0):( 0.26580222883408, 0 ) -(-1.0,0):( 0.64805427366389, 0 ) -(-0.5,0):( 0.88681888397007, 0 ) -( 0.0,0):( 1 , 0 ) -( 0.5,0):( 0.88681888397007, 0 ) -( 1.0,0):( 0.64805427366389, 0 ) -( 2.0,0):( 0.26580222883408, 0 ) - -&sech -( 2, 3):( -0.26351297515839, -0.03621163655877) -(-2, 3):( -0.26351297515839, 0.03621163655877) -(-2,-3):( -0.26351297515839, -0.03621163655877) -( 2,-3):( -0.26351297515839, 0.03621163655877) - -&csch -(-2.0,0):( -0.27572056477178, 0 ) -(-1.0,0):( -0.85091812823932, 0 ) -(-0.5,0):( -1.91903475133494, 0 ) -( 0.5,0):( 1.91903475133494, 0 ) -( 1.0,0):( 0.85091812823932, 0 ) -( 2.0,0):( 0.27572056477178, 0 ) - -&csch -( 2, 3):( -0.27254866146294, -0.04030057885689) -(-2, 3):( 0.27254866146294, -0.04030057885689) -(-2,-3):( 0.27254866146294, 0.04030057885689) -( 2,-3):( -0.27254866146294, 0.04030057885689) - -&coth -(-2.0,0):( -1.03731472072755, 0 ) -(-1.0,0):( -1.31303528549933, 0 ) -(-0.5,0):( -2.16395341373865, 0 ) -( 0.5,0):( 2.16395341373865, 0 ) -( 1.0,0):( 1.31303528549933, 0 ) -( 2.0,0):( 1.03731472072755, 0 ) - -&coth -( 2, 3):( 1.03574663776500, 0.01060478347034) -(-2, 3):( -1.03574663776500, 0.01060478347034) -(-2,-3):( -1.03574663776500, -0.01060478347034) -( 2,-3):( 1.03574663776500, -0.01060478347034) - -&asinh -(-2.0,0):( -1.44363547517881, 0 ) -(-1.0,0):( -0.88137358701954, 0 ) -(-0.5,0):( -0.48121182505960, 0 ) -( 0.0,0):( 0 , 0 ) -( 0.5,0):( 0.48121182505960, 0 ) -( 1.0,0):( 0.88137358701954, 0 ) -( 2.0,0):( 1.44363547517881, 0 ) - -&asinh -( 2, 3):( 1.96863792579310, 0.96465850440760) -(-2, 3):( -1.96863792579310, 0.96465850440761) -(-2,-3):( -1.96863792579310, -0.96465850440761) -( 2,-3):( 1.96863792579310, -0.96465850440760) - -&acosh -(-2.0,0):( 1.31695789692482, 3.14159265358979) -(-1.0,0):( 0, 3.14159265358979) -(-0.5,0):( 0, 2.09439510239320) -( 0.0,0):( 0, 1.57079632679490) -( 0.5,0):( 0, 1.04719755119660) -( 1.0,0):( 0 , 0 ) -( 2.0,0):( 1.31695789692482, 0 ) - -&acosh -( 2, 3):( 1.98338702991654, 1.00014354247380) -(-2, 3):( 1.98338702991653, 2.14144911111600) -(-2,-3):( 1.98338702991653, -2.14144911111600) -( 2,-3):( 1.98338702991654, -1.00014354247380) - -&atanh -(-2.0,0):( -0.54930614433405, 1.57079632679490) -(-0.5,0):( -0.54930614433405, 0 ) -( 0.0,0):( 0 , 0 ) -( 0.5,0):( 0.54930614433405, 0 ) -( 2.0,0):( 0.54930614433405, 1.57079632679490) - -&atanh -( 2, 3):( 0.14694666622553, 1.33897252229449) -(-2, 3):( -0.14694666622553, 1.33897252229449) -(-2,-3):( -0.14694666622553, -1.33897252229449) -( 2,-3):( 0.14694666622553, -1.33897252229449) - -&asech -(-2.0,0):( 0 , 2.09439510239320) -(-1.0,0):( 0 , 3.14159265358979) -(-0.5,0):( 1.31695789692482, 3.14159265358979) -( 0.5,0):( 1.31695789692482, 0 ) -( 1.0,0):( 0 , 0 ) -( 2.0,0):( 0 , 1.04719755119660) - -&asech -( 2, 3):( 0.23133469857397, -1.42041072246703) -(-2, 3):( 0.23133469857397, -1.72118193112276) -(-2,-3):( 0.23133469857397, 1.72118193112276) -( 2,-3):( 0.23133469857397, 1.42041072246703) - -&acsch -(-2.0,0):( -0.48121182505960, 0 ) -(-1.0,0):( -0.88137358701954, 0 ) -(-0.5,0):( -1.44363547517881, 0 ) -( 0.5,0):( 1.44363547517881, 0 ) -( 1.0,0):( 0.88137358701954, 0 ) -( 2.0,0):( 0.48121182505960, 0 ) - -&acsch -( 2, 3):( 0.15735549884499, -0.22996290237721) -(-2, 3):( -0.15735549884499, -0.22996290237721) -(-2,-3):( -0.15735549884499, 0.22996290237721) -( 2,-3):( 0.15735549884499, 0.22996290237721) - -&acoth -(-2.0,0):( -0.54930614433405, 0 ) -(-0.5,0):( -0.54930614433405, 1.57079632679490) -( 0.5,0):( 0.54930614433405, 1.57079632679490) -( 2.0,0):( 0.54930614433405, 0 ) - -&acoth -( 2, 3):( 0.14694666622553, -0.23182380450040) -(-2, 3):( -0.14694666622553, -0.23182380450040) -(-2,-3):( -0.14694666622553, 0.23182380450040) -( 2,-3):( 0.14694666622553, 0.23182380450040) - -# eof diff --git a/t/lib/cpan-loadme.t b/t/lib/cpan-loadme.t deleted file mode 100644 index dce7e1081d..0000000000 --- a/t/lib/cpan-loadme.t +++ /dev/null @@ -1,16 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -BEGIN { - print "1..1\n"; -} -use strict; -use CPAN; -use CPAN::FirstTime; - -print "ok 1\n"; - diff --git a/t/lib/cpan-vcmp.t b/t/lib/cpan-vcmp.t deleted file mode 100644 index 290fc3d206..0000000000 --- a/t/lib/cpan-vcmp.t +++ /dev/null @@ -1,62 +0,0 @@ -# -*- Mode: cperl; coding: utf-8; -*- - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use strict; -use CPAN; -use vars qw($D $N); - -while (<DATA>) { - next if /^v/ && $]<5.006; # v-string tests are not for pre-5.6.0 - chomp; - s/\s*#.*//; - push @$D, [ split ]; -} - -$N = scalar @$D; -print "1..$N\n"; - -while (@$D) { - my($l,$r,$exp) = @{shift @$D}; - my $res = CPAN::Version->vcmp($l,$r); - if ($res != $exp){ - print "# l[$l]r[$r]exp[$exp]res[$res]\n"; - print "not "; - } - print "ok ", $N-@$D, "\n"; -} - -__END__ -0 0 0 -1 0 1 -0 1 -1 -1 1 0 -1.1 0.0a 1 -1.1a 0.0 1 -1.2.3 1.1.1 1 -v1.2.3 v1.1.1 1 -v1.2.3 v1.2.1 1 -v1.2.3 v1.2.11 -1 -1.2.3 1.2.11 1 # not what they wanted -1.9 1.10 1 -VERSION VERSION 0 -0.02 undef 1 -1.57_00 1.57 1 -1.5700 1.57 1 -1.57_01 1.57 1 -0.2.10 0.2 1 -20000000.00 19990108 1 -1.00 0.96 1 -0.7.02 0.7 1 -1.3a5 1.3 1 -undef 1.00 -1 -v1.0 undef 1 -v0.2.4 0.24 -1 -v1.0.22 122 -1 -5.00556 v5.5.560 0 -5.005056 v5.5.56 0 -5.00557 v5.5.560 1 -5.00056 v5.0.561 -1 diff --git a/t/lib/cwd.t b/t/lib/cwd.t deleted file mode 100644 index 09b45d6004..0000000000 --- a/t/lib/cwd.t +++ /dev/null @@ -1,134 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Config; -use Cwd; -use strict; -use warnings; - -print "1..14\n"; - -# check imports -print +(defined(&cwd) && - defined(&getcwd) && - defined(&fastcwd) && - defined(&fastgetcwd) ? - "" : "not "), "ok 1\n"; -print +(!defined(&chdir) && - !defined(&abs_path) && - !defined(&fast_abs_path) ? - "" : "not "), "ok 2\n"; - -# XXX force Cwd to bootsrap its XSUBs since we have set @INC = "../lib" -# XXX and subsequent chdir()s can make them impossible to find -eval { fastcwd }; - -# Must find an external pwd (or equivalent) command. - -my $pwd_cmd = - ($^O eq "MSWin32" || $^O eq "NetWare") ? "cd" : (grep { -x && -f } map { "$_/pwd" } - split m/$Config{path_sep}/, $ENV{PATH})[0]; - -if ($^O eq 'VMS') { $pwd_cmd = 'SHOW DEFAULT'; } - -if (defined $pwd_cmd) { - chomp(my $start = `$pwd_cmd`); - # Win32's cd returns native C:\ style - $start =~ s,\\,/,g if ($^O eq 'MSWin32' || $^O eq "NetWare"); - # DCL SHOW DEFAULT has leading spaces - $start =~ s/^\s+// if $^O eq 'VMS'; - if ($?) { - for (3..6) { - print "ok $_ # Skip: '$pwd_cmd' failed\n"; - } - } else { - my $cwd = cwd; - my $getcwd = getcwd; - my $fastcwd = fastcwd; - my $fastgetcwd = fastgetcwd; - print +($cwd eq $start ? "" : "not "), "ok 3\n"; - print +($getcwd eq $start ? "" : "not "), "ok 4\n"; - print +($fastcwd eq $start ? "" : "not "), "ok 5\n"; - print +($fastgetcwd eq $start ? "" : "not "), "ok 6\n"; - } -} else { - for (3..6) { - print "ok $_ # Skip: no pwd command found\n"; - } -} - -mkdir "pteerslt", 0777; -mkdir "pteerslt/path", 0777; -mkdir "pteerslt/path/to", 0777; -mkdir "pteerslt/path/to/a", 0777; -mkdir "pteerslt/path/to/a/dir", 0777; -Cwd::chdir "pteerslt/path/to/a/dir"; -my $cwd = cwd; -my $getcwd = getcwd; -my $fastcwd = fastcwd; -my $fastgetcwd = fastgetcwd; -my $want = "t/pteerslt/path/to/a/dir"; -print "# cwd = '$cwd'\n"; -print "# getcwd = '$getcwd'\n"; -print "# fastcwd = '$fastcwd'\n"; -print "# fastgetcwd = '$fastgetcwd'\n"; -# This checked out OK on ODS-2 and ODS-5: -$want = "T\.PTEERSLT\.PATH\.TO\.A\.DIR\]" if $^O eq 'VMS'; -print +($cwd =~ m|$want$| ? "" : "not "), "ok 7\n"; -print +($getcwd =~ m|$want$| ? "" : "not "), "ok 8\n"; -print +($fastcwd =~ m|$want$| ? "" : "not "), "ok 9\n"; -print +($fastgetcwd =~ m|$want$| ? "" : "not "), "ok 10\n"; - -# Cwd::chdir should also update $ENV{PWD} -print "#$ENV{PWD}\n"; -print +($ENV{PWD} =~ m|$want$| ? "" : "not "), "ok 11\n"; -Cwd::chdir ".."; rmdir "dir"; -print "#$ENV{PWD}\n"; -Cwd::chdir ".."; rmdir "a"; -print "#$ENV{PWD}\n"; -Cwd::chdir ".."; rmdir "to"; -print "#$ENV{PWD}\n"; -Cwd::chdir ".."; rmdir "path"; -print "#$ENV{PWD}\n"; -Cwd::chdir ".."; rmdir "pteerslt"; -print "#$ENV{PWD}\n"; -if ($^O eq 'VMS') { - # This checked out OK on ODS-2 and ODS-5: - print +($ENV{PWD} =~ m|\bT\]$| ? "" : "not "), "ok 12\n"; -} -else { - print +($ENV{PWD} =~ m|\bt$| ? "" : "not "), "ok 12\n"; -} - -if ($Config{d_symlink}) { - mkdir "pteerslt", 0777; - mkdir "pteerslt/path", 0777; - mkdir "pteerslt/path/to", 0777; - mkdir "pteerslt/path/to/a", 0777; - mkdir "pteerslt/path/to/a/dir", 0777; - symlink "pteerslt/path/to/a/dir" => "linktest"; - - my $abs_path = Cwd::abs_path("linktest"); - my $fast_abs_path = Cwd::fast_abs_path("linktest"); - my $want = "t/pteerslt/path/to/a/dir"; - - print "# abs_path $abs_path\n"; - print "# fast_abs_path $fast_abs_path\n"; - print "# want $want\n"; - print +($abs_path =~ m|$want$| ? "" : "not "), "ok 13\n"; - print +($fast_abs_path =~ m|$want$| ? "" : "not "), "ok 14\n"; - - rmdir "pteerslt/path/to/a/dir"; - rmdir "pteerslt/path/to/a"; - rmdir "pteerslt/path/to"; - rmdir "pteerslt/path"; - rmdir "pteerslt"; - unlink "linktest"; -} else { - print "ok 13 # skipped\n"; - print "ok 14 # skipped\n"; -} diff --git a/t/lib/db-btree.t b/t/lib/db-btree.t deleted file mode 100755 index 4b4a7967ee..0000000000 --- a/t/lib/db-btree.t +++ /dev/null @@ -1,1296 +0,0 @@ -#!./perl -w - -BEGIN { - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bDB_File\b/) { - print "1..0 # Skip: DB_File was not built\n"; - exit 0; - } -} - -use warnings; -use strict; -use DB_File; -use Fcntl; - -print "1..157\n"; - -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - -sub lexical -{ - my(@a) = unpack ("C*", $a) ; - my(@b) = unpack ("C*", $b) ; - - my $len = (@a > @b ? @b : @a) ; - my $i = 0 ; - - foreach $i ( 0 .. $len -1) { - return $a[$i] - $b[$i] if $a[$i] != $b[$i] ; - } - - return @a - @b ; -} - -{ - package Redirect ; - use Symbol ; - - sub new - { - my $class = shift ; - my $filename = shift ; - my $fh = gensym ; - open ($fh, ">$filename") || die "Cannot open $filename: $!" ; - my $real_stdout = select($fh) ; - return bless [$fh, $real_stdout ] ; - - } - sub DESTROY - { - my $self = shift ; - close $self->[0] ; - select($self->[1]) ; - } -} - -sub docat -{ - my $file = shift; - #local $/ = undef unless wantarray ; - open(CAT,$file) || die "Cannot open $file: $!"; - my @result = <CAT>; - close(CAT); - wantarray ? @result : join("", @result) ; -} - -sub docat_del -{ - my $file = shift; - #local $/ = undef unless wantarray ; - open(CAT,$file) || die "Cannot open $file: $!"; - my @result = <CAT>; - close(CAT); - unlink $file ; - wantarray ? @result : join("", @result) ; -} - - -my $db185mode = ($DB_File::db_version == 1 && ! $DB_File::db_185_compat) ; -my $null_keys_allowed = ($DB_File::db_ver < 2.004010 - || $DB_File::db_ver >= 3.1 ); - -my $Dfile = "dbbtree.tmp"; -unlink $Dfile; - -umask(0); - -# Check the interface to BTREEINFO - -my $dbh = new DB_File::BTREEINFO ; -ok(1, ! defined $dbh->{flags}) ; -ok(2, ! defined $dbh->{cachesize}) ; -ok(3, ! defined $dbh->{psize}) ; -ok(4, ! defined $dbh->{lorder}) ; -ok(5, ! defined $dbh->{minkeypage}) ; -ok(6, ! defined $dbh->{maxkeypage}) ; -ok(7, ! defined $dbh->{compare}) ; -ok(8, ! defined $dbh->{prefix}) ; - -$dbh->{flags} = 3000 ; -ok(9, $dbh->{flags} == 3000) ; - -$dbh->{cachesize} = 9000 ; -ok(10, $dbh->{cachesize} == 9000); - -$dbh->{psize} = 400 ; -ok(11, $dbh->{psize} == 400) ; - -$dbh->{lorder} = 65 ; -ok(12, $dbh->{lorder} == 65) ; - -$dbh->{minkeypage} = 123 ; -ok(13, $dbh->{minkeypage} == 123) ; - -$dbh->{maxkeypage} = 1234 ; -ok(14, $dbh->{maxkeypage} == 1234 ); - -$dbh->{compare} = 1234 ; -ok(15, $dbh->{compare} == 1234) ; - -$dbh->{prefix} = 1234 ; -ok(16, $dbh->{prefix} == 1234 ); - -# Check that an invalid entry is caught both for store & fetch -eval '$dbh->{fred} = 1234' ; -ok(17, $@ =~ /^DB_File::BTREEINFO::STORE - Unknown element 'fred' at/ ) ; -eval 'my $q = $dbh->{fred}' ; -ok(18, $@ =~ /^DB_File::BTREEINFO::FETCH - Unknown element 'fred' at/ ) ; - -# Now check the interface to BTREE - -my ($X, %h) ; -ok(19, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ; - -my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); -ok(20, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32' || $^O eq 'NetWare'); - -my ($key, $value, $i); -while (($key,$value) = each(%h)) { - $i++; -} -ok(21, !$i ) ; - -$h{'goner1'} = 'snork'; - -$h{'abc'} = 'ABC'; -ok(22, $h{'abc'} eq 'ABC' ); -ok(23, ! defined $h{'jimmy'} ) ; -ok(24, ! exists $h{'jimmy'} ) ; -ok(25, defined $h{'abc'} ) ; - -$h{'def'} = 'DEF'; -$h{'jkl','mno'} = "JKL\034MNO"; -$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); -$h{'a'} = 'A'; - -#$h{'b'} = 'B'; -$X->STORE('b', 'B') ; - -$h{'c'} = 'C'; - -#$h{'d'} = 'D'; -$X->put('d', 'D') ; - -$h{'e'} = 'E'; -$h{'f'} = 'F'; -$h{'g'} = 'X'; -$h{'h'} = 'H'; -$h{'i'} = 'I'; - -$h{'goner2'} = 'snork'; -delete $h{'goner2'}; - - -# IMPORTANT - $X must be undefined before the untie otherwise the -# underlying DB close routine will not get called. -undef $X ; -untie(%h); - -# tie to the same file again -ok(26, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE)) ; - -# Modify an entry from the previous tie -$h{'g'} = 'G'; - -$h{'j'} = 'J'; -$h{'k'} = 'K'; -$h{'l'} = 'L'; -$h{'m'} = 'M'; -$h{'n'} = 'N'; -$h{'o'} = 'O'; -$h{'p'} = 'P'; -$h{'q'} = 'Q'; -$h{'r'} = 'R'; -$h{'s'} = 'S'; -$h{'t'} = 'T'; -$h{'u'} = 'U'; -$h{'v'} = 'V'; -$h{'w'} = 'W'; -$h{'x'} = 'X'; -$h{'y'} = 'Y'; -$h{'z'} = 'Z'; - -$h{'goner3'} = 'snork'; - -delete $h{'goner1'}; -$X->DELETE('goner3'); - -my @keys = keys(%h); -my @values = values(%h); - -ok(27, $#keys == 29 && $#values == 29) ; - -$i = 0 ; -while (($key,$value) = each(%h)) { - if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { - $key =~ y/a-z/A-Z/; - $i++ if $key eq $value; - } -} - -ok(28, $i == 30) ; - -@keys = ('blurfl', keys(%h), 'dyick'); -ok(29, $#keys == 31) ; - -#Check that the keys can be retrieved in order -my @b = keys %h ; -my @c = sort lexical @b ; -ok(30, ArrayCompare(\@b, \@c)) ; - -$h{'foo'} = ''; -ok(31, $h{'foo'} eq '' ) ; - -# Berkeley DB from version 2.4.10 to 3.0 does not allow null keys. -# This feature was reenabled in version 3.1 of Berkeley DB. -my $result = 0 ; -if ($null_keys_allowed) { - $h{''} = 'bar'; - $result = ( $h{''} eq 'bar' ); -} -else - { $result = 1 } -ok(32, $result) ; - -# check cache overflow and numeric keys and contents -my $ok = 1; -for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } -for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } -ok(33, $ok); - -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); -ok(34, $size > 0 ); - -@h{0..200} = 200..400; -my @foo = @h{0..200}; -ok(35, join(':',200..400) eq join(':',@foo) ); - -# Now check all the non-tie specific stuff - - -# Check R_NOOVERWRITE flag will make put fail when attempting to overwrite -# an existing record. - -my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; -ok(36, $status == 1 ); - -# check that the value of the key 'x' has not been changed by the -# previous test -ok(37, $h{'x'} eq 'X' ); - -# standard put -$status = $X->put('key', 'value') ; -ok(38, $status == 0 ); - -#check that previous put can be retrieved -$value = 0 ; -$status = $X->get('key', $value) ; -ok(39, $status == 0 ); -ok(40, $value eq 'value' ); - -# Attempting to delete an existing key should work - -$status = $X->del('q') ; -ok(41, $status == 0 ); -if ($null_keys_allowed) { - $status = $X->del('') ; -} else { - $status = 0 ; -} -ok(42, $status == 0 ); - -# Make sure that the key deleted, cannot be retrieved -ok(43, ! defined $h{'q'}) ; -ok(44, ! defined $h{''}) ; - -undef $X ; -untie %h ; - -ok(45, $X = tie(%h, 'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE )); - -# Attempting to delete a non-existant key should fail - -$status = $X->del('joe') ; -ok(46, $status == 1 ); - -# Check the get interface - -# First a non-existing key -$status = $X->get('aaaa', $value) ; -ok(47, $status == 1 ); - -# Next an existing key -$status = $X->get('a', $value) ; -ok(48, $status == 0 ); -ok(49, $value eq 'A' ); - -# seq -# ### - -# use seq to find an approximate match -$key = 'ke' ; -$value = '' ; -$status = $X->seq($key, $value, R_CURSOR) ; -ok(50, $status == 0 ); -ok(51, $key eq 'key' ); -ok(52, $value eq 'value' ); - -# seq when the key does not match -$key = 'zzz' ; -$value = '' ; -$status = $X->seq($key, $value, R_CURSOR) ; -ok(53, $status == 1 ); - - -# use seq to set the cursor, then delete the record @ the cursor. - -$key = 'x' ; -$value = '' ; -$status = $X->seq($key, $value, R_CURSOR) ; -ok(54, $status == 0 ); -ok(55, $key eq 'x' ); -ok(56, $value eq 'X' ); -$status = $X->del(0, R_CURSOR) ; -ok(57, $status == 0 ); -$status = $X->get('x', $value) ; -ok(58, $status == 1 ); - -# ditto, but use put to replace the key/value pair. -$key = 'y' ; -$value = '' ; -$status = $X->seq($key, $value, R_CURSOR) ; -ok(59, $status == 0 ); -ok(60, $key eq 'y' ); -ok(61, $value eq 'Y' ); - -$key = "replace key" ; -$value = "replace value" ; -$status = $X->put($key, $value, R_CURSOR) ; -ok(62, $status == 0 ); -ok(63, $key eq 'replace key' ); -ok(64, $value eq 'replace value' ); -$status = $X->get('y', $value) ; -ok(65, 1) ; # hard-wire to always pass. the previous test ($status == 1) - # only worked because of a bug in 1.85/6 - -# use seq to walk forwards through a file - -$status = $X->seq($key, $value, R_FIRST) ; -ok(66, $status == 0 ); -my $previous = $key ; - -$ok = 1 ; -while (($status = $X->seq($key, $value, R_NEXT)) == 0) -{ - ($ok = 0), last if ($previous cmp $key) == 1 ; -} - -ok(67, $status == 1 ); -ok(68, $ok == 1 ); - -# use seq to walk backwards through a file -$status = $X->seq($key, $value, R_LAST) ; -ok(69, $status == 0 ); -$previous = $key ; - -$ok = 1 ; -while (($status = $X->seq($key, $value, R_PREV)) == 0) -{ - ($ok = 0), last if ($previous cmp $key) == -1 ; - #print "key = [$key] value = [$value]\n" ; -} - -ok(70, $status == 1 ); -ok(71, $ok == 1 ); - - -# check seq FIRST/LAST - -# sync -# #### - -$status = $X->sync ; -ok(72, $status == 0 ); - - -# fd -# ## - -$status = $X->fd ; -ok(73, $status != 0 ); - - -undef $X ; -untie %h ; - -unlink $Dfile; - -# Now try an in memory file -my $Y; -ok(74, $Y = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_BTREE )); - -# fd with an in memory file should return failure -$status = $Y->fd ; -ok(75, $status == -1 ); - - -undef $Y ; -untie %h ; - -# Duplicate keys -my $bt = new DB_File::BTREEINFO ; -$bt->{flags} = R_DUP ; -my ($YY, %hh); -ok(76, $YY = tie(%hh, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $bt )) ; - -$hh{'Wall'} = 'Larry' ; -$hh{'Wall'} = 'Stone' ; # Note the duplicate key -$hh{'Wall'} = 'Brick' ; # Note the duplicate key -$hh{'Wall'} = 'Brick' ; # Note the duplicate key and value -$hh{'Smith'} = 'John' ; -$hh{'mouse'} = 'mickey' ; - -# first work in scalar context -ok(77, scalar $YY->get_dup('Unknown') == 0 ); -ok(78, scalar $YY->get_dup('Smith') == 1 ); -ok(79, scalar $YY->get_dup('Wall') == 4 ); - -# now in list context -my @unknown = $YY->get_dup('Unknown') ; -ok(80, "@unknown" eq "" ); - -my @smith = $YY->get_dup('Smith') ; -ok(81, "@smith" eq "John" ); - -{ -my @wall = $YY->get_dup('Wall') ; -my %wall ; -@wall{@wall} = @wall ; -ok(82, (@wall == 4 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) ); -} - -# hash -my %unknown = $YY->get_dup('Unknown', 1) ; -ok(83, keys %unknown == 0 ); - -my %smith = $YY->get_dup('Smith', 1) ; -ok(84, keys %smith == 1 && $smith{'John'}) ; - -my %wall = $YY->get_dup('Wall', 1) ; -ok(85, keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1 - && $wall{'Brick'} == 2); - -undef $YY ; -untie %hh ; -unlink $Dfile; - - -# test multiple callbacks -my $Dfile1 = "btree1" ; -my $Dfile2 = "btree2" ; -my $Dfile3 = "btree3" ; - -my $dbh1 = new DB_File::BTREEINFO ; -$dbh1->{compare} = sub { - no warnings 'numeric' ; - $_[0] <=> $_[1] } ; - -my $dbh2 = new DB_File::BTREEINFO ; -$dbh2->{compare} = sub { $_[0] cmp $_[1] } ; - -my $dbh3 = new DB_File::BTREEINFO ; -$dbh3->{compare} = sub { length $_[0] <=> length $_[1] } ; - - -my (%g, %k); -tie(%h, 'DB_File',$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) ; -tie(%g, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ; -tie(%k, 'DB_File',$Dfile3, O_RDWR|O_CREAT, 0640, $dbh3 ) ; - -my @Keys = qw( 0123 12 -1234 9 987654321 def ) ; -my (@srt_1, @srt_2, @srt_3); -{ - no warnings 'numeric' ; - @srt_1 = sort { $a <=> $b } @Keys ; -} -@srt_2 = sort { $a cmp $b } @Keys ; -@srt_3 = sort { length $a <=> length $b } @Keys ; - -foreach (@Keys) { - $h{$_} = 1 ; - $g{$_} = 1 ; - $k{$_} = 1 ; -} - -sub ArrayCompare -{ - my($a, $b) = @_ ; - - return 0 if @$a != @$b ; - - foreach (1 .. length @$a) - { - return 0 unless $$a[$_] eq $$b[$_] ; - } - - 1 ; -} - -ok(86, ArrayCompare (\@srt_1, [keys %h]) ); -ok(87, ArrayCompare (\@srt_2, [keys %g]) ); -ok(88, ArrayCompare (\@srt_3, [keys %k]) ); - -untie %h ; -untie %g ; -untie %k ; -unlink $Dfile1, $Dfile2, $Dfile3 ; - -# clear -# ##### - -ok(89, tie(%h, 'DB_File', $Dfile1, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); -foreach (1 .. 10) - { $h{$_} = $_ * 100 } - -# check that there are 10 elements in the hash -$i = 0 ; -while (($key,$value) = each(%h)) { - $i++; -} -ok(90, $i == 10); - -# now clear the hash -%h = () ; - -# check it is empty -$i = 0 ; -while (($key,$value) = each(%h)) { - $i++; -} -ok(91, $i == 0); - -untie %h ; -unlink $Dfile1 ; - -{ - # check that attempting to tie an array to a DB_BTREE will fail - - my $filename = "xyz" ; - my @x ; - eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE ; } ; - ok(92, $@ =~ /^DB_File can only tie an associative array to a DB_BTREE database/) ; - unlink $filename ; -} - -{ - # sub-class test - - package Another ; - - use warnings ; - use strict ; - - open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; - print FILE <<'EOM' ; - - package SubDB ; - - use warnings ; - use strict ; - use vars qw( @ISA @EXPORT) ; - - require Exporter ; - use DB_File; - @ISA=qw(DB_File); - @EXPORT = @DB_File::EXPORT ; - - sub STORE { - my $self = shift ; - my $key = shift ; - my $value = shift ; - $self->SUPER::STORE($key, $value * 2) ; - } - - sub FETCH { - my $self = shift ; - my $key = shift ; - $self->SUPER::FETCH($key) - 1 ; - } - - sub put { - my $self = shift ; - my $key = shift ; - my $value = shift ; - $self->SUPER::put($key, $value * 3) ; - } - - sub get { - my $self = shift ; - $self->SUPER::get($_[0], $_[1]) ; - $_[1] -= 2 ; - } - - sub A_new_method - { - my $self = shift ; - my $key = shift ; - my $value = $self->FETCH($key) ; - return "[[$value]]" ; - } - - 1 ; -EOM - - close FILE ; - - BEGIN { push @INC, '.'; } - eval 'use SubDB ; '; - main::ok(93, $@ eq "") ; - my %h ; - my $X ; - eval ' - $X = tie(%h, "SubDB","dbbtree.tmp", O_RDWR|O_CREAT, 0640, $DB_BTREE ); - ' ; - - main::ok(94, $@ eq "") ; - - my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; - main::ok(95, $@ eq "") ; - main::ok(96, $ret == 5) ; - - my $value = 0; - $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ; - main::ok(97, $@ eq "") ; - main::ok(98, $ret == 10) ; - - $ret = eval ' R_NEXT eq main::R_NEXT ' ; - main::ok(99, $@ eq "" ) ; - main::ok(100, $ret == 1) ; - - $ret = eval '$X->A_new_method("joe") ' ; - main::ok(101, $@ eq "") ; - main::ok(102, $ret eq "[[11]]") ; - - undef $X; - untie(%h); - unlink "SubDB.pm", "dbbtree.tmp" ; - -} - -{ - # DBM Filter tests - use warnings ; - use strict ; - my (%h, $db) ; - my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - unlink $Dfile; - - sub checkOutput - { - my($fk, $sk, $fv, $sv) = @_ ; - return - $fetch_key eq $fk && $store_key eq $sk && - $fetch_value eq $fv && $store_value eq $sv && - $_ eq 'original' ; - } - - ok(103, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); - - $db->filter_fetch_key (sub { $fetch_key = $_ }) ; - $db->filter_store_key (sub { $store_key = $_ }) ; - $db->filter_fetch_value (sub { $fetch_value = $_}) ; - $db->filter_store_value (sub { $store_value = $_ }) ; - - $_ = "original" ; - - $h{"fred"} = "joe" ; - # fk sk fv sv - ok(104, checkOutput( "", "fred", "", "joe")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(105, $h{"fred"} eq "joe"); - # fk sk fv sv - ok(106, checkOutput( "", "fred", "joe", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(107, $db->FIRSTKEY() eq "fred") ; - # fk sk fv sv - ok(108, checkOutput( "fred", "", "", "")) ; - - # replace the filters, but remember the previous set - my ($old_fk) = $db->filter_fetch_key - (sub { $_ = uc $_ ; $fetch_key = $_ }) ; - my ($old_sk) = $db->filter_store_key - (sub { $_ = lc $_ ; $store_key = $_ }) ; - my ($old_fv) = $db->filter_fetch_value - (sub { $_ = "[$_]"; $fetch_value = $_ }) ; - my ($old_sv) = $db->filter_store_value - (sub { s/o/x/g; $store_value = $_ }) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - $h{"Fred"} = "Joe" ; - # fk sk fv sv - ok(109, checkOutput( "", "fred", "", "Jxe")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(110, $h{"Fred"} eq "[Jxe]"); - # fk sk fv sv - ok(111, checkOutput( "", "fred", "[Jxe]", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(112, $db->FIRSTKEY() eq "FRED") ; - # fk sk fv sv - ok(113, checkOutput( "FRED", "", "", "")) ; - - # put the original filters back - $db->filter_fetch_key ($old_fk); - $db->filter_store_key ($old_sk); - $db->filter_fetch_value ($old_fv); - $db->filter_store_value ($old_sv); - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - $h{"fred"} = "joe" ; - ok(114, checkOutput( "", "fred", "", "joe")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(115, $h{"fred"} eq "joe"); - ok(116, checkOutput( "", "fred", "joe", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(117, $db->FIRSTKEY() eq "fred") ; - ok(118, checkOutput( "fred", "", "", "")) ; - - # delete the filters - $db->filter_fetch_key (undef); - $db->filter_store_key (undef); - $db->filter_fetch_value (undef); - $db->filter_store_value (undef); - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - $h{"fred"} = "joe" ; - ok(119, checkOutput( "", "", "", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(120, $h{"fred"} eq "joe"); - ok(121, checkOutput( "", "", "", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(122, $db->FIRSTKEY() eq "fred") ; - ok(123, checkOutput( "", "", "", "")) ; - - undef $db ; - untie %h; - unlink $Dfile; -} - -{ - # DBM Filter with a closure - - use warnings ; - use strict ; - my (%h, $db) ; - - unlink $Dfile; - ok(124, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); - - my %result = () ; - - sub Closure - { - my ($name) = @_ ; - my $count = 0 ; - my @kept = () ; - - return sub { ++$count ; - push @kept, $_ ; - $result{$name} = "$name - $count: [@kept]" ; - } - } - - $db->filter_store_key(Closure("store key")) ; - $db->filter_store_value(Closure("store value")) ; - $db->filter_fetch_key(Closure("fetch key")) ; - $db->filter_fetch_value(Closure("fetch value")) ; - - $_ = "original" ; - - $h{"fred"} = "joe" ; - ok(125, $result{"store key"} eq "store key - 1: [fred]"); - ok(126, $result{"store value"} eq "store value - 1: [joe]"); - ok(127, ! defined $result{"fetch key"} ); - ok(128, ! defined $result{"fetch value"} ); - ok(129, $_ eq "original") ; - - ok(130, $db->FIRSTKEY() eq "fred") ; - ok(131, $result{"store key"} eq "store key - 1: [fred]"); - ok(132, $result{"store value"} eq "store value - 1: [joe]"); - ok(133, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(134, ! defined $result{"fetch value"} ); - ok(135, $_ eq "original") ; - - $h{"jim"} = "john" ; - ok(136, $result{"store key"} eq "store key - 2: [fred jim]"); - ok(137, $result{"store value"} eq "store value - 2: [joe john]"); - ok(138, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(139, ! defined $result{"fetch value"} ); - ok(140, $_ eq "original") ; - - ok(141, $h{"fred"} eq "joe"); - ok(142, $result{"store key"} eq "store key - 3: [fred jim fred]"); - ok(143, $result{"store value"} eq "store value - 2: [joe john]"); - ok(144, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(145, $result{"fetch value"} eq "fetch value - 1: [joe]"); - ok(146, $_ eq "original") ; - - undef $db ; - untie %h; - unlink $Dfile; -} - -{ - # DBM Filter recursion detection - use warnings ; - use strict ; - my (%h, $db) ; - unlink $Dfile; - - ok(147, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); - - $db->filter_store_key (sub { $_ = $h{$_} }) ; - - eval '$h{1} = 1234' ; - ok(148, $@ =~ /^recursion detected in filter_store_key at/ ); - - undef $db ; - untie %h; - unlink $Dfile; -} - - -{ - # Examples from the POD - - - my $file = "xyzt" ; - { - my $redirect = new Redirect $file ; - - # BTREE example 1 - ### - - use warnings FATAL => qw(all) ; - use strict ; - use DB_File ; - - my %h ; - - sub Compare - { - my ($key1, $key2) = @_ ; - "\L$key1" cmp "\L$key2" ; - } - - # specify the Perl sub that will do the comparison - $DB_BTREE->{'compare'} = \&Compare ; - - unlink "tree" ; - tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0640, $DB_BTREE - or die "Cannot open file 'tree': $!\n" ; - - # Add a key/value pair to the file - $h{'Wall'} = 'Larry' ; - $h{'Smith'} = 'John' ; - $h{'mouse'} = 'mickey' ; - $h{'duck'} = 'donald' ; - - # Delete - delete $h{"duck"} ; - - # Cycle through the keys printing them in order. - # Note it is not necessary to sort the keys as - # the btree will have kept them in order automatically. - foreach (keys %h) - { print "$_\n" } - - untie %h ; - - unlink "tree" ; - } - - delete $DB_BTREE->{'compare'} ; - - ok(149, docat_del($file) eq <<'EOM') ; -mouse -Smith -Wall -EOM - - { - my $redirect = new Redirect $file ; - - # BTREE example 2 - ### - - use warnings FATAL => qw(all) ; - use strict ; - use DB_File ; - - use vars qw($filename %h ) ; - - $filename = "tree" ; - unlink $filename ; - - # Enable duplicate records - $DB_BTREE->{'flags'} = R_DUP ; - - tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE - or die "Cannot open $filename: $!\n"; - - # Add some key/value pairs to the file - $h{'Wall'} = 'Larry' ; - $h{'Wall'} = 'Brick' ; # Note the duplicate key - $h{'Wall'} = 'Brick' ; # Note the duplicate key and value - $h{'Smith'} = 'John' ; - $h{'mouse'} = 'mickey' ; - - # iterate through the associative array - # and print each key/value pair. - foreach (keys %h) - { print "$_ -> $h{$_}\n" } - - untie %h ; - - unlink $filename ; - } - - ok(150, docat_del($file) eq ($db185mode ? <<'EOM' : <<'EOM') ) ; -Smith -> John -Wall -> Brick -Wall -> Brick -Wall -> Brick -mouse -> mickey -EOM -Smith -> John -Wall -> Larry -Wall -> Larry -Wall -> Larry -mouse -> mickey -EOM - - { - my $redirect = new Redirect $file ; - - # BTREE example 3 - ### - - use warnings FATAL => qw(all) ; - use strict ; - use DB_File ; - - use vars qw($filename $x %h $status $key $value) ; - - $filename = "tree" ; - unlink $filename ; - - # Enable duplicate records - $DB_BTREE->{'flags'} = R_DUP ; - - $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE - or die "Cannot open $filename: $!\n"; - - # Add some key/value pairs to the file - $h{'Wall'} = 'Larry' ; - $h{'Wall'} = 'Brick' ; # Note the duplicate key - $h{'Wall'} = 'Brick' ; # Note the duplicate key and value - $h{'Smith'} = 'John' ; - $h{'mouse'} = 'mickey' ; - - # iterate through the btree using seq - # and print each key/value pair. - $key = $value = 0 ; - for ($status = $x->seq($key, $value, R_FIRST) ; - $status == 0 ; - $status = $x->seq($key, $value, R_NEXT) ) - { print "$key -> $value\n" } - - - undef $x ; - untie %h ; - } - - ok(151, docat_del($file) eq ($db185mode == 1 ? <<'EOM' : <<'EOM') ) ; -Smith -> John -Wall -> Brick -Wall -> Brick -Wall -> Larry -mouse -> mickey -EOM -Smith -> John -Wall -> Larry -Wall -> Brick -Wall -> Brick -mouse -> mickey -EOM - - - { - my $redirect = new Redirect $file ; - - # BTREE example 4 - ### - - use warnings FATAL => qw(all) ; - use strict ; - use DB_File ; - - use vars qw($filename $x %h ) ; - - $filename = "tree" ; - - # Enable duplicate records - $DB_BTREE->{'flags'} = R_DUP ; - - $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE - or die "Cannot open $filename: $!\n"; - - my $cnt = $x->get_dup("Wall") ; - print "Wall occurred $cnt times\n" ; - - my %hash = $x->get_dup("Wall", 1) ; - print "Larry is there\n" if $hash{'Larry'} ; - print "There are $hash{'Brick'} Brick Walls\n" ; - - my @list = sort $x->get_dup("Wall") ; - print "Wall => [@list]\n" ; - - @list = $x->get_dup("Smith") ; - print "Smith => [@list]\n" ; - - @list = $x->get_dup("Dog") ; - print "Dog => [@list]\n" ; - - undef $x ; - untie %h ; - } - - ok(152, docat_del($file) eq <<'EOM') ; -Wall occurred 3 times -Larry is there -There are 2 Brick Walls -Wall => [Brick Brick Larry] -Smith => [John] -Dog => [] -EOM - - { - my $redirect = new Redirect $file ; - - # BTREE example 5 - ### - - use warnings FATAL => qw(all) ; - use strict ; - use DB_File ; - - use vars qw($filename $x %h $found) ; - - my $filename = "tree" ; - - # Enable duplicate records - $DB_BTREE->{'flags'} = R_DUP ; - - $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE - or die "Cannot open $filename: $!\n"; - - $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; - print "Larry Wall is $found there\n" ; - - $found = ( $x->find_dup("Wall", "Harry") == 0 ? "" : "not") ; - print "Harry Wall is $found there\n" ; - - undef $x ; - untie %h ; - } - - ok(153, docat_del($file) eq <<'EOM') ; -Larry Wall is there -Harry Wall is not there -EOM - - { - my $redirect = new Redirect $file ; - - # BTREE example 6 - ### - - use warnings FATAL => qw(all) ; - use strict ; - use DB_File ; - - use vars qw($filename $x %h $found) ; - - my $filename = "tree" ; - - # Enable duplicate records - $DB_BTREE->{'flags'} = R_DUP ; - - $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE - or die "Cannot open $filename: $!\n"; - - $x->del_dup("Wall", "Larry") ; - - $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; - print "Larry Wall is $found there\n" ; - - undef $x ; - untie %h ; - - unlink $filename ; - } - - ok(154, docat_del($file) eq <<'EOM') ; -Larry Wall is not there -EOM - - { - my $redirect = new Redirect $file ; - - # BTREE example 7 - ### - - use warnings FATAL => qw(all) ; - use strict ; - use DB_File ; - use Fcntl ; - - use vars qw($filename $x %h $st $key $value) ; - - sub match - { - my $key = shift ; - my $value = 0; - my $orig_key = $key ; - $x->seq($key, $value, R_CURSOR) ; - print "$orig_key\t-> $key\t-> $value\n" ; - } - - $filename = "tree" ; - unlink $filename ; - - $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE - or die "Cannot open $filename: $!\n"; - - # Add some key/value pairs to the file - $h{'mouse'} = 'mickey' ; - $h{'Wall'} = 'Larry' ; - $h{'Walls'} = 'Brick' ; - $h{'Smith'} = 'John' ; - - - $key = $value = 0 ; - print "IN ORDER\n" ; - for ($st = $x->seq($key, $value, R_FIRST) ; - $st == 0 ; - $st = $x->seq($key, $value, R_NEXT) ) - - { print "$key -> $value\n" } - - print "\nPARTIAL MATCH\n" ; - - match "Wa" ; - match "A" ; - match "a" ; - - undef $x ; - untie %h ; - - unlink $filename ; - - } - - ok(155, docat_del($file) eq <<'EOM') ; -IN ORDER -Smith -> John -Wall -> Larry -Walls -> Brick -mouse -> mickey - -PARTIAL MATCH -Wa -> Wall -> Larry -A -> Smith -> John -a -> mouse -> mickey -EOM - -} - -#{ -# # R_SETCURSOR -# use strict ; -# my (%h, $db) ; -# unlink $Dfile; -# -# ok(156, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); -# -# $h{abc} = 33 ; -# my $k = "newest" ; -# my $v = 44 ; -# my $status = $db->put($k, $v, R_SETCURSOR) ; -# print "status = [$status]\n" ; -# ok(157, $status == 0) ; -# $status = $db->del($k, R_CURSOR) ; -# print "status = [$status]\n" ; -# ok(158, $status == 0) ; -# $k = "newest" ; -# ok(159, $db->get($k, $v, R_CURSOR)) ; -# -# ok(160, keys %h == 1) ; -# -# undef $db ; -# untie %h; -# unlink $Dfile; -#} - -{ - # Bug ID 20001013.009 - # - # test that $hash{KEY} = undef doesn't produce the warning - # Use of uninitialized value in null operation - use warnings ; - use strict ; - use DB_File ; - - unlink $Dfile; - my %h ; - my $a = ""; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - - tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE - or die "Can't open file: $!\n" ; - $h{ABC} = undef; - ok(156, $a eq "") ; - untie %h ; - unlink $Dfile; -} - -{ - # test that %hash = () doesn't produce the warning - # Argument "" isn't numeric in entersub - use warnings ; - use strict ; - use DB_File ; - - unlink $Dfile; - my %h ; - my $a = ""; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - - tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE - or die "Can't open file: $!\n" ; - %h = (); ; - ok(157, $a eq "") ; - untie %h ; - unlink $Dfile; -} - -exit ; diff --git a/t/lib/db-hash.t b/t/lib/db-hash.t deleted file mode 100755 index 6f2ef37b61..0000000000 --- a/t/lib/db-hash.t +++ /dev/null @@ -1,743 +0,0 @@ -#!./perl -w - -BEGIN { - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bDB_File\b/) { - print "1..0 # Skip: DB_File was not built\n"; - exit 0; - } -} - -use strict; -use warnings; -use DB_File; -use Fcntl; - -print "1..111\n"; - -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - -{ - package Redirect ; - use Symbol ; - - sub new - { - my $class = shift ; - my $filename = shift ; - my $fh = gensym ; - open ($fh, ">$filename") || die "Cannot open $filename: $!" ; - my $real_stdout = select($fh) ; - return bless [$fh, $real_stdout ] ; - - } - sub DESTROY - { - my $self = shift ; - close $self->[0] ; - select($self->[1]) ; - } -} - -sub docat_del -{ - my $file = shift; - local $/ = undef; - open(CAT,$file) || die "Cannot open $file: $!"; - my $result = <CAT>; - close(CAT); - unlink $file ; - return $result; -} - -my $Dfile = "dbhash.tmp"; -my $null_keys_allowed = ($DB_File::db_ver < 2.004010 - || $DB_File::db_ver >= 3.1 ); - -unlink $Dfile; - -umask(0); - -# Check the interface to HASHINFO - -my $dbh = new DB_File::HASHINFO ; - -ok(1, ! defined $dbh->{bsize}) ; -ok(2, ! defined $dbh->{ffactor}) ; -ok(3, ! defined $dbh->{nelem}) ; -ok(4, ! defined $dbh->{cachesize}) ; -ok(5, ! defined $dbh->{hash}) ; -ok(6, ! defined $dbh->{lorder}) ; - -$dbh->{bsize} = 3000 ; -ok(7, $dbh->{bsize} == 3000 ); - -$dbh->{ffactor} = 9000 ; -ok(8, $dbh->{ffactor} == 9000 ); - -$dbh->{nelem} = 400 ; -ok(9, $dbh->{nelem} == 400 ); - -$dbh->{cachesize} = 65 ; -ok(10, $dbh->{cachesize} == 65 ); - -$dbh->{hash} = "abc" ; -ok(11, $dbh->{hash} eq "abc" ); - -$dbh->{lorder} = 1234 ; -ok(12, $dbh->{lorder} == 1234 ); - -# Check that an invalid entry is caught both for store & fetch -eval '$dbh->{fred} = 1234' ; -ok(13, $@ =~ /^DB_File::HASHINFO::STORE - Unknown element 'fred' at/ ); -eval 'my $q = $dbh->{fred}' ; -ok(14, $@ =~ /^DB_File::HASHINFO::FETCH - Unknown element 'fred' at/ ); - - -# Now check the interface to HASH -my ($X, %h); -ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); - -my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); -ok(16, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32' || $^O eq 'NetWare'); - -my ($key, $value, $i); -while (($key,$value) = each(%h)) { - $i++; -} -ok(17, !$i ); - -$h{'goner1'} = 'snork'; - -$h{'abc'} = 'ABC'; -ok(18, $h{'abc'} eq 'ABC' ); -ok(19, !defined $h{'jimmy'} ); -ok(20, !exists $h{'jimmy'} ); -ok(21, exists $h{'abc'} ); - -$h{'def'} = 'DEF'; -$h{'jkl','mno'} = "JKL\034MNO"; -$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); -$h{'a'} = 'A'; - -#$h{'b'} = 'B'; -$X->STORE('b', 'B') ; - -$h{'c'} = 'C'; - -#$h{'d'} = 'D'; -$X->put('d', 'D') ; - -$h{'e'} = 'E'; -$h{'f'} = 'F'; -$h{'g'} = 'X'; -$h{'h'} = 'H'; -$h{'i'} = 'I'; - -$h{'goner2'} = 'snork'; -delete $h{'goner2'}; - - -# IMPORTANT - $X must be undefined before the untie otherwise the -# underlying DB close routine will not get called. -undef $X ; -untie(%h); - - -# tie to the same file again, do not supply a type - should default to HASH -ok(22, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640) ); - -# Modify an entry from the previous tie -$h{'g'} = 'G'; - -$h{'j'} = 'J'; -$h{'k'} = 'K'; -$h{'l'} = 'L'; -$h{'m'} = 'M'; -$h{'n'} = 'N'; -$h{'o'} = 'O'; -$h{'p'} = 'P'; -$h{'q'} = 'Q'; -$h{'r'} = 'R'; -$h{'s'} = 'S'; -$h{'t'} = 'T'; -$h{'u'} = 'U'; -$h{'v'} = 'V'; -$h{'w'} = 'W'; -$h{'x'} = 'X'; -$h{'y'} = 'Y'; -$h{'z'} = 'Z'; - -$h{'goner3'} = 'snork'; - -delete $h{'goner1'}; -$X->DELETE('goner3'); - -my @keys = keys(%h); -my @values = values(%h); - -ok(23, $#keys == 29 && $#values == 29) ; - -$i = 0 ; -while (($key,$value) = each(%h)) { - if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { - $key =~ y/a-z/A-Z/; - $i++ if $key eq $value; - } -} - -ok(24, $i == 30) ; - -@keys = ('blurfl', keys(%h), 'dyick'); -ok(25, $#keys == 31) ; - -$h{'foo'} = ''; -ok(26, $h{'foo'} eq '' ); - -# Berkeley DB from version 2.4.10 to 3.0 does not allow null keys. -# This feature was reenabled in version 3.1 of Berkeley DB. -my $result = 0 ; -if ($null_keys_allowed) { - $h{''} = 'bar'; - $result = ( $h{''} eq 'bar' ); -} -else - { $result = 1 } -ok(27, $result) ; - -# check cache overflow and numeric keys and contents -my $ok = 1; -for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } -for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } -ok(28, $ok ); - -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); -ok(29, $size > 0 ); - -@h{0..200} = 200..400; -my @foo = @h{0..200}; -ok(30, join(':',200..400) eq join(':',@foo) ); - - -# Now check all the non-tie specific stuff - -# Check NOOVERWRITE will make put fail when attempting to overwrite -# an existing record. - -my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ; -ok(31, $status == 1 ); - -# check that the value of the key 'x' has not been changed by the -# previous test -ok(32, $h{'x'} eq 'X' ); - -# standard put -$status = $X->put('key', 'value') ; -ok(33, $status == 0 ); - -#check that previous put can be retrieved -$value = 0 ; -$status = $X->get('key', $value) ; -ok(34, $status == 0 ); -ok(35, $value eq 'value' ); - -# Attempting to delete an existing key should work - -$status = $X->del('q') ; -ok(36, $status == 0 ); - -# Make sure that the key deleted, cannot be retrieved -{ - no warnings 'uninitialized' ; - ok(37, $h{'q'} eq undef ); -} - -# Attempting to delete a non-existant key should fail - -$status = $X->del('joe') ; -ok(38, $status == 1 ); - -# Check the get interface - -# First a non-existing key -$status = $X->get('aaaa', $value) ; -ok(39, $status == 1 ); - -# Next an existing key -$status = $X->get('a', $value) ; -ok(40, $status == 0 ); -ok(41, $value eq 'A' ); - -# seq -# ### - -# ditto, but use put to replace the key/value pair. - -# use seq to walk backwards through a file - check that this reversed is - -# check seq FIRST/LAST - -# sync -# #### - -$status = $X->sync ; -ok(42, $status == 0 ); - - -# fd -# ## - -$status = $X->fd ; -ok(43, $status != 0 ); - -undef $X ; -untie %h ; - -unlink $Dfile; - -# clear -# ##### - -ok(44, tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); -foreach (1 .. 10) - { $h{$_} = $_ * 100 } - -# check that there are 10 elements in the hash -$i = 0 ; -while (($key,$value) = each(%h)) { - $i++; -} -ok(45, $i == 10); - -# now clear the hash -%h = () ; - -# check it is empty -$i = 0 ; -while (($key,$value) = each(%h)) { - $i++; -} -ok(46, $i == 0); - -untie %h ; -unlink $Dfile ; - - -# Now try an in memory file -ok(47, $X = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); - -# fd with an in memory file should return fail -$status = $X->fd ; -ok(48, $status == -1 ); - -undef $X ; -untie %h ; - -{ - # check ability to override the default hashing - my %x ; - my $filename = "xyz" ; - my $hi = new DB_File::HASHINFO ; - $::count = 0 ; - $hi->{hash} = sub { ++$::count ; length $_[0] } ; - ok(49, tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $hi ) ; - $h{"abc"} = 123 ; - ok(50, $h{"abc"} == 123) ; - untie %x ; - unlink $filename ; - ok(51, $::count >0) ; -} - -{ - # check that attempting to tie an array to a DB_HASH will fail - - my $filename = "xyz" ; - my @x ; - eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_HASH ; } ; - ok(52, $@ =~ /^DB_File can only tie an associative array to a DB_HASH database/) ; - unlink $filename ; -} - -{ - # sub-class test - - package Another ; - - use warnings ; - use strict ; - - open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; - print FILE <<'EOM' ; - - package SubDB ; - - use warnings ; - use strict ; - use vars qw( @ISA @EXPORT) ; - - require Exporter ; - use DB_File; - @ISA=qw(DB_File); - @EXPORT = @DB_File::EXPORT ; - - sub STORE { - my $self = shift ; - my $key = shift ; - my $value = shift ; - $self->SUPER::STORE($key, $value * 2) ; - } - - sub FETCH { - my $self = shift ; - my $key = shift ; - $self->SUPER::FETCH($key) - 1 ; - } - - sub put { - my $self = shift ; - my $key = shift ; - my $value = shift ; - $self->SUPER::put($key, $value * 3) ; - } - - sub get { - my $self = shift ; - $self->SUPER::get($_[0], $_[1]) ; - $_[1] -= 2 ; - } - - sub A_new_method - { - my $self = shift ; - my $key = shift ; - my $value = $self->FETCH($key) ; - return "[[$value]]" ; - } - - 1 ; -EOM - - close FILE ; - - BEGIN { push @INC, '.'; } - eval 'use SubDB ; '; - main::ok(53, $@ eq "") ; - my %h ; - my $X ; - eval ' - $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640, $DB_HASH ); - ' ; - - main::ok(54, $@ eq "") ; - - my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; - main::ok(55, $@ eq "") ; - main::ok(56, $ret == 5) ; - - my $value = 0; - $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ; - main::ok(57, $@ eq "") ; - main::ok(58, $ret == 10) ; - - $ret = eval ' R_NEXT eq main::R_NEXT ' ; - main::ok(59, $@ eq "" ) ; - main::ok(60, $ret == 1) ; - - $ret = eval '$X->A_new_method("joe") ' ; - main::ok(61, $@ eq "") ; - main::ok(62, $ret eq "[[11]]") ; - - undef $X; - untie(%h); - unlink "SubDB.pm", "dbhash.tmp" ; - -} - -{ - # DBM Filter tests - use warnings ; - use strict ; - my (%h, $db) ; - my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - unlink $Dfile; - - sub checkOutput - { - my($fk, $sk, $fv, $sv) = @_ ; - return - $fetch_key eq $fk && $store_key eq $sk && - $fetch_value eq $fv && $store_value eq $sv && - $_ eq 'original' ; - } - - ok(63, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); - - $db->filter_fetch_key (sub { $fetch_key = $_ }) ; - $db->filter_store_key (sub { $store_key = $_ }) ; - $db->filter_fetch_value (sub { $fetch_value = $_}) ; - $db->filter_store_value (sub { $store_value = $_ }) ; - - $_ = "original" ; - - $h{"fred"} = "joe" ; - # fk sk fv sv - ok(64, checkOutput( "", "fred", "", "joe")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(65, $h{"fred"} eq "joe"); - # fk sk fv sv - ok(66, checkOutput( "", "fred", "joe", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(67, $db->FIRSTKEY() eq "fred") ; - # fk sk fv sv - ok(68, checkOutput( "fred", "", "", "")) ; - - # replace the filters, but remember the previous set - my ($old_fk) = $db->filter_fetch_key - (sub { $_ = uc $_ ; $fetch_key = $_ }) ; - my ($old_sk) = $db->filter_store_key - (sub { $_ = lc $_ ; $store_key = $_ }) ; - my ($old_fv) = $db->filter_fetch_value - (sub { $_ = "[$_]"; $fetch_value = $_ }) ; - my ($old_sv) = $db->filter_store_value - (sub { s/o/x/g; $store_value = $_ }) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - $h{"Fred"} = "Joe" ; - # fk sk fv sv - ok(69, checkOutput( "", "fred", "", "Jxe")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(70, $h{"Fred"} eq "[Jxe]"); - # fk sk fv sv - ok(71, checkOutput( "", "fred", "[Jxe]", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(72, $db->FIRSTKEY() eq "FRED") ; - # fk sk fv sv - ok(73, checkOutput( "FRED", "", "", "")) ; - - # put the original filters back - $db->filter_fetch_key ($old_fk); - $db->filter_store_key ($old_sk); - $db->filter_fetch_value ($old_fv); - $db->filter_store_value ($old_sv); - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - $h{"fred"} = "joe" ; - ok(74, checkOutput( "", "fred", "", "joe")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(75, $h{"fred"} eq "joe"); - ok(76, checkOutput( "", "fred", "joe", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(77, $db->FIRSTKEY() eq "fred") ; - ok(78, checkOutput( "fred", "", "", "")) ; - - # delete the filters - $db->filter_fetch_key (undef); - $db->filter_store_key (undef); - $db->filter_fetch_value (undef); - $db->filter_store_value (undef); - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - $h{"fred"} = "joe" ; - ok(79, checkOutput( "", "", "", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(80, $h{"fred"} eq "joe"); - ok(81, checkOutput( "", "", "", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(82, $db->FIRSTKEY() eq "fred") ; - ok(83, checkOutput( "", "", "", "")) ; - - undef $db ; - untie %h; - unlink $Dfile; -} - -{ - # DBM Filter with a closure - - use warnings ; - use strict ; - my (%h, $db) ; - - unlink $Dfile; - ok(84, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); - - my %result = () ; - - sub Closure - { - my ($name) = @_ ; - my $count = 0 ; - my @kept = () ; - - return sub { ++$count ; - push @kept, $_ ; - $result{$name} = "$name - $count: [@kept]" ; - } - } - - $db->filter_store_key(Closure("store key")) ; - $db->filter_store_value(Closure("store value")) ; - $db->filter_fetch_key(Closure("fetch key")) ; - $db->filter_fetch_value(Closure("fetch value")) ; - - $_ = "original" ; - - $h{"fred"} = "joe" ; - ok(85, $result{"store key"} eq "store key - 1: [fred]"); - ok(86, $result{"store value"} eq "store value - 1: [joe]"); - ok(87, ! defined $result{"fetch key"} ); - ok(88, ! defined $result{"fetch value"} ); - ok(89, $_ eq "original") ; - - ok(90, $db->FIRSTKEY() eq "fred") ; - ok(91, $result{"store key"} eq "store key - 1: [fred]"); - ok(92, $result{"store value"} eq "store value - 1: [joe]"); - ok(93, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(94, ! defined $result{"fetch value"} ); - ok(95, $_ eq "original") ; - - $h{"jim"} = "john" ; - ok(96, $result{"store key"} eq "store key - 2: [fred jim]"); - ok(97, $result{"store value"} eq "store value - 2: [joe john]"); - ok(98, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(99, ! defined $result{"fetch value"} ); - ok(100, $_ eq "original") ; - - ok(101, $h{"fred"} eq "joe"); - ok(102, $result{"store key"} eq "store key - 3: [fred jim fred]"); - ok(103, $result{"store value"} eq "store value - 2: [joe john]"); - ok(104, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(105, $result{"fetch value"} eq "fetch value - 1: [joe]"); - ok(106, $_ eq "original") ; - - undef $db ; - untie %h; - unlink $Dfile; -} - -{ - # DBM Filter recursion detection - use warnings ; - use strict ; - my (%h, $db) ; - unlink $Dfile; - - ok(107, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); - - $db->filter_store_key (sub { $_ = $h{$_} }) ; - - eval '$h{1} = 1234' ; - ok(108, $@ =~ /^recursion detected in filter_store_key at/ ); - - undef $db ; - untie %h; - unlink $Dfile; -} - - -{ - # Examples from the POD - - my $file = "xyzt" ; - { - my $redirect = new Redirect $file ; - - use warnings FATAL => qw(all); - use strict ; - use DB_File ; - use vars qw( %h $k $v ) ; - - unlink "fruit" ; - tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH - or die "Cannot open file 'fruit': $!\n"; - - # Add a few key/value pairs to the file - $h{"apple"} = "red" ; - $h{"orange"} = "orange" ; - $h{"banana"} = "yellow" ; - $h{"tomato"} = "red" ; - - # Check for existence of a key - print "Banana Exists\n\n" if $h{"banana"} ; - - # Delete a key/value pair. - delete $h{"apple"} ; - - # print the contents of the file - while (($k, $v) = each %h) - { print "$k -> $v\n" } - - untie %h ; - - unlink "fruit" ; - } - - ok(109, docat_del($file) eq <<'EOM') ; -Banana Exists - -orange -> orange -tomato -> red -banana -> yellow -EOM - -} - -{ - # Bug ID 20001013.009 - # - # test that $hash{KEY} = undef doesn't produce the warning - # Use of uninitialized value in null operation - use warnings ; - use strict ; - use DB_File ; - - unlink $Dfile; - my %h ; - my $a = ""; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - - tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ; - $h{ABC} = undef; - ok(110, $a eq "") ; - untie %h ; - unlink $Dfile; -} - -{ - # test that %hash = () doesn't produce the warning - # Argument "" isn't numeric in entersub - use warnings ; - use strict ; - use DB_File ; - - unlink $Dfile; - my %h ; - my $a = ""; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - - tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ; - %h = (); ; - ok(111, $a eq "") ; - untie %h ; - unlink $Dfile; -} - -exit ; diff --git a/t/lib/db-recno.t b/t/lib/db-recno.t deleted file mode 100755 index 6dd913cfc2..0000000000 --- a/t/lib/db-recno.t +++ /dev/null @@ -1,889 +0,0 @@ -#!./perl -w - -BEGIN { - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bDB_File\b/) { - print "1..0 # Skip: DB_File was not built\n"; - exit 0; - } -} - -use DB_File; -use Fcntl; -use strict ; -use warnings; -use vars qw($dbh $Dfile $bad_ones $FA) ; - -# full tied array support started in Perl 5.004_57 -# Double check to see if it is available. - -{ - sub try::TIEARRAY { bless [], "try" } - sub try::FETCHSIZE { $FA = 1 } - $FA = 0 ; - my @a ; - tie @a, 'try' ; - my $a = @a ; -} - - -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; - - return $result ; -} - -{ - package Redirect ; - use Symbol ; - - sub new - { - my $class = shift ; - my $filename = shift ; - my $fh = gensym ; - open ($fh, ">$filename") || die "Cannot open $filename: $!" ; - my $real_stdout = select($fh) ; - return bless [$fh, $real_stdout ] ; - - } - sub DESTROY - { - my $self = shift ; - close $self->[0] ; - select($self->[1]) ; - } -} - -sub docat -{ - my $file = shift; - local $/ = undef; - open(CAT,$file) || die "Cannot open $file:$!"; - my $result = <CAT>; - close(CAT); - return $result; -} - -sub docat_del -{ - my $file = shift; - local $/ = undef; - open(CAT,$file) || die "Cannot open $file: $!"; - my $result = <CAT>; - close(CAT); - unlink $file ; - return $result; -} - -sub bad_one -{ - print STDERR <<EOM unless $bad_ones++ ; -# -# Some older versions of Berkeley DB version 1 will fail tests 51, -# 53 and 55. -# -# You can safely ignore the errors if you're never going to use the -# broken functionality (recno databases with a modified bval). -# Otherwise you'll have to upgrade your DB library. -# -# If you want to use Berkeley DB version 1, then 1.85 and 1.86 are the -# last versions that were released. Berkeley DB version 2 is continually -# being updated -- Check out http://www.sleepycat.com/ for more details. -# -EOM -} - -print "1..128\n"; - -my $Dfile = "recno.tmp"; -unlink $Dfile ; - -umask(0); - -# Check the interface to RECNOINFO - -my $dbh = new DB_File::RECNOINFO ; -ok(1, ! defined $dbh->{bval}) ; -ok(2, ! defined $dbh->{cachesize}) ; -ok(3, ! defined $dbh->{psize}) ; -ok(4, ! defined $dbh->{flags}) ; -ok(5, ! defined $dbh->{lorder}) ; -ok(6, ! defined $dbh->{reclen}) ; -ok(7, ! defined $dbh->{bfname}) ; - -$dbh->{bval} = 3000 ; -ok(8, $dbh->{bval} == 3000 ); - -$dbh->{cachesize} = 9000 ; -ok(9, $dbh->{cachesize} == 9000 ); - -$dbh->{psize} = 400 ; -ok(10, $dbh->{psize} == 400 ); - -$dbh->{flags} = 65 ; -ok(11, $dbh->{flags} == 65 ); - -$dbh->{lorder} = 123 ; -ok(12, $dbh->{lorder} == 123 ); - -$dbh->{reclen} = 1234 ; -ok(13, $dbh->{reclen} == 1234 ); - -$dbh->{bfname} = 1234 ; -ok(14, $dbh->{bfname} == 1234 ); - - -# Check that an invalid entry is caught both for store & fetch -eval '$dbh->{fred} = 1234' ; -ok(15, $@ =~ /^DB_File::RECNOINFO::STORE - Unknown element 'fred' at/ ); -eval 'my $q = $dbh->{fred}' ; -ok(16, $@ =~ /^DB_File::RECNOINFO::FETCH - Unknown element 'fred' at/ ); - -# Now check the interface to RECNOINFO - -my $X ; -my @h ; -ok(17, $X = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ; - -ok(18, ((stat($Dfile))[2] & 0777) == ($^O eq 'os2' ? 0666 : 0640) - || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'amigaos') ; - -#my $l = @h ; -my $l = $X->length ; -ok(19, ($FA ? @h == 0 : !$l) ); - -my @data = qw( a b c d ever f g h i j k longername m n o p) ; - -$h[0] = shift @data ; -ok(20, $h[0] eq 'a' ); - -my $ i; -foreach (@data) - { $h[++$i] = $_ } - -unshift (@data, 'a') ; - -ok(21, defined $h[1] ); -ok(22, ! defined $h[16] ); -ok(23, $FA ? @h == @data : $X->length == @data ); - - -# Overwrite an entry & check fetch it -$h[3] = 'replaced' ; -$data[3] = 'replaced' ; -ok(24, $h[3] eq 'replaced' ); - -#PUSH -my @push_data = qw(added to the end) ; -($FA ? push(@h, @push_data) : $X->push(@push_data)) ; -push (@data, @push_data) ; -ok(25, $h[++$i] eq 'added' ); -ok(26, $h[++$i] eq 'to' ); -ok(27, $h[++$i] eq 'the' ); -ok(28, $h[++$i] eq 'end' ); - -# POP -my $popped = pop (@data) ; -my $value = ($FA ? pop @h : $X->pop) ; -ok(29, $value eq $popped) ; - -# SHIFT -$value = ($FA ? shift @h : $X->shift) ; -my $shifted = shift @data ; -ok(30, $value eq $shifted ); - -# UNSHIFT - -# empty list -($FA ? unshift @h,() : $X->unshift) ; -ok(31, ($FA ? @h == @data : $X->length == @data )); - -my @new_data = qw(add this to the start of the array) ; -$FA ? unshift (@h, @new_data) : $X->unshift (@new_data) ; -unshift (@data, @new_data) ; -ok(32, $FA ? @h == @data : $X->length == @data ); -ok(33, $h[0] eq "add") ; -ok(34, $h[1] eq "this") ; -ok(35, $h[2] eq "to") ; -ok(36, $h[3] eq "the") ; -ok(37, $h[4] eq "start") ; -ok(38, $h[5] eq "of") ; -ok(39, $h[6] eq "the") ; -ok(40, $h[7] eq "array") ; -ok(41, $h[8] eq $data[8]) ; - -# SPLICE - -# Now both arrays should be identical - -my $ok = 1 ; -my $j = 0 ; -foreach (@data) -{ - $ok = 0, last if $_ ne $h[$j ++] ; -} -ok(42, $ok ); - -# Neagtive subscripts - -# get the last element of the array -ok(43, $h[-1] eq $data[-1] ); -ok(44, $h[-1] eq $h[ ($FA ? @h : $X->length) -1] ); - -# get the first element using a negative subscript -eval '$h[ - ( $FA ? @h : $X->length)] = "abcd"' ; -ok(45, $@ eq "" ); -ok(46, $h[0] eq "abcd" ); - -# now try to read before the start of the array -eval '$h[ - (1 + ($FA ? @h : $X->length))] = 1234' ; -ok(47, $@ =~ '^Modification of non-creatable array value attempted' ); - -# IMPORTANT - $X must be undefined before the untie otherwise the -# underlying DB close routine will not get called. -undef $X ; -untie(@h); - -unlink $Dfile; - - -{ - # Check bval defaults to \n - - my @h = () ; - my $dbh = new DB_File::RECNOINFO ; - ok(48, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; - $h[0] = "abc" ; - $h[1] = "def" ; - $h[3] = "ghi" ; - untie @h ; - my $x = docat($Dfile) ; - unlink $Dfile; - ok(49, $x eq "abc\ndef\n\nghi\n") ; -} - -{ - # Change bval - - my @h = () ; - my $dbh = new DB_File::RECNOINFO ; - $dbh->{bval} = "-" ; - ok(50, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; - $h[0] = "abc" ; - $h[1] = "def" ; - $h[3] = "ghi" ; - untie @h ; - my $x = docat($Dfile) ; - unlink $Dfile; - my $ok = ($x eq "abc-def--ghi-") ; - bad_one() unless $ok ; - ok(51, $ok) ; -} - -{ - # Check R_FIXEDLEN with default bval (space) - - my @h = () ; - my $dbh = new DB_File::RECNOINFO ; - $dbh->{flags} = R_FIXEDLEN ; - $dbh->{reclen} = 5 ; - ok(52, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; - $h[0] = "abc" ; - $h[1] = "def" ; - $h[3] = "ghi" ; - untie @h ; - my $x = docat($Dfile) ; - unlink $Dfile; - my $ok = ($x eq "abc def ghi ") ; - bad_one() unless $ok ; - ok(53, $ok) ; -} - -{ - # Check R_FIXEDLEN with user-defined bval - - my @h = () ; - my $dbh = new DB_File::RECNOINFO ; - $dbh->{flags} = R_FIXEDLEN ; - $dbh->{bval} = "-" ; - $dbh->{reclen} = 5 ; - ok(54, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; - $h[0] = "abc" ; - $h[1] = "def" ; - $h[3] = "ghi" ; - untie @h ; - my $x = docat($Dfile) ; - unlink $Dfile; - my $ok = ($x eq "abc--def-------ghi--") ; - bad_one() unless $ok ; - ok(55, $ok) ; -} - -{ - # check that attempting to tie an associative array to a DB_RECNO will fail - - my $filename = "xyz" ; - my %x ; - eval { tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO ; } ; - ok(56, $@ =~ /^DB_File can only tie an array to a DB_RECNO database/) ; - unlink $filename ; -} - -{ - # sub-class test - - package Another ; - - use warnings ; - use strict ; - - open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; - print FILE <<'EOM' ; - - package SubDB ; - - use warnings ; - use strict ; - use vars qw( @ISA @EXPORT) ; - - require Exporter ; - use DB_File; - @ISA=qw(DB_File); - @EXPORT = @DB_File::EXPORT ; - - sub STORE { - my $self = shift ; - my $key = shift ; - my $value = shift ; - $self->SUPER::STORE($key, $value * 2) ; - } - - sub FETCH { - my $self = shift ; - my $key = shift ; - $self->SUPER::FETCH($key) - 1 ; - } - - sub put { - my $self = shift ; - my $key = shift ; - my $value = shift ; - $self->SUPER::put($key, $value * 3) ; - } - - sub get { - my $self = shift ; - $self->SUPER::get($_[0], $_[1]) ; - $_[1] -= 2 ; - } - - sub A_new_method - { - my $self = shift ; - my $key = shift ; - my $value = $self->FETCH($key) ; - return "[[$value]]" ; - } - - 1 ; -EOM - - close FILE ; - - BEGIN { push @INC, '.'; } - eval 'use SubDB ; '; - main::ok(57, $@ eq "") ; - my @h ; - my $X ; - eval ' - $X = tie(@h, "SubDB","recno.tmp", O_RDWR|O_CREAT, 0640, $DB_RECNO ); - ' ; - - main::ok(58, $@ eq "") ; - - my $ret = eval '$h[3] = 3 ; return $h[3] ' ; - main::ok(59, $@ eq "") ; - main::ok(60, $ret == 5) ; - - my $value = 0; - $ret = eval '$X->put(1, 4) ; $X->get(1, $value) ; return $value' ; - main::ok(61, $@ eq "") ; - main::ok(62, $ret == 10) ; - - $ret = eval ' R_NEXT eq main::R_NEXT ' ; - main::ok(63, $@ eq "" ) ; - main::ok(64, $ret == 1) ; - - $ret = eval '$X->A_new_method(1) ' ; - main::ok(65, $@ eq "") ; - main::ok(66, $ret eq "[[11]]") ; - - undef $X; - untie(@h); - unlink "SubDB.pm", "recno.tmp" ; - -} - -{ - - # test $# - my $self ; - unlink $Dfile; - ok(67, $self = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ; - $h[0] = "abc" ; - $h[1] = "def" ; - $h[2] = "ghi" ; - $h[3] = "jkl" ; - ok(68, $FA ? $#h == 3 : $self->length() == 4) ; - undef $self ; - untie @h ; - my $x = docat($Dfile) ; - ok(69, $x eq "abc\ndef\nghi\njkl\n") ; - - # $# sets array to same length - ok(70, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; - if ($FA) - { $#h = 3 } - else - { $self->STORESIZE(4) } - ok(71, $FA ? $#h == 3 : $self->length() == 4) ; - undef $self ; - untie @h ; - $x = docat($Dfile) ; - ok(72, $x eq "abc\ndef\nghi\njkl\n") ; - - # $# sets array to bigger - ok(73, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; - if ($FA) - { $#h = 6 } - else - { $self->STORESIZE(7) } - ok(74, $FA ? $#h == 6 : $self->length() == 7) ; - undef $self ; - untie @h ; - $x = docat($Dfile) ; - ok(75, $x eq "abc\ndef\nghi\njkl\n\n\n\n") ; - - # $# sets array smaller - ok(76, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; - if ($FA) - { $#h = 2 } - else - { $self->STORESIZE(3) } - ok(77, $FA ? $#h == 2 : $self->length() == 3) ; - undef $self ; - untie @h ; - $x = docat($Dfile) ; - ok(78, $x eq "abc\ndef\nghi\n") ; - - unlink $Dfile; - - -} - -{ - # DBM Filter tests - use warnings ; - use strict ; - my (@h, $db) ; - my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - unlink $Dfile; - - sub checkOutput - { - my($fk, $sk, $fv, $sv) = @_ ; - return - $fetch_key eq $fk && $store_key eq $sk && - $fetch_value eq $fv && $store_value eq $sv && - $_ eq 'original' ; - } - - ok(79, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); - - $db->filter_fetch_key (sub { $fetch_key = $_ }) ; - $db->filter_store_key (sub { $store_key = $_ }) ; - $db->filter_fetch_value (sub { $fetch_value = $_}) ; - $db->filter_store_value (sub { $store_value = $_ }) ; - - $_ = "original" ; - - $h[0] = "joe" ; - # fk sk fv sv - ok(80, checkOutput( "", 0, "", "joe")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(81, $h[0] eq "joe"); - # fk sk fv sv - ok(82, checkOutput( "", 0, "joe", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(83, $db->FIRSTKEY() == 0) ; - # fk sk fv sv - ok(84, checkOutput( 0, "", "", "")) ; - - # replace the filters, but remember the previous set - my ($old_fk) = $db->filter_fetch_key - (sub { ++ $_ ; $fetch_key = $_ }) ; - my ($old_sk) = $db->filter_store_key - (sub { $_ *= 2 ; $store_key = $_ }) ; - my ($old_fv) = $db->filter_fetch_value - (sub { $_ = "[$_]"; $fetch_value = $_ }) ; - my ($old_sv) = $db->filter_store_value - (sub { s/o/x/g; $store_value = $_ }) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - $h[1] = "Joe" ; - # fk sk fv sv - ok(85, checkOutput( "", 2, "", "Jxe")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(86, $h[1] eq "[Jxe]"); - # fk sk fv sv - ok(87, checkOutput( "", 2, "[Jxe]", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(88, $db->FIRSTKEY() == 1) ; - # fk sk fv sv - ok(89, checkOutput( 1, "", "", "")) ; - - # put the original filters back - $db->filter_fetch_key ($old_fk); - $db->filter_store_key ($old_sk); - $db->filter_fetch_value ($old_fv); - $db->filter_store_value ($old_sv); - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - $h[0] = "joe" ; - ok(90, checkOutput( "", 0, "", "joe")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(91, $h[0] eq "joe"); - ok(92, checkOutput( "", 0, "joe", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(93, $db->FIRSTKEY() == 0) ; - ok(94, checkOutput( 0, "", "", "")) ; - - # delete the filters - $db->filter_fetch_key (undef); - $db->filter_store_key (undef); - $db->filter_fetch_value (undef); - $db->filter_store_value (undef); - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - $h[0] = "joe" ; - ok(95, checkOutput( "", "", "", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(96, $h[0] eq "joe"); - ok(97, checkOutput( "", "", "", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(98, $db->FIRSTKEY() == 0) ; - ok(99, checkOutput( "", "", "", "")) ; - - undef $db ; - untie @h; - unlink $Dfile; -} - -{ - # DBM Filter with a closure - - use warnings ; - use strict ; - my (@h, $db) ; - - unlink $Dfile; - ok(100, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); - - my %result = () ; - - sub Closure - { - my ($name) = @_ ; - my $count = 0 ; - my @kept = () ; - - return sub { ++$count ; - push @kept, $_ ; - $result{$name} = "$name - $count: [@kept]" ; - } - } - - $db->filter_store_key(Closure("store key")) ; - $db->filter_store_value(Closure("store value")) ; - $db->filter_fetch_key(Closure("fetch key")) ; - $db->filter_fetch_value(Closure("fetch value")) ; - - $_ = "original" ; - - $h[0] = "joe" ; - ok(101, $result{"store key"} eq "store key - 1: [0]"); - ok(102, $result{"store value"} eq "store value - 1: [joe]"); - ok(103, ! defined $result{"fetch key"} ); - ok(104, ! defined $result{"fetch value"} ); - ok(105, $_ eq "original") ; - - ok(106, $db->FIRSTKEY() == 0 ) ; - ok(107, $result{"store key"} eq "store key - 1: [0]"); - ok(108, $result{"store value"} eq "store value - 1: [joe]"); - ok(109, $result{"fetch key"} eq "fetch key - 1: [0]"); - ok(110, ! defined $result{"fetch value"} ); - ok(111, $_ eq "original") ; - - $h[7] = "john" ; - ok(112, $result{"store key"} eq "store key - 2: [0 7]"); - ok(113, $result{"store value"} eq "store value - 2: [joe john]"); - ok(114, $result{"fetch key"} eq "fetch key - 1: [0]"); - ok(115, ! defined $result{"fetch value"} ); - ok(116, $_ eq "original") ; - - ok(117, $h[0] eq "joe"); - ok(118, $result{"store key"} eq "store key - 3: [0 7 0]"); - ok(119, $result{"store value"} eq "store value - 2: [joe john]"); - ok(120, $result{"fetch key"} eq "fetch key - 1: [0]"); - ok(121, $result{"fetch value"} eq "fetch value - 1: [joe]"); - ok(122, $_ eq "original") ; - - undef $db ; - untie @h; - unlink $Dfile; -} - -{ - # DBM Filter recursion detection - use warnings ; - use strict ; - my (@h, $db) ; - unlink $Dfile; - - ok(123, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); - - $db->filter_store_key (sub { $_ = $h[0] }) ; - - eval '$h[1] = 1234' ; - ok(124, $@ =~ /^recursion detected in filter_store_key at/ ); - - undef $db ; - untie @h; - unlink $Dfile; -} - - -{ - # Examples from the POD - - my $file = "xyzt" ; - { - my $redirect = new Redirect $file ; - - use warnings FATAL => qw(all); - use strict ; - use DB_File ; - - my $filename = "text" ; - unlink $filename ; - - my @h ; - my $x = tie @h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO - or die "Cannot open file 'text': $!\n" ; - - # Add a few key/value pairs to the file - $h[0] = "orange" ; - $h[1] = "blue" ; - $h[2] = "yellow" ; - - $FA ? push @h, "green", "black" - : $x->push("green", "black") ; - - my $elements = $FA ? scalar @h : $x->length ; - print "The array contains $elements entries\n" ; - - my $last = $FA ? pop @h : $x->pop ; - print "popped $last\n" ; - - $FA ? unshift @h, "white" - : $x->unshift("white") ; - my $first = $FA ? shift @h : $x->shift ; - print "shifted $first\n" ; - - # Check for existence of a key - print "Element 1 Exists with value $h[1]\n" if $h[1] ; - - # use a negative index - print "The last element is $h[-1]\n" ; - print "The 2nd last element is $h[-2]\n" ; - - undef $x ; - untie @h ; - - unlink $filename ; - } - - ok(125, docat_del($file) eq <<'EOM') ; -The array contains 5 entries -popped black -shifted white -Element 1 Exists with value blue -The last element is green -The 2nd last element is yellow -EOM - - my $save_output = "xyzt" ; - { - my $redirect = new Redirect $save_output ; - - use warnings FATAL => qw(all); - use strict ; - use vars qw(@h $H $file $i) ; - use DB_File ; - use Fcntl ; - - $file = "text" ; - - unlink $file ; - - $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0640, $DB_RECNO - or die "Cannot open file $file: $!\n" ; - - # first create a text file to play with - $h[0] = "zero" ; - $h[1] = "one" ; - $h[2] = "two" ; - $h[3] = "three" ; - $h[4] = "four" ; - - - # Print the records in order. - # - # The length method is needed here because evaluating a tied - # array in a scalar context does not return the number of - # elements in the array. - - print "\nORIGINAL\n" ; - foreach $i (0 .. $H->length - 1) { - print "$i: $h[$i]\n" ; - } - - # use the push & pop methods - $a = $H->pop ; - $H->push("last") ; - print "\nThe last record was [$a]\n" ; - - # and the shift & unshift methods - $a = $H->shift ; - $H->unshift("first") ; - print "The first record was [$a]\n" ; - - # Use the API to add a new record after record 2. - $i = 2 ; - $H->put($i, "Newbie", R_IAFTER) ; - - # and a new record before record 1. - $i = 1 ; - $H->put($i, "New One", R_IBEFORE) ; - - # delete record 3 - $H->del(3) ; - - # now print the records in reverse order - print "\nREVERSE\n" ; - for ($i = $H->length - 1 ; $i >= 0 ; -- $i) - { print "$i: $h[$i]\n" } - - # same again, but use the API functions instead - print "\nREVERSE again\n" ; - my ($s, $k, $v) = (0, 0, 0) ; - for ($s = $H->seq($k, $v, R_LAST) ; - $s == 0 ; - $s = $H->seq($k, $v, R_PREV)) - { print "$k: $v\n" } - - undef $H ; - untie @h ; - - unlink $file ; - } - - ok(126, docat_del($save_output) eq <<'EOM') ; - -ORIGINAL -0: zero -1: one -2: two -3: three -4: four - -The last record was [four] -The first record was [zero] - -REVERSE -5: last -4: three -3: Newbie -2: one -1: New One -0: first - -REVERSE again -5: last -4: three -3: Newbie -2: one -1: New One -0: first -EOM - -} - -{ - # Bug ID 20001013.009 - # - # test that $hash{KEY} = undef doesn't produce the warning - # Use of uninitialized value in null operation - use warnings ; - use strict ; - use DB_File ; - - unlink $Dfile; - my @h ; - my $a = ""; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - - tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO - or die "Can't open file: $!\n" ; - $h[0] = undef; - ok(127, $a eq "") ; - untie @h ; - unlink $Dfile; -} - -{ - # test that %hash = () doesn't produce the warning - # Argument "" isn't numeric in entersub - use warnings ; - use strict ; - use DB_File ; - my $a = ""; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - - unlink $Dfile; - my @h ; - - tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO - or die "Can't open file: $!\n" ; - @h = (); ; - ok(128, $a eq "") ; - untie @h ; - unlink $Dfile; -} - -exit ; diff --git a/t/lib/digest.t b/t/lib/digest.t deleted file mode 100644 index 5741b777fe..0000000000 --- a/t/lib/digest.t +++ /dev/null @@ -1,26 +0,0 @@ -print "1..3\n"; - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Digest; - -my $hexdigest = "900150983cd24fb0d6963f7d28e17f72"; -if (ord('A') == 193) { # EBCDIC - $hexdigest = "fe4ea0d98f9cd8d1d27f102a93cb0bb0"; # IBM-1047 -} - -print "not " unless Digest->MD5->add("abc")->hexdigest eq $hexdigest; -print "ok 1\n"; - -print "not " unless Digest->MD5->add("abc")->hexdigest eq $hexdigest; -print "ok 2\n"; - -eval { - print "not " unless Digest->new("HMAC-MD5" => "Jefe")->add("what do ya want for nothing?")->hexdigest eq "750c783e6ab0b503eaa86e310a5db738"; - print "ok 3\n"; -}; -print "ok 3\n" if $@ && $@ =~ /^Can't locate/; - diff --git a/t/lib/dirhand.t b/t/lib/dirhand.t deleted file mode 100755 index e83ea13496..0000000000 --- a/t/lib/dirhand.t +++ /dev/null @@ -1,34 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if (not $Config{'d_readdir'}) { - print "1..0\n"; - exit 0; - } -} - -use DirHandle; - -print "1..5\n"; - -$dot = new DirHandle ($^O eq 'MacOS' ? ':' : '.'); - -print defined($dot) ? "ok" : "not ok", " 1\n"; - -@a = sort <*>; -do { $first = $dot->read } while defined($first) && $first =~ /^\./; -print +(grep { $_ eq $first } @a) ? "ok" : "not ok", " 2\n"; - -@b = sort($first, (grep {/^[^.]/} $dot->read)); -print +(join("\0", @a) eq join("\0", @b)) ? "ok" : "not ok", " 3\n"; - -$dot->rewind; -@c = sort grep {/^[^.]/} $dot->read; -print +(join("\0", @b) eq join("\0", @c)) ? "ok" : "not ok", " 4\n"; - -$dot->close; -$dot->rewind; -print defined($dot->read) ? "not ok" : "ok", " 5\n"; diff --git a/t/lib/dosglob.t b/t/lib/dosglob.t deleted file mode 100755 index fd9bb1d119..0000000000 --- a/t/lib/dosglob.t +++ /dev/null @@ -1,112 +0,0 @@ -#!./perl - -# -# test glob() in File::DosGlob -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..10\n"; - -# override it in main:: -use File::DosGlob 'glob'; - -# test if $_ takes as the default -$_ = "lib/a*.t"; -my @r = glob; -print "not " if $_ ne 'lib/a*.t'; -print "ok 1\n"; -# we should have at least abbrev.t, anydbm.t, autoloader.t -print "# |@r|\nnot " if @r < 3; -print "ok 2\n"; - -# check if <*/*> works -@r = <*/a*.t>; -# atleast {argv,abbrev,anydbm,autoloader,append,arith,array,assignwarn,auto}.t -print "not " if @r < 9; -print "ok 3\n"; -my $r = scalar @r; - -# check if scalar context works -@r = (); -while (defined($_ = <*/a*.t>)) { - print "# $_\n"; - push @r, $_; -} -print "not " if @r != $r; -print "ok 4\n"; - -# check if list context works -@r = (); -for (<*/a*.t>) { - print "# $_\n"; - push @r, $_; -} -print "not " if @r != $r; -print "ok 5\n"; - -# test if implicit assign to $_ in while() works -@r = (); -while (<*/a*.t>) { - print "# $_\n"; - push @r, $_; -} -print "not " if @r != $r; -print "ok 6\n"; - -# test if explicit glob() gets assign magic too -my @s = (); -while (glob '*/a*.t') { - print "# $_\n"; - push @s, $_; -} -print "not " if "@r" ne "@s"; -print "ok 7\n"; - -# how about in a different package, like? -package Foo; -use File::DosGlob 'glob'; -@s = (); -while (glob '*/a*.t') { - print "# $_\n"; - push @s, $_; -} -print "not " if "@r" ne "@s"; -print "ok 8\n"; - -# test if different glob ops maintain independent contexts -@s = (); -while (<*/a*.t>) { - my $i = 0; - print "# $_ <"; - push @s, $_; - while (<*/b*.t>) { - print " $_"; - $i++; - } - print " >\n"; -} -print "not " if "@r" ne "@s"; -print "ok 9\n"; - -# how about a global override, hm? -eval <<'EOT'; -use File::DosGlob 'GLOBAL_glob'; -package Bar; -@s = (); -while (<*/a*.t>) { - my $i = 0; - print "# $_ <"; - push @s, $_; - while (glob '*/b*.t') { - print " $_"; - $i++; - } - print " >\n"; -} -print "not " if "@r" ne "@s"; -print "ok 10\n"; -EOT diff --git a/t/lib/dprof.t b/t/lib/dprof.t deleted file mode 100755 index be711f1330..0000000000 --- a/t/lib/dprof.t +++ /dev/null @@ -1,88 +0,0 @@ -#!perl - -BEGIN { - chdir( 't' ) if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bDevel\/DProf\b/){ - print "1..0 # Skip: Devel::DProf was not built\n"; - exit 0; - } -} - -END { - while(-e 'tmon.out' && unlink 'tmon.out') {} - while(-e 'err' && unlink 'err') {} -} - -use Benchmark qw( timediff timestr ); -use Getopt::Std 'getopts'; -getopts('vI:p:'); - -# -v Verbose -# -I Add to @INC -# -p Name of perl binary - -@tests = @ARGV ? @ARGV : sort (<lib/dprof/*_t>, <lib/dprof/*_v>); # glob-sort, for OS/2 - -$path_sep = $Config{path_sep} || ':'; -$perl5lib = $opt_I || join( $path_sep, @INC ); -$perl = $opt_p || $^X; - -if( $opt_v ){ - print "tests: @tests\n"; - print "perl: $perl\n"; - print "perl5lib: $perl5lib\n"; -} -if( $perl =~ m|^\./| ){ - # turn ./perl into ../perl, because of chdir(t) above. - $perl = ".$perl"; -} -if( ! -f $perl ){ die "Where's Perl?" } - -sub profile { - my $test = shift; - my @results; - local $ENV{PERL5LIB} = $perl5lib; - my $opt_d = '-d:DProf'; - - my $t_start = new Benchmark; - open( R, "$perl \"$opt_d\" $test |" ) || warn "$0: Can't run. $!\n"; - @results = <R>; - close R; - my $t_total = timediff( new Benchmark, $t_start ); - - if( $opt_v ){ - print "\n"; - print @results - } - - print '# ',timestr( $t_total, 'nop' ), "\n"; -} - - -sub verify { - my $test = shift; - - my $command = $perl.' "-I../lib" "-I./lib/dprof" '.$test; - $command .= ' -v' if $opt_v; - $command .= ' -p '. $perl; - system $command; -} - - -$| = 1; -print "1..18\n"; -while( @tests ){ - $test = shift @tests; - $test =~ s/\.$// if $^O eq 'VMS'; - if( $test =~ /_t$/i ){ - print "# $test" . '.' x (20 - length $test); - profile $test; - } - else{ - verify $test; - } -} - -unlink("tmon.out"); diff --git a/t/lib/dumper-ovl.t b/t/lib/dumper-ovl.t deleted file mode 100755 index d4b3a924ae..0000000000 --- a/t/lib/dumper-ovl.t +++ /dev/null @@ -1,35 +0,0 @@ -#!./perl -w - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { - print "1..0 # Skip: Data::Dumper was not built\n"; - exit 0; - } -} - -use Data::Dumper; - -print "1..1\n"; - -package Foo; -use overload '""' => 'as_string'; - -sub new { bless { foo => "bar" }, shift } -sub as_string { "%%%%" } - -package main; - -my $f = Foo->new; - -print "#\$f=$f\n"; - -$_ = Dumper($f); -s/^/#/mg; -print $_; - -print "not " unless /bar/ && /Foo/; -print "ok 1\n"; - diff --git a/t/lib/dumper.t b/t/lib/dumper.t deleted file mode 100755 index 10add1cedb..0000000000 --- a/t/lib/dumper.t +++ /dev/null @@ -1,810 +0,0 @@ -#!./perl -w -# -# testsuite for Data::Dumper -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { - print "1..0 # Skip: Data::Dumper was not built\n"; - exit 0; - } -} - -use Data::Dumper; -use Config; -my $Is_ebcdic = defined($Config{'ebcdic'}) && $Config{'ebcdic'} eq 'define'; - -$Data::Dumper::Pad = "#"; -my $TMAX; -my $XS; -my $TNUM = 0; -my $WANT = ''; - -sub TEST { - my $string = shift; - my $t = eval $string; - ++$TNUM; - $t =~ s/([A-Z]+)\(0x[0-9a-f]+\)/$1(0xdeadbeef)/g - if ($WANT =~ /deadbeef/); - if ($Is_ebcdic) { - # these data need massaging with non ascii character sets - # because of hashing order differences - $WANT = join("\n",sort(split(/\n/,$WANT))); - $WANT =~ s/\,$//mg; - $t = join("\n",sort(split(/\n/,$t))); - $t =~ s/\,$//mg; - } - print( ($t eq $WANT and not $@) ? "ok $TNUM\n" - : "not ok $TNUM\n--Expected--\n$WANT\n--Got--\n$@$t\n"); - - ++$TNUM; - eval "$t"; - print $@ ? "not ok $TNUM\n# \$@ says: $@\n" : "ok $TNUM\n"; - - $t = eval $string; - ++$TNUM; - $t =~ s/([A-Z]+)\(0x[0-9a-f]+\)/$1(0xdeadbeef)/g - if ($WANT =~ /deadbeef/); - if ($Is_ebcdic) { - # here too there are hashing order differences - $WANT = join("\n",sort(split(/\n/,$WANT))); - $WANT =~ s/\,$//mg; - $t = join("\n",sort(split(/\n/,$t))); - $t =~ s/\,$//mg; - } - print( ($t eq $WANT and not $@) ? "ok $TNUM\n" - : "not ok $TNUM\n--Expected--\n$WANT\n--Got--\n$@$t\n"); -} - -if (defined &Data::Dumper::Dumpxs) { - print "### XS extension loaded, will run XS tests\n"; - $TMAX = 186; $XS = 1; -} -else { - print "### XS extensions not loaded, will NOT run XS tests\n"; - $TMAX = 93; $XS = 0; -} - -print "1..$TMAX\n"; - -############# -############# - -@c = ('c'); -$c = \@c; -$b = {}; -$a = [1, $b, $c]; -$b->{a} = $a; -$b->{b} = $a->[1]; -$b->{c} = $a->[2]; - -############# 1 -## -$WANT = <<'EOT'; -#$a = [ -# 1, -# { -# 'c' => [ -# 'c' -# ], -# 'a' => $a, -# 'b' => $a->[1] -# }, -# $a->[1]{'c'} -# ]; -#$b = $a->[1]; -#$c = $a->[1]{'c'}; -EOT - -TEST q(Data::Dumper->Dump([$a,$b,$c], [qw(a b c)])); -TEST q(Data::Dumper->Dumpxs([$a,$b,$c], [qw(a b c)])) if $XS; - - -############# 7 -## -$WANT = <<'EOT'; -#@a = ( -# 1, -# { -# 'c' => [ -# 'c' -# ], -# 'a' => [], -# 'b' => {} -# }, -# [] -# ); -#$a[1]{'a'} = \@a; -#$a[1]{'b'} = $a[1]; -#$a[2] = $a[1]{'c'}; -#$b = $a[1]; -EOT - -$Data::Dumper::Purity = 1; # fill in the holes for eval -TEST q(Data::Dumper->Dump([$a, $b], [qw(*a b)])); # print as @a -TEST q(Data::Dumper->Dumpxs([$a, $b], [qw(*a b)])) if $XS; - -############# 13 -## -$WANT = <<'EOT'; -#%b = ( -# 'c' => [ -# 'c' -# ], -# 'a' => [ -# 1, -# {}, -# [] -# ], -# 'b' => {} -# ); -#$b{'a'}[1] = \%b; -#$b{'a'}[2] = $b{'c'}; -#$b{'b'} = \%b; -#$a = $b{'a'}; -EOT - -TEST q(Data::Dumper->Dump([$b, $a], [qw(*b a)])); # print as %b -TEST q(Data::Dumper->Dumpxs([$b, $a], [qw(*b a)])) if $XS; - -############# 19 -## -$WANT = <<'EOT'; -#$a = [ -# 1, -# { -# 'c' => [], -# 'a' => [], -# 'b' => {} -# }, -# [] -#]; -#$a->[1]{'c'} = \@c; -#$a->[1]{'a'} = $a; -#$a->[1]{'b'} = $a->[1]; -#$a->[2] = \@c; -#$b = $a->[1]; -EOT - -$Data::Dumper::Indent = 1; -TEST q( - $d = Data::Dumper->new([$a,$b], [qw(a b)]); - $d->Seen({'*c' => $c}); - $d->Dump; - ); -if ($XS) { - TEST q( - $d = Data::Dumper->new([$a,$b], [qw(a b)]); - $d->Seen({'*c' => $c}); - $d->Dumpxs; - ); -} - - -############# 25 -## -$WANT = <<'EOT'; -#$a = [ -# #0 -# 1, -# #1 -# { -# c => [ -# #0 -# 'c' -# ], -# a => $a, -# b => $a->[1] -# }, -# #2 -# $a->[1]{c} -# ]; -#$b = $a->[1]; -EOT - -$d->Indent(3); -$d->Purity(0)->Quotekeys(0); -TEST q( $d->Reset; $d->Dump ); - -TEST q( $d->Reset; $d->Dumpxs ) if $XS; - -############# 31 -## -$WANT = <<'EOT'; -#$VAR1 = [ -# 1, -# { -# 'c' => [ -# 'c' -# ], -# 'a' => [], -# 'b' => {} -# }, -# [] -#]; -#$VAR1->[1]{'a'} = $VAR1; -#$VAR1->[1]{'b'} = $VAR1->[1]; -#$VAR1->[2] = $VAR1->[1]{'c'}; -EOT - -TEST q(Dumper($a)); -TEST q(Data::Dumper::DumperX($a)) if $XS; - -############# 37 -## -$WANT = <<'EOT'; -#[ -# 1, -# { -# c => [ -# 'c' -# ], -# a => $VAR1, -# b => $VAR1->[1] -# }, -# $VAR1->[1]{c} -#] -EOT - -{ - local $Data::Dumper::Purity = 0; - local $Data::Dumper::Quotekeys = 0; - local $Data::Dumper::Terse = 1; - TEST q(Dumper($a)); - TEST q(Data::Dumper::DumperX($a)) if $XS; -} - - -############# 43 -## -$WANT = <<'EOT'; -#$VAR1 = { -# "reftest" => \\1, -# "abc\0'\efg" => "mno\0" -#}; -EOT - -$foo = { "abc\000\'\efg" => "mno\000", - "reftest" => \\1, - }; -{ - local $Data::Dumper::Useqq = 1; - TEST q(Dumper($foo)); -} - - $WANT = <<"EOT"; -#\$VAR1 = { -# 'reftest' => \\\\1, -# 'abc\0\\'\efg' => 'mno\0' -#}; -EOT - - { - local $Data::Dumper::Useqq = 1; - TEST q(Data::Dumper::DumperX($foo)) if $XS; # cheat - } - - - -############# -############# - -{ - package main; - use Data::Dumper; - $foo = 5; - @foo = (-10,\*foo); - %foo = (a=>1,b=>\$foo,c=>\@foo); - $foo{d} = \%foo; - $foo[2] = \%foo; - -############# 49 -## - $WANT = <<'EOT'; -#$foo = \*::foo; -#*::foo = \5; -#*::foo = [ -# #0 -# -10, -# #1 -# do{my $o}, -# #2 -# { -# 'c' => [], -# 'a' => 1, -# 'b' => do{my $o}, -# 'd' => {} -# } -# ]; -#*::foo{ARRAY}->[1] = $foo; -#*::foo{ARRAY}->[2]{'c'} = *::foo{ARRAY}; -#*::foo{ARRAY}->[2]{'b'} = *::foo{SCALAR}; -#*::foo{ARRAY}->[2]{'d'} = *::foo{ARRAY}->[2]; -#*::foo = *::foo{ARRAY}->[2]; -#@bar = @{*::foo{ARRAY}}; -#%baz = %{*::foo{ARRAY}->[2]}; -EOT - - $Data::Dumper::Purity = 1; - $Data::Dumper::Indent = 3; - TEST q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])); - TEST q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])) if $XS; - -############# 55 -## - $WANT = <<'EOT'; -#$foo = \*::foo; -#*::foo = \5; -#*::foo = [ -# -10, -# do{my $o}, -# { -# 'c' => [], -# 'a' => 1, -# 'b' => do{my $o}, -# 'd' => {} -# } -#]; -#*::foo{ARRAY}->[1] = $foo; -#*::foo{ARRAY}->[2]{'c'} = *::foo{ARRAY}; -#*::foo{ARRAY}->[2]{'b'} = *::foo{SCALAR}; -#*::foo{ARRAY}->[2]{'d'} = *::foo{ARRAY}->[2]; -#*::foo = *::foo{ARRAY}->[2]; -#$bar = *::foo{ARRAY}; -#$baz = *::foo{ARRAY}->[2]; -EOT - - $Data::Dumper::Indent = 1; - TEST q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])); - TEST q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])) if $XS; - -############# 61 -## - $WANT = <<'EOT'; -#@bar = ( -# -10, -# \*::foo, -# {} -#); -#*::foo = \5; -#*::foo = \@bar; -#*::foo = { -# 'c' => [], -# 'a' => 1, -# 'b' => do{my $o}, -# 'd' => {} -#}; -#*::foo{HASH}->{'c'} = \@bar; -#*::foo{HASH}->{'b'} = *::foo{SCALAR}; -#*::foo{HASH}->{'d'} = *::foo{HASH}; -#$bar[2] = *::foo{HASH}; -#%baz = %{*::foo{HASH}}; -#$foo = $bar[1]; -EOT - - TEST q(Data::Dumper->Dump([\\@foo, \\%foo, \\*foo], ['*bar', '*baz', '*foo'])); - TEST q(Data::Dumper->Dumpxs([\\@foo, \\%foo, \\*foo], ['*bar', '*baz', '*foo'])) if $XS; - -############# 67 -## - $WANT = <<'EOT'; -#$bar = [ -# -10, -# \*::foo, -# {} -#]; -#*::foo = \5; -#*::foo = $bar; -#*::foo = { -# 'c' => [], -# 'a' => 1, -# 'b' => do{my $o}, -# 'd' => {} -#}; -#*::foo{HASH}->{'c'} = $bar; -#*::foo{HASH}->{'b'} = *::foo{SCALAR}; -#*::foo{HASH}->{'d'} = *::foo{HASH}; -#$bar->[2] = *::foo{HASH}; -#$baz = *::foo{HASH}; -#$foo = $bar->[1]; -EOT - - TEST q(Data::Dumper->Dump([\\@foo, \\%foo, \\*foo], ['bar', 'baz', 'foo'])); - TEST q(Data::Dumper->Dumpxs([\\@foo, \\%foo, \\*foo], ['bar', 'baz', 'foo'])) if $XS; - -############# 73 -## - $WANT = <<'EOT'; -#$foo = \*::foo; -#@bar = ( -# -10, -# $foo, -# { -# c => \@bar, -# a => 1, -# b => \5, -# d => $bar[2] -# } -#); -#%baz = %{$bar[2]}; -EOT - - $Data::Dumper::Purity = 0; - $Data::Dumper::Quotekeys = 0; - TEST q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])); - TEST q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])) if $XS; - -############# 79 -## - $WANT = <<'EOT'; -#$foo = \*::foo; -#$bar = [ -# -10, -# $foo, -# { -# c => $bar, -# a => 1, -# b => \5, -# d => $bar->[2] -# } -#]; -#$baz = $bar->[2]; -EOT - - TEST q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])); - TEST q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])) if $XS; - -} - -############# -############# -{ - package main; - @dogs = ( 'Fido', 'Wags' ); - %kennel = ( - First => \$dogs[0], - Second => \$dogs[1], - ); - $dogs[2] = \%kennel; - $mutts = \%kennel; - $mutts = $mutts; # avoid warning - -############# 85 -## - $WANT = <<'EOT'; -#%kennels = ( -# Second => \'Wags', -# First => \'Fido' -#); -#@dogs = ( -# ${$kennels{First}}, -# ${$kennels{Second}}, -# \%kennels -#); -#%mutts = %kennels; -EOT - - TEST q( - $d = Data::Dumper->new([\\%kennel, \\@dogs, $mutts], - [qw(*kennels *dogs *mutts)] ); - $d->Dump; - ); - if ($XS) { - TEST q( - $d = Data::Dumper->new([\\%kennel, \\@dogs, $mutts], - [qw(*kennels *dogs *mutts)] ); - $d->Dumpxs; - ); - } - -############# 91 -## - $WANT = <<'EOT'; -#%kennels = %kennels; -#@dogs = @dogs; -#%mutts = %kennels; -EOT - - TEST q($d->Dump); - TEST q($d->Dumpxs) if $XS; - -############# 97 -## - $WANT = <<'EOT'; -#%kennels = ( -# Second => \'Wags', -# First => \'Fido' -#); -#@dogs = ( -# ${$kennels{First}}, -# ${$kennels{Second}}, -# \%kennels -#); -#%mutts = %kennels; -EOT - - - TEST q($d->Reset; $d->Dump); - if ($XS) { - TEST q($d->Reset; $d->Dumpxs); - } - -############# 103 -## - $WANT = <<'EOT'; -#@dogs = ( -# 'Fido', -# 'Wags', -# { -# Second => \$dogs[1], -# First => \$dogs[0] -# } -#); -#%kennels = %{$dogs[2]}; -#%mutts = %{$dogs[2]}; -EOT - - TEST q( - $d = Data::Dumper->new([\\@dogs, \\%kennel, $mutts], - [qw(*dogs *kennels *mutts)] ); - $d->Dump; - ); - if ($XS) { - TEST q( - $d = Data::Dumper->new([\\@dogs, \\%kennel, $mutts], - [qw(*dogs *kennels *mutts)] ); - $d->Dumpxs; - ); - } - -############# 109 -## - TEST q($d->Reset->Dump); - if ($XS) { - TEST q($d->Reset->Dumpxs); - } - -############# 115 -## - $WANT = <<'EOT'; -#@dogs = ( -# 'Fido', -# 'Wags', -# { -# Second => \'Wags', -# First => \'Fido' -# } -#); -#%kennels = ( -# Second => \'Wags', -# First => \'Fido' -#); -EOT - - TEST q( - $d = Data::Dumper->new( [\@dogs, \%kennel], [qw(*dogs *kennels)] ); - $d->Deepcopy(1)->Dump; - ); - if ($XS) { - TEST q($d->Reset->Dumpxs); - } - -} - -{ - -sub z { print "foo\n" } -$c = [ \&z ]; - -############# 121 -## - $WANT = <<'EOT'; -#$a = $b; -#$c = [ -# $b -#]; -EOT - -TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'b' => \&z})->Dump;); -TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'b' => \&z})->Dumpxs;) - if $XS; - -############# 127 -## - $WANT = <<'EOT'; -#$a = \&b; -#$c = [ -# \&b -#]; -EOT - -TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'*b' => \&z})->Dump;); -TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'*b' => \&z})->Dumpxs;) - if $XS; - -############# 133 -## - $WANT = <<'EOT'; -#*a = \&b; -#@c = ( -# \&b -#); -EOT - -TEST q(Data::Dumper->new([\&z,$c],['*a','*c'])->Seen({'*b' => \&z})->Dump;); -TEST q(Data::Dumper->new([\&z,$c],['*a','*c'])->Seen({'*b' => \&z})->Dumpxs;) - if $XS; - -} - -{ - $a = []; - $a->[1] = \$a->[0]; - -############# 139 -## - $WANT = <<'EOT'; -#@a = ( -# undef, -# do{my $o} -#); -#$a[1] = \$a[0]; -EOT - -TEST q(Data::Dumper->new([$a],['*a'])->Purity(1)->Dump;); -TEST q(Data::Dumper->new([$a],['*a'])->Purity(1)->Dumpxs;) - if $XS; -} - -{ - $a = \\\\\'foo'; - $b = $$$a; - -############# 145 -## - $WANT = <<'EOT'; -#$a = \\\\\'foo'; -#$b = ${${$a}}; -EOT - -TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dump;); -TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dumpxs;) - if $XS; -} - -{ - $a = [{ a => \$b }, { b => undef }]; - $b = [{ c => \$b }, { d => \$a }]; - -############# 151 -## - $WANT = <<'EOT'; -#$a = [ -# { -# a => \[ -# { -# c => do{my $o} -# }, -# { -# d => \[] -# } -# ] -# }, -# { -# b => undef -# } -#]; -#${$a->[0]{a}}->[0]->{c} = $a->[0]{a}; -#${${$a->[0]{a}}->[1]->{d}} = $a; -#$b = ${$a->[0]{a}}; -EOT - -TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dump;); -TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dumpxs;) - if $XS; -} - -{ - $a = [[[[\\\\\'foo']]]]; - $b = $a->[0][0]; - $c = $${$b->[0][0]}; - -############# 157 -## - $WANT = <<'EOT'; -#$a = [ -# [ -# [ -# [ -# \\\\\'foo' -# ] -# ] -# ] -#]; -#$b = $a->[0][0]; -#$c = ${${$a->[0][0][0][0]}}; -EOT - -TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Purity(1)->Dump;); -TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Purity(1)->Dumpxs;) - if $XS; -} - -{ - $f = "pearl"; - $e = [ $f ]; - $d = { 'e' => $e }; - $c = [ $d ]; - $b = { 'c' => $c }; - $a = { 'b' => $b }; - -############# 163 -## - $WANT = <<'EOT'; -#$a = { -# b => { -# c => [ -# { -# e => 'ARRAY(0xdeadbeef)' -# } -# ] -# } -#}; -#$b = $a->{b}; -#$c = $a->{b}{c}; -EOT - -TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(4)->Dump;); -TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(4)->Dumpxs;) - if $XS; - -############# 169 -## - $WANT = <<'EOT'; -#$a = { -# b => 'HASH(0xdeadbeef)' -#}; -#$b = $a->{b}; -#$c = [ -# 'HASH(0xdeadbeef)' -#]; -EOT - -TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(1)->Dump;); -TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(1)->Dumpxs;) - if $XS; -} - -{ - $a = \$a; - $b = [$a]; - -############# 175 -## - $WANT = <<'EOT'; -#$b = [ -# \$b->[0] -#]; -EOT - -TEST q(Data::Dumper->new([$b],['b'])->Purity(0)->Dump;); -TEST q(Data::Dumper->new([$b],['b'])->Purity(0)->Dumpxs;) - if $XS; - -############# 181 -## - $WANT = <<'EOT'; -#$b = [ -# \do{my $o} -#]; -#${$b->[0]} = $b->[0]; -EOT - - -TEST q(Data::Dumper->new([$b],['b'])->Purity(1)->Dump;); -TEST q(Data::Dumper->new([$b],['b'])->Purity(1)->Dumpxs;) - if $XS; -} diff --git a/t/lib/encode.t b/t/lib/encode.t deleted file mode 100644 index ceeb422672..0000000000 --- a/t/lib/encode.t +++ /dev/null @@ -1,122 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\Encode\b/) { - print "1..0 # Skip: Encode was not built\n"; - exit 0; - } -} -use Test; -use Encode qw(from_to encode decode encode_utf8 decode_utf8 find_encoding); -use charnames qw(greek); -my @encodings = grep(/iso-?8859/,Encode::encodings()); -my $n = 2; -my @character_set = ('0'..'9', 'A'..'Z', 'a'..'z'); -my @source = qw(ascii iso8859-1 cp1250); -my @destiny = qw(cp1047 cp37 posix-bc); -my @ebcdic_sets = qw(cp1047 cp37 posix-bc); -plan test => 38+$n*@encodings + 2*@source*@destiny*@character_set + 2*@ebcdic_sets*256; -my $str = join('',map(chr($_),0x20..0x7E)); -my $cpy = $str; -ok(length($str),from_to($cpy,'iso8859-1','Unicode'),"Length Wrong"); -ok($cpy,$str,"ASCII mangled by translating from iso8859-1 to Unicode"); -$cpy = $str; -ok(from_to($cpy,'Unicode','iso8859-1'),length($str),"Length wrong"); -ok($cpy,$str,"ASCII mangled by translating from Unicode to iso8859-1"); - -$str = join('',map(chr($_),0xa0..0xff)); -$cpy = $str; -ok(length($str),from_to($cpy,'iso8859-1','Unicode'),"Length Wrong"); - -my $sym = Encode->getEncoding('symbol'); -my $uni = $sym->decode(encode(ascii => 'a')); -ok("\N{alpha}",substr($uni,0,1),"alpha does not map to symbol 'a'"); -$str = $sym->encode("\N{Beta}"); -ok("B",decode(ascii => substr($str,0,1)),"Symbol 'B' does not map to Beta"); - -foreach my $enc (qw(symbol dingbats ascii),@encodings) - { - my $tab = Encode->getEncoding($enc); - ok(1,defined($tab),"Could not load $enc"); - $str = join('',map(chr($_),0x20..0x7E)); - $uni = $tab->decode($str); - $cpy = $tab->encode($uni); - ok($cpy,$str,"$enc mangled translating to Unicode and back"); - } - -# On ASCII based machines see if we can map several codepoints from -# three distinct ASCII sets to three distinct EBCDIC coded character sets. -# On EBCDIC machines see if we can map from three EBCDIC sets to three -# distinct ASCII sets. - -my @expectation = (240..249, 193..201,209..217,226..233, 129..137,145..153,162..169); -if (ord('A') != 65) { - my @temp = @destiny; - @destiny = @source; - @source = @temp; - undef(@temp); - @expectation = (48..57, 65..90, 97..122); -} - -foreach my $to (@destiny) - { - foreach my $from (@source) - { - my @expected = @expectation; - foreach my $chr (@character_set) - { - my $native_chr = $chr; - my $cpy = $chr; - my $rc = from_to($cpy,$from,$to); - ok(1,$rc,"Could not translate from $from to $to"); - ok(ord($cpy),shift(@expected),"mangled translating $native_chr from $from to $to"); - } - } - } - -# On either ASCII or EBCDIC machines ensure we can take the full one -# byte repetoire to EBCDIC sets and back. - -my $enc_as = 'iso8859-1'; -foreach my $enc_eb (@ebcdic_sets) - { - foreach my $ord (0..255) - { - $str = chr($ord); - my $rc = from_to($str,$enc_as,$enc_eb); - $rc += from_to($str,$enc_eb,$enc_as); - ok($rc,2,"return code for $ord $enc_eb -> $enc_as -> $enc_eb was not obtained"); - ok($ord,ord($str),"$enc_as mangled translating $ord to $enc_eb and back"); - } - } - -my $mime = find_encoding('iso-8859-2'); -ok(defined($mime),1,"Cannot find MIME-ish'iso-8859-2'"); -my $x11 = find_encoding('iso8859-2'); -ok(defined($x11),1,"Cannot find X11-ish 'iso8859-2'"); -ok($mime,$x11,"iso8598-2 and iso-8859-2 not same"); -my $spc = find_encoding('iso 8859-2'); -ok(defined($spc),1,"Cannot find 'iso 8859-2'"); -ok($spc,$mime,"iso 8859-2 and iso-8859-2 not same"); - -for my $i (256,128,129,256) - { - my $c = chr($i); - my $s = "$c\n".sprintf("%02X",$i); - ok(utf8::valid($s),1,"concat of $i botched"); - utf8::upgrade($s); - ok(utf8::valid($s),1,"concat of $i botched"); - } - -# Spot check a few points in/out of utf8 -for my $i (0x41,128,256,0x20AC) - { - my $c = chr($i); - my $o = encode_utf8($c); - ok(decode_utf8($o),$c,"decode_utf8 not inverse of encode_utf8 for $i"); - ok(encode('utf8',$c),$o,"utf8 encode by name broken for $i"); - ok(decode('utf8',$o),$c,"utf8 decode by name broken for $i"); - } - - diff --git a/t/lib/english.t b/t/lib/english.t deleted file mode 100755 index 459dc3b539..0000000000 --- a/t/lib/english.t +++ /dev/null @@ -1,65 +0,0 @@ -#!./perl - -print "1..22\n"; - -BEGIN { @INC = '../lib' } -use English qw( -no_match_vars ) ; -use Config; -my $threads = $Config{'use5005threads'} || 0; - -print $PID == $$ ? "ok 1\n" : "not ok 1\n"; - -$_ = 1; -print $ARG == $_ || $threads ? "ok 2\n" : "not ok 2\n"; - -sub foo { - print $ARG[0] == $_[0] || $threads ? "ok 3\n" : "not ok 3\n"; -} -&foo(1); - -"abc" =~ /b/; - -print ! $PREMATCH ? "" : "not ", "ok 4\n" ; -print ! $MATCH ? "" : "not ", "ok 5\n" ; -print ! $POSTMATCH ? "" : "not ", "ok 6\n" ; - -$OFS = " "; -$ORS = "\n"; -print 'ok',7; -undef $OUTPUT_FIELD_SEPARATOR; - -if ($threads) { $" = "\n" } else { $LIST_SEPARATOR = "\n" }; -@foo = ("ok 8", "ok 9"); -print "@foo"; -undef $OUTPUT_RECORD_SEPARATOR; - -eval 'NO SUCH FUNCTION'; -print "ok 10\n" if $EVAL_ERROR =~ /method/ || $threads; - -print $UID == $< ? "ok 11\n" : "not ok 11\n"; -print $GID == $( ? "ok 12\n" : "not ok 12\n"; -print $EUID == $> ? "ok 13\n" : "not ok 13\n"; -print $EGID == $) ? "ok 14\n" : "not ok 14\n"; - -print $PROGRAM_NAME eq $0 ? "ok 15\n" : "not ok 15\n"; -print $BASETIME == $^T ? "ok 16\n" : "not ok 16\n"; - -package B ; - -use English ; - -"abc" =~ /b/; - -print $PREMATCH ? "" : "not ", "ok 17\n" ; -print $MATCH ? "" : "not ", "ok 18\n" ; -print $POSTMATCH ? "" : "not ", "ok 19\n" ; - -package C ; - -use English qw( -no_match_vars ) ; - -"abc" =~ /b/; - -print ! $PREMATCH ? "" : "not ", "ok 20\n" ; -print ! $MATCH ? "" : "not ", "ok 21\n" ; -print ! $POSTMATCH ? "" : "not ", "ok 22\n" ; diff --git a/t/lib/env-array.t b/t/lib/env-array.t deleted file mode 100755 index c5068fda14..0000000000 --- a/t/lib/env-array.t +++ /dev/null @@ -1,100 +0,0 @@ -#!./perl - -$| = 1; - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -if ($^O eq 'VMS') { - print "1..11\n"; - foreach (1..11) { print "ok $_ # skipped for VMS\n"; } - exit 0; -} - -use Env qw(@FOO); -use vars qw(@BAR); - -sub array_equal -{ - my ($a, $b) = @_; - return 0 unless scalar(@$a) == scalar(@$b); - for my $i (0..scalar(@$a) - 1) { - return 0 unless $a->[$i] eq $b->[$i]; - } - return 1; -} - -sub test -{ - my ($desc, $code) = @_; - - &$code; - - print "# $desc...\n"; - print "# FOO = (", join(", ", @FOO), ")\n"; - print "# BAR = (", join(", ", @BAR), ")\n"; - - if (defined $check) { print "not " unless &$check; } - else { print "not " unless array_equal(\@FOO, \@BAR); } - - print "ok ", ++$i, "\n"; -} - -print "1..11\n"; - -test "Assignment", sub { - @FOO = qw(a B c); - @BAR = qw(a B c); -}; - -test "Storing", sub { - $FOO[1] = 'b'; - $BAR[1] = 'b'; -}; - -test "Truncation", sub { - $#FOO = 0; - $#BAR = 0; -}; - -test "Push", sub { - push @FOO, 'b', 'c'; - push @BAR, 'b', 'c'; -}; - -test "Pop", sub { - pop @FOO; - pop @BAR; -}; - -test "Shift", sub { - shift @FOO; - shift @BAR; -}; - -test "Push", sub { - push @FOO, 'c'; - push @BAR, 'c'; -}; - -test "Unshift", sub { - unshift @FOO, 'a'; - unshift @BAR, 'a'; -}; - -test "Reverse", sub { - @FOO = reverse @FOO; - @BAR = reverse @BAR; -}; - -test "Sort", sub { - @FOO = sort @FOO; - @BAR = sort @BAR; -}; - -test "Splice", sub { - splice @FOO, 1, 1, 'B'; - splice @BAR, 1, 1, 'B'; -}; diff --git a/t/lib/env.t b/t/lib/env.t deleted file mode 100755 index ff6af2edb8..0000000000 --- a/t/lib/env.t +++ /dev/null @@ -1,25 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -BEGIN { - $ENV{FOO} = "foo"; - $ENV{BAR} = "bar"; -} - -use Env qw(FOO $BAR); - -$FOO .= "/bar"; -$BAR .= "/baz"; - -print "1..2\n"; - -print "not " if $FOO ne 'foo/bar'; -print "ok 1\n"; - -print "not " if $BAR ne 'bar/baz'; -print "ok 2\n"; - diff --git a/t/lib/errno.t b/t/lib/errno.t deleted file mode 100755 index 02f5ce2ca6..0000000000 --- a/t/lib/errno.t +++ /dev/null @@ -1,54 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - if ($^O eq 'MacOS') { - @INC = qw(: ::lib ::macos:lib); - } else { - @INC = '../lib'; - } - } -} - -use Errno; - -print "1..5\n"; - -print "not " unless @Errno::EXPORT_OK; -print "ok 1\n"; -die unless @Errno::EXPORT_OK; - -$err = $Errno::EXPORT_OK[0]; -$num = &{"Errno::$err"}; - -print "not " unless &{"Errno::$err"} == $num; -print "ok 2\n"; - -$! = $num; -print "not " unless $!{$err}; -print "ok 3\n"; - -$! = 0; -print "not " if $!{$err}; -print "ok 4\n"; - -$s1 = join(",",sort keys(%!)); -$s2 = join(",",sort @Errno::EXPORT_OK); - -if($s1 ne $s2) { - my @s1 = keys(%!); - my @s2 = @Errno::EXPORT_OK; - my(%s1,%s2); - @s1{@s1} = (); - @s2{@s2} = (); - delete @s2{@s1}; - delete @s1{@s2}; - print "# These are only in \%!\n"; - print "# ",join(" ",map { "'$_'" } keys %s1),"\n"; - print "# These are only in \@EXPORT_OK\n"; - print "# ",join(" ",map { "'$_'" } keys %s2),"\n"; - print "not "; -} - -print "ok 5\n"; diff --git a/t/lib/exporter.t b/t/lib/exporter.t deleted file mode 100644 index a0028feb23..0000000000 --- a/t/lib/exporter.t +++ /dev/null @@ -1,145 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -# Utility testing functions. -my $test_num = 1; -sub ok ($;$) { - my($test, $name) = @_; - print "not " unless $test; - print "ok $test_num"; - print " - $name" if (defined $name && ! $^O eq 'VMS'); - print "\n"; - $test_num++; -} - - -my $loaded; -BEGIN { $| = 1; $^W = 1; } -END {print "not ok $test_num\n" unless $loaded;} -print "1..$Total_tests\n"; -use Exporter; -$loaded = 1; -ok(1, 'compile'); - - -BEGIN { - # Methods which Exporter says it implements. - @Exporter_Methods = qw(import - export_to_level - require_version - export_fail - ); -} - -BEGIN { $Total_tests = 14 + @Exporter_Methods } - -package Testing; -require Exporter; -@ISA = qw(Exporter); - -# Make sure Testing can do everything its supposed to. -foreach my $meth (@::Exporter_Methods) { - ::ok( Testing->can($meth), "subclass can $meth()" ); -} - -%EXPORT_TAGS = ( - This => [qw(stuff %left)], - That => [qw(Above the @wailing)], - tray => [qw(Fasten $seatbelt)], - ); -@EXPORT = qw(lifejacket); -@EXPORT_OK = qw(under &your $seat); -$VERSION = '1.05'; - -::ok( Testing->require_version(1.05), 'require_version()' ); -eval { Testing->require_version(1.11); 1 }; -::ok( $@, 'require_version() fail' ); -::ok( Testing->require_version(0), 'require_version(0)' ); - -sub lifejacket { 'lifejacket' } -sub stuff { 'stuff' } -sub Above { 'Above' } -sub the { 'the' } -sub Fasten { 'Fasten' } -sub your { 'your' } -sub under { 'under' } -use vars qw($seatbelt $seat @wailing %left); -$seatbelt = 'seatbelt'; -$seat = 'seat'; -@wailing = qw(AHHHHHH); -%left = ( left => "right" ); - - -Exporter::export_ok_tags; - -my %tags = map { $_ => 1 } map { @$_ } values %EXPORT_TAGS; -my %exportok = map { $_ => 1 } @EXPORT_OK; -my $ok = 1; -foreach my $tag (keys %tags) { - $ok = exists $exportok{$tag}; -} -::ok( $ok, 'export_ok_tags()' ); - - -package Foo; -Testing->import; - -::ok( defined &lifejacket, 'simple import' ); - - -package Bar; -my @imports = qw($seatbelt &Above stuff @wailing %left); -Testing->import(@imports); - -::ok( (!grep { eval "!defined $_" } map({ /^\w/ ? "&$_" : $_ } @imports)), - 'import by symbols' ); - - -package Yar; -my @tags = qw(:This :tray); -Testing->import(@tags); - -::ok( (!grep { eval "!defined $_" } map { /^\w/ ? "&$_" : $_ } - map { @$_ } @{$Testing::EXPORT_TAGS{@tags}}), - 'import by tags' ); - - -package Arrr; -Testing->import(qw(!lifejacket)); - -::ok( !defined &lifejacket, 'deny import by !' ); - - -package Mars; -Testing->import('/e/'); - -::ok( (!grep { eval "!defined $_" } map { /^\w/ ? "&$_" : $_ } - grep { /e/ } @Testing::EXPORT, @Testing::EXPORT_OK), - 'import by regex'); - - -package Venus; -Testing->import('!/e/'); - -::ok( (!grep { eval "defined $_" } map { /^\w/ ? "&$_" : $_ } - grep { /e/ } @Testing::EXPORT, @Testing::EXPORT_OK), - 'deny import by regex'); -::ok( !defined &lifejacket, 'further denial' ); - - -package More::Testing; -@ISA = qw(Exporter); -$VERSION = 0; -eval { More::Testing->require_version(0); 1 }; -::ok(!$@, 'require_version(0) and $VERSION = 0'); - - -package Yet::More::Testing; -@ISA = qw(Exporter); -$VERSION = 0; -eval { Yet::More::Testing->require_version(10); 1 }; -::ok($@ !~ /\(undef\)/, 'require_version(10) and $VERSION = 0'); diff --git a/t/lib/extutils.t b/t/lib/extutils.t deleted file mode 100644 index 50a9fe44f0..0000000000 --- a/t/lib/extutils.t +++ /dev/null @@ -1,483 +0,0 @@ -#!./perl -w - -print "1..27\n"; - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use warnings; -use strict; -use ExtUtils::MakeMaker; -use ExtUtils::Constant qw (constant_types C_constant XS_constant autoload); -use Config; -use File::Spec::Functions; -use File::Spec; -# Because were are going to be changing directory before running Makefile.PL -my $perl = File::Spec->rel2abs( $^X ); -# ExtUtils::Constant::C_constant uses $^X inside a comment, and we want to -# compare output to ensure that it is the same. We were probably run as ./perl -# whereas we will run the child with the full path in $perl. So make $^X for -# us the same as our child will see. -$^X = $perl; - -print "# perl=$perl\n"; -my $runperl = "$perl -x \"-I../../lib\""; - -$| = 1; - -my $dir = "ext-$$"; -my @files; - -print "# $dir being created...\n"; -mkdir $dir, 0777 or die "mkdir: $!\n"; - - -END { - use File::Path; - print "# $dir being removed...\n"; - rmtree($dir); -} - -my $package = "ExtTest"; - -# Test the code that generates 1 and 2 letter name comparisons. -my %compass = ( -N => 0, NE => 45, E => 90, SE => 135, S => 180, SW => 225, W => 270, NW => 315 -); - -my $parent_rfc1149 = - 'A Standard for the Transmission of IP Datagrams on Avian Carriers'; - -my @names = ("FIVE", {name=>"OK6", type=>"PV",}, - {name=>"OK7", type=>"PVN", - value=>['"not ok 7\\n\\0ok 7\\n"', 15]}, - {name => "FARTHING", type=>"NV"}, - {name => "NOT_ZERO", type=>"UV", value=>"~(UV)0"}, - {name => "OPEN", type=>"PV", value=>'"/*"', macro=>1}, - {name => "CLOSE", type=>"PV", value=>'"*/"', - macro=>["#if 1\n", "#endif\n"]}, - {name => "ANSWER", default=>["UV", 42]}, "NOTDEF", - {name => "Yes", type=>"YES"}, - {name => "No", type=>"NO"}, - {name => "Undef", type=>"UNDEF"}, -# OK. It wasn't really designed to allow the creation of dual valued constants. -# It was more for INADDR_ANY INADDR_BROADCAST INADDR_LOOPBACK INADDR_NONE - {name=>"RFC1149", type=>"SV", value=>"sv_2mortal(temp_sv)", - pre=>"SV *temp_sv = newSVpv(RFC1149, 0); " - . "(void) SvUPGRADE(temp_sv,SVt_PVIV); SvIOK_on(temp_sv); " - . "SvIVX(temp_sv) = 1149;"}, -); - -push @names, $_ foreach keys %compass; - -my @names_only = map {(ref $_) ? $_->{name} : $_} @names; - -my $types = {}; -my $constant_types = constant_types(); # macro defs -my $C_constant = join "\n", - C_constant ($package, undef, "IV", $types, undef, undef, @names); -my $XS_constant = XS_constant ($package, $types); # XS for ExtTest::constant - -################ Header -my $header = catfile($dir, "test.h"); -push @files, "test.h"; -open FH, ">$header" or die "open >$header: $!\n"; -print FH <<"EOT"; -#define FIVE 5 -#define OK6 "ok 6\\n" -#define OK7 1 -#define FARTHING 0.25 -#define NOT_ZERO 1 -#define Yes 0 -#define No 1 -#define Undef 1 -#define RFC1149 "$parent_rfc1149" -#undef NOTDEF - -EOT - -while (my ($point, $bearing) = each %compass) { - print FH "#define $point $bearing\n" -} -close FH or die "close $header: $!\n"; - -################ XS -my $xs = catfile($dir, "$package.xs"); -push @files, "$package.xs"; -open FH, ">$xs" or die "open >$xs: $!\n"; - -print FH <<'EOT'; -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" -EOT - -print FH "#include \"test.h\"\n\n"; -print FH $constant_types; -print FH $C_constant, "\n"; -print FH "MODULE = $package PACKAGE = $package\n"; -print FH "PROTOTYPES: ENABLE\n"; -print FH $XS_constant; -close FH or die "close $xs: $!\n"; - -################ PM -my $pm = catfile($dir, "$package.pm"); -push @files, "$package.pm"; -open FH, ">$pm" or die "open >$pm: $!\n"; -print FH "package $package;\n"; -print FH "use $];\n"; - -print FH <<'EOT'; - -use strict; -use warnings; -use Carp; - -require Exporter; -require DynaLoader; -use vars qw ($VERSION @ISA @EXPORT_OK); - -$VERSION = '0.01'; -@ISA = qw(Exporter DynaLoader); -@EXPORT_OK = qw( -EOT - -print FH "\t$_\n" foreach (@names_only); -print FH ");\n"; -print FH autoload ($package, $]); -print FH "bootstrap $package \$VERSION;\n1;\n__END__\n"; -close FH or die "close $pm: $!\n"; - -################ test.pl -my $testpl = catfile($dir, "test.pl"); -push @files, "test.pl"; -open FH, ">$testpl" or die "open >$testpl: $!\n"; - -print FH "use strict;\n"; -print FH "use $package qw(@names_only);\n"; -print FH <<'EOT'; - -# IV -my $five = FIVE; -if ($five == 5) { - print "ok 5\n"; -} else { - print "not ok 5 # $five\n"; -} - -# PV -print OK6; - -# PVN containing embedded \0s -$_ = OK7; -s/.*\0//s; -print; - -# NV -my $farthing = FARTHING; -if ($farthing == 0.25) { - print "ok 8\n"; -} else { - print "not ok 8 # $farthing\n"; -} - -# UV -my $not_zero = NOT_ZERO; -if ($not_zero > 0 && $not_zero == ~0) { - print "ok 9\n"; -} else { - print "not ok 9 # \$not_zero=$not_zero ~0=" . (~0) . "\n"; -} - -# Value includes a "*/" in an attempt to bust out of a C comment. -# Also tests custom cpp #if clauses -my $close = CLOSE; -if ($close eq '*/') { - print "ok 10\n"; -} else { - print "not ok 10 # \$close='$close'\n"; -} - -# Default values if macro not defined. -my $answer = ANSWER; -if ($answer == 42) { - print "ok 11\n"; -} else { - print "not ok 11 # What do you get if you multiply six by nine? '$answer'\n"; -} - -# not defined macro -my $notdef = eval { NOTDEF; }; -if (defined $notdef) { - print "not ok 12 # \$notdef='$notdef'\n"; -} elsif ($@ !~ /Your vendor has not defined ExtTest macro NOTDEF/) { - print "not ok 12 # \$@='$@'\n"; -} else { - print "ok 12\n"; -} - -# not a macro -my $notthere = eval { &ExtTest::NOTTHERE; }; -if (defined $notthere) { - print "not ok 13 # \$notthere='$notthere'\n"; -} elsif ($@ !~ /NOTTHERE is not a valid ExtTest macro/) { - chomp $@; - print "not ok 13 # \$@='$@'\n"; -} else { - print "ok 13\n"; -} - -# Truth -my $yes = Yes; -if ($yes) { - print "ok 14\n"; -} else { - print "not ok 14 # $yes='\$yes'\n"; -} - -# Falsehood -my $no = No; -if (defined $no and !$no) { - print "ok 15\n"; -} else { - print "not ok 15 # \$no=" . defined ($no) ? "'$no'\n" : "undef\n"; -} - -# Undef -my $undef = Undef; -unless (defined $undef) { - print "ok 16\n"; -} else { - print "not ok 16 # \$undef='$undef'\n"; -} - - -# invalid macro (chosen to look like a mix up between No and SW) -$notdef = eval { &ExtTest::So }; -if (defined $notdef) { - print "not ok 17 # \$notdef='$notdef'\n"; -} elsif ($@ !~ /^So is not a valid ExtTest macro/) { - print "not ok 17 # \$@='$@'\n"; -} else { - print "ok 17\n"; -} - -# invalid defined macro -$notdef = eval { &ExtTest::EW }; -if (defined $notdef) { - print "not ok 18 # \$notdef='$notdef'\n"; -} elsif ($@ !~ /^EW is not a valid ExtTest macro/) { - print "not ok 18 # \$@='$@'\n"; -} else { - print "ok 18\n"; -} - -my %compass = ( -EOT - -while (my ($point, $bearing) = each %compass) { - print FH "$point => $bearing, " -} - -print FH <<'EOT'; - -); - -my $fail; -while (my ($point, $bearing) = each %compass) { - my $val = eval $point; - if ($@) { - print "# $point: \$@='$@'\n"; - $fail = 1; - } elsif (!defined $bearing) { - print "# $point: \$val=undef\n"; - $fail = 1; - } elsif ($val != $bearing) { - print "# $point: \$val=$val, not $bearing\n"; - $fail = 1; - } -} -if ($fail) { - print "not ok 19\n"; -} else { - print "ok 19\n"; -} - -EOT - -print FH <<"EOT"; -my \$rfc1149 = RFC1149; -if (\$rfc1149 ne "$parent_rfc1149") { - print "not ok 20 # '\$rfc1149' ne '$parent_rfc1149'\n"; -} else { - print "ok 20\n"; -} - -if (\$rfc1149 != 1149) { - printf "not ok 21 # %d != 1149\n", \$rfc1149; -} else { - print "ok 21\n"; -} - -EOT - -print FH <<'EOT'; -# test macro=>1 -my $open = OPEN; -if ($open eq '/*') { - print "ok 22\n"; -} else { - print "not ok 22 # \$open='$open'\n"; -} -EOT -close FH or die "close $testpl: $!\n"; - -################ Makefile.PL -# We really need a Makefile.PL because make test for a no dynamic linking perl -# will run Makefile.PL again as part of the "make perl" target. -my $makefilePL = catfile($dir, "Makefile.PL"); -push @files, "Makefile.PL"; -open FH, ">$makefilePL" or die "open >$makefilePL: $!\n"; -print FH <<"EOT"; -#!$perl -w -use ExtUtils::MakeMaker; -WriteMakefile( - 'NAME' => "$package", - 'VERSION_FROM' => "$package.pm", # finds \$VERSION - (\$] >= 5.005 ? - (#ABSTRACT_FROM => "$package.pm", # XXX add this - AUTHOR => "$0") : ()) - ); -EOT - -close FH or die "close $makefilePL: $!\n"; - -chdir $dir or die $!; push @INC, '../../lib'; -END {chdir ".." or warn $!}; - -my @perlout = `$runperl Makefile.PL`; -if ($?) { - print "not ok 1 # $runperl Makefile.PL failed: $?\n"; - print "# $_" foreach @perlout; - exit($?); -} else { - print "ok 1\n"; -} - - -my $makefile = ($^O eq 'VMS' ? 'descrip' : 'Makefile'); -my $makefile_ext = ($^O eq 'VMS' ? '.mms' : ''); -if (-f "$makefile$makefile_ext") { - print "ok 2\n"; -} else { - print "not ok 2\n"; -} -my $makefile_rename = ($^O eq 'VMS' ? '.mms' : '.old'); -push @files, "$makefile$makefile_rename"; # Renamed by make clean - -my $make = $Config{make}; - -$make = $ENV{MAKE} if exists $ENV{MAKE}; - -my $makeout; - -print "# make = '$make'\n"; -$makeout = `$make`; -if ($?) { - print "not ok 3 # $make failed: $?\n"; - exit($?); -} else { - print "ok 3\n"; -} - -if ($Config{usedl}) { - print "ok 4\n"; -} else { - push @files, "perl$Config{exe_ext}"; - my $makeperl = "$make perl"; - print "# make = '$makeperl'\n"; - $makeout = `$makeperl`; - if ($?) { - print "not ok 4 # $makeperl failed: $?\n"; - exit($?); - } else { - print "ok 4\n"; - } -} - -my $test = 23; -my $maketest = "$make test"; -print "# make = '$maketest'\n"; -$makeout = `$maketest`; - -# echo of running the test script -$makeout =~ s/^\s*PERL_DL_NONLAZY=.+?\n//m; -$makeout =~ s/^MCR.+test.pl\n//mig if $^O eq 'VMS'; - -# GNU make babblings -$makeout =~ s/^\w*?make.+?(?:entering|leaving) directory.+?\n//mig; - -# Hopefully gets most make's babblings -# make -f Makefile.aperl perl -$makeout =~ s/^\w*?make.+\sperl[^A-Za-z0-9]*\n//mig; -# make[1]: `perl' is up to date. -$makeout =~ s/^\w*?make.+perl.+?is up to date.*?\n//mig; - -print $makeout; - -if ($?) { - print "not ok $test # $maketest failed: $?\n"; -} else { - print "ok $test\n"; -} -$test++; - -my $regen = `$runperl $package.xs`; -if ($?) { - print "not ok $test # $runperl $package.xs failed: $?\n"; -} else { - print "ok $test\n"; -} -$test++; - -my $expect = $constant_types . $C_constant . - "\n#### XS Section:\n" . $XS_constant; - -if ($expect eq $regen) { - print "ok $test\n"; -} else { - print "not ok $test\n"; - # open FOO, ">expect"; print FOO $expect; - # open FOO, ">regen"; print FOO $regen; close FOO; -} -$test++; - -my $makeclean = "$make clean"; -print "# make = '$makeclean'\n"; -$makeout = `$makeclean`; -if ($?) { - print "not ok $test # $make failed: $?\n"; -} else { - print "ok $test\n"; -} -$test++; - -foreach (@files) { - unlink $_ or warn "unlink $_: $!"; -} - -my $fail; -opendir DIR, "." or die "opendir '.': $!"; -while (defined (my $entry = readdir DIR)) { - next if $entry =~ /^\.\.?$/; - print "# Extra file '$entry'\n"; - $fail = 1; -} -closedir DIR or warn "closedir '.': $!"; -if ($fail) { - print "not ok $test\n"; -} else { - print "ok $test\n"; -} diff --git a/t/lib/fatal.t b/t/lib/fatal.t deleted file mode 100755 index f00b8766e8..0000000000 --- a/t/lib/fatal.t +++ /dev/null @@ -1,36 +0,0 @@ -#!./perl -w - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - print "1..15\n"; -} - -use strict; -use Fatal qw(open close :void opendir); - -my $i = 1; -eval { open FOO, '<lkjqweriuapofukndajsdlfjnvcvn' }; -print "not " unless $@ =~ /^Can't open/; -print "ok $i\n"; ++$i; - -my $foo = 'FOO'; -for ('$foo', "'$foo'", "*$foo", "\\*$foo") { - eval qq{ open $_, '<$0' }; - print "not " if $@; - print "ok $i\n"; ++$i; - - print "not " if $@ or scalar(<$foo>) !~ m|^#!./perl|; - print "ok $i\n"; ++$i; - eval qq{ close FOO }; - print "not " if $@; - print "ok $i\n"; ++$i; -} - -eval { opendir FOO, 'lkjqweriuapofukndajsdlfjnvcvn' }; -print "not " unless $@ =~ /^Can't open/; -print "ok $i\n"; ++$i; - -eval { my $a = opendir FOO, 'lkjqweriuapofukndajsdlfjnvcvn' }; -print "not " if $@ =~ /^Can't open/; -print "ok $i\n"; ++$i; diff --git a/t/lib/fcntl.t b/t/lib/fcntl.t deleted file mode 100644 index 24ade27c92..0000000000 --- a/t/lib/fcntl.t +++ /dev/null @@ -1,46 +0,0 @@ -#!./perl - -# A modest test: exercises only O_WRONLY, O_CREAT, and O_RDONLY. -# Have to be modest to be portable: could possibly extend testing -# also to O_RDWR and O_APPEND, but dunno about the portability of, -# say, O_TRUNC and O_EXCL, not to mention O_NONBLOCK. - -use Fcntl; - -print "1..6\n"; - -print "ok 1\n"; - -if (sysopen(my $wo, "fcntl$$", O_WRONLY|O_CREAT)) { - print "ok 2\n"; - if (syswrite($wo, "foo") == 3) { - print "ok 3\n"; - close($wo); - if (sysopen(my $ro, "fcntl$$", O_RDONLY)) { - print "ok 4\n"; - if (sysread($ro, my $read, 3)) { - print "ok 5\n"; - if ($read eq "foo") { - print "ok 6\n"; - } else { - print "not ok 6 # content '$read' not ok\n"; - } - } else { - print "not ok 5 # sysread failed: $!\n"; - } - } else { - print "not ok 4 # sysopen O_RDONLY failed: $!\n"; - } - close($ro); - } else { - print "not ok 3 # syswrite failed: $!\n"; - } - close($wo); -} else { - print "not ok 2 # sysopen O_WRONLY failed: $!\n"; -} - -END { - 1 while unlink "fcntl$$"; -} - diff --git a/t/lib/fields.t b/t/lib/fields.t deleted file mode 100755 index b4b5cce4ca..0000000000 --- a/t/lib/fields.t +++ /dev/null @@ -1,197 +0,0 @@ -#!./perl -w - -my $w; - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - $SIG{__WARN__} = sub { - if ($_[0] =~ /^Hides field 'b1' in base class/) { - $w++; - return; - } - print $_[0]; - }; -} - -use strict; -use warnings; -use vars qw($DEBUG); - -package B1; -use fields qw(b1 b2 b3); - -package B2; -use fields '_b1'; -use fields qw(b1 _b2 b2); - -sub new { bless [], shift } - -package D1; -use base 'B1'; -use fields qw(d1 d2 d3); - -package D2; -use base 'B1'; -use fields qw(_d1 _d2); -use fields qw(d1 d2); - -package D3; -use base 'B2'; -use fields qw(b1 d1 _b1 _d1); # hide b1 - -package D4; -use base 'D3'; -use fields qw(_d3 d3); - -package M; -sub m {} - -package D5; -use base qw(M B2); - -package Foo::Bar; -use base 'B1'; - -package Foo::Bar::Baz; -use base 'Foo::Bar'; -use fields qw(foo bar baz); - -# Test repeatability for when modules get reloaded. -package B1; -use fields qw(b1 b2 b3); - -package D3; -use base 'B2'; -use fields qw(b1 d1 _b1 _d1); # hide b1 - -package main; - -sub fstr { - my $h = shift; - my @tmp; - for my $k (sort {$h->{$a} <=> $h->{$b}} keys %$h) { - my $v = $h->{$k}; - push(@tmp, "$k:$v"); - } - my $str = join(",", @tmp); - print "$h => $str\n" if $DEBUG; - $str; -} - -my %expect = ( - B1 => "b1:1,b2:2,b3:3", - B2 => "_b1:1,b1:2,_b2:3,b2:4", - D1 => "b1:1,b2:2,b3:3,d1:4,d2:5,d3:6", - D2 => "b1:1,b2:2,b3:3,_d1:4,_d2:5,d1:6,d2:7", - D3 => "b2:4,b1:5,d1:6,_b1:7,_d1:8", - D4 => "b2:4,b1:5,d1:6,_d3:9,d3:10", - D5 => "b1:2,b2:4", - 'Foo::Bar::Baz' => 'b1:1,b2:2,b3:3,foo:4,bar:5,baz:6', -); - -print "1..", int(keys %expect)+15, "\n"; -my $testno = 0; -while (my($class, $exp) = each %expect) { - no strict 'refs'; - my $fstr = fstr(\%{$class."::FIELDS"}); - print "EXP: $exp\nGOT: $fstr\nnot " unless $fstr eq $exp; - print "ok ", ++$testno, "\n"; -} - -# Did we get the appropriate amount of warnings? -print "not " unless $w == 1; -print "ok ", ++$testno, "\n"; - -# A simple object creation and AVHV attribute access test -my B2 $obj1 = D3->new; -$obj1->{b1} = "B2"; -my D3 $obj2 = $obj1; -$obj2->{b1} = "D3"; - -print "not " unless $obj1->[2] eq "B2" && $obj1->[5] eq "D3"; -print "ok ", ++$testno, "\n"; - -# We should get compile time failures field name typos -eval q(my D3 $obj3 = $obj2; $obj3->{notthere} = ""); -print "not " unless $@ && $@ =~ /^No such pseudo-hash field "notthere"/; -print "ok ", ++$testno, "\n"; - -# Slices -@$obj1{"_b1", "b1"} = (17, 29); -print "not " unless "@$obj1[1,2]" eq "17 29"; -print "ok ", ++$testno, "\n"; -@$obj1[1,2] = (44,28); -print "not " unless "@$obj1{'b1','_b1','b1'}" eq "28 44 28"; -print "ok ", ++$testno, "\n"; - -my $ph = fields::phash(a => 1, b => 2, c => 3); -print "not " unless fstr($ph) eq 'a:1,b:2,c:3'; -print "ok ", ++$testno, "\n"; - -$ph = fields::phash([qw/a b c/], [1, 2, 3]); -print "not " unless fstr($ph) eq 'a:1,b:2,c:3'; -print "ok ", ++$testno, "\n"; - -$ph = fields::phash([qw/a b c/], [1]); -print "not " if exists $ph->{b} or exists $ph->{c} or !exists $ph->{a}; -print "ok ", ++$testno, "\n"; - -eval '$ph = fields::phash("odd")'; -print "not " unless $@ && $@ =~ /^Odd number of/; -print "ok ", ++$testno, "\n"; - -#fields::_dump(); - -# check if fields autovivify -{ - package Foo; - use fields qw(foo bar); - sub new { bless [], $_[0]; } - - package main; - my Foo $a = Foo->new(); - $a->{foo} = ['a', 'ok ' . ++$testno, 'c']; - $a->{bar} = { A => 'ok ' . ++$testno }; - print $a->{foo}[1], "\n"; - print $a->{bar}->{A}, "\n"; -} - -# check if fields autovivify -{ - package Bar; - use fields qw(foo bar); - sub new { return fields::new($_[0]) } - - package main; - my Bar $a = Bar::->new(); - $a->{foo} = ['a', 'ok ' . ++$testno, 'c']; - $a->{bar} = { A => 'ok ' . ++$testno }; - print $a->{foo}[1], "\n"; - print $a->{bar}->{A}, "\n"; -} - - -# Test $VERSION bug -package No::Version; - -use vars qw($Foo); -sub VERSION { 42 } - -package Test::Version; - -use base qw(No::Version); -print "not " unless $No::Version::VERSION =~ /set by base\.pm/; -print "ok ", ++$testno ,"\n"; - -# Test Inverse of $VERSION bug base.pm should not clobber existing $VERSION -package Has::Version; - -BEGIN { $Has::Version::VERSION = '42' }; - -package Test::Version2; - -use base qw(Has::Version); -print "#$Has::Version::VERSION\nnot " unless $Has::Version::VERSION eq '42'; -print "ok ", ++$testno ,"\n"; - diff --git a/t/lib/filecache.t b/t/lib/filecache.t deleted file mode 100755 index a97fdd532c..0000000000 --- a/t/lib/filecache.t +++ /dev/null @@ -1,25 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..1\n"; - -use FileCache; - -# This is really not a complete test as I don't bother to open enough -# files to make real swapping of open filedescriptor happen. - -$path = "foo"; -cacheout $path; - -print $path "\n"; - -close $path; - -print "not " unless -f $path; -print "ok 1\n"; - -unlink $path; diff --git a/t/lib/filecomp.t b/t/lib/filecomp.t deleted file mode 100644 index aedc32323e..0000000000 --- a/t/lib/filecomp.t +++ /dev/null @@ -1,114 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -BEGIN { - our @TEST = stat "TEST"; - our @README = stat "README"; - unless (@TEST && @README) { - print "1..0 # Skip: no file TEST or README\n"; - exit 0; - } -} - -print "1..12\n"; - -use File::Compare qw(compare compare_text); - -print "ok 1\n"; - -# named files, same, existing but different, cause an error -print "not " unless compare("README","README") == 0; -print "ok 2\n"; - -print "not " unless compare("TEST","README") == 1; -print "ok 3\n"; - -print "not " unless compare("README","HLAGHLAG") == -1; - # a file which doesn't exist -print "ok 4\n"; - -# compare_text, the same file, different but existing files -# cause error, test sub form. -print "not " unless compare_text("README","README") == 0; -print "ok 5\n"; - -print "not " unless compare_text("TEST","README") == 1; -print "ok 6\n"; - -print "not " unless compare_text("TEST","HLAGHLAG") == -1; -print "ok 7\n"; - -print "not " unless - compare_text("README","README",sub {$_[0] ne $_[1]}) == 0; -print "ok 8\n"; - -# filehandle and same file -{ - my $fh; - open ($fh, "<README") or print "not "; - binmode($fh); - print "not " unless compare($fh,"README") == 0; - print "ok 9\n"; - close $fh; -} - -# filehandle and different (but existing) file. -{ - my $fh; - open ($fh, "<README") or print "not "; - binmode($fh); - print "not " unless compare_text($fh,"TEST") == 1; - print "ok 10\n"; - close $fh; -} - -# Different file with contents of known file, -# will use File::Temp to do this, skip rest of -# tests if this doesn't seem to work - -my @donetests; -eval { - require File::Spec; import File::Spec; - require File::Path; import File::Path; - require File::Temp; import File::Temp qw/ :mktemp unlink0 /; - - my $template = File::Spec->catfile(File::Spec->tmpdir, 'fcmpXXXX'); - my($tfh,$filename) = mkstemp($template); - { - local $/; #slurp - my $fh; - open($fh,'README'); - binmode($fh); - my $data = <$fh>; - print $tfh $data; - close($fh); - } - seek($tfh,0,0); - $donetests[0] = compare($tfh, 'README'); - $donetests[1] = compare($filename, 'README'); - unlink0($tfh,$filename); -}; -print "# problems when testing with a tempory file\n" if $@; - -if (@donetests == 2) { - print "not " unless $donetests[0] == 0; - print "ok 11\n"; - if ($^O eq 'VMS') { - # The open attempt on FROM in File::Compare::compare should fail - # on this OS since files are not shared by default. - print "not " unless $donetests[1] == -1; - print "ok 12\n"; - } - else { - print "not " unless $donetests[1] == 0; - print "ok 12\n"; - } -} -else { - print "ok 11# Skip\nok 12 # Skip Likely due to File::Temp\n"; -} - diff --git a/t/lib/filecopy.t b/t/lib/filecopy.t deleted file mode 100755 index 44b5827e72..0000000000 --- a/t/lib/filecopy.t +++ /dev/null @@ -1,147 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - push @INC, "::lib:$MacPerl::Architecture" if $^O eq 'MacOS'; -} - -$| = 1; - -my @pass = (0,1); -my $tests = $^O eq 'MacOS' ? 14 : 11; -printf "1..%d\n", $tests * scalar(@pass); - -use File::Copy; - -for my $pass (@pass) { - - my $loopconst = $pass*$tests; - - # First we create a file - open(F, ">file-$$") or die; - binmode F; # for DOSISH platforms, because test 3 copies to stdout - printf F "ok %d\n", 3 + $loopconst; - close F; - - copy "file-$$", "copy-$$"; - - open(F, "copy-$$") or die; - $foo = <F>; - close(F); - - print "not " if -s "file-$$" != -s "copy-$$"; - printf "ok %d\n", 1 + $loopconst; - - print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; - printf "ok %d\n", 2+$loopconst; - - binmode STDOUT unless $^O eq 'VMS'; # Copy::copy works in binary mode - copy "copy-$$", \*STDOUT; - unlink "copy-$$" or die "unlink: $!"; - - open(F,"file-$$"); - copy(*F, "copy-$$"); - open(R, "copy-$$") or die "open copy-$$: $!"; $foo = <R>; close(R); - print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; - printf "ok %d\n", 4+$loopconst; - unlink "copy-$$" or die "unlink: $!"; - open(F,"file-$$"); - copy(\*F, "copy-$$"); - close(F) or die "close: $!"; - open(R, "copy-$$") or die; $foo = <R>; close(R) or die "close: $!"; - print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; - printf "ok %d\n", 5+$loopconst; - unlink "copy-$$" or die "unlink: $!"; - - require IO::File; - $fh = IO::File->new(">copy-$$") or die "Cannot open copy-$$:$!"; - binmode $fh or die; - copy("file-$$",$fh); - $fh->close or die "close: $!"; - open(R, "copy-$$") or die; $foo = <R>; close(R); - print "# foo=`$foo'\nnot " unless $foo eq sprintf "ok %d\n", 3+$loopconst; - printf "ok %d\n", 6+$loopconst; - unlink "copy-$$" or die "unlink: $!"; - require FileHandle; - my $fh = FileHandle->new(">copy-$$") or die "Cannot open copy-$$:$!"; - binmode $fh or die; - copy("file-$$",$fh); - $fh->close; - open(R, "copy-$$") or die; $foo = <R>; close(R); - print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; - printf "ok %d\n", 7+$loopconst; - unlink "file-$$" or die "unlink: $!"; - - print "# moved missing file.\nnot " if move("file-$$", "copy-$$"); - print "# target disappeared.\nnot " if not -e "copy-$$"; - printf "ok %d\n", 8+$loopconst; - - move "copy-$$", "file-$$" or print "# move did not succeed.\n"; - print "# not moved: $!\nnot " unless -e "file-$$" and not -e "copy-$$"; - open(R, "file-$$") or die; $foo = <R>; close(R); - print "# foo=`$foo'\nnot " unless $foo eq sprintf "ok %d\n", 3+$loopconst; - printf "ok %d\n", 9+$loopconst; - - if ($^O eq 'MacOS') { - - copy "file-$$", "lib"; - open(R, ":lib:file-$$") or die; $foo = <R>; close(R); - print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; - printf "ok %d\n", 10+$loopconst; - unlink ":lib:file-$$" or die "unlink: $!"; - - copy "file-$$", ":lib"; - open(R, ":lib:file-$$") or die; $foo = <R>; close(R); - print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; - printf "ok %d\n", 11+$loopconst; - unlink ":lib:file-$$" or die "unlink: $!"; - - copy "file-$$", ":lib:"; - open(R, ":lib:file-$$") or die; $foo = <R>; close(R); - print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; - printf "ok %d\n", 12+$loopconst; - unlink ":lib:file-$$" or die "unlink: $!"; - - unless (-e 'lib:') { # make sure there's no volume called 'lib' - undef $@; - eval { (copy "file-$$", "lib:") || die "'lib:' is not a volume name"; }; - print "# Died: $@"; - print "not " unless ( $@ =~ m|'lib:' is not a volume name| ); - } - printf "ok %d\n", 13+$loopconst; - - move "file-$$", ":lib:"; - open(R, ":lib:file-$$") or die "open :lib:file-$$: $!"; $foo = <R>; close(R); - print "not " unless $foo eq sprintf("ok %d\n", 3+$loopconst) - and not -e "file-$$";; - printf "ok %d\n", 14+$loopconst; - unlink ":lib:file-$$" or die "unlink: $!"; - - } else { - - copy "file-$$", "lib"; - open(R, "lib/file-$$") or die; $foo = <R>; close(R); - print "not " unless $foo eq sprintf "ok %d\n", 3+$loopconst; - printf "ok %d\n", 10+$loopconst; - unlink "lib/file-$$" or die "unlink: $!"; - - move "file-$$", "lib"; - open(R, "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R); - print "not " unless $foo eq sprintf("ok %d\n", 3+$loopconst) - and not -e "file-$$";; - printf "ok %d\n", 11+$loopconst; - unlink "lib/file-$$" or die "unlink: $!"; - - } -} - - -END { - 1 while unlink "file-$$"; - if ($^O eq 'MacOS') { - 1 while unlink ":lib:file-$$"; - } else { - 1 while unlink "lib/file-$$"; - } -} diff --git a/t/lib/filefind.t b/t/lib/filefind.t deleted file mode 100755 index 51e3ed8190..0000000000 --- a/t/lib/filefind.t +++ /dev/null @@ -1,734 +0,0 @@ -#!./perl - - -my %Expect_File = (); # what we expect for $_ -my %Expect_Name = (); # what we expect for $File::Find::name/fullname -my %Expect_Dir = (); # what we expect for $File::Find::dir -my $symlink_exists = eval { symlink("",""); 1 }; -my $warn_msg; - - -BEGIN { - chdir 't' if -d 't'; - unshift @INC => '../lib'; - - $SIG{'__WARN__'} = sub { $warn_msg = $_[0]; warn "# $_[0]"; } -} - -if ( $symlink_exists ) { print "1..188\n"; } -else { print "1..78\n"; } - -use File::Find; -use File::Spec; - -cleanup(); - -find({wanted => sub { print "ok 1\n" if $_ eq 'filefind.t'; } }, - File::Spec->curdir); - -finddepth({wanted => sub { print "ok 2\n" if $_ eq 'filefind.t'; } }, - File::Spec->curdir); - -my $case = 2; -my $FastFileTests_OK = 0; - -sub cleanup { - if (-d dir_path('for_find')) { - chdir(dir_path('for_find')); - } - if (-d dir_path('fa')) { - unlink file_path('fa', 'fa_ord'), - file_path('fa', 'fsl'), - file_path('fa', 'faa', 'faa_ord'), - file_path('fa', 'fab', 'fab_ord'), - file_path('fa', 'fab', 'faba', 'faba_ord'), - file_path('fb', 'fb_ord'), - file_path('fb', 'fba', 'fba_ord'); - rmdir dir_path('fa', 'faa'); - rmdir dir_path('fa', 'fab', 'faba'); - rmdir dir_path('fa', 'fab'); - rmdir dir_path('fa'); - rmdir dir_path('fb', 'fba'); - rmdir dir_path('fb'); - chdir File::Spec->updir; - rmdir dir_path('for_find'); - } -} - -END { - cleanup(); -} - -sub Check($) { - $case++; - if ($_[0]) { print "ok $case\n"; } - else { print "not ok $case\n"; } -} - -sub CheckDie($) { - $case++; - if ($_[0]) { print "ok $case\n"; } - else { print "not ok $case\n $!\n"; exit 0; } -} - -sub touch { - CheckDie( open(my $T,'>',$_[0]) ); -} - -sub MkDir($$) { - CheckDie( mkdir($_[0],$_[1]) ); -} - -sub wanted_File_Dir { - print "# \$File::Find::dir => '$File::Find::dir'\n"; - print "# \$_ => '$_'\n"; - s#\.$## if ($^O eq 'VMS' && $_ ne '.'); - Check( $Expect_File{$_} ); - if ( $FastFileTests_OK ) { - delete $Expect_File{ $_} - unless ( $Expect_Dir{$_} && ! -d _ ); - } else { - delete $Expect_File{$_} - unless ( $Expect_Dir{$_} && ! -d $_ ); - } -} - -sub wanted_File_Dir_prune { - &wanted_File_Dir; - $File::Find::prune=1 if $_ eq 'faba'; -} - -sub wanted_Name { - my $n = $File::Find::name; - $n =~ s#\.$## if ($^O eq 'VMS' && $n ne '.'); - print "# \$File::Find::name => '$n'\n"; - my $i = rindex($n,'/'); - my $OK = exists($Expect_Name{$n}); - unless ($^O eq 'MacOS') { - if ( $OK ) { - $OK= exists($Expect_Name{substr($n,0,$i)}) if $i >= 0; - } - } - Check($OK); - delete $Expect_Name{$n}; -} - -sub wanted_File { - print "# \$_ => '$_'\n"; - s#\.$## if ($^O eq 'VMS' && $_ ne '.'); - my $i = rindex($_,'/'); - my $OK = exists($Expect_File{ $_}); - unless ($^O eq 'MacOS') { - if ( $OK ) { - $OK= exists($Expect_File{ substr($_,0,$i)}) if $i >= 0; - } - } - Check($OK); - delete $Expect_File{ $_}; -} - -sub simple_wanted { - print "# \$File::Find::dir => '$File::Find::dir'\n"; - print "# \$_ => '$_'\n"; -} - -sub noop_wanted {} - -sub my_preprocess { - @files = @_; - print "# --preprocess--\n"; - print "# \$File::Find::dir => '$File::Find::dir' \n"; - foreach $file (@files) { - print "# $file \n"; - delete $Expect_Dir{ $File::Find::dir }->{$file}; - } - print "# --end preprocess--\n"; - Check(scalar(keys %{$Expect_Dir{ $File::Find::dir }}) == 0); - if (scalar(keys %{$Expect_Dir{ $File::Find::dir }}) == 0) { - delete $Expect_Dir{ $File::Find::dir } - } - return @files; -} - -sub my_postprocess { - print "# postprocess: \$File::Find::dir => '$File::Find::dir' \n"; - delete $Expect_Dir{ $File::Find::dir}; -} - - -# Use dir_path() to specify a directory path that's expected for -# $File::Find::dir (%Expect_Dir). Also use it in file operations like -# chdir, rmdir etc. -# -# dir_path() concatenates directory names to form a _relative_ -# directory path, independant from the platform it's run on, although -# there are limitations. Don't try to create an absolute path, -# because that may fail on operating systems that have the concept of -# volume names (e.g. Mac OS). Be careful when you want to create an -# updir path like ../fa (Unix) or ::fa: (Mac OS). Plain directory -# names will work best. As a special case, you can pass it a "." as -# first argument, to create a directory path like "./fa/dir" on -# operating systems other than Mac OS (actually, Mac OS will ignore -# the ".", if it's the first argument). If there's no second argument, -# this function will return the empty string on Mac OS and the string -# "./" otherwise. - -sub dir_path { - my $first_item = shift @_; - - if ($first_item eq '.') { - if ($^O eq 'MacOS') { - return '' unless @_; - # ignore first argument; return a relative path - # with leading ":" and with trailing ":" - return File::Spec->catdir("", @_); - } else { # other OS - return './' unless @_; - my $path = File::Spec->catdir(@_); - # add leading "./" - $path = "./$path"; - return $path; - } - - } else { # $first_item ne '.' - return $first_item unless @_; # return plain filename - if ($^O eq 'MacOS') { - # relative path with leading ":" and with trailing ":" - return File::Spec->catdir("", $first_item, @_); - } else { # other OS - return File::Spec->catdir($first_item, @_); - } - } -} - - -# Use topdir() to specify a directory path that you want to pass to -#find/finddepth Basically, topdir() does the same as dir_path() (see -#above), except that there's no trailing ":" on Mac OS. - -sub topdir { - my $path = dir_path(@_); - $path =~ s/:$// if ($^O eq 'MacOS'); - return $path; -} - - -# Use file_path() to specify a file path that's expected for $_ -# (%Expect_File). Also suitable for file operations like unlink etc. -# -# file_path() concatenates directory names (if any) and a filename to -# form a _relative_ file path (the last argument is assumed to be a -# file). It's independant from the platform it's run on, although -# there are limitations (see the warnings for dir_path() above). As a -# special case, you can pass it a "." as first argument, to create a -# file path like "./fa/file" on operating systems other than Mac OS -# (actually, Mac OS will ignore the ".", if it's the first -# argument). If there's no second argument, this function will return -# the empty string on Mac OS and the string "./" otherwise. - -sub file_path { - my $first_item = shift @_; - - if ($first_item eq '.') { - if ($^O eq 'MacOS') { - return '' unless @_; - # ignore first argument; return a relative path - # with leading ":", but without trailing ":" - return File::Spec->catfile("", @_); - } else { # other OS - return './' unless @_; - my $path = File::Spec->catfile(@_); - # add leading "./" - $path = "./$path"; - return $path; - } - - } else { # $first_item ne '.' - return $first_item unless @_; # return plain filename - if ($^O eq 'MacOS') { - # relative path with leading ":", but without trailing ":" - return File::Spec->catfile("", $first_item, @_); - } else { # other OS - return File::Spec->catfile($first_item, @_); - } - } -} - - -# Use file_path_name() to specify a file path that's expected for -# $File::Find::Name (%Expect_Name). Note: When the no_chdir => 1 -# option is in effect, $_ is the same as $File::Find::Name. In that -# case, also use this function to specify a file path that's expected -# for $_. -# -# Basically, file_path_name() does the same as file_path() (see -# above), except that there's always a leading ":" on Mac OS, even for -# plain file/directory names. - -sub file_path_name { - my $path = file_path(@_); - $path = ":$path" if (($^O eq 'MacOS') && ($path !~ /:/)); - return $path; -} - - - -MkDir( dir_path('for_find'), 0770 ); -CheckDie(chdir( dir_path('for_find'))); -MkDir( dir_path('fa'), 0770 ); -MkDir( dir_path('fb'), 0770 ); -touch( file_path('fb', 'fb_ord') ); -MkDir( dir_path('fb', 'fba'), 0770 ); -touch( file_path('fb', 'fba', 'fba_ord') ); -if ($^O eq 'MacOS') { - CheckDie( symlink(':fb',':fa:fsl') ) if $symlink_exists; -} else { - CheckDie( symlink('../fb','fa/fsl') ) if $symlink_exists; -} -touch( file_path('fa', 'fa_ord') ); - -MkDir( dir_path('fa', 'faa'), 0770 ); -touch( file_path('fa', 'faa', 'faa_ord') ); -MkDir( dir_path('fa', 'fab'), 0770 ); -touch( file_path('fa', 'fab', 'fab_ord') ); -MkDir( dir_path('fa', 'fab', 'faba'), 0770 ); -touch( file_path('fa', 'fab', 'faba', 'faba_ord') ); - - -%Expect_File = (File::Spec->curdir => 1, file_path('fsl') => 1, - file_path('fa_ord') => 1, file_path('fab') => 1, - file_path('fab_ord') => 1, file_path('faba') => 1, - file_path('faa') => 1, file_path('faa_ord') => 1); - -delete $Expect_File{ file_path('fsl') } unless $symlink_exists; -%Expect_Name = (); - -%Expect_Dir = ( dir_path('fa') => 1, dir_path('faa') => 1, - dir_path('fab') => 1, dir_path('faba') => 1, - dir_path('fb') => 1, dir_path('fba') => 1); - -delete @Expect_Dir{ dir_path('fb'), dir_path('fba') } unless $symlink_exists; -File::Find::find( {wanted => \&wanted_File_Dir_prune}, topdir('fa') ); -Check( scalar(keys %Expect_File) == 0 ); - - -print "# check re-entrancy\n"; - -%Expect_File = (File::Spec->curdir => 1, file_path('fsl') => 1, - file_path('fa_ord') => 1, file_path('fab') => 1, - file_path('fab_ord') => 1, file_path('faba') => 1, - file_path('faa') => 1, file_path('faa_ord') => 1); - -delete $Expect_File{ file_path('fsl') } unless $symlink_exists; -%Expect_Name = (); - -%Expect_Dir = ( dir_path('fa') => 1, dir_path('faa') => 1, - dir_path('fab') => 1, dir_path('faba') => 1, - dir_path('fb') => 1, dir_path('fba') => 1); - -delete @Expect_Dir{ dir_path('fb'), dir_path('fba') } unless $symlink_exists; - -File::Find::find( {wanted => sub { wanted_File_Dir_prune(); - File::Find::find( {wanted => sub - {} }, File::Spec->curdir ); } }, - topdir('fa') ); - -Check( scalar(keys %Expect_File) == 0 ); - - -# no_chdir is in effect, hence we use file_path_name to specify the expected paths for %Expect_File - -%Expect_File = (file_path_name('fa') => 1, - file_path_name('fa', 'fsl') => 1, - file_path_name('fa', 'fa_ord') => 1, - file_path_name('fa', 'fab') => 1, - file_path_name('fa', 'fab', 'fab_ord') => 1, - file_path_name('fa', 'fab', 'faba') => 1, - file_path_name('fa', 'fab', 'faba', 'faba_ord') => 1, - file_path_name('fa', 'faa') => 1, - file_path_name('fa', 'faa', 'faa_ord') => 1,); - -delete $Expect_File{ file_path_name('fa', 'fsl') } unless $symlink_exists; -%Expect_Name = (); - -%Expect_Dir = (dir_path('fa') => 1, - dir_path('fa', 'faa') => 1, - dir_path('fa', 'fab') => 1, - dir_path('fa', 'fab', 'faba') => 1, - dir_path('fb') => 1, - dir_path('fb', 'fba') => 1); - -delete @Expect_Dir{ dir_path('fb'), dir_path('fb', 'fba') } - unless $symlink_exists; - -File::Find::find( {wanted => \&wanted_File_Dir, no_chdir => 1}, - topdir('fa') ); Check( scalar(keys %Expect_File) == 0 ); - - -%Expect_File = (); - -%Expect_Name = (File::Spec->curdir => 1, - file_path_name('.', 'fa') => 1, - file_path_name('.', 'fa', 'fsl') => 1, - file_path_name('.', 'fa', 'fa_ord') => 1, - file_path_name('.', 'fa', 'fab') => 1, - file_path_name('.', 'fa', 'fab', 'fab_ord') => 1, - file_path_name('.', 'fa', 'fab', 'faba') => 1, - file_path_name('.', 'fa', 'fab', 'faba', 'faba_ord') => 1, - file_path_name('.', 'fa', 'faa') => 1, - file_path_name('.', 'fa', 'faa', 'faa_ord') => 1, - file_path_name('.', 'fb') => 1, - file_path_name('.', 'fb', 'fba') => 1, - file_path_name('.', 'fb', 'fba', 'fba_ord') => 1, - file_path_name('.', 'fb', 'fb_ord') => 1); - -delete $Expect_Name{ file_path('.', 'fa', 'fsl') } unless $symlink_exists; -%Expect_Dir = (); -File::Find::finddepth( {wanted => \&wanted_Name}, File::Spec->curdir ); -Check( scalar(keys %Expect_Name) == 0 ); - - -# no_chdir is in effect, hence we use file_path_name to specify the -# expected paths for %Expect_File - -%Expect_File = (File::Spec->curdir => 1, - file_path_name('.', 'fa') => 1, - file_path_name('.', 'fa', 'fsl') => 1, - file_path_name('.', 'fa', 'fa_ord') => 1, - file_path_name('.', 'fa', 'fab') => 1, - file_path_name('.', 'fa', 'fab', 'fab_ord') => 1, - file_path_name('.', 'fa', 'fab', 'faba') => 1, - file_path_name('.', 'fa', 'fab', 'faba', 'faba_ord') => 1, - file_path_name('.', 'fa', 'faa') => 1, - file_path_name('.', 'fa', 'faa', 'faa_ord') => 1, - file_path_name('.', 'fb') => 1, - file_path_name('.', 'fb', 'fba') => 1, - file_path_name('.', 'fb', 'fba', 'fba_ord') => 1, - file_path_name('.', 'fb', 'fb_ord') => 1); - -delete $Expect_File{ file_path_name('.', 'fa', 'fsl') } unless $symlink_exists; -%Expect_Name = (); -%Expect_Dir = (); - -File::Find::finddepth( {wanted => \&wanted_File, no_chdir => 1}, - File::Spec->curdir ); - -Check( scalar(keys %Expect_File) == 0 ); - - -print "# check preprocess\n"; -%Expect_File = (); -%Expect_Name = (); -%Expect_Dir = ( - File::Spec->curdir => {fa => 1, fb => 1}, - dir_path('.', 'fa') => {faa => 1, fab => 1, fa_ord => 1}, - dir_path('.', 'fa', 'faa') => {faa_ord => 1}, - dir_path('.', 'fa', 'fab') => {faba => 1, fab_ord => 1}, - dir_path('.', 'fa', 'fab', 'faba') => {faba_ord => 1}, - dir_path('.', 'fb') => {fba => 1, fb_ord => 1}, - dir_path('.', 'fb', 'fba') => {fba_ord => 1} - ); - -File::Find::find( {wanted => \&noop_wanted, - preprocess => \&my_preprocess}, File::Spec->curdir ); - -Check( scalar(keys %Expect_Dir) == 0 ); - - -print "# check postprocess\n"; -%Expect_File = (); -%Expect_Name = (); -%Expect_Dir = ( - File::Spec->curdir => 1, - dir_path('.', 'fa') => 1, - dir_path('.', 'fa', 'faa') => 1, - dir_path('.', 'fa', 'fab') => 1, - dir_path('.', 'fa', 'fab', 'faba') => 1, - dir_path('.', 'fb') => 1, - dir_path('.', 'fb', 'fba') => 1 - ); - -File::Find::find( {wanted => \&noop_wanted, - postprocess => \&my_postprocess}, File::Spec->curdir ); - -Check( scalar(keys %Expect_Dir) == 0 ); - - -if ( $symlink_exists ) { - print "# --- symbolic link tests --- \n"; - $FastFileTests_OK= 1; - - - # Verify that File::Find::find will call wanted even if the topdir of - # is a symlink to a directory, and it shouldn't follow the link - # unless follow is set, which it isn't in this case - %Expect_File = ( file_path('fsl') => 1 ); - %Expect_Name = (); - %Expect_Dir = (); - File::Find::find( {wanted => \&wanted_File_Dir}, topdir('fa', 'fsl') ); - Check( scalar(keys %Expect_File) == 0 ); - - - %Expect_File = (File::Spec->curdir => 1, file_path('fa_ord') => 1, - file_path('fsl') => 1, file_path('fb_ord') => 1, - file_path('fba') => 1, file_path('fba_ord') => 1, - file_path('fab') => 1, file_path('fab_ord') => 1, - file_path('faba') => 1, file_path('faa') => 1, - file_path('faa_ord') => 1); - - %Expect_Name = (); - - %Expect_Dir = (File::Spec->curdir => 1, dir_path('fa') => 1, - dir_path('faa') => 1, dir_path('fab') => 1, - dir_path('faba') => 1, dir_path('fb') => 1, - dir_path('fba') => 1); - - File::Find::find( {wanted => \&wanted_File_Dir_prune, - follow_fast => 1}, topdir('fa') ); - - Check( scalar(keys %Expect_File) == 0 ); - - - # no_chdir is in effect, hence we use file_path_name to specify - # the expected paths for %Expect_File - - %Expect_File = (file_path_name('fa') => 1, - file_path_name('fa', 'fa_ord') => 1, - file_path_name('fa', 'fsl') => 1, - file_path_name('fa', 'fsl', 'fb_ord') => 1, - file_path_name('fa', 'fsl', 'fba') => 1, - file_path_name('fa', 'fsl', 'fba', 'fba_ord') => 1, - file_path_name('fa', 'fab') => 1, - file_path_name('fa', 'fab', 'fab_ord') => 1, - file_path_name('fa', 'fab', 'faba') => 1, - file_path_name('fa', 'fab', 'faba', 'faba_ord') => 1, - file_path_name('fa', 'faa') => 1, - file_path_name('fa', 'faa', 'faa_ord') => 1); - - %Expect_Name = (); - - %Expect_Dir = (dir_path('fa') => 1, - dir_path('fa', 'faa') => 1, - dir_path('fa', 'fab') => 1, - dir_path('fa', 'fab', 'faba') => 1, - dir_path('fb') => 1, - dir_path('fb', 'fba') => 1); - - File::Find::find( {wanted => \&wanted_File_Dir, follow_fast => 1, - no_chdir => 1}, topdir('fa') ); - - Check( scalar(keys %Expect_File) == 0 ); - - %Expect_File = (); - - %Expect_Name = (file_path_name('fa') => 1, - file_path_name('fa', 'fa_ord') => 1, - file_path_name('fa', 'fsl') => 1, - file_path_name('fa', 'fsl', 'fb_ord') => 1, - file_path_name('fa', 'fsl', 'fba') => 1, - file_path_name('fa', 'fsl', 'fba', 'fba_ord') => 1, - file_path_name('fa', 'fab') => 1, - file_path_name('fa', 'fab', 'fab_ord') => 1, - file_path_name('fa', 'fab', 'faba') => 1, - file_path_name('fa', 'fab', 'faba', 'faba_ord') => 1, - file_path_name('fa', 'faa') => 1, - file_path_name('fa', 'faa', 'faa_ord') => 1); - - %Expect_Dir = (); - - File::Find::finddepth( {wanted => \&wanted_Name, - follow_fast => 1}, topdir('fa') ); - - Check( scalar(keys %Expect_Name) == 0 ); - - # no_chdir is in effect, hence we use file_path_name to specify - # the expected paths for %Expect_File - - %Expect_File = (file_path_name('fa') => 1, - file_path_name('fa', 'fa_ord') => 1, - file_path_name('fa', 'fsl') => 1, - file_path_name('fa', 'fsl', 'fb_ord') => 1, - file_path_name('fa', 'fsl', 'fba') => 1, - file_path_name('fa', 'fsl', 'fba', 'fba_ord') => 1, - file_path_name('fa', 'fab') => 1, - file_path_name('fa', 'fab', 'fab_ord') => 1, - file_path_name('fa', 'fab', 'faba') => 1, - file_path_name('fa', 'fab', 'faba', 'faba_ord') => 1, - file_path_name('fa', 'faa') => 1, - file_path_name('fa', 'faa', 'faa_ord') => 1); - - %Expect_Name = (); - %Expect_Dir = (); - - File::Find::finddepth( {wanted => \&wanted_File, follow_fast => 1, - no_chdir => 1}, topdir('fa') ); - - Check( scalar(keys %Expect_File) == 0 ); - - - print "# check dangling symbolic links\n"; - MkDir( dir_path('dangling_dir'), 0770 ); - CheckDie( symlink( dir_path('dangling_dir'), - file_path('dangling_dir_sl') ) ); - rmdir dir_path('dangling_dir'); - touch(file_path('dangling_file')); - if ($^O eq 'MacOS') { - CheckDie( symlink('dangling_file', ':fa:dangling_file_sl') ); - } else { - CheckDie( symlink('../dangling_file','fa/dangling_file_sl') ); - } - unlink file_path('dangling_file'); - - { - # these tests should also emit a warning - use warnings; - - %Expect_File = (File::Spec->curdir => 1, - file_path('fa_ord') => 1, - file_path('fsl') => 1, - file_path('fb_ord') => 1, - file_path('fba') => 1, - file_path('fba_ord') => 1, - file_path('fab') => 1, - file_path('fab_ord') => 1, - file_path('faba') => 1, - file_path('faba_ord') => 1, - file_path('faa') => 1, - file_path('faa_ord') => 1); - - %Expect_Name = (); - %Expect_Dir = (); - undef $warn_msg; - - File::Find::find( {wanted => \&wanted_File, follow => 1, - dangling_symlinks => - sub { $warn_msg = "$_[0] is a dangling symbolic link" } - }, - topdir('dangling_dir_sl'), topdir('fa') ); - - Check( scalar(keys %Expect_File) == 0 ); - Check( $warn_msg =~ m|dangling_dir_sl is a dangling symbolic link| ); - unlink file_path('fa', 'dangling_file_sl'), - file_path('dangling_dir_sl'); - - } - - - print "# check recursion\n"; - if ($^O eq 'MacOS') { - CheckDie( symlink(':fa:faa',':fa:faa:faa_sl') ); - } else { - CheckDie( symlink('../faa','fa/faa/faa_sl') ); - } - undef $@; - eval {File::Find::find( {wanted => \&simple_wanted, follow => 1, - no_chdir => 1}, topdir('fa') ); }; - Check( $@ =~ m|for_find[:/]fa[:/]faa[:/]faa_sl is a recursive symbolic link| ); - unlink file_path('fa', 'faa', 'faa_sl'); - - - print "# check follow_skip (file)\n"; - if ($^O eq 'MacOS') { - CheckDie( symlink(':fa:fa_ord',':fa:fa_ord_sl') ); # symlink to a file - } else { - CheckDie( symlink('./fa_ord','fa/fa_ord_sl') ); # symlink to a file - } - undef $@; - - eval {File::Find::finddepth( {wanted => \&simple_wanted, - follow => 1, - follow_skip => 0, no_chdir => 1}, - topdir('fa') );}; - - Check( $@ =~ m|for_find[:/]fa[:/]fa_ord encountered a second time| ); - - - # no_chdir is in effect, hence we use file_path_name to specify - # the expected paths for %Expect_File - - %Expect_File = (file_path_name('fa') => 1, - file_path_name('fa', 'fa_ord') => 1, - file_path_name('fa', 'fsl') => 1, - file_path_name('fa', 'fsl', 'fb_ord') => 1, - file_path_name('fa', 'fsl', 'fba') => 1, - file_path_name('fa', 'fsl', 'fba', 'fba_ord') => 1, - file_path_name('fa', 'fab') => 1, - file_path_name('fa', 'fab', 'fab_ord') => 1, - file_path_name('fa', 'fab', 'faba') => 1, - file_path_name('fa', 'fab', 'faba', 'faba_ord') => 1, - file_path_name('fa', 'faa') => 1, - file_path_name('fa', 'faa', 'faa_ord') => 1); - - %Expect_Name = (); - - %Expect_Dir = (dir_path('fa') => 1, - dir_path('fa', 'faa') => 1, - dir_path('fa', 'fab') => 1, - dir_path('fa', 'fab', 'faba') => 1, - dir_path('fb') => 1, - dir_path('fb','fba') => 1); - - File::Find::finddepth( {wanted => \&wanted_File_Dir, follow => 1, - follow_skip => 1, no_chdir => 1}, - topdir('fa') ); - - Check( scalar(keys %Expect_File) == 0 ); - unlink file_path('fa', 'fa_ord_sl'); - - - print "# check follow_skip (directory)\n"; - if ($^O eq 'MacOS') { - CheckDie( symlink(':fa:faa',':fa:faa_sl') ); # symlink to a directory - } else { - CheckDie( symlink('./faa','fa/faa_sl') ); # symlink to a directory - } - undef $@; - - eval {File::Find::find( {wanted => \&simple_wanted, follow => 1, - follow_skip => 0, no_chdir => 1}, - topdir('fa') );}; - - Check( $@ =~ m|for_find[:/]fa[:/]faa[:/]? encountered a second time| ); - - - undef $@; - - eval {File::Find::find( {wanted => \&simple_wanted, follow => 1, - follow_skip => 1, no_chdir => 1}, - topdir('fa') );}; - - Check( $@ =~ m|for_find[:/]fa[:/]faa[:/]? encountered a second time| ); - - # no_chdir is in effect, hence we use file_path_name to specify - # the expected paths for %Expect_File - - %Expect_File = (file_path_name('fa') => 1, - file_path_name('fa', 'fa_ord') => 1, - file_path_name('fa', 'fsl') => 1, - file_path_name('fa', 'fsl', 'fb_ord') => 1, - file_path_name('fa', 'fsl', 'fba') => 1, - file_path_name('fa', 'fsl', 'fba', 'fba_ord') => 1, - file_path_name('fa', 'fab') => 1, - file_path_name('fa', 'fab', 'fab_ord') => 1, - file_path_name('fa', 'fab', 'faba') => 1, - file_path_name('fa', 'fab', 'faba', 'faba_ord') => 1, - file_path_name('fa', 'faa') => 1, - file_path_name('fa', 'faa', 'faa_ord') => 1); - - %Expect_Name = (); - - %Expect_Dir = (dir_path('fa') => 1, - dir_path('fa', 'faa') => 1, - dir_path('fa', 'fab') => 1, - dir_path('fa', 'fab', 'faba') => 1, - dir_path('fb') => 1, - dir_path('fb', 'fba') => 1); - - File::Find::find( {wanted => \&wanted_File_Dir, follow => 1, - follow_skip => 2, no_chdir => 1}, topdir('fa') ); - - Check( scalar(keys %Expect_File) == 0 ); - unlink file_path('fa', 'faa_sl'); - -} - diff --git a/t/lib/filefunc.t b/t/lib/filefunc.t deleted file mode 100755 index 926812248c..0000000000 --- a/t/lib/filefunc.t +++ /dev/null @@ -1,17 +0,0 @@ -#!./perl - -BEGIN { - $^O = ''; - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..1\n"; - -use File::Spec::Functions; - -if (catfile('a','b','c') eq 'a/b/c') { - print "ok 1\n"; -} else { - print "not ok 1\n"; -} diff --git a/t/lib/filehand.t b/t/lib/filehand.t deleted file mode 100755 index eaddf496db..0000000000 --- a/t/lib/filehand.t +++ /dev/null @@ -1,91 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { - print "1..0\n"; - exit 0; - } -} - -use FileHandle; -use strict subs; - -autoflush STDOUT 1; - -$mystdout = new_from_fd FileHandle 1,"w"; -$| = 1; -autoflush $mystdout; -print "1..11\n"; - -print $mystdout "ok ".fileno($mystdout)."\n"; - -$fh = (new FileHandle "./TEST", O_RDONLY - or new FileHandle "TEST", O_RDONLY) - and print "ok 2\n"; - - -$buffer = <$fh>; -print $buffer eq "#!./perl\n" ? "ok 3\n" : "not ok 3\n"; - - -ungetc $fh ord 'A'; -CORE::read($fh, $buf,1); -print $buf eq 'A' ? "ok 4\n" : "not ok 4\n"; - -close $fh; - -$fh = new FileHandle; - -print "not " unless ($fh->open("< TEST") && <$fh> eq $buffer); -print "ok 5\n"; - -$fh->seek(0,0); -print "#possible mixed CRLF/LF in t/TEST\nnot " unless (<$fh> eq $buffer); -print "ok 6\n"; - -$fh->seek(0,2); -$line = <$fh>; -print "not " if (defined($line) || !$fh->eof); -print "ok 7\n"; - -print "not " unless ($fh->open("TEST","r") && !$fh->tell && $fh->close); -print "ok 8\n"; - -autoflush STDOUT 0; - -print "not " if ($|); -print "ok 9\n"; - -autoflush STDOUT 1; - -print "not " unless ($|); -print "ok 10\n"; - -if ($^O eq 'dos') -{ - printf("ok %d\n",11); - exit(0); -} - -($rd,$wr) = FileHandle::pipe; - -if ($^O eq 'VMS' || $^O eq 'os2' || $^O eq 'amigaos' || $^O eq 'MSWin32' || $^O eq 'NetWare' || - $Config{d_fork} ne 'define') { - $wr->autoflush; - $wr->printf("ok %d\n",11); - print $rd->getline; -} -else { - if (fork) { - $wr->close; - print $rd->getline; - } - else { - $rd->close; - $wr->printf("ok %d\n",11); - exit(0); - } -} diff --git a/t/lib/filepath.t b/t/lib/filepath.t deleted file mode 100755 index 42e0ae9f93..0000000000 --- a/t/lib/filepath.t +++ /dev/null @@ -1,28 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use File::Path; -use strict; - -my $count = 0; -use warnings; - -print "1..4\n"; - -# first check for stupid permissions second for full, so we clean up -# behind ourselves -for my $perm (0111,0777) { - mkpath("foo/bar"); - chmod $perm, "foo", "foo/bar"; - - print "not " unless -d "foo" && -d "foo/bar"; - print "ok ", ++$count, "\n"; - - rmtree("foo"); - print "not " if -e "foo"; - print "ok ", ++$count, "\n"; -} diff --git a/t/lib/filespec.t b/t/lib/filespec.t deleted file mode 100755 index c6d155fac1..0000000000 --- a/t/lib/filespec.t +++ /dev/null @@ -1,379 +0,0 @@ -#!./perl - -BEGIN { - $^O = ''; - chdir 't' if -d 't'; - @INC = '../lib'; -} - -# Each element in this array is a single test. Storing them this way makes -# maintenance easy, and should be OK since perl should be pretty functional -# before these tests are run. - -@tests = ( -# Function Expected -[ "Unix->catfile('a','b','c')", 'a/b/c' ], - -[ "Unix->splitpath('file')", ',,file' ], -[ "Unix->splitpath('/d1/d2/d3/')", ',/d1/d2/d3/,' ], -[ "Unix->splitpath('d1/d2/d3/')", ',d1/d2/d3/,' ], -[ "Unix->splitpath('/d1/d2/d3/.')", ',/d1/d2/d3/.,' ], -[ "Unix->splitpath('/d1/d2/d3/..')", ',/d1/d2/d3/..,' ], -[ "Unix->splitpath('/d1/d2/d3/.file')", ',/d1/d2/d3/,.file' ], -[ "Unix->splitpath('d1/d2/d3/file')", ',d1/d2/d3/,file' ], -[ "Unix->splitpath('/../../d1/')", ',/../../d1/,' ], -[ "Unix->splitpath('/././d1/')", ',/././d1/,' ], - -[ "Unix->catpath('','','file')", 'file' ], -[ "Unix->catpath('','/d1/d2/d3/','')", '/d1/d2/d3/' ], -[ "Unix->catpath('','d1/d2/d3/','')", 'd1/d2/d3/' ], -[ "Unix->catpath('','/d1/d2/d3/.','')", '/d1/d2/d3/.' ], -[ "Unix->catpath('','/d1/d2/d3/..','')", '/d1/d2/d3/..' ], -[ "Unix->catpath('','/d1/d2/d3/','.file')", '/d1/d2/d3/.file' ], -[ "Unix->catpath('','d1/d2/d3/','file')", 'd1/d2/d3/file' ], -[ "Unix->catpath('','/../../d1/','')", '/../../d1/' ], -[ "Unix->catpath('','/././d1/','')", '/././d1/' ], -[ "Unix->catpath('d1','d2/d3/','')", 'd2/d3/' ], -[ "Unix->catpath('d1','d2','d3/')", 'd2/d3/' ], - -[ "Unix->splitdir('')", '' ], -[ "Unix->splitdir('/d1/d2/d3/')", ',d1,d2,d3,' ], -[ "Unix->splitdir('d1/d2/d3/')", 'd1,d2,d3,' ], -[ "Unix->splitdir('/d1/d2/d3')", ',d1,d2,d3' ], -[ "Unix->splitdir('d1/d2/d3')", 'd1,d2,d3' ], - -[ "Unix->catdir()", '' ], -[ "Unix->catdir('/')", '/' ], -[ "Unix->catdir('','d1','d2','d3','')", '/d1/d2/d3' ], -[ "Unix->catdir('d1','d2','d3','')", 'd1/d2/d3' ], -[ "Unix->catdir('','d1','d2','d3')", '/d1/d2/d3' ], -[ "Unix->catdir('d1','d2','d3')", 'd1/d2/d3' ], - -[ "Unix->catfile('a','b','c')", 'a/b/c' ], - -[ "Unix->canonpath('')", '' ], -[ "Unix->canonpath('///../../..//./././a//b/.././c/././')", '/a/b/../c' ], -[ "Unix->canonpath('/.')", '/.' ], - -[ "Unix->abs2rel('/t1/t2/t3','/t1/t2/t3')", '' ], -[ "Unix->abs2rel('/t1/t2/t4','/t1/t2/t3')", '../t4' ], -[ "Unix->abs2rel('/t1/t2','/t1/t2/t3')", '..' ], -[ "Unix->abs2rel('/t1/t2/t3/t4','/t1/t2/t3')", 't4' ], -[ "Unix->abs2rel('/t4/t5/t6','/t1/t2/t3')", '../../../t4/t5/t6' ], -#[ "Unix->abs2rel('../t4','/t1/t2/t3')", '../t4' ], -[ "Unix->abs2rel('/','/t1/t2/t3')", '../../..' ], -[ "Unix->abs2rel('///','/t1/t2/t3')", '../../..' ], -[ "Unix->abs2rel('/.','/t1/t2/t3')", '../../../.' ], -[ "Unix->abs2rel('/./','/t1/t2/t3')", '../../..' ], -#[ "Unix->abs2rel('../t4','/t1/t2/t3')", '../t4' ], - -[ "Unix->rel2abs('t4','/t1/t2/t3')", '/t1/t2/t3/t4' ], -[ "Unix->rel2abs('t4/t5','/t1/t2/t3')", '/t1/t2/t3/t4/t5' ], -[ "Unix->rel2abs('.','/t1/t2/t3')", '/t1/t2/t3' ], -[ "Unix->rel2abs('..','/t1/t2/t3')", '/t1/t2/t3/..' ], -[ "Unix->rel2abs('../t4','/t1/t2/t3')", '/t1/t2/t3/../t4' ], -[ "Unix->rel2abs('/t1','/t1/t2/t3')", '/t1' ], - -[ "Win32->splitpath('file')", ',,file' ], -[ "Win32->splitpath('\\d1/d2\\d3/')", ',\\d1/d2\\d3/,' ], -[ "Win32->splitpath('d1/d2\\d3/')", ',d1/d2\\d3/,' ], -[ "Win32->splitpath('\\d1/d2\\d3/.')", ',\\d1/d2\\d3/.,' ], -[ "Win32->splitpath('\\d1/d2\\d3/..')", ',\\d1/d2\\d3/..,' ], -[ "Win32->splitpath('\\d1/d2\\d3/.file')", ',\\d1/d2\\d3/,.file' ], -[ "Win32->splitpath('\\d1/d2\\d3/file')", ',\\d1/d2\\d3/,file' ], -[ "Win32->splitpath('d1/d2\\d3/file')", ',d1/d2\\d3/,file' ], -[ "Win32->splitpath('C:\\d1/d2\\d3/')", 'C:,\\d1/d2\\d3/,' ], -[ "Win32->splitpath('C:d1/d2\\d3/')", 'C:,d1/d2\\d3/,' ], -[ "Win32->splitpath('C:\\d1/d2\\d3/file')", 'C:,\\d1/d2\\d3/,file' ], -[ "Win32->splitpath('C:d1/d2\\d3/file')", 'C:,d1/d2\\d3/,file' ], -[ "Win32->splitpath('C:\\../d2\\d3/file')", 'C:,\\../d2\\d3/,file' ], -[ "Win32->splitpath('C:../d2\\d3/file')", 'C:,../d2\\d3/,file' ], -[ "Win32->splitpath('\\../..\\d1/')", ',\\../..\\d1/,' ], -[ "Win32->splitpath('\\./.\\d1/')", ',\\./.\\d1/,' ], -[ "Win32->splitpath('\\\\node\\share\\d1/d2\\d3/')", '\\\\node\\share,\\d1/d2\\d3/,' ], -[ "Win32->splitpath('\\\\node\\share\\d1/d2\\d3/file')", '\\\\node\\share,\\d1/d2\\d3/,file' ], -[ "Win32->splitpath('\\\\node\\share\\d1/d2\\file')", '\\\\node\\share,\\d1/d2\\,file' ], -[ "Win32->splitpath('file',1)", ',file,' ], -[ "Win32->splitpath('\\d1/d2\\d3/',1)", ',\\d1/d2\\d3/,' ], -[ "Win32->splitpath('d1/d2\\d3/',1)", ',d1/d2\\d3/,' ], -[ "Win32->splitpath('\\\\node\\share\\d1/d2\\d3/',1)", '\\\\node\\share,\\d1/d2\\d3/,' ], - -[ "Win32->catpath('','','file')", 'file' ], -[ "Win32->catpath('','\\d1/d2\\d3/','')", '\\d1/d2\\d3/' ], -[ "Win32->catpath('','d1/d2\\d3/','')", 'd1/d2\\d3/' ], -[ "Win32->catpath('','\\d1/d2\\d3/.','')", '\\d1/d2\\d3/.' ], -[ "Win32->catpath('','\\d1/d2\\d3/..','')", '\\d1/d2\\d3/..' ], -[ "Win32->catpath('','\\d1/d2\\d3/','.file')", '\\d1/d2\\d3/.file' ], -[ "Win32->catpath('','\\d1/d2\\d3/','file')", '\\d1/d2\\d3/file' ], -[ "Win32->catpath('','d1/d2\\d3/','file')", 'd1/d2\\d3/file' ], -[ "Win32->catpath('C:','\\d1/d2\\d3/','')", 'C:\\d1/d2\\d3/' ], -[ "Win32->catpath('C:','d1/d2\\d3/','')", 'C:d1/d2\\d3/' ], -[ "Win32->catpath('C:','\\d1/d2\\d3/','file')", 'C:\\d1/d2\\d3/file' ], -[ "Win32->catpath('C:','d1/d2\\d3/','file')", 'C:d1/d2\\d3/file' ], -[ "Win32->catpath('C:','\\../d2\\d3/','file')", 'C:\\../d2\\d3/file' ], -[ "Win32->catpath('C:','../d2\\d3/','file')", 'C:../d2\\d3/file' ], -[ "Win32->catpath('','\\../..\\d1/','')", '\\../..\\d1/' ], -[ "Win32->catpath('','\\./.\\d1/','')", '\\./.\\d1/' ], -[ "Win32->catpath('\\\\node\\share','\\d1/d2\\d3/','')", '\\\\node\\share\\d1/d2\\d3/' ], -[ "Win32->catpath('\\\\node\\share','\\d1/d2\\d3/','file')", '\\\\node\\share\\d1/d2\\d3/file' ], -[ "Win32->catpath('\\\\node\\share','\\d1/d2\\','file')", '\\\\node\\share\\d1/d2\\file' ], - -[ "Win32->splitdir('')", '' ], -[ "Win32->splitdir('\\d1/d2\\d3/')", ',d1,d2,d3,' ], -[ "Win32->splitdir('d1/d2\\d3/')", 'd1,d2,d3,' ], -[ "Win32->splitdir('\\d1/d2\\d3')", ',d1,d2,d3' ], -[ "Win32->splitdir('d1/d2\\d3')", 'd1,d2,d3' ], - -[ "Win32->catdir()", '' ], -[ "Win32->catdir('')", '\\' ], -[ "Win32->catdir('/')", '\\' ], -[ "Win32->catdir('//d1','d2')", '\\\\d1\\d2' ], -[ "Win32->catdir('','/d1','d2')", '\\\\d1\\d2' ], -[ "Win32->catdir('','','/d1','d2')", '\\\\\\d1\\d2' ], -[ "Win32->catdir('','//d1','d2')", '\\\\\\d1\\d2' ], -[ "Win32->catdir('','','//d1','d2')", '\\\\\\\\d1\\d2' ], -[ "Win32->catdir('','d1','','d2','')", '\\d1\\d2' ], -[ "Win32->catdir('','d1','d2','d3','')", '\\d1\\d2\\d3' ], -[ "Win32->catdir('d1','d2','d3','')", 'd1\\d2\\d3' ], -[ "Win32->catdir('','d1','d2','d3')", '\\d1\\d2\\d3' ], -[ "Win32->catdir('d1','d2','d3')", 'd1\\d2\\d3' ], -[ "Win32->catdir('A:/d1','d2','d3')", 'A:\\d1\\d2\\d3' ], -[ "Win32->catdir('A:/d1','d2','d3','')", 'A:\\d1\\d2\\d3' ], -#[ "Win32->catdir('A:/d1','B:/d2','d3','')", 'A:\\d1\\d2\\d3' ], -[ "Win32->catdir('A:/d1','B:/d2','d3','')", 'A:\\d1\\B:\\d2\\d3' ], -[ "Win32->catdir('A:/')", 'A:\\' ], - -[ "Win32->catfile('a','b','c')", 'a\\b\\c' ], - -[ "Win32->canonpath('')", '' ], -[ "Win32->canonpath('a:')", 'A:' ], -[ "Win32->canonpath('A:f')", 'A:f' ], -[ "Win32->canonpath('//a\\b//c')", '\\\\a\\b\\c' ], -[ "Win32->canonpath('/a/..../c')", '\\a\\....\\c' ], -[ "Win32->canonpath('//a/b\\c')", '\\\\a\\b\\c' ], -[ "Win32->canonpath('////')", '\\\\\\' ], -[ "Win32->canonpath('//')", '\\' ], -[ "Win32->canonpath('/.')", '\\.' ], -[ "Win32->canonpath('//a/b/../../c')", '\\\\a\\b\\..\\..\\c' ], -[ "Win32->canonpath('//a/../../c')", '\\\\a\\..\\..\\c' ], - -[ "Win32->abs2rel('/t1/t2/t3','/t1/t2/t3')", '' ], -[ "Win32->abs2rel('/t1/t2/t4','/t1/t2/t3')", '..\\t4' ], -[ "Win32->abs2rel('/t1/t2','/t1/t2/t3')", '..' ], -[ "Win32->abs2rel('/t1/t2/t3/t4','/t1/t2/t3')", 't4' ], -[ "Win32->abs2rel('/t4/t5/t6','/t1/t2/t3')", '..\\..\\..\\t4\\t5\\t6' ], -#[ "Win32->abs2rel('../t4','/t1/t2/t3')", '\\t1\\t2\\t3\\..\\t4' ], -[ "Win32->abs2rel('/','/t1/t2/t3')", '..\\..\\..' ], -[ "Win32->abs2rel('///','/t1/t2/t3')", '..\\..\\..' ], -[ "Win32->abs2rel('/.','/t1/t2/t3')", '..\\..\\..\\.' ], -[ "Win32->abs2rel('/./','/t1/t2/t3')", '..\\..\\..' ], -[ "Win32->abs2rel('\\\\a/t1/t2/t4','/t2/t3')", '..\\t4' ], -[ "Win32->abs2rel('//a/t1/t2/t4','/t2/t3')", '..\\t4' ], - -[ "Win32->rel2abs('temp','C:/')", 'C:\\temp' ], -[ "Win32->rel2abs('temp','C:/a')", 'C:\\a\\temp' ], -[ "Win32->rel2abs('temp','C:/a/')", 'C:\\a\\temp' ], -[ "Win32->rel2abs('../','C:/')", 'C:\\..' ], -[ "Win32->rel2abs('../','C:/a')", 'C:\\a\\..' ], -[ "Win32->rel2abs('temp','//prague_main/work/')", '\\\\prague_main\\work\\temp' ], -[ "Win32->rel2abs('../temp','//prague_main/work/')", '\\\\prague_main\\work\\..\\temp' ], -[ "Win32->rel2abs('temp','//prague_main/work')", '\\\\prague_main\\work\\temp' ], -[ "Win32->rel2abs('../','//prague_main/work')", '\\\\prague_main\\work\\..' ], - -[ "VMS->splitpath('file')", ',,file' ], -[ "VMS->splitpath('[d1.d2.d3]')", ',[d1.d2.d3],' ], -[ "VMS->splitpath('[.d1.d2.d3]')", ',[.d1.d2.d3],' ], -[ "VMS->splitpath('[d1.d2.d3]file')", ',[d1.d2.d3],file' ], -[ "VMS->splitpath('d1/d2/d3/file')", ',[.d1.d2.d3],file' ], -[ "VMS->splitpath('/d1/d2/d3/file')", 'd1:,[d2.d3],file' ], -[ "VMS->splitpath('[.d1.d2.d3]file')", ',[.d1.d2.d3],file' ], -[ "VMS->splitpath('node::volume:[d1.d2.d3]')", 'node::volume:,[d1.d2.d3],' ], -[ "VMS->splitpath('node::volume:[d1.d2.d3]file')", 'node::volume:,[d1.d2.d3],file' ], -[ "VMS->splitpath('node\"access_spec\"::volume:[d1.d2.d3]')", 'node"access_spec"::volume:,[d1.d2.d3],' ], -[ "VMS->splitpath('node\"access_spec\"::volume:[d1.d2.d3]file')", 'node"access_spec"::volume:,[d1.d2.d3],file' ], - -[ "VMS->catpath('','','file')", 'file' ], -[ "VMS->catpath('','[d1.d2.d3]','')", '[d1.d2.d3]' ], -[ "VMS->catpath('','[.d1.d2.d3]','')", '[.d1.d2.d3]' ], -[ "VMS->catpath('','[d1.d2.d3]','file')", '[d1.d2.d3]file' ], -[ "VMS->catpath('','[.d1.d2.d3]','file')", '[.d1.d2.d3]file' ], -[ "VMS->catpath('','d1/d2/d3','file')", '[.d1.d2.d3]file' ], -[ "VMS->catpath('v','d1/d2/d3','file')", 'v:[.d1.d2.d3]file' ], -[ "VMS->catpath('node::volume:','[d1.d2.d3]','')", 'node::volume:[d1.d2.d3]' ], -[ "VMS->catpath('node::volume:','[d1.d2.d3]','file')", 'node::volume:[d1.d2.d3]file' ], -[ "VMS->catpath('node\"access_spec\"::volume:','[d1.d2.d3]','')", 'node"access_spec"::volume:[d1.d2.d3]' ], -[ "VMS->catpath('node\"access_spec\"::volume:','[d1.d2.d3]','file')", 'node"access_spec"::volume:[d1.d2.d3]file' ], - -[ "VMS->canonpath('')", '' ], -[ "VMS->canonpath('volume:[d1]file')", 'volume:[d1]file' ], -[ "VMS->canonpath('volume:[d1.-.d2.][d3.d4.-]')", 'volume:[d2.d3]' ], -[ "VMS->canonpath('volume:[000000.d1]d2.dir;1')", 'volume:[d1]d2.dir;1' ], - -[ "VMS->splitdir('')", '' ], -[ "VMS->splitdir('[]')", '' ], -[ "VMS->splitdir('d1.d2.d3')", 'd1,d2,d3' ], -[ "VMS->splitdir('[d1.d2.d3]')", 'd1,d2,d3' ], -[ "VMS->splitdir('.d1.d2.d3')", ',d1,d2,d3' ], -[ "VMS->splitdir('[.d1.d2.d3]')", ',d1,d2,d3' ], -[ "VMS->splitdir('.-.d2.d3')", ',-,d2,d3' ], -[ "VMS->splitdir('[.-.d2.d3]')", ',-,d2,d3' ], - -[ "VMS->catdir('')", '' ], -[ "VMS->catdir('d1','d2','d3')", '[.d1.d2.d3]' ], -[ "VMS->catdir('d1','d2/','d3')", '[.d1.d2.d3]' ], -[ "VMS->catdir('','d1','d2','d3')", '[.d1.d2.d3]' ], -[ "VMS->catdir('','-','d2','d3')", '[-.d2.d3]' ], -[ "VMS->catdir('','-','','d3')", '[-.d3]' ], -[ "VMS->catdir('dir.dir','d2.dir','d3.dir')", '[.dir.d2.d3]' ], -[ "VMS->catdir('[.name]')", '[.name]' ], -[ "VMS->catdir('[.name]','[.name]')", '[.name.name]'], - -[ "VMS->abs2rel('node::volume:[t1.t2.t3]','[t1.t2.t3]')", '' ], -[ "VMS->abs2rel('node::volume:[t1.t2.t4]','[t1.t2.t3]')", '[-.t4]' ], -[ "VMS->abs2rel('[t1.t2.t3]','[t1.t2.t3]')", '' ], -[ "VMS->abs2rel('[t1.t2.t3]file','[t1.t2.t3]')", 'file' ], -[ "VMS->abs2rel('[t1.t2.t4]','[t1.t2.t3]')", '[-.t4]' ], -[ "VMS->abs2rel('[t1.t2]file','[t1.t2.t3]')", '[-]file' ], -[ "VMS->abs2rel('[t1.t2.t3.t4]','[t1.t2.t3]')", '[t4]' ], -[ "VMS->abs2rel('[t4.t5.t6]','[t1.t2.t3]')", '[---.t4.t5.t6]' ], -[ "VMS->abs2rel('[000000]','[t1.t2.t3]')", '[---.000000]' ], -[ "VMS->abs2rel('a:[t1.t2.t4]','[t1.t2.t3]')", '[-.t4]' ], -[ "VMS->abs2rel('[a.-.b.c.-]','[t1.t2.t3]')", '[---.b]' ], - -[ "VMS->rel2abs('[.t4]','[t1.t2.t3]')", '[t1.t2.t3.t4]' ], -[ "VMS->rel2abs('[.t4.t5]','[t1.t2.t3]')", '[t1.t2.t3.t4.t5]' ], -[ "VMS->rel2abs('[]','[t1.t2.t3]')", '[t1.t2.t3]' ], -[ "VMS->rel2abs('[-]','[t1.t2.t3]')", '[t1.t2]' ], -[ "VMS->rel2abs('[-.t4]','[t1.t2.t3]')", '[t1.t2.t4]' ], -[ "VMS->rel2abs('[t1]','[t1.t2.t3]')", '[t1]' ], - -[ "OS2->catdir('A:/d1','B:/d2','d3','')", 'A:/d1/B:/d2/d3' ], -[ "OS2->catfile('a','b','c')", 'a/b/c' ], - -[ "Mac->splitpath('file')", ',,file' ], -[ "Mac->splitpath(':file')", ',:,file' ], -[ "Mac->splitpath(':d1',1)", ',:d1:,' ], -[ "Mac->splitpath('d1',1)", 'd1:,,' ], -[ "Mac->splitpath('d1:d2:d3:')", 'd1:,d2:d3:,' ], -[ "Mac->splitpath('d1:d2:d3',1)", 'd1:,d2:d3:,' ], -[ "Mac->splitpath(':d1:d2:d3:')", ',:d1:d2:d3:,' ], -[ "Mac->splitpath(':d1:d2:d3:',1)", ',:d1:d2:d3:,' ], -[ "Mac->splitpath('d1:d2:d3:file')", 'd1:,d2:d3:,file' ], -[ "Mac->splitpath('d1:d2:d3',1)", 'd1:,d2:d3:,' ], - -[ "Mac->catdir('')", ':' ], -[ "Mac->catdir('d1','d2','d3')", 'd1:d2:d3:' ], -[ "Mac->catdir('d1','d2/','d3')", 'd1:d2/:d3:' ], -[ "Mac->catdir('','d1','d2','d3')", ':d1:d2:d3:' ], -[ "Mac->catdir('','','d2','d3')", '::d2:d3:' ], -[ "Mac->catdir('','','','d3')", ':::d3:' ], -[ "Mac->catdir(':name')", ':name:' ], -[ "Mac->catdir(':name',':name')", ':name:name:' ], - -[ "Mac->catfile('a','b','c')", 'a:b:c' ], - -[ "Mac->canonpath('')", '' ], -[ "Mac->canonpath(':')", ':' ], -[ "Mac->canonpath('::')", '::' ], -[ "Mac->canonpath('a::')", 'a::' ], -[ "Mac->canonpath(':a::')", ':a::' ], - -[ "Mac->abs2rel('t1:t2:t3','t1:t2:t3')", ':' ], -[ "Mac->abs2rel('t1:t2','t1:t2:t3')", '::' ], -[ "Mac->abs2rel('t1:t4','t1:t2:t3')", ':::t4' ], -[ "Mac->abs2rel('t1:t2:t4','t1:t2:t3')", '::t4' ], -[ "Mac->abs2rel('t1:t2:t3:t4','t1:t2:t3')", ':t4' ], -[ "Mac->abs2rel('t4:t5:t6','t1:t2:t3')", '::::t4:t5:t6' ], -[ "Mac->abs2rel('t1','t1:t2:t3')", ':::' ], - -[ "Mac->rel2abs(':t4','t1:t2:t3')", 't1:t2:t3:t4' ], -[ "Mac->rel2abs(':t4:t5','t1:t2:t3')", 't1:t2:t3:t4:t5' ], -[ "Mac->rel2abs('','t1:t2:t3')", '' ], -[ "Mac->rel2abs('::','t1:t2:t3')", 't1:t2:t3::' ], -[ "Mac->rel2abs('::t4','t1:t2:t3')", 't1:t2:t3::t4' ], -[ "Mac->rel2abs('t1','t1:t2:t3')", 't1' ], -) ; - -# Grab all of the plain routines from File::Spec -use File::Spec @File::Spec::EXPORT_OK ; - -require File::Spec::Unix ; -require File::Spec::Win32 ; - -eval { - require VMS::Filespec ; -} ; - -my $skip_exception = "Install VMS::Filespec (from vms/ext)" ; - -if ( $@ ) { - # Not pretty, but it allows testing of things not implemented soley - # on VMS. It might be better to change File::Spec::VMS to do this, - # making it more usable when running on (say) Unix but working with - # VMS paths. - eval qq- - sub File::Spec::VMS::vmsify { die "$skip_exception" } - sub File::Spec::VMS::unixify { die "$skip_exception" } - sub File::Spec::VMS::vmspath { die "$skip_exception" } - - ; - $INC{"VMS/Filespec.pm"} = 1 ; -} -require File::Spec::VMS ; - -require File::Spec::OS2 ; -require File::Spec::Mac ; - -print "1..", scalar( @tests ), "\n" ; - -my $current_test= 1 ; - -# Test out the class methods -for ( @tests ) { - tryfunc( @$_ ) ; -} - - - -# -# Tries a named function with the given args and compares the result against -# an expected result. Works with functions that return scalars or arrays. -# -sub tryfunc { - my $function = shift ; - my $expected = shift ; - my $platform = shift ; - - if ($platform && $^O ne $platform) { - print "ok $current_test # skipped: $function\n" ; - ++$current_test ; - return; - } - - $function =~ s#\\#\\\\#g ; - - my $got ; - if ( $function =~ /^[^\$].*->/ ) { - $got = eval( "join( ',', File::Spec::$function )" ) ; - } - else { - $got = eval( "join( ',', $function )" ) ; - } - - if ( $@ ) { - if ( substr( $@, 0, length $skip_exception ) eq $skip_exception ) { - chomp $@ ; - print "ok $current_test # skip $function: $@\n" ; - } - else { - chomp $@ ; - print "not ok $current_test # $function: $@\n" ; - } - } - elsif ( !defined( $got ) || $got ne $expected ) { - print "not ok $current_test # $function: got '$got', expected '$expected'\n" ; - } - else { - print "ok $current_test # $function\n" ; - } - ++$current_test ; -} diff --git a/t/lib/filestat.t b/t/lib/filestat.t deleted file mode 100644 index ac6d95f745..0000000000 --- a/t/lib/filestat.t +++ /dev/null @@ -1,70 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -BEGIN { - our $hasst; - eval { my @n = stat "TEST" }; - $hasst = 1 unless $@ && $@ =~ /unimplemented/; - unless ($hasst) { print "1..0 # Skip: no stat\n"; exit 0 } - use Config; - $hasst = 0 unless $Config{'i_sysstat'} eq 'define'; - unless ($hasst) { print "1..0 # Skip: no sys/stat.h\n"; exit 0 } -} - -BEGIN { - our @stat = stat "TEST"; # This is the function stat. - unless (@stat) { print "1..0 # Skip: no file TEST\n"; exit 0 } -} - -print "1..14\n"; - -use File::stat; - -print "ok 1\n"; - -my $stat = stat "TEST"; # This is the OO stat. - -print "not " unless $stat->dev == $stat[ 0]; -print "ok 2\n"; - -print "not " unless $stat->ino == $stat[ 1]; -print "ok 3\n"; - -print "not " unless $stat->mode == $stat[ 2]; -print "ok 4\n"; - -print "not " unless $stat->nlink == $stat[ 3]; -print "ok 5\n"; - -print "not " unless $stat->uid == $stat[ 4]; -print "ok 6\n"; - -print "not " unless $stat->gid == $stat[ 5]; -print "ok 7\n"; - -print "not " unless $stat->rdev == $stat[ 6]; -print "ok 8\n"; - -print "not " unless $stat->size == $stat[ 7]; -print "ok 9\n"; - -print "not " unless $stat->atime == $stat[ 8]; -print "ok 10\n"; - -print "not " unless $stat->mtime == $stat[ 9]; -print "ok 11\n"; - -print "not " unless $stat->ctime == $stat[10]; -print "ok 12\n"; - -print "not " unless $stat->blksize == $stat[11]; -print "ok 13\n"; - -print "not " unless $stat->blocks == $stat[12]; -print "ok 14\n"; - -# Testing pretty much anything else is unportable. diff --git a/t/lib/filter-simple.t b/t/lib/filter-simple.t deleted file mode 100644 index 3fb32701c5..0000000000 --- a/t/lib/filter-simple.t +++ /dev/null @@ -1,27 +0,0 @@ -#!./perl - -BEGIN { - chdir('t') if -d 't'; - @INC = 'lib'; -} - -print "1..6\n"; - -use MyFilter qr/not ok/ => "ok", fail => "ok"; - -sub fail { print "fail ", $_[0], "\n" } - -print "not ok 1\n"; -print "fail 2\n"; - -fail(3); -&fail(4); - -print "not " unless "whatnot okapi" eq "whatokapi"; -print "ok 5\n"; - -no MyFilter; - -print "not " unless "not ok" =~ /^not /; -print "ok 6\n"; - diff --git a/t/lib/filter-util.t b/t/lib/filter-util.t deleted file mode 100644 index dc667c98ee..0000000000 --- a/t/lib/filter-util.t +++ /dev/null @@ -1,795 +0,0 @@ -BEGIN { - chdir('t') if -d 't'; - @INC = '.'; - push @INC, '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ m{\bFilter/Util/Call\b}) { - print "1..0 # Skip: Filter::Util::Call was not built\n"; - exit 0; - } - require 'lib/filter-util.pl'; -} - -use strict; -use warnings; - -use vars qw($Inc $Perl); - -print "1..28\n" ; - -$Perl = "$Perl -w" ; - -use Cwd ; -my $here = getcwd ; - - -my $filename = "call.tst" ; -my $filenamebin = "call.bin" ; -my $module = "MyTest" ; -my $module2 = "MyTest2" ; -my $module3 = "MyTest3" ; -my $module4 = "MyTest4" ; -my $module5 = "MyTest5" ; -my $nested = "nested" ; -my $block = "block" ; - -# Test error cases -################## - -# no filter function in module -############################### - -writeFile("${module}.pm", <<EOM) ; -package ${module} ; - -use Filter::Util::Call ; - -sub import { filter_add(bless []) } - -1 ; -EOM - -my $a = `$Perl "-I." $Inc -e "use ${module} ;" 2>&1` ; -ok(1, (($? >>8) != 0 or (($^O eq 'MSWin32' || $^O eq 'NetWare') && $? != 0))) ; -ok(2, $a =~ /^Can't locate object method "filter" via package "MyTest"/) ; - -# no reference parameter in filter_add -###################################### - -writeFile("${module}.pm", <<EOM) ; -package ${module} ; - -use Filter::Util::Call ; - -sub import { filter_add() } - -1 ; -EOM - -$a = `$Perl "-I." $Inc -e "use ${module} ;" 2>&1` ; -ok(3, (($? >>8) != 0 or (($^O eq 'MSWin32' || $^O eq 'NetWare') && $? != 0))) ; -#ok(4, $a =~ /^usage: filter_add\(ref\) at ${module}.pm/) ; -ok(4, $a =~ /^Not enough arguments for Filter::Util::Call::filter_add/) ; - - - - -# non-error cases -################# - - -# a simple filter, using a closure -################# - -writeFile("${module}.pm", <<EOM, <<'EOM') ; -package ${module} ; - -EOM -use Filter::Util::Call ; -sub import { - filter_add( - sub { - - my ($status) ; - - if (($status = filter_read()) > 0) { - s/ABC/DEF/g - } - $status ; - } ) ; -} - -1 ; -EOM - -writeFile($filename, <<EOM, <<'EOM') ; - -use $module ; -EOM - -use Cwd ; -$here = getcwd ; -print "I am $here\n" ; -print "some letters ABC\n" ; -$y = "ABCDEF" ; -print <<EOF ; -Alphabetti Spagetti ($y) -EOF - -EOM - -$a = `$Perl "-I." $Inc $filename 2>&1` ; -ok(5, ($? >>8) == 0) ; -ok(6, $a eq <<EOM) ; -I am $here -some letters DEF -Alphabetti Spagetti (DEFDEF) -EOM - -# a simple filter, not using a closure -################# - -writeFile("${module}.pm", <<EOM, <<'EOM') ; -package ${module} ; - -EOM -use Filter::Util::Call ; -sub import { filter_add(bless []) } - -sub filter -{ - my ($self) = @_ ; - my ($status) ; - - if (($status = filter_read()) > 0) { - s/ABC/DEF/g - } - $status ; -} - - -1 ; -EOM - -writeFile($filename, <<EOM, <<'EOM') ; - -use $module ; -EOM - -use Cwd ; -$here = getcwd ; -print "I am $here\n" ; -print "some letters ABC\n" ; -$y = "ABCDEF" ; -print <<EOF ; -Alphabetti Spagetti ($y) -EOF - -EOM - -$a = `$Perl "-I." $Inc $filename 2>&1` ; -ok(7, ($? >>8) == 0) ; -ok(8, $a eq <<EOM) ; -I am $here -some letters DEF -Alphabetti Spagetti (DEFDEF) -EOM - - -# nested filters -################ - - -writeFile("${module2}.pm", <<EOM, <<'EOM') ; -package ${module2} ; -use Filter::Util::Call ; - -EOM -sub import { filter_add(bless []) } - -sub filter -{ - my ($self) = @_ ; - my ($status) ; - - if (($status = filter_read()) > 0) { - s/XYZ/PQR/g - } - $status ; -} - -1 ; -EOM - -writeFile("${module3}.pm", <<EOM, <<'EOM') ; -package ${module3} ; -use Filter::Util::Call ; - -EOM -sub import { filter_add( - - sub - { - my ($status) ; - - if (($status = filter_read()) > 0) { - s/Fred/Joe/g - } - $status ; - } ) ; -} - -1 ; -EOM - -writeFile("${module4}.pm", <<EOM) ; -package ${module4} ; - -use $module5 ; - -print "I'm feeling used!\n" ; -print "Fred Joe ABC DEF PQR XYZ\n" ; -print "See you Today\n" ; -1; -EOM - -writeFile("${module5}.pm", <<EOM, <<'EOM') ; -package ${module5} ; -use Filter::Util::Call ; - -EOM -sub import { filter_add(bless []) } - -sub filter -{ - my ($self) = @_ ; - my ($status) ; - - if (($status = filter_read()) > 0) { - s/Today/Tomorrow/g - } - $status ; -} - -1 ; -EOM - -writeFile($filename, <<EOM, <<'EOM') ; - -# two filters for this file -use $module ; -use $module2 ; -require "$nested" ; -use $module4 ; -EOM - -print "some letters ABCXYZ\n" ; -$y = "ABCDEFXYZ" ; -print <<EOF ; -Fred likes Alphabetti Spagetti ($y) -EOF - -EOM - -writeFile($nested, <<EOM, <<'EOM') ; -use $module3 ; -EOM - -print "This is another file XYZ\n" ; -print <<EOF ; -Where is Fred? -EOF - -EOM - -$a = `$Perl "-I." $Inc $filename 2>&1` ; -ok(9, ($? >>8) == 0) ; -ok(10, $a eq <<EOM) ; -I'm feeling used! -Fred Joe ABC DEF PQR XYZ -See you Tomorrow -This is another file XYZ -Where is Joe? -some letters DEFPQR -Fred likes Alphabetti Spagetti (DEFDEFPQR) -EOM - -# using the module context (with a closure) -########################################### - - -writeFile("${module2}.pm", <<EOM, <<'EOM') ; -package ${module2} ; -use Filter::Util::Call ; - -EOM -sub import -{ - my ($type) = shift ; - my (@strings) = @_ ; - - - filter_add ( - - sub - { - my ($status) ; - my ($pattern) ; - - if (($status = filter_read()) > 0) { - foreach $pattern (@strings) - { s/$pattern/PQR/g } - } - - $status ; - } - ) - -} -1 ; -EOM - - -writeFile($filename, <<EOM, <<'EOM') ; - -use $module2 qw( XYZ KLM) ; -use $module2 qw( ABC NMO) ; -EOM - -print "some letters ABCXYZ KLM NMO\n" ; -$y = "ABCDEFXYZKLMNMO" ; -print <<EOF ; -Alphabetti Spagetti ($y) -EOF - -EOM - -$a = `$Perl "-I." $Inc $filename 2>&1` ; -ok(11, ($? >>8) == 0) ; -ok(12, $a eq <<EOM) ; -some letters PQRPQR PQR PQR -Alphabetti Spagetti (PQRDEFPQRPQRPQR) -EOM - - - -# using the module context (without a closure) -############################################## - - -writeFile("${module2}.pm", <<EOM, <<'EOM') ; -package ${module2} ; -use Filter::Util::Call ; - -EOM -sub import -{ - my ($type) = shift ; - my (@strings) = @_ ; - - - filter_add (bless [@strings]) -} - -sub filter -{ - my ($self) = @_ ; - my ($status) ; - my ($pattern) ; - - if (($status = filter_read()) > 0) { - foreach $pattern (@$self) - { s/$pattern/PQR/g } - } - - $status ; -} - -1 ; -EOM - - -writeFile($filename, <<EOM, <<'EOM') ; - -use $module2 qw( XYZ KLM) ; -use $module2 qw( ABC NMO) ; -EOM - -print "some letters ABCXYZ KLM NMO\n" ; -$y = "ABCDEFXYZKLMNMO" ; -print <<EOF ; -Alphabetti Spagetti ($y) -EOF - -EOM - -$a = `$Perl "-I." $Inc $filename 2>&1` ; -ok(13, ($? >>8) == 0) ; -ok(14, $a eq <<EOM) ; -some letters PQRPQR PQR PQR -Alphabetti Spagetti (PQRDEFPQRPQRPQR) -EOM - -# multi line test -################# - - -writeFile("${module2}.pm", <<EOM, <<'EOM') ; -package ${module2} ; -use Filter::Util::Call ; - -EOM -sub import -{ - my ($type) = shift ; - my (@strings) = @_ ; - - - filter_add(bless []) -} - -sub filter -{ - my ($self) = @_ ; - my ($status) ; - - # read first line - if (($status = filter_read()) > 0) { - chop ; - s/\r$//; - # and now the second line (it will append) - $status = filter_read() ; - } - - $status ; -} - -1 ; -EOM - - -writeFile($filename, <<EOM, <<'EOM') ; - -use $module2 ; -EOM -print "don't cut me -in half\n" ; -print -<<EOF ; -appen -ded -EO -F - -EOM - -$a = `$Perl "-I." $Inc $filename 2>&1` ; -ok(15, ($? >>8) == 0) ; -ok(16, $a eq <<EOM) ; -don't cut me in half -appended -EOM - -# Block test -############# - -writeFile("${block}.pm", <<EOM, <<'EOM') ; -package ${block} ; -use Filter::Util::Call ; - -EOM -sub import -{ - my ($type) = shift ; - my (@strings) = @_ ; - - - filter_add (bless [@strings] ) -} - -sub filter -{ - my ($self) = @_ ; - my ($status) ; - my ($pattern) ; - - filter_read(20) ; -} - -1 ; -EOM - -my $string = <<'EOM' ; -print "hello mum\n" ; -$x = 'me ' x 3 ; -print "Who wants it?\n$x\n" ; -EOM - - -writeFile($filename, <<EOM, $string ) ; -use $block ; -EOM - -$a = `$Perl "-I." $Inc $filename 2>&1` ; -ok(17, ($? >>8) == 0) ; -ok(18, $a eq <<EOM) ; -hello mum -Who wants it? -me me me -EOM - -# use in the filter -#################### - -writeFile("${block}.pm", <<EOM, <<'EOM') ; -package ${block} ; -use Filter::Util::Call ; - -EOM -use Cwd ; - -sub import -{ - my ($type) = shift ; - my (@strings) = @_ ; - - - filter_add(bless [@strings] ) -} - -sub filter -{ - my ($self) = @_ ; - my ($status) ; - my ($here) = quotemeta getcwd ; - - if (($status = filter_read()) > 0) { - s/DIR/$here/g - } - $status ; -} - -1 ; -EOM - -writeFile($filename, <<EOM, <<'EOM') ; -use $block ; -EOM -print "We are in DIR\n" ; -EOM - -$a = `$Perl "-I." $Inc $filename 2>&1` ; -ok(19, ($? >>8) == 0) ; -ok(20, $a eq <<EOM) ; -We are in $here -EOM - - -# filter_del -############# - -writeFile("${block}.pm", <<EOM, <<'EOM') ; -package ${block} ; -use Filter::Util::Call ; - -EOM - -sub import -{ - my ($type) = shift ; - my ($count) = @_ ; - - - filter_add(bless \$count ) -} - -sub filter -{ - my ($self) = @_ ; - my ($status) ; - - s/HERE/THERE/g - if ($status = filter_read()) > 0 ; - - -- $$self ; - filter_del() if $$self <= 0 ; - - $status ; -} - -1 ; -EOM - -writeFile($filename, <<EOM, <<'EOM') ; -use $block (3) ; -EOM -print " -HERE I am -I am HERE -HERE today gone tomorrow\n" ; -EOM - -$a = `$Perl "-I." $Inc $filename 2>&1` ; -ok(21, ($? >>8) == 0) ; -ok(22, $a eq <<EOM) ; - -THERE I am -I am THERE -HERE today gone tomorrow -EOM - - -# filter_read_exact -#################### - -writeFile("${block}.pm", <<EOM, <<'EOM') ; -package ${block} ; -use Filter::Util::Call ; - -EOM - -sub import -{ - my ($type) = shift ; - - filter_add(bless [] ) -} - -sub filter -{ - my ($self) = @_ ; - my ($status) ; - - if (($status = filter_read_exact(9)) > 0) { - s/HERE/THERE/g - } - - $status ; -} - -1 ; -EOM - -writeFile($filenamebin, <<EOM, <<'EOM') ; -use $block ; -EOM -print " -HERE I am -I'm HERE -HERE today gone tomorrow\n" ; -EOM - -$a = `$Perl "-I." $Inc $filenamebin 2>&1` ; -ok(23, ($? >>8) == 0) ; -ok(24, $a eq <<EOM) ; - -HERE I am -I'm THERE -THERE today gone tomorrow -EOM - -{ - -# Check __DATA__ -#################### - -writeFile("${block}.pm", <<EOM, <<'EOM') ; -package ${block} ; -use Filter::Util::Call ; - -EOM - -sub import -{ - my ($type) = shift ; - - filter_add(bless [] ) -} - -sub filter -{ - my ($self) = @_ ; - my ($status) ; - - if (($status = filter_read()) > 0) { - s/HERE/THERE/g - } - - $status ; -} - -1 ; -EOM - -writeFile($filename, <<EOM, <<'EOM') ; -use $block ; -EOM -print "HERE HERE\n"; -@a = <DATA>; -print @a; -__DATA__ -HERE I am -I'm HERE -HERE today gone tomorrow -EOM - -$a = `$Perl "-I." $Inc $filename 2>&1` ; -ok(25, ($? >>8) == 0) ; -ok(26, $a eq <<EOM) ; -THERE THERE -HERE I am -I'm HERE -HERE today gone tomorrow -EOM - -} - -{ - -# Check __END__ -#################### - -writeFile("${block}.pm", <<EOM, <<'EOM') ; -package ${block} ; -use Filter::Util::Call ; - -EOM - -sub import -{ - my ($type) = shift ; - - filter_add(bless [] ) -} - -sub filter -{ - my ($self) = @_ ; - my ($status) ; - - if (($status = filter_read()) > 0) { - s/HERE/THERE/g - } - - $status ; -} - -1 ; -EOM - -writeFile($filename, <<EOM, <<'EOM') ; -use $block ; -EOM -print "HERE HERE\n"; -@a = <DATA>; -print @a; -__END__ -HERE I am -I'm HERE -HERE today gone tomorrow -EOM - -$a = `$Perl "-I." $Inc $filename 2>&1` ; -ok(27, ($? >>8) == 0) ; -ok(28, $a eq <<EOM) ; -THERE THERE -HERE I am -I'm HERE -HERE today gone tomorrow -EOM - -} - -END { - 1 while unlink $filename ; - 1 while unlink $filenamebin ; - 1 while unlink "${module}.pm" ; - 1 while unlink "${module2}.pm" ; - 1 while unlink "${module3}.pm" ; - 1 while unlink "${module4}.pm" ; - 1 while unlink "${module5}.pm" ; - 1 while unlink $nested ; - 1 while unlink "${block}.pm" ; -} - - diff --git a/t/lib/findbin.t b/t/lib/findbin.t deleted file mode 100755 index 3e742f9a4f..0000000000 --- a/t/lib/findbin.t +++ /dev/null @@ -1,13 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..1\n"; - -use FindBin qw($Bin); - -print "not " unless $Bin =~ m,t[/.]lib\]?$,; -print "ok 1\n"; diff --git a/t/lib/findtaint.t b/t/lib/findtaint.t deleted file mode 100644 index b2c33c4b4f..0000000000 --- a/t/lib/findtaint.t +++ /dev/null @@ -1,388 +0,0 @@ -#!./perl -T - - -my %Expect_File = (); # what we expect for $_ -my %Expect_Name = (); # what we expect for $File::Find::name/fullname -my %Expect_Dir = (); # what we expect for $File::Find::dir -my $symlink_exists = eval { symlink("",""); 1 }; -my $cwd; -my $cwd_untainted; - -BEGIN { - chdir 't' if -d 't'; - unshift @INC => '../lib'; - - for (keys %ENV) { # untaint ENV - ($ENV{$_}) = $ENV{$_} =~ /(.*)/; - } -} - -if ( $symlink_exists ) { print "1..45\n"; } -else { print "1..27\n"; } - -use File::Find; -use File::Spec; -use Cwd; - -# Remove insecure directories from PATH -my @path; -my $sep = ($^O eq 'MSWin32') ? ';' : ':'; -foreach my $dir (split(/$sep/,$ENV{'PATH'})) - { - push(@path,$dir) unless -w $dir; - } -$ENV{'PATH'} = join($sep,@path); - -cleanup(); - -find({wanted => sub { print "ok 1\n" if $_ eq 'filefind.t'; }, - untaint => 1, untaint_pattern => qr|^(.+)$|}, File::Spec->curdir); - -finddepth({wanted => sub { print "ok 2\n" if $_ eq 'filefind.t'; }, - untaint => 1, untaint_pattern => qr|^(.+)$|}, - File::Spec->curdir); - -my $case = 2; -my $FastFileTests_OK = 0; - -sub cleanup { - if (-d dir_path('for_find')) { - chdir(dir_path('for_find')); - } - if (-d dir_path('fa')) { - unlink file_path('fa', 'fa_ord'), - file_path('fa', 'fsl'), - file_path('fa', 'faa', 'faa_ord'), - file_path('fa', 'fab', 'fab_ord'), - file_path('fa', 'fab', 'faba', 'faba_ord'), - file_path('fb', 'fb_ord'), - file_path('fb', 'fba', 'fba_ord'); - rmdir dir_path('fa', 'faa'); - rmdir dir_path('fa', 'fab', 'faba'); - rmdir dir_path('fa', 'fab'); - rmdir dir_path('fa'); - rmdir dir_path('fb', 'fba'); - rmdir dir_path('fb'); - chdir File::Spec->updir; - rmdir dir_path('for_find'); - } -} - -END { - cleanup(); -} - -sub Check($) { - $case++; - if ($_[0]) { print "ok $case\n"; } - else { print "not ok $case\n"; } -} - -sub CheckDie($) { - $case++; - if ($_[0]) { print "ok $case\n"; } - else { print "not ok $case\n $!\n"; exit 0; } -} - -sub touch { - CheckDie( open(my $T,'>',$_[0]) ); -} - -sub MkDir($$) { - CheckDie( mkdir($_[0],$_[1]) ); -} - -sub wanted_File_Dir { - print "# \$File::Find::dir => '$File::Find::dir'\n"; - print "# \$_ => '$_'\n"; - s#\.$## if ($^O eq 'VMS' && $_ ne '.'); - Check( $Expect_File{$_} ); - if ( $FastFileTests_OK ) { - delete $Expect_File{ $_} - unless ( $Expect_Dir{$_} && ! -d _ ); - } else { - delete $Expect_File{$_} - unless ( $Expect_Dir{$_} && ! -d $_ ); - } -} - -sub wanted_File_Dir_prune { - &wanted_File_Dir; - $File::Find::prune=1 if $_ eq 'faba'; -} - - -sub simple_wanted { - print "# \$File::Find::dir => '$File::Find::dir'\n"; - print "# \$_ => '$_'\n"; -} - - -# Use dir_path() to specify a directory path that's expected for -# $File::Find::dir (%Expect_Dir). Also use it in file operations like -# chdir, rmdir etc. -# -# dir_path() concatenates directory names to form a _relative_ -# directory path, independant from the platform it's run on, although -# there are limitations. Don't try to create an absolute path, -# because that may fail on operating systems that have the concept of -# volume names (e.g. Mac OS). Be careful when you want to create an -# updir path like ../fa (Unix) or ::fa: (Mac OS). Plain directory -# names will work best. As a special case, you can pass it a "." as -# first argument, to create a directory path like "./fa/dir" on -# operating systems other than Mac OS (actually, Mac OS will ignore -# the ".", if it's the first argument). If there's no second argument, -# this function will return the empty string on Mac OS and the string -# "./" otherwise. - -sub dir_path { - my $first_item = shift @_; - - if ($first_item eq '.') { - if ($^O eq 'MacOS') { - return '' unless @_; - # ignore first argument; return a relative path - # with leading ":" and with trailing ":" - return File::Spec->catdir("", @_); - } else { # other OS - return './' unless @_; - my $path = File::Spec->catdir(@_); - # add leading "./" - $path = "./$path"; - return $path; - } - - } else { # $first_item ne '.' - return $first_item unless @_; # return plain filename - if ($^O eq 'MacOS') { - # relative path with leading ":" and with trailing ":" - return File::Spec->catdir("", $first_item, @_); - } else { # other OS - return File::Spec->catdir($first_item, @_); - } - } -} - - -# Use topdir() to specify a directory path that you want to pass to -#find/finddepth Basically, topdir() does the same as dir_path() (see -#above), except that there's no trailing ":" on Mac OS. - -sub topdir { - my $path = dir_path(@_); - $path =~ s/:$// if ($^O eq 'MacOS'); - return $path; -} - - -# Use file_path() to specify a file path that's expected for $_ (%Expect_File). -# Also suitable for file operations like unlink etc. - -# file_path() concatenates directory names (if any) and a filename to -# form a _relative_ file path (the last argument is assumed to be a -# file). It's independant from the platform it's run on, although -# there are limitations (see the warnings for dir_path() above). As a -# special case, you can pass it a "." as first argument, to create a -# file path like "./fa/file" on operating systems other than Mac OS -# (actually, Mac OS will ignore the ".", if it's the first -# argument). If there's no second argument, this function will return -# the empty string on Mac OS and the string "./" otherwise. - -sub file_path { - my $first_item = shift @_; - - if ($first_item eq '.') { - if ($^O eq 'MacOS') { - return '' unless @_; - # ignore first argument; return a relative path - # with leading ":", but without trailing ":" - return File::Spec->catfile("", @_); - } else { # other OS - return './' unless @_; - my $path = File::Spec->catfile(@_); - # add leading "./" - $path = "./$path"; - return $path; - } - - } else { # $first_item ne '.' - return $first_item unless @_; # return plain filename - if ($^O eq 'MacOS') { - # relative path with leading ":", but without trailing ":" - return File::Spec->catfile("", $first_item, @_); - } else { # other OS - return File::Spec->catfile($first_item, @_); - } - } -} - - -# Use file_path_name() to specify a file path that's expected for -# $File::Find::Name (%Expect_Name). Note: When the no_chdir => 1 -# option is in effect, $_ is the same as $File::Find::Name. In that -# case, also use this function to specify a file path that's expected -# for $_. -# -# Basically, file_path_name() does the same as file_path() (see -# above), except that there's always a leading ":" on Mac OS, even for -# plain file/directory names. - -sub file_path_name { - my $path = file_path(@_); - $path = ":$path" if (($^O eq 'MacOS') && ($path !~ /:/)); - return $path; -} - - - -MkDir( dir_path('for_find'), 0770 ); -CheckDie(chdir( dir_path('for_find'))); - -$cwd = cwd(); # save cwd -( $cwd_untainted ) = $cwd =~ m|^(.+)$|; # untaint it - -MkDir( dir_path('fa'), 0770 ); -MkDir( dir_path('fb'), 0770 ); -touch( file_path('fb', 'fb_ord') ); -MkDir( dir_path('fb', 'fba'), 0770 ); -touch( file_path('fb', 'fba', 'fba_ord') ); -if ($^O eq 'MacOS') { - CheckDie( symlink(':fb',':fa:fsl') ) if $symlink_exists; -} else { - CheckDie( symlink('../fb','fa/fsl') ) if $symlink_exists; -} -touch( file_path('fa', 'fa_ord') ); - -MkDir( dir_path('fa', 'faa'), 0770 ); -touch( file_path('fa', 'faa', 'faa_ord') ); -MkDir( dir_path('fa', 'fab'), 0770 ); -touch( file_path('fa', 'fab', 'fab_ord') ); -MkDir( dir_path('fa', 'fab', 'faba'), 0770 ); -touch( file_path('fa', 'fab', 'faba', 'faba_ord') ); - -print "# check untainting (no follow)\n"; - -# untainting here should work correctly - -%Expect_File = (File::Spec->curdir => 1, file_path('fsl') => - 1,file_path('fa_ord') => 1, file_path('fab') => 1, - file_path('fab_ord') => 1, file_path('faba') => 1, - file_path('faa') => 1, file_path('faa_ord') => 1); -delete $Expect_File{ file_path('fsl') } unless $symlink_exists; -%Expect_Name = (); - -%Expect_Dir = ( dir_path('fa') => 1, dir_path('faa') => 1, - dir_path('fab') => 1, dir_path('faba') => 1, - dir_path('fb') => 1, dir_path('fba') => 1); - -delete @Expect_Dir{ dir_path('fb'), dir_path('fba') } unless $symlink_exists; - -File::Find::find( {wanted => \&wanted_File_Dir_prune, untaint => 1, - untaint_pattern => qr|^(.+)$|}, topdir('fa') ); - -Check( scalar(keys %Expect_File) == 0 ); - - -# don't untaint at all, should die -%Expect_File = (); -%Expect_Name = (); -%Expect_Dir = (); -undef $@; -eval {File::Find::find( {wanted => \&simple_wanted}, topdir('fa') );}; -Check( $@ =~ m|Insecure dependency| ); -chdir($cwd_untainted); - - -# untaint pattern doesn't match, should die -undef $@; - -eval {File::Find::find( {wanted => \&simple_wanted, untaint => 1, - untaint_pattern => qr|^(NO_MATCH)$|}, - topdir('fa') );}; - -Check( $@ =~ m|is still tainted| ); -chdir($cwd_untainted); - - -# untaint pattern doesn't match, should die when we chdir to cwd -print "# check untaint_skip (no follow)\n"; -undef $@; - -eval {File::Find::find( {wanted => \&simple_wanted, untaint => 1, - untaint_skip => 1, untaint_pattern => - qr|^(NO_MATCH)$|}, topdir('fa') );}; - -Check( $@ =~ m|insecure cwd| ); -chdir($cwd_untainted); - - -if ( $symlink_exists ) { - print "# --- symbolic link tests --- \n"; - $FastFileTests_OK= 1; - - print "# check untainting (follow)\n"; - - # untainting here should work correctly - # no_chdir is in effect, hence we use file_path_name to specify the expected paths for %Expect_File - - %Expect_File = (file_path_name('fa') => 1, - file_path_name('fa','fa_ord') => 1, - file_path_name('fa', 'fsl') => 1, - file_path_name('fa', 'fsl', 'fb_ord') => 1, - file_path_name('fa', 'fsl', 'fba') => 1, - file_path_name('fa', 'fsl', 'fba', 'fba_ord') => 1, - file_path_name('fa', 'fab') => 1, - file_path_name('fa', 'fab', 'fab_ord') => 1, - file_path_name('fa', 'fab', 'faba') => 1, - file_path_name('fa', 'fab', 'faba', 'faba_ord') => 1, - file_path_name('fa', 'faa') => 1, - file_path_name('fa', 'faa', 'faa_ord') => 1); - - %Expect_Name = (); - - %Expect_Dir = (dir_path('fa') => 1, - dir_path('fa', 'faa') => 1, - dir_path('fa', 'fab') => 1, - dir_path('fa', 'fab', 'faba') => 1, - dir_path('fb') => 1, - dir_path('fb', 'fba') => 1); - - File::Find::find( {wanted => \&wanted_File_Dir, follow_fast => 1, - no_chdir => 1, untaint => 1, untaint_pattern => - qr|^(.+)$| }, topdir('fa') ); - - Check( scalar(keys %Expect_File) == 0 ); - - - # don't untaint at all, should die - undef $@; - - eval {File::Find::find( {wanted => \&simple_wanted, follow => 1}, - topdir('fa') );}; - - Check( $@ =~ m|Insecure dependency| ); - chdir($cwd_untainted); - - # untaint pattern doesn't match, should die - undef $@; - - eval {File::Find::find( {wanted => \&simple_wanted, follow => 1, - untaint => 1, untaint_pattern => - qr|^(NO_MATCH)$|}, topdir('fa') );}; - - Check( $@ =~ m|is still tainted| ); - chdir($cwd_untainted); - - # untaint pattern doesn't match, should die when we chdir to cwd - print "# check untaint_skip (follow)\n"; - undef $@; - - eval {File::Find::find( {wanted => \&simple_wanted, untaint => 1, - untaint_skip => 1, untaint_pattern => - qr|^(NO_MATCH)$|}, topdir('fa') );}; - - Check( $@ =~ m|insecure cwd| ); - chdir($cwd_untainted); - -} - diff --git a/t/lib/ftmp-mktemp.t b/t/lib/ftmp-mktemp.t deleted file mode 100755 index 4e31d01a3f..0000000000 --- a/t/lib/ftmp-mktemp.t +++ /dev/null @@ -1,115 +0,0 @@ -#!/usr/bin/perl -w - -# Test for mktemp family of commands in File::Temp -# Use STANDARD safe level for these tests - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Test; import Test; - plan(tests => 9); -} - -use strict; - -use File::Spec; -use File::Path; -use File::Temp qw/ :mktemp unlink0 /; -use FileHandle; - -ok(1); - -# MKSTEMP - test - -# Create file in temp directory -my $template = File::Spec->catfile(File::Spec->tmpdir, 'wowserXXXX'); - -(my $fh, $template) = mkstemp($template); - -print "# MKSTEMP: FH is $fh File is $template fileno=".fileno($fh)."\n"; -# Check if the file exists -ok( (-e $template) ); - -# Autoflush -$fh->autoflush(1) if $] >= 5.006; - -# Try printing something to the file -my $string = "woohoo\n"; -print $fh $string; - -# rewind the file -ok(seek( $fh, 0, 0)); - -# Read from the file -my $line = <$fh>; - -# compare with previous string -ok($string, $line); - -# Tidy up -# This test fails on Windows NT since it seems that the size returned by -# stat(filehandle) does not always equal the size of the stat(filename) -# This must be due to caching. In particular this test writes 7 bytes -# to the file which are not recognised by stat(filename) -# Simply waiting 3 seconds seems to be enough for the system to update - -if ($^O eq 'MSWin32') { - sleep 3; -} -my $status = unlink0($fh, $template); -if ($status) { - ok( $status ); -} else { - skip("Skip test failed probably due to \$TMPDIR being on NFS",1); -} - -# MKSTEMPS -# File with suffix. This is created in the current directory so -# may be problematic on NFS - -$template = "suffixXXXXXX"; -my $suffix = ".dat"; - -($fh, my $fname) = mkstemps($template, $suffix); - -print "# MKSTEMPS: File is $template -> $fname fileno=".fileno($fh)."\n"; -# Check if the file exists -ok( (-e $fname) ); - -# This fails if you are running on NFS -# If this test fails simply skip it rather than doing a hard failure -$status = unlink0($fh, $fname); - -if ($status) { - ok($status); -} else { - skip("Skip test failed probably due to cwd being on NFS",1) -} - -# MKDTEMP -# Temp directory - -$template = File::Spec->catdir(File::Spec->tmpdir, 'tmpdirXXXXXX'); - -my $tmpdir = mkdtemp($template); - -print "# MKDTEMP: Name is $tmpdir from template $template\n"; - -ok( (-d $tmpdir ) ); - -# Need to tidy up after myself -rmtree($tmpdir); - -# MKTEMP -# Just a filename, not opened - -$template = File::Spec->catfile(File::Spec->tmpdir, 'mytestXXXXXX'); - -my $tmpfile = mktemp($template); - -print "# MKTEMP: Tempfile is $template -> $tmpfile\n"; - -# Okay if template no longer has XXXXX in - - -ok( ($tmpfile !~ /XXXXX$/) ); diff --git a/t/lib/ftmp-posix.t b/t/lib/ftmp-posix.t deleted file mode 100755 index 0a5e86061b..0000000000 --- a/t/lib/ftmp-posix.t +++ /dev/null @@ -1,83 +0,0 @@ -#!/usr/bin/perl -w -# Test for File::Temp - POSIX functions - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Test; import Test; - plan(tests => 7); -} - -use strict; - -use File::Temp qw/ :POSIX unlink0 /; -use FileHandle; - -ok(1); - -# TMPNAM - scalar - -print "# TMPNAM: in a scalar context: \n"; -my $tmpnam = tmpnam(); - -# simply check that the file does not exist -# Not a 100% water tight test though if another program -# has managed to create one in the meantime. -ok( !(-e $tmpnam )); - -print "# TMPNAM file name: $tmpnam\n"; - -# TMPNAM list context -# Not strict posix behaviour -(my $fh, $tmpnam) = tmpnam(); - -print "# TMPNAM: in list context: $fh $tmpnam\n"; - -# File is opened - make sure it exists -ok( (-e $tmpnam )); - -# Unlink it - a possible NFS issue again if TMPDIR is not a local disk -my $status = unlink0($fh, $tmpnam); -if ($status) { - ok( $status ); -} else { - skip("Skip test failed probably due to \$TMPDIR being on NFS",1); -} - -# TMPFILE - -$fh = tmpfile(); - -if (defined $fh) { - ok( $fh ); - print "# TMPFILE: tmpfile got FH $fh\n"; - - $fh->autoflush(1) if $] >= 5.006; - - # print something to it - my $original = "Hello a test\n"; - print "# TMPFILE: Wrote line: $original"; - print $fh $original - or die "Error printing to tempfile\n"; - - # rewind it - ok( seek($fh,0,0) ); - - # Read from it - my $line = <$fh>; - - print "# TMPFILE: Read line: $line"; - ok( $original, $line); - - close($fh); - -} else { - # Skip all the remaining tests - foreach (1..3) { - skip("Skip test failed probably due to \$TMPDIR being on NFS",1); - } -} - - - - diff --git a/t/lib/ftmp-security.t b/t/lib/ftmp-security.t deleted file mode 100755 index f9be237dd3..0000000000 --- a/t/lib/ftmp-security.t +++ /dev/null @@ -1,140 +0,0 @@ -#!/usr/bin/perl -w -# Test for File::Temp - Security levels - -# Some of the security checking will not work on all platforms -# Test a simple open in the cwd and tmpdir foreach of the -# security levels - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Test; import Test; - plan(tests => 13); -} - -use strict; -use File::Spec; - -# Set up END block - this needs to happen before we load -# File::Temp since this END block must be evaluated after the -# END block configured by File::Temp -my @files; # list of files to remove -END { foreach (@files) { ok( !(-e $_) )} } - -use File::Temp qw/ tempfile unlink0 /; -ok(1); - -# The high security tests must currently be skipped on some platforms -my $skipplat = ( ( - # No sticky bits. - $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'os2' || $^O eq 'dos' - ) ? 1 : 0 ); - -# Can not run high security tests in perls before 5.6.0 -my $skipperl = ($] < 5.006 ? 1 : 0 ); - -# Determine whether we need to skip things and why -my $skip = 0; -if ($skipplat) { - $skip = "Skip Not supported on this platform"; -} elsif ($skipperl) { - $skip = "Skip Perl version must be v5.6.0 for these tests"; - -} - -print "# We will be skipping some tests : $skip\n" if $skip; - -# start off with basic checking - -File::Temp->safe_level( File::Temp::STANDARD ); - -print "# Testing with STANDARD security...\n"; - -&test_security(0); - -# Try medium - -File::Temp->safe_level( File::Temp::MEDIUM ) - unless $skip; - -print "# Testing with MEDIUM security...\n"; - -# Now we need to start skipping tests -&test_security($skip); - -# Try HIGH - -File::Temp->safe_level( File::Temp::HIGH ) - unless $skip; - -print "# Testing with HIGH security...\n"; - -&test_security($skip); - -exit; - -# Subroutine to open two temporary files. -# one is opened in the current dir and the other in the temp dir - -sub test_security { - - # Read in the skip flag - my $skip = shift; - - # If we are skipping we need to simply fake the correct number - # of tests -- we dont use skip since the tempfile() commands will - # fail with MEDIUM/HIGH security before the skip() command would be run - if ($skip) { - - skip($skip,1); - skip($skip,1); - - # plus we need an end block so the tests come out in the right order - eval q{ END { skip($skip,1); skip($skip,1) } 1; } || die; - - return; - } - - # Create the tempfile - my $template = "tmpXXXXX"; - my ($fh1, $fname1) = eval { tempfile ( $template, - DIR => File::Spec->tmpdir, - UNLINK => 1, - ); - }; - - if (defined $fname1) { - print "# fname1 = $fname1\n"; - ok( (-e $fname1) ); - push(@files, $fname1); # store for end block - } elsif (File::Temp->safe_level() != File::Temp::STANDARD) { - my $skip2 = "Skip system possibly insecure, see INSTALL, section 'make test'"; - skip($skip2, 1); - # plus we need an end block so the tests come out in the right order - eval q{ END { skip($skip2,1); } 1; } || die; - } else { - ok(0); - } - - # Explicitly - if ( $< < File::Temp->top_system_uid() ){ - skip("Skip Test inappropriate for root", 1); - eval q{ END { skip($skip,1); } 1; } || die; - return; - } - my ($fh2, $fname2) = eval { tempfile ($template, UNLINK => 1 ); }; - if (defined $fname2) { - print "# fname2 = $fname2\n"; - ok( (-e $fname2) ); - push(@files, $fname2); # store for end block - close($fh2); - } elsif (File::Temp->safe_level() != File::Temp::STANDARD) { - my $skip2 = "Skip system possibly insecure, see INSTALL, section 'make test'"; - skip($skip2, 1); - # plus we need an end block so the tests come out in the right order - eval q{ END { skip($skip2,1); } 1; } || die; - } else { - ok(0); - } - -} diff --git a/t/lib/ftmp-tempfile.t b/t/lib/ftmp-tempfile.t deleted file mode 100755 index ed59765a75..0000000000 --- a/t/lib/ftmp-tempfile.t +++ /dev/null @@ -1,145 +0,0 @@ -#!/usr/local/bin/perl -w -# Test for File::Temp - tempfile function - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Test; import Test; - plan(tests => 20); -} - -use strict; -use File::Spec; - -# Will need to check that all files were unlinked correctly -# Set up an END block here to do it - -# Arrays containing list of dirs/files to test -my (@files, @dirs, @still_there); - -# And a test for files that should still be around -# These are tidied up -END { - foreach (@still_there) { - ok( -f $_ ); - ok( unlink( $_ ) ); - ok( !(-f $_) ); - } -} - -# Loop over an array hoping that the files dont exist -END { foreach (@files) { ok( !(-e $_) )} } - -# And a test for directories -END { foreach (@dirs) { ok( !(-d $_) )} } - -# Need to make sure that the END blocks are setup before -# the ones that File::Temp configures since END blocks are evaluated -# in revers order and we need to check the files *after* File::Temp -# removes them -use File::Temp qw/ tempfile tempdir/; - -# Now we start the tests properly -ok(1); - - -# Tempfile -# Open tempfile in some directory, unlink at end -my ($fh, $tempfile) = tempfile( - UNLINK => 1, - SUFFIX => '.txt', - ); - -ok( (-f $tempfile) ); -# Should still be around after closing -ok( close( $fh ) ); -ok( (-f $tempfile) ); -# Check again at exit -push(@files, $tempfile); - -# TEMPDIR test -# Create temp directory in current dir -my $template = 'tmpdirXXXXXX'; -print "# Template: $template\n"; -my $tempdir = tempdir( $template , - DIR => File::Spec->curdir, - CLEANUP => 1, - ); - -print "# TEMPDIR: $tempdir\n"; - -ok( (-d $tempdir) ); -push(@dirs, $tempdir); - -# Create file in the temp dir -($fh, $tempfile) = tempfile( - DIR => $tempdir, - UNLINK => 1, - SUFFIX => '.dat', - ); - -print "# TEMPFILE: Created $tempfile\n"; - -ok( (-f $tempfile)); -push(@files, $tempfile); - -# Test tempfile -# ..and again -($fh, $tempfile) = tempfile( - DIR => $tempdir, - ); - - -ok( (-f $tempfile )); -push(@files, $tempfile); - -print "# TEMPFILE: Created $tempfile\n"; - -# and another (with template) - -($fh, $tempfile) = tempfile( 'helloXXXXXXX', - DIR => $tempdir, - UNLINK => 1, - SUFFIX => '.dat', - ); - -print "# TEMPFILE: Created $tempfile\n"; - -ok( (-f $tempfile) ); -push(@files, $tempfile); - - -# Create a temporary file that should stay around after -# it has been closed -($fh, $tempfile) = tempfile( 'permXXXXXXX', UNLINK => 0 ); -print "# TEMPFILE: Created $tempfile\n"; -ok( -f $tempfile ); -ok( close( $fh ) ); -push( @still_there, $tempfile); # check at END - -# Would like to create a temp file and just retrieve the handle -# but the test is problematic since: -# - We dont know the filename so we cant check that it is tidied -# correctly -# - The unlink0 required on unix for tempfile creation will fail -# on NFS -# Try to do what we can. -# Tempfile croaks on error so we need an eval -$fh = eval { tempfile( 'ftmpXXXXX', DIR => File::Spec->tmpdir ) }; - -if ($fh) { - - # print something to it to make sure something is there - ok( print $fh "Test\n" ); - - # Close it - can not check it is gone since we dont know the name - ok( close($fh) ); - -} else { - skip "Skip Failed probably due to NFS", 1; - skip "Skip Failed probably due to NFS", 1; -} - -# Now END block will execute to test the removal of directories -print "# End of tests. Execute END blocks\n"; - diff --git a/t/lib/gdbm.t b/t/lib/gdbm.t deleted file mode 100755 index 0f5cfa0186..0000000000 --- a/t/lib/gdbm.t +++ /dev/null @@ -1,427 +0,0 @@ -#!./perl - -# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bGDBM_File\b/) { - print "1..0 # Skip: GDBM_File was not built\n"; - exit 0; - } -} - -use strict; -use warnings; - - -use GDBM_File; - -print "1..68\n"; - -unlink <Op.dbmx*>; - -umask(0); -my %h ; -print (tie(%h,'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640) ? "ok 1\n" : "not ok 1\n"); - -my $Dfile = "Op.dbmx.pag"; -if (! -e $Dfile) { - ($Dfile) = <Op.dbmx*>; -} -if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'dos') { - print "ok 2 # Skipped: different file permission semantics\n"; -} -else { - my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); - print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); -} -my $i = 0; -while (my ($key,$value) = each(%h)) { - $i++; -} -print (!$i ? "ok 3\n" : "not ok 3\n"); - -$h{'goner1'} = 'snork'; - -$h{'abc'} = 'ABC'; -$h{'def'} = 'DEF'; -$h{'jkl','mno'} = "JKL\034MNO"; -$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); -$h{'a'} = 'A'; -$h{'b'} = 'B'; -$h{'c'} = 'C'; -$h{'d'} = 'D'; -$h{'e'} = 'E'; -$h{'f'} = 'F'; -$h{'g'} = 'G'; -$h{'h'} = 'H'; -$h{'i'} = 'I'; - -$h{'goner2'} = 'snork'; -delete $h{'goner2'}; - -untie(%h); -print (tie(%h,'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640) ? "ok 4\n" : "not ok 4\n"); - -$h{'j'} = 'J'; -$h{'k'} = 'K'; -$h{'l'} = 'L'; -$h{'m'} = 'M'; -$h{'n'} = 'N'; -$h{'o'} = 'O'; -$h{'p'} = 'P'; -$h{'q'} = 'Q'; -$h{'r'} = 'R'; -$h{'s'} = 'S'; -$h{'t'} = 'T'; -$h{'u'} = 'U'; -$h{'v'} = 'V'; -$h{'w'} = 'W'; -$h{'x'} = 'X'; -$h{'y'} = 'Y'; -$h{'z'} = 'Z'; - -$h{'goner3'} = 'snork'; - -delete $h{'goner1'}; -delete $h{'goner3'}; - -my @keys = keys(%h); -my @values = values(%h); - -if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} - -while (my ($key,$value) = each(%h)) { - if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { - $key =~ y/a-z/A-Z/; - $i++ if $key eq $value; - } -} - -if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";} - -@keys = ('blurfl', keys(%h), 'dyick'); -if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";} - -$h{'foo'} = ''; -$h{''} = 'bar'; - -# check cache overflow and numeric keys and contents -my $ok = 1; -for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } -for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } -print ($ok ? "ok 8\n" : "not ok 8\n"); - -my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); -print ($size > 0 ? "ok 9\n" : "not ok 9\n"); - -@h{0..200} = 200..400; -my @foo = @h{0..200}; -print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; - -print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); -print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); - -untie %h; -unlink 'Op.dbmx.dir', $Dfile; - -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - -{ - # sub-class test - - package Another ; - - use strict ; - use warnings ; - - open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; - print FILE <<'EOM' ; - - package SubDB ; - - use strict ; - use vars qw(@ISA @EXPORT) ; - - require Exporter ; - use GDBM_File; - @ISA=qw(GDBM_File); - @EXPORT = @GDBM_File::EXPORT ; - - sub STORE { - my $self = shift ; - my $key = shift ; - my $value = shift ; - $self->SUPER::STORE($key, $value * 2) ; - } - - sub FETCH { - my $self = shift ; - my $key = shift ; - $self->SUPER::FETCH($key) - 1 ; - } - - sub A_new_method - { - my $self = shift ; - my $key = shift ; - my $value = $self->FETCH($key) ; - return "[[$value]]" ; - } - - 1 ; -EOM - - close FILE ; - - BEGIN { push @INC, '.'; } - unlink <dbhash.tmp*> ; - - eval 'use SubDB ; '; - main::ok(13, $@ eq "") ; - my %h ; - my $X ; - eval ' - $X = tie(%h, "SubDB","dbhash.tmp", &GDBM_WRCREAT, 0640 ); - ' ; - - main::ok(14, $@ eq "") ; - - my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; - main::ok(15, $@ eq "") ; - main::ok(16, $ret == 5) ; - - $ret = eval ' &GDBM_WRCREAT eq &main::GDBM_WRCREAT ' ; - main::ok(17, $@ eq "" ) ; - main::ok(18, $ret == 1) ; - - $ret = eval '$X->A_new_method("fred") ' ; - main::ok(19, $@ eq "") ; - main::ok(20, $ret eq "[[5]]") ; - - undef $X; - untie(%h); - unlink "SubDB.pm", <dbhash.tmp*> ; - -} - -{ - # DBM Filter tests - use strict ; - use warnings ; - my (%h, $db) ; - my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - - sub checkOutput - { - my($fk, $sk, $fv, $sv) = @_ ; - return - $fetch_key eq $fk && $store_key eq $sk && - $fetch_value eq $fv && $store_value eq $sv && - $_ eq 'original' ; - } - - unlink <Op.dbmx*>; - ok(21, $db = tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)) ; - - $db->filter_fetch_key (sub { $fetch_key = $_ }) ; - $db->filter_store_key (sub { $store_key = $_ }) ; - $db->filter_fetch_value (sub { $fetch_value = $_}) ; - $db->filter_store_value (sub { $store_value = $_ }) ; - - $_ = "original" ; - - $h{"fred"} = "joe" ; - # fk sk fv sv - ok(22, checkOutput( "", "fred", "", "joe")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(23, $h{"fred"} eq "joe"); - # fk sk fv sv - ok(24, checkOutput( "", "fred", "joe", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(25, $db->FIRSTKEY() eq "fred") ; - # fk sk fv sv - ok(26, checkOutput( "fred", "", "", "")) ; - - # replace the filters, but remember the previous set - my ($old_fk) = $db->filter_fetch_key - (sub { $_ = uc $_ ; $fetch_key = $_ }) ; - my ($old_sk) = $db->filter_store_key - (sub { $_ = lc $_ ; $store_key = $_ }) ; - my ($old_fv) = $db->filter_fetch_value - (sub { $_ = "[$_]"; $fetch_value = $_ }) ; - my ($old_sv) = $db->filter_store_value - (sub { s/o/x/g; $store_value = $_ }) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - $h{"Fred"} = "Joe" ; - # fk sk fv sv - ok(27, checkOutput( "", "fred", "", "Jxe")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(28, $h{"Fred"} eq "[Jxe]"); - # fk sk fv sv - ok(29, checkOutput( "", "fred", "[Jxe]", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(30, $db->FIRSTKEY() eq "FRED") ; - # fk sk fv sv - ok(31, checkOutput( "FRED", "", "", "")) ; - - # put the original filters back - $db->filter_fetch_key ($old_fk); - $db->filter_store_key ($old_sk); - $db->filter_fetch_value ($old_fv); - $db->filter_store_value ($old_sv); - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - $h{"fred"} = "joe" ; - ok(32, checkOutput( "", "fred", "", "joe")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(33, $h{"fred"} eq "joe"); - ok(34, checkOutput( "", "fred", "joe", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(35, $db->FIRSTKEY() eq "fred") ; - ok(36, checkOutput( "fred", "", "", "")) ; - - # delete the filters - $db->filter_fetch_key (undef); - $db->filter_store_key (undef); - $db->filter_fetch_value (undef); - $db->filter_store_value (undef); - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - $h{"fred"} = "joe" ; - ok(37, checkOutput( "", "", "", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(38, $h{"fred"} eq "joe"); - ok(39, checkOutput( "", "", "", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(40, $db->FIRSTKEY() eq "fred") ; - ok(41, checkOutput( "", "", "", "")) ; - - undef $db ; - untie %h; - unlink <Op.dbmx*>; -} - -{ - # DBM Filter with a closure - - use strict ; - use warnings ; - my (%h, $db) ; - - unlink <Op.dbmx*>; - ok(42, $db = tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)) ; - - my %result = () ; - - sub Closure - { - my ($name) = @_ ; - my $count = 0 ; - my @kept = () ; - - return sub { ++$count ; - push @kept, $_ ; - $result{$name} = "$name - $count: [@kept]" ; - } - } - - $db->filter_store_key(Closure("store key")) ; - $db->filter_store_value(Closure("store value")) ; - $db->filter_fetch_key(Closure("fetch key")) ; - $db->filter_fetch_value(Closure("fetch value")) ; - - $_ = "original" ; - - $h{"fred"} = "joe" ; - ok(43, $result{"store key"} eq "store key - 1: [fred]"); - ok(44, $result{"store value"} eq "store value - 1: [joe]"); - ok(45, !defined $result{"fetch key"} ); - ok(46, !defined $result{"fetch value"} ); - ok(47, $_ eq "original") ; - - ok(48, $db->FIRSTKEY() eq "fred") ; - ok(49, $result{"store key"} eq "store key - 1: [fred]"); - ok(50, $result{"store value"} eq "store value - 1: [joe]"); - ok(51, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(52, ! defined $result{"fetch value"} ); - ok(53, $_ eq "original") ; - - $h{"jim"} = "john" ; - ok(54, $result{"store key"} eq "store key - 2: [fred jim]"); - ok(55, $result{"store value"} eq "store value - 2: [joe john]"); - ok(56, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(57, ! defined $result{"fetch value"} ); - ok(58, $_ eq "original") ; - - ok(59, $h{"fred"} eq "joe"); - ok(60, $result{"store key"} eq "store key - 3: [fred jim fred]"); - ok(61, $result{"store value"} eq "store value - 2: [joe john]"); - ok(62, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(63, $result{"fetch value"} eq "fetch value - 1: [joe]"); - ok(64, $_ eq "original") ; - - undef $db ; - untie %h; - unlink <Op.dbmx*>; -} - -{ - # DBM Filter recursion detection - use strict ; - use warnings ; - my (%h, $db) ; - unlink <Op.dbmx*>; - - ok(65, $db = tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)) ; - - $db->filter_store_key (sub { $_ = $h{$_} }) ; - - eval '$h{1} = 1234' ; - ok(66, $@ =~ /^recursion detected in filter_store_key at/ ); - - undef $db ; - untie %h; - unlink <Op.dbmx*>; -} - -{ - # Bug ID 20001013.009 - # - # test that $hash{KEY} = undef doesn't produce the warning - # Use of uninitialized value in null operation - use warnings ; - use strict ; - use GDBM_File ; - - unlink <Op.dbmx*>; - my %h ; - my $a = ""; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - - ok(67, tie(%h, 'GDBM_File','Op.dbmx', &GDBM_WRCREAT, 0640)); - $h{ABC} = undef; - ok(68, $a eq "") ; - untie %h; - unlink <Op.dbmx*>; -} diff --git a/t/lib/getopt.t b/t/lib/getopt.t deleted file mode 100755 index fb70f10aae..0000000000 --- a/t/lib/getopt.t +++ /dev/null @@ -1,73 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..11\n"; - -use Getopt::Std; - -# First we test the getopt function -@ARGV = qw(-xo -f foo -y file); -getopt('f'); - -print "not " if "@ARGV" ne 'file'; -print "ok 1\n"; - -print "not " unless $opt_x && $opt_o && opt_y; -print "ok 2\n"; - -print "not " unless $opt_f eq 'foo'; -print "ok 3\n"; - - -# Then we try the getopts -$opt_o = $opt_i = $opt_f = undef; -@ARGV = qw(-foi -i file); -getopts('oif:') or print "not "; -print "ok 4\n"; - -print "not " unless "@ARGV" eq 'file'; -print "ok 5\n"; - -print "not " unless $opt_i and $opt_f eq 'oi'; -print "ok 6\n"; - -print "not " if $opt_o; -print "ok 7\n"; - -# Try illegal options, but avoid printing of the error message - -open(STDERR, ">stderr") || die; - -@ARGV = qw(-h help); - -!getopts("xf:y") or print "not "; -print "ok 8\n"; - - -# Then try the Getopt::Long module - -use Getopt::Long; - -@ARGV = qw(--help --file foo --foo --nobar --num=5 -- file); - -GetOptions( - 'help' => \$HELP, - 'file:s' => \$FILE, - 'foo!' => \$FOO, - 'bar!' => \$BAR, - 'num:i' => \$NO, -) || print "not "; -print "ok 9\n"; - -print "not " unless $HELP && $FOO && !$BAR && $FILE eq 'foo' && $NO == 5; -print "ok 10\n"; - -print "not " unless "@ARGV" eq "file"; -print "ok 11\n"; - -close STDERR; -unlink "stderr"; diff --git a/t/lib/glob-basic.t b/t/lib/glob-basic.t deleted file mode 100755 index ef9dd96495..0000000000 --- a/t/lib/glob-basic.t +++ /dev/null @@ -1,175 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - if ($^O eq 'MacOS') { - @INC = qw(: ::lib ::macos:lib); - } else { - @INC = '.'; - push @INC, '../lib'; - } - require Config; import Config; - if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) { - print "1..0\n"; - exit 0; - } - print "1..11\n"; -} -END { - print "not ok 1\n" unless $loaded; -} -use File::Glob ':glob'; -use Cwd (); -$loaded = 1; -print "ok 1\n"; - -sub array { - return '(', join(", ", map {defined $_ ? "\"$_\"" : "undef"} @a), ")\n"; -} - -# look for the contents of the current directory -$ENV{PATH} = "/bin"; -delete @ENV{BASH_ENV, CDPATH, ENV, IFS}; -@correct = (); -if (opendir(D, $^O eq "MacOS" ? ":" : ".")) { - @correct = grep { !/^\./ } sort readdir(D); - closedir D; -} -@a = File::Glob::glob("*", 0); -@a = sort @a; -if ("@a" ne "@correct" || GLOB_ERROR) { - print "# |@a| ne |@correct|\nnot "; -} -print "ok 2\n"; - -# look up the user's home directory -# should return a list with one item, and not set ERROR -if ($^O ne 'MSWin32' && $^O ne 'NetWare' && $^O ne 'VMS') { - eval { - ($name, $home) = (getpwuid($>))[0,7]; - 1; - } and do { - @a = bsd_glob("~$name", GLOB_TILDE); - if (scalar(@a) != 1 || $a[0] ne $home || GLOB_ERROR) { - print "not "; - } - }; -} -print "ok 3\n"; - -# check backslashing -# should return a list with one item, and not set ERROR -@a = bsd_glob('TEST', GLOB_QUOTE); -if (scalar @a != 1 || $a[0] ne 'TEST' || GLOB_ERROR) { - local $/ = "]["; - print "# [@a]\n"; - print "not "; -} -print "ok 4\n"; - -# check nonexistent checks -# should return an empty list -# XXX since errfunc is NULL on win32, this test is not valid there -@a = bsd_glob("asdfasdf", 0); -if (($^O ne 'MSWin32' && $^O ne 'NetWare') and scalar @a != 0) { - print "# |@a|\nnot "; -} -print "ok 5\n"; - -# check bad protections -# should return an empty list, and set ERROR -if ($^O eq 'mpeix' or $^O eq 'MSWin32' or $^O eq 'NetWare' or $^O eq 'os2' or $^O eq 'VMS' - or $^O eq 'cygwin' or Cwd::cwd() =~ m#^$Config{'afsroot'}#s or not $>) -{ - print "ok 6 # skipped\n"; -} -else { - $dir = "pteerslt"; - mkdir $dir, 0; - @a = bsd_glob("$dir/*", GLOB_ERR); - #print "\@a = ", array(@a); - rmdir $dir; - if (scalar(@a) != 0 || GLOB_ERROR == 0) { - print "not "; - } - print "ok 6\n"; -} - -# check for csh style globbing -@a = bsd_glob('{a,b}', GLOB_BRACE | GLOB_NOMAGIC); -unless (@a == 2 and $a[0] eq 'a' and $a[1] eq 'b') { - print "not "; -} -print "ok 7\n"; - -@a = bsd_glob( - '{TES*,doesntexist*,a,b}', - GLOB_BRACE | GLOB_NOMAGIC | ($^O eq 'VMS' ? GLOB_NOCASE : 0) -); - -# Working on t/TEST often causes this test to fail because it sees Emacs temp -# and RCS files. Filter them out, and .pm files too, and patch temp files. -@a = grep !/(,v$|~$|\.(pm|ori?g|rej)$)/, @a; - -print "# @a\n"; - -unless (@a == 3 - and $a[0] eq ($^O eq 'VMS'? 'test.' : 'TEST') - and $a[1] eq 'a' - and $a[2] eq 'b') -{ - print "not ok 8 # @a"; -} else { - print "ok 8\n"; -} - -# "~" should expand to $ENV{HOME} -$ENV{HOME} = "sweet home"; -@a = bsd_glob('~', GLOB_TILDE | GLOB_NOMAGIC); -unless ($^O eq "MacOS" || (@a == 1 and $a[0] eq $ENV{HOME})) { - print "not "; -} -print "ok 9\n"; - -# GLOB_ALPHASORT (default) should sort alphabetically regardless of case -mkdir "pteerslt", 0777; -chdir "pteerslt"; - -@f_names = qw(Ax.pl Bx.pl Cx.pl aY.pl bY.pl cY.pl); -@f_alpha = qw(Ax.pl aY.pl Bx.pl bY.pl Cx.pl cY.pl); -if ('a' lt 'A') { # EBCDIC char sets sort lower case before UPPER - @f_names = sort(@f_names); -} -if ($^O eq 'VMS') { # VMS is happily caseignorant - @f_alpha = qw(ax.pl ay.pl bx.pl by.pl cx.pl cy.pl); - @f_names = @f_alpha; -} - -for (@f_names) { - open T, "> $_"; - close T; -} - -$pat = "*.pl"; - -$ok = 1; -@g_names = bsd_glob($pat, 0); -print "# f_names = @f_names\n"; -print "# g_names = @g_names\n"; -for (@f_names) { - $ok = 0 unless $_ eq shift @g_names; -} -print $ok ? "ok 10\n" : "not ok 10\n"; - -$ok = 1; -@g_alpha = bsd_glob($pat); -print "# f_alpha = @f_alpha\n"; -print "# g_alpha = @g_alpha\n"; -for (@f_alpha) { - $ok = 0 unless $_ eq shift @g_alpha; -} -print $ok ? "ok 11\n" : "not ok 11\n"; - -unlink @f_names; -chdir ".."; -rmdir "pteerslt"; diff --git a/t/lib/glob-case.t b/t/lib/glob-case.t deleted file mode 100755 index 3c3980c880..0000000000 --- a/t/lib/glob-case.t +++ /dev/null @@ -1,60 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - if ($^O eq 'MacOS') { - @INC = qw(: ::lib ::macos:lib); - } else { - @INC = '.'; - push @INC, '../lib'; - } - require Config; import Config; - if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) { - print "1..0\n"; - exit 0; - } - print "1..7\n"; -} -END { - print "not ok 1\n" unless $loaded; -} -use File::Glob qw(:glob csh_glob); -$loaded = 1; -print "ok 1\n"; - -my $pat = $^O eq "MacOS" ? ":lib:G*.t" : "lib/G*.t"; - -# Test the actual use of the case sensitivity tags, via csh_glob() -import File::Glob ':nocase'; -@a = csh_glob($pat); # At least glob-basic.t glob-case.t glob-global.t -print "not " unless @a >= 3; -print "ok 2\n"; - -# This may fail on systems which are not case-PRESERVING -import File::Glob ':case'; -@a = csh_glob($pat); # None should be uppercase -print "not " unless @a == 0; -print "ok 3\n"; - -# Test the explicit use of the GLOB_NOCASE flag -@a = bsd_glob($pat, GLOB_NOCASE); -print "not " unless @a >= 3; -print "ok 4\n"; - -# Test Win32 backslash nastiness... -if ($^O ne 'MSWin32' && $^O ne 'NetWare') { - print "ok 5\nok 6\nok 7\n"; -} -else { - @a = File::Glob::glob("lib\\g*.t"); - print "not " unless @a >= 3; - print "ok 5\n"; - mkdir "[]", 0; - @a = File::Glob::glob("\\[\\]", GLOB_QUOTE); - rmdir "[]"; - print "# returned @a\nnot " unless @a == 1; - print "ok 6\n"; - @a = bsd_glob("lib\\*", GLOB_QUOTE); - print "not " if @a == 0; - print "ok 7\n"; -} diff --git a/t/lib/glob-global.t b/t/lib/glob-global.t deleted file mode 100755 index 1d7903275b..0000000000 --- a/t/lib/glob-global.t +++ /dev/null @@ -1,152 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - if ($^O eq 'MacOS') { - @INC = qw(: ::lib ::macos:lib); - } else { - @INC = '.'; - push @INC, '../lib'; - } - require Config; import Config; - if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) { - print "1..0\n"; - exit 0; - } - print "1..10\n"; -} -END { - print "not ok 1\n" unless $loaded; -} - -BEGIN { - *CORE::GLOBAL::glob = sub { "Just another Perl hacker," }; -} - -BEGIN { - if ("Just another Perl hacker," ne (<*>)[0]) { - die <<EOMessage; -Your version of perl ($]) doesn't seem to allow extensions to override -the core glob operator. -EOMessage - } -} - -use File::Glob ':globally'; -$loaded = 1; -print "ok 1\n"; - -$_ = $^O eq "MacOS" ? ":lib:*.t" : "lib/*.t"; -my @r = glob; -print "not " if $_ ne ($^O eq "MacOS" ? ":lib:*.t" : "lib/*.t"); -print "ok 2\n"; - -# we should have at least basic.t, global.t, taint.t -print "# |@r|\nnot " if @r < 3; -print "ok 3\n"; - -# check if <*/*> works -if ($^O eq "MacOS") { - @r = <:*:*.t>; -} else { - @r = <*/*.t>; -} -# at least t/global.t t/basic.t, t/taint.t -print "not " if @r < 3; -print "ok 4\n"; -my $r = scalar @r; - -# check if scalar context works -@r = (); -if ($^O eq "MacOS") { - while (defined($_ = <:*:*.t>)) { - #print "# $_\n"; - push @r, $_; - } -} else { - while (defined($_ = <*/*.t>)) { - #print "# $_\n"; - push @r, $_; - } -} -print "not " if @r != $r; -print "ok 5\n"; - -# check if list context works -@r = (); -if ($^O eq "MacOS") { - for (<:*:*.t>) { - #print "# $_\n"; - push @r, $_; - } -} else { - for (<*/*.t>) { - #print "# $_\n"; - push @r, $_; - } -} -print "not " if @r != $r; -print "ok 6\n"; - -# test if implicit assign to $_ in while() works -@r = (); -if ($^O eq "MacOS") { - while (<:*:*.t>) { - #print "# $_\n"; - push @r, $_; - } -} else { - while (<*/*.t>) { - #print "# $_\n"; - push @r, $_; - } -} -print "not " if @r != $r; -print "ok 7\n"; - -# test if explicit glob() gets assign magic too -my @s = (); -while (glob($^O eq 'MacOS' ? ':*:*.t' : '*/*.t')) { - #print "# $_\n"; - push @s, $_; -} -print "not " if "@r" ne "@s"; -print "ok 8\n"; - -# how about in a different package, like? -package Foo; -use File::Glob ':globally'; -@s = (); -while (glob($^O eq 'MacOS' ? ':*:*.t' : '*/*.t')) { - #print "# $_\n"; - push @s, $_; -} -print "not " if "@r" ne "@s"; -print "ok 9\n"; - -# test if different glob ops maintain independent contexts -@s = (); -my $i = 0; -if ($^O eq "MacOS") { - while (<:*:*.t>) { - #print "# $_ <"; - push @s, $_; - while (<:bas*:*.t>) { - #print " $_"; - $i++; - } - #print " >\n"; - } -} else { - while (<*/*.t>) { - #print "# $_ <"; - push @s, $_; - while (<bas*/*.t>) { - #print " $_"; - $i++; - } - #print " >\n"; - } -} -print "not " if "@r" ne "@s" or not $i; -print "ok 10\n"; diff --git a/t/lib/glob-taint.t b/t/lib/glob-taint.t deleted file mode 100755 index 4c0990358d..0000000000 --- a/t/lib/glob-taint.t +++ /dev/null @@ -1,31 +0,0 @@ -#!./perl -T - -BEGIN { - chdir 't' if -d 't'; - if ($^O eq 'MacOS') { - @INC = qw(: ::lib ::macos:lib); - } else { - @INC = '.'; - push @INC, '../lib'; - } - require Config; import Config; - if ($Config{'extensions'} !~ /\bFile\/Glob\b/i) { - print "1..0\n"; - exit 0; - } - print "1..2\n"; -} -END { - print "not ok 1\n" unless $loaded; -} -use File::Glob; -$loaded = 1; -print "ok 1\n"; - -# all filenames should be tainted -@a = File::Glob::bsd_glob("*"); -eval { $a = join("",@a), kill 0; 1 }; -unless ($@ =~ /Insecure dependency/) { - print "not "; -} -print "ok 2\n"; diff --git a/t/lib/gol-basic.t b/t/lib/gol-basic.t deleted file mode 100755 index c5d857d5b8..0000000000 --- a/t/lib/gol-basic.t +++ /dev/null @@ -1,26 +0,0 @@ -#!./perl -w - -BEGIN { - chdir('t') if -d 't'; - @INC = '../lib'; -} - -use Getopt::Long qw(:config no_ignore_case); -die("Getopt::Long version 2.24 required--this is only version ". - $Getopt::Long::VERSION) - unless $Getopt::Long::VERSION >= 2.24; - -print "1..9\n"; - -@ARGV = qw(-Foo -baR --foo bar); -undef $opt_baR; -undef $opt_bar; -print "ok 1\n" if GetOptions ("foo", "Foo=s"); -print ((defined $opt_foo) ? "" : "not ", "ok 2\n"); -print (($opt_foo == 1) ? "" : "not ", "ok 3\n"); -print ((defined $opt_Foo) ? "" : "not ", "ok 4\n"); -print (($opt_Foo eq "-baR") ? "" : "not ", "ok 5\n"); -print ((@ARGV == 1) ? "" : "not ", "ok 6\n"); -print (($ARGV[0] eq "bar") ? "" : "not ", "ok 7\n"); -print (!(defined $opt_baR) ? "" : "not ", "ok 8\n"); -print (!(defined $opt_bar) ? "" : "not ", "ok 9\n"); diff --git a/t/lib/gol-compat.t b/t/lib/gol-compat.t deleted file mode 100755 index 0bbe386846..0000000000 --- a/t/lib/gol-compat.t +++ /dev/null @@ -1,25 +0,0 @@ -#!./perl -w - -BEGIN { - chdir('t') if -d 't'; - @INC = '../lib'; -} - -require "newgetopt.pl"; - -print "1..9\n"; - -@ARGV = qw(-Foo -baR --foo bar); -$newgetopt::ignorecase = 0; -$newgetopt::ignorecase = 0; -undef $opt_baR; -undef $opt_bar; -print "ok 1\n" if NGetOpt ("foo", "Foo=s"); -print ((defined $opt_foo) ? "" : "not ", "ok 2\n"); -print (($opt_foo == 1) ? "" : "not ", "ok 3\n"); -print ((defined $opt_Foo) ? "" : "not ", "ok 4\n"); -print (($opt_Foo eq "-baR") ? "" : "not ", "ok 5\n"); -print ((@ARGV == 1) ? "" : "not ", "ok 6\n"); -print (($ARGV[0] eq "bar") ? "" : "not ", "ok 7\n"); -print (!(defined $opt_baR) ? "" : "not ", "ok 8\n"); -print (!(defined $opt_bar) ? "" : "not ", "ok 9\n"); diff --git a/t/lib/gol-linkage.t b/t/lib/gol-linkage.t deleted file mode 100755 index 3bd81a3552..0000000000 --- a/t/lib/gol-linkage.t +++ /dev/null @@ -1,37 +0,0 @@ -#!./perl -w - -BEGIN { - chdir('t') if -d 't'; - @INC = '../lib'; -} - -use Getopt::Long; - -print "1..18\n"; - -@ARGV = qw(-Foo -baR --foo bar); -Getopt::Long::Configure ("no_ignore_case"); -%lnk = (); -print "ok 1\n" if GetOptions (\%lnk, "foo", "Foo=s"); -print ((defined $lnk{foo}) ? "" : "not ", "ok 2\n"); -print (($lnk{foo} == 1) ? "" : "not ", "ok 3\n"); -print ((defined $lnk{Foo}) ? "" : "not ", "ok 4\n"); -print (($lnk{Foo} eq "-baR") ? "" : "not ", "ok 5\n"); -print ((@ARGV == 1) ? "" : "not ", "ok 6\n"); -print (($ARGV[0] eq "bar") ? "" : "not ", "ok 7\n"); -print (!(exists $lnk{baR}) ? "" : "not ", "ok 8\n"); - -@ARGV = qw(-Foo -baR --foo bar); -Getopt::Long::Configure ("default","no_ignore_case"); -%lnk = (); -my $foo; -print "ok 9\n" if GetOptions (\%lnk, "foo" => \$foo, "Foo=s"); -print ((defined $foo) ? "" : "not ", "ok 10\n"); -print (($foo == 1) ? "" : "not ", "ok 11\n"); -print ((defined $lnk{Foo}) ? "" : "not ", "ok 12\n"); -print (($lnk{Foo} eq "-baR") ? "" : "not ", "ok 13\n"); -print ((@ARGV == 1) ? "" : "not ", "ok 14\n"); -print (($ARGV[0] eq "bar") ? "" : "not ", "ok 15\n"); -print (!(exists $lnk{foo}) ? "" : "not ", "ok 16\n"); -print (!(exists $lnk{baR}) ? "" : "not ", "ok 17\n"); -print (!(exists $lnk{bar}) ? "" : "not ", "ok 18\n"); diff --git a/t/lib/gol-oo.t b/t/lib/gol-oo.t deleted file mode 100644 index 98f3eaadb9..0000000000 --- a/t/lib/gol-oo.t +++ /dev/null @@ -1,26 +0,0 @@ -#!./perl -w - -BEGIN { - chdir('t') if -d 't'; - @INC = '../lib'; -} - -use Getopt::Long; -die("Getopt::Long version 2.24 required--this is only version ". - $Getopt::Long::VERSION) - unless $Getopt::Long::VERSION >= 2.24; -print "1..9\n"; - -@ARGV = qw(-Foo -baR --foo bar); -my $p = new Getopt::Long::Parser (config => ["no_ignore_case"]); -undef $opt_baR; -undef $opt_bar; -print "ok 1\n" if $p->getoptions ("foo", "Foo=s"); -print ((defined $opt_foo) ? "" : "not ", "ok 2\n"); -print (($opt_foo == 1) ? "" : "not ", "ok 3\n"); -print ((defined $opt_Foo) ? "" : "not ", "ok 4\n"); -print (($opt_Foo eq "-baR") ? "" : "not ", "ok 5\n"); -print ((@ARGV == 1) ? "" : "not ", "ok 6\n"); -print (($ARGV[0] eq "bar") ? "" : "not ", "ok 7\n"); -print (!(defined $opt_baR) ? "" : "not ", "ok 8\n"); -print (!(defined $opt_bar) ? "" : "not ", "ok 9\n"); diff --git a/t/lib/h2ph.t b/t/lib/h2ph.t deleted file mode 100755 index 7b339b3927..0000000000 --- a/t/lib/h2ph.t +++ /dev/null @@ -1,37 +0,0 @@ -#!./perl - -# quickie tests to see if h2ph actually runs and does more or less what is -# expected - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -my $extracted_program = '../utils/h2ph'; # unix, nt, ... -if ($^O eq 'VMS') { $extracted_program = '[-.utils]h2ph.com'; } -if (!(-e $extracted_program)) { - print "1..0 # Skip: $extracted_program was not built\n"; - exit 0; -} - -print "1..2\n"; - -# quickly compare two text files -sub txt_compare { - local ($/, $A, $B); - for (($A,$B) = @_) { open(_,"<$_") ? $_ = <_> : die "$_ : $!"; close _ } - $A cmp $B; -} - -# does it run? -$ok = system("$^X \"-I../lib\" $extracted_program -d. \"-Q\" lib/h2ph.h"); -print(($ok == 0 ? "" : "not "), "ok 1\n"); - -# does it work? well, does it do what we expect? :-) -$ok = txt_compare("lib/h2ph.ph", "lib/h2ph.pht"); -print(($ok == 0 ? "" : "not "), "ok 2\n"); - -# cleanup - should this be in an END block? -unlink("lib/h2ph.ph"); -unlink("_h2ph_pre.ph"); diff --git a/t/lib/hostname.t b/t/lib/hostname.t deleted file mode 100755 index 85a04cd488..0000000000 --- a/t/lib/hostname.t +++ /dev/null @@ -1,25 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bSys\/Hostname\b/) { - print "1..0 # Skip: Sys::Hostname was not built\n"; - exit 0; - } -} - -use Sys::Hostname; - -eval { - $host = hostname; -}; - -if ($@) { - print "1..0\n" if $@ =~ /Cannot get host name/; -} else { - print "1..1\n"; - print "# \$host = `$host'\n"; - print "ok 1\n"; -} diff --git a/t/lib/i18n-collate.t b/t/lib/i18n-collate.t deleted file mode 100644 index bf3ba20b6a..0000000000 --- a/t/lib/i18n-collate.t +++ /dev/null @@ -1,44 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if (!$Config{d_setlocale} || $Config{ccflags} =~ /\bD?NO_LOCALE\b/) { - print "1..0\n"; - exit; - } -} - -print "1..7\n"; - -use I18N::Collate; - -print "ok 1\n"; - -$a = I18N::Collate->new("foo"); - -print "ok 2\n"; - -{ - use warnings; - local $SIG{__WARN__} = sub { $@ = $_[0] }; - $b = I18N::Collate->new("foo"); - print "not " unless $@ =~ /\bHAS BEEN DEPRECATED\b/; - print "ok 3\n"; - $@ = ''; -} - -print "not " unless $a eq $b; -print "ok 4\n"; - -$b = I18N::Collate->new("bar"); -print "not " if $@ =~ /\bHAS BEEN DEPRECATED\b/; -print "ok 5\n"; - -print "not " if $a eq $b; -print "ok 6\n"; - -print "not " if $a lt $b == $a gt $b; -print "ok 7\n"; - diff --git a/t/lib/i18n-langtags.t b/t/lib/i18n-langtags.t deleted file mode 100644 index 06c178ef27..0000000000 --- a/t/lib/i18n-langtags.t +++ /dev/null @@ -1,45 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -######################### We start with some black magic to print on failure. -require 5; - -use strict; -use Test; -BEGIN { plan tests => 23 }; -BEGIN { ok 1 } -use I18N::LangTags qw(is_language_tag same_language_tag - extract_language_tags super_languages - similarity_language_tag is_dialect_of - locale2language_tag alternate_language_tags - encode_language_tag - ); - -ok !is_language_tag(''); -ok is_language_tag('fr'); -ok is_language_tag('fr-ca'); -ok is_language_tag('fr-CA'); -ok !is_language_tag('fr-CA-'); -ok !is_language_tag('fr_CA'); -ok is_language_tag('fr-ca-joual'); -ok !is_language_tag('frca'); -ok is_language_tag('nav'); -ok is_language_tag('nav-shiprock'); -ok !is_language_tag('nav-ceremonial'); # subtag too long -ok !is_language_tag('x'); -ok !is_language_tag('i'); -ok is_language_tag('i-borg'); # NB: fictitious tag -ok is_language_tag('x-borg'); -ok is_language_tag('x-borg-prot5123'); -ok same_language_tag('x-borg-prot5123', 'i-BORG-Prot5123' ); -ok !same_language_tag('en', 'en-us' ); - -ok 0 == similarity_language_tag('en-ca', 'fr-ca'); -ok 1 == similarity_language_tag('en-ca', 'en-us'); -ok 2 == similarity_language_tag('en-us-southern', 'en-us-western'); -ok 2 == similarity_language_tag('en-us-southern', 'en-us'); - -# print "So there!\n"; - diff --git a/t/lib/io_const.t b/t/lib/io_const.t deleted file mode 100755 index db1a322453..0000000000 --- a/t/lib/io_const.t +++ /dev/null @@ -1,33 +0,0 @@ - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib'; - } -} - -use Config; - -BEGIN { - if(-d "lib" && -f "TEST") { - if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { - print "1..0\n"; - exit 0; - } - } -} - -use IO::Handle; - -print "1..6\n"; -my $i = 1; -foreach (qw(SEEK_SET SEEK_CUR SEEK_END _IOFBF _IOLBF _IONBF)) { - my $d1 = defined(&{"IO::Handle::" . $_}) ? 1 : 0; - my $v1 = $d1 ? &{"IO::Handle::" . $_}() : undef; - my $v2 = IO::Handle::constant($_); - my $d2 = defined($v2); - - print "not " - if($d1 != $d2 || ($d1 && ($v1 != $v2))); - print "ok ",$i++,"\n"; -} diff --git a/t/lib/io_dir.t b/t/lib/io_dir.t deleted file mode 100755 index 6ec4e9f232..0000000000 --- a/t/lib/io_dir.t +++ /dev/null @@ -1,68 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib'; - } - require Config; import Config; - if ($] < 5.00326 || not $Config{'d_readdir'}) { - print "1..0\n"; - exit 0; - } -} - -select(STDERR); $| = 1; -select(STDOUT); $| = 1; - -use IO::Dir qw(DIR_UNLINK); - -print "1..10\n"; - -my $DIR = $^O eq 'MacOS' ? ":" : "."; - -$dot = new IO::Dir $DIR; -print defined($dot) ? "ok" : "not ok", " 1\n"; - -@a = sort <*>; -do { $first = $dot->read } while defined($first) && $first =~ /^\./; -print +(grep { $_ eq $first } @a) ? "ok" : "not ok", " 2\n"; - -@b = sort($first, (grep {/^[^.]/} $dot->read)); -print +(join("\0", @a) eq join("\0", @b)) ? "ok" : "not ok", " 3\n"; - -$dot->rewind; -@c = sort grep {/^[^.]/} $dot->read; -print +(join("\0", @b) eq join("\0", @c)) ? "ok" : "not ok", " 4\n"; - -$dot->close; -$dot->rewind; -print defined($dot->read) ? "not ok" : "ok", " 5\n"; - -open(FH,'>X') || die "Can't create x"; -print FH "X"; -close(FH); - -tie %dir, IO::Dir, $DIR; -my @files = keys %dir; - -# I hope we do not have an empty dir :-) -print @files ? "ok" : "not ok", " 6\n"; - -my $stat = $dir{'X'}; -print defined($stat) && UNIVERSAL::isa($stat,'File::stat') && $stat->size == 1 - ? "ok" : "not ok", " 7\n"; - -delete $dir{'X'}; - -print -f 'X' ? "ok" : "not ok", " 8\n"; - -tie %dirx, IO::Dir, $DIR, DIR_UNLINK; - -my $statx = $dirx{'X'}; -print defined($statx) && UNIVERSAL::isa($statx,'File::stat') && $statx->size == 1 - ? "ok" : "not ok", " 9\n"; - -delete $dirx{'X'}; - -print -f 'X' ? "not ok" : "ok", " 10\n"; diff --git a/t/lib/io_dup.t b/t/lib/io_dup.t deleted file mode 100755 index 8983a56f36..0000000000 --- a/t/lib/io_dup.t +++ /dev/null @@ -1,61 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib'; - } -} - -use Config; - -BEGIN { - if(-d "lib" && -f "TEST") { - if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { - print "1..0\n"; - exit 0; - } - } -} - -use IO::Handle; -use IO::File; - -select(STDERR); $| = 1; -select(STDOUT); $| = 1; - -print "1..6\n"; - -print "ok 1\n"; - -$dupout = IO::Handle->new->fdopen( \*STDOUT ,"w"); -$duperr = IO::Handle->new->fdopen( \*STDERR ,"w"); - -$stdout = \*STDOUT; bless $stdout, "IO::File"; # "IO::Handle"; -$stderr = \*STDERR; bless $stderr, "IO::Handle"; - -$stdout->open( "Io.dup","w") || die "Can't open stdout"; -$stderr->fdopen($stdout,"w"); - -print $stdout "ok 2\n"; -print $stderr "ok 3\n"; -if ($^O eq 'MSWin32' || $^O eq 'NetWare') { - print `echo ok 4`; - print `echo ok 5 1>&2`; # does this *really* work? -} -else { - system 'echo ok 4'; - system 'echo ok 5 1>&2'; -} - -$stderr->close; -$stdout->close; - -$stdout->fdopen($dupout,"w"); -$stderr->fdopen($duperr,"w"); - -if ($^O eq 'MSWin32' || $^O eq 'NetWare') { print `type Io.dup` } -else { system 'cat Io.dup' } -unlink 'Io.dup'; - -print STDOUT "ok 6\n"; diff --git a/t/lib/io_linenum.t b/t/lib/io_linenum.t deleted file mode 100755 index cf55c980ea..0000000000 --- a/t/lib/io_linenum.t +++ /dev/null @@ -1,80 +0,0 @@ -#!./perl - -# test added 29th April 1999 by Paul Johnson (pjcj@transeda.com) -# updated 28th May 1999 by Paul Johnson - -my $File; - -BEGIN -{ - $File = __FILE__; - if (-d 't') - { - chdir 't'; - $File =~ s/^t\W+//; # Remove first directory - } - @INC = '../lib'; - require strict; import strict; -} - -use Test; - -BEGIN { plan tests => 12 } - -use IO::File; - -sub lineno -{ - my ($f) = @_; - my $l; - $l .= "$. "; - $l .= $f->input_line_number; - $l .= " $."; # check $. before and after input_line_number - $l; -} - -my $t; - -open (F, $File) or die $!; -my $io = IO::File->new($File) or die $!; - -<F> for (1 .. 10); -ok(lineno($io), "10 0 10"); - -$io->getline for (1 .. 5); -ok(lineno($io), "5 5 5"); - -<F>; -ok(lineno($io), "11 5 11"); - -$io->getline; -ok(lineno($io), "6 6 6"); - -$t = tell F; # tell F; provokes a warning -ok(lineno($io), "11 6 11"); - -<F>; -ok(lineno($io), "12 6 12"); - -select F; -ok(lineno($io), "12 6 12"); - -<F> for (1 .. 10); -ok(lineno($io), "22 6 22"); - -$io->getline for (1 .. 5); -ok(lineno($io), "11 11 11"); - -$t = tell F; -# We used to have problems here before local $. worked. -# input_line_number() used to use select and tell. When we did the -# same, that mechanism broke. It should work now. -ok(lineno($io), "22 11 22"); - -{ - local $.; - $io->getline for (1 .. 5); - ok(lineno($io), "16 16 16"); -} - -ok(lineno($io), "22 16 22"); diff --git a/t/lib/io_multihomed.t b/t/lib/io_multihomed.t deleted file mode 100644 index 62f25bc39e..0000000000 --- a/t/lib/io_multihomed.t +++ /dev/null @@ -1,128 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib'; - } -} - -use Config; - -BEGIN { - if(-d "lib" && -f "TEST") { - my $reason; - if (! $Config{'d_fork'}) { - $reason = 'no fork'; - } - elsif ($Config{'extensions'} !~ /\bSocket\b/) { - $reason = 'Socket extension unavailable'; - } - elsif ($Config{'extensions'} !~ /\bIO\b/) { - $reason = 'IO extension unavailable'; - } - if ($reason) { - print "1..0 # Skip: $reason\n"; - exit 0; - } - } -} - -$| = 1; - -print "1..8\n"; - -eval { - $SIG{ALRM} = sub { die; }; - alarm 60; -}; - -package Multi; -require IO::Socket::INET; -@ISA=qw(IO::Socket::INET); - -use Socket qw(inet_aton inet_ntoa unpack_sockaddr_in); - -sub _get_addr -{ - my($sock,$addr_str, $multi) = @_; - #print "_get_addr($sock, $addr_str, $multi)\n"; - - print "not " unless $multi; - print "ok 2\n"; - - ( - # private IP-addresses which I hope does not work anywhere :-) - inet_aton("10.250.230.10"), - inet_aton("10.250.230.12"), - inet_aton("127.0.0.1") # loopback - ) -} - -sub connect -{ - my $self = shift; - if (@_ == 1) { - my($port, $addr) = unpack_sockaddr_in($_[0]); - $addr = inet_ntoa($addr); - #print "connect($self, $port, $addr)\n"; - if($addr eq "10.250.230.10") { - print "ok 3\n"; - return 0; - } - if($addr eq "10.250.230.12") { - print "ok 4\n"; - return 0; - } - } - $self->SUPER::connect(@_); -} - - - -package main; - -use IO::Socket; - -$listen = IO::Socket::INET->new(Listen => 2, - Proto => 'tcp', - Timeout => 5, - ) or die "$!"; - -print "ok 1\n"; - -$port = $listen->sockport; - -if($pid = fork()) { - - $sock = $listen->accept() or die "$!"; - print "ok 5\n"; - - print $sock->getline(); - print $sock "ok 7\n"; - - waitpid($pid,0); - - $sock->close; - - print "ok 8\n"; - -} elsif(defined $pid) { - - $sock = Multi->new(PeerPort => $port, - Proto => 'tcp', - PeerAddr => 'localhost', - MultiHomed => 1, - Timeout => 1, - ) or die "$!"; - - print $sock "ok 6\n"; - sleep(1); # race condition - print $sock->getline(); - - $sock->close; - - exit; -} else { - die; -} diff --git a/t/lib/io_pipe.t b/t/lib/io_pipe.t deleted file mode 100755 index ae18224b12..0000000000 --- a/t/lib/io_pipe.t +++ /dev/null @@ -1,123 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib'; - } -} - -use Config; - -BEGIN { - if(-d "lib" && -f "TEST") { - my $reason; - if (! $Config{'d_fork'}) { - $reason = 'no fork'; - } - elsif ($Config{'extensions'} !~ /\bIO\b/) { - $reason = 'IO extension unavailable'; - } - undef $reason if $^O eq 'VMS'; - if ($reason) { - print "1..0 # Skip: $reason\n"; - exit 0; - } - } -} - -use IO::Pipe; - -my $perl = './perl'; - -$| = 1; -print "1..10\n"; - -$pipe = new IO::Pipe->reader($perl, '-e', 'print "not ok 1\n"'); -while (<$pipe>) { - s/^not //; - print; -} -$pipe->close or print "# \$!=$!\nnot "; -print "ok 2\n"; - -$cmd = 'BEGIN{$SIG{ALRM} = sub {print "not ok 4\n"; exit}; alarm 10} s/not //'; -$pipe = new IO::Pipe->writer($perl, '-pe', $cmd); -print $pipe "not ok 3\n" ; -$pipe->close or print "# \$!=$!\nnot "; -print "ok 4\n"; - -# Check if can fork with dynamic extensions (bug in CRT): -if ($^O eq 'os2' and - system "$^X -I../lib -MOpcode -e 'defined fork or die' > /dev/null 2>&1") { - print "ok $_ # skipped: broken fork\n" for 5..10; - exit 0; -} - -$pipe = new IO::Pipe; - -$pid = fork(); - -if($pid) - { - $pipe->writer; - print $pipe "Xk 5\n"; - print $pipe "oY 6\n"; - $pipe->close; - wait; - } -elsif(defined $pid) - { - $pipe->reader; - $stdin = bless \*STDIN, "IO::Handle"; - $stdin->fdopen($pipe,"r"); - exec 'tr', 'YX', 'ko'; - } -else - { - die "# error = $!"; - } - -$pipe = new IO::Pipe; -$pid = fork(); - -if($pid) - { - $pipe->reader; - while(<$pipe>) { - s/^not //; - print; - } - $pipe->close; - wait; - } -elsif(defined $pid) - { - $pipe->writer; - - $stdout = bless \*STDOUT, "IO::Handle"; - $stdout->fdopen($pipe,"w"); - print STDOUT "not ok 7\n"; - exec 'echo', 'not ok 8'; - } -else - { - die; - } - -$pipe = new IO::Pipe; -$pipe->writer; - -$SIG{'PIPE'} = 'broken_pipe'; - -sub broken_pipe { - print "ok 9\n"; -} - -print $pipe "not ok 9\n"; -$pipe->close; - -sleep 1; - -print "ok 10\n"; - diff --git a/t/lib/io_poll.t b/t/lib/io_poll.t deleted file mode 100755 index d31ea47f53..0000000000 --- a/t/lib/io_poll.t +++ /dev/null @@ -1,82 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib'; - } -} - -if ($^O eq 'mpeix') { - print "1..0 # Skip: broken on MPE/iX\n"; - exit 0; -} - -select(STDERR); $| = 1; -select(STDOUT); $| = 1; - -print "1..9\n"; - -use IO::Handle; -use IO::Poll qw(/POLL/); - -my $poll = new IO::Poll; - -my $stdout = \*STDOUT; -my $dupout = IO::Handle->new_from_fd(fileno($stdout),"w"); - -$poll->mask($stdout => POLLOUT); - -print "not " - unless $poll->mask($stdout) == POLLOUT; -print "ok 1\n"; - -$poll->mask($dupout => POLLPRI); - -print "not " - unless $poll->mask($dupout) == POLLPRI; -print "ok 2\n"; - -$poll->poll(0.1); - -if ($^O eq 'MSWin32' || $^O eq 'NetWare') { -print "ok 3 # skipped, doesn't work on non-socket fds\n"; -print "ok 4 # skipped, doesn't work on non-socket fds\n"; -} -else { -print "not " - unless $poll->events($stdout) == POLLOUT; -print "ok 3\n"; - -print "not " - if $poll->events($dupout); -print "ok 4\n"; -} - -my @h = $poll->handles; -print "not " - unless @h == 2; -print "ok 5\n"; - -$poll->remove($stdout); - -@h = $poll->handles; - -print "not " - unless @h == 1; -print "ok 6\n"; - -print "not " - if $poll->mask($stdout); -print "ok 7\n"; - -$poll->poll(0.1); - -print "not " - if $poll->events($stdout); -print "ok 8\n"; - -$poll->remove($dupout); -print "not " - if $poll->handles; -print "ok 9\n"; diff --git a/t/lib/io_scalar.t b/t/lib/io_scalar.t deleted file mode 100644 index 8368e666b9..0000000000 --- a/t/lib/io_scalar.t +++ /dev/null @@ -1,101 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - unless (find PerlIO::Layer 'perlio') { - print "1..0 # Skip: not perlio\n"; - exit 0; - } -} - -$| = 1; -print "1..20\n"; - -my $fh; -my $var = "ok 2\n"; -open($fh,"+<",\$var) or print "not "; -print "ok 1\n"; -print <$fh>; -print "not " unless eof($fh); -print "ok 3\n"; -seek($fh,0,0) or print "not "; -print "not " if eof($fh); -print "ok 4\n"; -print "ok 5\n"; -print $fh "ok 7\n" or print "not "; -print "ok 6\n"; -print $var; -$var = "foo\nbar\n"; -seek($fh,0,0) or print "not "; -print "not " if eof($fh); -print "ok 8\n"; -print "not " unless <$fh> eq "foo\n"; -print "ok 9\n"; -my $rv = close $fh; -if (!$rv) { - print "# Close on scalar failed: $!\n"; - print "not "; -} -print "ok 10\n"; - -# Test that semantics are similar to normal file-based I/O -# Check that ">" clobbers the scalar -$var = "Something"; -open $fh, ">", \$var; -print "# Got [$var], expect []\n"; -print "not " unless $var eq ""; -print "ok 11\n"; -# Check that file offset set to beginning of scalar -my $off = tell($fh); -print "# Got $off, expect 0\n"; -print "not " unless $off == 0; -print "ok 12\n"; -# Check that writes go where they should and update the offset -$var = "Something"; -print $fh "Brea"; -$off = tell($fh); -print "# Got $off, expect 4\n"; -print "not " unless $off == 4; -print "ok 13\n"; -print "# Got [$var], expect [Breathing]\n"; -print "not " unless $var eq "Breathing"; -print "ok 14\n"; -close $fh; - -# Check that ">>" appends to the scalar -$var = "Something "; -open $fh, ">>", \$var; -$off = tell($fh); -print "# Got $off, expect 10\n"; -print "not " unless $off == 10; -print "ok 15\n"; -print "# Got [$var], expect [Something ]\n"; -print "not " unless $var eq "Something "; -print "ok 16\n"; -# Check that further writes go to the very end of the scalar -$var .= "else "; -print "# Got [$var], expect [Something else ]\n"; -print "not " unless $var eq "Something else "; -print "ok 17\n"; -$off = tell($fh); -print "# Got $off, expect 10\n"; -print "not " unless $off == 10; -print "ok 18\n"; -print $fh "is here"; -print "# Got [$var], expect [Something else is here]\n"; -print "not " unless $var eq "Something else is here"; -print "ok 19\n"; -close $fh; - -# Check that updates to the scalar from elsewhere do not -# cause problems -$var = "line one\nline two\line three\n"; -open $fh, "<", \$var; -while (<$fh>) { - $var = "foo"; -} -close $fh; -print "# Got [$var], expect [foo]\n"; -print "not " unless $var eq "foo"; -print "ok 20\n"; diff --git a/t/lib/io_sel.t b/t/lib/io_sel.t deleted file mode 100755 index 84660db183..0000000000 --- a/t/lib/io_sel.t +++ /dev/null @@ -1,132 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib'; - } -} - -select(STDERR); $| = 1; -select(STDOUT); $| = 1; - -print "1..23\n"; - -use IO::Select 1.09; - -my $sel = new IO::Select(\*STDIN); -$sel->add(4, 5) == 2 or print "not "; -print "ok 1\n"; - -$sel->add([\*STDOUT, 'foo']) == 1 or print "not "; -print "ok 2\n"; - -@handles = $sel->handles; -print "not " unless $sel->count == 4 && @handles == 4; -print "ok 3\n"; -#print $sel->as_string, "\n"; - -$sel->remove(\*STDIN) == 1 or print "not "; -print "ok 4\n", -; -$sel->remove(\*STDIN, 5, 6) == 1 # two of there are not present - or print "not "; -print "ok 5\n"; - -print "not " unless $sel->count == 2; -print "ok 6\n"; -#print $sel->as_string, "\n"; - -$sel->remove(1, 4); -print "not " unless $sel->count == 0 && !defined($sel->bits); -print "ok 7\n"; - -$sel = new IO::Select; -print "not " unless $sel->count == 0 && !defined($sel->bits); -print "ok 8\n"; - -$sel->remove([\*STDOUT, 5]); -print "not " unless $sel->count == 0 && !defined($sel->bits); -print "ok 9\n"; - -if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'dos') { # 4-arg select is only valid on sockets - print "# skipping tests 10..15\n"; - for (10 .. 15) { print "ok $_\n" } - $sel->add(\*STDOUT); # update - goto POST_SOCKET; -} - -@a = $sel->can_read(); # should return imediately -print "not " unless @a == 0; -print "ok 10\n"; - -# we assume that we can write to STDOUT :-) -$sel->add([\*STDOUT, "ok 12\n"]); - -@a = $sel->can_write; -print "not " unless @a == 1; -print "ok 11\n"; - -my($fd, $msg) = @{shift @a}; -print $fd $msg; - -$sel->add(\*STDOUT); # update - -@a = IO::Select::select(undef, $sel, undef, 1); -print "not " unless @a == 3; -print "ok 13\n"; - -($r, $w, $e) = @a; - -print "not " unless @$r == 0 && @$w == 1 && @$e == 0; -print "ok 14\n"; - -$fd = $w->[0]; -print $fd "ok 15\n"; - -POST_SOCKET: -# Test new exists() method -$sel->exists(\*STDIN) and print "not "; -print "ok 16\n"; - -($sel->exists(0) || $sel->exists([\*STDERR])) and print "not "; -print "ok 17\n"; - -$fd = $sel->exists(\*STDOUT); -if ($fd) { - print $fd "ok 18\n"; -} else { - print "not ok 18\n"; -} - -$fd = $sel->exists([1, 'foo']); -if ($fd) { - print $fd "ok 19\n"; -} else { - print "not ok 19\n"; -} - -# Try self clearing -$sel->add(5,6,7,8,9,10); -print "not " unless $sel->count == 7; -print "ok 20\n"; - -$sel->remove($sel->handles); -print "not " unless $sel->count == 0 && !defined($sel->bits); -print "ok 21\n"; - -# check warnings -$SIG{__WARN__} = sub { - ++ $w - if $_[0] =~ /^Call to depreciated method 'has_error', use 'has_exception'/ - } ; -$w = 0 ; -IO::Select::has_error(); -print "not " unless $w == 0 ; -$w = 0 ; -print "ok 22\n" ; -use warnings 'IO::Select' ; -IO::Select::has_error(); -print "not " unless $w == 1 ; -$w = 0 ; -print "ok 23\n" ; diff --git a/t/lib/io_sock.t b/t/lib/io_sock.t deleted file mode 100755 index b752fd89ba..0000000000 --- a/t/lib/io_sock.t +++ /dev/null @@ -1,338 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib'; - } -} - -use Config; - -BEGIN { - if (-d "lib" && -f "TEST") { - my $reason; - if (! $Config{'d_fork'}) { - $reason = 'no fork'; - } - elsif ($Config{'extensions'} !~ /\bSocket\b/) { - $reason = 'Socket extension unavailable'; - } - elsif ($Config{'extensions'} !~ /\bIO\b/) { - $reason = 'IO extension unavailable'; - } - undef $reason if $^O eq 'VMS' and $Config{d_socket}; - if ($reason) { - print "1..0 # Skip: $reason\n"; - exit 0; - } - } -} - -$| = 1; -print "1..20\n"; - -eval { - $SIG{ALRM} = sub { die; }; - alarm 120; -}; - -use IO::Socket; - -$listen = IO::Socket::INET->new(Listen => 2, - Proto => 'tcp', - # some systems seem to need as much as 10, - # so be generous with the timeout - Timeout => 15, - ) or die "$!"; - -print "ok 1\n"; - -# Check if can fork with dynamic extensions (bug in CRT): -if ($^O eq 'os2' and - system "$^X -I../lib -MOpcode -e 'defined fork or die' > /dev/null 2>&1") { - print "ok $_ # skipped: broken fork\n" for 2..5; - exit 0; -} - -$port = $listen->sockport; - -if($pid = fork()) { - - $sock = $listen->accept() or die "accept failed: $!"; - print "ok 2\n"; - - $sock->autoflush(1); - print $sock->getline(); - - print $sock "ok 4\n"; - - $sock->close; - - waitpid($pid,0); - - print "ok 5\n"; - -} elsif(defined $pid) { - - $sock = IO::Socket::INET->new(PeerPort => $port, - Proto => 'tcp', - PeerAddr => 'localhost' - ) - || IO::Socket::INET->new(PeerPort => $port, - Proto => 'tcp', - PeerAddr => '127.0.0.1' - ) - or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)"; - - $sock->autoflush(1); - - print $sock "ok 3\n"; - - print $sock->getline(); - - $sock->close; - - exit; -} else { - die; -} - -# Test various other ways to create INET sockets that should -# also work. -$listen = IO::Socket::INET->new(Listen => '', Timeout => 15) or die "$!"; -$port = $listen->sockport; - -if($pid = fork()) { - SERVER_LOOP: - while (1) { - last SERVER_LOOP unless $sock = $listen->accept; - while (<$sock>) { - last SERVER_LOOP if /^quit/; - last if /^done/; - print; - } - $sock = undef; - } - $listen->close; -} elsif (defined $pid) { - # child, try various ways to connect - $sock = IO::Socket::INET->new("localhost:$port") - || IO::Socket::INET->new("127.0.0.1:$port"); - if ($sock) { - print "not " unless $sock->connected; - print "ok 6\n"; - $sock->print("ok 7\n"); - sleep(1); - print "ok 8\n"; - $sock->print("ok 9\n"); - $sock->print("done\n"); - $sock->close; - } - else { - print "# $@\n"; - print "not ok 6\n"; - print "not ok 7\n"; - print "not ok 8\n"; - print "not ok 9\n"; - } - - # some machines seem to suffer from a race condition here - sleep(2); - - $sock = IO::Socket::INET->new("127.0.0.1:$port"); - if ($sock) { - $sock->print("ok 10\n"); - $sock->print("done\n"); - $sock->close; - } - else { - print "# $@\n"; - print "not ok 10\n"; - } - - # some machines seem to suffer from a race condition here - sleep(1); - - $sock = IO::Socket->new(Domain => AF_INET, - PeerAddr => "localhost:$port") - || IO::Socket->new(Domain => AF_INET, - PeerAddr => "127.0.0.1:$port"); - if ($sock) { - $sock->print("ok 11\n"); - $sock->print("quit\n"); - } else { - print "not ok 11\n"; - } - $sock = undef; - sleep(1); - exit; -} else { - die; -} - -# Then test UDP sockets -$server = IO::Socket->new(Domain => AF_INET, - Proto => 'udp', - LocalAddr => 'localhost') - || IO::Socket->new(Domain => AF_INET, - Proto => 'udp', - LocalAddr => '127.0.0.1'); -$port = $server->sockport; - -if ($^O eq 'mpeix') { - print("ok 12 # skipped\n") -} else { - if ($pid = fork()) { - my $buf; - $server->recv($buf, 100); - print $buf; - } elsif (defined($pid)) { - #child - $sock = IO::Socket::INET->new(Proto => 'udp', - PeerAddr => "localhost:$port") - || IO::Socket::INET->new(Proto => 'udp', - PeerAddr => "127.0.0.1:$port"); - $sock->send("ok 12\n"); - sleep(1); - $sock->send("ok 12\n"); # send another one to be sure - exit; - } else { - die; - } -} - -print "not " unless $server->blocking; -print "ok 13\n"; - -$server->blocking(0); -print "not " if $server->blocking; -print "ok 14\n"; - -### TEST 15 -### Set up some data to be transfered between the server and -### the client. We'll use own source code ... -# -local @data; -if( !open( SRC, "< $0")) { - print "not ok 15 - $!"; -} else { - @data = <SRC>; - close( SRC); -} -print "ok 15\n"; - -### TEST 16 -### Start the server -# -my $listen = IO::Socket::INET->new( Listen => 2, Proto => 'tcp', Timeout => 15) || - print "not "; -print "ok 16\n"; -die if( !defined( $listen)); -my $serverport = $listen->sockport; - -my $server_pid = fork(); -if( $server_pid) { - - ### TEST 17 Client/Server establishment - # - print "ok 17\n"; - - ### TEST 18 - ### Get data from the server using a single stream - # - $sock = IO::Socket::INET->new("localhost:$serverport") - || IO::Socket::INET->new("127.0.0.1:$serverport"); - - if ($sock) { - $sock->print("send\n"); - - my @array = (); - while( <$sock>) { - push( @array, $_); - } - - $sock->print("done\n"); - $sock->close; - - print "not " if( @array != @data); - } else { - print "not "; - } - print "ok 18\n"; - - ### TEST 19 - ### Get data from the server using a stream, which is - ### interrupted by eof calls. - ### On perl-5.7.0@7673 this failed in a SOCKS environment, because eof - ### did an getc followed by an ungetc in order to check for the streams - ### end. getc(3) got replaced by the SOCKS funktion, which ended up in - ### a recv(2) call on the socket, while ungetc(3) put back a character - ### to an IO buffer, which never again was read. - # - $sock = IO::Socket::INET->new("localhost:$serverport") - || IO::Socket::INET->new("127.0.0.1:$serverport"); - - if ($sock) { - $sock->print("send\n"); - - my @array = (); - while( !eof( $sock ) ){ - while( <$sock>) { - push( @array, $_); - last; - } - } - - $sock->print("done\n"); - $sock->close; - - print "not " if( @array != @data); - } else { - print "not "; - } - print "ok 19\n"; - - ### TEST 20 - ### Stop the server - # - $sock = IO::Socket::INET->new("localhost:$serverport") - || IO::Socket::INET->new("127.0.0.1:$serverport"); - - if ($sock) { - $sock->print("done\n"); - $sock->close; - - print "not " if( 1 != kill 0, $server_pid); - } else { - print "not "; - } - print "ok 20\n"; - -} elsif( defined( $server_pid)) { - - ### Child - # - SERVER_LOOP: while (1) { - last SERVER_LOOP unless $sock = $listen->accept; - while (<$sock>) { - last SERVER_LOOP if /^quit/; - last if /^done/; - if( /^send/) { - print $sock @data; - last; - } - print; - } - $sock = undef; - } - $listen->close; - -} else { - - ### Fork failed - # - print "not ok 17\n"; - die; -} - diff --git a/t/lib/io_taint.t b/t/lib/io_taint.t deleted file mode 100755 index c98d70151f..0000000000 --- a/t/lib/io_taint.t +++ /dev/null @@ -1,48 +0,0 @@ -#!./perl -T - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib'; - } -} - -use Config; - -BEGIN { - if(-d "lib" && -f "TEST") { - if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { - print "1..0\n"; - exit 0; - } - } -} - -END { unlink "./__taint__$$" } - -print "1..3\n"; -use IO::File; -$x = new IO::File "> ./__taint__$$" || die("Cannot open ./__taint__$$\n"); -print $x "$$\n"; -$x->close; - -$x = new IO::File "< ./__taint__$$" || die("Cannot open ./__taint__$$\n"); -chop($unsafe = <$x>); -eval { kill 0 * $unsafe }; -print "not " if ((($^O ne 'MSWin32') && ($^O ne 'NetWare')) and ($@ !~ /^Insecure/o)); -print "ok 1\n"; -$x->close; - -# We could have just done a seek on $x, but technically we haven't tested -# seek yet... -$x = new IO::File "< ./__taint__$$" || die("Cannot open ./__taint__$$\n"); -$x->untaint; -print "not " if ($?); -print "ok 2\n"; # Calling the method worked -chop($unsafe = <$x>); -eval { kill 0 * $unsafe }; -print "not " if ($@ =~ /^Insecure/o); -print "ok 3\n"; # No Insecure message from using the data -$x->close; - -exit 0; diff --git a/t/lib/io_tell.t b/t/lib/io_tell.t deleted file mode 100755 index 65c63bdfc9..0000000000 --- a/t/lib/io_tell.t +++ /dev/null @@ -1,64 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib'; - $tell_file = "TEST"; - } - else { - $tell_file = "Makefile"; - } -} - -use Config; - -BEGIN { - if(-d "lib" && -f "TEST") { - if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { - print "1..0\n"; - exit 0; - } - } -} - -print "1..13\n"; - -use IO::File; - -$tst = IO::File->new("$tell_file","r") || die("Can't open $tell_file"); -binmode $tst; # its a nop unless it matters. Was only if ($^O eq 'MSWin32' or $^O eq 'dos'); -if ($tst->eof) { print "not ok 1\n"; } else { print "ok 1\n"; } - -$firstline = <$tst>; -$secondpos = tell; - -$x = 0; -while (<$tst>) { - if (eof) {$x++;} -} -if ($x == 1) { print "ok 2\n"; } else { print "not ok 2\n"; } - -$lastpos = tell; - -unless (eof) { print "not ok 3\n"; } else { print "ok 3\n"; } - -if ($tst->seek(0,0)) { print "ok 4\n"; } else { print "not ok 4\n"; } - -if (eof) { print "not ok 5\n"; } else { print "ok 5\n"; } - -if ($firstline eq <$tst>) { print "ok 6\n"; } else { print "not ok 6\n"; } - -if ($secondpos == tell) { print "ok 7\n"; } else { print "not ok 7\n"; } - -if ($tst->seek(0,1)) { print "ok 8\n"; } else { print "not ok 8\n"; } - -if ($tst->eof) { print "not ok 9\n"; } else { print "ok 9\n"; } - -if ($secondpos == tell) { print "ok 10\n"; } else { print "not ok 10\n"; } - -if ($tst->seek(0,2)) { print "ok 11\n"; } else { print "not ok 11\n"; } - -if ($lastpos == $tst->tell) { print "ok 12\n"; } else { print "not ok 12\n"; } - -unless (eof) { print "not ok 13\n"; } else { print "ok 13\n"; } diff --git a/t/lib/io_udp.t b/t/lib/io_udp.t deleted file mode 100755 index d63a5dcf7b..0000000000 --- a/t/lib/io_udp.t +++ /dev/null @@ -1,94 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib'; - } -} - -use Config; - -BEGIN { - if(-d "lib" && -f "TEST") { - my $reason; - - if ($Config{'extensions'} !~ /\bSocket\b/) { - $reason = 'Socket was not built'; - } - elsif ($Config{'extensions'} !~ /\bIO\b/) { - $reason = 'IO was not built'; - } - elsif ($^O eq 'apollo') { - $reason = "unknown *FIXME*"; - } - undef $reason if $^O eq 'VMS' and $Config{d_socket}; - if ($reason) { - print "1..0 # Skip: $reason\n"; - exit 0; - } - } -} - -sub compare_addr { - no utf8; - my $a = shift; - my $b = shift; - if (length($a) != length $b) { - my $min = (length($a) < length $b) ? length($a) : length $b; - if ($min and substr($a, 0, $min) eq substr($b, 0, $min)) { - printf "# Apparently: %d bytes junk at the end of %s\n# %s\n", - abs(length($a) - length ($b)), - $_[length($a) < length ($b) ? 1 : 0], - "consider decreasing bufsize of recfrom."; - substr($a, $min) = ""; - substr($b, $min) = ""; - } - return 0; - } - my @a = unpack_sockaddr_in($a); - my @b = unpack_sockaddr_in($b); - "$a[0]$a[1]" eq "$b[0]$b[1]"; -} - -$| = 1; -print "1..7\n"; - -use Socket; -use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY); - -$udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost') - || IO::Socket::INET->new(Proto => 'udp', LocalAddr => '127.0.0.1') - or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)"; - -print "ok 1\n"; - -$udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost') - || IO::Socket::INET->new(Proto => 'udp', LocalAddr => '127.0.0.1') - or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)"; - -print "ok 2\n"; - -$udpa->send("ok 4\n",0,$udpb->sockname); - -print "not " - unless compare_addr($udpa->peername,$udpb->sockname, 'peername', 'sockname'); -print "ok 3\n"; - -my $where = $udpb->recv($buf="",5); -print $buf; - -my @xtra = (); - -unless(compare_addr($where,$udpa->sockname, 'recv name', 'sockname')) { - print "not "; - @xtra = (0,$udpa->sockname); -} -print "ok 5\n"; - -$udpb->send("ok 6\n",@xtra); -$udpa->recv($buf="",5); -print $buf; - -print "not " if $udpa->connected; -print "ok 7\n"; diff --git a/t/lib/io_unix.t b/t/lib/io_unix.t deleted file mode 100644 index 2f6def0af7..0000000000 --- a/t/lib/io_unix.t +++ /dev/null @@ -1,89 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib'; - } -} - -use Config; - -BEGIN { - if(-d "lib" && -f "TEST") { - my $reason; - if (! $Config{'d_fork'}) { - $reason = 'no fork'; - } - elsif ($Config{'extensions'} !~ /\bSocket\b/) { - $reason = 'Socket extension unavailable'; - } - elsif ($Config{'extensions'} !~ /\bIO\b/) { - $reason = 'IO extension unavailable'; - } - elsif ($^O eq 'os2') { - require IO::Socket; - - eval {IO::Socket::pack_sockaddr_un('/tmp/foo') || 1} - or $@ !~ /not implemented/ or - $reason = 'compiled without TCP/IP stack v4'; - } elsif ($^O eq 'qnx') { - $reason = 'Not implemented'; - } - undef $reason if $^O eq 'VMS' and $Config{d_socket}; - if ($reason) { - print "1..0 # Skip: $reason\n"; - exit 0; - } - } -} - -$PATH = "/tmp/sock-$$"; - -# Test if we can create the file within the tmp directory -if (-e $PATH or not open(TEST, ">$PATH") and $^O ne 'os2') { - print "1..0 # Skip: cannot open '$PATH' for write\n"; - exit 0; -} -close(TEST); -unlink($PATH) or $^O eq 'os2' or die "Can't unlink $PATH: $!"; - -# Start testing -$| = 1; -print "1..5\n"; - -use IO::Socket; - -$listen = IO::Socket::UNIX->new(Local=>$PATH, Listen=>0) || die "$!"; -print "ok 1\n"; - -if($pid = fork()) { - - $sock = $listen->accept(); - print "ok 2\n"; - - print $sock->getline(); - - print $sock "ok 4\n"; - - $sock->close; - - waitpid($pid,0); - unlink($PATH) || $^O eq 'os2' || warn "Can't unlink $PATH: $!"; - - print "ok 5\n"; - -} elsif(defined $pid) { - - $sock = IO::Socket::UNIX->new(Peer => $PATH) or die "$!"; - - print $sock "ok 3\n"; - - print $sock->getline(); - - $sock->close; - - exit; -} else { - die; -} diff --git a/t/lib/io_xs.t b/t/lib/io_xs.t deleted file mode 100755 index 2449fc45c1..0000000000 --- a/t/lib/io_xs.t +++ /dev/null @@ -1,43 +0,0 @@ -#!./perl - -BEGIN { - unless(grep /blib/, @INC) { - chdir 't' if -d 't'; - @INC = '../lib'; - } -} - -use Config; - -BEGIN { - if(-d "lib" && -f "TEST") { - if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { - print "1..0\n"; - exit 0; - } - } -} - -use IO::File; -use IO::Seekable; - -print "1..4\n"; - -$x = new_tmpfile IO::File or print "not "; -print "ok 1\n"; -print $x "ok 2\n"; -$x->seek(0,SEEK_SET); -print <$x>; - -$x->seek(0,SEEK_SET); -print $x "not ok 3\n"; -$p = $x->getpos; -print $x "ok 3\n"; -$x->flush; -$x->setpos($p); -print scalar <$x>; - -$! = 0; -$x->setpos(undef); -print $! ? "ok 4 # $!\n" : "not ok 4\n"; - diff --git a/t/lib/ipc_sysv.t b/t/lib/ipc_sysv.t deleted file mode 100755 index 795ad5d6c7..0000000000 --- a/t/lib/ipc_sysv.t +++ /dev/null @@ -1,218 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - - @INC = '../lib'; - - require Config; import Config; - - my $reason; - - if ($Config{'extensions'} !~ /\bIPC\/SysV\b/) { - $reason = 'IPC::SysV was not built'; - } elsif ($Config{'d_sem'} ne 'define') { - $reason = '$Config{d_sem} undefined'; - } elsif ($Config{'d_msg'} ne 'define') { - $reason = '$Config{d_msg} undefined'; - } - if ($reason) { - print "1..0 # Skip: $reason\n"; - exit 0; - } -} - -# These constants are common to all tests. -# Later the sem* tests will import more for themselves. - -use IPC::SysV qw(IPC_PRIVATE IPC_NOWAIT IPC_STAT IPC_RMID S_IRWXU); -use strict; - -print "1..16\n"; - -my $msg; -my $sem; - -$SIG{__DIE__} = 'cleanup'; # will cleanup $msg and $sem if needed - -# FreeBSD is known to throw this if there's no SysV IPC in the kernel. -$SIG{SYS} = sub { - print STDERR <<EOM; -SIGSYS caught. -It may be that your kernel does not have SysV IPC configured. - -EOM - if ($^O eq 'freebsd') { - print STDERR <<EOM; -You must have following options in your kernel: - -options SYSVSHM -options SYSVSEM -options SYSVMSG - -See config(8). -EOM - } - exit(1); -}; - -my $perm = S_IRWXU; - -if ($Config{'d_msgget'} eq 'define' && - $Config{'d_msgctl'} eq 'define' && - $Config{'d_msgsnd'} eq 'define' && - $Config{'d_msgrcv'} eq 'define') { - - $msg = msgget(IPC_PRIVATE, $perm); - # Very first time called after machine is booted value may be 0 - die "msgget failed: $!\n" unless defined($msg) && $msg >= 0; - - print "ok 1\n"; - - #Putting a message on the queue - my $msgtype = 1; - my $msgtext = "hello"; - - my $test2bad; - my $test5bad; - my $test6bad; - - unless (msgsnd($msg,pack("L! a*",$msgtype,$msgtext),IPC_NOWAIT)) { - print "not "; - $test2bad = 1; - } - print "ok 2\n"; - if ($test2bad) { - print <<EOM; -# -# The failure of the subtest #2 may indicate that the message queue -# resource limits either of the system or of the testing account -# have been reached. Error message "Operating would block" is -# usually indicative of this situation. The error message was now: -# "$!" -# -# You can check the message queues with the 'ipcs' command and -# you can remove unneeded queues with the 'ipcrm -q id' command. -# You may also consider configuring your system or account -# to have more message queue resources. -# -# Because of the subtest #2 failing also the substests #5 and #6 will -# very probably also fail. -# -EOM - } - - my $data; - msgctl($msg,IPC_STAT,$data) or print "not "; - print "ok 3\n"; - - print "not " unless length($data); - print "ok 4\n"; - - my $msgbuf; - unless (msgrcv($msg,$msgbuf,256,0,IPC_NOWAIT)) { - print "not "; - $test5bad = 1; - } - print "ok 5\n"; - if ($test5bad && $test2bad) { - print <<EOM; -# -# This failure was to be expected because the subtest #2 failed. -# -EOM - } - - my($rmsgtype,$rmsgtext); - ($rmsgtype,$rmsgtext) = unpack("L! a*",$msgbuf); - unless ($rmsgtype == $msgtype && $rmsgtext eq $msgtext) { - print "not "; - $test6bad = 1; - } - print "ok 6\n"; - if ($test6bad && $test2bad) { - print <<EOM; -# -# This failure was to be expected because the subtest #2 failed. -# -EOM - } -} else { - for (1..6) { - print "ok $_\n"; # fake it - } -} - -if($Config{'d_semget'} eq 'define' && - $Config{'d_semctl'} eq 'define') { - - if ($Config{'d_semctl_semid_ds'} eq 'define' || - $Config{'d_semctl_semun'} eq 'define') { - - use IPC::SysV qw(IPC_CREAT GETALL SETALL); - - $sem = semget(IPC_PRIVATE, 10, $perm | IPC_CREAT); - # Very first time called after machine is booted value may be 0 - die "semget: $!\n" unless defined($sem) && $sem >= 0; - - print "ok 7\n"; - - my $data; - semctl($sem,0,IPC_STAT,$data) or print "not "; - print "ok 8\n"; - - print "not " unless length($data); - print "ok 9\n"; - - my $nsem = 10; - - semctl($sem,0,SETALL,pack("s!*",(0) x $nsem)) or print "not "; - print "ok 10\n"; - - $data = ""; - semctl($sem,0,GETALL,$data) or print "not "; - print "ok 11\n"; - - print "not " unless length($data) == length(pack("s!*",(0) x $nsem)); - print "ok 12\n"; - - my @data = unpack("s!*",$data); - - my $adata = "0" x $nsem; - - print "not " unless @data == $nsem and join("",@data) eq $adata; - print "ok 13\n"; - - my $poke = 2; - - $data[$poke] = 1; - semctl($sem,0,SETALL,pack("s!*",@data)) or print "not "; - print "ok 14\n"; - - $data = ""; - semctl($sem,0,GETALL,$data) or print "not "; - print "ok 15\n"; - - @data = unpack("s!*",$data); - - my $bdata = "0" x $poke . "1" . "0" x ($nsem-$poke-1); - - print "not " unless join("",@data) eq $bdata; - print "ok 16\n"; - } else { - for (7..16) { - print "ok $_ # skipped, no semctl possible\n"; - } - } -} else { - for (7..16) { - print "ok $_\n"; # fake it - } -} - -sub cleanup { - msgctl($msg,IPC_RMID,0) if defined $msg; - semctl($sem,0,IPC_RMID,undef) if defined $sem; -} - -cleanup; diff --git a/t/lib/lc-all.t b/t/lib/lc-all.t deleted file mode 100644 index ed93c5a856..0000000000 --- a/t/lib/lc-all.t +++ /dev/null @@ -1,366 +0,0 @@ -#!./perl -# -# all.t - tests for all_* routines in -# Locale::Country -# Locale::Language -# Locale::Currency -# -# There are four tests. We get a list of all codes, convert to -# language/country/currency, # convert back to code, -# and check that they're the same. Then we do the same, -# starting with list of languages/countries/currencies. -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Locale::Country; -use Locale::Language; -use Locale::Currency; - -print "1..12\n"; - -my $code; -my $language; -my $country; -my $ok; -my $reverse; -my $currency; - - -#----------------------------------------------------------------------- -# Old API - without codeset specified, default to ALPHA_2 -#----------------------------------------------------------------------- -$ok = 1; -foreach $code (all_country_codes()) -{ - $country = code2country($code); - if (!defined $country) - { - $ok = 0; - last; - } - $reverse = country2code($country); - if (!defined $reverse) - { - $ok = 0; - last; - } - if ($reverse ne $code) - { - $ok = 0; - last; - } -} -print ($ok ? "ok 1\n" : "not ok 1\n"); - -#----------------------------------------------------------------------- -# code to country, back to code, for ALPHA2 -#----------------------------------------------------------------------- -$ok = 1; -foreach $code (all_country_codes(LOCALE_CODE_ALPHA_2)) -{ - $country = code2country($code, LOCALE_CODE_ALPHA_2); - if (!defined $country) - { - $ok = 0; - last; - } - $reverse = country2code($country, LOCALE_CODE_ALPHA_2); - if (!defined $reverse) - { - $ok = 0; - last; - } - if ($reverse ne $code) - { - $ok = 0; - last; - } -} -print ($ok ? "ok 2\n" : "not ok 2\n"); - -#----------------------------------------------------------------------- -# code to country, back to code, for ALPHA3 -#----------------------------------------------------------------------- -$ok = 1; -foreach $code (all_country_codes(LOCALE_CODE_ALPHA_3)) -{ - $country = code2country($code, LOCALE_CODE_ALPHA_3); - if (!defined $country) - { - $ok = 0; - last; - } - $reverse = country2code($country, LOCALE_CODE_ALPHA_3); - if (!defined $reverse) - { - $ok = 0; - last; - } - if ($reverse ne $code) - { - $ok = 0; - last; - } -} -print ($ok ? "ok 3\n" : "not ok 3\n"); - -#----------------------------------------------------------------------- -# code to country, back to code, for NUMERIC -#----------------------------------------------------------------------- -$ok = 1; -foreach $code (all_country_codes(LOCALE_CODE_NUMERIC)) -{ - $country = code2country($code, LOCALE_CODE_NUMERIC); - if (!defined $country) - { - $ok = 0; - last; - } - $reverse = country2code($country, LOCALE_CODE_NUMERIC); - if (!defined $reverse) - { - $ok = 0; - last; - } - if ($reverse ne $code) - { - $ok = 0; - last; - } -} -print ($ok ? "ok 4\n" : "not ok 4\n"); - - -#----------------------------------------------------------------------- -# Old API - country to code, back to country, using default of ALPHA_2 -#----------------------------------------------------------------------- -$ok = 1; -foreach $country (all_country_names()) -{ - $code = country2code($country); - if (!defined $code) - { - $ok = 0; - last; - } - $reverse = code2country($code); - if (!defined $reverse) - { - $ok = 0; - last; - } - if ($reverse ne $country) - { - $ok = 0; - last; - } -} -print ($ok ? "ok 5\n" : "not ok 5\n"); - -#----------------------------------------------------------------------- -# country to code, back to country, using LOCALE_CODE_ALPHA_2 -#----------------------------------------------------------------------- -$ok = 1; -foreach $country (all_country_names()) -{ - $code = country2code($country, LOCALE_CODE_ALPHA_2); - if (!defined $code) - { - $ok = 0; - last; - } - $reverse = code2country($code, LOCALE_CODE_ALPHA_2); - if (!defined $reverse) - { - $ok = 0; - last; - } - if ($reverse ne $country) - { - $ok = 0; - last; - } -} -print ($ok ? "ok 6\n" : "not ok 6\n"); - -#----------------------------------------------------------------------- -# country to code, back to country, using LOCALE_CODE_ALPHA_3 -#----------------------------------------------------------------------- -$ok = 1; -foreach $country (all_country_names()) -{ - $code = country2code($country, LOCALE_CODE_ALPHA_3); - if (!defined $code) - { - next if ($country eq 'Antarctica' - || $country eq 'Bouvet Island' - || $country eq 'Cocos (Keeling) Islands' - || $country eq 'Christmas Island' - || $country eq 'France, Metropolitan' - || $country eq 'South Georgia and the South Sandwich Islands' - || $country eq 'Heard Island and McDonald Islands' - || $country eq 'British Indian Ocean Territory' - || $country eq 'French Southern Territories' - || $country eq 'United States Minor Outlying Islands' - || $country eq 'Mayotte' - || $country eq 'Zaire'); - $ok = 0; - last; - } - $reverse = code2country($code, LOCALE_CODE_ALPHA_3); - if (!defined $reverse) - { - $ok = 0; - last; - } - if ($reverse ne $country) - { - $ok = 0; - last; - } -} -print ($ok ? "ok 7\n" : "not ok 7\n"); - -#----------------------------------------------------------------------- -# country to code, back to country, using LOCALE_CODE_NUMERIC -#----------------------------------------------------------------------- -$ok = 1; -foreach $country (all_country_names()) -{ - $code = country2code($country, LOCALE_CODE_NUMERIC); - if (!defined $code) - { - next if ($country eq 'Antarctica' - || $country eq 'Bouvet Island' - || $country eq 'Cocos (Keeling) Islands' - || $country eq 'Christmas Island' - || $country eq 'France, Metropolitan' - || $country eq 'South Georgia and the South Sandwich Islands' - || $country eq 'Heard Island and McDonald Islands' - || $country eq 'British Indian Ocean Territory' - || $country eq 'French Southern Territories' - || $country eq 'United States Minor Outlying Islands' - || $country eq 'Mayotte' - || $country eq 'Zaire'); - $ok = 0; - last; - } - $reverse = code2country($code, LOCALE_CODE_NUMERIC); - if (!defined $reverse) - { - $ok = 0; - last; - } - if ($reverse ne $country) - { - $ok = 0; - last; - } -} -print ($ok ? "ok 8\n" : "not ok 8\n"); - - -$ok = 1; -foreach $code (all_language_codes()) -{ - $language = code2language($code); - if (!defined $language) - { - $ok = 0; - last; - } - $reverse = language2code($language); - if (!defined $reverse) - { - $ok = 0; - last; - } - if ($reverse ne $code) - { - $ok = 0; - last; - } -} -print ($ok ? "ok 9\n" : "not ok 9\n"); - - -$ok = 1; -foreach $language (all_language_names()) -{ - $code = language2code($language); - if (!defined $code) - { - $ok = 0; - last; - } - $reverse = code2language($code); - if (!defined $reverse) - { - $ok = 0; - last; - } - if ($reverse ne $language) - { - $ok = 0; - last; - } -} -print ($ok ? "ok 10\n" : "not ok 10\n"); - -$ok = 1; -foreach $code (all_currency_codes()) -{ - $currency = code2currency($code); - if (!defined $currency) - { - $ok = 0; - last; - } - $reverse = currency2code($currency); - if (!defined $reverse) - { - $ok = 0; - last; - } - # - # three special cases: - # The Kwacha has two codes - used in Zambia and Malawi - # The Russian Ruble has two codes - rub and rur - # The Belarussian Ruble has two codes - byb and byr - if ($reverse ne $code - && $code ne 'mwk' && $code ne 'zmk' - && $code ne 'byr' && $code ne 'byb' - && $code ne 'rub' && $code ne 'rur') - { - $ok = 0; - last; - } -} -print ($ok ? "ok 11\n" : "not ok 11\n"); - -$ok = 1; -foreach $currency (all_currency_names()) -{ - $code = currency2code($currency); - if (!defined $code) - { - $ok = 0; - last; - } - $reverse = code2currency($code); - if (!defined $reverse) - { - $ok = 0; - last; - } - if ($reverse ne $currency) - { - $ok = 0; - last; - } -} -print ($ok ? "ok 12\n" : "not ok 12\n"); diff --git a/t/lib/lc-constants.t b/t/lib/lc-constants.t deleted file mode 100644 index 359cdfc7a5..0000000000 --- a/t/lib/lc-constants.t +++ /dev/null @@ -1,49 +0,0 @@ -#!./perl -# -# constants.t - tests for Locale::Constants -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Locale::Constants; - -print "1..3\n"; - -if (defined LOCALE_CODE_ALPHA_2 - && defined LOCALE_CODE_ALPHA_3 - && defined LOCALE_CODE_NUMERIC) -{ - print "ok 1\n"; -} -else -{ - print "not ok 1\n"; -} - -if (LOCALE_CODE_ALPHA_2 != LOCALE_CODE_ALPHA_3 - && LOCALE_CODE_ALPHA_2 != LOCALE_CODE_NUMERIC - && LOCALE_CODE_ALPHA_3 != LOCALE_CODE_NUMERIC) -{ - print "ok 2\n"; -} -else -{ - print "not ok 2\n"; -} - -if (defined LOCALE_CODE_DEFAULT - && (LOCALE_CODE_DEFAULT == LOCALE_CODE_ALPHA_2 - || LOCALE_CODE_DEFAULT == LOCALE_CODE_ALPHA_3 - || LOCALE_CODE_DEFAULT == LOCALE_CODE_NUMERIC)) -{ - print "ok 3\n"; -} -else -{ - print "not ok 3\n"; -} - -exit 0; diff --git a/t/lib/lc-country.t b/t/lib/lc-country.t deleted file mode 100644 index 4234d1e6a7..0000000000 --- a/t/lib/lc-country.t +++ /dev/null @@ -1,114 +0,0 @@ -#!./perl -# -# country.t - tests for Locale::Country -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Locale::Country; - -#----------------------------------------------------------------------- -# This is an array of tests specs. Each spec is [TEST, OK_TO_DIE] -# Each TEST is eval'd as an expression. -# If it evaluates to FALSE, then "not ok N" is printed for the test, -# otherwise "ok N". If the eval dies, then the OK_TO_DIE flag is checked. -# If it is true (1), the test is treated as passing, otherwise it failed. -#----------------------------------------------------------------------- -@TESTS = -( - #================================================ - # TESTS FOR code2country - #================================================ - - #---- selection of examples which should all result in undef ----------- - ['!defined code2country()', 0], # no argument - ['!defined code2country(undef)', 0], # undef argument - ['!defined code2country("zz")', 0], # illegal code - ['!defined code2country("zz", LOCALE_CODE_ALPHA_2)', 0], # illegal code - ['!defined code2country("zz", LOCALE_CODE_ALPHA_3)', 0], # illegal code - ['!defined code2country("zz", LOCALE_CODE_NUMERIC)', 0], # illegal code - ['!defined code2country("ja")', 0], # should be jp for country - ['!defined code2country("uk")', 0], # should be jp for country - - #---- some successful examples ----------------------------------------- - ['code2country("BO") eq "Bolivia"', 0], - ['code2country("BO", LOCALE_CODE_ALPHA_2) eq "Bolivia"', 0], - ['code2country("bol", LOCALE_CODE_ALPHA_3) eq "Bolivia"', 0], - ['code2country("pk") eq "Pakistan"', 0], - ['code2country("sn") eq "Senegal"', 0], - ['code2country("us") eq "United States"', 0], - ['code2country("ad") eq "Andorra"', 0], # first in DATA segment - ['code2country("ad", LOCALE_CODE_ALPHA_2) eq "Andorra"', 0], - ['code2country("and", LOCALE_CODE_ALPHA_3) eq "Andorra"', 0], - ['code2country("020", LOCALE_CODE_NUMERIC) eq "Andorra"', 0], - ['code2country(48, LOCALE_CODE_NUMERIC) eq "Bahrain"', 0], - ['code2country("zw") eq "Zimbabwe"', 0], # last in DATA segment - ['code2country("gb") eq "United Kingdom"', 0], # United Kingdom is "gb", not "uk" - - #================================================ - # TESTS FOR country2code - #================================================ - - #---- selection of examples which should all result in undef ----------- - ['!defined code2country("BO", LOCALE_CODE_ALPHA_3)', 0], - ['!defined code2country("BO", LOCALE_CODE_NUMERIC)', 0], - ['!defined country2code()', 0], # no argument - ['!defined country2code(undef)', 0], # undef argument - ['!defined country2code("Banana")', 0], # illegal country name - - #---- some successful examples ----------------------------------------- - ['country2code("japan") eq "jp"', 0], - ['country2code("japan") ne "ja"', 0], - ['country2code("Japan") eq "jp"', 0], - ['country2code("United States") eq "us"', 0], - ['country2code("United Kingdom") eq "gb"', 0], - ['country2code("Andorra") eq "ad"', 0], # first in DATA segment - ['country2code("Zimbabwe") eq "zw"', 0], # last in DATA segment - - #================================================ - # TESTS FOR country_code2code - #================================================ - - #---- selection of examples which should all result in undef ----------- - ['!defined country_code2code("bo", LOCALE_CODE_ALPHA_3, LOCALE_CODE_ALPHA_3)', 0], - ['!defined country_code2code("zz", LOCALE_CODE_ALPHA_2, LOCALE_CODE_ALPHA_3)', 0], - ['!defined country_code2code("zz", LOCALE_CODE_ALPHA_3, LOCALE_CODE_ALPHA_3)', 0], - ['!defined country_code2code("zz", LOCALE_CODE_ALPHA_2)', 1], - ['!defined country_code2code("bo", LOCALE_CODE_ALPHA_2)', 1], - ['!defined country_code2code()', 1], # no argument - ['!defined country_code2code(undef)', 1], # undef argument - - #---- some successful examples ----------------------------------------- - ['country_code2code("BO", LOCALE_CODE_ALPHA_2, LOCALE_CODE_ALPHA_3) eq "bol"', 0], - ['country_code2code("bol", LOCALE_CODE_ALPHA_3, LOCALE_CODE_ALPHA_2) eq "bo"', 0], - ['country_code2code("zwe", LOCALE_CODE_ALPHA_3, LOCALE_CODE_ALPHA_2) eq "zw"', 0], - ['country_code2code("858", LOCALE_CODE_NUMERIC, LOCALE_CODE_ALPHA_3) eq "ury"', 0], - ['country_code2code(858, LOCALE_CODE_NUMERIC, LOCALE_CODE_ALPHA_3) eq "ury"', 0], - ['country_code2code("tr", LOCALE_CODE_ALPHA_2, LOCALE_CODE_NUMERIC) eq "792"', 0], - -); - -print "1..", int(@TESTS), "\n"; - -$testid = 1; -foreach $test (@TESTS) -{ - eval "print (($test->[0]) ? \"ok $testid\\n\" : \"not ok $testid\\n\" )"; - if ($@) - { - if (!$test->[1]) - { - print "not ok $testid\n"; - } - else - { - print "ok $testid\n"; - } - } - ++$testid; -} - -exit 0; diff --git a/t/lib/lc-currency.t b/t/lib/lc-currency.t deleted file mode 100644 index 55a04db9fb..0000000000 --- a/t/lib/lc-currency.t +++ /dev/null @@ -1,85 +0,0 @@ -#!./perl -# -# currency.t - tests for Locale::Currency -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Locale::Currency; - -#----------------------------------------------------------------------- -# This is an array of tests. Each test is eval'd as an expression. -# If it evaluates to FALSE, then "not ok N" is printed for the test, -# otherwise "ok N". -#----------------------------------------------------------------------- -@TESTS = -( - #================================================ - # TESTS FOR code2currency - #================================================ - - #---- selection of examples which should all result in undef ----------- - '!defined code2currency()', # no argument => undef returned - '!defined code2currency(undef)', # undef arg => undef returned - '!defined code2currency("zz")', # illegal code => undef - '!defined code2currency("zzzz")', # illegal code => undef - '!defined code2currency("zzz")', # illegal code => undef - '!defined code2currency("ukp")', # gbp for sterling, not ukp - - #---- misc tests ------------------------------------------------------- - 'code2currency("all") eq "Lek"', - 'code2currency("ats") eq "Schilling"', - 'code2currency("bob") eq "Boliviano"', - 'code2currency("bnd") eq "Brunei Dollar"', - 'code2currency("cop") eq "Colombian Peso"', - 'code2currency("dkk") eq "Danish Krone"', - 'code2currency("fjd") eq "Fiji Dollar"', - 'code2currency("idr") eq "Rupiah"', - 'code2currency("chf") eq "Swiss Franc"', - 'code2currency("mvr") eq "Rufiyaa"', - 'code2currency("mmk") eq "Kyat"', - 'code2currency("mwk") eq "Kwacha"', # two different codes for Kwacha - 'code2currency("zmk") eq "Kwacha"', # used in Zambia and Malawi - 'code2currency("byr") eq "Belarussian Ruble"', # 2 codes for belarussian ruble - 'code2currency("byb") eq "Belarussian Ruble"', # - 'code2currency("rub") eq "Russian Ruble"', # 2 codes for russian ruble - 'code2currency("rur") eq "Russian Ruble"', # - - #---- some successful examples ----------------------------------------- - 'code2currency("BOB") eq "Boliviano"', - 'code2currency("adp") eq "Andorran Peseta"', # first in DATA segment - 'code2currency("zwd") eq "Zimbabwe Dollar"', # last in DATA segment - - #================================================ - # TESTS FOR currency2code - #================================================ - - #---- selection of examples which should all result in undef ----------- - '!defined currency2code()', # no argument => undef returned - '!defined currency2code(undef)', # undef arg => undef returned - '!defined currency2code("")', # empty string => undef returned - '!defined currency2code("Banana")', # illegal curr name => undef - - #---- some successful examples ----------------------------------------- - 'currency2code("Kroon") eq "eek"', - 'currency2code("Markka") eq "fim"', - 'currency2code("Riel") eq "khr"', - 'currency2code("PULA") eq "bwp"', - 'currency2code("Andorran Peseta") eq "adp"', # first in DATA segment - 'currency2code("Zimbabwe Dollar") eq "zwd"', # last in DATA segment -); - -print "1..", int(@TESTS), "\n"; - -$testid = 1; -foreach $test (@TESTS) -{ - eval "print (($test) ? \"ok $testid\\n\" : \"not ok $testid\\n\" )"; - print "not ok $testid\n" if $@; - ++$testid; -} - -exit 0; diff --git a/t/lib/lc-language.t b/t/lib/lc-language.t deleted file mode 100644 index 9facd3509d..0000000000 --- a/t/lib/lc-language.t +++ /dev/null @@ -1,110 +0,0 @@ -#!./perl -# -# language.t - tests for Locale::Language -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Locale::Language; - -no utf8; # so that the naked 8-bit characters won't gripe under use utf8 - -#----------------------------------------------------------------------- -# This is an array of tests. Each test is eval'd as an expression. -# If it evaluates to FALSE, then "not ok N" is printed for the test, -# otherwise "ok N". -#----------------------------------------------------------------------- -@TESTS = -( - #================================================ - # TESTS FOR code2language - #================================================ - - #---- selection of examples which should all result in undef ----------- - '!defined code2language()', # no argument => undef returned - '!defined code2language(undef)', # undef arg => undef returned - '!defined code2language("zz")', # illegal code => undef - '!defined code2language("jp")', # ja for lang, jp for country - - #---- test recent changes ---------------------------------------------- - 'code2language("ae") eq "Avestan"', - 'code2language("bs") eq "Bosnian"', - 'code2language("ch") eq "Chamorro"', - 'code2language("ce") eq "Chechen"', - 'code2language("cu") eq "Church Slavic"', - 'code2language("cv") eq "Chuvash"', - 'code2language("hz") eq "Herero"', - 'code2language("ho") eq "Hiri Motu"', - 'code2language("ki") eq "Kikuyu"', - 'code2language("kj") eq "Kuanyama"', - 'code2language("kv") eq "Komi"', - 'code2language("mh") eq "Marshall"', - 'code2language("nv") eq "Navajo"', - 'code2language("nr") eq "Ndebele, South"', - 'code2language("nd") eq "Ndebele, North"', - 'code2language("ng") eq "Ndonga"', - 'code2language("nn") eq "Norwegian Nynorsk"', - 'code2language("nb") eq "Norwegian Bokml"', - 'code2language("ny") eq "Chichewa; Nyanja"', - 'code2language("oc") eq "Occitan (post 1500)"', - 'code2language("os") eq "Ossetian; Ossetic"', - 'code2language("pi") eq "Pali"', - '!defined code2language("sh")', # Serbo-Croatian withdrawn - 'code2language("se") eq "Sami"', - 'code2language("sc") eq "Sardinian"', - 'code2language("kw") eq "Cornish"', - 'code2language("gv") eq "Manx"', - 'code2language("lb") eq "Letzeburgesch"', - 'code2language("he") eq "Hebrew"', - '!defined code2language("iw")', # Hebrew withdrawn - 'code2language("id") eq "Indonesian"', - '!defined code2language("in")', # Indonesian withdrawn - 'code2language("iu") eq "Inuktitut"', - 'code2language("ug") eq "Uighur"', - '!defined code2language("ji")', # Yiddish withdrawn - 'code2language("yi") eq "Yiddish"', - 'code2language("za") eq "Zhuang"', - - #---- some successful examples ----------------------------------------- - 'code2language("DA") eq "Danish"', - 'code2language("eo") eq "Esperanto"', - 'code2language("fi") eq "Finnish"', - 'code2language("en") eq "English"', - 'code2language("aa") eq "Afar"', # first in DATA segment - 'code2language("zu") eq "Zulu"', # last in DATA segment - - #================================================ - # TESTS FOR language2code - #================================================ - - #---- selection of examples which should all result in undef ----------- - '!defined language2code()', # no argument => undef returned - '!defined language2code(undef)', # undef arg => undef returned - '!defined language2code("Banana")', # illegal lang name => undef - - #---- some successful examples ----------------------------------------- - 'language2code("Japanese") eq "ja"', - 'language2code("japanese") eq "ja"', - 'language2code("japanese") ne "jp"', - 'language2code("French") eq "fr"', - 'language2code("Greek") eq "el"', - 'language2code("english") eq "en"', - 'language2code("ESTONIAN") eq "et"', - 'language2code("Afar") eq "aa"', # first in DATA segment - 'language2code("Zulu") eq "zu"', # last in DATA segment -); - -print "1..", int(@TESTS), "\n"; - -$testid = 1; -foreach $test (@TESTS) -{ - eval "print (($test) ? \"ok $testid\\n\" : \"not ok $testid\\n\" )"; - print "not ok $testid\n" if $@; - ++$testid; -} - -exit 0; diff --git a/t/lib/lc-maketext.t b/t/lib/lc-maketext.t deleted file mode 100644 index 743d8eecbd..0000000000 --- a/t/lib/lc-maketext.t +++ /dev/null @@ -1,37 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -BEGIN { $| = 1; print "1..3\n"; } -END {print "not ok 1\n" unless $loaded;} -use Locale::Maketext 1.01; -print "# Perl v$], Locale::Maketext v$Locale::Maketext::VERSION\n"; -$loaded = 1; -print "ok 1\n"; -{ - package Woozle; - @ISA = ('Locale::Maketext'); - sub dubbil { return $_[1] * 2 } -} -{ - package Woozle::elx; - @ISA = ('Woozle'); - %Lexicon = ( - 'd2' => 'hum [dubbil,_1]', - ); -} - -$lh = Woozle->get_handle('elx'); -if($lh) { - print "ok 2\n"; - my $x = $lh->maketext('d2', 7); - if($x eq "hum 14") { - print "ok 3\n"; - } else { - print "not ok 3\n (got \"$x\")\n"; - } -} else { - print "not ok 2\n"; -} -#Shazam! diff --git a/t/lib/lc-uk.t b/t/lib/lc-uk.t deleted file mode 100644 index 948e2d1af2..0000000000 --- a/t/lib/lc-uk.t +++ /dev/null @@ -1,70 +0,0 @@ -#!./perl -# -# uk.t - tests for Locale::Country with "uk" aliases to "gb" -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Locale::Country; - -Locale::Country::_alias_code('uk' => 'gb'); - -#----------------------------------------------------------------------- -# This is an array of tests. Each test is eval'd as an expression. -# If it evaluates to FALSE, then "not ok N" is printed for the test, -# otherwise "ok N". -#----------------------------------------------------------------------- -@TESTS = -( - #================================================ - # TESTS FOR code2country - #================================================ - - #---- selection of examples which should all result in undef ----------- - '!defined code2country()', # no argument - '!defined code2country(undef)', # undef argument - '!defined code2country("zz")', # illegal code - '!defined code2country("ja")', # should be jp for country - - #---- some successful examples ----------------------------------------- - 'code2country("BO") eq "Bolivia"', - 'code2country("pk") eq "Pakistan"', - 'code2country("sn") eq "Senegal"', - 'code2country("us") eq "United States"', - 'code2country("ad") eq "Andorra"', # first in DATA segment - 'code2country("zw") eq "Zimbabwe"', # last in DATA segment - 'code2country("uk") eq "United Kingdom"', # normally "gb" - - #================================================ - # TESTS FOR country2code - #================================================ - - #---- selection of examples which should all result in undef ----------- - '!defined country2code()', # no argument - '!defined country2code(undef)', # undef argument - '!defined country2code("Banana")', # illegal country name - - #---- some successful examples ----------------------------------------- - 'country2code("japan") eq "jp"', - 'country2code("japan") ne "ja"', - 'country2code("Japan") eq "jp"', - 'country2code("United States") eq "us"', - 'country2code("United Kingdom") eq "uk"', - 'country2code("Andorra") eq "ad"', # first in DATA segment - 'country2code("Zimbabwe") eq "zw"', # last in DATA segment -); - -print "1..", int(@TESTS), "\n"; - -$testid = 1; -foreach $test (@TESTS) -{ - eval "print (($test) ? \"ok $testid\\n\" : \"not ok $testid\\n\" )"; - print "not ok $testid\n" if $@; - ++$testid; -} - -exit 0; diff --git a/t/lib/mbimbf.t b/t/lib/mbimbf.t deleted file mode 100644 index 3948102f0e..0000000000 --- a/t/lib/mbimbf.t +++ /dev/null @@ -1,214 +0,0 @@ -#!/usr/bin/perl -w - -# test accuracy, precicion and fallback, round_mode - -use strict; -use Test; - -BEGIN - { - $| = 1; - # chdir 't' if -d 't'; - unshift @INC, '../lib'; # for running manually - plan tests => 103; - } - -use Math::BigInt; -use Math::BigFloat; - -my ($x,$y,$z,$u); - -############################################################################### -# test defaults and set/get - -ok_undef ($Math::BigInt::accuracy); -ok_undef ($Math::BigInt::precision); -ok ($Math::BigInt::div_scale,40); -ok (Math::BigInt::round_mode(),'even'); -ok ($Math::BigInt::rnd_mode,'even'); - -ok_undef ($Math::BigFloat::accuracy); -ok_undef ($Math::BigFloat::precision); -ok ($Math::BigFloat::div_scale,40); -ok ($Math::BigFloat::rnd_mode,'even'); - -# accuracy -foreach (qw/5 42 -1 0/) - { - ok ($Math::BigFloat::accuracy = $_,$_); - ok ($Math::BigInt::accuracy = $_,$_); - } -ok_undef ($Math::BigFloat::accuracy = undef); -ok_undef ($Math::BigInt::accuracy = undef); - -# precision -foreach (qw/5 42 -1 0/) - { - ok ($Math::BigFloat::precision = $_,$_); - ok ($Math::BigInt::precision = $_,$_); - } -ok_undef ($Math::BigFloat::precision = undef); -ok_undef ($Math::BigInt::precision = undef); - -# fallback -foreach (qw/5 42 1/) - { - ok ($Math::BigFloat::div_scale = $_,$_); - ok ($Math::BigInt::div_scale = $_,$_); - } -# illegal values are possible for fallback due to no accessor - -# round_mode -foreach (qw/odd even zero trunc +inf -inf/) - { - ok ($Math::BigFloat::rnd_mode = $_,$_); - ok ($Math::BigInt::rnd_mode = $_,$_); - } -$Math::BigFloat::rnd_mode = 4; -ok ($Math::BigFloat::rnd_mode,4); -ok ($Math::BigInt::rnd_mode,'-inf'); # from above - -$Math::BigInt::accuracy = undef; -$Math::BigInt::precision = undef; -# local copies -$x = Math::BigFloat->new(123.456); -ok_undef ($x->accuracy()); -ok ($x->accuracy(5),5); -ok_undef ($x->accuracy(undef),undef); -ok_undef ($x->precision()); -ok ($x->precision(5),5); -ok_undef ($x->precision(undef),undef); - -# see if MBF changes MBIs values -ok ($Math::BigInt::accuracy = 42,42); -ok ($Math::BigFloat::accuracy = 64,64); -ok ($Math::BigInt::accuracy,42); # should be still 42 -ok ($Math::BigFloat::accuracy,64); # should be still 64 - -############################################################################### -# see if creating a number under set A or P will round it - -$Math::BigInt::accuracy = 4; -$Math::BigInt::precision = 3; - -ok (Math::BigInt->new(123456),123500); # with A -$Math::BigInt::accuracy = undef; -ok (Math::BigInt->new(123456),123000); # with P - -$Math::BigFloat::accuracy = 4; -$Math::BigFloat::precision = -1; -$Math::BigInt::precision = undef; - -ok (Math::BigFloat->new(123.456),123.5); # with A -$Math::BigFloat::accuracy = undef; -ok (Math::BigFloat->new(123.456),123.5); # with P from MBF, not MBI! - -$Math::BigFloat::precision = undef; - -############################################################################### -# see if setting accuracy/precision actually rounds the number - -$x = Math::BigFloat->new(123.456); $x->accuracy(4); ok ($x,123.5); -$x = Math::BigFloat->new(123.456); $x->precision(-2); ok ($x,123.46); - -$x = Math::BigInt->new(123456); $x->accuracy(4); ok ($x,123500); -$x = Math::BigInt->new(123456); $x->precision(2); ok ($x,123500); - -############################################################################### -# test actual rounding via round() - -$x = Math::BigFloat->new(123.456); -ok ($x->copy()->round(5,2),123.46); -ok ($x->copy()->round(4,2),123.5); -ok ($x->copy()->round(undef,-2),123.46); -ok ($x->copy()->round(undef,2),100); - -$x = Math::BigFloat->new(123.45000); -ok ($x->copy()->round(undef,-1,'odd'),123.5); - -# see if rounding is 'sticky' -$x = Math::BigFloat->new(123.4567); -$y = $x->copy()->bround(); # no-op since nowhere A or P defined - -ok ($y,123.4567); -$y = $x->copy()->round(5,2); -ok ($y->accuracy(),5); -ok_undef ($y->precision()); # A has precedence, so P still unset -$y = $x->copy()->round(undef,2); -ok ($y->precision(),2); -ok_undef ($y->accuracy()); # P has precedence, so A still unset - -# does copy work? -$x = Math::BigFloat->new(123.456); $x->accuracy(4); $x->precision(2); -$z = $x->copy(); ok ($z->accuracy(),4); ok ($z->precision(),2); - -############################################################################### -# test wether operations round properly afterwards -# These tests are not complete, since they do not excercise every "return" -# statement in the op's. But heh, it's better than nothing... - -$x = Math::BigFloat->new(123.456); -$y = Math::BigFloat->new(654.321); -$x->{_a} = 5; # $x->accuracy(5) would round $x straightaway -$y->{_a} = 4; # $y->accuracy(4) would round $x straightaway - -$z = $x + $y; ok ($z,777.8); -$z = $y - $x; ok ($z,530.9); -$z = $y * $x; ok ($z,80780); -$z = $x ** 2; ok ($z,15241); -$z = $x * $x; ok ($z,15241); -# not yet: $z = -$x; ok ($z,-123.46); ok ($x,123.456); -$z = $x->copy(); $z->{_a} = 2; $z = $z / 2; ok ($z,62); -$x = Math::BigFloat->new(123456); $x->{_a} = 4; -$z = $x->copy; $z++; ok ($z,123500); - -$x = Math::BigInt->new(123456); -$y = Math::BigInt->new(654321); -$x->{_a} = 5; # $x->accuracy(5) would round $x straightaway -$y->{_a} = 4; # $y->accuracy(4) would round $x straightaway - -$z = $x + $y; ok ($z,777800); -$z = $y - $x; ok ($z,530900); -$z = $y * $x; ok ($z,80780000000); -$z = $x ** 2; ok ($z,15241000000); -# not yet: $z = -$x; ok ($z,-123460); ok ($x,123456); -$z = $x->copy; $z++; ok ($z,123460); -$z = $x->copy(); $z->{_a} = 2; $z = $z / 2; ok ($z,62000); - -############################################################################### -# test mixed arguments - -$x = Math::BigFloat->new(10); -$u = Math::BigFloat->new(2.5); -$y = Math::BigInt->new(2); - -$z = $x + $y; ok ($z,12); ok (ref($z),'Math::BigFloat'); -$z = $x / $y; ok ($z,5); ok (ref($z),'Math::BigFloat'); -$z = $u * $y; ok ($z,5); ok (ref($z),'Math::BigFloat'); - -$y = Math::BigInt->new(12345); -$z = $u->copy()->bmul($y,2,0,'odd'); ok ($z,31000); -$z = $u->copy()->bmul($y,3,0,'odd'); ok ($z,30900); -$z = $u->copy()->bmul($y,undef,0,'odd'); ok ($z,30863); -$z = $u->copy()->bmul($y,undef,1,'odd'); ok ($z,30860); -$z = $u->copy()->bmul($y,undef,-1,'odd'); ok ($z,30862.5); - -# breakage: -# $z = $y->copy()->bmul($u,2,0,'odd'); ok ($z,31000); -# $z = $y * $u; ok ($z,5); ok (ref($z),'Math::BigInt'); -# $z = $y + $x; ok ($z,12); ok (ref($z),'Math::BigInt'); -# $z = $y / $x; ok ($z,0); ok (ref($z),'Math::BigInt'); - -# all done - -############################################################################### -# Perl 5.005 does not like ok ($x,undef) - -sub ok_undef - { - my $x = shift; - - ok (1,1) and return if !defined $x; - ok ($x,'undef'); - } - diff --git a/t/lib/md5-aaa.t b/t/lib/md5-aaa.t deleted file mode 100644 index f3f3202cb9..0000000000 --- a/t/lib/md5-aaa.t +++ /dev/null @@ -1,552 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use strict; -print "1..256\n"; - -use Digest::MD5 qw(md5_hex); - -my $Is_EBCDIC = ord('A') == 193; - -my $testno = 0; -while (<DATA>) { - if (!$Is_EBCDIC) { - next if /^EBCDIC/; - } - else { - next if !/^EBCDIC/; - s/^EBCDIC,\w+#//; - } - my($hexdigest, $message) = split; - $message =~ s/\"//g; - - my $failed; - $failed++ unless md5_hex($message) eq $hexdigest; - $failed++ unless Digest::MD5->new->add(split(//, $message))->digest - eq pack("H*", $hexdigest); - - print "not " if $failed; - print "ok ", ++$testno, "\n"; -} - - - -# This data was generated with: -# -# perl -e 'for (1..256) { system("md5sum --string=" . ("a" x $_)); }' -# -__END__ -0cc175b9c0f1b6a831c399e269772661 "a" -4124bc0a9335c27f086f24ba207a4912 "aa" -47bce5c74f589f4867dbd57e9ca9f808 "aaa" -74b87337454200d4d33f80c4663dc5e5 "aaaa" -594f803b380a41396ed63dca39503542 "aaaaa" -0b4e7a0e5fe84ad35fb5f95b9ceeac79 "aaaaaa" -5d793fc5b00a2348c3fb9ab59e5ca98a "aaaaaaa" -3dbe00a167653a1aaee01d93e77e730e "aaaaaaaa" -552e6a97297c53e592208cf97fbb3b60 "aaaaaaaaa" -e09c80c42fda55f9d992e59ca6b3307d "aaaaaaaaaa" -d57f21e6a273781dbf8b7657940f3b03 "aaaaaaaaaaa" -45e4812014d83dde5666ebdf5a8ed1ed "aaaaaaaaaaaa" -c162de19c4c3731ca3428769d0cd593d "aaaaaaaaaaaaa" -451599a5f9afa91a0f2097040a796f3d "aaaaaaaaaaaaaa" -12f9cf6998d52dbe773b06f848bb3608 "aaaaaaaaaaaaaaa" -23ca472302f49b3ea5592b146a312da0 "aaaaaaaaaaaaaaaa" -88e42e96cc71151b6e1938a1699b0a27 "aaaaaaaaaaaaaaaaa" -2c60c24e7087e18e45055a33f9a5be91 "aaaaaaaaaaaaaaaaaa" -639d76897485360b3147e66e0a8a3d6c "aaaaaaaaaaaaaaaaaaa" -22d42eb002cefa81e9ad604ea57bc01d "aaaaaaaaaaaaaaaaaaaa" -bd049f221af82804c5a2826809337c9b "aaaaaaaaaaaaaaaaaaaaa" -ff49cfac3968dbce26ebe7d4823e58bd "aaaaaaaaaaaaaaaaaaaaaa" -d95dbfee231e34cccb8c04444412ed7d "aaaaaaaaaaaaaaaaaaaaaaa" -40edae4bad0e5bf6d6c2dc5615a86afb "aaaaaaaaaaaaaaaaaaaaaaaa" -a5a8bfa3962f49330227955e24a2e67c "aaaaaaaaaaaaaaaaaaaaaaaaa" -ae791f19bdf77357ff10bb6b0e97e121 "aaaaaaaaaaaaaaaaaaaaaaaaaa" -aaab9c59a88bf0bdfcb170546c5459d6 "aaaaaaaaaaaaaaaaaaaaaaaaaaa" -b0f0545856af1a340acdedce23c54b97 "aaaaaaaaaaaaaaaaaaaaaaaaaaaa" -f7ce3d7d44f3342107d884bfa90c966a "aaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -59e794d45697b360e18ba972bada0123 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -3b0845db57c200be6052466f87b2198a "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -5eca9bd3eb07c006cd43ae48dfde7fd3 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -b4f13cb081e412f44e99742cb128a1a5 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -4c660346451b8cf91ef50f4634458d41 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -11db24dc3f6c2145701db08625dd6d76 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -80dad3aad8584778352c68ab06250327 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -1227fe415e79db47285cb2689c93963f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -8e084f489f1bdf08c39f98ff6447ce6d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -08b2f2b0864bac1ba1585043362cbec9 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -4697843037d962f62a5a429e611e0f5f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -10c4da18575c092b486f8ab96c01c02f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -af205d729450b663f48b11d839a1c8df "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -0d3f91798fac6ee279ec2485b25f1124 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -4c3c7c067634daec9716a80ea886d123 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -d1e358e6e3b707282cdd06e919f7e08c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -8c6ded4f0af86e0a7e301f8a716c4363 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -4c2d8bcb02d982d7cb77f649c0a2dea8 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -bdb662f765cd310f2a547cab1cfecef6 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -08ff5f7301d30200ab89169f6afdb7af "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -6eb6a030bcce166534b95bc2ab45d9cf "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -1bb77918e5695c944be02c16ae29b25e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -b6fe77c19f0f0f4946c761d62585bfea "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -e9e7e260dce84ffa6e0e7eb5fd9d37fc "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -eced9e0b81ef2bba605cbc5e2e76a1d0 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -ef1772b6dff9a122358552954ad0df65 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -3b0c8ac703f828b04c6c197006d17218 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -652b906d60af96844ebd21b674f35e93 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -dc2f2f2462a0d72358b2f99389458606 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -762fc2665994b217c52c3c2eb7d9f406 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -cc7ed669cf88f201c3297c6a91e1d18d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -cced11f7bbbffea2f718903216643648 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -24612f0ce2c9d2cf2b022ef1e027a54f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -b06521f39153d618550606be297466d5 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -014842d480b571495a4a0363793f7367 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -c743a45e0d2e6a95cb859adae0248435 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -def5d97e01e1219fb2fc8da6c4d6ba2f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -92cb737f8687ccb93022fdb411a77cca "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -a0d1395c7fb36247bfe2d49376d9d133 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -ab75504250558b788f99d1ebd219abf2 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -0f5c6c4e740bfcc08c3c26ccb2673d46 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -cddd19bec7f310d8c87149ef47a1828f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -96b39b8b95e016c79d104d83395b8133 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -f1fc0b14ff8fa674b02344577e23eeb1 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -0e8d28a1cafa3ffcff22afd480cce7d8 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -448539ffc17e1e81005b65581855cef4 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -61e39aae7c53e6e77db2e4405d9fb157 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -618a426895ee6133a372bebd1129b63e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -046c90690c9e36578b9d4a7e1d249c75 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -aadab38075c43296ee7e12466ebb03e3 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -b15af9cdabbaea0516866a33d8fd0f98 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -986e6938ed767a8ae9530eef54bfe5f1 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -7ae25a72b71a42ccbc5477fd989cd512 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -98d34e50d4aa7a893cc7919a91acb0e3 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -3fc53fc22ea40f1a0afd78fc2cd9aa0f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -923e37c738b9d7b1526f70b65229cc3d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -b3966b7a08e5d46fd0774b797ba78dc2 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -f50c7286b540bb181db1d6e05a51a296 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -4efd6c8826e65a61f82af954d431b59b "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -ef1031e79e7a15a4470a5e98b23781b5 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -067876bfd0df0f4c5002780ec85e6f8c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -789851dfa4c03563e9cef5f7bc050a7e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -baf934720818ee49477e74fc644faa5e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -9a0ea77ca26d2c121ddcc179edb76308 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -20c825561572e33d026f99ddfd999538 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -464c461455c5a927079a13609c20b637 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -cf37d42f89b6adb0e1a9e99104501b82 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -d266af45e3d06b70d9f52e2df4344186 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -f8b59fa22eb0ba944e2b7aa24d67b681 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -0918d7c2f9062743450a86eae9dde1a3 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -36a92cc94a9e0fa21f625f8bfb007adf "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -681d73898dad5685d48b5e8438bc3a66 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -337ccef058459c3c16411381778da0c4 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -6ccdfcc742862036ce07583633c5f77e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -ddfa1adc974649dc5b414be86def7457 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -650ebc28ad85f11aa4b63b6ee565b89d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -e4571793bcaba284017eeabd8df85697 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -4fc040d354ad9ba5e4f62862109d3e17 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -25814274e02aa7cc03d6314eb703e655 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -11378ecaee0089c840d26352704027e3 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -86f950bfcd824d5546da01c40576db31 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -089f243d1e831c5879aa375ee364a06e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -9146ef3527c7cfcc66dc615c3986e391 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -d727cfdfc9ed0347e6917a68b982f7bc "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -da8f45e1fdc12deecfe56aeb5288796e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -29cfcf52d8250a253a535cf7989c7bd2 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -0f6eb555b8e3c35411eebe9348594193 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -a922439f963e7e59040e4756992c6f1b "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -81f8453cf3f7e5ee5479c777e5a8d80c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -8a7bd0732ed6a28ce75f6dabc90e1613 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -5f61c0ccad4cac44c75ff505e1f1e537 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -f6acfca2d47c87f2b14ca038234d3614 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -269fc62c517f3d55c368152addca57e7 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -50587cb16413da779b35508018721647 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -5e4a3ecfdaa4636b84a39b6a7be7c047 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -c5339dc2af6bf595580281ffb07353f6 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -e51176a47347e167ed0ed766b6de1a0c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -020406e1d05cdc2aa287641f7ae2cc39 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -e510683b3f5ffe4093d021808bc6ff70 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -b325dc1c6f5e7a2b7cf465b9feab7948 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -e016e4ccc7fdaea56fc377600b58c4cb "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -3870ec709d2fc64b255d65be3123ad69 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -a92bde1f862c3fe797ecd69510bbd266 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -04daa146f3a2256fdcbf015c0f67e168 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -3d13c8bf627421ccc937aa1c9ac87bf1 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -247dc7ffc545e4dda64ae12def481c4e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -2dfd4def392ee9563241b7db7eb7c346 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -d11a18a4743a1a0a699d1704efb74a0d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -55b62fabd9c77d44d86e992eeeb093e6 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -9a72cf7d0bd5ae2907c79f91837e3ced "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -d3828cce1835534475029202ebd799e4 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -b0bebbf0015658d4740679f263a3f01f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -02368ebf1f53bc4634211b1693021666 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -04960f7d18960e348372949e4baa9752 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -c6041e7a86d407e9402b175670519260 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -439fd4c056bec1d14acd393746f6ae59 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -81a855120e04494c5a6c874a2360fd57 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -ef57bd47a964dc3aadd959c4131e64ac "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -0b0ab27b16cbba267c141fe0f4ee9189 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -abccd84f340bfe4ba59095cc3d5ca6ad "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -bc620e8c15265f195c8818e2f3e3c58b "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -fdcd84c4143286f6fc70c69208acd18d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -50e05071e773b1e9f3009a4a559ce6b2 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -9e69c7a6c1863fbba2532f09ba665bde "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -47a962111aa5187eeef3d17a278d95f2 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -c13e57e33526bc713b5a1825f92651bc "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -72b392f15593e42404b38e5c889fa75e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -5327acd3278274265d44e22ccfc4042c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -930dcac6da160b2a4c51879da76d3417 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -41292c326f926f1534ead47fe302f0a0 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -2bdecb5cf6b69a00f7832299ef2fb5a5 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -8bf93e9e8a3e4396de3f211c788e177e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -eea9cb566e19d6a7f55fbae78d94ef2a "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -3b8452700a829dec78397aa5c0458dd3 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -7950059f699eaea1e0a1759340d7c153 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -40840c5f1de00f17a8e70d5bd4d00af2 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -80f86f6af38be9ca8e40c2dc44491a0a "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -7aab2c2e72c77163e7102412dc332125 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -bfd6869ae2ee2fe2675846d341eaa67d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -7e4d976f6d552d1d5bac7e2693dc8759 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -37d9884c32abfc6f372ee899434e64ad "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -e362cd83a4b49d81ac6788b7839a56fd "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -9203cbb93b25d80b9d1b75e3c6c4b0dc "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -77441eda11554ec5b915d942605f66ed "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -e0fe0c02b5c9c5afe10ab9d6a3769efe "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -cc7682cf11b214e928f3df899772e789 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -ade0901d347afb25ecf9df4955bb8061 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -987379587cbe8e94b7057269232ff826 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -fd44a60101b04b7ddbc2b4e9b509ca1f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -53107a7f1e6f13a2e63239b6f2bf0ef1 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -0b82cdd562f26aaa2459610a7ba8cd76 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -79f12de7255e9c8c0ec9a9be45ee6210 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -92338d8de02ed7aa8b3adc9120b94e71 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -8fc48efda580fce85b8705d540e8382e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -63642b027ee89938c922722650f2eb9b "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -fe54daa473502e9cc2c26dd66d564eab "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -b90f3d4b7dcd8cdd8d96cb14695f4793 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -3e73392e7a03bca45b67650d79a8fc63 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -7fe51f2642dffbabc33eea2fcc2039ba "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -bc33790e52f99718cf920329961ee753 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -54d1e41ebac5db7886f01ab0afb65b17 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -16e2824f7a3f00ef0028994182071953 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -234c07907df5019d5f40f03936939bce "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -8ea3af1d9476fa0b6c04ce4f3a336c03 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -e95b69eae07d498d484afc771d1c45fc "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -f22a673abbc4372544ba37b51a5f5a91 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -7e6161eb1be7b06928c536fada91b7f1 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -4dfe3c301e88fff67822e1cfcfece43f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -edda210ac6645fbf5815eb4c58821f6d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -6a514de2bf1926129b08f9234cd0115e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -887f30b43b2867f4a9accceee7d16e6c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -15936442c22dab9b685de350bfe75971 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -281a39e10bab29f1f2dead149a1f3f87 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -04d5f8a53b0eeda82d3c0ccafd02c98e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -a91e6b80fe9d6db74fac76c7a67f065a "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -30334486fa9841044afb07f2573107a5 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -0183c0cf15a3c2ed97d326f421b6d62c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -4dc2a01b2161653753019b5228f765f8 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -71ef2dbdec7f78005354abebbfec8d8f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -a1d1cd1446c113726ba50cc86d8b6519 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -ed6da79cfd13ece051c4cb7c88e80c2e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -d2047852ce178d4ddb7978da3883f9c5 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -d75382e07dd096b618faeeac033eefff "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -3fb48e286d462dcc237c3335aa63ba14 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -55b959972677ea06c4d0e32f7fb2f10a "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -0a479c3623cfb9745e54d3376d0b9ae2 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -7825ad1ba19db7eec57d88b16936f32f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -833ccf25509cb423a4aa98accb15512d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -cae9609b05a9782610a5a43d7cd4b8ff "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -6c303e1da7f8a3032d13fe995847a722 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -4c47143a568e30ecde86dafe3bcb0558 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -9c48f0592f504b86360cfb6de00203b3 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -e1524f5686f170209366f9723880d9b0 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -a96164a43a192543d40e538b9e9e4ece "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -b774a4f788458a60e131d998705e4a06 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -1e97f0a7dfd3fac6ae585acdcf51a549 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -b6364c77b6dd495c2a7f6b0211ac6fce "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -5d22315e78df2bc4146aa66f6c405dbb "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -2a773d5b04e910612543a42deeaaaa62 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -0165449ac66b086accdec3051e0b691e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -54884ba571054eae72b2a5271828a1fc "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -520fb61f8625ea916d72a54a37937bc6 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -7717f05d6e424a2c7a20ab7977b21ec8 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -b64e4f62e3e14317e3a90f9ff2cde576 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -a49128259cfe50ba3bed80bbd11add7f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -b10cb153b79c2e4af6a8431c265aa82d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -2e50fee6f574241042bdfabfdd46a153 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -5d5656a09b98c24edd01c530d3aad5e2 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -5ac1e1609d82274371c349d5b7875298 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -b7b40d64ffccebd78abcf522376b3aae "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -8619933469d908a2d4a2d890909bea43 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -591a0ee6dccd872b46ae184eb0f9450e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -8cd256a02c8c5c1676e9220e655d9ac4 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -e48c0e2ed3e4e299a6e62e5416eb6d83 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -f30f75dce71e757ee562218c1efa0645 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -06bd7e90c0410dacb155732cf956f520 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -531a0a821a9304c215f1829b880306f1 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -93f4621c0b88499297ec3f8fbb3fb9c4 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -6af3d61e2e3ef8e189cffbea802c7e69 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -df84d21c884f99d6764d9bca4dec26e1 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -1bdbdf1c9087c796394bcda5789f7206 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -21f5b107cda33036590a19419afd7fb6 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -0eae304c738191613302fb6721ea3605 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -abed9cdef66dcec954b87124ba18c1ab "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -dfde09457e2017e31d4ecfaea010db8f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -46bc249a5a8fc5d622cf12c42c463ae0 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -81109eec5aa1a284fb5327b10e9c16b9 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#cd25041f9f36811b04ab3015805fe816 "a" -EBCDIC,1047#762b8b87733ee724b8cb751c3b956ea7 "aa" -EBCDIC,1047#f39105ec557abe624399862897a127ed "aaa" -EBCDIC,1047#b825cfc3203d45d01156b8e06ae74901 "aaaa" -EBCDIC,1047#a497a05975af505878aa98b26bd329dd "aaaaa" -EBCDIC,1047#90420f3fc7d64c6cdd7a3bf218b004b1 "aaaaaa" -EBCDIC,1047#b3d7a168407b1613f08f186dc3744a72 "aaaaaaa" -EBCDIC,1047#b7b4ab251d9cc8dc9fc562272a1c7f44 "aaaaaaaa" -EBCDIC,1047#eb974f5cd9b8100dad8e9b82bbdb4a7a "aaaaaaaaa" -EBCDIC,1047#cd675880a60d9c2095fe48981959ea5b "aaaaaaaaaa" -EBCDIC,1047#8396c227248d77e1ebb478b4c44ee8e8 "aaaaaaaaaaa" -EBCDIC,1047#ae59cf65c1c722b8ea6f6e770b20315f "aaaaaaaaaaaa" -EBCDIC,1047#d1550adc6c6f2baeb5da9e2acd75eea1 "aaaaaaaaaaaaa" -EBCDIC,1047#bddd60dbf174785c39827c71ecb29706 "aaaaaaaaaaaaaa" -EBCDIC,1047#d0ef1bc67b2d761513ad8c1f92ca7a2b "aaaaaaaaaaaaaaa" -EBCDIC,1047#dd613bdc90e1e71e57e40931cf3803c1 "aaaaaaaaaaaaaaaa" -EBCDIC,1047#3810ed84a3fabf136b9f5c2de3c802ca "aaaaaaaaaaaaaaaaa" -EBCDIC,1047#a41d584a36ba74526057338e4240b31d "aaaaaaaaaaaaaaaaaa" -EBCDIC,1047#e361a7b2e6adb9df91ed794f39c31a8f "aaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#dc089d8d25773e879ce759357394f63b "aaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#096bdd77ddd6393b5ff2878813ebc9c3 "aaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#e457d06769e51e7b34314c1fa885534b "aaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#ae3399b847ef9ce11d958a8926afa2a3 "aaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#be65d5ac6ebe81410cca55c2ad70e672 "aaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#108e4c3887db4178e5ea72782fb105d2 "aaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#d6ccc43d376b6ded51af488d1f56a872 "aaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#e208a35fdf88de1da8ec8411888b807e "aaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#bf09c576c720c32342308fae413347ae "aaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#aac629ca1ec1d5908fe85d6eeb352765 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#845a64111840e9db26e8f5032d59187d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#db38d8cf4f7037e6a150cc35e385972c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#2586f6fcb6ffb1578a94f8c9c2944b40 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#cb63decd219ee21068b330d321061434 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#d98cca1ccf230b2619ae6f452ab18325 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#f99e8a5e800a9c1b78b9c7181fa4113d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#c60d314815b0d438fe8cf18a62d8680d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#1256f52d15ab93e69c75d6cc9986fa49 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#7e6b1236d08400ec5723b76f3b883b2a "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#bae076b34373156e51196c8170fff549 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#b957a14baa9ab970516e5e3fe30560c5 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#8209c722c9d86984bde35f31e64de4c9 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#ad6abdadefb6809ef9db323939dad44e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#91ae6c863369dbfb13c688b9e5290929 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#770e940a6f11de3a3897031c7040573f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#2d07c71e6709d908992a19ee8fcd70c7 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#e748dc11e3b2984e0888782ecc9fa43f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#99573ce268b1f9e32e18319922380b2b "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#68951bca944217c5a17d54d9fe296ee9 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#53addd1728c3fd60ba02e29ff7eac4d8 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#7c4abc37772402388c8d792351ae3163 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#a21011fb1a5c1f06dfc23c1b9b921506 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#5ce00db35364620dc75696426b9c7948 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#50a785cbcd6cb70322f32062bcfc8940 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#92e6ad1aa09ecde0becf66dc9f356549 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#bb769fed437ab5471f0453bdf0de6ca2 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#49d68b22125368b152dd80773b1053cd "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#8c7ce5f0c7ed40ec25df22b68d1725f3 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#344d80c1906e9e728e0cc9703fc60803 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#630a45b11cc72d8e36aca0e180241cb4 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#1c9ba16c5be8d48b5d8fe1a8dd1b6999 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#74bb8337e8e9a3d114eb266437302949 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#134ddd06fa362804c9f8cf02111826bd "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#1ffd548f057ed474c0d3b53ee1f8ce1b "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#487823e5089b40d8c66a6a7fc613c26c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#a40e0c6392e974bc6e258fb7530b9ec3 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#dccf88078dcb7501156e17b6f5b90bd0 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#9012cdfe170301d3c8d11d9dab87bf96 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#046d4f6709367aa9be3452dc5dd03601 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#237b85d7be428836b0835e3f7411d0d0 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#32022ea076ffe7496da0b64b2482b963 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#c68b3e8c7c88bf10003deaf652549f1c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#e648925002262503def112984215d21d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#192328de11913688d002f01326071abb "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#42f7138b1f7ed2121098f3e418406e7b "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#cb64c10607f961b2714a3b104e487838 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#0a8fb4023704d318e53a6047531477f3 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#2c9a5487397c8245fe8a52684fa50554 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#26efb364f1da859fbc71744d2c62570e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#3359363d24960feaa2f05ea1b403ddcc "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#be9304d0a6297a1a1c7b02cbf177fe0c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#badb0d02141d35349b3b2838cb6450cc "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#75261d10ee76bfc016f98a868e535e49 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#d85006031896657b7215ed1f64f002b9 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#2db85d6ffa2287e42c0e55a72900dd4f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#f8ce69fabcf5d5013aaede9c90a7e4c0 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#5749ef4b7f6347c3cf9e8af2dc48093e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#afd1f87f6522f82f7d260909db38f84c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#690a229786930ec741404c83738f0e87 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#a1f02fbe5b1815f5d68ebfa5c5b8cdda "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#4e75faba6d50d6f3341b3623f3457c83 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#af0eed7206c2aba4622b15a826b3cf48 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#984236c86e268a506dda56886d4589aa "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#256f33cc0cd5d0d700b959143f8b81fb "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#a4f4a73bdf53bd03ec2bf406df8c5bf1 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#bac0c7bb84f581a8ca67e49ecb7eabdc "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#c1be2bc056a5abfff888f562f7420b8b "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#6db1e154a0feeb290d6f9b6ca78b9faa "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#163fa1f68d79b511aa832e4d513c0d75 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#f00e90ba697aa55722c87b51652b515f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#ba925e3f1584bb930da28396334dfb06 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#6a43780f9f36e80e977d31e6ee055ccf "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#f07953ebdb37e911069ab4dc1d11b691 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#0f21a8a924546d121d479c2ae9b22788 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#6c857bf152348cc6a8d63ef4bb3a8b22 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#afc61c11e9730f9221e5b013cb75e36b "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#7c762743838df21dbe61883325e4de3e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#a78d17621ef736358cf69909fe1841ae "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#687559a1f8bb2799d3f7e57ceb0f816e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#0a5eb0bcfc8888839b3b4f986e91db7c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#232c4a6355062f36d5b18a18453ba936 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#5ec9bdfb872d07265113dd94eaf7a9ea "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#f3c9f677ab5404ed16b029067a8d632f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#290997df4163f9f37994048b7f750ecb "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#9d482b2d64d165eaf1796bddb15ffc43 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#f7e059c707e4156d59bef9c887731b75 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#dec244a8f0d45814f8968492cae063ae "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#a153d558a8bed15abe61d6de1345200c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#c4c4155e9855435000915b9028af57ad "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#3bf4740880459875fc6625d3e8b9702b "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#b73a90ab965e8254aeb1ed8995ccf551 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#143a255cfc206e135b23ed557c6b8c7d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#1600b994bf10eeb85772e0f5811ed661 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#7becfd6e439108f896d34012bc3c879f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#9fb1155e1c1529943d378bc79ce7248a "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#210f27a4c085f4c50b119a9f530dbe64 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#c03e534627aec7638f2ef7136a987afb "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#056ff6dcf19eff62af1f7eaf68fdb868 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#78ebdbcbd1cf873ac5bc3317bc333d74 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#379ed8c06d6533b0ae397bd9bcc88727 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#68202ec0f97b3d04145ad8143b36bbec "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#f2e8c8f3ab9832adae73d6694b5aa6b5 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#4dd0228d79bab138ae330137ceac9547 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#db509dc0a6d9a43323f200c3944fdd47 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#91e5620a3fbe4a7dbddc6328024f57e6 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#cebbeb507c5b8534898b394c3cb6dbab "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#eaa83adae76b4e5a38361a7943b2fc51 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#cf3fe145cdd9d906dff484591bebb099 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#5ee68f513d294e242dfd84066a489ad4 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#1452349d5b61efaf5f86f6c67ae1e67d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#4a6d9c83bb7f0418977302f41861c674 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#1c82f764bc22e2b43aa64c86152576c5 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#94046ff34b09f2d5cd1ecc145f8b67f9 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#2f9b4413a963175dbf6c0e79fbafc13f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#fdcfd05667569a819bd43a32f3f0034c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#977ffabd477e827a170211d989121719 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#eb42e9022bad24209923768cd295da59 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#34daced153754389b0a3dd457aaa580f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#4d4ac318fd2765150cdd3a1fd9046f76 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#5f3779e31d8b4ecc587ef2aa620990cb "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#538a0f0a41a77491368d12d280b67ffc "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#2b8bea1be2920657faea5d2f306df93e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#fdb162676ff37cafbb0b37f4a34e1f05 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#79b031eae2e5d593ad9e1765c1b32311 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#9a9d79d611f3f97dac3f1f16aeb95810 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#eca47f4f27f10c6e50bc02e96c1305e0 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#c27a036a378a0c37e551623253de6c86 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#846248b2d8ba9a2845a5b5a6160ea043 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#37f6c0bb5c1c76a018bd92d6267d5f52 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#c71638a87de7d0b7ff178235d368ca87 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#c1769c2dafefeb4400d8aaaad7be13e2 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#c2170ff8ba444a468ecc92c68e156876 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#87d372bb84572d2c33e910a8f39a46c3 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#e198c2b2ad83adf6d2edb90918afb140 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#dc89c07be1a85973ce4a75fdd70b945f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#8213ffd54a231c594058b572f12ed2ce "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#64a275192c6bbaf330994498212ff235 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#e718b792be6311e0248a537ba6d5e84c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#b7ee2cd790ed748aa3ac632e2c30fe08 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#6a97471085d1e13858f7febbc8762a40 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#d82fa7cf3fe39751e88cc6a4c5ea0a80 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#4d3ea68fdfb845be4aa12eef1868ac54 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#b24417be7632f1db1f37c00f2be59372 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#79f7f0088af39859c26e8dd422102e4a "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#8e7c80a85e3a76bb83d81e12122d699c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#ffb596a208a1b81b17cf86e809ea9b15 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#a3e78c5e9bd595ea8457b25b7ae5ee7c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#200b9de7d5ebd0a74deb6d501fa9c273 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#75865e9d3111b6e17ba1e1b586c520e0 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#f13640a7b68db8d2bd853a95c371f4e7 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#4525f0da220d5e730ad91070c819ca6a "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#3f9c9eb19f1fd6aefeb3d736d5f37cbb "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#e3344f64ba3436948b3de13081c98eb9 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#18b50889733a1e896e8fd2e460e98d7f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#918a86710bc529f44f022d5f891107a1 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#4aaea2b4f2cfcfef3a5f6be8996b2a3e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#af899efcace3138fea64764015e265f6 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#d472112d115b9bfb34a65cc6683109fc "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#f2a42d47b187fc7a250f771ebcda779b "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#43442e458f65b5dc6b84181fb70f0e36 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#051771335f34ad905c1af28c429e23e2 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#c2c23e86aac60a7d8cb2f2d9a011b525 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#4276f514d2e9b5cf511a01b16d5bd7ad "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#43011a7d9ad322984e3617859eb37ee7 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#9b7e0d04de1c0121bd261a15cf9bb806 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#bc1e0269ae34e27ed0534a8ab5146324 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#85fa07daa4541779d7c8436a737802cf "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#5d1db871938d1dcc8a72509411dada31 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#e679a912e400a1c078e657be492a672c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#b17718a20096befcee63c2b55bbc5399 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#4786015b6aa47e81752f4e2aa59061d5 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#7f3793d46edf449ce5800d568ef6e83f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#8f992f2bc222fdc9ecf86eb0c984948b "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#aec900f38434e9fb7ded9d33f9a59b66 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#de3fe519c53310d2a8970a4ed2bcc937 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#02bf7d064c621689246886752ddc08bc "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#c306bdf0469814bf38b2cadc896489a3 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#9f84e151ea29f14871b63454585cbc78 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#cc4fd08ed3768b08646bfa6c332a6156 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#d35126a1dc2ae4b93ac67a442961a752 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#4c2ed17f95f823071289b94c7efe53f2 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#63e071ca26135f7e27d76fa57d015dbe "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#4e506bd75c0d1391a0dd36adc18b3485 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#b8a9a5bf97ce5fc88a24c128bb75536e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#97e8bb790b164bc3bdb7189630748841 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#3c7a2d742d599f4fac9231c5264967ee "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#0483a8dc4b24d3d26f0d3bf0402486c5 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#86022bc208c5bbded89bbaeae88e6dbf "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#c7a3f500cfe98f8c1959922b381b9438 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#bff3067df4cfff43007bea69f2380d6a "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#e34a5c41f51ea6d1f1b187e90d940b59 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#c8468cae7c8a2a999a0a164f68b759eb "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#4bccb2bff1862782004398afff2289b4 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#9710683ca0b5cbf10c3df249bfa85d7a "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#5a705ab132807ce9605b98444622abf3 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#dd53ab3422160f933f9723cd3cb53b5a "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#bad7e8a4aeea40f8642a0ca1cdfcc61b "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#4c0df2b1456694b51a5c809f34f959a8 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#f330498cabce39dd03eb02d6c983281f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#915ff5f5c93e0a7833be8cc529108216 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#b8facb5253a2b7e091c0a6c18d48e368 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#8ebdd257c3bc052f9c837f90fb1879cf "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#42d2cf830ee626939580323a824a4099 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#0d364adcb48ee9db07828ce127355a0b "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#14d9170b8f9ead33ec4da94d66b6b74a "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#0327eff7ae5d6b5966def78e593ff5f7 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#f08ac509f43f8e34008a65c3f47d29aa "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#7dc9cdc33fb9a0d70e1409357b086783 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#5f079c22e843c3426bcf03efbd0fc54d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#8422781e8a9390246920556090a9559d "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#0cc485a5c828b2cdc895f38b5c3b386e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#2259886c34c2e8adf2b3552bd47a3d6e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#c96af44682d38aa7e4b86954c883f8dc "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#85bfdfeff05f7120bd5821ac6668694e "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#b4083c69629ec95f6397cd5844edaf90 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#666550654d7c9e6b8a3118d9dc64bace "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#eef83a6cad3d9a8d963d468cb037ccce "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#c2fd346804a8c9c80a08312d7b9d17f3 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#6521b944a119cd1f787ff75c1452db74 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#805638adfdb3bf9591fd28dfadba697a "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#e62d07301fd3c0bdb5f7ce0e49e4b5d3 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#49b46e007e0c79c047f655b1b46167c2 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#8811ec9d3b878d168975ed835b3acaa8 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#9b4e8b089d75d1fe3567bcc97b4379d5 "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#c279605bdcfee9b4976eb57a9eb0d5fd "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#3e362e6f8c5eb3aa7530ef9722dda11c "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" -EBCDIC,1047#c54a2d44c8a73ab63d892b8b3d1c336f "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" diff --git a/t/lib/md5-align.t b/t/lib/md5-align.t deleted file mode 100644 index 4176062415..0000000000 --- a/t/lib/md5-align.t +++ /dev/null @@ -1,20 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -# Test that md5 works on unaligned memory blocks - -print "1..1\n"; - -use strict; -use Digest::MD5 qw(md5_hex); - -my $str = "\100" x 20; -substr($str, 0, 1, ""); # chopping off first char makes the string unaligned - -#use Devel::Peek; Dump($str); - -print "not " unless md5_hex($str) eq "c7ebb510e59ee96f404f288d14cc656a"; -print "ok 1\n"; - diff --git a/t/lib/md5-badf.t b/t/lib/md5-badf.t deleted file mode 100644 index 63effdfc21..0000000000 --- a/t/lib/md5-badf.t +++ /dev/null @@ -1,26 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -# Digest::MD5 2.07 and older used to trigger a core dump when -# passed an illegal file handle that failed to open. - -print "1..2\n"; - -use Digest::MD5 (); - -$md5 = Digest::MD5->new; - -eval { - use vars qw(*FOO); - $md5->addfile(*FOO); -}; -print "not " unless $@ =~ /^Bad filehandle: FOO/; -print "ok 1\n"; - -open(BAR, "none-existing-file.$$"); -$md5->addfile(*BAR); - -print "not " unless $md5->hexdigest eq "d41d8cd98f00b204e9800998ecf8427e"; -print "ok 2\n"; diff --git a/t/lib/md5-file.t b/t/lib/md5-file.t deleted file mode 100644 index c786a5f4e5..0000000000 --- a/t/lib/md5-file.t +++ /dev/null @@ -1,150 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..2\n"; - -use strict; -use Digest::MD5 qw(md5 md5_hex md5_base64); - -# -# This is the output of: 'md5sum MD5.pm MD5.xs' -# -my $EXPECT; - -if (ord('A') == 193) { # EBCDIC -$EXPECT = <<EOT; -95a81f17a8e6c2273aecac12d8c4cb90 ext/Digest/MD5/MD5.pm -9cecc5dbb27bd64b98f61f558b4db378 ext/Digest/MD5/MD5.xs -EOT -} else { # ASCII -$EXPECT = <<EOT; -3d0146bf194e4fe68733d00fba02a49e ext/Digest/MD5/MD5.pm -5526659171a63f532d990dd73791b60e ext/Digest/MD5/MD5.xs -EOT -} - -my $B64 = 1; -eval { require MIME::Base64; }; -if ($@) { - print $@; - print "# Will not test base64 methods\n"; - $B64 = 0; -} - -my $testno = 0; - -use File::Spec; - -for (split /^/, $EXPECT) { - my($md5hex, $file) = split ' '; - my @path = split(m:/:, $file); - my $last = pop @path; - my $path = File::Spec->updir; - while (@path) { - $path = File::Spec->catdir($path, shift @path); - } - $file = File::Spec->catfile($path, $last); - my $md5bin = pack("H*", $md5hex); - my $md5b64; - if ($B64) { - $md5b64 = MIME::Base64::encode($md5bin, ""); - chop($md5b64); chop($md5b64); # remove padding - } - my $failed; - - if (digest_file($file, 'digest') ne $md5bin) { - print "$file: Bad digest\n"; - $failed++; - } - - if (digest_file($file, 'hexdigest') ne $md5hex) { - print "$file: Bad hexdigest\n"; - $failed++; - } - - if ($B64 && digest_file($file, 'b64digest') ne $md5b64) { - print "$file: Bad b64digest\n"; - $failed++; - } - - my $data = cat_file($file); - if (md5($data) ne $md5bin) { - print "$file: md5() failed\n"; - $failed++; - } - if (md5_hex($data) ne $md5hex) { - print "$file: md5_hex() failed\n"; - $failed++; - } - if ($B64 && md5_base64($data) ne $md5b64) { - print "$file: md5_base64() failed\n"; - $failed++; - } - - if (Digest::MD5->new->add($data)->digest ne $md5bin) { - print "$file: MD5->new->add(...)->digest failed\n"; - $failed++; - } - if (Digest::MD5->new->add($data)->hexdigest ne $md5hex) { - print "$file: MD5->new->add(...)->hexdigest failed\n"; - $failed++; - } - if ($B64 && Digest::MD5->new->add($data)->b64digest ne $md5b64) { - print "$file: MD5->new->add(...)->b64digest failed\n"; - $failed++; - } - - my @data = split //, $data; - if (md5(@data) ne $md5bin) { - print "$file: md5(\@data) failed\n"; - $failed++; - } - if (Digest::MD5->new->add(@data)->digest ne $md5bin) { - print "$file: MD5->new->add(\@data)->digest failed\n"; - $failed++; - } - my $md5 = Digest::MD5->new; - for (@data) { - $md5->add($_); - } - if ($md5->digest ne $md5bin) { - print "$file: $md5->add()-loop failed\n"; - $failed++; - } - - print "not " if $failed; - print "ok ", ++$testno, "\n"; -} - - -sub digest_file -{ - my($file, $method) = @_; - $method ||= "digest"; - #print "$file $method\n"; - - open(FILE, $file) or die "Can't open $file: $!"; -# Digests avove are generated on UNIX without CRLF -# so leave handles in text mode -# binmode(FILE); - my $digest = Digest::MD5->new->addfile(*FILE)->$method(); - close(FILE); - - $digest; -} - -sub cat_file -{ - my($file) = @_; - local $/; # slurp - open(FILE, $file) or die "Can't open $file: $!"; -# Digests avove are generated on UNIX without CRLF -# so leave handles in text mode -# binmode(FILE); - my $tmp = <FILE>; - close(FILE); - $tmp; -} - diff --git a/t/lib/mimeb64.t b/t/lib/mimeb64.t deleted file mode 100644 index 7a61fe9576..0000000000 --- a/t/lib/mimeb64.t +++ /dev/null @@ -1,383 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use MIME::Base64; - -print "1..283\n"; - -print "# Testing MIME::Base64-", $MIME::Base64::VERSION, "\n"; - -BEGIN { - if (ord('A') == 41) { - *ASCII = sub { return $_[0] }; - } - else { - require Encode; - *ASCII = sub { Encode::encode('ascii',$_[0]) }; - } -} - -$testno = 1; - -encodeTest(); -decodeTest(); - -# This used to generate a warning -print "not " unless decode_base64(encode_base64("foo")) eq "foo"; -print "ok ", $testno++, "\n"; - -sub encodeTest -{ - print "# encode test\n"; - - my @encode_tests = ( - # All values - ["\000" => "AA=="], - ["\001" => "AQ=="], - ["\002" => "Ag=="], - ["\003" => "Aw=="], - ["\004" => "BA=="], - ["\005" => "BQ=="], - ["\006" => "Bg=="], - ["\007" => "Bw=="], - ["\010" => "CA=="], - ["\011" => "CQ=="], - ["\012" => "Cg=="], - ["\013" => "Cw=="], - ["\014" => "DA=="], - ["\015" => "DQ=="], - ["\016" => "Dg=="], - ["\017" => "Dw=="], - ["\020" => "EA=="], - ["\021" => "EQ=="], - ["\022" => "Eg=="], - ["\023" => "Ew=="], - ["\024" => "FA=="], - ["\025" => "FQ=="], - ["\026" => "Fg=="], - ["\027" => "Fw=="], - ["\030" => "GA=="], - ["\031" => "GQ=="], - ["\032" => "Gg=="], - ["\033" => "Gw=="], - ["\034" => "HA=="], - ["\035" => "HQ=="], - ["\036" => "Hg=="], - ["\037" => "Hw=="], - ["\040" => "IA=="], - ["\041" => "IQ=="], - ["\042" => "Ig=="], - ["\043" => "Iw=="], - ["\044" => "JA=="], - ["\045" => "JQ=="], - ["\046" => "Jg=="], - ["\047" => "Jw=="], - ["\050" => "KA=="], - ["\051" => "KQ=="], - ["\052" => "Kg=="], - ["\053" => "Kw=="], - ["\054" => "LA=="], - ["\055" => "LQ=="], - ["\056" => "Lg=="], - ["\057" => "Lw=="], - ["\060" => "MA=="], - ["\061" => "MQ=="], - ["\062" => "Mg=="], - ["\063" => "Mw=="], - ["\064" => "NA=="], - ["\065" => "NQ=="], - ["\066" => "Ng=="], - ["\067" => "Nw=="], - ["\070" => "OA=="], - ["\071" => "OQ=="], - ["\072" => "Og=="], - ["\073" => "Ow=="], - ["\074" => "PA=="], - ["\075" => "PQ=="], - ["\076" => "Pg=="], - ["\077" => "Pw=="], - ["\100" => "QA=="], - ["\101" => "QQ=="], - ["\102" => "Qg=="], - ["\103" => "Qw=="], - ["\104" => "RA=="], - ["\105" => "RQ=="], - ["\106" => "Rg=="], - ["\107" => "Rw=="], - ["\110" => "SA=="], - ["\111" => "SQ=="], - ["\112" => "Sg=="], - ["\113" => "Sw=="], - ["\114" => "TA=="], - ["\115" => "TQ=="], - ["\116" => "Tg=="], - ["\117" => "Tw=="], - ["\120" => "UA=="], - ["\121" => "UQ=="], - ["\122" => "Ug=="], - ["\123" => "Uw=="], - ["\124" => "VA=="], - ["\125" => "VQ=="], - ["\126" => "Vg=="], - ["\127" => "Vw=="], - ["\130" => "WA=="], - ["\131" => "WQ=="], - ["\132" => "Wg=="], - ["\133" => "Ww=="], - ["\134" => "XA=="], - ["\135" => "XQ=="], - ["\136" => "Xg=="], - ["\137" => "Xw=="], - ["\140" => "YA=="], - ["\141" => "YQ=="], - ["\142" => "Yg=="], - ["\143" => "Yw=="], - ["\144" => "ZA=="], - ["\145" => "ZQ=="], - ["\146" => "Zg=="], - ["\147" => "Zw=="], - ["\150" => "aA=="], - ["\151" => "aQ=="], - ["\152" => "ag=="], - ["\153" => "aw=="], - ["\154" => "bA=="], - ["\155" => "bQ=="], - ["\156" => "bg=="], - ["\157" => "bw=="], - ["\160" => "cA=="], - ["\161" => "cQ=="], - ["\162" => "cg=="], - ["\163" => "cw=="], - ["\164" => "dA=="], - ["\165" => "dQ=="], - ["\166" => "dg=="], - ["\167" => "dw=="], - ["\170" => "eA=="], - ["\171" => "eQ=="], - ["\172" => "eg=="], - ["\173" => "ew=="], - ["\174" => "fA=="], - ["\175" => "fQ=="], - ["\176" => "fg=="], - ["\177" => "fw=="], - ["\200" => "gA=="], - ["\201" => "gQ=="], - ["\202" => "gg=="], - ["\203" => "gw=="], - ["\204" => "hA=="], - ["\205" => "hQ=="], - ["\206" => "hg=="], - ["\207" => "hw=="], - ["\210" => "iA=="], - ["\211" => "iQ=="], - ["\212" => "ig=="], - ["\213" => "iw=="], - ["\214" => "jA=="], - ["\215" => "jQ=="], - ["\216" => "jg=="], - ["\217" => "jw=="], - ["\220" => "kA=="], - ["\221" => "kQ=="], - ["\222" => "kg=="], - ["\223" => "kw=="], - ["\224" => "lA=="], - ["\225" => "lQ=="], - ["\226" => "lg=="], - ["\227" => "lw=="], - ["\230" => "mA=="], - ["\231" => "mQ=="], - ["\232" => "mg=="], - ["\233" => "mw=="], - ["\234" => "nA=="], - ["\235" => "nQ=="], - ["\236" => "ng=="], - ["\237" => "nw=="], - ["\240" => "oA=="], - ["\241" => "oQ=="], - ["\242" => "og=="], - ["\243" => "ow=="], - ["\244" => "pA=="], - ["\245" => "pQ=="], - ["\246" => "pg=="], - ["\247" => "pw=="], - ["\250" => "qA=="], - ["\251" => "qQ=="], - ["\252" => "qg=="], - ["\253" => "qw=="], - ["\254" => "rA=="], - ["\255" => "rQ=="], - ["\256" => "rg=="], - ["\257" => "rw=="], - ["\260" => "sA=="], - ["\261" => "sQ=="], - ["\262" => "sg=="], - ["\263" => "sw=="], - ["\264" => "tA=="], - ["\265" => "tQ=="], - ["\266" => "tg=="], - ["\267" => "tw=="], - ["\270" => "uA=="], - ["\271" => "uQ=="], - ["\272" => "ug=="], - ["\273" => "uw=="], - ["\274" => "vA=="], - ["\275" => "vQ=="], - ["\276" => "vg=="], - ["\277" => "vw=="], - ["\300" => "wA=="], - ["\301" => "wQ=="], - ["\302" => "wg=="], - ["\303" => "ww=="], - ["\304" => "xA=="], - ["\305" => "xQ=="], - ["\306" => "xg=="], - ["\307" => "xw=="], - ["\310" => "yA=="], - ["\311" => "yQ=="], - ["\312" => "yg=="], - ["\313" => "yw=="], - ["\314" => "zA=="], - ["\315" => "zQ=="], - ["\316" => "zg=="], - ["\317" => "zw=="], - ["\320" => "0A=="], - ["\321" => "0Q=="], - ["\322" => "0g=="], - ["\323" => "0w=="], - ["\324" => "1A=="], - ["\325" => "1Q=="], - ["\326" => "1g=="], - ["\327" => "1w=="], - ["\330" => "2A=="], - ["\331" => "2Q=="], - ["\332" => "2g=="], - ["\333" => "2w=="], - ["\334" => "3A=="], - ["\335" => "3Q=="], - ["\336" => "3g=="], - ["\337" => "3w=="], - ["\340" => "4A=="], - ["\341" => "4Q=="], - ["\342" => "4g=="], - ["\343" => "4w=="], - ["\344" => "5A=="], - ["\345" => "5Q=="], - ["\346" => "5g=="], - ["\347" => "5w=="], - ["\350" => "6A=="], - ["\351" => "6Q=="], - ["\352" => "6g=="], - ["\353" => "6w=="], - ["\354" => "7A=="], - ["\355" => "7Q=="], - ["\356" => "7g=="], - ["\357" => "7w=="], - ["\360" => "8A=="], - ["\361" => "8Q=="], - ["\362" => "8g=="], - ["\363" => "8w=="], - ["\364" => "9A=="], - ["\365" => "9Q=="], - ["\366" => "9g=="], - ["\367" => "9w=="], - ["\370" => "+A=="], - ["\371" => "+Q=="], - ["\372" => "+g=="], - ["\373" => "+w=="], - ["\374" => "/A=="], - ["\375" => "/Q=="], - ["\376" => "/g=="], - ["\377" => "/w=="], - - ["\000\377" => "AP8="], - ["\377\000" => "/wA="], - ["\000\000\000" => "AAAA"], - - ['' => ''], - [ASCII('a') => 'YQ=='], - [ASCII('aa') => 'YWE='], - [ASCII('aaa') => 'YWFh'], - - [ASCII('aaa') => 'YWFh'], - [ASCII('aaa') => 'YWFh'], - [ASCII('aaa') => 'YWFh'], - - - # from HTTP spec - [ASCII('Aladdin:open sesame') => 'QWxhZGRpbjpvcGVuIHNlc2FtZQ=='], - - [ASCII('a') x 100 => 'YWFh' x 33 . 'YQ=='], - - [ASCII('Multipurpose Internet Mail Extensions: The Base64 Content-Transfer-Encoding is designed to represent sequences of octets in a form that is not humanly readable. ') - => "TXVsdGlwdXJwb3NlIEludGVybmV0IE1haWwgRXh0ZW5zaW9uczogVGhlIEJhc2U2NCBDb250ZW50LVRyYW5zZmVyLUVuY29kaW5nIGlzIGRlc2lnbmVkIHRvIHJlcHJlc2VudCBzZXF1ZW5jZXMgb2Ygb2N0ZXRzIGluIGEgZm9ybSB0aGF0IGlzIG5vdCBodW1hbmx5IHJlYWRhYmxlLiA="], - - ); - - for $test (@encode_tests) { - my($plain, $expected) = ($$test[0], $$test[1]); - - my $encoded = encode_base64($plain, ''); - if ($encoded ne $expected) { - print "test $testno ($plain): expected $expected, got $encoded\n"; - print "not "; - } - my $decoded = decode_base64($encoded); - if ($decoded ne $plain) { - print "test $testno ($encoded): expected $plain, got $decoded\n"; - print "not "; - } - - if (ord('A') != 193) { # perl versions broken on EBCDIC - # Try the old Perl versions too - if ($encoded ne MIME::Base64::old_encode_base64($plain, '')) { - print "old_encode_base64 give different result.\n"; - print "not "; - } - if ($plain ne MIME::Base64::old_decode_base64($encoded)) { - print "old_decode_base64 give different result.\n"; - print "not "; - } - } - - print "ok $testno\n"; - $testno++; - } -} - -sub decodeTest -{ - print "# decode test\n"; - - local $SIG{__WARN__} = sub { print $_[0] }; # avoid warnings on stderr - - my @decode_tests = ( - ['YWE=' => ASCII('aa')], - [' YWE=' => ASCII('aa')], - ['Y WE=' => ASCII('aa')], - ['YWE= ' => ASCII('aa')], - ["Y\nW\r\nE=" => ASCII('aa')], - - # These will generate some warnings - ['YWE=====' => ASCII('aa')], # extra padding - ['YWE' => ASCII('aa')], # missing padding - ['YWFh====' => ASCII('aaa')], - ['YQ' => ASCII('a')], - ['Y' => ''], - ['x==' => ''], - ['' => ''], - [undef() => ''], - ); - - for $test (@decode_tests) { - my($encoded, $expected) = ($$test[0], $$test[1]); - - my $decoded = decode_base64($encoded); - if ($decoded ne $expected) { - die "test $testno ($encoded): expected $expected, got $decoded\n"; - } - print "ok $testno\n"; - $testno++; - } -} diff --git a/t/lib/mimeb64u.t b/t/lib/mimeb64u.t deleted file mode 100644 index 0b8df1ae7c..0000000000 --- a/t/lib/mimeb64u.t +++ /dev/null @@ -1,16 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..1\n"; - -require MIME::Base64; - -eval { - MIME::Base64::encode(v300); -}; - -print "not " unless $@; -print "ok 1\n"; - diff --git a/t/lib/mimeqp.t b/t/lib/mimeqp.t deleted file mode 100755 index 1a7f9e4550..0000000000 --- a/t/lib/mimeqp.t +++ /dev/null @@ -1,113 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use MIME::QuotedPrint; - -$x70 = "x" x 70; - -@tests = - ( - # plain ascii should not be encoded - ["quoted printable" => - "quoted printable"], - - # 8-bit chars should be encoded - ["v\xe5re kj\xe6re norske tegn b\xf8r \xe6res" => - "v=E5re kj=E6re norske tegn b=F8r =E6res"], - - # trailing space should be encoded - [" " => "=20=20"], - ["\tt\t" => "\tt=09"], - ["test \ntest\n\t \t \n" => "test=20=20\ntest\n=09=20=09=20\n"], - - # "=" is special an should be decoded - ["=\n" => "=3D\n"], - ["\0\xff" => "=00=FF"], - - # Very long lines should be broken (not more than 76 chars - ["The Quoted-Printable encoding is intended to represent data that largly consists of octets that correspond to printable characters in the ASCII character set." => - "The Quoted-Printable encoding is intended to represent data that largly con= -sists of octets that correspond to printable characters in the ASCII charac= -ter set." - ], - - # Long lines after short lines were broken through 2.01. - ["short line -In America, any boy may become president and I suppose that's just one of the risks he takes. -- Adlai Stevenson" => - "short line -In America, any boy may become president and I suppose that's just one of t= -he risks he takes. -- Adlai Stevenson"], - - # My (roderick@argon.org) first crack at fixing that bug failed for - # multiple long lines. - ["College football is a game which would be much more interesting if the faculty played instead of the students, and even more interesting if the -trustees played. There would be a great increase in broken arms, legs, and necks, and simultaneously an appreciable diminution in the loss to humanity. -- H. L. Mencken" => - "College football is a game which would be much more interesting if the facu= -lty played instead of the students, and even more interesting if the -trustees played. There would be a great increase in broken arms, legs, and= - necks, and simultaneously an appreciable diminution in the loss to humanit= -y. -- H. L. Mencken"], - - # Don't break a line that's near but not over 76 chars. - ["$x70!23" => "$x70!23"], - ["$x70!234" => "$x70!234"], - ["$x70!2345" => "$x70!2345"], - ["$x70!23456" => "$x70!23456"], - ["$x70!23\n" => "$x70!23\n"], - ["$x70!234\n" => "$x70!234\n"], - ["$x70!2345\n" => "$x70!2345\n"], - ["$x70!23456\n" => "$x70!23456\n"], - - # Not allowed to break =XX escapes using soft line break - ["$x70===xxxx" => "$x70=3D=\n=3D=3Dxxxx"], - ["$x70!===xxx" => "$x70!=3D=\n=3D=3Dxxx"], - ["$x70!!===xx" => "$x70!!=3D=\n=3D=3Dxx"], - ["$x70!!!===x" => "$x70!!!=\n=3D=3D=3Dx"], - # ^ - # 70123456| - # max - # line width -); - -$notests = @tests + 2; -print "1..$notests\n"; - -$testno = 0; -for (@tests) { - $testno++; - ($plain, $encoded) = @$_; - if (ord('A') == 193) { # EBCDIC 8 bit chars are different - if ($testno == 2) { $plain =~ s/\xe5/\x47/; $plain =~ s/\xe6/\x9c/g; $plain =~ s/\xf8/\x70/; } - if ($testno == 7) { $plain =~ s/\xff/\xdf/; } - } - $x = encode_qp($plain); - if ($x ne $encoded) { - print "Encode test failed\n"; - print "Got: '$x'\n"; - print "Expected: '$encoded'\n"; - print "not ok $testno\n"; - next; - } - $x = decode_qp($encoded); - if ($x ne $plain) { - print "Decode test failed\n"; - print "Got: '$x'\n"; - print "Expected: '$plain'\n"; - print "not ok $testno\n"; - next; - } - print "ok $testno\n"; -} - -# Some extra testing for a case that was wrong until libwww-perl-5.09 -print "not " unless decode_qp("foo \n\nfoo =\n\nfoo=20\n\n") eq - "foo\n\nfoo \nfoo \n\n"; -$testno++; print "ok $testno\n"; - -# Same test but with "\r\n" terminated lines -print "not " unless decode_qp("foo \r\n\r\nfoo =\r\n\r\nfoo=20\r\n\r\n") eq - "foo\r\n\r\nfoo \r\nfoo \r\n\r\n"; -$testno++; print "ok $testno\n"; - diff --git a/t/lib/ndbm.t b/t/lib/ndbm.t deleted file mode 100755 index cb975e0047..0000000000 --- a/t/lib/ndbm.t +++ /dev/null @@ -1,420 +0,0 @@ -#!./perl - -# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bNDBM_File\b/) { - print "1..0 # Skip: NDBM_File was not built\n"; - exit 0; - } -} - -use strict; -use warnings; - -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - -require NDBM_File; -#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT -use Fcntl; - -print "1..65\n"; - -unlink <Op.dbmx*>; - -umask(0); -my %h; -ok(1, tie(%h,'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)); - -my $Dfile = "Op.dbmx.pag"; -if (! -e $Dfile) { - ($Dfile) = <Op.dbmx*>; -} -if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare') { - print "ok 2 # Skipped: different file permission semantics\n"; -} -else { - my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); - print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); -} -my $i = 0; -while (my ($key,$value) = each(%h)) { - $i++; -} -print (!$i ? "ok 3\n" : "not ok 3\n"); - -$h{'goner1'} = 'snork'; - -$h{'abc'} = 'ABC'; -$h{'def'} = 'DEF'; -$h{'jkl','mno'} = "JKL\034MNO"; -$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); -$h{'a'} = 'A'; -$h{'b'} = 'B'; -$h{'c'} = 'C'; -$h{'d'} = 'D'; -$h{'e'} = 'E'; -$h{'f'} = 'F'; -$h{'g'} = 'G'; -$h{'h'} = 'H'; -$h{'i'} = 'I'; - -$h{'goner2'} = 'snork'; -delete $h{'goner2'}; - -untie(%h); -print (tie(%h,'NDBM_File','Op.dbmx', &O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); - -$h{'j'} = 'J'; -$h{'k'} = 'K'; -$h{'l'} = 'L'; -$h{'m'} = 'M'; -$h{'n'} = 'N'; -$h{'o'} = 'O'; -$h{'p'} = 'P'; -$h{'q'} = 'Q'; -$h{'r'} = 'R'; -$h{'s'} = 'S'; -$h{'t'} = 'T'; -$h{'u'} = 'U'; -$h{'v'} = 'V'; -$h{'w'} = 'W'; -$h{'x'} = 'X'; -$h{'y'} = 'Y'; -$h{'z'} = 'Z'; - -$h{'goner3'} = 'snork'; - -delete $h{'goner1'}; -delete $h{'goner3'}; - -my @keys = keys(%h); -my @values = values(%h); - -if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} - -while (my ($key,$value) = each(%h)) { - if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { - $key =~ y/a-z/A-Z/; - $i++ if $key eq $value; - } -} - -if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";} - -@keys = ('blurfl', keys(%h), 'dyick'); -if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";} - -$h{'foo'} = ''; -$h{''} = 'bar'; - -# check cache overflow and numeric keys and contents -my $ok = 1; -for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } -for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } -print ($ok ? "ok 8\n" : "not ok 8\n"); - -my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); -print ($size > 0 ? "ok 9\n" : "not ok 9\n"); - -@h{0..200} = 200..400; -my @foo = @h{0..200}; -print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; - -print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); -print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); - -untie %h; -unlink 'Op.dbmx.dir', $Dfile; - -{ - # sub-class test - - package Another ; - - use strict ; - use warnings ; - - open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; - print FILE <<'EOM' ; - - package SubDB ; - - use strict ; - use warnings ; - use vars qw(@ISA @EXPORT) ; - - require Exporter ; - use NDBM_File; - @ISA=qw(NDBM_File); - @EXPORT = @NDBM_File::EXPORT if defined @NDBM_File::EXPORT ; - - sub STORE { - my $self = shift ; - my $key = shift ; - my $value = shift ; - $self->SUPER::STORE($key, $value * 2) ; - } - - sub FETCH { - my $self = shift ; - my $key = shift ; - $self->SUPER::FETCH($key) - 1 ; - } - - sub A_new_method - { - my $self = shift ; - my $key = shift ; - my $value = $self->FETCH($key) ; - return "[[$value]]" ; - } - - 1 ; -EOM - - close FILE ; - - BEGIN { push @INC, '.'; } - - eval 'use SubDB ; use Fcntl ; '; - main::ok(13, $@ eq "") ; - my %h ; - my $X ; - eval ' - $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640 ); - ' ; - - main::ok(14, $@ eq "") ; - - my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; - main::ok(15, $@ eq "") ; - main::ok(16, $ret == 5) ; - - $ret = eval '$X->A_new_method("fred") ' ; - main::ok(17, $@ eq "") ; - main::ok(18, $ret eq "[[5]]") ; - - undef $X; - untie(%h); - unlink "SubDB.pm", <dbhash.tmp*> ; - -} - -{ - # DBM Filter tests - use strict ; - use warnings ; - my (%h, $db) ; - my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - - sub checkOutput - { - my($fk, $sk, $fv, $sv) = @_ ; - return - $fetch_key eq $fk && $store_key eq $sk && - $fetch_value eq $fv && $store_value eq $sv && - $_ eq 'original' ; - } - - unlink <Op.dbmx*>; - ok(19, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ; - - $db->filter_fetch_key (sub { $fetch_key = $_ }) ; - $db->filter_store_key (sub { $store_key = $_ }) ; - $db->filter_fetch_value (sub { $fetch_value = $_}) ; - $db->filter_store_value (sub { $store_value = $_ }) ; - - $_ = "original" ; - - $h{"fred"} = "joe" ; - # fk sk fv sv - ok(20, checkOutput( "", "fred", "", "joe")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(21, $h{"fred"} eq "joe"); - # fk sk fv sv - ok(22, checkOutput( "", "fred", "joe", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(23, $db->FIRSTKEY() eq "fred") ; - # fk sk fv sv - ok(24, checkOutput( "fred", "", "", "")) ; - - # replace the filters, but remember the previous set - my ($old_fk) = $db->filter_fetch_key - (sub { $_ = uc $_ ; $fetch_key = $_ }) ; - my ($old_sk) = $db->filter_store_key - (sub { $_ = lc $_ ; $store_key = $_ }) ; - my ($old_fv) = $db->filter_fetch_value - (sub { $_ = "[$_]"; $fetch_value = $_ }) ; - my ($old_sv) = $db->filter_store_value - (sub { s/o/x/g; $store_value = $_ }) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - $h{"Fred"} = "Joe" ; - # fk sk fv sv - ok(25, checkOutput( "", "fred", "", "Jxe")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(26, $h{"Fred"} eq "[Jxe]"); - # fk sk fv sv - ok(27, checkOutput( "", "fred", "[Jxe]", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(28, $db->FIRSTKEY() eq "FRED") ; - # fk sk fv sv - ok(29, checkOutput( "FRED", "", "", "")) ; - - # put the original filters back - $db->filter_fetch_key ($old_fk); - $db->filter_store_key ($old_sk); - $db->filter_fetch_value ($old_fv); - $db->filter_store_value ($old_sv); - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - $h{"fred"} = "joe" ; - ok(30, checkOutput( "", "fred", "", "joe")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(31, $h{"fred"} eq "joe"); - ok(32, checkOutput( "", "fred", "joe", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(33, $db->FIRSTKEY() eq "fred") ; - ok(34, checkOutput( "fred", "", "", "")) ; - - # delete the filters - $db->filter_fetch_key (undef); - $db->filter_store_key (undef); - $db->filter_fetch_value (undef); - $db->filter_store_value (undef); - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - $h{"fred"} = "joe" ; - ok(35, checkOutput( "", "", "", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(36, $h{"fred"} eq "joe"); - ok(37, checkOutput( "", "", "", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(38, $db->FIRSTKEY() eq "fred") ; - ok(39, checkOutput( "", "", "", "")) ; - - undef $db ; - untie %h; - unlink <Op.dbmx*>; -} - -{ - # DBM Filter with a closure - - use strict ; - use warnings ; - my (%h, $db) ; - - unlink <Op.dbmx*>; - ok(40, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ; - - my %result = () ; - - sub Closure - { - my ($name) = @_ ; - my $count = 0 ; - my @kept = () ; - - return sub { ++$count ; - push @kept, $_ ; - $result{$name} = "$name - $count: [@kept]" ; - } - } - - $db->filter_store_key(Closure("store key")) ; - $db->filter_store_value(Closure("store value")) ; - $db->filter_fetch_key(Closure("fetch key")) ; - $db->filter_fetch_value(Closure("fetch value")) ; - - $_ = "original" ; - - $h{"fred"} = "joe" ; - ok(41, $result{"store key"} eq "store key - 1: [fred]"); - ok(42, $result{"store value"} eq "store value - 1: [joe]"); - ok(43, !defined $result{"fetch key"} ); - ok(44, !defined $result{"fetch value"} ); - ok(45, $_ eq "original") ; - - ok(46, $db->FIRSTKEY() eq "fred") ; - ok(47, $result{"store key"} eq "store key - 1: [fred]"); - ok(48, $result{"store value"} eq "store value - 1: [joe]"); - ok(49, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(50, ! defined $result{"fetch value"} ); - ok(51, $_ eq "original") ; - - $h{"jim"} = "john" ; - ok(52, $result{"store key"} eq "store key - 2: [fred jim]"); - ok(53, $result{"store value"} eq "store value - 2: [joe john]"); - ok(54, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(55, ! defined $result{"fetch value"} ); - ok(56, $_ eq "original") ; - - ok(57, $h{"fred"} eq "joe"); - ok(58, $result{"store key"} eq "store key - 3: [fred jim fred]"); - ok(59, $result{"store value"} eq "store value - 2: [joe john]"); - ok(60, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(61, $result{"fetch value"} eq "fetch value - 1: [joe]"); - ok(62, $_ eq "original") ; - - undef $db ; - untie %h; - unlink <Op.dbmx*>; -} - -{ - # DBM Filter recursion detection - use strict ; - use warnings ; - my (%h, $db) ; - unlink <Op.dbmx*>; - - ok(63, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ; - - $db->filter_store_key (sub { $_ = $h{$_} }) ; - - eval '$h{1} = 1234' ; - ok(64, $@ =~ /^recursion detected in filter_store_key at/ ); - - undef $db ; - untie %h; - unlink <Op.dbmx*>; -} - -{ - # Bug ID 20001013.009 - # - # test that $hash{KEY} = undef doesn't produce the warning - # Use of uninitialized value in null operation - use warnings ; - use strict ; - use NDBM_File ; - - unlink <Op.dbmx*>; - my %h ; - my $a = ""; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - - ok(65, tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ; -} diff --git a/t/lib/net-hostent.t b/t/lib/net-hostent.t deleted file mode 100644 index c3a12194ec..0000000000 --- a/t/lib/net-hostent.t +++ /dev/null @@ -1,72 +0,0 @@ -#!./perl -w - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bSocket\b/ && - !(($^O eq 'VMS') && $Config{d_socket})) { - print "1..0 # Test uses Socket, Socket not built\n"; - exit 0; - } -} - -BEGIN { $| = 1; print "1..7\n"; } - -END {print "not ok 1\n" unless $loaded;} - -use Net::hostent; - -$loaded = 1; -print "ok 1\n"; - -# test basic resolution of localhost <-> 127.0.0.1 -use Socket; - -my $h = gethost('localhost'); -print +(defined $h ? '' : 'not ') . "ok 2\n"; -my $i = gethostbyaddr(inet_aton("127.0.0.1")); -print +(!defined $i ? 'not ' : '') . "ok 3\n"; - -print "not " if inet_ntoa($h->addr) ne "127.0.0.1"; -print "ok 4\n"; - -print "not " if inet_ntoa($i->addr) ne "127.0.0.1"; -print "ok 5\n"; - -# need to skip the name comparisons on Win32 because windows will -# return the name of the machine instead of "localhost" when resolving -# 127.0.0.1 or even "localhost" - -# VMS returns "LOCALHOST" under tcp/ip services V4.1 ECO 2, possibly others -# OS/390 returns localhost.YADDA.YADDA - -if ($^O eq 'MSWin32' or $^O eq 'NetWare' or $^O eq 'cygwin') { - print "ok $_ # skipped on win32\n" for (6,7); -} else { - my $in_alias; - unless ($h->name =~ /^localhost(?:\..+)?$/i) { - foreach (@{$h->aliases}) { - if (/^localhost(?:\..+)?$/i) { - $in_alias = 1; - last; - } - } - print "not " unless $in_alias; - } # Else we found it as the hostname - print "ok 6 # ",$h->name, " ", join (",", @{$h->aliases}), "\n"; - - if ($in_alias) { - # If we found it in the aliases before, expect to find it there again. - foreach (@{$h->aliases}) { - if (/^localhost(?:\..+)?$/i) { - undef $in_alias; # This time, clear the flag if we see "localhost" - last; - } - } - print "not " if $in_alias; - } else { - print "not " unless $i->name =~ /^localhost(?:\..+)?$/i; - } - print "ok 7 # ",$h->name, " ", join (",", @{$h->aliases}), "\n"; -} diff --git a/t/lib/net-nent.t b/t/lib/net-nent.t deleted file mode 100644 index e73122ccc4..0000000000 --- a/t/lib/net-nent.t +++ /dev/null @@ -1,36 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -BEGIN { - our $hasne; - eval { my @n = getnetbyname "loopback" }; - $hasne = 1 unless $@ && $@ =~ /unimplemented/; - unless ($hasne) { print "1..0 # Skip: no getnetbyname\n"; exit 0 } - use Config; - $hasne = 0 unless $Config{'i_netdb'} eq 'define'; - unless ($hasne) { print "1..0 # Skip: no netdb.h\n"; exit 0 } -} - -BEGIN { - our @netent = getnetbyname "loopback"; # This is the function getnetbyname. - unless (@netent) { print "1..0 # Skip: no loopback net\n"; exit 0 } -} - -print "1..2\n"; - -use Net::netent; - -print "ok 1\n"; - -my $netent = getnetbyname "loopback"; # This is the OO getnetbyname. - -print "not " unless $netent->name eq $netent[0]; -print "ok 2\n"; - -# Testing pretty much anything else is unportable; -# e.g. the canonical name of the "loopback" net may be "loop". - diff --git a/t/lib/net-pent.t b/t/lib/net-pent.t deleted file mode 100644 index 6c5a1547b3..0000000000 --- a/t/lib/net-pent.t +++ /dev/null @@ -1,38 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -BEGIN { - our $haspe; - eval { my @n = getprotobyname "tcp" }; - $haspe = 1 unless $@ && $@ =~ /unimplemented/; - unless ($haspe) { print "1..0 # Skip: no getprotobyname\n"; exit 0 } - use Config; - $haspe = 0 unless $Config{'i_netdb'} eq 'define'; - unless ($haspe) { print "1..0 # Skip: no netdb.h\n"; exit 0 } -} - -BEGIN { - our @protoent = getprotobyname "tcp"; # This is the function getprotobyname. - unless (@protoent) { print "1..0 # Skip: no tcp protocol\n"; exit 0 } -} - -print "1..3\n"; - -use Net::protoent; - -print "ok 1\n"; - -my $protoent = getprotobyname "tcp"; # This is the OO getprotobyname. - -print "not " unless $protoent->name eq $protoent[0]; -print "ok 2\n"; - -print "not " unless $protoent->proto == $protoent[2]; -print "ok 3\n"; - -# Testing pretty much anything else is unportable. - diff --git a/t/lib/net-sent.t b/t/lib/net-sent.t deleted file mode 100644 index ef4a04dee8..0000000000 --- a/t/lib/net-sent.t +++ /dev/null @@ -1,38 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -BEGIN { - our $hasse; - eval { my @n = getservbyname "echo", "tcp" }; - $hasse = 1 unless $@ && $@ =~ /unimplemented/; - unless ($hasse) { print "1..0 # Skip: no getservbyname\n"; exit 0 } - use Config; - $hasse = 0 unless $Config{'i_netdb'} eq 'define'; - unless ($hasse) { print "1..0 # Skip: no netdb.h\n"; exit 0 } -} - -BEGIN { - our @servent = getservbyname "echo", "tcp"; # This is the function getservbyname. - unless (@servent) { print "1..0 # Skip: no echo service\n"; exit 0 } -} - -print "1..3\n"; - -use Net::servent; - -print "ok 1\n"; - -my $servent = getservbyname "echo", "tcp"; # This is the OO getservbyname. - -print "not " unless $servent->name eq $servent[0]; -print "ok 2\n"; - -print "not " unless $servent->port == $servent[2]; -print "ok 3\n"; - -# Testing pretty much anything else is unportable. - diff --git a/t/lib/next.t b/t/lib/next.t deleted file mode 100644 index 6328fd170c..0000000000 --- a/t/lib/next.t +++ /dev/null @@ -1,99 +0,0 @@ -#! /usr/local/bin/perl -w - - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -BEGIN { print "1..20\n"; } - -use NEXT; - -print "ok 1\n"; - -package A; -sub A::method { return ( 3, $_[0]->NEXT::method() ) } -sub A::DESTROY { $_[0]->NEXT::DESTROY() } - -package B; -use base qw( A ); -sub B::AUTOLOAD { return ( 9, $_[0]->NEXT::AUTOLOAD() ) } -sub B::DESTROY { $_[0]->NEXT::DESTROY() } - -package C; -sub C::DESTROY { print "ok 18\n"; $_[0]->NEXT::DESTROY() } - -package D; -@D::ISA = qw( B C E ); -sub D::method { return ( 2, $_[0]->NEXT::method() ) } -sub D::AUTOLOAD { return ( 8, $_[0]->NEXT::AUTOLOAD() ) } -sub D::DESTROY { print "ok 17\n"; $_[0]->NEXT::DESTROY() } -sub D::oops { $_[0]->NEXT::method() } - -package E; -@E::ISA = qw( F G ); -sub E::method { return ( 4, $_[0]->NEXT::method(), $_[0]->NEXT::method() ) } -sub E::AUTOLOAD { return ( 10, $_[0]->NEXT::AUTOLOAD() ) } -sub E::DESTROY { print "ok 19\n"; $_[0]->NEXT::DESTROY() } - -package F; -sub F::method { return ( 5 ) } -sub F::AUTOLOAD { return ( 11 ) } -sub F::DESTROY { print "ok 20\n" } - -package G; -sub G::method { return ( 6 ) } -sub G::AUTOLOAD { print "not "; return } -sub G::DESTROY { print "not ok 21"; return } - -package main; - -my $obj = bless {}, "D"; - -my @vals; - -# TEST NORMAL REDISPATCH (ok 2..6) -@vals = $obj->method(); -print map "ok $_\n", @vals; - -# RETEST NORMAL REDISPATCH SHOULD BE THE SAME (ok 7) -@vals = $obj->method(); -print "not " unless join("", @vals) == "23456"; -print "ok 7\n"; - -# TEST AUTOLOAD REDISPATCH (ok 8..11) -@vals = $obj->missing_method(); -print map "ok $_\n", @vals; - -# NAMED METHOD CAN'T REDISPATCH TO NAMED METHOD OF DIFFERENT NAME (ok 12) -eval { $obj->oops() } && print "not "; -print "ok 12\n"; - -# AUTOLOAD'ED METHOD CAN'T REDISPATCH TO NAMED METHOD (ok 13) -eval q{ - package C; - sub AUTOLOAD { $_[0]->NEXT::method() }; -}; -eval { $obj->missing_method(); } && print "not "; -print "ok 13\n"; - -# NAMED METHOD CAN'T REDISPATCH TO AUTOLOAD'ED METHOD (ok 14) -eval q{ - package C; - sub method { $_[0]->NEXT::AUTOLOAD() }; -}; -eval { $obj->method(); } && print "not "; -print "ok 14\n"; - -# BASE CLASS METHODS ONLY REDISPATCHED WITHIN HIERARCHY (ok 15..16) -my $ob2 = bless {}, "B"; -@val = $ob2->method(); -print "not " unless @val==1 && $val[0]==3; -print "ok 15\n"; - -@val = $ob2->missing_method(); -print "not " unless @val==1 && $val[0]==9; -print "ok 16\n"; - -# CAN REDISPATCH DESTRUCTORS (ok 17..20) diff --git a/t/lib/odbm.t b/t/lib/odbm.t deleted file mode 100755 index a43e70bd99..0000000000 --- a/t/lib/odbm.t +++ /dev/null @@ -1,437 +0,0 @@ -#!./perl - -# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bODBM_File\b/) { - print "1..0 # Skip: ODBM_File was not built\n"; - exit 0; - } -} - -use strict; -use warnings; - -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - -require ODBM_File; -#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT -use Fcntl; - -print "1..66\n"; - -unlink <Op.dbmx*>; - -umask(0); -my %h; -ok(1, tie(%h,'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)); - -my $Dfile = "Op.dbmx.pag"; -if (! -e $Dfile) { - ($Dfile) = <Op.dbmx*>; -} -if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare') { - print "ok 2 # Skipped: different file permission semantics\n"; -} -else { - my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); - print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); -} -my $i = 0; -while (my ($key,$value) = each(%h)) { - $i++; -} -print (!$i ? "ok 3\n" : "not ok 3\n"); - -$h{'goner1'} = 'snork'; - -$h{'abc'} = 'ABC'; -$h{'def'} = 'DEF'; -$h{'jkl','mno'} = "JKL\034MNO"; -$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); -$h{'a'} = 'A'; -$h{'b'} = 'B'; -$h{'c'} = 'C'; -$h{'d'} = 'D'; -$h{'e'} = 'E'; -$h{'f'} = 'F'; -$h{'g'} = 'G'; -$h{'h'} = 'H'; -$h{'i'} = 'I'; - -$h{'goner2'} = 'snork'; -delete $h{'goner2'}; - -untie(%h); -print (tie(%h,'ODBM_File','Op.dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); - -$h{'j'} = 'J'; -$h{'k'} = 'K'; -$h{'l'} = 'L'; -$h{'m'} = 'M'; -$h{'n'} = 'N'; -$h{'o'} = 'O'; -$h{'p'} = 'P'; -$h{'q'} = 'Q'; -$h{'r'} = 'R'; -$h{'s'} = 'S'; -$h{'t'} = 'T'; -$h{'u'} = 'U'; -$h{'v'} = 'V'; -$h{'w'} = 'W'; -$h{'x'} = 'X'; -$h{'y'} = 'Y'; -$h{'z'} = 'Z'; - -$h{'goner3'} = 'snork'; - -delete $h{'goner1'}; -delete $h{'goner3'}; - -my @keys = keys(%h); -my @values = values(%h); - -if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} - -while (my ($key,$value) = each(%h)) { - if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { - $key =~ y/a-z/A-Z/; - $i++ if $key eq $value; - } -} - -if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";} - -@keys = ('blurfl', keys(%h), 'dyick'); -if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";} - -$h{'foo'} = ''; -$h{''} = 'bar'; - -# check cache overflow and numeric keys and contents -my $ok = 1; -for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } -for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } -print ($ok ? "ok 8\n" : "not ok 8\n"); - -my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); -print ($size > 0 ? "ok 9\n" : "not ok 9\n"); - -@h{0..200} = 200..400; -my @foo = @h{0..200}; -print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; - -print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); -print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); - -untie %h; -unlink 'Op.dbmx.dir', $Dfile; - -{ - # sub-class test - - package Another ; - - use strict ; - use warnings ; - - open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; - print FILE <<'EOM' ; - - package SubDB ; - - use strict ; - use warnings ; - use vars qw(@ISA @EXPORT) ; - - require Exporter ; - use ODBM_File; - @ISA=qw(ODBM_File); - @EXPORT = @ODBM_File::EXPORT ; - - sub STORE { - my $self = shift ; - my $key = shift ; - my $value = shift ; - $self->SUPER::STORE($key, $value * 2) ; - } - - sub FETCH { - my $self = shift ; - my $key = shift ; - $self->SUPER::FETCH($key) - 1 ; - } - - sub A_new_method - { - my $self = shift ; - my $key = shift ; - my $value = $self->FETCH($key) ; - return "[[$value]]" ; - } - - 1 ; -EOM - - close FILE ; - - BEGIN { push @INC, '.'; } - - eval 'use SubDB ; use Fcntl ;'; - main::ok(13, $@ eq "") ; - my %h ; - my $X ; - eval ' - $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640 ); - ' ; - - main::ok(14, $@ eq "") ; - - my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; - main::ok(15, $@ eq "") ; - main::ok(16, $ret == 5) ; - - $ret = eval '$X->A_new_method("fred") ' ; - main::ok(17, $@ eq "") ; - main::ok(18, $ret eq "[[5]]") ; - - undef $X; - untie(%h); - unlink "SubDB.pm", <dbhash.tmp*> ; - -} - -{ - # DBM Filter tests - use strict ; - use warnings ; - my (%h, $db) ; - my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - - sub checkOutput - { - my($fk, $sk, $fv, $sv) = @_ ; - print "# ", join('|', $fetch_key, $fk, $store_key, $sk, - $fetch_value, $fv, $store_value, $sv, $_), "\n"; - return - $fetch_key eq $fk && $store_key eq $sk && - $fetch_value eq $fv && $store_value eq $sv && - $_ eq 'original' ; - } - - unlink <Op.dbmx*>; - ok(19, $db = tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ; - - $db->filter_fetch_key (sub { $fetch_key = $_ }) ; - $db->filter_store_key (sub { $store_key = $_ }) ; - $db->filter_fetch_value (sub { $fetch_value = $_}) ; - $db->filter_store_value (sub { $store_value = $_ }) ; - - $_ = "original" ; - - $h{"fred"} = "joe" ; - # fk sk fv sv - ok(20, checkOutput( "", "fred", "", "joe")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(21, $h{"fred"} eq "joe"); - # fk sk fv sv - ok(22, checkOutput( "", "fred", "joe", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(23, $db->FIRSTKEY() eq "fred") ; - # fk sk fv sv - ok(24, checkOutput( "fred", "", "", "")) ; - - # replace the filters, but remember the previous set - my ($old_fk) = $db->filter_fetch_key - (sub { $_ = uc $_ ; $fetch_key = $_ }) ; - my ($old_sk) = $db->filter_store_key - (sub { $_ = lc $_ ; $store_key = $_ }) ; - my ($old_fv) = $db->filter_fetch_value - (sub { $_ = "[$_]"; $fetch_value = $_ }) ; - my ($old_sv) = $db->filter_store_value - (sub { s/o/x/g; $store_value = $_ }) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - $h{"Fred"} = "Joe" ; - # fk sk fv sv - ok(25, checkOutput( "", "fred", "", "Jxe")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(26, $h{"Fred"} eq "[Jxe]"); - # fk sk fv sv - ok(27, checkOutput( "", "fred", "[Jxe]", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(28, $db->FIRSTKEY() eq "FRED") ; - # fk sk fv sv - ok(29, checkOutput( "FRED", "", "", "")) ; - - # put the original filters back - $db->filter_fetch_key ($old_fk); - $db->filter_store_key ($old_sk); - $db->filter_fetch_value ($old_fv); - $db->filter_store_value ($old_sv); - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - $h{"fred"} = "joe" ; - ok(30, checkOutput( "", "fred", "", "joe")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(31, $h{"fred"} eq "joe"); - ok(32, checkOutput( "", "fred", "joe", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(33, $db->FIRSTKEY() eq "fred") ; - ok(34, checkOutput( "fred", "", "", "")) ; - - # delete the filters - $db->filter_fetch_key (undef); - $db->filter_store_key (undef); - $db->filter_fetch_value (undef); - $db->filter_store_value (undef); - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - $h{"fred"} = "joe" ; - ok(35, checkOutput( "", "", "", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(36, $h{"fred"} eq "joe"); - ok(37, checkOutput( "", "", "", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(38, $db->FIRSTKEY() eq "fred") ; - ok(39, checkOutput( "", "", "", "")) ; - - undef $db ; - untie %h; - unlink <Op.dbmx*>; -} - -{ - # DBM Filter with a closure - - use strict ; - use warnings ; - my (%h, $db) ; - - unlink <Op.dbmx*>; - ok(40, $db = tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ; - - my %result = () ; - - sub Closure - { - my ($name) = @_ ; - my $count = 0 ; - my @kept = () ; - - return sub { ++$count ; - push @kept, $_ ; - $result{$name} = "$name - $count: [@kept]" ; - } - } - - $db->filter_store_key(Closure("store key")) ; - $db->filter_store_value(Closure("store value")) ; - $db->filter_fetch_key(Closure("fetch key")) ; - $db->filter_fetch_value(Closure("fetch value")) ; - - $_ = "original" ; - - $h{"fred"} = "joe" ; - ok(41, $result{"store key"} eq "store key - 1: [fred]"); - ok(42, $result{"store value"} eq "store value - 1: [joe]"); - ok(43, !defined $result{"fetch key"} ); - ok(44, !defined $result{"fetch value"} ); - ok(45, $_ eq "original") ; - - ok(46, $db->FIRSTKEY() eq "fred") ; - ok(47, $result{"store key"} eq "store key - 1: [fred]"); - ok(48, $result{"store value"} eq "store value - 1: [joe]"); - ok(49, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(50, ! defined $result{"fetch value"} ); - ok(51, $_ eq "original") ; - - $h{"jim"} = "john" ; - ok(52, $result{"store key"} eq "store key - 2: [fred jim]"); - ok(53, $result{"store value"} eq "store value - 2: [joe john]"); - ok(54, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(55, ! defined $result{"fetch value"} ); - ok(56, $_ eq "original") ; - - ok(57, $h{"fred"} eq "joe"); - ok(58, $result{"store key"} eq "store key - 3: [fred jim fred]"); - ok(59, $result{"store value"} eq "store value - 2: [joe john]"); - ok(60, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(61, $result{"fetch value"} eq "fetch value - 1: [joe]"); - ok(62, $_ eq "original") ; - - undef $db ; - untie %h; - unlink <Op.dbmx*>; -} - -{ - # DBM Filter recursion detection - use strict ; - use warnings ; - my (%h, $db) ; - unlink <Op.dbmx*>; - - ok(63, $db = tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ; - - $db->filter_store_key (sub { $_ = $h{$_} }) ; - - eval '$h{1} = 1234' ; - ok(64, $@ =~ /^recursion detected in filter_store_key at/ ); - - undef $db ; - untie %h; - unlink <Op.dbmx*>; -} - -{ - # Bug ID 20001013.009 - # - # test that $hash{KEY} = undef doesn't produce the warning - # Use of uninitialized value in null operation - use warnings ; - use strict ; - use ODBM_File ; - - unlink <Op.dbmx*>; - my %h ; - my $a = ""; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - - ok(65, tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ; - $h{ABC} = undef; - ok(66, $a eq "") ; - untie %h; - unlink <Op.dbmx*>; -} - -if ($^O eq 'hpux') { - print <<EOM; -# -# If you experience failures with the odbm test in HP-UX, -# this is a well-known bug that's unfortunately very hard to fix. -# The suggested course of action is to avoid using the ODBM_File, -# but to use instead the NDBM_File extension. -# -EOM -} diff --git a/t/lib/opcode.t b/t/lib/opcode.t deleted file mode 100755 index a785fce48b..0000000000 --- a/t/lib/opcode.t +++ /dev/null @@ -1,115 +0,0 @@ -#!./perl -w - -$|=1; - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { - print "1..0\n"; - exit 0; - } -} - -use Opcode qw( - opcodes opdesc opmask verify_opset - opset opset_to_ops opset_to_hex invert_opset - opmask_add full_opset empty_opset define_optag -); - -use strict; - -my $t = 1; -my $last_test; # initalised at end -print "1..$last_test\n"; - -my($s1, $s2, $s3); -my(@o1, @o2, @o3); - -# --- opset_to_ops and opset - -my @empty_l = opset_to_ops(empty_opset); -print @empty_l == 0 ? "ok $t\n" : "not ok $t\n"; $t++; - -my @full_l1 = opset_to_ops(full_opset); -print @full_l1 == opcodes() ? "ok $t\n" : "not ok $t\n"; $t++; -my @full_l2 = @full_l1; # = opcodes(); # XXX to be fixed -print "@full_l1" eq "@full_l2" ? "ok $t\n" : "not ok $t\n"; $t++; - -@empty_l = opset_to_ops(opset(':none')); -print @empty_l == 0 ? "ok $t\n" : "not ok $t\n"; $t++; - -my @full_l3 = opset_to_ops(opset(':all')); -print @full_l1 == @full_l3 ? "ok $t\n" : "not ok $t\n"; $t++; -print "@full_l1" eq "@full_l3" ? "ok $t\n" : "not ok $t\n"; $t++; - -die $t unless $t == 7; -$s1 = opset( 'padsv'); -$s2 = opset($s1, 'padav'); -$s3 = opset($s2, '!padav'); -print $s1 eq $s2 ? "not ok $t\n" : "ok $t\n"; ++$t; -print $s1 eq $s3 ? "ok $t\n" : "not ok $t\n"; ++$t; - -# --- define_optag - -print eval { opset(':_tst_') } ? "not ok $t\n" : "ok $t\n"; ++$t; -define_optag(":_tst_", opset(qw(padsv padav padhv))); -print eval { opset(':_tst_') } ? "ok $t\n" : "not ok $t\n"; ++$t; - -# --- opdesc and opcodes - -die $t unless $t == 11; -print opdesc("gv") eq "glob value" ? "ok $t\n" : "not ok $t\n"; $t++; -my @desc = opdesc(':_tst_','stub'); -print "@desc" eq "private variable private array private hash stub" - ? "ok $t\n" : "not ok $t\n#@desc\n"; $t++; -print opcodes() ? "ok $t\n" : "not ok $t\n"; $t++; -print "ok $t\n"; ++$t; - -# --- invert_opset - -$s1 = opset(qw(fileno padsv padav)); -@o2 = opset_to_ops(invert_opset($s1)); -print @o2 == opcodes-3 ? "ok $t\n" : "not ok $t\n"; $t++; - -# --- opmask - -die $t unless $t == 16; -print opmask() eq empty_opset() ? "ok $t\n" : "not ok $t\n"; $t++; # work -print length opmask() == int((opcodes()+7)/8) ? "ok $t\n" : "not ok $t\n"; $t++; - -# --- verify_opset - -print verify_opset($s1) && !verify_opset(42) ? "ok $t\n":"not ok $t\n"; $t++; - -# --- opmask_add - -opmask_add(opset(qw(fileno))); # add to global op_mask -print eval 'fileno STDOUT' ? "not ok $t\n" : "ok $t\n"; $t++; # fail -print $@ =~ /fileno trapped/ ? "ok $t\n" : "not ok $t\n# $@\n"; $t++; - -# --- check use of bit vector ops on opsets - -$s1 = opset('padsv'); -$s2 = opset('padav'); -$s3 = opset('padsv', 'padav', 'padhv'); - -# Non-negated -print (($s1 | $s2) eq opset($s1,$s2) ? "ok $t\n":"not ok $t\n"); $t++; -print (($s2 & $s3) eq opset($s2) ? "ok $t\n":"not ok $t\n"); $t++; -print (($s2 ^ $s3) eq opset('padsv','padhv') ? "ok $t\n":"not ok $t\n"); $t++; - -# Negated, e.g., with possible extra bits in last byte beyond last op bit. -# The extra bits mean we can't just say ~mask eq invert_opset(mask). - -@o1 = opset_to_ops( ~ $s3); -@o2 = opset_to_ops(invert_opset $s3); -print "@o1" eq "@o2" ? "ok $t\n":"not ok $t\n"; $t++; - -# --- finally, check some opname assertions - -foreach(@full_l1) { die "bad opname: $_" if /\W/ or /^\d/ } - -print "ok $last_test\n"; -BEGIN { $last_test = 25 } diff --git a/t/lib/open2.t b/t/lib/open2.t deleted file mode 100755 index fe49189d83..0000000000 --- a/t/lib/open2.t +++ /dev/null @@ -1,59 +0,0 @@ -#!./perl -w - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if (!$Config{'d_fork'} - # open2/3 supported on win32 (but not Borland due to CRT bugs) - && (($^O ne 'MSWin32' && $^O ne 'NetWare') || $Config{'cc'} =~ /^bcc/i)) - { - print "1..0\n"; - exit 0; - } - # make warnings fatal - $SIG{__WARN__} = sub { die @_ }; -} - -use strict; -use IO::Handle; -use IPC::Open2; -#require 'open2.pl'; use subs 'open2'; - -my $perl = './perl'; - -sub ok { - my ($n, $result, $info) = @_; - if ($result) { - print "ok $n\n"; - } - else { - print "not ok $n\n"; - print "# $info\n" if $info; - } -} - -sub cmd_line { - if ($^O eq 'MSWin32' || $^O eq 'NetWare') { - return qq/"$_[0]"/; - } - else { - return $_[0]; - } -} - -my ($pid, $reaped_pid); -STDOUT->autoflush; -STDERR->autoflush; - -print "1..7\n"; - -ok 1, $pid = open2 'READ', 'WRITE', $perl, '-e', - cmd_line('print scalar <STDIN>'); -ok 2, print WRITE "hi kid\n"; -ok 3, <READ> =~ /^hi kid\r?\n$/; -ok 4, close(WRITE), $!; -ok 5, close(READ), $!; -$reaped_pid = waitpid $pid, 0; -ok 6, $reaped_pid == $pid, $reaped_pid; -ok 7, $? == 0, $?; diff --git a/t/lib/open3.t b/t/lib/open3.t deleted file mode 100755 index 7d2d4113df..0000000000 --- a/t/lib/open3.t +++ /dev/null @@ -1,150 +0,0 @@ -#!./perl -w - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if (!$Config{'d_fork'} - # open2/3 supported on win32 (but not Borland due to CRT bugs) - && (($^O ne 'MSWin32' && $^O ne 'NetWare') || $Config{'cc'} =~ /^bcc/i)) - { - print "1..0\n"; - exit 0; - } - # make warnings fatal - $SIG{__WARN__} = sub { die @_ }; -} - -use strict; -use IO::Handle; -use IPC::Open3; -#require 'open3.pl'; use subs 'open3'; - -my $perl = $^X; - -sub ok { - my ($n, $result, $info) = @_; - if ($result) { - print "ok $n\n"; - } - else { - print "not ok $n\n"; - print "# $info\n" if $info; - } -} - -sub cmd_line { - if ($^O eq 'MSWin32' || $^O eq 'NetWare') { - my $cmd = shift; - $cmd =~ tr/\r\n//d; - $cmd =~ s/"/\\"/g; - return qq/"$cmd"/; - } - else { - return $_[0]; - } -} - -my ($pid, $reaped_pid); -STDOUT->autoflush; -STDERR->autoflush; - -print "1..22\n"; - -# basic -ok 1, $pid = open3 'WRITE', 'READ', 'ERROR', $perl, '-e', cmd_line(<<'EOF'); - $| = 1; - print scalar <STDIN>; - print STDERR "hi error\n"; -EOF -ok 2, print WRITE "hi kid\n"; -ok 3, <READ> =~ /^hi kid\r?\n$/; -ok 4, <ERROR> =~ /^hi error\r?\n$/; -ok 5, close(WRITE), $!; -ok 6, close(READ), $!; -ok 7, close(ERROR), $!; -$reaped_pid = waitpid $pid, 0; -ok 8, $reaped_pid == $pid, $reaped_pid; -ok 9, $? == 0, $?; - -# read and error together, both named -$pid = open3 'WRITE', 'READ', 'READ', $perl, '-e', cmd_line(<<'EOF'); - $| = 1; - print scalar <STDIN>; - print STDERR scalar <STDIN>; -EOF -print WRITE "ok 10\n"; -print scalar <READ>; -print WRITE "ok 11\n"; -print scalar <READ>; -waitpid $pid, 0; - -# read and error together, error empty -$pid = open3 'WRITE', 'READ', '', $perl, '-e', cmd_line(<<'EOF'); - $| = 1; - print scalar <STDIN>; - print STDERR scalar <STDIN>; -EOF -print WRITE "ok 12\n"; -print scalar <READ>; -print WRITE "ok 13\n"; -print scalar <READ>; -waitpid $pid, 0; - -# dup writer -ok 14, pipe PIPE_READ, PIPE_WRITE; -$pid = open3 '<&PIPE_READ', 'READ', '', - $perl, '-e', cmd_line('print scalar <STDIN>'); -close PIPE_READ; -print PIPE_WRITE "ok 15\n"; -close PIPE_WRITE; -print scalar <READ>; -waitpid $pid, 0; - -# dup reader -$pid = open3 'WRITE', '>&STDOUT', 'ERROR', - $perl, '-e', cmd_line('print scalar <STDIN>'); -print WRITE "ok 16\n"; -waitpid $pid, 0; - -# dup error: This particular case, duping stderr onto the existing -# stdout but putting stdout somewhere else, is a good case because it -# used not to work. -$pid = open3 'WRITE', 'READ', '>&STDOUT', - $perl, '-e', cmd_line('print STDERR scalar <STDIN>'); -print WRITE "ok 17\n"; -waitpid $pid, 0; - -# dup reader and error together, both named -$pid = open3 'WRITE', '>&STDOUT', '>&STDOUT', $perl, '-e', cmd_line(<<'EOF'); - $| = 1; - print STDOUT scalar <STDIN>; - print STDERR scalar <STDIN>; -EOF -print WRITE "ok 18\n"; -print WRITE "ok 19\n"; -waitpid $pid, 0; - -# dup reader and error together, error empty -$pid = open3 'WRITE', '>&STDOUT', '', $perl, '-e', cmd_line(<<'EOF'); - $| = 1; - print STDOUT scalar <STDIN>; - print STDERR scalar <STDIN>; -EOF -print WRITE "ok 20\n"; -print WRITE "ok 21\n"; -waitpid $pid, 0; - -# command line in single parameter variant of open3 -# for understanding of Config{'sh'} test see exec description in camel book -my $cmd = 'print(scalar(<STDIN>))'; -$cmd = $Config{'sh'} =~ /sh/ ? "'$cmd'" : cmd_line($cmd); -eval{$pid = open3 'WRITE', '>&STDOUT', 'ERROR', "$perl -e " . $cmd; }; -if ($@) { - print "error $@\n"; - print "not ok 22\n"; -} -else { - print WRITE "ok 22\n"; - waitpid $pid, 0; -} diff --git a/t/lib/ops.t b/t/lib/ops.t deleted file mode 100755 index 56b1bacabb..0000000000 --- a/t/lib/ops.t +++ /dev/null @@ -1,29 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { - print "1..0\n"; - exit 0; - } -} - -print "1..2\n"; - -eval <<'EOP'; - no ops 'fileno'; # equiv to "perl -M-ops=fileno" - $a = fileno STDIN; -EOP - -print $@ =~ /trapped/ ? "ok 1\n" : "not ok 1\n# $@\n"; - -eval <<'EOP'; - use ops ':default'; # equiv to "perl -M(as above) -Mops=:default" - eval 1; -EOP - -print $@ =~ /trapped/ ? "ok 2\n" : "not ok 2\n# $@\n"; - -1; diff --git a/t/lib/parsewords.t b/t/lib/parsewords.t deleted file mode 100755 index 261d81f3a4..0000000000 --- a/t/lib/parsewords.t +++ /dev/null @@ -1,110 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use warnings; -use Text::ParseWords; - -print "1..18\n"; - -@words = shellwords(qq(foo "bar quiz" zoo)); -print "not " if $words[0] ne 'foo'; -print "ok 1\n"; -print "not " if $words[1] ne 'bar quiz'; -print "ok 2\n"; -print "not " if $words[2] ne 'zoo'; -print "ok 3\n"; - -{ - # Gonna get some undefined things back - no warnings 'uninitialized' ; - - # Test quotewords() with other parameters and null last field - @words = quotewords(':+', 1, 'foo:::"bar:foo":zoo zoo:'); - print "not " unless join(";", @words) eq qq(foo;"bar:foo";zoo zoo;); - print "ok 4\n"; -} - -# Test $keep eq 'delimiters' and last field zero -@words = quotewords('\s+', 'delimiters', '4 3 2 1 0'); -print "not " unless join(";", @words) eq qq(4; ;3; ;2; ;1; ;0); -print "ok 5\n"; - -# Big ol' nasty test (thanks, Joerk!) -$string = 'aaaa"bbbbb" cc\\ cc \\\\\\"dddd" eee\\\\\\"ffff" "gg"'; - -# First with $keep == 1 -$result = join('|', parse_line('\s+', 1, $string)); -print "not " unless $result eq 'aaaa"bbbbb"|cc\\ cc|\\\\\\"dddd" eee\\\\\\"ffff"|"gg"'; -print "ok 6\n"; - -# Now, $keep == 0 -$result = join('|', parse_line('\s+', 0, $string)); -print "not " unless $result eq 'aaaabbbbb|cc cc|\\"dddd eee\\"ffff|gg'; -print "ok 7\n"; - -# Now test single quote behavior -$string = 'aaaa"bbbbb" cc\\ cc \\\\\\"dddd\' eee\\\\\\"ffff\' gg'; -$result = join('|', parse_line('\s+', 0, $string)); -print "not " unless $result eq 'aaaabbbbb|cc cc|\\"dddd eee\\\\\\"ffff|gg'; -print "ok 8\n"; - -# Make sure @nested_quotewords does the right thing -@lists = nested_quotewords('\s+', 0, 'a b c', '1 2 3', 'x y z'); -print "not " unless (@lists == 3 && @{$lists[0]} == 3 && @{$lists[1]} == 3 && @{$lists[2]} == 3); -print "ok 9\n"; - -# Now test error return -$string = 'foo bar baz"bach blech boop'; - -@words = shellwords($string); -print "not " if (@words); -print "ok 10\n"; - -@words = parse_line('s+', 0, $string); -print "not " if (@words); -print "ok 11\n"; - -@words = quotewords('s+', 0, $string); -print "not " if (@words); -print "ok 12\n"; - -{ - # Gonna get some more undefined things back - no warnings 'uninitialized' ; - - @words = nested_quotewords('s+', 0, $string); - print "not " if (@words); - print "ok 13\n"; - - # Now test empty fields - $result = join('|', parse_line(':', 0, 'foo::0:"":::')); - print "not " unless ($result eq 'foo||0||||'); - print "ok 14\n"; - - # Test for 0 in quotes without $keep - $result = join('|', parse_line(':', 0, ':"0":')); - print "not " unless ($result eq '|0|'); - print "ok 15\n"; - - # Test for \001 in quoted string - $result = join('|', parse_line(':', 0, ':"' . "\001" . '":')); - print "not " unless ($result eq "|\1|"); - print "ok 16\n"; - -} - -# Now test perlish single quote behavior -$Text::ParseWords::PERL_SINGLE_QUOTE = 1; -$string = 'aaaa"bbbbb" cc\ cc \\\\\"dddd\' eee\\\\\"\\\'ffff\' gg'; -$result = join('|', parse_line('\s+', 0, $string)); -print "not " unless $result eq 'aaaabbbbb|cc cc|\"dddd eee\\\\"\'ffff|gg'; -print "ok 17\n"; - -# test whitespace in the delimiters -@words = quotewords(' ', 1, '4 3 2 1 0'); -print "not " unless join(";", @words) eq qq(4;3;2;1;0); -print "ok 18\n"; diff --git a/t/lib/peek.t b/t/lib/peek.t deleted file mode 100644 index c14dc9bdad..0000000000 --- a/t/lib/peek.t +++ /dev/null @@ -1,308 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bPeek\b/) { - print "1..0 # Skip: Devel::Peek was not built\n"; - exit 0; - } -} - -use Devel::Peek; - -print "1..17\n"; - -our $DEBUG = 0; -open(SAVERR, ">&STDERR") or die "Can't dup STDERR: $!"; - -sub do_test { - my $pattern = pop; - if (open(OUT,">peek$$")) { - open(STDERR, ">&OUT") or die "Can't dup OUT: $!"; - Dump($_[1]); - open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!"; - close(OUT); - if (open(IN, "peek$$")) { - local $/; - $pattern =~ s/\$ADDR/0x[[:xdigit:]]+/g; - print $pattern, "\n" if $DEBUG; - my $dump = <IN>; - print $dump, "\n" if $DEBUG; - print "[$dump] vs [$pattern]\nnot " unless $dump =~ /$pattern/ms; - print "ok $_[0]\n"; - close(IN); - } else { - die "$0: failed to open peek$$: !\n"; - } - } else { - die "$0: failed to create peek$$: $!\n"; - } -} - -our $a; -our $b; -my $c; -local $d = 0; - -do_test( 1, - $a = "foo", -'SV = PV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(POK,pPOK\\) - PV = $ADDR "foo"\\\0 - CUR = 3 - LEN = 4' - ); - -do_test( 2, - "bar", -'SV = PV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(.*POK,READONLY,pPOK\\) - PV = $ADDR "bar"\\\0 - CUR = 3 - LEN = 4'); - -do_test( 3, - $b = 123, -'SV = IV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(IOK,pIOK\\) - IV = 123'); - -do_test( 4, - 456, -'SV = IV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(.*IOK,READONLY,pIOK\\) - IV = 456'); - -do_test( 5, - $c = 456, -'SV = IV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(PADBUSY,PADMY,IOK,pIOK\\) - IV = 456'); - -do_test( 6, - $c + $d, -'SV = IV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(PADTMP,IOK,pIOK\\) - IV = 456'); - -($d = "789") += 0.1; - -do_test( 7, - $d, -'SV = PVNV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(NOK,pNOK\\) - IV = 0 - NV = 789\\.(?:1(?:000+\d+)?|0999+\d+) - PV = $ADDR "789"\\\0 - CUR = 3 - LEN = 4'); - -do_test( 8, - 0xabcd, -'SV = IV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(.*IOK,READONLY,pIOK\\) - IV = 43981'); - -do_test( 9, - undef, -'SV = NULL\\(0x0\\) at $ADDR - REFCNT = 1 - FLAGS = \\(\\)'); - -do_test(10, - \$a, -'SV = RV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(ROK\\) - RV = $ADDR - SV = PV\\($ADDR\\) at $ADDR - REFCNT = 2 - FLAGS = \\(POK,pPOK\\) - PV = $ADDR "foo"\\\0 - CUR = 3 - LEN = 4'); - -do_test(11, - [$b,$c], -'SV = RV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(ROK\\) - RV = $ADDR - SV = PVAV\\($ADDR\\) at $ADDR - REFCNT = 2 - FLAGS = \\(\\) - IV = 0 - NV = 0 - ARRAY = $ADDR - FILL = 1 - MAX = 1 - ARYLEN = 0x0 - FLAGS = \\(REAL\\) - Elt No. 0 - SV = IV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(IOK,pIOK\\) - IV = 123 - Elt No. 1 - SV = IV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(IOK,pIOK\\) - IV = 456'); - -do_test(12, - {$b=>$c}, -'SV = RV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(ROK\\) - RV = $ADDR - SV = PVHV\\($ADDR\\) at $ADDR - REFCNT = 2 - FLAGS = \\(SHAREKEYS\\) - IV = 1 - NV = 0 - ARRAY = $ADDR \\(0:7, 1:1\\) - hash quality = 100.0% - KEYS = 1 - FILL = 1 - MAX = 7 - RITER = -1 - EITER = 0x0 - Elt "123" HASH = $ADDR - SV = IV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(IOK,pIOK\\) - IV = 456'); - -do_test(13, - sub(){@_}, -'SV = RV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(ROK\\) - RV = $ADDR - SV = PVCV\\($ADDR\\) at $ADDR - REFCNT = 2 - FLAGS = \\(PADBUSY,PADMY,POK,pPOK,ANON\\) - IV = 0 - NV = 0 - PROTOTYPE = "" - COMP_STASH = $ADDR\\t"main" - START = $ADDR ===> \\d+ - ROOT = $ADDR - XSUB = 0x0 - XSUBANY = 0 - GVGV::GV = $ADDR\\t"main" :: "__ANON__[^"]*" - FILE = ".*\\b(?i:peek\\.t)" - DEPTH = 0 -(?: MUTEXP = $ADDR - OWNER = $ADDR -)? FLAGS = 0x4 - PADLIST = $ADDR - OUTSIDE = $ADDR \\(MAIN\\)'); - -do_test(14, - \&do_test, -'SV = RV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(ROK\\) - RV = $ADDR - SV = PVCV\\($ADDR\\) at $ADDR - REFCNT = (3|4) - FLAGS = \\(\\) - IV = 0 - NV = 0 - COMP_STASH = $ADDR\\t"main" - START = $ADDR ===> \\d+ - ROOT = $ADDR - XSUB = 0x0 - XSUBANY = 0 - GVGV::GV = $ADDR\\t"main" :: "do_test" - FILE = ".*\\b(?i:peek\\.t)" - DEPTH = 1 -(?: MUTEXP = $ADDR - OWNER = $ADDR -)? FLAGS = 0x0 - PADLIST = $ADDR - \\d+\\. $ADDR \\("\\$pattern" \\d+-\\d+\\) - \\d+\\. $ADDR \\(FAKE "\\$DEBUG" 0-\\d+\\) - \\d+\\. $ADDR \\("\\$dump" \\d+-\\d+\\) - OUTSIDE = $ADDR \\(MAIN\\)'); - -do_test(15, - qr(tic), -'SV = RV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(ROK\\) - RV = $ADDR - SV = PVMG\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(OBJECT,RMG\\) - IV = 0 - NV = 0 - PV = 0 - MAGIC = $ADDR - MG_VIRTUAL = $ADDR - MG_TYPE = PERL_MAGIC_qr\(r\) - MG_OBJ = $ADDR - STASH = $ADDR\\t"Regexp"'); - -do_test(16, - (bless {}, "Tac"), -'SV = RV\\($ADDR\\) at $ADDR - REFCNT = 1 - FLAGS = \\(ROK\\) - RV = $ADDR - SV = PVHV\\($ADDR\\) at $ADDR - REFCNT = 2 - FLAGS = \\(OBJECT,SHAREKEYS\\) - IV = 0 - NV = 0 - STASH = $ADDR\\t"Tac" - ARRAY = 0x0 - KEYS = 0 - FILL = 0 - MAX = 7 - RITER = -1 - EITER = 0x0'); - -do_test(17, - *a, -'SV = PVGV\\($ADDR\\) at $ADDR - REFCNT = 5 - FLAGS = \\(GMG,SMG,MULTI(?:,IN_PAD)?\\) - IV = 0 - NV = 0 - MAGIC = $ADDR - MG_VIRTUAL = &PL_vtbl_glob - MG_TYPE = PERL_MAGIC_glob\(\*\) - MG_OBJ = $ADDR - NAME = "a" - NAMELEN = 1 - GvSTASH = $ADDR\\t"main" - GP = $ADDR - SV = $ADDR - REFCNT = 1 - IO = 0x0 - FORM = 0x0 - AV = 0x0 - HV = 0x0 - CV = 0x0 - CVGEN = 0x0 - GPFLAGS = 0x0 - LINE = \\d+ - FILE = ".*\\b(?i:peek\\.t)" - FLAGS = $ADDR - EGV = $ADDR\\t"a"'); - -END { - 1 while unlink("peek$$"); -} diff --git a/t/lib/perlio.t b/t/lib/perlio.t deleted file mode 100644 index d71ab8ec4f..0000000000 --- a/t/lib/perlio.t +++ /dev/null @@ -1,90 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bPerlIO\b/) { - print "1..0 # Skip: PerlIO was not built\n"; - exit 0; - } -} - -use PerlIO; - -print "1..19\n"; - -print "ok 1\n"; - -my $txt = "txt$$"; -my $bin = "bin$$"; -my $utf = "utf$$"; - -my $txtfh; -my $binfh; -my $utffh; - -print "not " unless open($txtfh, ">:crlf", $txt); -print "ok 2\n"; - -print "not " unless open($binfh, ">:raw", $bin); -print "ok 3\n"; - -print "not " unless open($utffh, ">:utf8", $utf); -print "ok 4\n"; - -print $txtfh "foo\n"; -print $txtfh "bar\n"; -print "not " unless close($txtfh); -print "ok 5\n"; - -print $binfh "foo\n"; -print $binfh "bar\n"; -print "not " unless close($binfh); -print "ok 6\n"; - -print $utffh "foo\x{ff}\n"; -print $utffh "bar\x{abcd}\n"; -print "not " unless close($utffh); -print "ok 7\n"; - -print "not " unless open($txtfh, "<:crlf", $txt); -print "ok 8\n"; - -print "not " unless open($binfh, "<:raw", $bin); -print "ok 9\n"; - -print "not " unless open($utffh, "<:utf8", $utf); -print "ok 10\n"; - -print "not " unless <$txtfh> eq "foo\n" && <$txtfh> eq "bar\n"; -print "ok 11\n"; - -print "not " unless <$binfh> eq "foo\n" && <$binfh> eq "bar\n"; -print "ok 12\n"; - -print "not " unless <$utffh> eq "foo\x{ff}\n" && <$utffh> eq "bar\x{abcd}\n"; -print "ok 13\n"; - -print "not " unless eof($txtfh); -print "ok 14\n"; - -print "not " unless eof($binfh); -print "ok 15\n"; - -print "not " unless eof($utffh); -print "ok 16\n"; - -print "not " unless close($txtfh); -print "ok 17\n"; - -print "not " unless close($binfh); -print "ok 18\n"; - -print "not " unless close($utffh); -print "ok 19\n"; - -END { - 1 while unlink $txt; - 1 while unlink $bin; - 1 while unlink $utf; -} - diff --git a/t/lib/ph.t b/t/lib/ph.t deleted file mode 100755 index de27dee5e2..0000000000 --- a/t/lib/ph.t +++ /dev/null @@ -1,96 +0,0 @@ -#!./perl - -# Check for presence and correctness of .ph files; for now, -# just socket.ph and pals. -# -- Kurt Starsinic <kstar@isinet.com> - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -# All the constants which Socket.pm tries to make available: -my @possibly_defined = qw( - INADDR_ANY INADDR_LOOPBACK INADDR_NONE AF_802 AF_APPLETALK AF_CCITT - AF_CHAOS AF_DATAKIT AF_DECnet AF_DLI AF_ECMA AF_GOSIP AF_HYLINK AF_IMPLINK - AF_INET AF_LAT AF_MAX AF_NBS AF_NIT AF_NS AF_OSI AF_OSINET AF_PUP - AF_SNA AF_UNIX AF_UNSPEC AF_X25 MSG_DONTROUTE MSG_MAXIOVLEN MSG_OOB - MSG_PEEK PF_802 PF_APPLETALK PF_CCITT PF_CHAOS PF_DATAKIT PF_DECnet PF_DLI - PF_ECMA PF_GOSIP PF_HYLINK PF_IMPLINK PF_INET PF_LAT PF_MAX PF_NBS PF_NIT - PF_NS PF_OSI PF_OSINET PF_PUP PF_SNA PF_UNIX PF_UNSPEC PF_X25 SOCK_DGRAM - SOCK_RAW SOCK_RDM SOCK_SEQPACKET SOCK_STREAM SOL_SOCKET SOMAXCONN - SO_ACCEPTCONN SO_BROADCAST SO_DEBUG SO_DONTLINGER SO_DONTROUTE SO_ERROR - SO_KEEPALIVE SO_LINGER SO_OOBINLINE SO_RCVBUF SO_RCVLOWAT SO_RCVTIMEO - SO_REUSEADDR SO_SNDBUF SO_SNDLOWAT SO_SNDTIMEO SO_TYPE SO_USELOOPBACK -); - - -# The libraries which I'm going to require: -my @libs = qw(Socket "sys/types.ph" "sys/socket.ph" "netinet/in.ph"); - - -# These are defined by Socket.pm even if the C header files don't define them: -my %ok_to_miss = ( - INADDR_NONE => 1, - INADDR_LOOPBACK => 1, -); - - -my $total_tests = scalar @libs + scalar @possibly_defined; -my $i = 0; - -print "1..$total_tests\n"; - - -foreach (@libs) { - $i++; - - if (eval "require $_" ) { - print "ok $i\n"; - } else { - print "# Skipping tests; $_ may be missing\n"; - foreach ($i .. $total_tests) { print "ok $_\n" } - exit; - } -} - - -foreach (@possibly_defined) { - $i++; - - $pm_val = eval "Socket::$_()"; - $ph_val = eval "main::$_()"; - - if (defined $pm_val and !defined $ph_val) { - if ($ok_to_miss{$_}) { print "ok $i\n" } - else { print "not ok $i\n" } - next; - } elsif (defined $ph_val and !defined $pm_val) { - print "not ok $i\n"; - next; - } - - # Socket.pm converts these to network byte order, so we convert the - # socket.ph version to match; note that these cases skip the following - # `elsif', which is only applied to _numeric_ values, not literal - # bitmasks. - if ($_ eq 'INADDR_ANY' - or $_ eq 'INADDR_LOOPBACK' - or $_ eq 'INADDR_NONE') { - $ph_val = pack("N*", $ph_val); # htonl(3) equivalent - } - - # Since Socket.pm and socket.ph wave their hands over macros differently, - # they could return functionally equivalent bitmaps with different numeric - # interpretations (due to sign extension). The only apparent case of this - # is SO_DONTLINGER (only on Solaris, and deprecated, at that): - elsif ($pm_val != $ph_val) { - $pm_val = oct(sprintf "0x%lx", $pm_val); - $ph_val = oct(sprintf "0x%lx", $ph_val); - } - - if ($pm_val == $ph_val) { print "ok $i\n" } - else { print "not ok $i\n" } -} - - diff --git a/t/lib/posix.t b/t/lib/posix.t deleted file mode 100755 index 09bd88c2a9..0000000000 --- a/t/lib/posix.t +++ /dev/null @@ -1,139 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($^O ne 'VMS' and $Config{'extensions'} !~ /\bPOSIX\b/) { - print "1..0\n"; - exit 0; - } -} - -use POSIX qw(fcntl_h signal_h limits_h _exit getcwd open read strftime write); -use strict subs; - -$| = 1; -print "1..27\n"; - -$Is_W32 = $^O eq 'MSWin32'; -$Is_NetWare = $^O eq 'NetWare'; -$Is_Dos = $^O eq 'dos'; - -$testfd = open("TEST", O_RDONLY, 0) and print "ok 1\n"; -read($testfd, $buffer, 9) if $testfd > 2; -print $buffer eq "#!./perl\n" ? "ok 2\n" : "not ok 2\n"; - -write(1,"ok 3\nnot ok 3\n", 5); - -if ($Is_Dos) { - for (4..5) { - print "ok $_ # skipped, no pipe() support on dos\n"; - } -} else { -@fds = POSIX::pipe(); -print $fds[0] > $testfd ? "ok 4\n" : "not ok 4\n"; -CORE::open($reader = \*READER, "<&=".$fds[0]); -CORE::open($writer = \*WRITER, ">&=".$fds[1]); -print $writer "ok 5\n"; -close $writer; -print <$reader>; -close $reader; -} - -if ($Is_W32 || $Is_Dos) { - for (6..11) { - print "ok $_ # skipped, no sigaction support on win32/dos\n"; - } -} -else { -$sigset = new POSIX::SigSet 1,3; -delset $sigset 1; -if (!ismember $sigset 1) { print "ok 6\n" } -if (ismember $sigset 3) { print "ok 7\n" } -$mask = new POSIX::SigSet &SIGINT; -$action = new POSIX::SigAction 'main::SigHUP', $mask, 0; -sigaction(&SIGHUP, $action); -$SIG{'INT'} = 'SigINT'; -kill 'HUP', $$; -sleep 1; -print "ok 11\n"; - -sub SigHUP { - print "ok 8\n"; - kill 'INT', $$; - sleep 2; - print "ok 9\n"; -} - -sub SigINT { - print "ok 10\n"; -} -} - -print &_POSIX_OPEN_MAX > $fds[1] ? "ok 12\n" : "not ok 12\n"; - -print getcwd() =~ m#/t$# ? "ok 13\n" : "not ok 13\n"; - -# Check string conversion functions. - -if ($Config{d_strtod}) { - $lc = &POSIX::setlocale(&POSIX::LC_NUMERIC, 'C') if $Config{d_setlocale}; - ($n, $x) = &POSIX::strtod('3.14159_OR_SO'); -# Using long double NVs may introduce greater accuracy than wanted. - $n =~ s/^3.1415(8999|9000)\d*$/3.14159/ - if $Config{uselongdouble} eq 'define'; - print (($n == 3.14159) && ($x == 6) ? - "ok 14\n" : "not ok 14\n"); - &POSIX::setlocale(&POSIX::LC_NUMERIC, $lc) if $Config{d_setlocale}; -} else { print "# strtod not present\n", "ok 14\n"; } - -if ($Config{d_strtol}) { - ($n, $x) = &POSIX::strtol('21_PENGUINS'); - print (($n == 21) && ($x == 9) ? "ok 15\n" : "not ok 15\n"); -} else { print "# strtol not present\n", "ok 15\n"; } - -if ($Config{d_strtoul}) { - ($n, $x) = &POSIX::strtoul('88_TEARS'); - print (($n == 88) && ($x == 6) ? "ok 16\n" : "not ok 16\n"); -} else { print "# strtoul not present\n", "ok 16\n"; } - -# Pick up whether we're really able to dynamically load everything. -print &POSIX::acos(1.0) == 0.0 ? "ok 17\n" : "not ok 17\n"; - -# This can coredump if struct tm has a timezone field and we -# didn't detect it. If this fails, try adding -# -DSTRUCT_TM_HASZONE to your cflags when compiling ext/POSIX/POSIX.c. -# See ext/POSIX/hints/sunos_4.pl and ext/POSIX/hints/linux.pl -print POSIX::strftime("ok 18 # %H:%M, on %D\n", localtime()); - -# If that worked, validate the mini_mktime() routine's normalisation of -# input fields to strftime(). -sub try_strftime { - my $num = shift; - my $expect = shift; - my $got = POSIX::strftime("%a %b %d %H:%M:%S %Y %j", @_); - if ($got eq $expect) { - print "ok $num\n"; - } - else { - print "# expected: $expect\n# got: $got\nnot ok $num\n"; - } -} - -$lc = &POSIX::setlocale(&POSIX::LC_TIME, 'C') if $Config{d_setlocale}; -try_strftime(19, "Wed Feb 28 00:00:00 1996 059", 0,0,0, 28,1,96); -try_strftime(20, "Thu Feb 29 00:00:60 1996 060", 60,0,-24, 30,1,96); -try_strftime(21, "Fri Mar 01 00:00:00 1996 061", 0,0,-24, 31,1,96); -try_strftime(22, "Sun Feb 28 00:00:00 1999 059", 0,0,0, 28,1,99); -try_strftime(23, "Mon Mar 01 00:00:00 1999 060", 0,0,24, 28,1,99); -try_strftime(24, "Mon Feb 28 00:00:00 2000 059", 0,0,0, 28,1,100); -try_strftime(25, "Tue Feb 29 00:00:00 2000 060", 0,0,0, 0,2,100); -try_strftime(26, "Wed Mar 01 00:00:00 2000 061", 0,0,0, 1,2,100); -try_strftime(27, "Fri Mar 31 00:00:00 2000 091", 0,0,0, 31,2,100); -&POSIX::setlocale(&POSIX::LC_TIME, $lc) if $Config{d_setlocale}; - -$| = 0; -# The following line assumes buffered output, which may be not true with EMX: -print '@#!*$@(!@#$' unless ($^O eq 'os2' || $^O eq 'uwin' || $^O eq 'os390'); -_exit(0); diff --git a/t/lib/safe1.t b/t/lib/safe1.t deleted file mode 100755 index 27993d95c9..0000000000 --- a/t/lib/safe1.t +++ /dev/null @@ -1,68 +0,0 @@ -#!./perl -w -$|=1; -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { - print "1..0\n"; - exit 0; - } -} - -# Tests Todo: -# 'main' as root - -package test; # test from somewhere other than main - -use vars qw($bar); - -use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex - opmask_add full_opset empty_opset opcodes opmask define_optag); - -use Safe 1.00; - -my $last_test; # initalised at end -print "1..$last_test\n"; - -my $t = 1; -my $cpt; -# create and destroy some automatic Safe compartments first -$cpt = new Safe or die; -$cpt = new Safe or die; -$cpt = new Safe or die; - -$cpt = new Safe "Root" or die; - -foreach(1..3) { - $foo = 42; - - $cpt->share(qw($foo)); - - print ${$cpt->varglob('foo')} == 42 ? "ok $t\n" : "not ok $t\n"; $t++; - - ${$cpt->varglob('foo')} = 9; - - print $foo == 9 ? "ok $t\n" : "not ok $t\n"; $t++; - - print $cpt->reval('$foo') == 9 ? "ok $t\n" : "not ok $t\n"; $t++; - # check 'main' has been changed: - print $cpt->reval('$::foo') == 9 ? "ok $t\n" : "not ok $t\n"; $t++; - print $cpt->reval('$main::foo') == 9 ? "ok $t\n" : "not ok $t\n"; $t++; - # check we can't see our test package: - print $cpt->reval('$test::foo') ? "not ok $t\n" : "ok $t\n"; $t++; - print $cpt->reval('${"test::foo"}') ? "not ok $t\n" : "ok $t\n"; $t++; - - $cpt->erase; # erase the compartment, e.g., delete all variables - - print $cpt->reval('$foo') ? "not ok $t\n" : "ok $t\n"; $t++; - - # Note that we *must* use $cpt->varglob here because if we used - # $Root::foo etc we would still see the original values! - # This seems to be because the compiler has created an extra ref. - - print ${$cpt->varglob('foo')} ? "not ok $t\n" : "ok $t\n"; $t++; -} - -print "ok $last_test\n"; -BEGIN { $last_test = 28 } diff --git a/t/lib/safe2.t b/t/lib/safe2.t deleted file mode 100755 index 4d6c84a692..0000000000 --- a/t/lib/safe2.t +++ /dev/null @@ -1,145 +0,0 @@ -#!./perl -w -$|=1; -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { - print "1..0\n"; - exit 0; - } - # test 30 rather naughtily expects English error messages - $ENV{'LC_ALL'} = 'C'; - $ENV{LANGUAGE} = 'C'; # GNU locale extension -} - -# Tests Todo: -# 'main' as root - -use vars qw($bar); - -use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex - opmask_add full_opset empty_opset opcodes opmask define_optag); - -use Safe 1.00; - -my $last_test; # initalised at end -print "1..$last_test\n"; - -# Set up a package namespace of things to be visible to the unsafe code -$Root::foo = "visible"; -$bar = "invisible"; - -# Stop perl from moaning about identifies which are apparently only used once -$Root::foo .= ""; - -my $cpt; -# create and destroy a couple of automatic Safe compartments first -$cpt = new Safe or die; -$cpt = new Safe or die; - -$cpt = new Safe "Root"; - -$cpt->reval(q{ system("echo not ok 1"); }); -if ($@ =~ /^system trapped by operation mask/) { - print "ok 1\n"; -} else { - print "#$@" if $@; - print "not ok 1\n"; -} - -$cpt->reval(q{ - print $foo eq 'visible' ? "ok 2\n" : "not ok 2\n"; - print $main::foo eq 'visible' ? "ok 3\n" : "not ok 3\n"; - print defined($bar) ? "not ok 4\n" : "ok 4\n"; - print defined($::bar) ? "not ok 5\n" : "ok 5\n"; - print defined($main::bar) ? "not ok 6\n" : "ok 6\n"; -}); -print $@ ? "not ok 7\n#$@" : "ok 7\n"; - -$foo = "ok 8\n"; -%bar = (key => "ok 9\n"); -@baz = (); push(@baz, "o", "10"); $" = 'k '; -$glob = "ok 11\n"; -@glob = qw(not ok 16); - -sub sayok { print "ok @_\n" } - -$cpt->share(qw($foo %bar @baz *glob sayok)); -$cpt->share('$"') unless $Config{use5005threads}; - -$cpt->reval(q{ - package other; - sub other_sayok { print "ok @_\n" } - package main; - print $foo ? $foo : "not ok 8\n"; - print $bar{key} ? $bar{key} : "not ok 9\n"; - (@baz) ? print "@baz\n" : print "not ok 10\n"; - print $glob; - other::other_sayok(12); - $foo =~ s/8/14/; - $bar{new} = "ok 15\n"; - @glob = qw(ok 16); -}); -print $@ ? "not ok 13\n#$@" : "ok 13\n"; -$" = ' '; -print $foo, $bar{new}, "@glob\n"; - -$Root::foo = "not ok 17"; -@{$cpt->varglob('bar')} = qw(not ok 18); -${$cpt->varglob('foo')} = "ok 17"; -@Root::bar = "ok"; -push(@Root::bar, "18"); # Two steps to prevent "Identifier used only once..." - -print "$Root::foo\n"; -print "@{$cpt->varglob('bar')}\n"; - -use strict; - -print 1 ? "ok 19\n" : "not ok 19\n"; -print 1 ? "ok 20\n" : "not ok 20\n"; - -my $m1 = $cpt->mask; -$cpt->trap("negate"); -my $m2 = $cpt->mask; -my @masked = opset_to_ops($m1); -print $m2 eq opset("negate", @masked) ? "ok 21\n" : "not ok 21\n"; - -print eval { $cpt->mask("a bad mask") } ? "not ok 22\n" : "ok 22\n"; - -print $cpt->reval("2 + 2") == 4 ? "ok 23\n" : "not ok 23\n"; - -$cpt->mask(empty_opset); -my $t_scalar = $cpt->reval('print wantarray ? "not ok 24\n" : "ok 24\n"'); -print $cpt->reval('@ary=(6,7,8);@ary') == 3 ? "ok 25\n" : "not ok 25\n"; -my @t_array = $cpt->reval('print wantarray ? "ok 26\n" : "not ok 26\n"; (2,3,4)'); -print $t_array[2] == 4 ? "ok 27\n" : "not ok 27\n"; - -my $t_scalar2 = $cpt->reval('die "foo bar"; 1'); -print defined $t_scalar2 ? "not ok 28\n" : "ok 28\n"; -print $@ =~ /foo bar/ ? "ok 29\n" : "not ok 29\n"; - -# --- rdo - -my $t = 30; -$cpt->rdo('/non/existant/file.name'); -# The regexp is getting rather baroque. -print $! =~ /cannot find|No such file|file specification syntax error|A file or directory in the path name does not exist|Invalid argument|Device not configured|file not found|File or directory doesn't exist/i ? "ok $t\n" : "not ok $t # $!\n"; $t++; -# test #31 is gone. -print 1 ? "ok $t\n" : "not ok $t\n#$@/$!\n"; $t++; - -#my $rdo_file = "tmp_rdo.tpl"; -#if (open X,">$rdo_file") { -# print X "999\n"; -# close X; -# $cpt->permit_only('const', 'leaveeval'); -# print $cpt->rdo($rdo_file) == 999 ? "ok $t\n" : "not ok $t\n"; $t++; -# unlink $rdo_file; -#} -#else { -# print "# test $t skipped, can't open file: $!\nok $t\n"; $t++; -#} - - -print "ok $last_test\n"; -BEGIN { $last_test = 32 } diff --git a/t/lib/sdbm.t b/t/lib/sdbm.t deleted file mode 100755 index 57928e0e51..0000000000 --- a/t/lib/sdbm.t +++ /dev/null @@ -1,429 +0,0 @@ -#!./perl - -# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if (($Config{'extensions'} !~ /\bSDBM_File\b/) && ($^O ne 'VMS')){ - print "1..0\n"; - exit 0; - } -} - -use strict; -use warnings; - -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - -require SDBM_File; -#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT -use Fcntl; - -print "1..68\n"; - -unlink <Op_dbmx.*>; - -umask(0); -my %h ; -ok(1, tie %h,'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640); - -my $Dfile = "Op_dbmx.pag"; -if (! -e $Dfile) { - ($Dfile) = <Op_dbmx.*>; -} -if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'dos') { - print "ok 2 # Skipped: different file permission semantics\n"; -} -else { - my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); - print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); -} -my $i = 0; -while (my ($key,$value) = each(%h)) { - $i++; -} -print (!$i ? "ok 3\n" : "not ok 3\n"); - -$h{'goner1'} = 'snork'; - -$h{'abc'} = 'ABC'; -$h{'def'} = 'DEF'; -$h{'jkl','mno'} = "JKL\034MNO"; -$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); -$h{'a'} = 'A'; -$h{'b'} = 'B'; -$h{'c'} = 'C'; -$h{'d'} = 'D'; -$h{'e'} = 'E'; -$h{'f'} = 'F'; -$h{'g'} = 'G'; -$h{'h'} = 'H'; -$h{'i'} = 'I'; - -$h{'goner2'} = 'snork'; -delete $h{'goner2'}; - -untie(%h); -print (tie(%h,'SDBM_File','Op_dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); - -$h{'j'} = 'J'; -$h{'k'} = 'K'; -$h{'l'} = 'L'; -$h{'m'} = 'M'; -$h{'n'} = 'N'; -$h{'o'} = 'O'; -$h{'p'} = 'P'; -$h{'q'} = 'Q'; -$h{'r'} = 'R'; -$h{'s'} = 'S'; -$h{'t'} = 'T'; -$h{'u'} = 'U'; -$h{'v'} = 'V'; -$h{'w'} = 'W'; -$h{'x'} = 'X'; -$h{'y'} = 'Y'; -$h{'z'} = 'Z'; - -$h{'goner3'} = 'snork'; - -delete $h{'goner1'}; -delete $h{'goner3'}; - -my @keys = keys(%h); -my @values = values(%h); - -if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} - -while (my ($key,$value) = each(%h)) { - if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { - $key =~ y/a-z/A-Z/; - $i++ if $key eq $value; - } -} - -if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";} - -@keys = ('blurfl', keys(%h), 'dyick'); -if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";} - -$h{'foo'} = ''; -$h{''} = 'bar'; - -# check cache overflow and numeric keys and contents -my $ok = 1; -for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } -for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } -print ($ok ? "ok 8\n" : "not ok 8\n"); - -my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); -print ($size > 0 ? "ok 9\n" : "not ok 9\n"); - -@h{0..200} = 200..400; -my @foo = @h{0..200}; -print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; - -print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); -print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); - - -{ - # sub-class test - - package Another ; - - use strict ; - use warnings ; - - open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; - print FILE <<'EOM' ; - - package SubDB ; - - use strict ; - use warnings ; - use vars qw( @ISA @EXPORT) ; - - require Exporter ; - use SDBM_File; - @ISA=qw(SDBM_File); - @EXPORT = @SDBM_File::EXPORT if defined @SDBM_File::EXPORT ; - - sub STORE { - my $self = shift ; - my $key = shift ; - my $value = shift ; - $self->SUPER::STORE($key, $value * 2) ; - } - - sub FETCH { - my $self = shift ; - my $key = shift ; - $self->SUPER::FETCH($key) - 1 ; - } - - sub A_new_method - { - my $self = shift ; - my $key = shift ; - my $value = $self->FETCH($key) ; - return "[[$value]]" ; - } - - 1 ; -EOM - - close FILE ; - - BEGIN { push @INC, '.'; } - - eval 'use SubDB ; use Fcntl ;'; - main::ok(13, $@ eq "") ; - my %h ; - my $X ; - eval ' - $X = tie(%h, "SubDB","dbhash_tmp", O_RDWR|O_CREAT, 0640 ); - ' ; - - main::ok(14, $@ eq "") ; - - my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; - main::ok(15, $@ eq "") ; - main::ok(16, $ret == 5) ; - - $ret = eval '$X->A_new_method("fred") ' ; - main::ok(17, $@ eq "") ; - main::ok(18, $ret eq "[[5]]") ; - - undef $X; - untie(%h); - unlink "SubDB.pm", <dbhash_tmp.*> ; - -} - -ok(19, !exists $h{'goner1'}); -ok(20, exists $h{'foo'}); - -untie %h; -unlink <Op_dbmx*>, $Dfile; - -{ - # DBM Filter tests - use strict ; - use warnings ; - my (%h, $db) ; - my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - - sub checkOutput - { - my($fk, $sk, $fv, $sv) = @_ ; - return - $fetch_key eq $fk && $store_key eq $sk && - $fetch_value eq $fv && $store_value eq $sv && - $_ eq 'original' ; - } - - unlink <Op_dbmx*>; - ok(21, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ; - - $db->filter_fetch_key (sub { $fetch_key = $_ }) ; - $db->filter_store_key (sub { $store_key = $_ }) ; - $db->filter_fetch_value (sub { $fetch_value = $_}) ; - $db->filter_store_value (sub { $store_value = $_ }) ; - - $_ = "original" ; - - $h{"fred"} = "joe" ; - # fk sk fv sv - ok(22, checkOutput( "", "fred", "", "joe")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(23, $h{"fred"} eq "joe"); - # fk sk fv sv - ok(24, checkOutput( "", "fred", "joe", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(25, $db->FIRSTKEY() eq "fred") ; - # fk sk fv sv - ok(26, checkOutput( "fred", "", "", "")) ; - - # replace the filters, but remember the previous set - my ($old_fk) = $db->filter_fetch_key - (sub { $_ = uc $_ ; $fetch_key = $_ }) ; - my ($old_sk) = $db->filter_store_key - (sub { $_ = lc $_ ; $store_key = $_ }) ; - my ($old_fv) = $db->filter_fetch_value - (sub { $_ = "[$_]"; $fetch_value = $_ }) ; - my ($old_sv) = $db->filter_store_value - (sub { s/o/x/g; $store_value = $_ }) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - $h{"Fred"} = "Joe" ; - # fk sk fv sv - ok(27, checkOutput( "", "fred", "", "Jxe")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(28, $h{"Fred"} eq "[Jxe]"); - # fk sk fv sv - ok(29, checkOutput( "", "fred", "[Jxe]", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(30, $db->FIRSTKEY() eq "FRED") ; - # fk sk fv sv - ok(31, checkOutput( "FRED", "", "", "")) ; - - # put the original filters back - $db->filter_fetch_key ($old_fk); - $db->filter_store_key ($old_sk); - $db->filter_fetch_value ($old_fv); - $db->filter_store_value ($old_sv); - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - $h{"fred"} = "joe" ; - ok(32, checkOutput( "", "fred", "", "joe")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(33, $h{"fred"} eq "joe"); - ok(34, checkOutput( "", "fred", "joe", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(35, $db->FIRSTKEY() eq "fred") ; - ok(36, checkOutput( "fred", "", "", "")) ; - - # delete the filters - $db->filter_fetch_key (undef); - $db->filter_store_key (undef); - $db->filter_fetch_value (undef); - $db->filter_store_value (undef); - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - $h{"fred"} = "joe" ; - ok(37, checkOutput( "", "", "", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(38, $h{"fred"} eq "joe"); - ok(39, checkOutput( "", "", "", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(40, $db->FIRSTKEY() eq "fred") ; - ok(41, checkOutput( "", "", "", "")) ; - - undef $db ; - untie %h; - unlink <Op_dbmx*>; -} - -{ - # DBM Filter with a closure - - use strict ; - use warnings ; - my (%h, $db) ; - - unlink <Op_dbmx*>; - ok(42, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ; - - my %result = () ; - - sub Closure - { - my ($name) = @_ ; - my $count = 0 ; - my @kept = () ; - - return sub { ++$count ; - push @kept, $_ ; - $result{$name} = "$name - $count: [@kept]" ; - } - } - - $db->filter_store_key(Closure("store key")) ; - $db->filter_store_value(Closure("store value")) ; - $db->filter_fetch_key(Closure("fetch key")) ; - $db->filter_fetch_value(Closure("fetch value")) ; - - $_ = "original" ; - - $h{"fred"} = "joe" ; - ok(43, $result{"store key"} eq "store key - 1: [fred]"); - ok(44, $result{"store value"} eq "store value - 1: [joe]"); - ok(45, !defined $result{"fetch key"} ); - ok(46, !defined $result{"fetch value"} ); - ok(47, $_ eq "original") ; - - ok(48, $db->FIRSTKEY() eq "fred") ; - ok(49, $result{"store key"} eq "store key - 1: [fred]"); - ok(50, $result{"store value"} eq "store value - 1: [joe]"); - ok(51, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(52, ! defined $result{"fetch value"} ); - ok(53, $_ eq "original") ; - - $h{"jim"} = "john" ; - ok(54, $result{"store key"} eq "store key - 2: [fred jim]"); - ok(55, $result{"store value"} eq "store value - 2: [joe john]"); - ok(56, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(57, ! defined $result{"fetch value"} ); - ok(58, $_ eq "original") ; - - ok(59, $h{"fred"} eq "joe"); - ok(60, $result{"store key"} eq "store key - 3: [fred jim fred]"); - ok(61, $result{"store value"} eq "store value - 2: [joe john]"); - ok(62, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(63, $result{"fetch value"} eq "fetch value - 1: [joe]"); - ok(64, $_ eq "original") ; - - undef $db ; - untie %h; - unlink <Op_dbmx*>; -} - -{ - # DBM Filter recursion detection - use strict ; - use warnings ; - my (%h, $db) ; - unlink <Op_dbmx*>; - - ok(65, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ; - - $db->filter_store_key (sub { $_ = $h{$_} }) ; - - eval '$h{1} = 1234' ; - ok(66, $@ =~ /^recursion detected in filter_store_key at/ ); - - undef $db ; - untie %h; - unlink <Op_dbmx*>; -} - -{ - # Bug ID 20001013.009 - # - # test that $hash{KEY} = undef doesn't produce the warning - # Use of uninitialized value in null operation - use warnings ; - use strict ; - use SDBM_File ; - - unlink <Op_dbmx*>; - my %h ; - my $a = ""; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - - ok(67, tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ; - $h{ABC} = undef; - ok(68, $a eq "") ; - - untie %h; - unlink <Op_dbmx*>; -} diff --git a/t/lib/searchdict.t b/t/lib/searchdict.t deleted file mode 100755 index c36fdb8c34..0000000000 --- a/t/lib/searchdict.t +++ /dev/null @@ -1,87 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..4\n"; - -$DICT = <<EOT; -Aarhus -Aaron -Ababa -aback -abaft -abandon -abandoned -abandoning -abandonment -abandons -abase -abased -abasement -abasements -abases -abash -abashed -abashes -abashing -abasing -abate -abated -abatement -abatements -abater -abates -abating -Abba -EOT - -use Search::Dict; - -open(DICT, "+>dict-$$") or die "Can't create dict-$$: $!"; -binmode DICT; # To make length expected one. -print DICT $DICT; - -my $pos = look *DICT, "Ababa"; -chomp($word = <DICT>); -print "not " if $pos < 0 || $word ne "Ababa"; -print "ok 1\n"; - -if (ord('a') > ord('A') ) { # ASCII - - $pos = look *DICT, "foo"; - chomp($word = <DICT>); - - print "not " if $pos != length($DICT); # will search to end of file - print "ok 2\n"; - - my $pos = look *DICT, "abash"; - chomp($word = <DICT>); - print "not " if $pos < 0 || $word ne "abash"; - print "ok 3\n"; - -} -else { # EBCDIC systems e.g. os390 - - $pos = look *DICT, "FOO"; - chomp($word = <DICT>); - - print "not " if $pos != length($DICT); # will search to end of file - print "ok 2\n"; - - my $pos = look *DICT, "Abba"; - chomp($word = <DICT>); - print "not " if $pos < 0 || $word ne "Abba"; - print "ok 3\n"; -} - -$pos = look *DICT, "aarhus", 1, 1; -chomp($word = <DICT>); - -print "not " if $pos < 0 || $word ne "Aarhus"; -print "ok 4\n"; - -close DICT or die "cannot close"; -unlink "dict-$$"; diff --git a/t/lib/selectsaver.t b/t/lib/selectsaver.t deleted file mode 100755 index 3b58d709ab..0000000000 --- a/t/lib/selectsaver.t +++ /dev/null @@ -1,28 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..3\n"; - -use SelectSaver; - -open(FOO, ">foo-$$") || die; - -print "ok 1\n"; -{ - my $saver = new SelectSaver(FOO); - print "foo\n"; -} - -# Get data written to file -open(FOO, "foo-$$") || die; -chomp($foo = <FOO>); -close FOO; -unlink "foo-$$"; - -print "ok 2\n" if $foo eq "foo"; - -print "ok 3\n"; diff --git a/t/lib/selfloader.t b/t/lib/selfloader.t deleted file mode 100755 index 6987f6592b..0000000000 --- a/t/lib/selfloader.t +++ /dev/null @@ -1,208 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - $dir = "self-$$"; - $sep = "/"; - - if ($^O eq 'MacOS') { - $dir = ":" . $dir; - $sep = ":"; - } - - @INC = $dir; - push @INC, '../lib'; - - print "1..19\n"; - - # First we must set up some selfloader files - mkdir $dir, 0755 or die "Can't mkdir $dir: $!"; - - open(FOO, ">$dir${sep}Foo.pm") or die; - print FOO <<'EOT'; -package Foo; -use SelfLoader; - -sub new { bless {}, shift } -sub foo; -sub bar; -sub bazmarkhianish; -sub a; -sub never; # declared but definition should never be read -1; -__DATA__ - -sub foo { shift; shift || "foo" }; - -sub bar { shift; shift || "bar" } - -sub bazmarkhianish { shift; shift || "baz" } - -package sheep; -sub bleat { shift; shift || "baa" } - -__END__ -sub never { die "D'oh" } -EOT - - close(FOO); - - open(BAR, ">$dir${sep}Bar.pm") or die; - print BAR <<'EOT'; -package Bar; -use SelfLoader; - -@ISA = 'Baz'; - -sub new { bless {}, shift } -sub a; - -1; -__DATA__ - -sub a { 'a Bar'; } -sub b { 'b Bar' } - -__END__ DATA -sub never { die "D'oh" } -EOT - - close(BAR); -}; - - -package Baz; - -sub a { 'a Baz' } -sub b { 'b Baz' } -sub c { 'c Baz' } - - -package main; -use Foo; -use Bar; - -$foo = new Foo; - -print "not " unless $foo->foo eq 'foo'; # selfloaded first time -print "ok 1\n"; - -print "not " unless $foo->foo eq 'foo'; # regular call -print "ok 2\n"; - -# Try an undefined method -eval { - $foo->will_fail; -}; -if ($@ =~ /^Undefined subroutine/) { - print "ok 3\n"; -} else { - print "not ok 3 $@\n"; -} - -# Used to be trouble with this -eval { - my $foo = new Foo; - die "oops"; -}; -if ($@ =~ /oops/) { - print "ok 4\n"; -} else { - print "not ok 4 $@\n"; -} - -# Pass regular expression variable to autoloaded function. This used -# to go wrong in AutoLoader because it used regular expressions to generate -# autoloaded filename. -"foo" =~ /(\w+)/; -print "not " unless $1 eq 'foo'; -print "ok 5\n"; - -print "not " unless $foo->bar($1) eq 'foo'; -print "ok 6\n"; - -print "not " unless $foo->bar($1) eq 'foo'; -print "ok 7\n"; - -print "not " unless $foo->bazmarkhianish($1) eq 'foo'; -print "ok 8\n"; - -print "not " unless $foo->bazmarkhianish($1) eq 'foo'; -print "ok 9\n"; - -# Check nested packages inside __DATA__ -print "not " unless sheep::bleat() eq 'baa'; -print "ok 10\n"; - -# Now check inheritance: - -$bar = new Bar; - -# Before anything is SelfLoaded there is no declaration of Foo::b so we should -# get Baz::b -print "not " unless $bar->b() eq 'b Baz'; -print "ok 11\n"; - -# There is no Bar::c so we should get Baz::c -print "not " unless $bar->c() eq 'c Baz'; -print "ok 12\n"; - -# This selfloads Bar::a because it is stubbed. It also stubs Bar::b as a side -# effect -print "not " unless $bar->a() eq 'a Bar'; -print "ok 13\n"; - -print "not " unless $bar->b() eq 'b Bar'; -print "ok 14\n"; - -print "not " unless $bar->c() eq 'c Baz'; -print "ok 15\n"; - - - -# Check that __END__ is honoured -# Try an subroutine that should never be noticed by selfloader -eval { - $foo->never; -}; -if ($@ =~ /^Undefined subroutine/) { - print "ok 16\n"; -} else { - print "not ok 16 $@\n"; -} - -# Try to read from the data file handle -my $foodata = <Foo::DATA>; -close Foo::DATA; -if (defined $foodata) { - print "not ok 17 # $foodata\n"; -} else { - print "ok 17\n"; -} - -# Check that __END__ DATA is honoured -# Try an subroutine that should never be noticed by selfloader -eval { - $bar->never; -}; -if ($@ =~ /^Undefined subroutine/) { - print "ok 18\n"; -} else { - print "not ok 18 $@\n"; -} - -# Try to read from the data file handle -my $bardata = <Bar::DATA>; -close Bar::DATA; -if ($bardata ne "sub never { die \"D'oh\" }\n") { - print "not ok 19 # $bardata\n"; -} else { - print "ok 19\n"; -} - -# cleanup -END { -return unless $dir && -d $dir; -unlink "$dir${sep}Foo.pm", "$dir${sep}Bar.pm"; -rmdir "$dir"; -} diff --git a/t/lib/selfstubber.t b/t/lib/selfstubber.t deleted file mode 100644 index 2e74a022d6..0000000000 --- a/t/lib/selfstubber.t +++ /dev/null @@ -1,285 +0,0 @@ -#!./perl -w - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use strict; -use Devel::SelfStubber; - -my $runperl = "$^X \"-I../lib\""; - -# ensure correct output ordering for system() calls - -select STDERR; $| = 1; select STDOUT; $| = 1; - -print "1..12\n"; - -my @cleanup; - -END { - foreach my $file (reverse @cleanup) { - unlink $file or warn "unlink $file failed: $!" while -f $file; - rmdir $file or warn "rmdir $file failed: $!" if -d $file; - } -} - -my $inlib = "SSI-$$"; -mkdir $inlib, 0777 or die $!; -push @cleanup, $inlib; - -while (<DATA>) { - if (/^\#{16,}\s+(.*)/) { - my $file = "$inlib/$1"; - push @cleanup, $file; - open FH, ">$file" or die $!; - } else { - print FH; - } -} -close FH; - -{ - my $file = "A-$$"; - push @cleanup, $file; - open FH, ">$file" or die $!; - select FH; - Devel::SelfStubber->stub('Child', $inlib); - select STDOUT; - print "ok 1\n"; - close FH or die $!; - - open FH, $file or die $!; - my @A = <FH>; - - if (@A == 1 && $A[0] =~ /^\s*sub\s+Child::foo\s*;\s*$/) { - print "ok 2\n"; - } else { - print "not ok 2\n"; - print "# $_" foreach (@A); - } -} - -{ - my $file = "B-$$"; - push @cleanup, $file; - open FH, ">$file" or die $!; - select FH; - Devel::SelfStubber->stub('Proto', $inlib); - select STDOUT; - print "ok 3\n"; # Checking that we did not die horribly. - close FH or die $!; - - open FH, $file or die $!; - my @B = <FH>; - - if (@B == 1 && $B[0] =~ /^\s*sub\s+Proto::bar\s*\(\$\$\);\s*$/) { - print "ok 4\n"; - } else { - print "not ok 4\n"; - print "# $_" foreach (@B); - } - - close FH or die $!; -} - -{ - my $file = "C-$$"; - push @cleanup, $file; - open FH, ">$file" or die $!; - select FH; - Devel::SelfStubber->stub('Attribs', $inlib); - select STDOUT; - print "ok 5\n"; # Checking that we did not die horribly. - close FH or die $!; - - open FH, $file or die $!; - my @C = <FH>; - - if (@C == 2 && $C[0] =~ /^\s*sub\s+Attribs::baz\s+:\s*locked\s*;\s*$/ - && $C[1] =~ /^\s*sub\s+Attribs::lv\s+:\s*lvalue\s*:\s*method\s*;\s*$/) { - print "ok 6\n"; - } else { - print "not ok 6\n"; - print "# $_" foreach (@C); - } - - close FH or die $!; -} - -# "wrong" and "right" may change if SelfLoader is changed. -my %wrong = ( Parent => 'Parent', Child => 'Parent' ); -my %right = ( Parent => 'Parent', Child => 'Child' ); -if ($^O eq 'VMS') { - # extra line feeds for MBX IPC - %wrong = ( Parent => "Parent\n", Child => "Parent\n" ); - %right = ( Parent => "Parent\n", Child => "Child\n" ); -} -my @module = qw(Parent Child) -; -sub fail { - my ($left, $right) = @_; - while (my ($key, $val) = each %$left) { - # warn "$key $val $$right{$key}"; - return 1 - unless $val eq $$right{$key}; - } - return; -} - -sub faildump { - my ($expect, $got) = @_; - foreach (sort keys %$expect) { - print "# $_ expect '$$expect{$_}' got '$$got{$_}'\n"; - } -} - -# Now test that the module tree behaves "wrongly" as expected - -foreach my $module (@module) { - my $file = "$module--$$"; - push @cleanup, $file; - open FH, ">$file" or die $!; - print FH "use $module; -print ${module}->foo; -"; - close FH or die $!; -} - -{ - my %output; - foreach my $module (@module) { - print "# $runperl \"-I$inlib\" $module--$$\n"; - ($output{$module} = `$runperl "-I$inlib" $module--$$`) - =~ s/\'s foo//; - } - - if (&fail (\%wrong, \%output)) { - print "not ok 7\n", &faildump (\%wrong, \%output); - } else { - print "ok 7\n"; - } -} - -my $lib="SSO-$$"; -mkdir $lib, 0777 or die $!; -push @cleanup, $lib; -$Devel::SelfStubber::JUST_STUBS=0; - -undef $/; -foreach my $module (@module, 'Data', 'End') { - my $file = "$lib/$module.pm"; - open FH, "$inlib/$module.pm" or die $!; - my $contents = <FH>; - close FH or die $!; - push @cleanup, $file; - open FH, ">$file" or die $!; - select FH; - if ($contents =~ /__DATA__/) { - # This will die for any module with no __DATA__ - Devel::SelfStubber->stub($module, $inlib); - } else { - print $contents; - } - select STDOUT; - close FH or die $!; -} -print "ok 8\n"; - -{ - my %output; - foreach my $module (@module) { - print "# $runperl \"-I$lib\" $module--$$\n"; - ($output{$module} = `$runperl "-I$lib" $module--$$`) - =~ s/\'s foo//; - } - - if (&fail (\%right, \%output)) { - print "not ok 9\n", &faildump (\%right, \%output); - } else { - print "ok 9\n"; - } -} - -# Check that the DATA handle stays open -system "$runperl -w \"-I$lib\" \"-MData\" -e \"Data::ok\""; - -# Possibly a pointless test as this doesn't really verify that it's been -# stubbed. -system "$runperl -w \"-I$lib\" \"-MEnd\" -e \"End::lime\""; - -# But check that the documentation after the __END__ survived. -open FH, "$lib/End.pm" or die $!; -$_ = <FH>; -close FH or die $!; - -if (/Did the documentation here survive\?/) { - print "ok 12\n"; -} else { - print "not ok 12 # information after an __END__ token seems to be lost\n"; -} - -__DATA__ -################ Parent.pm -package Parent; - -sub foo { - return __PACKAGE__; -} -1; -__END__ -################ Child.pm -package Child; -require Parent; -@ISA = 'Parent'; -use SelfLoader; - -1; -__DATA__ -sub foo { - return __PACKAGE__; -} -__END__ -################ Proto.pm -package Proto; -use SelfLoader; - -1; -__DATA__ -sub bar ($$) { -} -################ Attribs.pm -package Attribs; -use SelfLoader; - -1; -__DATA__ -sub baz : locked { -} -sub lv : lvalue : method { - my $a; - \$a; -} -################ Data.pm -package Data; -use SelfLoader; - -1; -__DATA__ -sub ok { - print <DATA>; -} -__END__ DATA -ok 10 -################ End.pm -package End; -use SelfLoader; - -1; -__DATA__ -sub lime { - print "ok 11\n"; -} -__END__ -Did the documentation here survive? diff --git a/t/lib/sigaction.t b/t/lib/sigaction.t deleted file mode 100644 index c38b122775..0000000000 --- a/t/lib/sigaction.t +++ /dev/null @@ -1,127 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - unshift @INC, '../lib'; -} - -BEGIN{ - # Don't do anything if POSIX is missing, or sigaction missing. - eval { use POSIX; }; - if($@ || $^O eq 'MSWin32' || $^O eq 'NetWare') { - print "1..0\n"; - exit 0; - } -} - -use strict; -use vars qw/$bad7 $ok10 $bad18 $ok/; - -$^W=1; - -print "1..18\n"; - -sub IGNORE { - $bad7=1; -} - -sub DEFAULT { - $bad18=1; -} - -sub foo { - $ok=1; -} - -my $newaction=POSIX::SigAction->new('::foo', new POSIX::SigSet(SIGUSR1), 0); -my $oldaction=POSIX::SigAction->new('::bar', new POSIX::SigSet(), 0); - -{ - my $bad; - local($SIG{__WARN__})=sub { $bad=1; }; - sigaction(SIGHUP, $newaction, $oldaction); - if($bad) { print "not ok 1\n" } else { print "ok 1\n"} -} - -if($oldaction->{HANDLER} eq 'DEFAULT' || - $oldaction->{HANDLER} eq 'IGNORE') - { print "ok 2\n" } else { print "not ok 2 # ", $oldaction->{HANDLER}, "\n"} -print $SIG{HUP} eq '::foo' ? "ok 3\n" : "not ok 3\n"; - -sigaction(SIGHUP, $newaction, $oldaction); -if($oldaction->{HANDLER} eq '::foo') - { print "ok 4\n" } else { print "not ok 4\n"} -if($oldaction->{MASK}->ismember(SIGUSR1)) - { print "ok 5\n" } else { print "not ok 5\n"} -if($oldaction->{FLAGS}) { - if ($^O eq 'linux') { - print "ok 6 # Skip: sigaction() broken in $^O\n"; - } else { - print "not ok 6\n"; - } -} else { - print "ok 6\n"; -} - -$newaction=POSIX::SigAction->new('IGNORE'); -sigaction(SIGHUP, $newaction); -kill 'HUP', $$; -print $bad7 ? "not ok 7\n" : "ok 7\n"; - -print $SIG{HUP} eq 'IGNORE' ? "ok 8\n" : "not ok 8\n"; -sigaction(SIGHUP, POSIX::SigAction->new('DEFAULT')); -print $SIG{HUP} eq 'DEFAULT' ? "ok 9\n" : "not ok 9\n"; - -$newaction=POSIX::SigAction->new(sub { $ok10=1; }); -sigaction(SIGHUP, $newaction); -{ - local($^W)=0; - kill 'HUP', $$; -} -print $ok10 ? "ok 10\n" : "not ok 10\n"; - -print ref($SIG{HUP}) eq 'CODE' ? "ok 11\n" : "not ok 11\n"; - -sigaction(SIGHUP, POSIX::SigAction->new('::foo')); -# Make sure the signal mask gets restored after sigaction croak()s. -eval { - my $act=POSIX::SigAction->new('::foo'); - delete $act->{HANDLER}; - sigaction(SIGINT, $act); -}; -kill 'HUP', $$; -print $ok ? "ok 12\n" : "not ok 12\n"; - -undef $ok; -# Make sure the signal mask gets restored after sigaction returns early. -my $x=defined sigaction(SIGKILL, $newaction, $oldaction); -kill 'HUP', $$; -print !$x && $ok ? "ok 13\n" : "not ok 13\n"; - -$SIG{HUP}=sub {}; -sigaction(SIGHUP, $newaction, $oldaction); -print ref($oldaction->{HANDLER}) eq 'CODE' ? "ok 14\n" : "not ok 14\n"; - -eval { - sigaction(SIGHUP, undef, $oldaction); -}; -print $@ ? "not ok 15\n" : "ok 15\n"; - -eval { - sigaction(SIGHUP, 0, $oldaction); -}; -print $@ ? "not ok 16\n" : "ok 16\n"; - -eval { - sigaction(SIGHUP, bless({},'Class'), $oldaction); -}; -print $@ ? "ok 17\n" : "not ok 17\n"; - -$newaction=POSIX::SigAction->new(sub { $ok10=1; }); -sigaction(SIGCONT, POSIX::SigAction->new('DEFAULT')); -{ - local($^W)=0; - kill 'CONT', $$; -} -print $bad18 ? "not ok 18\n" : "ok 18\n"; - diff --git a/t/lib/socket.t b/t/lib/socket.t deleted file mode 100755 index 481fd8f3e0..0000000000 --- a/t/lib/socket.t +++ /dev/null @@ -1,87 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bSocket\b/ && - !(($^O eq 'VMS') && $Config{d_socket})) { - print "1..0\n"; - exit 0; - } -} - -use Socket; - -print "1..8\n"; - -if (socket(T,PF_INET,SOCK_STREAM,6)) { - print "ok 1\n"; - - if (connect(T,pack_sockaddr_in(7,inet_aton("localhost")))){ - print "ok 2\n"; - - print "# Connected to " . - inet_ntoa((unpack_sockaddr_in(getpeername(T)))[1])."\n"; - - syswrite(T,"hello",5); - $read = sysread(T,$buff,10); # Connection may be granted, then closed! - while ($read > 0 && length($buff) < 5) { - # adjust for fact that TCP doesn't guarantee size of reads/writes - $read = sysread(T,$buff,10,length($buff)); - } - print(($read == 0 || $buff eq "hello") ? "ok 3\n" : "not ok 3\n"); - } - else { - print "# You're allowed to fail tests 2 and 3 if.\n"; - print "# The echo service has been disabled.\n"; - print "# $!\n"; - print "ok 2\n"; - print "ok 3\n"; - } -} -else { - print "# $!\n"; - print "not ok 1\n"; -} - -if( socket(S,PF_INET,SOCK_STREAM,6) ){ - print "ok 4\n"; - - if (connect(S,pack_sockaddr_in(7,INADDR_LOOPBACK))){ - print "ok 5\n"; - - print "# Connected to " . - inet_ntoa((unpack_sockaddr_in(getpeername(S)))[1])."\n"; - - syswrite(S,"olleh",5); - $read = sysread(S,$buff,10); # Connection may be granted, then closed! - while ($read > 0 && length($buff) < 5) { - # adjust for fact that TCP doesn't guarantee size of reads/writes - $read = sysread(S,$buff,10,length($buff)); - } - print(($read == 0 || $buff eq "olleh") ? "ok 6\n" : "not ok 6\n"); - } - else { - print "# You're allowed to fail tests 5 and 6 if.\n"; - print "# The echo service has been disabled.\n"; - print "# $!\n"; - print "ok 5\n"; - print "ok 6\n"; - } -} -else { - print "# $!\n"; - print "not ok 4\n"; -} - -# warnings -$SIG{__WARN__} = sub { - ++ $w if $_[0] =~ /^6-ARG sockaddr_in call is deprecated/ ; -} ; -$w = 0 ; -sockaddr_in(1,2,3,4,5,6) ; -print ($w == 1 ? "not ok 7\n" : "ok 7\n") ; -use warnings 'Socket' ; -sockaddr_in(1,2,3,4,5,6) ; -print ($w == 1 ? "ok 8\n" : "not ok 8\n") ; diff --git a/t/lib/soundex.t b/t/lib/soundex.t deleted file mode 100755 index d35f264c7a..0000000000 --- a/t/lib/soundex.t +++ /dev/null @@ -1,143 +0,0 @@ -#!./perl -# -# $Id: soundex.t,v 1.2 1994/03/24 00:30:27 mike Exp $ -# -# test module for soundex.pl -# -# $Log: soundex.t,v $ -# Revision 1.2 1994/03/24 00:30:27 mike -# Subtle bug (any excuse :-) spotted by Rich Pinder <rpinder@hsc.usc.edu> -# in the way I handles leasing characters which were different but had -# the same soundex code. This showed up comparing it with Oracle's -# soundex output. -# -# Revision 1.1 1994/03/02 13:03:02 mike -# Initial revision -# -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Text::Soundex; - -$test = 0; -print "1..13\n"; - -while (<DATA>) -{ - chop; - next if /^\s*;?#/; - next if /^\s*$/; - - ++$test; - $bad = 0; - - if (/^eval\s+/) - { - ($try = $_) =~ s/^eval\s+//; - - eval ($try); - if ($@) - { - $bad++; - print "not ok $test\n"; - print "# eval '$try' returned $@"; - } - } - elsif (/^\(/) - { - ($in, $out) = split (':'); - - $try = "\@expect = $out; \@got = &soundex $in;"; - eval ($try); - - if (@expect != @got) - { - $bad++; - print "not ok $test\n"; - print "# expected ", scalar @expect, " results, got ", scalar @got, "\n"; - print "# expected (", join (', ', @expect), - ") got (", join (', ', @got), ")\n"; - } - else - { - while (@got) - { - $expect = shift @expect; - $got = shift @got; - - if ($expect ne $got) - { - $bad++; - print "not ok $test\n"; - print "# expected $expect, got $got\n"; - } - } - } - } - else - { - ($in, $out) = split (':'); - - $try = "\$expect = $out; \$got = &soundex ($in);"; - eval ($try); - - if ($expect ne $got) - { - $bad++; - print "not ok $test\n"; - print "# expected $expect, got $got\n"; - } - } - - print "ok $test\n" unless $bad; -} - -__END__ -# -# 1..6 -# -# Knuth's test cases, scalar in, scalar out -# -'Euler':'E460' -'Gauss':'G200' -'Hilbert':'H416' -'Knuth':'K530' -'Lloyd':'L300' -'Lukasiewicz':'L222' -# -# 7..8 -# -# check default bad code -# -'2 + 2 = 4':undef -undef:undef -# -# 9 -# -# check array in, array out -# -('Ellery', 'Ghosh', 'Heilbronn', 'Kant', 'Ladd', 'Lissajous'):('E460', 'G200', 'H416', 'K530', 'L300', 'L222') -# -# 10 -# -# check array with explicit undef -# -('Mike', undef, 'Stok'):('M200', undef, 'S320') -# -# 11..12 -# -# check setting $Text::Soundex::noCode -# -eval $soundex_nocode = 'Z000'; -('Mike', undef, 'Stok'):('M200', 'Z000', 'S320') -# -# 13 -# -# a subtle difference between me & oracle, spotted by Rich Pinder -# <rpinder@hsc.usc.edu> -# -CZARKOWSKA:C622 diff --git a/t/lib/st-06compat.t b/t/lib/st-06compat.t deleted file mode 100644 index 1586b18a81..0000000000 --- a/t/lib/st-06compat.t +++ /dev/null @@ -1,157 +0,0 @@ -#!./perl - -# $Id: compat-0.6.t,v 1.0.1.1 2001/02/17 12:26:21 ram Exp $ -# -# Copyright (c) 1995-2000, Raphael Manfredi -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# -# $Log: compat-0.6.t,v $ -# Revision 1.0.1.1 2001/02/17 12:26:21 ram -# patch8: added EBCDIC version of the test, from Peter Prymmer -# -# Revision 1.0 2000/09/01 19:40:41 ram -# Baseline for first official release. -# - -BEGIN { - chdir('t') if -d 't'; - @INC = '.'; - push @INC, '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } - require 'lib/st-dump.pl'; -} - -sub ok; - -print "1..8\n"; - -use Storable qw(freeze nfreeze thaw); - -package TIED_HASH; - -sub TIEHASH { - my $self = bless {}, shift; - return $self; -} - -sub FETCH { - my $self = shift; - my ($key) = @_; - $main::hash_fetch++; - return $self->{$key}; -} - -sub STORE { - my $self = shift; - my ($key, $val) = @_; - $self->{$key} = $val; -} - -package SIMPLE; - -sub make { - my $self = bless [], shift; - my ($x) = @_; - $self->[0] = $x; - return $self; -} - -package ROOT; - -sub make { - my $self = bless {}, shift; - my $h = tie %hash, TIED_HASH; - $self->{h} = $h; - $self->{ref} = \%hash; - my @pool; - for (my $i = 0; $i < 5; $i++) { - push(@pool, SIMPLE->make($i)); - } - $self->{obj} = \@pool; - my @a = ('string', $h, $self); - $self->{a} = \@a; - $self->{num} = [1, 0, -3, -3.14159, 456, 4.5]; - $h->{key1} = 'val1'; - $h->{key2} = 'val2'; - return $self; -}; - -sub num { $_[0]->{num} } -sub h { $_[0]->{h} } -sub ref { $_[0]->{ref} } -sub obj { $_[0]->{obj} } - -package main; - -my $is_EBCDIC = (ord('A') == 193) ? 1 : 0; - -my $r = ROOT->make; - -my $data = ''; -if (!$is_EBCDIC) { # ASCII machine - while (<DATA>) { - next if /^#/; - $data .= unpack("u", $_); - } -} else { - while (<DATA>) { - next if /^#$/; # skip comments - next if /^#\s+/; # skip comments - next if /^[^#]/; # skip uuencoding for ASCII machines - s/^#//; # prepare uuencoded data for EBCDIC machines - $data .= unpack("u", $_); - } -} - -my $expected_length = $is_EBCDIC ? 217 : 278; -ok 1, length $data == $expected_length; - -my $y = thaw($data); -ok 2, 1; -ok 3, ref $y eq 'ROOT'; - -$Storable::canonical = 1; # Prevent "used once" warning -$Storable::canonical = 1; -# Allow for long double string conversions. -$y->{num}->[3] += 0; -$r->{num}->[3] += 0; -ok 4, nfreeze($y) eq nfreeze($r); - -ok 5, $y->ref->{key1} eq 'val1'; -ok 6, $y->ref->{key2} eq 'val2'; -ok 7, $hash_fetch == 2; - -my $num = $r->num; -my $ok = 1; -for (my $i = 0; $i < @$num; $i++) { - do { $ok = 0; last } unless $num->[$i] == $y->num->[$i]; -} -ok 8, $ok; - -__END__ -# -# using Storable-0.6@11, output of: print pack("u", nfreeze(ROOT->make)); -# original size: 278 bytes -# -M`P,````%!`(````&"(%8"(!8"'U8"@@M,RXQ-#$U.5@)```!R%@*`S0N-5A8 -M6`````-N=6T$`P````(*!'9A;#%8````!&ME>3$*!'9A;#)8````!&ME>3)B -M"51)141?2$%32%A8`````6@$`@````,*!G-T<FEN9U@$``````I8!``````` -M6%A8`````6$$`@````4$`@````$(@%AB!E-)35!,15A8!`(````!"(%88@93 -M24U03$586`0"`````0B"6&(&4TE-4$Q%6%@$`@````$(@UAB!E-)35!,15A8 -M!`(````!"(188@9324U03$586%A8`````V]B:@0,!``````*6%A8`````W)E -(9F($4D]/5%@` -# -# using Storable-0.6@11, output of: print '#' . pack("u", nfreeze(ROOT->make)); -# on OS/390 (cp 1047) original size: 217 bytes -# -#M!0,1!-G6UN,#````!00,!!$)X\G%Q&W(P>+(`P````(*!*6!D_$````$DH6H -#M\0H$I8&3\@````22A:CR`````YF%A@0"````!@B!"(`(?0H(8/-+\?3Q]?D) -#M```!R`H#]$OU`````Y6DE`0"````!001!N+)U-?3Q0(````!"(`$$@("```` -#M`0B!!!("`@````$(@@02`@(````!"(,$$@("`````0B$`````Y:"D00````` -#E!`````&(!`(````#"@:BHYF)E8<$``````0$```````````!@0`` diff --git a/t/lib/st-blessed.t b/t/lib/st-blessed.t deleted file mode 100644 index b1a18e62c3..0000000000 --- a/t/lib/st-blessed.t +++ /dev/null @@ -1,104 +0,0 @@ -#!./perl - -# $Id: blessed.t,v 1.0 2000/09/01 19:40:41 ram Exp $ -# -# Copyright (c) 1995-2000, Raphael Manfredi -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# -# $Log: blessed.t,v $ -# Revision 1.0 2000/09/01 19:40:41 ram -# Baseline for first official release. -# - -sub BEGIN { - chdir('t') if -d 't'; - @INC = '.'; - push @INC, '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } - require 'lib/st-dump.pl'; -} - -sub ok; - -use Storable qw(freeze thaw); - -print "1..10\n"; - -package SHORT_NAME; - -sub make { bless [], shift } - -package SHORT_NAME_WITH_HOOK; - -sub make { bless [], shift } - -sub STORABLE_freeze { - my $self = shift; - return ("", $self); -} - -sub STORABLE_thaw { - my $self = shift; - my $cloning = shift; - my ($x, $obj) = @_; - die "STORABLE_thaw" unless $obj eq $self; -} - -package main; - -# Still less than 256 bytes, so long classname logic not fully exercised -# Wait until Perl removes the restriction on identifier lengths. -my $name = "LONG_NAME_" . 'xxxxxxxxxxxxx::' x 14 . "final"; - -eval <<EOC; -package $name; - -\@ISA = ("SHORT_NAME"); -EOC -die $@ if $@; -ok 1, $@ eq ''; - -eval <<EOC; -package ${name}_WITH_HOOK; - -\@ISA = ("SHORT_NAME_WITH_HOOK"); -EOC -ok 2, $@ eq ''; - -# Construct a pool of objects -my @pool; - -for (my $i = 0; $i < 10; $i++) { - push(@pool, SHORT_NAME->make); - push(@pool, SHORT_NAME_WITH_HOOK->make); - push(@pool, $name->make); - push(@pool, "${name}_WITH_HOOK"->make); -} - -my $x = freeze \@pool; -ok 3, 1; - -my $y = thaw $x; -ok 4, ref $y eq 'ARRAY'; -ok 5, @{$y} == @pool; - -ok 6, ref $y->[0] eq 'SHORT_NAME'; -ok 7, ref $y->[1] eq 'SHORT_NAME_WITH_HOOK'; -ok 8, ref $y->[2] eq $name; -ok 9, ref $y->[3] eq "${name}_WITH_HOOK"; - -my $good = 1; -for (my $i = 0; $i < 10; $i++) { - do { $good = 0; last } unless ref $y->[4*$i] eq 'SHORT_NAME'; - do { $good = 0; last } unless ref $y->[4*$i+1] eq 'SHORT_NAME_WITH_HOOK'; - do { $good = 0; last } unless ref $y->[4*$i+2] eq $name; - do { $good = 0; last } unless ref $y->[4*$i+3] eq "${name}_WITH_HOOK"; -} -ok 10, $good; - diff --git a/t/lib/st-canonical.t b/t/lib/st-canonical.t deleted file mode 100644 index b55669b653..0000000000 --- a/t/lib/st-canonical.t +++ /dev/null @@ -1,153 +0,0 @@ -#!./perl - -# $Id: canonical.t,v 1.0 2000/09/01 19:40:41 ram Exp $ -# -# Copyright (c) 1995-2000, Raphael Manfredi -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# -# $Log: canonical.t,v $ -# Revision 1.0 2000/09/01 19:40:41 ram -# Baseline for first official release. -# - -sub BEGIN { - chdir('t') if -d 't'; - @INC = '.'; - push @INC, '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } -} - - -use Storable qw(freeze thaw dclone); -use vars qw($debugging $verbose); - -print "1..8\n"; - -sub ok { - my($testno, $ok) = @_; - print "not " unless $ok; - print "ok $testno\n"; -} - - -# Uncomment the folowing line to get a dump of the constructed data structure -# (you may want to reduce the size of the hashes too) -# $debugging = 1; - -$hashsize = 100; -$maxhash2size = 100; -$maxarraysize = 100; - -# Use MD5 if its available to make random string keys - -eval { require "MD5.pm" }; -$gotmd5 = !$@; - -# Use Data::Dumper if debugging and it is available to create an ASCII dump - -if ($debugging) { - eval { require "Data/Dumper.pm" }; - $gotdd = !$@; -} - -@fixed_strings = ("January", "February", "March", "April", "May", "June", - "July", "August", "September", "October", "November", "December" ); - -# Build some arbitrarily complex data structure starting with a top level hash -# (deeper levels contain scalars, references to hashes or references to arrays); - -for (my $i = 0; $i < $hashsize; $i++) { - my($k) = int(rand(1_000_000)); - $k = MD5->hexhash($k) if $gotmd5 and int(rand(2)); - $a1{$k} = { key => "$k", value => $i }; - - # A third of the elements are references to further hashes - - if (int(rand(1.5))) { - my($hash2) = {}; - my($hash2size) = int(rand($maxhash2size)); - while ($hash2size--) { - my($k2) = $k . $i . int(rand(100)); - $hash2->{$k2} = $fixed_strings[rand(int(@fixed_strings))]; - } - $a1{$k}->{value} = $hash2; - } - - # A further third are references to arrays - - elsif (int(rand(2))) { - my($arr_ref) = []; - my($arraysize) = int(rand($maxarraysize)); - while ($arraysize--) { - push(@$arr_ref, $fixed_strings[rand(int(@fixed_strings))]); - } - $a1{$k}->{value} = $arr_ref; - } -} - - -print STDERR Data::Dumper::Dumper(\%a1) if ($verbose and $gotdd); - - -# Copy the hash, element by element in order of the keys - -foreach $k (sort keys %a1) { - $a2{$k} = { key => "$k", value => $a1{$k}->{value} }; -} - -# Deep clone the hash - -$a3 = dclone(\%a1); - -# In canonical mode the frozen representation of each of the hashes -# should be identical - -$Storable::canonical = 1; - -$x1 = freeze(\%a1); -$x2 = freeze(\%a2); -$x3 = freeze($a3); - -ok 1, (length($x1) > $hashsize); # sanity check -ok 2, length($x1) == length($x2); # idem -ok 3, $x1 eq $x2; -ok 4, $x1 eq $x3; - -# In normal mode it is exceedingly unlikely that the frozen -# representaions of all the hashes will be the same (normally the hash -# elements are frozen in the order they are stored internally, -# i.e. pseudo-randomly). - -$Storable::canonical = 0; - -$x1 = freeze(\%a1); -$x2 = freeze(\%a2); -$x3 = freeze($a3); - - -# Two out of three the same may be a coincidence, all three the same -# is much, much more unlikely. Still it could happen, so this test -# may report a false negative. - -ok 5, ($x1 ne $x2) || ($x1 ne $x3); - - -# Ensure refs to "undef" values are properly shared -# Same test as in t/dclone.t to ensure the "canonical" code is also correct - -my $hash; -push @{$$hash{''}}, \$$hash{a}; -ok 6, $$hash{''}[0] == \$$hash{a}; - -my $cloned = dclone(dclone($hash)); -ok 7, $$cloned{''}[0] == \$$cloned{a}; - -$$cloned{a} = "blah"; -ok 8, $$cloned{''}[0] == \$$cloned{a}; - diff --git a/t/lib/st-dclone.t b/t/lib/st-dclone.t deleted file mode 100644 index 38c82ebcc1..0000000000 --- a/t/lib/st-dclone.t +++ /dev/null @@ -1,82 +0,0 @@ -#!./perl - -# $Id: dclone.t,v 1.0 2000/09/01 19:40:41 ram Exp $ -# -# Copyright (c) 1995-2000, Raphael Manfredi -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# -# $Log: dclone.t,v $ -# Revision 1.0 2000/09/01 19:40:41 ram -# Baseline for first official release. -# - -sub BEGIN { - chdir('t') if -d 't'; - @INC = '.'; - push @INC, '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } - require 'lib/st-dump.pl'; -} - - -use Storable qw(dclone); - -print "1..9\n"; - -$a = 'toto'; -$b = \$a; -$c = bless {}, CLASS; -$c->{attribute} = 'attrval'; -%a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c); -@a = ('first', undef, 3, -4, -3.14159, 456, 4.5, - $b, \$a, $a, $c, \$c, \%a); - -print "not " unless defined ($aref = dclone(\@a)); -print "ok 1\n"; - -$dumped = &dump(\@a); -print "ok 2\n"; - -$got = &dump($aref); -print "ok 3\n"; - -print "not " unless $got eq $dumped; -print "ok 4\n"; - -package FOO; @ISA = qw(Storable); - -sub make { - my $self = bless {}; - $self->{key} = \%main::a; - return $self; -}; - -package main; - -$foo = FOO->make; -print "not " unless defined($r = $foo->dclone); -print "ok 5\n"; - -print "not " unless &dump($foo) eq &dump($r); -print "ok 6\n"; - -# Ensure refs to "undef" values are properly shared during cloning -my $hash; -push @{$$hash{''}}, \$$hash{a}; -print "not " unless $$hash{''}[0] == \$$hash{a}; -print "ok 7\n"; - -my $cloned = dclone(dclone($hash)); -print "not " unless $$cloned{''}[0] == \$$cloned{a}; -print "ok 8\n"; - -$$cloned{a} = "blah"; -print "not " unless $$cloned{''}[0] == \$$cloned{a}; -print "ok 9\n"; - diff --git a/t/lib/st-forgive.t b/t/lib/st-forgive.t deleted file mode 100644 index 58810983c5..0000000000 --- a/t/lib/st-forgive.t +++ /dev/null @@ -1,67 +0,0 @@ -#!./perl - -# $Id: forgive.t,v 1.0.1.1 2000/09/01 19:40:42 ram Exp $ -# -# Copyright (c) 1995-2000, Raphael Manfredi -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# -# Original Author: Ulrich Pfeifer -# (C) Copyright 1997, Universitat Dortmund, all rights reserved. -# -# $Log: forgive.t,v $ -# Revision 1.0.1.1 2000/09/01 19:40:42 ram -# Baseline for first official release. -# -# Revision 1.0 2000/09/01 19:40:41 ram -# Baseline for first official release. -# - -sub BEGIN { - chdir('t') if -d 't'; - @INC = '.'; - push @INC, '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } -} - -use Storable qw(store retrieve); -use File::Spec; - -print "1..8\n"; - -my $test = 1; -my $bad = ['foo', sub { 1 }, 'bar']; -my $result; - -eval {$result = store ($bad , 'store')}; -print ((!defined $result)?"ok $test\n":"not ok $test\n"); $test++; -print (($@ ne '')?"ok $test\n":"not ok $test\n"); $test++; - -$Storable::forgive_me=1; - -my $devnull = File::Spec->devnull; - -open(SAVEERR, ">&STDERR"); -open(STDERR, ">$devnull") or - ( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) ); - -eval {$result = store ($bad , 'store')}; - -open(STDERR, ">&SAVEERR"); - -print ((defined $result)?"ok $test\n":"not ok $test\n"); $test++; -print (($@ eq '')?"ok $test\n":"not ok $test\n"); $test++; - -my $ret = retrieve('store'); -print ((defined $ret)?"ok $test\n":"not ok $test\n"); $test++; -print (($ret->[0] eq 'foo')?"ok $test\n":"not ok $test\n"); $test++; -print (($ret->[2] eq 'bar')?"ok $test\n":"not ok $test\n"); $test++; -print ((ref $ret->[1] eq 'SCALAR')?"ok $test\n":"not ok $test\n"); $test++; - - -END { 1 while unlink 'store' } diff --git a/t/lib/st-freeze.t b/t/lib/st-freeze.t deleted file mode 100644 index 37631edc7e..0000000000 --- a/t/lib/st-freeze.t +++ /dev/null @@ -1,119 +0,0 @@ -#!./perl - -# $Id: freeze.t,v 1.0 2000/09/01 19:40:41 ram Exp $ -# -# Copyright (c) 1995-2000, Raphael Manfredi -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# -# $Log: freeze.t,v $ -# Revision 1.0 2000/09/01 19:40:41 ram -# Baseline for first official release. -# - -sub BEGIN { - chdir('t') if -d 't'; - @INC = '.'; - push @INC, '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } - require 'lib/st-dump.pl'; -} - - -use Storable qw(freeze nfreeze thaw); - -print "1..15\n"; - -$a = 'toto'; -$b = \$a; -$c = bless {}, CLASS; -$c->{attribute} = $b; -$d = {}; -$e = []; -$d->{'a'} = $e; -$e->[0] = $d; -%a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c); -@a = ('first', undef, 3, -4, -3.14159, 456, 4.5, $d, \$d, \$e, $e, - $b, \$a, $a, $c, \$c, \%a); - -print "not " unless defined ($f1 = freeze(\@a)); -print "ok 1\n"; - -$dumped = &dump(\@a); -print "ok 2\n"; - -$root = thaw($f1); -print "not " unless defined $root; -print "ok 3\n"; - -$got = &dump($root); -print "ok 4\n"; - -print "not " unless $got eq $dumped; -print "ok 5\n"; - -package FOO; @ISA = qw(Storable); - -sub make { - my $self = bless {}; - $self->{key} = \%main::a; - return $self; -}; - -package main; - -$foo = FOO->make; -print "not " unless $f2 = $foo->freeze; -print "ok 6\n"; - -print "not " unless $f3 = $foo->nfreeze; -print "ok 7\n"; - -$root3 = thaw($f3); -print "not " unless defined $root3; -print "ok 8\n"; - -print "not " unless &dump($foo) eq &dump($root3); -print "ok 9\n"; - -$root = thaw($f2); -print "not " unless &dump($foo) eq &dump($root); -print "ok 10\n"; - -print "not " unless &dump($root3) eq &dump($root); -print "ok 11\n"; - -$other = freeze($root); -print "not " unless length($other) == length($f2); -print "ok 12\n"; - -$root2 = thaw($other); -print "not " unless &dump($root2) eq &dump($root); -print "ok 13\n"; - -$VAR1 = [ - 'method', - 1, - 'prepare', - 'SELECT table_name, table_owner, num_rows FROM iitables - where table_owner != \'$ingres\' and table_owner != \'DBA\'' -]; - -$x = nfreeze($VAR1); -$VAR2 = thaw($x); -print "not " unless $VAR2->[3] eq $VAR1->[3]; -print "ok 14\n"; - -# Test the workaround for LVALUE bug in perl 5.004_04 -- from Gisle Aas -sub foo { $_[0] = 1 } -$foo = []; -foo($foo->[1]); -eval { freeze($foo) }; -print "not " if $@; -print "ok 15\n"; - diff --git a/t/lib/st-lock.t b/t/lib/st-lock.t deleted file mode 100644 index 77d73bbb79..0000000000 --- a/t/lib/st-lock.t +++ /dev/null @@ -1,61 +0,0 @@ -#!./perl - -# $Id: lock.t,v 1.0.1.4 2001/01/03 09:41:00 ram Exp $ -# -# @COPYRIGHT@ -# -# $Log: lock.t,v $ -# Revision 1.0.1.4 2001/01/03 09:41:00 ram -# patch7: use new CAN_FLOCK routine to determine whether to run tests -# -# Revision 1.0.1.3 2000/10/26 17:11:27 ram -# patch5: just check $^O, there's no need for the whole Config -# -# Revision 1.0.1.2 2000/10/23 18:03:07 ram -# patch4: protected calls to flock() for dos platform -# -# Revision 1.0.1.1 2000/09/28 21:44:06 ram -# patch2: created. -# -# - -sub BEGIN { - chdir('t') if -d 't'; - @INC = '.'; - push @INC, '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } - - require 'lib/st-dump.pl'; -} - -sub ok; - -use Storable qw(lock_store lock_retrieve); - -unless (&Storable::CAN_FLOCK) { - print "1..0 # Skip: fcntl/flock emulation broken on this platform\n"; - exit 0; -} - -print "1..5\n"; - -@a = ('first', undef, 3, -4, -3.14159, 456, 4.5); - -# -# We're just ensuring things work, we're not validating locking. -# - -ok 1, defined lock_store(\@a, 'store'); -ok 2, $dumped = &dump(\@a); - -$root = lock_retrieve('store'); -ok 3, ref $root eq 'ARRAY'; -ok 4, @a == @$root; -ok 5, &dump($root) eq $dumped; - -unlink 't/store'; - diff --git a/t/lib/st-overload.t b/t/lib/st-overload.t deleted file mode 100644 index 6d1e5816d1..0000000000 --- a/t/lib/st-overload.t +++ /dev/null @@ -1,97 +0,0 @@ -#!./perl - -# $Id: overload.t,v 1.0.1.1 2001/02/17 12:27:22 ram Exp $ -# -# Copyright (c) 1995-2000, Raphael Manfredi -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# -# $Log: overload.t,v $ -# Revision 1.0.1.1 2001/02/17 12:27:22 ram -# patch8: added test for structures with indirect ref to overloaded -# -# Revision 1.0 2000/09/01 19:40:42 ram -# Baseline for first official release. -# - -sub BEGIN { - chdir('t') if -d 't'; - @INC = '.'; - push @INC, '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } - require 'lib/st-dump.pl'; -} - -sub ok; - -use Storable qw(freeze thaw); - -print "1..12\n"; - -package OVERLOADED; - -use overload - '""' => sub { $_[0][0] }; - -package main; - -$a = bless [77], OVERLOADED; - -$b = thaw freeze $a; -ok 1, ref $b eq 'OVERLOADED'; -ok 2, "$b" eq "77"; - -$c = thaw freeze \$a; -ok 3, ref $c eq 'REF'; -ok 4, ref $$c eq 'OVERLOADED'; -ok 5, "$$c" eq "77"; - -$d = thaw freeze [$a, $a]; -ok 6, "$d->[0]" eq "77"; -$d->[0][0]++; -ok 7, "$d->[1]" eq "78"; - -package REF_TO_OVER; - -sub make { - my $self = bless {}, shift; - my ($over) = @_; - $self->{over} = $over; - return $self; -} - -package OVER; - -use overload - '+' => \&plus, - '""' => sub { ref $_[0] }; - -sub plus { - return 314; -} - -sub make { - my $self = bless {}, shift; - my $ref = REF_TO_OVER->make($self); - $self->{ref} = $ref; - return $self; -} - -package main; - -$a = OVER->make(); -$b = thaw freeze $a; - -ok 8, ref $b eq 'OVER'; -ok 9, $a + $a == 314; -ok 10, ref $b->{ref} eq 'REF_TO_OVER'; -ok 11, "$b->{ref}->{over}" eq "$b"; -ok 12, $b + $b == 314; - -1; - diff --git a/t/lib/st-recurse.t b/t/lib/st-recurse.t deleted file mode 100644 index e3afc9cf2f..0000000000 --- a/t/lib/st-recurse.t +++ /dev/null @@ -1,300 +0,0 @@ -#!./perl - -# $Id: recurse.t,v 1.0.1.3 2001/02/17 12:28:33 ram Exp $ -# -# Copyright (c) 1995-2000, Raphael Manfredi -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# -# $Log: recurse.t,v $ -# Revision 1.0.1.3 2001/02/17 12:28:33 ram -# patch8: ensure blessing occurs ASAP, specially designed for hooks -# -# Revision 1.0.1.2 2000/11/05 17:22:05 ram -# patch6: stress hook a little more with refs to lexicals -# -# $Log: recurse.t,v $ -# Revision 1.0.1.1 2000/09/17 16:48:05 ram -# patch1: added test case for store hook bug -# -# $Log: recurse.t,v $ -# Revision 1.0 2000/09/01 19:40:42 ram -# Baseline for first official release. -# - -sub BEGIN { - chdir('t') if -d 't'; - @INC = '.'; - push @INC, '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } - require 'lib/st-dump.pl'; -} - -sub ok; - -use Storable qw(freeze thaw dclone); - -print "1..32\n"; - -package OBJ_REAL; - -use Storable qw(freeze thaw); - -@x = ('a', 1); - -sub make { bless [], shift } - -sub STORABLE_freeze { - my $self = shift; - my $cloning = shift; - die "STORABLE_freeze" unless Storable::is_storing; - return (freeze(\@x), $self); -} - -sub STORABLE_thaw { - my $self = shift; - my $cloning = shift; - my ($x, $obj) = @_; - die "STORABLE_thaw #1" unless $obj eq $self; - my $len = length $x; - my $a = thaw $x; - die "STORABLE_thaw #2" unless ref $a eq 'ARRAY'; - die "STORABLE_thaw #3" unless @$a == 2 && $a->[0] eq 'a' && $a->[1] == 1; - @$self = @$a; - die "STORABLE_thaw #4" unless Storable::is_retrieving; -} - -package OBJ_SYNC; - -@x = ('a', 1); - -sub make { bless {}, shift } - -sub STORABLE_freeze { - my $self = shift; - my ($cloning) = @_; - return if $cloning; - return ("", \@x, $self); -} - -sub STORABLE_thaw { - my $self = shift; - my ($cloning, $undef, $a, $obj) = @_; - die "STORABLE_thaw #1" unless $obj eq $self; - die "STORABLE_thaw #2" unless ref $a eq 'ARRAY' || @$a != 2; - $self->{ok} = $self; -} - -package OBJ_SYNC2; - -use Storable qw(dclone); - -sub make { - my $self = bless {}, shift; - my ($ext) = @_; - $self->{sync} = OBJ_SYNC->make; - $self->{ext} = $ext; - return $self; -} - -sub STORABLE_freeze { - my $self = shift; - my %copy = %$self; - my $r = \%copy; - my $t = dclone($r->{sync}); - return ("", [$t, $self->{ext}], $r, $self, $r->{ext}); -} - -sub STORABLE_thaw { - my $self = shift; - my ($cloning, $undef, $a, $r, $obj, $ext) = @_; - die "STORABLE_thaw #1" unless $obj eq $self; - die "STORABLE_thaw #2" unless ref $a eq 'ARRAY'; - die "STORABLE_thaw #3" unless ref $r eq 'HASH'; - die "STORABLE_thaw #4" unless $a->[1] == $r->{ext}; - $self->{ok} = $self; - ($self->{sync}, $self->{ext}) = @$a; -} - -package OBJ_REAL2; - -use Storable qw(freeze thaw); - -$MAX = 20; -$recursed = 0; -$hook_called = 0; - -sub make { bless [], shift } - -sub STORABLE_freeze { - my $self = shift; - $hook_called++; - return (freeze($self), $self) if ++$recursed < $MAX; - return ("no", $self); -} - -sub STORABLE_thaw { - my $self = shift; - my $cloning = shift; - my ($x, $obj) = @_; - die "STORABLE_thaw #1" unless $obj eq $self; - $self->[0] = thaw($x) if $x ne "no"; - $recursed--; -} - -package main; - -my $real = OBJ_REAL->make; -my $x = freeze $real; -ok 1, 1; - -my $y = thaw $x; -ok 2, 1; -ok 3, $y->[0] eq 'a'; -ok 4, $y->[1] == 1; - -my $sync = OBJ_SYNC->make; -$x = freeze $sync; -ok 5, 1; - -$y = thaw $x; -ok 6, 1; -ok 7, $y->{ok} == $y; - -my $ext = [1, 2]; -$sync = OBJ_SYNC2->make($ext); -$x = freeze [$sync, $ext]; -ok 8, 1; - -my $z = thaw $x; -$y = $z->[0]; -ok 9, 1; -ok 10, $y->{ok} == $y; -ok 11, ref $y->{sync} eq 'OBJ_SYNC'; -ok 12, $y->{ext} == $z->[1]; - -$real = OBJ_REAL2->make; -$x = freeze $real; -ok 13, 1; -ok 14, $OBJ_REAL2::recursed == $OBJ_REAL2::MAX; -ok 15, $OBJ_REAL2::hook_called == $OBJ_REAL2::MAX; - -$y = thaw $x; -ok 16, 1; -ok 17, $OBJ_REAL2::recursed == 0; - -$x = dclone $real; -ok 18, 1; -ok 19, ref $x eq 'OBJ_REAL2'; -ok 20, $OBJ_REAL2::recursed == 0; -ok 21, $OBJ_REAL2::hook_called == 2 * $OBJ_REAL2::MAX; - -ok 22, !Storable::is_storing; -ok 23, !Storable::is_retrieving; - -# -# The following was a test-case that Salvador Ortiz Garcia <sog@msg.com.mx> -# sent me, along with a proposed fix. -# - -package Foo; - -sub new { - my $class = shift; - my $dat = shift; - return bless {dat => $dat}, $class; -} - -package Bar; -sub new { - my $class = shift; - return bless { - a => 'dummy', - b => [ - Foo->new(1), - Foo->new(2), # Second instance of a Foo - ] - }, $class; -} - -sub STORABLE_freeze { - my($self,$clonning) = @_; - return "$self->{a}", $self->{b}; -} - -sub STORABLE_thaw { - my($self,$clonning,$dummy,$o) = @_; - $self->{a} = $dummy; - $self->{b} = $o; -} - -package main; - -my $bar = new Bar; -my $bar2 = thaw freeze $bar; - -ok 24, ref($bar2) eq 'Bar'; -ok 25, ref($bar->{b}[0]) eq 'Foo'; -ok 26, ref($bar->{b}[1]) eq 'Foo'; -ok 27, ref($bar2->{b}[0]) eq 'Foo'; -ok 28, ref($bar2->{b}[1]) eq 'Foo'; - -# -# The following attempts to make sure blessed objects are blessed ASAP -# at retrieve time. -# - -package CLASS_1; - -sub make { - my $self = bless {}, shift; - return $self; -} - -package CLASS_2; - -sub make { - my $self = bless {}, shift; - my ($o) = @_; - $self->{c1} = CLASS_1->make(); - $self->{o} = $o; - $self->{c3} = bless CLASS_1->make(), "CLASS_3"; - $o->set_c2($self); - return $self; -} - -sub STORABLE_freeze { - my($self, $clonning) = @_; - return "", $self->{c1}, $self->{c3}, $self->{o}; -} - -sub STORABLE_thaw { - my($self, $clonning, $frozen, $c1, $c3, $o) = @_; - main::ok 29, ref $self eq "CLASS_2"; - main::ok 30, ref $c1 eq "CLASS_1"; - main::ok 31, ref $c3 eq "CLASS_3"; - main::ok 32, ref $o eq "CLASS_OTHER"; - $self->{c1} = $c1; - $self->{c3} = $c3; -} - -package CLASS_OTHER; - -sub make { - my $self = bless {}, shift; - return $self; -} - -sub set_c2 { $_[0]->{c2} = $_[1] } - -package main; - -my $o = CLASS_OTHER->make(); -my $c2 = CLASS_2->make($o); -my $so = thaw freeze $o; - diff --git a/t/lib/st-retrieve.t b/t/lib/st-retrieve.t deleted file mode 100644 index c968485ab2..0000000000 --- a/t/lib/st-retrieve.t +++ /dev/null @@ -1,78 +0,0 @@ -#!./perl - -# $Id: retrieve.t,v 1.0 2000/09/01 19:40:42 ram Exp $ -# -# Copyright (c) 1995-2000, Raphael Manfredi -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# -# $Log: retrieve.t,v $ -# Revision 1.0 2000/09/01 19:40:42 ram -# Baseline for first official release. -# - -sub BEGIN { - chdir('t') if -d 't'; - @INC = '.'; - push @INC, '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } - require 'lib/st-dump.pl'; -} - - -use Storable qw(store retrieve nstore); - -print "1..14\n"; - -$a = 'toto'; -$b = \$a; -$c = bless {}, CLASS; -$c->{attribute} = 'attrval'; -%a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c); -@a = ('first', '', undef, 3, -4, -3.14159, 456, 4.5, - $b, \$a, $a, $c, \$c, \%a); - -print "not " unless defined store(\@a, 'store'); -print "ok 1\n"; -print "not " if Storable::last_op_in_netorder(); -print "ok 2\n"; -print "not " unless defined nstore(\@a, 'nstore'); -print "ok 3\n"; -print "not " unless Storable::last_op_in_netorder(); -print "ok 4\n"; -print "not " unless Storable::last_op_in_netorder(); -print "ok 5\n"; - -$root = retrieve('store'); -print "not " unless defined $root; -print "ok 6\n"; -print "not " if Storable::last_op_in_netorder(); -print "ok 7\n"; - -$nroot = retrieve('nstore'); -print "not " unless defined $nroot; -print "ok 8\n"; -print "not " unless Storable::last_op_in_netorder(); -print "ok 9\n"; - -$d1 = &dump($root); -print "ok 10\n"; -$d2 = &dump($nroot); -print "ok 11\n"; - -print "not " unless $d1 eq $d2; -print "ok 12\n"; - -# Make sure empty string is defined at retrieval time -print "not " unless defined $root->[1]; -print "ok 13\n"; -print "not " if length $root->[1]; -print "ok 14\n"; - -END { 1 while unlink('store', 'nstore') } - diff --git a/t/lib/st-store.t b/t/lib/st-store.t deleted file mode 100644 index d26755f129..0000000000 --- a/t/lib/st-store.t +++ /dev/null @@ -1,119 +0,0 @@ -#!./perl - -# $Id: store.t,v 1.0 2000/09/01 19:40:42 ram Exp $ -# -# Copyright (c) 1995-2000, Raphael Manfredi -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# -# $Log: store.t,v $ -# Revision 1.0 2000/09/01 19:40:42 ram -# Baseline for first official release. -# - -sub BEGIN { - chdir('t') if -d 't'; - @INC = '.'; - push @INC, '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } - require 'lib/st-dump.pl'; -} - -use Storable qw(store retrieve store_fd nstore_fd fd_retrieve); - -print "1..20\n"; - -$a = 'toto'; -$b = \$a; -$c = bless {}, CLASS; -$c->{attribute} = 'attrval'; -%a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c); -@a = ('first', undef, 3, -4, -3.14159, 456, 4.5, - $b, \$a, $a, $c, \$c, \%a); - -print "not " unless defined store(\@a, 'store'); -print "ok 1\n"; - -$dumped = &dump(\@a); -print "ok 2\n"; - -$root = retrieve('store'); -print "not " unless defined $root; -print "ok 3\n"; - -$got = &dump($root); -print "ok 4\n"; - -print "not " unless $got eq $dumped; -print "ok 5\n"; - -1 while unlink 'store'; - -package FOO; @ISA = qw(Storable); - -sub make { - my $self = bless {}; - $self->{key} = \%main::a; - return $self; -}; - -package main; - -$foo = FOO->make; -print "not " unless $foo->store('store'); -print "ok 6\n"; - -print "not " unless open(OUT, '>>store'); -print "ok 7\n"; -binmode OUT; - -print "not " unless defined store_fd(\@a, ::OUT); -print "ok 8\n"; -print "not " unless defined nstore_fd($foo, ::OUT); -print "ok 9\n"; -print "not " unless defined nstore_fd(\%a, ::OUT); -print "ok 10\n"; - -print "not " unless close(OUT); -print "ok 11\n"; - -print "not " unless open(OUT, 'store'); -binmode OUT; - -$r = fd_retrieve(::OUT); -print "not " unless defined $r; -print "ok 12\n"; -print "not " unless &dump($foo) eq &dump($r); -print "ok 13\n"; - -$r = fd_retrieve(::OUT); -print "not " unless defined $r; -print "ok 14\n"; -print "not " unless &dump(\@a) eq &dump($r); -print "ok 15\n"; - -$r = fd_retrieve(main::OUT); -print "not " unless defined $r; -print "ok 16\n"; -print "not " unless &dump($foo) eq &dump($r); -print "ok 17\n"; - -$r = fd_retrieve(::OUT); -print "not " unless defined $r; -print "ok 18\n"; -print "not " unless &dump(\%a) eq &dump($r); -print "ok 19\n"; - -eval { $r = fd_retrieve(::OUT); }; -print "not " unless $@; -print "ok 20\n"; - -close OUT; -END { 1 while unlink 'store' } - - diff --git a/t/lib/st-tied.t b/t/lib/st-tied.t deleted file mode 100644 index 88131fea03..0000000000 --- a/t/lib/st-tied.t +++ /dev/null @@ -1,213 +0,0 @@ -#!./perl - -# $Id: tied.t,v 1.0 2000/09/01 19:40:42 ram Exp $ -# -# Copyright (c) 1995-2000, Raphael Manfredi -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# -# $Log: tied.t,v $ -# Revision 1.0 2000/09/01 19:40:42 ram -# Baseline for first official release. -# - -sub BEGIN { - chdir('t') if -d 't'; - @INC = '.'; - push @INC, '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } - require 'lib/st-dump.pl'; -} - -sub ok; - -use Storable qw(freeze thaw); - -print "1..22\n"; - -($scalar_fetch, $array_fetch, $hash_fetch) = (0, 0, 0); - -package TIED_HASH; - -sub TIEHASH { - my $self = bless {}, shift; - return $self; -} - -sub FETCH { - my $self = shift; - my ($key) = @_; - $main::hash_fetch++; - return $self->{$key}; -} - -sub STORE { - my $self = shift; - my ($key, $value) = @_; - $self->{$key} = $value; -} - -sub FIRSTKEY { - my $self = shift; - scalar keys %{$self}; - return each %{$self}; -} - -sub NEXTKEY { - my $self = shift; - return each %{$self}; -} - -package TIED_ARRAY; - -sub TIEARRAY { - my $self = bless [], shift; - return $self; -} - -sub FETCH { - my $self = shift; - my ($idx) = @_; - $main::array_fetch++; - return $self->[$idx]; -} - -sub STORE { - my $self = shift; - my ($idx, $value) = @_; - $self->[$idx] = $value; -} - -sub FETCHSIZE { - my $self = shift; - return @{$self}; -} - -package TIED_SCALAR; - -sub TIESCALAR { - my $scalar; - my $self = bless \$scalar, shift; - return $self; -} - -sub FETCH { - my $self = shift; - $main::scalar_fetch++; - return $$self; -} - -sub STORE { - my $self = shift; - my ($value) = @_; - $$self = $value; -} - -package FAULT; - -$fault = 0; - -sub TIESCALAR { - my $pkg = shift; - return bless [@_], $pkg; -} - -sub FETCH { - my $self = shift; - my ($href, $key) = @$self; - $fault++; - untie $href->{$key}; - return $href->{$key} = 1; -} - -package main; - -$a = 'toto'; -$b = \$a; - -$c = tie %hash, TIED_HASH; -$d = tie @array, TIED_ARRAY; -tie $scalar, TIED_SCALAR; - -#$scalar = 'foo'; -#$hash{'attribute'} = \$d; -#$array[0] = $c; -#$array[1] = \$scalar; - -### If I say -### $hash{'attribute'} = $d; -### below, then dump() incorectly dumps the hash value as a string the second -### time it is reached. I have not investigated enough to tell whether it's -### a bug in my dump() routine or in the Perl tieing mechanism. -$scalar = 'foo'; -$hash{'attribute'} = 'plain value'; -$array[0] = \$scalar; -$array[1] = $c; -$array[2] = \@array; - -@tied = (\$scalar, \@array, \%hash); -%a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$a, 'scalarref', \$scalar); -@a = ('first', 3, -4, -3.14159, 456, 4.5, $d, \$d, - $b, \$a, $a, $c, \$c, \%a, \@array, \%hash, \@tied); - -ok 1, defined($f = freeze(\@a)); - -$dumped = &dump(\@a); -ok 2, 1; - -$root = thaw($f); -ok 3, defined $root; - -$got = &dump($root); -ok 4, 1; - -### Used to see the manifestation of the bug documented above. -### print "original: $dumped"; -### print "--------\n"; -### print "got: $got"; -### print "--------\n"; - -ok 5, $got eq $dumped; - -$g = freeze($root); -ok 6, length($f) == length($g); - -# Ensure the tied items in the retrieved image work -@old = ($scalar_fetch, $array_fetch, $hash_fetch); -@tied = ($tscalar, $tarray, $thash) = @{$root->[$#{$root}]}; -@type = qw(SCALAR ARRAY HASH); - -ok 7, tied $$tscalar; -ok 8, tied @{$tarray}; -ok 9, tied %{$thash}; - -@new = ($$tscalar, $tarray->[0], $thash->{'attribute'}); -@new = ($scalar_fetch, $array_fetch, $hash_fetch); - -# Tests 10..15 -for ($i = 0; $i < @new; $i++) { - print "not " unless $new[$i] == $old[$i] + 1; - printf "ok %d\n", 10 + 2*$i; # Tests 10,12,14 - print "not " unless ref $tied[$i] eq $type[$i]; - printf "ok %d\n", 11 + 2*$i; # Tests 11,13,15 -} - -# Check undef ties -my $h = {}; -tie $h->{'x'}, 'FAULT', $h, 'x'; -my $hf = freeze($h); -ok 16, defined $hf; -ok 17, $FAULT::fault == 0; -ok 18, $h->{'x'} == 1; -ok 19, $FAULT::fault == 1; - -my $ht = thaw($hf); -ok 20, defined $ht; -ok 21, $ht->{'x'} == 1; -ok 22, $FAULT::fault == 2; - diff --git a/t/lib/st-tiedhook.t b/t/lib/st-tiedhook.t deleted file mode 100644 index 46805cf510..0000000000 --- a/t/lib/st-tiedhook.t +++ /dev/null @@ -1,254 +0,0 @@ -#!./perl - -# $Id: tied_hook.t,v 1.0.1.1 2001/02/17 12:29:01 ram Exp $ -# -# Copyright (c) 1995-2000, Raphael Manfredi -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# -# $Log: tied_hook.t,v $ -# Revision 1.0.1.1 2001/02/17 12:29:01 ram -# patch8: added test for blessed ref to tied hash -# -# Revision 1.0 2000/09/01 19:40:42 ram -# Baseline for first official release. -# - -sub BEGIN { - chdir('t') if -d 't'; - @INC = '.'; - push @INC, '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } - require 'lib/st-dump.pl'; -} - -sub ok; - -use Storable qw(freeze thaw); - -print "1..25\n"; - -($scalar_fetch, $array_fetch, $hash_fetch) = (0, 0, 0); - -package TIED_HASH; - -sub TIEHASH { - my $self = bless {}, shift; - return $self; -} - -sub FETCH { - my $self = shift; - my ($key) = @_; - $main::hash_fetch++; - return $self->{$key}; -} - -sub STORE { - my $self = shift; - my ($key, $value) = @_; - $self->{$key} = $value; -} - -sub FIRSTKEY { - my $self = shift; - scalar keys %{$self}; - return each %{$self}; -} - -sub NEXTKEY { - my $self = shift; - return each %{$self}; -} - -sub STORABLE_freeze { - my $self = shift; - $main::hash_hook1++; - return join(":", keys %$self) . ";" . join(":", values %$self); -} - -sub STORABLE_thaw { - my ($self, $cloning, $frozen) = @_; - my ($keys, $values) = split(/;/, $frozen); - my @keys = split(/:/, $keys); - my @values = split(/:/, $values); - for (my $i = 0; $i < @keys; $i++) { - $self->{$keys[$i]} = $values[$i]; - } - $main::hash_hook2++; -} - -package TIED_ARRAY; - -sub TIEARRAY { - my $self = bless [], shift; - return $self; -} - -sub FETCH { - my $self = shift; - my ($idx) = @_; - $main::array_fetch++; - return $self->[$idx]; -} - -sub STORE { - my $self = shift; - my ($idx, $value) = @_; - $self->[$idx] = $value; -} - -sub FETCHSIZE { - my $self = shift; - return @{$self}; -} - -sub STORABLE_freeze { - my $self = shift; - $main::array_hook1++; - return join(":", @$self); -} - -sub STORABLE_thaw { - my ($self, $cloning, $frozen) = @_; - @$self = split(/:/, $frozen); - $main::array_hook2++; -} - -package TIED_SCALAR; - -sub TIESCALAR { - my $scalar; - my $self = bless \$scalar, shift; - return $self; -} - -sub FETCH { - my $self = shift; - $main::scalar_fetch++; - return $$self; -} - -sub STORE { - my $self = shift; - my ($value) = @_; - $$self = $value; -} - -sub STORABLE_freeze { - my $self = shift; - $main::scalar_hook1++; - return $$self; -} - -sub STORABLE_thaw { - my ($self, $cloning, $frozen) = @_; - $$self = $frozen; - $main::scalar_hook2++; -} - -package main; - -$a = 'toto'; -$b = \$a; - -$c = tie %hash, TIED_HASH; -$d = tie @array, TIED_ARRAY; -tie $scalar, TIED_SCALAR; - -$scalar = 'foo'; -$hash{'attribute'} = 'plain value'; -$array[0] = \$scalar; -$array[1] = $c; -$array[2] = \@array; -$array[3] = "plaine scalaire"; - -@tied = (\$scalar, \@array, \%hash); -%a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$a, 'scalarref', \$scalar); -@a = ('first', 3, -4, -3.14159, 456, 4.5, $d, \$d, - $b, \$a, $a, $c, \$c, \%a, \@array, \%hash, \@tied); - -ok 1, defined($f = freeze(\@a)); - -$dumped = &dump(\@a); -ok 2, 1; - -$root = thaw($f); -ok 3, defined $root; - -$got = &dump($root); -ok 4, 1; - -ok 5, $got ne $dumped; # our hooks did not handle refs in array - -$g = freeze($root); -ok 6, length($f) == length($g); - -# Ensure the tied items in the retrieved image work -@old = ($scalar_fetch, $array_fetch, $hash_fetch); -@tied = ($tscalar, $tarray, $thash) = @{$root->[$#{$root}]}; -@type = qw(SCALAR ARRAY HASH); - -ok 7, tied $$tscalar; -ok 8, tied @{$tarray}; -ok 9, tied %{$thash}; - -@new = ($$tscalar, $tarray->[0], $thash->{'attribute'}); -@new = ($scalar_fetch, $array_fetch, $hash_fetch); - -# Tests 10..15 -for ($i = 0; $i < @new; $i++) { - ok 10 + 2*$i, $new[$i] == $old[$i] + 1; # Tests 10,12,14 - ok 11 + 2*$i, ref $tied[$i] eq $type[$i]; # Tests 11,13,15 -} - -ok 16, $$tscalar eq 'foo'; -ok 17, $tarray->[3] eq 'plaine scalaire'; -ok 18, $thash->{'attribute'} eq 'plain value'; - -# Ensure hooks were called -ok 19, ($scalar_hook1 && $scalar_hook2); -ok 20, ($array_hook1 && $array_hook2); -ok 21, ($hash_hook1 && $hash_hook2); - -# -# And now for the "blessed ref to tied hash" with "store hook" test... -# - -my $bc = bless \%hash, 'FOO'; # FOO does not exist -> no hook -my $bx = thaw freeze $bc; - -ok 22, ref $bx eq 'FOO'; -my $old_hash_fetch = $hash_fetch; -my $v = $bx->{attribute}; -ok 23, $hash_fetch == $old_hash_fetch + 1; # Still tied - -package TIED_HASH_REF; - - -sub STORABLE_freeze { - my ($self, $cloning) = @_; - return if $cloning; - return('ref lost'); -} - -sub STORABLE_thaw { - my ($self, $cloning, $data) = @_; - return if $cloning; -} - -package main; - -$bc = bless \%hash, 'TIED_HASH_REF'; -$bx = thaw freeze $bc; - -ok 24, ref $bx eq 'TIED_HASH_REF'; -$old_hash_fetch = $hash_fetch; -$v = $bx->{attribute}; -ok 25, $hash_fetch == $old_hash_fetch + 1; # Still tied - diff --git a/t/lib/st-tieditems.t b/t/lib/st-tieditems.t deleted file mode 100644 index 3d0abf796f..0000000000 --- a/t/lib/st-tieditems.t +++ /dev/null @@ -1,68 +0,0 @@ -#!./perl - -# $Id: tied_items.t,v 1.0 2000/09/01 19:40:42 ram Exp $ -# -# Copyright (c) 1995-2000, Raphael Manfredi -# -# You may redistribute only under the same terms as Perl 5, as specified -# in the README file that comes with the distribution. -# -# $Log: tied_items.t,v $ -# Revision 1.0 2000/09/01 19:40:42 ram -# Baseline for first official release. -# - -# -# Tests ref to items in tied hash/array structures. -# - -sub BEGIN { - chdir('t') if -d 't'; - @INC = '.'; - push @INC, '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } - require 'lib/st-dump.pl'; -} - -sub ok; -$^W = 0; - -print "1..8\n"; - -use Storable qw(dclone); - -$h_fetches = 0; - -sub H::TIEHASH { bless \(my $x), "H" } -sub H::FETCH { $h_fetches++; $_[1] - 70 } - -tie %h, "H"; - -$ref = \$h{77}; -$ref2 = dclone $ref; - -ok 1, $h_fetches == 0; -ok 2, $$ref2 eq $$ref; -ok 3, $$ref2 == 7; -ok 4, $h_fetches == 2; - -$a_fetches = 0; - -sub A::TIEARRAY { bless \(my $x), "A" } -sub A::FETCH { $a_fetches++; $_[1] - 70 } - -tie @a, "A"; - -$ref = \$a[78]; -$ref2 = dclone $ref; - -ok 5, $a_fetches == 0; -ok 6, $$ref2 eq $$ref; -ok 7, $$ref2 == 8; -# I don't understand why it's 3 and not 2 -ok 8, $a_fetches == 3; - diff --git a/t/lib/st-utf8.t b/t/lib/st-utf8.t deleted file mode 100644 index 2160308a28..0000000000 --- a/t/lib/st-utf8.t +++ /dev/null @@ -1,40 +0,0 @@ -#!./perl - -# $Id: utf8.t,v 1.0.1.2 2000/09/28 21:44:17 ram Exp $ -# -# @COPYRIGHT@ -# -# $Log: utf8.t,v $ -# Revision 1.0.1.2 2000/09/28 21:44:17 ram -# patch2: fixed stupid typo -# -# Revision 1.0.1.1 2000/09/17 16:48:12 ram -# patch1: created. -# -# - -sub BEGIN { - if ($] < 5.006) { - print "1..0 # Skip: no utf8 support\n"; - exit 0; - } - chdir('t') if -d 't'; - @INC = '.'; - push @INC, '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bStorable\b/) { - print "1..0 # Skip: Storable was not built\n"; - exit 0; - } - require 'lib/st-dump.pl'; -} - -sub ok; - -use Storable qw(thaw freeze); - -print "1..1\n"; - -$x = chr(1234); -ok 1, $x eq ${thaw freeze \$x}; - diff --git a/t/lib/switch.t b/t/lib/switch.t deleted file mode 100644 index d1a8af191f..0000000000 --- a/t/lib/switch.t +++ /dev/null @@ -1,277 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Carp; -use Switch qw(__ fallthrough); - -my($C,$M);sub ok{$C++;$M.=$_[0]?"ok $C\n":"not ok $C (line ".(caller)[2].")\n"} -END{print"1..$C\n$M"} - -# NON-case THINGS; - -$case->{case} = { case => "case" }; - -*case = \&case; - -# PREMATURE case - -eval { case 1 { ok(0) }; ok(0) } || ok(1); - -# H.O. FUNCS - -switch (__ > 2) { - - case 1 { ok(0) } else { ok(1) } - case 2 { ok(0) } else { ok(1) } - case 3 { ok(1) } else { ok(0) } -} - -switch (3) { - - eval { case __ <= 1 || __ > 2 { ok(0) } } || ok(1); - case __ <= 2 { ok(0) }; - case __ <= 3 { ok(1) }; -} - -# POSSIBLE ARGS: NUMERIC, STRING, ARRAY, HASH, REGEX, CODE - -# 1. NUMERIC SWITCH - -for (1..3) -{ - switch ($_) { - # SELF - case ($_) { ok(1) } else { ok(0) } - - # NUMERIC - case (1) { ok ($_==1) } else { ok($_!=1) } - case 1 { ok ($_==1) } else { ok($_!=1) } - case (3) { ok ($_==3) } else { ok($_!=3) } - case (4) { ok (0) } else { ok(1) } - case (2) { ok ($_==2) } else { ok($_!=2) } - - # STRING - case ('a') { ok (0) } else { ok(1) } - case 'a' { ok (0) } else { ok(1) } - case ('3') { ok ($_ == 3) } else { ok($_ != 3) } - case ('3.0') { ok (0) } else { ok(1) } - - # ARRAY - case ([10,5,1]) { ok ($_==1) } else { ok($_!=1) } - case [10,5,1] { ok ($_==1) } else { ok($_!=1) } - case (['a','b']) { ok (0) } else { ok(1) } - case (['a','b',3]) { ok ($_==3) } else { ok ($_!=3) } - case (['a','b',2.0]) { ok ($_==2) } else { ok ($_!=2) } - case ([]) { ok (0) } else { ok(1) } - - # HASH - case ({}) { ok (0) } else { ok (1) } - case {} { ok (0) } else { ok (1) } - case {1,1} { ok ($_==1) } else { ok($_!=1) } - case ({1=>1, 2=>0}) { ok ($_==1) } else { ok($_!=1) } - - # SUB/BLOCK - case (sub {$_[0]==2}) { ok ($_==2) } else { ok($_!=2) } - case {$_[0]==2} { ok ($_==2) } else { ok($_!=2) } - case {0} { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH - case {1} { ok (1) } else { ok (0) } # ; -> SUB, NOT HASH - } -} - - -# 2. STRING SWITCH - -for ('a'..'c','1') -{ - switch ($_) { - # SELF - case ($_) { ok(1) } else { ok(0) } - - # NUMERIC - case (1) { ok ($_ !~ /[a-c]/) } else { ok ($_ =~ /[a-c]/) } - case (1.0) { ok ($_ !~ /[a-c]/) } else { ok ($_ =~ /[a-c]/) } - - # STRING - case ('a') { ok ($_ eq 'a') } else { ok($_ ne 'a') } - case ('b') { ok ($_ eq 'b') } else { ok($_ ne 'b') } - case ('c') { ok ($_ eq 'c') } else { ok($_ ne 'c') } - case ('1') { ok ($_ eq '1') } else { ok($_ ne '1') } - case ('d') { ok (0) } else { ok (1) } - - # ARRAY - case (['a','1']) { ok ($_ eq 'a' || $_ eq '1') } - else { ok ($_ ne 'a' && $_ ne '1') } - case (['z','2']) { ok (0) } else { ok(1) } - case ([]) { ok (0) } else { ok(1) } - - # HASH - case ({}) { ok (0) } else { ok (1) } - case ({a=>'a', 1=>1, 2=>0}) { ok ($_ eq 'a' || $_ eq '1') } - else { ok ($_ ne 'a' && $_ ne '1') } - - # SUB/BLOCK - case (sub{$_[0] eq 'a' }) { ok ($_ eq 'a') } - else { ok($_ ne 'a') } - case {$_[0] eq 'a'} { ok ($_ eq 'a') } else { ok($_ ne 'a') } - case {0} { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH - case {1} { ok (1) } else { ok (0) } # ; -> SUB, NOT HASH - } -} - - -# 3. ARRAY SWITCH - -my $iteration = 0; -for ([],[1,'a'],[2,'b']) -{ - switch ($_) { - $iteration++; - # SELF - case ($_) { ok(1) } - - # NUMERIC - case (1) { ok ($iteration==2) } else { ok ($iteration!=2) } - case (1.0) { ok ($iteration==2) } else { ok ($iteration!=2) } - - # STRING - case ('a') { ok ($iteration==2) } else { ok ($iteration!=2) } - case ('b') { ok ($iteration==3) } else { ok ($iteration!=3) } - case ('1') { ok ($iteration==2) } else { ok ($iteration!=2) } - - # ARRAY - case (['a',2]) { ok ($iteration>=2) } else { ok ($iteration<2) } - case ([1,'a']) { ok ($iteration==2) } else { ok($iteration!=2) } - case ([]) { ok (0) } else { ok(1) } - case ([7..100]) { ok (0) } else { ok(1) } - - # HASH - case ({}) { ok (0) } else { ok (1) } - case ({a=>'a', 1=>1, 2=>0}) { ok ($iteration==2) } - else { ok ($iteration!=2) } - - # SUB/BLOCK - case {scalar grep /a/, @_} { ok ($iteration==2) } - else { ok ($iteration!=2) } - case (sub {scalar grep /a/, @_ }) { ok ($iteration==2) } - else { ok ($iteration!=2) } - case {0} { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH - case {1} { ok (1) } else { ok (0) } # ; -> SUB, NOT HASH - } -} - - -# 4. HASH SWITCH - -$iteration = 0; -for ({},{a=>1,b=>0}) -{ - switch ($_) { - $iteration++; - - # SELF - case ($_) { ok(1) } else { ok(0) } - - # NUMERIC - case (1) { ok (0) } else { ok (1) } - case (1.0) { ok (0) } else { ok (1) } - - # STRING - case ('a') { ok ($iteration==2) } else { ok ($iteration!=2) } - case ('b') { ok (0) } else { ok (1) } - case ('c') { ok (0) } else { ok (1) } - - # ARRAY - case (['a',2]) { ok ($iteration==2) } - else { ok ($iteration!=2) } - case (['b','a']) { ok ($iteration==2) } - else { ok ($iteration!=2) } - case (['b','c']) { ok (0) } else { ok (1) } - case ([]) { ok (0) } else { ok(1) } - case ([7..100]) { ok (0) } else { ok(1) } - - # HASH - case ({}) { ok (0) } else { ok (1) } - case ({a=>'a', 1=>1, 2=>0}) { ok (0) } else { ok (1) } - - # SUB/BLOCK - case {$_[0]{a}} { ok ($iteration==2) } - else { ok ($iteration!=2) } - case (sub {$_[0]{a}}) { ok ($iteration==2) } - else { ok ($iteration!=2) } - case {0} { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH - case {1} { ok (1) } else { ok (0) } # ; -> SUB, NOT HASH - } -} - - -# 5. CODE SWITCH - -$iteration = 0; -for ( sub {1}, - sub { return 0 unless @_; - my ($data) = @_; - my $type = ref $data; - return $type eq 'HASH' && $data->{a} - || $type eq 'Regexp' && 'a' =~ /$data/ - || $type eq "" && $data eq '1'; - }, - sub {0} ) -{ - switch ($_) { - $iteration++; - # SELF - case ($_) { ok(1) } else { ok(0) } - - # NUMERIC - case (1) { ok ($iteration<=2) } else { ok ($iteration>2) } - case (1.0) { ok ($iteration<=2) } else { ok ($iteration>2) } - case (1.1) { ok ($iteration==1) } else { ok ($iteration!=1) } - - # STRING - case ('a') { ok ($iteration==1) } else { ok ($iteration!=1) } - case ('b') { ok ($iteration==1) } else { ok ($iteration!=1) } - case ('c') { ok ($iteration==1) } else { ok ($iteration!=1) } - case ('1') { ok ($iteration<=2) } else { ok ($iteration>2) } - - # ARRAY - case ([1, 'a']) { ok ($iteration<=2) } - else { ok ($iteration>2) } - case (['b','a']) { ok ($iteration==1) } - else { ok ($iteration!=1) } - case (['b','c']) { ok ($iteration==1) } - else { ok ($iteration!=1) } - case ([]) { ok ($iteration==1) } else { ok($iteration!=1) } - case ([7..100]) { ok ($iteration==1) } - else { ok($iteration!=1) } - - # HASH - case ({}) { ok ($iteration==1) } else { ok ($iteration!=1) } - case ({a=>'a', 1=>1, 2=>0}) { ok ($iteration<=2) } - else { ok ($iteration>2) } - - # SUB/BLOCK - case {$_[0]->{a}} { ok (0) } else { ok (1) } - case (sub {$_[0]{a}}) { ok (0) } else { ok (1) } - case {0} { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH - case {1} { ok (0) } else { ok (1) } # ; -> SUB, NOT HASH - } -} - - -# NESTED SWITCHES - -for my $count (1..3) -{ - switch ([9,"a",11]) { - case (qr/\d/) { - switch ($count) { - case (1) { ok($count==1) } - else { ok($count!=1) } - case ([5,6]) { ok(0) } else { ok(1) } - } - } - ok(1) case (11); - } -} diff --git a/t/lib/symbol.t b/t/lib/symbol.t deleted file mode 100755 index 03449a3ed7..0000000000 --- a/t/lib/symbol.t +++ /dev/null @@ -1,52 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..8\n"; - -BEGIN { $_ = 'foo'; } # because Symbol used to clobber $_ - -use Symbol; - -# First check $_ clobbering -print "not " if $_ ne 'foo'; -print "ok 1\n"; - - -# First test gensym() -$sym1 = gensym; -print "not " if ref($sym1) ne 'GLOB'; -print "ok 2\n"; - -$sym2 = gensym; - -print "not " if $sym1 eq $sym2; -print "ok 3\n"; - -ungensym $sym1; - -$sym1 = $sym2 = undef; - - -# Test qualify() -package foo; - -use Symbol qw(qualify); # must import into this package too - -qualify("x") eq "foo::x" or print "not "; -print "ok 4\n"; - -qualify("x", "FOO") eq "FOO::x" or print "not "; -print "ok 5\n"; - -qualify("BAR::x") eq "BAR::x" or print "not "; -print "ok 6\n"; - -qualify("STDOUT") eq "main::STDOUT" or print "not "; -print "ok 7\n"; - -qualify("ARGV", "FOO") eq "main::ARGV" or print "not "; -print "ok 8\n"; diff --git a/t/lib/syslfs.t b/t/lib/syslfs.t deleted file mode 100644 index 8d9769fded..0000000000 --- a/t/lib/syslfs.t +++ /dev/null @@ -1,267 +0,0 @@ -# NOTE: this file tests how large files (>2GB) work with raw system IO. -# stdio: open(), tell(), seek(), print(), read() is tested in t/op/lfs.t. -# If you modify/add tests here, remember to update also t/op/lfs.t. - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - # Don't bother if there are no quad offsets. - if ($Config{lseeksize} < 8) { - print "1..0 # Skip: no 64-bit file offsets\n"; - exit(0); - } - require Fcntl; import Fcntl qw(/^O_/ /^SEEK_/); -} - -use strict; - -$| = 1; - -our @s; -our $fail; - -sub zap { - close(BIG); - unlink("big"); - unlink("big1"); - unlink("big2"); -} - -sub bye { - zap(); - exit(0); -} - -my $explained; - -sub explain { - unless ($explained++) { - print <<EOM; -# -# If the lfs (large file support: large meaning larger than two -# gigabytes) tests are skipped or fail, it may mean either that your -# process (or process group) is not allowed to write large files -# (resource limits) or that the file system (the network filesystem?) -# you are running the tests on doesn't let your user/group have large -# files (quota) or the filesystem simply doesn't support large files. -# You may even need to reconfigure your kernel. (This is all very -# operating system and site-dependent.) -# -# Perl may still be able to support large files, once you have -# such a process, enough quota, and such a (file) system. -# It is just that the test failed now. -# -EOM - } - print "1..0 # Skip: @_\n" if @_; -} - -print "# checking whether we have sparse files...\n"; - -# Known have-nots. -if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') { - print "1..0 # Skip: no sparse files in $^O\n"; - bye(); -} - -# Known haves that have problems running this test -# (for example because they do not support sparse files, like UNICOS) -if ($^O eq 'unicos') { - print "1..0 # Skip: no sparse files in $^0, unable to test large files\n"; - bye(); -} - -# Then try heuristically to deduce whether we have sparse files. - -# We'll start off by creating a one megabyte file which has -# only three "true" bytes. If we have sparseness, we should -# consume less blocks than one megabyte (assuming nobody has -# one megabyte blocks...) - -sysopen(BIG, "big1", O_WRONLY|O_CREAT|O_TRUNC) or - do { warn "sysopen big1 failed: $!\n"; bye }; -sysseek(BIG, 1_000_000, SEEK_SET) or - do { warn "sysseek big1 failed: $!\n"; bye }; -syswrite(BIG, "big") or - do { warn "syswrite big1 failed; $!\n"; bye }; -close(BIG) or - do { warn "close big1 failed: $!\n"; bye }; - -my @s1 = stat("big1"); - -print "# s1 = @s1\n"; - -sysopen(BIG, "big2", O_WRONLY|O_CREAT|O_TRUNC) or - do { warn "sysopen big2 failed: $!\n"; bye }; -sysseek(BIG, 2_000_000, SEEK_SET) or - do { warn "sysseek big2 failed: $!\n"; bye }; -syswrite(BIG, "big") or - do { warn "syswrite big2 failed; $!\n"; bye }; -close(BIG) or - do { warn "close big2 failed: $!\n"; bye }; - -my @s2 = stat("big2"); - -print "# s2 = @s2\n"; - -zap(); - -unless ($s1[7] == 1_000_003 && $s2[7] == 2_000_003 && - $s1[11] == $s2[11] && $s1[12] == $s2[12]) { - print "1..0 # Skip: no sparse files?\n"; - bye; -} - -print "# we seem to have sparse files...\n"; - -# By now we better be sure that we do have sparse files: -# if we are not, the following will hog 5 gigabytes of disk. Ooops. -# This may fail by producing some signal; run in a subprocess first for safety - -$ENV{LC_ALL} = "C"; - -my $r = system '../perl', '-I../lib', '-e', <<'EOF'; -use Fcntl qw(/^O_/ /^SEEK_/); -sysopen(BIG, "big", O_WRONLY|O_CREAT|O_TRUNC) or die $!; -my $sysseek = sysseek(BIG, 5_000_000_000, SEEK_SET); -my $syswrite = syswrite(BIG, "big"); -exit 0; -EOF - -sysopen(BIG, "big", O_WRONLY|O_CREAT|O_TRUNC) or - do { warn "sysopen 'big' failed: $!\n"; bye }; -my $sysseek = sysseek(BIG, 5_000_000_000, SEEK_SET); -unless (! $r && defined $sysseek && $sysseek == 5_000_000_000) { - $sysseek = 'undef' unless defined $sysseek; - explain("seeking past 2GB failed: ", - $r ? 'signal '.($r & 0x7f) : "$! (sysseek returned $sysseek)"); - bye(); -} - -# The syswrite will fail if there are are filesize limitations (process or fs). -my $syswrite = syswrite(BIG, "big"); -print "# syswrite failed: $! (syswrite returned ", - defined $syswrite ? $syswrite : 'undef', ")\n" - unless defined $syswrite && $syswrite == 3; -my $close = close BIG; -print "# close failed: $!\n" unless $close; -unless($syswrite && $close) { - if ($! =~/too large/i) { - explain("writing past 2GB failed: process limits?"); - } elsif ($! =~ /quota/i) { - explain("filesystem quota limits?"); - } else { - explain("error: $!"); - } - bye(); -} - -@s = stat("big"); - -print "# @s\n"; - -unless ($s[7] == 5_000_000_003) { - explain("kernel/fs not configured to use large files?"); - bye(); -} - -sub fail () { - print "not "; - $fail++; -} - -sub offset ($$) { - my ($offset_will_be, $offset_want) = @_; - my $offset_is = eval $offset_will_be; - unless ($offset_is == $offset_want) { - print "# bad offset $offset_is, want $offset_want\n"; - my ($offset_func) = ($offset_will_be =~ /^(\w+)/); - if (unpack("L", pack("L", $offset_want)) == $offset_is) { - print "# 32-bit wraparound suspected in $offset_func() since\n"; - print "# $offset_want cast into 32 bits equals $offset_is.\n"; - } elsif ($offset_want - unpack("L", pack("L", $offset_want)) - 1 - == $offset_is) { - print "# 32-bit wraparound suspected in $offset_func() since\n"; - printf "# %s - unpack('L', pack('L', %s)) - 1 equals %s.\n", - $offset_want, - $offset_want, - $offset_is; - } - fail; - } -} - -print "1..17\n"; - -$fail = 0; - -fail unless $s[7] == 5_000_000_003; # exercizes pp_stat -print "ok 1\n"; - -fail unless -s "big" == 5_000_000_003; # exercizes pp_ftsize -print "ok 2\n"; - -fail unless -e "big"; -print "ok 3\n"; - -fail unless -f "big"; -print "ok 4\n"; - -sysopen(BIG, "big", O_RDONLY) or do { warn "sysopen failed: $!\n"; bye }; - -offset('sysseek(BIG, 4_500_000_000, SEEK_SET)', 4_500_000_000); -print "ok 5\n"; - -offset('sysseek(BIG, 0, SEEK_CUR)', 4_500_000_000); -print "ok 6\n"; - -offset('sysseek(BIG, 1, SEEK_CUR)', 4_500_000_001); -print "ok 7\n"; - -offset('sysseek(BIG, 0, SEEK_CUR)', 4_500_000_001); -print "ok 8\n"; - -offset('sysseek(BIG, -1, SEEK_CUR)', 4_500_000_000); -print "ok 9\n"; - -offset('sysseek(BIG, 0, SEEK_CUR)', 4_500_000_000); -print "ok 10\n"; - -offset('sysseek(BIG, -3, SEEK_END)', 5_000_000_000); -print "ok 11\n"; - -offset('sysseek(BIG, 0, SEEK_CUR)', 5_000_000_000); -print "ok 12\n"; - -my $big; - -fail unless sysread(BIG, $big, 3) == 3; -print "ok 13\n"; - -fail unless $big eq "big"; -print "ok 14\n"; - -# 705_032_704 = (I32)5_000_000_000 -# See that we don't have "big" in the 705_... spot: -# that would mean that we have a wraparound. -fail unless sysseek(BIG, 705_032_704, SEEK_SET); -print "ok 15\n"; - -my $zero; - -fail unless read(BIG, $zero, 3) == 3; -print "ok 16\n"; - -fail unless $zero eq "\0\0\0"; -print "ok 17\n"; - -explain() if $fail; - -bye(); # does the necessary cleanup - -END { - unlink "big"; # be paranoid about leaving 5 gig files lying around -} - -# eof diff --git a/t/lib/syslog.t b/t/lib/syslog.t deleted file mode 100755 index 801e882508..0000000000 --- a/t/lib/syslog.t +++ /dev/null @@ -1,72 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bSyslog\b/) { - print "1..0 # Skip: Sys::Syslog was not built\n"; - exit 0; - } - - require Socket; - - # This code inspired by Sys::Syslog::connect(): - require Sys::Hostname; - my ($host_uniq) = Sys::Hostname::hostname(); - my ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; - - if (! defined Socket::inet_aton($host)) { - print "1..0 # Skip: Can't lookup $host\n"; - exit 0; - } -} - -BEGIN { - eval {require Sys::Syslog} or do { - if ($@ =~ /Your vendor has not/) { - print "1..0 # Skipped: missing macros\n"; - exit 0; - } - } -} - -use Sys::Syslog qw(:DEFAULT setlogsock); - -# Test this to 1 if your syslog accepts udp connections. -# Most don't (or at least shouldn't) -my $Test_Syslog_INET = 0; - -print "1..6\n"; - -if (Sys::Syslog::_PATH_LOG()) { - if (-e Sys::Syslog::_PATH_LOG()) { - print defined(eval { setlogsock('unix') }) ? "ok 1\n" : "not ok 1\n"; - print defined(eval { openlog('perl', 'ndelay', 'local0') }) ? "ok 2\n" : "not ok 2\n"; - print defined(eval { syslog('info', 'test') }) ? "ok 3\n" : "not ok 3\n"; - } - else { - for (1..3) { - print - "ok $_ # skipping, file ", - Sys::Syslog::_PATH_LOG(), - " does not exist\n"; - } - } -} -else { - for (1..3) { print "ok $_ # skipping, _PATH_LOG unavailable\n" } -} - -if( $Test_Syslog_INET ) { - print defined(eval { setlogsock('inet') }) ? "ok 4\n" - : "not ok 4\n"; - print defined(eval { openlog('perl', 'ndelay', 'local0') }) ? "ok 5\n" - : "not ok 5\n"; - print defined(eval { syslog('info', 'test') }) ? "ok 6\n" - : "not ok 6\n"; -} -else { - print "ok $_ # skipped(assuming syslog doesn't accept inet connections)\n" - foreach (4..6); -} diff --git a/t/lib/tb-genxt.t b/t/lib/tb-genxt.t deleted file mode 100644 index 6889653841..0000000000 --- a/t/lib/tb-genxt.t +++ /dev/null @@ -1,104 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -# Before `make install' is performed this script should be runnable with -# `make test'. After `make install' it should work as `perl test.pl' - -######################### We start with some black magic to print on failure. - -# Change 1..1 below to 1..last_test_to_print . -# (It may become useful if the test is moved to ./t subdirectory.) - -BEGIN { $| = 1; print "1..35\n"; } -END {print "not ok 1\n" unless $loaded;} -use Text::Balanced qw ( gen_extract_tagged ); -$loaded = 1; -print "ok 1\n"; -$count=2; -use vars qw( $DEBUG ); -sub debug { print "\t>>>",@_ if $DEBUG } - -######################### End of black magic. - - -$cmd = "print"; -$neg = 0; -while (defined($str = <DATA>)) -{ - chomp $str; - $str =~ s/\\n/\n/g; - if ($str =~ s/\A# USING://) - { - $neg = 0; - eval{local$^W;*f = eval $str || die}; - next; - } - elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } - elsif (!$str || $str =~ /\A#/) { $neg = 0; next } - $str =~ s/\\n/\n/g; - debug "\tUsing: $cmd\n"; - debug "\t on: [$str]\n"; - - my @res; - $var = eval { @res = f($str) }; - debug "\t list got: [" . join("|",@res) . "]\n"; - debug "\t list left: [$str]\n"; - print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; - - pos $str = 0; - $var = eval { scalar f($str) }; - $var = "<undef>" unless defined $var; - debug "\t scalar got: [$var]\n"; - debug "\t scalar left: [$str]\n"; - print "not " if ($str =~ '\A;')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; -} - -__DATA__ - -# USING: gen_extract_tagged(qr/<[A-Z]+>/,undef, undef, {ignore=>["<BR>"]}); - <A>aaa<B>bbb<BR>ccc</B>ddd</A>; - -# USING: gen_extract_tagged("BEGIN","END"); - BEGIN at the BEGIN keyword and END at the END; - BEGIN at the beginning and end at the END; - -# USING: gen_extract_tagged(undef,undef,undef,{ignore=>["<[^>]*/>"]}); - <A>aaa<B>bbb<BR/>ccc</B>ddd</A>; - -# USING: gen_extract_tagged(";","-",undef,{reject=>[";"],fail=>"MAX"}); - ; at the ;-) keyword - -# USING: gen_extract_tagged("<[A-Z]+>",undef, undef, {ignore=>["<BR>"]}); - <A>aaa<B>bbb<BR>ccc</B>ddd</A>; - -# THESE SHOULD FAIL - BEGIN at the beginning and end at the end; - BEGIN at the BEGIN keyword and END at the end; - -# TEST EXTRACTION OF TAGGED STRINGS -# USING: gen_extract_tagged("BEGIN","END",undef,{reject=>["BEGIN","END"]}); -# THESE SHOULD FAIL - BEGIN at the BEGIN keyword and END at the end; - -# USING: gen_extract_tagged(";","-",undef,{reject=>[";"],fail=>"PARA"}); - ; at the ;-) keyword - - -# USING: gen_extract_tagged(); - <A>some text</A>; - <B>some text<A>other text</A></B>; - <A>some text<A>other text</A></A>; - <A HREF="#section2">some text</A>; - -# THESE SHOULD FAIL - <A>some text - <A>some text<A>other text</A>; - <B>some text<A>other text</B>; diff --git a/t/lib/tb-xbrak.t b/t/lib/tb-xbrak.t deleted file mode 100644 index 5a8e5249a8..0000000000 --- a/t/lib/tb-xbrak.t +++ /dev/null @@ -1,81 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -# Before `make install' is performed this script should be runnable with -# `make test'. After `make install' it should work as `perl test.pl' - -######################### We start with some black magic to print on failure. - -# Change 1..1 below to 1..last_test_to_print . -# (It may become useful if the test is moved to ./t subdirectory.) - -BEGIN { $| = 1; print "1..19\n"; } -END {print "not ok 1\n" unless $loaded;} -use Text::Balanced qw ( extract_bracketed ); -$loaded = 1; -print "ok 1\n"; -$count=2; -use vars qw( $DEBUG ); -sub debug { print "\t>>>",@_ if $DEBUG } - -######################### End of black magic. - - -$cmd = "print"; -$neg = 0; -while (defined($str = <DATA>)) -{ - chomp $str; - if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } - elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } - elsif (!$str || $str =~ /\A#/) { $neg = 0; next } - $str =~ s/\\n/\n/g; - debug "\tUsing: $cmd\n"; - debug "\t on: [$str]\n"; - - $var = eval "() = $cmd"; - debug "\t list got: [$var]\n"; - debug "\t list left: [$str]\n"; - print "not " if (substr($str,pos($str),1) eq ';')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; - - pos $str = 0; - $var = eval $cmd; - $var = "<undef>" unless defined $var; - debug "\t scalar got: [$var]\n"; - debug "\t scalar left: [$str]\n"; - print "not " if ($str =~ '\A;')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; -} - -__DATA__ - -# USING: extract_bracketed($str); -{a nested { and } are okay as are () and <> pairs and escaped \}'s }; -{a nested\n{ and } are okay as are\n() and <> pairs and escaped \}'s }; - -# USING: extract_bracketed($str,'{}'); -{a nested { and } are okay as are unbalanced ( and < pairs and escaped \}'s }; - -# THESE SHOULD FAIL -{an unmatched nested { isn't okay, nor are ( and < }; -{an unbalanced nested [ even with } and ] to match them; - - -# USING: extract_bracketed($str,'<"`q>'); -<a q{uoted} ">" unbalanced right bracket of /(q>)/ either sort (`>>>""">>>>`) is okay >; - -# USING: extract_bracketed($str,'<">'); -<a quoted ">" unbalanced right bracket is okay >; - -# USING: extract_bracketed($str,'<"`>'); -<a quoted ">" unbalanced right bracket of either sort (`>>>""">>>>`) is okay >; - -# THIS SHOULD FAIL -<a misquoted '>' unbalanced right bracket is bad >; diff --git a/t/lib/tb-xcode.t b/t/lib/tb-xcode.t deleted file mode 100644 index 00be51e542..0000000000 --- a/t/lib/tb-xcode.t +++ /dev/null @@ -1,94 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -# Before `make install' is performed this script should be runnable with -# `make test'. After `make install' it should work as `perl test.pl' - -######################### We start with some black magic to print on failure. - -# Change 1..1 below to 1..last_test_to_print . -# (It may become useful if the test is moved to ./t subdirectory.) - -BEGIN { $| = 1; print "1..37\n"; } -END {print "not ok 1\n" unless $loaded;} -use Text::Balanced qw ( extract_codeblock ); -$loaded = 1; -print "ok 1\n"; -$count=2; -use vars qw( $DEBUG ); -sub debug { print "\t>>>",@_ if $DEBUG } - -######################### End of black magic. - - -$cmd = "print"; -$neg = 0; -while (defined($str = <DATA>)) -{ - chomp $str; - if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } - elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } - elsif (!$str || $str =~ /\A#/) { $neg = 0; next } - $str =~ s/\\n/\n/g; - debug "\tUsing: $cmd\n"; - debug "\t on: [$str]\n"; - - my @res; - $var = eval "\@res = $cmd"; - debug "\t Failed: $@ at " . $@+0 .")" if $@; - debug "\t list got: [" . join("|",@res) . "]\n"; - debug "\t list left: [$str]\n"; - print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; - print "ok ", $count++; - print "\n"; - - pos $str = 0; - $var = eval $cmd; - $var = "<undef>" unless defined $var; - debug "\t scalar got: [$var]\n"; - debug "\t scalar left: [$str]\n"; - print "not " if ($str =~ '\A;')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; -} - -__DATA__ - -# USING: extract_codeblock($str,'<>'); -< %x = ( try => "this") >; -< %x = () >; -< %x = ( $try->{this}, "too") >; -< %'x = ( $try->{this}, "too") >; -< %'x'y = ( $try->{this}, "too") >; -< %::x::y = ( $try->{this}, "too") >; - -# THIS SHOULD FAIL -< %x = do { $try > 10 } >; - -# USING: extract_codeblock($str); - -{ $a = /\}/; }; -{ sub { $_[0] /= $_[1] } }; # / here -{ 1; }; -{ $a = 1; }; - - -# USING: extract_codeblock($str,undef,'=*'); -========{$a=1}; - -# USING: extract_codeblock($str,'{}<>'); -< %x = do { $try > 10 } >; - -# USING: extract_codeblock($str,'{}',undef,'<>'); -< %x = do { $try > 10 } >; - -# USING: extract_codeblock($str,'{}'); -{ $a = $b; # what's this doing here? \n };' -{ $a = $b; \n $a =~ /$b/; \n @a = map /\s/ @b }; - -# THIS SHOULD FAIL -{ $a = $b; # what's this doing here? };' -{ $a = $b; # what's this doing here? ;' diff --git a/t/lib/tb-xdeli.t b/t/lib/tb-xdeli.t deleted file mode 100644 index 7e5b06beca..0000000000 --- a/t/lib/tb-xdeli.t +++ /dev/null @@ -1,95 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -# Before `make install' is performed this script should be runnable with -# `make test'. After `make install' it should work as `perl test.pl' - -######################### We start with some black magic to print on failure. - -# Change 1..1 below to 1..last_test_to_print . -# (It may become useful if the test is moved to ./t subdirectory.) - -BEGIN { $| = 1; print "1..45\n"; } -END {print "not ok 1\n" unless $loaded;} -use Text::Balanced qw ( extract_delimited ); -$loaded = 1; -print "ok 1\n"; -$count=2; -use vars qw( $DEBUG ); -sub debug { print "\t>>>",@_ if $DEBUG } - -######################### End of black magic. - - -$cmd = "print"; -$neg = 0; -while (defined($str = <DATA>)) -{ - chomp $str; - if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } - elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } - elsif (!$str || $str =~ /\A#/) { $neg = 0; next } - $str =~ s/\\n/\n/g; - debug "\tUsing: $cmd\n"; - debug "\t on: [$str]\n"; - - $var = eval "() = $cmd"; - debug "\t list got: [$var]\n"; - debug "\t list left: [$str]\n"; - print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; - - pos $str = 0; - $var = eval $cmd; - $var = "<undef>" unless defined $var; - debug "\t scalar got: [$var]\n"; - debug "\t scalar left: [$str]\n"; - print "not " if ($str =~ '\A;')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; -} - -__DATA__ -# USING: extract_delimited($str,'/#$',undef,'/#$'); -/a/; -/a///; -#b#; -#b###; -$c$; -$c$$$; - -# TEST EXTRACTION OF DELIMITED TEXT WITH ESCAPES -# USING: extract_delimited($str,'/#$',undef,'\\'); -/a/; -/a\//; -#b#; -#b\##; -$c$; -$c\$$; - -# TEST EXTRACTION OF DELIMITED TEXT -# USING: extract_delimited($str); -'a'; -"b"; -`c`; -'a\''; -'a\\'; -'\\a'; -"a\\"; -"\\a"; -"b\'\"\'"; -`c '\`abc\`'`; - -# TEST EXTRACTION OF DELIMITED TEXT -# USING: extract_delimited($str,'/#$','-->'); --->/a/; --->#b#; --->$c$; - -# THIS SHOULD FAIL -$c$; diff --git a/t/lib/tb-xmult.t b/t/lib/tb-xmult.t deleted file mode 100644 index 31dd7d4051..0000000000 --- a/t/lib/tb-xmult.t +++ /dev/null @@ -1,316 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -# Before `make install' is performed this script should be runnable with -# `make test'. After `make install' it should work as `perl test.pl' - -######################### We start with some black magic to print on failure. - -# Change 1..1 below to 1..last_test_to_print . -# (It may become useful if the test is moved to ./t subdirectory.) - -BEGIN { $| = 1; print "1..85\n"; } -END {print "not ok 1\n" unless $loaded;} -use Text::Balanced qw ( :ALL ); -$loaded = 1; -print "ok 1\n"; -$count=2; -use vars qw( $DEBUG ); -sub debug { print "\t>>>",@_ if $DEBUG } - -######################### End of black magic. - -sub expect -{ - local $^W; - my ($l1, $l2) = @_; - - if (@$l1 != @$l2) - { - print "\@l1: ", join(", ", @$l1), "\n"; - print "\@l2: ", join(", ", @$l2), "\n"; - print "not "; - } - else - { - for (my $i = 0; $i < @$l1; $i++) - { - if ($l1->[$i] ne $l2->[$i]) - { - print "field $i: '$l1->[$i]' ne '$l2->[$i]'\n"; - print "not "; - last; - } - } - } - - print "ok $count\n"; - $count++; -} - -sub divide -{ - my ($text, @index) = @_; - my @bits = (); - unshift @index, 0; - push @index, length($text); - for ( my $i= 0; $i < $#index; $i++) - { - push @bits, substr($text, $index[$i], $index[$i+1]-$index[$i]); - } - pop @bits; - return @bits; - -} - - -$stdtext1 = q{$var = do {"val" && $val;};}; - -# TESTS 2-4 -$text = $stdtext1; -expect [ extract_multiple($text,undef,1) ], - [ divide $stdtext1 => 4 ]; - -expect [ pos $text], [ 4 ]; -expect [ $text ], [ $stdtext1 ]; - -# TESTS 5-7 -$text = $stdtext1; -expect [ scalar extract_multiple($text,undef,1) ], - [ divide $stdtext1 => 4 ]; - -expect [ pos $text], [ 0 ]; -expect [ $text ], [ substr($stdtext1,4) ]; - - -# TESTS 8-10 -$text = $stdtext1; -expect [ extract_multiple($text,undef,2) ], - [ divide($stdtext1 => 4, 10) ]; - -expect [ pos $text], [ 10 ]; -expect [ $text ], [ $stdtext1 ]; - -# TESTS 11-13 -$text = $stdtext1; -expect [ eval{local$^W;scalar extract_multiple($text,undef,2)} ], - [ substr($stdtext1,0,4) ]; - -expect [ pos $text], [ 0 ]; -expect [ $text ], [ substr($stdtext1,4) ]; - - -# TESTS 14-16 -$text = $stdtext1; -expect [ extract_multiple($text,undef,3) ], - [ divide($stdtext1 => 4, 10, 26) ]; - -expect [ pos $text], [ 26 ]; -expect [ $text ], [ $stdtext1 ]; - -# TESTS 17-19 -$text = $stdtext1; -expect [ eval{local$^W;scalar extract_multiple($text,undef,3)} ], - [ substr($stdtext1,0,4) ]; - -expect [ pos $text], [ 0 ]; -expect [ $text ], [ substr($stdtext1,4) ]; - - -# TESTS 20-22 -$text = $stdtext1; -expect [ extract_multiple($text,undef,4) ], - [ divide($stdtext1 => 4, 10, 26, 27) ]; - -expect [ pos $text], [ 27 ]; -expect [ $text ], [ $stdtext1 ]; - -# TESTS 23-25 -$text = $stdtext1; -expect [ eval{local$^W;scalar extract_multiple($text,undef,4)} ], - [ substr($stdtext1,0,4) ]; - -expect [ pos $text], [ 0 ]; -expect [ $text ], [ substr($stdtext1,4) ]; - - -# TESTS 26-28 -$text = $stdtext1; -expect [ extract_multiple($text,undef,5) ], - [ divide($stdtext1 => 4, 10, 26, 27) ]; - -expect [ pos $text], [ 27 ]; -expect [ $text ], [ $stdtext1 ]; - - -# TESTS 29-31 -$text = $stdtext1; -expect [ eval{local$^W;scalar extract_multiple($text,undef,5)} ], - [ substr($stdtext1,0,4) ]; - -expect [ pos $text], [ 0 ]; -expect [ $text ], [ substr($stdtext1,4) ]; - - - -# TESTS 32-34 -$stdtext2 = q{$var = "val" && (1,2,3);}; - -$text = $stdtext2; -expect [ extract_multiple($text) ], - [ divide($stdtext2 => 4, 7, 12, 24) ]; - -expect [ pos $text], [ 24 ]; -expect [ $text ], [ $stdtext2 ]; - -# TESTS 35-37 -$text = $stdtext2; -expect [ scalar extract_multiple($text) ], - [ substr($stdtext2,0,4) ]; - -expect [ pos $text], [ 0 ]; -expect [ $text ], [ substr($stdtext2,4) ]; - - -# TESTS 38-40 -$text = $stdtext2; -expect [ extract_multiple($text,[\&extract_bracketed]) ], - [ substr($stdtext2,0,15), substr($stdtext2,16,7), substr($stdtext2,23) ]; - -expect [ pos $text], [ 24 ]; -expect [ $text ], [ $stdtext2 ]; - -# TESTS 41-43 -$text = $stdtext2; -expect [ scalar extract_multiple($text,[\&extract_bracketed]) ], - [ substr($stdtext2,0,15) ]; - -expect [ pos $text], [ 0 ]; -expect [ $text ], [ substr($stdtext2,15) ]; - - -# TESTS 44-46 -$text = $stdtext2; -expect [ extract_multiple($text,[\&extract_variable]) ], - [ substr($stdtext2,0,4), substr($stdtext2,4) ]; - -expect [ pos $text], [ length($text) ]; -expect [ $text ], [ $stdtext2 ]; - -# TESTS 47-49 -$text = $stdtext2; -expect [ scalar extract_multiple($text,[\&extract_variable]) ], - [ substr($stdtext2,0,4) ]; - -expect [ pos $text], [ 0 ]; -expect [ $text ], [ substr($stdtext2,4) ]; - - -# TESTS 50-52 -$text = $stdtext2; -expect [ extract_multiple($text,[\&extract_quotelike]) ], - [ substr($stdtext2,0,6), substr($stdtext2,7,5), substr($stdtext2,12) ]; - -expect [ pos $text], [ length($text) ]; -expect [ $text ], [ $stdtext2 ]; - -# TESTS 53-55 -$text = $stdtext2; -expect [ scalar extract_multiple($text,[\&extract_quotelike]) ], - [ substr($stdtext2,0,6) ]; - -expect [ pos $text], [ 0 ]; -expect [ $text ], [ substr($stdtext2,6) ]; - - -# TESTS 56-58 -$text = $stdtext2; -expect [ extract_multiple($text,[\&extract_quotelike],2,1) ], - [ substr($stdtext2,7,5) ]; - -expect [ pos $text], [ 23 ]; -expect [ $text ], [ $stdtext2 ]; - -# TESTS 59-61 -$text = $stdtext2; -expect [ eval{local$^W;scalar extract_multiple($text,[\&extract_quotelike],2,1)} ], - [ substr($stdtext2,7,5) ]; - -expect [ pos $text], [ 6 ]; -expect [ $text ], [ substr($stdtext2,0,6). substr($stdtext2,12) ]; - - -# TESTS 62-64 -$text = $stdtext2; -expect [ extract_multiple($text,[\&extract_quotelike],1,1) ], - [ substr($stdtext2,7,5) ]; - -expect [ pos $text], [ 12 ]; -expect [ $text ], [ $stdtext2 ]; - -# TESTS 65-67 -$text = $stdtext2; -expect [ scalar extract_multiple($text,[\&extract_quotelike],1,1) ], - [ substr($stdtext2,7,5) ]; - -expect [ pos $text], [ 6 ]; -expect [ $text ], [ substr($stdtext2,0,6). substr($stdtext2,12) ]; - -# TESTS 68-70 -my $stdtext3 = "a,b,c"; - -$_ = $stdtext3; -expect [ extract_multiple(undef, [ sub { /\G[a-z]/gc && $& } ]) ], - [ divide($stdtext3 => 1,2,3,4,5) ]; - -expect [ pos ], [ 5 ]; -expect [ $_ ], [ $stdtext3 ]; - -# TESTS 71-73 - -$_ = $stdtext3; -expect [ scalar extract_multiple(undef, [ sub { /\G[a-z]/gc && $& } ]) ], - [ divide($stdtext3 => 1) ]; - -expect [ pos ], [ 0 ]; -expect [ $_ ], [ substr($stdtext3,1) ]; - - -# TESTS 74-76 - -$_ = $stdtext3; -expect [ extract_multiple(undef, [ qr/\G[a-z]/ ]) ], - [ divide($stdtext3 => 1,2,3,4,5) ]; - -expect [ pos ], [ 5 ]; -expect [ $_ ], [ $stdtext3 ]; - -# TESTS 77-79 - -$_ = $stdtext3; -expect [ scalar extract_multiple(undef, [ qr/\G[a-z]/ ]) ], - [ divide($stdtext3 => 1) ]; - -expect [ pos ], [ 0 ]; -expect [ $_ ], [ substr($stdtext3,1) ]; - - -# TESTS 80-82 - -$_ = $stdtext3; -expect [ extract_multiple(undef, [ q/([a-z]),?/ ]) ], - [ qw(a b c) ]; - -expect [ pos ], [ 5 ]; -expect [ $_ ], [ $stdtext3 ]; - -# TESTS 83-85 - -$_ = $stdtext3; -expect [ scalar extract_multiple(undef, [ q/([a-z]),?/ ]) ], - [ divide($stdtext3 => 1) ]; - -expect [ pos ], [ 0 ]; -expect [ $_ ], [ substr($stdtext3,2) ]; diff --git a/t/lib/tb-xquot.t b/t/lib/tb-xquot.t deleted file mode 100644 index 567e0a54b8..0000000000 --- a/t/lib/tb-xquot.t +++ /dev/null @@ -1,118 +0,0 @@ -#!./perl -ws - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -# Before `make install' is performed this script should be runnable with -# `make test'. After `make install' it should work as `perl test.pl' - -######################### We start with some black magic to print on failure. - -# Change 1..1 below to 1..last_test_to_print . -# (It may become useful if the test is moved to ./t subdirectory.) - -BEGIN { $| = 1; print "1..89\n"; } -END {print "not ok 1\n" unless $loaded;} -use Text::Balanced qw ( extract_quotelike ); -$loaded = 1; -print "ok 1\n"; -$count=2; -use vars qw( $DEBUG ); -# $DEBUG=1; -sub debug { print "\t>>>",@_ if $DEBUG } - -######################### End of black magic. - - -$cmd = "print"; -$neg = 0; -while (defined($str = <DATA>)) -{ - chomp $str; - if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } - elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } - elsif (!$str || $str =~ /\A#/) { $neg = 0; next } - debug "\tUsing: $cmd\n"; - debug "\t on: [$str]\n"; - $str =~ s/\\n/\n/g; - my $orig = $str; - - my @res; - eval qq{\@res = $cmd; }; - debug "\t got:\n" . join "", map { $res[$_]=~s/\n/\\n/g; "\t\t\t$_: [$res[$_]]\n"} (0..$#res); - debug "\t left: " . (map { s/\n/\\n/g; "[$_]\n" } my $cpy1 = $str)[0]; - debug "\t pos: " . (map { s/\n/\\n/g; "[$_]\n" } my $cpy2 = substr($str,pos($str)))[0] . "...]\n"; - print "not " if (substr($str,pos($str),1) eq ';')==$neg; - print "ok ", $count++; - print "\n"; - - $str = $orig; - debug "\tUsing: scalar $cmd\n"; - debug "\t on: [$str]\n"; - $var = eval $cmd; - print " ($@)" if $@ && $DEBUG; - $var = "<undef>" unless defined $var; - debug "\t scalar got: " . (map { s/\n/\\n/g; "[$_]\n" } $var)[0]; - debug "\t scalar left: " . (map { s/\n/\\n/g; "[$_]\n" } $str)[0]; - print "not " if ($str =~ '\A;')==$neg; - print "ok ", $count++; - print "\n"; -} - -__DATA__ - -# USING: extract_quotelike($str); -''; -""; -"a"; -'b'; -`cc`; - - -<<EOHERE; done();\nline1\nline2\nEOHERE\n; next; - <<EOHERE; done();\nline1\nline2\nEOHERE\n; next; -<<"EOHERE"; done()\nline1\nline2\nEOHERE\n and next -<<`EOHERE`; done()\nline1\nline2\nEOHERE\n and next -<<'EOHERE'; done()\nline1\n'line2'\nEOHERE\n and next -<<'EOHERE;'; done()\nline1\nline2\nEOHERE;\n and next -<<" EOHERE"; done() \nline1\nline2\n EOHERE\nand next -<<""; done()\nline1\nline2\n\n and next -<<; done()\nline1\nline2\n\n and next - - -"this is a nested $var[$x] {"; -/a/gci; -m/a/gci; - -q(d); -qq(e); -qx(f); -qr(g); -qw(h i j); -q{d}; -qq{e}; -qx{f}; -qr{g}; -qq{a nested { and } are okay as are () and <> pairs and escaped \}'s }; -q/slash/; -q # slash #; -qr qw qx; - -s/x/y/; -s/x/y/cgimsox; -s{a}{b}; -s{a}\n {b}; -s(a){b}; -s(a)/b/; -s/'/\\'/g; -tr/x/y/; -y/x/y/; - -# THESE SHOULD FAIL -s<$self->{pat}>{$self->{sub}}; # CAN'T HANDLE '>' in '->' -s-$self->{pap}-$self->{sub}-; # CAN'T HANDLE '-' in '->' -<<EOHERE; done();\nline1\nline2\nEOHERE;\n; next; # RDEL HAS NO ';' -<<'EOHERE'; done();\nline1\nline2\nEOHERE;\n; next; # RDEF HAS NO ';' - << EOTHERE; done();\nline1\nline2\n EOTHERE\n; next; # RDEL IS "" (!) diff --git a/t/lib/tb-xtagg.t b/t/lib/tb-xtagg.t deleted file mode 100644 index c883181c24..0000000000 --- a/t/lib/tb-xtagg.t +++ /dev/null @@ -1,118 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -# Before `make install' is performed this script should be runnable with -# `make test'. After `make install' it should work as `perl test.pl' - -######################### We start with some black magic to print on failure. - -# Change 1..1 below to 1..last_test_to_print . -# (It may become useful if the test is moved to ./t subdirectory.) - -BEGIN { $| = 1; print "1..53\n"; } -END {print "not ok 1\n" unless $loaded;} -use Text::Balanced qw ( extract_tagged gen_extract_tagged ); -$loaded = 1; -print "ok 1\n"; -$count=2; -use vars qw( $DEBUG ); -sub debug { print "\t>>>",@_ if $DEBUG } - -######################### End of black magic. - - -$cmd = "print"; -$neg = 0; -while (defined($str = <DATA>)) -{ - chomp $str; - if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } - elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } - elsif (!$str || $str =~ /\A#/) { $neg = 0; next } - $str =~ s/\\n/\n/g; - debug "\tUsing: $cmd\n"; - debug "\t on: [$str]\n"; - - my @res; - $var = eval "\@res = $cmd"; - debug "\t list got: [" . join("|",@res) . "]\n"; - debug "\t list left: [$str]\n"; - print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; - - pos $str = 0; - $var = eval $cmd; - $var = "<undef>" unless defined $var; - debug "\t scalar got: [$var]\n"; - debug "\t scalar left: [$str]\n"; - print "not " if ($str =~ '\A;')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; -} - -__DATA__ -# USING: gen_extract_tagged("BEGIN([A-Z]+)",'END$1',"(?s).*?(?=BEGIN)")->($str); - ignore\n this and then BEGINHERE at the ENDHERE; - ignore\n this and then BEGINTHIS at the ENDTHIS; - -# USING: extract_tagged($str,"BEGIN([A-Z]+)",'END$1',"(?s).*?(?=BEGIN)"); - ignore\n this and then BEGINHERE at the ENDHERE; - ignore\n this and then BEGINTHIS at the ENDTHIS; - -# USING: extract_tagged($str,"BEGIN([A-Z]+)",'END$1',"(?s).*?(?=BEGIN)"); - ignore\n this and then BEGINHERE at the ENDHERE; - ignore\n this and then BEGINTHIS at the ENDTHIS; - -# THIS SHOULD FAIL - ignore\n this and then BEGINTHIS at the ENDTHAT; - -# USING: extract_tagged($str,"BEGIN","END","(?s).*?(?=BEGIN)"); - ignore\n this and then BEGIN at the END; - -# USING: extract_tagged($str); - <A-1 HREF="#section2">some text</A-1>; - -# USING: extract_tagged($str,qr/<[A-Z]+>/,undef, undef, {ignore=>["<BR>"]}); - <A>aaa<B>bbb<BR>ccc</B>ddd</A>; - -# USING: extract_tagged($str,"BEGIN","END"); - BEGIN at the BEGIN keyword and END at the END; - BEGIN at the beginning and end at the END; - -# USING: extract_tagged($str,undef,undef,undef,{ignore=>["<[^>]*/>"]}); - <A>aaa<B>bbb<BR/>ccc</B>ddd</A>; - -# USING: extract_tagged($str,";","-",undef,{reject=>[";"],fail=>"MAX"}); - ; at the ;-) keyword - -# USING: extract_tagged($str,"<[A-Z]+>",undef, undef, {ignore=>["<BR>"]}); - <A>aaa<B>bbb<BR>ccc</B>ddd</A>; - -# THESE SHOULD FAIL - BEGIN at the beginning and end at the end; - BEGIN at the BEGIN keyword and END at the end; - -# TEST EXTRACTION OF TAGGED STRINGS -# USING: extract_tagged($str,"BEGIN","END",undef,{reject=>["BEGIN","END"]}); -# THESE SHOULD FAIL - BEGIN at the BEGIN keyword and END at the end; - -# USING: extract_tagged($str,";","-",undef,{reject=>[";"],fail=>"PARA"}); - ; at the ;-) keyword - - -# USING: extract_tagged($str); - <A>some text</A>; - <B>some text<A>other text</A></B>; - <A>some text<A>other text</A></A>; - <A HREF="#section2">some text</A>; - -# THESE SHOULD FAIL - <A>some text - <A>some text<A>other text</A>; - <B>some text<A>other text</B>; diff --git a/t/lib/tb-xvari.t b/t/lib/tb-xvari.t deleted file mode 100644 index dd35b9c032..0000000000 --- a/t/lib/tb-xvari.t +++ /dev/null @@ -1,107 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -# Before `make install' is performed this script should be runnable with -# `make test'. After `make install' it should work as `perl test.pl' - -######################### We start with some black magic to print on failure. - -# Change 1..1 below to 1..last_test_to_print . -# (It may become useful if the test is moved to ./t subdirectory.) - -BEGIN { $| = 1; print "1..81\n"; } -END {print "not ok 1\n" unless $loaded;} -use Text::Balanced qw ( extract_variable ); -$loaded = 1; -print "ok 1\n"; -$count=2; -use vars qw( $DEBUG ); -sub debug { print "\t>>>",@_ if $DEBUG } - -######################### End of black magic. - - -$cmd = "print"; -$neg = 0; -while (defined($str = <DATA>)) -{ - chomp $str; - if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } - elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } - elsif (!$str || $str =~ /\A#/) { $neg = 0; next } - $str =~ s/\\n/\n/g; - debug "\tUsing: $cmd\n"; - debug "\t on: [$str]\n"; - - my @res; - $var = eval "\@res = $cmd"; - debug "\t list got: [" . join("|",@res) . "]\n"; - debug "\t list left: [$str]\n"; - print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; - - pos $str = 0; - $var = eval $cmd; - $var = "<undef>" unless defined $var; - debug "\t scalar got: [$var]\n"; - debug "\t scalar left: [$str]\n"; - print "not " if ($str =~ '\A;')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; -} - -__DATA__ - -# USING: extract_variable($str); -# THESE SHOULD FAIL -$a->; -$a (1..3) { print $a }; - -# USING: extract_variable($str); -*var; -*$var; -*{var}; -*{$var}; -*var{cat}; -\&var; -\&mod::var; -\&mod'var; -$a; -$_; -$a[1]; -$_[1]; -$a{cat}; -$_{cat}; -$a->[1]; -$a->{"cat"}[1]; -@$listref; -@{$listref}; -$obj->nextval; -$obj->_nextval; -$obj->next_val_; -@{$obj->nextval}; -@{$obj->nextval($cat,$dog)->{new}}; -@{$obj->nextval($cat?$dog:$fish)->{new}}; -@{$obj->nextval(cat()?$dog:$fish)->{new}}; -$ a {'cat'}; -$a::b::c{d}->{$e->()}; -$a'b'c'd{e}->{$e->()}; -$a'b::c'd{e}->{$e->()}; -$#_; -$#array; -$#{array}; -$var[$#var]; - -# THESE SHOULD FAIL -$a->; -@{$; -$ a :: b :: c -$ a ' b ' c - -# USING: extract_variable($str,'=*'); -========$a; diff --git a/t/lib/test-harness.t b/t/lib/test-harness.t deleted file mode 100644 index a4c423ddd3..0000000000 --- a/t/lib/test-harness.t +++ /dev/null @@ -1,205 +0,0 @@ -#!perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use strict; - -# For shutting up Test::Harness. -package My::Dev::Null; -use Tie::Handle; -@My::Dev::Null::ISA = qw(Tie::StdHandle); - -sub WRITE { } - - -package main; - -# Utility testing functions. -my $test_num = 1; -sub ok ($;$) { - my($test, $name) = @_; - my $okstring = ''; - $okstring = "not " unless $test; - $okstring .= "ok $test_num"; - $okstring .= " - $name" if defined $name; - print "$okstring\n"; - $test_num++; -} - -sub eqhash { - my($a1, $a2) = @_; - return 0 unless keys %$a1 == keys %$a2; - - my $ok = 1; - foreach my $k (keys %$a1) { - $ok = $a1->{$k} eq $a2->{$k}; - last unless $ok; - } - - return $ok; -} - -use vars qw($Total_tests %samples); - -my $loaded; -BEGIN { $| = 1; $^W = 1; } -END {print "not ok $test_num\n" unless $loaded;} -print "1..$Total_tests\n"; -use Test::Harness; -$loaded = 1; -ok(1, 'compile'); -######################### End of black magic. - -BEGIN { - %samples = ( - simple => { - bonus => 0, - max => 5, - 'ok' => 5, - files => 1, - bad => 0, - good => 1, - tests => 1, - sub_skipped=> 0, - skipped => 0, - }, - simple_fail => { - bonus => 0, - max => 5, - 'ok' => 3, - files => 1, - bad => 1, - good => 0, - tests => 1, - sub_skipped => 0, - skipped => 0, - }, - descriptive => { - bonus => 0, - max => 5, - 'ok' => 5, - files => 1, - bad => 0, - good => 1, - tests => 1, - sub_skipped=> 0, - skipped => 0, - }, - no_nums => { - bonus => 0, - max => 5, - 'ok' => 4, - files => 1, - bad => 1, - good => 0, - tests => 1, - sub_skipped=> 0, - skipped => 0, - }, - todo => { - bonus => 1, - max => 5, - 'ok' => 5, - files => 1, - bad => 0, - good => 1, - tests => 1, - sub_skipped=> 0, - skipped => 0, - }, - skip => { - bonus => 0, - max => 5, - 'ok' => 5, - files => 1, - bad => 0, - good => 1, - tests => 1, - sub_skipped=> 1, - skipped => 0, - }, - bailout => 0, - combined => { - bonus => 1, - max => 10, - 'ok' => 8, - files => 1, - bad => 1, - good => 0, - tests => 1, - sub_skipped=> 1, - skipped => 0 - }, - duplicates => { - bonus => 0, - max => 10, - 'ok' => 11, - files => 1, - bad => 1, - good => 0, - tests => 1, - sub_skipped=> 0, - skipped => 0, - }, - header_at_end => { - bonus => 0, - max => 4, - 'ok' => 4, - files => 1, - bad => 0, - good => 1, - tests => 1, - sub_skipped=> 0, - skipped => 0, - }, - skip_all => { - bonus => 0, - max => 0, - 'ok' => 0, - files => 1, - bad => 0, - good => 1, - tests => 1, - sub_skipped=> 0, - skipped => 1, - }, - with_comments => { - bonus => 2, - max => 5, - 'ok' => 5, - files => 1, - bad => 0, - good => 1, - tests => 1, - sub_skipped=> 0, - skipped => 0, - }, - ); - - $Total_tests = keys(%samples) + 1; -} - -tie *NULL, 'My::Dev::Null' or die $!; - -while (my($test, $expect) = each %samples) { - # _run_all_tests() runs the tests but skips the formatting. - my($totals, $failed); - eval { - select NULL; # _run_all_tests() isn't as quiet as it should be. - ($totals, $failed) = - Test::Harness::_run_all_tests("lib/sample-tests/$test"); - }; - select STDOUT; - - unless( $@ ) { - ok( eqhash( $expect, {map { $_=>$totals->{$_} } keys %$expect} ), - $test ); - } - else { # special case for bailout - ok( ($test eq 'bailout' and $@ =~ /Further testing stopped: GERONI/i), - $test ); - } -} diff --git a/t/lib/textfill.t b/t/lib/textfill.t deleted file mode 100755 index 5ff3850caf..0000000000 --- a/t/lib/textfill.t +++ /dev/null @@ -1,98 +0,0 @@ -#!./perl -w - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Text::Wrap qw(&fill); - -@tests = (split(/\nEND\n/s, <<DONE)); -TEST1 -Cyberdog Information - -Cyberdog & Netscape in the news -Important Press Release regarding Cyberdog and Netscape. Check it out! - -Cyberdog Plug-in Support! -Cyberdog support for Netscape Plug-ins is now available to download! Go -to the Cyberdog Beta Download page and download it now! - -Cyberdog Book -Check out Jesse Feiler's way-cool book about Cyberdog. You can find -details out about the book as well as ordering information at Philmont -Software Mill site. - -Java! -Looking to view Java applets in Cyberdog 1.1 Beta 3? Download and install -the Mac OS Runtime for Java and try it out! - -Cyberdog 1.1 Beta 3 -We hope that Cyberdog and OpenDoc 1.1 will be available within the next -two weeks. In the meantime, we have released another version of -Cyberdog, Cyberdog 1.1 Beta 3. This version fixes several bugs that were -reported to us during out public beta period. You can check out our release -notes to see what we fixed! -END - Cyberdog Information - Cyberdog & Netscape in the news Important Press Release regarding - Cyberdog and Netscape. Check it out! - Cyberdog Plug-in Support! Cyberdog support for Netscape Plug-ins is now - available to download! Go to the Cyberdog Beta Download page and download - it now! - Cyberdog Book Check out Jesse Feiler's way-cool book about Cyberdog. - You can find details out about the book as well as ordering information at - Philmont Software Mill site. - Java! Looking to view Java applets in Cyberdog 1.1 Beta 3? Download and - install the Mac OS Runtime for Java and try it out! - Cyberdog 1.1 Beta 3 We hope that Cyberdog and OpenDoc 1.1 will be - available within the next two weeks. In the meantime, we have released - another version of Cyberdog, Cyberdog 1.1 Beta 3. This version fixes - several bugs that were reported to us during out public beta period. You - can check out our release notes to see what we fixed! -END -DONE - - -$| = 1; - -print "1..", @tests/2, "\n"; - -use Text::Wrap; - -$rerun = $ENV{'PERL_DL_NONLAZY'} ? 0 : 1; - -$tn = 1; -while (@tests) { - my $in = shift(@tests); - my $out = shift(@tests); - - $in =~ s/^TEST(\d+)?\n//; - - my $back = fill(' ', ' ', $in); - - if ($back eq $out) { - print "ok $tn\n"; - } elsif ($rerun) { - my $oi = $in; - open(F,">#o") and do { print F $back; close(F) }; - open(F,">#e") and do { print F $out; close(F) }; - foreach ($in, $back, $out) { - s/\t/^I\t/gs; - s/\n/\$\n/gs; - } - print "------------ input ------------\n"; - print $in; - print "\n------------ output -----------\n"; - print $back; - print "\n------------ expected ---------\n"; - print $out; - print "\n-------------------------------\n"; - $Text::Wrap::debug = 1; - fill(' ', ' ', $oi); - exit(1); - } else { - print "not ok $tn\n"; - } - $tn++; -} diff --git a/t/lib/texttabs.t b/t/lib/texttabs.t deleted file mode 100755 index 2856aff75b..0000000000 --- a/t/lib/texttabs.t +++ /dev/null @@ -1,141 +0,0 @@ -#!./perl -w - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -@tests = (split(/\nEND\n/s, <<DONE)); -TEST 1 u - x -END - x -END -TEST 2 e - x -END - x -END -TEST 3 e - x - y - z -END - x - y - z -END -TEST 4 u - x - y - z -END - x - y - z -END -TEST 5 u -This Is a test of a line with many embedded tabs -END -This Is a test of a line with many embedded tabs -END -TEST 6 e -This Is a test of a line with many embedded tabs -END -This Is a test of a line with many embedded tabs -END -TEST 7 u - x -END - x -END -TEST 8 e - - - - - -END - - - - - -END -TEST 9 u - -END - -END -TEST 10 u - - - - - -END - - - - - -END -TEST 11 u -foobar IN A 140.174.82.12 - -END -foobar IN A 140.174.82.12 - -END -DONE - -$| = 1; - -my $testcount = "1.."; -$testcount .= @tests/2; -print "$testcount\n"; - -use Text::Tabs; - -$rerun = $ENV{'PERL_DL_NONLAZY'} ? 0 : 1; - -$tn = 1; -while (@tests) { - my $in = shift(@tests); - my $out = shift(@tests); - - $in =~ s/^TEST\s*(\d+)?\s*(\S+)?\n//; - - if ($2 eq 'e') { - $f = \&expand; - $fn = 'expand'; - } else { - $f = \&unexpand; - $fn = 'unexpand'; - } - - my $back = &$f($in); - - if ($back eq $out) { - print "ok $tn\n"; - } elsif ($rerun) { - my $oi = $in; - foreach ($in, $back, $out) { - s/\t/^I\t/gs; - s/\n/\$\n/gs; - } - print "------------ input ------------\n"; - print $in; - print "\$\n------------ $fn -----------\n"; - print $back; - print "\$\n------------ expected ---------\n"; - print $out; - print "\$\n-------------------------------\n"; - $Text::Tabs::debug = 1; - my $back = &$f($in); - exit(1); - } else { - print "not ok $tn\n"; - } - $tn++; -} diff --git a/t/lib/textwrap.t b/t/lib/textwrap.t deleted file mode 100755 index fee6ce070d..0000000000 --- a/t/lib/textwrap.t +++ /dev/null @@ -1,209 +0,0 @@ -#!./perl -w - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -@tests = (split(/\nEND\n/s, <<DONE)); -TEST1 -This -is -a -test -END - This - is - a - test -END -TEST2 -This is a test of a very long line. It should be broken up and put onto multiple lines. -This is a test of a very long line. It should be broken up and put onto multiple lines. - -This is a test of a very long line. It should be broken up and put onto multiple lines. -END - This is a test of a very long line. It should be broken up and put onto - multiple lines. - This is a test of a very long line. It should be broken up and put onto - multiple lines. - - This is a test of a very long line. It should be broken up and put onto - multiple lines. -END -TEST3 -This is a test of a very long line. It should be broken up and put onto multiple lines. -END - This is a test of a very long line. It should be broken up and put onto - multiple lines. -END -TEST4 -This is a test of a very long line. It should be broken up and put onto multiple lines. - -END - This is a test of a very long line. It should be broken up and put onto - multiple lines. - -END -TEST5 -This is a test of a very long line. It should be broken up and put onto multiple This is a test of a very long line. It should be broken up and put -END - This is a test of a very long line. It should be broken up and put onto - multiple This is a test of a very long line. It should be broken up and - put -END -TEST6 -11111111 22222222 33333333 44444444 55555555 66666666 77777777 888888888 999999999 aaaaaaaaa bbbbbbbbb ccccccccc ddddddddd eeeeeeeee ffffffff gggggggg hhhhhhhh iiiiiiii jjjjjjjj kkkkkkkk llllllll mmmmmmmmm nnnnnnnnn ooooooooo ppppppppp qqqqqqqqq rrrrrrrrr sssssssss -END - 11111111 22222222 33333333 44444444 55555555 66666666 77777777 888888888 - 999999999 aaaaaaaaa bbbbbbbbb ccccccccc ddddddddd eeeeeeeee ffffffff - gggggggg hhhhhhhh iiiiiiii jjjjjjjj kkkkkkkk llllllll mmmmmmmmm nnnnnnnnn - ooooooooo ppppppppp qqqqqqqqq rrrrrrrrr sssssssss -END -TEST7 -c3t1d0s6 c4t1d0s6 c5t1d0s6 c6t1d0s6 c7t1d0s6 c8t1d0s6 c9t1d0s6 c10t1d0s6 c11t1d0s6 c12t1d0s6 c13t1d0s6 c14t1d0s6 c15t1d0s6 c16t1d0s6 c3t1d0s0 c4t1d0s0 c5t1d0s0 c6t1d0s0 c7t1d0s0 c8t1d0s0 c9t1d0s0 c10t1d0s0 c11t1d0s0 c12t1d0s0 c13t1d0s0 c14t1d0s0 c15t1d0s0 c16t1d0s0 -END - c3t1d0s6 c4t1d0s6 c5t1d0s6 c6t1d0s6 c7t1d0s6 c8t1d0s6 c9t1d0s6 c10t1d0s6 - c11t1d0s6 c12t1d0s6 c13t1d0s6 c14t1d0s6 c15t1d0s6 c16t1d0s6 c3t1d0s0 - c4t1d0s0 c5t1d0s0 c6t1d0s0 c7t1d0s0 c8t1d0s0 c9t1d0s0 c10t1d0s0 c11t1d0s0 - c12t1d0s0 c13t1d0s0 c14t1d0s0 c15t1d0s0 c16t1d0s0 -END -TEST8 -A test of a very very long word. -a123456789b123456789c123456789d123456789e123456789f123456789g123456789g1234567 -END - A test of a very very long word. - a123456789b123456789c123456789d123456789e123456789f123456789g123456789g123 - 4567 -END -TEST9 -A test of a very very long word. a123456789b123456789c123456789d123456789e123456789f123456789g123456789g1234567 -END - A test of a very very long word. - a123456789b123456789c123456789d123456789e123456789f123456789g123456789g123 - 4567 -END -TEST10 -my mother once said -"never eat paste my darling" -would that I heeded -END - my mother once said - "never eat paste my darling" - would that I heeded -END -TEST11 -This_is_a_word_that_is_too_long_to_wrap_we_want_to_make_sure_that_the_program_does_not_crash_and_burn -END - This_is_a_word_that_is_too_long_to_wrap_we_want_to_make_sure_that_the_pr - ogram_does_not_crash_and_burn -END -TEST12 -This - -Has - -Blank - -Lines - -END - This - - Has - - Blank - - Lines - -END -DONE - - -$| = 1; - -print "1..", 1 +@tests, "\n"; - -use Text::Wrap; - -$rerun = $ENV{'PERL_DL_NONLAZY'} ? 0 : 1; - -$tn = 1; - -@st = @tests; -while (@st) { - my $in = shift(@st); - my $out = shift(@st); - - $in =~ s/^TEST(\d+)?\n//; - - my $back = wrap(' ', ' ', $in); - - if ($back eq $out) { - print "ok $tn\n"; - } elsif ($rerun) { - my $oi = $in; - foreach ($in, $back, $out) { - s/\t/^I\t/gs; - s/\n/\$\n/gs; - } - print "------------ input ------------\n"; - print $in; - print "\n------------ output -----------\n"; - print $back; - print "\n------------ expected ---------\n"; - print $out; - print "\n-------------------------------\n"; - $Text::Wrap::debug = 1; - wrap(' ', ' ', $oi); - exit(1); - } else { - print "not ok $tn\n"; - } - $tn++; - -} - -@st = @tests; -while(@st) { - my $in = shift(@st); - my $out = shift(@st); - - $in =~ s/^TEST(\d+)?\n//; - - my @in = split("\n", $in, -1); - @in = ((map { "$_\n" } @in[0..$#in-1]), $in[-1]); - - my $back = wrap(' ', ' ', @in); - - if ($back eq $out) { - print "ok $tn\n"; - } elsif ($rerun) { - my $oi = $in; - foreach ($in, $back, $out) { - s/\t/^I\t/gs; - s/\n/\$\n/gs; - } - print "------------ input2 ------------\n"; - print $in; - print "\n------------ output2 -----------\n"; - print $back; - print "\n------------ expected2 ---------\n"; - print $out; - print "\n-------------------------------\n"; - $Text::Wrap::debug = 1; - wrap(' ', ' ', $oi); - exit(1); - } else { - print "not ok $tn\n"; - } - $tn++; -} - -$Text::Wrap::huge = 'overflow'; - -my $tw = 'This_is_a_word_that_is_too_long_to_wrap_we_want_to_make_sure_that_the_program_does_not_crash_and_burn'; -my $w = wrap('zzz','yyy',$tw); -print (($w eq "zzz$tw") ? "ok $tn\n" : "not ok $tn"); -$tn++; - diff --git a/t/lib/thr5005.t b/t/lib/thr5005.t deleted file mode 100755 index bc6aed7182..0000000000 --- a/t/lib/thr5005.t +++ /dev/null @@ -1,207 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if (! $Config{'use5005threads'}) { - print "1..0 # Skip: not use5005threads\n"; - exit 0; - } - - # XXX known trouble with global destruction - $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; -} -$| = 1; -print "1..74\n"; -use Thread 'yield'; -print "ok 1\n"; - -sub content -{ - print shift; - return shift; -} - -# create a thread passing args and immedaietly wait for it. -my $t = new Thread \&content,("ok 2\n","ok 3\n", 1..1000); -print $t->join; - -# check that lock works ... -{lock $foo; - $t = new Thread sub { lock $foo; print "ok 5\n" }; - print "ok 4\n"; -} -$t->join; - -sub dorecurse -{ - my $val = shift; - my $ret; - print $val; - if (@_) - { - $ret = Thread->new(\&dorecurse, @_); - $ret->join; - } -} - -$t = new Thread \&dorecurse, map { "ok $_\n" } 6..10; -$t->join; - -# test that sleep lets other thread run -$t = new Thread \&dorecurse,"ok 11\n"; -sleep 6; -print "ok 12\n"; -$t->join; - -sub islocked : locked { - my $val = shift; - my $ret; - print $val; - if (@_) - { - $ret = Thread->new(\&islocked, shift); - } - $ret; -} - -$t = Thread->new(\&islocked, "ok 13\n", "ok 14\n"); -$t->join->join; - -{ - package Loch::Ness; - sub new { bless [], shift } - sub monster : locked : method { - my($s, $m) = @_; - print "ok $m\n"; - } - sub gollum { &monster } -} -Loch::Ness->monster(15); -Loch::Ness->new->monster(16); -Loch::Ness->gollum(17); -Loch::Ness->new->gollum(18); - -my $short = "This is a long string that goes on and on."; -my $shorte = " a long string that goes on and on."; -my $long = "This is short."; -my $longe = " short."; -my $thr1 = new Thread \&threaded, $short, $shorte, "19"; -my $thr2 = new Thread \&threaded, $long, $longe, "20"; -my $thr3 = new Thread \&testsprintf, "21"; - -sub testsprintf { - my $testno = shift; - # this may coredump if thread vars are not properly initialised - my $same = sprintf "%.0f", $testno; - if ($testno eq $same) { - print "ok $testno\n"; - } else { - print "not ok $testno\t# '$testno' ne '$same'\n"; - } -} - -sub threaded { - my ($string, $string_end, $testno) = @_; - - # Do the match, saving the output in appropriate variables - $string =~ /(.*)(is)(.*)/; - # Yield control, allowing the other thread to fill in the match variables - yield(); - # Examine the match variable contents; on broken perls this fails - if ($3 eq $string_end) { - print "ok $testno\n"; - } - else { - warn <<EOT; - -# -# This is a KNOWN FAILURE, and one of the reasons why threading -# is still an experimental feature. It is here to stop people -# from deploying threads in production. ;-) -# -EOT - print "not ok $testno # other thread filled in match variables\n"; - } -} -$thr1->join; -$thr2->join; -$thr3->join; -print "ok 22\n"; - -{ - my $THRf_STATE_MASK = 7; - my $THRf_R_JOINABLE = 0; - my $THRf_R_JOINED = 1; - my $THRf_R_DETACHED = 2; - my $THRf_ZOMBIE = 3; - my $THRf_DEAD = 4; - my $THRf_DID_DIE = 8; - sub _test { - my($test, $t, $state, $die) = @_; - my $flags = $t->flags; - if (($flags & $THRf_STATE_MASK) == $state - && !($flags & $THRf_DID_DIE) == !$die) { - print "ok $test\n"; - } else { - print <<BAD; -not ok $test\t# got flags $flags not @{[ $state + ($die ? $THRf_DID_DIE : 0) ]} -BAD - } - } - - my @t; - push @t, ( - Thread->new(sub { sleep 4; die "thread die\n" }), - Thread->new(sub { die "thread die\n" }), - Thread->new(sub { sleep 4; 1 }), - Thread->new(sub { 1 }), - ) for 1, 2; - $_->detach for @t[grep $_ & 4, 0..$#t]; - - sleep 1; - my $test = 23; - for (0..7) { - my $t = $t[$_]; - my $flags = ($_ & 1) - ? ($_ & 4) ? $THRf_DEAD : $THRf_ZOMBIE - : ($_ & 4) ? $THRf_R_DETACHED : $THRf_R_JOINABLE; - _test($test++, $t, $flags, (($_ & 3) != 1) ? 0 : $THRf_DID_DIE); - printf "%sok %s\n", !$t->done == !($_ & 1) ? "" : "not ", $test++; - } -# $test = 39; - for (grep $_ & 1, 0..$#t) { - next if $_ & 4; # can't join detached threads - $t[$_]->eval; - my $die = ($_ & 2) ? "" : "thread die\n"; - printf "%sok %s\n", $@ eq $die ? "" : "not ", $test++; - } -# $test = 41; - for (0..7) { - my $t = $t[$_]; - my $flags = ($_ & 1) - ? ($_ & 4) ? $THRf_DEAD : $THRf_DEAD - : ($_ & 4) ? $THRf_R_DETACHED : $THRf_R_JOINABLE; - _test($test++, $t, $flags, (($_ & 3) != 1) ? 0 : $THRf_DID_DIE); - printf "%sok %s\n", !$t->done == !($_ & 1) ? "" : "not ", $test++; - } -# $test = 57; - for (grep !($_ & 1), 0..$#t) { - next if $_ & 4; # can't join detached threads - $t[$_]->eval; - my $die = ($_ & 2) ? "" : "thread die\n"; - printf "%sok %s\n", $@ eq $die ? "" : "not ", $test++; - } - sleep 1; # make sure even the detached threads are done sleeping -# $test = 59; - for (0..7) { - my $t = $t[$_]; - my $flags = ($_ & 1) - ? ($_ & 4) ? $THRf_DEAD : $THRf_DEAD - : ($_ & 4) ? $THRf_DEAD : $THRf_DEAD; - _test($test++, $t, $flags, ($_ & 2) ? 0 : $THRf_DID_DIE); - printf "%sok %s\n", $t->done ? "" : "not ", $test++; - } -# $test = 75; -} diff --git a/t/lib/tie-push.t b/t/lib/tie-push.t deleted file mode 100755 index b19aa0d0e8..0000000000 --- a/t/lib/tie-push.t +++ /dev/null @@ -1,25 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '.'; - push @INC, '../lib'; -} - -{ - package Basic; - use Tie::Array; - @ISA = qw(Tie::Array); - - sub TIEARRAY { return bless [], shift } - sub FETCH { $_[0]->[$_[1]] } - sub STORE { $_[0]->[$_[1]] = $_[2] } - sub FETCHSIZE { scalar(@{$_[0]}) } - sub STORESIZE { $#{$_[0]} = $_[1]-1 } -} - -tie @x,Basic; -tie @get,Basic; -tie @got,Basic; -tie @tests,Basic; -require "op/push.t" diff --git a/t/lib/tie-refhash.t b/t/lib/tie-refhash.t deleted file mode 100644 index d80b2e10fc..0000000000 --- a/t/lib/tie-refhash.t +++ /dev/null @@ -1,305 +0,0 @@ -#!/usr/bin/perl -w -# -# Basic test suite for Tie::RefHash and Tie::RefHash::Nestable. -# -# The testing is in two parts: first, run lots of tests on both a tied -# hash and an ordinary un-tied hash, and check they give the same -# answer. Then there are tests for those cases where the tied hashes -# should behave differently to normal hashes, that is, when using -# references as keys. -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '.'; - push @INC, '../lib'; -} - -use strict; -use Tie::RefHash; -use Data::Dumper; -my $numtests = 34; -my $currtest = 1; -print "1..$numtests\n"; - -my $ref = []; my $ref1 = []; - -# Test standard hash functionality, by performing the same operations -# on a tied hash and on a normal hash, and checking that the results -# are the same. This does of course assume that Perl hashes are not -# buggy :-) -# -my @tests = standard_hash_tests(); - -my @ordinary_results = runtests(\@tests, undef); -foreach my $class ('Tie::RefHash', 'Tie::RefHash::Nestable') { - my @tied_results = runtests(\@tests, $class); - my $all_ok = 1; - - die if @ordinary_results != @tied_results; - foreach my $i (0 .. $#ordinary_results) { - my ($or, $ow, $oe) = @{$ordinary_results[$i]}; - my ($tr, $tw, $te) = @{$tied_results[$i]}; - - my $ok = 1; - local $^W = 0; - $ok = 0 if (defined($or) != defined($tr)) or ($or ne $tr); - $ok = 0 if (defined($ow) != defined($tw)) or ($ow ne $tw); - $ok = 0 if (defined($oe) != defined($te)) or ($oe ne $te); - - if (not $ok) { - print STDERR - "failed for $class: $tests[$i]\n", - "ordinary hash gave:\n", - defined $or ? "\tresult: $or\n" : "\tundef result\n", - defined $ow ? "\twarning: $ow\n" : "\tno warning\n", - defined $oe ? "\texception: $oe\n" : "\tno exception\n", - "tied $class hash gave:\n", - defined $tr ? "\tresult: $tr\n" : "\tundef result\n", - defined $tw ? "\twarning: $tw\n" : "\tno warning\n", - defined $te ? "\texception: $te\n" : "\tno exception\n", - "\n"; - $all_ok = 0; - } - } - test($all_ok); -} - -# Now test Tie::RefHash's special powers -my (%h, $h); -$h = eval { tie %h, 'Tie::RefHash' }; -warn $@ if $@; -test(not $@); -test(ref($h) eq 'Tie::RefHash'); -test(defined(tied(%h)) and tied(%h) =~ /^Tie::RefHash/); -$h{$ref} = 'cholet'; -test($h{$ref} eq 'cholet'); -test(exists $h{$ref}); -test((keys %h) == 1); -test(ref((keys %h)[0]) eq 'ARRAY'); -test((keys %h)[0] eq $ref); -test((values %h) == 1); -test((values %h)[0] eq 'cholet'); -my $count = 0; -while (my ($k, $v) = each %h) { - if ($count++ == 0) { - test(ref($k) eq 'ARRAY'); - test($k eq $ref); - } -} -test($count == 1); -delete $h{$ref}; -test(not defined $h{$ref}); -test(not exists($h{$ref})); -test((keys %h) == 0); -test((values %h) == 0); -undef $h; -untie %h; - -# And now Tie::RefHash::Nestable's differences from Tie::RefHash. -$h = eval { tie %h, 'Tie::RefHash::Nestable' }; -warn $@ if $@; -test(not $@); -test(ref($h) eq 'Tie::RefHash::Nestable'); -test(defined(tied(%h)) and tied(%h) =~ /^Tie::RefHash::Nestable/); -$h{$ref}->{$ref1} = 'bungo'; -test($h{$ref}->{$ref1} eq 'bungo'); - -# Test that the nested hash is also tied (for current implementation) -test(defined(tied(%{$h{$ref}})) - and tied(%{$h{$ref}}) =~ /^Tie::RefHash::Nestable=/ ); - -test((keys %h) == 1); -test((keys %h)[0] eq $ref); -test((keys %{$h{$ref}}) == 1); -test((keys %{$h{$ref}})[0] eq $ref1); - - -die "expected to run $numtests tests, but ran ", $currtest - 1 - if $currtest - 1 != $numtests; - -@tests = (); -undef $ref; -undef $ref1; - -exit(); - - -# Print 'ok X' if true, 'not ok X' if false -# Uses global $currtest. -# -sub test { - my $t = shift; - print 'not ' if not $t; - print 'ok ', $currtest++, "\n"; -} - - -# Wrapper for Data::Dumper to 'dump' a scalar as an EXPR string. -sub dumped { - my $s = shift; - my $d = Dumper($s); - $d =~ s/^\$VAR1 =\s*//; - $d =~ s/;$//; - chomp $d; - return $d; -} - -# Crudely dump a hash into a canonical string representation (because -# hash keys can appear in any order, Data::Dumper may give different -# strings for the same hash). -# -sub dumph { - my $h = shift; - my $r = ''; - foreach (sort keys %$h) { - $r = dumped($_) . ' => ' . dumped($h->{$_}) . "\n"; - } - return $r; -} - -# Run the tests and give results. -# -# Parameters: reference to list of tests to run -# name of class to use for tied hash, or undef if not tied -# -# Returns: list of [R, W, E] tuples, one for each test. -# R is the return value from running the test, W any warnings it gave, -# and E any exception raised with 'die'. E and W will be tidied up a -# little to remove irrelevant details like line numbers :-) -# -# Will also run a few of its own 'ok N' tests. -# -sub runtests { - my ($tests, $class) = @_; - my @r; - - my (%h, $h); - if (defined $class) { - $h = eval { tie %h, $class }; - warn $@ if $@; - test(not $@); - test(ref($h) eq $class); - test(defined(tied(%h)) and tied(%h) =~ /^\Q$class\E/); - } - - foreach (@$tests) { - my ($result, $warning, $exception); - local $SIG{__WARN__} = sub { $warning .= $_[0] }; - $result = scalar(eval $_); - if ($@) - { - die "$@:$_" unless defined $class; - $exception = $@; - } - - foreach ($warning, $exception) { - next if not defined; - s/ at .+ line \d+\.$//mg; - s/ at .+ line \d+, at .*//mg; - s/ at .+ line \d+, near .*//mg; - } - - my (@warnings, %seen); - foreach (split /\n/, $warning) { - push @warnings, $_ unless $seen{$_}++; - } - $warning = join("\n", @warnings); - - push @r, [ $result, $warning, $exception ]; - } - - return @r; -} - - -# Things that should work just the same for an ordinary hash and a -# Tie::RefHash. -# -# Each test is a code string to be eval'd, it should do something with -# %h and give a scalar return value. The global $ref and $ref1 may -# also be used. -# -# One thing we don't test is that the ordering from 'keys', 'values' -# and 'each' is the same. You can't reasonably expect that. -# -sub standard_hash_tests { - my @r; - - # Library of standard tests on keys, values and each - my $STD_TESTS = <<'END' - join $;, sort keys %h; - join $;, sort values %h; - { my ($v, %tmp); $tmp{$v}++ while (defined($v = each %h)); dumph(\%tmp) } - { my ($k, $v, %tmp); $tmp{"$k$;$v"}++ while (($k, $v) = each %h); dumph(\%tmp) } -END - ; - - # Tests on the existence of the element 'foo' - my $FOO_TESTS = <<'END' - defined $h{foo}; - exists $h{foo}; - $h{foo}; -END - ; - - # Test storing and deleting 'foo' - push @r, split /\n/, <<"END" - $STD_TESTS; - $FOO_TESTS; - \$h{foo} = undef; - $STD_TESTS; - $FOO_TESTS; - \$h{foo} = 'hello'; - $STD_TESTS; - $FOO_TESTS; - delete \$h{foo}; - $STD_TESTS; - $FOO_TESTS; -END - ; - - # Test storing and removing under ordinary keys - my @things = ('boink', 0, 1, '', undef); - foreach my $key (map { dumped($_) } @things) { - foreach my $value ((map { dumped($_) } @things), '$ref') { - push @r, split /\n/, <<"END" - \$h{$key} = $value; - $STD_TESTS; - defined \$h{$key}; - exists \$h{$key}; - \$h{$key}; - delete \$h{$key}; - $STD_TESTS; - defined \$h{$key}; - exists \$h{$key}; - \$h{$key}; -END - ; - } - } - - # Test hash slices - my @slicetests; - @slicetests = split /\n/, <<'END' - @h{'b'} = (); - @h{'c'} = ('d'); - @h{'e'} = ('f', 'g'); - @h{'h', 'i'} = (); - @h{'j', 'k'} = ('l'); - @h{'m', 'n'} = ('o', 'p'); - @h{'q', 'r'} = ('s', 't', 'u'); -END - ; - my @aaa = @slicetests; - foreach (@slicetests) { - push @r, $_; - push @r, split(/\n/, $STD_TESTS); - } - - # Test CLEAR - push @r, '%h = ();', split(/\n/, $STD_TESTS); - - return @r; -} - diff --git a/t/lib/tie-splice.t b/t/lib/tie-splice.t deleted file mode 100644 index d7ea6cc1dc..0000000000 --- a/t/lib/tie-splice.t +++ /dev/null @@ -1,17 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '.'; - push @INC, '../lib'; -} - -# bug id 20001020.002 -# -dlc 20001021 - -use Tie::Array; -tie @a,Tie::StdArray; -undef *Tie::StdArray::SPLICE; -require "op/splice.t" - -# Pre-fix, this failed tests 6-9 diff --git a/t/lib/tie-stdarray.t b/t/lib/tie-stdarray.t deleted file mode 100755 index c4ae07102e..0000000000 --- a/t/lib/tie-stdarray.t +++ /dev/null @@ -1,13 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '.'; - push @INC, '../lib'; -} - -use Tie::Array; -tie @foo,Tie::StdArray; -tie @ary,Tie::StdArray; -tie @bar,Tie::StdArray; -require "op/array.t" diff --git a/t/lib/tie-stdhandle.t b/t/lib/tie-stdhandle.t deleted file mode 100755 index f03f5d92f6..0000000000 --- a/t/lib/tie-stdhandle.t +++ /dev/null @@ -1,47 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Tie::Handle; -tie *tst,Tie::StdHandle; - -$f = 'tst'; - -print "1..13\n"; - -# my $file tests - -unlink("afile.new") if -f "afile"; -print "$!\nnot " unless open($f,"+>afile") && open($f, "+<", "afile"); -print "ok 1\n"; -print "$!\nnot " unless binmode($f); -print "ok 2\n"; -print "not " unless -f "afile"; -print "ok 3\n"; -print "not " unless print $f "SomeData\n"; -print "ok 4\n"; -print "not " unless tell($f) == 9; -print "ok 5\n"; -print "not " unless printf $f "Some %d value\n",1234; -print "ok 6\n"; -print "not " unless seek($f,0,0); -print "ok 7\n"; -$b = <$f>; -print "not " unless $b eq "SomeData\n"; -print "ok 8\n"; -print "not " if eof($f); -print "ok 9\n"; -read($f,($b=''),4); -print "'$b' not " unless $b eq 'Some'; -print "ok 10\n"; -print "not " unless getc($f) eq ' '; -print "ok 11\n"; -$b = <$f>; -print "not " unless eof($f); -print "ok 12\n"; -print "not " unless close($f); -print "ok 13\n"; -unlink("afile"); diff --git a/t/lib/tie-stdpush.t b/t/lib/tie-stdpush.t deleted file mode 100755 index 31af30c32c..0000000000 --- a/t/lib/tie-stdpush.t +++ /dev/null @@ -1,11 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '.'; - push @INC, '../lib'; -} - -use Tie::Array; -tie @x,Tie::StdArray; -require "op/push.t" diff --git a/t/lib/tie-substrhash.t b/t/lib/tie-substrhash.t deleted file mode 100644 index 8256db7b58..0000000000 --- a/t/lib/tie-substrhash.t +++ /dev/null @@ -1,111 +0,0 @@ -#!/usr/bin/perl -w -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '.'; - push @INC, '../lib'; -} - -print "1..20\n"; - -use strict; - -require Tie::SubstrHash; - -my %a; - -tie %a, 'Tie::SubstrHash', 3, 3, 3; - -$a{abc} = 123; -$a{bcd} = 234; - -print "not " unless $a{abc} == 123; -print "ok 1\n"; - -print "not " unless keys %a == 2; -print "ok 2\n"; - -delete $a{abc}; - -print "not " unless $a{bcd} == 234; -print "ok 3\n"; - -print "not " unless (values %a)[0] == 234; -print "ok 4\n"; - -eval { $a{abcd} = 123 }; -print "not " unless $@ =~ /Key "abcd" is not 3 characters long/; -print "ok 5\n"; - -eval { $a{abc} = 1234 }; -print "not " unless $@ =~ /Value "1234" is not 3 characters long/; -print "ok 6\n"; - -eval { $a = $a{abcd}; $a++ }; -print "not " unless $@ =~ /Key "abcd" is not 3 characters long/; -print "ok 7\n"; - -@a{qw(abc cde)} = qw(123 345); - -print "not " unless $a{cde} == 345; -print "ok 8\n"; - -eval { $a{def} = 456 }; -print "not " unless $@ =~ /Table is full \(3 elements\)/; -print "ok 9\n"; - -%a = (); - -print "not " unless keys %a == 0; -print "ok 10\n"; - -# Tests 11..16 by Linc Madison. - -my $hashsize = 119; # arbitrary values from my data -my %test; -tie %test, "Tie::SubstrHash", 13, 86, $hashsize; - -for (my $i = 1; $i <= $hashsize; $i++) { - my $key1 = $i + 100_000; # fix to uniform 6-digit numbers - my $key2 = "abcdefg$key1"; - $test{$key2} = ("abcdefgh" x 10) . "$key1"; -} - -for (my $i = 1; $i <= $hashsize; $i++) { - my $key1 = $i + 100_000; - my $key2 = "abcdefg$key1"; - unless ($test{$key2}) { - print "not "; - last; - } -} -print "ok 11\n"; - -print "not " unless Tie::SubstrHash::findgteprime(1) == 2; -print "ok 12\n"; - -print "not " unless Tie::SubstrHash::findgteprime(2) == 2; -print "ok 13\n"; - -print "not " unless Tie::SubstrHash::findgteprime(5.5) == 7; -print "ok 14\n"; - -print "not " unless Tie::SubstrHash::findgteprime(13) == 13; -print "ok 15\n"; - -print "not " unless Tie::SubstrHash::findgteprime(13.000001) == 17; -print "ok 16\n"; - -print "not " unless Tie::SubstrHash::findgteprime(114) == 127; -print "ok 17\n"; - -print "not " unless Tie::SubstrHash::findgteprime(1000) == 1009; -print "ok 18\n"; - -print "not " unless Tie::SubstrHash::findgteprime(1024) == 1031; -print "ok 19\n"; - -print "not " unless Tie::SubstrHash::findgteprime(10000) == 10007; -print "ok 20\n"; - diff --git a/t/lib/time-gmtime.t b/t/lib/time-gmtime.t deleted file mode 100644 index 853ec3b6e3..0000000000 --- a/t/lib/time-gmtime.t +++ /dev/null @@ -1,57 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -BEGIN { - our $hasgm; - eval { my $n = gmtime 0 }; - $hasgm = 1 unless $@ && $@ =~ /unimplemented/; - unless ($hasgm) { print "1..0 # Skip: no gmtime\n"; exit 0 } -} - -BEGIN { - our @gmtime = gmtime 0; # This is the function gmtime. - unless (@gmtime) { print "1..0 # Skip: gmtime failed\n"; exit 0 } -} - -print "1..10\n"; - -use Time::gmtime; - -print "ok 1\n"; - -my $gmtime = gmtime 0 ; # This is the OO gmtime. - -print "not " unless $gmtime->sec == $gmtime[0]; -print "ok 2\n"; - -print "not " unless $gmtime->min == $gmtime[1]; -print "ok 3\n"; - -print "not " unless $gmtime->hour == $gmtime[2]; -print "ok 4\n"; - -print "not " unless $gmtime->mday == $gmtime[3]; -print "ok 5\n"; - -print "not " unless $gmtime->mon == $gmtime[4]; -print "ok 6\n"; - -print "not " unless $gmtime->year == $gmtime[5]; -print "ok 7\n"; - -print "not " unless $gmtime->wday == $gmtime[6]; -print "ok 8\n"; - -print "not " unless $gmtime->yday == $gmtime[7]; -print "ok 9\n"; - -print "not " unless $gmtime->isdst == $gmtime[8]; -print "ok 10\n"; - - - - diff --git a/t/lib/time-hires.t b/t/lib/time-hires.t deleted file mode 100644 index db35b955a5..0000000000 --- a/t/lib/time-hires.t +++ /dev/null @@ -1,216 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -BEGIN { $| = 1; print "1..19\n"; } - -END {print "not ok 1\n" unless $loaded;} - -use Time::HiRes qw(tv_interval); - -$loaded = 1; - -print "ok 1\n"; - -use strict; - -my $have_gettimeofday = defined &Time::HiRes::gettimeofday; -my $have_usleep = defined &Time::HiRes::usleep; -my $have_ualarm = defined &Time::HiRes::ualarm; - -import Time::HiRes 'gettimeofday' if $have_gettimeofday; -import Time::HiRes 'usleep' if $have_usleep; -import Time::HiRes 'ualarm' if $have_ualarm; - -use Config; - -sub skip { - map { print "ok $_ (skipped)\n" } @_; -} - -sub ok { - my ($n, $result, @info) = @_; - if ($result) { - print "ok $n\n"; - } - else { - print "not ok $n\n"; - print "# @info\n" if @info; - } -} - -if (!$have_gettimeofday) { - skip 2..6; -} -else { - my @one = gettimeofday(); - ok 2, @one == 2, 'gettimeofday returned ', 0+@one, ' args'; - ok 3, $one[0] > 850_000_000, "@one too small"; - - sleep 1; - - my @two = gettimeofday(); - ok 4, ($two[0] > $one[0] || ($two[0] == $one[0] && $two[1] > $one[1])), - "@two is not greater than @one"; - - my $f = Time::HiRes::time; - ok 5, $f > 850_000_000, "$f too small"; - ok 6, $f - $two[0] < 2, "$f - @two >= 2"; -} - -if (!$have_usleep) { - skip 7..8; -} -else { - my $one = time; - usleep(10_000); - my $two = time; - usleep(10_000); - my $three = time; - ok 7, $one == $two || $two == $three, "slept too long, $one $two $three"; - - if (!$have_gettimeofday) { - skip 8; - } - else { - my $f = Time::HiRes::time; - usleep(500_000); - my $f2 = Time::HiRes::time; - my $d = $f2 - $f; - ok 8, $d > 0.4 && $d < 0.8, "slept $d secs $f to $f2"; - } -} - -# Two-arg tv_interval() is always available. -{ - my $f = tv_interval [5, 100_000], [10, 500_000]; - ok 9, $f == 5.4, $f; -} - -if (!$have_gettimeofday) { - skip 10; -} -else { - my $r = [gettimeofday()]; - my $f = tv_interval $r; - ok 10, $f < 2, $f; -} - -if (!$have_usleep) { - skip 11; -} -else { - my $r = [gettimeofday()]; - #jTime::HiRes::sleep 0.5; - Time::HiRes::sleep( 0.5 ); - my $f = tv_interval $r; - ok 11, $f > 0.4 && $f < 0.8, "slept $f secs"; -} - -if (!$have_ualarm) { - skip 12..13; -} -else { - my $tick = 0; - local $SIG{ALRM} = sub { $tick++ }; - - my $one = time; $tick = 0; ualarm(10_000); sleep until $tick; - my $two = time; $tick = 0; ualarm(10_000); sleep until $tick; - my $three = time; - ok 12, $one == $two || $two == $three, "slept too long, $one $two $three"; - - $tick = 0; - ualarm(10_000, 10_000); - sleep until $tick >= 3; - ok 13, 1; - ualarm(0); -} - -# new test: did we even get close? - -{ - my $t = time(); - my $tf = Time::HiRes::time(); - ok 14, (abs($tf - $t) <= 1), - "time $t differs from Time::HiRes::time $tf"; -} - -unless (defined &Time::HiRes::gettimeofday - && defined &Time::HiRes::ualarm - && defined &Time::HiRes::usleep) { - for (15..17) { - print "ok $_ # skipped\n"; - } -} else { - use Time::HiRes qw (time alarm sleep); - - my ($f, $r, $i); - - print "# time..."; - $f = time; - print "$f\nok 15\n"; - - print "# sleep..."; - $r = [Time::HiRes::gettimeofday]; - sleep (0.5); - print Time::HiRes::tv_interval($r), "\nok 16\n"; - - $r = [Time::HiRes::gettimeofday]; - $i = 5; - $SIG{ALRM} = "tick"; - while ($i) - { - alarm(0.3); - select (undef, undef, undef, 10); - print "# Select returned! $i ", Time::HiRes::tv_interval ($r), "\n"; - } - - sub tick - { - $i--; - print "# Tick! $i ", Time::HiRes::tv_interval ($r), "\n"; - } - $SIG{ALRM} = 'DEFAULT'; - - print "ok 17\n"; -} - -unless (defined &Time::HiRes::setitimer - && defined &Time::HiRes::getitimer - && exists &Time::HiRes::ITIMER_VIRTUAL - && $Config{d_select}) { - for (18..19) { - print "ok $_ # Skip: no virtual interval timers\n"; - } -} else { - use Time::HiRes qw (setitimer getitimer ITIMER_VIRTUAL); - - my $i = 3; - my $r = [Time::HiRes::gettimeofday]; - - $SIG{VTALRM} = sub { - $i ? $i-- : setitimer(ITIMER_VIRTUAL, 0); - print "# Tick! $i ", Time::HiRes::tv_interval($r), "\n"; - }; - - print "# setitimer: ", join(" ", setitimer(ITIMER_VIRTUAL, 0.5, 0.4)), "\n"; - - # Assume interval timer granularity of 0.05 seconds. Too bold? - print "not " unless abs(getitimer(ITIMER_VIRTUAL) / 0.5) - 1 < 0.1; - print "ok 18\n"; - - print "# getitimer: ", join(" ", getitimer(ITIMER_VIRTUAL)), "\n"; - - while (getitimer(ITIMER_VIRTUAL)) { - my $j; $j++ for 1..1000; # Can't be unbreakable, must test getitimer(). - } - - print "# getitimer: ", join(" ", getitimer(ITIMER_VIRTUAL)), "\n"; - - print "not " unless getitimer(ITIMER_VIRTUAL) == 0; - print "ok 19\n"; - - $SIG{VTALRM} = 'DEFAULT'; -} - diff --git a/t/lib/time-localtime.t b/t/lib/time-localtime.t deleted file mode 100644 index 357615c780..0000000000 --- a/t/lib/time-localtime.t +++ /dev/null @@ -1,57 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -BEGIN { - our $haslocal; - eval { my $n = localtime 0 }; - $haslocal = 1 unless $@ && $@ =~ /unimplemented/; - unless ($haslocal) { print "1..0 # Skip: no localtime\n"; exit 0 } -} - -BEGIN { - our @localtime = localtime 0; # This is the function localtime. - unless (@localtime) { print "1..0 # Skip: localtime failed\n"; exit 0 } -} - -print "1..10\n"; - -use Time::localtime; - -print "ok 1\n"; - -my $localtime = localtime 0 ; # This is the OO localtime. - -print "not " unless $localtime->sec == $localtime[0]; -print "ok 2\n"; - -print "not " unless $localtime->min == $localtime[1]; -print "ok 3\n"; - -print "not " unless $localtime->hour == $localtime[2]; -print "ok 4\n"; - -print "not " unless $localtime->mday == $localtime[3]; -print "ok 5\n"; - -print "not " unless $localtime->mon == $localtime[4]; -print "ok 6\n"; - -print "not " unless $localtime->year == $localtime[5]; -print "ok 7\n"; - -print "not " unless $localtime->wday == $localtime[6]; -print "ok 8\n"; - -print "not " unless $localtime->yday == $localtime[7]; -print "ok 9\n"; - -print "not " unless $localtime->isdst == $localtime[8]; -print "ok 10\n"; - - - - diff --git a/t/lib/time-piece.t b/t/lib/time-piece.t deleted file mode 100644 index c62e36d95e..0000000000 --- a/t/lib/time-piece.t +++ /dev/null @@ -1,323 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -BEGIN { - require Config; import Config; - - if ($Config{extensions} !~ m!\bTime/Piece\b!) { - print "1..0 # Time::Piece not built\n"; - exit 0; - } -} - -print "1..86\n"; - -use Time::Piece; - -print "ok 1\n"; - -my $t = gmtime(951827696); # 2001-02-29T12:34:56 - -print "not " unless $t->sec == 56; -print "ok 2\n"; - -print "not " unless $t->second == 56; -print "ok 3\n"; - -print "not " unless $t->min == 34; -print "ok 4\n"; - -print "not " unless $t->minute == 34; -print "ok 5\n"; - -print "not " unless $t->hour == 12; -print "ok 6\n"; - -print "not " unless $t->mday == 29; -print "ok 7\n"; - -print "not " unless $t->day_of_month == 29; -print "ok 8\n"; - -print "not " unless $t->mon == 2; -print "ok 9\n"; - -print "not " unless $t->_mon == 1; -print "ok 10\n"; - -print "not " unless $t->monname eq 'Feb'; -print "ok 11\n"; - -print "not " unless $t->month eq 'February'; -print "ok 12\n"; - -print "not " unless $t->year == 2000; -print "ok 13\n"; - -print "not " unless $t->_year == 100; -print "ok 14\n"; - -print "not " unless $t->wday == 3; -print "ok 15\n"; - -print "not " unless $t->_wday == 2; -print "ok 16\n"; - -print "not " unless $t->day_of_week == 2; -print "ok 17\n"; - -print "not " unless $t->wdayname eq 'Tue'; -print "ok 18\n"; - -print "not " unless $t->weekday eq 'Tuesday'; -print "ok 19\n"; - -print "not " unless $t->yday == 59; -print "ok 20\n"; - -print "not " unless $t->day_of_year == 59; -print "ok 21\n"; - -# In GMT there should be no daylight savings ever. - -print "not " unless $t->isdst == 0; -print "ok 22\n"; - -print "not " unless $t->daylight_savings == 0; -print "ok 23\n"; - -print "not " unless $t->hms eq '12:34:56'; -print "ok 24\n"; - -print "not " unless $t->time eq '12:34:56'; -print "ok 25\n"; - -print "not " unless $t->ymd eq '2000-02-29'; -print "ok 26\n"; - -print "not " unless $t->date eq '2000-02-29'; -print "ok 27\n"; - -print "not " unless $t->mdy eq '02-29-2000'; -print "ok 28\n"; - -print "not " unless $t->dmy eq '29-02-2000'; -print "ok 29\n"; - -print "not " unless $t->cdate eq 'Tue Feb 29 12:34:56 2000'; -print "ok 30\n"; - -print "not " unless "$t" eq 'Tue Feb 29 12:34:56 2000'; -print "ok 31\n"; - -print "not " unless $t->datetime eq '2000-02-29T12:34:56'; -print "ok 32\n"; - -print "not " unless $t->epoch == 951827696; -print "ok 33\n"; - -# ->tzoffset? - -print "not " unless ($t->julian_day / 2451604.0075) - 1 < 0.001; -print "ok 34\n"; - -print "not " unless ($t->mjd / 51603.5075) - 1 < 0.001; -print "ok 35\n"; - -print "not " unless $t->week == 9; -print "ok 36\n"; - -if ($Config{d_strftime}) { - - print "not " unless $t->strftime('%a') eq 'Tue'; - print "ok 37\n"; - - print "not " unless $t->strftime('%A') eq 'Tuesday'; - print "ok 38\n"; - - print "not " unless $t->strftime('%b') eq 'Feb'; - print "ok 39\n"; - - print "not " unless $t->strftime('%B') eq 'February'; - print "ok 40\n"; - - print "not " unless $t->strftime('%c') eq 'Tue Feb 29 12:34:56 2000'; - print "ok 41\n"; - - print "not " unless $t->strftime('%C') == 20; - print "ok 42\n"; - - print "not " unless $t->strftime('%d') == 29; - print "ok 43\n"; - - print "not " unless $t->strftime('%D') eq '02/29/00'; # Yech! - print "ok 44\n"; - - print "not " unless $t->strftime('%e') eq '29'; # should test with < 10 - print "ok 45\n"; - - print "not " unless $t->strftime('%H') eq '12'; # should test with < 10 - print "ok 46\n"; - - print "not " unless $t->strftime('%b') eq 'Feb'; - print "ok 47\n"; - - print "not " unless $t->strftime('%I') eq '12'; # should test with < 10 - print "ok 48\n"; - - print "not " unless $t->strftime('%j') eq '059'; - print "ok 49\n"; - - print "not " unless $t->strftime('%M') eq '34'; # should test with < 10 - print "ok 50\n"; - - print "not " unless $t->strftime('%p') eq 'am'; - print "ok 51\n"; - - print "not " unless $t->strftime('%r') eq '12:34:56 am'; - print "ok 52\n"; - - print "not " unless $t->strftime('%R') eq '12:34'; # should test with > 12 - print "ok 53\n"; - - print "not " unless $t->strftime('%S') eq '56'; # should test with < 10 - print "ok 54\n"; - - print "not " unless $t->strftime('%T') eq '12:34:56'; # < 12 and > 12 - print "ok 55\n"; - - print "not " unless $t->strftime('%u') == 2; - print "ok 56\n"; - - print "not " unless $t->strftime('%U') eq '09'; # Sun cmp Mon - print "ok 57\n"; - - print "not " unless $t->strftime('%V') eq '09'; # Sun cmp Mon - print "ok 58\n"; - - print "not " unless $t->strftime('%w') == 2; - print "ok 59\n"; - - print "not " unless $t->strftime('%W') eq '09'; # Sun cmp Mon - print "ok 60\n"; - - print "not " unless $t->strftime('%x') eq '02/29/00'; # Yech! - print "ok 61\n"; - - print "not " unless $t->strftime('%y') == 0; # should test with 1999 - print "ok 62\n"; - - print "not " unless $t->strftime('%Y') eq '2000'; - print "ok 63\n"; - - # %Z can't be tested, too unportable - -} else { - for (38...63) { - print "ok $_ # Skip: no strftime\n"; - } -} - -print "not " unless $t->ymd("") eq '20000229'; -print "ok 64\n"; - -print "not " unless $t->mdy("/") eq '02/29/2000'; -print "ok 65\n"; - -print "not " unless $t->dmy(".") eq '29.02.2000'; -print "ok 66\n"; - -print "not " unless $t->date_separator() eq '-'; -print "ok 67\n"; - -$t->date_separator("/"); - -print "not " unless $t->ymd eq '2000/02/29'; -print "ok 68\n"; - -print "not " unless $t->date_separator() eq '/'; -print "ok 69\n"; - -$t->date_separator("-"); - -print "not " unless $t->hms(".") eq '12.34.56'; -print "ok 70\n"; - -print "not " unless $t->time_separator() eq ':'; -print "ok 71\n"; - -$t->time_separator("."); - -print "not " unless $t->hms eq '12.34.56'; -print "ok 72\n"; - -print "not " unless $t->time_separator() eq '.'; -print "ok 73\n"; - -$t->time_separator(":"); - -my @fidays = qw( sunnuntai maanantai tiistai keskiviikko torstai - perjantai lauantai ); -my @frdays = qw( Dimanche Lundi Merdi Mercredi Jeudi Vendredi Samedi ); - -print "not " unless $t->weekday(@fidays) eq "tiistai"; -print "ok 74\n"; - -my @days = $t->weekday_names(); - -Time::Piece::weekday_names(@frdays); - -print "not " unless $t->weekday eq "Merdi"; -print "ok 75\n"; - -Time::Piece::weekday_names(@days); - -print "not " unless $t->weekday eq "Tuesday"; -print "ok 76\n"; - -my @months = $t->mon_names(); - -my @dumonths = qw(januari februari maart april mei juni - juli augustus september oktober november december); - -print "not " unless $t->month(@dumonths) eq "februari"; -print "ok 77\n"; - -Time::Piece::month_names(@dumonths); - -print "not " unless $t->month eq "februari"; -print "ok 78\n"; - -Time::Piece::mon_names(@months); - -print "not " unless $t->monname eq "Feb"; -print "ok 79\n"; - -print "not " unless - $t->datetime(date => '/', T => ' ', time => '-') eq "2000/02/29 12-34-56"; -print "ok 80\n"; - -print "not " unless $t->is_leap_year; -print "ok 81\n"; - -print "not " unless $t->month_last_day == 29; # test more -print "ok 82\n"; - -print "not " if Time::Piece::_is_leap_year(1900); -print "ok 83\n"; - -print "not " if Time::Piece::_is_leap_year(1901); -print "ok 84\n"; - -print "not " unless Time::Piece::_is_leap_year(1904); -print "ok 85\n"; - -use Time::Piece 'strptime'; - -my %T = strptime("%T", "12:34:56"); - -print "not " unless keys %T == 3 && $T{H} == 12 && $T{M} == 34 && $T{S} == 56; -print "ok 86\n"; - diff --git a/t/lib/timelocal.t b/t/lib/timelocal.t deleted file mode 100755 index 100e0768aa..0000000000 --- a/t/lib/timelocal.t +++ /dev/null @@ -1,90 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Time::Local; - -# Set up time values to test -@time = - ( - #year,mon,day,hour,min,sec - [1970, 1, 2, 00, 00, 00], - [1980, 2, 28, 12, 00, 00], - [1980, 2, 29, 12, 00, 00], - [1999, 12, 31, 23, 59, 59], - [2000, 1, 1, 00, 00, 00], - [2010, 10, 12, 14, 13, 12], - ); - -# use vmsish 'time' makes for oddness around the Unix epoch -if ($^O eq 'VMS') { $time[0][2]++ } - -print "1..", @time * 2 + 5, "\n"; - -$count = 1; -for (@time) { - my($year, $mon, $mday, $hour, $min, $sec) = @$_; - $year -= 1900; - $mon --; - my $time = timelocal($sec,$min,$hour,$mday,$mon,$year); - # print scalar(localtime($time)), "\n"; - my($s,$m,$h,$D,$M,$Y) = localtime($time); - - if ($s == $sec && - $m == $min && - $h == $hour && - $D == $mday && - $M == $mon && - $Y == $year - ) { - print "ok $count\n"; - } else { - print "not ok $count\n"; - } - $count++; - - # Test gmtime function - $time = timegm($sec,$min,$hour,$mday,$mon,$year); - ($s,$m,$h,$D,$M,$Y) = gmtime($time); - - if ($s == $sec && - $m == $min && - $h == $hour && - $D == $mday && - $M == $mon && - $Y == $year - ) { - print "ok $count\n"; - } else { - print "not ok $count\n"; - } - $count++; -} - -#print "Testing that the differences between a few dates makes sence...\n"; - -timelocal(0,0,1,1,0,90) - timelocal(0,0,0,1,0,90) == 3600 - or print "not "; -print "ok ", $count++, "\n"; - -timelocal(1,2,3,1,0,100) - timelocal(1,2,3,31,11,99) == 24 * 3600 - or print "not "; -print "ok ", $count++, "\n"; - -# Diff beween Jan 1, 1970 and Mar 1, 1970 = (31 + 28 = 59 days) -timegm(0,0,0, 1, 2, 70) - timegm(0,0,0, 1, 0, 70) == 59 * 24 * 3600 - or print "not "; -print "ok ", $count++, "\n"; - - -#print "Testing timelocal.pl module too...\n"; -package test; -require 'timelocal.pl'; -timegm(0,0,0,1,0,70) == main::timegm(0,0,0,1,0,70) or print "not "; -print "ok ", $main::count++, "\n"; - -timelocal(1,2,3,4,5,78) == main::timelocal(1,2,3,4,5,78) or print "not "; -print "ok ", $main::count++, "\n"; diff --git a/t/lib/trig.t b/t/lib/trig.t deleted file mode 100755 index 4246a47c40..0000000000 --- a/t/lib/trig.t +++ /dev/null @@ -1,200 +0,0 @@ -#!./perl - -# -# Regression tests for the Math::Trig package -# -# The tests are quite modest as the Math::Complex tests exercise -# these quite vigorously. -# -# -- Jarkko Hietaniemi, April 1997 - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Math::Trig; - -use strict; - -use vars qw($x $y $z); - -my $eps = 1e-11; - -if ($^O eq 'unicos') { # See lib/Math/Complex.pm and t/lib/complex.t. - $eps = 1e-10; -} - -sub near ($$;$) { - my $e = defined $_[2] ? $_[2] : $eps; - $_[1] ? (abs($_[0]/$_[1] - 1) < $e) : abs($_[0]) < $e; -} - -print "1..26\n"; - -$x = 0.9; -print 'not ' unless (near(tan($x), sin($x) / cos($x))); -print "ok 1\n"; - -print 'not ' unless (near(sinh(2), 3.62686040784702)); -print "ok 2\n"; - -print 'not ' unless (near(acsch(0.1), 2.99822295029797)); -print "ok 3\n"; - -$x = asin(2); -print 'not ' unless (ref $x eq 'Math::Complex'); -print "ok 4\n"; - -# avoid using Math::Complex here -$x =~ /^([^-]+)(-[^i]+)i$/; -($y, $z) = ($1, $2); -print 'not ' unless (near($y, 1.5707963267949) and - near($z, -1.31695789692482)); -print "ok 5\n"; - -print 'not ' unless (near(deg2rad(90), pi/2)); -print "ok 6\n"; - -print 'not ' unless (near(rad2deg(pi), 180)); -print "ok 7\n"; - -use Math::Trig ':radial'; - -{ - my ($r,$t,$z) = cartesian_to_cylindrical(1,1,1); - - print 'not ' unless (near($r, sqrt(2))) and - (near($t, deg2rad(45))) and - (near($z, 1)); - print "ok 8\n"; - - ($x,$y,$z) = cylindrical_to_cartesian($r, $t, $z); - - print 'not ' unless (near($x, 1)) and - (near($y, 1)) and - (near($z, 1)); - print "ok 9\n"; - - ($r,$t,$z) = cartesian_to_cylindrical(1,1,0); - - print 'not ' unless (near($r, sqrt(2))) and - (near($t, deg2rad(45))) and - (near($z, 0)); - print "ok 10\n"; - - ($x,$y,$z) = cylindrical_to_cartesian($r, $t, $z); - - print 'not ' unless (near($x, 1)) and - (near($y, 1)) and - (near($z, 0)); - print "ok 11\n"; -} - -{ - my ($r,$t,$f) = cartesian_to_spherical(1,1,1); - - print 'not ' unless (near($r, sqrt(3))) and - (near($t, deg2rad(45))) and - (near($f, atan2(sqrt(2), 1))); - print "ok 12\n"; - - ($x,$y,$z) = spherical_to_cartesian($r, $t, $f); - - print 'not ' unless (near($x, 1)) and - (near($y, 1)) and - (near($z, 1)); - print "ok 13\n"; - - ($r,$t,$f) = cartesian_to_spherical(1,1,0); - - print 'not ' unless (near($r, sqrt(2))) and - (near($t, deg2rad(45))) and - (near($f, deg2rad(90))); - print "ok 14\n"; - - ($x,$y,$z) = spherical_to_cartesian($r, $t, $f); - - print 'not ' unless (near($x, 1)) and - (near($y, 1)) and - (near($z, 0)); - print "ok 15\n"; -} - -{ - my ($r,$t,$z) = cylindrical_to_spherical(spherical_to_cylindrical(1,1,1)); - - print 'not ' unless (near($r, 1)) and - (near($t, 1)) and - (near($z, 1)); - print "ok 16\n"; - - ($r,$t,$z) = spherical_to_cylindrical(cylindrical_to_spherical(1,1,1)); - - print 'not ' unless (near($r, 1)) and - (near($t, 1)) and - (near($z, 1)); - print "ok 17\n"; -} - -{ - use Math::Trig 'great_circle_distance'; - - print 'not ' - unless (near(great_circle_distance(0, 0, 0, pi/2), pi/2)); - print "ok 18\n"; - - print 'not ' - unless (near(great_circle_distance(0, 0, pi, pi), pi)); - print "ok 19\n"; - - # London to Tokyo. - my @L = (deg2rad(-0.5), deg2rad(90 - 51.3)); - my @T = (deg2rad(139.8),deg2rad(90 - 35.7)); - - my $km = great_circle_distance(@L, @T, 6378); - - print 'not ' unless (near($km, 9605.26637021388)); - print "ok 20\n"; -} - -{ - my $R2D = 57.295779513082320876798154814169; - - sub frac { $_[0] - int($_[0]) } - - my $lotta_radians = deg2rad(1E+20, 1); - print "not " unless near($lotta_radians, 1E+20/$R2D); - print "ok 21\n"; - - my $negat_degrees = rad2deg(-1E20, 1); - print "not " unless near($negat_degrees, -1E+20*$R2D); - print "ok 22\n"; - - my $posit_degrees = rad2deg(-10000, 1); - print "not " unless near($posit_degrees, -10000*$R2D); - print "ok 23\n"; -} - -{ - use Math::Trig 'great_circle_direction'; - - print 'not ' - unless (near(great_circle_direction(0, 0, 0, pi/2), pi)); - print "ok 24\n"; - - print 'not ' - unless (near(great_circle_direction(0, 0, pi, pi), -pi()/2)); - print "ok 25\n"; - - # London to Tokyo. - my @L = (deg2rad(-0.5), deg2rad(90 - 51.3)); - my @T = (deg2rad(139.8),deg2rad(90 - 35.7)); - - my $rad = great_circle_direction(@L, @T); - - print 'not ' unless (near($rad, -0.546644569997376)); - print "ok 26\n"; -} - -# eof diff --git a/t/lib/u-blessed.t b/t/lib/u-blessed.t deleted file mode 100755 index 89a740a8cb..0000000000 --- a/t/lib/u-blessed.t +++ /dev/null @@ -1,39 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{extensions} !~ /\bList\/Util\b/) { - print "1..0 # Skip: List::Util was not built\n"; - exit 0; - } -} - -use Scalar::Util qw(blessed); -use vars qw($t $y $x); - -print "1..7\n"; - -print "not " if blessed(1); -print "ok 1\n"; - -print "not " if blessed('A'); -print "ok 2\n"; - -print "not " if blessed({}); -print "ok 3\n"; - -print "not " if blessed([]); -print "ok 4\n"; - -$y = \$t; - -print "not " if blessed($y); -print "ok 5\n"; - -$x = bless [], "ABC"; - -print "not " unless blessed($x); -print "ok 6\n"; - -print "not " unless blessed($x) eq 'ABC'; -print "ok 7\n"; diff --git a/t/lib/u-dualvar.t b/t/lib/u-dualvar.t deleted file mode 100755 index 5bf4fe95f7..0000000000 --- a/t/lib/u-dualvar.t +++ /dev/null @@ -1,46 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{extensions} !~ /\bList\/Util\b/) { - print "1..0 # Skip: List::Util was not built\n"; - exit 0; - } -} - -BEGIN { - require Scalar::Util; - - if (grep { /dualvar/ } @Scalar::Util::EXPORT_FAIL) { - print "1..0\n"; - exit; - } -} - -use Scalar::Util qw(dualvar); - -print "1..6\n"; - -$var = dualvar 2.2,"string"; - -print "not " unless $var == 2.2; -print "ok 1\n"; - -print "not " unless $var eq "string"; -print "ok 2\n"; - -$var2 = $var; - -$var++; - -print "not " unless $var == 3.2; -print "ok 3\n"; - -print "not " unless $var ne "string"; -print "ok 4\n"; - -print "not " unless $var2 == 2.2; -print "ok 5\n"; - -print "not " unless $var2 eq "string"; -print "ok 6\n"; diff --git a/t/lib/u-first.t b/t/lib/u-first.t deleted file mode 100755 index 6a35948e95..0000000000 --- a/t/lib/u-first.t +++ /dev/null @@ -1,25 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{extensions} !~ /\bList\/Util\b/) { - print "1..0 # Skip: List::Util was not built\n"; - exit 0; - } -} - -use List::Util qw(first); - -print "1..4\n"; - -print "not " unless defined &first; -print "ok 1\n"; - -print "not " unless 9 == first { 8 == ($_ - 1) } 9,4,5,6; -print "ok 2\n"; - -print "not " if defined(first { 0 } 1,2,3,4); -print "ok 3\n"; - -print "not " if defined(first { 0 }); -print "ok 4\n"; diff --git a/t/lib/u-max.t b/t/lib/u-max.t deleted file mode 100755 index 911003b92a..0000000000 --- a/t/lib/u-max.t +++ /dev/null @@ -1,30 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{extensions} !~ /\bList\/Util\b/) { - print "1..0 # Skip: List::Util was not built\n"; - exit 0; - } -} - -use List::Util qw(max); - -print "1..5\n"; - -print "not " unless defined &max; -print "ok 1\n"; - -print "not " unless max(1) == 1; -print "ok 2\n"; - -print "not " unless max(1,2) == 2; -print "ok 3\n"; - -print "not " unless max(2,1) == 2; -print "ok 4\n"; - -my @a = map { rand() } 1 .. 20; -my @b = sort { $a <=> $b } @a; -print "not " unless max(@a) == $b[-1]; -print "ok 5\n"; diff --git a/t/lib/u-maxstr.t b/t/lib/u-maxstr.t deleted file mode 100755 index 0ec35cab30..0000000000 --- a/t/lib/u-maxstr.t +++ /dev/null @@ -1,30 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{extensions} !~ /\bList\/Util\b/) { - print "1..0 # Skip: List::Util was not built\n"; - exit 0; - } -} - -use List::Util qw(maxstr); - -print "1..5\n"; - -print "not " unless defined &maxstr; -print "ok 1\n"; - -print "not " unless maxstr('a') eq 'a'; -print "ok 2\n"; - -print "not " unless maxstr('a','b') eq 'b'; -print "ok 3\n"; - -print "not " unless maxstr('B','A') eq 'B'; -print "ok 4\n"; - -my @a = map { pack("u", pack("C*",map { int(rand(256))} (0..int(rand(10) + 2)))) } 0 .. 20; -my @b = sort { $a cmp $b } @a; -print "not " unless maxstr(@a) eq $b[-1]; -print "ok 5\n"; diff --git a/t/lib/u-min.t b/t/lib/u-min.t deleted file mode 100755 index a51ced4e3d..0000000000 --- a/t/lib/u-min.t +++ /dev/null @@ -1,30 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{extensions} !~ /\bList\/Util\b/) { - print "1..0 # Skip: List::Util was not built\n"; - exit 0; - } -} - -use List::Util qw(min); - -print "1..5\n"; - -print "not " unless defined &min; -print "ok 1\n"; - -print "not " unless min(9) == 9; -print "ok 2\n"; - -print "not " unless min(1,2) == 1; -print "ok 3\n"; - -print "not " unless min(2,1) == 1; -print "ok 4\n"; - -my @a = map { rand() } 1 .. 20; -my @b = sort { $a <=> $b } @a; -print "not " unless min(@a) == $b[0]; -print "ok 5\n"; diff --git a/t/lib/u-minstr.t b/t/lib/u-minstr.t deleted file mode 100755 index c000e7856d..0000000000 --- a/t/lib/u-minstr.t +++ /dev/null @@ -1,30 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{extensions} !~ /\bList\/Util\b/) { - print "1..0 # Skip: List::Util was not built\n"; - exit 0; - } -} - -use List::Util qw(minstr); - -print "1..5\n"; - -print "not " unless defined &minstr; -print "ok 1\n"; - -print "not " unless minstr('a') eq 'a'; -print "ok 2\n"; - -print "not " unless minstr('a','b') eq 'a'; -print "ok 3\n"; - -print "not " unless minstr('B','A') eq 'A'; -print "ok 4\n"; - -my @a = map { pack("u", pack("C*",map { int(rand(256))} (0..int(rand(10) + 2)))) } 0 .. 20; -my @b = sort { $a cmp $b } @a; -print "not " unless minstr(@a) eq $b[0]; -print "ok 5\n"; diff --git a/t/lib/u-readonly.t b/t/lib/u-readonly.t deleted file mode 100644 index 864e1f12f2..0000000000 --- a/t/lib/u-readonly.t +++ /dev/null @@ -1,46 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{extensions} !~ /\bList\/Util\b/) { - print "1..0 # Skip: List::Util was not built\n"; - exit 0; - } -} - -use Scalar::Util qw(readonly); - -print "1..9\n"; - -print "not " unless readonly(1); -print "ok 1\n"; - -my $var = 2; - -print "not " if readonly($var); -print "ok 2\n"; - -print "not " unless $var == 2; -print "ok 3\n"; - -print "not " unless readonly("fred"); -print "ok 4\n"; - -$var = "fred"; - -print "not " if readonly($var); -print "ok 5\n"; - -print "not " unless $var eq "fred"; -print "ok 6\n"; - -$var = \2; - -print "not " if readonly($var); -print "ok 7\n"; - -print "not " unless readonly($$var); -print "ok 8\n"; - -print "not " if readonly(*STDOUT); -print "ok 9\n"; diff --git a/t/lib/u-reduce.t b/t/lib/u-reduce.t deleted file mode 100755 index 063e0b791b..0000000000 --- a/t/lib/u-reduce.t +++ /dev/null @@ -1,30 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{extensions} !~ /\bList\/Util\b/) { - print "1..0 # Skip: List::Util was not built\n"; - exit 0; - } -} - -use List::Util qw(reduce min); - -print "1..5\n"; - -print "not " if defined reduce {}; -print "ok 1\n"; - -print "not " unless 9 == reduce { $a / $b } 756,3,7,4; -print "ok 2\n"; - -print "not " unless 9 == reduce { $a / $b } 9; -print "ok 3\n"; - -@a = map { rand } 0 .. 20; -print "not " unless min(@a) == reduce { $a < $b ? $a : $b } @a; -print "ok 4\n"; - -@a = map { pack("C", int(rand(256))) } 0 .. 20; -print "not " unless join("",@a) eq reduce { $a . $b } @a; -print "ok 5\n"; diff --git a/t/lib/u-reftype.t b/t/lib/u-reftype.t deleted file mode 100755 index ea7ea7bbc1..0000000000 --- a/t/lib/u-reftype.t +++ /dev/null @@ -1,55 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{extensions} !~ /\bList\/Util\b/) { - print "1..0 # Skip: List::Util was not built\n"; - exit 0; - } -} - -use Scalar::Util qw(reftype); -use vars qw($t $y $x *F); -use Symbol qw(gensym); - -# Ensure we do not trigger and tied methods -tie *F, 'MyTie'; - -@test = ( - [ undef, 1], - [ undef, 'A'], - [ HASH => {} ], - [ ARRAY => [] ], - [ SCALAR => \$t ], - [ REF => \(\$t) ], - [ GLOB => \*F ], - [ GLOB => gensym ], - [ CODE => sub {} ], -# [ IO => *STDIN{IO} ] the internal sv_reftype returns UNKNOWN -); - -print "1..", @test*4, "\n"; - -my $i = 1; -foreach $test (@test) { - my($type,$what) = @$test; - my $pack; - foreach $pack (undef,"ABC","0",undef) { - print "# $what\n"; - my $res = reftype($what); - printf "# %s - %s\n", map { defined($_) ? $_ : 'undef' } $type,$res; - print "not " if $type ? $res ne $type : defined($res); - bless $what, $pack if $type && defined $pack; - print "ok ",$i++,"\n"; - } -} - -package MyTie; - -sub TIEHANDLE { bless {} } -sub DESTROY {} - -sub AUTOLOAD { - warn "$AUTOLOAD called"; - exit 1; # May be in an eval -} diff --git a/t/lib/u-sum.t b/t/lib/u-sum.t deleted file mode 100755 index 34fb69076a..0000000000 --- a/t/lib/u-sum.t +++ /dev/null @@ -1,23 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{extensions} !~ /\bList\/Util\b/) { - print "1..0 # Skip: List::Util was not built\n"; - exit 0; - } -} - -use List::Util qw(sum); - -print "1..3\n"; - -print "not " if defined sum; -print "ok 1\n"; - -print "not " unless sum(9) == 9; -print "ok 2\n"; - -print "not " unless sum(1,2,3,4) == 10; -print "ok 3\n"; - diff --git a/t/lib/u-tainted.t b/t/lib/u-tainted.t deleted file mode 100644 index 5587bb7bf9..0000000000 --- a/t/lib/u-tainted.t +++ /dev/null @@ -1,38 +0,0 @@ -#!./perl -T - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{extensions} !~ /\bList\/Util\b/) { - print "1..0 # Skip: List::Util was not built\n"; - exit 0; - } -} - -use lib qw(blib/lib blib/arch); -use Scalar::Util qw(tainted); -use Config; - -print "1..5\n"; - -print "not " if tainted(1); -print "ok 1\n"; - -my $var = 2; - -print "not " if tainted($var); -print "ok 2\n"; - -my $key = (keys %ENV)[0]; - -$var = $ENV{$key}; - -print "not " unless tainted($var); -print "ok 3\n"; - -print "not " unless tainted($ENV{$key}); -print "ok 4\n"; - -print "not " if @ARGV and not tainted($ARGV[0]); -print "ok 5\n"; diff --git a/t/lib/u-weak.t b/t/lib/u-weak.t deleted file mode 100755 index 6c7bea7f4d..0000000000 --- a/t/lib/u-weak.t +++ /dev/null @@ -1,206 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{extensions} !~ /\bList\/Util\b/) { - print "1..0 # Skip: List::Util was not built\n"; - exit 0; - } -} - -BEGIN { - $|=1; - require Scalar::Util; - if (grep { /weaken/ } @Scalar::Util::EXPORT_FAIL) { - print("1..0\n"); - exit; - } - - $DEBUG = 0; - - if ($DEBUG && eval { require Devel::Peek } ) { - Devel::Peek->import('Dump'); - } - else { - *Dump = sub {}; - } -} - -use Scalar::Util qw(weaken isweak); -print "1..17\n"; - -######################### End of black magic. - -$cnt = 0; - -sub ok { - ++$cnt; - if($_[0]) { print "ok $cnt\n"; } else {print "not ok $cnt\n"; } -} - -$| = 1; - -if(1) { - -my ($y,$z); - -# -# Case 1: two references, one is weakened, the other is then undef'ed. -# - -{ - my $x = "foo"; - $y = \$x; - $z = \$x; -} -print "# START:\n"; -Dump($y); Dump($z); - -ok( $y ne "" and $z ne "" ); -weaken($y); - -print "# WEAK:\n"; -Dump($y); Dump($z); - -ok( $y ne "" and $z ne "" ); -undef($z); - -print "# UNDZ:\n"; -Dump($y); Dump($z); - -ok( not (defined($y) and defined($z)) ); -undef($y); - -print "# UNDY:\n"; -Dump($y); Dump($z); - -ok( not (defined($y) and defined($z)) ); - -print "# FIN:\n"; -Dump($y); Dump($z); - -# exit(0); - -# } -# { - -# -# Case 2: one reference, which is weakened -# - -# kill 5,$$; - -print "# CASE 2:\n"; - -{ - my $x = "foo"; - $y = \$x; -} - -ok( $y ne "" ); -print "# BW: \n"; -Dump($y); -weaken($y); -print "# AW: \n"; -Dump($y); -ok( not defined $y ); - -print "# EXITBLOCK\n"; -} - -# exit(0); - -# -# Case 3: a circular structure -# - -# kill 5, $$; - -$flag = 0; -{ - my $y = bless {}, Dest; - Dump($y); - print "# 1: $y\n"; - $y->{Self} = $y; - Dump($y); - print "# 2: $y\n"; - $y->{Flag} = \$flag; - print "# 3: $y\n"; - weaken($y->{Self}); - print "# WKED\n"; - ok( $y ne "" ); - print "# VALS: HASH ",$y," SELF ",\$y->{Self}," Y ",\$y, - " FLAG: ",\$y->{Flag},"\n"; - print "# VPRINT\n"; -} -print "# OUT $flag\n"; -ok( $flag == 1 ); - -print "# AFTER\n"; - -undef $flag; - -print "# FLAGU\n"; - -# -# Case 4: a more complicated circular structure -# - -$flag = 0; -{ - my $y = bless {}, Dest; - my $x = bless {}, Dest; - $x->{Ref} = $y; - $y->{Ref} = $x; - $x->{Flag} = \$flag; - $y->{Flag} = \$flag; - weaken($x->{Ref}); -} -ok( $flag == 2 ); - -# -# Case 5: deleting a weakref before the other one -# - -{ - my $x = "foo"; - $y = \$x; - $z = \$x; -} - -print "# CASE5\n"; -Dump($y); - -weaken($y); -Dump($y); -undef($y); - -ok( not defined $y); -ok($z ne ""); - - -# -# Case 6: test isweakref -# - -$a = 5; -ok(!isweak($a)); -$b = \$a; -ok(!isweak($b)); -weaken($b); -ok(isweak($b)); -$b = \$a; -ok(!isweak($b)); - -$x = {}; -weaken($x->{Y} = \$a); -ok(isweak($x->{Y})); -ok(!isweak($x->{Z})); - - -package Dest; - -sub DESTROY { - print "# INCFLAG\n"; - ${$_[0]{Flag}} ++; -} diff --git a/t/lib/user-grent.t b/t/lib/user-grent.t deleted file mode 100644 index 760b814d54..0000000000 --- a/t/lib/user-grent.t +++ /dev/null @@ -1,44 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -BEGIN { - our $hasgr; - eval { my @n = getgrgid 0 }; - $hasgr = 1 unless $@ && $@ =~ /unimplemented/; - unless ($hasgr) { print "1..0 # Skip: no getgrgid\n"; exit 0 } - use Config; - $hasgr = 0 unless $Config{'i_grp'} eq 'define'; - unless ($hasgr) { print "1..0 # Skip: no grp.h\n"; exit 0 } -} - -BEGIN { - our @grent = getgrgid 0; # This is the function getgrgid. - unless (@grent) { print "1..0 # Skip: no gid 0\n"; exit 0 } -} - -print "1..5\n"; - -use User::grent; - -print "ok 1\n"; - -my $grent = getgrgid 0; # This is the OO getgrgid. - -print "not " unless $grent->gid == 0; -print "ok 2\n"; - -print "not " unless $grent->name == $grent[0]; -print "ok 3\n"; - -print "not " unless $grent->passwd eq $grent[1]; -print "ok 4\n"; - -print "not " unless $grent->gid == $grent[2]; -print "ok 5\n"; - -# Testing pretty much anything else is unportable. - diff --git a/t/lib/user-pwent.t b/t/lib/user-pwent.t deleted file mode 100644 index e274265bd1..0000000000 --- a/t/lib/user-pwent.t +++ /dev/null @@ -1,63 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -BEGIN { - our $haspw; - eval { my @n = getpwuid 0 }; - $haspw = 1 unless $@ && $@ =~ /unimplemented/; - unless ($haspw) { print "1..0 # Skip: no getpwuid\n"; exit 0 } - use Config; - $haspw = 0 unless $Config{'i_pwd'} eq 'define'; - unless ($haspw) { print "1..0 # Skip: no pwd.h\n"; exit 0 } -} - -BEGIN { - our @pwent = getpwuid 0; # This is the function getpwuid. - unless (@pwent) { print "1..0 # Skip: no uid 0\n"; exit 0 } -} - -print "1..9\n"; - -use User::pwent; - -print "ok 1\n"; - -my $pwent = getpwuid 0; # This is the OO getpwuid. - -print "not " unless $pwent->uid == 0; -print "ok 2\n"; - -print "not " unless $pwent->name == $pwent[0]; -print "ok 3\n"; - -print "not " unless $pwent->passwd eq $pwent[1]; -print "ok 4\n"; - -print "not " unless $pwent->uid == $pwent[2]; -print "ok 5\n"; - -print "not " unless $pwent->gid == $pwent[3]; -print "ok 6\n"; - -# The quota and comment fields are unportable. - -print "not " unless $pwent->gecos eq $pwent[6]; -print "ok 7\n"; - -print "not " unless $pwent->dir eq $pwent[7]; -print "ok 8\n"; - -print "not " unless $pwent->shell eq $pwent[8]; -print "ok 9\n"; - -# The expire field is unportable. - -# Testing pretty much anything else is unportable: -# there maybe more than one username with uid 0; -# uid 0's home directory may be "/" or "/root' or something else, -# and so on. - diff --git a/t/lib/xs-typemap.t b/t/lib/xs-typemap.t deleted file mode 100644 index 0cf1ab3481..0000000000 --- a/t/lib/xs-typemap.t +++ /dev/null @@ -1,339 +0,0 @@ -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - if ($Config{'extensions'} !~ /\bXS\/Typemap\b/) { - print "1..0 # Skip: XS::Typemap was not built\n"; - exit 0; - } -} - -use Test; -BEGIN { plan tests => 84 } - -use strict; -use warnings; -use XS::Typemap; - -ok(1); - -# Some inheritance trees to check ISA relationships -BEGIN { - package intObjPtr::SubClass; - use base qw/ intObjPtr /; - sub xxx { 1; } -} - -BEGIN { - package intRefIvPtr::SubClass; - use base qw/ intRefIvPtr /; - sub xxx { 1 } -} - -# T_SV - standard perl scalar value -print "# T_SV\n"; - -my $sv = "Testing T_SV"; -ok( T_SV($sv), $sv); - -# T_SVREF - reference to Scalar -print "# T_SVREF\n"; - -$sv .= "REF"; -my $svref = \$sv; -ok( T_SVREF($svref), $svref ); - -# Now test that a non reference is rejected -# the typemaps croak -eval { T_SVREF( "fail - not ref" ) }; -ok( $@ ); - -# T_AVREF - reference to a perl Array -print "# T_AVREF\n"; - -my @array; -ok( T_AVREF(\@array), \@array); - -# Now test that a non array ref is rejected -eval { T_AVREF( \$sv ) }; -ok( $@ ); - -# T_HVREF - reference to a perl Hash -print "# T_HVREF\n"; - -my %hash; -ok( T_HVREF(\%hash), \%hash); - -# Now test that a non hash ref is rejected -eval { T_HVREF( \@array ) }; -ok( $@ ); - - -# T_CVREF - reference to perl subroutine -print "# T_CVREF\n"; -my $sub = sub { 1 }; -ok( T_CVREF($sub), $sub ); - -# Now test that a non code ref is rejected -eval { T_CVREF( \@array ) }; -ok( $@ ); - -# T_SYSRET - system return values -print "# T_SYSRET\n"; - -# first check success -ok( T_SYSRET_pass ); - -# ... now failure -ok( T_SYSRET_fail, undef); - -# T_UV - unsigned integer -print "# T_UV\n"; - -ok( T_UV(5), 5 ); # pass -ok( T_UV(-4) != -4); # fail - -# T_IV - signed integer -print "# T_IV\n"; - -ok( T_IV(5), 5); -ok( T_IV(-4), -4); -ok( T_IV(4.1), int(4.1)); -ok( T_IV("52"), "52"); -ok( T_IV(4.5) != 4.5); # failure - - -# Skip T_INT - -# T_ENUM - enum list -print "# T_ENUM\n"; - -ok( T_ENUM() ); # just hope for a true value - -# T_BOOL - boolean -print "# T_BOOL\n"; - -ok( T_BOOL(52) ); -ok( ! T_BOOL(0) ); -ok( ! T_BOOL('') ); -ok( ! T_BOOL(undef) ); - -# Skip T_U_INT - -# Skip T_SHORT - -# T_U_SHORT aka U16 - -print "# T_U_SHORT\n"; - -ok( T_U_SHORT(32000), 32000); -if ($Config{shortsize} == 2) { - ok( T_U_SHORT(65536) != 65536); # probably dont want to test edge cases -} else { - ok(1); # e.g. Crays have shortsize 4 (T3X) or 8 (CXX and SVX) -} - -# T_U_LONG aka U32 - -print "# T_U_LONG\n"; - -ok( T_U_LONG(65536), 65536); -ok( T_U_LONG(-1) != -1); - -# T_CHAR - -print "# T_CHAR\n"; - -ok( T_CHAR("a"), "a"); -ok( T_CHAR("-"), "-"); -ok( T_CHAR(chr(128)),chr(128)); -ok( T_CHAR(chr(256)) ne chr(256)); - -# T_U_CHAR - -print "# T_U_CHAR\n"; - -ok( T_U_CHAR(127), 127); -ok( T_U_CHAR(128), 128); -ok( T_U_CHAR(-1) != -1); -ok( T_U_CHAR(300) != 300); - -# T_FLOAT -print "# T_FLOAT\n"; - -# limited precision -ok( sprintf("%6.3f",T_FLOAT(52.345)), sprintf("%6.3f",52.345)); - -# T_NV -print "# T_NV\n"; - -ok( T_NV(52.345), 52.345); - -# T_DOUBLE -print "# T_DOUBLE\n"; - -ok( sprintf("%6.3f",T_DOUBLE(52.345)), sprintf("%6.3f",52.345)); - -# T_PV -print "# T_PV\n"; - -ok( T_PV("a string"), "a string"); -ok( T_PV(52), 52); - -# T_PTR -print "# T_PTR\n"; - -my $t = 5; -my $ptr = T_PTR_OUT($t); -ok( T_PTR_IN( $ptr ), $t ); - -# T_PTRREF -print "# T_PTRREF\n"; - -$t = -52; -$ptr = T_PTRREF_OUT( $t ); -ok( ref($ptr), "SCALAR"); -ok( T_PTRREF_IN( $ptr ), $t ); - -# test that a non-scalar ref is rejected -eval { T_PTRREF_IN( $t ); }; -ok( $@ ); - -# T_PTROBJ -print "# T_PTROBJ\n"; - -$t = 256; -$ptr = T_PTROBJ_OUT( $t ); -ok( ref($ptr), "intObjPtr"); -ok( $ptr->T_PTROBJ_IN, $t ); - -# check that normal scalar refs fail -eval {intObjPtr::T_PTROBJ_IN( \$t );}; -ok( $@ ); - -# check that inheritance works -bless $ptr, "intObjPtr::SubClass"; -ok( ref($ptr), "intObjPtr::SubClass"); -ok( $ptr->T_PTROBJ_IN, $t ); - -# Skip T_REF_IV_REF - -# T_REF_IV_PTR -print "# T_REF_IV_PTR\n"; - -$t = -365; -$ptr = T_REF_IV_PTR_OUT( $t ); -ok( ref($ptr), "intRefIvPtr"); -ok( $ptr->T_REF_IV_PTR_IN(), $t); - -# inheritance should not work -bless $ptr, "intRefIvPtr::SubClass"; -eval { $ptr->T_REF_IV_PTR_IN }; -ok( $@ ); - -# Skip T_PTRDESC - -# Skip T_REFREF - -# Skip T_REFOBJ - -# T_OPAQUEPTR -print "# T_OPAQUEPTR\n"; - -$t = 22; -my $p = T_OPAQUEPTR_IN( $t ); -ok( T_OPAQUEPTR_OUT($p), $t); - -# T_OPAQUEPTR with a struct -print "# T_OPAQUEPTR with a struct\n"; - -my @test = (5,6,7); -$p = T_OPAQUEPTR_IN_struct(@test); -my @result = T_OPAQUEPTR_OUT_struct($p); -ok(scalar(@result),scalar(@test)); -for (0..$#test) { - ok($result[$_], $test[$_]); -} - -# T_OPAQUE -print "# T_OPAQUE\n"; - -$t = 48; -$p = T_OPAQUE_IN( $t ); -ok(T_OPAQUEPTR_OUT_short( $p ), $t); # Test using T_OPAQUEPTR -ok(T_OPAQUE_OUT( $p ), $t ); # Test using T_OPQAQUE - -# T_OPAQUE_array -print "# A packed array\n"; - -my @opq = (2,4,8); -my $packed = T_OPAQUE_array(@opq); -my @uopq = unpack("i*",$packed); -ok(scalar(@uopq), scalar(@opq)); -for (0..$#opq) { - ok( $uopq[$_], $opq[$_]); -} - -# Skip T_PACKED - -# Skip T_PACKEDARRAY - -# Skip T_DATAUNIT - -# Skip T_CALLBACK - -# T_ARRAY -print "# T_ARRAY\n"; -my @inarr = (1,2,3,4,5,6,7,8,9,10); -my @outarr = T_ARRAY( 5, @inarr ); -ok(scalar(@outarr), scalar(@inarr)); - -for (0..$#inarr) { - ok($outarr[$_], $inarr[$_]); -} - - - -# T_STDIO -print "# T_STDIO\n"; - -# open a file in XS for write -my $testfile= "stdio.tmp"; -my $fh = T_STDIO_open( $testfile ); -ok( $fh ); - -# write to it using perl -if (defined $fh) { - - my @lines = ("NormalSTDIO\n", "PerlIO\n"); - - # print to it using FILE* through XS - ok( T_STDIO_print($fh, $lines[0]), length($lines[0])); - - # print to it using normal perl - ok(print $fh "$lines[1]"); - - # close it using XS - # This works fine but causes a segmentation fault during global - # destruction when the glob associated with this filehandle is - # tidied up. -# ok( T_STDIO_close( $fh ) ); - ok(close($fh)); # using perlio to close the glob works fine - - # open from perl, and check contents - open($fh, "< $testfile"); - ok($fh); - my $line = <$fh>; - ok($line,$lines[0]); - $line = <$fh>; - ok($line,$lines[1]); - - ok(close($fh)); - ok(unlink($testfile)); - -} else { - for (1..8) { - skip("Skip Test not relevant since file was not opened correctly",0); - } -} - diff --git a/t/pragma/sub_lval.t b/t/op/sub_lval.t index e101f97cf6..e101f97cf6 100755 --- a/t/pragma/sub_lval.t +++ b/t/op/sub_lval.t diff --git a/t/pragma/autouse.t b/t/pragma/autouse.t deleted file mode 100644 index 0a2d68003f..0000000000 --- a/t/pragma/autouse.t +++ /dev/null @@ -1,57 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Test; -BEGIN { plan tests => 10; } - -BEGIN { - require autouse; - eval { - "autouse"->import('List::Util' => 'List::Util::first(&@)'); - }; - ok( !$@ ); - - eval { - "autouse"->import('List::Util' => 'Foo::min'); - }; - ok( $@, qr/^autouse into different package attempted/ ); - - "autouse"->import('List::Util' => qw(max first(&@))); -} - -my @a = (1,2,3,4,5.5); -ok( max(@a), 5.5); - - -# first() has a prototype of &@. Make sure that's preserved. -ok( (first { $_ > 3 } @a), 4); - - -# Example from the docs. -use autouse 'Carp' => qw(carp croak); - -{ - my @warning; - local $SIG{__WARN__} = sub { push @warning, @_ }; - carp "this carp was predeclared and autoused\n"; - ok( scalar @warning, 1 ); - ok( $warning[0], "this carp was predeclared and autoused\n" ); - - eval { croak "It is but a scratch!" }; - ok( $@, qr/^It is but a scratch!/); -} - - -# Test that autouse's lazy module loading works. We assume that nothing -# involved in this test uses Text::Soundex, which is pretty safe. -use autouse 'Text::Soundex' => qw(soundex); - -my $mod_file = 'Text/Soundex.pm'; # just fine and portable for %INC -ok( !exists $INC{$mod_file} ); -ok( soundex('Basset'), 'B230' ); -ok( exists $INC{$mod_file} ); - diff --git a/t/pragma/constant.t b/t/pragma/constant.t deleted file mode 100755 index f932976f60..0000000000 --- a/t/pragma/constant.t +++ /dev/null @@ -1,251 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use warnings; -use vars qw{ @warnings }; -BEGIN { # ...and save 'em for later - $SIG{'__WARN__'} = sub { push @warnings, @_ } -} -END { print @warnings } - -######################### We start with some black magic to print on failure. - -BEGIN { $| = 1; print "1..82\n"; } -END {print "not ok 1\n" unless $loaded;} -use constant 1.01; -$loaded = 1; -#print "# Version: $constant::VERSION\n"; -print "ok 1\n"; - -######################### End of black magic. - -use strict; - -sub test ($$;$) { - my($num, $bool, $diag) = @_; - if ($bool) { - print "ok $num\n"; - return; - } - print "not ok $num\n"; - return unless defined $diag; - $diag =~ s/\Z\n?/\n/; # unchomp - print map "# $num : $_", split m/^/m, $diag; -} - -use constant PI => 4 * atan2 1, 1; - -test 2, substr(PI, 0, 7) eq '3.14159'; -test 3, defined PI; - -sub deg2rad { PI * $_[0] / 180 } - -my $ninety = deg2rad 90; - -test 4, $ninety > 1.5707; -test 5, $ninety < 1.5708; - -use constant UNDEF1 => undef; # the right way -use constant UNDEF2 => ; # the weird way -use constant 'UNDEF3' ; # the 'short' way -use constant EMPTY => ( ) ; # the right way for lists - -test 6, not defined UNDEF1; -test 7, not defined UNDEF2; -test 8, not defined UNDEF3; -my @undef = UNDEF1; -test 9, @undef == 1; -test 10, not defined $undef[0]; -@undef = UNDEF2; -test 11, @undef == 0; -@undef = UNDEF3; -test 12, @undef == 0; -@undef = EMPTY; -test 13, @undef == 0; - -use constant COUNTDOWN => scalar reverse 1, 2, 3, 4, 5; -use constant COUNTLIST => reverse 1, 2, 3, 4, 5; -use constant COUNTLAST => (COUNTLIST)[-1]; - -test 14, COUNTDOWN eq '54321'; -my @cl = COUNTLIST; -test 15, @cl == 5; -test 16, COUNTDOWN eq join '', @cl; -test 17, COUNTLAST == 1; -test 18, (COUNTLIST)[1] == 4; - -use constant ABC => 'ABC'; -test 19, "abc${\( ABC )}abc" eq "abcABCabc"; - -use constant DEF => 'D', 'E', chr ord 'F'; -test 20, "d e f @{[ DEF ]} d e f" eq "d e f D E F d e f"; - -use constant SINGLE => "'"; -use constant DOUBLE => '"'; -use constant BACK => '\\'; -my $tt = BACK . SINGLE . DOUBLE ; -test 21, $tt eq q(\\'"); - -use constant MESS => q('"'\\"'"\\); -test 22, MESS eq q('"'\\"'"\\); -test 23, length(MESS) == 8; - -use constant TRAILING => '12 cats'; -{ - no warnings 'numeric'; - test 24, TRAILING == 12; -} -test 25, TRAILING eq '12 cats'; - -use constant LEADING => " \t1234"; -test 26, LEADING == 1234; -test 27, LEADING eq " \t1234"; - -use constant ZERO1 => 0; -use constant ZERO2 => 0.0; -use constant ZERO3 => '0.0'; -test 28, ZERO1 eq '0'; -test 29, ZERO2 eq '0'; -test 30, ZERO3 eq '0.0'; - -{ - package Other; - use constant PI => 3.141; -} - -test 31, (PI > 3.1415 and PI < 3.1416); -test 32, Other::PI == 3.141; - -use constant E2BIG => $! = 7; -test 33, E2BIG == 7; -# This is something like "Arg list too long", but the actual message -# text may vary, so we can't test much better than this. -test 34, length(E2BIG) > 6; -test 35, index(E2BIG, " ") > 0; - -test 36, @warnings == 0, join "\n", "unexpected warning", @warnings; -@warnings = (); # just in case -undef &PI; -test 37, @warnings && - ($warnings[0] =~ /Constant sub.* undefined/), - shift @warnings; - -test 38, @warnings == 0, "unexpected warning"; -test 39, 1; - -use constant CSCALAR => \"ok 40\n"; -use constant CHASH => { foo => "ok 41\n" }; -use constant CARRAY => [ undef, "ok 42\n" ]; -use constant CPHASH => [ { foo => 1 }, "ok 43\n" ]; -use constant CCODE => sub { "ok $_[0]\n" }; - -print ${+CSCALAR}; -print CHASH->{foo}; -print CARRAY->[1]; -print CPHASH->{foo}; -eval q{ CPHASH->{bar} }; -test 44, scalar($@ =~ /^No such pseudo-hash field/); -print CCODE->(45); -eval q{ CCODE->{foo} }; -test 46, scalar($@ =~ /^Constant is not a HASH/); - -# Allow leading underscore -use constant _PRIVATE => 47; -test 47, _PRIVATE == 47; - -# Disallow doubled leading underscore -eval q{ - use constant __DISALLOWED => "Oops"; -}; -test 48, $@ =~ /begins with '__'/; - -# Check on declared() and %declared. This sub should be EXACTLY the -# same as the one quoted in the docs! -sub declared ($) { - use constant 1.01; # don't omit this! - my $name = shift; - $name =~ s/^::/main::/; - my $pkg = caller; - my $full_name = $name =~ /::/ ? $name : "${pkg}::$name"; - $constant::declared{$full_name}; -} - -test 49, declared 'PI'; -test 50, $constant::declared{'main::PI'}; - -test 51, !declared 'PIE'; -test 52, !$constant::declared{'main::PIE'}; - -{ - package Other; - use constant IN_OTHER_PACK => 42; - ::test 53, ::declared 'IN_OTHER_PACK'; - ::test 54, $constant::declared{'Other::IN_OTHER_PACK'}; - ::test 55, ::declared 'main::PI'; - ::test 56, $constant::declared{'main::PI'}; -} - -test 57, declared 'Other::IN_OTHER_PACK'; -test 58, $constant::declared{'Other::IN_OTHER_PACK'}; - -@warnings = (); -eval q{ - no warnings; - use warnings 'constant'; - use constant 'BEGIN' => 1 ; - use constant 'INIT' => 1 ; - use constant 'CHECK' => 1 ; - use constant 'END' => 1 ; - use constant 'DESTROY' => 1 ; - use constant 'AUTOLOAD' => 1 ; - use constant 'STDIN' => 1 ; - use constant 'STDOUT' => 1 ; - use constant 'STDERR' => 1 ; - use constant 'ARGV' => 1 ; - use constant 'ARGVOUT' => 1 ; - use constant 'ENV' => 1 ; - use constant 'INC' => 1 ; - use constant 'SIG' => 1 ; -}; - -test 59, @warnings == 15 ; -test 60, (shift @warnings) =~ /^Constant name 'BEGIN' is a Perl keyword at/; -shift @warnings; #Constant subroutine BEGIN redefined at -test 61, (shift @warnings) =~ /^Constant name 'INIT' is a Perl keyword at/; -test 62, (shift @warnings) =~ /^Constant name 'CHECK' is a Perl keyword at/; -test 63, (shift @warnings) =~ /^Constant name 'END' is a Perl keyword at/; -test 64, (shift @warnings) =~ /^Constant name 'DESTROY' is a Perl keyword at/; -test 65, (shift @warnings) =~ /^Constant name 'AUTOLOAD' is a Perl keyword at/; -test 66, (shift @warnings) =~ /^Constant name 'STDIN' is forced into package main:: a/; -test 67, (shift @warnings) =~ /^Constant name 'STDOUT' is forced into package main:: at/; -test 68, (shift @warnings) =~ /^Constant name 'STDERR' is forced into package main:: at/; -test 69, (shift @warnings) =~ /^Constant name 'ARGV' is forced into package main:: at/; -test 70, (shift @warnings) =~ /^Constant name 'ARGVOUT' is forced into package main:: at/; -test 71, (shift @warnings) =~ /^Constant name 'ENV' is forced into package main:: at/; -test 72, (shift @warnings) =~ /^Constant name 'INC' is forced into package main:: at/; -test 73, (shift @warnings) =~ /^Constant name 'SIG' is forced into package main:: at/; -@warnings = (); - - -use constant { - THREE => 3, - FAMILY => [ qw( John Jane Sally ) ], - AGES => { John => 33, Jane => 28, Sally => 3 }, - RFAM => [ [ qw( John Jane Sally ) ] ], - SPIT => sub { shift }, - PHFAM => [ { John => 1, Jane => 2, Sally => 3 }, 33, 28, 3 ], -}; - -test 74, @{+FAMILY} == THREE; -test 75, @{+FAMILY} == @{RFAM->[0]}; -test 76, FAMILY->[2] eq RFAM->[0]->[2]; -test 77, AGES->{FAMILY->[1]} == 28; -test 78, PHFAM->{John} == AGES->{John}; -test 79, PHFAM->[3] == AGES->{FAMILY->[2]}; -test 80, @{+PHFAM} == SPIT->(THREE+1); -test 81, THREE**3 eq SPIT->(@{+FAMILY}**3); -test 82, AGES->{FAMILY->[THREE-1]} == PHFAM->[THREE]; diff --git a/t/pragma/diagnostics.t b/t/pragma/diagnostics.t deleted file mode 100755 index 14014f6b68..0000000000 --- a/t/pragma/diagnostics.t +++ /dev/null @@ -1,38 +0,0 @@ -#!./perl - -BEGIN { - chdir '..' if -d '../pod' && -d '../t'; - @INC = 'lib'; -} - - -######################### We start with some black magic to print on failure. - -# Change 1..1 below to 1..last_test_to_print . -# (It may become useful if the test is moved to ./t subdirectory.) -use strict; -use warnings; - -use vars qw($Test_Num $Total_tests); - -my $loaded; -BEGIN { $| = 1; $Test_Num = 1 } -END {print "not ok $Test_Num\n" unless $loaded;} -print "1..$Total_tests\n"; -BEGIN { require diagnostics; } # Don't want diagnostics' noise yet. -$loaded = 1; -ok($loaded, 'compile'); -######################### End of black magic. - -sub ok { - my($test, $name) = shift; - print "not " unless $test; - print "ok $Test_Num"; - print " - $name" if defined $name; - print "\n"; - $Test_Num++; -} - - -# Change this to your # of ok() calls + 1 -BEGIN { $Total_tests = 1 } diff --git a/t/pragma/locale.t b/t/pragma/locale.t deleted file mode 100755 index e58616cbef..0000000000 --- a/t/pragma/locale.t +++ /dev/null @@ -1,839 +0,0 @@ -#!./perl -wT - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - unshift @INC, '.'; - require Config; import Config; - if (!$Config{d_setlocale} || $Config{ccflags} =~ /\bD?NO_LOCALE\b/) { - print "1..0\n"; - exit; - } - $| = 1; -} - -use strict; - -my $debug = 1; - -use Dumpvalue; - -my $dumper = Dumpvalue->new( - tick => qq{"}, - quoteHighBit => 0, - unctrl => "quote" - ); -sub debug { - return unless $debug; - my($mess) = join "", @_; - chop $mess; - print $dumper->stringify($mess,1), "\n"; -} - -sub debugf { - printf @_ if $debug; -} - -my $have_setlocale = 0; -eval { - require POSIX; - import POSIX ':locale_h'; - $have_setlocale++; -}; - -# Visual C's CRT goes silly on strings of the form "en_US.ISO8859-1" -# and mingw32 uses said silly CRT -$have_setlocale = 0 if (($^O eq 'MSWin32' || $^O eq 'NetWare') && $Config{cc} =~ /^(cl|gcc)/i); - -my $last = $have_setlocale ? &last : &last_without_setlocale; - -print "1..$last\n"; - -use vars qw(&LC_ALL); - -$a = 'abc %'; - -sub ok { - my ($n, $result) = @_; - - print 'not ' unless ($result); - print "ok $n\n"; -} - -# First we'll do a lot of taint checking for locales. -# This is the easiest to test, actually, as any locale, -# even the default locale will taint under 'use locale'. - -sub is_tainted { # hello, camel two. - no warnings 'uninitialized' ; - my $dummy; - not eval { $dummy = join("", @_), kill 0; 1 } -} - -sub check_taint ($$) { - ok $_[0], is_tainted($_[1]); -} - -sub check_taint_not ($$) { - ok $_[0], not is_tainted($_[1]); -} - -use locale; # engage locale and therefore locale taint. - -check_taint_not 1, $a; - -check_taint 2, uc($a); -check_taint 3, "\U$a"; -check_taint 4, ucfirst($a); -check_taint 5, "\u$a"; -check_taint 6, lc($a); -check_taint 7, "\L$a"; -check_taint 8, lcfirst($a); -check_taint 9, "\l$a"; - -check_taint_not 10, sprintf('%e', 123.456); -check_taint_not 11, sprintf('%f', 123.456); -check_taint_not 12, sprintf('%g', 123.456); -check_taint_not 13, sprintf('%d', 123.456); -check_taint_not 14, sprintf('%x', 123.456); - -$_ = $a; # untaint $_ - -$_ = uc($a); # taint $_ - -check_taint 15, $_; - -/(\w)/; # taint $&, $`, $', $+, $1. -check_taint 16, $&; -check_taint 17, $`; -check_taint 18, $'; -check_taint 19, $+; -check_taint 20, $1; -check_taint_not 21, $2; - -/(.)/; # untaint $&, $`, $', $+, $1. -check_taint_not 22, $&; -check_taint_not 23, $`; -check_taint_not 24, $'; -check_taint_not 25, $+; -check_taint_not 26, $1; -check_taint_not 27, $2; - -/(\W)/; # taint $&, $`, $', $+, $1. -check_taint 28, $&; -check_taint 29, $`; -check_taint 30, $'; -check_taint 31, $+; -check_taint 32, $1; -check_taint_not 33, $2; - -/(\s)/; # taint $&, $`, $', $+, $1. -check_taint 34, $&; -check_taint 35, $`; -check_taint 36, $'; -check_taint 37, $+; -check_taint 38, $1; -check_taint_not 39, $2; - -/(\S)/; # taint $&, $`, $', $+, $1. -check_taint 40, $&; -check_taint 41, $`; -check_taint 42, $'; -check_taint 43, $+; -check_taint 44, $1; -check_taint_not 45, $2; - -$_ = $a; # untaint $_ - -check_taint_not 46, $_; - -/(b)/; # this must not taint -check_taint_not 47, $&; -check_taint_not 48, $`; -check_taint_not 49, $'; -check_taint_not 50, $+; -check_taint_not 51, $1; -check_taint_not 52, $2; - -$_ = $a; # untaint $_ - -check_taint_not 53, $_; - -$b = uc($a); # taint $b -s/(.+)/$b/; # this must taint only the $_ - -check_taint 54, $_; -check_taint_not 55, $&; -check_taint_not 56, $`; -check_taint_not 57, $'; -check_taint_not 58, $+; -check_taint_not 59, $1; -check_taint_not 60, $2; - -$_ = $a; # untaint $_ - -s/(.+)/b/; # this must not taint -check_taint_not 61, $_; -check_taint_not 62, $&; -check_taint_not 63, $`; -check_taint_not 64, $'; -check_taint_not 65, $+; -check_taint_not 66, $1; -check_taint_not 67, $2; - -$b = $a; # untaint $b - -($b = $a) =~ s/\w/$&/; -check_taint 68, $b; # $b should be tainted. -check_taint_not 69, $a; # $a should be not. - -$_ = $a; # untaint $_ - -s/(\w)/\l$1/; # this must taint -check_taint 70, $_; -check_taint 71, $&; -check_taint 72, $`; -check_taint 73, $'; -check_taint 74, $+; -check_taint 75, $1; -check_taint_not 76, $2; - -$_ = $a; # untaint $_ - -s/(\w)/\L$1/; # this must taint -check_taint 77, $_; -check_taint 78, $&; -check_taint 79, $`; -check_taint 80, $'; -check_taint 81, $+; -check_taint 82, $1; -check_taint_not 83, $2; - -$_ = $a; # untaint $_ - -s/(\w)/\u$1/; # this must taint -check_taint 84, $_; -check_taint 85, $&; -check_taint 86, $`; -check_taint 87, $'; -check_taint 88, $+; -check_taint 89, $1; -check_taint_not 90, $2; - -$_ = $a; # untaint $_ - -s/(\w)/\U$1/; # this must taint -check_taint 91, $_; -check_taint 92, $&; -check_taint 93, $`; -check_taint 94, $'; -check_taint 95, $+; -check_taint 96, $1; -check_taint_not 97, $2; - -# After all this tainting $a should be cool. - -check_taint_not 98, $a; - -sub last_without_setlocale { 98 } - -# I think we've seen quite enough of taint. -# Let us do some *real* locale work now, -# unless setlocale() is missing (i.e. minitest). - -exit unless $have_setlocale; - -# Find locales. - -debug "# Scanning for locales...\n"; - -# Note that it's okay that some languages have their native names -# capitalized here even though that's not "right". They are lowercased -# anyway later during the scanning process (and besides, some clueless -# vendor might have them capitalized errorneously anyway). - -my $locales = <<EOF; -Afrikaans:af:za:1 15 -Arabic:ar:dz eg sa:6 arabic8 -Brezhoneg Breton:br:fr:1 15 -Bulgarski Bulgarian:bg:bg:5 -Chinese:zh:cn tw:cn.EUC eucCN eucTW euc.CN euc.TW Big5 GB2312 tw.EUC -Hrvatski Croatian:hr:hr:2 -Cymraeg Welsh:cy:cy:1 14 15 -Czech:cs:cz:2 -Dansk Danish:dk:da:1 15 -Nederlands Dutch:nl:be nl:1 15 -English American British:en:au ca gb ie nz us uk zw:1 15 cp850 -Esperanto:eo:eo:3 -Eesti Estonian:et:ee:4 6 13 -Suomi Finnish:fi:fi:1 15 -Flamish::fl:1 15 -Deutsch German:de:at be ch de lu:1 15 -Euskaraz Basque:eu:es fr:1 15 -Galego Galician:gl:es:1 15 -Ellada Greek:el:gr:7 g8 -Frysk:fy:nl:1 15 -Greenlandic:kl:gl:4 6 -Hebrew:iw:il:8 hebrew8 -Hungarian:hu:hu:2 -Indonesian:in:id:1 15 -Gaeilge Irish:ga:IE:1 14 15 -Italiano Italian:it:ch it:1 15 -Nihongo Japanese:ja:jp:euc eucJP jp.EUC sjis -Korean:ko:kr: -Latine Latin:la:va:1 15 -Latvian:lv:lv:4 6 13 -Lithuanian:lt:lt:4 6 13 -Macedonian:mk:mk:1 15 -Maltese:mt:mt:3 -Moldovan:mo:mo:2 -Norsk Norwegian:no no\@nynorsk:no:1 15 -Occitan:oc:es:1 15 -Polski Polish:pl:pl:2 -Rumanian:ro:ro:2 -Russki Russian:ru:ru su ua:5 koi8 koi8r KOI8-R koi8u cp1251 cp866 -Serbski Serbian:sr:yu:5 -Slovak:sk:sk:2 -Slovene Slovenian:sl:si:2 -Sqhip Albanian:sq:sq:1 15 -Svenska Swedish:sv:fi se:1 15 -Thai:th:th:11 tis620 -Turkish:tr:tr:9 turkish8 -Yiddish:yi::1 15 -EOF - -if ($^O eq 'os390') { - # These cause heartburn. Broken locales? - $locales =~ s/Svenska Swedish:sv:fi se:1 15\n//; - $locales =~ s/Thai:th:th:11 tis620\n//; -} - -sub in_utf8 () { $^H & 0x08 } - -if (in_utf8) { - require "pragma/locale/utf8"; -} else { - require "pragma/locale/latin1"; -} - -my @Locale; -my $Locale; -my @Alnum_; - -my @utf8locale; -my %utf8skip; - -sub getalnum_ { - sort grep /\w/, map { chr } 0..255 -} - -sub trylocale { - my $locale = shift; - if (setlocale(LC_ALL, $locale)) { - push @Locale, $locale; - } -} - -sub decode_encodings { - my @enc; - - foreach (split(/ /, shift)) { - if (/^(\d+)$/) { - push @enc, "ISO8859-$1"; - push @enc, "iso8859$1"; # HP - if ($1 eq '1') { - push @enc, "roman8"; # HP - } - } else { - push @enc, $_; - push @enc, "$_.UTF-8"; - } - } - if ($^O eq 'os390') { - push @enc, qw(IBM-037 IBM-819 IBM-1047); - } - - return @enc; -} - -trylocale("C"); -trylocale("POSIX"); -foreach (0..15) { - trylocale("ISO8859-$_"); - trylocale("iso8859$_"); - trylocale("iso8859-$_"); - trylocale("iso_8859_$_"); - trylocale("isolatin$_"); - trylocale("isolatin-$_"); - trylocale("iso_latin_$_"); -} - -# Sanitize the environment so that we can run the external 'locale' -# program without the taint mode getting grumpy. - -# $ENV{PATH} is special in VMS. -delete $ENV{PATH} if $^O ne 'VMS' or $Config{d_setenv}; - -# Other subversive stuff. -delete @ENV{qw(IFS CDPATH ENV BASH_ENV)}; - -if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a 2>/dev/null|")) { - while (<LOCALES>) { - chomp; - trylocale($_); - } - close(LOCALES); -} elsif ($^O eq 'VMS' && defined($ENV{'SYS$I18N_LOCALE'}) && -d 'SYS$I18N_LOCALE') { -# The SYS$I18N_LOCALE logical name search list was not present on -# VAX VMS V5.5-12, but was on AXP && VAX VMS V6.2 as well as later versions. - opendir(LOCALES, "SYS\$I18N_LOCALE:"); - while ($_ = readdir(LOCALES)) { - chomp; - trylocale($_); - } - close(LOCALES); -} else { - - # This is going to be slow. - - foreach my $locale (split(/\n/, $locales)) { - my ($locale_name, $language_codes, $country_codes, $encodings) = - split(/:/, $locale); - my @enc = decode_encodings($encodings); - foreach my $loc (split(/ /, $locale_name)) { - trylocale($loc); - foreach my $enc (@enc) { - trylocale("$loc.$enc"); - } - $loc = lc $loc; - foreach my $enc (@enc) { - trylocale("$loc.$enc"); - } - } - foreach my $lang (split(/ /, $language_codes)) { - trylocale($lang); - foreach my $country (split(/ /, $country_codes)) { - my $lc = "${lang}_${country}"; - trylocale($lc); - foreach my $enc (@enc) { - trylocale("$lc.$enc"); - } - my $lC = "${lang}_\U${country}"; - trylocale($lC); - foreach my $enc (@enc) { - trylocale("$lC.$enc"); - } - } - } - } -} - -setlocale(LC_ALL, "C"); - -sub utf8locale { $_[0] =~ /utf-?8/i } - -@Locale = sort @Locale; - -debug "# Locales = @Locale\n"; - -my %Problem; -my %Okay; -my %Testing; -my @Neoalpha; -my %Neoalpha; - -sub tryneoalpha { - my ($Locale, $i, $test) = @_; - unless ($test) { - $Problem{$i}{$Locale} = 1; - debug "# failed $i with locale '$Locale'\n"; - } else { - push @{$Okay{$i}}, $Locale; - } -} - -foreach $Locale (@Locale) { - debug "# Locale = $Locale\n"; - @Alnum_ = getalnum_(); - debug "# w = ", join("",@Alnum_), "\n"; - - unless (setlocale(LC_ALL, $Locale)) { - foreach (99..103) { - $Problem{$_}{$Locale} = -1; - } - next; - } - - # Sieve the uppercase and the lowercase. - - my %UPPER = (); - my %lower = (); - my %BoThCaSe = (); - for (@Alnum_) { - if (/[^\d_]/) { # skip digits and the _ - if (uc($_) eq $_) { - $UPPER{$_} = $_; - } - if (lc($_) eq $_) { - $lower{$_} = $_; - } - } - } - foreach (keys %UPPER) { - $BoThCaSe{$_}++ if exists $lower{$_}; - } - foreach (keys %lower) { - $BoThCaSe{$_}++ if exists $UPPER{$_}; - } - foreach (keys %BoThCaSe) { - delete $UPPER{$_}; - delete $lower{$_}; - } - - debug "# UPPER = ", join("", sort keys %UPPER ), "\n"; - debug "# lower = ", join("", sort keys %lower ), "\n"; - debug "# BoThCaSe = ", join("", sort keys %BoThCaSe), "\n"; - - # Find the alphabets that are not alphabets in the default locale. - - { - no locale; - - @Neoalpha = (); - for (keys %UPPER, keys %lower) { - push(@Neoalpha, $_) if (/\W/); - $Neoalpha{$_} = $_; - } - } - - @Neoalpha = sort @Neoalpha; - - debug "# Neoalpha = ", join("",@Neoalpha), "\n"; - - if (@Neoalpha == 0) { - # If we have no Neoalphas the remaining tests are no-ops. - debug "# no Neoalpha, skipping tests 99..102 for locale '$Locale'\n"; - foreach (99..102) { - push @{$Okay{$_}}, $Locale; - } - } else { - - # Test \w. - - if (utf8locale($Locale)) { - # utf8 and locales do not mix. - debug "# skipping UTF-8 locale '$Locale'\n"; - push @utf8locale, $Locale; - @utf8skip{99..102} = (); - } else { - my $word = join('', @Neoalpha); - - $word =~ /^(\w+)$/; - - tryneoalpha($Locale, 99, $1 eq $word); - } - # Cross-check the whole 8-bit character set. - - for (map { chr } 0..255) { - tryneoalpha($Locale, 100, - (/\w/ xor /\W/) || - (/\d/ xor /\D/) || - (/\s/ xor /\S/)); - } - - # Test for read-only scalars' locale vs non-locale comparisons. - - { - no locale; - $a = "qwerty"; - { - use locale; - tryneoalpha($Locale, 101, ($a cmp "qwerty") == 0); - } - } - - { - my ($from, $to, $lesser, $greater, - @test, %test, $test, $yes, $no, $sign); - - for (0..9) { - # Select a slice. - $from = int(($_*@Alnum_)/10); - $to = $from + int(@Alnum_/10); - $to = $#Alnum_ if ($to > $#Alnum_); - $lesser = join('', @Alnum_[$from..$to]); - # Select a slice one character on. - $from++; $to++; - $to = $#Alnum_ if ($to > $#Alnum_); - $greater = join('', @Alnum_[$from..$to]); - ($yes, $no, $sign) = ($lesser lt $greater - ? (" ", "not ", 1) - : ("not ", " ", -1)); - # all these tests should FAIL (return 0). - # Exact lt or gt cannot be tested because - # in some locales, say, eacute and E may test equal. - @test = - ( - $no.' ($lesser le $greater)', # 1 - 'not ($lesser ne $greater)', # 2 - ' ($lesser eq $greater)', # 3 - $yes.' ($lesser ge $greater)', # 4 - $yes.' ($lesser ge $greater)', # 5 - $yes.' ($greater le $lesser )', # 7 - 'not ($greater ne $lesser )', # 8 - ' ($greater eq $lesser )', # 9 - $no.' ($greater ge $lesser )', # 10 - 'not (($lesser cmp $greater) == -($sign))' # 11 - ); - @test{@test} = 0 x @test; - $test = 0; - for my $ti (@test) { - $test{$ti} = eval $ti; - $test ||= $test{$ti} - } - tryneoalpha($Locale, 102, $test == 0); - if ($test) { - debug "# lesser = '$lesser'\n"; - debug "# greater = '$greater'\n"; - debug "# lesser cmp greater = ", - $lesser cmp $greater, "\n"; - debug "# greater cmp lesser = ", - $greater cmp $lesser, "\n"; - debug "# (greater) from = $from, to = $to\n"; - for my $ti (@test) { - debugf("# %-40s %-4s", $ti, - $test{$ti} ? 'FAIL' : 'ok'); - if ($ti =~ /\(\.*(\$.+ +cmp +\$[^\)]+)\.*\)/) { - debugf("(%s == %4d)", $1, eval $1); - } - debug "\n#"; - } - - last; - } - } - } - } - - use locale; - - my ($x, $y) = (1.23, 1.23); - - $a = "$x"; - printf ''; # printf used to reset locale to "C" - $b = "$y"; - - debug "# 103..107: a = $a, b = $b, Locale = $Locale\n"; - - tryneoalpha($Locale, 103, $a eq $b); - - my $c = "$x"; - my $z = sprintf ''; # sprintf used to reset locale to "C" - my $d = "$y"; - - debug "# 104..107: c = $c, d = $d, Locale = $Locale\n"; - - tryneoalpha($Locale, 104, $c eq $d); - - { - use warnings; - my $w = 0; - local $SIG{__WARN__} = - sub { - print "# @_\n"; - $w++; - }; - - # The == (among other ops) used to warn for locales - # that had something else than "." as the radix character. - - tryneoalpha($Locale, 105, $c == 1.23); - - tryneoalpha($Locale, 106, $c == $x); - - tryneoalpha($Locale, 107, $c == $d); - - { -# no locale; # XXX did this ever work correctly? - - my $e = "$x"; - - debug "# 108..110: e = $e, Locale = $Locale\n"; - - tryneoalpha($Locale, 108, $e == 1.23); - - tryneoalpha($Locale, 109, $e == $x); - - tryneoalpha($Locale, 110, $e == $c); - } - - my $f = "1.23"; - my $g = 2.34; - - debug "# 111..115: f = $f, g = $g, locale = $Locale\n"; - - tryneoalpha($Locale, 111, $f == 1.23); - - tryneoalpha($Locale, 112, $f == $x); - - tryneoalpha($Locale, 113, $f == $c); - - tryneoalpha($Locale, 114, abs(($f + $g) - 3.57) < 0.01); - - tryneoalpha($Locale, 115, $w == 0); - } - - # Does taking lc separately differ from taking - # the lc "in-line"? (This was the bug 19990704.002, change #3568.) - # The bug was in the caching of the 'o'-magic. - { - use locale; - - sub lcA { - my $lc0 = lc $_[0]; - my $lc1 = lc $_[1]; - return $lc0 cmp $lc1; - } - - sub lcB { - return lc($_[0]) cmp lc($_[1]); - } - - my $x = "ab"; - my $y = "aa"; - my $z = "AB"; - - tryneoalpha($Locale, 116, - lcA($x, $y) == 1 && lcB($x, $y) == 1 || - lcA($x, $z) == 0 && lcB($x, $z) == 0); - } - - # Does lc of an UPPER (if different from the UPPER) match - # case-insensitively the UPPER, and does the UPPER match - # case-insensitively the lc of the UPPER. And vice versa. - { - if (utf8locale($Locale)) { - # utf8 and locales do not mix. - debug "# skipping UTF-8 locale '$Locale'\n"; - push @utf8locale, $Locale; - $utf8skip{117}++; - } else { - use locale; - use locale; - no utf8; # so that the native 8-bit characters work - - my @f = (); - foreach my $x (keys %UPPER) { - my $y = lc $x; - next unless uc $y eq $x; - push @f, $x unless $x =~ /$y/i && $y =~ /$x/i; - } - foreach my $x (keys %lower) { - my $y = uc $x; - next unless lc $y eq $x; - push @f, $x unless $x =~ /$y/i && $y =~ /$x/i; - } - tryneoalpha($Locale, 117, @f == 0); - if (@f) { - print "# failed 117 locale '$Locale' characters @f\n" - } - } - } -} - -# Recount the errors. - -foreach (&last_without_setlocale()+1..$last) { - if ($Problem{$_} || !defined $Okay{$_} || !@{$Okay{$_}}) { - if ($_ == 102) { - print "# The failure of test 102 is not necessarily fatal.\n"; - print "# It usually indicates a problem in the enviroment,\n"; - print "# not in Perl itself.\n"; - } - print "not "; - } - print "ok $_\n"; -} - -# Give final advice. - -my $didwarn = 0; - -foreach (99..$last) { - if ($Problem{$_}) { - my @f = sort keys %{ $Problem{$_} }; - my $f = join(" ", @f); - $f =~ s/(.{50,60}) /$1\n#\t/g; - print - "#\n", - "# The locale ", (@f == 1 ? "definition" : "definitions"), "\n#\n", - "#\t", $f, "\n#\n", - "# on your system may have errors because the locale test $_\n", - "# failed in ", (@f == 1 ? "that locale" : "those locales"), - ".\n"; - print <<EOW; -# -# If your users are not using these locales you are safe for the moment, -# but please report this failure first to perlbug\@perl.com using the -# perlbug script (as described in the INSTALL file) so that the exact -# details of the failures can be sorted out first and then your operating -# system supplier can be alerted about these anomalies. -# -EOW - $didwarn = 1; - } -} - -# Tell which locales were okay and which were not. - -if ($didwarn) { - my (@s, @F); - - foreach my $l (@Locale) { - my $p = 0; - foreach my $t (102..$last) { - $p++ if $Problem{$t}{$l}; - } - push @s, $l if $p == 0; - push @F, $l unless $p == 0; - } - - if (@s) { - my $s = join(" ", @s); - $s =~ s/(.{50,60}) /$1\n#\t/g; - - warn - "# The following locales\n#\n", - "#\t", $s, "\n#\n", - "# tested okay.\n#\n", - } else { - warn "# None of your locales were fully okay.\n"; - } - - if (@F) { - my $F = join(" ", @F); - $F =~ s/(.{50,60}) /$1\n#\t/g; - - warn - "# The following locales\n#\n", - "#\t", $F, "\n#\n", - "# had problems.\n#\n", - } else { - warn "# None of your locales were broken.\n"; - } - - if (@utf8locale) { - my $S = join(" ", @utf8locale); - $S =~ s/(.{50,60}) /$1\n#\t/g; - - warn "#\n# The following locales\n#\n", - "#\t", $S, "\n#\n", - "# were skipped for the tests ", - join(" ", sort {$a<=>$b} keys %utf8skip), "\n", - "# because UTF-8 and locales do not work together in Perl.\n#\n"; - } -} - -sub last { 117 } - -# eof diff --git a/t/pragma/locale/latin1 b/t/pragma/locale/latin1 deleted file mode 100644 index f40f7325e0..0000000000 --- a/t/pragma/locale/latin1 +++ /dev/null @@ -1,10 +0,0 @@ -$locales .= <<EOF; -Catal Catalan:ca:es:1 15 -Franais French:fr:be ca ch fr lu:1 15 -Gidhlig Gaelic:gd:gb uk:1 14 15 -Froyskt Faroese:fo:fo:1 15 -slensku Icelandic:is:is:1 15 -Smi Lappish:::4 6 13 -Portugus Portuguese:po:po br:1 15 -Espanl Spanish:es:ar bo cl co cr do ec es gt hn mx ni pa pe py sv uy ve:1 15 -EOF diff --git a/t/pragma/locale/utf8 b/t/pragma/locale/utf8 deleted file mode 100644 index fbbe94fb51..0000000000 --- a/t/pragma/locale/utf8 +++ /dev/null @@ -1,10 +0,0 @@ -$locales .= <<EOF; -Català Catalan:ca:es:1 15 -Français French:fr:be ca ch fr lu:1 15 -Gáidhlig Gaelic:gd:gb uk:1 14 15 -Føroyskt Faroese:fo:fo:1 15 -Íslensku Icelandic:is:is:1 15 -Sámi Lappish:::4 6 13 -Português Portuguese:po:po br:1 15 -Espanõl Spanish:es:ar bo cl co cr do ec es gt hn mx ni pa pe py sv uy ve:1 15 -EOF diff --git a/t/pragma/overload.t b/t/pragma/overload.t deleted file mode 100755 index d07506261d..0000000000 --- a/t/pragma/overload.t +++ /dev/null @@ -1,1050 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -package Oscalar; -use overload ( - # Anonymous subroutines: -'+' => sub {new Oscalar $ {$_[0]}+$_[1]}, -'-' => sub {new Oscalar - $_[2]? $_[1]-${$_[0]} : ${$_[0]}-$_[1]}, -'<=>' => sub {new Oscalar - $_[2]? $_[1]-${$_[0]} : ${$_[0]}-$_[1]}, -'cmp' => sub {new Oscalar - $_[2]? ($_[1] cmp ${$_[0]}) : (${$_[0]} cmp $_[1])}, -'*' => sub {new Oscalar ${$_[0]}*$_[1]}, -'/' => sub {new Oscalar - $_[2]? $_[1]/${$_[0]} : - ${$_[0]}/$_[1]}, -'%' => sub {new Oscalar - $_[2]? $_[1]%${$_[0]} : ${$_[0]}%$_[1]}, -'**' => sub {new Oscalar - $_[2]? $_[1]**${$_[0]} : ${$_[0]}-$_[1]}, - -qw( -"" stringify -0+ numify) # Order of arguments unsignificant -); - -sub new { - my $foo = $_[1]; - bless \$foo, $_[0]; -} - -sub stringify { "${$_[0]}" } -sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead - # comparing to direct compilation based on - # stringify - -package main; - -$test = 0; -$| = 1; -print "1..",&last,"\n"; - -sub test { - $test++; - if (@_ > 1) { - if ($_[0] eq $_[1]) { - print "ok $test\n"; - } else { - print "not ok $test: '$_[0]' ne '$_[1]'\n"; - } - } else { - if (shift) { - print "ok $test\n"; - } else { - print "not ok $test\n"; - } - } -} - -$a = new Oscalar "087"; -$b= "$a"; - -# All test numbers in comments are off by 1. -# So much for hard-wiring them in :-) To fix this: -test(1); # 1 - -test ($b eq $a); # 2 -test ($b eq "087"); # 3 -test (ref $a eq "Oscalar"); # 4 -test ($a eq $a); # 5 -test ($a eq "087"); # 6 - -$c = $a + 7; - -test (ref $c eq "Oscalar"); # 7 -test (!($c eq $a)); # 8 -test ($c eq "94"); # 9 - -$b=$a; - -test (ref $a eq "Oscalar"); # 10 - -$b++; - -test (ref $b eq "Oscalar"); # 11 -test ( $a eq "087"); # 12 -test ( $b eq "88"); # 13 -test (ref $a eq "Oscalar"); # 14 - -$c=$b; -$c-=$a; - -test (ref $c eq "Oscalar"); # 15 -test ( $a eq "087"); # 16 -test ( $c eq "1"); # 17 -test (ref $a eq "Oscalar"); # 18 - -$b=1; -$b+=$a; - -test (ref $b eq "Oscalar"); # 19 -test ( $a eq "087"); # 20 -test ( $b eq "88"); # 21 -test (ref $a eq "Oscalar"); # 22 - -eval q[ package Oscalar; use overload ('++' => sub { $ {$_[0]}++;$_[0] } ) ]; - -$b=$a; - -test (ref $a eq "Oscalar"); # 23 - -$b++; - -test (ref $b eq "Oscalar"); # 24 -test ( $a eq "087"); # 25 -test ( $b eq "88"); # 26 -test (ref $a eq "Oscalar"); # 27 - -package Oscalar; -$dummy=bless \$dummy; # Now cache of method should be reloaded -package main; - -$b=$a; -$b++; - -test (ref $b eq "Oscalar"); # 28 -test ( $a eq "087"); # 29 -test ( $b eq "88"); # 30 -test (ref $a eq "Oscalar"); # 31 - -undef $b; # Destroying updates tables too... - -eval q[package Oscalar; use overload ('++' => sub { $ {$_[0]} += 2; $_[0] } ) ]; - -$b=$a; - -test (ref $a eq "Oscalar"); # 32 - -$b++; - -test (ref $b eq "Oscalar"); # 33 -test ( $a eq "087"); # 34 -test ( $b eq "88"); # 35 -test (ref $a eq "Oscalar"); # 36 - -package Oscalar; -$dummy=bless \$dummy; # Now cache of method should be reloaded -package main; - -$b++; - -test (ref $b eq "Oscalar"); # 37 -test ( $a eq "087"); # 38 -test ( $b eq "90"); # 39 -test (ref $a eq "Oscalar"); # 40 - -$b=$a; -$b++; - -test (ref $b eq "Oscalar"); # 41 -test ( $a eq "087"); # 42 -test ( $b eq "89"); # 43 -test (ref $a eq "Oscalar"); # 44 - - -test ($b? 1:0); # 45 - -eval q[ package Oscalar; use overload ('=' => sub {$main::copies++; - package Oscalar; - local $new=$ {$_[0]}; - bless \$new } ) ]; - -$b=new Oscalar "$a"; - -test (ref $b eq "Oscalar"); # 46 -test ( $a eq "087"); # 47 -test ( $b eq "087"); # 48 -test (ref $a eq "Oscalar"); # 49 - -$b++; - -test (ref $b eq "Oscalar"); # 50 -test ( $a eq "087"); # 51 -test ( $b eq "89"); # 52 -test (ref $a eq "Oscalar"); # 53 -test ($copies == 0); # 54 - -$b+=1; - -test (ref $b eq "Oscalar"); # 55 -test ( $a eq "087"); # 56 -test ( $b eq "90"); # 57 -test (ref $a eq "Oscalar"); # 58 -test ($copies == 0); # 59 - -$b=$a; -$b+=1; - -test (ref $b eq "Oscalar"); # 60 -test ( $a eq "087"); # 61 -test ( $b eq "88"); # 62 -test (ref $a eq "Oscalar"); # 63 -test ($copies == 0); # 64 - -$b=$a; -$b++; - -test (ref $b eq "Oscalar") || print ref $b,"=ref(b)\n"; # 65 -test ( $a eq "087"); # 66 -test ( $b eq "89"); # 67 -test (ref $a eq "Oscalar"); # 68 -test ($copies == 1); # 69 - -eval q[package Oscalar; use overload ('+=' => sub {$ {$_[0]} += 3*$_[1]; - $_[0] } ) ]; -$c=new Oscalar; # Cause rehash - -$b=$a; -$b+=1; - -test (ref $b eq "Oscalar"); # 70 -test ( $a eq "087"); # 71 -test ( $b eq "90"); # 72 -test (ref $a eq "Oscalar"); # 73 -test ($copies == 2); # 74 - -$b+=$b; - -test (ref $b eq "Oscalar"); # 75 -test ( $b eq "360"); # 76 -test ($copies == 2); # 77 -$b=-$b; - -test (ref $b eq "Oscalar"); # 78 -test ( $b eq "-360"); # 79 -test ($copies == 2); # 80 - -$b=abs($b); - -test (ref $b eq "Oscalar"); # 81 -test ( $b eq "360"); # 82 -test ($copies == 2); # 83 - -$b=abs($b); - -test (ref $b eq "Oscalar"); # 84 -test ( $b eq "360"); # 85 -test ($copies == 2); # 86 - -eval q[package Oscalar; - use overload ('x' => sub {new Oscalar ( $_[2] ? "_.$_[1]._" x $ {$_[0]} - : "_.${$_[0]}._" x $_[1])}) ]; - -$a=new Oscalar "yy"; -$a x= 3; -test ($a eq "_.yy.__.yy.__.yy._"); # 87 - -eval q[package Oscalar; - use overload ('.' => sub {new Oscalar ( $_[2] ? - "_.$_[1].__.$ {$_[0]}._" - : "_.$ {$_[0]}.__.$_[1]._")}) ]; - -$a=new Oscalar "xx"; - -test ("b${a}c" eq "_._.b.__.xx._.__.c._"); # 88 - -# Check inheritance of overloading; -{ - package OscalarI; - @ISA = 'Oscalar'; -} - -$aI = new OscalarI "$a"; -test (ref $aI eq "OscalarI"); # 89 -test ("$aI" eq "xx"); # 90 -test ($aI eq "xx"); # 91 -test ("b${aI}c" eq "_._.b.__.xx._.__.c._"); # 92 - -# Here we test blessing to a package updates hash - -eval "package Oscalar; no overload '.'"; - -test ("b${a}" eq "_.b.__.xx._"); # 93 -$x="1"; -bless \$x, Oscalar; -test ("b${a}c" eq "bxxc"); # 94 -new Oscalar 1; -test ("b${a}c" eq "bxxc"); # 95 - -# Negative overloading: - -$na = eval { ~$a }; -test($@ =~ /no method found/); # 96 - -# Check AUTOLOADING: - -*Oscalar::AUTOLOAD = - sub { *{"Oscalar::$AUTOLOAD"} = sub {"_!_" . shift() . "_!_"} ; - goto &{"Oscalar::$AUTOLOAD"}}; - -eval "package Oscalar; sub comple; use overload '~' => 'comple'"; - -$na = eval { ~$a }; # Hash was not updated -test($@ =~ /no method found/); # 97 - -bless \$x, Oscalar; - -$na = eval { ~$a }; # Hash updated -warn "`$na', $@" if $@; -test !$@; # 98 -test($na eq '_!_xx_!_'); # 99 - -$na = 0; - -$na = eval { ~$aI }; # Hash was not updated -test($@ =~ /no method found/); # 100 - -bless \$x, OscalarI; - -$na = eval { ~$aI }; -print $@; - -test !$@; # 101 -test($na eq '_!_xx_!_'); # 102 - -eval "package Oscalar; sub rshft; use overload '>>' => 'rshft'"; - -$na = eval { $aI >> 1 }; # Hash was not updated -test($@ =~ /no method found/); # 103 - -bless \$x, OscalarI; - -$na = 0; - -$na = eval { $aI >> 1 }; -print $@; - -test !$@; # 104 -test($na eq '_!_xx_!_'); # 105 - -# warn overload::Method($a, '0+'), "\n"; -test (overload::Method($a, '0+') eq \&Oscalar::numify); # 106 -test (overload::Method($aI,'0+') eq \&Oscalar::numify); # 107 -test (overload::Overloaded($aI)); # 108 -test (!overload::Overloaded('overload')); # 109 - -test (! defined overload::Method($aI, '<<')); # 110 -test (! defined overload::Method($a, '<')); # 111 - -test (overload::StrVal($aI) =~ /^OscalarI=SCALAR\(0x[\da-fA-F]+\)$/); # 112 -test (overload::StrVal(\$aI) eq "@{[\$aI]}"); # 113 - -# Check overloading by methods (specified deep in the ISA tree). -{ - package OscalarII; - @ISA = 'OscalarI'; - sub Oscalar::lshft {"_<<_" . shift() . "_<<_"} - eval "package OscalarI; use overload '<<' => 'lshft', '|' => 'lshft'"; -} - -$aaII = "087"; -$aII = \$aaII; -bless $aII, 'OscalarII'; -bless \$fake, 'OscalarI'; # update the hash -test(($aI | 3) eq '_<<_xx_<<_'); # 114 -# warn $aII << 3; -test(($aII << 3) eq '_<<_087_<<_'); # 115 - -{ - BEGIN { $int = 7; overload::constant 'integer' => sub {$int++; shift}; } - $out = 2**10; -} -test($int, 9); # 116 -test($out, 1024); # 117 - -$foo = 'foo'; -$foo1 = 'f\'o\\o'; -{ - BEGIN { $q = $qr = 7; - overload::constant 'q' => sub {$q++; push @q, shift, ($_[1] || 'none'); shift}, - 'qr' => sub {$qr++; push @qr, shift, ($_[1] || 'none'); shift}; } - $out = 'foo'; - $out1 = 'f\'o\\o'; - $out2 = "a\a$foo,\,"; - /b\b$foo.\./; -} - -test($out, 'foo'); # 118 -test($out, $foo); # 119 -test($out1, 'f\'o\\o'); # 120 -test($out1, $foo1); # 121 -test($out2, "a\afoo,\,"); # 122 -test("@q", "foo q f'o\\\\o q a\\a qq ,\\, qq"); # 123 -test($q, 11); # 124 -test("@qr", "b\\b qq .\\. qq"); # 125 -test($qr, 9); # 126 - -{ - $_ = '!<b>!foo!<-.>!'; - BEGIN { overload::constant 'q' => sub {push @q1, shift, ($_[1] || 'none'); "_<" . (shift) . ">_"}, - 'qr' => sub {push @qr1, shift, ($_[1] || 'none'); "!<" . (shift) . ">!"}; } - $out = 'foo'; - $out1 = 'f\'o\\o'; - $out2 = "a\a$foo,\,"; - $res = /b\b$foo.\./; - $a = <<EOF; -oups -EOF - $b = <<'EOF'; -oups1 -EOF - $c = bareword; - m'try it'; - s'first part'second part'; - s/yet another/tail here/; - tr/A-Z/a-z/; -} - -test($out, '_<foo>_'); # 117 -test($out1, '_<f\'o\\o>_'); # 128 -test($out2, "_<a\a>_foo_<,\,>_"); # 129 -test("@q1", "foo q f'o\\\\o q a\\a qq ,\\, qq oups - qq oups1 - q second part q tail here s A-Z tr a-z tr"); # 130 -test("@qr1", "b\\b qq .\\. qq try it q first part q yet another qq"); # 131 -test($res, 1); # 132 -test($a, "_<oups ->_"); # 133 -test($b, "_<oups1 ->_"); # 134 -test($c, "bareword"); # 135 - -{ - package symbolic; # Primitive symbolic calculator - use overload nomethod => \&wrap, '""' => \&str, '0+' => \&num, - '=' => \&cpy, '++' => \&inc, '--' => \&dec; - - sub new { shift; bless ['n', @_] } - sub cpy { - my $self = shift; - bless [@$self], ref $self; - } - sub inc { $_[0] = bless ['++', $_[0], 1]; } - sub dec { $_[0] = bless ['--', $_[0], 1]; } - sub wrap { - my ($obj, $other, $inv, $meth) = @_; - if ($meth eq '++' or $meth eq '--') { - @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference - return $obj; - } - ($obj, $other) = ($other, $obj) if $inv; - bless [$meth, $obj, $other]; - } - sub str { - my ($meth, $a, $b) = @{+shift}; - $a = 'u' unless defined $a; - if (defined $b) { - "[$meth $a $b]"; - } else { - "[$meth $a]"; - } - } - my %subr = ( 'n' => sub {$_[0]} ); - foreach my $op (split " ", $overload::ops{with_assign}) { - $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}"; - } - my @bins = qw(binary 3way_comparison num_comparison str_comparison); - foreach my $op (split " ", "@overload::ops{ @bins }") { - $subr{$op} = eval "sub {shift() $op shift()}"; - } - foreach my $op (split " ", "@overload::ops{qw(unary func)}") { - $subr{$op} = eval "sub {$op shift()}"; - } - $subr{'++'} = $subr{'+'}; - $subr{'--'} = $subr{'-'}; - - sub num { - my ($meth, $a, $b) = @{+shift}; - my $subr = $subr{$meth} - or die "Do not know how to ($meth) in symbolic"; - $a = $a->num if ref $a eq __PACKAGE__; - $b = $b->num if ref $b eq __PACKAGE__; - $subr->($a,$b); - } - sub TIESCALAR { my $pack = shift; $pack->new(@_) } - sub FETCH { shift } - sub nop { } # Around a bug - sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; } - sub STORE { - my $obj = shift; - $#$obj = 1; - $obj->[1] = shift; - } -} - -{ - my $foo = new symbolic 11; - my $baz = $foo++; - test( (sprintf "%d", $foo), '12'); - test( (sprintf "%d", $baz), '11'); - my $bar = $foo; - $baz = ++$foo; - test( (sprintf "%d", $foo), '13'); - test( (sprintf "%d", $bar), '12'); - test( (sprintf "%d", $baz), '13'); - my $ban = $foo; - $baz = ($foo += 1); - test( (sprintf "%d", $foo), '14'); - test( (sprintf "%d", $bar), '12'); - test( (sprintf "%d", $baz), '14'); - test( (sprintf "%d", $ban), '13'); - $baz = 0; - $baz = $foo++; - test( (sprintf "%d", $foo), '15'); - test( (sprintf "%d", $baz), '14'); - test( "$foo", '[++ [+= [++ [++ [n 11] 1] 1] 1] 1]'); -} - -{ - my $iter = new symbolic 2; - my $side = new symbolic 1; - my $cnt = $iter; - - while ($cnt) { - $cnt = $cnt - 1; # The "simple" way - $side = (sqrt(1 + $side**2) - 1)/$side; - } - my $pi = $side*(2**($iter+2)); - test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]'; - test( (sprintf "%f", $pi), '3.182598'); -} - -{ - my $iter = new symbolic 2; - my $side = new symbolic 1; - my $cnt = $iter; - - while ($cnt--) { - $side = (sqrt(1 + $side**2) - 1)/$side; - } - my $pi = $side*(2**($iter+2)); - test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]'; - test( (sprintf "%f", $pi), '3.182598'); -} - -{ - my ($a, $b); - symbolic->vars($a, $b); - my $c = sqrt($a**2 + $b**2); - $a = 3; $b = 4; - test( (sprintf "%d", $c), '5'); - $a = 12; $b = 5; - test( (sprintf "%d", $c), '13'); -} - -{ - package symbolic1; # Primitive symbolic calculator - # Mutator inc/dec - use overload nomethod => \&wrap, '""' => \&str, '0+' => \&num, '=' => \&cpy; - - sub new { shift; bless ['n', @_] } - sub cpy { - my $self = shift; - bless [@$self], ref $self; - } - sub wrap { - my ($obj, $other, $inv, $meth) = @_; - if ($meth eq '++' or $meth eq '--') { - @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference - return $obj; - } - ($obj, $other) = ($other, $obj) if $inv; - bless [$meth, $obj, $other]; - } - sub str { - my ($meth, $a, $b) = @{+shift}; - $a = 'u' unless defined $a; - if (defined $b) { - "[$meth $a $b]"; - } else { - "[$meth $a]"; - } - } - my %subr = ( 'n' => sub {$_[0]} ); - foreach my $op (split " ", $overload::ops{with_assign}) { - $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}"; - } - my @bins = qw(binary 3way_comparison num_comparison str_comparison); - foreach my $op (split " ", "@overload::ops{ @bins }") { - $subr{$op} = eval "sub {shift() $op shift()}"; - } - foreach my $op (split " ", "@overload::ops{qw(unary func)}") { - $subr{$op} = eval "sub {$op shift()}"; - } - $subr{'++'} = $subr{'+'}; - $subr{'--'} = $subr{'-'}; - - sub num { - my ($meth, $a, $b) = @{+shift}; - my $subr = $subr{$meth} - or die "Do not know how to ($meth) in symbolic"; - $a = $a->num if ref $a eq __PACKAGE__; - $b = $b->num if ref $b eq __PACKAGE__; - $subr->($a,$b); - } - sub TIESCALAR { my $pack = shift; $pack->new(@_) } - sub FETCH { shift } - sub nop { } # Around a bug - sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; } - sub STORE { - my $obj = shift; - $#$obj = 1; - $obj->[1] = shift; - } -} - -{ - my $foo = new symbolic1 11; - my $baz = $foo++; - test( (sprintf "%d", $foo), '12'); - test( (sprintf "%d", $baz), '11'); - my $bar = $foo; - $baz = ++$foo; - test( (sprintf "%d", $foo), '13'); - test( (sprintf "%d", $bar), '12'); - test( (sprintf "%d", $baz), '13'); - my $ban = $foo; - $baz = ($foo += 1); - test( (sprintf "%d", $foo), '14'); - test( (sprintf "%d", $bar), '12'); - test( (sprintf "%d", $baz), '14'); - test( (sprintf "%d", $ban), '13'); - $baz = 0; - $baz = $foo++; - test( (sprintf "%d", $foo), '15'); - test( (sprintf "%d", $baz), '14'); - test( "$foo", '[++ [+= [++ [++ [n 11] 1] 1] 1] 1]'); -} - -{ - my $iter = new symbolic1 2; - my $side = new symbolic1 1; - my $cnt = $iter; - - while ($cnt) { - $cnt = $cnt - 1; # The "simple" way - $side = (sqrt(1 + $side**2) - 1)/$side; - } - my $pi = $side*(2**($iter+2)); - test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]'; - test( (sprintf "%f", $pi), '3.182598'); -} - -{ - my $iter = new symbolic1 2; - my $side = new symbolic1 1; - my $cnt = $iter; - - while ($cnt--) { - $side = (sqrt(1 + $side**2) - 1)/$side; - } - my $pi = $side*(2**($iter+2)); - test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]'; - test( (sprintf "%f", $pi), '3.182598'); -} - -{ - my ($a, $b); - symbolic1->vars($a, $b); - my $c = sqrt($a**2 + $b**2); - $a = 3; $b = 4; - test( (sprintf "%d", $c), '5'); - $a = 12; $b = 5; - test( (sprintf "%d", $c), '13'); -} - -{ - package two_face; # Scalars with separate string and - # numeric values. - sub new { my $p = shift; bless [@_], $p } - use overload '""' => \&str, '0+' => \&num, fallback => 1; - sub num {shift->[1]} - sub str {shift->[0]} -} - -{ - my $seven = new two_face ("vii", 7); - test( (sprintf "seven=$seven, seven=%d, eight=%d", $seven, $seven+1), - 'seven=vii, seven=7, eight=8'); - test( scalar ($seven =~ /i/), '1') -} - -{ - package sorting; - use overload 'cmp' => \∁ - sub new { my ($p, $v) = @_; bless \$v, $p } - sub comp { my ($x,$y) = @_; ($$x * 3 % 10) <=> ($$y * 3 % 10) or $$x cmp $$y } -} -{ - my @arr = map sorting->new($_), 0..12; - my @sorted1 = sort @arr; - my @sorted2 = map $$_, @sorted1; - test "@sorted2", '0 10 7 4 1 11 8 5 12 2 9 6 3'; -} -{ - package iterator; - use overload '<>' => \&iter; - sub new { my ($p, $v) = @_; bless \$v, $p } - sub iter { my ($x) = @_; return undef if $$x < 0; return $$x--; } -} - -# XXX iterator overload not intended to work with CORE::GLOBAL? -if (defined &CORE::GLOBAL::glob) { - test '1', '1'; # 175 - test '1', '1'; # 176 - test '1', '1'; # 177 -} -else { - my $iter = iterator->new(5); - my $acc = ''; - my $out; - $acc .= " $out" while $out = <${iter}>; - test $acc, ' 5 4 3 2 1 0'; # 175 - $iter = iterator->new(5); - test scalar <${iter}>, '5'; # 176 - $acc = ''; - $acc .= " $out" while $out = <$iter>; - test $acc, ' 4 3 2 1 0'; # 177 -} -{ - package deref; - use overload '%{}' => \&hderef, '&{}' => \&cderef, - '*{}' => \&gderef, '${}' => \&sderef, '@{}' => \&aderef; - sub new { my ($p, $v) = @_; bless \$v, $p } - sub deref { - my ($self, $key) = (shift, shift); - my $class = ref $self; - bless $self, 'deref::dummy'; # Disable overloading of %{} - my $out = $self->{$key}; - bless $self, $class; # Restore overloading - $out; - } - sub hderef {shift->deref('h')} - sub aderef {shift->deref('a')} - sub cderef {shift->deref('c')} - sub gderef {shift->deref('g')} - sub sderef {shift->deref('s')} -} -{ - my $deref = bless { h => { foo => 5 , fake => 23 }, - c => sub {return shift() + 34}, - 's' => \123, - a => [11..13], - g => \*srt, - }, 'deref'; - # Hash: - my @cont = sort %$deref; - if ("\t" eq "\011") { # ascii - test "@cont", '23 5 fake foo'; # 178 - } - else { # ebcdic alpha-numeric sort order - test "@cont", 'fake foo 23 5'; # 178 - } - my @keys = sort keys %$deref; - test "@keys", 'fake foo'; # 179 - my @val = sort values %$deref; - test "@val", '23 5'; # 180 - test $deref->{foo}, 5; # 181 - test defined $deref->{bar}, ''; # 182 - my $key; - @keys = (); - push @keys, $key while $key = each %$deref; - @keys = sort @keys; - test "@keys", 'fake foo'; # 183 - test exists $deref->{bar}, ''; # 184 - test exists $deref->{foo}, 1; # 185 - # Code: - test $deref->(5), 39; # 186 - test &$deref(6), 40; # 187 - sub xxx_goto { goto &$deref } - test xxx_goto(7), 41; # 188 - my $srt = bless { c => sub {$b <=> $a} - }, 'deref'; - *srt = \&$srt; - my @sorted = sort srt 11, 2, 5, 1, 22; - test "@sorted", '22 11 5 2 1'; # 189 - # Scalar - test $$deref, 123; # 190 - # Code - @sorted = sort $srt 11, 2, 5, 1, 22; - test "@sorted", '22 11 5 2 1'; # 191 - # Array - test "@$deref", '11 12 13'; # 192 - test $#$deref, '2'; # 193 - my $l = @$deref; - test $l, 3; # 194 - test $deref->[2], '13'; # 195 - $l = pop @$deref; - test $l, 13; # 196 - $l = 1; - test $deref->[$l], '12'; # 197 - # Repeated dereference - my $double = bless { h => $deref, - }, 'deref'; - test $double->{foo}, 5; # 198 -} - -{ - package two_refs; - use overload '%{}' => \&gethash, '@{}' => sub { ${shift()} }; - sub new { - my $p = shift; - bless \ [@_], $p; - } - sub gethash { - my %h; - my $self = shift; - tie %h, ref $self, $self; - \%h; - } - - sub TIEHASH { my $p = shift; bless \ shift, $p } - my %fields; - my $i = 0; - $fields{$_} = $i++ foreach qw{zero one two three}; - sub STORE { - my $self = ${shift()}; - my $key = $fields{shift()}; - defined $key or die "Out of band access"; - $$self->[$key] = shift; - } - sub FETCH { - my $self = ${shift()}; - my $key = $fields{shift()}; - defined $key or die "Out of band access"; - $$self->[$key]; - } -} - -my $bar = new two_refs 3,4,5,6; -$bar->[2] = 11; -test $bar->{two}, 11; # 199 -$bar->{three} = 13; -test $bar->[3], 13; # 200 - -{ - package two_refs_o; - @ISA = ('two_refs'); -} - -$bar = new two_refs_o 3,4,5,6; -$bar->[2] = 11; -test $bar->{two}, 11; # 201 -$bar->{three} = 13; -test $bar->[3], 13; # 202 - -{ - package two_refs1; - use overload '%{}' => sub { ${shift()}->[1] }, - '@{}' => sub { ${shift()}->[0] }; - sub new { - my $p = shift; - my $a = [@_]; - my %h; - tie %h, $p, $a; - bless \ [$a, \%h], $p; - } - sub gethash { - my %h; - my $self = shift; - tie %h, ref $self, $self; - \%h; - } - - sub TIEHASH { my $p = shift; bless \ shift, $p } - my %fields; - my $i = 0; - $fields{$_} = $i++ foreach qw{zero one two three}; - sub STORE { - my $a = ${shift()}; - my $key = $fields{shift()}; - defined $key or die "Out of band access"; - $a->[$key] = shift; - } - sub FETCH { - my $a = ${shift()}; - my $key = $fields{shift()}; - defined $key or die "Out of band access"; - $a->[$key]; - } -} - -$bar = new two_refs_o 3,4,5,6; -$bar->[2] = 11; -test $bar->{two}, 11; # 203 -$bar->{three} = 13; -test $bar->[3], 13; # 204 - -{ - package two_refs1_o; - @ISA = ('two_refs1'); -} - -$bar = new two_refs1_o 3,4,5,6; -$bar->[2] = 11; -test $bar->{two}, 11; # 205 -$bar->{three} = 13; -test $bar->[3], 13; # 206 - -{ - package B; - use overload bool => sub { ${+shift} }; -} - -my $aaa; -{ my $bbbb = 0; $aaa = bless \$bbbb, B } - -test !$aaa, 1; # 207 - -unless ($aaa) { - test 'ok', 'ok'; # 208 -} else { - test 'is not', 'ok'; # 208 -} - -# check that overload isn't done twice by join -{ my $c = 0; - package Join; - use overload '""' => sub { $c++ }; - my $x = join '', bless([]), 'pq', bless([]); - main::test $x, '0pq1'; # 209 -}; - -# Test module-specific warning -{ - # check the Odd number of arguments for overload::constant warning - my $a = "" ; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - $x = eval ' overload::constant "integer" ; ' ; - test($a eq "") ; # 210 - use warnings 'overload' ; - $x = eval ' overload::constant "integer" ; ' ; - test($a =~ /^Odd number of arguments for overload::constant at/) ; # 211 -} - -{ - # check the `$_[0]' is not an overloadable type warning - my $a = "" ; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - $x = eval ' overload::constant "fred" => sub {} ; ' ; - test($a eq "") ; # 212 - use warnings 'overload' ; - $x = eval ' overload::constant "fred" => sub {} ; ' ; - test($a =~ /^`fred' is not an overloadable type at/); # 213 -} - -{ - # check the `$_[1]' is not a code reference warning - my $a = "" ; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - $x = eval ' overload::constant "integer" => 1; ' ; - test($a eq "") ; # 214 - use warnings 'overload' ; - $x = eval ' overload::constant "integer" => 1; ' ; - test($a =~ /^`1' is not a code reference at/); # 215 -} - -{ - my $c = 0; - package ov_int1; - use overload '""' => sub { 3+shift->[0] }, - '0+' => sub { 10+shift->[0] }, - 'int' => sub { 100+shift->[0] }; - sub new {my $p = shift; bless [shift], $p} - - package ov_int2; - use overload '""' => sub { 5+shift->[0] }, - '0+' => sub { 30+shift->[0] }, - 'int' => sub { 'ov_int1'->new(1000+shift->[0]) }; - sub new {my $p = shift; bless [shift], $p} - - package noov_int; - use overload '""' => sub { 2+shift->[0] }, - '0+' => sub { 9+shift->[0] }; - sub new {my $p = shift; bless [shift], $p} - - package main; - - my $x = new noov_int 11; - my $int_x = int $x; - main::test("$int_x" eq 20); # 216 - $x = new ov_int1 31; - $int_x = int $x; - main::test("$int_x" eq 131); # 217 - $x = new ov_int2 51; - $int_x = int $x; - main::test("$int_x" eq 1054); # 218 -} - -# make sure that we don't inifinitely recurse -{ - my $c = 0; - package Recurse; - use overload '""' => sub { shift }, - '0+' => sub { shift }, - 'bool' => sub { shift }, - fallback => 1; - my $x = bless([]); - main::test("$x" =~ /Recurse=ARRAY/); # 219 - main::test($x); # 220 - main::test($x+0 =~ /Recurse=ARRAY/); # 221 -} - -# BugID 20010422.003 -package Foo; - -use overload - 'bool' => sub { return !$_[0]->is_zero() || undef; } -; - -sub is_zero - { - my $self = shift; - return $self->{var} == 0; - } - -sub new - { - my $class = shift; - my $self = {}; - $self->{var} = shift; - bless $self,$class; - } - -package main; - -use strict; - -my $r = Foo->new(8); -$r = Foo->new(0); - -test(($r || 0) == 0); # 222 - -# Last test is: -sub last {222} diff --git a/t/pragma/strict-refs b/t/pragma/strict-refs deleted file mode 100644 index 10599b0bb2..0000000000 --- a/t/pragma/strict-refs +++ /dev/null @@ -1,297 +0,0 @@ -Check strict refs functionality - -__END__ - -# no strict, should build & run ok. -my $fred ; -$b = "fred" ; -$a = $$b ; -$c = ${"def"} ; -$c = @{"def"} ; -$c = %{"def"} ; -$c = *{"def"} ; -$c = \&{"def"} ; -$c = def->[0]; -$c = def->{xyz}; -EXPECT - -######## - -# strict refs - error -use strict ; -my $fred ; -my $a = ${"fred"} ; -EXPECT -Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 5. -######## - -# strict refs - error -use strict 'refs' ; -my $fred ; -my $a = ${"fred"} ; -EXPECT -Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 5. -######## - -# strict refs - error -use strict 'refs' ; -my $fred ; -my $b = "fred" ; -my $a = $$b ; -EXPECT -Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 6. -######## - -# strict refs - error -use strict 'refs' ; -my $b ; -my $a = $$b ; -EXPECT -Can't use an undefined value as a SCALAR reference at - line 5. -######## - -# strict refs - error -use strict 'refs' ; -my $b ; -my $a = @$b ; -EXPECT -Can't use an undefined value as an ARRAY reference at - line 5. -######## - -# strict refs - error -use strict 'refs' ; -my $b ; -my $a = %$b ; -EXPECT -Can't use an undefined value as a HASH reference at - line 5. -######## - -# strict refs - error -use strict 'refs' ; -my $b ; -my $a = *$b ; -EXPECT -Can't use an undefined value as a symbol reference at - line 5. -######## - -# strict refs - error -use strict 'refs' ; -my $a = fred->[0] ; -EXPECT -Can't use bareword ("fred") as an ARRAY ref while "strict refs" in use at - line 4. -######## - -# strict refs - error -use strict 'refs' ; -my $a = fred->{barney} ; -EXPECT -Can't use bareword ("fred") as a HASH ref while "strict refs" in use at - line 4. -######## - -# strict refs - no error -use strict ; -no strict 'refs' ; -my $fred ; -my $b = "fred" ; -my $a = $$b ; -use strict 'refs' ; -EXPECT - -######## - -# strict refs - no error -use strict qw(subs vars) ; -my $fred ; -my $b = "fred" ; -my $a = $$b ; -use strict 'refs' ; -EXPECT - -######## - -# strict refs - no error -my $fred ; -my $b = "fred" ; -my $a = $$b ; -use strict 'refs' ; -EXPECT - -######## - -# strict refs - no error -use strict 'refs' ; -my $fred ; -my $b = \$fred ; -my $a = $$b ; -EXPECT - -######## - -# Check runtime scope of strict refs pragma -use strict 'refs'; -my $fred ; -my $b = "fred" ; -{ - no strict ; - my $a = $$b ; -} -my $a = $$b ; -EXPECT -Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 10. -######## - -# Check runtime scope of strict refs pragma -no strict ; -my $fred ; -my $b = "fred" ; -{ - use strict 'refs' ; - my $a = $$b ; -} -my $a = $$b ; -EXPECT -Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8. -######## - -# Check runtime scope of strict refs pragma -no strict ; -my $fred ; -my $b = "fred" ; -{ - use strict 'refs' ; - $a = sub { my $c = $$b ; } -} -&$a ; -EXPECT -Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8. -######## - - ---FILE-- abc -my $a = ${"Fred"} ; -1; ---FILE-- -use strict 'refs' ; -require "./abc"; -EXPECT - -######## - ---FILE-- abc -use strict 'refs' ; -1; ---FILE-- -require "./abc"; -my $a = ${"Fred"} ; -EXPECT - -######## - ---FILE-- abc -use strict 'refs' ; -my $a = ${"Fred"} ; -1; ---FILE-- -${"Fred"} ; -require "./abc"; -EXPECT -Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at ./abc line 2. -Compilation failed in require at - line 2. -######## - ---FILE-- abc.pm -use strict 'refs' ; -my $a = ${"Fred"} ; -1; ---FILE-- -my $a = ${"Fred"} ; -use abc; -EXPECT -Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at abc.pm line 2. -Compilation failed in require at - line 2. -BEGIN failed--compilation aborted at - line 2. -######## - -# Check scope of pragma with eval -no strict ; -eval { - my $a = ${"Fred"} ; -}; -print STDERR $@ ; -my $a = ${"Fred"} ; -EXPECT - -######## - -# Check scope of pragma with eval -no strict ; -eval { - use strict 'refs' ; - my $a = ${"Fred"} ; -}; -print STDERR $@ ; -my $a = ${"Fred"} ; -EXPECT -Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 6. -######## - -# Check scope of pragma with eval -use strict 'refs' ; -eval { - my $a = ${"Fred"} ; -}; -print STDERR $@ ; -EXPECT -Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 5. -######## - -# Check scope of pragma with eval -use strict 'refs' ; -eval { - no strict ; - my $a = ${"Fred"} ; -}; -print STDERR $@ ; -my $a = ${"Fred"} ; -EXPECT -Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 9. -######## - -# Check scope of pragma with eval -no strict ; -eval ' - my $a = ${"Fred"} ; -'; print STDERR $@ ; -my $a = ${"Fred"} ; -EXPECT - -######## - -# Check scope of pragma with eval -no strict ; -eval q[ - use strict 'refs' ; - my $a = ${"Fred"} ; -]; print STDERR $@; -EXPECT -Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at (eval 1) line 3. -######## - -# Check scope of pragma with eval -use strict 'refs' ; -eval ' - my $a = ${"Fred"} ; -'; print STDERR $@ ; -EXPECT -Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at (eval 1) line 2. -######## - -# Check scope of pragma with eval -use strict 'refs' ; -eval ' - no strict ; - my $a = ${"Fred"} ; -'; print STDERR $@; -my $a = ${"Fred"} ; -EXPECT -Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 8. diff --git a/t/pragma/strict-subs b/t/pragma/strict-subs deleted file mode 100644 index ed4fe7a443..0000000000 --- a/t/pragma/strict-subs +++ /dev/null @@ -1,319 +0,0 @@ -Check strict subs functionality - -__END__ - -# no strict, should build & run ok. -Fred ; -my $fred ; -$b = "fred" ; -$a = $$b ; -EXPECT - -######## - -use strict qw(refs vars); -Fred ; -EXPECT - -######## - -use strict ; -no strict 'subs' ; -Fred ; -EXPECT - -######## - -# strict subs - error -use strict 'subs' ; -Fred ; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at - line 4. -Execution of - aborted due to compilation errors. -######## - -# strict subs - error -use strict 'subs' ; -my @a = (A..Z); -EXPECT -Bareword "Z" not allowed while "strict subs" in use at - line 4. -Bareword "A" not allowed while "strict subs" in use at - line 4. -Execution of - aborted due to compilation errors. -######## - -# strict subs - error -use strict 'subs' ; -my $a = (B..Y); -EXPECT -Bareword "Y" not allowed while "strict subs" in use at - line 4. -Bareword "B" not allowed while "strict subs" in use at - line 4. -Execution of - aborted due to compilation errors. -######## - -# strict subs - error -use strict ; -Fred ; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at - line 4. -Execution of - aborted due to compilation errors. -######## - -# strict subs - no error -use strict 'subs' ; -sub Fred {} -Fred ; -EXPECT - -######## - -# Check compile time scope of strict subs pragma -use strict 'subs' ; -{ - no strict ; - my $a = Fred ; -} -my $a = Fred ; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at - line 8. -Execution of - aborted due to compilation errors. -######## - -# Check compile time scope of strict subs pragma -no strict; -{ - use strict 'subs' ; - my $a = Fred ; -} -my $a = Fred ; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at - line 6. -Execution of - aborted due to compilation errors. -######## - -# Check compile time scope of strict vars pragma -use strict 'vars' ; -{ - no strict ; - $joe = 1 ; -} -$joe = 1 ; -EXPECT -Variable "$joe" is not imported at - line 8. -Global symbol "$joe" requires explicit package name at - line 8. -Execution of - aborted due to compilation errors. -######## - -# Check compile time scope of strict vars pragma -no strict; -{ - use strict 'vars' ; - $joe = 1 ; -} -$joe = 1 ; -EXPECT -Global symbol "$joe" requires explicit package name at - line 6. -Execution of - aborted due to compilation errors. -######## - -# Check runtime scope of strict refs pragma -use strict 'refs'; -my $fred ; -my $b = "fred" ; -{ - no strict ; - my $a = $$b ; -} -my $a = $$b ; -EXPECT -Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 10. -######## - -# Check runtime scope of strict refs pragma -no strict ; -my $fred ; -my $b = "fred" ; -{ - use strict 'refs' ; - my $a = $$b ; -} -my $a = $$b ; -EXPECT -Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8. -######## - -# Check runtime scope of strict refs pragma -no strict ; -my $fred ; -my $b = "fred" ; -{ - use strict 'refs' ; - $a = sub { my $c = $$b ; } -} -&$a ; -EXPECT -Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8. -######## - -use strict 'subs' ; -my $a = Fred ; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at - line 3. -Execution of - aborted due to compilation errors. -######## - ---FILE-- abc -my $a = Fred ; -1; ---FILE-- -use strict 'subs' ; -require "./abc"; -EXPECT - -######## - ---FILE-- abc -use strict 'subs' ; -1; ---FILE-- -require "./abc"; -my $a = Fred ; -EXPECT - -######## - ---FILE-- abc -use strict 'subs' ; -my $a = Fred ; -1; ---FILE-- -Fred ; -require "./abc"; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at ./abc line 2. -Compilation failed in require at - line 2. -######## - ---FILE-- abc.pm -use strict 'subs' ; -my $a = Fred ; -1; ---FILE-- -Fred ; -use abc; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at abc.pm line 2. -Compilation failed in require at - line 2. -BEGIN failed--compilation aborted at - line 2. -######## - -# Check scope of pragma with eval -no strict ; -eval { - my $a = Fred ; -}; -print STDERR $@; -my $a = Fred ; -EXPECT - -######## - -# Check scope of pragma with eval -no strict ; -eval { - use strict 'subs' ; - my $a = Fred ; -}; -print STDERR $@; -my $a = Fred ; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at - line 6. -Execution of - aborted due to compilation errors. -######## - -# Check scope of pragma with eval -use strict 'subs' ; -eval { - my $a = Fred ; -}; -print STDERR $@; -my $a = Fred ; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at - line 5. -Bareword "Fred" not allowed while "strict subs" in use at - line 8. -Execution of - aborted due to compilation errors. -######## - -# Check scope of pragma with eval -use strict 'subs' ; -eval { - no strict ; - my $a = Fred ; -}; -print STDERR $@; -my $a = Fred ; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at - line 9. -Execution of - aborted due to compilation errors. -######## - -# Check scope of pragma with eval -no strict ; -eval ' - Fred ; -'; print STDERR $@ ; -Fred ; -EXPECT - -######## - -# Check scope of pragma with eval -no strict ; -eval q[ - use strict 'subs' ; - Fred ; -]; print STDERR $@; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at (eval 1) line 3. -######## - -# Check scope of pragma with eval -use strict 'subs' ; -eval ' - Fred ; -'; print STDERR $@ ; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at (eval 1) line 2. -######## - -# Check scope of pragma with eval -use strict 'subs' ; -eval ' - no strict ; - my $a = Fred ; -'; print STDERR $@; -my $a = Fred ; -EXPECT -Bareword "Fred" not allowed while "strict subs" in use at - line 8. -Execution of - aborted due to compilation errors. -######## - -# see if Foo->Bar(...) etc work under strictures -use strict; -package Foo; sub Bar { print "@_\n" } -Foo->Bar('a',1); -Bar Foo ('b',2); -Foo->Bar(qw/c 3/); -Bar Foo (qw/d 4/); -Foo::->Bar('A',1); -Bar Foo:: ('B',2); -Foo::->Bar(qw/C 3/); -Bar Foo:: (qw/D 4/); -EXPECT -Foo a 1 -Foo b 2 -Foo c 3 -Foo d 4 -Foo A 1 -Foo B 2 -Foo C 3 -Foo D 4 diff --git a/t/pragma/strict-vars b/t/pragma/strict-vars deleted file mode 100644 index 40b55572b8..0000000000 --- a/t/pragma/strict-vars +++ /dev/null @@ -1,410 +0,0 @@ -Check strict vars functionality - -__END__ - -# no strict, should build & run ok. -Fred ; -my $fred ; -$b = "fred" ; -$a = $$b ; -EXPECT - -######## - -use strict qw(subs refs) ; -$fred ; -EXPECT - -######## - -use strict ; -no strict 'vars' ; -$fred ; -EXPECT - -######## - -# strict vars - no error -use strict 'vars' ; -use vars qw( $freddy) ; -BEGIN { *freddy = \$joe::shmoe; } -$freddy = 2 ; -EXPECT - -######## - -# strict vars - no error -use strict 'vars' ; -use vars qw( $freddy) ; -local $abc::joe ; -my $fred ; -my $b = \$fred ; -$Fred::ABC = 1 ; -$freddy = 2 ; -EXPECT - -######## - -# strict vars - error -use strict ; -$fred ; -EXPECT -Global symbol "$fred" requires explicit package name at - line 4. -Execution of - aborted due to compilation errors. -######## - -# strict vars - error -use strict 'vars' ; -<$fred> ; -EXPECT -Global symbol "$fred" requires explicit package name at - line 4. -Execution of - aborted due to compilation errors. -######## - -# strict vars - error -use strict 'vars' ; -local $fred ; -EXPECT -Global symbol "$fred" requires explicit package name at - line 4. -Execution of - aborted due to compilation errors. -######## - -# Check compile time scope of strict vars pragma -use strict 'vars' ; -{ - no strict ; - $joe = 1 ; -} -$joe = 1 ; -EXPECT -Variable "$joe" is not imported at - line 8. -Global symbol "$joe" requires explicit package name at - line 8. -Execution of - aborted due to compilation errors. -######## - -# Check compile time scope of strict vars pragma -no strict; -{ - use strict 'vars' ; - $joe = 1 ; -} -$joe = 1 ; -EXPECT -Global symbol "$joe" requires explicit package name at - line 6. -Execution of - aborted due to compilation errors. -######## - ---FILE-- abc -$joe = 1 ; -1; ---FILE-- -use strict 'vars' ; -require "./abc"; -EXPECT - -######## - ---FILE-- abc -use strict 'vars' ; -1; ---FILE-- -require "./abc"; -$joe = 1 ; -EXPECT - -######## - ---FILE-- abc -use strict 'vars' ; -$joe = 1 ; -1; ---FILE-- -$joe = 1 ; -require "./abc"; -EXPECT -Variable "$joe" is not imported at ./abc line 2. -Global symbol "$joe" requires explicit package name at ./abc line 2. -Compilation failed in require at - line 2. -######## - ---FILE-- abc.pm -use strict 'vars' ; -$joe = 1 ; -1; ---FILE-- -$joe = 1 ; -use abc; -EXPECT -Variable "$joe" is not imported at abc.pm line 2. -Global symbol "$joe" requires explicit package name at abc.pm line 2. -Compilation failed in require at - line 2. -BEGIN failed--compilation aborted at - line 2. -######## - ---FILE-- abc.pm -package Burp; -use strict; -$a = 1;$f = 1;$k = 1; # just to get beyond the limit... -$b = 1;$g = 1;$l = 1; -$c = 1;$h = 1;$m = 1; -$d = 1;$i = 1;$n = 1; -$e = 1;$j = 1;$o = 1; -$p = 0b12; ---FILE-- -use abc; -EXPECT -Global symbol "$f" requires explicit package name at abc.pm line 3. -Global symbol "$k" requires explicit package name at abc.pm line 3. -Global symbol "$g" requires explicit package name at abc.pm line 4. -Global symbol "$l" requires explicit package name at abc.pm line 4. -Global symbol "$c" requires explicit package name at abc.pm line 5. -Global symbol "$h" requires explicit package name at abc.pm line 5. -Global symbol "$m" requires explicit package name at abc.pm line 5. -Global symbol "$d" requires explicit package name at abc.pm line 6. -Global symbol "$i" requires explicit package name at abc.pm line 6. -Global symbol "$n" requires explicit package name at abc.pm line 6. -Global symbol "$e" requires explicit package name at abc.pm line 7. -Global symbol "$j" requires explicit package name at abc.pm line 7. -Global symbol "$o" requires explicit package name at abc.pm line 7. -Global symbol "$p" requires explicit package name at abc.pm line 8. -Illegal binary digit '2' at abc.pm line 8, at end of line -abc.pm has too many errors. -Compilation failed in require at - line 1. -BEGIN failed--compilation aborted at - line 1. -######## - -# Check scope of pragma with eval -no strict ; -eval { - $joe = 1 ; -}; -print STDERR $@; -$joe = 1 ; -EXPECT - -######## - -# Check scope of pragma with eval -no strict ; -eval { - use strict 'vars' ; - $joe = 1 ; -}; -print STDERR $@; -$joe = 1 ; -EXPECT -Global symbol "$joe" requires explicit package name at - line 6. -Execution of - aborted due to compilation errors. -######## - -# Check scope of pragma with eval -use strict 'vars' ; -eval { - $joe = 1 ; -}; -print STDERR $@; -$joe = 1 ; -EXPECT -Global symbol "$joe" requires explicit package name at - line 5. -Global symbol "$joe" requires explicit package name at - line 8. -Execution of - aborted due to compilation errors. -######## - -# Check scope of pragma with eval -use strict 'vars' ; -eval { - no strict ; - $joe = 1 ; -}; -print STDERR $@; -$joe = 1 ; -EXPECT -Variable "$joe" is not imported at - line 9. -Global symbol "$joe" requires explicit package name at - line 9. -Execution of - aborted due to compilation errors. -######## - -# Check scope of pragma with eval -no strict ; -eval ' - $joe = 1 ; -'; print STDERR $@ ; -$joe = 1 ; -EXPECT - -######## - -# Check scope of pragma with eval -no strict ; -eval q[ - use strict 'vars' ; - $joe = 1 ; -]; print STDERR $@; -EXPECT -Global symbol "$joe" requires explicit package name at (eval 1) line 3. -######## - -# Check scope of pragma with eval -use strict 'vars' ; -eval ' - $joe = 1 ; -'; print STDERR $@ ; -EXPECT -Global symbol "$joe" requires explicit package name at (eval 1) line 2. -######## - -# Check scope of pragma with eval -use strict 'vars' ; -eval ' - no strict ; - $joe = 1 ; -'; print STDERR $@; -$joe = 1 ; -EXPECT -Global symbol "$joe" requires explicit package name at - line 8. -Execution of - aborted due to compilation errors. -######## - -# Check if multiple evals produce same errors -use strict 'vars'; -my $ret = eval q{ print $x; }; -print $@; -print "ok 1\n" unless defined $ret; -$ret = eval q{ print $x; }; -print $@; -print "ok 2\n" unless defined $ret; -EXPECT -Global symbol "$x" requires explicit package name at (eval 1) line 1. -ok 1 -Global symbol "$x" requires explicit package name at (eval 2) line 1. -ok 2 -######## - -# strict vars with outer our - no error -use strict 'vars' ; -our $freddy; -local $abc::joe ; -my $fred ; -my $b = \$fred ; -$Fred::ABC = 1 ; -$freddy = 2 ; -EXPECT - -######## - -# strict vars with inner our - no error -use strict 'vars' ; -sub foo { - our $fred; - $fred; -} -EXPECT - -######## - -# strict vars with outer our, inner use - no error -use strict 'vars' ; -our $fred; -sub foo { - $fred; -} -EXPECT - -######## - -# strict vars with nested our - no error -use strict 'vars' ; -our $fred; -sub foo { - our $fred; - $fred; -} -$fred ; -EXPECT - -######## - -# strict vars with elapsed our - error -use strict 'vars' ; -sub foo { - our $fred; - $fred; -} -$fred ; -EXPECT -Variable "$fred" is not imported at - line 8. -Global symbol "$fred" requires explicit package name at - line 8. -Execution of - aborted due to compilation errors. -######## - -# nested our with local - no error -$fred = 1; -use strict 'vars'; -{ - local our $fred = 2; - print $fred,"\n"; -} -print our $fred,"\n"; -EXPECT -2 -1 -######## - -# "nailed" our declaration visibility across package boundaries -use strict 'vars'; -our $foo; -$foo = 20; -package Foo; -print $foo, "\n"; -EXPECT -20 -######## - -# multiple our declarations in same scope, different packages, no warning -use strict 'vars'; -use warnings; -our $foo; -${foo} = 10; -package Foo; -our $foo = 20; -print $foo, "\n"; -EXPECT -20 -######## - -# multiple our declarations in same scope, same package, warning -use strict 'vars'; -use warnings; -our $foo; -${foo} = 10; -our $foo; -EXPECT -"our" variable $foo masks earlier declaration in same scope at - line 7. -######## - -# multiple our declarations in same scope, same package, warning -use strict 'vars'; -use warnings; -{ our $x = 1 } -{ our $x = 0 } -our $foo; -{ - our $foo; - package Foo; - our $foo; -} -EXPECT -"our" variable $foo redeclared at - line 9. - (Did you mean "local" instead of "our"?) -Name "Foo::foo" used only once: possible typo at - line 11. -######## - -# Make sure the strict vars failure still occurs -# now that the `@i should be written as \@i' failure does not occur -# 20000522 mjd@plover.com (MJD) -use strict 'vars'; -no warnings; -"@i_like_crackers"; -EXPECT -Global symbol "@i_like_crackers" requires explicit package name at - line 7. -Execution of - aborted due to compilation errors. diff --git a/t/pragma/strict.t b/t/pragma/strict.t deleted file mode 100755 index 8b9083f4fc..0000000000 --- a/t/pragma/strict.t +++ /dev/null @@ -1,100 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - $ENV{PERL5LIB} = '../lib'; -} - -$| = 1; - -my $Is_VMS = $^O eq 'VMS'; -my $Is_MSWin32 = $^O eq 'MSWin32'; -my $Is_NetWare = $^O eq 'NetWare'; -my $tmpfile = "tmp0000"; -my $i = 0 ; -1 while -f ++$tmpfile; -END { if ($tmpfile) { 1 while unlink $tmpfile; } } - -my @prgs = () ; - -foreach (sort glob($^O eq 'MacOS' ? ":pragma:strict-*" : "pragma/strict-*")) { - - next if /(~|\.orig|,v)$/; - - open F, "<$_" or die "Cannot open $_: $!\n" ; - while (<F>) { - last if /^__END__/ ; - } - - { - local $/ = undef; - @prgs = (@prgs, split "\n########\n", <F>) ; - } - close F ; -} - -undef $/; - -print "1..", scalar @prgs, "\n"; - - -for (@prgs){ - my $switch = ""; - my @temps = () ; - if (s/^\s*-\w+//){ - $switch = $&; - } - my($prog,$expected) = split(/\nEXPECT\n/, $_); - if ( $prog =~ /--FILE--/) { - my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; - shift @files ; - die "Internal error test $i didn't split into pairs, got " . - scalar(@files) . "[" . join("%%%%", @files) ."]\n" - if @files % 2 ; - while (@files > 2) { - my $filename = shift @files ; - my $code = shift @files ; - $code =~ s|\./abc|:abc|g if $^O eq 'MacOS'; - push @temps, $filename ; - open F, ">$filename" or die "Cannot open $filename: $!\n" ; - print F $code ; - close F ; - } - shift @files ; - $prog = shift @files ; - $prog =~ s|\./abc|:abc|g if $^O eq 'MacOS'; - } - open TEST, ">$tmpfile"; - print TEST $prog,"\n"; - close TEST; - my $results = $Is_MSWin32 ? - `.\\perl -I../lib $switch $tmpfile 2>&1` : - $^O eq 'MacOS' ? - `$^X -I::lib $switch $tmpfile` : - $^O eq 'NetWare' ? - `perl -I../lib $switch $tmpfile 2>&1` : - `./perl $switch $tmpfile 2>&1`; - my $status = $?; - $results =~ s/\n+$//; - # allow expected output to be written as if $prog is on STDIN - $results =~ s/tmp\d+/-/g; - $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg - $expected =~ s/\n+$//; - $expected =~ s|(\./)?abc\.pm|:abc.pm|g if $^O eq 'MacOS'; - $expected =~ s|./abc|:abc|g if $^O eq 'MacOS'; - my $prefix = ($results =~ s/^PREFIX\n//) ; - if ( $results =~ s/^SKIPPED\n//) { - print "$results\n" ; - } - elsif (($prefix and $results !~ /^\Q$expected/) or - (!$prefix and $results ne $expected)){ - print STDERR "PROG: $switch\n$prog\n"; - print STDERR "EXPECTED:\n$expected\n"; - print STDERR "GOT:\n$results\n"; - print "not "; - } - print "ok ", ++$i, "\n"; - foreach (@temps) - { unlink $_ if $_ } -} diff --git a/t/pragma/subs.t b/t/pragma/subs.t deleted file mode 100755 index 2f684b41ed..0000000000 --- a/t/pragma/subs.t +++ /dev/null @@ -1,162 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - $ENV{PERL5LIB} = '../lib'; -} - -$| = 1; -undef $/; -my @prgs = split "\n########\n", <DATA>; -print "1..", scalar @prgs, "\n"; - -my $Is_VMS = $^O eq 'VMS'; -my $Is_MSWin32 = $^O eq 'MSWin32'; -my $Is_NetWare = $^O eq 'NetWare'; -my $tmpfile = "tmp0000"; -my $i = 0 ; -1 while -f ++$tmpfile; -END { if ($tmpfile) { 1 while unlink $tmpfile} } - -for (@prgs){ - my $switch = ""; - my @temps = () ; - if (s/^\s*-\w+//){ - $switch = $&; - } - my($prog,$expected) = split(/\nEXPECT\n/, $_); - if ( $prog =~ /--FILE--/) { - my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; - shift @files ; - die "Internal error test $i didn't split into pairs, got " . - scalar(@files) . "[" . join("%%%%", @files) ."]\n" - if @files % 2 ; - while (@files > 2) { - my $filename = shift @files ; - my $code = shift @files ; - push @temps, $filename ; - open F, ">$filename" or die "Cannot open $filename: $!\n" ; - print F $code ; - close F ; - } - shift @files ; - $prog = shift @files ; - } - open TEST, ">$tmpfile"; - print TEST $prog,"\n"; - close TEST; - my $results = $Is_VMS ? - `./perl $switch $tmpfile 2>&1` : - $Is_MSWin32 ? - `.\\perl -I../lib $switch $tmpfile 2>&1` : - $Is_NetWare ? - `perl -I../lib $switch $tmpfile 2>&1` : - `./perl $switch $tmpfile 2>&1`; - my $status = $?; - $results =~ s/\n+$//; - # allow expected output to be written as if $prog is on STDIN - $results =~ s/tmp\d+/-/g; - $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg -# bison says 'parse error' instead of 'syntax error', -# various yaccs may or may not capitalize 'syntax'. - $results =~ s/^(syntax|parse) error/syntax error/mig; - $expected =~ s/\n+$//; - my $prefix = ($results =~ s/^PREFIX\n//) ; - if ( $results =~ s/^SKIPPED\n//) { - print "$results\n" ; - } - elsif (($prefix and $results !~ /^\Q$expected/) or - (!$prefix and $results ne $expected)){ - print STDERR "PROG: $switch\n$prog\n"; - print STDERR "EXPECTED:\n$expected\n"; - print STDERR "GOT:\n$results\n"; - print "not "; - } - print "ok ", ++$i, "\n"; - foreach (@temps) - { unlink $_ if $_ } -} - -__END__ - -# Error - not predeclaring a sub -Fred 1,2 ; -sub Fred {} -EXPECT -Number found where operator expected at - line 3, near "Fred 1" - (Do you need to predeclare Fred?) -syntax error at - line 3, near "Fred 1" -Execution of - aborted due to compilation errors. -######## - -# Error - not predeclaring a sub in time -Fred 1,2 ; -use subs qw( Fred ) ; -sub Fred {} -EXPECT -Number found where operator expected at - line 3, near "Fred 1" - (Do you need to predeclare Fred?) -syntax error at - line 3, near "Fred 1" -BEGIN not safe after errors--compilation aborted at - line 4. -######## - -# AOK -use subs qw( Fred) ; -Fred 1,2 ; -sub Fred { print $_[0] + $_[1], "\n" } -EXPECT -3 -######## - -# override a built-in function -use subs qw( open ) ; -open 1,2 ; -sub open { print $_[0] + $_[1], "\n" } -EXPECT -3 -######## - -# override a built-in function, call after definition -use subs qw( open ) ; -sub open { print $_[0] + $_[1], "\n" } -open 1,2 ; -EXPECT -3 -######## - -# override a built-in function, call with () -use subs qw( open ) ; -open (1,2) ; -sub open { print $_[0] + $_[1], "\n" } -EXPECT -3 -######## - -# override a built-in function, call with () after definition -use subs qw( open ) ; -sub open { print $_[0] + $_[1], "\n" } -open (1,2) ; -EXPECT -3 -######## - ---FILE-- abc -Fred 1,2 ; -1; ---FILE-- -use subs qw( Fred ) ; -require "./abc" ; -sub Fred { print $_[0] + $_[1], "\n" } -EXPECT -3 -######## - -# check that it isn't affected by block scope -{ - use subs qw( Fred ) ; -} -Fred 1, 2; -sub Fred { print $_[0] + $_[1], "\n" } -EXPECT -3 diff --git a/t/pragma/utf8.t b/t/pragma/utf8.t deleted file mode 100755 index 850470e0e8..0000000000 --- a/t/pragma/utf8.t +++ /dev/null @@ -1,103 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -# NOTE! -# -# Think carefully before adding tests here. In general this should be -# used only for about three categories of tests: -# -# (1) tests that absolutely require 'use utf8', and since that in general -# shouldn't be needed as the utf8 is being obsoleted, this should -# have rather few tests. If you want to test Unicode and regexes, -# you probably want to go to op/regexp or op/pat; if you want to test -# split, go to op/split; pack, op/pack; appending or joining, -# op/append or op/join, and so forth -# -# (2) tests that have to do with Unicode tokenizing (though it's likely -# that all the other Unicode tests sprinkled around the t/**/*.t are -# going to catch that) -# -# (3) complicated tests that simultaneously stress so many Unicode features -# that deciding into which other test script the tests should go to -# is hard -- maybe consider breaking up the complicated test -# -# - -use Test; -plan tests => 15; - -{ - # bug id 20001009.001 - - my ($a, $b); - - { use bytes; $a = "\xc3\xa4" } - { use utf8; $b = "\xe4" } - - my $test = 68; - - ok($a ne $b); - - { use utf8; ok($a ne $b) } -} - - -{ - # bug id 20000730.004 - - my $smiley = "\x{263a}"; - - for my $s ("\x{263a}", - $smiley, - - "" . $smiley, - "" . "\x{263a}", - - $smiley . "", - "\x{263a}" . "", - ) { - my $length_chars = length($s); - my $length_bytes; - { use bytes; $length_bytes = length($s) } - my @regex_chars = $s =~ m/(.)/g; - my $regex_chars = @regex_chars; - my @split_chars = split //, $s; - my $split_chars = @split_chars; - ok("$length_chars/$regex_chars/$split_chars/$length_bytes" eq - "1/1/1/3"); - } - - for my $s ("\x{263a}" . "\x{263a}", - $smiley . $smiley, - - "\x{263a}\x{263a}", - "$smiley$smiley", - - "\x{263a}" x 2, - $smiley x 2, - ) { - my $length_chars = length($s); - my $length_bytes; - { use bytes; $length_bytes = length($s) } - my @regex_chars = $s =~ m/(.)/g; - my $regex_chars = @regex_chars; - my @split_chars = split //, $s; - my $split_chars = @split_chars; - ok("$length_chars/$regex_chars/$split_chars/$length_bytes" eq - "2/2/2/6"); - } -} - - -{ - my $w = 0; - local $SIG{__WARN__} = sub { print "#($_[0])\n"; $w++ }; - my $x = eval q/"\\/ . "\x{100}" . q/"/;; - - ok($w == 0 && $x eq "\x{100}"); -} - diff --git a/t/pragma/vars.t b/t/pragma/vars.t deleted file mode 100644 index 3075f8e5ff..0000000000 --- a/t/pragma/vars.t +++ /dev/null @@ -1,105 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - $ENV{PERL5LIB} = '../lib'; -} - -$| = 1; - -print "1..27\n"; - -# catch "used once" warnings -my @warns; -BEGIN { $SIG{__WARN__} = sub { push @warns, @_ }; $^W = 1 }; - -%x = (); -$y = 3; -@z = (); -$X::x = 13; - -use vars qw($p @q %r *s &t $X::p); - -my $e = !(grep /^Name "X::x" used only once: possible typo/, @warns) && 'not '; -print "${e}ok 1\n"; -$e = !(grep /^Name "main::x" used only once: possible typo/, @warns) && 'not '; -print "${e}ok 2\n"; -$e = !(grep /^Name "main::y" used only once: possible typo/, @warns) && 'not '; -print "${e}ok 3\n"; -$e = !(grep /^Name "main::z" used only once: possible typo/, @warns) && 'not '; -print "${e}ok 4\n"; -($e, @warns) = @warns != 4 && 'not '; -print "${e}ok 5\n"; - -# this is inside eval() to avoid creation of symbol table entries and -# to avoid "used once" warnings -eval <<'EOE'; -$e = ! $main::{p} && 'not '; -print "${e}ok 6\n"; -$e = ! *q{ARRAY} && 'not '; -print "${e}ok 7\n"; -$e = ! *r{HASH} && 'not '; -print "${e}ok 8\n"; -$e = ! $main::{s} && 'not '; -print "${e}ok 9\n"; -$e = ! *t{CODE} && 'not '; -print "${e}ok 10\n"; -$e = defined $X::{q} && 'not '; -print "${e}ok 11\n"; -$e = ! $X::{p} && 'not '; -print "${e}ok 12\n"; -EOE -$e = $@ && 'not '; -print "${e}ok 13\n"; - -eval q{use vars qw(@X::y !abc); $e = ! *X::y{ARRAY} && 'not '}; -print "${e}ok 14\n"; -$e = $@ !~ /^'!abc' is not a valid variable name/ && 'not '; -print "${e}ok 15\n"; - -eval 'use vars qw($x[3])'; -$e = $@ !~ /^Can't declare individual elements of hash or array/ && 'not '; -print "${e}ok 16\n"; - -{ local $^W; - eval 'use vars qw($!)'; - ($e, @warns) = ($@ || @warns) ? 'not ' : ''; - print "${e}ok 17\n"; -}; - -# NB the next test only works because vars.pm has already been loaded -eval 'use warnings "vars"; use vars qw($!)'; -$e = ($@ || (shift(@warns)||'') !~ /^No need to declare built-in vars/) - && 'not '; -print "${e}ok 18\n"; - -no strict 'vars'; -eval 'use vars qw(@x%%)'; -$e = $@ && 'not '; -print "${e}ok 19\n"; -$e = ! *{'x%%'}{ARRAY} && 'not '; -print "${e}ok 20\n"; -eval '$u = 3; @v = (); %w = ()'; -$e = $@ && 'not '; -print "${e}ok 21\n"; - -use strict 'vars'; -eval 'use vars qw(@y%%)'; -$e = $@ !~ /^'\@y%%' is not a valid variable name under strict vars/ && 'not '; -print "${e}ok 22\n"; -$e = *{'y%%'}{ARRAY} && 'not '; -print "${e}ok 23\n"; -eval '$u = 3; @v = (); %w = ()'; -my @errs = split /\n/, $@; -$e = @errs != 3 && 'not '; -print "${e}ok 24\n"; -$e = !(grep(/^Global symbol "\$u" requires explicit package name/, @errs)) - && 'not '; -print "${e}ok 25\n"; -$e = !(grep(/^Global symbol "\@v" requires explicit package name/, @errs)) - && 'not '; -print "${e}ok 26\n"; -$e = !(grep(/^Global symbol "\%w" requires explicit package name/, @errs)) - && 'not '; -print "${e}ok 27\n"; diff --git a/t/pragma/warn/1global b/t/pragma/warn/1global deleted file mode 100644 index 0af80221b2..0000000000 --- a/t/pragma/warn/1global +++ /dev/null @@ -1,189 +0,0 @@ -Check existing $^W functionality - - -__END__ - -# warnable code, warnings disabled -$a =+ 3 ; -EXPECT - -######## --w -# warnable code, warnings enabled via command line switch -$a =+ 3 ; -EXPECT -Reversed += operator at - line 3. -Name "main::a" used only once: possible typo at - line 3. -######## -#! perl -w -# warnable code, warnings enabled via #! line -$a =+ 3 ; -EXPECT -Reversed += operator at - line 3. -Name "main::a" used only once: possible typo at - line 3. -######## - -# warnable code, warnings enabled via compile time $^W -BEGIN { $^W = 1 } -$a =+ 3 ; -EXPECT -Reversed += operator at - line 4. -Name "main::a" used only once: possible typo at - line 4. -######## - -# compile-time warnable code, warnings enabled via runtime $^W -# so no warning printed. -$^W = 1 ; -$a =+ 3 ; -EXPECT - -######## - -# warnable code, warnings enabled via runtime $^W -$^W = 1 ; -my $b ; chop $b ; -EXPECT -Use of uninitialized value in scalar chop at - line 4. -######## - -# warnings enabled at compile time, disabled at run time -BEGIN { $^W = 1 } -$^W = 0 ; -my $b ; chop $b ; -EXPECT - -######## - -# warnings disabled at compile time, enabled at run time -BEGIN { $^W = 0 } -$^W = 1 ; -my $b ; chop $b ; -EXPECT -Use of uninitialized value in scalar chop at - line 5. -######## --w ---FILE-- abcd -my $b ; chop $b ; -1 ; ---FILE-- -require "./abcd"; -EXPECT -Use of uninitialized value in scalar chop at ./abcd line 1. -######## - ---FILE-- abcd -my $b ; chop $b ; -1 ; ---FILE-- -#! perl -w -require "./abcd"; -EXPECT -Use of uninitialized value in scalar chop at ./abcd line 1. -######## - ---FILE-- abcd -my $b ; chop $b ; -1 ; ---FILE-- -$^W =1 ; -require "./abcd"; -EXPECT -Use of uninitialized value in scalar chop at ./abcd line 1. -######## - ---FILE-- abcd -$^W = 0; -my $b ; chop $b ; -1 ; ---FILE-- -$^W =1 ; -require "./abcd"; -EXPECT - -######## - ---FILE-- abcd -$^W = 1; -1 ; ---FILE-- -$^W =0 ; -require "./abcd"; -my $b ; chop $b ; -EXPECT -Use of uninitialized value in scalar chop at - line 3. -######## - -$^W = 1; -eval 'my $b ; chop $b ;' ; -print $@ ; -EXPECT -Use of uninitialized value in scalar chop at (eval 1) line 1. -######## - -eval '$^W = 1;' ; -print $@ ; -my $b ; chop $b ; -EXPECT -Use of uninitialized value in scalar chop at - line 4. -######## - -eval {$^W = 1;} ; -print $@ ; -my $b ; chop $b ; -EXPECT -Use of uninitialized value in scalar chop at - line 4. -######## - -{ - local ($^W) = 1; -} -my $b ; chop $b ; -EXPECT - -######## - -my $a ; chop $a ; -{ - local ($^W) = 1; - my $b ; chop $b ; -} -my $c ; chop $c ; -EXPECT -Use of uninitialized value in scalar chop at - line 5. -######## --w --e undef -EXPECT -Use of uninitialized value in -e at - line 2. -######## - -$^W = 1 + 2 ; -EXPECT - -######## - -$^W = $a ; -EXPECT - -######## - -sub fred {} -$^W = fred() ; -EXPECT - -######## - -sub fred { my $b ; chop $b ;} -{ local $^W = 0 ; - fred() ; -} -EXPECT - -######## - -sub fred { my $b ; chop $b ;} -{ local $^W = 1 ; - fred() ; -} -EXPECT -Use of uninitialized value in scalar chop at - line 2. diff --git a/t/pragma/warn/2use b/t/pragma/warn/2use deleted file mode 100644 index e25d43adbb..0000000000 --- a/t/pragma/warn/2use +++ /dev/null @@ -1,354 +0,0 @@ -Check lexical warnings functionality - -TODO - check that the warning hierarchy works. - -__END__ - -# check illegal category is caught -use warnings 'this-should-never-be-a-warning-category' ; -EXPECT -unknown warnings category 'this-should-never-be-a-warning-category' at - line 3 -BEGIN failed--compilation aborted at - line 3. -######## - -# Check compile time scope of pragma -use warnings 'syntax' ; -{ - no warnings ; - my $a =+ 1 ; -} -my $a =+ 1 ; -EXPECT -Reversed += operator at - line 8. -######## - -# Check compile time scope of pragma -no warnings; -{ - use warnings 'syntax' ; - my $a =+ 1 ; -} -my $a =+ 1 ; -EXPECT -Reversed += operator at - line 6. -######## - -# Check runtime scope of pragma -use warnings 'uninitialized' ; -{ - no warnings ; - my $b ; chop $b ; -} -my $b ; chop $b ; -EXPECT -Use of uninitialized value in scalar chop at - line 8. -######## - -# Check runtime scope of pragma -no warnings ; -{ - use warnings 'uninitialized' ; - my $b ; chop $b ; -} -my $b ; chop $b ; -EXPECT -Use of uninitialized value in scalar chop at - line 6. -######## - -# Check runtime scope of pragma -no warnings ; -{ - use warnings 'uninitialized' ; - $a = sub { my $b ; chop $b ; } -} -&$a ; -EXPECT -Use of uninitialized value in scalar chop at - line 6. -######## - -use warnings 'syntax' ; -my $a =+ 1 ; -EXPECT -Reversed += operator at - line 3. -######## - ---FILE-- abc -my $a =+ 1 ; -1; ---FILE-- -use warnings 'syntax' ; -require "./abc"; -EXPECT - -######## - ---FILE-- abc -use warnings 'syntax' ; -1; ---FILE-- -require "./abc"; -my $a =+ 1 ; -EXPECT - -######## - ---FILE-- abc -use warnings 'syntax' ; -my $a =+ 1 ; -1; ---FILE-- -use warnings 'uninitialized' ; -require "./abc"; -my $a ; chop $a ; -EXPECT -Reversed += operator at ./abc line 2. -Use of uninitialized value in scalar chop at - line 3. -######## - ---FILE-- abc.pm -use warnings 'syntax' ; -my $a =+ 1 ; -1; ---FILE-- -use warnings 'uninitialized' ; -use abc; -my $a ; chop $a ; -EXPECT -Reversed += operator at abc.pm line 2. -Use of uninitialized value in scalar chop at - line 3. -######## - -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval { - my $b ; chop $b ; - }; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT - -######## - -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval { - use warnings 'uninitialized' ; - my $b ; chop $b ; - }; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT -Use of uninitialized value in scalar chop at - line 8. -######## - -# Check scope of pragma with eval -no warnings; -{ - use warnings 'uninitialized' ; - eval { - my $b ; chop $b ; - }; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT -Use of uninitialized value in scalar chop at - line 7. -Use of uninitialized value in scalar chop at - line 9. -######## - -# Check scope of pragma with eval -no warnings; -{ - use warnings 'uninitialized' ; - eval { - no warnings ; - my $b ; chop $b ; - }; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT -Use of uninitialized value in scalar chop at - line 10. -######## - -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval { - my $a =+ 1 ; - }; print STDERR $@ ; - my $a =+ 1 ; -} -EXPECT - -######## - -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval { - use warnings 'syntax' ; - my $a =+ 1 ; - }; print STDERR $@ ; - my $a =+ 1 ; -} -EXPECT -Reversed += operator at - line 8. -######## - -# Check scope of pragma with eval -no warnings; -{ - use warnings 'syntax' ; - eval { - my $a =+ 1 ; - }; print STDERR $@ ; - my $a =+ 1 ; -} -EXPECT -Reversed += operator at - line 7. -Reversed += operator at - line 9. -######## - -# Check scope of pragma with eval -no warnings; -{ - use warnings 'syntax' ; - eval { - no warnings ; - my $a =+ 1 ; - }; print STDERR $@ ; - my $a =+ 1 ; -} -EXPECT -Reversed += operator at - line 10. -######## - -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval ' - my $b ; chop $b ; - '; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT - -######## - -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval q[ - use warnings 'uninitialized' ; - my $b ; chop $b ; - ]; print STDERR $@; - my $b ; chop $b ; -} -EXPECT -Use of uninitialized value in scalar chop at (eval 1) line 3. -######## - -# Check scope of pragma with eval -no warnings; -{ - use warnings 'uninitialized' ; - eval ' - my $b ; chop $b ; - '; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT -Use of uninitialized value in scalar chop at (eval 1) line 2. -Use of uninitialized value in scalar chop at - line 9. -######## - -# Check scope of pragma with eval -no warnings; -{ - use warnings 'uninitialized' ; - eval ' - no warnings ; - my $b ; chop $b ; - '; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT -Use of uninitialized value in scalar chop at - line 10. -######## - -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval ' - my $a =+ 1 ; - '; print STDERR $@ ; - my $a =+ 1 ; -} -EXPECT - -######## - -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval q[ - use warnings 'syntax' ; - my $a =+ 1 ; - ]; print STDERR $@; - my $a =+ 1 ; -} -EXPECT -Reversed += operator at (eval 1) line 3. -######## - -# Check scope of pragma with eval -no warnings; -{ - use warnings 'syntax' ; - eval ' - my $a =+ 1 ; - '; print STDERR $@; - my $a =+ 1 ; -} -EXPECT -Reversed += operator at - line 9. -Reversed += operator at (eval 1) line 2. -######## - -# Check scope of pragma with eval -no warnings; -{ - use warnings 'syntax' ; - eval ' - no warnings ; - my $a =+ 1 ; - '; print STDERR $@; - my $a =+ 1 ; -} -EXPECT -Reversed += operator at - line 10. -######## - -# Check the additive nature of the pragma -my $a =+ 1 ; -my $a ; chop $a ; -use warnings 'syntax' ; -$a =+ 1 ; -my $b ; chop $b ; -use warnings 'uninitialized' ; -my $c ; chop $c ; -no warnings 'syntax' ; -$a =+ 1 ; -EXPECT -Reversed += operator at - line 6. -Use of uninitialized value in scalar chop at - line 9. diff --git a/t/pragma/warn/3both b/t/pragma/warn/3both deleted file mode 100644 index a4d9ba806d..0000000000 --- a/t/pragma/warn/3both +++ /dev/null @@ -1,266 +0,0 @@ -Check interaction of $^W and lexical - -__END__ - -# Check interaction of $^W and use warnings -sub fred { - use warnings ; - my $b ; - chop $b ; -} -{ local $^W = 0 ; - fred() ; -} - -EXPECT -Use of uninitialized value in scalar chop at - line 6. -######## - -# Check interaction of $^W and use warnings -sub fred { - use warnings ; - my $b ; - chop $b ; -} -{ $^W = 0 ; - fred() ; -} - -EXPECT -Use of uninitialized value in scalar chop at - line 6. -######## - -# Check interaction of $^W and use warnings -sub fred { - no warnings ; - my $b ; - chop $b ; -} -{ local $^W = 1 ; - fred() ; -} - -EXPECT - -######## - -# Check interaction of $^W and use warnings -sub fred { - no warnings ; - my $b ; - chop $b ; -} -{ $^W = 1 ; - fred() ; -} - -EXPECT - -######## - -# Check interaction of $^W and use warnings -use warnings ; -$^W = 1 ; -my $b ; -chop $b ; -EXPECT -Use of uninitialized value in scalar chop at - line 6. -######## - -# Check interaction of $^W and use warnings -$^W = 1 ; -use warnings ; -my $b ; -chop $b ; -EXPECT -Use of uninitialized value in scalar chop at - line 6. -######## - -# Check interaction of $^W and use warnings -$^W = 1 ; -no warnings ; -my $b ; -chop $b ; -EXPECT - -######## - -# Check interaction of $^W and use warnings -no warnings ; -$^W = 1 ; -my $b ; -chop $b ; -EXPECT - -######## --w -# Check interaction of $^W and use warnings -no warnings ; -my $b ; -chop $b ; -EXPECT - -######## --w -# Check interaction of $^W and use warnings -use warnings ; -my $b ; -chop $b ; -EXPECT -Use of uninitialized value in scalar chop at - line 5. -######## - -# Check interaction of $^W and use warnings -sub fred { - use warnings ; - my $b ; - chop $b ; -} -BEGIN { $^W = 0 } -fred() ; -EXPECT -Use of uninitialized value in scalar chop at - line 6. -######## - -# Check interaction of $^W and use warnings -sub fred { - no warnings ; - my $b ; - chop $b ; -} -BEGIN { $^W = 1 } -fred() ; - -EXPECT - -######## - -# Check interaction of $^W and use warnings -use warnings ; -BEGIN { $^W = 1 } -my $b ; -chop $b ; -EXPECT -Use of uninitialized value in scalar chop at - line 6. -######## - -# Check interaction of $^W and use warnings -BEGIN { $^W = 1 } -use warnings ; -my $b ; -chop $b ; -EXPECT -Use of uninitialized value in scalar chop at - line 6. -######## - -# Check interaction of $^W and use warnings -BEGIN { $^W = 1 } -no warnings ; -my $b ; -chop $b ; -EXPECT - -######## - -# Check interaction of $^W and use warnings -no warnings ; -BEGIN { $^W = 1 } -my $b ; -chop $b ; -EXPECT - -######## - -# Check interaction of $^W and use warnings -BEGIN { $^W = 1 } -{ - no warnings ; - my $b ; - chop $b ; -} -my $b ; -chop $b ; -EXPECT -Use of uninitialized value in scalar chop at - line 10. -######## - -# Check interaction of $^W and use warnings -BEGIN { $^W = 0 } -{ - use warnings ; - my $b ; - chop $b ; -} -my $b ; -chop $b ; -EXPECT -Use of uninitialized value in scalar chop at - line 7. -######## - -# Check scope of pragma with eval -BEGIN { $^W = 1 } -{ - no warnings ; - eval ' - my $b ; chop $b ; - '; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT - -######## - -# Check scope of pragma with eval -BEGIN { $^W = 1 } -use warnings; -{ - no warnings ; - eval q[ - use warnings 'uninitialized' ; - my $b ; chop $b ; - ]; print STDERR $@; - my $b ; chop $b ; -} -EXPECT -Use of uninitialized value in scalar chop at (eval 1) line 3. -######## - -# Check scope of pragma with eval -BEGIN { $^W = 0 } -{ - use warnings 'uninitialized' ; - eval ' - my $b ; chop $b ; - '; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT -Use of uninitialized value in scalar chop at (eval 1) line 2. -Use of uninitialized value in scalar chop at - line 9. -######## - -# Check scope of pragma with eval -BEGIN { $^W = 0 } -{ - use warnings 'uninitialized' ; - eval ' - no warnings ; - my $b ; chop $b ; - '; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT -Use of uninitialized value in scalar chop at - line 10. -######## - -# Check scope of pragma with eval -BEGIN { $^W = 1 } -{ - no warnings ; - eval ' - my $a =+ 1 ; - '; print STDERR $@ ; - my $a =+ 1 ; -} -EXPECT - diff --git a/t/pragma/warn/4lint b/t/pragma/warn/4lint deleted file mode 100644 index 848822dd30..0000000000 --- a/t/pragma/warn/4lint +++ /dev/null @@ -1,216 +0,0 @@ -Check lint - -__END__ --W -# lint: check compile time $^W is zapped -BEGIN { $^W = 0 ;} -$a = 1 ; -$a =+ 1 ; -close STDIN ; print STDIN "abc" ; -EXPECT -Reversed += operator at - line 5. -print() on closed filehandle STDIN at - line 6. -######## --W -# lint: check runtime $^W is zapped -$^W = 0 ; -close STDIN ; print STDIN "abc" ; -EXPECT -print() on closed filehandle STDIN at - line 4. -######## --W -# lint: check runtime $^W is zapped -{ - $^W = 0 ; - close STDIN ; print STDIN "abc" ; -} -EXPECT -print() on closed filehandle STDIN at - line 5. -######## --W -# lint: check "no warnings" is zapped -no warnings ; -$a = 1 ; -$a =+ 1 ; -close STDIN ; print STDIN "abc" ; -EXPECT -Reversed += operator at - line 5. -print() on closed filehandle STDIN at - line 6. -######## --W -# lint: check "no warnings" is zapped -{ - no warnings ; - close STDIN ; print STDIN "abc" ; -} -EXPECT -print() on closed filehandle STDIN at - line 5. -######## --Ww -# lint: check combination of -w and -W -{ - $^W = 0 ; - close STDIN ; print STDIN "abc" ; -} -EXPECT -print() on closed filehandle STDIN at - line 5. -######## --W ---FILE-- abc.pm -no warnings 'syntax' ; -my $a = 0; -$a =+ 1 ; -1; ---FILE-- -no warnings 'uninitialized' ; -use abc; -my $a ; chop $a ; -EXPECT -Reversed += operator at abc.pm line 3. -Use of uninitialized value in scalar chop at - line 3. -######## --W ---FILE-- abc -no warnings 'syntax' ; -my $a = 0; -$a =+ 1 ; -1; ---FILE-- -no warnings 'uninitialized' ; -require "./abc"; -my $a ; chop $a ; -EXPECT -Reversed += operator at ./abc line 3. -Use of uninitialized value in scalar chop at - line 3. -######## --W ---FILE-- abc.pm -BEGIN {$^W = 0} -my $a = 0 ; -$a =+ 1 ; -1; ---FILE-- -$^W = 0 ; -use abc; -my $a ; chop $a ; -EXPECT -Reversed += operator at abc.pm line 3. -Use of uninitialized value in scalar chop at - line 3. -######## --W ---FILE-- abc -BEGIN {$^W = 0} -my $a = 0 ; -$a =+ 1 ; -1; ---FILE-- -$^W = 0 ; -require "./abc"; -my $a ; chop $a ; -EXPECT -Reversed += operator at ./abc line 3. -Use of uninitialized value in scalar chop at - line 3. -######## --W -# Check scope of pragma with eval -{ - no warnings ; - eval ' - my $b ; chop $b ; - '; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT -Use of uninitialized value in scalar chop at (eval 1) line 2. -Use of uninitialized value in scalar chop at - line 8. -######## --W -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval q[ - use warnings 'uninitialized' ; - my $b ; chop $b ; - ]; print STDERR $@; - my $b ; chop $b ; -} -EXPECT -Use of uninitialized value in scalar chop at (eval 1) line 3. -Use of uninitialized value in scalar chop at - line 10. -######## --W -# Check scope of pragma with eval -no warnings; -{ - use warnings 'uninitialized' ; - eval ' - my $b ; chop $b ; - '; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT -Use of uninitialized value in scalar chop at (eval 1) line 2. -Use of uninitialized value in scalar chop at - line 9. -######## --W -# Check scope of pragma with eval -no warnings; -{ - use warnings 'uninitialized' ; - eval ' - no warnings ; - my $b ; chop $b ; - '; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT -Use of uninitialized value in scalar chop at (eval 1) line 3. -Use of uninitialized value in scalar chop at - line 10. -######## --W -# Check scope of pragma with eval -use warnings; -{ - my $a = "1"; my $b = "2"; - no warnings ; - eval q[ - use warnings 'syntax' ; - $a =+ 1 ; - ]; print STDERR $@; - $a =+ 1 ; -} -EXPECT -Reversed += operator at - line 11. -Reversed += operator at (eval 1) line 3. -######## --W -# Check scope of pragma with eval -no warnings; -{ - my $a = "1"; my $b = "2"; - use warnings 'syntax' ; - eval ' - $a =+ 1 ; - '; print STDERR $@; - $a =+ 1 ; -} -EXPECT -Reversed += operator at - line 10. -Reversed += operator at (eval 1) line 2. -######## --W -# Check scope of pragma with eval -no warnings; -{ - my $a = "1"; my $b = "2"; - use warnings 'syntax' ; - eval ' - no warnings ; - $a =+ 1 ; - '; print STDERR $@; - $a =+ 1 ; -} -EXPECT -Reversed += operator at - line 11. -Reversed += operator at (eval 1) line 3. diff --git a/t/pragma/warn/5nolint b/t/pragma/warn/5nolint deleted file mode 100644 index 56158a20be..0000000000 --- a/t/pragma/warn/5nolint +++ /dev/null @@ -1,204 +0,0 @@ -syntax anti-lint - -__END__ --X -# nolint: check compile time $^W is zapped -BEGIN { $^W = 1 ;} -$a = $b = 1 ; -$a =+ 1 ; -close STDIN ; print STDIN "abc" ; -EXPECT -######## --X -# nolint: check runtime $^W is zapped -$^W = 1 ; -close STDIN ; print STDIN "abc" ; -EXPECT -######## --X -# nolint: check runtime $^W is zapped -{ - $^W = 1 ; - close STDIN ; print STDIN "abc" ; -} -EXPECT -######## --X -# nolint: check "no warnings" is zapped -use warnings ; -$a = $b = 1 ; -$a =+ 1 ; -close STDIN ; print STDIN "abc" ; -EXPECT -######## --X -# nolint: check "no warnings" is zapped -{ - use warnings ; - close STDIN ; print STDIN "abc" ; -} -EXPECT -######## --Xw -# nolint: check combination of -w and -X -{ - $^W = 1 ; - close STDIN ; print STDIN "abc" ; -} -EXPECT -######## --X ---FILE-- abc.pm -use warnings 'syntax' ; -my $a = 0; -$a =+ 1 ; -1; ---FILE-- -use warnings 'uninitialized' ; -use abc; -my $a ; chop $a ; -EXPECT -######## --X ---FILE-- abc -use warnings 'syntax' ; -my $a = 0; -$a =+ 1 ; -1; ---FILE-- -use warnings 'uninitialized' ; -require "./abc"; -my $a ; chop $a ; -EXPECT -######## --X ---FILE-- abc.pm -BEGIN {$^W = 1} -my ($a, $b) = (0,0); -$a =+ 1 ; -1; ---FILE-- -$^W = 1 ; -use abc; -my $a ; chop $a ; -EXPECT -######## --X ---FILE-- abc -BEGIN {$^W = 1} -my ($a, $b) = (0,0); -$a =+ 1 ; -1; ---FILE-- -$^W = 1 ; -require "./abc"; -my $a ; chop $a ; -EXPECT -######## --X -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval ' - my $b ; chop $b ; - '; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT - -######## --X -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval q[ - use warnings 'uninitialized' ; - my $b ; chop $b ; - ]; print STDERR $@; - my $b ; chop $b ; -} -EXPECT - -######## --X -# Check scope of pragma with eval -no warnings; -{ - use warnings 'uninitialized' ; - eval ' - my $b ; chop $b ; - '; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT - -######## --X -# Check scope of pragma with eval -no warnings; -{ - use warnings 'uninitialized' ; - eval ' - no warnings ; - my $b ; chop $b ; - '; print STDERR $@ ; - my $b ; chop $b ; -} -EXPECT - -######## --X -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval ' - my $a =+ 1 ; - '; print STDERR $@ ; - my $a =+ 1 ; -} -EXPECT - -######## --X -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval q[ - use warnings 'syntax' ; - my $a =+ 1 ; - ]; print STDERR $@; - my $a =+ 1 ; -} -EXPECT - -######## --X -# Check scope of pragma with eval -no warnings; -{ - use warnings 'syntax' ; - eval ' - my $a =+ 1 ; - '; print STDERR $@; - my $a =+ 1 ; -} -EXPECT - -######## --X -# Check scope of pragma with eval -no warnings; -{ - use warnings 'syntax' ; - eval ' - no warnings ; - my $a =+ 1 ; - '; print STDERR $@; - my $a =+ 1 ; -} -EXPECT - diff --git a/t/pragma/warn/6default b/t/pragma/warn/6default deleted file mode 100644 index a8aafeeb22..0000000000 --- a/t/pragma/warn/6default +++ /dev/null @@ -1,121 +0,0 @@ -Check default warnings - -__END__ -# default warnings should be displayed if you don't add anything -# optional shouldn't -my $a = oct "7777777777777777777777777777777777779" ; -EXPECT -Integer overflow in octal number at - line 3. -######## -# no warnings should be displayed -no warnings ; -my $a = oct "7777777777777777777777777777777777778" ; -EXPECT -######## -# all warnings should be displayed -use warnings ; -my $a = oct "7777777777777777777777777777777777778" ; -EXPECT -Integer overflow in octal number at - line 3. -Illegal octal digit '8' ignored at - line 3. -Octal number > 037777777777 non-portable at - line 3. -######## -# check scope -use warnings ; -my $a = oct "7777777777777777777777777777777777778" ; -{ - no warnings ; - my $a = oct "7777777777777777777777777777777777778" ; -} -my $c = oct "7777777777777777777777777777777777778" ; -EXPECT -Integer overflow in octal number at - line 3. -Illegal octal digit '8' ignored at - line 3. -Octal number > 037777777777 non-portable at - line 3. -Integer overflow in octal number at - line 8. -Illegal octal digit '8' ignored at - line 8. -Octal number > 037777777777 non-portable at - line 8. -######## -# all warnings should be displayed -use warnings ; -my $a = oct "0xfffffffffffffffffg" ; -EXPECT -Integer overflow in hexadecimal number at - line 3. -Illegal hexadecimal digit 'g' ignored at - line 3. -Hexadecimal number > 0xffffffff non-portable at - line 3. -######## -# all warnings should be displayed -use warnings ; -my $a = oct "0b111111111111111111111111111111111111111111111111111111111111111112"; -EXPECT -Integer overflow in binary number at - line 3. -Illegal binary digit '2' ignored at - line 3. -Binary number > 0b11111111111111111111111111111111 non-portable at - line 3. -######## - -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval ' - my $a = oct "0xfffffffffffffffffg" ; - '; print STDERR $@ ; - my $a = oct "0xfffffffffffffffffg" ; -} -EXPECT - -######## - -# Check scope of pragma with eval -use warnings; -{ - no warnings ; - eval q[ - use warnings ; - my $a = oct "0xfffffffffffffffffg" ; - ]; print STDERR $@; - my $a = oct "0xfffffffffffffffffg" ; -} -EXPECT -Integer overflow in hexadecimal number at (eval 1) line 3. -Illegal hexadecimal digit 'g' ignored at (eval 1) line 3. -Hexadecimal number > 0xffffffff non-portable at (eval 1) line 3. -######## - -# Check scope of pragma with eval -no warnings; -{ - use warnings ; - eval ' - my $a = oct "0xfffffffffffffffffg" ; - '; print STDERR $@ ; -} -EXPECT -Integer overflow in hexadecimal number at (eval 1) line 2. -Illegal hexadecimal digit 'g' ignored at (eval 1) line 2. -Hexadecimal number > 0xffffffff non-portable at (eval 1) line 2. -######## - -# Check scope of pragma with eval -no warnings; -{ - use warnings; - eval ' - no warnings ; - my $a = oct "0xfffffffffffffffffg" ; - '; print STDERR $@ ; -} -EXPECT - -######## - -# Check scope of pragma with eval -no warnings; -{ - use warnings 'deprecated' ; - eval ' - my $a = oct "0xfffffffffffffffffg" ; - '; print STDERR $@; -} -EXPECT - diff --git a/t/pragma/warn/7fatal b/t/pragma/warn/7fatal deleted file mode 100644 index a25fa2c2ea..0000000000 --- a/t/pragma/warn/7fatal +++ /dev/null @@ -1,312 +0,0 @@ -Check FATAL functionality - -__END__ - -# Check compile time warning -use warnings FATAL => 'syntax' ; -{ - no warnings ; - $a =+ 1 ; -} -$a =+ 1 ; -print STDERR "The End.\n" ; -EXPECT -Reversed += operator at - line 8. -######## - -# Check compile time warning -use warnings FATAL => 'all' ; -{ - no warnings ; - my $a =+ 1 ; -} -my $a =+ 1 ; -print STDERR "The End.\n" ; -EXPECT -Reversed += operator at - line 8. -######## - -# Check runtime scope of pragma -use warnings FATAL => 'uninitialized' ; -{ - no warnings ; - my $b ; chop $b ; -} -my $b ; chop $b ; -print STDERR "The End.\n" ; -EXPECT -Use of uninitialized value in scalar chop at - line 8. -######## - -# Check runtime scope of pragma -use warnings FATAL => 'all' ; -{ - no warnings ; - my $b ; chop $b ; -} -my $b ; chop $b ; -print STDERR "The End.\n" ; -EXPECT -Use of uninitialized value in scalar chop at - line 8. -######## - -# Check runtime scope of pragma -no warnings ; -{ - use warnings FATAL => 'uninitialized' ; - $a = sub { my $b ; chop $b ; } -} -&$a ; -print STDERR "The End.\n" ; -EXPECT -Use of uninitialized value in scalar chop at - line 6. -######## - -# Check runtime scope of pragma -no warnings ; -{ - use warnings FATAL => 'all' ; - $a = sub { my $b ; chop $b ; } -} -&$a ; -print STDERR "The End.\n" ; -EXPECT -Use of uninitialized value in scalar chop at - line 6. -######## - ---FILE-- abc -$a =+ 1 ; -1; ---FILE-- -use warnings FATAL => 'syntax' ; -require "./abc"; -EXPECT - -######## - ---FILE-- abc -use warnings FATAL => 'syntax' ; -1; ---FILE-- -require "./abc"; -$a =+ 1 ; -EXPECT - -######## - ---FILE-- abc -use warnings 'syntax' ; -$a =+ 1 ; -1; ---FILE-- -use warnings FATAL => 'uninitialized' ; -require "./abc"; -my $a ; chop $a ; -print STDERR "The End.\n" ; -EXPECT -Reversed += operator at ./abc line 2. -Use of uninitialized value in scalar chop at - line 3. -######## - ---FILE-- abc.pm -use warnings 'syntax' ; -$a =+ 1 ; -1; ---FILE-- -use warnings FATAL => 'uninitialized' ; -use abc; -my $a ; chop $a ; -print STDERR "The End.\n" ; -EXPECT -Reversed += operator at abc.pm line 2. -Use of uninitialized value in scalar chop at - line 3. -######## - -# Check scope of pragma with eval -no warnings ; -eval { - use warnings FATAL => 'uninitialized' ; - my $b ; chop $b ; -}; print STDERR "-- $@" ; -my $b ; chop $b ; -print STDERR "The End.\n" ; -EXPECT --- Use of uninitialized value in scalar chop at - line 6. -The End. -######## - -# Check scope of pragma with eval -use warnings FATAL => 'uninitialized' ; -eval { - my $b ; chop $b ; -}; print STDERR "-- $@" ; -my $b ; chop $b ; -print STDERR "The End.\n" ; -EXPECT --- Use of uninitialized value in scalar chop at - line 5. -Use of uninitialized value in scalar chop at - line 7. -######## - -# Check scope of pragma with eval -use warnings FATAL => 'uninitialized' ; -eval { - no warnings ; - my $b ; chop $b ; -}; print STDERR $@ ; -my $b ; chop $b ; -print STDERR "The End.\n" ; -EXPECT -Use of uninitialized value in scalar chop at - line 8. -######## - -# Check scope of pragma with eval -no warnings ; -eval { - use warnings FATAL => 'syntax' ; - $a =+ 1 ; -}; print STDERR "-- $@" ; -$a =+ 1 ; -print STDERR "The End.\n" ; -EXPECT -Reversed += operator at - line 6. -######## - -# Check scope of pragma with eval -use warnings FATAL => 'syntax' ; -eval { - $a =+ 1 ; -}; print STDERR "-- $@" ; -$a =+ 1 ; -print STDERR "The End.\n" ; -EXPECT -Reversed += operator at - line 5. -######## - -# Check scope of pragma with eval -use warnings FATAL => 'syntax' ; -eval { - no warnings ; - $a =+ 1 ; -}; print STDERR $@ ; -$a =+ 1 ; -print STDERR "The End.\n" ; -EXPECT -Reversed += operator at - line 8. -######## - -# Check scope of pragma with eval -no warnings ; -eval { - use warnings FATAL => 'syntax' ; -}; print STDERR $@ ; -$a =+ 1 ; -print STDERR "The End.\n" ; -EXPECT -The End. -######## - -# Check scope of pragma with eval -no warnings ; -eval q[ - use warnings FATAL => 'uninitialized' ; - my $b ; chop $b ; -]; print STDERR "-- $@"; -my $b ; chop $b ; -print STDERR "The End.\n" ; -EXPECT --- Use of uninitialized value in scalar chop at (eval 1) line 3. -The End. -######## - -# Check scope of pragma with eval -use warnings FATAL => 'uninitialized' ; -eval ' - my $b ; chop $b ; -'; print STDERR "-- $@" ; -my $b ; chop $b ; -print STDERR "The End.\n" ; -EXPECT --- Use of uninitialized value in scalar chop at (eval 1) line 2. -Use of uninitialized value in scalar chop at - line 7. -######## - -# Check scope of pragma with eval -use warnings FATAL => 'uninitialized' ; -eval ' - no warnings ; - my $b ; chop $b ; -'; print STDERR $@ ; -my $b ; chop $b ; -print STDERR "The End.\n" ; -EXPECT -Use of uninitialized value in scalar chop at - line 8. -######## - -# Check scope of pragma with eval -no warnings ; -eval q[ - use warnings FATAL => 'syntax' ; - $a =+ 1 ; -]; print STDERR "-- $@"; -$a =+ 1 ; -print STDERR "The End.\n" ; -EXPECT --- Reversed += operator at (eval 1) line 3. -The End. -######## - -# Check scope of pragma with eval -use warnings FATAL => 'syntax' ; -eval ' - $a =+ 1 ; -'; print STDERR "-- $@"; -print STDERR "The End.\n" ; -EXPECT --- Reversed += operator at (eval 1) line 2. -The End. -######## - -# Check scope of pragma with eval -use warnings FATAL => 'syntax' ; -eval ' - no warnings ; - $a =+ 1 ; -'; print STDERR "-- $@"; -$a =+ 1 ; -print STDERR "The End.\n" ; -EXPECT -Reversed += operator at - line 8. -######## - -use warnings 'void' ; - -time ; - -{ - use warnings FATAL => qw(void) ; - length "abc" ; -} - -join "", 1,2,3 ; - -print "done\n" ; -EXPECT -Useless use of time in void context at - line 4. -Useless use of length in void context at - line 8. -######## - -use warnings ; - -time ; - -{ - use warnings FATAL => qw(void) ; - length "abc" ; -} - -join "", 1,2,3 ; - -print "done\n" ; -EXPECT -Useless use of time in void context at - line 4. -Useless use of length in void context at - line 8. diff --git a/t/pragma/warn/8signal b/t/pragma/warn/8signal deleted file mode 100644 index cc1b9d926d..0000000000 --- a/t/pragma/warn/8signal +++ /dev/null @@ -1,18 +0,0 @@ -Check interaction of __WARN__, __DIE__ & lexical Warnings - -TODO - -__END__ -# 8signal -BEGIN { $| = 1; $SIG{__WARN__} = sub { print "WARN -- @_" } } -BEGIN { $SIG{__DIE__} = sub { print "DIE -- @_" } } -$a =+ 1 ; -use warnings qw(syntax) ; -$a =+ 1 ; -use warnings FATAL => qw(syntax) ; -$a =+ 1 ; -print "The End.\n" ; -EXPECT -WARN -- Reversed += operator at - line 6. -DIE -- Reversed += operator at - line 8. -Reversed += operator at - line 8. diff --git a/t/pragma/warn/9enabled b/t/pragma/warn/9enabled deleted file mode 100755 index f5579b2dde..0000000000 --- a/t/pragma/warn/9enabled +++ /dev/null @@ -1,1162 +0,0 @@ -Check warnings::enabled & warnings::warn - -__END__ - ---FILE-- abc.pm -package abc ; -use warnings "io" ; -print "ok1\n" if ! warnings::enabled('all') ; -print "ok2\n" if ! warnings::enabled("io") ; -1; ---FILE-- -no warnings; -use abc ; -EXPECT -ok1 -ok2 -######## - ---FILE-- abc.pm -package abc ; -no warnings ; -print "ok1\n" if !warnings::enabled('all') ; -print "ok2\n" if warnings::enabled("syntax") ; -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -EXPECT -ok1 -ok2 -######## - ---FILE-- abc.pm -package abc ; -use warnings 'syntax' ; -print "ok1\n" if warnings::enabled('io') ; -print "ok2\n" if ! warnings::enabled("syntax") ; -1; ---FILE-- -use warnings 'io' ; -use abc ; -EXPECT -ok1 -ok2 -######## - ---FILE-- abc -no warnings ; -print "ok1\n" if !warnings::enabled('all') ; -print "ok2\n" if warnings::enabled("syntax") ; -1; ---FILE-- -use warnings 'syntax' ; -require "abc" ; -EXPECT -ok1 -ok2 -######## - ---FILE-- abc -use warnings 'syntax' ; -print "ok1\n" if ! warnings::enabled('all') ; -print "ok2\n" if ! warnings::enabled("syntax") ; -print "ok3\n" if warnings::enabled("io") ; -1; ---FILE-- -use warnings 'io' ; -require "abc" ; -EXPECT -ok1 -ok2 -ok3 -######## - ---FILE-- abc.pm -package abc ; -no warnings ; -sub check { - print "ok1\n" if !warnings::enabled('all') ; - print "ok2\n" if warnings::enabled("syntax") ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -abc::check() ; -EXPECT -ok1 -ok2 -######## - ---FILE-- abc.pm -package abc ; -use warnings 'io' ; -sub check { - print "ok1\n" if ! warnings::enabled('all') ; - print "ok2\n" if warnings::enabled("syntax") ; - print "ok3\n" if ! warnings::enabled("io") ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -abc::check() ; -EXPECT -ok1 -ok2 -ok3 -######## - ---FILE-- abc -package abc ; -no warnings ; -sub check { - print "ok1\n" if !warnings::enabled('all') ; - print "ok2\n" if warnings::enabled("syntax") ; -} -1; ---FILE-- -use warnings 'syntax' ; -require "abc" ; -abc::check() ; -EXPECT -ok1 -ok2 -######## - ---FILE-- abc -package abc ; -use warnings 'io' ; -sub check { - print "ok1\n" if ! warnings::enabled('all') ; - print "ok2\n" if warnings::enabled("syntax") ; - print "ok3\n" if ! warnings::enabled("io") ; -} -1; ---FILE-- -use warnings 'syntax' ; -require "abc" ; -abc::check() ; -EXPECT -ok1 -ok2 -ok3 -######## - ---FILE-- abc.pm -package abc ; -use warnings "io" ; -print "ok1\n" if ! warnings::enabled('all') ; -print "ok2\n" if ! warnings::enabled("io") ; -1; ---FILE-- def.pm -no warnings; -use abc ; -1; ---FILE-- -use warnings; -use def ; -EXPECT -ok1 -ok2 -######## - ---FILE-- abc.pm -package abc ; -no warnings ; -print "ok1\n" if ! warnings::enabled('all') ; -print "ok2\n" if warnings::enabled("syntax") ; -print "ok3\n" if !warnings::enabled("io") ; -1; ---FILE-- def.pm -use warnings 'syntax' ; -print "ok4\n" if !warnings::enabled('all') ; -print "ok5\n" if warnings::enabled("io") ; -use abc ; -1; ---FILE-- -use warnings 'io' ; -use def ; -EXPECT -ok1 -ok2 -ok3 -ok4 -ok5 -######## - ---FILE-- abc.pm -package abc ; -no warnings ; -sub check { - print "ok1\n" if !warnings::enabled('all') ; - print "ok2\n" if warnings::enabled("syntax") ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -eval { abc::check() ; }; -print $@ ; -EXPECT -ok1 -ok2 -######## - ---FILE-- abc.pm -package abc ; -use warnings 'io' ; -sub check { - print "ok1\n" if ! warnings::enabled('all') ; - print "ok2\n" if warnings::enabled("syntax") ; - print "ok3\n" if ! warnings::enabled("io") ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -eval { abc::check() ; } ; -print $@ ; -EXPECT -ok1 -ok2 -ok3 -######## - ---FILE-- abc -package abc ; -no warnings ; -sub check { - print "ok1\n" if !warnings::enabled('all') ; - print "ok2\n" if warnings::enabled("syntax") ; -} -1; ---FILE-- -use warnings 'syntax' ; -require "abc" ; -eval { abc::check() ; } ; -print $@ ; -EXPECT -ok1 -ok2 -######## - ---FILE-- abc -package abc ; -use warnings 'io' ; -sub check { - print "ok1\n" if !warnings::enabled('all') ; - print "ok2\n" if warnings::enabled("syntax") ; - print "ok3\n" if warnings::enabled("io") ; -} -1; ---FILE-- -use warnings 'syntax' ; -require "abc" ; -eval { use warnings 'io' ; abc::check() ; }; -abc::check() ; -print $@ ; -EXPECT -ok1 -ok2 -ok3 -ok1 -ok2 -######## - ---FILE-- abc.pm -package abc ; -use warnings 'io' ; -sub check { - print "ok1\n" if ! warnings::enabled('all') ; - print "ok2\n" if warnings::enabled("syntax") ; - print "ok3\n" if ! warnings::enabled("io") ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -sub fred { abc::check() } -fred() ; -EXPECT -ok1 -ok2 -ok3 -######## - ---FILE-- abc.pm -package abc ; -use warnings 'io' ; -sub check { - print "ok1\n" if ! warnings::enabled('all') ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -sub fred { no warnings ; abc::check() } -fred() ; -EXPECT -ok1 -######## - ---FILE-- abc.pm -package abc ; -use warnings 'misc' ; -sub check { - print "ok1\n" if ! warnings::enabled('all') ; - print "ok2\n" if warnings::enabled("syntax") ; - print "ok3\n" if warnings::enabled("io") ; - print "ok4\n" if ! warnings::enabled("misc") ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -sub fred { use warnings 'io' ; abc::check() } -fred() ; -EXPECT -ok1 -ok2 -ok3 -ok4 -######## - -# check warnings::warn -use warnings ; -eval { warnings::warn() } ; -print $@ ; -eval { warnings::warn("fred", "joe") } ; -print $@ ; -EXPECT -Usage: warnings::warn([category,] 'message') at - line 4 -unknown warnings category 'fred' at - line 6 -######## - -# check warnings::warnif -use warnings ; -eval { warnings::warnif() } ; -print $@ ; -eval { warnings::warnif("fred", "joe") } ; -print $@ ; -EXPECT -Usage: warnings::warnif([category,] 'message') at - line 4 -unknown warnings category 'fred' at - line 6 -######## - ---FILE-- abc.pm -package abc ; -use warnings 'misc' ; -sub check { warnings::warn("io", "hello") } -1; ---FILE-- -use warnings "io" ; -use abc; -abc::check() ; -EXPECT -hello at - line 3 -######## - ---FILE-- abc.pm -package abc ; -use warnings 'misc' ; -sub check { warnings::warn("misc", "hello") } -1; ---FILE-- -use warnings "io" ; -use abc; -abc::check() ; -EXPECT -hello at - line 3 -######## - ---FILE-- abc.pm -package abc ; -use warnings 'misc' ; -sub check { warnings::warn("io", "hello") } -1; ---FILE-- -use warnings qw( FATAL deprecated ) ; -use abc; -eval { abc::check() ; } ; -print "[[$@]]\n"; -EXPECT -hello at - line 3 - eval {...} called at - line 3 -[[]] -######## - ---FILE-- abc.pm -package abc ; -use warnings 'misc' ; -sub check { warnings::warn("io", "hello") } -1; ---FILE-- -use warnings qw( FATAL io ) ; -use abc; -eval { abc::check() ; } ; -print "[[$@]]\n"; -EXPECT -[[hello at - line 3 - eval {...} called at - line 3 -]] -######## --W ---FILE-- abc.pm -package abc ; -use warnings "io" ; -print "ok1\n" if warnings::enabled("io") ; -print "ok2\n" if warnings::enabled("all") ; -1; ---FILE-- -no warnings; -use abc ; -EXPECT -ok1 -ok2 -######## --X ---FILE-- abc.pm -package abc ; -use warnings "io" ; -print "ok1\n" if !warnings::enabled("io") ; -print "ok2\n" if !warnings::enabled("all") ; -1; ---FILE-- -use warnings; -use abc ; -EXPECT -ok1 -ok2 -######## - ---FILE-- abc.pm -package abc ; -no warnings ; -sub check { - print "ok\n" if ! warnings::enabled() ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -abc::check() ; -EXPECT -package 'abc' not registered for warnings at abc.pm line 4 -######## - ---FILE-- abc.pm -package abc ; -no warnings ; -sub check { - warnings::warn("fred") ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -abc::check() ; -EXPECT -package 'abc' not registered for warnings at abc.pm line 4 -######## - ---FILE-- abc.pm -package abc ; -no warnings ; -sub check { - warnings::warnif("fred") ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -abc::check() ; -EXPECT -package 'abc' not registered for warnings at abc.pm line 4 -######## - ---FILE-- abc.pm -package abc ; -use warnings 'io' ; -use warnings::register ; -sub check { - print "ok1\n" if warnings::enabled ; - print "ok2\n" if warnings::enabled("syntax") ; - print "ok3\n" if !warnings::enabled("io") ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -use warnings 'abc' ; -abc::check() ; -EXPECT -ok1 -ok2 -ok3 -######## - ---FILE-- abc.pm -package abc ; -use warnings 'io' ; -use warnings::register ; -sub check { - print "ok1\n" if !warnings::enabled ; - print "ok2\n" if warnings::enabled("syntax") ; - print "ok3\n" if !warnings::enabled("io") ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -abc::check() ; -EXPECT -ok1 -ok2 -ok3 -######## - ---FILE-- abc.pm -package abc ; -no warnings ; -use warnings::register ; -sub check { - print "ok1\n" if warnings::enabled ; - print "ok2\n" if warnings::enabled("syntax") ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -use warnings 'abc' ; -eval { abc::check() ; }; -print $@ ; -EXPECT -ok1 -ok2 -######## - ---FILE-- abc.pm -package abc ; -use warnings 'io' ; -use warnings::register ; -sub check { - print "ok1\n" if !warnings::enabled ; - print "ok2\n" if warnings::enabled("syntax") ; - print "ok3\n" if !warnings::enabled("io") ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -eval { abc::check() ; } ; -print $@ ; -EXPECT -ok1 -ok2 -ok3 -######## - ---FILE-- abc.pm -package abc ; -use warnings 'io' ; -use warnings::register ; -sub check { - print "ok1\n" if warnings::enabled ; - print "ok2\n" if warnings::enabled("syntax") ; - print "ok3\n" if !warnings::enabled("io") ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -use warnings 'abc' ; -sub fred { abc::check() } -fred() ; -EXPECT -ok1 -ok2 -ok3 -######## - ---FILE-- abc.pm -package abc ; -use warnings 'io' ; -use warnings::register ; -sub check { - print "ok1\n" if ! warnings::enabled ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -sub fred { no warnings ; abc::check() } -fred() ; -EXPECT -ok1 -######## - ---FILE-- abc.pm -package abc ; -use warnings 'misc' ; -use warnings::register; -sub check { - print "ok1\n" if warnings::enabled ; - print "ok2\n" if warnings::enabled("syntax") ; - print "ok3\n" if warnings::enabled("io") ; - print "ok4\n" if ! warnings::enabled("misc") ; -} -1; ---FILE-- -use warnings 'syntax' ; -use abc ; -use warnings 'abc' ; -sub fred { use warnings 'io' ; abc::check() } -fred() ; -EXPECT -ok1 -ok2 -ok3 -ok4 -######## - ---FILE-- abc.pm -package abc ; -use warnings 'misc' ; -use warnings::register; -sub check { warnings::warn("hello") } -1; ---FILE-- -use abc; -use warnings "abc" ; -abc::check() ; -EXPECT -hello at - line 3 -######## - ---FILE-- abc.pm -package abc ; -use warnings::register; -sub check { warnings::warn("hello") } -1; ---FILE-- -use abc; -abc::check() ; -EXPECT -hello at - line 2 -######## - ---FILE-- abc.pm -package abc ; -use warnings::register ; -sub check { warnings::warn("hello") } -1; ---FILE-- -use abc; -use warnings qw( FATAL deprecated ) ; -eval { abc::check() ; } ; -print "[[$@]]\n"; -EXPECT -hello at - line 3 - eval {...} called at - line 3 -[[]] -######## - ---FILE-- abc.pm -package abc ; -use warnings::register ; -sub check { warnings::warn("hello") } -1; ---FILE-- -use abc; -use warnings qw( FATAL abc ) ; -eval { abc::check() ; } ; -print "[[$@]]\n"; -EXPECT -[[hello at - line 3 - eval {...} called at - line 3 -]] -######## --W ---FILE-- abc.pm -package abc ; -use warnings "io" ; -use warnings::register ; -sub check { - print "ok1\n" if warnings::enabled() ; - print "ok2\n" if warnings::enabled("io") ; - print "ok3\n" if warnings::enabled("all") ; -} -1; ---FILE-- -no warnings; -use abc ; -abc::check() ; -EXPECT -ok1 -ok2 -ok3 -######## --X ---FILE-- abc.pm -package abc ; -use warnings "io" ; -use warnings::register ; -sub check { - print "ok1\n" if !warnings::enabled() ; - print "ok2\n" if !warnings::enabled("io") ; - print "ok3\n" if !warnings::enabled("all") ; -} -1; ---FILE-- -no warnings; -use abc ; -abc::check() ; -EXPECT -ok1 -ok2 -ok3 -######## - ---FILE-- abc.pm -package abc ; -use warnings "io" ; -use warnings::register ; -sub check { - print "ok1\n" if warnings::enabled() ; - print "ok2\n" if warnings::enabled("io") ; - print "ok3\n" if warnings::enabled("all") ; -} -1; ---FILE-- -use warnings 'all'; -use abc ; -abc::check() ; -EXPECT -ok1 -ok2 -ok3 -######## - ---FILE-- abc.pm -package abc ; -use warnings "io" ; -use warnings::register ; -sub check { - print "ok1\n" if !warnings::enabled() ; - print "ok2\n" if !warnings::enabled("io") ; - print "ok3\n" if !warnings::enabled("all") ; -} -1; ---FILE-- -use abc ; -no warnings ; -abc::check() ; -EXPECT -ok1 -ok2 -ok3 -######## - ---FILE-- abc.pm -package abc ; -use warnings "io" ; -use warnings::register ; -sub check { - print "ok1\n" if !warnings::enabled() ; - print "ok2\n" if !warnings::enabled("io") ; - print "ok3\n" if !warnings::enabled("all") ; - warnings::warnif("my message 1") ; - warnings::warnif('abc', "my message 2") ; - warnings::warnif('io', "my message 3") ; - warnings::warnif('all', "my message 4") ; -} -1; ---FILE-- -use abc ; -use warnings 'abc'; -no warnings ; -abc::check() ; -EXPECT -ok1 -ok2 -ok3 -######## - ---FILE-- abc.pm -package abc ; -use warnings "io" ; -use warnings::register ; -sub check { - print "abc self" . (warnings::enabled() ? "" : " not") . " enabled\n" ; - print "abc def" . (warnings::enabled('def') ? "" : " not") . " enabled\n" ; - print "abc all" . (warnings::enabled('all') ? "" : " not") . " enabled\n" ; -} -1; ---FILE-- def.pm -package def ; -use warnings "io" ; -use warnings::register ; -sub check { - print "def self" . (warnings::enabled() ? "" : " not") . " enabled\n" ; - print "def abc" . (warnings::enabled('abc') ? "" : " not") . " enabled\n" ; - print "def all" . (warnings::enabled('all') ? "" : " not") . " enabled\n" ; -} -1; ---FILE-- -use abc ; -use def ; -use warnings 'abc'; -abc::check() ; -def::check() ; -no warnings 'abc' ; -use warnings 'def' ; -abc::check() ; -def::check() ; -use warnings 'abc' ; -use warnings 'def' ; -abc::check() ; -def::check() ; -no warnings 'abc' ; -no warnings 'def' ; -abc::check() ; -def::check() ; -use warnings; -abc::check() ; -def::check() ; -no warnings 'abc' ; -abc::check() ; -def::check() ; -EXPECT -abc self enabled -abc def not enabled -abc all not enabled -def self not enabled -def abc enabled -def all not enabled -abc self not enabled -abc def enabled -abc all not enabled -def self enabled -def abc not enabled -def all not enabled -abc self enabled -abc def enabled -abc all not enabled -def self enabled -def abc enabled -def all not enabled -abc self not enabled -abc def not enabled -abc all not enabled -def self not enabled -def abc not enabled -def all not enabled -abc self enabled -abc def enabled -abc all enabled -def self enabled -def abc enabled -def all enabled -abc self not enabled -abc def enabled -abc all not enabled -def self enabled -def abc not enabled -def all not enabled -######## --w ---FILE-- abc.pm -package abc ; -no warnings ; -use warnings::register ; -sub check { - print "ok1\n" if warnings::enabled() ; - print "ok2\n" if warnings::enabled("io") ; - print "ok3\n" if warnings::enabled("all") ; -} -1; ---FILE-- -use abc ; -abc::check() ; -EXPECT -ok1 -ok2 -ok3 -######## --w ---FILE-- abc.pm -package abc ; -no warnings ; -use warnings::register ; -sub check { - print "ok1\n" if !warnings::enabled() ; - print "ok2\n" if !warnings::enabled("io") ; - print "ok3\n" if !warnings::enabled("all") ; -} -1; ---FILE-- -use abc ; -use warnings 'abc'; -no warnings ; -abc::check() ; -EXPECT -ok1 -ok2 -ok3 -######## - ---FILE-- abc.pm -package abc ; -no warnings ; -use warnings::register ; -sub check { - print "ok1\n" if !warnings::enabled() ; - print "ok2\n" if !warnings::enabled("io") ; - print "ok3\n" if !warnings::enabled("all") ; - warnings::warnif("my message 1") ; - warnings::warnif('abc', "my message 2") ; - warnings::warnif('io', "my message 3") ; - warnings::warnif('all', "my message 4") ; -} -1; ---FILE-- -use abc ; -use warnings 'abc'; -no warnings ; -BEGIN { $^W = 1 ; } -abc::check() ; -EXPECT -ok1 -ok2 -ok3 -######## - ---FILE-- abc.pm -package abc ; -no warnings ; -use warnings::register ; -sub check { - print "ok1\n" if !warnings::enabled() ; - print "ok2\n" if !warnings::enabled("io") ; - print "ok3\n" if !warnings::enabled("all") ; -} -1; ---FILE-- -use abc ; -use warnings 'abc'; -no warnings ; -$^W = 1 ; -abc::check() ; -EXPECT -ok1 -ok2 -ok3 -######## - ---FILE-- abc.pm -$| = 1; -package abc ; -no warnings ; -use warnings::register ; -sub check { - print "ok1\n" if warnings::enabled() ; - print "ok2\n" if !warnings::enabled("io") ; - print "ok3\n" if !warnings::enabled("all") ; - print "ok4\n" if warnings::enabled("abc") ; - warnings::warn("my message 1") ; - warnings::warnif("my message 2") ; - warnings::warnif('abc', "my message 3") ; - warnings::warnif('io', "my message 4") ; - warnings::warnif('all', "my message 5") ; -} -sub in2 { no warnings ; check() } -sub in1 { no warnings ; in2() } -1; ---FILE-- -use abc ; -use warnings 'abc'; -abc::in1() ; -EXPECT -ok1 -ok2 -ok3 -ok4 -my message 1 at - line 3 -my message 2 at - line 3 -my message 3 at - line 3 -######## - ---FILE-- def.pm -package def ; -no warnings ; -use warnings::register ; -sub check { - print "ok1\n" if warnings::enabled() ; - print "ok2\n" if !warnings::enabled("io") ; - print "ok3\n" if !warnings::enabled("all") ; - print "ok4\n" if warnings::enabled("def") ; - warnings::warn("my message 1") ; - warnings::warnif("my message 2") ; - warnings::warnif('def', "my message 3") ; - warnings::warnif('io', "my message 4") ; - warnings::warnif('all', "my message 5") ; -} -sub in2 { no warnings ; check() } -sub in1 { no warnings ; in2() } -1; ---FILE-- abc.pm -$| = 1; -package abc ; -use def ; -use warnings 'def'; -sub in1 { def::in1() ; } -1; ---FILE-- -use abc ; -no warnings; -abc::in1() ; -EXPECT -ok1 -ok2 -ok3 -ok4 -my message 1 at abc.pm line 5 - abc::in1() called at - line 3 -my message 2 at abc.pm line 5 - abc::in1() called at - line 3 -my message 3 at abc.pm line 5 - abc::in1() called at - line 3 -######## - ---FILE-- def.pm -$| = 1; -package def ; -no warnings ; -use warnings::register ; -require Exporter; -@ISA = qw( Exporter ) ; -@EXPORT = qw( in1 ) ; -sub check { - print "ok1\n" if warnings::enabled() ; - print "ok2\n" if !warnings::enabled("io") ; - print "ok3\n" if !warnings::enabled("all") ; - print "ok4\n" if warnings::enabled("abc") ; - print "ok5\n" if !warnings::enabled("def") ; - warnings::warn("my message 1") ; - warnings::warnif("my message 2") ; - warnings::warnif('abc', "my message 3") ; - warnings::warnif('def', "my message 4") ; - warnings::warnif('io', "my message 5") ; - warnings::warnif('all', "my message 6") ; -} -sub in2 { no warnings ; check() } -sub in1 { no warnings ; in2() } -1; ---FILE-- abc.pm -package abc ; -use warnings::register ; -use def ; -#@ISA = qw(def) ; -1; ---FILE-- -use abc ; -no warnings; -use warnings 'abc'; -abc::in1() ; -EXPECT -ok2 -ok3 -ok4 -ok5 -my message 1 at - line 4 -my message 3 at - line 4 -######## - ---FILE-- def.pm -package def ; -no warnings ; -use warnings::register ; - -sub new -{ - my $class = shift ; - bless [], $class ; -} - -sub check -{ - my $self = shift ; - print "ok1\n" if !warnings::enabled() ; - print "ok2\n" if !warnings::enabled("io") ; - print "ok3\n" if !warnings::enabled("all") ; - print "ok4\n" if warnings::enabled("abc") ; - print "ok5\n" if !warnings::enabled("def") ; - print "ok6\n" if warnings::enabled($self) ; - - warnings::warn("my message 1") ; - warnings::warn($self, "my message 2") ; - - warnings::warnif("my message 3") ; - warnings::warnif('abc', "my message 4") ; - warnings::warnif('def', "my message 5") ; - warnings::warnif('io', "my message 6") ; - warnings::warnif('all', "my message 7") ; - warnings::warnif($self, "my message 8") ; -} -sub in2 -{ - no warnings ; - my $self = shift ; - $self->check() ; -} -sub in1 -{ - no warnings ; - my $self = shift ; - $self->in2(); -} -1; ---FILE-- abc.pm -$| = 1; -package abc ; -use warnings::register ; -use def ; -@ISA = qw(def) ; -sub new -{ - my $class = shift ; - bless [], $class ; -} - -1; ---FILE-- -use abc ; -no warnings; -use warnings 'abc'; -$a = new abc ; -$a->in1() ; -print "**\n"; -$b = new def ; -$b->in1() ; -EXPECT -ok1 -ok2 -ok3 -ok4 -ok5 -ok6 -my message 1 at - line 5 -my message 2 at - line 5 -my message 4 at - line 5 -my message 8 at - line 5 -** -ok1 -ok2 -ok3 -ok4 -ok5 -my message 1 at - line 8 -my message 2 at - line 8 -my message 4 at - line 8 diff --git a/t/pragma/warn/av b/t/pragma/warn/av deleted file mode 100644 index 79bd3b7600..0000000000 --- a/t/pragma/warn/av +++ /dev/null @@ -1,9 +0,0 @@ - av.c - - Mandatory Warnings ALL TODO - ------------------ - av_reify called on tied array [av_reify] - - Attempt to clear deleted array [av_clear] - -__END__ diff --git a/t/pragma/warn/doio b/t/pragma/warn/doio deleted file mode 100644 index 2a357e2755..0000000000 --- a/t/pragma/warn/doio +++ /dev/null @@ -1,209 +0,0 @@ - doio.c - - Can't open bidirectional pipe [Perl_do_open9] - open(F, "| true |"); - - Missing command in piped open [Perl_do_open9] - open(F, "| "); - - Missing command in piped open [Perl_do_open9] - open(F, " |"); - - warn(warn_nl, "open"); [Perl_do_open9] - open(F, "true\ncd") - - close() on unopened filehandle %s [Perl_do_close] - $a = "fred";close("$a") - - tell() on closed filehandle [Perl_do_tell] - $a = "fred";$a = tell($a) - - seek() on closed filehandle [Perl_do_seek] - $a = "fred";$a = seek($a,1,1) - - sysseek() on closed filehandle [Perl_do_sysseek] - $a = "fred";$a = seek($a,1,1) - - warn(warn_uninit); [Perl_do_print] - print $a ; - - -x on closed filehandle %s [Perl_my_stat] - close STDIN ; -x STDIN ; - - warn(warn_nl, "stat"); [Perl_my_stat] - stat "ab\ncd" - - warn(warn_nl, "lstat"); [Perl_my_lstat] - lstat "ab\ncd" - - Can't exec \"%s\": %s [Perl_do_aexec5] - - Can't exec \"%s\": %s [Perl_do_exec3] - - Filehandle %s opened only for output [Perl_do_eof] - my $a = eof STDOUT - - Mandatory Warnings ALL TODO - ------------------ - Can't do inplace edit: %s is not a regular file [Perl_nextargv] - edit a directory - - Can't do inplace edit: %s would not be unique [Perl_nextargv] - Can't rename %s to %s: %s, skipping file [Perl_nextargv] - Can't rename %s to %s: %s, skipping file [Perl_nextargv] - Can't remove %s: %s, skipping file [Perl_nextargv] - Can't do inplace edit on %s: %s [Perl_nextargv] - - -__END__ -# doio.c [Perl_do_open9] -use warnings 'io' ; -open(F, '|'.($^O eq 'VMS' ? 'mcr ':'')."$^X -e 1|"); -close(F); -no warnings 'io' ; -open(G, '|'.($^O eq 'VMS' ? 'mcr ':'')."$^X -e 1|"); -close(G); -EXPECT -Can't open bidirectional pipe at - line 3. -######## -# doio.c [Perl_do_open9] -use warnings 'io' ; -open(F, "| "); -no warnings 'io' ; -open(G, "| "); -EXPECT -Missing command in piped open at - line 3. -######## -# doio.c [Perl_do_open9] -use warnings 'io' ; -open(F, " |"); -no warnings 'io' ; -open(G, " |"); -EXPECT -Missing command in piped open at - line 3. -######## -# doio.c [Perl_do_open9] -use warnings 'io' ; -open(F, "<true\ncd"); -no warnings 'io' ; -open(G, "<true\ncd"); -EXPECT -Unsuccessful open on filename containing newline at - line 3. -######## -# doio.c [Perl_do_close] <<TODO -use warnings 'unopened' ; -close "fred" ; -no warnings 'unopened' ; -close "joe" ; -EXPECT -close() on unopened filehandle fred at - line 3. -######## -# doio.c [Perl_do_tell Perl_do_seek Perl_do_sysseek Perl_my_stat] -use warnings 'io' ; -close STDIN ; -tell(STDIN); -$a = seek(STDIN,1,1); -$a = sysseek(STDIN,1,1); --x STDIN ; -stat(STDIN) ; -$a = "fred"; -tell($a); -seek($a,1,1); -sysseek($a,1,1); --x $a; # ok -stat($a); # ok -no warnings 'io' ; -close STDIN ; -tell(STDIN); -$a = seek(STDIN,1,1); -$a = sysseek(STDIN,1,1); --x STDIN ; -stat(STDIN) ; -$a = "fred"; -tell($a); -seek($a,1,1); -sysseek($a,1,1); --x $a; -stat($a); -EXPECT -tell() on closed filehandle STDIN at - line 4. -seek() on closed filehandle STDIN at - line 5. -sysseek() on closed filehandle STDIN at - line 6. --x on closed filehandle STDIN at - line 7. -stat() on closed filehandle STDIN at - line 8. -tell() on unopened filehandle at - line 10. -seek() on unopened filehandle at - line 11. -sysseek() on unopened filehandle at - line 12. -######## -# doio.c [Perl_do_print] -use warnings 'uninitialized' ; -print $a ; -no warnings 'uninitialized' ; -print $b ; -EXPECT -Use of uninitialized value in print at - line 3. -######## -# doio.c [Perl_my_stat Perl_my_lstat] -use warnings 'io' ; -stat "ab\ncd"; -lstat "ab\ncd"; -no warnings 'io' ; -stat "ab\ncd"; -lstat "ab\ncd"; -EXPECT -Unsuccessful stat on filename containing newline at - line 3. -Unsuccessful stat on filename containing newline at - line 4. -######## -# doio.c [Perl_do_aexec5] -use warnings 'io' ; -exec "lskdjfalksdjfdjfkls","" ; -no warnings 'io' ; -exec "lskdjfalksdjfdjfkls","" ; -EXPECT -OPTION regex -Can't exec "lskdjfalksdjfdjfkls": .+ -######## -# doio.c [Perl_do_exec3] -use warnings 'io' ; -exec "lskdjfalksdjfdjfkls", "abc" ; -no warnings 'io' ; -exec "lskdjfalksdjfdjfkls", "abc" ; -EXPECT -OPTION regex -Can't exec "lskdjfalksdjfdjfkls(:? abc)?": .+ -######## -# doio.c [Perl_nextargv] -$^W = 0 ; -my $filename = "./temp.dir" ; -mkdir $filename, 0777 - or die "Cannot create directory $filename: $!\n" ; -{ - local (@ARGV) = ($filename) ; - local ($^I) = "" ; - my $x = <> ; -} -{ - no warnings 'inplace' ; - local (@ARGV) = ($filename) ; - local ($^I) = "" ; - my $x = <> ; -} -{ - use warnings 'inplace' ; - local (@ARGV) = ($filename) ; - local ($^I) = "" ; - my $x = <> ; -} -rmdir $filename ; -EXPECT -Can't do inplace edit: ./temp.dir is not a regular file at - line 9. -Can't do inplace edit: ./temp.dir is not a regular file at - line 21. - -######## -# doio.c [Perl_do_eof] -use warnings 'io' ; -my $a = eof STDOUT ; -no warnings 'io' ; -$a = eof STDOUT ; -EXPECT -Filehandle STDOUT opened only for output at - line 3. diff --git a/t/pragma/warn/doop b/t/pragma/warn/doop deleted file mode 100644 index 5803b44581..0000000000 --- a/t/pragma/warn/doop +++ /dev/null @@ -1,6 +0,0 @@ -# doop.c -use utf8 ; -$_ = "\x80 \xff" ; -chop ; -EXPECT -######## diff --git a/t/pragma/warn/gv b/t/pragma/warn/gv deleted file mode 100644 index 5ed4eca018..0000000000 --- a/t/pragma/warn/gv +++ /dev/null @@ -1,54 +0,0 @@ - gv.c AOK - - Can't locate package %s for @%s::ISA - @ISA = qw(Fred); joe() - - Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated - sub Other::AUTOLOAD { 1 } sub Other::fred {} - @ISA = qw(Other) ; - fred() ; - - Use of $# is deprecated - Use of $* is deprecated - - $a = ${"#"} ; - $a = ${"*"} ; - - Mandatory Warnings ALL TODO - ------------------ - - Had to create %s unexpectedly [gv_fetchpv] - Attempt to free unreferenced glob pointers [gp_free] - -__END__ -# gv.c -use warnings 'misc' ; -@ISA = qw(Fred); joe() -EXPECT -Can't locate package Fred for @main::ISA at - line 3. -Undefined subroutine &main::joe called at - line 3. -######## -# gv.c -no warnings 'misc' ; -@ISA = qw(Fred); joe() -EXPECT -Undefined subroutine &main::joe called at - line 3. -######## -# gv.c -sub Other::AUTOLOAD { 1 } sub Other::fred {} -@ISA = qw(Other) ; -use warnings 'deprecated' ; -fred() ; -EXPECT -Use of inherited AUTOLOAD for non-method main::fred() is deprecated at - line 5. -######## -# gv.c -use warnings 'deprecated' ; -$a = ${"#"}; -$a = ${"*"}; -no warnings 'deprecated' ; -$a = ${"#"}; -$a = ${"*"}; -EXPECT -Use of $# is deprecated at - line 3. -Use of $* is deprecated at - line 4. diff --git a/t/pragma/warn/hv b/t/pragma/warn/hv deleted file mode 100644 index c9eec028f1..0000000000 --- a/t/pragma/warn/hv +++ /dev/null @@ -1,8 +0,0 @@ - hv.c - - - Mandatory Warnings ALL TODO - ------------------ - Attempt to free non-existent shared string [unsharepvn] - -__END__ diff --git a/t/pragma/warn/malloc b/t/pragma/warn/malloc deleted file mode 100644 index 2f8b096a51..0000000000 --- a/t/pragma/warn/malloc +++ /dev/null @@ -1,9 +0,0 @@ - malloc.c - - - Mandatory Warnings ALL TODO - ------------------ - %s free() ignored [Perl_mfree] - %s", "Bad free() ignored [Perl_mfree] - -__END__ diff --git a/t/pragma/warn/mg b/t/pragma/warn/mg deleted file mode 100644 index f2243357b3..0000000000 --- a/t/pragma/warn/mg +++ /dev/null @@ -1,44 +0,0 @@ - mg.c AOK - - No such signal: SIG%s - $SIG{FRED} = sub {} - - SIG%s handler \"%s\" not defined. - $SIG{"INT"} = "ok3"; kill "INT",$$; - - Mandatory Warnings TODO - ------------------ - Can't break at that line [magic_setdbline] - -__END__ -# mg.c -use warnings 'signal' ; -$SIG{FRED} = sub {}; -EXPECT -No such signal: SIGFRED at - line 3. -######## -# mg.c -no warnings 'signal' ; -$SIG{FRED} = sub {}; -EXPECT - -######## -# mg.c -use warnings 'signal' ; -if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') { - print "SKIPPED\n# $^O, can't kill() to raise()\n"; exit; -} -$|=1; -$SIG{"INT"} = "fred"; kill "INT",$$; -EXPECT -SIGINT handler "fred" not defined. -######## -# mg.c -no warnings 'signal' ; -if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') { - print "SKIPPED\n# win32, can't kill() to raise()\n"; exit; -} -$|=1; -$SIG{"INT"} = "fred"; kill "INT",$$; -EXPECT - diff --git a/t/pragma/warn/op b/t/pragma/warn/op deleted file mode 100644 index 2f847ad14c..0000000000 --- a/t/pragma/warn/op +++ /dev/null @@ -1,928 +0,0 @@ - op.c AOK - - "my" variable %s masks earlier declaration in same scope - my $x; - my $x ; - - Variable "%s" may be unavailable - sub x { - my $x; - sub y { - $x - } - } - - Variable "%s" will not stay shared - sub x { - my $x; - sub y { - sub { $x } - } - } - - Found = in conditional, should be == - 1 if $a = 1 ; - - Use of implicit split to @_ is deprecated - split ; - - Use of implicit split to @_ is deprecated - $a = split ; - - Useless use of time in void context - Useless use of a variable in void context - Useless use of a constant in void context - time ; - $a ; - "abc" - - Applying %s to %s will act on scalar(%s) - my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ; - @a =~ /abc/ ; - @a =~ s/a/b/ ; - @a =~ tr/a/b/ ; - @$b =~ /abc/ ; - @$b =~ s/a/b/ ; - @$b =~ tr/a/b/ ; - %a =~ /abc/ ; - %a =~ s/a/b/ ; - %a =~ tr/a/b/ ; - %$c =~ /abc/ ; - %$c =~ s/a/b/ ; - %$c =~ tr/a/b/ ; - - - Parentheses missing around "my" list at -e line 1. - my $a, $b = (1,2); - - Parentheses missing around "local" list at -e line 1. - local $a, $b = (1,2); - - Bareword found in conditional at -e line 1. - use warnings 'bareword'; my $x = print(ABC || 1); - - Value of %s may be \"0\"; use \"defined\" - $x = 1 if $x = <FH> ; - $x = 1 while $x = <FH> ; - - Subroutine fred redefined at -e line 1. - sub fred{1;} sub fred{1;} - - Constant subroutine %s redefined - sub fred() {1;} sub fred() {1;} - - Format FRED redefined at /tmp/x line 5. - format FRED = - . - format FRED = - . - - Array @%s missing the @ in argument %d of %s() - push fred ; - - Hash %%%s missing the %% in argument %d of %s() - keys joe ; - - Statement unlikely to be reached - (Maybe you meant system() when you said exec()? - exec "true" ; my $a - - defined(@array) is deprecated - (Maybe you should just omit the defined()?) - my @a ; defined @a ; - defined (@a = (1,2,3)) ; - - defined(%hash) is deprecated - (Maybe you should just omit the defined()?) - my %h ; defined %h ; - - /---/ should probably be written as "---" - join(/---/, @foo); - - %s() called too early to check prototype [Perl_peep] - fred() ; sub fred ($$) {} - - - Mandatory Warnings - ------------------ - Prototype mismatch: [cv_ckproto] - sub fred() ; - sub fred($) {} - - %s never introduced [pad_leavemy] TODO - Runaway prototype [newSUB] TODO - oops: oopsAV [oopsAV] TODO - oops: oopsHV [oopsHV] TODO - - -__END__ -# op.c -use warnings 'misc' ; -my $x ; -my $x ; -no warnings 'misc' ; -my $x ; -EXPECT -"my" variable $x masks earlier declaration in same scope at - line 4. -######## -# op.c -use warnings 'closure' ; -sub x { - my $x; - sub y { - $x - } - } -EXPECT -Variable "$x" will not stay shared at - line 7. -######## -# op.c -no warnings 'closure' ; -sub x { - my $x; - sub y { - $x - } - } -EXPECT - -######## -# op.c -use warnings 'closure' ; -sub x { - our $x; - sub y { - $x - } - } -EXPECT - -######## -# op.c -use warnings 'closure' ; -sub x { - my $x; - sub y { - sub { $x } - } - } -EXPECT -Variable "$x" may be unavailable at - line 6. -######## -# op.c -no warnings 'closure' ; -sub x { - my $x; - sub y { - sub { $x } - } - } -EXPECT - -######## -# op.c -use warnings 'syntax' ; -1 if $a = 1 ; -no warnings 'syntax' ; -1 if $a = 1 ; -EXPECT -Found = in conditional, should be == at - line 3. -######## -# op.c -use warnings 'deprecated' ; -split ; -no warnings 'deprecated' ; -split ; -EXPECT -Use of implicit split to @_ is deprecated at - line 3. -######## -# op.c -use warnings 'deprecated' ; -$a = split ; -no warnings 'deprecated' ; -$a = split ; -EXPECT -Use of implicit split to @_ is deprecated at - line 3. -######## -# op.c -use warnings 'deprecated'; -my (@foo, %foo); -%main::foo->{"bar"}; -%foo->{"bar"}; -@main::foo->[23]; -@foo->[23]; -$main::foo = {}; %$main::foo->{"bar"}; -$foo = {}; %$foo->{"bar"}; -$main::foo = []; @$main::foo->[34]; -$foo = []; @$foo->[34]; -no warnings 'deprecated'; -%main::foo->{"bar"}; -%foo->{"bar"}; -@main::foo->[23]; -@foo->[23]; -$main::foo = {}; %$main::foo->{"bar"}; -$foo = {}; %$foo->{"bar"}; -$main::foo = []; @$main::foo->[34]; -$foo = []; @$foo->[34]; -EXPECT -Using a hash as a reference is deprecated at - line 4. -Using a hash as a reference is deprecated at - line 5. -Using an array as a reference is deprecated at - line 6. -Using an array as a reference is deprecated at - line 7. -Using a hash as a reference is deprecated at - line 8. -Using a hash as a reference is deprecated at - line 9. -Using an array as a reference is deprecated at - line 10. -Using an array as a reference is deprecated at - line 11. -######## -# op.c -use warnings 'void' ; close STDIN ; -1 x 3 ; # OP_REPEAT - # OP_GVSV -wantarray ; # OP_WANTARRAY - # OP_GV - # OP_PADSV - # OP_PADAV - # OP_PADHV - # OP_PADANY - # OP_AV2ARYLEN -ref ; # OP_REF -\@a ; # OP_REFGEN -\$a ; # OP_SREFGEN -defined $a ; # OP_DEFINED -hex $a ; # OP_HEX -oct $a ; # OP_OCT -length $a ; # OP_LENGTH -substr $a,1 ; # OP_SUBSTR -vec $a,1,2 ; # OP_VEC -index $a,1,2 ; # OP_INDEX -rindex $a,1,2 ; # OP_RINDEX -sprintf $a ; # OP_SPRINTF -$a[0] ; # OP_AELEM - # OP_AELEMFAST -@a[0] ; # OP_ASLICE -#values %a ; # OP_VALUES -#keys %a ; # OP_KEYS -$a{0} ; # OP_HELEM -@a{0} ; # OP_HSLICE -unpack "a", "a" ; # OP_UNPACK -pack $a,"" ; # OP_PACK -join "" ; # OP_JOIN -(@a)[0,1] ; # OP_LSLICE - # OP_ANONLIST - # OP_ANONHASH -sort(1,2) ; # OP_SORT -reverse(1,2) ; # OP_REVERSE - # OP_RANGE - # OP_FLIP -(1 ..2) ; # OP_FLOP -caller ; # OP_CALLER -fileno STDIN ; # OP_FILENO -eof STDIN ; # OP_EOF -tell STDIN ; # OP_TELL -readlink 1; # OP_READLINK -time ; # OP_TIME -localtime ; # OP_LOCALTIME -gmtime ; # OP_GMTIME -eval { getgrnam 1 }; # OP_GGRNAM -eval { getgrgid 1 }; # OP_GGRGID -eval { getpwnam 1 }; # OP_GPWNAM -eval { getpwuid 1 }; # OP_GPWUID -EXPECT -Useless use of repeat (x) in void context at - line 3. -Useless use of wantarray in void context at - line 5. -Useless use of reference-type operator in void context at - line 12. -Useless use of reference constructor in void context at - line 13. -Useless use of single ref constructor in void context at - line 14. -Useless use of defined operator in void context at - line 15. -Useless use of hex in void context at - line 16. -Useless use of oct in void context at - line 17. -Useless use of length in void context at - line 18. -Useless use of substr in void context at - line 19. -Useless use of vec in void context at - line 20. -Useless use of index in void context at - line 21. -Useless use of rindex in void context at - line 22. -Useless use of sprintf in void context at - line 23. -Useless use of array element in void context at - line 24. -Useless use of array slice in void context at - line 26. -Useless use of hash element in void context at - line 29. -Useless use of hash slice in void context at - line 30. -Useless use of unpack in void context at - line 31. -Useless use of pack in void context at - line 32. -Useless use of join or string in void context at - line 33. -Useless use of list slice in void context at - line 34. -Useless use of sort in void context at - line 37. -Useless use of reverse in void context at - line 38. -Useless use of range (or flop) in void context at - line 41. -Useless use of caller in void context at - line 42. -Useless use of fileno in void context at - line 43. -Useless use of eof in void context at - line 44. -Useless use of tell in void context at - line 45. -Useless use of readlink in void context at - line 46. -Useless use of time in void context at - line 47. -Useless use of localtime in void context at - line 48. -Useless use of gmtime in void context at - line 49. -Useless use of getgrnam in void context at - line 50. -Useless use of getgrgid in void context at - line 51. -Useless use of getpwnam in void context at - line 52. -Useless use of getpwuid in void context at - line 53. -######## -# op.c -no warnings 'void' ; close STDIN ; -1 x 3 ; # OP_REPEAT - # OP_GVSV -wantarray ; # OP_WANTARRAY - # OP_GV - # OP_PADSV - # OP_PADAV - # OP_PADHV - # OP_PADANY - # OP_AV2ARYLEN -ref ; # OP_REF -\@a ; # OP_REFGEN -\$a ; # OP_SREFGEN -defined $a ; # OP_DEFINED -hex $a ; # OP_HEX -oct $a ; # OP_OCT -length $a ; # OP_LENGTH -substr $a,1 ; # OP_SUBSTR -vec $a,1,2 ; # OP_VEC -index $a,1,2 ; # OP_INDEX -rindex $a,1,2 ; # OP_RINDEX -sprintf $a ; # OP_SPRINTF -$a[0] ; # OP_AELEM - # OP_AELEMFAST -@a[0] ; # OP_ASLICE -#values %a ; # OP_VALUES -#keys %a ; # OP_KEYS -$a{0} ; # OP_HELEM -@a{0} ; # OP_HSLICE -unpack "a", "a" ; # OP_UNPACK -pack $a,"" ; # OP_PACK -join "" ; # OP_JOIN -(@a)[0,1] ; # OP_LSLICE - # OP_ANONLIST - # OP_ANONHASH -sort(1,2) ; # OP_SORT -reverse(1,2) ; # OP_REVERSE - # OP_RANGE - # OP_FLIP -(1 ..2) ; # OP_FLOP -caller ; # OP_CALLER -fileno STDIN ; # OP_FILENO -eof STDIN ; # OP_EOF -tell STDIN ; # OP_TELL -readlink 1; # OP_READLINK -time ; # OP_TIME -localtime ; # OP_LOCALTIME -gmtime ; # OP_GMTIME -eval { getgrnam 1 }; # OP_GGRNAM -eval { getgrgid 1 }; # OP_GGRGID -eval { getpwnam 1 }; # OP_GPWNAM -eval { getpwuid 1 }; # OP_GPWUID -EXPECT -######## -# op.c -use warnings 'void' ; -for (@{[0]}) { "$_" } # check warning isn't duplicated -no warnings 'void' ; -for (@{[0]}) { "$_" } # check warning isn't duplicated -EXPECT -Useless use of string in void context at - line 3. -######## -# op.c -use warnings 'void' ; -use Config ; -BEGIN { - if ( ! $Config{d_telldir}) { - print <<EOM ; -SKIPPED -# telldir not present -EOM - exit - } -} -telldir 1 ; # OP_TELLDIR -no warnings 'void' ; -telldir 1 ; # OP_TELLDIR -EXPECT -Useless use of telldir in void context at - line 13. -######## -# op.c -use warnings 'void' ; -use Config ; -BEGIN { - if ( ! $Config{d_getppid}) { - print <<EOM ; -SKIPPED -# getppid not present -EOM - exit - } -} -getppid ; # OP_GETPPID -no warnings 'void' ; -getppid ; # OP_GETPPID -EXPECT -Useless use of getppid in void context at - line 13. -######## -# op.c -use warnings 'void' ; -use Config ; -BEGIN { - if ( ! $Config{d_getpgrp}) { - print <<EOM ; -SKIPPED -# getpgrp not present -EOM - exit - } -} -getpgrp ; # OP_GETPGRP -no warnings 'void' ; -getpgrp ; # OP_GETPGRP -EXPECT -Useless use of getpgrp in void context at - line 13. -######## -# op.c -use warnings 'void' ; -use Config ; -BEGIN { - if ( ! $Config{d_times}) { - print <<EOM ; -SKIPPED -# times not present -EOM - exit - } -} -times ; # OP_TMS -no warnings 'void' ; -times ; # OP_TMS -EXPECT -Useless use of times in void context at - line 13. -######## -# op.c -use warnings 'void' ; -use Config ; -BEGIN { - if ( ! $Config{d_getprior} or $^O eq 'os2') { # Locks before fixpak22 - print <<EOM ; -SKIPPED -# getpriority not present -EOM - exit - } -} -getpriority 1,2; # OP_GETPRIORITY -no warnings 'void' ; -getpriority 1,2; # OP_GETPRIORITY -EXPECT -Useless use of getpriority in void context at - line 13. -######## -# op.c -use warnings 'void' ; -use Config ; -BEGIN { - if ( ! $Config{d_getlogin}) { - print <<EOM ; -SKIPPED -# getlogin not present -EOM - exit - } -} -getlogin ; # OP_GETLOGIN -no warnings 'void' ; -getlogin ; # OP_GETLOGIN -EXPECT -Useless use of getlogin in void context at - line 13. -######## -# op.c -use warnings 'void' ; -use Config ; BEGIN { -if ( ! $Config{d_socket}) { - print <<EOM ; -SKIPPED -# getsockname not present -# getpeername not present -# gethostbyname not present -# gethostbyaddr not present -# gethostent not present -# getnetbyname not present -# getnetbyaddr not present -# getnetent not present -# getprotobyname not present -# getprotobynumber not present -# getprotoent not present -# getservbyname not present -# getservbyport not present -# getservent not present -EOM - exit -} } -getsockname STDIN ; # OP_GETSOCKNAME -getpeername STDIN ; # OP_GETPEERNAME -gethostbyname 1 ; # OP_GHBYNAME -gethostbyaddr 1,2; # OP_GHBYADDR -gethostent ; # OP_GHOSTENT -getnetbyname 1 ; # OP_GNBYNAME -getnetbyaddr 1,2 ; # OP_GNBYADDR -getnetent ; # OP_GNETENT -getprotobyname 1; # OP_GPBYNAME -getprotobynumber 1; # OP_GPBYNUMBER -getprotoent ; # OP_GPROTOENT -getservbyname 1,2; # OP_GSBYNAME -getservbyport 1,2; # OP_GSBYPORT -getservent ; # OP_GSERVENT - -no warnings 'void' ; -getsockname STDIN ; # OP_GETSOCKNAME -getpeername STDIN ; # OP_GETPEERNAME -gethostbyname 1 ; # OP_GHBYNAME -gethostbyaddr 1,2; # OP_GHBYADDR -gethostent ; # OP_GHOSTENT -getnetbyname 1 ; # OP_GNBYNAME -getnetbyaddr 1,2 ; # OP_GNBYADDR -getnetent ; # OP_GNETENT -getprotobyname 1; # OP_GPBYNAME -getprotobynumber 1; # OP_GPBYNUMBER -getprotoent ; # OP_GPROTOENT -getservbyname 1,2; # OP_GSBYNAME -getservbyport 1,2; # OP_GSBYPORT -getservent ; # OP_GSERVENT -INIT { - # some functions may not be there, so we exit without running - exit; -} -EXPECT -Useless use of getsockname in void context at - line 24. -Useless use of getpeername in void context at - line 25. -Useless use of gethostbyname in void context at - line 26. -Useless use of gethostbyaddr in void context at - line 27. -Useless use of gethostent in void context at - line 28. -Useless use of getnetbyname in void context at - line 29. -Useless use of getnetbyaddr in void context at - line 30. -Useless use of getnetent in void context at - line 31. -Useless use of getprotobyname in void context at - line 32. -Useless use of getprotobynumber in void context at - line 33. -Useless use of getprotoent in void context at - line 34. -Useless use of getservbyname in void context at - line 35. -Useless use of getservbyport in void context at - line 36. -Useless use of getservent in void context at - line 37. -######## -# op.c -use warnings 'void' ; -*a ; # OP_RV2GV -$a ; # OP_RV2SV -@a ; # OP_RV2AV -%a ; # OP_RV2HV -no warnings 'void' ; -*a ; # OP_RV2GV -$a ; # OP_RV2SV -@a ; # OP_RV2AV -%a ; # OP_RV2HV -EXPECT -Useless use of a variable in void context at - line 3. -Useless use of a variable in void context at - line 4. -Useless use of a variable in void context at - line 5. -Useless use of a variable in void context at - line 6. -######## -# op.c -use warnings 'void' ; -"abc"; # OP_CONST -7 ; # OP_CONST -no warnings 'void' ; -"abc"; # OP_CONST -7 ; # OP_CONST -EXPECT -Useless use of a constant in void context at - line 3. -Useless use of a constant in void context at - line 4. -######## -# op.c -# -use warnings 'misc' ; -my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ; -@a =~ /abc/ ; -@a =~ s/a/b/ ; -@a =~ tr/a/b/ ; -@$b =~ /abc/ ; -@$b =~ s/a/b/ ; -@$b =~ tr/a/b/ ; -%a =~ /abc/ ; -%a =~ s/a/b/ ; -%a =~ tr/a/b/ ; -%$c =~ /abc/ ; -%$c =~ s/a/b/ ; -%$c =~ tr/a/b/ ; -{ -no warnings 'misc' ; -my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ; -@a =~ /abc/ ; -@a =~ s/a/b/ ; -@a =~ tr/a/b/ ; -@$b =~ /abc/ ; -@$b =~ s/a/b/ ; -@$b =~ tr/a/b/ ; -%a =~ /abc/ ; -%a =~ s/a/b/ ; -%a =~ tr/a/b/ ; -%$c =~ /abc/ ; -%$c =~ s/a/b/ ; -%$c =~ tr/a/b/ ; -} -EXPECT -Applying pattern match (m//) to @array will act on scalar(@array) at - line 5. -Applying substitution (s///) to @array will act on scalar(@array) at - line 6. -Applying transliteration (tr///) to @array will act on scalar(@array) at - line 7. -Applying pattern match (m//) to @array will act on scalar(@array) at - line 8. -Applying substitution (s///) to @array will act on scalar(@array) at - line 9. -Applying transliteration (tr///) to @array will act on scalar(@array) at - line 10. -Applying pattern match (m//) to %hash will act on scalar(%hash) at - line 11. -Applying substitution (s///) to %hash will act on scalar(%hash) at - line 12. -Applying transliteration (tr///) to %hash will act on scalar(%hash) at - line 13. -Applying pattern match (m//) to %hash will act on scalar(%hash) at - line 14. -Applying substitution (s///) to %hash will act on scalar(%hash) at - line 15. -Applying transliteration (tr///) to %hash will act on scalar(%hash) at - line 16. -Can't modify private array in substitution (s///) at - line 6, near "s/a/b/ ;" -BEGIN not safe after errors--compilation aborted at - line 18. -######## -# op.c -use warnings 'syntax' ; -my $a, $b = (1,2); -no warnings 'syntax' ; -my $c, $d = (1,2); -EXPECT -Parentheses missing around "my" list at - line 3. -######## -# op.c -use warnings 'syntax' ; -local $a, $b = (1,2); -no warnings 'syntax' ; -local $c, $d = (1,2); -EXPECT -Parentheses missing around "local" list at - line 3. -######## -# op.c -use warnings 'bareword' ; -print (ABC || 1) ; -no warnings 'bareword' ; -print (ABC || 1) ; -EXPECT -Bareword found in conditional at - line 3. -######## ---FILE-- abc - ---FILE-- -# op.c -use warnings 'misc' ; -open FH, "<abc" ; -$x = 1 if $x = <FH> ; -no warnings 'misc' ; -$x = 1 if $x = <FH> ; -EXPECT -Value of <HANDLE> construct can be "0"; test with defined() at - line 4. -######## -# op.c -use warnings 'misc' ; -opendir FH, "." ; -$x = 1 if $x = readdir FH ; -no warnings 'misc' ; -$x = 1 if $x = readdir FH ; -closedir FH ; -EXPECT -Value of readdir() operator can be "0"; test with defined() at - line 4. -######## -# op.c -use warnings 'misc' ; -$x = 1 if $x = <*> ; -no warnings 'misc' ; -$x = 1 if $x = <*> ; -EXPECT -Value of glob construct can be "0"; test with defined() at - line 3. -######## -# op.c -use warnings 'misc' ; -%a = (1,2,3,4) ; -$x = 1 if $x = each %a ; -no warnings 'misc' ; -$x = 1 if $x = each %a ; -EXPECT -Value of each() operator can be "0"; test with defined() at - line 4. -######## -# op.c -use warnings 'misc' ; -$x = 1 while $x = <*> and 0 ; -no warnings 'misc' ; -$x = 1 while $x = <*> and 0 ; -EXPECT -Value of glob construct can be "0"; test with defined() at - line 3. -######## -# op.c -use warnings 'misc' ; -opendir FH, "." ; -$x = 1 while $x = readdir FH and 0 ; -no warnings 'misc' ; -$x = 1 while $x = readdir FH and 0 ; -closedir FH ; -EXPECT -Value of readdir() operator can be "0"; test with defined() at - line 4. -######## -# op.c -use warnings 'redefine' ; -sub fred {} -sub fred {} -no warnings 'redefine' ; -sub fred {} -EXPECT -Subroutine fred redefined at - line 4. -######## -# op.c -use warnings 'redefine' ; -sub fred () { 1 } -sub fred () { 1 } -no warnings 'redefine' ; -sub fred () { 1 } -EXPECT -Constant subroutine fred redefined at - line 4. -######## -# op.c -no warnings 'redefine' ; -sub fred () { 1 } -sub fred () { 2 } -EXPECT -Constant subroutine fred redefined at - line 4. -######## -# op.c -no warnings 'redefine' ; -sub fred () { 1 } -*fred = sub () { 2 }; -EXPECT -Constant subroutine fred redefined at - line 4. -######## -# op.c -use warnings 'redefine' ; -format FRED = -. -format FRED = -. -no warnings 'redefine' ; -format FRED = -. -EXPECT -Format FRED redefined at - line 5. -######## -# op.c -use warnings 'deprecated' ; -push FRED; -no warnings 'deprecated' ; -push FRED; -EXPECT -Array @FRED missing the @ in argument 1 of push() at - line 3. -######## -# op.c -use warnings 'deprecated' ; -@a = keys FRED ; -no warnings 'deprecated' ; -@a = keys FRED ; -EXPECT -Hash %FRED missing the % in argument 1 of keys() at - line 3. -######## -# op.c -use warnings 'syntax' ; -exec "$^X -e 1" ; -my $a -EXPECT -Statement unlikely to be reached at - line 4. - (Maybe you meant system() when you said exec()?) -######## -# op.c -use warnings 'deprecated' ; -my @a; defined(@a); -EXPECT -defined(@array) is deprecated at - line 3. - (Maybe you should just omit the defined()?) -######## -# op.c -use warnings 'deprecated' ; -defined(@a = (1,2,3)); -EXPECT -defined(@array) is deprecated at - line 3. - (Maybe you should just omit the defined()?) -######## -# op.c -use warnings 'deprecated' ; -my %h; defined(%h); -EXPECT -defined(%hash) is deprecated at - line 3. - (Maybe you should just omit the defined()?) -######## -# op.c -no warnings 'syntax' ; -exec "$^X -e 1" ; -my $a -EXPECT - -######## -# op.c -sub fred(); -sub fred($) {} -EXPECT -Prototype mismatch: sub main::fred () vs ($) at - line 3. -######## -# op.c -$^W = 0 ; -sub fred() ; -sub fred($) {} -{ - no warnings 'prototype' ; - sub Fred() ; - sub Fred($) {} - use warnings 'prototype' ; - sub freD() ; - sub freD($) {} -} -sub FRED() ; -sub FRED($) {} -EXPECT -Prototype mismatch: sub main::fred () vs ($) at - line 4. -Prototype mismatch: sub main::freD () vs ($) at - line 11. -Prototype mismatch: sub main::FRED () vs ($) at - line 14. -######## -# op.c -use warnings 'syntax' ; -join /---/, 'x', 'y', 'z'; -EXPECT -/---/ should probably be written as "---" at - line 3. -######## -# op.c [Perl_peep] -use warnings 'prototype' ; -fred() ; -sub fred ($$) {} -no warnings 'prototype' ; -joe() ; -sub joe ($$) {} -EXPECT -main::fred() called too early to check prototype at - line 3. -######## -# op.c [Perl_newATTRSUB] ---FILE-- abc.pm -use warnings 'void' ; -BEGIN { $| = 1; print "in begin\n"; } -CHECK { print "in check\n"; } -INIT { print "in init\n"; } -END { print "in end\n"; } -print "in mainline\n"; -1; ---FILE-- -use abc; -delete $INC{"abc.pm"}; -require abc; -do "abc.pm"; -EXPECT -in begin -in mainline -in check -in init -in begin -Too late to run CHECK block at abc.pm line 3. -Too late to run INIT block at abc.pm line 4. -in mainline -in begin -Too late to run CHECK block at abc.pm line 3. -Too late to run INIT block at abc.pm line 4. -in mainline -in end -in end -in end -######## -# op.c [Perl_newATTRSUB] ---FILE-- abc.pm -no warnings 'void' ; -BEGIN { $| = 1; print "in begin\n"; } -CHECK { print "in check\n"; } -INIT { print "in init\n"; } -END { print "in end\n"; } -print "in mainline\n"; -1; ---FILE-- -require abc; -do "abc.pm"; -EXPECT -in begin -in mainline -in begin -in mainline -in end -in end -######## -# op.c -my @x; -use warnings 'syntax' ; -push(@x); -unshift(@x); -no warnings 'syntax' ; -push(@x); -unshift(@x); -EXPECT -Useless use of push with no values at - line 4. -Useless use of unshift with no values at - line 5. diff --git a/t/pragma/warn/perl b/t/pragma/warn/perl deleted file mode 100644 index 512ee7fb65..0000000000 --- a/t/pragma/warn/perl +++ /dev/null @@ -1,72 +0,0 @@ - perl.c AOK - - gv_check(defstash) - Name \"%s::%s\" used only once: possible typo - - Mandatory Warnings All TODO - ------------------ - Recompile perl with -DDEBUGGING to use -D switch [moreswitches] - Unbalanced scopes: %ld more ENTERs than LEAVEs [perl_destruct] - Unbalanced saves: %ld more saves than restores [perl_destruct] - Unbalanced tmps: %ld more allocs than frees [perl_destruct] - Unbalanced context: %ld more PUSHes than POPs [perl_destruct] - Unbalanced string table refcount: (%d) for \"%s\" [perl_destruct] - Scalars leaked: %ld [perl_destruct] - - -__END__ -# perl.c -no warnings 'once' ; -$x = 3 ; -use warnings 'once' ; -$z = 3 ; -EXPECT -Name "main::z" used only once: possible typo at - line 5. -######## --w -# perl.c -$x = 3 ; -no warnings 'once' ; -$z = 3 -EXPECT -Name "main::x" used only once: possible typo at - line 3. -######## -# perl.c -BEGIN { $^W =1 ; } -$x = 3 ; -no warnings 'once' ; -$z = 3 -EXPECT -Name "main::x" used only once: possible typo at - line 3. -######## --W -# perl.c -no warnings 'once' ; -$x = 3 ; -use warnings 'once' ; -$z = 3 ; -EXPECT -Name "main::z" used only once: possible typo at - line 6. -Name "main::x" used only once: possible typo at - line 4. -######## --X -# perl.c -use warnings 'once' ; -$x = 3 ; -EXPECT -######## - -# perl.c -{ use warnings 'once' ; $x = 3 ; } -$y = 3 ; -EXPECT -Name "main::x" used only once: possible typo at - line 3. -######## - -# perl.c -$z = 3 ; -BEGIN { $^W = 1 } -{ no warnings 'once' ; $x = 3 ; } -$y = 3 ; -EXPECT -Name "main::y" used only once: possible typo at - line 6. diff --git a/t/pragma/warn/perlio b/t/pragma/warn/perlio deleted file mode 100644 index 18c0dfa89f..0000000000 --- a/t/pragma/warn/perlio +++ /dev/null @@ -1,10 +0,0 @@ - perlio.c - - - Mandatory Warnings ALL TODO - ------------------ - Setting cnt to %d - Setting ptr %p > end+1 %p - Setting cnt to %d, ptr implies %d - -__END__ diff --git a/t/pragma/warn/perly b/t/pragma/warn/perly deleted file mode 100644 index afc5dccc72..0000000000 --- a/t/pragma/warn/perly +++ /dev/null @@ -1,31 +0,0 @@ - perly.y AOK - - dep() => deprecate("\"do\" to call subroutines") - Use of "do" to call subroutines is deprecated - - sub fred {} do fred() - sub fred {} do fred(1) - sub fred {} $a = "fred" ; do $a() - sub fred {} $a = "fred" ; do $a(1) - - -__END__ -# perly.y -use warnings 'deprecated' ; -sub fred {} -do fred() ; -do fred(1) ; -$a = "fred" ; -do $a() ; -do $a(1) ; -no warnings 'deprecated' ; -do fred() ; -do fred(1) ; -$a = "fred" ; -do $a() ; -do $a(1) ; -EXPECT -Use of "do" to call subroutines is deprecated at - line 4. -Use of "do" to call subroutines is deprecated at - line 5. -Use of "do" to call subroutines is deprecated at - line 7. -Use of "do" to call subroutines is deprecated at - line 8. diff --git a/t/pragma/warn/pp b/t/pragma/warn/pp deleted file mode 100644 index 62f054a6ee..0000000000 --- a/t/pragma/warn/pp +++ /dev/null @@ -1,150 +0,0 @@ - pp.c TODO - - substr outside of string - $a = "ab" ; $b = substr($a, 4,5) ; - - Attempt to use reference as lvalue in substr - $a = "ab" ; $b = \$a ; substr($b, 1,1) = $b - - uninitialized in pp_rv2gv() - my *b = *{ undef()} - - uninitialized in pp_rv2sv() - my $a = undef ; my $b = $$a - - Odd number of elements in hash list - my $a = { 1,2,3 } ; - - Invalid type in unpack: '%c - my $A = pack ("A,A", 1,2) ; - my @A = unpack ("A,A", "22") ; - - Attempt to pack pointer to temporary value - pack("p", "abc") ; - - Explicit blessing to '' (assuming package main) - bless \[], ""; - - Constant subroutine %s undefined <<<TODO - Constant subroutine (anonymous) undefined <<<TODO - -__END__ -# pp.c -use warnings 'substr' ; -$a = "ab" ; -$b = substr($a, 4,5) ; -no warnings 'substr' ; -$a = "ab" ; -$b = substr($a, 4,5) ; -EXPECT -substr outside of string at - line 4. -######## -# pp.c -use warnings 'substr' ; -$a = "ab" ; -$b = \$a ; -substr($b, 1,1) = "ab" ; -no warnings 'substr' ; -substr($b, 1,1) = "ab" ; -EXPECT -Attempt to use reference as lvalue in substr at - line 5. -######## -# pp.c -use warnings 'uninitialized' ; -# TODO -EXPECT - -######## -# pp.c -use warnings 'misc' ; -my $a = { 1,2,3}; -no warnings 'misc' ; -my $b = { 1,2,3}; -EXPECT -Odd number of elements in hash assignment at - line 3. -######## -# pp.c -use warnings 'pack' ; -use warnings 'unpack' ; -my @a = unpack ("A,A", "22") ; -my $a = pack ("A,A", 1,2) ; -no warnings 'pack' ; -no warnings 'unpack' ; -my @b = unpack ("A,A", "22") ; -my $b = pack ("A,A", 1,2) ; -EXPECT -Invalid type in unpack: ',' at - line 4. -Invalid type in pack: ',' at - line 5. -######## -# pp.c -use warnings 'uninitialized' ; -my $a = undef ; -my $b = $$a; -no warnings 'uninitialized' ; -my $c = $$a; -EXPECT -Use of uninitialized value in scalar dereference at - line 4. -######## -# pp.c -use warnings 'pack' ; -sub foo { my $a = "a"; return $a . $a++ . $a++ } -my $a = pack("p", &foo) ; -no warnings 'pack' ; -my $b = pack("p", &foo) ; -EXPECT -Attempt to pack pointer to temporary value at - line 4. -######## -# pp.c -use warnings 'misc' ; -bless \[], "" ; -no warnings 'misc' ; -bless \[], "" ; -EXPECT -Explicit blessing to '' (assuming package main) at - line 3. -######## -# pp.c -use utf8 ; -$_ = "\x80 \xff" ; -reverse ; -EXPECT -######## -# pp.c -use warnings 'pack' ; -print unpack("C", pack("C", -1)), "\n"; -print unpack("C", pack("C", 0)), "\n"; -print unpack("C", pack("C", 255)), "\n"; -print unpack("C", pack("C", 256)), "\n"; -print unpack("c", pack("c", -129)), "\n"; -print unpack("c", pack("c", -128)), "\n"; -print unpack("c", pack("c", 127)), "\n"; -print unpack("c", pack("c", 128)), "\n"; -no warnings 'pack' ; -print unpack("C", pack("C", -1)), "\n"; -print unpack("C", pack("C", 0)), "\n"; -print unpack("C", pack("C", 255)), "\n"; -print unpack("C", pack("C", 256)), "\n"; -print unpack("c", pack("c", -129)), "\n"; -print unpack("c", pack("c", -128)), "\n"; -print unpack("c", pack("c", 127)), "\n"; -print unpack("c", pack("c", 128)), "\n"; -EXPECT -Character in "C" format wrapped at - line 3. -Character in "C" format wrapped at - line 6. -Character in "c" format wrapped at - line 7. -Character in "c" format wrapped at - line 10. -255 -0 -255 -0 -127 --128 -127 --128 -255 -0 -255 -0 -127 --128 -127 --128 diff --git a/t/pragma/warn/pp_ctl b/t/pragma/warn/pp_ctl deleted file mode 100644 index ac01f277b1..0000000000 --- a/t/pragma/warn/pp_ctl +++ /dev/null @@ -1,230 +0,0 @@ - pp_ctl.c AOK - - Not enough format arguments - format STDOUT = - @<<< @<<< - $a - . - write; - - - Exiting substitution via %s - $_ = "abc" ; - while ($i ++ == 0) - { - s/ab/last/e ; - } - - Exiting subroutine via %s - sub fred { last } - { fred() } - - Exiting eval via %s - { eval "last" } - - Exiting pseudo-block via %s - @a = (1,2) ; @b = sort { last } @a ; - - Exiting substitution via %s - $_ = "abc" ; - last fred: - while ($i ++ == 0) - { - s/ab/last fred/e ; - } - - - Exiting subroutine via %s - sub fred { last joe } - joe: { fred() } - - Exiting eval via %s - fred: { eval "last fred" } - - Exiting pseudo-block via %s - @a = (1,2) ; fred: @b = sort { last fred } @a ; - - - Deep recursion on subroutine \"%s\" - sub fred - { - fred() if $a++ < 200 - } - - fred() - - (in cleanup) foo bar - package Foo; - DESTROY { die "foo bar" } - { bless [], 'Foo' for 1..10 } - -__END__ -# pp_ctl.c -use warnings 'syntax' ; -format STDOUT = -@<<< @<<< -1 -. -write; -EXPECT -Not enough format arguments at - line 5. -1 -######## -# pp_ctl.c -no warnings 'syntax' ; -format = -@<<< @<<< -1 -. -write ; -EXPECT -1 -######## -# pp_ctl.c -use warnings 'exiting' ; -$_ = "abc" ; - -while ($i ++ == 0) -{ - s/ab/last/e ; -} -no warnings 'exiting' ; -while ($i ++ == 0) -{ - s/ab/last/e ; -} -EXPECT -Exiting substitution via last at - line 7. -######## -# pp_ctl.c -use warnings 'exiting' ; -sub fred { last } -{ fred() } -no warnings 'exiting' ; -sub joe { last } -{ joe() } -EXPECT -Exiting subroutine via last at - line 3. -######## -# pp_ctl.c -{ - eval "use warnings 'exiting' ; last;" -} -print STDERR $@ ; -{ - eval "no warnings 'exiting' ;last;" -} -print STDERR $@ ; -EXPECT -Exiting eval via last at (eval 1) line 1. -######## -# pp_ctl.c -use warnings 'exiting' ; -@a = (1,2) ; -@b = sort { last } @a ; -no warnings 'exiting' ; -@b = sort { last } @a ; -EXPECT -Exiting pseudo-block via last at - line 4. -Can't "last" outside a loop block at - line 4. -######## -# pp_ctl.c -use warnings 'exiting' ; -$_ = "abc" ; -fred: -while ($i ++ == 0) -{ - s/ab/last fred/e ; -} -no warnings 'exiting' ; -while ($i ++ == 0) -{ - s/ab/last fred/e ; -} -EXPECT -Exiting substitution via last at - line 7. -######## -# pp_ctl.c -use warnings 'exiting' ; -sub fred { last joe } -joe: { fred() } -no warnings 'exiting' ; -sub Fred { last Joe } -Joe: { Fred() } -EXPECT -Exiting subroutine via last at - line 3. -######## -# pp_ctl.c -joe: -{ eval "use warnings 'exiting' ; last joe;" } -print STDERR $@ ; -Joe: -{ eval "no warnings 'exiting' ; last Joe;" } -print STDERR $@ ; -EXPECT -Exiting eval via last at (eval 1) line 1. -######## -# pp_ctl.c -use warnings 'exiting' ; -@a = (1,2) ; -fred: @b = sort { last fred } @a ; -no warnings 'exiting' ; -Fred: @b = sort { last Fred } @a ; -EXPECT -Exiting pseudo-block via last at - line 4. -Label not found for "last fred" at - line 4. -######## -# pp_ctl.c -use warnings 'recursion' ; -BEGIN { warn "PREFIX\n" ;} -sub fred -{ - fred() if $a++ < 200 -} - -fred() -EXPECT -Deep recursion on subroutine "main::fred" at - line 6. -######## -# pp_ctl.c -no warnings 'recursion' ; -BEGIN { warn "PREFIX\n" ;} -sub fred -{ - fred() if $a++ < 200 -} - -fred() -EXPECT -######## -# pp_ctl.c -use warnings 'misc' ; -package Foo; -DESTROY { die "@{$_[0]} foo bar" } -{ bless ['A'], 'Foo' for 1..10 } -{ bless ['B'], 'Foo' for 1..10 } -EXPECT - (in cleanup) A foo bar at - line 4. - (in cleanup) B foo bar at - line 4. -######## -# pp_ctl.c -no warnings 'misc' ; -package Foo; -DESTROY { die "@{$_[0]} foo bar" } -{ bless ['A'], 'Foo' for 1..10 } -{ bless ['B'], 'Foo' for 1..10 } -EXPECT -######## -# pp_ctl.c -use warnings; -eval 'print $foo'; -EXPECT -Use of uninitialized value in print at (eval 1) line 1. -######## -# pp_ctl.c -use warnings; -{ - no warnings; - eval 'print $foo'; -} -EXPECT diff --git a/t/pragma/warn/pp_hot b/t/pragma/warn/pp_hot deleted file mode 100644 index c5a3790587..0000000000 --- a/t/pragma/warn/pp_hot +++ /dev/null @@ -1,284 +0,0 @@ - pp_hot.c - - print() on unopened filehandle abc [pp_print] - $f = $a = "abc" ; print $f $a - - Filehandle %s opened only for input [pp_print] - print STDIN "abc" ; - - Filehandle %s opened only for output [pp_print] - print <STDOUT> ; - - print() on closed filehandle %s [pp_print] - close STDIN ; print STDIN "abc" ; - - uninitialized [pp_rv2av] - my $a = undef ; my @b = @$a - - uninitialized [pp_rv2hv] - my $a = undef ; my %b = %$a - - Odd number of elements in hash list [pp_aassign] - %X = (1,2,3) ; - - Reference found where even-sized list expected [pp_aassign] - $X = [ 1 ..3 ]; - - Filehandle %s opened only for output [Perl_do_readline] - open (FH, ">./xcv") ; - my $a = <FH> ; - - glob failed (can't start child: %s) [Perl_do_readline] <<TODO - - readline() on closed filehandle %s [Perl_do_readline] - close STDIN ; $a = <STDIN>; - - readline() on closed filehandle %s [Perl_do_readline] - readline(NONESUCH); - - glob failed (child exited with status %d%s) [Perl_do_readline] <<TODO - - Deep recursion on subroutine \"%s\" [Perl_sub_crush_depth] - sub fred { fred() if $a++ < 200} fred() - - Deep recursion on anonymous subroutine [Perl_sub_crush_depth] - $a = sub { &$a if $a++ < 200} &$a - - Possible Y2K bug: about to append an integer to '19' [pp_concat] - $x = "19$yy\n"; - - Use of reference "%s" as array index [pp_aelem] - $x[\1] - -__END__ -# pp_hot.c [pp_print] -use warnings 'unopened' ; -$f = $a = "abc" ; -print $f $a; -no warnings 'unopened' ; -print $f $a; -EXPECT -print() on unopened filehandle abc at - line 4. -######## -# pp_hot.c [pp_print] -use warnings 'io' ; -print STDIN "anc"; -print <STDOUT>; -print <STDERR>; -open(FOO, ">&STDOUT") and print <FOO>; -print getc(STDERR); -print getc(FOO); -#################################################################### -# The next test is known to fail on some systems (Linux+old glibc, # -# some *BSDs (including Mac OS X and NeXT), among others. # -# We skip it for now (on the grounds that it is "just" a warning). # -#################################################################### -#read(FOO,$_,1); -no warnings 'io' ; -print STDIN "anc"; -EXPECT -Filehandle STDIN opened only for input at - line 3. -Filehandle STDOUT opened only for output at - line 4. -Filehandle STDERR opened only for output at - line 5. -Filehandle FOO opened only for output at - line 6. -Filehandle STDERR opened only for output at - line 7. -Filehandle FOO opened only for output at - line 8. -######## -# pp_hot.c [pp_print] -use warnings 'closed' ; -close STDIN ; -print STDIN "anc"; -opendir STDIN, "."; -print STDIN "anc"; -closedir STDIN; -no warnings 'closed' ; -print STDIN "anc"; -opendir STDIN, "."; -print STDIN "anc"; -EXPECT -print() on closed filehandle STDIN at - line 4. -print() on closed filehandle STDIN at - line 6. - (Are you trying to call print() on dirhandle STDIN?) -######## -# pp_hot.c [pp_rv2av] -use warnings 'uninitialized' ; -my $a = undef ; -my @b = @$a; -no warnings 'uninitialized' ; -my @c = @$a; -EXPECT -Use of uninitialized value in array dereference at - line 4. -######## -# pp_hot.c [pp_rv2hv] -use warnings 'uninitialized' ; -my $a = undef ; -my %b = %$a; -no warnings 'uninitialized' ; -my %c = %$a; -EXPECT -Use of uninitialized value in hash dereference at - line 4. -######## -# pp_hot.c [pp_aassign] -use warnings 'misc' ; -my %X ; %X = (1,2,3) ; -no warnings 'misc' ; -my %Y ; %Y = (1,2,3) ; -EXPECT -Odd number of elements in hash assignment at - line 3. -######## -# pp_hot.c [pp_aassign] -use warnings 'misc' ; -my %X ; %X = [1 .. 3] ; -no warnings 'misc' ; -my %Y ; %Y = [1 .. 3] ; -EXPECT -Reference found where even-sized list expected at - line 3. -######## -# pp_hot.c [Perl_do_readline] -use warnings 'closed' ; -close STDIN ; $a = <STDIN> ; -opendir STDIN, "." ; $a = <STDIN> ; -closedir STDIN; -no warnings 'closed' ; -opendir STDIN, "." ; $a = <STDIN> ; -$a = <STDIN> ; -EXPECT -readline() on closed filehandle STDIN at - line 3. -readline() on closed filehandle STDIN at - line 4. - (Are you trying to call readline() on dirhandle STDIN?) -######## -# pp_hot.c [Perl_do_readline] -use warnings 'io' ; -my $file = "./xcv" ; unlink $file ; -open (FH, ">./xcv") ; -my $a = <FH> ; -no warnings 'io' ; -$a = <FH> ; -close (FH) ; -unlink $file ; -EXPECT -Filehandle FH opened only for output at - line 5. -######## -# pp_hot.c [Perl_sub_crush_depth] -use warnings 'recursion' ; -sub fred -{ - fred() if $a++ < 200 -} -{ - local $SIG{__WARN__} = sub { - die "ok\n" if $_[0] =~ /^Deep recursion on subroutine "main::fred"/ - }; - fred(); -} -EXPECT -ok -######## -# pp_hot.c [Perl_sub_crush_depth] -no warnings 'recursion' ; -sub fred -{ - fred() if $a++ < 200 -} -{ - local $SIG{__WARN__} = sub { - die "ok\n" if $_[0] =~ /^Deep recursion on subroutine "main::fred"/ - }; - fred(); -} -EXPECT - -######## -# pp_hot.c [Perl_sub_crush_depth] -use warnings 'recursion' ; -$b = sub -{ - &$b if $a++ < 200 -} ; - -&$b ; -EXPECT -Deep recursion on anonymous subroutine at - line 5. -######## -# pp_hot.c [Perl_sub_crush_depth] -no warnings 'recursion' ; -$b = sub -{ - &$b if $a++ < 200 -} ; - -&$b ; -EXPECT -######## -# pp_hot.c [pp_concat] -use warnings 'uninitialized'; -my($x, $y); -sub a { shift } -a($x . "x"); # should warn once -a($x . $y); # should warn twice -$x .= $y; # should warn once -$y .= $y; # should warn once -EXPECT -Use of uninitialized value in concatenation (.) or string at - line 5. -Use of uninitialized value in concatenation (.) or string at - line 6. -Use of uninitialized value in concatenation (.) or string at - line 6. -Use of uninitialized value in concatenation (.) or string at - line 7. -Use of uninitialized value in concatenation (.) or string at - line 8. -######## -# pp_hot.c [pp_concat] -use warnings 'y2k'; -use Config; -BEGIN { - unless ($Config{ccflags} =~ /Y2KWARN/) { - print "SKIPPED\n# perl not built with -DPERL_Y2KWARN"; - exit 0; - } -} -my $x; -my $yy = 78; -$x = "19$yy\n"; -$x = "19" . $yy . "\n"; -$x = "319$yy\n"; -$x = "319" . $yy . "\n"; -$yy = 19; -$x = "ok $yy\n"; -$yy = 9; -$x = 1 . $yy; -no warnings 'y2k'; -$x = "19$yy\n"; -$x = "19" . $yy . "\n"; -EXPECT -Possible Y2K bug: about to append an integer to '19' at - line 12. -Possible Y2K bug: about to append an integer to '19' at - line 13. -######## -# pp_hot.c [pp_aelem] -{ -use warnings 'misc'; -print $x[\1]; -} -{ -no warnings 'misc'; -print $x[\1]; -} - -EXPECT -OPTION regex -Use of reference ".*" as array index at - line 4. -######## -# pp_hot.c [pp_aelem] -package Foo;use overload q("") => sub {};package main;$a = bless {}, "Foo"; -$b = {}; -{ -use warnings 'misc'; -print $x[$a]; -print $x[$b]; -} -{ -no warnings 'misc'; -print $x[$a]; -print $x[$b]; -} - -EXPECT -OPTION regex -Use of reference ".*" as array index at - line 7. diff --git a/t/pragma/warn/pp_sys b/t/pragma/warn/pp_sys deleted file mode 100644 index e30637b0d4..0000000000 --- a/t/pragma/warn/pp_sys +++ /dev/null @@ -1,419 +0,0 @@ - pp_sys.c AOK - - untie attempted while %d inner references still exist [pp_untie] - sub TIESCALAR { bless [] } ; tie $a, 'main'; untie $a ; - - fileno() on unopened filehandle abc [pp_fileno] - $a = "abc"; fileno($a) - - binmode() on unopened filehandle abc [pp_binmode] - $a = "abc"; fileno($a) - - printf() on unopened filehandle abc [pp_prtf] - $a = "abc"; printf $a "fred" - - Filehandle %s opened only for input [pp_leavewrite] - format STDIN = - . - write STDIN; - - write() on closed filehandle %s [pp_leavewrite] - format STDIN = - . - close STDIN; - write STDIN ; - - page overflow [pp_leavewrite] - - printf() on unopened filehandle abc [pp_prtf] - $a = "abc"; printf $a "fred" - - Filehandle %s opened only for input [pp_prtf] - $a = "abc"; - printf $a "fred" - - printf() on closed filehandle %s [pp_prtf] - close STDIN ; - printf STDIN "fred" - - syswrite() on closed filehandle %s [pp_send] - close STDIN; - syswrite STDIN, "fred", 1; - - send() on closed socket %s [pp_send] - close STDIN; - send STDIN, "fred", 1 - - bind() on closed socket %s [pp_bind] - close STDIN; - bind STDIN, "fred" ; - - - connect() on closed socket %s [pp_connect] - close STDIN; - connect STDIN, "fred" ; - - listen() on closed socket %s [pp_listen] - close STDIN; - listen STDIN, 2; - - accept() on closed socket %s [pp_accept] - close STDIN; - accept "fred", STDIN ; - - shutdown() on closed socket %s [pp_shutdown] - close STDIN; - shutdown STDIN, 0; - - setsockopt() on closed socket %s [pp_ssockopt] - getsockopt() on closed socket %s [pp_ssockopt] - close STDIN; - setsockopt STDIN, 1,2,3; - getsockopt STDIN, 1,2; - - getsockname() on closed socket %s [pp_getpeername] - getpeername() on closed socket %s [pp_getpeername] - close STDIN; - getsockname STDIN; - getpeername STDIN; - - flock() on closed socket %s [pp_flock] - flock() on closed socket [pp_flock] - close STDIN; - flock STDIN, 8; - flock $a, 8; - - The stat preceding lstat() wasn't an lstat %s [pp_stat] - lstat(STDIN); - - warn(warn_nl, "stat"); [pp_stat] - - -T on closed filehandle %s - stat() on closed filehandle %s - close STDIN ; -T STDIN ; stat(STDIN) ; - - warn(warn_nl, "open"); [pp_fttext] - -T "abc\ndef" ; - - Filehandle %s opened only for output [pp_sysread] - my $file = "./xcv" ; - open(F, ">$file") ; - my $a = sysread(F, $a,10) ; - - - -__END__ -# pp_sys.c [pp_untie] -use warnings 'untie' ; -sub TIESCALAR { bless [] } ; -$b = tie $a, 'main'; -untie $a ; -no warnings 'untie' ; -$c = tie $d, 'main'; -untie $d ; -EXPECT -untie attempted while 1 inner references still exist at - line 5. -######## -# pp_sys.c [pp_leavewrite] -use warnings 'io' ; -format STDIN = -. -write STDIN; -no warnings 'io' ; -write STDIN; -EXPECT -Filehandle STDIN opened only for input at - line 5. -######## -# pp_sys.c [pp_leavewrite] -use warnings 'closed' ; -format STDIN = -. -close STDIN; -write STDIN; -opendir STDIN, "."; -write STDIN; -closedir STDIN; -no warnings 'closed' ; -write STDIN; -opendir STDIN, "."; -write STDIN; -EXPECT -write() on closed filehandle STDIN at - line 6. -write() on closed filehandle STDIN at - line 8. - (Are you trying to call write() on dirhandle STDIN?) -######## -# pp_sys.c [pp_leavewrite] -use warnings 'io' ; -format STDOUT_TOP = -abc -. -format STDOUT = -def -ghi -. -$= = 1 ; -$- =1 ; -open STDOUT, ">".($^O eq 'VMS'? 'NL:' : '/dev/null') ; -write ; -no warnings 'io' ; -write ; -EXPECT -page overflow at - line 13. -######## -# pp_sys.c [pp_prtf] -use warnings 'unopened' ; -$a = "abc"; -printf $a "fred"; -no warnings 'unopened' ; -printf $a "fred"; -EXPECT -printf() on unopened filehandle abc at - line 4. -######## -# pp_sys.c [pp_prtf] -use warnings 'closed' ; -close STDIN ; -printf STDIN "fred"; -opendir STDIN, "."; -printf STDIN "fred"; -closedir STDIN; -no warnings 'closed' ; -printf STDIN "fred"; -opendir STDIN, "."; -printf STDIN "fred"; -EXPECT -printf() on closed filehandle STDIN at - line 4. -printf() on closed filehandle STDIN at - line 6. - (Are you trying to call printf() on dirhandle STDIN?) -######## -# pp_sys.c [pp_prtf] -use warnings 'io' ; -printf STDIN "fred"; -no warnings 'io' ; -printf STDIN "fred"; -EXPECT -Filehandle STDIN opened only for input at - line 3. -######## -# pp_sys.c [pp_send] -use warnings 'closed' ; -close STDIN; -syswrite STDIN, "fred", 1; -opendir STDIN, "."; -syswrite STDIN, "fred", 1; -closedir STDIN; -no warnings 'closed' ; -syswrite STDIN, "fred", 1; -opendir STDIN, "."; -syswrite STDIN, "fred", 1; -EXPECT -syswrite() on closed filehandle STDIN at - line 4. -syswrite() on closed filehandle STDIN at - line 6. - (Are you trying to call syswrite() on dirhandle STDIN?) -######## -# pp_sys.c [pp_flock] -use Config; -BEGIN { - if ( !$Config{d_flock} && - !$Config{d_fcntl_can_lock} && - !$Config{d_lockf} ) { - print <<EOM ; -SKIPPED -# flock not present -EOM - exit ; - } -} -use warnings qw(unopened closed); -close STDIN; -flock STDIN, 8; -opendir STDIN, "."; -flock STDIN, 8; -flock FOO, 8; -flock $a, 8; -no warnings qw(unopened closed); -flock STDIN, 8; -opendir STDIN, "."; -flock STDIN, 8; -flock FOO, 8; -flock $a, 8; -EXPECT -flock() on closed filehandle STDIN at - line 16. -flock() on closed filehandle STDIN at - line 18. - (Are you trying to call flock() on dirhandle STDIN?) -flock() on unopened filehandle FOO at - line 19. -flock() on unopened filehandle at - line 20. -######## -# pp_sys.c [pp_prtf pp_send pp_bind pp_connect pp_listen pp_accept pp_shutdown pp_ssockopt ppp_getpeername] -use warnings 'io' ; -use Config; -BEGIN { - if ( $^O ne 'VMS' and ! $Config{d_socket}) { - print <<EOM ; -SKIPPED -# send not present -# bind not present -# connect not present -# accept not present -# shutdown not present -# setsockopt not present -# getsockopt not present -# getsockname not present -# getpeername not present -EOM - exit ; - } -} -close STDIN; -send STDIN, "fred", 1; -bind STDIN, "fred" ; -connect STDIN, "fred" ; -listen STDIN, 2; -accept "fred", STDIN; -shutdown STDIN, 0; -setsockopt STDIN, 1,2,3; -getsockopt STDIN, 1,2; -getsockname STDIN; -getpeername STDIN; -opendir STDIN, "."; -send STDIN, "fred", 1; -bind STDIN, "fred" ; -connect STDIN, "fred" ; -listen STDIN, 2; -accept "fred", STDIN; -shutdown STDIN, 0; -setsockopt STDIN, 1,2,3; -getsockopt STDIN, 1,2; -getsockname STDIN; -getpeername STDIN; -closedir STDIN; -no warnings 'io' ; -send STDIN, "fred", 1; -bind STDIN, "fred" ; -connect STDIN, "fred" ; -listen STDIN, 2; -accept STDIN, "fred" ; -shutdown STDIN, 0; -setsockopt STDIN, 1,2,3; -getsockopt STDIN, 1,2; -getsockname STDIN; -getpeername STDIN; -opendir STDIN, "."; -send STDIN, "fred", 1; -bind STDIN, "fred" ; -connect STDIN, "fred" ; -listen STDIN, 2; -accept "fred", STDIN; -shutdown STDIN, 0; -setsockopt STDIN, 1,2,3; -getsockopt STDIN, 1,2; -getsockname STDIN; -getpeername STDIN; -EXPECT -send() on closed socket STDIN at - line 22. -bind() on closed socket STDIN at - line 23. -connect() on closed socket STDIN at - line 24. -listen() on closed socket STDIN at - line 25. -accept() on closed socket STDIN at - line 26. -shutdown() on closed socket STDIN at - line 27. -setsockopt() on closed socket STDIN at - line 28. -getsockopt() on closed socket STDIN at - line 29. -getsockname() on closed socket STDIN at - line 30. -getpeername() on closed socket STDIN at - line 31. -send() on closed socket STDIN at - line 33. - (Are you trying to call send() on dirhandle STDIN?) -bind() on closed socket STDIN at - line 34. - (Are you trying to call bind() on dirhandle STDIN?) -connect() on closed socket STDIN at - line 35. - (Are you trying to call connect() on dirhandle STDIN?) -listen() on closed socket STDIN at - line 36. - (Are you trying to call listen() on dirhandle STDIN?) -accept() on closed socket STDIN at - line 37. - (Are you trying to call accept() on dirhandle STDIN?) -shutdown() on closed socket STDIN at - line 38. - (Are you trying to call shutdown() on dirhandle STDIN?) -setsockopt() on closed socket STDIN at - line 39. - (Are you trying to call setsockopt() on dirhandle STDIN?) -getsockopt() on closed socket STDIN at - line 40. - (Are you trying to call getsockopt() on dirhandle STDIN?) -getsockname() on closed socket STDIN at - line 41. - (Are you trying to call getsockname() on dirhandle STDIN?) -getpeername() on closed socket STDIN at - line 42. - (Are you trying to call getpeername() on dirhandle STDIN?) -######## -# pp_sys.c [pp_stat] -use warnings 'newline' ; -stat "abc\ndef"; -no warnings 'newline' ; -stat "abc\ndef"; -EXPECT -Unsuccessful stat on filename containing newline at - line 3. -######## -# pp_sys.c [pp_stat] -use Config; -BEGIN { - if ($^O eq 'd_lstat') { - print <<EOM ; -SKIPPED -# lstat not present -EOM - exit ; - } -} -use warnings 'io' ; -lstat(STDIN) ; -no warnings 'io' ; -lstat(STDIN) ; -EXPECT -The stat preceding lstat() wasn't an lstat at - line 13. -######## -# pp_sys.c [pp_fttext] -use warnings qw(unopened closed) ; -close STDIN ; --T STDIN ; -stat(STDIN) ; --T HOCUS; -stat(POCUS); -no warnings qw(unopened closed) ; --T STDIN ; -stat(STDIN); --T HOCUS; -stat(POCUS); -EXPECT --T on closed filehandle STDIN at - line 4. -stat() on closed filehandle STDIN at - line 5. --T on unopened filehandle HOCUS at - line 6. -stat() on unopened filehandle POCUS at - line 7. -######## -# pp_sys.c [pp_fttext] -use warnings 'newline' ; --T "abc\ndef" ; -no warnings 'newline' ; --T "abc\ndef" ; -EXPECT -Unsuccessful open on filename containing newline at - line 3. -######## -# pp_sys.c [pp_sysread] -use warnings 'io' ; -if ($^O eq 'dos') { - print <<EOM ; -SKIPPED -# skipped on dos -EOM - exit ; -} -my $file = "./xcv" ; -open(F, ">$file") ; -my $a = sysread(F, $a,10) ; -no warnings 'io' ; -my $a = sysread(F, $a,10) ; -close F ; -unlink $file ; -EXPECT -Filehandle F opened only for output at - line 12. -######## -# pp_sys.c [pp_binmode] -use warnings 'unopened' ; -binmode(BLARG); -$a = "BLERG";binmode($a); -EXPECT -binmode() on unopened filehandle BLARG at - line 3. -binmode() on unopened filehandle at - line 4. diff --git a/t/pragma/warn/regcomp b/t/pragma/warn/regcomp deleted file mode 100644 index ceca4410d6..0000000000 --- a/t/pragma/warn/regcomp +++ /dev/null @@ -1,239 +0,0 @@ - regcomp.c AOK - - Quantifier unexpected on zero-length expression [S_study_chunk] - - (?p{}) is deprecated - use (??{}) [S_reg] - $a =~ /(?p{'x'})/ ; - - - Useless (%s%c) - %suse /%c modifier [S_reg] - Useless (%sc) - %suse /gc modifier [S_reg] - - - - Strange *+?{} on zero-length expression [S_study_chunk] - /(?=a)?/ - - %.*s matches null string many times [S_regpiece] - $a = "ABC123" ; $a =~ /(?=a)*/' - - /%.127s/: Unrecognized escape \\%c passed through [S_regatom] - $x = '\m' ; /$x/ - - POSIX syntax [%c %c] is reserved for future extensions [S_checkposixcc] - - - Character class [:%.*s:] unknown [S_regpposixcc] - - Character class syntax [%c %c] belongs inside character classes [S_checkposixcc] - - /%.127s/: false [] range \"%*.*s\" in regexp [S_regclass] - - /%.127s/: false [] range \"%*.*s\" in regexp [S_regclassutf8] - - /%.127s/: Unrecognized escape \\%c in character class passed through" [S_regclass] - - /%.127s/: Unrecognized escape \\%c in character class passed through" [S_regclassutf8] - - False [] range \"%*.*s\" [S_regclass] - -__END__ -# regcomp.c [S_regpiece] -use warnings 'regexp' ; -my $a = "ABC123" ; -$a =~ /(?=a)*/ ; -no warnings 'regexp' ; -$a =~ /(?=a)*/ ; -EXPECT -(?=a)* matches null string many times in regex; marked by <-- HERE in m/(?=a)* <-- HERE / at - line 4. -######## -# regcomp.c [S_study_chunk] -use warnings 'regexp' ; -$_ = "" ; -/(?=a)?/; -no warnings 'regexp' ; -/(?=a)?/; -EXPECT -Quantifier unexpected on zero-length expression in regex; marked by <-- HERE in m/(?=a)? <-- HERE / at - line 4. -######## -# regcomp.c [S_regatom] -$x = '\m' ; -use warnings 'regexp' ; -$a =~ /a$x/ ; -no warnings 'regexp' ; -$a =~ /a$x/ ; -EXPECT -Unrecognized escape \m passed through in regex; marked by <-- HERE in m/a\m <-- HERE / at - line 4. -######## -# regcomp.c [S_regpposixcc S_checkposixcc] -# -use warnings 'regexp' ; -$_ = "" ; -/[:alpha:]/; -/[:zog:]/; -/[[:zog:]]/; -no warnings 'regexp' ; -/[:alpha:]/; -/[:zog:]/; -/[[:zog:]]/; -EXPECT -POSIX syntax [: :] belongs inside character classes in regex; marked by <-- HERE in m/[:alpha:] <-- HERE / at - line 5. -POSIX syntax [: :] belongs inside character classes in regex; marked by <-- HERE in m/[:zog:] <-- HERE / at - line 6. -POSIX class [:zog:] unknown in regex; marked by <-- HERE in m/[[:zog:] <-- HERE ]/ -######## -# regcomp.c [S_checkposixcc] -# -use warnings 'regexp' ; -$_ = "" ; -/[.zog.]/; -no warnings 'regexp' ; -/[.zog.]/; -EXPECT -POSIX syntax [. .] belongs inside character classes in regex; marked by <-- HERE in m/[.zog.] <-- HERE / at - line 5. -POSIX syntax [. .] is reserved for future extensions in regex; marked by <-- HERE in m/[.zog.] <-- HERE / -######## -# regcomp.c [S_checkposixcc] -# -use warnings 'regexp' ; -$_ = "" ; -/[[.zog.]]/; -no warnings 'regexp' ; -/[[.zog.]]/; -EXPECT -POSIX syntax [. .] is reserved for future extensions in regex; marked by <-- HERE in m/[[.zog.] <-- HERE ]/ -######## -# regcomp.c [S_regclass] -$_ = ""; -use warnings 'regexp' ; -/[a-b]/; -/[a-\d]/; -/[\d-b]/; -/[\s-\d]/; -/[\d-\s]/; -/[a-[:digit:]]/; -/[[:digit:]-b]/; -/[[:alpha:]-[:digit:]]/; -/[[:digit:]-[:alpha:]]/; -no warnings 'regexp' ; -/[a-b]/; -/[a-\d]/; -/[\d-b]/; -/[\s-\d]/; -/[\d-\s]/; -/[a-[:digit:]]/; -/[[:digit:]-b]/; -/[[:alpha:]-[:digit:]]/; -/[[:digit:]-[:alpha:]]/; -EXPECT -False [] range "a-\d" in regex; marked by <-- HERE in m/[a-\d <-- HERE ]/ at - line 5. -False [] range "\d-" in regex; marked by <-- HERE in m/[\d- <-- HERE b]/ at - line 6. -False [] range "\s-" in regex; marked by <-- HERE in m/[\s- <-- HERE \d]/ at - line 7. -False [] range "\d-" in regex; marked by <-- HERE in m/[\d- <-- HERE \s]/ at - line 8. -False [] range "a-[:digit:]" in regex; marked by <-- HERE in m/[a-[:digit:] <-- HERE ]/ at - line 9. -False [] range "[:digit:]-" in regex; marked by <-- HERE in m/[[:digit:]- <-- HERE b]/ at - line 10. -False [] range "[:alpha:]-" in regex; marked by <-- HERE in m/[[:alpha:]- <-- HERE [:digit:]]/ at - line 11. -False [] range "[:digit:]-" in regex; marked by <-- HERE in m/[[:digit:]- <-- HERE [:alpha:]]/ at - line 12. -######## -# regcomp.c [S_regclassutf8] -BEGIN { - if (ord("\t") == 5) { - print "SKIPPED\n# ebcdic regular expression ranges differ."; - exit 0; - } -} -use utf8; -$_ = ""; -use warnings 'regexp' ; -/[a-b]/; -/[a-\d]/; -/[\d-b]/; -/[\s-\d]/; -/[\d-\s]/; -/[a-[:digit:]]/; -/[[:digit:]-b]/; -/[[:alpha:]-[:digit:]]/; -/[[:digit:]-[:alpha:]]/; -no warnings 'regexp' ; -/[a-b]/; -/[a-\d]/; -/[\d-b]/; -/[\s-\d]/; -/[\d-\s]/; -/[a-[:digit:]]/; -/[[:digit:]-b]/; -/[[:alpha:]-[:digit:]]/; -/[[:digit:]-[:alpha:]]/; -EXPECT -False [] range "a-\d" in regex; marked by <-- HERE in m/[a-\d <-- HERE ]/ at - line 12. -False [] range "\d-" in regex; marked by <-- HERE in m/[\d- <-- HERE b]/ at - line 13. -False [] range "\s-" in regex; marked by <-- HERE in m/[\s- <-- HERE \d]/ at - line 14. -False [] range "\d-" in regex; marked by <-- HERE in m/[\d- <-- HERE \s]/ at - line 15. -False [] range "a-[:digit:]" in regex; marked by <-- HERE in m/[a-[:digit:] <-- HERE ]/ at - line 16. -False [] range "[:digit:]-" in regex; marked by <-- HERE in m/[[:digit:]- <-- HERE b]/ at - line 17. -False [] range "[:alpha:]-" in regex; marked by <-- HERE in m/[[:alpha:]- <-- HERE [:digit:]]/ at - line 18. -False [] range "[:digit:]-" in regex; marked by <-- HERE in m/[[:digit:]- <-- HERE [:alpha:]]/ at - line 19. -######## -# regcomp.c [S_regclass S_regclassutf8] -use warnings 'regexp' ; -$a =~ /[a\zb]/ ; -no warnings 'regexp' ; -$a =~ /[a\zb]/ ; -EXPECT -Unrecognized escape \z in character class passed through in regex; marked by <-- HERE in m/[a\z <-- HERE b]/ at - line 3. - -######## -# regcomp.c [S_study_chunk] -use warnings 'deprecated' ; -$a = "xx" ; -$a =~ /(?p{'x'})/ ; -no warnings ; -use warnings 'regexp' ; -$a =~ /(?p{'x'})/ ; -use warnings; -no warnings 'deprecated' ; -no warnings 'regexp' ; -$a =~ /(?p{'x'})/ ; -EXPECT -(?p{}) is deprecated - use (??{}) in regex; marked by <-- HERE in m/(?p <-- HERE {'x'})/ at - line 4. -(?p{}) is deprecated - use (??{}) in regex; marked by <-- HERE in m/(?p <-- HERE {'x'})/ at - line 7. -######## -# regcomp.c [S_reg] -use warnings 'regexp' ; -$a = qr/(?c)/; -$a = qr/(?-c)/; -$a = qr/(?g)/; -$a = qr/(?-g)/; -$a = qr/(?o)/; -$a = qr/(?-o)/; -$a = qr/(?g-o)/; -$a = qr/(?g-c)/; -$a = qr/(?o-cg)/; # (?c) means (?g) error won't be thrown -$a = qr/(?ogc)/; -no warnings 'regexp' ; -$a = qr/(?c)/; -$a = qr/(?-c)/; -$a = qr/(?g)/; -$a = qr/(?-g)/; -$a = qr/(?o)/; -$a = qr/(?-o)/; -$a = qr/(?g-o)/; -$a = qr/(?g-c)/; -$a = qr/(?o-cg)/; # (?c) means (?g) error won't be thrown -$a = qr/(?ogc)/; -#EXPECT -EXPECT -Useless (?c) - use /gc modifier in regex; marked by <-- HERE in m/(?c <-- HERE )/ at - line 3. -Useless (?-c) - don't use /gc modifier in regex; marked by <-- HERE in m/(?-c <-- HERE )/ at - line 4. -Useless (?g) - use /g modifier in regex; marked by <-- HERE in m/(?g <-- HERE )/ at - line 5. -Useless (?-g) - don't use /g modifier in regex; marked by <-- HERE in m/(?-g <-- HERE )/ at - line 6. -Useless (?o) - use /o modifier in regex; marked by <-- HERE in m/(?o <-- HERE )/ at - line 7. -Useless (?-o) - don't use /o modifier in regex; marked by <-- HERE in m/(?-o <-- HERE )/ at - line 8. -Useless (?g) - use /g modifier in regex; marked by <-- HERE in m/(?g <-- HERE -o)/ at - line 9. -Useless (?-o) - don't use /o modifier in regex; marked by <-- HERE in m/(?g-o <-- HERE )/ at - line 9. -Useless (?g) - use /g modifier in regex; marked by <-- HERE in m/(?g <-- HERE -c)/ at - line 10. -Useless (?-c) - don't use /gc modifier in regex; marked by <-- HERE in m/(?g-c <-- HERE )/ at - line 10. -Useless (?o) - use /o modifier in regex; marked by <-- HERE in m/(?o <-- HERE -cg)/ at - line 11. -Useless (?-c) - don't use /gc modifier in regex; marked by <-- HERE in m/(?o-c <-- HERE g)/ at - line 11. -Useless (?o) - use /o modifier in regex; marked by <-- HERE in m/(?o <-- HERE gc)/ at - line 12. -Useless (?g) - use /g modifier in regex; marked by <-- HERE in m/(?og <-- HERE c)/ at - line 12. -Useless (?c) - use /gc modifier in regex; marked by <-- HERE in m/(?ogc <-- HERE )/ at - line 12. diff --git a/t/pragma/warn/regexec b/t/pragma/warn/regexec deleted file mode 100644 index 73696dfb1d..0000000000 --- a/t/pragma/warn/regexec +++ /dev/null @@ -1,119 +0,0 @@ - regexec.c - - This test generates "bad free" warnings when run under - PERL_DESTRUCT_LEVEL. This file merely serves as a placeholder - for investigation. - - Complex regular subexpression recursion limit (%d) exceeded - - $_ = 'a' x (2**15+1); /^()(a\1)*$/ ; - Complex regular subexpression recursion limit (%d) exceeded - - $_ = 'a' x (2**15+1); /^()(a\1)*?$/ ; - - (The actual value substituted for %d is masked in the tests so that - REG_INFTY configuration variable value does not affect outcome.) -__END__ -# regexec.c -print("SKIPPED\n# most systems run into stacksize limits\n"),exit; -use warnings 'regexp' ; -$SIG{__WARN__} = sub{local ($m) = shift; - $m =~ s/\(\d+\)/(*MASKED*)/; - print STDERR $m}; -$_ = 'a' x (2**15+1); -/^()(a\1)*$/ ; -# -# If this test fails with a segmentation violation or similar, -# you may have to increase the default stacksize limit in your -# shell. You may need superuser privileges. -# -# Under the sh, ksh, zsh: -# $ ulimit -s -# 8192 -# $ ulimit -s 16000 -# -# Under the csh: -# % limit stacksize -# stacksize 8192 kbytes -# % limit stacksize 16000 -# -EXPECT -Complex regular subexpression recursion limit (*MASKED*) exceeded at - line 9. -######## -# regexec.c -print("SKIPPED\n# most systems run into stacksize limits\n"),exit; -no warnings 'regexp' ; -$SIG{__WARN__} = sub{local ($m) = shift; - $m =~ s/\(\d+\)/(*MASKED*)/; - print STDERR $m}; -$_ = 'a' x (2**15+1); -/^()(a\1)*$/ ; -# -# If this test fails with a segmentation violation or similar, -# you may have to increase the default stacksize limit in your -# shell. You may need superuser privileges. -# -# Under the sh, ksh, zsh: -# $ ulimit -s -# 8192 -# $ ulimit -s 16000 -# -# Under the csh: -# % limit stacksize -# stacksize 8192 kbytes -# % limit stacksize 16000 -# -EXPECT - -######## -# regexec.c -print("SKIPPED\n# most systems run into stacksize limits\n"),exit; -use warnings 'regexp' ; -$SIG{__WARN__} = sub{local ($m) = shift; - $m =~ s/\(\d+\)/(*MASKED*)/; - print STDERR $m}; -$_ = 'a' x (2**15+1); -/^()(a\1)*?$/ ; -# -# If this test fails with a segmentation violation or similar, -# you may have to increase the default stacksize limit in your -# shell. You may need superuser privileges. -# -# Under the sh, ksh, zsh: -# $ ulimit -s -# 8192 -# $ ulimit -s 16000 -# -# Under the csh: -# % limit stacksize -# stacksize 8192 kbytes -# % limit stacksize 16000 -# -EXPECT -Complex regular subexpression recursion limit (*MASKED*) exceeded at - line 9. -######## -# regexec.c -print("SKIPPED\n# most systems run into stacksize limits\n"),exit; -no warnings 'regexp' ; -$SIG{__WARN__} = sub{local ($m) = shift; - $m =~ s/\(\d+\)/(*MASKED*)/; - print STDERR $m}; -$_ = 'a' x (2**15+1); -/^()(a\1)*?$/ ; -# -# If this test fails with a segmentation violation or similar, -# you may have to increase the default stacksize limit in your -# shell. You may need superuser privileges. -# -# Under the sh, ksh, zsh: -# $ ulimit -s -# 8192 -# $ ulimit -s 16000 -# -# Under the csh: -# % limit stacksize -# stacksize 8192 kbytes -# % limit stacksize 16000 -# -EXPECT - diff --git a/t/pragma/warn/run b/t/pragma/warn/run deleted file mode 100644 index 7a4be20e70..0000000000 --- a/t/pragma/warn/run +++ /dev/null @@ -1,8 +0,0 @@ - run.c - - - Mandatory Warnings ALL TODO - ------------------ - NULL OP IN RUN - -__END__ diff --git a/t/pragma/warn/sv b/t/pragma/warn/sv deleted file mode 100644 index b3929e2210..0000000000 --- a/t/pragma/warn/sv +++ /dev/null @@ -1,320 +0,0 @@ - sv.c - - warn(warn_uninit); - - warn(warn_uninit); - - warn(warn_uninit); - - warn(warn_uninit); - - not_a_number(sv); - - not_a_number(sv); - - warn(warn_uninit); - - not_a_number(sv); - - warn(warn_uninit); - - not_a_number(sv); - - not_a_number(sv); - - warn(warn_uninit); - - warn(warn_uninit); - - Subroutine %s redefined - - Invalid conversion in %s: - - Undefined value assigned to typeglob - - Possible Y2K bug: %d format string following '19' - - Reference is already weak [Perl_sv_rvweaken] <<TODO - - Mandatory Warnings - ------------------ - Malformed UTF-8 character [sv_pos_b2u] (not tested: difficult to produce - with perl now) - - Mandatory Warnings TODO - ------------------ - Attempt to free non-arena SV: 0x%lx [del_sv] - Reference miscount in sv_replace() [sv_replace] - Attempt to free unreferenced scalar [sv_free] - Attempt to free temp prematurely: SV 0x%lx [sv_free] - semi-panic: attempt to dup freed string [newSVsv] - - -__END__ -# sv.c -use integer ; -use warnings 'uninitialized' ; -$x = 1 + $a[0] ; # a -no warnings 'uninitialized' ; -$x = 1 + $b[0] ; # a -EXPECT -Use of uninitialized value in integer addition (+) at - line 4. -######## -# sv.c (sv_2iv) -package fred ; -sub TIESCALAR { my $x ; bless \$x} -sub FETCH { return undef } -sub STORE { return 1 } -package main ; -tie $A, 'fred' ; -use integer ; -use warnings 'uninitialized' ; -$A *= 2 ; -no warnings 'uninitialized' ; -$A *= 2 ; -EXPECT -Use of uninitialized value in integer multiplication (*) at - line 10. -######## -# sv.c -use integer ; -use warnings 'uninitialized' ; -my $x *= 2 ; #b -no warnings 'uninitialized' ; -my $y *= 2 ; #b -EXPECT -Use of uninitialized value in integer multiplication (*) at - line 4. -######## -# sv.c (sv_2uv) -package fred ; -sub TIESCALAR { my $x ; bless \$x} -sub FETCH { return undef } -sub STORE { return 1 } -package main ; -tie $A, 'fred' ; -use warnings 'uninitialized' ; -$B = 0 ; -$B |= $A ; -no warnings 'uninitialized' ; -$B = 0 ; -$B |= $A ; -EXPECT -Use of uninitialized value in bitwise or (|) at - line 10. -######## -# sv.c -use warnings 'uninitialized' ; -my $Y = 1 ; -my $x = 1 | $a[$Y] ; -no warnings 'uninitialized' ; -my $Y = 1 ; -$x = 1 | $b[$Y] ; -EXPECT -Use of uninitialized value in bitwise or (|) at - line 4. -######## -# sv.c -use warnings 'uninitialized' ; -my $x *= 1 ; # d -no warnings 'uninitialized' ; -my $y *= 1 ; # d -EXPECT -Use of uninitialized value in multiplication (*) at - line 3. -######## -# sv.c -use warnings 'uninitialized' ; -$x = 1 + $a[0] ; # e -no warnings 'uninitialized' ; -$x = 1 + $b[0] ; # e -EXPECT -Use of uninitialized value in addition (+) at - line 3. -######## -# sv.c (sv_2nv) -package fred ; -sub TIESCALAR { my $x ; bless \$x} -sub FETCH { return undef } -sub STORE { return 1 } -package main ; -tie $A, 'fred' ; -use warnings 'uninitialized' ; -$A *= 2 ; -no warnings 'uninitialized' ; -$A *= 2 ; -EXPECT -Use of uninitialized value in multiplication (*) at - line 9. -######## -# sv.c -use warnings 'uninitialized' ; -$x = $y + 1 ; # f -no warnings 'uninitialized' ; -$x = $z + 1 ; # f -EXPECT -Use of uninitialized value in addition (+) at - line 3. -######## -# sv.c -use warnings 'uninitialized' ; -$x = chop undef ; # g -no warnings 'uninitialized' ; -$x = chop undef ; # g -EXPECT -Modification of a read-only value attempted at - line 3. -######## -# sv.c -use warnings 'uninitialized' ; -$x = chop $y ; # h -no warnings 'uninitialized' ; -$x = chop $z ; # h -EXPECT -Use of uninitialized value in scalar chop at - line 3. -######## -# sv.c (sv_2pv) -package fred ; -sub TIESCALAR { my $x ; bless \$x} -sub FETCH { return undef } -sub STORE { return 1 } -package main ; -tie $A, 'fred' ; -use warnings 'uninitialized' ; -$B = "" ; -$B .= $A ; -no warnings 'uninitialized' ; -$C = "" ; -$C .= $A ; -EXPECT -Use of uninitialized value in concatenation (.) or string at - line 10. -######## -# sv.c -use warnings 'numeric' ; -sub TIESCALAR{bless[]} ; -sub FETCH {"def"} ; -tie $a,"main" ; -my $b = 1 + $a; -no warnings 'numeric' ; -my $c = 1 + $a; -EXPECT -Argument "def" isn't numeric in addition (+) at - line 6. -######## -# sv.c -use warnings 'numeric' ; -my $x = 1 + "def" ; -no warnings 'numeric' ; -my $z = 1 + "def" ; -EXPECT -Argument "def" isn't numeric in addition (+) at - line 3. -######## -# sv.c -use warnings 'numeric' ; -my $a = "def" ; -my $x = 1 + $a ; -no warnings 'numeric' ; -my $y = 1 + $a ; -EXPECT -Argument "def" isn't numeric in addition (+) at - line 4. -######## -# sv.c -use warnings 'numeric' ; use integer ; -my $a = "def" ; -my $x = 1 + $a ; -no warnings 'numeric' ; -my $z = 1 + $a ; -EXPECT -Argument "def" isn't numeric in integer addition (+) at - line 4. -######## -# sv.c -use warnings 'numeric' ; -my $x = 1 & "def" ; -no warnings 'numeric' ; -my $z = 1 & "def" ; -EXPECT -Argument "def" isn't numeric in bitwise and (&) at - line 3. -######## -# sv.c -use warnings 'numeric' ; -my $x = pack i => "def" ; -no warnings 'numeric' ; -my $z = pack i => "def" ; -EXPECT -Argument "def" isn't numeric in pack at - line 3. -######## -# sv.c -use warnings 'numeric' ; -my $a = "d\0f" ; -my $x = 1 + $a ; -no warnings 'numeric' ; -my $z = 1 + $a ; -EXPECT -Argument "d\0f" isn't numeric in addition (+) at - line 4. -######## -# sv.c -use warnings 'redefine' ; -sub fred {} -sub joe {} -*fred = \&joe ; -no warnings 'redefine' ; -sub jim {} -*jim = \&joe ; -EXPECT -Subroutine fred redefined at - line 5. -######## -# sv.c -use warnings 'printf' ; -open F, ">".($^O eq 'VMS'? 'NL:' : '/dev/null') ; -printf F "%z\n" ; -my $a = sprintf "%z" ; -printf F "%" ; -$a = sprintf "%" ; -printf F "%\x02" ; -$a = sprintf "%\x02" ; -no warnings 'printf' ; -printf F "%z\n" ; -$a = sprintf "%z" ; -printf F "%" ; -$a = sprintf "%" ; -printf F "%\x02" ; -$a = sprintf "%\x02" ; -EXPECT -Invalid conversion in sprintf: "%z" at - line 5. -Invalid conversion in sprintf: end of string at - line 7. -Invalid conversion in sprintf: "%\002" at - line 9. -Invalid conversion in printf: "%z" at - line 4. -Invalid conversion in printf: end of string at - line 6. -Invalid conversion in printf: "%\002" at - line 8. -######## -# sv.c -use warnings 'misc' ; -*a = undef ; -no warnings 'misc' ; -*b = undef ; -EXPECT -Undefined value assigned to typeglob at - line 3. -######## -# sv.c -use warnings 'y2k'; -use Config; -BEGIN { - unless ($Config{ccflags} =~ /Y2KWARN/) { - print "SKIPPED\n# perl not built with -DPERL_Y2KWARN"; - exit 0; - } - $|=1; -} -my $x; -my $yy = 78; -$x = printf "19%02d\n", $yy; -$x = sprintf "#19%02d\n", $yy; -$x = printf " 19%02d\n", 78; -$x = sprintf "19%02d\n", 78; -$x = printf "319%02d\n", $yy; -$x = sprintf "319%02d\n", $yy; -no warnings 'y2k'; -$x = printf "19%02d\n", $yy; -$x = sprintf "19%02d\n", $yy; -$x = printf "19%02d\n", 78; -$x = sprintf "19%02d\n", 78; -EXPECT -Possible Y2K bug: %d format string following '19' at - line 16. -Possible Y2K bug: %d format string following '19' at - line 13. -1978 -Possible Y2K bug: %d format string following '19' at - line 14. -Possible Y2K bug: %d format string following '19' at - line 15. - 1978 -31978 -1978 -1978 diff --git a/t/pragma/warn/taint b/t/pragma/warn/taint deleted file mode 100644 index fd6deed60f..0000000000 --- a/t/pragma/warn/taint +++ /dev/null @@ -1,49 +0,0 @@ - taint.c AOK - - Insecure %s%s while running with -T switch - -__END__ --T ---FILE-- abc -def ---FILE-- -# taint.c -open(FH, "<abc") ; -$a = <FH> ; -close FH ; -chdir $a ; -print "xxx\n" ; -EXPECT -Insecure dependency in chdir while running with -T switch at - line 5. -######## --TU ---FILE-- abc -def ---FILE-- -# taint.c -open(FH, "<abc") ; -$a = <FH> ; -close FH ; -chdir $a ; -print "xxx\n" ; -EXPECT -xxx -######## --TU ---FILE-- abc -def ---FILE-- -# taint.c -open(FH, "<abc") ; -$a = <FH> ; -close FH ; -use warnings 'taint' ; -chdir $a ; -print "xxx\n" ; -no warnings 'taint' ; -chdir $a ; -print "yyy\n" ; -EXPECT -Insecure dependency in chdir while running with -T switch at - line 6. -xxx -yyy diff --git a/t/pragma/warn/toke b/t/pragma/warn/toke deleted file mode 100644 index 242b0059fb..0000000000 --- a/t/pragma/warn/toke +++ /dev/null @@ -1,732 +0,0 @@ -toke.c AOK - - we seem to have lost a few ambiguous warnings!! - - - $a = <<; - Use of comma-less variable list is deprecated - (called 3 times via depcom) - - \1 better written as $1 - use warnings 'syntax' ; - s/(abc)/\1/; - - warn(warn_nosemi) - Semicolon seems to be missing - $a = 1 - &time ; - - - Reversed %c= operator - my $a =+ 2 ; - $a =- 2 ; - $a =* 2 ; - $a =% 2 ; - $a =& 2 ; - $a =. 2 ; - $a =^ 2 ; - $a =| 2 ; - $a =< 2 ; - $a =/ 2 ; - - Multidimensional syntax %.*s not supported - my $a = $a[1,2] ; - - You need to quote \"%s\"" - sub fred {} ; $SIG{TERM} = fred; - - Scalar value %.*s better written as $%.*s" - @a[3] = 2; - @a{3} = 2; - - Can't use \\%c to mean $%c in expression - $_ = "ab" ; s/(ab)/\1/e; - - Unquoted string "abc" may clash with future reserved word at - line 3. - warn(warn_reserved - $a = abc; - - chmod() mode argument is missing initial 0 - chmod 3; - - Possible attempt to separate words with commas - @a = qw(a, b, c) ; - - Possible attempt to put comments in qw() list - @a = qw(a b # c) ; - - umask: argument is missing initial 0 - umask 3; - - %s (...) interpreted as function - print ("") - printf ("") - sort ("") - - Ambiguous use of %c{%s%s} resolved to %c%s%s - $a = ${time[2]} - $a = ${time{2}} - - - Ambiguous use of %c{%s} resolved to %c%s - $a = ${time} - sub fred {} $a = ${fred} - - Misplaced _ in number - $a = 1_2; - $a = 1_2345_6; - - Bareword \"%s\" refers to nonexistent package - $a = FRED:: ; - - Ambiguous call resolved as CORE::%s(), qualify as such or use & - sub time {} - my $a = time() - - Unrecognized escape \\%c passed through - $a = "\m" ; - - %s number > %s non-portable - my $a = 0b011111111111111111111111111111110 ; - $a = 0b011111111111111111111111111111111 ; - $a = 0b111111111111111111111111111111111 ; - $a = 0x0fffffffe ; - $a = 0x0ffffffff ; - $a = 0x1ffffffff ; - $a = 0037777777776 ; - $a = 0037777777777 ; - $a = 0047777777777 ; - - Integer overflow in binary number - my $a = 0b011111111111111111111111111111110 ; - $a = 0b011111111111111111111111111111111 ; - $a = 0b111111111111111111111111111111111 ; - $a = 0x0fffffffe ; - $a = 0x0ffffffff ; - $a = 0x1ffffffff ; - $a = 0037777777776 ; - $a = 0037777777777 ; - $a = 0047777777777 ; - - Mandatory Warnings - ------------------ - Use of "%s" without parentheses is ambiguous [check_uni] - rand + 4 - - Ambiguous use of -%s resolved as -&%s() [yylex] - sub fred {} ; - fred ; - - Precedence problem: open %.*s should be open(%.*s) [yylex] - open FOO || die; - - Operator or semicolon missing before %c%s [yylex] - Ambiguous use of %c resolved as operator %c - *foo *foo - -__END__ -# toke.c -use warnings 'deprecated' ; -format STDOUT = -@<<< @||| @>>> @>>> -$a $b "abc" 'def' -. -no warnings 'deprecated' ; -format STDOUT = -@<<< @||| @>>> @>>> -$a $b "abc" 'def' -. -EXPECT -Use of comma-less variable list is deprecated at - line 5. -Use of comma-less variable list is deprecated at - line 5. -Use of comma-less variable list is deprecated at - line 5. -######## -# toke.c -use warnings 'deprecated' ; -$a = <<; - -no warnings 'deprecated' ; -$a = <<; - -EXPECT -Use of bare << to mean <<"" is deprecated at - line 3. -######## -# toke.c -use warnings 'syntax' ; -s/(abc)/\1/; -no warnings 'syntax' ; -s/(abc)/\1/; -EXPECT -\1 better written as $1 at - line 3. -######## -# toke.c -use warnings 'semicolon' ; -$a = 1 -&time ; -no warnings 'semicolon' ; -$a = 1 -&time ; -EXPECT -Semicolon seems to be missing at - line 3. -######## -# toke.c -use warnings 'syntax' ; -my $a =+ 2 ; -$a =- 2 ; -$a =* 2 ; -$a =% 2 ; -$a =& 2 ; -$a =. 2 ; -$a =^ 2 ; -$a =| 2 ; -$a =< 2 ; -$a =/ 2 ; -EXPECT -Reversed += operator at - line 3. -Reversed -= operator at - line 4. -Reversed *= operator at - line 5. -Reversed %= operator at - line 6. -Reversed &= operator at - line 7. -Reversed .= operator at - line 8. -Reversed ^= operator at - line 9. -Reversed |= operator at - line 10. -Reversed <= operator at - line 11. -syntax error at - line 8, near "=." -syntax error at - line 9, near "=^" -syntax error at - line 10, near "=|" -Unterminated <> operator at - line 11. -######## -# toke.c -no warnings 'syntax' ; -my $a =+ 2 ; -$a =- 2 ; -$a =* 2 ; -$a =% 2 ; -$a =& 2 ; -$a =. 2 ; -$a =^ 2 ; -$a =| 2 ; -$a =< 2 ; -$a =/ 2 ; -EXPECT -syntax error at - line 8, near "=." -syntax error at - line 9, near "=^" -syntax error at - line 10, near "=|" -Unterminated <> operator at - line 11. -######## -# toke.c -use warnings 'syntax' ; -my $a = $a[1,2] ; -no warnings 'syntax' ; -my $a = $a[1,2] ; -EXPECT -Multidimensional syntax $a[1,2] not supported at - line 3. -######## -# toke.c -use warnings 'syntax' ; -sub fred {} ; $SIG{TERM} = fred; -no warnings 'syntax' ; -$SIG{TERM} = fred; -EXPECT -You need to quote "fred" at - line 3. -######## -# toke.c -use warnings 'syntax' ; -@a[3] = 2; -@a{3} = 2; -no warnings 'syntax' ; -@a[3] = 2; -@a{3} = 2; -EXPECT -Scalar value @a[3] better written as $a[3] at - line 3. -Scalar value @a{3} better written as $a{3} at - line 4. -######## -# toke.c -use warnings 'syntax' ; -$_ = "ab" ; -s/(ab)/\1/e; -no warnings 'syntax' ; -$_ = "ab" ; -s/(ab)/\1/e; -EXPECT -Can't use \1 to mean $1 in expression at - line 4. -######## -# toke.c -use warnings 'reserved' ; -$a = abc; -$a = { def - -=> 1 }; -no warnings 'reserved' ; -$a = abc; -EXPECT -Unquoted string "abc" may clash with future reserved word at - line 3. -######## -# toke.c -use warnings 'chmod' ; -chmod 3; -no warnings 'chmod' ; -chmod 3; -EXPECT -chmod() mode argument is missing initial 0 at - line 3. -######## -# toke.c -use warnings 'qw' ; -@a = qw(a, b, c) ; -no warnings 'qw' ; -@a = qw(a, b, c) ; -EXPECT -Possible attempt to separate words with commas at - line 3. -######## -# toke.c -use warnings 'qw' ; -@a = qw(a b #) ; -no warnings 'qw' ; -@a = qw(a b #) ; -EXPECT -Possible attempt to put comments in qw() list at - line 3. -######## -# toke.c -use warnings 'umask' ; -umask 3; -no warnings 'umask' ; -umask 3; -EXPECT -umask: argument is missing initial 0 at - line 3. -######## -# toke.c -use warnings 'syntax' ; -print ("") -EXPECT -print (...) interpreted as function at - line 3. -######## -# toke.c -no warnings 'syntax' ; -print ("") -EXPECT - -######## -# toke.c -use warnings 'syntax' ; -printf ("") -EXPECT -printf (...) interpreted as function at - line 3. -######## -# toke.c -no warnings 'syntax' ; -printf ("") -EXPECT - -######## -# toke.c -use warnings 'syntax' ; -sort ("") -EXPECT -sort (...) interpreted as function at - line 3. -######## -# toke.c -no warnings 'syntax' ; -sort ("") -EXPECT - -######## -# toke.c -use warnings 'ambiguous' ; -$a = ${time[2]}; -no warnings 'ambiguous' ; -$a = ${time[2]}; -EXPECT -Ambiguous use of ${time[...]} resolved to $time[...] at - line 3. -######## -# toke.c -use warnings 'ambiguous' ; -$a = ${time{2}}; -EXPECT -Ambiguous use of ${time{...}} resolved to $time{...} at - line 3. -######## -# toke.c -no warnings 'ambiguous' ; -$a = ${time{2}}; -EXPECT - -######## -# toke.c -use warnings 'ambiguous' ; -$a = ${time} ; -no warnings 'ambiguous' ; -$a = ${time} ; -EXPECT -Ambiguous use of ${time} resolved to $time at - line 3. -######## -# toke.c -use warnings 'ambiguous' ; -sub fred {} -$a = ${fred} ; -no warnings 'ambiguous' ; -$a = ${fred} ; -EXPECT -Ambiguous use of ${fred} resolved to $fred at - line 4. -######## -# toke.c -use warnings 'syntax' ; -$a = _123; print "$a\n"; #( 3 string) -$a = 1_23; print "$a\n"; -$a = 12_3; print "$a\n"; -$a = 123_; print "$a\n"; # 6 -$a = _+123; print "$a\n"; # 7 string) -$a = +_123; print "$a\n"; #( 8 string) -$a = +1_23; print "$a\n"; -$a = +12_3; print "$a\n"; -$a = +123_; print "$a\n"; # 11 -$a = _-123; print "$a\n"; #(12 string) -$a = -_123; print "$a\n"; #(13 string) -$a = -1_23; print "$a\n"; -$a = -12_3; print "$a\n"; -$a = -123_; print "$a\n"; # 16 -$a = 123._456; print "$a\n"; # 17 -$a = 123.4_56; print "$a\n"; -$a = 123.45_6; print "$a\n"; -$a = 123.456_; print "$a\n"; # 20 -$a = +123._456; print "$a\n"; # 21 -$a = +123.4_56; print "$a\n"; -$a = +123.45_6; print "$a\n"; -$a = +123.456_; print "$a\n"; # 24 -$a = -123._456; print "$a\n"; # 25 -$a = -123.4_56; print "$a\n"; -$a = -123.45_6; print "$a\n"; -$a = -123.456_; print "$a\n"; # 28 -$a = 123.456E_12; print "$a\n"; # 29 -$a = 123.456E1_2; print "$a\n"; -$a = 123.456E12_; print "$a\n"; # 31 -$a = 123.456E_+12; print "$a\n"; # 32 -$a = 123.456E+_12; print "$a\n"; # 33 -$a = 123.456E+1_2; print "$a\n"; -$a = 123.456E+12_; print "$a\n"; # 35 -$a = 123.456E_-12; print "$a\n"; # 36 -$a = 123.456E-_12; print "$a\n"; # 37 -$a = 123.456E-1_2; print "$a\n"; -$a = 123.456E-12_; print "$a\n"; # 39 -$a = 1__23; print "$a\n"; # 40 -$a = 12.3__4; print "$a\n"; # 41 -$a = 12.34e1__2; print "$a\n"; # 42 -no warnings 'syntax' ; -$a = _123; print "$a\n"; -$a = 1_23; print "$a\n"; -$a = 12_3; print "$a\n"; -$a = 123_; print "$a\n"; -$a = _+123; print "$a\n"; -$a = +_123; print "$a\n"; -$a = +1_23; print "$a\n"; -$a = +12_3; print "$a\n"; -$a = +123_; print "$a\n"; -$a = _-123; print "$a\n"; -$a = -_123; print "$a\n"; -$a = -1_23; print "$a\n"; -$a = -12_3; print "$a\n"; -$a = -123_; print "$a\n"; -$a = 123._456; print "$a\n"; -$a = 123.4_56; print "$a\n"; -$a = 123.45_6; print "$a\n"; -$a = 123.456_; print "$a\n"; -$a = +123._456; print "$a\n"; -$a = +123.4_56; print "$a\n"; -$a = +123.45_6; print "$a\n"; -$a = +123.456_; print "$a\n"; -$a = -123._456; print "$a\n"; -$a = -123.4_56; print "$a\n"; -$a = -123.45_6; print "$a\n"; -$a = -123.456_; print "$a\n"; -$a = 123.456E_12; print "$a\n"; -$a = 123.456E1_2; print "$a\n"; -$a = 123.456E12_; print "$a\n"; -$a = 123.456E_+12; print "$a\n"; -$a = 123.456E+_12; print "$a\n"; -$a = 123.456E+1_2; print "$a\n"; -$a = 123.456E+12_; print "$a\n"; -$a = 123.456E_-12; print "$a\n"; -$a = 123.456E-_12; print "$a\n"; -$a = 123.456E-1_2; print "$a\n"; -$a = 123.456E-12_; print "$a\n"; -$a = 1__23; print "$a\n"; -$a = 12.3__4; print "$a\n"; -$a = 12.34e1__2; print "$a\n"; -EXPECT -OPTIONS regex -Misplaced _ in number at - line 6. -Misplaced _ in number at - line 11. -Misplaced _ in number at - line 16. -Misplaced _ in number at - line 17. -Misplaced _ in number at - line 20. -Misplaced _ in number at - line 21. -Misplaced _ in number at - line 24. -Misplaced _ in number at - line 25. -Misplaced _ in number at - line 28. -Misplaced _ in number at - line 29. -Misplaced _ in number at - line 31. -Misplaced _ in number at - line 32. -Misplaced _ in number at - line 33. -Misplaced _ in number at - line 35. -Misplaced _ in number at - line 36. -Misplaced _ in number at - line 37. -Misplaced _ in number at - line 39. -Misplaced _ in number at - line 40. -Misplaced _ in number at - line 41. -Misplaced _ in number at - line 42. -_123 -123 -123 -123 -123 -_123 -123 -123 -123 --123 --_123 --123 --123 --123 -123.456 -123.456 -123.456 -123.456 -123.456 -123.456 -123.456 -123.456 --123.456 --123.456 --123.456 --123.456 -123456000000000 -123456000000000 -123456000000000 -123456000000000 -123456000000000 -123456000000000 -123456000000000 -1.23456e-0?10 -1.23456e-0?10 -1.23456e-0?10 -1.23456e-0?10 -123 -12.34 -12340000000000 -_123 -123 -123 -123 -123 -_123 -123 -123 -123 --123 --_123 --123 --123 --123 -123.456 -123.456 -123.456 -123.456 -123.456 -123.456 -123.456 -123.456 --123.456 --123.456 --123.456 --123.456 -123456000000000 -123456000000000 -123456000000000 -123456000000000 -123456000000000 -123456000000000 -123456000000000 -1.23456e-0?10 -1.23456e-0?10 -1.23456e-0?10 -1.23456e-0?10 -123 -12.34 -12340000000000 -######## -# toke.c -use warnings 'bareword' ; -#line 25 "bar" -$a = FRED:: ; -no warnings 'bareword' ; -#line 25 "bar" -$a = FRED:: ; -EXPECT -Bareword "FRED::" refers to nonexistent package at bar line 25. -######## -# toke.c -use warnings 'ambiguous' ; -sub time {} -my $a = time() ; -no warnings 'ambiguous' ; -my $b = time() ; -EXPECT -Ambiguous call resolved as CORE::time(), qualify as such or use & at - line 4. -######## -# toke.c -use warnings ; -eval <<'EOE'; -# line 30 "foo" -warn "yelp"; -{ - $_ = " \x{123} " ; -} -EOE -EXPECT -yelp at foo line 30. -######## -# toke.c -my $a = rand + 4 ; -EXPECT -Warning: Use of "rand" without parens is ambiguous at - line 2. -######## -# toke.c -$^W = 0 ; -my $a = rand + 4 ; -{ - no warnings 'ambiguous' ; - $a = rand + 4 ; - use warnings 'ambiguous' ; - $a = rand + 4 ; -} -$a = rand + 4 ; -EXPECT -Warning: Use of "rand" without parens is ambiguous at - line 3. -Warning: Use of "rand" without parens is ambiguous at - line 8. -Warning: Use of "rand" without parens is ambiguous at - line 10. -######## -# toke.c -sub fred {}; --fred ; -EXPECT -Ambiguous use of -fred resolved as -&fred() at - line 3. -######## -# toke.c -$^W = 0 ; -sub fred {} ; --fred ; -{ - no warnings 'ambiguous' ; - -fred ; - use warnings 'ambiguous' ; - -fred ; -} --fred ; -EXPECT -Ambiguous use of -fred resolved as -&fred() at - line 4. -Ambiguous use of -fred resolved as -&fred() at - line 9. -Ambiguous use of -fred resolved as -&fred() at - line 11. -######## -# toke.c -open FOO || time; -EXPECT -Precedence problem: open FOO should be open(FOO) at - line 2. -######## -# toke.c -$^W = 0 ; -open FOO || time; -{ - no warnings 'precedence' ; - open FOO || time; - use warnings 'precedence' ; - open FOO || time; -} -open FOO || time; -EXPECT -Precedence problem: open FOO should be open(FOO) at - line 3. -Precedence problem: open FOO should be open(FOO) at - line 8. -Precedence problem: open FOO should be open(FOO) at - line 10. -######## -# toke.c -$^W = 0 ; -*foo *foo ; -{ - no warnings 'ambiguous' ; - *foo *foo ; - use warnings 'ambiguous' ; - *foo *foo ; -} -*foo *foo ; -EXPECT -Operator or semicolon missing before *foo at - line 3. -Ambiguous use of * resolved as operator * at - line 3. -Operator or semicolon missing before *foo at - line 8. -Ambiguous use of * resolved as operator * at - line 8. -Operator or semicolon missing before *foo at - line 10. -Ambiguous use of * resolved as operator * at - line 10. -######## -# toke.c -use warnings 'misc' ; -my $a = "\m" ; -no warnings 'misc' ; -$a = "\m" ; -EXPECT -Unrecognized escape \m passed through at - line 3. -######## -# toke.c -use warnings 'portable' ; -my $a = 0b011111111111111111111111111111110 ; - $a = 0b011111111111111111111111111111111 ; - $a = 0b111111111111111111111111111111111 ; - $a = 0x0fffffffe ; - $a = 0x0ffffffff ; - $a = 0x1ffffffff ; - $a = 0037777777776 ; - $a = 0037777777777 ; - $a = 0047777777777 ; -no warnings 'portable' ; - $a = 0b011111111111111111111111111111110 ; - $a = 0b011111111111111111111111111111111 ; - $a = 0b111111111111111111111111111111111 ; - $a = 0x0fffffffe ; - $a = 0x0ffffffff ; - $a = 0x1ffffffff ; - $a = 0037777777776 ; - $a = 0037777777777 ; - $a = 0047777777777 ; -EXPECT -Binary number > 0b11111111111111111111111111111111 non-portable at - line 5. -Hexadecimal number > 0xffffffff non-portable at - line 8. -Octal number > 037777777777 non-portable at - line 11. -######## -# toke.c -use warnings 'overflow' ; -my $a = 0b011111111111111111111111111111110 ; - $a = 0b011111111111111111111111111111111 ; - $a = 0b10000000000000000000000000000000000000000000000000000000000000000 ; - $a = 0x0fffffffe ; - $a = 0x0ffffffff ; - $a = 0x10000000000000000 ; - $a = 0037777777776 ; - $a = 0037777777777 ; - $a = 002000000000000000000000; -no warnings 'overflow' ; - $a = 0b011111111111111111111111111111110 ; - $a = 0b011111111111111111111111111111111 ; - $a = 0b10000000000000000000000000000000000000000000000000000000000000000 ; - $a = 0x0fffffffe ; - $a = 0x0ffffffff ; - $a = 0x10000000000000000 ; - $a = 0037777777776 ; - $a = 0037777777777 ; - $a = 002000000000000000000000; -EXPECT -Integer overflow in binary number at - line 5. -Integer overflow in hexadecimal number at - line 8. -Integer overflow in octal number at - line 11. -######## -# toke.c -use warnings 'ambiguous'; -"@mjd_previously_unused_array"; -no warnings 'ambiguous'; -"@mjd_previously_unused_array"; -EXPECT -Possible unintended interpolation of @mjd_previously_unused_array in string at - line 3. diff --git a/t/pragma/warn/universal b/t/pragma/warn/universal deleted file mode 100644 index d9b1883532..0000000000 --- a/t/pragma/warn/universal +++ /dev/null @@ -1,14 +0,0 @@ - universal.c AOK - - Can't locate package %s for @%s::ISA [S_isa_lookup] - - - -__END__ -# universal.c [S_isa_lookup] -use warnings 'misc' ; -@ISA = qw(Joe) ; -my $a = bless [] ; -UNIVERSAL::isa $a, Jim ; -EXPECT -Can't locate package Joe for @main::ISA at - line 5. diff --git a/t/pragma/warn/utf8 b/t/pragma/warn/utf8 deleted file mode 100644 index 9a7dbafdee..0000000000 --- a/t/pragma/warn/utf8 +++ /dev/null @@ -1,35 +0,0 @@ - - utf8.c AOK - - [utf8_to_uv] - Malformed UTF-8 character - my $a = ord "\x80" ; - - Malformed UTF-8 character - my $a = ord "\xf080" ; - <<<<<< this warning can't be easily triggered from perl anymore - - [utf16_to_utf8] - Malformed UTF-16 surrogate - <<<<<< Add a test when somethig actually calls utf16_to_utf8 - -__END__ -# utf8.c [utf8_to_uv] -W -BEGIN { - if (ord('A') == 193) { - print "SKIPPED\n# ebcdic platforms do not generate Malformed UTF-8 warnings."; - exit 0; - } -} -use utf8 ; -my $a = "snstorm" ; -{ - no warnings 'utf8' ; - my $a = "snstorm"; - use warnings 'utf8' ; - my $a = "snstorm"; -} -EXPECT -Malformed UTF-8 character (unexpected non-continuation byte 0x73 after start byte 0xf8) at - line 9. -Malformed UTF-8 character (unexpected non-continuation byte 0x73 after start byte 0xf8) at - line 14. -######## diff --git a/t/pragma/warn/util b/t/pragma/warn/util deleted file mode 100644 index e82d6a6617..0000000000 --- a/t/pragma/warn/util +++ /dev/null @@ -1,108 +0,0 @@ - util.c AOK - - Illegal octal digit ignored - my $a = oct "029" ; - - Illegal hex digit ignored - my $a = hex "0xv9" ; - - Illegal binary digit ignored - my $a = oct "0b9" ; - - Integer overflow in binary number - my $a = oct "0b111111111111111111111111111111111111111111" ; - Binary number > 0b11111111111111111111111111111111 non-portable - $a = oct "0b111111111111111111111111111111111" ; - Integer overflow in octal number - my $a = oct "077777777777777777777777777777" ; - Octal number > 037777777777 non-portable - $a = oct "0047777777777" ; - Integer overflow in hexadecimal number - my $a = hex "0xffffffffffffffffffff" ; - Hexadecimal number > 0xffffffff non-portable - $a = hex "0x1ffffffff" ; - -__END__ -# util.c -use warnings 'digit' ; -my $a = oct "029" ; -no warnings 'digit' ; -$a = oct "029" ; -EXPECT -Illegal octal digit '9' ignored at - line 3. -######## -# util.c -use warnings 'digit' ; -my $a = hex "0xv9" ; -no warnings 'digit' ; -$a = hex "0xv9" ; -EXPECT -Illegal hexadecimal digit 'v' ignored at - line 3. -######## -# util.c -use warnings 'digit' ; -my $a = oct "0b9" ; -no warnings 'digit' ; -$a = oct "0b9" ; -EXPECT -Illegal binary digit '9' ignored at - line 3. -######## -# util.c -use warnings 'overflow' ; -my $a = oct "0b11111111111111111111111111111111111111111111111111111111111111111"; -no warnings 'overflow' ; -$a = oct "0b11111111111111111111111111111111111111111111111111111111111111111"; -EXPECT -Integer overflow in binary number at - line 3. -######## -# util.c -use warnings 'overflow' ; -my $a = hex "0xffffffffffffffffffff" ; -no warnings 'overflow' ; -$a = hex "0xffffffffffffffffffff" ; -EXPECT -Integer overflow in hexadecimal number at - line 3. -######## -# util.c -use warnings 'overflow' ; -my $a = oct "077777777777777777777777777777" ; -no warnings 'overflow' ; -$a = oct "077777777777777777777777777777" ; -EXPECT -Integer overflow in octal number at - line 3. -######## -# util.c -use warnings 'portable' ; -my $a = oct "0b011111111111111111111111111111110" ; - $a = oct "0b011111111111111111111111111111111" ; - $a = oct "0b111111111111111111111111111111111" ; -no warnings 'portable' ; - $a = oct "0b011111111111111111111111111111110" ; - $a = oct "0b011111111111111111111111111111111" ; - $a = oct "0b111111111111111111111111111111111" ; -EXPECT -Binary number > 0b11111111111111111111111111111111 non-portable at - line 5. -######## -# util.c -use warnings 'portable' ; -my $a = hex "0x0fffffffe" ; - $a = hex "0x0ffffffff" ; - $a = hex "0x1ffffffff" ; -no warnings 'portable' ; - $a = hex "0x0fffffffe" ; - $a = hex "0x0ffffffff" ; - $a = hex "0x1ffffffff" ; -EXPECT -Hexadecimal number > 0xffffffff non-portable at - line 5. -######## -# util.c -use warnings 'portable' ; -my $a = oct "0037777777776" ; - $a = oct "0037777777777" ; - $a = oct "0047777777777" ; -no warnings 'portable' ; - $a = oct "0037777777776" ; - $a = oct "0037777777777" ; - $a = oct "0047777777777" ; -EXPECT -Octal number > 037777777777 non-portable at - line 5. diff --git a/t/pragma/warnings.t b/t/pragma/warnings.t deleted file mode 100644 index 09b41fbd64..0000000000 --- a/t/pragma/warnings.t +++ /dev/null @@ -1,131 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - $ENV{PERL5LIB} = '../lib'; - require Config; import Config; -} - -$| = 1; - -my $Is_VMS = $^O eq 'VMS'; -my $Is_MSWin32 = $^O eq 'MSWin32'; -my $Is_NetWare = $^O eq 'NetWare'; -my $tmpfile = "tmp0000"; -my $i = 0 ; -1 while -f ++$tmpfile; -END { if ($tmpfile) { 1 while unlink $tmpfile} } - -my @prgs = () ; -my @w_files = () ; - -if (@ARGV) - { print "ARGV = [@ARGV]\n" ; @w_files = map { s#^#./pragma/warn/#; $_ } @ARGV } -else - { @w_files = sort glob("pragma/warn/*") } - -my $files = 0; -foreach my $file (@w_files) { - - next if $file =~ /(~|\.orig|,v)$/; - - open F, "<$file" or die "Cannot open $file: $!\n" ; - my $line = 0; - while (<F>) { - $line++; - last if /^__END__/ ; - } - - { - local $/ = undef; - $files++; - @prgs = (@prgs, $file, split "\n########\n", <F>) ; - } - close F ; -} - -undef $/; - -print "1..", scalar(@prgs)-$files, "\n"; - - -for (@prgs){ - unless (/\n/) - { - print "# From $_\n"; - next; - } - my $switch = ""; - my @temps = () ; - if (s/^\s*-\w+//){ - $switch = $&; - $switch =~ s/(-\S*[A-Z]\S*)/"$1"/ if $Is_VMS; # protect uc switches - } - my($prog,$expected) = split(/\nEXPECT\n/, $_); - if ( $prog =~ /--FILE--/) { - my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; - shift @files ; - die "Internal error test $i didn't split into pairs, got " . - scalar(@files) . "[" . join("%%%%", @files) ."]\n" - if @files % 2 ; - while (@files > 2) { - my $filename = shift @files ; - my $code = shift @files ; - push @temps, $filename ; - open F, ">$filename" or die "Cannot open $filename: $!\n" ; - print F $code ; - close F ; - } - shift @files ; - $prog = shift @files ; - } - open TEST, ">$tmpfile"; - print TEST $prog,"\n"; - close TEST; - my $results = $Is_VMS ? - `./perl "-I../lib" $switch $tmpfile 2>&1` : - $Is_MSWin32 ? - `.\\perl -I../lib $switch $tmpfile 2>&1` : - $Is_NetWare ? - `perl -I../lib $switch $tmpfile 2>&1` : - `./perl -I../lib $switch $tmpfile 2>&1`; - my $status = $?; - $results =~ s/\n+$//; - # allow expected output to be written as if $prog is on STDIN - $results =~ s/tmp\d+/-/g; - $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg -# bison says 'parse error' instead of 'syntax error', -# various yaccs may or may not capitalize 'syntax'. - $results =~ s/^(syntax|parse) error/syntax error/mig; - # allow all tests to run when there are leaks - $results =~ s/Scalars leaked: \d+\n//g; - $expected =~ s/\n+$//; - my $prefix = ($results =~ s#^PREFIX(\n|$)##) ; - # any special options? (OPTIONS foo bar zap) - my $option_regex = 0; - if ($expected =~ s/^OPTIONS? (.+)\n//) { - foreach my $option (split(' ', $1)) { - if ($option eq 'regex') { # allow regular expressions - $option_regex = 1; - } else { - die "$0: Unknown OPTION '$option'\n"; - } - } - } - if ( $results =~ s/^SKIPPED\n//) { - print "$results\n" ; - } - elsif (($prefix && (( $option_regex && $results !~ /^$expected/) || - (!$option_regex && $results !~ /^\Q$expected/))) or - (!$prefix && (( $option_regex && $results !~ /^$expected/) || - (!$option_regex && $results ne $expected)))) { - print STDERR "PROG: $switch\n$prog\n"; - print STDERR "EXPECTED:\n$expected\n"; - print STDERR "GOT:\n$results\n"; - print "not "; - } - print "ok ", ++$i, "\n"; - foreach (@temps) - { unlink $_ if $_ } -} |