3 # Copyright (c) 2002 Slaven Rezic
5 # You may redistribute only under the same terms as Perl 5, as specified
6 # in the README file that comes with the distribution.
11 require Config; import Config;
12 if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
13 print "1..0 # Skip: Storable was not built\n";
26 print "1..0 # skip: tests only work with B::Deparse 0.61 and at least perl 5.6.0\n";
30 if ($File::Spec::VERSION < 0.8) {
31 print "1..0 # Skip: newer File::Spec needed\n";
36 BEGIN { plan tests => 59 }
38 use Storable qw(retrieve store nstore freeze nfreeze thaw dclone);
41 #$Storable::DEBUGME = 1;
43 use vars qw($freezed $thawed @obj @res $blessed_code);
45 $blessed_code = bless sub { "blessed" }, "Some::Package";
46 { package Another::Package; sub foo { __PACKAGE__ } }
49 no strict; # to make the life for Safe->reval easier
56 ([\&code, # code reference
58 $blessed_code, # blessed code reference
59 \&Another::Package::foo, # code in another package
60 sub ($$;$) { 0 }, # prototypes
61 sub { print "test\n" },
62 \&Test::ok, # large scalar
65 {"a" => sub { "srt" }, "b" => \&code},
67 sub { ord("a")-ord("7") },
71 \&dclone, # XS function
73 sub { open FOO, "/" },
76 $Storable::Deparse = 1;
79 ######################################################################
82 $freezed = freeze $obj[0];
83 $thawed = thaw $freezed;
85 ok($thawed->[0]->(), "JAPH");
86 ok($thawed->[1]->(), 42);
87 ok($thawed->[2]->(), "blessed");
88 ok($thawed->[3]->(), "Another::Package");
89 ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
91 ######################################################################
93 $freezed = freeze $obj[1];
94 $thawed = thaw $freezed;
96 ok($thawed->{"a"}->(), "srt");
97 ok($thawed->{"b"}->(), "JAPH");
99 ######################################################################
101 $freezed = freeze $obj[2];
102 $thawed = thaw $freezed;
106 ######################################################################
108 $freezed = freeze $obj[3];
109 $thawed = thaw $freezed;
111 ok($thawed->(), "JAPH");
113 ######################################################################
115 eval { $freezed = freeze $obj[4] };
116 ok($@, qr/The result of B::Deparse::coderef2text was empty/);
118 ######################################################################
121 my $new_sub = dclone($obj[2]);
122 ok($new_sub->(), $obj[2]->());
124 ######################################################################
125 # Test retrieve & store
127 store $obj[0], 'store';
128 $thawed = retrieve 'store';
130 ok($thawed->[0]->(), "JAPH");
131 ok($thawed->[1]->(), 42);
132 ok($thawed->[2]->(), "blessed");
133 ok($thawed->[3]->(), "Another::Package");
134 ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
136 ######################################################################
138 nstore $obj[0], 'store';
139 $thawed = retrieve 'store';
142 ok($thawed->[0]->(), "JAPH");
143 ok($thawed->[1]->(), 42);
144 ok($thawed->[2]->(), "blessed");
145 ok($thawed->[3]->(), "Another::Package");
146 ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
148 ######################################################################
154 local $Storable::Eval = 0;
157 $freezed = freeze $obj[$i];
159 eval { $thawed = thaw $freezed };
160 ok($@, qr/Can\'t eval/);
166 local $Storable::Deparse = 0;
169 eval { $freezed = freeze $obj[$i] };
170 ok($@, qr/Can\'t store CODE items/);
175 local $Storable::Eval = 0;
176 local $Storable::forgive_me = 1;
178 $freezed = freeze $obj[0]->[$i];
180 eval { $thawed = thaw $freezed };
182 ok($$thawed, qr/^sub/);
187 local $Storable::Deparse = 0;
188 local $Storable::forgive_me = 1;
190 my $devnull = File::Spec->devnull;
192 open(SAVEERR, ">&STDERR");
193 open(STDERR, ">$devnull") or
194 ( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) );
196 eval { $freezed = freeze $obj[0]->[0] };
198 open(STDERR, ">&SAVEERR");
206 local $Storable::Eval = sub { $safe->reval(shift) };
208 $freezed = freeze $obj[0]->[0];
210 eval { $thawed = thaw $freezed };
212 ok($thawed->(), "JAPH");
214 $freezed = freeze $obj[0]->[6];
215 eval { $thawed = thaw $freezed };
216 # The "Code sub ..." error message only appears if Log::Agent is installed
217 ok($@, qr/(trapped|Code sub)/);
220 # Disable or fix this test if the internal representation of Storable
222 skip("no malicious storable file check", 1);
224 # Construct malicious storable code
225 $freezed = nfreeze $obj[0]->[0];
226 my $bad_code = ';open FOO, "/badfile"';
227 # 5th byte is (short) length of scalar
228 my $len = ord(substr($freezed, 4, 1));
229 substr($freezed, 4, 1, chr($len+length($bad_code)));
230 substr($freezed, -1, 0, $bad_code);
232 eval { $thawed = thaw $freezed };
233 ok($@, qr/(trapped|Code sub)/);
239 # because of opcodes used in "use strict":
240 $safe->permit(qw(:default require caller));
241 local $Storable::Eval = sub { $safe->reval(shift) };
243 $freezed = freeze $obj[0]->[1];
245 eval { $thawed = thaw $freezed };
253 sub new { bless {}, shift }
256 # Here you can apply some nifty regexpes to ensure the
257 # safeness of the source code.
258 my $coderef = eval $source;
263 my $safe = new MySafe;
264 local $Storable::Eval = sub { $safe->reval($_[0]) };
266 $freezed = freeze $obj[0];
267 eval { $thawed = thaw $freezed };
273 ok($thawed->[0]->(), "JAPH");
274 ok($thawed->[1]->(), 42);
275 ok($thawed->[2]->(), "blessed");
276 ok($thawed->[3]->(), "Another::Package");
277 ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
282 # Check internal "seen" code
283 my $short_sub = sub { "short sub" }; # for SX_SCALAR
285 my $long_sub_code = 'sub { "' . "x"x255 . '" }';
286 my $long_sub = eval $long_sub_code; die $@ if $@;
289 local $Storable::Deparse = 1;
290 local $Storable::Eval = 1;
292 for my $sub ($short_sub, $long_sub) {
295 $res = thaw freeze [$sub, $sub];
296 ok(int($res->[0]), int($res->[1]));
298 $res = thaw freeze [$sclr, $sub, $sub, $sclr];
299 ok(int($res->[0]), int($res->[3]));
300 ok(int($res->[1]), int($res->[2]));
302 $res = thaw freeze [$sub, $sub, $sclr, $sclr];
303 ok(int($res->[0]), int($res->[1]));
304 ok(int($res->[2]), int($res->[3]));