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.

4 files changed, 22 insertions, 5 deletions

diff --git a/embed.fnc b/embed.fnc
index ab2cc87465..292ccaa7bd 100644
--- 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 1cd59b22a6..62e9beea5b 100644
--- 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 b9a7a7aaf1..c28ec54780 100644
--- 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 66d2ef8022..4275b37d36 100644
--- 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