| Commit | Line | Data |
|---|
| ee0f7aac |
1 | #!./perl -w |
| ee0f7aac |
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 | |
| 2e72b0af |
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 | |
projects / p5sagit/p5-mst-13.2.git / blame