perlpacktut: mention h2ph

[perl5.git] / dquote_static.c

diff --git a/dquote_static.c b/dquote_static.c
index f3cade8..da1b5b9 100644 (file)
--- 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)
 {
 
@@ -268,6 +281,9 @@ S_grok_bslash_x(pTHX_ char **s, UV *uv, const char** error_msg,
     }
 
     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
@@ -286,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