X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=mg.c;h=6418b2754b1ad571c1375d299402f97641d61ada;hb=b0ce926a45891e83ffb4badae874161f93c0eb49;hp=0e9ca198e7894c41f4179ddbc072cd4518db9670;hpb=6520202708b2a849ca8538ed88e0f75376c3b2d7;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/mg.c b/mg.c
index 0e9ca19..6418b27 100644
--- a/mg.c
+++ b/mg.c
@@ -33,6 +33,9 @@
 #  define VTBL			*vtbl
 #endif
 
+static void restore_magic(pTHXo_ void *p);
+static void unwind_handler_stack(pTHXo_ void *p);
+
 /*
  * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
  */
@@ -51,7 +54,7 @@ S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
     MGS* mgs;
     assert(SvMAGICAL(sv));
 
-    SAVEDESTRUCTOR(S_restore_magic, (void*)mgs_ix);
+    SAVEDESTRUCTOR(restore_magic, (void*)mgs_ix);
 
     mgs = SSPTR(mgs_ix, MGS*);
     mgs->mgs_sv = sv;
@@ -63,48 +66,6 @@ S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
     SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
 }
 
-STATIC void
-S_restore_magic(pTHX_ void *p)
-{
-    dTHR;
-    MGS* mgs = SSPTR((I32)p, MGS*);
-    SV* sv = mgs->mgs_sv;
-
-    if (!sv)
-        return;
-
-    if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
-    {
-	if (mgs->mgs_flags)
-	    SvFLAGS(sv) |= mgs->mgs_flags;
-	else
-	    mg_magical(sv);
-	if (SvGMAGICAL(sv))
-	    SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
-    }
-
-    mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
-
-    /* If we're still on top of the stack, pop us off.  (That condition
-     * will be satisfied if restore_magic was called explicitly, but *not*
-     * if it's being called via leave_scope.)
-     * The reason for doing this is that otherwise, things like sv_2cv()
-     * may leave alloc gunk on the savestack, and some code
-     * (e.g. sighandler) doesn't expect that...
-     */
-    if (PL_savestack_ix == mgs->mgs_ss_ix)
-    {
-	I32 popval = SSPOPINT;
-        assert(popval == SAVEt_DESTRUCTOR);
-        PL_savestack_ix -= 2;
-	popval = SSPOPINT;
-        assert(popval == SAVEt_ALLOC);
-	popval = SSPOPINT;
-        PL_savestack_ix -= popval;
-    }
-
-}
-
 void
 Perl_mg_magical(pTHX_ SV *sv)
 {
@@ -153,7 +114,7 @@ Perl_mg_get(pTHX_ SV *sv)
 	    mgp = &SvMAGIC(sv);	/* Re-establish pointer after sv_upgrade */
     }
 
-    restore_magic((void*)mgs_ix);
+    restore_magic(aTHXo_ (void*)mgs_ix);
     return 0;
 }
 
@@ -179,7 +140,7 @@ Perl_mg_set(pTHX_ SV *sv)
 	    (VTBL->svt_set)(aTHX_ sv, mg);
     }
 
-    restore_magic((void*)mgs_ix);
+    restore_magic(aTHXo_ (void*)mgs_ix);
     return 0;
 }
 
@@ -199,7 +160,7 @@ Perl_mg_length(pTHX_ SV *sv)
 	    save_magic(mgs_ix, sv);
 	    /* omit MGf_GSKIP -- not changed here */
 	    len = (VTBL->svt_len)(aTHX_ sv, mg);
-	    restore_magic((void*)mgs_ix);
+	    restore_magic(aTHXo_ (void*)mgs_ix);
 	    return len;
 	}
     }
@@ -223,7 +184,7 @@ Perl_mg_size(pTHX_ SV *sv)
 	    save_magic(mgs_ix, sv);
 	    /* omit MGf_GSKIP -- not changed here */
 	    len = (VTBL->svt_len)(aTHX_ sv, mg);
-	    restore_magic((void*)mgs_ix);
+	    restore_magic(aTHXo_ (void*)mgs_ix);
 	    return len;
 	}
     }
@@ -258,7 +219,7 @@ Perl_mg_clear(pTHX_ SV *sv)
 	    (VTBL->svt_clear)(aTHX_ sv, mg);
     }
 
-    restore_magic((void*)mgs_ix);
+    restore_magic(aTHXo_ (void*)mgs_ix);
     return 0;
 }
 
@@ -431,33 +392,6 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
     return 0;
 }
 
-#if 0
-static char * 
-printW(SV *sv)
-{
-#if 1
-    return "" ;
-
-#else
-    int i ;
-    static char buffer[50] ;
-    char buf1[20] ;
-    char * p ;
-
-
-    sprintf(buffer, "Buffer %d, Length = %d - ", sv, SvCUR(sv)) ;
-    p = SvPVX(sv) ;
-    for (i = 0; i < SvCUR(sv) ; ++ i) {
-        sprintf (buf1, " %x [%x]", (p+i), *(p+i)) ;
-	strcat(buffer, buf1) ;
-    } 
-
-    return buffer ;
-
-#endif
-}
-#endif
-
 int
 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 {
@@ -473,16 +407,17 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 	sv_setsv(sv, PL_bodytarget);
 	break;
     case '\002':		/* ^B */
-	/* printf("magic_get $^B: ") ; */
-	if (PL_curcop->cop_warnings == WARN_NONE)
-	    /* printf("WARN_NONE\n"), */
+	if (PL_curcop->cop_warnings == WARN_NONE ||
+	    PL_curcop->cop_warnings == WARN_STD)
+	{
 	    sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
-        else if (PL_curcop->cop_warnings == WARN_ALL)
-	    /* printf("WARN_ALL\n"), */
+        }
+        else if (PL_curcop->cop_warnings == WARN_ALL) {
 	    sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
-        else 
-	    /* printf("some %s\n", printW(PL_curcop->cop_warnings)), */
+	}    
+        else {
 	    sv_setsv(sv, PL_curcop->cop_warnings);
+	}    
 	break;
     case '\003':		/* ^C */
 	sv_setiv(sv, (IV)PL_minus_c);
@@ -576,7 +511,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 #endif
 	break;
     case '\027':		/* ^W */
-	sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) == G_WARN_ON));
+	sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
 	break;
     case '1': case '2': case '3': case '4':
     case '5': case '6': case '7': case '8': case '9': case '&':
@@ -893,7 +828,12 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
     }
     FreeEnvironmentStrings(envv);
 #  else
-#    ifndef PERL_USE_SAFE_PUTENV
+#    ifdef CYGWIN
+    I32 i;
+    for (i = 0; environ[i]; i++)
+       Safefree(environ[i]);
+#    else
+#      ifndef PERL_USE_SAFE_PUTENV
     I32 i;
 
     if (environ == PL_origenviron)
@@ -901,7 +841,8 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
     else
 	for (i = 0; environ[i]; i++)
 	    safesysfree(environ[i]);
-#    endif /* PERL_USE_SAFE_PUTENV */
+#      endif /* PERL_USE_SAFE_PUTENV */
+#    endif /* CYGWIN */
 
     environ[0] = Nullch;
 
@@ -1234,8 +1175,8 @@ Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
 		     atoi(MgPV(mg,n_a)), FALSE);
     if (svp && SvIOKp(*svp) && (o = (OP*)SvSTASH(*svp)))
 	o->op_private = i;
-    else
-	Perl_warn(aTHX_ "Can't break at that line\n");
+    else if (ckWARN_d(WARN_INTERNAL))
+	Perl_warner(aTHX_ WARN_INTERNAL, "Can't break at that line\n");
     return 0;
 }
 
@@ -1678,16 +1619,19 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	break;
     case '\002':	/* ^B */
 	if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
-            if (memEQ(SvPVX(sv), WARN_ALLstring, WARNsize))
+            if (memEQ(SvPVX(sv), WARN_ALLstring, WARNsize)) {
 	        PL_compiling.cop_warnings = WARN_ALL;
+	        PL_dowarn |= G_WARN_ONCE ;
+	    }	
 	    else if (memEQ(SvPVX(sv), WARN_NONEstring, WARNsize))
 	        PL_compiling.cop_warnings = WARN_NONE;
             else {
-	        if (PL_compiling.cop_warnings != WARN_NONE && 
-		    PL_compiling.cop_warnings != WARN_ALL)
-	            sv_setsv(PL_compiling.cop_warnings, sv);
-	        else
+	        if (specialWARN(PL_compiling.cop_warnings))
 		    PL_compiling.cop_warnings = newSVsv(sv) ;
+	        else
+	            sv_setsv(PL_compiling.cop_warnings, sv);
+	        if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
+	            PL_dowarn |= G_WARN_ONCE ;
 	    }
 	}
 	break;
@@ -1738,6 +1682,8 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	break;
     case '\020':	/* ^P */
 	PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
+	if (PL_perldb && !PL_DBsingle)
+	    init_debugger();
 	break;
     case '\024':	/* ^T */
 #ifdef BIG_TIME
@@ -1749,7 +1695,8 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
     case '\027':	/* ^W */
 	if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
 	    i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
-	    PL_dowarn = (i ? G_WARN_ON : G_WARN_OFF) ;
+	    PL_dowarn = (PL_dowarn & ~G_WARN_ON) 
+		    		| (i ? G_WARN_ON : G_WARN_OFF) ;
 	}
 	break;
     case '.':
@@ -1866,13 +1813,13 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	if (PL_uid == PL_euid)		/* special case $< = $> */
 	    (void)PerlProc_setuid(PL_uid);
 	else {
-	    PL_uid = (I32)PerlProc_getuid();
+	    PL_uid = PerlProc_getuid();
 	    Perl_croak(aTHX_ "setruid() not implemented");
 	}
 #endif
 #endif
 #endif
-	PL_uid = (I32)PerlProc_getuid();
+	PL_uid = PerlProc_getuid();
 	PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
 	break;
     case '>':
@@ -1893,13 +1840,13 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	if (PL_euid == PL_uid)		/* special case $> = $< */
 	    PerlProc_setuid(PL_euid);
 	else {
-	    PL_euid = (I32)PerlProc_geteuid();
+	    PL_euid = rlProc_geteuid();
 	    Perl_croak(aTHX_ "seteuid() not implemented");
 	}
 #endif
 #endif
 #endif
-	PL_euid = (I32)PerlProc_geteuid();
+	PL_euid = PerlProc_geteuid();
 	PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
 	break;
     case '(':
@@ -1920,13 +1867,13 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	if (PL_gid == PL_egid)			/* special case $( = $) */
 	    (void)PerlProc_setgid(PL_gid);
 	else {
-	    PL_gid = (I32)PerlProc_getgid();
+	    PL_gid = PerlProc_getgid();
 	    Perl_croak(aTHX_ "setrgid() not implemented");
 	}
 #endif
 #endif
 #endif
-	PL_gid = (I32)PerlProc_getgid();
+	PL_gid = PerlProc_getgid();
 	PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
 	break;
     case ')':
@@ -1937,7 +1884,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 
 	    while (isSPACE(*p))
 		++p;
-	    PL_egid = I_V(atol(p));
+	    PL_egid = I_V(Atol(p));
 	    for (i = 0; i < NGROUPS; ++i) {
 		while (*p && !isSPACE(*p))
 		    ++p;
@@ -1945,7 +1892,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 		    ++p;
 		if (!*p)
 		    break;
-		gary[i] = I_V(atol(p));
+		gary[i] = I_V(Atol(p));
 	    }
 	    if (i)
 		(void)setgroups(i, gary);
@@ -1969,13 +1916,13 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	if (PL_egid == PL_gid)			/* special case $) = $( */
 	    (void)PerlProc_setgid(PL_egid);
 	else {
-	    PL_egid = (I32)PerlProc_getegid();
+	    PL_egid = PerlProc_getegid();
 	    Perl_croak(aTHX_ "setegid() not implemented");
 	}
 #endif
 #endif
 #endif
-	PL_egid = (I32)PerlProc_getegid();
+	PL_egid = PerlProc_getegid();
 	PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
 	break;
     case ':':
@@ -2083,19 +2030,6 @@ Perl_whichsig(pTHX_ char *sig)
 
 static SV* sig_sv;
 
-STATIC void
-S_unwind_handler_stack(pTHX_ void *p)
-{
-    dTHR;
-    U32 flags = *(U32*)p;
-
-    if (flags & 1)
-	PL_savestack_ix -= 5; /* Unprotect save in progress. */
-    /* cxstack_ix-- Not needed, die already unwound it. */
-    if (flags & 64)
-	SvREFCNT_dec(sig_sv);
-}
-
 Signal_t
 Perl_sighandler(int sig)
 {
@@ -2128,7 +2062,7 @@ Perl_sighandler(int sig)
     if (flags & 1) {
 	PL_savestack_ix += 5;		/* Protect save in progress. */
 	o_save_i = PL_savestack_ix;
-	SAVEDESTRUCTOR(S_unwind_handler_stack, (void*)&flags);
+	SAVEDESTRUCTOR(unwind_handler_stack, (void*)&flags);
     }
     if (flags & 4) 
 	PL_markstack_ptr++;		/* Protect mark. */
@@ -2189,3 +2123,62 @@ cleanup:
 }
 
 
+#ifdef PERL_OBJECT
+#define NO_XSLOCKS
+#include "XSUB.h"
+#endif
+
+static void
+restore_magic(pTHXo_ void *p)
+{
+    dTHR;
+    MGS* mgs = SSPTR((I32)p, MGS*);
+    SV* sv = mgs->mgs_sv;
+
+    if (!sv)
+        return;
+
+    if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
+    {
+	if (mgs->mgs_flags)
+	    SvFLAGS(sv) |= mgs->mgs_flags;
+	else
+	    mg_magical(sv);
+	if (SvGMAGICAL(sv))
+	    SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
+    }
+
+    mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
+
+    /* If we're still on top of the stack, pop us off.  (That condition
+     * will be satisfied if restore_magic was called explicitly, but *not*
+     * if it's being called via leave_scope.)
+     * The reason for doing this is that otherwise, things like sv_2cv()
+     * may leave alloc gunk on the savestack, and some code
+     * (e.g. sighandler) doesn't expect that...
+     */
+    if (PL_savestack_ix == mgs->mgs_ss_ix)
+    {
+	I32 popval = SSPOPINT;
+        assert(popval == SAVEt_DESTRUCTOR);
+        PL_savestack_ix -= 2;
+	popval = SSPOPINT;
+        assert(popval == SAVEt_ALLOC);
+	popval = SSPOPINT;
+        PL_savestack_ix -= popval;
+    }
+
+}
+
+static void
+unwind_handler_stack(pTHXo_ void *p)
+{
+    dTHR;
+    U32 flags = *(U32*)p;
+
+    if (flags & 1)
+	PL_savestack_ix -= 5; /* Unprotect save in progress. */
+    /* cxstack_ix-- Not needed, die already unwound it. */
+    if (flags & 64)
+	SvREFCNT_dec(sig_sv);
+}