ext/Storable/t/restrict.t

   1 #!./perl
   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 sub BEGIN {
  11     chdir('t') if -d 't';
  12     @INC = '.';
  13     push @INC, '../lib';
  14     require Config; import Config;
  15     if ($Config{'extensions'} !~ /\bStorable\b/) {
  16         print "1..0 # Skip: Storable was not built\n";
  17         exit 0;
  18     }
  19     require 'lib/st-dump.pl';
  20 }
  21
  22
  23 use Storable qw(dclone);
  24 use Hash::Util qw(lock_hash unlock_value);
  25
  26 print "1..16\n";
  27
  28 my %hash = (question => '?', answer => 42, extra => 'junk', undef => undef);
  29 lock_hash %hash;
  30 unlock_value %hash, 'answer';
  31 unlock_value %hash, 'extra';
  32 delete $hash{'extra'};
  33
  34 my $test;
  35
  36 package Restrict_Test;
  37
  38 sub me_second {
  39   return (undef, $_[0]);
  40 }
  41
  42 package main;
  43
  44 sub testit {
  45   my $hash = shift;
  46   my $copy = dclone $hash;
  47
  48   my @in_keys = sort keys %$hash;
  49   my @out_keys = sort keys %$copy;
  50   unless (ok ++$test, "@in_keys" eq "@out_keys") {
  51     print "# Failed: keys mis-match after deep clone.\n";
  52     print "# Original keys: @in_keys\n";
  53     print "# Copy's keys: @out_keys\n";
  54   }
  55
  56   # $copy = $hash;      # used in initial debug of the tests
  57
  58   ok ++$test, Internals::SvREADONLY(%$copy), "cloned hash restricted?";
  59
  60   ok ++$test, Internals::SvREADONLY($copy->{question}),
  61     "key 'question' not locked in copy?";
  62
  63   ok ++$test, !Internals::SvREADONLY($copy->{answer}),
  64     "key 'answer' not locked in copy?";
  65
  66   eval { $copy->{extra} = 15 } ;
  67   unless (ok ++$test, !$@, "Can assign to reserved key 'extra'?") {
  68     my $diag = $@;
  69     $diag =~ s/\n.*\z//s;
  70     print "# \$@: $diag\n";
  71   }
  72
  73   eval { $copy->{nono} = 7 } ;
  74   ok ++$test, $@, "Can not assign to invalid key 'nono'?";
  75
  76   ok ++$test, exists $copy->{undef},
  77     "key 'undef' exists";
  78
  79   ok ++$test, !defined $copy->{undef},
  80     "value for key 'undef' is undefined";
  81 }
  82
  83 for $Storable::canonical (0, 1) {
  84   print "# \$Storable::canonical = $Storable::canonical\n";
  85   testit (\%hash);
  86   my $object = \%hash;
  87   # bless {}, "Restrict_Test";
  88 }
  89