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