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
9sub BEGIN {
10    unshift @INC, 't';
11    unshift @INC, 't/compat' if $] < 5.006002;
12    require Config; import Config;
13    if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
14        print "1..0 # Skip: Storable was not built\n";
15        exit 0;
16    }
17}
18
19use strict;
20BEGIN {
21    if (!eval q{
22	use Test::More;
23	use B::Deparse 0.61;
24	use 5.006;
25	1;
26    }) {
27	print "1..0 # skip: tests only work with B::Deparse 0.61 and at least perl 5.6.0\n";
28	exit;
29    }
30    require File::Spec;
31    if ($File::Spec::VERSION < 0.8) {
32	print "1..0 # Skip: newer File::Spec needed\n";
33	exit 0;
34    }
35}
36
37BEGIN { plan tests => 63 }
38
39use Storable qw(retrieve store nstore freeze nfreeze thaw dclone);
40use Safe;
41
42#$Storable::DEBUGME = 1;
43
44our ($freezed, $thawed, @obj, @res, $blessed_code);
45
46$blessed_code = bless sub { "blessed" }, "Some::Package";
47{ package Another::Package; sub foo { __PACKAGE__ } }
48
49{
50    no strict; # to make the life for Safe->reval easier
51    sub code { "JAPH" }
52}
53
54local *FOO;
55
56@obj =
57    ([\&code,                   # code reference
58      sub { 6*7 },
59      $blessed_code,            # blessed code reference
60      \&Another::Package::foo,  # code in another package
61      sub ($$;$) { 0 },         # prototypes
62      sub { print "test\n" },
63      \&Storable::_store,       # large scalar
64     ],
65
66     {"a" => sub { "srt" }, "b" => \&code},
67
68     sub { ord("a")-ord("7") },
69
70     \&code,
71
72     \&dclone,                 # XS function
73
74     sub { open FOO, '<', "/" },
75    );
76
77$Storable::Deparse = 1;
78$Storable::Eval    = 1;
79
80######################################################################
81# Test freeze & thaw
82
83$freezed = freeze $obj[0];
84$thawed  = thaw $freezed;
85
86is($thawed->[0]->(), "JAPH");
87is($thawed->[1]->(), 42);
88is($thawed->[2]->(), "blessed");
89is($thawed->[3]->(), "Another::Package");
90is(prototype($thawed->[4]), prototype($obj[0]->[4]));
91
92######################################################################
93
94$freezed = freeze $obj[1];
95$thawed  = thaw $freezed;
96
97is($thawed->{"a"}->(), "srt");
98is($thawed->{"b"}->(), "JAPH");
99
100######################################################################
101
102$freezed = freeze $obj[2];
103$thawed  = thaw $freezed;
104
105is($thawed->(), (ord "A") == 193 ? -118 : 42);
106
107######################################################################
108
109$freezed = freeze $obj[3];
110$thawed  = thaw $freezed;
111
112is($thawed->(), "JAPH");
113
114######################################################################
115
116eval { $freezed = freeze $obj[4] };
117like($@, qr/The result of B::Deparse::coderef2text was empty/);
118
119######################################################################
120# Test dclone
121
122my $new_sub = dclone($obj[2]);
123is($new_sub->(), $obj[2]->());
124
125######################################################################
126# Test retrieve & store
127
128store $obj[0], "store$$";
129# $Storable::DEBUGME = 1;
130$thawed = retrieve "store$$";
131
132is($thawed->[0]->(), "JAPH");
133is($thawed->[1]->(), 42);
134is($thawed->[2]->(), "blessed");
135is($thawed->[3]->(), "Another::Package");
136is(prototype($thawed->[4]), prototype($obj[0]->[4]));
137
138######################################################################
139
140nstore $obj[0], "store$$";
141$thawed = retrieve "store$$";
142unlink "store$$";
143
144is($thawed->[0]->(), "JAPH");
145is($thawed->[1]->(), 42);
146is($thawed->[2]->(), "blessed");
147is($thawed->[3]->(), "Another::Package");
148is(prototype($thawed->[4]), prototype($obj[0]->[4]));
149
150######################################################################
151# Security with
152#   $Storable::Eval
153#   $Storable::Deparse
154
155{
156    local $Storable::Eval = 0;
157
158    for my $i (0 .. 1) {
159	$freezed = freeze $obj[$i];
160	$@ = "";
161	eval { $thawed  = thaw $freezed };
162	like($@, qr/Can\'t eval/);
163    }
164}
165
166{
167
168    local $Storable::Deparse = 0;
169    for my $i (0 .. 1) {
170	$@ = "";
171	eval { $freezed = freeze $obj[$i] };
172	like($@, qr/Can\'t store CODE items/);
173    }
174}
175
176{
177    local $Storable::Eval = 0;
178    local $Storable::forgive_me = 1;
179    for my $i (0 .. 4) {
180	$freezed = freeze $obj[0]->[$i];
181	$@ = "";
182	eval { $thawed  = thaw $freezed };
183	is($@, "");
184	like($$thawed, qr/^sub/);
185    }
186}
187
188{
189    local $Storable::Deparse = 0;
190    local $Storable::forgive_me = 1;
191
192    my $devnull = File::Spec->devnull;
193
194    open(SAVEERR, ">&STDERR");
195    open(STDERR, '>', $devnull) or
196	( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) );
197
198    eval { $freezed = freeze $obj[0]->[0] };
199
200    open(STDERR, ">&SAVEERR");
201
202    is($@, "");
203    isnt($freezed, '');
204}
205
206{
207    my $safe = new Safe;
208    local $Storable::Eval = sub { $safe->reval(shift) };
209
210    $freezed = freeze $obj[0]->[0];
211    $@ = "";
212    eval { $thawed = thaw $freezed };
213    is($@, "");
214    is($thawed->(), "JAPH");
215
216    $freezed = freeze $obj[0]->[6];
217    eval { $thawed = thaw $freezed };
218    # The "Code sub ..." error message only appears if Log::Agent is installed
219    like($@, qr/(trapped|Code sub)/);
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	like($@, qr/(trapped|Code sub)/);
236    }
237}
238
239{
240    my $safe = new Safe;
241    # because of opcodes used in "use strict":
242    $safe->permit(qw(:default require caller));
243    local $Storable::Eval = sub { $safe->reval(shift) };
244
245    $freezed = freeze $obj[0]->[1];
246    $@ = "";
247    eval { $thawed = thaw $freezed };
248    is($@, "");
249    is($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    is($@, "");
271
272    if ($@ ne "") {
273        fail() for (1..5);
274    } else {
275	is($thawed->[0]->(), "JAPH");
276	is($thawed->[1]->(), 42);
277	is($thawed->[2]->(), "blessed");
278	is($thawed->[3]->(), "Another::Package");
279	is(prototype($thawed->[4]), prototype($obj[0]->[4]));
280    }
281}
282
283{
284    # Check internal "seen" code
285    my $short_sub = sub { "short sub" }; # for SX_SCALAR
286    # for SX_LSCALAR
287    my $long_sub_code = 'sub { "' . "x"x255 . '" }';
288    my $long_sub = eval $long_sub_code; die $@ if $@;
289    my $sclr = \1;
290
291    local $Storable::Deparse = 1;
292    local $Storable::Eval    = 1;
293
294    for my $sub ($short_sub, $long_sub) {
295	my $res;
296
297	$res = thaw freeze [$sub, $sub];
298	is(int($res->[0]), int($res->[1]));
299
300	$res = thaw freeze [$sclr, $sub, $sub, $sclr];
301	is(int($res->[0]), int($res->[3]));
302	is(int($res->[1]), int($res->[2]));
303
304	$res = thaw freeze [$sub, $sub, $sclr, $sclr];
305	is(int($res->[0]), int($res->[1]));
306	is(int($res->[2]), int($res->[3]));
307    }
308
309}
310
311{
312    my @text = ("hello", "\x{a3}", "\x{a3} \x{2234}", "\x{2234}\x{2234}");
313
314    for my $text(@text) {
315        my $res = (thaw freeze eval "sub {'" . $text . "'}")->();
316        ok($res eq $text);
317    }
318}
319
320