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 ###### { 181 ###### const int retval = PL_savestack_ix; 182 #define REGCP_PAREN_ELEMS 4 183 ###### const int paren_elems_to_push = (PL_regsize - parenfloor) * REGCP_PAREN_ELEMS; 184 ###### int p; 185 186 ###### if (paren_elems_to_push < 0) 187 ###### Perl_croak(aTHX_ "panic: paren_elems_to_push < 0"); 188 189 #define REGCP_OTHER_ELEMS 6 190 ###### SSGROW(paren_elems_to_push + REGCP_OTHER_ELEMS); 191 ###### for (p = PL_regsize; p > parenfloor; p--) { 192 /* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */ 193 ###### SSPUSHINT(PL_regendp[p]); 194 ###### SSPUSHINT(PL_regstartp[p]); 195 ###### SSPUSHPTR(PL_reg_start_tmp[p]); 196 ###### SSPUSHINT(p); 197 } 198 /* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */ 199 ###### SSPUSHINT(PL_regsize); 200 ###### SSPUSHINT(*PL_reglastparen); 201 ###### SSPUSHINT(*PL_reglastcloseparen); 202 ###### 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 ###### SSPUSHINT(paren_elems_to_push + REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS); 207 ###### SSPUSHINT(SAVEt_REGCONTEXT); /* Magic cookie. */ 208 209 ###### 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 ###### { 225 ###### I32 i; 226 ###### U32 paren = 0; 227 ###### char *input; 228 229 ###### GET_RE_DEBUG_FLAGS_DECL; 230 231 /* Pop REGCP_OTHER_ELEMS before the parentheses loop starts. */ 232 ###### i = SSPOPINT; 233 ###### assert(i == SAVEt_REGCONTEXT); /* Check that the magic cookie is there. */ 234 ###### i = SSPOPINT; /* Parentheses elements to pop. */ 235 ###### input = (char *) SSPOPPTR; 236 ###### *PL_reglastcloseparen = SSPOPINT; 237 ###### *PL_reglastparen = SSPOPINT; 238 ###### PL_regsize = SSPOPINT; 239 240 /* Now restore the parentheses context. */ 241 ###### for (i -= (REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS); 242 i > 0; i -= REGCP_PAREN_ELEMS) { 243 ###### I32 tmps; 244 ###### paren = (U32)SSPOPINT; 245 ###### PL_reg_start_tmp[paren] = (char *) SSPOPPTR; 246 ###### PL_regstartp[paren] = SSPOPINT; 247 ###### tmps = SSPOPINT; 248 ###### if (paren <= *PL_reglastparen) 249 ###### 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 ###### ); 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 ###### ); 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 ###### for (paren = *PL_reglastparen + 1; (I32)paren <= PL_regnpar; paren++) { 278 ###### if ((I32)paren > PL_regsize) 279 ###### PL_regstartp[paren] = -1; 280 ###### PL_regendp[paren] = -1; 281 } 282 #endif 283 ###### return input; 284 } 285 286 STATIC char * 287 S_regcp_set_to(pTHX_ I32 ss) 288 ###### { 289 ###### const I32 tmp = PL_savestack_ix; 290 291 ###### PL_savestack_ix = ss; 292 ###### regcppop(); 293 ###### PL_savestack_ix = tmp; 294 ###### 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 ###### { 347 ###### PL_regprecomp = prog->precomp; /* Needed for FAIL. */ 348 #ifdef DEBUGGING 349 ###### PL_regprogram = prog->program; 350 #endif 351 ###### PL_regnpar = prog->nparens; 352 ###### PL_regdata = prog->data; 353 ###### 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 ###### { 406 ###### register I32 start_shift = 0; 407 /* Should be nonnegative! */ 408 ###### register I32 end_shift = 0; 409 ###### register char *s; 410 ###### register SV *check; 411 ###### char *strbeg; 412 ###### char *t; 413 ###### const int do_utf8 = sv ? SvUTF8(sv) : 0; /* if no sv we have to assume bytes */ 414 ###### I32 ml_anch; 415 ###### register char *other_last = Nullch; /* other substr checked before this */ 416 ###### char *check_at = Nullch; /* check substr found at this pos */ 417 ###### const I32 multiline = prog->reganch & PMf_MULTILINE; 418 #ifdef DEBUGGING 419 ###### char *i_strpos = strpos; 420 ###### SV *dsv = PERL_DEBUG_PAD_ZERO(0); 421 #endif 422 423 ###### GET_RE_DEBUG_FLAGS_DECL; 424 425 ###### RX_MATCH_UTF8_set(prog,do_utf8); 426 427 ###### if (prog->reganch & ROPT_UTF8) { 428 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, 429 ###### "UTF-8 regex...\n")); 430 ###### 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 ###### }); 456 457 /* CHR_DIST() would be more correct here but it makes things slow. */ 458 ###### if (prog->minlen > strend - strpos) { 459 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, 460 ###### "String too short... [re_intuit_start]\n")); 461 ###### goto fail; 462 } 463 ###### strbeg = (sv && SvPOK(sv)) ? strend - SvCUR(sv) : strpos; 464 ###### PL_regeol = strend; 465 ###### if (do_utf8) { 466 ###### if (!prog->check_utf8 && prog->check_substr) 467 ###### to_utf8_substr(prog); 468 ###### check = prog->check_utf8; 469 } else { 470 ###### if (!prog->check_substr && prog->check_utf8) 471 ###### to_byte_substr(prog); 472 ###### check = prog->check_substr; 473 } 474 ###### if (check == &PL_sv_undef) { 475 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, 476 ###### "Non-utf string cannot match utf check string\n")); 477 ###### goto fail; 478 } 479 ###### if (prog->reganch & ROPT_ANCH) { /* Match at beg-of-str or after \n */ 480 ###### ml_anch = !( (prog->reganch & ROPT_ANCH_SINGLE) 481 || ( (prog->reganch & ROPT_ANCH_BOL) 482 && !multiline ) ); /* Check after \n? */ 483 484 ###### if (!ml_anch) { 485 ###### 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 ###### DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not at start...\n")); 491 ###### goto fail; 492 } 493 ###### 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 ###### I32 slen; 497 498 ###### s = HOP3c(strpos, prog->check_offset_min, strend); 499 ###### if (SvTAIL(check)) { 500 ###### slen = SvCUR(check); /* >= 1 */ 501 502 ###### if ( strend - s > slen || strend - s < slen - 1 503 || (strend - s == slen && strend[-1] != '\n')) { 504 ###### 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 ###### slen--; 509 ###### if (slen && (*SvPVX_const(check) != *s 510 || (slen > 1 511 && memNE(SvPVX_const(check), s, slen)))) { 512 report_neq: 513 ###### DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String not equal...\n")); 514 ###### goto fail_finish; 515 } 516 } 517 ###### else if (*SvPVX_const(check) != *s 518 || ((slen = SvCUR(check)) > 1 519 && memNE(SvPVX_const(check), s, slen))) 520 ###### goto report_neq; 521 ###### goto success_at_start; 522 } 523 } 524 /* Match is anchored, but substr is not anchored wrt beg-of-str. */ 525 ###### s = strpos; 526 ###### start_shift = prog->check_offset_min; /* okay to underestimate on CC */ 527 ###### end_shift = prog->minlen - start_shift - 528 CHR_SVLEN(check) + (SvTAIL(check) != 0); 529 ###### if (!ml_anch) { 530 ###### const I32 end = prog->check_offset_max + CHR_SVLEN(check) 531 ###### - (SvTAIL(check) != 0); 532 ###### const I32 eshift = CHR_DIST((U8*)strend, (U8*)s) - end; 533 534 ###### if (end_shift < eshift) 535 ###### end_shift = eshift; 536 } 537 } 538 else { /* Can match at random position */ 539 ###### ml_anch = 0; 540 ###### s = strpos; 541 ###### start_shift = prog->check_offset_min; /* okay to underestimate on CC */ 542 /* Should be nonnegative! */ 543 ###### 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 ###### 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 ###### if (flags & REXEC_SCREAM) { 556 ###### I32 p = -1; /* Internal iterator of scream. */ 557 ###### I32 * const pp = data ? data->scream_pos : &p; 558 559 ###### if (PL_screamfirst[BmRARE(check)] >= 0 560 || ( BmRARE(check) == '\n' 561 && (BmPREVIOUS(check) == SvCUR(check) - 1) 562 && SvTAIL(check) )) 563 ###### s = screaminstr(sv, check, 564 start_shift + (s - strbeg), end_shift, pp, 0); 565 else 566 ###### goto fail_finish; 567 /* we may be pointing at the wrong string */ 568 ###### if (s && RX_MATCH_COPIED(prog)) 569 ###### s = strbeg + (s - SvPVX_const(sv)); 570 ###### if (data) 571 ###### *data->scream_olds = s; 572 } 573 ###### else if (prog->reganch & ROPT_CANY_SEEN) 574 ###### s = fbm_instr((U8*)(s + start_shift), 575 (U8*)(strend - end_shift), 576 check, multiline ? FBMrf_MULTILINE : 0); 577 else 578 ###### 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 ###### (s ? " at offset " : "...\n") ) ); 593 594 ###### if (!s) 595 ###### goto fail_finish; 596 597 ###### check_at = s; 598 599 /* Finish the diagnostic message */ 600 ###### 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 ###### 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 ###### if (!other_last) 614 ###### other_last = strpos; 615 ###### if (check == (do_utf8 ? prog->float_utf8 : prog->float_substr)) { 616 do_other_anchored: 617 { 618 ###### char *last = HOP3c(s, -start_shift, strbeg), *last1, *last2; 619 ###### char *s1 = s; 620 ###### SV* must; 621 622 ###### t = s - prog->check_offset_max; 623 ###### 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 ###### t = strpos; 630 ###### t = HOP3c(t, prog->anchored_offset, strend); 631 ###### if (t < other_last) /* These positions already checked */ 632 ###### t = other_last; 633 ###### last2 = last1 = HOP3c(strend, -prog->minlen, strbeg); 634 ###### if (last < last1) 635 ###### last1 = last; 636 /* XXXX It is not documented what units *_offsets are in. Assume bytes. */ 637 /* On end-of-str: see comment below. */ 638 ###### must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr; 639 ###### if (must == &PL_sv_undef) { 640 ###### s = (char*)NULL; 641 ###### DEBUG_EXECUTE_r(must = prog->anchored_utf8); /* for debug */ 642 } 643 else 644 ###### 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 ###### PL_colors[1], (SvTAIL(must) ? "$" : ""))); 659 ###### if (!s) { 660 ###### if (last1 >= last2) { 661 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, 662 ###### ", 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 ###### (long)(HOP3c(s1, 1, strend) - i_strpos))); 668 ###### other_last = HOP3c(last1, prog->anchored_offset+1, strend); 669 ###### s = HOP3c(last, 1, strend); 670 ###### goto restart; 671 } 672 else { 673 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n", 674 ###### (long)(s - i_strpos))); 675 ###### t = HOP3c(s, -prog->anchored_offset, strbeg); 676 ###### other_last = HOP3c(s, 1, strend); 677 ###### s = s1; 678 ###### if (t == strpos) 679 ###### goto try_at_start; 680 ###### goto try_at_offset; 681 } 682 } 683 } 684 else { /* Take into account the floating substring. */ 685 ###### char *last, *last1; 686 ###### char *s1 = s; 687 ###### SV* must; 688 689 ###### t = HOP3c(s, -start_shift, strbeg); 690 ###### last1 = last = 691 HOP3c(strend, -prog->minlen + prog->float_min_offset, strbeg); 692 ###### if (CHR_DIST((U8*)last, (U8*)t) > prog->float_max_offset) 693 ###### last = HOP3c(t, prog->float_max_offset, strend); 694 ###### s = HOP3c(t, prog->float_min_offset, strend); 695 ###### if (s < other_last) 696 ###### s = other_last; 697 /* XXXX It is not documented what units *_offsets are in. Assume bytes. */ 698 ###### 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 ###### if (must == &PL_sv_undef) { 703 ###### s = (char*)NULL; 704 ###### DEBUG_EXECUTE_r(must = prog->float_utf8); /* for debug message */ 705 } 706 else 707 ###### 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 ###### PL_colors[1], (SvTAIL(must) ? "$" : ""))); 717 ###### if (!s) { 718 ###### if (last1 == last) { 719 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, 720 ###### ", 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 ###### (long)(s1 + 1 - i_strpos))); 726 ###### other_last = last; 727 ###### s = HOP3c(t, 1, strend); 728 ###### goto restart; 729 } 730 else { 731 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n", 732 ###### (long)(s - i_strpos))); 733 ###### other_last = s; /* Fix this later. --Hugo */ 734 ###### s = s1; 735 ###### if (t == strpos) 736 ###### goto try_at_start; 737 ###### goto try_at_offset; 738 } 739 } 740 } 741 742 ###### t = s - prog->check_offset_max; 743 ###### 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 ###### 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 ###### while (t < strend - prog->minlen) { 759 ###### if (*t == '\n') { 760 ###### if (t < check_at - prog->check_offset_min) { 761 ###### 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 ###### 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 ###### 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 ###### s = t + 1; 777 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld...\n", 778 ###### 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 ###### PL_colors[0], PL_colors[1], (long)(t + 1 - i_strpos))); 786 ###### other_last = strpos = s = t + 1; 787 ###### goto restart; 788 } 789 ###### t++; 790 } 791 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Did not find /%s^%s/m...\n", 792 ###### 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 ###### PL_colors[0], PL_colors[1])); 798 } 799 ###### s = t; 800 set_useful: 801 ###### ++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 ###### 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 ###### t = strpos; 817 ###### 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 ###### ); 823 success_at_start: 824 ###### 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 ###### DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "... Disabling check substring...\n")); 837 ###### SvREFCNT_dec(do_utf8 ? prog->check_utf8 : prog->check_substr); 838 ###### if (do_utf8 ? prog->check_substr : prog->check_utf8) 839 ###### SvREFCNT_dec(do_utf8 ? prog->check_substr : prog->check_utf8); 840 ###### prog->check_substr = prog->check_utf8 = Nullsv; /* disable */ 841 ###### prog->float_substr = prog->float_utf8 = Nullsv; /* clear */ 842 ###### check = Nullsv; /* abort */ 843 ###### 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 ###### prog->reganch &= ~RE_USE_INTUIT; 848 } 849 else 850 ###### s = strpos; 851 } 852 853 /* Last resort... */ 854 /* XXXX BmUSEFUL already changed, maybe multiple change is meaningful... */ 855 ###### 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 ###### const U8* str = (U8*)STRING(prog->regstclass); 865 ###### const int cl_l = (PL_regkind[(U8)OP(prog->regstclass)] == EXACT 866 ? CHR_DIST(str+STR_LEN(prog->regstclass), str) 867 ###### : 1); 868 ###### 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 ###### : strend); 874 875 ###### t = s; 876 ###### cache_re(prog); 877 ###### s = find_byclass(prog, prog->regstclass, s, endpos, 1); 878 ###### if (!s) { 879 #ifdef DEBUGGING 880 ###### const char *what = 0; 881 #endif 882 ###### if (endpos == strend) { 883 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, 884 ###### "Could not match STCLASS...\n") ); 885 ###### goto fail; 886 } 887 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, 888 ###### "This position contradicts STCLASS...\n") ); 889 ###### if ((prog->reganch & ROPT_ANCH) && !ml_anch) 890 ###### goto fail; 891 /* Contradict one of substrings */ 892 ###### if (prog->anchored_substr || prog->anchored_utf8) { 893 ###### if ((do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) == check) { 894 ###### DEBUG_EXECUTE_r( what = "anchored" ); 895 hop_and_restart: 896 ###### s = HOP3c(t, 1, strend); 897 ###### 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 ###### "Could not match STCLASS...\n") ); 901 ###### goto fail; 902 } 903 ###### 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 ###### what, (long)(s + start_shift - i_strpos)) ); 908 ###### goto restart; 909 } 910 /* Have both, check_string is floating */ 911 ###### if (t + start_shift >= check_at) /* Contradicts floating=check */ 912 ###### goto retry_floating_check; 913 /* Recheck anchored substring, but not floating... */ 914 ###### s = check_at; 915 ###### 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 ###### (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 ###### if (ml_anch) { 925 ###### s = t = t + 1; 926 ###### if (!check) 927 ###### goto giveup; 928 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, 929 "Looking for /%s^%s/m starting at offset %ld...\n", 930 ###### PL_colors[0], PL_colors[1], (long)(t - i_strpos)) ); 931 ###### goto try_at_offset; 932 } 933 ###### 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 ###### t = check_at - start_shift; 938 ###### DEBUG_EXECUTE_r( what = "floating" ); 939 ###### goto hop_and_restart; 940 } 941 ###### 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 ###### ); 946 } 947 else { 948 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, 949 "Does not contradict STCLASS...\n"); 950 ###### ); 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 ###### PL_colors[5], (long)(s - i_strpos)) ); 957 ###### return s; 958 959 fail_finish: /* Substring not found */ 960 ###### if (prog->check_substr || prog->check_utf8) /* could be removed already */ 961 ###### 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 ###### PL_colors[4], PL_colors[5])); 965 ###### 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 ###### { 972 dVAR; 973 ###### const I32 doevery = (prog->reganch & ROPT_SKIP) == 0; 974 ###### char *m; 975 ###### STRLEN ln; 976 ###### STRLEN lnc; 977 ###### register STRLEN uskip; 978 ###### unsigned int c1; 979 ###### unsigned int c2; 980 ###### char *e; 981 ###### register I32 tmp = 1; /* Scratch variable? */ 982 ###### register const bool do_utf8 = PL_reg_match_utf8; 983 984 /* We know what class it must start with. */ 985 ###### switch (OP(c)) { 986 case ANYOF: 987 ###### if (do_utf8) { 988 ###### while (s + (uskip = UTF8SKIP(s)) <= strend) { 989 ###### 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 ###### if (tmp && (norun || regtry(prog, s))) 994 ###### goto got_it; 995 else 996 ###### tmp = doevery; 997 } 998 else 999 ###### tmp = 1; 1000 ###### s += uskip; 1001 } 1002 } 1003 else { 1004 ###### while (s < strend) { 1005 ###### STRLEN skip = 1; 1006 1007 ###### 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 ###### if (tmp && (norun || regtry(prog, s))) 1013 ###### goto got_it; 1014 else 1015 ###### tmp = doevery; 1016 } 1017 else 1018 ###### tmp = 1; 1019 ###### s += skip; 1020 } 1021 } 1022 ###### break; 1023 case CANY: 1024 ###### while (s < strend) { 1025 ###### if (tmp && (norun || regtry(prog, s))) 1026 ###### goto got_it; 1027 else 1028 ###### tmp = doevery; 1029 ###### s++; 1030 } 1031 ###### break; 1032 case EXACTF: 1033 ###### m = STRING(c); 1034 ###### ln = STR_LEN(c); /* length to match in octets/bytes */ 1035 ###### lnc = (I32) ln; /* length to match in characters */ 1036 ###### if (UTF) { 1037 ###### STRLEN ulen1, ulen2; 1038 ###### U8 *sm = (U8 *) m; 1039 ###### U8 tmpbuf1[UTF8_MAXBYTES_CASE+1]; 1040 ###### U8 tmpbuf2[UTF8_MAXBYTES_CASE+1]; 1041 1042 ###### to_utf8_lower((U8*)m, tmpbuf1, &ulen1); 1043 ###### to_utf8_upper((U8*)m, tmpbuf2, &ulen2); 1044 1045 ###### c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXBYTES_CASE, 1046 0, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY); 1047 ###### c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXBYTES_CASE, 1048 0, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY); 1049 ###### lnc = 0; 1050 ###### while (sm < ((U8 *) m + ln)) { 1051 ###### lnc++; 1052 ###### sm += UTF8SKIP(sm); 1053 } 1054 } 1055 else { 1056 ###### c1 = *(U8*)m; 1057 ###### c2 = PL_fold[c1]; 1058 } 1059 ###### goto do_exactf; 1060 case EXACTFL: 1061 ###### m = STRING(c); 1062 ###### ln = STR_LEN(c); 1063 ###### lnc = (I32) ln; 1064 ###### c1 = *(U8*)m; 1065 ###### c2 = PL_fold_locale[c1]; 1066 do_exactf: 1067 ###### e = HOP3c(strend, -((I32)lnc), s); 1068 1069 ###### 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 ###### if (do_utf8) { 1084 ###### UV c, f; 1085 ###### U8 tmpbuf [UTF8_MAXBYTES+1]; 1086 ###### STRLEN len, foldlen; 1087 1088 ###### if (c1 == c2) { 1089 /* Upper and lower of 1st char are equal - 1090 * probably not a "letter". */ 1091 ###### while (s <= e) { 1092 ###### c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len, 1093 ckWARN(WARN_UTF8) ? 1094 0 : UTF8_ALLOW_ANY); 1095 ###### 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 ###### goto got_it; 1101 else { 1102 ###### U8 foldbuf[UTF8_MAXBYTES_CASE+1]; 1103 ###### uvchr_to_utf8(tmpbuf, c); 1104 ###### f = to_utf8_fold(tmpbuf, foldbuf, &foldlen); 1105 ###### 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 ###### goto got_it; 1114 } 1115 ###### s += len; 1116 } 1117 } 1118 else { 1119 ###### while (s <= e) { 1120 ###### 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 ###### if (c == (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA || 1132 c == (UV)UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA) 1133 ###### c = (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA; 1134 1135 ###### 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 ###### goto got_it; 1141 else { 1142 ###### U8 foldbuf[UTF8_MAXBYTES_CASE+1]; 1143 ###### uvchr_to_utf8(tmpbuf, c); 1144 ###### f = to_utf8_fold(tmpbuf, foldbuf, &foldlen); 1145 ###### 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 ###### goto got_it; 1154 } 1155 ###### s += len; 1156 } 1157 } 1158 } 1159 else { 1160 ###### if (c1 == c2) 1161 ###### while (s <= e) { 1162 ###### 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 ###### goto got_it; 1168 ###### s++; 1169 } 1170 else 1171 ###### while (s <= e) { 1172 ###### 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 ###### goto got_it; 1178 ###### s++; 1179 } 1180 } 1181 ###### break; 1182 case BOUNDL: 1183 ###### PL_reg_flags |= RF_tainted; 1184 /* FALL THROUGH */ 1185 case BOUND: 1186 ###### if (do_utf8) { 1187 ###### if (s == PL_bostr) 1188 ###### tmp = '\n'; 1189 else { 1190 ###### U8 *r = reghop3((U8*)s, -1, (U8*)PL_bostr); 1191 1192 ###### tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, 0); 1193 } 1194 ###### tmp = ((OP(c) == BOUND ? 1195 isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0); 1196 ###### LOAD_UTF8_CHARCLASS_ALNUM(); 1197 ###### while (s + (uskip = UTF8SKIP(s)) <= strend) { 1198 ###### if (tmp == !(OP(c) == BOUND ? 1199 swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) : 1200 isALNUM_LC_utf8((U8*)s))) 1201 { 1202 ###### tmp = !tmp; 1203 ###### if ((norun || regtry(prog, s))) 1204 ###### goto got_it; 1205 } 1206 ###### s += uskip; 1207 } 1208 } 1209 else { 1210 ###### tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n'; 1211 ###### tmp = ((OP(c) == BOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0); 1212 ###### while (s < strend) { 1213 ###### if (tmp == 1214 !(OP(c) == BOUND ? isALNUM(*s) : isALNUM_LC(*s))) { 1215 ###### tmp = !tmp; 1216 ###### if ((norun || regtry(prog, s))) 1217 ###### goto got_it; 1218 } 1219 ###### s++; 1220 } 1221 } 1222 ###### 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 ###### 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 ###### tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n'; 1252 ###### tmp = ((OP(c) == NBOUND ? 1253 isALNUM(tmp) : isALNUM_LC(tmp)) != 0); 1254 ###### while (s < strend) { 1255 ###### if (tmp == 1256 !(OP(c) == NBOUND ? isALNUM(*s) : isALNUM_LC(*s))) 1257 ###### tmp = !tmp; 1258 ###### else if ((norun || regtry(prog, s))) 1259 ###### goto got_it; 1260 ###### s++; 1261 } 1262 } 1263 ###### if ((!prog->minlen && !tmp) && (norun || regtry(prog, s))) 1264 ###### goto got_it; 1265 ###### break; 1266 case ALNUM: 1267 ###### if (do_utf8) { 1268 ###### LOAD_UTF8_CHARCLASS_ALNUM(); 1269 ###### while (s + (uskip = UTF8SKIP(s)) <= strend) { 1270 ###### if (swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8)) { 1271 ###### if (tmp && (norun || regtry(prog, s))) 1272 ###### goto got_it; 1273 else 1274 ###### tmp = doevery; 1275 } 1276 else 1277 ###### tmp = 1; 1278 ###### s += uskip; 1279 } 1280 } 1281 else { 1282 ###### while (s < strend) { 1283 ###### if (isALNUM(*s)) { 1284 ###### if (tmp && (norun || regtry(prog, s))) 1285 ###### goto got_it; 1286 else 1287 ###### tmp = doevery; 1288 } 1289 else 1290 ###### tmp = 1; 1291 ###### s++; 1292 } 1293 } 1294 ###### break; 1295 case ALNUML: 1296 ###### PL_reg_flags |= RF_tainted; 1297 ###### 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 ###### while (s < strend) { 1312 ###### if (isALNUM_LC(*s)) { 1313 ###### if (tmp && (norun || regtry(prog, s))) 1314 ###### goto got_it; 1315 else 1316 ###### tmp = doevery; 1317 } 1318 else 1319 ###### tmp = 1; 1320 ###### s++; 1321 } 1322 } 1323 ###### break; 1324 case NALNUM: 1325 ###### if (do_utf8) { 1326 ###### LOAD_UTF8_CHARCLASS_ALNUM(); 1327 ###### while (s + (uskip = UTF8SKIP(s)) <= strend) { 1328 ###### 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 ###### tmp = 1; 1336 ###### s += uskip; 1337 } 1338 } 1339 else { 1340 ###### while (s < strend) { 1341 ###### if (!isALNUM(*s)) { 1342 ###### if (tmp && (norun || regtry(prog, s))) 1343 ###### goto got_it; 1344 else 1345 ###### tmp = doevery; 1346 } 1347 else 1348 ###### tmp = 1; 1349 ###### s++; 1350 } 1351 } 1352 ###### break; 1353 case NALNUML: 1354 ###### PL_reg_flags |= RF_tainted; 1355 ###### 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 ###### while (s < strend) { 1370 ###### if (!isALNUM_LC(*s)) { 1371 ###### if (tmp && (norun || regtry(prog, s))) 1372 ###### goto got_it; 1373 else 1374 ###### tmp = doevery; 1375 } 1376 else 1377 ###### tmp = 1; 1378 ###### s++; 1379 } 1380 } 1381 ###### break; 1382 case SPACE: 1383 ###### if (do_utf8) { 1384 ###### LOAD_UTF8_CHARCLASS_SPACE(); 1385 ###### while (s + (uskip = UTF8SKIP(s)) <= strend) { 1386 ###### if (*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8)) { 1387 ###### 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 ###### while (s < strend) { 1399 ###### if (isSPACE(*s)) { 1400 ###### if (tmp && (norun || regtry(prog, s))) 1401 ###### goto got_it; 1402 else 1403 ###### tmp = doevery; 1404 } 1405 else 1406 ###### tmp = 1; 1407 ###### s++; 1408 } 1409 } 1410 ###### break; 1411 case SPACEL: 1412 ###### PL_reg_flags |= RF_tainted; 1413 ###### 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 ###### while (s < strend) { 1428 ###### if (isSPACE_LC(*s)) { 1429 ###### if (tmp && (norun || regtry(prog, s))) 1430 ###### goto got_it; 1431 else 1432 ###### tmp = doevery; 1433 } 1434 else 1435 ###### tmp = 1; 1436 ###### s++; 1437 } 1438 } 1439 ###### break; 1440 case NSPACE: 1441 ###### if (do_utf8) { 1442 ###### LOAD_UTF8_CHARCLASS_SPACE(); 1443 ###### while (s + (uskip = UTF8SKIP(s)) <= strend) { 1444 ###### if (!(*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8))) { 1445 ###### 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 ###### while (s < strend) { 1457 ###### if (!isSPACE(*s)) { 1458 ###### if (tmp && (norun || regtry(prog, s))) 1459 ###### goto got_it; 1460 else 1461 ###### tmp = doevery; 1462 } 1463 else 1464 ###### tmp = 1; 1465 ###### s++; 1466 } 1467 } 1468 ###### break; 1469 case NSPACEL: 1470 ###### PL_reg_flags |= RF_tainted; 1471 ###### 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 ###### while (s < strend) { 1486 ###### if (!isSPACE_LC(*s)) { 1487 ###### 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 ###### break; 1498 case DIGIT: 1499 ###### if (do_utf8) { 1500 ###### LOAD_UTF8_CHARCLASS_DIGIT(); 1501 ###### while (s + (uskip = UTF8SKIP(s)) <= strend) { 1502 ###### if (swash_fetch(PL_utf8_digit,(U8*)s, do_utf8)) { 1503 ###### 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 ###### while (s < strend) { 1515 ###### if (isDIGIT(*s)) { 1516 ###### if (tmp && (norun || regtry(prog, s))) 1517 ###### goto got_it; 1518 else 1519 ###### tmp = doevery; 1520 } 1521 else 1522 ###### tmp = 1; 1523 ###### 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 ###### break; 1556 case NDIGIT: 1557 ###### 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 ###### while (s < strend) { 1573 ###### if (!isDIGIT(*s)) { 1574 ###### if (tmp && (norun || regtry(prog, s))) 1575 ###### goto got_it; 1576 else 1577 ###### tmp = doevery; 1578 } 1579 else 1580 ###### tmp = 1; 1581 ###### 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 ###### break; 1617 } 1618 ###### return 0; 1619 got_it: 1620 ###### 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 ###### { 1635 ###### register char *s; 1636 ###### register regnode *c; 1637 ###### register char *startpos = stringarg; 1638 ###### I32 minlen; /* must match at least this many chars */ 1639 ###### I32 dontbother = 0; /* how many characters not to try at end */ 1640 ###### I32 end_shift = 0; /* Same for the end. */ /* CC */ 1641 ###### I32 scream_pos = -1; /* Internal iterator of scream. */ 1642 ###### char *scream_olds; 1643 ###### SV* oreplsv = GvSV(PL_replgv); 1644 ###### const bool do_utf8 = DO_UTF8(sv); 1645 ###### const I32 multiline = prog->reganch & PMf_MULTILINE; 1646 #ifdef DEBUGGING 1647 ###### SV *dsv0 = PERL_DEBUG_PAD_ZERO(0); 1648 ###### SV *dsv1 = PERL_DEBUG_PAD_ZERO(1); 1649 #endif 1650 1651 ###### GET_RE_DEBUG_FLAGS_DECL; 1652 1653 ###### PERL_UNUSED_ARG(data); 1654 ###### RX_MATCH_UTF8_set(prog,do_utf8); 1655 1656 ###### PL_regcc = 0; 1657 1658 ###### cache_re(prog); 1659 #ifdef DEBUGGING 1660 ###### PL_regnarrate = DEBUG_r_TEST; 1661 #endif 1662 1663 /* Be paranoid... */ 1664 ###### if (prog == NULL || startpos == NULL) { 1665 ###### Perl_croak(aTHX_ "NULL regexp parameter"); 1666 ###### return 0; 1667 } 1668 1669 ###### minlen = prog->minlen; 1670 ###### if (strend - startpos < minlen) { 1671 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, 1672 ###### "String too short [regexec_flags]...\n")); 1673 ###### goto phooey; 1674 } 1675 1676 /* Check validity of program. */ 1677 ###### if (UCHARAT(prog->program) != REG_MAGIC) { 1678 ###### Perl_croak(aTHX_ "corrupted regexp program"); 1679 } 1680 1681 ###### PL_reg_flags = 0; 1682 ###### PL_reg_eval_set = 0; 1683 ###### PL_reg_maxiter = 0; 1684 1685 ###### if (prog->reganch & ROPT_UTF8) 1686 ###### PL_reg_flags |= RF_utf8; 1687 1688 /* Mark beginning of line for ^ and lookbehind. */ 1689 ###### PL_regbol = startpos; 1690 ###### PL_bostr = strbeg; 1691 ###### PL_reg_sv = sv; 1692 1693 /* Mark end of line for $ (and such) */ 1694 ###### PL_regeol = strend; 1695 1696 /* see how far we have to get to not match where we matched before */ 1697 ###### PL_regtill = startpos+minend; 1698 1699 /* We start without call_cc context. */ 1700 ###### PL_reg_call_cc = 0; 1701 1702 /* If there is a "must appear" string, look for it. */ 1703 ###### s = startpos; 1704 1705 ###### if (prog->reganch & ROPT_GPOS_SEEN) { /* Need to have PL_reg_ganch */ 1706 ###### MAGIC *mg; 1707 1708 ###### if (flags & REXEC_IGNOREPOS) /* Means: check only at start */ 1709 ###### PL_reg_ganch = startpos; 1710 ###### 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 ###### PL_reg_ganch = strbeg + mg->mg_len; /* Defined pos() */ 1715 ###### if (prog->reganch & ROPT_ANCH_GPOS) { 1716 ###### if (s > PL_reg_ganch) 1717 ###### goto phooey; 1718 ###### s = PL_reg_ganch; 1719 } 1720 } 1721 else /* pos() not defined */ 1722 ###### PL_reg_ganch = strbeg; 1723 } 1724 1725 ###### if (!(flags & REXEC_CHECKED) && (prog->check_substr != Nullsv || prog->check_utf8 != Nullsv)) { 1726 ###### re_scream_pos_data d; 1727 1728 ###### d.scream_olds = &scream_olds; 1729 ###### d.scream_pos = &scream_pos; 1730 ###### s = re_intuit_start(prog, sv, s, strend, flags, &d); 1731 ###### if (!s) { 1732 ###### 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 ###### }); 1760 1761 /* Simplest case: anchored match need be tried only once. */ 1762 /* [unless only anchor is BOL and multiline is set] */ 1763 ###### if (prog->reganch & (ROPT_ANCH & ~ROPT_ANCH_GPOS)) { 1764 ###### if (s == startpos && regtry(prog, startpos)) 1765 ###### goto got_it; 1766 ###### else if (multiline || (prog->reganch & ROPT_IMPLICIT) 1767 || (prog->reganch & ROPT_ANCH_MBOL)) /* XXXX SBOL? */ 1768 { 1769 ###### char *end; 1770 1771 ###### if (minlen) 1772 ###### dontbother = minlen - 1; 1773 ###### end = HOP3c(strend, -dontbother, strbeg) - 1; 1774 /* for multiline we only have to try after newlines */ 1775 ###### if (prog->check_substr || prog->check_utf8) { 1776 ###### if (s == startpos) 1777 ###### goto after_try; 1778 ###### while (1) { 1779 ###### if (regtry(prog, s)) 1780 ###### goto got_it; 1781 after_try: 1782 ###### if (s >= end) 1783 ###### goto phooey; 1784 ###### if (prog->reganch & RE_USE_INTUIT) { 1785 ###### s = re_intuit_start(prog, sv, s + 1, strend, flags, NULL); 1786 ###### if (!s) 1787 ###### goto phooey; 1788 } 1789 else 1790 ###### s++; 1791 } 1792 } else { 1793 ###### if (s > startpos) 1794 ###### s--; 1795 ###### while (s < end) { 1796 ###### if (*s++ == '\n') { /* don't need PL_utf8skip here */ 1797 ###### if (regtry(prog, s)) 1798 ###### goto got_it; 1799 } 1800 } 1801 } 1802 } 1803 ###### goto phooey; 1804 ###### } else if (prog->reganch & ROPT_ANCH_GPOS) { 1805 ###### if (regtry(prog, PL_reg_ganch)) 1806 ###### goto got_it; 1807 ###### goto phooey; 1808 } 1809 1810 /* Messy cases: unanchored match. */ 1811 ###### 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 ###### char ch; 1815 #ifdef DEBUGGING 1816 ###### int did_match = 0; 1817 #endif 1818 ###### if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)) 1819 ###### do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog); 1820 ###### ch = SvPVX_const(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)[0]; 1821 1822 ###### if (do_utf8) { 1823 ###### while (s < strend) { 1824 ###### if (*s == ch) { 1825 ###### DEBUG_EXECUTE_r( did_match = 1 ); 1826 ###### 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 ###### while (s < strend) { 1836 ###### if (*s == ch) { 1837 ###### DEBUG_EXECUTE_r( did_match = 1 ); 1838 ###### if (regtry(prog, s)) goto got_it; 1839 ###### s++; 1840 ###### while (s < strend && *s == ch) 1841 ###### s++; 1842 } 1843 ###### s++; 1844 } 1845 } 1846 DEBUG_EXECUTE_r(if (!did_match) 1847 PerlIO_printf(Perl_debug_log, 1848 "Did not find anchored character...\n") 1849 ###### ); 1850 } 1851 ###### 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 ###### SV *must; 1856 ###### I32 back_max; 1857 ###### I32 back_min; 1858 ###### char *last; 1859 ###### char *last1; /* Last position checked before */ 1860 #ifdef DEBUGGING 1861 ###### int did_match = 0; 1862 #endif 1863 ###### if (prog->anchored_substr || prog->anchored_utf8) { 1864 ###### if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)) 1865 ###### do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog); 1866 ###### must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr; 1867 ###### back_max = back_min = prog->anchored_offset; 1868 } else { 1869 ###### if (!(do_utf8 ? prog->float_utf8 : prog->float_substr)) 1870 ###### do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog); 1871 ###### must = do_utf8 ? prog->float_utf8 : prog->float_substr; 1872 ###### back_max = prog->float_max_offset; 1873 ###### back_min = prog->float_min_offset; 1874 } 1875 ###### if (must == &PL_sv_undef) 1876 /* could not downgrade utf8 check substring, so must fail */ 1877 ###### goto phooey; 1878 1879 ###### last = HOP3c(strend, /* Cannot start after this */ 1880 -(I32)(CHR_SVLEN(must) 1881 - (SvTAIL(must) != 0) + back_min), strbeg); 1882 1883 ###### if (s > PL_bostr) 1884 ###### last1 = HOPc(s, -1); 1885 else 1886 ###### last1 = s - 1; /* bogus */ 1887 1888 /* XXXX check_substr already used to find "s", can optimize if 1889 check_substr==must. */ 1890 ###### scream_pos = -1; 1891 ###### dontbother = end_shift; 1892 ###### strend = HOPc(strend, -dontbother); 1893 ###### 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 ###### if ((flags & REXEC_SCREAM) && RX_MATCH_COPIED(prog)) 1902 ###### s = strbeg + (s - SvPVX_const(sv)); 1903 ###### DEBUG_EXECUTE_r( did_match = 1 ); 1904 ###### if (HOPc(s, -back_max) > last1) { 1905 ###### last1 = HOPc(s, -back_min); 1906 ###### s = HOPc(s, -back_max); 1907 } 1908 else { 1909 ###### char *t = (last1 >= PL_bostr) ? HOPc(last1, 1) : last1 + 1; 1910 1911 ###### last1 = HOPc(s, -back_min); 1912 ###### s = t; 1913 } 1914 ###### if (do_utf8) { 1915 ###### while (s <= last1) { 1916 ###### if (regtry(prog, s)) 1917 ###### goto got_it; 1918 ###### s += UTF8SKIP(s); 1919 } 1920 } 1921 else { 1922 ###### while (s <= last1) { 1923 ###### if (regtry(prog, s)) 1924 ###### goto got_it; 1925 ###### 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 ###### ); 1939 ###### goto phooey; 1940 } 1941 ###### else if ((c = prog->regstclass)) { 1942 ###### if (minlen) { 1943 ###### I32 op = (U8)OP(prog->regstclass); 1944 /* don't bother with what can't match */ 1945 ###### if (PL_regkind[op] != EXACT && op != CANY) 1946 ###### 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 ###### }); 1969 ###### if (find_byclass(prog, c, s, strend, 0)) 1970 ###### goto got_it; 1971 ###### DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass...\n")); 1972 } 1973 else { 1974 ###### dontbother = 0; 1975 ###### if (prog->float_substr != Nullsv || prog->float_utf8 != Nullsv) { 1976 /* Trim the end. */ 1977 ###### char *last; 1978 ###### SV* float_real; 1979 1980 ###### if (!(do_utf8 ? prog->float_utf8 : prog->float_substr)) 1981 ###### do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog); 1982 ###### float_real = do_utf8 ? prog->float_utf8 : prog->float_substr; 1983 1984 ###### 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 ###### STRLEN len; 1995 ###### const char * const little = SvPV_const(float_real, len); 1996 1997 ###### if (SvTAIL(float_real)) { 1998 ###### if (memEQ(strend - len + 1, little, len - 1)) 1999 ###### last = strend - len + 1; 2000 ###### else if (!multiline) 2001 ###### last = memEQ(strend - len, little, len) 2002 ? strend - len : Nullch; 2003 else 2004 ###### goto find_last; 2005 } else { 2006 find_last: 2007 ###### if (len) 2008 ###### last = rninstr(s, strend, little, little + len); 2009 else 2010 ###### last = strend; /* matching "$" */ 2011 } 2012 } 2013 ###### 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 ###### dontbother = strend - last + prog->float_min_offset; 2020 } 2021 ###### if (minlen && (dontbother < minlen)) 2022 ###### dontbother = minlen - 1; 2023 ###### strend -= dontbother; /* this one's always in bytes! */ 2024 /* We don't know much -- general case. */ 2025 ###### if (do_utf8) { 2026 ###### for (;;) { 2027 ###### if (regtry(prog, s)) 2028 ###### goto got_it; 2029 ###### if (s >= strend) 2030 ###### break; 2031 ###### s += UTF8SKIP(s); 2032 }; 2033 } 2034 else { 2035 ###### do { 2036 ###### if (regtry(prog, s)) 2037 ###### goto got_it; 2038 ###### } while (s++ < strend); 2039 } 2040 } 2041 2042 /* Failure. */ 2043 ###### goto phooey; 2044 2045 got_it: 2046 ###### RX_MATCH_TAINTED_set(prog, PL_reg_flags & RF_tainted); 2047 2048 ###### if (PL_reg_eval_set) { 2049 /* Preserve the current value of $^R */ 2050 ###### if (oreplsv != GvSV(PL_replgv)) 2051 ###### sv_setsv(oreplsv, GvSV(PL_replgv));/* So that when GvSV(replgv) is 2052 restored, the value remains 2053 the same. */ 2054 ###### restore_pos(aTHX_ 0); 2055 } 2056 2057 /* make sure $`, $&, $', and $digit will work later */ 2058 ###### if ( !(flags & REXEC_NOT_FIRST) ) { 2059 ###### RX_MATCH_COPY_FREE(prog); 2060 ###### if (flags & REXEC_COPY_STR) { 2061 ###### 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 ###### RX_MATCH_COPIED_on(prog); 2077 ###### s = savepvn(strbeg, i); 2078 ###### prog->subbeg = s; 2079 } 2080 ###### prog->sublen = i; 2081 } 2082 else { 2083 ###### prog->subbeg = strbeg; 2084 ###### prog->sublen = PL_regeol - strbeg; /* strend may have been modified */ 2085 } 2086 } 2087 2088 ###### return 1; 2089 2090 phooey: 2091 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n", 2092 ###### PL_colors[4], PL_colors[5])); 2093 ###### if (PL_reg_eval_set) 2094 ###### restore_pos(aTHX_ 0); 2095 ###### 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 ###### { 2104 ###### register I32 i; 2105 ###### register I32 *sp; 2106 ###### register I32 *ep; 2107 ###### CHECKPOINT lastcp; 2108 ###### GET_RE_DEBUG_FLAGS_DECL; 2109 2110 #ifdef DEBUGGING 2111 ###### PL_regindent = 0; /* XXXX Not good when matches are reenterable... */ 2112 #endif 2113 ###### if ((prog->reganch & ROPT_EVAL_SEEN) && !PL_reg_eval_set) { 2114 ###### MAGIC *mg; 2115 2116 ###### 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 ###### )); 2121 ###### SAVEI32(cxstack[cxstack_ix].blk_oldsp); 2122 ###### cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base; 2123 /* Otherwise OP_NEXTSTATE will free whatever on stack now. */ 2124 ###### 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 ###### if (PL_reg_sv) { 2130 /* Make $_ available to executed code. */ 2131 ###### if (PL_reg_sv != DEFSV) { 2132 ###### SAVE_DEFSV; 2133 ###### DEFSV = PL_reg_sv; 2134 } 2135 2136 ###### 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 ###### sv_magic(PL_reg_sv, (SV*)0, 2140 PERL_MAGIC_regex_global, Nullch, 0); 2141 ###### mg = mg_find(PL_reg_sv, PERL_MAGIC_regex_global); 2142 ###### mg->mg_len = -1; 2143 } 2144 ###### PL_reg_magic = mg; 2145 ###### PL_reg_oldpos = mg->mg_len; 2146 ###### SAVEDESTRUCTOR_X(restore_pos, 0); 2147 } 2148 ###### if (!PL_reg_curpm) { 2149 ###### 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 ###### PM_SETRE(PL_reg_curpm, prog); 2162 ###### PL_reg_oldcurpm = PL_curpm; 2163 ###### PL_curpm = PL_reg_curpm; 2164 ###### 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 ###### PL_reg_oldsaved = prog->subbeg; 2169 ###### PL_reg_oldsavedlen = prog->sublen; 2170 #ifdef PERL_OLD_COPY_ON_WRITE 2171 PL_nrs = prog->saved_copy; 2172 #endif 2173 ###### RX_MATCH_COPIED_off(prog); 2174 } 2175 else 2176 ###### PL_reg_oldsaved = Nullch; 2177 ###### prog->subbeg = PL_bostr; 2178 ###### prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */ 2179 } 2180 ###### prog->startp[0] = startpos - PL_bostr; 2181 ###### PL_reginput = startpos; 2182 ###### PL_regstartp = prog->startp; 2183 ###### PL_regendp = prog->endp; 2184 ###### PL_reglastparen = &prog->lastparen; 2185 ###### PL_reglastcloseparen = &prog->lastcloseparen; 2186 ###### prog->lastparen = 0; 2187 ###### prog->lastcloseparen = 0; 2188 ###### PL_regsize = 0; 2189 ###### DEBUG_EXECUTE_r(PL_reg_starttry = startpos); 2190 ###### if (PL_reg_start_tmpl <= prog->nparens) { 2191 ###### PL_reg_start_tmpl = prog->nparens*3/2 + 3; 2192 ###### if(PL_reg_start_tmp) 2193 ###### Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*); 2194 else 2195 ###### 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 ###### sp = prog->startp; 2214 ###### ep = prog->endp; 2215 ###### if (prog->nparens) { 2216 ###### for (i = prog->nparens; i > (I32)*PL_reglastparen; i--) { 2217 ###### *++sp = -1; 2218 ###### *++ep = -1; 2219 } 2220 } 2221 #endif 2222 ###### REGCP_SET(lastcp); 2223 ###### if (regmatch(prog->program + 1)) { 2224 ###### prog->endp[0] = PL_reginput - PL_bostr; 2225 ###### return 1; 2226 } 2227 ###### REGCP_UNWIND(lastcp); 2228 ###### 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 ###### { 2387 dVAR; 2388 ###### register regnode *scan; /* Current node. */ 2389 ###### regnode *next; /* Next node. */ 2390 ###### regnode *inner; /* Next node in internal branch. */ 2391 ###### register I32 nextchr; /* renamed nextchr - nextchar colides with 2392 function of same name */ 2393 ###### register I32 n; /* no or next */ 2394 ###### register I32 ln = 0; /* len or last */ 2395 ###### register char *s = Nullch; /* operand or save */ 2396 ###### register char *locinput = PL_reginput; 2397 ###### register I32 c1 = 0, c2 = 0, paren; /* case fold search, parenth */ 2398 ###### int minmod = 0, sw = 0, logical = 0; 2399 ###### I32 unwind = 0; 2400 2401 /* used by the trie code */ 2402 ###### SV *sv_accept_buff = 0; /* accepting states we have traversed */ 2403 ###### reg_trie_accepted *accept_buff = 0; /* "" */ 2404 ###### reg_trie_data *trie; /* what trie are we using right now */ 2405 ###### U32 accepted = 0; /* how many accepting states we have seen*/ 2406 2407 #if 0 2408 I32 firstcp = PL_savestack_ix; 2409 #endif 2410 ###### const register bool do_utf8 = PL_reg_match_utf8; 2411 #ifdef DEBUGGING 2412 ###### SV *dsv0 = PERL_DEBUG_PAD_ZERO(0); 2413 ###### SV *dsv1 = PERL_DEBUG_PAD_ZERO(1); 2414 ###### SV *dsv2 = PERL_DEBUG_PAD_ZERO(2); 2415 2416 ###### SV *re_debug_flags = NULL; 2417 #endif 2418 2419 ###### GET_RE_DEBUG_FLAGS; 2420 2421 #ifdef DEBUGGING 2422 ###### PL_regindent++; 2423 #endif 2424 2425 2426 /* Note that nextchr is a byte even in UTF */ 2427 ###### nextchr = UCHARAT(locinput); 2428 ###### scan = prog; 2429 ###### 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 ###### }); 2495 2496 ###### next = scan + NEXT_OFF(scan); 2497 ###### if (next == scan) 2498 ###### next = NULL; 2499 2500 ###### switch (OP(scan)) { 2501 case BOL: 2502 ###### if (locinput == PL_bostr) 2503 { 2504 /* regtill = regbol; */ 2505 ###### break; 2506 } 2507 ###### sayNO; 2508 case MBOL: 2509 ###### if (locinput == PL_bostr || 2510 ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n')) 2511 { 2512 ###### break; 2513 } 2514 ###### sayNO; 2515 case SBOL: 2516 ###### if (locinput == PL_bostr) 2517 ###### break; 2518 ###### sayNO; 2519 case GPOS: 2520 ###### if (locinput == PL_reg_ganch) 2521 ###### break; 2522 ###### sayNO; 2523 case EOL: 2524 ###### goto seol; 2525 case MEOL: 2526 ###### if ((nextchr || locinput < PL_regeol) && nextchr != '\n') 2527 ###### sayNO; 2528 ###### break; 2529 case SEOL: 2530 seol: 2531 ###### if ((nextchr || locinput < PL_regeol) && nextchr != '\n') 2532 ###### sayNO; 2533 ###### if (PL_regeol - locinput > 1) 2534 ###### sayNO; 2535 ###### break; 2536 case EOS: 2537 ###### if (PL_regeol != locinput) 2538 ###### sayNO; 2539 ###### break; 2540 case SANY: 2541 ###### if (!nextchr && locinput >= PL_regeol) 2542 ###### sayNO; 2543 ###### if (do_utf8) { 2544 ###### locinput += PL_utf8skip[nextchr]; 2545 ###### if (locinput > PL_regeol) 2546 ###### sayNO; 2547 ###### nextchr = UCHARAT(locinput); 2548 } 2549 else 2550 ###### nextchr = UCHARAT(++locinput); 2551 ###### break; 2552 case CANY: 2553 ###### if (!nextchr && locinput >= PL_regeol) 2554 ###### sayNO; 2555 ###### nextchr = UCHARAT(++locinput); 2556 ###### break; 2557 case REG_ANY: 2558 ###### if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n') 2559 ###### sayNO; 2560 ###### if (do_utf8) { 2561 ###### locinput += PL_utf8skip[nextchr]; 2562 ###### if (locinput > PL_regeol) 2563 ###### sayNO; 2564 ###### nextchr = UCHARAT(locinput); 2565 } 2566 else 2567 ###### nextchr = UCHARAT(++locinput); 2568 ###### 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 ###### const U32 uniflags = ckWARN( WARN_UTF8 ) ? 0 : UTF8_ALLOW_ANY; 2587 ###### U8 *uc = ( U8* )locinput; 2588 ###### U32 state = 1; 2589 ###### U16 charid = 0; 2590 ###### U32 base = 0; 2591 ###### UV uvc = 0; 2592 ###### STRLEN len = 0; 2593 ###### STRLEN foldlen = 0; 2594 ###### U8 *uscan = (U8*)NULL; 2595 ###### STRLEN bufflen=0; 2596 ###### accepted = 0; 2597 2598 ###### trie = (reg_trie_data*)PL_regdata->data[ ARG( scan ) ]; 2599 2600 ###### while ( state && uc <= (U8*)PL_regeol ) { 2601 2602 ###### TRIE_CHECK_STATE_IS_ACCEPTING; 2603 2604 ###### 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 ###### ); 2612 2613 ###### if ( base ) { 2614 2615 ###### if ( do_utf8 || UTF ) { 2616 ###### if ( foldlen>0 ) { 2617 ###### uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags ); 2618 ###### foldlen -= len; 2619 ###### uscan += len; 2620 ###### len=0; 2621 } else { 2622 ###### U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ]; 2623 ###### uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags ); 2624 ###### uvc = to_uni_fold( uvc, foldbuf, &foldlen ); 2625 ###### foldlen -= UNISKIP( uvc ); 2626 ###### uscan = foldbuf + UNISKIP( uvc ); 2627 } 2628 } else { 2629 ###### uvc = (UV)*uc; 2630 ###### len = 1; 2631 } 2632 2633 ###### TRIE_HANDLE_CHAR; 2634 2635 } else { 2636 ###### 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 ###### ); 2643 } 2644 ###### if ( !accepted ) { 2645 ###### sayNO; 2646 } else { 2647 ###### 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 ###### const U32 uniflags = ckWARN( WARN_UTF8 ) ? 0 : UTF8_ALLOW_ANY; 2655 ###### U8 *uc = (U8*)locinput; 2656 ###### U32 state = 1; 2657 ###### U16 charid = 0; 2658 ###### U32 base = 0; 2659 ###### UV uvc = 0; 2660 ###### STRLEN len = 0; 2661 ###### STRLEN bufflen = 0; 2662 ###### accepted = 0; 2663 2664 ###### trie = (reg_trie_data*)PL_regdata->data[ ARG( scan ) ]; 2665 2666 ###### while ( state && uc <= (U8*)PL_regeol ) { 2667 2668 ###### TRIE_CHECK_STATE_IS_ACCEPTING; 2669 2670 ###### 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 ###### ); 2678 2679 ###### if ( base ) { 2680 2681 ###### if ( do_utf8 || UTF ) { 2682 ###### uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags ); 2683 } else { 2684 ###### uvc = (U32)*uc; 2685 ###### len = 1; 2686 } 2687 2688 ###### TRIE_HANDLE_CHAR; 2689 2690 } else { 2691 ###### 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 ###### ); 2698 } 2699 ###### if ( !accepted ) { 2700 ###### 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 ###### int gotit = 0; 2720 2721 ###### 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 ###### }); 2731 ###### 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 ###### FREETMPS; 2735 ###### LEAVE; 2736 ###### 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 ###### ); 2743 ###### while ( !gotit && accepted-- ) { 2744 ###### U32 best = 0; 2745 ###### U32 cur; 2746 ###### 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 ###### ); 2754 2755 ###### if ( accept_buff[ cur ].wordnum < accept_buff[ best ].wordnum ) 2756 ###### 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 ###### }); 2766 ###### if ( best= PL_regeol) 2807 ###### sayNO; 2808 ###### 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 ###### sayNO; 2813 ###### l += ulen; 2814 ###### s ++; 2815 } 2816 } 2817 else { 2818 /* The target is not utf8, the pattern is utf8. */ 2819 ###### while (s < e) { 2820 ###### STRLEN ulen; 2821 ###### if (l >= PL_regeol) 2822 ###### sayNO; 2823 ###### 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 ###### sayNO; 2828 ###### s += ulen; 2829 ###### l ++; 2830 } 2831 } 2832 ###### locinput = l; 2833 ###### nextchr = UCHARAT(locinput); 2834 ###### break; 2835 } 2836 /* The target and the pattern have the same utf8ness. */ 2837 /* Inline the first character, for speed. */ 2838 ###### if (UCHARAT(s) != nextchr) 2839 ###### sayNO; 2840 ###### if (PL_regeol - locinput < ln) 2841 ###### sayNO; 2842 ###### if (ln > 1 && memNE(s, locinput, ln)) 2843 ###### sayNO; 2844 ###### locinput += ln; 2845 ###### nextchr = UCHARAT(locinput); 2846 ###### break; 2847 case EXACTFL: 2848 ###### PL_reg_flags |= RF_tainted; 2849 /* FALL THROUGH */ 2850 case EXACTF: 2851 ###### s = STRING(scan); 2852 ###### ln = STR_LEN(scan); 2853 2854 ###### if (do_utf8 || UTF) { 2855 /* Either target or the pattern are utf8. */ 2856 ###### char *l = locinput; 2857 ###### char *e = PL_regeol; 2858 2859 ###### 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 ###### 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 ###### sayNO; 2873 } 2874 ###### locinput = e; 2875 ###### nextchr = UCHARAT(locinput); 2876 ###### break; 2877 } 2878 2879 /* Neither the target and the pattern are utf8. */ 2880 2881 /* Inline the first character, for speed. */ 2882 ###### if (UCHARAT(s) != nextchr && 2883 UCHARAT(s) != ((OP(scan) == EXACTF) 2884 ? PL_fold : PL_fold_locale)[nextchr]) 2885 ###### sayNO; 2886 ###### if (PL_regeol - locinput < ln) 2887 ###### sayNO; 2888 ###### if (ln > 1 && (OP(scan) == EXACTF 2889 ? ibcmp(s, locinput, ln) 2890 : ibcmp_locale(s, locinput, ln))) 2891 ###### sayNO; 2892 ###### locinput += ln; 2893 ###### nextchr = UCHARAT(locinput); 2894 ###### break; 2895 case ANYOF: 2896 ###### if (do_utf8) { 2897 ###### STRLEN inclasslen = PL_regeol - locinput; 2898 2899 ###### if (!reginclass(scan, (U8*)locinput, &inclasslen, do_utf8)) 2900 ###### sayNO_ANYOF; 2901 ###### if (locinput >= PL_regeol) 2902 ###### sayNO; 2903 ###### locinput += inclasslen ? inclasslen : UTF8SKIP(locinput); 2904 ###### nextchr = UCHARAT(locinput); 2905 ###### break; 2906 } 2907 else { 2908 ###### if (nextchr < 0) 2909 ###### nextchr = UCHARAT(locinput); 2910 ###### if (!REGINCLASS(scan, (U8*)locinput)) 2911 ###### sayNO_ANYOF; 2912 ###### if (!nextchr && locinput >= PL_regeol) 2913 ###### sayNO; 2914 ###### nextchr = UCHARAT(++locinput); 2915 ###### break; 2916 } 2917 no_anyof: 2918 /* If we might have the case of the German sharp s 2919 *