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