+/* Note:
+ * Returns a swatch (a bit vector string) for a code point sequence
+ * that starts from the value C<start> and comprises the number C<span>.
+ * A C<swash> must be an object created by SWASHNEW (see lib/utf8_heavy.pl).
+ * Should be used via swash_fetch, which will cache the swatch in C<swash>.
+ */
+STATIC SV*
+S_swash_get(pTHX_ SV* swash, UV start, UV span)
+{
+ SV *swatch;
+ U8 *l, *lend, *x, *xend, *s;
+ STRLEN lcur, xcur, scur;
+
+ HV* const hv = (HV*)SvRV(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 nonesvp = hv_fetchs(hv, "NONE", FALSE);
+ SV** const extssvp = hv_fetchs(hv, "EXTRAS", FALSE);
+ const U8* const typestr = (U8*)SvPV_nolen(*typesvp);
+ const int typeto = typestr[0] == 'T' && typestr[1] == 'o';
+ const STRLEN bits = SvUV(*bitssvp);
+ const STRLEN octets = bits >> 3; /* if bits == 1, then octets == 0 */
+ const UV none = SvUV(*nonesvp);
+ const UV end = start + span;
+
+ if (bits != 1 && bits != 8 && bits != 16 && bits != 32) {
+ Perl_croak(aTHX_ "panic: swash_get doesn't expect bits %"UVuf,
+ (UV)bits);
+ }
+
+ /* create and initialize $swatch */
+ swatch = newSVpvs("");
+ scur = octets ? (span * octets) : (span + 7) / 8;
+ SvGROW(swatch, scur + 1);
+ s = (U8*)SvPVX(swatch);
+ if (octets && none) {
+ const U8* const e = s + scur;
+ while (s < e) {
+ if (bits == 8)
+ *s++ = (U8)(none & 0xff);
+ else if (bits == 16) {
+ *s++ = (U8)((none >> 8) & 0xff);
+ *s++ = (U8)( none & 0xff);
+ }
+ else if (bits == 32) {
+ *s++ = (U8)((none >> 24) & 0xff);
+ *s++ = (U8)((none >> 16) & 0xff);
+ *s++ = (U8)((none >> 8) & 0xff);
+ *s++ = (U8)( none & 0xff);
+ }
+ }
+ *s = '\0';
+ }
+ else {
+ (void)memzero((U8*)s, scur + 1);
+ }
+ SvCUR_set(swatch, scur);
+ s = (U8*)SvPVX(swatch);
+
+ /* read $swash->{LIST} */
+ l = (U8*)SvPV(*listsvp, lcur);
+ lend = l + lcur;
+ while (l < lend) {
+ UV min, max, val;
+ STRLEN numlen;
+ I32 flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
+
+ U8* const nl = (U8*)memchr(l, '\n', lend - l);
+
+ numlen = lend - l;
+ min = grok_hex((char *)l, &numlen, &flags, NULL);
+ if (numlen)
+ l += numlen;
+ else if (nl) {
+ l = nl + 1; /* 1 is length of "\n" */
+ continue;
+ }
+ else {
+ l = lend; /* to LIST's end at which \n is not found */
+ break;
+ }
+
+ if (isBLANK(*l)) {
+ ++l;
+ flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
+ numlen = lend - l;
+ max = grok_hex((char *)l, &numlen, &flags, NULL);
+ if (numlen)
+ l += numlen;
+ else
+ max = min;
+
+ if (octets) {
+ if (isBLANK(*l)) {
+ ++l;
+ flags = PERL_SCAN_SILENT_ILLDIGIT |
+ PERL_SCAN_DISALLOW_PREFIX;
+ numlen = lend - l;
+ val = grok_hex((char *)l, &numlen, &flags, NULL);
+ if (numlen)
+ l += numlen;
+ else
+ val = 0;
+ }
+ else {
+ val = 0;
+ if (typeto) {
+ Perl_croak(aTHX_ "%s: illegal mapping '%s'",
+ typestr, l);
+ }
+ }
+ }
+ else
+ val = 0; /* bits == 1, then val should be ignored */
+ }
+ else {
+ max = min;
+ if (octets) {
+ val = 0;
+ if (typeto) {
+ Perl_croak(aTHX_ "%s: illegal mapping '%s'", typestr, l);
+ }
+ }
+ else
+ val = 0; /* bits == 1, then val should be ignored */
+ }
+
+ if (nl)
+ l = nl + 1;
+ else
+ l = lend;
+
+ if (max < start)
+ continue;
+
+ if (octets) {
+ UV key;
+ if (min < start) {
+ if (!none || val < none) {
+ val += start - min;
+ }
+ min = start;
+ }
+ for (key = min; key <= max; key++) {
+ STRLEN offset;
+ if (key >= end)
+ goto go_out_list;
+ /* offset must be non-negative (start <= min <= key < end) */
+ offset = octets * (key - start);
+ if (bits == 8)
+ s[offset] = (U8)(val & 0xff);
+ else if (bits == 16) {
+ s[offset ] = (U8)((val >> 8) & 0xff);
+ s[offset + 1] = (U8)( val & 0xff);
+ }
+ else if (bits == 32) {
+ s[offset ] = (U8)((val >> 24) & 0xff);
+ s[offset + 1] = (U8)((val >> 16) & 0xff);
+ s[offset + 2] = (U8)((val >> 8) & 0xff);
+ s[offset + 3] = (U8)( val & 0xff);
+ }
+
+ if (!none || val < none)
+ ++val;
+ }
+ }
+ else { /* bits == 1, then val should be ignored */
+ UV key;
+ if (min < start)
+ min = start;
+ for (key = min; key <= max; key++) {
+ const STRLEN offset = (STRLEN)(key - start);
+ if (key >= end)
+ goto go_out_list;
+ s[offset >> 3] |= 1 << (offset & 7);
+ }
+ }
+ } /* while */
+ go_out_list:
+
+ /* 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 *s, *o, *nl;
+ STRLEN slen, olen;
+
+ 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 = (HV*)SvRV(*othersvp);
+ otherbitssvp = hv_fetchs(otherhv, "BITS", FALSE);
+ otherbits = (STRLEN)SvUV(*otherbitssvp);
+ if (bits < otherbits)
+ Perl_croak(aTHX_ "panic: swash_get found swatch size mismatch");
+
+ /* The "other" swatch must be destroyed after. */
+ other = swash_get(*othersvp, start, span);
+ o = (U8*)SvPV(other, olen);
+
+ if (!olen)
+ Perl_croak(aTHX_ "panic: swash_get got improper swatch");
+
+ s = (U8*)SvPV(swatch, slen);
+ if (bits == 1 && otherbits == 1) {
+ if (slen != olen)
+ Perl_croak(aTHX_ "panic: swash_get found swatch length mismatch");
+
+ switch (opc) {
+ case '+':
+ while (slen--)
+ *s++ |= *o++;
+ break;
+ case '!':
+ while (slen--)
+ *s++ |= ~*o++;
+ break;
+ case '-':
+ while (slen--)
+ *s++ &= ~*o++;
+ break;
+ case '&':
+ while (slen--)
+ *s++ &= *o++;
+ break;
+ default:
+ break;
+ }
+ }
+ else {
+ STRLEN otheroctets = otherbits >> 3;
+ STRLEN offset = 0;
+ U8* const send = s + slen;
+
+ while (s < send) {
+ UV otherval = 0;
+
+ if (otherbits == 1) {
+ otherval = (o[offset >> 3] >> (offset & 7)) & 1;
+ ++offset;
+ }
+ else {
+ STRLEN vlen = otheroctets;
+ otherval = *o++;
+ while (--vlen) {
+ otherval <<= 8;
+ otherval |= *o++;
+ }
+ }
+
+ if (opc == '+' && otherval)
+ NOOP; /* replace with otherval */
+ else if (opc == '!' && !otherval)
+ otherval = 1;
+ else if (opc == '-' && otherval)
+ otherval = 0;
+ else if (opc == '&' && !otherval)
+ otherval = 0;
+ else {
+ s += octets; /* no replacement */
+ continue;
+ }
+
+ if (bits == 8)
+ *s++ = (U8)( otherval & 0xff);
+ else if (bits == 16) {
+ *s++ = (U8)((otherval >> 8) & 0xff);
+ *s++ = (U8)( otherval & 0xff);
+ }
+ else if (bits == 32) {
+ *s++ = (U8)((otherval >> 24) & 0xff);
+ *s++ = (U8)((otherval >> 16) & 0xff);
+ *s++ = (U8)((otherval >> 8) & 0xff);
+ *s++ = (U8)( otherval & 0xff);
+ }
+ }
+ }
+ sv_free(other); /* through with it! */
+ } /* while */
+ return swatch;
+}