Commit | Line | Data |
530b72ba |
1 | #!./perl -w |
e16e2ff8 |
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 { |
372cb964 |
11 | chdir('t') if -d 't'; |
530b72ba |
12 | if ($ENV{PERL_CORE}){ |
7dadce44 |
13 | @INC = ('.', '../lib', '../ext/Storable/t'); |
530b72ba |
14 | require Config; |
15 | if ($Config::Config{'extensions'} !~ /\bStorable\b/) { |
16 | print "1..0 # Skip: Storable was not built\n"; |
17 | exit 0; |
18 | } |
19 | } else { |
20 | unless (eval "require Hash::Util") { |
21 | if ($@ =~ /Can\'t locate Hash\/Util\.pm in \@INC/) { |
22 | print "1..0 # Skip: No Hash::Util\n"; |
23 | exit 0; |
24 | } else { |
25 | die; |
26 | } |
27 | } |
372cb964 |
28 | unshift @INC, 't'; |
e16e2ff8 |
29 | } |
372cb964 |
30 | require 'st-dump.pl'; |
e16e2ff8 |
31 | } |
32 | |
33 | |
34 | use Storable qw(dclone); |
35 | use Hash::Util qw(lock_hash unlock_value); |
36 | |
37 | print "1..16\n"; |
38 | |
39 | my %hash = (question => '?', answer => 42, extra => 'junk', undef => undef); |
40 | lock_hash %hash; |
41 | unlock_value %hash, 'answer'; |
42 | unlock_value %hash, 'extra'; |
43 | delete $hash{'extra'}; |
44 | |
45 | my $test; |
46 | |
47 | package Restrict_Test; |
48 | |
49 | sub me_second { |
50 | return (undef, $_[0]); |
51 | } |
52 | |
53 | package main; |
54 | |
55 | sub testit { |
56 | my $hash = shift; |
57 | my $copy = dclone $hash; |
58 | |
59 | my @in_keys = sort keys %$hash; |
60 | my @out_keys = sort keys %$copy; |
61 | unless (ok ++$test, "@in_keys" eq "@out_keys") { |
62 | print "# Failed: keys mis-match after deep clone.\n"; |
63 | print "# Original keys: @in_keys\n"; |
64 | print "# Copy's keys: @out_keys\n"; |
65 | } |
66 | |
67 | # $copy = $hash; # used in initial debug of the tests |
68 | |
69 | ok ++$test, Internals::SvREADONLY(%$copy), "cloned hash restricted?"; |
70 | |
71 | ok ++$test, Internals::SvREADONLY($copy->{question}), |
72 | "key 'question' not locked in copy?"; |
73 | |
74 | ok ++$test, !Internals::SvREADONLY($copy->{answer}), |
75 | "key 'answer' not locked in copy?"; |
76 | |
77 | eval { $copy->{extra} = 15 } ; |
78 | unless (ok ++$test, !$@, "Can assign to reserved key 'extra'?") { |
79 | my $diag = $@; |
80 | $diag =~ s/\n.*\z//s; |
530b72ba |
81 | print "# \$\@: $diag\n"; |
e16e2ff8 |
82 | } |
83 | |
84 | eval { $copy->{nono} = 7 } ; |
85 | ok ++$test, $@, "Can not assign to invalid key 'nono'?"; |
86 | |
87 | ok ++$test, exists $copy->{undef}, |
88 | "key 'undef' exists"; |
89 | |
90 | ok ++$test, !defined $copy->{undef}, |
91 | "value for key 'undef' is undefined"; |
92 | } |
93 | |
94 | for $Storable::canonical (0, 1) { |
95 | print "# \$Storable::canonical = $Storable::canonical\n"; |
96 | testit (\%hash); |
97 | my $object = \%hash; |
98 | # bless {}, "Restrict_Test"; |
99 | } |