This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Relax internal function API
authorKarl Williamson <khw@cpan.org>
Tue, 14 Feb 2017 01:27:02 +0000 (18:27 -0700)
committerKarl Williamson <khw@cpan.org>
Tue, 14 Feb 2017 04:24:10 +0000 (21:24 -0700)
This changes  yyerror_pvn so that its first parameter can be NULL.  This
indicates no message is to be output, but that parsing is to be
abandoned immediately, without waiting for more errors to build up.

embed.fnc
proto.h
toke.c

index c1fa1f5..b7366b6 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1879,7 +1879,7 @@ p |void   |write_to_stderr|NN SV* msv
 p      |int    |yyerror        |NN const char *const s
 p      |void   |abort_execution|NN const char * const msg|NN const char * const name
 p      |int    |yyerror_pv     |NN const char *const s|U32 flags
-p      |int    |yyerror_pvn    |NN const char *const s|STRLEN len|U32 flags
+p      |int    |yyerror_pvn    |NULLOK const char *const s|STRLEN len|U32 flags
 : Used in perly.y, and by Data::Alias
 EXp    |int    |yylex
 p      |void   |yyunlex
diff --git a/proto.h b/proto.h
index 7a74c8f..d914547 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -3699,8 +3699,6 @@ PERL_CALLCONV int Perl_yyerror_pv(pTHX_ const char *const s, U32 flags);
 #define PERL_ARGS_ASSERT_YYERROR_PV    \
        assert(s)
 PERL_CALLCONV int      Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags);
-#define PERL_ARGS_ASSERT_YYERROR_PVN   \
-       assert(s)
 PERL_CALLCONV int      Perl_yylex(pTHX);
 PERL_CALLCONV int      Perl_yyparse(pTHX_ int gramtype);
 PERL_CALLCONV void     Perl_yyunlex(pTHX);
diff --git a/toke.c b/toke.c
index a825f6a..c45ae9d 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -11487,8 +11487,12 @@ Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
     SV * const where_sv = newSVpvs_flags("", SVs_TEMP);
     int yychar  = PL_parser->yychar;
 
-    PERL_ARGS_ASSERT_YYERROR_PVN;
+    /* Output error message 's' with length 'len'.  'flags' are SV flags that
+     * apply.  If the number of errors found is large enough, it abandons
+     * parsing.  If 's' is NULL, there is no message, and it abandons
+     * processing unconditionally */
 
+    if (s != NULL) {
     if (!yychar || (yychar == ';' && !PL_rsfp))
        sv_catpvs(where_sv, "at EOF");
     else if (   PL_oldoldbufptr
@@ -11574,14 +11578,24 @@ Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
     else {
        qerror(msg);
     }
-    if (PL_error_count >= 10) {
-       SV * errsv;
-       if (PL_in_eval && ((errsv = ERRSV), SvCUR(errsv)))
-           Perl_croak(aTHX_ "%" SVf "%s has too many errors.\n",
-                      SVfARG(errsv), OutCopFILE(PL_curcop));
-       else
-           Perl_croak(aTHX_ "%s has too many errors.\n",
-            OutCopFILE(PL_curcop));
+    }
+    if (s == NULL || PL_error_count >= 10) {
+        const char * msg = "";
+        const char * const name = OutCopFILE(PL_curcop);
+
+       if (PL_in_eval) {
+            SV * errsv = ERRSV;
+            if (SvCUR(errsv)) {
+                msg = Perl_form(aTHX_ "%" SVf, SVfARG(errsv));
+            }
+        }
+
+        if (s == NULL) {
+            abort_execution(msg, name);
+        }
+        else {
+            Perl_croak(aTHX_ "%s%s has too many errors.\n", msg, name);
+        }
     }
     PL_in_my = 0;
     PL_in_my_stash = NULL;