X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/b67d718a3a2383d6737032d9ab26efd2a0ba2d9b..483394c85ff7a2176750ef684131581da42b6e20:/dquote_static.c

diff --git a/dquote_static.c b/dquote_static.c
index 9293b7b..da1b5b9 100644
--- a/dquote_static.c
+++ b/dquote_static.c
@@ -15,7 +15,11 @@
     Pulled from regcomp.c.
  */
 PERL_STATIC_INLINE I32
-S_regcurly(pTHX_ const char *s)
+S_regcurly(pTHX_ const char *s,
+           const bool rbrace_must_be_escaped /* Should the terminating '} be
+                                                preceded by a backslash?  This
+                                                is an abnormal case */
+    )
 {
     PERL_ARGS_ASSERT_REGCURLY;
 
@@ -30,9 +34,10 @@ S_regcurly(pTHX_ const char *s)
 	while (isDIGIT(*s))
 	    s++;
     }
-    if (*s != '}')
-	return FALSE;
-    return TRUE;
+
+    return (rbrace_must_be_escaped)
+           ? *s == '\\' && *(s+1) == '}'
+           : *s == '}';
 }
 
 /* XXX Add documentation after final interface and behavior is decided */
@@ -87,6 +92,7 @@ S_grok_bslash_c(pTHX_ const char source, const bool utf8, const bool output_warn
 STATIC bool
 S_grok_bslash_o(pTHX_ char **s, UV *uv, const char** error_msg,
                       const bool output_warning, const bool strict,
+                      const bool silence_non_portable,
                       const bool UTF)
 {
 
@@ -110,6 +116,8 @@ S_grok_bslash_o(pTHX_ char **s, UV *uv, const char** error_msg,
  *	    them
  *	strict is true if this should fail instead of warn if there are
  *	    non-octal digits within the braces
+ *      silence_non_portable is true if to suppress warnings about the code
+ *          point returned being too large to fit on all platforms.
  *	UTF is true iff the string *s is encoded in UTF-8.
  */
     char* e;
@@ -150,6 +158,10 @@ S_grok_bslash_o(pTHX_ char **s, UV *uv, const char** error_msg,
 	return FALSE;
     }
 
+    if (silence_non_portable) {
+        flags |= PERL_SCAN_SILENT_NON_PORTABLE;
+    }
+
     *uv = grok_oct(*s, &numbers_len, &flags, NULL);
     /* Note that if has non-octal, will ignore everything starting with that up
      * to the '}' */
@@ -180,6 +192,7 @@ S_grok_bslash_o(pTHX_ char **s, UV *uv, const char** error_msg,
 PERL_STATIC_INLINE bool
 S_grok_bslash_x(pTHX_ char **s, UV *uv, const char** error_msg,
                       const bool output_warning, const bool strict,
+                      const bool silence_non_portable,
                       const bool UTF)
 {
 
@@ -205,11 +218,13 @@ S_grok_bslash_x(pTHX_ char **s, UV *uv, const char** error_msg,
  *	    fail instead of warn or be silent.  For example, it requires
  *	    exactly 2 digits following the \x (when there are no braces).
  *	    3 digits could be a mistake, so is forbidden in this mode.
+ *      silence_non_portable is true if to suppress warnings about the code
+ *          point returned being too large to fit on all platforms.
  *	UTF is true iff the string *s is encoded in UTF-8.
  */
     char* e;
     STRLEN numbers_len;
-    I32 flags = 0;
+    I32 flags = PERL_SCAN_DISALLOW_PREFIX;
 
     PERL_ARGS_ASSERT_GROK_BSLASH_X;
 
@@ -225,7 +240,6 @@ S_grok_bslash_x(pTHX_ char **s, UV *uv, const char** error_msg,
     if (**s != '{') {
         STRLEN len = (strict) ? 3 : 2;
 
-	flags |= PERL_SCAN_DISALLOW_PREFIX;
 	*uv = grok_hex(*s, &len, &flags, NULL);
 	*s += len;
         if (strict && len != 2) {
@@ -266,7 +280,10 @@ S_grok_bslash_x(pTHX_ char **s, UV *uv, const char** error_msg,
         return TRUE;
     }
 
-    flags |= PERL_SCAN_ALLOW_UNDERSCORES|PERL_SCAN_DISALLOW_PREFIX;
+    flags |= PERL_SCAN_ALLOW_UNDERSCORES;
+    if (silence_non_portable) {
+        flags |= PERL_SCAN_SILENT_NON_PORTABLE;
+    }
 
     *uv = grok_hex(*s, &numbers_len, &flags, NULL);
     /* Note that if has non-hex, will ignore everything starting with that up
@@ -285,6 +302,35 @@ S_grok_bslash_x(pTHX_ char **s, UV *uv, const char** error_msg,
     return TRUE;
 }
 
+STATIC char*
+S_form_short_octal_warning(pTHX_
+                           const char * const s, /* Points to first non-octal */
+                           const STRLEN len      /* Length of octals string, so
+                                                    (s-len) points to first
+                                                    octal */
+) {
+    /* Return a character string consisting of a warning message for when a
+     * string constant in octal is weird, like "\078".  */
+
+    const char * sans_leading_zeros = s - len;
+
+    PERL_ARGS_ASSERT_FORM_SHORT_OCTAL_WARNING;
+
+    assert(*s == '8' || *s == '9');
+
+    /* Remove the leading zeros, retaining one zero so won't be zero length */
+    while (*sans_leading_zeros == '0') sans_leading_zeros++;
+    if (sans_leading_zeros == s) {
+        sans_leading_zeros--;
+    }
+
+    return Perl_form(aTHX_
+                     "'%.*s' resolved to '\\o{%.*s}%c'",
+                     (int) (len + 2), s - len - 1,
+                     (int) (s - sans_leading_zeros), sans_leading_zeros,
+                     *s);
+}
+
 /*
  * Local variables:
  * c-indentation-style: bsd