This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Dual-life I18N::Collate
[perl5.git] / dist / Storable / t / restrict.t
CommitLineData
530b72ba 1#!./perl -w
e16e2ff8
NC
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
9sub BEGIN {
48c887dd 10 unshift @INC, 't';
530b72ba 11 if ($ENV{PERL_CORE}){
530b72ba
NC
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
NC
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
NC
26 exit 0;
27 } else {
28 die;
29 }
30 }
372cb964 31 unshift @INC, 't';
e16e2ff8 32 }
372cb964 33 require 'st-dump.pl';
e16e2ff8
NC
34}
35
36
dfd91409 37use Storable qw(dclone freeze thaw);
e16e2ff8
NC
38use Hash::Util qw(lock_hash unlock_value);
39
dfd91409 40print "1..100\n";
e16e2ff8
NC
41
42my %hash = (question => '?', answer => 42, extra => 'junk', undef => undef);
43lock_hash %hash;
44unlock_value %hash, 'answer';
45unlock_value %hash, 'extra';
46delete $hash{'extra'};
47
48my $test;
49
50package Restrict_Test;
51
52sub me_second {
53 return (undef, $_[0]);
54}
55
56package main;
57
dfd91409
NC
58sub freeze_thaw {
59 my $temp = freeze $_[0];
60 return thaw $temp;
61}
62
e16e2ff8
NC
63sub testit {
64 my $hash = shift;
dfd91409
NC
65 my $cloner = shift;
66 my $copy = &$cloner($hash);
e16e2ff8
NC
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
NC
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
103for $Storable::canonical (0, 1) {
dfd91409
NC
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
NC
127 }
128 }
e16e2ff8 129}