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

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

p4raw-id: //depot/perl@19819

8 files changed, 108 insertions, 74 deletions

diff --git a/embed.fnc b/embed.fnc
index be08619186..d7acddde7f 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -844,6 +844,7 @@ Afp	|void	|warner		|U32 err|const char* pat|...
 Ap	|void	|vwarner	|U32 err|const char* pat|va_list* args
 p	|void	|watch		|char** addr
 Ap	|I32	|whichsig	|char* sig
+p	|void	|write_to_stderr|const char* message|int msglen
 p	|int	|yyerror	|char* s
 #ifdef USE_PURE_BISON
 p	|int	|yylex_r	|YYSTYPE *lvalp|int *lcharp
diff --git a/embed.h b/embed.h
index 5907e20af5..b1541c7b49 100644
--- a/embed.h
+++ b/embed.h
@@ -1124,6 +1124,9 @@
 #endif
 #define whichsig		Perl_whichsig
 #ifdef PERL_CORE
+#define write_to_stderr		Perl_write_to_stderr
+#endif
+#ifdef PERL_CORE
 #define yyerror			Perl_yyerror
 #endif
 #ifdef USE_PURE_BISON
@@ -3600,6 +3603,9 @@
 #endif
 #define whichsig(a)		Perl_whichsig(aTHX_ a)
 #ifdef PERL_CORE
+#define write_to_stderr(a,b)	Perl_write_to_stderr(aTHX_ a,b)
+#endif
+#ifdef PERL_CORE
 #define yyerror(a)		Perl_yyerror(aTHX_ a)
 #endif
 #ifdef USE_PURE_BISON
diff --git a/pod/perltie.pod b/pod/perltie.pod
index 3665f0420e..8f3a6774ae 100644
--- a/pod/perltie.pod
+++ b/pod/perltie.pod
@@ -794,9 +794,16 @@ READ, and possibly CLOSE, UNTIE and DESTROY.  The class can also provide: BINMOD
 OPEN, EOF, FILENO, SEEK, TELL - if the corresponding perl operators are
 used on the handle.
 
-It is especially useful when perl is embedded in some other program,
-where output to STDOUT and STDERR may have to be redirected in some
-special way. See nvi and the Apache module for examples.
+When STDERR is tied, its PRINT method will be called to issue warnings
+and error messages.  This feature is temporarily disabled during the call, 
+which means you can use C<warn()> inside PRINT without starting a recursive
+loop.  And just like C<__WARN__> and C<__DIE__> handlers, STDERR's PRINT
+method may be called to report parser errors, so the caveats mentioned under 
+L<perlvar/%SIG> apply.
+
+All of this is especially useful when perl is embedded in some other 
+program, where output to STDOUT and STDERR may have to be redirected 
+in some special way.  See nvi and the Apache module for examples.
 
 In our example we're going to create a shouting handle.
 
diff --git a/pp_ctl.c b/pp_ctl.c
index 42fea5904e..30e7b1356a 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1329,8 +1329,6 @@ OP *
 Perl_die_where(pTHX_ char *message, STRLEN msglen)
 {
     STRLEN n_a;
-    IO *io;
-    MAGIC *mg;
 
     if (PL_in_eval) {
 	I32 cxix;
@@ -1412,30 +1410,7 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen)
     if (!message)
 	message = SvPVx(ERRSV, msglen);
 
-    /* if STDERR is tied, print to it instead */
-    if (PL_stderrgv && (io = GvIOp(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;
-    }
-    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
-    }
+    write_to_stderr(message, msglen);
     my_failure_exit();
     /* NOTREACHED */
     return 0;
diff --git a/proto.h b/proto.h
index 1f03b3bdaa..01e96ffb80 100644
--- a/proto.h
+++ b/proto.h
@@ -806,6 +806,7 @@ PERL_CALLCONV void	Perl_warner(pTHX_ U32 err, const char* pat, ...)
 PERL_CALLCONV void	Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args);
 PERL_CALLCONV void	Perl_watch(pTHX_ char** addr);
 PERL_CALLCONV I32	Perl_whichsig(pTHX_ char* sig);
+PERL_CALLCONV void	Perl_write_to_stderr(pTHX_ const char* message, int msglen);
 PERL_CALLCONV int	Perl_yyerror(pTHX_ char* s);
 #ifdef USE_PURE_BISON
 PERL_CALLCONV int	Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp);
diff --git a/t/op/runlevel.t b/t/op/runlevel.t
index fffe103836..531b862fd8 100755
--- a/t/op/runlevel.t
+++ b/t/op/runlevel.t
@@ -374,3 +374,36 @@ sub d {
 }
 EXPECT
 0
+########
+sub TIEHANDLE { bless {} }
+sub PRINT { next }
+
+tie *STDERR, '';
+{ map ++$_, 1 }
+
+EXPECT
+Can't "next" outside a loop block at - line 2.
+########
+sub TIEHANDLE { bless {} }
+sub PRINT { print "[TIE] $_[1]" }
+
+tie *STDERR, '';
+die "DIE\n";
+
+EXPECT
+[TIE] DIE
+########
+sub TIEHANDLE { bless {} }
+sub PRINT { 
+    (split(/./, 'x'x10000))[0];
+    eval('die("test\n")');
+    warn "[TIE] $_[1]";
+}
+open OLDERR, '>&STDERR';
+tie *STDERR, '';
+
+use warnings FATAL => qw(uninitialized);
+print undef;
+
+EXPECT
+[TIE] Use of uninitialized value in print at - line 11.
diff --git a/t/op/tiehandle.t b/t/op/tiehandle.t
index 818cecf185..3442e6bc3e 100755
--- a/t/op/tiehandle.t
+++ b/t/op/tiehandle.t
@@ -77,7 +77,7 @@ package main;
 
 use Symbol;
 
-print "1..40\n";
+print "1..41\n";
 
 my $fh = gensym;
 
@@ -228,6 +228,11 @@ ok($r == 1);
     @expect = (PRINT => $ob,"sometext\n");
 
     Implement::compare(PRINT => @received);
+
+    use warnings;
+    print undef;
+
+    ok($received[1] =~ /Use of uninitialized value/);
 }
 
 {
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);
     }
 }