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