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