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