dist/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     unshift @INC, 't';
  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";
  20         exit 0;
  21     }
  22     unless ($Config{ivsize} and $Config{ivsize} > $Config{longsize}) {
  23         print "1..0 # Skip: Your IVs are no larger than your longs\n";
  24         exit 0;
  25     }
  26 }
  27
  28 use Storable qw(freeze thaw);
  29 use strict;
  30 use Test::More tests=>30;
  31
  32 use vars qw(%tests);
  33
  34 {
  35     local $/ = "\n\nend\n";
  36     while (<DATA>) {
  37         next unless /\S/s;
  38         unless (/begin ([0-7]{3}) ([^\n]*)\n(.*)$/s) {
  39             s/\n.*//s;
  40             warn "Dodgy data in section starting '$_'";
  41             next;
  42         }
  43         next unless oct $1 == ord 'A'; # Skip ASCII on EBCDIC, and vice versa
  44         my $data = unpack 'u', $3;
  45         $tests{$2} = $data;
  46     }
  47 }
  48
  49 # perl makes easy things easy, and hard things possible:
  50 my $test = freeze \'Hell';
  51
  52 my $header = Storable::read_magic ($test);
  53
  54 is ($header->{byteorder}, $Config{byteorder},
  55     "header's byteorder and Config.pm's should agree");
  56
  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');
  61
  62 my $kingdom = $Config{byteorder} =~ /23/ ? "Lillput" : "Belfuscu";
  63
  64 my $name = join ',', $kingdom, @$header{qw(intsize longsize ptrsize nvsize)};
  65
  66 SKIP: {
  67     my $real_thing = $tests{$name};
  68     if (!defined $real_thing) {
  69         print << "EOM";
  70 # No test data for Storable 1.x for:
  71 #
  72 # byteorder      '$Config{byteorder}'
  73 # sizeof(int)    $$header{intsize}
  74 # sizeof(long)   $$header{longsize}
  75 # sizeof(char *) $$header{ptrsize}
  76 # sizeof(NV)     $$header{nvsize}
  77
  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
  80 # this test.
  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.
  83 EOM
  84         skip "# No 1.x test file", 9;
  85     }
  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");
  94
  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);
  98
  99     is (@$result, 4, "4 elements in array");
 100     like ($$result[0],
 101           qr/^This file was written with [0-9.]+ on perl [0-9.]+\z/,
 102          "1st element");
 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");
 107 }
 108
 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");
 113
 114 my $test_kludge;
 115 {
 116     local $Storable::interwork_56_64bit = 1;
 117     $test_kludge = freeze \'Heck';
 118 }
 119
 120 my $header_kludge = Storable::read_magic ($test_kludge);
 121
 122 cmp_ok (length ($header_kludge->{byteorder}), '==', $Config{longsize},
 123         "With 5.6 interwork kludge byteorder string should be same size as long"
 124        );
 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");
 129
 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");
 134
 135 {
 136     local $Storable::interwork_56_64bit = 1;
 137
 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");
 142
 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");
 147 }
 148
 149 #  All together now:
 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");
 154
 155 __END__
 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.
 159
 160 # byteorder      '1234'
 161 # sizeof(int)    4
 162 # sizeof(long)   4
 163 # sizeof(char *) 4
 164 # sizeof(NV)     8
 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```
 169
 170 end
 171
 172 # byteorder      '4321'
 173 # sizeof(int)    4
 174 # sizeof(long)   4
 175 # sizeof(char *) 4
 176 # sizeof(NV)     8
 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`
 181
 182 end
 183
 184 # byteorder      '1234'
 185 # sizeof(int)    4
 186 # sizeof(long)   4
 187 # sizeof(char *) 4
 188 # sizeof(NV)     12
 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```
 193
 194 end
 195