1 /* regexec.c 2 */ 3 4 /* 5 * "One Ring to rule them all, One Ring to find them..." 6 */ 7 8 /* This file contains functions for executing a regular expression. See 9 * also regcomp.c which funnily enough, contains functions for compiling 10 * a regular expression. 11 * 12 * This file is also copied at build time to ext/re/re_exec.c, where 13 * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT. 14 * This causes the main functions to be compiled under new names and with 15 * debugging support added, which makes "use re 'debug'" work. 16 17 */ 18 19 /* NOTE: this is derived from Henry Spencer's regexp code, and should not 20 * confused with the original package (see point 3 below). Thanks, Henry! 21 */ 22 23 /* Additional note: this code is very heavily munged from Henry's version 24 * in places. In some spots I've traded clarity for efficiency, so don't 25 * blame Henry for some of the lack of readability. 26 */ 27 28 /* The names of the functions have been changed from regcomp and 29 * regexec to pregcomp and pregexec in order to avoid conflicts 30 * with the POSIX routines of the same names. 31 */ 32 33 #ifdef PERL_EXT_RE_BUILD 34 /* need to replace pregcomp et al, so enable that */ 35 # ifndef PERL_IN_XSUB_RE 36 # define PERL_IN_XSUB_RE 37 # endif 38 /* need access to debugger hooks */ 39 # if defined(PERL_EXT_RE_DEBUG) && !defined(DEBUGGING) 40 # define DEBUGGING 41 # endif 42 #endif 43 44 #ifdef PERL_IN_XSUB_RE 45 /* We *really* need to overwrite these symbols: */ 46 # define Perl_regexec_flags my_regexec 47 # define Perl_regdump my_regdump 48 # define Perl_regprop my_regprop 49 # define Perl_re_intuit_start my_re_intuit_start 50 /* *These* symbols are masked to allow static link. */ 51 # define Perl_pregexec my_pregexec 52 # define Perl_reginitcolors my_reginitcolors 53 # define Perl_regclass_swash my_regclass_swash 54 55 # define PERL_NO_GET_CONTEXT 56 #endif 57 58 /* 59 * pregcomp and pregexec -- regsub and regerror are not used in perl 60 * 61 * Copyright (c) 1986 by University of Toronto. 62 * Written by Henry Spencer. Not derived from licensed software. 63 * 64 * Permission is granted to anyone to use this software for any 65 * purpose on any computer system, and to redistribute it freely, 66 * subject to the following restrictions: 67 * 68 * 1. The author is not responsible for the consequences of use of 69 * this software, no matter how awful, even if they arise 70 * from defects in it. 71 * 72 * 2. The origin of this software must not be misrepresented, either 73 * by explicit claim or by omission. 74 * 75 * 3. Altered versions must be plainly marked as such, and must not 76 * be misrepresented as being the original software. 77 * 78 **** Alterations to Henry's code are... 79 **** 80 **** Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 81 **** 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others 82 **** 83 **** You may distribute under the terms of either the GNU General Public 84 **** License or the Artistic License, as specified in the README file. 85 * 86 * Beware that some of this code is subtly aware of the way operator 87 * precedence is structured in regular expressions. Serious changes in 88 * regular-expression syntax might require a total rethink. 89 */ 90 #include "EXTERN.h" 91 #define PERL_IN_REGEXEC_C 92 #include "perl.h" 93 94 #include "regcomp.h" 95 96 #define RF_tainted 1 /* tainted information used? */ 97 #define RF_warned 2 /* warned about big count? */ 98 #define RF_evaled 4 /* Did an EVAL with setting? */ 99 #define RF_utf8 8 /* String contains multibyte chars? */ 100 101 #define UTF ((PL_reg_flags & RF_utf8) != 0) 102 103 #define RS_init 1 /* eval environment created */ 104 #define RS_set 2 /* replsv value is set */ 105 106 #ifndef STATIC 107 #define STATIC static 108 #endif 109 110 #define REGINCLASS(p,c) (ANYOF_FLAGS(p) ? reginclass(p,c,0,0) : ANYOF_BITMAP_TEST(p,*(c))) 111 112 /* 113 * Forwards. 114 */ 115 116 #define CHR_SVLEN(sv) (do_utf8 ? sv_len_utf8(sv) : SvCUR(sv)) 117 #define CHR_DIST(a,b) (PL_reg_match_utf8 ? utf8_distance(a,b) : a - b) 118 119 #define reghop_c(pos,off) ((char*)reghop((U8*)pos, off)) 120 #define reghopmaybe_c(pos,off) ((char*)reghopmaybe((U8*)pos, off)) 121 #define HOP(pos,off) (PL_reg_match_utf8 ? reghop((U8*)pos, off) : (U8*)(pos + off)) 122 #define HOPMAYBE(pos,off) (PL_reg_match_utf8 ? reghopmaybe((U8*)pos, off) : (U8*)(pos + off)) 123 #define HOPc(pos,off) ((char*)HOP(pos,off)) 124 #define HOPMAYBEc(pos,off) ((char*)HOPMAYBE(pos,off)) 125 126 #define HOPBACK(pos, off) ( \ 127 (PL_reg_match_utf8) \ 128 ? reghopmaybe((U8*)pos, -off) \ 129 : (pos - off >= PL_bostr) \ 130 ? (U8*)(pos - off) \ 131 : (U8*)NULL \ 132 ) 133 #define HOPBACKc(pos, off) (char*)HOPBACK(pos, off) 134 135 #define reghop3_c(pos,off,lim) ((char*)reghop3((U8*)pos, off, (U8*)lim)) 136 #define reghopmaybe3_c(pos,off,lim) ((char*)reghopmaybe3((U8*)pos, off, (U8*)lim)) 137 #define HOP3(pos,off,lim) (PL_reg_match_utf8 ? reghop3((U8*)pos, off, (U8*)lim) : (U8*)(pos + off)) 138 #define HOPMAYBE3(pos,off,lim) (PL_reg_match_utf8 ? reghopmaybe3((U8*)pos, off, (U8*)lim) : (U8*)(pos + off)) 139 #define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim)) 140 #define HOPMAYBE3c(pos,off,lim) ((char*)HOPMAYBE3(pos,off,lim)) 141 142 #define LOAD_UTF8_CHARCLASS(class,str) STMT_START { \ 143 if (!CAT2(PL_utf8_,class)) { bool ok; ENTER; save_re_context(); ok=CAT2(is_utf8_,class)((const U8*)str); assert(ok); LEAVE; } } STMT_END 144 #define LOAD_UTF8_CHARCLASS_ALNUM() LOAD_UTF8_CHARCLASS(alnum,"a") 145 #define LOAD_UTF8_CHARCLASS_DIGIT() LOAD_UTF8_CHARCLASS(digit,"0") 146 #define LOAD_UTF8_CHARCLASS_SPACE() LOAD_UTF8_CHARCLASS(space," ") 147 #define LOAD_UTF8_CHARCLASS_MARK() LOAD_UTF8_CHARCLASS(mark, "\xcd\x86") 148 149 /* for use after a quantifier and before an EXACT-like node -- japhy */ 150 #define JUMPABLE(rn) ( \ 151 OP(rn) == OPEN || OP(rn) == CLOSE || OP(rn) == EVAL || \ 152 OP(rn) == SUSPEND || OP(rn) == IFMATCH || \ 153 OP(rn) == PLUS || OP(rn) == MINMOD || \ 154 (PL_regkind[(U8)OP(rn)] == CURLY && ARG1(rn) > 0) \ 155 ) 156 157 #define HAS_TEXT(rn) ( \ 158 PL_regkind[(U8)OP(rn)] == EXACT || PL_regkind[(U8)OP(rn)] == REF \ 159 ) 160 161 /* 162 Search for mandatory following text node; for lookahead, the text must 163 follow but for lookbehind (rn->flags != 0) we skip to the next step. 164 */ 165 #define FIND_NEXT_IMPT(rn) STMT_START { \ 166 while (JUMPABLE(rn)) \ 167 if (OP(rn) == SUSPEND || PL_regkind[(U8)OP(rn)] == CURLY) \ 168 rn = NEXTOPER(NEXTOPER(rn)); \ 169 else if (OP(rn) == PLUS) \ 170 rn = NEXTOPER(rn); \ 171 else if (OP(rn) == IFMATCH) \ 172 rn = (rn->flags == 0) ? NEXTOPER(NEXTOPER(rn)) : rn + ARG(rn); \ 173 else rn += NEXT_OFF(rn); \ 174 } STMT_END 175 176 static void restore_pos(pTHX_ void *arg); 177 178 STATIC CHECKPOINT 179 S_regcppush(pTHX_ I32 parenfloor) 180 1215116 { 181 1215116 const int retval = PL_savestack_ix; 182 #define REGCP_PAREN_ELEMS 4 183 1215116 const int paren_elems_to_push = (PL_regsize - parenfloor) * REGCP_PAREN_ELEMS; 184 1215116 int p; 185 186 1215116 if (paren_elems_to_push < 0) 187 ###### Perl_croak(aTHX_ "panic: paren_elems_to_push < 0"); 188 189 #define REGCP_OTHER_ELEMS 6 190 1215116 SSGROW(paren_elems_to_push + REGCP_OTHER_ELEMS); 191 1393949 for (p = PL_regsize; p > parenfloor; p--) { 192 /* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */ 193 178833 SSPUSHINT(PL_regendp[p]); 194 178833 SSPUSHINT(PL_regstartp[p]); 195 178833 SSPUSHPTR(PL_reg_start_tmp[p]); 196 178833 SSPUSHINT(p); 197 } 198 /* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */ 199 1215116 SSPUSHINT(PL_regsize); 200 1215116 SSPUSHINT(*PL_reglastparen); 201 1215116 SSPUSHINT(*PL_reglastcloseparen); 202 1215116 SSPUSHPTR(PL_reginput); 203 #define REGCP_FRAME_ELEMS 2 204 /* REGCP_FRAME_ELEMS are part of the REGCP_OTHER_ELEMS and 205 * are needed for the regexp context stack bookkeeping. */ 206 1215116 SSPUSHINT(paren_elems_to_push + REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS); 207 1215116 SSPUSHINT(SAVEt_REGCONTEXT); /* Magic cookie. */ 208 209 1215116 return retval; 210 } 211 212 /* These are needed since we do not localize EVAL nodes: */ 213 # define REGCP_SET(cp) DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, \ 214 " Setting an EVAL scope, savestack=%"IVdf"\n", \ 215 (IV)PL_savestack_ix)); cp = PL_savestack_ix 216 217 # define REGCP_UNWIND(cp) DEBUG_EXECUTE_r(cp != PL_savestack_ix ? \ 218 PerlIO_printf(Perl_debug_log, \ 219 " Clearing an EVAL scope, savestack=%"IVdf"..%"IVdf"\n", \ 220 (IV)(cp), (IV)PL_savestack_ix) : 0); regcpblow(cp) 221 222 STATIC char * 223 S_regcppop(pTHX) 224 679222 { 225 679222 I32 i; 226 679222 U32 paren = 0; 227 679222 char *input; 228 229 679222 GET_RE_DEBUG_FLAGS_DECL; 230 231 /* Pop REGCP_OTHER_ELEMS before the parentheses loop starts. */ 232 679222 i = SSPOPINT; 233 679222 assert(i == SAVEt_REGCONTEXT); /* Check that the magic cookie is there. */ 234 679222 i = SSPOPINT; /* Parentheses elements to pop. */ 235 679222 input = (char *) SSPOPPTR; 236 679222 *PL_reglastcloseparen = SSPOPINT; 237 679222 *PL_reglastparen = SSPOPINT; 238 679222 PL_regsize = SSPOPINT; 239 240 /* Now restore the parentheses context. */ 241 799840 for (i -= (REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS); 242 i > 0; i -= REGCP_PAREN_ELEMS) { 243 120618 I32 tmps; 244 120618 paren = (U32)SSPOPINT; 245 120618 PL_reg_start_tmp[paren] = (char *) SSPOPPTR; 246 120618 PL_regstartp[paren] = SSPOPINT; 247 120618 tmps = SSPOPINT; 248 120618 if (paren <= *PL_reglastparen) 249 23876 PL_regendp[paren] = tmps; 250 DEBUG_EXECUTE_r( 251 PerlIO_printf(Perl_debug_log, 252 " restoring \\%"UVuf" to %"IVdf"(%"IVdf")..%"IVdf"%s\n", 253 (UV)paren, (IV)PL_regstartp[paren], 254 (IV)(PL_reg_start_tmp[paren] - PL_bostr), 255 (IV)PL_regendp[paren], 256 (paren > *PL_reglastparen ? "(no)" : "")); 257 120618 ); 258 } 259 DEBUG_EXECUTE_r( 260 if ((I32)(*PL_reglastparen + 1) <= PL_regnpar) { 261 PerlIO_printf(Perl_debug_log, 262 " restoring \\%"IVdf"..\\%"IVdf" to undef\n", 263 (IV)(*PL_reglastparen + 1), (IV)PL_regnpar); 264 } 265 679222 ); 266 #if 1 267 /* It would seem that the similar code in regtry() 268 * already takes care of this, and in fact it is in 269 * a better location to since this code can #if 0-ed out 270 * but the code in regtry() is needed or otherwise tests 271 * requiring null fields (pat.t#187 and split.t#{13,14} 272 * (as of patchlevel 7877) will fail. Then again, 273 * this code seems to be necessary or otherwise 274 * building DynaLoader will fail: 275 * "Error: '*' not in typemap in DynaLoader.xs, line 164" 276 * --jhi */ 277 1743941 for (paren = *PL_reglastparen + 1; (I32)paren <= PL_regnpar; paren++) { 278 1064719 if ((I32)paren > PL_regsize) 279 988140 PL_regstartp[paren] = -1; 280 1064719 PL_regendp[paren] = -1; 281 } 282 #endif 283 679222 return input; 284 } 285 286 STATIC char * 287 S_regcp_set_to(pTHX_ I32 ss) 288 5544 { 289 5544 const I32 tmp = PL_savestack_ix; 290 291 5544 PL_savestack_ix = ss; 292 5544 regcppop(); 293 5544 PL_savestack_ix = tmp; 294 5544 return Nullch; 295 } 296 297 typedef struct re_cc_state 298 { 299 I32 ss; 300 regnode *node; 301 struct re_cc_state *prev; 302 CURCUR *cc; 303 regexp *re; 304 } re_cc_state; 305 306 #define regcpblow(cp) LEAVE_SCOPE(cp) /* Ignores regcppush()ed data. */ 307 308 #define TRYPAREN(paren, n, input) { \ 309 if (paren) { \ 310 if (n) { \ 311 PL_regstartp[paren] = HOPc(input, -1) - PL_bostr; \ 312 PL_regendp[paren] = input - PL_bostr; \ 313 } \ 314 else \ 315 PL_regendp[paren] = -1; \ 316 } \ 317 if (regmatch(next)) \ 318 sayYES; \ 319 if (paren && n) \ 320 PL_regendp[paren] = -1; \ 321 } 322 323 324 /* 325 * pregexec and friends 326 */ 327 328 /* 329 - pregexec - match a regexp against a string 330 */ 331 I32 332 Perl_pregexec(pTHX_ register regexp *prog, char *stringarg, register char *strend, 333 char *strbeg, I32 minend, SV *screamer, U32 nosave) 334 /* strend: pointer to null at end of string */ 335 /* strbeg: real beginning of string */ 336 /* minend: end of match must be >=minend after stringarg. */ 337 /* nosave: For optimizations. */ 338 ###### { 339 ###### return 340 regexec_flags(prog, stringarg, strend, strbeg, minend, screamer, NULL, 341 nosave ? 0 : REXEC_COPY_STR); 342 } 343 344 STATIC void 345 S_cache_re(pTHX_ regexp *prog) 346 11716568 { 347 11716568 PL_regprecomp = prog->precomp; /* Needed for FAIL. */ 348 #ifdef DEBUGGING 349 11716568 PL_regprogram = prog->program; 350 #endif 351 11716568 PL_regnpar = prog->nparens; 352 11716568 PL_regdata = prog->data; 353 11716568 PL_reg_re = prog; 354 } 355 356 /* 357 * Need to implement the following flags for reg_anch: 358 * 359 * USE_INTUIT_NOML - Useful to call re_intuit_start() first 360 * USE_INTUIT_ML 361 * INTUIT_AUTORITATIVE_NOML - Can trust a positive answer 362 * INTUIT_AUTORITATIVE_ML 363 * INTUIT_ONCE_NOML - Intuit can match in one location only. 364 * INTUIT_ONCE_ML 365 * 366 * Another flag for this function: SECOND_TIME (so that float substrs 367 * with giant delta may be not rechecked). 368 */ 369 370 /* Assumptions: if ANCH_GPOS, then strpos is anchored. XXXX Check GPOS logic */ 371 372 /* If SCREAM, then SvPVX_const(sv) should be compatible with strpos and strend. 373 Otherwise, only SvCUR(sv) is used to get strbeg. */ 374 375 /* XXXX We assume that strpos is strbeg unless sv. */ 376 377 /* XXXX Some places assume that there is a fixed substring. 378 An update may be needed if optimizer marks as "INTUITable" 379 RExen without fixed substrings. Similarly, it is assumed that 380 lengths of all the strings are no more than minlen, thus they 381 cannot come from lookahead. 382 (Or minlen should take into account lookahead.) */ 383 384 /* A failure to find a constant substring means that there is no need to make 385 an expensive call to REx engine, thus we celebrate a failure. Similarly, 386 finding a substring too deep into the string means that less calls to 387 regtry() should be needed. 388 389 REx compiler's optimizer found 4 possible hints: 390 a) Anchored substring; 391 b) Fixed substring; 392 c) Whether we are anchored (beginning-of-line or \G); 393 d) First node (of those at offset 0) which may distingush positions; 394 We use a)b)d) and multiline-part of c), and try to find a position in the 395 string which does not contradict any of them. 396 */ 397 398 /* Most of decisions we do here should have been done at compile time. 399 The nodes of the REx which we used for the search should have been 400 deleted from the finite automaton. */ 401 402 char * 403 Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, 404 char *strend, U32 flags, re_scream_pos_data *data) 405 4555374 { 406 4555374 register I32 start_shift = 0; 407 /* Should be nonnegative! */ 408 4555374 register I32 end_shift = 0; 409 4555374 register char *s; 410 4555374 register SV *check; 411 4555374 char *strbeg; 412 4555374 char *t; 413 4555374 const int do_utf8 = sv ? SvUTF8(sv) : 0; /* if no sv we have to assume bytes */ 414 4555374 I32 ml_anch; 415 4555374 register char *other_last = Nullch; /* other substr checked before this */ 416 4555374 char *check_at = Nullch; /* check substr found at this pos */ 417 4555374 const I32 multiline = prog->reganch & PMf_MULTILINE; 418 #ifdef DEBUGGING 419 4555374 char *i_strpos = strpos; 420 4555374 SV *dsv = PERL_DEBUG_PAD_ZERO(0); 421 #endif 422 423 4555374 GET_RE_DEBUG_FLAGS_DECL; 424 425 4555374 RX_MATCH_UTF8_set(prog,do_utf8); 426 427 4555374 if (prog->reganch & ROPT_UTF8) { 428 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, 429 2085 "UTF-8 regex...\n")); 430 2085 PL_reg_flags |= RF_utf8; 431 } 432 433 DEBUG_EXECUTE_r({ 434 const char *s = PL_reg_match_utf8 ? 435 sv_uni_display(dsv, sv, 60, UNI_DISPLAY_REGEX) : 436 strpos; 437 const int len = PL_reg_match_utf8 ? 438 strlen(s) : strend - strpos; 439 if (!PL_colorset) 440 reginitcolors(); 441 if (PL_reg_match_utf8) 442 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, 443 "UTF-8 target...\n")); 444 PerlIO_printf(Perl_debug_log, 445 "%sGuessing start of match, REx%s \"%s%.60s%s%s\" against \"%s%.*s%s%s\"...\n", 446 PL_colors[4], PL_colors[5], PL_colors[0], 447 prog->precomp, 448 PL_colors[1], 449 (strlen(prog->precomp) > 60 ? "..." : ""), 450 PL_colors[0], 451 (int)(len > 60 ? 60 : len), 452 s, PL_colors[1], 453 (len > 60 ? "..." : "") 454 ); 455 4555374 }); 456 457 /* CHR_DIST() would be more correct here but it makes things slow. */ 458 4555374 if (prog->minlen > strend - strpos) { 459 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, 460 93641 "String too short... [re_intuit_start]\n")); 461 ###### goto fail; 462 } 463 4461733 strbeg = (sv && SvPOK(sv)) ? strend - SvCUR(sv) : strpos; 464 4461733 PL_regeol = strend; 465 4461733 if (do_utf8) { 466 4977 if (!prog->check_utf8 && prog->check_substr) 467 89 to_utf8_substr(prog); 468 4977 check = prog->check_utf8; 469 } else { 470 4456756 if (!prog->check_substr && prog->check_utf8) 471 19 to_byte_substr(prog); 472 4456756 check = prog->check_substr; 473 } 474 4461733 if (check == &PL_sv_undef) { 475 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, 476 2 "Non-utf string cannot match utf check string\n")); 477 ###### goto fail; 478 } 479 4461731 if (prog->reganch & ROPT_ANCH) { /* Match at beg-of-str or after \n */ 480 2624230 ml_anch = !( (prog->reganch & ROPT_ANCH_SINGLE) 481 || ( (prog->reganch & ROPT_ANCH_BOL) 482 && !multiline ) ); /* Check after \n? */ 483 484 2624230 if (!ml_anch) { 485 2551524 if ( !(prog->reganch & (ROPT_ANCH_GPOS /* Checked by the caller */ 486 | ROPT_IMPLICIT)) /* not a real BOL */ 487 /* SvCUR is not set on references: SvRV and SvPVX_const overlap */ 488 && sv && !SvROK(sv) 489 && (strpos != strbeg)) { 490 14 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not at start...\n")); 491 ###### goto fail; 492 } 493 2551510 if (prog->check_offset_min == prog->check_offset_max && 494 !(prog->reganch & ROPT_CANY_SEEN)) { 495 /* Substring at constant offset from beg-of-str... */ 496 1283680 I32 slen; 497 498 1283680 s = HOP3c(strpos, prog->check_offset_min, strend); 499 1283680 if (SvTAIL(check)) { 500 17998 slen = SvCUR(check); /* >= 1 */ 501 502 17998 if ( strend - s > slen || strend - s < slen - 1 503 || (strend - s == slen && strend[-1] != '\n')) { 504 3142 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String too long...\n")); 505 ###### goto fail_finish; 506 } 507 /* Now should match s[0..slen-2] */ 508 14856 slen--; 509 14856 if (slen && (*SvPVX_const(check) != *s 510 || (slen > 1 511 && memNE(SvPVX_const(check), s, slen)))) { 512 report_neq: 513 1078513 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String not equal...\n")); 514 ###### goto fail_finish; 515 } 516 } 517 1265682 else if (*SvPVX_const(check) != *s 518 || ((slen = SvCUR(check)) > 1 519 && memNE(SvPVX_const(check), s, slen))) 520 1340536 goto report_neq; 521 1340536 goto success_at_start; 522 } 523 } 524 /* Match is anchored, but substr is not anchored wrt beg-of-str. */ 525 1340536 s = strpos; 526 1340536 start_shift = prog->check_offset_min; /* okay to underestimate on CC */ 527 1340536 end_shift = prog->minlen - start_shift - 528 CHR_SVLEN(check) + (SvTAIL(check) != 0); 529 1340536 if (!ml_anch) { 530 1267830 const I32 end = prog->check_offset_max + CHR_SVLEN(check) 531 1267830 - (SvTAIL(check) != 0); 532 1267830 const I32 eshift = CHR_DIST((U8*)strend, (U8*)s) - end; 533 534 1267830 if (end_shift < eshift) 535 120985 end_shift = eshift; 536 } 537 } 538 else { /* Can match at random position */ 539 1837501 ml_anch = 0; 540 1837501 s = strpos; 541 1837501 start_shift = prog->check_offset_min; /* okay to underestimate on CC */ 542 /* Should be nonnegative! */ 543 1837501 end_shift = prog->minlen - start_shift - 544 CHR_SVLEN(check) + (SvTAIL(check) != 0); 545 } 546 547 #ifdef DEBUGGING /* 7/99: reports of failure (with the older version) */ 548 3178037 if (end_shift < 0) 549 ###### Perl_croak(aTHX_ "panic: end_shift"); 550 #endif 551 552 restart: 553 /* Find a possible match in the region s..strend by looking for 554 the "check" substring in the region corrected by start/end_shift. */ 555 3193413 if (flags & REXEC_SCREAM) { 556 17 I32 p = -1; /* Internal iterator of scream. */ 557 17 I32 * const pp = data ? data->scream_pos : &p; 558 559 17 if (PL_screamfirst[BmRARE(check)] >= 0 560 || ( BmRARE(check) == '\n' 561 && (BmPREVIOUS(check) == SvCUR(check) - 1) 562 && SvTAIL(check) )) 563 17 s = screaminstr(sv, check, 564 start_shift + (s - strbeg), end_shift, pp, 0); 565 else 566 17 goto fail_finish; 567 /* we may be pointing at the wrong string */ 568 17 if (s && RX_MATCH_COPIED(prog)) 569 4 s = strbeg + (s - SvPVX_const(sv)); 570 17 if (data) 571 2 *data->scream_olds = s; 572 } 573 3193396 else if (prog->reganch & ROPT_CANY_SEEN) 574 3735 s = fbm_instr((U8*)(s + start_shift), 575 (U8*)(strend - end_shift), 576 check, multiline ? FBMrf_MULTILINE : 0); 577 else 578 3189661 s = fbm_instr(HOP3(s, start_shift, strend), 579 HOP3(strend, -end_shift, strbeg), 580 check, multiline ? FBMrf_MULTILINE : 0); 581 582 /* Update the count-of-usability, remove useless subpatterns, 583 unshift s. */ 584 585 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s %s substr \"%s%.*s%s\"%s%s", 586 (s ? "Found" : "Did not find"), 587 (check == (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) ? "anchored" : "floating"), 588 PL_colors[0], 589 (int)(SvCUR(check) - (SvTAIL(check)!=0)), 590 SvPVX_const(check), 591 PL_colors[1], (SvTAIL(check) ? "$" : ""), 592 3193413 (s ? " at offset " : "...\n") ) ); 593 594 3193413 if (!s) 595 1255756 goto fail_finish; 596 597 1937657 check_at = s; 598 599 /* Finish the diagnostic message */ 600 1937657 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(s - i_strpos)) ); 601 602 /* Got a candidate. Check MBOL anchoring, and the *other* substr. 603 Start with the other substr. 604 XXXX no SCREAM optimization yet - and a very coarse implementation 605 XXXX /ttx+/ results in anchored="ttx", floating="x". floating will 606 *always* match. Probably should be marked during compile... 607 Probably it is right to do no SCREAM here... 608 */ 609 610 1937657 if (do_utf8 ? (prog->float_utf8 && prog->anchored_utf8) : (prog->float_substr && prog->anchored_substr)) { 611 /* Take into account the "other" substring. */ 612 /* XXXX May be hopelessly wrong for UTF... */ 613 435932 if (!other_last) 614 435406 other_last = strpos; 615 435932 if (check == (do_utf8 ? prog->float_utf8 : prog->float_substr)) { 616 do_other_anchored: 617 { 618 190642 char *last = HOP3c(s, -start_shift, strbeg), *last1, *last2; 619 190642 char *s1 = s; 620 190642 SV* must; 621 622 190642 t = s - prog->check_offset_max; 623 190642 if (s - strpos > prog->check_offset_max /* signed-corrected t > strpos */ 624 && (!do_utf8 625 || ((t = reghopmaybe3_c(s, -(prog->check_offset_max), strpos)) 626 && t > strpos))) 627 /* EMPTY */; 628 else 629 190571 t = strpos; 630 190642 t = HOP3c(t, prog->anchored_offset, strend); 631 190642 if (t < other_last) /* These positions already checked */ 632 452 t = other_last; 633 190642 last2 = last1 = HOP3c(strend, -prog->minlen, strbeg); 634 190642 if (last < last1) 635 188328 last1 = last; 636 /* XXXX It is not documented what units *_offsets are in. Assume bytes. */ 637 /* On end-of-str: see comment below. */ 638 190642 must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr; 639 190642 if (must == &PL_sv_undef) { 640 1 s = (char*)NULL; 641 1 DEBUG_EXECUTE_r(must = prog->anchored_utf8); /* for debug */ 642 } 643 else 644 190641 s = fbm_instr( 645 (unsigned char*)t, 646 HOP3(HOP3(last1, prog->anchored_offset, strend) 647 + SvCUR(must), -(SvTAIL(must)!=0), strbeg), 648 must, 649 multiline ? FBMrf_MULTILINE : 0 650 ); 651 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, 652 "%s anchored substr \"%s%.*s%s\"%s", 653 (s ? "Found" : "Contradicts"), 654 PL_colors[0], 655 (int)(SvCUR(must) 656 - (SvTAIL(must)!=0)), 657 SvPVX_const(must), 658 190642 PL_colors[1], (SvTAIL(must) ? "$" : ""))); 659 190642 if (!s) { 660 1977 if (last1 >= last2) { 661 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, 662 130 ", giving up...\n")); 663 ###### goto fail_finish; 664 } 665 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, 666 ", trying floating at offset %ld...\n", 667 1847 (long)(HOP3c(s1, 1, strend) - i_strpos))); 668 1847 other_last = HOP3c(last1, prog->anchored_offset+1, strend); 669 1847 s = HOP3c(last, 1, strend); 670 1847 goto restart; 671 } 672 else { 673 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n", 674 188665 (long)(s - i_strpos))); 675 188665 t = HOP3c(s, -prog->anchored_offset, strbeg); 676 188665 other_last = HOP3c(s, 1, strend); 677 188665 s = s1; 678 188665 if (t == strpos) 679 14695 goto try_at_start; 680 245349 goto try_at_offset; 681 } 682 } 683 } 684 else { /* Take into account the floating substring. */ 685 245349 char *last, *last1; 686 245349 char *s1 = s; 687 245349 SV* must; 688 689 245349 t = HOP3c(s, -start_shift, strbeg); 690 245349 last1 = last = 691 HOP3c(strend, -prog->minlen + prog->float_min_offset, strbeg); 692 245349 if (CHR_DIST((U8*)last, (U8*)t) > prog->float_max_offset) 693 189 last = HOP3c(t, prog->float_max_offset, strend); 694 245349 s = HOP3c(t, prog->float_min_offset, strend); 695 245349 if (s < other_last) 696 10 s = other_last; 697 /* XXXX It is not documented what units *_offsets are in. Assume bytes. */ 698 245349 must = do_utf8 ? prog->float_utf8 : prog->float_substr; 699 /* fbm_instr() takes into account exact value of end-of-str 700 if the check is SvTAIL(ed). Since false positives are OK, 701 and end-of-str is not later than strend we are OK. */ 702 245349 if (must == &PL_sv_undef) { 703 1 s = (char*)NULL; 704 1 DEBUG_EXECUTE_r(must = prog->float_utf8); /* for debug message */ 705 } 706 else 707 245348 s = fbm_instr((unsigned char*)s, 708 (unsigned char*)last + SvCUR(must) 709 - (SvTAIL(must)!=0), 710 must, multiline ? FBMrf_MULTILINE : 0); 711 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s floating substr \"%s%.*s%s\"%s", 712 (s ? "Found" : "Contradicts"), 713 PL_colors[0], 714 (int)(SvCUR(must) - (SvTAIL(must)!=0)), 715 SvPVX_const(must), 716 245349 PL_colors[1], (SvTAIL(must) ? "$" : ""))); 717 245349 if (!s) { 718 1367 if (last1 == last) { 719 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, 720 1289 ", giving up...\n")); 721 ###### goto fail_finish; 722 } 723 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, 724 ", trying anchored starting at offset %ld...\n", 725 78 (long)(s1 + 1 - i_strpos))); 726 78 other_last = last; 727 78 s = HOP3c(t, 1, strend); 728 78 goto restart; 729 } 730 else { 731 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n", 732 243982 (long)(s - i_strpos))); 733 243982 other_last = s; /* Fix this later. --Hugo */ 734 243982 s = s1; 735 243982 if (t == strpos) 736 5141 goto try_at_start; 737 1501725 goto try_at_offset; 738 } 739 } 740 } 741 742 1501725 t = s - prog->check_offset_max; 743 1501725 if (s - strpos > prog->check_offset_max /* signed-corrected t > strpos */ 744 && (!do_utf8 745 || ((t = reghopmaybe3_c(s, -prog->check_offset_max, strpos)) 746 && t > strpos))) { 747 /* Fixed substring is found far enough so that the match 748 cannot start at strpos. */ 749 try_at_offset: 750 762180 if (ml_anch && t[-1] != '\n') { 751 /* Eventually fbm_*() should handle this, but often 752 anchored_offset is not 0, so this check will not be wasted. */ 753 /* XXXX In the code below we prefer to look for "^" even in 754 presence of anchored substrings. And we search even 755 beyond the found float position. These pessimizations 756 are historical artefacts only. */ 757 find_anchor: 758 996765 while (t < strend - prog->minlen) { 759 996601 if (*t == '\n') { 760 20039 if (t < check_at - prog->check_offset_min) { 761 12972 if (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) { 762 /* Since we moved from the found position, 763 we definitely contradict the found anchored 764 substr. Due to the above check we do not 765 contradict "check" substr. 766 Thus we can arrive here only if check substr 767 is float. Redo checking for "other"=="fixed". 768 */ 769 1 strpos = t + 1; 770 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld, rescanning for anchored from offset %ld...\n", 771 1 PL_colors[0], PL_colors[1], (long)(strpos - i_strpos), (long)(strpos - i_strpos + prog->anchored_offset))); 772 ###### goto do_other_anchored; 773 } 774 /* We don't contradict the found floating substring. */ 775 /* XXXX Why not check for STCLASS? */ 776 12971 s = t + 1; 777 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld...\n", 778 12971 PL_colors[0], PL_colors[1], (long)(s - i_strpos))); 779 ###### goto set_useful; 780 } 781 /* Position contradicts check-string */ 782 /* XXXX probably better to look for check-string 783 than for "\n", so one should lower the limit for t? */ 784 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting lookup for check-string at offset %ld...\n", 785 7067 PL_colors[0], PL_colors[1], (long)(t + 1 - i_strpos))); 786 7067 other_last = strpos = s = t + 1; 787 7067 goto restart; 788 } 789 976562 t++; 790 } 791 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Did not find /%s^%s/m...\n", 792 164 PL_colors[0], PL_colors[1])); 793 ###### goto fail_finish; 794 } 795 else { 796 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Starting position does not contradict /%s^%s/m...\n", 797 744622 PL_colors[0], PL_colors[1])); 798 } 799 744622 s = t; 800 set_useful: 801 757593 ++BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr); /* hooray/5 */ 802 } 803 else { 804 /* The found string does not prohibit matching at strpos, 805 - no optimization of calling REx engine can be performed, 806 unless it was an MBOL and we are not after MBOL, 807 or a future STCLASS check will fail this. */ 808 try_at_start: 809 /* Even in this situation we may use MBOL flag if strpos is offset 810 wrt the start of the string. */ 811 1183035 if (ml_anch && sv && !SvROK(sv) /* See prev comment on SvROK */ 812 && (strpos != strbeg) && strpos[-1] != '\n' 813 /* May be due to an implicit anchor of m{.*foo} */ 814 && !(prog->reganch & ROPT_IMPLICIT)) 815 { 816 2645 t = strpos; 817 2645 goto find_anchor; 818 } 819 DEBUG_EXECUTE_r( if (ml_anch) 820 PerlIO_printf(Perl_debug_log, "Position at offset %ld does not contradict /%s^%s/m...\n", 821 (long)(strpos - i_strpos), PL_colors[0], PL_colors[1]); 822 1180390 ); 823 success_at_start: 824 1382415 if (!(prog->reganch & ROPT_NAUGHTY) /* XXXX If strpos moved? */ 825 && (do_utf8 ? ( 826 prog->check_utf8 /* Could be deleted already */ 827 && --BmUSEFUL(prog->check_utf8) < 0 828 && (prog->check_utf8 == prog->float_utf8) 829 ) : ( 830 prog->check_substr /* Could be deleted already */ 831 && --BmUSEFUL(prog->check_substr) < 0 832 && (prog->check_substr == prog->float_substr) 833 ))) 834 { 835 /* If flags & SOMETHING - do not do it many times on the same match */ 836 600 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "... Disabling check substring...\n")); 837 600 SvREFCNT_dec(do_utf8 ? prog->check_utf8 : prog->check_substr); 838 600 if (do_utf8 ? prog->check_substr : prog->check_utf8) 839 5 SvREFCNT_dec(do_utf8 ? prog->check_substr : prog->check_utf8); 840 600 prog->check_substr = prog->check_utf8 = Nullsv; /* disable */ 841 600 prog->float_substr = prog->float_utf8 = Nullsv; /* clear */ 842 600 check = Nullsv; /* abort */ 843 600 s = strpos; 844 /* XXXX This is a remnant of the old implementation. It 845 looks wasteful, since now INTUIT can use many 846 other heuristics. */ 847 600 prog->reganch &= ~RE_USE_INTUIT; 848 } 849 else 850 1381815 s = strpos; 851 } 852 853 /* Last resort... */ 854 /* XXXX BmUSEFUL already changed, maybe multiple change is meaningful... */ 855 2140008 if (prog->regstclass) { 856 /* minlen == 0 is possible if regstclass is \b or \B, 857 and the fixed substr is ''$. 858 Since minlen is already taken into account, s+1 is before strend; 859 accidentally, minlen >= 1 guaranties no false positives at s + 1 860 even for \b or \B. But (minlen? 1 : 0) below assumes that 861 regstclass does not come from lookahead... */ 862 /* If regstclass takes bytelength more than 1: If charlength==1, OK. 863 This leaves EXACTF only, which is dealt with in find_byclass(). */ 864 594787 const U8* str = (U8*)STRING(prog->regstclass); 865 594787 const int cl_l = (PL_regkind[(U8)OP(prog->regstclass)] == EXACT 866 ? CHR_DIST(str+STR_LEN(prog->regstclass), str) 867 594787 : 1); 868 594787 const char * const endpos = (prog->anchored_substr || prog->anchored_utf8 || ml_anch) 869 ? HOP3c(s, (prog->minlen ? cl_l : 0), strend) 870 : (prog->float_substr || prog->float_utf8 871 ? HOP3c(HOP3c(check_at, -start_shift, strbeg), 872 cl_l, strend) 873 594787 : strend); 874 875 594787 t = s; 876 594787 cache_re(prog); 877 594787 s = find_byclass(prog, prog->regstclass, s, endpos, 1); 878 594787 if (!s) { 879 #ifdef DEBUGGING 880 33286 const char *what = 0; 881 #endif 882 33286 if (endpos == strend) { 883 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, 884 9478 "Could not match STCLASS...\n") ); 885 ###### goto fail; 886 } 887 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, 888 23808 "This position contradicts STCLASS...\n") ); 889 23808 if ((prog->reganch & ROPT_ANCH) && !ml_anch) 890 5269 goto fail; 891 /* Contradict one of substrings */ 892 18539 if (prog->anchored_substr || prog->anchored_utf8) { 893 862 if ((do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) == check) { 894 797 DEBUG_EXECUTE_r( what = "anchored" ); 895 hop_and_restart: 896 7636 s = HOP3c(t, 1, strend); 897 7636 if (s + start_shift + end_shift > strend) { 898 /* XXXX Should be taken into account earlier? */ 899 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, 900 1252 "Could not match STCLASS...\n") ); 901 ###### goto fail; 902 } 903 6384 if (!check) 904 ###### goto giveup; 905 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, 906 "Looking for %s substr starting at offset %ld...\n", 907 6384 what, (long)(s + start_shift - i_strpos)) ); 908 ###### goto restart; 909 } 910 /* Have both, check_string is floating */ 911 65 if (t + start_shift >= check_at) /* Contradicts floating=check */ 912 7 goto retry_floating_check; 913 /* Recheck anchored substring, but not floating... */ 914 58 s = check_at; 915 58 if (!check) 916 ###### goto giveup; 917 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, 918 "Looking for anchored substr starting at offset %ld...\n", 919 58 (long)(other_last - i_strpos)) ); 920 ###### goto do_other_anchored; 921 } 922 /* Another way we could have checked stclass at the 923 current position only: */ 924 17677 if (ml_anch) { 925 10845 s = t = t + 1; 926 10845 if (!check) 927 2 goto giveup; 928 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, 929 "Looking for /%s^%s/m starting at offset %ld...\n", 930 10843 PL_colors[0], PL_colors[1], (long)(t - i_strpos)) ); 931 ###### goto try_at_offset; 932 } 933 6832 if (!(do_utf8 ? prog->float_utf8 : prog->float_substr)) /* Could have been deleted */ 934 ###### goto fail; 935 /* Check is floating subtring. */ 936 retry_floating_check: 937 6839 t = check_at - start_shift; 938 6839 DEBUG_EXECUTE_r( what = "floating" ); 939 ###### goto hop_and_restart; 940 } 941 561501 if (t != s) { 942 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, 943 "By STCLASS: moving %ld --> %ld\n", 944 (long)(t - i_strpos), (long)(s - i_strpos)) 945 151445 ); 946 } 947 else { 948 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, 949 "Does not contradict STCLASS...\n"); 950 410056 ); 951 } 952 } 953 giveup: 954 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s%s:%s match at offset %ld\n", 955 PL_colors[4], (check ? "Guessed" : "Giving up"), 956 2106724 PL_colors[5], (long)(s - i_strpos)) ); 957 2106724 return s; 958 959 fail_finish: /* Substring not found */ 960 2338994 if (prog->check_substr || prog->check_utf8) /* could be removed already */ 961 2338994 BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr) += 5; /* hooray */ 962 fail: 963 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n", 964 2448650 PL_colors[4], PL_colors[5])); 965 2448650 return Nullch; 966 } 967 968 /* We know what class REx starts with. Try to find this position... */ 969 STATIC char * 970 S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, const char *strend, I32 norun) 971 5597636 { 972 dVAR; 973 5597636 const I32 doevery = (prog->reganch & ROPT_SKIP) == 0; 974 5597636 char *m; 975 5597636 STRLEN ln; 976 5597636 STRLEN lnc; 977 5597636 register STRLEN uskip; 978 5597636 unsigned int c1; 979 5597636 unsigned int c2; 980 5597636 char *e; 981 5597636 register I32 tmp = 1; /* Scratch variable? */ 982 5597636 register const bool do_utf8 = PL_reg_match_utf8; 983 984 /* We know what class it must start with. */ 985 5597636 switch (OP(c)) { 986 case ANYOF: 987 3342502 if (do_utf8) { 988 1188325 while (s + (uskip = UTF8SKIP(s)) <= strend) { 989 1188136 if ((ANYOF_FLAGS(c) & ANYOF_UNICODE) || 990 !UTF8_IS_INVARIANT((U8)s[0]) ? 991 reginclass(c, (U8*)s, 0, do_utf8) : 992 REGINCLASS(c, (U8*)s)) { 993 4142 if (tmp && (norun || regtry(prog, s))) 994 4 goto got_it; 995 else 996 4 tmp = doevery; 997 } 998 else 999 1183994 tmp = 1; 1000 1183998 s += uskip; 1001 } 1002 } 1003 else { 1004 9410736 while (s < strend) { 1005 7602014 STRLEN skip = 1; 1006 1007 7602014 if (REGINCLASS(c, (U8*)s) || 1008 (ANYOF_FOLD_SHARP_S(c, s, strend) && 1009 /* The assignment of 2 is intentional: 1010 * for the folded sharp s, the skip is 2. */ 1011 (skip = SHARP_S_SKIP))) { 1012 1971618 if (tmp && (norun || regtry(prog, s))) 1013 442165 goto got_it; 1014 else 1015 442165 tmp = doevery; 1016 } 1017 else 1018 5630396 tmp = 1; 1019 6072561 s += skip; 1020 } 1021 } 1022 35 break; 1023 case CANY: 1024 35 while (s < strend) { 1025 35 if (tmp && (norun || regtry(prog, s))) 1026 ###### goto got_it; 1027 else 1028 ###### tmp = doevery; 1029 ###### s++; 1030 } 1031 25271 break; 1032 case EXACTF: 1033 25271 m = STRING(c); 1034 25271 ln = STR_LEN(c); /* length to match in octets/bytes */ 1035 25271 lnc = (I32) ln; /* length to match in characters */ 1036 25271 if (UTF) { 1037 5925 STRLEN ulen1, ulen2; 1038 5925 U8 *sm = (U8 *) m; 1039 5925 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1]; 1040 5925 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1]; 1041 1042 5925 to_utf8_lower((U8*)m, tmpbuf1, &ulen1); 1043 5925 to_utf8_upper((U8*)m, tmpbuf2, &ulen2); 1044 1045 5925 c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXBYTES_CASE, 1046 0, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY); 1047 5925 c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXBYTES_CASE, 1048 0, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY); 1049 5925 lnc = 0; 1050 18113 while (sm < ((U8 *) m + ln)) { 1051 12188 lnc++; 1052 12188 sm += UTF8SKIP(sm); 1053 } 1054 } 1055 else { 1056 19346 c1 = *(U8*)m; 1057 19346 c2 = PL_fold[c1]; 1058 } 1059 19346 goto do_exactf; 1060 case EXACTFL: 1061 1696824 m = STRING(c); 1062 1696824 ln = STR_LEN(c); 1063 1696824 lnc = (I32) ln; 1064 1696824 c1 = *(U8*)m; 1065 1696824 c2 = PL_fold_locale[c1]; 1066 do_exactf: 1067 1722095 e = HOP3c(strend, -((I32)lnc), s); 1068 1069 1722095 if (norun && e < s) 1070 ###### e = s; /* Due to minlen logic of intuit() */ 1071 1072 /* The idea in the EXACTF* cases is to first find the 1073 * first character of the EXACTF* node and then, if 1074 * necessary, case-insensitively compare the full 1075 * text of the node. The c1 and c2 are the first 1076 * characters (though in Unicode it gets a bit 1077 * more complicated because there are more cases 1078 * than just upper and lower: one needs to use 1079 * the so-called folding case for case-insensitive 1080 * matching (called "loose matching" in Unicode). 1081 * ibcmp_utf8() will do just that. */ 1082 1083 1722095 if (do_utf8) { 1084 5931 UV c, f; 1085 5931 U8 tmpbuf [UTF8_MAXBYTES+1]; 1086 5931 STRLEN len, foldlen; 1087 1088 5931 if (c1 == c2) { 1089 /* Upper and lower of 1st char are equal - 1090 * probably not a "letter". */ 1091 5894 while (s <= e) { 1092 5893 c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len, 1093 ckWARN(WARN_UTF8) ? 1094 0 : UTF8_ALLOW_ANY); 1095 5893 if ( c == c1 1096 && (ln == len || 1097 ibcmp_utf8(s, (char **)0, 0, do_utf8, 1098 m, (char **)0, ln, (bool)UTF)) 1099 && (norun || regtry(prog, s)) ) 1100 1 goto got_it; 1101 else { 1102 1 U8 foldbuf[UTF8_MAXBYTES_CASE+1]; 1103 1 uvchr_to_utf8(tmpbuf, c); 1104 1 f = to_utf8_fold(tmpbuf, foldbuf, &foldlen); 1105 1 if ( f != c 1106 && (f == c1 || f == c2) 1107 && (ln == foldlen || 1108 !ibcmp_utf8((char *) foldbuf, 1109 (char **)0, foldlen, do_utf8, 1110 m, 1111 (char **)0, ln, (bool)UTF)) 1112 && (norun || regtry(prog, s)) ) 1113 1 goto got_it; 1114 } 1115 1 s += len; 1116 } 1117 } 1118 else { 1119 47 while (s <= e) { 1120 46 c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len, 1121 ckWARN(WARN_UTF8) ? 1122 0 : UTF8_ALLOW_ANY); 1123 1124 /* Handle some of the three Greek sigmas cases. 1125 * Note that not all the possible combinations 1126 * are handled here: some of them are handled 1127 * by the standard folding rules, and some of 1128 * them (the character class or ANYOF cases) 1129 * are handled during compiletime in 1130 * regexec.c:S_regclass(). */ 1131 46 if (c == (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA || 1132 c == (UV)UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA) 1133 6 c = (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA; 1134 1135 46 if ( (c == c1 || c == c2) 1136 && (ln == len || 1137 ibcmp_utf8(s, (char **)0, 0, do_utf8, 1138 m, (char **)0, ln, (bool)UTF)) 1139 && (norun || regtry(prog, s)) ) 1140 12 goto got_it; 1141 else { 1142 12 U8 foldbuf[UTF8_MAXBYTES_CASE+1]; 1143 12 uvchr_to_utf8(tmpbuf, c); 1144 12 f = to_utf8_fold(tmpbuf, foldbuf, &foldlen); 1145 12 if ( f != c 1146 && (f == c1 || f == c2) 1147 && (ln == foldlen || 1148 !ibcmp_utf8((char *) foldbuf, 1149 (char **)0, foldlen, do_utf8, 1150 m, 1151 (char **)0, ln, (bool)UTF)) 1152 && (norun || regtry(prog, s)) ) 1153 9 goto got_it; 1154 } 1155 9 s += len; 1156 } 1157 } 1158 } 1159 else { 1160 1716164 if (c1 == c2) 1161 54779 while (s <= e) { 1162 53393 if ( *(U8*)s == c1 1163 && (ln == 1 || !(OP(c) == EXACTF 1164 ? ibcmp(s, m, ln) 1165 : ibcmp_locale(s, m, ln))) 1166 && (norun || regtry(prog, s)) ) 1167 52919 goto got_it; 1168 52919 s++; 1169 } 1170 else 1171 1769337 while (s <= e) { 1172 1753178 if ( (*(U8*)s == c1 || *(U8*)s == c2) 1173 && (ln == 1 || !(OP(c) == EXACTF 1174 ? ibcmp(s, m, ln) 1175 : ibcmp_locale(s, m, ln))) 1176 && (norun || regtry(prog, s)) ) 1177 55033 goto got_it; 1178 55033 s++; 1179 } 1180 } 1181 8 break; 1182 case BOUNDL: 1183 8 PL_reg_flags |= RF_tainted; 1184 /* FALL THROUGH */ 1185 case BOUND: 1186 21426 if (do_utf8) { 1187 11 if (s == PL_bostr) 1188 10 tmp = '\n'; 1189 else { 1190 1 U8 *r = reghop3((U8*)s, -1, (U8*)PL_bostr); 1191 1192 1 tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, 0); 1193 } 1194 11 tmp = ((OP(c) == BOUND ? 1195 isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0); 1196 11 LOAD_UTF8_CHARCLASS_ALNUM(); 1197 22 while (s + (uskip = UTF8SKIP(s)) <= strend) { 1198 13 if (tmp == !(OP(c) == BOUND ? 1199 swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) : 1200 isALNUM_LC_utf8((U8*)s))) 1201 { 1202 11 tmp = !tmp; 1203 11 if ((norun || regtry(prog, s))) 1204 11 goto got_it; 1205 } 1206 11 s += uskip; 1207 } 1208 } 1209 else { 1210 21415 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n'; 1211 21415 tmp = ((OP(c) == BOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0); 1212 127818 while (s < strend) { 1213 115967 if (tmp == 1214 !(OP(c) == BOUND ? isALNUM(*s) : isALNUM_LC(*s))) { 1215 38613 tmp = !tmp; 1216 38613 if ((norun || regtry(prog, s))) 1217 106403 goto got_it; 1218 } 1219 106403 s++; 1220 } 1221 } 1222 11860 if ((!prog->minlen && tmp) && (norun || regtry(prog, s))) 1223 ###### goto got_it; 1224 ###### break; 1225 case NBOUNDL: 1226 ###### PL_reg_flags |= RF_tainted; 1227 /* FALL THROUGH */ 1228 case NBOUND: 1229 111 if (do_utf8) { 1230 ###### if (s == PL_bostr) 1231 ###### tmp = '\n'; 1232 else { 1233 ###### U8 *r = reghop3((U8*)s, -1, (U8*)PL_bostr); 1234 1235 ###### tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, 0); 1236 } 1237 ###### tmp = ((OP(c) == NBOUND ? 1238 isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0); 1239 ###### LOAD_UTF8_CHARCLASS_ALNUM(); 1240 ###### while (s + (uskip = UTF8SKIP(s)) <= strend) { 1241 ###### if (tmp == !(OP(c) == NBOUND ? 1242 swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) : 1243 isALNUM_LC_utf8((U8*)s))) 1244 ###### tmp = !tmp; 1245 ###### else if ((norun || regtry(prog, s))) 1246 ###### goto got_it; 1247 ###### s += uskip; 1248 } 1249 } 1250 else { 1251 111 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n'; 1252 111 tmp = ((OP(c) == NBOUND ? 1253 isALNUM(tmp) : isALNUM_LC(tmp)) != 0); 1254 147 while (s < strend) { 1255 117 if (tmp == 1256 !(OP(c) == NBOUND ? isALNUM(*s) : isALNUM_LC(*s))) 1257 36 tmp = !tmp; 1258 81 else if ((norun || regtry(prog, s))) 1259 36 goto got_it; 1260 36 s++; 1261 } 1262 } 1263 30 if ((!prog->minlen && !tmp) && (norun || regtry(prog, s))) 1264 1214 goto got_it; 1265 1214 break; 1266 case ALNUM: 1267 1214 if (do_utf8) { 1268 139 LOAD_UTF8_CHARCLASS_ALNUM(); 1269 239 while (s + (uskip = UTF8SKIP(s)) <= strend) { 1270 143 if (swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8)) { 1271 43 if (tmp && (norun || regtry(prog, s))) 1272 ###### goto got_it; 1273 else 1274 ###### tmp = doevery; 1275 } 1276 else 1277 100 tmp = 1; 1278 100 s += uskip; 1279 } 1280 } 1281 else { 1282 1821 while (s < strend) { 1283 1351 if (isALNUM(*s)) { 1284 663 if (tmp && (norun || regtry(prog, s))) 1285 58 goto got_it; 1286 else 1287 58 tmp = doevery; 1288 } 1289 else 1290 688 tmp = 1; 1291 746 s++; 1292 } 1293 } 1294 176394 break; 1295 case ALNUML: 1296 176394 PL_reg_flags |= RF_tainted; 1297 176394 if (do_utf8) { 1298 ###### while (s + (uskip = UTF8SKIP(s)) <= strend) { 1299 ###### if (isALNUM_LC_utf8((U8*)s)) { 1300 ###### if (tmp && (norun || regtry(prog, s))) 1301 ###### goto got_it; 1302 else 1303 ###### tmp = doevery; 1304 } 1305 else 1306 ###### tmp = 1; 1307 ###### s += uskip; 1308 } 1309 } 1310 else { 1311 275188 while (s < strend) { 1312 176396 if (isALNUM_LC(*s)) { 1313 77602 if (tmp && (norun || regtry(prog, s))) 1314 ###### goto got_it; 1315 else 1316 ###### tmp = doevery; 1317 } 1318 else 1319 98794 tmp = 1; 1320 98794 s++; 1321 } 1322 } 1323 124421 break; 1324 case NALNUM: 1325 124421 if (do_utf8) { 1326 2 LOAD_UTF8_CHARCLASS_ALNUM(); 1327 15 while (s + (uskip = UTF8SKIP(s)) <= strend) { 1328 13 if (!swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8)) { 1329 ###### if (tmp && (norun || regtry(prog, s))) 1330 ###### goto got_it; 1331 else 1332 ###### tmp = doevery; 1333 } 1334 else 1335 13 tmp = 1; 1336 13 s += uskip; 1337 } 1338 } 1339 else { 1340 930036 while (s < strend) { 1341 820609 if (!isALNUM(*s)) { 1342 14992 if (tmp && (norun || regtry(prog, s))) 1343 ###### goto got_it; 1344 else 1345 ###### tmp = doevery; 1346 } 1347 else 1348 805617 tmp = 1; 1349 805617 s++; 1350 } 1351 } 1352 47451 break; 1353 case NALNUML: 1354 47451 PL_reg_flags |= RF_tainted; 1355 47451 if (do_utf8) { 1356 ###### while (s + (uskip = UTF8SKIP(s)) <= strend) { 1357 ###### if (!isALNUM_LC_utf8((U8*)s)) { 1358 ###### if (tmp && (norun || regtry(prog, s))) 1359 ###### goto got_it; 1360 else 1361 ###### tmp = doevery; 1362 } 1363 else 1364 ###### tmp = 1; 1365 ###### s += uskip; 1366 } 1367 } 1368 else { 1369 72399 while (s < strend) { 1370 47912 if (!isALNUM_LC(*s)) { 1371 22964 if (tmp && (norun || regtry(prog, s))) 1372 ###### goto got_it; 1373 else 1374 ###### tmp = doevery; 1375 } 1376 else 1377 24948 tmp = 1; 1378 24948 s++; 1379 } 1380 } 1381 142455 break; 1382 case SPACE: 1383 142455 if (do_utf8) { 1384 1 LOAD_UTF8_CHARCLASS_SPACE(); 1385 1 while (s + (uskip = UTF8SKIP(s)) <= strend) { 1386 1 if (*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8)) { 1387 1 if (tmp && (norun || regtry(prog, s))) 1388 ###### goto got_it; 1389 else 1390 ###### tmp = doevery; 1391 } 1392 else 1393 ###### tmp = 1; 1394 ###### s += uskip; 1395 } 1396 } 1397 else { 1398 2223340 while (s < strend) { 1399 2162061 if (isSPACE(*s)) { 1400 205662 if (tmp && (norun || regtry(prog, s))) 1401 124487 goto got_it; 1402 else 1403 124487 tmp = doevery; 1404 } 1405 else 1406 1956399 tmp = 1; 1407 2080886 s++; 1408 } 1409 } 1410 573 break; 1411 case SPACEL: 1412 573 PL_reg_flags |= RF_tainted; 1413 573 if (do_utf8) { 1414 ###### while (s + (uskip = UTF8SKIP(s)) <= strend) { 1415 ###### if (*s == ' ' || isSPACE_LC_utf8((U8*)s)) { 1416 ###### if (tmp && (norun || regtry(prog, s))) 1417 ###### goto got_it; 1418 else 1419 ###### tmp = doevery; 1420 } 1421 else 1422 ###### tmp = 1; 1423 ###### s += uskip; 1424 } 1425 } 1426 else { 1427 9216 while (s < strend) { 1428 8983 if (isSPACE_LC(*s)) { 1429 1617 if (tmp && (norun || regtry(prog, s))) 1430 1277 goto got_it; 1431 else 1432 1277 tmp = doevery; 1433 } 1434 else 1435 7366 tmp = 1; 1436 8643 s++; 1437 } 1438 } 1439 14785 break; 1440 case NSPACE: 1441 14785 if (do_utf8) { 1442 2 LOAD_UTF8_CHARCLASS_SPACE(); 1443 2 while (s + (uskip = UTF8SKIP(s)) <= strend) { 1444 2 if (!(*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8))) { 1445 2 if (tmp && (norun || regtry(prog, s))) 1446 ###### goto got_it; 1447 else 1448 ###### tmp = doevery; 1449 } 1450 else 1451 ###### tmp = 1; 1452 ###### s += uskip; 1453 } 1454 } 1455 else { 1456 28135 while (s < strend) { 1457 27406 if (!isSPACE(*s)) { 1458 14054 if (tmp && (norun || regtry(prog, s))) 1459 ###### goto got_it; 1460 else 1461 ###### tmp = doevery; 1462 } 1463 else 1464 13352 tmp = 1; 1465 13352 s++; 1466 } 1467 } 1468 1 break; 1469 case NSPACEL: 1470 1 PL_reg_flags |= RF_tainted; 1471 1 if (do_utf8) { 1472 ###### while (s + (uskip = UTF8SKIP(s)) <= strend) { 1473 ###### if (!(*s == ' ' || isSPACE_LC_utf8((U8*)s))) { 1474 ###### if (tmp && (norun || regtry(prog, s))) 1475 ###### goto got_it; 1476 else 1477 ###### tmp = doevery; 1478 } 1479 else 1480 ###### tmp = 1; 1481 ###### s += uskip; 1482 } 1483 } 1484 else { 1485 1 while (s < strend) { 1486 1 if (!isSPACE_LC(*s)) { 1487 1 if (tmp && (norun || regtry(prog, s))) 1488 ###### goto got_it; 1489 else 1490 ###### tmp = doevery; 1491 } 1492 else 1493 ###### tmp = 1; 1494 ###### s++; 1495 } 1496 } 1497 2891 break; 1498 case DIGIT: 1499 2891 if (do_utf8) { 1500 1 LOAD_UTF8_CHARCLASS_DIGIT(); 1501 1 while (s + (uskip = UTF8SKIP(s)) <= strend) { 1502 1 if (swash_fetch(PL_utf8_digit,(U8*)s, do_utf8)) { 1503 1 if (tmp && (norun || regtry(prog, s))) 1504 ###### goto got_it; 1505 else 1506 ###### tmp = doevery; 1507 } 1508 else 1509 ###### tmp = 1; 1510 ###### s += uskip; 1511 } 1512 } 1513 else { 1514 8462 while (s < strend) { 1515 7652 if (isDIGIT(*s)) { 1516 2096 if (tmp && (norun || regtry(prog, s))) 1517 16 goto got_it; 1518 else 1519 16 tmp = doevery; 1520 } 1521 else 1522 5556 tmp = 1; 1523 5572 s++; 1524 } 1525 } 1526 ###### break; 1527 case DIGITL: 1528 ###### PL_reg_flags |= RF_tainted; 1529 ###### if (do_utf8) { 1530 ###### while (s + (uskip = UTF8SKIP(s)) <= strend) { 1531 ###### if (isDIGIT_LC_utf8((U8*)s)) { 1532 ###### if (tmp && (norun || regtry(prog, s))) 1533 ###### goto got_it; 1534 else 1535 ###### tmp = doevery; 1536 } 1537 else 1538 ###### tmp = 1; 1539 ###### s += uskip; 1540 } 1541 } 1542 else { 1543 ###### while (s < strend) { 1544 ###### if (isDIGIT_LC(*s)) { 1545 ###### if (tmp && (norun || regtry(prog, s))) 1546 ###### goto got_it; 1547 else 1548 ###### tmp = doevery; 1549 } 1550 else 1551 ###### tmp = 1; 1552 ###### s++; 1553 } 1554 } 1555 1282 break; 1556 case NDIGIT: 1557 1282 if (do_utf8) { 1558 ###### LOAD_UTF8_CHARCLASS_DIGIT(); 1559 ###### while (s + (uskip = UTF8SKIP(s)) <= strend) { 1560 ###### if (!swash_fetch(PL_utf8_digit,(U8*)s, do_utf8)) { 1561 ###### if (tmp && (norun || regtry(prog, s))) 1562 ###### goto got_it; 1563 else 1564 ###### tmp = doevery; 1565 } 1566 else 1567 ###### tmp = 1; 1568 ###### s += uskip; 1569 } 1570 } 1571 else { 1572 3465 while (s < strend) { 1573 2709 if (!isDIGIT(*s)) { 1574 526 if (tmp && (norun || regtry(prog, s))) 1575 ###### goto got_it; 1576 else 1577 ###### tmp = doevery; 1578 } 1579 else 1580 2183 tmp = 1; 1581 2183 s++; 1582 } 1583 } 1584 ###### break; 1585 case NDIGITL: 1586 ###### PL_reg_flags |= RF_tainted; 1587 ###### if (do_utf8) { 1588 ###### while (s + (uskip = UTF8SKIP(s)) <= strend) { 1589 ###### if (!isDIGIT_LC_utf8((U8*)s)) { 1590 ###### if (tmp && (norun || regtry(prog, s))) 1591 ###### goto got_it; 1592 else 1593 ###### tmp = doevery; 1594 } 1595 else 1596 ###### tmp = 1; 1597 ###### s += uskip; 1598 } 1599 } 1600 else { 1601 ###### while (s < strend) { 1602 ###### if (!isDIGIT_LC(*s)) { 1603 ###### if (tmp && (norun || regtry(prog, s))) 1604 ###### goto got_it; 1605 else 1606 ###### tmp = doevery; 1607 } 1608 else 1609 ###### tmp = 1; 1610 ###### s++; 1611 } 1612 } 1613 ###### break; 1614 default: 1615 ###### Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c)); 1616 2135429 break; 1617 } 1618 2135429 return 0; 1619 got_it: 1620 3462207 return s; 1621 } 1622 1623 /* 1624 - regexec_flags - match a regexp against a string 1625 */ 1626 I32 1627 Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *strend, 1628 char *strbeg, I32 minend, SV *sv, void *data, U32 flags) 1629 /* strend: pointer to null at end of string */ 1630 /* strbeg: real beginning of string */ 1631 /* minend: end of match must be >=minend after stringarg. */ 1632 /* data: May be used for some additional optimizations. */ 1633 /* nosave: For optimizations. */ 1634 11094673 { 1635 11094673 register char *s; 1636 11094673 register regnode *c; 1637 11094673 register char *startpos = stringarg; 1638 11094673 I32 minlen; /* must match at least this many chars */ 1639 11094673 I32 dontbother = 0; /* how many characters not to try at end */ 1640 11094673 I32 end_shift = 0; /* Same for the end. */ /* CC */ 1641 11094673 I32 scream_pos = -1; /* Internal iterator of scream. */ 1642 11094673 char *scream_olds; 1643 11094673 SV* oreplsv = GvSV(PL_replgv); 1644 11094673 const bool do_utf8 = DO_UTF8(sv); 1645 11094673 const I32 multiline = prog->reganch & PMf_MULTILINE; 1646 #ifdef DEBUGGING 1647 11094673 SV *dsv0 = PERL_DEBUG_PAD_ZERO(0); 1648 11094673 SV *dsv1 = PERL_DEBUG_PAD_ZERO(1); 1649 #endif 1650 1651 11094673 GET_RE_DEBUG_FLAGS_DECL; 1652 1653 11094673 PERL_UNUSED_ARG(data); 1654 11094673 RX_MATCH_UTF8_set(prog,do_utf8); 1655 1656 11094673 PL_regcc = 0; 1657 1658 11094673 cache_re(prog); 1659 #ifdef DEBUGGING 1660 11094673 PL_regnarrate = DEBUG_r_TEST; 1661 #endif 1662 1663 /* Be paranoid... */ 1664 11094673 if (prog == NULL || startpos == NULL) { 1665 ###### Perl_croak(aTHX_ "NULL regexp parameter"); 1666 11094673 return 0; 1667 } 1668 1669 11094673 minlen = prog->minlen; 1670 11094673 if (strend - startpos < minlen) { 1671 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, 1672 139799 "String too short [regexec_flags]...\n")); 1673 ###### goto phooey; 1674 } 1675 1676 /* Check validity of program. */ 1677 10954874 if (UCHARAT(prog->program) != REG_MAGIC) { 1678 ###### Perl_croak(aTHX_ "corrupted regexp program"); 1679 } 1680 1681 10954874 PL_reg_flags = 0; 1682 10954874 PL_reg_eval_set = 0; 1683 10954874 PL_reg_maxiter = 0; 1684 1685 10954874 if (prog->reganch & ROPT_UTF8) 1686 7724 PL_reg_flags |= RF_utf8; 1687 1688 /* Mark beginning of line for ^ and lookbehind. */ 1689 10954874 PL_regbol = startpos; 1690 10954874 PL_bostr = strbeg; 1691 10954874 PL_reg_sv = sv; 1692 1693 /* Mark end of line for $ (and such) */ 1694 10954874 PL_regeol = strend; 1695 1696 /* see how far we have to get to not match where we matched before */ 1697 10954874 PL_regtill = startpos+minend; 1698 1699 /* We start without call_cc context. */ 1700 10954874 PL_reg_call_cc = 0; 1701 1702 /* If there is a "must appear" string, look for it. */ 1703 10954874 s = startpos; 1704 1705 10954874 if (prog->reganch & ROPT_GPOS_SEEN) { /* Need to have PL_reg_ganch */ 1706 974702 MAGIC *mg; 1707 1708 974702 if (flags & REXEC_IGNOREPOS) /* Means: check only at start */ 1709 440733 PL_reg_ganch = startpos; 1710 533969 else if (sv && SvTYPE(sv) >= SVt_PVMG 1711 && SvMAGIC(sv) 1712 && (mg = mg_find(sv, PERL_MAGIC_regex_global)) 1713 && mg->mg_len >= 0) { 1714 47 PL_reg_ganch = strbeg + mg->mg_len; /* Defined pos() */ 1715 47 if (prog->reganch & ROPT_ANCH_GPOS) { 1716 22 if (s > PL_reg_ganch) 1717 ###### goto phooey; 1718 22 s = PL_reg_ganch; 1719 } 1720 } 1721 else /* pos() not defined */ 1722 533922 PL_reg_ganch = strbeg; 1723 } 1724 1725 10954874 if (!(flags & REXEC_CHECKED) && (prog->check_substr != Nullsv || prog->check_utf8 != Nullsv)) { 1726 696064 re_scream_pos_data d; 1727 1728 696064 d.scream_olds = &scream_olds; 1729 696064 d.scream_pos = &scream_pos; 1730 696064 s = re_intuit_start(prog, sv, s, strend, flags, &d); 1731 696064 if (!s) { 1732 135194 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not present...\n")); 1733 ###### goto phooey; /* not present */ 1734 } 1735 } 1736 1737 DEBUG_EXECUTE_r({ 1738 const char * const s0 = UTF 1739 ? pv_uni_display(dsv0, (U8*)prog->precomp, prog->prelen, 60, 1740 UNI_DISPLAY_REGEX) 1741 : prog->precomp; 1742 const int len0 = UTF ? SvCUR(dsv0) : prog->prelen; 1743 const char * const s1 = do_utf8 ? sv_uni_display(dsv1, sv, 60, 1744 UNI_DISPLAY_REGEX) : startpos; 1745 const int len1 = do_utf8 ? SvCUR(dsv1) : strend - startpos; 1746 if (!PL_colorset) 1747 reginitcolors(); 1748 PerlIO_printf(Perl_debug_log, 1749 "%sMatching REx%s \"%s%*.*s%s%s\" against \"%s%.*s%s%s\"\n", 1750 PL_colors[4], PL_colors[5], PL_colors[0], 1751 len0, len0, s0, 1752 PL_colors[1], 1753 len0 > 60 ? "..." : "", 1754 PL_colors[0], 1755 (int)(len1 > 60 ? 60 : len1), 1756 s1, PL_colors[1], 1757 (len1 > 60 ? "..." : "") 1758 ); 1759 10819680 }); 1760 1761 /* Simplest case: anchored match need be tried only once. */ 1762 /* [unless only anchor is BOL and multiline is set] */ 1763 10819680 if (prog->reganch & (ROPT_ANCH & ~ROPT_ANCH_GPOS)) { 1764 3521359 if (s == startpos && regtry(prog, startpos)) 1765 1879531 goto got_it; 1766 1641828 else if (multiline || (prog->reganch & ROPT_IMPLICIT) 1767 || (prog->reganch & ROPT_ANCH_MBOL)) /* XXXX SBOL? */ 1768 { 1769 447852 char *end; 1770 1771 447852 if (minlen) 1772 442132 dontbother = minlen - 1; 1773 447852 end = HOP3c(strend, -dontbother, strbeg) - 1; 1774 /* for multiline we only have to try after newlines */ 1775 447852 if (prog->check_substr || prog->check_utf8) { 1776 16950 if (s == startpos) 1777 2094 goto after_try; 1778 19520 while (1) { 1779 19520 if (regtry(prog, s)) 1780 14919 goto got_it; 1781 after_try: 1782 6695 if (s >= end) 1783 ###### goto phooey; 1784 6695 if (prog->reganch & RE_USE_INTUIT) { 1785 6695 s = re_intuit_start(prog, sv, s + 1, strend, flags, NULL); 1786 6695 if (!s) 1787 2031 goto phooey; 1788 } 1789 else 1790 ###### s++; 1791 } 1792 } else { 1793 430902 if (s > startpos) 1794 ###### s--; 1795 1567958 while (s < end) { 1796 1514301 if (*s++ == '\n') { /* don't need PL_utf8skip here */ 1797 381362 if (regtry(prog, s)) 1798 377245 goto got_it; 1799 } 1800 } 1801 } 1802 } 1803 7298321 goto phooey; 1804 7298321 } else if (prog->reganch & ROPT_ANCH_GPOS) { 1805 974521 if (regtry(prog, PL_reg_ganch)) 1806 895459 goto got_it; 1807 6323800 goto phooey; 1808 } 1809 1810 /* Messy cases: unanchored match. */ 1811 6323800 if ((prog->anchored_substr || prog->anchored_utf8) && prog->reganch & ROPT_SKIP) { 1812 /* we have /x+whatever/ */ 1813 /* it must be a one character string (XXXX Except UTF?) */ 1814 57159 char ch; 1815 #ifdef DEBUGGING 1816 57159 int did_match = 0; 1817 #endif 1818 57159 if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)) 1819 2 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog); 1820 57159 ch = SvPVX_const(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)[0]; 1821 1822 57159 if (do_utf8) { 1823 2 while (s < strend) { 1824 2 if (*s == ch) { 1825 2 DEBUG_EXECUTE_r( did_match = 1 ); 1826 2 if (regtry(prog, s)) goto got_it; 1827 ###### s += UTF8SKIP(s); 1828 ###### while (s < strend && *s == ch) 1829 ###### s += UTF8SKIP(s); 1830 } 1831 ###### s += UTF8SKIP(s); 1832 } 1833 } 1834 else { 1835 208614 while (s < strend) { 1836 208059 if (*s == ch) { 1837 60518 DEBUG_EXECUTE_r( did_match = 1 ); 1838 60518 if (regtry(prog, s)) goto got_it; 1839 3916 s++; 1840 6128 while (s < strend && *s == ch) 1841 2212 s++; 1842 } 1843 151457 s++; 1844 } 1845 } 1846 DEBUG_EXECUTE_r(if (!did_match) 1847 PerlIO_printf(Perl_debug_log, 1848 "Did not find anchored character...\n") 1849 555 ); 1850 } 1851 6266641 else if (prog->anchored_substr != Nullsv 1852 || prog->anchored_utf8 != Nullsv 1853 || ((prog->float_substr != Nullsv || prog->float_utf8 != Nullsv) 1854 && prog->float_max_offset < strend - s)) { 1855 765282 SV *must; 1856 765282 I32 back_max; 1857 765282 I32 back_min; 1858 765282 char *last; 1859 765282 char *last1; /* Last position checked before */ 1860 #ifdef DEBUGGING 1861 765282 int did_match = 0; 1862 #endif 1863 765282 if (prog->anchored_substr || prog->anchored_utf8) { 1864 763003 if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)) 1865 63 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog); 1866 763003 must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr; 1867 763003 back_max = back_min = prog->anchored_offset; 1868 } else { 1869 2279 if (!(do_utf8 ? prog->float_utf8 : prog->float_substr)) 1870 ###### do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog); 1871 2279 must = do_utf8 ? prog->float_utf8 : prog->float_substr; 1872 2279 back_max = prog->float_max_offset; 1873 2279 back_min = prog->float_min_offset; 1874 } 1875 765282 if (must == &PL_sv_undef) 1876 /* could not downgrade utf8 check substring, so must fail */ 1877 4 goto phooey; 1878 1879 765278 last = HOP3c(strend, /* Cannot start after this */ 1880 -(I32)(CHR_SVLEN(must) 1881 - (SvTAIL(must) != 0) + back_min), strbeg); 1882 1883 765278 if (s > PL_bostr) 1884 681912 last1 = HOPc(s, -1); 1885 else 1886 83366 last1 = s - 1; /* bogus */ 1887 1888 /* XXXX check_substr already used to find "s", can optimize if 1889 check_substr==must. */ 1890 765278 scream_pos = -1; 1891 765278 dontbother = end_shift; 1892 765278 strend = HOPc(strend, -dontbother); 1893 1140301 while ( (s <= last) && 1894 ((flags & REXEC_SCREAM) 1895 ? (s = screaminstr(sv, must, HOP3c(s, back_min, strend) - strbeg, 1896 end_shift, &scream_pos, 0)) 1897 : (s = fbm_instr((unsigned char*)HOP3(s, back_min, strend), 1898 (unsigned char*)strend, must, 1899 multiline ? FBMrf_MULTILINE : 0))) ) { 1900 /* we may be pointing at the wrong string */ 1901 1066268 if ((flags & REXEC_SCREAM) && RX_MATCH_COPIED(prog)) 1902 3 s = strbeg + (s - SvPVX_const(sv)); 1903 1066268 DEBUG_EXECUTE_r( did_match = 1 ); 1904 1066268 if (HOPc(s, -back_max) > last1) { 1905 1064471 last1 = HOPc(s, -back_min); 1906 1064471 s = HOPc(s, -back_max); 1907 } 1908 else { 1909 1797 char *t = (last1 >= PL_bostr) ? HOPc(last1, 1) : last1 + 1; 1910 1911 1797 last1 = HOPc(s, -back_min); 1912 1797 s = t; 1913 } 1914 1066268 if (do_utf8) { 1915 1412 while (s <= last1) { 1916 1391 if (regtry(prog, s)) 1917 1370 goto got_it; 1918 21 s += UTF8SKIP(s); 1919 } 1920 } 1921 else { 1922 1440266 while (s <= last1) { 1923 1065264 if (regtry(prog, s)) 1924 689875 goto got_it; 1925 375389 s++; 1926 } 1927 } 1928 } 1929 DEBUG_EXECUTE_r(if (!did_match) 1930 PerlIO_printf(Perl_debug_log, 1931 "Did not find %s substr \"%s%.*s%s\"%s...\n", 1932 ((must == prog->anchored_substr || must == prog->anchored_utf8) 1933 ? "anchored" : "floating"), 1934 PL_colors[0], 1935 (int)(SvCUR(must) - (SvTAIL(must)!=0)), 1936 SvPVX_const(must), 1937 PL_colors[1], (SvTAIL(must) ? "$" : "")) 1938 74033 ); 1939 ###### goto phooey; 1940 } 1941 5501359 else if ((c = prog->regstclass)) { 1942 5002849 if (minlen) { 1943 5002847 I32 op = (U8)OP(prog->regstclass); 1944 /* don't bother with what can't match */ 1945 5002847 if (PL_regkind[op] != EXACT && op != CANY) 1946 3286196 strend = HOPc(strend, -(minlen - 1)); 1947 } 1948 DEBUG_EXECUTE_r({ 1949 SV *prop = sv_newmortal(); 1950 const char *s0; 1951 const char *s1; 1952 int len0; 1953 int len1; 1954 1955 regprop(prop, c); 1956 s0 = UTF ? 1957 pv_uni_display(dsv0, (U8*)SvPVX_const(prop), SvCUR(prop), 60, 1958 UNI_DISPLAY_REGEX) : 1959 SvPVX_const(prop); 1960 len0 = UTF ? SvCUR(dsv0) : SvCUR(prop); 1961 s1 = UTF ? 1962 sv_uni_display(dsv1, sv, 60, UNI_DISPLAY_REGEX) : s; 1963 len1 = UTF ? SvCUR(dsv1) : strend - s; 1964 PerlIO_printf(Perl_debug_log, 1965 "Matching stclass \"%*.*s\" against \"%*.*s\"\n", 1966 len0, len0, s0, 1967 len1, len1, s1); 1968 5002849 }); 1969 5002849 if (find_byclass(prog, c, s, strend, 0)) 1970 2900706 goto got_it; 1971 2102143 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass...\n")); 1972 } 1973 else { 1974 498510 dontbother = 0; 1975 498510 if (prog->float_substr != Nullsv || prog->float_utf8 != Nullsv) { 1976 /* Trim the end. */ 1977 76982 char *last; 1978 76982 SV* float_real; 1979 1980 76982 if (!(do_utf8 ? prog->float_utf8 : prog->float_substr)) 1981 ###### do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog); 1982 76982 float_real = do_utf8 ? prog->float_utf8 : prog->float_substr; 1983 1984 76982 if (flags & REXEC_SCREAM) { 1985 ###### last = screaminstr(sv, float_real, s - strbeg, 1986 end_shift, &scream_pos, 1); /* last one */ 1987 ###### if (!last) 1988 ###### last = scream_olds; /* Only one occurrence. */ 1989 /* we may be pointing at the wrong string */ 1990 ###### else if (RX_MATCH_COPIED(prog)) 1991 ###### s = strbeg + (s - SvPVX_const(sv)); 1992 } 1993 else { 1994 76982 STRLEN len; 1995 76982 const char * const little = SvPV_const(float_real, len); 1996 1997 76982 if (SvTAIL(float_real)) { 1998 12644 if (memEQ(strend - len + 1, little, len - 1)) 1999 12644 last = strend - len + 1; 2000 ###### else if (!multiline) 2001 ###### last = memEQ(strend - len, little, len) 2002 ? strend - len : Nullch; 2003 else 2004 64338 goto find_last; 2005 } else { 2006 find_last: 2007 64338 if (len) 2008 64338 last = rninstr(s, strend, little, little + len); 2009 else 2010 ###### last = strend; /* matching "$" */ 2011 } 2012 } 2013 76982 if (last == NULL) { 2014 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, 2015 "%sCan't trim the tail, match fails (should not happen)%s\n", 2016 ###### PL_colors[4], PL_colors[5])); 2017 ###### goto phooey; /* Should not happen! */ 2018 } 2019 76982 dontbother = strend - last + prog->float_min_offset; 2020 } 2021 498510 if (minlen && (dontbother < minlen)) 2022 251067 dontbother = minlen - 1; 2023 498510 strend -= dontbother; /* this one's always in bytes! */ 2024 /* We don't know much -- general case. */ 2025 498510 if (do_utf8) { 2026 34533 for (;;) { 2027 32419 if (regtry(prog, s)) 2028 30294 goto got_it; 2029 2125 if (s >= strend) 2030 11 break; 2031 2114 s += UTF8SKIP(s); 2032 }; 2033 } 2034 else { 2035 4180984 do { 2036 4180984 if (regtry(prog, s)) 2037 357468 goto got_it; 2038 3823515 } while (s++ < strend); 2039 } 2040 } 2041 2042 /* Failure. */ 2043 7203471 goto phooey; 2044 2045 got_it: 2046 7203471 RX_MATCH_TAINTED_set(prog, PL_reg_flags & RF_tainted); 2047 2048 7203471 if (PL_reg_eval_set) { 2049 /* Preserve the current value of $^R */ 2050 3206 if (oreplsv != GvSV(PL_replgv)) 2051 306 sv_setsv(oreplsv, GvSV(PL_replgv));/* So that when GvSV(replgv) is 2052 restored, the value remains 2053 the same. */ 2054 3206 restore_pos(aTHX_ 0); 2055 } 2056 2057 /* make sure $`, $&, $', and $digit will work later */ 2058 7203471 if ( !(flags & REXEC_NOT_FIRST) ) { 2059 6811398 RX_MATCH_COPY_FREE(prog); 2060 6811398 if (flags & REXEC_COPY_STR) { 2061 3398779 I32 i = PL_regeol - startpos + (stringarg - strbeg); 2062 #ifdef PERL_OLD_COPY_ON_WRITE 2063 if ((SvIsCOW(sv) 2064 || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) { 2065 if (DEBUG_C_TEST) { 2066 PerlIO_printf(Perl_debug_log, 2067 "Copy on write: regexp capture, type %d\n", 2068 (int) SvTYPE(sv)); 2069 } 2070 prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv); 2071 prog->subbeg = (char *)SvPVX_const(prog->saved_copy); 2072 assert (SvPOKp(prog->saved_copy)); 2073 } else 2074 #endif 2075 { 2076 3398779 RX_MATCH_COPIED_on(prog); 2077 3398779 s = savepvn(strbeg, i); 2078 3398779 prog->subbeg = s; 2079 } 2080 3398779 prog->sublen = i; 2081 } 2082 else { 2083 3412619 prog->subbeg = strbeg; 2084 3412619 prog->sublen = PL_regeol - strbeg; /* strend may have been modified */ 2085 } 2086 } 2087 2088 7203471 return 1; 2089 2090 phooey: 2091 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n", 2092 3891201 PL_colors[4], PL_colors[5])); 2093 3891201 if (PL_reg_eval_set) 2094 609 restore_pos(aTHX_ 0); 2095 3891201 return 0; 2096 } 2097 2098 /* 2099 - regtry - try match at specific point 2100 */ 2101 STATIC I32 /* 0 failure, 1 success */ 2102 S_regtry(pTHX_ regexp *prog, char *startpos) 2103 13711296 { 2104 13711296 register I32 i; 2105 13711296 register I32 *sp; 2106 13711296 register I32 *ep; 2107 13711296 CHECKPOINT lastcp; 2108 13711296 GET_RE_DEBUG_FLAGS_DECL; 2109 2110 #ifdef DEBUGGING 2111 13711296 PL_regindent = 0; /* XXXX Not good when matches are reenterable... */ 2112 #endif 2113 13711296 if ((prog->reganch & ROPT_EVAL_SEEN) && !PL_reg_eval_set) { 2114 3820 MAGIC *mg; 2115 2116 3820 PL_reg_eval_set = RS_init; 2117 DEBUG_EXECUTE_r(DEBUG_s( 2118 PerlIO_printf(Perl_debug_log, " setting stack tmpbase at %"IVdf"\n", 2119 (IV)(PL_stack_sp - PL_stack_base)); 2120 3820 )); 2121 3820 SAVEI32(cxstack[cxstack_ix].blk_oldsp); 2122 3820 cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base; 2123 /* Otherwise OP_NEXTSTATE will free whatever on stack now. */ 2124 3820 SAVETMPS; 2125 /* Apparently this is not needed, judging by wantarray. */ 2126 /* SAVEI8(cxstack[cxstack_ix].blk_gimme); 2127 cxstack[cxstack_ix].blk_gimme = G_SCALAR; */ 2128 2129 3820 if (PL_reg_sv) { 2130 /* Make $_ available to executed code. */ 2131 3820 if (PL_reg_sv != DEFSV) { 2132 3103 SAVE_DEFSV; 2133 3103 DEFSV = PL_reg_sv; 2134 } 2135 2136 3820 if (!(SvTYPE(PL_reg_sv) >= SVt_PVMG && SvMAGIC(PL_reg_sv) 2137 && (mg = mg_find(PL_reg_sv, PERL_MAGIC_regex_global)))) { 2138 /* prepare for quick setting of pos */ 2139 2403 sv_magic(PL_reg_sv, (SV*)0, 2140 PERL_MAGIC_regex_global, Nullch, 0); 2141 2403 mg = mg_find(PL_reg_sv, PERL_MAGIC_regex_global); 2142 2403 mg->mg_len = -1; 2143 } 2144 3820 PL_reg_magic = mg; 2145 3820 PL_reg_oldpos = mg->mg_len; 2146 3820 SAVEDESTRUCTOR_X(restore_pos, 0); 2147 } 2148 3820 if (!PL_reg_curpm) { 2149 86 Newz(22, PL_reg_curpm, 1, PMOP); 2150 #ifdef USE_ITHREADS 2151 { 2152 SV* repointer = newSViv(0); 2153 /* so we know which PL_regex_padav element is PL_reg_curpm */ 2154 SvFLAGS(repointer) |= SVf_BREAK; 2155 av_push(PL_regex_padav,repointer); 2156 PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav); 2157 PL_regex_pad = AvARRAY(PL_regex_padav); 2158 } 2159 #endif 2160 } 2161 3820 PM_SETRE(PL_reg_curpm, prog); 2162 3820 PL_reg_oldcurpm = PL_curpm; 2163 3820 PL_curpm = PL_reg_curpm; 2164 3820 if (RX_MATCH_COPIED(prog)) { 2165 /* Here is a serious problem: we cannot rewrite subbeg, 2166 since it may be needed if this match fails. Thus 2167 $` inside (?{}) could fail... */ 2168 2460 PL_reg_oldsaved = prog->subbeg; 2169 2460 PL_reg_oldsavedlen = prog->sublen; 2170 #ifdef PERL_OLD_COPY_ON_WRITE 2171 PL_nrs = prog->saved_copy; 2172 #endif 2173 2460 RX_MATCH_COPIED_off(prog); 2174 } 2175 else 2176 1360 PL_reg_oldsaved = Nullch; 2177 3820 prog->subbeg = PL_bostr; 2178 3820 prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */ 2179 } 2180 13711296 prog->startp[0] = startpos - PL_bostr; 2181 13711296 PL_reginput = startpos; 2182 13711296 PL_regstartp = prog->startp; 2183 13711296 PL_regendp = prog->endp; 2184 13711296 PL_reglastparen = &prog->lastparen; 2185 13711296 PL_reglastcloseparen = &prog->lastcloseparen; 2186 13711296 prog->lastparen = 0; 2187 13711296 prog->lastcloseparen = 0; 2188 13711296 PL_regsize = 0; 2189 13711296 DEBUG_EXECUTE_r(PL_reg_starttry = startpos); 2190 13711296 if (PL_reg_start_tmpl <= prog->nparens) { 2191 52353 PL_reg_start_tmpl = prog->nparens*3/2 + 3; 2192 52353 if(PL_reg_start_tmp) 2193 8495 Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*); 2194 else 2195 43858 New(22, PL_reg_start_tmp, PL_reg_start_tmpl, char*); 2196 } 2197 2198 /* XXXX What this code is doing here?!!! There should be no need 2199 to do this again and again, PL_reglastparen should take care of 2200 this! --ilya*/ 2201 2202 /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code. 2203 * Actually, the code in regcppop() (which Ilya may be meaning by 2204 * PL_reglastparen), is not needed at all by the test suite 2205 * (op/regexp, op/pat, op/split), but that code is needed, oddly 2206 * enough, for building DynaLoader, or otherwise this 2207 * "Error: '*' not in typemap in DynaLoader.xs, line 164" 2208 * will happen. Meanwhile, this code *is* needed for the 2209 * above-mentioned test suite tests to succeed. The common theme 2210 * on those tests seems to be returning null fields from matches. 2211 * --jhi */ 2212 #if 1 2213 13711296 sp = prog->startp; 2214 13711296 ep = prog->endp; 2215 13711296 if (prog->nparens) { 2216 13824751 for (i = prog->nparens; i > (I32)*PL_reglastparen; i--) { 2217 8775065 *++sp = -1; 2218 8775065 *++ep = -1; 2219 } 2220 } 2221 #endif 2222 13711296 REGCP_SET(lastcp); 2223 13711296 if (regmatch(prog->program + 1)) { 2224 7203471 prog->endp[0] = PL_reginput - PL_bostr; 2225 7203471 return 1; 2226 } 2227 6507824 REGCP_UNWIND(lastcp); 2228 6507824 return 0; 2229 } 2230 2231 #define RE_UNWIND_BRANCH 1 2232 #define RE_UNWIND_BRANCHJ 2 2233 2234 union re_unwind_t; 2235 2236 typedef struct { /* XX: makes sense to enlarge it... */ 2237 I32 type; 2238 I32 prev; 2239 CHECKPOINT lastcp; 2240 } re_unwind_generic_t; 2241 2242 typedef struct { 2243 I32 type; 2244 I32 prev; 2245 CHECKPOINT lastcp; 2246 I32 lastparen; 2247 regnode *next; 2248 char *locinput; 2249 I32 nextchr; 2250 #ifdef DEBUGGING 2251 int regindent; 2252 #endif 2253 } re_unwind_branch_t; 2254 2255 typedef union re_unwind_t { 2256 I32 type; 2257 re_unwind_generic_t generic; 2258 re_unwind_branch_t branch; 2259 } re_unwind_t; 2260 2261 #define sayYES goto yes 2262 #define sayNO goto no 2263 #define sayNO_ANYOF goto no_anyof 2264 #define sayYES_FINAL goto yes_final 2265 #define sayYES_LOUD goto yes_loud 2266 #define sayNO_FINAL goto no_final 2267 #define sayNO_SILENT goto do_no 2268 #define saySAME(x) if (x) goto yes; else goto no 2269 2270 #define POSCACHE_SUCCESS 0 /* caching success rather than failure */ 2271 #define POSCACHE_SEEN 1 /* we know what we're caching */ 2272 #define POSCACHE_START 2 /* the real cache: this bit maps to pos 0 */ 2273 #define CACHEsayYES STMT_START { \ 2274 if (cache_offset | cache_bit) { \ 2275 if (!(PL_reg_poscache[0] & (1<states[ state ].wordnum ) { \ 2320 if ( !accepted ) { \ 2321 ENTER; \ 2322 SAVETMPS; \ 2323 bufflen = TRIE_INITAL_ACCEPT_BUFFLEN ; \ 2324 sv_accept_buff=NEWSV( 1234, \ 2325 bufflen * sizeof(reg_trie_accepted) - 1 ); \ 2326 SvCUR_set( sv_accept_buff, sizeof(reg_trie_accepted) ); \ 2327 SvPOK_on( sv_accept_buff ); \ 2328 sv_2mortal( sv_accept_buff ); \ 2329 accept_buff = (reg_trie_accepted*)SvPV_nolen( sv_accept_buff );\ 2330 } else { \ 2331 if ( accepted >= bufflen ) { \ 2332 bufflen *= 2; \ 2333 accept_buff =(reg_trie_accepted*)SvGROW( sv_accept_buff, \ 2334 bufflen * sizeof(reg_trie_accepted) ); \ 2335 } \ 2336 SvCUR_set( sv_accept_buff,SvCUR( sv_accept_buff ) \ 2337 + sizeof( reg_trie_accepted ) ); \ 2338 } \ 2339 accept_buff[ accepted ].wordnum = trie->states[ state ].wordnum; \ 2340 accept_buff[ accepted ].endpos = uc; \ 2341 ++accepted; \ 2342 } } STMT_END 2343 2344 #define TRIE_HANDLE_CHAR STMT_START { \ 2345 if ( uvc < 256 ) { \ 2346 charid = trie->charmap[ uvc ]; \ 2347 } else { \ 2348 charid = 0; \ 2349 if( trie->widecharmap ) { \ 2350 SV** svpp = (SV**)NULL; \ 2351 svpp = hv_fetch( trie->widecharmap, (char*)&uvc, \ 2352 sizeof( UV ), 0 ); \ 2353 if ( svpp ) { \ 2354 charid = (U16)SvIV( *svpp ); \ 2355 } \ 2356 } \ 2357 } \ 2358 if ( charid && \ 2359 ( base + charid > trie->uniquecharcount ) && \ 2360 ( base + charid - 1 - trie->uniquecharcount < trie->lasttrans) && \ 2361 trie->trans[ base + charid - 1 - trie->uniquecharcount ].check == state ) \ 2362 { \ 2363 state = trie->trans[ base + charid - 1 - trie->uniquecharcount ].next; \ 2364 } else { \ 2365 state = 0; \ 2366 } \ 2367 uc += len; \ 2368 } STMT_END 2369 2370 /* 2371 - regmatch - main matching routine 2372 * 2373 * Conceptually the strategy is simple: check to see whether the current 2374 * node matches, call self recursively to see whether the rest matches, 2375 * and then act accordingly. In practice we make some effort to avoid 2376 * recursion, in particular by going through "ordinary" nodes (that don't 2377 * need to know whether the rest of the match failed) by a loop instead of 2378 * by recursion. 2379 */ 2380 /* [lwall] I've hoisted the register declarations to the outer block in order to 2381 * maybe save a little bit of pushing and popping on the stack. It also takes 2382 * advantage of machines that use a register save mask on subroutine entry. 2383 */ 2384 STATIC I32 /* 0 failure, 1 success */ 2385 S_regmatch(pTHX_ regnode *prog) 2386 28953002 { 2387 dVAR; 2388 28953002 register regnode *scan; /* Current node. */ 2389 28953002 regnode *next; /* Next node. */ 2390 28953002 regnode *inner; /* Next node in internal branch. */ 2391 28953002 register I32 nextchr; /* renamed nextchr - nextchar colides with 2392 function of same name */ 2393 28953002 register I32 n; /* no or next */ 2394 28953002 register I32 ln = 0; /* len or last */ 2395 28953002 register char *s = Nullch; /* operand or save */ 2396 28953002 register char *locinput = PL_reginput; 2397 28953002 register I32 c1 = 0, c2 = 0, paren; /* case fold search, parenth */ 2398 28953002 int minmod = 0, sw = 0, logical = 0; 2399 28953002 I32 unwind = 0; 2400 2401 /* used by the trie code */ 2402 28953002 SV *sv_accept_buff = 0; /* accepting states we have traversed */ 2403 28953002 reg_trie_accepted *accept_buff = 0; /* "" */ 2404 28953002 reg_trie_data *trie; /* what trie are we using right now */ 2405 28953002 U32 accepted = 0; /* how many accepting states we have seen*/ 2406 2407 #if 0 2408 I32 firstcp = PL_savestack_ix; 2409 #endif 2410 28953002 const register bool do_utf8 = PL_reg_match_utf8; 2411 #ifdef DEBUGGING 2412 28953002 SV *dsv0 = PERL_DEBUG_PAD_ZERO(0); 2413 28953002 SV *dsv1 = PERL_DEBUG_PAD_ZERO(1); 2414 28953002 SV *dsv2 = PERL_DEBUG_PAD_ZERO(2); 2415 2416 28953002 SV *re_debug_flags = NULL; 2417 #endif 2418 2419 28953002 GET_RE_DEBUG_FLAGS; 2420 2421 #ifdef DEBUGGING 2422 28953002 PL_regindent++; 2423 #endif 2424 2425 2426 /* Note that nextchr is a byte even in UTF */ 2427 28953002 nextchr = UCHARAT(locinput); 2428 28953002 scan = prog; 2429 63107958 while (scan != NULL) { 2430 2431 DEBUG_EXECUTE_r( { 2432 SV *prop = sv_newmortal(); 2433 const int docolor = *PL_colors[0]; 2434 const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */ 2435 int l = (PL_regeol - locinput) > taill ? taill : (PL_regeol - locinput); 2436 /* The part of the string before starttry has one color 2437 (pref0_len chars), between starttry and current 2438 position another one (pref_len - pref0_len chars), 2439 after the current position the third one. 2440 We assume that pref0_len <= pref_len, otherwise we 2441 decrease pref0_len. */ 2442 int pref_len = (locinput - PL_bostr) > (5 + taill) - l 2443 ? (5 + taill) - l : locinput - PL_bostr; 2444 int pref0_len; 2445 2446 while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len))) 2447 pref_len++; 2448 pref0_len = pref_len - (locinput - PL_reg_starttry); 2449 if (l + pref_len < (5 + taill) && l < PL_regeol - locinput) 2450 l = ( PL_regeol - locinput > (5 + taill) - pref_len 2451 ? (5 + taill) - pref_len : PL_regeol - locinput); 2452 while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput + l))) 2453 l--; 2454 if (pref0_len < 0) 2455 pref0_len = 0; 2456 if (pref0_len > pref_len) 2457 pref0_len = pref_len; 2458 regprop(prop, scan); 2459 { 2460 const char * const s0 = 2461 do_utf8 && OP(scan) != CANY ? 2462 pv_uni_display(dsv0, (U8*)(locinput - pref_len), 2463 pref0_len, 60, UNI_DISPLAY_REGEX) : 2464 locinput - pref_len; 2465 const int len0 = do_utf8 ? strlen(s0) : pref0_len; 2466 const char * const s1 = do_utf8 && OP(scan) != CANY ? 2467 pv_uni_display(dsv1, (U8*)(locinput - pref_len + pref0_len), 2468 pref_len - pref0_len, 60, UNI_DISPLAY_REGEX) : 2469 locinput - pref_len + pref0_len; 2470 const int len1 = do_utf8 ? strlen(s1) : pref_len - pref0_len; 2471 const char * const s2 = do_utf8 && OP(scan) != CANY ? 2472 pv_uni_display(dsv2, (U8*)locinput, 2473 PL_regeol - locinput, 60, UNI_DISPLAY_REGEX) : 2474 locinput; 2475 const int len2 = do_utf8 ? strlen(s2) : l; 2476 PerlIO_printf(Perl_debug_log, 2477 "%4"IVdf" <%s%.*s%s%s%.*s%s%s%s%.*s%s>%*s|%3"IVdf":%*s%s\n", 2478 (IV)(locinput - PL_bostr), 2479 PL_colors[4], 2480 len0, s0, 2481 PL_colors[5], 2482 PL_colors[2], 2483 len1, s1, 2484 PL_colors[3], 2485 (docolor ? "" : "> <"), 2486 PL_colors[0], 2487 len2, s2, 2488 PL_colors[1], 2489 15 - l - pref_len + 1, 2490 "", 2491 (IV)(scan - PL_regprogram), PL_regindent*2, "", 2492 SvPVX_const(prop)); 2493 } 2494 63107958 }); 2495 2496 63107958 next = scan + NEXT_OFF(scan); 2497 63107958 if (next == scan) 2498 10473303 next = NULL; 2499 2500 63107958 switch (OP(scan)) { 2501 case BOL: 2502 4164077 if (locinput == PL_bostr) 2503 { 2504 /* regtill = regbol; */ 2505 3026145 break; 2506 } 2507 929551 sayNO; 2508 case MBOL: 2509 929551 if (locinput == PL_bostr || 2510 ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n')) 2511 { 2512 43150 break; 2513 } 2514 43150 sayNO; 2515 case SBOL: 2516 43150 if (locinput == PL_bostr) 2517 37509 break; 2518 978427 sayNO; 2519 case GPOS: 2520 978427 if (locinput == PL_reg_ganch) 2521 974706 break; 2522 911 sayNO; 2523 case EOL: 2524 911 goto seol; 2525 case MEOL: 2526 911 if ((nextchr || locinput < PL_regeol) && nextchr != '\n') 2527 79 sayNO; 2528 1345196 break; 2529 case SEOL: 2530 seol: 2531 1345196 if ((nextchr || locinput < PL_regeol) && nextchr != '\n') 2532 730887 sayNO; 2533 614309 if (PL_regeol - locinput > 1) 2534 610 sayNO; 2535 129257 break; 2536 case EOS: 2537 129257 if (PL_regeol != locinput) 2538 89583 sayNO; 2539 26157 break; 2540 case SANY: 2541 26157 if (!nextchr && locinput >= PL_regeol) 2542 ###### sayNO; 2543 26157 if (do_utf8) { 2544 25 locinput += PL_utf8skip[nextchr]; 2545 25 if (locinput > PL_regeol) 2546 ###### sayNO; 2547 25 nextchr = UCHARAT(locinput); 2548 } 2549 else 2550 26132 nextchr = UCHARAT(++locinput); 2551 26132 break; 2552 case CANY: 2553 67 if (!nextchr && locinput >= PL_regeol) 2554 ###### sayNO; 2555 67 nextchr = UCHARAT(++locinput); 2556 67 break; 2557 case REG_ANY: 2558 92793 if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n') 2559 92640 sayNO; 2560 92640 if (do_utf8) { 2561 30015 locinput += PL_utf8skip[nextchr]; 2562 30015 if (locinput > PL_regeol) 2563 ###### sayNO; 2564 30015 nextchr = UCHARAT(locinput); 2565 } 2566 else 2567 62625 nextchr = UCHARAT(++locinput); 2568 62625 break; 2569 2570 2571 2572 /* 2573 traverse the TRIE keeping track of all accepting states 2574 we transition through until we get to a failing node. 2575 2576 we use two slightly different pieces of code to handle 2577 the traversal depending on whether its case sensitive or 2578 not. we reuse the accept code however. (this should probably 2579 be turned into a macro.) 2580 2581 */ 2582 case TRIEF: 2583 case TRIEFL: 2584 { 2585 2586 11982 const U32 uniflags = ckWARN( WARN_UTF8 ) ? 0 : UTF8_ALLOW_ANY; 2587 11982 U8 *uc = ( U8* )locinput; 2588 11982 U32 state = 1; 2589 11982 U16 charid = 0; 2590 11982 U32 base = 0; 2591 11982 UV uvc = 0; 2592 11982 STRLEN len = 0; 2593 11982 STRLEN foldlen = 0; 2594 11982 U8 *uscan = (U8*)NULL; 2595 11982 STRLEN bufflen=0; 2596 11982 accepted = 0; 2597 2598 11982 trie = (reg_trie_data*)PL_regdata->data[ ARG( scan ) ]; 2599 2600 29707 while ( state && uc <= (U8*)PL_regeol ) { 2601 2602 17725 TRIE_CHECK_STATE_IS_ACCEPTING; 2603 2604 17725 base = trie->states[ state ].trans.base; 2605 2606 DEBUG_TRIE_EXECUTE_r( 2607 PerlIO_printf( Perl_debug_log, 2608 "%*s %sState: %4"UVxf", Base: %4"UVxf", Accepted: %4"UVxf" ", 2609 REPORT_CODE_OFF + PL_regindent * 2, "", PL_colors[4], 2610 (UV)state, (UV)base, (UV)accepted ); 2611 17725 ); 2612 2613 17725 if ( base ) { 2614 2615 16653 if ( do_utf8 || UTF ) { 2616 128 if ( foldlen>0 ) { 2617 5 uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags ); 2618 5 foldlen -= len; 2619 5 uscan += len; 2620 5 len=0; 2621 } else { 2622 123 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ]; 2623 123 uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags ); 2624 123 uvc = to_uni_fold( uvc, foldbuf, &foldlen ); 2625 123 foldlen -= UNISKIP( uvc ); 2626 123 uscan = foldbuf + UNISKIP( uvc ); 2627 } 2628 } else { 2629 16525 uvc = (UV)*uc; 2630 16525 len = 1; 2631 } 2632 2633 16653 TRIE_HANDLE_CHAR; 2634 2635 } else { 2636 1072 state = 0; 2637 } 2638 DEBUG_TRIE_EXECUTE_r( 2639 PerlIO_printf( Perl_debug_log, 2640 "Charid:%3x CV:%4"UVxf" After State: %4"UVxf"%s\n", 2641 charid, uvc, (UV)state, PL_colors[5] ); 2642 17725 ); 2643 } 2644 11982 if ( !accepted ) { 2645 10575 sayNO; 2646 } else { 2647 315460 goto TrieAccept; 2648 } 2649 } 2650 /* unreached codepoint: we jump into the middle of the next case 2651 from previous if blocks */ 2652 case TRIE: 2653 { 2654 315460 const U32 uniflags = ckWARN( WARN_UTF8 ) ? 0 : UTF8_ALLOW_ANY; 2655 315460 U8 *uc = (U8*)locinput; 2656 315460 U32 state = 1; 2657 315460 U16 charid = 0; 2658 315460 U32 base = 0; 2659 315460 UV uvc = 0; 2660 315460 STRLEN len = 0; 2661 315460 STRLEN bufflen = 0; 2662 315460 accepted = 0; 2663 2664 315460 trie = (reg_trie_data*)PL_regdata->data[ ARG( scan ) ]; 2665 2666 737722 while ( state && uc <= (U8*)PL_regeol ) { 2667 2668 422262 TRIE_CHECK_STATE_IS_ACCEPTING; 2669 2670 422262 base = trie->states[ state ].trans.base; 2671 2672 DEBUG_TRIE_EXECUTE_r( 2673 PerlIO_printf( Perl_debug_log, 2674 "%*s %sState: %4"UVxf", Base: %4"UVxf", Accepted: %4"UVxf" ", 2675 REPORT_CODE_OFF + PL_regindent * 2, "", PL_colors[4], 2676 (UV)state, (UV)base, (UV)accepted ); 2677 422262 ); 2678 2679 422262 if ( base ) { 2680 2681 401723 if ( do_utf8 || UTF ) { 2682 1873 uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags ); 2683 } else { 2684 399850 uvc = (U32)*uc; 2685 399850 len = 1; 2686 } 2687 2688 401723 TRIE_HANDLE_CHAR; 2689 2690 } else { 2691 20539 state = 0; 2692 } 2693 DEBUG_TRIE_EXECUTE_r( 2694 PerlIO_printf( Perl_debug_log, 2695 "Charid:%3x CV:%4"UVxf" After State: %4"UVxf"%s\n", 2696 charid, uvc, (UV)state, PL_colors[5] ); 2697 422262 ); 2698 } 2699 315460 if ( !accepted ) { 2700 290835 sayNO; 2701 } 2702 } 2703 2704 2705 /* 2706 There was at least one accepting state that we 2707 transitioned through. Presumably the number of accepting 2708 states is going to be low, typically one or two. So we 2709 simply scan through to find the one with lowest wordnum. 2710 Once we find it, we swap the last state into its place 2711 and decrement the size. We then try to match the rest of 2712 the pattern at the point where the word ends, if we 2713 succeed then we end the loop, otherwise the loop 2714 eventually terminates once all of the accepting states 2715 have been tried. 2716 */ 2717 TrieAccept: 2718 { 2719 26032 int gotit = 0; 2720 2721 26032 if ( accepted == 1 ) { 2722 DEBUG_EXECUTE_r({ 2723 SV **tmp = av_fetch( trie->words, accept_buff[ 0 ].wordnum-1, 0 ); 2724 PerlIO_printf( Perl_debug_log, 2725 "%*s %sonly one match : #%d <%s>%s\n", 2726 REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4], 2727 accept_buff[ 0 ].wordnum, 2728 tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr", 2729 PL_colors[5] ); 2730 24524 }); 2731 24524 PL_reginput = (char *)accept_buff[ 0 ].endpos; 2732 /* in this case we free tmps/leave before we call regmatch 2733 as we wont be using accept_buff again. */ 2734 24524 FREETMPS; 2735 24524 LEAVE; 2736 24524 gotit = regmatch( scan + NEXT_OFF( scan ) ); 2737 } else { 2738 DEBUG_EXECUTE_r( 2739 PerlIO_printf( Perl_debug_log,"%*s %sgot %"IVdf" possible matches%s\n", 2740 REPORT_CODE_OFF + PL_regindent * 2, "", PL_colors[4], (IV)accepted, 2741 PL_colors[5] ); 2742 1508 ); 2743 5128 while ( !gotit && accepted-- ) { 2744 3620 U32 best = 0; 2745 3620 U32 cur; 2746 9506 for( cur = 1 ; cur <= accepted ; cur++ ) { 2747 DEBUG_TRIE_EXECUTE_r( 2748 PerlIO_printf( Perl_debug_log, 2749 "%*s %sgot %"IVdf" (%d) as best, looking at %"IVdf" (%d)%s\n", 2750 REPORT_CODE_OFF + PL_regindent * 2, "", PL_colors[4], 2751 (IV)best, accept_buff[ best ].wordnum, (IV)cur, 2752 accept_buff[ cur ].wordnum, PL_colors[5] ); 2753 5886 ); 2754 2755 5886 if ( accept_buff[ cur ].wordnum < accept_buff[ best ].wordnum ) 2756 2424 best = cur; 2757 } 2758 DEBUG_EXECUTE_r({ 2759 SV **tmp = av_fetch( trie->words, accept_buff[ best ].wordnum - 1, 0 ); 2760 PerlIO_printf( Perl_debug_log, "%*s %strying alternation #%d <%s> at 0x%p%s\n", 2761 REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4], 2762 accept_buff[best].wordnum, 2763 tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr",scan, 2764 PL_colors[5] ); 2765 3620 }); 2766 3620 if ( best= PL_regeol) 2807 8 sayNO; 2808 9270 if (NATIVE_TO_UNI(*(U8*)s) != 2809 utf8n_to_uvuni((U8*)l, UTF8_MAXBYTES, &ulen, 2810 ckWARN(WARN_UTF8) ? 2811 0 : UTF8_ALLOW_ANY)) 2812 2604 sayNO; 2813 6666 l += ulen; 2814 6666 s ++; 2815 } 2816 } 2817 else { 2818 /* The target is not utf8, the pattern is utf8. */ 2819 292 while (s < e) { 2820 243 STRLEN ulen; 2821 243 if (l >= PL_regeol) 2822 3 sayNO; 2823 240 if (NATIVE_TO_UNI(*((U8*)l)) != 2824 utf8n_to_uvuni((U8*)s, UTF8_MAXBYTES, &ulen, 2825 ckWARN(WARN_UTF8) ? 2826 0 : UTF8_ALLOW_ANY)) 2827 31 sayNO; 2828 209 s += ulen; 2829 209 l ++; 2830 } 2831 } 2832 3135 locinput = l; 2833 3135 nextchr = UCHARAT(locinput); 2834 3135 break; 2835 } 2836 /* The target and the pattern have the same utf8ness. */ 2837 /* Inline the first character, for speed. */ 2838 6805445 if (UCHARAT(s) != nextchr) 2839 2767374 sayNO; 2840 4038071 if (PL_regeol - locinput < ln) 2841 1566 sayNO; 2842 4036505 if (ln > 1 && memNE(s, locinput, ln)) 2843 403101 sayNO; 2844 3633404 locinput += ln; 2845 3633404 nextchr = UCHARAT(locinput); 2846 3633404 break; 2847 case EXACTFL: 2848 1696542 PL_reg_flags |= RF_tainted; 2849 /* FALL THROUGH */ 2850 case EXACTF: 2851 1824337 s = STRING(scan); 2852 1824337 ln = STR_LEN(scan); 2853 2854 1824337 if (do_utf8 || UTF) { 2855 /* Either target or the pattern are utf8. */ 2856 8907 char *l = locinput; 2857 8907 char *e = PL_regeol; 2858 2859 8907 if (ibcmp_utf8(s, 0, ln, (bool)UTF, 2860 l, &e, 0, do_utf8)) { 2861 /* One more case for the sharp s: 2862 * pack("U0U*", 0xDF) =~ /ss/i, 2863 * the 0xC3 0x9F are the UTF-8 2864 * byte sequence for the U+00DF. */ 2865 15 if (!(do_utf8 && 2866 toLOWER(s[0]) == 's' && 2867 ln >= 2 && 2868 toLOWER(s[1]) == 's' && 2869 (U8)l[0] == 0xC3 && 2870 e - l >= 2 && 2871 (U8)l[1] == 0x9F)) 2872 8892 sayNO; 2873 } 2874 8892 locinput = e; 2875 8892 nextchr = UCHARAT(locinput); 2876 8892 break; 2877 } 2878 2879 /* Neither the target and the pattern are utf8. */ 2880 2881 /* Inline the first character, for speed. */ 2882 1815430 if (UCHARAT(s) != nextchr && 2883 UCHARAT(s) != ((OP(scan) == EXACTF) 2884 ? PL_fold : PL_fold_locale)[nextchr]) 2885 107856 sayNO; 2886 1707574 if (PL_regeol - locinput < ln) 2887 355 sayNO; 2888 1707219 if (ln > 1 && (OP(scan) == EXACTF 2889 ? ibcmp(s, locinput, ln) 2890 : ibcmp_locale(s, locinput, ln))) 2891 1705025 sayNO; 2892 1705025 locinput += ln; 2893 1705025 nextchr = UCHARAT(locinput); 2894 1705025 break; 2895 case ANYOF: 2896 4437711 if (do_utf8) { 2897 22504 STRLEN inclasslen = PL_regeol - locinput; 2898 2899 22504 if (!reginclass(scan, (U8*)locinput, &inclasslen, do_utf8)) 2900 2370 sayNO_ANYOF; 2901 20134 if (locinput >= PL_regeol) 2902 3 sayNO; 2903 20131 locinput += inclasslen ? inclasslen : UTF8SKIP(locinput); 2904 20131 nextchr = UCHARAT(locinput); 2905 20131 break; 2906 } 2907 else { 2908 4415207 if (nextchr < 0) 2909 ###### nextchr = UCHARAT(locinput); 2910 4415207 if (!REGINCLASS(scan, (U8*)locinput)) 2911 1051159 sayNO_ANYOF; 2912 2956545 if (!nextchr && locinput >= PL_regeol) 2913 31328 sayNO; 2914 2925217 nextchr = UCHARAT(++locinput); 2915 2925217 break; 2916 } 2917 no_anyof: 2918 /* If we might have the case of the German sharp s 2919 * in a casefolding Unicode character class. */ 2920 2921 1461032 if (ANYOF_FOLD_SHARP_S(scan, locinput, PL_regeol)) { 2922 2 locinput += SHARP_S_SKIP; 2923 2 nextchr = UCHARAT(locinput); 2924 } 2925 else 2926 77601 sayNO; 2927 77601 break; 2928 case ALNUML: 2929 77601 PL_reg_flags |= RF_tainted; 2930 /* FALL THROUGH */ 2931 case ALNUM: 2932 84447 if (!nextchr) 2933 2 sayNO; 2934 84445 if (do_utf8) { 2935 35 LOAD_UTF8_CHARCLASS_ALNUM(); 2936 35 if (!(OP(scan) == ALNUM 2937 ? swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8) 2938 : isALNUM_LC_utf8((U8*)locinput))) 2939 { 2940 ###### sayNO; 2941 } 2942 35 locinput += PL_utf8skip[nextchr]; 2943 35 nextchr = UCHARAT(locinput); 2944 35 break; 2945 } 2946 84410 if (!(OP(scan) == ALNUM 2947 ? isALNUM(nextchr) : isALNUM_LC(nextchr))) 2948 84323 sayNO; 2949 84323 nextchr = UCHARAT(++locinput); 2950 84323 break; 2951 case NALNUML: 2952 22964 PL_reg_flags |= RF_tainted; 2953 /* FALL THROUGH */ 2954 case NALNUM: 2955 59276 if (!nextchr && locinput >= PL_regeol) 2956 96 sayNO; 2957 59180 if (do_utf8) { 2958 ###### LOAD_UTF8_CHARCLASS_ALNUM(); 2959 ###### if (OP(scan) == NALNUM 2960 ? swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8) 2961 : isALNUM_LC_utf8((U8*)locinput)) 2962 { 2963 ###### sayNO; 2964 } 2965 ###### locinput += PL_utf8skip[nextchr]; 2966 ###### nextchr = UCHARAT(locinput); 2967 ###### break; 2968 } 2969 59180 if (OP(scan) == NALNUM 2970 ? isALNUM(nextchr) : isALNUM_LC(nextchr)) 2971 41624 sayNO; 2972 41624 nextchr = UCHARAT(++locinput); 2973 41624 break; 2974 case BOUNDL: 2975 case NBOUNDL: 2976 128 PL_reg_flags |= RF_tainted; 2977 /* FALL THROUGH */ 2978 case BOUND: 2979 case NBOUND: 2980 /* was last char in word? */ 2981 416361 if (do_utf8) { 2982 14 if (locinput == PL_bostr) 2983 10 ln = '\n'; 2984 else { 2985 4 const U8 * const r = reghop3((U8*)locinput, -1, (U8*)PL_bostr); 2986 2987 4 ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, 0); 2988 } 2989 14 if (OP(scan) == BOUND || OP(scan) == NBOUND) { 2990 14 ln = isALNUM_uni(ln); 2991 14 LOAD_UTF8_CHARCLASS_ALNUM(); 2992 14 n = swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8); 2993 } 2994 else { 2995 ###### ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(ln)); 2996 ###### n = isALNUM_LC_utf8((U8*)locinput); 2997 } 2998 } 2999 else { 3000 416347 ln = (locinput != PL_bostr) ? 3001 UCHARAT(locinput - 1) : '\n'; 3002 416347 if (OP(scan) == BOUND || OP(scan) == NBOUND) { 3003 416219 ln = isALNUM(ln); 3004 416219 n = isALNUM(nextchr); 3005 } 3006 else { 3007 128 ln = isALNUM_LC(ln); 3008 128 n = isALNUM_LC(nextchr); 3009 } 3010 } 3011 416361 if (((!ln) == (!n)) == (OP(scan) == BOUND || 3012 OP(scan) == BOUNDL)) 3013 189276 sayNO; 3014 7681 break; 3015 case SPACEL: 3016 7681 PL_reg_flags |= RF_tainted; 3017 /* FALL THROUGH */ 3018 case SPACE: 3019 224272 if (!nextchr) 3020 350 sayNO; 3021 223922 if (do_utf8) { 3022 4 if (UTF8_IS_CONTINUED(nextchr)) { 3023 4 LOAD_UTF8_CHARCLASS_SPACE(); 3024 4 if (!(OP(scan) == SPACE 3025 ? swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8) 3026 : isSPACE_LC_utf8((U8*)locinput))) 3027 { 3028 ###### sayNO; 3029 } 3030 4 locinput += PL_utf8skip[nextchr]; 3031 4 nextchr = UCHARAT(locinput); 3032 4 break; 3033 } 3034 ###### if (!(OP(scan) == SPACE 3035 ? isSPACE(nextchr) : isSPACE_LC(nextchr))) 3036 ###### sayNO; 3037 ###### nextchr = UCHARAT(++locinput); 3038 } 3039 else { 3040 223918 if (!(OP(scan) == SPACE 3041 ? isSPACE(nextchr) : isSPACE_LC(nextchr))) 3042 5471 sayNO; 3043 117258 nextchr = UCHARAT(++locinput); 3044 } 3045 117258 break; 3046 case NSPACEL: 3047 4947 PL_reg_flags |= RF_tainted; 3048 /* FALL THROUGH */ 3049 case NSPACE: 3050 109241 if (!nextchr && locinput >= PL_regeol) 3051 94 sayNO; 3052 109147 if (do_utf8) { 3053 3 LOAD_UTF8_CHARCLASS_SPACE(); 3054 3 if (OP(scan) == NSPACE 3055 ? swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8) 3056 : isSPACE_LC_utf8((U8*)locinput)) 3057 { 3058 3 sayNO; 3059 } 3060 3 locinput += PL_utf8skip[nextchr]; 3061 3 nextchr = UCHARAT(locinput); 3062 3 break; 3063 } 3064 109144 if (OP(scan) == NSPACE 3065 ? isSPACE(nextchr) : isSPACE_LC(nextchr)) 3066 95889 sayNO; 3067 95889 nextchr = UCHARAT(++locinput); 3068 95889 break; 3069 case DIGITL: 3070 ###### PL_reg_flags |= RF_tainted; 3071 /* FALL THROUGH */ 3072 case DIGIT: 3073 63233 if (!nextchr) 3074 6 sayNO; 3075 63227 if (do_utf8) { 3076 2 LOAD_UTF8_CHARCLASS_DIGIT(); 3077 2 if (!(OP(scan) == DIGIT 3078 ? swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8) 3079 : isDIGIT_LC_utf8((U8*)locinput))) 3080 { 3081 ###### sayNO; 3082 } 3083 1 locinput += PL_utf8skip[nextchr]; 3084 1 nextchr = UCHARAT(locinput); 3085 1 break; 3086 } 3087 63225 if (!(OP(scan) == DIGIT 3088 ? isDIGIT(nextchr) : isDIGIT_LC(nextchr))) 3089 ###### sayNO; 3090 3877 nextchr = UCHARAT(++locinput); 3091 3877 break; 3092 case NDIGITL: 3093 ###### PL_reg_flags |= RF_tainted; 3094 /* FALL THROUGH */ 3095 case NDIGIT: 3096 526 if (!nextchr && locinput >= PL_regeol) 3097 ###### sayNO; 3098 526 if (do_utf8) { 3099 ###### LOAD_UTF8_CHARCLASS_DIGIT(); 3100 ###### if (OP(scan) == NDIGIT 3101 ? swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8) 3102 : isDIGIT_LC_utf8((U8*)locinput)) 3103 { 3104 ###### sayNO; 3105 } 3106 ###### locinput += PL_utf8skip[nextchr]; 3107 ###### nextchr = UCHARAT(locinput); 3108 ###### break; 3109 } 3110 526 if (OP(scan) == NDIGIT 3111 ? isDIGIT(nextchr) : isDIGIT_LC(nextchr)) 3112 526 sayNO; 3113 526 nextchr = UCHARAT(++locinput); 3114 526 break; 3115 case CLUMP: 3116 11 if (locinput >= PL_regeol) 3117 ###### sayNO; 3118 11 if (do_utf8) { 3119 7 LOAD_UTF8_CHARCLASS_MARK(); 3120 7 if (swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8)) 3121 ###### sayNO; 3122 7 locinput += PL_utf8skip[nextchr]; 3123 10 while (locinput < PL_regeol && 3124 swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8)) 3125 3 locinput += UTF8SKIP(locinput); 3126 7 if (locinput > PL_regeol) 3127 ###### sayNO; 3128 } 3129 else 3130 4 locinput++; 3131 11 nextchr = UCHARAT(locinput); 3132 11 break; 3133 case REFFL: 3134 ###### PL_reg_flags |= RF_tainted; 3135 /* FALL THROUGH */ 3136 case REF: 3137 case REFF: 3138 7136 n = ARG(scan); /* which paren pair */ 3139 7136 ln = PL_regstartp[n]; 3140 7136 PL_reg_leftiter = PL_reg_maxiter; /* Void cache */ 3141 7136 if ((I32)*PL_reglastparen < n || ln == -1) 3142 6686 sayNO; /* Do not match unless seen CLOSEn. */ 3143 6686 if (ln == PL_regendp[n]) 3144 10 break; 3145 3146 6676 s = PL_bostr + ln; 3147 6676 if (do_utf8 && OP(scan) != REF) { /* REF can do byte comparison */ 3148 ###### char *l = locinput; 3149 ###### const char *e = PL_bostr + PL_regendp[n]; 3150 /* 3151 * Note that we can't do the "other character" lookup trick as 3152 * in the 8-bit case (no pun intended) because in Unicode we 3153 * have to map both upper and title case to lower case. 3154 */ 3155 ###### if (OP(scan) == REFF) { 3156 ###### while (s < e) { 3157 ###### STRLEN ulen1, ulen2; 3158 ###### U8 tmpbuf1[UTF8_MAXBYTES_CASE+1]; 3159 ###### U8 tmpbuf2[UTF8_MAXBYTES_CASE+1]; 3160 3161 ###### if (l >= PL_regeol) 3162 ###### sayNO; 3163 ###### toLOWER_utf8((U8*)s, tmpbuf1, &ulen1); 3164 ###### toLOWER_utf8((U8*)l, tmpbuf2, &ulen2); 3165 ###### if (ulen1 != ulen2 || memNE((char *)tmpbuf1, (char *)tmpbuf2, ulen1)) 3166 ###### sayNO; 3167 ###### s += ulen1; 3168 ###### l += ulen2; 3169 } 3170 } 3171 ###### locinput = l; 3172 ###### nextchr = UCHARAT(locinput); 3173 ###### break; 3174 } 3175 3176 /* Inline the first character, for speed. */ 3177 6676 if (UCHARAT(s) != nextchr && 3178 (OP(scan) == REF || 3179 (UCHARAT(s) != ((OP(scan) == REFF 3180 ? PL_fold : PL_fold_locale)[nextchr])))) 3181 2280 sayNO; 3182 2280 ln = PL_regendp[n] - ln; 3183 2280 if (locinput + ln > PL_regeol) 3184 110 sayNO; 3185 2170 if (ln > 1 && (OP(scan) == REF 3186 ? memNE(s, locinput, ln) 3187 : (OP(scan) == REFF 3188 ? ibcmp(s, locinput, ln) 3189 : ibcmp_locale(s, locinput, ln)))) 3190 2170 sayNO; 3191 2170 locinput += ln; 3192 2170 nextchr = UCHARAT(locinput); 3193 2170 break; 3194 3195 case NOTHING: 3196 case TAIL: 3197 10629 break; 3198 case BACK: 3199 10629 break; 3200 case EVAL: 3201 { 3202 10629 dSP; 3203 10629 OP_4tree *oop = PL_op; 3204 10629 COP *ocurcop = PL_curcop; 3205 10629 PAD *old_comppad; 3206 10629 SV *ret; 3207 10629 struct regexp *oreg = PL_reg_re; 3208 3209 10629 n = ARG(scan); 3210 10629 PL_op = (OP_4tree*)PL_regdata->data[n]; 3211 10629 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, " re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) ); 3212 10629 PAD_SAVE_LOCAL(old_comppad, (PAD*)PL_regdata->data[n + 2]); 3213 10629 PL_regendp[0] = PL_reg_magic->mg_len = locinput - PL_bostr; 3214 3215 { 3216 10629 SV **before = SP; 3217 10629 CALLRUNOPS(aTHX); /* Scalar context. */ 3218 10628 SPAGAIN; 3219 10628 if (SP == before) 3220 ###### ret = &PL_sv_undef; /* protect against empty (?{}) blocks. */ 3221 else { 3222 10628 ret = POPs; 3223 10628 PUTBACK; 3224 } 3225 } 3226 3227 10628 PL_op = oop; 3228 10628 PAD_RESTORE_LOCAL(old_comppad); 3229 10628 PL_curcop = ocurcop; 3230 10628 if (logical) { 3231 10099 if (logical == 2) { /* Postponed subexpression. */ 3232 9905 regexp *re; 3233 9905 MAGIC *mg = Null(MAGIC*); 3234 9905 re_cc_state state; 3235 9905 CHECKPOINT cp, lastcp; 3236 9905 int toggleutf; 3237 9905 register SV *sv; 3238 3239 9905 if(SvROK(ret) && SvSMAGICAL(sv = SvRV(ret))) 3240 8492 mg = mg_find(sv, PERL_MAGIC_qr); 3241 1413 else if (SvSMAGICAL(ret)) { 3242 11 if (SvGMAGICAL(ret)) 3243 4 sv_unmagic(ret, PERL_MAGIC_qr); 3244 else 3245 7 mg = mg_find(ret, PERL_MAGIC_qr); 3246 } 3247 3248 9905 if (mg) { 3249 8498 re = (regexp *)mg->mg_obj; 3250 8498 (void)ReREFCNT_inc(re); 3251 } 3252 else { 3253 1407 STRLEN len; 3254 1407 const char *t = SvPV_const(ret, len); 3255 1407 PMOP pm; 3256 1407 char * const oprecomp = PL_regprecomp; 3257 1407 const I32 osize = PL_regsize; 3258 1407 const I32 onpar = PL_regnpar; 3259 3260 1407 Zero(&pm, 1, PMOP); 3261 1407 if (DO_UTF8(ret)) pm.op_pmdynflags |= PMdf_DYN_UTF8; 3262 1407 re = CALLREGCOMP(aTHX_ (char*)t, (char*)t + len, &pm); 3263 1407 if (!(SvFLAGS(ret) 3264 & (SVs_TEMP | SVs_PADTMP | SVf_READONLY 3265 | SVs_GMG))) 3266 6 sv_magic(ret,(SV*)ReREFCNT_inc(re), 3267 PERL_MAGIC_qr,0,0); 3268 1407 PL_regprecomp = oprecomp; 3269 1407 PL_regsize = osize; 3270 1407 PL_regnpar = onpar; 3271 } 3272 DEBUG_EXECUTE_r( 3273 PerlIO_printf(Perl_debug_log, 3274 "Entering embedded \"%s%.60s%s%s\"\n", 3275 PL_colors[0], 3276 re->precomp, 3277 PL_colors[1], 3278 (strlen(re->precomp) > 60 ? "..." : "")) 3279 9905 ); 3280 9905 state.node = next; 3281 9905 state.prev = PL_reg_call_cc; 3282 9905 state.cc = PL_regcc; 3283 9905 state.re = PL_reg_re; 3284 3285 9905 PL_regcc = 0; 3286 3287 9905 cp = regcppush(0); /* Save *all* the positions. */ 3288 9905 REGCP_SET(lastcp); 3289 9905 cache_re(re); 3290 9905 state.ss = PL_savestack_ix; 3291 9905 *PL_reglastparen = 0; 3292 9905 *PL_reglastcloseparen = 0; 3293 9905 PL_reg_call_cc = &state; 3294 9905 PL_reginput = locinput; 3295 9905 toggleutf = ((PL_reg_flags & RF_utf8) != 0) ^ 3296 ((re->reganch & ROPT_UTF8) != 0); 3297 9905 if (toggleutf) PL_reg_flags ^= RF_utf8; 3298 3299 /* XXXX This is too dramatic a measure... */ 3300 9905 PL_reg_maxiter = 0; 3301 3302 9905 if (regmatch(re->program + 1)) { 3303 /* Even though we succeeded, we need to restore 3304 global variables, since we may be wrapped inside 3305 SUSPEND, thus the match may be not finished yet. */ 3306 3307 /* XXXX Do this only if SUSPENDed? */ 3308 4319 PL_reg_call_cc = state.prev; 3309 4319 PL_regcc = state.cc; 3310 4319 PL_reg_re = state.re; 3311 4319 cache_re(PL_reg_re); 3312 4319 if (toggleutf) PL_reg_flags ^= RF_utf8; 3313 3314 /* XXXX This is too dramatic a measure... */ 3315 4319 PL_reg_maxiter = 0; 3316 3317 /* These are needed even if not SUSPEND. */ 3318 4319 ReREFCNT_dec(re); 3319 4319 regcpblow(cp); 3320 4319 sayYES; 3321 } 3322 5586 ReREFCNT_dec(re); 3323 5586 REGCP_UNWIND(lastcp); 3324 5586 regcppop(); 3325 5586 PL_reg_call_cc = state.prev; 3326 5586 PL_regcc = state.cc; 3327 5586 PL_reg_re = state.re; 3328 5586 cache_re(PL_reg_re); 3329 5586 if (toggleutf) PL_reg_flags ^= RF_utf8; 3330 3331 /* XXXX This is too dramatic a measure... */ 3332 5586 PL_reg_maxiter = 0; 3333 3334 5586 logical = 0; 3335 5586 sayNO; 3336 } 3337 194 sw = SvTRUE(ret); 3338 194 logical = 0; 3339 } 3340 else { 3341 529 sv_setsv(save_scalar(PL_replgv), ret); 3342 529 cache_re(oreg); 3343 } 3344 529 break; 3345 } 3346 case OPEN: 3347 7139107 n = ARG(scan); /* which paren pair */ 3348 7139107 PL_reg_start_tmp[n] = locinput; 3349 7139107 if (n > PL_regsize) 3350 6305872 PL_regsize = n; 3351 6305872 break; 3352 case CLOSE: 3353 5823937 n = ARG(scan); /* which paren pair */ 3354 5823937 PL_regstartp[n] = PL_reg_start_tmp[n] - PL_bostr; 3355 5823937 PL_regendp[n] = locinput - PL_bostr; 3356 5823937 if (n > (I32)*PL_reglastparen) 3357 4773465 *PL_reglastparen = n; 3358 5823937 *PL_reglastcloseparen = n; 3359 5823937 break; 3360 case GROUPP: 3361 380 n = ARG(scan); /* which paren pair */ 3362 380 sw = ((I32)*PL_reglastparen >= n && PL_regendp[n] != -1); 3363 380 break; 3364 case IFTHEN: 3365 634 PL_reg_leftiter = PL_reg_maxiter; /* Void cache */ 3366 634 if (sw) 3367 306 next = NEXTOPER(NEXTOPER(scan)); 3368 else { 3369 328 next = scan + ARG(scan); 3370 328 if (OP(next) == IFTHEN) /* Fake one. */ 3371 170 next = NEXTOPER(NEXTOPER(next)); 3372 } 3373 170 break; 3374 case LOGICAL: 3375 10159 logical = scan->flags; 3376 10159 break; 3377 /******************************************************************* 3378 PL_regcc contains infoblock about the innermost (...)* loop, and 3379 a pointer to the next outer infoblock. 3380 3381 Here is how Y(A)*Z is processed (if it is compiled into CURLYX/WHILEM): 3382 3383 1) After matching X, regnode for CURLYX is processed; 3384 3385 2) This regnode creates infoblock on the stack, and calls 3386 regmatch() recursively with the starting point at WHILEM node; 3387 3388 3) Each hit of WHILEM node tries to match A and Z (in the order 3389 depending on the current iteration, min/max of {min,max} and 3390 greediness). The information about where are nodes for "A" 3391 and "Z" is read from the infoblock, as is info on how many times "A" 3392 was already matched, and greediness. 3393 3394 4) After A matches, the same WHILEM node is hit again. 3395 3396 5) Each time WHILEM is hit, PL_regcc is the infoblock created by CURLYX 3397 of the same pair. Thus when WHILEM tries to match Z, it temporarily 3398 resets PL_regcc, since this Y(A)*Z can be a part of some other loop: 3399 as in (Y(A)*Z)*. If Z matches, the automaton will hit the WHILEM node 3400 of the external loop. 3401 3402 Currently present infoblocks form a tree with a stem formed by PL_curcc 3403 and whatever it mentions via ->next, and additional attached trees 3404 corresponding to temporarily unset infoblocks as in "5" above. 3405 3406 In the following picture infoblocks for outer loop of 3407 (Y(A)*?Z)*?T are denoted O, for inner I. NULL starting block 3408 is denoted by x. The matched string is YAAZYAZT. Temporarily postponed 3409 infoblocks are drawn below the "reset" infoblock. 3410 3411 In fact in the picture below we do not show failed matches for Z and T 3412 by WHILEM blocks. [We illustrate minimal matches, since for them it is 3413 more obvious *why* one needs to *temporary* unset infoblocks.] 3414 3415 Matched REx position InfoBlocks Comment 3416 (Y(A)*?Z)*?T x 3417 Y(A)*?Z)*?T x <- O 3418 Y (A)*?Z)*?T x <- O 3419 Y A)*?Z)*?T x <- O <- I 3420 YA )*?Z)*?T x <- O <- I 3421 YA A)*?Z)*?T x <- O <- I 3422 YAA )*?Z)*?T x <- O <- I 3423 YAA Z)*?T x <- O # Temporary unset I 3424 I 3425 3426 YAAZ Y(A)*?Z)*?T x <- O 3427 I 3428 3429 YAAZY (A)*?Z)*?T x <- O 3430 I 3431 3432 YAAZY A)*?Z)*?T x <- O <- I 3433 I 3434 3435 YAAZYA )*?Z)*?T x <- O <- I 3436 I 3437 3438 YAAZYA Z)*?T x <- O # Temporary unset I 3439 I,I 3440 3441 YAAZYAZ )*?T x <- O 3442 I,I 3443 3444 YAAZYAZ T x # Temporary unset O 3445 O 3446 I,I 3447 3448 YAAZYAZT x 3449 O 3450 I,I 3451 *******************************************************************/ 3452 case CURLYX: { 3453 1170519 CURCUR cc; 3454 1170519 CHECKPOINT cp = PL_savestack_ix; 3455 /* No need to save/restore up to this paren */ 3456 1170519 I32 parenfloor = scan->flags; 3457 3458 1170519 if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */ 3459 12 next += ARG(next); 3460 1170519 cc.oldcc = PL_regcc; 3461 1170519 PL_regcc = &cc; 3462 /* XXXX Probably it is better to teach regpush to support 3463 parenfloor > PL_regsize... */ 3464 1170519 if (parenfloor > (I32)*PL_reglastparen) 3465 236255 parenfloor = *PL_reglastparen; /* Pessimization... */ 3466 1170519 cc.parenfloor = parenfloor; 3467 1170519 cc.cur = -1; 3468 1170519 cc.min = ARG1(scan); 3469 1170519 cc.max = ARG2(scan); 3470 1170519 cc.scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS; 3471 1170519 cc.next = next; 3472 1170519 cc.minmod = minmod; 3473 1170519 cc.lastloc = 0; 3474 1170519 PL_reginput = locinput; 3475 1170519 n = regmatch(PREVOPER(next)); /* start on the WHILEM */ 3476 1170519 regcpblow(cp); 3477 1170519 PL_regcc = cc.oldcc; 3478 1170519 saySAME(n); 3479 } 3480 /* NOT REACHED */ 3481 case WHILEM: { 3482 /* 3483 * This is really hard to understand, because after we match 3484 * what we're trying to match, we must make sure the rest of 3485 * the REx is going to match for sure, and to do that we have 3486 * to go back UP the parse tree by recursing ever deeper. And 3487 * if it fails, we have to reset our parent's current state 3488 * that we can try again after backing off. 3489 */ 3490 3491 1802011 CHECKPOINT cp, lastcp; 3492 1802011 CURCUR* cc = PL_regcc; 3493 1802011 char *lastloc = cc->lastloc; /* Detection of 0-len. */ 3494 1802011 I32 cache_offset = 0, cache_bit = 0; 3495 3496 1802011 n = cc->cur + 1; /* how many we know we matched */ 3497 1802011 PL_reginput = locinput; 3498 3499 DEBUG_EXECUTE_r( 3500 PerlIO_printf(Perl_debug_log, 3501 "%*s %ld out of %ld..%ld cc=%"UVxf"\n", 3502 REPORT_CODE_OFF+PL_regindent*2, "", 3503 (long)n, (long)cc->min, 3504 (long)cc->max, PTR2UV(cc)) 3505 1802011 ); 3506 3507 /* If degenerate scan matches "", assume scan done. */ 3508 3509 1802011 if (locinput == cc->lastloc && n >= cc->min) { 3510 572 PL_regcc = cc->oldcc; 3511 572 if (PL_regcc) 3512 ###### ln = PL_regcc->cur; 3513 DEBUG_EXECUTE_r( 3514 PerlIO_printf(Perl_debug_log, 3515 "%*s empty match detected, try continuation...\n", 3516 REPORT_CODE_OFF+PL_regindent*2, "") 3517 572 ); 3518 572 if (regmatch(cc->next)) 3519 542 sayYES; 3520 30 if (PL_regcc) 3521 ###### PL_regcc->cur = ln; 3522 30 PL_regcc = cc; 3523 30 sayNO; 3524 } 3525 3526 /* First just match a string of min scans. */ 3527 3528 1801439 if (n < cc->min) { 3529 13637 cc->cur = n; 3530 13637 cc->lastloc = locinput; 3531 13637 if (regmatch(cc->scan)) 3532 1729 sayYES; 3533 11908 cc->cur = n - 1; 3534 11908 cc->lastloc = lastloc; 3535 11908 sayNO; 3536 } 3537 3538 1787802 if (scan->flags) { 3539 /* Check whether we already were at this position. 3540 Postpone detection until we know the match is not 3541 *that* much linear. */ 3542 148606 if (!PL_reg_maxiter) { 3543 29483 PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4); 3544 29483 PL_reg_leftiter = PL_reg_maxiter; 3545 } 3546 148606 if (PL_reg_leftiter-- == 0) { 3547 180 const I32 size = (PL_reg_maxiter + 7 + POSCACHE_START)/8; 3548 180 if (PL_reg_poscache) { 3549 175 if ((I32)PL_reg_poscache_size < size) { 3550 ###### Renew(PL_reg_poscache, size, char); 3551 ###### PL_reg_poscache_size = size; 3552 } 3553 175 Zero(PL_reg_poscache, size, char); 3554 } 3555 else { 3556 5 PL_reg_poscache_size = size; 3557 5 Newz(29, PL_reg_poscache, size, char); 3558 } 3559 DEBUG_EXECUTE_r( 3560 PerlIO_printf(Perl_debug_log, 3561 "%sDetected a super-linear match, switching on caching%s...\n", 3562 PL_colors[4], PL_colors[5]) 3563 180 ); 3564 } 3565 148606 if (PL_reg_leftiter < 0) { 3566 88440 cache_offset = locinput - PL_bostr; 3567 3568 88440 cache_offset = (scan->flags & 0xf) - 1 + POSCACHE_START 3569 + cache_offset * (scan->flags>>4); 3570 88440 cache_bit = cache_offset % 8; 3571 88440 cache_offset /= 8; 3572 88440 if (PL_reg_poscache[cache_offset] & (1<minmod) { 3592 6165 PL_regcc = cc->oldcc; 3593 6165 if (PL_regcc) 3594 ###### ln = PL_regcc->cur; 3595 6165 cp = regcppush(cc->parenfloor); 3596 6165 REGCP_SET(lastcp); 3597 6165 if (regmatch(cc->next)) { 3598 606 regcpblow(cp); 3599 606 CACHEsayYES; /* All done. */ 3600 } 3601 5559 REGCP_UNWIND(lastcp); 3602 5559 regcppop(); 3603 5559 if (PL_regcc) 3604 ###### PL_regcc->cur = ln; 3605 5559 PL_regcc = cc; 3606 3607 5559 if (n >= cc->max) { /* Maximum greed exceeded? */ 3608 ###### if (ckWARN(WARN_REGEXP) && n >= REG_INFTY 3609 && !(PL_reg_flags & RF_warned)) { 3610 ###### PL_reg_flags |= RF_warned; 3611 ###### Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded", 3612 "Complex regular subexpression recursion", 3613 REG_INFTY - 1); 3614 } 3615 ###### CACHEsayNO; 3616 } 3617 3618 DEBUG_EXECUTE_r( 3619 PerlIO_printf(Perl_debug_log, 3620 "%*s trying longer...\n", 3621 REPORT_CODE_OFF+PL_regindent*2, "") 3622 5559 ); 3623 /* Try scanning more and see if it helps. */ 3624 5559 PL_reginput = locinput; 3625 5559 cc->cur = n; 3626 5559 cc->lastloc = locinput; 3627 5559 cp = regcppush(cc->parenfloor); 3628 5559 REGCP_SET(lastcp); 3629 5559 if (regmatch(cc->scan)) { 3630 5551 regcpblow(cp); 3631 5551 CACHEsayYES; 3632 } 3633 8 REGCP_UNWIND(lastcp); 3634 8 regcppop(); 3635 8 cc->cur = n - 1; 3636 8 cc->lastloc = lastloc; 3637 8 CACHEsayNO; 3638 } 3639 3640 /* Prefer scan over next for maximal matching. */ 3641 3642 1698417 if (n < cc->max) { /* More greed allowed? */ 3643 1187943 cp = regcppush(cc->parenfloor); 3644 1187943 cc->cur = n; 3645 1187943 cc->lastloc = locinput; 3646 1187943 REGCP_SET(lastcp); 3647 1187943 if (regmatch(cc->scan)) { 3648 526643 regcpblow(cp); 3649 526643 CACHEsayYES; 3650 } 3651 661300 REGCP_UNWIND(lastcp); 3652 661300 regcppop(); /* Restore some previous $s? */ 3653 661300 PL_reginput = locinput; 3654 DEBUG_EXECUTE_r( 3655 PerlIO_printf(Perl_debug_log, 3656 "%*s failed, try continuation...\n", 3657 REPORT_CODE_OFF+PL_regindent*2, "") 3658 661300 ); 3659 } 3660 1171774 if (ckWARN(WARN_REGEXP) && n >= REG_INFTY 3661 && !(PL_reg_flags & RF_warned)) { 3662 ###### PL_reg_flags |= RF_warned; 3663 ###### Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded", 3664 "Complex regular subexpression recursion", 3665 REG_INFTY - 1); 3666 } 3667 3668 /* Failed deeper matches of scan, so see if this one works. */ 3669 1171774 PL_regcc = cc->oldcc; 3670 1171774 if (PL_regcc) 3671 104968 ln = PL_regcc->cur; 3672 1171774 if (regmatch(cc->next)) 3673 1054662 CACHEsayYES; 3674 117112 if (PL_regcc) 3675 579 PL_regcc->cur = ln; 3676 117112 PL_regcc = cc; 3677 117112 cc->cur = n - 1; 3678 117112 cc->lastloc = lastloc; 3679 117112 CACHEsayNO; 3680 } 3681 /* NOT REACHED */ 3682 case BRANCHJ: 3683 36 next = scan + ARG(scan); 3684 36 if (next == scan) 3685 ###### next = NULL; 3686 36 inner = NEXTOPER(NEXTOPER(scan)); 3687 36 goto do_branch; 3688 case BRANCH: 3689 1901017 inner = NEXTOPER(scan); 3690 do_branch: 3691 { 3692 1901053 c1 = OP(scan); 3693 1901053 if (OP(next) != c1) /* No choice. */ 3694 ###### next = inner; /* Avoid recursion. */ 3695 else { 3696 1901053 const I32 lastparen = *PL_reglastparen; 3697 1901053 I32 unwind1; 3698 1901053 re_unwind_branch_t *uw; 3699 3700 /* Put unwinding data on stack */ 3701 1901053 unwind1 = SSNEWt(1,re_unwind_branch_t); 3702 1901053 uw = SSPTRt(unwind1,re_unwind_branch_t); 3703 1901053 uw->prev = unwind; 3704 1901053 unwind = unwind1; 3705 1901053 uw->type = ((c1 == BRANCH) 3706 ? RE_UNWIND_BRANCH 3707 : RE_UNWIND_BRANCHJ); 3708 1901053 uw->lastparen = lastparen; 3709 1901053 uw->next = next; 3710 1901053 uw->locinput = locinput; 3711 1901053 uw->nextchr = nextchr; 3712 #ifdef DEBUGGING 3713 1901053 uw->regindent = ++PL_regindent; 3714 #endif 3715 3716 1901053 REGCP_SET(uw->lastcp); 3717 3718 /* Now go into the first branch */ 3719 1901053 next = inner; 3720 } 3721 } 3722 1901053 break; 3723 case MINMOD: 3724 331069 minmod = 1; 3725 331069 break; 3726 case CURLYM: 3727 { 3728 264281 I32 l = 0; 3729 264281 CHECKPOINT lastcp; 3730 3731 /* We suppose that the next guy does not need 3732 backtracking: in particular, it is of constant non-zero length, 3733 and has no parenths to influence future backrefs. */ 3734 264281 ln = ARG1(scan); /* min to match */ 3735 264281 n = ARG2(scan); /* max to match */ 3736 264281 paren = scan->flags; 3737 264281 if (paren) { 3738 122816 if (paren > PL_regsize) 3739 122519 PL_regsize = paren; 3740 122816 if (paren > (I32)*PL_reglastparen) 3741 122554 *PL_reglastparen = paren; 3742 } 3743 264281 scan = NEXTOPER(scan) + NODE_STEP_REGNODE; 3744 264281 if (paren) 3745 122816 scan += NEXT_OFF(scan); /* Skip former OPEN. */ 3746 264281 PL_reginput = locinput; 3747 264281 if (minmod) { 3748 224 minmod = 0; 3749 224 if (ln && regrepeat_hard(scan, ln, &l) < ln) 3750 20 sayNO; 3751 204 locinput = PL_reginput; 3752 204 if (HAS_TEXT(next) || JUMPABLE(next)) { 3753 174 regnode *text_node = next; 3754 3755 174 if (! HAS_TEXT(text_node)) FIND_NEXT_IMPT(text_node); 3756 3757 174 if (! HAS_TEXT(text_node)) c1 = c2 = -1000; 3758 else { 3759 71 if (PL_regkind[(U8)OP(text_node)] == REF) { 3760 60 c1 = c2 = -1000; 3761 60 goto assume_ok_MM; 3762 } 3763 11 else { c1 = (U8)*STRING(text_node); } 3764 11 if (OP(text_node) == EXACTF || OP(text_node) == REFF) 3765 ###### c2 = PL_fold[c1]; 3766 11 else if (OP(text_node) == EXACTFL || OP(text_node) == REFFL) 3767 ###### c2 = PL_fold_locale[c1]; 3768 else 3769 11 c2 = c1; 3770 } 3771 } 3772 else 3773 30 c1 = c2 = -1000; 3774 assume_ok_MM: 3775 204 REGCP_SET(lastcp); 3776 424 while (n >= ln || (n == REG_INFTY && ln > 0)) { /* ln overflow ? */ 3777 /* If it could work, try it. */ 3778 424 if (c1 == -1000 || 3779 UCHARAT(PL_reginput) == c1 || 3780 UCHARAT(PL_reginput) == c2) 3781 { 3782 424 if (paren) { 3783 51 if (ln) { 3784 30 PL_regstartp[paren] = 3785 HOPc(PL_reginput, -l) - PL_bostr; 3786 30 PL_regendp[paren] = PL_reginput - PL_bostr; 3787 } 3788 else 3789 21 PL_regendp[paren] = -1; 3790 } 3791 424 if (regmatch(next)) 3792 184 sayYES; 3793 240 REGCP_UNWIND(lastcp); 3794 } 3795 /* Couldn't or didn't -- move forward. */ 3796 240 PL_reginput = locinput; 3797 240 if (regrepeat_hard(scan, 1, &l)) { 3798 220 ln++; 3799 220 locinput = PL_reginput; 3800 } 3801 else 3802 264057 sayNO; 3803 } 3804 } 3805 else { 3806 264057 n = regrepeat_hard(scan, n, &l); 3807 264057 locinput = PL_reginput; 3808 DEBUG_EXECUTE_r( 3809 PerlIO_printf(Perl_debug_log, 3810 "%*s matched %"IVdf" times, len=%"IVdf"...\n", 3811 (int)(REPORT_CODE_OFF+PL_regindent*2), "", 3812 (IV) n, (IV)l) 3813 264057 ); 3814 264057 if (n >= ln) { 3815 159005 if (HAS_TEXT(next) || JUMPABLE(next)) { 3816 140327 regnode *text_node = next; 3817 3818 140327 if (! HAS_TEXT(text_node)) FIND_NEXT_IMPT(text_node); 3819 3820 140327 if (! HAS_TEXT(text_node)) c1 = c2 = -1000; 3821 else { 3822 111514 if (PL_regkind[(U8)OP(text_node)] == REF) { 3823 60 c1 = c2 = -1000; 3824 60 goto assume_ok_REG; 3825 } 3826 111454 else { c1 = (U8)*STRING(text_node); } 3827 3828 111454 if (OP(text_node) == EXACTF || OP(text_node) == REFF) 3829 141 c2 = PL_fold[c1]; 3830 111313 else if (OP(text_node) == EXACTFL || OP(text_node) == REFFL) 3831 1 c2 = PL_fold_locale[c1]; 3832 else 3833 111312 c2 = c1; 3834 } 3835 } 3836 else 3837 18678 c1 = c2 = -1000; 3838 } 3839 assume_ok_REG: 3840 264057 REGCP_SET(lastcp); 3841 300400 while (n >= ln) { 3842 /* If it could work, try it. */ 3843 159674 if (c1 == -1000 || 3844 UCHARAT(PL_reginput) == c1 || 3845 UCHARAT(PL_reginput) == c2) 3846 { 3847 DEBUG_EXECUTE_r( 3848 PerlIO_printf(Perl_debug_log, 3849 "%*s trying tail with n=%"IVdf"...\n", 3850 (int)(REPORT_CODE_OFF+PL_regindent*2), "", (IV)n) 3851 157852 ); 3852 157852 if (paren) { 3853 122709 if (n) { 3854 10560 PL_regstartp[paren] = HOPc(PL_reginput, -l) - PL_bostr; 3855 10560 PL_regendp[paren] = PL_reginput - PL_bostr; 3856 } 3857 else 3858 112149 PL_regendp[paren] = -1; 3859 } 3860 157852 if (regmatch(next)) 3861 123331 sayYES; 3862 34521 REGCP_UNWIND(lastcp); 3863 } 3864 /* Couldn't or didn't -- back up. */ 3865 36343 n--; 3866 36343 locinput = HOPc(locinput, -l); 3867 36343 PL_reginput = locinput; 3868 } 3869 } 3870 2353 sayNO; 3871 2353 break; 3872 } 3873 case CURLYN: 3874 2353 paren = scan->flags; /* Which paren to set */ 3875 2353 if (paren > PL_regsize) 3876 2143 PL_regsize = paren; 3877 2353 if (paren > (I32)*PL_reglastparen) 3878 2143 *PL_reglastparen = paren; 3879 2353 ln = ARG1(scan); /* min to match */ 3880 2353 n = ARG2(scan); /* max to match */ 3881 2353 scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE); 3882 2353 goto repeat; 3883 case CURLY: 3884 287440 paren = 0; 3885 287440 ln = ARG1(scan); /* min to match */ 3886 287440 n = ARG2(scan); /* max to match */ 3887 287440 scan = NEXTOPER(scan) + NODE_STEP_REGNODE; 3888 287440 goto repeat; 3889 case STAR: 3890 4979568 ln = 0; 3891 4979568 n = REG_INFTY; 3892 4979568 scan = NEXTOPER(scan); 3893 4979568 paren = 0; 3894 4979568 goto repeat; 3895 case PLUS: 3896 7128241 ln = 1; 3897 7128241 n = REG_INFTY; 3898 7128241 scan = NEXTOPER(scan); 3899 7128241 paren = 0; 3900 repeat: 3901 /* 3902 * Lookahead to avoid useless match attempts 3903 * when we know what character comes next. 3904 */ 3905 3906 /* 3907 * Used to only do .*x and .*?x, but now it allows 3908 * for )'s, ('s and (?{ ... })'s to be in the way 3909 * of the quantifier and the EXACT-like node. -- japhy 3910 */ 3911 3912 12397602 if (HAS_TEXT(next) || JUMPABLE(next)) { 3913 9731128 U8 *s; 3914 9731128 regnode *text_node = next; 3915 3916 9731128 if (! HAS_TEXT(text_node)) FIND_NEXT_IMPT(text_node); 3917 3918 9731128 if (! HAS_TEXT(text_node)) c1 = c2 = -1000; 3919 else { 3920 3390621 if (PL_regkind[(U8)OP(text_node)] == REF) { 3921 1795 c1 = c2 = -1000; 3922 1795 goto assume_ok_easy; 3923 } 3924 3388826 else { s = (U8*)STRING(text_node); } 3925 3926 3388826 if (!UTF) { 3927 3388805 c2 = c1 = *s; 3928 3388805 if (OP(text_node) == EXACTF || OP(text_node) == REFF) 3929 273976 c2 = PL_fold[c1]; 3930 3114829 else if (OP(text_node) == EXACTFL || OP(text_node) == REFFL) 3931 ###### c2 = PL_fold_locale[c1]; 3932 } 3933 else { /* UTF */ 3934 21 if (OP(text_node) == EXACTF || OP(text_node) == REFF) { 3935 3 STRLEN ulen1, ulen2; 3936 3 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1]; 3937 3 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1]; 3938 3939 3 to_utf8_lower((U8*)s, tmpbuf1, &ulen1); 3940 3 to_utf8_upper((U8*)s, tmpbuf2, &ulen2); 3941 3942 3 c1 = utf8n_to_uvuni(tmpbuf1, UTF8_MAXBYTES, 0, 3943 ckWARN(WARN_UTF8) ? 3944 0 : UTF8_ALLOW_ANY); 3945 3 c2 = utf8n_to_uvuni(tmpbuf2, UTF8_MAXBYTES, 0, 3946 ckWARN(WARN_UTF8) ? 3947 0 : UTF8_ALLOW_ANY); 3948 } 3949 else { 3950 18 c2 = c1 = utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, 3951 ckWARN(WARN_UTF8) ? 3952 0 : UTF8_ALLOW_ANY); 3953 } 3954 } 3955 } 3956 } 3957 else 3958 2666474 c1 = c2 = -1000; 3959 assume_ok_easy: 3960 12397602 PL_reginput = locinput; 3961 12397602 if (minmod) { 3962 330231 CHECKPOINT lastcp; 3963 330231 minmod = 0; 3964 330231 if (ln && regrepeat(scan, ln) < ln) 3965 24 sayNO; 3966 330207 locinput = PL_reginput; 3967 330207 REGCP_SET(lastcp); 3968 330207 if (c1 != -1000) { 3969 283692 char *e; /* Should not check after this */ 3970 283692 char *old = locinput; 3971 283692 int count = 0; 3972 3973 283692 if (n == REG_INFTY) { 3974 283602 e = PL_regeol - 1; 3975 283602 if (do_utf8) 3976 28 while (UTF8_IS_CONTINUATION(*(U8*)e)) 3977 3 e--; 3978 } 3979 90 else if (do_utf8) { 3980 ###### int m = n - ln; 3981 ###### for (e = locinput; 3982 m >0 && e + UTF8SKIP(e) <= PL_regeol; m--) 3983 ###### e += UTF8SKIP(e); 3984 } 3985 else { 3986 90 e = locinput + n - ln; 3987 90 if (e >= PL_regeol) 3988 10 e = PL_regeol - 1; 3989 } 3990 285481 while (1) { 3991 /* Find place 'next' could work */ 3992 285481 if (!do_utf8) { 3993 285456 if (c1 == c2) { 3994 809550 while (locinput <= e && 3995 UCHARAT(locinput) != c1) 3996 524384 locinput++; 3997 } else { 3998 360 while (locinput <= e 3999 && UCHARAT(locinput) != c1 4000 && UCHARAT(locinput) != c2) 4001 70 locinput++; 4002 } 4003 285456 count = locinput - old; 4004 } 4005 else { 4006 25 if (c1 == c2) { 4007 829 STRLEN len; 4008 /* count initialised to 4009 * utf8_distance(old, locinput) */ 4010 829 while (locinput <= e && 4011 utf8n_to_uvchr((U8*)locinput, 4012 UTF8_MAXBYTES, &len, 4013 ckWARN(WARN_UTF8) ? 4014 0 : UTF8_ALLOW_ANY) != (UV)c1) { 4015 804 locinput += len; 4016 804 count++; 4017 } 4018 } else { 4019 ###### STRLEN len; 4020 /* count initialised to 4021 * utf8_distance(old, locinput) */ 4022 ###### while (locinput <= e) { 4023 ###### UV c = utf8n_to_uvchr((U8*)locinput, 4024 UTF8_MAXBYTES, &len, 4025 ckWARN(WARN_UTF8) ? 4026 ###### 0 : UTF8_ALLOW_ANY); 4027 ###### if (c == (UV)c1 || c == (UV)c2) 4028 ###### break; 4029 ###### locinput += len; 4030 ###### count++; 4031 } 4032 } 4033 } 4034 285481 if (locinput > e) 4035 99 sayNO; 4036 /* PL_reginput == old now */ 4037 285382 if (locinput != old) { 4038 192938 ln = 1; /* Did some */ 4039 192938 if (regrepeat(scan, count) < count) 4040 194 sayNO; 4041 } 4042 /* PL_reginput == locinput now */ 4043 285188 TRYPAREN(paren, ln, locinput); 4044 1789 PL_reginput = locinput; /* Could be reset... */ 4045 1789 REGCP_UNWIND(lastcp); 4046 /* Couldn't or didn't -- move forward. */ 4047 1789 old = locinput; 4048 1789 if (do_utf8) 4049 ###### locinput += UTF8SKIP(locinput); 4050 else 4051 1789 locinput++; 4052 1789 count = 1; 4053 } 4054 } 4055 else 4056 449803 while (n >= ln || (n == REG_INFTY && ln > 0)) { /* ln overflow ? */ 4057 449803 UV c; 4058 449803 if (c1 != -1000) { 4059 ###### if (do_utf8) 4060 ###### c = utf8n_to_uvchr((U8*)PL_reginput, 4061 UTF8_MAXBYTES, 0, 4062 ckWARN(WARN_UTF8) ? 4063 0 : UTF8_ALLOW_ANY); 4064 else 4065 ###### c = UCHARAT(PL_reginput); 4066 /* If it could work, try it. */ 4067 ###### if (c == (UV)c1 || c == (UV)c2) 4068 { 4069 ###### TRYPAREN(paren, ln, PL_reginput); 4070 ###### REGCP_UNWIND(lastcp); 4071 } 4072 } 4073 /* If it could work, try it. */ 4074 449803 else if (c1 == -1000) 4075 { 4076 449803 TRYPAREN(paren, ln, PL_reginput); 4077 406275 REGCP_UNWIND(lastcp); 4078 } 4079 /* Couldn't or didn't -- move forward. */ 4080 406275 PL_reginput = locinput; 4081 406275 if (regrepeat(scan, 1)) { 4082 403288 ln++; 4083 403288 locinput = PL_reginput; 4084 } 4085 else 4086 12067371 sayNO; 4087 } 4088 } 4089 else { 4090 12067371 CHECKPOINT lastcp; 4091 12067371 n = regrepeat(scan, n); 4092 12067371 locinput = PL_reginput; 4093 12067371 if (ln < n && PL_regkind[(U8)OP(next)] == EOL && 4094 (OP(next) != MEOL || 4095 OP(next) == SEOL || OP(next) == EOS)) 4096 { 4097 383154 ln = n; /* why back off? */ 4098 /* ...because $ and \Z can match before *and* after 4099 newline at the end. Consider "\n\n" =~ /\n+\Z\n/. 4100 We should back off by one in this case. */ 4101 383154 if (UCHARAT(PL_reginput - 1) == '\n' && OP(next) != EOS) 4102 25349 ln--; 4103 } 4104 12067371 REGCP_SET(lastcp); 4105 12067371 if (paren) { 4106 2343 UV c = 0; 4107 2711 while (n >= ln) { 4108 2445 if (c1 != -1000) { 4109 244 if (do_utf8) 4110 3 c = utf8n_to_uvchr((U8*)PL_reginput, 4111 UTF8_MAXBYTES, 0, 4112 ckWARN(WARN_UTF8) ? 4113 0 : UTF8_ALLOW_ANY); 4114 else 4115 241 c = UCHARAT(PL_reginput); 4116 } 4117 /* If it could work, try it. */ 4118 2445 if (c1 == -1000 || c == (UV)c1 || c == (UV)c2) 4119 { 4120 2325 TRYPAREN(paren, n, PL_reginput); 4121 248 REGCP_UNWIND(lastcp); 4122 } 4123 /* Couldn't or didn't -- back up. */ 4124 368 n--; 4125 368 PL_reginput = locinput = HOPc(locinput, -1); 4126 } 4127 } 4128 else { 4129 12065028 UV c = 0; 4130 32332741 while (n >= ln) { 4131 27088717 if (c1 != -1000) { 4132 18877035 if (do_utf8) 4133 1457 c = utf8n_to_uvchr((U8*)PL_reginput, 4134 UTF8_MAXBYTES, 0, 4135 ckWARN(WARN_UTF8) ? 4136 0 : UTF8_ALLOW_ANY); 4137 else 4138 18875578 c = UCHARAT(PL_reginput); 4139 } 4140 /* If it could work, try it. */ 4141 27088717 if (c1 == -1000 || c == (UV)c1 || c == (UV)c2) 4142 { 4143 9524742 TRYPAREN(paren, n, PL_reginput); 4144 2703738 REGCP_UNWIND(lastcp); 4145 } 4146 /* Couldn't or didn't -- back up. */ 4147 20267713 n--; 4148 20267713 PL_reginput = locinput = HOPc(locinput, -1); 4149 } 4150 } 4151 } 4152 7384519 sayNO; 4153 7384519 break; 4154 case END: 4155 7384519 if (PL_reg_call_cc) { 4156 5544 re_cc_state *cur_call_cc = PL_reg_call_cc; 4157 5544 CURCUR *cctmp = PL_regcc; 4158 5544 regexp *re = PL_reg_re; 4159 5544 CHECKPOINT cp, lastcp; 4160 4161 5544 cp = regcppush(0); /* Save *all* the positions. */ 4162 5544 REGCP_SET(lastcp); 4163 5544 regcp_set_to(PL_reg_call_cc->ss); /* Restore parens of 4164 the caller. */ 4165 5544 PL_reginput = locinput; /* Make position available to 4166 the callcc. */ 4167 5544 cache_re(PL_reg_call_cc->re); 4168 5544 PL_regcc = PL_reg_call_cc->cc; 4169 5544 PL_reg_call_cc = PL_reg_call_cc->prev; 4170 5544 if (regmatch(cur_call_cc->node)) { 4171 4319 PL_reg_call_cc = cur_call_cc; 4172 4319 regcpblow(cp); 4173 4319 sayYES; 4174 } 4175 1225 REGCP_UNWIND(lastcp); 4176 1225 regcppop(); 4177 1225 PL_reg_call_cc = cur_call_cc; 4178 1225 PL_regcc = cctmp; 4179 1225 PL_reg_re = re; 4180 1225 cache_re(re); 4181 4182 DEBUG_EXECUTE_r( 4183 PerlIO_printf(Perl_debug_log, 4184 "%*s continuation failed...\n", 4185 REPORT_CODE_OFF+PL_regindent*2, "") 4186 1225 ); 4187 ###### sayNO_SILENT; 4188 } 4189 7378975 if (locinput < PL_regtill) { 4190 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, 4191 "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n", 4192 PL_colors[4], 4193 (long)(locinput - PL_reg_starttry), 4194 (long)(PL_regtill - PL_reg_starttry), 4195 175504 PL_colors[5])); 4196 ###### sayNO_FINAL; /* Cannot match: too short. */ 4197 } 4198 7203471 PL_reginput = locinput; /* put where regtry can find it */ 4199 7203471 sayYES_FINAL; /* Success! */ 4200 case SUCCEED: 4201 457133 PL_reginput = locinput; /* put where regtry can find it */ 4202 457133 sayYES_LOUD; /* Success! */ 4203 case SUSPEND: 4204 12899 n = 1; 4205 12899 PL_reginput = locinput; 4206 12899 goto do_ifmatch; 4207 case UNLESSM: 4208 767290 n = 0; 4209 767290 if (scan->flags) { 4210 383454 s = HOPBACKc(locinput, scan->flags); 4211 383454 if (!s) 4212 729 goto say_yes; 4213 382725 PL_reginput = s; 4214 } 4215 else 4216 383836 PL_reginput = locinput; 4217 383836 goto do_ifmatch; 4218 case IFMATCH: 4219 48763 n = 1; 4220 48763 if (scan->flags) { 4221 31949 s = HOPBACKc(locinput, scan->flags); 4222 31949 if (!s) 4223 2175 goto say_no; 4224 29774 PL_reginput = s; 4225 } 4226 else 4227 16814 PL_reginput = locinput; 4228 4229 do_ifmatch: 4230 826048 inner = NEXTOPER(NEXTOPER(scan)); 4231 826048 if (regmatch(inner) != n) { 4232 say_no: 4233 300928 if (logical) { 4234 30 logical = 0; 4235 30 sw = 0; 4236 30 goto do_longjump; 4237 } 4238 else 4239 528024 sayNO; 4240 } 4241 say_yes: 4242 528024 if (logical) { 4243 30 logical = 0; 4244 30 sw = 1; 4245 } 4246 528024 if (OP(scan) == SUSPEND) { 4247 6494 locinput = PL_reginput; 4248 6494 nextchr = UCHARAT(locinput); 4249 } 4250 /* FALL THROUGH. */ 4251 case LONGJMP: 4252 do_longjump: 4253 528072 next = scan + ARG(scan); 4254 528072 if (next == scan) 4255 ###### next = NULL; 4256 ###### break; 4257 default: 4258 ###### PerlIO_printf(Perl_error_log, "%"UVxf" %d\n", 4259 PTR2UV(scan), OP(scan)); 4260 ###### Perl_croak(aTHX_ "regexp memory corruption"); 4261 } 4262 reenter: 4263 34154956 scan = next; 4264 } 4265 4266 /* 4267 * We get here only if there's trouble -- normally "case END" is 4268 * the terminating point. 4269 */ 4270 ###### Perl_croak(aTHX_ "corrupted regexp pointers"); 4271 /*NOTREACHED*/ 4272 457133 sayNO; 4273 4274 yes_loud: 4275 DEBUG_EXECUTE_r( 4276 PerlIO_printf(Perl_debug_log, 4277 "%*s %scould match...%s\n", 4278 REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4], PL_colors[5]) 4279 457133 ); 4280 ###### goto yes; 4281 yes_final: 4282 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n", 4283 7203471 PL_colors[4], PL_colors[5])); 4284 yes: 4285 #ifdef DEBUGGING 4286 17613253 PL_regindent--; 4287 #endif 4288 4289 #if 0 /* Breaks $^R */ 4290 if (unwind) 4291 regcpblow(firstcp); 4292 #endif 4293 17613253 return 1; 4294 4295 no: 4296 DEBUG_EXECUTE_r( 4297 PerlIO_printf(Perl_debug_log, 4298 "%*s %sfailed...%s\n", 4299 REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4], PL_colors[5]) 4300 13791480 ); 4301 goto do_no; 4302 no_final: 4303 do_no: 4304 15853523 if (unwind) { 4305 4513775 re_unwind_t *uw = SSPTRt(unwind,re_unwind_t); 4306 4307 4513775 switch (uw->type) { 4308 case RE_UNWIND_BRANCH: 4309 case RE_UNWIND_BRANCHJ: 4310 { 4311 4513775 re_unwind_branch_t *uwb = &(uw->branch); 4312 4513775 const I32 lastparen = uwb->lastparen; 4313 4314 4513775 REGCP_UNWIND(uwb->lastcp); 4315 4528858 for (n = *PL_reglastparen; n > lastparen; n--) 4316 15083 PL_regendp[n] = -1; 4317 4513775 *PL_reglastparen = n; 4318 4513775 scan = next = uwb->next; 4319 4513775 if ( !scan || 4320 OP(scan) != (uwb->type == RE_UNWIND_BRANCH 4321 ? BRANCH : BRANCHJ) ) { /* Failure */ 4322 1802104 unwind = uwb->prev; 4323 #ifdef DEBUGGING 4324 1802104 PL_regindent--; 4325 #endif 4326 1802104 goto do_no; 4327 } 4328 /* Have more choice yet. Reuse the same uwb. */ 4329 2711671 if ((n = (uwb->type == RE_UNWIND_BRANCH 4330 ? NEXT_OFF(next) : ARG(next)))) 4331 2711671 next += n; 4332 else 4333 ###### next = NULL; /* XXXX Needn't unwinding in this case... */ 4334 2711671 uwb->next = next; 4335 2711671 next = NEXTOPER(scan); 4336 2711671 if (uwb->type == RE_UNWIND_BRANCHJ) 4337 552876 next = NEXTOPER(next); 4338 2711671 locinput = uwb->locinput; 4339 2711671 nextchr = uwb->nextchr; 4340 #ifdef DEBUGGING 4341 2711671 PL_regindent = uwb->regindent; 4342 #endif 4343 4344 2711671 goto reenter; 4345 } 4346 /* NOT REACHED */ 4347 default: 4348 ###### Perl_croak(aTHX_ "regexp unwind memory corruption"); 4349 } 4350 /* NOT REACHED */ 4351 } 4352 #ifdef DEBUGGING 4353 11339748 PL_regindent--; 4354 #endif 4355 11339748 return 0; 4356 } 4357 4358 /* 4359 - regrepeat - repeatedly match something simple, report how many 4360 */ 4361 /* 4362 * [This routine now assumes that it will only match on things of length 1. 4363 * That was true before, but now we assume scan - reginput is the count, 4364 * rather than incrementing count on every character. [Er, except utf8.]] 4365 */ 4366 STATIC I32 4367 S_regrepeat(pTHX_ const regnode *p, I32 max) 4368 12672339 { 4369 dVAR; 4370 12672339 register char *scan; 4371 12672339 register I32 c; 4372 12672339 register char *loceol = PL_regeol; 4373 12672339 register I32 hardcount = 0; 4374 12672339 register bool do_utf8 = PL_reg_match_utf8; 4375 4376 12672339 scan = PL_reginput; 4377 12672339 if (max == REG_INFTY) 4378 11791681 max = I32_MAX; 4379 880658 else if (max < loceol - scan) 4380 824062 loceol = scan + max; 4381 12672339 switch (OP(p)) { 4382 case REG_ANY: 4383 1045418 if (do_utf8) { 4384 35 loceol = PL_regeol; 4385 965 while (scan < loceol && hardcount < max && *scan != '\n') { 4386 930 scan += UTF8SKIP(scan); 4387 930 hardcount++; 4388 } 4389 } else { 4390 10879832 while (scan < loceol && *scan != '\n') 4391 9834449 scan++; 4392 } 4393 175461 break; 4394 case SANY: 4395 175461 if (do_utf8) { 4396 9 loceol = PL_regeol; 4397 22 while (scan < loceol && hardcount < max) { 4398 13 scan += UTF8SKIP(scan); 4399 13 hardcount++; 4400 } 4401 } 4402 else 4403 175452 scan = loceol; 4404 175452 break; 4405 case CANY: 4406 11 scan = loceol; 4407 11 break; 4408 case EXACT: /* length of string is 1 */ 4409 566018 c = (U8)*STRING(p); 4410 829491 while (scan < loceol && UCHARAT(scan) == c) 4411 263473 scan++; 4412 6177 break; 4413 case EXACTF: /* length of string is 1 */ 4414 6177 c = (U8)*STRING(p); 4415 8812 while (scan < loceol && 4416 (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold[c])) 4417 2635 scan++; 4418 ###### break; 4419 case EXACTFL: /* length of string is 1 */ 4420 ###### PL_reg_flags |= RF_tainted; 4421 ###### c = (U8)*STRING(p); 4422 ###### while (scan < loceol && 4423 (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold_locale[c])) 4424 ###### scan++; 4425 5258084 break; 4426 case ANYOF: 4427 5258084 if (do_utf8) { 4428 48521 loceol = PL_regeol; 4429 1609686 while (hardcount < max && scan < loceol && 4430 reginclass(p, (U8*)scan, 0, do_utf8)) { 4431 1561165 scan += UTF8SKIP(scan); 4432 1561165 hardcount++; 4433 } 4434 } else { 4435 32094273 while (scan < loceol && REGINCLASS(p, (U8*)scan)) 4436 26884710 scan++; 4437 } 4438 204146 break; 4439 case ALNUM: 4440 204146 if (do_utf8) { 4441 124 loceol = PL_regeol; 4442 124 LOAD_UTF8_CHARCLASS_ALNUM(); 4443 417 while (hardcount < max && scan < loceol && 4444 swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) { 4445 293 scan += UTF8SKIP(scan); 4446 293 hardcount++; 4447 } 4448 } else { 4449 1438040 while (scan < loceol && isALNUM(*scan)) 4450 1234018 scan++; 4451 } 4452 194 break; 4453 case ALNUML: 4454 194 PL_reg_flags |= RF_tainted; 4455 194 if (do_utf8) { 4456 ###### loceol = PL_regeol; 4457 ###### while (hardcount < max && scan < loceol && 4458 isALNUM_LC_utf8((U8*)scan)) { 4459 ###### scan += UTF8SKIP(scan); 4460 ###### hardcount++; 4461 } 4462 } else { 4463 11861 while (scan < loceol && isALNUM_LC(*scan)) 4464 11667 scan++; 4465 } 4466 412 break; 4467 case NALNUM: 4468 412 if (do_utf8) { 4469 ###### loceol = PL_regeol; 4470 ###### LOAD_UTF8_CHARCLASS_ALNUM(); 4471 ###### while (hardcount < max && scan < loceol && 4472 !swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) { 4473 ###### scan += UTF8SKIP(scan); 4474 ###### hardcount++; 4475 } 4476 } else { 4477 792 while (scan < loceol && !isALNUM(*scan)) 4478 380 scan++; 4479 } 4480 ###### break; 4481 case NALNUML: 4482 ###### PL_reg_flags |= RF_tainted; 4483 ###### if (do_utf8) { 4484 ###### loceol = PL_regeol; 4485 ###### while (hardcount < max && scan < loceol && 4486 !isALNUM_LC_utf8((U8*)scan)) { 4487 ###### scan += UTF8SKIP(scan); 4488 ###### hardcount++; 4489 } 4490 } else { 4491 ###### while (scan < loceol && !isALNUM_LC(*scan)) 4492 ###### scan++; 4493 } 4494 3557416 break; 4495 case SPACE: 4496 3557416 if (do_utf8) { 4497 41 loceol = PL_regeol; 4498 41 LOAD_UTF8_CHARCLASS_SPACE(); 4499 79 while (hardcount < max && scan < loceol && 4500 (*scan == ' ' || 4501 swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) { 4502 38 scan += UTF8SKIP(scan); 4503 38 hardcount++; 4504 } 4505 } else { 4506 5748638 while (scan < loceol && isSPACE(*scan)) 4507 2191263 scan++; 4508 } 4509 3073 break; 4510 case SPACEL: 4511 3073 PL_reg_flags |= RF_tainted; 4512 3073 if (do_utf8) { 4513 ###### loceol = PL_regeol; 4514 ###### while (hardcount < max && scan < loceol && 4515 (*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) { 4516 ###### scan += UTF8SKIP(scan); 4517 ###### hardcount++; 4518 } 4519 } else { 4520 5364 while (scan < loceol && isSPACE_LC(*scan)) 4521 2291 scan++; 4522 } 4523 845081 break; 4524 case NSPACE: 4525 845081 if (do_utf8) { 4526 7 loceol = PL_regeol; 4527 7 LOAD_UTF8_CHARCLASS_SPACE(); 4528 47 while (hardcount < max && scan < loceol && 4529 !(*scan == ' ' || 4530 swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) { 4531 40 scan += UTF8SKIP(scan); 4532 40 hardcount++; 4533 } 4534 } else { 4535 5503649 while (scan < loceol && !isSPACE(*scan)) 4536 4658575 scan++; 4537 10 break; 4538 } 4539 case NSPACEL: 4540 10 PL_reg_flags |= RF_tainted; 4541 10 if (do_utf8) { 4542 7 loceol = PL_regeol; 4543 7 while (hardcount < max && scan < loceol && 4544 !(*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) { 4545 ###### scan += UTF8SKIP(scan); 4546 ###### hardcount++; 4547 } 4548 } else { 4549 15 while (scan < loceol && !isSPACE_LC(*scan)) 4550 12 scan++; 4551 } 4552 1010835 break; 4553 case DIGIT: 4554 1010835 if (do_utf8) { 4555 1 loceol = PL_regeol; 4556 1 LOAD_UTF8_CHARCLASS_DIGIT(); 4557 2 while (hardcount < max && scan < loceol && 4558 swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) { 4559 1 scan += UTF8SKIP(scan); 4560 1 hardcount++; 4561 } 4562 } else { 4563 1575243 while (scan < loceol && isDIGIT(*scan)) 4564 564409 scan++; 4565 } 4566 8 break; 4567 case NDIGIT: 4568 8 if (do_utf8) { 4569 ###### loceol = PL_regeol; 4570 ###### LOAD_UTF8_CHARCLASS_DIGIT(); 4571 ###### while (hardcount < max && scan < loceol && 4572 !swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) { 4573 ###### scan += UTF8SKIP(scan); 4574 ###### hardcount++; 4575 } 4576 } else { 4577 38 while (scan < loceol && !isDIGIT(*scan)) 4578 30 scan++; 4579 } 4580 12672339 break; 4581 default: /* Called on something of 0 width. */ 4582 12672339 break; /* So match right here or not at all. */ 4583 } 4584 4585 12672339 if (hardcount) 4586 14151 c = hardcount; 4587 else 4588 12658188 c = scan - PL_reginput; 4589 12672339 PL_reginput = scan; 4590 4591 DEBUG_r({ 4592 SV *re_debug_flags = NULL; 4593 SV *prop = sv_newmortal(); 4594 GET_RE_DEBUG_FLAGS; 4595 DEBUG_EXECUTE_r({ 4596 regprop(prop, p); 4597 PerlIO_printf(Perl_debug_log, 4598 "%*s %s can match %"IVdf" times out of %"IVdf"...\n", 4599 REPORT_CODE_OFF+1, "", SvPVX_const(prop),(IV)c,(IV)max); 4600 }); 4601 12672339 }); 4602 4603 12672339 return(c); 4604 } 4605 4606 /* 4607 - regrepeat_hard - repeatedly match something, report total lenth and length 4608 * 4609 * The repeater is supposed to have constant non-zero length. 4610 */ 4611 4612 STATIC I32 4613 S_regrepeat_hard(pTHX_ regnode *p, I32 max, I32 *lp) 4614 264490 { 4615 264490 register char *scan = Nullch; 4616 264490 register char *start; 4617 264490 register char *loceol = PL_regeol; 4618 264490 I32 l = 0; 4619 264490 I32 count = 0, res = 1; 4620 4621 264490 if (!max) 4622 ###### return 0; 4623 4624 264490 start = PL_reginput; 4625 264490 if (PL_reg_match_utf8) { 4626 8031 while (PL_reginput < loceol && (scan = PL_reginput, res = regmatch(p))) { 4627 7477 if (!count++) { 4628 259 l = 0; 4629 767 while (start < PL_reginput) { 4630 508 l++; 4631 508 start += UTF8SKIP(start); 4632 } 4633 259 *lp = l; 4634 259 if (l == 0) 4635 ###### return max; 4636 } 4637 7477 if (count == max) 4638 7 return count; 4639 } 4640 } 4641 else { 4642 394007 while (PL_reginput < loceol && (scan = PL_reginput, res = regmatch(p))) { 4643 130078 if (!count++) { 4644 16022 *lp = l = PL_reginput - start; 4645 16022 if (max != REG_INFTY && l*max < loceol - scan) 4646 1532 loceol = scan + l*max; 4647 16022 if (l == 0) 4648 ###### return max; 4649 } 4650 } 4651 } 4652 264483 if (!res) 4653 258007 PL_reginput = scan; 4654 4655 264483 return count; 4656 } 4657 4658 /* 4659 - regclass_swash - prepare the utf8 swash 4660 */ 4661 4662 SV * 4663 Perl_regclass_swash(pTHX_ register const regnode* node, bool doinit, SV** listsvp, SV **altsvp) 4664 2442710 { 4665 2442710 SV *sw = NULL; 4666 2442710 SV *si = NULL; 4667 2442710 SV *alt = NULL; 4668 4669 2442710 if (PL_regdata && PL_regdata->count) { 4670 2442710 const U32 n = ARG(node); 4671 4672 2442710 if (PL_regdata->what[n] == 's') { 4673 2442707 SV *rv = (SV*)PL_regdata->data[n]; 4674 2442707 AV *av = (AV*)SvRV((SV*)rv); 4675 2442707 SV **ary = AvARRAY(av); 4676 2442707 SV **a, **b; 4677 4678 /* See the end of regcomp.c:S_reglass() for 4679 * documentation of these array elements. */ 4680 4681 2442707 si = *ary; 4682 2442707 a = SvTYPE(ary[1]) == SVt_RV ? &ary[1] : 0; 4683 2442707 b = SvTYPE(ary[2]) == SVt_PVAV ? &ary[2] : 0; 4684 4685 2442707 if (a) 4686 2434459 sw = *a; 4687 8248 else if (si && doinit) { 4688 8248 sw = swash_init("utf8", "", si, 1, 0); 4689 8248 (void)av_store(av, 1, sw); 4690 } 4691 2442707 if (b) 4692 212 alt = *b; 4693 } 4694 } 4695 4696 2442710 if (listsvp) 4697 ###### *listsvp = si; 4698 2442710 if (altsvp) 4699 2442710 *altsvp = alt; 4700 4701 2442710 return sw; 4702 } 4703 4704 /* 4705 - reginclass - determine if a character falls into a character class 4706 4707 The n is the ANYOF regnode, the p is the target string, lenp 4708 is pointer to the maximum length of how far to go in the p 4709 (if the lenp is zero, UTF8SKIP(p) is used), 4710 do_utf8 tells whether the target string is in UTF-8. 4711 4712 */ 4713 4714 STATIC bool 4715 S_reginclass(pTHX_ register const regnode *n, register const U8* p, STRLEN* lenp, register bool do_utf8) 4716 10774669 { 4717 dVAR; 4718 10774669 const char flags = ANYOF_FLAGS(n); 4719 10774669 bool match = FALSE; 4720 10774669 UV c = *p; 4721 10774669 STRLEN len = 0; 4722 10774669 STRLEN plen; 4723 4724 10774669 if (do_utf8 && !UTF8_IS_INVARIANT(c)) 4725 2476337 c = utf8n_to_uvchr(p, UTF8_MAXBYTES, &len, 4726 ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY); 4727 4728 10774669 plen = lenp ? *lenp : UNISKIP(NATIVE_TO_UNI(c)); 4729 10774669 if (do_utf8 || (flags & ANYOF_UNICODE)) { 4730 2834425 if (lenp) 4731 22504 *lenp = 0; 4732 2834425 if (do_utf8 && !ANYOF_RUNTIME(n)) { 4733 2814335 if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c)) 4734 330803 match = TRUE; 4735 } 4736 2834425 if (!match && do_utf8 && (flags & ANYOF_UNICODE_ALL) && c >= 256) 4737 60912 match = TRUE; 4738 2834425 if (!match) { 4739 2442710 AV *av; 4740 2442710 SV *sw = regclass_swash(n, TRUE, 0, (SV**)&av); 4741 4742 2442710 if (sw) { 4743 2442707 if (swash_fetch(sw, p, do_utf8)) 4744 1201878 match = TRUE; 4745 1240829 else if (flags & ANYOF_FOLD) { 4746 1116 if (!match && lenp && av) { 4747 103 I32 i; 4748 4749 103 for (i = 0; i <= av_len(av); i++) { 4750 103 SV* sv = *av_fetch(av, i, FALSE); 4751 103 STRLEN len; 4752 103 const char *s = SvPV_const(sv, len); 4753 4754 103 if (len <= plen && memEQ(s, (char*)p, len)) { 4755 103 *lenp = len; 4756 103 match = TRUE; 4757 103 break; 4758 } 4759 } 4760 } 4761 1116 if (!match) { 4762 1013 U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; 4763 1013 STRLEN tmplen; 4764 4765 1013 to_utf8_fold(p, tmpbuf, &tmplen); 4766 1013 if (swash_fetch(sw, tmpbuf, do_utf8)) 4767 998 match = TRUE; 4768 } 4769 } 4770 } 4771 } 4772 2834425 if (match && lenp && *lenp == 0) 4773 19997 *lenp = UNISKIP(NATIVE_TO_UNI(c)); 4774 } 4775 10774669 if (!match && c < 256) { 4776 7959215 if (ANYOF_BITMAP_TEST(n, c)) 4777 4373287 match = TRUE; 4778 3585928 else if (flags & ANYOF_FOLD) { 4779 8253 U8 f; 4780 4781 8253 if (flags & ANYOF_LOCALE) { 4782 24 PL_reg_flags |= RF_tainted; 4783 24 f = PL_fold_locale[c]; 4784 } 4785 else 4786 8229 f = PL_fold[c]; 4787 8253 if (f != c && ANYOF_BITMAP_TEST(n, f)) 4788 96 match = TRUE; 4789 } 4790 4791 7959215 if (!match && (flags & ANYOF_CLASS)) { 4792 100324 PL_reg_flags |= RF_tainted; 4793 100324 if ( 4794 (ANYOF_CLASS_TEST(n, ANYOF_ALNUM) && isALNUM_LC(c)) || 4795 (ANYOF_CLASS_TEST(n, ANYOF_NALNUM) && !isALNUM_LC(c)) || 4796 (ANYOF_CLASS_TEST(n, ANYOF_SPACE) && isSPACE_LC(c)) || 4797 (ANYOF_CLASS_TEST(n, ANYOF_NSPACE) && !isSPACE_LC(c)) || 4798 (ANYOF_CLASS_TEST(n, ANYOF_DIGIT) && isDIGIT_LC(c)) || 4799 (ANYOF_CLASS_TEST(n, ANYOF_NDIGIT) && !isDIGIT_LC(c)) || 4800 (ANYOF_CLASS_TEST(n, ANYOF_ALNUMC) && isALNUMC_LC(c)) || 4801 (ANYOF_CLASS_TEST(n, ANYOF_NALNUMC) && !isALNUMC_LC(c)) || 4802 (ANYOF_CLASS_TEST(n, ANYOF_ALPHA) && isALPHA_LC(c)) || 4803 (ANYOF_CLASS_TEST(n, ANYOF_NALPHA) && !isALPHA_LC(c)) || 4804 (ANYOF_CLASS_TEST(n, ANYOF_ASCII) && isASCII(c)) || 4805 (ANYOF_CLASS_TEST(n, ANYOF_NASCII) && !isASCII(c)) || 4806 (ANYOF_CLASS_TEST(n, ANYOF_CNTRL) && isCNTRL_LC(c)) || 4807 (ANYOF_CLASS_TEST(n, ANYOF_NCNTRL) && !isCNTRL_LC(c)) || 4808 (ANYOF_CLASS_TEST(n, ANYOF_GRAPH) && isGRAPH_LC(c)) || 4809 (ANYOF_CLASS_TEST(n, ANYOF_NGRAPH) && !isGRAPH_LC(c)) || 4810 (ANYOF_CLASS_TEST(n, ANYOF_LOWER) && isLOWER_LC(c)) || 4811 (ANYOF_CLASS_TEST(n, ANYOF_NLOWER) && !isLOWER_LC(c)) || 4812 (ANYOF_CLASS_TEST(n, ANYOF_PRINT) && isPRINT_LC(c)) || 4813 (ANYOF_CLASS_TEST(n, ANYOF_NPRINT) && !isPRINT_LC(c)) || 4814 (ANYOF_CLASS_TEST(n, ANYOF_PUNCT) && isPUNCT_LC(c)) || 4815 (ANYOF_CLASS_TEST(n, ANYOF_NPUNCT) && !isPUNCT_LC(c)) || 4816 (ANYOF_CLASS_TEST(n, ANYOF_UPPER) && isUPPER_LC(c)) || 4817 (ANYOF_CLASS_TEST(n, ANYOF_NUPPER) && !isUPPER_LC(c)) || 4818 (ANYOF_CLASS_TEST(n, ANYOF_XDIGIT) && isXDIGIT(c)) || 4819 (ANYOF_CLASS_TEST(n, ANYOF_NXDIGIT) && !isXDIGIT(c)) || 4820 (ANYOF_CLASS_TEST(n, ANYOF_PSXSPC) && isPSXSPC(c)) || 4821 (ANYOF_CLASS_TEST(n, ANYOF_NPSXSPC) && !isPSXSPC(c)) || 4822 (ANYOF_CLASS_TEST(n, ANYOF_BLANK) && isBLANK(c)) || 4823 (ANYOF_CLASS_TEST(n, ANYOF_NBLANK) && !isBLANK(c)) 4824 ) /* How's that for a conditional? */ 4825 { 4826 5078 match = TRUE; 4827 } 4828 } 4829 } 4830 4831 10774669 return (flags & ANYOF_INVERT) ? !match : match; 4832 } 4833 4834 STATIC U8 * 4835 S_reghop(pTHX_ U8 *s, I32 off) 4836 11803 { 4837 11803 return S_reghop3(aTHX_ s, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr)); 4838 } 4839 4840 STATIC U8 * 4841 S_reghop3(pTHX_ U8 *s, I32 off, U8* lim) 4842 30001 { 4843 30001 if (off >= 0) { 4844 19935 while (off-- && s < lim) { 4845 /* XXX could check well-formedness here */ 4846 313 s += UTF8SKIP(s); 4847 } 4848 } 4849 else { 4850 30118 while (off++) { 4851 19739 if (s > lim) { 4852 19476 s--; 4853 19476 if (UTF8_IS_CONTINUED(*s)) { 4854 10558 while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s)) 4855 6419 s--; 4856 } 4857 /* XXX could check well-formedness here */ 4858 } 4859 } 4860 } 4861 30001 return s; 4862 } 4863 4864 STATIC U8 * 4865 S_reghopmaybe(pTHX_ U8 *s, I32 off) 4866 4 { 4867 4 return S_reghopmaybe3(aTHX_ s, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr)); 4868 } 4869 4870 STATIC U8 * 4871 S_reghopmaybe3(pTHX_ U8* s, I32 off, U8* lim) 4872 97 { 4873 97 if (off >= 0) { 4874 80 while (off-- && s < lim) { 4875 /* XXX could check well-formedness here */ 4876 ###### s += UTF8SKIP(s); 4877 } 4878 80 if (off >= 0) 4879 ###### return 0; 4880 } 4881 else { 4882 47 while (off++) { 4883 30 if (s > lim) { 4884 30 s--; 4885 30 if (UTF8_IS_CONTINUED(*s)) { 4886 41 while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s)) 4887 23 s--; 4888 } 4889 /* XXX could check well-formedness here */ 4890 } 4891 else 4892 17 break; 4893 } 4894 17 if (off <= 0) 4895 ###### return 0; 4896 } 4897 97 return s; 4898 } 4899 4900 static void 4901 restore_pos(pTHX_ void *arg) 4902 7635 { 4903 7635 PERL_UNUSED_ARG(arg); 4904 7635 if (PL_reg_eval_set) { 4905 3816 if (PL_reg_oldsaved) { 4906 2460 PL_reg_re->subbeg = PL_reg_oldsaved; 4907 2460 PL_reg_re->sublen = PL_reg_oldsavedlen; 4908 #ifdef PERL_OLD_COPY_ON_WRITE 4909 PL_reg_re->saved_copy = PL_nrs; 4910 #endif 4911 2460 RX_MATCH_COPIED_on(PL_reg_re); 4912 } 4913 3816 PL_reg_magic->mg_len = PL_reg_oldpos; 4914 3816 PL_reg_eval_set = 0; 4915 3816 PL_curpm = PL_reg_oldcurpm; 4916 } 4917 } 4918 4919 STATIC void 4920 S_to_utf8_substr(pTHX_ register regexp *prog) 4921 140 { 4922 140 if (prog->float_substr && !prog->float_utf8) { 4923 11 SV* sv; 4924 11 prog->float_utf8 = sv = newSVsv(prog->float_substr); 4925 11 sv_utf8_upgrade(sv); 4926 11 if (SvTAIL(prog->float_substr)) 4927 1 SvTAIL_on(sv); 4928 11 if (prog->float_substr == prog->check_substr) 4929 5 prog->check_utf8 = sv; 4930 } 4931 140 if (prog->anchored_substr && !prog->anchored_utf8) { 4932 137 SV* sv; 4933 137 prog->anchored_utf8 = sv = newSVsv(prog->anchored_substr); 4934 137 sv_utf8_upgrade(sv); 4935 137 if (SvTAIL(prog->anchored_substr)) 4936 17 SvTAIL_on(sv); 4937 137 if (prog->anchored_substr == prog->check_substr) 4938 132 prog->check_utf8 = sv; 4939 } 4940 } 4941 4942 STATIC void 4943 S_to_byte_substr(pTHX_ register regexp *prog) 4944 33 { 4945 33 if (prog->float_utf8 && !prog->float_substr) { 4946 22 SV* sv; 4947 22 prog->float_substr = sv = newSVsv(prog->float_utf8); 4948 22 if (sv_utf8_downgrade(sv, TRUE)) { 4949 18 if (SvTAIL(prog->float_utf8)) 4950 ###### SvTAIL_on(sv); 4951 } else { 4952 4 SvREFCNT_dec(sv); 4953 4 prog->float_substr = sv = &PL_sv_undef; 4954 } 4955 22 if (prog->float_utf8 == prog->check_utf8) 4956 16 prog->check_substr = sv; 4957 } 4958 33 if (prog->anchored_utf8 && !prog->anchored_substr) { 4959 31 SV* sv; 4960 31 prog->anchored_substr = sv = newSVsv(prog->anchored_utf8); 4961 31 if (sv_utf8_downgrade(sv, TRUE)) { 4962 25 if (SvTAIL(prog->anchored_utf8)) 4963 1 SvTAIL_on(sv); 4964 } else { 4965 6 SvREFCNT_dec(sv); 4966 6 prog->anchored_substr = sv = &PL_sv_undef; 4967 } 4968 31 if (prog->anchored_utf8 == prog->check_utf8) 4969 17 prog->check_substr = sv; 4970 } 4971 } 4972 4973 /* 4974 * Local variables: 4975 * c-indentation-style: bsd 4976 * c-basic-offset: 4 4977 * indent-tabs-mode: t 4978 * End: 4979 * 4980 * ex: set ts=8 sts=4 sw=4 noet: 4981 */