Change 19819 by [EMAIL PROTECTED] on 2003/06/19 14:08:13
Subject: [PATCH] Re: [perl #17934] tied STDERR and internal warnings
From: [EMAIL PROTECTED] (Steve Grazzini)
Date: Wed, 18 Jun 2003 19:42:37 -0400
Message-ID: <[EMAIL PROTECTED]>
Affected files ...
... //depot/perl/embed.fnc#87 edit
... //depot/perl/embed.h#404 edit
... //depot/perl/pod/perltie.pod#33 edit
... //depot/perl/pp_ctl.c#360 edit
... //depot/perl/proto.h#444 edit
... //depot/perl/t/op/runlevel.t#25 edit
... //depot/perl/t/op/tiehandle.t#10 edit
... //depot/perl/util.c#392 edit
Differences ...
==== //depot/perl/embed.fnc#87 (text) ====
Index: perl/embed.fnc
--- perl/embed.fnc#86~19786~ Sun Jun 15 00:41:23 2003
+++ perl/embed.fnc Thu Jun 19 07:08:13 2003
@@ -844,6 +844,7 @@
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
==== //depot/perl/embed.h#404 (text+w) ====
Index: perl/embed.h
--- perl/embed.h#403~19786~ Sun Jun 15 00:41:23 2003
+++ perl/embed.h Thu Jun 19 07:08:13 2003
@@ -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
@@ -3599,6 +3602,9 @@
#define watch(a) Perl_watch(aTHX_ a)
#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
==== //depot/perl/pod/perltie.pod#33 (text) ====
Index: perl/pod/perltie.pod
--- perl/pod/perltie.pod#32~19452~ Thu May 8 11:12:46 2003
+++ perl/pod/perltie.pod Thu Jun 19 07:08:13 2003
@@ -794,9 +794,16 @@
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.
==== //depot/perl/pp_ctl.c#360 (text) ====
Index: perl/pp_ctl.c
--- perl/pp_ctl.c#359~19801~ Mon Jun 16 15:47:28 2003
+++ perl/pp_ctl.c Thu Jun 19 07:08:13 2003
@@ -1329,8 +1329,6 @@
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 @@
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;
==== //depot/perl/proto.h#444 (text+w) ====
Index: perl/proto.h
--- perl/proto.h#443~19786~ Sun Jun 15 00:41:23 2003
+++ perl/proto.h Thu Jun 19 07:08:13 2003
@@ -806,6 +806,7 @@
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);
==== //depot/perl/t/op/runlevel.t#25 (xtext) ====
Index: perl/t/op/runlevel.t
--- perl/t/op/runlevel.t#24~16257~ Sun Apr 28 13:26:30 2002
+++ perl/t/op/runlevel.t Thu Jun 19 07:08:13 2003
@@ -374,3 +374,36 @@
}
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.
==== //depot/perl/t/op/tiehandle.t#10 (xtext) ====
Index: perl/t/op/tiehandle.t
--- perl/t/op/tiehandle.t#9~17716~ Mon Aug 12 04:29:53 2002
+++ perl/t/op/tiehandle.t Thu Jun 19 07:08:13 2003
@@ -77,7 +77,7 @@
use Symbol;
-print "1..40\n";
+print "1..41\n";
my $fh = gensym;
@@ -228,6 +228,11 @@
@expect = (PRINT => $ob,"sometext\n");
Implement::compare(PRINT => @received);
+
+ use warnings;
+ print undef;
+
+ ok($received[1] =~ /Use of uninitialized value/);
}
{
==== //depot/perl/util.c#392 (text) ====
Index: perl/util.c
--- perl/util.c#391~19772~ Sat Jun 14 00:07:38 2003
+++ perl/util.c Thu Jun 19 07:08:13 2003
@@ -977,6 +977,52 @@
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 @@
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 @@
CV *cv;
SV *msv;
STRLEN msglen;
- IO *io;
- MAGIC *mg;
msv = vmess(pat, args);
message = SvPV(msv, msglen);
@@ -1246,25 +1278,7 @@
}
}
- /* 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 @@
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 @@
return;
}
}
- {
- PerlIO *serr = Perl_error_log;
- PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
- (void)PerlIO_flush(serr);
- }
+ write_to_stderr(message, msglen);
}
}
End of Patch.
