Typo fix.
[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;
28 use 5.6.0;
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
41BEGIN { plan tests => 47 }
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
50sub code { "JAPH" }
51$blessed_code = bless sub { "blessed" }, "Some::Package";
52{ package Another::Package; sub foo { __PACKAGE__ } }
53
54@obj =
55 ([\&code, # code reference
56 sub { 6*7 },
57 $blessed_code, # blessed code reference
58 \&Another::Package::foo, # code in another package
59 sub ($$;$) { 0 }, # prototypes
60 sub { print "test\n" },
61 \&Test::ok, # large scalar
62 ],
63
64 {"a" => sub { "srt" }, "b" => \&code},
65
66 sub { ord("a")-ord("7") },
67
68 \&code,
69
70 \&dclone, # XS function
71
72 sub { open FOO, "/" },
73 );
74
75$Storable::Deparse = 1;
76$Storable::Eval = 1;
77
78######################################################################
79# Test freeze & thaw
80
81$freezed = freeze $obj[0];
82$thawed = thaw $freezed;
83
84ok($thawed->[0]->(), "JAPH");
85ok($thawed->[1]->(), 42);
86ok($thawed->[2]->(), "blessed");
87ok($thawed->[3]->(), "Another::Package");
88ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
89
90######################################################################
91
92$freezed = freeze $obj[1];
93$thawed = thaw $freezed;
94
95ok($thawed->{"a"}->(), "srt");
96ok($thawed->{"b"}->(), "JAPH");
97
98######################################################################
99
100$freezed = freeze $obj[2];
101$thawed = thaw $freezed;
102
103ok($thawed->(), 42);
104
105######################################################################
106
107$freezed = freeze $obj[3];
108$thawed = thaw $freezed;
109
110ok($thawed->(), "JAPH");
111
112######################################################################
113
114eval { $freezed = freeze $obj[4] };
115ok($@ =~ /The result of B::Deparse::coderef2text was empty/);
116
117######################################################################
118# Test dclone
119
120my $new_sub = dclone($obj[2]);
121ok($new_sub->(), $obj[2]->());
122
123######################################################################
124# Test retrieve & store
125
126store $obj[0], 'store';
127$thawed = retrieve 'store';
128
129ok($thawed->[0]->(), "JAPH");
130ok($thawed->[1]->(), 42);
131ok($thawed->[2]->(), "blessed");
132ok($thawed->[3]->(), "Another::Package");
133ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
134
135######################################################################
136
137nstore $obj[0], 'store';
138$thawed = retrieve 'store';
139unlink 'store';
140
141ok($thawed->[0]->(), "JAPH");
142ok($thawed->[1]->(), 42);
143ok($thawed->[2]->(), "blessed");
144ok($thawed->[3]->(), "Another::Package");
145ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
146
147######################################################################
148# Security with
149# $Storable::Eval
150# $Storable::Safe
151# $Storable::Deparse
152
153{
154 local $Storable::Eval = 0;
155
156 for my $i (0 .. 1) {
157 $freezed = freeze $obj[$i];
158 $@ = "";
159 eval { $thawed = thaw $freezed };
160 ok($@ =~ /Can\'t eval/);
161 }
162}
163
164{
165
166 local $Storable::Deparse = 0;
167 for my $i (0 .. 1) {
168 $@ = "";
169 eval { $freezed = freeze $obj[$i] };
170 ok($@ =~ /Can\'t store CODE items/);
171 }
172}
173
174{
175 local $Storable::Eval = 0;
176 local $Storable::forgive_me = 1;
177 for my $i (0 .. 4) {
178 $freezed = freeze $obj[0]->[$i];
179 $@ = "";
180 eval { $thawed = thaw $freezed };
181 ok($@, "");
182 ok($$thawed =~ /^sub/);
183 }
184}
185
186{
187 local $Storable::Deparse = 0;
188 local $Storable::forgive_me = 1;
189
190 my $devnull = File::Spec->devnull;
191
192 open(SAVEERR, ">&STDERR");
193 open(STDERR, ">$devnull") or
194 ( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) );
195
196 eval { $freezed = freeze $obj[0]->[0] };
197
198 open(STDERR, ">&SAVEERR");
199
200 ok($@, "");
201 ok($freezed ne '');
202}
203
204{
205 my $safe = new Safe;
206 $safe->permit(qw(:default require));
207 local $Storable::Eval = sub { $safe->reval(shift) };
208
209 for my $def ([0 => "JAPH",
210 1 => 42,
211 ]
212 ) {
213 my($i, $res) = @$def;
214 $freezed = freeze $obj[0]->[$i];
215 $@ = "";
216 eval { $thawed = thaw $freezed };
d329d3eb 217 skip(q{ok($@, ""});
218 skip(q{$thawed->(), $res});
464b080a 219 }
220
221 $freezed = freeze $obj[0]->[6];
222 eval { $thawed = thaw $freezed };
223 ok($@ =~ /trapped/);
224
225 if (0) {
226 # Disable or fix this test if the internal representation of Storable
227 # changes.
228 skip("no malicious storable file check", 1);
229 } else {
230 # Construct malicious storable code
231 $freezed = nfreeze $obj[0]->[0];
232 my $bad_code = ';open FOO, "/badfile"';
233 # 5th byte is (short) length of scalar
234 my $len = ord(substr($freezed, 4, 1));
235 substr($freezed, 4, 1, chr($len+length($bad_code)));
236 substr($freezed, -1, 0, $bad_code);
237 $@ = "";
238 eval { $thawed = thaw $freezed };
239 ok($@ =~ /trapped/);
240 }
241}
242
243{
244 {
245 package MySafe;
246 sub new { bless {}, shift }
247 sub reval {
248 my $source = $_[1];
249 # Here you can apply some nifty regexpes to ensure the
250 # safeness of the source code.
251 my $coderef = eval $source;
252 $coderef;
253 }
254 }
255
256 my $safe = new MySafe;
257 local $Storable::Eval = sub { $safe->reval($_[0]) };
258
259 $freezed = freeze $obj[0];
260 eval { $thawed = thaw $freezed };
261 ok($@, "");
262
263 if ($@ ne "") {
264 ok(0) for (1..5);
265 } else {
266 ok($thawed->[0]->(), "JAPH");
267 ok($thawed->[1]->(), 42);
268 ok($thawed->[2]->(), "blessed");
269 ok($thawed->[3]->(), "Another::Package");
270 ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
271 }
272}
273