Re: [ID 20020601.005] Storable: STORABLE_freeze mechanism leaks memory (unfreed SVs)
[p5sagit/p5-mst-13.2.git] / ext / Storable / t / recurse.t
CommitLineData
7a6a85bf 1#!./perl
7a6a85bf 2#
3# Copyright (c) 1995-2000, Raphael Manfredi
4#
9e21b3d0 5# You may redistribute only under the same terms as Perl 5, as specified
6# in the README file that comes with the distribution.
7a6a85bf 7#
7a6a85bf 8
9sub BEGIN {
0c384302 10 if ($ENV{PERL_CORE}){
11 chdir('t') if -d 't';
7dadce44 12 @INC = ('.', '../lib', '../ext/Storable/t');
372cb964 13 } else {
14 unshift @INC, 't';
0c384302 15 }
9f233367 16 require Config; import Config;
0c384302 17 if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
9f233367 18 print "1..0 # Skip: Storable was not built\n";
19 exit 0;
20 }
372cb964 21 require 'st-dump.pl';
7a6a85bf 22}
23
24sub ok;
25
26use Storable qw(freeze thaw dclone);
27
5e2505e0 28print "1..33\n";
7a6a85bf 29
30package OBJ_REAL;
31
32use Storable qw(freeze thaw);
33
34@x = ('a', 1);
35
36sub make { bless [], shift }
37
38sub 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
45sub 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
58package OBJ_SYNC;
59
60@x = ('a', 1);
61
62sub make { bless {}, shift }
63
64sub STORABLE_freeze {
65 my $self = shift;
66 my ($cloning) = @_;
67 return if $cloning;
68 return ("", \@x, $self);
69}
70
71sub 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
79package OBJ_SYNC2;
80
81use Storable qw(dclone);
82
83sub make {
84 my $self = bless {}, shift;
85 my ($ext) = @_;
86 $self->{sync} = OBJ_SYNC->make;
87 $self->{ext} = $ext;
88 return $self;
89}
90
91sub STORABLE_freeze {
92 my $self = shift;
90826881 93 my %copy = %$self;
94 my $r = \%copy;
95 my $t = dclone($r->{sync});
96 return ("", [$t, $self->{ext}], $r, $self, $r->{ext});
7a6a85bf 97}
98
99sub STORABLE_thaw {
100 my $self = shift;
90826881 101 my ($cloning, $undef, $a, $r, $obj, $ext) = @_;
7a6a85bf 102 die "STORABLE_thaw #1" unless $obj eq $self;
103 die "STORABLE_thaw #2" unless ref $a eq 'ARRAY';
90826881 104 die "STORABLE_thaw #3" unless ref $r eq 'HASH';
105 die "STORABLE_thaw #4" unless $a->[1] == $r->{ext};
7a6a85bf 106 $self->{ok} = $self;
107 ($self->{sync}, $self->{ext}) = @$a;
108}
109
110package OBJ_REAL2;
111
112use Storable qw(freeze thaw);
113
114$MAX = 20;
115$recursed = 0;
116$hook_called = 0;
117
118sub make { bless [], shift }
119
120sub STORABLE_freeze {
121 my $self = shift;
122 $hook_called++;
123 return (freeze($self), $self) if ++$recursed < $MAX;
124 return ("no", $self);
125}
126
127sub 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
136package main;
137
138my $real = OBJ_REAL->make;
139my $x = freeze $real;
140ok 1, 1;
141
142my $y = thaw $x;
56d3e32d 143ok 2, ref $y eq 'OBJ_REAL';
7a6a85bf 144ok 3, $y->[0] eq 'a';
145ok 4, $y->[1] == 1;
146
147my $sync = OBJ_SYNC->make;
148$x = freeze $sync;
149ok 5, 1;
150
151$y = thaw $x;
152ok 6, 1;
153ok 7, $y->{ok} == $y;
154
155my $ext = [1, 2];
156$sync = OBJ_SYNC2->make($ext);
157$x = freeze [$sync, $ext];
158ok 8, 1;
159
160my $z = thaw $x;
161$y = $z->[0];
162ok 9, 1;
163ok 10, $y->{ok} == $y;
164ok 11, ref $y->{sync} eq 'OBJ_SYNC';
165ok 12, $y->{ext} == $z->[1];
166
167$real = OBJ_REAL2->make;
168$x = freeze $real;
169ok 13, 1;
170ok 14, $OBJ_REAL2::recursed == $OBJ_REAL2::MAX;
171ok 15, $OBJ_REAL2::hook_called == $OBJ_REAL2::MAX;
172
173$y = thaw $x;
174ok 16, 1;
175ok 17, $OBJ_REAL2::recursed == 0;
176
177$x = dclone $real;
178ok 18, 1;
179ok 19, ref $x eq 'OBJ_REAL2';
180ok 20, $OBJ_REAL2::recursed == 0;
181ok 21, $OBJ_REAL2::hook_called == 2 * $OBJ_REAL2::MAX;
182
183ok 22, !Storable::is_storing;
184ok 23, !Storable::is_retrieving;
dd19458b 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
191package Foo;
192
193sub new {
194 my $class = shift;
195 my $dat = shift;
196 return bless {dat => $dat}, $class;
197}
198
199package Bar;
200sub 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
211sub STORABLE_freeze {
212 my($self,$clonning) = @_;
213 return "$self->{a}", $self->{b};
214}
215
216sub STORABLE_thaw {
217 my($self,$clonning,$dummy,$o) = @_;
218 $self->{a} = $dummy;
219 $self->{b} = $o;
220}
221
222package main;
223
224my $bar = new Bar;
225my $bar2 = thaw freeze $bar;
226
227ok 24, ref($bar2) eq 'Bar';
228ok 25, ref($bar->{b}[0]) eq 'Foo';
229ok 26, ref($bar->{b}[1]) eq 'Foo';
230ok 27, ref($bar2->{b}[0]) eq 'Foo';
231ok 28, ref($bar2->{b}[1]) eq 'Foo';
232
b12202d0 233#
234# The following attempts to make sure blessed objects are blessed ASAP
235# at retrieve time.
236#
237
238package CLASS_1;
239
240sub make {
241 my $self = bless {}, shift;
242 return $self;
243}
244
245package CLASS_2;
246
247sub 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
257sub STORABLE_freeze {
258 my($self, $clonning) = @_;
259 return "", $self->{c1}, $self->{c3}, $self->{o};
260}
261
262sub 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
272package CLASS_OTHER;
273
274sub make {
275 my $self = bless {}, shift;
276 return $self;
277}
278
279sub set_c2 { $_[0]->{c2} = $_[1] }
280
5e2505e0 281#
282# Is the reference count of the extra references returned from a
283# STORABLE_freeze hook correct? [ID 20020601.005]
284#
285package Foo2;
286
287sub new {
288 my $self = bless {}, $_[0];
289 $self->{freezed} = "$self";
290 return $self;
291}
292
293sub DESTROY {
294 my $self = shift;
295 $::refcount_ok = 1 unless "$self" eq $self->{freezed};
296}
297
298package Foo3;
299
300sub new {
301 bless {}, $_[0];
302}
303
304sub STORABLE_freeze {
305 my $obj = shift;
306 return ("", $obj, Foo2->new);
307}
308
309sub STORABLE_thaw { } # Not really used
310
b12202d0 311package main;
5e2505e0 312use vars qw($refcount_ok);
b12202d0 313
314my $o = CLASS_OTHER->make();
315my $c2 = CLASS_2->make($o);
316my $so = thaw freeze $o;
317
5e2505e0 318$refcount_ok = 0;
319thaw freeze(Foo3->new);
320ok 33, $refcount_ok == 1;