t/lib/st-tied.t

   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
  18 sub BEGIN {
  19     chdir('t') if -d 't';
  20     unshift @INC, '../lib';
  21     require Config; import Config;
  22     if ($Config{'extensions'} !~ /\bStorable\b/) {
  23         print "1..0 # Skip: Storable was not built\n";
  24         exit 0;
  25     }
  26     require 'lib/st-dump.pl';
  27 }
  28
  29 sub ok;
  30
  31 use Storable qw(freeze thaw);
  32
  33 print "1..22\n";
  34
  35 ($scalar_fetch, $array_fetch, $hash_fetch) = (0, 0, 0);
  36
  37 package TIED_HASH;
  38
  39 sub TIEHASH {
  40         my $self = bless {}, shift;
  41         return $self;
  42 }
  43
  44 sub FETCH {
  45         my $self = shift;
  46         my ($key) = @_;
  47         $main::hash_fetch++;
  48         return $self->{$key};
  49 }
  50
  51 sub STORE {
  52         my $self = shift;
  53         my ($key, $value) = @_;
  54         $self->{$key} = $value;
  55 }
  56
  57 sub FIRSTKEY {
  58         my $self = shift;
  59         scalar keys %{$self};
  60         return each %{$self};
  61 }
  62
  63 sub NEXTKEY {
  64         my $self = shift;
  65         return each %{$self};
  66 }
  67
  68 package TIED_ARRAY;
  69
  70 sub TIEARRAY {
  71         my $self = bless [], shift;
  72         return $self;
  73 }
  74
  75 sub FETCH {
  76         my $self = shift;
  77         my ($idx) = @_;
  78         $main::array_fetch++;
  79         return $self->[$idx];
  80 }
  81
  82 sub STORE {
  83         my $self = shift;
  84         my ($idx, $value) = @_;
  85         $self->[$idx] = $value;
  86 }
  87
  88 sub FETCHSIZE {
  89         my $self = shift;
  90         return @{$self};
  91 }
  92
  93 package TIED_SCALAR;
  94
  95 sub TIESCALAR {
  96         my $scalar;
  97         my $self = bless \$scalar, shift;
  98         return $self;
  99 }
 100
 101 sub FETCH {
 102         my $self = shift;
 103         $main::scalar_fetch++;
 104         return $$self;
 105 }
 106
 107 sub STORE {
 108         my $self = shift;
 109         my ($value) = @_;
 110         $$self = $value;
 111 }
 112
 113 package FAULT;
 114
 115 $fault = 0;
 116
 117 sub TIESCALAR {
 118         my $pkg = shift;
 119         return bless [@_], $pkg;
 120 }
 121
 122 sub FETCH {
 123         my $self = shift;
 124         my ($href, $key) = @$self;
 125         $fault++;
 126         untie $href->{$key};
 127         return $href->{$key} = 1;
 128 }
 129
 130 package main;
 131
 132 $a = 'toto';
 133 $b = \$a;
 134
 135 $c = tie %hash, TIED_HASH;
 136 $d = tie @array, TIED_ARRAY;
 137 tie $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
 160 ok 1, defined($f = freeze(\@a));
 161
 162 $dumped = &dump(\@a);
 163 ok 2, 1;
 164
 165 $root = thaw($f);
 166 ok 3, defined $root;
 167
 168 $got = &dump($root);
 169 ok 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
 177 ok 5, $got eq $dumped;
 178
 179 $g = freeze($root);
 180 ok 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
 187 ok 7, tied $$tscalar;
 188 ok 8, tied @{$tarray};
 189 ok 9, tied %{$thash};
 190
 191 @new = ($$tscalar, $tarray->[0], $thash->{'attribute'});
 192 @new = ($scalar_fetch, $array_fetch, $hash_fetch);
 193
 194 # Tests 10..15
 195 for ($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
 203 my $h = {};
 204 tie $h->{'x'}, 'FAULT', $h, 'x';
 205 my $hf = freeze($h);
 206 ok 16, defined $hf;
 207 ok 17, $FAULT::fault == 0;
 208 ok 18, $h->{'x'} == 1;
 209 ok 19, $FAULT::fault == 1;
 210
 211 my $ht = thaw($hf);
 212 ok 20, defined $ht;
 213 ok 21, $ht->{'x'} == 1;
 214 ok 22, $FAULT::fault == 2;
 215