Re: [PATCH] Enhanced Storable::read_magic()
[p5sagit/p5-mst-13.2.git] / ext / Storable / t / freeze.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     sub ok;
23 }
24
25 use Storable qw(freeze nfreeze thaw);
26
27 print "1..20\n";
28
29 $a = 'toto';
30 $b = \$a;
31 $c = bless {}, CLASS;
32 $c->{attribute} = $b;
33 $d = {};
34 $e = [];
35 $d->{'a'} = $e;
36 $e->[0] = $d;
37 %a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c);
38 @a = ('first', undef, 3, -4, -3.14159, 456, 4.5, $d, \$d, \$e, $e,
39         $b, \$a, $a, $c, \$c, \%a);
40
41 print "not " unless defined ($f1 = freeze(\@a));
42 print "ok 1\n";
43
44 $dumped = &dump(\@a);
45 print "ok 2\n";
46
47 $root = thaw($f1);
48 print "not " unless defined $root;
49 print "ok 3\n";
50
51 $got = &dump($root);
52 print "ok 4\n";
53
54 print "not " unless $got eq $dumped; 
55 print "ok 5\n";
56
57 package FOO; @ISA = qw(Storable);
58
59 sub make {
60         my $self = bless {};
61         $self->{key} = \%main::a;
62         return $self;
63 };
64
65 package main;
66
67 $foo = FOO->make;
68 print "not " unless $f2 = $foo->freeze;
69 print "ok 6\n";
70
71 print "not " unless $f3 = $foo->nfreeze;
72 print "ok 7\n";
73
74 $root3 = thaw($f3);
75 print "not " unless defined $root3;
76 print "ok 8\n";
77
78 print "not " unless &dump($foo) eq &dump($root3);
79 print "ok 9\n";
80
81 $root = thaw($f2);
82 print "not " unless &dump($foo) eq &dump($root);
83 print "ok 10\n";
84
85 print "not " unless &dump($root3) eq &dump($root);
86 print "ok 11\n";
87
88 $other = freeze($root);
89 print "not " unless length($other) == length($f2);
90 print "ok 12\n";
91
92 $root2 = thaw($other);
93 print "not " unless &dump($root2) eq &dump($root);
94 print "ok 13\n";
95
96 $VAR1 = [
97         'method',
98         1,
99         'prepare',
100         'SELECT table_name, table_owner, num_rows FROM iitables
101                   where table_owner != \'$ingres\' and table_owner != \'DBA\''
102 ];
103
104 $x = nfreeze($VAR1);
105 $VAR2 = thaw($x);
106 print "not " unless $VAR2->[3] eq $VAR1->[3];
107 print "ok 14\n";
108
109 # Test the workaround for LVALUE bug in perl 5.004_04 -- from Gisle Aas
110 sub foo { $_[0] = 1 }
111 $foo = [];
112 foo($foo->[1]);
113 eval { freeze($foo) };
114 print "not " if $@;
115 print "ok 15\n";
116
117 # Test cleanup bug found by Claudio Garcia -- RAM, 08/06/2001
118 my $thaw_me = 'asdasdasdasd';
119
120 eval {
121         my $thawed = thaw $thaw_me;
122 };
123 ok 16, $@;
124
125 my %to_be_frozen = (foo => 'bar');
126 my $frozen;
127 eval {
128         $frozen = freeze \%to_be_frozen;
129 };
130 ok 17, !$@;
131
132 freeze {};
133 eval { thaw $thaw_me };
134 eval { $frozen = freeze { foo => {} } };
135 ok 18, !$@;
136
137 thaw $frozen;                   # used to segfault here
138 ok 19, 1;
139
140 if ($] >= 5.006) {
141     eval '
142         $a = []; $#$a = 2; $a->[1] = undef;
143         $b = thaw freeze $a;
144         @a = map { ~~ exists $a->[$_] } 0 .. $#$a;
145         @b = map { ~~ exists $b->[$_] } 0 .. $#$b;
146         ok 20, "@a" eq "@b";
147     ';
148 }
149 else {
150     print "ok 20 # skipped (no av_exists)\n";
151 }