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