ext/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     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
  23 use strict;
  24 BEGIN {
  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
  41 BEGIN { plan tests => 59 }
  42
  43 use Storable qw(retrieve store nstore freeze nfreeze thaw dclone);
  44 use Safe;
  45
  46 #$Storable::DEBUGME = 1;
  47
  48 use 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
  58 local *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
  90 ok($thawed->[0]->(), "JAPH");
  91 ok($thawed->[1]->(), 42);
  92 ok($thawed->[2]->(), "blessed");
  93 ok($thawed->[3]->(), "Another::Package");
  94 ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
  95
  96 ######################################################################
  97
  98 $freezed = freeze $obj[1];
  99 $thawed  = thaw $freezed;
 100
 101 ok($thawed->{"a"}->(), "srt");
 102 ok($thawed->{"b"}->(), "JAPH");
 103
 104 ######################################################################
 105
 106 $freezed = freeze $obj[2];
 107 $thawed  = thaw $freezed;
 108
 109 ok($thawed->(), 42);
 110
 111 ######################################################################
 112
 113 $freezed = freeze $obj[3];
 114 $thawed  = thaw $freezed;
 115
 116 ok($thawed->(), "JAPH");
 117
 118 ######################################################################
 119
 120 eval { $freezed = freeze $obj[4] };
 121 ok($@, qr/The result of B::Deparse::coderef2text was empty/);
 122
 123 ######################################################################
 124 # Test dclone
 125
 126 my $new_sub = dclone($obj[2]);
 127 ok($new_sub->(), $obj[2]->());
 128
 129 ######################################################################
 130 # Test retrieve & store
 131
 132 store $obj[0], 'store';
 133 $thawed = retrieve 'store';
 134
 135 ok($thawed->[0]->(), "JAPH");
 136 ok($thawed->[1]->(), 42);
 137 ok($thawed->[2]->(), "blessed");
 138 ok($thawed->[3]->(), "Another::Package");
 139 ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
 140
 141 ######################################################################
 142
 143 nstore $obj[0], 'store';
 144 $thawed = retrieve 'store';
 145 unlink 'store';
 146
 147 ok($thawed->[0]->(), "JAPH");
 148 ok($thawed->[1]->(), 42);
 149 ok($thawed->[2]->(), "blessed");
 150 ok($thawed->[3]->(), "Another::Package");
 151 ok(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 }