X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=gv.c;h=418e08c7d276ef60d783faba5493c3e784af8329;hb=4df4e287246babaf287cf6336ca862ceeead8e46;hp=823102c7b86a018f2b7dc4cb460ee1dc1eaedb21;hpb=890ce7af62ab97fd07b5b49562f13e94286469fb;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/gv.c b/gv.c
index 823102c..418e08c 100644
--- a/gv.c
+++ b/gv.c
@@ -122,6 +122,25 @@ Perl_gv_fetchfile(pTHX_ const char *name)
     return gv;
 }
 
+/*
+=for apidoc gv_const_sv
+
+If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for
+inlining, or C<gv> is a placeholder reference that would be promoted to such
+a typeglob, then returns the value returned by the sub.  Otherwise, returns
+NULL.
+
+=cut
+*/
+
+SV *
+Perl_gv_const_sv(pTHX_ GV *gv)
+{
+    if (SvTYPE(gv) == SVt_PVGV)
+	return cv_const_sv(GvCVu(gv));
+    return SvROK(gv) ? SvRV(gv) : NULL;
+}
+
 void
 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
 {
@@ -129,6 +148,24 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
     register GP *gp;
     const bool doproto = SvTYPE(gv) > SVt_NULL;
     const char * const proto = (doproto && SvPOK(gv)) ? SvPVX_const(gv) : NULL;
+    SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
+
+    assert (!(proto && has_constant));
+
+    if (has_constant) {
+	/* The constant has to be a simple scalar type.  */
+	switch (SvTYPE(has_constant)) {
+	case SVt_PVAV:
+	case SVt_PVHV:
+	case SVt_PVCV:
+	case SVt_PVFM:
+	case SVt_PVIO:
+            Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
+		       sv_reftype(has_constant, 0));
+	}
+	SvRV_set(gv, NULL);
+	SvROK_off(gv);
+    }
 
     sv_upgrade((SV*)gv, SVt_PVGV);
     if (SvLEN(gv)) {
@@ -163,9 +200,14 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
     if (doproto) {			/* Replicate part of newSUB here. */
 	SvIOK_off(gv);
 	ENTER;
-	/* XXX unsafe for threads if eval_owner isn't held */
-	start_subparse(0,0);		/* Create CV in compcv. */
-	GvCV(gv) = PL_compcv;
+	if (has_constant) {
+	    /* newCONSTSUB takes ownership of the reference from us.  */
+	    GvCV(gv) = newCONSTSUB(stash, name, has_constant);
+	} else {
+	    /* XXX unsafe for threads if eval_owner isn't held */
+	    (void) start_subparse(0,0);	/* Create empty CV in compcv. */
+	    GvCV(gv) = PL_compcv;
+	}
 	LEAVE;
 
 	PL_sub_generation++;
@@ -273,7 +315,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
     }
 
     gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
-    av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav;
+    av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : NULL;
 
     /* create and re-create @.*::SUPER::ISA on demand */
     if (!av || !SvMAGIC(av)) {
@@ -302,8 +344,8 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 	/* NOTE: No support for tied ISA */
 	I32 items = AvFILLp(av) + 1;
 	while (items--) {
-	    SV* sv = *svp++;
-	    HV* basestash = gv_stashsv(sv, FALSE);
+	    SV* const sv = *svp++;
+	    HV* const basestash = gv_stashsv(sv, FALSE);
 	    if (!basestash) {
 		if (ckWARN(WARN_MISC))
 		    Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
@@ -320,9 +362,9 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
     /* if at top level, try UNIVERSAL */
 
     if (level == 0 || level == -1) {
-	HV* lastchance;
+	HV* const lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE);
 
-	if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) {
+	if (lastchance) {
 	    if ((gv = gv_fetchmeth(lastchance, name, len,
 				  (level >= 0) ? level + 1 : level - 1)))
 	    {
@@ -397,20 +439,6 @@ Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 le
 }
 
 /*
-=for apidoc gv_fetchmethod
-
-See L<gv_fetchmethod_autoload>.
-
-=cut
-*/
-
-GV *
-Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name)
-{
-    return gv_fetchmethod_autoload(stash, name, TRUE);
-}
-
-/*
 =for apidoc gv_fetchmethod_autoload
 
 Returns the glob which contains the subroutine to call to invoke the method
@@ -447,7 +475,7 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
     HV* ostash = stash;
 
     if (stash && SvTYPE(stash) < SVt_PVHV)
-	stash = Nullhv;
+	stash = NULL;
 
     for (nend = name; *nend; nend++) {
 	if (*nend == '\'')
@@ -530,7 +558,7 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
     if (stash) {
 	if (SvTYPE(stash) < SVt_PVHV) {
 	    packname = SvPV_const((SV*)stash, packname_len);
-	    stash = Nullhv;
+	    stash = NULL;
 	}
 	else {
 	    packname = HvNAME_get(stash);
@@ -547,8 +575,9 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
     /*
      * Inheriting AUTOLOAD for non-methods works ... for now.
      */
-    if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && !method &&
-	(GvCVGEN(gv) || GvSTASH(gv) != stash))
+    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);
@@ -668,7 +697,7 @@ Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
 	GvHV(tmpgv) = newHV();
     stash = GvHV(tmpgv);
     if (!HvNAME_get(stash))
-	Perl_hv_name_set(aTHX_ stash, name, namelen, 0);
+	hv_name_set(stash, name, namelen, 0);
     return stash;
 }
 
@@ -712,7 +741,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
     I32 len;
     register const char *namend;
     HV *stash = 0;
-    const I32 add = flags & ~SVf_UTF8;
+    const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
+    const I32 add = flags & ~SVf_UTF8 & ~ GV_NOADD_NOINIT;
 
     PERL_UNUSED_ARG(full_len);
 
@@ -758,7 +788,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 		    stash = GvHV(gv) = newHV();
 
 		if (!HvNAME_get(stash))
-		    Perl_hv_name_set(aTHX_ stash, nambeg, namend - nambeg, 0);
+		    hv_name_set(stash, nambeg, namend - nambeg, 0);
 	    }
 
 	    if (*namend == ':')
@@ -877,7 +907,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 		require_errno(gv);
 	}
 	return gv;
-    } else if (add & GV_NOINIT) {
+    } else if (no_init) {
 	return gv;
     }
 
@@ -957,7 +987,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 		    hv = GvHVn(gv);
 		    hv_magic(hv, Nullgv, PERL_MAGIC_sig);
 		    for (i = 1; i < SIG_SIZE; i++) {
-			SV ** const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
+			SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
 			if (init)
 			    sv_setsv(*init, &PL_sv_undef);
 			PL_psig_ptr[i] = 0;
@@ -1182,38 +1212,10 @@ Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
 }
 
 void
-Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
-{
-    gv_fullname4(sv, gv, prefix, TRUE);
-}
-
-void
 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
 {
-    const GV *egv = GvEGV(gv);
-    if (!egv)
-	egv = gv;
-    gv_fullname4(sv, egv, prefix, keepmain);
-}
-
-void
-Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
-{
-    gv_efullname4(sv, gv, prefix, TRUE);
-}
-
-/* compatibility with versions <= 5.003. */
-void
-Perl_gv_fullname(pTHX_ SV *sv, const GV *gv)
-{
-    gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
-}
-
-/* compatibility with versions <= 5.003. */
-void
-Perl_gv_efullname(pTHX_ SV *sv, const GV *gv)
-{
-    gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
+    const GV * const egv = GvEGV(gv);
+    gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
 }
 
 IO *
@@ -1223,11 +1225,14 @@ Perl_newIO(pTHX)
     IO * const io = (IO*)NEWSV(0,0);
 
     sv_upgrade((SV *)io,SVt_PVIO);
-    SvREFCNT(io) = 1;
+    /* 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_fetchpv("FileHandle::", FALSE, SVt_PVHV);
+    iogv = gv_fetchpv("FileHandle::", 0, SVt_PVHV);
     /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
     if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
       iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
@@ -1261,14 +1266,14 @@ Perl_gv_check(pTHX_ HV *stash)
 		file = GvFILE(gv);
 		/* performance hack: if filename is absolute and it's a standard
 		 * module, don't bother warning */
-		if (file
-		    && PERL_FILE_IS_ABSOLUTE(file)
 #ifdef MACOS_TRADITIONAL
-		    && (instr(file, ":lib:")
+#   define LIB_COMPONENT ":lib:"
 #else
-		    && (instr(file, "/lib/")
+#   define LIB_COMPONENT "/lib/"
 #endif
-		    || instr(file, ".pm")))
+		if (file
+		    && PERL_FILE_IS_ABSOLUTE(file)
+		    && (instr(file, LIB_COMPONENT) || instr(file, ".pm")))
 		{
 		    continue;
 		}