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