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