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