Commit | Line | Data |
e16e2ff8 |
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 | |