This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
utf8.c: Add function to create inversion of swash
authorKarl Williamson <public@khwilliamson.com>
Sun, 7 Nov 2010 22:40:40 +0000 (15:40 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Mon, 8 Nov 2010 05:42:42 +0000 (21:42 -0800)
This adds _swash_inversion_hash() which takes a mapping swash and returns
a hash that is the inverse relation.  That is, given a code point, it
allows quick lookup of all code points that map to it.

The function is not for public use, as it will likely be revised, so is
not in the public API, and it's name begins with underscore.

It does not deal with multi-char mappings at this time, nor other swash
complications.

embed.fnc
embed.h
global.sym
proto.h
utf8.c

index 22e9345..c9d054d 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1257,6 +1257,7 @@ Apd       |void   |sv_vsetpvfn    |NN SV *const sv|NN const char *const pat|const STRLEN pa
 ApR    |NV     |str_to_version |NN SV *sv
 Ap     |SV*    |swash_init     |NN const char* pkg|NN const char* name|NN SV* listsv|I32 minbits|I32 none
 Ap     |UV     |swash_fetch    |NN SV *swash|NN const U8 *ptr|bool do_utf8
+EMpRX  |HV*    |_swash_inversion_hash  |NN SV *swash
 Ap     |void   |taint_env
 Ap     |void   |taint_proper   |NULLOK const char* f|NN const char *const s
 Apd    |UV     |to_utf8_case   |NN const U8 *p|NN U8* ustrp|NULLOK STRLEN *lenp \
diff --git a/embed.h b/embed.h
index 0d83212..ac080b7 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define do_spawn_nowait(a)     Perl_do_spawn_nowait(aTHX_ a)
 #endif
 #if defined(PERL_CORE) || defined(PERL_EXT)
+#define _swash_inversion_hash(a)       Perl__swash_inversion_hash(aTHX_ a)
 #define av_reify(a)            Perl_av_reify(aTHX_ a)
 #define grok_bslash_c(a,b)     Perl_grok_bslash_c(aTHX_ a,b)
 #define grok_bslash_o(a,b,c,d,e)       Perl_grok_bslash_o(aTHX_ a,b,c,d,e)
index 9e37876..95a232b 100644 (file)
@@ -17,6 +17,7 @@
 #
 Perl_Gv_AMupdate
 Perl_PerlIO_context_layers
+Perl__swash_inversion_hash
 Perl_amagic_call
 Perl_amagic_deref_call
 Perl_apply_attrs_string
diff --git a/proto.h b/proto.h
index 17cacb6..04bb2d8 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -23,6 +23,12 @@ PERL_CALLCONV int    Perl_Gv_AMupdate(pTHX_ HV* stash, bool destructing)
        assert(stash)
 
 PERL_CALLCONV const char *     Perl_PerlIO_context_layers(pTHX_ const char *mode);
+PERL_CALLCONV HV*      Perl__swash_inversion_hash(pTHX_ SV *swash)
+                       __attribute__warn_unused_result__
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT__SWASH_INVERSION_HASH \
+       assert(swash)
+
 PERL_CALLCONV PADOFFSET        Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
                        __attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_ALLOCMY       \
diff --git a/utf8.c b/utf8.c
index 432e4ad..818af02 100644 (file)
--- a/utf8.c
+++ b/utf8.c
@@ -2377,6 +2377,138 @@ S_swash_get(pTHX_ SV* swash, UV start, UV span)
     return swatch;
 }
 
+HV*
+Perl__swash_inversion_hash(pTHX_ SV* swash)
+{
+
+   /* Subject to change or removal.  For use only in one place in regexec.c
+    *
+    * Returns a hash which is the inversion and closure of a swash mapping.
+    * For example, consider the input lines:
+    * 004B             006B
+    * 004C             006C
+    * 212A             006B
+    *
+    * The returned hash would have two keys, the utf8 for 006B and the utf8 for
+    * 006C.  The value for each key is an array.  For 006C, the array would
+    * have a two elements, the utf8 for itself, and for 004C.  For 006B, there
+    * would be three elements in its array, the utf8 for 006B, 004B and 212A.
+    *
+    * Essentially, for any code point, it gives all the code points that map to
+    * it, or the list of 'froms' for that point.
+    *
+    * Currently it only looks at the main body of the swash, and ignores any
+    * additions or deletions from other swashes */
+
+    U8 *l, *lend;
+    STRLEN lcur;
+    HV *const hv = MUTABLE_HV(SvRV(swash));
+
+    /* The string containing the main body of the table */
+    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 nonesvp = hv_fetchs(hv, "NONE", FALSE);
+    /*SV** const extssvp = hv_fetchs(hv, "EXTRAS", 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 */
+    const UV     none  = SvUV(*nonesvp);
+
+    HV* ret = newHV();
+
+    PERL_ARGS_ASSERT__SWASH_INVERSION_HASH;
+
+    /* Must have at least 8 bits to get the mappings */
+    if (bits != 8 && bits != 16 && bits != 32) {
+       Perl_croak(aTHX_ "panic: swash_inversion_hash doesn't expect bits %"UVuf,
+                                                (UV)bits);
+    }
+
+    /* read $swash->{LIST} */
+    l = (U8*)SvPV(*listsvp, lcur);
+    lend = l + lcur;
+
+    /* Go through each input line */
+    while (l < lend) {
+       UV min, max, val;
+       UV inverse;
+       l = S_swash_scan_list_line(aTHX_ l, lend, &min, &max, &val,
+                                        cBOOL(octets), typestr);
+       if (l > lend) {
+           break;
+       }
+
+       /* Each element in the range is to be inverted */
+       for (inverse = min; inverse <= max; inverse++) {
+           AV* list;
+           SV* element;
+           SV** listp;
+           IV i;
+           bool found_key = FALSE;
+
+           /* The key is the inverse mapping */
+           char key[UTF8_MAXBYTES+1];
+           char* key_end = (char *) uvuni_to_utf8((U8*) key, val);
+           STRLEN key_len = key_end - key;
+
+           /* And the value is what the forward mapping is from. */
+           char utf8_inverse[UTF8_MAXBYTES+1];
+           char *utf8_inverse_end = (char *) uvuni_to_utf8((U8*) utf8_inverse, inverse);
+
+           /* Get the list for the map */
+           if ((listp = hv_fetch(ret, key, key_len, FALSE))) {
+               list = (AV*) *listp;
+           }
+           else { /* No entry yet for it: create one */
+               list = newAV();
+               if (! hv_store(ret, key, key_len, (SV*) list, FALSE)) {
+                   Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
+               }
+           }
+
+           for (i = 0; i < av_len(list); i++) {
+               SV** entryp = av_fetch(list, i, FALSE);
+               SV* entry;
+               if (entryp == NULL) {
+                   Perl_croak(aTHX_ "panic: av_fetch() unexpectedly failed");
+               }
+               entry = *entryp;
+               if (SvCUR(entry) != key_len) {
+                   continue;
+               }
+               if (memEQ(key, SvPVX(entry), key_len)) {
+                   found_key = TRUE;
+                   break;
+               }
+           }
+           if (! found_key) {
+               element = newSVpvn_flags(key, key_len, SVf_UTF8);
+               av_push(list, element);
+           }
+
+
+           /* Simply add the value to the list */
+           element = newSVpvn_flags(utf8_inverse, utf8_inverse_end - utf8_inverse, SVf_UTF8);
+           av_push(list, element);
+
+           /* swash_get() increments the value of val for each element in the
+            * range.  That makes more compact tables possible.  You can
+            * express the capitalization, for example, of all consecutive
+            * letters with a single line: 0061\t007A\t0041 This maps 0061 to
+            * 0041, 0062 to 0042, etc.  I (khw) have never understood 'none',
+            * and it's not documented, and perhaps not even currently used,
+            * but I copied the semantics from swash_get(), just in case */
+           if (!none || val < none) {
+               ++val;
+           }
+       }
+    }
+
+    return ret;
+}
+
 /*
 =for apidoc uvchr_to_utf8