This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
5.8.8's Test::More doesn't provide note(), so revert to a print statement.
[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';
1afdebce 11 unshift @INC, 't/compat' if $] < 5.006002;
530b72ba 12 if ($ENV{PERL_CORE}){
530b72ba
NC
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
NC
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
NC
27 exit 0;
28 } else {
29 die;
30 }
31 }
372cb964 32 unshift @INC, 't';
e16e2ff8 33 }
e16e2ff8
NC
34}
35
36
dfd91409 37use Storable qw(dclone freeze thaw);
e16e2ff8 38use Hash::Util qw(lock_hash unlock_value);
dddb60fc 39use Test::More tests => 100;
e16e2ff8
NC
40
41my %hash = (question => '?', answer => 42, extra => 'junk', undef => undef);
42lock_hash %hash;
43unlock_value %hash, 'answer';
44unlock_value %hash, 'extra';
45delete $hash{'extra'};
46
47my $test;
48
49package Restrict_Test;
50
51sub me_second {
52 return (undef, $_[0]);
53}
54
55package main;
56
dfd91409
NC
57sub freeze_thaw {
58 my $temp = freeze $_[0];
59 return thaw $temp;
60}
61
e16e2ff8
NC
62sub testit {
63 my $hash = shift;
dfd91409
NC
64 my $cloner = shift;
65 my $copy = &$cloner($hash);
e16e2ff8
NC
66
67 my @in_keys = sort keys %$hash;
68 my @out_keys = sort keys %$copy;
dddb60fc 69 is("@in_keys", "@out_keys", "keys match after deep clone");
e16e2ff8
NC
70
71 # $copy = $hash; # used in initial debug of the tests
72
dddb60fc 73 is(Internals::SvREADONLY(%$copy), 1, "cloned hash restricted?");
e16e2ff8 74
dddb60fc
NC
75 is(Internals::SvREADONLY($copy->{question}), 1,
76 "key 'question' not locked in copy?");
e16e2ff8 77
dddb60fc
NC
78 is(Internals::SvREADONLY($copy->{answer}), '',
79 "key 'answer' not locked in copy?");
e16e2ff8
NC
80
81 eval { $copy->{extra} = 15 } ;
dddb60fc 82 is($@, '', "Can assign to reserved key 'extra'?");
e16e2ff8
NC
83
84 eval { $copy->{nono} = 7 } ;
dddb60fc 85 isnt($@, '', "Can not assign to invalid key 'nono'?");
e16e2ff8 86
dddb60fc 87 is(exists $copy->{undef}, 1, "key 'undef' exists");
e16e2ff8 88
dddb60fc 89 is($copy->{undef}, undef, "value for key 'undef' is undefined");
e16e2ff8
NC
90}
91
92for $Storable::canonical (0, 1) {
dfd91409 93 for my $cloner (\&dclone, \&freeze_thaw) {
a03ee83d 94 print "# \$Storable::canonical = $Storable::canonical\n";
dfd91409
NC
95 testit (\%hash, $cloner);
96 my $object = \%hash;
97 # bless {}, "Restrict_Test";
98
99 my %hash2;
100 $hash2{"k$_"} = "v$_" for 0..16;
101 lock_hash %hash2;
102 for (0..16) {
103 unlock_value %hash2, "k$_";
104 delete $hash2{"k$_"};
105 }
106 my $copy = &$cloner(\%hash2);
107
108 for (0..16) {
109 my $k = "k$_";
110 eval { $copy->{$k} = undef } ;
dddb60fc 111 is($@, '', "Can assign to reserved key '$k'?");
18026298
NC
112 }
113 }
e16e2ff8 114}