ext/Storable/t/tied_hook.t

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