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 { 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 19use strict; 20BEGIN { 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 37BEGIN { plan tests => 63 } 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 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 54local *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 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])); 91 92###################################################################### 93 94$freezed = freeze $obj[1]; 95$thawed = thaw $freezed; 96 97is($thawed->{"a"}->(), "srt"); 98is($thawed->{"b"}->(), "JAPH"); 99 100###################################################################### 101 102$freezed = freeze $obj[2]; 103$thawed = thaw $freezed; 104 105is($thawed->(), 42); 106 107###################################################################### 108 109$freezed = freeze $obj[3]; 110$thawed = thaw $freezed; 111 112is($thawed->(), "JAPH"); 113 114###################################################################### 115 116eval { $freezed = freeze $obj[4] }; 117like($@, qr/The result of B::Deparse::coderef2text was empty/); 118 119###################################################################### 120# Test dclone 121 122my $new_sub = dclone($obj[2]); 123is($new_sub->(), $obj[2]->()); 124 125###################################################################### 126# Test retrieve & store 127 128store $obj[0], 'store'; 129$thawed = retrieve 'store'; 130 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])); 136 137###################################################################### 138 139nstore $obj[0], 'store'; 140$thawed = retrieve 'store'; 141unlink 'store'; 142 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])); 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 319