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.6.0;
  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 => 49 }
  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 @obj =
  59     ([\&code,                   # code reference
  60       sub { 6*7 },
  61       $blessed_code,            # blessed code reference
  62       \&Another::Package::foo,  # code in another package
  63       sub ($$;$) { 0 },         # prototypes
  64       sub { print "test\n" },
  65       \&Test::ok,               # large scalar
  66      ],
  67
  68      {"a" => sub { "srt" }, "b" => \&code},
  69
  70      sub { ord("a")-ord("7") },
  71
  72      \&code,
  73
  74      \&dclone,                 # XS function
  75
  76      sub { open FOO, "/" },
  77     );
  78
  79 $Storable::Deparse = 1;
  80 $Storable::Eval    = 1;
  81
  82 ######################################################################
  83 # Test freeze & thaw
  84
  85 $freezed = freeze $obj[0];
  86 $thawed  = thaw $freezed;
  87
  88 ok($thawed->[0]->(), "JAPH");
  89 ok($thawed->[1]->(), 42);
  90 ok($thawed->[2]->(), "blessed");
  91 ok($thawed->[3]->(), "Another::Package");
  92 ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
  93
  94 ######################################################################
  95
  96 $freezed = freeze $obj[1];
  97 $thawed  = thaw $freezed;
  98
  99 ok($thawed->{"a"}->(), "srt");
 100 ok($thawed->{"b"}->(), "JAPH");
 101
 102 ######################################################################
 103
 104 $freezed = freeze $obj[2];
 105 $thawed  = thaw $freezed;
 106
 107 ok($thawed->(), 42);
 108
 109 ######################################################################
 110
 111 $freezed = freeze $obj[3];
 112 $thawed  = thaw $freezed;
 113
 114 ok($thawed->(), "JAPH");
 115
 116 ######################################################################
 117
 118 eval { $freezed = freeze $obj[4] };
 119 ok($@ =~ /The result of B::Deparse::coderef2text was empty/);
 120
 121 ######################################################################
 122 # Test dclone
 123
 124 my $new_sub = dclone($obj[2]);
 125 ok($new_sub->(), $obj[2]->());
 126
 127 ######################################################################
 128 # Test retrieve & store
 129
 130 store $obj[0], 'store';
 131 $thawed = retrieve 'store';
 132
 133 ok($thawed->[0]->(), "JAPH");
 134 ok($thawed->[1]->(), 42);
 135 ok($thawed->[2]->(), "blessed");
 136 ok($thawed->[3]->(), "Another::Package");
 137 ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
 138
 139 ######################################################################
 140
 141 nstore $obj[0], 'store';
 142 $thawed = retrieve 'store';
 143 unlink 'store';
 144
 145 ok($thawed->[0]->(), "JAPH");
 146 ok($thawed->[1]->(), 42);
 147 ok($thawed->[2]->(), "blessed");
 148 ok($thawed->[3]->(), "Another::Package");
 149 ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
 150
 151 ######################################################################
 152 # Security with
 153 #   $Storable::Eval
 154 #   $Storable::Deparse
 155
 156 {
 157     local $Storable::Eval = 0;
 158
 159     for my $i (0 .. 1) {
 160         $freezed = freeze $obj[$i];
 161         $@ = "";
 162         eval { $thawed  = thaw $freezed };
 163         ok($@ =~ /Can\'t eval/);
 164     }
 165 }
 166
 167 {
 168
 169     local $Storable::Deparse = 0;
 170     for my $i (0 .. 1) {
 171         $@ = "";
 172         eval { $freezed = freeze $obj[$i] };
 173         ok($@ =~ /Can\'t store CODE items/);
 174     }
 175 }
 176
 177 {
 178     local $Storable::Eval = 0;
 179     local $Storable::forgive_me = 1;
 180     for my $i (0 .. 4) {
 181         $freezed = freeze $obj[0]->[$i];
 182         $@ = "";
 183         eval { $thawed  = thaw $freezed };
 184         ok($@, "");
 185         ok($$thawed =~ /^sub/);
 186     }
 187 }
 188
 189 {
 190     local $Storable::Deparse = 0;
 191     local $Storable::forgive_me = 1;
 192
 193     my $devnull = File::Spec->devnull;
 194
 195     open(SAVEERR, ">&STDERR");
 196     open(STDERR, ">$devnull") or
 197         ( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) );
 198
 199     eval { $freezed = freeze $obj[0]->[0] };
 200
 201     open(STDERR, ">&SAVEERR");
 202
 203     ok($@, "");
 204     ok($freezed ne '');
 205 }
 206
 207 {
 208     my $safe = new Safe;
 209     local $Storable::Eval = sub { $safe->reval(shift) };
 210
 211     $freezed = freeze $obj[0]->[0];
 212     $@ = "";
 213     eval { $thawed = thaw $freezed };
 214     ok($@, "");
 215     ok($thawed->(), "JAPH");
 216
 217     $freezed = freeze $obj[0]->[6];
 218     eval { $thawed = thaw $freezed };
 219     ok($@ =~ /trapped/);
 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         ok($@ =~ /trapped/);
 236     }
 237 }
 238
 239 {
 240     my $safe = new Safe;
 241     # because of opcodes used in "use strict":
 242     $safe->permit(qw(:default require));
 243     local $Storable::Eval = sub { $safe->reval(shift) };
 244
 245     $freezed = freeze $obj[0]->[1];
 246     $@ = "";
 247     eval { $thawed = thaw $freezed };
 248     ok($@, "");
 249     ok($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     ok($@, "");
 271
 272     if ($@ ne "") {
 273         ok(0) for (1..5);
 274     } else {
 275         ok($thawed->[0]->(), "JAPH");
 276         ok($thawed->[1]->(), 42);
 277         ok($thawed->[2]->(), "blessed");
 278         ok($thawed->[3]->(), "Another::Package");
 279         ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
 280     }
 281 }
 282