Store weak references.
[p5sagit/p5-mst-13.2.git] / ext / Storable / t / tied.t
CommitLineData
7a6a85bf 1#!./perl
7a6a85bf 2#
3# Copyright (c) 1995-2000, Raphael Manfredi
4#
9e21b3d0 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 8
9sub BEGIN {
0c384302 10 if ($ENV{PERL_CORE}){
11 chdir('t') if -d 't';
7dadce44 12 @INC = ('.', '../lib', '../ext/Storable/t');
372cb964 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 18 print "1..0 # Skip: Storable was not built\n";
19 exit 0;
20 }
372cb964 21 require 'st-dump.pl';
7a6a85bf 22}
23
24sub ok;
25
26use Storable qw(freeze thaw);
27
06389709 28print "1..23\n";
7a6a85bf 29
30($scalar_fetch, $array_fetch, $hash_fetch) = (0, 0, 0);
31
32package TIED_HASH;
33
34sub TIEHASH {
35 my $self = bless {}, shift;
36 return $self;
37}
38
39sub FETCH {
40 my $self = shift;
41 my ($key) = @_;
42 $main::hash_fetch++;
43 return $self->{$key};
44}
45
46sub STORE {
47 my $self = shift;
48 my ($key, $value) = @_;
49 $self->{$key} = $value;
50}
51
52sub FIRSTKEY {
53 my $self = shift;
54 scalar keys %{$self};
55 return each %{$self};
56}
57
58sub NEXTKEY {
59 my $self = shift;
60 return each %{$self};
61}
62
63package TIED_ARRAY;
64
65sub TIEARRAY {
66 my $self = bless [], shift;
67 return $self;
68}
69
70sub FETCH {
71 my $self = shift;
72 my ($idx) = @_;
73 $main::array_fetch++;
74 return $self->[$idx];
75}
76
77sub STORE {
78 my $self = shift;
79 my ($idx, $value) = @_;
80 $self->[$idx] = $value;
81}
82
83sub FETCHSIZE {
84 my $self = shift;
85 return @{$self};
86}
87
88package TIED_SCALAR;
89
90sub TIESCALAR {
91 my $scalar;
92 my $self = bless \$scalar, shift;
93 return $self;
94}
95
96sub FETCH {
97 my $self = shift;
98 $main::scalar_fetch++;
99 return $$self;
100}
101
102sub STORE {
103 my $self = shift;
104 my ($value) = @_;
105 $$self = $value;
106}
107
108package FAULT;
109
110$fault = 0;
111
112sub TIESCALAR {
113 my $pkg = shift;
114 return bless [@_], $pkg;
115}
116
117sub FETCH {
118 my $self = shift;
119 my ($href, $key) = @$self;
120 $fault++;
121 untie $href->{$key};
122 return $href->{$key} = 1;
123}
124
125package main;
126
127$a = 'toto';
128$b = \$a;
129
130$c = tie %hash, TIED_HASH;
131$d = tie @array, TIED_ARRAY;
132tie $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
155ok 1, defined($f = freeze(\@a));
156
157$dumped = &dump(\@a);
158ok 2, 1;
159
160$root = thaw($f);
161ok 3, defined $root;
162
163$got = &dump($root);
164ok 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
172ok 5, $got eq $dumped;
173
174$g = freeze($root);
175ok 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
182ok 7, tied $$tscalar;
183ok 8, tied @{$tarray};
184ok 9, tied %{$thash};
185
186@new = ($$tscalar, $tarray->[0], $thash->{'attribute'});
187@new = ($scalar_fetch, $array_fetch, $hash_fetch);
188
189# Tests 10..15
190for ($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
198my $h = {};
199tie $h->{'x'}, 'FAULT', $h, 'x';
200my $hf = freeze($h);
201ok 16, defined $hf;
202ok 17, $FAULT::fault == 0;
203ok 18, $h->{'x'} == 1;
204ok 19, $FAULT::fault == 1;
205
206my $ht = thaw($hf);
207ok 20, defined $ht;
208ok 21, $ht->{'x'} == 1;
209ok 22, $FAULT::fault == 2;
f4193312 210
211{
212 package P;
213 use Storable qw(freeze thaw);
d5f92636 214 use vars qw($a $b);
f4193312 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