Make Internals::SvREADONLY smarter

(aka: More fun with Hash::Util)

$ perl -lMHash::Util=lock_value
$h{a} = __PACKAGE__; lock_value %h, a; $h{a} = "3"; print $h{a}'
^D
3

OK, so it didn’t really lock it. Now for more fun:

$ perl -lMHash::Util=unlock_value
$h{a} = __PACKAGE__; unlock_value %h, a; $h{a} =~ y/ia/ao/;
print __PACKAGE__
^D
moan

There are three different ways to fix this:
1) Add an SvFAKE function to Internals:: (not *more* ‘internals’ for
   people [ahem, Const::Fast, ahem] to abuse!)
2) Use B::* functions in Hash::Util to check the flags (too slow)
3) Make Internals::SvREADONLY less ‘internal’, by having it deal with
   readonliness in general, rather than just the SVf_READONLY flag.

The third approach seems the most logical, so that’s what this
commit does.

There is one test in t/op/tr.t that uses Internals::SvREADONLY to
detect bovinity, so I’ve changed it to use B instead, as that will
have no effect on post-install efficiency.

(This approach also fixes Const::Fast’s bugginess, but that is purely
accidental.)

diff --git a/t/lib/universal.t b/t/lib/universal.t
index af4a828..1576470 100644 (file)
--- a/t/lib/universal.t
+++ b/t/lib/universal.t
@@ -6,7 +6,7 @@ BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
     require './test.pl';
-    plan( tests => 5 );
+    plan( tests => 10 );
 }
 
 for my $arg ('', 'q[]', qw( 1 undef )) {
@@ -28,6 +28,25 @@ Internals::HvREHASH $hashref at (eval 4) line 1.
 
 $x = *foo;
 Internals::SvREADONLY $x, 1;
+ok Internals::SvREADONLY($x),
+         'read-only glob copies are read-only acc. to Internals::';
 eval { $x = [] };
 like $@, qr/Modification of a read-only value attempted at/,
     'read-only glob copies';
+Internals::SvREADONLY($x,0);
+$x = 42;
+is $x, 42, 'Internals::SvREADONLY can turn off readonliness on globs';
+
+$h{a} = __PACKAGE__;
+Internals::SvREADONLY $h{a}, 1;
+eval { $h{a} = 3 };
+like $@, qr/Modification of a read-only value attempted at/,
+    'making a COW scalar into a read-only one';
+
+$h{b} = __PACKAGE__;
+ok !Internals::SvREADONLY($h{b}),
+       'cows are not read-only acc. to Internals::';
+Internals::SvREADONLY($h{b},0);
+$h{b} =~ y/ia/ao/;
+is __PACKAGE__, 'main',
+  'turning off a cow’s readonliness did not affect sharers of the same PV';

diff --git a/t/op/tr.t b/t/op/tr.t
index 52574b0..0f2ae97 100644 (file)
--- a/t/op/tr.t
+++ b/t/op/tr.t
@@ -483,11 +483,13 @@ is($s, "AxBC", "utf8, DELETE");
 }
 
 ($s) = keys %{{pie => 3}};
-my $wasro = Internals::SvREADONLY($s);
-{
+SKIP: {
+    if (!eval { require B }) { skip "no B", 1 }
+    my $wasro = B::svref_2object(\$s)->FLAGS & &B::SVf_READONLY;
     $wasro or local $TODO = "didn't have a COW";
     $s =~ tr/i//;
-    ok( Internals::SvREADONLY($s), "count-only tr doesn't deCOW COWs" );
+    ok( B::svref_2object(\$s)->FLAGS & &B::SVf_READONLY,
+       "count-only tr doesn't deCOW COWs" );
 }
 
 # [ RT #61520 ]

diff --git a/universal.c b/universal.c
index 35d1bcc..3295fc5 100644 (file)
--- a/universal.c
+++ b/universal.c
@@ -777,19 +777,20 @@ XS(XS_Internals_SvREADONLY)       /* This is dangerous stuff. */
     sv = SvRV(svz);
 
     if (items == 1) {
-        if (SvREADONLY(sv))
+        if (SvREADONLY(sv) && !SvIsCOW(sv))
             XSRETURN_YES;
         else
             XSRETURN_NO;
     }
     else if (items == 2) {
        if (SvTRUE(ST(1))) {
+           if (SvIsCOW(sv)) sv_force_normal(sv);
            SvREADONLY_on(sv);
            XSRETURN_YES;
        }
        else {
            /* I hope you really know what you are doing. */
-           SvREADONLY_off(sv);
+           if (!SvIsCOW(sv)) SvREADONLY_off(sv);
            XSRETURN_NO;
        }
     }