X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=gv.c;h=2d43338448fe6c01228855ec16bf286be1ce6fa0;hb=d57eded6852763e3753285b692dd66ed278e268d;hp=768824defe9e9cc09c029ccfd1b7f1cfe46d7170;hpb=b267980ddb40b015c095b6e55ef52f73a92b67b0;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/gv.c b/gv.c
index 768824d..2d43338 100644
--- a/gv.c
+++ b/gv.c
@@ -1,6 +1,6 @@
 /*    gv.c
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, 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.
@@ -45,15 +45,20 @@ Perl_gv_IOadd(pTHX_ register GV *gv)
 {
     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
 	Perl_croak(aTHX_ "Bad symbol for filehandle");
-    if (!GvIOp(gv))
+    if (!GvIOp(gv)) {
+#ifdef GV_SHARED_CHECK
+        if (GvSHARED(gv)) {
+            Perl_croak(aTHX_ "Bad symbol for filehandle (GV is shared)");
+        }
+#endif
 	GvIOp(gv) = newIO();
+    }
     return gv;
 }
 
 GV *
 Perl_gv_fetchfile(pTHX_ const char *name)
 {
-    dTHR;
     char smallbuf[256];
     char *tmpbuf;
     STRLEN tmplen;
@@ -85,7 +90,6 @@ Perl_gv_fetchfile(pTHX_ const char *name)
 void
 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
 {
-    dTHR;
     register GP *gp;
     bool doproto = SvTYPE(gv) > SVt_NULL;
     char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
@@ -121,7 +125,7 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
 	LEAVE;
 
 	PL_sub_generation++;
-	CvGV(GvCV(gv)) = (GV*)SvREFCNT_inc(gv);
+	CvGV(GvCV(gv)) = gv;
 	CvFILE(GvCV(gv)) = CopFILE(PL_curcop);
 	CvSTASH(GvCV(gv)) = PL_curstash;
 #ifdef USE_THREADS
@@ -227,7 +231,6 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 	    basestash = gv_stashpvn(packname, packlen, TRUE);
 	    gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
 	    if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
-		dTHR;		/* just for SvREFCNT_dec */
 		gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
 		if (!gvp || !(gv = *gvp))
 		    Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash));
@@ -247,7 +250,6 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 	    SV* sv = *svp++;
 	    HV* basestash = gv_stashsv(sv, FALSE);
 	    if (!basestash) {
-		dTHR;		/* just for ckWARN */
 		if (ckWARN(WARN_MISC))
 		    Perl_warner(aTHX_ WARN_MISC, "Can't locate package %s for @%s::ISA",
 			SvPVX(sv), HvNAME(stash));
@@ -342,7 +344,6 @@ C<call_sv> apply equally to these functions.
 GV *
 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
 {
-    dTHR;
     register const char *nend;
     const char *nsplit = 0;
     GV* gv;
@@ -403,7 +404,6 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
 GV*
 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
 {
-    dTHR;
     static char autoload[] = "AUTOLOAD";
     static STRLEN autolen = 8;
     GV* gv;
@@ -418,7 +418,7 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
 	return Nullgv;
     cv = GvCV(gv);
 
-    if (!CvROOT(cv))
+    if (!(CvROOT(cv) || CvXSUB(cv)))
 	return Nullgv;
 
     /*
@@ -430,6 +430,20 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
 	  "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
 	     HvNAME(stash), (int)len, name);
 
+#ifndef USE_THREADS
+    if (CvXSUB(cv)) {
+        /* rather than lookup/init $AUTOLOAD here
+         * only to have the XSUB do another lookup for $AUTOLOAD
+         * and split that value on the last '::',
+         * pass along the same data via some unused fields in the CV
+         */
+        CvSTASH(cv) = stash;
+        SvPVX(cv) = (char *)name; /* cast to loose constness warning */
+        SvCUR(cv) = len;
+        return gv;
+    }
+#endif
+
     /*
      * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
      * The subroutine's original name may not be "AUTOLOAD", so we don't
@@ -457,6 +471,28 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
     return gv;
 }
 
+/* The "gv" parameter should be the glob known to Perl code as *!
+ * The scalar must already have been magicalized.
+ */
+STATIC void
+S_require_errno(pTHX_ GV *gv)
+{
+    HV* stash = gv_stashpvn("Errno",5,FALSE);
+
+    if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) { 
+	dSP;
+	PUTBACK;
+	ENTER;
+	save_scalar(gv); /* keep the value of $! */
+	require_pv("Errno.pm");
+	LEAVE;
+	SPAGAIN;
+	stash = gv_stashpvn("Errno",5,FALSE);
+	if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
+	    Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
+    }
+}
+
 /*
 =for apidoc gv_stashpv
 
@@ -525,7 +561,6 @@ Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
 GV *
 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
 {
-    dTHR;
     register const char *name = nambeg;
     register GV *gv = 0;
     GV**gvp;
@@ -681,6 +716,8 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
 	if (add) {
 	    GvMULTI_on(gv);
 	    gv_init_sv(gv, sv_type);
+	    if (*name=='!' && sv_type == SVt_PVHV && len==1)
+		require_errno(gv);
 	}
 	return gv;
     } else if (add & GV_NOINIT) {
@@ -694,7 +731,8 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
     gv_init(gv, stash, name, len, add & GV_ADDMULTI);
     gv_init_sv(gv, sv_type);
 
-    if (isLEXWARN_on && isALPHA(name[0]) && ! ckWARN(WARN_ONCE))
+    if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) 
+			                    : (PL_dowarn & G_WARN_ON ) ) )
         GvMULTI_on(gv) ;
 
     /* set up magic where warranted */
@@ -743,20 +781,21 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
 	    HV *hv;
 	    I32 i;
 	    if (!PL_psig_ptr) {
-		int sig_num[] = { SIG_NUM };
-		New(73, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
-		New(73, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
+		Newz(73, PL_psig_ptr,  SIG_SIZE, SV*);
+		Newz(73, PL_psig_name, SIG_SIZE, SV*);
+		Newz(73, PL_psig_pend, SIG_SIZE, int);
 	    }
 	    GvMULTI_on(gv);
 	    hv = GvHVn(gv);
 	    hv_magic(hv, Nullgv, 'S');
-	    for (i = 1; PL_sig_name[i]; i++) {
+	    for (i = 1; i < SIG_SIZE; i++) {
 	    	SV ** init;
 	    	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;
 	    	PL_psig_name[i] = 0;
+	    	PL_psig_pend[i] = 0;
 	    }
 	}
 	break;
@@ -800,19 +839,19 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
     case '!':
 	if (len > 1)
 	    break;
-	if (sv_type > SVt_PV && PL_curcop != &PL_compiling) {
-	    HV* stash = gv_stashpvn("Errno",5,FALSE);
-	    if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
-		dSP;
-		PUTBACK;
-		require_pv("Errno.pm");
-		SPAGAIN;
-		stash = gv_stashpvn("Errno",5,FALSE);
-		if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
-		    Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
-	    }
-	}
-	goto magicalize;
+
+	/* If %! has been used, automatically load Errno.pm.
+	   The require will itself set errno, so in order to
+	   preserve its value we have to set up the magic
+	   now (rather than going to magicalize)
+	*/
+
+	sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
+
+	if (sv_type == SVt_PVHV)
+	    require_errno(gv);
+
+	break;
     case '-':
 	if (len > 1)
 	    break;
@@ -840,7 +879,6 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
     case ',':
     case '\\':
     case '/':
-    case '|':
     case '\001':	/* $^A */
     case '\003':	/* $^C */
     case '\004':	/* $^D */
@@ -848,12 +886,20 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
     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 '|':
+	if (len > 1)
+	    break;
+	sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
+	goto magicalize;
+    case '\017':	/* $^O & $^OPEN */
+	if (len > 1 && strNE(name, "\017PEN"))
+	    break;
+	goto magicalize;
     case '\023':	/* $^S */
 	if (len > 1)
 	    break;
@@ -992,7 +1038,6 @@ Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
 IO *
 Perl_newIO(pTHX)
 {
-    dTHR;
     IO *io;
     GV *iogv;
 
@@ -1011,7 +1056,6 @@ Perl_newIO(pTHX)
 void
 Perl_gv_check(pTHX_ HV *stash)
 {
-    dTHR;
     register HE *entry;
     register I32 i;
     register GV *gv;
@@ -1088,7 +1132,6 @@ Perl_gp_ref(pTHX_ GP *gp)
 void
 Perl_gp_free(pTHX_ GV *gv)
 {
-    dTHR;
     GP* gp;
 
     if (!gv || !(gp = GvGP(gv)))
@@ -1144,127 +1187,81 @@ register GV *gv;
 }
 #endif			/* Microport 2.4 hack */
 
+int
+Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
+{
+    AMT *amtp = (AMT*)mg->mg_ptr;
+    if (amtp && AMT_AMAGIC(amtp)) {
+	int i;
+	for (i = 1; i < NofAMmeth; i++) {
+	    CV *cv = amtp->table[i];
+	    if (cv != Nullcv) {
+		SvREFCNT_dec((SV *) cv);
+		amtp->table[i] = Nullcv;
+	    }
+	}
+    }
+ return 0;
+}
+
 /* Updates and caches the CV's */
 
 bool
 Perl_Gv_AMupdate(pTHX_ HV *stash)
 {
-  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)
-      return AMT_AMAGIC(amtp);
-  if (amtp && AMT_AMAGIC(amtp)) {	/* Have table. */
-    int i;
-    for (i=1; i<NofAMmeth; i++) {
-      if (amtp->table[i]) {
-	SvREFCNT_dec(amtp->table[i]);
-      }
-    }
-  }
+      return AMT_OVERLOADED(amtp);
   sv_unmagic((SV*)stash, 'c');
 
   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
 
+  Zero(&amt,1,AMT);
   amt.was_ok_am = PL_amagic_generation;
   amt.was_ok_sub = PL_sub_generation;
   amt.fallback = AMGfallNO;
   amt.flags = 0;
 
-#ifdef OVERLOAD_VIA_HASH
-  gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE);	/* A shortcut */
-  if (gvp && ((gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv)))) {
-    int filled=0;
-    int i;
-    char *cp;
-    SV* sv;
-    SV** svp;
-
-    /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
-
-    if (( cp = (char *)PL_AMG_names[0] ) &&
-	(svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) {
-      if (SvTRUE(sv)) amt.fallback=AMGfallYES;
-      else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
-    }
-    for (i = 1; i < NofAMmeth; i++) {
-      cv = 0;
-      cp = (char *)PL_AMG_names[i];
-
-        svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE);
-        if (svp && ((sv = *svp) != &PL_sv_undef)) {
-          switch (SvTYPE(sv)) {
-            default:
-              if (!SvROK(sv)) {
-                if (!SvOK(sv)) break;
-		gv = gv_fetchmethod(stash, SvPV(sv, n_a));
-                if (gv) cv = GvCV(gv);
-                break;
-              }
-              cv = (CV*)SvRV(sv);
-              if (SvTYPE(cv) == SVt_PVCV)
-                  break;
-                /* FALL THROUGH */
-            case SVt_PVHV:
-            case SVt_PVAV:
-	      Perl_croak(aTHX_ "Not a subroutine reference in overload table");
-	      return FALSE;
-            case SVt_PVCV:
-              cv = (CV*)sv;
-              break;
-            case SVt_PVGV:
-              if (!(cv = GvCVu((GV*)sv)))
-                cv = sv_2cv(sv, &stash, &gv, FALSE);
-              break;
-          }
-          if (cv) filled=1;
-	  else {
-	    Perl_croak(aTHX_ "Method for operation %s not found in package %.256s during blessing\n",
-		cp,HvNAME(stash));
-	    return FALSE;
-	  }
-        }
-#else
   {
-    int filled = 0;
-    int i;
-    const char *cp;
+    int filled = 0, have_ovl = 0;
+    int i, lim = 1;
     SV* sv = NULL;
 
     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
 
-    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;
-    }
+    /* Try to find via inheritance. */
+    gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
+    if (gv)
+	sv = GvSV(gv);
+
+    if (!gv)
+	lim = DESTROY_amg;		/* Skip overloading entries. */
+    else if (SvTRUE(sv))
+	amt.fallback=AMGfallYES;
+    else if (SvOK(sv))
+	amt.fallback=AMGfallNEVER;
+
+    for (i = 1; i < lim; i++)
+	amt.table[i] = Nullcv;
+    for (; i < NofAMmeth; i++) {
+	char *cooky = (char*)PL_AMG_names[i];
+	/* Human-readable form, for debugging: */
+	char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
+	STRLEN l = strlen(cooky);
 
-    for (i = 1; i < NofAMmeth; i++) {
-	SV *cookie = sv_2mortal(Perl_newSVpvf(aTHX_ "(%s", cp = PL_AMG_names[i]));
 	DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
 		     cp, HvNAME(stash)) );
 	/* don't fill the cache while looking up! */
-	gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1);
+	gv = gv_fetchmeth(stash, cooky, l, -1);
         cv = 0;
-        if(gv && (cv = GvCV(gv))) {
+        if (gv && (cv = GvCV(gv))) {
 	    if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
 		&& strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
 		/* GvSV contains the name of the method. */
@@ -1292,27 +1289,55 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
 			 cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
 			 GvNAME(CvGV(cv))) );
 	    filled = 1;
+	    if (i < DESTROY_amg)
+		have_ovl = 1;
 	}
-#endif
 	amt.table[i]=(CV*)SvREFCNT_inc(cv);
     }
     if (filled) {
       AMT_AMAGIC_on(&amt);
+      if (have_ovl)
+	  AMT_OVERLOADED_on(&amt);
       sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
-      return TRUE;
+      return have_ovl;
     }
   }
   /* Here we have no table: */
- no_table:
+  /* no_table: */
   AMT_AMAGIC_off(&amt);
   sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
   return FALSE;
 }
 
+
+CV*
+Perl_gv_handler(pTHX_ HV *stash, I32 id)
+{
+    dTHR;
+    MAGIC *mg;
+    AMT *amtp;
+
+    if (!stash)
+        return Nullcv;
+    mg = mg_find((SV*)stash,'c');
+    if (!mg) {
+      do_update:
+	Gv_AMupdate(stash);
+	mg = mg_find((SV*)stash,'c');
+    }
+    amtp = (AMT*)mg->mg_ptr;
+    if ( amtp->was_ok_am != PL_amagic_generation
+	 || amtp->was_ok_sub != PL_sub_generation )
+	goto do_update;
+    if (AMT_AMAGIC(amtp))
+	return amtp->table[id];
+    return Nullcv;
+}
+
+
 SV*
 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
 {
-  dTHR;
   MAGIC *mg;
   CV *cv;
   CV **cvp=NULL, **ocvp=NULL;
@@ -1416,6 +1441,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
 	     lr = 1;
 	   }
 	   break;
+	 case int_amg:
 	 case iter_amg:			/* XXXX Eventually should do to_gv. */
 	     /* FAIL safe */
 	     return NULL;	/* Delegate operation to standard mechanisms. */
@@ -1493,7 +1519,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
 	if (off==-1) off=method;
 	msg = sv_2mortal(Perl_newSVpvf(aTHX_
 		      "Operation `%s': no method found,%sargument %s%s%s%s",
-		      PL_AMG_names[method + assignshift],
+		      AMG_id2name(method + assignshift),
 		      (flags & AMGf_unary ? " " : "\n\tleft "),
 		      SvAMAGIC(left)?
 		        "in overloaded package ":
@@ -1522,11 +1548,11 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
   if (!notfound) {
     DEBUG_o( Perl_deb(aTHX_
   "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
-		 PL_AMG_names[off],
+		 AMG_id2name(off),
 		 method+assignshift==off? "" :
 		             " (initially `",
 		 method+assignshift==off? "" :
-		             PL_AMG_names[method+assignshift],
+		             AMG_id2name(method+assignshift),
 		 method+assignshift==off? "" : "')",
 		 flags & AMGf_unary? "" :
 		   lr==1 ? " for right argument": " for left argument",
@@ -1586,7 +1612,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
     PUSHs(lr>0? left: right);
     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
     if (notfound) {
-      PUSHs( sv_2mortal(newSVpv((char *)PL_AMG_names[method + assignshift],0)));
+      PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
     }
     PUSHs((SV*)cv);
     PUTBACK;
@@ -1672,6 +1698,13 @@ Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
 	if (len == 3 && strEQ(name, "SIG"))
 	    goto yes;
 	break;
+    case '\017':   /* $^O & $^OPEN */
+	if (len == 1
+	    || (len == 4 && strEQ(name, "\027PEN")))
+	{
+	    goto yes;
+	}
+	break;
     case '\027':   /* $^W & $^WARNING_BITS */
 	if (len == 1
 	    || (len == 12 && strEQ(name, "\027ARNING_BITS"))
@@ -1715,7 +1748,6 @@ Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
     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 */