Change 19823 by [EMAIL PROTECTED] on 2003/06/19 14:51:22
Integrate:
[ 19818]
Subject: [PATCH -current] email address correction
Date: Thu, 19 Jun 2003 02:19:31 -0700
Message-ID: <[EMAIL PROTECTED]>
From: [EMAIL PROTECTED] (Richard Soderberg)
[ 19819]
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]>
[ 19820]
Upgrade to MakeMaker 6.10_07 (from makemaker.org snapshot
as of 2003-06-19 18:39 EET).
[ 19821]
A tweak from Alan Burlison for MM 6.10_07 that makes Solaris
make happy.
[ 19822]
This change chunk doesn't work well with blead.
Affected files ...
... //depot/maint-5.8/perl/embed.fnc#30 integrate
... //depot/maint-5.8/perl/embed.h#33 integrate
... //depot/maint-5.8/perl/ext/threads/threads.pm#3 integrate
... //depot/maint-5.8/perl/lib/ExtUtils/MM_Any.pm#8 integrate
... //depot/maint-5.8/perl/lib/ExtUtils/MM_OS2.pm#4 integrate
... //depot/maint-5.8/perl/lib/ExtUtils/MM_Unix.pm#9 integrate
... //depot/maint-5.8/perl/lib/ExtUtils/MM_VMS.pm#7 integrate
... //depot/maint-5.8/perl/lib/ExtUtils/MakeMaker.pm#7 integrate
... //depot/maint-5.8/perl/lib/ExtUtils/t/Command.t#3 integrate
... //depot/maint-5.8/perl/lib/ExtUtils/t/MM_OS2.t#4 integrate
... //depot/maint-5.8/perl/lib/ExtUtils/t/MM_Unix.t#3 integrate
... //depot/maint-5.8/perl/pod/perltie.pod#5 integrate
... //depot/maint-5.8/perl/pp_ctl.c#28 integrate
... //depot/maint-5.8/perl/proto.h#28 integrate
... //depot/maint-5.8/perl/t/op/runlevel.t#2 integrate
... //depot/maint-5.8/perl/t/op/tiehandle.t#3 integrate
... //depot/maint-5.8/perl/util.c#22 integrate
Differences ...
==== //depot/maint-5.8/perl/embed.fnc#30 (text) ====
Index: perl/embed.fnc
--- perl/embed.fnc#29~19791~ Sun Jun 15 10:57:06 2003
+++ perl/embed.fnc Thu Jun 19 07:51:22 2003
@@ -859,6 +859,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/maint-5.8/perl/embed.h#33 (text+w) ====
Index: perl/embed.h
--- perl/embed.h#32~19791~ Sun Jun 15 10:57:06 2003
+++ perl/embed.h Thu Jun 19 07:51:22 2003
@@ -1144,6 +1144,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
@@ -3642,6 +3645,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/maint-5.8/perl/ext/threads/threads.pm#3 (xtext) ====
Index: perl/ext/threads/threads.pm
--- perl/ext/threads/threads.pm#2~19256~ Thu Apr 17 11:26:24 2003
+++ perl/ext/threads/threads.pm Thu Jun 19 07:51:22 2003
@@ -280,7 +280,7 @@
Thanks to
-Richard Soderberg E<lt>rs at crystalflame.netE<gt>
+Richard Soderberg E<lt>perl at crystalflame.netE<gt>
Helping me out tons, trying to find reasons for races and other weird bugs!
Simon Cozens E<lt>simon at brecon.co.ukE<gt>
==== //depot/maint-5.8/perl/lib/ExtUtils/MM_Any.pm#8 (text) ====
Index: perl/lib/ExtUtils/MM_Any.pm
--- perl/lib/ExtUtils/MM_Any.pm#7~19722~ Mon Jun 9 10:52:25 2003
+++ perl/lib/ExtUtils/MM_Any.pm Thu Jun 19 07:51:22 2003
@@ -490,7 +490,7 @@
sub libscan {
my($self,$path) = @_;
my($dirs,$file) = ($self->splitpath($path))[1,2];
- return '' if grep /^RCS|CVS|SCCS|\.svn$/,
+ return '' if grep /^(?:RCS|CVS|SCCS|\.svn)$/,
$self->splitdir($dirs), $file;
return $path;
==== //depot/maint-5.8/perl/lib/ExtUtils/MM_OS2.pm#4 (text) ====
Index: perl/lib/ExtUtils/MM_OS2.pm
--- perl/lib/ExtUtils/MM_OS2.pm#3~19165~ Tue Apr 8 10:43:04 2003
+++ perl/lib/ExtUtils/MM_OS2.pm Thu Jun 19 07:51:22 2003
@@ -130,9 +130,9 @@
$self->{PERL_ARCHIVE} = "\$(PERL_INC)/libperl\$(LIB_EXT)";
- $self->{PERL_ARCHIVE_AFTER} = !$OS2::is_aout
- ? "\$(PERL_INC)/libperl_override\$(LIB_EXT)"
- : '';
+ $self->{PERL_ARCHIVE_AFTER} = $OS2::is_aout
+ ? ''
+ : '$(PERL_INC)/libperl_override$(LIB_EXT)';
$self->{EXPORT_LIST} = '$(BASEEXT).def';
}
==== //depot/maint-5.8/perl/lib/ExtUtils/MM_Unix.pm#9 (text) ====
Index: perl/lib/ExtUtils/MM_Unix.pm
--- perl/lib/ExtUtils/MM_Unix.pm#8~19704~ Fri Jun 6 22:24:27 2003
+++ perl/lib/ExtUtils/MM_Unix.pm Thu Jun 19 07:51:22 2003
@@ -792,7 +792,7 @@
my $date_check = $self->oneliner(<<'CODE', ['-l']);
print 'Warning: Makefile possibly out of date with $(VERSION_FROM)'
- if -e '$(VERSION_FROM)' and -M '$(VERSION_FROM)' < -M '$(FIRST_MAKEFILE)';
+ if -e '$(VERSION_FROM)' and -M '$(VERSION_FROM)' < -M '$(FIRST_MAKEFILE)';
CODE
return sprintf <<'MAKE_FRAG', $date_check;
@@ -2591,8 +2591,7 @@
} . ($Is_Win32
? q{FIXIN = pl2bat.bat
-} : q{FIXIN = $(PERLRUN) "-MExtUtils::MY" \
- -e "MY->fixin(shift)"
+} : q{FIXIN = $(PERLRUN) "-MExtUtils::MY" -e "MY->fixin(shift)"
}).qq{
pure_all :: @to
\$(NOECHO) \$(NOOP)
@@ -3566,7 +3565,8 @@
$cmd =~ s{^\n+}{};
$cmd =~ s{\n+$}{};
- $cmd = $self->quote_literal($cmd);
+ my @cmds = split /\n/, $cmd;
+ $cmd = join " \n\t-e ", map $self->quote_literal($_), @cmds;
$cmd = $self->escape_newlines($cmd);
$switches = join ' ', @$switches;
==== //depot/maint-5.8/perl/lib/ExtUtils/MM_VMS.pm#7 (text) ====
Index: perl/lib/ExtUtils/MM_VMS.pm
--- perl/lib/ExtUtils/MM_VMS.pm#6~19611~ Sat May 24 00:50:43 2003
+++ perl/lib/ExtUtils/MM_VMS.pm Thu Jun 19 07:51:22 2003
@@ -21,7 +21,7 @@
use File::Basename;
use vars qw($Revision @ISA $VERSION);
($VERSION) = '5.67';
-($Revision) = q$Revision: 1.95 $ =~ /Revision:\s+(\S+)/;
+($Revision) = q$Revision: 1.97 $ =~ /Revision:\s+(\S+)/;
require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
==== //depot/maint-5.8/perl/lib/ExtUtils/MakeMaker.pm#7 (text) ====
Index: perl/lib/ExtUtils/MakeMaker.pm
--- perl/lib/ExtUtils/MakeMaker.pm#6~19704~ Fri Jun 6 22:24:27 2003
+++ perl/lib/ExtUtils/MakeMaker.pm Thu Jun 19 07:51:22 2003
@@ -2,8 +2,8 @@
BEGIN {require 5.005_03;}
-$VERSION = '6.10_05';
-($Revision) = q$Revision: 1.115 $ =~ /Revision:\s+(\S+)/;
+$VERSION = '6.10_07';
+($Revision) = q$Revision: 1.117 $ =~ /Revision:\s+(\S+)/;
require Exporter;
use Config;
@@ -2029,7 +2029,7 @@
$VERSION = '1.00';
*VERSION = \'1.01';
- $VERSION = sprintf "%d.%03d", q$Revision: 1.115 $ =~ /(\d+)/g;
+ $VERSION = sprintf "%d.%03d", q$Revision: 1.117 $ =~ /(\d+)/g;
$FOO::VERSION = '1.10';
*FOO::VERSION = \'1.11';
our $VERSION = 1.2.3; # new for perl5.6.0
==== //depot/maint-5.8/perl/lib/ExtUtils/t/MM_OS2.t#4 (text) ====
Index: perl/lib/ExtUtils/t/MM_OS2.t
--- perl/lib/ExtUtils/t/MM_OS2.t#3~19791~ Sun Jun 15 10:57:06 2003
+++ perl/lib/ExtUtils/t/MM_OS2.t Thu Jun 19 07:51:22 2003
@@ -259,12 +259,13 @@
local *OS2::is_aout;
*OS2::is_aout = \$aout;
- $mm->init_linker;
+ $mm->init_linker;
isnt( $mm->{PERL_ARCHIVE_AFTER}, '',
'PERL_ARCHIVE_AFTER should be empty without $is_aout set' );
$aout = 1;
- is( $mm->{PERL_ARCHIVE_AFTER}, '$(PERL_INC)/libperl_override$(LIB_EXT)',
- '... and `$(PERL_INC)/libperl_override$(LIB_EXT)\' if it is set' );
+ is( $mm->{PERL_ARCHIVE_AFTER},
+ '$(PERL_INC)/libperl_override$(LIB_EXT)',
+ '... and has libperl_override if it is set' );
}
# EXPORT_LIST
==== //depot/maint-5.8/perl/lib/ExtUtils/t/MM_Unix.t#3 (text) ====
Index: perl/lib/ExtUtils/t/MM_Unix.t
--- perl/lib/ExtUtils/t/MM_Unix.t#2~19103~ Mon Mar 31 02:41:09 2003
+++ perl/lib/ExtUtils/t/MM_Unix.t Thu Jun 19 07:51:22 2003
@@ -18,7 +18,7 @@
plan skip_all => 'Non-Unix platform';
}
else {
- plan tests => 115;
+ plan tests => 116;
}
}
@@ -167,7 +167,8 @@
is ($t->libscan('CVS/bar/car'), '', 'libscan on CVS');
is ($t->libscan('SCCS'), '', 'libscan on SCCS');
is ($t->libscan('.svn/something'), '', 'libscan on Subversion');
-is ($t->libscan('foo/b~r'), 'foo/b~r', 'libscan on file with ~');
+is ($t->libscan('foo/b~r'), 'foo/b~r', 'libscan on file with ~');
+is ($t->libscan('foo/RCS.pm'), 'foo/RCS.pm', 'libscan on file with RCS');
is ($t->libscan('Fatty'), 'Fatty', 'libscan on something not a VC file' );
==== //depot/maint-5.8/perl/pod/perltie.pod#5 (text) ====
Index: perl/pod/perltie.pod
--- perl/pod/perltie.pod#4~19515~ Tue May 13 10:51:05 2003
+++ perl/pod/perltie.pod Thu Jun 19 07:51:22 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/maint-5.8/perl/pp_ctl.c#28 (text) ====
Index: perl/pp_ctl.c
--- perl/pp_ctl.c#27~19803~ Mon Jun 16 22:18:41 2003
+++ perl/pp_ctl.c Thu Jun 19 07:51:22 2003
@@ -1302,8 +1302,6 @@
Perl_die_where(pTHX_ char *message, STRLEN msglen)
{
STRLEN n_a;
- IO *io;
- MAGIC *mg;
if (PL_in_eval) {
I32 cxix;
@@ -1385,30 +1383,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/maint-5.8/perl/proto.h#28 (text+w) ====
Index: perl/proto.h
--- perl/proto.h#27~19791~ Sun Jun 15 10:57:06 2003
+++ perl/proto.h Thu Jun 19 07:51:22 2003
@@ -821,6 +821,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/maint-5.8/perl/t/op/runlevel.t#2 (xtext) ====
Index: perl/t/op/runlevel.t
--- perl/t/op/runlevel.t#1~17645~ Fri Jul 19 12:29:57 2002
+++ perl/t/op/runlevel.t Thu Jun 19 07:51:22 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/maint-5.8/perl/t/op/tiehandle.t#3 (xtext) ====
Index: perl/t/op/tiehandle.t
--- perl/t/op/tiehandle.t#2~18080~ Sun Nov 3 21:23:04 2002
+++ perl/t/op/tiehandle.t Thu Jun 19 07:51:22 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/maint-5.8/perl/util.c#22 (text) ====
Index: perl/util.c
--- perl/util.c#21~19774~ Sat Jun 14 01:06:18 2003
+++ perl/util.c Thu Jun 19 07:51:22 2003
@@ -981,6 +981,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)
{
@@ -1148,19 +1194,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();
}
@@ -1215,8 +1249,6 @@
CV *cv;
SV *msv;
STRLEN msglen;
- IO *io;
- MAGIC *mg;
msv = vmess(pat, args);
message = SvPV(msv, msglen);
@@ -1250,25 +1282,7 @@
}
}
- /* if STDERR is tied, use 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;
- 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)
@@ -1371,11 +1385,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 {
@@ -1407,11 +1417,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.
