downgrade.t

source of perl for linux application,

#!./perl -w
#
#  Copyright 2002, Larry Wall.
#
#  You may redistribute only under the same terms as Perl 5, as specified
#  in the README file that comes with the distribution.
#

# I ought to keep this test easily backwards compatible to 5.004, so no
# qr//;

# This test checks downgrade behaviour on pre-5.8 perls when new 5.8 features
# are encountered.

sub BEGIN {
    if ($ENV{PERL_CORE}){
	chdir('t') if -d 't';
	@INC = ('.', '../lib');
    } else {
	unshift @INC, 't';
    }
    require Config; import Config;
    if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
        print "1..0 # Skip: Storable was not built\n";
        exit 0;
    }
}

use Test::More;
use Storable 'thaw';

use strict;
use vars qw(@RESTRICT_TESTS %R_HASH %U_HASH $UTF8_CROAK $RESTRICTED_CROAK);

@RESTRICT_TESTS = ('Locked hash', 'Locked hash placeholder',
                   'Locked keys', 'Locked keys placeholder',
                  );
%R_HASH = (perl => 'rules');

if ($] > 5.007002) {
  # This is cheating. "\xdf" in Latin 1 is beta S, so will match \w if it
  # is stored in utf8, not bytes.
  # "\xdf" is y diaresis in EBCDIC (except for cp875, but so far no-one seems
  # to use that) which has exactly the same properties for \w
  # So the tests happen to pass.
  my $utf8 = "Schlo\xdf" . chr 256;
  chop $utf8;

  # \xe5 is V in EBCDIC. That doesn't have the same properties w.r.t. \w as
  # an a circumflex, so we need to be explicit.

  # and its these very properties we're trying to test - an edge case
  # involving whether scalars are being stored in bytes or in utf8.
  my $a_circumflex = (ord ('A') == 193 ? "\x47" : "\xe5");
  %U_HASH = (map {$_, $_} 'castle', "ch${a_circumflex}teau", $utf8, chr 0x57CE);
  plan tests => 169;
} elsif ($] >= 5.006) {
  plan tests => 59;
} else {
  plan tests => 67;
}

$UTF8_CROAK = "/^Cannot retrieve UTF8 data in non-UTF8 perl/";
$RESTRICTED_CROAK = "/^Cannot retrieve restricted hash/";

my %tests;
{
  local $/ = "\n\nend\n";
  while (<DATA>) {
    next unless /\S/s;
    unless (/begin ([0-7]{3}) ([^\n]*)\n(.*)$/s) {
      s/\n.*//s;
      warn "Dodgy data in section starting '$_'";
      next;
    }
    next unless oct $1 == ord 'A'; # Skip ASCII on EBCDIC, and vice versa
    my $data = unpack 'u', $3;
    $tests{$2} = $data;
  }
}

# use Data::Dumper; $Data::Dumper::Useqq = 1; print Dumper \%tests;
sub thaw_hash {
  my ($name, $expected) = @_;
  my $hash = eval {thaw $tests{$name}};
  is ($@, '', "Thawed $name without error?");
  isa_ok ($hash, 'HASH');
  ok (defined $hash && eq_hash($hash, $expected),
      "And it is the hash we expected?");
  $hash;
}

sub thaw_scalar {
  my ($name, $expected, $bug) = @_;
  my $scalar = eval {thaw $tests{$name}};
  is ($@, '', "Thawed $name without error?");
  isa_ok ($scalar, 'SCALAR', "Thawed $name?");
  if ($bug and $] == 5.006) {
    # Aargh. <expletive> <expletive> 5.6.0's harness doesn't even honour
    # TODO tests.
    warn "# Test skipped because eq is buggy for certain Unicode cases in 5.6.0";
    warn "# Please upgrade to 5.6.1\n";
    ok ("I'd really like to fail this test on 5.6.0 but I'm told that CPAN auto-dependancies mess up, and certain vendors only ship 5.6.0. Get your vendor to ugrade. Else upgrade your vendor.");
    # One such vendor being the folks who brought you LONG_MIN as a positive
    # integer.
  } else {
    is ($$scalar, $expected, "And it is the data we expected?");
  }
  $scalar;
}

sub thaw_fail {
  my ($name, $expected) = @_;
  my $thing = eval {thaw $tests{$name}};
  is ($thing, undef, "Thawed $name failed as expected?");
  like ($@, $expected, "Error as predicted?");
}

sub test_locked_hash {
  my $hash = shift;
  my @keys = keys %$hash;
  my ($key, $value) = each %$hash;
  eval {$hash->{$key} = reverse $value};
  like( $@, "/^Modification of a read-only value attempted/",
        'trying to change a locked key' );
  is ($hash->{$key}, $value, "hash should not change?");
  eval {$hash->{use} = 'perl'};
  like( $@, "/^Attempt to access disallowed key 'use' in a restricted hash/",
        'trying to add another key' );
  ok (eq_array([keys %$hash], \@keys), "Still the same keys?");
}

sub test_restricted_hash {
  my $hash = shift;
  my @keys = keys %$hash;
  my ($key, $value) = each %$hash;
  eval {$hash->{$key} = reverse $value};
  is( $@, '',
        'trying to change a restricted key' );
  is ($hash->{$key}, reverse ($value), "hash should change");
  eval {$hash->{use} = 'perl'};
  like( $@, "/^Attempt to access disallowed key 'use' in a restricted hash/",
        'trying to add another key' );
  ok (eq_array([keys %$hash], \@keys), "Still the same keys?");
}

sub test_placeholder {
  my $hash = shift;
  eval {$hash->{rules} = 42};
  is ($@, '', 'No errors');
  is ($hash->{rules}, 42, "New value added");
}

sub test_newkey {
  my $hash = shift;
  eval {$hash->{nms} = "http://nms-cgi.sourceforge.net/"};
  is ($@, '', 'No errors');
  is ($hash->{nms}, "http://nms-cgi.sourceforge.net/", "New value added");
}

# $Storable::DEBUGME = 1;
thaw_hash ('Hash with utf8 flag but no utf8 keys', \%R_HASH);

if (eval "use Hash::Util; 1") {
  print "# We have Hash::Util, so test that the restricted hashes in <DATA> are valid\n";
  for $Storable::downgrade_restricted (0, 1, undef, "cheese") {
    my $hash = thaw_hash ('Locked hash', \%R_HASH);
    test_locked_hash ($hash);
    $hash = thaw_hash ('Locked hash placeholder', \%R_HASH);
    test_locked_hash ($hash);
    test_placeholder ($hash);

    $hash = thaw_hash ('Locked keys', \%R_HASH);
    test_restricted_hash ($hash);
    $hash = thaw_hash ('Locked keys placeholder', \%R_HASH);
    test_restricted_hash ($hash);
    test_placeholder ($hash);
  }
} else {
  print "# We don't have Hash::Util, so test that the restricted hashes downgrade\n";
  my $hash = thaw_hash ('Locked hash', \%R_HASH);
  test_newkey ($hash);
  $hash = thaw_hash ('Locked hash placeholder', \%R_HASH);
  test_newkey ($hash);
  $hash = thaw_hash ('Locked keys', \%R_HASH);
  test_newkey ($hash);
  $hash = thaw_hash ('Locked keys placeholder', \%R_HASH);
  test_newkey ($hash);
  local $Storable::downgrade_restricted = 0;
  thaw_fail ('Locked hash', $RESTRICTED_CROAK);
  thaw_fail ('Locked hash placeholder', $RESTRICTED_CROAK);
  thaw_fail ('Locked keys', $RESTRICTED_CROAK);
  thaw_fail ('Locked keys placeholder', $RESTRICTED_CROAK);
}

if ($] >= 5.006) {
  print "# We have utf8 scalars, so test that the utf8 scalars in <DATA> are valid\n";
  thaw_scalar ('Short 8 bit utf8 data', "\xDF", 1);
  thaw_scalar ('Long 8 bit utf8 data', "\xDF" x 256, 1);
  thaw_scalar ('Short 24 bit utf8 data', chr 0xC0FFEE);
  thaw_scalar ('Long 24 bit utf8 data', chr (0xC0FFEE) x 256);
} else {
  print "# We don't have utf8 scalars, so test that the utf8 scalars downgrade\n";
  thaw_fail ('Short 8 bit utf8 data', $UTF8_CROAK);
  thaw_fail ('Long 8 bit utf8 data', $UTF8_CROAK);
  thaw_fail ('Short 24 bit utf8 data', $UTF8_CROAK);
  thaw_fail ('Long 24 bit utf8 data', $UTF8_CROAK);
  local $Storable::drop_utf8 = 1;
  my $bytes = thaw $tests{'Short 8 bit utf8 data as bytes'};
  thaw_scalar ('Short 8 bit utf8 data', $$bytes);
  thaw_scalar ('Long 8 bit utf8 data', $$bytes x 256);
  $bytes = thaw $tests{'Short 24 bit utf8 data as bytes'};
  thaw_scalar ('Short 24 bit utf8 data', $$bytes);
  thaw_scalar ('Long 24 bit utf8 data', $$bytes x 256);
}

if ($] > 5.007002) {
  print "# We have utf8 hashes, so test that the utf8 hashes in <DATA> are valid\n";
  my $hash = thaw_hash ('Hash with utf8 keys', \%U_HASH);
  my $a_circumflex = (ord ('A') == 193 ? "\x47" : "\xe5");
  for (keys %$hash) {
    my $l = 0 + /^\w+$/;
    my $r = 0 + $hash->{$_} =~ /^\w+$/;
    cmp_ok ($l, '==', $r, sprintf "key length %d", length $_);
    cmp_ok ($l, '==', $_ eq "ch${a_circumflex}teau" ? 0 : 1);
  }
  if (eval "use Hash::Util; 1") {
    print "# We have Hash::Util, so test that the restricted utf8 hash is valid\n";
  my $hash = thaw_hash ('Locked hash with utf8 keys', \%U_HASH);
    for (keys %$hash) {
      my $l = 0 + /^\w+$/;
      my $r = 0 + $hash->{$_} =~ /^\w+$/;
      cmp_ok ($l, '==', $r, sprintf "key length %d", length $_);
      cmp_ok ($l, '==', $_ eq "ch${a_circumflex}teau" ? 0 : 1);
    }
    test_locked_hash ($hash);
  } else {
    print "# We don't have Hash::Util, so test that the utf8 hash downgrades\n";
    fail ("You can't get here [perl version $]]. This is a bug in the test.
# Please send the output of perl -V to perlbug\@perl.org");
  }
} else {
  print "# We don't have utf8 hashes, so test that the utf8 hashes downgrade\n";
  thaw_fail ('Hash with utf8 keys', $UTF8_CROAK);
  thaw_fail ('Locked hash with utf8 keys', $UTF8_CROAK);
  local $Storable::drop_utf8 = 1;
  my $what = $] < 5.006 ? 'pre 5.6' : '5.6';
  my $expect = thaw $tests{"Hash with utf8 keys for $what"};
  thaw_hash ('Hash with utf8 keys', $expect);
  #foreach (keys %$expect) { print "'$_':\t'$expect->{$_}'\n"; }
  #foreach (keys %$got) { print "'$_':\t'$got->{$_}'\n"; }
  if (eval "use Hash::Util; 1") {
    print "# We have Hash::Util, so test that the restricted hashes in <DATA> are valid\n";
    fail ("You can't get here [perl version $]]. This is a bug in the test.
# Please send the output of perl -V to perlbug\@perl.org");
  } else {