1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
|
#!./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.
#
sub BEGIN {
unshift @INC, 't';
unshift @INC, 't/compat' if $] < 5.006002;
if ($ENV{PERL_CORE}){
require Config;
if ($Config::Config{'extensions'} !~ /\bStorable\b/) {
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
} else {
if ($] < 5.005) {
print "1..0 # Skip: No Hash::Util pre 5.005\n";
exit 0;
# And doing this seems on 5.004 seems to create bogus warnings about
# uninitialized variables, or coredumps in Perl_pp_padsv
} elsif (!eval "require Hash::Util") {
if ($@ =~ /Can\'t locate Hash\/Util\.pm in \@INC/s) {
print "1..0 # Skip: No Hash::Util:\n";
exit 0;
} else {
die;
}
}
unshift @INC, 't';
}
}
use Storable qw(dclone freeze thaw);
use Hash::Util qw(lock_hash unlock_value lock_keys);
use Test::More tests => 304;
my %hash = (question => '?', answer => 42, extra => 'junk', undef => undef);
lock_hash %hash;
unlock_value %hash, 'answer';
unlock_value %hash, 'extra';
delete $hash{'extra'};
my $test;
package Restrict_Test;
sub me_second {
return (undef, $_[0]);
}
package main;
sub freeze_thaw {
my $temp = freeze $_[0];
return thaw $temp;
}
sub testit {
my $hash = shift;
my $cloner = shift;
my $copy = &$cloner($hash);
my @in_keys = sort keys %$hash;
my @out_keys = sort keys %$copy;
is("@in_keys", "@out_keys", "keys match after deep clone");
# $copy = $hash; # used in initial debug of the tests
is(Internals::SvREADONLY(%$copy), 1, "cloned hash restricted?");
is(Internals::SvREADONLY($copy->{question}), 1,
"key 'question' not locked in copy?");
is(Internals::SvREADONLY($copy->{answer}), '',
"key 'answer' not locked in copy?");
eval { $copy->{extra} = 15 } ;
is($@, '', "Can assign to reserved key 'extra'?");
eval { $copy->{nono} = 7 } ;
isnt($@, '', "Can not assign to invalid key 'nono'?");
is(exists $copy->{undef}, 1, "key 'undef' exists");
is($copy->{undef}, undef, "value for key 'undef' is undefined");
}
for $Storable::canonical (0, 1) {
for my $cloner (\&dclone, \&freeze_thaw) {
print "# \$Storable::canonical = $Storable::canonical\n";
testit (\%hash, $cloner);
my $object = \%hash;
# bless {}, "Restrict_Test";
my %hash2;
$hash2{"k$_"} = "v$_" for 0..16;
lock_hash %hash2;
for (0..16) {
unlock_value %hash2, "k$_";
delete $hash2{"k$_"};
}
my $copy = &$cloner(\%hash2);
for (0..16) {
my $k = "k$_";
eval { $copy->{$k} = undef } ;
is($@, '', "Can assign to reserved key '$k'?");
}
my %hv;
$hv{a} = __PACKAGE__;
lock_keys %hv;
my $hv2 = &$cloner(\%hv);
ok eval { $$hv2{a} = 70 }, 'COWs do not become read-only';
}
}
# [perl #73972]
{
for my $n (1..100) {
my @keys = map { "FOO$_" } (1..$n);
my $hash1 = {};
lock_keys(%$hash1, @keys);
my $hash2 = dclone($hash1);
my $success;
$success = eval { $hash2->{$_} = 'test' for @keys; 1 };
my $err = $@;
ok($success, "can store in all of the $n restricted slots")
|| diag("failed with $@");
$success = !eval { $hash2->{a} = 'test'; 1 };
ok($success, "the hash is still restricted");
}
}
|
