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