dist/Storable/t/code.t

   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
   9 sub 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
  18 use strict;
  19 BEGIN {
  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
  36 BEGIN { plan tests => 63 }
  37
  38 use Storable qw(retrieve store nstore freeze nfreeze thaw dclone);
  39 use Safe;
  40
  41 #$Storable::DEBUGME = 1;
  42
  43 use 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
  53 local *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
  85 is($thawed->[0]->(), "JAPH");
  86 is($thawed->[1]->(), 42);
  87 is($thawed->[2]->(), "blessed");
  88 is($thawed->[3]->(), "Another::Package");
  89 is(prototype($thawed->[4]), prototype($obj[0]->[4]));
  90
  91 ######################################################################
  92
  93 $freezed = freeze $obj[1];
  94 $thawed  = thaw $freezed;
  95
  96 is($thawed->{"a"}->(), "srt");
  97 is($thawed->{"b"}->(), "JAPH");
  98
  99 ######################################################################
 100
 101 $freezed = freeze $obj[2];
 102 $thawed  = thaw $freezed;
 103
 104 is($thawed->(), 42);
 105
 106 ######################################################################
 107
 108 $freezed = freeze $obj[3];
 109 $thawed  = thaw $freezed;
 110
 111 is($thawed->(), "JAPH");
 112
 113 ######################################################################
 114
 115 eval { $freezed = freeze $obj[4] };
 116 like($@, qr/The result of B::Deparse::coderef2text was empty/);
 117
 118 ######################################################################
 119 # Test dclone
 120
 121 my $new_sub = dclone($obj[2]);
 122 is($new_sub->(), $obj[2]->());
 123
 124 ######################################################################
 125 # Test retrieve & store
 126
 127 store $obj[0], 'store';
 128 $thawed = retrieve 'store';
 129
 130 is($thawed->[0]->(), "JAPH");
 131 is($thawed->[1]->(), 42);
 132 is($thawed->[2]->(), "blessed");
 133 is($thawed->[3]->(), "Another::Package");
 134 is(prototype($thawed->[4]), prototype($obj[0]->[4]));
 135
 136 ######################################################################
 137
 138 nstore $obj[0], 'store';
 139 $thawed = retrieve 'store';
 140 unlink 'store';
 141
 142 is($thawed->[0]->(), "JAPH");
 143 is($thawed->[1]->(), 42);
 144 is($thawed->[2]->(), "blessed");
 145 is($thawed->[3]->(), "Another::Package");
 146 is(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
 309 {
 310     my @text = ("hello", "\x{a3}", "\x{a3} \x{2234}", "\x{2234}\x{2234}");
 311
 312     for my $text(@text) {
 313         my $res = (thaw freeze eval "sub {'" . $text . "'}")->();
 314         ok($res eq $text);
 315     }
 316 }
 317