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

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

p4raw-id: //depot/perl@19819

diff --git a/embed.fnc b/embed.fnc
index be08619..d7acddd 100644 (file)
--- 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 5907e20..b1541c7 100644 (file)
--- 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 3665f04..8f3a677 100644 (file)
--- 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 42fea59..30e7b13 100644 (file)
--- 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 1f03b3b..01e96ff 100644 (file)
--- 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 fffe103..531b862 100755 (executable)
--- 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 818cecf..3442e6b 100755 (executable)
--- 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 597452c..f6d6449 100644 (file)
--- 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);
     }
 }