Gecko [ www.blackthorn-inc.com ]

Name	Size	Permission	Date
HAS_ATTACH.pm	121 B	-r--r--r--	2014-12-27 11:48
HAS_HOOK.pm	82 B	-r--r--r--	2014-12-27 11:48
HAS_OVERLOAD.pm	185 B	-r--r--r--	2014-12-27 11:48
attach.t	1007 B	-r--r--r--	2014-12-27 11:48
attach_errors.t	6.65 KB	-r--r--r--	2014-12-27 11:48
attach_singleton.t	2.32 KB	-r--r--r--	2014-12-27 11:48
blessed.t	6.77 KB	-r--r--r--	2014-12-27 11:48
canonical.t	3.46 KB	-r--r--r--	2014-12-27 11:49
circular_hook.t	1.98 KB	-r--r--r--	2014-12-27 11:48
code.t	7.23 KB	-r--r--r--	2014-12-27 11:48
compat01.t	1.15 KB	-r--r--r--	2014-12-27 11:48
compat06.t	3.25 KB	-r--r--r--	2014-12-27 11:48
croak.t	949 B	-r--r--r--	2014-12-27 11:48
dclone.t	2.19 KB	-r--r--r--	2014-12-27 11:48
destroy.t	362 B	-r--r--r--	2014-12-27 11:48
downgrade.t	17.41 KB	-r--r--r--	2014-12-27 11:48
file_magic.t	13.23 KB	-r--r--r--	2014-12-27 11:48
forgive.t	1.51 KB	-r--r--r--	2014-12-27 11:48
freeze.t	2.56 KB	-r--r--r--	2014-12-27 11:48
integer.t	6.08 KB	-r--r--r--	2014-12-27 11:48
interwork56.t	5.95 KB	-r--r--r--	2014-12-27 11:48
just_plain_nasty.t	4.24 KB	-r--r--r--	2014-12-27 11:48
leaks.t	626 B	-r--r--r--	2014-12-27 11:48
lock.t	1014 B	-r--r--r--	2014-12-27 11:48
make_56_interwork.pl	1.45 KB	-r--r--r--	2014-12-27 11:48
make_downgrade.pl	2.23 KB	-r--r--r--	2014-12-27 11:48
make_overload.pl	177 B	-r--r--r--	2014-12-27 11:48
malice.t	10.3 KB	-r--r--r--	2014-12-27 11:48
overload.t	2.04 KB	-r--r--r--	2014-12-27 11:48
recurse.t	5.74 KB	-r--r--r--	2014-12-27 11:48
restrict.t	3.42 KB	-r--r--r--	2014-12-27 11:48
retrieve.t	1.34 KB	-r--r--r--	2014-12-27 11:48
robust.t	309 B	-r--r--r--	2014-12-27 11:48
sig_die.t	734 B	-r--r--r--	2014-12-27 11:48
st-dump.pl	3.35 KB	-r--r--r--	2014-12-27 11:48
store.t	1.76 KB	-r--r--r--	2014-12-27 11:48
testlib.pl	865 B	-r--r--r--	2014-12-27 11:48
threads.t	1.8 KB	-r--r--r--	2014-12-27 11:48
tied.t	4.12 KB	-r--r--r--	2014-12-27 11:48
tied_hook.t	4.59 KB	-r--r--r--	2014-12-27 11:48
tied_items.t	1.07 KB	-r--r--r--	2014-12-27 11:48
tied_store.t	924 B	-r--r--r--	2014-12-27 11:48
utf8.t	1.14 KB	-r--r--r--	2014-12-27 11:48
utf8hash.t	5.26 KB	-r--r--r--	2014-12-27 11:48
weak.t	3.46 KB	-r--r--r--	2014-12-27 11:48

Rename

#!./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 {
    unshift @INC, 't';
    unshift @INC, 't/compat' if $] < 5.006002;
    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);

use Test::More tests => 8;

# Uncomment the following 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 Digest::MD5 if its available to make random string keys

eval { require Digest::MD5; };
$gotmd5 = !$@;
diag "Will use Digest::MD5" if $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 = Digest::MD5::md5_hex($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);

cmp_ok(length $x1, '>', $hashsize);	# sanity check
is(length $x1, length $x2);		# idem
is($x1, $x2);
is($x1, $x3);

# In normal mode it is exceedingly unlikely that the frozen
# representations 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(($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};
is($$hash{''}[0], \$$hash{a});

my $cloned = dclone(dclone($hash));
is($$cloned{''}[0], \$$cloned{a});

$$cloned{a} = "blah";
is($$cloned{''}[0], \$$cloned{a});