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