This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #27567] [patch] a typo and a mistake in perltoot.pod
[perl5.git] / ext / Storable / t / restrict.t
CommitLineData
530b72ba 1#!./perl -w
e16e2ff8
NC
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
9sub BEGIN {
372cb964 10 chdir('t') if -d 't';
530b72ba 11 if ($ENV{PERL_CORE}){
7dadce44 12 @INC = ('.', '../lib', '../ext/Storable/t');
530b72ba
NC
13 require Config;
14 if ($Config::Config{'extensions'} !~ /\bStorable\b/) {
15 print "1..0 # Skip: Storable was not built\n";
16 exit 0;
17 }
18 } else {
68c03c1a 19 if ($] < 5.005) {
a2307be4
NC
20 print "1..0 # Skip: No Hash::Util pre 5.005\n";
21 exit 0;
22 # And doing this seems on 5.004 seems to create bogus warnings about
23 # unitialized variables, or coredumps in Perl_pp_padsv
24 } elsif (!eval "require Hash::Util") {
25 if ($@ =~ /Can\'t locate Hash\/Util\.pm in \@INC/s) {
26 print "1..0 # Skip: No Hash::Util:\n";
530b72ba
NC
27 exit 0;
28 } else {
29 die;
30 }
31 }
372cb964 32 unshift @INC, 't';
e16e2ff8 33 }
372cb964 34 require 'st-dump.pl';
e16e2ff8
NC
35}
36
37
38use Storable qw(dclone);
39use Hash::Util qw(lock_hash unlock_value);
40
18026298 41print "1..50\n";
e16e2ff8
NC
42
43my %hash = (question => '?', answer => 42, extra => 'junk', undef => undef);
44lock_hash %hash;
45unlock_value %hash, 'answer';
46unlock_value %hash, 'extra';
47delete $hash{'extra'};
48
49my $test;
50
51package Restrict_Test;
52
53sub me_second {
54 return (undef, $_[0]);
55}
56
57package main;
58
59sub testit {
60 my $hash = shift;
61 my $copy = dclone $hash;
62
63 my @in_keys = sort keys %$hash;
64 my @out_keys = sort keys %$copy;
65 unless (ok ++$test, "@in_keys" eq "@out_keys") {
66 print "# Failed: keys mis-match after deep clone.\n";
67 print "# Original keys: @in_keys\n";
68 print "# Copy's keys: @out_keys\n";
69 }
70
71 # $copy = $hash; # used in initial debug of the tests
72
73 ok ++$test, Internals::SvREADONLY(%$copy), "cloned hash restricted?";
74
75 ok ++$test, Internals::SvREADONLY($copy->{question}),
76 "key 'question' not locked in copy?";
77
78 ok ++$test, !Internals::SvREADONLY($copy->{answer}),
79 "key 'answer' not locked in copy?";
80
81 eval { $copy->{extra} = 15 } ;
82 unless (ok ++$test, !$@, "Can assign to reserved key 'extra'?") {
83 my $diag = $@;
84 $diag =~ s/\n.*\z//s;
530b72ba 85 print "# \$\@: $diag\n";
e16e2ff8
NC
86 }
87
88 eval { $copy->{nono} = 7 } ;
89 ok ++$test, $@, "Can not assign to invalid key 'nono'?";
90
91 ok ++$test, exists $copy->{undef},
92 "key 'undef' exists";
93
94 ok ++$test, !defined $copy->{undef},
95 "value for key 'undef' is undefined";
96}
97
98for $Storable::canonical (0, 1) {
99 print "# \$Storable::canonical = $Storable::canonical\n";
100 testit (\%hash);
101 my $object = \%hash;
102 # bless {}, "Restrict_Test";
18026298
NC
103
104 my %hash2;
105 $hash2{"k$_"} = "v$_" for 0..16;
106 lock_hash %hash2;
107 for (0..16) {
108 unlock_value %hash2, "k$_";
109 delete $hash2{"k$_"};
110 }
111 my $copy = dclone \%hash2;
112
113 for (0..16) {
114 my $k = "k$_";
115 eval { $copy->{$k} = undef } ;
116 unless (ok ++$test, !$@, "Can assign to reserved key '$k'?") {
117 my $diag = $@;
118 $diag =~ s/\n.*\z//s;
119 print "# \$\@: $diag\n";
120 }
121 }
e16e2ff8 122}