Make ++ and -- work on glob copies

These ops considered typeglobs read-only, even if they weren’t.

diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 37a4d5d..8b09500 100644 (file)
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -805,6 +805,10 @@ C<glob> now clears %ENV before calling csh, since the latter croaks on some
 systems if it does not like the contents of the LS_COLORS enviroment
 variable [perl #98662].
 
+=item *
+
+C<++> and C<--> now work on copies of globs, instead of dying.
+
 =back
 
 =head1 Known Problems

diff --git a/pp.c b/pp.c
index 84c68e6..ba07c31 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -1054,7 +1054,7 @@ PP(pp_undef)
 PP(pp_predec)
 {
     dVAR; dSP;
-    if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
+    if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
        Perl_croak_no_modify(aTHX);
     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
         && SvIVX(TOPs) != IV_MIN)
@@ -1071,7 +1071,7 @@ PP(pp_predec)
 PP(pp_postinc)
 {
     dVAR; dSP; dTARGET;
-    if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
+    if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
        Perl_croak_no_modify(aTHX);
     if (SvROK(TOPs))
        TARG = sv_newmortal();
@@ -1095,7 +1095,7 @@ PP(pp_postinc)
 PP(pp_postdec)
 {
     dVAR; dSP; dTARGET;
-    if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
+    if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
        Perl_croak_no_modify(aTHX);
     if (SvROK(TOPs))
        TARG = sv_newmortal();

diff --git a/pp_hot.c b/pp_hot.c
index ca6b195..594d114 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -362,7 +362,7 @@ PP(pp_eq)
 PP(pp_preinc)
 {
     dVAR; dSP;
-    if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
+    if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
        Perl_croak_no_modify(aTHX);
     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
         && SvIVX(TOPs) != IV_MAX)

diff --git a/sv.c b/sv.c
index d6d32e7..6ab04da 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -7848,7 +7848,7 @@ Perl_sv_inc_nomg(pTHX_ register SV *const sv)
     if (!sv)
        return;
     if (SvTHINKFIRST(sv)) {
-       if (SvIsCOW(sv))
+       if (SvIsCOW(sv) || isGV_with_GP(sv))
            sv_force_normal_flags(sv, 0);
        if (SvREADONLY(sv)) {
            if (IN_PERL_RUNTIME)
@@ -8029,7 +8029,7 @@ Perl_sv_dec_nomg(pTHX_ register SV *const sv)
     if (!sv)
        return;
     if (SvTHINKFIRST(sv)) {
-       if (SvIsCOW(sv))
+       if (SvIsCOW(sv) || isGV_with_GP(sv))
            sv_force_normal_flags(sv, 0);
        if (SvREADONLY(sv)) {
            if (IN_PERL_RUNTIME)

diff --git a/t/op/auto.t b/t/op/auto.t
index ecfe48b..00f7caa 100644 (file)
--- a/t/op/auto.t
+++ b/t/op/auto.t
@@ -3,10 +3,10 @@
 BEGIN {
     chdir 't' if -d 't';
     @INC = qw(. ../lib);
+    require "test.pl";
 }
 
-require "test.pl";
-plan( tests => 39 );
+plan( tests => 47 );
 
 $x = 10000;
 cmp_ok(0 + ++$x - 1,'==',10000,'scalar ++x - 1');
@@ -55,3 +55,11 @@ cmp_ok(++($foo = 'zz'), 'eq','aaa','zzz incr aaa');
 cmp_ok(++($foo = 'A99'),'eq','B00','A99 incr B00');
 cmp_ok(++($foo = 'zi'), 'eq','zj','zi incr zj (EBCDIC i,j non-contiguous check)');
 cmp_ok(++($foo = 'zr'), 'eq','zs','zr incr zs (EBCDIC r,s non-contiguous check)');
+
+# test with glob copies
+
+for(qw '$x++ ++$x $x-- --$x') {
+  my $x = *foo;
+  ok eval "$_; 1", "$_ does not die on a glob copy";
+  is $x, /-/ ? -1 : 1, "result of $_ on a glob copy";
+}