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