X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=gv.c;h=c73d503d5f4776d5db92d648996721dd489be78f;hb=9d79914594fed2aeeee07968feace7d26f9332c9;hp=8f9395f070d8d2fe52e9e05208bf4b0057a1698a;hpb=89ffc314668a83ba2b452e1498a0e37c4453876e;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/gv.c b/gv.c
index 8f9395f..c73d503 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.
@@ -412,7 +412,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;
 
     /*
@@ -424,6 +424,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
@@ -736,20 +750,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;
@@ -1141,6 +1156,23 @@ 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
@@ -1155,27 +1187,20 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
 
   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;
 
   {
-    int filled = 0;
-    int i;
+    int filled = 0, have_ovl = 0;
+    int i, lim = 1;
     const char *cp;
     SV* sv = NULL;
 
@@ -1187,15 +1212,18 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
 	sv = GvSV(gv);
 
     if (!gv)
-	goto no_table;
+	lim = DESTROY_amg;		/* Skip overloading entries. */
     else if (SvTRUE(sv))
 	amt.fallback=AMGfallYES;
     else if (SvOK(sv))
 	amt.fallback=AMGfallNEVER;
 
-    for (i = 1; i < NofAMmeth; i++) {
-	char *cooky = PL_AMG_names[i];
-	char *cp = AMG_id2name(i); /* Human-readable form, for debugging */
+    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);
 
 	DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
@@ -1231,13 +1259,17 @@ 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;
 	}
 	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: */
@@ -1247,6 +1279,32 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
   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)
 {
@@ -1353,6 +1411,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. */