This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fix Storable test for pre-5.19.2 threaded perls
[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     unshift @INC, 't';
24     unshift @INC, 't/compat' if $] < 5.006002;
25     require Config; import Config;
26     if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
27         print "1..0 # Skip: Storable was not built\n";
28         exit 0;
29     }
30 }
31
32 use Test::More;
33
34 use Storable qw(freeze thaw store retrieve);
35
36 {
37     %::weird_refs = (
38         REF     => \(my $aref    = []),
39         VSTRING => \(my $vstring = v1.2.3),
40        'long VSTRING' => \(my $vstring = eval "v" . 0 x 300),
41         LVALUE  => \(my $substr  = substr((my $str = "foo"), 0, 3)),
42     );
43 }
44
45 my $test = 12;
46 my $tests = $test + 23 + (2 * 6 * keys %::immortals) + (3 * keys %::weird_refs);
47 plan(tests => $tests);
48
49 package SHORT_NAME;
50
51 sub make { bless [], shift }
52
53 package SHORT_NAME_WITH_HOOK;
54
55 sub make { bless [], shift }
56
57 sub STORABLE_freeze {
58         my $self = shift;
59         return ("", $self);
60 }
61
62 sub STORABLE_thaw {
63         my $self = shift;
64         my $cloning = shift;
65         my ($x, $obj) = @_;
66         die "STORABLE_thaw" unless $obj eq $self;
67 }
68
69 package main;
70
71 # Still less than 256 bytes, so long classname logic not fully exercised
72 # Wait until Perl removes the restriction on identifier lengths.
73 my $name = "LONG_NAME_" . 'xxxxxxxxxxxxx::' x 14 . "final";
74
75 eval <<EOC;
76 package $name;
77
78 \@ISA = ("SHORT_NAME");
79 EOC
80 is($@, '');
81
82 eval <<EOC;
83 package ${name}_WITH_HOOK;
84
85 \@ISA = ("SHORT_NAME_WITH_HOOK");
86 EOC
87 is($@, '');
88
89 # Construct a pool of objects
90 my @pool;
91
92 for (my $i = 0; $i < 10; $i++) {
93         push(@pool, SHORT_NAME->make);
94         push(@pool, SHORT_NAME_WITH_HOOK->make);
95         push(@pool, $name->make);
96         push(@pool, "${name}_WITH_HOOK"->make);
97 }
98
99 my $x = freeze \@pool;
100 pass("Freeze didn't crash");
101
102 my $y = thaw $x;
103 is(ref $y, 'ARRAY');
104 is(scalar @{$y}, @pool);
105
106 is(ref $y->[0], 'SHORT_NAME');
107 is(ref $y->[1], 'SHORT_NAME_WITH_HOOK');
108 is(ref $y->[2], $name);
109 is(ref $y->[3], "${name}_WITH_HOOK");
110
111 my $good = 1;
112 for (my $i = 0; $i < 10; $i++) {
113         do { $good = 0; last } unless ref $y->[4*$i]   eq 'SHORT_NAME';
114         do { $good = 0; last } unless ref $y->[4*$i+1] eq 'SHORT_NAME_WITH_HOOK';
115         do { $good = 0; last } unless ref $y->[4*$i+2] eq $name;
116         do { $good = 0; last } unless ref $y->[4*$i+3] eq "${name}_WITH_HOOK";
117 }
118 is($good, 1);
119
120 {
121         my $blessed_ref = bless \\[1,2,3], 'Foobar';
122         my $x = freeze $blessed_ref;
123         my $y = thaw $x;
124         is(ref $y, 'Foobar');
125         is($$$y->[0], 1);
126 }
127
128 package RETURNS_IMMORTALS;
129
130 sub make { my $self = shift; bless [@_], $self }
131
132 sub STORABLE_freeze {
133   # Some reference some number of times.
134   my $self = shift;
135   my ($what, $times) = @$self;
136   return ("$what$times", ($::immortals{$what}) x $times);
137 }
138
139 sub STORABLE_thaw {
140         my $self = shift;
141         my $cloning = shift;
142         my ($x, @refs) = @_;
143         my ($what, $times) = $x =~ /(.)(\d+)/;
144         die "'$x' didn't match" unless defined $times;
145         main::is(scalar @refs, $times);
146         my $expect = $::immortals{$what};
147         die "'$x' did not give a reference" unless ref $expect;
148         my $fail;
149         foreach (@refs) {
150           $fail++ if $_ != $expect;
151         }
152         main::is($fail, undef);
153 }
154
155 package main;
156
157 # $Storable::DEBUGME = 1;
158 my $count;
159 foreach $count (1..3) {
160   my $immortal;
161   foreach $immortal (keys %::immortals) {
162     print "# $immortal x $count\n";
163     my $i =  RETURNS_IMMORTALS->make ($immortal, $count);
164
165     my $f = freeze ($i);
166     isnt($f, undef);
167     my $t = thaw $f;
168     pass("thaw didn't crash");
169   }
170 }
171
172 # Test automatic require of packages to find thaw hook.
173
174 package HAS_HOOK;
175
176 $loaded_count = 0;
177 $thawed_count = 0;
178
179 sub make {
180   bless [];
181 }
182
183 sub STORABLE_freeze {
184   my $self = shift;
185   return '';
186 }
187
188 package main;
189
190 my $f = freeze (HAS_HOOK->make);
191
192 is($HAS_HOOK::loaded_count, 0);
193 is($HAS_HOOK::thawed_count, 0);
194
195 my $t = thaw $f;
196 is($HAS_HOOK::loaded_count, 1);
197 is($HAS_HOOK::thawed_count, 1);
198 isnt($t, undef);
199 is(ref $t, 'HAS_HOOK');
200
201 delete $INC{"HAS_HOOK.pm"};
202 delete $HAS_HOOK::{STORABLE_thaw};
203
204 $t = thaw $f;
205 is($HAS_HOOK::loaded_count, 2);
206 is($HAS_HOOK::thawed_count, 2);
207 isnt($t, undef);
208 is(ref $t, 'HAS_HOOK');
209
210 {
211     package STRESS_THE_STACK;
212
213     my $stress;
214     sub make {
215         bless [];
216     }
217
218     sub no_op {
219         0;
220     }
221
222     sub STORABLE_freeze {
223         my $self = shift;
224         ++$freeze_count;
225         return no_op(1..(++$stress * 2000)) ? die "can't happen" : '';
226     }
227
228     sub STORABLE_thaw {
229         my $self = shift;
230         ++$thaw_count;
231         no_op(1..(++$stress * 2000)) && die "can't happen";
232         return;
233     }
234 }
235
236 $STRESS_THE_STACK::freeze_count = 0;
237 $STRESS_THE_STACK::thaw_count = 0;
238
239 $f = freeze (STRESS_THE_STACK->make);
240
241 is($STRESS_THE_STACK::freeze_count, 1);
242 is($STRESS_THE_STACK::thaw_count, 0);
243
244 $t = thaw $f;
245 is($STRESS_THE_STACK::freeze_count, 1);
246 is($STRESS_THE_STACK::thaw_count, 1);
247 isnt($t, undef);
248 is(ref $t, 'STRESS_THE_STACK');
249
250 my $file = "storable-testfile.$$";
251 die "Temporary file '$file' already exists" if -e $file;
252
253 END { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }}
254
255 $STRESS_THE_STACK::freeze_count = 0;
256 $STRESS_THE_STACK::thaw_count = 0;
257
258 store (STRESS_THE_STACK->make, $file);
259
260 is($STRESS_THE_STACK::freeze_count, 1);
261 is($STRESS_THE_STACK::thaw_count, 0);
262
263 $t = retrieve ($file);
264 is($STRESS_THE_STACK::freeze_count, 1);
265 is($STRESS_THE_STACK::thaw_count, 1);
266 isnt($t, undef);
267 is(ref $t, 'STRESS_THE_STACK');
268
269 {
270     package ModifyARG112358;
271     sub STORABLE_freeze { $_[0] = "foo"; }
272     my $o= {str=>bless {}};
273     my $f= ::freeze($o);
274     ::is ref $o->{str}, __PACKAGE__,
275         'assignment to $_[0] in STORABLE_freeze does not corrupt things';
276 }
277
278 # [perl #113880]
279 {
280     {
281         package WeirdRefHook;
282         sub STORABLE_freeze { () }
283         $INC{'WeirdRefHook.pm'} = __FILE__;
284     }
285
286     for my $weird (keys %weird_refs) {
287         my $obj = $weird_refs{$weird};
288         bless $obj, 'WeirdRefHook';
289         my $frozen;
290         my $success = eval { $frozen = freeze($obj); 1 };
291         ok($success, "can freeze $weird objects")
292             || diag("freezing failed: $@");
293         my $thawn = thaw($frozen);
294         # is_deeply ignores blessings
295         is ref $thawn, ref $obj, "get the right blessing back for $weird";
296         if ($weird =~ 'VSTRING') {
297             # It is not just Storable that did not support vstrings. :-)
298             # See https://rt.cpan.org/Ticket/Display.html?id=78678
299             my $newver = "version"->can("new")
300                            ? sub { "version"->new(shift) }
301                            : sub { "" };
302             if (!ok
303                   $$thawn eq $$obj && &$newver($$thawn) eq &$newver($$obj),
304                  "get the right value back"
305             ) {
306                 diag "$$thawn vs $$obj";
307                 diag &$newver($$thawn) eq &$newver($$obj) if &$newver(1);
308              }
309         }
310         else {
311             is_deeply($thawn, $obj, "get the right value back");
312         }
313     }
314 }