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