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 /ext | |
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 'ext')
86 files changed, 15027 insertions, 0 deletions
diff --git a/ext/B/B.t b/ext/B/B.t new file mode 100755 index 0000000000..f21f4891e4 --- /dev/null +++ b/ext/B/B.t @@ -0,0 +1,63 @@ +#!./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/ext/B/Debug.t b/ext/B/Debug.t new file mode 100644 index 0000000000..286dac3574 --- /dev/null +++ b/ext/B/Debug.t @@ -0,0 +1,70 @@ +#!./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/ext/B/Deparse.t b/ext/B/Deparse.t new file mode 100644 index 0000000000..048ce31eef --- /dev/null +++ b/ext/B/Deparse.t @@ -0,0 +1,176 @@ +#!./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/ext/B/Showlex.t b/ext/B/Showlex.t new file mode 100644 index 0000000000..a21f03bb15 --- /dev/null +++ b/ext/B/Showlex.t @@ -0,0 +1,39 @@ +#!./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/ext/B/Stash.t b/ext/B/Stash.t new file mode 100644 index 0000000000..bc9d896927 --- /dev/null +++ b/ext/B/Stash.t @@ -0,0 +1,60 @@ +#!./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/ext/Cwd/Cwd.t b/ext/Cwd/Cwd.t new file mode 100644 index 0000000000..09b45d6004 --- /dev/null +++ b/ext/Cwd/Cwd.t @@ -0,0 +1,134 @@ +#!./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/ext/DB_File/t/db-btree.t b/ext/DB_File/t/db-btree.t new file mode 100755 index 0000000000..4b4a7967ee --- /dev/null +++ b/ext/DB_File/t/db-btree.t @@ -0,0 +1,1296 @@ +#!./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/ext/DB_File/t/db-hash.t b/ext/DB_File/t/db-hash.t new file mode 100755 index 0000000000..6f2ef37b61 --- /dev/null +++ b/ext/DB_File/t/db-hash.t @@ -0,0 +1,743 @@ +#!./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/ext/DB_File/t/db-recno.t b/ext/DB_File/t/db-recno.t new file mode 100755 index 0000000000..6dd913cfc2 --- /dev/null +++ b/ext/DB_File/t/db-recno.t @@ -0,0 +1,889 @@ +#!./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/ext/Data/Dumper/t/dumper.t b/ext/Data/Dumper/t/dumper.t new file mode 100755 index 0000000000..10add1cedb --- /dev/null +++ b/ext/Data/Dumper/t/dumper.t @@ -0,0 +1,810 @@ +#!./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/ext/Data/Dumper/t/overload.t b/ext/Data/Dumper/t/overload.t new file mode 100755 index 0000000000..d4b3a924ae --- /dev/null +++ b/ext/Data/Dumper/t/overload.t @@ -0,0 +1,35 @@ +#!./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/ext/Devel/Peek/Peek.t b/ext/Devel/Peek/Peek.t new file mode 100644 index 0000000000..c14dc9bdad --- /dev/null +++ b/ext/Devel/Peek/Peek.t @@ -0,0 +1,308 @@ +#!./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/ext/Digest/MD5/t/aaa.t b/ext/Digest/MD5/t/aaa.t new file mode 100644 index 0000000000..f3f3202cb9 --- /dev/null +++ b/ext/Digest/MD5/t/aaa.t @@ -0,0 +1,552 @@ +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/ext/Digest/MD5/t/align.t b/ext/Digest/MD5/t/align.t new file mode 100644 index 0000000000..4176062415 --- /dev/null +++ b/ext/Digest/MD5/t/align.t @@ -0,0 +1,20 @@ +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/ext/Digest/MD5/t/badfile.t b/ext/Digest/MD5/t/badfile.t new file mode 100644 index 0000000000..63effdfc21 --- /dev/null +++ b/ext/Digest/MD5/t/badfile.t @@ -0,0 +1,26 @@ +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/ext/Digest/MD5/t/files.t b/ext/Digest/MD5/t/files.t new file mode 100644 index 0000000000..c786a5f4e5 --- /dev/null +++ b/ext/Digest/MD5/t/files.t @@ -0,0 +1,150 @@ +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/ext/Encode.t b/ext/Encode.t new file mode 100644 index 0000000000..ceeb422672 --- /dev/null +++ b/ext/Encode.t @@ -0,0 +1,122 @@ +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/ext/Errno/Errno.t b/ext/Errno/Errno.t new file mode 100755 index 0000000000..02f5ce2ca6 --- /dev/null +++ b/ext/Errno/Errno.t @@ -0,0 +1,54 @@ +#!./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/ext/Fcntl/Fcntl.t b/ext/Fcntl/Fcntl.t new file mode 100644 index 0000000000..24ade27c92 --- /dev/null +++ b/ext/Fcntl/Fcntl.t @@ -0,0 +1,46 @@ +#!./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/ext/Fcntl/syslfs.t b/ext/Fcntl/syslfs.t new file mode 100644 index 0000000000..8d9769fded --- /dev/null +++ b/ext/Fcntl/syslfs.t @@ -0,0 +1,267 @@ +# 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/ext/Filter/t/call.t b/ext/Filter/t/call.t new file mode 100644 index 0000000000..dc667c98ee --- /dev/null +++ b/ext/Filter/t/call.t @@ -0,0 +1,795 @@ +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/ext/GDBM_File/gdbm.t b/ext/GDBM_File/gdbm.t new file mode 100755 index 0000000000..0f5cfa0186 --- /dev/null +++ b/ext/GDBM_File/gdbm.t @@ -0,0 +1,427 @@ +#!./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/ext/IO/lib/IO/t/io_const.t b/ext/IO/lib/IO/t/io_const.t new file mode 100755 index 0000000000..db1a322453 --- /dev/null +++ b/ext/IO/lib/IO/t/io_const.t @@ -0,0 +1,33 @@ + +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/ext/IO/lib/IO/t/io_dir.t b/ext/IO/lib/IO/t/io_dir.t new file mode 100755 index 0000000000..6ec4e9f232 --- /dev/null +++ b/ext/IO/lib/IO/t/io_dir.t @@ -0,0 +1,68 @@ +#!./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/ext/IO/lib/IO/t/io_dup.t b/ext/IO/lib/IO/t/io_dup.t new file mode 100755 index 0000000000..8983a56f36 --- /dev/null +++ b/ext/IO/lib/IO/t/io_dup.t @@ -0,0 +1,61 @@ +#!./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/ext/IO/lib/IO/t/io_linenum.t b/ext/IO/lib/IO/t/io_linenum.t new file mode 100755 index 0000000000..cf55c980ea --- /dev/null +++ b/ext/IO/lib/IO/t/io_linenum.t @@ -0,0 +1,80 @@ +#!./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/ext/IO/lib/IO/t/io_multihomed.t b/ext/IO/lib/IO/t/io_multihomed.t new file mode 100644 index 0000000000..62f25bc39e --- /dev/null +++ b/ext/IO/lib/IO/t/io_multihomed.t @@ -0,0 +1,128 @@ +#!./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/ext/IO/lib/IO/t/io_pipe.t b/ext/IO/lib/IO/t/io_pipe.t new file mode 100755 index 0000000000..ae18224b12 --- /dev/null +++ b/ext/IO/lib/IO/t/io_pipe.t @@ -0,0 +1,123 @@ +#!./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/ext/IO/lib/IO/t/io_poll.t b/ext/IO/lib/IO/t/io_poll.t new file mode 100755 index 0000000000..d31ea47f53 --- /dev/null +++ b/ext/IO/lib/IO/t/io_poll.t @@ -0,0 +1,82 @@ +#!./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/ext/IO/lib/IO/t/io_sel.t b/ext/IO/lib/IO/t/io_sel.t new file mode 100755 index 0000000000..84660db183 --- /dev/null +++ b/ext/IO/lib/IO/t/io_sel.t @@ -0,0 +1,132 @@ +#!./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/ext/IO/lib/IO/t/io_sock.t b/ext/IO/lib/IO/t/io_sock.t new file mode 100755 index 0000000000..b752fd89ba --- /dev/null +++ b/ext/IO/lib/IO/t/io_sock.t @@ -0,0 +1,338 @@ +#!./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/ext/IO/lib/IO/t/io_taint.t b/ext/IO/lib/IO/t/io_taint.t new file mode 100755 index 0000000000..c98d70151f --- /dev/null +++ b/ext/IO/lib/IO/t/io_taint.t @@ -0,0 +1,48 @@ +#!./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/ext/IO/lib/IO/t/io_tell.t b/ext/IO/lib/IO/t/io_tell.t new file mode 100755 index 0000000000..65c63bdfc9 --- /dev/null +++ b/ext/IO/lib/IO/t/io_tell.t @@ -0,0 +1,64 @@ +#!./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/ext/IO/lib/IO/t/io_udp.t b/ext/IO/lib/IO/t/io_udp.t new file mode 100755 index 0000000000..d63a5dcf7b --- /dev/null +++ b/ext/IO/lib/IO/t/io_udp.t @@ -0,0 +1,94 @@ +#!./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/ext/IO/lib/IO/t/io_unix.t b/ext/IO/lib/IO/t/io_unix.t new file mode 100644 index 0000000000..2f6def0af7 --- /dev/null +++ b/ext/IO/lib/IO/t/io_unix.t @@ -0,0 +1,89 @@ +#!./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/ext/IO/lib/IO/t/io_xs.t b/ext/IO/lib/IO/t/io_xs.t new file mode 100644 index 0000000000..2449fc45c1 --- /dev/null +++ b/ext/IO/lib/IO/t/io_xs.t @@ -0,0 +1,43 @@ +#!./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/ext/List/Util/t/blessed.t b/ext/List/Util/t/blessed.t new file mode 100755 index 0000000000..89a740a8cb --- /dev/null +++ b/ext/List/Util/t/blessed.t @@ -0,0 +1,39 @@ +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/ext/List/Util/t/dualvar.t b/ext/List/Util/t/dualvar.t new file mode 100755 index 0000000000..5bf4fe95f7 --- /dev/null +++ b/ext/List/Util/t/dualvar.t @@ -0,0 +1,46 @@ +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/ext/List/Util/t/first.t b/ext/List/Util/t/first.t new file mode 100755 index 0000000000..6a35948e95 --- /dev/null +++ b/ext/List/Util/t/first.t @@ -0,0 +1,25 @@ +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/ext/List/Util/t/max.t b/ext/List/Util/t/max.t new file mode 100755 index 0000000000..911003b92a --- /dev/null +++ b/ext/List/Util/t/max.t @@ -0,0 +1,30 @@ +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/ext/List/Util/t/maxstr.t b/ext/List/Util/t/maxstr.t new file mode 100755 index 0000000000..0ec35cab30 --- /dev/null +++ b/ext/List/Util/t/maxstr.t @@ -0,0 +1,30 @@ +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/ext/List/Util/t/min.t b/ext/List/Util/t/min.t new file mode 100755 index 0000000000..a51ced4e3d --- /dev/null +++ b/ext/List/Util/t/min.t @@ -0,0 +1,30 @@ +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/ext/List/Util/t/minstr.t b/ext/List/Util/t/minstr.t new file mode 100755 index 0000000000..c000e7856d --- /dev/null +++ b/ext/List/Util/t/minstr.t @@ -0,0 +1,30 @@ +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/ext/List/Util/t/readonly.t b/ext/List/Util/t/readonly.t new file mode 100644 index 0000000000..864e1f12f2 --- /dev/null +++ b/ext/List/Util/t/readonly.t @@ -0,0 +1,46 @@ +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/ext/List/Util/t/reduce.t b/ext/List/Util/t/reduce.t new file mode 100755 index 0000000000..063e0b791b --- /dev/null +++ b/ext/List/Util/t/reduce.t @@ -0,0 +1,30 @@ +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/ext/List/Util/t/reftype.t b/ext/List/Util/t/reftype.t new file mode 100755 index 0000000000..ea7ea7bbc1 --- /dev/null +++ b/ext/List/Util/t/reftype.t @@ -0,0 +1,55 @@ +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/ext/List/Util/t/sum.t b/ext/List/Util/t/sum.t new file mode 100755 index 0000000000..34fb69076a --- /dev/null +++ b/ext/List/Util/t/sum.t @@ -0,0 +1,23 @@ +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/ext/List/Util/t/tainted.t b/ext/List/Util/t/tainted.t new file mode 100644 index 0000000000..5587bb7bf9 --- /dev/null +++ b/ext/List/Util/t/tainted.t @@ -0,0 +1,38 @@ +#!./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/ext/List/Util/t/weak.t b/ext/List/Util/t/weak.t new file mode 100755 index 0000000000..6c7bea7f4d --- /dev/null +++ b/ext/List/Util/t/weak.t @@ -0,0 +1,206 @@ +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/ext/MIME/Base64/t/base64.t b/ext/MIME/Base64/t/base64.t new file mode 100644 index 0000000000..7a61fe9576 --- /dev/null +++ b/ext/MIME/Base64/t/base64.t @@ -0,0 +1,383 @@ +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/ext/MIME/Base64/t/qp.t b/ext/MIME/Base64/t/qp.t new file mode 100644 index 0000000000..1a7f9e4550 --- /dev/null +++ b/ext/MIME/Base64/t/qp.t @@ -0,0 +1,113 @@ +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/ext/MIME/Base64/t/unicode.t b/ext/MIME/Base64/t/unicode.t new file mode 100644 index 0000000000..0b8df1ae7c --- /dev/null +++ b/ext/MIME/Base64/t/unicode.t @@ -0,0 +1,16 @@ +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/ext/NDBM_File/ndbm.t b/ext/NDBM_File/ndbm.t new file mode 100755 index 0000000000..cb975e0047 --- /dev/null +++ b/ext/NDBM_File/ndbm.t @@ -0,0 +1,420 @@ +#!./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/ext/ODBM_File/odbm.t b/ext/ODBM_File/odbm.t new file mode 100755 index 0000000000..a43e70bd99 --- /dev/null +++ b/ext/ODBM_File/odbm.t @@ -0,0 +1,437 @@ +#!./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/ext/ODBM_File/sdbm.t b/ext/ODBM_File/sdbm.t new file mode 100755 index 0000000000..57928e0e51 --- /dev/null +++ b/ext/ODBM_File/sdbm.t @@ -0,0 +1,429 @@ +#!./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/ext/Opcode/Opcode.t b/ext/Opcode/Opcode.t new file mode 100755 index 0000000000..a785fce48b --- /dev/null +++ b/ext/Opcode/Opcode.t @@ -0,0 +1,115 @@ +#!./perl -w + +$|=1; + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { + print "1..0\n"; + exit 0; + } +} + +use Opcode qw( + opcodes opdesc opmask verify_opset + opset opset_to_ops opset_to_hex invert_opset + opmask_add full_opset empty_opset define_optag +); + +use strict; + +my $t = 1; +my $last_test; # initalised at end +print "1..$last_test\n"; + +my($s1, $s2, $s3); +my(@o1, @o2, @o3); + +# --- opset_to_ops and opset + +my @empty_l = opset_to_ops(empty_opset); +print @empty_l == 0 ? "ok $t\n" : "not ok $t\n"; $t++; + +my @full_l1 = opset_to_ops(full_opset); +print @full_l1 == opcodes() ? "ok $t\n" : "not ok $t\n"; $t++; +my @full_l2 = @full_l1; # = opcodes(); # XXX to be fixed +print "@full_l1" eq "@full_l2" ? "ok $t\n" : "not ok $t\n"; $t++; + +@empty_l = opset_to_ops(opset(':none')); +print @empty_l == 0 ? "ok $t\n" : "not ok $t\n"; $t++; + +my @full_l3 = opset_to_ops(opset(':all')); +print @full_l1 == @full_l3 ? "ok $t\n" : "not ok $t\n"; $t++; +print "@full_l1" eq "@full_l3" ? "ok $t\n" : "not ok $t\n"; $t++; + +die $t unless $t == 7; +$s1 = opset( 'padsv'); +$s2 = opset($s1, 'padav'); +$s3 = opset($s2, '!padav'); +print $s1 eq $s2 ? "not ok $t\n" : "ok $t\n"; ++$t; +print $s1 eq $s3 ? "ok $t\n" : "not ok $t\n"; ++$t; + +# --- define_optag + +print eval { opset(':_tst_') } ? "not ok $t\n" : "ok $t\n"; ++$t; +define_optag(":_tst_", opset(qw(padsv padav padhv))); +print eval { opset(':_tst_') } ? "ok $t\n" : "not ok $t\n"; ++$t; + +# --- opdesc and opcodes + +die $t unless $t == 11; +print opdesc("gv") eq "glob value" ? "ok $t\n" : "not ok $t\n"; $t++; +my @desc = opdesc(':_tst_','stub'); +print "@desc" eq "private variable private array private hash stub" + ? "ok $t\n" : "not ok $t\n#@desc\n"; $t++; +print opcodes() ? "ok $t\n" : "not ok $t\n"; $t++; +print "ok $t\n"; ++$t; + +# --- invert_opset + +$s1 = opset(qw(fileno padsv padav)); +@o2 = opset_to_ops(invert_opset($s1)); +print @o2 == opcodes-3 ? "ok $t\n" : "not ok $t\n"; $t++; + +# --- opmask + +die $t unless $t == 16; +print opmask() eq empty_opset() ? "ok $t\n" : "not ok $t\n"; $t++; # work +print length opmask() == int((opcodes()+7)/8) ? "ok $t\n" : "not ok $t\n"; $t++; + +# --- verify_opset + +print verify_opset($s1) && !verify_opset(42) ? "ok $t\n":"not ok $t\n"; $t++; + +# --- opmask_add + +opmask_add(opset(qw(fileno))); # add to global op_mask +print eval 'fileno STDOUT' ? "not ok $t\n" : "ok $t\n"; $t++; # fail +print $@ =~ /fileno trapped/ ? "ok $t\n" : "not ok $t\n# $@\n"; $t++; + +# --- check use of bit vector ops on opsets + +$s1 = opset('padsv'); +$s2 = opset('padav'); +$s3 = opset('padsv', 'padav', 'padhv'); + +# Non-negated +print (($s1 | $s2) eq opset($s1,$s2) ? "ok $t\n":"not ok $t\n"); $t++; +print (($s2 & $s3) eq opset($s2) ? "ok $t\n":"not ok $t\n"); $t++; +print (($s2 ^ $s3) eq opset('padsv','padhv') ? "ok $t\n":"not ok $t\n"); $t++; + +# Negated, e.g., with possible extra bits in last byte beyond last op bit. +# The extra bits mean we can't just say ~mask eq invert_opset(mask). + +@o1 = opset_to_ops( ~ $s3); +@o2 = opset_to_ops(invert_opset $s3); +print "@o1" eq "@o2" ? "ok $t\n":"not ok $t\n"; $t++; + +# --- finally, check some opname assertions + +foreach(@full_l1) { die "bad opname: $_" if /\W/ or /^\d/ } + +print "ok $last_test\n"; +BEGIN { $last_test = 25 } diff --git a/ext/Opcode/ops.t b/ext/Opcode/ops.t new file mode 100755 index 0000000000..56b1bacabb --- /dev/null +++ b/ext/Opcode/ops.t @@ -0,0 +1,29 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { + print "1..0\n"; + exit 0; + } +} + +print "1..2\n"; + +eval <<'EOP'; + no ops 'fileno'; # equiv to "perl -M-ops=fileno" + $a = fileno STDIN; +EOP + +print $@ =~ /trapped/ ? "ok 1\n" : "not ok 1\n# $@\n"; + +eval <<'EOP'; + use ops ':default'; # equiv to "perl -M(as above) -Mops=:default" + eval 1; +EOP + +print $@ =~ /trapped/ ? "ok 2\n" : "not ok 2\n# $@\n"; + +1; diff --git a/ext/POSIX/POSIX.t b/ext/POSIX/POSIX.t new file mode 100755 index 0000000000..09bd88c2a9 --- /dev/null +++ b/ext/POSIX/POSIX.t @@ -0,0 +1,139 @@ +#!./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/ext/POSIX/sigaction.t b/ext/POSIX/sigaction.t new file mode 100644 index 0000000000..c38b122775 --- /dev/null +++ b/ext/POSIX/sigaction.t @@ -0,0 +1,127 @@ +#!./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/ext/PerlIO/PerlIO.t b/ext/PerlIO/PerlIO.t new file mode 100644 index 0000000000..d71ab8ec4f --- /dev/null +++ b/ext/PerlIO/PerlIO.t @@ -0,0 +1,90 @@ +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/ext/PerlIO/t/scalar.t b/ext/PerlIO/t/scalar.t new file mode 100644 index 0000000000..8368e666b9 --- /dev/null +++ b/ext/PerlIO/t/scalar.t @@ -0,0 +1,101 @@ +#!./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/ext/Safe/safe1.t b/ext/Safe/safe1.t new file mode 100755 index 0000000000..27993d95c9 --- /dev/null +++ b/ext/Safe/safe1.t @@ -0,0 +1,68 @@ +#!./perl -w +$|=1; +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') { + print "1..0\n"; + exit 0; + } +} + +# Tests Todo: +# 'main' as root + +package test; # test from somewhere other than main + +use vars qw($bar); + +use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex + opmask_add full_opset empty_opset opcodes opmask define_optag); + +use Safe 1.00; + +my $last_test; # initalised at end +print "1..$last_test\n"; + +my $t = 1; +my $cpt; +# create and destroy some automatic Safe compartments first +$cpt = new Safe or die; +$cpt = new Safe or die; +$cpt = new Safe or die; + +$cpt = new Safe "Root" or die; + +foreach(1..3) { + $foo = 42; + + $cpt->share(qw($foo)); + + print ${$cpt->varglob('foo')} == 42 ? "ok $t\n" : "not ok $t\n"; $t++; + + ${$cpt->varglob('foo')} = 9; + + print $foo == 9 ? "ok $t\n" : "not ok $t\n"; $t++; + + print $cpt->reval('$foo') == 9 ? "ok $t\n" : "not ok $t\n"; $t++; + # check 'main' has been changed: + print $cpt->reval('$::foo') == 9 ? "ok $t\n" : "not ok $t\n"; $t++; + print $cpt->reval('$main::foo') == 9 ? "ok $t\n" : "not ok $t\n"; $t++; + # check we can't see our test package: + print $cpt->reval('$test::foo') ? "not ok $t\n" : "ok $t\n"; $t++; + print $cpt->reval('${"test::foo"}') ? "not ok $t\n" : "ok $t\n"; $t++; + + $cpt->erase; # erase the compartment, e.g., delete all variables + + print $cpt->reval('$foo') ? "not ok $t\n" : "ok $t\n"; $t++; + + # Note that we *must* use $cpt->varglob here because if we used + # $Root::foo etc we would still see the original values! + # This seems to be because the compiler has created an extra ref. + + print ${$cpt->varglob('foo')} ? "not ok $t\n" : "ok $t\n"; $t++; +} + +print "ok $last_test\n"; +BEGIN { $last_test = 28 } diff --git a/ext/Safe/safe2.t b/ext/Safe/safe2.t new file mode 100755 index 0000000000..4d6c84a692 --- /dev/null +++ b/ext/Safe/safe2.t @@ -0,0 +1,145 @@ +#!./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/ext/Socket/Socket.t b/ext/Socket/Socket.t new file mode 100755 index 0000000000..481fd8f3e0 --- /dev/null +++ b/ext/Socket/Socket.t @@ -0,0 +1,87 @@ +#!./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/ext/Storable/t/blessed.t b/ext/Storable/t/blessed.t new file mode 100644 index 0000000000..b1a18e62c3 --- /dev/null +++ b/ext/Storable/t/blessed.t @@ -0,0 +1,104 @@ +#!./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/ext/Storable/t/canonical.t b/ext/Storable/t/canonical.t new file mode 100644 index 0000000000..b55669b653 --- /dev/null +++ b/ext/Storable/t/canonical.t @@ -0,0 +1,153 @@ +#!./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/ext/Storable/t/compat06.t b/ext/Storable/t/compat06.t new file mode 100644 index 0000000000..1586b18a81 --- /dev/null +++ b/ext/Storable/t/compat06.t @@ -0,0 +1,157 @@ +#!./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/ext/Storable/t/dclone.t b/ext/Storable/t/dclone.t new file mode 100644 index 0000000000..38c82ebcc1 --- /dev/null +++ b/ext/Storable/t/dclone.t @@ -0,0 +1,82 @@ +#!./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/ext/Storable/t/forgive.t b/ext/Storable/t/forgive.t new file mode 100644 index 0000000000..58810983c5 --- /dev/null +++ b/ext/Storable/t/forgive.t @@ -0,0 +1,67 @@ +#!./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/ext/Storable/t/freeze.t b/ext/Storable/t/freeze.t new file mode 100644 index 0000000000..37631edc7e --- /dev/null +++ b/ext/Storable/t/freeze.t @@ -0,0 +1,119 @@ +#!./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/ext/Storable/t/lock.t b/ext/Storable/t/lock.t new file mode 100644 index 0000000000..77d73bbb79 --- /dev/null +++ b/ext/Storable/t/lock.t @@ -0,0 +1,61 @@ +#!./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/ext/Storable/t/overload.t b/ext/Storable/t/overload.t new file mode 100644 index 0000000000..6d1e5816d1 --- /dev/null +++ b/ext/Storable/t/overload.t @@ -0,0 +1,97 @@ +#!./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/ext/Storable/t/recurse.t b/ext/Storable/t/recurse.t new file mode 100644 index 0000000000..e3afc9cf2f --- /dev/null +++ b/ext/Storable/t/recurse.t @@ -0,0 +1,300 @@ +#!./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/ext/Storable/t/retrieve.t b/ext/Storable/t/retrieve.t new file mode 100644 index 0000000000..c968485ab2 --- /dev/null +++ b/ext/Storable/t/retrieve.t @@ -0,0 +1,78 @@ +#!./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/ext/Storable/t/store.t b/ext/Storable/t/store.t new file mode 100644 index 0000000000..d26755f129 --- /dev/null +++ b/ext/Storable/t/store.t @@ -0,0 +1,119 @@ +#!./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/ext/Storable/t/tied.t b/ext/Storable/t/tied.t new file mode 100644 index 0000000000..88131fea03 --- /dev/null +++ b/ext/Storable/t/tied.t @@ -0,0 +1,213 @@ +#!./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/ext/Storable/t/tied_hook.t b/ext/Storable/t/tied_hook.t new file mode 100644 index 0000000000..46805cf510 --- /dev/null +++ b/ext/Storable/t/tied_hook.t @@ -0,0 +1,254 @@ +#!./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/ext/Storable/t/tied_items.t b/ext/Storable/t/tied_items.t new file mode 100644 index 0000000000..3d0abf796f --- /dev/null +++ b/ext/Storable/t/tied_items.t @@ -0,0 +1,68 @@ +#!./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/ext/Storable/t/utf8.t b/ext/Storable/t/utf8.t new file mode 100644 index 0000000000..2160308a28 --- /dev/null +++ b/ext/Storable/t/utf8.t @@ -0,0 +1,40 @@ +#!./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/ext/Sys/Hostname/Hostname.t b/ext/Sys/Hostname/Hostname.t new file mode 100755 index 0000000000..85a04cd488 --- /dev/null +++ b/ext/Sys/Hostname/Hostname.t @@ -0,0 +1,25 @@ +#!./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/ext/Sys/Syslog/syslog.t b/ext/Sys/Syslog/syslog.t new file mode 100755 index 0000000000..801e882508 --- /dev/null +++ b/ext/Sys/Syslog/syslog.t @@ -0,0 +1,72 @@ +#!./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/ext/Thread/thr5005.t b/ext/Thread/thr5005.t new file mode 100755 index 0000000000..6650683e16 --- /dev/null +++ b/ext/Thread/thr5005.t @@ -0,0 +1,207 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if (! $Config{'use5005threads'}) { + print "1..0 # Skip: no 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/ext/Time/HiRes/HiRes.t b/ext/Time/HiRes/HiRes.t new file mode 100644 index 0000000000..db35b955a5 --- /dev/null +++ b/ext/Time/HiRes/HiRes.t @@ -0,0 +1,216 @@ +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/ext/Time/Piece/Piece.t b/ext/Time/Piece/Piece.t new file mode 100644 index 0000000000..c62e36d95e --- /dev/null +++ b/ext/Time/Piece/Piece.t @@ -0,0 +1,323 @@ +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/ext/XS/Typemap/Typemap.t b/ext/XS/Typemap/Typemap.t new file mode 100644 index 0000000000..0cf1ab3481 --- /dev/null +++ b/ext/XS/Typemap/Typemap.t @@ -0,0 +1,339 @@ +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/ext/attrs.t b/ext/attrs.t new file mode 100644 index 0000000000..18a02aba84 --- /dev/null +++ b/ext/attrs.t @@ -0,0 +1,141 @@ +#!./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; |