This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Increase $Storable::VERSION to 2.35
[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 my $test = 12;
30 my $tests = $test + 22 + 2 * 6 * keys %::immortals;
31 plan(tests => $tests);
32
33 package SHORT_NAME;
34
35 sub make { bless [], shift }
36
37 package SHORT_NAME_WITH_HOOK;
38
39 sub make { bless [], shift }
40
41 sub STORABLE_freeze {
42         my $self = shift;
43         return ("", $self);
44 }
45
46 sub STORABLE_thaw {
47         my $self = shift;
48         my $cloning = shift;
49         my ($x, $obj) = @_;
50         die "STORABLE_thaw" unless $obj eq $self;
51 }
52
53 package main;
54
55 # Still less than 256 bytes, so long classname logic not fully exercised
56 # Wait until Perl removes the restriction on identifier lengths.
57 my $name = "LONG_NAME_" . 'xxxxxxxxxxxxx::' x 14 . "final";
58
59 eval <<EOC;
60 package $name;
61
62 \@ISA = ("SHORT_NAME");
63 EOC
64 is($@, '');
65
66 eval <<EOC;
67 package ${name}_WITH_HOOK;
68
69 \@ISA = ("SHORT_NAME_WITH_HOOK");
70 EOC
71 is($@, '');
72
73 # Construct a pool of objects
74 my @pool;
75
76 for (my $i = 0; $i < 10; $i++) {
77         push(@pool, SHORT_NAME->make);
78         push(@pool, SHORT_NAME_WITH_HOOK->make);
79         push(@pool, $name->make);
80         push(@pool, "${name}_WITH_HOOK"->make);
81 }
82
83 my $x = freeze \@pool;
84 pass("Freeze didn't crash");
85
86 my $y = thaw $x;
87 is(ref $y, 'ARRAY');
88 is(scalar @{$y}, @pool);
89
90 is(ref $y->[0], 'SHORT_NAME');
91 is(ref $y->[1], 'SHORT_NAME_WITH_HOOK');
92 is(ref $y->[2], $name);
93 is(ref $y->[3], "${name}_WITH_HOOK");
94
95 my $good = 1;
96 for (my $i = 0; $i < 10; $i++) {
97         do { $good = 0; last } unless ref $y->[4*$i]   eq 'SHORT_NAME';
98         do { $good = 0; last } unless ref $y->[4*$i+1] eq 'SHORT_NAME_WITH_HOOK';
99         do { $good = 0; last } unless ref $y->[4*$i+2] eq $name;
100         do { $good = 0; last } unless ref $y->[4*$i+3] eq "${name}_WITH_HOOK";
101 }
102 is($good, 1);
103
104 {
105         my $blessed_ref = bless \\[1,2,3], 'Foobar';
106         my $x = freeze $blessed_ref;
107         my $y = thaw $x;
108         is(ref $y, 'Foobar');
109         is($$$y->[0], 1);
110 }
111
112 package RETURNS_IMMORTALS;
113
114 sub make { my $self = shift; bless [@_], $self }
115
116 sub STORABLE_freeze {
117   # Some reference some number of times.
118   my $self = shift;
119   my ($what, $times) = @$self;
120   return ("$what$times", ($::immortals{$what}) x $times);
121 }
122
123 sub STORABLE_thaw {
124         my $self = shift;
125         my $cloning = shift;
126         my ($x, @refs) = @_;
127         my ($what, $times) = $x =~ /(.)(\d+)/;
128         die "'$x' didn't match" unless defined $times;
129         main::is(scalar @refs, $times);
130         my $expect = $::immortals{$what};
131         die "'$x' did not give a reference" unless ref $expect;
132         my $fail;
133         foreach (@refs) {
134           $fail++ if $_ != $expect;
135         }
136         main::is($fail, undef);
137 }
138
139 package main;
140
141 # $Storable::DEBUGME = 1;
142 my $count;
143 foreach $count (1..3) {
144   my $immortal;
145   foreach $immortal (keys %::immortals) {
146     print "# $immortal x $count\n";
147     my $i =  RETURNS_IMMORTALS->make ($immortal, $count);
148
149     my $f = freeze ($i);
150     isnt($f, undef);
151     my $t = thaw $f;
152     pass("thaw didn't crash");
153   }
154 }
155
156 # Test automatic require of packages to find thaw hook.
157
158 package HAS_HOOK;
159
160 $loaded_count = 0;
161 $thawed_count = 0;
162
163 sub make {
164   bless [];
165 }
166
167 sub STORABLE_freeze {
168   my $self = shift;
169   return '';
170 }
171
172 package main;
173
174 my $f = freeze (HAS_HOOK->make);
175
176 is($HAS_HOOK::loaded_count, 0);
177 is($HAS_HOOK::thawed_count, 0);
178
179 my $t = thaw $f;
180 is($HAS_HOOK::loaded_count, 1);
181 is($HAS_HOOK::thawed_count, 1);
182 isnt($t, undef);
183 is(ref $t, 'HAS_HOOK');
184
185 delete $INC{"HAS_HOOK.pm"};
186 delete $HAS_HOOK::{STORABLE_thaw};
187
188 $t = thaw $f;
189 is($HAS_HOOK::loaded_count, 2);
190 is($HAS_HOOK::thawed_count, 2);
191 isnt($t, undef);
192 is(ref $t, 'HAS_HOOK');
193
194 {
195     package STRESS_THE_STACK;
196
197     my $stress;
198     sub make {
199         bless [];
200     }
201
202     sub no_op {
203         0;
204     }
205
206     sub STORABLE_freeze {
207         my $self = shift;
208         ++$freeze_count;
209         return no_op(1..(++$stress * 2000)) ? die "can't happen" : '';
210     }
211
212     sub STORABLE_thaw {
213         my $self = shift;
214         ++$thaw_count;
215         no_op(1..(++$stress * 2000)) && die "can't happen";
216         return;
217     }
218 }
219
220 $STRESS_THE_STACK::freeze_count = 0;
221 $STRESS_THE_STACK::thaw_count = 0;
222
223 $f = freeze (STRESS_THE_STACK->make);
224
225 is($STRESS_THE_STACK::freeze_count, 1);
226 is($STRESS_THE_STACK::thaw_count, 0);
227
228 $t = thaw $f;
229 is($STRESS_THE_STACK::freeze_count, 1);
230 is($STRESS_THE_STACK::thaw_count, 1);
231 isnt($t, undef);
232 is(ref $t, 'STRESS_THE_STACK');
233
234 my $file = "storable-testfile.$$";
235 die "Temporary file '$file' already exists" if -e $file;
236
237 END { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }}
238
239 $STRESS_THE_STACK::freeze_count = 0;
240 $STRESS_THE_STACK::thaw_count = 0;
241
242 store (STRESS_THE_STACK->make, $file);
243
244 is($STRESS_THE_STACK::freeze_count, 1);
245 is($STRESS_THE_STACK::thaw_count, 0);
246
247 $t = retrieve ($file);
248 is($STRESS_THE_STACK::freeze_count, 1);
249 is($STRESS_THE_STACK::thaw_count, 1);
250 isnt($t, undef);
251 is(ref $t, 'STRESS_THE_STACK');