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