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