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