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

diff --git a/embed.h b/embed.h
index 7cde885..bf92164 100644 (file)
--- 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 85e33dd..35a53cb 100755 (executable)
--- 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 65a31f1..5394d4d 100644 (file)
--- 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 6da5323..7391156 100644 (file)
--- 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 772d41a..e01f29d 100644 (file)
--- 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 5ee74d7..7200c60 100644 (file)
--- 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 ae76f82..29131ee 100644 (file)
--- 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 5da23fe..6614162 100644 (file)
--- 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 0053bdd..788464f 100644 (file)
--- 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 de91ed4..c7cbe7e 100644 (file)
--- 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 ed7ab92..0f20e54 100644 (file)
--- 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 caaaf20..07c3e74 100644 (file)
--- 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 38c7ce6..74958d3 100644 (file)
--- 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 ed1b3bd..ceab482 100644 (file)
--- 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 7bf1556..10599b0 100644 (file)
--- 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 42107fa..3e3e0e3 100644 (file)
--- 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 06bcb5b..2b64b7e 100644 (file)
--- 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 3c098a2..5280054 100644 (file)
--- 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 552c092..a92c4db 100644 (file)
--- 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);