3 # Copyright 2002, Larry Wall.
5 # You may redistribute only under the same terms as Perl 5, as specified
6 # in the README file that comes with the distribution.
9 # I ought to keep this test easily backwards compatible to 5.004, so no
12 # This test checks whether the kludge to interwork with 5.6 Storables compiled
13 # on Unix systems with IV as long long works.
17 require Config; import Config;
18 if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
19 print "1..0 # Skip: Storable was not built\n";
22 unless ($Config{ivsize} and $Config{ivsize} > $Config{longsize}) {
23 print "1..0 # Skip: Your IVs are no larger than your longs\n";
28 use Storable qw(freeze thaw);
30 use Test::More tests=>30;
35 local $/ = "\n\nend\n";
38 unless (/begin ([0-7]{3}) ([^\n]*)\n(.*)$/s) {
40 warn "Dodgy data in section starting '$_'";
43 next unless oct $1 == ord 'A'; # Skip ASCII on EBCDIC, and vice versa
44 my $data = unpack 'u', $3;
49 # perl makes easy things easy, and hard things possible:
50 my $test = freeze \'Hell';
52 my $header = Storable::read_magic ($test);
54 is ($header->{byteorder}, $Config{byteorder},
55 "header's byteorder and Config.pm's should agree");
57 my $result = eval {thaw $test};
58 isa_ok ($result, 'SCALAR', "Check thawing test data");
59 is ($@, '', "causes no errors");
60 is ($$result, 'Hell', 'and gives the expected data');
62 my $kingdom = $Config{byteorder} =~ /23/ ? "Lillput" : "Belfuscu";
64 my $name = join ',', $kingdom, @$header{qw(intsize longsize ptrsize nvsize)};
67 my $real_thing = $tests{$name};
68 if (!defined $real_thing) {
70 # No test data for Storable 1.x for:
72 # byteorder '$Config{byteorder}'
73 # sizeof(int) $$header{intsize}
74 # sizeof(long) $$header{longsize}
75 # sizeof(char *) $$header{ptrsize}
76 # sizeof(NV) $$header{nvsize}
78 # If you have Storable 1.x built with perl 5.6.x on this platform, please
79 # make_56_interwork.pl to generate test data, and append the test data to
81 # You may find that make_56_interwork.pl reports that your platform has no
82 # interworking problems, in which case you need do nothing.
84 skip "# No 1.x test file", 9;
86 my $result = eval {thaw $real_thing};
87 is ($result, undef, "By default should not be able to thaw");
88 like ($@, qr/Byte order is not compatible/,
89 "because the header byte order strings differ");
90 local $Storable::interwork_56_64bit = 1;
91 $result = eval {thaw $real_thing};
92 isa_ok ($result, 'ARRAY', "With flag should now thaw");
93 is ($@, '', "with no errors");
95 # However, as the file is written with Storable pre 2.01, it's a known
96 # bug that large (positive) UVs become IVs
97 my $value = (~0 ^ (~0 >> 1) ^ 2);
99 is (@$result, 4, "4 elements in array");
101 qr/^This file was written with [0-9.]+ on perl [0-9.]+\z/,
103 is ($$result[1], "$kingdom was correct", "2nd element");
104 cmp_ok ($$result[2] ^ $value, '==', 0, "3rd element") or
105 printf "# expected %#X, got %#X\n", $value, $$result[2];
106 is ($$result[3], "The End", "4th element");
109 $result = eval {thaw $test};
110 isa_ok ($result, 'SCALAR', "CHORUS: check thawing test data");
111 is ($@, '', " causes no errors");
112 is ($$result, 'Hell', " and gives the expected data");
116 local $Storable::interwork_56_64bit = 1;
117 $test_kludge = freeze \'Heck';
120 my $header_kludge = Storable::read_magic ($test_kludge);
122 cmp_ok (length ($header_kludge->{byteorder}), '==', $Config{longsize},
123 "With 5.6 interwork kludge byteorder string should be same size as long"
125 $result = eval {thaw $test_kludge};
126 is ($result, undef, "By default should not be able to thaw");
127 like ($@, qr/Byte order is not compatible/,
128 "because the header byte order strings differ");
130 $result = eval {thaw $test};
131 isa_ok ($result, 'SCALAR', "CHORUS: check thawing test data");
132 is ($@, '', " causes no errors");
133 is ($$result, 'Hell', " and gives the expected data");
136 local $Storable::interwork_56_64bit = 1;
138 $result = eval {thaw $test_kludge};
139 isa_ok ($result, 'SCALAR', "should be able to thaw kludge data");
140 is ($@, '', "with no errors");
141 is ($$result, 'Heck', "and gives expected data");
143 $result = eval {thaw $test};
144 is ($result, undef, "But now can't thaw real data");
145 like ($@, qr/Byte order is not compatible/,
146 "because the header byte order strings differ");
150 $result = eval {thaw $test};
151 isa_ok ($result, 'SCALAR', "CHORUS: check thawing test data");
152 is ($@, '', " causes no errors");
153 is ($$result, 'Hell', " and gives the expected data");
156 # A whole run of 1.1.14 freeze data, uuencoded. The "mode bits" are the octal
157 # value of 'A', the "file name" is the test name. Use make_56_interwork.pl
158 # with a copy of Storable 1.X generate these.
165 begin 101 Lillput,4,4,4,8
166 M!`0$,3(S-`0$!`@"!`````HQ5&AI<R!F:6QE('=A<R!W<FET=&5N('=I=&@@
167 M,2XP,30@;VX@<&5R;"`U+C`P-C`P,0H33&EL;'!U="!W87,@8V]R<F5C=`8"
168 0````````@`H'5&AE($5N9```
177 begin 101 Belfuscu,4,4,4,8
178 M!`0$-#,R,00$!`@"````!`HQ5&AI<R!F:6QE('=A<R!W<FET=&5N('=I=&@@
179 M,2XP,30@;VX@<&5R;"`U+C`P-C`P,0H40F5L9G5S8W4@=V%S(&-O<G)E8W0&
180 1@`````````(*!U1H92!%;F0`
189 begin 101 Lillput,4,4,4,12
190 M!`0$,3(S-`0$!`P"!`````HQ5&AI<R!F:6QE('=A<R!W<FET=&5N('=I=&@@
191 M,2XP,30@;VX@<&5R;"`U+C`P-C`P,0H33&EL;'!U="!W87,@8V]R<F5C=`8"
192 0````````@`H'5&AE($5N9```