locinput = (p); \
SET_nextchr
-
-#define LOAD_UTF8_CHARCLASS(swash_ptr, property_name, invlist) STMT_START { \
- if (!swash_ptr) { \
- U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST; \
- swash_ptr = _core_swash_init("utf8", property_name, &PL_sv_undef, \
- 1, 0, invlist, &flags); \
- assert(swash_ptr); \
- } \
- } STMT_END
-
-/* If in debug mode, we test that a known character properly matches */
-#ifdef DEBUGGING
-# define LOAD_UTF8_CHARCLASS_DEBUG_TEST(swash_ptr, \
- property_name, \
- invlist, \
- utf8_char_in_property) \
- LOAD_UTF8_CHARCLASS(swash_ptr, property_name, invlist); \
- assert(swash_fetch(swash_ptr, (U8 *) utf8_char_in_property, TRUE));
-#else
-# define LOAD_UTF8_CHARCLASS_DEBUG_TEST(swash_ptr, \
- property_name, \
- invlist, \
- utf8_char_in_property) \
- LOAD_UTF8_CHARCLASS(swash_ptr, property_name, invlist)
-#endif
-
-#define LOAD_UTF8_CHARCLASS_ALNUM() LOAD_UTF8_CHARCLASS_DEBUG_TEST( \
- PL_utf8_swash_ptrs[_CC_WORDCHAR], \
- "", \
- PL_XPosix_ptrs[_CC_WORDCHAR], \
- LATIN_SMALL_LIGATURE_LONG_S_T_UTF8);
-
#define PLACEHOLDER /* Something for the preprocessor to grab onto */
/* TODO: Combine JUMPABLE and HAS_TEXT to cache OP(rn) */
/* Currently these are only used when PL_regkind[OP(rn)] == EXACT so
we don't need this definition. XXX These are now out-of-sync*/
#define IS_TEXT(rn) ( OP(rn)==EXACT || OP(rn)==REF || OP(rn)==NREF )
-#define IS_TEXTF(rn) ( OP(rn)==EXACTFU || OP(rn)==EXACTFU_SS || OP(rn)==EXACTFA || OP(rn)==EXACTFA_NO_TRIE || OP(rn)==EXACTF || OP(rn)==REFF || OP(rn)==NREFF )
+#define IS_TEXTF(rn) ( OP(rn)==EXACTFU || OP(rn)==EXACTFU_SS || OP(rn)==EXACTFAA || OP(rn)==EXACTFAA_NO_TRIE || OP(rn)==EXACTF || OP(rn)==REFF || OP(rn)==NREFF )
#define IS_TEXTFL(rn) ( OP(rn)==EXACTFL || OP(rn)==REFFL || OP(rn)==NREFFL )
#else
/* ... so we use this as its faster. */
#define IS_TEXT(rn) ( OP(rn)==EXACT || OP(rn)==EXACTL )
-#define IS_TEXTFU(rn) ( OP(rn)==EXACTFU || OP(rn)==EXACTFLU8 || OP(rn)==EXACTFU_SS || OP(rn) == EXACTFA || OP(rn) == EXACTFA_NO_TRIE)
+#define IS_TEXTFU(rn) ( OP(rn)==EXACTFU || OP(rn)==EXACTFLU8 || OP(rn)==EXACTFU_SS || OP(rn) == EXACTFAA || OP(rn) == EXACTFAA_NO_TRIE)
#define IS_TEXTF(rn) ( OP(rn)==EXACTF )
#define IS_TEXTFL(rn) ( OP(rn)==EXACTFL )
#endif
STATIC bool
-S_isFOO_utf8_lc(pTHX_ const U8 classnum, const U8* character)
+S_isFOO_utf8_lc(pTHX_ const U8 classnum, const U8* character, const U8* e)
{
/* Returns a boolean as to whether or not the (well-formed) UTF-8-encoded
* 'character' is a member of the Posix character class given by 'classnum'
EIGHT_BIT_UTF8_TO_NATIVE(*character, *(character + 1)));
}
- _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(character, character + UTF8SKIP(character));
-
- if (classnum < _FIRST_NON_SWASH_CC) {
-
- /* Initialize the swash unless done already */
- if (! PL_utf8_swash_ptrs[classnum]) {
- U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
- PL_utf8_swash_ptrs[classnum] =
- _core_swash_init("utf8",
- "",
- &PL_sv_undef, 1, 0,
- PL_XPosix_ptrs[classnum], &flags);
- }
-
- return cBOOL(swash_fetch(PL_utf8_swash_ptrs[classnum], (U8 *)
- character,
- TRUE /* is UTF */ ));
- }
+ _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(character, e);
switch ((_char_class_number) classnum) {
case _CC_ENUM_SPACE: return is_XPERLSPACE_high(character);
case _CC_ENUM_BLANK: return is_HORIZWS_high(character);
case _CC_ENUM_XDIGIT: return is_XDIGIT_high(character);
case _CC_ENUM_VERTSPACE: return is_VERTWS_high(character);
- default: break;
+ default:
+ return _invlist_contains_cp(PL_XPosix_ptrs[classnum],
+ utf8_to_uvchr_buf(character, e, NULL));
}
return FALSE; /* Things like CNTRL are always below 256 */
PERL_UINTMAX_T complemented = ~ * (PERL_UINTMAX_T *) s;
if (complemented & PERL_VARIANTS_WORD_MASK) {
-#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 \
- || BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
+# if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 \
+ || BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
s += _variant_byte_number(complemented);
return s;
-#else /* If weird byte order, drop into next loop to do byte-at-a-time
+# else /* If weird byte order, drop into next loop to do byte-at-a-time
checks. */
break;
-#endif
+# endif
}
s += PERL_WORDSIZE;
}
-STATIC char *
-S_find_span_end(char * s, const char * send, const char span_byte)
+STATIC U8 *
+S_find_span_end(U8 * s, const U8 * send, const U8 span_byte)
{
/* Returns the position of the first byte in the sequence between 's' and
* 'send-1' inclusive that isn't 'span_byte'; returns 'send' if none found.
continue;
}
- /* Here, at least one byte in the word isn't 'span_byte'. This xor
- * leaves 1 bits only in those non-matching bytes */
+ /* Here, at least one byte in the word isn't 'span_byte'. */
+
+#ifdef EBCDIC
+
+ break;
+
+#else
+
+ /* This xor leaves 1 bits only in those non-matching bytes */
span_word ^= * (PERL_UINTMAX_T *) s;
/* Make sure the upper bit of each non-matching byte is set. This
/* That reduces the problem to what this function solves */
return s + _variant_byte_number(span_word);
+#endif
+
} while (s + PERL_WORDSIZE <= send);
}
return s;
}
+STATIC U8 *
+S_find_next_masked(U8 * s, const U8 * send, const U8 byte, const U8 mask)
+{
+ /* Returns the position of the first byte in the sequence between 's'
+ * and 'send-1' inclusive that when ANDed with 'mask' yields 'byte';
+ * returns 'send' if none found. It uses word-level operations instead of
+ * byte to speed up the process */
+
+ PERL_ARGS_ASSERT_FIND_NEXT_MASKED;
+
+ assert(send >= s);
+ assert((byte & mask) == byte);
+
+#ifndef EBCDIC
+
+ if ((STRLEN) (send - s) >= PERL_WORDSIZE
+ + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(s)
+ - (PTR2nat(s) & PERL_WORD_BOUNDARY_MASK))
+ {
+ PERL_UINTMAX_T word_complemented, mask_word;
+
+ while (PTR2nat(s) & PERL_WORD_BOUNDARY_MASK) {
+ if (((*s) & mask) == byte) {
+ return s;
+ }
+ s++;
+ }
+
+ word_complemented = ~ (PERL_COUNT_MULTIPLIER * byte);
+ mask_word = PERL_COUNT_MULTIPLIER * mask;
+
+ do {
+ PERL_UINTMAX_T masked = (* (PERL_UINTMAX_T *) s) & mask_word;
+
+ /* If 'masked' contains 'byte' within it, anding with the
+ * complement will leave those 8 bits 0 */
+ masked &= word_complemented;
+
+ /* This causes the most significant bit to be set to 1 for any
+ * bytes in the word that aren't completely 0 */
+ masked |= masked << 1;
+ masked |= masked << 2;
+ masked |= masked << 4;
+
+ /* The msbits are the same as what marks a byte as variant, so we
+ * can use this mask. If all msbits are 1, the word doesn't
+ * contain 'byte' */
+ if ((masked & PERL_VARIANTS_WORD_MASK) == PERL_VARIANTS_WORD_MASK) {
+ s += PERL_WORDSIZE;
+ continue;
+ }
+
+ /* Here, the msbit of bytes in the word that aren't 'byte' are 1,
+ * and any that are, are 0. Complement and re-AND to swap that */
+ masked = ~ masked;
+ masked &= PERL_VARIANTS_WORD_MASK;
+
+ /* This reduces the problem to that solved by this function */
+ s += _variant_byte_number(masked);
+ return s;
+
+ } while (s + PERL_WORDSIZE <= send);
+ }
+
+#endif
+
+ while (s < send) {
+ if (((*s) & mask) == byte) {
+ return s;
+ }
+ s++;
+ }
+
+ return s;
+}
+
+STATIC U8 *
+S_find_span_end_mask(U8 * s, const U8 * send, const U8 span_byte, const U8 mask)
+{
+ /* Returns the position of the first byte in the sequence between 's' and
+ * 'send-1' inclusive that when ANDed with 'mask' isn't 'span_byte'.
+ * 'span_byte' should have been ANDed with 'mask' in the call of this
+ * function. Returns 'send' if none found. Works like find_span_end(),
+ * except for the AND */
+
+ PERL_ARGS_ASSERT_FIND_SPAN_END_MASK;
+
+ assert(send >= s);
+ assert((span_byte & mask) == span_byte);
+
+ if ((STRLEN) (send - s) >= PERL_WORDSIZE
+ + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(s)
+ - (PTR2nat(s) & PERL_WORD_BOUNDARY_MASK))
+ {
+ PERL_UINTMAX_T span_word, mask_word;
+
+ while (PTR2nat(s) & PERL_WORD_BOUNDARY_MASK) {
+ if (((*s) & mask) != span_byte) {
+ return s;
+ }
+ s++;
+ }
+
+ span_word = PERL_COUNT_MULTIPLIER * span_byte;
+ mask_word = PERL_COUNT_MULTIPLIER * mask;
+
+ do {
+ PERL_UINTMAX_T masked = (* (PERL_UINTMAX_T *) s) & mask_word;
+
+ if (masked == span_word) {
+ s += PERL_WORDSIZE;
+ continue;
+ }
+
+#ifdef EBCDIC
+
+ break;
+
+#else
+
+ masked ^= span_word;
+ masked |= masked << 1;
+ masked |= masked << 2;
+ masked |= masked << 4;
+ return s + _variant_byte_number(masked);
+
+#endif
+
+ } while (s + PERL_WORDSIZE <= send);
+ }
+
+ while (s < send) {
+ if (((*s) & mask) != span_byte) {
+ return s;
+ }
+ s++;
+ }
+
+ return s;
+}
+
/*
* pregexec and friends
*/
if (check_len > targ_len) {
DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
- "Anchored string too short...\n"));
+ "Target string too short to match required substring...\n"));
goto fail_finish;
}
end_point - check_len
)
+ check_len;
+ if (end_point < start_point)
+ goto fail_finish;
}
}
? (utf8_target ? trie_utf8 : trie_plain) \
: (scan->flags == EXACTL) \
? (utf8_target ? trie_utf8l : trie_plain) \
- : (scan->flags == EXACTFA) \
+ : (scan->flags == EXACTFAA) \
? (utf8_target \
? trie_utf8_exactfa_fold \
: trie_latin_utf8_exactfa_fold) \
dump_exec_pos(li,s,(reginfo->strend),(reginfo->strbeg), \
startpos, doutf8, depth)
-#define REXEC_FBC_EXACTISH_SCAN(COND) \
-STMT_START { \
- while (s <= e) { \
- if ( (COND) \
- && (ln == 1 || folder(s, pat_string, ln)) \
- && (reginfo->intuit || regtry(reginfo, &s)) )\
- goto got_it; \
- s++; \
- } \
-} STMT_END
-
#define REXEC_FBC_SCAN(UTF8, CODE) \
STMT_START { \
while (s < strend) { \
* there is no such occurrence. */
#define REXEC_FBC_FIND_NEXT_SCAN(UTF8, f) \
while (s < strend) { \
- s = f; \
+ s = (f); \
if (s >= strend) { \
break; \
} \
0, UTF8_ALLOW_DEFAULT); \
} \
tmp = TEST_UV(tmp); \
- LOAD_UTF8_CHARCLASS_ALNUM(); \
REXEC_FBC_SCAN(1, /* 1=>is-utf8; advances s while s < strend */ \
if (tmp == ! (TEST_UTF8((U8 *) s, (U8 *) reginfo->strend))) { \
tmp = !tmp; \
}
break;
- case EXACTFA_NO_TRIE: /* This node only generated for non-utf8 patterns */
+ case ANYOFM: /* ARG() is the base byte; FLAGS() the mask byte */
+ /* UTF-8ness doesn't matter, so use 0 */
+ REXEC_FBC_FIND_NEXT_SCAN(0,
+ (char *) find_next_masked((U8 *) s, (U8 *) strend,
+ (U8) ARG(c), FLAGS(c)));
+ break;
+
+ case EXACTFAA_NO_TRIE: /* This node only generated for non-utf8 patterns */
assert(! is_utf8_pat);
/* FALLTHROUGH */
- case EXACTFA:
+ case EXACTFAA:
if (is_utf8_pat || utf8_target) {
utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII;
goto do_exactf_utf8;
c1 = *pat_string;
c2 = fold_array[c1];
if (c1 == c2) { /* If char and fold are the same */
- REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1);
+ while (s <= e) {
+ s = (char *) memchr(s, c1, e + 1 - s);
+ if (s == NULL) {
+ break;
+ }
+
+ /* Check that the rest of the node matches */
+ if ( (ln == 1 || folder(s + 1, pat_string + 1, ln - 1))
+ && (reginfo->intuit || regtry(reginfo, &s)) )
+ {
+ goto got_it;
+ }
+ s++;
+ }
}
else {
- REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1 || *(U8*)s == c2);
+ U8 bits_differing = c1 ^ c2;
+
+ /* If the folds differ in one bit position only, we can mask to
+ * match either of them, and can use this faster find method. Both
+ * ASCII and EBCDIC tend to have their case folds differ in only
+ * one position, so this is very likely */
+ if (LIKELY(PL_bitcount[bits_differing] == 1)) {
+ bits_differing = ~ bits_differing;
+ while (s <= e) {
+ s = (char *) find_next_masked((U8 *) s, (U8 *) e + 1,
+ (c1 & bits_differing), bits_differing);
+ if (s > e) {
+ break;
+ }
+
+ if ( (ln == 1 || folder(s + 1, pat_string + 1, ln - 1))
+ && (reginfo->intuit || regtry(reginfo, &s)) )
+ {
+ goto got_it;
+ }
+ s++;
+ }
+ }
+ else { /* Otherwise, stuck with looking byte-at-a-time. This
+ should actually happen only in EXACTFL nodes */
+ while (s <= e) {
+ if ( (*(U8*)s == c1 || *(U8*)s == c2)
+ && (ln == 1 || folder(s + 1, pat_string + 1, ln - 1))
+ && (reginfo->intuit || regtry(reginfo, &s)) )
+ {
+ goto got_it;
+ }
+ s++;
+ }
+ }
}
break;
case POSIXL:
_CHECK_AND_WARN_PROBLEMATIC_LOCALE;
- REXEC_FBC_CSCAN(to_complement ^ cBOOL(isFOO_utf8_lc(FLAGS(c), (U8 *) s)),
+ REXEC_FBC_CSCAN(to_complement ^ cBOOL(isFOO_utf8_lc(FLAGS(c), (U8 *) s, (U8 *) strend)),
to_complement ^ cBOOL(isFOO_lc(FLAGS(c), *s)));
break;
posix_utf8:
classnum = (_char_class_number) FLAGS(c);
- if (classnum < _FIRST_NON_SWASH_CC) {
- while (s < strend) {
-
- /* We avoid loading in the swash as long as possible, but
- * should we have to, we jump to a separate loop. This
- * extra 'if' statement is what keeps this code from being
- * just a call to REXEC_FBC_CLASS_SCAN() */
- if (UTF8_IS_ABOVE_LATIN1(*s)) {
- goto found_above_latin1;
- }
-
- REXEC_FBC_CLASS_SCAN_GUTS(1, (UTF8_IS_INVARIANT(*s)
- && to_complement ^ cBOOL(_generic_isCC((U8) *s,
- classnum)))
- || ( UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, strend)
- && to_complement ^ cBOOL(
- _generic_isCC(EIGHT_BIT_UTF8_TO_NATIVE(*s,
- *(s + 1)),
- classnum))));
- }
- }
- else switch (classnum) { /* These classes are implemented as
- macros */
+ switch (classnum) {
+ default:
+ REXEC_FBC_CLASS_SCAN(1, /* 1=>is-utf8 */
+ to_complement ^ cBOOL(_invlist_contains_cp(
+ PL_XPosix_ptrs[classnum],
+ utf8_to_uvchr_buf((U8 *) s,
+ (U8 *) strend,
+ NULL))));
+ break;
case _CC_ENUM_SPACE:
REXEC_FBC_CLASS_SCAN(1, /* 1=>is-utf8 */
to_complement ^ cBOOL(isSPACE_utf8_safe(s, strend)));
REXEC_FBC_CLASS_SCAN(1,
to_complement ^ cBOOL(isCNTRL_utf8_safe(s, strend)));
break;
-
- default:
- Perl_croak(aTHX_ "panic: find_byclass() node %d='%s' has an unexpected character class '%d'", OP(c), PL_reg_name[OP(c)], classnum);
- NOT_REACHED; /* NOTREACHED */
}
}
break;
- found_above_latin1: /* Here we have to load a swash to get the result
- for the current code point */
- if (! PL_utf8_swash_ptrs[classnum]) {
- U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
- PL_utf8_swash_ptrs[classnum] =
- _core_swash_init("utf8",
- "",
- &PL_sv_undef, 1, 0,
- PL_XPosix_ptrs[classnum], &flags);
- }
-
- /* This is a copy of the loop above for swash classes, though using the
- * FBC macro instead of being expanded out. Since we've loaded the
- * swash, we don't have to check for that each time through the loop */
- REXEC_FBC_CLASS_SCAN(1, /* 1=>is-utf8 */
- to_complement ^ cBOOL(_generic_utf8_safe(
- classnum,
- s,
- strend,
- swash_fetch(PL_utf8_swash_ptrs[classnum],
- (U8 *) s, TRUE))));
- break;
-
case AHOCORASICKC:
case AHOCORASICK:
{
else { /* an EXACTFish node which doesn't begin with a multi-char fold */
c1 = is_utf8_pat ? valid_utf8_to_uvchr(pat, NULL) : *pat;
if (c1 > 255) {
- /* Load the folds hash, if not already done */
- SV** listp;
- if (! PL_utf8_foldclosures) {
- _load_PL_utf8_foldclosures();
+ const unsigned int * remaining_folds_to_list;
+ unsigned int first_folds_to;
+
+ /* Look up what code points (besides c1) fold to c1; e.g.,
+ * [ 'K', KELVIN_SIGN ] both fold to 'k'. */
+ Size_t folds_to_count = _inverse_folds(c1,
+ &first_folds_to,
+ &remaining_folds_to_list);
+ if (folds_to_count == 0) {
+ c2 = c1; /* there is only a single character that could
+ match */
}
-
- /* The fold closures data structure is a hash with the keys
- * being the UTF-8 of every character that is folded to, like
- * 'k', and the values each an array of all code points that
- * fold to its key. e.g. [ 'k', 'K', KELVIN_SIGN ].
- * Multi-character folds are not included */
- if ((! (listp = hv_fetch(PL_utf8_foldclosures,
- (char *) pat,
- UTF8SKIP(pat),
- FALSE))))
- {
- /* Not found in the hash, therefore there are no folds
- * containing it, so there is only a single character that
- * could match */
- c2 = c1;
+ else if (folds_to_count != 1) {
+ /* If there aren't exactly two folds to this (itself and
+ * another), it is outside the scope of this function */
+ use_chrtest_void = TRUE;
}
- else { /* Does participate in folds */
- AV* list = (AV*) *listp;
- if (av_tindex_skip_len_mg(list) != 1) {
-
- /* If there aren't exactly two folds to this, it is
- * outside the scope of this function */
- use_chrtest_void = TRUE;
- }
- else { /* There are two. Get them */
- SV** c_p = av_fetch(list, 0, FALSE);
- if (c_p == NULL) {
- Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
- }
- c1 = SvUV(*c_p);
-
- c_p = av_fetch(list, 1, FALSE);
- if (c_p == NULL) {
- Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
- }
- c2 = SvUV(*c_p);
-
- /* Folds that cross the 255/256 boundary are forbidden
- * if EXACTFL (and isnt a UTF8 locale), or EXACTFA and
- * one is ASCIII. Since the pattern character is above
- * 255, and its only other match is below 256, the only
- * legal match will be to itself. We have thrown away
- * the original, so have to compute which is the one
- * above 255. */
- if ((c1 < 256) != (c2 < 256)) {
- if ((OP(text_node) == EXACTFL
- && ! IN_UTF8_CTYPE_LOCALE)
- || ((OP(text_node) == EXACTFA
- || OP(text_node) == EXACTFA_NO_TRIE)
- && (isASCII(c1) || isASCII(c2))))
- {
- if (c1 < 256) {
- c1 = c2;
- }
- else {
- c2 = c1;
- }
- }
- }
+ else { /* There are two. We already have one, get the other */
+ c2 = first_folds_to;
+
+ /* Folds that cross the 255/256 boundary are forbidden if
+ * EXACTFL (and isnt a UTF8 locale), or EXACTFAA and one is
+ * ASCIII. The only other match to c1 is c2, and since c1
+ * is above 255, c2 better be as well under these
+ * circumstances. If it isn't, it means the only legal
+ * match of c1 is itself. */
+ if ( c2 < 256
+ && ( ( OP(text_node) == EXACTFL
+ && ! IN_UTF8_CTYPE_LOCALE)
+ || (( OP(text_node) == EXACTFAA
+ || OP(text_node) == EXACTFAA_NO_TRIE)
+ && (isASCII(c1) || isASCII(c2)))))
+ {
+ c2 = c1;
}
}
}
if (utf8_target
&& HAS_NONLATIN1_FOLD_CLOSURE(c1)
&& ( ! (OP(text_node) == EXACTFL && ! IN_UTF8_CTYPE_LOCALE))
- && ((OP(text_node) != EXACTFA
- && OP(text_node) != EXACTFA_NO_TRIE)
+ && ((OP(text_node) != EXACTFAA
+ && OP(text_node) != EXACTFAA_NO_TRIE)
|| ! isASCII(c1)))
{
/* Here, there could be something above Latin1 in the target
}
/* FALLTHROUGH */
/* /u rules for all these. This happens to work for
- * EXACTFA as nothing in Latin1 folds to ASCII */
- case EXACTFA_NO_TRIE: /* This node only generated for
- non-utf8 patterns */
+ * EXACTFAA as nothing in Latin1 folds to ASCII */
+ case EXACTFAA_NO_TRIE: /* This node only generated for
+ non-utf8 patterns */
assert(! is_utf8_pat);
/* FALLTHROUGH */
- case EXACTFA:
+ case EXACTFAA:
case EXACTFU_SS:
case EXACTFU:
c2 = PL_fold_latin1[c1];
*/
if(!NEXTCHR_IS_EOS && !ANYOF_BITMAP_TEST(scan, nextchr)) {
DEBUG_EXECUTE_r(
- Perl_re_exec_indentf( aTHX_ "%sfailed to match trie start class...%s\n",
+ Perl_re_exec_indentf( aTHX_ "%sTRIE: failed to match trie start class...%s\n",
depth, PL_colors[4], PL_colors[5])
);
sayNO_SILENT;
if (scan->flags == EXACTL || scan->flags == EXACTFLU8) {
_CHECK_AND_WARN_PROBLEMATIC_LOCALE;
if (utf8_target
- && nextchr >= 0 /* guard against negative EOS value in nextchr */
+ && ! NEXTCHR_IS_EOS
&& UTF8_IS_ABOVE_LATIN1(nextchr)
&& scan->flags == EXACTL)
{
{
if (trie->states[ state ].wordnum) {
DEBUG_EXECUTE_r(
- Perl_re_exec_indentf( aTHX_ "%smatched empty string...%s\n",
+ Perl_re_exec_indentf( aTHX_ "%sTRIE: matched empty string...%s\n",
depth, PL_colors[4], PL_colors[5])
);
if (!trie->jump)
break;
} else {
DEBUG_EXECUTE_r(
- Perl_re_exec_indentf( aTHX_ "%sfailed to match trie start class...%s\n",
+ Perl_re_exec_indentf( aTHX_ "%sTRIE: failed to match trie start class...%s\n",
depth, PL_colors[4], PL_colors[5])
);
sayNO_SILENT;
DUMP_EXEC_POS( (char *)uc, scan, utf8_target, depth );
/* HERE */
PerlIO_printf( Perl_debug_log,
- "%*s%sState: %4" UVxf " Accepted: %c ",
+ "%*s%sTRIE: State: %4" UVxf " Accepted: %c ",
INDENT_CHARS(depth), "", PL_colors[4],
(UV)state, (accepted ? 'Y' : 'N'));
});
}
DEBUG_TRIE_EXECUTE_r(
Perl_re_printf( aTHX_
- "Charid:%3x CP:%4" UVxf " After State: %4" UVxf "%s\n",
+ "TRIE: Charid:%3x CP:%4" UVxf " After State: %4" UVxf "%s\n",
charid, uvc, (UV)state, PL_colors[5] );
);
}
}
DEBUG_EXECUTE_r(
- Perl_re_exec_indentf( aTHX_ "%sgot %" IVdf " possible matches%s\n",
+ Perl_re_exec_indentf( aTHX_ "%sTRIE: got %" IVdf " possible matches%s\n",
depth,
PL_colors[4], (IV)ST.accepted, PL_colors[5] );
);
? av_fetch(trie_words, ST.nextword - 1, 0) : NULL;
SV *sv= tmp ? sv_newmortal() : NULL;
- Perl_re_exec_indentf( aTHX_ "%sonly one match left, short-circuiting: #%d <%s>%s\n",
+ Perl_re_exec_indentf( aTHX_ "%sTRIE: only one match left, short-circuiting: #%d <%s>%s\n",
depth, PL_colors[4],
ST.nextword,
tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0,
fold_utf8_flags = is_utf8_pat ? FOLDEQ_S1_ALREADY_FOLDED : 0;
goto do_exactf;
- case EXACTFA_NO_TRIE: /* This node only generated for non-utf8
+ case EXACTFAA_NO_TRIE: /* This node only generated for non-utf8
patterns */
assert(! is_utf8_pat);
/* FALLTHROUGH */
- case EXACTFA: /* /abc/iaa */
+ case EXACTFAA: /* /abc/iaa */
folder = foldEQ_latin1;
fold_array = PL_fold_latin1;
fold_utf8_flags = FOLDEQ_UTF8_NOMIX_ASCII;
}
break;
+ case ANYOFM:
+ if (NEXTCHR_IS_EOS || (UCHARAT(locinput) & FLAGS(scan)) != ARG(scan)) {
+ sayNO;
+ }
+ locinput++;
+ break;
+
case ASCII:
if (NEXTCHR_IS_EOS || ! isASCII(UCHARAT(locinput))) {
sayNO;
else { /* Handle above Latin-1 code points */
utf8_posix_above_latin1:
classnum = (_char_class_number) FLAGS(scan);
- if (classnum < _FIRST_NON_SWASH_CC) {
-
- /* Here, uses a swash to find such code points. Load if if
- * not done already */
- if (! PL_utf8_swash_ptrs[classnum]) {
- U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
- PL_utf8_swash_ptrs[classnum]
- = _core_swash_init("utf8",
- "",
- &PL_sv_undef, 1, 0,
- PL_XPosix_ptrs[classnum], &flags);
- }
- if (! (to_complement
- ^ cBOOL(swash_fetch(PL_utf8_swash_ptrs[classnum],
- (U8 *) locinput, TRUE))))
- {
- sayNO;
- }
- }
- else { /* Here, uses macros to find above Latin-1 code points */
- switch (classnum) {
- case _CC_ENUM_SPACE:
- if (! (to_complement
- ^ cBOOL(is_XPERLSPACE_high(locinput))))
- {
- sayNO;
- }
- break;
- case _CC_ENUM_BLANK:
- if (! (to_complement
- ^ cBOOL(is_HORIZWS_high(locinput))))
- {
- sayNO;
- }
- break;
- case _CC_ENUM_XDIGIT:
- if (! (to_complement
- ^ cBOOL(is_XDIGIT_high(locinput))))
- {
- sayNO;
- }
- break;
- case _CC_ENUM_VERTSPACE:
- if (! (to_complement
- ^ cBOOL(is_VERTWS_high(locinput))))
- {
- sayNO;
- }
- break;
- default: /* The rest, e.g. [:cntrl:], can't match
- above Latin1 */
- if (! to_complement) {
- sayNO;
- }
- break;
- }
+ switch (classnum) {
+ default:
+ if (! (to_complement
+ ^ cBOOL(_invlist_contains_cp(
+ PL_XPosix_ptrs[classnum],
+ utf8_to_uvchr_buf((U8 *) locinput,
+ (U8 *) reginfo->strend,
+ NULL)))))
+ {
+ sayNO;
+ }
+ break;
+ case _CC_ENUM_SPACE:
+ if (! (to_complement
+ ^ cBOOL(is_XPERLSPACE_high(locinput))))
+ {
+ sayNO;
+ }
+ break;
+ case _CC_ENUM_BLANK:
+ if (! (to_complement
+ ^ cBOOL(is_HORIZWS_high(locinput))))
+ {
+ sayNO;
+ }
+ break;
+ case _CC_ENUM_XDIGIT:
+ if (! (to_complement
+ ^ cBOOL(is_XDIGIT_high(locinput))))
+ {
+ sayNO;
+ }
+ break;
+ case _CC_ENUM_VERTSPACE:
+ if (! (to_complement
+ ^ cBOOL(is_VERTWS_high(locinput))))
+ {
+ sayNO;
+ }
+ break;
+ case _CC_ENUM_CNTRL: /* These can't match above Latin1 */
+ case _CC_ENUM_ASCII:
+ if (! to_complement) {
+ sayNO;
+ }
+ break;
}
locinput += UTF8SKIP(locinput);
}
rei = RXi_GET(re);
DEBUG_EXECUTE_r(
debug_start_match(re_sv, utf8_target, locinput,
- reginfo->strend, "Matching embedded");
+ reginfo->strend, "EVAL/GOSUB: Matching embedded");
);
startpoint = rei->program + 1;
EVAL_CLOSE_PAREN_CLEAR(st); /* ST.close_paren = 0;
if (n > maxopenparen)
maxopenparen = n;
DEBUG_BUFFERS_r(Perl_re_exec_indentf( aTHX_
- "rex=0x%" UVxf " offs=0x%" UVxf ": \\%" UVuf ": set %" IVdf " tmp; maxopenparen=%" UVuf "\n",
+ "OPEN: rex=0x%" UVxf " offs=0x%" UVxf ": \\%" UVuf ": set %" IVdf " tmp; maxopenparen=%" UVuf "\n",
depth,
PTR2UV(rex),
PTR2UV(rex->offs),
rex->offs[n].start = rex->offs[n].start_tmp; \
rex->offs[n].end = locinput - reginfo->strbeg; \
DEBUG_BUFFERS_r(Perl_re_exec_indentf( aTHX_ \
- "rex=0x%" UVxf " offs=0x%" UVxf ": \\%" UVuf ": set %" IVdf "..%" IVdf "\n", \
+ "CLOSE: rex=0x%" UVxf " offs=0x%" UVxf ": \\%" UVuf ": set %" IVdf "..%" IVdf "\n", \
depth, \
PTR2UV(rex), \
PTR2UV(rex->offs), \
ST.cache_mask = 0;
- DEBUG_EXECUTE_r( Perl_re_exec_indentf( aTHX_ "whilem: matched %ld out of %d..%d\n",
+ DEBUG_EXECUTE_r( Perl_re_exec_indentf( aTHX_ "WHILEM: matched %ld out of %d..%d\n",
depth, (long)n, min, max)
);
/* If degenerate A matches "", assume A done. */
if (locinput == cur_curlyx->u.curlyx.lastloc) {
- DEBUG_EXECUTE_r( Perl_re_exec_indentf( aTHX_ "whilem: empty match detected, trying continuation...\n",
+ DEBUG_EXECUTE_r( Perl_re_exec_indentf( aTHX_ "WHILEM: empty match detected, trying continuation...\n",
depth)
);
goto do_whilem_B_max;
Newxz(aux->poscache, size, char);
}
DEBUG_EXECUTE_r( Perl_re_printf( aTHX_
- "%swhilem: Detected a super-linear match, switching on caching%s...\n",
+ "%sWHILEM: Detected a super-linear match, switching on caching%s...\n",
PL_colors[4], PL_colors[5])
);
}
mask = 1 << (offset % 8);
offset /= 8;
if (reginfo->info_aux->poscache[offset] & mask) {
- DEBUG_EXECUTE_r( Perl_re_exec_indentf( aTHX_ "whilem: (cache) already tried at this position...\n",
+ DEBUG_EXECUTE_r( Perl_re_exec_indentf( aTHX_ "WHILEM: (cache) already tried at this position...\n",
depth)
);
cur_curlyx->u.curlyx.count--;
case WHILEM_A_max_fail: /* just failed to match A in a maximal match */
REGCP_UNWIND(ST.lastcp);
regcppop(rex, &maxopenparen); /* Restore some previous $<digit>s? */
- DEBUG_EXECUTE_r(Perl_re_exec_indentf( aTHX_ "whilem: failed, trying continuation...\n",
+ DEBUG_EXECUTE_r(Perl_re_exec_indentf( aTHX_ "WHILEM: failed, trying continuation...\n",
depth)
);
do_whilem_B_max:
CACHEsayNO;
}
- DEBUG_EXECUTE_r(Perl_re_exec_indentf( aTHX_ "trying longer...\n", depth)
+ DEBUG_EXECUTE_r(Perl_re_exec_indentf( aTHX_ "WHILEM: B min fail: trying longer...\n", depth)
);
/* Try grabbing another A and see if it helps. */
cur_curlyx->u.curlyx.lastloc = locinput;
st->u.eval.prev_eval = cur_eval;
cur_eval = CUR_EVAL.prev_eval;
DEBUG_EXECUTE_r(
- Perl_re_exec_indentf( aTHX_ "EVAL trying tail ... (cur_eval=%p)\n",
+ Perl_re_exec_indentf( aTHX_ "END: EVAL trying tail ... (cur_eval=%p)\n",
depth, cur_eval););
if ( nochange_depth )
nochange_depth--;
if (locinput < reginfo->till) {
DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
- "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
+ "%sEND: Match possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
PL_colors[4],
(long)(locinput - startpos),
(long)(reginfo->till - startpos),
case SUCCEED: /* successful SUSPEND/UNLESSM/IFMATCH/CURLYM */
DEBUG_EXECUTE_r(
- Perl_re_exec_indentf( aTHX_ "%ssubpattern success...%s\n",
+ Perl_re_exec_indentf( aTHX_ "%sSUCCEED: subpattern success...%s\n",
depth, PL_colors[4], PL_colors[5]));
sayYES; /* Success! */
sv_commit = ST.mark_name;
DEBUG_EXECUTE_r({
- Perl_re_exec_indentf( aTHX_ "%ssetting cutpoint to mark:%" SVf "...%s\n",
+ Perl_re_exec_indentf( aTHX_ "%sMARKPOINT: next fail: setting cutpoint to mark:%" SVf "...%s\n",
depth,
PL_colors[4], SVfARG(sv_commit), PL_colors[5]);
});
* since here, to match at all, 1 char == 1 byte */
loceol = scan + max;
}
- scan = find_span_end(scan, loceol, (U8) c);
+ scan = (char *) find_span_end((U8 *) scan, (U8 *) loceol, (U8) c);
}
else if (reginfo->is_utf8_pat) {
if (utf8_target) {
/* Target isn't utf8; convert the character in the UTF-8
* pattern to non-UTF8, and do a simple find */
c = EIGHT_BIT_UTF8_TO_NATIVE(c, *(STRING(p) + 1));
- scan = find_span_end(scan, loceol, (U8) c);
+ scan = (char *) find_span_end((U8 *) scan, (U8 *) loceol, (U8) c);
} /* else pattern char is above Latin1, can't possibly match the
non-UTF-8 target */
}
}
break;
- case EXACTFA_NO_TRIE: /* This node only generated for non-utf8 patterns */
+ case EXACTFAA_NO_TRIE: /* This node only generated for non-utf8 patterns */
assert(! reginfo->is_utf8_pat);
/* FALLTHROUGH */
- case EXACTFA:
+ case EXACTFAA:
utf8_flags = FOLDEQ_UTF8_NOMIX_ASCII;
goto do_exactf;
}
}
else if (c1 == c2) {
- scan = find_span_end(scan, loceol, c1);
+ scan = (char *) find_span_end((U8 *) scan, (U8 *) loceol, (U8) c1);
}
else {
/* See comments in regmatch() CURLY_B_min_known_fail. We avoid
U8 c1_c2_bits_differing = c1 ^ c2;
if (isPOWER_OF_2(c1_c2_bits_differing)) {
- U8 c1_masked = c1 & ~ c1_c2_bits_differing;
U8 c1_c2_mask = ~ c1_c2_bits_differing;
- while ( scan < loceol
- && (UCHARAT(scan) & c1_c2_mask) == c1_masked)
- {
- scan++;
- }
+ scan = (char *) find_span_end_mask((U8 *) scan,
+ (U8 *) loceol,
+ c1 & c1_c2_mask,
+ c1_c2_mask);
}
else {
while ( scan < loceol
}
break;
- case ASCII:
+ case ANYOFM:
if (utf8_target && loceol - scan > max) {
/* We didn't adjust <loceol> at the beginning of this routine
loceol = scan + max;
}
+ scan = (char *) find_span_end_mask((U8 *) scan, (U8 *) loceol, (U8) ARG(p), FLAGS(p));
+ break;
+
+ case ASCII:
+ if (utf8_target && loceol - scan > max) {
+ loceol = scan + max;
+ }
+
scan = find_next_non_ascii(scan, loceol, utf8_target);
break;
} else {
while (hardcount < max && scan < loceol
&& to_complement ^ cBOOL(isFOO_utf8_lc(FLAGS(p),
- (U8 *) scan)))
+ (U8 *) scan,
+ (U8 *) loceol)))
{
scan += UTF8SKIP(scan);
hardcount++;
else {
utf8_posix:
classnum = (_char_class_number) FLAGS(p);
- if (classnum < _FIRST_NON_SWASH_CC) {
-
- /* Here, a swash is needed for above-Latin1 code points.
- * Process as many Latin1 code points using the built-in rules.
- * Go to another loop to finish processing upon encountering
- * the first Latin1 code point. We could do that in this loop
- * as well, but the other way saves having to test if the swash
- * has been loaded every time through the loop: extra space to
- * save a test. */
- while (hardcount < max && scan < loceol) {
- if (UTF8_IS_INVARIANT(*scan)) {
- if (! (to_complement ^ cBOOL(_generic_isCC((U8) *scan,
- classnum))))
- {
- break;
- }
- scan++;
+ switch (classnum) {
+ default:
+ while ( hardcount < max && scan < loceol
+ && to_complement ^ cBOOL(_invlist_contains_cp(
+ PL_XPosix_ptrs[classnum],
+ utf8_to_uvchr_buf((U8 *) scan,
+ (U8 *) loceol,
+ NULL))))
+ {
+ scan += UTF8SKIP(scan);
+ hardcount++;
}
- else if (UTF8_IS_DOWNGRADEABLE_START(*scan)) {
- if (! (to_complement
- ^ cBOOL(_generic_isCC(EIGHT_BIT_UTF8_TO_NATIVE(*scan,
- *(scan + 1)),
- classnum))))
- {
- break;
- }
- scan += 2;
+ break;
+
+ /* For the classes below, the knowledge of how to handle
+ * every code point is compiled in to Perl via a macro.
+ * This code is written for making the loops as tight as
+ * possible. It could be refactored to save space instead.
+ * */
+
+ case _CC_ENUM_SPACE:
+ while (hardcount < max
+ && scan < loceol
+ && (to_complement
+ ^ cBOOL(isSPACE_utf8_safe(scan, loceol))))
+ {
+ scan += UTF8SKIP(scan);
+ hardcount++;
}
- else {
- goto found_above_latin1;
+ break;
+ case _CC_ENUM_BLANK:
+ while (hardcount < max
+ && scan < loceol
+ && (to_complement
+ ^ cBOOL(isBLANK_utf8_safe(scan, loceol))))
+ {
+ scan += UTF8SKIP(scan);
+ hardcount++;
}
-
- hardcount++;
- }
- }
- else {
- /* For these character classes, the knowledge of how to handle
- * every code point is compiled in to Perl via a macro. This
- * code is written for making the loops as tight as possible.
- * It could be refactored to save space instead */
- switch (classnum) {
- case _CC_ENUM_SPACE:
- while (hardcount < max
- && scan < loceol
- && (to_complement
- ^ cBOOL(isSPACE_utf8_safe(scan, loceol))))
- {
- scan += UTF8SKIP(scan);
- hardcount++;
- }
- break;
- case _CC_ENUM_BLANK:
- while (hardcount < max
- && scan < loceol
- && (to_complement
- ^ cBOOL(isBLANK_utf8_safe(scan, loceol))))
- {
- scan += UTF8SKIP(scan);
- hardcount++;
- }
- break;
- case _CC_ENUM_XDIGIT:
- while (hardcount < max
- && scan < loceol
- && (to_complement
- ^ cBOOL(isXDIGIT_utf8_safe(scan, loceol))))
- {
- scan += UTF8SKIP(scan);
- hardcount++;
- }
- break;
- case _CC_ENUM_VERTSPACE:
- while (hardcount < max
- && scan < loceol
- && (to_complement
- ^ cBOOL(isVERTWS_utf8_safe(scan, loceol))))
- {
- scan += UTF8SKIP(scan);
- hardcount++;
- }
- break;
- case _CC_ENUM_CNTRL:
- while (hardcount < max
- && scan < loceol
- && (to_complement
- ^ cBOOL(isCNTRL_utf8_safe(scan, loceol))))
- {
- scan += UTF8SKIP(scan);
- hardcount++;
- }
- break;
- default:
- Perl_croak(aTHX_ "panic: regrepeat() node %d='%s' has an unexpected character class '%d'", OP(p), PL_reg_name[OP(p)], classnum);
- }
+ break;
+ case _CC_ENUM_XDIGIT:
+ while (hardcount < max
+ && scan < loceol
+ && (to_complement
+ ^ cBOOL(isXDIGIT_utf8_safe(scan, loceol))))
+ {
+ scan += UTF8SKIP(scan);
+ hardcount++;
+ }
+ break;
+ case _CC_ENUM_VERTSPACE:
+ while (hardcount < max
+ && scan < loceol
+ && (to_complement
+ ^ cBOOL(isVERTWS_utf8_safe(scan, loceol))))
+ {
+ scan += UTF8SKIP(scan);
+ hardcount++;
+ }
+ break;
+ case _CC_ENUM_CNTRL:
+ while (hardcount < max
+ && scan < loceol
+ && (to_complement
+ ^ cBOOL(isCNTRL_utf8_safe(scan, loceol))))
+ {
+ scan += UTF8SKIP(scan);
+ hardcount++;
+ }
+ break;
}
}
break;
- found_above_latin1: /* Continuation of POSIXU and NPOSIXU */
-
- /* Load the swash if not already present */
- if (! PL_utf8_swash_ptrs[classnum]) {
- U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
- PL_utf8_swash_ptrs[classnum] = _core_swash_init(
- "utf8",
- "",
- &PL_sv_undef, 1, 0,
- PL_XPosix_ptrs[classnum], &flags);
- }
-
- while (hardcount < max && scan < loceol
- && to_complement ^ cBOOL(_generic_utf8_safe(
- classnum,
- scan,
- loceol,
- swash_fetch(PL_utf8_swash_ptrs[classnum],
- (U8 *) scan,
- TRUE))))
- {
- scan += UTF8SKIP(scan);
- hardcount++;
- }
- break;
-
case LNBREAK:
if (utf8_target) {
while (hardcount < max && scan < loceol &&
return isGCB(cp_gcb_val, next_cp_gcb_val, strbeg, s, TRUE);
}
+/*
+=head1 Unicode Support
+
+=for apidoc isSCRIPT_RUN
+
+Returns a bool as to whether or not the sequence of bytes from C<s> up to but
+not including C<send> form a "script run". C<utf8_target> is TRUE iff the
+sequence starting at C<s> is to be treated as UTF-8. To be precise, except for
+two degenerate cases given below, this function returns TRUE iff all code
+points in it come from any combination of three "scripts" given by the Unicode
+"Script Extensions" property: Common, Inherited, and possibly one other.
+Additionally all decimal digits must come from the same consecutive sequence of
+10.
+
+For example, if all the characters in the sequence are Greek, or Common, or
+Inherited, this function will return TRUE, provided any decimal digits in it
+are the ASCII digits "0".."9". For scripts (unlike Greek) that have their own
+digits defined this will accept either digits from that set or from 0..9, but
+not a combination of the two. Some scripts, such as Arabic, have more than one
+set of digits. All digits must come from the same set for this function to
+return TRUE.
+
+C<*ret_script>, if C<ret_script> is not NULL, will on return of TRUE
+contain the script found, using the C<SCX_enum> typedef. Its value will be
+C<SCX_INVALID> if the function returns FALSE.
+
+If the sequence is empty, TRUE is returned, but C<*ret_script> (if asked for)
+will be C<SCX_INVALID>.
+
+If the sequence contains a single code point which is unassigned to a character
+in the version of Unicode being used, the function will return TRUE, and the
+script will be C<SCX_Unknown>. Any other combination of unassigned code points
+in the input sequence will result in the function treating the input as not
+being a script run.
+
+The returned script will be C<SCX_Inherited> iff all the code points in it are
+from the Inherited script.
+
+Otherwise, the returned script will be C<SCX_Common> iff all the code points in
+it are from the Inherited or Common scripts.
+
+=cut
+
+*/
+
bool
Perl_isSCRIPT_RUN(pTHX_ const U8 * s, const U8 * send, const bool utf8_target)
{
- /* Checks that every character in the sequence from 's' to 'send' is one of
- * three scripts: Common, Inherited, and possibly one other. Additionally
- * all decimal digits must come from the same consecutive sequence of 10.
- * 'utf8_target' is TRUE iff the sequence is encoded in UTF-8.
- *
- * Basically, it looks at each character in the sequence to see if the
+ /* Basically, it looks at each character in the sequence to see if the
* above conditions are met; if not it fails. It uses an inversion map to
* find the enum corresponding to the script of each character. But this
* is complicated by the fact that a few code points can be in any of
bool retval = TRUE;
- assert(send > s);
+ /* This is supposed to be a return parameter, but currently unused */
+ SCX_enum * ret_script = NULL;
+
+ assert(send >= s);
PERL_ARGS_ASSERT_ISSCRIPT_RUN;
+ /* All code points in 0..255 are either Common or Latin, so must be a
+ * script run. We can special case it */
+ if (! utf8_target && LIKELY(send > s)) {
+ if (ret_script == NULL) {
+ return TRUE;
+ }
+
+ /* If any character is Latin, the run is Latin */
+ while (s < send) {
+ if (isALPHA_L1(*s) && LIKELY(*s != MICRO_SIGN_NATIVE)) {
+ *ret_script = SCX_Latin;
+ return TRUE;
+ }
+ }
+
+ /* If all are Common ... */
+ *ret_script = SCX_Common;
+ return TRUE;
+ }
+
/* Look at each character in the sequence */
while (s < send) {
UV cp;
* because they are used in commerce even in scripts that have their
* own set. Hence any ASCII ones found are ok, unless a digit from
* another set has already been encountered. (The other digit ranges
- * in Common are not similarly blessed */
+ * in Common are not similarly blessed) */
if (UNLIKELY(isDIGIT(*s))) {
+ if (UNLIKELY(script_of_run == SCX_Unknown)) {
+ retval = FALSE;
+ break;
+ }
if (zero_of_run > 0) {
if (zero_of_run != '0') {
retval = FALSE;
}
/* Here, isn't an ASCII digit. Find the code point of the character */
- if (utf8_target && ! UTF8_IS_INVARIANT(*s)) {
+ if (! UTF8_IS_INVARIANT(*s)) {
Size_t len;
cp = valid_utf8_to_uvchr((U8 *) s, &len);
s += len;
break;
}
+ /* For the first character, or the run is inherited, the run's script
+ * is set to the char's */
+ if ( UNLIKELY(script_of_run == SCX_INVALID)
+ || UNLIKELY(script_of_run == SCX_Inherited))
+ {
+ script_of_run = script_of_char;
+ }
+
+ /* For the character's script to be Unknown, it must be the first
+ * character in the sequence (for otherwise a test above would have
+ * prevented us from reaching here), and we have set the run's script
+ * to it. Nothing further to be done for this character */
if (UNLIKELY(script_of_char == SCX_Unknown)) {
- script_of_run = SCX_Unknown;
- continue;
+ continue;
}
/* We accept 'inherited' script characters currently even at the
continue;
}
- /* If unknown, the run's script is set to the char's */
- if (UNLIKELY(script_of_run == SCX_INVALID)) {
+ /* If the run so far is Common, and the new character isn't, change the
+ * run's script to that of this character */
+ if (script_of_run == SCX_Common && script_of_char != SCX_Common) {
+
+ /* But Common contains several sets of digits. Only the '0' set
+ * can be part of another script. */
+ if (zero_of_run > 0 && zero_of_run != '0') {
+ retval = FALSE;
+ break;
+ }
+
script_of_run = script_of_char;
}
goto scripts_match;
}
- /* Here, the scripts of the run and the current character don't match
- * exactly. The run could so far have been entirely characters from
- * Common. It's now time to change its script to that of this
- * non-Common character */
- if (script_of_run == SCX_Common) {
-
- /* But Common contains several sets of digits. Only the '0' set
- * can be part of another script. */
- if (zero_of_run > 0 && zero_of_run != '0') {
- retval = FALSE;
- break;
- }
-
- script_of_run = script_of_char;
- goto scripts_match;
- }
/* Here, the script of the run isn't Common. But characters in Common
* match any script */
/* Too early a Unicode version to have a code point belonging to more
* than one script, so, if the scripts don't exactly match, fail */
+ PERL_UNUSED_VAR(intersection_len);
retval = FALSE;
break;
} /* end of looping through CLOSESR text */
Safefree(intersection);
+
+ if (ret_script != NULL) {
+ if (retval) {
+ *ret_script = script_of_run;
+ }
+ else {
+ *ret_script = SCX_INVALID;
+ }
+ }
+
return retval;
}
https://perl5.git.perl.org / perl5.git / blobdiff