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