Store weak references.
[p5sagit/p5-mst-13.2.git] / ext / Storable / t / code.t
CommitLineData
464b080a 1#!./perl
2#
3# Copyright (c) 2002 Slaven Rezic
4#
5# You may redistribute only under the same terms as Perl 5, as specified
6# in the README file that comes with the distribution.
7#
8
9sub BEGIN {
10 if ($ENV{PERL_CORE}){
11 chdir('t') if -d 't';
12 @INC = ('.', '../lib');
13 } else {
14 unshift @INC, 't';
15 }
16 require Config; import Config;
17 if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
18 print "1..0 # Skip: Storable was not built\n";
19 exit 0;
20 }
21}
22
23use strict;
24BEGIN {
25 if (!eval q{
26 use Test;
27 use B::Deparse 0.61;
9820b33a 28 use 5.006;
464b080a 29 1;
30 }) {
31 print "1..0 # skip: tests only work with B::Deparse 0.61 and at least perl 5.6.0\n";
32 exit;
33 }
34 require File::Spec;
35 if ($File::Spec::VERSION < 0.8) {
36 print "1..0 # Skip: newer File::Spec needed\n";
37 exit 0;
38 }
39}
40
a8b7ef86 41BEGIN { plan tests => 59 }
464b080a 42
43use Storable qw(retrieve store nstore freeze nfreeze thaw dclone);
44use Safe;
45
46#$Storable::DEBUGME = 1;
47
48use vars qw($freezed $thawed @obj @res $blessed_code);
49
464b080a 50$blessed_code = bless sub { "blessed" }, "Some::Package";
51{ package Another::Package; sub foo { __PACKAGE__ } }
52
197b90bc 53{
54 no strict; # to make the life for Safe->reval easier
55 sub code { "JAPH" }
56}
57
9820b33a 58local *FOO;
59
464b080a 60@obj =
61 ([\&code, # code reference
62 sub { 6*7 },
63 $blessed_code, # blessed code reference
64 \&Another::Package::foo, # code in another package
65 sub ($$;$) { 0 }, # prototypes
66 sub { print "test\n" },
67 \&Test::ok, # large scalar
68 ],
69
70 {"a" => sub { "srt" }, "b" => \&code},
71
72 sub { ord("a")-ord("7") },
73
74 \&code,
75
76 \&dclone, # XS function
77
78 sub { open FOO, "/" },
79 );
80
81$Storable::Deparse = 1;
82$Storable::Eval = 1;
83
84######################################################################
85# Test freeze & thaw
86
87$freezed = freeze $obj[0];
88$thawed = thaw $freezed;
89
90ok($thawed->[0]->(), "JAPH");
91ok($thawed->[1]->(), 42);
92ok($thawed->[2]->(), "blessed");
93ok($thawed->[3]->(), "Another::Package");
94ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
95
96######################################################################
97
98$freezed = freeze $obj[1];
99$thawed = thaw $freezed;
100
101ok($thawed->{"a"}->(), "srt");
102ok($thawed->{"b"}->(), "JAPH");
103
104######################################################################
105
106$freezed = freeze $obj[2];
107$thawed = thaw $freezed;
108
109ok($thawed->(), 42);
110
111######################################################################
112
113$freezed = freeze $obj[3];
114$thawed = thaw $freezed;
115
116ok($thawed->(), "JAPH");
117
118######################################################################
119
120eval { $freezed = freeze $obj[4] };
8578bbeb 121ok($@, qr/The result of B::Deparse::coderef2text was empty/);
464b080a 122
123######################################################################
124# Test dclone
125
126my $new_sub = dclone($obj[2]);
127ok($new_sub->(), $obj[2]->());
128
129######################################################################
130# Test retrieve & store
131
132store $obj[0], 'store';
133$thawed = retrieve 'store';
134
135ok($thawed->[0]->(), "JAPH");
136ok($thawed->[1]->(), 42);
137ok($thawed->[2]->(), "blessed");
138ok($thawed->[3]->(), "Another::Package");
139ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
140
141######################################################################
142
143nstore $obj[0], 'store';
144$thawed = retrieve 'store';
145unlink 'store';
146
147ok($thawed->[0]->(), "JAPH");
148ok($thawed->[1]->(), 42);
149ok($thawed->[2]->(), "blessed");
150ok($thawed->[3]->(), "Another::Package");
151ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
152
153######################################################################
154# Security with
155# $Storable::Eval
464b080a 156# $Storable::Deparse
157
158{
159 local $Storable::Eval = 0;
160
161 for my $i (0 .. 1) {
162 $freezed = freeze $obj[$i];
163 $@ = "";
164 eval { $thawed = thaw $freezed };
8578bbeb 165 ok($@, qr/Can\'t eval/);
464b080a 166 }
167}
168
169{
170
171 local $Storable::Deparse = 0;
172 for my $i (0 .. 1) {
173 $@ = "";
174 eval { $freezed = freeze $obj[$i] };
8578bbeb 175 ok($@, qr/Can\'t store CODE items/);
464b080a 176 }
177}
178
179{
180 local $Storable::Eval = 0;
181 local $Storable::forgive_me = 1;
182 for my $i (0 .. 4) {
183 $freezed = freeze $obj[0]->[$i];
184 $@ = "";
185 eval { $thawed = thaw $freezed };
186 ok($@, "");
8578bbeb 187 ok($$thawed, qr/^sub/);
464b080a 188 }
189}
190
191{
192 local $Storable::Deparse = 0;
193 local $Storable::forgive_me = 1;
194
195 my $devnull = File::Spec->devnull;
196
197 open(SAVEERR, ">&STDERR");
198 open(STDERR, ">$devnull") or
199 ( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) );
200
201 eval { $freezed = freeze $obj[0]->[0] };
202
203 open(STDERR, ">&SAVEERR");
204
205 ok($@, "");
206 ok($freezed ne '');
207}
208
209{
210 my $safe = new Safe;
464b080a 211 local $Storable::Eval = sub { $safe->reval(shift) };
212
197b90bc 213 $freezed = freeze $obj[0]->[0];
214 $@ = "";
215 eval { $thawed = thaw $freezed };
216 ok($@, "");
217 ok($thawed->(), "JAPH");
464b080a 218
219 $freezed = freeze $obj[0]->[6];
220 eval { $thawed = thaw $freezed };
8578bbeb 221 # The "Code sub ..." error message only appears if Log::Agent is installed
222 ok($@, qr/(trapped|Code sub)/);
464b080a 223
224 if (0) {
225 # Disable or fix this test if the internal representation of Storable
226 # changes.
227 skip("no malicious storable file check", 1);
228 } else {
229 # Construct malicious storable code
230 $freezed = nfreeze $obj[0]->[0];
231 my $bad_code = ';open FOO, "/badfile"';
232 # 5th byte is (short) length of scalar
233 my $len = ord(substr($freezed, 4, 1));
234 substr($freezed, 4, 1, chr($len+length($bad_code)));
235 substr($freezed, -1, 0, $bad_code);
236 $@ = "";
237 eval { $thawed = thaw $freezed };
8578bbeb 238 ok($@, qr/(trapped|Code sub)/);
464b080a 239 }
240}
241
242{
197b90bc 243 my $safe = new Safe;
244 # because of opcodes used in "use strict":
e279cb0b 245 $safe->permit(qw(:default require));
197b90bc 246 local $Storable::Eval = sub { $safe->reval(shift) };
247
248 $freezed = freeze $obj[0]->[1];
249 $@ = "";
250 eval { $thawed = thaw $freezed };
251 ok($@, "");
252 ok($thawed->(), 42);
253}
254
255{
464b080a 256 {
257 package MySafe;
258 sub new { bless {}, shift }
259 sub reval {
260 my $source = $_[1];
261 # Here you can apply some nifty regexpes to ensure the
262 # safeness of the source code.
263 my $coderef = eval $source;
264 $coderef;
265 }
266 }
267
268 my $safe = new MySafe;
269 local $Storable::Eval = sub { $safe->reval($_[0]) };
270
271 $freezed = freeze $obj[0];
272 eval { $thawed = thaw $freezed };
273 ok($@, "");
274
275 if ($@ ne "") {
276 ok(0) for (1..5);
277 } else {
278 ok($thawed->[0]->(), "JAPH");
279 ok($thawed->[1]->(), 42);
280 ok($thawed->[2]->(), "blessed");
281 ok($thawed->[3]->(), "Another::Package");
282 ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
283 }
284}
285
a8b7ef86 286{
287 # Check internal "seen" code
288 my $short_sub = sub { "short sub" }; # for SX_SCALAR
289 # for SX_LSCALAR
290 my $long_sub_code = 'sub { "' . "x"x255 . '" }';
291 my $long_sub = eval $long_sub_code; die $@ if $@;
292 my $sclr = \1;
293
294 local $Storable::Deparse = 1;
295 local $Storable::Eval = 1;
296
297 for my $sub ($short_sub, $long_sub) {
298 my $res;
299
300 $res = thaw freeze [$sub, $sub];
301 ok(int($res->[0]), int($res->[1]));
302
303 $res = thaw freeze [$sclr, $sub, $sub, $sclr];
304 ok(int($res->[0]), int($res->[3]));
305 ok(int($res->[1]), int($res->[2]));
306
307 $res = thaw freeze [$sub, $sub, $sclr, $sclr];
308 ok(int($res->[0]), int($res->[1]));
309 ok(int($res->[2]), int($res->[3]));
310 }
311
312}