Commit | Line | Data |
---|---|---|
464b080a SR |
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 SR |
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 SR |
50 | $blessed_code = bless sub { "blessed" }, "Some::Package"; |
51 | { package Another::Package; sub foo { __PACKAGE__ } } | |
52 | ||
197b90bc SR |
53 | { |
54 | no strict; # to make the life for Safe->reval easier | |
55 | sub code { "JAPH" } | |
56 | } | |
57 | ||
464b080a SR |
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 SR |
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 SR |
209 | local $Storable::Eval = sub { $safe->reval(shift) }; |
210 | ||
197b90bc SR |
211 | $freezed = freeze $obj[0]->[0]; |
212 | $@ = ""; | |
213 | eval { $thawed = thaw $freezed }; | |
214 | ok($@, ""); | |
215 | ok($thawed->(), "JAPH"); | |
464b080a SR |
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 SR |
240 | my $safe = new Safe; |
241 | # because of opcodes used in "use strict": | |
e279cb0b | 242 | $safe->permit(qw(:default require)); |
197b90bc SR |
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 SR |
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 |