From: Steve Grazzini Date: Wed, 18 Jun 2003 19:42:37 +0000 (-0400) Subject: Re: [perl #17934] tied STDERR and internal warnings X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7ff032551aa263179d4cb6df3dd91502d713e6ba;p=p5sagit%2Fp5-mst-13.2.git 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 --- 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 --- 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 --- 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 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 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 --- 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 --- 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 --- 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 --- 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 --- 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); } }