summaryrefslogtreecommitdiff
path: root/ext/Storable/t
diff options
context:
space:
mode:
Diffstat (limited to 'ext/Storable/t')
-rw-r--r--ext/Storable/t/blessed.t104
-rw-r--r--ext/Storable/t/canonical.t153
-rw-r--r--ext/Storable/t/compat06.t157
-rw-r--r--ext/Storable/t/dclone.t82
-rw-r--r--ext/Storable/t/forgive.t67
-rw-r--r--ext/Storable/t/freeze.t119
-rw-r--r--ext/Storable/t/lock.t61
-rw-r--r--ext/Storable/t/overload.t97
-rw-r--r--ext/Storable/t/recurse.t300
-rw-r--r--ext/Storable/t/retrieve.t78
-rw-r--r--ext/Storable/t/store.t119
-rw-r--r--ext/Storable/t/tied.t213
-rw-r--r--ext/Storable/t/tied_hook.t254
-rw-r--r--ext/Storable/t/tied_items.t68
-rw-r--r--ext/Storable/t/utf8.t40
15 files changed, 1912 insertions, 0 deletions
diff --git a/ext/Storable/t/blessed.t b/ext/Storable/t/blessed.t
new file mode 100644
index 0000000000..b1a18e62c3
--- /dev/null
+++ b/ext/Storable/t/blessed.t
@@ -0,0 +1,104 @@
+#!./perl
+
+# $Id: blessed.t,v 1.0 2000/09/01 19:40:41 ram Exp $
+#
+# Copyright (c) 1995-2000, Raphael Manfredi
+#
+# You may redistribute only under the same terms as Perl 5, as specified
+# in the README file that comes with the distribution.
+#
+# $Log: blessed.t,v $
+# Revision 1.0 2000/09/01 19:40:41 ram
+# Baseline for first official release.
+#
+
+sub BEGIN {
+ chdir('t') if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+ require 'lib/st-dump.pl';
+}
+
+sub ok;
+
+use Storable qw(freeze thaw);
+
+print "1..10\n";
+
+package SHORT_NAME;
+
+sub make { bless [], shift }
+
+package SHORT_NAME_WITH_HOOK;
+
+sub make { bless [], shift }
+
+sub STORABLE_freeze {
+ my $self = shift;
+ return ("", $self);
+}
+
+sub STORABLE_thaw {
+ my $self = shift;
+ my $cloning = shift;
+ my ($x, $obj) = @_;
+ die "STORABLE_thaw" unless $obj eq $self;
+}
+
+package main;
+
+# Still less than 256 bytes, so long classname logic not fully exercised
+# Wait until Perl removes the restriction on identifier lengths.
+my $name = "LONG_NAME_" . 'xxxxxxxxxxxxx::' x 14 . "final";
+
+eval <<EOC;
+package $name;
+
+\@ISA = ("SHORT_NAME");
+EOC
+die $@ if $@;
+ok 1, $@ eq '';
+
+eval <<EOC;
+package ${name}_WITH_HOOK;
+
+\@ISA = ("SHORT_NAME_WITH_HOOK");
+EOC
+ok 2, $@ eq '';
+
+# Construct a pool of objects
+my @pool;
+
+for (my $i = 0; $i < 10; $i++) {
+ push(@pool, SHORT_NAME->make);
+ push(@pool, SHORT_NAME_WITH_HOOK->make);
+ push(@pool, $name->make);
+ push(@pool, "${name}_WITH_HOOK"->make);
+}
+
+my $x = freeze \@pool;
+ok 3, 1;
+
+my $y = thaw $x;
+ok 4, ref $y eq 'ARRAY';
+ok 5, @{$y} == @pool;
+
+ok 6, ref $y->[0] eq 'SHORT_NAME';
+ok 7, ref $y->[1] eq 'SHORT_NAME_WITH_HOOK';
+ok 8, ref $y->[2] eq $name;
+ok 9, ref $y->[3] eq "${name}_WITH_HOOK";
+
+my $good = 1;
+for (my $i = 0; $i < 10; $i++) {
+ do { $good = 0; last } unless ref $y->[4*$i] eq 'SHORT_NAME';
+ do { $good = 0; last } unless ref $y->[4*$i+1] eq 'SHORT_NAME_WITH_HOOK';
+ do { $good = 0; last } unless ref $y->[4*$i+2] eq $name;
+ do { $good = 0; last } unless ref $y->[4*$i+3] eq "${name}_WITH_HOOK";
+}
+ok 10, $good;
+
diff --git a/ext/Storable/t/canonical.t b/ext/Storable/t/canonical.t
new file mode 100644
index 0000000000..b55669b653
--- /dev/null
+++ b/ext/Storable/t/canonical.t
@@ -0,0 +1,153 @@
+#!./perl
+
+# $Id: canonical.t,v 1.0 2000/09/01 19:40:41 ram Exp $
+#
+# Copyright (c) 1995-2000, Raphael Manfredi
+#
+# You may redistribute only under the same terms as Perl 5, as specified
+# in the README file that comes with the distribution.
+#
+# $Log: canonical.t,v $
+# Revision 1.0 2000/09/01 19:40:41 ram
+# Baseline for first official release.
+#
+
+sub BEGIN {
+ chdir('t') if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+}
+
+
+use Storable qw(freeze thaw dclone);
+use vars qw($debugging $verbose);
+
+print "1..8\n";
+
+sub ok {
+ my($testno, $ok) = @_;
+ print "not " unless $ok;
+ print "ok $testno\n";
+}
+
+
+# Uncomment the folowing line to get a dump of the constructed data structure
+# (you may want to reduce the size of the hashes too)
+# $debugging = 1;
+
+$hashsize = 100;
+$maxhash2size = 100;
+$maxarraysize = 100;
+
+# Use MD5 if its available to make random string keys
+
+eval { require "MD5.pm" };
+$gotmd5 = !$@;
+
+# Use Data::Dumper if debugging and it is available to create an ASCII dump
+
+if ($debugging) {
+ eval { require "Data/Dumper.pm" };
+ $gotdd = !$@;
+}
+
+@fixed_strings = ("January", "February", "March", "April", "May", "June",
+ "July", "August", "September", "October", "November", "December" );
+
+# Build some arbitrarily complex data structure starting with a top level hash
+# (deeper levels contain scalars, references to hashes or references to arrays);
+
+for (my $i = 0; $i < $hashsize; $i++) {
+ my($k) = int(rand(1_000_000));
+ $k = MD5->hexhash($k) if $gotmd5 and int(rand(2));
+ $a1{$k} = { key => "$k", value => $i };
+
+ # A third of the elements are references to further hashes
+
+ if (int(rand(1.5))) {
+ my($hash2) = {};
+ my($hash2size) = int(rand($maxhash2size));
+ while ($hash2size--) {
+ my($k2) = $k . $i . int(rand(100));
+ $hash2->{$k2} = $fixed_strings[rand(int(@fixed_strings))];
+ }
+ $a1{$k}->{value} = $hash2;
+ }
+
+ # A further third are references to arrays
+
+ elsif (int(rand(2))) {
+ my($arr_ref) = [];
+ my($arraysize) = int(rand($maxarraysize));
+ while ($arraysize--) {
+ push(@$arr_ref, $fixed_strings[rand(int(@fixed_strings))]);
+ }
+ $a1{$k}->{value} = $arr_ref;
+ }
+}
+
+
+print STDERR Data::Dumper::Dumper(\%a1) if ($verbose and $gotdd);
+
+
+# Copy the hash, element by element in order of the keys
+
+foreach $k (sort keys %a1) {
+ $a2{$k} = { key => "$k", value => $a1{$k}->{value} };
+}
+
+# Deep clone the hash
+
+$a3 = dclone(\%a1);
+
+# In canonical mode the frozen representation of each of the hashes
+# should be identical
+
+$Storable::canonical = 1;
+
+$x1 = freeze(\%a1);
+$x2 = freeze(\%a2);
+$x3 = freeze($a3);
+
+ok 1, (length($x1) > $hashsize); # sanity check
+ok 2, length($x1) == length($x2); # idem
+ok 3, $x1 eq $x2;
+ok 4, $x1 eq $x3;
+
+# In normal mode it is exceedingly unlikely that the frozen
+# representaions of all the hashes will be the same (normally the hash
+# elements are frozen in the order they are stored internally,
+# i.e. pseudo-randomly).
+
+$Storable::canonical = 0;
+
+$x1 = freeze(\%a1);
+$x2 = freeze(\%a2);
+$x3 = freeze($a3);
+
+
+# Two out of three the same may be a coincidence, all three the same
+# is much, much more unlikely. Still it could happen, so this test
+# may report a false negative.
+
+ok 5, ($x1 ne $x2) || ($x1 ne $x3);
+
+
+# Ensure refs to "undef" values are properly shared
+# Same test as in t/dclone.t to ensure the "canonical" code is also correct
+
+my $hash;
+push @{$$hash{''}}, \$$hash{a};
+ok 6, $$hash{''}[0] == \$$hash{a};
+
+my $cloned = dclone(dclone($hash));
+ok 7, $$cloned{''}[0] == \$$cloned{a};
+
+$$cloned{a} = "blah";
+ok 8, $$cloned{''}[0] == \$$cloned{a};
+
diff --git a/ext/Storable/t/compat06.t b/ext/Storable/t/compat06.t
new file mode 100644
index 0000000000..1586b18a81
--- /dev/null
+++ b/ext/Storable/t/compat06.t
@@ -0,0 +1,157 @@
+#!./perl
+
+# $Id: compat-0.6.t,v 1.0.1.1 2001/02/17 12:26:21 ram Exp $
+#
+# Copyright (c) 1995-2000, Raphael Manfredi
+#
+# You may redistribute only under the same terms as Perl 5, as specified
+# in the README file that comes with the distribution.
+#
+# $Log: compat-0.6.t,v $
+# Revision 1.0.1.1 2001/02/17 12:26:21 ram
+# patch8: added EBCDIC version of the test, from Peter Prymmer
+#
+# Revision 1.0 2000/09/01 19:40:41 ram
+# Baseline for first official release.
+#
+
+BEGIN {
+ chdir('t') if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+ require 'lib/st-dump.pl';
+}
+
+sub ok;
+
+print "1..8\n";
+
+use Storable qw(freeze nfreeze thaw);
+
+package TIED_HASH;
+
+sub TIEHASH {
+ my $self = bless {}, shift;
+ return $self;
+}
+
+sub FETCH {
+ my $self = shift;
+ my ($key) = @_;
+ $main::hash_fetch++;
+ return $self->{$key};
+}
+
+sub STORE {
+ my $self = shift;
+ my ($key, $val) = @_;
+ $self->{$key} = $val;
+}
+
+package SIMPLE;
+
+sub make {
+ my $self = bless [], shift;
+ my ($x) = @_;
+ $self->[0] = $x;
+ return $self;
+}
+
+package ROOT;
+
+sub make {
+ my $self = bless {}, shift;
+ my $h = tie %hash, TIED_HASH;
+ $self->{h} = $h;
+ $self->{ref} = \%hash;
+ my @pool;
+ for (my $i = 0; $i < 5; $i++) {
+ push(@pool, SIMPLE->make($i));
+ }
+ $self->{obj} = \@pool;
+ my @a = ('string', $h, $self);
+ $self->{a} = \@a;
+ $self->{num} = [1, 0, -3, -3.14159, 456, 4.5];
+ $h->{key1} = 'val1';
+ $h->{key2} = 'val2';
+ return $self;
+};
+
+sub num { $_[0]->{num} }
+sub h { $_[0]->{h} }
+sub ref { $_[0]->{ref} }
+sub obj { $_[0]->{obj} }
+
+package main;
+
+my $is_EBCDIC = (ord('A') == 193) ? 1 : 0;
+
+my $r = ROOT->make;
+
+my $data = '';
+if (!$is_EBCDIC) { # ASCII machine
+ while (<DATA>) {
+ next if /^#/;
+ $data .= unpack("u", $_);
+ }
+} else {
+ while (<DATA>) {
+ next if /^#$/; # skip comments
+ next if /^#\s+/; # skip comments
+ next if /^[^#]/; # skip uuencoding for ASCII machines
+ s/^#//; # prepare uuencoded data for EBCDIC machines
+ $data .= unpack("u", $_);
+ }
+}
+
+my $expected_length = $is_EBCDIC ? 217 : 278;
+ok 1, length $data == $expected_length;
+
+my $y = thaw($data);
+ok 2, 1;
+ok 3, ref $y eq 'ROOT';
+
+$Storable::canonical = 1; # Prevent "used once" warning
+$Storable::canonical = 1;
+# Allow for long double string conversions.
+$y->{num}->[3] += 0;
+$r->{num}->[3] += 0;
+ok 4, nfreeze($y) eq nfreeze($r);
+
+ok 5, $y->ref->{key1} eq 'val1';
+ok 6, $y->ref->{key2} eq 'val2';
+ok 7, $hash_fetch == 2;
+
+my $num = $r->num;
+my $ok = 1;
+for (my $i = 0; $i < @$num; $i++) {
+ do { $ok = 0; last } unless $num->[$i] == $y->num->[$i];
+}
+ok 8, $ok;
+
+__END__
+#
+# using Storable-0.6@11, output of: print pack("u", nfreeze(ROOT->make));
+# original size: 278 bytes
+#
+M`P,````%!`(````&"(%8"(!8"'U8"@@M,RXQ-#$U.5@)```!R%@*`S0N-5A8
+M6`````-N=6T$`P````(*!'9A;#%8````!&ME>3$*!'9A;#)8````!&ME>3)B
+M"51)141?2$%32%A8`````6@$`@````,*!G-T<FEN9U@$``````I8!```````
+M6%A8`````6$$`@````4$`@````$(@%AB!E-)35!,15A8!`(````!"(%88@93
+M24U03$586`0"`````0B"6&(&4TE-4$Q%6%@$`@````$(@UAB!E-)35!,15A8
+M!`(````!"(188@9324U03$586%A8`````V]B:@0,!``````*6%A8`````W)E
+(9F($4D]/5%@`
+#
+# using Storable-0.6@11, output of: print '#' . pack("u", nfreeze(ROOT->make));
+# on OS/390 (cp 1047) original size: 217 bytes
+#
+#M!0,1!-G6UN,#````!00,!!$)X\G%Q&W(P>+(`P````(*!*6!D_$````$DH6H
+#M\0H$I8&3\@````22A:CR`````YF%A@0"````!@B!"(`(?0H(8/-+\?3Q]?D)
+#M```!R`H#]$OU`````Y6DE`0"````!001!N+)U-?3Q0(````!"(`$$@("````
+#M`0B!!!("`@````$(@@02`@(````!"(,$$@("`````0B$`````Y:"D00`````
+#E!`````&(!`(````#"@:BHYF)E8<$``````0$```````````!@0``
diff --git a/ext/Storable/t/dclone.t b/ext/Storable/t/dclone.t
new file mode 100644
index 0000000000..38c82ebcc1
--- /dev/null
+++ b/ext/Storable/t/dclone.t
@@ -0,0 +1,82 @@
+#!./perl
+
+# $Id: dclone.t,v 1.0 2000/09/01 19:40:41 ram Exp $
+#
+# Copyright (c) 1995-2000, Raphael Manfredi
+#
+# You may redistribute only under the same terms as Perl 5, as specified
+# in the README file that comes with the distribution.
+#
+# $Log: dclone.t,v $
+# Revision 1.0 2000/09/01 19:40:41 ram
+# Baseline for first official release.
+#
+
+sub BEGIN {
+ chdir('t') if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+ require 'lib/st-dump.pl';
+}
+
+
+use Storable qw(dclone);
+
+print "1..9\n";
+
+$a = 'toto';
+$b = \$a;
+$c = bless {}, CLASS;
+$c->{attribute} = 'attrval';
+%a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c);
+@a = ('first', undef, 3, -4, -3.14159, 456, 4.5,
+ $b, \$a, $a, $c, \$c, \%a);
+
+print "not " unless defined ($aref = dclone(\@a));
+print "ok 1\n";
+
+$dumped = &dump(\@a);
+print "ok 2\n";
+
+$got = &dump($aref);
+print "ok 3\n";
+
+print "not " unless $got eq $dumped;
+print "ok 4\n";
+
+package FOO; @ISA = qw(Storable);
+
+sub make {
+ my $self = bless {};
+ $self->{key} = \%main::a;
+ return $self;
+};
+
+package main;
+
+$foo = FOO->make;
+print "not " unless defined($r = $foo->dclone);
+print "ok 5\n";
+
+print "not " unless &dump($foo) eq &dump($r);
+print "ok 6\n";
+
+# Ensure refs to "undef" values are properly shared during cloning
+my $hash;
+push @{$$hash{''}}, \$$hash{a};
+print "not " unless $$hash{''}[0] == \$$hash{a};
+print "ok 7\n";
+
+my $cloned = dclone(dclone($hash));
+print "not " unless $$cloned{''}[0] == \$$cloned{a};
+print "ok 8\n";
+
+$$cloned{a} = "blah";
+print "not " unless $$cloned{''}[0] == \$$cloned{a};
+print "ok 9\n";
+
diff --git a/ext/Storable/t/forgive.t b/ext/Storable/t/forgive.t
new file mode 100644
index 0000000000..58810983c5
--- /dev/null
+++ b/ext/Storable/t/forgive.t
@@ -0,0 +1,67 @@
+#!./perl
+
+# $Id: forgive.t,v 1.0.1.1 2000/09/01 19:40:42 ram Exp $
+#
+# Copyright (c) 1995-2000, Raphael Manfredi
+#
+# You may redistribute only under the same terms as Perl 5, as specified
+# in the README file that comes with the distribution.
+#
+# Original Author: Ulrich Pfeifer
+# (C) Copyright 1997, Universitat Dortmund, all rights reserved.
+#
+# $Log: forgive.t,v $
+# Revision 1.0.1.1 2000/09/01 19:40:42 ram
+# Baseline for first official release.
+#
+# Revision 1.0 2000/09/01 19:40:41 ram
+# Baseline for first official release.
+#
+
+sub BEGIN {
+ chdir('t') if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+}
+
+use Storable qw(store retrieve);
+use File::Spec;
+
+print "1..8\n";
+
+my $test = 1;
+my $bad = ['foo', sub { 1 }, 'bar'];
+my $result;
+
+eval {$result = store ($bad , 'store')};
+print ((!defined $result)?"ok $test\n":"not ok $test\n"); $test++;
+print (($@ ne '')?"ok $test\n":"not ok $test\n"); $test++;
+
+$Storable::forgive_me=1;
+
+my $devnull = File::Spec->devnull;
+
+open(SAVEERR, ">&STDERR");
+open(STDERR, ">$devnull") or
+ ( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) );
+
+eval {$result = store ($bad , 'store')};
+
+open(STDERR, ">&SAVEERR");
+
+print ((defined $result)?"ok $test\n":"not ok $test\n"); $test++;
+print (($@ eq '')?"ok $test\n":"not ok $test\n"); $test++;
+
+my $ret = retrieve('store');
+print ((defined $ret)?"ok $test\n":"not ok $test\n"); $test++;
+print (($ret->[0] eq 'foo')?"ok $test\n":"not ok $test\n"); $test++;
+print (($ret->[2] eq 'bar')?"ok $test\n":"not ok $test\n"); $test++;
+print ((ref $ret->[1] eq 'SCALAR')?"ok $test\n":"not ok $test\n"); $test++;
+
+
+END { 1 while unlink 'store' }
diff --git a/ext/Storable/t/freeze.t b/ext/Storable/t/freeze.t
new file mode 100644
index 0000000000..37631edc7e
--- /dev/null
+++ b/ext/Storable/t/freeze.t
@@ -0,0 +1,119 @@
+#!./perl
+
+# $Id: freeze.t,v 1.0 2000/09/01 19:40:41 ram Exp $
+#
+# Copyright (c) 1995-2000, Raphael Manfredi
+#
+# You may redistribute only under the same terms as Perl 5, as specified
+# in the README file that comes with the distribution.
+#
+# $Log: freeze.t,v $
+# Revision 1.0 2000/09/01 19:40:41 ram
+# Baseline for first official release.
+#
+
+sub BEGIN {
+ chdir('t') if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+ require 'lib/st-dump.pl';
+}
+
+
+use Storable qw(freeze nfreeze thaw);
+
+print "1..15\n";
+
+$a = 'toto';
+$b = \$a;
+$c = bless {}, CLASS;
+$c->{attribute} = $b;
+$d = {};
+$e = [];
+$d->{'a'} = $e;
+$e->[0] = $d;
+%a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c);
+@a = ('first', undef, 3, -4, -3.14159, 456, 4.5, $d, \$d, \$e, $e,
+ $b, \$a, $a, $c, \$c, \%a);
+
+print "not " unless defined ($f1 = freeze(\@a));
+print "ok 1\n";
+
+$dumped = &dump(\@a);
+print "ok 2\n";
+
+$root = thaw($f1);
+print "not " unless defined $root;
+print "ok 3\n";
+
+$got = &dump($root);
+print "ok 4\n";
+
+print "not " unless $got eq $dumped;
+print "ok 5\n";
+
+package FOO; @ISA = qw(Storable);
+
+sub make {
+ my $self = bless {};
+ $self->{key} = \%main::a;
+ return $self;
+};
+
+package main;
+
+$foo = FOO->make;
+print "not " unless $f2 = $foo->freeze;
+print "ok 6\n";
+
+print "not " unless $f3 = $foo->nfreeze;
+print "ok 7\n";
+
+$root3 = thaw($f3);
+print "not " unless defined $root3;
+print "ok 8\n";
+
+print "not " unless &dump($foo) eq &dump($root3);
+print "ok 9\n";
+
+$root = thaw($f2);
+print "not " unless &dump($foo) eq &dump($root);
+print "ok 10\n";
+
+print "not " unless &dump($root3) eq &dump($root);
+print "ok 11\n";
+
+$other = freeze($root);
+print "not " unless length($other) == length($f2);
+print "ok 12\n";
+
+$root2 = thaw($other);
+print "not " unless &dump($root2) eq &dump($root);
+print "ok 13\n";
+
+$VAR1 = [
+ 'method',
+ 1,
+ 'prepare',
+ 'SELECT table_name, table_owner, num_rows FROM iitables
+ where table_owner != \'$ingres\' and table_owner != \'DBA\''
+];
+
+$x = nfreeze($VAR1);
+$VAR2 = thaw($x);
+print "not " unless $VAR2->[3] eq $VAR1->[3];
+print "ok 14\n";
+
+# Test the workaround for LVALUE bug in perl 5.004_04 -- from Gisle Aas
+sub foo { $_[0] = 1 }
+$foo = [];
+foo($foo->[1]);
+eval { freeze($foo) };
+print "not " if $@;
+print "ok 15\n";
+
diff --git a/ext/Storable/t/lock.t b/ext/Storable/t/lock.t
new file mode 100644
index 0000000000..77d73bbb79
--- /dev/null
+++ b/ext/Storable/t/lock.t
@@ -0,0 +1,61 @@
+#!./perl
+
+# $Id: lock.t,v 1.0.1.4 2001/01/03 09:41:00 ram Exp $
+#
+# @COPYRIGHT@
+#
+# $Log: lock.t,v $
+# Revision 1.0.1.4 2001/01/03 09:41:00 ram
+# patch7: use new CAN_FLOCK routine to determine whether to run tests
+#
+# Revision 1.0.1.3 2000/10/26 17:11:27 ram
+# patch5: just check $^O, there's no need for the whole Config
+#
+# Revision 1.0.1.2 2000/10/23 18:03:07 ram
+# patch4: protected calls to flock() for dos platform
+#
+# Revision 1.0.1.1 2000/09/28 21:44:06 ram
+# patch2: created.
+#
+#
+
+sub BEGIN {
+ chdir('t') if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+
+ require 'lib/st-dump.pl';
+}
+
+sub ok;
+
+use Storable qw(lock_store lock_retrieve);
+
+unless (&Storable::CAN_FLOCK) {
+ print "1..0 # Skip: fcntl/flock emulation broken on this platform\n";
+ exit 0;
+}
+
+print "1..5\n";
+
+@a = ('first', undef, 3, -4, -3.14159, 456, 4.5);
+
+#
+# We're just ensuring things work, we're not validating locking.
+#
+
+ok 1, defined lock_store(\@a, 'store');
+ok 2, $dumped = &dump(\@a);
+
+$root = lock_retrieve('store');
+ok 3, ref $root eq 'ARRAY';
+ok 4, @a == @$root;
+ok 5, &dump($root) eq $dumped;
+
+unlink 't/store';
+
diff --git a/ext/Storable/t/overload.t b/ext/Storable/t/overload.t
new file mode 100644
index 0000000000..6d1e5816d1
--- /dev/null
+++ b/ext/Storable/t/overload.t
@@ -0,0 +1,97 @@
+#!./perl
+
+# $Id: overload.t,v 1.0.1.1 2001/02/17 12:27:22 ram Exp $
+#
+# Copyright (c) 1995-2000, Raphael Manfredi
+#
+# You may redistribute only under the same terms as Perl 5, as specified
+# in the README file that comes with the distribution.
+#
+# $Log: overload.t,v $
+# Revision 1.0.1.1 2001/02/17 12:27:22 ram
+# patch8: added test for structures with indirect ref to overloaded
+#
+# Revision 1.0 2000/09/01 19:40:42 ram
+# Baseline for first official release.
+#
+
+sub BEGIN {
+ chdir('t') if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+ require 'lib/st-dump.pl';
+}
+
+sub ok;
+
+use Storable qw(freeze thaw);
+
+print "1..12\n";
+
+package OVERLOADED;
+
+use overload
+ '""' => sub { $_[0][0] };
+
+package main;
+
+$a = bless [77], OVERLOADED;
+
+$b = thaw freeze $a;
+ok 1, ref $b eq 'OVERLOADED';
+ok 2, "$b" eq "77";
+
+$c = thaw freeze \$a;
+ok 3, ref $c eq 'REF';
+ok 4, ref $$c eq 'OVERLOADED';
+ok 5, "$$c" eq "77";
+
+$d = thaw freeze [$a, $a];
+ok 6, "$d->[0]" eq "77";
+$d->[0][0]++;
+ok 7, "$d->[1]" eq "78";
+
+package REF_TO_OVER;
+
+sub make {
+ my $self = bless {}, shift;
+ my ($over) = @_;
+ $self->{over} = $over;
+ return $self;
+}
+
+package OVER;
+
+use overload
+ '+' => \&plus,
+ '""' => sub { ref $_[0] };
+
+sub plus {
+ return 314;
+}
+
+sub make {
+ my $self = bless {}, shift;
+ my $ref = REF_TO_OVER->make($self);
+ $self->{ref} = $ref;
+ return $self;
+}
+
+package main;
+
+$a = OVER->make();
+$b = thaw freeze $a;
+
+ok 8, ref $b eq 'OVER';
+ok 9, $a + $a == 314;
+ok 10, ref $b->{ref} eq 'REF_TO_OVER';
+ok 11, "$b->{ref}->{over}" eq "$b";
+ok 12, $b + $b == 314;
+
+1;
+
diff --git a/ext/Storable/t/recurse.t b/ext/Storable/t/recurse.t
new file mode 100644
index 0000000000..e3afc9cf2f
--- /dev/null
+++ b/ext/Storable/t/recurse.t
@@ -0,0 +1,300 @@
+#!./perl
+
+# $Id: recurse.t,v 1.0.1.3 2001/02/17 12:28:33 ram Exp $
+#
+# Copyright (c) 1995-2000, Raphael Manfredi
+#
+# You may redistribute only under the same terms as Perl 5, as specified
+# in the README file that comes with the distribution.
+#
+# $Log: recurse.t,v $
+# Revision 1.0.1.3 2001/02/17 12:28:33 ram
+# patch8: ensure blessing occurs ASAP, specially designed for hooks
+#
+# Revision 1.0.1.2 2000/11/05 17:22:05 ram
+# patch6: stress hook a little more with refs to lexicals
+#
+# $Log: recurse.t,v $
+# Revision 1.0.1.1 2000/09/17 16:48:05 ram
+# patch1: added test case for store hook bug
+#
+# $Log: recurse.t,v $
+# Revision 1.0 2000/09/01 19:40:42 ram
+# Baseline for first official release.
+#
+
+sub BEGIN {
+ chdir('t') if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+ require 'lib/st-dump.pl';
+}
+
+sub ok;
+
+use Storable qw(freeze thaw dclone);
+
+print "1..32\n";
+
+package OBJ_REAL;
+
+use Storable qw(freeze thaw);
+
+@x = ('a', 1);
+
+sub make { bless [], shift }
+
+sub STORABLE_freeze {
+ my $self = shift;
+ my $cloning = shift;
+ die "STORABLE_freeze" unless Storable::is_storing;
+ return (freeze(\@x), $self);
+}
+
+sub STORABLE_thaw {
+ my $self = shift;
+ my $cloning = shift;
+ my ($x, $obj) = @_;
+ die "STORABLE_thaw #1" unless $obj eq $self;
+ my $len = length $x;
+ my $a = thaw $x;
+ die "STORABLE_thaw #2" unless ref $a eq 'ARRAY';
+ die "STORABLE_thaw #3" unless @$a == 2 && $a->[0] eq 'a' && $a->[1] == 1;
+ @$self = @$a;
+ die "STORABLE_thaw #4" unless Storable::is_retrieving;
+}
+
+package OBJ_SYNC;
+
+@x = ('a', 1);
+
+sub make { bless {}, shift }
+
+sub STORABLE_freeze {
+ my $self = shift;
+ my ($cloning) = @_;
+ return if $cloning;
+ return ("", \@x, $self);
+}
+
+sub STORABLE_thaw {
+ my $self = shift;
+ my ($cloning, $undef, $a, $obj) = @_;
+ die "STORABLE_thaw #1" unless $obj eq $self;
+ die "STORABLE_thaw #2" unless ref $a eq 'ARRAY' || @$a != 2;
+ $self->{ok} = $self;
+}
+
+package OBJ_SYNC2;
+
+use Storable qw(dclone);
+
+sub make {
+ my $self = bless {}, shift;
+ my ($ext) = @_;
+ $self->{sync} = OBJ_SYNC->make;
+ $self->{ext} = $ext;
+ return $self;
+}
+
+sub STORABLE_freeze {
+ my $self = shift;
+ my %copy = %$self;
+ my $r = \%copy;
+ my $t = dclone($r->{sync});
+ return ("", [$t, $self->{ext}], $r, $self, $r->{ext});
+}
+
+sub STORABLE_thaw {
+ my $self = shift;
+ my ($cloning, $undef, $a, $r, $obj, $ext) = @_;
+ die "STORABLE_thaw #1" unless $obj eq $self;
+ die "STORABLE_thaw #2" unless ref $a eq 'ARRAY';
+ die "STORABLE_thaw #3" unless ref $r eq 'HASH';
+ die "STORABLE_thaw #4" unless $a->[1] == $r->{ext};
+ $self->{ok} = $self;
+ ($self->{sync}, $self->{ext}) = @$a;
+}
+
+package OBJ_REAL2;
+
+use Storable qw(freeze thaw);
+
+$MAX = 20;
+$recursed = 0;
+$hook_called = 0;
+
+sub make { bless [], shift }
+
+sub STORABLE_freeze {
+ my $self = shift;
+ $hook_called++;
+ return (freeze($self), $self) if ++$recursed < $MAX;
+ return ("no", $self);
+}
+
+sub STORABLE_thaw {
+ my $self = shift;
+ my $cloning = shift;
+ my ($x, $obj) = @_;
+ die "STORABLE_thaw #1" unless $obj eq $self;
+ $self->[0] = thaw($x) if $x ne "no";
+ $recursed--;
+}
+
+package main;
+
+my $real = OBJ_REAL->make;
+my $x = freeze $real;
+ok 1, 1;
+
+my $y = thaw $x;
+ok 2, 1;
+ok 3, $y->[0] eq 'a';
+ok 4, $y->[1] == 1;
+
+my $sync = OBJ_SYNC->make;
+$x = freeze $sync;
+ok 5, 1;
+
+$y = thaw $x;
+ok 6, 1;
+ok 7, $y->{ok} == $y;
+
+my $ext = [1, 2];
+$sync = OBJ_SYNC2->make($ext);
+$x = freeze [$sync, $ext];
+ok 8, 1;
+
+my $z = thaw $x;
+$y = $z->[0];
+ok 9, 1;
+ok 10, $y->{ok} == $y;
+ok 11, ref $y->{sync} eq 'OBJ_SYNC';
+ok 12, $y->{ext} == $z->[1];
+
+$real = OBJ_REAL2->make;
+$x = freeze $real;
+ok 13, 1;
+ok 14, $OBJ_REAL2::recursed == $OBJ_REAL2::MAX;
+ok 15, $OBJ_REAL2::hook_called == $OBJ_REAL2::MAX;
+
+$y = thaw $x;
+ok 16, 1;
+ok 17, $OBJ_REAL2::recursed == 0;
+
+$x = dclone $real;
+ok 18, 1;
+ok 19, ref $x eq 'OBJ_REAL2';
+ok 20, $OBJ_REAL2::recursed == 0;
+ok 21, $OBJ_REAL2::hook_called == 2 * $OBJ_REAL2::MAX;
+
+ok 22, !Storable::is_storing;
+ok 23, !Storable::is_retrieving;
+
+#
+# The following was a test-case that Salvador Ortiz Garcia <sog@msg.com.mx>
+# sent me, along with a proposed fix.
+#
+
+package Foo;
+
+sub new {
+ my $class = shift;
+ my $dat = shift;
+ return bless {dat => $dat}, $class;
+}
+
+package Bar;
+sub new {
+ my $class = shift;
+ return bless {
+ a => 'dummy',
+ b => [
+ Foo->new(1),
+ Foo->new(2), # Second instance of a Foo
+ ]
+ }, $class;
+}
+
+sub STORABLE_freeze {
+ my($self,$clonning) = @_;
+ return "$self->{a}", $self->{b};
+}
+
+sub STORABLE_thaw {
+ my($self,$clonning,$dummy,$o) = @_;
+ $self->{a} = $dummy;
+ $self->{b} = $o;
+}
+
+package main;
+
+my $bar = new Bar;
+my $bar2 = thaw freeze $bar;
+
+ok 24, ref($bar2) eq 'Bar';
+ok 25, ref($bar->{b}[0]) eq 'Foo';
+ok 26, ref($bar->{b}[1]) eq 'Foo';
+ok 27, ref($bar2->{b}[0]) eq 'Foo';
+ok 28, ref($bar2->{b}[1]) eq 'Foo';
+
+#
+# The following attempts to make sure blessed objects are blessed ASAP
+# at retrieve time.
+#
+
+package CLASS_1;
+
+sub make {
+ my $self = bless {}, shift;
+ return $self;
+}
+
+package CLASS_2;
+
+sub make {
+ my $self = bless {}, shift;
+ my ($o) = @_;
+ $self->{c1} = CLASS_1->make();
+ $self->{o} = $o;
+ $self->{c3} = bless CLASS_1->make(), "CLASS_3";
+ $o->set_c2($self);
+ return $self;
+}
+
+sub STORABLE_freeze {
+ my($self, $clonning) = @_;
+ return "", $self->{c1}, $self->{c3}, $self->{o};
+}
+
+sub STORABLE_thaw {
+ my($self, $clonning, $frozen, $c1, $c3, $o) = @_;
+ main::ok 29, ref $self eq "CLASS_2";
+ main::ok 30, ref $c1 eq "CLASS_1";
+ main::ok 31, ref $c3 eq "CLASS_3";
+ main::ok 32, ref $o eq "CLASS_OTHER";
+ $self->{c1} = $c1;
+ $self->{c3} = $c3;
+}
+
+package CLASS_OTHER;
+
+sub make {
+ my $self = bless {}, shift;
+ return $self;
+}
+
+sub set_c2 { $_[0]->{c2} = $_[1] }
+
+package main;
+
+my $o = CLASS_OTHER->make();
+my $c2 = CLASS_2->make($o);
+my $so = thaw freeze $o;
+
diff --git a/ext/Storable/t/retrieve.t b/ext/Storable/t/retrieve.t
new file mode 100644
index 0000000000..c968485ab2
--- /dev/null
+++ b/ext/Storable/t/retrieve.t
@@ -0,0 +1,78 @@
+#!./perl
+
+# $Id: retrieve.t,v 1.0 2000/09/01 19:40:42 ram Exp $
+#
+# Copyright (c) 1995-2000, Raphael Manfredi
+#
+# You may redistribute only under the same terms as Perl 5, as specified
+# in the README file that comes with the distribution.
+#
+# $Log: retrieve.t,v $
+# Revision 1.0 2000/09/01 19:40:42 ram
+# Baseline for first official release.
+#
+
+sub BEGIN {
+ chdir('t') if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+ require 'lib/st-dump.pl';
+}
+
+
+use Storable qw(store retrieve nstore);
+
+print "1..14\n";
+
+$a = 'toto';
+$b = \$a;
+$c = bless {}, CLASS;
+$c->{attribute} = 'attrval';
+%a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c);
+@a = ('first', '', undef, 3, -4, -3.14159, 456, 4.5,
+ $b, \$a, $a, $c, \$c, \%a);
+
+print "not " unless defined store(\@a, 'store');
+print "ok 1\n";
+print "not " if Storable::last_op_in_netorder();
+print "ok 2\n";
+print "not " unless defined nstore(\@a, 'nstore');
+print "ok 3\n";
+print "not " unless Storable::last_op_in_netorder();
+print "ok 4\n";
+print "not " unless Storable::last_op_in_netorder();
+print "ok 5\n";
+
+$root = retrieve('store');
+print "not " unless defined $root;
+print "ok 6\n";
+print "not " if Storable::last_op_in_netorder();
+print "ok 7\n";
+
+$nroot = retrieve('nstore');
+print "not " unless defined $nroot;
+print "ok 8\n";
+print "not " unless Storable::last_op_in_netorder();
+print "ok 9\n";
+
+$d1 = &dump($root);
+print "ok 10\n";
+$d2 = &dump($nroot);
+print "ok 11\n";
+
+print "not " unless $d1 eq $d2;
+print "ok 12\n";
+
+# Make sure empty string is defined at retrieval time
+print "not " unless defined $root->[1];
+print "ok 13\n";
+print "not " if length $root->[1];
+print "ok 14\n";
+
+END { 1 while unlink('store', 'nstore') }
+
diff --git a/ext/Storable/t/store.t b/ext/Storable/t/store.t
new file mode 100644
index 0000000000..d26755f129
--- /dev/null
+++ b/ext/Storable/t/store.t
@@ -0,0 +1,119 @@
+#!./perl
+
+# $Id: store.t,v 1.0 2000/09/01 19:40:42 ram Exp $
+#
+# Copyright (c) 1995-2000, Raphael Manfredi
+#
+# You may redistribute only under the same terms as Perl 5, as specified
+# in the README file that comes with the distribution.
+#
+# $Log: store.t,v $
+# Revision 1.0 2000/09/01 19:40:42 ram
+# Baseline for first official release.
+#
+
+sub BEGIN {
+ chdir('t') if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+ require 'lib/st-dump.pl';
+}
+
+use Storable qw(store retrieve store_fd nstore_fd fd_retrieve);
+
+print "1..20\n";
+
+$a = 'toto';
+$b = \$a;
+$c = bless {}, CLASS;
+$c->{attribute} = 'attrval';
+%a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c);
+@a = ('first', undef, 3, -4, -3.14159, 456, 4.5,
+ $b, \$a, $a, $c, \$c, \%a);
+
+print "not " unless defined store(\@a, 'store');
+print "ok 1\n";
+
+$dumped = &dump(\@a);
+print "ok 2\n";
+
+$root = retrieve('store');
+print "not " unless defined $root;
+print "ok 3\n";
+
+$got = &dump($root);
+print "ok 4\n";
+
+print "not " unless $got eq $dumped;
+print "ok 5\n";
+
+1 while unlink 'store';
+
+package FOO; @ISA = qw(Storable);
+
+sub make {
+ my $self = bless {};
+ $self->{key} = \%main::a;
+ return $self;
+};
+
+package main;
+
+$foo = FOO->make;
+print "not " unless $foo->store('store');
+print "ok 6\n";
+
+print "not " unless open(OUT, '>>store');
+print "ok 7\n";
+binmode OUT;
+
+print "not " unless defined store_fd(\@a, ::OUT);
+print "ok 8\n";
+print "not " unless defined nstore_fd($foo, ::OUT);
+print "ok 9\n";
+print "not " unless defined nstore_fd(\%a, ::OUT);
+print "ok 10\n";
+
+print "not " unless close(OUT);
+print "ok 11\n";
+
+print "not " unless open(OUT, 'store');
+binmode OUT;
+
+$r = fd_retrieve(::OUT);
+print "not " unless defined $r;
+print "ok 12\n";
+print "not " unless &dump($foo) eq &dump($r);
+print "ok 13\n";
+
+$r = fd_retrieve(::OUT);
+print "not " unless defined $r;
+print "ok 14\n";
+print "not " unless &dump(\@a) eq &dump($r);
+print "ok 15\n";
+
+$r = fd_retrieve(main::OUT);
+print "not " unless defined $r;
+print "ok 16\n";
+print "not " unless &dump($foo) eq &dump($r);
+print "ok 17\n";
+
+$r = fd_retrieve(::OUT);
+print "not " unless defined $r;
+print "ok 18\n";
+print "not " unless &dump(\%a) eq &dump($r);
+print "ok 19\n";
+
+eval { $r = fd_retrieve(::OUT); };
+print "not " unless $@;
+print "ok 20\n";
+
+close OUT;
+END { 1 while unlink 'store' }
+
+
diff --git a/ext/Storable/t/tied.t b/ext/Storable/t/tied.t
new file mode 100644
index 0000000000..88131fea03
--- /dev/null
+++ b/ext/Storable/t/tied.t
@@ -0,0 +1,213 @@
+#!./perl
+
+# $Id: tied.t,v 1.0 2000/09/01 19:40:42 ram Exp $
+#
+# Copyright (c) 1995-2000, Raphael Manfredi
+#
+# You may redistribute only under the same terms as Perl 5, as specified
+# in the README file that comes with the distribution.
+#
+# $Log: tied.t,v $
+# Revision 1.0 2000/09/01 19:40:42 ram
+# Baseline for first official release.
+#
+
+sub BEGIN {
+ chdir('t') if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+ require 'lib/st-dump.pl';
+}
+
+sub ok;
+
+use Storable qw(freeze thaw);
+
+print "1..22\n";
+
+($scalar_fetch, $array_fetch, $hash_fetch) = (0, 0, 0);
+
+package TIED_HASH;
+
+sub TIEHASH {
+ my $self = bless {}, shift;
+ return $self;
+}
+
+sub FETCH {
+ my $self = shift;
+ my ($key) = @_;
+ $main::hash_fetch++;
+ return $self->{$key};
+}
+
+sub STORE {
+ my $self = shift;
+ my ($key, $value) = @_;
+ $self->{$key} = $value;
+}
+
+sub FIRSTKEY {
+ my $self = shift;
+ scalar keys %{$self};
+ return each %{$self};
+}
+
+sub NEXTKEY {
+ my $self = shift;
+ return each %{$self};
+}
+
+package TIED_ARRAY;
+
+sub TIEARRAY {
+ my $self = bless [], shift;
+ return $self;
+}
+
+sub FETCH {
+ my $self = shift;
+ my ($idx) = @_;
+ $main::array_fetch++;
+ return $self->[$idx];
+}
+
+sub STORE {
+ my $self = shift;
+ my ($idx, $value) = @_;
+ $self->[$idx] = $value;
+}
+
+sub FETCHSIZE {
+ my $self = shift;
+ return @{$self};
+}
+
+package TIED_SCALAR;
+
+sub TIESCALAR {
+ my $scalar;
+ my $self = bless \$scalar, shift;
+ return $self;
+}
+
+sub FETCH {
+ my $self = shift;
+ $main::scalar_fetch++;
+ return $$self;
+}
+
+sub STORE {
+ my $self = shift;
+ my ($value) = @_;
+ $$self = $value;
+}
+
+package FAULT;
+
+$fault = 0;
+
+sub TIESCALAR {
+ my $pkg = shift;
+ return bless [@_], $pkg;
+}
+
+sub FETCH {
+ my $self = shift;
+ my ($href, $key) = @$self;
+ $fault++;
+ untie $href->{$key};
+ return $href->{$key} = 1;
+}
+
+package main;
+
+$a = 'toto';
+$b = \$a;
+
+$c = tie %hash, TIED_HASH;
+$d = tie @array, TIED_ARRAY;
+tie $scalar, TIED_SCALAR;
+
+#$scalar = 'foo';
+#$hash{'attribute'} = \$d;
+#$array[0] = $c;
+#$array[1] = \$scalar;
+
+### If I say
+### $hash{'attribute'} = $d;
+### below, then dump() incorectly dumps the hash value as a string the second
+### time it is reached. I have not investigated enough to tell whether it's
+### a bug in my dump() routine or in the Perl tieing mechanism.
+$scalar = 'foo';
+$hash{'attribute'} = 'plain value';
+$array[0] = \$scalar;
+$array[1] = $c;
+$array[2] = \@array;
+
+@tied = (\$scalar, \@array, \%hash);
+%a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$a, 'scalarref', \$scalar);
+@a = ('first', 3, -4, -3.14159, 456, 4.5, $d, \$d,
+ $b, \$a, $a, $c, \$c, \%a, \@array, \%hash, \@tied);
+
+ok 1, defined($f = freeze(\@a));
+
+$dumped = &dump(\@a);
+ok 2, 1;
+
+$root = thaw($f);
+ok 3, defined $root;
+
+$got = &dump($root);
+ok 4, 1;
+
+### Used to see the manifestation of the bug documented above.
+### print "original: $dumped";
+### print "--------\n";
+### print "got: $got";
+### print "--------\n";
+
+ok 5, $got eq $dumped;
+
+$g = freeze($root);
+ok 6, length($f) == length($g);
+
+# Ensure the tied items in the retrieved image work
+@old = ($scalar_fetch, $array_fetch, $hash_fetch);
+@tied = ($tscalar, $tarray, $thash) = @{$root->[$#{$root}]};
+@type = qw(SCALAR ARRAY HASH);
+
+ok 7, tied $$tscalar;
+ok 8, tied @{$tarray};
+ok 9, tied %{$thash};
+
+@new = ($$tscalar, $tarray->[0], $thash->{'attribute'});
+@new = ($scalar_fetch, $array_fetch, $hash_fetch);
+
+# Tests 10..15
+for ($i = 0; $i < @new; $i++) {
+ print "not " unless $new[$i] == $old[$i] + 1;
+ printf "ok %d\n", 10 + 2*$i; # Tests 10,12,14
+ print "not " unless ref $tied[$i] eq $type[$i];
+ printf "ok %d\n", 11 + 2*$i; # Tests 11,13,15
+}
+
+# Check undef ties
+my $h = {};
+tie $h->{'x'}, 'FAULT', $h, 'x';
+my $hf = freeze($h);
+ok 16, defined $hf;
+ok 17, $FAULT::fault == 0;
+ok 18, $h->{'x'} == 1;
+ok 19, $FAULT::fault == 1;
+
+my $ht = thaw($hf);
+ok 20, defined $ht;
+ok 21, $ht->{'x'} == 1;
+ok 22, $FAULT::fault == 2;
+
diff --git a/ext/Storable/t/tied_hook.t b/ext/Storable/t/tied_hook.t
new file mode 100644
index 0000000000..46805cf510
--- /dev/null
+++ b/ext/Storable/t/tied_hook.t
@@ -0,0 +1,254 @@
+#!./perl
+
+# $Id: tied_hook.t,v 1.0.1.1 2001/02/17 12:29:01 ram Exp $
+#
+# Copyright (c) 1995-2000, Raphael Manfredi
+#
+# You may redistribute only under the same terms as Perl 5, as specified
+# in the README file that comes with the distribution.
+#
+# $Log: tied_hook.t,v $
+# Revision 1.0.1.1 2001/02/17 12:29:01 ram
+# patch8: added test for blessed ref to tied hash
+#
+# Revision 1.0 2000/09/01 19:40:42 ram
+# Baseline for first official release.
+#
+
+sub BEGIN {
+ chdir('t') if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+ require 'lib/st-dump.pl';
+}
+
+sub ok;
+
+use Storable qw(freeze thaw);
+
+print "1..25\n";
+
+($scalar_fetch, $array_fetch, $hash_fetch) = (0, 0, 0);
+
+package TIED_HASH;
+
+sub TIEHASH {
+ my $self = bless {}, shift;
+ return $self;
+}
+
+sub FETCH {
+ my $self = shift;
+ my ($key) = @_;
+ $main::hash_fetch++;
+ return $self->{$key};
+}
+
+sub STORE {
+ my $self = shift;
+ my ($key, $value) = @_;
+ $self->{$key} = $value;
+}
+
+sub FIRSTKEY {
+ my $self = shift;
+ scalar keys %{$self};
+ return each %{$self};
+}
+
+sub NEXTKEY {
+ my $self = shift;
+ return each %{$self};
+}
+
+sub STORABLE_freeze {
+ my $self = shift;
+ $main::hash_hook1++;
+ return join(":", keys %$self) . ";" . join(":", values %$self);
+}
+
+sub STORABLE_thaw {
+ my ($self, $cloning, $frozen) = @_;
+ my ($keys, $values) = split(/;/, $frozen);
+ my @keys = split(/:/, $keys);
+ my @values = split(/:/, $values);
+ for (my $i = 0; $i < @keys; $i++) {
+ $self->{$keys[$i]} = $values[$i];
+ }
+ $main::hash_hook2++;
+}
+
+package TIED_ARRAY;
+
+sub TIEARRAY {
+ my $self = bless [], shift;
+ return $self;
+}
+
+sub FETCH {
+ my $self = shift;
+ my ($idx) = @_;
+ $main::array_fetch++;
+ return $self->[$idx];
+}
+
+sub STORE {
+ my $self = shift;
+ my ($idx, $value) = @_;
+ $self->[$idx] = $value;
+}
+
+sub FETCHSIZE {
+ my $self = shift;
+ return @{$self};
+}
+
+sub STORABLE_freeze {
+ my $self = shift;
+ $main::array_hook1++;
+ return join(":", @$self);
+}
+
+sub STORABLE_thaw {
+ my ($self, $cloning, $frozen) = @_;
+ @$self = split(/:/, $frozen);
+ $main::array_hook2++;
+}
+
+package TIED_SCALAR;
+
+sub TIESCALAR {
+ my $scalar;
+ my $self = bless \$scalar, shift;
+ return $self;
+}
+
+sub FETCH {
+ my $self = shift;
+ $main::scalar_fetch++;
+ return $$self;
+}
+
+sub STORE {
+ my $self = shift;
+ my ($value) = @_;
+ $$self = $value;
+}
+
+sub STORABLE_freeze {
+ my $self = shift;
+ $main::scalar_hook1++;
+ return $$self;
+}
+
+sub STORABLE_thaw {
+ my ($self, $cloning, $frozen) = @_;
+ $$self = $frozen;
+ $main::scalar_hook2++;
+}
+
+package main;
+
+$a = 'toto';
+$b = \$a;
+
+$c = tie %hash, TIED_HASH;
+$d = tie @array, TIED_ARRAY;
+tie $scalar, TIED_SCALAR;
+
+$scalar = 'foo';
+$hash{'attribute'} = 'plain value';
+$array[0] = \$scalar;
+$array[1] = $c;
+$array[2] = \@array;
+$array[3] = "plaine scalaire";
+
+@tied = (\$scalar, \@array, \%hash);
+%a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$a, 'scalarref', \$scalar);
+@a = ('first', 3, -4, -3.14159, 456, 4.5, $d, \$d,
+ $b, \$a, $a, $c, \$c, \%a, \@array, \%hash, \@tied);
+
+ok 1, defined($f = freeze(\@a));
+
+$dumped = &dump(\@a);
+ok 2, 1;
+
+$root = thaw($f);
+ok 3, defined $root;
+
+$got = &dump($root);
+ok 4, 1;
+
+ok 5, $got ne $dumped; # our hooks did not handle refs in array
+
+$g = freeze($root);
+ok 6, length($f) == length($g);
+
+# Ensure the tied items in the retrieved image work
+@old = ($scalar_fetch, $array_fetch, $hash_fetch);
+@tied = ($tscalar, $tarray, $thash) = @{$root->[$#{$root}]};
+@type = qw(SCALAR ARRAY HASH);
+
+ok 7, tied $$tscalar;
+ok 8, tied @{$tarray};
+ok 9, tied %{$thash};
+
+@new = ($$tscalar, $tarray->[0], $thash->{'attribute'});
+@new = ($scalar_fetch, $array_fetch, $hash_fetch);
+
+# Tests 10..15
+for ($i = 0; $i < @new; $i++) {
+ ok 10 + 2*$i, $new[$i] == $old[$i] + 1; # Tests 10,12,14
+ ok 11 + 2*$i, ref $tied[$i] eq $type[$i]; # Tests 11,13,15
+}
+
+ok 16, $$tscalar eq 'foo';
+ok 17, $tarray->[3] eq 'plaine scalaire';
+ok 18, $thash->{'attribute'} eq 'plain value';
+
+# Ensure hooks were called
+ok 19, ($scalar_hook1 && $scalar_hook2);
+ok 20, ($array_hook1 && $array_hook2);
+ok 21, ($hash_hook1 && $hash_hook2);
+
+#
+# And now for the "blessed ref to tied hash" with "store hook" test...
+#
+
+my $bc = bless \%hash, 'FOO'; # FOO does not exist -> no hook
+my $bx = thaw freeze $bc;
+
+ok 22, ref $bx eq 'FOO';
+my $old_hash_fetch = $hash_fetch;
+my $v = $bx->{attribute};
+ok 23, $hash_fetch == $old_hash_fetch + 1; # Still tied
+
+package TIED_HASH_REF;
+
+
+sub STORABLE_freeze {
+ my ($self, $cloning) = @_;
+ return if $cloning;
+ return('ref lost');
+}
+
+sub STORABLE_thaw {
+ my ($self, $cloning, $data) = @_;
+ return if $cloning;
+}
+
+package main;
+
+$bc = bless \%hash, 'TIED_HASH_REF';
+$bx = thaw freeze $bc;
+
+ok 24, ref $bx eq 'TIED_HASH_REF';
+$old_hash_fetch = $hash_fetch;
+$v = $bx->{attribute};
+ok 25, $hash_fetch == $old_hash_fetch + 1; # Still tied
+
diff --git a/ext/Storable/t/tied_items.t b/ext/Storable/t/tied_items.t
new file mode 100644
index 0000000000..3d0abf796f
--- /dev/null
+++ b/ext/Storable/t/tied_items.t
@@ -0,0 +1,68 @@
+#!./perl
+
+# $Id: tied_items.t,v 1.0 2000/09/01 19:40:42 ram Exp $
+#
+# Copyright (c) 1995-2000, Raphael Manfredi
+#
+# You may redistribute only under the same terms as Perl 5, as specified
+# in the README file that comes with the distribution.
+#
+# $Log: tied_items.t,v $
+# Revision 1.0 2000/09/01 19:40:42 ram
+# Baseline for first official release.
+#
+
+#
+# Tests ref to items in tied hash/array structures.
+#
+
+sub BEGIN {
+ chdir('t') if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+ require 'lib/st-dump.pl';
+}
+
+sub ok;
+$^W = 0;
+
+print "1..8\n";
+
+use Storable qw(dclone);
+
+$h_fetches = 0;
+
+sub H::TIEHASH { bless \(my $x), "H" }
+sub H::FETCH { $h_fetches++; $_[1] - 70 }
+
+tie %h, "H";
+
+$ref = \$h{77};
+$ref2 = dclone $ref;
+
+ok 1, $h_fetches == 0;
+ok 2, $$ref2 eq $$ref;
+ok 3, $$ref2 == 7;
+ok 4, $h_fetches == 2;
+
+$a_fetches = 0;
+
+sub A::TIEARRAY { bless \(my $x), "A" }
+sub A::FETCH { $a_fetches++; $_[1] - 70 }
+
+tie @a, "A";
+
+$ref = \$a[78];
+$ref2 = dclone $ref;
+
+ok 5, $a_fetches == 0;
+ok 6, $$ref2 eq $$ref;
+ok 7, $$ref2 == 8;
+# I don't understand why it's 3 and not 2
+ok 8, $a_fetches == 3;
+
diff --git a/ext/Storable/t/utf8.t b/ext/Storable/t/utf8.t
new file mode 100644
index 0000000000..2160308a28
--- /dev/null
+++ b/ext/Storable/t/utf8.t
@@ -0,0 +1,40 @@
+#!./perl
+
+# $Id: utf8.t,v 1.0.1.2 2000/09/28 21:44:17 ram Exp $
+#
+# @COPYRIGHT@
+#
+# $Log: utf8.t,v $
+# Revision 1.0.1.2 2000/09/28 21:44:17 ram
+# patch2: fixed stupid typo
+#
+# Revision 1.0.1.1 2000/09/17 16:48:12 ram
+# patch1: created.
+#
+#
+
+sub BEGIN {
+ if ($] < 5.006) {
+ print "1..0 # Skip: no utf8 support\n";
+ exit 0;
+ }
+ chdir('t') if -d 't';
+ @INC = '.';
+ push @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+ require 'lib/st-dump.pl';
+}
+
+sub ok;
+
+use Storable qw(thaw freeze);
+
+print "1..1\n";
+
+$x = chr(1234);
+ok 1, $x eq ${thaw freeze \$x};
+
View Lorry Controller Status