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