recurse.t revision 1.1.1.2
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} 18 19use Storable qw(freeze thaw dclone); 20use Test::More tests => 33; 21 22package OBJ_REAL; 23 24use Storable qw(freeze thaw); 25 26@x = ('a', 1); 27 28sub make { bless [], shift } 29 30sub STORABLE_freeze { 31 my $self = shift; 32 my $cloning = shift; 33 die "STORABLE_freeze" unless Storable::is_storing; 34 return (freeze(\@x), $self); 35} 36 37sub STORABLE_thaw { 38 my $self = shift; 39 my $cloning = shift; 40 my ($x, $obj) = @_; 41 die "STORABLE_thaw #1" unless $obj eq $self; 42 my $len = length $x; 43 my $a = thaw $x; 44 die "STORABLE_thaw #2" unless ref $a eq 'ARRAY'; 45 die "STORABLE_thaw #3" unless @$a == 2 && $a->[0] eq 'a' && $a->[1] == 1; 46 @$self = @$a; 47 die "STORABLE_thaw #4" unless Storable::is_retrieving; 48} 49 50package OBJ_SYNC; 51 52@x = ('a', 1); 53 54sub make { bless {}, shift } 55 56sub STORABLE_freeze { 57 my $self = shift; 58 my ($cloning) = @_; 59 return if $cloning; 60 return ("", \@x, $self); 61} 62 63sub STORABLE_thaw { 64 my $self = shift; 65 my ($cloning, $undef, $a, $obj) = @_; 66 die "STORABLE_thaw #1" unless $obj eq $self; 67 die "STORABLE_thaw #2" unless ref $a eq 'ARRAY' || @$a != 2; 68 $self->{ok} = $self; 69} 70 71package OBJ_SYNC2; 72 73use Storable qw(dclone); 74 75sub make { 76 my $self = bless {}, shift; 77 my ($ext) = @_; 78 $self->{sync} = OBJ_SYNC->make; 79 $self->{ext} = $ext; 80 return $self; 81} 82 83sub STORABLE_freeze { 84 my $self = shift; 85 my %copy = %$self; 86 my $r = \%copy; 87 my $t = dclone($r->{sync}); 88 return ("", [$t, $self->{ext}], $r, $self, $r->{ext}); 89} 90 91sub STORABLE_thaw { 92 my $self = shift; 93 my ($cloning, $undef, $a, $r, $obj, $ext) = @_; 94 die "STORABLE_thaw #1" unless $obj eq $self; 95 die "STORABLE_thaw #2" unless ref $a eq 'ARRAY'; 96 die "STORABLE_thaw #3" unless ref $r eq 'HASH'; 97 die "STORABLE_thaw #4" unless $a->[1] == $r->{ext}; 98 $self->{ok} = $self; 99 ($self->{sync}, $self->{ext}) = @$a; 100} 101 102package OBJ_REAL2; 103 104use Storable qw(freeze thaw); 105 106$MAX = 20; 107$recursed = 0; 108$hook_called = 0; 109 110sub make { bless [], shift } 111 112sub STORABLE_freeze { 113 my $self = shift; 114 $hook_called++; 115 return (freeze($self), $self) if ++$recursed < $MAX; 116 return ("no", $self); 117} 118 119sub STORABLE_thaw { 120 my $self = shift; 121 my $cloning = shift; 122 my ($x, $obj) = @_; 123 die "STORABLE_thaw #1" unless $obj eq $self; 124 $self->[0] = thaw($x) if $x ne "no"; 125 $recursed--; 126} 127 128package main; 129 130my $real = OBJ_REAL->make; 131my $x = freeze $real; 132isnt($x, undef); 133 134my $y = thaw $x; 135is(ref $y, 'OBJ_REAL'); 136is($y->[0], 'a'); 137is($y->[1], 1); 138 139my $sync = OBJ_SYNC->make; 140$x = freeze $sync; 141isnt($x, undef); 142 143$y = thaw $x; 144is(ref $y, 'OBJ_SYNC'); 145is($y->{ok}, $y); 146 147my $ext = [1, 2]; 148$sync = OBJ_SYNC2->make($ext); 149$x = freeze [$sync, $ext]; 150isnt($x, undef); 151 152my $z = thaw $x; 153$y = $z->[0]; 154is(ref $y, 'OBJ_SYNC2'); 155is($y->{ok}, $y); 156is(ref $y->{sync}, 'OBJ_SYNC'); 157is($y->{ext}, $z->[1]); 158 159$real = OBJ_REAL2->make; 160$x = freeze $real; 161isnt($x, undef); 162is($OBJ_REAL2::recursed, $OBJ_REAL2::MAX); 163is($OBJ_REAL2::hook_called, $OBJ_REAL2::MAX); 164 165$y = thaw $x; 166is(ref $y, 'OBJ_REAL2'); 167is($OBJ_REAL2::recursed, 0); 168 169$x = dclone $real; 170isnt($x, undef); 171is(ref $x, 'OBJ_REAL2'); 172is($OBJ_REAL2::recursed, 0); 173is($OBJ_REAL2::hook_called, 2 * $OBJ_REAL2::MAX); 174 175is(Storable::is_storing, ''); 176is(Storable::is_retrieving, ''); 177 178# 179# The following was a test-case that Salvador Ortiz Garcia <sog@msg.com.mx> 180# sent me, along with a proposed fix. 181# 182 183package Foo; 184 185sub new { 186 my $class = shift; 187 my $dat = shift; 188 return bless {dat => $dat}, $class; 189} 190 191package Bar; 192sub new { 193 my $class = shift; 194 return bless { 195 a => 'dummy', 196 b => [ 197 Foo->new(1), 198 Foo->new(2), # Second instance of a Foo 199 ] 200 }, $class; 201} 202 203sub STORABLE_freeze { 204 my($self,$clonning) = @_; 205 return "$self->{a}", $self->{b}; 206} 207 208sub STORABLE_thaw { 209 my($self,$clonning,$dummy,$o) = @_; 210 $self->{a} = $dummy; 211 $self->{b} = $o; 212} 213 214package main; 215 216my $bar = new Bar; 217my $bar2 = thaw freeze $bar; 218 219is(ref($bar2), 'Bar'); 220is(ref($bar->{b}[0]), 'Foo'); 221is(ref($bar->{b}[1]), 'Foo'); 222is(ref($bar2->{b}[0]), 'Foo'); 223is(ref($bar2->{b}[1]), 'Foo'); 224 225# 226# The following attempts to make sure blessed objects are blessed ASAP 227# at retrieve time. 228# 229 230package CLASS_1; 231 232sub make { 233 my $self = bless {}, shift; 234 return $self; 235} 236 237package CLASS_2; 238 239sub make { 240 my $self = bless {}, shift; 241 my ($o) = @_; 242 $self->{c1} = CLASS_1->make(); 243 $self->{o} = $o; 244 $self->{c3} = bless CLASS_1->make(), "CLASS_3"; 245 $o->set_c2($self); 246 return $self; 247} 248 249sub STORABLE_freeze { 250 my($self, $clonning) = @_; 251 return "", $self->{c1}, $self->{c3}, $self->{o}; 252} 253 254sub STORABLE_thaw { 255 my($self, $clonning, $frozen, $c1, $c3, $o) = @_; 256 main::is(ref $self, "CLASS_2"); 257 main::is(ref $c1, "CLASS_1"); 258 main::is(ref $c3, "CLASS_3"); 259 main::is(ref $o, "CLASS_OTHER"); 260 $self->{c1} = $c1; 261 $self->{c3} = $c3; 262} 263 264package CLASS_OTHER; 265 266sub make { 267 my $self = bless {}, shift; 268 return $self; 269} 270 271sub set_c2 { $_[0]->{c2} = $_[1] } 272 273# 274# Is the reference count of the extra references returned from a 275# STORABLE_freeze hook correct? [ID 20020601.005] 276# 277package Foo2; 278 279sub new { 280 my $self = bless {}, $_[0]; 281 $self->{freezed} = "$self"; 282 return $self; 283} 284 285sub DESTROY { 286 my $self = shift; 287 $::refcount_ok = 1 unless "$self" eq $self->{freezed}; 288} 289 290package Foo3; 291 292sub new { 293 bless {}, $_[0]; 294} 295 296sub STORABLE_freeze { 297 my $obj = shift; 298 return ("", $obj, Foo2->new); 299} 300 301sub STORABLE_thaw { } # Not really used 302 303package main; 304use vars qw($refcount_ok); 305 306my $o = CLASS_OTHER->make(); 307my $c2 = CLASS_2->make($o); 308my $so = thaw freeze $o; 309 310$refcount_ok = 0; 311thaw freeze(Foo3->new); 312is($refcount_ok, 1); 313