1#!./perl 2# 3# Copyright (c) 1995-2000, Raphael Manfredi 4# 5# You may redistribute only under the same terms as Perl 5, as specified 6# in the README file that comes with the distribution. 7# 8 9sub BEGIN { 10 unshift @INC, 't'; 11 unshift @INC, 't/compat' if $] < 5.006002; 12 require Config; import Config; 13 if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { 14 print "1..0 # Skip: Storable was not built\n"; 15 exit 0; 16 } 17 require 'st-dump.pl'; 18} 19 20use Storable qw(freeze nfreeze thaw); 21 22use Test::More tests => 21; 23 24$a = 'toto'; 25$b = \$a; 26$c = bless {}, CLASS; 27$c->{attribute} = $b; 28$d = {}; 29$e = []; 30$d->{'a'} = $e; 31$e->[0] = $d; 32%a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c); 33@a = ('first', undef, 3, -4, -3.14159, 456, 4.5, $d, \$d, \$e, $e, 34 $b, \$a, $a, $c, \$c, \%a); 35 36my $f1 = freeze(\@a); 37isnt($f1, undef); 38 39$dumped = &dump(\@a); 40isnt($dumped, undef); 41 42$root = thaw($f1); 43isnt($root, undef); 44 45$got = &dump($root); 46isnt($got, undef); 47 48is($got, $dumped); 49 50package FOO; @ISA = qw(Storable); 51 52sub make { 53 my $self = bless {}; 54 $self->{key} = \%main::a; 55 return $self; 56}; 57 58package main; 59 60$foo = FOO->make; 61my $f2 = $foo->freeze; 62isnt($f2, undef); 63 64my $f3 = $foo->nfreeze; 65isnt($f3, undef); 66 67$root3 = thaw($f3); 68isnt($root3, undef); 69 70is(&dump($foo), &dump($root3)); 71 72$root = thaw($f2); 73is(&dump($foo), &dump($root)); 74 75is(&dump($root3), &dump($root)); 76 77$other = freeze($root); 78is(length$other, length $f2); 79 80$root2 = thaw($other); 81is(&dump($root2), &dump($root)); 82 83$VAR1 = [ 84 'method', 85 1, 86 'prepare', 87 'SELECT table_name, table_owner, num_rows FROM iitables 88 where table_owner != \'$ingres\' and table_owner != \'DBA\'' 89]; 90 91$x = nfreeze($VAR1); 92$VAR2 = thaw($x); 93is($VAR2->[3], $VAR1->[3]); 94 95# Test the workaround for LVALUE bug in perl 5.004_04 -- from Gisle Aas 96sub foo { $_[0] = 1 } 97$foo = []; 98foo($foo->[1]); 99eval { freeze($foo) }; 100is($@, ''); 101 102# Test cleanup bug found by Claudio Garcia -- RAM, 08/06/2001 103my $thaw_me = 'asdasdasdasd'; 104 105eval { 106 my $thawed = thaw $thaw_me; 107}; 108isnt($@, ''); 109 110my %to_be_frozen = (foo => 'bar'); 111my $frozen; 112eval { 113 $frozen = freeze \%to_be_frozen; 114}; 115is($@, ''); 116 117freeze {}; 118eval { thaw $thaw_me }; 119eval { $frozen = freeze { foo => {} } }; 120is($@, ''); 121 122thaw $frozen; # used to segfault here 123pass("Didn't segfault"); 124 125SKIP: { 126 skip 'no av_exists', 2 unless $] >= 5.006; 127 my (@a, @b); 128 eval ' 129 $a = []; $#$a = 2; $a->[1] = undef; 130 $b = thaw freeze $a; 131 @a = map { ~~ exists $a->[$_] } 0 .. $#$a; 132 @b = map { ~~ exists $b->[$_] } 0 .. $#$b; 133 '; 134 is($@, ''); 135 is("@a", "@b"); 136} 137