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     @INC = '.';
  18     push @INC, '../lib';
  19     require Config; import Config;
  20     if ($Config{'extensions'} !~ /\bStorable\b/) {
  21         print "1..0 # Skip: Storable was not built\n";
  22         exit 0;
  23     }
  24     require 'lib/st-dump.pl';
  25 }
  26
  27 sub ok;
  28
  29 use Storable qw(freeze thaw dclone);
  30
  31 print "1..23\n";
  32
  33 package OBJ_REAL;
  34
  35 use Storable qw(freeze thaw);
  36
  37 @x = ('a', 1);
  38
  39 sub make { bless [], shift }
  40
  41 sub STORABLE_freeze {
  42         my $self = shift;
  43         my $cloning = shift;
  44         die "STORABLE_freeze" unless Storable::is_storing;
  45         return (freeze(\@x), $self);
  46 }
  47
  48 sub STORABLE_thaw {
  49         my $self = shift;
  50         my $cloning = shift;
  51         my ($x, $obj) = @_;
  52         die "STORABLE_thaw #1" unless $obj eq $self;
  53         my $len = length $x;
  54         my $a = thaw $x;
  55         die "STORABLE_thaw #2" unless ref $a eq 'ARRAY';
  56         die "STORABLE_thaw #3" unless @$a == 2 && $a->[0] eq 'a' && $a->[1] == 1;
  57         @$self = @$a;
  58         die "STORABLE_thaw #4" unless Storable::is_retrieving;
  59 }
  60
  61 package OBJ_SYNC;
  62
  63 @x = ('a', 1);
  64
  65 sub make { bless {}, shift }
  66
  67 sub STORABLE_freeze {
  68         my $self = shift;
  69         my ($cloning) = @_;
  70         return if $cloning;
  71         return ("", \@x, $self);
  72 }
  73
  74 sub STORABLE_thaw {
  75         my $self = shift;
  76         my ($cloning, $undef, $a, $obj) = @_;
  77         die "STORABLE_thaw #1" unless $obj eq $self;
  78         die "STORABLE_thaw #2" unless ref $a eq 'ARRAY' || @$a != 2;
  79         $self->{ok} = $self;
  80 }
  81
  82 package OBJ_SYNC2;
  83
  84 use Storable qw(dclone);
  85
  86 sub make {
  87         my $self = bless {}, shift;
  88         my ($ext) = @_;
  89         $self->{sync} = OBJ_SYNC->make;
  90         $self->{ext} = $ext;
  91         return $self;
  92 }
  93
  94 sub STORABLE_freeze {
  95         my $self = shift;
  96         my $t = dclone($self->{sync});
  97         return ("", [$t, $self->{ext}], $self, $self->{ext});
  98 }
  99
 100 sub STORABLE_thaw {
 101         my $self = shift;
 102         my ($cloning, $undef, $a, $obj, $ext) = @_;
 103         die "STORABLE_thaw #1" unless $obj eq $self;
 104         die "STORABLE_thaw #2" unless ref $a eq 'ARRAY';
 105         $self->{ok} = $self;
 106         ($self->{sync}, $self->{ext}) = @$a;
 107 }
 108
 109 package OBJ_REAL2;
 110
 111 use Storable qw(freeze thaw);
 112
 113 $MAX = 20;
 114 $recursed = 0;
 115 $hook_called = 0;
 116
 117 sub make { bless [], shift }
 118
 119 sub STORABLE_freeze {
 120         my $self = shift;
 121         $hook_called++;
 122         return (freeze($self), $self) if ++$recursed < $MAX;
 123         return ("no", $self);
 124 }
 125
 126 sub STORABLE_thaw {
 127         my $self = shift;
 128         my $cloning = shift;
 129         my ($x, $obj) = @_;
 130         die "STORABLE_thaw #1" unless $obj eq $self;
 131         $self->[0] = thaw($x) if $x ne "no";
 132         $recursed--;
 133 }
 134
 135 package main;
 136
 137 my $real = OBJ_REAL->make;
 138 my $x = freeze $real;
 139 ok 1, 1;
 140
 141 my $y = thaw $x;
 142 ok 2, 1;
 143 ok 3, $y->[0] eq 'a';
 144 ok 4, $y->[1] == 1;
 145
 146 my $sync = OBJ_SYNC->make;
 147 $x = freeze $sync;
 148 ok 5, 1;
 149
 150 $y = thaw $x;
 151 ok 6, 1;
 152 ok 7, $y->{ok} == $y;
 153
 154 my $ext = [1, 2];
 155 $sync = OBJ_SYNC2->make($ext);
 156 $x = freeze [$sync, $ext];
 157 ok 8, 1;
 158
 159 my $z = thaw $x;
 160 $y = $z->[0];
 161 ok 9, 1;
 162 ok 10, $y->{ok} == $y;
 163 ok 11, ref $y->{sync} eq 'OBJ_SYNC';
 164 ok 12, $y->{ext} == $z->[1];
 165
 166 $real = OBJ_REAL2->make;
 167 $x = freeze $real;
 168 ok 13, 1;
 169 ok 14, $OBJ_REAL2::recursed == $OBJ_REAL2::MAX;
 170 ok 15, $OBJ_REAL2::hook_called == $OBJ_REAL2::MAX;
 171
 172 $y = thaw $x;
 173 ok 16, 1;
 174 ok 17, $OBJ_REAL2::recursed == 0;
 175
 176 $x = dclone $real;
 177 ok 18, 1;
 178 ok 19, ref $x eq 'OBJ_REAL2';
 179 ok 20, $OBJ_REAL2::recursed == 0;
 180 ok 21, $OBJ_REAL2::hook_called == 2 * $OBJ_REAL2::MAX;
 181
 182 ok 22, !Storable::is_storing;
 183 ok 23, !Storable::is_retrieving;