dslinux/user/perl/ext/Storable/t HAS_ATTACH.pm HAS_HOOK.pm HAS_OVERLOAD.pm attach_errors.t attach_singleton.t blessed.t canonical.t circular_hook.t code.t compat06.t croak.t dclone.t downgrade.t forgive.t freeze.t integer.t interwork56.t just_plain_nasty.t lock.t make_56_interwork.pl make_downgrade.pl make_overload.pl malice.t overload.t recurse.t restrict.t retrieve.t sig_die.t st-dump.pl store.t testlib.pl threads.t tied.t tied_hook.t tied_items.t utf8.t utf8hash.t weak.t
cayenne
dslinux_cayenne at user.in-berlin.de
Tue Dec 5 05:26:58 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/ext/Storable/t
In directory antilope:/tmp/cvs-serv7729/ext/Storable/t
Added Files:
HAS_ATTACH.pm HAS_HOOK.pm HAS_OVERLOAD.pm attach_errors.t
attach_singleton.t blessed.t canonical.t circular_hook.t
code.t compat06.t croak.t dclone.t downgrade.t forgive.t
freeze.t integer.t interwork56.t just_plain_nasty.t lock.t
make_56_interwork.pl make_downgrade.pl make_overload.pl
malice.t overload.t recurse.t restrict.t retrieve.t sig_die.t
st-dump.pl store.t testlib.pl threads.t tied.t tied_hook.t
tied_items.t utf8.t utf8hash.t weak.t
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: dclone.t ---
#!./perl
#
# 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.
#
sub BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib', '../ext/Storable/t');
} else {
unshift @INC, 't';
}
require Config; import Config;
if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
require 'st-dump.pl';
}
use Storable qw(dclone);
print "1..10\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";
# [ID 20020221.007] SEGV in Storable with empty string scalar object
package TestString;
sub new {
my ($type, $string) = @_;
return bless(\$string, $type);
}
package main;
my $empty_string_obj = TestString->new('');
my $clone = dclone($empty_string_obj);
# If still here after the dclone the fix (#17543) worked.
print ref $clone eq ref $empty_string_obj &&
$$clone eq $$empty_string_obj &&
$$clone eq '' ? "ok 10\n" : "not ok 10\n";
--- NEW FILE: make_56_interwork.pl ---
#!/usr/bin/perl -w
use strict;
use Config;
use Storable qw(freeze thaw);
# Lilliput decreed that eggs should be eaten small end first.
# Belfuscu welcomed the rebels who wanted to eat big end first.
my $kingdom = $Config{byteorder} =~ /23/ ? "Lillput" : "Belfuscu";
my $frozen = freeze
["This file was written with $Storable::VERSION on perl $]",
"$kingdom was correct", (~0 ^ (~0 >> 1) ^ 2),
"The End"];
my $ivsize = $Config{ivsize} || $Config{longsize};
my $storesize = unpack 'xxC', $frozen;
my $storebyteorder = unpack "xxxA$storesize", $frozen;
if ($Config{byteorder} eq $storebyteorder) {
my $ivtype = $Config{ivtype} || 'long';
print <<"EOM";
You only need to run this generator program where Config.pm's byteorder string
is not the same length as the size of IVs.
This length difference should only happen on perl 5.6.x configured with IVs as
long long on Unix, OS/2 or any platform that runs the Configure stript (ie not
MS Windows)
This is perl $], sizeof(long) is $Config{longsize}, IVs are '$ivtype', sizeof(IV) is $ivsize,
byteorder is '$Config{byteorder}', Storable $Storable::VERSION writes a byteorder of '$storebyteorder'
EOM
exit; # Grr '
}
my ($i, $l, $p, $n) = unpack "xxxx${storesize}CCCC", $frozen;
print <<"EOM";
# byteorder '$storebyteorder'
# sizeof(int) $i
# sizeof(long) $l
# sizeof(char *) $p
# sizeof(NV) $n
EOM
my $uu = pack 'u', $frozen;
printf "begin %3o $kingdom,$i,$l,$p,$n\n", ord 'A';
print $uu;
print "\nend\n\n";
--- NEW FILE: make_overload.pl ---
#!/usr/local/bin/perl -w
use strict;
use Storable qw(nfreeze);
use HAS_OVERLOAD;
my $o = HAS_OVERLOAD->make("snow");
my $f = nfreeze \$o;
my $uu = pack 'u', $f;
print $uu;
--- NEW FILE: compat06.t ---
#!./perl
#
# 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.
#
BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib', '../ext/Storable/t');
} else {
unshift @INC, 't';
}
require Config; import Config;
if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
require '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 at 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 at 93
M24U03$586`0"`````0B"6&(&4TE-4$Q%6%@$`@````$(@UAB!E-)35!,15A8
M!`(````!"(188 at 9324U03$586%A8`````V]B:@0,!``````*6%A8`````W)E
(9F($4D]/5%@`
#
# using Storable-0.6 at 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 at 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``
--- NEW FILE: weak.t ---
#!./perl -w
#
# Copyright 2004, Larry Wall.
#
# You may redistribute only under the same terms as Perl 5, as specified
# in the README file that comes with the distribution.
#
sub BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib', '../ext/Storable/t');
} else {
# This lets us distribute Test::More in t/
unshift @INC, 't';
}
require Config; import Config;
if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
if ($Config{extensions} !~ /\bList\/Util\b/) {
print "1..0 # Skip: List::Util was not built\n";
exit 0;
}
require Scalar::Util;
Scalar::Util->import(qw(weaken isweak));
if (grep { /weaken/ } @Scalar::Util::EXPORT_FAIL) {
print("1..0 # Skip: No support for weaken in Scalar::Util\n");
exit 0;
}
}
use Test::More 'no_plan';
use Storable qw (store retrieve freeze thaw nstore nfreeze);
require 'testlib.pl';
use vars '$file';
use strict;
sub tester {
my ($contents, $sub, $testersub, $what) = @_;
# Test that if we re-write it, everything still works:
my $clone = &$sub ($contents);
is ($@, "", "There should be no error extracting for $what");
&$testersub ($clone, $what);
}
my $r = {};
my $s1 = [$r, $r];
weaken $s1->[1];
ok (isweak($s1->[1]), "element 1 is a weak reference");
my $s0 = [$r, $r];
weaken $s0->[0];
ok (isweak($s0->[0]), "element 0 is a weak reference");
my $w = [$r];
weaken $w->[0];
ok (isweak($w->[0]), "element 0 is a weak reference");
package OVERLOADED;
use overload
'""' => sub { $_[0][0] };
package main;
$a = bless [77], 'OVERLOADED';
my $o = [$a, $a];
weaken $o->[0];
ok (isweak($o->[0]), "element 0 is a weak reference");
my @tests = (
[$s1,
sub {
my ($clone, $what) = @_;
isa_ok($clone,'ARRAY');
isa_ok($clone->[0],'HASH');
isa_ok($clone->[1],'HASH');
ok(!isweak $clone->[0], "Element 0 isn't weak");
ok(isweak $clone->[1], "Element 1 is weak");
}
],
# The weak reference needs to hang around long enough for other stuff to
# be able to make references to it. So try it second.
[$s0,
sub {
my ($clone, $what) = @_;
isa_ok($clone,'ARRAY');
isa_ok($clone->[0],'HASH');
isa_ok($clone->[1],'HASH');
ok(isweak $clone->[0], "Element 0 is weak");
ok(!isweak $clone->[1], "Element 1 isn't weak");
}
],
[$w,
sub {
my ($clone, $what) = @_;
isa_ok($clone,'ARRAY');
if ($what eq 'nothing') {
# We're the original, so we're still a weakref to a hash
isa_ok($clone->[0],'HASH');
ok(isweak $clone->[0], "Element 0 is weak");
} else {
is($clone->[0],undef);
}
}
],
[$o,
sub {
my ($clone, $what) = @_;
isa_ok($clone,'ARRAY');
isa_ok($clone->[0],'OVERLOADED');
isa_ok($clone->[1],'OVERLOADED');
ok(isweak $clone->[0], "Element 0 is weak");
ok(!isweak $clone->[1], "Element 1 isn't weak");
is ("$clone->[0]", 77, "Element 0 stringifies to 77");
is ("$clone->[1]", 77, "Element 1 stringifies to 77");
}
],
);
foreach (@tests) {
my ($input, $testsub) = @$_;
tester($input, sub {return shift}, $testsub, 'nothing');
ok (defined store($input, $file));
# Read the contents into memory:
my $contents = slurp ($file);
tester($contents, \&store_and_retrieve, $testsub, 'file');
# And now try almost everything again with a Storable string
my $stored = freeze $input;
tester($stored, \&freeze_and_thaw, $testsub, 'string');
ok (defined nstore($input, $file));
tester($contents, \&store_and_retrieve, $testsub, 'network file');
$stored = nfreeze $input;
tester($stored, \&freeze_and_thaw, $testsub, 'network string');
}
--- NEW FILE: code.t ---
#!./perl
#
# Copyright (c) 2002 Slaven Rezic
#
# You may redistribute only under the same terms as Perl 5, as specified
# in the README file that comes with the distribution.
#
sub BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib');
} else {
unshift @INC, 't';
}
require Config; import Config;
if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
}
use strict;
BEGIN {
if (!eval q{
use Test;
use B::Deparse 0.61;
use 5.006;
1;
}) {
print "1..0 # skip: tests only work with B::Deparse 0.61 and at least perl 5.6.0\n";
exit;
}
require File::Spec;
if ($File::Spec::VERSION < 0.8) {
print "1..0 # Skip: newer File::Spec needed\n";
exit 0;
}
}
BEGIN { plan tests => 59 }
use Storable qw(retrieve store nstore freeze nfreeze thaw dclone);
use Safe;
#$Storable::DEBUGME = 1;
use vars qw($freezed $thawed @obj @res $blessed_code);
$blessed_code = bless sub { "blessed" }, "Some::Package";
{ package Another::Package; sub foo { __PACKAGE__ } }
{
no strict; # to make the life for Safe->reval easier
sub code { "JAPH" }
}
local *FOO;
@obj =
([\&code, # code reference
sub { 6*7 },
$blessed_code, # blessed code reference
\&Another::Package::foo, # code in another package
sub ($$;$) { 0 }, # prototypes
sub { print "test\n" },
\&Test::ok, # large scalar
],
{"a" => sub { "srt" }, "b" => \&code},
sub { ord("a")-ord("7") },
\&code,
\&dclone, # XS function
sub { open FOO, "/" },
);
$Storable::Deparse = 1;
$Storable::Eval = 1;
######################################################################
# Test freeze & thaw
$freezed = freeze $obj[0];
$thawed = thaw $freezed;
ok($thawed->[0]->(), "JAPH");
ok($thawed->[1]->(), 42);
ok($thawed->[2]->(), "blessed");
ok($thawed->[3]->(), "Another::Package");
ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
######################################################################
$freezed = freeze $obj[1];
$thawed = thaw $freezed;
ok($thawed->{"a"}->(), "srt");
ok($thawed->{"b"}->(), "JAPH");
######################################################################
$freezed = freeze $obj[2];
$thawed = thaw $freezed;
ok($thawed->(), 42);
######################################################################
$freezed = freeze $obj[3];
$thawed = thaw $freezed;
ok($thawed->(), "JAPH");
######################################################################
eval { $freezed = freeze $obj[4] };
ok($@, qr/The result of B::Deparse::coderef2text was empty/);
######################################################################
# Test dclone
my $new_sub = dclone($obj[2]);
ok($new_sub->(), $obj[2]->());
######################################################################
# Test retrieve & store
store $obj[0], 'store';
$thawed = retrieve 'store';
ok($thawed->[0]->(), "JAPH");
ok($thawed->[1]->(), 42);
ok($thawed->[2]->(), "blessed");
ok($thawed->[3]->(), "Another::Package");
ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
######################################################################
nstore $obj[0], 'store';
$thawed = retrieve 'store';
unlink 'store';
ok($thawed->[0]->(), "JAPH");
ok($thawed->[1]->(), 42);
ok($thawed->[2]->(), "blessed");
ok($thawed->[3]->(), "Another::Package");
ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
######################################################################
# Security with
# $Storable::Eval
# $Storable::Deparse
{
local $Storable::Eval = 0;
for my $i (0 .. 1) {
$freezed = freeze $obj[$i];
$@ = "";
eval { $thawed = thaw $freezed };
ok($@, qr/Can\'t eval/);
}
}
{
local $Storable::Deparse = 0;
for my $i (0 .. 1) {
$@ = "";
eval { $freezed = freeze $obj[$i] };
ok($@, qr/Can\'t store CODE items/);
}
}
{
local $Storable::Eval = 0;
local $Storable::forgive_me = 1;
for my $i (0 .. 4) {
$freezed = freeze $obj[0]->[$i];
$@ = "";
eval { $thawed = thaw $freezed };
ok($@, "");
ok($$thawed, qr/^sub/);
}
}
{
local $Storable::Deparse = 0;
local $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 { $freezed = freeze $obj[0]->[0] };
open(STDERR, ">&SAVEERR");
ok($@, "");
ok($freezed ne '');
}
{
my $safe = new Safe;
local $Storable::Eval = sub { $safe->reval(shift) };
$freezed = freeze $obj[0]->[0];
$@ = "";
eval { $thawed = thaw $freezed };
ok($@, "");
ok($thawed->(), "JAPH");
$freezed = freeze $obj[0]->[6];
eval { $thawed = thaw $freezed };
# The "Code sub ..." error message only appears if Log::Agent is installed
ok($@, qr/(trapped|Code sub)/);
if (0) {
# Disable or fix this test if the internal representation of Storable
# changes.
skip("no malicious storable file check", 1);
} else {
# Construct malicious storable code
$freezed = nfreeze $obj[0]->[0];
my $bad_code = ';open FOO, "/badfile"';
# 5th byte is (short) length of scalar
my $len = ord(substr($freezed, 4, 1));
substr($freezed, 4, 1, chr($len+length($bad_code)));
substr($freezed, -1, 0, $bad_code);
$@ = "";
eval { $thawed = thaw $freezed };
ok($@, qr/(trapped|Code sub)/);
}
}
{
my $safe = new Safe;
# because of opcodes used in "use strict":
$safe->permit(qw(:default require));
local $Storable::Eval = sub { $safe->reval(shift) };
$freezed = freeze $obj[0]->[1];
$@ = "";
eval { $thawed = thaw $freezed };
ok($@, "");
ok($thawed->(), 42);
}
{
{
package MySafe;
sub new { bless {}, shift }
sub reval {
my $source = $_[1];
# Here you can apply some nifty regexpes to ensure the
# safeness of the source code.
my $coderef = eval $source;
$coderef;
}
}
my $safe = new MySafe;
local $Storable::Eval = sub { $safe->reval($_[0]) };
$freezed = freeze $obj[0];
eval { $thawed = thaw $freezed };
ok($@, "");
if ($@ ne "") {
ok(0) for (1..5);
} else {
ok($thawed->[0]->(), "JAPH");
ok($thawed->[1]->(), 42);
ok($thawed->[2]->(), "blessed");
ok($thawed->[3]->(), "Another::Package");
ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
}
}
{
# Check internal "seen" code
my $short_sub = sub { "short sub" }; # for SX_SCALAR
# for SX_LSCALAR
my $long_sub_code = 'sub { "' . "x"x255 . '" }';
my $long_sub = eval $long_sub_code; die $@ if $@;
my $sclr = \1;
local $Storable::Deparse = 1;
local $Storable::Eval = 1;
for my $sub ($short_sub, $long_sub) {
my $res;
$res = thaw freeze [$sub, $sub];
ok(int($res->[0]), int($res->[1]));
$res = thaw freeze [$sclr, $sub, $sub, $sclr];
ok(int($res->[0]), int($res->[3]));
ok(int($res->[1]), int($res->[2]));
$res = thaw freeze [$sub, $sub, $sclr, $sclr];
ok(int($res->[0]), int($res->[1]));
ok(int($res->[2]), int($res->[3]));
}
}
--- NEW FILE: make_downgrade.pl ---
#!/usr/local/bin/perl -w
use strict;
use 5.007003;
use Hash::Util qw(lock_hash unlock_hash lock_keys);
use Storable qw(nfreeze);
# If this looks like a hack, it's probably because it is :-)
sub uuencode_it {
my ($data, $name) = @_;
my $frozen = nfreeze $data;
my $uu = pack 'u', $frozen;
printf "begin %3o $name\n", ord 'A';
print $uu;
print "\nend\n\n";
}
my %hash = (perl=>"rules");
lock_hash %hash;
uuencode_it (\%hash, "Locked hash");
unlock_hash %hash;
lock_keys %hash, 'perl', 'rules';
lock_hash %hash;
uuencode_it (\%hash, "Locked hash placeholder");
unlock_hash %hash;
lock_keys %hash, 'perl';
uuencode_it (\%hash, "Locked keys");
unlock_hash %hash;
lock_keys %hash, 'perl', 'rules';
uuencode_it (\%hash, "Locked keys placeholder");
unlock_hash %hash;
my $utf8 = "\x{DF}\x{100}";
chop $utf8;
uuencode_it (\$utf8, "Short 8 bit utf8 data");
my $utf8b = $utf8;
utf8::encode ($utf8b);
uuencode_it (\$utf8b, "Short 8 bit utf8 data as bytes");
$utf8 x= 256;
uuencode_it (\$utf8, "Long 8 bit utf8 data");
$utf8 = "\x{C0FFEE}";
uuencode_it (\$utf8, "Short 24 bit utf8 data");
$utf8b = $utf8;
utf8::encode ($utf8b);
uuencode_it (\$utf8b, "Short 24 bit utf8 data as bytes");
$utf8 x= 256;
uuencode_it (\$utf8, "Long 24 bit utf8 data");
# Hash which has the utf8 bit set, but no longer has any utf8 keys
my %uhash = ("\x{100}", "gone", "perl", "rules");
delete $uhash{"\x{100}"};
# use Devel::Peek; Dump \%uhash;
uuencode_it (\%uhash, "Hash with utf8 flag but no utf8 keys");
$utf8 = "Schlo\xdf" . chr 256;
chop $utf8;
my $a_circumflex = (ord ('A') == 193 ? "\x47" : "\xe5");
%uhash = (map {$_, $_} 'castle', "ch${a_circumflex}teau", $utf8, "\x{57CE}");
uuencode_it (\%uhash, "Hash with utf8 keys");
lock_hash %uhash;
uuencode_it (\%uhash, "Locked hash with utf8 keys");
my (%pre56, %pre58);
while (my ($key, $val) = each %uhash) {
# hash keys are always stored downgraded to bytes if possible, with a flag
# to say "promote back to utf8"
# Whereas scalars are stored as is.
utf8::encode ($key) if ord $key > 256;
$pre58{$key} = $val;
utf8::encode ($val) unless $val eq "ch\xe5teau";
$pre56{$key} = $val;
}
uuencode_it (\%pre56, "Hash with utf8 keys for pre 5.6");
uuencode_it (\%pre58, "Hash with utf8 keys for 5.6");
--- NEW FILE: tied_hook.t ---
#!./perl
#
# 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.
#
sub BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib', '../ext/Storable/t');
} else {
unshift @INC, 't';
}
require Config; import Config;
if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
require '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
--- NEW FILE: tied.t ---
#!./perl
#
# 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.
#
sub BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib', '../ext/Storable/t');
} else {
unshift @INC, 't';
}
require Config; import Config;
if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
require 'st-dump.pl';
}
sub ok;
use Storable qw(freeze thaw);
print "1..23\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;
{
package P;
use Storable qw(freeze thaw);
use vars qw($a $b);
$b = "not ok ";
sub TIESCALAR { bless \$a } sub FETCH { "ok " }
tie $a, P; my $r = thaw freeze \$a; $b = $$r;
print $b , 23, "\n";
}
--- NEW FILE: attach_errors.t ---
#!./perl -w
#
# Copyright 2005, Adam Kennedy.
#
# You may redistribute only under the same terms as Perl 5, as specified
# in the README file that comes with the distribution.
#
# Man, blessed.t scared the hell out of me. For a second there I thought
# I'd lose Test::More...
# This file tests several known-error cases relating to STORABLE_attach, in
# which Storable should (correctly) throw errors.
sub BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib');
} else {
unshift @INC, 't';
}
require Config; import Config;
if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
}
use Test::More tests => 35;
use Storable ();
#####################################################################
# Error 1
#
# Classes that implement STORABLE_thaw _cannot_ have references
# returned by their STORABLE_freeze method. When they do, Storable
# should throw an exception
# Good Case - should not die
{
my $goodfreeze = bless {}, 'My::GoodFreeze';
my $frozen = undef;
eval {
$frozen = Storable::freeze( $goodfreeze );
};
ok( ! $@, 'Storable does not die when STORABLE_freeze does not return references' );
ok( $frozen, 'Storable freezes to a string successfully' );
package My::GoodFreeze;
sub STORABLE_freeze {
my ($self, $clone) = @_;
# Illegally include a reference in this return
return ('');
}
sub STORABLE_attach {
my ($class, $clone, $string) = @_;
return bless { }, 'My::GoodFreeze';
}
}
# Error Case - should die on freeze
{
my $badfreeze = bless {}, 'My::BadFreeze';
eval {
Storable::freeze( $badfreeze );
};
ok( $@, 'Storable dies correctly when STORABLE_freeze returns a referece' );
# Check for a unique substring of the error message
ok( $@ =~ /cannot return references/, 'Storable dies with the expected error' );
package My::BadFreeze;
sub STORABLE_freeze {
my ($self, $clone) = @_;
# Illegally include a reference in this return
return ('', []);
}
sub STORABLE_attach {
my ($class, $clone, $string) = @_;
return bless { }, 'My::BadFreeze';
}
}
#####################################################################
# Error 2
#
# If, for some reason, a STORABLE_attach object is accidentally stored
# with references, this should be checked and and error should be throw.
# Good Case - should not die
{
my $goodthaw = bless {}, 'My::GoodThaw';
my $frozen = undef;
eval {
$frozen = Storable::freeze( $goodthaw );
};
ok( $frozen, 'Storable freezes to a string as expected' );
my $thawed = eval {
Storable::thaw( $frozen );
};
isa_ok( $thawed, 'My::GoodThaw' );
is( $thawed->{foo}, 'bar', 'My::GoodThaw thawed correctly as expected' );
package My::GoodThaw;
sub STORABLE_freeze {
my ($self, $clone) = @_;
return ('');
}
sub STORABLE_attach {
my ($class, $clone, $string) = @_;
return bless { 'foo' => 'bar' }, 'My::GoodThaw';
}
}
# Bad Case - should die on thaw
{
# Create the frozen string normally
my $badthaw = bless { }, 'My::BadThaw';
my $frozen = undef;
eval {
$frozen = Storable::freeze( $badthaw );
};
ok( $frozen, 'BadThaw was frozen with references correctly' );
# Set up the error condition by deleting the normal STORABLE_thaw,
# and creating a STORABLE_attach.
*My::BadThaw::STORABLE_attach = *My::BadThaw::STORABLE_thaw;
*My::BadThaw::STORABLE_attach = *My::BadThaw::STORABLE_thaw; # Suppress a warning
delete ${'My::BadThaw::'}{STORABLE_thaw};
# Trigger the error condition
my $thawed = undef;
eval {
$thawed = Storable::thaw( $frozen );
};
ok( $@, 'My::BadThaw object dies when thawing as expected' );
# Check for a snippet from the error message
ok( $@ =~ /unexpected references/, 'Dies with the expected error message' );
package My::BadThaw;
sub STORABLE_freeze {
my ($self, $clone) = @_;
return ('', []);
}
# Start with no STORABLE_attach method so we can get a
# frozen object-containing-a-reference into the freeze string.
sub STORABLE_thaw {
my ($class, $clone, $string) = @_;
return bless { 'foo' => 'bar' }, 'My::BadThaw';
}
}
#####################################################################
# Error 3
#
# Die if what is returned by STORABLE_attach is not something of that class
# Good Case - should not die
{
my $goodattach = bless { }, 'My::GoodAttach';
my $frozen = Storable::freeze( $goodattach );
ok( $frozen, 'My::GoodAttach return as expected' );
my $thawed = eval {
Storable::thaw( $frozen );
};
isa_ok( $thawed, 'My::GoodAttach' );
is( ref($thawed), 'My::GoodAttach::Subclass',
'The slightly-tricky good "returns a subclass" case returns as expected' );
package My::GoodAttach;
sub STORABLE_freeze {
my ($self, $cloning) = @_;
return ('');
}
sub STORABLE_attach {
my ($class, $cloning, $string) = @_;
return bless { }, 'My::GoodAttach::Subclass';
}
package My::GoodAttach::Subclass;
BEGIN {
@ISA = 'My::GoodAttach';
}
}
# Bad Cases - die on thaw
{
my $returnvalue = undef;
# Create and freeze the object
my $badattach = bless { }, 'My::BadAttach';
my $frozen = Storable::freeze( $badattach );
ok( $frozen, 'BadAttach freezes as expected' );
# Try a number of different return values, all of which
# should cause Storable to die.
my @badthings = (
undef,
'',
1,
[],
{},
\"foo",
(bless { }, 'Foo'),
);
foreach ( @badthings ) {
$returnvalue = $_;
my $thawed = undef;
eval {
$thawed = Storable::thaw( $frozen );
};
ok( $@, 'BadAttach dies on thaw' );
ok( $@ =~ /STORABLE_attach did not return a My::BadAttach object/,
'BadAttach dies on thaw with the expected error message' );
is( $thawed, undef, 'Double checking $thawed was not set' );
}
package My::BadAttach;
sub STORABLE_freeze {
my ($self, $cloning) = @_;
return ('');
}
sub STORABLE_attach {
my ($class, $cloning, $string) = @_;
return $returnvalue;
}
}
--- NEW FILE: utf8.t ---
#!./perl -w
#
# 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.
#
sub BEGIN {
if ($] < 5.006) {
print "1..0 # Skip: no utf8 support\n";
exit 0;
}
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib', '../ext/Storable/t');
} else {
unshift @INC, 't';
}
require Config; import Config;
if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
require 'st-dump.pl';
}
use strict;
sub ok;
use Storable qw(thaw freeze);
print "1..6\n";
my $x = chr(1234);
ok 1, $x eq ${thaw freeze \$x};
# Long scalar
$x = join '', map {chr $_} (0..1023);
ok 2, $x eq ${thaw freeze \$x};
# Char in the range 127-255 (probably) in utf8
$x = chr (175) . chr (256);
chop $x;
ok 3, $x eq ${thaw freeze \$x};
# Storable needs to cope if a frozen string happens to be internall utf8
# encoded
$x = chr 256;
my $data = freeze \$x;
ok 4, $x eq ${thaw $data};
$data .= chr 256;
chop $data;
ok 5, $x eq ${thaw $data};
$data .= chr 256;
# This definately isn't valid
eval {thaw $data};
ok 6, $@ =~ /corrupt.*characters outside/;
--- NEW FILE: forgive.t ---
#!./perl
#
# 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.
#
sub BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib');
} else {
unshift @INC, 't';
}
require Config; import Config;
if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
}
use Storable qw(store retrieve);
# problems with 5.00404 when in an BEGIN block, so this is defined here
if (!eval { require File::Spec; 1 } || $File::Spec::VERSION < 0.8) {
print "1..0 # Skip: File::Spec 0.8 needed\n";
exit 0;
# Mention $File::Spec::VERSION again, as 5.00503's harness seems to have
# warnings on.
exit $File::Spec::VERSION;
}
print "1..8\n";
my $test = 1;
*GLOB = *GLOB; # peacify -w
my $bad = ['foo', \*GLOB, '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' }
--- NEW FILE: store.t ---
#!./perl
#
# 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.
#
sub BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib', '../ext/Storable/t');
} else {
unshift @INC, 't';
}
require Config; import Config;
if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
require '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 or die "Could not close: $!";
END { 1 while unlink 'store' }
--- NEW FILE: recurse.t ---
#!./perl
#
# 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.
#
sub BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib', '../ext/Storable/t');
} else {
unshift @INC, 't';
}
require Config; import Config;
if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
require 'st-dump.pl';
}
sub ok;
use Storable qw(freeze thaw dclone);
print "1..33\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, ref $y eq 'OBJ_REAL';
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 at 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] }
#
# Is the reference count of the extra references returned from a
# STORABLE_freeze hook correct? [ID 20020601.005]
#
package Foo2;
sub new {
my $self = bless {}, $_[0];
$self->{freezed} = "$self";
return $self;
}
sub DESTROY {
my $self = shift;
$::refcount_ok = 1 unless "$self" eq $self->{freezed};
}
package Foo3;
sub new {
bless {}, $_[0];
}
sub STORABLE_freeze {
my $obj = shift;
return ("", $obj, Foo2->new);
}
sub STORABLE_thaw { } # Not really used
package main;
use vars qw($refcount_ok);
my $o = CLASS_OTHER->make();
my $c2 = CLASS_2->make($o);
my $so = thaw freeze $o;
$refcount_ok = 0;
thaw freeze(Foo3->new);
ok 33, $refcount_ok == 1;
--- NEW FILE: HAS_HOOK.pm ---
package HAS_HOOK;
sub STORABLE_thaw {
++$thawed_count;
}
++$loaded_count;
1;
--- NEW FILE: croak.t ---
#!./perl -w
# Please keep this test this simple. (ie just one test.)
# There's some sort of not-croaking properly problem in Storable when built
# with 5.005_03. This test shows it up, whereas malice.t does not.
# In particular, don't use Test; as this covers up the problem.
sub BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib');
}
require Config; import Config;
if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
}
use strict;
BEGIN {
die "Oi! No! Don't change this test so that Carp is used before Storable"
if defined &Carp::carp;
}
use Storable qw(freeze thaw);
print "1..2\n";
for my $test (1,2) {
eval {thaw "\xFF\xFF"};
if ($@ =~ /Storable binary image v127.255 more recent than I am \(v2\.\d+\)/)
{
print "ok $test\n";
} else {
chomp $@;
print "not ok $test # Expected a meaningful croak. Got '$@'\n";
}
}
--- NEW FILE: canonical.t ---
#!./perl
#
# 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.
#
sub BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib');
} else {
unshift @INC, 't';
}
require Config; import Config;
if ($ENV{PERL_CORE} and $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};
--- NEW FILE: testlib.pl ---
#!perl -w
use strict;
use vars '$file';
$file = "storable-testfile.$$";
die "Temporary file '$file' already exists" if -e $file;
END { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }}
use Storable qw (store retrieve freeze thaw nstore nfreeze);
sub slurp {
my $file = shift;
local (*FH, $/);
open FH, "<$file" or die "Can't open '$file': $!";
binmode FH;
my $contents = <FH>;
die "Can't read $file: $!" unless defined $contents;
return $contents;
}
sub store_and_retrieve {
my $data = shift;
unlink $file or die "Can't unlink '$file': $!";
open FH, ">$file" or die "Can't open '$file': $!";
binmode FH;
print FH $data or die "Can't print to '$file': $!";
close FH or die "Can't close '$file': $!";
return eval {retrieve $file};
}
sub freeze_and_thaw {
my $data = shift;
return eval {thaw $data};
}
$file;
--- NEW FILE: st-dump.pl ---
#
# 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.
#
# NOTE THAT THIS FILE IS COPIED FROM ext/Storable/t/st-dump.pl
# TO t/lib/st-dump.pl. One could also play games with
# File::Spec->updir and catdir to get the st-dump.pl in
# ext/Storable into @INC.
sub ok {
my ($num, $ok, $name) = @_;
$num .= " - $name" if defined $name and length $name;
print $ok ? "ok $num\n" : "not ok $num\n";
$ok;
}
sub num_equal {
my ($num, $left, $right, $name) = @_;
my $ok = ((defined $left) ? $left == $right : undef);
unless (ok ($num, $ok, $name)) {
print "# Expected $right\n";
if (!defined $left) {
print "# Got undef\n";
} elsif ($left !~ tr/0-9//c) {
print "# Got $left\n";
} else {
$left =~ s/([^-a-zA-Z0-9_+])/sprintf "\\%03o", ord $1/ge;
print "# Got \"$left\"\n";
}
}
$ok;
}
package dump;
use Carp;
%dump = (
'SCALAR' => 'dump_scalar',
'LVALUE' => 'dump_scalar',
'ARRAY' => 'dump_array',
'HASH' => 'dump_hash',
'REF' => 'dump_ref',
);
# Given an object, dump its transitive data closure
sub main'dump {
my ($object) = @_;
croak "Not a reference!" unless ref($object);
local %dumped;
local %object;
local $count = 0;
local $dumped = '';
&recursive_dump($object, 1);
return $dumped;
}
# This is the root recursive dumping routine that may indirectly be
# called by one of the routine it calls...
# The link parameter is set to false when the reference passed to
# the routine is an internal temporay variable, implying the object's
# address is not to be dumped in the %dumped table since it's not a
# user-visible object.
sub recursive_dump {
my ($object, $link) = @_;
# Get something like SCALAR(0x...) or TYPE=SCALAR(0x...).
# Then extract the bless, ref and address parts of that string.
my $what = "$object"; # Stringify
my ($bless, $ref, $addr) = $what =~ /^(\w+)=(\w+)\((0x.*)\)$/;
($ref, $addr) = $what =~ /^(\w+)\((0x.*)\)$/ unless $bless;
# Special case for references to references. When stringified,
# they appear as being scalars. However, ref() correctly pinpoints
# them as being references indirections. And that's it.
$ref = 'REF' if ref($object) eq 'REF';
# Make sure the object has not been already dumped before.
# We don't want to duplicate data. Retrieval will know how to
# relink from the previously seen object.
if ($link && $dumped{$addr}++) {
my $num = $object{$addr};
$dumped .= "OBJECT #$num seen\n";
return;
}
my $objcount = $count++;
$object{$addr} = $objcount;
# Call the appropriate dumping routine based on the reference type.
# If the referenced was blessed, we bless it once the object is dumped.
# The retrieval code will perform the same on the last object retrieved.
croak "Unknown simple type '$ref'" unless defined $dump{$ref};
&{$dump{$ref}}($object); # Dump object
&bless($bless) if $bless; # Mark it as blessed, if necessary
$dumped .= "OBJECT $objcount\n";
}
# Indicate that current object is blessed
sub bless {
my ($class) = @_;
$dumped .= "BLESS $class\n";
}
# Dump single scalar
sub dump_scalar {
my ($sref) = @_;
my $scalar = $$sref;
unless (defined $scalar) {
$dumped .= "UNDEF\n";
return;
}
my $len = length($scalar);
$dumped .= "SCALAR len=$len $scalar\n";
}
# Dump array
sub dump_array {
my ($aref) = @_;
my $items = 0 + @{$aref};
$dumped .= "ARRAY items=$items\n";
foreach $item (@{$aref}) {
unless (defined $item) {
$dumped .= 'ITEM_UNDEF' . "\n";
next;
}
$dumped .= 'ITEM ';
&recursive_dump(\$item, 1);
}
}
# Dump hash table
sub dump_hash {
my ($href) = @_;
my $items = scalar(keys %{$href});
$dumped .= "HASH items=$items\n";
foreach $key (sort keys %{$href}) {
$dumped .= 'KEY ';
&recursive_dump(\$key, undef);
unless (defined $href->{$key}) {
$dumped .= 'VALUE_UNDEF' . "\n";
next;
}
$dumped .= 'VALUE ';
&recursive_dump(\$href->{$key}, 1);
}
}
# Dump reference to reference
sub dump_ref {
my ($rref) = @_;
my $deref = $$rref; # Follow reference to reference
$dumped .= 'REF ';
&recursive_dump($deref, 1); # $dref is a reference
}
1;
--- NEW FILE: utf8hash.t ---
#!./perl
sub BEGIN {
if ($] < 5.007) {
print "1..0 # Skip: no utf8 hash key support\n";
exit 0;
}
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib');
if ($^O eq 'MacOS') {
# Look, I'm using this fully-qualified variable more than once!
my $arch = $MacPerl::Architecture;
push @INC, "::lib:${MacPerl::Architecture}:";
}
} else {
unshift @INC, 't';
}
require Config; import Config;
if ($ENV{PERL_CORE}){
if($Config{'extensions'} !~ /\bStorable\b/) {
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
}
}
use strict;
our $DEBUGME = shift || 0;
use Storable qw(store nstore retrieve thaw freeze);
{
no warnings;
$Storable::DEBUGME = ($DEBUGME > 1);
}
# Better than no plan, because I was getting out of memory errors, at which
# point Test::More tidily prints up 1..79 as if I meant to finish there.
use Test::More tests=>148;
use bytes ();
my %utf8hash;
$Storable::canonical = $Storable::canonical; # Shut up a used only once warning.
for $Storable::canonical (0, 1) {
# first we generate a nasty hash which keys include both utf8
# on and off with identical PVs
no utf8; # we have a naked 8-bit byte below (in Latin 1, anyway)
# In Latin 1 -ese the below ord() should end up 0xc0 (192),
# in EBCDIC 0x64 (100). Both should end up being UTF-8/UTF-EBCDIC.
my @ords = (
ord("Á"), # LATIN CAPITAL LETTER A WITH GRAVE
0x3000, #IDEOGRAPHIC SPACE
);
foreach my $i (@ords){
my $u = chr($i); utf8::upgrade($u);
# warn sprintf "%d,%d", bytes::length($u), is_utf8($u);
my $b = pack("C*", unpack("C*", $u));
# warn sprintf "%d,%d" ,bytes::length($b), is_utf8($b);
isnt($u, $b,
"equivalence - with utf8flag");
is (pack("C*", unpack("C*", $u)), pack("C*", unpack("C*", $b)),
"equivalence - without utf8flag");
$utf8hash{$u} = $utf8hash{$b} = $i;
}
sub nkeys($){
my $href = shift;
return scalar keys %$href;
}
my $nk;
is($nk = nkeys(\%utf8hash), scalar(@ords)*2,
"nasty hash generated (nkeys=$nk)");
# now let the show begin!
my $thawed = thaw(freeze(\%utf8hash));
is($nk = nkeys($thawed),
nkeys(\%utf8hash),
"scalar keys \%{\$thawed} (nkeys=$nk)");
for my $k (sort keys %$thawed){
is($utf8hash{$k}, $thawed->{$k}, "frozen item chr($utf8hash{$k})");
}
my $storage = "utfhash.po"; # po = perl object!
my $retrieved;
ok((nstore \%utf8hash, $storage), "nstore to $storage");
ok(($retrieved = retrieve($storage)), "retrieve from $storage");
is($nk = nkeys($retrieved),
nkeys(\%utf8hash),
"scalar keys \%{\$retrieved} (nkeys=$nk)");
for my $k (sort keys %$retrieved){
is($utf8hash{$k}, $retrieved->{$k}, "nstored item chr($utf8hash{$k})");
}
unlink $storage;
ok((store \%utf8hash, $storage), "store to $storage");
ok(($retrieved = retrieve($storage)), "retrieve from $storage");
is($nk = nkeys($retrieved),
nkeys(\%utf8hash),
"scalar keys \%{\$retrieved} (nkeys=$nk)");
for my $k (sort keys %$retrieved){
is($utf8hash{$k}, $retrieved->{$k}, "stored item chr($utf8hash{$k})");
}
$DEBUGME or unlink $storage;
# On the premis that more tests are good, here are NWC's tests:
package Hash_Test;
sub me_second {
return (undef, $_[0]);
}
package main;
my $utf8 = "Schlo\xdf" . chr 256;
chop $utf8;
# Set this to 1 to test the test by bypassing Storable.
my $bypass = 0;
sub class_test {
my ($object, $package) = @_;
unless ($package) {
is ref $object, 'HASH', "$object is unblessed";
return;
}
isa_ok ($object, $package);
my ($garbage, $copy) = eval {$object->me_second};
is $@, "", "check it has correct method";
cmp_ok $copy, '==', $object, "and that it returns the same object";
}
# Thanks to Dan Kogai for the Kanji for "castle" (which he informs me also
# means 'a city' in Mandarin).
my %hash = (map {$_, $_} 'castle', "ch\xe5teau", $utf8, "\x{57CE}");
for my $package ('', 'Hash_Test') {
# Run through and sanity check these.
if ($package) {
bless \%hash, $package;
}
for (keys %hash) {
my $l = 0 + /^\w+$/;
my $r = 0 + $hash{$_} =~ /^\w+$/;
cmp_ok ($l, '==', $r);
}
# Grr. This cperl mode thinks that ${ is a punctuation variable.
# I presume it's punishment for using xemacs rather than emacs. Or OS/2 :-)
my $copy = $bypass ? \%hash : ${thaw freeze \\%hash};
class_test ($copy, $package);
for (keys %$copy) {
my $l = 0 + /^\w+$/;
my $r = 0 + $copy->{$_} =~ /^\w+$/;
cmp_ok ($l, '==', $r, sprintf "key length %d", length $_);
}
my $bytes = my $char = chr 27182;
utf8::encode ($bytes);
my $orig = {$char => 1};
if ($package) {
bless $orig, $package;
}
my $just_utf8 = $bypass ? $orig : ${thaw freeze \$orig};
class_test ($just_utf8, $package);
cmp_ok (scalar keys %$just_utf8, '==', 1, "1 key in utf8?");
cmp_ok ($just_utf8->{$char}, '==', 1, "utf8 key present?");
ok (!exists $just_utf8->{$bytes}, "bytes key absent?");
$orig = {$bytes => 1};
if ($package) {
bless $orig, $package;
}
my $just_bytes = $bypass ? $orig : ${thaw freeze \$orig};
class_test ($just_bytes, $package);
cmp_ok (scalar keys %$just_bytes, '==', 1, "1 key in bytes?");
cmp_ok ($just_bytes->{$bytes}, '==', 1, "bytes key present?");
ok (!exists $just_bytes->{$char}, "utf8 key absent?");
die sprintf "Both have length %d, which is crazy", length $char
if length $char == length $bytes;
$orig = {$bytes => length $bytes, $char => length $char};
if ($package) {
bless $orig, $package;
}
my $both = $bypass ? $orig : ${thaw freeze \$orig};
class_test ($both, $package);
cmp_ok (scalar keys %$both, '==', 2, "2 keys?");
cmp_ok ($both->{$bytes}, '==', length $bytes, "bytes key present?");
cmp_ok ($both->{$char}, '==', length $char, "utf8 key present?");
}
}
--- NEW FILE: restrict.t ---
#!./perl -w
#
# Copyright 2002, Larry Wall.
#
# You may redistribute only under the same terms as Perl 5, as specified
# in the README file that comes with the distribution.
#
sub BEGIN {
chdir('t') if -d 't';
if ($ENV{PERL_CORE}){
@INC = ('.', '../lib', '../ext/Storable/t');
require Config;
if ($Config::Config{'extensions'} !~ /\bStorable\b/) {
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
} else {
if ($] < 5.005) {
print "1..0 # Skip: No Hash::Util pre 5.005\n";
exit 0;
# And doing this seems on 5.004 seems to create bogus warnings about
# unitialized variables, or coredumps in Perl_pp_padsv
} elsif (!eval "require Hash::Util") {
if ($@ =~ /Can\'t locate Hash\/Util\.pm in \@INC/s) {
print "1..0 # Skip: No Hash::Util:\n";
exit 0;
} else {
die;
}
}
unshift @INC, 't';
}
require 'st-dump.pl';
}
use Storable qw(dclone freeze thaw);
use Hash::Util qw(lock_hash unlock_value);
print "1..100\n";
my %hash = (question => '?', answer => 42, extra => 'junk', undef => undef);
lock_hash %hash;
unlock_value %hash, 'answer';
unlock_value %hash, 'extra';
delete $hash{'extra'};
my $test;
package Restrict_Test;
sub me_second {
return (undef, $_[0]);
}
package main;
sub freeze_thaw {
my $temp = freeze $_[0];
return thaw $temp;
}
sub testit {
my $hash = shift;
my $cloner = shift;
my $copy = &$cloner($hash);
my @in_keys = sort keys %$hash;
my @out_keys = sort keys %$copy;
unless (ok ++$test, "@in_keys" eq "@out_keys") {
print "# Failed: keys mis-match after deep clone.\n";
print "# Original keys: @in_keys\n";
print "# Copy's keys: @out_keys\n";
}
# $copy = $hash; # used in initial debug of the tests
ok ++$test, Internals::SvREADONLY(%$copy), "cloned hash restricted?";
ok ++$test, Internals::SvREADONLY($copy->{question}),
"key 'question' not locked in copy?";
ok ++$test, !Internals::SvREADONLY($copy->{answer}),
"key 'answer' not locked in copy?";
eval { $copy->{extra} = 15 } ;
unless (ok ++$test, !$@, "Can assign to reserved key 'extra'?") {
my $diag = $@;
$diag =~ s/\n.*\z//s;
print "# \$\@: $diag\n";
}
eval { $copy->{nono} = 7 } ;
ok ++$test, $@, "Can not assign to invalid key 'nono'?";
ok ++$test, exists $copy->{undef},
"key 'undef' exists";
ok ++$test, !defined $copy->{undef},
"value for key 'undef' is undefined";
}
for $Storable::canonical (0, 1) {
for my $cloner (\&dclone, \&freeze_thaw) {
print "# \$Storable::canonical = $Storable::canonical\n";
testit (\%hash, $cloner);
my $object = \%hash;
# bless {}, "Restrict_Test";
my %hash2;
$hash2{"k$_"} = "v$_" for 0..16;
lock_hash %hash2;
for (0..16) {
unlock_value %hash2, "k$_";
delete $hash2{"k$_"};
}
my $copy = &$cloner(\%hash2);
for (0..16) {
my $k = "k$_";
eval { $copy->{$k} = undef } ;
unless (ok ++$test, !$@, "Can assign to reserved key '$k'?") {
my $diag = $@;
$diag =~ s/\n.*\z//s;
print "# \$\@: $diag\n";
}
}
}
}
--- NEW FILE: just_plain_nasty.t ---
#!/usr/bin/perl
# This is a test suite to cover all the nasty and horrible data
# structures that cause bizarre corner cases.
# Everyone's invited! :-D
sub BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib');
} else {
unshift @INC, 't';
}
require Config; import Config;
if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
}
use strict;
BEGIN {
if (!eval q{
use Test;
use B::Deparse 0.61;
use 5.006;
1;
}) {
print "1..0 # skip: tests only work with B::Deparse 0.61 and at least perl 5.6.0\n";
exit;
}
require File::Spec;
if ($File::Spec::VERSION < 0.8) {
print "1..0 # Skip: newer File::Spec needed\n";
exit 0;
}
}
use Storable qw(freeze thaw);
#$Storable::DEBUGME = 1;
BEGIN {
plan tests => 34;
}
{
package Banana;
use overload
'<=>' => \&compare,
'==' => \&equal,
'""' => \&real,
fallback => 1;
sub compare { return int(rand(3))-1 };
sub equal { return 1 if rand(1) > 0.5 }
sub real { return "keep it so" }
}
my (@a);
for my $dbun (1, 0) { # dbun - don't be utterly nasty - being utterly
# nasty means having a reference to the object
# directly within itself. otherwise it's in the
# second array.
my $nasty = [
($a[0] = bless [ ], "Banana"),
($a[1] = [ ]),
];
$a[$dbun]->[0] = $a[0];
ok(ref($nasty), "ARRAY", "Sanity found (now to play with it :->)");
$Storable::Deparse = $Storable::Deparse = 1;
$Storable::Eval = $Storable::Eval = 1;
headit("circular overload 1 - freeze");
my $icicle = freeze $nasty;
#print $icicle; # cat -ve recommended :)
headit("circular overload 1 - thaw");
my $oh_dear = thaw $icicle;
ok(ref($oh_dear), "ARRAY", "dclone - circular overload");
ok($oh_dear->[0], "keep it so", "amagic ok 1");
ok($oh_dear->[$dbun]->[0], "keep it so", "amagic ok 2");
headit("closure dclone - freeze");
$icicle = freeze sub { "two" };
#print $icicle;
headit("closure dclone - thaw");
my $sub2 = thaw $icicle;
ok($sub2->(), "two", "closures getting dcloned OK");
headit("circular overload, after closure - freeze");
#use Data::Dumper;
#print Dumper $nasty;
$icicle = freeze $nasty;
#print $icicle;
headit("circular overload, after closure - thaw");
$oh_dear = thaw $icicle;
ok(ref($oh_dear), "ARRAY", "dclone - after a closure dclone");
ok($oh_dear->[0], "keep it so", "amagic ok 1");
ok($oh_dear->[$dbun]->[0], "keep it so", "amagic ok 2");
push @{$nasty}, sub { print "Goodbye, cruel world.\n" };
headit("closure freeze AFTER circular overload");
#print Dumper $nasty;
$icicle = freeze $nasty;
#print $icicle;
headit("circular thaw AFTER circular overload");
$oh_dear = thaw $icicle;
ok(ref($oh_dear), "ARRAY", "dclone - before a closure dclone");
ok($oh_dear->[0], "keep it so", "amagic ok 1");
ok($oh_dear->[$dbun]->[0], "keep it so", "amagic ok 2");
@{$nasty} = @{$nasty}[0, 2, 1];
headit("closure freeze BETWEEN circular overload");
#print Dumper $nasty;
$icicle = freeze $nasty;
#print $icicle;
headit("circular thaw BETWEEN circular overload");
$oh_dear = thaw $icicle;
ok(ref($oh_dear), "ARRAY", "dclone - between a closure dclone");
ok($oh_dear->[0], "keep it so", "amagic ok 1");
ok($oh_dear->[$dbun?2:0]->[0], "keep it so", "amagic ok 2");
@{$nasty} = @{$nasty}[1, 0, 2];
headit("closure freeze BEFORE circular overload");
#print Dumper $nasty;
$icicle = freeze $nasty;
#print $icicle;
headit("circular thaw BEFORE circular overload");
$oh_dear = thaw $icicle;
ok(ref($oh_dear), "ARRAY", "dclone - after a closure dclone");
ok($oh_dear->[1], "keep it so", "amagic ok 1");
ok($oh_dear->[$dbun+1]->[0], "keep it so", "amagic ok 2");
}
sub headit {
return; # comment out to get headings - useful for scanning
# output with $Storable::DEBUGME = 1
my $title = shift;
my $size_left = (66 - length($title)) >> 1;
my $size_right = (67 - length($title)) >> 1;
print "# ".("-" x $size_left). " $title "
.("-" x $size_right)."\n";
}
--- NEW FILE: malice.t ---
#!./perl -w
#
# Copyright 2002, Larry Wall.
#
# You may redistribute only under the same terms as Perl 5, as specified
# in the README file that comes with the distribution.
#
# I'm trying to keep this test easily backwards compatible to 5.004, so no
# qr//;
# This test tries to craft malicious data to test out as many different
# error traps in Storable as possible
# It also acts as a test for read_header
sub BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib', '../ext/Storable/t');
} else {
# This lets us distribute Test::More in t/
unshift @INC, 't';
}
require Config; import Config;
if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
}
use strict;
use vars qw($file_magic_str $other_magic $network_magic $byteorder
$major $minor $minor_write $fancy);
$byteorder = $Config{byteorder};
$file_magic_str = 'pst0';
$other_magic = 7 + length $byteorder;
$network_magic = 2;
$major = 2;
$minor = 7;
$minor_write = $] > 5.005_50 ? 7 : 4;
use Test::More;
# If it's 5.7.3 or later the hash will be stored with flags, which is
# 2 extra bytes. There are 2 * 2 * 2 tests per byte in the body and header
# common to normal and network order serialised objects (hence the 8)
# There are only 2 * 2 tests per byte in the parts of the header not present
# for network order, and 2 tests per byte on the 'pst0' "magic number" only
# present in files, but not in things store()ed to memory
$fancy = ($] > 5.007 ? 2 : 0);
plan tests => 368 + length ($byteorder) * 4 + $fancy * 8 + 1;
use Storable qw (store retrieve freeze thaw nstore nfreeze);
require 'testlib.pl';
use vars '$file';
# The chr 256 is a hack to force the hash to always have the utf8 keys flag
# set on 5.7.3 and later. Otherwise the test fails if run with -Mutf8 because
# only there does the hash has the flag on, and hence only there is it stored
# as a flagged hash, which is 2 bytes longer
my %hash = (perl => 'rules', chr 256, '');
delete $hash{chr 256};
sub test_hash {
my $clone = shift;
is (ref $clone, "HASH", "Get hash back");
is (scalar keys %$clone, 1, "with 1 key");
is ((keys %$clone)[0], "perl", "which is correct");
is ($clone->{perl}, "rules");
}
sub test_header {
my ($header, $isfile, $isnetorder) = @_;
is (!!$header->{file}, !!$isfile, "is file");
is ($header->{major}, $major, "major number");
is ($header->{minor}, $minor_write, "minor number");
is (!!$header->{netorder}, !!$isnetorder, "is network order");
if ($isnetorder) {
# Network order header has no sizes
} else {
is ($header->{byteorder}, $byteorder, "byte order");
is ($header->{intsize}, $Config{intsize}, "int size");
is ($header->{longsize}, $Config{longsize}, "long size");
SKIP: {
skip ("No \$Config{prtsize} on this perl version ($])", 1)
unless defined $Config{ptrsize};
is ($header->{ptrsize}, $Config{ptrsize}, "long size");
}
is ($header->{nvsize}, $Config{nvsize} || $Config{doublesize} || 8,
"nv size"); # 5.00405 doesn't even have doublesize in config.
}
}
sub test_truncated {
my ($data, $sub, $magic_len, $what) = @_;
for my $i (0 .. length ($data) - 1) {
my $short = substr $data, 0, $i;
# local $Storable::DEBUGME = 1;
my $clone = &$sub($short);
is (defined ($clone), '', "truncated $what to $i should fail");
if ($i < $magic_len) {
like ($@, "/^Magic number checking on storable $what failed/",
"Should croak with magic number warning");
} else {
is ($@, "", "Should not set \$\@");
}
}
}
sub test_corrupt {
my ($data, $sub, $what, $name) = @_;
my $clone = &$sub($data);
is (defined ($clone), '', "$name $what should fail");
like ($@, $what, $name);
}
sub test_things {
my ($contents, $sub, $what, $isnetwork) = @_;
my $isfile = $what eq 'file';
my $file_magic = $isfile ? length $file_magic_str : 0;
my $header = Storable::read_magic ($contents);
test_header ($header, $isfile, $isnetwork);
# Test that if we re-write it, everything still works:
my $clone = &$sub ($contents);
is ($@, "", "There should be no error");
test_hash ($clone);
# Now lets check the short version:
test_truncated ($contents, $sub, $file_magic
+ ($isnetwork ? $network_magic : $other_magic), $what);
my $copy;
if ($isfile) {
$copy = $contents;
substr ($copy, 0, 4) = 'iron';
test_corrupt ($copy, $sub, "/^File is not a perl storable/",
"magic number");
}
$copy = $contents;
# Needs to be more than 1, as we're already coding a spread of 1 minor version
# number on writes (2.5, 2.4). May increase to 2 if we figure we can do 2.3
# on 5.005_03 (No utf8).
# 4 allows for a small safety margin
# (Joke:
# Question: What is the value of pi?
# Mathematician answers "It's pi, isn't it"
# Physicist answers "3.1, within experimental error"
# Engineer answers "Well, allowing for a small safety margin, 18"
# )
my $minor4 = $header->{minor} + 4;
substr ($copy, $file_magic + 1, 1) = chr $minor4;
{
# Now by default newer minor version numbers are not a pain.
$clone = &$sub($copy);
is ($@, "", "by default no error on higher minor");
test_hash ($clone);
local $Storable::accept_future_minor = 0;
test_corrupt ($copy, $sub,
"/^Storable binary image v$header->{major}\.$minor4 more recent than I am \\(v$header->{major}\.$minor\\)/",
"higher minor");
}
$copy = $contents;
my $major1 = $header->{major} + 1;
substr ($copy, $file_magic, 1) = chr 2*$major1;
test_corrupt ($copy, $sub,
"/^Storable binary image v$major1\.$header->{minor} more recent than I am \\(v$header->{major}\.$minor\\)/",
"higher major");
# Continue messing with the previous copy
my $minor1 = $header->{minor} - 1;
substr ($copy, $file_magic + 1, 1) = chr $minor1;
test_corrupt ($copy, $sub,
"/^Storable binary image v$major1\.$minor1 more recent than I am \\(v$header->{major}\.$minor\\)/",
"higher major, lower minor");
my $where;
if (!$isnetwork) {
# All these are omitted from the network order header.
# I'm not sure if it's correct to omit the byte size stuff.
$copy = $contents;
substr ($copy, $file_magic + 3, length $header->{byteorder})
= reverse $header->{byteorder};
test_corrupt ($copy, $sub, "/^Byte order is not compatible/",
"byte order");
$where = $file_magic + 3 + length $header->{byteorder};
foreach (['intsize', "Integer"],
['longsize', "Long integer"],
['ptrsize', "Pointer"],
['nvsize', "Double"]) {
my ($key, $name) = @$_;
$copy = $contents;
substr ($copy, $where++, 1) = chr 0;
test_corrupt ($copy, $sub, "/^$name size is not compatible/",
"$name size");
}
} else {
$where = $file_magic + $network_magic;
}
# Just the header and a tag 255. As 28 is currently the highest tag, this
# is "unexpected"
$copy = substr ($contents, 0, $where) . chr 255;
test_corrupt ($copy, $sub,
"/^Corrupted storable $what \\(binary v$header->{major}.$header->{minor}\\)/",
"bogus tag");
# Now drop the minor version number
substr ($copy, $file_magic + 1, 1) = chr $minor1;
test_corrupt ($copy, $sub,
"/^Corrupted storable $what \\(binary v$header->{major}.$minor1\\)/",
"bogus tag, minor less 1");
# Now increase the minor version number
substr ($copy, $file_magic + 1, 1) = chr $minor4;
# local $Storable::DEBUGME = 1;
# This is the delayed croak
test_corrupt ($copy, $sub,
"/^Storable binary image v$header->{major}.$minor4 contains data of type 255. This Storable is v$header->{major}.$minor and can only handle data types up to 28/",
"bogus tag, minor plus 4");
# And check again that this croak is not delayed:
{
# local $Storable::DEBUGME = 1;
local $Storable::accept_future_minor = 0;
test_corrupt ($copy, $sub,
"/^Storable binary image v$header->{major}\.$minor4 more recent than I am \\(v$header->{major}\.$minor\\)/",
"higher minor");
}
}
ok (defined store(\%hash, $file));
my $expected = 20 + length ($file_magic_str) + $other_magic + $fancy;
my $length = -s $file;
die "Don't seem to have written file '$file' as I can't get its length: $!"
unless defined $file;
die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length"
unless $length == $expected;
# Read the contents into memory:
my $contents = slurp ($file);
# Test the original direct from disk
my $clone = retrieve $file;
test_hash ($clone);
# Then test it.
test_things($contents, \&store_and_retrieve, 'file');
# And now try almost everything again with a Storable string
my $stored = freeze \%hash;
test_things($stored, \&freeze_and_thaw, 'string');
# Network order.
unlink $file or die "Can't unlink '$file': $!";
ok (defined nstore(\%hash, $file));
$expected = 20 + length ($file_magic_str) + $network_magic + $fancy;
$length = -s $file;
die "Don't seem to have written file '$file' as I can't get its length: $!"
unless defined $file;
die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length"
unless $length == $expected;
# Read the contents into memory:
$contents = slurp ($file);
# Test the original direct from disk
$clone = retrieve $file;
test_hash ($clone);
# Then test it.
test_things($contents, \&store_and_retrieve, 'file', 1);
# And now try almost everything again with a Storable string
$stored = nfreeze \%hash;
test_things($stored, \&freeze_and_thaw, 'string', 1);
# Test that the bug fixed by #20587 doesn't affect us under some older
# Perl. AMS 20030901
{
chop(my $a = chr(0xDF).chr(256));
my %a = (chr(0xDF) => 1);
$a{$a}++;
freeze \%a;
# If we were built with -DDEBUGGING, the assert() should have killed
# us, which will probably alert the user that something went wrong.
ok(1);
}
--- NEW FILE: attach_singleton.t ---
#!./perl -w
#
# Copyright 2005, Adam Kennedy.
#
# You may redistribute only under the same terms as Perl 5, as specified
# in the README file that comes with the distribution.
#
# Tests freezing/thawing structures containing Singleton objects,
# which should see both structs pointing to the same object.
sub BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib');
} else {
unshift @INC, 't';
}
require Config; import Config;
if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
}
use Test::More tests => 11;
use Storable ();
# Get the singleton
my $object = My::Singleton->new;
isa_ok( $object, 'My::Singleton' );
# Confirm (for the record) that the class is actually a Singleton
my $object2 = My::Singleton->new;
isa_ok( $object2, 'My::Singleton' );
is( "$object", "$object2", 'Class is a singleton' );
############
# Main Tests
my $struct = [ 1, $object, 3 ];
# Freeze the struct
my $frozen = Storable::freeze( $struct );
ok( (defined($frozen) and ! ref($frozen) and length($frozen)), 'freeze returns a string' );
# Thaw the struct
my $thawed = Storable::thaw( $frozen );
# Now it should look exactly like the original
is_deeply( $struct, $thawed, 'Struct superficially looks like the original' );
# ... EXCEPT that the Singleton should be the same instance of the object
is( "$struct->[1]", "$thawed->[1]", 'Singleton thaws correctly' );
# We can also test this empirically
$struct->[1]->{value} = 'Goodbye cruel world!';
is_deeply( $struct, $thawed, 'Empiric testing corfirms correct behaviour' );
# End Tests
###########
package My::Singleton;
my $SINGLETON = undef;
sub new {
$SINGLETON or
$SINGLETON = bless { value => 'Hello World!' }, $_[0];
}
sub STORABLE_freeze {
my $self = shift;
# We don't actually need to return anything, but provide a null string
# to avoid the null-list-return behaviour.
return ('foo');
}
sub STORABLE_attach {
my ($class, $clone, $string) = @_;
Test::More::ok( ! ref $class, 'STORABLE_attach passed class, and not an object' );
Test::More::is( $class, 'My::Singleton', 'STORABLE_attach is passed the correct class name' );
Test::More::is( $clone, 0, 'We are not in a dclone' );
Test::More::is( $string, 'foo', 'STORABLE_attach gets the string back' );
# Get the Singleton object and return it
return $class->new;
}
--- NEW FILE: HAS_ATTACH.pm ---
package HAS_ATTACH;
sub STORABLE_attach {
++$attached_count;
return bless [], 'HAS_ATTACH';
}
++$loaded_count;
1;
--- NEW FILE: circular_hook.t ---
#!./perl -w
#
# Copyright 2005, Adam Kennedy.
#
# You may redistribute only under the same terms as Perl 5, as specified
# in the README file that comes with the distribution.
#
# Man, blessed.t scared the hell out of me. For a second there I thought
# I'd lose Test::More...
# This file tests several known-error cases relating to STORABLE_attach, in
# which Storable should (correctly) throw errors.
sub BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib');
} else {
unshift @INC, 't';
}
require Config; import Config;
if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
}
use Storable ();
use Test::More tests => 9;
my $ddd = bless { }, 'Foo';
my $eee = bless { Bar => $ddd }, 'Bar';
$ddd->{Foo} = $eee;
my $array = [ $ddd ];
my $string = Storable::freeze( $array );
my $thawed = Storable::thaw( $string );
# is_deeply infinite loops in ciculars, so do it manually
# is_deeply( $array, $thawed, 'Circular hooked objects work' );
is( ref($thawed), 'ARRAY', 'Top level ARRAY' );
is( scalar(@$thawed), 1, 'ARRAY contains one element' );
isa_ok( $thawed->[0], 'Foo' );
is( scalar(keys %{$thawed->[0]}), 1, 'Foo contains one element' );
isa_ok( $thawed->[0]->{Foo}, 'Bar' );
is( scalar(keys %{$thawed->[0]->{Foo}}), 1, 'Bar contains one element' );
isa_ok( $thawed->[0]->{Foo}->{Bar}, 'Foo' );
is( $thawed->[0], $thawed->[0]->{Foo}->{Bar}, 'Circular is... well... circular' );
# Make sure the thawing went the way we expected
is_deeply( \@Foo::order, [ 'Bar', 'Foo' ], 'thaw order is correct (depth first)' );
package Foo;
@order = ();
sub STORABLE_freeze {
my ($self, $clone) = @_;
my $class = ref $self;
# print "# Freezing $class\n";
return ($class, $self->{$class});
}
sub STORABLE_thaw {
my ($self, $clone, $string, @refs) = @_;
my $class = ref $self;
# print "# Thawing $class\n";
$self->{$class} = shift @refs;
push @order, $class;
return;
}
package Bar;
BEGIN {
@ISA = 'Foo';
}
1;
--- NEW FILE: retrieve.t ---
#!./perl
#
# 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.
#
sub BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib', '../ext/Storable/t');
} else {
unshift @INC, 't';
}
require Config; import Config;
if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
require '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') }
--- NEW FILE: integer.t ---
#!./perl -w
#
# Copyright 2002, Larry Wall.
#
# You may redistribute only under the same terms as Perl 5, as specified
# in the README file that comes with the distribution.
#
# I ought to keep this test easily backwards compatible to 5.004, so no
# qr//;
# This test checks downgrade behaviour on pre-5.8 perls when new 5.8 features
# are encountered.
sub BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib');
} else {
unshift @INC, 't';
}
require Config; import Config;
if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
}
use Test::More;
use Storable qw (dclone store retrieve freeze thaw nstore nfreeze);
use strict;
my $max_uv = ~0;
my $max_uv_m1 = ~0 ^ 1;
# Express it in this way so as not to use any addition, as 5.6 maths would
# do this in NVs on 64 bit machines, and we're overflowing IVs so can't use
# use integer.
my $max_iv_p1 = $max_uv ^ ($max_uv >> 1);
my $lots_of_9C = do {
my $temp = sprintf "%#x", ~0;
$temp =~ s/ff/9c/g;
local $^W;
eval $temp;
};
my $max_iv = ~0 >> 1;
my $min_iv = do {use integer; -$max_iv-1}; # 2s complement assumption
my @processes = (["dclone", \&do_clone],
["freeze/thaw", \&freeze_and_thaw],
["nfreeze/thaw", \&nfreeze_and_thaw],
["store/retrieve", \&store_and_retrieve],
["nstore/retrieve", \&nstore_and_retrieve],
);
my @numbers =
(# IV bounds of 8 bits
-1, 0, 1, -127, -128, -129, 42, 126, 127, 128, 129, 254, 255, 256, 257,
# IV bounds of 32 bits
-2147483647, -2147483648, -2147483649, 2147483646, 2147483647, 2147483648,
# IV bounds
$min_iv, do {use integer; $min_iv + 1}, do {use integer; $max_iv - 1},
$max_iv,
# UV bounds at 32 bits
0x7FFFFFFF, 0x80000000, 0x80000001, 0xFFFFFFFF, 0xDEADBEEF,
# UV bounds
$max_iv_p1, $max_uv_m1, $max_uv, $lots_of_9C,
# NV-UV conversion
2559831922.0,
);
plan tests => @processes * @numbers * 5;
my $file = "integer.$$";
die "Temporary file '$file' already exists" if -e $file;
END { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }}
sub do_clone {
my $data = shift;
my $copy = eval {dclone $data};
is ($@, '', 'Should be no error dcloning');
ok (1, "dlcone is only 1 process, not 2");
return $copy;
}
sub freeze_and_thaw {
my $data = shift;
my $frozen = eval {freeze $data};
is ($@, '', 'Should be no error freezing');
my $copy = eval {thaw $frozen};
is ($@, '', 'Should be no error thawing');
return $copy;
}
sub nfreeze_and_thaw {
my $data = shift;
my $frozen = eval {nfreeze $data};
is ($@, '', 'Should be no error nfreezing');
my $copy = eval {thaw $frozen};
is ($@, '', 'Should be no error thawing');
return $copy;
}
sub store_and_retrieve {
my $data = shift;
my $frozen = eval {store $data, $file};
is ($@, '', 'Should be no error storing');
my $copy = eval {retrieve $file};
is ($@, '', 'Should be no error retrieving');
return $copy;
}
sub nstore_and_retrieve {
my $data = shift;
my $frozen = eval {nstore $data, $file};
is ($@, '', 'Should be no error storing');
my $copy = eval {retrieve $file};
is ($@, '', 'Should be no error retrieving');
return $copy;
}
foreach (@processes) {
my ($process, $sub) = @$_;
foreach my $number (@numbers) {
# as $number is an alias into @numbers, we don't want any side effects of
# conversion macros affecting later runs, so pass a copy to Storable:
my $copy1 = my $copy2 = my $copy0 = $number;
my $copy_s = &$sub (\$copy0);
if (is (ref $copy_s, "SCALAR", "got back a scalar ref?")) {
# Test inside use integer to see if the bit pattern is identical
# and outside to see if the sign is right.
# On 5.8 we don't need this trickery anymore.
# We really do need 2 copies here, as conversion may have side effect
# bugs. In particular, I know that this happens:
# perl5.00503 -le '$a = "-2147483649"; $a & 0; print $a; print $a+1'
# -2147483649
# 2147483648
my $copy_s1 = my $copy_s2 = $$copy_s;
# On 5.8 can do this with a straight ==, due to the integer/float maths
# on 5.6 can't do this with
# my $eq = do {use integer; $copy_s1 == $copy1} && $copy_s1 == $copy1;
# because on builds with IV as long long it tickles bugs.
# (Uncomment it and the Devel::Peek line below to see the messed up
# state of the scalar, with PV showing the correct string for the
# number, and IV holding a bogus value which has been truncated to 32 bits
# So, check the bit patterns are identical, and check that the sign is the
# same. This works on all the versions in all the sizes.
# $eq = && (($copy_s1 <=> 0) == ($copy1 <=> 0));
# Split this into 2 tests, to cater for 5.005_03
# Aargh. Even this doesn't work because 5.6.x sends values with (same
# number of decimal digits as ~0 + 1) via atof. So ^ is getting strings
# cast to doubles cast to integers. And that truncates low order bits.
# my $bit = ok (($copy_s1 ^ $copy1) == 0, "$process $copy1 (bitpattern)");
# Oh well; at least the parser gets it right. :-)
my $copy_s3 = eval $copy_s1;
die "Was supposed to have number $copy_s3, got error $@"
unless defined $copy_s3;
my $bit = ok (($copy_s3 ^ $copy1) == 0, "$process $copy1 (bitpattern)");
# This is sick. 5.005_03 survives without the IV/UV flag, and somehow
# gets it right, providing you don't have side effects of conversion.
# local $TODO;
# $TODO = "pre 5.6 doesn't have flag to distinguish IV/UV"
# if $[ < 5.005_56 and $copy1 > $max_iv;
my $sign = ok (($copy_s2 <=> 0) == ($copy2 <=> 0),
"$process $copy1 (sign)");
unless ($bit and $sign) {
printf "# Passed in %s (%#x, %i)\n# got back '%s' (%#x, %i)\n",
$copy1, $copy1, $copy1, $copy_s1, $copy_s1, $copy_s1;
# use Devel::Peek; Dump $number; Dump $copy1; Dump $copy_s1;
}
# unless ($bit) { use Devel::Peek; Dump $copy_s1; Dump $$copy_s; }
} else {
fail ("$process $copy1");
fail ("$process $copy1");
}
}
}
--- NEW FILE: freeze.t ---
#!./perl
#
# 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.
#
sub BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib', '../ext/Storable/t');
} else {
unshift @INC, 't';
}
require Config; import Config;
if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
require 'st-dump.pl';
sub ok;
}
use Storable qw(freeze nfreeze thaw);
print "1..20\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";
# Test cleanup bug found by Claudio Garcia -- RAM, 08/06/2001
my $thaw_me = 'asdasdasdasd';
eval {
my $thawed = thaw $thaw_me;
};
ok 16, $@;
my %to_be_frozen = (foo => 'bar');
my $frozen;
eval {
$frozen = freeze \%to_be_frozen;
};
ok 17, !$@;
freeze {};
eval { thaw $thaw_me };
eval { $frozen = freeze { foo => {} } };
ok 18, !$@;
thaw $frozen; # used to segfault here
ok 19, 1;
if ($] >= 5.006) {
eval '
$a = []; $#$a = 2; $a->[1] = undef;
$b = thaw freeze $a;
@a = map { ~~ exists $a->[$_] } 0 .. $#$a;
@b = map { ~~ exists $b->[$_] } 0 .. $#$b;
ok 20, "@a" eq "@b";
';
}
else {
print "ok 20 # skipped (no av_exists)\n";
}
--- NEW FILE: downgrade.t ---
#!./perl -w
#
# Copyright 2002, Larry Wall.
#
# You may redistribute only under the same terms as Perl 5, as specified
# in the README file that comes with the distribution.
#
# I ought to keep this test easily backwards compatible to 5.004, so no
# qr//;
# This test checks downgrade behaviour on pre-5.8 perls when new 5.8 features
# are encountered.
sub BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib');
} else {
unshift @INC, 't';
}
require Config; import Config;
if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
}
use Test::More;
use Storable 'thaw';
use strict;
use vars qw(@RESTRICT_TESTS %R_HASH %U_HASH $UTF8_CROAK $RESTRICTED_CROAK);
@RESTRICT_TESTS = ('Locked hash', 'Locked hash placeholder',
'Locked keys', 'Locked keys placeholder',
);
%R_HASH = (perl => 'rules');
if ($] > 5.007002) {
# This is cheating. "\xdf" in Latin 1 is beta S, so will match \w if it
# is stored in utf8, not bytes.
# "\xdf" is y diaresis in EBCDIC (except for cp875, but so far no-one seems
# to use that) which has exactly the same properties for \w
# So the tests happen to pass.
my $utf8 = "Schlo\xdf" . chr 256;
chop $utf8;
# \xe5 is V in EBCDIC. That doesn't have the same properties w.r.t. \w as
# an a circumflex, so we need to be explicit.
# and its these very properties we're trying to test - an edge case
# involving whether scalars are being stored in bytes or in utf8.
my $a_circumflex = (ord ('A') == 193 ? "\x47" : "\xe5");
%U_HASH = (map {$_, $_} 'castle', "ch${a_circumflex}teau", $utf8, chr 0x57CE);
plan tests => 169;
} elsif ($] >= 5.006) {
plan tests => 59;
} else {
plan tests => 67;
}
$UTF8_CROAK = "/^Cannot retrieve UTF8 data in non-UTF8 perl/";
$RESTRICTED_CROAK = "/^Cannot retrieve restricted hash/";
my %tests;
{
local $/ = "\n\nend\n";
while (<DATA>) {
next unless /\S/s;
unless (/begin ([0-7]{3}) ([^\n]*)\n(.*)$/s) {
s/\n.*//s;
warn "Dodgy data in section starting '$_'";
next;
}
next unless oct $1 == ord 'A'; # Skip ASCII on EBCDIC, and vice versa
my $data = unpack 'u', $3;
$tests{$2} = $data;
}
}
# use Data::Dumper; $Data::Dumper::Useqq = 1; print Dumper \%tests;
sub thaw_hash {
my ($name, $expected) = @_;
my $hash = eval {thaw $tests{$name}};
is ($@, '', "Thawed $name without error?");
isa_ok ($hash, 'HASH');
ok (defined $hash && eq_hash($hash, $expected),
"And it is the hash we expected?");
$hash;
}
sub thaw_scalar {
my ($name, $expected, $bug) = @_;
my $scalar = eval {thaw $tests{$name}};
is ($@, '', "Thawed $name without error?");
isa_ok ($scalar, 'SCALAR', "Thawed $name?");
if ($bug and $] == 5.006) {
# Aargh. <expletive> <expletive> 5.6.0's harness doesn't even honour
# TODO tests.
warn "# Test skipped because eq is buggy for certain Unicode cases in 5.6.0";
warn "# Please upgrade to 5.6.1\n";
ok ("I'd really like to fail this test on 5.6.0 but I'm told that CPAN auto-dependancies mess up, and certain vendors only ship 5.6.0. Get your vendor to ugrade. Else upgrade your vendor.");
# One such vendor being the folks who brought you LONG_MIN as a positive
# integer.
} else {
is ($$scalar, $expected, "And it is the data we expected?");
}
$scalar;
}
sub thaw_fail {
my ($name, $expected) = @_;
my $thing = eval {thaw $tests{$name}};
is ($thing, undef, "Thawed $name failed as expected?");
like ($@, $expected, "Error as predicted?");
}
sub test_locked_hash {
my $hash = shift;
my @keys = keys %$hash;
my ($key, $value) = each %$hash;
eval {$hash->{$key} = reverse $value};
like( $@, "/^Modification of a read-only value attempted/",
'trying to change a locked key' );
is ($hash->{$key}, $value, "hash should not change?");
eval {$hash->{use} = 'perl'};
like( $@, "/^Attempt to access disallowed key 'use' in a restricted hash/",
'trying to add another key' );
ok (eq_array([keys %$hash], \@keys), "Still the same keys?");
}
sub test_restricted_hash {
my $hash = shift;
my @keys = keys %$hash;
my ($key, $value) = each %$hash;
eval {$hash->{$key} = reverse $value};
is( $@, '',
'trying to change a restricted key' );
is ($hash->{$key}, reverse ($value), "hash should change");
eval {$hash->{use} = 'perl'};
like( $@, "/^Attempt to access disallowed key 'use' in a restricted hash/",
'trying to add another key' );
ok (eq_array([keys %$hash], \@keys), "Still the same keys?");
}
sub test_placeholder {
my $hash = shift;
eval {$hash->{rules} = 42};
is ($@, '', 'No errors');
is ($hash->{rules}, 42, "New value added");
}
sub test_newkey {
my $hash = shift;
eval {$hash->{nms} = "http://nms-cgi.sourceforge.net/"};
is ($@, '', 'No errors');
is ($hash->{nms}, "http://nms-cgi.sourceforge.net/", "New value added");
}
# $Storable::DEBUGME = 1;
thaw_hash ('Hash with utf8 flag but no utf8 keys', \%R_HASH);
if (eval "use Hash::Util; 1") {
print "# We have Hash::Util, so test that the restricted hashes in <DATA> are valid\n";
for $Storable::downgrade_restricted (0, 1, undef, "cheese") {
my $hash = thaw_hash ('Locked hash', \%R_HASH);
test_locked_hash ($hash);
$hash = thaw_hash ('Locked hash placeholder', \%R_HASH);
test_locked_hash ($hash);
test_placeholder ($hash);
$hash = thaw_hash ('Locked keys', \%R_HASH);
test_restricted_hash ($hash);
$hash = thaw_hash ('Locked keys placeholder', \%R_HASH);
test_restricted_hash ($hash);
test_placeholder ($hash);
}
} else {
print "# We don't have Hash::Util, so test that the restricted hashes downgrade\n";
my $hash = thaw_hash ('Locked hash', \%R_HASH);
test_newkey ($hash);
$hash = thaw_hash ('Locked hash placeholder', \%R_HASH);
test_newkey ($hash);
$hash = thaw_hash ('Locked keys', \%R_HASH);
test_newkey ($hash);
$hash = thaw_hash ('Locked keys placeholder', \%R_HASH);
test_newkey ($hash);
local $Storable::downgrade_restricted = 0;
thaw_fail ('Locked hash', $RESTRICTED_CROAK);
thaw_fail ('Locked hash placeholder', $RESTRICTED_CROAK);
thaw_fail ('Locked keys', $RESTRICTED_CROAK);
thaw_fail ('Locked keys placeholder', $RESTRICTED_CROAK);
}
if ($] >= 5.006) {
print "# We have utf8 scalars, so test that the utf8 scalars in <DATA> are valid\n";
thaw_scalar ('Short 8 bit utf8 data', "\xDF", 1);
thaw_scalar ('Long 8 bit utf8 data', "\xDF" x 256, 1);
thaw_scalar ('Short 24 bit utf8 data', chr 0xC0FFEE);
thaw_scalar ('Long 24 bit utf8 data', chr (0xC0FFEE) x 256);
} else {
print "# We don't have utf8 scalars, so test that the utf8 scalars downgrade\n";
thaw_fail ('Short 8 bit utf8 data', $UTF8_CROAK);
thaw_fail ('Long 8 bit utf8 data', $UTF8_CROAK);
thaw_fail ('Short 24 bit utf8 data', $UTF8_CROAK);
thaw_fail ('Long 24 bit utf8 data', $UTF8_CROAK);
local $Storable::drop_utf8 = 1;
my $bytes = thaw $tests{'Short 8 bit utf8 data as bytes'};
thaw_scalar ('Short 8 bit utf8 data', $$bytes);
thaw_scalar ('Long 8 bit utf8 data', $$bytes x 256);
$bytes = thaw $tests{'Short 24 bit utf8 data as bytes'};
thaw_scalar ('Short 24 bit utf8 data', $$bytes);
thaw_scalar ('Long 24 bit utf8 data', $$bytes x 256);
}
if ($] > 5.007002) {
print "# We have utf8 hashes, so test that the utf8 hashes in <DATA> are valid\n";
my $hash = thaw_hash ('Hash with utf8 keys', \%U_HASH);
for (keys %$hash) {
my $l = 0 + /^\w+$/;
my $r = 0 + $hash->{$_} =~ /^\w+$/;
cmp_ok ($l, '==', $r, sprintf "key length %d", length $_);
cmp_ok ($l, '==', $_ eq "ch\xe5teau" ? 0 : 1);
}
if (eval "use Hash::Util; 1") {
print "# We have Hash::Util, so test that the restricted utf8 hash is valid\n";
my $hash = thaw_hash ('Locked hash with utf8 keys', \%U_HASH);
for (keys %$hash) {
my $l = 0 + /^\w+$/;
my $r = 0 + $hash->{$_} =~ /^\w+$/;
cmp_ok ($l, '==', $r, sprintf "key length %d", length $_);
cmp_ok ($l, '==', $_ eq "ch\xe5teau" ? 0 : 1);
}
test_locked_hash ($hash);
} else {
print "# We don't have Hash::Util, so test that the utf8 hash downgrades\n";
fail ("You can't get here [perl version $]]. This is a bug in the test.
# Please send the output of perl -V to perlbug\@perl.org");
}
} else {
print "# We don't have utf8 hashes, so test that the utf8 hashes downgrade\n";
thaw_fail ('Hash with utf8 keys', $UTF8_CROAK);
thaw_fail ('Locked hash with utf8 keys', $UTF8_CROAK);
local $Storable::drop_utf8 = 1;
my $what = $] < 5.006 ? 'pre 5.6' : '5.6';
my $expect = thaw $tests{"Hash with utf8 keys for $what"};
thaw_hash ('Hash with utf8 keys', $expect);
#foreach (keys %$expect) { print "'$_':\t'$expect->{$_}'\n"; }
#foreach (keys %$got) { print "'$_':\t'$got->{$_}'\n"; }
if (eval "use Hash::Util; 1") {
print "# We have Hash::Util, so test that the restricted hashes in <DATA> are valid\n";
fail ("You can't get here [perl version $]]. This is a bug in the test.
# Please send the output of perl -V to perlbug\@perl.org");
} else {
print "# We don't have Hash::Util, so test that the restricted hashes downgrade\n";
my $hash = thaw_hash ('Locked hash with utf8 keys', $expect);
test_newkey ($hash);
local $Storable::downgrade_restricted = 0;
thaw_fail ('Locked hash with utf8 keys', $RESTRICTED_CROAK);
# Which croak comes first is a bit of an implementation issue :-)
local $Storable::drop_utf8 = 0;
thaw_fail ('Locked hash with utf8 keys', $RESTRICTED_CROAK);
}
}
__END__
# A whole run of 2.x nfreeze data, uuencoded. The "mode bits" are the octal
# value of 'A', the "file name" is the test name. Use make_downgrade.pl to
# generate these.
begin 101 Locked hash
8!049`0````$*!7)U;&5S!`````1P97)L
end
begin 101 Locked hash placeholder
C!049`0````(*!7)U;&5S!`````1P97)L#A0````%<G5L97,`
end
begin 101 Locked keys
8!049`0````$*!7)U;&5S``````1P97)L
end
begin 101 Locked keys placeholder
C!049`0````(*!7)U;&5S``````1P97)L#A0````%<G5L97,`
end
begin 101 Short 8 bit utf8 data
&!047`L.?
end
begin 101 Short 8 bit utf8 data as bytes
&!04*`L.?
end
begin 101 Long 8 bit utf8 data
M!048```"`,.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?
MPY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#
MG\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?
MPY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#
MG\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?
MPY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#
MG\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?
MPY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#
MG\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?
MPY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#
MG\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?
8PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?
end
begin 101 Short 24 bit utf8 data
)!047!?BPC[^N
end
begin 101 Short 24 bit utf8 data as bytes
)!04*!?BPC[^N
end
begin 101 Long 24 bit utf8 data
M!048```%`/BPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
;OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N
end
begin 101 Hash with utf8 flag but no utf8 keys
8!049``````$*!7)U;&5S``````1P97)L
end
begin 101 Hash with utf8 keys
M!049``````0*!F-A<W1L90`````&8V%S=&QE"@=C:.5T96%U``````=C:.5T
D96%U%P/EGXX!`````^6?CA<'4V-H;&_#GP(````&4V-H;&_?
end
begin 101 Locked hash with utf8 keys
M!049`0````0*!F-A<W1L900````&8V%S=&QE"@=C:.5T96%U!`````=C:.5T
D96%U%P/EGXX%`````^6?CA<'4V-H;&_#GP8````&4V-H;&_?
end
begin 101 Hash with utf8 keys for pre 5.6
M!049``````0*!F-A<W1L90`````&8V%S=&QE"@=C:.5T96%U``````=C:.5T
D96%U"@/EGXX``````^6?C at H'4V-H;&_#GP(````&4V-H;&_?
end
begin 101 Hash with utf8 keys for 5.6
M!049``````0*!F-A<W1L90`````&8V%S=&QE"@=C:.5T96%U``````=C:.5T
D96%U%P/EGXX``````^6?CA<'4V-H;&_#GP(````&4V-H;&_?
end
begin 301 Locked hash
8!049`0````$*!9FDDX6B!`````27A9F3
end
begin 301 Locked hash placeholder
C!049`0````(.%`````69I).%H at H%F:23A:(`````!)>%F9,`
end
begin 301 Locked keys
8!049`0````$*!9FDDX6B``````27A9F3
end
begin 301 Locked keys placeholder
C!049`0````(.%`````69I).%H at H%F:23A:(`````!)>%F9,`
end
begin 301 Short 8 bit utf8 data
&!047`HMS
end
begin 301 Short 8 bit utf8 data as bytes
&!04*`HMS
end
begin 301 Long 8 bit utf8 data
M!048```"`(MSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMS
MBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+
M<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMS
MBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+
M<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMS
MBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+
M<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMS
MBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+
M<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMS
MBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+
M<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMS
8BW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMS
end
begin 301 Short 24 bit utf8 data
*!047!OM30G-S50``
end
begin 301 Short 24 bit utf8 data as bytes
*!04*!OM30G-S50``
end
begin 301 Long 24 bit utf8 data
M!048```&`/M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3
M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S
M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3
M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S
M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3
M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S
M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3
M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S
M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3
M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S
M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3
M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S
M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3
M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S
M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3
M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S
M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3
M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S
M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3
M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S
M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3
M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S
M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3
M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S
M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3
M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S
M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3
M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S
M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3
M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S
M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3
M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S
M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3
M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S
-5?M30G-S5?M30G-S50``
end
begin 301 Hash with utf8 flag but no utf8 keys
8!049``````$*!9FDDX6B``````27A9F3
end
begin 301 Hash with utf8 keys
M!049``````0*!X.(1Z.%@:0`````!X.(1Z.%@:0*!H.!HJ.3A0`````&@X&B
FHY.%%P3<9')5`0````3<9')5%P?B at XB3EHMS`@````;B at XB3EM\`
end
begin 301 Locked hash with utf8 keys
M!049`0````0*!X.(1Z.%@:0$````!X.(1Z.%@:0*!H.!HJ.3A00````&@X&B
FHY.%%P3<9')5!0````3<9')5%P?B at XB3EHMS!@````;B at XB3EM\`
end
begin 301 Hash with utf8 keys for pre 5.6
M!049``````0*!H.!HJ.3A0`````&@X&BHY.%"@B#B(M&HX6!I``````'@XA'
GHX6!I`H'XH.(DY:+<P(````&XH.(DY;?"@3<9')5``````3<9')5
end
begin 301 Hash with utf8 keys for 5.6
M!049``````0*!H.!HJ.3A0`````&@X&BHY.%"@>#B$>CA8&D``````>#B$>C
FA8&D%P?B at XB3EHMS`@````;B at XB3EM\7!-QD<E4`````!-QD<E4`
end
--- NEW FILE: lock.t ---
#!./perl
#
# 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.
#
sub BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib', '../ext/Storable/t');
} else {
unshift @INC, 't';
}
require Config; import Config;
if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
require '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';
--- NEW FILE: overload.t ---
#!./perl
#
# 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.
#
sub BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib', '../ext/Storable/t');
} else {
unshift @INC, 't';
}
require Config; import Config;
if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
require 'st-dump.pl';
}
sub ok;
use Storable qw(freeze thaw);
print "1..16\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;
# nfreeze data generated by make_overload.pl
my $f = unpack 'u', q{7!084$0Q(05-?3U9%4DQ/040*!'-N;W<`};
# see note at the end of do_retrieve in Storable.xs about why this test has to
# use a reference to an overloaded reference, rather than just a reference.
my $t = eval {thaw $f};
print "# $@" if $@;
ok 13, $@ eq "";
ok 14, ref ($t) eq 'REF';
ok 15, ref ($$t) eq 'HAS_OVERLOAD';
ok 16, $$$t eq 'snow';
1;
--- NEW FILE: blessed.t ---
#!./perl
#
# 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.
#
sub BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib', '../ext/Storable/t');
} else {
unshift @INC, 't';
}
require Config; import Config;
if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
require 'st-dump.pl';
}
sub ok;
use Storable qw(freeze thaw);
%::immortals
= (u => \undef,
'y' => \(1 == 1),
n => \(1 == 0)
);
my $test = 12;
my $tests = $test + 6 + 2 * 6 * keys %::immortals;
print "1..$tests\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;
{
my $blessed_ref = bless \\[1,2,3], 'Foobar';
my $x = freeze $blessed_ref;
my $y = thaw $x;
ok 11, ref $y eq 'Foobar';
ok 12, $$$y->[0] == 1;
}
package RETURNS_IMMORTALS;
sub make { my $self = shift; bless [@_], $self }
sub STORABLE_freeze {
# Some reference some number of times.
my $self = shift;
my ($what, $times) = @$self;
return ("$what$times", ($::immortals{$what}) x $times);
}
sub STORABLE_thaw {
my $self = shift;
my $cloning = shift;
my ($x, @refs) = @_;
my ($what, $times) = $x =~ /(.)(\d+)/;
die "'$x' didn't match" unless defined $times;
main::ok ++$test, @refs == $times;
my $expect = $::immortals{$what};
die "'$x' did not give a reference" unless ref $expect;
my $fail;
foreach (@refs) {
$fail++ if $_ != $expect;
}
main::ok ++$test, !$fail;
}
package main;
# $Storable::DEBUGME = 1;
my $count;
foreach $count (1..3) {
my $immortal;
foreach $immortal (keys %::immortals) {
print "# $immortal x $count\n";
my $i = RETURNS_IMMORTALS->make ($immortal, $count);
my $f = freeze ($i);
ok ++$test, $f;
my $t = thaw $f;
ok ++$test, 1;
}
}
# Test automatic require of packages to find thaw hook.
package HAS_HOOK;
$loaded_count = 0;
$thawed_count = 0;
sub make {
bless [];
}
sub STORABLE_freeze {
my $self = shift;
return '';
}
package main;
my $f = freeze (HAS_HOOK->make);
ok ++$test, $HAS_HOOK::loaded_count == 0;
ok ++$test, $HAS_HOOK::thawed_count == 0;
my $t = thaw $f;
ok ++$test, $HAS_HOOK::loaded_count == 1;
ok ++$test, $HAS_HOOK::thawed_count == 1;
ok ++$test, $t;
ok ++$test, ref $t eq 'HAS_HOOK';
# Can't do this because the method is still cached by UNIVERSAL::can
# delete $INC{"HAS_HOOK.pm"};
# undef &HAS_HOOK::STORABLE_thaw;
#
# warn HAS_HOOK->can('STORABLE_thaw');
# $t = thaw $f;
# ok ++$test, $HAS_HOOK::loaded_count == 2;
# ok ++$test, $HAS_HOOK::thawed_count == 2;
# ok ++$test, $t;
# ok ++$test, ref $t eq 'HAS_HOOK';
--- NEW FILE: tied_items.t ---
#!./perl
#
# 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.
#
#
# Tests ref to items in tied hash/array structures.
#
sub BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib', '../ext/Storable/t');
} else {
unshift @INC, 't';
}
require Config; import Config;
if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
require '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;
--- NEW FILE: HAS_OVERLOAD.pm ---
package HAS_OVERLOAD;
use overload
'""' => sub { ${$_[0]} }, fallback => 1;
sub make {
my $package = shift;
my $value = shift;
bless \$value, $package;
}
++$loaded_count;
1;
--- NEW FILE: sig_die.t ---
#!./perl
#
# Copyright (c) 2002 Slaven Rezic
#
# You may redistribute only under the same terms as Perl 5, as specified
# in the README file that comes with the distribution.
#
sub BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib');
} else {
unshift @INC, 't';
}
require Config; import Config;
if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
}
use strict;
BEGIN {
if (!eval q{
use Test::More;
1;
}) {
print "1..0 # skip: tests only work with Test::More\n";
exit;
}
}
BEGIN { plan tests => 1 }
my @warns;
$SIG{__WARN__} = sub { push @warns, shift };
$SIG{__DIE__} = sub { require Carp; warn Carp::longmess(); warn "Evil die!" };
require Storable;
Storable::dclone({foo => "bar"});
is(join("", @warns), "", "__DIE__ is not evil here");
--- NEW FILE: threads.t ---
# as of 2.09 on win32 Storable w/threads dies with "free to wrong
# pool" since it uses the same context for different threads. since
# win32 perl implementation allocates a different memory pool for each
# thread using the a memory pool from one thread to allocate memory
# for another thread makes win32 perl very unhappy
#
# but the problem exists everywhere, not only on win32 perl , it's
# just hard to catch it deterministically - since the same context is
# used if two or more threads happen to change the state of the
# context in the middle of the operation, and those operations aren't
# atomic per thread, bad things including data loss and corrupted data
# can happen.
#
# this has been solved in 2.10 by adding a Storable::CLONE which calls
# Storable::init_perinterp() to create a new context for each new
# thread when it starts
sub BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib');
} else {
unshift @INC, 't';
}
require Config; import Config;
if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
unless ($Config{'useithreads'} and eval { require threads; 1 }) {
print "1..0 # Skip: no threads\n";
exit 0;
}
# - is \W, so can't use \b at start. Negative look ahead and look behind
# works at start/end of string, or where preceded/followed by spaces
if ($] == 5.008002 and $Config{'ccflags'} =~ /(?<!\S)-DDEBUGGING(?!\S)/) {
# Bug caused by change 21610, fixed by change 21849
print "1..0 # Skip: tickles bug in threads combined with -DDEBUGGING on 5.8.2\n";
exit 0;
}
}
use Test::More;
use strict;
use threads;
use Storable qw(nfreeze);
plan tests => 2;
threads->new(\&sub1);
$_->join() for threads->list();
ok 1;
sub sub1 {
nfreeze {};
ok 1;
}
--- NEW FILE: interwork56.t ---
#!./perl -w
#
# Copyright 2002, Larry Wall.
#
# You may redistribute only under the same terms as Perl 5, as specified
# in the README file that comes with the distribution.
#
# I ought to keep this test easily backwards compatible to 5.004, so no
# qr//;
# This test checks whether the kludge to interwork with 5.6 Storables compiled
# on Unix systems with IV as long long works.
sub BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib');
} else {
unshift @INC, 't';
}
require Config; import Config;
if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
unless ($Config{ivsize} and $Config{ivsize} > $Config{longsize}) {
print "1..0 # Skip: Your IVs are no larger than your longs\n";
exit 0;
}
}
use Storable qw(freeze thaw);
use strict;
use Test::More tests=>30;
use vars qw(%tests);
{
local $/ = "\n\nend\n";
while (<DATA>) {
next unless /\S/s;
unless (/begin ([0-7]{3}) ([^\n]*)\n(.*)$/s) {
s/\n.*//s;
warn "Dodgy data in section starting '$_'";
next;
}
next unless oct $1 == ord 'A'; # Skip ASCII on EBCDIC, and vice versa
my $data = unpack 'u', $3;
$tests{$2} = $data;
}
}
# perl makes easy things easy, and hard things possible:
my $test = freeze \'Hell';
my $header = Storable::read_magic ($test);
is ($header->{byteorder}, $Config{byteorder},
"header's byteorder and Config.pm's should agree");
my $result = eval {thaw $test};
isa_ok ($result, 'SCALAR', "Check thawing test data");
is ($@, '', "causes no errors");
is ($$result, 'Hell', 'and gives the expected data');
my $kingdom = $Config{byteorder} =~ /23/ ? "Lillput" : "Belfuscu";
my $name = join ',', $kingdom, @$header{qw(intsize longsize ptrsize nvsize)};
SKIP: {
my $real_thing = $tests{$name};
if (!defined $real_thing) {
print << "EOM";
# No test data for Storable 1.x for:
#
# byteorder '$Config{byteorder}'
# sizeof(int) $$header{intsize}
# sizeof(long) $$header{longsize}
# sizeof(char *) $$header{ptrsize}
# sizeof(NV) $$header{nvsize}
# If you have Storable 1.x built with perl 5.6.x on this platform, please
# make_56_interwork.pl to generate test data, and append the test data to
# this test.
# You may find that make_56_interwork.pl reports that your platform has no
# interworking problems, in which case you need do nothing.
EOM
skip "# No 1.x test file", 9;
}
my $result = eval {thaw $real_thing};
is ($result, undef, "By default should not be able to thaw");
like ($@, qr/Byte order is not compatible/,
"because the header byte order strings differ");
local $Storable::interwork_56_64bit = 1;
$result = eval {thaw $real_thing};
isa_ok ($result, 'ARRAY', "With flag should now thaw");
is ($@, '', "with no errors");
# However, as the file is written with Storable pre 2.01, it's a known
# bug that large (positive) UVs become IVs
my $value = (~0 ^ (~0 >> 1) ^ 2);
is (@$result, 4, "4 elements in array");
like ($$result[0],
qr/^This file was written with [0-9.]+ on perl [0-9.]+\z/,
"1st element");
is ($$result[1], "$kingdom was correct", "2nd element");
cmp_ok ($$result[2] ^ $value, '==', 0, "3rd element") or
printf "# expected %#X, got %#X\n", $value, $$result[2];
is ($$result[3], "The End", "4th element");
}
$result = eval {thaw $test};
isa_ok ($result, 'SCALAR', "CHORUS: check thawing test data");
is ($@, '', " causes no errors");
is ($$result, 'Hell', " and gives the expected data");
my $test_kludge;
{
local $Storable::interwork_56_64bit = 1;
$test_kludge = freeze \'Heck';
}
my $header_kludge = Storable::read_magic ($test_kludge);
cmp_ok (length ($header_kludge->{byteorder}), '==', $Config{longsize},
"With 5.6 interwork kludge byteorder string should be same size as long"
);
$result = eval {thaw $test_kludge};
is ($result, undef, "By default should not be able to thaw");
like ($@, qr/Byte order is not compatible/,
"because the header byte order strings differ");
$result = eval {thaw $test};
isa_ok ($result, 'SCALAR', "CHORUS: check thawing test data");
is ($@, '', " causes no errors");
is ($$result, 'Hell', " and gives the expected data");
{
local $Storable::interwork_56_64bit = 1;
$result = eval {thaw $test_kludge};
isa_ok ($result, 'SCALAR', "should be able to thaw kludge data");
is ($@, '', "with no errors");
is ($$result, 'Heck', "and gives expected data");
$result = eval {thaw $test};
is ($result, undef, "But now can't thaw real data");
like ($@, qr/Byte order is not compatible/,
"because the header byte order strings differ");
}
# All together now:
$result = eval {thaw $test};
isa_ok ($result, 'SCALAR', "CHORUS: check thawing test data");
is ($@, '', " causes no errors");
is ($$result, 'Hell', " and gives the expected data");
__END__
# A whole run of 1.1.14 freeze data, uuencoded. The "mode bits" are the octal
# value of 'A', the "file name" is the test name. Use make_56_interwork.pl
# with a copy of Storable 1.X generate these.
# byteorder '1234'
# sizeof(int) 4
# sizeof(long) 4
# sizeof(char *) 4
# sizeof(NV) 8
begin 101 Lillput,4,4,4,8
M!`0$,3(S-`0$!`@"!`````HQ5&AI<R!F:6QE('=A<R!W<FET=&5N('=I=&@@
M,2XP,30@;VX@<&5R;"`U+C`P-C`P,0H33&EL;'!U="!W87, at 8V]R<F5C=`8"
0````````@`H'5&AE($5N9```
end
# byteorder '4321'
# sizeof(int) 4
# sizeof(long) 4
# sizeof(char *) 4
# sizeof(NV) 8
begin 101 Belfuscu,4,4,4,8
M!`0$-#,R,00$!`@"````!`HQ5&AI<R!F:6QE('=A<R!W<FET=&5N('=I=&@@
M,2XP,30@;VX@<&5R;"`U+C`P-C`P,0H40F5L9G5S8W4@=V%S(&-O<G)E8W0&
1@`````````(*!U1H92!%;F0`
end
# byteorder '1234'
# sizeof(int) 4
# sizeof(long) 4
# sizeof(char *) 4
# sizeof(NV) 12
begin 101 Lillput,4,4,4,12
M!`0$,3(S-`0$!`P"!`````HQ5&AI<R!F:6QE('=A<R!W<FET=&5N('=I=&@@
M,2XP,30@;VX@<&5R;"`U+C`P-C`P,0H33&EL;'!U="!W87, at 8V]R<F5C=`8"
0````````@`H'5&AE($5N9```
end
More information about the dslinux-commit
mailing list