This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
c383142d5aacfddf71f966cca3ff9228727decd9
[perl5.git] / dist / Storable / t / code.t
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     unshift @INC, 't';
11     unshift @INC, 't/compat' if $] < 5.006002;
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
19 use strict;
20 BEGIN {
21     if (!eval q{
22         use Test::More;
23         use B::Deparse 0.61;
24         use 5.006;
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
37 BEGIN { plan tests => 63 }
38
39 use Storable qw(retrieve store nstore freeze nfreeze thaw dclone);
40 use Safe;
41
42 #$Storable::DEBUGME = 1;
43
44 use vars qw($freezed $thawed @obj @res $blessed_code);
45
46 $blessed_code = bless sub { "blessed" }, "Some::Package";
47 { package Another::Package; sub foo { __PACKAGE__ } }
48
49 {
50     no strict; # to make the life for Safe->reval easier
51     sub code { "JAPH" }
52 }
53
54 local *FOO;
55
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" },
63       \&Storable::_store,       # large scalar
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
86 is($thawed->[0]->(), "JAPH");
87 is($thawed->[1]->(), 42);
88 is($thawed->[2]->(), "blessed");
89 is($thawed->[3]->(), "Another::Package");
90 is(prototype($thawed->[4]), prototype($obj[0]->[4]));
91
92 ######################################################################
93
94 $freezed = freeze $obj[1];
95 $thawed  = thaw $freezed;
96
97 is($thawed->{"a"}->(), "srt");
98 is($thawed->{"b"}->(), "JAPH");
99
100 ######################################################################
101
102 $freezed = freeze $obj[2];
103 $thawed  = thaw $freezed;
104
105 is($thawed->(), 42);
106
107 ######################################################################
108
109 $freezed = freeze $obj[3];
110 $thawed  = thaw $freezed;
111
112 is($thawed->(), "JAPH");
113
114 ######################################################################
115
116 eval { $freezed = freeze $obj[4] };
117 like($@, qr/The result of B::Deparse::coderef2text was empty/);
118
119 ######################################################################
120 # Test dclone
121
122 my $new_sub = dclone($obj[2]);
123 is($new_sub->(), $obj[2]->());
124
125 ######################################################################
126 # Test retrieve & store
127
128 store $obj[0], 'store';
129 $thawed = retrieve 'store';
130
131 is($thawed->[0]->(), "JAPH");
132 is($thawed->[1]->(), 42);
133 is($thawed->[2]->(), "blessed");
134 is($thawed->[3]->(), "Another::Package");
135 is(prototype($thawed->[4]), prototype($obj[0]->[4]));
136
137 ######################################################################
138
139 nstore $obj[0], 'store';
140 $thawed = retrieve 'store';
141 unlink 'store';
142
143 is($thawed->[0]->(), "JAPH");
144 is($thawed->[1]->(), 42);
145 is($thawed->[2]->(), "blessed");
146 is($thawed->[3]->(), "Another::Package");
147 is(prototype($thawed->[4]), prototype($obj[0]->[4]));
148
149 ######################################################################
150 # Security with
151 #   $Storable::Eval
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 };
161         like($@, qr/Can\'t eval/);
162     }
163 }
164
165 {
166
167     local $Storable::Deparse = 0;
168     for my $i (0 .. 1) {
169         $@ = "";
170         eval { $freezed = freeze $obj[$i] };
171         like($@, qr/Can\'t store CODE items/);
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 };
182         is($@, "");
183         like($$thawed, qr/^sub/);
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
201     is($@, "");
202     isnt($freezed, '');
203 }
204
205 {
206     my $safe = new Safe;
207     local $Storable::Eval = sub { $safe->reval(shift) };
208
209     $freezed = freeze $obj[0]->[0];
210     $@ = "";
211     eval { $thawed = thaw $freezed };
212     is($@, "");
213     is($thawed->(), "JAPH");
214
215     $freezed = freeze $obj[0]->[6];
216     eval { $thawed = thaw $freezed };
217     # The "Code sub ..." error message only appears if Log::Agent is installed
218     like($@, qr/(trapped|Code sub)/);
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 };
234         like($@, qr/(trapped|Code sub)/);
235     }
236 }
237
238 {
239     my $safe = new Safe;
240     # because of opcodes used in "use strict":
241     $safe->permit(qw(:default require caller));
242     local $Storable::Eval = sub { $safe->reval(shift) };
243
244     $freezed = freeze $obj[0]->[1];
245     $@ = "";
246     eval { $thawed = thaw $freezed };
247     is($@, "");
248     is($thawed->(), 42);
249 }
250
251 {
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 };
269     is($@, "");
270
271     if ($@ ne "") {
272         fail() for (1..5);
273     } else {
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]));
279     }
280 }
281
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];
297         is(int($res->[0]), int($res->[1]));
298
299         $res = thaw freeze [$sclr, $sub, $sub, $sclr];
300         is(int($res->[0]), int($res->[3]));
301         is(int($res->[1]), int($res->[2]));
302
303         $res = thaw freeze [$sub, $sub, $sclr, $sclr];
304         is(int($res->[0]), int($res->[1]));
305         is(int($res->[2]), int($res->[3]));
306     }
307
308 }
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