Re: [perl #17934] tied STDERR and internal warnings

Message-ID: <20030618234237.GA6267@grazzini.net>

p4raw-id: //depot/perl@19819

1 files changed, 50 insertions, 44 deletions

diff --git a/util.c b/util.c
index 597452c426..f6d64490e5 100644
--- a/util.c
+++ b/util.c
@@ -977,6 +977,52 @@ Perl_vmess(pTHX_ const char *pat, va_list *args)
     return sv;
 }
 
+void
+Perl_write_to_stderr(pTHX_ const char* message, int msglen)
+{
+    IO *io;
+    MAGIC *mg;
+
+    if (PL_stderrgv && SvREFCNT(PL_stderrgv) 
+	&& (io = GvIO(PL_stderrgv))
+	&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) 
+    {
+	dSP;
+	ENTER;
+	SAVETMPS;
+
+	save_re_context();
+	SAVESPTR(PL_stderrgv);
+	PL_stderrgv = Nullgv;
+
+	PUSHSTACKi(PERLSI_MAGIC);
+
+	PUSHMARK(SP);
+	EXTEND(SP,2);
+	PUSHs(SvTIED_obj((SV*)io, mg));
+	PUSHs(sv_2mortal(newSVpvn(message, msglen)));
+	PUTBACK;
+	call_method("PRINT", G_SCALAR);
+
+	POPSTACK;
+	FREETMPS;
+	LEAVE;
+    }
+    else {
+#ifdef USE_SFIO
+	/* SFIO can really mess with your errno */
+	int e = errno;
+#endif
+	PerlIO *serr = Perl_error_log;
+
+	PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
+	(void)PerlIO_flush(serr);
+#ifdef USE_SFIO
+	errno = e;
+#endif
+    }
+}
+
 OP *
 Perl_vdie(pTHX_ const char* pat, va_list *args)
 {
@@ -1144,19 +1190,7 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args)
     else if (!message)
 	message = SvPVx(ERRSV, msglen);
 
-    {
-#ifdef USE_SFIO
-	/* SFIO can really mess with your errno */
-	int e = errno;
-#endif
-	PerlIO *serr = Perl_error_log;
-
-	PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
-	(void)PerlIO_flush(serr);
-#ifdef USE_SFIO
-	errno = e;
-#endif
-    }
+    write_to_stderr(message, msglen);
     my_failure_exit();
 }
 
@@ -1211,8 +1245,6 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args)
     CV *cv;
     SV *msv;
     STRLEN msglen;
-    IO *io;
-    MAGIC *mg;
 
     msv = vmess(pat, args);
     message = SvPV(msv, msglen);
@@ -1246,25 +1278,7 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args)
 	}
     }
 
-    /* if STDERR is tied, use it instead */
-    if (PL_stderrgv && SvREFCNT(PL_stderrgv) && (io = GvIO(PL_stderrgv))
-	&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
-	dSP; ENTER;
-	PUSHMARK(SP);
-	XPUSHs(SvTIED_obj((SV*)io, mg));
-	XPUSHs(sv_2mortal(newSVpvn(message, msglen)));
-	PUTBACK;
-	call_method("PRINT", G_SCALAR);
-	LEAVE;
-	return;
-    }
-
-    {
-	PerlIO *serr = Perl_error_log;
-
-	PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
-	(void)PerlIO_flush(serr);
-    }
+    write_to_stderr(message, msglen);
 }
 
 #if defined(PERL_IMPLICIT_CONTEXT)
@@ -1364,11 +1378,7 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
 	    PL_restartop = die_where(message, msglen);
 	    JMPENV_JUMP(3);
 	}
-	{
-	    PerlIO *serr = Perl_error_log;
-	    PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
-	    (void)PerlIO_flush(serr);
-	}
+	write_to_stderr(message, msglen);
 	my_failure_exit();
     }
     else {
@@ -1400,11 +1410,7 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
 		return;
 	    }
 	}
-	{
-	    PerlIO *serr = Perl_error_log;
-	    PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
-	    (void)PerlIO_flush(serr);
-	}
+	write_to_stderr(message, msglen);
     }
 }