Add Storable 0.7.2 from Raphael Manfredi,

plus the patch from

Subject: Re: someone with too much time and a 64-bit box and interest in Storable?
Message-ID: <Pine.LNX.4.10.10008210258160.1292-100000@busy.netsoft.ro>

plus changes to get Storable to compile with
picky ANSI compilers.

p4raw-id: //depot/perl@6734

14 files changed, 1657 insertions, 0 deletions

diff --git a/t/lib/st-06compat.t b/t/lib/st-06compat.t
new file mode 100644
index 0000000000..23245d5bd7
--- /dev/null
+++ b/t/lib/st-06compat.t
@@ -0,0 +1,123 @@
+#!./perl
+
+# $Id: compat-0.6.t,v 0.7 2000/08/03 22:04:44 ram Exp $
+#
+#  Copyright (c) 1995-2000, Raphael Manfredi
+#  
+#  You may redistribute only under the terms of the Artistic License,
+#  as specified in the README file that comes with the distribution.
+#
+# $Log: compat-0.6.t,v $
+# Revision 0.7  2000/08/03 22:04:44  ram
+# Baseline for second beta release.
+#
+
+BEGIN {
+    chdir('t') if -d 't';
+    unshift @INC, '../lib';
+    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 $r = ROOT->make;
+
+my $data = '';
+while (<DATA>) {
+	next if /^#/;
+	$data .= unpack("u", $_);
+}
+
+ok 1, length $data == 278;
+
+my $y = thaw($data);
+ok 2, 1;
+ok 3, ref $y eq 'ROOT';
+
+$Storable::canonical = 1;		# Prevent "used once" warning
+$Storable::canonical = 1;
+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%@`
diff --git a/t/lib/st-blessed.t b/t/lib/st-blessed.t
new file mode 100644
index 0000000000..22fc5263d0
--- /dev/null
+++ b/t/lib/st-blessed.t
@@ -0,0 +1,98 @@
+#!./perl
+
+# $Id: blessed.t,v 0.7 2000/08/03 22:04:44 ram Exp $
+#
+#  Copyright (c) 1995-2000, Raphael Manfredi
+#  
+#  You may redistribute only under the terms of the Artistic License,
+#  as specified in the README file that comes with the distribution.
+#
+# $Log: blessed.t,v $
+# Revision 0.7  2000/08/03 22:04:44  ram
+# Baseline for second beta release.
+#
+
+sub BEGIN {
+    chdir('t') if -d 't';
+    unshift @INC, '../lib';
+    require 'lib/st-dump.pl';
+}
+
+sub ok;
+
+use Storable qw(freeze thaw);
+
+print "1..10\n";
+
+package SHORT_NAME;
+
+sub make { bless [], shift }
+
+package SHORT_NAME_WITH_HOOK;
+
+sub make { bless [], shift }
+
+sub STORABLE_freeze {
+	my $self = shift;
+	return ("", $self);
+}
+
+sub STORABLE_thaw {
+	my $self = shift;
+	my $cloning = shift;
+	my ($x, $obj) = @_;
+	die "STORABLE_thaw" unless $obj eq $self;
+}
+
+package main;
+
+# Still less than 256 bytes, so long classname logic not fully exercised
+# Wait until Perl removes the restriction on identifier lengths.
+my $name = "LONG_NAME_" . 'xxxxxxxxxxxxx::' x 14 . "final";
+
+eval <<EOC;
+package $name;
+
+\@ISA = ("SHORT_NAME");
+EOC
+die $@ if $@;
+ok 1, $@ eq '';
+
+eval <<EOC;
+package ${name}_WITH_HOOK;
+
+\@ISA = ("SHORT_NAME_WITH_HOOK");
+EOC
+ok 2, $@ eq '';
+
+# Construct a pool of objects
+my @pool;
+
+for (my $i = 0; $i < 10; $i++) {
+	push(@pool, SHORT_NAME->make);
+	push(@pool, SHORT_NAME_WITH_HOOK->make);
+	push(@pool, $name->make);
+	push(@pool, "${name}_WITH_HOOK"->make);
+}
+
+my $x = freeze \@pool;
+ok 3, 1;
+
+my $y = thaw $x;
+ok 4, ref $y eq 'ARRAY';
+ok 5, @{$y} == @pool;
+
+ok 6, ref $y->[0] eq 'SHORT_NAME';
+ok 7, ref $y->[1] eq 'SHORT_NAME_WITH_HOOK';
+ok 8, ref $y->[2] eq $name;
+ok 9, ref $y->[3] eq "${name}_WITH_HOOK";
+
+my $good = 1;
+for (my $i = 0; $i < 10; $i++) {
+	do { $good = 0; last } unless ref $y->[4*$i]   eq 'SHORT_NAME';
+	do { $good = 0; last } unless ref $y->[4*$i+1] eq 'SHORT_NAME_WITH_HOOK';
+	do { $good = 0; last } unless ref $y->[4*$i+2] eq $name;
+	do { $good = 0; last } unless ref $y->[4*$i+3] eq "${name}_WITH_HOOK";
+}
+ok 10, $good;
+
diff --git a/t/lib/st-canonical.t b/t/lib/st-canonical.t
new file mode 100644
index 0000000000..67cd72d4da
--- /dev/null
+++ b/t/lib/st-canonical.t
@@ -0,0 +1,147 @@
+#!./perl
+
+# $Id: canonical.t,v 0.7 2000/08/03 22:04:44 ram Exp $
+#
+#  Copyright (c) 1995-2000, Raphael Manfredi
+#  
+#  You may redistribute only under the terms of the Artistic License,
+#  as specified in the README file that comes with the distribution.
+#  
+# $Log: canonical.t,v $
+# Revision 0.7  2000/08/03 22:04:44  ram
+# Baseline for second beta release.
+#
+
+sub BEGIN {
+    chdir('t') if -d 't';
+    unshift @INC, '../lib';
+}
+
+
+use Storable qw(freeze thaw dclone);
+use vars qw($debugging $verbose);
+
+print "1..8\n";
+
+sub ok {
+    my($testno, $ok) = @_;
+    print "not " unless $ok;
+    print "ok $testno\n";
+}
+
+
+# Uncomment the folowing line to get a dump of the constructed data structure
+# (you may want to reduce the size of the hashes too)
+# $debugging = 1;
+
+$hashsize = 100;
+$maxhash2size = 100;
+$maxarraysize = 100;
+
+# Use MD5 if its available to make random string keys
+
+eval { require "MD5.pm" };
+$gotmd5 = !$@;
+
+# Use Data::Dumper if debugging and it is available to create an ASCII dump
+
+if ($debugging) {
+    eval { require "Data/Dumper.pm" };
+    $gotdd  = !$@;
+}
+
+@fixed_strings = ("January", "February", "March", "April", "May", "June",
+		  "July", "August", "September", "October", "November", "December" );
+
+# Build some arbitrarily complex data structure starting with a top level hash
+# (deeper levels contain scalars, references to hashes or references to arrays);
+
+for (my $i = 0; $i < $hashsize; $i++) {
+	my($k) = int(rand(1_000_000));
+	$k = MD5->hexhash($k) if $gotmd5 and int(rand(2));
+	$a1{$k} = { key => "$k", value => $i };
+
+	# A third of the elements are references to further hashes
+
+	if (int(rand(1.5))) {
+		my($hash2) = {};
+		my($hash2size) = int(rand($maxhash2size));
+		while ($hash2size--) {
+			my($k2) = $k . $i . int(rand(100));
+			$hash2->{$k2} = $fixed_strings[rand(int(@fixed_strings))];
+		}
+		$a1{$k}->{value} = $hash2;
+	}
+
+	# A further third are references to arrays
+
+	elsif (int(rand(2))) {
+		my($arr_ref) = [];
+		my($arraysize) = int(rand($maxarraysize));
+		while ($arraysize--) {
+			push(@$arr_ref, $fixed_strings[rand(int(@fixed_strings))]);
+		}
+		$a1{$k}->{value} = $arr_ref;
+	}	
+}
+
+
+print STDERR Data::Dumper::Dumper(\%a1) if ($verbose and $gotdd);
+
+
+# Copy the hash, element by element in order of the keys
+
+foreach $k (sort keys %a1) {
+    $a2{$k} = { key => "$k", value => $a1{$k}->{value} };
+}
+
+# Deep clone the hash
+
+$a3 = dclone(\%a1);
+
+# In canonical mode the frozen representation of each of the hashes
+# should be identical
+
+$Storable::canonical = 1;
+
+$x1 = freeze(\%a1);
+$x2 = freeze(\%a2);
+$x3 = freeze($a3);
+
+ok 1, (length($x1) > $hashsize);	# sanity check
+ok 2, length($x1) == length($x2);	# idem
+ok 3, $x1 eq $x2;
+ok 4, $x1 eq $x3;
+
+# In normal mode it is exceedingly unlikely that the frozen
+# representaions of all the hashes will be the same (normally the hash
+# elements are frozen in the order they are stored internally,
+# i.e. pseudo-randomly).
+
+$Storable::canonical = 0;
+
+$x1 = freeze(\%a1);
+$x2 = freeze(\%a2);
+$x3 = freeze($a3);
+
+
+# Two out of three the same may be a coincidence, all three the same
+# is much, much more unlikely.  Still it could happen, so this test
+# may report a false negative.
+
+ok 5, ($x1 ne $x2) || ($x1 ne $x3);    
+
+
+# Ensure refs to "undef" values are properly shared
+# Same test as in t/dclone.t to ensure the "canonical" code is also correct
+
+my $hash;
+push @{$$hash{''}}, \$$hash{a};
+ok 6, $$hash{''}[0] == \$$hash{a};
+
+my $cloned = dclone(dclone($hash));
+ok 7, $$cloned{''}[0] == \$$cloned{a};
+
+$$cloned{a} = "blah";
+ok 8, $$cloned{''}[0] == \$$cloned{a};
+
diff --git a/t/lib/st-dclone.t b/t/lib/st-dclone.t
new file mode 100644
index 0000000000..95407950bc
--- /dev/null
+++ b/t/lib/st-dclone.t
@@ -0,0 +1,76 @@
+#!./perl
+
+# $Id: dclone.t,v 0.7 2000/08/03 22:04:44 ram Exp $
+#
+#  Copyright (c) 1995-2000, Raphael Manfredi
+#  
+#  You may redistribute only under the terms of the Artistic License,
+#  as specified in the README file that comes with the distribution.
+#
+# $Log: dclone.t,v $
+# Revision 0.7  2000/08/03 22:04:44  ram
+# Baseline for second beta release.
+#
+
+sub BEGIN {
+    chdir('t') if -d 't';
+    unshift @INC, '../lib';
+    require 'lib/st-dump.pl';
+}
+
+
+use Storable qw(dclone);
+
+print "1..9\n";
+
+$a = 'toto';
+$b = \$a;
+$c = bless {}, CLASS;
+$c->{attribute} = 'attrval';
+%a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c);
+@a = ('first', undef, 3, -4, -3.14159, 456, 4.5,
+	$b, \$a, $a, $c, \$c, \%a);
+
+print "not " unless defined ($aref = dclone(\@a));
+print "ok 1\n";
+
+$dumped = &dump(\@a);
+print "ok 2\n";
+
+$got = &dump($aref);
+print "ok 3\n";
+
+print "not " unless $got eq $dumped; 
+print "ok 4\n";
+
+package FOO; @ISA = qw(Storable);
+
+sub make {
+	my $self = bless {};
+	$self->{key} = \%main::a;
+	return $self;
+};
+
+package main;
+
+$foo = FOO->make;
+print "not " unless defined($r = $foo->dclone);
+print "ok 5\n";
+
+print "not " unless &dump($foo) eq &dump($r);
+print "ok 6\n";
+
+# Ensure refs to "undef" values are properly shared during cloning
+my $hash;
+push @{$$hash{''}}, \$$hash{a};
+print "not " unless $$hash{''}[0] == \$$hash{a};
+print "ok 7\n";
+
+my $cloned = dclone(dclone($hash));
+print "not " unless $$cloned{''}[0] == \$$cloned{a};
+print "ok 8\n";
+
+$$cloned{a} = "blah";
+print "not " unless $$cloned{''}[0] == \$$cloned{a};
+print "ok 9\n";
+
diff --git a/t/lib/st-dump.pl b/t/lib/st-dump.pl
new file mode 100644
index 0000000000..b9f64a450d
--- /dev/null
+++ b/t/lib/st-dump.pl
@@ -0,0 +1,146 @@
+;# $Id: dump.pl,v 0.7 2000/08/03 22:04:45 ram Exp $
+;#
+;#  Copyright (c) 1995-2000, Raphael Manfredi
+;#  
+;#  You may redistribute only under the terms of the Artistic License,
+;#  as specified in the README file that comes with the distribution.
+;#
+;# $Log: dump.pl,v $
+;# Revision 0.7  2000/08/03 22:04:45  ram
+;# Baseline for second beta release.
+;#
+
+sub ok {
+	my ($num, $ok) = @_;
+	print "not " unless $ok;
+	print "ok $num\n";
+}
+
+package dump;
+use Carp;
+
+%dump = (
+	'SCALAR'	=> '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;
diff --git a/t/lib/st-forgive.t b/t/lib/st-forgive.t
new file mode 100644
index 0000000000..1cce7c7e3a
--- /dev/null
+++ b/t/lib/st-forgive.t
@@ -0,0 +1,58 @@
+#!./perl
+
+# $Id: forgive.t,v 0.7.1.1 2000/08/03 22:04:45 ram Exp $
+#
+#  Copyright (c) 1995-2000, Raphael Manfredi
+#  
+#  You may redistribute only under the terms of the Artistic License,
+#  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 0.7.1.1  2000/08/03 22:04:45  ram
+# Baseline for second beta release.
+#
+# Revision 0.7  2000/08/03 22:04:45  ram
+# Baseline for second beta release.
+#
+
+sub BEGIN {
+    chdir('t') if -d 't';
+    unshift @INC, '../lib';
+}
+
+use Storable qw(store retrieve);
+
+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;
+
+open(SAVEERR, ">&STDERR");
+open(STDERR, ">/dev/null") 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 { unlink 'store' }
diff --git a/t/lib/st-freeze.t b/t/lib/st-freeze.t
new file mode 100644
index 0000000000..4420f11aa5
--- /dev/null
+++ b/t/lib/st-freeze.t
@@ -0,0 +1,113 @@
+#!./perl
+
+# $Id: freeze.t,v 0.7 2000/08/03 22:04:45 ram Exp $
+#
+#  Copyright (c) 1995-2000, Raphael Manfredi
+#  
+#  You may redistribute only under the terms of the Artistic License,
+#  as specified in the README file that comes with the distribution.
+#
+# $Log: freeze.t,v $
+# Revision 0.7  2000/08/03 22:04:45  ram
+# Baseline for second beta release.
+#
+
+sub BEGIN {
+    chdir('t') if -d 't';
+    unshift @INC, '../lib';
+    require 'lib/st-dump.pl';
+}
+
+
+use Storable qw(freeze nfreeze thaw);
+
+print "1..15\n";
+
+$a = 'toto';
+$b = \$a;
+$c = bless {}, CLASS;
+$c->{attribute} = $b;
+$d = {};
+$e = [];
+$d->{'a'} = $e;
+$e->[0] = $d;
+%a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c);
+@a = ('first', undef, 3, -4, -3.14159, 456, 4.5, $d, \$d, \$e, $e,
+	$b, \$a, $a, $c, \$c, \%a);
+
+print "not " unless defined ($f1 = freeze(\@a));
+print "ok 1\n";
+
+$dumped = &dump(\@a);
+print "ok 2\n";
+
+$root = thaw($f1);
+print "not " unless defined $root;
+print "ok 3\n";
+
+$got = &dump($root);
+print "ok 4\n";
+
+print "not " unless $got eq $dumped; 
+print "ok 5\n";
+
+package FOO; @ISA = qw(Storable);
+
+sub make {
+	my $self = bless {};
+	$self->{key} = \%main::a;
+	return $self;
+};
+
+package main;
+
+$foo = FOO->make;
+print "not " unless $f2 = $foo->freeze;
+print "ok 6\n";
+
+print "not " unless $f3 = $foo->nfreeze;
+print "ok 7\n";
+
+$root3 = thaw($f3);
+print "not " unless defined $root3;
+print "ok 8\n";
+
+print "not " unless &dump($foo) eq &dump($root3);
+print "ok 9\n";
+
+$root = thaw($f2);
+print "not " unless &dump($foo) eq &dump($root);
+print "ok 10\n";
+
+print "not " unless &dump($root3) eq &dump($root);
+print "ok 11\n";
+
+$other = freeze($root);
+print "not " unless length($other) == length($f2);
+print "ok 12\n";
+
+$root2 = thaw($other);
+print "not " unless &dump($root2) eq &dump($root);
+print "ok 13\n";
+
+$VAR1 = [
+	'method',
+	1,
+	'prepare',
+	'SELECT table_name, table_owner, num_rows FROM iitables
+                  where table_owner != \'$ingres\' and table_owner != \'DBA\''
+];
+
+$x = nfreeze($VAR1);
+$VAR2 = thaw($x);
+print "not " unless $VAR2->[3] eq $VAR1->[3];
+print "ok 14\n";
+
+# Test the workaround for LVALUE bug in perl 5.004_04 -- from Gisle Aas
+sub foo { $_[0] = 1 }
+$foo = [];
+foo($foo->[1]);
+eval { freeze($foo) };
+print "not " if $@;
+print "ok 15\n";
+
diff --git a/t/lib/st-overload.t b/t/lib/st-overload.t
new file mode 100644
index 0000000000..bef265ff88
--- /dev/null
+++ b/t/lib/st-overload.t
@@ -0,0 +1,49 @@
+#!./perl
+
+# $Id: overload.t,v 0.7.1.1 2000/08/13 20:10:10 ram Exp $
+#
+#  Copyright (c) 1995-2000, Raphael Manfredi
+#  
+#  You may redistribute only under the terms of the Artistic License,
+#  as specified in the README file that comes with the distribution.
+#  
+# $Log: overload.t,v $
+# Revision 0.7.1.1  2000/08/13 20:10:10  ram
+# patch1: created
+#
+
+sub BEGIN {
+    chdir('t') if -d 't';
+    unshift @INC, '../lib';
+    require 'lib/st-dump.pl';
+}
+
+sub ok;
+
+use Storable qw(freeze thaw);
+
+print "1..7\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";
+
diff --git a/t/lib/st-recurse.t b/t/lib/st-recurse.t
new file mode 100644
index 0000000000..b177677819
--- /dev/null
+++ b/t/lib/st-recurse.t
@@ -0,0 +1,177 @@
+#!./perl
+
+# $Id: recurse.t,v 0.7 2000/08/03 22:04:45 ram Exp $
+#
+#  Copyright (c) 1995-2000, Raphael Manfredi
+#  
+#  You may redistribute only under the terms of the Artistic License,
+#  as specified in the README file that comes with the distribution.
+#  
+# $Log: recurse.t,v $
+# Revision 0.7  2000/08/03 22:04:45  ram
+# Baseline for second beta release.
+#
+
+sub BEGIN {
+    chdir('t') if -d 't';
+    unshift @INC, '../lib';
+    require 'lib/st-dump.pl';
+}
+
+sub ok;
+
+use Storable qw(freeze thaw dclone);
+
+print "1..23\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 $t = dclone($self->{sync});
+	return ("", [$t, $self->{ext}], $self, $self->{ext});
+}
+
+sub STORABLE_thaw {
+	my $self = shift;
+	my ($cloning, $undef, $a, $obj, $ext) = @_;
+	die "STORABLE_thaw #1" unless $obj eq $self;
+	die "STORABLE_thaw #2" unless ref $a eq 'ARRAY';
+	$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;
diff --git a/t/lib/st-retrieve.t b/t/lib/st-retrieve.t
new file mode 100644
index 0000000000..463262f9d8
--- /dev/null
+++ b/t/lib/st-retrieve.t
@@ -0,0 +1,72 @@
+#!./perl
+
+# $Id: retrieve.t,v 0.7 2000/08/03 22:04:45 ram Exp $
+#
+#  Copyright (c) 1995-2000, Raphael Manfredi
+#  
+#  You may redistribute only under the terms of the Artistic License,
+#  as specified in the README file that comes with the distribution.
+#
+# $Log: retrieve.t,v $
+# Revision 0.7  2000/08/03 22:04:45  ram
+# Baseline for second beta release.
+#
+
+sub BEGIN {
+    chdir('t') if -d 't';
+    unshift @INC, '../lib';
+    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 { unlink 'store', 'nstore' }
+
diff --git a/t/lib/st-store.t b/t/lib/st-store.t
new file mode 100644
index 0000000000..fe76499211
--- /dev/null
+++ b/t/lib/st-store.t
@@ -0,0 +1,114 @@
+#!./perl
+
+# $Id: store.t,v 0.7 2000/08/03 22:04:45 ram Exp $
+#
+#  Copyright (c) 1995-2000, Raphael Manfredi
+#  
+#  You may redistribute only under the terms of the Artistic License,
+#  as specified in the README file that comes with the distribution.
+#
+# $Log: store.t,v $
+# Revision 0.7  2000/08/03 22:04:45  ram
+# Baseline for second beta release.
+#
+
+sub BEGIN {
+    chdir('t') if -d 't';
+    unshift @INC, '../lib';
+    require 'lib/st-dump.pl';
+}
+
+
+use Storable qw(store retrieve store_fd nstore_fd retrieve_fd);
+
+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";
+
+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 = retrieve_fd(::OUT);
+print "not " unless defined $r;
+print "ok 12\n";
+print "not " unless &dump($foo) eq &dump($r);
+print "ok 13\n";
+
+$r = retrieve_fd(::OUT);
+print "not " unless defined $r;
+print "ok 14\n";
+print "not " unless &dump(\@a) eq &dump($r);
+print "ok 15\n";
+
+$r = retrieve_fd(main::OUT);
+print "not " unless defined $r;
+print "ok 16\n";
+print "not " unless &dump($foo) eq &dump($r);
+print "ok 17\n";
+
+$r = retrieve_fd(::OUT);
+print "not " unless defined $r;
+print "ok 18\n";
+print "not " unless &dump(\%a) eq &dump($r);
+print "ok 19\n";
+
+eval { $r = retrieve_fd(::OUT); };
+print "not " unless $@;
+print "ok 20\n";
+
+close OUT;
+END { unlink 'store' }
+
+
diff --git a/t/lib/st-tied.t b/t/lib/st-tied.t
new file mode 100644
index 0000000000..52d0da919c
--- /dev/null
+++ b/t/lib/st-tied.t
@@ -0,0 +1,210 @@
+#!./perl
+
+# $Id: tied.t,v 0.7.1.1 2000/08/13 20:10:27 ram Exp $
+#
+#  Copyright (c) 1995-2000, Raphael Manfredi
+#  
+#  You may redistribute only under the terms of the Artistic License,
+#  as specified in the README file that comes with the distribution.
+#
+# $Log: tied.t,v $
+# Revision 0.7.1.1  2000/08/13 20:10:27  ram
+# patch1: added test case for "undef" in hashes
+#
+# Revision 0.7  2000/08/03 22:04:45  ram
+# Baseline for second beta release.
+#
+
+sub BEGIN {
+    chdir('t') if -d 't';
+    unshift @INC, '../lib';
+    require 'lib/st-dump.pl';
+}
+
+sub ok;
+
+use Storable qw(freeze thaw);
+
+print "1..22\n";
+
+($scalar_fetch, $array_fetch, $hash_fetch) = (0, 0, 0);
+
+package TIED_HASH;
+
+sub TIEHASH {
+	my $self = bless {}, shift;
+	return $self;
+}
+
+sub FETCH {
+	my $self = shift;
+	my ($key) = @_;
+	$main::hash_fetch++;
+	return $self->{$key};
+}
+
+sub STORE {
+	my $self = shift;
+	my ($key, $value) = @_;
+	$self->{$key} = $value;
+}
+
+sub FIRSTKEY {
+	my $self = shift;
+	scalar keys %{$self};
+	return each %{$self};
+}
+
+sub NEXTKEY {
+	my $self = shift;
+	return each %{$self};
+}
+
+package TIED_ARRAY;
+
+sub TIEARRAY {
+	my $self = bless [], shift;
+	return $self;
+}
+
+sub FETCH {
+	my $self = shift;
+	my ($idx) = @_;
+	$main::array_fetch++;
+	return $self->[$idx];
+}
+
+sub STORE {
+	my $self = shift;
+	my ($idx, $value) = @_;
+	$self->[$idx] = $value;
+}
+
+sub FETCHSIZE {
+	my $self = shift;
+	return @{$self};
+}
+
+package TIED_SCALAR;
+
+sub TIESCALAR {
+	my $scalar;
+	my $self = bless \$scalar, shift;
+	return $self;
+}
+
+sub FETCH {
+	my $self = shift;
+	$main::scalar_fetch++;
+	return $$self;
+}
+
+sub STORE {
+	my $self = shift;
+	my ($value) = @_;
+	$$self = $value;
+}
+
+package FAULT;
+
+$fault = 0;
+
+sub TIESCALAR {
+	my $pkg = shift;
+	return bless [@_], $pkg;
+}
+
+sub FETCH {
+	my $self = shift;
+	my ($href, $key) = @$self;
+	$fault++;
+	untie $href->{$key};
+	return $href->{$key} = 1;
+}
+
+package main;
+
+$a = 'toto';
+$b = \$a;
+
+$c = tie %hash, TIED_HASH;
+$d = tie @array, TIED_ARRAY;
+tie $scalar, TIED_SCALAR;
+
+#$scalar = 'foo';
+#$hash{'attribute'} = \$d;
+#$array[0] = $c;
+#$array[1] = \$scalar;
+
+### If I say
+###   $hash{'attribute'} = $d;
+### below, then dump() incorectly dumps the hash value as a string the second
+### time it is reached. I have not investigated enough to tell whether it's
+### a bug in my dump() routine or in the Perl tieing mechanism.
+$scalar = 'foo';
+$hash{'attribute'} = 'plain value';
+$array[0] = \$scalar;
+$array[1] = $c;
+$array[2] = \@array;
+
+@tied = (\$scalar, \@array, \%hash);
+%a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$a, 'scalarref', \$scalar);
+@a = ('first', 3, -4, -3.14159, 456, 4.5, $d, \$d,
+	$b, \$a, $a, $c, \$c, \%a, \@array, \%hash, \@tied);
+
+ok 1, defined($f = freeze(\@a));
+
+$dumped = &dump(\@a);
+ok 2, 1;
+
+$root = thaw($f);
+ok 3, defined $root;
+
+$got = &dump($root);
+ok 4, 1;
+
+### Used to see the manifestation of the bug documented above.
+### print "original: $dumped";
+### print "--------\n";
+### print "got: $got";
+### print "--------\n";
+
+ok 5, $got eq $dumped; 
+
+$g = freeze($root);
+ok 6, length($f) == length($g);
+
+# Ensure the tied items in the retrieved image work
+@old = ($scalar_fetch, $array_fetch, $hash_fetch);
+@tied = ($tscalar, $tarray, $thash) = @{$root->[$#{$root}]};
+@type = qw(SCALAR  ARRAY  HASH);
+
+ok 7, tied $$tscalar;
+ok 8, tied @{$tarray};
+ok 9, tied %{$thash};
+
+@new = ($$tscalar, $tarray->[0], $thash->{'attribute'});
+@new = ($scalar_fetch, $array_fetch, $hash_fetch);
+
+# Tests 10..15
+for ($i = 0; $i < @new; $i++) {
+	print "not " unless $new[$i] == $old[$i] + 1;
+	printf "ok %d\n", 10 + 2*$i;	# Tests 10,12,14
+	print "not " unless ref $tied[$i] eq $type[$i];
+	printf "ok %d\n", 11 + 2*$i;	# Tests 11,13,15
+}
+
+# Check undef ties
+my $h = {};
+tie $h->{'x'}, 'FAULT', $h, 'x';
+my $hf = freeze($h);
+ok 16, defined $hf;
+ok 17, $FAULT::fault == 0;
+ok 18, $h->{'x'} == 1;
+ok 19, $FAULT::fault == 1;
+
+my $ht = thaw($hf);
+ok 20, defined $ht;
+ok 21, $ht->{'x'} == 1;
+ok 22, $FAULT::fault == 2;
+
diff --git a/t/lib/st-tiedhook.t b/t/lib/st-tiedhook.t
new file mode 100644
index 0000000000..3f1b7fd875
--- /dev/null
+++ b/t/lib/st-tiedhook.t
@@ -0,0 +1,209 @@
+#!./perl
+
+# $Id: tied_hook.t,v 0.7 2000/08/03 22:04:45 ram Exp $
+#
+#  Copyright (c) 1995-2000, Raphael Manfredi
+#  
+#  You may redistribute only under the terms of the Artistic License,
+#  as specified in the README file that comes with the distribution.
+#
+# $Log: tied_hook.t,v $
+# Revision 0.7  2000/08/03 22:04:45  ram
+# Baseline for second beta release.
+#
+
+sub BEGIN {
+    chdir('t') if -d 't';
+    unshift @INC, '../lib';
+    require 'lib/st-dump.pl';
+}
+
+sub ok;
+
+use Storable qw(freeze thaw);
+
+print "1..21\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);
+
diff --git a/t/lib/st-tieditems.t b/t/lib/st-tieditems.t
new file mode 100644
index 0000000000..e8b127de45
--- /dev/null
+++ b/t/lib/st-tieditems.t
@@ -0,0 +1,65 @@
+#!./perl
+
+# $Id: tied_items.t,v 0.7.1.2 2000/08/14 07:20:35 ram Exp $
+#
+#  Copyright (c) 1995-2000, Raphael Manfredi
+#  
+#  You may redistribute only under the terms of the Artistic License,
+#  as specified in the README file that comes with the distribution.
+#
+# $Log: tied_items.t,v $
+# Revision 0.7.1.2  2000/08/14 07:20:35  ram
+# patch2: removed spurious dependency to Devel::Peek, used for testing only
+#
+# Revision 0.7.1.1  2000/08/13 20:10:31  ram
+# patch1: created
+#
+
+#
+# Tests ref to items in tied hash/array structures.
+#
+
+sub BEGIN {
+    chdir('t') if -d 't';
+    unshift @INC, '../lib';
+    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;
+