t/lib/st-recurse.t

   1 #!./perl
   2
   3 # $Id: recurse.t,v 0.7 2000/08/03 22:04:45 ram Exp $
   4 #
   5 #  Copyright (c) 1995-2000, Raphael Manfredi
   6 #
   7 #  You may redistribute only under the terms of the Artistic License,
   8 #  as specified in the README file that comes with the distribution.
   9 #
  10 # $Log: recurse.t,v $
  11 # Revision 0.7  2000/08/03 22:04:45  ram
  12 # Baseline for second beta release.
  13 #
  14
  15 sub BEGIN {
  16     chdir('t') if -d 't';
  17     unshift @INC, '../lib';
  18     require 'lib/st-dump.pl';
  19 }
  20
  21 sub ok;
  22
  23 use Storable qw(freeze thaw dclone);
  24
  25 print "1..23\n";
  26
  27 package OBJ_REAL;
  28
  29 use Storable qw(freeze thaw);
  30
  31 @x = ('a', 1);
  32
  33 sub make { bless [], shift }
  34
  35 sub STORABLE_freeze {
  36         my $self = shift;
  37         my $cloning = shift;
  38         die "STORABLE_freeze" unless Storable::is_storing;
  39         return (freeze(\@x), $self);
  40 }
  41
  42 sub STORABLE_thaw {
  43         my $self = shift;
  44         my $cloning = shift;
  45         my ($x, $obj) = @_;
  46         die "STORABLE_thaw #1" unless $obj eq $self;
  47         my $len = length $x;
  48         my $a = thaw $x;
  49         die "STORABLE_thaw #2" unless ref $a eq 'ARRAY';
  50         die "STORABLE_thaw #3" unless @$a == 2 && $a->[0] eq 'a' && $a->[1] == 1;
  51         @$self = @$a;
  52         die "STORABLE_thaw #4" unless Storable::is_retrieving;
  53 }
  54
  55 package OBJ_SYNC;
  56
  57 @x = ('a', 1);
  58
  59 sub make { bless {}, shift }
  60
  61 sub STORABLE_freeze {
  62         my $self = shift;
  63         my ($cloning) = @_;
  64         return if $cloning;
  65         return ("", \@x, $self);
  66 }
  67
  68 sub STORABLE_thaw {
  69         my $self = shift;
  70         my ($cloning, $undef, $a, $obj) = @_;
  71         die "STORABLE_thaw #1" unless $obj eq $self;
  72         die "STORABLE_thaw #2" unless ref $a eq 'ARRAY' || @$a != 2;
  73         $self->{ok} = $self;
  74 }
  75
  76 package OBJ_SYNC2;
  77
  78 use Storable qw(dclone);
  79
  80 sub make {
  81         my $self = bless {}, shift;
  82         my ($ext) = @_;
  83         $self->{sync} = OBJ_SYNC->make;
  84         $self->{ext} = $ext;
  85         return $self;
  86 }
  87
  88 sub STORABLE_freeze {
  89         my $self = shift;
  90         my $t = dclone($self->{sync});
  91         return ("", [$t, $self->{ext}], $self, $self->{ext});
  92 }
  93
  94 sub STORABLE_thaw {
  95         my $self = shift;
  96         my ($cloning, $undef, $a, $obj, $ext) = @_;
  97         die "STORABLE_thaw #1" unless $obj eq $self;
  98         die "STORABLE_thaw #2" unless ref $a eq 'ARRAY';
  99         $self->{ok} = $self;
 100         ($self->{sync}, $self->{ext}) = @$a;
 101 }
 102
 103 package OBJ_REAL2;
 104
 105 use Storable qw(freeze thaw);
 106
 107 $MAX = 20;
 108 $recursed = 0;
 109 $hook_called = 0;
 110
 111 sub make { bless [], shift }
 112
 113 sub STORABLE_freeze {
 114         my $self = shift;
 115         $hook_called++;
 116         return (freeze($self), $self) if ++$recursed < $MAX;
 117         return ("no", $self);
 118 }
 119
 120 sub STORABLE_thaw {
 121         my $self = shift;
 122         my $cloning = shift;
 123         my ($x, $obj) = @_;
 124         die "STORABLE_thaw #1" unless $obj eq $self;
 125         $self->[0] = thaw($x) if $x ne "no";
 126         $recursed--;
 127 }
 128
 129 package main;
 130
 131 my $real = OBJ_REAL->make;
 132 my $x = freeze $real;
 133 ok 1, 1;
 134
 135 my $y = thaw $x;
 136 ok 2, 1;
 137 ok 3, $y->[0] eq 'a';
 138 ok 4, $y->[1] == 1;
 139
 140 my $sync = OBJ_SYNC->make;
 141 $x = freeze $sync;
 142 ok 5, 1;
 143
 144 $y = thaw $x;
 145 ok 6, 1;
 146 ok 7, $y->{ok} == $y;
 147
 148 my $ext = [1, 2];
 149 $sync = OBJ_SYNC2->make($ext);
 150 $x = freeze [$sync, $ext];
 151 ok 8, 1;
 152
 153 my $z = thaw $x;
 154 $y = $z->[0];
 155 ok 9, 1;
 156 ok 10, $y->{ok} == $y;
 157 ok 11, ref $y->{sync} eq 'OBJ_SYNC';
 158 ok 12, $y->{ext} == $z->[1];
 159
 160 $real = OBJ_REAL2->make;
 161 $x = freeze $real;
 162 ok 13, 1;
 163 ok 14, $OBJ_REAL2::recursed == $OBJ_REAL2::MAX;
 164 ok 15, $OBJ_REAL2::hook_called == $OBJ_REAL2::MAX;
 165
 166 $y = thaw $x;
 167 ok 16, 1;
 168 ok 17, $OBJ_REAL2::recursed == 0;
 169
 170 $x = dclone $real;
 171 ok 18, 1;
 172 ok 19, ref $x eq 'OBJ_REAL2';
 173 ok 20, $OBJ_REAL2::recursed == 0;
 174 ok 21, $OBJ_REAL2::hook_called == 2 * $OBJ_REAL2::MAX;
 175
 176 ok 22, !Storable::is_storing;
 177 ok 23, !Storable::is_retrieving;