make new Storable tests forgiving of places where not built
[p5sagit/p5-mst-13.2.git] / t / lib / st-recurse.t
CommitLineData
7a6a85bf 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
15sub BEGIN {
16 chdir('t') if -d 't';
9f233367 17 require Config; import Config;
18 if ($Config{'extensions'} !~ /\bStorable\b/) {
19 print "1..0 # Skip: Storable was not built\n";
20 exit 0;
21 }
7a6a85bf 22 unshift @INC, '../lib';
23 require 'lib/st-dump.pl';
24}
25
26sub ok;
27
28use Storable qw(freeze thaw dclone);
29
30print "1..23\n";
31
32package OBJ_REAL;
33
34use Storable qw(freeze thaw);
35
36@x = ('a', 1);
37
38sub make { bless [], shift }
39
40sub 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
47sub 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
60package OBJ_SYNC;
61
62@x = ('a', 1);
63
64sub make { bless {}, shift }
65
66sub STORABLE_freeze {
67 my $self = shift;
68 my ($cloning) = @_;
69 return if $cloning;
70 return ("", \@x, $self);
71}
72
73sub 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
81package OBJ_SYNC2;
82
83use Storable qw(dclone);
84
85sub make {
86 my $self = bless {}, shift;
87 my ($ext) = @_;
88 $self->{sync} = OBJ_SYNC->make;
89 $self->{ext} = $ext;
90 return $self;
91}
92
93sub STORABLE_freeze {
94 my $self = shift;
95 my $t = dclone($self->{sync});
96 return ("", [$t, $self->{ext}], $self, $self->{ext});
97}
98
99sub 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
108package OBJ_REAL2;
109
110use Storable qw(freeze thaw);
111
112$MAX = 20;
113$recursed = 0;
114$hook_called = 0;
115
116sub make { bless [], shift }
117
118sub STORABLE_freeze {
119 my $self = shift;
120 $hook_called++;
121 return (freeze($self), $self) if ++$recursed < $MAX;
122 return ("no", $self);
123}
124
125sub 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
134package main;
135
136my $real = OBJ_REAL->make;
137my $x = freeze $real;
138ok 1, 1;
139
140my $y = thaw $x;
141ok 2, 1;
142ok 3, $y->[0] eq 'a';
143ok 4, $y->[1] == 1;
144
145my $sync = OBJ_SYNC->make;
146$x = freeze $sync;
147ok 5, 1;
148
149$y = thaw $x;
150ok 6, 1;
151ok 7, $y->{ok} == $y;
152
153my $ext = [1, 2];
154$sync = OBJ_SYNC2->make($ext);
155$x = freeze [$sync, $ext];
156ok 8, 1;
157
158my $z = thaw $x;
159$y = $z->[0];
160ok 9, 1;
161ok 10, $y->{ok} == $y;
162ok 11, ref $y->{sync} eq 'OBJ_SYNC';
163ok 12, $y->{ext} == $z->[1];
164
165$real = OBJ_REAL2->make;
166$x = freeze $real;
167ok 13, 1;
168ok 14, $OBJ_REAL2::recursed == $OBJ_REAL2::MAX;
169ok 15, $OBJ_REAL2::hook_called == $OBJ_REAL2::MAX;
170
171$y = thaw $x;
172ok 16, 1;
173ok 17, $OBJ_REAL2::recursed == 0;
174
175$x = dclone $real;
176ok 18, 1;
177ok 19, ref $x eq 'OBJ_REAL2';
178ok 20, $OBJ_REAL2::recursed == 0;
179ok 21, $OBJ_REAL2::hook_called == 2 * $OBJ_REAL2::MAX;
180
181ok 22, !Storable::is_storing;
182ok 23, !Storable::is_retrieving;