ext/Storable/t/recurse.t

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