shared hash keys and ++/--

Message-ID: <20011203163716.C21702@plum.flirble.org>

p4raw-id: //depot/perl@13442

diff --git a/pp.c b/pp.c
index 3ab629e..ff85c37 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -815,10 +815,10 @@ PP(pp_undef)
 PP(pp_predec)
 {
     dSP;
-    if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
+    if (SvTYPE(TOPs) > SVt_PVLV)
        DIE(aTHX_ PL_no_modify);
-    if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
-       SvIVX(TOPs) != IV_MIN)
+    if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
+        && SvIVX(TOPs) != IV_MIN)
     {
        --SvIVX(TOPs);
        SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
@@ -832,11 +832,11 @@ PP(pp_predec)
 PP(pp_postinc)
 {
     dSP; dTARGET;
-    if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
+    if (SvTYPE(TOPs) > SVt_PVLV)
        DIE(aTHX_ PL_no_modify);
     sv_setsv(TARG, TOPs);
-    if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
-       SvIVX(TOPs) != IV_MAX)
+    if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
+        && SvIVX(TOPs) != IV_MAX)
     {
        ++SvIVX(TOPs);
        SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
@@ -853,11 +853,11 @@ PP(pp_postinc)
 PP(pp_postdec)
 {
     dSP; dTARGET;
-    if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
+    if (SvTYPE(TOPs) > SVt_PVLV)
        DIE(aTHX_ PL_no_modify);
     sv_setsv(TARG, TOPs);
-    if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
-       SvIVX(TOPs) != IV_MIN)
+    if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
+        && SvIVX(TOPs) != IV_MIN)
     {
        --SvIVX(TOPs);
        SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);

diff --git a/pp_hot.c b/pp_hot.c
index 8781b6c..29ec96b 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -302,10 +302,10 @@ PP(pp_eq)
 PP(pp_preinc)
 {
     dSP;
-    if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
+    if (SvTYPE(TOPs) > SVt_PVLV)
        DIE(aTHX_ PL_no_modify);
-    if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
-       SvIVX(TOPs) != IV_MAX)
+    if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
+        && SvIVX(TOPs) != IV_MAX)
     {
        ++SvIVX(TOPs);
        SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);

diff --git a/sv.c b/sv.c
index b1da4a8..fcabd8e 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -5846,6 +5846,8 @@ Perl_sv_inc(pTHX_ register SV *sv)
     if (SvGMAGICAL(sv))
        mg_get(sv);
     if (SvTHINKFIRST(sv)) {
+       if (SvREADONLY(sv) && SvFAKE(sv))
+           sv_force_normal(sv);
        if (SvREADONLY(sv)) {
            if (PL_curcop != &PL_compiling)
                Perl_croak(aTHX_ PL_no_modify);
@@ -6000,6 +6002,8 @@ Perl_sv_dec(pTHX_ register SV *sv)
     if (SvGMAGICAL(sv))
        mg_get(sv);
     if (SvTHINKFIRST(sv)) {
+       if (SvREADONLY(sv) && SvFAKE(sv))
+           sv_force_normal(sv);
        if (SvREADONLY(sv)) {
            if (PL_curcop != &PL_compiling)
                Perl_croak(aTHX_ PL_no_modify);

diff --git a/t/op/inc.t b/t/op/inc.t
index f59115e..f360c03 100755 (executable)
--- a/t/op/inc.t
+++ b/t/op/inc.t
@@ -1,97 +1,153 @@
-#!./perl
+#!./perl -w
 
-print "1..12\n";
+# use strict;
+
+print "1..24\n";
+
+my $test = 1;
+
+sub ok {
+  my ($pass, $wrong, $err) = @_;
+  if ($pass) {
+    print "ok $test\n";
+    $test = $test + 1; # Would be doubleplusbad to use ++ in the ++ test.
+    return 1;
+  } else {
+    if ($err) {
+      chomp $err;
+      print "not ok $test # $err\n";
+    } else {
+      if (defined $wrong) {
+        $wrong = ", got $wrong";
+      } else {
+        $wrong = '';
+      }
+      printf "not ok $test # line %d$wrong\n", (caller)[2];
+    }
+  }
+  $test = $test + 1;
+  return;
+}
 
 # Verify that addition/subtraction properly upgrade to doubles.
 # These tests are only significant on machines with 32 bit longs,
 # and two's complement negation, but shouldn't fail anywhere.
 
-$a = 2147483647;
-$c=$a++;
-if ($a == 2147483648) 
-       {print "ok 1\n"}
-else
-       {print "not ok 1\n";}
+my $a = 2147483647;
+my $c=$a++;
+ok ($a == 2147483648, $a);
 
 $a = 2147483647;
 $c=++$a;
-if ($a == 2147483648) 
-       {print "ok 2\n"}
-else
-       {print "not ok 2\n";}
+ok ($a == 2147483648, $a);
 
 $a = 2147483647;
 $a=$a+1;
-if ($a == 2147483648) 
-       {print "ok 3\n"}
-else
-       {print "not ok 3\n";}
+ok ($a == 2147483648, $a);
 
 $a = -2147483648;
 $c=$a--;
-if ($a == -2147483649) 
-       {print "ok 4\n"}
-else
-       {print "not ok 4\n";}
+ok ($a == -2147483649, $a);
 
 $a = -2147483648;
 $c=--$a;
-if ($a == -2147483649) 
-       {print "ok 5\n"}
-else
-       {print "not ok 5\n";}
+ok ($a == -2147483649, $a);
 
 $a = -2147483648;
 $a=$a-1;
-if ($a == -2147483649) 
-       {print "ok 6\n"}
-else
-       {print "not ok 6\n";}
+ok ($a == -2147483649, $a);
 
 $a = 2147483648;
 $a = -$a;
 $c=$a--;
-if ($a == -2147483649) 
-       {print "ok 7\n"}
-else
-       {print "not ok 7\n";}
+ok ($a == -2147483649, $a);
 
 $a = 2147483648;
 $a = -$a;
 $c=--$a;
-if ($a == -2147483649) 
-       {print "ok 8\n"}
-else
-       {print "not ok 8\n";}
+ok ($a == -2147483649, $a);
 
 $a = 2147483648;
 $a = -$a;
 $a=$a-1;
-if ($a == -2147483649) 
-       {print "ok 9\n"}
-else
-       {print "not ok 9\n";}
+ok ($a == -2147483649, $a);
 
 $a = 2147483648;
 $b = -$a;
 $c=$b--;
-if ($b == -$a-1) 
-       {print "ok 10\n"}
-else
-       {print "not ok 10\n";}
+ok ($b == -$a-1, $a);
 
 $a = 2147483648;
 $b = -$a;
 $c=--$b;
-if ($b == -$a-1) 
-       {print "ok 11\n"}
-else
-       {print "not ok 11\n";}
+ok ($b == -$a-1, $a);
 
 $a = 2147483648;
 $b = -$a;
 $b=$b-1;
-if ($b == -(++$a)) 
-       {print "ok 12\n"}
-else
-       {print "not ok 12\n";}
+ok ($b == -(++$a), $a);
+
+# Verify that shared hash keys become unshared.
+
+sub check_same {
+  my ($orig, $suspect) = @_;
+  my $fail;
+  while (my ($key, $value) = each %$suspect) {
+    if (exists $orig->{$key}) {
+      if ($orig->{$key} ne $value) {
+        print "# key '$key' was '$orig->{$key}' now '$value'\n";
+        $fail = 1;
+      }
+    } else {
+      print "# key '$key' is '$orig->{$key}', unexpect.\n";
+      $fail = 1;
+    }
+  }
+  foreach (keys %$orig) {
+    next if (exists $suspect->{$_});
+    print "# key '$_' was '$orig->{$_}' now missing\n";
+    $fail = 1;
+  }
+  ok (!$fail);
+}
+
+my (%orig) = my (%inc) = my (%dec) = my (%postinc) = my (%postdec)
+  = (1 => 1, ab => "ab");
+my %up = (1=>2, ab => 'ac');
+my %down = (1=>0, ab => -1);
+
+foreach (keys %inc) {
+  my $ans = $up{$_};
+  my $up;
+  eval {$up = ++$_};
+  ok ((defined $up and $up eq $ans), $up, $@);
+}
+
+check_same (\%orig, \%inc);
+
+foreach (keys %dec) {
+  my $ans = $down{$_};
+  my $down;
+  eval {$down = --$_};
+  ok ((defined $down and $down eq $ans), $down, $@);
+}
+
+check_same (\%orig, \%dec);
+
+foreach (keys %postinc) {
+  my $ans = $postinc{$_};
+  my $up;
+  eval {$up = $_++};
+  ok ((defined $up and $up eq $ans), $up, $@);
+}
+
+check_same (\%orig, \%postinc);
+
+foreach (keys %postdec) {
+  my $ans = $postdec{$_};
+  my $down;
+  eval {$down = $_--};
+  ok ((defined $down and $down eq $ans), $down, $@);
+}
+
+check_same (\%orig, \%postdec);