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