regexec.c: Allow for returning shared swash

This changes the function that returns the swash associated with a
bracketed character class so that it returns the original swash and not
a copy.  The function is renamed and made accessible only from within
regexec.c, and a new wrapper function with the original name is created
that just calls the other one and returns a copy of the swash.

Thus, all access from outside regexec.c will use a copy which if
overwritten will not harm others; while the option exists from within
regexec.c to use a shared version.

diff --git a/embed.fnc b/embed.fnc
index ab2cc87..292ccaa 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1967,6 +1967,9 @@ ERs       |bool   |reginclass     |NULLOK const regexp * const prog|NN const regnode * const
 Es     |CHECKPOINT|regcppush   |I32 parenfloor
 Es     |char*  |regcppop       |NN const regexp *rex
 ERsn   |U8*    |reghop3        |NN U8 *s|I32 off|NN const U8 *lim
+ERsM   |SV*    |core_regclass_swash|NULLOK const regexp *prog \
+                               |NN const struct regnode *node|bool doinit \
+                               |NULLOK SV **listsvp|NULLOK SV **altsvp
 #ifdef XXX_dmq
 ERsn   |U8*    |reghop4        |NN U8 *s|I32 off|NN const U8 *llim \
                                |NN const U8 *rlim

diff --git a/embed.h b/embed.h
index 1cd59b2..62e9bee 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -960,6 +960,7 @@
 #define _swash_to_invlist(a)   Perl__swash_to_invlist(aTHX_ a)
 #  endif
 #  if defined(PERL_IN_REGEXEC_C)
+#define core_regclass_swash(a,b,c,d,e) S_core_regclass_swash(aTHX_ a,b,c,d,e)
 #define find_byclass(a,b,c,d,e)        S_find_byclass(aTHX_ a,b,c,d,e)
 #define reg_check_named_buff_matched(a,b)      S_reg_check_named_buff_matched(aTHX_ a,b)
 #define regcppop(a)            S_regcppop(aTHX_ a)

diff --git a/proto.h b/proto.h
index b9a7a7a..c28ec54 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -6604,6 +6604,12 @@ PERL_CALLCONV SV*        Perl__swash_to_invlist(pTHX_ SV* const swash)
 
 #endif
 #if defined(PERL_IN_REGEXEC_C)
+STATIC SV*     S_core_regclass_swash(pTHX_ const regexp *prog, const struct regnode *node, bool doinit, SV **listsvp, SV **altsvp)
+                       __attribute__warn_unused_result__
+                       __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_CORE_REGCLASS_SWASH   \
+       assert(node)
+
 STATIC char*   S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, const char *strend, regmatch_info *reginfo)
                        __attribute__warn_unused_result__
                        __attribute__nonnull__(pTHX_1)

diff --git a/regexec.c b/regexec.c
index 66d2ef8..4275b37 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -6476,12 +6476,20 @@ S_regrepeat(pTHX_ const regexp *prog, const regnode *p, I32 max, int depth)
 
 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
 /*
-- regclass_swash - prepare the utf8 swash
-*/
-
+- regclass_swash - prepare the utf8 swash.  Wraps the shared core version to
+create a copy so that changes the caller makes won't change the shared one
+ */
 SV *
 Perl_regclass_swash(pTHX_ const regexp *prog, register const regnode* node, bool doinit, SV** listsvp, SV **altsvp)
 {
+    PERL_ARGS_ASSERT_REGCLASS_SWASH;
+    return newSVsv(core_regclass_swash(prog, node, doinit, listsvp, altsvp));
+}
+#endif
+
+STATIC SV *
+S_core_regclass_swash(pTHX_ const regexp *prog, register const regnode* node, bool doinit, SV** listsvp, SV **altsvp)
+{
     /* Returns the swash for the input 'node' in the regex 'prog'.
      * If <doinit> is true, will attempt to create the swash if not already
      *   done.
@@ -6500,7 +6508,7 @@ Perl_regclass_swash(pTHX_ const regexp *prog, register const regnode* node, bool
     RXi_GET_DECL(prog,progi);
     const struct reg_data * const data = prog ? progi->data : NULL;
 
-    PERL_ARGS_ASSERT_REGCLASS_SWASH;
+    PERL_ARGS_ASSERT_CORE_REGCLASS_SWASH;
 
     assert(ANYOF_NONBITMAP(node));
 
@@ -6587,7 +6595,6 @@ Perl_regclass_swash(pTHX_ const regexp *prog, register const regnode* node, bool
 
     return sw;
 }
-#endif
 
 /*
  - reginclass - determine if a character falls into a character class