X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=gv.c;h=f48ef9855c74a31d4bf2763b9751ebcae16f18f2;hb=92a665d639a42192198e801676cccae0bd9afa83;hp=d56e8d06919c2c3e039e0c19c2783f76759a2b13;hpb=9e0d86f862e086b0fde6b64ca39c85508bf50910;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/gv.c b/gv.c
index d56e8d0..f48ef98 100644
--- a/gv.c
+++ b/gv.c
@@ -677,11 +677,11 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
  * that implements the logic of automatical ties like %! and %-
  *
  * The "gv" parameter should be the glob.
- * "varpv" holds the name of the var, used for error messages
- * "namesv" holds the module name
+ * "varpv" holds the name of the var, used for error messages.
+ * "namesv" holds the module name. Its refcount will be decremented.
  * "methpv" holds the method name to test for to check that things
- *   are working reasonably close to as expected
- * "flags" if flag & 1 then save the scalar before loading.
+ *   are working reasonably close to as expected.
+ * "flags": if flag & 1 then save the scalar before loading.
  * For the protection of $! to work (it is set by this routine)
  * the sv slot must already be magicalized.
  */
@@ -690,25 +690,30 @@ S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methp
 {
     dVAR;
     HV* stash = gv_stashsv(namesv, 0);
-    
+
     if (!stash || !(gv_fetchmethod(stash, methpv))) {
-        SV *module = newSVsv(namesv);
+	SV *module = newSVsv(namesv);
+	char varname = *varpv; /* varpv might be clobbered by load_module,
+				  so save it. For the moment it's always
+				  a single char. */
 	dSP;
-	PUTBACK;
 	ENTER;
 	if ( flags & 1 )
-	    save_scalar(gv); 
-        Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
+	    save_scalar(gv);
+	PUSHSTACKi(PERLSI_MAGIC);
+	Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
+	POPSTACK;
 	LEAVE;
 	SPAGAIN;
 	stash = gv_stashsv(namesv, 0);
 	if (!stash)
-	    Perl_croak( aTHX_ "panic: Can't use %%%s because %"SVf" is not available", 
-	        varpv, SVfARG(module));
-	else if (!gv_fetchmethod(stash, methpv))    
-	    Perl_croak( aTHX_ "panic: Can't use %%%s because %"SVf" does not support method %s", 
-	        varpv, SVfARG(module), methpv);
+	    Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" is not available",
+		    varname, SVfARG(namesv));
+	else if (!gv_fetchmethod(stash, methpv))
+	    Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" does not support method %s",
+		    varname, SVfARG(namesv), methpv);
     }
+    SvREFCNT_dec(namesv);
     return stash;
 }
 
@@ -996,14 +1001,12 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	if (add) {
 	    GvMULTI_on(gv);
 	    gv_init_sv(gv, sv_type);
-	    if (sv_type == SVt_PVHV && len == 1 ) {
+	    if (len == 1 && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) {
 	        if (*name == '!')
 		    require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
-		else
-		if (*name == '-' || *name == '+') 
-		     require_tie_mod(gv, name, newSVpvs("re::Tie::Hash::NamedCapture"), "FETCH", 0);
-		
-            }		    
+		else if (*name == '-' || *name == '+')
+		    require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "FETCH", 0);
+	    }
 	}
 	return gv;
     } else if (no_init) {
@@ -1188,13 +1191,13 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	    goto magicalize;
 
 	case '!':
-	GvMULTI_on(gv);    
+	    GvMULTI_on(gv);
 	    /* If %! has been used, automatically load Errno.pm. */
 
 	    sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
 
             /* magicalization must be done before require_tie_mod is called */
-	    if (sv_type == SVt_PVHV)
+	    if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
 		require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
 
 	    break;
@@ -1202,31 +1205,19 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	case '+':
 	GvMULTI_on(gv); /* no used once warnings here */
         {
-            bool plus = (*name == '+');
-            SV *stashname = newSVpvs("re::Tie::Hash::NamedCapture");
             AV* const av = GvAVn(gv);
-    	    HV *const hv = GvHVn(gv);
-    	    HV *const hv_tie = newHV();
-            SV *tie = newRV_noinc((SV*)hv_tie);
+	    SV* const avc = (*name == '+') ? (SV*)av : NULL;
 
-            sv_bless(tie, gv_stashsv(stashname,GV_ADD));
-            hv_magic(hv, (GV*)tie, PERL_MAGIC_tied);    
-            sv_magic((SV*)av, (plus ? (SV*)av : NULL), PERL_MAGIC_regdata, NULL, 0);
+	    sv_magic((SV*)av, avc, PERL_MAGIC_regdata, NULL, 0);
             sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
-
-            if (plus)
+            if (avc)
                 SvREADONLY_on(GvSVn(gv));
-            else
-                Perl_hv_store(aTHX_ hv_tie, STR_WITH_LEN("all"), newSViv(1), 0);
-            
-            SvREADONLY_on(hv);
-            SvREADONLY_on(tie);
             SvREADONLY_on(av);
-                
-            if (sv_type == SVt_PVHV) 
-                require_tie_mod(gv, name, stashname, "FETCH", 0);
 
-	    break;
+            if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
+                require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "FETCH", 0);
+
+            break;
 	}
 	case '*':
 	case '#':
@@ -1296,7 +1287,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"))
-		upg_version(PL_patchlevel);
+		upg_version(PL_patchlevel, TRUE);
 	    GvSV(gv) = vnumify(PL_patchlevel);
 	    SvREADONLY_on(GvSV(gv));
 	    SvREFCNT_dec(sv);