Re: [Another bug] Re: about Storable perl module (again)
[p5sagit/p5-mst-13.2.git] / ext / Storable / t / recurse.t
1 #!./perl
2
3 # $Id: recurse.t,v 1.0.1.3 2001/02/17 12:28:33 ram Exp $
4 #
5 #  Copyright (c) 1995-2000, Raphael Manfredi
6 #  
7 #  You may redistribute only under the same terms as Perl 5, as specified
8 #  in the README file that comes with the distribution.
9 #  
10 # $Log: recurse.t,v $
11 # Revision 1.0.1.3  2001/02/17 12:28:33  ram
12 # patch8: ensure blessing occurs ASAP, specially designed for hooks
13 #
14 # Revision 1.0.1.2  2000/11/05 17:22:05  ram
15 # patch6: stress hook a little more with refs to lexicals
16 #
17 # $Log: recurse.t,v $
18 # Revision 1.0.1.1  2000/09/17 16:48:05  ram
19 # patch1: added test case for store hook bug
20 #
21 # $Log: recurse.t,v $
22 # Revision 1.0  2000/09/01 19:40:42  ram
23 # Baseline for first official release.
24 #
25
26 sub BEGIN {
27     if ($ENV{PERL_CORE}){
28         chdir('t') if -d 't';
29         @INC = ('.', '../lib', '../ext/Storable/t');
30     } else {
31         unshift @INC, 't';
32     }
33     require Config; import Config;
34     if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
35         print "1..0 # Skip: Storable was not built\n";
36         exit 0;
37     }
38     require 'st-dump.pl';
39 }
40
41 sub ok;
42
43 use Storable qw(freeze thaw dclone);
44
45 print "1..32\n";
46
47 package OBJ_REAL;
48
49 use Storable qw(freeze thaw);
50
51 @x = ('a', 1);
52
53 sub make { bless [], shift }
54
55 sub STORABLE_freeze {
56         my $self = shift;
57         my $cloning = shift;
58         die "STORABLE_freeze" unless Storable::is_storing;
59         return (freeze(\@x), $self);
60 }
61
62 sub STORABLE_thaw {
63         my $self = shift;
64         my $cloning = shift;
65         my ($x, $obj) = @_;
66         die "STORABLE_thaw #1" unless $obj eq $self;
67         my $len = length $x;
68         my $a = thaw $x;
69         die "STORABLE_thaw #2" unless ref $a eq 'ARRAY';
70         die "STORABLE_thaw #3" unless @$a == 2 && $a->[0] eq 'a' && $a->[1] == 1;
71         @$self = @$a;
72         die "STORABLE_thaw #4" unless Storable::is_retrieving;
73 }
74
75 package OBJ_SYNC;
76
77 @x = ('a', 1);
78
79 sub make { bless {}, shift }
80
81 sub STORABLE_freeze {
82         my $self = shift;
83         my ($cloning) = @_;
84         return if $cloning;
85         return ("", \@x, $self);
86 }
87
88 sub STORABLE_thaw {
89         my $self = shift;
90         my ($cloning, $undef, $a, $obj) = @_;
91         die "STORABLE_thaw #1" unless $obj eq $self;
92         die "STORABLE_thaw #2" unless ref $a eq 'ARRAY' || @$a != 2;
93         $self->{ok} = $self;
94 }
95
96 package OBJ_SYNC2;
97
98 use Storable qw(dclone);
99
100 sub make {
101         my $self = bless {}, shift;
102         my ($ext) = @_;
103         $self->{sync} = OBJ_SYNC->make;
104         $self->{ext} = $ext;
105         return $self;
106 }
107
108 sub STORABLE_freeze {
109         my $self = shift;
110         my %copy = %$self;
111         my $r = \%copy;
112         my $t = dclone($r->{sync});
113         return ("", [$t, $self->{ext}], $r, $self, $r->{ext});
114 }
115
116 sub STORABLE_thaw {
117         my $self = shift;
118         my ($cloning, $undef, $a, $r, $obj, $ext) = @_;
119         die "STORABLE_thaw #1" unless $obj eq $self;
120         die "STORABLE_thaw #2" unless ref $a eq 'ARRAY';
121         die "STORABLE_thaw #3" unless ref $r eq 'HASH';
122         die "STORABLE_thaw #4" unless $a->[1] == $r->{ext};
123         $self->{ok} = $self;
124         ($self->{sync}, $self->{ext}) = @$a;
125 }
126
127 package OBJ_REAL2;
128
129 use Storable qw(freeze thaw);
130
131 $MAX = 20;
132 $recursed = 0;
133 $hook_called = 0;
134
135 sub make { bless [], shift }
136
137 sub STORABLE_freeze {
138         my $self = shift;
139         $hook_called++;
140         return (freeze($self), $self) if ++$recursed < $MAX;
141         return ("no", $self);
142 }
143
144 sub STORABLE_thaw {
145         my $self = shift;
146         my $cloning = shift;
147         my ($x, $obj) = @_;
148         die "STORABLE_thaw #1" unless $obj eq $self;
149         $self->[0] = thaw($x) if $x ne "no";
150         $recursed--;
151 }
152
153 package main;
154
155 my $real = OBJ_REAL->make;
156 my $x = freeze $real;
157 ok 1, 1;
158
159 my $y = thaw $x;
160 ok 2, 1;
161 ok 3, $y->[0] eq 'a';
162 ok 4, $y->[1] == 1;
163
164 my $sync = OBJ_SYNC->make;
165 $x = freeze $sync;
166 ok 5, 1;
167
168 $y = thaw $x;
169 ok 6, 1;
170 ok 7, $y->{ok} == $y;
171
172 my $ext = [1, 2];
173 $sync = OBJ_SYNC2->make($ext);
174 $x = freeze [$sync, $ext];
175 ok 8, 1;
176
177 my $z = thaw $x;
178 $y = $z->[0];
179 ok 9, 1;
180 ok 10, $y->{ok} == $y;
181 ok 11, ref $y->{sync} eq 'OBJ_SYNC';
182 ok 12, $y->{ext} == $z->[1];
183
184 $real = OBJ_REAL2->make;
185 $x = freeze $real;
186 ok 13, 1;
187 ok 14, $OBJ_REAL2::recursed == $OBJ_REAL2::MAX;
188 ok 15, $OBJ_REAL2::hook_called == $OBJ_REAL2::MAX;
189
190 $y = thaw $x;
191 ok 16, 1;
192 ok 17, $OBJ_REAL2::recursed == 0;
193
194 $x = dclone $real;
195 ok 18, 1;
196 ok 19, ref $x eq 'OBJ_REAL2';
197 ok 20, $OBJ_REAL2::recursed == 0;
198 ok 21, $OBJ_REAL2::hook_called == 2 * $OBJ_REAL2::MAX;
199
200 ok 22, !Storable::is_storing;
201 ok 23, !Storable::is_retrieving;
202
203 #
204 # The following was a test-case that Salvador Ortiz Garcia <sog@msg.com.mx>
205 # sent me, along with a proposed fix.
206 #
207
208 package Foo;
209
210 sub new {
211         my $class = shift;
212         my $dat = shift;
213         return bless {dat => $dat}, $class;
214 }
215
216 package Bar;
217 sub new {
218         my $class = shift;
219         return bless {
220                 a => 'dummy',
221                 b => [ 
222                         Foo->new(1),
223                         Foo->new(2), # Second instance of a Foo 
224                 ]
225         }, $class;
226 }
227
228 sub STORABLE_freeze {
229         my($self,$clonning) = @_;
230         return "$self->{a}", $self->{b};
231 }
232
233 sub STORABLE_thaw {
234         my($self,$clonning,$dummy,$o) = @_;
235         $self->{a} = $dummy;
236         $self->{b} = $o;
237 }
238
239 package main;
240
241 my $bar = new Bar;
242 my $bar2 = thaw freeze $bar;
243
244 ok 24, ref($bar2) eq 'Bar';
245 ok 25, ref($bar->{b}[0]) eq 'Foo';
246 ok 26, ref($bar->{b}[1]) eq 'Foo';
247 ok 27, ref($bar2->{b}[0]) eq 'Foo';
248 ok 28, ref($bar2->{b}[1]) eq 'Foo';
249
250 #
251 # The following attempts to make sure blessed objects are blessed ASAP
252 # at retrieve time.
253 #
254
255 package CLASS_1;
256
257 sub make {
258         my $self = bless {}, shift;
259         return $self;
260 }
261
262 package CLASS_2;
263
264 sub make {
265         my $self = bless {}, shift;
266         my ($o) = @_;
267         $self->{c1} = CLASS_1->make();
268         $self->{o} = $o;
269         $self->{c3} = bless CLASS_1->make(), "CLASS_3";
270         $o->set_c2($self);
271         return $self;
272 }
273
274 sub STORABLE_freeze {
275         my($self, $clonning) = @_;
276         return "", $self->{c1}, $self->{c3}, $self->{o};
277 }
278
279 sub STORABLE_thaw {
280         my($self, $clonning, $frozen, $c1, $c3, $o) = @_;
281         main::ok 29, ref $self eq "CLASS_2";
282         main::ok 30, ref $c1 eq "CLASS_1";
283         main::ok 31, ref $c3 eq "CLASS_3";
284         main::ok 32, ref $o eq "CLASS_OTHER";
285         $self->{c1} = $c1;
286         $self->{c3} = $c3;
287 }
288
289 package CLASS_OTHER;
290
291 sub make {
292         my $self = bless {}, shift;
293         return $self;
294 }
295
296 sub set_c2 { $_[0]->{c2} = $_[1] }
297
298 package main;
299
300 my $o = CLASS_OTHER->make();
301 my $c2 = CLASS_2->make($o);
302 my $so = thaw freeze $o;
303