perlpacktut: mention h2ph

[perl5.git] / dquote_static.c

diff --git a/dquote_static.c b/dquote_static.c
index 1ab4ebd..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 '}' */
@@ -162,12 +174,12 @@ S_grok_bslash_o(pTHX_ char **s, UV *uv, const char** error_msg,
             return FALSE;
         }
         else if (output_warning) {
-       Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
-       /* diag_listed_as: Non-octal character '%c'.  Resolved as "%s" */
-                      "Non-octal character '%c'.  Resolved as \"\\o{%.*s}\"",
-                      *(*s + numbers_len),
-                      (int) numbers_len,
-                      *s);
+            Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
+            /* diag_listed_as: Non-octal character '%c'.  Resolved as "%s" */
+                        "Non-octal character '%c'.  Resolved as \"\\o{%.*s}\"",
+                        *(*s + numbers_len),
+                        (int) numbers_len,
+                        *s);
         }
     }
 
@@ -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