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 if ($ENV{PERL_CORE}){ 11 chdir('t') if -d 't'; 12 @INC = ('.', '../lib'); 13 } else { 14 unshift @INC, 't'; 15 } 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"; 19 exit 0; 20 } 21} 22 23use strict; 24BEGIN { 25 if (!eval q{ 26 use Test; 27 use B::Deparse 0.61; 28 use 5.006; 29 1; 30 }) { 31 print "1..0 # skip: tests only work with B::Deparse 0.61 and at least perl 5.6.0\n"; 32 exit; 33 } 34 require File::Spec; 35 if ($File::Spec::VERSION < 0.8) { 36 print "1..0 # Skip: newer File::Spec needed\n"; 37 exit 0; 38 } 39} 40 41BEGIN { plan tests => 59 } 42 43use Storable qw(retrieve store nstore freeze nfreeze thaw dclone); 44use Safe; 45 46#$Storable::DEBUGME = 1; 47 48use vars qw($freezed $thawed @obj @res $blessed_code); 49 50$blessed_code = bless sub { "blessed" }, "Some::Package"; 51{ package Another::Package; sub foo { __PACKAGE__ } } 52 53{ 54 no strict; # to make the life for Safe->reval easier 55 sub code { "JAPH" } 56} 57 58local *FOO; 59 60@obj = 61 ([\&code, # code reference 62 sub { 6*7 }, 63 $blessed_code, # blessed code reference 64 \&Another::Package::foo, # code in another package 65 sub ($$;$) { 0 }, # prototypes 66 sub { print "test\n" }, 67 \&Test::ok, # large scalar 68 ], 69 70 {"a" => sub { "srt" }, "b" => \&code}, 71 72 sub { ord("a")-ord("7") }, 73 74 \&code, 75 76 \&dclone, # XS function 77 78 sub { open FOO, "/" }, 79 ); 80 81$Storable::Deparse = 1; 82$Storable::Eval = 1; 83 84###################################################################### 85# Test freeze & thaw 86 87$freezed = freeze $obj[0]; 88$thawed = thaw $freezed; 89 90ok($thawed->[0]->(), "JAPH"); 91ok($thawed->[1]->(), 42); 92ok($thawed->[2]->(), "blessed"); 93ok($thawed->[3]->(), "Another::Package"); 94ok(prototype($thawed->[4]), prototype($obj[0]->[4])); 95 96###################################################################### 97 98$freezed = freeze $obj[1]; 99$thawed = thaw $freezed; 100 101ok($thawed->{"a"}->(), "srt"); 102ok($thawed->{"b"}->(), "JAPH"); 103 104###################################################################### 105 106$freezed = freeze $obj[2]; 107$thawed = thaw $freezed; 108 109ok($thawed->(), 42); 110 111###################################################################### 112 113$freezed = freeze $obj[3]; 114$thawed = thaw $freezed; 115 116ok($thawed->(), "JAPH"); 117 118###################################################################### 119 120eval { $freezed = freeze $obj[4] }; 121ok($@, qr/The result of B::Deparse::coderef2text was empty/); 122 123###################################################################### 124# Test dclone 125 126my $new_sub = dclone($obj[2]); 127ok($new_sub->(), $obj[2]->()); 128 129###################################################################### 130# Test retrieve & store 131 132store $obj[0], 'store'; 133$thawed = retrieve 'store'; 134 135ok($thawed->[0]->(), "JAPH"); 136ok($thawed->[1]->(), 42); 137ok($thawed->[2]->(), "blessed"); 138ok($thawed->[3]->(), "Another::Package"); 139ok(prototype($thawed->[4]), prototype($obj[0]->[4])); 140 141###################################################################### 142 143nstore $obj[0], 'store'; 144$thawed = retrieve 'store'; 145unlink 'store'; 146 147ok($thawed->[0]->(), "JAPH"); 148ok($thawed->[1]->(), 42); 149ok($thawed->[2]->(), "blessed"); 150ok($thawed->[3]->(), "Another::Package"); 151ok(prototype($thawed->[4]), prototype($obj[0]->[4])); 152 153###################################################################### 154# Security with 155# $Storable::Eval 156# $Storable::Deparse 157 158{ 159 local $Storable::Eval = 0; 160 161 for my $i (0 .. 1) { 162 $freezed = freeze $obj[$i]; 163 $@ = ""; 164 eval { $thawed = thaw $freezed }; 165 ok($@, qr/Can\'t eval/); 166 } 167} 168 169{ 170 171 local $Storable::Deparse = 0; 172 for my $i (0 .. 1) { 173 $@ = ""; 174 eval { $freezed = freeze $obj[$i] }; 175 ok($@, qr/Can\'t store CODE items/); 176 } 177} 178 179{ 180 local $Storable::Eval = 0; 181 local $Storable::forgive_me = 1; 182 for my $i (0 .. 4) { 183 $freezed = freeze $obj[0]->[$i]; 184 $@ = ""; 185 eval { $thawed = thaw $freezed }; 186 ok($@, ""); 187 ok($$thawed, qr/^sub/); 188 } 189} 190 191{ 192 local $Storable::Deparse = 0; 193 local $Storable::forgive_me = 1; 194 195 my $devnull = File::Spec->devnull; 196 197 open(SAVEERR, ">&STDERR"); 198 open(STDERR, ">$devnull") or 199 ( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) ); 200 201 eval { $freezed = freeze $obj[0]->[0] }; 202 203 open(STDERR, ">&SAVEERR"); 204 205 ok($@, ""); 206 ok($freezed ne ''); 207} 208 209{ 210 my $safe = new Safe; 211 local $Storable::Eval = sub { $safe->reval(shift) }; 212 213 $freezed = freeze $obj[0]->[0]; 214 $@ = ""; 215 eval { $thawed = thaw $freezed }; 216 ok($@, ""); 217 ok($thawed->(), "JAPH"); 218 219 $freezed = freeze $obj[0]->[6]; 220 eval { $thawed = thaw $freezed }; 221 # The "Code sub ..." error message only appears if Log::Agent is installed 222 ok($@, qr/(trapped|Code sub)/); 223 224 if (0) { 225 # Disable or fix this test if the internal representation of Storable 226 # changes. 227 skip("no malicious storable file check", 1); 228 } else { 229 # Construct malicious storable code 230 $freezed = nfreeze $obj[0]->[0]; 231 my $bad_code = ';open FOO, "/badfile"'; 232 # 5th byte is (short) length of scalar 233 my $len = ord(substr($freezed, 4, 1)); 234 substr($freezed, 4, 1, chr($len+length($bad_code))); 235 substr($freezed, -1, 0, $bad_code); 236 $@ = ""; 237 eval { $thawed = thaw $freezed }; 238 ok($@, qr/(trapped|Code sub)/); 239 } 240} 241 242{ 243 my $safe = new Safe; 244 # because of opcodes used in "use strict": 245 $safe->permit(qw(:default require)); 246 local $Storable::Eval = sub { $safe->reval(shift) }; 247 248 $freezed = freeze $obj[0]->[1]; 249 $@ = ""; 250 eval { $thawed = thaw $freezed }; 251 ok($@, ""); 252 ok($thawed->(), 42); 253} 254 255{ 256 { 257 package MySafe; 258 sub new { bless {}, shift } 259 sub reval { 260 my $source = $_[1]; 261 # Here you can apply some nifty regexpes to ensure the 262 # safeness of the source code. 263 my $coderef = eval $source; 264 $coderef; 265 } 266 } 267 268 my $safe = new MySafe; 269 local $Storable::Eval = sub { $safe->reval($_[0]) }; 270 271 $freezed = freeze $obj[0]; 272 eval { $thawed = thaw $freezed }; 273 ok($@, ""); 274 275 if ($@ ne "") { 276 ok(0) for (1..5); 277 } else { 278 ok($thawed->[0]->(), "JAPH"); 279 ok($thawed->[1]->(), 42); 280 ok($thawed->[2]->(), "blessed"); 281 ok($thawed->[3]->(), "Another::Package"); 282 ok(prototype($thawed->[4]), prototype($obj[0]->[4])); 283 } 284} 285 286{ 287 # Check internal "seen" code 288 my $short_sub = sub { "short sub" }; # for SX_SCALAR 289 # for SX_LSCALAR 290 my $long_sub_code = 'sub { "' . "x"x255 . '" }'; 291 my $long_sub = eval $long_sub_code; die $@ if $@; 292 my $sclr = \1; 293 294 local $Storable::Deparse = 1; 295 local $Storable::Eval = 1; 296 297 for my $sub ($short_sub, $long_sub) { 298 my $res; 299 300 $res = thaw freeze [$sub, $sub]; 301 ok(int($res->[0]), int($res->[1])); 302 303 $res = thaw freeze [$sclr, $sub, $sub, $sclr]; 304 ok(int($res->[0]), int($res->[3])); 305 ok(int($res->[1]), int($res->[2])); 306 307 $res = thaw freeze [$sub, $sub, $sclr, $sclr]; 308 ok(int($res->[0]), int($res->[1])); 309 ok(int($res->[2]), int($res->[3])); 310 } 311 312} 313