summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGurusamy Sarathy <gsar@cpan.org>1999-09-20 03:06:10 +0000
committerGurusamy Sarathy <gsar@cpan.org>1999-09-20 03:06:10 +0000
commit5a844595b9262407e093364ec4d29a22962723f0 (patch)
tree26cc1f15a25dbb3a9f2a698c89b85b9c7c37fd0e
parent371b7e1ad2e46c79c7794d9b0f41b49157e7653c (diff)
downloadperl-5a844595b9262407e093364ec4d29a22962723f0.tar.gz
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 p4raw-id: //depot/perl@4197
-rw-r--r--embed.h14
-rwxr-xr-xembed.pl9
-rw-r--r--embedvar.h3
-rw-r--r--ext/DynaLoader/dlutils.c2
-rw-r--r--ext/Thread/Thread.xs1
-rw-r--r--global.sym3
-rw-r--r--gv.c27
-rw-r--r--objXSUB.h14
-rw-r--r--op.c6
-rw-r--r--perl.c4
-rw-r--r--perlapi.c86
-rw-r--r--pp_ctl.c28
-rw-r--r--proto.h5
-rw-r--r--regcomp.c2
-rw-r--r--t/pragma/strict-refs2
-rw-r--r--t/pragma/strict-vars16
-rw-r--r--thrdvar.h1
-rw-r--r--toke.c7
-rw-r--r--util.c57
19 files changed, 215 insertions, 72 deletions
diff --git a/embed.h b/embed.h
index 7cde885829..bf92164ed7 100644
--- a/embed.h
+++ b/embed.h
@@ -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
diff --git a/embed.pl b/embed.pl
index 85e33dded6..35a53cba6e 100755
--- a/embed.pl
+++ b/embed.pl
@@ -492,6 +492,7 @@ print EM <<'END';
# 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 @@ print EM <<'END';
# 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 @@ my %vfuncs = qw(
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 @@ sub emit_func {
? '' : 'return ');
my $emitval = '';
if (@args and $args[$#args] =~ /\.\.\./) {
- pop @args;
pop @aargs;
my $retarg = '';
my $ctxfunc = $func;
@@ -1049,6 +1051,7 @@ npr |void |croak_nocontext|const char* pat|...
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 @@ p |void |markstack_grow
#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
diff --git a/embedvar.h b/embedvar.h
index 65a31f1ec7..5394d4d42c 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -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
diff --git a/ext/DynaLoader/dlutils.c b/ext/DynaLoader/dlutils.c
index 6da532392f..73911565d9 100644
--- a/ext/DynaLoader/dlutils.c
+++ b/ext/DynaLoader/dlutils.c
@@ -55,7 +55,7 @@ SaveError(pTHXo_ char* pat, ...)
/* 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);
diff --git a/ext/Thread/Thread.xs b/ext/Thread/Thread.xs
index 772d41a495..e01f29de06 100644
--- a/ext/Thread/Thread.xs
+++ b/ext/Thread/Thread.xs
@@ -181,6 +181,7 @@ threadstart(void *arg)
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);
diff --git a/global.sym b/global.sym
index 5ee74d7477..7200c602a0 100644
--- a/global.sym
+++ b/global.sym
@@ -48,6 +48,7 @@ Perl_croak_nocontext
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_malloced_size
Perl_markstack_grow
Perl_mem_collxfrm
Perl_mess
+Perl_vmess
+Perl_qerror
Perl_mg_clear
Perl_mg_copy
Perl_mg_find
diff --git a/gv.c b/gv.c
index ae76f82949..29131ee323 100644
--- a/gv.c
+++ b/gv.c
@@ -568,26 +568,15 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
/* 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 */
diff --git a/objXSUB.h b/objXSUB.h
index 5da23fe984..66141626da 100644
--- a/objXSUB.h
+++ b/objXSUB.h
@@ -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
diff --git a/op.c b/op.c
index 0053bdd779..788464fa4b 100644
--- a/op.c
+++ b/op.c
@@ -96,9 +96,9 @@ S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
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 */
diff --git a/perl.c b/perl.c
index de91ed456f..c7cbe7e182 100644
--- a/perl.c
+++ b/perl.c
@@ -443,6 +443,10 @@ perl_destruct(pTHXx)
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)
diff --git a/perlapi.c b/perlapi.c
index ed7ab92d99..0f20e54a47 100644
--- a/perlapi.c
+++ b/perlapi.c
@@ -314,7 +314,7 @@ Perl_convert(pTHXo_ I32 optype, I32 flags, OP* o)
#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 @@ Perl_vcroak(pTHXo_ const char* pat, va_list* args)
#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 @@ Perl_croak_nocontext(const char* pat)
#undef Perl_die_nocontext
OP*
-Perl_die_nocontext(const char* pat)
+Perl_die_nocontext(const char* pat, ...)
{
dTHXo;
OP* retval;
@@ -357,7 +357,7 @@ Perl_die_nocontext(const char* pat)
#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 @@ Perl_deb_nocontext(const char* pat)
#undef Perl_form_nocontext
char*
-Perl_form_nocontext(const char* pat)
+Perl_form_nocontext(const char* pat, ...)
{
dTHXo;
char* retval;
@@ -380,9 +380,23 @@ Perl_form_nocontext(const char* pat)
}
+#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 @@ Perl_warn_nocontext(const char* pat)
#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 @@ Perl_warner_nocontext(U32 err, const char* pat)
#undef Perl_newSVpvf_nocontext
SV*
-Perl_newSVpvf_nocontext(const char* pat)
+Perl_newSVpvf_nocontext(const char* pat, ...)
{
dTHXo;
SV* retval;
@@ -418,7 +432,7 @@ Perl_newSVpvf_nocontext(const char* pat)
#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 @@ Perl_sv_catpvf_nocontext(SV* sv, const char* pat)
#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 @@ Perl_sv_setpvf_nocontext(SV* sv, const char* pat)
#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 @@ Perl_sv_catpvf_mg_nocontext(SV* sv, const char* pat)
#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 @@ Perl_cxinc(pTHXo)
#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 @@ Perl_deprecate(pTHXo_ char* s)
#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 @@ Perl_fold_constants(pTHXo_ OP* arg)
#undef Perl_form
char*
-Perl_form(pTHXo_ const char* pat)
+Perl_form(pTHXo_ const char* pat, ...)
{
char* retval;
va_list args;
@@ -2172,9 +2186,29 @@ Perl_mem_collxfrm(pTHXo_ const char* s, STRLEN len, STRLEN* xlen)
#undef Perl_mess
SV*
-Perl_mess(pTHXo_ const char* pat, va_list* args)
+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_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 @@ Perl_newSVpvn(pTHXo_ const char* s, STRLEN len)
#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 @@ Perl_sv_bless(pTHXo_ SV* sv, HV* stash)
#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 @@ Perl_sv_reset(pTHXo_ char* s, HV* stash)
#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 @@ Perl_wait4pid(pTHXo_ Pid_t pid, int* statusp, int flags)
#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 @@ Perl_vwarn(pTHXo_ const char* pat, va_list* args)
#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 @@ Perl_runops_debug(pTHXo)
#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 @@ Perl_sv_catsv_mg(pTHXo_ SV *dstr, SV *sstr)
#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 @@ Perl_pv_display(pTHXo_ SV *sv, char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
#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 @@ Perl_magic_dump(pTHXo_ MAGIC *mg)
#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;
diff --git a/pp_ctl.c b/pp_ctl.c
index caaaf20d8f..07c3e74618 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1247,6 +1247,18 @@ S_free_closures(pTHX)
}
}
+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 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen)
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 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen)
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 @@ S_doeval(pTHX_ int gimme, OP** startop)
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);
diff --git a/proto.h b/proto.h
index 38c7ce6273..74958d38b0 100644
--- a/proto.h
+++ b/proto.h
@@ -56,6 +56,7 @@ VIRTUAL void Perl_croak_nocontext(const char* pat, ...) __attribute__((noreturn)
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 @@ VIRTUAL void Perl_markstack_grow(pTHX);
#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);
diff --git a/regcomp.c b/regcomp.c
index ed1b3bd0a2..ceab482936 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -3395,7 +3395,7 @@ S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
#else
va_start(args);
#endif
- msv = mess(buf, &args);
+ msv = vmess(buf, &args);
va_end(args);
message = SvPV(msv,l1);
if (l1 > 512)
diff --git a/t/pragma/strict-refs b/t/pragma/strict-refs
index 7bf1556e10..10599b0bb2 100644
--- a/t/pragma/strict-refs
+++ b/t/pragma/strict-refs
@@ -196,6 +196,7 @@ ${"Fred"} ;
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 @@ my $a = ${"Fred"} ;
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.
########
diff --git a/t/pragma/strict-vars b/t/pragma/strict-vars
index 42107fa8e1..3e3e0e3a35 100644
--- a/t/pragma/strict-vars
+++ b/t/pragma/strict-vars
@@ -165,6 +165,7 @@ print STDERR $@;
$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 @@ $joe = 1 ;
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
diff --git a/thrdvar.h b/thrdvar.h
index 06bcb5b4e7..2b64b7e087 100644
--- a/thrdvar.h
+++ b/thrdvar.h
@@ -101,6 +101,7 @@ PERLVAR(Tmainstack, AV *) /* the stack when nothing funny is happening */
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() */
diff --git a/toke.c b/toke.c
index 3c098a2fd4..5280054a06 100644
--- a/toke.c
+++ b/toke.c
@@ -6897,7 +6897,6 @@ int
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 @@ PRId64 ")\n",
}
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;
diff --git a/util.c b/util.c
index 552c09268e..a92c4dba2b 100644
--- a/util.c
+++ b/util.c
@@ -1379,8 +1379,33 @@ Perl_vform(pTHX_ const char *pat, va_list *args)
return SvPVX(sv);
}
+#if defined(PERL_IMPLICIT_CONTEXT)
+SV *
+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, va_list *args)
+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 @@ Perl_vdie(pTHX_ const char* pat, va_list *args)
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;
@@ -1529,9 +1560,18 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args)
SV *msv;
STRLEN msglen;
- msv = mess(pat, args);
- message = SvPV(msv,msglen);
- DEBUG_S(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message));
+ 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);
+
+ 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 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args)
SV *msv;
STRLEN msglen;
- msv = mess(pat, args);
+ msv = vmess(pat, args);
message = SvPV(msv, msglen);
if (PL_warnhook) {
@@ -1705,7 +1745,7 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
SV *msv;
STRLEN msglen;
- msv = mess(pat, args);
+ msv = vmess(pat, args);
message = SvPV(msv, msglen);
if (ckDEAD(err)) {
@@ -3370,6 +3410,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t)
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);