ext/Storable/t/downgrade.t

   1 #!./perl -w
   2
   3 #
   4 #  Copyright 2002, Larry Wall.
   5 #
   6 #  You may redistribute only under the same terms as Perl 5, as specified
   7 #  in the README file that comes with the distribution.
   8 #
   9
  10 # I ought to keep this test easily backwards compatible to 5.004, so no
  11 # qr//;
  12
  13 # This test checks downgrade behaviour on pre-5.8 perls when new 5.8 features
  14 # are encountered.
  15
  16 sub BEGIN {
  17     if ($ENV{PERL_CORE}){
  18         chdir('t') if -d 't';
  19         @INC = '.';
  20         push @INC, '../lib';
  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     # require 'lib/st-dump.pl';
  28 }
  29
  30 BEGIN {
  31   if (ord 'A' != 65) {
  32     die <<'EBCDIC';
  33 This test doesn't have EBCDIC data yet. Please run t/make_downgrade.pl using
  34 perl 5.8 (or later) and append its output to the end of the test.
  35 Please also mail the output to perlbug@perl.org so that the CPAN copy of
  36 Storable can be updated.
  37 EBCDIC
  38   }
  39 }
  40 use Test::More;
  41 use Storable 'thaw';
  42
  43 use strict;
  44 use vars qw(@RESTRICT_TESTS %R_HASH %U_HASH $UTF8_CROAK $RESTRICTED_CROAK);
  45
  46 @RESTRICT_TESTS = ('Locked hash', 'Locked hash placeholder',
  47                    'Locked keys', 'Locked keys placeholder',
  48                   );
  49 %R_HASH = (perl => 'rules');
  50
  51 if ($] >= 5.007003) {
  52   my $utf8 = "Schlo\xdf" . chr 256;
  53   chop $utf8;
  54
  55   %U_HASH = (map {$_, $_} 'castle', "ch\xe5teau", $utf8, chr 0x57CE);
  56   plan tests => 169;
  57 } elsif ($] >= 5.006) {
  58   plan tests => 59;
  59 } else {
  60   plan tests => 67;
  61 }
  62
  63 $UTF8_CROAK = qr/^Cannot retrieve UTF8 data in non-UTF8 perl/;
  64 $RESTRICTED_CROAK = qr/^Cannot retrieve restricted hash/;
  65
  66 my %tests;
  67 {
  68   local $/ = "\n\nend\n";
  69   while (<DATA>) {
  70     next unless /\S/s;
  71     unless (/begin ([0-7]{3}) ([^\n]*)\n(.*)$/s) {
  72       s/\n.*//s;
  73       warn "Dodgy data in section starting '$_'";
  74       next;
  75     }
  76     next unless oct $1 == ord 'A'; # Skip ASCII on EBCDIC, and vice versa
  77     my $data = unpack 'u', $3;
  78     $tests{$2} = $data;
  79   }
  80 }
  81
  82 # use Data::Dumper; $Data::Dumper::Useqq = 1; print Dumper \%tests;
  83 sub thaw_hash {
  84   my ($name, $expected) = @_;
  85   my $hash = eval {thaw $tests{$name}};
  86   is ($@, '', "Thawed $name without error?");
  87   isa_ok ($hash, 'HASH');
  88   ok (defined $hash && eq_hash($hash, $expected),
  89       "And it is the hash we expected?");
  90   $hash;
  91 }
  92
  93 sub thaw_scalar {
  94   my ($name, $expected) = @_;
  95   my $scalar = eval {thaw $tests{$name}};
  96   is ($@, '', "Thawed $name without error?");
  97   isa_ok ($scalar, 'SCALAR', "Thawed $name?");
  98   is ($$scalar, $expected, "And it is the data we expected?");
  99   $scalar;
 100 }
 101
 102 sub thaw_fail {
 103   my ($name, $expected) = @_;
 104   my $thing = eval {thaw $tests{$name}};
 105   is ($thing, undef, "Thawed $name failed as expected?");
 106   like ($@, $expected, "Error as predicted?");
 107 }
 108
 109 sub test_locked_hash {
 110   my $hash = shift;
 111   my @keys = keys %$hash;
 112   my ($key, $value) = each %$hash;
 113   eval {$hash->{$key} = reverse $value};
 114   like( $@, qr/^Modification of a read-only value attempted/,
 115         'trying to change a locked key' );
 116   is ($hash->{$key}, $value, "hash should not change?");
 117   eval {$hash->{use} = 'perl'};
 118   like( $@, qr/^Attempt to access disallowed key 'use' in a restricted hash/,
 119         'trying to add another key' );
 120   ok (eq_array([keys %$hash], \@keys), "Still the same keys?");
 121 }
 122
 123 sub test_restricted_hash {
 124   my $hash = shift;
 125   my @keys = keys %$hash;
 126   my ($key, $value) = each %$hash;
 127   eval {$hash->{$key} = reverse $value};
 128   is( $@, '',
 129         'trying to change a restricted key' );
 130   is ($hash->{$key}, reverse ($value), "hash should change");
 131   eval {$hash->{use} = 'perl'};
 132   like( $@, qr/^Attempt to access disallowed key 'use' in a restricted hash/,
 133         'trying to add another key' );
 134   ok (eq_array([keys %$hash], \@keys), "Still the same keys?");
 135 }
 136
 137 sub test_placeholder {
 138   my $hash = shift;
 139   eval {$hash->{rules} = 42};
 140   is ($@, '', 'No errors');
 141   is ($hash->{rules}, 42, "New value added");
 142 }
 143
 144 sub test_newkey {
 145   my $hash = shift;
 146   eval {$hash->{nms} = "http://nms-cgi.sourceforge.net/"};
 147   is ($@, '', 'No errors');
 148   is ($hash->{nms}, "http://nms-cgi.sourceforge.net/", "New value added");
 149 }
 150
 151 # $Storable::DEBUGME = 1;
 152 thaw_hash ('Hash with utf8 flag but no utf8 keys', \%R_HASH);
 153
 154 if (eval "use Hash::Util; 1") {
 155   print "# We have Hash::Util, so test that the restricted hashes in <DATA> are valid\n";
 156   for $Storable::downgrade_restricted (0, 1, undef, "cheese") {
 157     my $hash = thaw_hash ('Locked hash', \%R_HASH);
 158     test_locked_hash ($hash);
 159     $hash = thaw_hash ('Locked hash placeholder', \%R_HASH);
 160     test_locked_hash ($hash);
 161     test_placeholder ($hash);
 162
 163     $hash = thaw_hash ('Locked keys', \%R_HASH);
 164     test_restricted_hash ($hash);
 165     $hash = thaw_hash ('Locked keys placeholder', \%R_HASH);
 166     test_restricted_hash ($hash);
 167     test_placeholder ($hash);
 168   }
 169 } else {
 170   print "# We don't have Hash::Util, so test that the restricted hashes downgrade\n";
 171   my $hash = thaw_hash ('Locked hash', \%R_HASH);
 172   test_newkey ($hash);
 173   $hash = thaw_hash ('Locked hash placeholder', \%R_HASH);
 174   test_newkey ($hash);
 175   $hash = thaw_hash ('Locked keys', \%R_HASH);
 176   test_newkey ($hash);
 177   $hash = thaw_hash ('Locked keys placeholder', \%R_HASH);
 178   test_newkey ($hash);
 179   local $Storable::downgrade_restricted = 0;
 180   thaw_fail ('Locked hash', $RESTRICTED_CROAK);
 181   thaw_fail ('Locked hash placeholder', $RESTRICTED_CROAK);
 182   thaw_fail ('Locked keys', $RESTRICTED_CROAK);
 183   thaw_fail ('Locked keys placeholder', $RESTRICTED_CROAK);
 184 }
 185
 186 if ($] >= 5.006) {
 187   print "# We have utf8 scalars, so test that the utf8 scalars in <DATA> are valid\n";
 188   print "# These seem to fail on 5.6 - you should seriously consider upgrading to 5.6.1\n" if $] == 5.006;
 189   thaw_scalar ('Short 8 bit utf8 data', "\xDF");
 190   thaw_scalar ('Long 8 bit utf8 data', "\xDF" x 256);
 191   thaw_scalar ('Short 24 bit utf8 data', chr 0xC0FFEE);
 192   thaw_scalar ('Long 24 bit utf8 data', chr (0xC0FFEE) x 256);
 193 } else {
 194   print "# We don't have utf8 scalars, so test that the utf8 scalars downgrade\n";
 195   thaw_fail ('Short 8 bit utf8 data', $UTF8_CROAK);
 196   thaw_fail ('Long 8 bit utf8 data', $UTF8_CROAK);
 197   thaw_fail ('Short 24 bit utf8 data', $UTF8_CROAK);
 198   thaw_fail ('Long 24 bit utf8 data', $UTF8_CROAK);
 199   local $Storable::drop_utf8 = 1;
 200   my $bytes = thaw $tests{'Short 8 bit utf8 data as bytes'};
 201   thaw_scalar ('Short 8 bit utf8 data', $$bytes);
 202   thaw_scalar ('Long 8 bit utf8 data', $$bytes x 256);
 203   $bytes = thaw $tests{'Short 24 bit utf8 data as bytes'};
 204   thaw_scalar ('Short 24 bit utf8 data', $$bytes);
 205   thaw_scalar ('Long 24 bit utf8 data', $$bytes x 256);
 206 }
 207
 208 if ($] >= 5.007003) {
 209   print "# We have utf8 hashes, so test that the utf8 hashes in <DATA> are valid\n";
 210   my $hash = thaw_hash ('Hash with utf8 keys', \%U_HASH);
 211   for (keys %$hash) {
 212     my $l = 0 + /^\w+$/;
 213     my $r = 0 + $hash->{$_} =~ /^\w+$/;
 214     cmp_ok ($l, '==', $r, sprintf "key length %d", length $_);
 215     cmp_ok ($l, '==', $_ eq "ch\xe5teau" ? 0 : 1);
 216   }
 217   if (eval "use Hash::Util; 1") {
 218     print "# We have Hash::Util, so test that the restricted utf8 hash is valid\n";
 219   my $hash = thaw_hash ('Locked hash with utf8 keys', \%U_HASH);
 220     for (keys %$hash) {
 221       my $l = 0 + /^\w+$/;
 222       my $r = 0 + $hash->{$_} =~ /^\w+$/;
 223       cmp_ok ($l, '==', $r, sprintf "key length %d", length $_);
 224       cmp_ok ($l, '==', $_ eq "ch\xe5teau" ? 0 : 1);
 225     }
 226     test_locked_hash ($hash);
 227   } else {
 228     print "# We don't have Hash::Util, so test that the utf8 hash downgrades\n";
 229     fail ("You can't get here [perl version $]]. This is a bug in the test.
 230 # Please send the output of perl -V to perlbug\@perl.org");
 231   }
 232 } else {
 233   print "# We don't have utf8 hashes, so test that the utf8 hashes downgrade\n";
 234   thaw_fail ('Hash with utf8 keys', $UTF8_CROAK);
 235   thaw_fail ('Locked hash with utf8 keys', $UTF8_CROAK);
 236   local $Storable::drop_utf8 = 1;
 237   my $what = $] < 5.006 ? 'pre 5.6' : '5.6';
 238   my $expect = thaw $tests{"Hash with utf8 keys for $what"};
 239   thaw_hash ('Hash with utf8 keys', $expect);
 240   #foreach (keys %$expect) { print "'$_':\t'$expect->{$_}'\n"; }
 241   #foreach (keys %$got) { print "'$_':\t'$got->{$_}'\n"; }
 242   if (eval "use Hash::Util; 1") {
 243     print "# We have Hash::Util, so test that the restricted hashes in <DATA> are valid\n";
 244     fail ("You can't get here [perl version $]]. This is a bug in the test.
 245 # Please send the output of perl -V to perlbug\@perl.org");
 246   } else {
 247     print "# We don't have Hash::Util, so test that the restricted hashes downgrade\n";
 248     my $hash = thaw_hash ('Locked hash with utf8 keys', $expect);
 249     test_newkey ($hash);
 250     local $Storable::downgrade_restricted = 0;
 251     thaw_fail ('Locked hash with utf8 keys', $RESTRICTED_CROAK);
 252     # Which croak comes first is a bit of an implementation issue :-)
 253     local $Storable::drop_utf8 = 0;
 254     thaw_fail ('Locked hash with utf8 keys', $RESTRICTED_CROAK);
 255   }
 256 }
 257 __END__
 258 # A whole run of 2.x nfreeze data, uuencoded. The "mode bits" are the octal
 259 # value of 'A', the "file name" is the test name. Use make_downgrade.pl to
 260 # generate these.
 261 begin 101 Locked hash
 262 8!049`0````$*!7)U;&5S!`````1P97)L
 263
 264 end
 265
 266 begin 101 Locked hash placeholder
 267 C!049`0````(*!7)U;&5S!`````1P97)L#A0````%<G5L97,`
 268
 269 end
 270
 271 begin 101 Locked keys
 272 8!049`0````$*!7)U;&5S``````1P97)L
 273
 274 end
 275
 276 begin 101 Locked keys placeholder
 277 C!049`0````(*!7)U;&5S``````1P97)L#A0````%<G5L97,`
 278
 279 end
 280
 281 begin 101 Short 8 bit utf8 data
 282 &!047`L.?
 283
 284 end
 285
 286 begin 101 Short 8 bit utf8 data as bytes
 287 &!04*`L.?
 288
 289 end
 290
 291 begin 101 Long 8 bit utf8 data
 292 M!048```"`,.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?
 293 MPY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#
 294 MG\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?
 295 MPY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#
 296 MG\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?
 297 MPY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#
 298 MG\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?
 299 MPY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#
 300 MG\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?
 301 MPY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#
 302 MG\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?
 303 8PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?
 304
 305 end
 306
 307 begin 101 Short 24 bit utf8 data
 308 )!047!?BPC[^N
 309
 310 end
 311
 312 begin 101 Short 24 bit utf8 data as bytes
 313 )!04*!?BPC[^N
 314
 315 end
 316
 317 begin 101 Long 24 bit utf8 data
 318 M!048```%`/BPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
 319 MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
 320 MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
 321 MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
 322 MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
 323 MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
 324 MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
 325 MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
 326 MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
 327 MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
 328 MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
 329 MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
 330 MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
 331 MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
 332 MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
 333 MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
 334 MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
 335 MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
 336 MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
 337 MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
 338 MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
 339 MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
 340 MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
 341 MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
 342 MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
 343 MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
 344 MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
 345 MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/
 346 ;OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N
 347
 348 end
 349
 350 begin 101 Hash with utf8 flag but no utf8 keys
 351 8!049``````$*!7)U;&5S``````1P97)L
 352
 353 end
 354
 355 begin 101 Hash with utf8 keys
 356 M!049``````0*!F-A<W1L90`````&8V%S=&QE"@=C:.5T96%U``````=C:.5T
 357 D96%U%P/EGXX!`````^6?CA<'4V-H;&_#GP(````&4V-H;&_?
 358
 359 end
 360
 361 begin 101 Locked hash with utf8 keys
 362 M!049`0````0*!F-A<W1L900````&8V%S=&QE"@=C:.5T96%U!`````=C:.5T
 363 D96%U%P/EGXX%`````^6?CA<'4V-H;&_#GP8````&4V-H;&_?
 364
 365 end
 366
 367 begin 101 Hash with utf8 keys for pre 5.6
 368 M!049``````0*!F-A<W1L90`````&8V%S=&QE"@=C:.5T96%U``````=C:.5T
 369 D96%U"@/EGXX``````^6?C@H'4V-H;&_#GP(````&4V-H;&_?
 370
 371 end
 372
 373 begin 101 Hash with utf8 keys for 5.6
 374 M!049``````0*!F-A<W1L90`````&8V%S=&QE"@=C:.5T96%U``````=C:.5T
 375 D96%U%P/EGXX``````^6?CA<'4V-H;&_#GP(````&4V-H;&_?
 376
 377 end
 378