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
40 #define B_ON_NON_UTF8_LOCALE_IS_WRONG \
41 "Use of \\b{} or \\B{} for non-UTF-8 locale is wrong. Assuming a UTF-8 locale"
44 * pregcomp and pregexec -- regsub and regerror are not used in perl
46 * Copyright (c) 1986 by University of Toronto.
47 * Written by Henry Spencer. Not derived from licensed software.
49 * Permission is granted to anyone to use this software for any
50 * purpose on any computer system, and to redistribute it freely,
51 * subject to the following restrictions:
53 * 1. The author is not responsible for the consequences of use of
54 * this software, no matter how awful, even if they arise
57 * 2. The origin of this software must not be misrepresented, either
58 * by explicit claim or by omission.
60 * 3. Altered versions must be plainly marked as such, and must not
61 * be misrepresented as being the original software.
63 **** Alterations to Henry's code are...
65 **** Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
66 **** 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
67 **** by Larry Wall and others
69 **** You may distribute under the terms of either the GNU General Public
70 **** License or the Artistic License, as specified in the README file.
72 * Beware that some of this code is subtly aware of the way operator
73 * precedence is structured in regular expressions. Serious changes in
74 * regular-expression syntax might require a total rethink.
77 #define PERL_IN_REGEXEC_C
80 #ifdef PERL_IN_XSUB_RE
86 #include "invlist_inline.h"
87 #include "unicode_constants.h"
90 /* At least one required character in the target string is expressible only in
92 static const char* const non_utf8_target_but_utf8_required
93 = "Can't match, because target string needs to be in UTF-8\n";
96 #define NON_UTF8_TARGET_BUT_UTF8_REQUIRED(target) STMT_START { \
97 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s", non_utf8_target_but_utf8_required));\
101 #define HAS_NONLATIN1_FOLD_CLOSURE(i) _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)
104 #define STATIC static
107 /* Valid only for non-utf8 strings: avoids the reginclass
108 * call if there are no complications: i.e., if everything matchable is
109 * straight forward in the bitmap */
110 #define REGINCLASS(prog,p,c) (ANYOF_FLAGS(p) ? reginclass(prog,p,c,c+1,0) \
111 : ANYOF_BITMAP_TEST(p,*(c)))
117 #define CHR_SVLEN(sv) (utf8_target ? sv_len_utf8(sv) : SvCUR(sv))
118 #define CHR_DIST(a,b) (reginfo->is_utf8_target ? utf8_distance(a,b) : a - b)
120 #define HOPc(pos,off) \
121 (char *)(reginfo->is_utf8_target \
122 ? reghop3((U8*)pos, off, \
123 (U8*)(off >= 0 ? reginfo->strend : reginfo->strbeg)) \
126 #define HOPBACKc(pos, off) \
127 (char*)(reginfo->is_utf8_target \
128 ? reghopmaybe3((U8*)pos, -off, (U8*)(reginfo->strbeg)) \
129 : (pos - off >= reginfo->strbeg) \
133 #define HOP3(pos,off,lim) (reginfo->is_utf8_target ? reghop3((U8*)(pos), off, (U8*)(lim)) : (U8*)(pos + off))
134 #define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim))
136 /* lim must be +ve. Returns NULL on overshoot */
137 #define HOPMAYBE3(pos,off,lim) \
138 (reginfo->is_utf8_target \
139 ? reghopmaybe3((U8*)pos, off, (U8*)(lim)) \
140 : ((U8*)pos + off <= lim) \
144 /* like HOP3, but limits the result to <= lim even for the non-utf8 case.
145 * off must be >=0; args should be vars rather than expressions */
146 #define HOP3lim(pos,off,lim) (reginfo->is_utf8_target \
147 ? reghop3((U8*)(pos), off, (U8*)(lim)) \
148 : (U8*)((pos + off) > lim ? lim : (pos + off)))
150 #define HOP4(pos,off,llim, rlim) (reginfo->is_utf8_target \
151 ? reghop4((U8*)(pos), off, (U8*)(llim), (U8*)(rlim)) \
153 #define HOP4c(pos,off,llim, rlim) ((char*)HOP4(pos,off,llim, rlim))
155 #define NEXTCHR_EOS -10 /* nextchr has fallen off the end */
156 #define NEXTCHR_IS_EOS (nextchr < 0)
158 #define SET_nextchr \
159 nextchr = ((locinput < reginfo->strend) ? UCHARAT(locinput) : NEXTCHR_EOS)
161 #define SET_locinput(p) \
166 #define LOAD_UTF8_CHARCLASS(swash_ptr, property_name, invlist) STMT_START { \
168 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST; \
169 swash_ptr = _core_swash_init("utf8", property_name, &PL_sv_undef, \
170 1, 0, invlist, &flags); \
175 /* If in debug mode, we test that a known character properly matches */
177 # define LOAD_UTF8_CHARCLASS_DEBUG_TEST(swash_ptr, \
180 utf8_char_in_property) \
181 LOAD_UTF8_CHARCLASS(swash_ptr, property_name, invlist); \
182 assert(swash_fetch(swash_ptr, (U8 *) utf8_char_in_property, TRUE));
184 # define LOAD_UTF8_CHARCLASS_DEBUG_TEST(swash_ptr, \
187 utf8_char_in_property) \
188 LOAD_UTF8_CHARCLASS(swash_ptr, property_name, invlist)
191 #define LOAD_UTF8_CHARCLASS_ALNUM() LOAD_UTF8_CHARCLASS_DEBUG_TEST( \
192 PL_utf8_swash_ptrs[_CC_WORDCHAR], \
194 PL_XPosix_ptrs[_CC_WORDCHAR], \
195 LATIN_SMALL_LIGATURE_LONG_S_T_UTF8);
197 #define PLACEHOLDER /* Something for the preprocessor to grab onto */
198 /* TODO: Combine JUMPABLE and HAS_TEXT to cache OP(rn) */
200 /* for use after a quantifier and before an EXACT-like node -- japhy */
201 /* it would be nice to rework regcomp.sym to generate this stuff. sigh
203 * NOTE that *nothing* that affects backtracking should be in here, specifically
204 * VERBS must NOT be included. JUMPABLE is used to determine if we can ignore a
205 * node that is in between two EXACT like nodes when ascertaining what the required
206 * "follow" character is. This should probably be moved to regex compile time
207 * although it may be done at run time beause of the REF possibility - more
208 * investigation required. -- demerphq
210 #define JUMPABLE(rn) ( \
212 (OP(rn) == CLOSE && (!cur_eval || cur_eval->u.eval.close_paren != ARG(rn))) || \
214 OP(rn) == SUSPEND || OP(rn) == IFMATCH || \
215 OP(rn) == PLUS || OP(rn) == MINMOD || \
217 (PL_regkind[OP(rn)] == CURLY && ARG1(rn) > 0) \
219 #define IS_EXACT(rn) (PL_regkind[OP(rn)] == EXACT)
221 #define HAS_TEXT(rn) ( IS_EXACT(rn) || PL_regkind[OP(rn)] == REF )
224 /* Currently these are only used when PL_regkind[OP(rn)] == EXACT so
225 we don't need this definition. XXX These are now out-of-sync*/
226 #define IS_TEXT(rn) ( OP(rn)==EXACT || OP(rn)==REF || OP(rn)==NREF )
227 #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 )
228 #define IS_TEXTFL(rn) ( OP(rn)==EXACTFL || OP(rn)==REFFL || OP(rn)==NREFFL )
231 /* ... so we use this as its faster. */
232 #define IS_TEXT(rn) ( OP(rn)==EXACT || OP(rn)==EXACTL )
233 #define IS_TEXTFU(rn) ( OP(rn)==EXACTFU || OP(rn)==EXACTFLU8 || OP(rn)==EXACTFU_SS || OP(rn) == EXACTFA || OP(rn) == EXACTFA_NO_TRIE)
234 #define IS_TEXTF(rn) ( OP(rn)==EXACTF )
235 #define IS_TEXTFL(rn) ( OP(rn)==EXACTFL )
240 Search for mandatory following text node; for lookahead, the text must
241 follow but for lookbehind (rn->flags != 0) we skip to the next step.
243 #define FIND_NEXT_IMPT(rn) STMT_START { \
244 while (JUMPABLE(rn)) { \
245 const OPCODE type = OP(rn); \
246 if (type == SUSPEND || PL_regkind[type] == CURLY) \
247 rn = NEXTOPER(NEXTOPER(rn)); \
248 else if (type == PLUS) \
250 else if (type == IFMATCH) \
251 rn = (rn->flags == 0) ? NEXTOPER(NEXTOPER(rn)) : rn + ARG(rn); \
252 else rn += NEXT_OFF(rn); \
256 #define SLAB_FIRST(s) (&(s)->states[0])
257 #define SLAB_LAST(s) (&(s)->states[PERL_REGMATCH_SLAB_SLOTS-1])
259 static void S_setup_eval_state(pTHX_ regmatch_info *const reginfo);
260 static void S_cleanup_regmatch_info_aux(pTHX_ void *arg);
261 static regmatch_state * S_push_slab(pTHX);
263 #define REGCP_PAREN_ELEMS 3
264 #define REGCP_OTHER_ELEMS 3
265 #define REGCP_FRAME_ELEMS 1
266 /* REGCP_FRAME_ELEMS are not part of the REGCP_OTHER_ELEMS and
267 * are needed for the regexp context stack bookkeeping. */
270 S_regcppush(pTHX_ const regexp *rex, I32 parenfloor, U32 maxopenparen)
272 const int retval = PL_savestack_ix;
273 const int paren_elems_to_push =
274 (maxopenparen - parenfloor) * REGCP_PAREN_ELEMS;
275 const UV total_elems = paren_elems_to_push + REGCP_OTHER_ELEMS;
276 const UV elems_shifted = total_elems << SAVE_TIGHT_SHIFT;
278 GET_RE_DEBUG_FLAGS_DECL;
280 PERL_ARGS_ASSERT_REGCPPUSH;
282 if (paren_elems_to_push < 0)
283 Perl_croak(aTHX_ "panic: paren_elems_to_push, %i < 0, maxopenparen: %i parenfloor: %i REGCP_PAREN_ELEMS: %u",
284 (int)paren_elems_to_push, (int)maxopenparen,
285 (int)parenfloor, (unsigned)REGCP_PAREN_ELEMS);
287 if ((elems_shifted >> SAVE_TIGHT_SHIFT) != total_elems)
288 Perl_croak(aTHX_ "panic: paren_elems_to_push offset %"UVuf
289 " out of range (%lu-%ld)",
291 (unsigned long)maxopenparen,
294 SSGROW(total_elems + REGCP_FRAME_ELEMS);
297 if ((int)maxopenparen > (int)parenfloor)
298 PerlIO_printf(Perl_debug_log,
299 "rex=0x%"UVxf" offs=0x%"UVxf": saving capture indices:\n",
304 for (p = parenfloor+1; p <= (I32)maxopenparen; p++) {
305 /* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */
306 SSPUSHIV(rex->offs[p].end);
307 SSPUSHIV(rex->offs[p].start);
308 SSPUSHINT(rex->offs[p].start_tmp);
309 DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
310 " \\%"UVuf": %"IVdf"(%"IVdf")..%"IVdf"\n",
312 (IV)rex->offs[p].start,
313 (IV)rex->offs[p].start_tmp,
317 /* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */
318 SSPUSHINT(maxopenparen);
319 SSPUSHINT(rex->lastparen);
320 SSPUSHINT(rex->lastcloseparen);
321 SSPUSHUV(SAVEt_REGCONTEXT | elems_shifted); /* Magic cookie. */
326 /* These are needed since we do not localize EVAL nodes: */
327 #define REGCP_SET(cp) \
329 PerlIO_printf(Perl_debug_log, \
330 " Setting an EVAL scope, savestack=%"IVdf"\n", \
331 (IV)PL_savestack_ix)); \
334 #define REGCP_UNWIND(cp) \
336 if (cp != PL_savestack_ix) \
337 PerlIO_printf(Perl_debug_log, \
338 " Clearing an EVAL scope, savestack=%"IVdf"..%"IVdf"\n", \
339 (IV)(cp), (IV)PL_savestack_ix)); \
342 #define UNWIND_PAREN(lp, lcp) \
343 for (n = rex->lastparen; n > lp; n--) \
344 rex->offs[n].end = -1; \
345 rex->lastparen = n; \
346 rex->lastcloseparen = lcp;
350 S_regcppop(pTHX_ regexp *rex, U32 *maxopenparen_p)
354 GET_RE_DEBUG_FLAGS_DECL;
356 PERL_ARGS_ASSERT_REGCPPOP;
358 /* Pop REGCP_OTHER_ELEMS before the parentheses loop starts. */
360 assert((i & SAVE_MASK) == SAVEt_REGCONTEXT); /* Check that the magic cookie is there. */
361 i >>= SAVE_TIGHT_SHIFT; /* Parentheses elements to pop. */
362 rex->lastcloseparen = SSPOPINT;
363 rex->lastparen = SSPOPINT;
364 *maxopenparen_p = SSPOPINT;
366 i -= REGCP_OTHER_ELEMS;
367 /* Now restore the parentheses context. */
369 if (i || rex->lastparen + 1 <= rex->nparens)
370 PerlIO_printf(Perl_debug_log,
371 "rex=0x%"UVxf" offs=0x%"UVxf": restoring capture indices to:\n",
376 paren = *maxopenparen_p;
377 for ( ; i > 0; i -= REGCP_PAREN_ELEMS) {
379 rex->offs[paren].start_tmp = SSPOPINT;
380 rex->offs[paren].start = SSPOPIV;
382 if (paren <= rex->lastparen)
383 rex->offs[paren].end = tmps;
384 DEBUG_BUFFERS_r( PerlIO_printf(Perl_debug_log,
385 " \\%"UVuf": %"IVdf"(%"IVdf")..%"IVdf"%s\n",
387 (IV)rex->offs[paren].start,
388 (IV)rex->offs[paren].start_tmp,
389 (IV)rex->offs[paren].end,
390 (paren > rex->lastparen ? "(skipped)" : ""));
395 /* It would seem that the similar code in regtry()
396 * already takes care of this, and in fact it is in
397 * a better location to since this code can #if 0-ed out
398 * but the code in regtry() is needed or otherwise tests
399 * requiring null fields (pat.t#187 and split.t#{13,14}
400 * (as of patchlevel 7877) will fail. Then again,
401 * this code seems to be necessary or otherwise
402 * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
403 * --jhi updated by dapm */
404 for (i = rex->lastparen + 1; i <= rex->nparens; i++) {
405 if (i > *maxopenparen_p)
406 rex->offs[i].start = -1;
407 rex->offs[i].end = -1;
408 DEBUG_BUFFERS_r( PerlIO_printf(Perl_debug_log,
409 " \\%"UVuf": %s ..-1 undeffing\n",
411 (i > *maxopenparen_p) ? "-1" : " "
417 /* restore the parens and associated vars at savestack position ix,
418 * but without popping the stack */
421 S_regcp_restore(pTHX_ regexp *rex, I32 ix, U32 *maxopenparen_p)
423 I32 tmpix = PL_savestack_ix;
424 PL_savestack_ix = ix;
425 regcppop(rex, maxopenparen_p);
426 PL_savestack_ix = tmpix;
429 #define regcpblow(cp) LEAVE_SCOPE(cp) /* Ignores regcppush()ed data. */
432 S_isFOO_lc(pTHX_ const U8 classnum, const U8 character)
434 /* Returns a boolean as to whether or not 'character' is a member of the
435 * Posix character class given by 'classnum' that should be equivalent to a
436 * value in the typedef '_char_class_number'.
438 * Ideally this could be replaced by a just an array of function pointers
439 * to the C library functions that implement the macros this calls.
440 * However, to compile, the precise function signatures are required, and
441 * these may vary from platform to to platform. To avoid having to figure
442 * out what those all are on each platform, I (khw) am using this method,
443 * which adds an extra layer of function call overhead (unless the C
444 * optimizer strips it away). But we don't particularly care about
445 * performance with locales anyway. */
447 switch ((_char_class_number) classnum) {
448 case _CC_ENUM_ALPHANUMERIC: return isALPHANUMERIC_LC(character);
449 case _CC_ENUM_ALPHA: return isALPHA_LC(character);
450 case _CC_ENUM_ASCII: return isASCII_LC(character);
451 case _CC_ENUM_BLANK: return isBLANK_LC(character);
452 case _CC_ENUM_CASED: return isLOWER_LC(character)
453 || isUPPER_LC(character);
454 case _CC_ENUM_CNTRL: return isCNTRL_LC(character);
455 case _CC_ENUM_DIGIT: return isDIGIT_LC(character);
456 case _CC_ENUM_GRAPH: return isGRAPH_LC(character);
457 case _CC_ENUM_LOWER: return isLOWER_LC(character);
458 case _CC_ENUM_PRINT: return isPRINT_LC(character);
459 case _CC_ENUM_PUNCT: return isPUNCT_LC(character);
460 case _CC_ENUM_SPACE: return isSPACE_LC(character);
461 case _CC_ENUM_UPPER: return isUPPER_LC(character);
462 case _CC_ENUM_WORDCHAR: return isWORDCHAR_LC(character);
463 case _CC_ENUM_XDIGIT: return isXDIGIT_LC(character);
464 default: /* VERTSPACE should never occur in locales */
465 Perl_croak(aTHX_ "panic: isFOO_lc() has an unexpected character class '%d'", classnum);
468 NOT_REACHED; /* NOTREACHED */
473 S_isFOO_utf8_lc(pTHX_ const U8 classnum, const U8* character)
475 /* Returns a boolean as to whether or not the (well-formed) UTF-8-encoded
476 * 'character' is a member of the Posix character class given by 'classnum'
477 * that should be equivalent to a value in the typedef
478 * '_char_class_number'.
480 * This just calls isFOO_lc on the code point for the character if it is in
481 * the range 0-255. Outside that range, all characters use Unicode
482 * rules, ignoring any locale. So use the Unicode function if this class
483 * requires a swash, and use the Unicode macro otherwise. */
485 PERL_ARGS_ASSERT_ISFOO_UTF8_LC;
487 if (UTF8_IS_INVARIANT(*character)) {
488 return isFOO_lc(classnum, *character);
490 else if (UTF8_IS_DOWNGRADEABLE_START(*character)) {
491 return isFOO_lc(classnum,
492 TWO_BYTE_UTF8_TO_NATIVE(*character, *(character + 1)));
495 _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(character, character + UTF8SKIP(character));
497 if (classnum < _FIRST_NON_SWASH_CC) {
499 /* Initialize the swash unless done already */
500 if (! PL_utf8_swash_ptrs[classnum]) {
501 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
502 PL_utf8_swash_ptrs[classnum] =
503 _core_swash_init("utf8",
506 PL_XPosix_ptrs[classnum], &flags);
509 return cBOOL(swash_fetch(PL_utf8_swash_ptrs[classnum], (U8 *)
511 TRUE /* is UTF */ ));
514 switch ((_char_class_number) classnum) {
515 case _CC_ENUM_SPACE: return is_XPERLSPACE_high(character);
516 case _CC_ENUM_BLANK: return is_HORIZWS_high(character);
517 case _CC_ENUM_XDIGIT: return is_XDIGIT_high(character);
518 case _CC_ENUM_VERTSPACE: return is_VERTWS_high(character);
522 return FALSE; /* Things like CNTRL are always below 256 */
526 * pregexec and friends
529 #ifndef PERL_IN_XSUB_RE
531 - pregexec - match a regexp against a string
534 Perl_pregexec(pTHX_ REGEXP * const prog, char* stringarg, char *strend,
535 char *strbeg, SSize_t minend, SV *screamer, U32 nosave)
536 /* stringarg: the point in the string at which to begin matching */
537 /* strend: pointer to null at end of string */
538 /* strbeg: real beginning of string */
539 /* minend: end of match must be >= minend bytes after stringarg. */
540 /* screamer: SV being matched: only used for utf8 flag, pos() etc; string
541 * itself is accessed via the pointers above */
542 /* nosave: For optimizations. */
544 PERL_ARGS_ASSERT_PREGEXEC;
547 regexec_flags(prog, stringarg, strend, strbeg, minend, screamer, NULL,
548 nosave ? 0 : REXEC_COPY_STR);
554 /* re_intuit_start():
556 * Based on some optimiser hints, try to find the earliest position in the
557 * string where the regex could match.
559 * rx: the regex to match against
560 * sv: the SV being matched: only used for utf8 flag; the string
561 * itself is accessed via the pointers below. Note that on
562 * something like an overloaded SV, SvPOK(sv) may be false
563 * and the string pointers may point to something unrelated to
565 * strbeg: real beginning of string
566 * strpos: the point in the string at which to begin matching
567 * strend: pointer to the byte following the last char of the string
568 * flags currently unused; set to 0
569 * data: currently unused; set to NULL
571 * The basic idea of re_intuit_start() is to use some known information
572 * about the pattern, namely:
574 * a) the longest known anchored substring (i.e. one that's at a
575 * constant offset from the beginning of the pattern; but not
576 * necessarily at a fixed offset from the beginning of the
578 * b) the longest floating substring (i.e. one that's not at a constant
579 * offset from the beginning of the pattern);
580 * c) Whether the pattern is anchored to the string; either
581 * an absolute anchor: /^../, or anchored to \n: /^.../m,
582 * or anchored to pos(): /\G/;
583 * d) A start class: a real or synthetic character class which
584 * represents which characters are legal at the start of the pattern;
586 * to either quickly reject the match, or to find the earliest position
587 * within the string at which the pattern might match, thus avoiding
588 * running the full NFA engine at those earlier locations, only to
589 * eventually fail and retry further along.
591 * Returns NULL if the pattern can't match, or returns the address within
592 * the string which is the earliest place the match could occur.
594 * The longest of the anchored and floating substrings is called 'check'
595 * and is checked first. The other is called 'other' and is checked
596 * second. The 'other' substring may not be present. For example,
598 * /(abc|xyz)ABC\d{0,3}DEFG/
602 * check substr (float) = "DEFG", offset 6..9 chars
603 * other substr (anchored) = "ABC", offset 3..3 chars
606 * Be aware that during the course of this function, sometimes 'anchored'
607 * refers to a substring being anchored relative to the start of the
608 * pattern, and sometimes to the pattern itself being anchored relative to
609 * the string. For example:
611 * /\dabc/: "abc" is anchored to the pattern;
612 * /^\dabc/: "abc" is anchored to the pattern and the string;
613 * /\d+abc/: "abc" is anchored to neither the pattern nor the string;
614 * /^\d+abc/: "abc" is anchored to neither the pattern nor the string,
615 * but the pattern is anchored to the string.
619 Perl_re_intuit_start(pTHX_
622 const char * const strbeg,
626 re_scream_pos_data *data)
628 struct regexp *const prog = ReANY(rx);
629 SSize_t start_shift = prog->check_offset_min;
630 /* Should be nonnegative! */
631 SSize_t end_shift = 0;
632 /* current lowest pos in string where the regex can start matching */
633 char *rx_origin = strpos;
635 const bool utf8_target = (sv && SvUTF8(sv)) ? 1 : 0; /* if no sv we have to assume bytes */
636 U8 other_ix = 1 - prog->substrs->check_ix;
638 char *other_last = strpos;/* latest pos 'other' substr already checked to */
639 char *check_at = NULL; /* check substr found at this pos */
640 const I32 multiline = prog->extflags & RXf_PMf_MULTILINE;
641 RXi_GET_DECL(prog,progi);
642 regmatch_info reginfo_buf; /* create some info to pass to find_byclass */
643 regmatch_info *const reginfo = ®info_buf;
644 GET_RE_DEBUG_FLAGS_DECL;
646 PERL_ARGS_ASSERT_RE_INTUIT_START;
647 PERL_UNUSED_ARG(flags);
648 PERL_UNUSED_ARG(data);
650 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
651 "Intuit: trying to determine minimum start position...\n"));
653 /* for now, assume that all substr offsets are positive. If at some point
654 * in the future someone wants to do clever things with look-behind and
655 * -ve offsets, they'll need to fix up any code in this function
656 * which uses these offsets. See the thread beginning
657 * <20140113145929.GF27210@iabyn.com>
659 assert(prog->substrs->data[0].min_offset >= 0);
660 assert(prog->substrs->data[0].max_offset >= 0);
661 assert(prog->substrs->data[1].min_offset >= 0);
662 assert(prog->substrs->data[1].max_offset >= 0);
663 assert(prog->substrs->data[2].min_offset >= 0);
664 assert(prog->substrs->data[2].max_offset >= 0);
666 /* for now, assume that if both present, that the floating substring
667 * doesn't start before the anchored substring.
668 * If you break this assumption (e.g. doing better optimisations
669 * with lookahead/behind), then you'll need to audit the code in this
670 * function carefully first
673 ! ( (prog->anchored_utf8 || prog->anchored_substr)
674 && (prog->float_utf8 || prog->float_substr))
675 || (prog->float_min_offset >= prog->anchored_offset));
677 /* byte rather than char calculation for efficiency. It fails
678 * to quickly reject some cases that can't match, but will reject
679 * them later after doing full char arithmetic */
680 if (prog->minlen > strend - strpos) {
681 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
682 " String too short...\n"));
686 RX_MATCH_UTF8_set(rx,utf8_target);
687 reginfo->is_utf8_target = cBOOL(utf8_target);
688 reginfo->info_aux = NULL;
689 reginfo->strbeg = strbeg;
690 reginfo->strend = strend;
691 reginfo->is_utf8_pat = cBOOL(RX_UTF8(rx));
693 /* not actually used within intuit, but zero for safety anyway */
694 reginfo->poscache_maxiter = 0;
697 if (!prog->check_utf8 && prog->check_substr)
698 to_utf8_substr(prog);
699 check = prog->check_utf8;
701 if (!prog->check_substr && prog->check_utf8) {
702 if (! to_byte_substr(prog)) {
703 NON_UTF8_TARGET_BUT_UTF8_REQUIRED(fail);
706 check = prog->check_substr;
709 /* dump the various substring data */
710 DEBUG_OPTIMISE_MORE_r({
712 for (i=0; i<=2; i++) {
713 SV *sv = (utf8_target ? prog->substrs->data[i].utf8_substr
714 : prog->substrs->data[i].substr);
718 PerlIO_printf(Perl_debug_log,
719 " substrs[%d]: min=%"IVdf" max=%"IVdf" end shift=%"IVdf
720 " useful=%"IVdf" utf8=%d [%s]\n",
722 (IV)prog->substrs->data[i].min_offset,
723 (IV)prog->substrs->data[i].max_offset,
724 (IV)prog->substrs->data[i].end_shift,
731 if (prog->intflags & PREGf_ANCH) { /* Match at \G, beg-of-str or after \n */
733 /* ml_anch: check after \n?
735 * A note about PREGf_IMPLICIT: on an un-anchored pattern beginning
736 * with /.*.../, these flags will have been added by the
738 * /.*abc/, /.*abc/m: PREGf_IMPLICIT | PREGf_ANCH_MBOL
739 * /.*abc/s: PREGf_IMPLICIT | PREGf_ANCH_SBOL
741 ml_anch = (prog->intflags & PREGf_ANCH_MBOL)
742 && !(prog->intflags & PREGf_IMPLICIT);
744 if (!ml_anch && !(prog->intflags & PREGf_IMPLICIT)) {
745 /* we are only allowed to match at BOS or \G */
747 /* trivially reject if there's a BOS anchor and we're not at BOS.
749 * Note that we don't try to do a similar quick reject for
750 * \G, since generally the caller will have calculated strpos
751 * based on pos() and gofs, so the string is already correctly
752 * anchored by definition; and handling the exceptions would
753 * be too fiddly (e.g. REXEC_IGNOREPOS).
755 if ( strpos != strbeg
756 && (prog->intflags & PREGf_ANCH_SBOL))
758 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
759 " Not at start...\n"));
763 /* in the presence of an anchor, the anchored (relative to the
764 * start of the regex) substr must also be anchored relative
765 * to strpos. So quickly reject if substr isn't found there.
766 * This works for \G too, because the caller will already have
767 * subtracted gofs from pos, and gofs is the offset from the
768 * \G to the start of the regex. For example, in /.abc\Gdef/,
769 * where substr="abcdef", pos()=3, gofs=4, offset_min=1:
770 * caller will have set strpos=pos()-4; we look for the substr
771 * at position pos()-4+1, which lines up with the "a" */
773 if (prog->check_offset_min == prog->check_offset_max) {
774 /* Substring at constant offset from beg-of-str... */
775 SSize_t slen = SvCUR(check);
776 char *s = HOP3c(strpos, prog->check_offset_min, strend);
778 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
779 " Looking for check substr at fixed offset %"IVdf"...\n",
780 (IV)prog->check_offset_min));
783 /* In this case, the regex is anchored at the end too.
784 * Unless it's a multiline match, the lengths must match
785 * exactly, give or take a \n. NB: slen >= 1 since
786 * the last char of check is \n */
788 && ( strend - s > slen
789 || strend - s < slen - 1
790 || (strend - s == slen && strend[-1] != '\n')))
792 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
793 " String too long...\n"));
796 /* Now should match s[0..slen-2] */
799 if (slen && (*SvPVX_const(check) != *s
800 || (slen > 1 && memNE(SvPVX_const(check), s, slen))))
802 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
803 " String not equal...\n"));
808 goto success_at_start;
813 end_shift = prog->check_end_shift;
815 #ifdef DEBUGGING /* 7/99: reports of failure (with the older version) */
817 Perl_croak(aTHX_ "panic: end_shift: %"IVdf" pattern:\n%s\n ",
818 (IV)end_shift, RX_PRECOMP(prog));
823 /* This is the (re)entry point of the main loop in this function.
824 * The goal of this loop is to:
825 * 1) find the "check" substring in the region rx_origin..strend
826 * (adjusted by start_shift / end_shift). If not found, reject
828 * 2) If it exists, look for the "other" substr too if defined; for
829 * example, if the check substr maps to the anchored substr, then
830 * check the floating substr, and vice-versa. If not found, go
831 * back to (1) with rx_origin suitably incremented.
832 * 3) If we find an rx_origin position that doesn't contradict
833 * either of the substrings, then check the possible additional
834 * constraints on rx_origin of /^.../m or a known start class.
835 * If these fail, then depending on which constraints fail, jump
836 * back to here, or to various other re-entry points further along
837 * that skip some of the first steps.
838 * 4) If we pass all those tests, update the BmUSEFUL() count on the
839 * substring. If the start position was determined to be at the
840 * beginning of the string - so, not rejected, but not optimised,
841 * since we have to run regmatch from position 0 - decrement the
842 * BmUSEFUL() count. Otherwise increment it.
846 /* first, look for the 'check' substring */
852 DEBUG_OPTIMISE_MORE_r({
853 PerlIO_printf(Perl_debug_log,
854 " At restart: rx_origin=%"IVdf" Check offset min: %"IVdf
855 " Start shift: %"IVdf" End shift %"IVdf
856 " Real end Shift: %"IVdf"\n",
857 (IV)(rx_origin - strbeg),
858 (IV)prog->check_offset_min,
861 (IV)prog->check_end_shift);
864 end_point = HOP3(strend, -end_shift, strbeg);
865 start_point = HOPMAYBE3(rx_origin, start_shift, end_point);
870 /* If the regex is absolutely anchored to either the start of the
871 * string (SBOL) or to pos() (ANCH_GPOS), then
872 * check_offset_max represents an upper bound on the string where
873 * the substr could start. For the ANCH_GPOS case, we assume that
874 * the caller of intuit will have already set strpos to
875 * pos()-gofs, so in this case strpos + offset_max will still be
876 * an upper bound on the substr.
879 && prog->intflags & PREGf_ANCH
880 && prog->check_offset_max != SSize_t_MAX)
882 SSize_t len = SvCUR(check) - !!SvTAIL(check);
883 const char * const anchor =
884 (prog->intflags & PREGf_ANCH_GPOS ? strpos : strbeg);
886 /* do a bytes rather than chars comparison. It's conservative;
887 * so it skips doing the HOP if the result can't possibly end
888 * up earlier than the old value of end_point.
890 if ((char*)end_point - anchor > prog->check_offset_max) {
891 end_point = HOP3lim((U8*)anchor,
892 prog->check_offset_max,
898 check_at = fbm_instr( start_point, end_point,
899 check, multiline ? FBMrf_MULTILINE : 0);
901 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
902 " doing 'check' fbm scan, [%"IVdf"..%"IVdf"] gave %"IVdf"\n",
903 (IV)((char*)start_point - strbeg),
904 (IV)((char*)end_point - strbeg),
905 (IV)(check_at ? check_at - strbeg : -1)
908 /* Update the count-of-usability, remove useless subpatterns,
912 RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
913 SvPVX_const(check), RE_SV_DUMPLEN(check), 30);
914 PerlIO_printf(Perl_debug_log, " %s %s substr %s%s%s",
915 (check_at ? "Found" : "Did not find"),
916 (check == (utf8_target ? prog->anchored_utf8 : prog->anchored_substr)
917 ? "anchored" : "floating"),
920 (check_at ? " at offset " : "...\n") );
925 /* set rx_origin to the minimum position where the regex could start
926 * matching, given the constraint of the just-matched check substring.
927 * But don't set it lower than previously.
930 if (check_at - rx_origin > prog->check_offset_max)
931 rx_origin = HOP3c(check_at, -prog->check_offset_max, rx_origin);
932 /* Finish the diagnostic message */
933 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
934 "%ld (rx_origin now %"IVdf")...\n",
935 (long)(check_at - strbeg),
936 (IV)(rx_origin - strbeg)
941 /* now look for the 'other' substring if defined */
943 if (utf8_target ? prog->substrs->data[other_ix].utf8_substr
944 : prog->substrs->data[other_ix].substr)
946 /* Take into account the "other" substring. */
950 struct reg_substr_datum *other;
953 other = &prog->substrs->data[other_ix];
955 /* if "other" is anchored:
956 * we've previously found a floating substr starting at check_at.
957 * This means that the regex origin must lie somewhere
958 * between min (rx_origin): HOP3(check_at, -check_offset_max)
959 * and max: HOP3(check_at, -check_offset_min)
960 * (except that min will be >= strpos)
961 * So the fixed substr must lie somewhere between
962 * HOP3(min, anchored_offset)
963 * HOP3(max, anchored_offset) + SvCUR(substr)
966 /* if "other" is floating
967 * Calculate last1, the absolute latest point where the
968 * floating substr could start in the string, ignoring any
969 * constraints from the earlier fixed match. It is calculated
972 * strend - prog->minlen (in chars) is the absolute latest
973 * position within the string where the origin of the regex
974 * could appear. The latest start point for the floating
975 * substr is float_min_offset(*) on from the start of the
976 * regex. last1 simply combines thee two offsets.
978 * (*) You might think the latest start point should be
979 * float_max_offset from the regex origin, and technically
980 * you'd be correct. However, consider
982 * Here, float min, max are 3,5 and minlen is 7.
983 * This can match either
987 * In the first case, the regex matches minlen chars; in the
988 * second, minlen+1, in the third, minlen+2.
989 * In the first case, the floating offset is 3 (which equals
990 * float_min), in the second, 4, and in the third, 5 (which
991 * equals float_max). In all cases, the floating string bcd
992 * can never start more than 4 chars from the end of the
993 * string, which equals minlen - float_min. As the substring
994 * starts to match more than float_min from the start of the
995 * regex, it makes the regex match more than minlen chars,
996 * and the two cancel each other out. So we can always use
997 * float_min - minlen, rather than float_max - minlen for the
998 * latest position in the string.
1000 * Note that -minlen + float_min_offset is equivalent (AFAIKT)
1001 * to CHR_SVLEN(must) - !!SvTAIL(must) + prog->float_end_shift
1004 assert(prog->minlen >= other->min_offset);
1005 last1 = HOP3c(strend,
1006 other->min_offset - prog->minlen, strbeg);
1008 if (other_ix) {/* i.e. if (other-is-float) */
1009 /* last is the latest point where the floating substr could
1010 * start, *given* any constraints from the earlier fixed
1011 * match. This constraint is that the floating string starts
1012 * <= float_max_offset chars from the regex origin (rx_origin).
1013 * If this value is less than last1, use it instead.
1015 assert(rx_origin <= last1);
1017 /* this condition handles the offset==infinity case, and
1018 * is a short-cut otherwise. Although it's comparing a
1019 * byte offset to a char length, it does so in a safe way,
1020 * since 1 char always occupies 1 or more bytes,
1021 * so if a string range is (last1 - rx_origin) bytes,
1022 * it will be less than or equal to (last1 - rx_origin)
1023 * chars; meaning it errs towards doing the accurate HOP3
1024 * rather than just using last1 as a short-cut */
1025 (last1 - rx_origin) < other->max_offset
1027 : (char*)HOP3lim(rx_origin, other->max_offset, last1);
1030 assert(strpos + start_shift <= check_at);
1031 last = HOP4c(check_at, other->min_offset - start_shift,
1035 s = HOP3c(rx_origin, other->min_offset, strend);
1036 if (s < other_last) /* These positions already checked */
1039 must = utf8_target ? other->utf8_substr : other->substr;
1040 assert(SvPOK(must));
1043 char *to = last + SvCUR(must) - (SvTAIL(must)!=0);
1047 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1048 " skipping 'other' fbm scan: %"IVdf" > %"IVdf"\n",
1049 (IV)(from - strbeg),
1055 (unsigned char*)from,
1058 multiline ? FBMrf_MULTILINE : 0
1060 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1061 " doing 'other' fbm scan, [%"IVdf"..%"IVdf"] gave %"IVdf"\n",
1062 (IV)(from - strbeg),
1064 (IV)(s ? s - strbeg : -1)
1070 RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
1071 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
1072 PerlIO_printf(Perl_debug_log, " %s %s substr %s%s",
1073 s ? "Found" : "Contradicts",
1074 other_ix ? "floating" : "anchored",
1075 quoted, RE_SV_TAIL(must));
1080 /* last1 is latest possible substr location. If we didn't
1081 * find it before there, we never will */
1082 if (last >= last1) {
1083 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1084 "; giving up...\n"));
1088 /* try to find the check substr again at a later
1089 * position. Maybe next time we'll find the "other" substr
1091 other_last = HOP3c(last, 1, strend) /* highest failure */;
1093 other_ix /* i.e. if other-is-float */
1094 ? HOP3c(rx_origin, 1, strend)
1095 : HOP4c(last, 1 - other->min_offset, strbeg, strend);
1096 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1097 "; about to retry %s at offset %ld (rx_origin now %"IVdf")...\n",
1098 (other_ix ? "floating" : "anchored"),
1099 (long)(HOP3c(check_at, 1, strend) - strbeg),
1100 (IV)(rx_origin - strbeg)
1105 if (other_ix) { /* if (other-is-float) */
1106 /* other_last is set to s, not s+1, since its possible for
1107 * a floating substr to fail first time, then succeed
1108 * second time at the same floating position; e.g.:
1109 * "-AB--AABZ" =~ /\wAB\d*Z/
1110 * The first time round, anchored and float match at
1111 * "-(AB)--AAB(Z)" then fail on the initial \w character
1112 * class. Second time round, they match at "-AB--A(AB)(Z)".
1117 rx_origin = HOP3c(s, -other->min_offset, strbeg);
1118 other_last = HOP3c(s, 1, strend);
1120 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1121 " at offset %ld (rx_origin now %"IVdf")...\n",
1123 (IV)(rx_origin - strbeg)
1129 DEBUG_OPTIMISE_MORE_r(
1130 PerlIO_printf(Perl_debug_log,
1131 " Check-only match: offset min:%"IVdf" max:%"IVdf
1132 " check_at:%"IVdf" rx_origin:%"IVdf" rx_origin-check_at:%"IVdf
1133 " strend:%"IVdf"\n",
1134 (IV)prog->check_offset_min,
1135 (IV)prog->check_offset_max,
1136 (IV)(check_at-strbeg),
1137 (IV)(rx_origin-strbeg),
1138 (IV)(rx_origin-check_at),
1144 postprocess_substr_matches:
1146 /* handle the extra constraint of /^.../m if present */
1148 if (ml_anch && rx_origin != strbeg && rx_origin[-1] != '\n') {
1151 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1152 " looking for /^/m anchor"));
1154 /* we have failed the constraint of a \n before rx_origin.
1155 * Find the next \n, if any, even if it's beyond the current
1156 * anchored and/or floating substrings. Whether we should be
1157 * scanning ahead for the next \n or the next substr is debatable.
1158 * On the one hand you'd expect rare substrings to appear less
1159 * often than \n's. On the other hand, searching for \n means
1160 * we're effectively flipping between check_substr and "\n" on each
1161 * iteration as the current "rarest" string candidate, which
1162 * means for example that we'll quickly reject the whole string if
1163 * hasn't got a \n, rather than trying every substr position
1167 s = HOP3c(strend, - prog->minlen, strpos);
1168 if (s <= rx_origin ||
1169 ! ( rx_origin = (char *)memchr(rx_origin, '\n', s - rx_origin)))
1171 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1172 " Did not find /%s^%s/m...\n",
1173 PL_colors[0], PL_colors[1]));
1177 /* earliest possible origin is 1 char after the \n.
1178 * (since *rx_origin == '\n', it's safe to ++ here rather than
1179 * HOP(rx_origin, 1)) */
1182 if (prog->substrs->check_ix == 0 /* check is anchored */
1183 || rx_origin >= HOP3c(check_at, - prog->check_offset_min, strpos))
1185 /* Position contradicts check-string; either because
1186 * check was anchored (and thus has no wiggle room),
1187 * or check was float and rx_origin is above the float range */
1188 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1189 " Found /%s^%s/m, about to restart lookup for check-string with rx_origin %ld...\n",
1190 PL_colors[0], PL_colors[1], (long)(rx_origin - strbeg)));
1194 /* if we get here, the check substr must have been float,
1195 * is in range, and we may or may not have had an anchored
1196 * "other" substr which still contradicts */
1197 assert(prog->substrs->check_ix); /* check is float */
1199 if (utf8_target ? prog->anchored_utf8 : prog->anchored_substr) {
1200 /* whoops, the anchored "other" substr exists, so we still
1201 * contradict. On the other hand, the float "check" substr
1202 * didn't contradict, so just retry the anchored "other"
1204 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1205 " Found /%s^%s/m, rescanning for anchored from offset %ld (rx_origin now %"IVdf")...\n",
1206 PL_colors[0], PL_colors[1],
1207 (long)(rx_origin - strbeg + prog->anchored_offset),
1208 (long)(rx_origin - strbeg)
1210 goto do_other_substr;
1213 /* success: we don't contradict the found floating substring
1214 * (and there's no anchored substr). */
1215 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1216 " Found /%s^%s/m with rx_origin %ld...\n",
1217 PL_colors[0], PL_colors[1], (long)(rx_origin - strbeg)));
1220 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1221 " (multiline anchor test skipped)\n"));
1227 /* if we have a starting character class, then test that extra constraint.
1228 * (trie stclasses are too expensive to use here, we are better off to
1229 * leave it to regmatch itself) */
1231 if (progi->regstclass && PL_regkind[OP(progi->regstclass)]!=TRIE) {
1232 const U8* const str = (U8*)STRING(progi->regstclass);
1234 /* XXX this value could be pre-computed */
1235 const int cl_l = (PL_regkind[OP(progi->regstclass)] == EXACT
1236 ? (reginfo->is_utf8_pat
1237 ? utf8_distance(str + STR_LEN(progi->regstclass), str)
1238 : STR_LEN(progi->regstclass))
1242 /* latest pos that a matching float substr constrains rx start to */
1243 char *rx_max_float = NULL;
1245 /* if the current rx_origin is anchored, either by satisfying an
1246 * anchored substring constraint, or a /^.../m constraint, then we
1247 * can reject the current origin if the start class isn't found
1248 * at the current position. If we have a float-only match, then
1249 * rx_origin is constrained to a range; so look for the start class
1250 * in that range. if neither, then look for the start class in the
1251 * whole rest of the string */
1253 /* XXX DAPM it's not clear what the minlen test is for, and why
1254 * it's not used in the floating case. Nothing in the test suite
1255 * causes minlen == 0 here. See <20140313134639.GS12844@iabyn.com>.
1256 * Here are some old comments, which may or may not be correct:
1258 * minlen == 0 is possible if regstclass is \b or \B,
1259 * and the fixed substr is ''$.
1260 * Since minlen is already taken into account, rx_origin+1 is
1261 * before strend; accidentally, minlen >= 1 guaranties no false
1262 * positives at rx_origin + 1 even for \b or \B. But (minlen? 1 :
1263 * 0) below assumes that regstclass does not come from lookahead...
1264 * If regstclass takes bytelength more than 1: If charlength==1, OK.
1265 * This leaves EXACTF-ish only, which are dealt with in
1269 if (prog->anchored_substr || prog->anchored_utf8 || ml_anch)
1270 endpos= HOP3c(rx_origin, (prog->minlen ? cl_l : 0), strend);
1271 else if (prog->float_substr || prog->float_utf8) {
1272 rx_max_float = HOP3c(check_at, -start_shift, strbeg);
1273 endpos= HOP3c(rx_max_float, cl_l, strend);
1278 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1279 " looking for class: start_shift: %"IVdf" check_at: %"IVdf
1280 " rx_origin: %"IVdf" endpos: %"IVdf"\n",
1281 (IV)start_shift, (IV)(check_at - strbeg),
1282 (IV)(rx_origin - strbeg), (IV)(endpos - strbeg)));
1284 s = find_byclass(prog, progi->regstclass, rx_origin, endpos,
1287 if (endpos == strend) {
1288 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1289 " Could not match STCLASS...\n") );
1292 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1293 " This position contradicts STCLASS...\n") );
1294 if ((prog->intflags & PREGf_ANCH) && !ml_anch
1295 && !(prog->intflags & PREGf_IMPLICIT))
1298 /* Contradict one of substrings */
1299 if (prog->anchored_substr || prog->anchored_utf8) {
1300 if (prog->substrs->check_ix == 1) { /* check is float */
1301 /* Have both, check_string is floating */
1302 assert(rx_origin + start_shift <= check_at);
1303 if (rx_origin + start_shift != check_at) {
1304 /* not at latest position float substr could match:
1305 * Recheck anchored substring, but not floating.
1306 * The condition above is in bytes rather than
1307 * chars for efficiency. It's conservative, in
1308 * that it errs on the side of doing 'goto
1309 * do_other_substr'. In this case, at worst,
1310 * an extra anchored search may get done, but in
1311 * practice the extra fbm_instr() is likely to
1312 * get skipped anyway. */
1313 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1314 " about to retry anchored at offset %ld (rx_origin now %"IVdf")...\n",
1315 (long)(other_last - strbeg),
1316 (IV)(rx_origin - strbeg)
1318 goto do_other_substr;
1326 /* In the presence of ml_anch, we might be able to
1327 * find another \n without breaking the current float
1330 /* strictly speaking this should be HOP3c(..., 1, ...),
1331 * but since we goto a block of code that's going to
1332 * search for the next \n if any, its safe here */
1334 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1335 " about to look for /%s^%s/m starting at rx_origin %ld...\n",
1336 PL_colors[0], PL_colors[1],
1337 (long)(rx_origin - strbeg)) );
1338 goto postprocess_substr_matches;
1341 /* strictly speaking this can never be true; but might
1342 * be if we ever allow intuit without substrings */
1343 if (!(utf8_target ? prog->float_utf8 : prog->float_substr))
1346 rx_origin = rx_max_float;
1349 /* at this point, any matching substrings have been
1350 * contradicted. Start again... */
1352 rx_origin = HOP3c(rx_origin, 1, strend);
1354 /* uses bytes rather than char calculations for efficiency.
1355 * It's conservative: it errs on the side of doing 'goto restart',
1356 * where there is code that does a proper char-based test */
1357 if (rx_origin + start_shift + end_shift > strend) {
1358 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1359 " Could not match STCLASS...\n") );
1362 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1363 " about to look for %s substr starting at offset %ld (rx_origin now %"IVdf")...\n",
1364 (prog->substrs->check_ix ? "floating" : "anchored"),
1365 (long)(rx_origin + start_shift - strbeg),
1366 (IV)(rx_origin - strbeg)
1373 if (rx_origin != s) {
1374 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1375 " By STCLASS: moving %ld --> %ld\n",
1376 (long)(rx_origin - strbeg), (long)(s - strbeg))
1380 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1381 " Does not contradict STCLASS...\n");
1386 /* Decide whether using the substrings helped */
1388 if (rx_origin != strpos) {
1389 /* Fixed substring is found far enough so that the match
1390 cannot start at strpos. */
1392 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " try at offset...\n"));
1393 ++BmUSEFUL(utf8_target ? prog->check_utf8 : prog->check_substr); /* hooray/5 */
1396 /* The found rx_origin position does not prohibit matching at
1397 * strpos, so calling intuit didn't gain us anything. Decrement
1398 * the BmUSEFUL() count on the check substring, and if we reach
1400 if (!(prog->intflags & PREGf_NAUGHTY)
1402 prog->check_utf8 /* Could be deleted already */
1403 && --BmUSEFUL(prog->check_utf8) < 0
1404 && (prog->check_utf8 == prog->float_utf8)
1406 prog->check_substr /* Could be deleted already */
1407 && --BmUSEFUL(prog->check_substr) < 0
1408 && (prog->check_substr == prog->float_substr)
1411 /* If flags & SOMETHING - do not do it many times on the same match */
1412 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " ... Disabling check substring...\n"));
1413 /* XXX Does the destruction order has to change with utf8_target? */
1414 SvREFCNT_dec(utf8_target ? prog->check_utf8 : prog->check_substr);
1415 SvREFCNT_dec(utf8_target ? prog->check_substr : prog->check_utf8);
1416 prog->check_substr = prog->check_utf8 = NULL; /* disable */
1417 prog->float_substr = prog->float_utf8 = NULL; /* clear */
1418 check = NULL; /* abort */
1419 /* XXXX This is a remnant of the old implementation. It
1420 looks wasteful, since now INTUIT can use many
1421 other heuristics. */
1422 prog->extflags &= ~RXf_USE_INTUIT;
1426 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1427 "Intuit: %sSuccessfully guessed:%s match at offset %ld\n",
1428 PL_colors[4], PL_colors[5], (long)(rx_origin - strbeg)) );
1432 fail_finish: /* Substring not found */
1433 if (prog->check_substr || prog->check_utf8) /* could be removed already */
1434 BmUSEFUL(utf8_target ? prog->check_utf8 : prog->check_substr) += 5; /* hooray */
1436 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n",
1437 PL_colors[4], PL_colors[5]));
1442 #define DECL_TRIE_TYPE(scan) \
1443 const enum { trie_plain, trie_utf8, trie_utf8_fold, trie_latin_utf8_fold, \
1444 trie_utf8_exactfa_fold, trie_latin_utf8_exactfa_fold, \
1445 trie_utf8l, trie_flu8 } \
1446 trie_type = ((scan->flags == EXACT) \
1447 ? (utf8_target ? trie_utf8 : trie_plain) \
1448 : (scan->flags == EXACTL) \
1449 ? (utf8_target ? trie_utf8l : trie_plain) \
1450 : (scan->flags == EXACTFA) \
1452 ? trie_utf8_exactfa_fold \
1453 : trie_latin_utf8_exactfa_fold) \
1454 : (scan->flags == EXACTFLU8 \
1458 : trie_latin_utf8_fold)))
1460 #define REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc, uscan, len, uvc, charid, foldlen, foldbuf, uniflags) \
1463 U8 flags = FOLD_FLAGS_FULL; \
1464 switch (trie_type) { \
1466 _CHECK_AND_WARN_PROBLEMATIC_LOCALE; \
1467 if (utf8_target && UTF8_IS_ABOVE_LATIN1(*uc)) { \
1468 _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(uc, uc + UTF8SKIP(uc)); \
1470 goto do_trie_utf8_fold; \
1471 case trie_utf8_exactfa_fold: \
1472 flags |= FOLD_FLAGS_NOMIX_ASCII; \
1474 case trie_utf8_fold: \
1475 do_trie_utf8_fold: \
1476 if ( foldlen>0 ) { \
1477 uvc = utf8n_to_uvchr( (const U8*) uscan, UTF8_MAXLEN, &len, uniflags ); \
1482 uvc = _to_utf8_fold_flags( (const U8*) uc, foldbuf, &foldlen, flags); \
1483 len = UTF8SKIP(uc); \
1484 skiplen = UNISKIP( uvc ); \
1485 foldlen -= skiplen; \
1486 uscan = foldbuf + skiplen; \
1489 case trie_latin_utf8_exactfa_fold: \
1490 flags |= FOLD_FLAGS_NOMIX_ASCII; \
1492 case trie_latin_utf8_fold: \
1493 if ( foldlen>0 ) { \
1494 uvc = utf8n_to_uvchr( (const U8*) uscan, UTF8_MAXLEN, &len, uniflags ); \
1500 uvc = _to_fold_latin1( (U8) *uc, foldbuf, &foldlen, flags); \
1501 skiplen = UNISKIP( uvc ); \
1502 foldlen -= skiplen; \
1503 uscan = foldbuf + skiplen; \
1507 _CHECK_AND_WARN_PROBLEMATIC_LOCALE; \
1508 if (utf8_target && UTF8_IS_ABOVE_LATIN1(*uc)) { \
1509 _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(uc, uc + UTF8SKIP(uc)); \
1513 uvc = utf8n_to_uvchr( (const U8*) uc, UTF8_MAXLEN, &len, uniflags ); \
1520 charid = trie->charmap[ uvc ]; \
1524 if (widecharmap) { \
1525 SV** const svpp = hv_fetch(widecharmap, \
1526 (char*)&uvc, sizeof(UV), 0); \
1528 charid = (U16)SvIV(*svpp); \
1533 #define DUMP_EXEC_POS(li,s,doutf8) \
1534 dump_exec_pos(li,s,(reginfo->strend),(reginfo->strbeg), \
1537 #define REXEC_FBC_EXACTISH_SCAN(COND) \
1541 && (ln == 1 || folder(s, pat_string, ln)) \
1542 && (reginfo->intuit || regtry(reginfo, &s)) )\
1548 #define REXEC_FBC_UTF8_SCAN(CODE) \
1550 while (s < strend) { \
1556 #define REXEC_FBC_SCAN(CODE) \
1558 while (s < strend) { \
1564 #define REXEC_FBC_UTF8_CLASS_SCAN(COND) \
1565 REXEC_FBC_UTF8_SCAN( /* Loops while (s < strend) */ \
1567 if (tmp && (reginfo->intuit || regtry(reginfo, &s))) \
1576 #define REXEC_FBC_CLASS_SCAN(COND) \
1577 REXEC_FBC_SCAN( /* Loops while (s < strend) */ \
1579 if (tmp && (reginfo->intuit || regtry(reginfo, &s))) \
1588 #define REXEC_FBC_CSCAN(CONDUTF8,COND) \
1589 if (utf8_target) { \
1590 REXEC_FBC_UTF8_CLASS_SCAN(CONDUTF8); \
1593 REXEC_FBC_CLASS_SCAN(COND); \
1596 /* The three macros below are slightly different versions of the same logic.
1598 * The first is for /a and /aa when the target string is UTF-8. This can only
1599 * match ascii, but it must advance based on UTF-8. The other two handle the
1600 * non-UTF-8 and the more generic UTF-8 cases. In all three, we are looking
1601 * for the boundary (or non-boundary) between a word and non-word character.
1602 * The utf8 and non-utf8 cases have the same logic, but the details must be
1603 * different. Find the "wordness" of the character just prior to this one, and
1604 * compare it with the wordness of this one. If they differ, we have a
1605 * boundary. At the beginning of the string, pretend that the previous
1606 * character was a new-line.
1608 * All these macros uncleanly have side-effects with each other and outside
1609 * variables. So far it's been too much trouble to clean-up
1611 * TEST_NON_UTF8 is the macro or function to call to test if its byte input is
1612 * a word character or not.
1613 * IF_SUCCESS is code to do if it finds that we are at a boundary between
1615 * IF_FAIL is code to do if we aren't at a boundary between word/non-word
1617 * Exactly one of the two IF_FOO parameters is a no-op, depending on whether we
1618 * are looking for a boundary or for a non-boundary. If we are looking for a
1619 * boundary, we want IF_FAIL to be the no-op, and for IF_SUCCESS to go out and
1620 * see if this tentative match actually works, and if so, to quit the loop
1621 * here. And vice-versa if we are looking for a non-boundary.
1623 * 'tmp' below in the next three macros in the REXEC_FBC_SCAN and
1624 * REXEC_FBC_UTF8_SCAN loops is a loop invariant, a bool giving the return of
1625 * TEST_NON_UTF8(s-1). To see this, note that that's what it is defined to be
1626 * at entry to the loop, and to get to the IF_FAIL branch, tmp must equal
1627 * TEST_NON_UTF8(s), and in the opposite branch, IF_SUCCESS, tmp is that
1628 * complement. But in that branch we complement tmp, meaning that at the
1629 * bottom of the loop tmp is always going to be equal to TEST_NON_UTF8(s),
1630 * which means at the top of the loop in the next iteration, it is
1631 * TEST_NON_UTF8(s-1) */
1632 #define FBC_UTF8_A(TEST_NON_UTF8, IF_SUCCESS, IF_FAIL) \
1633 tmp = (s != reginfo->strbeg) ? UCHARAT(s - 1) : '\n'; \
1634 tmp = TEST_NON_UTF8(tmp); \
1635 REXEC_FBC_UTF8_SCAN( /* advances s while s < strend */ \
1636 if (tmp == ! TEST_NON_UTF8((U8) *s)) { \
1638 IF_SUCCESS; /* Is a boundary if values for s-1 and s differ */ \
1645 /* Like FBC_UTF8_A, but TEST_UV is a macro which takes a UV as its input, and
1646 * TEST_UTF8 is a macro that for the same input code points returns identically
1647 * to TEST_UV, but takes a pointer to a UTF-8 encoded string instead */
1648 #define FBC_UTF8(TEST_UV, TEST_UTF8, IF_SUCCESS, IF_FAIL) \
1649 if (s == reginfo->strbeg) { \
1652 else { /* Back-up to the start of the previous character */ \
1653 U8 * const r = reghop3((U8*)s, -1, (U8*)reginfo->strbeg); \
1654 tmp = utf8n_to_uvchr(r, (U8*) reginfo->strend - r, \
1655 0, UTF8_ALLOW_DEFAULT); \
1657 tmp = TEST_UV(tmp); \
1658 LOAD_UTF8_CHARCLASS_ALNUM(); \
1659 REXEC_FBC_UTF8_SCAN( /* advances s while s < strend */ \
1660 if (tmp == ! (TEST_UTF8((U8 *) s))) { \
1669 /* Like the above two macros. UTF8_CODE is the complete code for handling
1670 * UTF-8. Common to the BOUND and NBOUND cases, set-up by the FBC_BOUND, etc
1672 #define FBC_BOUND_COMMON(UTF8_CODE, TEST_NON_UTF8, IF_SUCCESS, IF_FAIL) \
1673 if (utf8_target) { \
1676 else { /* Not utf8 */ \
1677 tmp = (s != reginfo->strbeg) ? UCHARAT(s - 1) : '\n'; \
1678 tmp = TEST_NON_UTF8(tmp); \
1679 REXEC_FBC_SCAN( /* advances s while s < strend */ \
1680 if (tmp == ! TEST_NON_UTF8((U8) *s)) { \
1689 /* Here, things have been set up by the previous code so that tmp is the \
1690 * return of TEST_NON_UTF(s-1) or TEST_UTF8(s-1) (depending on the \
1691 * utf8ness of the target). We also have to check if this matches against \
1692 * the EOS, which we treat as a \n (which is the same value in both UTF-8 \
1693 * or non-UTF8, so can use the non-utf8 test condition even for a UTF-8 \
1695 if (tmp == ! TEST_NON_UTF8('\n')) { \
1702 /* This is the macro to use when we want to see if something that looks like it
1703 * could match, actually does, and if so exits the loop */
1704 #define REXEC_FBC_TRYIT \
1705 if ((reginfo->intuit || regtry(reginfo, &s))) \
1708 /* The only difference between the BOUND and NBOUND cases is that
1709 * REXEC_FBC_TRYIT is called when matched in BOUND, and when non-matched in
1710 * NBOUND. This is accomplished by passing it as either the if or else clause,
1711 * with the other one being empty (PLACEHOLDER is defined as empty).
1713 * The TEST_FOO parameters are for operating on different forms of input, but
1714 * all should be ones that return identically for the same underlying code
1716 #define FBC_BOUND(TEST_NON_UTF8, TEST_UV, TEST_UTF8) \
1718 FBC_UTF8(TEST_UV, TEST_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER), \
1719 TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER)
1721 #define FBC_BOUND_A(TEST_NON_UTF8) \
1723 FBC_UTF8_A(TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER), \
1724 TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER)
1726 #define FBC_NBOUND(TEST_NON_UTF8, TEST_UV, TEST_UTF8) \
1728 FBC_UTF8(TEST_UV, TEST_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT), \
1729 TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT)
1731 #define FBC_NBOUND_A(TEST_NON_UTF8) \
1733 FBC_UTF8_A(TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT), \
1734 TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT)
1736 /* Takes a pointer to an inversion list, a pointer to its corresponding
1737 * inversion map, and a code point, and returns the code point's value
1738 * according to the two arrays. It assumes that all code points have a value.
1739 * This is used as the base macro for macros for particular properties */
1740 #define _generic_GET_BREAK_VAL_CP(invlist, invmap, cp) \
1741 invmap[_invlist_search(invlist, cp)]
1743 /* Same as above, but takes begin, end ptrs to a UTF-8 encoded string instead
1744 * of a code point, returning the value for the first code point in the string.
1745 * And it takes the particular macro name that finds the desired value given a
1746 * code point. Merely convert the UTF-8 to code point and call the cp macro */
1747 #define _generic_GET_BREAK_VAL_UTF8(cp_macro, pos, strend) \
1748 (__ASSERT_(pos < strend) \
1749 /* Note assumes is valid UTF-8 */ \
1750 (cp_macro(utf8_to_uvchr_buf((pos), (strend), NULL))))
1752 /* Returns the GCB value for the input code point */
1753 #define getGCB_VAL_CP(cp) \
1754 _generic_GET_BREAK_VAL_CP( \
1759 /* Returns the GCB value for the first code point in the UTF-8 encoded string
1760 * bounded by pos and strend */
1761 #define getGCB_VAL_UTF8(pos, strend) \
1762 _generic_GET_BREAK_VAL_UTF8(getGCB_VAL_CP, pos, strend)
1765 /* Returns the SB value for the input code point */
1766 #define getSB_VAL_CP(cp) \
1767 _generic_GET_BREAK_VAL_CP( \
1772 /* Returns the SB value for the first code point in the UTF-8 encoded string
1773 * bounded by pos and strend */
1774 #define getSB_VAL_UTF8(pos, strend) \
1775 _generic_GET_BREAK_VAL_UTF8(getSB_VAL_CP, pos, strend)
1777 /* Returns the WB value for the input code point */
1778 #define getWB_VAL_CP(cp) \
1779 _generic_GET_BREAK_VAL_CP( \
1784 /* Returns the WB value for the first code point in the UTF-8 encoded string
1785 * bounded by pos and strend */
1786 #define getWB_VAL_UTF8(pos, strend) \
1787 _generic_GET_BREAK_VAL_UTF8(getWB_VAL_CP, pos, strend)
1789 /* We know what class REx starts with. Try to find this position... */
1790 /* if reginfo->intuit, its a dryrun */
1791 /* annoyingly all the vars in this routine have different names from their counterparts
1792 in regmatch. /grrr */
1794 S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s,
1795 const char *strend, regmatch_info *reginfo)
1798 const I32 doevery = (prog->intflags & PREGf_SKIP) == 0;
1799 char *pat_string; /* The pattern's exactish string */
1800 char *pat_end; /* ptr to end char of pat_string */
1801 re_fold_t folder; /* Function for computing non-utf8 folds */
1802 const U8 *fold_array; /* array for folding ords < 256 */
1808 I32 tmp = 1; /* Scratch variable? */
1809 const bool utf8_target = reginfo->is_utf8_target;
1810 UV utf8_fold_flags = 0;
1811 const bool is_utf8_pat = reginfo->is_utf8_pat;
1812 bool to_complement = FALSE; /* Invert the result? Taking the xor of this
1813 with a result inverts that result, as 0^1 =
1815 _char_class_number classnum;
1817 RXi_GET_DECL(prog,progi);
1819 PERL_ARGS_ASSERT_FIND_BYCLASS;
1821 /* We know what class it must start with. */
1824 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
1829 REXEC_FBC_UTF8_CLASS_SCAN(
1830 reginclass(prog, c, (U8*)s, (U8*) strend, utf8_target));
1833 REXEC_FBC_CLASS_SCAN(REGINCLASS(prog, c, (U8*)s));
1837 case EXACTFA_NO_TRIE: /* This node only generated for non-utf8 patterns */
1838 assert(! is_utf8_pat);
1841 if (is_utf8_pat || utf8_target) {
1842 utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII;
1843 goto do_exactf_utf8;
1845 fold_array = PL_fold_latin1; /* Latin1 folds are not affected by */
1846 folder = foldEQ_latin1; /* /a, except the sharp s one which */
1847 goto do_exactf_non_utf8; /* isn't dealt with by these */
1849 case EXACTF: /* This node only generated for non-utf8 patterns */
1850 assert(! is_utf8_pat);
1852 utf8_fold_flags = 0;
1853 goto do_exactf_utf8;
1855 fold_array = PL_fold;
1857 goto do_exactf_non_utf8;
1860 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
1861 if (is_utf8_pat || utf8_target || IN_UTF8_CTYPE_LOCALE) {
1862 utf8_fold_flags = FOLDEQ_LOCALE;
1863 goto do_exactf_utf8;
1865 fold_array = PL_fold_locale;
1866 folder = foldEQ_locale;
1867 goto do_exactf_non_utf8;
1871 utf8_fold_flags = FOLDEQ_S2_ALREADY_FOLDED;
1873 goto do_exactf_utf8;
1876 if (! utf8_target) { /* All code points in this node require
1877 UTF-8 to express. */
1880 utf8_fold_flags = FOLDEQ_LOCALE | FOLDEQ_S2_ALREADY_FOLDED
1881 | FOLDEQ_S2_FOLDS_SANE;
1882 goto do_exactf_utf8;
1885 if (is_utf8_pat || utf8_target) {
1886 utf8_fold_flags = is_utf8_pat ? FOLDEQ_S2_ALREADY_FOLDED : 0;
1887 goto do_exactf_utf8;
1890 /* Any 'ss' in the pattern should have been replaced by regcomp,
1891 * so we don't have to worry here about this single special case
1892 * in the Latin1 range */
1893 fold_array = PL_fold_latin1;
1894 folder = foldEQ_latin1;
1898 do_exactf_non_utf8: /* Neither pattern nor string are UTF8, and there
1899 are no glitches with fold-length differences
1900 between the target string and pattern */
1902 /* The idea in the non-utf8 EXACTF* cases is to first find the
1903 * first character of the EXACTF* node and then, if necessary,
1904 * case-insensitively compare the full text of the node. c1 is the
1905 * first character. c2 is its fold. This logic will not work for
1906 * Unicode semantics and the german sharp ss, which hence should
1907 * not be compiled into a node that gets here. */
1908 pat_string = STRING(c);
1909 ln = STR_LEN(c); /* length to match in octets/bytes */
1911 /* We know that we have to match at least 'ln' bytes (which is the
1912 * same as characters, since not utf8). If we have to match 3
1913 * characters, and there are only 2 availabe, we know without
1914 * trying that it will fail; so don't start a match past the
1915 * required minimum number from the far end */
1916 e = HOP3c(strend, -((SSize_t)ln), s);
1918 if (reginfo->intuit && e < s) {
1919 e = s; /* Due to minlen logic of intuit() */
1923 c2 = fold_array[c1];
1924 if (c1 == c2) { /* If char and fold are the same */
1925 REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1);
1928 REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1 || *(U8*)s == c2);
1936 /* If one of the operands is in utf8, we can't use the simpler folding
1937 * above, due to the fact that many different characters can have the
1938 * same fold, or portion of a fold, or different- length fold */
1939 pat_string = STRING(c);
1940 ln = STR_LEN(c); /* length to match in octets/bytes */
1941 pat_end = pat_string + ln;
1942 lnc = is_utf8_pat /* length to match in characters */
1943 ? utf8_length((U8 *) pat_string, (U8 *) pat_end)
1946 /* We have 'lnc' characters to match in the pattern, but because of
1947 * multi-character folding, each character in the target can match
1948 * up to 3 characters (Unicode guarantees it will never exceed
1949 * this) if it is utf8-encoded; and up to 2 if not (based on the
1950 * fact that the Latin 1 folds are already determined, and the
1951 * only multi-char fold in that range is the sharp-s folding to
1952 * 'ss'. Thus, a pattern character can match as little as 1/3 of a
1953 * string character. Adjust lnc accordingly, rounding up, so that
1954 * if we need to match at least 4+1/3 chars, that really is 5. */
1955 expansion = (utf8_target) ? UTF8_MAX_FOLD_CHAR_EXPAND : 2;
1956 lnc = (lnc + expansion - 1) / expansion;
1958 /* As in the non-UTF8 case, if we have to match 3 characters, and
1959 * only 2 are left, it's guaranteed to fail, so don't start a
1960 * match that would require us to go beyond the end of the string
1962 e = HOP3c(strend, -((SSize_t)lnc), s);
1964 if (reginfo->intuit && e < s) {
1965 e = s; /* Due to minlen logic of intuit() */
1968 /* XXX Note that we could recalculate e to stop the loop earlier,
1969 * as the worst case expansion above will rarely be met, and as we
1970 * go along we would usually find that e moves further to the left.
1971 * This would happen only after we reached the point in the loop
1972 * where if there were no expansion we should fail. Unclear if
1973 * worth the expense */
1976 char *my_strend= (char *)strend;
1977 if (foldEQ_utf8_flags(s, &my_strend, 0, utf8_target,
1978 pat_string, NULL, ln, is_utf8_pat, utf8_fold_flags)
1979 && (reginfo->intuit || regtry(reginfo, &s)) )
1983 s += (utf8_target) ? UTF8SKIP(s) : 1;
1989 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
1990 if (FLAGS(c) != TRADITIONAL_BOUND) {
1991 if (! IN_UTF8_CTYPE_LOCALE) {
1992 Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
1993 B_ON_NON_UTF8_LOCALE_IS_WRONG);
1998 FBC_BOUND(isWORDCHAR_LC, isWORDCHAR_LC_uvchr, isWORDCHAR_LC_utf8);
2002 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
2003 if (FLAGS(c) != TRADITIONAL_BOUND) {
2004 if (! IN_UTF8_CTYPE_LOCALE) {
2005 Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
2006 B_ON_NON_UTF8_LOCALE_IS_WRONG);
2011 FBC_NBOUND(isWORDCHAR_LC, isWORDCHAR_LC_uvchr, isWORDCHAR_LC_utf8);
2014 case BOUND: /* regcomp.c makes sure that this only has the traditional \b
2016 assert(FLAGS(c) == TRADITIONAL_BOUND);
2018 FBC_BOUND(isWORDCHAR, isWORDCHAR_uni, isWORDCHAR_utf8);
2021 case BOUNDA: /* regcomp.c makes sure that this only has the traditional \b
2023 assert(FLAGS(c) == TRADITIONAL_BOUND);
2025 FBC_BOUND_A(isWORDCHAR_A);
2028 case NBOUND: /* regcomp.c makes sure that this only has the traditional \b
2030 assert(FLAGS(c) == TRADITIONAL_BOUND);
2032 FBC_NBOUND(isWORDCHAR, isWORDCHAR_uni, isWORDCHAR_utf8);
2035 case NBOUNDA: /* regcomp.c makes sure that this only has the traditional \b
2037 assert(FLAGS(c) == TRADITIONAL_BOUND);
2039 FBC_NBOUND_A(isWORDCHAR_A);
2043 if ((bound_type) FLAGS(c) == TRADITIONAL_BOUND) {
2044 FBC_NBOUND(isWORDCHAR_L1, isWORDCHAR_uni, isWORDCHAR_utf8);
2055 switch((bound_type) FLAGS(c)) {
2056 case TRADITIONAL_BOUND:
2057 FBC_BOUND(isWORDCHAR_L1, isWORDCHAR_uni, isWORDCHAR_utf8);
2060 if (s == reginfo->strbeg) { /* GCB always matches at begin and
2062 if (to_complement ^ cBOOL(reginfo->intuit
2063 || regtry(reginfo, &s)))
2067 s += (utf8_target) ? UTF8SKIP(s) : 1;
2071 GCB_enum before = getGCB_VAL_UTF8(
2073 (U8*)(reginfo->strbeg)),
2074 (U8*) reginfo->strend);
2075 while (s < strend) {
2076 GCB_enum after = getGCB_VAL_UTF8((U8*) s,
2077 (U8*) reginfo->strend);
2078 if (to_complement ^ isGCB(before, after)) {
2079 if (reginfo->intuit || regtry(reginfo, &s)) {
2087 else { /* Not utf8. Everything is a GCB except between CR and
2089 while (s < strend) {
2090 if (to_complement ^ (UCHARAT(s - 1) != '\r'
2091 || UCHARAT(s) != '\n'))
2093 if (reginfo->intuit || regtry(reginfo, &s)) {
2101 if (to_complement ^ cBOOL(reginfo->intuit || regtry(reginfo, &s))) {
2107 if (s == reginfo->strbeg) { /* SB always matches at beginning */
2109 ^ cBOOL(reginfo->intuit || regtry(reginfo, &s)))
2114 /* Didn't match. Go try at the next position */
2115 s += (utf8_target) ? UTF8SKIP(s) : 1;
2119 SB_enum before = getSB_VAL_UTF8(reghop3((U8*)s,
2121 (U8*)(reginfo->strbeg)),
2122 (U8*) reginfo->strend);
2123 while (s < strend) {
2124 SB_enum after = getSB_VAL_UTF8((U8*) s,
2125 (U8*) reginfo->strend);
2126 if (to_complement ^ isSB(before,
2128 (U8*) reginfo->strbeg,
2130 (U8*) reginfo->strend,
2133 if (reginfo->intuit || regtry(reginfo, &s)) {
2141 else { /* Not utf8. */
2142 SB_enum before = getSB_VAL_CP((U8) *(s -1));
2143 while (s < strend) {
2144 SB_enum after = getSB_VAL_CP((U8) *s);
2145 if (to_complement ^ isSB(before,
2147 (U8*) reginfo->strbeg,
2149 (U8*) reginfo->strend,
2152 if (reginfo->intuit || regtry(reginfo, &s)) {
2161 /* Here are at the final position in the target string. The SB
2162 * value is always true here, so matches, depending on other
2164 if (to_complement ^ cBOOL(reginfo->intuit
2165 || regtry(reginfo, &s)))
2173 if (s == reginfo->strbeg) {
2174 if (to_complement ^ cBOOL(reginfo->intuit
2175 || regtry(reginfo, &s)))
2179 s += (utf8_target) ? UTF8SKIP(s) : 1;
2183 /* We are at a boundary between char_sub_0 and char_sub_1.
2184 * We also keep track of the value for char_sub_-1 as we
2185 * loop through the line. Context may be needed to make a
2186 * determination, and if so, this can save having to
2188 WB_enum previous = WB_UNKNOWN;
2189 WB_enum before = getWB_VAL_UTF8(
2192 (U8*)(reginfo->strbeg)),
2193 (U8*) reginfo->strend);
2194 while (s < strend) {
2195 WB_enum after = getWB_VAL_UTF8((U8*) s,
2196 (U8*) reginfo->strend);
2197 if (to_complement ^ isWB(previous,
2200 (U8*) reginfo->strbeg,
2202 (U8*) reginfo->strend,
2205 if (reginfo->intuit || regtry(reginfo, &s)) {
2214 else { /* Not utf8. */
2215 WB_enum previous = WB_UNKNOWN;
2216 WB_enum before = getWB_VAL_CP((U8) *(s -1));
2217 while (s < strend) {
2218 WB_enum after = getWB_VAL_CP((U8) *s);
2219 if (to_complement ^ isWB(previous,
2222 (U8*) reginfo->strbeg,
2224 (U8*) reginfo->strend,
2227 if (reginfo->intuit || regtry(reginfo, &s)) {
2237 if (to_complement ^ cBOOL(reginfo->intuit
2238 || regtry(reginfo, &s)))
2248 REXEC_FBC_CSCAN(is_LNBREAK_utf8_safe(s, strend),
2249 is_LNBREAK_latin1_safe(s, strend)
2253 /* The argument to all the POSIX node types is the class number to pass to
2254 * _generic_isCC() to build a mask for searching in PL_charclass[] */
2261 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
2262 REXEC_FBC_CSCAN(to_complement ^ cBOOL(isFOO_utf8_lc(FLAGS(c), (U8 *) s)),
2263 to_complement ^ cBOOL(isFOO_lc(FLAGS(c), *s)));
2278 /* The complement of something that matches only ASCII matches all
2279 * non-ASCII, plus everything in ASCII that isn't in the class. */
2280 REXEC_FBC_UTF8_CLASS_SCAN(! isASCII_utf8(s)
2281 || ! _generic_isCC_A(*s, FLAGS(c)));
2290 /* Don't need to worry about utf8, as it can match only a single
2291 * byte invariant character. */
2292 REXEC_FBC_CLASS_SCAN(
2293 to_complement ^ cBOOL(_generic_isCC_A(*s, FLAGS(c))));
2301 if (! utf8_target) {
2302 REXEC_FBC_CLASS_SCAN(to_complement ^ cBOOL(_generic_isCC(*s,
2308 classnum = (_char_class_number) FLAGS(c);
2309 if (classnum < _FIRST_NON_SWASH_CC) {
2310 while (s < strend) {
2312 /* We avoid loading in the swash as long as possible, but
2313 * should we have to, we jump to a separate loop. This
2314 * extra 'if' statement is what keeps this code from being
2315 * just a call to REXEC_FBC_UTF8_CLASS_SCAN() */
2316 if (UTF8_IS_ABOVE_LATIN1(*s)) {
2317 goto found_above_latin1;
2319 if ((UTF8_IS_INVARIANT(*s)
2320 && to_complement ^ cBOOL(_generic_isCC((U8) *s,
2322 || (UTF8_IS_DOWNGRADEABLE_START(*s)
2323 && to_complement ^ cBOOL(
2324 _generic_isCC(TWO_BYTE_UTF8_TO_NATIVE(*s,
2328 if (tmp && (reginfo->intuit || regtry(reginfo, &s)))
2340 else switch (classnum) { /* These classes are implemented as
2342 case _CC_ENUM_SPACE:
2343 REXEC_FBC_UTF8_CLASS_SCAN(
2344 to_complement ^ cBOOL(isSPACE_utf8(s)));
2347 case _CC_ENUM_BLANK:
2348 REXEC_FBC_UTF8_CLASS_SCAN(
2349 to_complement ^ cBOOL(isBLANK_utf8(s)));
2352 case _CC_ENUM_XDIGIT:
2353 REXEC_FBC_UTF8_CLASS_SCAN(
2354 to_complement ^ cBOOL(isXDIGIT_utf8(s)));
2357 case _CC_ENUM_VERTSPACE:
2358 REXEC_FBC_UTF8_CLASS_SCAN(
2359 to_complement ^ cBOOL(isVERTWS_utf8(s)));
2362 case _CC_ENUM_CNTRL:
2363 REXEC_FBC_UTF8_CLASS_SCAN(
2364 to_complement ^ cBOOL(isCNTRL_utf8(s)));
2368 Perl_croak(aTHX_ "panic: find_byclass() node %d='%s' has an unexpected character class '%d'", OP(c), PL_reg_name[OP(c)], classnum);
2369 NOT_REACHED; /* NOTREACHED */
2374 found_above_latin1: /* Here we have to load a swash to get the result
2375 for the current code point */
2376 if (! PL_utf8_swash_ptrs[classnum]) {
2377 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2378 PL_utf8_swash_ptrs[classnum] =
2379 _core_swash_init("utf8",
2382 PL_XPosix_ptrs[classnum], &flags);
2385 /* This is a copy of the loop above for swash classes, though using the
2386 * FBC macro instead of being expanded out. Since we've loaded the
2387 * swash, we don't have to check for that each time through the loop */
2388 REXEC_FBC_UTF8_CLASS_SCAN(
2389 to_complement ^ cBOOL(_generic_utf8(
2392 swash_fetch(PL_utf8_swash_ptrs[classnum],
2400 /* what trie are we using right now */
2401 reg_ac_data *aho = (reg_ac_data*)progi->data->data[ ARG( c ) ];
2402 reg_trie_data *trie = (reg_trie_data*)progi->data->data[ aho->trie ];
2403 HV *widecharmap = MUTABLE_HV(progi->data->data[ aho->trie + 1 ]);
2405 const char *last_start = strend - trie->minlen;
2407 const char *real_start = s;
2409 STRLEN maxlen = trie->maxlen;
2411 U8 **points; /* map of where we were in the input string
2412 when reading a given char. For ASCII this
2413 is unnecessary overhead as the relationship
2414 is always 1:1, but for Unicode, especially
2415 case folded Unicode this is not true. */
2416 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
2420 GET_RE_DEBUG_FLAGS_DECL;
2422 /* We can't just allocate points here. We need to wrap it in
2423 * an SV so it gets freed properly if there is a croak while
2424 * running the match */
2427 sv_points=newSV(maxlen * sizeof(U8 *));
2428 SvCUR_set(sv_points,
2429 maxlen * sizeof(U8 *));
2430 SvPOK_on(sv_points);
2431 sv_2mortal(sv_points);
2432 points=(U8**)SvPV_nolen(sv_points );
2433 if ( trie_type != trie_utf8_fold
2434 && (trie->bitmap || OP(c)==AHOCORASICKC) )
2437 bitmap=(U8*)trie->bitmap;
2439 bitmap=(U8*)ANYOF_BITMAP(c);
2441 /* this is the Aho-Corasick algorithm modified a touch
2442 to include special handling for long "unknown char" sequences.
2443 The basic idea being that we use AC as long as we are dealing
2444 with a possible matching char, when we encounter an unknown char
2445 (and we have not encountered an accepting state) we scan forward
2446 until we find a legal starting char.
2447 AC matching is basically that of trie matching, except that when
2448 we encounter a failing transition, we fall back to the current
2449 states "fail state", and try the current char again, a process
2450 we repeat until we reach the root state, state 1, or a legal
2451 transition. If we fail on the root state then we can either
2452 terminate if we have reached an accepting state previously, or
2453 restart the entire process from the beginning if we have not.
2456 while (s <= last_start) {
2457 const U32 uniflags = UTF8_ALLOW_DEFAULT;
2465 U8 *uscan = (U8*)NULL;
2466 U8 *leftmost = NULL;
2468 U32 accepted_word= 0;
2472 while ( state && uc <= (U8*)strend ) {
2474 U32 word = aho->states[ state ].wordnum;
2478 DEBUG_TRIE_EXECUTE_r(
2479 if ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
2480 dump_exec_pos( (char *)uc, c, strend, real_start,
2481 (char *)uc, utf8_target );
2482 PerlIO_printf( Perl_debug_log,
2483 " Scanning for legal start char...\n");
2487 while ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
2491 while ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
2497 if (uc >(U8*)last_start) break;
2501 U8 *lpos= points[ (pointpos - trie->wordinfo[word].len) % maxlen ];
2502 if (!leftmost || lpos < leftmost) {
2503 DEBUG_r(accepted_word=word);
2509 points[pointpos++ % maxlen]= uc;
2510 if (foldlen || uc < (U8*)strend) {
2511 REXEC_TRIE_READ_CHAR(trie_type, trie,
2513 uscan, len, uvc, charid, foldlen,
2515 DEBUG_TRIE_EXECUTE_r({
2516 dump_exec_pos( (char *)uc, c, strend,
2517 real_start, s, utf8_target);
2518 PerlIO_printf(Perl_debug_log,
2519 " Charid:%3u CP:%4"UVxf" ",
2531 word = aho->states[ state ].wordnum;
2533 base = aho->states[ state ].trans.base;
2535 DEBUG_TRIE_EXECUTE_r({
2537 dump_exec_pos( (char *)uc, c, strend, real_start,
2539 PerlIO_printf( Perl_debug_log,
2540 "%sState: %4"UVxf", word=%"UVxf,
2541 failed ? " Fail transition to " : "",
2542 (UV)state, (UV)word);
2548 ( ((offset = base + charid
2549 - 1 - trie->uniquecharcount)) >= 0)
2550 && ((U32)offset < trie->lasttrans)
2551 && trie->trans[offset].check == state
2552 && (tmp=trie->trans[offset].next))
2554 DEBUG_TRIE_EXECUTE_r(
2555 PerlIO_printf( Perl_debug_log," - legal\n"));
2560 DEBUG_TRIE_EXECUTE_r(
2561 PerlIO_printf( Perl_debug_log," - fail\n"));
2563 state = aho->fail[state];
2567 /* we must be accepting here */
2568 DEBUG_TRIE_EXECUTE_r(
2569 PerlIO_printf( Perl_debug_log," - accepting\n"));
2578 if (!state) state = 1;
2581 if ( aho->states[ state ].wordnum ) {
2582 U8 *lpos = points[ (pointpos - trie->wordinfo[aho->states[ state ].wordnum].len) % maxlen ];
2583 if (!leftmost || lpos < leftmost) {
2584 DEBUG_r(accepted_word=aho->states[ state ].wordnum);
2589 s = (char*)leftmost;
2590 DEBUG_TRIE_EXECUTE_r({
2592 Perl_debug_log,"Matches word #%"UVxf" at position %"IVdf". Trying full pattern...\n",
2593 (UV)accepted_word, (IV)(s - real_start)
2596 if (reginfo->intuit || regtry(reginfo, &s)) {
2602 DEBUG_TRIE_EXECUTE_r({
2603 PerlIO_printf( Perl_debug_log,"Pattern failed. Looking for new start point...\n");
2606 DEBUG_TRIE_EXECUTE_r(
2607 PerlIO_printf( Perl_debug_log,"No match.\n"));
2616 Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
2623 /* set RX_SAVED_COPY, RX_SUBBEG etc.
2624 * flags have same meanings as with regexec_flags() */
2627 S_reg_set_capture_string(pTHX_ REGEXP * const rx,
2634 struct regexp *const prog = ReANY(rx);
2636 if (flags & REXEC_COPY_STR) {
2640 PerlIO_printf(Perl_debug_log,
2641 "Copy on write: regexp capture, type %d\n",
2644 /* Create a new COW SV to share the match string and store
2645 * in saved_copy, unless the current COW SV in saved_copy
2646 * is valid and suitable for our purpose */
2647 if (( prog->saved_copy
2648 && SvIsCOW(prog->saved_copy)
2649 && SvPOKp(prog->saved_copy)
2652 && SvPVX(sv) == SvPVX(prog->saved_copy)))
2654 /* just reuse saved_copy SV */
2655 if (RXp_MATCH_COPIED(prog)) {
2656 Safefree(prog->subbeg);
2657 RXp_MATCH_COPIED_off(prog);
2661 /* create new COW SV to share string */
2662 RX_MATCH_COPY_FREE(rx);
2663 prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
2665 prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
2666 assert (SvPOKp(prog->saved_copy));
2667 prog->sublen = strend - strbeg;
2668 prog->suboffset = 0;
2669 prog->subcoffset = 0;
2674 SSize_t max = strend - strbeg;
2677 if ( (flags & REXEC_COPY_SKIP_POST)
2678 && !(prog->extflags & RXf_PMf_KEEPCOPY) /* //p */
2679 && !(PL_sawampersand & SAWAMPERSAND_RIGHT)
2680 ) { /* don't copy $' part of string */
2683 /* calculate the right-most part of the string covered
2684 * by a capture. Due to look-ahead, this may be to
2685 * the right of $&, so we have to scan all captures */
2686 while (n <= prog->lastparen) {
2687 if (prog->offs[n].end > max)
2688 max = prog->offs[n].end;
2692 max = (PL_sawampersand & SAWAMPERSAND_LEFT)
2693 ? prog->offs[0].start
2695 assert(max >= 0 && max <= strend - strbeg);
2698 if ( (flags & REXEC_COPY_SKIP_PRE)
2699 && !(prog->extflags & RXf_PMf_KEEPCOPY) /* //p */
2700 && !(PL_sawampersand & SAWAMPERSAND_LEFT)
2701 ) { /* don't copy $` part of string */
2704 /* calculate the left-most part of the string covered
2705 * by a capture. Due to look-behind, this may be to
2706 * the left of $&, so we have to scan all captures */
2707 while (min && n <= prog->lastparen) {
2708 if ( prog->offs[n].start != -1
2709 && prog->offs[n].start < min)
2711 min = prog->offs[n].start;
2715 if ((PL_sawampersand & SAWAMPERSAND_RIGHT)
2716 && min > prog->offs[0].end
2718 min = prog->offs[0].end;
2722 assert(min >= 0 && min <= max && min <= strend - strbeg);
2725 if (RX_MATCH_COPIED(rx)) {
2726 if (sublen > prog->sublen)
2728 (char*)saferealloc(prog->subbeg, sublen+1);
2731 prog->subbeg = (char*)safemalloc(sublen+1);
2732 Copy(strbeg + min, prog->subbeg, sublen, char);
2733 prog->subbeg[sublen] = '\0';
2734 prog->suboffset = min;
2735 prog->sublen = sublen;
2736 RX_MATCH_COPIED_on(rx);
2738 prog->subcoffset = prog->suboffset;
2739 if (prog->suboffset && utf8_target) {
2740 /* Convert byte offset to chars.
2741 * XXX ideally should only compute this if @-/@+
2742 * has been seen, a la PL_sawampersand ??? */
2744 /* If there's a direct correspondence between the
2745 * string which we're matching and the original SV,
2746 * then we can use the utf8 len cache associated with
2747 * the SV. In particular, it means that under //g,
2748 * sv_pos_b2u() will use the previously cached
2749 * position to speed up working out the new length of
2750 * subcoffset, rather than counting from the start of
2751 * the string each time. This stops
2752 * $x = "\x{100}" x 1E6; 1 while $x =~ /(.)/g;
2753 * from going quadratic */
2754 if (SvPOKp(sv) && SvPVX(sv) == strbeg)
2755 prog->subcoffset = sv_pos_b2u_flags(sv, prog->subcoffset,
2756 SV_GMAGIC|SV_CONST_RETURN);
2758 prog->subcoffset = utf8_length((U8*)strbeg,
2759 (U8*)(strbeg+prog->suboffset));
2763 RX_MATCH_COPY_FREE(rx);
2764 prog->subbeg = strbeg;
2765 prog->suboffset = 0;
2766 prog->subcoffset = 0;
2767 prog->sublen = strend - strbeg;
2775 - regexec_flags - match a regexp against a string
2778 Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend,
2779 char *strbeg, SSize_t minend, SV *sv, void *data, U32 flags)
2780 /* stringarg: the point in the string at which to begin matching */
2781 /* strend: pointer to null at end of string */
2782 /* strbeg: real beginning of string */
2783 /* minend: end of match must be >= minend bytes after stringarg. */
2784 /* sv: SV being matched: only used for utf8 flag, pos() etc; string
2785 * itself is accessed via the pointers above */
2786 /* data: May be used for some additional optimizations.
2787 Currently unused. */
2788 /* flags: For optimizations. See REXEC_* in regexp.h */
2791 struct regexp *const prog = ReANY(rx);
2795 SSize_t minlen; /* must match at least this many chars */
2796 SSize_t dontbother = 0; /* how many characters not to try at end */
2797 const bool utf8_target = cBOOL(DO_UTF8(sv));
2799 RXi_GET_DECL(prog,progi);
2800 regmatch_info reginfo_buf; /* create some info to pass to regtry etc */
2801 regmatch_info *const reginfo = ®info_buf;
2802 regexp_paren_pair *swap = NULL;
2804 GET_RE_DEBUG_FLAGS_DECL;
2806 PERL_ARGS_ASSERT_REGEXEC_FLAGS;
2807 PERL_UNUSED_ARG(data);
2809 /* Be paranoid... */
2811 Perl_croak(aTHX_ "NULL regexp parameter");
2815 debug_start_match(rx, utf8_target, stringarg, strend,
2819 startpos = stringarg;
2821 if (prog->intflags & PREGf_GPOS_SEEN) {
2824 /* set reginfo->ganch, the position where \G can match */
2827 (flags & REXEC_IGNOREPOS)
2828 ? stringarg /* use start pos rather than pos() */
2829 : ((mg = mg_find_mglob(sv)) && mg->mg_len >= 0)
2830 /* Defined pos(): */
2831 ? strbeg + MgBYTEPOS(mg, sv, strbeg, strend-strbeg)
2832 : strbeg; /* pos() not defined; use start of string */
2834 DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
2835 "GPOS ganch set to strbeg[%"IVdf"]\n", (IV)(reginfo->ganch - strbeg)));
2837 /* in the presence of \G, we may need to start looking earlier in
2838 * the string than the suggested start point of stringarg:
2839 * if prog->gofs is set, then that's a known, fixed minimum
2842 * /ab|c\G/: gofs = 1
2843 * or if the minimum offset isn't known, then we have to go back
2844 * to the start of the string, e.g. /w+\G/
2847 if (prog->intflags & PREGf_ANCH_GPOS) {
2848 startpos = reginfo->ganch - prog->gofs;
2850 ((flags & REXEC_FAIL_ON_UNDERFLOW) ? stringarg : strbeg))
2852 DEBUG_r(PerlIO_printf(Perl_debug_log,
2853 "fail: ganch-gofs before earliest possible start\n"));
2857 else if (prog->gofs) {
2858 if (startpos - prog->gofs < strbeg)
2861 startpos -= prog->gofs;
2863 else if (prog->intflags & PREGf_GPOS_FLOAT)
2867 minlen = prog->minlen;
2868 if ((startpos + minlen) > strend || startpos < strbeg) {
2869 DEBUG_r(PerlIO_printf(Perl_debug_log,
2870 "Regex match can't succeed, so not even tried\n"));
2874 /* at the end of this function, we'll do a LEAVE_SCOPE(oldsave),
2875 * which will call destuctors to reset PL_regmatch_state, free higher
2876 * PL_regmatch_slabs, and clean up regmatch_info_aux and
2877 * regmatch_info_aux_eval */
2879 oldsave = PL_savestack_ix;
2883 if ((prog->extflags & RXf_USE_INTUIT)
2884 && !(flags & REXEC_CHECKED))
2886 s = re_intuit_start(rx, sv, strbeg, startpos, strend,
2891 if (prog->extflags & RXf_CHECK_ALL) {
2892 /* we can match based purely on the result of INTUIT.
2893 * Set up captures etc just for $& and $-[0]
2894 * (an intuit-only match wont have $1,$2,..) */
2895 assert(!prog->nparens);
2897 /* s/// doesn't like it if $& is earlier than where we asked it to
2898 * start searching (which can happen on something like /.\G/) */
2899 if ( (flags & REXEC_FAIL_ON_UNDERFLOW)
2902 /* this should only be possible under \G */
2903 assert(prog->intflags & PREGf_GPOS_SEEN);
2904 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
2905 "matched, but failing for REXEC_FAIL_ON_UNDERFLOW\n"));
2909 /* match via INTUIT shouldn't have any captures.
2910 * Let @-, @+, $^N know */
2911 prog->lastparen = prog->lastcloseparen = 0;
2912 RX_MATCH_UTF8_set(rx, utf8_target);
2913 prog->offs[0].start = s - strbeg;
2914 prog->offs[0].end = utf8_target
2915 ? (char*)utf8_hop((U8*)s, prog->minlenret) - strbeg
2916 : s - strbeg + prog->minlenret;
2917 if ( !(flags & REXEC_NOT_FIRST) )
2918 S_reg_set_capture_string(aTHX_ rx,
2920 sv, flags, utf8_target);
2926 multiline = prog->extflags & RXf_PMf_MULTILINE;
2928 if (strend - s < (minlen+(prog->check_offset_min<0?prog->check_offset_min:0))) {
2929 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
2930 "String too short [regexec_flags]...\n"));
2934 /* Check validity of program. */
2935 if (UCHARAT(progi->program) != REG_MAGIC) {
2936 Perl_croak(aTHX_ "corrupted regexp program");
2939 RX_MATCH_TAINTED_off(rx);
2940 RX_MATCH_UTF8_set(rx, utf8_target);
2942 reginfo->prog = rx; /* Yes, sorry that this is confusing. */
2943 reginfo->intuit = 0;
2944 reginfo->is_utf8_target = cBOOL(utf8_target);
2945 reginfo->is_utf8_pat = cBOOL(RX_UTF8(rx));
2946 reginfo->warned = FALSE;
2947 reginfo->strbeg = strbeg;
2949 reginfo->poscache_maxiter = 0; /* not yet started a countdown */
2950 reginfo->strend = strend;
2951 /* see how far we have to get to not match where we matched before */
2952 reginfo->till = stringarg + minend;
2954 if (prog->extflags & RXf_EVAL_SEEN && SvPADTMP(sv)) {
2955 /* SAVEFREESV, not sv_mortalcopy, as this SV must last until after
2956 S_cleanup_regmatch_info_aux has executed (registered by
2957 SAVEDESTRUCTOR_X below). S_cleanup_regmatch_info_aux modifies
2958 magic belonging to this SV.
2959 Not newSVsv, either, as it does not COW.
2961 reginfo->sv = newSV(0);
2962 SvSetSV_nosteal(reginfo->sv, sv);
2963 SAVEFREESV(reginfo->sv);
2966 /* reserve next 2 or 3 slots in PL_regmatch_state:
2967 * slot N+0: may currently be in use: skip it
2968 * slot N+1: use for regmatch_info_aux struct
2969 * slot N+2: use for regmatch_info_aux_eval struct if we have (?{})'s
2970 * slot N+3: ready for use by regmatch()
2974 regmatch_state *old_regmatch_state;
2975 regmatch_slab *old_regmatch_slab;
2976 int i, max = (prog->extflags & RXf_EVAL_SEEN) ? 2 : 1;
2978 /* on first ever match, allocate first slab */
2979 if (!PL_regmatch_slab) {
2980 Newx(PL_regmatch_slab, 1, regmatch_slab);
2981 PL_regmatch_slab->prev = NULL;
2982 PL_regmatch_slab->next = NULL;
2983 PL_regmatch_state = SLAB_FIRST(PL_regmatch_slab);
2986 old_regmatch_state = PL_regmatch_state;
2987 old_regmatch_slab = PL_regmatch_slab;
2989 for (i=0; i <= max; i++) {
2991 reginfo->info_aux = &(PL_regmatch_state->u.info_aux);
2993 reginfo->info_aux_eval =
2994 reginfo->info_aux->info_aux_eval =
2995 &(PL_regmatch_state->u.info_aux_eval);
2997 if (++PL_regmatch_state > SLAB_LAST(PL_regmatch_slab))
2998 PL_regmatch_state = S_push_slab(aTHX);
3001 /* note initial PL_regmatch_state position; at end of match we'll
3002 * pop back to there and free any higher slabs */
3004 reginfo->info_aux->old_regmatch_state = old_regmatch_state;
3005 reginfo->info_aux->old_regmatch_slab = old_regmatch_slab;
3006 reginfo->info_aux->poscache = NULL;
3008 SAVEDESTRUCTOR_X(S_cleanup_regmatch_info_aux, reginfo->info_aux);
3010 if ((prog->extflags & RXf_EVAL_SEEN))
3011 S_setup_eval_state(aTHX_ reginfo);
3013 reginfo->info_aux_eval = reginfo->info_aux->info_aux_eval = NULL;
3016 /* If there is a "must appear" string, look for it. */
3018 if (PL_curpm && (PM_GETRE(PL_curpm) == rx)) {
3019 /* We have to be careful. If the previous successful match
3020 was from this regex we don't want a subsequent partially
3021 successful match to clobber the old results.
3022 So when we detect this possibility we add a swap buffer
3023 to the re, and switch the buffer each match. If we fail,
3024 we switch it back; otherwise we leave it swapped.
3027 /* do we need a save destructor here for eval dies? */
3028 Newxz(prog->offs, (prog->nparens + 1), regexp_paren_pair);
3029 DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
3030 "rex=0x%"UVxf" saving offs: orig=0x%"UVxf" new=0x%"UVxf"\n",
3037 /* Simplest case: anchored match need be tried only once, or with
3038 * MBOL, only at the beginning of each line.
3040 * Note that /.*.../ sets PREGf_IMPLICIT|MBOL, while /.*.../s sets
3041 * PREGf_IMPLICIT|SBOL. The idea is that with /.*.../s, if it doesn't
3042 * match at the start of the string then it won't match anywhere else
3043 * either; while with /.*.../, if it doesn't match at the beginning,
3044 * the earliest it could match is at the start of the next line */
3046 if (prog->intflags & (PREGf_ANCH & ~PREGf_ANCH_GPOS)) {
3049 if (regtry(reginfo, &s))
3052 if (!(prog->intflags & PREGf_ANCH_MBOL))
3055 /* didn't match at start, try at other newline positions */
3058 dontbother = minlen - 1;
3059 end = HOP3c(strend, -dontbother, strbeg) - 1;
3061 /* skip to next newline */
3063 while (s <= end) { /* note it could be possible to match at the end of the string */
3064 /* NB: newlines are the same in unicode as they are in latin */
3067 if (prog->check_substr || prog->check_utf8) {
3068 /* note that with PREGf_IMPLICIT, intuit can only fail
3069 * or return the start position, so it's of limited utility.
3070 * Nevertheless, I made the decision that the potential for
3071 * quick fail was still worth it - DAPM */
3072 s = re_intuit_start(rx, sv, strbeg, s, strend, flags, NULL);
3076 if (regtry(reginfo, &s))
3080 } /* end anchored search */
3082 if (prog->intflags & PREGf_ANCH_GPOS)
3084 /* PREGf_ANCH_GPOS should never be true if PREGf_GPOS_SEEN is not true */
3085 assert(prog->intflags & PREGf_GPOS_SEEN);
3086 /* For anchored \G, the only position it can match from is
3087 * (ganch-gofs); we already set startpos to this above; if intuit
3088 * moved us on from there, we can't possibly succeed */
3089 assert(startpos == reginfo->ganch - prog->gofs);
3090 if (s == startpos && regtry(reginfo, &s))
3095 /* Messy cases: unanchored match. */
3096 if ((prog->anchored_substr || prog->anchored_utf8) && prog->intflags & PREGf_SKIP) {
3097 /* we have /x+whatever/ */
3098 /* it must be a one character string (XXXX Except is_utf8_pat?) */
3104 if (! prog->anchored_utf8) {
3105 to_utf8_substr(prog);
3107 ch = SvPVX_const(prog->anchored_utf8)[0];
3110 DEBUG_EXECUTE_r( did_match = 1 );
3111 if (regtry(reginfo, &s)) goto got_it;
3113 while (s < strend && *s == ch)
3120 if (! prog->anchored_substr) {
3121 if (! to_byte_substr(prog)) {
3122 NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
3125 ch = SvPVX_const(prog->anchored_substr)[0];
3128 DEBUG_EXECUTE_r( did_match = 1 );
3129 if (regtry(reginfo, &s)) goto got_it;
3131 while (s < strend && *s == ch)
3136 DEBUG_EXECUTE_r(if (!did_match)
3137 PerlIO_printf(Perl_debug_log,
3138 "Did not find anchored character...\n")
3141 else if (prog->anchored_substr != NULL
3142 || prog->anchored_utf8 != NULL
3143 || ((prog->float_substr != NULL || prog->float_utf8 != NULL)
3144 && prog->float_max_offset < strend - s)) {
3149 char *last1; /* Last position checked before */
3153 if (prog->anchored_substr || prog->anchored_utf8) {
3155 if (! prog->anchored_utf8) {
3156 to_utf8_substr(prog);
3158 must = prog->anchored_utf8;
3161 if (! prog->anchored_substr) {
3162 if (! to_byte_substr(prog)) {
3163 NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
3166 must = prog->anchored_substr;
3168 back_max = back_min = prog->anchored_offset;
3171 if (! prog->float_utf8) {
3172 to_utf8_substr(prog);
3174 must = prog->float_utf8;
3177 if (! prog->float_substr) {
3178 if (! to_byte_substr(prog)) {
3179 NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
3182 must = prog->float_substr;
3184 back_max = prog->float_max_offset;
3185 back_min = prog->float_min_offset;
3191 last = HOP3c(strend, /* Cannot start after this */
3192 -(SSize_t)(CHR_SVLEN(must)
3193 - (SvTAIL(must) != 0) + back_min), strbeg);
3195 if (s > reginfo->strbeg)
3196 last1 = HOPc(s, -1);
3198 last1 = s - 1; /* bogus */
3200 /* XXXX check_substr already used to find "s", can optimize if
3201 check_substr==must. */
3203 strend = HOPc(strend, -dontbother);
3204 while ( (s <= last) &&
3205 (s = fbm_instr((unsigned char*)HOP4c(s, back_min, strbeg, strend),
3206 (unsigned char*)strend, must,
3207 multiline ? FBMrf_MULTILINE : 0)) ) {
3208 DEBUG_EXECUTE_r( did_match = 1 );
3209 if (HOPc(s, -back_max) > last1) {
3210 last1 = HOPc(s, -back_min);
3211 s = HOPc(s, -back_max);
3214 char * const t = (last1 >= reginfo->strbeg)
3215 ? HOPc(last1, 1) : last1 + 1;
3217 last1 = HOPc(s, -back_min);
3221 while (s <= last1) {
3222 if (regtry(reginfo, &s))
3225 s++; /* to break out of outer loop */
3232 while (s <= last1) {
3233 if (regtry(reginfo, &s))
3239 DEBUG_EXECUTE_r(if (!did_match) {
3240 RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
3241 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
3242 PerlIO_printf(Perl_debug_log, "Did not find %s substr %s%s...\n",
3243 ((must == prog->anchored_substr || must == prog->anchored_utf8)
3244 ? "anchored" : "floating"),
3245 quoted, RE_SV_TAIL(must));
3249 else if ( (c = progi->regstclass) ) {
3251 const OPCODE op = OP(progi->regstclass);
3252 /* don't bother with what can't match */
3253 if (PL_regkind[op] != EXACT && PL_regkind[op] != TRIE)
3254 strend = HOPc(strend, -(minlen - 1));
3257 SV * const prop = sv_newmortal();
3258 regprop(prog, prop, c, reginfo, NULL);
3260 RE_PV_QUOTED_DECL(quoted,utf8_target,PERL_DEBUG_PAD_ZERO(1),
3262 PerlIO_printf(Perl_debug_log,
3263 "Matching stclass %.*s against %s (%d bytes)\n",
3264 (int)SvCUR(prop), SvPVX_const(prop),
3265 quoted, (int)(strend - s));
3268 if (find_byclass(prog, c, s, strend, reginfo))
3270 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass... [regexec_flags]\n"));
3274 if (prog->float_substr != NULL || prog->float_utf8 != NULL) {
3282 if (! prog->float_utf8) {
3283 to_utf8_substr(prog);
3285 float_real = prog->float_utf8;
3288 if (! prog->float_substr) {
3289 if (! to_byte_substr(prog)) {
3290 NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
3293 float_real = prog->float_substr;
3296 little = SvPV_const(float_real, len);
3297 if (SvTAIL(float_real)) {
3298 /* This means that float_real contains an artificial \n on
3299 * the end due to the presence of something like this:
3300 * /foo$/ where we can match both "foo" and "foo\n" at the
3301 * end of the string. So we have to compare the end of the
3302 * string first against the float_real without the \n and
3303 * then against the full float_real with the string. We
3304 * have to watch out for cases where the string might be
3305 * smaller than the float_real or the float_real without
3307 char *checkpos= strend - len;
3309 PerlIO_printf(Perl_debug_log,
3310 "%sChecking for float_real.%s\n",
3311 PL_colors[4], PL_colors[5]));
3312 if (checkpos + 1 < strbeg) {
3313 /* can't match, even if we remove the trailing \n
3314 * string is too short to match */
3316 PerlIO_printf(Perl_debug_log,
3317 "%sString shorter than required trailing substring, cannot match.%s\n",
3318 PL_colors[4], PL_colors[5]));
3320 } else if (memEQ(checkpos + 1, little, len - 1)) {
3321 /* can match, the end of the string matches without the
3323 last = checkpos + 1;
3324 } else if (checkpos < strbeg) {
3325 /* cant match, string is too short when the "\n" is
3328 PerlIO_printf(Perl_debug_log,
3329 "%sString does not contain required trailing substring, cannot match.%s\n",
3330 PL_colors[4], PL_colors[5]));
3332 } else if (!multiline) {
3333 /* non multiline match, so compare with the "\n" at the
3334 * end of the string */
3335 if (memEQ(checkpos, little, len)) {
3339 PerlIO_printf(Perl_debug_log,
3340 "%sString does not contain required trailing substring, cannot match.%s\n",
3341 PL_colors[4], PL_colors[5]));
3345 /* multiline match, so we have to search for a place
3346 * where the full string is located */
3352 last = rninstr(s, strend, little, little + len);
3354 last = strend; /* matching "$" */
3357 /* at one point this block contained a comment which was
3358 * probably incorrect, which said that this was a "should not
3359 * happen" case. Even if it was true when it was written I am
3360 * pretty sure it is not anymore, so I have removed the comment
3361 * and replaced it with this one. Yves */
3363 PerlIO_printf(Perl_debug_log,
3364 "%sString does not contain required substring, cannot match.%s\n",
3365 PL_colors[4], PL_colors[5]
3369 dontbother = strend - last + prog->float_min_offset;
3371 if (minlen && (dontbother < minlen))
3372 dontbother = minlen - 1;
3373 strend -= dontbother; /* this one's always in bytes! */
3374 /* We don't know much -- general case. */
3377 if (regtry(reginfo, &s))
3386 if (regtry(reginfo, &s))
3388 } while (s++ < strend);
3396 /* s/// doesn't like it if $& is earlier than where we asked it to
3397 * start searching (which can happen on something like /.\G/) */
3398 if ( (flags & REXEC_FAIL_ON_UNDERFLOW)
3399 && (prog->offs[0].start < stringarg - strbeg))
3401 /* this should only be possible under \G */
3402 assert(prog->intflags & PREGf_GPOS_SEEN);
3403 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
3404 "matched, but failing for REXEC_FAIL_ON_UNDERFLOW\n"));
3410 PerlIO_printf(Perl_debug_log,
3411 "rex=0x%"UVxf" freeing offs: 0x%"UVxf"\n",
3418 /* clean up; this will trigger destructors that will free all slabs
3419 * above the current one, and cleanup the regmatch_info_aux
3420 * and regmatch_info_aux_eval sructs */
3422 LEAVE_SCOPE(oldsave);
3424 if (RXp_PAREN_NAMES(prog))
3425 (void)hv_iterinit(RXp_PAREN_NAMES(prog));
3427 /* make sure $`, $&, $', and $digit will work later */
3428 if ( !(flags & REXEC_NOT_FIRST) )
3429 S_reg_set_capture_string(aTHX_ rx,
3430 strbeg, reginfo->strend,
3431 sv, flags, utf8_target);
3436 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
3437 PL_colors[4], PL_colors[5]));
3439 /* clean up; this will trigger destructors that will free all slabs
3440 * above the current one, and cleanup the regmatch_info_aux
3441 * and regmatch_info_aux_eval sructs */
3443 LEAVE_SCOPE(oldsave);
3446 /* we failed :-( roll it back */
3447 DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
3448 "rex=0x%"UVxf" rolling back offs: freeing=0x%"UVxf" restoring=0x%"UVxf"\n",
3453 Safefree(prog->offs);
3460 /* Set which rex is pointed to by PL_reg_curpm, handling ref counting.
3461 * Do inc before dec, in case old and new rex are the same */
3462 #define SET_reg_curpm(Re2) \
3463 if (reginfo->info_aux_eval) { \
3464 (void)ReREFCNT_inc(Re2); \
3465 ReREFCNT_dec(PM_GETRE(PL_reg_curpm)); \
3466 PM_SETRE((PL_reg_curpm), (Re2)); \
3471 - regtry - try match at specific point
3473 STATIC I32 /* 0 failure, 1 success */
3474 S_regtry(pTHX_ regmatch_info *reginfo, char **startposp)
3477 REGEXP *const rx = reginfo->prog;
3478 regexp *const prog = ReANY(rx);
3480 RXi_GET_DECL(prog,progi);
3481 GET_RE_DEBUG_FLAGS_DECL;
3483 PERL_ARGS_ASSERT_REGTRY;
3485 reginfo->cutpoint=NULL;
3487 prog->offs[0].start = *startposp - reginfo->strbeg;
3488 prog->lastparen = 0;
3489 prog->lastcloseparen = 0;
3491 /* XXXX What this code is doing here?!!! There should be no need
3492 to do this again and again, prog->lastparen should take care of
3495 /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
3496 * Actually, the code in regcppop() (which Ilya may be meaning by
3497 * prog->lastparen), is not needed at all by the test suite
3498 * (op/regexp, op/pat, op/split), but that code is needed otherwise
3499 * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
3500 * Meanwhile, this code *is* needed for the
3501 * above-mentioned test suite tests to succeed. The common theme
3502 * on those tests seems to be returning null fields from matches.
3503 * --jhi updated by dapm */
3505 if (prog->nparens) {
3506 regexp_paren_pair *pp = prog->offs;
3508 for (i = prog->nparens; i > (I32)prog->lastparen; i--) {
3516 result = regmatch(reginfo, *startposp, progi->program + 1);
3518 prog->offs[0].end = result;
3521 if (reginfo->cutpoint)
3522 *startposp= reginfo->cutpoint;
3523 REGCP_UNWIND(lastcp);
3528 #define sayYES goto yes
3529 #define sayNO goto no
3530 #define sayNO_SILENT goto no_silent
3532 /* we dont use STMT_START/END here because it leads to
3533 "unreachable code" warnings, which are bogus, but distracting. */
3534 #define CACHEsayNO \
3535 if (ST.cache_mask) \
3536 reginfo->info_aux->poscache[ST.cache_offset] |= ST.cache_mask; \
3539 /* this is used to determine how far from the left messages like
3540 'failed...' are printed. It should be set such that messages
3541 are inline with the regop output that created them.
3543 #define REPORT_CODE_OFF 32
3546 #define CHRTEST_UNINIT -1001 /* c1/c2 haven't been calculated yet */
3547 #define CHRTEST_VOID -1000 /* the c1/c2 "next char" test should be skipped */
3548 #define CHRTEST_NOT_A_CP_1 -999
3549 #define CHRTEST_NOT_A_CP_2 -998
3551 /* grab a new slab and return the first slot in it */
3553 STATIC regmatch_state *
3556 #if PERL_VERSION < 9 && !defined(PERL_CORE)
3559 regmatch_slab *s = PL_regmatch_slab->next;
3561 Newx(s, 1, regmatch_slab);
3562 s->prev = PL_regmatch_slab;
3564 PL_regmatch_slab->next = s;
3566 PL_regmatch_slab = s;
3567 return SLAB_FIRST(s);
3571 /* push a new state then goto it */
3573 #define PUSH_STATE_GOTO(state, node, input) \
3574 pushinput = input; \
3576 st->resume_state = state; \
3579 /* push a new state with success backtracking, then goto it */
3581 #define PUSH_YES_STATE_GOTO(state, node, input) \
3582 pushinput = input; \
3584 st->resume_state = state; \
3585 goto push_yes_state;
3592 regmatch() - main matching routine
3594 This is basically one big switch statement in a loop. We execute an op,
3595 set 'next' to point the next op, and continue. If we come to a point which
3596 we may need to backtrack to on failure such as (A|B|C), we push a
3597 backtrack state onto the backtrack stack. On failure, we pop the top
3598 state, and re-enter the loop at the state indicated. If there are no more
3599 states to pop, we return failure.
3601 Sometimes we also need to backtrack on success; for example /A+/, where
3602 after successfully matching one A, we need to go back and try to
3603 match another one; similarly for lookahead assertions: if the assertion
3604 completes successfully, we backtrack to the state just before the assertion
3605 and then carry on. In these cases, the pushed state is marked as
3606 'backtrack on success too'. This marking is in fact done by a chain of
3607 pointers, each pointing to the previous 'yes' state. On success, we pop to
3608 the nearest yes state, discarding any intermediate failure-only states.
3609 Sometimes a yes state is pushed just to force some cleanup code to be
3610 called at the end of a successful match or submatch; e.g. (??{$re}) uses
3611 it to free the inner regex.
3613 Note that failure backtracking rewinds the cursor position, while
3614 success backtracking leaves it alone.
3616 A pattern is complete when the END op is executed, while a subpattern
3617 such as (?=foo) is complete when the SUCCESS op is executed. Both of these
3618 ops trigger the "pop to last yes state if any, otherwise return true"
3621 A common convention in this function is to use A and B to refer to the two
3622 subpatterns (or to the first nodes thereof) in patterns like /A*B/: so A is
3623 the subpattern to be matched possibly multiple times, while B is the entire
3624 rest of the pattern. Variable and state names reflect this convention.
3626 The states in the main switch are the union of ops and failure/success of
3627 substates associated with with that op. For example, IFMATCH is the op
3628 that does lookahead assertions /(?=A)B/ and so the IFMATCH state means
3629 'execute IFMATCH'; while IFMATCH_A is a state saying that we have just
3630 successfully matched A and IFMATCH_A_fail is a state saying that we have
3631 just failed to match A. Resume states always come in pairs. The backtrack
3632 state we push is marked as 'IFMATCH_A', but when that is popped, we resume
3633 at IFMATCH_A or IFMATCH_A_fail, depending on whether we are backtracking
3634 on success or failure.
3636 The struct that holds a backtracking state is actually a big union, with
3637 one variant for each major type of op. The variable st points to the
3638 top-most backtrack struct. To make the code clearer, within each
3639 block of code we #define ST to alias the relevant union.
3641 Here's a concrete example of a (vastly oversimplified) IFMATCH
3647 #define ST st->u.ifmatch
3649 case IFMATCH: // we are executing the IFMATCH op, (?=A)B
3650 ST.foo = ...; // some state we wish to save
3652 // push a yes backtrack state with a resume value of
3653 // IFMATCH_A/IFMATCH_A_fail, then continue execution at the
3655 PUSH_YES_STATE_GOTO(IFMATCH_A, A, newinput);
3658 case IFMATCH_A: // we have successfully executed A; now continue with B
3660 bar = ST.foo; // do something with the preserved value
3663 case IFMATCH_A_fail: // A failed, so the assertion failed
3664 ...; // do some housekeeping, then ...
3665 sayNO; // propagate the failure
3672 For any old-timers reading this who are familiar with the old recursive
3673 approach, the code above is equivalent to:
3675 case IFMATCH: // we are executing the IFMATCH op, (?=A)B
3684 ...; // do some housekeeping, then ...
3685 sayNO; // propagate the failure
3688 The topmost backtrack state, pointed to by st, is usually free. If you
3689 want to claim it, populate any ST.foo fields in it with values you wish to
3690 save, then do one of
3692 PUSH_STATE_GOTO(resume_state, node, newinput);
3693 PUSH_YES_STATE_GOTO(resume_state, node, newinput);
3695 which sets that backtrack state's resume value to 'resume_state', pushes a
3696 new free entry to the top of the backtrack stack, then goes to 'node'.
3697 On backtracking, the free slot is popped, and the saved state becomes the
3698 new free state. An ST.foo field in this new top state can be temporarily
3699 accessed to retrieve values, but once the main loop is re-entered, it
3700 becomes available for reuse.
3702 Note that the depth of the backtrack stack constantly increases during the
3703 left-to-right execution of the pattern, rather than going up and down with
3704 the pattern nesting. For example the stack is at its maximum at Z at the
3705 end of the pattern, rather than at X in the following:
3707 /(((X)+)+)+....(Y)+....Z/
3709 The only exceptions to this are lookahead/behind assertions and the cut,
3710 (?>A), which pop all the backtrack states associated with A before
3713 Backtrack state structs are allocated in slabs of about 4K in size.
3714 PL_regmatch_state and st always point to the currently active state,
3715 and PL_regmatch_slab points to the slab currently containing
3716 PL_regmatch_state. The first time regmatch() is called, the first slab is
3717 allocated, and is never freed until interpreter destruction. When the slab
3718 is full, a new one is allocated and chained to the end. At exit from
3719 regmatch(), slabs allocated since entry are freed.
3724 #define DEBUG_STATE_pp(pp) \
3726 DUMP_EXEC_POS(locinput, scan, utf8_target); \
3727 PerlIO_printf(Perl_debug_log, \
3728 " %*s"pp" %s%s%s%s%s\n", \
3730 PL_reg_name[st->resume_state], \
3731 ((st==yes_state||st==mark_state) ? "[" : ""), \
3732 ((st==yes_state) ? "Y" : ""), \
3733 ((st==mark_state) ? "M" : ""), \
3734 ((st==yes_state||st==mark_state) ? "]" : "") \
3739 #define REG_NODE_NUM(x) ((x) ? (int)((x)-prog) : -1)
3744 S_debug_start_match(pTHX_ const REGEXP *prog, const bool utf8_target,
3745 const char *start, const char *end, const char *blurb)
3747 const bool utf8_pat = RX_UTF8(prog) ? 1 : 0;
3749 PERL_ARGS_ASSERT_DEBUG_START_MATCH;
3754 RE_PV_QUOTED_DECL(s0, utf8_pat, PERL_DEBUG_PAD_ZERO(0),
3755 RX_PRECOMP_const(prog), RX_PRELEN(prog), 60);
3757 RE_PV_QUOTED_DECL(s1, utf8_target, PERL_DEBUG_PAD_ZERO(1),
3758 start, end - start, 60);
3760 PerlIO_printf(Perl_debug_log,
3761 "%s%s REx%s %s against %s\n",
3762 PL_colors[4], blurb, PL_colors[5], s0, s1);
3764 if (utf8_target||utf8_pat)
3765 PerlIO_printf(Perl_debug_log, "UTF-8 %s%s%s...\n",
3766 utf8_pat ? "pattern" : "",
3767 utf8_pat && utf8_target ? " and " : "",
3768 utf8_target ? "string" : ""
3774 S_dump_exec_pos(pTHX_ const char *locinput,
3775 const regnode *scan,
3776 const char *loc_regeol,
3777 const char *loc_bostr,
3778 const char *loc_reg_starttry,
3779 const bool utf8_target)
3781 const int docolor = *PL_colors[0] || *PL_colors[2] || *PL_colors[4];
3782 const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
3783 int l = (loc_regeol - locinput) > taill ? taill : (loc_regeol - locinput);
3784 /* The part of the string before starttry has one color
3785 (pref0_len chars), between starttry and current
3786 position another one (pref_len - pref0_len chars),
3787 after the current position the third one.
3788 We assume that pref0_len <= pref_len, otherwise we
3789 decrease pref0_len. */
3790 int pref_len = (locinput - loc_bostr) > (5 + taill) - l
3791 ? (5 + taill) - l : locinput - loc_bostr;
3794 PERL_ARGS_ASSERT_DUMP_EXEC_POS;
3796 while (utf8_target && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
3798 pref0_len = pref_len - (locinput - loc_reg_starttry);
3799 if (l + pref_len < (5 + taill) && l < loc_regeol - locinput)
3800 l = ( loc_regeol - locinput > (5 + taill) - pref_len
3801 ? (5 + taill) - pref_len : loc_regeol - locinput);
3802 while (utf8_target && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
3806 if (pref0_len > pref_len)
3807 pref0_len = pref_len;
3809 const int is_uni = utf8_target ? 1 : 0;
3811 RE_PV_COLOR_DECL(s0,len0,is_uni,PERL_DEBUG_PAD(0),
3812 (locinput - pref_len),pref0_len, 60, 4, 5);
3814 RE_PV_COLOR_DECL(s1,len1,is_uni,PERL_DEBUG_PAD(1),
3815 (locinput - pref_len + pref0_len),
3816 pref_len - pref0_len, 60, 2, 3);
3818 RE_PV_COLOR_DECL(s2,len2,is_uni,PERL_DEBUG_PAD(2),
3819 locinput, loc_regeol - locinput, 10, 0, 1);
3821 const STRLEN tlen=len0+len1+len2;
3822 PerlIO_printf(Perl_debug_log,
3823 "%4"IVdf" <%.*s%.*s%s%.*s>%*s|",
3824 (IV)(locinput - loc_bostr),
3827 (docolor ? "" : "> <"),
3829 (int)(tlen > 19 ? 0 : 19 - tlen),
3836 /* reg_check_named_buff_matched()
3837 * Checks to see if a named buffer has matched. The data array of
3838 * buffer numbers corresponding to the buffer is expected to reside
3839 * in the regexp->data->data array in the slot stored in the ARG() of
3840 * node involved. Note that this routine doesn't actually care about the
3841 * name, that information is not preserved from compilation to execution.
3842 * Returns the index of the leftmost defined buffer with the given name
3843 * or 0 if non of the buffers matched.
3846 S_reg_check_named_buff_matched(const regexp *rex, const regnode *scan)
3849 RXi_GET_DECL(rex,rexi);
3850 SV *sv_dat= MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
3851 I32 *nums=(I32*)SvPVX(sv_dat);
3853 PERL_ARGS_ASSERT_REG_CHECK_NAMED_BUFF_MATCHED;
3855 for ( n=0; n<SvIVX(sv_dat); n++ ) {
3856 if ((I32)rex->lastparen >= nums[n] &&
3857 rex->offs[nums[n]].end != -1)
3867 S_setup_EXACTISH_ST_c1_c2(pTHX_ const regnode * const text_node, int *c1p,
3868 U8* c1_utf8, int *c2p, U8* c2_utf8, regmatch_info *reginfo)
3870 /* This function determines if there are one or two characters that match
3871 * the first character of the passed-in EXACTish node <text_node>, and if
3872 * so, returns them in the passed-in pointers.
3874 * If it determines that no possible character in the target string can
3875 * match, it returns FALSE; otherwise TRUE. (The FALSE situation occurs if
3876 * the first character in <text_node> requires UTF-8 to represent, and the
3877 * target string isn't in UTF-8.)
3879 * If there are more than two characters that could match the beginning of
3880 * <text_node>, or if more context is required to determine a match or not,
3881 * it sets both *<c1p> and *<c2p> to CHRTEST_VOID.
3883 * The motiviation behind this function is to allow the caller to set up
3884 * tight loops for matching. If <text_node> is of type EXACT, there is
3885 * only one possible character that can match its first character, and so
3886 * the situation is quite simple. But things get much more complicated if
3887 * folding is involved. It may be that the first character of an EXACTFish
3888 * node doesn't participate in any possible fold, e.g., punctuation, so it
3889 * can be matched only by itself. The vast majority of characters that are
3890 * in folds match just two things, their lower and upper-case equivalents.
3891 * But not all are like that; some have multiple possible matches, or match
3892 * sequences of more than one character. This function sorts all that out.
3894 * Consider the patterns A*B or A*?B where A and B are arbitrary. In a
3895 * loop of trying to match A*, we know we can't exit where the thing
3896 * following it isn't a B. And something can't be a B unless it is the
3897 * beginning of B. By putting a quick test for that beginning in a tight
3898 * loop, we can rule out things that can't possibly be B without having to
3899 * break out of the loop, thus avoiding work. Similarly, if A is a single
3900 * character, we can make a tight loop matching A*, using the outputs of
3903 * If the target string to match isn't in UTF-8, and there aren't
3904 * complications which require CHRTEST_VOID, *<c1p> and *<c2p> are set to
3905 * the one or two possible octets (which are characters in this situation)
3906 * that can match. In all cases, if there is only one character that can
3907 * match, *<c1p> and *<c2p> will be identical.
3909 * If the target string is in UTF-8, the buffers pointed to by <c1_utf8>
3910 * and <c2_utf8> will contain the one or two UTF-8 sequences of bytes that
3911 * can match the beginning of <text_node>. They should be declared with at
3912 * least length UTF8_MAXBYTES+1. (If the target string isn't in UTF-8, it is
3913 * undefined what these contain.) If one or both of the buffers are
3914 * invariant under UTF-8, *<c1p>, and *<c2p> will also be set to the
3915 * corresponding invariant. If variant, the corresponding *<c1p> and/or
3916 * *<c2p> will be set to a negative number(s) that shouldn't match any code
3917 * point (unless inappropriately coerced to unsigned). *<c1p> will equal
3918 * *<c2p> if and only if <c1_utf8> and <c2_utf8> are the same. */
3920 const bool utf8_target = reginfo->is_utf8_target;
3922 UV c1 = (UV)CHRTEST_NOT_A_CP_1;
3923 UV c2 = (UV)CHRTEST_NOT_A_CP_2;
3924 bool use_chrtest_void = FALSE;
3925 const bool is_utf8_pat = reginfo->is_utf8_pat;
3927 /* Used when we have both utf8 input and utf8 output, to avoid converting
3928 * to/from code points */
3929 bool utf8_has_been_setup = FALSE;
3933 U8 *pat = (U8*)STRING(text_node);
3934 U8 folded[UTF8_MAX_FOLD_CHAR_EXPAND * UTF8_MAXBYTES_CASE + 1] = { '\0' };
3936 if (OP(text_node) == EXACT || OP(text_node) == EXACTL) {
3938 /* In an exact node, only one thing can be matched, that first
3939 * character. If both the pat and the target are UTF-8, we can just
3940 * copy the input to the output, avoiding finding the code point of
3945 else if (utf8_target) {
3946 Copy(pat, c1_utf8, UTF8SKIP(pat), U8);
3947 Copy(pat, c2_utf8, UTF8SKIP(pat), U8);
3948 utf8_has_been_setup = TRUE;
3951 c2 = c1 = valid_utf8_to_uvchr(pat, NULL);
3954 else { /* an EXACTFish node */
3955 U8 *pat_end = pat + STR_LEN(text_node);
3957 /* An EXACTFL node has at least some characters unfolded, because what
3958 * they match is not known until now. So, now is the time to fold
3959 * the first few of them, as many as are needed to determine 'c1' and
3960 * 'c2' later in the routine. If the pattern isn't UTF-8, we only need
3961 * to fold if in a UTF-8 locale, and then only the Sharp S; everything
3962 * else is 1-1 and isn't assumed to be folded. In a UTF-8 pattern, we
3963 * need to fold as many characters as a single character can fold to,
3964 * so that later we can check if the first ones are such a multi-char
3965 * fold. But, in such a pattern only locale-problematic characters
3966 * aren't folded, so we can skip this completely if the first character
3967 * in the node isn't one of the tricky ones */
3968 if (OP(text_node) == EXACTFL) {
3970 if (! is_utf8_pat) {
3971 if (IN_UTF8_CTYPE_LOCALE && *pat == LATIN_SMALL_LETTER_SHARP_S)
3973 folded[0] = folded[1] = 's';
3975 pat_end = folded + 2;
3978 else if (is_PROBLEMATIC_LOCALE_FOLDEDS_START_utf8(pat)) {
3983 for (i = 0; i < UTF8_MAX_FOLD_CHAR_EXPAND && s < pat_end; i++) {
3985 *(d++) = (U8) toFOLD_LC(*s);
3990 _to_utf8_fold_flags(s,
3993 FOLD_FLAGS_FULL | FOLD_FLAGS_LOCALE);
4004 if ((is_utf8_pat && is_MULTI_CHAR_FOLD_utf8_safe(pat, pat_end))
4005 || (!is_utf8_pat && is_MULTI_CHAR_FOLD_latin1_safe(pat, pat_end)))
4007 /* Multi-character folds require more context to sort out. Also
4008 * PL_utf8_foldclosures used below doesn't handle them, so have to
4009 * be handled outside this routine */
4010 use_chrtest_void = TRUE;
4012 else { /* an EXACTFish node which doesn't begin with a multi-char fold */
4013 c1 = is_utf8_pat ? valid_utf8_to_uvchr(pat, NULL) : *pat;
4015 /* Load the folds hash, if not already done */
4017 if (! PL_utf8_foldclosures) {
4018 _load_PL_utf8_foldclosures();
4021 /* The fold closures data structure is a hash with the keys
4022 * being the UTF-8 of every character that is folded to, like
4023 * 'k', and the values each an array of all code points that
4024 * fold to its key. e.g. [ 'k', 'K', KELVIN_SIGN ].
4025 * Multi-character folds are not included */
4026 if ((! (listp = hv_fetch(PL_utf8_foldclosures,
4031 /* Not found in the hash, therefore there are no folds
4032 * containing it, so there is only a single character that
4036 else { /* Does participate in folds */
4037 AV* list = (AV*) *listp;
4038 if (av_tindex(list) != 1) {
4040 /* If there aren't exactly two folds to this, it is
4041 * outside the scope of this function */
4042 use_chrtest_void = TRUE;
4044 else { /* There are two. Get them */
4045 SV** c_p = av_fetch(list, 0, FALSE);
4047 Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
4051 c_p = av_fetch(list, 1, FALSE);
4053 Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
4057 /* Folds that cross the 255/256 boundary are forbidden
4058 * if EXACTFL (and isnt a UTF8 locale), or EXACTFA and
4059 * one is ASCIII. Since the pattern character is above
4060 * 255, and its only other match is below 256, the only
4061 * legal match will be to itself. We have thrown away
4062 * the original, so have to compute which is the one
4064 if ((c1 < 256) != (c2 < 256)) {
4065 if ((OP(text_node) == EXACTFL
4066 && ! IN_UTF8_CTYPE_LOCALE)
4067 || ((OP(text_node) == EXACTFA
4068 || OP(text_node) == EXACTFA_NO_TRIE)
4069 && (isASCII(c1) || isASCII(c2))))
4082 else /* Here, c1 is <= 255 */
4084 && HAS_NONLATIN1_FOLD_CLOSURE(c1)
4085 && ( ! (OP(text_node) == EXACTFL && ! IN_UTF8_CTYPE_LOCALE))
4086 && ((OP(text_node) != EXACTFA
4087 && OP(text_node) != EXACTFA_NO_TRIE)
4090 /* Here, there could be something above Latin1 in the target
4091 * which folds to this character in the pattern. All such
4092 * cases except LATIN SMALL LETTER Y WITH DIAERESIS have more
4093 * than two characters involved in their folds, so are outside
4094 * the scope of this function */
4095 if (UNLIKELY(c1 == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
4096 c2 = LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS;
4099 use_chrtest_void = TRUE;
4102 else { /* Here nothing above Latin1 can fold to the pattern
4104 switch (OP(text_node)) {
4106 case EXACTFL: /* /l rules */
4107 c2 = PL_fold_locale[c1];
4110 case EXACTF: /* This node only generated for non-utf8
4112 assert(! is_utf8_pat);
4113 if (! utf8_target) { /* /d rules */
4118 /* /u rules for all these. This happens to work for
4119 * EXACTFA as nothing in Latin1 folds to ASCII */
4120 case EXACTFA_NO_TRIE: /* This node only generated for
4121 non-utf8 patterns */
4122 assert(! is_utf8_pat);
4127 c2 = PL_fold_latin1[c1];
4131 Perl_croak(aTHX_ "panic: Unexpected op %u", OP(text_node));
4132 NOT_REACHED; /* NOTREACHED */
4138 /* Here have figured things out. Set up the returns */
4139 if (use_chrtest_void) {
4140 *c2p = *c1p = CHRTEST_VOID;
4142 else if (utf8_target) {
4143 if (! utf8_has_been_setup) { /* Don't have the utf8; must get it */
4144 uvchr_to_utf8(c1_utf8, c1);
4145 uvchr_to_utf8(c2_utf8, c2);
4148 /* Invariants are stored in both the utf8 and byte outputs; Use
4149 * negative numbers otherwise for the byte ones. Make sure that the
4150 * byte ones are the same iff the utf8 ones are the same */
4151 *c1p = (UTF8_IS_INVARIANT(*c1_utf8)) ? *c1_utf8 : CHRTEST_NOT_A_CP_1;
4152 *c2p = (UTF8_IS_INVARIANT(*c2_utf8))
4155 ? CHRTEST_NOT_A_CP_1
4156 : CHRTEST_NOT_A_CP_2;
4158 else if (c1 > 255) {
4159 if (c2 > 255) { /* both possibilities are above what a non-utf8 string
4164 *c1p = *c2p = c2; /* c2 is the only representable value */
4166 else { /* c1 is representable; see about c2 */
4168 *c2p = (c2 < 256) ? c2 : c1;
4174 /* This creates a single number by combining two, with 'before' being like the
4175 * 10's digit, but this isn't necessarily base 10; it is base however many
4176 * elements of the enum there are */
4177 #define GCBcase(before, after) ((GCB_ENUM_COUNT * before) + after)
4180 S_isGCB(const GCB_enum before, const GCB_enum after)
4182 /* returns a boolean indicating if there is a Grapheme Cluster Boundary
4183 * between the inputs. See http://www.unicode.org/reports/tr29/ */
4185 switch (GCBcase(before, after)) {
4187 /* Break at the start and end of text.
4191 Break before and after controls except between CR and LF
4192 GB4. ( Control | CR | LF ) ÷
4193 GB5. ÷ ( Control | CR | LF )
4195 Otherwise, break everywhere.
4200 /* Do not break between a CR and LF.
4202 case GCBcase(GCB_CR, GCB_LF):
4205 /* Do not break Hangul syllable sequences.
4206 GB6. L × ( L | V | LV | LVT ) */
4207 case GCBcase(GCB_L, GCB_L):
4208 case GCBcase(GCB_L, GCB_V):
4209 case GCBcase(GCB_L, GCB_LV):
4210 case GCBcase(GCB_L, GCB_LVT):
4213 /* GB7. ( LV | V ) × ( V | T ) */
4214 case GCBcase(GCB_LV, GCB_V):
4215 case GCBcase(GCB_LV, GCB_T):
4216 case GCBcase(GCB_V, GCB_V):
4217 case GCBcase(GCB_V, GCB_T):
4220 /* GB8. ( LVT | T) × T */
4221 case GCBcase(GCB_LVT, GCB_T):
4222 case GCBcase(GCB_T, GCB_T):
4225 /* Do not break between regional indicator symbols.
4226 GB8a. Regional_Indicator × Regional_Indicator */
4227 case GCBcase(GCB_Regional_Indicator, GCB_Regional_Indicator):
4230 /* Do not break before extending characters.
4232 case GCBcase(GCB_Other, GCB_Extend):
4233 case GCBcase(GCB_Extend, GCB_Extend):
4234 case GCBcase(GCB_L, GCB_Extend):
4235 case GCBcase(GCB_LV, GCB_Extend):
4236 case GCBcase(GCB_LVT, GCB_Extend):
4237 case GCBcase(GCB_Prepend, GCB_Extend):
4238 case GCBcase(GCB_Regional_Indicator, GCB_Extend):
4239 case GCBcase(GCB_SpacingMark, GCB_Extend):
4240 case GCBcase(GCB_T, GCB_Extend):
4241 case GCBcase(GCB_V, GCB_Extend):
4244 /* Do not break before SpacingMarks, or after Prepend characters.
4245 GB9a. × SpacingMark */
4246 case GCBcase(GCB_Other, GCB_SpacingMark):
4247 case GCBcase(GCB_Extend, GCB_SpacingMark):
4248 case GCBcase(GCB_L, GCB_SpacingMark):
4249 case GCBcase(GCB_LV, GCB_SpacingMark):
4250 case GCBcase(GCB_LVT, GCB_SpacingMark):
4251 case GCBcase(GCB_Prepend, GCB_SpacingMark):
4252 case GCBcase(GCB_Regional_Indicator, GCB_SpacingMark):
4253 case GCBcase(GCB_SpacingMark, GCB_SpacingMark):
4254 case GCBcase(GCB_T, GCB_SpacingMark):
4255 case GCBcase(GCB_V, GCB_SpacingMark):
4258 /* GB9b. Prepend × */
4259 case GCBcase(GCB_Prepend, GCB_Other):
4260 case GCBcase(GCB_Prepend, GCB_L):
4261 case GCBcase(GCB_Prepend, GCB_LV):
4262 case GCBcase(GCB_Prepend, GCB_LVT):
4263 case GCBcase(GCB_Prepend, GCB_Prepend):
4264 case GCBcase(GCB_Prepend, GCB_Regional_Indicator):
4265 case GCBcase(GCB_Prepend, GCB_T):
4266 case GCBcase(GCB_Prepend, GCB_V):
4270 NOT_REACHED; /* NOTREACHED */
4273 #define SBcase(before, after) ((SB_ENUM_COUNT * before) + after)
4276 S_isSB(pTHX_ SB_enum before,
4278 const U8 * const strbeg,
4279 const U8 * const curpos,
4280 const U8 * const strend,
4281 const bool utf8_target)
4283 /* returns a boolean indicating if there is a Sentence Boundary Break
4284 * between the inputs. See http://www.unicode.org/reports/tr29/ */
4286 U8 * lpos = (U8 *) curpos;
4290 PERL_ARGS_ASSERT_ISSB;
4292 /* Break at the start and end of text.
4295 if (before == SB_EDGE || after == SB_EDGE) {
4299 /* SB 3: Do not break within CRLF. */
4300 if (before == SB_CR && after == SB_LF) {
4304 /* Break after paragraph separators. (though why CR and LF are considered
4305 * so is beyond me (khw)
4306 SB4. Sep | CR | LF ÷ */
4307 if (before == SB_Sep || before == SB_CR || before == SB_LF) {
4311 /* Ignore Format and Extend characters, except after sot, Sep, CR, or LF.
4312 * (See Section 6.2, Replacing Ignore Rules.)
4313 SB5. X (Extend | Format)* → X */
4314 if (after == SB_Extend || after == SB_Format) {
4318 if (before == SB_Extend || before == SB_Format) {
4319 before = backup_one_SB(strbeg, &lpos, utf8_target);
4322 /* Do not break after ambiguous terminators like period, if they are
4323 * immediately followed by a number or lowercase letter, if they are
4324 * between uppercase letters, if the first following letter (optionally
4325 * after certain punctuation) is lowercase, or if they are followed by
4326 * "continuation" punctuation such as comma, colon, or semicolon. For
4327 * example, a period may be an abbreviation or numeric period, and thus may
4328 * not mark the end of a sentence.
4330 * SB6. ATerm × Numeric */
4331 if (before == SB_ATerm && after == SB_Numeric) {
4335 /* SB7. (Upper | Lower) ATerm × Upper */
4336 if (before == SB_ATerm && after == SB_Upper) {
4338 backup = backup_one_SB(strbeg, &temp_pos, utf8_target);
4339 if (backup == SB_Upper || backup == SB_Lower) {
4344 /* SB8a. (STerm | ATerm) Close* Sp* × (SContinue | STerm | ATerm)
4345 * SB10. (STerm | ATerm) Close* Sp* × ( Sp | Sep | CR | LF ) */
4348 while (backup == SB_Sp) {
4349 backup = backup_one_SB(strbeg, &temp_pos, utf8_target);
4351 while (backup == SB_Close) {
4352 backup = backup_one_SB(strbeg, &temp_pos, utf8_target);
4354 if ((backup == SB_STerm || backup == SB_ATerm)
4355 && ( after == SB_SContinue
4356 || after == SB_STerm
4357 || after == SB_ATerm
4366 /* SB8. ATerm Close* Sp* × ( ¬(OLetter | Upper | Lower | Sep | CR | LF |
4367 * STerm | ATerm) )* Lower */
4368 if (backup == SB_ATerm) {
4369 U8 * rpos = (U8 *) curpos;
4370 SB_enum later = after;
4372 while ( later != SB_OLetter
4373 && later != SB_Upper
4374 && later != SB_Lower
4378 && later != SB_STerm
4379 && later != SB_ATerm
4380 && later != SB_EDGE)
4382 later = advance_one_SB(&rpos, strend, utf8_target);
4384 if (later == SB_Lower) {
4389 /* Break after sentence terminators, but include closing punctuation,
4390 * trailing spaces, and a paragraph separator (if present). [See note
4392 * SB9. ( STerm | ATerm ) Close* × ( Close | Sp | Sep | CR | LF ) */
4395 while (backup == SB_Close) {
4396 backup = backup_one_SB(strbeg, &temp_pos, utf8_target);
4398 if ((backup == SB_STerm || backup == SB_ATerm)
4399 && ( after == SB_Close
4409 /* SB11. ( STerm | ATerm ) Close* Sp* ( Sep | CR | LF )? ÷ */
4411 backup = backup_one_SB(strbeg, &temp_pos, utf8_target);
4412 if ( backup == SB_Sep
4421 while (backup == SB_Sp) {
4422 backup = backup_one_SB(strbeg, &lpos, utf8_target);
4424 while (backup == SB_Close) {
4425 backup = backup_one_SB(strbeg, &lpos, utf8_target);
4427 if (backup == SB_STerm || backup == SB_ATerm) {
4431 /* Otherwise, do not break.
4438 S_advance_one_SB(pTHX_ U8 ** curpos, const U8 * const strend, const bool utf8_target)
4442 PERL_ARGS_ASSERT_ADVANCE_ONE_SB;
4444 if (*curpos >= strend) {
4450 *curpos += UTF8SKIP(*curpos);
4451 if (*curpos >= strend) {
4454 sb = getSB_VAL_UTF8(*curpos, strend);
4455 } while (sb == SB_Extend || sb == SB_Format);
4460 if (*curpos >= strend) {
4463 sb = getSB_VAL_CP(**curpos);
4464 } while (sb == SB_Extend || sb == SB_Format);
4471 S_backup_one_SB(pTHX_ const U8 * const strbeg, U8 ** curpos, const bool utf8_target)
4475 PERL_ARGS_ASSERT_BACKUP_ONE_SB;
4477 if (*curpos < strbeg) {
4482 U8 * prev_char_pos = reghopmaybe3(*curpos, -1, strbeg);
4483 if (! prev_char_pos) {
4487 /* Back up over Extend and Format. curpos is always just to the right
4488 * of the characater whose value we are getting */
4490 U8 * prev_prev_char_pos;
4491 if ((prev_prev_char_pos = reghopmaybe3((U8 *) prev_char_pos, -1,
4494 sb = getSB_VAL_UTF8(prev_prev_char_pos, prev_char_pos);
4495 *curpos = prev_char_pos;
4496 prev_char_pos = prev_prev_char_pos;
4499 *curpos = (U8 *) strbeg;
4502 } while (sb == SB_Extend || sb == SB_Format);
4506 if (*curpos - 2 < strbeg) {
4507 *curpos = (U8 *) strbeg;
4511 sb = getSB_VAL_CP(*(*curpos - 1));
4512 } while (sb == SB_Extend || sb == SB_Format);
4518 #define WBcase(before, after) ((WB_ENUM_COUNT * before) + after)
4521 S_isWB(pTHX_ WB_enum previous,
4524 const U8 * const strbeg,
4525 const U8 * const curpos,
4526 const U8 * const strend,
4527 const bool utf8_target)
4529 /* Return a boolean as to if the boundary between 'before' and 'after' is
4530 * a Unicode word break, using their published algorithm. Context may be
4531 * needed to make this determination. If the value for the character
4532 * before 'before' is known, it is passed as 'previous'; otherwise that
4533 * should be set to WB_UNKNOWN. The other input parameters give the
4534 * boundaries and current position in the matching of the string. That
4535 * is, 'curpos' marks the position where the character whose wb value is
4536 * 'after' begins. See http://www.unicode.org/reports/tr29/ */
4538 U8 * before_pos = (U8 *) curpos;
4539 U8 * after_pos = (U8 *) curpos;
4541 PERL_ARGS_ASSERT_ISWB;
4543 /* WB1 and WB2: Break at the start and end of text. */
4544 if (before == WB_EDGE || after == WB_EDGE) {
4548 /* WB 3: Do not break within CRLF. */
4549 if (before == WB_CR && after == WB_LF) {
4553 /* WB 3a and WB 3b: Otherwise break before and after Newlines (including CR
4555 if ( before == WB_CR || before == WB_LF || before == WB_Newline
4556 || after == WB_CR || after == WB_LF || after == WB_Newline)
4561 /* Ignore Format and Extend characters, except when they appear at the
4562 * beginning of a region of text.
4563 * WB4. X (Extend | Format)* → X. */
4565 if (after == WB_Extend || after == WB_Format) {
4569 if (before == WB_Extend || before == WB_Format) {
4570 before = backup_one_WB(&previous, strbeg, &before_pos, utf8_target);
4573 switch (WBcase(before, after)) {
4574 /* Otherwise, break everywhere (including around ideographs).
4579 /* Do not break between most letters.
4580 WB5. (ALetter | Hebrew_Letter) × (ALetter | Hebrew_Letter) */
4581 case WBcase(WB_ALetter, WB_ALetter):
4582 case WBcase(WB_ALetter, WB_Hebrew_Letter):
4583 case WBcase(WB_Hebrew_Letter, WB_ALetter):
4584 case WBcase(WB_Hebrew_Letter, WB_Hebrew_Letter):
4587 /* Do not break letters across certain punctuation.
4588 WB6. (ALetter | Hebrew_Letter)
4589 × (MidLetter | MidNumLet | Single_Quote) (ALetter
4591 case WBcase(WB_ALetter, WB_MidLetter):
4592 case WBcase(WB_ALetter, WB_MidNumLet):
4593 case WBcase(WB_ALetter, WB_Single_Quote):
4594 case WBcase(WB_Hebrew_Letter, WB_MidLetter):
4595 case WBcase(WB_Hebrew_Letter, WB_MidNumLet):
4596 /*case WBcase(WB_Hebrew_Letter, WB_Single_Quote):*/
4597 after = advance_one_WB(&after_pos, strend, utf8_target);
4598 return after != WB_ALetter && after != WB_Hebrew_Letter;
4600 /* WB7. (ALetter | Hebrew_Letter) (MidLetter | MidNumLet |
4601 * Single_Quote) × (ALetter | Hebrew_Letter) */
4602 case WBcase(WB_MidLetter, WB_ALetter):
4603 case WBcase(WB_MidLetter, WB_Hebrew_Letter):
4604 case WBcase(WB_MidNumLet, WB_ALetter):
4605 case WBcase(WB_MidNumLet, WB_Hebrew_Letter):
4606 case WBcase(WB_Single_Quote, WB_ALetter):
4607 case WBcase(WB_Single_Quote, WB_Hebrew_Letter):
4609 = backup_one_WB(&previous, strbeg, &before_pos, utf8_target);
4610 return before != WB_ALetter && before != WB_Hebrew_Letter;
4612 /* WB7a. Hebrew_Letter × Single_Quote */
4613 case WBcase(WB_Hebrew_Letter, WB_Single_Quote):
4616 /* WB7b. Hebrew_Letter × Double_Quote Hebrew_Letter */
4617 case WBcase(WB_Hebrew_Letter, WB_Double_Quote):
4618 return advance_one_WB(&after_pos, strend, utf8_target)
4619 != WB_Hebrew_Letter;
4621 /* WB7c. Hebrew_Letter Double_Quote × Hebrew_Letter */
4622 case WBcase(WB_Double_Quote, WB_Hebrew_Letter):
4623 return backup_one_WB(&previous, strbeg, &before_pos, utf8_target)
4624 != WB_Hebrew_Letter;
4626 /* Do not break within sequences of digits, or digits adjacent to
4627 * letters (“3a”, or “A3”).
4628 WB8. Numeric × Numeric */
4629 case WBcase(WB_Numeric, WB_Numeric):
4632 /* WB9. (ALetter | Hebrew_Letter) × Numeric */
4633 case WBcase(WB_ALetter, WB_Numeric):
4634 case WBcase(WB_Hebrew_Letter, WB_Numeric):
4637 /* WB10. Numeric × (ALetter | Hebrew_Letter) */
4638 case WBcase(WB_Numeric, WB_ALetter):
4639 case WBcase(WB_Numeric, WB_Hebrew_Letter):
4642 /* Do not break within sequences, such as “3.2” or “3,456.789”.
4643 WB11. Numeric (MidNum | MidNumLet | Single_Quote) × Numeric
4645 case WBcase(WB_MidNum, WB_Numeric):
4646 case WBcase(WB_MidNumLet, WB_Numeric):
4647 case WBcase(WB_Single_Quote, WB_Numeric):
4648 return backup_one_WB(&previous, strbeg, &before_pos, utf8_target)
4651 /* WB12. Numeric × (MidNum | MidNumLet | Single_Quote) Numeric
4653 case WBcase(WB_Numeric, WB_MidNum):
4654 case WBcase(WB_Numeric, WB_MidNumLet):
4655 case WBcase(WB_Numeric, WB_Single_Quote):
4656 return advance_one_WB(&after_pos, strend, utf8_target)
4659 /* Do not break between Katakana.
4660 WB13. Katakana × Katakana */
4661 case WBcase(WB_Katakana, WB_Katakana):
4664 /* Do not break from extenders.
4665 WB13a. (ALetter | Hebrew_Letter | Numeric | Katakana |
4666 ExtendNumLet) × ExtendNumLet */
4667 case WBcase(WB_ALetter, WB_ExtendNumLet):
4668 case WBcase(WB_Hebrew_Letter, WB_ExtendNumLet):
4669 case WBcase(WB_Numeric, WB_ExtendNumLet):
4670 case WBcase(WB_Katakana, WB_ExtendNumLet):
4671 case WBcase(WB_ExtendNumLet, WB_ExtendNumLet):
4674 /* WB13b. ExtendNumLet × (ALetter | Hebrew_Letter | Numeric
4676 case WBcase(WB_ExtendNumLet, WB_ALetter):
4677 case WBcase(WB_ExtendNumLet, WB_Hebrew_Letter):
4678 case WBcase(WB_ExtendNumLet, WB_Numeric):
4679 case WBcase(WB_ExtendNumLet, WB_Katakana):
4682 /* Do not break between regional indicator symbols.
4683 WB13c. Regional_Indicator × Regional_Indicator */
4684 case WBcase(WB_Regional_Indicator, WB_Regional_Indicator):
4689 NOT_REACHED; /* NOTREACHED */
4693 S_advance_one_WB(pTHX_ U8 ** curpos, const U8 * const strend, const bool utf8_target)
4697 PERL_ARGS_ASSERT_ADVANCE_ONE_WB;
4699 if (*curpos >= strend) {
4705 /* Advance over Extend and Format */
4707 *curpos += UTF8SKIP(*curpos);
4708 if (*curpos >= strend) {
4711 wb = getWB_VAL_UTF8(*curpos, strend);
4712 } while (wb == WB_Extend || wb == WB_Format);
4717 if (*curpos >= strend) {
4720 wb = getWB_VAL_CP(**curpos);
4721 } while (wb == WB_Extend || wb == WB_Format);
4728 S_backup_one_WB(pTHX_ WB_enum * previous, const U8 * const strbeg, U8 ** curpos, const bool utf8_target)
4732 PERL_ARGS_ASSERT_BACKUP_ONE_WB;
4734 /* If we know what the previous character's break value is, don't have
4736 if (*previous != WB_UNKNOWN) {
4738 *previous = WB_UNKNOWN;
4739 /* XXX Note that doesn't change curpos, and maybe should */
4741 /* But we always back up over these two types */
4742 if (wb != WB_Extend && wb != WB_Format) {
4747 if (*curpos < strbeg) {
4752 U8 * prev_char_pos = reghopmaybe3(*curpos, -1, strbeg);
4753 if (! prev_char_pos) {
4757 /* Back up over Extend and Format. curpos is always just to the right
4758 * of the characater whose value we are getting */
4760 U8 * prev_prev_char_pos;
4761 if ((prev_prev_char_pos = reghopmaybe3((U8 *) prev_char_pos,
4765 wb = getWB_VAL_UTF8(prev_prev_char_pos, prev_char_pos);
4766 *curpos = prev_char_pos;
4767 prev_char_pos = prev_prev_char_pos;
4770 *curpos = (U8 *) strbeg;
4773 } while (wb == WB_Extend || wb == WB_Format);
4777 if (*curpos - 2 < strbeg) {
4778 *curpos = (U8 *) strbeg;
4782 wb = getWB_VAL_CP(*(*curpos - 1));
4783 } while (wb == WB_Extend || wb == WB_Format);
4789 /* returns -1 on failure, $+[0] on success */
4791 S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
4793 #if PERL_VERSION < 9 && !defined(PERL_CORE)
4797 const bool utf8_target = reginfo->is_utf8_target;
4798 const U32 uniflags = UTF8_ALLOW_DEFAULT;
4799 REGEXP *rex_sv = reginfo->prog;
4800 regexp *rex = ReANY(rex_sv);
4801 RXi_GET_DECL(rex,rexi);
4802 /* the current state. This is a cached copy of PL_regmatch_state */
4804 /* cache heavy used fields of st in registers */
4807 U32 n = 0; /* general value; init to avoid compiler warning */
4808 SSize_t ln = 0; /* len or last; init to avoid compiler warning */
4809 char *locinput = startpos;
4810 char *pushinput; /* where to continue after a PUSH */
4811 I32 nextchr; /* is always set to UCHARAT(locinput) */
4813 bool result = 0; /* return value of S_regmatch */
4814 int depth = 0; /* depth of backtrack stack */
4815 U32 nochange_depth = 0; /* depth of GOSUB recursion with nochange */
4816 const U32 max_nochange_depth =
4817 (3 * rex->nparens > MAX_RECURSE_EVAL_NOCHANGE_DEPTH) ?
4818 3 * rex->nparens : MAX_RECURSE_EVAL_NOCHANGE_DEPTH;
4819 regmatch_state *yes_state = NULL; /* state to pop to on success of
4821 /* mark_state piggy backs on the yes_state logic so that when we unwind
4822 the stack on success we can update the mark_state as we go */
4823 regmatch_state *mark_state = NULL; /* last mark state we have seen */
4824 regmatch_state *cur_eval = NULL; /* most recent EVAL_AB state */
4825 struct regmatch_state *cur_curlyx = NULL; /* most recent curlyx */
4827 bool no_final = 0; /* prevent failure from backtracking? */
4828 bool do_cutgroup = 0; /* no_final only until next branch/trie entry */
4829 char *startpoint = locinput;
4830 SV *popmark = NULL; /* are we looking for a mark? */
4831 SV *sv_commit = NULL; /* last mark name seen in failure */
4832 SV *sv_yes_mark = NULL; /* last mark name we have seen
4833 during a successful match */
4834 U32 lastopen = 0; /* last open we saw */
4835 bool has_cutgroup = RX_HAS_CUTGROUP(rex) ? 1 : 0;
4836 SV* const oreplsv = GvSVn(PL_replgv);
4837 /* these three flags are set by various ops to signal information to
4838 * the very next op. They have a useful lifetime of exactly one loop
4839 * iteration, and are not preserved or restored by state pushes/pops
4841 bool sw = 0; /* the condition value in (?(cond)a|b) */
4842 bool minmod = 0; /* the next "{n,m}" is a "{n,m}?" */
4843 int logical = 0; /* the following EVAL is:
4847 or the following IFMATCH/UNLESSM is:
4848 false: plain (?=foo)
4849 true: used as a condition: (?(?=foo))
4851 PAD* last_pad = NULL;
4853 I32 gimme = G_SCALAR;
4854 CV *caller_cv = NULL; /* who called us */
4855 CV *last_pushed_cv = NULL; /* most recently called (?{}) CV */
4856 CHECKPOINT runops_cp; /* savestack position before executing EVAL */
4857 U32 maxopenparen = 0; /* max '(' index seen so far */
4858 int to_complement; /* Invert the result? */
4859 _char_class_number classnum;
4860 bool is_utf8_pat = reginfo->is_utf8_pat;
4865 GET_RE_DEBUG_FLAGS_DECL;
4868 /* protect against undef(*^R) */
4869 SAVEFREESV(SvREFCNT_inc_simple_NN(oreplsv));
4871 /* shut up 'may be used uninitialized' compiler warnings for dMULTICALL */
4872 multicall_oldcatch = 0;
4873 multicall_cv = NULL;
4875 PERL_UNUSED_VAR(multicall_cop);
4876 PERL_UNUSED_VAR(newsp);
4879 PERL_ARGS_ASSERT_REGMATCH;
4881 DEBUG_OPTIMISE_r( DEBUG_EXECUTE_r({
4882 PerlIO_printf(Perl_debug_log,"regmatch start\n");
4885 st = PL_regmatch_state;
4887 /* Note that nextchr is a byte even in UTF */
4890 while (scan != NULL) {
4893 SV * const prop = sv_newmortal();
4894 regnode *rnext=regnext(scan);
4895 DUMP_EXEC_POS( locinput, scan, utf8_target );
4896 regprop(rex, prop, scan, reginfo, NULL);
4898 PerlIO_printf(Perl_debug_log,
4899 "%3"IVdf":%*s%s(%"IVdf")\n",
4900 (IV)(scan - rexi->program), depth*2, "",
4902 (PL_regkind[OP(scan)] == END || !rnext) ?
4903 0 : (IV)(rnext - rexi->program));
4906 next = scan + NEXT_OFF(scan);
4909 state_num = OP(scan);
4915 assert(nextchr < 256 && (nextchr >= 0 || nextchr == NEXTCHR_EOS));
4917 switch (state_num) {
4918 case SBOL: /* /^../ and /\A../ */
4919 if (locinput == reginfo->strbeg)
4923 case MBOL: /* /^../m */
4924 if (locinput == reginfo->strbeg ||
4925 (!NEXTCHR_IS_EOS && locinput[-1] == '\n'))
4932 if (locinput == reginfo->ganch)
4936 case KEEPS: /* \K */
4937 /* update the startpoint */
4938 st->u.keeper.val = rex->offs[0].start;
4939 rex->offs[0].start = locinput - reginfo->strbeg;
4940 PUSH_STATE_GOTO(KEEPS_next, next, locinput);
4942 NOT_REACHED; /* NOTREACHED */
4944 case KEEPS_next_fail:
4945 /* rollback the start point change */
4946 rex->offs[0].start = st->u.keeper.val;
4949 NOT_REACHED; /* NOTREACHED */
4951 case MEOL: /* /..$/m */
4952 if (!NEXTCHR_IS_EOS && nextchr != '\n')
4956 case SEOL: /* /..$/ */
4957 if (!NEXTCHR_IS_EOS && nextchr != '\n')
4959 if (reginfo->strend - locinput > 1)
4964 if (!NEXTCHR_IS_EOS)
4968 case SANY: /* /./s */
4971 goto increment_locinput;
4973 case REG_ANY: /* /./ */
4974 if ((NEXTCHR_IS_EOS) || nextchr == '\n')
4976 goto increment_locinput;
4980 #define ST st->u.trie
4981 case TRIEC: /* (ab|cd) with known charclass */
4982 /* In this case the charclass data is available inline so
4983 we can fail fast without a lot of extra overhead.
4985 if(!NEXTCHR_IS_EOS && !ANYOF_BITMAP_TEST(scan, nextchr)) {
4987 PerlIO_printf(Perl_debug_log,
4988 "%*s %sfailed to match trie start class...%s\n",
4989 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
4993 NOT_REACHED; /* NOTREACHED */
4996 case TRIE: /* (ab|cd) */
4997 /* the basic plan of execution of the trie is:
4998 * At the beginning, run though all the states, and
4999 * find the longest-matching word. Also remember the position
5000 * of the shortest matching word. For example, this pattern:
5003 * when matched against the string "abcde", will generate
5004 * accept states for all words except 3, with the longest
5005 * matching word being 4, and the shortest being 2 (with
5006 * the position being after char 1 of the string).
5008 * Then for each matching word, in word order (i.e. 1,2,4,5),
5009 * we run the remainder of the pattern; on each try setting
5010 * the current position to the character following the word,
5011 * returning to try the next word on failure.
5013 * We avoid having to build a list of words at runtime by
5014 * using a compile-time structure, wordinfo[].prev, which
5015 * gives, for each word, the previous accepting word (if any).
5016 * In the case above it would contain the mappings 1->2, 2->0,
5017 * 3->0, 4->5, 5->1. We can use this table to generate, from
5018 * the longest word (4 above), a list of all words, by
5019 * following the list of prev pointers; this gives us the
5020 * unordered list 4,5,1,2. Then given the current word we have
5021 * just tried, we can go through the list and find the
5022 * next-biggest word to try (so if we just failed on word 2,
5023 * the next in the list is 4).
5025 * Since at runtime we don't record the matching position in
5026 * the string for each word, we have to work that out for
5027 * each word we're about to process. The wordinfo table holds
5028 * the character length of each word; given that we recorded
5029 * at the start: the position of the shortest word and its
5030 * length in chars, we just need to move the pointer the
5031 * difference between the two char lengths. Depending on
5032 * Unicode status and folding, that's cheap or expensive.
5034 * This algorithm is optimised for the case where are only a
5035 * small number of accept states, i.e. 0,1, or maybe 2.
5036 * With lots of accepts states, and having to try all of them,
5037 * it becomes quadratic on number of accept states to find all
5042 /* what type of TRIE am I? (utf8 makes this contextual) */
5043 DECL_TRIE_TYPE(scan);
5045 /* what trie are we using right now */
5046 reg_trie_data * const trie
5047 = (reg_trie_data*)rexi->data->data[ ARG( scan ) ];
5048 HV * widecharmap = MUTABLE_HV(rexi->data->data[ ARG( scan ) + 1 ]);
5049 U32 state = trie->startstate;
5051 if (scan->flags == EXACTL || scan->flags == EXACTFLU8) {
5052 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
5054 && UTF8_IS_ABOVE_LATIN1(nextchr)
5055 && scan->flags == EXACTL)
5057 /* We only output for EXACTL, as we let the folder
5058 * output this message for EXACTFLU8 to avoid
5060 _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(locinput,
5065 && (NEXTCHR_IS_EOS || !TRIE_BITMAP_TEST(trie, nextchr)))
5067 if (trie->states[ state ].wordnum) {
5069 PerlIO_printf(Perl_debug_log,
5070 "%*s %smatched empty string...%s\n",
5071 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
5077 PerlIO_printf(Perl_debug_log,
5078 "%*s %sfailed to match trie start class...%s\n",
5079 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
5086 U8 *uc = ( U8* )locinput;
5090 U8 *uscan = (U8*)NULL;
5091 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
5092 U32 charcount = 0; /* how many input chars we have matched */
5093 U32 accepted = 0; /* have we seen any accepting states? */
5095 ST.jump = trie->jump;
5098 ST.longfold = FALSE; /* char longer if folded => it's harder */
5101 /* fully traverse the TRIE; note the position of the
5102 shortest accept state and the wordnum of the longest
5105 while ( state && uc <= (U8*)(reginfo->strend) ) {
5106 U32 base = trie->states[ state ].trans.base;
5110 wordnum = trie->states[ state ].wordnum;
5112 if (wordnum) { /* it's an accept state */
5115 /* record first match position */
5117 ST.firstpos = (U8*)locinput;
5122 ST.firstchars = charcount;
5125 if (!ST.nextword || wordnum < ST.nextword)
5126 ST.nextword = wordnum;
5127 ST.topword = wordnum;
5130 DEBUG_TRIE_EXECUTE_r({
5131 DUMP_EXEC_POS( (char *)uc, scan, utf8_target );
5132 PerlIO_printf( Perl_debug_log,
5133 "%*s %sState: %4"UVxf" Accepted: %c ",
5134 2+depth * 2, "", PL_colors[4],
5135 (UV)state, (accepted ? 'Y' : 'N'));
5138 /* read a char and goto next state */
5139 if ( base && (foldlen || uc < (U8*)(reginfo->strend))) {
5141 REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
5142 uscan, len, uvc, charid, foldlen,
5149 base + charid - 1 - trie->uniquecharcount)) >= 0)
5151 && ((U32)offset < trie->lasttrans)
5152 && trie->trans[offset].check == state)
5154 state = trie->trans[offset].next;
5165 DEBUG_TRIE_EXECUTE_r(
5166 PerlIO_printf( Perl_debug_log,
5167 "Charid:%3x CP:%4"UVxf" After State: %4"UVxf"%s\n",
5168 charid, uvc, (UV)state, PL_colors[5] );
5174 /* calculate total number of accept states */
5179 w = trie->wordinfo[w].prev;
5182 ST.accepted = accepted;
5186 PerlIO_printf( Perl_debug_log,
5187 "%*s %sgot %"IVdf" possible matches%s\n",
5188 REPORT_CODE_OFF + depth * 2, "",
5189 PL_colors[4], (IV)ST.accepted, PL_colors[5] );
5191 goto trie_first_try; /* jump into the fail handler */
5194 NOT_REACHED; /* NOTREACHED */
5196 case TRIE_next_fail: /* we failed - try next alternative */
5200 REGCP_UNWIND(ST.cp);
5201 UNWIND_PAREN(ST.lastparen, ST.lastcloseparen);
5203 if (!--ST.accepted) {
5205 PerlIO_printf( Perl_debug_log,
5206 "%*s %sTRIE failed...%s\n",
5207 REPORT_CODE_OFF+depth*2, "",
5214 /* Find next-highest word to process. Note that this code
5215 * is O(N^2) per trie run (O(N) per branch), so keep tight */
5218 U16 const nextword = ST.nextword;
5219 reg_trie_wordinfo * const wordinfo
5220 = ((reg_trie_data*)rexi->data->data[ARG(ST.me)])->wordinfo;
5221 for (word=ST.topword; word; word=wordinfo[word].prev) {
5222 if (word > nextword && (!min || word < min))
5235 ST.lastparen = rex->lastparen;
5236 ST.lastcloseparen = rex->lastcloseparen;
5240 /* find start char of end of current word */
5242 U32 chars; /* how many chars to skip */
5243 reg_trie_data * const trie
5244 = (reg_trie_data*)rexi->data->data[ARG(ST.me)];
5246 assert((trie->wordinfo[ST.nextword].len - trie->prefixlen)
5248 chars = (trie->wordinfo[ST.nextword].len - trie->prefixlen)
5253 /* the hard option - fold each char in turn and find
5254 * its folded length (which may be different */
5255 U8 foldbuf[UTF8_MAXBYTES_CASE + 1];
5263 uvc = utf8n_to_uvchr((U8*)uc, UTF8_MAXLEN, &len,
5271 uvc = to_uni_fold(uvc, foldbuf, &foldlen);
5276 uvc = utf8n_to_uvchr(uscan, UTF8_MAXLEN, &len,
5292 scan = ST.me + ((ST.jump && ST.jump[ST.nextword])
5293 ? ST.jump[ST.nextword]
5297 PerlIO_printf( Perl_debug_log,
5298 "%*s %sTRIE matched word #%d, continuing%s\n",
5299 REPORT_CODE_OFF+depth*2, "",
5306 if (ST.accepted > 1 || has_cutgroup) {
5307 PUSH_STATE_GOTO(TRIE_next, scan, (char*)uc);
5309 NOT_REACHED; /* NOTREACHED */
5311 /* only one choice left - just continue */
5313 AV *const trie_words
5314 = MUTABLE_AV(rexi->data->data[ARG(ST.me)+TRIE_WORDS_OFFSET]);
5315 SV ** const tmp = trie_words
5316 ? av_fetch(trie_words, ST.nextword - 1, 0) : NULL;
5317 SV *sv= tmp ? sv_newmortal() : NULL;
5319 PerlIO_printf( Perl_debug_log,
5320 "%*s %sonly one match left, short-circuiting: #%d <%s>%s\n",
5321 REPORT_CODE_OFF+depth*2, "", PL_colors[4],
5323 tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0,
5324 PL_colors[0], PL_colors[1],
5325 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)|PERL_PV_ESCAPE_NONASCII
5327 : "not compiled under -Dr",
5331 locinput = (char*)uc;
5332 continue; /* execute rest of RE */
5337 case EXACTL: /* /abc/l */
5338 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
5340 /* Complete checking would involve going through every character
5341 * matched by the string to see if any is above latin1. But the
5342 * comparision otherwise might very well be a fast assembly
5343 * language routine, and I (khw) don't think slowing things down
5344 * just to check for this warning is worth it. So this just checks
5345 * the first character */
5346 if (utf8_target && UTF8_IS_ABOVE_LATIN1(*locinput)) {
5347 _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(locinput, reginfo->strend);
5350 case EXACT: { /* /abc/ */
5351 char *s = STRING(scan);
5353 if (utf8_target != is_utf8_pat) {
5354 /* The target and the pattern have differing utf8ness. */
5356 const char * const e = s + ln;
5359 /* The target is utf8, the pattern is not utf8.
5360 * Above-Latin1 code points can't match the pattern;
5361 * invariants match exactly, and the other Latin1 ones need
5362 * to be downgraded to a single byte in order to do the
5363 * comparison. (If we could be confident that the target
5364 * is not malformed, this could be refactored to have fewer
5365 * tests by just assuming that if the first bytes match, it
5366 * is an invariant, but there are tests in the test suite
5367 * dealing with (??{...}) which violate this) */
5369 if (l >= reginfo->strend
5370 || UTF8_IS_ABOVE_LATIN1(* (U8*) l))
5374 if (UTF8_IS_INVARIANT(*(U8*)l)) {
5381 if (TWO_BYTE_UTF8_TO_NATIVE(*l, *(l+1)) != * (U8*) s)
5391 /* The target is not utf8, the pattern is utf8. */
5393 if (l >= reginfo->strend
5394 || UTF8_IS_ABOVE_LATIN1(* (U8*) s))
5398 if (UTF8_IS_INVARIANT(*(U8*)s)) {
5405 if (TWO_BYTE_UTF8_TO_NATIVE(*s, *(s+1)) != * (U8*) l)
5417 /* The target and the pattern have the same utf8ness. */
5418 /* Inline the first character, for speed. */
5419 if (reginfo->strend - locinput < ln
5420 || UCHARAT(s) != nextchr
5421 || (ln > 1 && memNE(s, locinput, ln)))
5430 case EXACTFL: { /* /abc/il */
5432 const U8 * fold_array;
5434 U32 fold_utf8_flags;
5436 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
5437 folder = foldEQ_locale;
5438 fold_array = PL_fold_locale;
5439 fold_utf8_flags = FOLDEQ_LOCALE;
5442 case EXACTFLU8: /* /abc/il; but all 'abc' are above 255, so
5443 is effectively /u; hence to match, target
5445 if (! utf8_target) {
5448 fold_utf8_flags = FOLDEQ_LOCALE | FOLDEQ_S1_ALREADY_FOLDED
5449 | FOLDEQ_S1_FOLDS_SANE;
5450 folder = foldEQ_latin1;
5451 fold_array = PL_fold_latin1;
5454 case EXACTFU_SS: /* /\x{df}/iu */
5455 case EXACTFU: /* /abc/iu */
5456 folder = foldEQ_latin1;
5457 fold_array = PL_fold_latin1;
5458 fold_utf8_flags = is_utf8_pat ? FOLDEQ_S1_ALREADY_FOLDED : 0;
5461 case EXACTFA_NO_TRIE: /* This node only generated for non-utf8
5463 assert(! is_utf8_pat);
5465 case EXACTFA: /* /abc/iaa */
5466 folder = foldEQ_latin1;
5467 fold_array = PL_fold_latin1;
5468 fold_utf8_flags = FOLDEQ_UTF8_NOMIX_ASCII;
5471 case EXACTF: /* /abc/i This node only generated for
5472 non-utf8 patterns */
5473 assert(! is_utf8_pat);
5475 fold_array = PL_fold;
5476 fold_utf8_flags = 0;
5484 || state_num == EXACTFU_SS
5485 || (state_num == EXACTFL && IN_UTF8_CTYPE_LOCALE))
5487 /* Either target or the pattern are utf8, or has the issue where
5488 * the fold lengths may differ. */
5489 const char * const l = locinput;
5490 char *e = reginfo->strend;
5492 if (! foldEQ_utf8_flags(s, 0, ln, is_utf8_pat,
5493 l, &e, 0, utf8_target, fold_utf8_flags))
5501 /* Neither the target nor the pattern are utf8 */
5502 if (UCHARAT(s) != nextchr
5504 && UCHARAT(s) != fold_array[nextchr])
5508 if (reginfo->strend - locinput < ln)
5510 if (ln > 1 && ! folder(s, locinput, ln))
5516 case NBOUNDL: /* /\B/l */
5520 case BOUNDL: /* /\b/l */
5521 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
5523 if (FLAGS(scan) != TRADITIONAL_BOUND) {
5524 if (! IN_UTF8_CTYPE_LOCALE) {
5525 Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
5526 B_ON_NON_UTF8_LOCALE_IS_WRONG);
5532 if (locinput == reginfo->strbeg)
5533 ln = isWORDCHAR_LC('\n');
5535 ln = isWORDCHAR_LC_utf8(reghop3((U8*)locinput, -1,
5536 (U8*)(reginfo->strbeg)));
5538 n = (NEXTCHR_IS_EOS)
5539 ? isWORDCHAR_LC('\n')
5540 : isWORDCHAR_LC_utf8((U8*)locinput);
5542 else { /* Here the string isn't utf8 */
5543 ln = (locinput == reginfo->strbeg)
5544 ? isWORDCHAR_LC('\n')
5545 : isWORDCHAR_LC(UCHARAT(locinput - 1));
5546 n = (NEXTCHR_IS_EOS)
5547 ? isWORDCHAR_LC('\n')
5548 : isWORDCHAR_LC(nextchr);
5550 if (to_complement ^ (ln == n)) {
5555 case NBOUND: /* /\B/ */
5559 case BOUND: /* /\b/ */
5563 goto bound_ascii_match_only;
5565 case NBOUNDA: /* /\B/a */
5569 case BOUNDA: /* /\b/a */
5571 bound_ascii_match_only:
5572 /* Here the string isn't utf8, or is utf8 and only ascii characters
5573 * are to match \w. In the latter case looking at the byte just
5574 * prior to the current one may be just the final byte of a
5575 * multi-byte character. This is ok. There are two cases:
5576 * 1) it is a single byte character, and then the test is doing
5577 * just what it's supposed to.
5578 * 2) it is a multi-byte character, in which case the final byte is
5579 * never mistakable for ASCII, and so the test will say it is
5580 * not a word character, which is the correct answer. */
5581 ln = (locinput == reginfo->strbeg)
5582 ? isWORDCHAR_A('\n')
5583 : isWORDCHAR_A(UCHARAT(locinput - 1));
5584 n = (NEXTCHR_IS_EOS)
5585 ? isWORDCHAR_A('\n')
5586 : isWORDCHAR_A(nextchr);
5587 if (to_complement ^ (ln == n)) {
5592 case NBOUNDU: /* /\B/u */
5596 case BOUNDU: /* /\b/u */
5602 switch((bound_type) FLAGS(scan)) {
5603 case TRADITIONAL_BOUND:
5604 ln = (locinput == reginfo->strbeg)
5605 ? 0 /* isWORDCHAR_L1('\n') */
5606 : isWORDCHAR_utf8(reghop3((U8*)locinput, -1,
5607 (U8*)(reginfo->strbeg)));
5608 n = (NEXTCHR_IS_EOS)
5609 ? 0 /* isWORDCHAR_L1('\n') */
5610 : isWORDCHAR_utf8((U8*)locinput);
5611 match = cBOOL(ln != n);
5614 if (locinput == reginfo->strbeg || NEXTCHR_IS_EOS) {
5615 match = TRUE; /* GCB always matches at begin and
5619 /* Find the gcb values of previous and current
5620 * chars, then see if is a break point */
5621 match = isGCB(getGCB_VAL_UTF8(
5622 reghop3((U8*)locinput,
5624 (U8*)(reginfo->strbeg)),
5625 (U8*) reginfo->strend),
5626 getGCB_VAL_UTF8((U8*) locinput,
5627 (U8*) reginfo->strend));
5631 case SB_BOUND: /* Always matches at begin and end */
5632 if (locinput == reginfo->strbeg || NEXTCHR_IS_EOS) {
5636 match = isSB(getSB_VAL_UTF8(
5637 reghop3((U8*)locinput,
5639 (U8*)(reginfo->strbeg)),
5640 (U8*) reginfo->strend),
5641 getSB_VAL_UTF8((U8*) locinput,
5642 (U8*) reginfo->strend),
5643 (U8*) reginfo->strbeg,
5645 (U8*) reginfo->strend,
5651 if (locinput == reginfo->strbeg || NEXTCHR_IS_EOS) {
5655 match = isWB(WB_UNKNOWN,
5657 reghop3((U8*)locinput,
5659 (U8*)(reginfo->strbeg)),
5660 (U8*) reginfo->strend),
5661 getWB_VAL_UTF8((U8*) locinput,
5662 (U8*) reginfo->strend),
5663 (U8*) reginfo->strbeg,
5665 (U8*) reginfo->strend,
5671 else { /* Not utf8 target */
5672 switch((bound_type) FLAGS(scan)) {
5673 case TRADITIONAL_BOUND:
5674 ln = (locinput == reginfo->strbeg)
5675 ? 0 /* isWORDCHAR_L1('\n') */
5676 : isWORDCHAR_L1(UCHARAT(locinput - 1));
5677 n = (NEXTCHR_IS_EOS)
5678 ? 0 /* isWORDCHAR_L1('\n') */
5679 : isWORDCHAR_L1(nextchr);
5680 match = cBOOL(ln != n);
5684 if (locinput == reginfo->strbeg || NEXTCHR_IS_EOS) {
5685 match = TRUE; /* GCB always matches at begin and
5688 else { /* Only CR-LF combo isn't a GCB in 0-255
5690 match = UCHARAT(locinput - 1) != '\r'
5691 || UCHARAT(locinput) != '\n';
5695 case SB_BOUND: /* Always matches at begin and end */
5696 if (locinput == reginfo->strbeg || NEXTCHR_IS_EOS) {
5700 match = isSB(getSB_VAL_CP(UCHARAT(locinput -1)),
5701 getSB_VAL_CP(UCHARAT(locinput)),
5702 (U8*) reginfo->strbeg,
5704 (U8*) reginfo->strend,
5710 if (locinput == reginfo->strbeg || NEXTCHR_IS_EOS) {
5714 match = isWB(WB_UNKNOWN,
5715 getWB_VAL_CP(UCHARAT(locinput -1)),
5716 getWB_VAL_CP(UCHARAT(locinput)),
5717 (U8*) reginfo->strbeg,
5719 (U8*) reginfo->strend,
5726 if (to_complement ^ ! match) {
5731 case ANYOFL: /* /[abc]/l */
5732 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
5734 case ANYOFD: /* /[abc]/d */
5735 case ANYOF: /* /[abc]/ */
5739 if (!reginclass(rex, scan, (U8*)locinput, (U8*)reginfo->strend,
5742 locinput += UTF8SKIP(locinput);
5745 if (!REGINCLASS(rex, scan, (U8*)locinput))
5751 /* The argument (FLAGS) to all the POSIX node types is the class number
5754 case NPOSIXL: /* \W or [:^punct:] etc. under /l */
5758 case POSIXL: /* \w or [:punct:] etc. under /l */
5759 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
5763 /* Use isFOO_lc() for characters within Latin1. (Note that
5764 * UTF8_IS_INVARIANT works even on non-UTF-8 strings, or else
5765 * wouldn't be invariant) */
5766 if (UTF8_IS_INVARIANT(nextchr) || ! utf8_target) {
5767 if (! (to_complement ^ cBOOL(isFOO_lc(FLAGS(scan), (U8) nextchr)))) {
5771 else if (UTF8_IS_DOWNGRADEABLE_START(nextchr)) {
5772 if (! (to_complement ^ cBOOL(isFOO_lc(FLAGS(scan),
5773 (U8) TWO_BYTE_UTF8_TO_NATIVE(nextchr,
5774 *(locinput + 1))))))
5779 else { /* Here, must be an above Latin-1 code point */
5780 _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(locinput, reginfo->strend);
5781 goto utf8_posix_above_latin1;
5784 /* Here, must be utf8 */
5785 locinput += UTF8SKIP(locinput);
5788 case NPOSIXD: /* \W or [:^punct:] etc. under /d */
5792 case POSIXD: /* \w or [:punct:] etc. under /d */
5798 case NPOSIXA: /* \W or [:^punct:] etc. under /a */
5800 if (NEXTCHR_IS_EOS) {
5804 /* All UTF-8 variants match */
5805 if (! UTF8_IS_INVARIANT(nextchr)) {
5806 goto increment_locinput;
5812 case POSIXA: /* \w or [:punct:] etc. under /a */
5815 /* We get here through POSIXD, NPOSIXD, and NPOSIXA when not in
5816 * UTF-8, and also from NPOSIXA even in UTF-8 when the current
5817 * character is a single byte */
5820 || ! (to_complement ^ cBOOL(_generic_isCC_A(nextchr,
5826 /* Here we are either not in utf8, or we matched a utf8-invariant,
5827 * so the next char is the next byte */
5831 case NPOSIXU: /* \W or [:^punct:] etc. under /u */
5835 case POSIXU: /* \w or [:punct:] etc. under /u */
5837 if (NEXTCHR_IS_EOS) {
5841 /* Use _generic_isCC() for characters within Latin1. (Note that
5842 * UTF8_IS_INVARIANT works even on non-UTF-8 strings, or else
5843 * wouldn't be invariant) */
5844 if (UTF8_IS_INVARIANT(nextchr) || ! utf8_target) {
5845 if (! (to_complement ^ cBOOL(_generic_isCC(nextchr,
5852 else if (UTF8_IS_DOWNGRADEABLE_START(nextchr)) {
5853 if (! (to_complement
5854 ^ cBOOL(_generic_isCC(TWO_BYTE_UTF8_TO_NATIVE(nextchr,
5862 else { /* Handle above Latin-1 code points */
5863 utf8_posix_above_latin1:
5864 classnum = (_char_class_number) FLAGS(scan);
5865 if (classnum < _FIRST_NON_SWASH_CC) {
5867 /* Here, uses a swash to find such code points. Load if if
5868 * not done already */
5869 if (! PL_utf8_swash_ptrs[classnum]) {
5870 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
5871 PL_utf8_swash_ptrs[classnum]
5872 = _core_swash_init("utf8",
5875 PL_XPosix_ptrs[classnum], &flags);
5877 if (! (to_complement
5878 ^ cBOOL(swash_fetch(PL_utf8_swash_ptrs[classnum],
5879 (U8 *) locinput, TRUE))))
5884 else { /* Here, uses macros to find above Latin-1 code points */
5886 case _CC_ENUM_SPACE:
5887 if (! (to_complement
5888 ^ cBOOL(is_XPERLSPACE_high(locinput))))
5893 case _CC_ENUM_BLANK:
5894 if (! (to_complement
5895 ^ cBOOL(is_HORIZWS_high(locinput))))
5900 case _CC_ENUM_XDIGIT:
5901 if (! (to_complement
5902 ^ cBOOL(is_XDIGIT_high(locinput))))
5907 case _CC_ENUM_VERTSPACE:
5908 if (! (to_complement
5909 ^ cBOOL(is_VERTWS_high(locinput))))
5914 default: /* The rest, e.g. [:cntrl:], can't match
5916 if (! to_complement) {
5922 locinput += UTF8SKIP(locinput);
5926 case CLUMP: /* Match \X: logical Unicode character. This is defined as
5927 a Unicode extended Grapheme Cluster */
5930 if (! utf8_target) {
5932 /* Match either CR LF or '.', as all the other possibilities
5934 locinput++; /* Match the . or CR */
5935 if (nextchr == '\r' /* And if it was CR, and the next is LF,
5937 && locinput < reginfo->strend
5938 && UCHARAT(locinput) == '\n')
5945 /* Get the gcb type for the current character */
5946 GCB_enum prev_gcb = getGCB_VAL_UTF8((U8*) locinput,
5947 (U8*) reginfo->strend);
5949 /* Then scan through the input until we get to the first
5950 * character whose type is supposed to be a gcb with the
5951 * current character. (There is always a break at the
5953 locinput += UTF8SKIP(locinput);
5954 while (locinput < reginfo->strend) {
5955 GCB_enum cur_gcb = getGCB_VAL_UTF8((U8*) locinput,
5956 (U8*) reginfo->strend);
5957 if (isGCB(prev_gcb, cur_gcb)) {
5962 locinput += UTF8SKIP(locinput);
5969 case NREFFL: /* /\g{name}/il */
5970 { /* The capture buffer cases. The ones beginning with N for the
5971 named buffers just convert to the equivalent numbered and
5972 pretend they were called as the corresponding numbered buffer
5974 /* don't initialize these in the declaration, it makes C++
5979 const U8 *fold_array;
5982 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
5983 folder = foldEQ_locale;
5984 fold_array = PL_fold_locale;
5986 utf8_fold_flags = FOLDEQ_LOCALE;
5989 case NREFFA: /* /\g{name}/iaa */
5990 folder = foldEQ_latin1;
5991 fold_array = PL_fold_latin1;
5993 utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII;
5996 case NREFFU: /* /\g{name}/iu */
5997 folder = foldEQ_latin1;
5998 fold_array = PL_fold_latin1;
6000 utf8_fold_flags = 0;
6003 case NREFF: /* /\g{name}/i */
6005 fold_array = PL_fold;
6007 utf8_fold_flags = 0;
6010 case NREF: /* /\g{name}/ */
6014 utf8_fold_flags = 0;
6017 /* For the named back references, find the corresponding buffer
6019 n = reg_check_named_buff_matched(rex,scan);
6024 goto do_nref_ref_common;
6026 case REFFL: /* /\1/il */
6027 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
6028 folder = foldEQ_locale;
6029 fold_array = PL_fold_locale;
6030 utf8_fold_flags = FOLDEQ_LOCALE;
6033 case REFFA: /* /\1/iaa */
6034 folder = foldEQ_latin1;
6035 fold_array = PL_fold_latin1;
6036 utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII;
6039 case REFFU: /* /\1/iu */
6040 folder = foldEQ_latin1;
6041 fold_array = PL_fold_latin1;
6042 utf8_fold_flags = 0;
6045 case REFF: /* /\1/i */
6047 fold_array = PL_fold;
6048 utf8_fold_flags = 0;
6051 case REF: /* /\1/ */
6054 utf8_fold_flags = 0;
6058 n = ARG(scan); /* which paren pair */
6061 ln = rex->offs[n].start;
6062 reginfo->poscache_iter = reginfo->poscache_maxiter; /* Void cache */
6063 if (rex->lastparen < n || ln == -1)
6064 sayNO; /* Do not match unless seen CLOSEn. */
6065 if (ln == rex->offs[n].end)
6068 s = reginfo->strbeg + ln;
6069 if (type != REF /* REF can do byte comparison */
6070 && (utf8_target || type == REFFU || type == REFFL))
6072 char * limit = reginfo->strend;
6074 /* This call case insensitively compares the entire buffer
6075 * at s, with the current input starting at locinput, but
6076 * not going off the end given by reginfo->strend, and
6077 * returns in <limit> upon success, how much of the
6078 * current input was matched */
6079 if (! foldEQ_utf8_flags(s, NULL, rex->offs[n].end - ln, utf8_target,
6080 locinput, &limit, 0, utf8_target, utf8_fold_flags))
6088 /* Not utf8: Inline the first character, for speed. */
6089 if (!NEXTCHR_IS_EOS &&
6090 UCHARAT(s) != nextchr &&
6092 UCHARAT(s) != fold_array[nextchr]))
6094 ln = rex->offs[n].end - ln;
6095 if (locinput + ln > reginfo->strend)
6097 if (ln > 1 && (type == REF
6098 ? memNE(s, locinput, ln)
6099 : ! folder(s, locinput, ln)))
6105 case NOTHING: /* null op; e.g. the 'nothing' following
6106 * the '*' in m{(a+|b)*}' */
6108 case TAIL: /* placeholder while compiling (A|B|C) */
6112 #define ST st->u.eval
6117 regexp_internal *rei;
6118 regnode *startpoint;
6120 case GOSTART: /* (?R) */
6121 case GOSUB: /* /(...(?1))/ /(...(?&foo))/ */
6122 if (cur_eval && cur_eval->locinput==locinput) {
6123 if (cur_eval->u.eval.close_paren == (U32)ARG(scan))
6124 Perl_croak(aTHX_ "Infinite recursion in regex");
6125 if ( ++nochange_depth > max_nochange_depth )
6127 "Pattern subroutine nesting without pos change"
6128 " exceeded limit in regex");
6135 if (OP(scan)==GOSUB) {
6136 startpoint = scan + ARG2L(scan);
6137 ST.close_paren = ARG(scan);
6139 startpoint = rei->program+1;
6143 /* Save all the positions seen so far. */
6144 ST.cp = regcppush(rex, 0, maxopenparen);
6145 REGCP_SET(ST.lastcp);
6147 /* and then jump to the code we share with EVAL */
6148 goto eval_recurse_doit;
6151 case EVAL: /* /(?{A})B/ /(??{A})B/ and /(?(?{A})X|Y)B/ */
6152 if (cur_eval && cur_eval->locinput==locinput) {
6153 if ( ++nochange_depth > max_nochange_depth )
6154 Perl_croak(aTHX_ "EVAL without pos change exceeded limit in regex");
6159 /* execute the code in the {...} */
6163 OP * const oop = PL_op;
6164 COP * const ocurcop = PL_curcop;
6168 /* save *all* paren positions */
6169 regcppush(rex, 0, maxopenparen);
6170 REGCP_SET(runops_cp);
6173 caller_cv = find_runcv(NULL);
6177 if (rexi->data->what[n] == 'r') { /* code from an external qr */
6179 (REGEXP*)(rexi->data->data[n])
6182 nop = (OP*)rexi->data->data[n+1];
6184 else if (rexi->data->what[n] == 'l') { /* literal code */
6186 nop = (OP*)rexi->data->data[n];
6187 assert(CvDEPTH(newcv));
6190 /* literal with own CV */
6191 assert(rexi->data->what[n] == 'L');
6192 newcv = rex->qr_anoncv;
6193 nop = (OP*)rexi->data->data[n];
6196 /* normally if we're about to execute code from the same
6197 * CV that we used previously, we just use the existing
6198 * CX stack entry. However, its possible that in the
6199 * meantime we may have backtracked, popped from the save
6200 * stack, and undone the SAVECOMPPAD(s) associated with
6201 * PUSH_MULTICALL; in which case PL_comppad no longer
6202 * points to newcv's pad. */
6203 if (newcv != last_pushed_cv || PL_comppad != last_pad)
6205 U8 flags = (CXp_SUB_RE |
6206 ((newcv == caller_cv) ? CXp_SUB_RE_FAKE : 0));
6207 if (last_pushed_cv) {
6208 CHANGE_MULTICALL_FLAGS(newcv, flags);
6211 PUSH_MULTICALL_FLAGS(newcv, flags);
6213 last_pushed_cv = newcv;
6216 /* these assignments are just to silence compiler
6218 multicall_cop = NULL;
6221 last_pad = PL_comppad;
6223 /* the initial nextstate you would normally execute
6224 * at the start of an eval (which would cause error
6225 * messages to come from the eval), may be optimised
6226 * away from the execution path in the regex code blocks;
6227 * so manually set PL_curcop to it initially */
6229 OP *o = cUNOPx(nop)->op_first;
6230 assert(o->op_type == OP_NULL);
6231 if (o->op_targ == OP_SCOPE) {
6232 o = cUNOPo->op_first;
6235 assert(o->op_targ == OP_LEAVE);
6236 o = cUNOPo->op_first;
6237 assert(o->op_type == OP_ENTER);
6241 if (o->op_type != OP_STUB) {
6242 assert( o->op_type == OP_NEXTSTATE
6243 || o->op_type == OP_DBSTATE
6244 || (o->op_type == OP_NULL
6245 && ( o->op_targ == OP_NEXTSTATE
6246 || o->op_targ == OP_DBSTATE
6250 PL_curcop = (COP*)o;
6255 DEBUG_STATE_r( PerlIO_printf(Perl_debug_log,
6256 " re EVAL PL_op=0x%"UVxf"\n", PTR2UV(nop)) );
6258 rex->offs[0].end = locinput - reginfo->strbeg;
6259 if (reginfo->info_aux_eval->pos_magic)
6260 MgBYTEPOS_set(reginfo->info_aux_eval->pos_magic,
6261 reginfo->sv, reginfo->strbeg,
6262 locinput - reginfo->strbeg);
6265 SV *sv_mrk = get_sv("REGMARK", 1);
6266 sv_setsv(sv_mrk, sv_yes_mark);
6269 /* we don't use MULTICALL here as we want to call the
6270 * first op of the block of interest, rather than the
6271 * first op of the sub */
6272 before = (IV)(SP-PL_stack_base);
6274 CALLRUNOPS(aTHX); /* Scalar context. */
6276 if ((IV)(SP-PL_stack_base) == before)
6277 ret = &PL_sv_undef; /* protect against empty (?{}) blocks. */
6283 /* before restoring everything, evaluate the returned
6284 * value, so that 'uninit' warnings don't use the wrong
6285 * PL_op or pad. Also need to process any magic vars
6286 * (e.g. $1) *before* parentheses are restored */
6291 if (logical == 0) /* (?{})/ */
6292 sv_setsv(save_scalar(PL_replgv), ret); /* $^R */
6293 else if (logical == 1) { /* /(?(?{...})X|Y)/ */
6294 sw = cBOOL(SvTRUE(ret));
6297 else { /* /(??{}) */
6298 /* if its overloaded, let the regex compiler handle
6299 * it; otherwise extract regex, or stringify */
6300 if (SvGMAGICAL(ret))
6301 ret = sv_mortalcopy(ret);
6302 if (!SvAMAGIC(ret)) {
6306 if (SvTYPE(sv) == SVt_REGEXP)
6307 re_sv = (REGEXP*) sv;
6308 else if (SvSMAGICAL(ret)) {
6309 MAGIC *mg = mg_find(ret, PERL_MAGIC_qr);
6311 re_sv = (REGEXP *) mg->mg_obj;
6314 /* force any undef warnings here */
6315 if (!re_sv && !SvPOK(ret) && !SvNIOK(ret)) {
6316 ret = sv_mortalcopy(ret);
6317 (void) SvPV_force_nolen(ret);
6323 /* *** Note that at this point we don't restore
6324 * PL_comppad, (or pop the CxSUB) on the assumption it may
6325 * be used again soon. This is safe as long as nothing
6326 * in the regexp code uses the pad ! */
6328 PL_curcop = ocurcop;
6329 S_regcp_restore(aTHX_ rex, runops_cp, &maxopenparen);
6330 PL_curpm = PL_reg_curpm;
6336 /* only /(??{})/ from now on */
6339 /* extract RE object from returned value; compiling if
6343 re_sv = reg_temp_copy(NULL, re_sv);
6348 if (SvUTF8(ret) && IN_BYTES) {
6349 /* In use 'bytes': make a copy of the octet
6350 * sequence, but without the flag on */
6352 const char *const p = SvPV(ret, len);
6353 ret = newSVpvn_flags(p, len, SVs_TEMP);
6355 if (rex->intflags & PREGf_USE_RE_EVAL)
6356 pm_flags |= PMf_USE_RE_EVAL;
6358 /* if we got here, it should be an engine which
6359 * supports compiling code blocks and stuff */
6360 assert(rex->engine && rex->engine->op_comp);
6361 assert(!(scan->flags & ~RXf_PMf_COMPILETIME));
6362 re_sv = rex->engine->op_comp(aTHX_ &ret, 1, NULL,
6363 rex->engine, NULL, NULL,
6364 /* copy /msixn etc to inner pattern */
6369 & (SVs_TEMP | SVs_GMG | SVf_ROK))
6370 && (!SvPADTMP(ret) || SvREADONLY(ret))) {
6371 /* This isn't a first class regexp. Instead, it's
6372 caching a regexp onto an existing, Perl visible
6374 sv_magic(ret, MUTABLE_SV(re_sv), PERL_MAGIC_qr, 0, 0);
6380 RXp_MATCH_COPIED_off(re);
6381 re->subbeg = rex->subbeg;
6382 re->sublen = rex->sublen;
6383 re->suboffset = rex->suboffset;
6384 re->subcoffset = rex->subcoffset;
6386 re->lastcloseparen = 0;
6389 debug_start_match(re_sv, utf8_target, locinput,
6390 reginfo->strend, "Matching embedded");
6392 startpoint = rei->program + 1;
6393 ST.close_paren = 0; /* only used for GOSUB */
6394 /* Save all the seen positions so far. */
6395 ST.cp = regcppush(rex, 0, maxopenparen);
6396 REGCP_SET(ST.lastcp);
6397 /* and set maxopenparen to 0, since we are starting a "fresh" match */
6399 /* run the pattern returned from (??{...}) */
6401 eval_recurse_doit: /* Share code with GOSUB below this line
6402 * At this point we expect the stack context to be
6403 * set up correctly */
6405 /* invalidate the S-L poscache. We're now executing a
6406 * different set of WHILEM ops (and their associated
6407 * indexes) against the same string, so the bits in the
6408 * cache are meaningless. Setting maxiter to zero forces
6409 * the cache to be invalidated and zeroed before reuse.
6410 * XXX This is too dramatic a measure. Ideally we should
6411 * save the old cache and restore when running the outer
6413 reginfo->poscache_maxiter = 0;
6415 /* the new regexp might have a different is_utf8_pat than we do */
6416 is_utf8_pat = reginfo->is_utf8_pat = cBOOL(RX_UTF8(re_sv));
6418 ST.prev_rex = rex_sv;
6419 ST.prev_curlyx = cur_curlyx;
6421 SET_reg_curpm(rex_sv);
6426 ST.prev_eval = cur_eval;
6428 /* now continue from first node in postoned RE */
6429 PUSH_YES_STATE_GOTO(EVAL_AB, startpoint, locinput);
6431 NOT_REACHED; /* NOTREACHED */
6434 case EVAL_AB: /* cleanup after a successful (??{A})B */
6435 /* note: this is called twice; first after popping B, then A */
6436 rex_sv = ST.prev_rex;
6437 is_utf8_pat = reginfo->is_utf8_pat = cBOOL(RX_UTF8(rex_sv));
6438 SET_reg_curpm(rex_sv);
6439 rex = ReANY(rex_sv);
6440 rexi = RXi_GET(rex);
6442 /* preserve $^R across LEAVE's. See Bug 121070. */
6443 SV *save_sv= GvSV(PL_replgv);
6444 SvREFCNT_inc(save_sv);
6445 regcpblow(ST.cp); /* LEAVE in disguise */
6446 sv_setsv(GvSV(PL_replgv), save_sv);
6447 SvREFCNT_dec(save_sv);
6449 cur_eval = ST.prev_eval;
6450 cur_curlyx = ST.prev_curlyx;
6452 /* Invalidate cache. See "invalidate" comment above. */
6453 reginfo->poscache_maxiter = 0;
6454 if ( nochange_depth )
6459 case EVAL_AB_fail: /* unsuccessfully ran A or B in (??{A})B */
6460 /* note: this is called twice; first after popping B, then A */
6461 rex_sv = ST.prev_rex;
6462 is_utf8_pat = reginfo->is_utf8_pat = cBOOL(RX_UTF8(rex_sv));
6463 SET_reg_curpm(rex_sv);
6464 rex = ReANY(rex_sv);
6465 rexi = RXi_GET(rex);
6467 REGCP_UNWIND(ST.lastcp);
6468 regcppop(rex, &maxopenparen);
6469 cur_eval = ST.prev_eval;
6470 cur_curlyx = ST.prev_curlyx;
6471 /* Invalidate cache. See "invalidate" comment above. */
6472 reginfo->poscache_maxiter = 0;
6473 if ( nochange_depth )
6479 n = ARG(scan); /* which paren pair */
6480 rex->offs[n].start_tmp = locinput - reginfo->strbeg;
6481 if (n > maxopenparen)
6483 DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
6484 "rex=0x%"UVxf" offs=0x%"UVxf": \\%"UVuf": set %"IVdf" tmp; maxopenparen=%"UVuf"\n",
6488 (IV)rex->offs[n].start_tmp,
6494 /* XXX really need to log other places start/end are set too */
6495 #define CLOSE_CAPTURE \
6496 rex->offs[n].start = rex->offs[n].start_tmp; \
6497 rex->offs[n].end = locinput - reginfo->strbeg; \
6498 DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log, \
6499 "rex=0x%"UVxf" offs=0x%"UVxf": \\%"UVuf": set %"IVdf"..%"IVdf"\n", \
6501 PTR2UV(rex->offs), \
6503 (IV)rex->offs[n].start, \
6504 (IV)rex->offs[n].end \
6508 n = ARG(scan); /* which paren pair */
6510 if (n > rex->lastparen)
6512 rex->lastcloseparen = n;
6513 if (cur_eval && cur_eval->u.eval.close_paren == n) {
6518 case ACCEPT: /* (*ACCEPT) */
6522 cursor && OP(cursor)!=END;
6523 cursor=regnext(cursor))
6525 if ( OP(cursor)==CLOSE ){
6527 if ( n <= lastopen ) {
6529 if (n > rex->lastparen)
6531 rex->lastcloseparen = n;
6532 if ( n == ARG(scan) || (cur_eval &&
6533 cur_eval->u.eval.close_paren == n))
6542 case GROUPP: /* (?(1)) */
6543 n = ARG(scan); /* which paren pair */
6544 sw = cBOOL(rex->lastparen >= n && rex->offs[n].end != -1);
6547 case NGROUPP: /* (?(<name>)) */
6548 /* reg_check_named_buff_matched returns 0 for no match */
6549 sw = cBOOL(0 < reg_check_named_buff_matched(rex,scan));
6552 case INSUBP: /* (?(R)) */
6554 sw = (cur_eval && (!n || cur_eval->u.eval.close_paren == n));
6557 case DEFINEP: /* (?(DEFINE)) */
6561 case IFTHEN: /* (?(cond)A|B) */
6562 reginfo->poscache_iter = reginfo->poscache_maxiter; /* Void cache */
6564 next = NEXTOPER(NEXTOPER(scan));
6566 next = scan + ARG(scan);
6567 if (OP(next) == IFTHEN) /* Fake one. */
6568 next = NEXTOPER(NEXTOPER(next));
6572 case LOGICAL: /* modifier for EVAL and IFMATCH */
6573 logical = scan->flags;
6576 /*******************************************************************
6578 The CURLYX/WHILEM pair of ops handle the most generic case of the /A*B/
6579 pattern, where A and B are subpatterns. (For simple A, CURLYM or
6580 STAR/PLUS/CURLY/CURLYN are used instead.)
6582 A*B is compiled as <CURLYX><A><WHILEM><B>
6584 On entry to the subpattern, CURLYX is called. This pushes a CURLYX
6585 state, which contains the current count, initialised to -1. It also sets
6586 cur_curlyx to point to this state, with any previous value saved in the
6589 CURLYX then jumps straight to the WHILEM op, rather than executing A,
6590 since the pattern may possibly match zero times (i.e. it's a while {} loop
6591 rather than a do {} while loop).
6593 Each entry to WHILEM represents a successful match of A. The count in the
6594 CURLYX block is incremented, another WHILEM state is pushed, and execution
6595 passes to A or B depending on greediness and the current count.
6597 For example, if matching against the string a1a2a3b (where the aN are
6598 substrings that match /A/), then the match progresses as follows: (the
6599 pushed states are interspersed with the bits of strings matched so far):
6602 <CURLYX cnt=0><WHILEM>
6603 <CURLYX cnt=1><WHILEM> a1 <WHILEM>
6604 <CURLYX cnt=2><WHILEM> a1 <WHILEM> a2 <WHILEM>
6605 <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM>
6606 <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM> b
6608 (Contrast this with something like CURLYM, which maintains only a single
6612 a1 <CURLYM cnt=1> a2
6613 a1 a2 <CURLYM cnt=2> a3
6614 a1 a2 a3 <CURLYM cnt=3> b
6617 Each WHILEM state block marks a point to backtrack to upon partial failure
6618 of A or B, and also contains some minor state data related to that
6619 iteration. The CURLYX block, pointed to by cur_curlyx, contains the
6620 overall state, such as the count, and pointers to the A and B ops.
6622 This is complicated slightly by nested CURLYX/WHILEM's. Since cur_curlyx
6623 must always point to the *current* CURLYX block, the rules are:
6625 When executing CURLYX, save the old cur_curlyx in the CURLYX state block,
6626 and set cur_curlyx to point the new block.
6628 When popping the CURLYX block after a successful or unsuccessful match,
6629 restore the previous cur_curlyx.
6631 When WHILEM is about to execute B, save the current cur_curlyx, and set it
6632 to the outer one saved in the CURLYX block.
6634 When popping the WHILEM block after a successful or unsuccessful B match,
6635 restore the previous cur_curlyx.
6637 Here's an example for the pattern (AI* BI)*BO
6638 I and O refer to inner and outer, C and W refer to CURLYX and WHILEM:
6641 curlyx backtrack stack
6642 ------ ---------------
6644 CO <CO prev=NULL> <WO>
6645 CI <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
6646 CO <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
6647 NULL <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi <WO prev=CO> bo
6649 At this point the pattern succeeds, and we work back down the stack to
6650 clean up, restoring as we go:
6652 CO <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
6653 CI <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
6654 CO <CO prev=NULL> <WO>
6657 *******************************************************************/
6659 #define ST st->u.curlyx
6661 case CURLYX: /* start of /A*B/ (for complex A) */
6663 /* No need to save/restore up to this paren */
6664 I32 parenfloor = scan->flags;
6666 assert(next); /* keep Coverity happy */
6667 if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
6670 /* XXXX Probably it is better to teach regpush to support
6671 parenfloor > maxopenparen ... */
6672 if (parenfloor > (I32)rex->lastparen)
6673 parenfloor = rex->lastparen; /* Pessimization... */
6675 ST.prev_curlyx= cur_curlyx;
6677 ST.cp = PL_savestack_ix;
6679 /* these fields contain the state of the current curly.
6680 * they are accessed by subsequent WHILEMs */
6681 ST.parenfloor = parenfloor;
6686 ST.count = -1; /* this will be updated by WHILEM */
6687 ST.lastloc = NULL; /* this will be updated by WHILEM */
6689 PUSH_YES_STATE_GOTO(CURLYX_end, PREVOPER(next), locinput);
6691 NOT_REACHED; /* NOTREACHED */
6694 case CURLYX_end: /* just finished matching all of A*B */
6695 cur_curlyx = ST.prev_curlyx;
6698 NOT_REACHED; /* NOTREACHED */
6700 case CURLYX_end_fail: /* just failed to match all of A*B */
6702 cur_curlyx = ST.prev_curlyx;
6705 NOT_REACHED; /* NOTREACHED */
6709 #define ST st->u.whilem
6711 case WHILEM: /* just matched an A in /A*B/ (for complex A) */
6713 /* see the discussion above about CURLYX/WHILEM */
6718 assert(cur_curlyx); /* keep Coverity happy */
6720 min = ARG1(cur_curlyx->u.curlyx.me);
6721 max = ARG2(cur_curlyx->u.curlyx.me);
6722 A = NEXTOPER(cur_curlyx->u.curlyx.me) + EXTRA_STEP_2ARGS;
6723 n = ++cur_curlyx->u.curlyx.count; /* how many A's matched */
6724 ST.save_lastloc = cur_curlyx->u.curlyx.lastloc;
6725 ST.cache_offset = 0;
6729 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
6730 "%*s whilem: matched %ld out of %d..%d\n",
6731 REPORT_CODE_OFF+depth*2, "", (long)n, min, max)
6734 /* First just match a string of min A's. */
6737 ST.cp = regcppush(rex, cur_curlyx->u.curlyx.parenfloor,
6739 cur_curlyx->u.curlyx.lastloc = locinput;
6740 REGCP_SET(ST.lastcp);
6742 PUSH_STATE_GOTO(WHILEM_A_pre, A, locinput);
6744 NOT_REACHED; /* NOTREACHED */
6747 /* If degenerate A matches "", assume A done. */
6749 if (locinput == cur_curlyx->u.curlyx.lastloc) {
6750 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
6751 "%*s whilem: empty match detected, trying continuation...\n",
6752 REPORT_CODE_OFF+depth*2, "")
6754 goto do_whilem_B_max;
6757 /* super-linear cache processing.
6759 * The idea here is that for certain types of CURLYX/WHILEM -
6760 * principally those whose upper bound is infinity (and
6761 * excluding regexes that have things like \1 and other very
6762 * non-regular expresssiony things), then if a pattern like
6763 * /....A*.../ fails and we backtrack to the WHILEM, then we
6764 * make a note that this particular WHILEM op was at string
6765 * position 47 (say) when the rest of pattern failed. Then, if
6766 * we ever find ourselves back at that WHILEM, and at string
6767 * position 47 again, we can just fail immediately rather than
6768 * running the rest of the pattern again.
6770 * This is very handy when patterns start to go
6771 * 'super-linear', like in (a+)*(a+)*(a+)*, where you end up
6772 * with a combinatorial explosion of backtracking.
6774 * The cache is implemented as a bit array, with one bit per
6775 * string byte position per WHILEM op (up to 16) - so its
6776 * between 0.25 and 2x the string size.
6778 * To avoid allocating a poscache buffer every time, we do an
6779 * initially countdown; only after we have executed a WHILEM
6780 * op (string-length x #WHILEMs) times do we allocate the
6783 * The top 4 bits of scan->flags byte say how many different
6784 * relevant CURLLYX/WHILEM op pairs there are, while the
6785 * bottom 4-bits is the identifying index number of this
6791 if (!reginfo->poscache_maxiter) {
6792 /* start the countdown: Postpone detection until we
6793 * know the match is not *that* much linear. */
6794 reginfo->poscache_maxiter
6795 = (reginfo->strend - reginfo->strbeg + 1)
6797 /* possible overflow for long strings and many CURLYX's */
6798 if (reginfo->poscache_maxiter < 0)
6799 reginfo->poscache_maxiter = I32_MAX;
6800 reginfo->poscache_iter = reginfo->poscache_maxiter;
6803 if (reginfo->poscache_iter-- == 0) {
6804 /* initialise cache */
6805 const SSize_t size = (reginfo->poscache_maxiter + 7)/8;
6806 regmatch_info_aux *const aux = reginfo->info_aux;
6807 if (aux->poscache) {
6808 if ((SSize_t)reginfo->poscache_size < size) {
6809 Renew(aux->poscache, size, char);
6810 reginfo->poscache_size = size;
6812 Zero(aux->poscache, size, char);
6815 reginfo->poscache_size = size;
6816 Newxz(aux->poscache, size, char);
6818 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
6819 "%swhilem: Detected a super-linear match, switching on caching%s...\n",
6820 PL_colors[4], PL_colors[5])
6824 if (reginfo->poscache_iter < 0) {
6825 /* have we already failed at this position? */
6826 SSize_t offset, mask;
6828 reginfo->poscache_iter = -1; /* stop eventual underflow */
6829 offset = (scan->flags & 0xf) - 1
6830 + (locinput - reginfo->strbeg)
6832 mask = 1 << (offset % 8);
6834 if (reginfo->info_aux->poscache[offset] & mask) {
6835 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
6836 "%*s whilem: (cache) already tried at this position...\n",
6837 REPORT_CODE_OFF+depth*2, "")
6839 sayNO; /* cache records failure */
6841 ST.cache_offset = offset;
6842 ST.cache_mask = mask;
6846 /* Prefer B over A for minimal matching. */
6848 if (cur_curlyx->u.curlyx.minmod) {
6849 ST.save_curlyx = cur_curlyx;
6850 cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
6851 ST.cp = regcppush(rex, ST.save_curlyx->u.curlyx.parenfloor,
6853 REGCP_SET(ST.lastcp);
6854 PUSH_YES_STATE_GOTO(WHILEM_B_min, ST.save_curlyx->u.curlyx.B,
6857 NOT_REACHED; /* NOTREACHED */
6860 /* Prefer A over B for maximal matching. */
6862 if (n < max) { /* More greed allowed? */
6863 ST.cp = regcppush(rex, cur_curlyx->u.curlyx.parenfloor,
6865 cur_curlyx->u.curlyx.lastloc = locinput;
6866 REGCP_SET(ST.lastcp);
6867 PUSH_STATE_GOTO(WHILEM_A_max, A, locinput);
6869 NOT_REACHED; /* NOTREACHED */
6871 goto do_whilem_B_max;
6874 NOT_REACHED; /* NOTREACHED */
6876 case WHILEM_B_min: /* just matched B in a minimal match */
6877 case WHILEM_B_max: /* just matched B in a maximal match */
6878 cur_curlyx = ST.save_curlyx;
6881 NOT_REACHED; /* NOTREACHED */
6883 case WHILEM_B_max_fail: /* just failed to match B in a maximal match */
6884 cur_curlyx = ST.save_curlyx;
6885 cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
6886 cur_curlyx->u.curlyx.count--;
6889 NOT_REACHED; /* NOTREACHED */
6891 case WHILEM_A_min_fail: /* just failed to match A in a minimal match */
6893 case WHILEM_A_pre_fail: /* just failed to match even minimal A */
6894 REGCP_UNWIND(ST.lastcp);
6895 regcppop(rex, &maxopenparen);
6896 cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
6897 cur_curlyx->u.curlyx.count--;
6900 NOT_REACHED; /* NOTREACHED */
6902 case WHILEM_A_max_fail: /* just failed to match A in a maximal match */
6903 REGCP_UNWIND(ST.lastcp);
6904 regcppop(rex, &maxopenparen); /* Restore some previous $<digit>s? */
6905 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
6906 "%*s whilem: failed, trying continuation...\n",
6907 REPORT_CODE_OFF+depth*2, "")
6910 if (cur_curlyx->u.curlyx.count >= REG_INFTY
6911 && ckWARN(WARN_REGEXP)
6912 && !reginfo->warned)
6914 reginfo->warned = TRUE;
6915 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6916 "Complex regular subexpression recursion limit (%d) "
6922 ST.save_curlyx = cur_curlyx;
6923 cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
6924 PUSH_YES_STATE_GOTO(WHILEM_B_max, ST.save_curlyx->u.curlyx.B,
6927 NOT_REACHED; /* NOTREACHED */
6929 case WHILEM_B_min_fail: /* just failed to match B in a minimal match */
6930 cur_curlyx = ST.save_curlyx;
6931 REGCP_UNWIND(ST.lastcp);
6932 regcppop(rex, &maxopenparen);
6934 if (cur_curlyx->u.curlyx.count >= /*max*/ARG2(cur_curlyx->u.curlyx.me)) {
6935 /* Maximum greed exceeded */
6936 if (cur_curlyx->u.curlyx.count >= REG_INFTY
6937 && ckWARN(WARN_REGEXP)
6938 && !reginfo->warned)
6940 reginfo->warned = TRUE;
6941 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6942 "Complex regular subexpression recursion "
6943 "limit (%d) exceeded",
6946 cur_curlyx->u.curlyx.count--;
6950 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
6951 "%*s trying longer...\n", REPORT_CODE_OFF+depth*2, "")
6953 /* Try grabbing another A and see if it helps. */
6954 cur_curlyx->u.curlyx.lastloc = locinput;
6955 ST.cp = regcppush(rex, cur_curlyx->u.curlyx.parenfloor,
6957 REGCP_SET(ST.lastcp);
6958 PUSH_STATE_GOTO(WHILEM_A_min,
6959 /*A*/ NEXTOPER(ST.save_curlyx->u.curlyx.me) + EXTRA_STEP_2ARGS,
6962 NOT_REACHED; /* NOTREACHED */
6965 #define ST st->u.branch
6967 case BRANCHJ: /* /(...|A|...)/ with long next pointer */
6968 next = scan + ARG(scan);
6971 scan = NEXTOPER(scan);
6974 case BRANCH: /* /(...|A|...)/ */
6975 scan = NEXTOPER(scan); /* scan now points to inner node */
6976 ST.lastparen = rex->lastparen;
6977 ST.lastcloseparen = rex->lastcloseparen;
6978 ST.next_branch = next;
6981 /* Now go into the branch */
6983 PUSH_YES_STATE_GOTO(BRANCH_next, scan, locinput);
6985 PUSH_STATE_GOTO(BRANCH_next, scan, locinput);
6988 NOT_REACHED; /* NOTREACHED */
6990 case CUTGROUP: /* /(*THEN)/ */
6991 sv_yes_mark = st->u.mark.mark_name = scan->flags ? NULL :
6992 MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
6993 PUSH_STATE_GOTO(CUTGROUP_next, next, locinput);
6995 NOT_REACHED; /* NOTREACHED */
6997 case CUTGROUP_next_fail:
7000 if (st->u.mark.mark_name)
7001 sv_commit = st->u.mark.mark_name;
7004 NOT_REACHED; /* NOTREACHED */
7009 NOT_REACHED; /* NOTREACHED */
7011 case BRANCH_next_fail: /* that branch failed; try the next, if any */
7016 REGCP_UNWIND(ST.cp);
7017 UNWIND_PAREN(ST.lastparen, ST.lastcloseparen);
7018 scan = ST.next_branch;
7019 /* no more branches? */
7020 if (!scan || (OP(scan) != BRANCH && OP(scan) != BRANCHJ)) {
7022 PerlIO_printf( Perl_debug_log,
7023 "%*s %sBRANCH failed...%s\n",
7024 REPORT_CODE_OFF+depth*2, "",
7030 continue; /* execute next BRANCH[J] op */
7033 case MINMOD: /* next op will be non-greedy, e.g. A*? */
7038 #define ST st->u.curlym
7040 case CURLYM: /* /A{m,n}B/ where A is fixed-length */
7042 /* This is an optimisation of CURLYX that enables us to push
7043 * only a single backtracking state, no matter how many matches
7044 * there are in {m,n}. It relies on the pattern being constant
7045 * length, with no parens to influence future backrefs
7049 scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
7051 ST.lastparen = rex->lastparen;
7052 ST.lastcloseparen = rex->lastcloseparen;
7054 /* if paren positive, emulate an OPEN/CLOSE around A */
7056 U32 paren = ST.me->flags;
7057 if (paren > maxopenparen)
7058 maxopenparen = paren;
7059 scan += NEXT_OFF(scan); /* Skip former OPEN. */
7067 ST.c1 = CHRTEST_UNINIT;
7070 if (!(ST.minmod ? ARG1(ST.me) : ARG2(ST.me))) /* min/max */
7073 curlym_do_A: /* execute the A in /A{m,n}B/ */
7074 PUSH_YES_STATE_GOTO(CURLYM_A, ST.A, locinput); /* match A */
7076 NOT_REACHED; /* NOTREACHED */
7078 case CURLYM_A: /* we've just matched an A */
7080 /* after first match, determine A's length: u.curlym.alen */
7081 if (ST.count == 1) {
7082 if (reginfo->is_utf8_target) {
7083 char *s = st->locinput;
7084 while (s < locinput) {
7090 ST.alen = locinput - st->locinput;
7093 ST.count = ST.minmod ? ARG1(ST.me) : ARG2(ST.me);
7096 PerlIO_printf(Perl_debug_log,
7097 "%*s CURLYM now matched %"IVdf" times, len=%"IVdf"...\n",
7098 (int)(REPORT_CODE_OFF+(depth*2)), "",
7099 (IV) ST.count, (IV)ST.alen)
7102 if (cur_eval && cur_eval->u.eval.close_paren &&
7103 cur_eval->u.eval.close_paren == (U32)ST.me->flags)
7107 I32 max = (ST.minmod ? ARG1(ST.me) : ARG2(ST.me));
7108 if ( max == REG_INFTY || ST.count < max )
7109 goto curlym_do_A; /* try to match another A */
7111 goto curlym_do_B; /* try to match B */
7113 case CURLYM_A_fail: /* just failed to match an A */
7114 REGCP_UNWIND(ST.cp);
7116 if (ST.minmod || ST.count < ARG1(ST.me) /* min*/
7117 || (cur_eval && cur_eval->u.eval.close_paren &&
7118 cur_eval->u.eval.close_paren == (U32)ST.me->flags))
7121 curlym_do_B: /* execute the B in /A{m,n}B/ */
7122 if (ST.c1 == CHRTEST_UNINIT) {
7123 /* calculate c1 and c2 for possible match of 1st char
7124 * following curly */
7125 ST.c1 = ST.c2 = CHRTEST_VOID;
7127 if (HAS_TEXT(ST.B) || JUMPABLE(ST.B)) {
7128 regnode *text_node = ST.B;
7129 if (! HAS_TEXT(text_node))
7130 FIND_NEXT_IMPT(text_node);
7133 (HAS_TEXT(text_node) && PL_regkind[OP(text_node)] == EXACT)
7135 But the former is redundant in light of the latter.
7137 if this changes back then the macro for
7138 IS_TEXT and friends need to change.
7140 if (PL_regkind[OP(text_node)] == EXACT) {
7141 if (! S_setup_EXACTISH_ST_c1_c2(aTHX_
7142 text_node, &ST.c1, ST.c1_utf8, &ST.c2, ST.c2_utf8,
7152 PerlIO_printf(Perl_debug_log,
7153 "%*s CURLYM trying tail with matches=%"IVdf"...\n",
7154 (int)(REPORT_CODE_OFF+(depth*2)),
7157 if (! NEXTCHR_IS_EOS && ST.c1 != CHRTEST_VOID) {
7158 if (! UTF8_IS_INVARIANT(nextchr) && utf8_target) {
7159 if (memNE(locinput, ST.c1_utf8, UTF8SKIP(locinput))
7160 && memNE(locinput, ST.c2_utf8, UTF8SKIP(locinput)))
7162 /* simulate B failing */
7164 PerlIO_printf(Perl_debug_log,
7165 "%*s CURLYM Fast bail next target=0x%"UVXf" c1=0x%"UVXf" c2=0x%"UVXf"\n",
7166 (int)(REPORT_CODE_OFF+(depth*2)),"",
7167 valid_utf8_to_uvchr((U8 *) locinput, NULL),
7168 valid_utf8_to_uvchr(ST.c1_utf8, NULL),
7169 valid_utf8_to_uvchr(ST.c2_utf8, NULL))
7171 state_num = CURLYM_B_fail;
7172 goto reenter_switch;
7175 else if (nextchr != ST.c1 && nextchr != ST.c2) {
7176 /* simulate B failing */
7178 PerlIO_printf(Perl_debug_log,
7179 "%*s CURLYM Fast bail next target=0x%X c1=0x%X c2=0x%X\n",
7180 (int)(REPORT_CODE_OFF+(depth*2)),"",
7181 (int) nextchr, ST.c1, ST.c2)
7183 state_num = CURLYM_B_fail;
7184 goto reenter_switch;
7189 /* emulate CLOSE: mark current A as captured */
7190 I32 paren = ST.me->flags;
7192 rex->offs[paren].start
7193 = HOPc(locinput, -ST.alen) - reginfo->strbeg;
7194 rex->offs[paren].end = locinput - reginfo->strbeg;
7195 if ((U32)paren > rex->lastparen)
7196 rex->lastparen = paren;
7197 rex->lastcloseparen = paren;
7200 rex->offs[paren].end = -1;
7201 if (cur_eval && cur_eval->u.eval.close_paren &&
7202 cur_eval->u.eval.close_paren == (U32)ST.me->flags)
7211 PUSH_STATE_GOTO(CURLYM_B, ST.B, locinput); /* match B */
7213 NOT_REACHED; /* NOTREACHED */
7215 case CURLYM_B_fail: /* just failed to match a B */
7216 REGCP_UNWIND(ST.cp);
7217 UNWIND_PAREN(ST.lastparen, ST.lastcloseparen);
7219 I32 max = ARG2(ST.me);
7220 if (max != REG_INFTY && ST.count == max)
7222 goto curlym_do_A; /* try to match a further A */
7224 /* backtrack one A */
7225 if (ST.count == ARG1(ST.me) /* min */)
7228 SET_locinput(HOPc(locinput, -ST.alen));
7229 goto curlym_do_B; /* try to match B */
7232 #define ST st->u.curly
7234 #define CURLY_SETPAREN(paren, success) \
7237 rex->offs[paren].start = HOPc(locinput, -1) - reginfo->strbeg; \
7238 rex->offs[paren].end = locinput - reginfo->strbeg; \
7239 if (paren > rex->lastparen) \
7240 rex->lastparen = paren; \
7241 rex->lastcloseparen = paren; \
7244 rex->offs[paren].end = -1; \
7245 rex->lastparen = ST.lastparen; \
7246 rex->lastcloseparen = ST.lastcloseparen; \
7250 case STAR: /* /A*B/ where A is width 1 char */
7254 scan = NEXTOPER(scan);
7257 case PLUS: /* /A+B/ where A is width 1 char */
7261 scan = NEXTOPER(scan);
7264 case CURLYN: /* /(A){m,n}B/ where A is width 1 char */
7265 ST.paren = scan->flags; /* Which paren to set */
7266 ST.lastparen = rex->lastparen;
7267 ST.lastcloseparen = rex->lastcloseparen;
7268 if (ST.paren > maxopenparen)
7269 maxopenparen = ST.paren;
7270 ST.min = ARG1(scan); /* min to match */
7271 ST.max = ARG2(scan); /* max to match */
7272 if (cur_eval && cur_eval->u.eval.close_paren &&
7273 cur_eval->u.eval.close_paren == (U32)ST.paren) {
7277 scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
7280 case CURLY: /* /A{m,n}B/ where A is width 1 char */
7282 ST.min = ARG1(scan); /* min to match */
7283 ST.max = ARG2(scan); /* max to match */
7284 scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
7287 * Lookahead to avoid useless match attempts
7288 * when we know what character comes next.
7290 * Used to only do .*x and .*?x, but now it allows
7291 * for )'s, ('s and (?{ ... })'s to be in the way
7292 * of the quantifier and the EXACT-like node. -- japhy
7295 assert(ST.min <= ST.max);
7296 if (! HAS_TEXT(next) && ! JUMPABLE(next)) {
7297 ST.c1 = ST.c2 = CHRTEST_VOID;
7300 regnode *text_node = next;
7302 if (! HAS_TEXT(text_node))
7303 FIND_NEXT_IMPT(text_node);
7305 if (! HAS_TEXT(text_node))
7306 ST.c1 = ST.c2 = CHRTEST_VOID;
7308 if ( PL_regkind[OP(text_node)] != EXACT ) {
7309 ST.c1 = ST.c2 = CHRTEST_VOID;
7313 /* Currently we only get here when
7315 PL_rekind[OP(text_node)] == EXACT
7317 if this changes back then the macro for IS_TEXT and
7318 friends need to change. */
7319 if (! S_setup_EXACTISH_ST_c1_c2(aTHX_
7320 text_node, &ST.c1, ST.c1_utf8, &ST.c2, ST.c2_utf8,
7332 char *li = locinput;
7335 regrepeat(rex, &li, ST.A, reginfo, ST.min, depth)
7341 if (ST.c1 == CHRTEST_VOID)
7342 goto curly_try_B_min;
7344 ST.oldloc = locinput;
7346 /* set ST.maxpos to the furthest point along the
7347 * string that could possibly match */
7348 if (ST.max == REG_INFTY) {
7349 ST.maxpos = reginfo->strend - 1;
7351 while (UTF8_IS_CONTINUATION(*(U8*)ST.maxpos))
7354 else if (utf8_target) {
7355 int m = ST.max - ST.min;
7356 for (ST.maxpos = locinput;
7357 m >0 && ST.maxpos < reginfo->strend; m--)
7358 ST.maxpos += UTF8SKIP(ST.maxpos);
7361 ST.maxpos = locinput + ST.max - ST.min;
7362 if (ST.maxpos >= reginfo->strend)
7363 ST.maxpos = reginfo->strend - 1;
7365 goto curly_try_B_min_known;
7369 /* avoid taking address of locinput, so it can remain
7371 char *li = locinput;
7372 ST.count = regrepeat(rex, &li, ST.A, reginfo, ST.max, depth);
7373 if (ST.count < ST.min)
7376 if ((ST.count > ST.min)
7377 && (PL_regkind[OP(ST.B)] == EOL) && (OP(ST.B) != MEOL))
7379 /* A{m,n} must come at the end of the string, there's
7380 * no point in backing off ... */
7382 /* ...except that $ and \Z can match before *and* after
7383 newline at the end. Consider "\n\n" =~ /\n+\Z\n/.
7384 We may back off by one in this case. */
7385 if (UCHARAT(locinput - 1) == '\n' && OP(ST.B) != EOS)
7389 goto curly_try_B_max;
7392 NOT_REACHED; /* NOTREACHED */
7394 case CURLY_B_min_known_fail:
7395 /* failed to find B in a non-greedy match where c1,c2 valid */
7397 REGCP_UNWIND(ST.cp);
7399 UNWIND_PAREN(ST.lastparen, ST.lastcloseparen);
7401 /* Couldn't or didn't -- move forward. */
7402 ST.oldloc = locinput;
7404 locinput += UTF8SKIP(locinput);
7408 curly_try_B_min_known:
7409 /* find the next place where 'B' could work, then call B */
7413 n = (ST.oldloc == locinput) ? 0 : 1;
7414 if (ST.c1 == ST.c2) {
7415 /* set n to utf8_distance(oldloc, locinput) */
7416 while (locinput <= ST.maxpos
7417 && memNE(locinput, ST.c1_utf8, UTF8SKIP(locinput)))
7419 locinput += UTF8SKIP(locinput);
7424 /* set n to utf8_distance(oldloc, locinput) */
7425 while (locinput <= ST.maxpos
7426 && memNE(locinput, ST.c1_utf8, UTF8SKIP(locinput))
7427 && memNE(locinput, ST.c2_utf8, UTF8SKIP(locinput)))
7429 locinput += UTF8SKIP(locinput);
7434 else { /* Not utf8_target */
7435 if (ST.c1 == ST.c2) {
7436 while (locinput <= ST.maxpos &&
7437 UCHARAT(locinput) != ST.c1)
7441 while (locinput <= ST.maxpos
7442 && UCHARAT(locinput) != ST.c1
7443 && UCHARAT(locinput) != ST.c2)
7446 n = locinput - ST.oldloc;
7448 if (locinput > ST.maxpos)
7451 /* In /a{m,n}b/, ST.oldloc is at "a" x m, locinput is
7452 * at b; check that everything between oldloc and
7453 * locinput matches */
7454 char *li = ST.oldloc;
7456 if (regrepeat(rex, &li, ST.A, reginfo, n, depth) < n)
7458 assert(n == REG_INFTY || locinput == li);
7460 CURLY_SETPAREN(ST.paren, ST.count);
7461 if (cur_eval && cur_eval->u.eval.close_paren &&
7462 cur_eval->u.eval.close_paren == (U32)ST.paren) {
7465 PUSH_STATE_GOTO(CURLY_B_min_known, ST.B, locinput);
7468 NOT_REACHED; /* NOTREACHED */
7470 case CURLY_B_min_fail:
7471 /* failed to find B in a non-greedy match where c1,c2 invalid */
7473 REGCP_UNWIND(ST.cp);
7475 UNWIND_PAREN(ST.lastparen, ST.lastcloseparen);
7477 /* failed -- move forward one */
7479 char *li = locinput;
7480 if (!regrepeat(rex, &li, ST.A, reginfo, 1, depth)) {
7487 if (ST.count <= ST.max || (ST.max == REG_INFTY &&
7488 ST.count > 0)) /* count overflow ? */
7491 CURLY_SETPAREN(ST.paren, ST.count);
7492 if (cur_eval && cur_eval->u.eval.close_paren &&
7493 cur_eval->u.eval.close_paren == (U32)ST.paren) {
7496 PUSH_STATE_GOTO(CURLY_B_min, ST.B, locinput);
7501 NOT_REACHED; /* NOTREACHED */
7504 /* a successful greedy match: now try to match B */
7505 if (cur_eval && cur_eval->u.eval.close_paren &&
7506 cur_eval->u.eval.close_paren == (U32)ST.paren) {
7510 bool could_match = locinput < reginfo->strend;
7512 /* If it could work, try it. */
7513 if (ST.c1 != CHRTEST_VOID && could_match) {
7514 if (! UTF8_IS_INVARIANT(UCHARAT(locinput)) && utf8_target)
7516 could_match = memEQ(locinput,
7521 UTF8SKIP(locinput));
7524 could_match = UCHARAT(locinput) == ST.c1
7525 || UCHARAT(locinput) == ST.c2;
7528 if (ST.c1 == CHRTEST_VOID || could_match) {
7529 CURLY_SETPAREN(ST.paren, ST.count);
7530 PUSH_STATE_GOTO(CURLY_B_max, ST.B, locinput);
7532 NOT_REACHED; /* NOTREACHED */
7537 case CURLY_B_max_fail:
7538 /* failed to find B in a greedy match */
7540 REGCP_UNWIND(ST.cp);
7542 UNWIND_PAREN(ST.lastparen, ST.lastcloseparen);
7545 if (--ST.count < ST.min)
7547 locinput = HOPc(locinput, -1);
7548 goto curly_try_B_max;
7552 case END: /* last op of main pattern */
7555 /* we've just finished A in /(??{A})B/; now continue with B */
7557 st->u.eval.prev_rex = rex_sv; /* inner */
7559 /* Save *all* the positions. */
7560 st->u.eval.cp = regcppush(rex, 0, maxopenparen);
7561 rex_sv = cur_eval->u.eval.prev_rex;
7562 is_utf8_pat = reginfo->is_utf8_pat = cBOOL(RX_UTF8(rex_sv));
7563 SET_reg_curpm(rex_sv);
7564 rex = ReANY(rex_sv);
7565 rexi = RXi_GET(rex);
7566 cur_curlyx = cur_eval->u.eval.prev_curlyx;
7568 REGCP_SET(st->u.eval.lastcp);
7570 /* Restore parens of the outer rex without popping the
7572 S_regcp_restore(aTHX_ rex, cur_eval->u.eval.lastcp,
7575 st->u.eval.prev_eval = cur_eval;
7576 cur_eval = cur_eval->u.eval.prev_eval;
7578 PerlIO_printf(Perl_debug_log, "%*s EVAL trying tail ... %"UVxf"\n",
7579 REPORT_CODE_OFF+depth*2, "",PTR2UV(cur_eval)););
7580 if ( nochange_depth )
7583 PUSH_YES_STATE_GOTO(EVAL_AB, st->u.eval.prev_eval->u.eval.B,
7584 locinput); /* match B */
7587 if (locinput < reginfo->till) {
7588 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
7589 "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
7591 (long)(locinput - startpos),
7592 (long)(reginfo->till - startpos),
7595 sayNO_SILENT; /* Cannot match: too short. */
7597 sayYES; /* Success! */
7599 case SUCCEED: /* successful SUSPEND/UNLESSM/IFMATCH/CURLYM */
7601 PerlIO_printf(Perl_debug_log,
7602 "%*s %ssubpattern success...%s\n",
7603 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5]));
7604 sayYES; /* Success! */
7607 #define ST st->u.ifmatch
7612 case SUSPEND: /* (?>A) */
7614 newstart = locinput;
7617 case UNLESSM: /* -ve lookaround: (?!A), or with flags, (?<!A) */
7619 goto ifmatch_trivial_fail_test;
7621 case IFMATCH: /* +ve lookaround: (?=A), or with flags, (?<=A) */
7623 ifmatch_trivial_fail_test:
7625 char * const s = HOPBACKc(locinput, scan->flags);
7630 sw = 1 - cBOOL(ST.wanted);
7634 next = scan + ARG(scan);
7642 newstart = locinput;
7646 ST.logical = logical;
7647 logical = 0; /* XXX: reset state of logical once it has been saved into ST */
7649 /* execute body of (?...A) */
7650 PUSH_YES_STATE_GOTO(IFMATCH_A, NEXTOPER(NEXTOPER(scan)), newstart);
7652 NOT_REACHED; /* NOTREACHED */
7655 case IFMATCH_A_fail: /* body of (?...A) failed */
7656 ST.wanted = !ST.wanted;
7659 case IFMATCH_A: /* body of (?...A) succeeded */
7661 sw = cBOOL(ST.wanted);
7663 else if (!ST.wanted)
7666 if (OP(ST.me) != SUSPEND) {
7667 /* restore old position except for (?>...) */
7668 locinput = st->locinput;
7670 scan = ST.me + ARG(ST.me);
7673 continue; /* execute B */
7677 case LONGJMP: /* alternative with many branches compiles to
7678 * (BRANCHJ; EXACT ...; LONGJMP ) x N */
7679 next = scan + ARG(scan);
7684 case COMMIT: /* (*COMMIT) */
7685 reginfo->cutpoint = reginfo->strend;
7688 case PRUNE: /* (*PRUNE) */
7690 sv_yes_mark = sv_commit = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
7691 PUSH_STATE_GOTO(COMMIT_next, next, locinput);
7693 NOT_REACHED; /* NOTREACHED */
7695 case COMMIT_next_fail:
7699 case OPFAIL: /* (*FAIL) */
7702 NOT_REACHED; /* NOTREACHED */
7704 #define ST st->u.mark
7705 case MARKPOINT: /* (*MARK:foo) */
7706 ST.prev_mark = mark_state;
7707 ST.mark_name = sv_commit = sv_yes_mark
7708 = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
7710 ST.mark_loc = locinput;
7711 PUSH_YES_STATE_GOTO(MARKPOINT_next, next, locinput);
7713 NOT_REACHED; /* NOTREACHED */
7715 case MARKPOINT_next:
7716 mark_state = ST.prev_mark;
7719 NOT_REACHED; /* NOTREACHED */
7721 case MARKPOINT_next_fail:
7722 if (popmark && sv_eq(ST.mark_name,popmark))
7724 if (ST.mark_loc > startpoint)
7725 reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1);
7726 popmark = NULL; /* we found our mark */
7727 sv_commit = ST.mark_name;
7730 PerlIO_printf(Perl_debug_log,
7731 "%*s %ssetting cutpoint to mark:%"SVf"...%s\n",
7732 REPORT_CODE_OFF+depth*2, "",
7733 PL_colors[4], SVfARG(sv_commit), PL_colors[5]);
7736 mark_state = ST.prev_mark;
7737 sv_yes_mark = mark_state ?
7738 mark_state->u.mark.mark_name : NULL;
7741 NOT_REACHED; /* NOTREACHED */
7743 case SKIP: /* (*SKIP) */
7745 /* (*SKIP) : if we fail we cut here*/
7746 ST.mark_name = NULL;
7747 ST.mark_loc = locinput;
7748 PUSH_STATE_GOTO(SKIP_next,next, locinput);
7750 /* (*SKIP:NAME) : if there is a (*MARK:NAME) fail where it was,
7751 otherwise do nothing. Meaning we need to scan
7753 regmatch_state *cur = mark_state;
7754 SV *find = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
7757 if ( sv_eq( cur->u.mark.mark_name,
7760 ST.mark_name = find;
7761 PUSH_STATE_GOTO( SKIP_next, next, locinput);
7763 cur = cur->u.mark.prev_mark;
7766 /* Didn't find our (*MARK:NAME) so ignore this (*SKIP:NAME) */
7769 case SKIP_next_fail:
7771 /* (*CUT:NAME) - Set up to search for the name as we
7772 collapse the stack*/
7773 popmark = ST.mark_name;
7775 /* (*CUT) - No name, we cut here.*/
7776 if (ST.mark_loc > startpoint)
7777 reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1);
7778 /* but we set sv_commit to latest mark_name if there
7779 is one so they can test to see how things lead to this
7782 sv_commit=mark_state->u.mark.mark_name;
7787 NOT_REACHED; /* NOTREACHED */
7790 case LNBREAK: /* \R */
7791 if ((n=is_LNBREAK_safe(locinput, reginfo->strend, utf8_target))) {
7798 PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
7799 PTR2UV(scan), OP(scan));
7800 Perl_croak(aTHX_ "regexp memory corruption");
7802 /* this is a point to jump to in order to increment
7803 * locinput by one character */
7805 assert(!NEXTCHR_IS_EOS);
7807 locinput += PL_utf8skip[nextchr];
7808 /* locinput is allowed to go 1 char off the end, but not 2+ */
7809 if (locinput > reginfo->strend)
7818 /* switch break jumps here */
7819 scan = next; /* prepare to execute the next op and ... */
7820 continue; /* ... jump back to the top, reusing st */
7824 /* push a state that backtracks on success */
7825 st->u.yes.prev_yes_state = yes_state;
7829 /* push a new regex state, then continue at scan */
7831 regmatch_state *newst;
7834 regmatch_state *cur = st;
7835 regmatch_state *curyes = yes_state;
7837 regmatch_slab *slab = PL_regmatch_slab;
7838 for (;curd > -1;cur--,curd--) {
7839 if (cur < SLAB_FIRST(slab)) {
7841 cur = SLAB_LAST(slab);
7843 PerlIO_printf(Perl_error_log, "%*s#%-3d %-10s %s\n",
7844 REPORT_CODE_OFF + 2 + depth * 2,"",
7845 curd, PL_reg_name[cur->resume_state],
7846 (curyes == cur) ? "yes" : ""
7849 curyes = cur->u.yes.prev_yes_state;
7852 DEBUG_STATE_pp("push")
7855 st->locinput = locinput;
7857 if (newst > SLAB_LAST(PL_regmatch_slab))
7858 newst = S_push_slab(aTHX);
7859 PL_regmatch_state = newst;
7861 locinput = pushinput;
7869 * We get here only if there's trouble -- normally "case END" is
7870 * the terminating point.
7872 Perl_croak(aTHX_ "corrupted regexp pointers");
7875 NOT_REACHED; /* NOTREACHED */
7879 /* we have successfully completed a subexpression, but we must now
7880 * pop to the state marked by yes_state and continue from there */
7881 assert(st != yes_state);
7883 while (st != yes_state) {
7885 if (st < SLAB_FIRST(PL_regmatch_slab)) {
7886 PL_regmatch_slab = PL_regmatch_slab->prev;
7887 st = SLAB_LAST(PL_regmatch_slab);
7891 DEBUG_STATE_pp("pop (no final)");
7893 DEBUG_STATE_pp("pop (yes)");
7899 while (yes_state < SLAB_FIRST(PL_regmatch_slab)
7900 || yes_state > SLAB_LAST(PL_regmatch_slab))
7902 /* not in this slab, pop slab */
7903 depth -= (st - SLAB_FIRST(PL_regmatch_slab) + 1);
7904 PL_regmatch_slab = PL_regmatch_slab->prev;
7905 st = SLAB_LAST(PL_regmatch_slab);
7907 depth -= (st - yes_state);
7910 yes_state = st->u.yes.prev_yes_state;
7911 PL_regmatch_state = st;
7914 locinput= st->locinput;
7915 state_num = st->resume_state + no_final;
7916 goto reenter_switch;
7919 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
7920 PL_colors[4], PL_colors[5]));
7922 if (reginfo->info_aux_eval) {
7923 /* each successfully executed (?{...}) block does the equivalent of
7924 * local $^R = do {...}
7925 * When popping the save stack, all these locals would be undone;
7926 * bypass this by setting the outermost saved $^R to the latest
7928 /* I dont know if this is needed or works properly now.
7929 * see code related to PL_replgv elsewhere in this file.
7932 if (oreplsv != GvSV(PL_replgv))
7933 sv_setsv(oreplsv, GvSV(PL_replgv));
7940 PerlIO_printf(Perl_debug_log,
7941 "%*s %sfailed...%s\n",
7942 REPORT_CODE_OFF+depth*2, "",
7943 PL_colors[4], PL_colors[5])
7955 /* there's a previous state to backtrack to */
7957 if (st < SLAB_FIRST(PL_regmatch_slab)) {
7958 PL_regmatch_slab = PL_regmatch_slab->prev;
7959 st = SLAB_LAST(PL_regmatch_slab);
7961 PL_regmatch_state = st;
7962 locinput= st->locinput;
7964 DEBUG_STATE_pp("pop");
7966 if (yes_state == st)
7967 yes_state = st->u.yes.prev_yes_state;
7969 state_num = st->resume_state + 1; /* failure = success + 1 */
7970 goto reenter_switch;
7975 if (rex->intflags & PREGf_VERBARG_SEEN) {
7976 SV *sv_err = get_sv("REGERROR", 1);
7977 SV *sv_mrk = get_sv("REGMARK", 1);
7979 sv_commit = &PL_sv_no;
7981 sv_yes_mark = &PL_sv_yes;
7984 sv_commit = &PL_sv_yes;
7985 sv_yes_mark = &PL_sv_no;
7989 sv_setsv(sv_err, sv_commit);
7990 sv_setsv(sv_mrk, sv_yes_mark);
7994 if (last_pushed_cv) {
7997 PERL_UNUSED_VAR(SP);
8000 assert(!result || locinput - reginfo->strbeg >= 0);
8001 return result ? locinput - reginfo->strbeg : -1;
8005 - regrepeat - repeatedly match something simple, report how many
8007 * What 'simple' means is a node which can be the operand of a quantifier like
8010 * startposp - pointer a pointer to the start position. This is updated
8011 * to point to the byte following the highest successful
8013 * p - the regnode to be repeatedly matched against.
8014 * reginfo - struct holding match state, such as strend
8015 * max - maximum number of things to match.
8016 * depth - (for debugging) backtracking depth.
8019 S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p,
8020 regmatch_info *const reginfo, I32 max, int depth)
8022 char *scan; /* Pointer to current position in target string */
8024 char *loceol = reginfo->strend; /* local version */
8025 I32 hardcount = 0; /* How many matches so far */
8026 bool utf8_target = reginfo->is_utf8_target;
8027 unsigned int to_complement = 0; /* Invert the result? */
8029 _char_class_number classnum;
8031 PERL_UNUSED_ARG(depth);
8034 PERL_ARGS_ASSERT_REGREPEAT;
8037 if (max == REG_INFTY)
8039 else if (! utf8_target && loceol - scan > max)
8040 loceol = scan + max;
8042 /* Here, for the case of a non-UTF-8 target we have adjusted <loceol> down
8043 * to the maximum of how far we should go in it (leaving it set to the real
8044 * end, if the maximum permissible would take us beyond that). This allows
8045 * us to make the loop exit condition that we haven't gone past <loceol> to
8046 * also mean that we haven't exceeded the max permissible count, saving a
8047 * test each time through the loop. But it assumes that the OP matches a
8048 * single byte, which is true for most of the OPs below when applied to a
8049 * non-UTF-8 target. Those relatively few OPs that don't have this
8050 * characteristic will have to compensate.
8052 * There is no adjustment for UTF-8 targets, as the number of bytes per
8053 * character varies. OPs will have to test both that the count is less
8054 * than the max permissible (using <hardcount> to keep track), and that we
8055 * are still within the bounds of the string (using <loceol>. A few OPs
8056 * match a single byte no matter what the encoding. They can omit the max
8057 * test if, for the UTF-8 case, they do the adjustment that was skipped
8060 * Thus, the code above sets things up for the common case; and exceptional
8061 * cases need extra work; the common case is to make sure <scan> doesn't
8062 * go past <loceol>, and for UTF-8 to also use <hardcount> to make sure the
8063 * count doesn't exceed the maximum permissible */
8068 while (scan < loceol && hardcount < max && *scan != '\n') {
8069 scan += UTF8SKIP(scan);
8073 while (scan < loceol && *scan != '\n')
8079 while (scan < loceol && hardcount < max) {
8080 scan += UTF8SKIP(scan);
8088 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
8089 if (utf8_target && UTF8_IS_ABOVE_LATIN1(*scan)) {
8090 _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(scan, loceol);
8094 assert(STR_LEN(p) == reginfo->is_utf8_pat ? UTF8SKIP(STRING(p)) : 1);
8098 /* Can use a simple loop if the pattern char to match on is invariant
8099 * under UTF-8, or both target and pattern aren't UTF-8. Note that we
8100 * can use UTF8_IS_INVARIANT() even if the pattern isn't UTF-8, as it's
8101 * true iff it doesn't matter if the argument is in UTF-8 or not */
8102 if (UTF8_IS_INVARIANT(c) || (! utf8_target && ! reginfo->is_utf8_pat)) {
8103 if (utf8_target && loceol - scan > max) {
8104 /* We didn't adjust <loceol> because is UTF-8, but ok to do so,
8105 * since here, to match at all, 1 char == 1 byte */
8106 loceol = scan + max;
8108 while (scan < loceol && UCHARAT(scan) == c) {
8112 else if (reginfo->is_utf8_pat) {
8114 STRLEN scan_char_len;
8116 /* When both target and pattern are UTF-8, we have to do
8118 while (hardcount < max
8120 && (scan_char_len = UTF8SKIP(scan)) <= STR_LEN(p)
8121 && memEQ(scan, STRING(p), scan_char_len))
8123 scan += scan_char_len;
8127 else if (! UTF8_IS_ABOVE_LATIN1(c)) {
8129 /* Target isn't utf8; convert the character in the UTF-8
8130 * pattern to non-UTF8, and do a simple loop */
8131 c = TWO_BYTE_UTF8_TO_NATIVE(c, *(STRING(p) + 1));
8132 while (scan < loceol && UCHARAT(scan) == c) {
8135 } /* else pattern char is above Latin1, can't possibly match the
8140 /* Here, the string must be utf8; pattern isn't, and <c> is
8141 * different in utf8 than not, so can't compare them directly.
8142 * Outside the loop, find the two utf8 bytes that represent c, and
8143 * then look for those in sequence in the utf8 string */
8144 U8 high = UTF8_TWO_BYTE_HI(c);
8145 U8 low = UTF8_TWO_BYTE_LO(c);
8147 while (hardcount < max
8148 && scan + 1 < loceol
8149 && UCHARAT(scan) == high
8150 && UCHARAT(scan + 1) == low)
8158 case EXACTFA_NO_TRIE: /* This node only generated for non-utf8 patterns */
8159 assert(! reginfo->is_utf8_pat);
8162 utf8_flags = FOLDEQ_UTF8_NOMIX_ASCII;
8166 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
8167 utf8_flags = FOLDEQ_LOCALE;
8170 case EXACTF: /* This node only generated for non-utf8 patterns */
8171 assert(! reginfo->is_utf8_pat);
8176 if (! utf8_target) {
8179 utf8_flags = FOLDEQ_LOCALE | FOLDEQ_S2_ALREADY_FOLDED
8180 | FOLDEQ_S2_FOLDS_SANE;
8185 utf8_flags = reginfo->is_utf8_pat ? FOLDEQ_S2_ALREADY_FOLDED : 0;
8189 U8 c1_utf8[UTF8_MAXBYTES+1], c2_utf8[UTF8_MAXBYTES+1];
8191 assert(STR_LEN(p) == reginfo->is_utf8_pat ? UTF8SKIP(STRING(p)) : 1);
8193 if (S_setup_EXACTISH_ST_c1_c2(aTHX_ p, &c1, c1_utf8, &c2, c2_utf8,
8196 if (c1 == CHRTEST_VOID) {
8197 /* Use full Unicode fold matching */
8198 char *tmpeol = reginfo->strend;
8199 STRLEN pat_len = reginfo->is_utf8_pat ? UTF8SKIP(STRING(p)) : 1;
8200 while (hardcount < max
8201 && foldEQ_utf8_flags(scan, &tmpeol, 0, utf8_target,
8202 STRING(p), NULL, pat_len,
8203 reginfo->is_utf8_pat, utf8_flags))
8206 tmpeol = reginfo->strend;
8210 else if (utf8_target) {
8212 while (scan < loceol
8214 && memEQ(scan, c1_utf8, UTF8SKIP(scan)))
8216 scan += UTF8SKIP(scan);
8221 while (scan < loceol
8223 && (memEQ(scan, c1_utf8, UTF8SKIP(scan))
8224 || memEQ(scan, c2_utf8, UTF8SKIP(scan))))
8226 scan += UTF8SKIP(scan);
8231 else if (c1 == c2) {
8232 while (scan < loceol && UCHARAT(scan) == c1) {
8237 while (scan < loceol &&
8238 (UCHARAT(scan) == c1 || UCHARAT(scan) == c2))
8247 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
8252 while (hardcount < max
8254 && reginclass(prog, p, (U8*)scan, (U8*) loceol, utf8_target))
8256 scan += UTF8SKIP(scan);
8260 while (scan < loceol && REGINCLASS(prog, p, (U8*)scan))
8265 /* The argument (FLAGS) to all the POSIX node types is the class number */
8272 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
8273 if (! utf8_target) {
8274 while (scan < loceol && to_complement ^ cBOOL(isFOO_lc(FLAGS(p),
8280 while (hardcount < max && scan < loceol
8281 && to_complement ^ cBOOL(isFOO_utf8_lc(FLAGS(p),
8284 scan += UTF8SKIP(scan);
8297 if (utf8_target && loceol - scan > max) {
8299 /* We didn't adjust <loceol> at the beginning of this routine
8300 * because is UTF-8, but it is actually ok to do so, since here, to
8301 * match, 1 char == 1 byte. */
8302 loceol = scan + max;
8304 while (scan < loceol && _generic_isCC_A((U8) *scan, FLAGS(p))) {
8317 if (! utf8_target) {
8318 while (scan < loceol && ! _generic_isCC_A((U8) *scan, FLAGS(p))) {
8324 /* The complement of something that matches only ASCII matches all
8325 * non-ASCII, plus everything in ASCII that isn't in the class. */
8326 while (hardcount < max && scan < loceol
8327 && (! isASCII_utf8(scan)
8328 || ! _generic_isCC_A((U8) *scan, FLAGS(p))))
8330 scan += UTF8SKIP(scan);
8341 if (! utf8_target) {
8342 while (scan < loceol && to_complement
8343 ^ cBOOL(_generic_isCC((U8) *scan, FLAGS(p))))
8350 classnum = (_char_class_number) FLAGS(p);
8351 if (classnum < _FIRST_NON_SWASH_CC) {
8353 /* Here, a swash is needed for above-Latin1 code points.
8354 * Process as many Latin1 code points using the built-in rules.
8355 * Go to another loop to finish processing upon encountering
8356 * the first Latin1 code point. We could do that in this loop
8357 * as well, but the other way saves having to test if the swash
8358 * has been loaded every time through the loop: extra space to
8360 while (hardcount < max && scan < loceol) {
8361 if (UTF8_IS_INVARIANT(*scan)) {
8362 if (! (to_complement ^ cBOOL(_generic_isCC((U8) *scan,
8369 else if (UTF8_IS_DOWNGRADEABLE_START(*scan)) {
8370 if (! (to_complement
8371 ^ cBOOL(_generic_isCC(TWO_BYTE_UTF8_TO_NATIVE(*scan,
8380 goto found_above_latin1;
8387 /* For these character classes, the knowledge of how to handle
8388 * every code point is compiled in to Perl via a macro. This
8389 * code is written for making the loops as tight as possible.
8390 * It could be refactored to save space instead */
8392 case _CC_ENUM_SPACE:
8393 while (hardcount < max
8395 && (to_complement ^ cBOOL(isSPACE_utf8(scan))))
8397 scan += UTF8SKIP(scan);
8401 case _CC_ENUM_BLANK:
8402 while (hardcount < max
8404 && (to_complement ^ cBOOL(isBLANK_utf8(scan))))
8406 scan += UTF8SKIP(scan);
8410 case _CC_ENUM_XDIGIT:
8411 while (hardcount < max
8413 && (to_complement ^ cBOOL(isXDIGIT_utf8(scan))))
8415 scan += UTF8SKIP(scan);
8419 case _CC_ENUM_VERTSPACE:
8420 while (hardcount < max
8422 && (to_complement ^ cBOOL(isVERTWS_utf8(scan))))
8424 scan += UTF8SKIP(scan);
8428 case _CC_ENUM_CNTRL:
8429 while (hardcount < max
8431 && (to_complement ^ cBOOL(isCNTRL_utf8(scan))))
8433 scan += UTF8SKIP(scan);
8438 Perl_croak(aTHX_ "panic: regrepeat() node %d='%s' has an unexpected character class '%d'", OP(p), PL_reg_name[OP(p)], classnum);
8444 found_above_latin1: /* Continuation of POSIXU and NPOSIXU */
8446 /* Load the swash if not already present */
8447 if (! PL_utf8_swash_ptrs[classnum]) {
8448 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
8449 PL_utf8_swash_ptrs[classnum] = _core_swash_init(
8453 PL_XPosix_ptrs[classnum], &flags);
8456 while (hardcount < max && scan < loceol
8457 && to_complement ^ cBOOL(_generic_utf8(
8460 swash_fetch(PL_utf8_swash_ptrs[classnum],
8464 scan += UTF8SKIP(scan);
8471 while (hardcount < max && scan < loceol &&
8472 (c=is_LNBREAK_utf8_safe(scan, loceol))) {
8477 /* LNBREAK can match one or two latin chars, which is ok, but we
8478 * have to use hardcount in this situation, and throw away the
8479 * adjustment to <loceol> done before the switch statement */
8480 loceol = reginfo->strend;
8481 while (scan < loceol && (c=is_LNBREAK_latin1_safe(scan, loceol))) {
8490 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
8504 /* These are all 0 width, so match right here or not at all. */
8508 Perl_croak(aTHX_ "panic: regrepeat() called with unrecognized node type %d='%s'", OP(p), PL_reg_name[OP(p)]);
8510 NOT_REACHED; /* NOTREACHED */
8517 c = scan - *startposp;
8521 GET_RE_DEBUG_FLAGS_DECL;
8523 SV * const prop = sv_newmortal();
8524 regprop(prog, prop, p, reginfo, NULL);
8525 PerlIO_printf(Perl_debug_log,
8526 "%*s %s can match %"IVdf" times out of %"IVdf"...\n",
8527 REPORT_CODE_OFF + depth*2, "", SvPVX_const(prop),(IV)c,(IV)max);
8535 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
8537 - regclass_swash - prepare the utf8 swash. Wraps the shared core version to
8538 create a copy so that changes the caller makes won't change the shared one.
8539 If <altsvp> is non-null, will return NULL in it, for back-compat.
8542 Perl_regclass_swash(pTHX_ const regexp *prog, const regnode* node, bool doinit, SV** listsvp, SV **altsvp)
8544 PERL_ARGS_ASSERT_REGCLASS_SWASH;
8550 return newSVsv(_get_regclass_nonbitmap_data(prog, node, doinit, listsvp, NULL, NULL));
8553 #endif /* !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION) */
8556 - reginclass - determine if a character falls into a character class
8558 n is the ANYOF-type regnode
8559 p is the target string
8560 p_end points to one byte beyond the end of the target string
8561 utf8_target tells whether p is in UTF-8.
8563 Returns true if matched; false otherwise.
8565 Note that this can be a synthetic start class, a combination of various
8566 nodes, so things you think might be mutually exclusive, such as locale,
8567 aren't. It can match both locale and non-locale
8572 S_reginclass(pTHX_ regexp * const prog, const regnode * const n, const U8* const p, const U8* const p_end, const bool utf8_target)
8575 const char flags = ANYOF_FLAGS(n);
8579 PERL_ARGS_ASSERT_REGINCLASS;
8581 /* If c is not already the code point, get it. Note that
8582 * UTF8_IS_INVARIANT() works even if not in UTF-8 */
8583 if (! UTF8_IS_INVARIANT(c) && utf8_target) {
8585 c = utf8n_to_uvchr(p, p_end - p, &c_len,
8586 (UTF8_ALLOW_DEFAULT & UTF8_ALLOW_ANYUV)
8587 | UTF8_ALLOW_FFFF | UTF8_CHECK_ONLY);
8588 /* see [perl #37836] for UTF8_ALLOW_ANYUV; [perl #38293] for
8589 * UTF8_ALLOW_FFFF */
8590 if (c_len == (STRLEN)-1)
8591 Perl_croak(aTHX_ "Malformed UTF-8 character (fatal)");
8592 if (c > 255 && OP(n) == ANYOFL && ! is_ANYOF_SYNTHETIC(n)) {
8593 _CHECK_AND_OUTPUT_WIDE_LOCALE_CP_MSG(c);
8597 /* If this character is potentially in the bitmap, check it */
8598 if (c < NUM_ANYOF_CODE_POINTS) {
8599 if (ANYOF_BITMAP_TEST(n, c))
8601 else if ((flags & ANYOF_MATCHES_ALL_NON_UTF8_NON_ASCII)
8607 else if (flags & ANYOF_LOCALE_FLAGS) {
8608 if ((flags & ANYOF_LOC_FOLD)
8610 && ANYOF_BITMAP_TEST(n, PL_fold_locale[c]))
8614 else if (ANYOF_POSIXL_TEST_ANY_SET(n)
8618 /* The data structure is arranged so bits 0, 2, 4, ... are set
8619 * if the class includes the Posix character class given by
8620 * bit/2; and 1, 3, 5, ... are set if the class includes the
8621 * complemented Posix class given by int(bit/2). So we loop
8622 * through the bits, each time changing whether we complement
8623 * the result or not. Suppose for the sake of illustration
8624 * that bits 0-3 mean respectively, \w, \W, \s, \S. If bit 0
8625 * is set, it means there is a match for this ANYOF node if the
8626 * character is in the class given by the expression (0 / 2 = 0
8627 * = \w). If it is in that class, isFOO_lc() will return 1,
8628 * and since 'to_complement' is 0, the result will stay TRUE,
8629 * and we exit the loop. Suppose instead that bit 0 is 0, but
8630 * bit 1 is 1. That means there is a match if the character
8631 * matches \W. We won't bother to call isFOO_lc() on bit 0,
8632 * but will on bit 1. On the second iteration 'to_complement'
8633 * will be 1, so the exclusive or will reverse things, so we
8634 * are testing for \W. On the third iteration, 'to_complement'
8635 * will be 0, and we would be testing for \s; the fourth
8636 * iteration would test for \S, etc.
8638 * Note that this code assumes that all the classes are closed
8639 * under folding. For example, if a character matches \w, then
8640 * its fold does too; and vice versa. This should be true for
8641 * any well-behaved locale for all the currently defined Posix
8642 * classes, except for :lower: and :upper:, which are handled
8643 * by the pseudo-class :cased: which matches if either of the
8644 * other two does. To get rid of this assumption, an outer
8645 * loop could be used below to iterate over both the source
8646 * character, and its fold (if different) */
8649 int to_complement = 0;
8651 while (count < ANYOF_MAX) {
8652 if (ANYOF_POSIXL_TEST(n, count)
8653 && to_complement ^ cBOOL(isFOO_lc(count/2, (U8) c)))
8666 /* If the bitmap didn't (or couldn't) match, and something outside the
8667 * bitmap could match, try that. */
8669 if (c >= NUM_ANYOF_CODE_POINTS
8670 && (flags & ANYOF_MATCHES_ALL_ABOVE_BITMAP))
8672 match = TRUE; /* Everything above the bitmap matches */
8674 else if ((flags & ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES)
8675 || (utf8_target && (flags & ANYOF_HAS_UTF8_NONBITMAP_MATCHES))
8676 || ((flags & ANYOF_LOC_FOLD)
8677 && IN_UTF8_CTYPE_LOCALE
8678 && ARG(n) != ANYOF_ONLY_HAS_BITMAP))
8680 SV* only_utf8_locale = NULL;
8681 SV * const sw = _get_regclass_nonbitmap_data(prog, n, TRUE, 0,
8682 &only_utf8_locale, NULL);
8688 } else { /* Convert to utf8 */
8689 utf8_p = utf8_buffer;
8690 append_utf8_from_native_byte(*p, &utf8_p);
8691 utf8_p = utf8_buffer;
8694 if (swash_fetch(sw, utf8_p, TRUE)) {
8698 if (! match && only_utf8_locale && IN_UTF8_CTYPE_LOCALE) {
8699 match = _invlist_contains_cp(only_utf8_locale, c);
8703 if (UNICODE_IS_SUPER(c)
8704 && (flags & ANYOF_WARN_SUPER)
8705 && ckWARN_d(WARN_NON_UNICODE))
8707 Perl_warner(aTHX_ packWARN(WARN_NON_UNICODE),
8708 "Matched non-Unicode code point 0x%04"UVXf" against Unicode property; may not be portable", c);
8712 #if ANYOF_INVERT != 1
8713 /* Depending on compiler optimization cBOOL takes time, so if don't have to
8715 # error ANYOF_INVERT needs to be set to 1, or guarded with cBOOL below,
8718 /* The xor complements the return if to invert: 1^1 = 0, 1^0 = 1 */
8719 return (flags & ANYOF_INVERT) ^ match;
8723 S_reghop3(U8 *s, SSize_t off, const U8* lim)
8725 /* return the position 'off' UTF-8 characters away from 's', forward if
8726 * 'off' >= 0, backwards if negative. But don't go outside of position
8727 * 'lim', which better be < s if off < 0 */
8729 PERL_ARGS_ASSERT_REGHOP3;
8732 while (off-- && s < lim) {
8733 /* XXX could check well-formedness here */
8738 while (off++ && s > lim) {
8740 if (UTF8_IS_CONTINUED(*s)) {
8741 while (s > lim && UTF8_IS_CONTINUATION(*s))
8744 /* XXX could check well-formedness here */
8751 S_reghop4(U8 *s, SSize_t off, const U8* llim, const U8* rlim)
8753 PERL_ARGS_ASSERT_REGHOP4;
8756 while (off-- && s < rlim) {
8757 /* XXX could check well-formedness here */
8762 while (off++ && s > llim) {
8764 if (UTF8_IS_CONTINUED(*s)) {
8765 while (s > llim && UTF8_IS_CONTINUATION(*s))
8768 /* XXX could check well-formedness here */
8774 /* like reghop3, but returns NULL on overrun, rather than returning last
8778 S_reghopmaybe3(U8* s, SSize_t off, const U8* lim)
8780 PERL_ARGS_ASSERT_REGHOPMAYBE3;
8783 while (off-- && s < lim) {
8784 /* XXX could check well-formedness here */
8791 while (off++ && s > lim) {
8793 if (UTF8_IS_CONTINUED(*s)) {
8794 while (s > lim && UTF8_IS_CONTINUATION(*s))
8797 /* XXX could check well-formedness here */
8806 /* when executing a regex that may have (?{}), extra stuff needs setting
8807 up that will be visible to the called code, even before the current
8808 match has finished. In particular:
8810 * $_ is localised to the SV currently being matched;
8811 * pos($_) is created if necessary, ready to be updated on each call-out
8813 * a fake PMOP is created that can be set to PL_curpm (normally PL_curpm
8814 isn't set until the current pattern is successfully finished), so that
8815 $1 etc of the match-so-far can be seen;
8816 * save the old values of subbeg etc of the current regex, and set then
8817 to the current string (again, this is normally only done at the end
8822 S_setup_eval_state(pTHX_ regmatch_info *const reginfo)
8825 regexp *const rex = ReANY(reginfo->prog);
8826 regmatch_info_aux_eval *eval_state = reginfo->info_aux_eval;
8828 eval_state->rex = rex;
8831 /* Make $_ available to executed code. */
8832 if (reginfo->sv != DEFSV) {
8834 DEFSV_set(reginfo->sv);
8837 if (!(mg = mg_find_mglob(reginfo->sv))) {
8838 /* prepare for quick setting of pos */
8839 mg = sv_magicext_mglob(reginfo->sv);
8842 eval_state->pos_magic = mg;
8843 eval_state->pos = mg->mg_len;
8844 eval_state->pos_flags = mg->mg_flags;
8847 eval_state->pos_magic = NULL;
8849 if (!PL_reg_curpm) {
8850 /* PL_reg_curpm is a fake PMOP that we can attach the current
8851 * regex to and point PL_curpm at, so that $1 et al are visible
8852 * within a /(?{})/. It's just allocated once per interpreter the
8853 * first time its needed */
8854 Newxz(PL_reg_curpm, 1, PMOP);
8857 SV* const repointer = &PL_sv_undef;
8858 /* this regexp is also owned by the new PL_reg_curpm, which
8859 will try to free it. */
8860 av_push(PL_regex_padav, repointer);
8861 PL_reg_curpm->op_pmoffset = av_tindex(PL_regex_padav);
8862 PL_regex_pad = AvARRAY(PL_regex_padav);
8866 SET_reg_curpm(reginfo->prog);
8867 eval_state->curpm = PL_curpm;
8868 PL_curpm = PL_reg_curpm;
8869 if (RXp_MATCH_COPIED(rex)) {
8870 /* Here is a serious problem: we cannot rewrite subbeg,
8871 since it may be needed if this match fails. Thus
8872 $` inside (?{}) could fail... */
8873 eval_state->subbeg = rex->subbeg;
8874 eval_state->sublen = rex->sublen;
8875 eval_state->suboffset = rex->suboffset;
8876 eval_state->subcoffset = rex->subcoffset;
8878 eval_state->saved_copy = rex->saved_copy;
8880 RXp_MATCH_COPIED_off(rex);
8883 eval_state->subbeg = NULL;
8884 rex->subbeg = (char *)reginfo->strbeg;
8886 rex->subcoffset = 0;
8887 rex->sublen = reginfo->strend - reginfo->strbeg;
8891 /* destructor to clear up regmatch_info_aux and regmatch_info_aux_eval */
8894 S_cleanup_regmatch_info_aux(pTHX_ void *arg)
8896 regmatch_info_aux *aux = (regmatch_info_aux *) arg;
8897 regmatch_info_aux_eval *eval_state = aux->info_aux_eval;
8900 Safefree(aux->poscache);
8904 /* undo the effects of S_setup_eval_state() */
8906 if (eval_state->subbeg) {
8907 regexp * const rex = eval_state->rex;
8908 rex->subbeg = eval_state->subbeg;
8909 rex->sublen = eval_state->sublen;
8910 rex->suboffset = eval_state->suboffset;
8911 rex->subcoffset = eval_state->subcoffset;
8913 rex->saved_copy = eval_state->saved_copy;
8915 RXp_MATCH_COPIED_on(rex);
8917 if (eval_state->pos_magic)
8919 eval_state->pos_magic->mg_len = eval_state->pos;
8920 eval_state->pos_magic->mg_flags =
8921 (eval_state->pos_magic->mg_flags & ~MGf_BYTES)
8922 | (eval_state->pos_flags & MGf_BYTES);
8925 PL_curpm = eval_state->curpm;
8928 PL_regmatch_state = aux->old_regmatch_state;
8929 PL_regmatch_slab = aux->old_regmatch_slab;
8931 /* free all slabs above current one - this must be the last action
8932 * of this function, as aux and eval_state are allocated within
8933 * slabs and may be freed here */
8935 s = PL_regmatch_slab->next;
8937 PL_regmatch_slab->next = NULL;
8939 regmatch_slab * const osl = s;
8948 S_to_utf8_substr(pTHX_ regexp *prog)
8950 /* Converts substr fields in prog from bytes to UTF-8, calling fbm_compile
8951 * on the converted value */
8955 PERL_ARGS_ASSERT_TO_UTF8_SUBSTR;
8958 if (prog->substrs->data[i].substr
8959 && !prog->substrs->data[i].utf8_substr) {
8960 SV* const sv = newSVsv(prog->substrs->data[i].substr);
8961 prog->substrs->data[i].utf8_substr = sv;
8962 sv_utf8_upgrade(sv);
8963 if (SvVALID(prog->substrs->data[i].substr)) {
8964 if (SvTAIL(prog->substrs->data[i].substr)) {
8965 /* Trim the trailing \n that fbm_compile added last
8967 SvCUR_set(sv, SvCUR(sv) - 1);
8968 /* Whilst this makes the SV technically "invalid" (as its
8969 buffer is no longer followed by "\0") when fbm_compile()
8970 adds the "\n" back, a "\0" is restored. */
8971 fbm_compile(sv, FBMcf_TAIL);
8975 if (prog->substrs->data[i].substr == prog->check_substr)
8976 prog->check_utf8 = sv;
8982 S_to_byte_substr(pTHX_ regexp *prog)
8984 /* Converts substr fields in prog from UTF-8 to bytes, calling fbm_compile
8985 * on the converted value; returns FALSE if can't be converted. */
8989 PERL_ARGS_ASSERT_TO_BYTE_SUBSTR;
8992 if (prog->substrs->data[i].utf8_substr
8993 && !prog->substrs->data[i].substr) {
8994 SV* sv = newSVsv(prog->substrs->data[i].utf8_substr);
8995 if (! sv_utf8_downgrade(sv, TRUE)) {
8998 if (SvVALID(prog->substrs->data[i].utf8_substr)) {
8999 if (SvTAIL(prog->substrs->data[i].utf8_substr)) {
9000 /* Trim the trailing \n that fbm_compile added last
9002 SvCUR_set(sv, SvCUR(sv) - 1);
9003 fbm_compile(sv, FBMcf_TAIL);
9007 prog->substrs->data[i].substr = sv;
9008 if (prog->substrs->data[i].utf8_substr == prog->check_utf8)
9009 prog->check_substr = sv;
9017 * ex: set ts=8 sts=4 sw=4 et:
https://perl5.git.perl.org / perl5.git / blob