5 * One Ring to rule them all, One Ring to find them
7 * [p.v of _The Lord of the Rings_, opening poem]
8 * [p.50 of _The Lord of the Rings_, I/iii: "The Shadow of the Past"]
9 * [p.254 of _The Lord of the Rings_, II/ii: "The Council of Elrond"]
12 /* This file contains functions for executing a regular expression. See
13 * also regcomp.c which funnily enough, contains functions for compiling
14 * a regular expression.
16 * This file is also copied at build time to ext/re/re_exec.c, where
17 * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT.
18 * This causes the main functions to be compiled under new names and with
19 * debugging support added, which makes "use re 'debug'" work.
22 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
23 * confused with the original package (see point 3 below). Thanks, Henry!
26 /* Additional note: this code is very heavily munged from Henry's version
27 * in places. In some spots I've traded clarity for efficiency, so don't
28 * blame Henry for some of the lack of readability.
31 /* The names of the functions have been changed from regcomp and
32 * regexec to pregcomp and pregexec in order to avoid conflicts
33 * with the POSIX routines of the same names.
36 #ifdef PERL_EXT_RE_BUILD
41 * pregcomp and pregexec -- regsub and regerror are not used in perl
43 * Copyright (c) 1986 by University of Toronto.
44 * Written by Henry Spencer. Not derived from licensed software.
46 * Permission is granted to anyone to use this software for any
47 * purpose on any computer system, and to redistribute it freely,
48 * subject to the following restrictions:
50 * 1. The author is not responsible for the consequences of use of
51 * this software, no matter how awful, even if they arise
54 * 2. The origin of this software must not be misrepresented, either
55 * by explicit claim or by omission.
57 * 3. Altered versions must be plainly marked as such, and must not
58 * be misrepresented as being the original software.
60 **** Alterations to Henry's code are...
62 **** Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
63 **** 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
64 **** by Larry Wall and others
66 **** You may distribute under the terms of either the GNU General Public
67 **** License or the Artistic License, as specified in the README file.
69 * Beware that some of this code is subtly aware of the way operator
70 * precedence is structured in regular expressions. Serious changes in
71 * regular-expression syntax might require a total rethink.
74 #define PERL_IN_REGEXEC_C
77 #ifdef PERL_IN_XSUB_RE
83 #include "invlist_inline.h"
84 #include "unicode_constants.h"
86 #define B_ON_NON_UTF8_LOCALE_IS_WRONG \
87 "Use of \\b{} or \\B{} for non-UTF-8 locale is wrong. Assuming a UTF-8 locale"
89 static const char utf8_locale_required[] =
90 "Use of (?[ ]) for non-UTF-8 locale is wrong. Assuming a UTF-8 locale";
93 /* At least one required character in the target string is expressible only in
95 static const char* const non_utf8_target_but_utf8_required
96 = "Can't match, because target string needs to be in UTF-8\n";
99 #define NON_UTF8_TARGET_BUT_UTF8_REQUIRED(target) STMT_START { \
100 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s", non_utf8_target_but_utf8_required));\
104 #define HAS_NONLATIN1_FOLD_CLOSURE(i) _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)
107 #define STATIC static
110 /* Valid only for non-utf8 strings: avoids the reginclass
111 * call if there are no complications: i.e., if everything matchable is
112 * straight forward in the bitmap */
113 #define REGINCLASS(prog,p,c) (ANYOF_FLAGS(p) ? reginclass(prog,p,c,c+1,0) \
114 : ANYOF_BITMAP_TEST(p,*(c)))
120 #define CHR_SVLEN(sv) (utf8_target ? sv_len_utf8(sv) : SvCUR(sv))
121 #define CHR_DIST(a,b) (reginfo->is_utf8_target ? utf8_distance(a,b) : a - b)
123 #define HOPc(pos,off) \
124 (char *)(reginfo->is_utf8_target \
125 ? reghop3((U8*)pos, off, \
126 (U8*)(off >= 0 ? reginfo->strend : reginfo->strbeg)) \
129 #define HOPBACKc(pos, off) \
130 (char*)(reginfo->is_utf8_target \
131 ? reghopmaybe3((U8*)pos, -off, (U8*)(reginfo->strbeg)) \
132 : (pos - off >= reginfo->strbeg) \
136 #define HOP3(pos,off,lim) (reginfo->is_utf8_target ? reghop3((U8*)(pos), off, (U8*)(lim)) : (U8*)(pos + off))
137 #define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim))
139 /* lim must be +ve. Returns NULL on overshoot */
140 #define HOPMAYBE3(pos,off,lim) \
141 (reginfo->is_utf8_target \
142 ? reghopmaybe3((U8*)pos, off, (U8*)(lim)) \
143 : ((U8*)pos + off <= lim) \
147 /* like HOP3, but limits the result to <= lim even for the non-utf8 case.
148 * off must be >=0; args should be vars rather than expressions */
149 #define HOP3lim(pos,off,lim) (reginfo->is_utf8_target \
150 ? reghop3((U8*)(pos), off, (U8*)(lim)) \
151 : (U8*)((pos + off) > lim ? lim : (pos + off)))
153 #define HOP4(pos,off,llim, rlim) (reginfo->is_utf8_target \
154 ? reghop4((U8*)(pos), off, (U8*)(llim), (U8*)(rlim)) \
156 #define HOP4c(pos,off,llim, rlim) ((char*)HOP4(pos,off,llim, rlim))
158 #define NEXTCHR_EOS -10 /* nextchr has fallen off the end */
159 #define NEXTCHR_IS_EOS (nextchr < 0)
161 #define SET_nextchr \
162 nextchr = ((locinput < reginfo->strend) ? UCHARAT(locinput) : NEXTCHR_EOS)
164 #define SET_locinput(p) \
169 #define LOAD_UTF8_CHARCLASS(swash_ptr, property_name, invlist) STMT_START { \
171 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST; \
172 swash_ptr = _core_swash_init("utf8", property_name, &PL_sv_undef, \
173 1, 0, invlist, &flags); \
178 /* If in debug mode, we test that a known character properly matches */
180 # define LOAD_UTF8_CHARCLASS_DEBUG_TEST(swash_ptr, \
183 utf8_char_in_property) \
184 LOAD_UTF8_CHARCLASS(swash_ptr, property_name, invlist); \
185 assert(swash_fetch(swash_ptr, (U8 *) utf8_char_in_property, TRUE));
187 # define LOAD_UTF8_CHARCLASS_DEBUG_TEST(swash_ptr, \
190 utf8_char_in_property) \
191 LOAD_UTF8_CHARCLASS(swash_ptr, property_name, invlist)
194 #define LOAD_UTF8_CHARCLASS_ALNUM() LOAD_UTF8_CHARCLASS_DEBUG_TEST( \
195 PL_utf8_swash_ptrs[_CC_WORDCHAR], \
197 PL_XPosix_ptrs[_CC_WORDCHAR], \
198 LATIN_SMALL_LIGATURE_LONG_S_T_UTF8);
200 #define PLACEHOLDER /* Something for the preprocessor to grab onto */
201 /* TODO: Combine JUMPABLE and HAS_TEXT to cache OP(rn) */
203 /* for use after a quantifier and before an EXACT-like node -- japhy */
204 /* it would be nice to rework regcomp.sym to generate this stuff. sigh
206 * NOTE that *nothing* that affects backtracking should be in here, specifically
207 * VERBS must NOT be included. JUMPABLE is used to determine if we can ignore a
208 * node that is in between two EXACT like nodes when ascertaining what the required
209 * "follow" character is. This should probably be moved to regex compile time
210 * although it may be done at run time beause of the REF possibility - more
211 * investigation required. -- demerphq
213 #define JUMPABLE(rn) ( \
215 (OP(rn) == CLOSE && (!cur_eval || cur_eval->u.eval.close_paren != ARG(rn))) || \
217 OP(rn) == SUSPEND || OP(rn) == IFMATCH || \
218 OP(rn) == PLUS || OP(rn) == MINMOD || \
220 (PL_regkind[OP(rn)] == CURLY && ARG1(rn) > 0) \
222 #define IS_EXACT(rn) (PL_regkind[OP(rn)] == EXACT)
224 #define HAS_TEXT(rn) ( IS_EXACT(rn) || PL_regkind[OP(rn)] == REF )
227 /* Currently these are only used when PL_regkind[OP(rn)] == EXACT so
228 we don't need this definition. XXX These are now out-of-sync*/
229 #define IS_TEXT(rn) ( OP(rn)==EXACT || OP(rn)==REF || OP(rn)==NREF )
230 #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 )
231 #define IS_TEXTFL(rn) ( OP(rn)==EXACTFL || OP(rn)==REFFL || OP(rn)==NREFFL )
234 /* ... so we use this as its faster. */
235 #define IS_TEXT(rn) ( OP(rn)==EXACT || OP(rn)==EXACTL )
236 #define IS_TEXTFU(rn) ( OP(rn)==EXACTFU || OP(rn)==EXACTFLU8 || OP(rn)==EXACTFU_SS || OP(rn) == EXACTFA || OP(rn) == EXACTFA_NO_TRIE)
237 #define IS_TEXTF(rn) ( OP(rn)==EXACTF )
238 #define IS_TEXTFL(rn) ( OP(rn)==EXACTFL )
243 Search for mandatory following text node; for lookahead, the text must
244 follow but for lookbehind (rn->flags != 0) we skip to the next step.
246 #define FIND_NEXT_IMPT(rn) STMT_START { \
247 while (JUMPABLE(rn)) { \
248 const OPCODE type = OP(rn); \
249 if (type == SUSPEND || PL_regkind[type] == CURLY) \
250 rn = NEXTOPER(NEXTOPER(rn)); \
251 else if (type == PLUS) \
253 else if (type == IFMATCH) \
254 rn = (rn->flags == 0) ? NEXTOPER(NEXTOPER(rn)) : rn + ARG(rn); \
255 else rn += NEXT_OFF(rn); \
259 #define SLAB_FIRST(s) (&(s)->states[0])
260 #define SLAB_LAST(s) (&(s)->states[PERL_REGMATCH_SLAB_SLOTS-1])
262 static void S_setup_eval_state(pTHX_ regmatch_info *const reginfo);
263 static void S_cleanup_regmatch_info_aux(pTHX_ void *arg);
264 static regmatch_state * S_push_slab(pTHX);
266 #define REGCP_PAREN_ELEMS 3
267 #define REGCP_OTHER_ELEMS 3
268 #define REGCP_FRAME_ELEMS 1
269 /* REGCP_FRAME_ELEMS are not part of the REGCP_OTHER_ELEMS and
270 * are needed for the regexp context stack bookkeeping. */
273 S_regcppush(pTHX_ const regexp *rex, I32 parenfloor, U32 maxopenparen)
275 const int retval = PL_savestack_ix;
276 const int paren_elems_to_push =
277 (maxopenparen - parenfloor) * REGCP_PAREN_ELEMS;
278 const UV total_elems = paren_elems_to_push + REGCP_OTHER_ELEMS;
279 const UV elems_shifted = total_elems << SAVE_TIGHT_SHIFT;
281 GET_RE_DEBUG_FLAGS_DECL;
283 PERL_ARGS_ASSERT_REGCPPUSH;
285 if (paren_elems_to_push < 0)
286 Perl_croak(aTHX_ "panic: paren_elems_to_push, %i < 0, maxopenparen: %i parenfloor: %i REGCP_PAREN_ELEMS: %u",
287 (int)paren_elems_to_push, (int)maxopenparen,
288 (int)parenfloor, (unsigned)REGCP_PAREN_ELEMS);
290 if ((elems_shifted >> SAVE_TIGHT_SHIFT) != total_elems)
291 Perl_croak(aTHX_ "panic: paren_elems_to_push offset %"UVuf
292 " out of range (%lu-%ld)",
294 (unsigned long)maxopenparen,
297 SSGROW(total_elems + REGCP_FRAME_ELEMS);
300 if ((int)maxopenparen > (int)parenfloor)
301 PerlIO_printf(Perl_debug_log,
302 "rex=0x%"UVxf" offs=0x%"UVxf": saving capture indices:\n",
307 for (p = parenfloor+1; p <= (I32)maxopenparen; p++) {
308 /* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */
309 SSPUSHIV(rex->offs[p].end);
310 SSPUSHIV(rex->offs[p].start);
311 SSPUSHINT(rex->offs[p].start_tmp);
312 DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
313 " \\%"UVuf": %"IVdf"(%"IVdf")..%"IVdf"\n",
315 (IV)rex->offs[p].start,
316 (IV)rex->offs[p].start_tmp,
320 /* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */
321 SSPUSHINT(maxopenparen);
322 SSPUSHINT(rex->lastparen);
323 SSPUSHINT(rex->lastcloseparen);
324 SSPUSHUV(SAVEt_REGCONTEXT | elems_shifted); /* Magic cookie. */
329 /* These are needed since we do not localize EVAL nodes: */
330 #define REGCP_SET(cp) \
332 PerlIO_printf(Perl_debug_log, \
333 " Setting an EVAL scope, savestack=%"IVdf"\n", \
334 (IV)PL_savestack_ix)); \
337 #define REGCP_UNWIND(cp) \
339 if (cp != PL_savestack_ix) \
340 PerlIO_printf(Perl_debug_log, \
341 " Clearing an EVAL scope, savestack=%"IVdf"..%"IVdf"\n", \
342 (IV)(cp), (IV)PL_savestack_ix)); \
345 #define UNWIND_PAREN(lp, lcp) \
346 for (n = rex->lastparen; n > lp; n--) \
347 rex->offs[n].end = -1; \
348 rex->lastparen = n; \
349 rex->lastcloseparen = lcp;
353 S_regcppop(pTHX_ regexp *rex, U32 *maxopenparen_p)
357 GET_RE_DEBUG_FLAGS_DECL;
359 PERL_ARGS_ASSERT_REGCPPOP;
361 /* Pop REGCP_OTHER_ELEMS before the parentheses loop starts. */
363 assert((i & SAVE_MASK) == SAVEt_REGCONTEXT); /* Check that the magic cookie is there. */
364 i >>= SAVE_TIGHT_SHIFT; /* Parentheses elements to pop. */
365 rex->lastcloseparen = SSPOPINT;
366 rex->lastparen = SSPOPINT;
367 *maxopenparen_p = SSPOPINT;
369 i -= REGCP_OTHER_ELEMS;
370 /* Now restore the parentheses context. */
372 if (i || rex->lastparen + 1 <= rex->nparens)
373 PerlIO_printf(Perl_debug_log,
374 "rex=0x%"UVxf" offs=0x%"UVxf": restoring capture indices to:\n",
379 paren = *maxopenparen_p;
380 for ( ; i > 0; i -= REGCP_PAREN_ELEMS) {
382 rex->offs[paren].start_tmp = SSPOPINT;
383 rex->offs[paren].start = SSPOPIV;
385 if (paren <= rex->lastparen)
386 rex->offs[paren].end = tmps;
387 DEBUG_BUFFERS_r( PerlIO_printf(Perl_debug_log,
388 " \\%"UVuf": %"IVdf"(%"IVdf")..%"IVdf"%s\n",
390 (IV)rex->offs[paren].start,
391 (IV)rex->offs[paren].start_tmp,
392 (IV)rex->offs[paren].end,
393 (paren > rex->lastparen ? "(skipped)" : ""));
398 /* It would seem that the similar code in regtry()
399 * already takes care of this, and in fact it is in
400 * a better location to since this code can #if 0-ed out
401 * but the code in regtry() is needed or otherwise tests
402 * requiring null fields (pat.t#187 and split.t#{13,14}
403 * (as of patchlevel 7877) will fail. Then again,
404 * this code seems to be necessary or otherwise
405 * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
406 * --jhi updated by dapm */
407 for (i = rex->lastparen + 1; i <= rex->nparens; i++) {
408 if (i > *maxopenparen_p)
409 rex->offs[i].start = -1;
410 rex->offs[i].end = -1;
411 DEBUG_BUFFERS_r( PerlIO_printf(Perl_debug_log,
412 " \\%"UVuf": %s ..-1 undeffing\n",
414 (i > *maxopenparen_p) ? "-1" : " "
420 /* restore the parens and associated vars at savestack position ix,
421 * but without popping the stack */
424 S_regcp_restore(pTHX_ regexp *rex, I32 ix, U32 *maxopenparen_p)
426 I32 tmpix = PL_savestack_ix;
427 PL_savestack_ix = ix;
428 regcppop(rex, maxopenparen_p);
429 PL_savestack_ix = tmpix;
432 #define regcpblow(cp) LEAVE_SCOPE(cp) /* Ignores regcppush()ed data. */
435 S_isFOO_lc(pTHX_ const U8 classnum, const U8 character)
437 /* Returns a boolean as to whether or not 'character' is a member of the
438 * Posix character class given by 'classnum' that should be equivalent to a
439 * value in the typedef '_char_class_number'.
441 * Ideally this could be replaced by a just an array of function pointers
442 * to the C library functions that implement the macros this calls.
443 * However, to compile, the precise function signatures are required, and
444 * these may vary from platform to to platform. To avoid having to figure
445 * out what those all are on each platform, I (khw) am using this method,
446 * which adds an extra layer of function call overhead (unless the C
447 * optimizer strips it away). But we don't particularly care about
448 * performance with locales anyway. */
450 switch ((_char_class_number) classnum) {
451 case _CC_ENUM_ALPHANUMERIC: return isALPHANUMERIC_LC(character);
452 case _CC_ENUM_ALPHA: return isALPHA_LC(character);
453 case _CC_ENUM_ASCII: return isASCII_LC(character);
454 case _CC_ENUM_BLANK: return isBLANK_LC(character);
455 case _CC_ENUM_CASED: return isLOWER_LC(character)
456 || isUPPER_LC(character);
457 case _CC_ENUM_CNTRL: return isCNTRL_LC(character);
458 case _CC_ENUM_DIGIT: return isDIGIT_LC(character);
459 case _CC_ENUM_GRAPH: return isGRAPH_LC(character);
460 case _CC_ENUM_LOWER: return isLOWER_LC(character);
461 case _CC_ENUM_PRINT: return isPRINT_LC(character);
462 case _CC_ENUM_PUNCT: return isPUNCT_LC(character);
463 case _CC_ENUM_SPACE: return isSPACE_LC(character);
464 case _CC_ENUM_UPPER: return isUPPER_LC(character);
465 case _CC_ENUM_WORDCHAR: return isWORDCHAR_LC(character);
466 case _CC_ENUM_XDIGIT: return isXDIGIT_LC(character);
467 default: /* VERTSPACE should never occur in locales */
468 Perl_croak(aTHX_ "panic: isFOO_lc() has an unexpected character class '%d'", classnum);
471 NOT_REACHED; /* NOTREACHED */
476 S_isFOO_utf8_lc(pTHX_ const U8 classnum, const U8* character)
478 /* Returns a boolean as to whether or not the (well-formed) UTF-8-encoded
479 * 'character' is a member of the Posix character class given by 'classnum'
480 * that should be equivalent to a value in the typedef
481 * '_char_class_number'.
483 * This just calls isFOO_lc on the code point for the character if it is in
484 * the range 0-255. Outside that range, all characters use Unicode
485 * rules, ignoring any locale. So use the Unicode function if this class
486 * requires a swash, and use the Unicode macro otherwise. */
488 PERL_ARGS_ASSERT_ISFOO_UTF8_LC;
490 if (UTF8_IS_INVARIANT(*character)) {
491 return isFOO_lc(classnum, *character);
493 else if (UTF8_IS_DOWNGRADEABLE_START(*character)) {
494 return isFOO_lc(classnum,
495 EIGHT_BIT_UTF8_TO_NATIVE(*character, *(character + 1)));
498 _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(character, character + UTF8SKIP(character));
500 if (classnum < _FIRST_NON_SWASH_CC) {
502 /* Initialize the swash unless done already */
503 if (! PL_utf8_swash_ptrs[classnum]) {
504 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
505 PL_utf8_swash_ptrs[classnum] =
506 _core_swash_init("utf8",
509 PL_XPosix_ptrs[classnum], &flags);
512 return cBOOL(swash_fetch(PL_utf8_swash_ptrs[classnum], (U8 *)
514 TRUE /* is UTF */ ));
517 switch ((_char_class_number) classnum) {
518 case _CC_ENUM_SPACE: return is_XPERLSPACE_high(character);
519 case _CC_ENUM_BLANK: return is_HORIZWS_high(character);
520 case _CC_ENUM_XDIGIT: return is_XDIGIT_high(character);
521 case _CC_ENUM_VERTSPACE: return is_VERTWS_high(character);
525 return FALSE; /* Things like CNTRL are always below 256 */
529 * pregexec and friends
532 #ifndef PERL_IN_XSUB_RE
534 - pregexec - match a regexp against a string
537 Perl_pregexec(pTHX_ REGEXP * const prog, char* stringarg, char *strend,
538 char *strbeg, SSize_t minend, SV *screamer, U32 nosave)
539 /* stringarg: the point in the string at which to begin matching */
540 /* strend: pointer to null at end of string */
541 /* strbeg: real beginning of string */
542 /* minend: end of match must be >= minend bytes after stringarg. */
543 /* screamer: SV being matched: only used for utf8 flag, pos() etc; string
544 * itself is accessed via the pointers above */
545 /* nosave: For optimizations. */
547 PERL_ARGS_ASSERT_PREGEXEC;
550 regexec_flags(prog, stringarg, strend, strbeg, minend, screamer, NULL,
551 nosave ? 0 : REXEC_COPY_STR);
557 /* re_intuit_start():
559 * Based on some optimiser hints, try to find the earliest position in the
560 * string where the regex could match.
562 * rx: the regex to match against
563 * sv: the SV being matched: only used for utf8 flag; the string
564 * itself is accessed via the pointers below. Note that on
565 * something like an overloaded SV, SvPOK(sv) may be false
566 * and the string pointers may point to something unrelated to
568 * strbeg: real beginning of string
569 * strpos: the point in the string at which to begin matching
570 * strend: pointer to the byte following the last char of the string
571 * flags currently unused; set to 0
572 * data: currently unused; set to NULL
574 * The basic idea of re_intuit_start() is to use some known information
575 * about the pattern, namely:
577 * a) the longest known anchored substring (i.e. one that's at a
578 * constant offset from the beginning of the pattern; but not
579 * necessarily at a fixed offset from the beginning of the
581 * b) the longest floating substring (i.e. one that's not at a constant
582 * offset from the beginning of the pattern);
583 * c) Whether the pattern is anchored to the string; either
584 * an absolute anchor: /^../, or anchored to \n: /^.../m,
585 * or anchored to pos(): /\G/;
586 * d) A start class: a real or synthetic character class which
587 * represents which characters are legal at the start of the pattern;
589 * to either quickly reject the match, or to find the earliest position
590 * within the string at which the pattern might match, thus avoiding
591 * running the full NFA engine at those earlier locations, only to
592 * eventually fail and retry further along.
594 * Returns NULL if the pattern can't match, or returns the address within
595 * the string which is the earliest place the match could occur.
597 * The longest of the anchored and floating substrings is called 'check'
598 * and is checked first. The other is called 'other' and is checked
599 * second. The 'other' substring may not be present. For example,
601 * /(abc|xyz)ABC\d{0,3}DEFG/
605 * check substr (float) = "DEFG", offset 6..9 chars
606 * other substr (anchored) = "ABC", offset 3..3 chars
609 * Be aware that during the course of this function, sometimes 'anchored'
610 * refers to a substring being anchored relative to the start of the
611 * pattern, and sometimes to the pattern itself being anchored relative to
612 * the string. For example:
614 * /\dabc/: "abc" is anchored to the pattern;
615 * /^\dabc/: "abc" is anchored to the pattern and the string;
616 * /\d+abc/: "abc" is anchored to neither the pattern nor the string;
617 * /^\d+abc/: "abc" is anchored to neither the pattern nor the string,
618 * but the pattern is anchored to the string.
622 Perl_re_intuit_start(pTHX_
625 const char * const strbeg,
629 re_scream_pos_data *data)
631 struct regexp *const prog = ReANY(rx);
632 SSize_t start_shift = prog->check_offset_min;
633 /* Should be nonnegative! */
634 SSize_t end_shift = 0;
635 /* current lowest pos in string where the regex can start matching */
636 char *rx_origin = strpos;
638 const bool utf8_target = (sv && SvUTF8(sv)) ? 1 : 0; /* if no sv we have to assume bytes */
639 U8 other_ix = 1 - prog->substrs->check_ix;
641 char *other_last = strpos;/* latest pos 'other' substr already checked to */
642 char *check_at = NULL; /* check substr found at this pos */
643 const I32 multiline = prog->extflags & RXf_PMf_MULTILINE;
644 RXi_GET_DECL(prog,progi);
645 regmatch_info reginfo_buf; /* create some info to pass to find_byclass */
646 regmatch_info *const reginfo = ®info_buf;
647 GET_RE_DEBUG_FLAGS_DECL;
649 PERL_ARGS_ASSERT_RE_INTUIT_START;
650 PERL_UNUSED_ARG(flags);
651 PERL_UNUSED_ARG(data);
653 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
654 "Intuit: trying to determine minimum start position...\n"));
656 /* for now, assume that all substr offsets are positive. If at some point
657 * in the future someone wants to do clever things with lookbehind and
658 * -ve offsets, they'll need to fix up any code in this function
659 * which uses these offsets. See the thread beginning
660 * <20140113145929.GF27210@iabyn.com>
662 assert(prog->substrs->data[0].min_offset >= 0);
663 assert(prog->substrs->data[0].max_offset >= 0);
664 assert(prog->substrs->data[1].min_offset >= 0);
665 assert(prog->substrs->data[1].max_offset >= 0);
666 assert(prog->substrs->data[2].min_offset >= 0);
667 assert(prog->substrs->data[2].max_offset >= 0);
669 /* for now, assume that if both present, that the floating substring
670 * doesn't start before the anchored substring.
671 * If you break this assumption (e.g. doing better optimisations
672 * with lookahead/behind), then you'll need to audit the code in this
673 * function carefully first
676 ! ( (prog->anchored_utf8 || prog->anchored_substr)
677 && (prog->float_utf8 || prog->float_substr))
678 || (prog->float_min_offset >= prog->anchored_offset));
680 /* byte rather than char calculation for efficiency. It fails
681 * to quickly reject some cases that can't match, but will reject
682 * them later after doing full char arithmetic */
683 if (prog->minlen > strend - strpos) {
684 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
685 " String too short...\n"));
689 RX_MATCH_UTF8_set(rx,utf8_target);
690 reginfo->is_utf8_target = cBOOL(utf8_target);
691 reginfo->info_aux = NULL;
692 reginfo->strbeg = strbeg;
693 reginfo->strend = strend;
694 reginfo->is_utf8_pat = cBOOL(RX_UTF8(rx));
696 /* not actually used within intuit, but zero for safety anyway */
697 reginfo->poscache_maxiter = 0;
700 if (!prog->check_utf8 && prog->check_substr)
701 to_utf8_substr(prog);
702 check = prog->check_utf8;
704 if (!prog->check_substr && prog->check_utf8) {
705 if (! to_byte_substr(prog)) {
706 NON_UTF8_TARGET_BUT_UTF8_REQUIRED(fail);
709 check = prog->check_substr;
712 /* dump the various substring data */
713 DEBUG_OPTIMISE_MORE_r({
715 for (i=0; i<=2; i++) {
716 SV *sv = (utf8_target ? prog->substrs->data[i].utf8_substr
717 : prog->substrs->data[i].substr);
721 PerlIO_printf(Perl_debug_log,
722 " substrs[%d]: min=%"IVdf" max=%"IVdf" end shift=%"IVdf
723 " useful=%"IVdf" utf8=%d [%s]\n",
725 (IV)prog->substrs->data[i].min_offset,
726 (IV)prog->substrs->data[i].max_offset,
727 (IV)prog->substrs->data[i].end_shift,
734 if (prog->intflags & PREGf_ANCH) { /* Match at \G, beg-of-str or after \n */
736 /* ml_anch: check after \n?
738 * A note about PREGf_IMPLICIT: on an un-anchored pattern beginning
739 * with /.*.../, these flags will have been added by the
741 * /.*abc/, /.*abc/m: PREGf_IMPLICIT | PREGf_ANCH_MBOL
742 * /.*abc/s: PREGf_IMPLICIT | PREGf_ANCH_SBOL
744 ml_anch = (prog->intflags & PREGf_ANCH_MBOL)
745 && !(prog->intflags & PREGf_IMPLICIT);
747 if (!ml_anch && !(prog->intflags & PREGf_IMPLICIT)) {
748 /* we are only allowed to match at BOS or \G */
750 /* trivially reject if there's a BOS anchor and we're not at BOS.
752 * Note that we don't try to do a similar quick reject for
753 * \G, since generally the caller will have calculated strpos
754 * based on pos() and gofs, so the string is already correctly
755 * anchored by definition; and handling the exceptions would
756 * be too fiddly (e.g. REXEC_IGNOREPOS).
758 if ( strpos != strbeg
759 && (prog->intflags & PREGf_ANCH_SBOL))
761 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
762 " Not at start...\n"));
766 /* in the presence of an anchor, the anchored (relative to the
767 * start of the regex) substr must also be anchored relative
768 * to strpos. So quickly reject if substr isn't found there.
769 * This works for \G too, because the caller will already have
770 * subtracted gofs from pos, and gofs is the offset from the
771 * \G to the start of the regex. For example, in /.abc\Gdef/,
772 * where substr="abcdef", pos()=3, gofs=4, offset_min=1:
773 * caller will have set strpos=pos()-4; we look for the substr
774 * at position pos()-4+1, which lines up with the "a" */
776 if (prog->check_offset_min == prog->check_offset_max) {
777 /* Substring at constant offset from beg-of-str... */
778 SSize_t slen = SvCUR(check);
779 char *s = HOP3c(strpos, prog->check_offset_min, strend);
781 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
782 " Looking for check substr at fixed offset %"IVdf"...\n",
783 (IV)prog->check_offset_min));
786 /* In this case, the regex is anchored at the end too.
787 * Unless it's a multiline match, the lengths must match
788 * exactly, give or take a \n. NB: slen >= 1 since
789 * the last char of check is \n */
791 && ( strend - s > slen
792 || strend - s < slen - 1
793 || (strend - s == slen && strend[-1] != '\n')))
795 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
796 " String too long...\n"));
799 /* Now should match s[0..slen-2] */
802 if (slen && (*SvPVX_const(check) != *s
803 || (slen > 1 && memNE(SvPVX_const(check), s, slen))))
805 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
806 " String not equal...\n"));
811 goto success_at_start;
816 end_shift = prog->check_end_shift;
818 #ifdef DEBUGGING /* 7/99: reports of failure (with the older version) */
820 Perl_croak(aTHX_ "panic: end_shift: %"IVdf" pattern:\n%s\n ",
821 (IV)end_shift, RX_PRECOMP(prog));
826 /* This is the (re)entry point of the main loop in this function.
827 * The goal of this loop is to:
828 * 1) find the "check" substring in the region rx_origin..strend
829 * (adjusted by start_shift / end_shift). If not found, reject
831 * 2) If it exists, look for the "other" substr too if defined; for
832 * example, if the check substr maps to the anchored substr, then
833 * check the floating substr, and vice-versa. If not found, go
834 * back to (1) with rx_origin suitably incremented.
835 * 3) If we find an rx_origin position that doesn't contradict
836 * either of the substrings, then check the possible additional
837 * constraints on rx_origin of /^.../m or a known start class.
838 * If these fail, then depending on which constraints fail, jump
839 * back to here, or to various other re-entry points further along
840 * that skip some of the first steps.
841 * 4) If we pass all those tests, update the BmUSEFUL() count on the
842 * substring. If the start position was determined to be at the
843 * beginning of the string - so, not rejected, but not optimised,
844 * since we have to run regmatch from position 0 - decrement the
845 * BmUSEFUL() count. Otherwise increment it.
849 /* first, look for the 'check' substring */
855 DEBUG_OPTIMISE_MORE_r({
856 PerlIO_printf(Perl_debug_log,
857 " At restart: rx_origin=%"IVdf" Check offset min: %"IVdf
858 " Start shift: %"IVdf" End shift %"IVdf
859 " Real end Shift: %"IVdf"\n",
860 (IV)(rx_origin - strbeg),
861 (IV)prog->check_offset_min,
864 (IV)prog->check_end_shift);
867 end_point = HOP3(strend, -end_shift, strbeg);
868 start_point = HOPMAYBE3(rx_origin, start_shift, end_point);
873 /* If the regex is absolutely anchored to either the start of the
874 * string (SBOL) or to pos() (ANCH_GPOS), then
875 * check_offset_max represents an upper bound on the string where
876 * the substr could start. For the ANCH_GPOS case, we assume that
877 * the caller of intuit will have already set strpos to
878 * pos()-gofs, so in this case strpos + offset_max will still be
879 * an upper bound on the substr.
882 && prog->intflags & PREGf_ANCH
883 && prog->check_offset_max != SSize_t_MAX)
885 SSize_t len = SvCUR(check) - !!SvTAIL(check);
886 const char * const anchor =
887 (prog->intflags & PREGf_ANCH_GPOS ? strpos : strbeg);
889 /* do a bytes rather than chars comparison. It's conservative;
890 * so it skips doing the HOP if the result can't possibly end
891 * up earlier than the old value of end_point.
893 if ((char*)end_point - anchor > prog->check_offset_max) {
894 end_point = HOP3lim((U8*)anchor,
895 prog->check_offset_max,
901 check_at = fbm_instr( start_point, end_point,
902 check, multiline ? FBMrf_MULTILINE : 0);
904 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
905 " doing 'check' fbm scan, [%"IVdf"..%"IVdf"] gave %"IVdf"\n",
906 (IV)((char*)start_point - strbeg),
907 (IV)((char*)end_point - strbeg),
908 (IV)(check_at ? check_at - strbeg : -1)
911 /* Update the count-of-usability, remove useless subpatterns,
915 RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
916 SvPVX_const(check), RE_SV_DUMPLEN(check), 30);
917 PerlIO_printf(Perl_debug_log, " %s %s substr %s%s%s",
918 (check_at ? "Found" : "Did not find"),
919 (check == (utf8_target ? prog->anchored_utf8 : prog->anchored_substr)
920 ? "anchored" : "floating"),
923 (check_at ? " at offset " : "...\n") );
928 /* set rx_origin to the minimum position where the regex could start
929 * matching, given the constraint of the just-matched check substring.
930 * But don't set it lower than previously.
933 if (check_at - rx_origin > prog->check_offset_max)
934 rx_origin = HOP3c(check_at, -prog->check_offset_max, rx_origin);
935 /* Finish the diagnostic message */
936 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
937 "%ld (rx_origin now %"IVdf")...\n",
938 (long)(check_at - strbeg),
939 (IV)(rx_origin - strbeg)
944 /* now look for the 'other' substring if defined */
946 if (utf8_target ? prog->substrs->data[other_ix].utf8_substr
947 : prog->substrs->data[other_ix].substr)
949 /* Take into account the "other" substring. */
953 struct reg_substr_datum *other;
956 other = &prog->substrs->data[other_ix];
958 /* if "other" is anchored:
959 * we've previously found a floating substr starting at check_at.
960 * This means that the regex origin must lie somewhere
961 * between min (rx_origin): HOP3(check_at, -check_offset_max)
962 * and max: HOP3(check_at, -check_offset_min)
963 * (except that min will be >= strpos)
964 * So the fixed substr must lie somewhere between
965 * HOP3(min, anchored_offset)
966 * HOP3(max, anchored_offset) + SvCUR(substr)
969 /* if "other" is floating
970 * Calculate last1, the absolute latest point where the
971 * floating substr could start in the string, ignoring any
972 * constraints from the earlier fixed match. It is calculated
975 * strend - prog->minlen (in chars) is the absolute latest
976 * position within the string where the origin of the regex
977 * could appear. The latest start point for the floating
978 * substr is float_min_offset(*) on from the start of the
979 * regex. last1 simply combines thee two offsets.
981 * (*) You might think the latest start point should be
982 * float_max_offset from the regex origin, and technically
983 * you'd be correct. However, consider
985 * Here, float min, max are 3,5 and minlen is 7.
986 * This can match either
990 * In the first case, the regex matches minlen chars; in the
991 * second, minlen+1, in the third, minlen+2.
992 * In the first case, the floating offset is 3 (which equals
993 * float_min), in the second, 4, and in the third, 5 (which
994 * equals float_max). In all cases, the floating string bcd
995 * can never start more than 4 chars from the end of the
996 * string, which equals minlen - float_min. As the substring
997 * starts to match more than float_min from the start of the
998 * regex, it makes the regex match more than minlen chars,
999 * and the two cancel each other out. So we can always use
1000 * float_min - minlen, rather than float_max - minlen for the
1001 * latest position in the string.
1003 * Note that -minlen + float_min_offset is equivalent (AFAIKT)
1004 * to CHR_SVLEN(must) - !!SvTAIL(must) + prog->float_end_shift
1007 assert(prog->minlen >= other->min_offset);
1008 last1 = HOP3c(strend,
1009 other->min_offset - prog->minlen, strbeg);
1011 if (other_ix) {/* i.e. if (other-is-float) */
1012 /* last is the latest point where the floating substr could
1013 * start, *given* any constraints from the earlier fixed
1014 * match. This constraint is that the floating string starts
1015 * <= float_max_offset chars from the regex origin (rx_origin).
1016 * If this value is less than last1, use it instead.
1018 assert(rx_origin <= last1);
1020 /* this condition handles the offset==infinity case, and
1021 * is a short-cut otherwise. Although it's comparing a
1022 * byte offset to a char length, it does so in a safe way,
1023 * since 1 char always occupies 1 or more bytes,
1024 * so if a string range is (last1 - rx_origin) bytes,
1025 * it will be less than or equal to (last1 - rx_origin)
1026 * chars; meaning it errs towards doing the accurate HOP3
1027 * rather than just using last1 as a short-cut */
1028 (last1 - rx_origin) < other->max_offset
1030 : (char*)HOP3lim(rx_origin, other->max_offset, last1);
1033 assert(strpos + start_shift <= check_at);
1034 last = HOP4c(check_at, other->min_offset - start_shift,
1038 s = HOP3c(rx_origin, other->min_offset, strend);
1039 if (s < other_last) /* These positions already checked */
1042 must = utf8_target ? other->utf8_substr : other->substr;
1043 assert(SvPOK(must));
1046 char *to = last + SvCUR(must) - (SvTAIL(must)!=0);
1050 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1051 " skipping 'other' fbm scan: %"IVdf" > %"IVdf"\n",
1052 (IV)(from - strbeg),
1058 (unsigned char*)from,
1061 multiline ? FBMrf_MULTILINE : 0
1063 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1064 " doing 'other' fbm scan, [%"IVdf"..%"IVdf"] gave %"IVdf"\n",
1065 (IV)(from - strbeg),
1067 (IV)(s ? s - strbeg : -1)
1073 RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
1074 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
1075 PerlIO_printf(Perl_debug_log, " %s %s substr %s%s",
1076 s ? "Found" : "Contradicts",
1077 other_ix ? "floating" : "anchored",
1078 quoted, RE_SV_TAIL(must));
1083 /* last1 is latest possible substr location. If we didn't
1084 * find it before there, we never will */
1085 if (last >= last1) {
1086 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1087 "; giving up...\n"));
1091 /* try to find the check substr again at a later
1092 * position. Maybe next time we'll find the "other" substr
1094 other_last = HOP3c(last, 1, strend) /* highest failure */;
1096 other_ix /* i.e. if other-is-float */
1097 ? HOP3c(rx_origin, 1, strend)
1098 : HOP4c(last, 1 - other->min_offset, strbeg, strend);
1099 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1100 "; about to retry %s at offset %ld (rx_origin now %"IVdf")...\n",
1101 (other_ix ? "floating" : "anchored"),
1102 (long)(HOP3c(check_at, 1, strend) - strbeg),
1103 (IV)(rx_origin - strbeg)
1108 if (other_ix) { /* if (other-is-float) */
1109 /* other_last is set to s, not s+1, since its possible for
1110 * a floating substr to fail first time, then succeed
1111 * second time at the same floating position; e.g.:
1112 * "-AB--AABZ" =~ /\wAB\d*Z/
1113 * The first time round, anchored and float match at
1114 * "-(AB)--AAB(Z)" then fail on the initial \w character
1115 * class. Second time round, they match at "-AB--A(AB)(Z)".
1120 rx_origin = HOP3c(s, -other->min_offset, strbeg);
1121 other_last = HOP3c(s, 1, strend);
1123 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1124 " at offset %ld (rx_origin now %"IVdf")...\n",
1126 (IV)(rx_origin - strbeg)
1132 DEBUG_OPTIMISE_MORE_r(
1133 PerlIO_printf(Perl_debug_log,
1134 " Check-only match: offset min:%"IVdf" max:%"IVdf
1135 " check_at:%"IVdf" rx_origin:%"IVdf" rx_origin-check_at:%"IVdf
1136 " strend:%"IVdf"\n",
1137 (IV)prog->check_offset_min,
1138 (IV)prog->check_offset_max,
1139 (IV)(check_at-strbeg),
1140 (IV)(rx_origin-strbeg),
1141 (IV)(rx_origin-check_at),
1147 postprocess_substr_matches:
1149 /* handle the extra constraint of /^.../m if present */
1151 if (ml_anch && rx_origin != strbeg && rx_origin[-1] != '\n') {
1154 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1155 " looking for /^/m anchor"));
1157 /* we have failed the constraint of a \n before rx_origin.
1158 * Find the next \n, if any, even if it's beyond the current
1159 * anchored and/or floating substrings. Whether we should be
1160 * scanning ahead for the next \n or the next substr is debatable.
1161 * On the one hand you'd expect rare substrings to appear less
1162 * often than \n's. On the other hand, searching for \n means
1163 * we're effectively flipping between check_substr and "\n" on each
1164 * iteration as the current "rarest" string candidate, which
1165 * means for example that we'll quickly reject the whole string if
1166 * hasn't got a \n, rather than trying every substr position
1170 s = HOP3c(strend, - prog->minlen, strpos);
1171 if (s <= rx_origin ||
1172 ! ( rx_origin = (char *)memchr(rx_origin, '\n', s - rx_origin)))
1174 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1175 " Did not find /%s^%s/m...\n",
1176 PL_colors[0], PL_colors[1]));
1180 /* earliest possible origin is 1 char after the \n.
1181 * (since *rx_origin == '\n', it's safe to ++ here rather than
1182 * HOP(rx_origin, 1)) */
1185 if (prog->substrs->check_ix == 0 /* check is anchored */
1186 || rx_origin >= HOP3c(check_at, - prog->check_offset_min, strpos))
1188 /* Position contradicts check-string; either because
1189 * check was anchored (and thus has no wiggle room),
1190 * or check was float and rx_origin is above the float range */
1191 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1192 " Found /%s^%s/m, about to restart lookup for check-string with rx_origin %ld...\n",
1193 PL_colors[0], PL_colors[1], (long)(rx_origin - strbeg)));
1197 /* if we get here, the check substr must have been float,
1198 * is in range, and we may or may not have had an anchored
1199 * "other" substr which still contradicts */
1200 assert(prog->substrs->check_ix); /* check is float */
1202 if (utf8_target ? prog->anchored_utf8 : prog->anchored_substr) {
1203 /* whoops, the anchored "other" substr exists, so we still
1204 * contradict. On the other hand, the float "check" substr
1205 * didn't contradict, so just retry the anchored "other"
1207 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1208 " Found /%s^%s/m, rescanning for anchored from offset %"IVdf" (rx_origin now %"IVdf")...\n",
1209 PL_colors[0], PL_colors[1],
1210 (IV)(rx_origin - strbeg + prog->anchored_offset),
1211 (IV)(rx_origin - strbeg)
1213 goto do_other_substr;
1216 /* success: we don't contradict the found floating substring
1217 * (and there's no anchored substr). */
1218 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1219 " Found /%s^%s/m with rx_origin %ld...\n",
1220 PL_colors[0], PL_colors[1], (long)(rx_origin - strbeg)));
1223 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1224 " (multiline anchor test skipped)\n"));
1230 /* if we have a starting character class, then test that extra constraint.
1231 * (trie stclasses are too expensive to use here, we are better off to
1232 * leave it to regmatch itself) */
1234 if (progi->regstclass && PL_regkind[OP(progi->regstclass)]!=TRIE) {
1235 const U8* const str = (U8*)STRING(progi->regstclass);
1237 /* XXX this value could be pre-computed */
1238 const int cl_l = (PL_regkind[OP(progi->regstclass)] == EXACT
1239 ? (reginfo->is_utf8_pat
1240 ? utf8_distance(str + STR_LEN(progi->regstclass), str)
1241 : STR_LEN(progi->regstclass))
1245 /* latest pos that a matching float substr constrains rx start to */
1246 char *rx_max_float = NULL;
1248 /* if the current rx_origin is anchored, either by satisfying an
1249 * anchored substring constraint, or a /^.../m constraint, then we
1250 * can reject the current origin if the start class isn't found
1251 * at the current position. If we have a float-only match, then
1252 * rx_origin is constrained to a range; so look for the start class
1253 * in that range. if neither, then look for the start class in the
1254 * whole rest of the string */
1256 /* XXX DAPM it's not clear what the minlen test is for, and why
1257 * it's not used in the floating case. Nothing in the test suite
1258 * causes minlen == 0 here. See <20140313134639.GS12844@iabyn.com>.
1259 * Here are some old comments, which may or may not be correct:
1261 * minlen == 0 is possible if regstclass is \b or \B,
1262 * and the fixed substr is ''$.
1263 * Since minlen is already taken into account, rx_origin+1 is
1264 * before strend; accidentally, minlen >= 1 guaranties no false
1265 * positives at rx_origin + 1 even for \b or \B. But (minlen? 1 :
1266 * 0) below assumes that regstclass does not come from lookahead...
1267 * If regstclass takes bytelength more than 1: If charlength==1, OK.
1268 * This leaves EXACTF-ish only, which are dealt with in
1272 if (prog->anchored_substr || prog->anchored_utf8 || ml_anch)
1273 endpos= HOP3c(rx_origin, (prog->minlen ? cl_l : 0), strend);
1274 else if (prog->float_substr || prog->float_utf8) {
1275 rx_max_float = HOP3c(check_at, -start_shift, strbeg);
1276 endpos= HOP3c(rx_max_float, cl_l, strend);
1281 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1282 " looking for class: start_shift: %"IVdf" check_at: %"IVdf
1283 " rx_origin: %"IVdf" endpos: %"IVdf"\n",
1284 (IV)start_shift, (IV)(check_at - strbeg),
1285 (IV)(rx_origin - strbeg), (IV)(endpos - strbeg)));
1287 s = find_byclass(prog, progi->regstclass, rx_origin, endpos,
1290 if (endpos == strend) {
1291 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1292 " Could not match STCLASS...\n") );
1295 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1296 " This position contradicts STCLASS...\n") );
1297 if ((prog->intflags & PREGf_ANCH) && !ml_anch
1298 && !(prog->intflags & PREGf_IMPLICIT))
1301 /* Contradict one of substrings */
1302 if (prog->anchored_substr || prog->anchored_utf8) {
1303 if (prog->substrs->check_ix == 1) { /* check is float */
1304 /* Have both, check_string is floating */
1305 assert(rx_origin + start_shift <= check_at);
1306 if (rx_origin + start_shift != check_at) {
1307 /* not at latest position float substr could match:
1308 * Recheck anchored substring, but not floating.
1309 * The condition above is in bytes rather than
1310 * chars for efficiency. It's conservative, in
1311 * that it errs on the side of doing 'goto
1312 * do_other_substr'. In this case, at worst,
1313 * an extra anchored search may get done, but in
1314 * practice the extra fbm_instr() is likely to
1315 * get skipped anyway. */
1316 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1317 " about to retry anchored at offset %ld (rx_origin now %"IVdf")...\n",
1318 (long)(other_last - strbeg),
1319 (IV)(rx_origin - strbeg)
1321 goto do_other_substr;
1329 /* In the presence of ml_anch, we might be able to
1330 * find another \n without breaking the current float
1333 /* strictly speaking this should be HOP3c(..., 1, ...),
1334 * but since we goto a block of code that's going to
1335 * search for the next \n if any, its safe here */
1337 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1338 " about to look for /%s^%s/m starting at rx_origin %ld...\n",
1339 PL_colors[0], PL_colors[1],
1340 (long)(rx_origin - strbeg)) );
1341 goto postprocess_substr_matches;
1344 /* strictly speaking this can never be true; but might
1345 * be if we ever allow intuit without substrings */
1346 if (!(utf8_target ? prog->float_utf8 : prog->float_substr))
1349 rx_origin = rx_max_float;
1352 /* at this point, any matching substrings have been
1353 * contradicted. Start again... */
1355 rx_origin = HOP3c(rx_origin, 1, strend);
1357 /* uses bytes rather than char calculations for efficiency.
1358 * It's conservative: it errs on the side of doing 'goto restart',
1359 * where there is code that does a proper char-based test */
1360 if (rx_origin + start_shift + end_shift > strend) {
1361 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1362 " Could not match STCLASS...\n") );
1365 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1366 " about to look for %s substr starting at offset %ld (rx_origin now %"IVdf")...\n",
1367 (prog->substrs->check_ix ? "floating" : "anchored"),
1368 (long)(rx_origin + start_shift - strbeg),
1369 (IV)(rx_origin - strbeg)
1376 if (rx_origin != s) {
1377 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1378 " By STCLASS: moving %ld --> %ld\n",
1379 (long)(rx_origin - strbeg), (long)(s - strbeg))
1383 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1384 " Does not contradict STCLASS...\n");
1389 /* Decide whether using the substrings helped */
1391 if (rx_origin != strpos) {
1392 /* Fixed substring is found far enough so that the match
1393 cannot start at strpos. */
1395 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " try at offset...\n"));
1396 ++BmUSEFUL(utf8_target ? prog->check_utf8 : prog->check_substr); /* hooray/5 */
1399 /* The found rx_origin position does not prohibit matching at
1400 * strpos, so calling intuit didn't gain us anything. Decrement
1401 * the BmUSEFUL() count on the check substring, and if we reach
1403 if (!(prog->intflags & PREGf_NAUGHTY)
1405 prog->check_utf8 /* Could be deleted already */
1406 && --BmUSEFUL(prog->check_utf8) < 0
1407 && (prog->check_utf8 == prog->float_utf8)
1409 prog->check_substr /* Could be deleted already */
1410 && --BmUSEFUL(prog->check_substr) < 0
1411 && (prog->check_substr == prog->float_substr)
1414 /* If flags & SOMETHING - do not do it many times on the same match */
1415 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " ... Disabling check substring...\n"));
1416 /* XXX Does the destruction order has to change with utf8_target? */
1417 SvREFCNT_dec(utf8_target ? prog->check_utf8 : prog->check_substr);
1418 SvREFCNT_dec(utf8_target ? prog->check_substr : prog->check_utf8);
1419 prog->check_substr = prog->check_utf8 = NULL; /* disable */
1420 prog->float_substr = prog->float_utf8 = NULL; /* clear */
1421 check = NULL; /* abort */
1422 /* XXXX This is a remnant of the old implementation. It
1423 looks wasteful, since now INTUIT can use many
1424 other heuristics. */
1425 prog->extflags &= ~RXf_USE_INTUIT;
1429 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1430 "Intuit: %sSuccessfully guessed:%s match at offset %ld\n",
1431 PL_colors[4], PL_colors[5], (long)(rx_origin - strbeg)) );
1435 fail_finish: /* Substring not found */
1436 if (prog->check_substr || prog->check_utf8) /* could be removed already */
1437 BmUSEFUL(utf8_target ? prog->check_utf8 : prog->check_substr) += 5; /* hooray */
1439 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n",
1440 PL_colors[4], PL_colors[5]));
1445 #define DECL_TRIE_TYPE(scan) \
1446 const enum { trie_plain, trie_utf8, trie_utf8_fold, trie_latin_utf8_fold, \
1447 trie_utf8_exactfa_fold, trie_latin_utf8_exactfa_fold, \
1448 trie_utf8l, trie_flu8 } \
1449 trie_type = ((scan->flags == EXACT) \
1450 ? (utf8_target ? trie_utf8 : trie_plain) \
1451 : (scan->flags == EXACTL) \
1452 ? (utf8_target ? trie_utf8l : trie_plain) \
1453 : (scan->flags == EXACTFA) \
1455 ? trie_utf8_exactfa_fold \
1456 : trie_latin_utf8_exactfa_fold) \
1457 : (scan->flags == EXACTFLU8 \
1461 : trie_latin_utf8_fold)))
1463 #define REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc, uscan, len, uvc, charid, foldlen, foldbuf, uniflags) \
1466 U8 flags = FOLD_FLAGS_FULL; \
1467 switch (trie_type) { \
1469 _CHECK_AND_WARN_PROBLEMATIC_LOCALE; \
1470 if (utf8_target && UTF8_IS_ABOVE_LATIN1(*uc)) { \
1471 _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(uc, uc + UTF8SKIP(uc)); \
1473 goto do_trie_utf8_fold; \
1474 case trie_utf8_exactfa_fold: \
1475 flags |= FOLD_FLAGS_NOMIX_ASCII; \
1477 case trie_utf8_fold: \
1478 do_trie_utf8_fold: \
1479 if ( foldlen>0 ) { \
1480 uvc = utf8n_to_uvchr( (const U8*) uscan, UTF8_MAXLEN, &len, uniflags ); \
1485 uvc = _to_utf8_fold_flags( (const U8*) uc, foldbuf, &foldlen, flags); \
1486 len = UTF8SKIP(uc); \
1487 skiplen = UVCHR_SKIP( uvc ); \
1488 foldlen -= skiplen; \
1489 uscan = foldbuf + skiplen; \
1492 case trie_latin_utf8_exactfa_fold: \
1493 flags |= FOLD_FLAGS_NOMIX_ASCII; \
1495 case trie_latin_utf8_fold: \
1496 if ( foldlen>0 ) { \
1497 uvc = utf8n_to_uvchr( (const U8*) uscan, UTF8_MAXLEN, &len, uniflags ); \
1503 uvc = _to_fold_latin1( (U8) *uc, foldbuf, &foldlen, flags); \
1504 skiplen = UVCHR_SKIP( uvc ); \
1505 foldlen -= skiplen; \
1506 uscan = foldbuf + skiplen; \
1510 _CHECK_AND_WARN_PROBLEMATIC_LOCALE; \
1511 if (utf8_target && UTF8_IS_ABOVE_LATIN1(*uc)) { \
1512 _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(uc, uc + UTF8SKIP(uc)); \
1516 uvc = utf8n_to_uvchr( (const U8*) uc, UTF8_MAXLEN, &len, uniflags ); \
1523 charid = trie->charmap[ uvc ]; \
1527 if (widecharmap) { \
1528 SV** const svpp = hv_fetch(widecharmap, \
1529 (char*)&uvc, sizeof(UV), 0); \
1531 charid = (U16)SvIV(*svpp); \
1536 #define DUMP_EXEC_POS(li,s,doutf8) \
1537 dump_exec_pos(li,s,(reginfo->strend),(reginfo->strbeg), \
1540 #define REXEC_FBC_EXACTISH_SCAN(COND) \
1544 && (ln == 1 || folder(s, pat_string, ln)) \
1545 && (reginfo->intuit || regtry(reginfo, &s)) )\
1551 #define REXEC_FBC_UTF8_SCAN(CODE) \
1553 while (s < strend) { \
1559 #define REXEC_FBC_SCAN(CODE) \
1561 while (s < strend) { \
1567 #define REXEC_FBC_UTF8_CLASS_SCAN(COND) \
1568 REXEC_FBC_UTF8_SCAN( /* Loops while (s < strend) */ \
1570 if (tmp && (reginfo->intuit || regtry(reginfo, &s))) \
1579 #define REXEC_FBC_CLASS_SCAN(COND) \
1580 REXEC_FBC_SCAN( /* Loops while (s < strend) */ \
1582 if (tmp && (reginfo->intuit || regtry(reginfo, &s))) \
1591 #define REXEC_FBC_CSCAN(CONDUTF8,COND) \
1592 if (utf8_target) { \
1593 REXEC_FBC_UTF8_CLASS_SCAN(CONDUTF8); \
1596 REXEC_FBC_CLASS_SCAN(COND); \
1599 /* The three macros below are slightly different versions of the same logic.
1601 * The first is for /a and /aa when the target string is UTF-8. This can only
1602 * match ascii, but it must advance based on UTF-8. The other two handle the
1603 * non-UTF-8 and the more generic UTF-8 cases. In all three, we are looking
1604 * for the boundary (or non-boundary) between a word and non-word character.
1605 * The utf8 and non-utf8 cases have the same logic, but the details must be
1606 * different. Find the "wordness" of the character just prior to this one, and
1607 * compare it with the wordness of this one. If they differ, we have a
1608 * boundary. At the beginning of the string, pretend that the previous
1609 * character was a new-line.
1611 * All these macros uncleanly have side-effects with each other and outside
1612 * variables. So far it's been too much trouble to clean-up
1614 * TEST_NON_UTF8 is the macro or function to call to test if its byte input is
1615 * a word character or not.
1616 * IF_SUCCESS is code to do if it finds that we are at a boundary between
1618 * IF_FAIL is code to do if we aren't at a boundary between word/non-word
1620 * Exactly one of the two IF_FOO parameters is a no-op, depending on whether we
1621 * are looking for a boundary or for a non-boundary. If we are looking for a
1622 * boundary, we want IF_FAIL to be the no-op, and for IF_SUCCESS to go out and
1623 * see if this tentative match actually works, and if so, to quit the loop
1624 * here. And vice-versa if we are looking for a non-boundary.
1626 * 'tmp' below in the next three macros in the REXEC_FBC_SCAN and
1627 * REXEC_FBC_UTF8_SCAN loops is a loop invariant, a bool giving the return of
1628 * TEST_NON_UTF8(s-1). To see this, note that that's what it is defined to be
1629 * at entry to the loop, and to get to the IF_FAIL branch, tmp must equal
1630 * TEST_NON_UTF8(s), and in the opposite branch, IF_SUCCESS, tmp is that
1631 * complement. But in that branch we complement tmp, meaning that at the
1632 * bottom of the loop tmp is always going to be equal to TEST_NON_UTF8(s),
1633 * which means at the top of the loop in the next iteration, it is
1634 * TEST_NON_UTF8(s-1) */
1635 #define FBC_UTF8_A(TEST_NON_UTF8, IF_SUCCESS, IF_FAIL) \
1636 tmp = (s != reginfo->strbeg) ? UCHARAT(s - 1) : '\n'; \
1637 tmp = TEST_NON_UTF8(tmp); \
1638 REXEC_FBC_UTF8_SCAN( /* advances s while s < strend */ \
1639 if (tmp == ! TEST_NON_UTF8((U8) *s)) { \
1641 IF_SUCCESS; /* Is a boundary if values for s-1 and s differ */ \
1648 /* Like FBC_UTF8_A, but TEST_UV is a macro which takes a UV as its input, and
1649 * TEST_UTF8 is a macro that for the same input code points returns identically
1650 * to TEST_UV, but takes a pointer to a UTF-8 encoded string instead */
1651 #define FBC_UTF8(TEST_UV, TEST_UTF8, IF_SUCCESS, IF_FAIL) \
1652 if (s == reginfo->strbeg) { \
1655 else { /* Back-up to the start of the previous character */ \
1656 U8 * const r = reghop3((U8*)s, -1, (U8*)reginfo->strbeg); \
1657 tmp = utf8n_to_uvchr(r, (U8*) reginfo->strend - r, \
1658 0, UTF8_ALLOW_DEFAULT); \
1660 tmp = TEST_UV(tmp); \
1661 LOAD_UTF8_CHARCLASS_ALNUM(); \
1662 REXEC_FBC_UTF8_SCAN( /* advances s while s < strend */ \
1663 if (tmp == ! (TEST_UTF8((U8 *) s))) { \
1672 /* Like the above two macros. UTF8_CODE is the complete code for handling
1673 * UTF-8. Common to the BOUND and NBOUND cases, set-up by the FBC_BOUND, etc
1675 #define FBC_BOUND_COMMON(UTF8_CODE, TEST_NON_UTF8, IF_SUCCESS, IF_FAIL) \
1676 if (utf8_target) { \
1679 else { /* Not utf8 */ \
1680 tmp = (s != reginfo->strbeg) ? UCHARAT(s - 1) : '\n'; \
1681 tmp = TEST_NON_UTF8(tmp); \
1682 REXEC_FBC_SCAN( /* advances s while s < strend */ \
1683 if (tmp == ! TEST_NON_UTF8((U8) *s)) { \
1692 /* Here, things have been set up by the previous code so that tmp is the \
1693 * return of TEST_NON_UTF(s-1) or TEST_UTF8(s-1) (depending on the \
1694 * utf8ness of the target). We also have to check if this matches against \
1695 * the EOS, which we treat as a \n (which is the same value in both UTF-8 \
1696 * or non-UTF8, so can use the non-utf8 test condition even for a UTF-8 \
1698 if (tmp == ! TEST_NON_UTF8('\n')) { \
1705 /* This is the macro to use when we want to see if something that looks like it
1706 * could match, actually does, and if so exits the loop */
1707 #define REXEC_FBC_TRYIT \
1708 if ((reginfo->intuit || regtry(reginfo, &s))) \
1711 /* The only difference between the BOUND and NBOUND cases is that
1712 * REXEC_FBC_TRYIT is called when matched in BOUND, and when non-matched in
1713 * NBOUND. This is accomplished by passing it as either the if or else clause,
1714 * with the other one being empty (PLACEHOLDER is defined as empty).
1716 * The TEST_FOO parameters are for operating on different forms of input, but
1717 * all should be ones that return identically for the same underlying code
1719 #define FBC_BOUND(TEST_NON_UTF8, TEST_UV, TEST_UTF8) \
1721 FBC_UTF8(TEST_UV, TEST_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER), \
1722 TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER)
1724 #define FBC_BOUND_A(TEST_NON_UTF8) \
1726 FBC_UTF8_A(TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER), \
1727 TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER)
1729 #define FBC_NBOUND(TEST_NON_UTF8, TEST_UV, TEST_UTF8) \
1731 FBC_UTF8(TEST_UV, TEST_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT), \
1732 TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT)
1734 #define FBC_NBOUND_A(TEST_NON_UTF8) \
1736 FBC_UTF8_A(TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT), \
1737 TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT)
1739 /* Takes a pointer to an inversion list, a pointer to its corresponding
1740 * inversion map, and a code point, and returns the code point's value
1741 * according to the two arrays. It assumes that all code points have a value.
1742 * This is used as the base macro for macros for particular properties */
1743 #define _generic_GET_BREAK_VAL_CP(invlist, invmap, cp) \
1744 invmap[_invlist_search(invlist, cp)]
1746 /* Same as above, but takes begin, end ptrs to a UTF-8 encoded string instead
1747 * of a code point, returning the value for the first code point in the string.
1748 * And it takes the particular macro name that finds the desired value given a
1749 * code point. Merely convert the UTF-8 to code point and call the cp macro */
1750 #define _generic_GET_BREAK_VAL_UTF8(cp_macro, pos, strend) \
1751 (__ASSERT_(pos < strend) \
1752 /* Note assumes is valid UTF-8 */ \
1753 (cp_macro(utf8_to_uvchr_buf((pos), (strend), NULL))))
1755 /* Returns the GCB value for the input code point */
1756 #define getGCB_VAL_CP(cp) \
1757 _generic_GET_BREAK_VAL_CP( \
1762 /* Returns the GCB value for the first code point in the UTF-8 encoded string
1763 * bounded by pos and strend */
1764 #define getGCB_VAL_UTF8(pos, strend) \
1765 _generic_GET_BREAK_VAL_UTF8(getGCB_VAL_CP, pos, strend)
1767 /* Returns the LB value for the input code point */
1768 #define getLB_VAL_CP(cp) \
1769 _generic_GET_BREAK_VAL_CP( \
1774 /* Returns the LB value for the first code point in the UTF-8 encoded string
1775 * bounded by pos and strend */
1776 #define getLB_VAL_UTF8(pos, strend) \
1777 _generic_GET_BREAK_VAL_UTF8(getLB_VAL_CP, pos, strend)
1780 /* Returns the SB value for the input code point */
1781 #define getSB_VAL_CP(cp) \
1782 _generic_GET_BREAK_VAL_CP( \
1787 /* Returns the SB value for the first code point in the UTF-8 encoded string
1788 * bounded by pos and strend */
1789 #define getSB_VAL_UTF8(pos, strend) \
1790 _generic_GET_BREAK_VAL_UTF8(getSB_VAL_CP, pos, strend)
1792 /* Returns the WB value for the input code point */
1793 #define getWB_VAL_CP(cp) \
1794 _generic_GET_BREAK_VAL_CP( \
1799 /* Returns the WB value for the first code point in the UTF-8 encoded string
1800 * bounded by pos and strend */
1801 #define getWB_VAL_UTF8(pos, strend) \
1802 _generic_GET_BREAK_VAL_UTF8(getWB_VAL_CP, pos, strend)
1804 /* We know what class REx starts with. Try to find this position... */
1805 /* if reginfo->intuit, its a dryrun */
1806 /* annoyingly all the vars in this routine have different names from their counterparts
1807 in regmatch. /grrr */
1809 S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s,
1810 const char *strend, regmatch_info *reginfo)
1813 const I32 doevery = (prog->intflags & PREGf_SKIP) == 0;
1814 char *pat_string; /* The pattern's exactish string */
1815 char *pat_end; /* ptr to end char of pat_string */
1816 re_fold_t folder; /* Function for computing non-utf8 folds */
1817 const U8 *fold_array; /* array for folding ords < 256 */
1823 I32 tmp = 1; /* Scratch variable? */
1824 const bool utf8_target = reginfo->is_utf8_target;
1825 UV utf8_fold_flags = 0;
1826 const bool is_utf8_pat = reginfo->is_utf8_pat;
1827 bool to_complement = FALSE; /* Invert the result? Taking the xor of this
1828 with a result inverts that result, as 0^1 =
1830 _char_class_number classnum;
1832 RXi_GET_DECL(prog,progi);
1834 PERL_ARGS_ASSERT_FIND_BYCLASS;
1836 /* We know what class it must start with. */
1839 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
1841 if (ANYOFL_UTF8_LOCALE_REQD(FLAGS(c)) && ! IN_UTF8_CTYPE_LOCALE) {
1842 Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE), utf8_locale_required);
1849 REXEC_FBC_UTF8_CLASS_SCAN(
1850 reginclass(prog, c, (U8*)s, (U8*) strend, utf8_target));
1853 REXEC_FBC_CLASS_SCAN(REGINCLASS(prog, c, (U8*)s));
1857 case EXACTFA_NO_TRIE: /* This node only generated for non-utf8 patterns */
1858 assert(! is_utf8_pat);
1861 if (is_utf8_pat || utf8_target) {
1862 utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII;
1863 goto do_exactf_utf8;
1865 fold_array = PL_fold_latin1; /* Latin1 folds are not affected by */
1866 folder = foldEQ_latin1; /* /a, except the sharp s one which */
1867 goto do_exactf_non_utf8; /* isn't dealt with by these */
1869 case EXACTF: /* This node only generated for non-utf8 patterns */
1870 assert(! is_utf8_pat);
1872 utf8_fold_flags = 0;
1873 goto do_exactf_utf8;
1875 fold_array = PL_fold;
1877 goto do_exactf_non_utf8;
1880 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
1881 if (is_utf8_pat || utf8_target || IN_UTF8_CTYPE_LOCALE) {
1882 utf8_fold_flags = FOLDEQ_LOCALE;
1883 goto do_exactf_utf8;
1885 fold_array = PL_fold_locale;
1886 folder = foldEQ_locale;
1887 goto do_exactf_non_utf8;
1891 utf8_fold_flags = FOLDEQ_S2_ALREADY_FOLDED;
1893 goto do_exactf_utf8;
1896 if (! utf8_target) { /* All code points in this node require
1897 UTF-8 to express. */
1900 utf8_fold_flags = FOLDEQ_LOCALE | FOLDEQ_S2_ALREADY_FOLDED
1901 | FOLDEQ_S2_FOLDS_SANE;
1902 goto do_exactf_utf8;
1905 if (is_utf8_pat || utf8_target) {
1906 utf8_fold_flags = is_utf8_pat ? FOLDEQ_S2_ALREADY_FOLDED : 0;
1907 goto do_exactf_utf8;
1910 /* Any 'ss' in the pattern should have been replaced by regcomp,
1911 * so we don't have to worry here about this single special case
1912 * in the Latin1 range */
1913 fold_array = PL_fold_latin1;
1914 folder = foldEQ_latin1;
1918 do_exactf_non_utf8: /* Neither pattern nor string are UTF8, and there
1919 are no glitches with fold-length differences
1920 between the target string and pattern */
1922 /* The idea in the non-utf8 EXACTF* cases is to first find the
1923 * first character of the EXACTF* node and then, if necessary,
1924 * case-insensitively compare the full text of the node. c1 is the
1925 * first character. c2 is its fold. This logic will not work for
1926 * Unicode semantics and the german sharp ss, which hence should
1927 * not be compiled into a node that gets here. */
1928 pat_string = STRING(c);
1929 ln = STR_LEN(c); /* length to match in octets/bytes */
1931 /* We know that we have to match at least 'ln' bytes (which is the
1932 * same as characters, since not utf8). If we have to match 3
1933 * characters, and there are only 2 availabe, we know without
1934 * trying that it will fail; so don't start a match past the
1935 * required minimum number from the far end */
1936 e = HOP3c(strend, -((SSize_t)ln), s);
1938 if (reginfo->intuit && e < s) {
1939 e = s; /* Due to minlen logic of intuit() */
1943 c2 = fold_array[c1];
1944 if (c1 == c2) { /* If char and fold are the same */
1945 REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1);
1948 REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1 || *(U8*)s == c2);
1956 /* If one of the operands is in utf8, we can't use the simpler folding
1957 * above, due to the fact that many different characters can have the
1958 * same fold, or portion of a fold, or different- length fold */
1959 pat_string = STRING(c);
1960 ln = STR_LEN(c); /* length to match in octets/bytes */
1961 pat_end = pat_string + ln;
1962 lnc = is_utf8_pat /* length to match in characters */
1963 ? utf8_length((U8 *) pat_string, (U8 *) pat_end)
1966 /* We have 'lnc' characters to match in the pattern, but because of
1967 * multi-character folding, each character in the target can match
1968 * up to 3 characters (Unicode guarantees it will never exceed
1969 * this) if it is utf8-encoded; and up to 2 if not (based on the
1970 * fact that the Latin 1 folds are already determined, and the
1971 * only multi-char fold in that range is the sharp-s folding to
1972 * 'ss'. Thus, a pattern character can match as little as 1/3 of a
1973 * string character. Adjust lnc accordingly, rounding up, so that
1974 * if we need to match at least 4+1/3 chars, that really is 5. */
1975 expansion = (utf8_target) ? UTF8_MAX_FOLD_CHAR_EXPAND : 2;
1976 lnc = (lnc + expansion - 1) / expansion;
1978 /* As in the non-UTF8 case, if we have to match 3 characters, and
1979 * only 2 are left, it's guaranteed to fail, so don't start a
1980 * match that would require us to go beyond the end of the string
1982 e = HOP3c(strend, -((SSize_t)lnc), s);
1984 if (reginfo->intuit && e < s) {
1985 e = s; /* Due to minlen logic of intuit() */
1988 /* XXX Note that we could recalculate e to stop the loop earlier,
1989 * as the worst case expansion above will rarely be met, and as we
1990 * go along we would usually find that e moves further to the left.
1991 * This would happen only after we reached the point in the loop
1992 * where if there were no expansion we should fail. Unclear if
1993 * worth the expense */
1996 char *my_strend= (char *)strend;
1997 if (foldEQ_utf8_flags(s, &my_strend, 0, utf8_target,
1998 pat_string, NULL, ln, is_utf8_pat, utf8_fold_flags)
1999 && (reginfo->intuit || regtry(reginfo, &s)) )
2003 s += (utf8_target) ? UTF8SKIP(s) : 1;
2009 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
2010 if (FLAGS(c) != TRADITIONAL_BOUND) {
2011 if (! IN_UTF8_CTYPE_LOCALE) {
2012 Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
2013 B_ON_NON_UTF8_LOCALE_IS_WRONG);
2018 FBC_BOUND(isWORDCHAR_LC, isWORDCHAR_LC_uvchr, isWORDCHAR_LC_utf8);
2022 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
2023 if (FLAGS(c) != TRADITIONAL_BOUND) {
2024 if (! IN_UTF8_CTYPE_LOCALE) {
2025 Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
2026 B_ON_NON_UTF8_LOCALE_IS_WRONG);
2031 FBC_NBOUND(isWORDCHAR_LC, isWORDCHAR_LC_uvchr, isWORDCHAR_LC_utf8);
2034 case BOUND: /* regcomp.c makes sure that this only has the traditional \b
2036 assert(FLAGS(c) == TRADITIONAL_BOUND);
2038 FBC_BOUND(isWORDCHAR, isWORDCHAR_uni, isWORDCHAR_utf8);
2041 case BOUNDA: /* regcomp.c makes sure that this only has the traditional \b
2043 assert(FLAGS(c) == TRADITIONAL_BOUND);
2045 FBC_BOUND_A(isWORDCHAR_A);
2048 case NBOUND: /* regcomp.c makes sure that this only has the traditional \b
2050 assert(FLAGS(c) == TRADITIONAL_BOUND);
2052 FBC_NBOUND(isWORDCHAR, isWORDCHAR_uni, isWORDCHAR_utf8);
2055 case NBOUNDA: /* regcomp.c makes sure that this only has the traditional \b
2057 assert(FLAGS(c) == TRADITIONAL_BOUND);
2059 FBC_NBOUND_A(isWORDCHAR_A);
2063 if ((bound_type) FLAGS(c) == TRADITIONAL_BOUND) {
2064 FBC_NBOUND(isWORDCHAR_L1, isWORDCHAR_uni, isWORDCHAR_utf8);
2075 switch((bound_type) FLAGS(c)) {
2076 case TRADITIONAL_BOUND:
2077 FBC_BOUND(isWORDCHAR_L1, isWORDCHAR_uni, isWORDCHAR_utf8);
2080 if (s == reginfo->strbeg) {
2081 if (reginfo->intuit || regtry(reginfo, &s))
2086 /* Didn't match. Try at the next position (if there is one) */
2087 s += (utf8_target) ? UTF8SKIP(s) : 1;
2088 if (UNLIKELY(s >= reginfo->strend)) {
2094 GCB_enum before = getGCB_VAL_UTF8(
2096 (U8*)(reginfo->strbeg)),
2097 (U8*) reginfo->strend);
2098 while (s < strend) {
2099 GCB_enum after = getGCB_VAL_UTF8((U8*) s,
2100 (U8*) reginfo->strend);
2101 if ( (to_complement ^ isGCB(before, after))
2102 && (reginfo->intuit || regtry(reginfo, &s)))
2110 else { /* Not utf8. Everything is a GCB except between CR and
2112 while (s < strend) {
2113 if ((to_complement ^ ( UCHARAT(s - 1) != '\r'
2114 || UCHARAT(s) != '\n'))
2115 && (reginfo->intuit || regtry(reginfo, &s)))
2123 /* And, since this is a bound, it can match after the final
2124 * character in the string */
2125 if ((reginfo->intuit || regtry(reginfo, &s))) {
2131 if (s == reginfo->strbeg) {
2132 if (reginfo->intuit || regtry(reginfo, &s)) {
2135 s += (utf8_target) ? UTF8SKIP(s) : 1;
2136 if (UNLIKELY(s >= reginfo->strend)) {
2142 LB_enum before = getLB_VAL_UTF8(reghop3((U8*)s,
2144 (U8*)(reginfo->strbeg)),
2145 (U8*) reginfo->strend);
2146 while (s < strend) {
2147 LB_enum after = getLB_VAL_UTF8((U8*) s, (U8*) reginfo->strend);
2148 if (to_complement ^ isLB(before,
2150 (U8*) reginfo->strbeg,
2152 (U8*) reginfo->strend,
2154 && (reginfo->intuit || regtry(reginfo, &s)))
2162 else { /* Not utf8. */
2163 LB_enum before = getLB_VAL_CP((U8) *(s -1));
2164 while (s < strend) {
2165 LB_enum after = getLB_VAL_CP((U8) *s);
2166 if (to_complement ^ isLB(before,
2168 (U8*) reginfo->strbeg,
2170 (U8*) reginfo->strend,
2172 && (reginfo->intuit || regtry(reginfo, &s)))
2181 if (reginfo->intuit || regtry(reginfo, &s)) {
2188 if (s == reginfo->strbeg) {
2189 if (reginfo->intuit || regtry(reginfo, &s)) {
2192 s += (utf8_target) ? UTF8SKIP(s) : 1;
2193 if (UNLIKELY(s >= reginfo->strend)) {
2199 SB_enum before = getSB_VAL_UTF8(reghop3((U8*)s,
2201 (U8*)(reginfo->strbeg)),
2202 (U8*) reginfo->strend);
2203 while (s < strend) {
2204 SB_enum after = getSB_VAL_UTF8((U8*) s,
2205 (U8*) reginfo->strend);
2206 if ((to_complement ^ isSB(before,
2208 (U8*) reginfo->strbeg,
2210 (U8*) reginfo->strend,
2212 && (reginfo->intuit || regtry(reginfo, &s)))
2220 else { /* Not utf8. */
2221 SB_enum before = getSB_VAL_CP((U8) *(s -1));
2222 while (s < strend) {
2223 SB_enum after = getSB_VAL_CP((U8) *s);
2224 if ((to_complement ^ isSB(before,
2226 (U8*) reginfo->strbeg,
2228 (U8*) reginfo->strend,
2230 && (reginfo->intuit || regtry(reginfo, &s)))
2239 /* Here are at the final position in the target string. The SB
2240 * value is always true here, so matches, depending on other
2242 if (reginfo->intuit || regtry(reginfo, &s)) {
2249 if (s == reginfo->strbeg) {
2250 if (reginfo->intuit || regtry(reginfo, &s)) {
2253 s += (utf8_target) ? UTF8SKIP(s) : 1;
2254 if (UNLIKELY(s >= reginfo->strend)) {
2260 /* We are at a boundary between char_sub_0 and char_sub_1.
2261 * We also keep track of the value for char_sub_-1 as we
2262 * loop through the line. Context may be needed to make a
2263 * determination, and if so, this can save having to
2265 WB_enum previous = WB_UNKNOWN;
2266 WB_enum before = getWB_VAL_UTF8(
2269 (U8*)(reginfo->strbeg)),
2270 (U8*) reginfo->strend);
2271 while (s < strend) {
2272 WB_enum after = getWB_VAL_UTF8((U8*) s,
2273 (U8*) reginfo->strend);
2274 if ((to_complement ^ isWB(previous,
2277 (U8*) reginfo->strbeg,
2279 (U8*) reginfo->strend,
2281 && (reginfo->intuit || regtry(reginfo, &s)))
2290 else { /* Not utf8. */
2291 WB_enum previous = WB_UNKNOWN;
2292 WB_enum before = getWB_VAL_CP((U8) *(s -1));
2293 while (s < strend) {
2294 WB_enum after = getWB_VAL_CP((U8) *s);
2295 if ((to_complement ^ isWB(previous,
2298 (U8*) reginfo->strbeg,
2300 (U8*) reginfo->strend,
2302 && (reginfo->intuit || regtry(reginfo, &s)))
2312 if (reginfo->intuit || regtry(reginfo, &s)) {
2319 REXEC_FBC_CSCAN(is_LNBREAK_utf8_safe(s, strend),
2320 is_LNBREAK_latin1_safe(s, strend)
2324 /* The argument to all the POSIX node types is the class number to pass to
2325 * _generic_isCC() to build a mask for searching in PL_charclass[] */
2332 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
2333 REXEC_FBC_CSCAN(to_complement ^ cBOOL(isFOO_utf8_lc(FLAGS(c), (U8 *) s)),
2334 to_complement ^ cBOOL(isFOO_lc(FLAGS(c), *s)));
2349 /* The complement of something that matches only ASCII matches all
2350 * non-ASCII, plus everything in ASCII that isn't in the class. */
2351 REXEC_FBC_UTF8_CLASS_SCAN(! isASCII_utf8(s)
2352 || ! _generic_isCC_A(*s, FLAGS(c)));
2361 /* Don't need to worry about utf8, as it can match only a single
2362 * byte invariant character. */
2363 REXEC_FBC_CLASS_SCAN(
2364 to_complement ^ cBOOL(_generic_isCC_A(*s, FLAGS(c))));
2372 if (! utf8_target) {
2373 REXEC_FBC_CLASS_SCAN(to_complement ^ cBOOL(_generic_isCC(*s,
2379 classnum = (_char_class_number) FLAGS(c);
2380 if (classnum < _FIRST_NON_SWASH_CC) {
2381 while (s < strend) {
2383 /* We avoid loading in the swash as long as possible, but
2384 * should we have to, we jump to a separate loop. This
2385 * extra 'if' statement is what keeps this code from being
2386 * just a call to REXEC_FBC_UTF8_CLASS_SCAN() */
2387 if (UTF8_IS_ABOVE_LATIN1(*s)) {
2388 goto found_above_latin1;
2390 if ((UTF8_IS_INVARIANT(*s)
2391 && to_complement ^ cBOOL(_generic_isCC((U8) *s,
2393 || (UTF8_IS_DOWNGRADEABLE_START(*s)
2394 && to_complement ^ cBOOL(
2395 _generic_isCC(EIGHT_BIT_UTF8_TO_NATIVE(*s,
2399 if (tmp && (reginfo->intuit || regtry(reginfo, &s)))
2411 else switch (classnum) { /* These classes are implemented as
2413 case _CC_ENUM_SPACE:
2414 REXEC_FBC_UTF8_CLASS_SCAN(
2415 to_complement ^ cBOOL(isSPACE_utf8(s)));
2418 case _CC_ENUM_BLANK:
2419 REXEC_FBC_UTF8_CLASS_SCAN(
2420 to_complement ^ cBOOL(isBLANK_utf8(s)));
2423 case _CC_ENUM_XDIGIT:
2424 REXEC_FBC_UTF8_CLASS_SCAN(
2425 to_complement ^ cBOOL(isXDIGIT_utf8(s)));
2428 case _CC_ENUM_VERTSPACE:
2429 REXEC_FBC_UTF8_CLASS_SCAN(
2430 to_complement ^ cBOOL(isVERTWS_utf8(s)));
2433 case _CC_ENUM_CNTRL:
2434 REXEC_FBC_UTF8_CLASS_SCAN(
2435 to_complement ^ cBOOL(isCNTRL_utf8(s)));
2439 Perl_croak(aTHX_ "panic: find_byclass() node %d='%s' has an unexpected character class '%d'", OP(c), PL_reg_name[OP(c)], classnum);
2440 NOT_REACHED; /* NOTREACHED */
2445 found_above_latin1: /* Here we have to load a swash to get the result
2446 for the current code point */
2447 if (! PL_utf8_swash_ptrs[classnum]) {
2448 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2449 PL_utf8_swash_ptrs[classnum] =
2450 _core_swash_init("utf8",
2453 PL_XPosix_ptrs[classnum], &flags);
2456 /* This is a copy of the loop above for swash classes, though using the
2457 * FBC macro instead of being expanded out. Since we've loaded the
2458 * swash, we don't have to check for that each time through the loop */
2459 REXEC_FBC_UTF8_CLASS_SCAN(
2460 to_complement ^ cBOOL(_generic_utf8(
2463 swash_fetch(PL_utf8_swash_ptrs[classnum],
2471 /* what trie are we using right now */
2472 reg_ac_data *aho = (reg_ac_data*)progi->data->data[ ARG( c ) ];
2473 reg_trie_data *trie = (reg_trie_data*)progi->data->data[ aho->trie ];
2474 HV *widecharmap = MUTABLE_HV(progi->data->data[ aho->trie + 1 ]);
2476 const char *last_start = strend - trie->minlen;
2478 const char *real_start = s;
2480 STRLEN maxlen = trie->maxlen;
2482 U8 **points; /* map of where we were in the input string
2483 when reading a given char. For ASCII this
2484 is unnecessary overhead as the relationship
2485 is always 1:1, but for Unicode, especially
2486 case folded Unicode this is not true. */
2487 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
2491 GET_RE_DEBUG_FLAGS_DECL;
2493 /* We can't just allocate points here. We need to wrap it in
2494 * an SV so it gets freed properly if there is a croak while
2495 * running the match */
2498 sv_points=newSV(maxlen * sizeof(U8 *));
2499 SvCUR_set(sv_points,
2500 maxlen * sizeof(U8 *));
2501 SvPOK_on(sv_points);
2502 sv_2mortal(sv_points);
2503 points=(U8**)SvPV_nolen(sv_points );
2504 if ( trie_type != trie_utf8_fold
2505 && (trie->bitmap || OP(c)==AHOCORASICKC) )
2508 bitmap=(U8*)trie->bitmap;
2510 bitmap=(U8*)ANYOF_BITMAP(c);
2512 /* this is the Aho-Corasick algorithm modified a touch
2513 to include special handling for long "unknown char" sequences.
2514 The basic idea being that we use AC as long as we are dealing
2515 with a possible matching char, when we encounter an unknown char
2516 (and we have not encountered an accepting state) we scan forward
2517 until we find a legal starting char.
2518 AC matching is basically that of trie matching, except that when
2519 we encounter a failing transition, we fall back to the current
2520 states "fail state", and try the current char again, a process
2521 we repeat until we reach the root state, state 1, or a legal
2522 transition. If we fail on the root state then we can either
2523 terminate if we have reached an accepting state previously, or
2524 restart the entire process from the beginning if we have not.
2527 while (s <= last_start) {
2528 const U32 uniflags = UTF8_ALLOW_DEFAULT;
2536 U8 *uscan = (U8*)NULL;
2537 U8 *leftmost = NULL;
2539 U32 accepted_word= 0;
2543 while ( state && uc <= (U8*)strend ) {
2545 U32 word = aho->states[ state ].wordnum;
2549 DEBUG_TRIE_EXECUTE_r(
2550 if ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
2551 dump_exec_pos( (char *)uc, c, strend, real_start,
2552 (char *)uc, utf8_target );
2553 PerlIO_printf( Perl_debug_log,
2554 " Scanning for legal start char...\n");
2558 while ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
2562 while ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
2568 if (uc >(U8*)last_start) break;
2572 U8 *lpos= points[ (pointpos - trie->wordinfo[word].len) % maxlen ];
2573 if (!leftmost || lpos < leftmost) {
2574 DEBUG_r(accepted_word=word);
2580 points[pointpos++ % maxlen]= uc;
2581 if (foldlen || uc < (U8*)strend) {
2582 REXEC_TRIE_READ_CHAR(trie_type, trie,
2584 uscan, len, uvc, charid, foldlen,
2586 DEBUG_TRIE_EXECUTE_r({
2587 dump_exec_pos( (char *)uc, c, strend,
2588 real_start, s, utf8_target);
2589 PerlIO_printf(Perl_debug_log,
2590 " Charid:%3u CP:%4"UVxf" ",
2602 word = aho->states[ state ].wordnum;
2604 base = aho->states[ state ].trans.base;
2606 DEBUG_TRIE_EXECUTE_r({
2608 dump_exec_pos( (char *)uc, c, strend, real_start,
2610 PerlIO_printf( Perl_debug_log,
2611 "%sState: %4"UVxf", word=%"UVxf,
2612 failed ? " Fail transition to " : "",
2613 (UV)state, (UV)word);
2619 ( ((offset = base + charid
2620 - 1 - trie->uniquecharcount)) >= 0)
2621 && ((U32)offset < trie->lasttrans)
2622 && trie->trans[offset].check == state
2623 && (tmp=trie->trans[offset].next))
2625 DEBUG_TRIE_EXECUTE_r(
2626 PerlIO_printf( Perl_debug_log," - legal\n"));
2631 DEBUG_TRIE_EXECUTE_r(
2632 PerlIO_printf( Perl_debug_log," - fail\n"));
2634 state = aho->fail[state];
2638 /* we must be accepting here */
2639 DEBUG_TRIE_EXECUTE_r(
2640 PerlIO_printf( Perl_debug_log," - accepting\n"));
2649 if (!state) state = 1;
2652 if ( aho->states[ state ].wordnum ) {
2653 U8 *lpos = points[ (pointpos - trie->wordinfo[aho->states[ state ].wordnum].len) % maxlen ];
2654 if (!leftmost || lpos < leftmost) {
2655 DEBUG_r(accepted_word=aho->states[ state ].wordnum);
2660 s = (char*)leftmost;
2661 DEBUG_TRIE_EXECUTE_r({
2663 Perl_debug_log,"Matches word #%"UVxf" at position %"IVdf". Trying full pattern...\n",
2664 (UV)accepted_word, (IV)(s - real_start)
2667 if (reginfo->intuit || regtry(reginfo, &s)) {
2673 DEBUG_TRIE_EXECUTE_r({
2674 PerlIO_printf( Perl_debug_log,"Pattern failed. Looking for new start point...\n");
2677 DEBUG_TRIE_EXECUTE_r(
2678 PerlIO_printf( Perl_debug_log,"No match.\n"));
2687 Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
2694 /* set RX_SAVED_COPY, RX_SUBBEG etc.
2695 * flags have same meanings as with regexec_flags() */
2698 S_reg_set_capture_string(pTHX_ REGEXP * const rx,
2705 struct regexp *const prog = ReANY(rx);
2707 if (flags & REXEC_COPY_STR) {
2711 PerlIO_printf(Perl_debug_log,
2712 "Copy on write: regexp capture, type %d\n",
2715 /* Create a new COW SV to share the match string and store
2716 * in saved_copy, unless the current COW SV in saved_copy
2717 * is valid and suitable for our purpose */
2718 if (( prog->saved_copy
2719 && SvIsCOW(prog->saved_copy)
2720 && SvPOKp(prog->saved_copy)
2723 && SvPVX(sv) == SvPVX(prog->saved_copy)))
2725 /* just reuse saved_copy SV */
2726 if (RXp_MATCH_COPIED(prog)) {
2727 Safefree(prog->subbeg);
2728 RXp_MATCH_COPIED_off(prog);
2732 /* create new COW SV to share string */
2733 RX_MATCH_COPY_FREE(rx);
2734 prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
2736 prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
2737 assert (SvPOKp(prog->saved_copy));
2738 prog->sublen = strend - strbeg;
2739 prog->suboffset = 0;
2740 prog->subcoffset = 0;
2745 SSize_t max = strend - strbeg;
2748 if ( (flags & REXEC_COPY_SKIP_POST)
2749 && !(prog->extflags & RXf_PMf_KEEPCOPY) /* //p */
2750 && !(PL_sawampersand & SAWAMPERSAND_RIGHT)
2751 ) { /* don't copy $' part of string */
2754 /* calculate the right-most part of the string covered
2755 * by a capture. Due to lookahead, this may be to
2756 * the right of $&, so we have to scan all captures */
2757 while (n <= prog->lastparen) {
2758 if (prog->offs[n].end > max)
2759 max = prog->offs[n].end;
2763 max = (PL_sawampersand & SAWAMPERSAND_LEFT)
2764 ? prog->offs[0].start
2766 assert(max >= 0 && max <= strend - strbeg);
2769 if ( (flags & REXEC_COPY_SKIP_PRE)
2770 && !(prog->extflags & RXf_PMf_KEEPCOPY) /* //p */
2771 && !(PL_sawampersand & SAWAMPERSAND_LEFT)
2772 ) { /* don't copy $` part of string */
2775 /* calculate the left-most part of the string covered
2776 * by a capture. Due to lookbehind, this may be to
2777 * the left of $&, so we have to scan all captures */
2778 while (min && n <= prog->lastparen) {
2779 if ( prog->offs[n].start != -1
2780 && prog->offs[n].start < min)
2782 min = prog->offs[n].start;
2786 if ((PL_sawampersand & SAWAMPERSAND_RIGHT)
2787 && min > prog->offs[0].end
2789 min = prog->offs[0].end;
2793 assert(min >= 0 && min <= max && min <= strend - strbeg);
2796 if (RX_MATCH_COPIED(rx)) {
2797 if (sublen > prog->sublen)
2799 (char*)saferealloc(prog->subbeg, sublen+1);
2802 prog->subbeg = (char*)safemalloc(sublen+1);
2803 Copy(strbeg + min, prog->subbeg, sublen, char);
2804 prog->subbeg[sublen] = '\0';
2805 prog->suboffset = min;
2806 prog->sublen = sublen;
2807 RX_MATCH_COPIED_on(rx);
2809 prog->subcoffset = prog->suboffset;
2810 if (prog->suboffset && utf8_target) {
2811 /* Convert byte offset to chars.
2812 * XXX ideally should only compute this if @-/@+
2813 * has been seen, a la PL_sawampersand ??? */
2815 /* If there's a direct correspondence between the
2816 * string which we're matching and the original SV,
2817 * then we can use the utf8 len cache associated with
2818 * the SV. In particular, it means that under //g,
2819 * sv_pos_b2u() will use the previously cached
2820 * position to speed up working out the new length of
2821 * subcoffset, rather than counting from the start of
2822 * the string each time. This stops
2823 * $x = "\x{100}" x 1E6; 1 while $x =~ /(.)/g;
2824 * from going quadratic */
2825 if (SvPOKp(sv) && SvPVX(sv) == strbeg)
2826 prog->subcoffset = sv_pos_b2u_flags(sv, prog->subcoffset,
2827 SV_GMAGIC|SV_CONST_RETURN);
2829 prog->subcoffset = utf8_length((U8*)strbeg,
2830 (U8*)(strbeg+prog->suboffset));
2834 RX_MATCH_COPY_FREE(rx);
2835 prog->subbeg = strbeg;
2836 prog->suboffset = 0;
2837 prog->subcoffset = 0;
2838 prog->sublen = strend - strbeg;
2846 - regexec_flags - match a regexp against a string
2849 Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend,
2850 char *strbeg, SSize_t minend, SV *sv, void *data, U32 flags)
2851 /* stringarg: the point in the string at which to begin matching */
2852 /* strend: pointer to null at end of string */
2853 /* strbeg: real beginning of string */
2854 /* minend: end of match must be >= minend bytes after stringarg. */
2855 /* sv: SV being matched: only used for utf8 flag, pos() etc; string
2856 * itself is accessed via the pointers above */
2857 /* data: May be used for some additional optimizations.
2858 Currently unused. */
2859 /* flags: For optimizations. See REXEC_* in regexp.h */
2862 struct regexp *const prog = ReANY(rx);
2866 SSize_t minlen; /* must match at least this many chars */
2867 SSize_t dontbother = 0; /* how many characters not to try at end */
2868 const bool utf8_target = cBOOL(DO_UTF8(sv));
2870 RXi_GET_DECL(prog,progi);
2871 regmatch_info reginfo_buf; /* create some info to pass to regtry etc */
2872 regmatch_info *const reginfo = ®info_buf;
2873 regexp_paren_pair *swap = NULL;
2875 GET_RE_DEBUG_FLAGS_DECL;
2877 PERL_ARGS_ASSERT_REGEXEC_FLAGS;
2878 PERL_UNUSED_ARG(data);
2880 /* Be paranoid... */
2882 Perl_croak(aTHX_ "NULL regexp parameter");
2886 debug_start_match(rx, utf8_target, stringarg, strend,
2890 startpos = stringarg;
2892 /* set these early as they may be used by the HOP macros below */
2893 reginfo->strbeg = strbeg;
2894 reginfo->strend = strend;
2895 reginfo->is_utf8_target = cBOOL(utf8_target);
2897 if (prog->intflags & PREGf_GPOS_SEEN) {
2900 /* set reginfo->ganch, the position where \G can match */
2903 (flags & REXEC_IGNOREPOS)
2904 ? stringarg /* use start pos rather than pos() */
2905 : ((mg = mg_find_mglob(sv)) && mg->mg_len >= 0)
2906 /* Defined pos(): */
2907 ? strbeg + MgBYTEPOS(mg, sv, strbeg, strend-strbeg)
2908 : strbeg; /* pos() not defined; use start of string */
2910 DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
2911 "GPOS ganch set to strbeg[%"IVdf"]\n", (IV)(reginfo->ganch - strbeg)));
2913 /* in the presence of \G, we may need to start looking earlier in
2914 * the string than the suggested start point of stringarg:
2915 * if prog->gofs is set, then that's a known, fixed minimum
2918 * /ab|c\G/: gofs = 1
2919 * or if the minimum offset isn't known, then we have to go back
2920 * to the start of the string, e.g. /w+\G/
2923 if (prog->intflags & PREGf_ANCH_GPOS) {
2925 startpos = HOPBACKc(reginfo->ganch, prog->gofs);
2927 ((flags & REXEC_FAIL_ON_UNDERFLOW) && startpos < stringarg))
2929 DEBUG_r(PerlIO_printf(Perl_debug_log,
2930 "fail: ganch-gofs before earliest possible start\n"));
2935 startpos = reginfo->ganch;
2937 else if (prog->gofs) {
2938 startpos = HOPBACKc(startpos, prog->gofs);
2942 else if (prog->intflags & PREGf_GPOS_FLOAT)
2946 minlen = prog->minlen;
2947 if ((startpos + minlen) > strend || startpos < strbeg) {
2948 DEBUG_r(PerlIO_printf(Perl_debug_log,
2949 "Regex match can't succeed, so not even tried\n"));
2953 /* at the end of this function, we'll do a LEAVE_SCOPE(oldsave),
2954 * which will call destuctors to reset PL_regmatch_state, free higher
2955 * PL_regmatch_slabs, and clean up regmatch_info_aux and
2956 * regmatch_info_aux_eval */
2958 oldsave = PL_savestack_ix;
2962 if ((prog->extflags & RXf_USE_INTUIT)
2963 && !(flags & REXEC_CHECKED))
2965 s = re_intuit_start(rx, sv, strbeg, startpos, strend,
2970 if (prog->extflags & RXf_CHECK_ALL) {
2971 /* we can match based purely on the result of INTUIT.
2972 * Set up captures etc just for $& and $-[0]
2973 * (an intuit-only match wont have $1,$2,..) */
2974 assert(!prog->nparens);
2976 /* s/// doesn't like it if $& is earlier than where we asked it to
2977 * start searching (which can happen on something like /.\G/) */
2978 if ( (flags & REXEC_FAIL_ON_UNDERFLOW)
2981 /* this should only be possible under \G */
2982 assert(prog->intflags & PREGf_GPOS_SEEN);
2983 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
2984 "matched, but failing for REXEC_FAIL_ON_UNDERFLOW\n"));
2988 /* match via INTUIT shouldn't have any captures.
2989 * Let @-, @+, $^N know */
2990 prog->lastparen = prog->lastcloseparen = 0;
2991 RX_MATCH_UTF8_set(rx, utf8_target);
2992 prog->offs[0].start = s - strbeg;
2993 prog->offs[0].end = utf8_target
2994 ? (char*)utf8_hop((U8*)s, prog->minlenret) - strbeg
2995 : s - strbeg + prog->minlenret;
2996 if ( !(flags & REXEC_NOT_FIRST) )
2997 S_reg_set_capture_string(aTHX_ rx,
2999 sv, flags, utf8_target);
3005 multiline = prog->extflags & RXf_PMf_MULTILINE;
3007 if (strend - s < (minlen+(prog->check_offset_min<0?prog->check_offset_min:0))) {
3008 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
3009 "String too short [regexec_flags]...\n"));
3013 /* Check validity of program. */
3014 if (UCHARAT(progi->program) != REG_MAGIC) {
3015 Perl_croak(aTHX_ "corrupted regexp program");
3018 RX_MATCH_TAINTED_off(rx);
3019 RX_MATCH_UTF8_set(rx, utf8_target);
3021 reginfo->prog = rx; /* Yes, sorry that this is confusing. */
3022 reginfo->intuit = 0;
3023 reginfo->is_utf8_pat = cBOOL(RX_UTF8(rx));
3024 reginfo->warned = FALSE;
3026 reginfo->poscache_maxiter = 0; /* not yet started a countdown */
3027 /* see how far we have to get to not match where we matched before */
3028 reginfo->till = stringarg + minend;
3030 if (prog->extflags & RXf_EVAL_SEEN && SvPADTMP(sv)) {
3031 /* SAVEFREESV, not sv_mortalcopy, as this SV must last until after
3032 S_cleanup_regmatch_info_aux has executed (registered by
3033 SAVEDESTRUCTOR_X below). S_cleanup_regmatch_info_aux modifies
3034 magic belonging to this SV.
3035 Not newSVsv, either, as it does not COW.
3037 reginfo->sv = newSV(0);
3038 SvSetSV_nosteal(reginfo->sv, sv);
3039 SAVEFREESV(reginfo->sv);
3042 /* reserve next 2 or 3 slots in PL_regmatch_state:
3043 * slot N+0: may currently be in use: skip it
3044 * slot N+1: use for regmatch_info_aux struct
3045 * slot N+2: use for regmatch_info_aux_eval struct if we have (?{})'s
3046 * slot N+3: ready for use by regmatch()
3050 regmatch_state *old_regmatch_state;
3051 regmatch_slab *old_regmatch_slab;
3052 int i, max = (prog->extflags & RXf_EVAL_SEEN) ? 2 : 1;
3054 /* on first ever match, allocate first slab */
3055 if (!PL_regmatch_slab) {
3056 Newx(PL_regmatch_slab, 1, regmatch_slab);
3057 PL_regmatch_slab->prev = NULL;
3058 PL_regmatch_slab->next = NULL;
3059 PL_regmatch_state = SLAB_FIRST(PL_regmatch_slab);
3062 old_regmatch_state = PL_regmatch_state;
3063 old_regmatch_slab = PL_regmatch_slab;
3065 for (i=0; i <= max; i++) {
3067 reginfo->info_aux = &(PL_regmatch_state->u.info_aux);
3069 reginfo->info_aux_eval =
3070 reginfo->info_aux->info_aux_eval =
3071 &(PL_regmatch_state->u.info_aux_eval);
3073 if (++PL_regmatch_state > SLAB_LAST(PL_regmatch_slab))
3074 PL_regmatch_state = S_push_slab(aTHX);
3077 /* note initial PL_regmatch_state position; at end of match we'll
3078 * pop back to there and free any higher slabs */
3080 reginfo->info_aux->old_regmatch_state = old_regmatch_state;
3081 reginfo->info_aux->old_regmatch_slab = old_regmatch_slab;
3082 reginfo->info_aux->poscache = NULL;
3084 SAVEDESTRUCTOR_X(S_cleanup_regmatch_info_aux, reginfo->info_aux);
3086 if ((prog->extflags & RXf_EVAL_SEEN))
3087 S_setup_eval_state(aTHX_ reginfo);
3089 reginfo->info_aux_eval = reginfo->info_aux->info_aux_eval = NULL;
3092 /* If there is a "must appear" string, look for it. */
3094 if (PL_curpm && (PM_GETRE(PL_curpm) == rx)) {
3095 /* We have to be careful. If the previous successful match
3096 was from this regex we don't want a subsequent partially
3097 successful match to clobber the old results.
3098 So when we detect this possibility we add a swap buffer
3099 to the re, and switch the buffer each match. If we fail,
3100 we switch it back; otherwise we leave it swapped.
3103 /* do we need a save destructor here for eval dies? */
3104 Newxz(prog->offs, (prog->nparens + 1), regexp_paren_pair);
3105 DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
3106 "rex=0x%"UVxf" saving offs: orig=0x%"UVxf" new=0x%"UVxf"\n",
3113 /* Simplest case: anchored match need be tried only once, or with
3114 * MBOL, only at the beginning of each line.
3116 * Note that /.*.../ sets PREGf_IMPLICIT|MBOL, while /.*.../s sets
3117 * PREGf_IMPLICIT|SBOL. The idea is that with /.*.../s, if it doesn't
3118 * match at the start of the string then it won't match anywhere else
3119 * either; while with /.*.../, if it doesn't match at the beginning,
3120 * the earliest it could match is at the start of the next line */
3122 if (prog->intflags & (PREGf_ANCH & ~PREGf_ANCH_GPOS)) {
3125 if (regtry(reginfo, &s))
3128 if (!(prog->intflags & PREGf_ANCH_MBOL))
3131 /* didn't match at start, try at other newline positions */
3134 dontbother = minlen - 1;
3135 end = HOP3c(strend, -dontbother, strbeg) - 1;
3137 /* skip to next newline */
3139 while (s <= end) { /* note it could be possible to match at the end of the string */
3140 /* NB: newlines are the same in unicode as they are in latin */
3143 if (prog->check_substr || prog->check_utf8) {
3144 /* note that with PREGf_IMPLICIT, intuit can only fail
3145 * or return the start position, so it's of limited utility.
3146 * Nevertheless, I made the decision that the potential for
3147 * quick fail was still worth it - DAPM */
3148 s = re_intuit_start(rx, sv, strbeg, s, strend, flags, NULL);
3152 if (regtry(reginfo, &s))
3156 } /* end anchored search */
3158 if (prog->intflags & PREGf_ANCH_GPOS)
3160 /* PREGf_ANCH_GPOS should never be true if PREGf_GPOS_SEEN is not true */
3161 assert(prog->intflags & PREGf_GPOS_SEEN);
3162 /* For anchored \G, the only position it can match from is
3163 * (ganch-gofs); we already set startpos to this above; if intuit
3164 * moved us on from there, we can't possibly succeed */
3165 assert(startpos == HOPBACKc(reginfo->ganch, prog->gofs));
3166 if (s == startpos && regtry(reginfo, &s))
3171 /* Messy cases: unanchored match. */
3172 if ((prog->anchored_substr || prog->anchored_utf8) && prog->intflags & PREGf_SKIP) {
3173 /* we have /x+whatever/ */
3174 /* it must be a one character string (XXXX Except is_utf8_pat?) */
3180 if (! prog->anchored_utf8) {
3181 to_utf8_substr(prog);
3183 ch = SvPVX_const(prog->anchored_utf8)[0];
3186 DEBUG_EXECUTE_r( did_match = 1 );
3187 if (regtry(reginfo, &s)) goto got_it;
3189 while (s < strend && *s == ch)
3196 if (! prog->anchored_substr) {
3197 if (! to_byte_substr(prog)) {
3198 NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
3201 ch = SvPVX_const(prog->anchored_substr)[0];
3204 DEBUG_EXECUTE_r( did_match = 1 );
3205 if (regtry(reginfo, &s)) goto got_it;
3207 while (s < strend && *s == ch)
3212 DEBUG_EXECUTE_r(if (!did_match)
3213 PerlIO_printf(Perl_debug_log,
3214 "Did not find anchored character...\n")
3217 else if (prog->anchored_substr != NULL
3218 || prog->anchored_utf8 != NULL
3219 || ((prog->float_substr != NULL || prog->float_utf8 != NULL)
3220 && prog->float_max_offset < strend - s)) {
3225 char *last1; /* Last position checked before */
3229 if (prog->anchored_substr || prog->anchored_utf8) {
3231 if (! prog->anchored_utf8) {
3232 to_utf8_substr(prog);
3234 must = prog->anchored_utf8;
3237 if (! prog->anchored_substr) {
3238 if (! to_byte_substr(prog)) {
3239 NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
3242 must = prog->anchored_substr;
3244 back_max = back_min = prog->anchored_offset;
3247 if (! prog->float_utf8) {
3248 to_utf8_substr(prog);
3250 must = prog->float_utf8;
3253 if (! prog->float_substr) {
3254 if (! to_byte_substr(prog)) {
3255 NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
3258 must = prog->float_substr;
3260 back_max = prog->float_max_offset;
3261 back_min = prog->float_min_offset;
3267 last = HOP3c(strend, /* Cannot start after this */
3268 -(SSize_t)(CHR_SVLEN(must)
3269 - (SvTAIL(must) != 0) + back_min), strbeg);
3271 if (s > reginfo->strbeg)
3272 last1 = HOPc(s, -1);
3274 last1 = s - 1; /* bogus */
3276 /* XXXX check_substr already used to find "s", can optimize if
3277 check_substr==must. */
3279 strend = HOPc(strend, -dontbother);
3280 while ( (s <= last) &&
3281 (s = fbm_instr((unsigned char*)HOP4c(s, back_min, strbeg, strend),
3282 (unsigned char*)strend, must,
3283 multiline ? FBMrf_MULTILINE : 0)) ) {
3284 DEBUG_EXECUTE_r( did_match = 1 );
3285 if (HOPc(s, -back_max) > last1) {
3286 last1 = HOPc(s, -back_min);
3287 s = HOPc(s, -back_max);
3290 char * const t = (last1 >= reginfo->strbeg)
3291 ? HOPc(last1, 1) : last1 + 1;
3293 last1 = HOPc(s, -back_min);
3297 while (s <= last1) {
3298 if (regtry(reginfo, &s))
3301 s++; /* to break out of outer loop */
3308 while (s <= last1) {
3309 if (regtry(reginfo, &s))
3315 DEBUG_EXECUTE_r(if (!did_match) {
3316 RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
3317 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
3318 PerlIO_printf(Perl_debug_log, "Did not find %s substr %s%s...\n",
3319 ((must == prog->anchored_substr || must == prog->anchored_utf8)
3320 ? "anchored" : "floating"),
3321 quoted, RE_SV_TAIL(must));
3325 else if ( (c = progi->regstclass) ) {
3327 const OPCODE op = OP(progi->regstclass);
3328 /* don't bother with what can't match */
3329 if (PL_regkind[op] != EXACT && PL_regkind[op] != TRIE)
3330 strend = HOPc(strend, -(minlen - 1));
3333 SV * const prop = sv_newmortal();
3334 regprop(prog, prop, c, reginfo, NULL);
3336 RE_PV_QUOTED_DECL(quoted,utf8_target,PERL_DEBUG_PAD_ZERO(1),
3338 PerlIO_printf(Perl_debug_log,
3339 "Matching stclass %.*s against %s (%d bytes)\n",
3340 (int)SvCUR(prop), SvPVX_const(prop),
3341 quoted, (int)(strend - s));
3344 if (find_byclass(prog, c, s, strend, reginfo))
3346 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass... [regexec_flags]\n"));
3350 if (prog->float_substr != NULL || prog->float_utf8 != NULL) {
3358 if (! prog->float_utf8) {
3359 to_utf8_substr(prog);
3361 float_real = prog->float_utf8;
3364 if (! prog->float_substr) {
3365 if (! to_byte_substr(prog)) {
3366 NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
3369 float_real = prog->float_substr;
3372 little = SvPV_const(float_real, len);
3373 if (SvTAIL(float_real)) {
3374 /* This means that float_real contains an artificial \n on
3375 * the end due to the presence of something like this:
3376 * /foo$/ where we can match both "foo" and "foo\n" at the
3377 * end of the string. So we have to compare the end of the
3378 * string first against the float_real without the \n and
3379 * then against the full float_real with the string. We
3380 * have to watch out for cases where the string might be
3381 * smaller than the float_real or the float_real without
3383 char *checkpos= strend - len;
3385 PerlIO_printf(Perl_debug_log,
3386 "%sChecking for float_real.%s\n",
3387 PL_colors[4], PL_colors[5]));
3388 if (checkpos + 1 < strbeg) {
3389 /* can't match, even if we remove the trailing \n
3390 * string is too short to match */
3392 PerlIO_printf(Perl_debug_log,
3393 "%sString shorter than required trailing substring, cannot match.%s\n",
3394 PL_colors[4], PL_colors[5]));
3396 } else if (memEQ(checkpos + 1, little, len - 1)) {
3397 /* can match, the end of the string matches without the
3399 last = checkpos + 1;
3400 } else if (checkpos < strbeg) {
3401 /* cant match, string is too short when the "\n" is
3404 PerlIO_printf(Perl_debug_log,
3405 "%sString does not contain required trailing substring, cannot match.%s\n",
3406 PL_colors[4], PL_colors[5]));
3408 } else if (!multiline) {
3409 /* non multiline match, so compare with the "\n" at the
3410 * end of the string */
3411 if (memEQ(checkpos, little, len)) {
3415 PerlIO_printf(Perl_debug_log,
3416 "%sString does not contain required trailing substring, cannot match.%s\n",
3417 PL_colors[4], PL_colors[5]));
3421 /* multiline match, so we have to search for a place
3422 * where the full string is located */
3428 last = rninstr(s, strend, little, little + len);
3430 last = strend; /* matching "$" */
3433 /* at one point this block contained a comment which was
3434 * probably incorrect, which said that this was a "should not
3435 * happen" case. Even if it was true when it was written I am
3436 * pretty sure it is not anymore, so I have removed the comment
3437 * and replaced it with this one. Yves */
3439 PerlIO_printf(Perl_debug_log,
3440 "%sString does not contain required substring, cannot match.%s\n",
3441 PL_colors[4], PL_colors[5]
3445 dontbother = strend - last + prog->float_min_offset;
3447 if (minlen && (dontbother < minlen))
3448 dontbother = minlen - 1;
3449 strend -= dontbother; /* this one's always in bytes! */
3450 /* We don't know much -- general case. */
3453 if (regtry(reginfo, &s))
3462 if (regtry(reginfo, &s))
3464 } while (s++ < strend);
3472 /* s/// doesn't like it if $& is earlier than where we asked it to
3473 * start searching (which can happen on something like /.\G/) */
3474 if ( (flags & REXEC_FAIL_ON_UNDERFLOW)
3475 && (prog->offs[0].start < stringarg - strbeg))
3477 /* this should only be possible under \G */
3478 assert(prog->intflags & PREGf_GPOS_SEEN);
3479 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
3480 "matched, but failing for REXEC_FAIL_ON_UNDERFLOW\n"));
3486 PerlIO_printf(Perl_debug_log,
3487 "rex=0x%"UVxf" freeing offs: 0x%"UVxf"\n",
3494 /* clean up; this will trigger destructors that will free all slabs
3495 * above the current one, and cleanup the regmatch_info_aux
3496 * and regmatch_info_aux_eval sructs */
3498 LEAVE_SCOPE(oldsave);
3500 if (RXp_PAREN_NAMES(prog))
3501 (void)hv_iterinit(RXp_PAREN_NAMES(prog));
3503 /* make sure $`, $&, $', and $digit will work later */
3504 if ( !(flags & REXEC_NOT_FIRST) )
3505 S_reg_set_capture_string(aTHX_ rx,
3506 strbeg, reginfo->strend,
3507 sv, flags, utf8_target);
3512 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
3513 PL_colors[4], PL_colors[5]));
3515 /* clean up; this will trigger destructors that will free all slabs
3516 * above the current one, and cleanup the regmatch_info_aux
3517 * and regmatch_info_aux_eval sructs */
3519 LEAVE_SCOPE(oldsave);
3522 /* we failed :-( roll it back */
3523 DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
3524 "rex=0x%"UVxf" rolling back offs: freeing=0x%"UVxf" restoring=0x%"UVxf"\n",
3529 Safefree(prog->offs);
3536 /* Set which rex is pointed to by PL_reg_curpm, handling ref counting.
3537 * Do inc before dec, in case old and new rex are the same */
3538 #define SET_reg_curpm(Re2) \
3539 if (reginfo->info_aux_eval) { \
3540 (void)ReREFCNT_inc(Re2); \
3541 ReREFCNT_dec(PM_GETRE(PL_reg_curpm)); \
3542 PM_SETRE((PL_reg_curpm), (Re2)); \
3547 - regtry - try match at specific point
3549 STATIC bool /* 0 failure, 1 success */
3550 S_regtry(pTHX_ regmatch_info *reginfo, char **startposp)
3553 REGEXP *const rx = reginfo->prog;
3554 regexp *const prog = ReANY(rx);
3556 RXi_GET_DECL(prog,progi);
3557 GET_RE_DEBUG_FLAGS_DECL;
3559 PERL_ARGS_ASSERT_REGTRY;
3561 reginfo->cutpoint=NULL;
3563 prog->offs[0].start = *startposp - reginfo->strbeg;
3564 prog->lastparen = 0;
3565 prog->lastcloseparen = 0;
3567 /* XXXX What this code is doing here?!!! There should be no need
3568 to do this again and again, prog->lastparen should take care of
3571 /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
3572 * Actually, the code in regcppop() (which Ilya may be meaning by
3573 * prog->lastparen), is not needed at all by the test suite
3574 * (op/regexp, op/pat, op/split), but that code is needed otherwise
3575 * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
3576 * Meanwhile, this code *is* needed for the
3577 * above-mentioned test suite tests to succeed. The common theme
3578 * on those tests seems to be returning null fields from matches.
3579 * --jhi updated by dapm */
3581 if (prog->nparens) {
3582 regexp_paren_pair *pp = prog->offs;
3584 for (i = prog->nparens; i > (I32)prog->lastparen; i--) {
3592 result = regmatch(reginfo, *startposp, progi->program + 1);
3594 prog->offs[0].end = result;
3597 if (reginfo->cutpoint)
3598 *startposp= reginfo->cutpoint;
3599 REGCP_UNWIND(lastcp);
3604 #define sayYES goto yes
3605 #define sayNO goto no
3606 #define sayNO_SILENT goto no_silent
3608 /* we dont use STMT_START/END here because it leads to
3609 "unreachable code" warnings, which are bogus, but distracting. */
3610 #define CACHEsayNO \
3611 if (ST.cache_mask) \
3612 reginfo->info_aux->poscache[ST.cache_offset] |= ST.cache_mask; \
3615 /* this is used to determine how far from the left messages like
3616 'failed...' are printed. It should be set such that messages
3617 are inline with the regop output that created them.
3619 #define REPORT_CODE_OFF 32
3622 #define CHRTEST_UNINIT -1001 /* c1/c2 haven't been calculated yet */
3623 #define CHRTEST_VOID -1000 /* the c1/c2 "next char" test should be skipped */
3624 #define CHRTEST_NOT_A_CP_1 -999
3625 #define CHRTEST_NOT_A_CP_2 -998
3627 /* grab a new slab and return the first slot in it */
3629 STATIC regmatch_state *
3632 #if PERL_VERSION < 9 && !defined(PERL_CORE)
3635 regmatch_slab *s = PL_regmatch_slab->next;
3637 Newx(s, 1, regmatch_slab);
3638 s->prev = PL_regmatch_slab;
3640 PL_regmatch_slab->next = s;
3642 PL_regmatch_slab = s;
3643 return SLAB_FIRST(s);
3647 /* push a new state then goto it */
3649 #define PUSH_STATE_GOTO(state, node, input) \
3650 pushinput = input; \
3652 st->resume_state = state; \
3655 /* push a new state with success backtracking, then goto it */
3657 #define PUSH_YES_STATE_GOTO(state, node, input) \
3658 pushinput = input; \
3660 st->resume_state = state; \
3661 goto push_yes_state;
3668 regmatch() - main matching routine
3670 This is basically one big switch statement in a loop. We execute an op,
3671 set 'next' to point the next op, and continue. If we come to a point which
3672 we may need to backtrack to on failure such as (A|B|C), we push a
3673 backtrack state onto the backtrack stack. On failure, we pop the top
3674 state, and re-enter the loop at the state indicated. If there are no more
3675 states to pop, we return failure.
3677 Sometimes we also need to backtrack on success; for example /A+/, where
3678 after successfully matching one A, we need to go back and try to
3679 match another one; similarly for lookahead assertions: if the assertion
3680 completes successfully, we backtrack to the state just before the assertion
3681 and then carry on. In these cases, the pushed state is marked as
3682 'backtrack on success too'. This marking is in fact done by a chain of
3683 pointers, each pointing to the previous 'yes' state. On success, we pop to
3684 the nearest yes state, discarding any intermediate failure-only states.
3685 Sometimes a yes state is pushed just to force some cleanup code to be
3686 called at the end of a successful match or submatch; e.g. (??{$re}) uses
3687 it to free the inner regex.
3689 Note that failure backtracking rewinds the cursor position, while
3690 success backtracking leaves it alone.
3692 A pattern is complete when the END op is executed, while a subpattern
3693 such as (?=foo) is complete when the SUCCESS op is executed. Both of these
3694 ops trigger the "pop to last yes state if any, otherwise return true"
3697 A common convention in this function is to use A and B to refer to the two
3698 subpatterns (or to the first nodes thereof) in patterns like /A*B/: so A is
3699 the subpattern to be matched possibly multiple times, while B is the entire
3700 rest of the pattern. Variable and state names reflect this convention.
3702 The states in the main switch are the union of ops and failure/success of
3703 substates associated with with that op. For example, IFMATCH is the op
3704 that does lookahead assertions /(?=A)B/ and so the IFMATCH state means
3705 'execute IFMATCH'; while IFMATCH_A is a state saying that we have just
3706 successfully matched A and IFMATCH_A_fail is a state saying that we have
3707 just failed to match A. Resume states always come in pairs. The backtrack
3708 state we push is marked as 'IFMATCH_A', but when that is popped, we resume
3709 at IFMATCH_A or IFMATCH_A_fail, depending on whether we are backtracking
3710 on success or failure.
3712 The struct that holds a backtracking state is actually a big union, with
3713 one variant for each major type of op. The variable st points to the
3714 top-most backtrack struct. To make the code clearer, within each
3715 block of code we #define ST to alias the relevant union.
3717 Here's a concrete example of a (vastly oversimplified) IFMATCH
3723 #define ST st->u.ifmatch
3725 case IFMATCH: // we are executing the IFMATCH op, (?=A)B
3726 ST.foo = ...; // some state we wish to save
3728 // push a yes backtrack state with a resume value of
3729 // IFMATCH_A/IFMATCH_A_fail, then continue execution at the
3731 PUSH_YES_STATE_GOTO(IFMATCH_A, A, newinput);
3734 case IFMATCH_A: // we have successfully executed A; now continue with B
3736 bar = ST.foo; // do something with the preserved value
3739 case IFMATCH_A_fail: // A failed, so the assertion failed
3740 ...; // do some housekeeping, then ...
3741 sayNO; // propagate the failure
3748 For any old-timers reading this who are familiar with the old recursive
3749 approach, the code above is equivalent to:
3751 case IFMATCH: // we are executing the IFMATCH op, (?=A)B
3760 ...; // do some housekeeping, then ...
3761 sayNO; // propagate the failure
3764 The topmost backtrack state, pointed to by st, is usually free. If you
3765 want to claim it, populate any ST.foo fields in it with values you wish to
3766 save, then do one of
3768 PUSH_STATE_GOTO(resume_state, node, newinput);
3769 PUSH_YES_STATE_GOTO(resume_state, node, newinput);
3771 which sets that backtrack state's resume value to 'resume_state', pushes a
3772 new free entry to the top of the backtrack stack, then goes to 'node'.
3773 On backtracking, the free slot is popped, and the saved state becomes the
3774 new free state. An ST.foo field in this new top state can be temporarily
3775 accessed to retrieve values, but once the main loop is re-entered, it
3776 becomes available for reuse.
3778 Note that the depth of the backtrack stack constantly increases during the
3779 left-to-right execution of the pattern, rather than going up and down with
3780 the pattern nesting. For example the stack is at its maximum at Z at the
3781 end of the pattern, rather than at X in the following:
3783 /(((X)+)+)+....(Y)+....Z/
3785 The only exceptions to this are lookahead/behind assertions and the cut,
3786 (?>A), which pop all the backtrack states associated with A before
3789 Backtrack state structs are allocated in slabs of about 4K in size.
3790 PL_regmatch_state and st always point to the currently active state,
3791 and PL_regmatch_slab points to the slab currently containing
3792 PL_regmatch_state. The first time regmatch() is called, the first slab is
3793 allocated, and is never freed until interpreter destruction. When the slab
3794 is full, a new one is allocated and chained to the end. At exit from
3795 regmatch(), slabs allocated since entry are freed.
3800 #define DEBUG_STATE_pp(pp) \
3802 DUMP_EXEC_POS(locinput, scan, utf8_target); \
3803 PerlIO_printf(Perl_debug_log, \
3804 " %*s"pp" %s%s%s%s%s\n", \
3806 PL_reg_name[st->resume_state], \
3807 ((st==yes_state||st==mark_state) ? "[" : ""), \
3808 ((st==yes_state) ? "Y" : ""), \
3809 ((st==mark_state) ? "M" : ""), \
3810 ((st==yes_state||st==mark_state) ? "]" : "") \
3815 #define REG_NODE_NUM(x) ((x) ? (int)((x)-prog) : -1)
3820 S_debug_start_match(pTHX_ const REGEXP *prog, const bool utf8_target,
3821 const char *start, const char *end, const char *blurb)
3823 const bool utf8_pat = RX_UTF8(prog) ? 1 : 0;
3825 PERL_ARGS_ASSERT_DEBUG_START_MATCH;
3830 RE_PV_QUOTED_DECL(s0, utf8_pat, PERL_DEBUG_PAD_ZERO(0),
3831 RX_PRECOMP_const(prog), RX_PRELEN(prog), 60);
3833 RE_PV_QUOTED_DECL(s1, utf8_target, PERL_DEBUG_PAD_ZERO(1),
3834 start, end - start, 60);
3836 PerlIO_printf(Perl_debug_log,
3837 "%s%s REx%s %s against %s\n",
3838 PL_colors[4], blurb, PL_colors[5], s0, s1);
3840 if (utf8_target||utf8_pat)
3841 PerlIO_printf(Perl_debug_log, "UTF-8 %s%s%s...\n",
3842 utf8_pat ? "pattern" : "",
3843 utf8_pat && utf8_target ? " and " : "",
3844 utf8_target ? "string" : ""
3850 S_dump_exec_pos(pTHX_ const char *locinput,
3851 const regnode *scan,
3852 const char *loc_regeol,
3853 const char *loc_bostr,
3854 const char *loc_reg_starttry,
3855 const bool utf8_target)
3857 const int docolor = *PL_colors[0] || *PL_colors[2] || *PL_colors[4];
3858 const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
3859 int l = (loc_regeol - locinput) > taill ? taill : (loc_regeol - locinput);
3860 /* The part of the string before starttry has one color
3861 (pref0_len chars), between starttry and current
3862 position another one (pref_len - pref0_len chars),
3863 after the current position the third one.
3864 We assume that pref0_len <= pref_len, otherwise we
3865 decrease pref0_len. */
3866 int pref_len = (locinput - loc_bostr) > (5 + taill) - l
3867 ? (5 + taill) - l : locinput - loc_bostr;
3870 PERL_ARGS_ASSERT_DUMP_EXEC_POS;
3872 while (utf8_target && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
3874 pref0_len = pref_len - (locinput - loc_reg_starttry);
3875 if (l + pref_len < (5 + taill) && l < loc_regeol - locinput)
3876 l = ( loc_regeol - locinput > (5 + taill) - pref_len
3877 ? (5 + taill) - pref_len : loc_regeol - locinput);
3878 while (utf8_target && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
3882 if (pref0_len > pref_len)
3883 pref0_len = pref_len;
3885 const int is_uni = utf8_target ? 1 : 0;
3887 RE_PV_COLOR_DECL(s0,len0,is_uni,PERL_DEBUG_PAD(0),
3888 (locinput - pref_len),pref0_len, 60, 4, 5);
3890 RE_PV_COLOR_DECL(s1,len1,is_uni,PERL_DEBUG_PAD(1),
3891 (locinput - pref_len + pref0_len),
3892 pref_len - pref0_len, 60, 2, 3);
3894 RE_PV_COLOR_DECL(s2,len2,is_uni,PERL_DEBUG_PAD(2),
3895 locinput, loc_regeol - locinput, 10, 0, 1);
3897 const STRLEN tlen=len0+len1+len2;
3898 PerlIO_printf(Perl_debug_log,
3899 "%4"IVdf" <%.*s%.*s%s%.*s>%*s|",
3900 (IV)(locinput - loc_bostr),
3903 (docolor ? "" : "> <"),
3905 (int)(tlen > 19 ? 0 : 19 - tlen),
3912 /* reg_check_named_buff_matched()
3913 * Checks to see if a named buffer has matched. The data array of
3914 * buffer numbers corresponding to the buffer is expected to reside
3915 * in the regexp->data->data array in the slot stored in the ARG() of
3916 * node involved. Note that this routine doesn't actually care about the
3917 * name, that information is not preserved from compilation to execution.
3918 * Returns the index of the leftmost defined buffer with the given name
3919 * or 0 if non of the buffers matched.
3922 S_reg_check_named_buff_matched(const regexp *rex, const regnode *scan)
3925 RXi_GET_DECL(rex,rexi);
3926 SV *sv_dat= MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
3927 I32 *nums=(I32*)SvPVX(sv_dat);
3929 PERL_ARGS_ASSERT_REG_CHECK_NAMED_BUFF_MATCHED;
3931 for ( n=0; n<SvIVX(sv_dat); n++ ) {
3932 if ((I32)rex->lastparen >= nums[n] &&
3933 rex->offs[nums[n]].end != -1)
3943 S_setup_EXACTISH_ST_c1_c2(pTHX_ const regnode * const text_node, int *c1p,
3944 U8* c1_utf8, int *c2p, U8* c2_utf8, regmatch_info *reginfo)
3946 /* This function determines if there are one or two characters that match
3947 * the first character of the passed-in EXACTish node <text_node>, and if
3948 * so, returns them in the passed-in pointers.
3950 * If it determines that no possible character in the target string can
3951 * match, it returns FALSE; otherwise TRUE. (The FALSE situation occurs if
3952 * the first character in <text_node> requires UTF-8 to represent, and the
3953 * target string isn't in UTF-8.)
3955 * If there are more than two characters that could match the beginning of
3956 * <text_node>, or if more context is required to determine a match or not,
3957 * it sets both *<c1p> and *<c2p> to CHRTEST_VOID.
3959 * The motiviation behind this function is to allow the caller to set up
3960 * tight loops for matching. If <text_node> is of type EXACT, there is
3961 * only one possible character that can match its first character, and so
3962 * the situation is quite simple. But things get much more complicated if
3963 * folding is involved. It may be that the first character of an EXACTFish
3964 * node doesn't participate in any possible fold, e.g., punctuation, so it
3965 * can be matched only by itself. The vast majority of characters that are
3966 * in folds match just two things, their lower and upper-case equivalents.
3967 * But not all are like that; some have multiple possible matches, or match
3968 * sequences of more than one character. This function sorts all that out.
3970 * Consider the patterns A*B or A*?B where A and B are arbitrary. In a
3971 * loop of trying to match A*, we know we can't exit where the thing
3972 * following it isn't a B. And something can't be a B unless it is the
3973 * beginning of B. By putting a quick test for that beginning in a tight
3974 * loop, we can rule out things that can't possibly be B without having to
3975 * break out of the loop, thus avoiding work. Similarly, if A is a single
3976 * character, we can make a tight loop matching A*, using the outputs of
3979 * If the target string to match isn't in UTF-8, and there aren't
3980 * complications which require CHRTEST_VOID, *<c1p> and *<c2p> are set to
3981 * the one or two possible octets (which are characters in this situation)
3982 * that can match. In all cases, if there is only one character that can
3983 * match, *<c1p> and *<c2p> will be identical.
3985 * If the target string is in UTF-8, the buffers pointed to by <c1_utf8>
3986 * and <c2_utf8> will contain the one or two UTF-8 sequences of bytes that
3987 * can match the beginning of <text_node>. They should be declared with at
3988 * least length UTF8_MAXBYTES+1. (If the target string isn't in UTF-8, it is
3989 * undefined what these contain.) If one or both of the buffers are
3990 * invariant under UTF-8, *<c1p>, and *<c2p> will also be set to the
3991 * corresponding invariant. If variant, the corresponding *<c1p> and/or
3992 * *<c2p> will be set to a negative number(s) that shouldn't match any code
3993 * point (unless inappropriately coerced to unsigned). *<c1p> will equal
3994 * *<c2p> if and only if <c1_utf8> and <c2_utf8> are the same. */
3996 const bool utf8_target = reginfo->is_utf8_target;
3998 UV c1 = (UV)CHRTEST_NOT_A_CP_1;
3999 UV c2 = (UV)CHRTEST_NOT_A_CP_2;
4000 bool use_chrtest_void = FALSE;
4001 const bool is_utf8_pat = reginfo->is_utf8_pat;
4003 /* Used when we have both utf8 input and utf8 output, to avoid converting
4004 * to/from code points */
4005 bool utf8_has_been_setup = FALSE;
4009 U8 *pat = (U8*)STRING(text_node);
4010 U8 folded[UTF8_MAX_FOLD_CHAR_EXPAND * UTF8_MAXBYTES_CASE + 1] = { '\0' };
4012 if (OP(text_node) == EXACT || OP(text_node) == EXACTL) {
4014 /* In an exact node, only one thing can be matched, that first
4015 * character. If both the pat and the target are UTF-8, we can just
4016 * copy the input to the output, avoiding finding the code point of
4021 else if (utf8_target) {
4022 Copy(pat, c1_utf8, UTF8SKIP(pat), U8);
4023 Copy(pat, c2_utf8, UTF8SKIP(pat), U8);
4024 utf8_has_been_setup = TRUE;
4027 c2 = c1 = valid_utf8_to_uvchr(pat, NULL);
4030 else { /* an EXACTFish node */
4031 U8 *pat_end = pat + STR_LEN(text_node);
4033 /* An EXACTFL node has at least some characters unfolded, because what
4034 * they match is not known until now. So, now is the time to fold
4035 * the first few of them, as many as are needed to determine 'c1' and
4036 * 'c2' later in the routine. If the pattern isn't UTF-8, we only need
4037 * to fold if in a UTF-8 locale, and then only the Sharp S; everything
4038 * else is 1-1 and isn't assumed to be folded. In a UTF-8 pattern, we
4039 * need to fold as many characters as a single character can fold to,
4040 * so that later we can check if the first ones are such a multi-char
4041 * fold. But, in such a pattern only locale-problematic characters
4042 * aren't folded, so we can skip this completely if the first character
4043 * in the node isn't one of the tricky ones */
4044 if (OP(text_node) == EXACTFL) {
4046 if (! is_utf8_pat) {
4047 if (IN_UTF8_CTYPE_LOCALE && *pat == LATIN_SMALL_LETTER_SHARP_S)
4049 folded[0] = folded[1] = 's';
4051 pat_end = folded + 2;
4054 else if (is_PROBLEMATIC_LOCALE_FOLDEDS_START_utf8(pat)) {
4059 for (i = 0; i < UTF8_MAX_FOLD_CHAR_EXPAND && s < pat_end; i++) {
4061 *(d++) = (U8) toFOLD_LC(*s);
4066 _to_utf8_fold_flags(s,
4069 FOLD_FLAGS_FULL | FOLD_FLAGS_LOCALE);
4080 if ((is_utf8_pat && is_MULTI_CHAR_FOLD_utf8_safe(pat, pat_end))
4081 || (!is_utf8_pat && is_MULTI_CHAR_FOLD_latin1_safe(pat, pat_end)))
4083 /* Multi-character folds require more context to sort out. Also
4084 * PL_utf8_foldclosures used below doesn't handle them, so have to
4085 * be handled outside this routine */
4086 use_chrtest_void = TRUE;
4088 else { /* an EXACTFish node which doesn't begin with a multi-char fold */
4089 c1 = is_utf8_pat ? valid_utf8_to_uvchr(pat, NULL) : *pat;
4091 /* Load the folds hash, if not already done */
4093 if (! PL_utf8_foldclosures) {
4094 _load_PL_utf8_foldclosures();
4097 /* The fold closures data structure is a hash with the keys
4098 * being the UTF-8 of every character that is folded to, like
4099 * 'k', and the values each an array of all code points that
4100 * fold to its key. e.g. [ 'k', 'K', KELVIN_SIGN ].
4101 * Multi-character folds are not included */
4102 if ((! (listp = hv_fetch(PL_utf8_foldclosures,
4107 /* Not found in the hash, therefore there are no folds
4108 * containing it, so there is only a single character that
4112 else { /* Does participate in folds */
4113 AV* list = (AV*) *listp;
4114 if (av_tindex(list) != 1) {
4116 /* If there aren't exactly two folds to this, it is
4117 * outside the scope of this function */
4118 use_chrtest_void = TRUE;
4120 else { /* There are two. Get them */
4121 SV** c_p = av_fetch(list, 0, FALSE);
4123 Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
4127 c_p = av_fetch(list, 1, FALSE);
4129 Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
4133 /* Folds that cross the 255/256 boundary are forbidden
4134 * if EXACTFL (and isnt a UTF8 locale), or EXACTFA and
4135 * one is ASCIII. Since the pattern character is above
4136 * 255, and its only other match is below 256, the only
4137 * legal match will be to itself. We have thrown away
4138 * the original, so have to compute which is the one
4140 if ((c1 < 256) != (c2 < 256)) {
4141 if ((OP(text_node) == EXACTFL
4142 && ! IN_UTF8_CTYPE_LOCALE)
4143 || ((OP(text_node) == EXACTFA
4144 || OP(text_node) == EXACTFA_NO_TRIE)
4145 && (isASCII(c1) || isASCII(c2))))
4158 else /* Here, c1 is <= 255 */
4160 && HAS_NONLATIN1_FOLD_CLOSURE(c1)
4161 && ( ! (OP(text_node) == EXACTFL && ! IN_UTF8_CTYPE_LOCALE))
4162 && ((OP(text_node) != EXACTFA
4163 && OP(text_node) != EXACTFA_NO_TRIE)
4166 /* Here, there could be something above Latin1 in the target
4167 * which folds to this character in the pattern. All such
4168 * cases except LATIN SMALL LETTER Y WITH DIAERESIS have more
4169 * than two characters involved in their folds, so are outside
4170 * the scope of this function */
4171 if (UNLIKELY(c1 == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
4172 c2 = LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS;
4175 use_chrtest_void = TRUE;
4178 else { /* Here nothing above Latin1 can fold to the pattern
4180 switch (OP(text_node)) {
4182 case EXACTFL: /* /l rules */
4183 c2 = PL_fold_locale[c1];
4186 case EXACTF: /* This node only generated for non-utf8
4188 assert(! is_utf8_pat);
4189 if (! utf8_target) { /* /d rules */
4194 /* /u rules for all these. This happens to work for
4195 * EXACTFA as nothing in Latin1 folds to ASCII */
4196 case EXACTFA_NO_TRIE: /* This node only generated for
4197 non-utf8 patterns */
4198 assert(! is_utf8_pat);
4203 c2 = PL_fold_latin1[c1];
4207 Perl_croak(aTHX_ "panic: Unexpected op %u", OP(text_node));
4208 NOT_REACHED; /* NOTREACHED */
4214 /* Here have figured things out. Set up the returns */
4215 if (use_chrtest_void) {
4216 *c2p = *c1p = CHRTEST_VOID;
4218 else if (utf8_target) {
4219 if (! utf8_has_been_setup) { /* Don't have the utf8; must get it */
4220 uvchr_to_utf8(c1_utf8, c1);
4221 uvchr_to_utf8(c2_utf8, c2);
4224 /* Invariants are stored in both the utf8 and byte outputs; Use
4225 * negative numbers otherwise for the byte ones. Make sure that the
4226 * byte ones are the same iff the utf8 ones are the same */
4227 *c1p = (UTF8_IS_INVARIANT(*c1_utf8)) ? *c1_utf8 : CHRTEST_NOT_A_CP_1;
4228 *c2p = (UTF8_IS_INVARIANT(*c2_utf8))
4231 ? CHRTEST_NOT_A_CP_1
4232 : CHRTEST_NOT_A_CP_2;
4234 else if (c1 > 255) {
4235 if (c2 > 255) { /* both possibilities are above what a non-utf8 string
4240 *c1p = *c2p = c2; /* c2 is the only representable value */
4242 else { /* c1 is representable; see about c2 */
4244 *c2p = (c2 < 256) ? c2 : c1;
4250 PERL_STATIC_INLINE bool
4251 S_isGCB(const GCB_enum before, const GCB_enum after)
4253 /* returns a boolean indicating if there is a Grapheme Cluster Boundary
4254 * between the inputs. See http://www.unicode.org/reports/tr29/ */
4256 return GCB_table[before][after];
4259 /* Combining marks attach to most classes that precede them, but this defines
4260 * the exceptions (from TR14) */
4261 #define LB_CM_ATTACHES_TO(prev) ( ! ( prev == LB_EDGE \
4262 || prev == LB_Mandatory_Break \
4263 || prev == LB_Carriage_Return \
4264 || prev == LB_Line_Feed \
4265 || prev == LB_Next_Line \
4266 || prev == LB_Space \
4267 || prev == LB_ZWSpace))
4270 S_isLB(pTHX_ LB_enum before,
4272 const U8 * const strbeg,
4273 const U8 * const curpos,
4274 const U8 * const strend,
4275 const bool utf8_target)
4277 U8 * temp_pos = (U8 *) curpos;
4278 LB_enum prev = before;
4280 /* Is the boundary between 'before' and 'after' line-breakable?
4281 * Most of this is just a table lookup of a generated table from Unicode
4282 * rules. But some rules require context to decide, and so have to be
4283 * implemented in code */
4285 PERL_ARGS_ASSERT_ISLB;
4287 /* Rule numbers in the comments below are as of Unicode 8.0 */
4291 switch (LB_table[before][after]) {
4296 case LB_NOBREAK_EVEN_WITH_SP_BETWEEN:
4299 case LB_SP_foo + LB_BREAKABLE:
4300 case LB_SP_foo + LB_NOBREAK:
4301 case LB_SP_foo + LB_NOBREAK_EVEN_WITH_SP_BETWEEN:
4303 /* When we have something following a SP, we have to look at the
4304 * context in order to know what to do.
4306 * SP SP should not reach here because LB7: Do not break before
4307 * spaces. (For two spaces in a row there is nothing that
4308 * overrides that) */
4309 assert(after != LB_Space);
4311 /* Here we have a space followed by a non-space. Mostly this is a
4312 * case of LB18: "Break after spaces". But there are complications
4313 * as the handling of spaces is somewhat tricky. They are in a
4314 * number of rules, which have to be applied in priority order, but
4315 * something earlier in the string can cause a rule to be skipped
4316 * and a lower priority rule invoked. A prime example is LB7 which
4317 * says don't break before a space. But rule LB8 (lower priority)
4318 * says that the first break opportunity after a ZW is after any
4319 * span of spaces immediately after it. If a ZW comes before a SP
4320 * in the input, rule LB8 applies, and not LB7. Other such rules
4321 * involve combining marks which are rules 9 and 10, but they may
4322 * override higher priority rules if they come earlier in the
4323 * string. Since we're doing random access into the middle of the
4324 * string, we have to look for rules that should get applied based
4325 * on both string position and priority. Combining marks do not
4326 * attach to either ZW nor SP, so we don't have to consider them
4329 * To check for LB8, we have to find the first non-space character
4330 * before this span of spaces */
4332 prev = backup_one_LB(strbeg, &temp_pos, utf8_target);
4334 while (prev == LB_Space);
4336 /* LB8 Break before any character following a zero-width space,
4337 * even if one or more spaces intervene.
4339 * So if we have a ZW just before this span, and to get here this
4340 * is the final space in the span. */
4341 if (prev == LB_ZWSpace) {
4345 /* Here, not ZW SP+. There are several rules that have higher
4346 * priority than LB18 and can be resolved now, as they don't depend
4347 * on anything earlier in the string (except ZW, which we have
4348 * already handled). One of these rules is LB11 Do not break
4349 * before Word joiner, but we have specially encoded that in the
4350 * lookup table so it is caught by the single test below which
4351 * catches the other ones. */
4352 if (LB_table[LB_Space][after] - LB_SP_foo
4353 == LB_NOBREAK_EVEN_WITH_SP_BETWEEN)
4358 /* If we get here, we have to XXX consider combining marks. */
4359 if (prev == LB_Combining_Mark) {
4361 /* What happens with these depends on the character they
4364 prev = backup_one_LB(strbeg, &temp_pos, utf8_target);
4366 while (prev == LB_Combining_Mark);
4368 /* Most times these attach to and inherit the characteristics
4369 * of that character, but not always, and when not, they are to
4370 * be treated as AL by rule LB10. */
4371 if (! LB_CM_ATTACHES_TO(prev)) {
4372 prev = LB_Alphabetic;
4376 /* Here, we have the character preceding the span of spaces all set
4377 * up. We follow LB18: "Break after spaces" unless the table shows
4378 * that is overriden */
4379 return LB_table[prev][after] != LB_NOBREAK_EVEN_WITH_SP_BETWEEN;
4383 /* We don't know how to treat the CM except by looking at the first
4384 * non-CM character preceding it */
4386 prev = backup_one_LB(strbeg, &temp_pos, utf8_target);
4388 while (prev == LB_Combining_Mark);
4390 /* Here, 'prev' is that first earlier non-CM character. If the CM
4391 * attatches to it, then it inherits the behavior of 'prev'. If it
4392 * doesn't attach, it is to be treated as an AL */
4393 if (! LB_CM_ATTACHES_TO(prev)) {
4394 prev = LB_Alphabetic;
4399 case LB_HY_or_BA_then_foo + LB_BREAKABLE:
4400 case LB_HY_or_BA_then_foo + LB_NOBREAK:
4402 /* LB21a Don't break after Hebrew + Hyphen.
4405 if (backup_one_LB(strbeg, &temp_pos, utf8_target)
4406 == LB_Hebrew_Letter)
4411 return LB_table[prev][after] - LB_HY_or_BA_then_foo == LB_BREAKABLE;
4413 case LB_PR_or_PO_then_OP_or_HY + LB_BREAKABLE:
4414 case LB_PR_or_PO_then_OP_or_HY + LB_NOBREAK:
4416 /* LB25a (PR | PO) × ( OP | HY )? NU */
4417 if (advance_one_LB(&temp_pos, strend, utf8_target) == LB_Numeric) {
4421 return LB_table[prev][after] - LB_PR_or_PO_then_OP_or_HY
4424 case LB_SY_or_IS_then_various + LB_BREAKABLE:
4425 case LB_SY_or_IS_then_various + LB_NOBREAK:
4427 /* LB25d NU (SY | IS)* × (NU | SY | IS | CL | CP ) */
4429 LB_enum temp = prev;
4431 temp = backup_one_LB(strbeg, &temp_pos, utf8_target);
4433 while (temp == LB_Break_Symbols || temp == LB_Infix_Numeric);
4434 if (temp == LB_Numeric) {
4438 return LB_table[prev][after] - LB_SY_or_IS_then_various
4442 case LB_various_then_PO_or_PR + LB_BREAKABLE:
4443 case LB_various_then_PO_or_PR + LB_NOBREAK:
4445 /* LB25e NU (SY | IS)* (CL | CP)? × (PO | PR) */
4447 LB_enum temp = prev;
4448 if (temp == LB_Close_Punctuation || temp == LB_Close_Parenthesis)
4450 temp = backup_one_LB(strbeg, &temp_pos, utf8_target);
4452 while (temp == LB_Break_Symbols || temp == LB_Infix_Numeric) {
4453 temp = backup_one_LB(strbeg, &temp_pos, utf8_target);
4455 if (temp == LB_Numeric) {
4458 return LB_various_then_PO_or_PR;
4466 PerlIO_printf(Perl_error_log, "Unhandled LB pair: LB_table[%d, %d] = %d\n",
4467 before, after, LB_table[before][after]);
4474 S_advance_one_LB(pTHX_ U8 ** curpos, const U8 * const strend, const bool utf8_target)
4478 PERL_ARGS_ASSERT_ADVANCE_ONE_LB;
4480 if (*curpos >= strend) {
4485 *curpos += UTF8SKIP(*curpos);
4486 if (*curpos >= strend) {
4489 lb = getLB_VAL_UTF8(*curpos, strend);
4493 if (*curpos >= strend) {
4496 lb = getLB_VAL_CP(**curpos);
4503 S_backup_one_LB(pTHX_ const U8 * const strbeg, U8 ** curpos, const bool utf8_target)
4507 PERL_ARGS_ASSERT_BACKUP_ONE_LB;
4509 if (*curpos < strbeg) {
4514 U8 * prev_char_pos = reghopmaybe3(*curpos, -1, strbeg);
4515 U8 * prev_prev_char_pos;
4517 if (! prev_char_pos) {
4521 if ((prev_prev_char_pos = reghopmaybe3((U8 *) prev_char_pos, -1, strbeg))) {
4522 lb = getLB_VAL_UTF8(prev_prev_char_pos, prev_char_pos);
4523 *curpos = prev_char_pos;
4524 prev_char_pos = prev_prev_char_pos;
4527 *curpos = (U8 *) strbeg;
4532 if (*curpos - 2 < strbeg) {
4533 *curpos = (U8 *) strbeg;
4537 lb = getLB_VAL_CP(*(*curpos - 1));
4543 /* This creates a single number by combining two, with 'before' being like the
4544 * 10's digit, but this isn't necessarily base 10; it is base however many
4545 * elements of the enum there are */
4546 #define SBcase(before, after) ((SB_ENUM_COUNT * before) + after)
4549 S_isSB(pTHX_ SB_enum before,
4551 const U8 * const strbeg,
4552 const U8 * const curpos,
4553 const U8 * const strend,
4554 const bool utf8_target)
4556 /* returns a boolean indicating if there is a Sentence Boundary Break
4557 * between the inputs. See http://www.unicode.org/reports/tr29/ */
4559 U8 * lpos = (U8 *) curpos;
4563 PERL_ARGS_ASSERT_ISSB;
4565 /* Break at the start and end of text.
4568 if (before == SB_EDGE || after == SB_EDGE) {
4572 /* SB 3: Do not break within CRLF. */
4573 if (before == SB_CR && after == SB_LF) {
4577 /* Break after paragraph separators. (though why CR and LF are considered
4578 * so is beyond me (khw)
4579 SB4. Sep | CR | LF ÷ */
4580 if (before == SB_Sep || before == SB_CR || before == SB_LF) {
4584 /* Ignore Format and Extend characters, except after sot, Sep, CR, or LF.
4585 * (See Section 6.2, Replacing Ignore Rules.)
4586 SB5. X (Extend | Format)* → X */
4587 if (after == SB_Extend || after == SB_Format) {
4591 if (before == SB_Extend || before == SB_Format) {
4592 before = backup_one_SB(strbeg, &lpos, utf8_target);
4595 /* Do not break after ambiguous terminators like period, if they are
4596 * immediately followed by a number or lowercase letter, if they are
4597 * between uppercase letters, if the first following letter (optionally
4598 * after certain punctuation) is lowercase, or if they are followed by
4599 * "continuation" punctuation such as comma, colon, or semicolon. For
4600 * example, a period may be an abbreviation or numeric period, and thus may
4601 * not mark the end of a sentence.
4603 * SB6. ATerm × Numeric */
4604 if (before == SB_ATerm && after == SB_Numeric) {
4608 /* SB7. (Upper | Lower) ATerm × Upper */
4609 if (before == SB_ATerm && after == SB_Upper) {
4611 backup = backup_one_SB(strbeg, &temp_pos, utf8_target);
4612 if (backup == SB_Upper || backup == SB_Lower) {
4617 /* SB8a. (STerm | ATerm) Close* Sp* × (SContinue | STerm | ATerm)
4618 * SB10. (STerm | ATerm) Close* Sp* × ( Sp | Sep | CR | LF ) */
4621 while (backup == SB_Sp) {
4622 backup = backup_one_SB(strbeg, &temp_pos, utf8_target);
4624 while (backup == SB_Close) {
4625 backup = backup_one_SB(strbeg, &temp_pos, utf8_target);
4627 if ((backup == SB_STerm || backup == SB_ATerm)
4628 && ( after == SB_SContinue
4629 || after == SB_STerm
4630 || after == SB_ATerm
4639 /* SB8. ATerm Close* Sp* × ( ¬(OLetter | Upper | Lower | Sep | CR | LF |
4640 * STerm | ATerm) )* Lower */
4641 if (backup == SB_ATerm) {
4642 U8 * rpos = (U8 *) curpos;
4643 SB_enum later = after;
4645 while ( later != SB_OLetter
4646 && later != SB_Upper
4647 && later != SB_Lower
4651 && later != SB_STerm
4652 && later != SB_ATerm
4653 && later != SB_EDGE)
4655 later = advance_one_SB(&rpos, strend, utf8_target);
4657 if (later == SB_Lower) {
4662 /* Break after sentence terminators, but include closing punctuation,
4663 * trailing spaces, and a paragraph separator (if present). [See note
4665 * SB9. ( STerm | ATerm ) Close* × ( Close | Sp | Sep | CR | LF ) */
4668 while (backup == SB_Close) {
4669 backup = backup_one_SB(strbeg, &temp_pos, utf8_target);
4671 if ((backup == SB_STerm || backup == SB_ATerm)
4672 && ( after == SB_Close
4682 /* SB11. ( STerm | ATerm ) Close* Sp* ( Sep | CR | LF )? ÷ */
4684 backup = backup_one_SB(strbeg, &temp_pos, utf8_target);
4685 if ( backup == SB_Sep
4694 while (backup == SB_Sp) {
4695 backup = backup_one_SB(strbeg, &lpos, utf8_target);
4697 while (backup == SB_Close) {
4698 backup = backup_one_SB(strbeg, &lpos, utf8_target);
4700 if (backup == SB_STerm || backup == SB_ATerm) {
4704 /* Otherwise, do not break.
4711 S_advance_one_SB(pTHX_ U8 ** curpos, const U8 * const strend, const bool utf8_target)
4715 PERL_ARGS_ASSERT_ADVANCE_ONE_SB;
4717 if (*curpos >= strend) {
4723 *curpos += UTF8SKIP(*curpos);
4724 if (*curpos >= strend) {
4727 sb = getSB_VAL_UTF8(*curpos, strend);
4728 } while (sb == SB_Extend || sb == SB_Format);
4733 if (*curpos >= strend) {
4736 sb = getSB_VAL_CP(**curpos);
4737 } while (sb == SB_Extend || sb == SB_Format);
4744 S_backup_one_SB(pTHX_ const U8 * const strbeg, U8 ** curpos, const bool utf8_target)
4748 PERL_ARGS_ASSERT_BACKUP_ONE_SB;
4750 if (*curpos < strbeg) {
4755 U8 * prev_char_pos = reghopmaybe3(*curpos, -1, strbeg);
4756 if (! prev_char_pos) {
4760 /* Back up over Extend and Format. curpos is always just to the right
4761 * of the characater whose value we are getting */
4763 U8 * prev_prev_char_pos;
4764 if ((prev_prev_char_pos = reghopmaybe3((U8 *) prev_char_pos, -1,
4767 sb = getSB_VAL_UTF8(prev_prev_char_pos, prev_char_pos);
4768 *curpos = prev_char_pos;
4769 prev_char_pos = prev_prev_char_pos;
4772 *curpos = (U8 *) strbeg;
4775 } while (sb == SB_Extend || sb == SB_Format);
4779 if (*curpos - 2 < strbeg) {
4780 *curpos = (U8 *) strbeg;
4784 sb = getSB_VAL_CP(*(*curpos - 1));
4785 } while (sb == SB_Extend || sb == SB_Format);
4791 #define WBcase(before, after) ((WB_ENUM_COUNT * before) + after)
4794 S_isWB(pTHX_ WB_enum previous,
4797 const U8 * const strbeg,
4798 const U8 * const curpos,
4799 const U8 * const strend,
4800 const bool utf8_target)
4802 /* Return a boolean as to if the boundary between 'before' and 'after' is
4803 * a Unicode word break, using their published algorithm, but tailored for
4804 * Perl by treating spans of white space as one unit. Context may be
4805 * needed to make this determination. If the value for the character
4806 * before 'before' is known, it is passed as 'previous'; otherwise that
4807 * should be set to WB_UNKNOWN. The other input parameters give the
4808 * boundaries and current position in the matching of the string. That
4809 * is, 'curpos' marks the position where the character whose wb value is
4810 * 'after' begins. See http://www.unicode.org/reports/tr29/ */
4812 U8 * before_pos = (U8 *) curpos;
4813 U8 * after_pos = (U8 *) curpos;
4815 PERL_ARGS_ASSERT_ISWB;
4817 /* WB1 and WB2: Break at the start and end of text. */
4818 if (before == WB_EDGE || after == WB_EDGE) {
4822 /* WB 3 is: "Do not break within CRLF." Perl extends this so that all
4823 * white space sequences ending in a vertical space are treated as one
4826 if (after == WB_CR || after == WB_LF || after == WB_Newline) {
4827 if (before == WB_CR || before == WB_LF || before == WB_Newline
4828 || before == WB_Perl_Tailored_HSpace)
4833 /* WB 3a: Otherwise break before Newlines (including CR and LF) */
4837 /* Here, we know that 'after' is not a vertical space character, but
4838 * 'before' could be. WB 3b is: "Otherwise break after Newlines (including
4839 * CR and LF)." Perl changes that to not break-up spans of white space,
4840 * except when horizontal space is followed by an Extend or Format
4841 * character. These apply just to the final white space character in the
4842 * span, so it is broken away from the rest. (If the Extend or Format
4843 * character follows a vertical space character, it is treated as beginning
4844 * a line, and doesn't modify the preceeding character.) */
4845 if ( before == WB_CR || before == WB_LF || before == WB_Newline
4846 || before == WB_Perl_Tailored_HSpace)
4848 if (after == WB_Perl_Tailored_HSpace) {
4849 U8 * temp_pos = (U8 *) curpos;
4851 = advance_one_WB(&temp_pos, strend, utf8_target,
4852 FALSE /* Don't skip Extend nor Format */ );
4853 return next == WB_Extend || next == WB_Format;
4855 else if (before != WB_Perl_Tailored_HSpace) {
4857 /* Here, 'before' must be one of the vertical space characters, and
4858 * after is not any type of white-space. Follow WB 3b. */
4862 /* Here, 'before' is horizontal space, and 'after' is not any kind of
4863 * space. Normal rules apply */
4866 /* Ignore Format and Extend characters, except when they appear at the
4867 * beginning of a region of text.
4868 * WB4. X (Extend | Format)* → X. */
4870 if (after == WB_Extend || after == WB_Format) {
4874 if (before == WB_Extend || before == WB_Format) {
4875 before = backup_one_WB(&previous, strbeg, &before_pos, utf8_target);
4878 switch (WBcase(before, after)) {
4879 /* Otherwise, break everywhere (including around ideographs).
4884 /* Do not break between most letters.
4885 WB5. (ALetter | Hebrew_Letter) × (ALetter | Hebrew_Letter) */
4886 case WBcase(WB_ALetter, WB_ALetter):
4887 case WBcase(WB_ALetter, WB_Hebrew_Letter):
4888 case WBcase(WB_Hebrew_Letter, WB_ALetter):
4889 case WBcase(WB_Hebrew_Letter, WB_Hebrew_Letter):
4892 /* Do not break letters across certain punctuation.
4893 WB6. (ALetter | Hebrew_Letter)
4894 × (MidLetter | MidNumLet | Single_Quote) (ALetter
4896 case WBcase(WB_ALetter, WB_MidLetter):
4897 case WBcase(WB_ALetter, WB_MidNumLet):
4898 case WBcase(WB_ALetter, WB_Single_Quote):
4899 case WBcase(WB_Hebrew_Letter, WB_MidLetter):
4900 case WBcase(WB_Hebrew_Letter, WB_MidNumLet):
4901 /*case WBcase(WB_Hebrew_Letter, WB_Single_Quote):*/
4902 after = advance_one_WB(&after_pos, strend, utf8_target,
4903 TRUE /* Do skip Extend and Format */ );
4904 return after != WB_ALetter && after != WB_Hebrew_Letter;
4906 /* WB7. (ALetter | Hebrew_Letter) (MidLetter | MidNumLet |
4907 * Single_Quote) × (ALetter | Hebrew_Letter) */
4908 case WBcase(WB_MidLetter, WB_ALetter):
4909 case WBcase(WB_MidLetter, WB_Hebrew_Letter):
4910 case WBcase(WB_MidNumLet, WB_ALetter):
4911 case WBcase(WB_MidNumLet, WB_Hebrew_Letter):
4912 case WBcase(WB_Single_Quote, WB_ALetter):
4913 case WBcase(WB_Single_Quote, WB_Hebrew_Letter):
4915 = backup_one_WB(&previous, strbeg, &before_pos, utf8_target);
4916 return before != WB_ALetter && before != WB_Hebrew_Letter;
4918 /* WB7a. Hebrew_Letter × Single_Quote */
4919 case WBcase(WB_Hebrew_Letter, WB_Single_Quote):
4922 /* WB7b. Hebrew_Letter × Double_Quote Hebrew_Letter */
4923 case WBcase(WB_Hebrew_Letter, WB_Double_Quote):
4924 return advance_one_WB(&after_pos, strend, utf8_target,
4925 TRUE /* Do skip Extend and Format */ )
4926 != WB_Hebrew_Letter;
4928 /* WB7c. Hebrew_Letter Double_Quote × Hebrew_Letter */
4929 case WBcase(WB_Double_Quote, WB_Hebrew_Letter):
4930 return backup_one_WB(&previous, strbeg, &before_pos, utf8_target)
4931 != WB_Hebrew_Letter;
4933 /* Do not break within sequences of digits, or digits adjacent to
4934 * letters (“3a”, or “A3”).
4935 WB8. Numeric × Numeric */
4936 case WBcase(WB_Numeric, WB_Numeric):
4939 /* WB9. (ALetter | Hebrew_Letter) × Numeric */
4940 case WBcase(WB_ALetter, WB_Numeric):
4941 case WBcase(WB_Hebrew_Letter, WB_Numeric):
4944 /* WB10. Numeric × (ALetter | Hebrew_Letter) */
4945 case WBcase(WB_Numeric, WB_ALetter):
4946 case WBcase(WB_Numeric, WB_Hebrew_Letter):
4949 /* Do not break within sequences, such as “3.2” or “3,456.789”.
4950 WB11. Numeric (MidNum | MidNumLet | Single_Quote) × Numeric
4952 case WBcase(WB_MidNum, WB_Numeric):
4953 case WBcase(WB_MidNumLet, WB_Numeric):
4954 case WBcase(WB_Single_Quote, WB_Numeric):
4955 return backup_one_WB(&previous, strbeg, &before_pos, utf8_target)
4958 /* WB12. Numeric × (MidNum | MidNumLet | Single_Quote) Numeric
4960 case WBcase(WB_Numeric, WB_MidNum):
4961 case WBcase(WB_Numeric, WB_MidNumLet):
4962 case WBcase(WB_Numeric, WB_Single_Quote):
4963 return advance_one_WB(&after_pos, strend, utf8_target,
4964 TRUE /* Do skip Extend and Format */ )
4967 /* Do not break between Katakana.
4968 WB13. Katakana × Katakana */
4969 case WBcase(WB_Katakana, WB_Katakana):
4972 /* Do not break from extenders.
4973 WB13a. (ALetter | Hebrew_Letter | Numeric | Katakana |
4974 ExtendNumLet) × ExtendNumLet */
4975 case WBcase(WB_ALetter, WB_ExtendNumLet):
4976 case WBcase(WB_Hebrew_Letter, WB_ExtendNumLet):
4977 case WBcase(WB_Numeric, WB_ExtendNumLet):
4978 case WBcase(WB_Katakana, WB_ExtendNumLet):
4979 case WBcase(WB_ExtendNumLet, WB_ExtendNumLet):
4982 /* WB13b. ExtendNumLet × (ALetter | Hebrew_Letter | Numeric
4984 case WBcase(WB_ExtendNumLet, WB_ALetter):
4985 case WBcase(WB_ExtendNumLet, WB_Hebrew_Letter):
4986 case WBcase(WB_ExtendNumLet, WB_Numeric):
4987 case WBcase(WB_ExtendNumLet, WB_Katakana):
4990 /* Do not break between regional indicator symbols.
4991 WB13c. Regional_Indicator × Regional_Indicator */
4992 case WBcase(WB_Regional_Indicator, WB_Regional_Indicator):
4997 NOT_REACHED; /* NOTREACHED */
5001 S_advance_one_WB(pTHX_ U8 ** curpos,
5002 const U8 * const strend,
5003 const bool utf8_target,
5004 const bool skip_Extend_Format)
5008 PERL_ARGS_ASSERT_ADVANCE_ONE_WB;
5010 if (*curpos >= strend) {
5016 /* Advance over Extend and Format */
5018 *curpos += UTF8SKIP(*curpos);
5019 if (*curpos >= strend) {
5022 wb = getWB_VAL_UTF8(*curpos, strend);
5023 } while ( skip_Extend_Format
5024 && (wb == WB_Extend || wb == WB_Format));
5029 if (*curpos >= strend) {
5032 wb = getWB_VAL_CP(**curpos);
5033 } while ( skip_Extend_Format
5034 && (wb == WB_Extend || wb == WB_Format));
5041 S_backup_one_WB(pTHX_ WB_enum * previous, const U8 * const strbeg, U8 ** curpos, const bool utf8_target)
5045 PERL_ARGS_ASSERT_BACKUP_ONE_WB;
5047 /* If we know what the previous character's break value is, don't have
5049 if (*previous != WB_UNKNOWN) {
5052 /* But we need to move backwards by one */
5054 *curpos = reghopmaybe3(*curpos, -1, strbeg);
5056 *previous = WB_EDGE;
5057 *curpos = (U8 *) strbeg;
5060 *previous = WB_UNKNOWN;
5065 *previous = (*curpos <= strbeg) ? WB_EDGE : WB_UNKNOWN;
5068 /* And we always back up over these two types */
5069 if (wb != WB_Extend && wb != WB_Format) {
5074 if (*curpos < strbeg) {
5079 U8 * prev_char_pos = reghopmaybe3(*curpos, -1, strbeg);
5080 if (! prev_char_pos) {
5084 /* Back up over Extend and Format. curpos is always just to the right
5085 * of the characater whose value we are getting */
5087 U8 * prev_prev_char_pos;
5088 if ((prev_prev_char_pos = reghopmaybe3((U8 *) prev_char_pos,
5092 wb = getWB_VAL_UTF8(prev_prev_char_pos, prev_char_pos);
5093 *curpos = prev_char_pos;
5094 prev_char_pos = prev_prev_char_pos;
5097 *curpos = (U8 *) strbeg;
5100 } while (wb == WB_Extend || wb == WB_Format);
5104 if (*curpos - 2 < strbeg) {
5105 *curpos = (U8 *) strbeg;
5109 wb = getWB_VAL_CP(*(*curpos - 1));
5110 } while (wb == WB_Extend || wb == WB_Format);
5116 /* returns -1 on failure, $+[0] on success */
5118 S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
5120 #if PERL_VERSION < 9 && !defined(PERL_CORE)
5124 const bool utf8_target = reginfo->is_utf8_target;
5125 const U32 uniflags = UTF8_ALLOW_DEFAULT;
5126 REGEXP *rex_sv = reginfo->prog;
5127 regexp *rex = ReANY(rex_sv);
5128 RXi_GET_DECL(rex,rexi);
5129 /* the current state. This is a cached copy of PL_regmatch_state */
5131 /* cache heavy used fields of st in registers */
5134 U32 n = 0; /* general value; init to avoid compiler warning */
5135 SSize_t ln = 0; /* len or last; init to avoid compiler warning */
5136 char *locinput = startpos;
5137 char *pushinput; /* where to continue after a PUSH */
5138 I32 nextchr; /* is always set to UCHARAT(locinput) */
5140 bool result = 0; /* return value of S_regmatch */
5141 int depth = 0; /* depth of backtrack stack */
5142 U32 nochange_depth = 0; /* depth of GOSUB recursion with nochange */
5143 const U32 max_nochange_depth =
5144 (3 * rex->nparens > MAX_RECURSE_EVAL_NOCHANGE_DEPTH) ?
5145 3 * rex->nparens : MAX_RECURSE_EVAL_NOCHANGE_DEPTH;
5146 regmatch_state *yes_state = NULL; /* state to pop to on success of
5148 /* mark_state piggy backs on the yes_state logic so that when we unwind
5149 the stack on success we can update the mark_state as we go */
5150 regmatch_state *mark_state = NULL; /* last mark state we have seen */
5151 regmatch_state *cur_eval = NULL; /* most recent EVAL_AB state */
5152 struct regmatch_state *cur_curlyx = NULL; /* most recent curlyx */
5154 bool no_final = 0; /* prevent failure from backtracking? */
5155 bool do_cutgroup = 0; /* no_final only until next branch/trie entry */
5156 char *startpoint = locinput;
5157 SV *popmark = NULL; /* are we looking for a mark? */
5158 SV *sv_commit = NULL; /* last mark name seen in failure */
5159 SV *sv_yes_mark = NULL; /* last mark name we have seen
5160 during a successful match */
5161 U32 lastopen = 0; /* last open we saw */
5162 bool has_cutgroup = RX_HAS_CUTGROUP(rex) ? 1 : 0;
5163 SV* const oreplsv = GvSVn(PL_replgv);
5164 /* these three flags are set by various ops to signal information to
5165 * the very next op. They have a useful lifetime of exactly one loop
5166 * iteration, and are not preserved or restored by state pushes/pops
5168 bool sw = 0; /* the condition value in (?(cond)a|b) */
5169 bool minmod = 0; /* the next "{n,m}" is a "{n,m}?" */
5170 int logical = 0; /* the following EVAL is:
5174 or the following IFMATCH/UNLESSM is:
5175 false: plain (?=foo)
5176 true: used as a condition: (?(?=foo))
5178 PAD* last_pad = NULL;
5180 I32 gimme = G_SCALAR;
5181 CV *caller_cv = NULL; /* who called us */
5182 CV *last_pushed_cv = NULL; /* most recently called (?{}) CV */
5183 CHECKPOINT runops_cp; /* savestack position before executing EVAL */
5184 U32 maxopenparen = 0; /* max '(' index seen so far */
5185 int to_complement; /* Invert the result? */
5186 _char_class_number classnum;
5187 bool is_utf8_pat = reginfo->is_utf8_pat;
5192 GET_RE_DEBUG_FLAGS_DECL;
5195 /* protect against undef(*^R) */
5196 SAVEFREESV(SvREFCNT_inc_simple_NN(oreplsv));
5198 /* shut up 'may be used uninitialized' compiler warnings for dMULTICALL */
5199 multicall_oldcatch = 0;
5200 multicall_cv = NULL;
5202 PERL_UNUSED_VAR(multicall_cop);
5203 PERL_UNUSED_VAR(newsp);
5206 PERL_ARGS_ASSERT_REGMATCH;
5208 DEBUG_OPTIMISE_r( DEBUG_EXECUTE_r({
5209 PerlIO_printf(Perl_debug_log,"regmatch start\n");
5212 st = PL_regmatch_state;
5214 /* Note that nextchr is a byte even in UTF */
5217 while (scan != NULL) {
5220 SV * const prop = sv_newmortal();
5221 regnode *rnext=regnext(scan);
5222 DUMP_EXEC_POS( locinput, scan, utf8_target );
5223 regprop(rex, prop, scan, reginfo, NULL);
5225 PerlIO_printf(Perl_debug_log,
5226 "%3"IVdf":%*s%s(%"IVdf")\n",
5227 (IV)(scan - rexi->program), depth*2, "",
5229 (PL_regkind[OP(scan)] == END || !rnext) ?
5230 0 : (IV)(rnext - rexi->program));
5233 next = scan + NEXT_OFF(scan);
5236 state_num = OP(scan);
5242 assert(nextchr < 256 && (nextchr >= 0 || nextchr == NEXTCHR_EOS));
5244 switch (state_num) {
5245 case SBOL: /* /^../ and /\A../ */
5246 if (locinput == reginfo->strbeg)
5250 case MBOL: /* /^../m */
5251 if (locinput == reginfo->strbeg ||
5252 (!NEXTCHR_IS_EOS && locinput[-1] == '\n'))
5259 if (locinput == reginfo->ganch)
5263 case KEEPS: /* \K */
5264 /* update the startpoint */
5265 st->u.keeper.val = rex->offs[0].start;
5266 rex->offs[0].start = locinput - reginfo->strbeg;
5267 PUSH_STATE_GOTO(KEEPS_next, next, locinput);
5269 NOT_REACHED; /* NOTREACHED */
5271 case KEEPS_next_fail:
5272 /* rollback the start point change */
5273 rex->offs[0].start = st->u.keeper.val;
5276 NOT_REACHED; /* NOTREACHED */
5278 case MEOL: /* /..$/m */
5279 if (!NEXTCHR_IS_EOS && nextchr != '\n')
5283 case SEOL: /* /..$/ */
5284 if (!NEXTCHR_IS_EOS && nextchr != '\n')
5286 if (reginfo->strend - locinput > 1)
5291 if (!NEXTCHR_IS_EOS)
5295 case SANY: /* /./s */
5298 goto increment_locinput;
5300 case REG_ANY: /* /./ */
5301 if ((NEXTCHR_IS_EOS) || nextchr == '\n')
5303 goto increment_locinput;
5307 #define ST st->u.trie
5308 case TRIEC: /* (ab|cd) with known charclass */
5309 /* In this case the charclass data is available inline so
5310 we can fail fast without a lot of extra overhead.
5312 if(!NEXTCHR_IS_EOS && !ANYOF_BITMAP_TEST(scan, nextchr)) {
5314 PerlIO_printf(Perl_debug_log,
5315 "%*s %sfailed to match trie start class...%s\n",
5316 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
5320 NOT_REACHED; /* NOTREACHED */
5323 case TRIE: /* (ab|cd) */
5324 /* the basic plan of execution of the trie is:
5325 * At the beginning, run though all the states, and
5326 * find the longest-matching word. Also remember the position
5327 * of the shortest matching word. For example, this pattern:
5330 * when matched against the string "abcde", will generate
5331 * accept states for all words except 3, with the longest
5332 * matching word being 4, and the shortest being 2 (with
5333 * the position being after char 1 of the string).
5335 * Then for each matching word, in word order (i.e. 1,2,4,5),
5336 * we run the remainder of the pattern; on each try setting
5337 * the current position to the character following the word,
5338 * returning to try the next word on failure.
5340 * We avoid having to build a list of words at runtime by
5341 * using a compile-time structure, wordinfo[].prev, which
5342 * gives, for each word, the previous accepting word (if any).
5343 * In the case above it would contain the mappings 1->2, 2->0,
5344 * 3->0, 4->5, 5->1. We can use this table to generate, from
5345 * the longest word (4 above), a list of all words, by
5346 * following the list of prev pointers; this gives us the
5347 * unordered list 4,5,1,2. Then given the current word we have
5348 * just tried, we can go through the list and find the
5349 * next-biggest word to try (so if we just failed on word 2,
5350 * the next in the list is 4).
5352 * Since at runtime we don't record the matching position in
5353 * the string for each word, we have to work that out for
5354 * each word we're about to process. The wordinfo table holds
5355 * the character length of each word; given that we recorded
5356 * at the start: the position of the shortest word and its
5357 * length in chars, we just need to move the pointer the
5358 * difference between the two char lengths. Depending on
5359 * Unicode status and folding, that's cheap or expensive.
5361 * This algorithm is optimised for the case where are only a
5362 * small number of accept states, i.e. 0,1, or maybe 2.
5363 * With lots of accepts states, and having to try all of them,
5364 * it becomes quadratic on number of accept states to find all
5369 /* what type of TRIE am I? (utf8 makes this contextual) */
5370 DECL_TRIE_TYPE(scan);
5372 /* what trie are we using right now */
5373 reg_trie_data * const trie
5374 = (reg_trie_data*)rexi->data->data[ ARG( scan ) ];
5375 HV * widecharmap = MUTABLE_HV(rexi->data->data[ ARG( scan ) + 1 ]);
5376 U32 state = trie->startstate;
5378 if (scan->flags == EXACTL || scan->flags == EXACTFLU8) {
5379 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
5381 && UTF8_IS_ABOVE_LATIN1(nextchr)
5382 && scan->flags == EXACTL)
5384 /* We only output for EXACTL, as we let the folder
5385 * output this message for EXACTFLU8 to avoid
5387 _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(locinput,
5392 && (NEXTCHR_IS_EOS || !TRIE_BITMAP_TEST(trie, nextchr)))
5394 if (trie->states[ state ].wordnum) {
5396 PerlIO_printf(Perl_debug_log,
5397 "%*s %smatched empty string...%s\n",
5398 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
5404 PerlIO_printf(Perl_debug_log,
5405 "%*s %sfailed to match trie start class...%s\n",
5406 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
5413 U8 *uc = ( U8* )locinput;
5417 U8 *uscan = (U8*)NULL;
5418 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
5419 U32 charcount = 0; /* how many input chars we have matched */
5420 U32 accepted = 0; /* have we seen any accepting states? */
5422 ST.jump = trie->jump;
5425 ST.longfold = FALSE; /* char longer if folded => it's harder */
5428 /* fully traverse the TRIE; note the position of the
5429 shortest accept state and the wordnum of the longest
5432 while ( state && uc <= (U8*)(reginfo->strend) ) {
5433 U32 base = trie->states[ state ].trans.base;
5437 wordnum = trie->states[ state ].wordnum;
5439 if (wordnum) { /* it's an accept state */
5442 /* record first match position */
5444 ST.firstpos = (U8*)locinput;
5449 ST.firstchars = charcount;
5452 if (!ST.nextword || wordnum < ST.nextword)
5453 ST.nextword = wordnum;
5454 ST.topword = wordnum;
5457 DEBUG_TRIE_EXECUTE_r({
5458 DUMP_EXEC_POS( (char *)uc, scan, utf8_target );
5459 PerlIO_printf( Perl_debug_log,
5460 "%*s %sState: %4"UVxf" Accepted: %c ",
5461 2+depth * 2, "", PL_colors[4],
5462 (UV)state, (accepted ? 'Y' : 'N'));
5465 /* read a char and goto next state */
5466 if ( base && (foldlen || uc < (U8*)(reginfo->strend))) {
5468 REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
5469 uscan, len, uvc, charid, foldlen,
5476 base + charid - 1 - trie->uniquecharcount)) >= 0)
5478 && ((U32)offset < trie->lasttrans)
5479 && trie->trans[offset].check == state)
5481 state = trie->trans[offset].next;
5492 DEBUG_TRIE_EXECUTE_r(
5493 PerlIO_printf( Perl_debug_log,
5494 "Charid:%3x CP:%4"UVxf" After State: %4"UVxf"%s\n",
5495 charid, uvc, (UV)state, PL_colors[5] );
5501 /* calculate total number of accept states */
5506 w = trie->wordinfo[w].prev;
5509 ST.accepted = accepted;
5513 PerlIO_printf( Perl_debug_log,
5514 "%*s %sgot %"IVdf" possible matches%s\n",
5515 REPORT_CODE_OFF + depth * 2, "",
5516 PL_colors[4], (IV)ST.accepted, PL_colors[5] );
5518 goto trie_first_try; /* jump into the fail handler */
5521 NOT_REACHED; /* NOTREACHED */
5523 case TRIE_next_fail: /* we failed - try next alternative */
5527 REGCP_UNWIND(ST.cp);
5528 UNWIND_PAREN(ST.lastparen, ST.lastcloseparen);
5530 if (!--ST.accepted) {
5532 PerlIO_printf( Perl_debug_log,
5533 "%*s %sTRIE failed...%s\n",
5534 REPORT_CODE_OFF+depth*2, "",
5541 /* Find next-highest word to process. Note that this code
5542 * is O(N^2) per trie run (O(N) per branch), so keep tight */
5545 U16 const nextword = ST.nextword;
5546 reg_trie_wordinfo * const wordinfo
5547 = ((reg_trie_data*)rexi->data->data[ARG(ST.me)])->wordinfo;
5548 for (word=ST.topword; word; word=wordinfo[word].prev) {
5549 if (word > nextword && (!min || word < min))
5562 ST.lastparen = rex->lastparen;
5563 ST.lastcloseparen = rex->lastcloseparen;
5567 /* find start char of end of current word */
5569 U32 chars; /* how many chars to skip */
5570 reg_trie_data * const trie
5571 = (reg_trie_data*)rexi->data->data[ARG(ST.me)];
5573 assert((trie->wordinfo[ST.nextword].len - trie->prefixlen)
5575 chars = (trie->wordinfo[ST.nextword].len - trie->prefixlen)
5580 /* the hard option - fold each char in turn and find
5581 * its folded length (which may be different */
5582 U8 foldbuf[UTF8_MAXBYTES_CASE + 1];
5590 uvc = utf8n_to_uvchr((U8*)uc, UTF8_MAXLEN, &len,
5598 uvc = to_uni_fold(uvc, foldbuf, &foldlen);
5603 uvc = utf8n_to_uvchr(uscan, UTF8_MAXLEN, &len,
5619 scan = ST.me + ((ST.jump && ST.jump[ST.nextword])
5620 ? ST.jump[ST.nextword]
5624 PerlIO_printf( Perl_debug_log,
5625 "%*s %sTRIE matched word #%d, continuing%s\n",
5626 REPORT_CODE_OFF+depth*2, "",
5633 if (ST.accepted > 1 || has_cutgroup) {
5634 PUSH_STATE_GOTO(TRIE_next, scan, (char*)uc);
5636 NOT_REACHED; /* NOTREACHED */
5638 /* only one choice left - just continue */
5640 AV *const trie_words
5641 = MUTABLE_AV(rexi->data->data[ARG(ST.me)+TRIE_WORDS_OFFSET]);
5642 SV ** const tmp = trie_words
5643 ? av_fetch(trie_words, ST.nextword - 1, 0) : NULL;
5644 SV *sv= tmp ? sv_newmortal() : NULL;
5646 PerlIO_printf( Perl_debug_log,
5647 "%*s %sonly one match left, short-circuiting: #%d <%s>%s\n",
5648 REPORT_CODE_OFF+depth*2, "", PL_colors[4],
5650 tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0,
5651 PL_colors[0], PL_colors[1],
5652 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)|PERL_PV_ESCAPE_NONASCII
5654 : "not compiled under -Dr",
5658 locinput = (char*)uc;
5659 continue; /* execute rest of RE */
5664 case EXACTL: /* /abc/l */
5665 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
5667 /* Complete checking would involve going through every character
5668 * matched by the string to see if any is above latin1. But the
5669 * comparision otherwise might very well be a fast assembly
5670 * language routine, and I (khw) don't think slowing things down
5671 * just to check for this warning is worth it. So this just checks
5672 * the first character */
5673 if (utf8_target && UTF8_IS_ABOVE_LATIN1(*locinput)) {
5674 _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(locinput, reginfo->strend);
5677 case EXACT: { /* /abc/ */
5678 char *s = STRING(scan);
5680 if (utf8_target != is_utf8_pat) {
5681 /* The target and the pattern have differing utf8ness. */
5683 const char * const e = s + ln;
5686 /* The target is utf8, the pattern is not utf8.
5687 * Above-Latin1 code points can't match the pattern;
5688 * invariants match exactly, and the other Latin1 ones need
5689 * to be downgraded to a single byte in order to do the
5690 * comparison. (If we could be confident that the target
5691 * is not malformed, this could be refactored to have fewer
5692 * tests by just assuming that if the first bytes match, it
5693 * is an invariant, but there are tests in the test suite
5694 * dealing with (??{...}) which violate this) */
5696 if (l >= reginfo->strend
5697 || UTF8_IS_ABOVE_LATIN1(* (U8*) l))
5701 if (UTF8_IS_INVARIANT(*(U8*)l)) {
5708 if (EIGHT_BIT_UTF8_TO_NATIVE(*l, *(l+1)) != * (U8*) s)
5718 /* The target is not utf8, the pattern is utf8. */
5720 if (l >= reginfo->strend
5721 || UTF8_IS_ABOVE_LATIN1(* (U8*) s))
5725 if (UTF8_IS_INVARIANT(*(U8*)s)) {
5732 if (EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s+1)) != * (U8*) l)
5744 /* The target and the pattern have the same utf8ness. */
5745 /* Inline the first character, for speed. */
5746 if (reginfo->strend - locinput < ln
5747 || UCHARAT(s) != nextchr
5748 || (ln > 1 && memNE(s, locinput, ln)))
5757 case EXACTFL: { /* /abc/il */
5759 const U8 * fold_array;
5761 U32 fold_utf8_flags;
5763 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
5764 folder = foldEQ_locale;
5765 fold_array = PL_fold_locale;
5766 fold_utf8_flags = FOLDEQ_LOCALE;
5769 case EXACTFLU8: /* /abc/il; but all 'abc' are above 255, so
5770 is effectively /u; hence to match, target
5772 if (! utf8_target) {
5775 fold_utf8_flags = FOLDEQ_LOCALE | FOLDEQ_S1_ALREADY_FOLDED
5776 | FOLDEQ_S1_FOLDS_SANE;
5777 folder = foldEQ_latin1;
5778 fold_array = PL_fold_latin1;
5781 case EXACTFU_SS: /* /\x{df}/iu */
5782 case EXACTFU: /* /abc/iu */
5783 folder = foldEQ_latin1;
5784 fold_array = PL_fold_latin1;
5785 fold_utf8_flags = is_utf8_pat ? FOLDEQ_S1_ALREADY_FOLDED : 0;
5788 case EXACTFA_NO_TRIE: /* This node only generated for non-utf8
5790 assert(! is_utf8_pat);
5792 case EXACTFA: /* /abc/iaa */
5793 folder = foldEQ_latin1;
5794 fold_array = PL_fold_latin1;
5795 fold_utf8_flags = FOLDEQ_UTF8_NOMIX_ASCII;
5798 case EXACTF: /* /abc/i This node only generated for
5799 non-utf8 patterns */
5800 assert(! is_utf8_pat);
5802 fold_array = PL_fold;
5803 fold_utf8_flags = 0;
5811 || state_num == EXACTFU_SS
5812 || (state_num == EXACTFL && IN_UTF8_CTYPE_LOCALE))
5814 /* Either target or the pattern are utf8, or has the issue where
5815 * the fold lengths may differ. */
5816 const char * const l = locinput;
5817 char *e = reginfo->strend;
5819 if (! foldEQ_utf8_flags(s, 0, ln, is_utf8_pat,
5820 l, &e, 0, utf8_target, fold_utf8_flags))
5828 /* Neither the target nor the pattern are utf8 */
5829 if (UCHARAT(s) != nextchr
5831 && UCHARAT(s) != fold_array[nextchr])
5835 if (reginfo->strend - locinput < ln)
5837 if (ln > 1 && ! folder(s, locinput, ln))
5843 case NBOUNDL: /* /\B/l */
5847 case BOUNDL: /* /\b/l */
5850 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
5852 if (FLAGS(scan) != TRADITIONAL_BOUND) {
5853 if (! IN_UTF8_CTYPE_LOCALE) {
5854 Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
5855 B_ON_NON_UTF8_LOCALE_IS_WRONG);
5861 if (locinput == reginfo->strbeg)
5862 b1 = isWORDCHAR_LC('\n');
5864 b1 = isWORDCHAR_LC_utf8(reghop3((U8*)locinput, -1,
5865 (U8*)(reginfo->strbeg)));
5867 b2 = (NEXTCHR_IS_EOS)
5868 ? isWORDCHAR_LC('\n')
5869 : isWORDCHAR_LC_utf8((U8*)locinput);
5871 else { /* Here the string isn't utf8 */
5872 b1 = (locinput == reginfo->strbeg)
5873 ? isWORDCHAR_LC('\n')
5874 : isWORDCHAR_LC(UCHARAT(locinput - 1));
5875 b2 = (NEXTCHR_IS_EOS)
5876 ? isWORDCHAR_LC('\n')
5877 : isWORDCHAR_LC(nextchr);
5879 if (to_complement ^ (b1 == b2)) {
5885 case NBOUND: /* /\B/ */
5889 case BOUND: /* /\b/ */
5893 goto bound_ascii_match_only;
5895 case NBOUNDA: /* /\B/a */
5899 case BOUNDA: /* /\b/a */
5903 bound_ascii_match_only:
5904 /* Here the string isn't utf8, or is utf8 and only ascii characters
5905 * are to match \w. In the latter case looking at the byte just
5906 * prior to the current one may be just the final byte of a
5907 * multi-byte character. This is ok. There are two cases:
5908 * 1) it is a single byte character, and then the test is doing
5909 * just what it's supposed to.
5910 * 2) it is a multi-byte character, in which case the final byte is
5911 * never mistakable for ASCII, and so the test will say it is
5912 * not a word character, which is the correct answer. */
5913 b1 = (locinput == reginfo->strbeg)
5914 ? isWORDCHAR_A('\n')
5915 : isWORDCHAR_A(UCHARAT(locinput - 1));
5916 b2 = (NEXTCHR_IS_EOS)
5917 ? isWORDCHAR_A('\n')
5918 : isWORDCHAR_A(nextchr);
5919 if (to_complement ^ (b1 == b2)) {
5925 case NBOUNDU: /* /\B/u */
5929 case BOUNDU: /* /\b/u */
5932 if (UNLIKELY(reginfo->strbeg >= reginfo->strend)) {
5935 else if (utf8_target) {
5937 switch((bound_type) FLAGS(scan)) {
5938 case TRADITIONAL_BOUND:
5941 b1 = (locinput == reginfo->strbeg)
5942 ? 0 /* isWORDCHAR_L1('\n') */
5943 : isWORDCHAR_utf8(reghop3((U8*)locinput, -1,
5944 (U8*)(reginfo->strbeg)));
5945 b2 = (NEXTCHR_IS_EOS)
5946 ? 0 /* isWORDCHAR_L1('\n') */
5947 : isWORDCHAR_utf8((U8*)locinput);
5948 match = cBOOL(b1 != b2);
5952 if (locinput == reginfo->strbeg || NEXTCHR_IS_EOS) {
5953 match = TRUE; /* GCB always matches at begin and
5957 /* Find the gcb values of previous and current
5958 * chars, then see if is a break point */
5959 match = isGCB(getGCB_VAL_UTF8(
5960 reghop3((U8*)locinput,
5962 (U8*)(reginfo->strbeg)),
5963 (U8*) reginfo->strend),
5964 getGCB_VAL_UTF8((U8*) locinput,
5965 (U8*) reginfo->strend));
5970 if (locinput == reginfo->strbeg) {
5973 else if (NEXTCHR_IS_EOS) {
5977 match = isLB(getLB_VAL_UTF8(
5978 reghop3((U8*)locinput,
5980 (U8*)(reginfo->strbeg)),
5981 (U8*) reginfo->strend),
5982 getLB_VAL_UTF8((U8*) locinput,
5983 (U8*) reginfo->strend),
5984 (U8*) reginfo->strbeg,
5986 (U8*) reginfo->strend,
5991 case SB_BOUND: /* Always matches at begin and end */
5992 if (locinput == reginfo->strbeg || NEXTCHR_IS_EOS) {
5996 match = isSB(getSB_VAL_UTF8(
5997 reghop3((U8*)locinput,
5999 (U8*)(reginfo->strbeg)),
6000 (U8*) reginfo->strend),
6001 getSB_VAL_UTF8((U8*) locinput,
6002 (U8*) reginfo->strend),
6003 (U8*) reginfo->strbeg,
6005 (U8*) reginfo->strend,
6011 if (locinput == reginfo->strbeg || NEXTCHR_IS_EOS) {
6015 match = isWB(WB_UNKNOWN,
6017 reghop3((U8*)locinput,
6019 (U8*)(reginfo->strbeg)),
6020 (U8*) reginfo->strend),
6021 getWB_VAL_UTF8((U8*) locinput,
6022 (U8*) reginfo->strend),
6023 (U8*) reginfo->strbeg,
6025 (U8*) reginfo->strend,
6031 else { /* Not utf8 target */
6032 switch((bound_type) FLAGS(scan)) {
6033 case TRADITIONAL_BOUND:
6036 b1 = (locinput == reginfo->strbeg)
6037 ? 0 /* isWORDCHAR_L1('\n') */
6038 : isWORDCHAR_L1(UCHARAT(locinput - 1));
6039 b2 = (NEXTCHR_IS_EOS)
6040 ? 0 /* isWORDCHAR_L1('\n') */
6041 : isWORDCHAR_L1(nextchr);
6042 match = cBOOL(b1 != b2);
6047 if (locinput == reginfo->strbeg || NEXTCHR_IS_EOS) {
6048 match = TRUE; /* GCB always matches at begin and
6051 else { /* Only CR-LF combo isn't a GCB in 0-255
6053 match = UCHARAT(locinput - 1) != '\r'
6054 || UCHARAT(locinput) != '\n';
6059 if (locinput == reginfo->strbeg) {
6062 else if (NEXTCHR_IS_EOS) {
6066 match = isLB(getLB_VAL_CP(UCHARAT(locinput -1)),
6067 getLB_VAL_CP(UCHARAT(locinput)),
6068 (U8*) reginfo->strbeg,
6070 (U8*) reginfo->strend,
6075 case SB_BOUND: /* Always matches at begin and end */
6076 if (locinput == reginfo->strbeg || NEXTCHR_IS_EOS) {
6080 match = isSB(getSB_VAL_CP(UCHARAT(locinput -1)),
6081 getSB_VAL_CP(UCHARAT(locinput)),
6082 (U8*) reginfo->strbeg,
6084 (U8*) reginfo->strend,
6090 if (locinput == reginfo->strbeg || NEXTCHR_IS_EOS) {
6094 match = isWB(WB_UNKNOWN,
6095 getWB_VAL_CP(UCHARAT(locinput -1)),
6096 getWB_VAL_CP(UCHARAT(locinput)),
6097 (U8*) reginfo->strbeg,
6099 (U8*) reginfo->strend,
6106 if (to_complement ^ ! match) {
6111 case ANYOFL: /* /[abc]/l */
6112 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
6114 if (ANYOFL_UTF8_LOCALE_REQD(FLAGS(scan)) && ! IN_UTF8_CTYPE_LOCALE)
6116 Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE), utf8_locale_required);
6119 case ANYOFD: /* /[abc]/d */
6120 case ANYOF: /* /[abc]/ */
6123 if (utf8_target && ! UTF8_IS_INVARIANT(*locinput)) {
6124 if (!reginclass(rex, scan, (U8*)locinput, (U8*)reginfo->strend,
6127 locinput += UTF8SKIP(locinput);
6130 if (!REGINCLASS(rex, scan, (U8*)locinput))
6136 /* The argument (FLAGS) to all the POSIX node types is the class number
6139 case NPOSIXL: /* \W or [:^punct:] etc. under /l */
6143 case POSIXL: /* \w or [:punct:] etc. under /l */
6144 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
6148 /* Use isFOO_lc() for characters within Latin1. (Note that
6149 * UTF8_IS_INVARIANT works even on non-UTF-8 strings, or else
6150 * wouldn't be invariant) */
6151 if (UTF8_IS_INVARIANT(nextchr) || ! utf8_target) {
6152 if (! (to_complement ^ cBOOL(isFOO_lc(FLAGS(scan), (U8) nextchr)))) {
6156 else if (UTF8_IS_DOWNGRADEABLE_START(nextchr)) {
6157 if (! (to_complement ^ cBOOL(isFOO_lc(FLAGS(scan),
6158 EIGHT_BIT_UTF8_TO_NATIVE(nextchr,
6159 *(locinput + 1))))))
6164 else { /* Here, must be an above Latin-1 code point */
6165 _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(locinput, reginfo->strend);
6166 goto utf8_posix_above_latin1;
6169 /* Here, must be utf8 */
6170 locinput += UTF8SKIP(locinput);
6173 case NPOSIXD: /* \W or [:^punct:] etc. under /d */
6177 case POSIXD: /* \w or [:punct:] etc. under /d */
6183 case NPOSIXA: /* \W or [:^punct:] etc. under /a */
6185 if (NEXTCHR_IS_EOS) {
6189 /* All UTF-8 variants match */
6190 if (! UTF8_IS_INVARIANT(nextchr)) {
6191 goto increment_locinput;
6197 case POSIXA: /* \w or [:punct:] etc. under /a */
6200 /* We get here through POSIXD, NPOSIXD, and NPOSIXA when not in
6201 * UTF-8, and also from NPOSIXA even in UTF-8 when the current
6202 * character is a single byte */
6205 || ! (to_complement ^ cBOOL(_generic_isCC_A(nextchr,
6211 /* Here we are either not in utf8, or we matched a utf8-invariant,
6212 * so the next char is the next byte */
6216 case NPOSIXU: /* \W or [:^punct:] etc. under /u */
6220 case POSIXU: /* \w or [:punct:] etc. under /u */
6222 if (NEXTCHR_IS_EOS) {
6226 /* Use _generic_isCC() for characters within Latin1. (Note that
6227 * UTF8_IS_INVARIANT works even on non-UTF-8 strings, or else
6228 * wouldn't be invariant) */
6229 if (UTF8_IS_INVARIANT(nextchr) || ! utf8_target) {
6230 if (! (to_complement ^ cBOOL(_generic_isCC(nextchr,
6237 else if (UTF8_IS_DOWNGRADEABLE_START(nextchr)) {
6238 if (! (to_complement
6239 ^ cBOOL(_generic_isCC(EIGHT_BIT_UTF8_TO_NATIVE(nextchr,
6247 else { /* Handle above Latin-1 code points */
6248 utf8_posix_above_latin1:
6249 classnum = (_char_class_number) FLAGS(scan);
6250 if (classnum < _FIRST_NON_SWASH_CC) {
6252 /* Here, uses a swash to find such code points. Load if if
6253 * not done already */
6254 if (! PL_utf8_swash_ptrs[classnum]) {
6255 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
6256 PL_utf8_swash_ptrs[classnum]
6257 = _core_swash_init("utf8",
6260 PL_XPosix_ptrs[classnum], &flags);
6262 if (! (to_complement
6263 ^ cBOOL(swash_fetch(PL_utf8_swash_ptrs[classnum],
6264 (U8 *) locinput, TRUE))))
6269 else { /* Here, uses macros to find above Latin-1 code points */
6271 case _CC_ENUM_SPACE:
6272 if (! (to_complement
6273 ^ cBOOL(is_XPERLSPACE_high(locinput))))
6278 case _CC_ENUM_BLANK:
6279 if (! (to_complement
6280 ^ cBOOL(is_HORIZWS_high(locinput))))
6285 case _CC_ENUM_XDIGIT:
6286 if (! (to_complement
6287 ^ cBOOL(is_XDIGIT_high(locinput))))
6292 case _CC_ENUM_VERTSPACE:
6293 if (! (to_complement
6294 ^ cBOOL(is_VERTWS_high(locinput))))
6299 default: /* The rest, e.g. [:cntrl:], can't match
6301 if (! to_complement) {
6307 locinput += UTF8SKIP(locinput);
6311 case CLUMP: /* Match \X: logical Unicode character. This is defined as
6312 a Unicode extended Grapheme Cluster */
6315 if (! utf8_target) {
6317 /* Match either CR LF or '.', as all the other possibilities
6319 locinput++; /* Match the . or CR */
6320 if (nextchr == '\r' /* And if it was CR, and the next is LF,
6322 && locinput < reginfo->strend
6323 && UCHARAT(locinput) == '\n')
6330 /* Get the gcb type for the current character */
6331 GCB_enum prev_gcb = getGCB_VAL_UTF8((U8*) locinput,
6332 (U8*) reginfo->strend);
6334 /* Then scan through the input until we get to the first
6335 * character whose type is supposed to be a gcb with the
6336 * current character. (There is always a break at the
6338 locinput += UTF8SKIP(locinput);
6339 while (locinput < reginfo->strend) {
6340 GCB_enum cur_gcb = getGCB_VAL_UTF8((U8*) locinput,
6341 (U8*) reginfo->strend);
6342 if (isGCB(prev_gcb, cur_gcb)) {
6347 locinput += UTF8SKIP(locinput);
6354 case NREFFL: /* /\g{name}/il */
6355 { /* The capture buffer cases. The ones beginning with N for the
6356 named buffers just convert to the equivalent numbered and
6357 pretend they were called as the corresponding numbered buffer
6359 /* don't initialize these in the declaration, it makes C++
6364 const U8 *fold_array;
6367 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
6368 folder = foldEQ_locale;
6369 fold_array = PL_fold_locale;
6371 utf8_fold_flags = FOLDEQ_LOCALE;
6374 case NREFFA: /* /\g{name}/iaa */
6375 folder = foldEQ_latin1;
6376 fold_array = PL_fold_latin1;
6378 utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII;
6381 case NREFFU: /* /\g{name}/iu */
6382 folder = foldEQ_latin1;
6383 fold_array = PL_fold_latin1;
6385 utf8_fold_flags = 0;
6388 case NREFF: /* /\g{name}/i */
6390 fold_array = PL_fold;
6392 utf8_fold_flags = 0;
6395 case NREF: /* /\g{name}/ */
6399 utf8_fold_flags = 0;
6402 /* For the named back references, find the corresponding buffer
6404 n = reg_check_named_buff_matched(rex,scan);
6409 goto do_nref_ref_common;
6411 case REFFL: /* /\1/il */
6412 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
6413 folder = foldEQ_locale;
6414 fold_array = PL_fold_locale;
6415 utf8_fold_flags = FOLDEQ_LOCALE;
6418 case REFFA: /* /\1/iaa */
6419 folder = foldEQ_latin1;
6420 fold_array = PL_fold_latin1;
6421 utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII;
6424 case REFFU: /* /\1/iu */
6425 folder = foldEQ_latin1;
6426 fold_array = PL_fold_latin1;
6427 utf8_fold_flags = 0;
6430 case REFF: /* /\1/i */
6432 fold_array = PL_fold;
6433 utf8_fold_flags = 0;
6436 case REF: /* /\1/ */
6439 utf8_fold_flags = 0;
6443 n = ARG(scan); /* which paren pair */
6446 ln = rex->offs[n].start;
6447 reginfo->poscache_iter = reginfo->poscache_maxiter; /* Void cache */
6448 if (rex->lastparen < n || ln == -1)
6449 sayNO; /* Do not match unless seen CLOSEn. */
6450 if (ln == rex->offs[n].end)
6453 s = reginfo->strbeg + ln;
6454 if (type != REF /* REF can do byte comparison */
6455 && (utf8_target || type == REFFU || type == REFFL))
6457 char * limit = reginfo->strend;
6459 /* This call case insensitively compares the entire buffer
6460 * at s, with the current input starting at locinput, but
6461 * not going off the end given by reginfo->strend, and
6462 * returns in <limit> upon success, how much of the
6463 * current input was matched */
6464 if (! foldEQ_utf8_flags(s, NULL, rex->offs[n].end - ln, utf8_target,
6465 locinput, &limit, 0, utf8_target, utf8_fold_flags))
6473 /* Not utf8: Inline the first character, for speed. */
6474 if (!NEXTCHR_IS_EOS &&
6475 UCHARAT(s) != nextchr &&
6477 UCHARAT(s) != fold_array[nextchr]))
6479 ln = rex->offs[n].end - ln;
6480 if (locinput + ln > reginfo->strend)
6482 if (ln > 1 && (type == REF
6483 ? memNE(s, locinput, ln)
6484 : ! folder(s, locinput, ln)))
6490 case NOTHING: /* null op; e.g. the 'nothing' following
6491 * the '*' in m{(a+|b)*}' */
6493 case TAIL: /* placeholder while compiling (A|B|C) */
6497 #define ST st->u.eval
6502 regexp_internal *rei;
6503 regnode *startpoint;
6505 case GOSTART: /* (?R) */
6506 case GOSUB: /* /(...(?1))/ /(...(?&foo))/ */
6507 if (cur_eval && cur_eval->locinput==locinput) {
6508 if (cur_eval->u.eval.close_paren == (U32)ARG(scan))
6509 Perl_croak(aTHX_ "Infinite recursion in regex");
6510 if ( ++nochange_depth > max_nochange_depth )
6512 "Pattern subroutine nesting without pos change"
6513 " exceeded limit in regex");
6520 if (OP(scan)==GOSUB) {
6521 startpoint = scan + ARG2L(scan);
6522 ST.close_paren = ARG(scan);
6524 startpoint = rei->program+1;
6528 /* Save all the positions seen so far. */
6529 ST.cp = regcppush(rex, 0, maxopenparen);
6530 REGCP_SET(ST.lastcp);
6532 /* and then jump to the code we share with EVAL */
6533 goto eval_recurse_doit;
6536 case EVAL: /* /(?{A})B/ /(??{A})B/ and /(?(?{A})X|Y)B/ */
6537 if (cur_eval && cur_eval->locinput==locinput) {
6538 if ( ++nochange_depth > max_nochange_depth )
6539 Perl_croak(aTHX_ "EVAL without pos change exceeded limit in regex");
6544 /* execute the code in the {...} */
6548 OP * const oop = PL_op;
6549 COP * const ocurcop = PL_curcop;
6553 /* save *all* paren positions */
6554 regcppush(rex, 0, maxopenparen);
6555 REGCP_SET(runops_cp);
6558 caller_cv = find_runcv(NULL);
6562 if (rexi->data->what[n] == 'r') { /* code from an external qr */
6564 (REGEXP*)(rexi->data->data[n])
6567 nop = (OP*)rexi->data->data[n+1];
6569 else if (rexi->data->what[n] == 'l') { /* literal code */
6571 nop = (OP*)rexi->data->data[n];
6572 assert(CvDEPTH(newcv));
6575 /* literal with own CV */
6576 assert(rexi->data->what[n] == 'L');
6577 newcv = rex->qr_anoncv;
6578 nop = (OP*)rexi->data->data[n];
6581 /* normally if we're about to execute code from the same
6582 * CV that we used previously, we just use the existing
6583 * CX stack entry. However, its possible that in the
6584 * meantime we may have backtracked, popped from the save
6585 * stack, and undone the SAVECOMPPAD(s) associated with
6586 * PUSH_MULTICALL; in which case PL_comppad no longer
6587 * points to newcv's pad. */
6588 if (newcv != last_pushed_cv || PL_comppad != last_pad)
6590 U8 flags = (CXp_SUB_RE |
6591 ((newcv == caller_cv) ? CXp_SUB_RE_FAKE : 0));
6592 if (last_pushed_cv) {
6593 /* PUSH/POP_MULTICALL save and restore the
6594 * caller's PL_comppad; if we call multiple subs
6595 * using the same CX block, we have to save and
6596 * unwind the varying PL_comppad's ourselves,
6597 * especially restoring the right PL_comppad on
6598 * backtrack - so save it on the save stack */
6600 CHANGE_MULTICALL_FLAGS(newcv, flags);
6603 PUSH_MULTICALL_FLAGS(newcv, flags);
6605 last_pushed_cv = newcv;
6608 /* these assignments are just to silence compiler
6610 multicall_cop = NULL;
6613 last_pad = PL_comppad;
6615 /* the initial nextstate you would normally execute
6616 * at the start of an eval (which would cause error
6617 * messages to come from the eval), may be optimised
6618 * away from the execution path in the regex code blocks;
6619 * so manually set PL_curcop to it initially */
6621 OP *o = cUNOPx(nop)->op_first;
6622 assert(o->op_type == OP_NULL);
6623 if (o->op_targ == OP_SCOPE) {
6624 o = cUNOPo->op_first;
6627 assert(o->op_targ == OP_LEAVE);
6628 o = cUNOPo->op_first;
6629 assert(o->op_type == OP_ENTER);
6633 if (o->op_type != OP_STUB) {
6634 assert( o->op_type == OP_NEXTSTATE
6635 || o->op_type == OP_DBSTATE
6636 || (o->op_type == OP_NULL
6637 && ( o->op_targ == OP_NEXTSTATE
6638 || o->op_targ == OP_DBSTATE
6642 PL_curcop = (COP*)o;
6647 DEBUG_STATE_r( PerlIO_printf(Perl_debug_log,
6648 " re EVAL PL_op=0x%"UVxf"\n", PTR2UV(nop)) );
6650 rex->offs[0].end = locinput - reginfo->strbeg;
6651 if (reginfo->info_aux_eval->pos_magic)
6652 MgBYTEPOS_set(reginfo->info_aux_eval->pos_magic,
6653 reginfo->sv, reginfo->strbeg,
6654 locinput - reginfo->strbeg);
6657 SV *sv_mrk = get_sv("REGMARK", 1);
6658 sv_setsv(sv_mrk, sv_yes_mark);
6661 /* we don't use MULTICALL here as we want to call the
6662 * first op of the block of interest, rather than the
6663 * first op of the sub */
6664 before = (IV)(SP-PL_stack_base);
6666 CALLRUNOPS(aTHX); /* Scalar context. */
6668 if ((IV)(SP-PL_stack_base) == before)
6669 ret = &PL_sv_undef; /* protect against empty (?{}) blocks. */
6675 /* before restoring everything, evaluate the returned
6676 * value, so that 'uninit' warnings don't use the wrong
6677 * PL_op or pad. Also need to process any magic vars
6678 * (e.g. $1) *before* parentheses are restored */
6683 if (logical == 0) /* (?{})/ */
6684 sv_setsv(save_scalar(PL_replgv), ret); /* $^R */
6685 else if (logical == 1) { /* /(?(?{...})X|Y)/ */
6686 sw = cBOOL(SvTRUE(ret));
6689 else { /* /(??{}) */
6690 /* if its overloaded, let the regex compiler handle
6691 * it; otherwise extract regex, or stringify */
6692 if (SvGMAGICAL(ret))
6693 ret = sv_mortalcopy(ret);
6694 if (!SvAMAGIC(ret)) {
6698 if (SvTYPE(sv) == SVt_REGEXP)
6699 re_sv = (REGEXP*) sv;
6700 else if (SvSMAGICAL(ret)) {
6701 MAGIC *mg = mg_find(ret, PERL_MAGIC_qr);
6703 re_sv = (REGEXP *) mg->mg_obj;
6706 /* force any undef warnings here */
6707 if (!re_sv && !SvPOK(ret) && !SvNIOK(ret)) {
6708 ret = sv_mortalcopy(ret);
6709 (void) SvPV_force_nolen(ret);
6715 /* *** Note that at this point we don't restore
6716 * PL_comppad, (or pop the CxSUB) on the assumption it may
6717 * be used again soon. This is safe as long as nothing
6718 * in the regexp code uses the pad ! */
6720 PL_curcop = ocurcop;
6721 S_regcp_restore(aTHX_ rex, runops_cp, &maxopenparen);
6722 PL_curpm = PL_reg_curpm;
6728 /* only /(??{})/ from now on */
6731 /* extract RE object from returned value; compiling if
6735 re_sv = reg_temp_copy(NULL, re_sv);
6740 if (SvUTF8(ret) && IN_BYTES) {
6741 /* In use 'bytes': make a copy of the octet
6742 * sequence, but without the flag on */
6744 const char *const p = SvPV(ret, len);
6745 ret = newSVpvn_flags(p, len, SVs_TEMP);
6747 if (rex->intflags & PREGf_USE_RE_EVAL)
6748 pm_flags |= PMf_USE_RE_EVAL;
6750 /* if we got here, it should be an engine which
6751 * supports compiling code blocks and stuff */
6752 assert(rex->engine && rex->engine->op_comp);
6753 assert(!(scan->flags & ~RXf_PMf_COMPILETIME));
6754 re_sv = rex->engine->op_comp(aTHX_ &ret, 1, NULL,
6755 rex->engine, NULL, NULL,
6756 /* copy /msixn etc to inner pattern */
6761 & (SVs_TEMP | SVs_GMG | SVf_ROK))
6762 && (!SvPADTMP(ret) || SvREADONLY(ret))) {
6763 /* This isn't a first class regexp. Instead, it's
6764 caching a regexp onto an existing, Perl visible
6766 sv_magic(ret, MUTABLE_SV(re_sv), PERL_MAGIC_qr, 0, 0);
6772 RXp_MATCH_COPIED_off(re);
6773 re->subbeg = rex->subbeg;
6774 re->sublen = rex->sublen;
6775 re->suboffset = rex->suboffset;
6776 re->subcoffset = rex->subcoffset;
6778 re->lastcloseparen = 0;
6781 debug_start_match(re_sv, utf8_target, locinput,
6782 reginfo->strend, "Matching embedded");
6784 startpoint = rei->program + 1;
6785 ST.close_paren = 0; /* only used for GOSUB */
6786 /* Save all the seen positions so far. */
6787 ST.cp = regcppush(rex, 0, maxopenparen);
6788 REGCP_SET(ST.lastcp);
6789 /* and set maxopenparen to 0, since we are starting a "fresh" match */
6791 /* run the pattern returned from (??{...}) */
6793 eval_recurse_doit: /* Share code with GOSUB below this line
6794 * At this point we expect the stack context to be
6795 * set up correctly */
6797 /* invalidate the S-L poscache. We're now executing a
6798 * different set of WHILEM ops (and their associated
6799 * indexes) against the same string, so the bits in the
6800 * cache are meaningless. Setting maxiter to zero forces
6801 * the cache to be invalidated and zeroed before reuse.
6802 * XXX This is too dramatic a measure. Ideally we should
6803 * save the old cache and restore when running the outer
6805 reginfo->poscache_maxiter = 0;
6807 /* the new regexp might have a different is_utf8_pat than we do */
6808 is_utf8_pat = reginfo->is_utf8_pat = cBOOL(RX_UTF8(re_sv));
6810 ST.prev_rex = rex_sv;
6811 ST.prev_curlyx = cur_curlyx;
6813 SET_reg_curpm(rex_sv);
6818 ST.prev_eval = cur_eval;
6820 /* now continue from first node in postoned RE */
6821 PUSH_YES_STATE_GOTO(EVAL_AB, startpoint, locinput);
6823 NOT_REACHED; /* NOTREACHED */
6826 case EVAL_AB: /* cleanup after a successful (??{A})B */
6827 /* note: this is called twice; first after popping B, then A */
6828 rex_sv = ST.prev_rex;
6829 is_utf8_pat = reginfo->is_utf8_pat = cBOOL(RX_UTF8(rex_sv));
6830 SET_reg_curpm(rex_sv);
6831 rex = ReANY(rex_sv);
6832 rexi = RXi_GET(rex);
6834 /* preserve $^R across LEAVE's. See Bug 121070. */
6835 SV *save_sv= GvSV(PL_replgv);
6836 SvREFCNT_inc(save_sv);
6837 regcpblow(ST.cp); /* LEAVE in disguise */
6838 sv_setsv(GvSV(PL_replgv), save_sv);
6839 SvREFCNT_dec(save_sv);
6841 cur_eval = ST.prev_eval;
6842 cur_curlyx = ST.prev_curlyx;
6844 /* Invalidate cache. See "invalidate" comment above. */
6845 reginfo->poscache_maxiter = 0;
6846 if ( nochange_depth )
6851 case EVAL_AB_fail: /* unsuccessfully ran A or B in (??{A})B */
6852 /* note: this is called twice; first after popping B, then A */
6853 rex_sv = ST.prev_rex;
6854 is_utf8_pat = reginfo->is_utf8_pat = cBOOL(RX_UTF8(rex_sv));
6855 SET_reg_curpm(rex_sv);
6856 rex = ReANY(rex_sv);
6857 rexi = RXi_GET(rex);
6859 REGCP_UNWIND(ST.lastcp);
6860 regcppop(rex, &maxopenparen);
6861 cur_eval = ST.prev_eval;
6862 cur_curlyx = ST.prev_curlyx;
6863 /* Invalidate cache. See "invalidate" comment above. */
6864 reginfo->poscache_maxiter = 0;
6865 if ( nochange_depth )
6871 n = ARG(scan); /* which paren pair */
6872 rex->offs[n].start_tmp = locinput - reginfo->strbeg;
6873 if (n > maxopenparen)
6875 DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
6876 "rex=0x%"UVxf" offs=0x%"UVxf": \\%"UVuf": set %"IVdf" tmp; maxopenparen=%"UVuf"\n",
6880 (IV)rex->offs[n].start_tmp,
6886 /* XXX really need to log other places start/end are set too */
6887 #define CLOSE_CAPTURE \
6888 rex->offs[n].start = rex->offs[n].start_tmp; \
6889 rex->offs[n].end = locinput - reginfo->strbeg; \
6890 DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log, \
6891 "rex=0x%"UVxf" offs=0x%"UVxf": \\%"UVuf": set %"IVdf"..%"IVdf"\n", \
6893 PTR2UV(rex->offs), \
6895 (IV)rex->offs[n].start, \
6896 (IV)rex->offs[n].end \
6900 n = ARG(scan); /* which paren pair */
6902 if (n > rex->lastparen)
6904 rex->lastcloseparen = n;
6905 if (cur_eval && cur_eval->u.eval.close_paren == n) {
6910 case ACCEPT: /* (*ACCEPT) */
6912 sv_yes_mark = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
6916 cursor && OP(cursor)!=END;
6917 cursor=regnext(cursor))
6919 if ( OP(cursor)==CLOSE ){
6921 if ( n <= lastopen ) {
6923 if (n > rex->lastparen)
6925 rex->lastcloseparen = n;
6926 if ( n == ARG(scan) || (cur_eval &&
6927 cur_eval->u.eval.close_paren == n))
6936 case GROUPP: /* (?(1)) */
6937 n = ARG(scan); /* which paren pair */
6938 sw = cBOOL(rex->lastparen >= n && rex->offs[n].end != -1);
6941 case NGROUPP: /* (?(<name>)) */
6942 /* reg_check_named_buff_matched returns 0 for no match */
6943 sw = cBOOL(0 < reg_check_named_buff_matched(rex,scan));
6946 case INSUBP: /* (?(R)) */
6948 sw = (cur_eval && (!n || cur_eval->u.eval.close_paren == n));
6951 case DEFINEP: /* (?(DEFINE)) */
6955 case IFTHEN: /* (?(cond)A|B) */
6956 reginfo->poscache_iter = reginfo->poscache_maxiter; /* Void cache */
6958 next = NEXTOPER(NEXTOPER(scan));
6960 next = scan + ARG(scan);
6961 if (OP(next) == IFTHEN) /* Fake one. */
6962 next = NEXTOPER(NEXTOPER(next));
6966 case LOGICAL: /* modifier for EVAL and IFMATCH */
6967 logical = scan->flags;
6970 /*******************************************************************
6972 The CURLYX/WHILEM pair of ops handle the most generic case of the /A*B/
6973 pattern, where A and B are subpatterns. (For simple A, CURLYM or
6974 STAR/PLUS/CURLY/CURLYN are used instead.)
6976 A*B is compiled as <CURLYX><A><WHILEM><B>
6978 On entry to the subpattern, CURLYX is called. This pushes a CURLYX
6979 state, which contains the current count, initialised to -1. It also sets
6980 cur_curlyx to point to this state, with any previous value saved in the
6983 CURLYX then jumps straight to the WHILEM op, rather than executing A,
6984 since the pattern may possibly match zero times (i.e. it's a while {} loop
6985 rather than a do {} while loop).
6987 Each entry to WHILEM represents a successful match of A. The count in the
6988 CURLYX block is incremented, another WHILEM state is pushed, and execution
6989 passes to A or B depending on greediness and the current count.
6991 For example, if matching against the string a1a2a3b (where the aN are
6992 substrings that match /A/), then the match progresses as follows: (the
6993 pushed states are interspersed with the bits of strings matched so far):
6996 <CURLYX cnt=0><WHILEM>
6997 <CURLYX cnt=1><WHILEM> a1 <WHILEM>
6998 <CURLYX cnt=2><WHILEM> a1 <WHILEM> a2 <WHILEM>
6999 <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM>
7000 <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM> b
7002 (Contrast this with something like CURLYM, which maintains only a single
7006 a1 <CURLYM cnt=1> a2
7007 a1 a2 <CURLYM cnt=2> a3
7008 a1 a2 a3 <CURLYM cnt=3> b
7011 Each WHILEM state block marks a point to backtrack to upon partial failure
7012 of A or B, and also contains some minor state data related to that
7013 iteration. The CURLYX block, pointed to by cur_curlyx, contains the
7014 overall state, such as the count, and pointers to the A and B ops.
7016 This is complicated slightly by nested CURLYX/WHILEM's. Since cur_curlyx
7017 must always point to the *current* CURLYX block, the rules are:
7019 When executing CURLYX, save the old cur_curlyx in the CURLYX state block,
7020 and set cur_curlyx to point the new block.
7022 When popping the CURLYX block after a successful or unsuccessful match,
7023 restore the previous cur_curlyx.
7025 When WHILEM is about to execute B, save the current cur_curlyx, and set it
7026 to the outer one saved in the CURLYX block.
7028 When popping the WHILEM block after a successful or unsuccessful B match,
7029 restore the previous cur_curlyx.
7031 Here's an example for the pattern (AI* BI)*BO
7032 I and O refer to inner and outer, C and W refer to CURLYX and WHILEM:
7035 curlyx backtrack stack
7036 ------ ---------------
7038 CO <CO prev=NULL> <WO>
7039 CI <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
7040 CO <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
7041 NULL <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi <WO prev=CO> bo
7043 At this point the pattern succeeds, and we work back down the stack to
7044 clean up, restoring as we go:
7046 CO <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
7047 CI <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
7048 CO <CO prev=NULL> <WO>
7051 *******************************************************************/
7053 #define ST st->u.curlyx
7055 case CURLYX: /* start of /A*B/ (for complex A) */
7057 /* No need to save/restore up to this paren */
7058 I32 parenfloor = scan->flags;
7060 assert(next); /* keep Coverity happy */
7061 if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
7064 /* XXXX Probably it is better to teach regpush to support
7065 parenfloor > maxopenparen ... */
7066 if (parenfloor > (I32)rex->lastparen)
7067 parenfloor = rex->lastparen; /* Pessimization... */
7069 ST.prev_curlyx= cur_curlyx;
7071 ST.cp = PL_savestack_ix;
7073 /* these fields contain the state of the current curly.
7074 * they are accessed by subsequent WHILEMs */
7075 ST.parenfloor = parenfloor;
7080 ST.count = -1; /* this will be updated by WHILEM */
7081 ST.lastloc = NULL; /* this will be updated by WHILEM */
7083 PUSH_YES_STATE_GOTO(CURLYX_end, PREVOPER(next), locinput);
7085 NOT_REACHED; /* NOTREACHED */
7088 case CURLYX_end: /* just finished matching all of A*B */
7089 cur_curlyx = ST.prev_curlyx;
7092 NOT_REACHED; /* NOTREACHED */
7094 case CURLYX_end_fail: /* just failed to match all of A*B */
7096 cur_curlyx = ST.prev_curlyx;
7099 NOT_REACHED; /* NOTREACHED */
7103 #define ST st->u.whilem
7105 case WHILEM: /* just matched an A in /A*B/ (for complex A) */
7107 /* see the discussion above about CURLYX/WHILEM */
7112 assert(cur_curlyx); /* keep Coverity happy */
7114 min = ARG1(cur_curlyx->u.curlyx.me);
7115 max = ARG2(cur_curlyx->u.curlyx.me);
7116 A = NEXTOPER(cur_curlyx->u.curlyx.me) + EXTRA_STEP_2ARGS;
7117 n = ++cur_curlyx->u.curlyx.count; /* how many A's matched */
7118 ST.save_lastloc = cur_curlyx->u.curlyx.lastloc;
7119 ST.cache_offset = 0;
7123 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
7124 "%*s whilem: matched %ld out of %d..%d\n",
7125 REPORT_CODE_OFF+depth*2, "", (long)n, min, max)
7128 /* First just match a string of min A's. */
7131 ST.cp = regcppush(rex, cur_curlyx->u.curlyx.parenfloor,
7133 cur_curlyx->u.curlyx.lastloc = locinput;
7134 REGCP_SET(ST.lastcp);
7136 PUSH_STATE_GOTO(WHILEM_A_pre, A, locinput);
7138 NOT_REACHED; /* NOTREACHED */
7141 /* If degenerate A matches "", assume A done. */
7143 if (locinput == cur_curlyx->u.curlyx.lastloc) {
7144 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
7145 "%*s whilem: empty match detected, trying continuation...\n",
7146 REPORT_CODE_OFF+depth*2, "")
7148 goto do_whilem_B_max;
7151 /* super-linear cache processing.
7153 * The idea here is that for certain types of CURLYX/WHILEM -
7154 * principally those whose upper bound is infinity (and
7155 * excluding regexes that have things like \1 and other very
7156 * non-regular expresssiony things), then if a pattern like
7157 * /....A*.../ fails and we backtrack to the WHILEM, then we
7158 * make a note that this particular WHILEM op was at string
7159 * position 47 (say) when the rest of pattern failed. Then, if
7160 * we ever find ourselves back at that WHILEM, and at string
7161 * position 47 again, we can just fail immediately rather than
7162 * running the rest of the pattern again.
7164 * This is very handy when patterns start to go
7165 * 'super-linear', like in (a+)*(a+)*(a+)*, where you end up
7166 * with a combinatorial explosion of backtracking.
7168 * The cache is implemented as a bit array, with one bit per
7169 * string byte position per WHILEM op (up to 16) - so its
7170 * between 0.25 and 2x the string size.
7172 * To avoid allocating a poscache buffer every time, we do an
7173 * initially countdown; only after we have executed a WHILEM
7174 * op (string-length x #WHILEMs) times do we allocate the
7177 * The top 4 bits of scan->flags byte say how many different
7178 * relevant CURLLYX/WHILEM op pairs there are, while the
7179 * bottom 4-bits is the identifying index number of this
7185 if (!reginfo->poscache_maxiter) {
7186 /* start the countdown: Postpone detection until we
7187 * know the match is not *that* much linear. */
7188 reginfo->poscache_maxiter
7189 = (reginfo->strend - reginfo->strbeg + 1)
7191 /* possible overflow for long strings and many CURLYX's */
7192 if (reginfo->poscache_maxiter < 0)
7193 reginfo->poscache_maxiter = I32_MAX;
7194 reginfo->poscache_iter = reginfo->poscache_maxiter;
7197 if (reginfo->poscache_iter-- == 0) {
7198 /* initialise cache */
7199 const SSize_t size = (reginfo->poscache_maxiter + 7)/8;
7200 regmatch_info_aux *const aux = reginfo->info_aux;
7201 if (aux->poscache) {
7202 if ((SSize_t)reginfo->poscache_size < size) {
7203 Renew(aux->poscache, size, char);
7204 reginfo->poscache_size = size;
7206 Zero(aux->poscache, size, char);
7209 reginfo->poscache_size = size;
7210 Newxz(aux->poscache, size, char);
7212 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
7213 "%swhilem: Detected a super-linear match, switching on caching%s...\n",
7214 PL_colors[4], PL_colors[5])
7218 if (reginfo->poscache_iter < 0) {
7219 /* have we already failed at this position? */
7220 SSize_t offset, mask;
7222 reginfo->poscache_iter = -1; /* stop eventual underflow */
7223 offset = (scan->flags & 0xf) - 1
7224 + (locinput - reginfo->strbeg)
7226 mask = 1 << (offset % 8);
7228 if (reginfo->info_aux->poscache[offset] & mask) {
7229 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
7230 "%*s whilem: (cache) already tried at this position...\n",
7231 REPORT_CODE_OFF+depth*2, "")
7233 sayNO; /* cache records failure */
7235 ST.cache_offset = offset;
7236 ST.cache_mask = mask;
7240 /* Prefer B over A for minimal matching. */
7242 if (cur_curlyx->u.curlyx.minmod) {
7243 ST.save_curlyx = cur_curlyx;
7244 cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
7245 ST.cp = regcppush(rex, ST.save_curlyx->u.curlyx.parenfloor,
7247 REGCP_SET(ST.lastcp);
7248 PUSH_YES_STATE_GOTO(WHILEM_B_min, ST.save_curlyx->u.curlyx.B,
7251 NOT_REACHED; /* NOTREACHED */
7254 /* Prefer A over B for maximal matching. */
7256 if (n < max) { /* More greed allowed? */
7257 ST.cp = regcppush(rex, cur_curlyx->u.curlyx.parenfloor,
7259 cur_curlyx->u.curlyx.lastloc = locinput;
7260 REGCP_SET(ST.lastcp);
7261 PUSH_STATE_GOTO(WHILEM_A_max, A, locinput);
7263 NOT_REACHED; /* NOTREACHED */
7265 goto do_whilem_B_max;
7268 NOT_REACHED; /* NOTREACHED */
7270 case WHILEM_B_min: /* just matched B in a minimal match */
7271 case WHILEM_B_max: /* just matched B in a maximal match */
7272 cur_curlyx = ST.save_curlyx;
7275 NOT_REACHED; /* NOTREACHED */
7277 case WHILEM_B_max_fail: /* just failed to match B in a maximal match */
7278 cur_curlyx = ST.save_curlyx;
7279 cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
7280 cur_curlyx->u.curlyx.count--;
7283 NOT_REACHED; /* NOTREACHED */
7285 case WHILEM_A_min_fail: /* just failed to match A in a minimal match */
7287 case WHILEM_A_pre_fail: /* just failed to match even minimal A */
7288 REGCP_UNWIND(ST.lastcp);
7289 regcppop(rex, &maxopenparen);
7290 cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
7291 cur_curlyx->u.curlyx.count--;
7294 NOT_REACHED; /* NOTREACHED */
7296 case WHILEM_A_max_fail: /* just failed to match A in a maximal match */
7297 REGCP_UNWIND(ST.lastcp);
7298 regcppop(rex, &maxopenparen); /* Restore some previous $<digit>s? */
7299 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
7300 "%*s whilem: failed, trying continuation...\n",
7301 REPORT_CODE_OFF+depth*2, "")
7304 if (cur_curlyx->u.curlyx.count >= REG_INFTY
7305 && ckWARN(WARN_REGEXP)
7306 && !reginfo->warned)
7308 reginfo->warned = TRUE;
7309 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7310 "Complex regular subexpression recursion limit (%d) "
7316 ST.save_curlyx = cur_curlyx;
7317 cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
7318 PUSH_YES_STATE_GOTO(WHILEM_B_max, ST.save_curlyx->u.curlyx.B,
7321 NOT_REACHED; /* NOTREACHED */
7323 case WHILEM_B_min_fail: /* just failed to match B in a minimal match */
7324 cur_curlyx = ST.save_curlyx;
7325 REGCP_UNWIND(ST.lastcp);
7326 regcppop(rex, &maxopenparen);
7328 if (cur_curlyx->u.curlyx.count >= /*max*/ARG2(cur_curlyx->u.curlyx.me)) {
7329 /* Maximum greed exceeded */
7330 if (cur_curlyx->u.curlyx.count >= REG_INFTY
7331 && ckWARN(WARN_REGEXP)
7332 && !reginfo->warned)
7334 reginfo->warned = TRUE;
7335 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7336 "Complex regular subexpression recursion "
7337 "limit (%d) exceeded",
7340 cur_curlyx->u.curlyx.count--;
7344 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
7345 "%*s trying longer...\n", REPORT_CODE_OFF+depth*2, "")
7347 /* Try grabbing another A and see if it helps. */
7348 cur_curlyx->u.curlyx.lastloc = locinput;
7349 ST.cp = regcppush(rex, cur_curlyx->u.curlyx.parenfloor,
7351 REGCP_SET(ST.lastcp);
7352 PUSH_STATE_GOTO(WHILEM_A_min,
7353 /*A*/ NEXTOPER(ST.save_curlyx->u.curlyx.me) + EXTRA_STEP_2ARGS,
7356 NOT_REACHED; /* NOTREACHED */
7359 #define ST st->u.branch
7361 case BRANCHJ: /* /(...|A|...)/ with long next pointer */
7362 next = scan + ARG(scan);
7365 scan = NEXTOPER(scan);
7368 case BRANCH: /* /(...|A|...)/ */
7369 scan = NEXTOPER(scan); /* scan now points to inner node */
7370 ST.lastparen = rex->lastparen;
7371 ST.lastcloseparen = rex->lastcloseparen;
7372 ST.next_branch = next;
7375 /* Now go into the branch */
7377 PUSH_YES_STATE_GOTO(BRANCH_next, scan, locinput);
7379 PUSH_STATE_GOTO(BRANCH_next, scan, locinput);
7382 NOT_REACHED; /* NOTREACHED */
7384 case CUTGROUP: /* /(*THEN)/ */
7385 sv_yes_mark = st->u.mark.mark_name = scan->flags
7386 ? MUTABLE_SV(rexi->data->data[ ARG( scan ) ])
7388 PUSH_STATE_GOTO(CUTGROUP_next, next, locinput);
7390 NOT_REACHED; /* NOTREACHED */
7392 case CUTGROUP_next_fail:
7395 if (st->u.mark.mark_name)
7396 sv_commit = st->u.mark.mark_name;
7399 NOT_REACHED; /* NOTREACHED */
7404 NOT_REACHED; /* NOTREACHED */
7406 case BRANCH_next_fail: /* that branch failed; try the next, if any */
7411 REGCP_UNWIND(ST.cp);
7412 UNWIND_PAREN(ST.lastparen, ST.lastcloseparen);
7413 scan = ST.next_branch;
7414 /* no more branches? */
7415 if (!scan || (OP(scan) != BRANCH && OP(scan) != BRANCHJ)) {
7417 PerlIO_printf( Perl_debug_log,
7418 "%*s %sBRANCH failed...%s\n",
7419 REPORT_CODE_OFF+depth*2, "",
7425 continue; /* execute next BRANCH[J] op */
7428 case MINMOD: /* next op will be non-greedy, e.g. A*? */
7433 #define ST st->u.curlym
7435 case CURLYM: /* /A{m,n}B/ where A is fixed-length */
7437 /* This is an optimisation of CURLYX that enables us to push
7438 * only a single backtracking state, no matter how many matches
7439 * there are in {m,n}. It relies on the pattern being constant
7440 * length, with no parens to influence future backrefs
7444 scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
7446 ST.lastparen = rex->lastparen;
7447 ST.lastcloseparen = rex->lastcloseparen;
7449 /* if paren positive, emulate an OPEN/CLOSE around A */
7451 U32 paren = ST.me->flags;
7452 if (paren > maxopenparen)
7453 maxopenparen = paren;
7454 scan += NEXT_OFF(scan); /* Skip former OPEN. */
7462 ST.c1 = CHRTEST_UNINIT;
7465 if (!(ST.minmod ? ARG1(ST.me) : ARG2(ST.me))) /* min/max */
7468 curlym_do_A: /* execute the A in /A{m,n}B/ */
7469 PUSH_YES_STATE_GOTO(CURLYM_A, ST.A, locinput); /* match A */
7471 NOT_REACHED; /* NOTREACHED */
7473 case CURLYM_A: /* we've just matched an A */
7475 /* after first match, determine A's length: u.curlym.alen */
7476 if (ST.count == 1) {
7477 if (reginfo->is_utf8_target) {
7478 char *s = st->locinput;
7479 while (s < locinput) {
7485 ST.alen = locinput - st->locinput;
7488 ST.count = ST.minmod ? ARG1(ST.me) : ARG2(ST.me);
7491 PerlIO_printf(Perl_debug_log,
7492 "%*s CURLYM now matched %"IVdf" times, len=%"IVdf"...\n",
7493 (int)(REPORT_CODE_OFF+(depth*2)), "",
7494 (IV) ST.count, (IV)ST.alen)
7497 if (cur_eval && cur_eval->u.eval.close_paren &&
7498 cur_eval->u.eval.close_paren == (U32)ST.me->flags)
7502 I32 max = (ST.minmod ? ARG1(ST.me) : ARG2(ST.me));
7503 if ( max == REG_INFTY || ST.count < max )
7504 goto curlym_do_A; /* try to match another A */
7506 goto curlym_do_B; /* try to match B */
7508 case CURLYM_A_fail: /* just failed to match an A */
7509 REGCP_UNWIND(ST.cp);
7511 if (ST.minmod || ST.count < ARG1(ST.me) /* min*/
7512 || (cur_eval && cur_eval->u.eval.close_paren &&
7513 cur_eval->u.eval.close_paren == (U32)ST.me->flags))
7516 curlym_do_B: /* execute the B in /A{m,n}B/ */
7517 if (ST.c1 == CHRTEST_UNINIT) {
7518 /* calculate c1 and c2 for possible match of 1st char
7519 * following curly */
7520 ST.c1 = ST.c2 = CHRTEST_VOID;
7522 if (HAS_TEXT(ST.B) || JUMPABLE(ST.B)) {
7523 regnode *text_node = ST.B;
7524 if (! HAS_TEXT(text_node))
7525 FIND_NEXT_IMPT(text_node);
7528 (HAS_TEXT(text_node) && PL_regkind[OP(text_node)] == EXACT)
7530 But the former is redundant in light of the latter.
7532 if this changes back then the macro for
7533 IS_TEXT and friends need to change.
7535 if (PL_regkind[OP(text_node)] == EXACT) {
7536 if (! S_setup_EXACTISH_ST_c1_c2(aTHX_
7537 text_node, &ST.c1, ST.c1_utf8, &ST.c2, ST.c2_utf8,
7547 PerlIO_printf(Perl_debug_log,
7548 "%*s CURLYM trying tail with matches=%"IVdf"...\n",
7549 (int)(REPORT_CODE_OFF+(depth*2)),
7552 if (! NEXTCHR_IS_EOS && ST.c1 != CHRTEST_VOID) {
7553 if (! UTF8_IS_INVARIANT(nextchr) && utf8_target) {
7554 if (memNE(locinput, ST.c1_utf8, UTF8SKIP(locinput))
7555 && memNE(locinput, ST.c2_utf8, UTF8SKIP(locinput)))
7557 /* simulate B failing */
7559 PerlIO_printf(Perl_debug_log,
7560 "%*s CURLYM Fast bail next target=0x%"UVXf" c1=0x%"UVXf" c2=0x%"UVXf"\n",
7561 (int)(REPORT_CODE_OFF+(depth*2)),"",
7562 valid_utf8_to_uvchr((U8 *) locinput, NULL),
7563 valid_utf8_to_uvchr(ST.c1_utf8, NULL),
7564 valid_utf8_to_uvchr(ST.c2_utf8, NULL))
7566 state_num = CURLYM_B_fail;
7567 goto reenter_switch;
7570 else if (nextchr != ST.c1 && nextchr != ST.c2) {
7571 /* simulate B failing */
7573 PerlIO_printf(Perl_debug_log,
7574 "%*s CURLYM Fast bail next target=0x%X c1=0x%X c2=0x%X\n",
7575 (int)(REPORT_CODE_OFF+(depth*2)),"",
7576 (int) nextchr, ST.c1, ST.c2)
7578 state_num = CURLYM_B_fail;
7579 goto reenter_switch;
7584 /* emulate CLOSE: mark current A as captured */
7585 I32 paren = ST.me->flags;
7587 rex->offs[paren].start
7588 = HOPc(locinput, -ST.alen) - reginfo->strbeg;
7589 rex->offs[paren].end = locinput - reginfo->strbeg;
7590 if ((U32)paren > rex->lastparen)
7591 rex->lastparen = paren;
7592 rex->lastcloseparen = paren;
7595 rex->offs[paren].end = -1;
7596 if (cur_eval && cur_eval->u.eval.close_paren &&
7597 cur_eval->u.eval.close_paren == (U32)ST.me->flags)
7606 PUSH_STATE_GOTO(CURLYM_B, ST.B, locinput); /* match B */
7608 NOT_REACHED; /* NOTREACHED */
7610 case CURLYM_B_fail: /* just failed to match a B */
7611 REGCP_UNWIND(ST.cp);
7612 UNWIND_PAREN(ST.lastparen, ST.lastcloseparen);
7614 I32 max = ARG2(ST.me);
7615 if (max != REG_INFTY && ST.count == max)
7617 goto curlym_do_A; /* try to match a further A */
7619 /* backtrack one A */
7620 if (ST.count == ARG1(ST.me) /* min */)
7623 SET_locinput(HOPc(locinput, -ST.alen));
7624 goto curlym_do_B; /* try to match B */
7627 #define ST st->u.curly
7629 #define CURLY_SETPAREN(paren, success) \
7632 rex->offs[paren].start = HOPc(locinput, -1) - reginfo->strbeg; \
7633 rex->offs[paren].end = locinput - reginfo->strbeg; \
7634 if (paren > rex->lastparen) \
7635 rex->lastparen = paren; \
7636 rex->lastcloseparen = paren; \
7639 rex->offs[paren].end = -1; \
7640 rex->lastparen = ST.lastparen; \
7641 rex->lastcloseparen = ST.lastcloseparen; \
7645 case STAR: /* /A*B/ where A is width 1 char */
7649 scan = NEXTOPER(scan);
7652 case PLUS: /* /A+B/ where A is width 1 char */
7656 scan = NEXTOPER(scan);
7659 case CURLYN: /* /(A){m,n}B/ where A is width 1 char */
7660 ST.paren = scan->flags; /* Which paren to set */
7661 ST.lastparen = rex->lastparen;
7662 ST.lastcloseparen = rex->lastcloseparen;
7663 if (ST.paren > maxopenparen)
7664 maxopenparen = ST.paren;
7665 ST.min = ARG1(scan); /* min to match */
7666 ST.max = ARG2(scan); /* max to match */
7667 if (cur_eval && cur_eval->u.eval.close_paren &&
7668 cur_eval->u.eval.close_paren == (U32)ST.paren) {
7672 scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
7675 case CURLY: /* /A{m,n}B/ where A is width 1 char */
7677 ST.min = ARG1(scan); /* min to match */
7678 ST.max = ARG2(scan); /* max to match */
7679 scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
7682 * Lookahead to avoid useless match attempts
7683 * when we know what character comes next.
7685 * Used to only do .*x and .*?x, but now it allows
7686 * for )'s, ('s and (?{ ... })'s to be in the way
7687 * of the quantifier and the EXACT-like node. -- japhy
7690 assert(ST.min <= ST.max);
7691 if (! HAS_TEXT(next) && ! JUMPABLE(next)) {
7692 ST.c1 = ST.c2 = CHRTEST_VOID;
7695 regnode *text_node = next;
7697 if (! HAS_TEXT(text_node))
7698 FIND_NEXT_IMPT(text_node);
7700 if (! HAS_TEXT(text_node))
7701 ST.c1 = ST.c2 = CHRTEST_VOID;
7703 if ( PL_regkind[OP(text_node)] != EXACT ) {
7704 ST.c1 = ST.c2 = CHRTEST_VOID;
7708 /* Currently we only get here when
7710 PL_rekind[OP(text_node)] == EXACT
7712 if this changes back then the macro for IS_TEXT and
7713 friends need to change. */
7714 if (! S_setup_EXACTISH_ST_c1_c2(aTHX_
7715 text_node, &ST.c1, ST.c1_utf8, &ST.c2, ST.c2_utf8,
7727 char *li = locinput;
7730 regrepeat(rex, &li, ST.A, reginfo, ST.min, depth)
7736 if (ST.c1 == CHRTEST_VOID)
7737 goto curly_try_B_min;
7739 ST.oldloc = locinput;
7741 /* set ST.maxpos to the furthest point along the
7742 * string that could possibly match */
7743 if (ST.max == REG_INFTY) {
7744 ST.maxpos = reginfo->strend - 1;
7746 while (UTF8_IS_CONTINUATION(*(U8*)ST.maxpos))
7749 else if (utf8_target) {
7750 int m = ST.max - ST.min;
7751 for (ST.maxpos = locinput;
7752 m >0 && ST.maxpos < reginfo->strend; m--)
7753 ST.maxpos += UTF8SKIP(ST.maxpos);
7756 ST.maxpos = locinput + ST.max - ST.min;
7757 if (ST.maxpos >= reginfo->strend)
7758 ST.maxpos = reginfo->strend - 1;
7760 goto curly_try_B_min_known;
7764 /* avoid taking address of locinput, so it can remain
7766 char *li = locinput;
7767 ST.count = regrepeat(rex, &li, ST.A, reginfo, ST.max, depth);
7768 if (ST.count < ST.min)
7771 if ((ST.count > ST.min)
7772 && (PL_regkind[OP(ST.B)] == EOL) && (OP(ST.B) != MEOL))
7774 /* A{m,n} must come at the end of the string, there's
7775 * no point in backing off ... */
7777 /* ...except that $ and \Z can match before *and* after
7778 newline at the end. Consider "\n\n" =~ /\n+\Z\n/.
7779 We may back off by one in this case. */
7780 if (UCHARAT(locinput - 1) == '\n' && OP(ST.B) != EOS)
7784 goto curly_try_B_max;
7787 NOT_REACHED; /* NOTREACHED */
7789 case CURLY_B_min_known_fail:
7790 /* failed to find B in a non-greedy match where c1,c2 valid */
7792 REGCP_UNWIND(ST.cp);
7794 UNWIND_PAREN(ST.lastparen, ST.lastcloseparen);
7796 /* Couldn't or didn't -- move forward. */
7797 ST.oldloc = locinput;
7799 locinput += UTF8SKIP(locinput);
7803 curly_try_B_min_known:
7804 /* find the next place where 'B' could work, then call B */
7808 n = (ST.oldloc == locinput) ? 0 : 1;
7809 if (ST.c1 == ST.c2) {
7810 /* set n to utf8_distance(oldloc, locinput) */
7811 while (locinput <= ST.maxpos
7812 && memNE(locinput, ST.c1_utf8, UTF8SKIP(locinput)))
7814 locinput += UTF8SKIP(locinput);
7819 /* set n to utf8_distance(oldloc, locinput) */
7820 while (locinput <= ST.maxpos
7821 && memNE(locinput, ST.c1_utf8, UTF8SKIP(locinput))
7822 && memNE(locinput, ST.c2_utf8, UTF8SKIP(locinput)))
7824 locinput += UTF8SKIP(locinput);
7829 else { /* Not utf8_target */
7830 if (ST.c1 == ST.c2) {
7831 while (locinput <= ST.maxpos &&
7832 UCHARAT(locinput) != ST.c1)
7836 while (locinput <= ST.maxpos
7837 && UCHARAT(locinput) != ST.c1
7838 && UCHARAT(locinput) != ST.c2)
7841 n = locinput - ST.oldloc;
7843 if (locinput > ST.maxpos)
7846 /* In /a{m,n}b/, ST.oldloc is at "a" x m, locinput is
7847 * at b; check that everything between oldloc and
7848 * locinput matches */
7849 char *li = ST.oldloc;
7851 if (regrepeat(rex, &li, ST.A, reginfo, n, depth) < n)
7853 assert(n == REG_INFTY || locinput == li);
7855 CURLY_SETPAREN(ST.paren, ST.count);
7856 if (cur_eval && cur_eval->u.eval.close_paren &&
7857 cur_eval->u.eval.close_paren == (U32)ST.paren) {
7860 PUSH_STATE_GOTO(CURLY_B_min_known, ST.B, locinput);
7863 NOT_REACHED; /* NOTREACHED */
7865 case CURLY_B_min_fail:
7866 /* failed to find B in a non-greedy match where c1,c2 invalid */
7868 REGCP_UNWIND(ST.cp);
7870 UNWIND_PAREN(ST.lastparen, ST.lastcloseparen);
7872 /* failed -- move forward one */
7874 char *li = locinput;
7875 if (!regrepeat(rex, &li, ST.A, reginfo, 1, depth)) {
7882 if (ST.count <= ST.max || (ST.max == REG_INFTY &&
7883 ST.count > 0)) /* count overflow ? */
7886 CURLY_SETPAREN(ST.paren, ST.count);
7887 if (cur_eval && cur_eval->u.eval.close_paren &&
7888 cur_eval->u.eval.close_paren == (U32)ST.paren) {
7891 PUSH_STATE_GOTO(CURLY_B_min, ST.B, locinput);
7896 NOT_REACHED; /* NOTREACHED */
7899 /* a successful greedy match: now try to match B */
7900 if (cur_eval && cur_eval->u.eval.close_paren &&
7901 cur_eval->u.eval.close_paren == (U32)ST.paren) {
7905 bool could_match = locinput < reginfo->strend;
7907 /* If it could work, try it. */
7908 if (ST.c1 != CHRTEST_VOID && could_match) {
7909 if (! UTF8_IS_INVARIANT(UCHARAT(locinput)) && utf8_target)
7911 could_match = memEQ(locinput,
7916 UTF8SKIP(locinput));
7919 could_match = UCHARAT(locinput) == ST.c1
7920 || UCHARAT(locinput) == ST.c2;
7923 if (ST.c1 == CHRTEST_VOID || could_match) {
7924 CURLY_SETPAREN(ST.paren, ST.count);
7925 PUSH_STATE_GOTO(CURLY_B_max, ST.B, locinput);
7927 NOT_REACHED; /* NOTREACHED */
7932 case CURLY_B_max_fail:
7933 /* failed to find B in a greedy match */
7935 REGCP_UNWIND(ST.cp);
7937 UNWIND_PAREN(ST.lastparen, ST.lastcloseparen);
7940 if (--ST.count < ST.min)
7942 locinput = HOPc(locinput, -1);
7943 goto curly_try_B_max;
7947 case END: /* last op of main pattern */
7950 /* we've just finished A in /(??{A})B/; now continue with B */
7952 st->u.eval.prev_rex = rex_sv; /* inner */
7954 /* Save *all* the positions. */
7955 st->u.eval.cp = regcppush(rex, 0, maxopenparen);
7956 rex_sv = cur_eval->u.eval.prev_rex;
7957 is_utf8_pat = reginfo->is_utf8_pat = cBOOL(RX_UTF8(rex_sv));
7958 SET_reg_curpm(rex_sv);
7959 rex = ReANY(rex_sv);
7960 rexi = RXi_GET(rex);
7961 cur_curlyx = cur_eval->u.eval.prev_curlyx;
7963 REGCP_SET(st->u.eval.lastcp);
7965 /* Restore parens of the outer rex without popping the
7967 S_regcp_restore(aTHX_ rex, cur_eval->u.eval.lastcp,
7970 st->u.eval.prev_eval = cur_eval;
7971 cur_eval = cur_eval->u.eval.prev_eval;
7973 PerlIO_printf(Perl_debug_log, "%*s EVAL trying tail ... %"UVxf"\n",
7974 REPORT_CODE_OFF+depth*2, "",PTR2UV(cur_eval)););
7975 if ( nochange_depth )
7978 PUSH_YES_STATE_GOTO(EVAL_AB, st->u.eval.prev_eval->u.eval.B,
7979 locinput); /* match B */
7982 if (locinput < reginfo->till) {
7983 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
7984 "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
7986 (long)(locinput - startpos),
7987 (long)(reginfo->till - startpos),
7990 sayNO_SILENT; /* Cannot match: too short. */
7992 sayYES; /* Success! */
7994 case SUCCEED: /* successful SUSPEND/UNLESSM/IFMATCH/CURLYM */
7996 PerlIO_printf(Perl_debug_log,
7997 "%*s %ssubpattern success...%s\n",
7998 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5]));
7999 sayYES; /* Success! */
8002 #define ST st->u.ifmatch
8007 case SUSPEND: /* (?>A) */
8009 newstart = locinput;
8012 case UNLESSM: /* -ve lookaround: (?!A), or with flags, (?<!A) */
8014 goto ifmatch_trivial_fail_test;
8016 case IFMATCH: /* +ve lookaround: (?=A), or with flags, (?<=A) */
8018 ifmatch_trivial_fail_test:
8020 char * const s = HOPBACKc(locinput, scan->flags);
8025 sw = 1 - cBOOL(ST.wanted);
8029 next = scan + ARG(scan);
8037 newstart = locinput;
8041 ST.logical = logical;
8042 logical = 0; /* XXX: reset state of logical once it has been saved into ST */
8044 /* execute body of (?...A) */
8045 PUSH_YES_STATE_GOTO(IFMATCH_A, NEXTOPER(NEXTOPER(scan)), newstart);
8047 NOT_REACHED; /* NOTREACHED */
8050 case IFMATCH_A_fail: /* body of (?...A) failed */
8051 ST.wanted = !ST.wanted;
8054 case IFMATCH_A: /* body of (?...A) succeeded */
8056 sw = cBOOL(ST.wanted);
8058 else if (!ST.wanted)
8061 if (OP(ST.me) != SUSPEND) {
8062 /* restore old position except for (?>...) */
8063 locinput = st->locinput;
8065 scan = ST.me + ARG(ST.me);
8068 continue; /* execute B */
8072 case LONGJMP: /* alternative with many branches compiles to
8073 * (BRANCHJ; EXACT ...; LONGJMP ) x N */
8074 next = scan + ARG(scan);
8079 case COMMIT: /* (*COMMIT) */
8080 reginfo->cutpoint = reginfo->strend;
8083 case PRUNE: /* (*PRUNE) */
8085 sv_yes_mark = sv_commit = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
8086 PUSH_STATE_GOTO(COMMIT_next, next, locinput);
8088 NOT_REACHED; /* NOTREACHED */
8090 case COMMIT_next_fail:
8094 NOT_REACHED; /* NOTREACHED */
8096 case OPFAIL: /* (*FAIL) */
8098 sv_commit = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
8100 /* deal with (?(?!)X|Y) properly,
8101 * make sure we trigger the no branch
8102 * of the trailing IFTHEN structure*/
8109 NOT_REACHED; /* NOTREACHED */
8111 #define ST st->u.mark
8112 case MARKPOINT: /* (*MARK:foo) */
8113 ST.prev_mark = mark_state;
8114 ST.mark_name = sv_commit = sv_yes_mark
8115 = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
8117 ST.mark_loc = locinput;
8118 PUSH_YES_STATE_GOTO(MARKPOINT_next, next, locinput);
8120 NOT_REACHED; /* NOTREACHED */
8122 case MARKPOINT_next:
8123 mark_state = ST.prev_mark;
8126 NOT_REACHED; /* NOTREACHED */
8128 case MARKPOINT_next_fail:
8129 if (popmark && sv_eq(ST.mark_name,popmark))
8131 if (ST.mark_loc > startpoint)
8132 reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1);
8133 popmark = NULL; /* we found our mark */
8134 sv_commit = ST.mark_name;
8137 PerlIO_printf(Perl_debug_log,
8138 "%*s %ssetting cutpoint to mark:%"SVf"...%s\n",
8139 REPORT_CODE_OFF+depth*2, "",
8140 PL_colors[4], SVfARG(sv_commit), PL_colors[5]);
8143 mark_state = ST.prev_mark;
8144 sv_yes_mark = mark_state ?
8145 mark_state->u.mark.mark_name : NULL;
8148 NOT_REACHED; /* NOTREACHED */
8150 case SKIP: /* (*SKIP) */
8152 /* (*SKIP) : if we fail we cut here*/
8153 ST.mark_name = NULL;
8154 ST.mark_loc = locinput;
8155 PUSH_STATE_GOTO(SKIP_next,next, locinput);
8157 /* (*SKIP:NAME) : if there is a (*MARK:NAME) fail where it was,
8158 otherwise do nothing. Meaning we need to scan
8160 regmatch_state *cur = mark_state;
8161 SV *find = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
8164 if ( sv_eq( cur->u.mark.mark_name,
8167 ST.mark_name = find;
8168 PUSH_STATE_GOTO( SKIP_next, next, locinput);
8170 cur = cur->u.mark.prev_mark;
8173 /* Didn't find our (*MARK:NAME) so ignore this (*SKIP:NAME) */
8176 case SKIP_next_fail:
8178 /* (*CUT:NAME) - Set up to search for the name as we
8179 collapse the stack*/
8180 popmark = ST.mark_name;
8182 /* (*CUT) - No name, we cut here.*/
8183 if (ST.mark_loc > startpoint)
8184 reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1);
8185 /* but we set sv_commit to latest mark_name if there
8186 is one so they can test to see how things lead to this
8189 sv_commit=mark_state->u.mark.mark_name;
8194 NOT_REACHED; /* NOTREACHED */
8197 case LNBREAK: /* \R */
8198 if ((n=is_LNBREAK_safe(locinput, reginfo->strend, utf8_target))) {
8205 PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
8206 PTR2UV(scan), OP(scan));
8207 Perl_croak(aTHX_ "regexp memory corruption");
8209 /* this is a point to jump to in order to increment
8210 * locinput by one character */
8212 assert(!NEXTCHR_IS_EOS);
8214 locinput += PL_utf8skip[nextchr];
8215 /* locinput is allowed to go 1 char off the end, but not 2+ */
8216 if (locinput > reginfo->strend)
8225 /* switch break jumps here */
8226 scan = next; /* prepare to execute the next op and ... */
8227 continue; /* ... jump back to the top, reusing st */
8231 /* push a state that backtracks on success */
8232 st->u.yes.prev_yes_state = yes_state;
8236 /* push a new regex state, then continue at scan */
8238 regmatch_state *newst;
8241 regmatch_state *cur = st;
8242 regmatch_state *curyes = yes_state;
8244 regmatch_slab *slab = PL_regmatch_slab;
8245 for (;curd > -1;cur--,curd--) {
8246 if (cur < SLAB_FIRST(slab)) {
8248 cur = SLAB_LAST(slab);
8250 PerlIO_printf(Perl_error_log, "%*s#%-3d %-10s %s\n",
8251 REPORT_CODE_OFF + 2 + depth * 2,"",
8252 curd, PL_reg_name[cur->resume_state],
8253 (curyes == cur) ? "yes" : ""
8256 curyes = cur->u.yes.prev_yes_state;
8259 DEBUG_STATE_pp("push")
8262 st->locinput = locinput;
8264 if (newst > SLAB_LAST(PL_regmatch_slab))
8265 newst = S_push_slab(aTHX);
8266 PL_regmatch_state = newst;
8268 locinput = pushinput;
8276 * We get here only if there's trouble -- normally "case END" is
8277 * the terminating point.
8279 Perl_croak(aTHX_ "corrupted regexp pointers");
8282 NOT_REACHED; /* NOTREACHED */
8286 /* we have successfully completed a subexpression, but we must now
8287 * pop to the state marked by yes_state and continue from there */
8288 assert(st != yes_state);
8290 while (st != yes_state) {
8292 if (st < SLAB_FIRST(PL_regmatch_slab)) {
8293 PL_regmatch_slab = PL_regmatch_slab->prev;
8294 st = SLAB_LAST(PL_regmatch_slab);
8298 DEBUG_STATE_pp("pop (no final)");
8300 DEBUG_STATE_pp("pop (yes)");
8306 while (yes_state < SLAB_FIRST(PL_regmatch_slab)
8307 || yes_state > SLAB_LAST(PL_regmatch_slab))
8309 /* not in this slab, pop slab */
8310 depth -= (st - SLAB_FIRST(PL_regmatch_slab) + 1);
8311 PL_regmatch_slab = PL_regmatch_slab->prev;
8312 st = SLAB_LAST(PL_regmatch_slab);
8314 depth -= (st - yes_state);
8317 yes_state = st->u.yes.prev_yes_state;
8318 PL_regmatch_state = st;
8321 locinput= st->locinput;
8322 state_num = st->resume_state + no_final;
8323 goto reenter_switch;
8326 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
8327 PL_colors[4], PL_colors[5]));
8329 if (reginfo->info_aux_eval) {
8330 /* each successfully executed (?{...}) block does the equivalent of
8331 * local $^R = do {...}
8332 * When popping the save stack, all these locals would be undone;
8333 * bypass this by setting the outermost saved $^R to the latest
8335 /* I dont know if this is needed or works properly now.
8336 * see code related to PL_replgv elsewhere in this file.
8339 if (oreplsv != GvSV(PL_replgv))
8340 sv_setsv(oreplsv, GvSV(PL_replgv));
8347 PerlIO_printf(Perl_debug_log,
8348 "%*s %sfailed...%s\n",
8349 REPORT_CODE_OFF+depth*2, "",
8350 PL_colors[4], PL_colors[5])
8362 /* there's a previous state to backtrack to */
8364 if (st < SLAB_FIRST(PL_regmatch_slab)) {
8365 PL_regmatch_slab = PL_regmatch_slab->prev;
8366 st = SLAB_LAST(PL_regmatch_slab);
8368 PL_regmatch_state = st;
8369 locinput= st->locinput;
8371 DEBUG_STATE_pp("pop");
8373 if (yes_state == st)
8374 yes_state = st->u.yes.prev_yes_state;
8376 state_num = st->resume_state + 1; /* failure = success + 1 */
8377 goto reenter_switch;
8382 if (rex->intflags & PREGf_VERBARG_SEEN) {
8383 SV *sv_err = get_sv("REGERROR", 1);
8384 SV *sv_mrk = get_sv("REGMARK", 1);
8386 sv_commit = &PL_sv_no;
8388 sv_yes_mark = &PL_sv_yes;
8391 sv_commit = &PL_sv_yes;
8392 sv_yes_mark = &PL_sv_no;
8396 sv_setsv(sv_err, sv_commit);
8397 sv_setsv(sv_mrk, sv_yes_mark);
8401 if (last_pushed_cv) {
8404 PERL_UNUSED_VAR(SP);
8407 assert(!result || locinput - reginfo->strbeg >= 0);
8408 return result ? locinput - reginfo->strbeg : -1;
8412 - regrepeat - repeatedly match something simple, report how many
8414 * What 'simple' means is a node which can be the operand of a quantifier like
8417 * startposp - pointer a pointer to the start position. This is updated
8418 * to point to the byte following the highest successful
8420 * p - the regnode to be repeatedly matched against.
8421 * reginfo - struct holding match state, such as strend
8422 * max - maximum number of things to match.
8423 * depth - (for debugging) backtracking depth.
8426 S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p,
8427 regmatch_info *const reginfo, I32 max, int depth)
8429 char *scan; /* Pointer to current position in target string */
8431 char *loceol = reginfo->strend; /* local version */
8432 I32 hardcount = 0; /* How many matches so far */
8433 bool utf8_target = reginfo->is_utf8_target;
8434 unsigned int to_complement = 0; /* Invert the result? */
8436 _char_class_number classnum;
8438 PERL_UNUSED_ARG(depth);
8441 PERL_ARGS_ASSERT_REGREPEAT;
8444 if (max == REG_INFTY)
8446 else if (! utf8_target && loceol - scan > max)
8447 loceol = scan + max;
8449 /* Here, for the case of a non-UTF-8 target we have adjusted <loceol> down
8450 * to the maximum of how far we should go in it (leaving it set to the real
8451 * end, if the maximum permissible would take us beyond that). This allows
8452 * us to make the loop exit condition that we haven't gone past <loceol> to
8453 * also mean that we haven't exceeded the max permissible count, saving a
8454 * test each time through the loop. But it assumes that the OP matches a
8455 * single byte, which is true for most of the OPs below when applied to a
8456 * non-UTF-8 target. Those relatively few OPs that don't have this
8457 * characteristic will have to compensate.
8459 * There is no adjustment for UTF-8 targets, as the number of bytes per
8460 * character varies. OPs will have to test both that the count is less
8461 * than the max permissible (using <hardcount> to keep track), and that we
8462 * are still within the bounds of the string (using <loceol>. A few OPs
8463 * match a single byte no matter what the encoding. They can omit the max
8464 * test if, for the UTF-8 case, they do the adjustment that was skipped
8467 * Thus, the code above sets things up for the common case; and exceptional
8468 * cases need extra work; the common case is to make sure <scan> doesn't
8469 * go past <loceol>, and for UTF-8 to also use <hardcount> to make sure the
8470 * count doesn't exceed the maximum permissible */
8475 while (scan < loceol && hardcount < max && *scan != '\n') {
8476 scan += UTF8SKIP(scan);
8480 while (scan < loceol && *scan != '\n')
8486 while (scan < loceol && hardcount < max) {
8487 scan += UTF8SKIP(scan);
8495 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
8496 if (utf8_target && UTF8_IS_ABOVE_LATIN1(*scan)) {
8497 _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(scan, loceol);
8501 assert(STR_LEN(p) == reginfo->is_utf8_pat ? UTF8SKIP(STRING(p)) : 1);
8505 /* Can use a simple loop if the pattern char to match on is invariant
8506 * under UTF-8, or both target and pattern aren't UTF-8. Note that we
8507 * can use UTF8_IS_INVARIANT() even if the pattern isn't UTF-8, as it's
8508 * true iff it doesn't matter if the argument is in UTF-8 or not */
8509 if (UTF8_IS_INVARIANT(c) || (! utf8_target && ! reginfo->is_utf8_pat)) {
8510 if (utf8_target && loceol - scan > max) {
8511 /* We didn't adjust <loceol> because is UTF-8, but ok to do so,
8512 * since here, to match at all, 1 char == 1 byte */
8513 loceol = scan + max;
8515 while (scan < loceol && UCHARAT(scan) == c) {
8519 else if (reginfo->is_utf8_pat) {
8521 STRLEN scan_char_len;
8523 /* When both target and pattern are UTF-8, we have to do
8525 while (hardcount < max
8527 && (scan_char_len = UTF8SKIP(scan)) <= STR_LEN(p)
8528 && memEQ(scan, STRING(p), scan_char_len))
8530 scan += scan_char_len;
8534 else if (! UTF8_IS_ABOVE_LATIN1(c)) {
8536 /* Target isn't utf8; convert the character in the UTF-8
8537 * pattern to non-UTF8, and do a simple loop */
8538 c = EIGHT_BIT_UTF8_TO_NATIVE(c, *(STRING(p) + 1));
8539 while (scan < loceol && UCHARAT(scan) == c) {
8542 } /* else pattern char is above Latin1, can't possibly match the
8547 /* Here, the string must be utf8; pattern isn't, and <c> is
8548 * different in utf8 than not, so can't compare them directly.
8549 * Outside the loop, find the two utf8 bytes that represent c, and
8550 * then look for those in sequence in the utf8 string */
8551 U8 high = UTF8_TWO_BYTE_HI(c);
8552 U8 low = UTF8_TWO_BYTE_LO(c);
8554 while (hardcount < max
8555 && scan + 1 < loceol
8556 && UCHARAT(scan) == high
8557 && UCHARAT(scan + 1) == low)
8565 case EXACTFA_NO_TRIE: /* This node only generated for non-utf8 patterns */
8566 assert(! reginfo->is_utf8_pat);
8569 utf8_flags = FOLDEQ_UTF8_NOMIX_ASCII;
8573 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
8574 utf8_flags = FOLDEQ_LOCALE;
8577 case EXACTF: /* This node only generated for non-utf8 patterns */
8578 assert(! reginfo->is_utf8_pat);
8583 if (! utf8_target) {
8586 utf8_flags = FOLDEQ_LOCALE | FOLDEQ_S2_ALREADY_FOLDED
8587 | FOLDEQ_S2_FOLDS_SANE;
8592 utf8_flags = reginfo->is_utf8_pat ? FOLDEQ_S2_ALREADY_FOLDED : 0;
8596 U8 c1_utf8[UTF8_MAXBYTES+1], c2_utf8[UTF8_MAXBYTES+1];
8598 assert(STR_LEN(p) == reginfo->is_utf8_pat ? UTF8SKIP(STRING(p)) : 1);
8600 if (S_setup_EXACTISH_ST_c1_c2(aTHX_ p, &c1, c1_utf8, &c2, c2_utf8,
8603 if (c1 == CHRTEST_VOID) {
8604 /* Use full Unicode fold matching */
8605 char *tmpeol = reginfo->strend;
8606 STRLEN pat_len = reginfo->is_utf8_pat ? UTF8SKIP(STRING(p)) : 1;
8607 while (hardcount < max
8608 && foldEQ_utf8_flags(scan, &tmpeol, 0, utf8_target,
8609 STRING(p), NULL, pat_len,
8610 reginfo->is_utf8_pat, utf8_flags))
8613 tmpeol = reginfo->strend;
8617 else if (utf8_target) {
8619 while (scan < loceol
8621 && memEQ(scan, c1_utf8, UTF8SKIP(scan)))
8623 scan += UTF8SKIP(scan);
8628 while (scan < loceol
8630 && (memEQ(scan, c1_utf8, UTF8SKIP(scan))
8631 || memEQ(scan, c2_utf8, UTF8SKIP(scan))))
8633 scan += UTF8SKIP(scan);
8638 else if (c1 == c2) {
8639 while (scan < loceol && UCHARAT(scan) == c1) {
8644 while (scan < loceol &&
8645 (UCHARAT(scan) == c1 || UCHARAT(scan) == c2))
8654 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
8656 if (ANYOFL_UTF8_LOCALE_REQD(FLAGS(p)) && ! IN_UTF8_CTYPE_LOCALE) {
8657 Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE), utf8_locale_required);
8663 while (hardcount < max
8665 && reginclass(prog, p, (U8*)scan, (U8*) loceol, utf8_target))
8667 scan += UTF8SKIP(scan);
8671 while (scan < loceol && REGINCLASS(prog, p, (U8*)scan))
8676 /* The argument (FLAGS) to all the POSIX node types is the class number */
8683 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
8684 if (! utf8_target) {
8685 while (scan < loceol && to_complement ^ cBOOL(isFOO_lc(FLAGS(p),
8691 while (hardcount < max && scan < loceol
8692 && to_complement ^ cBOOL(isFOO_utf8_lc(FLAGS(p),
8695 scan += UTF8SKIP(scan);
8708 if (utf8_target && loceol - scan > max) {
8710 /* We didn't adjust <loceol> at the beginning of this routine
8711 * because is UTF-8, but it is actually ok to do so, since here, to
8712 * match, 1 char == 1 byte. */
8713 loceol = scan + max;
8715 while (scan < loceol && _generic_isCC_A((U8) *scan, FLAGS(p))) {
8728 if (! utf8_target) {
8729 while (scan < loceol && ! _generic_isCC_A((U8) *scan, FLAGS(p))) {
8735 /* The complement of something that matches only ASCII matches all
8736 * non-ASCII, plus everything in ASCII that isn't in the class. */
8737 while (hardcount < max && scan < loceol
8738 && (! isASCII_utf8(scan)
8739 || ! _generic_isCC_A((U8) *scan, FLAGS(p))))
8741 scan += UTF8SKIP(scan);
8752 if (! utf8_target) {
8753 while (scan < loceol && to_complement
8754 ^ cBOOL(_generic_isCC((U8) *scan, FLAGS(p))))
8761 classnum = (_char_class_number) FLAGS(p);
8762 if (classnum < _FIRST_NON_SWASH_CC) {
8764 /* Here, a swash is needed for above-Latin1 code points.
8765 * Process as many Latin1 code points using the built-in rules.
8766 * Go to another loop to finish processing upon encountering
8767 * the first Latin1 code point. We could do that in this loop
8768 * as well, but the other way saves having to test if the swash
8769 * has been loaded every time through the loop: extra space to
8771 while (hardcount < max && scan < loceol) {
8772 if (UTF8_IS_INVARIANT(*scan)) {
8773 if (! (to_complement ^ cBOOL(_generic_isCC((U8) *scan,
8780 else if (UTF8_IS_DOWNGRADEABLE_START(*scan)) {
8781 if (! (to_complement
8782 ^ cBOOL(_generic_isCC(EIGHT_BIT_UTF8_TO_NATIVE(*scan,
8791 goto found_above_latin1;
8798 /* For these character classes, the knowledge of how to handle
8799 * every code point is compiled in to Perl via a macro. This
8800 * code is written for making the loops as tight as possible.
8801 * It could be refactored to save space instead */
8803 case _CC_ENUM_SPACE:
8804 while (hardcount < max
8806 && (to_complement ^ cBOOL(isSPACE_utf8(scan))))
8808 scan += UTF8SKIP(scan);
8812 case _CC_ENUM_BLANK:
8813 while (hardcount < max
8815 && (to_complement ^ cBOOL(isBLANK_utf8(scan))))
8817 scan += UTF8SKIP(scan);
8821 case _CC_ENUM_XDIGIT:
8822 while (hardcount < max
8824 && (to_complement ^ cBOOL(isXDIGIT_utf8(scan))))
8826 scan += UTF8SKIP(scan);
8830 case _CC_ENUM_VERTSPACE:
8831 while (hardcount < max
8833 && (to_complement ^ cBOOL(isVERTWS_utf8(scan))))
8835 scan += UTF8SKIP(scan);
8839 case _CC_ENUM_CNTRL:
8840 while (hardcount < max
8842 && (to_complement ^ cBOOL(isCNTRL_utf8(scan))))
8844 scan += UTF8SKIP(scan);
8849 Perl_croak(aTHX_ "panic: regrepeat() node %d='%s' has an unexpected character class '%d'", OP(p), PL_reg_name[OP(p)], classnum);
8855 found_above_latin1: /* Continuation of POSIXU and NPOSIXU */
8857 /* Load the swash if not already present */
8858 if (! PL_utf8_swash_ptrs[classnum]) {
8859 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
8860 PL_utf8_swash_ptrs[classnum] = _core_swash_init(
8864 PL_XPosix_ptrs[classnum], &flags);
8867 while (hardcount < max && scan < loceol
8868 && to_complement ^ cBOOL(_generic_utf8(
8871 swash_fetch(PL_utf8_swash_ptrs[classnum],
8875 scan += UTF8SKIP(scan);
8882 while (hardcount < max && scan < loceol &&
8883 (c=is_LNBREAK_utf8_safe(scan, loceol))) {
8888 /* LNBREAK can match one or two latin chars, which is ok, but we
8889 * have to use hardcount in this situation, and throw away the
8890 * adjustment to <loceol> done before the switch statement */
8891 loceol = reginfo->strend;
8892 while (scan < loceol && (c=is_LNBREAK_latin1_safe(scan, loceol))) {
8901 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
8915 /* These are all 0 width, so match right here or not at all. */
8919 Perl_croak(aTHX_ "panic: regrepeat() called with unrecognized node type %d='%s'", OP(p), PL_reg_name[OP(p)]);
8921 NOT_REACHED; /* NOTREACHED */
8928 c = scan - *startposp;
8932 GET_RE_DEBUG_FLAGS_DECL;
8934 SV * const prop = sv_newmortal();
8935 regprop(prog, prop, p, reginfo, NULL);
8936 PerlIO_printf(Perl_debug_log,
8937 "%*s %s can match %"IVdf" times out of %"IVdf"...\n",
8938 REPORT_CODE_OFF + depth*2, "", SvPVX_const(prop),(IV)c,(IV)max);
8946 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
8948 - regclass_swash - prepare the utf8 swash. Wraps the shared core version to
8949 create a copy so that changes the caller makes won't change the shared one.
8950 If <altsvp> is non-null, will return NULL in it, for back-compat.
8953 Perl_regclass_swash(pTHX_ const regexp *prog, const regnode* node, bool doinit, SV** listsvp, SV **altsvp)
8955 PERL_ARGS_ASSERT_REGCLASS_SWASH;
8961 return newSVsv(_get_regclass_nonbitmap_data(prog, node, doinit, listsvp, NULL, NULL));
8964 #endif /* !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION) */
8967 - reginclass - determine if a character falls into a character class
8969 n is the ANYOF-type regnode
8970 p is the target string
8971 p_end points to one byte beyond the end of the target string
8972 utf8_target tells whether p is in UTF-8.
8974 Returns true if matched; false otherwise.
8976 Note that this can be a synthetic start class, a combination of various
8977 nodes, so things you think might be mutually exclusive, such as locale,
8978 aren't. It can match both locale and non-locale
8983 S_reginclass(pTHX_ regexp * const prog, const regnode * const n, const U8* const p, const U8* const p_end, const bool utf8_target)
8986 const char flags = ANYOF_FLAGS(n);
8990 PERL_ARGS_ASSERT_REGINCLASS;
8992 /* If c is not already the code point, get it. Note that
8993 * UTF8_IS_INVARIANT() works even if not in UTF-8 */
8994 if (! UTF8_IS_INVARIANT(c) && utf8_target) {
8996 c = utf8n_to_uvchr(p, p_end - p, &c_len,
8997 (UTF8_ALLOW_DEFAULT & UTF8_ALLOW_ANYUV)
8998 | UTF8_ALLOW_FFFF | UTF8_CHECK_ONLY);
8999 /* see [perl #37836] for UTF8_ALLOW_ANYUV; [perl #38293] for
9000 * UTF8_ALLOW_FFFF */
9001 if (c_len == (STRLEN)-1)
9002 Perl_croak(aTHX_ "Malformed UTF-8 character (fatal)");
9003 if (c > 255 && OP(n) == ANYOFL && ! ANYOFL_UTF8_LOCALE_REQD(flags)) {
9004 _CHECK_AND_OUTPUT_WIDE_LOCALE_CP_MSG(c);
9008 /* If this character is potentially in the bitmap, check it */
9009 if (c < NUM_ANYOF_CODE_POINTS) {
9010 if (ANYOF_BITMAP_TEST(n, c))
9013 & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER)
9020 else if (flags & ANYOF_LOCALE_FLAGS) {
9021 if ((flags & ANYOFL_FOLD)
9023 && ANYOF_BITMAP_TEST(n, PL_fold_locale[c]))
9027 else if (ANYOF_POSIXL_TEST_ANY_SET(n)
9031 /* The data structure is arranged so bits 0, 2, 4, ... are set
9032 * if the class includes the Posix character class given by
9033 * bit/2; and 1, 3, 5, ... are set if the class includes the
9034 * complemented Posix class given by int(bit/2). So we loop
9035 * through the bits, each time changing whether we complement
9036 * the result or not. Suppose for the sake of illustration
9037 * that bits 0-3 mean respectively, \w, \W, \s, \S. If bit 0
9038 * is set, it means there is a match for this ANYOF node if the
9039 * character is in the class given by the expression (0 / 2 = 0
9040 * = \w). If it is in that class, isFOO_lc() will return 1,
9041 * and since 'to_complement' is 0, the result will stay TRUE,
9042 * and we exit the loop. Suppose instead that bit 0 is 0, but
9043 * bit 1 is 1. That means there is a match if the character
9044 * matches \W. We won't bother to call isFOO_lc() on bit 0,
9045 * but will on bit 1. On the second iteration 'to_complement'
9046 * will be 1, so the exclusive or will reverse things, so we
9047 * are testing for \W. On the third iteration, 'to_complement'
9048 * will be 0, and we would be testing for \s; the fourth
9049 * iteration would test for \S, etc.
9051 * Note that this code assumes that all the classes are closed
9052 * under folding. For example, if a character matches \w, then
9053 * its fold does too; and vice versa. This should be true for
9054 * any well-behaved locale for all the currently defined Posix
9055 * classes, except for :lower: and :upper:, which are handled
9056 * by the pseudo-class :cased: which matches if either of the
9057 * other two does. To get rid of this assumption, an outer
9058 * loop could be used below to iterate over both the source
9059 * character, and its fold (if different) */
9062 int to_complement = 0;
9064 while (count < ANYOF_MAX) {
9065 if (ANYOF_POSIXL_TEST(n, count)
9066 && to_complement ^ cBOOL(isFOO_lc(count/2, (U8) c)))
9079 /* If the bitmap didn't (or couldn't) match, and something outside the
9080 * bitmap could match, try that. */
9082 if (c >= NUM_ANYOF_CODE_POINTS
9083 && (flags & ANYOF_MATCHES_ALL_ABOVE_BITMAP))
9085 match = TRUE; /* Everything above the bitmap matches */
9087 /* Here doesn't match everything above the bitmap. If there is
9088 * some information available beyond the bitmap, we may find a
9089 * match in it. If so, this is most likely because the code point
9090 * is outside the bitmap range. But rarely, it could be because of
9091 * some other reason. If so, various flags are set to indicate
9092 * this possibility. On ANYOFD nodes, there may be matches that
9093 * happen only when the target string is UTF-8; or for other node
9094 * types, because runtime lookup is needed, regardless of the
9095 * UTF-8ness of the target string. Finally, under /il, there may
9096 * be some matches only possible if the locale is a UTF-8 one. */
9097 else if ( ARG(n) != ANYOF_ONLY_HAS_BITMAP
9098 && ( c >= NUM_ANYOF_CODE_POINTS
9099 || ( (flags & ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP)
9100 && ( UNLIKELY(OP(n) != ANYOFD)
9101 || (utf8_target && ! isASCII_uni(c)
9102 # if NUM_ANYOF_CODE_POINTS > 256
9106 || ( ANYOFL_SOME_FOLDS_ONLY_IN_UTF8_LOCALE(flags)
9107 && IN_UTF8_CTYPE_LOCALE)))
9109 SV* only_utf8_locale = NULL;
9110 SV * const sw = _get_regclass_nonbitmap_data(prog, n, TRUE, 0,
9111 &only_utf8_locale, NULL);
9117 } else { /* Convert to utf8 */
9118 utf8_p = utf8_buffer;
9119 append_utf8_from_native_byte(*p, &utf8_p);
9120 utf8_p = utf8_buffer;
9123 if (swash_fetch(sw, utf8_p, TRUE)) {
9127 if (! match && only_utf8_locale && IN_UTF8_CTYPE_LOCALE) {
9128 match = _invlist_contains_cp(only_utf8_locale, c);
9132 if (UNICODE_IS_SUPER(c)
9134 & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER)
9136 && ckWARN_d(WARN_NON_UNICODE))
9138 Perl_warner(aTHX_ packWARN(WARN_NON_UNICODE),
9139 "Matched non-Unicode code point 0x%04"UVXf" against Unicode property; may not be portable", c);
9143 #if ANYOF_INVERT != 1
9144 /* Depending on compiler optimization cBOOL takes time, so if don't have to
9146 # error ANYOF_INVERT needs to be set to 1, or guarded with cBOOL below,
9149 /* The xor complements the return if to invert: 1^1 = 0, 1^0 = 1 */
9150 return (flags & ANYOF_INVERT) ^ match;
9154 S_reghop3(U8 *s, SSize_t off, const U8* lim)
9156 /* return the position 'off' UTF-8 characters away from 's', forward if
9157 * 'off' >= 0, backwards if negative. But don't go outside of position
9158 * 'lim', which better be < s if off < 0 */
9160 PERL_ARGS_ASSERT_REGHOP3;
9163 while (off-- && s < lim) {
9164 /* XXX could check well-formedness here */
9169 while (off++ && s > lim) {
9171 if (UTF8_IS_CONTINUED(*s)) {
9172 while (s > lim && UTF8_IS_CONTINUATION(*s))
9174 if (! UTF8_IS_START(*s)) {
9175 Perl_croak_nocontext("Malformed UTF-8 character (fatal)");
9178 /* XXX could check well-formedness here */
9185 S_reghop4(U8 *s, SSize_t off, const U8* llim, const U8* rlim)
9187 PERL_ARGS_ASSERT_REGHOP4;
9190 while (off-- && s < rlim) {
9191 /* XXX could check well-formedness here */
9196 while (off++ && s > llim) {
9198 if (UTF8_IS_CONTINUED(*s)) {
9199 while (s > llim && UTF8_IS_CONTINUATION(*s))
9201 if (! UTF8_IS_START(*s)) {
9202 Perl_croak_nocontext("Malformed UTF-8 character (fatal)");
9205 /* XXX could check well-formedness here */
9211 /* like reghop3, but returns NULL on overrun, rather than returning last
9215 S_reghopmaybe3(U8* s, SSize_t off, const U8* lim)
9217 PERL_ARGS_ASSERT_REGHOPMAYBE3;
9220 while (off-- && s < lim) {
9221 /* XXX could check well-formedness here */
9228 while (off++ && s > lim) {
9230 if (UTF8_IS_CONTINUED(*s)) {
9231 while (s > lim && UTF8_IS_CONTINUATION(*s))
9233 if (! UTF8_IS_START(*s)) {
9234 Perl_croak_nocontext("Malformed UTF-8 character (fatal)");
9237 /* XXX could check well-formedness here */
9246 /* when executing a regex that may have (?{}), extra stuff needs setting
9247 up that will be visible to the called code, even before the current
9248 match has finished. In particular:
9250 * $_ is localised to the SV currently being matched;
9251 * pos($_) is created if necessary, ready to be updated on each call-out
9253 * a fake PMOP is created that can be set to PL_curpm (normally PL_curpm
9254 isn't set until the current pattern is successfully finished), so that
9255 $1 etc of the match-so-far can be seen;
9256 * save the old values of subbeg etc of the current regex, and set then
9257 to the current string (again, this is normally only done at the end
9262 S_setup_eval_state(pTHX_ regmatch_info *const reginfo)
9265 regexp *const rex = ReANY(reginfo->prog);
9266 regmatch_info_aux_eval *eval_state = reginfo->info_aux_eval;
9268 eval_state->rex = rex;
9271 /* Make $_ available to executed code. */
9272 if (reginfo->sv != DEFSV) {
9274 DEFSV_set(reginfo->sv);
9277 if (!(mg = mg_find_mglob(reginfo->sv))) {
9278 /* prepare for quick setting of pos */
9279 mg = sv_magicext_mglob(reginfo->sv);
9282 eval_state->pos_magic = mg;
9283 eval_state->pos = mg->mg_len;
9284 eval_state->pos_flags = mg->mg_flags;
9287 eval_state->pos_magic = NULL;
9289 if (!PL_reg_curpm) {
9290 /* PL_reg_curpm is a fake PMOP that we can attach the current
9291 * regex to and point PL_curpm at, so that $1 et al are visible
9292 * within a /(?{})/. It's just allocated once per interpreter the
9293 * first time its needed */
9294 Newxz(PL_reg_curpm, 1, PMOP);
9297 SV* const repointer = &PL_sv_undef;
9298 /* this regexp is also owned by the new PL_reg_curpm, which
9299 will try to free it. */
9300 av_push(PL_regex_padav, repointer);
9301 PL_reg_curpm->op_pmoffset = av_tindex(PL_regex_padav);
9302 PL_regex_pad = AvARRAY(PL_regex_padav);
9306 SET_reg_curpm(reginfo->prog);
9307 eval_state->curpm = PL_curpm;
9308 PL_curpm = PL_reg_curpm;
9309 if (RXp_MATCH_COPIED(rex)) {
9310 /* Here is a serious problem: we cannot rewrite subbeg,
9311 since it may be needed if this match fails. Thus
9312 $` inside (?{}) could fail... */
9313 eval_state->subbeg = rex->subbeg;
9314 eval_state->sublen = rex->sublen;
9315 eval_state->suboffset = rex->suboffset;
9316 eval_state->subcoffset = rex->subcoffset;
9318 eval_state->saved_copy = rex->saved_copy;
9320 RXp_MATCH_COPIED_off(rex);
9323 eval_state->subbeg = NULL;
9324 rex->subbeg = (char *)reginfo->strbeg;
9326 rex->subcoffset = 0;
9327 rex->sublen = reginfo->strend - reginfo->strbeg;
9331 /* destructor to clear up regmatch_info_aux and regmatch_info_aux_eval */
9334 S_cleanup_regmatch_info_aux(pTHX_ void *arg)
9336 regmatch_info_aux *aux = (regmatch_info_aux *) arg;
9337 regmatch_info_aux_eval *eval_state = aux->info_aux_eval;
9340 Safefree(aux->poscache);
9344 /* undo the effects of S_setup_eval_state() */
9346 if (eval_state->subbeg) {
9347 regexp * const rex = eval_state->rex;
9348 rex->subbeg = eval_state->subbeg;
9349 rex->sublen = eval_state->sublen;
9350 rex->suboffset = eval_state->suboffset;
9351 rex->subcoffset = eval_state->subcoffset;
9353 rex->saved_copy = eval_state->saved_copy;
9355 RXp_MATCH_COPIED_on(rex);
9357 if (eval_state->pos_magic)
9359 eval_state->pos_magic->mg_len = eval_state->pos;
9360 eval_state->pos_magic->mg_flags =
9361 (eval_state->pos_magic->mg_flags & ~MGf_BYTES)
9362 | (eval_state->pos_flags & MGf_BYTES);
9365 PL_curpm = eval_state->curpm;
9368 PL_regmatch_state = aux->old_regmatch_state;
9369 PL_regmatch_slab = aux->old_regmatch_slab;
9371 /* free all slabs above current one - this must be the last action
9372 * of this function, as aux and eval_state are allocated within
9373 * slabs and may be freed here */
9375 s = PL_regmatch_slab->next;
9377 PL_regmatch_slab->next = NULL;
9379 regmatch_slab * const osl = s;
9388 S_to_utf8_substr(pTHX_ regexp *prog)
9390 /* Converts substr fields in prog from bytes to UTF-8, calling fbm_compile
9391 * on the converted value */
9395 PERL_ARGS_ASSERT_TO_UTF8_SUBSTR;
9398 if (prog->substrs->data[i].substr
9399 && !prog->substrs->data[i].utf8_substr) {
9400 SV* const sv = newSVsv(prog->substrs->data[i].substr);
9401 prog->substrs->data[i].utf8_substr = sv;
9402 sv_utf8_upgrade(sv);
9403 if (SvVALID(prog->substrs->data[i].substr)) {
9404 if (SvTAIL(prog->substrs->data[i].substr)) {
9405 /* Trim the trailing \n that fbm_compile added last
9407 SvCUR_set(sv, SvCUR(sv) - 1);
9408 /* Whilst this makes the SV technically "invalid" (as its
9409 buffer is no longer followed by "\0") when fbm_compile()
9410 adds the "\n" back, a "\0" is restored. */
9411 fbm_compile(sv, FBMcf_TAIL);
9415 if (prog->substrs->data[i].substr == prog->check_substr)
9416 prog->check_utf8 = sv;
9422 S_to_byte_substr(pTHX_ regexp *prog)
9424 /* Converts substr fields in prog from UTF-8 to bytes, calling fbm_compile
9425 * on the converted value; returns FALSE if can't be converted. */
9429 PERL_ARGS_ASSERT_TO_BYTE_SUBSTR;
9432 if (prog->substrs->data[i].utf8_substr
9433 && !prog->substrs->data[i].substr) {
9434 SV* sv = newSVsv(prog->substrs->data[i].utf8_substr);
9435 if (! sv_utf8_downgrade(sv, TRUE)) {
9438 if (SvVALID(prog->substrs->data[i].utf8_substr)) {
9439 if (SvTAIL(prog->substrs->data[i].utf8_substr)) {
9440 /* Trim the trailing \n that fbm_compile added last
9442 SvCUR_set(sv, SvCUR(sv) - 1);
9443 fbm_compile(sv, FBMcf_TAIL);
9447 prog->substrs->data[i].substr = sv;
9448 if (prog->substrs->data[i].utf8_substr == prog->check_utf8)
9449 prog->check_substr = sv;
9457 * ex: set ts=8 sts=4 sw=4 et:
https://perl5.git.perl.org / perl5.git / blob