This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix a null pointer dereference segfault in Storable.
[perl5.git] / dist / Storable / t / store.t
1 #!./perl
2 #
3 #  Copyright (c) 1995-2000, Raphael Manfredi
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 sub BEGIN {
10     unshift @INC, 't';
11     unshift @INC, 't/compat' if $] < 5.006002;
12     require Config; import Config;
13     if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
14         print "1..0 # Skip: Storable was not built\n";
15         exit 0;
16     }
17     require 'st-dump.pl';
18 }
19
20 use Storable qw(store retrieve store_fd nstore_fd fd_retrieve);
21
22 use Test::More tests => 24;
23
24 $a = 'toto';
25 $b = \$a;
26 $c = bless {}, CLASS;
27 $c->{attribute} = 'attrval';
28 %a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c);
29 @a = ('first', undef, 3, -4, -3.14159, 456, 4.5,
30         $b, \$a, $a, $c, \$c, \%a);
31
32 isnt(store(\@a, 'store'), undef);
33
34 $dumped = &dump(\@a);
35 isnt($dumped, undef);
36
37 $root = retrieve('store');
38 isnt($root, undef);
39
40 $got = &dump($root);
41 isnt($got, undef);
42
43 is($got, $dumped);
44
45 1 while unlink 'store';
46
47 package FOO; @ISA = qw(Storable);
48
49 sub make {
50         my $self = bless {};
51         $self->{key} = \%main::a;
52         return $self;
53 };
54
55 package main;
56
57 $foo = FOO->make;
58 isnt($foo->store('store'), undef);
59
60 isnt(open(OUT, '>>store'), undef);
61 binmode OUT;
62
63 isnt(store_fd(\@a, ::OUT), undef);
64 isnt(nstore_fd($foo, ::OUT), undef);
65 isnt(nstore_fd(\%a, ::OUT), undef);
66
67 isnt(close(OUT), undef);
68
69 isnt(open(OUT, 'store'), undef);
70
71 $r = fd_retrieve(::OUT);
72 isnt($r, undef);
73 is(&dump($r), &dump($foo));
74
75 $r = fd_retrieve(::OUT);
76 isnt($r, undef);
77 is(&dump($r), &dump(\@a));
78
79 $r = fd_retrieve(main::OUT);
80 isnt($r, undef);
81 is(&dump($r), &dump($foo));
82
83 $r = fd_retrieve(::OUT);
84 isnt($r, undef);
85 is(&dump($r), &dump(\%a));
86
87 eval { $r = fd_retrieve(::OUT); };
88 isnt($@, '');
89
90 {
91     my %test = (
92         old_retrieve_array => "\x70\x73\x74\x30\x01\x0a\x02\x02\x02\x02\x00\x3d\x08\x84\x08\x85\x08\x06\x04\x00\x00\x01\x1b",
93         old_retrieve_hash  => "\x70\x73\x74\x30\x01\x0a\x03\x00\xe8\x03\x00\x00\x81\x00\x00\x00\x01\x61",
94         retrieve_code      => "\x70\x73\x74\x30\x05\x0a\x19\xf0\x00\xff\xe8\x03\x1a\x0a\x0e\x01",
95     );
96
97     for my $k (sort keys %test) {
98         open my $fh, '<', \$test{$k};
99         eval { Storable::fd_retrieve($fh); };
100         is($?, 0, 'RT 130098:  no segfault in Storable::fd_retrieve()');
101     }
102 }
103
104 close OUT or die "Could not close: $!";
105 END { 1 while unlink 'store' }