Commit | Line | Data |
---|---|---|
7a6a85bf | 1 | #!./perl |
7a6a85bf RG |
2 | # |
3 | # Copyright (c) 1995-2000, Raphael Manfredi | |
4 | # | |
9e21b3d0 JH |
5 | # You may redistribute only under the same terms as Perl 5, as specified |
6 | # in the README file that comes with the distribution. | |
7a6a85bf | 7 | # |
7a6a85bf RG |
8 | |
9 | sub BEGIN { | |
0c384302 JH |
10 | if ($ENV{PERL_CORE}){ |
11 | chdir('t') if -d 't'; | |
7dadce44 | 12 | @INC = ('.', '../lib', '../ext/Storable/t'); |
372cb964 NC |
13 | } else { |
14 | unshift @INC, 't'; | |
0c384302 | 15 | } |
9f233367 | 16 | require Config; import Config; |
0c384302 | 17 | if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { |
9f233367 PP |
18 | print "1..0 # Skip: Storable was not built\n"; |
19 | exit 0; | |
20 | } | |
372cb964 | 21 | require 'st-dump.pl'; |
7a6a85bf RG |
22 | } |
23 | ||
24 | sub ok; | |
25 | ||
26 | use Storable qw(freeze thaw); | |
27 | ||
06389709 | 28 | print "1..23\n"; |
7a6a85bf RG |
29 | |
30 | ($scalar_fetch, $array_fetch, $hash_fetch) = (0, 0, 0); | |
31 | ||
32 | package TIED_HASH; | |
33 | ||
34 | sub TIEHASH { | |
35 | my $self = bless {}, shift; | |
36 | return $self; | |
37 | } | |
38 | ||
39 | sub FETCH { | |
40 | my $self = shift; | |
41 | my ($key) = @_; | |
42 | $main::hash_fetch++; | |
43 | return $self->{$key}; | |
44 | } | |
45 | ||
46 | sub STORE { | |
47 | my $self = shift; | |
48 | my ($key, $value) = @_; | |
49 | $self->{$key} = $value; | |
50 | } | |
51 | ||
52 | sub FIRSTKEY { | |
53 | my $self = shift; | |
54 | scalar keys %{$self}; | |
55 | return each %{$self}; | |
56 | } | |
57 | ||
58 | sub NEXTKEY { | |
59 | my $self = shift; | |
60 | return each %{$self}; | |
61 | } | |
62 | ||
63 | package TIED_ARRAY; | |
64 | ||
65 | sub TIEARRAY { | |
66 | my $self = bless [], shift; | |
67 | return $self; | |
68 | } | |
69 | ||
70 | sub FETCH { | |
71 | my $self = shift; | |
72 | my ($idx) = @_; | |
73 | $main::array_fetch++; | |
74 | return $self->[$idx]; | |
75 | } | |
76 | ||
77 | sub STORE { | |
78 | my $self = shift; | |
79 | my ($idx, $value) = @_; | |
80 | $self->[$idx] = $value; | |
81 | } | |
82 | ||
83 | sub FETCHSIZE { | |
84 | my $self = shift; | |
85 | return @{$self}; | |
86 | } | |
87 | ||
88 | package TIED_SCALAR; | |
89 | ||
90 | sub TIESCALAR { | |
91 | my $scalar; | |
92 | my $self = bless \$scalar, shift; | |
93 | return $self; | |
94 | } | |
95 | ||
96 | sub FETCH { | |
97 | my $self = shift; | |
98 | $main::scalar_fetch++; | |
99 | return $$self; | |
100 | } | |
101 | ||
102 | sub STORE { | |
103 | my $self = shift; | |
104 | my ($value) = @_; | |
105 | $$self = $value; | |
106 | } | |
107 | ||
108 | package FAULT; | |
109 | ||
110 | $fault = 0; | |
111 | ||
112 | sub TIESCALAR { | |
113 | my $pkg = shift; | |
114 | return bless [@_], $pkg; | |
115 | } | |
116 | ||
117 | sub FETCH { | |
118 | my $self = shift; | |
119 | my ($href, $key) = @$self; | |
120 | $fault++; | |
121 | untie $href->{$key}; | |
122 | return $href->{$key} = 1; | |
123 | } | |
124 | ||
125 | package main; | |
126 | ||
127 | $a = 'toto'; | |
128 | $b = \$a; | |
129 | ||
130 | $c = tie %hash, TIED_HASH; | |
131 | $d = tie @array, TIED_ARRAY; | |
132 | tie $scalar, TIED_SCALAR; | |
133 | ||
134 | #$scalar = 'foo'; | |
135 | #$hash{'attribute'} = \$d; | |
136 | #$array[0] = $c; | |
137 | #$array[1] = \$scalar; | |
138 | ||
139 | ### If I say | |
140 | ### $hash{'attribute'} = $d; | |
141 | ### below, then dump() incorectly dumps the hash value as a string the second | |
142 | ### time it is reached. I have not investigated enough to tell whether it's | |
143 | ### a bug in my dump() routine or in the Perl tieing mechanism. | |
144 | $scalar = 'foo'; | |
145 | $hash{'attribute'} = 'plain value'; | |
146 | $array[0] = \$scalar; | |
147 | $array[1] = $c; | |
148 | $array[2] = \@array; | |
149 | ||
150 | @tied = (\$scalar, \@array, \%hash); | |
151 | %a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$a, 'scalarref', \$scalar); | |
152 | @a = ('first', 3, -4, -3.14159, 456, 4.5, $d, \$d, | |
153 | $b, \$a, $a, $c, \$c, \%a, \@array, \%hash, \@tied); | |
154 | ||
155 | ok 1, defined($f = freeze(\@a)); | |
156 | ||
157 | $dumped = &dump(\@a); | |
158 | ok 2, 1; | |
159 | ||
160 | $root = thaw($f); | |
161 | ok 3, defined $root; | |
162 | ||
163 | $got = &dump($root); | |
164 | ok 4, 1; | |
165 | ||
166 | ### Used to see the manifestation of the bug documented above. | |
167 | ### print "original: $dumped"; | |
168 | ### print "--------\n"; | |
169 | ### print "got: $got"; | |
170 | ### print "--------\n"; | |
171 | ||
172 | ok 5, $got eq $dumped; | |
173 | ||
174 | $g = freeze($root); | |
175 | ok 6, length($f) == length($g); | |
176 | ||
177 | # Ensure the tied items in the retrieved image work | |
178 | @old = ($scalar_fetch, $array_fetch, $hash_fetch); | |
179 | @tied = ($tscalar, $tarray, $thash) = @{$root->[$#{$root}]}; | |
180 | @type = qw(SCALAR ARRAY HASH); | |
181 | ||
182 | ok 7, tied $$tscalar; | |
183 | ok 8, tied @{$tarray}; | |
184 | ok 9, tied %{$thash}; | |
185 | ||
186 | @new = ($$tscalar, $tarray->[0], $thash->{'attribute'}); | |
187 | @new = ($scalar_fetch, $array_fetch, $hash_fetch); | |
188 | ||
189 | # Tests 10..15 | |
190 | for ($i = 0; $i < @new; $i++) { | |
191 | print "not " unless $new[$i] == $old[$i] + 1; | |
192 | printf "ok %d\n", 10 + 2*$i; # Tests 10,12,14 | |
193 | print "not " unless ref $tied[$i] eq $type[$i]; | |
194 | printf "ok %d\n", 11 + 2*$i; # Tests 11,13,15 | |
195 | } | |
196 | ||
197 | # Check undef ties | |
198 | my $h = {}; | |
199 | tie $h->{'x'}, 'FAULT', $h, 'x'; | |
200 | my $hf = freeze($h); | |
201 | ok 16, defined $hf; | |
202 | ok 17, $FAULT::fault == 0; | |
203 | ok 18, $h->{'x'} == 1; | |
204 | ok 19, $FAULT::fault == 1; | |
205 | ||
206 | my $ht = thaw($hf); | |
207 | ok 20, defined $ht; | |
208 | ok 21, $ht->{'x'} == 1; | |
209 | ok 22, $FAULT::fault == 2; | |
f4193312 AE |
210 | |
211 | { | |
212 | package P; | |
213 | use Storable qw(freeze thaw); | |
d5f92636 | 214 | use vars qw($a $b); |
f4193312 AE |
215 | $b = "not ok "; |
216 | sub TIESCALAR { bless \$a } sub FETCH { "ok " } | |
217 | tie $a, P; my $r = thaw freeze \$a; $b = $$r; | |
218 | print $b , 23, "\n"; | |
219 | } | |
220 |