path: root/lang/perl/patches/999-fixup-regex-engine-build-under-Uusedl.patch

From ba6e2c38aafc23cf114f3ba0d0ff3baead34328b Mon Sep 17 00:00:00 2001
From: Yves Orton <demerphq@gmail.com>
Date: Tue, 1 Aug 2023 23:12:46 +0200
Subject: [PATCH] regcomp*.c, regexec.c - fixup regex engine build under
 -Uusedl

The regex engine is built a bit different from most of the perl
codebase. It is compiled as part of the main libperl.so and it is
also compiled (with DEBUGGING enabled) as part of the re extension.
When perl itself is compiled with DEBUGGING enabled then the code
in the re.so extension and the code in libperl.so is the same.

This all works fine and dandy until you have a static build where the
re.so is linked into libperl.so, which results in duplicate symbols
being defined. These symbols come in two flaviours: "auxiliary" and
"debugging" related symbols.

We have basically three cases:

1. USE_DYNAMIC_LOADING is defined. In this case we are doing a dynamic
   build and re.so will be separate from libperl.so, so it even if this
   is a DEBUGGING enabled build debug and auxiliary functions can be
   compiled into *both* re.so and libperl.so. This is basically the
   "standard build".

2. USE_DYNAMIC_LOADING is not defined, and DEBUGGING is not defined
   either. In this case auxiliary functions should only be compiled in
   libperl.so, and the debug functions should only be compiled into
   re.so

3. USE_DYNAMIC_LOADING is not defined, and DEBUGGING *is* defined. In
   this case auxiliary functions AND debug functions should only be
   compiled into libperl.so

It is possible to detect the different build options by looking at the
defines 'USE_DYNAMIC_LOADING', 'PERL_EXT_RE_DEBUG' and
'DEBUGGING_RE_ONLY'. 'USE_DYNAMIC_LOADING' is NOT defined when we are
building a static perl. 'PERL_EXT_RE_DEBUG' is defined only when we are
building re.so, and 'DEBUGGING_RE_ONLY' is defined only when we are
building re.so in a perl that is not itself already a DEBUGGING enabled
perl. The file ext/re/re_top.h responsible for setting up
DEBUGGING_RE_ONLY.

This patch uses 'PERL_EXT_RE_DEBUG', 'DEBUGGING_RE_ONLY' and
'USE_DYNAMIC_LOADING' to define in regcomp.h two further define flags
'PERL_RE_BUILD_DEBUG' and 'PERL_RE_BUILD_AUX'.

The 'PERL_RE_BUILD_DEBUG' flag determines if the debugging functions
should be compiled into libperl.so or re.so or both. The
'PERL_RE_BUILD_AUX' flag determines if the auxiliary functions should be
compiled into just libperl.so or into it and re.so. We then use these
flags to guard the different types of functions so that we can build in
all three modes without duplicate symbols.
---
 regcomp.c         |  13 +-
 regcomp.h         |  14 ++-
 regcomp_debug.c   | 308 +++++++++++++++++++++++-----------------------
 regcomp_invlist.c |   3 +-
 regexec.c         |   3 +-
 5 files changed, 181 insertions(+), 160 deletions(-)

--- a/regcomp.c
+++ b/regcomp.c
@@ -290,6 +290,7 @@ S_edit_distance(const UV* src,
 /* END of edit_distance() stuff
  * ========================================================= */
 
+#ifdef PERL_RE_BUILD_AUX
 /* add a data member to the struct reg_data attached to this regex, it should
  * always return a non-zero return. the 's' argument is the type of the items
  * being added and the n is the number of items. The length of 's' should match
@@ -340,6 +341,7 @@ Perl_reg_add_data(RExC_state_t* const pR
     assert(count>0);
     return count;
 }
+#endif /* PERL_RE_BUILD_AUX */
 
 /*XXX: todo make this not included in a non debugging perl, but appears to be
  * used anyway there, in 'use re' */
@@ -7443,6 +7445,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_stat
 }
 
 
+#ifdef PERL_RE_BUILD_AUX
 void
 Perl_populate_anyof_bitmap_from_invlist(pTHX_ regnode *node, SV** invlist_ptr)
 {
@@ -7502,6 +7505,7 @@ Perl_populate_anyof_bitmap_from_invlist(
         }
     }
 }
+#endif /* PERL_RE_BUILD_AUX */
 
 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
    Character classes ([:foo:]) can also be negated ([:^foo:]).
@@ -9095,6 +9099,7 @@ S_dump_regex_sets_structures(pTHX_ RExC_
 #undef IS_OPERATOR
 #undef IS_OPERAND
 
+#ifdef PERL_RE_BUILD_AUX
 void
 Perl_add_above_Latin1_folds(pTHX_ RExC_state_t *pRExC_state, const U8 cp, SV** invlist)
 {
@@ -9182,6 +9187,8 @@ Perl_add_above_Latin1_folds(pTHX_ RExC_s
          }
     }
 }
+#endif /* PERL_RE_BUILD_AUX */
+
 
 STATIC void
 S_output_posix_warnings(pTHX_ RExC_state_t *pRExC_state, AV* posix_warnings)
@@ -12105,6 +12112,7 @@ S_optimize_regclass(pTHX_
 
 #undef HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION
 
+#ifdef PERL_RE_BUILD_AUX
 void
 Perl_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state,
                 regnode* const node,
@@ -12261,6 +12269,7 @@ Perl_set_ANYOF_arg(pTHX_ RExC_state_t* c
     RExC_rxi->data->data[n] = (void*)rv;
     ARG1u_SET(node, n);
 }
+#endif /* PERL_RE_BUILD_AUX */
 
 SV *
 
@@ -12999,6 +13008,8 @@ S_regtail_study(pTHX_ RExC_state_t *pREx
 }
 #endif
 
+
+#ifdef PERL_RE_BUILD_AUX
 SV*
 Perl_get_ANYOFM_contents(pTHX_ const regnode * n) {
 
@@ -13047,7 +13058,7 @@ Perl_get_ANYOFHbbm_contents(pTHX_ const
                                       UTF_CONTINUATION_MARK | 0));
     return cp_list;
 }
-
+#endif /* PERL_RE_BUILD_AUX */
 
 
 SV *
--- a/regcomp.h
+++ b/regcomp.h
@@ -1554,7 +1554,19 @@ typedef enum {
 #define EVAL_OPTIMISTIC_FLAG    128
 #define EVAL_FLAGS_MASK         (EVAL_OPTIMISTIC_FLAG-1)
 
-
+/* We define PERL_RE_BUILD_DEBUG if we are NOT compiling the re extension and
+ * we are under DEBUGGING, or if we are ARE compiling the re extension
+ * and this is not a DEBUGGING enabled build (identified by
+ * DEBUGGING_RE_ONLY being defined)
+ */
+#if ( defined(USE_DYNAMIC_LOADING) && defined(DEBUGGING)) || \
+    ( defined(PERL_EXT_RE_BUILD) && defined(DEBUGGING_RE_ONLY)) || \
+    (!defined(PERL_EXT_RE_BUILD) && defined(DEBUGGING))
+#define PERL_RE_BUILD_DEBUG
+#endif
+#if ( defined(USE_DYNAMIC_LOADING) || !defined(PERL_EXT_RE_BUILD) )
+#define PERL_RE_BUILD_AUX
+#endif
 
 #endif /* PERL_REGCOMP_H_ */
 
--- a/regcomp_debug.c
+++ b/regcomp_debug.c
@@ -18,8 +18,7 @@
 #include "unicode_constants.h"
 #include "regcomp_internal.h"
 
-#ifdef DEBUGGING
-
+#ifdef PERL_RE_BUILD_DEBUG
 int
 Perl_re_printf(pTHX_ const char *fmt, ...)
 {
@@ -159,13 +158,160 @@ Perl_debug_peep(pTHX_ const char *str, c
    });
 }
 
-#endif /* DEBUGGING */
+const regnode *
+Perl_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
+            const regnode *last, const regnode *plast,
+            SV* sv, I32 indent, U32 depth)
+{
+    const regnode *next;
+    const regnode *optstart= NULL;
+
+    RXi_GET_DECL(r, ri);
+    DECLARE_AND_GET_RE_DEBUG_FLAGS;
+
+    PERL_ARGS_ASSERT_DUMPUNTIL;
+
+#ifdef DEBUG_DUMPUNTIL
+    Perl_re_printf( aTHX_  "--- %d : %d - %d - %d\n", indent, node-start,
+        last ? last-start : 0, plast ? plast-start : 0);
+#endif
+
+    if (plast && plast < last)
+        last= plast;
+
+    while (node && (!last || node < last)) {
+        const U8 op = OP(node);
+
+        if (op == CLOSE || op == SRCLOSE || op == WHILEM)
+            indent--;
+        next = regnext((regnode *)node);
+        const regnode *after = regnode_after((regnode *)node,0);
+
+        /* Where, what. */
+        if (op == OPTIMIZED) {
+            if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
+                optstart = node;
+            else
+                goto after_print;
+        } else
+            CLEAR_OPTSTART;
+
+        regprop(r, sv, node, NULL, NULL);
+        Perl_re_printf( aTHX_  "%4" IVdf ":%*s%s", (IV)(node - start),
+                      (int)(2*indent + 1), "", SvPVX_const(sv));
+
+        if (op != OPTIMIZED) {
+            if (next == NULL)           /* Next ptr. */
+                Perl_re_printf( aTHX_  " (0)");
+            else if (REGNODE_TYPE(op) == BRANCH
+                     && REGNODE_TYPE(OP(next)) != BRANCH )
+                Perl_re_printf( aTHX_  " (FAIL)");
+            else
+                Perl_re_printf( aTHX_  " (%" IVdf ")", (IV)(next - start));
+            Perl_re_printf( aTHX_ "\n");
+        }
+
+      after_print:
+        if (REGNODE_TYPE(op) == BRANCHJ) {
+            assert(next);
+            const regnode *nnode = (OP(next) == LONGJMP
+                                   ? regnext((regnode *)next)
+                                   : next);
+            if (last && nnode > last)
+                nnode = last;
+            DUMPUNTIL(after, nnode);
+        }
+        else if (REGNODE_TYPE(op) == BRANCH) {
+            assert(next);
+            DUMPUNTIL(after, next);
+        }
+        else if ( REGNODE_TYPE(op)  == TRIE ) {
+            const regnode *this_trie = node;
+            const U32 n = ARG1u(node);
+            const reg_ac_data * const ac = op>=AHOCORASICK ?
+               (reg_ac_data *)ri->data->data[n] :
+               NULL;
+            const reg_trie_data * const trie =
+                (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
+#ifdef DEBUGGING
+            AV *const trie_words
+                           = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
+#endif
+            const regnode *nextbranch= NULL;
+            I32 word_idx;
+            SvPVCLEAR(sv);
+            for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
+                SV ** const elem_ptr = av_fetch_simple(trie_words, word_idx, 0);
+
+                Perl_re_indentf( aTHX_  "%s ",
+                    indent+3,
+                    elem_ptr
+                    ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr),
+                                SvCUR(*elem_ptr), PL_dump_re_max_len,
+                                PL_colors[0], PL_colors[1],
+                                (SvUTF8(*elem_ptr)
+                                 ? PERL_PV_ESCAPE_UNI
+                                 : 0)
+                                | PERL_PV_PRETTY_ELLIPSES
+                                | PERL_PV_PRETTY_LTGT
+                            )
+                    : "???"
+                );
+                if (trie->jump) {
+                    U16 dist= trie->jump[word_idx+1];
+                    Perl_re_printf( aTHX_  "(%" UVuf ")\n",
+                               (UV)((dist ? this_trie + dist : next) - start));
+                    if (dist) {
+                        if (!nextbranch)
+                            nextbranch= this_trie + trie->jump[0];
+                        DUMPUNTIL(this_trie + dist, nextbranch);
+                    }
+                    if (nextbranch && REGNODE_TYPE(OP(nextbranch))==BRANCH)
+                        nextbranch= regnext((regnode *)nextbranch);
+                } else {
+                    Perl_re_printf( aTHX_  "\n");
+                }
+            }
+            if (last && next > last)
+                node= last;
+            else
+                node= next;
+        }
+        else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
+            DUMPUNTIL(after, after + 1); /* +1 is NOT a REGNODE_AFTER */
+        }
+        else if (REGNODE_TYPE(op) == CURLY && op != CURLYX) {
+            assert(next);
+            DUMPUNTIL(after, next);
+        }
+        else if ( op == PLUS || op == STAR) {
+            DUMPUNTIL(after, after + 1); /* +1 NOT a REGNODE_AFTER */
+        }
+        else if (REGNODE_TYPE(op) == EXACT || op == ANYOFHs) {
+            /* Literal string, where present. */
+            node = (const regnode *)REGNODE_AFTER_varies(node);
+        }
+        else {
+            node = REGNODE_AFTER_opcode(node,op);
+        }
+        if (op == CURLYX || op == OPEN || op == SROPEN)
+            indent++;
+        if (REGNODE_TYPE(op) == END)
+            break;
+    }
+    CLEAR_OPTSTART;
+#ifdef DEBUG_DUMPUNTIL
+    Perl_re_printf( aTHX_  "--- %d\n", (int)indent);
+#endif
+    return node;
+}
+
+#endif  /* PERL_RE_BUILD_DEBUG */
 
 /*
  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
  */
 #ifdef DEBUGGING
-
 static void
 S_regdump_intflags(pTHX_ const char *lead, const U32 flags)
 {
@@ -907,8 +1053,8 @@ Perl_regprop(pTHX_ const regexp *prog, S
 #endif  /* DEBUGGING */
 }
 
-#ifdef DEBUGGING
 
+#ifdef DEBUGGING
 STATIC void
 S_put_code_point(pTHX_ SV *sv, UV c)
 {
@@ -1517,154 +1663,4 @@ S_put_charclass_bitmap_innards(pTHX_ SV
 
     return did_output_something;
 }
-
-
-const regnode *
-Perl_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
-            const regnode *last, const regnode *plast,
-            SV* sv, I32 indent, U32 depth)
-{
-    const regnode *next;
-    const regnode *optstart= NULL;
-
-    RXi_GET_DECL(r, ri);
-    DECLARE_AND_GET_RE_DEBUG_FLAGS;
-
-    PERL_ARGS_ASSERT_DUMPUNTIL;
-
-#ifdef DEBUG_DUMPUNTIL
-    Perl_re_printf( aTHX_  "--- %d : %d - %d - %d\n", indent, node-start,
-        last ? last-start : 0, plast ? plast-start : 0);
-#endif
-
-    if (plast && plast < last)
-        last= plast;
-
-    while (node && (!last || node < last)) {
-        const U8 op = OP(node);
-
-        if (op == CLOSE || op == SRCLOSE || op == WHILEM)
-            indent--;
-        next = regnext((regnode *)node);
-        const regnode *after = regnode_after((regnode *)node,0);
-
-        /* Where, what. */
-        if (op == OPTIMIZED) {
-            if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
-                optstart = node;
-            else
-                goto after_print;
-        } else
-            CLEAR_OPTSTART;
-
-        regprop(r, sv, node, NULL, NULL);
-        Perl_re_printf( aTHX_  "%4" IVdf ":%*s%s", (IV)(node - start),
-                      (int)(2*indent + 1), "", SvPVX_const(sv));
-
-        if (op != OPTIMIZED) {
-            if (next == NULL)           /* Next ptr. */
-                Perl_re_printf( aTHX_  " (0)");
-            else if (REGNODE_TYPE(op) == BRANCH
-                     && REGNODE_TYPE(OP(next)) != BRANCH )
-                Perl_re_printf( aTHX_  " (FAIL)");
-            else
-                Perl_re_printf( aTHX_  " (%" IVdf ")", (IV)(next - start));
-            Perl_re_printf( aTHX_ "\n");
-        }
-
-      after_print:
-        if (REGNODE_TYPE(op) == BRANCHJ) {
-            assert(next);
-            const regnode *nnode = (OP(next) == LONGJMP
-                                   ? regnext((regnode *)next)
-                                   : next);
-            if (last && nnode > last)
-                nnode = last;
-            DUMPUNTIL(after, nnode);
-        }
-        else if (REGNODE_TYPE(op) == BRANCH) {
-            assert(next);
-            DUMPUNTIL(after, next);
-        }
-        else if ( REGNODE_TYPE(op)  == TRIE ) {
-            const regnode *this_trie = node;
-            const U32 n = ARG1u(node);
-            const reg_ac_data * const ac = op>=AHOCORASICK ?
-               (reg_ac_data *)ri->data->data[n] :
-               NULL;
-            const reg_trie_data * const trie =
-                (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
-#ifdef DEBUGGING
-            AV *const trie_words
-                           = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
-#endif
-            const regnode *nextbranch= NULL;
-            I32 word_idx;
-            SvPVCLEAR(sv);
-            for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
-                SV ** const elem_ptr = av_fetch_simple(trie_words, word_idx, 0);
-
-                Perl_re_indentf( aTHX_  "%s ",
-                    indent+3,
-                    elem_ptr
-                    ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr),
-                                SvCUR(*elem_ptr), PL_dump_re_max_len,
-                                PL_colors[0], PL_colors[1],
-                                (SvUTF8(*elem_ptr)
-                                 ? PERL_PV_ESCAPE_UNI
-                                 : 0)
-                                | PERL_PV_PRETTY_ELLIPSES
-                                | PERL_PV_PRETTY_LTGT
-                            )
-                    : "???"
-                );
-                if (trie->jump) {
-                    U16 dist= trie->jump[word_idx+1];
-                    Perl_re_printf( aTHX_  "(%" UVuf ")\n",
-                               (UV)((dist ? this_trie + dist : next) - start));
-                    if (dist) {
-                        if (!nextbranch)
-                            nextbranch= this_trie + trie->jump[0];
-                        DUMPUNTIL(this_trie + dist, nextbranch);
-                    }
-                    if (nextbranch && REGNODE_TYPE(OP(nextbranch))==BRANCH)
-                        nextbranch= regnext((regnode *)nextbranch);
-                } else {
-                    Perl_re_printf( aTHX_  "\n");
-                }
-            }
-            if (last && next > last)
-                node= last;
-            else
-                node= next;
-        }
-        else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
-            DUMPUNTIL(after, after + 1); /* +1 is NOT a REGNODE_AFTER */
-        }
-        else if (REGNODE_TYPE(op) == CURLY && op != CURLYX) {
-            assert(next);
-            DUMPUNTIL(after, next);
-        }
-        else if ( op == PLUS || op == STAR) {
-            DUMPUNTIL(after, after + 1); /* +1 NOT a REGNODE_AFTER */
-        }
-        else if (REGNODE_TYPE(op) == EXACT || op == ANYOFHs) {
-            /* Literal string, where present. */
-            node = (const regnode *)REGNODE_AFTER_varies(node);
-        }
-        else {
-            node = REGNODE_AFTER_opcode(node,op);
-        }
-        if (op == CURLYX || op == OPEN || op == SROPEN)
-            indent++;
-        if (REGNODE_TYPE(op) == END)
-            break;
-    }
-    CLEAR_OPTSTART;
-#ifdef DEBUG_DUMPUNTIL
-    Perl_re_printf( aTHX_  "--- %d\n", (int)indent);
-#endif
-    return node;
-}
-
-#endif  /* DEBUGGING */
+#endif /* DEBUGGING */
--- a/regcomp_invlist.c
+++ b/regcomp_invlist.c
@@ -18,7 +18,7 @@
 #include "unicode_constants.h"
 #include "regcomp_internal.h"
 
-
+#ifdef PERL_RE_BUILD_AUX
 void
 Perl_populate_bitmap_from_invlist(pTHX_ SV * invlist, const UV offset, const U8 * bitmap, const Size_t len)
 {
@@ -70,6 +70,7 @@ Perl_populate_invlist_from_bitmap(pTHX_
         }
     }
 }
+#endif /* PERL_RE_BUILD_AUX */
 
 /* This section of code defines the inversion list object and its methods.  The
  * interfaces are highly subject to change, so as much as possible is static to
--- a/regexec.c
+++ b/regexec.c
@@ -4421,7 +4421,8 @@ S_regtry(pTHX_ regmatch_info *reginfo, c
 */
 #define REPORT_CODE_OFF 29
 #define INDENT_CHARS(depth) ((int)(depth) % 20)
-#ifdef DEBUGGING
+
+#ifdef PERL_RE_BUILD_DEBUG
 int
 Perl_re_exec_indentf(pTHX_ const char *fmt, U32 depth, ...)
 {