This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
utf8.c: Extract code into separate function
authorKarl Williamson <khw@cpan.org>
Fri, 2 Feb 2018 17:43:33 +0000 (10:43 -0700)
committerKarl Williamson <khw@cpan.org>
Wed, 7 Feb 2018 18:19:13 +0000 (11:19 -0700)
This is in preparation for the next commit which will use this code in
multiple places

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

index ea389e4..763a17c 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -2847,6 +2847,9 @@ sn        |NV|mulexp10    |NV value|I32 exponent
 #endif
 
 #if defined(PERL_IN_UTF8_C)
+sR     |HV *   |new_msg_hv |NN const char * const message                  \
+                           |U32 categories                                 \
+                           |U32 flag
 sRM    |UV     |check_locale_boundary_crossing                             \
                |NN const U8* const p                                       \
                |const UV result                                            \
diff --git a/embed.h b/embed.h
index d1fe34a..5f2184a 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define is_utf8_common(a,b,c,d)        S_is_utf8_common(aTHX_ a,b,c,d)
 #define is_utf8_common_with_len(a,b,c,d,e)     S_is_utf8_common_with_len(aTHX_ a,b,c,d,e)
 #define is_utf8_overlong_given_start_byte_ok   S_is_utf8_overlong_given_start_byte_ok
+#define new_msg_hv(a,b,c)      S_new_msg_hv(aTHX_ a,b,c)
 #define swash_scan_list_line(a,b,c,d,e,f,g)    S_swash_scan_list_line(aTHX_ a,b,c,d,e,f,g)
 #define swatch_get(a,b,c)      S_swatch_get(aTHX_ a,b,c)
 #define to_lower_latin1                S_to_lower_latin1
diff --git a/proto.h b/proto.h
index 4852115..2e3f965 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -5992,6 +5992,11 @@ PERL_STATIC_INLINE int   S_is_utf8_overlong_given_start_byte_ok(const U8 * const s
        assert(s)
 #endif
 
+STATIC HV *    S_new_msg_hv(pTHX_ const char * const message, U32 categories, U32 flag)
+                       __attribute__warn_unused_result__;
+#define PERL_ARGS_ASSERT_NEW_MSG_HV    \
+       assert(message)
+
 STATIC U8*     S_swash_scan_list_line(pTHX_ U8* l, U8* const lend, UV* min, UV* max, UV* val, const bool wants_value, const U8* const typestr)
                        __attribute__warn_unused_result__;
 #define PERL_ARGS_ASSERT_SWASH_SCAN_LIST_LINE  \
diff --git a/utf8.c b/utf8.c
index 21664d5..18367f5 100644 (file)
--- a/utf8.c
+++ b/utf8.c
@@ -101,6 +101,29 @@ Perl__force_out_malformed_utf8_message(pTHX_
     }
 }
 
+STATIC HV *
+S_new_msg_hv(pTHX_ const char * const message, /* The message text */
+                   U32 categories,  /* Packed warning categories */
+                   U32 flag)        /* Flag associated with this message */
+{
+    /* Creates, populates, and returns an HV* that describes an error message
+     * for the translators between UTF8 and code point */
+
+    SV* msg_sv = newSVpv(message, 0);
+    SV* category_sv = newSVuv(categories);
+    SV* flag_bit_sv = newSVuv(flag);
+
+    HV* msg_hv = newHV();
+
+    PERL_ARGS_ASSERT_NEW_MSG_HV;
+
+    hv_stores(msg_hv, "text", msg_sv);
+    hv_stores(msg_hv, "warn_categories",  category_sv);
+    hv_stores(msg_hv, "flag_bit", flag_bit_sv);
+
+    return msg_hv;
+}
+
 /*
 =for apidoc uvoffuni_to_utf8_flags
 
@@ -2142,22 +2165,15 @@ Perl_utf8n_to_uvchr_msgs(pTHX_ const U8 *s,
              * this iteration of the loop */
             if (message) {
                 if (msgs) {
-                    SV* msg_sv = newSVpv(message, 0);
-                    SV* category_sv = newSVuv(pack_warn);
-                    SV* flag_bit_sv = newSVuv(this_flag_bit);
-                    HV* msg_hv = newHV();
-
                     assert(this_flag_bit);
 
                     if (*msgs == NULL) {
                         *msgs = newAV();
                     }
 
-                    hv_stores(msg_hv, "text", msg_sv);
-                    hv_stores(msg_hv, "warn_categories",  category_sv);
-                    hv_stores(msg_hv, "flag_bit", flag_bit_sv);
-
-                    av_push(*msgs, newRV_noinc((SV*)msg_hv));
+                    av_push(*msgs, newRV_noinc((SV*) new_msg_hv(message,
+                                                                pack_warn,
+                                                                this_flag_bit)));
                 }
                 else if (PL_op)
                     Perl_warner(aTHX_ pack_warn, "%s in %s", message,