Commit | Line | Data |
---|---|---|
7a6a85bf | 1 | #!./perl |
7a6a85bf RG |
2 | # |
3 | # Copyright (c) 1995-2000, Raphael Manfredi | |
4 | # | |
9e21b3d0 JH |
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 | # |
04ef8d9d | 8 | use Config; |
7a6a85bf RG |
9 | |
10 | sub BEGIN { | |
48c887dd | 11 | unshift @INC, 't'; |
1afdebce | 12 | unshift @INC, 't/compat' if $] < 5.006002; |
0c384302 | 13 | if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { |
9f233367 PP |
14 | print "1..0 # Skip: Storable was not built\n"; |
15 | exit 0; | |
16 | } | |
7a6a85bf RG |
17 | } |
18 | ||
7a6a85bf | 19 | use Storable qw(freeze thaw dclone); |
c86b4700 TR |
20 | |
21 | $Storable::flags = Storable::FLAGS_COMPAT; | |
22 | ||
120060c8 | 23 | use Test::More tests => 39; |
7a6a85bf RG |
24 | |
25 | package OBJ_REAL; | |
26 | ||
27 | use Storable qw(freeze thaw); | |
28 | ||
29 | @x = ('a', 1); | |
30 | ||
31 | sub make { bless [], shift } | |
32 | ||
33 | sub STORABLE_freeze { | |
17ab2b3c RU |
34 | my $self = shift; |
35 | my $cloning = shift; | |
36 | die "STORABLE_freeze" unless Storable::is_storing; | |
37 | return (freeze(\@x), $self); | |
7a6a85bf RG |
38 | } |
39 | ||
40 | sub STORABLE_thaw { | |
17ab2b3c RU |
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; | |
7a6a85bf RG |
51 | } |
52 | ||
53 | package OBJ_SYNC; | |
54 | ||
55 | @x = ('a', 1); | |
56 | ||
57 | sub make { bless {}, shift } | |
58 | ||
59 | sub STORABLE_freeze { | |
17ab2b3c RU |
60 | my $self = shift; |
61 | my ($cloning) = @_; | |
62 | return if $cloning; | |
63 | return ("", \@x, $self); | |
7a6a85bf RG |
64 | } |
65 | ||
66 | sub STORABLE_thaw { | |
17ab2b3c RU |
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; | |
7a6a85bf RG |
72 | } |
73 | ||
74 | package OBJ_SYNC2; | |
75 | ||
76 | use Storable qw(dclone); | |
77 | ||
78 | sub make { | |
17ab2b3c RU |
79 | my $self = bless {}, shift; |
80 | my ($ext) = @_; | |
81 | $self->{sync} = OBJ_SYNC->make; | |
82 | $self->{ext} = $ext; | |
83 | return $self; | |
7a6a85bf RG |
84 | } |
85 | ||
86 | sub STORABLE_freeze { | |
17ab2b3c RU |
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}); | |
7a6a85bf RG |
92 | } |
93 | ||
94 | sub STORABLE_thaw { | |
17ab2b3c RU |
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; | |
7a6a85bf RG |
103 | } |
104 | ||
105 | package OBJ_REAL2; | |
106 | ||
107 | use Storable qw(freeze thaw); | |
108 | ||
109 | $MAX = 20; | |
110 | $recursed = 0; | |
111 | $hook_called = 0; | |
112 | ||
113 | sub make { bless [], shift } | |
114 | ||
115 | sub STORABLE_freeze { | |
17ab2b3c RU |
116 | my $self = shift; |
117 | $hook_called++; | |
118 | return (freeze($self), $self) if ++$recursed < $MAX; | |
119 | return ("no", $self); | |
7a6a85bf RG |
120 | } |
121 | ||
122 | sub STORABLE_thaw { | |
17ab2b3c RU |
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--; | |
7a6a85bf RG |
129 | } |
130 | ||
131 | package main; | |
132 | ||
133 | my $real = OBJ_REAL->make; | |
134 | my $x = freeze $real; | |
dddb60fc | 135 | isnt($x, undef); |
7a6a85bf RG |
136 | |
137 | my $y = thaw $x; | |
dddb60fc NC |
138 | is(ref $y, 'OBJ_REAL'); |
139 | is($y->[0], 'a'); | |
140 | is($y->[1], 1); | |
7a6a85bf RG |
141 | |
142 | my $sync = OBJ_SYNC->make; | |
143 | $x = freeze $sync; | |
dddb60fc | 144 | isnt($x, undef); |
7a6a85bf RG |
145 | |
146 | $y = thaw $x; | |
dddb60fc NC |
147 | is(ref $y, 'OBJ_SYNC'); |
148 | is($y->{ok}, $y); | |
7a6a85bf RG |
149 | |
150 | my $ext = [1, 2]; | |
151 | $sync = OBJ_SYNC2->make($ext); | |
152 | $x = freeze [$sync, $ext]; | |
dddb60fc | 153 | isnt($x, undef); |
7a6a85bf RG |
154 | |
155 | my $z = thaw $x; | |
156 | $y = $z->[0]; | |
dddb60fc NC |
157 | is(ref $y, 'OBJ_SYNC2'); |
158 | is($y->{ok}, $y); | |
159 | is(ref $y->{sync}, 'OBJ_SYNC'); | |
160 | is($y->{ext}, $z->[1]); | |
7a6a85bf RG |
161 | |
162 | $real = OBJ_REAL2->make; | |
163 | $x = freeze $real; | |
dddb60fc NC |
164 | isnt($x, undef); |
165 | is($OBJ_REAL2::recursed, $OBJ_REAL2::MAX); | |
166 | is($OBJ_REAL2::hook_called, $OBJ_REAL2::MAX); | |
7a6a85bf RG |
167 | |
168 | $y = thaw $x; | |
dddb60fc NC |
169 | is(ref $y, 'OBJ_REAL2'); |
170 | is($OBJ_REAL2::recursed, 0); | |
7a6a85bf RG |
171 | |
172 | $x = dclone $real; | |
dddb60fc NC |
173 | isnt($x, undef); |
174 | is(ref $x, 'OBJ_REAL2'); | |
175 | is($OBJ_REAL2::recursed, 0); | |
176 | is($OBJ_REAL2::hook_called, 2 * $OBJ_REAL2::MAX); | |
7a6a85bf | 177 | |
dddb60fc NC |
178 | is(Storable::is_storing, ''); |
179 | is(Storable::is_retrieving, ''); | |
dd19458b JH |
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 | ||
186 | package Foo; | |
187 | ||
188 | sub new { | |
17ab2b3c RU |
189 | my $class = shift; |
190 | my $dat = shift; | |
191 | return bless {dat => $dat}, $class; | |
dd19458b JH |
192 | } |
193 | ||
194 | package Bar; | |
195 | sub new { | |
17ab2b3c RU |
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; | |
dd19458b JH |
204 | } |
205 | ||
206 | sub STORABLE_freeze { | |
17ab2b3c RU |
207 | my($self,$clonning) = @_; |
208 | return "$self->{a}", $self->{b}; | |
dd19458b JH |
209 | } |
210 | ||
211 | sub STORABLE_thaw { | |
17ab2b3c RU |
212 | my($self,$clonning,$dummy,$o) = @_; |
213 | $self->{a} = $dummy; | |
214 | $self->{b} = $o; | |
dd19458b JH |
215 | } |
216 | ||
217 | package main; | |
218 | ||
219 | my $bar = new Bar; | |
220 | my $bar2 = thaw freeze $bar; | |
221 | ||
dddb60fc NC |
222 | is(ref($bar2), 'Bar'); |
223 | is(ref($bar->{b}[0]), 'Foo'); | |
224 | is(ref($bar->{b}[1]), 'Foo'); | |
225 | is(ref($bar2->{b}[0]), 'Foo'); | |
226 | is(ref($bar2->{b}[1]), 'Foo'); | |
dd19458b | 227 | |
b12202d0 JH |
228 | # |
229 | # The following attempts to make sure blessed objects are blessed ASAP | |
230 | # at retrieve time. | |
231 | # | |
232 | ||
233 | package CLASS_1; | |
234 | ||
235 | sub make { | |
17ab2b3c RU |
236 | my $self = bless {}, shift; |
237 | return $self; | |
b12202d0 JH |
238 | } |
239 | ||
240 | package CLASS_2; | |
241 | ||
242 | sub make { | |
17ab2b3c RU |
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; | |
b12202d0 JH |
250 | } |
251 | ||
252 | sub STORABLE_freeze { | |
17ab2b3c RU |
253 | my($self, $clonning) = @_; |
254 | return "", $self->{c1}, $self->{c3}, $self->{o}; | |
b12202d0 JH |
255 | } |
256 | ||
257 | sub STORABLE_thaw { | |
17ab2b3c RU |
258 | my($self, $clonning, $frozen, $c1, $c3, $o) = @_; |
259 | main::is(ref $self, "CLASS_2"); | |
260 | main::is(ref $c1, "CLASS_1"); | |
261 | main::is(ref $c3, "CLASS_3"); | |
262 | main::is(ref $o, "CLASS_OTHER"); | |
263 | $self->{c1} = $c1; | |
264 | $self->{c3} = $c3; | |
b12202d0 JH |
265 | } |
266 | ||
267 | package CLASS_OTHER; | |
268 | ||
269 | sub make { | |
17ab2b3c RU |
270 | my $self = bless {}, shift; |
271 | return $self; | |
b12202d0 JH |
272 | } |
273 | ||
274 | sub set_c2 { $_[0]->{c2} = $_[1] } | |
275 | ||
5e2505e0 RG |
276 | # |
277 | # Is the reference count of the extra references returned from a | |
126fe723 | 278 | # STORABLE_freeze hook correct? [ID 20020601.005 (#9436)] |
5e2505e0 RG |
279 | # |
280 | package Foo2; | |
281 | ||
282 | sub new { | |
17ab2b3c RU |
283 | my $self = bless {}, $_[0]; |
284 | $self->{freezed} = "$self"; | |
285 | return $self; | |
5e2505e0 RG |
286 | } |
287 | ||
288 | sub DESTROY { | |
17ab2b3c RU |
289 | my $self = shift; |
290 | $::refcount_ok = 1 unless "$self" eq $self->{freezed}; | |
5e2505e0 RG |
291 | } |
292 | ||
293 | package Foo3; | |
294 | ||
295 | sub new { | |
17ab2b3c | 296 | bless {}, $_[0]; |
5e2505e0 RG |
297 | } |
298 | ||
299 | sub STORABLE_freeze { | |
17ab2b3c RU |
300 | my $obj = shift; |
301 | return ("", $obj, Foo2->new); | |
5e2505e0 RG |
302 | } |
303 | ||
304 | sub STORABLE_thaw { } # Not really used | |
305 | ||
b12202d0 JH |
306 | package main; |
307 | ||
308 | my $o = CLASS_OTHER->make(); | |
309 | my $c2 = CLASS_2->make($o); | |
310 | my $so = thaw freeze $o; | |
311 | ||
1a58b39a | 312 | our $refcount_ok = 0; |
5e2505e0 | 313 | thaw freeze(Foo3->new); |
c0e3b4b5 | 314 | is($refcount_ok, 1, "check refcount"); |
17ab2b3c RU |
315 | |
316 | # Check stack overflows [cpan #97526] | |
04ef8d9d RU |
317 | # JSON::XS limits this to 512. |
318 | # Small 64bit systems fail with 1200 (c++ debugging), with gcc 3000. | |
319 | # Optimized 64bit allows up to 33.000 recursion depth. | |
320 | # with asan the limit is 255 though. | |
2a0bbd31 TC |
321 | |
322 | local $Storable::recursion_limit = 30; | |
323 | local $Storable::recursion_limit_hash = 20; | |
04ef8d9d RU |
324 | sub MAX_DEPTH () { Storable::stack_depth() } |
325 | sub MAX_DEPTH_HASH () { Storable::stack_depth_hash() } | |
17ab2b3c RU |
326 | { |
327 | my $t; | |
c0e3b4b5 | 328 | print "# max depth ", MAX_DEPTH, "\n"; |
04ef8d9d | 329 | $t = [$t] for 1 .. MAX_DEPTH; |
17ab2b3c | 330 | dclone $t; |
04ef8d9d | 331 | pass "can nest ".MAX_DEPTH." array refs"; |
17ab2b3c RU |
332 | } |
333 | { | |
334 | my $t; | |
04ef8d9d | 335 | $t = {1=>$t} for 1 .. MAX_DEPTH_HASH-10; |
17ab2b3c | 336 | dclone $t; |
04ef8d9d | 337 | pass "can nest ".(MAX_DEPTH_HASH)." hash refs"; |
17ab2b3c RU |
338 | } |
339 | { | |
4f79e9d7 RU |
340 | my (@t); |
341 | push @t, [{}] for 1..5000; | |
342 | #diag 'trying simple array[5000] stack overflow, no recursion'; | |
343 | dclone \@t; | |
344 | is $@, '', 'No simple array[5000] stack overflow #257'; | |
345 | } | |
04ef8d9d | 346 | |
dd7f75e0 RU |
347 | eval { |
348 | my $t; | |
c0e3b4b5 | 349 | $t = [$t] for 1 .. MAX_DEPTH*2; |
2d572b08 | 350 | eval { note('trying catching recursive aref stack overflow') }; |
dd7f75e0 RU |
351 | dclone $t; |
352 | }; | |
353 | like $@, qr/Max\. recursion depth with nested structures exceeded/, | |
c0e3b4b5 | 354 | 'Caught aref stack overflow '.MAX_DEPTH*2; |
81c9046e RU |
355 | |
356 | if ($ENV{APPVEYOR} and length(pack "p", "") >= 8) { | |
357 | # TODO: need to repro this fail on a small machine. | |
358 | ok(1, "skip dclone of big hash"); | |
359 | } | |
360 | else { | |
17ab2b3c RU |
361 | eval { |
362 | my $t; | |
04ef8d9d | 363 | # 35.000 will cause appveyor 64bit windows to fail earlier |
c0e3b4b5 | 364 | $t = {1=>$t} for 1 .. MAX_DEPTH * 2; |
2d572b08 | 365 | eval { note('trying catching recursive href stack overflow') }; |
17ab2b3c RU |
366 | dclone $t; |
367 | }; | |
368 | like $@, qr/Max\. recursion depth with nested structures exceeded/, | |
120060c8 TC |
369 | 'Caught href stack overflow '.MAX_DEPTH_HASH*2; |
370 | } | |
371 | ||
372 | { | |
373 | # perl #133326 | |
374 | my @tt; | |
375 | #$Storable::DEBUGME=1; | |
376 | for (1..16000) { | |
377 | my $t = [[[]]]; | |
378 | push @tt, $t; | |
379 | } | |
380 | ok(eval { dclone \@tt; 1 }, | |
381 | "low depth structure shouldn't be treated as nested"); | |
17ab2b3c | 382 | } |