This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Restructure grok_bslash_c
authorKarl Williamson <khw@cpan.org>
Wed, 15 Jan 2020 17:48:05 +0000 (10:48 -0700)
committerKarl Williamson <khw@cpan.org>
Thu, 23 Jan 2020 22:46:56 +0000 (15:46 -0700)
This commit causes this function to allow a caller to request any
messages generated to be returned to the caller, instead of always being
handled within this function.

Like the previous commit for grok_bslash_c, here are two reasons to do
this, repeated here.

1) In pattern compilation this brings these messages into conformity
   with the other ones that get generated in pattern compilation, where
   there is a particular syntax, including marking the exact position in
   the parse where the problem occurred.

2) The messages could be truncated due to the (mostly) single-pass
   nature of pattern compilation that is now in effect.  It keeps track
   of where during a parse a message has been output, and won't output
   it again if a second parsing pass turns out to be necessary.  Prior
   to this commit, it had to assume that a message from one of these
   functions did get output, and this caused some out-of-bounds reads
   when a subparse (using a constructed pattern) was executed.  The
   possibility of those went away in commit 5d894ca5213, which
   guarantees it won't try to read outside bounds, but that may still
   mean it is outputting text from the wrong parse, giving meaningless
   results.  This commit should stop that possibility.

dquote.c
embed.fnc
embed.h
pod/perldelta.pod
proto.h
regcomp.c
t/lib/warnings/regcomp
t/lib/warnings/toke
t/re/reg_mesg.t
toke.c

index 3a2ba46..d6e442e 100644 (file)
--- a/dquote.c
+++ b/dquote.c
 #include "dquote_inline.h"
 
 /* XXX Add documentation after final interface and behavior is decided */
-/* May want to show context for error, so would pass S_grok_bslash_c(pTHX_ const char* current, const char* start, const bool output_warning)
-    U8 source = *current;
-*/
 
-char
-Perl_grok_bslash_c(pTHX_ const char source, const bool output_warning)
+bool
+Perl_grok_bslash_c(pTHX_ const char   source,
+                         U8 *         result,
+                         const char** message,
+                         U32 *        packed_warn)
 {
-
-    U8 result;
+    PERL_ARGS_ASSERT_GROK_BSLASH_C;
+
+    /* This returns TRUE if the \c? sequence is valid; FALSE otherwise.  If it
+     * is valid, the sequence evaluates to a single character, which will be
+     * stored into *result.
+     *
+     * source   is the character immediately after a '\c' sequence.
+     * result   points to a char variable into which this function will store
+     *          what the sequence evaluates to, if valid; unchanged otherwise.
+     * message  A pointer to any warning or error message will be stored into
+     *          this pointer; NULL if none.
+     * packed_warn if NULL on input asks that this routine display any warning
+     *          messages.  Otherwise, if the function found a warning, the
+     *          packed warning categories will be stored into *packed_warn (and
+     *          the corresponding message text into *message); 0 if none.
+     */
+
+    *message = NULL;
+    if (packed_warn) *packed_warn = 0;
 
     if (! isPRINT_A(source)) {
-        Perl_croak(aTHX_ "%s",
-                        "Character following \"\\c\" must be printable ASCII");
+        *message = "Character following \"\\c\" must be printable ASCII";
+        return FALSE;
     }
-    else if (source == '{') {
+
+    if (source == '{') {
         const char control = toCTRL('{');
         if (isPRINT_A(control)) {
             /* diag_listed_as: Use "%s" instead of "%s" */
-            Perl_croak(aTHX_ "Use \"%c\" instead of \"\\c{\"", control);
+            *message = Perl_form(aTHX_ "Use \"%c\" instead of \"\\c{\"", control);
         }
         else {
-            Perl_croak(aTHX_ "Sequence \"\\c{\" invalid");
+            *message = "Sequence \"\\c{\" invalid";
         }
+        return FALSE;
     }
 
-    result = toCTRL(source);
-    if (output_warning && isPRINT_A(result)) {
+    *result = toCTRL(source);
+    if (isPRINT_A(*result) && ckWARN(WARN_SYNTAX)) {
         U8 clearer[3];
         U8 i = 0;
-        if (! isWORDCHAR(result)) {
+        char format[] = "\"\\c%c\" is more clearly written simply as \"%s\"";
+
+        if (! isWORDCHAR(*result)) {
             clearer[i++] = '\\';
         }
-        clearer[i++] = result;
+        clearer[i++] = *result;
         clearer[i++] = '\0';
 
-        Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
-                        "\"\\c%c\" is more clearly written simply as \"%s\"",
-                        source,
-                        clearer);
+        if (packed_warn) {
+            *message = Perl_form(aTHX_ format, source, clearer);
+            *packed_warn = packWARN(WARN_SYNTAX);
+        }
+        else {
+            Perl_warner(aTHX_ packWARN(WARN_SYNTAX), format, source, clearer);
+        }
     }
 
-    return result;
+    return TRUE;
 }
 
 bool
index 014e0f2..012a479 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1143,7 +1143,10 @@ EpRX     |bool   |grok_bslash_x  |NN char** s             \
                                |const bool output_warning       \
                                |const bool strict               \
                                |const bool utf8
-EpRX   |char   |grok_bslash_c  |const char source|const bool output_warning
+EpRX   |bool   |grok_bslash_c  |const char source              \
+                               |NN U8 * result                 \
+                               |NN const char** message        \
+                               |NULLOK U32 * packed_warn
 EpRX   |bool   |grok_bslash_o  |NN char** s             \
                                |NN const char* const send       \
                                |NN UV* uv                       \
diff --git a/embed.h b/embed.h
index 6fbbed7..cd167db 100644 (file)
--- a/embed.h
+++ b/embed.h
 #  endif
 #  if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_TOKE_C) || defined(PERL_IN_DQUOTE_C)
 #define form_short_octal_warning(a,b)  S_form_short_octal_warning(aTHX_ a,b)
-#define grok_bslash_c(a,b)     Perl_grok_bslash_c(aTHX_ a,b)
+#define grok_bslash_c(a,b,c,d) Perl_grok_bslash_c(aTHX_ a,b,c,d)
 #define grok_bslash_o(a,b,c,d,e,f,g)   Perl_grok_bslash_o(aTHX_ a,b,c,d,e,f,g)
 #define grok_bslash_x(a,b,c,d,e,f,g)   Perl_grok_bslash_x(aTHX_ a,b,c,d,e,f,g)
 #define regcurly               S_regcurly
index 0901ccc..3379edf 100644 (file)
@@ -230,7 +230,35 @@ XXX Changes (i.e. rewording) of diagnostic messages go here
 
 =item *
 
-XXX Describe change here
+L<Character following "\c" must be printable ASCII|perldiag/"Character following "\c" must be printable ASCII">
+
+now has extra text added at the end, when raised during regular
+expression pattern compilation, marking where precisely in the pattern
+it occured.
+
+=item *
+
+L<Use "%s" instead of "%s"|perldiag/"Use "%s" instead of "%s"">
+
+now has extra text added at the end, when raised during regular
+expression pattern compilation, marking where precisely in the pattern
+it occured.
+
+=item *
+
+L<Sequence "\c{" invalid|perldiag/"Sequence "\c{" invalid">
+
+now has extra text added at the end, when raised during regular
+expression pattern compilation, marking where precisely in the pattern
+it occured.
+
+=item *
+
+L<"\c%c" is more clearly written simply as "%s"|perldiag/""\c%c" is more clearly written simply as "%s"">
+
+now has extra text added at the end, when raised during regular
+expression pattern compilation, marking where precisely in the pattern
+it occured.
 
 =back
 
diff --git a/proto.h b/proto.h
index 1f71619..d5fb2ca 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -5912,9 +5912,10 @@ PERL_STATIC_INLINE char* S_form_short_octal_warning(pTHX_ const char * const s,
        assert(s)
 #endif
 
-PERL_CALLCONV char     Perl_grok_bslash_c(pTHX_ const char source, const bool output_warning)
+PERL_CALLCONV bool     Perl_grok_bslash_c(pTHX_ const char source, U8 * result, const char** message, U32 * packed_warn)
                        __attribute__warn_unused_result__;
-#define PERL_ARGS_ASSERT_GROK_BSLASH_C
+#define PERL_ARGS_ASSERT_GROK_BSLASH_C \
+       assert(result); assert(message)
 
 PERL_CALLCONV bool     Perl_grok_bslash_o(pTHX_ char** s, const char* const send, UV* uv, const char** message, const bool output_warning, const bool strict, const bool utf8)
                        __attribute__warn_unused_result__;
index 39875a1..93bacdf 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -13968,6 +13968,10 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
                        || ! is_PATWS_safe((p), RExC_end, UTF));
 
                switch ((U8)*p) {
+                  const char* message;
+                  U32 packed_warn;
+                  U8 grok_c_char;
+
                case '^':
                case '$':
                case '.':
@@ -14134,10 +14138,24 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
                            break;
                        }
                    case 'c':
-                       p++;
-                       ender = grok_bslash_c(*p, TO_OUTPUT_WARNINGS(p));
-                        UPDATE_WARNINGS_LOC(p);
                         p++;
+                        if (! grok_bslash_c(*p, &grok_c_char,
+                                            &message, &packed_warn))
+                        {
+                            /* going to die anyway; point to exact spot of
+                             * failure */
+                            RExC_parse = p + ((UTF)
+                                              ? UTF8_SAFE_SKIP(p, RExC_end)
+                                              : 1);
+                            vFAIL(message);
+                        }
+
+                        ender = grok_c_char;
+                        p++;
+                        if (message && TO_OUTPUT_WARNINGS(p)) {
+                            warn_non_literal_string(p, packed_warn, message);
+                        }
+
                        break;
                     case '8': case '9': /* must be a backreference */
                         --p;
@@ -17372,6 +17390,9 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth,
              * is already in 'value'.  Otherwise, need to translate the escape
              * into what it signifies. */
             if (! skip_white || ! isBLANK_A(value)) switch ((I32)value) {
+                const char * message;
+                U32 packed_warn;
+                U8 grok_c_char;
 
            case 'w':   namedclass = ANYOF_WORDCHAR;    break;
            case 'W':   namedclass = ANYOF_NWORDCHAR;   break;
@@ -17657,9 +17678,23 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth,
                 non_portable_endpoint++;
                break;
            case 'c':
-               value = grok_bslash_c(*RExC_parse, TO_OUTPUT_WARNINGS(RExC_parse));
-                UPDATE_WARNINGS_LOC(RExC_parse);
-               RExC_parse++;
+                if (! grok_bslash_c(*RExC_parse, &grok_c_char, &message,
+                                                                &packed_warn))
+                {
+                    /* going to die anyway; point to exact spot of
+                        * failure */
+                    RExC_parse += (UTF)
+                                  ? UTF8_SAFE_SKIP(RExC_parse, RExC_end)
+                                  : 1;
+                    vFAIL(message);
+                }
+
+                value = grok_c_char;
+                RExC_parse++;
+                if (message && TO_OUTPUT_WARNINGS(RExC_parse)) {
+                    warn_non_literal_string(RExC_parse, packed_warn, message);
+                }
+
                 non_portable_endpoint++;
                break;
            case '0': case '1': case '2': case '3': case '4':
index 6dcb789..b10680b 100644 (file)
@@ -35,8 +35,8 @@ no warnings 'syntax';
 $a = qr/\c,/;
 $a = qr/[\c,]/;
 EXPECT
-"\c," is more clearly written simply as "l" at - line 9.
-"\c," is more clearly written simply as "l" at - line 10.
+"\c," is more clearly written simply as "l" in regex; marked by <-- HERE in m/\c, <-- HERE / at - line 9.
+"\c," is more clearly written simply as "l" in regex; marked by <-- HERE in m/[\c, <-- HERE ]/ at - line 10.
 ########
 # This is because currently a different error is output under
 # use re 'strict', so can't go in reg_mesg.t
index e66558a..e875874 100644 (file)
@@ -1422,7 +1422,8 @@ use warnings;
 my $a = "\c{ack}";
 EXPECT
 OPTION fatal
-Use ";" instead of "\c{" at - line 9.
+Use ";" instead of "\c{" at - line 9, within string
+Execution of - aborted due to compilation errors.
 ########
 # toke.c
 BEGIN {
@@ -1441,7 +1442,8 @@ Sequence "\c{" invalid at - line 9.
 my $a = "\câ";
 EXPECT
 OPTION fatal
-Character following "\c" must be printable ASCII at - line 2.
+Character following "\c" must be printable ASCII at - line 2, within string
+Execution of - aborted due to compilation errors.
 ########
 # toke.c
 use warnings 'syntax' ;
index 1ef912b..c7d51d9 100644 (file)
@@ -283,7 +283,6 @@ my @death =
  "m/(?('/" => "Sequence (?('... not terminated {#} m/(?('{#}/",
  'm/\g{/'  => 'Sequence \g{... not terminated {#} m/\g{{#}/',
  'm/\k</'  => 'Sequence \k<... not terminated {#} m/\k<{#}/',
- 'm/\cß/' => "Character following \"\\c\" must be printable ASCII",
  '/((?# This is a comment in the middle of a token)?:foo)/' => 'In \'(?...)\', the \'(\' and \'?\' must be adjacent {#} m/((?# This is a comment in the middle of a token)?{#}:foo)/',
  '/((?# This is a comment in the middle of a token)*FAIL)/' => 'In \'(*VERB...)\', the \'(\' and \'*\' must be adjacent {#} m/((?# This is a comment in the middle of a token)*{#}FAIL)/',
  '/((?# This is a comment in the middle of a token)*script_run:foo)/' => 'In \'(*...)\', the \'(\' and \'*\' must be adjacent {#} m/((?# This is a comment in the middle of a token)*{#}script_run:foo)/',
@@ -491,7 +490,8 @@ my @death_utf8 = mark_as_utf8(
  '/(?[ \t + \e # ネ This was supposed to be a comment ])/' =>
     "Syntax error in (?[...]) {#} m/(?[ \\t + \\e # ネ This was supposed to be a comment ]){#}/",
  'm/(*ネ)ネ/' => q<Unknown '(*...)' construct 'ネ' {#} m/(*ネ){#}ネ/>,
- '/\cネ/' => "Character following \"\\c\" must be printable ASCII",
+ '/\cネ/' => "Character following \"\\c\" must be printable ASCII {#} m/\\cネ{#}/",
+ '/[\cネ]/' => "Character following \"\\c\" must be printable ASCII {#} m/[\\cネ{#}]/",
  '/\b{ネ}/' => "'ネ' is an unknown bound type {#} m/\\b{ネ{#}}/",
  '/\B{ネ}/' => "'ネ' is an unknown bound type {#} m/\\B{ネ{#}}/",
 );
diff --git a/toke.c b/toke.c
index 0638b98..41e6930 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -3997,7 +3997,14 @@ S_scan_const(pTHX_ char *start)
            case 'c':
                s++;
                if (s < send) {
-                   *d++ = grok_bslash_c(*s, 1);
+                    const char * message;
+
+                   if (! grok_bslash_c(*s, (U8 *) d, &message, NULL)) {
+                        yyerror(message);
+                        yyquit();   /* Have always immediately croaked on
+                                       errors in this */
+                    }
+                   d++;
                }
                else {
                    yyerror("Missing control char name in \\c");