Commit | Line | Data |
7a6a85bf |
1 | #!./perl |
2 | |
90826881 |
3 | # $Id: recurse.t,v 1.0.1.2 2000/11/05 17:22:05 ram Exp ram $ |
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 $ |
90826881 |
11 | # Revision 1.0.1.2 2000/11/05 17:22:05 ram |
12 | # patch6: stress hook a little more with refs to lexicals |
13 | # |
14 | # $Log: recurse.t,v $ |
dd19458b |
15 | # Revision 1.0.1.1 2000/09/17 16:48:05 ram |
16 | # patch1: added test case for store hook bug |
17 | # |
18 | # $Log: recurse.t,v $ |
9e21b3d0 |
19 | # Revision 1.0 2000/09/01 19:40:42 ram |
20 | # Baseline for first official release. |
7a6a85bf |
21 | # |
22 | |
23 | sub BEGIN { |
24 | chdir('t') if -d 't'; |
20822f61 |
25 | @INC = '.'; |
26 | push @INC, '../lib'; |
9f233367 |
27 | require Config; import Config; |
28 | if ($Config{'extensions'} !~ /\bStorable\b/) { |
29 | print "1..0 # Skip: Storable was not built\n"; |
30 | exit 0; |
31 | } |
7a6a85bf |
32 | require 'lib/st-dump.pl'; |
33 | } |
34 | |
35 | sub ok; |
36 | |
37 | use Storable qw(freeze thaw dclone); |
38 | |
dd19458b |
39 | print "1..28\n"; |
7a6a85bf |
40 | |
41 | package OBJ_REAL; |
42 | |
43 | use Storable qw(freeze thaw); |
44 | |
45 | @x = ('a', 1); |
46 | |
47 | sub make { bless [], shift } |
48 | |
49 | sub STORABLE_freeze { |
50 | my $self = shift; |
51 | my $cloning = shift; |
52 | die "STORABLE_freeze" unless Storable::is_storing; |
53 | return (freeze(\@x), $self); |
54 | } |
55 | |
56 | sub STORABLE_thaw { |
57 | my $self = shift; |
58 | my $cloning = shift; |
59 | my ($x, $obj) = @_; |
60 | die "STORABLE_thaw #1" unless $obj eq $self; |
61 | my $len = length $x; |
62 | my $a = thaw $x; |
63 | die "STORABLE_thaw #2" unless ref $a eq 'ARRAY'; |
64 | die "STORABLE_thaw #3" unless @$a == 2 && $a->[0] eq 'a' && $a->[1] == 1; |
65 | @$self = @$a; |
66 | die "STORABLE_thaw #4" unless Storable::is_retrieving; |
67 | } |
68 | |
69 | package OBJ_SYNC; |
70 | |
71 | @x = ('a', 1); |
72 | |
73 | sub make { bless {}, shift } |
74 | |
75 | sub STORABLE_freeze { |
76 | my $self = shift; |
77 | my ($cloning) = @_; |
78 | return if $cloning; |
79 | return ("", \@x, $self); |
80 | } |
81 | |
82 | sub STORABLE_thaw { |
83 | my $self = shift; |
84 | my ($cloning, $undef, $a, $obj) = @_; |
85 | die "STORABLE_thaw #1" unless $obj eq $self; |
86 | die "STORABLE_thaw #2" unless ref $a eq 'ARRAY' || @$a != 2; |
87 | $self->{ok} = $self; |
88 | } |
89 | |
90 | package OBJ_SYNC2; |
91 | |
92 | use Storable qw(dclone); |
93 | |
94 | sub make { |
95 | my $self = bless {}, shift; |
96 | my ($ext) = @_; |
97 | $self->{sync} = OBJ_SYNC->make; |
98 | $self->{ext} = $ext; |
99 | return $self; |
100 | } |
101 | |
102 | sub STORABLE_freeze { |
103 | my $self = shift; |
90826881 |
104 | my %copy = %$self; |
105 | my $r = \%copy; |
106 | my $t = dclone($r->{sync}); |
107 | return ("", [$t, $self->{ext}], $r, $self, $r->{ext}); |
7a6a85bf |
108 | } |
109 | |
110 | sub STORABLE_thaw { |
111 | my $self = shift; |
90826881 |
112 | my ($cloning, $undef, $a, $r, $obj, $ext) = @_; |
7a6a85bf |
113 | die "STORABLE_thaw #1" unless $obj eq $self; |
114 | die "STORABLE_thaw #2" unless ref $a eq 'ARRAY'; |
90826881 |
115 | die "STORABLE_thaw #3" unless ref $r eq 'HASH'; |
116 | die "STORABLE_thaw #4" unless $a->[1] == $r->{ext}; |
7a6a85bf |
117 | $self->{ok} = $self; |
118 | ($self->{sync}, $self->{ext}) = @$a; |
119 | } |
120 | |
121 | package OBJ_REAL2; |
122 | |
123 | use Storable qw(freeze thaw); |
124 | |
125 | $MAX = 20; |
126 | $recursed = 0; |
127 | $hook_called = 0; |
128 | |
129 | sub make { bless [], shift } |
130 | |
131 | sub STORABLE_freeze { |
132 | my $self = shift; |
133 | $hook_called++; |
134 | return (freeze($self), $self) if ++$recursed < $MAX; |
135 | return ("no", $self); |
136 | } |
137 | |
138 | sub STORABLE_thaw { |
139 | my $self = shift; |
140 | my $cloning = shift; |
141 | my ($x, $obj) = @_; |
142 | die "STORABLE_thaw #1" unless $obj eq $self; |
143 | $self->[0] = thaw($x) if $x ne "no"; |
144 | $recursed--; |
145 | } |
146 | |
147 | package main; |
148 | |
149 | my $real = OBJ_REAL->make; |
150 | my $x = freeze $real; |
151 | ok 1, 1; |
152 | |
153 | my $y = thaw $x; |
154 | ok 2, 1; |
155 | ok 3, $y->[0] eq 'a'; |
156 | ok 4, $y->[1] == 1; |
157 | |
158 | my $sync = OBJ_SYNC->make; |
159 | $x = freeze $sync; |
160 | ok 5, 1; |
161 | |
162 | $y = thaw $x; |
163 | ok 6, 1; |
164 | ok 7, $y->{ok} == $y; |
165 | |
166 | my $ext = [1, 2]; |
167 | $sync = OBJ_SYNC2->make($ext); |
168 | $x = freeze [$sync, $ext]; |
169 | ok 8, 1; |
170 | |
171 | my $z = thaw $x; |
172 | $y = $z->[0]; |
173 | ok 9, 1; |
174 | ok 10, $y->{ok} == $y; |
175 | ok 11, ref $y->{sync} eq 'OBJ_SYNC'; |
176 | ok 12, $y->{ext} == $z->[1]; |
177 | |
178 | $real = OBJ_REAL2->make; |
179 | $x = freeze $real; |
180 | ok 13, 1; |
181 | ok 14, $OBJ_REAL2::recursed == $OBJ_REAL2::MAX; |
182 | ok 15, $OBJ_REAL2::hook_called == $OBJ_REAL2::MAX; |
183 | |
184 | $y = thaw $x; |
185 | ok 16, 1; |
186 | ok 17, $OBJ_REAL2::recursed == 0; |
187 | |
188 | $x = dclone $real; |
189 | ok 18, 1; |
190 | ok 19, ref $x eq 'OBJ_REAL2'; |
191 | ok 20, $OBJ_REAL2::recursed == 0; |
192 | ok 21, $OBJ_REAL2::hook_called == 2 * $OBJ_REAL2::MAX; |
193 | |
194 | ok 22, !Storable::is_storing; |
195 | ok 23, !Storable::is_retrieving; |
dd19458b |
196 | |
197 | # |
198 | # The following was a test-case that Salvador Ortiz Garcia <sog@msg.com.mx> |
199 | # sent me, along with a proposed fix. |
200 | # |
201 | |
202 | package Foo; |
203 | |
204 | sub new { |
205 | my $class = shift; |
206 | my $dat = shift; |
207 | return bless {dat => $dat}, $class; |
208 | } |
209 | |
210 | package Bar; |
211 | sub new { |
212 | my $class = shift; |
213 | return bless { |
214 | a => 'dummy', |
215 | b => [ |
216 | Foo->new(1), |
217 | Foo->new(2), # Second instance of a Foo |
218 | ] |
219 | }, $class; |
220 | } |
221 | |
222 | sub STORABLE_freeze { |
223 | my($self,$clonning) = @_; |
224 | return "$self->{a}", $self->{b}; |
225 | } |
226 | |
227 | sub STORABLE_thaw { |
228 | my($self,$clonning,$dummy,$o) = @_; |
229 | $self->{a} = $dummy; |
230 | $self->{b} = $o; |
231 | } |
232 | |
233 | package main; |
234 | |
235 | my $bar = new Bar; |
236 | my $bar2 = thaw freeze $bar; |
237 | |
238 | ok 24, ref($bar2) eq 'Bar'; |
239 | ok 25, ref($bar->{b}[0]) eq 'Foo'; |
240 | ok 26, ref($bar->{b}[1]) eq 'Foo'; |
241 | ok 27, ref($bar2->{b}[0]) eq 'Foo'; |
242 | ok 28, ref($bar2->{b}[1]) eq 'Foo'; |
243 | |