toke.c: Split code to load _charnames.pm into own fnc

This is in preparation for it being called from more than one place.

diff --git a/embed.fnc b/embed.fnc
index 4bb864f..cc5b10c 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -2962,6 +2962,10 @@ EXpR     |SV*    |get_and_check_backslash_N_name|NN const char* s        \
                                |NN const char* const e                 \
                                |const bool is_utf8                     \
                                |NN const char** error_msg
+EXpR   |HV*    |load_charnames |NN SV * char_name                      \
+                               |NN const char * context                \
+                               |const STRLEN context_len               \
+                               |NN const char ** error_msg
 
 : For use ONLY in B::Hooks::Parser, by special dispensation
 EXpxR  |char*  |scan_str       |NN char *start|int keep_quoted \

diff --git a/embed.h b/embed.h
index c948c45..a1f0418 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -922,6 +922,7 @@
 #define cv_ckproto_len_flags(a,b,c,d,e)        Perl_cv_ckproto_len_flags(aTHX_ a,b,c,d,e)
 #define get_and_check_backslash_N_name(a,b,c,d)        Perl_get_and_check_backslash_N_name(aTHX_ a,b,c,d)
 #define grok_atoUV             Perl_grok_atoUV
+#define load_charnames(a,b,c,d)        Perl_load_charnames(aTHX_ a,b,c,d)
 #define mg_find_mglob(a)       Perl_mg_find_mglob(aTHX_ a)
 #define multiconcat_stringify(a)       Perl_multiconcat_stringify(aTHX_ a)
 #define multideref_stringify(a,b)      Perl_multideref_stringify(aTHX_ a,b)

diff --git a/proto.h b/proto.h
index 9110ed8..4b8beab 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1771,6 +1771,11 @@ PERL_CALLCONV void       Perl_lex_unstuff(pTHX_ char* ptr);
        assert(ptr)
 PERL_CALLCONV OP*      Perl_list(pTHX_ OP* o);
 #define PERL_ARGS_ASSERT_LIST
+PERL_CALLCONV HV*      Perl_load_charnames(pTHX_ SV * char_name, const char * context, const STRLEN context_len, const char ** error_msg)
+                       __attribute__warn_unused_result__;
+#define PERL_ARGS_ASSERT_LOAD_CHARNAMES        \
+       assert(char_name); assert(context); assert(error_msg)
+
 PERL_CALLCONV void     Perl_load_module(pTHX_ U32 flags, SV* name, SV* ver, ...);
 #define PERL_ARGS_ASSERT_LOAD_MODULE   \
        assert(name)

diff --git a/toke.c b/toke.c
index 6857201..2c3bbb3 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -2586,6 +2586,64 @@ S_sublex_done(pTHX)
     }
 }
 
+HV *
+Perl_load_charnames(pTHX_ SV * char_name, const char * context,
+                          const STRLEN context_len, const char ** error_msg)
+{
+    /* Load the official _charnames module if not already there.  The
+     * parameters are just to give info for any error messages generated:
+     *  char_name   a name to look up which is the reason for loading this
+     *  context     'char_name' in the context in the input in which it appears
+     *  context_len how many bytes 'context' occupies
+     *  error_msg   *error_msg will be set to any error
+     *
+     *  Returns the ^H table if success; otherwise NULL */
+
+    unsigned int i;
+    HV * table;
+    SV **cvp;
+    SV * res;
+
+    PERL_ARGS_ASSERT_LOAD_CHARNAMES;
+
+    /* This loop is executed 1 1/2 times.  On the first time through, if it
+     * isn't already loaded, try loading it, and iterate just once to see if it
+     * worked.  */
+    for (i = 0; i < 2; i++) {
+        table = GvHV(PL_hintgv);                /* ^H */
+
+        if (    table
+            && (PL_hints & HINT_LOCALIZE_HH)
+            && (cvp = hv_fetchs(table, "charnames", FALSE))
+            &&  SvOK(*cvp))
+        {
+            return table;   /* Quit if already loaded */
+        }
+
+        if (i == 0) {
+            Perl_load_module(aTHX_
+                0,
+                newSVpvs("_charnames"),
+
+                /* version parameter; no need to specify it, as if we get too early
+                * a version, will fail anyway, not being able to find 'charnames'
+                * */
+                NULL,
+                newSVpvs(":full"),
+                newSVpvs(":short"),
+                NULL);
+        }
+    }
+
+    /* Here, it failed; new_constant will give appropriate error messages */
+    *error_msg = NULL;
+    res = new_constant( NULL, 0, "charnames", char_name, NULL,
+                        context, context_len, error_msg);
+    SvREFCNT_dec(res);
+
+    return NULL;
+}
+
 STATIC SV*
 S_get_and_check_backslash_N_name_wrapper(pTHX_ const char* s, const char* const e)
 {
@@ -2631,8 +2689,6 @@ Perl_get_and_check_backslash_N_name(pTHX_ const char* s,
     SV *cv;
     SV *rv;
     HV *stash;
-    bool charnames_loaded = FALSE; /* Is charnames loaded? */
-    unsigned int i;
 
     /* Points to the beginning of the \N{... so that any messages include the
      * context of what's failing*/
@@ -2656,40 +2712,17 @@ Perl_get_and_check_backslash_N_name(pTHX_ const char* s,
     }
 
     /* Autoload the charnames module */
-    for (i = 0; i < 2; i++) {
-        table = GvHV(PL_hintgv);                /* ^H */
-
-        charnames_loaded =     table
-                           && (PL_hints & HINT_LOCALIZE_HH)
-                           && (cvp = hv_fetchs(table, "charnames", FALSE))
-                           && SvOK(*cvp);
-        /* Quit if loaded, or failed to load.  In the latter case, we break out
-         * so that new_constant()'s error handling takes care of the necessary
-         * messages. */
-        if (i > 0 || charnames_loaded) {
-            break;
-        }
-
-        Perl_load_module(aTHX_
-            0,
-            newSVpvs("_charnames"),
 
-              /* version parameter; no need to specify it, as if we get too
-               * early a version, will fail anyway, not being able to find
-               * '_charnames' */
-            NULL,
-            newSVpvs(":full"),
-            newSVpvs(":short"),
-            NULL);
+    table = load_charnames(char_name, context, context_len, error_msg);
+    if (table == NULL) {
+        return NULL;
     }
 
     *error_msg = NULL;
     res = new_constant( NULL, 0, "charnames", char_name, NULL,
                         context, context_len, error_msg);
     if (*error_msg) {
-        if (charnames_loaded) {
-            *error_msg = Perl_form(aTHX_ "Unknown charname '%s'", SvPVX(char_name));
-        }
+        *error_msg = Perl_form(aTHX_ "Unknown charname '%s'", SvPVX(char_name));
 
         SvREFCNT_dec(res);
         return NULL;