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::Safe
 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         ok($@ =~ /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         ok($@ =~ /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         ok($@, "");
 182         ok($$thawed =~ /^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     ok($@, "");
 201     ok($freezed ne '');
 202 }
 203
 204 {
 205     my $safe = new Safe;
 206     $safe->permit(qw(:default require));
 207     local $Storable::Eval = sub { $safe->reval(shift) };
 208
 209     for my $def ([0 => "JAPH",
 210                   1 => 42,
 211                  ]
 212                 ) {
 213         my($i, $res) = @$def;
 214         $freezed = freeze $obj[0]->[$i];
 215         $@ = "";
 216         eval { $thawed = thaw $freezed };
 217         ok($@, "");
 218         ok($thawed->(), $res);
 219     }
 220
 221     $freezed = freeze $obj[0]->[6];
 222     eval { $thawed = thaw $freezed };
 223     ok($@ =~ /trapped/);
 224
 225     if (0) {
 226         # Disable or fix this test if the internal representation of Storable
 227         # changes.
 228         skip("no malicious storable file check", 1);
 229     } else {
 230         # Construct malicious storable code
 231         $freezed = nfreeze $obj[0]->[0];
 232         my $bad_code = ';open FOO, "/badfile"';
 233         # 5th byte is (short) length of scalar
 234         my $len = ord(substr($freezed, 4, 1));
 235         substr($freezed, 4, 1, chr($len+length($bad_code)));
 236         substr($freezed, -1, 0, $bad_code);
 237         $@ = "";
 238         eval { $thawed = thaw $freezed };
 239         ok($@ =~ /trapped/);
 240     }
 241 }
 242
 243 {
 244     {
 245         package MySafe;
 246         sub new { bless {}, shift }
 247         sub reval {
 248             my $source = $_[1];
 249             # Here you can apply some nifty regexpes to ensure the
 250             # safeness of the source code.
 251             my $coderef = eval $source;
 252             $coderef;
 253         }
 254     }
 255
 256     my $safe = new MySafe;
 257     local $Storable::Eval = sub { $safe->reval($_[0]) };
 258
 259     $freezed = freeze $obj[0];
 260     eval { $thawed  = thaw $freezed };
 261     ok($@, "");
 262
 263     if ($@ ne "") {
 264         ok(0) for (1..5);
 265     } else {
 266         ok($thawed->[0]->(), "JAPH");
 267         ok($thawed->[1]->(), 42);
 268         ok($thawed->[2]->(), "blessed");
 269         ok($thawed->[3]->(), "Another::Package");
 270         ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
 271     }
 272 }
 273