Don’t crash with $tied[-1] when array is tied to non-obj

The code for checking to see whether $NEGATIVE_INDICES is defined in
the tie package was very fragile, and was repeated four times.

diff --git a/av.c b/av.c
index b707059..fe6cd9b 100644 (file)
--- a/av.c
+++ b/av.c
@@ -211,6 +211,31 @@ The rough perl equivalent is C<$myarray[$idx]>.
 =cut
 */
 
+static bool
+S_adjust_index(pTHX_ AV *av, const MAGIC *mg, I32 *keyp)
+{
+    bool adjust_index = 1;
+    if (mg) {
+       /* Handle negative array indices 20020222 MJD */
+       SV * const ref = SvTIED_obj(MUTABLE_SV(av), mg);
+       SvGETMAGIC(ref);
+       if (SvROK(ref) && SvOBJECT(SvRV(ref))) {
+           SV * const * const negative_indices_glob =
+               hv_fetchs(SvSTASH(SvRV(ref)), NEGATIVE_INDICES_VAR, 0);
+
+           if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob)))
+               adjust_index = 0;
+       }
+    }
+
+    if (adjust_index) {
+       *keyp += AvFILL(av) + 1;
+       if (*keyp < 0)
+           return FALSE;
+    }
+    return TRUE;
+}
+
 SV**
 Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
 {
@@ -225,23 +250,8 @@ Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
         if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
            SV *sv;
            if (key < 0) {
-               I32 adjust_index = 1;
-               if (tied_magic) {
-                   /* Handle negative array indices 20020222 MJD */
-                   SV * const * const negative_indices_glob =
-                       hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
-                                                        tied_magic))),
-                               NEGATIVE_INDICES_VAR, 16, 0);
-
-                   if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob)))
-                       adjust_index = 0;
-               }
-
-               if (adjust_index) {
-                   key += AvFILL(av) + 1;
-                   if (key < 0)
+               if (!S_adjust_index(aTHX_ av, tied_magic, &key))
                        return NULL;
-               }
            }
 
             sv = sv_newmortal();
@@ -316,21 +326,9 @@ Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
     if (SvRMAGICAL(av)) {
         const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied);
         if (tied_magic) {
-            /* Handle negative array indices 20020222 MJD */
             if (key < 0) {
-               bool adjust_index = 1;
-               SV * const * const negative_indices_glob =
-                    hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av), 
-                                                     tied_magic))), 
-                             NEGATIVE_INDICES_VAR, 16, 0);
-                if (negative_indices_glob
-                    && SvTRUE(GvSV(*negative_indices_glob)))
-                    adjust_index = 0;
-                if (adjust_index) {
-                    key += AvFILL(av) + 1;
-                    if (key < 0)
+               if (!S_adjust_index(aTHX_ av, tied_magic, &key))
                         return 0;
-                }
             }
            if (val != &PL_sv_undef) {
                mg_copy(MUTABLE_SV(av), val, 0, key);
@@ -861,24 +859,10 @@ Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
         const MAGIC * const tied_magic
            = mg_find((const SV *)av, PERL_MAGIC_tied);
         if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
-            /* Handle negative array indices 20020222 MJD */
             SV **svp;
             if (key < 0) {
-                unsigned adjust_index = 1;
-                if (tied_magic) {
-                   SV * const * const negative_indices_glob =
-                        hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av), 
-                                                         tied_magic))), 
-                                 NEGATIVE_INDICES_VAR, 16, 0);
-                    if (negative_indices_glob
-                        && SvTRUE(GvSV(*negative_indices_glob)))
-                        adjust_index = 0;
-                }
-                if (adjust_index) {
-                    key += AvFILL(av) + 1;
-                    if (key < 0)
+               if (!S_adjust_index(aTHX_ av, tied_magic, &key))
                        return NULL;
-                }
             }
             svp = av_fetch(av, key, TRUE);
             if (svp) {
@@ -954,23 +938,8 @@ Perl_av_exists(pTHX_ AV *av, I32 key)
             MAGIC *mg;
             /* Handle negative array indices 20020222 MJD */
             if (key < 0) {
-                unsigned adjust_index = 1;
-                if (tied_magic) {
-                   SV * const * const negative_indices_glob =
-                        hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av), 
-                                                         tied_magic))), 
-                                 NEGATIVE_INDICES_VAR, 16, 0);
-                    if (negative_indices_glob
-                        && SvTRUE(GvSV(*negative_indices_glob)))
-                        adjust_index = 0;
-                }
-                if (adjust_index) {
-                    key += AvFILL(av) + 1;
-                    if (key < 0)
+               if (!S_adjust_index(aTHX_ av, tied_magic, &key))
                         return FALSE;
-                    else
-                        return TRUE;
-                }
             }
 
             if(key >= 0 && regdata_magic) {

diff --git a/mg.c b/mg.c
index 2f8c81c..89629a2 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -111,22 +111,19 @@ S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
        bumped = TRUE;
     }
 
-    /* Turning READONLY off for a copy-on-write scalar (including shared
-       hash keys) is a bad idea.  */
-    if (SvIsCOW(sv))
-      sv_force_normal_flags(sv, 0);
-
     SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
 
     mgs = SSPTR(mgs_ix, MGS*);
     mgs->mgs_sv = sv;
     mgs->mgs_magical = SvMAGICAL(sv);
-    mgs->mgs_readonly = SvREADONLY(sv) != 0;
+    mgs->mgs_readonly = SvREADONLY(sv) && !SvIsCOW(sv);
     mgs->mgs_ss_ix = PL_savestack_ix;   /* points after the saved destructor */
     mgs->mgs_bumped = bumped;
 
     SvMAGICAL_off(sv);
-    SvREADONLY_off(sv);
+    /* Turning READONLY off for a copy-on-write scalar (including shared
+       hash keys) is a bad idea.  */
+    if (!SvIsCOW(sv)) SvREADONLY_off(sv);
 }
 
 /*

diff --git a/regcomp.c b/regcomp.c
index a3a07b9..f676645 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -14178,6 +14178,9 @@ Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
 
     if (!ret_x)
        ret_x = (REGEXP*) newSV_type(SVt_REGEXP);
+    /* This ensures that SvTHINKFIRST(sv) is true, and hence that
+       sv_force_normal(sv) is called.  */
+    SvFAKE_on(ret_x);
     ret = (struct regexp *)SvANY(ret_x);
     
     (void)ReREFCNT_inc(rx);
@@ -14190,8 +14193,6 @@ Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
     memcpy(&(ret->xpv_cur), &(r->xpv_cur),
           sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
     SvLEN_set(ret_x, 0);
-    SvSTASH_set(ret_x, NULL);
-    SvMAGIC_set(ret_x, NULL);
     if (r->offs) {
         const I32 npar = r->nparens+1;
         Newx(ret->offs, npar, regexp_paren_pair);

diff --git a/sv.c b/sv.c
index 4fb42bb..7f40cc7 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -1161,7 +1161,7 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
        no longer need to unshare so as to free up the IVX slot for its proper
        purpose. So it's safe to move the early return earlier.  */
 
-    if (new_type != SVt_PV && SvIsCOW(sv)) {
+    if (new_type > SVt_PVMG && SvIsCOW(sv)) {
        sv_force_normal_flags(sv, 0);
     }
 
@@ -1329,11 +1329,6 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
        }
        break;
 
-
-    case SVt_REGEXP:
-       /* This ensures that SvTHINKFIRST(sv) is true, and hence that
-          sv_force_normal_flags(sv) is called.  */
-       SvFAKE_on(sv);
     case SVt_PVIV:
        /* XXX Is this still needed?  Was it ever needed?   Surely as there is
           no route from NV to PVIV, NOK can never be true  */
@@ -1344,6 +1339,7 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
     case SVt_PVGV:
     case SVt_PVCV:
     case SVt_PVLV:
+    case SVt_REGEXP:
     case SVt_PVMG:
     case SVt_PVNV:
     case SVt_PV:
@@ -2067,7 +2063,7 @@ S_sv_2iuv_common(pTHX_ SV *const sv)
                                  SvUVX(sv)));
        }
     }
-    else if (SvPOKp(sv) && SvLEN(sv)) {
+    else if (SvPOKp(sv)) {
        UV value;
        const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
        /* We want to avoid a possible problem when we cache an IV/ a UV which
@@ -2277,18 +2273,16 @@ Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
        return PTR2IV(SvRV(sv));
     }
 
-    if (SvVALID(sv)) {
+    if (SvVALID(sv) || SvTYPE(sv) == SVt_REGEXP) {
        /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
           the same flag bit as SVf_IVisUV, so must not let them cache IVs.
           In practice they are extremely unlikely to actually get anywhere
           accessible by user Perl code - the only way that I'm aware of is when
           a constant subroutine which is used as the second argument to index.
+
+          Regexps have no SvIVX and SvNVX fields.
        */
-       if (SvIOKp(sv))
-           return SvIVX(sv);
-       if (SvNOKp(sv))
-           return I_V(SvNVX(sv));
-       if (SvPOKp(sv) && SvLEN(sv)) {
+           assert(SvPOKp(sv));
            UV value;
            const int numtype
                = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
@@ -2309,16 +2303,14 @@ Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
                    not_a_number(sv);
            }
            return I_V(Atof(SvPVX_const(sv)));
-       }
-       if (ckWARN(WARN_UNINITIALIZED))
-           report_uninit(sv);
-       return 0;
     }
 
     if (SvTHINKFIRST(sv)) {
+#ifdef PERL_OLD_COPY_ON_WRITE
        if (SvIsCOW(sv)) {
            sv_force_normal_flags(sv, 0);
        }
+#endif
        if (SvREADONLY(sv) && !SvOK(sv)) {
            if (ckWARN(WARN_UNINITIALIZED))
                report_uninit(sv);
@@ -2370,14 +2362,11 @@ Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
        return PTR2UV(SvRV(sv));
     }
 
-    if (SvVALID(sv)) {
+    if (SvVALID(sv) || SvTYPE(sv) == SVt_REGEXP) {
        /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
-          the same flag bit as SVf_IVisUV, so must not let them cache IVs.  */
-       if (SvIOKp(sv))
-           return SvUVX(sv);
-       if (SvNOKp(sv))
-           return U_V(SvNVX(sv));
-       if (SvPOKp(sv) && SvLEN(sv)) {
+          the same flag bit as SVf_IVisUV, so must not let them cache IVs.  
+          Regexps have no SvIVX and SvNVX fields. */
+           assert(SvPOKp(sv));
            UV value;
            const int numtype
                = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
@@ -2393,16 +2382,14 @@ Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
                    not_a_number(sv);
            }
            return U_V(Atof(SvPVX_const(sv)));
-       }
-       if (ckWARN(WARN_UNINITIALIZED))
-           report_uninit(sv);
-       return 0;
     }
 
     if (SvTHINKFIRST(sv)) {
+#ifdef PERL_OLD_COPY_ON_WRITE
        if (SvIsCOW(sv)) {
            sv_force_normal_flags(sv, 0);
        }
+#endif
        if (SvREADONLY(sv) && !SvOK(sv)) {
            if (ckWARN(WARN_UNINITIALIZED))
                report_uninit(sv);
@@ -2436,14 +2423,15 @@ Perl_sv_2nv_flags(pTHX_ register SV *const sv, const I32 flags)
     dVAR;
     if (!sv)
        return 0.0;
-    if (SvGMAGICAL(sv) || SvVALID(sv)) {
+    if (SvGMAGICAL(sv) || SvVALID(sv) || SvTYPE(sv) == SVt_REGEXP) {
        /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
-          the same flag bit as SVf_IVisUV, so must not let them cache NVs.  */
+          the same flag bit as SVf_IVisUV, so must not let them cache NVs.
+          Regexps have no SvIVX and SvNVX fields.  */
        if (flags & SV_GMAGIC)
            mg_get(sv);
        if (SvNOKp(sv))
            return SvNVX(sv);
-       if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) {
+       if (SvPOKp(sv) && !SvIOKp(sv)) {
            if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
                !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
                not_a_number(sv);
@@ -2475,9 +2463,11 @@ Perl_sv_2nv_flags(pTHX_ register SV *const sv, const I32 flags)
            }
            return PTR2NV(SvRV(sv));
        }
+#ifdef PERL_OLD_COPY_ON_WRITE
        if (SvIsCOW(sv)) {
            sv_force_normal_flags(sv, 0);
        }
+#endif
        if (SvREADONLY(sv) && !SvOK(sv)) {
            if (ckWARN(WARN_UNINITIALIZED))
                report_uninit(sv);
@@ -2527,7 +2517,7 @@ Perl_sv_2nv_flags(pTHX_ register SV *const sv, const I32 flags)
            SvNOKp_on(sv);
 #endif
     }
-    else if (SvPOKp(sv) && SvLEN(sv)) {
+    else if (SvPOKp(sv)) {
        UV value;
        const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
        if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
@@ -9456,9 +9446,7 @@ Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
         Perl_croak(aTHX_ "Can't bless non-reference value");
     tmpRef = SvRV(sv);
     if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
-       if (SvIsCOW(tmpRef))
-           sv_force_normal_flags(tmpRef, 0);
-       if (SvREADONLY(tmpRef))
+       if (SvREADONLY(tmpRef) && !SvIsCOW(tmpRef))
            Perl_croak_no_modify(aTHX);
        if (SvOBJECT(tmpRef)) {
            if (SvTYPE(tmpRef) != SVt_PVIO)

diff --git a/t/lib/warnings/9uninit b/t/lib/warnings/9uninit
index d1450d5..2877f14 100644 (file)
--- a/t/lib/warnings/9uninit
+++ b/t/lib/warnings/9uninit
@@ -2072,3 +2072,17 @@ Use of uninitialized value $h{"17"} in sprintf at - line 5.
 Use of uninitialized value $h{"18"} in sprintf at - line 5.
 Use of uninitialized value $h{"19"} in sprintf at - line 5.
 Use of uninitialized value $h{"20"} in sprintf at - line 5.
+########
+# NAME SvPOK && SvLEN==0 should not produce uninit warning
+use warnings 'uninitialized';
+
+$v = int(${qr||}); # sv_2iv on a regexp
+$v = 1.1 *  ${qr||}; # sv_2nv on a regexp
+$v = ${qr||} << 2; # sv_2uv on a regexp
+
+sub TIESCALAR{bless[]}
+sub FETCH {${qr||}}
+tie $t, "";
+$v = 1.1 * $t; # sv_2nv on a tied regexp
+
+EXPECT

diff --git a/t/op/qr.t b/t/op/qr.t
index 29f2773..fb82d73 100644 (file)
--- a/t/op/qr.t
+++ b/t/op/qr.t
@@ -7,7 +7,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan(tests => 20);
+plan(tests => 24);
 
 sub r {
     return qr/Good/;
@@ -67,3 +67,18 @@ like "bar",qr//,'[perl #96230] =~ qr// does not reuse last successful pat';
 $_ = "bar";
 $_ =~ s/${qr||}/baz/;
 is $_, "bazbar", '[perl #96230] s/$qr// does not reuse last pat';
+
+{
+    my $x = 1.1; $x = ${qr//};
+    pass 'no assertion failure when upgrading NV to regexp';
+}
+
+sub TIESCALAR{bless[]}
+sub STORE { is ref\pop, "REGEXP", "stored regexp" }
+tie my $t, "";
+$t = ${qr||};
+ok tied $t, 'tied var is still tied after regexp assignment';
+
+bless \my $t2;
+$t2 = ${qr||};
+is ref \$t2, 'main', 'regexp assignment is not maledictory';

diff --git a/t/op/tie.t b/t/op/tie.t
index 5808a09..ad58af7 100644 (file)
--- a/t/op/tie.t
+++ b/t/op/tie.t
@@ -1302,3 +1302,33 @@ each %$h;
 delete $$h{foo};
 tie %$h, 'l';
 EXPECT
+########
+
+# NAME EXISTS on arrays
+sub TIEARRAY{bless[]};
+sub FETCHSIZE { 50 }
+sub EXISTS { print "does $_[1] exist?\n" }
+tie @a, "";
+exists $a[1];
+exists $a[-1];
+$NEGATIVE_INDICES=1;
+exists $a[-1];
+EXPECT
+does 1 exist?
+does 49 exist?
+does -1 exist?
+########
+
+# Crash when using negative index on array tied to non-object
+sub TIEARRAY{bless[]};
+${\tie @a, ""} = undef;
+eval { $_ = $a[-1] }; print $@;
+eval { $a[-1] = '' }; print $@;
+eval { delete $a[-1] }; print $@;
+eval { exists $a[-1] }; print $@;
+
+EXPECT
+Can't call method "FETCHSIZE" on an undefined value at - line 5.
+Can't call method "FETCHSIZE" on an undefined value at - line 6.
+Can't call method "FETCHSIZE" on an undefined value at - line 7.
+Can't call method "FETCHSIZE" on an undefined value at - line 8.

diff --git a/toke.c b/toke.c
index 45468b3..a382619 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -8974,8 +8974,11 @@ now_ok:
 
     /* Check the eval first */
     if (!PL_in_eval && SvTRUE(ERRSV)) {
-       sv_catpvs(ERRSV, "Propagated");
-       yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
+       STRLEN errlen;
+       const char * errstr;
+       sv_catpvs(ERRSV, "Propagated");
+       errstr = SvPV_const(ERRSV, errlen);
+       yyerror_pvn(errstr, errlen, 0); /* Duplicates the message inside eval */
        (void)POPs;
        res = SvREFCNT_inc_simple(sv);
     }
@@ -11041,7 +11044,6 @@ Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
     SV *msg;
     SV * const where_sv = newSVpvs_flags("", SVs_TEMP);
     int yychar  = PL_parser->yychar;
-    U32 is_utf8 = flags & SVf_UTF8;
 
     PERL_ARGS_ASSERT_YYERROR_PVN;
 
@@ -11102,7 +11104,7 @@ Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
        else
            Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
     }
-    msg = sv_2mortal(newSVpvn_flags(s, len, is_utf8));
+    msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP);
     Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
         OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
     if (context)