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.
12 @INC = ('.', '../lib');
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";
31 print "1..0 # skip: tests only work with B::Deparse 0.61 and at least perl 5.6.0\n";
35 if ($File::Spec::VERSION < 0.8) {
36 print "1..0 # Skip: newer File::Spec needed\n";
41 BEGIN { plan tests => 47 }
43 use Storable qw(retrieve store nstore freeze nfreeze thaw dclone);
46 #$Storable::DEBUGME = 1;
48 use vars qw($freezed $thawed @obj @res $blessed_code);
51 $blessed_code = bless sub { "blessed" }, "Some::Package";
52 { package Another::Package; sub foo { __PACKAGE__ } }
55 ([\&code, # code reference
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
64 {"a" => sub { "srt" }, "b" => \&code},
66 sub { ord("a")-ord("7") },
70 \&dclone, # XS function
72 sub { open FOO, "/" },
75 $Storable::Deparse = 1;
78 ######################################################################
81 $freezed = freeze $obj[0];
82 $thawed = thaw $freezed;
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]));
90 ######################################################################
92 $freezed = freeze $obj[1];
93 $thawed = thaw $freezed;
95 ok($thawed->{"a"}->(), "srt");
96 ok($thawed->{"b"}->(), "JAPH");
98 ######################################################################
100 $freezed = freeze $obj[2];
101 $thawed = thaw $freezed;
105 ######################################################################
107 $freezed = freeze $obj[3];
108 $thawed = thaw $freezed;
110 ok($thawed->(), "JAPH");
112 ######################################################################
114 eval { $freezed = freeze $obj[4] };
115 ok($@ =~ /The result of B::Deparse::coderef2text was empty/);
117 ######################################################################
120 my $new_sub = dclone($obj[2]);
121 ok($new_sub->(), $obj[2]->());
123 ######################################################################
124 # Test retrieve & store
126 store $obj[0], 'store';
127 $thawed = retrieve 'store';
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]));
135 ######################################################################
137 nstore $obj[0], 'store';
138 $thawed = retrieve 'store';
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]));
147 ######################################################################
154 local $Storable::Eval = 0;
157 $freezed = freeze $obj[$i];
159 eval { $thawed = thaw $freezed };
160 ok($@ =~ /Can\'t eval/);
166 local $Storable::Deparse = 0;
169 eval { $freezed = freeze $obj[$i] };
170 ok($@ =~ /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 =~ /^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 $safe->permit(qw(:default require));
207 local $Storable::Eval = sub { $safe->reval(shift) };
209 for my $def ([0 => "JAPH",
213 my($i, $res) = @$def;
214 $freezed = freeze $obj[0]->[$i];
216 eval { $thawed = thaw $freezed };
218 skip(q{$thawed->(), $res});
221 $freezed = freeze $obj[0]->[6];
222 eval { $thawed = thaw $freezed };
226 # Disable or fix this test if the internal representation of Storable
228 skip("no malicious storable file check", 1);
230 # Construct malicious storable code
231 $freezed = nfreeze $obj[0]->[0];
232 my $bad_code = ';open FOO, "/badfile"';
233 # 5th byte is (short) length of scalar
234 my $len = ord(substr($freezed, 4, 1));
235 substr($freezed, 4, 1, chr($len+length($bad_code)));
236 substr($freezed, -1, 0, $bad_code);
238 eval { $thawed = thaw $freezed };
246 sub new { bless {}, shift }
249 # Here you can apply some nifty regexpes to ensure the
250 # safeness of the source code.
251 my $coderef = eval $source;
256 my $safe = new MySafe;
257 local $Storable::Eval = sub { $safe->reval($_[0]) };
259 $freezed = freeze $obj[0];
260 eval { $thawed = thaw $freezed };
266 ok($thawed->[0]->(), "JAPH");
267 ok($thawed->[1]->(), 42);
268 ok($thawed->[2]->(), "blessed");
269 ok($thawed->[3]->(), "Another::Package");
270 ok(prototype($thawed->[4]), prototype($obj[0]->[4]));