Commit | Line | Data |
7a6a85bf |
1 | #!./perl |
7a6a85bf |
2 | # |
3 | # Copyright (c) 1995-2000, Raphael Manfredi |
4 | # |
9e21b3d0 |
5 | # You may redistribute only under the same terms as Perl 5, as specified |
6 | # in the README file that comes with the distribution. |
7a6a85bf |
7 | # |
7a6a85bf |
8 | |
9 | sub BEGIN { |
48c887dd |
10 | unshift @INC, 't'; |
9f233367 |
11 | require Config; import Config; |
0c384302 |
12 | if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { |
9f233367 |
13 | print "1..0 # Skip: Storable was not built\n"; |
14 | exit 0; |
15 | } |
372cb964 |
16 | require 'st-dump.pl'; |
7a6a85bf |
17 | } |
18 | |
19 | sub ok; |
20 | |
21 | use Storable qw(freeze thaw); |
22 | |
dfd91409 |
23 | %::immortals |
24 | = (u => \undef, |
25 | 'y' => \(1 == 1), |
26 | n => \(1 == 0) |
27 | ); |
28 | |
29 | my $test = 12; |
754c00ca |
30 | my $tests = $test + 6 + 2 * 6 * keys %::immortals; |
dfd91409 |
31 | print "1..$tests\n"; |
7a6a85bf |
32 | |
33 | package SHORT_NAME; |
34 | |
35 | sub make { bless [], shift } |
36 | |
37 | package SHORT_NAME_WITH_HOOK; |
38 | |
39 | sub make { bless [], shift } |
40 | |
41 | sub STORABLE_freeze { |
42 | my $self = shift; |
43 | return ("", $self); |
44 | } |
45 | |
46 | sub STORABLE_thaw { |
47 | my $self = shift; |
48 | my $cloning = shift; |
49 | my ($x, $obj) = @_; |
50 | die "STORABLE_thaw" unless $obj eq $self; |
51 | } |
52 | |
53 | package main; |
54 | |
55 | # Still less than 256 bytes, so long classname logic not fully exercised |
56 | # Wait until Perl removes the restriction on identifier lengths. |
57 | my $name = "LONG_NAME_" . 'xxxxxxxxxxxxx::' x 14 . "final"; |
58 | |
59 | eval <<EOC; |
60 | package $name; |
61 | |
62 | \@ISA = ("SHORT_NAME"); |
63 | EOC |
64 | die $@ if $@; |
65 | ok 1, $@ eq ''; |
66 | |
67 | eval <<EOC; |
68 | package ${name}_WITH_HOOK; |
69 | |
70 | \@ISA = ("SHORT_NAME_WITH_HOOK"); |
71 | EOC |
72 | ok 2, $@ eq ''; |
73 | |
74 | # Construct a pool of objects |
75 | my @pool; |
76 | |
77 | for (my $i = 0; $i < 10; $i++) { |
78 | push(@pool, SHORT_NAME->make); |
79 | push(@pool, SHORT_NAME_WITH_HOOK->make); |
80 | push(@pool, $name->make); |
81 | push(@pool, "${name}_WITH_HOOK"->make); |
82 | } |
83 | |
84 | my $x = freeze \@pool; |
85 | ok 3, 1; |
86 | |
87 | my $y = thaw $x; |
88 | ok 4, ref $y eq 'ARRAY'; |
89 | ok 5, @{$y} == @pool; |
90 | |
91 | ok 6, ref $y->[0] eq 'SHORT_NAME'; |
92 | ok 7, ref $y->[1] eq 'SHORT_NAME_WITH_HOOK'; |
93 | ok 8, ref $y->[2] eq $name; |
94 | ok 9, ref $y->[3] eq "${name}_WITH_HOOK"; |
95 | |
96 | my $good = 1; |
97 | for (my $i = 0; $i < 10; $i++) { |
98 | do { $good = 0; last } unless ref $y->[4*$i] eq 'SHORT_NAME'; |
99 | do { $good = 0; last } unless ref $y->[4*$i+1] eq 'SHORT_NAME_WITH_HOOK'; |
100 | do { $good = 0; last } unless ref $y->[4*$i+2] eq $name; |
101 | do { $good = 0; last } unless ref $y->[4*$i+3] eq "${name}_WITH_HOOK"; |
102 | } |
103 | ok 10, $good; |
87baa35a |
104 | |
105 | { |
106 | my $blessed_ref = bless \\[1,2,3], 'Foobar'; |
107 | my $x = freeze $blessed_ref; |
108 | my $y = thaw $x; |
109 | ok 11, ref $y eq 'Foobar'; |
110 | ok 12, $$$y->[0] == 1; |
111 | } |
dfd91409 |
112 | |
113 | package RETURNS_IMMORTALS; |
114 | |
115 | sub make { my $self = shift; bless [@_], $self } |
116 | |
117 | sub STORABLE_freeze { |
118 | # Some reference some number of times. |
119 | my $self = shift; |
120 | my ($what, $times) = @$self; |
121 | return ("$what$times", ($::immortals{$what}) x $times); |
122 | } |
123 | |
124 | sub STORABLE_thaw { |
125 | my $self = shift; |
126 | my $cloning = shift; |
127 | my ($x, @refs) = @_; |
128 | my ($what, $times) = $x =~ /(.)(\d+)/; |
129 | die "'$x' didn't match" unless defined $times; |
130 | main::ok ++$test, @refs == $times; |
131 | my $expect = $::immortals{$what}; |
132 | die "'$x' did not give a reference" unless ref $expect; |
133 | my $fail; |
134 | foreach (@refs) { |
135 | $fail++ if $_ != $expect; |
136 | } |
137 | main::ok ++$test, !$fail; |
138 | } |
139 | |
140 | package main; |
141 | |
142 | # $Storable::DEBUGME = 1; |
143 | my $count; |
144 | foreach $count (1..3) { |
145 | my $immortal; |
146 | foreach $immortal (keys %::immortals) { |
147 | print "# $immortal x $count\n"; |
148 | my $i = RETURNS_IMMORTALS->make ($immortal, $count); |
149 | |
150 | my $f = freeze ($i); |
151 | ok ++$test, $f; |
152 | my $t = thaw $f; |
153 | ok ++$test, 1; |
154 | } |
155 | } |
754c00ca |
156 | |
157 | # Test automatic require of packages to find thaw hook. |
158 | |
159 | package HAS_HOOK; |
160 | |
161 | $loaded_count = 0; |
162 | $thawed_count = 0; |
163 | |
164 | sub make { |
165 | bless []; |
166 | } |
167 | |
168 | sub STORABLE_freeze { |
169 | my $self = shift; |
170 | return ''; |
171 | } |
172 | |
173 | package main; |
174 | |
175 | my $f = freeze (HAS_HOOK->make); |
176 | |
177 | ok ++$test, $HAS_HOOK::loaded_count == 0; |
178 | ok ++$test, $HAS_HOOK::thawed_count == 0; |
179 | |
180 | my $t = thaw $f; |
181 | ok ++$test, $HAS_HOOK::loaded_count == 1; |
182 | ok ++$test, $HAS_HOOK::thawed_count == 1; |
183 | ok ++$test, $t; |
184 | ok ++$test, ref $t eq 'HAS_HOOK'; |
185 | |
186 | # Can't do this because the method is still cached by UNIVERSAL::can |
187 | # delete $INC{"HAS_HOOK.pm"}; |
188 | # undef &HAS_HOOK::STORABLE_thaw; |
189 | # |
190 | # warn HAS_HOOK->can('STORABLE_thaw'); |
191 | # $t = thaw $f; |
192 | # ok ++$test, $HAS_HOOK::loaded_count == 2; |
193 | # ok ++$test, $HAS_HOOK::thawed_count == 2; |
194 | # ok ++$test, $t; |
195 | # ok ++$test, ref $t eq 'HAS_HOOK'; |