X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/f776e3cd68509957cc5ab2967a78fb0ad213d8aa..d00eb2498c2f3efedfc04e6a6a3691e600b0c96a:/gv.c

diff --git a/gv.c b/gv.c
index 81b8e58..42c1556 100644
--- a/gv.c
+++ b/gv.c
@@ -1,7 +1,7 @@
 /*    gv.c
  *
  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- *    2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
+ *    2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -73,8 +73,22 @@ Perl_gv_HVadd(pTHX_ register GV *gv)
 GV *
 Perl_gv_IOadd(pTHX_ register GV *gv)
 {
-    if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
-	Perl_croak(aTHX_ "Bad symbol for filehandle");
+    dVAR;
+    if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) {
+
+        /*
+         * if it walks like a dirhandle, then let's assume that
+         * this is a dirhandle.
+         */
+        const char *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";
+        Perl_croak(aTHX_ "Bad symbol for %s", fh);
+    }
+
     if (!GvIOp(gv)) {
 #ifdef GV_UNIQUE_CHECK
         if (GvUNIQUE(gv)) {
@@ -89,6 +103,7 @@ Perl_gv_IOadd(pTHX_ register GV *gv)
 GV *
 Perl_gv_fetchfile(pTHX_ const char *name)
 {
+    dVAR;
     char smallbuf[256];
     char *tmpbuf;
     STRLEN tmplen;
@@ -122,6 +137,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)
 {
@@ -134,6 +168,16 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
     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);
     }
@@ -150,7 +194,7 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
     Newxz(gp, 1, GP);
     GvGP(gv) = gp_ref(gp);
 #ifdef PERL_DONT_CREATE_GVSV
-    GvSV(gv) = 0;
+    GvSV(gv) = NULL;
 #else
     GvSV(gv) = NEWSV(72,0);
 #endif
@@ -240,6 +284,7 @@ obtained from the GV with the C<GvCV> macro.
 GV *
 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 {
+    dVAR;
     AV* av;
     GV* topgv;
     GV* gv;
@@ -250,7 +295,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
     /* UNIVERSAL methods should be callable without a stash */
     if (!stash) {
 	level = -1;  /* probably appropriate */
-	if(!(stash = gv_stashpvn("UNIVERSAL", 9, FALSE)))
+	if(!(stash = gv_stashpvs("UNIVERSAL", FALSE)))
 	    return 0;
     }
 
@@ -333,7 +378,7 @@ 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* const lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE);
+	HV* const lastchance = gv_stashpvs("UNIVERSAL", FALSE);
 
 	if (lastchance) {
 	    if ((gv = gv_fetchmeth(lastchance, name, len,
@@ -440,8 +485,9 @@ C<call_sv> apply equally to these functions.
 GV *
 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
 {
+    dVAR;
     register const char *nend;
-    const char *nsplit = 0;
+    const char *nsplit = NULL;
     GV* gv;
     HV* ostash = stash;
 
@@ -584,7 +630,7 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
     LEAVE;
     varsv = GvSVn(vargv);
     sv_setpvn(varsv, packname, packname_len);
-    sv_catpvn(varsv, "::", 2);
+    sv_catpvs(varsv, "::");
     sv_catpvn(varsv, name, len);
     SvTAINTED_off(varsv);
     return gv;
@@ -597,7 +643,7 @@ STATIC void
 S_require_errno(pTHX_ GV *gv)
 {
     dVAR;
-    HV* stash = gv_stashpvn("Errno",5,FALSE);
+    HV* stash = gv_stashpvs("Errno", FALSE);
 
     if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
 	dSP;
@@ -605,10 +651,10 @@ S_require_errno(pTHX_ GV *gv)
 	ENTER;
 	save_scalar(gv); /* keep the value of $! */
         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
-                         newSVpvn("Errno",5), Nullsv);
+                         newSVpvs("Errno"), Nullsv);
 	LEAVE;
 	SPAGAIN;
-	stash = gv_stashpvn("Errno",5,FALSE);
+	stash = gv_stashpvs("Errno", FALSE);
 	if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
 	    Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
     }
@@ -646,7 +692,7 @@ package does not exist then NULL is returned.
 HV*
 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
 {
-    char smallbuf[256];
+    char smallbuf[128];
     char *tmpbuf;
     HV *stash;
     GV *tmpgv;
@@ -659,7 +705,7 @@ Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
     tmpbuf[namelen++] = ':';
     tmpbuf[namelen++] = ':';
     tmpbuf[namelen] = '\0';
-    tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
+    tmpgv = gv_fetchpvn_flags(tmpbuf, namelen, create, SVt_PVHV);
     if (tmpbuf != smallbuf)
 	Safefree(tmpbuf);
     if (!tmpgv)
@@ -706,13 +752,16 @@ GV *
 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 		       I32 sv_type)
 {
+    dVAR;
     register const char *name = nambeg;
-    register GV *gv = 0;
+    register GV *gv = NULL;
     GV**gvp;
     I32 len;
     register const char *namend;
-    HV *stash = 0;
-    const I32 add = flags & ~SVf_UTF8;
+    HV *stash = NULL;
+    const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
+    const I32 no_expand = flags & GV_NOEXPAND;
+    const I32 add = flags & ~SVf_UTF8 & ~GV_NOADD_NOINIT & ~GV_NOEXPAND;
 
     PERL_UNUSED_ARG(full_len);
 
@@ -730,7 +779,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 
 	    len = namend - name;
 	    if (len > 0) {
-		char smallbuf[256];
+		char smallbuf[128];
 		char *tmpbuf;
 
 		if (len + 3 < sizeof (smallbuf))
@@ -856,7 +905,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	    if (USE_UTF8_IN_NAMES)
 		SvUTF8_on(err);
 	    qerror(err);
-	    stash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
+	    stash = GvHV(gv_fetchpvn_flags("<none>::", 8, GV_ADDMULTI, SVt_PVHV));
 	}
 	else
 	    return Nullgv;
@@ -877,7 +926,9 @@ 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;
+    } else if (no_expand && SvROK(gv)) {
 	return gv;
     }
 
@@ -1135,7 +1186,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	{
 	    SV * const sv = GvSVn(gv);
 	    if (!sv_derived_from(PL_patchlevel, "version"))
-		(void *)upg_version(PL_patchlevel);
+		upg_version(PL_patchlevel);
 	    GvSV(gv) = vnumify(PL_patchlevel);
 	    SvREADONLY_on(GvSV(gv));
 	    SvREFCNT_dec(sv);
@@ -1176,7 +1227,7 @@ Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
 
     if (keepmain || strNE(name, "main")) {
 	sv_catpvn(sv,name,namelen);
-	sv_catpvn(sv,"::", 2);
+	sv_catpvs(sv,"::");
     }
     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
 }
@@ -1191,6 +1242,7 @@ Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain
 IO *
 Perl_newIO(pTHX)
 {
+    dVAR;
     GV *iogv;
     IO * const io = (IO*)NEWSV(0,0);
 
@@ -1202,10 +1254,10 @@ Perl_newIO(pTHX)
     SvOBJECT_on(io);
     /* Clear the stashcache because a new IO could overrule a package name */
     hv_clear(PL_stashcache);
-    iogv = gv_fetchpv("FileHandle::", 0, SVt_PVHV);
+    iogv = gv_fetchpvn_flags("FileHandle::", 12, 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);
+      iogv = gv_fetchpvn_flags("IO::Handle::", 12, TRUE, SVt_PVHV);
     SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv)));
     return io;
 }
@@ -1213,6 +1265,7 @@ Perl_newIO(pTHX)
 void
 Perl_gv_check(pTHX_ HV *stash)
 {
+    dVAR;
     register I32 i;
 
     if (!HvARRAY(stash))
@@ -1264,6 +1317,7 @@ Perl_gv_check(pTHX_ HV *stash)
 GV *
 Perl_newGVgen(pTHX_ const char *pack)
 {
+    dVAR;
     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
 		      TRUE, SVt_PVGV);
 }
@@ -1273,6 +1327,7 @@ Perl_newGVgen(pTHX_ const char *pack)
 GP*
 Perl_gp_ref(pTHX_ GP *gp)
 {
+    dVAR;
     if (!gp)
 	return (GP*)NULL;
     gp->gp_refcnt++;
@@ -1294,6 +1349,7 @@ Perl_gp_ref(pTHX_ GP *gp)
 void
 Perl_gp_free(pTHX_ GV *gv)
 {
+    dVAR;
     GP* gp;
 
     if (!gv || !(gp = GvGP(gv)))
@@ -1358,6 +1414,7 @@ Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
 bool
 Perl_Gv_AMupdate(pTHX_ HV *stash)
 {
+  dVAR;
   MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
   AMT * const amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
   AMT amt;
@@ -1480,6 +1537,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
 CV*
 Perl_gv_handler(pTHX_ HV *stash, I32 id)
 {
+    dVAR;
     MAGIC *mg;
     AMT *amtp;