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