-HV*
-Perl__swash_inversion_hash(pTHX_ SV* const swash)
-{
-
- /* Subject to change or removal. For use only in regcomp.c and regexec.c
- * Can't be used on a property that is subject to user override, as it
- * relies on the value of SPECIALS in the swash which would be set by
- * utf8_heavy.pl to the hash in the non-overriden file, and hence is not set
- * for overridden properties
- *
- * 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 UTF-8 for 006B and the UTF-8 for
- * 006C. The value for each key is an array. For 006C, the array would
- * have two elements, the UTF-8 for itself, and for 004C. For 006B, there
- * would be three elements in its array, the UTF-8 for 006B, 004B and 212A.
- *
- * Note that there are no elements in the hash for 004B, 004C, 212A. The
- * keys are only code points that are folded-to, so it isn't a full closure.
- *
- * 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 ignores any additions or deletions from other swashes,
- * looking at just the main body of the swash, and if there are SPECIALS
- * in the swash, at that hash
- *
- * The specials hash can be extra code points, and most likely consists of
- * maps from single code points to multiple ones (each expressed as a string
- * of UTF-8 characters). This function currently returns only 1-1 mappings.
- * However consider this possible input in the specials hash:
- * "\xEF\xAC\x85" => "\x{0073}\x{0074}", # U+FB05 => 0073 0074
- * "\xEF\xAC\x86" => "\x{0073}\x{0074}", # U+FB06 => 0073 0074
- *
- * Both FB05 and FB06 map to the same multi-char sequence, which we don't
- * currently handle. But it also means that FB05 and FB06 are equivalent in
- * a 1-1 mapping which we should handle, and this relationship may not be in
- * the main table. Therefore this function examines all the multi-char
- * sequences and adds the 1-1 mappings that come out of that.
- *
- * XXX This function was originally intended to be multipurpose, but its
- * only use is quite likely to remain for constructing the inversion of
- * the CaseFolding (//i) property. If it were more general purpose for
- * regex patterns, it would have to do the FB05/FB06 game for simple folds,
- * because certain folds are prohibited under /iaa and /il. As an example,
- * in Unicode 3.0.1 both U+0130 and U+0131 fold to 'i', and hence are both
- * equivalent under /i. But under /iaa and /il, the folds to 'i' are
- * prohibited, so we would not figure out that they fold to each other.
- * Code could be written to automatically figure this out, similar to the
- * code that does this for multi-character folds, but this is the only case
- * where something like this is ever likely to happen, as all the single
- * char folds to the 0-255 range are now quite settled. Instead there is a
- * little special code that is compiled only for this Unicode version. This
- * is smaller and didn't require much coding time to do. But this makes
- * this routine strongly tied to being used just for CaseFolding. If ever
- * it should be generalized, this would have to be fixed */
-
- U8 *l, *lend;
- STRLEN lcur;
- HV *const hv = MUTABLE_HV(SvRV(swash));
-
- /* The string containing the main body of the table. This will have its
- * assertion fail if the swash has been converted to its inversion list */
- 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);
- SV **specials_p = hv_fetchs(hv, "SPECIALS", 0);
-
- 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);
- }
-
- if (specials_p) { /* It might be "special" (sometimes, but not always, a
- mapping to more than one character */
-
- /* Construct an inverse mapping hash for the specials */
- HV * const specials_hv = MUTABLE_HV(SvRV(*specials_p));
- HV * specials_inverse = newHV();
- char *char_from; /* the lhs of the map */
- I32 from_len; /* its byte length */
- char *char_to; /* the rhs of the map */
- I32 to_len; /* its byte length */
- SV *sv_to; /* and in a sv */
- AV* from_list; /* list of things that map to each 'to' */
-
- hv_iterinit(specials_hv);
-
- /* The keys are the characters (in UTF-8) that map to the corresponding
- * UTF-8 string value. Iterate through the list creating the inverse
- * list. */
- while ((sv_to = hv_iternextsv(specials_hv, &char_from, &from_len))) {
- SV** listp;
- if (! SvPOK(sv_to)) {
- Perl_croak(aTHX_ "panic: value returned from hv_iternextsv() "
- "unexpectedly is not a string, flags=%lu",
- (unsigned long)SvFLAGS(sv_to));
- }
- /*DEBUG_U(PerlIO_printf(Perl_debug_log, "Found mapping from %" UVXf ", First char of to is %" UVXf "\n", valid_utf8_to_uvchr((U8*) char_from, 0), valid_utf8_to_uvchr((U8*) SvPVX(sv_to), 0)));*/
-
- /* Each key in the inverse list is a mapped-to value, and the key's
- * hash value is a list of the strings (each in UTF-8) that map to
- * it. Those strings are all one character long */
- if ((listp = hv_fetch(specials_inverse,
- SvPVX(sv_to),
- SvCUR(sv_to), 0)))
- {
- from_list = (AV*) *listp;
- }
- else { /* No entry yet for it: create one */
- from_list = newAV();
- if (! hv_store(specials_inverse,
- SvPVX(sv_to),
- SvCUR(sv_to),
- (SV*) from_list, 0))
- {
- Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
- }
- }
-
- /* Here have the list associated with this 'to' (perhaps newly
- * created and empty). Just add to it. Note that we ASSUME that
- * the input is guaranteed to not have duplications, so we don't
- * check for that. Duplications just slow down execution time. */
- av_push(from_list, newSVpvn_utf8(char_from, from_len, TRUE));
- }
-
- /* Here, 'specials_inverse' contains the inverse mapping. Go through
- * it looking for cases like the FB05/FB06 examples above. There would
- * be an entry in the hash like
- * 'st' => [ FB05, FB06 ]
- * In this example we will create two lists that get stored in the
- * returned hash, 'ret':
- * FB05 => [ FB05, FB06 ]
- * FB06 => [ FB05, FB06 ]
- *
- * Note that there is nothing to do if the array only has one element.
- * (In the normal 1-1 case handled below, we don't have to worry about
- * two lists, as everything gets tied to the single list that is
- * generated for the single character 'to'. But here, we are omitting
- * that list, ('st' in the example), so must have multiple lists.) */
- while ((from_list = (AV *) hv_iternextsv(specials_inverse,
- &char_to, &to_len)))
- {
- if (av_tindex_skip_len_mg(from_list) > 0) {
- SSize_t i;
-
- /* We iterate over all combinations of i,j to place each code
- * point on each list */
- for (i = 0; i <= av_tindex_skip_len_mg(from_list); i++) {
- SSize_t j;
- AV* i_list = newAV();
- SV** entryp = av_fetch(from_list, i, FALSE);
- if (entryp == NULL) {
- Perl_croak(aTHX_ "panic: av_fetch() unexpectedly failed");
- }
- if (hv_fetch(ret, SvPVX(*entryp), SvCUR(*entryp), FALSE)) {
- Perl_croak(aTHX_ "panic: unexpected entry for %s", SvPVX(*entryp));
- }
- if (! hv_store(ret, SvPVX(*entryp), SvCUR(*entryp),
- (SV*) i_list, FALSE))
- {
- Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
- }
-
- /* For DEBUG_U: UV u = valid_utf8_to_uvchr((U8*) SvPVX(*entryp), 0);*/
- for (j = 0; j <= av_tindex_skip_len_mg(from_list); j++) {
- entryp = av_fetch(from_list, j, FALSE);
- if (entryp == NULL) {
- Perl_croak(aTHX_ "panic: av_fetch() unexpectedly failed");
- }
-
- /* When i==j this adds itself to the list */
- av_push(i_list, newSVuv(utf8_to_uvchr_buf(
- (U8*) SvPVX(*entryp),
- (U8*) SvPVX(*entryp) + SvCUR(*entryp),
- 0)));
- /*DEBUG_U(PerlIO_printf(Perl_debug_log, "%s: %d: Adding %" UVXf " to list for %" UVXf "\n", __FILE__, __LINE__, valid_utf8_to_uvchr((U8*) SvPVX(*entryp), 0), u));*/
- }
- }
- }
- }
- SvREFCNT_dec(specials_inverse); /* done with it */
- } /* End of specials */
-
- /* read $swash->{LIST} */
-
-#if UNICODE_MAJOR_VERSION == 3 \
- && UNICODE_DOT_VERSION == 0 \
- && UNICODE_DOT_DOT_VERSION == 1
-
- /* For this version only U+130 and U+131 are equivalent under qr//i. Add a
- * rule so that things work under /iaa and /il */
-
- SV * mod_listsv = sv_mortalcopy(*listsvp);
- sv_catpv(mod_listsv, "130\t130\t131\n");
- l = (U8*)SvPV(mod_listsv, lcur);
-
-#else
-
- l = (U8*)SvPV(*listsvp, lcur);
-
-#endif
-
- lend = l + lcur;
-
- /* Go through each input line */
- while (l < lend) {
- UV min, max, val;
- UV inverse;
- l = swash_scan_list_line(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** listp;
- IV i;
- bool found_key = FALSE;
- bool found_inverse = FALSE;
-
- /* The key is the inverse mapping */
- char key[UTF8_MAXBYTES+1];
- char* key_end = (char *) uvchr_to_utf8((U8*) key, val);
- STRLEN key_len = key_end - key;
-
- /* 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");
- }
- }
-
- /* Look through list to see if this inverse mapping already is
- * listed, or if there is a mapping to itself already */
- for (i = 0; i <= av_tindex_skip_len_mg(list); i++) {
- SV** entryp = av_fetch(list, i, FALSE);
- SV* entry;
- UV uv;
- if (entryp == NULL) {
- Perl_croak(aTHX_ "panic: av_fetch() unexpectedly failed");
- }
- entry = *entryp;
- uv = SvUV(entry);
- /*DEBUG_U(PerlIO_printf(Perl_debug_log, "list for %" UVXf " contains %" UVXf "\n", val, uv));*/
- if (uv == val) {
- found_key = TRUE;
- }
- if (uv == inverse) {
- found_inverse = TRUE;
- }
-
- /* No need to continue searching if found everything we are
- * looking for */
- if (found_key && found_inverse) {
- break;
- }
- }
-
- /* Make sure there is a mapping to itself on the list */
- if (! found_key) {
- av_push(list, newSVuv(val));
- /*DEBUG_U(PerlIO_printf(Perl_debug_log, "%s: %d: Adding %" UVXf " to list for %" UVXf "\n", __FILE__, __LINE__, val, val));*/
- }
-
-
- /* Simply add the value to the list */
- if (! found_inverse) {
- av_push(list, newSVuv(inverse));
- /*DEBUG_U(PerlIO_printf(Perl_debug_log, "%s: %d: Adding %" UVXf " to list for %" UVXf "\n", __FILE__, __LINE__, inverse, val));*/
- }
-
- /* swatch_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; it appears to be used only in
- * implementing tr//; I copied the semantics from swatch_get(), just
- * in case */
- if (!none || val < none) {
- ++val;
- }
- }
- }
-
- return ret;
-}
-
-SV*
-Perl__swash_to_invlist(pTHX_ SV* const swash)
-{
-
- /* Subject to change or removal. For use only in one place in regcomp.c.
- * Ownership is given to one reference count in the returned SV* */
-
- U8 *l, *lend;
- char *loc;
- STRLEN lcur;
- HV *const hv = MUTABLE_HV(SvRV(swash));
- UV elements = 0; /* Number of elements in the inversion list */
- U8 empty[] = "";
- SV** listsvp;
- SV** typesvp;
- SV** bitssvp;
- SV** extssvp;
- SV** invert_it_svp;
-
- U8* typestr;
- STRLEN bits;
- STRLEN octets; /* if bits == 1, then octets == 0 */
- U8 *x, *xend;
- STRLEN xcur;
-
- SV* invlist;
-
- PERL_ARGS_ASSERT__SWASH_TO_INVLIST;
-
- /* If not a hash, it must be the swash's inversion list instead */
- if (SvTYPE(hv) != SVt_PVHV) {
- return SvREFCNT_inc_simple_NN((SV*) hv);
- }
-
- /* The string containing the main body of the table */
- listsvp = hv_fetchs(hv, "LIST", FALSE);
- typesvp = hv_fetchs(hv, "TYPE", FALSE);
- bitssvp = hv_fetchs(hv, "BITS", FALSE);
- extssvp = hv_fetchs(hv, "EXTRAS", FALSE);
- invert_it_svp = hv_fetchs(hv, "INVERT_IT", FALSE);
-
- typestr = (U8*)SvPV_nolen(*typesvp);
- bits = SvUV(*bitssvp);
- octets = bits >> 3; /* if bits == 1, then octets == 0 */
-
- /* read $swash->{LIST} */
- if (SvPOK(*listsvp)) {
- l = (U8*)SvPV(*listsvp, lcur);
- }
- else {
- /* LIST legitimately doesn't contain a string during compilation phases
- * of Perl itself, before the Unicode tables are generated. In this
- * case, just fake things up by creating an empty list */
- l = empty;
- lcur = 0;
- }
- loc = (char *) l;
- lend = l + lcur;
-
- if (*l == 'V') { /* Inversion list format */
- const char *after_atou = (char *) lend;
- UV element0;
- UV* other_elements_ptr;
-
- /* The first number is a count of the rest */
- l++;
- if (!grok_atoUV((const char *)l, &elements, &after_atou)) {
- Perl_croak(aTHX_ "panic: Expecting a valid count of elements at start of inversion list");
- }
- if (elements == 0) {
- invlist = _new_invlist(0);
- }
- else {
- l = (U8 *) after_atou;
-
- /* Get the 0th element, which is needed to setup the inversion list */
- while (isSPACE(*l)) l++;
- if (!grok_atoUV((const char *)l, &element0, &after_atou)) {
- Perl_croak(aTHX_ "panic: Expecting a valid 0th element for inversion list");
- }
- l = (U8 *) after_atou;
- invlist = _setup_canned_invlist(elements, element0, &other_elements_ptr);
- elements--;
-
- /* Then just populate the rest of the input */
- while (elements-- > 0) {
- if (l > lend) {
- Perl_croak(aTHX_ "panic: Expecting %" UVuf " more elements than available", elements);
- }
- while (isSPACE(*l)) l++;
- if (!grok_atoUV((const char *)l, other_elements_ptr++, &after_atou)) {
- Perl_croak(aTHX_ "panic: Expecting a valid element in inversion list");
- }
- l = (U8 *) after_atou;
- }
- }
- }
- else {
-
- /* Scan the input to count the number of lines to preallocate array
- * size based on worst possible case, which is each line in the input
- * creates 2 elements in the inversion list: 1) the beginning of a
- * range in the list; 2) the beginning of a range not in the list. */
- while ((loc = (strchr(loc, '\n'))) != NULL) {
- elements += 2;
- loc++;
- }
-
- /* If the ending is somehow corrupt and isn't a new line, add another
- * element for the final range that isn't in the inversion list */
- if (! (*lend == '\n'
- || (*lend == '\0' && (lcur == 0 || *(lend - 1) == '\n'))))
- {
- elements++;
- }
-
- invlist = _new_invlist(elements);
-
- /* Now go through the input again, adding each range to the list */
- while (l < lend) {
- UV start, end;
- UV val; /* Not used by this function */
-
- l = swash_scan_list_line(l, lend, &start, &end, &val,
- cBOOL(octets), typestr);
-
- if (l > lend) {
- break;
- }
-
- invlist = _add_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 swatch_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, bits=%" UVuf ", otherbits=%" UVuf,
- (UV)bits, (UV)otherbits);
- }
-
- /* The "other" swatch must be destroyed after. */
- other = _swash_to_invlist((SV *)*othersvp);
-
- /* End of code copied from swatch_get() */
- switch (opc) {
- case '+':
- _invlist_union(invlist, other, &invlist);
- break;
- case '!':
- _invlist_union_maybe_complement_2nd(invlist, other, TRUE, &invlist);
- break;
- case '-':
- _invlist_subtract(invlist, other, &invlist);
- break;
- case '&':
- _invlist_intersection(invlist, other, &invlist);
- break;
- default:
- break;
- }
- sv_free(other); /* through with it! */
- }
-
- SvREADONLY_on(invlist);
- return invlist;
-}
-
-SV*
-Perl__get_swash_invlist(pTHX_ SV* const swash)
-{
- SV** ptr;
-
- PERL_ARGS_ASSERT__GET_SWASH_INVLIST;
-
- if (! SvROK(swash)) {
- return NULL;
- }
-
- /* If it really isn't a hash, it isn't really swash; must be an inversion
- * list */
- if (SvTYPE(SvRV(swash)) != SVt_PVHV) {
- return SvRV(swash);
- }
-
- ptr = hv_fetchs(MUTABLE_HV(SvRV(swash)), "V", FALSE);
- if (! ptr) {
- return NULL;
- }
-
- return *ptr;
-}
-
https://perl5.git.perl.org / perl5.git / blobdiff