X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/e858de61083066071eb1526df39bdaa094032c61..1d3434b8c1ecb43ba830424cfca969ab84444ed7:/gv.c

diff --git a/gv.c b/gv.c
index 50e9040..b48e4d8 100644
--- a/gv.c
+++ b/gv.c
@@ -22,8 +22,7 @@
 EXT char rcsid[];
 
 GV *
-gv_AVadd(gv)
-register GV *gv;
+gv_AVadd(register GV *gv)
 {
     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
 	croak("Bad symbol for array");
@@ -33,8 +32,7 @@ register GV *gv;
 }
 
 GV *
-gv_HVadd(gv)
-register GV *gv;
+gv_HVadd(register GV *gv)
 {
     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
 	croak("Bad symbol for hash");
@@ -44,8 +42,7 @@ register GV *gv;
 }
 
 GV *
-gv_IOadd(gv)
-register GV *gv;
+gv_IOadd(register GV *gv)
 {
     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
 	croak("Bad symbol for filehandle");
@@ -55,8 +52,7 @@ register GV *gv;
 }
 
 GV *
-gv_fetchfile(name)
-char *name;
+gv_fetchfile(char *name)
 {
     dTHR;
     char smallbuf[256];
@@ -80,24 +76,28 @@ char *name;
     sv_setpv(GvSV(gv), name);
     if (*name == '/' && (instr(name, "/lib/") || instr(name, ".pm")))
 	GvMULTI_on(gv);
-    if (perldb)
+    if (PERLDB_LINE)
 	hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L');
     return gv;
 }
 
 void
-gv_init(gv, stash, name, len, multi)
-GV *gv;
-HV *stash;
-char *name;
-STRLEN len;
-int multi;
+gv_init(GV *gv, HV *stash, char *name, STRLEN len, int multi)
 {
+    dTHR;
     register GP *gp;
+    bool doproto = SvTYPE(gv) > SVt_NULL;
+    char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
 
     sv_upgrade((SV*)gv, SVt_PVGV);
-    if (SvLEN(gv))
-	Safefree(SvPVX(gv));
+    if (SvLEN(gv)) {
+	if (proto) {
+	    SvPVX(gv) = NULL;
+	    SvLEN(gv) = 0;
+	    SvPOK_off(gv);
+	} else
+	    Safefree(SvPVX(gv));
+    }
     Newz(602, gp, 1, GP);
     GvGP(gv) = gp_ref(gp);
     GvSV(gv) = NEWSV(72,0);
@@ -105,17 +105,36 @@ int multi;
     GvFILEGV(gv) = curcop->cop_filegv;
     GvEGV(gv) = gv;
     sv_magic((SV*)gv, (SV*)gv, '*', name, len);
-    GvSTASH(gv) = stash;
+    GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
     GvNAME(gv) = savepvn(name, len);
     GvNAMELEN(gv) = len;
     if (multi)
 	GvMULTI_on(gv);
+    if (doproto) {			/* Replicate part of newSUB here. */
+	ENTER;
+	start_subparse(0,0);		/* Create CV in compcv. */
+	GvCV(gv) = compcv;
+	LEAVE;
+
+	GvCVGEN(gv) = 0;
+	sub_generation++;
+	CvGV(GvCV(gv)) = (GV*)SvREFCNT_inc(gv);
+	CvFILEGV(GvCV(gv)) = curcop->cop_filegv;
+	CvSTASH(GvCV(gv)) = curstash;
+#ifdef USE_THREADS
+	CvOWNER(GvCV(gv)) = 0;
+	New(666, CvMUTEXP(GvCV(gv)), 1, perl_mutex);
+	MUTEX_INIT(CvMUTEXP(GvCV(gv)));
+#endif /* USE_THREADS */
+	if (proto) {
+	    sv_setpv((SV*)GvCV(gv), proto);
+	    Safefree(proto);
+	}
+    }
 }
 
 static void
-gv_init_sv(gv, sv_type)
-GV* gv;
-I32 sv_type;
+gv_init_sv(GV *gv, I32 sv_type)
 {
     switch (sv_type) {
     case SVt_PVIO:
@@ -131,11 +150,7 @@ I32 sv_type;
 }
 
 GV *
-gv_fetchmeth(stash, name, len, level)
-HV* stash;
-char* name;
-STRLEN len;
-I32 level;
+gv_fetchmeth(HV *stash, char *name, STRLEN len, I32 level)
 {
     AV* av;
     GV* topgv;
@@ -171,8 +186,8 @@ I32 level;
     gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
     av = (gvp && (gv = *gvp) && gv != (GV*)&sv_undef) ? GvAV(gv) : Nullav;
 
-    /* create @.*::SUPER::ISA on demand */
-    if (!av) {
+    /* create and re-create @.*::SUPER::ISA on demand */
+    if (!av || !SvMAGIC(av)) {
 	char* packname = HvNAME(stash);
 	STRLEN packlen = strlen(packname);
 
@@ -197,7 +212,8 @@ I32 level;
 
     if (av) {
 	SV** svp = AvARRAY(av);
-	I32 items = AvFILL(av) + 1;
+	/* NOTE: No support for tied ISA */
+	I32 items = AvFILLp(av) + 1;
 	while (items--) {
 	    SV* sv = *svp++;
 	    HV* basestash = gv_stashsv(sv, FALSE);
@@ -233,7 +249,6 @@ I32 level;
 		    (cv = GvCV(gv)) &&
 		    (CvROOT(cv) || CvXSUB(cv)))
 		{
-		    dTHR;	/* just for SvREFCNT_inc */
 		    if (cv = GvCV(topgv))
 			SvREFCNT_dec(cv);
 		    GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
@@ -248,19 +263,15 @@ I32 level;
 }
 
 GV *
-gv_fetchmethod(stash, name)
-HV* stash;
-char* name;
+gv_fetchmethod(HV *stash, char *name)
 {
     return gv_fetchmethod_autoload(stash, name, TRUE);
 }
 
 GV *
-gv_fetchmethod_autoload(stash, name, autoload)
-HV* stash;
-char* name;
-I32 autoload;
+gv_fetchmethod_autoload(HV *stash, char *name, I32 autoload)
 {
+    dTHR;
     register char *nend;
     char *nsplit = 0;
     GV* gv;
@@ -319,11 +330,7 @@ I32 autoload;
 }
 
 GV*
-gv_autoload4(stash, name, len, method)
-HV* stash;
-char* name;
-STRLEN len;
-I32 method;
+gv_autoload4(HV *stash, char *name, STRLEN len, I32 method)
 {
     static char autoload[] = "AUTOLOAD";
     static STRLEN autolen = 8;
@@ -366,18 +373,13 @@ I32 method;
 }
 
 HV*
-gv_stashpv(name,create)
-char *name;
-I32 create;
+gv_stashpv(char *name, I32 create)
 {
     return gv_stashpvn(name, strlen(name), create);
 }
 
 HV*
-gv_stashpvn(name,namelen,create)
-char *name;
-U32 namelen;
-I32 create;
+gv_stashpvn(char *name, U32 namelen, I32 create)
 {
     char smallbuf[256];
     char *tmpbuf;
@@ -406,9 +408,7 @@ I32 create;
 }
 
 HV*
-gv_stashsv(sv,create)
-SV *sv;
-I32 create;
+gv_stashsv(SV *sv, I32 create)
 {
     register char *ptr;
     STRLEN len;
@@ -418,10 +418,7 @@ I32 create;
 
 
 GV *
-gv_fetchpv(nambeg,add,sv_type)
-char *nambeg;
-I32 add;
-I32 sv_type;
+gv_fetchpv(char *nambeg, I32 add, I32 sv_type)
 {
     dTHR;
     register char *name = nambeg;
@@ -431,7 +428,6 @@ I32 sv_type;
     register char *namend;
     HV *stash = 0;
     U32 add_gvflags = 0;
-    char *tmpbuf;
 
     if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
 	name++;
@@ -447,23 +443,29 @@ I32 sv_type;
 
 	    len = namend - name;
 	    if (len > 0) {
-		New(601, tmpbuf, len+3, char);
+		char *tmpbuf;
+		char autobuf[64];
+
+		if (len < sizeof(autobuf) - 2)
+		    tmpbuf = autobuf;
+		else
+		    New(601, tmpbuf, len+3, char);
 		Copy(name, tmpbuf, len, char);
 		tmpbuf[len++] = ':';
 		tmpbuf[len++] = ':';
 		tmpbuf[len] = '\0';
 		gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
-		Safefree(tmpbuf);
-		if (!gvp || *gvp == (GV*)&sv_undef)
-		    return Nullgv;
-		gv = *gvp;
-
-		if (SvTYPE(gv) == SVt_PVGV)
-		    GvMULTI_on(gv);
-		else if (!add)
+		gv = gvp ? *gvp : Nullgv;
+		if (gv && gv != (GV*)&sv_undef) {
+		    if (SvTYPE(gv) != SVt_PVGV)
+			gv_init(gv, stash, tmpbuf, len, (add & 2));
+		    else
+			GvMULTI_on(gv);
+		}
+		if (tmpbuf != autobuf)
+		    Safefree(tmpbuf);
+		if (!gv || gv == (GV*)&sv_undef)
 		    return Nullgv;
-		else
-		    gv_init(gv, stash, nambeg, namend - nambeg, (add & 2));
 
 		if (!(stash = GvHV(gv)))
 		    stash = GvHV(gv) = newHV();
@@ -557,17 +559,26 @@ I32 sv_type;
     /* By this point we should have a stash and a name */
 
     if (!stash) {
-	if (add) {
-	    warn("Global symbol \"%s\" requires explicit package name", name);
-	    ++error_count;
-	    stash = curstash ? curstash : defstash;	/* avoid core dumps */
-	    add_gvflags = ((sv_type == SVt_PV) ? GVf_IMPORTED_SV
-			   : (sv_type == SVt_PVAV) ? GVf_IMPORTED_AV
-			   : (sv_type == SVt_PVHV) ? GVf_IMPORTED_HV
-			   : 0);
-	}
-	else
+	if (!add)
 	    return Nullgv;
+	if (add & ~2) {
+	    char sv_type_char = ((sv_type == SVt_PV) ? '$'
+				 : (sv_type == SVt_PVAV) ? '@'
+				 : (sv_type == SVt_PVHV) ? '%'
+				 : 0);
+	    if (sv_type_char) 
+		warn("Global symbol \"%c%s\" requires explicit package name",
+		     sv_type_char, name);
+	    else
+		warn("Global symbol \"%s\" requires explicit package name",
+		     name);
+	}
+	++error_count;
+	stash = curstash ? curstash : defstash;	/* avoid core dumps */
+	add_gvflags = ((sv_type == SVt_PV) ? GVf_IMPORTED_SV
+		       : (sv_type == SVt_PVAV) ? GVf_IMPORTED_AV
+		       : (sv_type == SVt_PVHV) ? GVf_IMPORTED_HV
+		       : 0);
     }
 
     if (!SvREFCNT(stash))	/* symbol table under destruction */
@@ -583,13 +594,15 @@ I32 sv_type;
 	    gv_init_sv(gv, sv_type);
 	}
 	return gv;
+    } else if (add & GV_NOINIT) {
+	return gv;
     }
 
     /* Adding a new symbol */
 
-    if (add & 4)
+    if (add & GV_ADDWARN)
 	warn("Had to create %s unexpectedly", nambeg);
-    gv_init(gv, stash, name, len, add & 2);
+    gv_init(gv, stash, name, len, add & GV_ADDMULTI);
     gv_init_sv(gv, sv_type);
     GvFLAGS(gv) |= add_gvflags;
 
@@ -615,7 +628,9 @@ I32 sv_type;
 	    AV* av = GvAVn(gv);
 	    GvMULTI_on(gv);
 	    sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0);
-	    if (add & 2 && strEQ(nambeg,"AnyDBM_File::ISA") && AvFILL(av) == -1)
+	    /* NOTE: No support for tied ISA */
+	    if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
+		&& AvFILLp(av) == -1)
 	    {
 		char *pname;
 		av_push(av, newSVpv(pname = "NDBM_File",0));
@@ -636,7 +651,7 @@ I32 sv_type;
         if (strEQ(name, "OVERLOAD")) {
             HV* hv = GvHVn(gv);
             GvMULTI_on(gv);
-            sv_magic((SV*)hv, (SV*)gv, 'A', 0, 0);
+            hv_magic(hv, gv, 'A');
         }
         break;
 #endif /* OVERLOAD */
@@ -656,11 +671,6 @@ I32 sv_type;
 	    	psig_ptr[i] = 0;
 	    	psig_name[i] = 0;
 	    }
-	    /* initialize signal stack */
-	    signalstack = newAV();
-	    AvREAL_off(signalstack);
-	    av_extend(signalstack, 30);
-	    av_fill(signalstack, 0);
 	}
 	break;
 
@@ -699,13 +709,28 @@ I32 sv_type;
 #endif
 	goto magicalize;
 
+    case '!':
+	if(len > 1)
+	    break;
+	if(sv_type > SVt_PV) {
+	    HV* stash = gv_stashpvn("Errno",5,FALSE);
+	    if(!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
+		dSP;
+		PUTBACK;
+		perl_require_pv("Errno.pm");
+		SPAGAIN;
+		stash = gv_stashpvn("Errno",5,FALSE);
+		if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
+		    croak("Can't use %%! because Errno.pm is not avaliable");
+	    }
+	}
+	goto magicalize;
     case '#':
     case '*':
 	if (dowarn && len == 1 && sv_type == SVt_PV)
 	    warn("Use of $%s is deprecated", name);
 	/* FALL THROUGH */
     case '[':
-    case '!':
     case '^':
     case '~':
     case '=':
@@ -744,6 +769,7 @@ I32 sv_type;
     case '7':
     case '8':
     case '9':
+    case '\023':
       ro_magicalize:
 	SvREADONLY_on(GvSV(gv));
       magicalize:
@@ -775,10 +801,7 @@ I32 sv_type;
 }
 
 void
-gv_fullname3(sv, gv, prefix)
-SV *sv;
-GV *gv;
-char *prefix;
+gv_fullname3(SV *sv, GV *gv, char *prefix)
 {
     HV *hv = GvSTASH(gv);
     if (!hv) {
@@ -792,10 +815,7 @@ char *prefix;
 }
 
 void
-gv_efullname3(sv, gv, prefix)
-SV *sv;
-GV *gv;
-char *prefix;
+gv_efullname3(SV *sv, GV *gv, char *prefix)
 {
     GV *egv = GvEGV(gv);
     if (!egv)
@@ -805,24 +825,20 @@ char *prefix;
 
 /* XXX compatibility with versions <= 5.003. */
 void
-gv_fullname(sv,gv)
-SV *sv;
-GV *gv;
+gv_fullname(SV *sv, GV *gv)
 {
     gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
 }
 
 /* XXX compatibility with versions <= 5.003. */
 void
-gv_efullname(sv,gv)
-SV *sv;
-GV *gv;
+gv_efullname(SV *sv, GV *gv)
 {
     gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
 }
 
 IO *
-newIO()
+newIO(void)
 {
     dTHR;
     IO *io;
@@ -832,14 +848,15 @@ newIO()
     sv_upgrade((SV *)io,SVt_PVIO);
     SvREFCNT(io) = 1;
     SvOBJECT_on(io);
-    iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
+    iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
+    if (!iogv)
+      iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
     SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
     return io;
 }
 
 void
-gv_check(stash)
-HV* stash;
+gv_check(HV *stash)
 {
     dTHR;
     register HE *entry;
@@ -860,7 +877,7 @@ HV* stash;
 	    }
 	    else if (isALPHA(*HeKEY(entry))) {
 		gv = (GV*)HeVAL(entry);
-		if (GvMULTI(gv))
+		if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
 		    continue;
 		curcop->cop_line = GvLINE(gv);
 		filegv = GvFILEGV(gv);
@@ -875,8 +892,7 @@ HV* stash;
 }
 
 GV *
-newGVgen(pack)
-char *pack;
+newGVgen(char *pack)
 {
     return gv_fetchpv(form("%s::_GEN_%ld", pack, (long)gensym++),
 		      TRUE, SVt_PVGV);
@@ -885,8 +901,7 @@ char *pack;
 /* hopefully this is only called on local symbol table entries */
 
 GP*
-gp_ref(gp)
-GP* gp;
+gp_ref(GP *gp)
 {
     gp->gp_refcnt++;
     if (gp->gp_cv) {
@@ -905,8 +920,7 @@ GP* gp;
 }
 
 void
-gp_free(gv)
-GV* gv;
+gp_free(GV *gv)
 {
     GP* gp;
     CV* cv;
@@ -966,8 +980,7 @@ register GV *gv;
 /* Updates and caches the CV's */
 
 bool
-Gv_AMupdate(stash)
-HV* stash;
+Gv_AMupdate(HV *stash)
 {
   dTHR;  
   GV** gvp;
@@ -975,7 +988,7 @@ HV* stash;
   GV* gv;
   CV* cv;
   MAGIC* mg=mg_find((SV*)stash,'c');
-  AMT *amtp=mg ? (AMT*)mg->mg_ptr: NULL;
+  AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
   AMT amt;
 
   if (mg && amtp->was_ok_am == amagic_generation
@@ -1123,15 +1136,8 @@ HV* stash;
   return FALSE;
 }
 
-/* During call to this subroutine stack can be reallocated. It is
- * advised to call SPAGAIN macro in your code after call */
-
 SV*
-amagic_call(left,right,method,flags)
-SV* left;
-SV* right;
-int method;
-int flags; 
+amagic_call(SV *left, SV *right, int method, int flags)
 {
   dTHR;
   MAGIC *mg; 
@@ -1145,7 +1151,7 @@ int flags;
       && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) 
 			? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
-			: NULL))
+			: (CV **) NULL))
       && ((cv = cvp[off=method+assignshift]) 
 	  || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
 						          * usual method */
@@ -1238,7 +1244,7 @@ int flags;
 	       && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
 	       && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) 
 			  ? (amtp = (AMT*)mg->mg_ptr)->table
-			  : NULL))
+			  : (CV **) NULL))
 	       && (cv = cvp[off=method])) { /* Method for right
 					     * argument found */
       lr=1;
@@ -1333,7 +1339,6 @@ int flags;
 	|| inc_dec_ass) RvDEEPCP(left);
   }
   {
-    dTHR;
     dSP;
     BINOP myop;
     SV* res;
@@ -1345,15 +1350,16 @@ int flags;
     myop.op_next = Nullop;
     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
 
+    PUSHSTACK(SI_OVERLOAD);
     ENTER;
-    SAVESPTR(op);
+    SAVEOP();
     op = (OP *) &myop;
-    if (perldb && curstash != debstash)
+    if (PERLDB_SUB && curstash != debstash)
 	op->op_private |= OPpENTERSUB_DB;
     PUTBACK;
     pp_pushmark(ARGS);
 
-    EXTEND(sp, notfound + 5);
+    EXTEND(SP, notfound + 5);
     PUSHs(lr>0? right: left);
     PUSHs(lr>0? left: right);
     PUSHs( lr > 0 ? &sv_yes : ( assign ? &sv_undef : &sv_no ));
@@ -1369,7 +1375,7 @@ int flags;
     SPAGAIN;
 
     res=POPs;
-    PUTBACK;
+    POPSTACK();
     CATCH_SET(oldcatch);
 
     if (postpr) {
@@ -1411,3 +1417,4 @@ int flags;
   }
 }
 #endif /* OVERLOAD */
+