lib/Internals.t

   1 #!/usr/bin/perl -Tw
   2
   3 BEGIN {
   4     if( $ENV{PERL_CORE} ) {
   5         @INC = '../lib';
   6         chdir 't';
   7     }
   8 }
   9
  10 use Test::More tests => 74;
  11
  12 my $ro_err = qr/^Modification of a read-only value attempted/;
  13
  14 ### Read-only scalar
  15 my $foo;
  16
  17 ok( !Internals::SvREADONLY $foo );
  18 $foo = 3;
  19 is($foo, 3);
  20
  21 ok(  Internals::SvREADONLY $foo, 1 );
  22 ok(  Internals::SvREADONLY $foo );
  23 eval { $foo = 'foo'; };
  24 like($@, $ro_err, q/Can't modify read-only scalar/);
  25 eval { undef($foo); };
  26 like($@, $ro_err, q/Can't undef read-only scalar/);
  27 is($foo, 3);
  28
  29 ok( !Internals::SvREADONLY $foo, 0 );
  30 ok( !Internals::SvREADONLY $foo );
  31 $foo = 'foo';
  32 is($foo, 'foo');
  33
  34 ### Read-only array
  35 my @foo;
  36
  37 ok( !Internals::SvREADONLY @foo );
  38 @foo = (1..3);
  39 is(scalar(@foo), 3);
  40 is($foo[2], 3);
  41
  42 ok(  Internals::SvREADONLY @foo, 1 );
  43 ok(  Internals::SvREADONLY @foo );
  44 eval { undef(@foo); };
  45 like($@, $ro_err, q/Can't undef read-only array/);
  46 eval { delete($foo[2]); };
  47 like($@, $ro_err, q/Can't delete from read-only array/);
  48 eval { shift(@foo); };
  49 like($@, $ro_err, q/Can't shift read-only array/);
  50 eval { push(@foo, 'bork'); };
  51 like($@, $ro_err, q/Can't push onto read-only array/);
  52 eval { @foo = qw/foo bar/; };
  53 like($@, $ro_err, q/Can't reassign read-only array/);
  54
  55 ok( !Internals::SvREADONLY @foo, 0 );
  56 ok( !Internals::SvREADONLY @foo );
  57 eval { @foo = qw/foo bar/; };
  58 is(scalar(@foo), 2);
  59 is($foo[1], 'bar');
  60
  61 ### Read-only array element
  62
  63 ok( !Internals::SvREADONLY $foo[2] );
  64 $foo[2] = 'baz';
  65 is($foo[2], 'baz');
  66
  67 ok(  Internals::SvREADONLY $foo[2], 1 );
  68 ok(  Internals::SvREADONLY $foo[2] );
  69
  70 $foo[0] = 99;
  71 is($foo[0], 99, 'Rest of array still modifiable');
  72
  73 shift(@foo);
  74 ok(  Internals::SvREADONLY $foo[1] );
  75 eval { $foo[1] = 'bork'; };
  76 like($@, $ro_err, 'Read-only array element moved');
  77 is($foo[1], 'baz');
  78
  79 ok( !Internals::SvREADONLY $foo[2] );
  80 $foo[2] = 'qux';
  81 is($foo[2], 'qux');
  82
  83 unshift(@foo, 'foo');
  84 ok( !Internals::SvREADONLY $foo[1] );
  85 ok(  Internals::SvREADONLY $foo[2] );
  86
  87 eval { $foo[2] = 86; };
  88 like($@, $ro_err, q/Can't modify read-only array element/);
  89 eval { undef($foo[2]); };
  90 like($@, $ro_err, q/Can't undef read-only array element/);
  91 TODO: {
  92     local $TODO = 'Due to restricted hashes implementation';
  93     eval { delete($foo[2]); };
  94     like($@, $ro_err, q/Can't delete read-only array element/);
  95 }
  96
  97 ok( !Internals::SvREADONLY $foo[2], 0 );
  98 ok( !Internals::SvREADONLY $foo[2] );
  99 $foo[2] = 'xyzzy';
 100 is($foo[2], 'xyzzy');
 101
 102 ### Read-only hash
 103 my %foo;
 104
 105 ok( !Internals::SvREADONLY %foo );
 106 %foo = ('foo' => 1, 2 => 'bar');
 107 is(scalar(keys(%foo)), 2);
 108 is($foo{'foo'}, 1);
 109
 110 ok(  Internals::SvREADONLY %foo, 1 );
 111 ok(  Internals::SvREADONLY %foo );
 112 eval { undef(%foo); };
 113 like($@, $ro_err, q/Can't undef read-only hash/);
 114 TODO: {
 115     local $TODO = 'Due to restricted hashes implementation';
 116     eval { %foo = ('ping' => 'pong'); };
 117     like($@, $ro_err, q/Can't modify read-only hash/);
 118 }
 119 eval { $foo{'baz'} = 123; };
 120 like($@, qr/Attempt to access disallowed key/, q/Can't add to a read-only hash/);
 121
 122 # These ops are allow for Hash::Util functionality
 123 $foo{2} = 'qux';
 124 is($foo{2}, 'qux', 'Can modify elements in a read-only hash');
 125 my $qux = delete($foo{2});
 126 ok(! exists($foo{2}), 'Can delete keys from a read-only hash');
 127 is($qux, 'qux');
 128 $foo{2} = 2;
 129 is($foo{2}, 2, 'Can add back deleted keys in a read-only hash');
 130
 131 ok( !Internals::SvREADONLY %foo, 0 );
 132 ok( !Internals::SvREADONLY %foo );
 133
 134 ### Read-only hash values
 135
 136 ok( !Internals::SvREADONLY $foo{foo} );
 137 $foo{'foo'} = 'bar';
 138 is($foo{'foo'}, 'bar');
 139
 140 ok(  Internals::SvREADONLY $foo{foo}, 1 );
 141 ok(  Internals::SvREADONLY $foo{foo} );
 142 eval { $foo{'foo'} = 88; };
 143 like($@, $ro_err, q/Can't modify a read-only hash value/);
 144 eval { undef($foo{'foo'}); };
 145 like($@, $ro_err, q/Can't undef a read-only hash value/);
 146 my $bar = delete($foo{'foo'});
 147 ok(! exists($foo{'foo'}), 'Can delete a read-only hash value');
 148 is($bar, 'bar');
 149
 150 ok( !Internals::SvREADONLY $foo{foo}, 0 );
 151 ok( !Internals::SvREADONLY $foo{foo} );
 152
 153 is(  Internals::SvREFCNT($foo), 1 );
 154 {
 155     my $bar = \$foo;
 156     is(  Internals::SvREFCNT($foo), 2 );
 157     is(  Internals::SvREFCNT($bar), 1 );
 158 }
 159 is(  Internals::SvREFCNT($foo), 1 );
 160
 161 is(  Internals::SvREFCNT(@foo), 1 );
 162 is(  Internals::SvREFCNT($foo[2]), 1 );
 163 is(  Internals::SvREFCNT(%foo), 1 );
 164 is(  Internals::SvREFCNT($foo{foo}), 1 );
 165