| 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 => 82; |
| 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 | |
| 166 | is( Internals::SvREFCNT($foo, 2), 2, "update ref count"); |
| 167 | is( Internals::SvREFCNT($foo), 2, "check we got the stored value"); |
| 168 | |
| 169 | # the reference count is a U16, but was returned as an IV resulting in |
| 170 | # different values between 32 and 64-bit builds |
| 171 | my $big_count = 0xFFFFFFF0; # -16 32-bit signed |
| 172 | is( Internals::SvREFCNT($foo, $big_count), $big_count, |
| 173 | "set reference count unsigned"); |
| 174 | is( Internals::SvREFCNT($foo), $big_count, "reference count unsigned"); |
| 175 | |
| 176 | { |
| 177 | my @arr = Internals::SvREFCNT($foo, 1 ); |
| 178 | is(scalar(@arr), 1, "SvREFCNT always returns only 1 item"); |
| 179 | } |
| 180 | |
| 181 | { |
| 182 | my $usage = 'Usage: Internals::SvREFCNT(SCALAR[, REFCOUNT])'; |
| 183 | eval { &Internals::SvREFCNT();}; |
| 184 | like($@, qr/\Q$usage\E/); |
| 185 | $foo = \"perl"; |
| 186 | eval { &Internals::SvREFCNT($foo, 0..1);}; |
| 187 | like($@, qr/\Q$usage\E/); |
| 188 | eval { &Internals::SvREFCNT($foo, 0..3);}; |
| 189 | like($@, qr/\Q$usage\E/); |
| 190 | } |