Re: [Another bug] Re: about Storable perl module (again)
[p5sagit/p5-mst-13.2.git] / ext / Storable / t / recurse.t
CommitLineData
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#
10# $Log: recurse.t,v $
b12202d0 11# Revision 1.0.1.3 2001/02/17 12:28:33 ram
12# patch8: ensure blessing occurs ASAP, specially designed for hooks
13#
90826881 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 $
dd19458b 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 $
9e21b3d0 22# Revision 1.0 2000/09/01 19:40:42 ram
23# Baseline for first official release.
7a6a85bf 24#
25
26sub BEGIN {
0c384302 27 if ($ENV{PERL_CORE}){
28 chdir('t') if -d 't';
7dadce44 29 @INC = ('.', '../lib', '../ext/Storable/t');
372cb964 30 } else {
31 unshift @INC, 't';
0c384302 32 }
9f233367 33 require Config; import Config;
0c384302 34 if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
9f233367 35 print "1..0 # Skip: Storable was not built\n";
36 exit 0;
37 }
372cb964 38 require 'st-dump.pl';
7a6a85bf 39}
40
41sub ok;
42
43use Storable qw(freeze thaw dclone);
44
b12202d0 45print "1..32\n";
7a6a85bf 46
47package OBJ_REAL;
48
49use Storable qw(freeze thaw);
50
51@x = ('a', 1);
52
53sub make { bless [], shift }
54
55sub 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
62sub 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
75package OBJ_SYNC;
76
77@x = ('a', 1);
78
79sub make { bless {}, shift }
80
81sub STORABLE_freeze {
82 my $self = shift;
83 my ($cloning) = @_;
84 return if $cloning;
85 return ("", \@x, $self);
86}
87
88sub 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
96package OBJ_SYNC2;
97
98use Storable qw(dclone);
99
100sub make {
101 my $self = bless {}, shift;
102 my ($ext) = @_;
103 $self->{sync} = OBJ_SYNC->make;
104 $self->{ext} = $ext;
105 return $self;
106}
107
108sub STORABLE_freeze {
109 my $self = shift;
90826881 110 my %copy = %$self;
111 my $r = \%copy;
112 my $t = dclone($r->{sync});
113 return ("", [$t, $self->{ext}], $r, $self, $r->{ext});
7a6a85bf 114}
115
116sub STORABLE_thaw {
117 my $self = shift;
90826881 118 my ($cloning, $undef, $a, $r, $obj, $ext) = @_;
7a6a85bf 119 die "STORABLE_thaw #1" unless $obj eq $self;
120 die "STORABLE_thaw #2" unless ref $a eq 'ARRAY';
90826881 121 die "STORABLE_thaw #3" unless ref $r eq 'HASH';
122 die "STORABLE_thaw #4" unless $a->[1] == $r->{ext};
7a6a85bf 123 $self->{ok} = $self;
124 ($self->{sync}, $self->{ext}) = @$a;
125}
126
127package OBJ_REAL2;
128
129use Storable qw(freeze thaw);
130
131$MAX = 20;
132$recursed = 0;
133$hook_called = 0;
134
135sub make { bless [], shift }
136
137sub STORABLE_freeze {
138 my $self = shift;
139 $hook_called++;
140 return (freeze($self), $self) if ++$recursed < $MAX;
141 return ("no", $self);
142}
143
144sub 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
153package main;
154
155my $real = OBJ_REAL->make;
156my $x = freeze $real;
157ok 1, 1;
158
159my $y = thaw $x;
160ok 2, 1;
161ok 3, $y->[0] eq 'a';
162ok 4, $y->[1] == 1;
163
164my $sync = OBJ_SYNC->make;
165$x = freeze $sync;
166ok 5, 1;
167
168$y = thaw $x;
169ok 6, 1;
170ok 7, $y->{ok} == $y;
171
172my $ext = [1, 2];
173$sync = OBJ_SYNC2->make($ext);
174$x = freeze [$sync, $ext];
175ok 8, 1;
176
177my $z = thaw $x;
178$y = $z->[0];
179ok 9, 1;
180ok 10, $y->{ok} == $y;
181ok 11, ref $y->{sync} eq 'OBJ_SYNC';
182ok 12, $y->{ext} == $z->[1];
183
184$real = OBJ_REAL2->make;
185$x = freeze $real;
186ok 13, 1;
187ok 14, $OBJ_REAL2::recursed == $OBJ_REAL2::MAX;
188ok 15, $OBJ_REAL2::hook_called == $OBJ_REAL2::MAX;
189
190$y = thaw $x;
191ok 16, 1;
192ok 17, $OBJ_REAL2::recursed == 0;
193
194$x = dclone $real;
195ok 18, 1;
196ok 19, ref $x eq 'OBJ_REAL2';
197ok 20, $OBJ_REAL2::recursed == 0;
198ok 21, $OBJ_REAL2::hook_called == 2 * $OBJ_REAL2::MAX;
199
200ok 22, !Storable::is_storing;
201ok 23, !Storable::is_retrieving;
dd19458b 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
208package Foo;
209
210sub new {
211 my $class = shift;
212 my $dat = shift;
213 return bless {dat => $dat}, $class;
214}
215
216package Bar;
217sub 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
228sub STORABLE_freeze {
229 my($self,$clonning) = @_;
230 return "$self->{a}", $self->{b};
231}
232
233sub STORABLE_thaw {
234 my($self,$clonning,$dummy,$o) = @_;
235 $self->{a} = $dummy;
236 $self->{b} = $o;
237}
238
239package main;
240
241my $bar = new Bar;
242my $bar2 = thaw freeze $bar;
243
244ok 24, ref($bar2) eq 'Bar';
245ok 25, ref($bar->{b}[0]) eq 'Foo';
246ok 26, ref($bar->{b}[1]) eq 'Foo';
247ok 27, ref($bar2->{b}[0]) eq 'Foo';
248ok 28, ref($bar2->{b}[1]) eq 'Foo';
249
b12202d0 250#
251# The following attempts to make sure blessed objects are blessed ASAP
252# at retrieve time.
253#
254
255package CLASS_1;
256
257sub make {
258 my $self = bless {}, shift;
259 return $self;
260}
261
262package CLASS_2;
263
264sub 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
274sub STORABLE_freeze {
275 my($self, $clonning) = @_;
276 return "", $self->{c1}, $self->{c3}, $self->{o};
277}
278
279sub 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
289package CLASS_OTHER;
290
291sub make {
292 my $self = bless {}, shift;
293 return $self;
294}
295
296sub set_c2 { $_[0]->{c2} = $_[1] }
297
298package main;
299
300my $o = CLASS_OTHER->make();
301my $c2 = CLASS_2->make($o);
302my $so = thaw freeze $o;
303