[perl #109264] ->method(my(...)) forcing lvalue cx

[perl5.git] / op.c

diff --git a/op.c b/op.c
index 12f0cbc..09f45d0 100644 (file)
--- a/op.c
+++ b/op.c
@@ -1167,14 +1167,6 @@ Perl_scalarvoid(pTHX_ OP *o)
            no_bareword_allowed(o);
        else {
            if (ckWARN(WARN_VOID)) {
-               if (SvOK(sv)) {
-                   SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
-                               "a constant (%"SVf")", sv));
-                   useless = SvPV_nolen(msv);
-                    useless_is_utf8 = SvUTF8(msv);
-               }
-               else
-                   useless = "a constant (undef)";
                /* don't warn on optimised away booleans, eg 
                 * use constant Foo, 5; Foo || print; */
                if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
@@ -1196,7 +1188,24 @@ Perl_scalarvoid(pTHX_ OP *o)
                        strnEQ(maybe_macro, "ds", 2) ||
                        strnEQ(maybe_macro, "ig", 2))
                            useless = NULL;
+                   else {
+                       SV * const dsv = newSVpvs("");
+                       SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
+                                   "a constant (%s)",
+                                   pv_pretty(dsv, maybe_macro, SvCUR(sv), 32, NULL, NULL,
+                                           PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_NOCLEAR | PERL_PV_ESCAPE_UNI_DETECT )));
+                       SvREFCNT_dec(dsv);
+                       useless = SvPV_nolen(msv);
+                       useless_is_utf8 = SvUTF8(msv);
+                   }
                }
+               else if (SvOK(sv)) {
+                   SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
+                               "a constant (%"SVf")", sv));
+                   useless = SvPV_nolen(msv);
+               }
+               else
+                   useless = "a constant (undef)";
            }
        }
        op_null(o);             /* don't execute or even remember it */
@@ -2393,6 +2402,7 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
         OP *kid;
        for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
            my_kid(kid, attrs, imopsp);
+       return o;
     } else if (type == OP_UNDEF
 #ifdef PERL_MAD
               || type == OP_STUB
@@ -2535,7 +2545,9 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
           && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
               ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
               : NULL
-        : varname(NULL, isary ? '@' : '%', left->op_targ, NULL, 0, 1);
+        : varname(
+           (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1
+          );
       if (name)
        Perl_warner(aTHX_ packWARN(WARN_MISC),
              "Applying %s to %"SVf" will act on scalar(%"SVf")",
@@ -2934,7 +2946,7 @@ S_fold_constants(pTHX_ register OP *o)
     case OP_SCMP:
     case OP_SPRINTF:
        /* XXX what about the numeric ops? */
-       if (PL_hints & HINT_LOCALE)
+       if (IN_LOCALE_COMPILETIME)
            goto nope;
        break;
     }
@@ -4097,10 +4109,13 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags)
 
     if (PL_hints & HINT_RE_TAINT)
        pmop->op_pmflags |= PMf_RETAINT;
-    if (PL_hints & HINT_LOCALE) {
+    if (IN_LOCALE_COMPILETIME) {
        set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
     }
-    else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
+    else if ((! (PL_hints & HINT_BYTES))
+                /* Both UNI_8_BIT and locale :not_characters imply Unicode */
+            && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS)))
+    {
        set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
     }
     if (PL_hints & HINT_RE_FLAGS) {
@@ -6440,6 +6455,13 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 CV *
 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 {
+    return newATTRSUB_flags(floor, o, proto, attrs, block, 0);
+}
+
+CV *
+Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
+                           OP *block, U32 flags)
+{
     dVAR;
     GV *gv;
     const char *ps;
@@ -6457,9 +6479,11 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
           || PL_madskills)
        ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
     STRLEN namlen = 0;
-    const char * const name = o ? SvPV_const(cSVOPo->op_sv, namlen) : NULL;
+    const bool o_is_gv = flags & 1;
+    const char * const name =
+        o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
     bool has_name;
-    bool name_is_utf8 = o ? (SvUTF8(cSVOPo->op_sv) ? 1 : 0) : 0;
+    bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
 
     if (proto) {
        assert(proto->op_type == OP_CONST);
@@ -6469,10 +6493,12 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
     else
        ps = NULL;
 
-    if (name) {
-       gv = isGV(cSVOPo->op_sv)
-             ? (GV *)cSVOPo->op_sv
-             : gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
+    if (o_is_gv) {
+       gv = (GV*)o;
+       o = NULL;
+       has_name = TRUE;
+    } else if (name) {
+       gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
        has_name = TRUE;
     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
        SV * const sv = sv_newmortal();
@@ -7725,6 +7751,11 @@ Perl_ck_ftst(pTHX_ OP *o)
                && kidtype != OP_STAT && kidtype != OP_LSTAT) {
            o->op_private |= OPpFT_STACKED;
            kid->op_private |= OPpFT_STACKING;
+           if (kidtype == OP_FTTTY && (
+                  !(kid->op_private & OPpFT_STACKED)
+               || kid->op_private & OPpFT_AFTER_t
+              ))
+               o->op_private |= OPpFT_AFTER_t;
        }
     }
     else {
@@ -9115,7 +9146,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
                continue;
            case '_':
                /* _ must be at the end */
-               if (proto[1] && proto[1] != ';')
+               if (proto[1] && !strchr(";@%", proto[1]))
                    goto oops;
            case '$':
                proto++;
@@ -9720,7 +9751,8 @@ Perl_ck_length(pTHX_ OP *o)
                 case OP_PADHV:
                 case OP_PADAV:
                     name = varname(
-                        NULL, hash ? '%' : '@', kid->op_targ, NULL, 0, 1
+                        (GV *)PL_compcv, hash ? '%' : '@', kid->op_targ,
+                        NULL, 0, 1
                     );
                     break;
                 case OP_RV2HV: