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