From 4e8ee35f1af746a63f71461d067e654dd9500dad Mon Sep 17 00:00:00 2001 From: Karl Williamson Date: Tue, 4 Feb 2020 14:43:14 -0700 Subject: [PATCH] toke.c: Split code to load _charnames.pm into own fnc This is in preparation for it being called from more than one place. --- embed.fnc | 4 +++ embed.h | 1 + proto.h | 5 ++++ toke.c | 91 +++++++++++++++++++++++++++++++++++++++++++-------------------- 4 files changed, 72 insertions(+), 29 deletions(-) diff --git a/embed.fnc b/embed.fnc index 4bb864f..cc5b10c 100644 --- 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 --- 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 --- 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 --- 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; -- 1.8.3.1