lib/utf8.pm: Fix pod verbatim line wraps

[perl5.git] / gv.c

diff --git a/gv.c b/gv.c
index 6d36a1f..2325194 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;
-    SV *opnumsv;
     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) {
+#ifdef DEBUGGING
+        CV *orig_cv = cv;
+#endif
        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(
@@ -547,21 +551,25 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
                     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;
     }
-    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;
 }
 
@@ -1500,7 +1508,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 
     if (!stash) {
     no_stash:
-       if (len && isIDFIRST_lazy(name)) {
+       if (len && isIDFIRST_lazy_if(name, is_utf8)) {
            bool global = FALSE;
 
            switch (len) {
@@ -1588,15 +1596,17 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
     /* By this point we should have a stash and a name */
 
     if (!stash) {
-       if (add) {
+       if (add && !PL_in_clean_all) {
+           SV * const namesv = newSVpvn_flags(name, len, is_utf8);
            SV * const err = Perl_mess(aTHX_
                 "Global symbol \"%s%"SVf"\" requires explicit package name",
                 (sv_type == SVt_PV ? "$"
                  : sv_type == SVt_PVAV ? "@"
                  : sv_type == SVt_PVHV ? "%"
-                 : ""), SVfARG(newSVpvn_flags(name, len, SVs_TEMP | is_utf8)));
+                 : ""), SVfARG(namesv));
            GV *gv;
-           if (USE_UTF8_IN_NAMES)
+           SvREFCNT_dec_NN(namesv);
+           if (is_utf8)
                SvUTF8_on(err);
            qerror(err);
            gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
@@ -1626,13 +1636,24 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
        if (add) {
            GvMULTI_on(gv);
            gv_init_svtype(gv, sv_type);
+            /* You reach this path once the typeglob has already been created,
+               either by the same or a different sigil.  If this path didn't
+               exist, then (say) referencing $! first, and %! second would
+               mean that %! was not handled correctly.  */
            if (len == 1 && stash == PL_defstash) {
              if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
                if (*name == '!')
                    require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
                else if (*name == '-' || *name == '+')
                    require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
-             }
+              } else if (sv_type == SVt_PV) {
+                  if (*name == '*' || *name == '#') {
+                      /* diag_listed_as: $* is no longer supported */
+                      Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,
+                                                       WARN_SYNTAX),
+                                       "$%c is no longer supported", *name);
+                  }
+              }
              if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
                 switch (*name) {
                case '[':
@@ -2734,16 +2755,9 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
               && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
                          ? (amtp = (AMT*)mg->mg_ptr)->table
                          : NULL))
-              && ((cv = cvp[off=method+assignshift])
-                  || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
-                                                                  * usual method */
-                      (
-#ifdef DEBUGGING
-                       fl = 1,
-#endif
-                       cv = cvp[off=method])))) { /* Method for right
-                                                   * argument found */
-       lr=1;
+              && (cv = cvp[off=method])) { /* Method for right
+                                            * argument found */
+      lr=1;
     } else if (((cvp && amtp->fallback > AMGfallNEVER)
                 || (ocvp && oamtp->fallback > AMGfallNEVER))
               && !(flags & AMGf_unary)) {