}
+STATIC char *
+S_find_span_end(char * s, const char * send, const char 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.
+ * */
+
+ PERL_ARGS_ASSERT_FIND_SPAN_END;
+
+ assert(send >= s);
+
+ if ((STRLEN) (send - s) >= PERL_WORDSIZE
+ + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(s)
+ - (PTR2nat(s) & PERL_WORD_BOUNDARY_MASK))
+ {
+ PERL_UINTMAX_T span_word;
+
+ /* Process per-byte until reach word boundary. XXX This loop could be
+ * eliminated if we knew that this platform had fast unaligned reads */
+ while (PTR2nat(s) & PERL_WORD_BOUNDARY_MASK) {
+ if (*s != span_byte) {
+ return s;
+ }
+ s++;
+ }
+
+ /* Create a word filled with the bytes we are spanning */
+ span_word = PERL_COUNT_MULTIPLIER * span_byte;
+
+ /* Process per-word as long as we have at least a full word left */
+ do {
+
+ /* Keep going if the whole word is composed of 'span_byte's */
+ if ((* (PERL_UINTMAX_T *) s) == span_word) {
+ s += PERL_WORDSIZE;
+ continue;
+ }
+
+ /* Here, at least one byte in the word isn't 'span_byte'. 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
+ * makes each such byte look like an ASCII platform variant byte */
+ span_word |= span_word << 1;
+ span_word |= span_word << 2;
+ span_word |= span_word << 4;
+
+ /* That reduces the problem to what this function solves */
+ return s + _variant_byte_number(span_word);
+
+ } while (s + PERL_WORDSIZE <= send);
+ }
+
+ /* Process the straggler bytes beyond the final word boundary */
+ while (s < send) {
+ if (*s != span_byte) {
+ return s;
+ }
+ s++;
+ }
+
+ return s;
+}
+
+STATIC char *
+S_find_next_masked(char * s, const char * 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);
+
+ 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 (((* (U8 *) 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);
+ }
+
+ while (s < send) {
+ if (((* (U8 *) 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 (((* (U8 *) 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;
+ }
+
+ masked ^= span_word;
+ masked |= masked << 1;
+ masked |= masked << 2;
+ masked |= masked << 4;
+ return s + _variant_byte_number(masked);
+
+ } while (s + PERL_WORDSIZE <= send);
+ }
+
+ while (s < send) {
+ if (((* (U8 *) s) & mask) != span_byte) {
+ return s;
+ }
+ s++;
+ }
+
+ return s;
+}
+
/*
* pregexec and friends
*/
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) { \
} \
} STMT_END
-/* We keep track of where the next character should start after an occurrence
- * of the one we're looking for. Knowing that, we can see right away if the
- * next occurrence is adjacent to the previous. When 'doevery' is FALSE, we
- * don't accept the 2nd and succeeding adjacent occurrences */
-
#define REXEC_FBC_CLASS_SCAN_GUTS(UTF8, COND) \
if (COND) { \
- if ( ( doevery \
- || s != previous_occurrence_end) \
- && (reginfo->intuit || regtry(reginfo, &s))) \
- { \
- goto got_it; \
- } \
+ FBC_CHECK_AND_TRY \
s += ((UTF8) ? UTF8SKIP(s) : 1); \
previous_occurrence_end = s; \
} \
REXEC_FBC_CLASS_SCAN(0, COND); \
}
+/* We keep track of where the next character should start after an occurrence
+ * of the one we're looking for. Knowing that, we can see right away if the
+ * next occurrence is adjacent to the previous. When 'doevery' is FALSE, we
+ * don't accept the 2nd and succeeding adjacent occurrences */
+#define FBC_CHECK_AND_TRY \
+ if ( ( doevery \
+ || s != previous_occurrence_end) \
+ && (reginfo->intuit || regtry(reginfo, &s))) \
+ { \
+ goto got_it; \
+ }
+
+
+/* This differs from the above macros in that it calls a function which returns
+ * the next occurrence of the thing being looked for in 's'; and 'strend' if
+ * there is no such occurrence. */
+#define REXEC_FBC_FIND_NEXT_SCAN(UTF8, f) \
+ while (s < strend) { \
+ s = f; \
+ if (s >= strend) { \
+ break; \
+ } \
+ \
+ FBC_CHECK_AND_TRY \
+ s += (UTF8) ? UTF8SKIP(s) : 1; \
+ previous_occurrence_end = s; \
+ }
+
/* The three macros below are slightly different versions of the same logic.
*
* The first is for /a and /aa when the target string is UTF-8. This can only
const char *strend, regmatch_info *reginfo)
{
dVAR;
+
+ /* TRUE if x+ need not match at just the 1st pos of run of x's */
const I32 doevery = (prog->intflags & PREGf_SKIP) == 0;
+
char *pat_string; /* The pattern's exactish string */
char *pat_end; /* ptr to end char of pat_string */
re_fold_t folder; /* Function for computing non-utf8 folds */
}
break;
+ 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,
+ find_next_masked(s, strend, ARG(c), FLAGS(c)));
+ break;
+
case EXACTFA_NO_TRIE: /* This node only generated for non-utf8 patterns */
assert(! is_utf8_pat);
/* FALLTHROUGH */
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 = find_next_masked(s, 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;
break;
case ASCII:
- s = find_next_ascii(s, strend, utf8_target);
- if (s < strend && (reginfo->intuit || regtry(reginfo, &s))) {
- goto got_it;
- }
-
+ REXEC_FBC_FIND_NEXT_SCAN(0, find_next_ascii(s, strend, utf8_target));
break;
case NASCII:
- s = find_next_non_ascii(s, strend, utf8_target);
- if (s < strend && (reginfo->intuit || regtry(reginfo, &s))) {
- goto got_it;
+ if (utf8_target) {
+ REXEC_FBC_FIND_NEXT_SCAN(1, find_next_non_ascii(s, strend,
+ utf8_target));
+ }
+ else {
+ REXEC_FBC_FIND_NEXT_SCAN(0, find_next_non_ascii(s, strend,
+ utf8_target));
}
break;
}
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;
case SRCLOSE: /* (*SCRIPT_RUN: ... ) */
- if (! isSCRIPT_RUN(script_run_begin, (U8 *) locinput, utf8_target))
+ if (! isSCRIPT_RUN(script_run_begin, (U8 *) locinput, utf8_target, NULL))
{
sayNO;
}
hardcount++;
}
} else {
- while (scan < loceol && *scan != '\n')
- scan++;
+ scan = (char *) memchr(scan, '\n', loceol - scan);
+ if (! scan) {
+ scan = loceol;
+ }
}
break;
case SANY:
c = (U8)*STRING(p);
- /* Can use a simple loop if the pattern char to match on is invariant
+ /* Can use a simple find if the pattern char to match on is invariant
* under UTF-8, or both target and pattern aren't UTF-8. Note that we
* can use UTF8_IS_INVARIANT() even if the pattern isn't UTF-8, as it's
* true iff it doesn't matter if the argument is in UTF-8 or not */
* since here, to match at all, 1 char == 1 byte */
loceol = scan + max;
}
- while (scan < loceol && UCHARAT(scan) == c) {
- scan++;
- }
+ scan = find_span_end(scan, loceol, (U8) c);
}
else if (reginfo->is_utf8_pat) {
if (utf8_target) {
else if (! UTF8_IS_ABOVE_LATIN1(c)) {
/* Target isn't utf8; convert the character in the UTF-8
- * pattern to non-UTF8, and do a simple loop */
+ * pattern to non-UTF8, and do a simple find */
c = EIGHT_BIT_UTF8_TO_NATIVE(c, *(STRING(p) + 1));
- while (scan < loceol && UCHARAT(scan) == c) {
- scan++;
- }
+ scan = find_span_end(scan, loceol, (U8) c);
} /* else pattern char is above Latin1, can't possibly match the
non-UTF-8 target */
}
}
}
else if (c1 == c2) {
- while (scan < loceol && UCHARAT(scan) == c1) {
- scan++;
- }
+ scan = find_span_end(scan, loceol, 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;
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)
+Perl_isSCRIPT_RUN(pTHX_ const U8 * s, const U8 * send, const bool utf8_target, SCX_enum * ret_script)
{
- /* 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);
+ 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 */
} /* 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