1#!./perl -w
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//;
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    # This lets us distribute Test::More in t/
18    unshift @INC, 't';
19    unshift @INC, 't/compat' if $] < 5.006002;
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    }
25}
26
27use strict;
28
29our $byteorder = $Config{byteorder};
30
31our $file_magic_str = 'pst0';
32our $other_magic = 7 + length $byteorder;
33our $network_magic = 2;
34our $major = 2;
35our $minor = 12;
36our $minor_write = $] >= 5.019 ? 11 : $] > 5.008 ? 9 : $] > 5.005_50 ? 8 : 4;
37
38use 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
46our $fancy = ($] > 5.007 ? 2 : 0);
47
48plan tests => 372 + length ($byteorder) * 4 + $fancy * 8;
49
50use Storable qw (store retrieve freeze thaw nstore nfreeze);
51require 'testlib.pl';
52our $file;
53
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
58my %hash = (perl => 'rules', chr 256, '');
59delete $hash{chr 256};
60
61sub test_hash {
62  my $clone = shift;
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");
66  is ($clone->{perl}, "rules", "Got expected value when looking up key in clone");
67}
68
69sub test_header {
70  my ($header, $isfile, $isnetorder) = @_;
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");
75  if ($isnetorder) {
76    # Network order header has no sizes
77  } else {
78    is ($header->{byteorder}, $byteorder, "byte order");
79    is ($header->{intsize}, $Config{intsize}, "int size");
80    is ($header->{longsize}, $Config{longsize}, "long size");
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    }
86    is ($header->{nvsize}, $Config{nvsize} || $Config{doublesize} || 8,
87        "nv size"); # 5.00405 doesn't even have doublesize in config.
88  }
89}
90
91sub 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
96    # local $Storable::DEBUGME = 1;
97    my $clone = &$sub($short);
98    is (defined ($clone), '', "truncated $what to $i should fail");
99    if ($i < $magic_len) {
100      like ($@, "/^Magic number checking on storable $what failed/",
101          "Should croak with magic number warning");
102    } else {
103      is ($@, "", "Should not set \$\@");
104    }
105  }
106}
107
108sub test_corrupt {
109  my ($data, $sub, $what, $name) = @_;
110
111  my $clone = &$sub($data);
112  local $Test::Builder::Level = $Test::Builder::Level + 1;
113  is (defined ($clone), '', "$name $what should fail");
114  like ($@, $what, $name);
115}
116
117sub 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
128  is ($@, "", "There should be no error");
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;
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
149  # Which we've now exhausted given that Storable 2.25 is writing 2.8
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  # )
156  my $minor6 = $header->{minor} + 6;
157  substr ($copy, $file_magic + 1, 1) = chr $minor6;
158  {
159    # Now by default newer minor version numbers are not a pain.
160    $clone = &$sub($copy);
161    is ($@, "", "by default no error on higher minor");
162    test_hash ($clone);
163
164    local $Storable::accept_future_minor = 0;
165    test_corrupt ($copy, $sub,
166                  "/^Storable binary image v$header->{major}\.$minor6 more recent than I am \\(v$header->{major}\.$minor\\)/",
167                  "higher minor");
168  }
169
170  $copy = $contents;
171  my $major1 = $header->{major} + 1;
172  substr ($copy, $file_magic, 1) = chr 2*$major1;
173  test_corrupt ($copy, $sub,
174                "/^Storable binary image v$major1\.$header->{minor} more recent than I am \\(v$header->{major}\.$minor\\)/",
175                "higher major");
176
177  # Continue messing with the previous copy
178  my $minor1 = $header->{minor} - 1;
179  substr ($copy, $file_magic + 1, 1) = chr $minor1;
180  test_corrupt ($copy, $sub,
181                "/^Storable binary image v$major1\.$minor1 more recent than I am \\(v$header->{major}\.$minor\\)/",
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"],
196             ['longsize', "Long integer"],
197             ['ptrsize', "Pointer"],
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
209  # Just the header and a tag 255. As 34 is currently the highest tag, this
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");
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
224  substr ($copy, $file_magic + 1, 1) = chr $minor6;
225
226  # local $Storable::DEBUGME = 1;
227  # This is the delayed croak
228  test_corrupt ($copy, $sub,
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 35/",
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,
236                  "/^Storable binary image v$header->{major}\.$minor6 more recent than I am \\(v$header->{major}\.$minor\\)/",
237                  "higher minor");
238  }
239}
240
241ok (defined store(\%hash, $file), "store() returned defined value");
242
243my $expected = 20 + length ($file_magic_str) + $other_magic + $fancy;
244my $length = -s $file;
245
246die "Don't seem to have written file '$file' as I can't get its length: $!"
247  unless defined $file;
248
249die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length"
250  unless $length == $expected;
251
252# Read the contents into memory:
253my $contents = slurp ($file);
254
255# Test the original direct from disk
256my $clone = retrieve $file;
257test_hash ($clone);
258
259# Then test it.
260test_things($contents, \&store_and_retrieve, 'file');
261
262# And now try almost everything again with a Storable string
263my $stored = freeze \%hash;
264test_things($stored, \&freeze_and_thaw, 'string');
265
266# Network order.
267unlink $file or die "Can't unlink '$file': $!";
268
269ok (defined nstore(\%hash, $file), "nstore() returned defined value");
270
271$expected = 20 + length ($file_magic_str) + $network_magic + $fancy;
272$length = -s $file;
273
274die "Don't seem to have written file '$file' as I can't get its length: $!"
275  unless defined $file;
276
277die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length"
278  unless $length == $expected;
279
280# Read the contents into memory:
281$contents = slurp ($file);
282
283# Test the original direct from disk
284$clone = retrieve $file;
285test_hash ($clone);
286
287# Then test it.
288test_things($contents, \&store_and_retrieve, 'file', 1);
289
290# And now try almost everything again with a Storable string
291$stored = nfreeze \%hash;
292test_things($stored, \&freeze_and_thaw, 'string', 1);
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}
305
306# Unusual in that the empty string is stored with an SX_LSCALAR marker
307my $hash = store_and_retrieve("pst0\5\6\3\0\0\0\1\1\0\0\0\0\0\0\0\5empty");
308ok(!$@, "no exception");
309is(ref($hash), "HASH", "got a hash");
310is($hash->{empty}, "", "got empty element");
311