Store weak references.
[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.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 }