t/lib/st-recurse.t

   1 #!./perl
   2
   3 # $Id: recurse.t,v 1.0.1.2 2000/11/05 17:22:05 ram Exp ram $
   4 #
   5 #  Copyright (c) 1995-2000, Raphael Manfredi
   6 #
   7 #  You may redistribute only under the same terms as Perl 5, as specified
   8 #  in the README file that comes with the distribution.
   9 #
  10 # $Log: recurse.t,v $
  11 # Revision 1.0.1.2  2000/11/05 17:22:05  ram
  12 # patch6: stress hook a little more with refs to lexicals
  13 #
  14 # $Log: recurse.t,v $
  15 # Revision 1.0.1.1  2000/09/17 16:48:05  ram
  16 # patch1: added test case for store hook bug
  17 #
  18 # $Log: recurse.t,v $
  19 # Revision 1.0  2000/09/01 19:40:42  ram
  20 # Baseline for first official release.
  21 #
  22
  23 sub BEGIN {
  24     chdir('t') if -d 't';
  25     @INC = '.';
  26     push @INC, '../lib';
  27     require Config; import Config;
  28     if ($Config{'extensions'} !~ /\bStorable\b/) {
  29         print "1..0 # Skip: Storable was not built\n";
  30         exit 0;
  31     }
  32     require 'lib/st-dump.pl';
  33 }
  34
  35 sub ok;
  36
  37 use Storable qw(freeze thaw dclone);
  38
  39 print "1..28\n";
  40
  41 package OBJ_REAL;
  42
  43 use Storable qw(freeze thaw);
  44
  45 @x = ('a', 1);
  46
  47 sub make { bless [], shift }
  48
  49 sub STORABLE_freeze {
  50         my $self = shift;
  51         my $cloning = shift;
  52         die "STORABLE_freeze" unless Storable::is_storing;
  53         return (freeze(\@x), $self);
  54 }
  55
  56 sub STORABLE_thaw {
  57         my $self = shift;
  58         my $cloning = shift;
  59         my ($x, $obj) = @_;
  60         die "STORABLE_thaw #1" unless $obj eq $self;
  61         my $len = length $x;
  62         my $a = thaw $x;
  63         die "STORABLE_thaw #2" unless ref $a eq 'ARRAY';
  64         die "STORABLE_thaw #3" unless @$a == 2 && $a->[0] eq 'a' && $a->[1] == 1;
  65         @$self = @$a;
  66         die "STORABLE_thaw #4" unless Storable::is_retrieving;
  67 }
  68
  69 package OBJ_SYNC;
  70
  71 @x = ('a', 1);
  72
  73 sub make { bless {}, shift }
  74
  75 sub STORABLE_freeze {
  76         my $self = shift;
  77         my ($cloning) = @_;
  78         return if $cloning;
  79         return ("", \@x, $self);
  80 }
  81
  82 sub STORABLE_thaw {
  83         my $self = shift;
  84         my ($cloning, $undef, $a, $obj) = @_;
  85         die "STORABLE_thaw #1" unless $obj eq $self;
  86         die "STORABLE_thaw #2" unless ref $a eq 'ARRAY' || @$a != 2;
  87         $self->{ok} = $self;
  88 }
  89
  90 package OBJ_SYNC2;
  91
  92 use Storable qw(dclone);
  93
  94 sub make {
  95         my $self = bless {}, shift;
  96         my ($ext) = @_;
  97         $self->{sync} = OBJ_SYNC->make;
  98         $self->{ext} = $ext;
  99         return $self;
 100 }
 101
 102 sub STORABLE_freeze {
 103         my $self = shift;
 104         my %copy = %$self;
 105         my $r = \%copy;
 106         my $t = dclone($r->{sync});
 107         return ("", [$t, $self->{ext}], $r, $self, $r->{ext});
 108 }
 109
 110 sub STORABLE_thaw {
 111         my $self = shift;
 112         my ($cloning, $undef, $a, $r, $obj, $ext) = @_;
 113         die "STORABLE_thaw #1" unless $obj eq $self;
 114         die "STORABLE_thaw #2" unless ref $a eq 'ARRAY';
 115         die "STORABLE_thaw #3" unless ref $r eq 'HASH';
 116         die "STORABLE_thaw #4" unless $a->[1] == $r->{ext};
 117         $self->{ok} = $self;
 118         ($self->{sync}, $self->{ext}) = @$a;
 119 }
 120
 121 package OBJ_REAL2;
 122
 123 use Storable qw(freeze thaw);
 124
 125 $MAX = 20;
 126 $recursed = 0;
 127 $hook_called = 0;
 128
 129 sub make { bless [], shift }
 130
 131 sub STORABLE_freeze {
 132         my $self = shift;
 133         $hook_called++;
 134         return (freeze($self), $self) if ++$recursed < $MAX;
 135         return ("no", $self);
 136 }
 137
 138 sub STORABLE_thaw {
 139         my $self = shift;
 140         my $cloning = shift;
 141         my ($x, $obj) = @_;
 142         die "STORABLE_thaw #1" unless $obj eq $self;
 143         $self->[0] = thaw($x) if $x ne "no";
 144         $recursed--;
 145 }
 146
 147 package main;
 148
 149 my $real = OBJ_REAL->make;
 150 my $x = freeze $real;
 151 ok 1, 1;
 152
 153 my $y = thaw $x;
 154 ok 2, 1;
 155 ok 3, $y->[0] eq 'a';
 156 ok 4, $y->[1] == 1;
 157
 158 my $sync = OBJ_SYNC->make;
 159 $x = freeze $sync;
 160 ok 5, 1;
 161
 162 $y = thaw $x;
 163 ok 6, 1;
 164 ok 7, $y->{ok} == $y;
 165
 166 my $ext = [1, 2];
 167 $sync = OBJ_SYNC2->make($ext);
 168 $x = freeze [$sync, $ext];
 169 ok 8, 1;
 170
 171 my $z = thaw $x;
 172 $y = $z->[0];
 173 ok 9, 1;
 174 ok 10, $y->{ok} == $y;
 175 ok 11, ref $y->{sync} eq 'OBJ_SYNC';
 176 ok 12, $y->{ext} == $z->[1];
 177
 178 $real = OBJ_REAL2->make;
 179 $x = freeze $real;
 180 ok 13, 1;
 181 ok 14, $OBJ_REAL2::recursed == $OBJ_REAL2::MAX;
 182 ok 15, $OBJ_REAL2::hook_called == $OBJ_REAL2::MAX;
 183
 184 $y = thaw $x;
 185 ok 16, 1;
 186 ok 17, $OBJ_REAL2::recursed == 0;
 187
 188 $x = dclone $real;
 189 ok 18, 1;
 190 ok 19, ref $x eq 'OBJ_REAL2';
 191 ok 20, $OBJ_REAL2::recursed == 0;
 192 ok 21, $OBJ_REAL2::hook_called == 2 * $OBJ_REAL2::MAX;
 193
 194 ok 22, !Storable::is_storing;
 195 ok 23, !Storable::is_retrieving;
 196
 197 #
 198 # The following was a test-case that Salvador Ortiz Garcia <sog@msg.com.mx>
 199 # sent me, along with a proposed fix.
 200 #
 201
 202 package Foo;
 203
 204 sub new {
 205         my $class = shift;
 206         my $dat = shift;
 207         return bless {dat => $dat}, $class;
 208 }
 209
 210 package Bar;
 211 sub new {
 212         my $class = shift;
 213         return bless {
 214                 a => 'dummy',
 215                 b => [
 216                         Foo->new(1),
 217                         Foo->new(2), # Second instance of a Foo
 218                 ]
 219         }, $class;
 220 }
 221
 222 sub STORABLE_freeze {
 223         my($self,$clonning) = @_;
 224         return "$self->{a}", $self->{b};
 225 }
 226
 227 sub STORABLE_thaw {
 228         my($self,$clonning,$dummy,$o) = @_;
 229         $self->{a} = $dummy;
 230         $self->{b} = $o;
 231 }
 232
 233 package main;
 234
 235 my $bar = new Bar;
 236 my $bar2 = thaw freeze $bar;
 237
 238 ok 24, ref($bar2) eq 'Bar';
 239 ok 25, ref($bar->{b}[0]) eq 'Foo';
 240 ok 26, ref($bar->{b}[1]) eq 'Foo';
 241 ok 27, ref($bar2->{b}[0]) eq 'Foo';
 242 ok 28, ref($bar2->{b}[1]) eq 'Foo';
 243