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