Perl / perl5

🐪 The Perl programming language
https://dev.perl.org/perl5/
Other
1.93k stars 551 forks source link

strict errors in eval very hard to detect #480

Closed p5pRT closed 20 years ago

p5pRT commented 25 years ago

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

Searchable as RT1321$

p5pRT commented 25 years ago

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 \;   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 commented 23 years ago

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​: 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 \; 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 ```diff -----------------------------------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. ```