Re: [ID 20020601.005] Storable: STORABLE_freeze mechanism leaks memory (unfreed SVs)
[p5sagit/p5-mst-13.2.git] / ext / Storable / t / interwork56.t
1 #!./perl -w
2 #
3 #  Copyright 2002, Larry Wall.
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 # I ought to keep this test easily backwards compatible to 5.004, so no
10 # qr//;
11
12 # This test checks whether the kludge to interwork with 5.6 Storables compiled
13 # on Unix systems with IV as long long works.
14
15 sub BEGIN {
16     if ($ENV{PERL_CORE}){
17         chdir('t') if -d 't';
18         @INC = ('.', '../lib');
19     } else {
20         unshift @INC, 't';
21     }
22     require Config; import Config;
23     if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
24         print "1..0 # Skip: Storable was not built\n";
25         exit 0;
26     }
27     unless ($Config{ivsize} and $Config{ivsize} > $Config{longsize}) {
28         print "1..0 # Skip: Your IVs are no larger than your longs\n";
29         exit 0;
30     }
31 }
32
33 use Storable qw(freeze thaw);
34 use strict;
35 use Test::More tests=>30;
36
37 use vars qw(%tests);
38
39 {
40     local $/ = "\n\nend\n";
41     while (<DATA>) {
42         next unless /\S/s;
43         unless (/begin ([0-7]{3}) ([^\n]*)\n(.*)$/s) {
44             s/\n.*//s;
45             warn "Dodgy data in section starting '$_'";
46             next;
47         }
48         next unless oct $1 == ord 'A'; # Skip ASCII on EBCDIC, and vice versa
49         my $data = unpack 'u', $3;
50         $tests{$2} = $data;
51     }
52 }
53
54 # perl makes easy things easy, and hard things possible:
55 my $test = freeze \'Hell';
56
57 my $header = Storable::read_magic ($test);
58
59 is ($header->{byteorder}, $Config{byteorder},
60     "header's byteorder and Config.pm's should agree");
61
62 my $result = eval {thaw $test};
63 isa_ok ($result, 'SCALAR', "Check thawing test data");
64 is ($@, '', "causes no errors");
65 is ($$result, 'Hell', 'and gives the expected data');
66
67 my $kingdom = $Config{byteorder} =~ /23/ ? "Lillput" : "Belfuscu";
68
69 my $name = join ',', $kingdom, @$header{qw(intsize longsize ptrsize nvsize)};
70
71 SKIP: {
72     my $real_thing = $tests{$name};
73     if (!defined $real_thing) {
74         print << "EOM";
75 # No test data for Storable 1.x for:
76 #
77 # byteorder      '$Config{byteorder}'
78 # sizeof(int)    $$header{intsize}
79 # sizeof(long)   $$header{longsize}
80 # sizeof(char *) $$header{ptrsize}
81 # sizeof(NV)     $$header{nvsize}
82
83 # If you have Storable 1.x built with perl 5.6.x on this platform, please
84 # make_56_interwork.pl to generate test data, and append the test data to
85 # this test. 
86 # You may find that make_56_interwork.pl reports that your platform has no
87 # interworking problems, in which case you need do nothing.
88 EOM
89         skip "# No 1.x test file", 9;
90     }
91     my $result = eval {thaw $real_thing};
92     is ($result, undef, "By default should not be able to thaw");
93     like ($@, qr/Byte order is not compatible/,
94           "because the header byte order strings differ");
95     local $Storable::interwork_56_64bit = 1;
96     $result = eval {thaw $real_thing};
97     isa_ok ($result, 'ARRAY', "With flag should now thaw");
98     is ($@, '', "with no errors");
99
100     # However, as the file is written with Storable pre 2.01, it's a known
101     # bug that large (positive) UVs become IVs
102     my $value = (~0 ^ (~0 >> 1) ^ 2);
103
104     is (@$result, 4, "4 elements in array");
105     like ($$result[0],
106           qr/^This file was written with [0-9.]+ on perl [0-9.]+\z/,
107          "1st element");
108     is ($$result[1], "$kingdom was correct", "2nd element");
109     cmp_ok ($$result[2] ^ $value, '==', 0, "3rd element") or
110         printf "# expected %#X, got %#X\n", $value, $$result[2];
111     is ($$result[3], "The End", "4th element");
112 }
113
114 $result = eval {thaw $test};
115 isa_ok ($result, 'SCALAR', "CHORUS: check thawing test data");
116 is ($@, '', "        causes no errors");
117 is ($$result, 'Hell', "        and gives the expected data");
118
119 my $test_kludge;
120 {
121     local $Storable::interwork_56_64bit = 1;
122     $test_kludge = freeze \'Heck';
123 }
124
125 my $header_kludge = Storable::read_magic ($test_kludge);
126
127 cmp_ok (length ($header_kludge->{byteorder}), '==', $Config{longsize},
128         "With 5.6 interwork kludge byteorder string should be same size as long"
129        );
130 $result = eval {thaw $test_kludge};
131 is ($result, undef, "By default should not be able to thaw");
132 like ($@, qr/Byte order is not compatible/,
133       "because the header byte order strings differ");
134
135 $result = eval {thaw $test};
136 isa_ok ($result, 'SCALAR', "CHORUS: check thawing test data");
137 is ($@, '', "        causes no errors");
138 is ($$result, 'Hell', "        and gives the expected data");
139
140 {
141     local $Storable::interwork_56_64bit = 1;
142
143     $result = eval {thaw $test_kludge};
144     isa_ok ($result, 'SCALAR', "should be able to thaw kludge data");
145     is ($@, '', "with no errors");
146     is ($$result, 'Heck', "and gives expected data");
147
148     $result = eval {thaw $test};
149     is ($result, undef, "But now can't thaw real data");
150     like ($@, qr/Byte order is not compatible/,
151           "because the header byte order strings differ");
152 }
153
154 #  All together now:
155 $result = eval {thaw $test};
156 isa_ok ($result, 'SCALAR', "CHORUS: check thawing test data");
157 is ($@, '', "        causes no errors");
158 is ($$result, 'Hell', "        and gives the expected data");
159
160 __END__
161 # A whole run of 1.1.14 freeze data, uuencoded. The "mode bits" are the octal
162 # value of 'A', the "file name" is the test name. Use make_56_interwork.pl
163 # with a copy of Storable 1.X generate these.
164
165 # byteorder      '1234'
166 # sizeof(int)    4
167 # sizeof(long)   4
168 # sizeof(char *) 4
169 # sizeof(NV)     8
170 begin 101 Lillput,4,4,4,8
171 M!`0$,3(S-`0$!`@"!`````HQ5&AI<R!F:6QE('=A<R!W<FET=&5N('=I=&@@
172 M,2XP,30@;VX@<&5R;"`U+C`P-C`P,0H33&EL;'!U="!W87,@8V]R<F5C=`8"
173 0````````@`H'5&AE($5N9```
174
175 end
176
177 # byteorder      '4321'
178 # sizeof(int)    4
179 # sizeof(long)   4
180 # sizeof(char *) 4
181 # sizeof(NV)     8
182 begin 101 Belfuscu,4,4,4,8
183 M!`0$-#,R,00$!`@"````!`HQ5&AI<R!F:6QE('=A<R!W<FET=&5N('=I=&@@
184 M,2XP,30@;VX@<&5R;"`U+C`P-C`P,0H40F5L9G5S8W4@=V%S(&-O<G)E8W0&
185 1@`````````(*!U1H92!%;F0`
186
187 end
188
189 # byteorder      '1234'
190 # sizeof(int)    4
191 # sizeof(long)   4
192 # sizeof(char *) 4
193 # sizeof(NV)     12
194 begin 101 Lillput,4,4,4,12
195 M!`0$,3(S-`0$!`P"!`````HQ5&AI<R!F:6QE('=A<R!W<FET=&5N('=I=&@@
196 M,2XP,30@;VX@<&5R;"`U+C`P-C`P,0H33&EL;'!U="!W87,@8V]R<F5C=`8"
197 0````````@`H'5&AE($5N9```
198
199 end
200