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
Revert "UTF8f"
[perl5.git] / gv.c
diff --git a/gv.c b/gv.c
index 7e954d8..87e94b0 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -450,7 +450,6 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
     static const char file[] = __FILE__;
     CV *cv, *oldcompcv = NULL;
     int opnum = 0;
     static const char file[] = __FILE__;
     CV *cv, *oldcompcv = NULL;
     int opnum = 0;
-    SV *opnumsv;
     bool ampable = TRUE; /* &{}-able */
     COP *oldcurcop = NULL;
     yy_parser *oldparser = NULL;
     bool ampable = TRUE; /* &{}-able */
     COP *oldcurcop = NULL;
     yy_parser *oldparser = NULL;
@@ -536,8 +535,13 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
     if (stash)
        (void)hv_store(stash,name,len,(SV *)gv,0);
     if (ampable) {
     if (stash)
        (void)hv_store(stash,name,len,(SV *)gv,0);
     if (ampable) {
+#ifdef DEBUGGING
+        CV *orig_cv = cv;
+#endif
        CvLVALUE_on(cv);
        CvLVALUE_on(cv);
-       newATTRSUB_flags(
+        /* newATTRSUB will free the CV and return NULL if we're still
+           compiling after a syntax error */
+       if ((cv = newATTRSUB_flags(
                   oldsavestack_ix, (OP *)gv,
                   NULL,NULL,
                   coresub_op(
                   oldsavestack_ix, (OP *)gv,
                   NULL,NULL,
                   coresub_op(
@@ -547,21 +551,25 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
                     code, opnum
                   ),
                   1
                     code, opnum
                   ),
                   1
-       );
-       assert(GvCV(gv) == cv);
-       if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS
-        && opnum != OP_UNDEF)
-           CvLVALUE_off(cv); /* Now *that* was a neat trick. */
+               )) != NULL) {
+            assert(GvCV(gv) == orig_cv);
+            if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS
+                && opnum != OP_UNDEF)
+                CvLVALUE_off(cv); /* Now *that* was a neat trick. */
+        }
        LEAVE;
        PL_parser = oldparser;
        PL_curcop = oldcurcop;
        PL_compcv = oldcompcv;
     }
        LEAVE;
        PL_parser = oldparser;
        PL_curcop = oldcurcop;
        PL_compcv = oldcompcv;
     }
-    opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL;
-    cv_set_call_checker(
-       cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv
-    );
-    SvREFCNT_dec(opnumsv);
+    if (cv) {
+        SV *opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL;
+        cv_set_call_checker(
+          cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv
+        );
+        SvREFCNT_dec(opnumsv);
+    }
+
     return gv;
 }
 
     return gv;
 }
 
@@ -1018,10 +1026,9 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
                        return gv;
                }
                Perl_croak(aTHX_
                        return gv;
                }
                Perl_croak(aTHX_
-                          "Can't locate object method \"%"SVf
+                          "Can't locate object method \"%"UTF8f
                           "\" via package \"%"HEKf"\"",
                           "\" via package \"%"HEKf"\"",
-                                   SVfARG(newSVpvn_flags(name, nend - name,
-                                           SVs_TEMP | is_utf8)),
+                                   is_utf8, nend - name, name,
                                     HEKfARG(HvNAME_HEK(stash)));
            }
            else {
                                     HEKfARG(HvNAME_HEK(stash)));
            }
            else {
@@ -1031,7 +1038,7 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
                    packnamesv = newSVpvn_flags(origname, nsplit - origname,
                                                     SVs_TEMP | is_utf8);
                } else {
                    packnamesv = newSVpvn_flags(origname, nsplit - origname,
                                                     SVs_TEMP | is_utf8);
                } else {
-                   packnamesv = sv_2mortal(newSVsv(error_report));
+                   packnamesv = error_report;
                }
 
                Perl_croak(aTHX_
                }
 
                Perl_croak(aTHX_
@@ -1130,9 +1137,10 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
      && (GvCVGEN(gv) || GvSTASH(gv) != stash)
     )
        Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
      && (GvCVGEN(gv) || GvSTASH(gv) != stash)
     )
        Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
-                        "Use of inherited AUTOLOAD for non-method %"SVf"::%"SVf"() is deprecated",
+                        "Use of inherited AUTOLOAD for non-method %"SVf
+                        "::%"UTF8f"() is deprecated",
                         SVfARG(packname),
                         SVfARG(packname),
-                         SVfARG(newSVpvn_flags(name, len, SVs_TEMP | is_utf8)));
+                         is_utf8, len, name);
 
     if (CvISXSUB(cv)) {
         /* Instead of forcing the XSUB do another lookup for $AUTOLOAD
 
     if (CvISXSUB(cv)) {
         /* Instead of forcing the XSUB do another lookup for $AUTOLOAD
@@ -1402,7 +1410,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
     const char *name = nambeg;
     GV *gv = NULL;
     GV**gvp;
     const char *name = nambeg;
     GV *gv = NULL;
     GV**gvp;
-    I32 len;
+    STRLEN len;
     const char *name_cursor;
     HV *stash = NULL;
     const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
     const char *name_cursor;
     HV *stash = NULL;
     const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
@@ -1561,18 +1569,18 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                             (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
                             (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
                    {
                             (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
                             (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
                    {
-                        SV* namesv = newSVpvn_flags(name, len, SVs_TEMP | is_utf8);
                        /* diag_listed_as: Variable "%s" is not imported%s */
                        Perl_ck_warner_d(
                            aTHX_ packWARN(WARN_MISC),
                        /* diag_listed_as: Variable "%s" is not imported%s */
                        Perl_ck_warner_d(
                            aTHX_ packWARN(WARN_MISC),
-                           "Variable \"%c%"SVf"\" is not imported",
+                           "Variable \"%c%"UTF8f"\" is not imported",
                            sv_type == SVt_PVAV ? '@' :
                            sv_type == SVt_PVHV ? '%' : '$',
                            sv_type == SVt_PVAV ? '@' :
                            sv_type == SVt_PVHV ? '%' : '$',
-                           SVfARG(namesv));
+                           is_utf8, len, name);
                        if (GvCVu(*gvp))
                            Perl_ck_warner_d(
                                aTHX_ packWARN(WARN_MISC),
                        if (GvCVu(*gvp))
                            Perl_ck_warner_d(
                                aTHX_ packWARN(WARN_MISC),
-                               "\t(Did you mean &%"SVf" instead?)\n", SVfARG(namesv)
+                               "\t(Did you mean &%"UTF8f" instead?)\n",
+                               is_utf8, len, name
                            );
                        stash = NULL;
                    }
                            );
                        stash = NULL;
                    }
@@ -1589,15 +1597,14 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 
     if (!stash) {
        if (add && !PL_in_clean_all) {
 
     if (!stash) {
        if (add && !PL_in_clean_all) {
-           SV * const namesv = newSVpvn_flags(name, len, is_utf8);
            SV * const err = Perl_mess(aTHX_
            SV * const err = Perl_mess(aTHX_
-                "Global symbol \"%s%"SVf"\" requires explicit package name",
+                "Global symbol \"%s%"UTF8f
+                "\" requires explicit package name",
                 (sv_type == SVt_PV ? "$"
                  : sv_type == SVt_PVAV ? "@"
                  : sv_type == SVt_PVHV ? "%"
                 (sv_type == SVt_PV ? "$"
                  : sv_type == SVt_PVAV ? "@"
                  : sv_type == SVt_PVHV ? "%"
-                 : ""), SVfARG(namesv));
+                 : ""), is_utf8, len, name);
            GV *gv;
            GV *gv;
-           SvREFCNT_dec_NN(namesv);
            if (is_utf8)
                SvUTF8_on(err);
            qerror(err);
            if (is_utf8)
                SvUTF8_on(err);
            qerror(err);
@@ -1639,14 +1646,11 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                else if (*name == '-' || *name == '+')
                    require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
               } else if (sv_type == SVt_PV) {
                else if (*name == '-' || *name == '+')
                    require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
               } else if (sv_type == SVt_PV) {
-                  if (*name == '*') {
-                      Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,
-                                                       WARN_SYNTAX),
-                                       "$* is no longer supported, and will become a syntax error");
-                  } else if (*name == '#') {
+                  if (*name == '*' || *name == '#') {
+                      /* diag_listed_as: $* is no longer supported */
                       Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,
                                                        WARN_SYNTAX),
                       Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,
                                                        WARN_SYNTAX),
-                                       "$# is no longer supported");
+                                       "$%c is no longer supported", *name);
                   }
               }
              if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
                   }
               }
              if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
@@ -1695,8 +1699,9 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
     faking_it = SvOK(gv);
 
     if (add & GV_ADDWARN)
     faking_it = SvOK(gv);
 
     if (add & GV_ADDWARN)
-       Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %"SVf" unexpectedly",
-                SVfARG(newSVpvn_flags(nambeg, name_end-nambeg, SVs_TEMP | is_utf8 )));
+       Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
+               "Had to create %"UTF8f" unexpectedly",
+                is_utf8, name_end-nambeg, nambeg);
     gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
 
     if ( isIDFIRST_lazy_if(name, is_utf8)
     gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
 
     if ( isIDFIRST_lazy_if(name, is_utf8)
@@ -1937,14 +1942,11 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
             break;
        }
        case '*':               /* $* */
             break;
        }
        case '*':               /* $* */
-           if (sv_type == SVt_PV)
-               Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
-                                "$* is no longer supported, and will become a syntax error");
-           break;
        case '#':               /* $# */
            if (sv_type == SVt_PV)
        case '#':               /* $# */
            if (sv_type == SVt_PV)
+               /* diag_listed_as: $* is no longer supported */
                Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
                Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
-                                "$# is no longer supported");
+                                "$%c is no longer supported", *name);
            break;
        case '\010':    /* $^H */
            {
            break;
        case '\010':    /* $^H */
            {
@@ -2122,10 +2124,10 @@ Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
 {
     dVAR;
     PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
 {
     dVAR;
     PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
+    assert(!(flags & ~SVf_UTF8));
 
 
-    return gv_fetchpv(Perl_form(aTHX_ "%"SVf"::_GEN_%ld",
-                                    SVfARG(newSVpvn_flags(pack, strlen(pack),
-                                            SVs_TEMP | flags)),
+    return gv_fetchpv(Perl_form(aTHX_ "%"UTF8f"::_GEN_%ld",
+                                    flags, strlen(pack), pack,
                                 (long)PL_gensym++),
                       GV_ADD, SVt_PVGV);
 }
                                 (long)PL_gensym++),
                       GV_ADD, SVt_PVGV);
 }
@@ -3172,10 +3174,11 @@ Perl_gv_try_downgrade(pTHX_ GV *gv)
                        HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
            *gvp == (SV*)gv) {
        SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
                        HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
            *gvp == (SV*)gv) {
        SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
+       const bool imported = !!GvIMPORTED_CV(gv);
        SvREFCNT(gv) = 0;
        sv_clear((SV*)gv);
        SvREFCNT(gv) = 1;
        SvREFCNT(gv) = 0;
        sv_clear((SV*)gv);
        SvREFCNT(gv) = 1;
-       SvFLAGS(gv) = SVt_IV|SVf_ROK;
+       SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported;
        SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
                                STRUCT_OFFSET(XPVIV, xiv_iv));
        SvRV_set(gv, value);
        SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
                                STRUCT_OFFSET(XPVIV, xiv_iv));
        SvRV_set(gv, value);
Unnamed repository; edit this file 'description' to name the repository.