This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Storable retrieve_lscalar fails for empty strings [PATCH]
[perl5.git] / ext / Storable / t / malice.t
CommitLineData
b8778c7c 1#!./perl -w
b8778c7c
NC
2#
3# Copyright 2002, Larry Wall.
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# I'm trying to keep this test easily backwards compatible to 5.004, so no
10# qr//;
b8778c7c
NC
11
12# This test tries to craft malicious data to test out as many different
13# error traps in Storable as possible
14# It also acts as a test for read_header
15
16sub BEGIN {
17 if ($ENV{PERL_CORE}){
18 chdir('t') if -d 't';
c3c53033 19 @INC = ('.', '../lib', '../ext/Storable/t');
a2307be4
NC
20 } else {
21 # This lets us distribute Test::More in t/
22 unshift @INC, 't';
b8778c7c
NC
23 }
24 require Config; import Config;
25 if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
26 print "1..0 # Skip: Storable was not built\n";
27 exit 0;
28 }
b8778c7c
NC
29}
30
31use strict;
677a847b
NC
32use vars qw($file_magic_str $other_magic $network_magic $byteorder
33 $major $minor $minor_write $fancy);
34
35$byteorder = $Config{byteorder};
36
96ef0061 37$file_magic_str = 'pst0';
677a847b 38$other_magic = 7 + length $byteorder;
96ef0061
JH
39$network_magic = 2;
40$major = 2;
c3c53033
NC
41$minor = 7;
42$minor_write = $] > 5.005_50 ? 7 : 4;
b8778c7c 43
372cb964
NC
44use Test::More;
45
46# If it's 5.7.3 or later the hash will be stored with flags, which is
47# 2 extra bytes. There are 2 * 2 * 2 tests per byte in the body and header
48# common to normal and network order serialised objects (hence the 8)
49# There are only 2 * 2 tests per byte in the parts of the header not present
50# for network order, and 2 tests per byte on the 'pst0' "magic number" only
51# present in files, but not in things store()ed to memory
52$fancy = ($] > 5.007 ? 2 : 0);
53
d4aa20cb 54plan tests => 372 + length ($byteorder) * 4 + $fancy * 8;
b8778c7c
NC
55
56use Storable qw (store retrieve freeze thaw nstore nfreeze);
c3c53033
NC
57require 'testlib.pl';
58use vars '$file';
b8778c7c 59
9d80fab7
NC
60# The chr 256 is a hack to force the hash to always have the utf8 keys flag
61# set on 5.7.3 and later. Otherwise the test fails if run with -Mutf8 because
62# only there does the hash has the flag on, and hence only there is it stored
63# as a flagged hash, which is 2 bytes longer
64my %hash = (perl => 'rules', chr 256, '');
65delete $hash{chr 256};
b8778c7c
NC
66
67sub test_hash {
68 my $clone = shift;
372cb964
NC
69 is (ref $clone, "HASH", "Get hash back");
70 is (scalar keys %$clone, 1, "with 1 key");
71 is ((keys %$clone)[0], "perl", "which is correct");
72 is ($clone->{perl}, "rules");
b8778c7c
NC
73}
74
75sub test_header {
76 my ($header, $isfile, $isnetorder) = @_;
372cb964
NC
77 is (!!$header->{file}, !!$isfile, "is file");
78 is ($header->{major}, $major, "major number");
79 is ($header->{minor}, $minor_write, "minor number");
80 is (!!$header->{netorder}, !!$isnetorder, "is network order");
677a847b
NC
81 if ($isnetorder) {
82 # Network order header has no sizes
83 } else {
84 is ($header->{byteorder}, $byteorder, "byte order");
372cb964
NC
85 is ($header->{intsize}, $Config{intsize}, "int size");
86 is ($header->{longsize}, $Config{longsize}, "long size");
a2307be4
NC
87 SKIP: {
88 skip ("No \$Config{prtsize} on this perl version ($])", 1)
89 unless defined $Config{ptrsize};
90 is ($header->{ptrsize}, $Config{ptrsize}, "long size");
91 }
372cb964 92 is ($header->{nvsize}, $Config{nvsize} || $Config{doublesize} || 8,
b8778c7c
NC
93 "nv size"); # 5.00405 doesn't even have doublesize in config.
94 }
95}
96
b8778c7c
NC
97sub test_truncated {
98 my ($data, $sub, $magic_len, $what) = @_;
99 for my $i (0 .. length ($data) - 1) {
100 my $short = substr $data, 0, $i;
101
a2307be4 102 # local $Storable::DEBUGME = 1;
b8778c7c 103 my $clone = &$sub($short);
372cb964 104 is (defined ($clone), '', "truncated $what to $i should fail");
b8778c7c 105 if ($i < $magic_len) {
372cb964 106 like ($@, "/^Magic number checking on storable $what failed/",
b8778c7c
NC
107 "Should croak with magic number warning");
108 } else {
372cb964 109 is ($@, "", "Should not set \$\@");
b8778c7c
NC
110 }
111 }
112}
113
114sub test_corrupt {
115 my ($data, $sub, $what, $name) = @_;
116
117 my $clone = &$sub($data);
372cb964
NC
118 is (defined ($clone), '', "$name $what should fail");
119 like ($@, $what, $name);
b8778c7c
NC
120}
121
122sub test_things {
123 my ($contents, $sub, $what, $isnetwork) = @_;
124 my $isfile = $what eq 'file';
125 my $file_magic = $isfile ? length $file_magic_str : 0;
126
127 my $header = Storable::read_magic ($contents);
128 test_header ($header, $isfile, $isnetwork);
129
130 # Test that if we re-write it, everything still works:
131 my $clone = &$sub ($contents);
132
372cb964 133 is ($@, "", "There should be no error");
b8778c7c
NC
134
135 test_hash ($clone);
136
137 # Now lets check the short version:
138 test_truncated ($contents, $sub, $file_magic
139 + ($isnetwork ? $network_magic : $other_magic), $what);
140
141 my $copy;
142 if ($isfile) {
143 $copy = $contents;
144 substr ($copy, 0, 4) = 'iron';
145 test_corrupt ($copy, $sub, "/^File is not a perl storable/",
146 "magic number");
147 }
148
149 $copy = $contents;
530b72ba
NC
150 # Needs to be more than 1, as we're already coding a spread of 1 minor version
151 # number on writes (2.5, 2.4). May increase to 2 if we figure we can do 2.3
152 # on 5.005_03 (No utf8).
153 # 4 allows for a small safety margin
154 # (Joke:
155 # Question: What is the value of pi?
156 # Mathematician answers "It's pi, isn't it"
157 # Physicist answers "3.1, within experimental error"
158 # Engineer answers "Well, allowing for a small safety margin, 18"
159 # )
160 my $minor4 = $header->{minor} + 4;
161 substr ($copy, $file_magic + 1, 1) = chr $minor4;
e8189732
NC
162 {
163 # Now by default newer minor version numbers are not a pain.
164 $clone = &$sub($copy);
372cb964 165 is ($@, "", "by default no error on higher minor");
e8189732
NC
166 test_hash ($clone);
167
168 local $Storable::accept_future_minor = 0;
169 test_corrupt ($copy, $sub,
170 "/^Storable binary image v$header->{major}\.$minor4 more recent than I am \\(v$header->{major}\.$minor\\)/",
171 "higher minor");
172 }
b8778c7c
NC
173
174 $copy = $contents;
175 my $major1 = $header->{major} + 1;
176 substr ($copy, $file_magic, 1) = chr 2*$major1;
177 test_corrupt ($copy, $sub,
530b72ba 178 "/^Storable binary image v$major1\.$header->{minor} more recent than I am \\(v$header->{major}\.$minor\\)/",
b8778c7c
NC
179 "higher major");
180
181 # Continue messing with the previous copy
530b72ba 182 my $minor1 = $header->{minor} - 1;
b8778c7c
NC
183 substr ($copy, $file_magic + 1, 1) = chr $minor1;
184 test_corrupt ($copy, $sub,
530b72ba 185 "/^Storable binary image v$major1\.$minor1 more recent than I am \\(v$header->{major}\.$minor\\)/",
b8778c7c
NC
186 "higher major, lower minor");
187
188 my $where;
189 if (!$isnetwork) {
190 # All these are omitted from the network order header.
191 # I'm not sure if it's correct to omit the byte size stuff.
192 $copy = $contents;
193 substr ($copy, $file_magic + 3, length $header->{byteorder})
194 = reverse $header->{byteorder};
195
196 test_corrupt ($copy, $sub, "/^Byte order is not compatible/",
197 "byte order");
198 $where = $file_magic + 3 + length $header->{byteorder};
199 foreach (['intsize', "Integer"],
291cf09c 200 ['longsize', "Long integer"],
a2307be4 201 ['ptrsize', "Pointer"],
b8778c7c
NC
202 ['nvsize', "Double"]) {
203 my ($key, $name) = @$_;
204 $copy = $contents;
205 substr ($copy, $where++, 1) = chr 0;
206 test_corrupt ($copy, $sub, "/^$name size is not compatible/",
207 "$name size");
208 }
209 } else {
210 $where = $file_magic + $network_magic;
211 }
212
c3c53033 213 # Just the header and a tag 255. As 28 is currently the highest tag, this
b8778c7c
NC
214 # is "unexpected"
215 $copy = substr ($contents, 0, $where) . chr 255;
216
217 test_corrupt ($copy, $sub,
218 "/^Corrupted storable $what \\(binary v$header->{major}.$header->{minor}\\)/",
219 "bogus tag");
e8189732
NC
220
221 # Now drop the minor version number
222 substr ($copy, $file_magic + 1, 1) = chr $minor1;
223
224 test_corrupt ($copy, $sub,
225 "/^Corrupted storable $what \\(binary v$header->{major}.$minor1\\)/",
226 "bogus tag, minor less 1");
227 # Now increase the minor version number
228 substr ($copy, $file_magic + 1, 1) = chr $minor4;
229
230 # local $Storable::DEBUGME = 1;
231 # This is the delayed croak
232 test_corrupt ($copy, $sub,
c3c53033 233 "/^Storable binary image v$header->{major}.$minor4 contains data of type 255. This Storable is v$header->{major}.$minor and can only handle data types up to 28/",
e8189732
NC
234 "bogus tag, minor plus 4");
235 # And check again that this croak is not delayed:
236 {
237 # local $Storable::DEBUGME = 1;
238 local $Storable::accept_future_minor = 0;
239 test_corrupt ($copy, $sub,
240 "/^Storable binary image v$header->{major}\.$minor4 more recent than I am \\(v$header->{major}\.$minor\\)/",
241 "higher minor");
242 }
b8778c7c
NC
243}
244
b8778c7c
NC
245ok (defined store(\%hash, $file));
246
9d80fab7 247my $expected = 20 + length ($file_magic_str) + $other_magic + $fancy;
b8778c7c
NC
248my $length = -s $file;
249
250die "Don't seem to have written file '$file' as I can't get its length: $!"
251 unless defined $file;
252
291cf09c 253die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length"
b8778c7c
NC
254 unless $length == $expected;
255
256# Read the contents into memory:
c3c53033 257my $contents = slurp ($file);
b8778c7c
NC
258
259# Test the original direct from disk
260my $clone = retrieve $file;
261test_hash ($clone);
262
263# Then test it.
264test_things($contents, \&store_and_retrieve, 'file');
265
266# And now try almost everything again with a Storable string
267my $stored = freeze \%hash;
268test_things($stored, \&freeze_and_thaw, 'string');
269
270# Network order.
271unlink $file or die "Can't unlink '$file': $!";
272
273ok (defined nstore(\%hash, $file));
274
9d80fab7 275$expected = 20 + length ($file_magic_str) + $network_magic + $fancy;
b8778c7c
NC
276$length = -s $file;
277
278die "Don't seem to have written file '$file' as I can't get its length: $!"
279 unless defined $file;
280
291cf09c 281die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length"
b8778c7c
NC
282 unless $length == $expected;
283
284# Read the contents into memory:
c3c53033 285$contents = slurp ($file);
b8778c7c
NC
286
287# Test the original direct from disk
288$clone = retrieve $file;
289test_hash ($clone);
290
291# Then test it.
292test_things($contents, \&store_and_retrieve, 'file', 1);
293
294# And now try almost everything again with a Storable string
295$stored = nfreeze \%hash;
296test_things($stored, \&freeze_and_thaw, 'string', 1);
fcaa57e7
AMS
297
298# Test that the bug fixed by #20587 doesn't affect us under some older
299# Perl. AMS 20030901
300{
301 chop(my $a = chr(0xDF).chr(256));
302 my %a = (chr(0xDF) => 1);
303 $a{$a}++;
304 freeze \%a;
305 # If we were built with -DDEBUGGING, the assert() should have killed
306 # us, which will probably alert the user that something went wrong.
307 ok(1);
308}
d4aa20cb
GA
309
310# Unusual in that the empty string is stored with an SX_LSCALAR marker
311my $hash = store_and_retrieve("pst0\5\6\3\0\0\0\1\1\0\0\0\0\0\0\0\5empty");
312ok(!$@, "no exception");
313is(ref($hash), "HASH", "got a hash");
314is($hash->{empty}, "", "got empty element");