Commit | Line | Data |
7a6a85bf |
1 | #!./perl |
2 | |
3 | # $Id: recurse.t,v 0.7 2000/08/03 22:04:45 ram Exp $ |
4 | # |
5 | # Copyright (c) 1995-2000, Raphael Manfredi |
6 | # |
7 | # You may redistribute only under the terms of the Artistic License, |
8 | # as specified in the README file that comes with the distribution. |
9 | # |
10 | # $Log: recurse.t,v $ |
11 | # Revision 0.7 2000/08/03 22:04:45 ram |
12 | # Baseline for second beta release. |
13 | # |
14 | |
15 | sub BEGIN { |
16 | chdir('t') if -d 't'; |
17 | unshift @INC, '../lib'; |
18 | require 'lib/st-dump.pl'; |
19 | } |
20 | |
21 | sub ok; |
22 | |
23 | use Storable qw(freeze thaw dclone); |
24 | |
25 | print "1..23\n"; |
26 | |
27 | package OBJ_REAL; |
28 | |
29 | use Storable qw(freeze thaw); |
30 | |
31 | @x = ('a', 1); |
32 | |
33 | sub make { bless [], shift } |
34 | |
35 | sub STORABLE_freeze { |
36 | my $self = shift; |
37 | my $cloning = shift; |
38 | die "STORABLE_freeze" unless Storable::is_storing; |
39 | return (freeze(\@x), $self); |
40 | } |
41 | |
42 | sub STORABLE_thaw { |
43 | my $self = shift; |
44 | my $cloning = shift; |
45 | my ($x, $obj) = @_; |
46 | die "STORABLE_thaw #1" unless $obj eq $self; |
47 | my $len = length $x; |
48 | my $a = thaw $x; |
49 | die "STORABLE_thaw #2" unless ref $a eq 'ARRAY'; |
50 | die "STORABLE_thaw #3" unless @$a == 2 && $a->[0] eq 'a' && $a->[1] == 1; |
51 | @$self = @$a; |
52 | die "STORABLE_thaw #4" unless Storable::is_retrieving; |
53 | } |
54 | |
55 | package OBJ_SYNC; |
56 | |
57 | @x = ('a', 1); |
58 | |
59 | sub make { bless {}, shift } |
60 | |
61 | sub STORABLE_freeze { |
62 | my $self = shift; |
63 | my ($cloning) = @_; |
64 | return if $cloning; |
65 | return ("", \@x, $self); |
66 | } |
67 | |
68 | sub STORABLE_thaw { |
69 | my $self = shift; |
70 | my ($cloning, $undef, $a, $obj) = @_; |
71 | die "STORABLE_thaw #1" unless $obj eq $self; |
72 | die "STORABLE_thaw #2" unless ref $a eq 'ARRAY' || @$a != 2; |
73 | $self->{ok} = $self; |
74 | } |
75 | |
76 | package OBJ_SYNC2; |
77 | |
78 | use Storable qw(dclone); |
79 | |
80 | sub make { |
81 | my $self = bless {}, shift; |
82 | my ($ext) = @_; |
83 | $self->{sync} = OBJ_SYNC->make; |
84 | $self->{ext} = $ext; |
85 | return $self; |
86 | } |
87 | |
88 | sub STORABLE_freeze { |
89 | my $self = shift; |
90 | my $t = dclone($self->{sync}); |
91 | return ("", [$t, $self->{ext}], $self, $self->{ext}); |
92 | } |
93 | |
94 | sub STORABLE_thaw { |
95 | my $self = shift; |
96 | my ($cloning, $undef, $a, $obj, $ext) = @_; |
97 | die "STORABLE_thaw #1" unless $obj eq $self; |
98 | die "STORABLE_thaw #2" unless ref $a eq 'ARRAY'; |
99 | $self->{ok} = $self; |
100 | ($self->{sync}, $self->{ext}) = @$a; |
101 | } |
102 | |
103 | package OBJ_REAL2; |
104 | |
105 | use Storable qw(freeze thaw); |
106 | |
107 | $MAX = 20; |
108 | $recursed = 0; |
109 | $hook_called = 0; |
110 | |
111 | sub make { bless [], shift } |
112 | |
113 | sub STORABLE_freeze { |
114 | my $self = shift; |
115 | $hook_called++; |
116 | return (freeze($self), $self) if ++$recursed < $MAX; |
117 | return ("no", $self); |
118 | } |
119 | |
120 | sub STORABLE_thaw { |
121 | my $self = shift; |
122 | my $cloning = shift; |
123 | my ($x, $obj) = @_; |
124 | die "STORABLE_thaw #1" unless $obj eq $self; |
125 | $self->[0] = thaw($x) if $x ne "no"; |
126 | $recursed--; |
127 | } |
128 | |
129 | package main; |
130 | |
131 | my $real = OBJ_REAL->make; |
132 | my $x = freeze $real; |
133 | ok 1, 1; |
134 | |
135 | my $y = thaw $x; |
136 | ok 2, 1; |
137 | ok 3, $y->[0] eq 'a'; |
138 | ok 4, $y->[1] == 1; |
139 | |
140 | my $sync = OBJ_SYNC->make; |
141 | $x = freeze $sync; |
142 | ok 5, 1; |
143 | |
144 | $y = thaw $x; |
145 | ok 6, 1; |
146 | ok 7, $y->{ok} == $y; |
147 | |
148 | my $ext = [1, 2]; |
149 | $sync = OBJ_SYNC2->make($ext); |
150 | $x = freeze [$sync, $ext]; |
151 | ok 8, 1; |
152 | |
153 | my $z = thaw $x; |
154 | $y = $z->[0]; |
155 | ok 9, 1; |
156 | ok 10, $y->{ok} == $y; |
157 | ok 11, ref $y->{sync} eq 'OBJ_SYNC'; |
158 | ok 12, $y->{ext} == $z->[1]; |
159 | |
160 | $real = OBJ_REAL2->make; |
161 | $x = freeze $real; |
162 | ok 13, 1; |
163 | ok 14, $OBJ_REAL2::recursed == $OBJ_REAL2::MAX; |
164 | ok 15, $OBJ_REAL2::hook_called == $OBJ_REAL2::MAX; |
165 | |
166 | $y = thaw $x; |
167 | ok 16, 1; |
168 | ok 17, $OBJ_REAL2::recursed == 0; |
169 | |
170 | $x = dclone $real; |
171 | ok 18, 1; |
172 | ok 19, ref $x eq 'OBJ_REAL2'; |
173 | ok 20, $OBJ_REAL2::recursed == 0; |
174 | ok 21, $OBJ_REAL2::hook_called == 2 * $OBJ_REAL2::MAX; |
175 | |
176 | ok 22, !Storable::is_storing; |
177 | ok 23, !Storable::is_retrieving; |