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