t/lib/st-tiedhook.t

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