This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
utf8.c: Create API so internals can be hidden
authorKarl Williamson <public@khwilliamson.com>
Mon, 16 Jul 2012 04:01:52 +0000 (22:01 -0600)
committerKarl Williamson <public@khwilliamson.com>
Thu, 19 Jul 2012 15:39:06 +0000 (09:39 -0600)
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
embed.h
proto.h
regcomp.c
utf8.c

index 0f19f7c..f2e1390 100644 (file)
--- 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 (file)
--- a/embed.h
+++ b/embed.h
 #  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 (file)
--- 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)
index 22e2cd8..c6a6b1d 100644 (file)
--- 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 (file)
--- 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