This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Extra guidance for JAPH debuggers.
[perl5.git] / ext / Storable / t / restrict.t
CommitLineData
e16e2ff8
NC
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
10sub 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
23use Storable qw(dclone);
24use Hash::Util qw(lock_hash unlock_value);
25
26print "1..16\n";
27
28my %hash = (question => '?', answer => 42, extra => 'junk', undef => undef);
29lock_hash %hash;
30unlock_value %hash, 'answer';
31unlock_value %hash, 'extra';
32delete $hash{'extra'};
33
34my $test;
35
36package Restrict_Test;
37
38sub me_second {
39 return (undef, $_[0]);
40}
41
42package main;
43
44sub 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
83for $Storable::canonical (0, 1) {
84 print "# \$Storable::canonical = $Storable::canonical\n";
85 testit (\%hash);
86 my $object = \%hash;
87 # bless {}, "Restrict_Test";
88}
89