1#!./perl
2#
3#  Copyright (c) 1995-2000, Raphael Manfredi
4#  
5#  You may redistribute only under the same terms as Perl 5, as specified
6#  in the README file that comes with the distribution.
7#
8
9sub BEGIN {
10    unshift @INC, 't';
11    unshift @INC, 't/compat' if $] < 5.006002;
12    require Config; import Config;
13    if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
14        print "1..0 # Skip: Storable was not built\n";
15        exit 0;
16    }
17    require 'st-dump.pl';
18}
19
20use Storable qw(freeze thaw);
21
22$Storable::flags = Storable::FLAGS_COMPAT;
23
24use Test::More tests => 28;
25
26($scalar_fetch, $array_fetch, $hash_fetch) = (0, 0, 0);
27
28package TIED_HASH;
29
30sub TIEHASH {
31	my $self = bless {}, shift;
32	return $self;
33}
34
35sub FETCH {
36	my $self = shift;
37	my ($key) = @_;
38	$main::hash_fetch++;
39	return $self->{$key};
40}
41
42sub STORE {
43	my $self = shift;
44	my ($key, $value) = @_;
45	$self->{$key} = $value;
46}
47
48sub FIRSTKEY {
49	my $self = shift;
50	scalar keys %{$self};
51	return each %{$self};
52}
53
54sub NEXTKEY {
55	my $self = shift;
56	return each %{$self};
57}
58
59sub STORABLE_freeze {
60	my $self = shift;
61	$main::hash_hook1++;
62	return join(":", keys %$self) . ";" . join(":", values %$self);
63}
64
65sub STORABLE_thaw {
66	my ($self, $cloning, $frozen) = @_;
67	my ($keys, $values) = split(/;/, $frozen);
68	my @keys = split(/:/, $keys);
69	my @values = split(/:/, $values);
70	for (my $i = 0; $i < @keys; $i++) {
71		$self->{$keys[$i]} = $values[$i];
72	}
73	$main::hash_hook2++;
74}
75
76package TIED_ARRAY;
77
78sub TIEARRAY {
79	my $self = bless [], shift;
80	return $self;
81}
82
83sub FETCH {
84	my $self = shift;
85	my ($idx) = @_;
86	$main::array_fetch++;
87	return $self->[$idx];
88}
89
90sub STORE {
91	my $self = shift;
92	my ($idx, $value) = @_;
93	$self->[$idx] = $value;
94}
95
96sub FETCHSIZE {
97	my $self = shift;
98	return @{$self};
99}
100
101sub STORABLE_freeze {
102	my $self = shift;
103	$main::array_hook1++;
104	return join(":", @$self);
105}
106
107sub STORABLE_thaw {
108	my ($self, $cloning, $frozen) = @_;
109	@$self = split(/:/, $frozen);
110	$main::array_hook2++;
111}
112
113package TIED_SCALAR;
114
115sub TIESCALAR {
116	my $scalar;
117	my $self = bless \$scalar, shift;
118	return $self;
119}
120
121sub FETCH {
122	my $self = shift;
123	$main::scalar_fetch++;
124	return $$self;
125}
126
127sub STORE {
128	my $self = shift;
129	my ($value) = @_;
130	$$self = $value;
131}
132
133sub STORABLE_freeze {
134	my $self = shift;
135	$main::scalar_hook1++;
136	return $$self;
137}
138
139sub STORABLE_thaw {
140	my ($self, $cloning, $frozen) = @_;
141	$$self = $frozen;
142	$main::scalar_hook2++;
143}
144
145package main;
146
147$a = 'toto';
148$b = \$a;
149
150$c = tie %hash, TIED_HASH;
151$d = tie @array, TIED_ARRAY;
152tie $scalar, TIED_SCALAR;
153
154$scalar = 'foo';
155$hash{'attribute'} = 'plain value';
156$array[0] = \$scalar;
157$array[1] = $c;
158$array[2] = \@array;
159$array[3] = "plaine scalaire";
160
161@tied = (\$scalar, \@array, \%hash);
162%a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$a, 'scalarref', \$scalar);
163@a = ('first', 3, -4, -3.14159, 456, 4.5, $d, \$d,
164	$b, \$a, $a, $c, \$c, \%a, \@array, \%hash, \@tied);
165
166my $f = freeze(\@a);
167isnt($f, undef);
168$dumped = &dump(\@a);
169isnt($dumped, undef);
170
171$root = thaw($f);
172isnt($root, undef);
173
174$got = &dump($root);
175isnt($got, undef);
176
177isnt($got, $dumped);		# our hooks did not handle refs in array
178
179$g = freeze($root);
180is(length $f, length $g);
181
182# Ensure the tied items in the retrieved image work
183@old = ($scalar_fetch, $array_fetch, $hash_fetch);
184@tied = ($tscalar, $tarray, $thash) = @{$root->[$#{$root}]};
185@type = qw(SCALAR  ARRAY  HASH);
186
187is(ref tied $$tscalar, 'TIED_SCALAR');
188is(ref tied @$tarray, 'TIED_ARRAY');
189is(ref tied %$thash, 'TIED_HASH');
190
191@new = ($$tscalar, $tarray->[0], $thash->{'attribute'});
192@new = ($scalar_fetch, $array_fetch, $hash_fetch);
193
194# Tests 10..15
195for ($i = 0; $i < @new; $i++) {
196    is($new[$i], $old[$i] + 1);		# Tests 10,12,14
197    is(ref $tied[$i], $type[$i]);	# Tests 11,13,15
198}
199
200is($$tscalar, 'foo');
201is($tarray->[3], 'plaine scalaire');
202is($thash->{'attribute'}, 'plain value');
203
204# Ensure hooks were called
205is($scalar_hook1, 2);
206is($scalar_hook2, 1);
207is($array_hook1, 2);
208is($array_hook2, 1);
209is($hash_hook1, 2);
210is($hash_hook2, 1);
211
212#
213# And now for the "blessed ref to tied hash" with "store hook" test...
214#
215
216my $bc = bless \%hash, 'FOO';		# FOO does not exist -> no hook
217my $bx = thaw freeze $bc;
218
219is(ref $bx, 'FOO');
220my $old_hash_fetch = $hash_fetch;
221my $v = $bx->{attribute};
222is($hash_fetch, $old_hash_fetch + 1, 'Still tied');
223
224package TIED_HASH_REF;
225
226
227sub STORABLE_freeze {
228        my ($self, $cloning) = @_;
229        return if $cloning;
230        return('ref lost');
231}
232
233sub STORABLE_thaw {
234        my ($self, $cloning, $data) = @_;
235        return if $cloning;
236}
237
238package main;
239
240$bc = bless \%hash, 'TIED_HASH_REF';
241$bx = thaw freeze $bc;
242
243is(ref $bx, 'TIED_HASH_REF');
244$old_hash_fetch = $hash_fetch;
245$v = $bx->{attribute};
246is($hash_fetch, $old_hash_fetch + 1, 'Still tied');
247