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 if ($ENV{PERL_CORE}){ 11 chdir('t') if -d 't'; 12 @INC = ('.', '../lib', '../ext/Storable/t'); 13 } else { 14 unshift @INC, 't'; 15 } 16 require Config; import Config; 17 if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { 18 print "1..0 # Skip: Storable was not built\n"; 19 exit 0; 20 } 21 require 'st-dump.pl'; 22} 23 24sub ok; 25 26use Storable qw(freeze thaw); 27 28print "1..23\n"; 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; 210 211{ 212 package P; 213 use Storable qw(freeze thaw); 214 use vars qw($a $b); 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 221