This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
07d17aa85961441e32c9bf530d2e225fb741281f
[perl5.git] / dist / Storable / t / blessed.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 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
22 sub BEGIN {
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     }
30     require Config; import Config;
31     if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
32         print "1..0 # Skip: Storable was not built\n";
33         exit 0;
34     }
35 }
36
37 use Test::More;
38
39 use Storable qw(freeze thaw store retrieve fd_retrieve);
40
41 %::weird_refs = 
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)));
46
47 my $test = 13;
48 my $tests = $test + 41 + (2 * 6 * keys %::immortals) + (3 * keys %::weird_refs);
49 plan(tests => $tests);
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
74 #   Identifier too long - 5.004
75 #   parser.h: char      tokenbuf[256]: cperl5.24 => 1024
76 my $m = ($Config{usecperl} and $] >= 5.024) ? 56 : 14;
77 my $longname = "LONG_NAME_" . ('xxxxxxxxxxxxx::' x $m) . "final";
78
79 eval <<EOC;
80 package $longname;
81
82 \@ISA = ("SHORT_NAME");
83 EOC
84 is($@, '');
85
86 eval <<EOC;
87 package ${longname}_WITH_HOOK;
88
89 \@ISA = ("SHORT_NAME_WITH_HOOK");
90 EOC
91 is($@, '');
92
93 # Construct a pool of objects
94 my @pool;
95 for (my $i = 0; $i < 10; $i++) {
96     push(@pool, SHORT_NAME->make);
97     push(@pool, SHORT_NAME_WITH_HOOK->make);
98     push(@pool, $longname->make);
99     push(@pool, "${longname}_WITH_HOOK"->make);
100 }
101
102 my $x = freeze \@pool;
103 pass("Freeze didn't crash");
104
105 my $y = thaw $x;
106 is(ref $y, 'ARRAY');
107 is(scalar @{$y}, @pool);
108
109 is(ref $y->[0], 'SHORT_NAME');
110 is(ref $y->[1], 'SHORT_NAME_WITH_HOOK');
111 is(ref $y->[2], $longname);
112 is(ref $y->[3], "${longname}_WITH_HOOK");
113
114 my $good = 1;
115 for (my $i = 0; $i < 10; $i++) {
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;
119     do { $good = 0; last } unless ref $y->[4*$i+3] eq "${longname}_WITH_HOOK";
120 }
121 is($good, 1);
122
123 {
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);
129 }
130
131 package RETURNS_IMMORTALS;
132
133 sub make { my $self = shift; bless [@_], $self }
134
135 sub STORABLE_freeze {
136     # Some reference some number of times.
137     my $self = shift;
138     my ($what, $times) = @$self;
139     return ("$what$times", ($::immortals{$what}) x $times);
140 }
141
142 sub STORABLE_thaw {
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);
156 }
157
158 package main;
159
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)
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);
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     }
177     my $t = thaw $f;
178     pass("thaw didn't crash");
179   }
180 }
181
182 # Test automatic require of packages to find thaw hook.
183
184 package HAS_HOOK;
185
186 $loaded_count = 0;
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
202 is($HAS_HOOK::loaded_count, 0);
203 is($HAS_HOOK::thawed_count, 0);
204
205 my $t = thaw $f;
206 is($HAS_HOOK::loaded_count, 1);
207 is($HAS_HOOK::thawed_count, 1);
208 isnt($t, undef);
209 is(ref $t, 'HAS_HOOK');
210
211 delete $INC{"HAS_HOOK.pm"};
212 delete $HAS_HOOK::{STORABLE_thaw};
213
214 $t = thaw $f;
215 is($HAS_HOOK::loaded_count, 2);
216 is($HAS_HOOK::thawed_count, 2);
217 isnt($t, undef);
218 is(ref $t, 'HAS_HOOK');
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
251 is($STRESS_THE_STACK::freeze_count, 1);
252 is($STRESS_THE_STACK::thaw_count, 0);
253
254 $t = thaw $f;
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');
259
260 my $file = "storable-testfile.$$";
261 die "Temporary file '$file' already exists" if -e $file;
262
263 END { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }}
264
265 $STRESS_THE_STACK::freeze_count = 0;
266 $STRESS_THE_STACK::thaw_count = 0;
267
268 store (STRESS_THE_STACK->make, $file);
269
270 is($STRESS_THE_STACK::freeze_count, 1);
271 is($STRESS_THE_STACK::thaw_count, 0);
272
273 $t = retrieve ($file);
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');
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 }
287
288 # [perl #113880]
289 {
290     {
291         package WeirdRefHook;
292         sub STORABLE_freeze { () }
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: $@");
303         my $thawn = thaw($frozen);
304         # is_deeply ignores blessings
305         is ref $thawn, ref $obj, "get the right blessing back for $weird";
306         if ($weird =~ 'VSTRING') {
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         }
323     }
324 }
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 }
360
361 SKIP: {
362     # These tests leak. Ignore the leaks for now: try to fix after the
363     # 5.30.0 release
364     skip("leaky under ASan", 18);
365         if (    $ENV{PERL_DESTRUCT_LEVEL} eq '2'
366              && $Config{ccflags} =~ /sanitize/
367              && $] <= 5.030)
368
369     {
370         package FreezeHookDies;
371         sub STORABLE_freeze {
372             die ${$_[0]}
373         }
374
375         package ThawHookDies;
376         sub STORABLE_freeze {
377             my ($self, $cloning) = @_;
378             my $tmp = $$self;
379             return "a", \$tmp;
380         }
381         sub STORABLE_thaw {
382             my ($self, $cloning, $str, $obj) = @_;
383             die $$obj;
384         }
385     }
386     my $x = bless \(my $tmpx = "Foo"), "FreezeHookDies";
387     my $y = bless \(my $tmpy = []), "FreezeHookDies";
388
389     ok(!eval { store($x, "store$$"); 1 }, "store of hook which throws no NL died");
390     ok(!eval { store($y, "store$$"); 1 }, "store of hook which throws ref died");
391
392     ok(!eval { freeze($x); 1 }, "freeze of hook which throws no NL died");
393     ok(!eval { freeze($y); 1 }, "freeze of hook which throws ref died");
394
395     ok(!eval { dclone($x); 1 }, "dclone of hook which throws no NL died");
396     ok(!eval { dclone($y); 1 }, "dclone of hook which throws ref died");
397
398     my $ostr = bless \(my $tmpstr = "Foo"), "ThawHookDies";
399     my $oref = bless \(my $tmpref = []), "ThawHookDies";
400     ok(store($ostr, "store$$"), "save throw Foo on thaw");
401     ok(!eval { retrieve("store$$"); 1 }, "retrieve of throw Foo on thaw died");
402     open FH, "<", "store$$" or die;
403     binmode FH;
404     ok(!eval { fd_retrieve(*FH); 1 }, "fd_retrieve of throw Foo on thaw died");
405     ok(!ref $@, "right thing thrown");
406     close FH;
407     ok(store($oref, "store$$"), "save throw ref on thaw");
408     ok(!eval { retrieve("store$$"); 1 }, "retrieve of throw ref on thaw died");
409     open FH, "<", "store$$" or die;
410     binmode FH;
411     ok(!eval { fd_retrieve(*FH); 1 }, "fd_retrieve of throw [] on thaw died");
412     ok(ref $@, "right thing thrown");
413     close FH;
414
415     my $strdata = freeze($ostr);
416     ok(!eval { thaw($strdata); 1 }, "thaw of throw Foo on thaw died");
417     ok(!ref $@, "and a string thrown");
418     my $refdata = freeze($oref);
419     ok(!eval { thaw($refdata); 1 }, "thaw of throw [] on thaw died");
420     ok(ref $@, "and a ref thrown");
421
422     unlink("store$$");
423 }