Storable 2.06 (was Re: Bug in ext/Storable/t/integer.t)
[p5sagit/p5-mst-13.2.git] / 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