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