This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
in Carp, avoid vivifying utf8 stash on Perl 5.6
[perl5.git] / op.c
diff --git a/op.c b/op.c
index 709ef91..a9296f3 100644 (file)
--- a/op.c
+++ b/op.c
@@ -837,7 +837,8 @@ Perl_op_contextualize(pTHX_ OP *o, I32 context)
        case G_ARRAY:  return list(o);
        case G_VOID:   return scalarvoid(o);
        default:
-           Perl_croak(aTHX_ "panic: op_contextualize bad context");
+           Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
+                      (long) context);
            return o;
     }
 }
@@ -1166,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)
@@ -1195,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 */
@@ -2392,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
@@ -2534,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")",
@@ -2933,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;
     }
@@ -4096,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) {
@@ -6439,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;
@@ -6456,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);
@@ -6468,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();
@@ -7724,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 {
@@ -8149,7 +8181,7 @@ Perl_ck_grep(pTHX_ OP *o)
        return o;
     kid = cLISTOPo->op_first->op_sibling;
     if (kid->op_type != OP_NULL)
-       Perl_croak(aTHX_ "panic: ck_grep");
+       Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
     kid = kUNOP->op_first;
 
     if (!gwop)
@@ -8215,11 +8247,6 @@ Perl_ck_defined(pTHX_ OP *o)             /* 19990527 MJD */
     if ((o->op_flags & OPf_KIDS)) {
        switch (cUNOPo->op_first->op_type) {
        case OP_RV2AV:
-           /* This is needed for
-              if (defined %stash::)
-              to work.   Do not break Tk.
-              */
-           break;                      /* Globals via GV can be undef */
        case OP_PADAV:
        case OP_AASSIGN:                /* Is this a good idea? */
            Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
@@ -8862,7 +8889,7 @@ Perl_ck_split(pTHX_ OP *o)
 
     kid = cLISTOPo->op_first;
     if (kid->op_type != OP_NULL)
-       Perl_croak(aTHX_ "panic: ck_split");
+       Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
     kid = kid->op_sibling;
     op_free(cLISTOPo->op_first);
     if (kid)
@@ -9086,7 +9113,8 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
     const char *e = NULL;
     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
-       Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto");
+       Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
+                  "flags=%lx", (unsigned long) SvFLAGS(protosv));
     if (SvTYPE(protosv) == SVt_PVCV)
         proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
     else proto = SvPV(protosv, proto_len);
@@ -9118,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++;
@@ -9723,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:
@@ -9811,7 +9840,7 @@ S_inplace_aassign(pTHX_ OP *o) {
        return;
 
     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
-    oright = cUNOPx(modop)->op_first->op_sibling;
+    if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return;
 
     if (modop->op_flags & OPf_STACKED) {
        /* skip sort subroutine/block */
Unnamed repository; edit this file 'description' to name the repository.