add Perl_current_re_engine() function

Abstract out into a separate function the task of finding the current
in-scope regex engine ($^H{regex}). Currently this task is only done in
one place each for compile- and run-time, but shortly we'll need it in
other places too.

diff --git a/embed.fnc b/embed.fnc
index 594485d..55345c8 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1056,6 +1056,7 @@ Ap        |void   |regfree_internal|NN REGEXP *const rx
 #if defined(USE_ITHREADS)
 Ap     |void*  |regdupe_internal|NN REGEXP * const r|NN CLONE_PARAMS* param
 #endif
+p      |regexp_engine*|current_re_engine
 Ap     |REGEXP*|pregcomp       |NN SV * const pattern|const U32 flags
 Ap     |REGEXP*|re_compile     |NN SV * const pattern|U32 flags
 Ap     |char*  |re_intuit_start|NN REGEXP * const rx|NULLOK SV* sv|NN char* strpos \

diff --git a/embed.h b/embed.h
index a980a87..b565bb5 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1053,6 +1053,7 @@
 #define core_prototype(a,b,c,d)        Perl_core_prototype(aTHX_ a,b,c,d)
 #define coresub_op(a,b,c)      Perl_coresub_op(aTHX_ a,b,c)
 #define create_eval_scope(a)   Perl_create_eval_scope(aTHX_ a)
+#define current_re_engine()    Perl_current_re_engine(aTHX)
 #define cv_ckproto_len_flags(a,b,c,d,e)        Perl_cv_ckproto_len_flags(aTHX_ a,b,c,d,e)
 #define cvgv_set(a,b)          Perl_cvgv_set(aTHX_ a,b)
 #define cvstash_set(a,b)       Perl_cvstash_set(aTHX_ a,b)

diff --git a/pp_ctl.c b/pp_ctl.c
index 2cde665..d4709b4 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -187,20 +187,20 @@ PP(pp_regcomp)
        if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
            memNE(RX_PRECOMP(re), t, len))
        {
-           const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
+           const regexp_engine *eng;
             U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
+
            if (re) {
+               eng = RX_ENGINE(re);
                ReREFCNT_dec(re);
 #ifdef USE_ITHREADS
                PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
 #else
                PM_SETRE(pm, NULL);     /* crucial if regcomp aborts */
 #endif
-           } else if (PL_curcop->cop_hints_hash) {
-               SV *ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
-                if (ptr && SvIOK(ptr) && SvIV(ptr))
-                    eng = INT2PTR(regexp_engine*,SvIV(ptr));
            }
+           else
+               eng = current_re_engine();
 
            if (PL_op->op_flags & OPf_SPECIAL)
                PL_reginterp_cnt = I32_MAX; /* Mark as safe.  */

diff --git a/proto.h b/proto.h
index 02bc3cc..e52b31b 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -646,6 +646,7 @@ PERL_CALLCONV void  Perl_croak_xs_usage(pTHX_ const CV *const cv, const char *con
 #define PERL_ARGS_ASSERT_CROAK_XS_USAGE        \
        assert(cv); assert(params)
 
+PERL_CALLCONV regexp_engine*   Perl_current_re_engine(pTHX);
 PERL_CALLCONV const char *     Perl_custom_op_desc(pTHX_ const OP *o)
                        __attribute__warn_unused_result__
                        __attribute__nonnull__(pTHX_1);

diff --git a/regcomp.c b/regcomp.c
index cf04d0a..5b5babf 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -4901,27 +4901,53 @@ extern const struct regexp_engine my_reg_engine;
 #endif
 
 #ifndef PERL_IN_XSUB_RE 
+
+/* return the currently in-scope regex engine (or NULL if none)  */
+
+regexp_engine *
+Perl_current_re_engine(pTHX)
+{
+    dVAR;
+
+    if (IN_PERL_COMPILETIME) {
+       HV * const table = GvHV(PL_hintgv);
+       SV **ptr;
+
+       if (!table)
+           return NULL;
+       ptr = hv_fetchs(table, "regcomp", FALSE);
+       if ( !(ptr && SvIOK(*ptr) && SvIV(*ptr)))
+           return NULL;
+       return INT2PTR(regexp_engine*,SvIV(*ptr));
+    }
+    else {
+       SV *ptr;
+       if (!PL_curcop->cop_hints_hash)
+           return NULL;
+       ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
+       if ( !(ptr && SvIOK(ptr) && SvIV(ptr)))
+           return NULL;
+       return INT2PTR(regexp_engine*,SvIV(ptr));
+    }
+}
+
+
 REGEXP *
 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
 {
     dVAR;
-    HV * const table = GvHV(PL_hintgv);
+    regexp_engine *eng = current_re_engine();
 
     PERL_ARGS_ASSERT_PREGCOMP;
 
-    /* Dispatch a request to compile a regexp to correct 
-       regexp engine. */
-    if (table) {
-        SV **ptr= hv_fetchs(table, "regcomp", FALSE);
+    /* Dispatch a request to compile a regexp to correct regexp engine. */
+    if (eng) {
         GET_RE_DEBUG_FLAGS_DECL;
-        if (ptr && SvIOK(*ptr) && SvIV(*ptr)) {
-            const regexp_engine *eng=INT2PTR(regexp_engine*,SvIV(*ptr));
-            DEBUG_COMPILE_r({
-                PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
-                    SvIV(*ptr));
-            });            
-            return CALLREGCOMP_ENG(eng, pattern, flags);
-        } 
+       DEBUG_COMPILE_r({
+           PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
+                           PTR2UV(eng));
+       });
+       return CALLREGCOMP_ENG(eng, pattern, flags);
     }
     return Perl_re_compile(aTHX_ pattern, flags);
 }