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