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