ext/Storable/t/recurse.t

   1 #!./perl
   2
   3 # $Id: recurse.t,v 1.0.1.3 2001/02/17 12:28:33 ram Exp $
   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.3  2001/02/17 12:28:33  ram
  12 # patch8: ensure blessing occurs ASAP, specially designed for hooks
  13 #
  14 # Revision 1.0.1.2  2000/11/05 17:22:05  ram
  15 # patch6: stress hook a little more with refs to lexicals
  16 #
  17 # $Log: recurse.t,v $
  18 # Revision 1.0.1.1  2000/09/17 16:48:05  ram
  19 # patch1: added test case for store hook bug
  20 #
  21 # $Log: recurse.t,v $
  22 # Revision 1.0  2000/09/01 19:40:42  ram
  23 # Baseline for first official release.
  24 #
  25
  26 sub BEGIN {
  27     if ($ENV{PERL_CORE}){
  28         chdir('t') if -d 't';
  29         @INC = '.';
  30         push @INC, '../lib';
  31     }
  32     require Config; import Config;
  33     if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
  34         print "1..0 # Skip: Storable was not built\n";
  35         exit 0;
  36     }
  37     require 'lib/st-dump.pl';
  38 }
  39
  40 sub ok;
  41
  42 use Storable qw(freeze thaw dclone);
  43
  44 print "1..32\n";
  45
  46 package OBJ_REAL;
  47
  48 use Storable qw(freeze thaw);
  49
  50 @x = ('a', 1);
  51
  52 sub make { bless [], shift }
  53
  54 sub STORABLE_freeze {
  55         my $self = shift;
  56         my $cloning = shift;
  57         die "STORABLE_freeze" unless Storable::is_storing;
  58         return (freeze(\@x), $self);
  59 }
  60
  61 sub STORABLE_thaw {
  62         my $self = shift;
  63         my $cloning = shift;
  64         my ($x, $obj) = @_;
  65         die "STORABLE_thaw #1" unless $obj eq $self;
  66         my $len = length $x;
  67         my $a = thaw $x;
  68         die "STORABLE_thaw #2" unless ref $a eq 'ARRAY';
  69         die "STORABLE_thaw #3" unless @$a == 2 && $a->[0] eq 'a' && $a->[1] == 1;
  70         @$self = @$a;
  71         die "STORABLE_thaw #4" unless Storable::is_retrieving;
  72 }
  73
  74 package OBJ_SYNC;
  75
  76 @x = ('a', 1);
  77
  78 sub make { bless {}, shift }
  79
  80 sub STORABLE_freeze {
  81         my $self = shift;
  82         my ($cloning) = @_;
  83         return if $cloning;
  84         return ("", \@x, $self);
  85 }
  86
  87 sub STORABLE_thaw {
  88         my $self = shift;
  89         my ($cloning, $undef, $a, $obj) = @_;
  90         die "STORABLE_thaw #1" unless $obj eq $self;
  91         die "STORABLE_thaw #2" unless ref $a eq 'ARRAY' || @$a != 2;
  92         $self->{ok} = $self;
  93 }
  94
  95 package OBJ_SYNC2;
  96
  97 use Storable qw(dclone);
  98
  99 sub make {
 100         my $self = bless {}, shift;
 101         my ($ext) = @_;
 102         $self->{sync} = OBJ_SYNC->make;
 103         $self->{ext} = $ext;
 104         return $self;
 105 }
 106
 107 sub STORABLE_freeze {
 108         my $self = shift;
 109         my %copy = %$self;
 110         my $r = \%copy;
 111         my $t = dclone($r->{sync});
 112         return ("", [$t, $self->{ext}], $r, $self, $r->{ext});
 113 }
 114
 115 sub STORABLE_thaw {
 116         my $self = shift;
 117         my ($cloning, $undef, $a, $r, $obj, $ext) = @_;
 118         die "STORABLE_thaw #1" unless $obj eq $self;
 119         die "STORABLE_thaw #2" unless ref $a eq 'ARRAY';
 120         die "STORABLE_thaw #3" unless ref $r eq 'HASH';
 121         die "STORABLE_thaw #4" unless $a->[1] == $r->{ext};
 122         $self->{ok} = $self;
 123         ($self->{sync}, $self->{ext}) = @$a;
 124 }
 125
 126 package OBJ_REAL2;
 127
 128 use Storable qw(freeze thaw);
 129
 130 $MAX = 20;
 131 $recursed = 0;
 132 $hook_called = 0;
 133
 134 sub make { bless [], shift }
 135
 136 sub STORABLE_freeze {
 137         my $self = shift;
 138         $hook_called++;
 139         return (freeze($self), $self) if ++$recursed < $MAX;
 140         return ("no", $self);
 141 }
 142
 143 sub STORABLE_thaw {
 144         my $self = shift;
 145         my $cloning = shift;
 146         my ($x, $obj) = @_;
 147         die "STORABLE_thaw #1" unless $obj eq $self;
 148         $self->[0] = thaw($x) if $x ne "no";
 149         $recursed--;
 150 }
 151
 152 package main;
 153
 154 my $real = OBJ_REAL->make;
 155 my $x = freeze $real;
 156 ok 1, 1;
 157
 158 my $y = thaw $x;
 159 ok 2, 1;
 160 ok 3, $y->[0] eq 'a';
 161 ok 4, $y->[1] == 1;
 162
 163 my $sync = OBJ_SYNC->make;
 164 $x = freeze $sync;
 165 ok 5, 1;
 166
 167 $y = thaw $x;
 168 ok 6, 1;
 169 ok 7, $y->{ok} == $y;
 170
 171 my $ext = [1, 2];
 172 $sync = OBJ_SYNC2->make($ext);
 173 $x = freeze [$sync, $ext];
 174 ok 8, 1;
 175
 176 my $z = thaw $x;
 177 $y = $z->[0];
 178 ok 9, 1;
 179 ok 10, $y->{ok} == $y;
 180 ok 11, ref $y->{sync} eq 'OBJ_SYNC';
 181 ok 12, $y->{ext} == $z->[1];
 182
 183 $real = OBJ_REAL2->make;
 184 $x = freeze $real;
 185 ok 13, 1;
 186 ok 14, $OBJ_REAL2::recursed == $OBJ_REAL2::MAX;
 187 ok 15, $OBJ_REAL2::hook_called == $OBJ_REAL2::MAX;
 188
 189 $y = thaw $x;
 190 ok 16, 1;
 191 ok 17, $OBJ_REAL2::recursed == 0;
 192
 193 $x = dclone $real;
 194 ok 18, 1;
 195 ok 19, ref $x eq 'OBJ_REAL2';
 196 ok 20, $OBJ_REAL2::recursed == 0;
 197 ok 21, $OBJ_REAL2::hook_called == 2 * $OBJ_REAL2::MAX;
 198
 199 ok 22, !Storable::is_storing;
 200 ok 23, !Storable::is_retrieving;
 201
 202 #
 203 # The following was a test-case that Salvador Ortiz Garcia <sog@msg.com.mx>
 204 # sent me, along with a proposed fix.
 205 #
 206
 207 package Foo;
 208
 209 sub new {
 210         my $class = shift;
 211         my $dat = shift;
 212         return bless {dat => $dat}, $class;
 213 }
 214
 215 package Bar;
 216 sub new {
 217         my $class = shift;
 218         return bless {
 219                 a => 'dummy',
 220                 b => [
 221                         Foo->new(1),
 222                         Foo->new(2), # Second instance of a Foo
 223                 ]
 224         }, $class;
 225 }
 226
 227 sub STORABLE_freeze {
 228         my($self,$clonning) = @_;
 229         return "$self->{a}", $self->{b};
 230 }
 231
 232 sub STORABLE_thaw {
 233         my($self,$clonning,$dummy,$o) = @_;
 234         $self->{a} = $dummy;
 235         $self->{b} = $o;
 236 }
 237
 238 package main;
 239
 240 my $bar = new Bar;
 241 my $bar2 = thaw freeze $bar;
 242
 243 ok 24, ref($bar2) eq 'Bar';
 244 ok 25, ref($bar->{b}[0]) eq 'Foo';
 245 ok 26, ref($bar->{b}[1]) eq 'Foo';
 246 ok 27, ref($bar2->{b}[0]) eq 'Foo';
 247 ok 28, ref($bar2->{b}[1]) eq 'Foo';
 248
 249 #
 250 # The following attempts to make sure blessed objects are blessed ASAP
 251 # at retrieve time.
 252 #
 253
 254 package CLASS_1;
 255
 256 sub make {
 257         my $self = bless {}, shift;
 258         return $self;
 259 }
 260
 261 package CLASS_2;
 262
 263 sub make {
 264         my $self = bless {}, shift;
 265         my ($o) = @_;
 266         $self->{c1} = CLASS_1->make();
 267         $self->{o} = $o;
 268         $self->{c3} = bless CLASS_1->make(), "CLASS_3";
 269         $o->set_c2($self);
 270         return $self;
 271 }
 272
 273 sub STORABLE_freeze {
 274         my($self, $clonning) = @_;
 275         return "", $self->{c1}, $self->{c3}, $self->{o};
 276 }
 277
 278 sub STORABLE_thaw {
 279         my($self, $clonning, $frozen, $c1, $c3, $o) = @_;
 280         main::ok 29, ref $self eq "CLASS_2";
 281         main::ok 30, ref $c1 eq "CLASS_1";
 282         main::ok 31, ref $c3 eq "CLASS_3";
 283         main::ok 32, ref $o eq "CLASS_OTHER";
 284         $self->{c1} = $c1;
 285         $self->{c3} = $c3;
 286 }
 287
 288 package CLASS_OTHER;
 289
 290 sub make {
 291         my $self = bless {}, shift;
 292         return $self;
 293 }
 294
 295 sub set_c2 { $_[0]->{c2} = $_[1] }
 296
 297 package main;
 298
 299 my $o = CLASS_OTHER->make();
 300 my $c2 = CLASS_2->make($o);
 301 my $so = thaw freeze $o;
 302