X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=gv.c;h=2d4cebc784fbad47c33edc026f77fdbba2a0a493;hb=3387927231e5bf4138a3082ecafb247e03a8061a;hp=d46b25379503920a8bd104f2eeeb0fde8a5353f0;hpb=d5713896ecd1399c9c6c4076514a33eb2880d8c3;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/gv.c b/gv.c
index d46b253..2d4cebc 100644
--- a/gv.c
+++ b/gv.c
@@ -45,15 +45,34 @@ Perl_gv_add_by_type(pTHX_ GV *gv, svtype type)
 {
     SV **where;
 
-    PERL_ARGS_ASSERT_GV_ADD_BY_TYPE;
-
-    if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV)
-	Perl_croak(aTHX_ "Bad symbol for %s", type == SVt_PVAV ? "array" : type == SVt_PVHV ? "hash" : "scalar");
+    if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV) {
+	const char *what;
+	if (type == SVt_PVIO) {
+	    /*
+	     * if it walks like a dirhandle, then let's assume that
+	     * this is a dirhandle.
+	     */
+	    what = PL_op->op_type ==  OP_READDIR ||
+		PL_op->op_type ==  OP_TELLDIR ||
+		PL_op->op_type ==  OP_SEEKDIR ||
+		PL_op->op_type ==  OP_REWINDDIR ||
+		PL_op->op_type ==  OP_CLOSEDIR ?
+		"dirhandle" : "filehandle";
+	    /* diag_listed_as: Bad symbol for filehandle */
+	} else if (type == SVt_PVHV) {
+	    what = "hash";
+	} else {
+	    what = type == SVt_PVAV ? "array" : "scalar";
+	}
+	Perl_croak(aTHX_ "Bad symbol for %s", what);
+    }
 
     if (type == SVt_PVHV) {
 	where = (SV **)&GvHV(gv);
     } else if (type == SVt_PVAV) {
 	where = (SV **)&GvAV(gv);
+    } else if (type == SVt_PVIO) {
+	where = (SV **)&GvIOp(gv);
     } else {
 	where = &GvSV(gv);
     }
@@ -64,34 +83,6 @@ Perl_gv_add_by_type(pTHX_ GV *gv, svtype type)
 }
 
 GV *
-Perl_gv_IOadd(pTHX_ register GV *gv)
-{
-    dVAR;
-
-    if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV) {
-
-        /*
-         * if it walks like a dirhandle, then let's assume that
-         * this is a dirhandle.
-         */
-	const char * const fh =
-			 PL_op->op_type ==  OP_READDIR ||
-                         PL_op->op_type ==  OP_TELLDIR ||
-                         PL_op->op_type ==  OP_SEEKDIR ||
-                         PL_op->op_type ==  OP_REWINDDIR ||
-                         PL_op->op_type ==  OP_CLOSEDIR ?
-                         "dirhandle" : "filehandle";
-	/* diag_listed_as: Bad symbol for filehandle */
-        Perl_croak(aTHX_ "Bad symbol for %s", fh);
-    }
-
-    if (!GvIOp(gv)) {
-	GvIOp(gv) = newIO();
-    }
-    return gv;
-}
-
-GV *
 Perl_gv_fetchfile(pTHX_ const char *name)
 {
     PERL_ARGS_ASSERT_GV_FETCHFILE;
@@ -422,9 +413,8 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
         cstash = gv_stashsv(linear_sv, 0);
 
         if (!cstash) {
-            if (ckWARN(WARN_SYNTAX))
-                Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
-                    SVfARG(linear_sv), hvname);
+	    Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
+			   SVfARG(linear_sv), hvname);
             continue;
         }
 
@@ -738,11 +728,10 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
      * Inheriting AUTOLOAD for non-methods works ... for now.
      */
     if (!method && (GvCVGEN(gv) || GvSTASH(gv) != stash)
-	&& ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)
     )
-	Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
-	  "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
-	     packname, (int)len, name);
+	Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+			 "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
+			 packname, (int)len, name);
 
     if (CvISXSUB(cv)) {
         /* rather than lookup/init $AUTOLOAD here
@@ -864,17 +853,18 @@ Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
     char *tmpbuf;
     HV *stash;
     GV *tmpgv;
+    U32 tmplen = namelen + 2;
 
     PERL_ARGS_ASSERT_GV_STASHPVN;
 
-    if (namelen + 2 <= sizeof smallbuf)
+    if (tmplen <= sizeof smallbuf)
 	tmpbuf = smallbuf;
     else
-	Newx(tmpbuf, namelen + 2, char);
-    Copy(name,tmpbuf,namelen,char);
-    tmpbuf[namelen++] = ':';
-    tmpbuf[namelen++] = ':';
-    tmpgv = gv_fetchpvn_flags(tmpbuf, namelen, flags, SVt_PVHV);
+	Newx(tmpbuf, tmplen, char);
+    Copy(name, tmpbuf, namelen, char);
+    tmpbuf[namelen]   = ':';
+    tmpbuf[namelen+1] = ':';
+    tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
     if (tmpbuf != smallbuf)
 	Safefree(tmpbuf);
     if (!tmpgv)
@@ -1071,12 +1061,17 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 			     (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
 		    {
 			/* diag_listed_as: Variable "%s" is not imported%s */
-			Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
+			Perl_ck_warner_d(
+			    aTHX_ packWARN(WARN_MISC),
+			    "Variable \"%c%s\" is not imported",
 			    sv_type == SVt_PVAV ? '@' :
 			    sv_type == SVt_PVHV ? '%' : '$',
 			    name);
 			if (GvCVu(*gvp))
-			    Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
+			    Perl_ck_warner_d(
+				aTHX_ packWARN(WARN_MISC),
+				"\t(Did you mean &%s instead?)\n", name
+			    );
 			stash = NULL;
 		    }
 		}
@@ -1147,8 +1142,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 
     faking_it = SvOK(gv);
 
-    if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
-	Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
+    if (add & GV_ADDWARN)
+	Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
     gv_init(gv, stash, name, len, add & GV_ADDMULTI);
     gv_init_sv(gv, faking_it ? SVt_PVCV : sv_type);
 
@@ -1306,9 +1301,9 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	/* Names of length 1.  (Or 0. But name is NUL terminated, so that will
 	   be case '\0' in this switch statement (ie a default case)  */
 	switch (*name) {
-	case '&':
-	case '`':
-	case '\'':
+	case '&':		/* $& */
+	case '`':		/* $` */
+	case '\'':		/* $' */
 	    if (
 		sv_type == SVt_PVAV ||
 		sv_type == SVt_PVHV ||
@@ -1319,17 +1314,17 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	    PL_sawampersand = TRUE;
 	    goto magicalize;
 
-	case ':':
+	case ':':		/* $: */
 	    sv_setpv(GvSVn(gv),PL_chopset);
 	    goto magicalize;
 
-	case '?':
+	case '?':		/* $? */
 #ifdef COMPLEX_STATUS
 	    SvUPGRADE(GvSVn(gv), SVt_PVLV);
 #endif
 	    goto magicalize;
 
-	case '!':
+	case '!':		/* $! */
 	    GvMULTI_on(gv);
 	    /* If %! has been used, automatically load Errno.pm. */
 
@@ -1340,8 +1335,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 		require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
 
 	    break;
-	case '-':
-	case '+':
+	case '-':		/* $- */
+	case '+':		/* $+ */
 	GvMULTI_on(gv); /* no used once warnings here */
         {
             AV* const av = GvAVn(gv);
@@ -1358,13 +1353,13 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 
             break;
 	}
-	case '*':
-	case '#':
-	    if (sv_type == SVt_PV && ckWARN2_d(WARN_DEPRECATED, WARN_SYNTAX))
-		Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
-			    "$%c is no longer supported", *name);
+	case '*':		/* $* */
+	case '#':		/* $# */
+	    if (sv_type == SVt_PV)
+		Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
+				 "$%c is no longer supported", *name);
 	    break;
-	case '|':
+	case '|':		/* $| */
 	    sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
 	    goto magicalize;
 
@@ -1378,28 +1373,28 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	ro_magicalize:
 	    SvREADONLY_on(GvSVn(gv));
 	    /* FALL THROUGH */
-	case '0':
-	case '1':
-	case '2':
-	case '3':
-	case '4':
-	case '5':
-	case '6':
-	case '7':
-	case '8':
-	case '9':
-	case '[':
-	case '^':
-	case '~':
-	case '=':
-	case '%':
-	case '.':
-	case '(':
-	case ')':
-	case '<':
-	case '>':
-	case '\\':
-	case '/':
+	case '0':		/* $0 */
+	case '1':		/* $1 */
+	case '2':		/* $2 */
+	case '3':		/* $3 */
+	case '4':		/* $4 */
+	case '5':		/* $5 */
+	case '6':		/* $6 */
+	case '7':		/* $7 */
+	case '8':		/* $8 */
+	case '9':		/* $9 */
+	case '[':		/* $[ */
+	case '^':		/* $^ */
+	case '~':		/* $~ */
+	case '=':		/* $= */
+	case '%':		/* $% */
+	case '.':		/* $. */
+	case '(':		/* $( */
+	case ')':		/* $) */
+	case '<':		/* $< */
+	case '>':		/* $> */
+	case '\\':		/* $\ */
+	case '/':		/* $/ */
 	case '\001':	/* $^A */
 	case '\003':	/* $^C */
 	case '\004':	/* $^D */
@@ -1419,10 +1414,10 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	    sv_setpvs(GvSVn(gv),"\f");
 	    PL_formfeed = GvSVn(gv);
 	    break;
-	case ';':
+	case ';':		/* $; */
 	    sv_setpvs(GvSVn(gv),"\034");
 	    break;
-	case ']':
+	case ']':		/* $] */
 	{
 	    SV * const sv = GvSVn(gv);
 	    if (!sv_derived_from(PL_patchlevel, "version"))
@@ -1478,34 +1473,13 @@ Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
 void
 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
 {
-    const GV * const egv = GvEGV(gv);
+    const GV * const egv = GvEGVx(gv);
 
     PERL_ARGS_ASSERT_GV_EFULLNAME4;
 
     gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
 }
 
-IO *
-Perl_newIO(pTHX)
-{
-    dVAR;
-    GV *iogv;
-    IO * const io = MUTABLE_IO(newSV_type(SVt_PVIO));
-    /* This used to read SvREFCNT(io) = 1;
-       It's not clear why the reference count needed an explicit reset. NWC
-    */
-    assert (SvREFCNT(io) == 1);
-    SvOBJECT_on(io);
-    /* Clear the stashcache because a new IO could overrule a package name */
-    hv_clear(PL_stashcache);
-    iogv = gv_fetchpvs("FileHandle::", 0, SVt_PVHV);
-    /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
-    if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
-      iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV);
-    SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
-    return io;
-}
-
 void
 Perl_gv_check(pTHX_ const HV *stash)
 {
@@ -1590,10 +1564,9 @@ Perl_gp_free(pTHX_ GV *gv)
     if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
 	return;
     if (gp->gp_refcnt == 0) {
-	if (ckWARN_d(WARN_INTERNAL))
-	    Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
-			"Attempt to free unreferenced glob pointers"
-                        pTHX__FORMAT pTHX__VALUE);
+	Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
+			 "Attempt to free unreferenced glob pointers"
+			 pTHX__FORMAT pTHX__VALUE);
         return;
     }
     if (--gp->gp_refcnt > 0) {
@@ -1845,6 +1818,99 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id)
 }
 
 
+/* Implement tryAMAGICun_MG macro.
+   Do get magic, then see if the stack arg is overloaded and if so call it.
+   Flags:
+	AMGf_set     return the arg using SETs rather than assigning to
+		     the targ
+	AMGf_numeric apply sv_2num to the stack arg.
+*/
+
+bool
+Perl_try_amagic_un(pTHX_ int method, int flags) {
+    dVAR;
+    dSP;
+    SV* tmpsv;
+    SV* const arg = TOPs;
+
+    SvGETMAGIC(arg);
+
+    if (SvAMAGIC(arg) && (tmpsv = AMG_CALLun_var(arg,method))) {
+	if (flags & AMGf_set) {
+	    SETs(tmpsv);
+	}
+	else {
+	    dTARGET;
+	    if (SvPADMY(TARG)) {
+		sv_setsv(TARG, tmpsv);
+		SETTARG;
+	    }
+	    else
+		SETs(tmpsv);
+	}
+	PUTBACK;
+	return TRUE;
+    }
+
+    if ((flags & AMGf_numeric) && SvROK(arg))
+	*sp = sv_2num(arg);
+    return FALSE;
+}
+
+
+/* Implement tryAMAGICbin_MG macro.
+   Do get magic, then see if the two stack args are overloaded and if so
+   call it.
+   Flags:
+	AMGf_set     return the arg using SETs rather than assigning to
+		     the targ
+	AMGf_assign  op may be called as mutator (eg +=)
+	AMGf_numeric apply sv_2num to the stack arg.
+*/
+
+bool
+Perl_try_amagic_bin(pTHX_ int method, int flags) {
+    dVAR;
+    dSP;
+    SV* const left = TOPm1s;
+    SV* const right = TOPs;
+
+    SvGETMAGIC(left);
+    if (left != right)
+	SvGETMAGIC(right);
+
+    if (SvAMAGIC(left) || SvAMAGIC(right)) {
+	SV * const tmpsv = amagic_call(left, right, method,
+		    ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
+	if (tmpsv) {
+	    if (flags & AMGf_set) {
+		(void)POPs;
+		SETs(tmpsv);
+	    }
+	    else {
+		dATARGET;
+		(void)POPs;
+		if (opASSIGN || SvPADMY(TARG)) {
+		    sv_setsv(TARG, tmpsv);
+		    SETTARG;
+		}
+		else
+		    SETs(tmpsv);
+	    }
+	    PUTBACK;
+	    return TRUE;
+	}
+    }
+    if (flags & AMGf_numeric) {
+	if (SvROK(left))
+	    *(sp-1) = sv_2num(left);
+	if (SvROK(right))
+	    *sp     = sv_2num(right);
+    }
+    return FALSE;
+}
+
+
 SV*
 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
 {
@@ -1934,7 +2000,8 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
            (void)((cv = cvp[off=bool__amg])
                   || (cv = cvp[off=numer_amg])
                   || (cv = cvp[off=string_amg]));
-           postpr = 1;
+           if (cv)
+               postpr = 1;
            break;
 	 case copy_amg:
 	   {
@@ -1995,6 +2062,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
 	 case int_amg:
 	 case iter_amg:			/* XXXX Eventually should do to_gv. */
 	 case ftest_amg:		/* XXXX Eventually should do to_gv. */
+	 case regexp_amg:
 	     /* FAIL safe */
 	     return NULL;	/* Delegate operation to standard mechanisms. */
 	     break;
@@ -2038,35 +2106,24 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
 	 case ge_amg:
 	 case eq_amg:
 	 case ne_amg:
-	   postpr = 1; off=ncmp_amg; break;
+             off = ncmp_amg;
+             break;
 	 case slt_amg:
 	 case sle_amg:
 	 case sgt_amg:
 	 case sge_amg:
 	 case seq_amg:
 	 case sne_amg:
-	   postpr = 1; off=scmp_amg; break;
+             off = scmp_amg;
+             break;
 	 }
-      if (off != -1) cv = cvp[off];
-      if (!cv) {
-	goto not_found;
-      }
+      if ((off != -1) && (cv = cvp[off]))
+          postpr = 1;
+      else
+          goto not_found;
     } else {
     not_found:			/* No method found, either report or croak */
       switch (method) {
-	 case lt_amg:
-	 case le_amg:
-	 case gt_amg:
-	 case ge_amg:
-	 case eq_amg:
-	 case ne_amg:
-	 case slt_amg:
-	 case sle_amg:
-	 case sgt_amg:
-	 case sge_amg:
-	 case seq_amg:
-	 case sne_amg:
-	   postpr = 0; break;
 	 case to_sv_amg:
 	 case to_av_amg:
 	 case to_hv_amg:
@@ -2156,7 +2213,10 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
   if (( (method + assignshift == off)
 	&& (assign || (method == inc_amg) || (method == dec_amg)))
       || force_cpy)
+  {
     RvDEEPCP(left);
+  }
+
   {
     dSP;
     BINOP myop;
@@ -2403,6 +2463,66 @@ Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
 }
 
 /*
+=for apidoc gv_try_downgrade
+
+If the typeglob C<gv> can be expressed more succinctly, by having
+something other than a real GV in its place in the stash, replace it
+with the optimised form.  Basic requirements for this are that C<gv>
+is a real typeglob, is sufficiently ordinary, and is only referenced
+from its package.  This function is meant to be used when a GV has been
+looked up in part to see what was there, causing upgrading, but based
+on what was found it turns out that the real GV isn't required after all.
+
+If C<gv> is a completely empty typeglob, it is deleted from the stash.
+
+If C<gv> is a typeglob containing only a sufficiently-ordinary constant
+sub, the typeglob is replaced with a scalar-reference placeholder that
+more compactly represents the same thing.
+
+=cut
+*/
+
+void
+Perl_gv_try_downgrade(pTHX_ GV *gv)
+{
+    HV *stash;
+    CV *cv;
+    HEK *namehek;
+    SV **gvp;
+    PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
+    if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
+	    !SvOBJECT(gv) && !SvMAGICAL(gv) && !SvREADONLY(gv) &&
+	    isGV_with_GP(gv) && GvGP(gv) &&
+	    !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
+	    !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
+	    GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
+	return;
+    cv = GvCV(gv);
+    if (!cv) {
+	HEK *gvnhek = GvNAME_HEK(gv);
+	(void)hv_delete(stash, HEK_KEY(gvnhek),
+	    HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD);
+    } else if (GvMULTI(gv) && cv &&
+	    !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
+	    CvSTASH(cv) == stash && CvGV(cv) == gv &&
+	    CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
+	    !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
+	    (namehek = GvNAME_HEK(gv)) &&
+	    (gvp = hv_fetch(stash, HEK_KEY(namehek),
+			HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
+	    *gvp == (SV*)gv) {
+	SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
+	SvREFCNT(gv) = 0;
+	sv_clear((SV*)gv);
+	SvREFCNT(gv) = 1;
+	SvFLAGS(gv) = SVt_IV|SVf_ROK;
+	SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
+				STRUCT_OFFSET(XPVIV, xiv_iv));
+	SvRV_set(gv, value);
+    }
+}
+
+/*
  * Local variables:
  * c-indentation-style: bsd
  * c-basic-offset: 4