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 | |
41 | BEGIN { plan tests => 47 } |
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 | |
50 | sub 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 | |
84 | ok($thawed->[0]->(), "JAPH"); |
85 | ok($thawed->[1]->(), 42); |
86 | ok($thawed->[2]->(), "blessed"); |
87 | ok($thawed->[3]->(), "Another::Package"); |
88 | ok(prototype($thawed->[4]), prototype($obj[0]->[4])); |
89 | |
90 | ###################################################################### |
91 | |
92 | $freezed = freeze $obj[1]; |
93 | $thawed = thaw $freezed; |
94 | |
95 | ok($thawed->{"a"}->(), "srt"); |
96 | ok($thawed->{"b"}->(), "JAPH"); |
97 | |
98 | ###################################################################### |
99 | |
100 | $freezed = freeze $obj[2]; |
101 | $thawed = thaw $freezed; |
102 | |
103 | ok($thawed->(), 42); |
104 | |
105 | ###################################################################### |
106 | |
107 | $freezed = freeze $obj[3]; |
108 | $thawed = thaw $freezed; |
109 | |
110 | ok($thawed->(), "JAPH"); |
111 | |
112 | ###################################################################### |
113 | |
114 | eval { $freezed = freeze $obj[4] }; |
115 | ok($@ =~ /The result of B::Deparse::coderef2text was empty/); |
116 | |
117 | ###################################################################### |
118 | # Test dclone |
119 | |
120 | my $new_sub = dclone($obj[2]); |
121 | ok($new_sub->(), $obj[2]->()); |
122 | |
123 | ###################################################################### |
124 | # Test retrieve & store |
125 | |
126 | store $obj[0], 'store'; |
127 | $thawed = retrieve 'store'; |
128 | |
129 | ok($thawed->[0]->(), "JAPH"); |
130 | ok($thawed->[1]->(), 42); |
131 | ok($thawed->[2]->(), "blessed"); |
132 | ok($thawed->[3]->(), "Another::Package"); |
133 | ok(prototype($thawed->[4]), prototype($obj[0]->[4])); |
134 | |
135 | ###################################################################### |
136 | |
137 | nstore $obj[0], 'store'; |
138 | $thawed = retrieve 'store'; |
139 | unlink 'store'; |
140 | |
141 | ok($thawed->[0]->(), "JAPH"); |
142 | ok($thawed->[1]->(), 42); |
143 | ok($thawed->[2]->(), "blessed"); |
144 | ok($thawed->[3]->(), "Another::Package"); |
145 | ok(prototype($thawed->[4]), prototype($obj[0]->[4])); |
146 | |
147 | ###################################################################### |
148 | # Security with |
149 | # $Storable::Eval |
464b080a |
150 | # $Storable::Deparse |
151 | |
152 | { |
153 | local $Storable::Eval = 0; |
154 | |
155 | for my $i (0 .. 1) { |
156 | $freezed = freeze $obj[$i]; |
157 | $@ = ""; |
158 | eval { $thawed = thaw $freezed }; |
159 | ok($@ =~ /Can\'t eval/); |
160 | } |
161 | } |
162 | |
163 | { |
164 | |
165 | local $Storable::Deparse = 0; |
166 | for my $i (0 .. 1) { |
167 | $@ = ""; |
168 | eval { $freezed = freeze $obj[$i] }; |
169 | ok($@ =~ /Can\'t store CODE items/); |
170 | } |
171 | } |
172 | |
173 | { |
174 | local $Storable::Eval = 0; |
175 | local $Storable::forgive_me = 1; |
176 | for my $i (0 .. 4) { |
177 | $freezed = freeze $obj[0]->[$i]; |
178 | $@ = ""; |
179 | eval { $thawed = thaw $freezed }; |
180 | ok($@, ""); |
181 | ok($$thawed =~ /^sub/); |
182 | } |
183 | } |
184 | |
185 | { |
186 | local $Storable::Deparse = 0; |
187 | local $Storable::forgive_me = 1; |
188 | |
189 | my $devnull = File::Spec->devnull; |
190 | |
191 | open(SAVEERR, ">&STDERR"); |
192 | open(STDERR, ">$devnull") or |
193 | ( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) ); |
194 | |
195 | eval { $freezed = freeze $obj[0]->[0] }; |
196 | |
197 | open(STDERR, ">&SAVEERR"); |
198 | |
199 | ok($@, ""); |
200 | ok($freezed ne ''); |
201 | } |
202 | |
203 | { |
204 | my $safe = new Safe; |
205 | $safe->permit(qw(:default require)); |
206 | local $Storable::Eval = sub { $safe->reval(shift) }; |
207 | |
208 | for my $def ([0 => "JAPH", |
209 | 1 => 42, |
210 | ] |
211 | ) { |
212 | my($i, $res) = @$def; |
213 | $freezed = freeze $obj[0]->[$i]; |
214 | $@ = ""; |
215 | eval { $thawed = thaw $freezed }; |
d2b96869 |
216 | ok($@, ""); |
217 | ok($thawed->(), $res); |
464b080a |
218 | } |
219 | |
220 | $freezed = freeze $obj[0]->[6]; |
221 | eval { $thawed = thaw $freezed }; |
222 | ok($@ =~ /trapped/); |
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 }; |
238 | ok($@ =~ /trapped/); |
239 | } |
240 | } |
241 | |
242 | { |
243 | { |
244 | package MySafe; |
245 | sub new { bless {}, shift } |
246 | sub reval { |
247 | my $source = $_[1]; |
248 | # Here you can apply some nifty regexpes to ensure the |
249 | # safeness of the source code. |
250 | my $coderef = eval $source; |
251 | $coderef; |
252 | } |
253 | } |
254 | |
255 | my $safe = new MySafe; |
256 | local $Storable::Eval = sub { $safe->reval($_[0]) }; |
257 | |
258 | $freezed = freeze $obj[0]; |
259 | eval { $thawed = thaw $freezed }; |
260 | ok($@, ""); |
261 | |
262 | if ($@ ne "") { |
263 | ok(0) for (1..5); |
264 | } else { |
265 | ok($thawed->[0]->(), "JAPH"); |
266 | ok($thawed->[1]->(), 42); |
267 | ok($thawed->[2]->(), "blessed"); |
268 | ok($thawed->[3]->(), "Another::Package"); |
269 | ok(prototype($thawed->[4]), prototype($obj[0]->[4])); |
270 | } |
271 | } |
272 | |