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 | # |
7a6a85bf | 8 | |
50621bf1 Z |
9 | BEGIN { |
10 | # Do this as the very first thing, in order to avoid problems with the | |
11 | # PADTMP flag on pre-5.19.3 threaded Perls. On those Perls, compiling | |
12 | # code that contains a constant-folded canonical truth value breaks | |
13 | # the ability to take a reference to that canonical truth value later. | |
14 | $::false = 0; | |
15 | %::immortals = ( | |
16 | 'u' => \undef, | |
17 | 'y' => \!$::false, | |
18 | 'n' => \!!$::false, | |
19 | ); | |
20 | } | |
21 | ||
7a6a85bf | 22 | sub BEGIN { |
17847ee1 RU |
23 | if ($ENV{PERL_CORE}) { |
24 | chdir 'dist/Storable' if -d 'dist/Storable'; | |
25 | @INC = ('../../lib', 't'); | |
26 | } else { | |
27 | unshift @INC, 't'; | |
28 | unshift @INC, 't/compat' if $] < 5.006002; | |
29 | } | |
9f233367 | 30 | require Config; import Config; |
0c384302 | 31 | if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { |
9f233367 PP |
32 | print "1..0 # Skip: Storable was not built\n"; |
33 | exit 0; | |
34 | } | |
7a6a85bf RG |
35 | } |
36 | ||
dddb60fc | 37 | use Test::More; |
7a6a85bf | 38 | |
06f586da | 39 | use Storable qw(freeze thaw store retrieve fd_retrieve); |
7a6a85bf | 40 | |
1cb8a344 | 41 | %::weird_refs = |
fb502597 RU |
42 | (REF => \(my $aref = []), |
43 | VSTRING => \(my $vstring = v1.2.3), | |
44 | 'long VSTRING' => \(my $lvstring = eval "v" . 0 x 300), | |
45 | LVALUE => \(my $substr = substr((my $str = "foo"), 0, 3))); | |
cc4aa37c | 46 | |
42d0708b | 47 | my $test = 18; |
06f586da | 48 | my $tests = $test + 41 + (2 * 6 * keys %::immortals) + (3 * keys %::weird_refs); |
dddb60fc | 49 | plan(tests => $tests); |
7a6a85bf RG |
50 | |
51 | package SHORT_NAME; | |
52 | ||
53 | sub make { bless [], shift } | |
54 | ||
55 | package SHORT_NAME_WITH_HOOK; | |
56 | ||
57 | sub make { bless [], shift } | |
58 | ||
59 | sub STORABLE_freeze { | |
60 | my $self = shift; | |
61 | return ("", $self); | |
62 | } | |
63 | ||
64 | sub STORABLE_thaw { | |
65 | my $self = shift; | |
66 | my $cloning = shift; | |
67 | my ($x, $obj) = @_; | |
68 | die "STORABLE_thaw" unless $obj eq $self; | |
69 | } | |
70 | ||
71 | package main; | |
72 | ||
73 | # Still less than 256 bytes, so long classname logic not fully exercised | |
1cb8a344 | 74 | # Identifier too long - 5.004 |
04ef8d9d RU |
75 | # parser.h: char tokenbuf[256]: cperl5.24 => 1024 |
76 | my $m = ($Config{usecperl} and $] >= 5.024) ? 56 : 14; | |
1cb8a344 | 77 | my $longname = "LONG_NAME_" . ('xxxxxxxxxxxxx::' x $m) . "final"; |
7a6a85bf RG |
78 | |
79 | eval <<EOC; | |
1cb8a344 | 80 | package $longname; |
7a6a85bf RG |
81 | |
82 | \@ISA = ("SHORT_NAME"); | |
83 | EOC | |
dddb60fc | 84 | is($@, ''); |
7a6a85bf RG |
85 | |
86 | eval <<EOC; | |
fb502597 | 87 | package ${longname}_WITH_HOOK; |
7a6a85bf RG |
88 | |
89 | \@ISA = ("SHORT_NAME_WITH_HOOK"); | |
90 | EOC | |
dddb60fc | 91 | is($@, ''); |
7a6a85bf RG |
92 | |
93 | # Construct a pool of objects | |
94 | my @pool; | |
7a6a85bf | 95 | for (my $i = 0; $i < 10; $i++) { |
1cb8a344 RU |
96 | push(@pool, SHORT_NAME->make); |
97 | push(@pool, SHORT_NAME_WITH_HOOK->make); | |
98 | push(@pool, $longname->make); | |
fb502597 | 99 | push(@pool, "${longname}_WITH_HOOK"->make); |
7a6a85bf RG |
100 | } |
101 | ||
102 | my $x = freeze \@pool; | |
dddb60fc | 103 | pass("Freeze didn't crash"); |
7a6a85bf RG |
104 | |
105 | my $y = thaw $x; | |
dddb60fc NC |
106 | is(ref $y, 'ARRAY'); |
107 | is(scalar @{$y}, @pool); | |
7a6a85bf | 108 | |
dddb60fc NC |
109 | is(ref $y->[0], 'SHORT_NAME'); |
110 | is(ref $y->[1], 'SHORT_NAME_WITH_HOOK'); | |
1cb8a344 | 111 | is(ref $y->[2], $longname); |
fb502597 | 112 | is(ref $y->[3], "${longname}_WITH_HOOK"); |
7a6a85bf RG |
113 | |
114 | my $good = 1; | |
115 | for (my $i = 0; $i < 10; $i++) { | |
1cb8a344 RU |
116 | do { $good = 0; last } unless ref $y->[4*$i] eq 'SHORT_NAME'; |
117 | do { $good = 0; last } unless ref $y->[4*$i+1] eq 'SHORT_NAME_WITH_HOOK'; | |
118 | do { $good = 0; last } unless ref $y->[4*$i+2] eq $longname; | |
fb502597 | 119 | do { $good = 0; last } unless ref $y->[4*$i+3] eq "${longname}_WITH_HOOK"; |
7a6a85bf | 120 | } |
dddb60fc | 121 | is($good, 1); |
87baa35a SR |
122 | |
123 | { | |
1cb8a344 RU |
124 | my $blessed_ref = bless \\[1,2,3], 'Foobar'; |
125 | my $x = freeze $blessed_ref; | |
126 | my $y = thaw $x; | |
127 | is(ref $y, 'Foobar'); | |
128 | is($$$y->[0], 1); | |
87baa35a | 129 | } |
dfd91409 NC |
130 | |
131 | package RETURNS_IMMORTALS; | |
132 | ||
133 | sub make { my $self = shift; bless [@_], $self } | |
134 | ||
135 | sub STORABLE_freeze { | |
1cb8a344 RU |
136 | # Some reference some number of times. |
137 | my $self = shift; | |
138 | my ($what, $times) = @$self; | |
139 | return ("$what$times", ($::immortals{$what}) x $times); | |
dfd91409 NC |
140 | } |
141 | ||
142 | sub STORABLE_thaw { | |
1cb8a344 RU |
143 | my $self = shift; |
144 | my $cloning = shift; | |
145 | my ($x, @refs) = @_; | |
146 | my ($what, $times) = $x =~ /(.)(\d+)/; | |
147 | die "'$x' didn't match" unless defined $times; | |
148 | main::is(scalar @refs, $times); | |
149 | my $expect = $::immortals{$what}; | |
150 | die "'$x' did not give a reference" unless ref $expect; | |
151 | my $fail; | |
152 | foreach (@refs) { | |
153 | $fail++ if $_ != $expect; | |
154 | } | |
155 | main::is($fail, undef); | |
dfd91409 NC |
156 | } |
157 | ||
158 | package main; | |
159 | ||
17ab2b3c RU |
160 | # XXX Failed tests: 15, 27, 39 with 5.12 and 5.10 threaded. |
161 | # 15: 1 fail (y x 1), 27: 2 fail (y x 2), 39: 3 fail (y x 3) | |
dfd91409 NC |
162 | # $Storable::DEBUGME = 1; |
163 | my $count; | |
164 | foreach $count (1..3) { | |
165 | my $immortal; | |
166 | foreach $immortal (keys %::immortals) { | |
167 | print "# $immortal x $count\n"; | |
168 | my $i = RETURNS_IMMORTALS->make ($immortal, $count); | |
169 | ||
170 | my $f = freeze ($i); | |
17ab2b3c RU |
171 | TODO: { |
172 | # ref sv_true is not always sv_true, at least in older threaded perls. | |
173 | local $TODO = "Some 5.10/12 do not preserve ref identity with freeze \\(1 == 1)" | |
174 | if !defined($f) and $] < 5.013 and $] > 5.009 and $immortal eq 'y'; | |
175 | isnt($f, undef); | |
176 | } | |
dfd91409 | 177 | my $t = thaw $f; |
dddb60fc | 178 | pass("thaw didn't crash"); |
dfd91409 NC |
179 | } |
180 | } | |
754c00ca NC |
181 | |
182 | # Test automatic require of packages to find thaw hook. | |
183 | ||
184 | package HAS_HOOK; | |
185 | ||
d0071613 | 186 | $loaded_count = 0; |
754c00ca NC |
187 | $thawed_count = 0; |
188 | ||
189 | sub make { | |
190 | bless []; | |
191 | } | |
192 | ||
193 | sub STORABLE_freeze { | |
194 | my $self = shift; | |
195 | return ''; | |
196 | } | |
197 | ||
198 | package main; | |
199 | ||
200 | my $f = freeze (HAS_HOOK->make); | |
201 | ||
d0071613 | 202 | is($HAS_HOOK::loaded_count, 0); |
dddb60fc | 203 | is($HAS_HOOK::thawed_count, 0); |
754c00ca NC |
204 | |
205 | my $t = thaw $f; | |
d0071613 | 206 | is($HAS_HOOK::loaded_count, 1); |
dddb60fc NC |
207 | is($HAS_HOOK::thawed_count, 1); |
208 | isnt($t, undef); | |
209 | is(ref $t, 'HAS_HOOK'); | |
754c00ca | 210 | |
9d021ad4 NC |
211 | delete $INC{"HAS_HOOK.pm"}; |
212 | delete $HAS_HOOK::{STORABLE_thaw}; | |
213 | ||
214 | $t = thaw $f; | |
d0071613 | 215 | is($HAS_HOOK::loaded_count, 2); |
dddb60fc NC |
216 | is($HAS_HOOK::thawed_count, 2); |
217 | isnt($t, undef); | |
218 | is(ref $t, 'HAS_HOOK'); | |
8e88cfee NC |
219 | |
220 | { | |
221 | package STRESS_THE_STACK; | |
222 | ||
223 | my $stress; | |
224 | sub make { | |
225 | bless []; | |
226 | } | |
227 | ||
228 | sub no_op { | |
229 | 0; | |
230 | } | |
231 | ||
232 | sub STORABLE_freeze { | |
233 | my $self = shift; | |
234 | ++$freeze_count; | |
235 | return no_op(1..(++$stress * 2000)) ? die "can't happen" : ''; | |
236 | } | |
237 | ||
238 | sub STORABLE_thaw { | |
239 | my $self = shift; | |
240 | ++$thaw_count; | |
241 | no_op(1..(++$stress * 2000)) && die "can't happen"; | |
242 | return; | |
243 | } | |
244 | } | |
245 | ||
246 | $STRESS_THE_STACK::freeze_count = 0; | |
247 | $STRESS_THE_STACK::thaw_count = 0; | |
248 | ||
249 | $f = freeze (STRESS_THE_STACK->make); | |
250 | ||
dddb60fc NC |
251 | is($STRESS_THE_STACK::freeze_count, 1); |
252 | is($STRESS_THE_STACK::thaw_count, 0); | |
8e88cfee NC |
253 | |
254 | $t = thaw $f; | |
dddb60fc NC |
255 | is($STRESS_THE_STACK::freeze_count, 1); |
256 | is($STRESS_THE_STACK::thaw_count, 1); | |
257 | isnt($t, undef); | |
258 | is(ref $t, 'STRESS_THE_STACK'); | |
8e88cfee NC |
259 | |
260 | my $file = "storable-testfile.$$"; | |
261 | die "Temporary file '$file' already exists" if -e $file; | |
262 | ||
04ef8d9d | 263 | END { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }} |
8e88cfee NC |
264 | |
265 | $STRESS_THE_STACK::freeze_count = 0; | |
266 | $STRESS_THE_STACK::thaw_count = 0; | |
267 | ||
268 | store (STRESS_THE_STACK->make, $file); | |
269 | ||
dddb60fc NC |
270 | is($STRESS_THE_STACK::freeze_count, 1); |
271 | is($STRESS_THE_STACK::thaw_count, 0); | |
8e88cfee NC |
272 | |
273 | $t = retrieve ($file); | |
dddb60fc NC |
274 | is($STRESS_THE_STACK::freeze_count, 1); |
275 | is($STRESS_THE_STACK::thaw_count, 1); | |
276 | isnt($t, undef); | |
277 | is(ref $t, 'STRESS_THE_STACK'); | |
27cc3b5a FC |
278 | |
279 | { | |
280 | package ModifyARG112358; | |
281 | sub STORABLE_freeze { $_[0] = "foo"; } | |
282 | my $o= {str=>bless {}}; | |
283 | my $f= ::freeze($o); | |
284 | ::is ref $o->{str}, __PACKAGE__, | |
285 | 'assignment to $_[0] in STORABLE_freeze does not corrupt things'; | |
286 | } | |
cc4aa37c JL |
287 | |
288 | # [perl #113880] | |
289 | { | |
290 | { | |
291 | package WeirdRefHook; | |
4ae8bca7 | 292 | sub STORABLE_freeze { () } |
cc4aa37c JL |
293 | $INC{'WeirdRefHook.pm'} = __FILE__; |
294 | } | |
295 | ||
296 | for my $weird (keys %weird_refs) { | |
297 | my $obj = $weird_refs{$weird}; | |
298 | bless $obj, 'WeirdRefHook'; | |
299 | my $frozen; | |
300 | my $success = eval { $frozen = freeze($obj); 1 }; | |
301 | ok($success, "can freeze $weird objects") | |
302 | || diag("freezing failed: $@"); | |
e00e3c3e FC |
303 | my $thawn = thaw($frozen); |
304 | # is_deeply ignores blessings | |
305 | is ref $thawn, ref $obj, "get the right blessing back for $weird"; | |
7e2a0d45 | 306 | if ($weird =~ 'VSTRING') { |
e00e3c3e FC |
307 | # It is not just Storable that did not support vstrings. :-) |
308 | # See https://rt.cpan.org/Ticket/Display.html?id=78678 | |
309 | my $newver = "version"->can("new") | |
310 | ? sub { "version"->new(shift) } | |
311 | : sub { "" }; | |
312 | if (!ok | |
313 | $$thawn eq $$obj && &$newver($$thawn) eq &$newver($$obj), | |
314 | "get the right value back" | |
315 | ) { | |
316 | diag "$$thawn vs $$obj"; | |
317 | diag &$newver($$thawn) eq &$newver($$obj) if &$newver(1); | |
318 | } | |
319 | } | |
320 | else { | |
321 | is_deeply($thawn, $obj, "get the right value back"); | |
322 | } | |
cc4aa37c JL |
323 | } |
324 | } | |
48968138 TC |
325 | |
326 | { | |
327 | # [perl #118551] | |
328 | { | |
329 | package RT118551; | |
330 | ||
331 | sub new { | |
332 | my $class = shift; | |
333 | my $string = shift; | |
334 | die 'Bad data' unless defined $string; | |
335 | my $self = { string => $string }; | |
336 | return bless $self, $class; | |
337 | } | |
338 | ||
339 | sub STORABLE_freeze { | |
340 | my $self = shift; | |
341 | my $cloning = shift; | |
342 | return if $cloning; | |
343 | return ($self->{string}); | |
344 | } | |
345 | ||
346 | sub STORABLE_attach { | |
347 | my $class = shift; | |
348 | my $cloning = shift; | |
349 | my $string = shift; | |
350 | return $class->new($string); | |
351 | } | |
352 | } | |
353 | ||
354 | my $x = [ RT118551->new('a'), RT118551->new('') ]; | |
355 | ||
356 | $y = freeze($x); | |
357 | ||
358 | ok(eval {thaw($y)}, "empty serialized") or diag $@; # <-- dies here with "Bad data" | |
359 | } | |
06f586da | 360 | |
d493784f | 361 | { |
06f586da TC |
362 | { |
363 | package FreezeHookDies; | |
364 | sub STORABLE_freeze { | |
365 | die ${$_[0]} | |
366 | } | |
367 | ||
368 | package ThawHookDies; | |
369 | sub STORABLE_freeze { | |
370 | my ($self, $cloning) = @_; | |
371 | my $tmp = $$self; | |
372 | return "a", \$tmp; | |
373 | } | |
374 | sub STORABLE_thaw { | |
375 | my ($self, $cloning, $str, $obj) = @_; | |
376 | die $$obj; | |
377 | } | |
378 | } | |
379 | my $x = bless \(my $tmpx = "Foo"), "FreezeHookDies"; | |
380 | my $y = bless \(my $tmpy = []), "FreezeHookDies"; | |
381 | ||
382 | ok(!eval { store($x, "store$$"); 1 }, "store of hook which throws no NL died"); | |
383 | ok(!eval { store($y, "store$$"); 1 }, "store of hook which throws ref died"); | |
384 | ||
385 | ok(!eval { freeze($x); 1 }, "freeze of hook which throws no NL died"); | |
386 | ok(!eval { freeze($y); 1 }, "freeze of hook which throws ref died"); | |
387 | ||
388 | ok(!eval { dclone($x); 1 }, "dclone of hook which throws no NL died"); | |
389 | ok(!eval { dclone($y); 1 }, "dclone of hook which throws ref died"); | |
390 | ||
391 | my $ostr = bless \(my $tmpstr = "Foo"), "ThawHookDies"; | |
392 | my $oref = bless \(my $tmpref = []), "ThawHookDies"; | |
393 | ok(store($ostr, "store$$"), "save throw Foo on thaw"); | |
394 | ok(!eval { retrieve("store$$"); 1 }, "retrieve of throw Foo on thaw died"); | |
395 | open FH, "<", "store$$" or die; | |
396 | binmode FH; | |
397 | ok(!eval { fd_retrieve(*FH); 1 }, "fd_retrieve of throw Foo on thaw died"); | |
398 | ok(!ref $@, "right thing thrown"); | |
399 | close FH; | |
400 | ok(store($oref, "store$$"), "save throw ref on thaw"); | |
401 | ok(!eval { retrieve("store$$"); 1 }, "retrieve of throw ref on thaw died"); | |
402 | open FH, "<", "store$$" or die; | |
403 | binmode FH; | |
404 | ok(!eval { fd_retrieve(*FH); 1 }, "fd_retrieve of throw [] on thaw died"); | |
405 | ok(ref $@, "right thing thrown"); | |
406 | close FH; | |
407 | ||
408 | my $strdata = freeze($ostr); | |
409 | ok(!eval { thaw($strdata); 1 }, "thaw of throw Foo on thaw died"); | |
410 | ok(!ref $@, "and a string thrown"); | |
411 | my $refdata = freeze($oref); | |
412 | ok(!eval { thaw($refdata); 1 }, "thaw of throw [] on thaw died"); | |
413 | ok(ref $@, "and a ref thrown"); | |
414 | ||
415 | unlink("store$$"); | |
416 | } | |
545d4990 TC |
417 | |
418 | { | |
419 | # trying to freeze a glob via STORABLE_freeze | |
420 | { | |
421 | package GlobHookedBase; | |
422 | ||
423 | sub STORABLE_freeze { | |
424 | return \1; | |
425 | } | |
426 | ||
427 | package GlobHooked; | |
428 | our @ISA = "GlobHookedBase"; | |
429 | } | |
430 | use Symbol (); | |
431 | my $glob = bless Symbol::gensym(), "GlobHooked"; | |
432 | eval { | |
433 | my $data = freeze($glob); | |
434 | }; | |
435 | my $msg = $@; | |
436 | like($msg, qr/Unexpected object type \(GLOB\) of class 'GlobHooked' in store_hook\(\) calling GlobHookedBase::STORABLE_freeze/, | |
437 | "check we get the verbose message"); | |
438 | } | |
42d0708b TC |
439 | |
440 | SKIP: | |
441 | { | |
442 | $] < 5.012 | |
443 | and skip "Can't assign regexps directly before 5.12", 4; | |
444 | my $hook_called; | |
445 | # store regexp via hook | |
446 | { | |
447 | package RegexpHooked; | |
448 | sub STORABLE_freeze { | |
449 | ++$hook_called; | |
450 | "$_[0]"; | |
451 | } | |
452 | sub STORABLE_thaw { | |
453 | my ($obj, $cloning, $serialized) = @_; | |
454 | ++$hook_called; | |
455 | $$obj = ${ qr/$serialized/ }; | |
456 | } | |
457 | } | |
458 | ||
459 | my $obj = bless qr/abc/, "RegexpHooked"; | |
460 | my $data = freeze($obj); | |
461 | ok($data, "froze regexp blessed into hooked class"); | |
462 | ok($hook_called, "and the hook was actually called"); | |
463 | $hook_called = 0; | |
464 | my $obj_thawed = thaw($data); | |
465 | ok($hook_called, "hook called for thaw"); | |
466 | like("abc", $obj_thawed, "check the regexp"); | |
467 | } |