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
CommitLineData
7a6a85bf 1#!./perl
7a6a85bf
RG
2#
3# Copyright (c) 1995-2000, Raphael Manfredi
adf9095d 4#
9e21b3d0
JH
5# You may redistribute only under the same terms as Perl 5, as specified
6# in the README file that comes with the distribution.
7a6a85bf 7#
7a6a85bf
RG
8
9sub BEGIN {
48c887dd 10 unshift @INC, 't';
1afdebce 11 unshift @INC, 't/compat' if $] < 5.006002;
9f233367 12 require Config; import Config;
0c384302 13 if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
9f233367
PP
14 print "1..0 # Skip: Storable was not built\n";
15 exit 0;
16 }
372cb964 17 require 'st-dump.pl';
7a6a85bf
RG
18}
19
9e21b3d0 20use Storable qw(store retrieve store_fd nstore_fd fd_retrieve);
7a6a85bf 21
adf9095d 22use Test::More tests => 24;
7a6a85bf
RG
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
1ec1a96c 32isnt(store(\@a, 'store'), undef);
7a6a85bf
RG
33
34$dumped = &dump(\@a);
1ec1a96c 35isnt($dumped, undef);
7a6a85bf
RG
36
37$root = retrieve('store');
1ec1a96c 38isnt($root, undef);
7a6a85bf
RG
39
40$got = &dump($root);
1ec1a96c 41isnt($got, undef);
7a6a85bf 42
1ec1a96c 43is($got, $dumped);
7a6a85bf 44
29fc1735 451 while unlink 'store';
7a6a85bf
RG
46
47package FOO; @ISA = qw(Storable);
48
49sub make {
50 my $self = bless {};
51 $self->{key} = \%main::a;
52 return $self;
53};
54
55package main;
56
57$foo = FOO->make;
1ec1a96c 58isnt($foo->store('store'), undef);
7a6a85bf 59
1ec1a96c 60isnt(open(OUT, '>>store'), undef);
7a6a85bf
RG
61binmode OUT;
62
1ec1a96c
NC
63isnt(store_fd(\@a, ::OUT), undef);
64isnt(nstore_fd($foo, ::OUT), undef);
65isnt(nstore_fd(\%a, ::OUT), undef);
7a6a85bf 66
1ec1a96c 67isnt(close(OUT), undef);
7a6a85bf 68
1ec1a96c 69isnt(open(OUT, 'store'), undef);
7a6a85bf 70
9e21b3d0 71$r = fd_retrieve(::OUT);
1ec1a96c
NC
72isnt($r, undef);
73is(&dump($r), &dump($foo));
7a6a85bf 74
9e21b3d0 75$r = fd_retrieve(::OUT);
1ec1a96c
NC
76isnt($r, undef);
77is(&dump($r), &dump(\@a));
7a6a85bf 78
9e21b3d0 79$r = fd_retrieve(main::OUT);
1ec1a96c
NC
80isnt($r, undef);
81is(&dump($r), &dump($foo));
7a6a85bf 82
9e21b3d0 83$r = fd_retrieve(::OUT);
1ec1a96c
NC
84isnt($r, undef);
85is(&dump($r), &dump(\%a));
7a6a85bf 86
9e21b3d0 87eval { $r = fd_retrieve(::OUT); };
1ec1a96c 88isnt($@, '');
7a6a85bf 89
adf9095d
JL
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
d1e4d418 104close OUT or die "Could not close: $!";
29fc1735 105END { 1 while unlink 'store' }