Commit | Line | Data |
---|---|---|
7a6a85bf | 1 | #!./perl |
7a6a85bf RG |
2 | # |
3 | # Copyright (c) 1995-2000, Raphael Manfredi | |
a258c17c | 4 | # Copyright (c) 2017, cPanel Inc |
7a6a85bf | 5 | # |
9e21b3d0 JH |
6 | # You may redistribute only under the same terms as Perl 5, as specified |
7 | # in the README file that comes with the distribution. | |
7a6a85bf | 8 | # |
7a6a85bf RG |
9 | |
10 | sub BEGIN { | |
a258c17c | 11 | unshift @INC, 'dist/Storable/t' if $ENV{PERL_CORE} and -d 'dist/Storable/t'; |
48c887dd | 12 | unshift @INC, 't'; |
1afdebce | 13 | unshift @INC, 't/compat' if $] < 5.006002; |
9f233367 | 14 | require Config; import Config; |
0c384302 | 15 | if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { |
9f233367 PP |
16 | print "1..0 # Skip: Storable was not built\n"; |
17 | exit 0; | |
18 | } | |
372cb964 | 19 | require 'st-dump.pl'; |
7a6a85bf RG |
20 | } |
21 | ||
22 | ||
23 | use Storable qw(store retrieve nstore); | |
a258c17c | 24 | use Test::More tests => 20; |
7a6a85bf RG |
25 | |
26 | $a = 'toto'; | |
27 | $b = \$a; | |
28 | $c = bless {}, CLASS; | |
29 | $c->{attribute} = 'attrval'; | |
30 | %a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c); | |
31 | @a = ('first', '', undef, 3, -4, -3.14159, 456, 4.5, | |
32 | $b, \$a, $a, $c, \$c, \%a); | |
33 | ||
1cb8a344 | 34 | isnt(store(\@a, "store$$"), undef); |
dddb60fc NC |
35 | is(Storable::last_op_in_netorder(), ''); |
36 | isnt(nstore(\@a, 'nstore'), undef); | |
37 | is(Storable::last_op_in_netorder(), 1); | |
38 | is(Storable::last_op_in_netorder(), 1); | |
7a6a85bf | 39 | |
1cb8a344 | 40 | $root = retrieve("store$$"); |
dddb60fc NC |
41 | isnt($root, undef); |
42 | is(Storable::last_op_in_netorder(), ''); | |
7a6a85bf RG |
43 | |
44 | $nroot = retrieve('nstore'); | |
dddb60fc NC |
45 | isnt($root, undef); |
46 | is(Storable::last_op_in_netorder(), 1); | |
7a6a85bf RG |
47 | |
48 | $d1 = &dump($root); | |
dddb60fc | 49 | isnt($d1, undef); |
7a6a85bf | 50 | $d2 = &dump($nroot); |
dddb60fc | 51 | isnt($d2, undef); |
7a6a85bf | 52 | |
dddb60fc | 53 | is($d1, $d2); |
7a6a85bf RG |
54 | |
55 | # Make sure empty string is defined at retrieval time | |
dddb60fc NC |
56 | isnt($root->[1], undef); |
57 | is(length $root->[1], 0); | |
7a6a85bf | 58 | |
a258c17c RU |
59 | # $Storable::DEBUGME = 1; |
60 | { | |
61 | # len>I32: todo patch the storable image number into the strings, fake 2.10 | |
62 | # $Storable::BIN_MINOR | |
63 | my $retrieve_blessed = "\x04\x0a\x08\x31\x32\x33\x34\x35\x36\x37\x38\x04\x08\x08\x08\x11\xff\x49\x6e\x74\xff\x72\x6e\x61\x6c\x73\x02\x00\x00\x00\x00"; | |
64 | my $x = eval { Storable::mretrieve($retrieve_blessed); }; | |
65 | # Long integer or Double size or Byte order is not compatible | |
66 | like($@, qr/^(Corrupted classname length|.* is not compatible|panic: malloc)/, "RT #130635 $@"); | |
67 | is($x, undef, 'and undef result'); | |
68 | } | |
69 | ||
70 | { | |
71 | # len>I32 | |
72 | my $retrieve_hook = "\x04\x0a\x08\x31\x32\x33\x34\x35\x36\x37\x38\x04\x08\x08\x08\x13\x04\x49\xfe\xf4\xff\x72\x6e\x61\x6c\x73\x02\x00\x00\x00\x00"; | |
73 | my $x = eval { Storable::mretrieve($retrieve_hook); }; | |
74 | like($@, qr/^(Corrupted classname length|.* is not compatible|panic: malloc)/, "$@"); | |
75 | is($x, undef, 'and undef result'); | |
76 | } | |
77 | ||
7e52c9ca | 78 | SKIP: |
a258c17c | 79 | { |
7e52c9ca TC |
80 | # this can allocate a lot of memory, only do that if the testers tells us we can |
81 | # the test allocates 2GB, but other memory is allocated too, so we want | |
82 | # at least 3 | |
83 | $ENV{PERL_TEST_MEMORY} && $ENV{PERL_TEST_MEMORY} >= 3 | |
84 | or skip "over 2GB memory needed for this test", 2; | |
a258c17c RU |
85 | # len<I32, len>127: stack overflow |
86 | my $retrieve_hook = "\x04\x0a\x08\x31\x32\x33\x34\x35\x36\x37\x38\x04\x08\x08\x08\x13\x04\x49\xfe\xf4\x7f\x72\x6e\x61\x6c\x73\x02\x00\x00\x00\x00"; | |
87 | my $x = eval { Storable::mretrieve($retrieve_hook); }; | |
88 | is($?, 0, "no stack overflow in retrieve_hook()"); | |
89 | is($x, undef, 'either out of mem or normal error (malloc 2GB)'); | |
90 | } | |
91 | ||
1cb8a344 | 92 | END { 1 while unlink("store$$", 'nstore') } |