X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=gv.c;h=836fdb23d2de60d9afab13f463f0b4dfabfc37b0;hb=02237c86f171377b770f43f3200e5b80153a9722;hp=e1e4ae081c4ec6ee91549066516adba0ae964732;hpb=7766f1371a6d2b58d0f46fbe6a60785860a39c1e;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/gv.c b/gv.c
index e1e4ae0..836fdb2 100644
--- a/gv.c
+++ b/gv.c
@@ -1,6 +1,6 @@
 /*    gv.c
  *
- *    Copyright (c) 1991-1999, Larry Wall
+ *    Copyright (c) 1991-2000, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -106,7 +106,7 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
     GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : "";
     GvCVGEN(gv) = 0;
     GvEGV(gv) = gv;
-    sv_magic((SV*)gv, (SV*)gv, '*', name, len);
+    sv_magic((SV*)gv, (SV*)gv, '*', Nullch, 0);
     GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
     GvNAME(gv) = savepvn(name, len);
     GvNAMELEN(gv) = len;
@@ -154,6 +154,27 @@ S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
     }
 }
 
+/*
+=for apidoc gv_fetchmeth
+
+Returns the glob with the given C<name> and a defined subroutine or
+C<NULL>.  The glob lives in the given C<stash>, or in the stashes
+accessible via @ISA and @UNIVERSAL. 
+
+The argument C<level> should be either 0 or -1.  If C<level==0>, as a
+side-effect creates a glob with the given C<name> in the given C<stash>
+which in the case of success contains an alias for the subroutine, and sets
+up caching info for this glob.  Similarly for all the searched stashes. 
+
+This function grants C<"SUPER"> token as a postfix of the stash name. The
+GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
+visible to Perl code.  So when calling C<call_sv>, you should not use
+the GV directly; instead, you should use the method's CV, which can be
+obtained from the GV with the C<GvCV> macro. 
+
+=cut
+*/
+
 GV *
 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 {
@@ -178,7 +199,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 	topgv = *gvp;
 	if (SvTYPE(topgv) != SVt_PVGV)
 	    gv_init(topgv, stash, name, len, TRUE);
-	if (cv = GvCV(topgv)) {
+	if ((cv = GvCV(topgv))) {
 	    /* If genuine method or valid cache entry, use it */
 	    if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
 		return topgv;
@@ -244,9 +265,10 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
     if (level == 0 || level == -1) {
 	HV* lastchance;
 
-	if (lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE)) {
-	    if (gv = gv_fetchmeth(lastchance, name, len,
-				  (level >= 0) ? level + 1 : level - 1)) {
+	if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) {
+	    if ((gv = gv_fetchmeth(lastchance, name, len,
+				  (level >= 0) ? level + 1 : level - 1)))
+	    {
 	  gotcha:
 		/*
 		 * Cache method in topgv if:
@@ -258,7 +280,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 		    (cv = GvCV(gv)) &&
 		    (CvROOT(cv) || CvXSUB(cv)))
 		{
-		    if (cv = GvCV(topgv))
+		    if ((cv = GvCV(topgv)))
 			SvREFCNT_dec(cv);
 		    GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
 		    GvCVGEN(topgv) = PL_sub_generation;
@@ -275,12 +297,48 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
     return 0;
 }
 
+/*
+=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
+on the C<stash>.  In fact in the presence of autoloading this may be the
+glob for "AUTOLOAD".  In this case the corresponding variable $AUTOLOAD is
+already setup. 
+
+The third parameter of C<gv_fetchmethod_autoload> determines whether
+AUTOLOAD lookup is performed if the given method is not present: non-zero
+means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD. 
+Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
+with a non-zero C<autoload> parameter. 
+
+These functions grant C<"SUPER"> token as a prefix of the method name. Note
+that if you want to keep the returned glob for a long time, you need to
+check for it being "AUTOLOAD", since at the later time the call may load a
+different subroutine due to $AUTOLOAD changing its value. Use the glob
+created via a side effect to do this. 
+
+These functions have the same side-effects and as C<gv_fetchmeth> with
+C<level==0>.  C<name> should be writable if contains C<':'> or C<'
+''>. The warning against passing the GV returned by C<gv_fetchmeth> to
+C<call_sv> apply equally to these functions. 
+
+=cut
+*/
+
 GV *
 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
 {
@@ -314,7 +372,7 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
 
     gv = gv_fetchmeth(stash, name, nend - name, 0);
     if (!gv) {
-	if (strEQ(name,"import"))
+	if (strEQ(name,"import") || strEQ(name,"unimport"))
 	    gv = (GV*)&PL_sv_yes;
 	else if (autoload)
 	    gv = gv_autoload4(stash, name, nend - name, TRUE);
@@ -360,6 +418,9 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
 	return Nullgv;
     cv = GvCV(gv);
 
+    if (!CvROOT(cv))
+	return Nullgv;
+
     /*
      * Inheriting AUTOLOAD for non-methods works ... for now.
      */
@@ -377,9 +438,18 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
      */
     varstash = GvSTASH(CvGV(cv));
     vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
+    ENTER;
+
+#ifdef USE_THREADS
+    sv_lock((SV *)varstash);
+#endif
     if (!isGV(vargv))
 	gv_init(vargv, varstash, autoload, autolen, FALSE);
+    LEAVE;
     varsv = GvSV(vargv);
+#ifdef USE_THREADS
+    sv_lock(varsv);
+#endif
     sv_setpv(varsv, HvNAME(stash));
     sv_catpvn(varsv, "::", 2);
     sv_catpvn(varsv, name, len);
@@ -387,6 +457,17 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
     return gv;
 }
 
+/*
+=for apidoc gv_stashpv
+
+Returns a pointer to the stash for a specified package.  C<name> should
+be a valid UTF-8 string.  If C<create> is set then the package will be
+created if it does not already exist.  If C<create> is not set and the
+package does not exist then NULL is returned.
+
+=cut
+*/
+
 HV*
 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
 {
@@ -422,6 +503,15 @@ Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
     return stash;
 }
 
+/*
+=for apidoc gv_stashsv
+
+Returns a pointer to the stash for a specified package, which must be a
+valid UTF-8 string.  See C<gv_stashpv>.
+
+=cut
+*/
+
 HV*
 Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
 {
@@ -442,7 +532,6 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
     I32 len;
     register const char *namend;
     HV *stash = 0;
-    U32 add_gvflags = 0;
 
     if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
 	name++;
@@ -504,9 +593,7 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
     /* No stash in name, so see how we can default */
 
     if (!stash) {
-	if (isIDFIRST(*name)
-	    || (IN_UTF8 && ((*name & 0xc0) == 0xc0) && isIDFIRST_utf8((U8*)name)))
-	{
+	if (isIDFIRST_lazy(name)) {
 	    bool global = FALSE;
 
 	    if (isUPPER(*name)) {
@@ -533,7 +620,6 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
 	    else if ((COP*)PL_curcop == &PL_compiling) {
 		stash = PL_curstash;
 		if (add && (PL_hints & HINT_STRICT_VARS) &&
-		    !(add & GV_ADDOUR) &&
 		    sv_type != SVt_PVCV &&
 		    sv_type != SVt_PVGV &&
 		    sv_type != SVt_PVFM &&
@@ -547,16 +633,16 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
 		    {
 			stash = 0;
 		    }
-		    else if (sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp) ||
-			     sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp) ||
-			     sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp) )
+		    else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
+			     (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
+			     (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
 		    {
 			Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
 			    sv_type == SVt_PVAV ? '@' :
 			    sv_type == SVt_PVHV ? '%' : '$',
 			    name);
 			if (GvCVu(*gvp))
-			    Perl_warn(aTHX_ "(Did you mean &%s instead?)\n", name);
+			    Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
 			stash = 0;
 		    }
 		}
@@ -578,8 +664,10 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
 		  : sv_type == SVt_PVAV ? "@"
 		  : sv_type == SVt_PVHV ? "%"
 		  : ""), name));
+	    stash = PL_nullstash;
 	}
-	return Nullgv;
+	else
+	    return Nullgv;
     }
 
     if (!SvREFCNT(stash))	/* symbol table under destruction */
@@ -605,7 +693,6 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
 	Perl_warner(aTHX_ WARN_INTERNAL, "Had to create %s unexpectedly", nambeg);
     gv_init(gv, stash, name, len, add & GV_ADDMULTI);
     gv_init_sv(gv, sv_type);
-    GvFLAGS(gv) |= add_gvflags;
 
     if (isLEXWARN_on && isALPHA(name[0]) && ! ckWARN(WARN_ONCE))
         GvMULTI_on(gv) ;
@@ -753,25 +840,26 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
     case '\\':
     case '/':
     case '|':
-    case '\001':
-    case '\003':
-    case '\004':
-    case '\005':
-    case '\006':
-    case '\010':
-    case '\011':	/* NOT \t in EBCDIC */
-    case '\017':
-    case '\020':
-    case '\024':
+    case '\001':	/* $^A */
+    case '\003':	/* $^C */
+    case '\004':	/* $^D */
+    case '\005':	/* $^E */
+    case '\006':	/* $^F */
+    case '\010':	/* $^H */
+    case '\011':	/* $^I, NOT \t in EBCDIC */
+    case '\017':	/* $^O */
+    case '\020':	/* $^P */
+    case '\024':	/* $^T */
 	if (len > 1)
 	    break;
 	goto magicalize;
-    case '\023':
+    case '\023':	/* $^S */
 	if (len > 1)
 	    break;
 	goto ro_magicalize;
-    case '\027':	/* $^W & $^Warnings */
-	if (len > 1 && strNE(name, "\027arnings"))
+    case '\027':	/* $^W & $^WARNING_BITS */
+	if (len > 1 && strNE(name, "\027ARNING_BITS")
+	    && strNE(name, "\027IDE_SYSTEM_CALLS"))
 	    break;
 	goto magicalize;
 
@@ -798,7 +886,7 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
 	sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
 	break;
 
-    case '\014':
+    case '\014':	/* $^L */
 	if (len > 1)
 	    break;
 	sv_setpv(GvSV(gv),"\f");
@@ -813,21 +901,45 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
 	if (len == 1) {
 	    SV *sv = GvSV(gv);
 	    (void)SvUPGRADE(sv, SVt_PVNV);
-	    sv_setpv(sv, PL_patchlevel);
-	    (void)sv_2nv(sv);
+	    SvNVX(sv) = SvNVX(PL_patchlevel);
+	    SvNOK_on(sv);
+	    (void)SvPV_nolen(sv);
 	    SvREADONLY_on(sv);
 	}
 	break;
+    case '\026':	/* $^V */
+	if (len == 1) {
+	    SV *sv = GvSV(gv);
+	    GvSV(gv) = SvREFCNT_inc(PL_patchlevel);
+	    SvREFCNT_dec(sv);
+	}
+	break;
     }
     return gv;
 }
 
 void
+Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
+{
+    HV *hv = GvSTASH(gv);
+    if (!hv) {
+	(void)SvOK_off(sv);
+	return;
+    }
+    sv_setpv(sv, prefix ? prefix : "");
+    if (keepmain || strNE(HvNAME(hv), "main")) {
+	sv_catpv(sv,HvNAME(hv));
+	sv_catpvn(sv,"::", 2);
+    }
+    sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
+}
+
+void
 Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
 {
     HV *hv = GvSTASH(gv);
     if (!hv) {
-	SvOK_off(sv);
+	(void)SvOK_off(sv);
 	return;
     }
     sv_setpv(sv, prefix ? prefix : "");
@@ -837,6 +949,15 @@ Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
 }
 
 void
+Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
+{
+    GV *egv = GvEGV(gv);
+    if (!egv)
+	egv = gv;
+    gv_fullname4(sv, egv, prefix, keepmain);
+}
+
+void
 Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
 {
     GV *egv = GvEGV(gv);
@@ -960,7 +1081,6 @@ Perl_gp_free(pTHX_ GV *gv)
 {
     dTHR;  
     GP* gp;
-    CV* cv;
 
     if (!gv || !(gp = GvGP(gv)))
 	return;
@@ -1020,15 +1140,17 @@ register GV *gv;
 bool
 Perl_Gv_AMupdate(pTHX_ HV *stash)
 {
-  dTHR;  
-  GV** gvp;
-  HV* hv;
+  dTHR;
   GV* gv;
   CV* cv;
   MAGIC* mg=mg_find((SV*)stash,'c');
   AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
   AMT amt;
   STRLEN n_a;
+#ifdef OVERLOAD_VIA_HASH
+  GV** gvp;
+  HV* hv;
+#endif
 
   if (mg && amtp->was_ok_am == PL_amagic_generation
       && amtp->was_ok_sub == PL_sub_generation)
@@ -1109,18 +1231,21 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
     int i;
     const char *cp;
     SV* sv = NULL;
-    SV** svp;
 
     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
 
-    if ( cp = PL_AMG_names[0] ) {
+    if ((cp = PL_AMG_names[0])) {
 	/* Try to find via inheritance. */
 	gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */
-	if (gv) sv = GvSV(gv);
-
-	if (!gv) goto no_table;
-	else if (SvTRUE(sv)) amt.fallback=AMGfallYES;
-	else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
+	if (gv)
+	    sv = GvSV(gv);
+
+	if (!gv)
+	    goto no_table;
+	else if (SvTRUE(sv))
+	    amt.fallback=AMGfallYES;
+	else if (SvOK(sv))
+	    amt.fallback=AMGfallNEVER;
     }
 
     for (i = 1; i < NofAMmeth; i++) {
@@ -1276,7 +1401,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
 	   }
 	   break;
 	 case neg_amg:
-	   if (cv = cvp[off=subtr_amg]) {
+	   if ((cv = cvp[off=subtr_amg])) {
 	     right = left;
 	     left = sv_2mortal(newSViv(0));
 	     lr = 1;
@@ -1365,7 +1490,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
 	if (amtp && amtp->fallback >= AMGfallYES) {
 	  DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
 	} else {
-	  Perl_croak(aTHX_ "%_", msg);
+	  Perl_croak(aTHX_ "%"SVf, msg);
 	}
 	return NULL;
       }
@@ -1444,7 +1569,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
     PUSHs((SV*)cv);
     PUTBACK;
 
-    if (PL_op = Perl_pp_entersub(aTHX))
+    if ((PL_op = Perl_pp_entersub(aTHX)))
       CALLRUNOPS(aTHX);
     LEAVE;
     SPAGAIN;
@@ -1492,3 +1617,110 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
     }
   }
 }
+
+/*
+=for apidoc is_gv_magical
+
+Returns C<TRUE> if given the name of a magical GV.
+
+Currently only useful internally when determining if a GV should be
+created even in rvalue contexts.
+
+C<flags> is not used at present but available for future extension to
+allow selecting particular classes of magical variable.
+
+=cut
+*/
+bool
+Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
+{
+    if (!len)
+	return FALSE;
+
+    switch (*name) {
+    case 'I':
+	if (len == 3 && strEQ(name, "ISA"))
+	    goto yes;
+	break;
+    case 'O':
+	if (len == 8 && strEQ(name, "OVERLOAD"))
+	    goto yes;
+	break;
+    case 'S':
+	if (len == 3 && strEQ(name, "SIG"))
+	    goto yes;
+	break;
+    case '\027':   /* $^W & $^WARNING_BITS */
+	if (len == 1
+	    || (len == 12 && strEQ(name, "\027ARNING_BITS"))
+	    || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS")))
+	{
+	    goto yes;
+	}
+	break;
+
+    case '&':
+    case '`':
+    case '\'':
+    case ':':
+    case '?':
+    case '!':
+    case '-':
+    case '#':
+    case '*':
+    case '[':
+    case '^':
+    case '~':
+    case '=':
+    case '%':
+    case '.':
+    case '(':
+    case ')':
+    case '<':
+    case '>':
+    case ',':
+    case '\\':
+    case '/':
+    case '|':
+    case '+':
+    case ';':
+    case ']':
+    case '\001':   /* $^A */
+    case '\003':   /* $^C */
+    case '\004':   /* $^D */
+    case '\005':   /* $^E */
+    case '\006':   /* $^F */
+    case '\010':   /* $^H */
+    case '\011':   /* $^I, NOT \t in EBCDIC */
+    case '\014':   /* $^L */
+    case '\017':   /* $^O */
+    case '\020':   /* $^P */
+    case '\023':   /* $^S */
+    case '\024':   /* $^T */
+    case '\026':   /* $^V */
+	if (len == 1)
+	    goto yes;
+	break;
+    case '1':
+    case '2':
+    case '3':
+    case '4':
+    case '5':
+    case '6':
+    case '7':
+    case '8':
+    case '9':
+	if (len > 1) {
+	    char *end = name + len;
+	    while (--end > name) {
+		if (!isDIGIT(*end))
+		    return FALSE;
+	    }
+	}
+    yes:
+	return TRUE;
+    default:
+	break;
+    }
+    return FALSE;
+}