add op_comp field to regexp_engine API

Perl's internal function for compiling regexes that knows about code
blocks, Perl_re_op_compile, isn't part of the engine API. However, the
way that regcomp.c is dual-lifed as ext/re/re_comp.c with debugging
compiled in, means that Perl_re_op_compile is also compiled as
my_re_op_compile. These days days the mechanism to choose whether to call
the main functions or the debugging my_* functions when 'use re debug' is
in scope, is the re engine API jump table. Ergo, to ensure that
my_re_op_compile gets called appropriately, this method needs adding to
the jump table.

So, I've added it, but documented as 'for perl internal use only, set to
null in your engine'.

I've also updated current_re_engine() to always return a pointer to a jump
table, even if we're using the internal engine (formerly it returned
null). This then allows us to use the simple condition (eng->op_comp)
to determine whether the current engine supports code blocks.

diff --git a/embed.fnc b/embed.fnc
index fc93e49..e05af38 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1056,11 +1056,11 @@ 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
+EXp    |regexp_engine const *|current_re_engine
 Ap     |REGEXP*|pregcomp       |NN SV * const pattern|const U32 flags
 p      |REGEXP*|re_op_compile  |NULLOK SV ** const patternp \
                                |int pat_count|NULLOK OP *expr \
-                               |NULLOK const regexp_engine* eng \
+                               |NN const regexp_engine* eng \
                                |NULLOK REGEXP *VOL old_re \
                                |NULLOK int *is_bare_re \
                                |U32 rx_flags|U32 pm_flags

diff --git a/embed.h b/embed.h
index 173c193..d6ea5b2 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -857,6 +857,7 @@
 #if defined(PERL_CORE) || defined(PERL_EXT)
 #define _is_utf8__perl_idstart(a)      Perl__is_utf8__perl_idstart(aTHX_ a)
 #define av_reify(a)            Perl_av_reify(aTHX_ a)
+#define current_re_engine()    Perl_current_re_engine(aTHX)
 #define is_utf8_X_L(a)         Perl_is_utf8_X_L(aTHX_ a)
 #define is_utf8_X_LV(a)                Perl_is_utf8_X_LV(aTHX_ a)
 #define is_utf8_X_LVT(a)       Perl_is_utf8_X_LVT(aTHX_ a)
@@ -1053,7 +1054,6 @@
 #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/ext/re/re.xs b/ext/re/re.xs
index 54e3640..68a5ebc 100644 (file)
--- a/ext/re/re.xs
+++ b/ext/re/re.xs
@@ -12,7 +12,10 @@
 START_EXTERN_C
 
 extern REGEXP* my_re_compile (pTHX_ SV * const pattern, const U32 pm_flags);
-extern REGEXP* my_re_op_compile (pTHX_ SV * const pattern, OP *expr, const U32 pm_flags);
+extern REGEXP* my_re_op_compile (pTHX_ SV ** const patternp, int pat_count,
+                   OP *expr, const regexp_engine* eng, REGEXP *VOL old_re,
+                    int *is_bare_re, U32 orig_rx_flags, U32 pm_flags);
+
 extern I32     my_regexec (pTHX_ REGEXP * const prog, char* stringarg, char* strend,
                            char* strbeg, I32 minend, SV* screamer,
                            void* data, U32 flags);
@@ -58,8 +61,9 @@ const struct regexp_engine my_reg_engine = {
         my_reg_named_buff_iter,
         my_reg_qr_package,
 #if defined(USE_ITHREADS)
-        my_regdupe 
+        my_regdupe,
 #endif
+        my_re_op_compile,
 };
 
 MODULE = re    PACKAGE = re

diff --git a/op.c b/op.c
index d729bff..e139a73 100644 (file)
--- a/op.c
+++ b/op.c
@@ -4361,12 +4361,12 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
 
     if (is_compiletime) {
        U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
-       regexp_engine *eng = current_re_engine();
+       regexp_engine const *eng = current_re_engine();
 
        if (o->op_flags & OPf_SPECIAL)
            rx_flags |= RXf_SPLIT;
 
-       if (!has_code || (eng && eng != &PL_core_reg_engine)) {
+       if (!has_code || !eng->op_comp) {
            /* compile-time simple constant pattern */
            SV *pat;
 
@@ -4412,7 +4412,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
                pat = newSVpvn_flags(p, len, SVs_TEMP);
            }
 
-           PM_SETRE(pm, CALLREGCOMP(pat, rx_flags));
+           PM_SETRE(pm, CALLREGCOMP_ENG(eng, pat, rx_flags));
 #ifdef PERL_MAD
            op_getmad(expr,(OP*)pm,'e');
 #else
@@ -4421,7 +4421,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
        }
        else {
            /* compile-time pattern that includes literal code blocks */
-           REGEXP* re = re_op_compile(NULL, 0, expr, NULL, NULL, NULL,
+           REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
                                        rx_flags, pm->op_pmflags);
            PM_SETRE(pm, re);
            if (pm->op_pmflags & PMf_HAS_CV) {

diff --git a/pod/perlreapi.pod b/pod/perlreapi.pod
index 5e45620..93da14b 100644 (file)
--- a/pod/perlreapi.pod
+++ b/pod/perlreapi.pod
@@ -34,6 +34,8 @@ following format:
     #ifdef USE_ITHREADS
         void*   (*dupe) (pTHX_ REGEXP * const rx, CLONE_PARAMS *param);
     #endif
+        REGEXP* (*op_comp) (...);
+
 
 When a regexp is compiled, its C<engine> field is then set to point at
 the appropriate structure, so that when it needs to be used Perl can find
@@ -462,6 +464,11 @@ modify the final structure if it really must.
 
 On unthreaded builds this field doesn't exist.
 
+=head2 op_comp
+
+This is private to the perl core and subject to change. Should be left
+null.
+
 =head1 The REGEXP structure
 
 The REGEXP struct is defined in F<regexp.h>. All regex engines must be able to

diff --git a/pp_ctl.c b/pp_ctl.c
index f816b95..4b79392 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -113,7 +113,10 @@ PP(pp_regcomp)
     if (PL_op->op_flags & OPf_SPECIAL)
        PL_reginterp_cnt = (I32_MAX>>1); /* Mark as safe.  */
 
-    new_re = re_op_compile(args, nargs, pm->op_code_list, eng, re,
+    new_re = (eng->op_comp
+                   ? eng->op_comp
+                   : &Perl_re_op_compile
+           )(aTHX_ args, nargs, pm->op_code_list, eng, re,
                &is_bare_re,
                (pm->op_pmflags & RXf_PMf_COMPILETIME),
                pm->op_pmflags);

diff --git a/proto.h b/proto.h
index 772c904..ba75b64 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -646,7 +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 regexp_engine const *    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);
@@ -3150,7 +3150,11 @@ PERL_CALLCONV SV*        Perl_re_intuit_string(pTHX_ REGEXP  *const r)
 #define PERL_ARGS_ASSERT_RE_INTUIT_STRING      \
        assert(r)
 
-PERL_CALLCONV REGEXP*  Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, OP *expr, const regexp_engine* eng, REGEXP *VOL old_re, int *is_bare_re, U32 rx_flags, U32 pm_flags);
+PERL_CALLCONV REGEXP*  Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, OP *expr, const regexp_engine* eng, REGEXP *VOL old_re, int *is_bare_re, U32 rx_flags, U32 pm_flags)
+                       __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT_RE_OP_COMPILE \
+       assert(eng)
+
 PERL_CALLCONV Malloc_t Perl_realloc(Malloc_t where, MEM_SIZE nbytes)
                        __attribute__malloc__
                        __attribute__warn_unused_result__;

diff --git a/regcomp.c b/regcomp.c
index 289308c..021e14e 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -4900,18 +4900,11 @@ Perl_reginitcolors(pTHX)
  * scope
  */
 
-#ifndef PERL_IN_XSUB_RE
-#define RE_ENGINE_PTR &PL_core_reg_engine
-#else
-extern const struct regexp_engine my_reg_engine;
-#define RE_ENGINE_PTR &my_reg_engine
-#endif
-
 #ifndef PERL_IN_XSUB_RE 
 
-/* return the currently in-scope regex engine (or NULL if none)  */
+/* return the currently in-scope regex engine (or the default if none)  */
 
-regexp_engine *
+regexp_engine const *
 Perl_current_re_engine(pTHX)
 {
     dVAR;
@@ -4921,19 +4914,19 @@ Perl_current_re_engine(pTHX)
        SV **ptr;
 
        if (!table)
-           return NULL;
+           return &PL_core_reg_engine;
        ptr = hv_fetchs(table, "regcomp", FALSE);
        if ( !(ptr && SvIOK(*ptr) && SvIV(*ptr)))
-           return NULL;
+           return &PL_core_reg_engine;
        return INT2PTR(regexp_engine*,SvIV(*ptr));
     }
     else {
        SV *ptr;
        if (!PL_curcop->cop_hints_hash)
-           return NULL;
+           return &PL_core_reg_engine;
        ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
        if ( !(ptr && SvIOK(ptr) && SvIV(ptr)))
-           return NULL;
+           return &PL_core_reg_engine;
        return INT2PTR(regexp_engine*,SvIV(ptr));
     }
 }
@@ -4943,20 +4936,17 @@ REGEXP *
 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
 {
     dVAR;
-    regexp_engine *eng = current_re_engine();
+    regexp_engine const *eng = current_re_engine();
+    GET_RE_DEBUG_FLAGS_DECL;
 
     PERL_ARGS_ASSERT_PREGCOMP;
 
     /* Dispatch a request to compile a regexp to correct regexp engine. */
-    if (eng) {
-        GET_RE_DEBUG_FLAGS_DECL;
-       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);
+    DEBUG_COMPILE_r({
+       PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
+                       PTR2UV(eng));
+    });
+    return CALLREGCOMP_ENG(eng, pattern, flags);
 }
 #endif
 
@@ -4968,8 +4958,8 @@ Perl_re_compile(pTHX_ SV * const pattern, U32 rx_flags)
 {
     SV *pat = pattern; /* defeat constness! */
     PERL_ARGS_ASSERT_RE_COMPILE;
-    return Perl_re_op_compile(aTHX_ &pat, 1, NULL,
-                                   NULL, NULL, NULL, rx_flags, 0);
+    return Perl_re_op_compile(aTHX_ &pat, 1, NULL, current_re_engine(),
+                               NULL, NULL, rx_flags, 0);
 }
 
 
@@ -4989,8 +4979,9 @@ Perl_re_compile(pTHX_ SV * const pattern, U32 rx_flags)
  * If the pattern hasn't changed from old_re, then old_re will be
  * returned.
  *
- * If eng is set (and not equal to PL_core_reg_engine), then just do the
- * initial concatenation of arguments, then pass on to the external
+ * eng is the current engine. If that engine has an op_comp method, then
+ * handle directly (i.e. we assume that op_comp was us); otherwise, just
+ * do the initial concatenation of arguments and pass on to the external
  * engine.
  *
  * If is_bare_re is not null, set it to a boolean indicating whether the
@@ -5053,6 +5044,8 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
 #endif    
     GET_RE_DEBUG_FLAGS_DECL;
 
+    PERL_ARGS_ASSERT_RE_OP_COMPILE;
+
     DEBUG_r(if (!PL_colorset) reginitcolors());
 
 #ifndef PERL_IN_XSUB_RE
@@ -5212,7 +5205,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
                if (SvROK(rx))
                    rx = SvRV(rx);
                if (SvTYPE(rx) == SVt_REGEXP
-                   && RX_ENGINE((REGEXP*)rx) == RE_ENGINE_PTR)
+                   && RX_ENGINE((REGEXP*)rx)->op_comp)
                {
 
                    RXi_GET_DECL(((struct regexp*)SvANY(rx)), ri);
@@ -5320,7 +5313,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
 
     exp = SvPV_nomg(pat, plen);
 
-    if (eng && eng != RE_ENGINE_PTR) {
+    if (!eng->op_comp) {
        if ((SvUTF8(pat) && IN_BYTES)
                || SvGMAGICAL(pat) || SvAMAGIC(pat))
        {
@@ -5546,7 +5539,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
 
     /* non-zero initialization begins here */
     RXi_SET( r, ri );
-    r->engine= RE_ENGINE_PTR;
+    r->engine= eng;
     r->extflags = rx_flags;
     if (pm_flags & PMf_IS_QR) {
        ri->code_blocks = pRExC_state->code_blocks;
@@ -6176,8 +6169,6 @@ reStudy:
     return rx;
 }
 
-#undef RE_ENGINE_PTR
-
 
 SV*
 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,

diff --git a/regcomp.h b/regcomp.h
index f130734..6d037ef 100644 (file)
--- a/regcomp.h
+++ b/regcomp.h
@@ -523,8 +523,9 @@ EXTCONST regexp_engine PL_core_reg_engine = {
         Perl_reg_named_buff_iter,
         Perl_reg_qr_package,
 #if defined(USE_ITHREADS)        
-        Perl_regdupe_internal
+        Perl_regdupe_internal,
 #endif        
+        Perl_re_op_compile
 };
 #endif /* DOINIT */
 #endif /* PLUGGABLE_RE_EXTENSION */

diff --git a/regexp.h b/regexp.h
index 8b19055..b4427d3 100644 (file)
--- a/regexp.h
+++ b/regexp.h
@@ -163,6 +163,10 @@ typedef struct regexp_engine {
 #ifdef USE_ITHREADS
     void*   (*dupe) (pTHX_ REGEXP * const rx, CLONE_PARAMS *param);
 #endif
+    REGEXP* (*op_comp) (pTHX_ SV ** const patternp, int pat_count,
+                   OP *expr, const struct regexp_engine* eng,
+                   REGEXP *VOL old_re,
+                   int *is_bare_re, U32 orig_rx_flags, U32 pm_flags);
 } regexp_engine;
 
 /*