t/lib/st-recurse.t

   1 #!./perl
   2
   3 # $Id: recurse.t,v 1.0.1.1 2000/09/17 16:48:05 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.1  2000/09/17 16:48:05  ram
  12 # patch1: added test case for store hook bug
  13 #
  14 # $Log: recurse.t,v $
  15 # Revision 1.0  2000/09/01 19:40:42  ram
  16 # Baseline for first official release.
  17 #
  18
  19 sub BEGIN {
  20     chdir('t') if -d 't';
  21     @INC = '.';
  22     push @INC, '../lib';
  23     require Config; import Config;
  24     if ($Config{'extensions'} !~ /\bStorable\b/) {
  25         print "1..0 # Skip: Storable was not built\n";
  26         exit 0;
  27     }
  28     require 'lib/st-dump.pl';
  29 }
  30
  31 sub ok;
  32
  33 use Storable qw(freeze thaw dclone);
  34
  35 print "1..28\n";
  36
  37 package OBJ_REAL;
  38
  39 use Storable qw(freeze thaw);
  40
  41 @x = ('a', 1);
  42
  43 sub make { bless [], shift }
  44
  45 sub STORABLE_freeze {
  46         my $self = shift;
  47         my $cloning = shift;
  48         die "STORABLE_freeze" unless Storable::is_storing;
  49         return (freeze(\@x), $self);
  50 }
  51
  52 sub STORABLE_thaw {
  53         my $self = shift;
  54         my $cloning = shift;
  55         my ($x, $obj) = @_;
  56         die "STORABLE_thaw #1" unless $obj eq $self;
  57         my $len = length $x;
  58         my $a = thaw $x;
  59         die "STORABLE_thaw #2" unless ref $a eq 'ARRAY';
  60         die "STORABLE_thaw #3" unless @$a == 2 && $a->[0] eq 'a' && $a->[1] == 1;
  61         @$self = @$a;
  62         die "STORABLE_thaw #4" unless Storable::is_retrieving;
  63 }
  64
  65 package OBJ_SYNC;
  66
  67 @x = ('a', 1);
  68
  69 sub make { bless {}, shift }
  70
  71 sub STORABLE_freeze {
  72         my $self = shift;
  73         my ($cloning) = @_;
  74         return if $cloning;
  75         return ("", \@x, $self);
  76 }
  77
  78 sub STORABLE_thaw {
  79         my $self = shift;
  80         my ($cloning, $undef, $a, $obj) = @_;
  81         die "STORABLE_thaw #1" unless $obj eq $self;
  82         die "STORABLE_thaw #2" unless ref $a eq 'ARRAY' || @$a != 2;
  83         $self->{ok} = $self;
  84 }
  85
  86 package OBJ_SYNC2;
  87
  88 use Storable qw(dclone);
  89
  90 sub make {
  91         my $self = bless {}, shift;
  92         my ($ext) = @_;
  93         $self->{sync} = OBJ_SYNC->make;
  94         $self->{ext} = $ext;
  95         return $self;
  96 }
  97
  98 sub STORABLE_freeze {
  99         my $self = shift;
 100         my $t = dclone($self->{sync});
 101         return ("", [$t, $self->{ext}], $self, $self->{ext});
 102 }
 103
 104 sub STORABLE_thaw {
 105         my $self = shift;
 106         my ($cloning, $undef, $a, $obj, $ext) = @_;
 107         die "STORABLE_thaw #1" unless $obj eq $self;
 108         die "STORABLE_thaw #2" unless ref $a eq 'ARRAY';
 109         $self->{ok} = $self;
 110         ($self->{sync}, $self->{ext}) = @$a;
 111 }
 112
 113 package OBJ_REAL2;
 114
 115 use Storable qw(freeze thaw);
 116
 117 $MAX = 20;
 118 $recursed = 0;
 119 $hook_called = 0;
 120
 121 sub make { bless [], shift }
 122
 123 sub STORABLE_freeze {
 124         my $self = shift;
 125         $hook_called++;
 126         return (freeze($self), $self) if ++$recursed < $MAX;
 127         return ("no", $self);
 128 }
 129
 130 sub STORABLE_thaw {
 131         my $self = shift;
 132         my $cloning = shift;
 133         my ($x, $obj) = @_;
 134         die "STORABLE_thaw #1" unless $obj eq $self;
 135         $self->[0] = thaw($x) if $x ne "no";
 136         $recursed--;
 137 }
 138
 139 package main;
 140
 141 my $real = OBJ_REAL->make;
 142 my $x = freeze $real;
 143 ok 1, 1;
 144
 145 my $y = thaw $x;
 146 ok 2, 1;
 147 ok 3, $y->[0] eq 'a';
 148 ok 4, $y->[1] == 1;
 149
 150 my $sync = OBJ_SYNC->make;
 151 $x = freeze $sync;
 152 ok 5, 1;
 153
 154 $y = thaw $x;
 155 ok 6, 1;
 156 ok 7, $y->{ok} == $y;
 157
 158 my $ext = [1, 2];
 159 $sync = OBJ_SYNC2->make($ext);
 160 $x = freeze [$sync, $ext];
 161 ok 8, 1;
 162
 163 my $z = thaw $x;
 164 $y = $z->[0];
 165 ok 9, 1;
 166 ok 10, $y->{ok} == $y;
 167 ok 11, ref $y->{sync} eq 'OBJ_SYNC';
 168 ok 12, $y->{ext} == $z->[1];
 169
 170 $real = OBJ_REAL2->make;
 171 $x = freeze $real;
 172 ok 13, 1;
 173 ok 14, $OBJ_REAL2::recursed == $OBJ_REAL2::MAX;
 174 ok 15, $OBJ_REAL2::hook_called == $OBJ_REAL2::MAX;
 175
 176 $y = thaw $x;
 177 ok 16, 1;
 178 ok 17, $OBJ_REAL2::recursed == 0;
 179
 180 $x = dclone $real;
 181 ok 18, 1;
 182 ok 19, ref $x eq 'OBJ_REAL2';
 183 ok 20, $OBJ_REAL2::recursed == 0;
 184 ok 21, $OBJ_REAL2::hook_called == 2 * $OBJ_REAL2::MAX;
 185
 186 ok 22, !Storable::is_storing;
 187 ok 23, !Storable::is_retrieving;
 188
 189 #
 190 # The following was a test-case that Salvador Ortiz Garcia <sog@msg.com.mx>
 191 # sent me, along with a proposed fix.
 192 #
 193
 194 package Foo;
 195
 196 sub new {
 197         my $class = shift;
 198         my $dat = shift;
 199         return bless {dat => $dat}, $class;
 200 }
 201
 202 package Bar;
 203 sub new {
 204         my $class = shift;
 205         return bless {
 206                 a => 'dummy',
 207                 b => [
 208                         Foo->new(1),
 209                         Foo->new(2), # Second instance of a Foo
 210                 ]
 211         }, $class;
 212 }
 213
 214 sub STORABLE_freeze {
 215         my($self,$clonning) = @_;
 216         return "$self->{a}", $self->{b};
 217 }
 218
 219 sub STORABLE_thaw {
 220         my($self,$clonning,$dummy,$o) = @_;
 221         $self->{a} = $dummy;
 222         $self->{b} = $o;
 223 }
 224
 225 package main;
 226
 227 my $bar = new Bar;
 228 my $bar2 = thaw freeze $bar;
 229
 230 ok 24, ref($bar2) eq 'Bar';
 231 ok 25, ref($bar->{b}[0]) eq 'Foo';
 232 ok 26, ref($bar->{b}[1]) eq 'Foo';
 233 ok 27, ref($bar2->{b}[0]) eq 'Foo';
 234 ok 28, ref($bar2->{b}[1]) eq 'Foo';
 235