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