strict errors in eval very hard to detect #480

p5pRT · 1999-09-06T12:21:34Z

Migrated from rt.perl.org#1321 (status was 'resolved')

Searchable as RT1321$

p5pRT · 1999-09-06T12:21:34Z

From tchrist@jhereg.perl.com

------- Forwarded Message

Date: Mon, 06 Sep 1999 04:51:55 GMT
From: Rick Delaney <rick.delaney@home.com>
Subject: Re: "use strict" errors are second-class exceptions?
Organization: @Home Network Canada
Newsgroups: comp.lang.perl.misc
Article: 251674 of comp.lang.perl.misc
X-Complaints-To: abuse@home.net
X-Trace: news1.rdc1.ab.home.com 936593515 24.65.44.96 (Sun, 05 Sep 1999 21:51:55 P
DT)
NNTP-Posting-Date: Sun, 05 Sep 1999 21:51:55 PDT

[posted & mailed]

Sean McAfee wrote:

perldiag classifies strictness violations in precisely the same category as
other trappable errors which put errors into $@ when encountered inside an
eval. In my admittedly not-totally-exhaustive perusal of the Perl docs,
I can't find any documented reason for this difference in behavior. Is this
then a bug?

Could be. This has been mentioned here a couple of times before.
Here's one of them

http://x46.deja.com/getdoc.xp?AN=483645444

I'm using Perl 5.005_03.

Man, what a bummer. It's rather crucial for the code I'm writing now to be
able to distinguish warnings from fatals.

I remember this trick from Mike Guy to check compilation with eval.

use strict;
my $code = 'FOO; print "made it\n";';
eval "die 'Compiled OK';$code";
print "failed strict\n" if $@ !~ /Compiled OK/;

It could still have side effects if you have BEGIN or use in $code,
though. And you have to eval again if you actually want to run $code.

I'd at least like to see $@ =~ /eval had compilation errors/ when the
code fails the strict test, even if all the warnings couldn't be jammed
in there.

- --
Rick Delaney
rick.delaney@home.com

------- End of Forwarded Message

Witness this code:

# warntester
use strict;

my($str,$retval);

$^W = 0; # absolutely no warnings
no warning; # ditto
no warning "all"; # paranoia

# XXX: this "can't" happen
$SIG{__WARN__} = sub { print "Leaked warning: @_\n" } ;

numout();

$str = q{ print $x };
$retval = eval $str;

if ($@) { print "eval #1 failed: $@\n" }
printf "retval #1 is %s\n", defined($retval)
? ($retval ? "true" : "false")
: "the undefined value";

$retval = eval $str;
if ($@) { print "eval #2 failed: $@\n" }
printf "retval #2 is %s\n",
defined($retval)
? ($retval ? "true" : "false")
: "the undefined value";

close STDOUT;
exit;

sub numout {
my $kid = open(STDOUT, "|-");
die "fork: $!" unless defined $kid;
return if $kid;
print "$.: $_" while <STDIN>;
exit;
}

That produces:

1: Leaked warning: Global symbol "$x" requires explicit package name at (eval 1) line 2.
2:
3: retval #1 is the undefined value
4: retval #2 is true

First of all, that shouldn't be a warning when it's going to terminate
the eval. Second of all, the rule is anything that terminates an eval
must set $@. This didn't. And no, the print of undef didn't return
undef, because print defined(print undef) produces 1. Thirdly, both
retvals should produce the same value, but don't. Fourthly, the error
is now forgotten about, because of the attempt to suppress duplicates.

This makes it impossible to employ the important strict pragma for a
certain class of problems. This is an important bug. I do not know
how to fix it, however, because you don't want to terminate the attempt
at compilation earlier than you really have to; otherwise, you don't
get as many errors out as once as possible. Nor do you get too many
duplicates (yes, the diagnostics pragma suppresses dups or semi-dups,
but the normal course of events doesn't.)

--tom

p5pRT · 2000-12-09T03:31:52Z

From @gsar

On Mon, 06 Sep 1999 10:21:08 MDT, Tom Christiansen wrote:

From: Rick Delaney <rick.delaney@home.com>
Subject: Re: "use strict" errors are second-class exceptions?

[posted & mailed]
[...]
I remember this trick from Mike Guy to check compilation with eval.

use strict;
my $code = 'FOO; print "made it\n";';
eval "die 'Compiled OK';$code";
print "failed strict\n" if $@ !~ /Compiled OK/;

It could still have side effects if you have BEGIN or use in $code,
though. And you have to eval again if you actually want to run $code.

I'd at least like to see $@ =~ /eval had compilation errors/ when the
code fails the strict test, even if all the warnings couldn't be jammed
in there.

- --
Rick Delaney
rick.delaney@home.com

------- End of Forwarded Message

Witness this code:

# warntester
use strict;

my($str,$retval);

$^W = 0; # absolutely no warnings
no warning; # ditto
no warning "all"; # paranoia
          \# XXX&#8203;: this "can't" happen
$SIG{__WARN__} = sub { print "Leaked warning: @_\n" } ;

numout();

$str = q{ print $x };
$retval = eval $str;

if ($@) { print "eval #1 failed: $@\n" }
printf "retval #1 is %s\n", defined($retval)
? ($retval ? "true" : "false")
: "the undefined value";

$retval = eval $str;
if ($@) { print "eval #2 failed: $@\n" }
printf "retval #2 is %s\n",
defined($retval)
? ($retval ? "true" : "false")
: "the undefined value";

close STDOUT;
exit;

sub numout {
my $kid = open(STDOUT, "|-");
die "fork: $!" unless defined $kid;
return if $kid;
print "$.: $_" while <STDIN>;
exit;
}

That produces:

1: Leaked warning: Global symbol "$x" requires explicit package name at (eval
1) line 2.
2:
3: retval #1 is the undefined value
4: retval #2 is true

First of all, that shouldn't be a warning when it's going to terminate
the eval. Second of all, the rule is anything that terminates an eval
must set $@. This didn't. And no, the print of undef didn't return
undef, because print defined(print undef) produces 1. Thirdly, both
retvals should produce the same value, but don't. Fourthly, the error
is now forgotten about, because of the attempt to suppress duplicates.

This makes it impossible to employ the important strict pragma for a
certain class of problems. This is an important bug. I do not know
how to fix it, however, because you don't want to terminate the attempt
at compilation earlier than you really have to; otherwise, you don't
get as many errors out as once as possible. Nor do you get too many
duplicates (yes, the diagnostics pragma suppresses dups or semi-dups,
but the normal course of events doesn't.)

Thanks for that test case. I think this patch addresses everything
you've identified.

Sarathy
gsar@activestate.com

Inline Patch

-----------------------------------8<-----------------------------------
Change 4197 by gsar@auger on 1999/09/20 03:06:10

	queue errors due to strictures rather than printing them as
	warnings; symbols that violate strictures do *not* end up in
	the symbol table anyway, making multiple evals of the same piece
	of code produce the same errors; errors indicate all locations
	of a global symbol rather than just the first one; these
	changes make compile-time failures within evals reliably
	visible via the return value or contents of $@, and trappable
	using __DIE__ hooks

Affected files ...

... //depot/perl/embed.h#126 edit
... //depot/perl/embed.pl#65 edit
... //depot/perl/embedvar.h#72 edit
... //depot/perl/ext/DynaLoader/dlutils.c#11 edit
... //depot/perl/ext/Thread/Thread.xs#44 edit
... //depot/perl/global.sym#110 edit
... //depot/perl/gv.c#71 edit
... //depot/perl/objXSUB.h#69 edit
... //depot/perl/op.c#193 edit
... //depot/perl/perl.c#167 edit
... //depot/perl/perlapi.c#18 edit
... //depot/perl/pp_ctl.c#148 edit
... //depot/perl/proto.h#157 edit
... //depot/perl/regcomp.c#98 edit
... //depot/perl/t/pragma/strict-refs#6 edit
... //depot/perl/t/pragma/strict-vars#6 edit
... //depot/perl/thrdvar.h#34 edit
... //depot/perl/toke.c#149 edit
... //depot/perl/util.c#148 edit

Differences ...

==== //depot/perl/embed.h#126 (text+w) ====
Index: perl/embed.h
--- perl/embed.h.~1~	Sun Sep 19 20:06:18 1999
+++ perl/embed.h	Sun Sep 19 20:06:18 1999
@@ -97,6 +97,7 @@
 #define die_nocontext		Perl_die_nocontext
 #define deb_nocontext		Perl_deb_nocontext
 #define form_nocontext		Perl_form_nocontext
+#define mess_nocontext		Perl_mess_nocontext
 #define warn_nocontext		Perl_warn_nocontext
 #define warner_nocontext	Perl_warner_nocontext
 #define newSVpvf_nocontext	Perl_newSVpvf_nocontext
@@ -364,6 +365,8 @@
 #define mem_collxfrm		Perl_mem_collxfrm
 #endif
 #define mess			Perl_mess
+#define vmess			Perl_vmess
+#define qerror			Perl_qerror
 #define mg_clear		Perl_mg_clear
 #define mg_copy			Perl_mg_copy
 #define mg_find			Perl_mg_find
@@ -1698,7 +1701,8 @@
 #if defined(USE_LOCALE_COLLATE)
 #define mem_collxfrm(a,b,c)	Perl_mem_collxfrm(aTHX_ a,b,c)
 #endif
-#define mess(a,b)		Perl_mess(aTHX_ a,b)
+#define vmess(a,b)		Perl_vmess(aTHX_ a,b)
+#define qerror(a)		Perl_qerror(aTHX_ a)
 #define mg_clear(a)		Perl_mg_clear(aTHX_ a)
 #define mg_copy(a,b,c,d)	Perl_mg_copy(aTHX_ a,b,c,d)
 #define mg_find(a,b)		Perl_mg_find(aTHX_ a,b)
@@ -2818,6 +2822,8 @@
 #define deb_nocontext		Perl_deb_nocontext
 #define Perl_form_nocontext	CPerlObj::Perl_form_nocontext
 #define form_nocontext		Perl_form_nocontext
+#define Perl_mess_nocontext	CPerlObj::Perl_mess_nocontext
+#define mess_nocontext		Perl_mess_nocontext
 #define Perl_warn_nocontext	CPerlObj::Perl_warn_nocontext
 #define warn_nocontext		Perl_warn_nocontext
 #define Perl_warner_nocontext	CPerlObj::Perl_warner_nocontext
@@ -3333,6 +3339,10 @@
 #endif
 #define Perl_mess		CPerlObj::Perl_mess
 #define mess			Perl_mess
+#define Perl_vmess		CPerlObj::Perl_vmess
+#define vmess			Perl_vmess
+#define Perl_qerror		CPerlObj::Perl_qerror
+#define qerror			Perl_qerror
 #define Perl_mg_clear		CPerlObj::Perl_mg_clear
 #define mg_clear		Perl_mg_clear
 #define Perl_mg_copy		CPerlObj::Perl_mg_copy
@@ -5365,6 +5375,7 @@
 #  define deb				Perl_deb_nocontext
 #  define die				Perl_die_nocontext
 #  define form				Perl_form_nocontext
+#  define mess				Perl_mess_nocontext
 #  define newSVpvf			Perl_newSVpvf_nocontext
 #  define sv_catpvf			Perl_sv_catpvf_nocontext
 #  define sv_setpvf			Perl_sv_setpvf_nocontext
@@ -5382,6 +5393,7 @@
 #  define Perl_die_nocontext		Perl_die
 #  define Perl_deb_nocontext		Perl_deb
 #  define Perl_form_nocontext		Perl_form
+#  define Perl_mess_nocontext		Perl_mess
 #  define Perl_newSVpvf_nocontext	Perl_newSVpvf
 #  define Perl_sv_catpvf_nocontext	Perl_sv_catpvf
 #  define Perl_sv_setpvf_nocontext	Perl_sv_setpvf

==== //depot/perl/embed.pl#65 (xtext) ====
Index: perl/embed.pl
--- perl/embed.pl.~1~	Sun Sep 19 20:06:18 1999
+++ perl/embed.pl	Sun Sep 19 20:06:18 1999
@@ -492,6 +492,7 @@
 #  define deb				Perl_deb_nocontext
 #  define die				Perl_die_nocontext
 #  define form				Perl_form_nocontext
+#  define mess				Perl_mess_nocontext
 #  define newSVpvf			Perl_newSVpvf_nocontext
 #  define sv_catpvf			Perl_sv_catpvf_nocontext
 #  define sv_setpvf			Perl_sv_setpvf_nocontext
@@ -509,6 +510,7 @@
 #  define Perl_die_nocontext		Perl_die
 #  define Perl_deb_nocontext		Perl_deb
 #  define Perl_form_nocontext		Perl_form
+#  define Perl_mess_nocontext		Perl_mess
 #  define Perl_newSVpvf_nocontext	Perl_newSVpvf
 #  define Perl_sv_catpvf_nocontext	Perl_sv_catpvf
 #  define Perl_sv_setpvf_nocontext	Perl_sv_setpvf
@@ -843,6 +845,7 @@
     Perl_warner			Perl_vwarner
     Perl_die			Perl_vdie
     Perl_form			Perl_vform
+    Perl_mess			Perl_vmess
     Perl_deb			Perl_vdeb
     Perl_newSVpvf		Perl_vnewSVpvf
     Perl_sv_setpvf		Perl_sv_vsetpvf
@@ -871,7 +874,6 @@
 		  ? '' : 'return ');
     my $emitval = '';
     if (@args and $args[$#args] =~ /\.\.\./) {
-	pop @args;
 	pop @aargs;
 	my $retarg = '';
 	my $ctxfunc = $func;
@@ -1049,6 +1051,7 @@
 np	|OP*	|die_nocontext	|const char* pat|...
 np	|void	|deb_nocontext	|const char* pat|...
 np	|char*	|form_nocontext	|const char* pat|...
+np	|SV*	|mess_nocontext	|const char* pat|...
 np	|void	|warn_nocontext	|const char* pat|...
 np	|void	|warner_nocontext|U32 err|const char* pat|...
 np	|SV*	|newSVpvf_nocontext|const char* pat|...
@@ -1326,7 +1329,9 @@
 #if defined(USE_LOCALE_COLLATE)
 p	|char*	|mem_collxfrm	|const char* s|STRLEN len|STRLEN* xlen
 #endif
-p	|SV*	|mess		|const char* pat|va_list* args
+p	|SV*	|mess		|const char* pat|...
+p	|SV*	|vmess		|const char* pat|va_list* args
+p	|void	|qerror		|SV* err
 p	|int	|mg_clear	|SV* sv
 p	|int	|mg_copy	|SV* sv|SV* nsv|const char* key|I32 klen
 p	|MAGIC*	|mg_find	|SV* sv|int type

==== //depot/perl/embedvar.h#72 (text+w) ====
Index: perl/embedvar.h
--- perl/embedvar.h.~1~	Sun Sep 19 20:06:18 1999
+++ perl/embedvar.h	Sun Sep 19 20:06:18 1999
@@ -51,6 +51,7 @@
 #define PL_dumpindent		(vTHX->Tdumpindent)
 #define PL_efloatbuf		(vTHX->Tefloatbuf)
 #define PL_efloatsize		(vTHX->Tefloatsize)
+#define PL_errors		(vTHX->Terrors)
 #define PL_extralen		(vTHX->Textralen)
 #define PL_firstgv		(vTHX->Tfirstgv)
 #define PL_formtarget		(vTHX->Tformtarget)
@@ -1000,6 +1001,7 @@
 #define PL_dumpindent		(aTHX->Tdumpindent)
 #define PL_efloatbuf		(aTHX->Tefloatbuf)
 #define PL_efloatsize		(aTHX->Tefloatsize)
+#define PL_errors		(aTHX->Terrors)
 #define PL_extralen		(aTHX->Textralen)
 #define PL_firstgv		(aTHX->Tfirstgv)
 #define PL_formtarget		(aTHX->Tformtarget)
@@ -1136,6 +1138,7 @@
 #define PL_Tdumpindent		PL_dumpindent
 #define PL_Tefloatbuf		PL_efloatbuf
 #define PL_Tefloatsize		PL_efloatsize
+#define PL_Terrors		PL_errors
 #define PL_Textralen		PL_extralen
 #define PL_Tfirstgv		PL_firstgv
 #define PL_Tformtarget		PL_formtarget

==== //depot/perl/ext/DynaLoader/dlutils.c#11 (text) ====
Index: perl/ext/DynaLoader/dlutils.c
--- perl/ext/DynaLoader/dlutils.c.~1~	Sun Sep 19 20:06:18 1999
+++ perl/ext/DynaLoader/dlutils.c	Sun Sep 19 20:06:18 1999
@@ -55,7 +55,7 @@
     /* This code is based on croak/warn, see mess() in util.c */
 
     va_start(args, pat);
-    msv = mess(pat, &args);
+    msv = vmess(pat, &args);
     va_end(args);
 
     message = SvPV(msv,len);

==== //depot/perl/ext/Thread/Thread.xs#44 (text) ====
Index: perl/ext/Thread/Thread.xs
--- perl/ext/Thread/Thread.xs.~1~	Sun Sep 19 20:06:18 1999
+++ perl/ext/Thread/Thread.xs	Sun Sep 19 20:06:18 1999
@@ -181,6 +181,7 @@
     SvREFCNT_dec(PL_rs);
     SvREFCNT_dec(PL_nrs);
     SvREFCNT_dec(PL_statname);
+    SvREFCNT_dec(PL_errors);
     Safefree(PL_screamfirst);
     Safefree(PL_screamnext);
     Safefree(PL_reg_start_tmp);

==== //depot/perl/global.sym#110 (text+w) ====
Index: perl/global.sym
--- perl/global.sym.~1~	Sun Sep 19 20:06:18 1999
+++ perl/global.sym	Sun Sep 19 20:06:18 1999
@@ -48,6 +48,7 @@
 Perl_die_nocontext
 Perl_deb_nocontext
 Perl_form_nocontext
+Perl_mess_nocontext
 Perl_warn_nocontext
 Perl_warner_nocontext
 Perl_newSVpvf_nocontext
@@ -296,6 +297,8 @@
 Perl_markstack_grow
 Perl_mem_collxfrm
 Perl_mess
+Perl_vmess
+Perl_qerror
 Perl_mg_clear
 Perl_mg_copy
 Perl_mg_find

==== //depot/perl/gv.c#71 (text) ====
Index: perl/gv.c
--- perl/gv.c.~1~	Sun Sep 19 20:06:18 1999
+++ perl/gv.c	Sun Sep 19 20:06:18 1999
@@ -568,26 +568,15 @@
     /* By this point we should have a stash and a name */
 
     if (!stash) {
-	if (!add)
-	    return Nullgv;
-	{
-	    char sv_type_char = ((sv_type == SVt_PV) ? '$'
-				 : (sv_type == SVt_PVAV) ? '@'
-				 : (sv_type == SVt_PVHV) ? '%'
-				 : 0);
-	    if (sv_type_char) 
-		Perl_warn(aTHX_ "Global symbol \"%c%s\" requires explicit package name",
-		     sv_type_char, name);
-	    else
-		Perl_warn(aTHX_ "Global symbol \"%s\" requires explicit package name",
-		     name);
+	if (add) {
+	    qerror(Perl_mess(aTHX_
+		 "Global symbol \"%s%s\" requires explicit package name",
+		 (sv_type == SVt_PV ? "$"
+		  : sv_type == SVt_PVAV ? "@"
+		  : sv_type == SVt_PVHV ? "%"
+		  : ""), name));
 	}
-	++PL_error_count;
-	stash = PL_curstash ? PL_curstash : PL_defstash;	/* avoid core dumps */
-	add_gvflags = ((sv_type == SVt_PV) ? GVf_IMPORTED_SV
-		       : (sv_type == SVt_PVAV) ? GVf_IMPORTED_AV
-		       : (sv_type == SVt_PVHV) ? GVf_IMPORTED_HV
-		       : 0);
+	return Nullgv;
     }
 
     if (!SvREFCNT(stash))	/* symbol table under destruction */

==== //depot/perl/objXSUB.h#69 (text+w) ====
Index: perl/objXSUB.h
--- perl/objXSUB.h.~1~	Sun Sep 19 20:06:18 1999
+++ perl/objXSUB.h	Sun Sep 19 20:06:18 1999
@@ -580,6 +580,8 @@
 #define PL_efloatbuf		(*Perl_Tefloatbuf_ptr(aTHXo))
 #undef  PL_efloatsize
 #define PL_efloatsize		(*Perl_Tefloatsize_ptr(aTHXo))
+#undef  PL_errors
+#define PL_errors		(*Perl_Terrors_ptr(aTHXo))
 #undef  PL_extralen
 #define PL_extralen		(*Perl_Textralen_ptr(aTHXo))
 #undef  PL_firstgv
@@ -1004,6 +1006,10 @@
 #define Perl_form_nocontext	pPerl->Perl_form_nocontext
 #undef  form_nocontext
 #define form_nocontext		Perl_form_nocontext
+#undef  Perl_mess_nocontext
+#define Perl_mess_nocontext	pPerl->Perl_mess_nocontext
+#undef  mess_nocontext
+#define mess_nocontext		Perl_mess_nocontext
 #undef  Perl_warn_nocontext
 #define Perl_warn_nocontext	pPerl->Perl_warn_nocontext
 #undef  warn_nocontext
@@ -2015,6 +2021,14 @@
 #define Perl_mess		pPerl->Perl_mess
 #undef  mess
 #define mess			Perl_mess
+#undef  Perl_vmess
+#define Perl_vmess		pPerl->Perl_vmess
+#undef  vmess
+#define vmess			Perl_vmess
+#undef  Perl_qerror
+#define Perl_qerror		pPerl->Perl_qerror
+#undef  qerror
+#define qerror			Perl_qerror
 #undef  Perl_mg_clear
 #define Perl_mg_clear		pPerl->Perl_mg_clear
 #undef  mg_clear

==== //depot/perl/op.c#193 (text) ====
Index: perl/op.c
--- perl/op.c.~1~	Sun Sep 19 20:06:18 1999
+++ perl/op.c	Sun Sep 19 20:06:18 1999
@@ -96,9 +96,9 @@
 STATIC void
 S_no_bareword_allowed(pTHX_ OP *o)
 {
-    Perl_warn(aTHX_ "Bareword \"%s\" not allowed while \"strict subs\" in use",
-	  SvPV_nolen(cSVOPo->op_sv));
-    ++PL_error_count;
+    qerror(Perl_mess(aTHX_
+		     "Bareword \"%s\" not allowed while \"strict subs\" in use",
+		     SvPV_nolen(cSVOPo->op_sv)));
 }
 
 /* "register" allocation */

==== //depot/perl/perl.c#167 (text) ====
Index: perl/perl.c
--- perl/perl.c.~1~	Sun Sep 19 20:06:18 1999
+++ perl/perl.c	Sun Sep 19 20:06:18 1999
@@ -443,6 +443,10 @@
     PL_defstash = 0;
     SvREFCNT_dec(hv);
 
+    /* clear queued errors */
+    SvREFCNT_dec(PL_errors);
+    PL_errors = Nullsv;
+
     FREETMPS;
     if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
 	if (PL_scopestack_ix != 0)

==== //depot/perl/perlapi.c#18 (text+w) ====
Index: perl/perlapi.c
--- perl/perlapi.c.~1~	Sun Sep 19 20:06:18 1999
+++ perl/perlapi.c	Sun Sep 19 20:06:18 1999
@@ -314,7 +314,7 @@
 
 #undef  Perl_croak
 void
-Perl_croak(pTHXo_ const char* pat)
+Perl_croak(pTHXo_ const char* pat, ...)
 {
     va_list args;
     va_start(args, pat);
@@ -332,7 +332,7 @@
 
 #undef  Perl_croak_nocontext
 void
-Perl_croak_nocontext(const char* pat)
+Perl_croak_nocontext(const char* pat, ...)
 {
     dTHXo;
     va_list args;
@@ -343,7 +343,7 @@
 
 #undef  Perl_die_nocontext
 OP*
-Perl_die_nocontext(const char* pat)
+Perl_die_nocontext(const char* pat, ...)
 {
     dTHXo;
     OP* retval;
@@ -357,7 +357,7 @@
 
 #undef  Perl_deb_nocontext
 void
-Perl_deb_nocontext(const char* pat)
+Perl_deb_nocontext(const char* pat, ...)
 {
     dTHXo;
     va_list args;
@@ -368,7 +368,7 @@
 
 #undef  Perl_form_nocontext
 char*
-Perl_form_nocontext(const char* pat)
+Perl_form_nocontext(const char* pat, ...)
 {
     dTHXo;
     char* retval;
@@ -379,10 +379,24 @@
     return retval;
 
 }
+
+#undef  Perl_mess_nocontext
+SV*
+Perl_mess_nocontext(const char* pat, ...)
+{
+    dTHXo;
+    SV* retval;
+    va_list args;
+    va_start(args, pat);
+    retval = ((CPerlObj*)pPerl)->Perl_vmess(pat, &args);
+    va_end(args);
+    return retval;
 
+}
+
 #undef  Perl_warn_nocontext
 void
-Perl_warn_nocontext(const char* pat)
+Perl_warn_nocontext(const char* pat, ...)
 {
     dTHXo;
     va_list args;
@@ -393,7 +407,7 @@
 
 #undef  Perl_warner_nocontext
 void
-Perl_warner_nocontext(U32 err, const char* pat)
+Perl_warner_nocontext(U32 err, const char* pat, ...)
 {
     dTHXo;
     va_list args;
@@ -404,7 +418,7 @@
 
 #undef  Perl_newSVpvf_nocontext
 SV*
-Perl_newSVpvf_nocontext(const char* pat)
+Perl_newSVpvf_nocontext(const char* pat, ...)
 {
     dTHXo;
     SV* retval;
@@ -418,7 +432,7 @@
 
 #undef  Perl_sv_catpvf_nocontext
 void
-Perl_sv_catpvf_nocontext(SV* sv, const char* pat)
+Perl_sv_catpvf_nocontext(SV* sv, const char* pat, ...)
 {
     dTHXo;
     va_list args;
@@ -429,7 +443,7 @@
 
 #undef  Perl_sv_setpvf_nocontext
 void
-Perl_sv_setpvf_nocontext(SV* sv, const char* pat)
+Perl_sv_setpvf_nocontext(SV* sv, const char* pat, ...)
 {
     dTHXo;
     va_list args;
@@ -440,7 +454,7 @@
 
 #undef  Perl_sv_catpvf_mg_nocontext
 void
-Perl_sv_catpvf_mg_nocontext(SV* sv, const char* pat)
+Perl_sv_catpvf_mg_nocontext(SV* sv, const char* pat, ...)
 {
     dTHXo;
     va_list args;
@@ -451,7 +465,7 @@
 
 #undef  Perl_sv_setpvf_mg_nocontext
 void
-Perl_sv_setpvf_mg_nocontext(SV* sv, const char* pat)
+Perl_sv_setpvf_mg_nocontext(SV* sv, const char* pat, ...)
 {
     dTHXo;
     va_list args;
@@ -570,7 +584,7 @@
 
 #undef  Perl_deb
 void
-Perl_deb(pTHXo_ const char* pat)
+Perl_deb(pTHXo_ const char* pat, ...)
 {
     va_list args;
     va_start(args, pat);
@@ -636,7 +650,7 @@
 
 #undef  Perl_die
 OP*
-Perl_die(pTHXo_ const char* pat)
+Perl_die(pTHXo_ const char* pat, ...)
 {
     OP* retval;
     va_list args;
@@ -1014,7 +1028,7 @@
 
 #undef  Perl_form
 char*
-Perl_form(pTHXo_ const char* pat)
+Perl_form(pTHXo_ const char* pat, ...)
 {
     char* retval;
     va_list args;
@@ -2171,10 +2185,30 @@
 #endif
 
 #undef  Perl_mess
+SV*
+Perl_mess(pTHXo_ const char* pat, ...)
+{
+    SV* retval;
+    va_list args;
+    va_start(args, pat);
+    retval = ((CPerlObj*)pPerl)->Perl_vmess(pat, &args);
+    va_end(args);
+    return retval;
+
+}
+
+#undef  Perl_vmess
 SV*
-Perl_mess(pTHXo_ const char* pat, va_list* args)
+Perl_vmess(pTHXo_ const char* pat, va_list* args)
+{
+    return ((CPerlObj*)pPerl)->Perl_vmess(pat, args);
+}
+
+#undef  Perl_qerror
+void
+Perl_qerror(pTHXo_ SV* err)
 {
-    return ((CPerlObj*)pPerl)->Perl_mess(pat, args);
+    ((CPerlObj*)pPerl)->Perl_qerror(err);
 }
 
 #undef  Perl_mg_clear
@@ -2688,7 +2722,7 @@
 
 #undef  Perl_newSVpvf
 SV*
-Perl_newSVpvf(pTHXo_ const char* pat)
+Perl_newSVpvf(pTHXo_ const char* pat, ...)
 {
     SV* retval;
     va_list args;
@@ -3713,7 +3747,7 @@
 
 #undef  Perl_sv_catpvf
 void
-Perl_sv_catpvf(pTHXo_ SV* sv, const char* pat)
+Perl_sv_catpvf(pTHXo_ SV* sv, const char* pat, ...)
 {
     va_list args;
     va_start(args, pat);
@@ -3991,7 +4025,7 @@
 
 #undef  Perl_sv_setpvf
 void
-Perl_sv_setpvf(pTHXo_ SV* sv, const char* pat)
+Perl_sv_setpvf(pTHXo_ SV* sv, const char* pat, ...)
 {
     va_list args;
     va_start(args, pat);
@@ -4299,7 +4333,7 @@
 
 #undef  Perl_warn
 void
-Perl_warn(pTHXo_ const char* pat)
+Perl_warn(pTHXo_ const char* pat, ...)
 {
     va_list args;
     va_start(args, pat);
@@ -4316,7 +4350,7 @@
 
 #undef  Perl_warner
 void
-Perl_warner(pTHXo_ U32 err, const char* pat)
+Perl_warner(pTHXo_ U32 err, const char* pat, ...)
 {
     va_list args;
     va_start(args, pat);
@@ -4515,7 +4549,7 @@
 
 #undef  Perl_sv_catpvf_mg
 void
-Perl_sv_catpvf_mg(pTHXo_ SV *sv, const char* pat)
+Perl_sv_catpvf_mg(pTHXo_ SV *sv, const char* pat, ...)
 {
     va_list args;
     va_start(args, pat);
@@ -4553,7 +4587,7 @@
 
 #undef  Perl_sv_setpvf_mg
 void
-Perl_sv_setpvf_mg(pTHXo_ SV *sv, const char* pat)
+Perl_sv_setpvf_mg(pTHXo_ SV *sv, const char* pat, ...)
 {
     va_list args;
     va_start(args, pat);
@@ -4640,7 +4674,7 @@
 
 #undef  Perl_dump_indent
 void
-Perl_dump_indent(pTHXo_ I32 level, PerlIO *file, const char* pat)
+Perl_dump_indent(pTHXo_ I32 level, PerlIO *file, const char* pat, ...)
 {
     va_list args;
     va_start(args, pat);
@@ -4713,7 +4747,7 @@
 
 #undef  Perl_default_protect
 void*
-Perl_default_protect(pTHXo_ int *excpt, protect_body_t body)
+Perl_default_protect(pTHXo_ int *excpt, protect_body_t body, ...)
 {
     void* retval;
     va_list args;

==== //depot/perl/pp_ctl.c#148 (text) ====
Index: perl/pp_ctl.c
--- perl/pp_ctl.c.~1~	Sun Sep 19 20:06:18 1999
+++ perl/pp_ctl.c	Sun Sep 19 20:06:18 1999
@@ -1247,6 +1247,18 @@
     }
 }
 
+void
+Perl_qerror(pTHX_ SV *err)
+{
+    if (PL_in_eval)
+	sv_catsv(ERRSV, err);
+    else if (PL_errors)
+	sv_catsv(PL_errors, err);
+    else
+	Perl_warn(aTHX_ "%_", err);
+    ++PL_error_count;
+}
+
 OP *
 Perl_die_where(pTHX_ char *message, STRLEN msglen)
 {
@@ -1288,7 +1300,9 @@
 	else
 	    message = SvPVx(ERRSV, msglen);
 
-	while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) {
+	while ((cxix = dopoptoeval(cxstack_ix)) < 0
+	       && PL_curstackinfo->si_prev)
+	{
 	    dounwind(-1);
 	    POPSTACK;
 	}
@@ -1315,7 +1329,8 @@
 
 	    if (optype == OP_REQUIRE) {
 		char* msg = SvPVx(ERRSV, n_a);
-		DIE(aTHX_ "%s", *msg ? msg : "Compilation failed in require");
+		DIE(aTHX_ "%sCompilation failed in require",
+		    *msg ? msg : "Unknown error\n");
 	    }
 	    return pop_return();
 	}
@@ -2625,13 +2640,16 @@
 	LEAVE;
 	if (optype == OP_REQUIRE) {
 	    char* msg = SvPVx(ERRSV, n_a);
-	    DIE(aTHX_ "%s", *msg ? msg : "Compilation failed in require");
-	} else if (startop) {
+	    DIE(aTHX_ "%sCompilation failed in require",
+		*msg ? msg : "Unknown error\n");
+	}
+	else if (startop) {
 	    char* msg = SvPVx(ERRSV, n_a);
 
 	    POPBLOCK(cx,PL_curpm);
 	    POPEVAL(cx);
-	    Perl_croak(aTHX_ "%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
+	    Perl_croak(aTHX_ "%sCompilation failed in regexp",
+		       (*msg ? msg : "Unknown error\n"));
 	}
 	SvREFCNT_dec(PL_rs);
 	PL_rs = SvREFCNT_inc(PL_nrs);

==== //depot/perl/proto.h#157 (text+w) ====
Index: perl/proto.h
--- perl/proto.h.~1~	Sun Sep 19 20:06:18 1999
+++ perl/proto.h	Sun Sep 19 20:06:18 1999
@@ -56,6 +56,7 @@
 VIRTUAL OP*	Perl_die_nocontext(const char* pat, ...);
 VIRTUAL void	Perl_deb_nocontext(const char* pat, ...);
 VIRTUAL char*	Perl_form_nocontext(const char* pat, ...);
+VIRTUAL SV*	Perl_mess_nocontext(const char* pat, ...);
 VIRTUAL void	Perl_warn_nocontext(const char* pat, ...);
 VIRTUAL void	Perl_warner_nocontext(U32 err, const char* pat, ...);
 VIRTUAL SV*	Perl_newSVpvf_nocontext(const char* pat, ...);
@@ -322,7 +323,9 @@
 #if defined(USE_LOCALE_COLLATE)
 VIRTUAL char*	Perl_mem_collxfrm(pTHX_ const char* s, STRLEN len, STRLEN* xlen);
 #endif
-VIRTUAL SV*	Perl_mess(pTHX_ const char* pat, va_list* args);
+VIRTUAL SV*	Perl_mess(pTHX_ const char* pat, ...);
+VIRTUAL SV*	Perl_vmess(pTHX_ const char* pat, va_list* args);
+VIRTUAL void	Perl_qerror(pTHX_ SV* err);
 VIRTUAL int	Perl_mg_clear(pTHX_ SV* sv);
 VIRTUAL int	Perl_mg_copy(pTHX_ SV* sv, SV* nsv, const char* key, I32 klen);
 VIRTUAL MAGIC*	Perl_mg_find(pTHX_ SV* sv, int type);

==== //depot/perl/regcomp.c#98 (text) ====
Index: perl/regcomp.c
--- perl/regcomp.c.~1~	Sun Sep 19 20:06:18 1999
+++ perl/regcomp.c	Sun Sep 19 20:06:18 1999
@@ -3395,7 +3395,7 @@
 #else
     va_start(args);
 #endif
-    msv = mess(buf, &args);
+    msv = vmess(buf, &args);
     va_end(args);
     message = SvPV(msv,l1);
     if (l1 > 512)

==== //depot/perl/t/pragma/strict-refs#6 (text) ====
Index: perl/t/pragma/strict-refs
--- perl/t/pragma/strict-refs.~1~	Sun Sep 19 20:06:18 1999
+++ perl/t/pragma/strict-refs	Sun Sep 19 20:06:18 1999
@@ -196,6 +196,7 @@
 require "./abc";
 EXPECT
 Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at ./abc line 2.
+Compilation failed in require at - line 2.
 ########
 
 --FILE-- abc.pm
@@ -207,6 +208,7 @@
 use abc;
 EXPECT
 Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at abc.pm line 2.
+Compilation failed in require at - line 2.
 BEGIN failed--compilation aborted at - line 2.
 ########
 

==== //depot/perl/t/pragma/strict-vars#6 (text) ====
Index: perl/t/pragma/strict-vars
--- perl/t/pragma/strict-vars.~1~	Sun Sep 19 20:06:18 1999
+++ perl/t/pragma/strict-vars	Sun Sep 19 20:06:18 1999
@@ -165,6 +165,7 @@
 $joe = 1 ;
 EXPECT
 Global symbol "$joe" requires explicit package name at - line 5.
+Global symbol "$joe" requires explicit package name at - line 8.
 Execution of - aborted due to compilation errors.
 ########
 
@@ -221,3 +222,18 @@
 EXPECT
 Global symbol "$joe" requires explicit package name at - line 8.
 Execution of - aborted due to compilation errors.
+########
+
+# Check if multiple evals produce same errors
+use strict 'vars';
+my $ret = eval q{ print $x; };
+print $@;
+print "ok 1\n" unless defined $ret;
+$ret = eval q{ print $x; };
+print $@;
+print "ok 2\n" unless defined $ret;
+EXPECT
+Global symbol "$x" requires explicit package name at (eval 1) line 1.
+ok 1
+Global symbol "$x" requires explicit package name at (eval 2) line 1.
+ok 2

==== //depot/perl/thrdvar.h#34 (text) ====
Index: perl/thrdvar.h
--- perl/thrdvar.h.~1~	Sun Sep 19 20:06:18 1999
+++ perl/thrdvar.h	Sun Sep 19 20:06:18 1999
@@ -101,6 +101,7 @@
 PERLVAR(Ttop_env,	JMPENV *)	/* ptr. to current sigjmp() environment */
 PERLVAR(Tstart_env,	JMPENV)		/* empty startup sigjmp() environment */
 PERLVARI(Tprotect,	protect_proc_t,	MEMBER_TO_FPTR(Perl_default_protect))
+PERLVARI(Terrors,	SV *, Nullsv)	/* outstanding queued errors */
 
 /* statics "owned" by various functions */
 PERLVAR(Tav_fetch_sv,	SV *)		/* owned by av_fetch() */

==== //depot/perl/toke.c#149 (text) ====
Index: perl/toke.c
--- perl/toke.c.~1~	Sun Sep 19 20:06:18 1999
+++ perl/toke.c	Sun Sep 19 20:06:18 1999
@@ -6897,7 +6897,6 @@
 Perl_yywarn(pTHX_ char *s)
 {
     dTHR;
-    --PL_error_count;
     PL_in_eval |= EVAL_WARNONLY;
     yyerror(s);
     PL_in_eval &= ~EVAL_WARNONLY;
@@ -6977,11 +6976,9 @@
     }
     if (PL_in_eval & EVAL_WARNONLY)
 	Perl_warn(aTHX_ "%_", msg);
-    else if (PL_in_eval)
-	sv_catsv(ERRSV, msg);
     else
-	PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
-    if (++PL_error_count >= 10)
+	qerror(msg);
+    if (PL_error_count >= 10)
 	Perl_croak(aTHX_ "%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
     PL_in_my = 0;
     PL_in_my_stash = Nullhv;

==== //depot/perl/util.c#148 (text) ====
Index: perl/util.c
--- perl/util.c.~1~	Sun Sep 19 20:06:18 1999
+++ perl/util.c	Sun Sep 19 20:06:18 1999
@@ -1379,8 +1379,33 @@
     return SvPVX(sv);
 }
 
+#if defined(PERL_IMPLICIT_CONTEXT)
 SV *
-Perl_mess(pTHX_ const char *pat, va_list *args)
+Perl_mess_nocontext(const char *pat, ...)
+{
+    dTHX;
+    SV *retval;
+    va_list args;
+    va_start(args, pat);
+    retval = vmess(pat, &args);
+    va_end(args);
+    return retval;
+}
+#endif /* PERL_IMPLICIT_CONTEXT */
+
+SV *
+Perl_mess(pTHX_ const char *pat, ...)
+{
+    SV *retval;
+    va_list args;
+    va_start(args, pat);
+    retval = vmess(pat, &args);
+    va_end(args);
+    return retval;
+}
+
+SV *
+Perl_vmess(pTHX_ const char *pat, va_list *args)
 {
     SV *sv = mess_alloc();
     static char dgd[] = " during global destruction.\n";
@@ -1438,8 +1463,14 @@
 			  thr, PL_curstack, PL_mainstack));
 
     if (pat) {
-	msv = mess(pat, args);
-	message = SvPV(msv,msglen);
+	msv = vmess(pat, args);
+	if (PL_errors && SvCUR(PL_errors)) {
+	    sv_catsv(PL_errors, msv);
+	    message = SvPV(PL_errors, msglen);
+	    SvCUR_set(PL_errors, 0);
+	}
+	else
+	    message = SvPV(msv,msglen);
     }
     else {
 	message = Nullch;
@@ -1528,10 +1559,19 @@
     CV *cv;
     SV *msv;
     STRLEN msglen;
+
+    msv = vmess(pat, args);
+    if (PL_errors && SvCUR(PL_errors)) {
+	sv_catsv(PL_errors, msv);
+	message = SvPV(PL_errors, msglen);
+	SvCUR_set(PL_errors, 0);
+    }
+    else
+	message = SvPV(msv,msglen);
 
-    msv = mess(pat, args);
-    message = SvPV(msv,msglen);
-    DEBUG_S(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message));
+    DEBUG_S(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s",
+			  (unsigned long) thr, message));
+
     if (PL_diehook) {
 	/* sv_2cv might call Perl_croak() */
 	SV *olddiehook = PL_diehook;
@@ -1609,7 +1649,7 @@
     SV *msv;
     STRLEN msglen;
 
-    msv = mess(pat, args);
+    msv = vmess(pat, args);
     message = SvPV(msv, msglen);
 
     if (PL_warnhook) {
@@ -1705,7 +1745,7 @@
     SV *msv;
     STRLEN msglen;
 
-    msv = mess(pat, args);
+    msv = vmess(pat, args);
     message = SvPV(msv, msglen);
 
     if (ckDEAD(err)) {
@@ -3370,6 +3410,7 @@
     PL_restartop = 0;
 
     PL_statname = NEWSV(66,0);
+    PL_errors = newSVpvn("", 0);
     PL_maxscream = -1;
     PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
     PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
End of Patch.

p5pRT closed this as completed Nov 28, 2003

p5pRT added Severity Fatal type-library labels Oct 18, 2019

This was referenced Oct 18, 2019

Segmentation fault in recursive FETCH #6314

Closed

Program terminated with signal 11, Segmentation fault. #12469

Closed

perl doesn't handle m{}g for >= 2GB files even with largefiles and 64bitall #12807

Closed

Provide feedback

Saved searches

Use saved searches to filter your results more quickly

strict errors in eval very hard to detect #480

strict errors in eval very hard to detect #480

p5pRT commented Sep 6, 1999

p5pRT commented Sep 6, 1999

p5pRT commented Dec 9, 2000

strict errors in eval very hard to detect #480

strict errors in eval very hard to detect #480

Comments

p5pRT commented Sep 6, 1999

p5pRT commented Sep 6, 1999

From tchrist@jhereg.perl.com

p5pRT commented Dec 9, 2000

From @gsar