This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add fnc to force out UTF-8 malform warnings at death
authorKarl Williamson <khw@cpan.org>
Thu, 8 Dec 2016 03:48:40 +0000 (20:48 -0700)
committerKarl Williamson <khw@cpan.org>
Fri, 23 Dec 2016 20:21:31 +0000 (13:21 -0700)
The bottom level UTF-8 decode routine now generates detailed messages
when it encounters malformations.  In some instances these should be
treated as croak reasons and output even if warnings are off, just
before dying.  This commit adds a function to do this.

embed.fnc
embed.h
proto.h
utf8.c

index 49cf3f4..4743524 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1754,6 +1754,9 @@ Ap        |void   |unsharepvn     |NULLOK const char* sv|I32 len|U32 hash
 p      |void   |unshare_hek    |NULLOK HEK* hek
 : Used in perly.y
 p      |void   |utilize        |int aver|I32 floor|NULLOK OP* version|NN OP* idop|NULLOK OP* arg
+ApM    |void   |_force_out_malformed_utf8_message                          \
+               |NN const U8 *const p|NN const U8 * const e|const U32 flags \
+               |const bool die_here
 Ap     |U8*    |utf16_to_utf8  |NN U8* p|NN U8 *d|I32 bytelen|NN I32 *newlen
 Ap     |U8*    |utf16_to_utf8_reversed|NN U8* p|NN U8 *d|I32 bytelen|NN I32 *newlen
 AdpPR  |STRLEN |utf8_length    |NN const U8* s|NN const U8 *e
diff --git a/embed.h b/embed.h
index 2ea48e3..66fe0cc 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -27,6 +27,7 @@
 /* Hide global symbols */
 
 #define Gv_AMupdate(a,b)       Perl_Gv_AMupdate(aTHX_ a,b)
+#define _force_out_malformed_utf8_message(a,b,c,d)     Perl__force_out_malformed_utf8_message(aTHX_ a,b,c,d)
 #define _is_in_locale_category(a,b)    Perl__is_in_locale_category(aTHX_ a,b)
 #define _is_uni_FOO(a,b)       Perl__is_uni_FOO(aTHX_ a,b)
 #define _is_uni_perl_idcont(a) Perl__is_uni_perl_idcont(aTHX_ a)
diff --git a/proto.h b/proto.h
index ecf6f71..c7065cd 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -41,6 +41,9 @@ PERL_CALLCONV void*   Perl_Slab_Alloc(pTHX_ size_t sz)
 PERL_CALLCONV void     Perl_Slab_Free(pTHX_ void *op);
 #define PERL_ARGS_ASSERT_SLAB_FREE     \
        assert(op)
+PERL_CALLCONV void     Perl__force_out_malformed_utf8_message(pTHX_ const U8 *const p, const U8 * const e, const U32 flags, const bool die_here);
+#define PERL_ARGS_ASSERT__FORCE_OUT_MALFORMED_UTF8_MESSAGE     \
+       assert(p); assert(e)
 PERL_CALLCONV bool     Perl__is_in_locale_category(pTHX_ const bool compiling, const int category);
 PERL_CALLCONV bool     Perl__is_uni_FOO(pTHX_ const U8 classnum, const UV c)
                        __attribute__warn_unused_result__;
diff --git a/utf8.c b/utf8.c
index 9fe9b03..5268730 100644 (file)
--- a/utf8.c
+++ b/utf8.c
@@ -52,6 +52,54 @@ within non-zero characters.
 =cut
 */
 
+void
+Perl__force_out_malformed_utf8_message(pTHX_
+            const U8 *const p,      /* First byte in UTF-8 sequence */
+            const U8 * const e,     /* Final byte in sequence (may include
+                                       multiple chars */
+            const U32 flags,        /* Flags to pass to utf8n_to_uvchr(),
+                                       usually 0, or some DISALLOW flags */
+            const bool die_here)    /* If TRUE, this function does not return */
+{
+    /* This core-only function is to be called when a malformed UTF-8 character
+     * is found, in order to output the detailed information about the
+     * malformation before dieing.  The reason it exists is for the occasions
+     * when such a malformation is fatal, but warnings might be turned off, so
+     * that normally they would not be actually output.  This ensures that they
+     * do get output.  Because a sequence may be malformed in more than one
+     * way, multiple messages may be generated, so we can't make them fatal, as
+     * that would cause the first one to die.
+     *
+     * Instead we pretend -W was passed to perl, then die afterwards.  The
+     * flexibility is here to return to the caller so they can finish up and
+     * die themselves */
+    U32 errors;
+
+    PERL_ARGS_ASSERT__FORCE_OUT_MALFORMED_UTF8_MESSAGE;
+
+    ENTER;
+    SAVESPTR(PL_dowarn);
+    SAVESPTR(PL_curcop);
+
+    PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
+    if (PL_curcop) {
+        PL_curcop->cop_warnings = pWARN_ALL;
+    }
+
+    (void) utf8n_to_uvchr_error(p, e - p, NULL, flags & ~UTF8_CHECK_ONLY, &errors);
+
+    LEAVE;
+
+    if (! errors) {
+       Perl_croak(aTHX_ "panic: _force_out_malformed_utf8_message should"
+                         " be called only when there are errors found");
+    }
+
+    if (die_here) {
+        Perl_croak(aTHX_ "Malformed UTF-8 character (fatal)");
+    }
+}
+
 /*
 =for apidoc uvoffuni_to_utf8_flags