make new Storable tests forgiving of places where not built
[p5sagit/p5-mst-13.2.git] / t / lib / st-tied.t
CommitLineData
7a6a85bf 1#!./perl
2
3# $Id: tied.t,v 0.7.1.1 2000/08/13 20:10:27 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: tied.t,v $
11# Revision 0.7.1.1 2000/08/13 20:10:27 ram
12# patch1: added test case for "undef" in hashes
13#
14# Revision 0.7 2000/08/03 22:04:45 ram
15# Baseline for second beta release.
16#
17
18sub BEGIN {
19 chdir('t') if -d 't';
9f233367 20 require Config; import Config;
21 if ($Config{'extensions'} !~ /\bStorable\b/) {
22 print "1..0 # Skip: Storable was not built\n";
23 exit 0;
24 }
7a6a85bf 25 unshift @INC, '../lib';
26 require 'lib/st-dump.pl';
27}
28
29sub ok;
30
31use Storable qw(freeze thaw);
32
33print "1..22\n";
34
35($scalar_fetch, $array_fetch, $hash_fetch) = (0, 0, 0);
36
37package TIED_HASH;
38
39sub TIEHASH {
40 my $self = bless {}, shift;
41 return $self;
42}
43
44sub FETCH {
45 my $self = shift;
46 my ($key) = @_;
47 $main::hash_fetch++;
48 return $self->{$key};
49}
50
51sub STORE {
52 my $self = shift;
53 my ($key, $value) = @_;
54 $self->{$key} = $value;
55}
56
57sub FIRSTKEY {
58 my $self = shift;
59 scalar keys %{$self};
60 return each %{$self};
61}
62
63sub NEXTKEY {
64 my $self = shift;
65 return each %{$self};
66}
67
68package TIED_ARRAY;
69
70sub TIEARRAY {
71 my $self = bless [], shift;
72 return $self;
73}
74
75sub FETCH {
76 my $self = shift;
77 my ($idx) = @_;
78 $main::array_fetch++;
79 return $self->[$idx];
80}
81
82sub STORE {
83 my $self = shift;
84 my ($idx, $value) = @_;
85 $self->[$idx] = $value;
86}
87
88sub FETCHSIZE {
89 my $self = shift;
90 return @{$self};
91}
92
93package TIED_SCALAR;
94
95sub TIESCALAR {
96 my $scalar;
97 my $self = bless \$scalar, shift;
98 return $self;
99}
100
101sub FETCH {
102 my $self = shift;
103 $main::scalar_fetch++;
104 return $$self;
105}
106
107sub STORE {
108 my $self = shift;
109 my ($value) = @_;
110 $$self = $value;
111}
112
113package FAULT;
114
115$fault = 0;
116
117sub TIESCALAR {
118 my $pkg = shift;
119 return bless [@_], $pkg;
120}
121
122sub FETCH {
123 my $self = shift;
124 my ($href, $key) = @$self;
125 $fault++;
126 untie $href->{$key};
127 return $href->{$key} = 1;
128}
129
130package main;
131
132$a = 'toto';
133$b = \$a;
134
135$c = tie %hash, TIED_HASH;
136$d = tie @array, TIED_ARRAY;
137tie $scalar, TIED_SCALAR;
138
139#$scalar = 'foo';
140#$hash{'attribute'} = \$d;
141#$array[0] = $c;
142#$array[1] = \$scalar;
143
144### If I say
145### $hash{'attribute'} = $d;
146### below, then dump() incorectly dumps the hash value as a string the second
147### time it is reached. I have not investigated enough to tell whether it's
148### a bug in my dump() routine or in the Perl tieing mechanism.
149$scalar = 'foo';
150$hash{'attribute'} = 'plain value';
151$array[0] = \$scalar;
152$array[1] = $c;
153$array[2] = \@array;
154
155@tied = (\$scalar, \@array, \%hash);
156%a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$a, 'scalarref', \$scalar);
157@a = ('first', 3, -4, -3.14159, 456, 4.5, $d, \$d,
158 $b, \$a, $a, $c, \$c, \%a, \@array, \%hash, \@tied);
159
160ok 1, defined($f = freeze(\@a));
161
162$dumped = &dump(\@a);
163ok 2, 1;
164
165$root = thaw($f);
166ok 3, defined $root;
167
168$got = &dump($root);
169ok 4, 1;
170
171### Used to see the manifestation of the bug documented above.
172### print "original: $dumped";
173### print "--------\n";
174### print "got: $got";
175### print "--------\n";
176
177ok 5, $got eq $dumped;
178
179$g = freeze($root);
180ok 6, 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
187ok 7, tied $$tscalar;
188ok 8, tied @{$tarray};
189ok 9, tied %{$thash};
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 print "not " unless $new[$i] == $old[$i] + 1;
197 printf "ok %d\n", 10 + 2*$i; # Tests 10,12,14
198 print "not " unless ref $tied[$i] eq $type[$i];
199 printf "ok %d\n", 11 + 2*$i; # Tests 11,13,15
200}
201
202# Check undef ties
203my $h = {};
204tie $h->{'x'}, 'FAULT', $h, 'x';
205my $hf = freeze($h);
206ok 16, defined $hf;
207ok 17, $FAULT::fault == 0;
208ok 18, $h->{'x'} == 1;
209ok 19, $FAULT::fault == 1;
210
211my $ht = thaw($hf);
212ok 20, defined $ht;
213ok 21, $ht->{'x'} == 1;
214ok 22, $FAULT::fault == 2;
215