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 44our ($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->(), (ord "A") == 193 ? -118 : 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# $Storable::DEBUGME = 1; 130$thawed = retrieve "store$$"; 131 132is($thawed->[0]->(), "JAPH"); 133is($thawed->[1]->(), 42); 134is($thawed->[2]->(), "blessed"); 135is($thawed->[3]->(), "Another::Package"); 136is(prototype($thawed->[4]), prototype($obj[0]->[4])); 137 138###################################################################### 139 140nstore $obj[0], "store$$"; 141$thawed = retrieve "store$$"; 142unlink "store$$"; 143 144is($thawed->[0]->(), "JAPH"); 145is($thawed->[1]->(), 42); 146is($thawed->[2]->(), "blessed"); 147is($thawed->[3]->(), "Another::Package"); 148is(prototype($thawed->[4]), prototype($obj[0]->[4])); 149 150###################################################################### 151# Security with 152# $Storable::Eval 153# $Storable::Deparse 154 155{ 156 local $Storable::Eval = 0; 157 158 for my $i (0 .. 1) { 159 $freezed = freeze $obj[$i]; 160 $@ = ""; 161 eval { $thawed = thaw $freezed }; 162 like($@, qr/Can\'t eval/); 163 } 164} 165 166{ 167 168 local $Storable::Deparse = 0; 169 for my $i (0 .. 1) { 170 $@ = ""; 171 eval { $freezed = freeze $obj[$i] }; 172 like($@, qr/Can\'t store CODE items/); 173 } 174} 175 176{ 177 local $Storable::Eval = 0; 178 local $Storable::forgive_me = 1; 179 for my $i (0 .. 4) { 180 $freezed = freeze $obj[0]->[$i]; 181 $@ = ""; 182 eval { $thawed = thaw $freezed }; 183 is($@, ""); 184 like($$thawed, qr/^sub/); 185 } 186} 187 188{ 189 local $Storable::Deparse = 0; 190 local $Storable::forgive_me = 1; 191 192 my $devnull = File::Spec->devnull; 193 194 open(SAVEERR, ">&STDERR"); 195 open(STDERR, '>', $devnull) or 196 ( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) ); 197 198 eval { $freezed = freeze $obj[0]->[0] }; 199 200 open(STDERR, ">&SAVEERR"); 201 202 is($@, ""); 203 isnt($freezed, ''); 204} 205 206{ 207 my $safe = new Safe; 208 local $Storable::Eval = sub { $safe->reval(shift) }; 209 210 $freezed = freeze $obj[0]->[0]; 211 $@ = ""; 212 eval { $thawed = thaw $freezed }; 213 is($@, ""); 214 is($thawed->(), "JAPH"); 215 216 $freezed = freeze $obj[0]->[6]; 217 eval { $thawed = thaw $freezed }; 218 # The "Code sub ..." error message only appears if Log::Agent is installed 219 like($@, qr/(trapped|Code sub)/); 220 221 if (0) { 222 # Disable or fix this test if the internal representation of Storable 223 # changes. 224 skip("no malicious storable file check", 1); 225 } else { 226 # Construct malicious storable code 227 $freezed = nfreeze $obj[0]->[0]; 228 my $bad_code = ';open FOO, "/badfile"'; 229 # 5th byte is (short) length of scalar 230 my $len = ord(substr($freezed, 4, 1)); 231 substr($freezed, 4, 1, chr($len+length($bad_code))); 232 substr($freezed, -1, 0, $bad_code); 233 $@ = ""; 234 eval { $thawed = thaw $freezed }; 235 like($@, qr/(trapped|Code sub)/); 236 } 237} 238 239{ 240 my $safe = new Safe; 241 # because of opcodes used in "use strict": 242 $safe->permit(qw(:default require caller)); 243 local $Storable::Eval = sub { $safe->reval(shift) }; 244 245 $freezed = freeze $obj[0]->[1]; 246 $@ = ""; 247 eval { $thawed = thaw $freezed }; 248 is($@, ""); 249 is($thawed->(), 42); 250} 251 252{ 253 { 254 package MySafe; 255 sub new { bless {}, shift } 256 sub reval { 257 my $source = $_[1]; 258 # Here you can apply some nifty regexpes to ensure the 259 # safeness of the source code. 260 my $coderef = eval $source; 261 $coderef; 262 } 263 } 264 265 my $safe = new MySafe; 266 local $Storable::Eval = sub { $safe->reval($_[0]) }; 267 268 $freezed = freeze $obj[0]; 269 eval { $thawed = thaw $freezed }; 270 is($@, ""); 271 272 if ($@ ne "") { 273 fail() for (1..5); 274 } else { 275 is($thawed->[0]->(), "JAPH"); 276 is($thawed->[1]->(), 42); 277 is($thawed->[2]->(), "blessed"); 278 is($thawed->[3]->(), "Another::Package"); 279 is(prototype($thawed->[4]), prototype($obj[0]->[4])); 280 } 281} 282 283{ 284 # Check internal "seen" code 285 my $short_sub = sub { "short sub" }; # for SX_SCALAR 286 # for SX_LSCALAR 287 my $long_sub_code = 'sub { "' . "x"x255 . '" }'; 288 my $long_sub = eval $long_sub_code; die $@ if $@; 289 my $sclr = \1; 290 291 local $Storable::Deparse = 1; 292 local $Storable::Eval = 1; 293 294 for my $sub ($short_sub, $long_sub) { 295 my $res; 296 297 $res = thaw freeze [$sub, $sub]; 298 is(int($res->[0]), int($res->[1])); 299 300 $res = thaw freeze [$sclr, $sub, $sub, $sclr]; 301 is(int($res->[0]), int($res->[3])); 302 is(int($res->[1]), int($res->[2])); 303 304 $res = thaw freeze [$sub, $sub, $sclr, $sclr]; 305 is(int($res->[0]), int($res->[1])); 306 is(int($res->[2]), int($res->[3])); 307 } 308 309} 310 311{ 312 my @text = ("hello", "\x{a3}", "\x{a3} \x{2234}", "\x{2234}\x{2234}"); 313 314 for my $text(@text) { 315 my $res = (thaw freeze eval "sub {'" . $text . "'}")->(); 316 ok($res eq $text); 317 } 318} 319 320