From afb790dd4ff01f57e25399cc548ef7f9609a1ad2 Mon Sep 17 00:00:00 2001
From: Karl Williamson <public@khwilliamson.com>
Date: Sun, 15 Jul 2012 22:01:52 -0600
Subject: [PATCH] utf8.c: Create API so internals can be hidden

This creates a function to hide some of the internal details of swashes
from the regex engine, which is the only authorized user, enforced
through #ifdefs in embed.fnc.  These work closely together, but it's
best to have a clean interface.
---
 embed.fnc |  1 +
 embed.h   |  1 +
 proto.h   |  6 ++++++
 regcomp.c |  9 ++-------
 utf8.c    | 13 +++++++++++++
 5 files changed, 23 insertions(+), 7 deletions(-)

diff --git a/embed.fnc b/embed.fnc
index 0f19f7c..f2e1390 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1420,6 +1420,7 @@ EXp	|SV*	|_core_swash_init|NN const char* pkg|NN const char* name|NN SV* listsv|
                 |I32 none|bool return_if_undef|NULLOK SV* invlist \
 		|bool passed_in_invlist_has_user_defined_property
 EXMpR	|SV*	|_invlist_contents|NN SV* const invlist
+EXMpR	|bool	|_is_swash_user_defined|NN SV *swash
 #endif
 Ap	|void	|taint_env
 Ap	|void	|taint_proper	|NULLOK const char* f|NN const char *const s
diff --git a/embed.h b/embed.h
index a010f2d..b0cfe9f 100644
--- a/embed.h
+++ b/embed.h
@@ -953,6 +953,7 @@
 #  if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_REGEXEC_C) || defined(PERL_IN_UTF8_C)
 #define _core_swash_init(a,b,c,d,e,f,g,h)	Perl__core_swash_init(aTHX_ a,b,c,d,e,f,g,h)
 #define _invlist_contents(a)	Perl__invlist_contents(aTHX_ a)
+#define _is_swash_user_defined(a)	Perl__is_swash_user_defined(aTHX_ a)
 #  endif
 #  if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_UTF8_C)
 #define _add_range_to_invlist(a,b,c)	Perl__add_range_to_invlist(aTHX_ a,b,c)
diff --git a/proto.h b/proto.h
index 4da7ab0..b45aa80 100644
--- a/proto.h
+++ b/proto.h
@@ -6677,6 +6677,12 @@ PERL_CALLCONV SV*	Perl__invlist_contents(pTHX_ SV* const invlist)
 #define PERL_ARGS_ASSERT__INVLIST_CONTENTS	\
 	assert(invlist)
 
+PERL_CALLCONV bool	Perl__is_swash_user_defined(pTHX_ SV *swash)
+			__attribute__warn_unused_result__
+			__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT__IS_SWASH_USER_DEFINED	\
+	assert(swash)
+
 #endif
 #if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_UTF8_C)
 PERL_CALLCONV SV*	Perl__add_range_to_invlist(pTHX_ SV* invlist, const UV start, const UV end)
diff --git a/regcomp.c b/regcomp.c
index 22e2cd8..c6a6b1d 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -11234,13 +11234,8 @@ parseit:
                         /* Here, did get the swash and its inversion list.  If
                          * the swash is from a user-defined property, then this
                          * whole character class should be regarded as such */
-                        SV** user_defined_svp =
-                                            hv_fetchs(MUTABLE_HV(SvRV(swash)),
-                                                        "USER_DEFINED", FALSE);
-                        if (user_defined_svp) {
-                            has_user_defined_property
-                                                    |= SvUV(*user_defined_svp);
-                        }
+                        has_user_defined_property =
+                                                _is_swash_user_defined(swash);
 
                         /* Invert if asking for the complement */
                         if (value == 'P') {
diff --git a/utf8.c b/utf8.c
index 2592728..5797f8e 100644
--- a/utf8.c
+++ b/utf8.c
@@ -4090,6 +4090,19 @@ Perl__swash_to_invlist(pTHX_ SV* const swash)
     return invlist;
 }
 
+bool
+Perl__is_swash_user_defined(pTHX_ SV* const swash)
+{
+    SV** ptr = hv_fetchs(MUTABLE_HV(SvRV(swash)), "USER_DEFINED", FALSE);
+
+    PERL_ARGS_ASSERT__IS_SWASH_USER_DEFINED;
+
+    if (! ptr) {
+        return FALSE;
+    }
+    return cBOOL(SvUV(*ptr));
+}
+
 /*
 =for apidoc uvchr_to_utf8
 
-- 
2.7.4