S_return_lvalues: collapse duplicated code

[perl5.git] / utf8.c

diff --git a/utf8.c b/utf8.c
index 99eea4b..797c811 100644 (file)
--- a/utf8.c
+++ b/utf8.c
@@ -2268,7 +2268,9 @@ S_swash_scan_list_line(pTHX_ U8* l, U8* const lend, UV* min, UV* max, UV* val,
 {
     const int  typeto  = typestr[0] == 'T' && typestr[1] == 'o';
     STRLEN numlen;         /* Length of the number */
-    I32 flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
+    I32 flags = PERL_SCAN_SILENT_ILLDIGIT
+               | PERL_SCAN_DISALLOW_PREFIX
+               | PERL_SCAN_SILENT_NON_PORTABLE;
 
     /* nl points to the next \n in the scan */
     U8* const nl = (U8*)memchr(l, '\n', lend - l);
@@ -2288,7 +2290,9 @@ S_swash_scan_list_line(pTHX_ U8* l, U8* const lend, UV* min, UV* max, UV* val,
     /* The max range value follows, separated by a BLANK */
     if (isBLANK(*l)) {
        ++l;
-       flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
+       flags = PERL_SCAN_SILENT_ILLDIGIT
+               | PERL_SCAN_DISALLOW_PREFIX
+               | PERL_SCAN_SILENT_NON_PORTABLE;
        numlen = lend - l;
        *max = grok_hex((char *)l, &numlen, &flags, NULL);
        if (numlen)
@@ -2301,8 +2305,9 @@ S_swash_scan_list_line(pTHX_ U8* l, U8* const lend, UV* min, UV* max, UV* val,
        if (wants_value) {
            if (isBLANK(*l)) {
                ++l;
-               flags = PERL_SCAN_SILENT_ILLDIGIT |
-                       PERL_SCAN_DISALLOW_PREFIX;
+               flags = PERL_SCAN_SILENT_ILLDIGIT
+                     | PERL_SCAN_DISALLOW_PREFIX
+                     | PERL_SCAN_SILENT_NON_PORTABLE;
                numlen = lend - l;
                *val = grok_hex((char *)l, &numlen, &flags, NULL);
                if (numlen)
@@ -2353,7 +2358,7 @@ STATIC SV*
 S_swash_get(pTHX_ SV* swash, UV start, UV span)
 {
     SV *swatch;
-    U8 *l, *lend, *x, *xend, *s;
+    U8 *l, *lend, *x, *xend, *s, *send;
     STRLEN lcur, xcur, scur;
     HV *const hv = MUTABLE_HV(SvRV(swash));
 
@@ -2364,6 +2369,7 @@ S_swash_get(pTHX_ SV* swash, UV start, UV span)
     SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
     SV** const nonesvp = hv_fetchs(hv, "NONE", FALSE);
     SV** const extssvp = hv_fetchs(hv, "EXTRAS", FALSE);
+    SV** const invert_it_svp = hv_fetchs(hv, "INVERT_IT", FALSE);
     const U8* const typestr = (U8*)SvPV_nolen(*typesvp);
     const STRLEN bits  = SvUV(*bitssvp);
     const STRLEN octets = bits >> 3; /* if bits == 1, then octets == 0 */
@@ -2466,7 +2472,17 @@ S_swash_get(pTHX_ SV* swash, UV start, UV span)
     } /* while */
   go_out_list:
 
-    /* read $swash->{EXTRAS} */
+    /* Invert if the data says it should be */
+    if (invert_it_svp && SvUV(*invert_it_svp)) {
+       send = s + scur;
+       while (s < send) {
+           *s = ~(*s);
+           s++;
+       }
+    }
+
+    /* read $swash->{EXTRAS}
+     * This code also copied to swash_to_invlist() below */
     x = (U8*)SvPV(*extssvp, xcur);
     xend = x + xcur;
     while (x < xend) {
@@ -2884,10 +2900,14 @@ Perl__swash_to_invlist(pTHX_ SV* const swash)
     SV** const listsvp = hv_fetchs(hv, "LIST", FALSE);
     SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
     SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
+    SV** const extssvp = hv_fetchs(hv, "EXTRAS", FALSE);
+    SV** const invert_it_svp = hv_fetchs(hv, "INVERT_IT", FALSE);
 
     const U8* const typestr = (U8*)SvPV_nolen(*typesvp);
     const STRLEN bits  = SvUV(*bitssvp);
     const STRLEN octets = bits >> 3; /* if bits == 1, then octets == 0 */
+    U8 *x, *xend;
+    STRLEN xcur;
 
     SV* invlist;
 
@@ -2939,6 +2959,84 @@ Perl__swash_to_invlist(pTHX_ SV* const swash)
        _append_range_to_invlist(invlist, start, end);
     }
 
+    /* Invert if the data says it should be */
+    if (invert_it_svp && SvUV(*invert_it_svp)) {
+       _invlist_invert(invlist);
+    }
+
+    /* This code is copied from swash_get()
+     * read $swash->{EXTRAS} */
+    x = (U8*)SvPV(*extssvp, xcur);
+    xend = x + xcur;
+    while (x < xend) {
+       STRLEN namelen;
+       U8 *namestr;
+       SV** othersvp;
+       HV* otherhv;
+       STRLEN otherbits;
+       SV **otherbitssvp, *other;
+       U8 *nl;
+
+       const U8 opc = *x++;
+       if (opc == '\n')
+           continue;
+
+       nl = (U8*)memchr(x, '\n', xend - x);
+
+       if (opc != '-' && opc != '+' && opc != '!' && opc != '&') {
+           if (nl) {
+               x = nl + 1; /* 1 is length of "\n" */
+               continue;
+           }
+           else {
+               x = xend; /* to EXTRAS' end at which \n is not found */
+               break;
+           }
+       }
+
+       namestr = x;
+       if (nl) {
+           namelen = nl - namestr;
+           x = nl + 1;
+       }
+       else {
+           namelen = xend - namestr;
+           x = xend;
+       }
+
+       othersvp = hv_fetch(hv, (char *)namestr, namelen, FALSE);
+       otherhv = MUTABLE_HV(SvRV(*othersvp));
+       otherbitssvp = hv_fetchs(otherhv, "BITS", FALSE);
+       otherbits = (STRLEN)SvUV(*otherbitssvp);
+
+       if (bits != otherbits || bits != 1) {
+           Perl_croak(aTHX_ "panic: _swash_to_invlist only operates on boolean properties");
+       }
+
+       /* The "other" swatch must be destroyed after. */
+       other = _swash_to_invlist((SV *)*othersvp);
+
+       /* End of code copied from swash_get() */
+       switch (opc) {
+       case '+':
+           _invlist_union(invlist, other, &invlist);
+           break;
+       case '!':
+           _invlist_invert(other);
+           _invlist_union(invlist, other, &invlist);
+           break;
+       case '-':
+           _invlist_subtract(invlist, other, &invlist);
+           break;
+       case '&':
+           _invlist_intersection(invlist, other, &invlist);
+           break;
+       default:
+           break;
+       }
+       sv_free(other); /* through with it! */
+    }
+
     return invlist;
 }