X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/e7881358a40c0c95ec67889ca179bd8ca552060a..291cc134f6d2f9b4f4954ba0d93c2605547c5f92:/gv.c

diff --git a/gv.c b/gv.c
index 6d36a1f..2325194 100644
--- 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)) {