Re: [ID 20020601.005] Storable: STORABLE_freeze mechanism leaks memory (unfreed SVs)
[p5sagit/p5-mst-13.2.git] / ext / Storable / t / retrieve.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     if ($ENV{PERL_CORE}){
11         chdir('t') if -d 't';
12         @INC = ('.', '../lib', '../ext/Storable/t');
13     } else {
14         unshift @INC, 't';
15     }
16     require Config; import Config;
17     if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
18         print "1..0 # Skip: Storable was not built\n";
19         exit 0;
20     }
21     require 'st-dump.pl';
22 }
23
24
25 use Storable qw(store retrieve nstore);
26
27 print "1..14\n";
28
29 $a = 'toto';
30 $b = \$a;
31 $c = bless {}, CLASS;
32 $c->{attribute} = 'attrval';
33 %a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c);
34 @a = ('first', '', undef, 3, -4, -3.14159, 456, 4.5,
35         $b, \$a, $a, $c, \$c, \%a);
36
37 print "not " unless defined store(\@a, 'store');
38 print "ok 1\n";
39 print "not " if Storable::last_op_in_netorder();
40 print "ok 2\n";
41 print "not " unless defined nstore(\@a, 'nstore');
42 print "ok 3\n";
43 print "not " unless Storable::last_op_in_netorder();
44 print "ok 4\n";
45 print "not " unless Storable::last_op_in_netorder();
46 print "ok 5\n";
47
48 $root = retrieve('store');
49 print "not " unless defined $root;
50 print "ok 6\n";
51 print "not " if Storable::last_op_in_netorder();
52 print "ok 7\n";
53
54 $nroot = retrieve('nstore');
55 print "not " unless defined $nroot;
56 print "ok 8\n";
57 print "not " unless Storable::last_op_in_netorder();
58 print "ok 9\n";
59
60 $d1 = &dump($root);
61 print "ok 10\n";
62 $d2 = &dump($nroot);
63 print "ok 11\n";
64
65 print "not " unless $d1 eq $d2; 
66 print "ok 12\n";
67
68 # Make sure empty string is defined at retrieval time
69 print "not " unless defined $root->[1];
70 print "ok 13\n";
71 print "not " if length $root->[1];
72 print "ok 14\n";
73
74 END { 1 while unlink('store', 'nstore') }