X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/5629c67553f30a19f4842982925a3d994d46684c..8bbf3450a1ff0a3996dade29a4194cc0939d871f:/regexec.c diff --git a/regexec.c b/regexec.c index 1145b60..728b1ae 100644 --- a/regexec.c +++ b/regexec.c @@ -67,7 +67,8 @@ * **** Alterations to Henry's code are... **** - **** Copyright (c) 1991-2001, Larry Wall + **** Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, + **** 2000, 2001, 2002, 2003, 2004, by Larry Wall and others **** **** You may distribute under the terms of either the GNU General Public **** License or the Artistic License, as specified in the README file. @@ -80,20 +81,15 @@ #define PERL_IN_REGEXEC_C #include "perl.h" -#ifdef PERL_IN_XSUB_RE -# if defined(PERL_CAPI) || defined(PERL_OBJECT) -# include "XSUB.h" -# endif -#endif - #include "regcomp.h" #define RF_tainted 1 /* tainted information used? */ #define RF_warned 2 /* warned about big count? */ #define RF_evaled 4 /* Did an EVAL with setting? */ #define RF_utf8 8 /* String contains multibyte chars? */ +#define RF_false 16 /* odd number of nested negatives */ -#define UTF (PL_reg_flags & RF_utf8) +#define UTF ((PL_reg_flags & RF_utf8) != 0) #define RS_init 1 /* eval environment created */ #define RS_set 2 /* replsv value is set */ @@ -102,22 +98,24 @@ #define STATIC static #endif +#define REGINCLASS(p,c) (ANYOF_FLAGS(p) ? reginclass(p,c,0,0) : ANYOF_BITMAP_TEST(p,*(c))) + /* * Forwards. */ -#define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv)) -#define CHR_DIST(a,b) (DO_UTF8(PL_reg_sv) ? utf8_distance(a,b) : a - b) +#define CHR_SVLEN(sv) (do_utf8 ? sv_len_utf8(sv) : SvCUR(sv)) +#define CHR_DIST(a,b) (PL_reg_match_utf8 ? utf8_distance(a,b) : a - b) #define reghop_c(pos,off) ((char*)reghop((U8*)pos, off)) #define reghopmaybe_c(pos,off) ((char*)reghopmaybe((U8*)pos, off)) -#define HOP(pos,off) (DO_UTF8(PL_reg_sv) ? reghop((U8*)pos, off) : (U8*)(pos + off)) -#define HOPMAYBE(pos,off) (DO_UTF8(PL_reg_sv) ? reghopmaybe((U8*)pos, off) : (U8*)(pos + off)) +#define HOP(pos,off) (PL_reg_match_utf8 ? reghop((U8*)pos, off) : (U8*)(pos + off)) +#define HOPMAYBE(pos,off) (PL_reg_match_utf8 ? reghopmaybe((U8*)pos, off) : (U8*)(pos + off)) #define HOPc(pos,off) ((char*)HOP(pos,off)) #define HOPMAYBEc(pos,off) ((char*)HOPMAYBE(pos,off)) #define HOPBACK(pos, off) ( \ - (UTF && DO_UTF8(PL_reg_sv)) \ + (PL_reg_match_utf8) \ ? reghopmaybe((U8*)pos, -off) \ : (pos - off >= PL_bostr) \ ? (U8*)(pos - off) \ @@ -127,14 +125,41 @@ #define reghop3_c(pos,off,lim) ((char*)reghop3((U8*)pos, off, (U8*)lim)) #define reghopmaybe3_c(pos,off,lim) ((char*)reghopmaybe3((U8*)pos, off, (U8*)lim)) -#define HOP3(pos,off,lim) (DO_UTF8(PL_reg_sv) ? reghop3((U8*)pos, off, (U8*)lim) : (U8*)(pos + off)) -#define HOPMAYBE3(pos,off,lim) (DO_UTF8(PL_reg_sv) ? reghopmaybe3((U8*)pos, off, (U8*)lim) : (U8*)(pos + off)) +#define HOP3(pos,off,lim) (PL_reg_match_utf8 ? reghop3((U8*)pos, off, (U8*)lim) : (U8*)(pos + off)) +#define HOPMAYBE3(pos,off,lim) (PL_reg_match_utf8 ? reghopmaybe3((U8*)pos, off, (U8*)lim) : (U8*)(pos + off)) #define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim)) #define HOPMAYBE3c(pos,off,lim) ((char*)HOPMAYBE3(pos,off,lim)) -#define LOAD_UTF8_CHARCLASS(a,b) STMT_START { if (!CAT2(PL_utf8_,a)) (void)CAT2(is_utf8_, a)((U8*)b); } STMT_END +#define LOAD_UTF8_CHARCLASS(a,b) STMT_START { if (!CAT2(PL_utf8_,a)) { ENTER; save_re_context(); (void)CAT2(is_utf8_, a)((U8*)b); LEAVE; } } STMT_END + +/* for use after a quantifier and before an EXACT-like node -- japhy */ +#define JUMPABLE(rn) ( \ + OP(rn) == OPEN || OP(rn) == CLOSE || OP(rn) == EVAL || \ + OP(rn) == SUSPEND || OP(rn) == IFMATCH || \ + OP(rn) == PLUS || OP(rn) == MINMOD || \ + (PL_regkind[(U8)OP(rn)] == CURLY && ARG1(rn) > 0) \ +) + +#define HAS_TEXT(rn) ( \ + PL_regkind[(U8)OP(rn)] == EXACT || PL_regkind[(U8)OP(rn)] == REF \ +) -static void restore_pos(pTHXo_ void *arg); +/* + Search for mandatory following text node; for lookahead, the text must + follow but for lookbehind (rn->flags != 0) we skip to the next step. +*/ +#define FIND_NEXT_IMPT(rn) STMT_START { \ + while (JUMPABLE(rn)) \ + if (OP(rn) == SUSPEND || PL_regkind[(U8)OP(rn)] == CURLY) \ + rn = NEXTOPER(NEXTOPER(rn)); \ + else if (OP(rn) == PLUS) \ + rn = NEXTOPER(rn); \ + else if (OP(rn) == IFMATCH) \ + rn = (rn->flags == 0) ? NEXTOPER(NEXTOPER(rn)) : rn + ARG(rn); \ + else rn += NEXT_OFF(rn); \ +} STMT_END + +static void restore_pos(pTHX_ void *arg); STATIC CHECKPOINT S_regcppush(pTHX_ I32 parenfloor) @@ -147,8 +172,8 @@ S_regcppush(pTHX_ I32 parenfloor) if (paren_elems_to_push < 0) Perl_croak(aTHX_ "panic: paren_elems_to_push < 0"); -#define REGCP_OTHER_ELEMS 5 - SSCHECK(paren_elems_to_push + REGCP_OTHER_ELEMS); +#define REGCP_OTHER_ELEMS 6 + SSGROW(paren_elems_to_push + REGCP_OTHER_ELEMS); for (p = PL_regsize; p > parenfloor; p--) { /* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */ SSPUSHINT(PL_regendp[p]); @@ -159,6 +184,7 @@ S_regcppush(pTHX_ I32 parenfloor) /* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */ SSPUSHINT(PL_regsize); SSPUSHINT(*PL_reglastparen); + SSPUSHINT(*PL_reglastcloseparen); SSPUSHPTR(PL_reginput); #define REGCP_FRAME_ELEMS 2 /* REGCP_FRAME_ELEMS are part of the REGCP_OTHER_ELEMS and @@ -192,6 +218,7 @@ S_regcppop(pTHX) assert(i == SAVEt_REGCONTEXT); /* Check that the magic cookie is there. */ i = SSPOPINT; /* Parentheses elements to pop. */ input = (char *) SSPOPPTR; + *PL_reglastcloseparen = SSPOPINT; *PL_reglastparen = SSPOPINT; PL_regsize = SSPOPINT; @@ -214,7 +241,7 @@ S_regcppop(pTHX) ); } DEBUG_r( - if (*PL_reglastparen + 1 <= PL_regnpar) { + if ((I32)(*PL_reglastparen + 1) <= PL_regnpar) { PerlIO_printf(Perl_debug_log, " restoring \\%"IVdf"..\\%"IVdf" to undef\n", (IV)(*PL_reglastparen + 1), (IV)PL_regnpar); @@ -231,8 +258,8 @@ S_regcppop(pTHX) * building DynaLoader will fail: * "Error: '*' not in typemap in DynaLoader.xs, line 164" * --jhi */ - for (paren = *PL_reglastparen + 1; paren <= PL_regnpar; paren++) { - if (paren > PL_regsize) + for (paren = *PL_reglastparen + 1; (I32)paren <= PL_regnpar; paren++) { + if ((I32)paren > PL_regsize) PL_regstartp[paren] = -1; PL_regendp[paren] = -1; } @@ -367,36 +394,68 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, register SV *check; char *strbeg; char *t; + int do_utf8 = sv ? SvUTF8(sv) : 0; /* if no sv we have to assume bytes */ I32 ml_anch; register char *other_last = Nullch; /* other substr checked before this */ char *check_at = Nullch; /* check substr found at this pos */ #ifdef DEBUGGING char *i_strpos = strpos; + SV *dsv = PERL_DEBUG_PAD_ZERO(0); #endif + RX_MATCH_UTF8_set(prog,do_utf8); - DEBUG_r( if (!PL_colorset) reginitcolors() ); - DEBUG_r(PerlIO_printf(Perl_debug_log, - "%sGuessing start of match, REx%s `%s%.60s%s%s' against `%s%.*s%s%s'...\n", - PL_colors[4],PL_colors[5],PL_colors[0], - prog->precomp, - PL_colors[1], - (strlen(prog->precomp) > 60 ? "..." : ""), - PL_colors[0], - (int)(strend - strpos > 60 ? 60 : strend - strpos), - strpos, PL_colors[1], - (strend - strpos > 60 ? "..." : "")) - ); - - if (prog->reganch & ROPT_UTF8) + if (prog->reganch & ROPT_UTF8) { + DEBUG_r(PerlIO_printf(Perl_debug_log, + "UTF-8 regex...\n")); PL_reg_flags |= RF_utf8; + } - if (prog->minlen > CHR_DIST((U8*)strend, (U8*)strpos)) { - DEBUG_r(PerlIO_printf(Perl_debug_log, "String too short...\n")); + DEBUG_r({ + char *s = PL_reg_match_utf8 ? + sv_uni_display(dsv, sv, 60, UNI_DISPLAY_REGEX) : + strpos; + int len = PL_reg_match_utf8 ? + strlen(s) : strend - strpos; + if (!PL_colorset) + reginitcolors(); + if (PL_reg_match_utf8) + DEBUG_r(PerlIO_printf(Perl_debug_log, + "UTF-8 target...\n")); + PerlIO_printf(Perl_debug_log, + "%sGuessing start of match, REx%s `%s%.60s%s%s' against `%s%.*s%s%s'...\n", + PL_colors[4],PL_colors[5],PL_colors[0], + prog->precomp, + PL_colors[1], + (strlen(prog->precomp) > 60 ? "..." : ""), + PL_colors[0], + (int)(len > 60 ? 60 : len), + s, PL_colors[1], + (len > 60 ? "..." : "") + ); + }); + + /* CHR_DIST() would be more correct here but it makes things slow. */ + if (prog->minlen > strend - strpos) { + DEBUG_r(PerlIO_printf(Perl_debug_log, + "String too short... [re_intuit_start]\n")); goto fail; } strbeg = (sv && SvPOK(sv)) ? strend - SvCUR(sv) : strpos; PL_regeol = strend; - check = prog->check_substr; + if (do_utf8) { + if (!prog->check_utf8 && prog->check_substr) + to_utf8_substr(prog); + check = prog->check_utf8; + } else { + if (!prog->check_substr && prog->check_utf8) + to_byte_substr(prog); + check = prog->check_substr; + } + if (check == &PL_sv_undef) { + DEBUG_r(PerlIO_printf(Perl_debug_log, + "Non-utf string cannot match utf check string\n")); + goto fail; + } if (prog->reganch & ROPT_ANCH) { /* Match at beg-of-str or after \n */ ml_anch = !( (prog->reganch & ROPT_ANCH_SINGLE) || ( (prog->reganch & ROPT_ANCH_BOL) @@ -412,7 +471,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, goto fail; } if (prog->check_offset_min == prog->check_offset_max && - !(prog->reganch & ROPT_SANY_SEEN)) { + !(prog->reganch & ROPT_CANY_SEEN)) { /* Substring at constant offset from beg-of-str... */ I32 slen; @@ -485,10 +544,13 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, start_shift + (s - strbeg), end_shift, pp, 0); else goto fail_finish; + /* we may be pointing at the wrong string */ + if (s && RX_MATCH_COPIED(prog)) + s = strbeg + (s - SvPVX(sv)); if (data) *data->scream_olds = s; } - else if (prog->reganch & ROPT_SANY_SEEN) + else if (prog->reganch & ROPT_CANY_SEEN) s = fbm_instr((U8*)(s + start_shift), (U8*)(strend - end_shift), check, PL_multiline ? FBMrf_MULTILINE : 0); @@ -502,7 +564,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, DEBUG_r(PerlIO_printf(Perl_debug_log, "%s %s substr `%s%.*s%s'%s%s", (s ? "Found" : "Did not find"), - ((check == prog->anchored_substr) ? "anchored" : "floating"), + (check == (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) ? "anchored" : "floating"), PL_colors[0], (int)(SvCUR(check) - (SvTAIL(check)!=0)), SvPVX(check), @@ -525,20 +587,21 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, Probably it is right to do no SCREAM here... */ - if (prog->float_substr && prog->anchored_substr) { + if (do_utf8 ? (prog->float_utf8 && prog->anchored_utf8) : (prog->float_substr && prog->anchored_substr)) { /* Take into account the "other" substring. */ /* XXXX May be hopelessly wrong for UTF... */ if (!other_last) other_last = strpos; - if (check == prog->float_substr) { + if (check == (do_utf8 ? prog->float_utf8 : prog->float_substr)) { do_other_anchored: { char *last = HOP3c(s, -start_shift, strbeg), *last1, *last2; char *s1 = s; + SV* must; t = s - prog->check_offset_max; if (s - strpos > prog->check_offset_max /* signed-corrected t > strpos */ - && (!(prog->reganch & ROPT_UTF8) + && (!do_utf8 || ((t = reghopmaybe3_c(s, -(prog->check_offset_max), strpos)) && t > strpos))) /* EMPTY */; @@ -552,20 +615,27 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, last1 = last; /* XXXX It is not documented what units *_offsets are in. Assume bytes. */ /* On end-of-str: see comment below. */ - s = fbm_instr((unsigned char*)t, - HOP3(HOP3(last1, prog->anchored_offset, strend) - + SvCUR(prog->anchored_substr), - -(SvTAIL(prog->anchored_substr)!=0), strbeg), - prog->anchored_substr, - PL_multiline ? FBMrf_MULTILINE : 0); + must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr; + if (must == &PL_sv_undef) { + s = (char*)NULL; + DEBUG_r(must = prog->anchored_utf8); /* for debug */ + } + else + s = fbm_instr( + (unsigned char*)t, + HOP3(HOP3(last1, prog->anchored_offset, strend) + + SvCUR(must), -(SvTAIL(must)!=0), strbeg), + must, + PL_multiline ? FBMrf_MULTILINE : 0 + ); DEBUG_r(PerlIO_printf(Perl_debug_log, "%s anchored substr `%s%.*s%s'%s", (s ? "Found" : "Contradicts"), PL_colors[0], - (int)(SvCUR(prog->anchored_substr) - - (SvTAIL(prog->anchored_substr)!=0)), - SvPVX(prog->anchored_substr), - PL_colors[1], (SvTAIL(prog->anchored_substr) ? "$" : ""))); + (int)(SvCUR(must) + - (SvTAIL(must)!=0)), + SvPVX(must), + PL_colors[1], (SvTAIL(must) ? "$" : ""))); if (!s) { if (last1 >= last2) { DEBUG_r(PerlIO_printf(Perl_debug_log, @@ -592,60 +662,66 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, } } else { /* Take into account the floating substring. */ - char *last, *last1; - char *s1 = s; - - t = HOP3c(s, -start_shift, strbeg); - last1 = last = - HOP3c(strend, -prog->minlen + prog->float_min_offset, strbeg); - if (CHR_DIST((U8*)last, (U8*)t) > prog->float_max_offset) - last = HOP3c(t, prog->float_max_offset, strend); - s = HOP3c(t, prog->float_min_offset, strend); - if (s < other_last) - s = other_last; + char *last, *last1; + char *s1 = s; + SV* must; + + t = HOP3c(s, -start_shift, strbeg); + last1 = last = + HOP3c(strend, -prog->minlen + prog->float_min_offset, strbeg); + if (CHR_DIST((U8*)last, (U8*)t) > prog->float_max_offset) + last = HOP3c(t, prog->float_max_offset, strend); + s = HOP3c(t, prog->float_min_offset, strend); + if (s < other_last) + s = other_last; /* XXXX It is not documented what units *_offsets are in. Assume bytes. */ - /* fbm_instr() takes into account exact value of end-of-str - if the check is SvTAIL(ed). Since false positives are OK, - and end-of-str is not later than strend we are OK. */ + must = do_utf8 ? prog->float_utf8 : prog->float_substr; + /* fbm_instr() takes into account exact value of end-of-str + if the check is SvTAIL(ed). Since false positives are OK, + and end-of-str is not later than strend we are OK. */ + if (must == &PL_sv_undef) { + s = (char*)NULL; + DEBUG_r(must = prog->float_utf8); /* for debug message */ + } + else s = fbm_instr((unsigned char*)s, - (unsigned char*)last + SvCUR(prog->float_substr) - - (SvTAIL(prog->float_substr)!=0), - prog->float_substr, PL_multiline ? FBMrf_MULTILINE : 0); - DEBUG_r(PerlIO_printf(Perl_debug_log, "%s floating substr `%s%.*s%s'%s", - (s ? "Found" : "Contradicts"), - PL_colors[0], - (int)(SvCUR(prog->float_substr) - - (SvTAIL(prog->float_substr)!=0)), - SvPVX(prog->float_substr), - PL_colors[1], (SvTAIL(prog->float_substr) ? "$" : ""))); - if (!s) { - if (last1 == last) { - DEBUG_r(PerlIO_printf(Perl_debug_log, - ", giving up...\n")); - goto fail_finish; - } + (unsigned char*)last + SvCUR(must) + - (SvTAIL(must)!=0), + must, PL_multiline ? FBMrf_MULTILINE : 0); + DEBUG_r(PerlIO_printf(Perl_debug_log, "%s floating substr `%s%.*s%s'%s", + (s ? "Found" : "Contradicts"), + PL_colors[0], + (int)(SvCUR(must) - (SvTAIL(must)!=0)), + SvPVX(must), + PL_colors[1], (SvTAIL(must) ? "$" : ""))); + if (!s) { + if (last1 == last) { DEBUG_r(PerlIO_printf(Perl_debug_log, - ", trying anchored starting at offset %ld...\n", - (long)(s1 + 1 - i_strpos))); - other_last = last; - s = HOP3c(t, 1, strend); - goto restart; - } - else { - DEBUG_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n", - (long)(s - i_strpos))); - other_last = s; /* Fix this later. --Hugo */ - s = s1; - if (t == strpos) - goto try_at_start; - goto try_at_offset; + ", giving up...\n")); + goto fail_finish; } + DEBUG_r(PerlIO_printf(Perl_debug_log, + ", trying anchored starting at offset %ld...\n", + (long)(s1 + 1 - i_strpos))); + other_last = last; + s = HOP3c(t, 1, strend); + goto restart; + } + else { + DEBUG_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n", + (long)(s - i_strpos))); + other_last = s; /* Fix this later. --Hugo */ + s = s1; + if (t == strpos) + goto try_at_start; + goto try_at_offset; + } } } t = s - prog->check_offset_max; if (s - strpos > prog->check_offset_max /* signed-corrected t > strpos */ - && (!(prog->reganch & ROPT_UTF8) + && (!do_utf8 || ((t = reghopmaybe3_c(s, -prog->check_offset_max, strpos)) && t > strpos))) { /* Fixed substring is found far enough so that the match @@ -662,7 +738,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, while (t < strend - prog->minlen) { if (*t == '\n') { if (t < check_at - prog->check_offset_min) { - if (prog->anchored_substr) { + if (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) { /* Since we moved from the found position, we definitely contradict the found anchored substr. Due to the above check we do not @@ -702,7 +778,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, } s = t; set_useful: - ++BmUSEFUL(prog->check_substr); /* hooray/5 */ + ++BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr); /* hooray/5 */ } else { /* The found string does not prohibit matching at strpos, @@ -726,15 +802,23 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, ); success_at_start: if (!(prog->reganch & ROPT_NAUGHTY) /* XXXX If strpos moved? */ - && prog->check_substr /* Could be deleted already */ - && --BmUSEFUL(prog->check_substr) < 0 - && prog->check_substr == prog->float_substr) + && (do_utf8 ? ( + prog->check_utf8 /* Could be deleted already */ + && --BmUSEFUL(prog->check_utf8) < 0 + && (prog->check_utf8 == prog->float_utf8) + ) : ( + prog->check_substr /* Could be deleted already */ + && --BmUSEFUL(prog->check_substr) < 0 + && (prog->check_substr == prog->float_substr) + ))) { /* If flags & SOMETHING - do not do it many times on the same match */ DEBUG_r(PerlIO_printf(Perl_debug_log, "... Disabling check substring...\n")); - SvREFCNT_dec(prog->check_substr); - prog->check_substr = Nullsv; /* disable */ - prog->float_substr = Nullsv; /* clear */ + SvREFCNT_dec(do_utf8 ? prog->check_utf8 : prog->check_substr); + if (do_utf8 ? prog->check_substr : prog->check_utf8) + SvREFCNT_dec(do_utf8 ? prog->check_substr : prog->check_utf8); + prog->check_substr = prog->check_utf8 = Nullsv; /* disable */ + prog->float_substr = prog->float_utf8 = Nullsv; /* clear */ check = Nullsv; /* abort */ s = strpos; /* XXXX This is a remnant of the old implementation. It @@ -761,20 +845,17 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, int cl_l = (PL_regkind[(U8)OP(prog->regstclass)] == EXACT ? CHR_DIST(str+STR_LEN(prog->regstclass), str) : 1); - char *endpos = (prog->anchored_substr || ml_anch) + char *endpos = (prog->anchored_substr || prog->anchored_utf8 || ml_anch) ? HOP3c(s, (prog->minlen ? cl_l : 0), strend) - : (prog->float_substr + : (prog->float_substr || prog->float_utf8 ? HOP3c(HOP3c(check_at, -start_shift, strbeg), cl_l, strend) : strend); char *startpos = strbeg; t = s; - if (prog->reganch & ROPT_UTF8) { - PL_regdata = prog->data; - PL_bostr = startpos; - } - s = find_byclass(prog, prog->regstclass, s, endpos, startpos, 1); + cache_re(prog); + s = find_byclass(prog, prog->regstclass, s, endpos, startpos, 1); if (!s) { #ifdef DEBUGGING char *what = 0; @@ -789,8 +870,8 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, if ((prog->reganch & ROPT_ANCH) && !ml_anch) goto fail; /* Contradict one of substrings */ - if (prog->anchored_substr) { - if (prog->anchored_substr == check) { + if (prog->anchored_substr || prog->anchored_utf8) { + if ((do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) == check) { DEBUG_r( what = "anchored" ); hop_and_restart: s = HOP3c(t, 1, strend); @@ -830,7 +911,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, PL_colors[0],PL_colors[1], (long)(t - i_strpos)) ); goto try_at_offset; } - if (!prog->float_substr) /* Could have been deleted */ + if (!(do_utf8 ? prog->float_utf8 : prog->float_substr)) /* Could have been deleted */ goto fail; /* Check is floating subtring. */ retry_floating_check: @@ -857,8 +938,8 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, return s; fail_finish: /* Substring not found */ - if (prog->check_substr) /* could be removed already */ - BmUSEFUL(prog->check_substr) += 5; /* hooray */ + if (prog->check_substr || prog->check_utf8) /* could be removed already */ + BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr) += 5; /* hooray */ fail: DEBUG_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n", PL_colors[4],PL_colors[5])); @@ -872,33 +953,83 @@ S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *sta I32 doevery = (prog->reganch & ROPT_SKIP) == 0; char *m; STRLEN ln; + STRLEN lnc; unsigned int c1; unsigned int c2; char *e; register I32 tmp = 1; /* Scratch variable? */ - register bool do_utf8 = DO_UTF8(PL_reg_sv); + register bool do_utf8 = PL_reg_match_utf8; /* We know what class it must start with. */ switch (OP(c)) { case ANYOF: + if (do_utf8) { + while (s < strend) { + if ((ANYOF_FLAGS(c) & ANYOF_UNICODE) || + !UTF8_IS_INVARIANT((U8)s[0]) ? + reginclass(c, (U8*)s, 0, do_utf8) : + REGINCLASS(c, (U8*)s)) { + if (tmp && (norun || regtry(prog, s))) + goto got_it; + else + tmp = doevery; + } + else + tmp = 1; + s += UTF8SKIP(s); + } + } + else { + while (s < strend) { + STRLEN skip = 1; + + if (REGINCLASS(c, (U8*)s) || + (ANYOF_FOLD_SHARP_S(c, s, strend) && + /* The assignment of 2 is intentional: + * for the folded sharp s, the skip is 2. */ + (skip = SHARP_S_SKIP))) { + if (tmp && (norun || regtry(prog, s))) + goto got_it; + else + tmp = doevery; + } + else + tmp = 1; + s += skip; + } + } + break; + case CANY: while (s < strend) { - if (reginclass(c, (U8*)s, do_utf8)) { - if (tmp && (norun || regtry(prog, s))) - goto got_it; - else - tmp = doevery; - } + if (tmp && (norun || regtry(prog, s))) + goto got_it; else - tmp = 1; - s += do_utf8 ? UTF8SKIP(s) : 1; + tmp = doevery; + s++; } break; case EXACTF: - m = STRING(c); - ln = STR_LEN(c); + m = STRING(c); + ln = STR_LEN(c); /* length to match in octets/bytes */ + lnc = (I32) ln; /* length to match in characters */ if (UTF) { - c1 = to_utf8_lower((U8*)m); - c2 = to_utf8_upper((U8*)m); + STRLEN ulen1, ulen2; + U8 *sm = (U8 *) m; + U8 tmpbuf1[UTF8_MAXLEN_UCLC+1]; + U8 tmpbuf2[UTF8_MAXLEN_UCLC+1]; + + to_utf8_lower((U8*)m, tmpbuf1, &ulen1); + to_utf8_upper((U8*)m, tmpbuf2, &ulen2); + + c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXLEN_UCLC, + 0, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY); + c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXLEN_UCLC, + 0, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY); + lnc = 0; + while (sm < ((U8 *) m + ln)) { + lnc++; + sm += UTF8SKIP(sm); + } } else { c1 = *(U8*)m; @@ -906,32 +1037,102 @@ S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *sta } goto do_exactf; case EXACTFL: - m = STRING(c); - ln = STR_LEN(c); + m = STRING(c); + ln = STR_LEN(c); + lnc = (I32) ln; c1 = *(U8*)m; c2 = PL_fold_locale[c1]; do_exactf: - e = strend - ln; + e = HOP3c(strend, -((I32)lnc), s); if (norun && e < s) e = s; /* Due to minlen logic of intuit() */ + /* The idea in the EXACTF* cases is to first find the + * first character of the EXACTF* node and then, if + * necessary, case-insensitively compare the full + * text of the node. The c1 and c2 are the first + * characters (though in Unicode it gets a bit + * more complicated because there are more cases + * than just upper and lower: one needs to use + * the so-called folding case for case-insensitive + * matching (called "loose matching" in Unicode). + * ibcmp_utf8() will do just that. */ + if (do_utf8) { - STRLEN len; - if (c1 == c2) + UV c, f; + U8 tmpbuf [UTF8_MAXLEN+1]; + U8 foldbuf[UTF8_MAXLEN_FOLD+1]; + STRLEN len, foldlen; + + if (c1 == c2) { + /* Upper and lower of 1st char are equal - + * probably not a "letter". */ while (s <= e) { - if ( utf8_to_uvchr((U8*)s, &len) == c1 - && regtry(prog, s) ) + c = utf8n_to_uvchr((U8*)s, UTF8_MAXLEN, &len, + ckWARN(WARN_UTF8) ? + 0 : UTF8_ALLOW_ANY); + if ( c == c1 + && (ln == len || + ibcmp_utf8(s, (char **)0, 0, do_utf8, + m, (char **)0, ln, (bool)UTF)) + && (norun || regtry(prog, s)) ) goto got_it; + else { + uvchr_to_utf8(tmpbuf, c); + f = to_utf8_fold(tmpbuf, foldbuf, &foldlen); + if ( f != c + && (f == c1 || f == c2) + && (ln == foldlen || + !ibcmp_utf8((char *) foldbuf, + (char **)0, foldlen, do_utf8, + m, + (char **)0, ln, (bool)UTF)) + && (norun || regtry(prog, s)) ) + goto got_it; + } s += len; } - else + } + else { while (s <= e) { - UV c = utf8_to_uvchr((U8*)s, &len); - if ( (c == c1 || c == c2) && regtry(prog, s) ) + c = utf8n_to_uvchr((U8*)s, UTF8_MAXLEN, &len, + ckWARN(WARN_UTF8) ? + 0 : UTF8_ALLOW_ANY); + + /* Handle some of the three Greek sigmas cases. + * Note that not all the possible combinations + * are handled here: some of them are handled + * by the standard folding rules, and some of + * them (the character class or ANYOF cases) + * are handled during compiletime in + * regexec.c:S_regclass(). */ + if (c == (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA || + c == (UV)UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA) + c = (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA; + + if ( (c == c1 || c == c2) + && (ln == len || + ibcmp_utf8(s, (char **)0, 0, do_utf8, + m, (char **)0, ln, (bool)UTF)) + && (norun || regtry(prog, s)) ) goto got_it; + else { + uvchr_to_utf8(tmpbuf, c); + f = to_utf8_fold(tmpbuf, foldbuf, &foldlen); + if ( f != c + && (f == c1 || f == c2) + && (ln == foldlen || + !ibcmp_utf8((char *) foldbuf, + (char **)0, foldlen, do_utf8, + m, + (char **)0, ln, (bool)UTF)) + && (norun || regtry(prog, s)) ) + goto got_it; + } s += len; } + } } else { if (c1 == c2) @@ -964,10 +1165,9 @@ S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *sta if (s == PL_bostr) tmp = '\n'; else { - U8 *r = reghop3((U8*)s, -1, (U8*)startpos); + U8 *r = reghop3((U8*)s, -1, (U8*)PL_bostr); - if (s > (char*)r) - tmp = (I32)utf8n_to_uvchr(r, s - (char*)r, 0, 0); + tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, 0); } tmp = ((OP(c) == BOUND ? isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0); @@ -1008,10 +1208,9 @@ S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *sta if (s == PL_bostr) tmp = '\n'; else { - U8 *r = reghop3((U8*)s, -1, (U8*)startpos); + U8 *r = reghop3((U8*)s, -1, (U8*)PL_bostr); - if (s > (char*)r) - tmp = (I32)utf8n_to_uvchr(r, s - (char*)r, 0, 0); + tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, 0); } tmp = ((OP(c) == NBOUND ? isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0); @@ -1423,6 +1622,11 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * char *scream_olds; SV* oreplsv = GvSV(PL_replgv); bool do_utf8 = DO_UTF8(sv); +#ifdef DEBUGGING + SV *dsv0 = PERL_DEBUG_PAD_ZERO(0); + SV *dsv1 = PERL_DEBUG_PAD_ZERO(1); +#endif + RX_MATCH_UTF8_set(prog,do_utf8); PL_regcc = 0; @@ -1438,12 +1642,10 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * } minlen = prog->minlen; - if (do_utf8) { - if (!(prog->reganch & ROPT_SANY_SEEN)) - if (utf8_distance((U8*)strend, (U8*)startpos) < minlen) goto phooey; - } - else { - if (strend - startpos < minlen) goto phooey; + if (strend - startpos < minlen) { + DEBUG_r(PerlIO_printf(Perl_debug_log, + "String too short [regexec_flags]...\n")); + goto phooey; } /* Check validity of program. */ @@ -1486,7 +1688,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * && mg->mg_len >= 0) { PL_reg_ganch = strbeg + mg->mg_len; /* Defined pos() */ if (prog->reganch & ROPT_ANCH_GPOS) { - if (s > PL_reg_ganch) + if (s > PL_reg_ganch) goto phooey; s = PL_reg_ganch; } @@ -1495,29 +1697,41 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * PL_reg_ganch = strbeg; } - if (do_utf8 == (UTF!=0) && - !(flags & REXEC_CHECKED) && prog->check_substr != Nullsv) { + if (!(flags & REXEC_CHECKED) && (prog->check_substr != Nullsv || prog->check_utf8 != Nullsv)) { re_scream_pos_data d; d.scream_olds = &scream_olds; d.scream_pos = &scream_pos; s = re_intuit_start(prog, sv, s, strend, flags, &d); - if (!s) + if (!s) { + DEBUG_r(PerlIO_printf(Perl_debug_log, "Not present...\n")); goto phooey; /* not present */ + } } - DEBUG_r( if (!PL_colorset) reginitcolors() ); - DEBUG_r(PerlIO_printf(Perl_debug_log, - "%sMatching REx%s `%s%.60s%s%s' against `%s%.*s%s%s'\n", - PL_colors[4],PL_colors[5],PL_colors[0], - prog->precomp, - PL_colors[1], - (strlen(prog->precomp) > 60 ? "..." : ""), - PL_colors[0], - (int)(strend - startpos > 60 ? 60 : strend - startpos), - startpos, PL_colors[1], - (strend - startpos > 60 ? "..." : "")) - ); + DEBUG_r({ + char *s0 = UTF ? + pv_uni_display(dsv0, (U8*)prog->precomp, prog->prelen, 60, + UNI_DISPLAY_REGEX) : + prog->precomp; + int len0 = UTF ? SvCUR(dsv0) : prog->prelen; + char *s1 = do_utf8 ? sv_uni_display(dsv1, sv, 60, + UNI_DISPLAY_REGEX) : startpos; + int len1 = do_utf8 ? SvCUR(dsv1) : strend - startpos; + if (!PL_colorset) + reginitcolors(); + PerlIO_printf(Perl_debug_log, + "%sMatching REx%s `%s%*.*s%s%s' against `%s%.*s%s%s'\n", + PL_colors[4],PL_colors[5],PL_colors[0], + len0, len0, s0, + PL_colors[1], + len0 > 60 ? "..." : "", + PL_colors[0], + (int)(len1 > 60 ? 60 : len1), + s1, PL_colors[1], + (len1 > 60 ? "..." : "") + ); + }); /* Simplest case: anchored match need be tried only once. */ /* [unless only anchor is BOL and multiline is set] */ @@ -1533,7 +1747,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * dontbother = minlen - 1; end = HOP3c(strend, -dontbother, strbeg) - 1; /* for multiline we only have to try after newlines */ - if (prog->check_substr) { + if (prog->check_substr || prog->check_utf8) { if (s == startpos) goto after_try; while (1) { @@ -1569,13 +1783,16 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * } /* Messy cases: unanchored match. */ - if (prog->anchored_substr && prog->reganch & ROPT_SKIP) { + if ((prog->anchored_substr || prog->anchored_utf8) && prog->reganch & ROPT_SKIP) { /* we have /x+whatever/ */ /* it must be a one character string (XXXX Except UTF?) */ - char ch = SvPVX(prog->anchored_substr)[0]; + char ch; #ifdef DEBUGGING int did_match = 0; #endif + if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)) + do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog); + ch = SvPVX(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)[0]; if (do_utf8) { while (s < strend) { @@ -1607,23 +1824,37 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * ); } /*SUPPRESS 560*/ - else if (do_utf8 == (UTF!=0) && - (prog->anchored_substr != Nullsv - || (prog->float_substr != Nullsv - && prog->float_max_offset < strend - s))) { - SV *must = prog->anchored_substr - ? prog->anchored_substr : prog->float_substr; - I32 back_max = - prog->anchored_substr ? prog->anchored_offset : prog->float_max_offset; - I32 back_min = - prog->anchored_substr ? prog->anchored_offset : prog->float_min_offset; - char *last = HOP3c(strend, /* Cannot start after this */ - -(I32)(CHR_SVLEN(must) - - (SvTAIL(must) != 0) + back_min), strbeg); + else if (prog->anchored_substr != Nullsv + || prog->anchored_utf8 != Nullsv + || ((prog->float_substr != Nullsv || prog->float_utf8 != Nullsv) + && prog->float_max_offset < strend - s)) { + SV *must; + I32 back_max; + I32 back_min; + char *last; char *last1; /* Last position checked before */ #ifdef DEBUGGING int did_match = 0; #endif + if (prog->anchored_substr || prog->anchored_utf8) { + if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)) + do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog); + must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr; + back_max = back_min = prog->anchored_offset; + } else { + if (!(do_utf8 ? prog->float_utf8 : prog->float_substr)) + do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog); + must = do_utf8 ? prog->float_utf8 : prog->float_substr; + back_max = prog->float_max_offset; + back_min = prog->float_min_offset; + } + if (must == &PL_sv_undef) + /* could not downgrade utf8 check substring, so must fail */ + goto phooey; + + last = HOP3c(strend, /* Cannot start after this */ + -(I32)(CHR_SVLEN(must) + - (SvTAIL(must) != 0) + back_min), strbeg); if (s > PL_bostr) last1 = HOPc(s, -1); @@ -1642,6 +1873,9 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * : (s = fbm_instr((unsigned char*)HOP3(s, back_min, strend), (unsigned char*)strend, must, PL_multiline ? FBMrf_MULTILINE : 0))) ) { + /* we may be pointing at the wrong string */ + if ((flags & REXEC_SCREAM) && RX_MATCH_COPIED(prog)) + s = strbeg + (s - SvPVX(sv)); DEBUG_r( did_match = 1 ); if (HOPc(s, -back_max) > last1) { last1 = HOPc(s, -back_min); @@ -1671,7 +1905,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * DEBUG_r(if (!did_match) PerlIO_printf(Perl_debug_log, "Did not find %s substr `%s%.*s%s'%s...\n", - ((must == prog->anchored_substr) + ((must == prog->anchored_substr || must == prog->anchored_utf8) ? "anchored" : "floating"), PL_colors[0], (int)(SvCUR(must) - (SvTAIL(must)!=0)), @@ -1681,13 +1915,32 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * goto phooey; } else if ((c = prog->regstclass)) { - if (minlen && PL_regkind[(U8)OP(prog->regstclass)] != EXACT) + if (minlen) { + I32 op = (U8)OP(prog->regstclass); /* don't bother with what can't match */ - strend = HOPc(strend, -(minlen - 1)); + if (PL_regkind[op] != EXACT && op != CANY) + strend = HOPc(strend, -(minlen - 1)); + } DEBUG_r({ SV *prop = sv_newmortal(); + char *s0; + char *s1; + int len0; + int len1; + regprop(prop, c); - PerlIO_printf(Perl_debug_log, "Matching stclass `%s' against `%s'\n", SvPVX(prop), s); + s0 = UTF ? + pv_uni_display(dsv0, (U8*)SvPVX(prop), SvCUR(prop), 60, + UNI_DISPLAY_REGEX) : + SvPVX(prop); + len0 = UTF ? SvCUR(dsv0) : SvCUR(prop); + s1 = UTF ? + sv_uni_display(dsv1, sv, 60, UNI_DISPLAY_REGEX) : s; + len1 = UTF ? SvCUR(dsv1) : strend - s; + PerlIO_printf(Perl_debug_log, + "Matching stclass `%*.*s' against `%*.*s'\n", + len0, len0, s0, + len1, len1, s1); }); if (find_byclass(prog, c, s, strend, startpos, 0)) goto got_it; @@ -1695,20 +1948,29 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * } else { dontbother = 0; - if (prog->float_substr != Nullsv) { /* Trim the end. */ + if (prog->float_substr != Nullsv || prog->float_utf8 != Nullsv) { + /* Trim the end. */ char *last; + SV* float_real; + + if (!(do_utf8 ? prog->float_utf8 : prog->float_substr)) + do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog); + float_real = do_utf8 ? prog->float_utf8 : prog->float_substr; if (flags & REXEC_SCREAM) { - last = screaminstr(sv, prog->float_substr, s - strbeg, + last = screaminstr(sv, float_real, s - strbeg, end_shift, &scream_pos, 1); /* last one */ if (!last) last = scream_olds; /* Only one occurrence. */ + /* we may be pointing at the wrong string */ + else if (RX_MATCH_COPIED(prog)) + s = strbeg + (s - SvPVX(sv)); } else { STRLEN len; - char *little = SvPV(prog->float_substr, len); + char *little = SvPV(float_real, len); - if (SvTAIL(prog->float_substr)) { + if (SvTAIL(float_real)) { if (memEQ(strend - len + 1, little, len - 1)) last = strend - len + 1; else if (!PL_multiline) @@ -1765,22 +2027,33 @@ got_it: sv_setsv(oreplsv, GvSV(PL_replgv));/* So that when GvSV(replgv) is restored, the value remains the same. */ - restore_pos(aTHXo_ 0); + restore_pos(aTHX_ 0); } /* make sure $`, $&, $', and $digit will work later */ if ( !(flags & REXEC_NOT_FIRST) ) { - if (RX_MATCH_COPIED(prog)) { - Safefree(prog->subbeg); - RX_MATCH_COPIED_off(prog); - } + RX_MATCH_COPY_FREE(prog); if (flags & REXEC_COPY_STR) { I32 i = PL_regeol - startpos + (stringarg - strbeg); - - s = savepvn(strbeg, i); - prog->subbeg = s; +#ifdef PERL_COPY_ON_WRITE + if ((SvIsCOW(sv) + || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) { + if (DEBUG_C_TEST) { + PerlIO_printf(Perl_debug_log, + "Copy on write: regexp capture, type %d\n", + (int) SvTYPE(sv)); + } + prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv); + prog->subbeg = SvPVX(prog->saved_copy); + assert (SvPOKp(prog->saved_copy)); + } else +#endif + { + RX_MATCH_COPIED_on(prog); + s = savepvn(strbeg, i); + prog->subbeg = s; + } prog->sublen = i; - RX_MATCH_COPIED_on(prog); } else { prog->subbeg = strbeg; @@ -1794,7 +2067,7 @@ phooey: DEBUG_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n", PL_colors[4],PL_colors[5])); if (PL_reg_eval_set) - restore_pos(aTHXo_ 0); + restore_pos(aTHX_ 0); return 0; } @@ -1831,8 +2104,7 @@ S_regtry(pTHX_ regexp *prog, char *startpos) if (PL_reg_sv) { /* Make $_ available to executed code. */ if (PL_reg_sv != DEFSV) { - /* SAVE_DEFSV does *not* suffice here for USE_THREADS */ - SAVESPTR(DEFSV); + SAVE_DEFSV; DEFSV = PL_reg_sv; } @@ -1848,8 +2120,19 @@ S_regtry(pTHX_ regexp *prog, char *startpos) PL_reg_oldpos = mg->mg_len; SAVEDESTRUCTOR_X(restore_pos, 0); } - if (!PL_reg_curpm) + if (!PL_reg_curpm) { Newz(22,PL_reg_curpm, 1, PMOP); +#ifdef USE_ITHREADS + { + SV* repointer = newSViv(0); + /* so we know which PL_regex_padav element is PL_reg_curpm */ + SvFLAGS(repointer) |= SVf_BREAK; + av_push(PL_regex_padav,repointer); + PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav); + PL_regex_pad = AvARRAY(PL_regex_padav); + } +#endif + } PM_SETRE(PL_reg_curpm, prog); PL_reg_oldcurpm = PL_curpm; PL_curpm = PL_reg_curpm; @@ -1859,6 +2142,9 @@ S_regtry(pTHX_ regexp *prog, char *startpos) $` inside (?{}) could fail... */ PL_reg_oldsaved = prog->subbeg; PL_reg_oldsavedlen = prog->sublen; +#ifdef PERL_COPY_ON_WRITE + PL_nrs = prog->saved_copy; +#endif RX_MATCH_COPIED_off(prog); } else @@ -1871,7 +2157,9 @@ S_regtry(pTHX_ regexp *prog, char *startpos) PL_regstartp = prog->startp; PL_regendp = prog->endp; PL_reglastparen = &prog->lastparen; + PL_reglastcloseparen = &prog->lastcloseparen; prog->lastparen = 0; + prog->lastcloseparen = 0; PL_regsize = 0; DEBUG_r(PL_reg_starttry = startpos); if (PL_reg_start_tmpl <= prog->nparens) { @@ -1900,7 +2188,7 @@ S_regtry(pTHX_ regexp *prog, char *startpos) sp = prog->startp; ep = prog->endp; if (prog->nparens) { - for (i = prog->nparens; i > *PL_reglastparen; i--) { + for (i = prog->nparens; i > (I32)*PL_reglastparen; i--) { *++sp = -1; *++ep = -1; } @@ -1945,6 +2233,17 @@ typedef union re_unwind_t { re_unwind_branch_t branch; } re_unwind_t; +#define sayYES goto yes +#define sayNO goto no +#define sayNO_ANYOF goto no_anyof +#define sayYES_FINAL goto yes_final +#define sayYES_LOUD goto yes_loud +#define sayNO_FINAL goto no_final +#define sayNO_SILENT goto do_no +#define saySAME(x) if (x) goto yes; else goto no + +#define REPORT_CODE_OFF 24 + /* - regmatch - main matching routine * @@ -1977,7 +2276,12 @@ S_regmatch(pTHX_ regnode *prog) #if 0 I32 firstcp = PL_savestack_ix; #endif - register bool do_utf8 = DO_UTF8(PL_reg_sv); + register bool do_utf8 = PL_reg_match_utf8; +#ifdef DEBUGGING + SV *dsv0 = PERL_DEBUG_PAD_ZERO(0); + SV *dsv1 = PERL_DEBUG_PAD_ZERO(1); + SV *dsv2 = PERL_DEBUG_PAD_ZERO(2); +#endif #ifdef DEBUGGING PL_regindent++; @@ -1987,26 +2291,8 @@ S_regmatch(pTHX_ regnode *prog) nextchr = UCHARAT(locinput); scan = prog; while (scan != NULL) { -#define sayNO_L (logical ? (logical = 0, sw = 0, goto cont) : sayNO) -#if 1 -# define sayYES goto yes -# define sayNO goto no -# define sayYES_FINAL goto yes_final -# define sayYES_LOUD goto yes_loud -# define sayNO_FINAL goto no_final -# define sayNO_SILENT goto do_no -# define saySAME(x) if (x) goto yes; else goto no -# define REPORT_CODE_OFF 24 -#else -# define sayYES return 1 -# define sayNO return 0 -# define sayYES_FINAL return 1 -# define sayYES_LOUD return 1 -# define sayNO_FINAL return 0 -# define sayNO_SILENT return 0 -# define saySAME(x) return x -#endif - DEBUG_r( { + + DEBUG_r( { SV *prop = sv_newmortal(); int docolor = *PL_colors[0]; int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */ @@ -2021,33 +2307,55 @@ S_regmatch(pTHX_ regnode *prog) ? (5 + taill) - l : locinput - PL_bostr; int pref0_len; - while (UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len))) + while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len))) pref_len++; pref0_len = pref_len - (locinput - PL_reg_starttry); if (l + pref_len < (5 + taill) && l < PL_regeol - locinput) l = ( PL_regeol - locinput > (5 + taill) - pref_len ? (5 + taill) - pref_len : PL_regeol - locinput); - while (UTF8_IS_CONTINUATION(*(U8*)(locinput + l))) + while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput + l))) l--; if (pref0_len < 0) pref0_len = 0; if (pref0_len > pref_len) pref0_len = pref_len; regprop(prop, scan); - PerlIO_printf(Perl_debug_log, - "%4"IVdf" <%s%.*s%s%s%.*s%s%s%s%.*s%s>%*s|%3"IVdf":%*s%s\n", - (IV)(locinput - PL_bostr), - PL_colors[4], pref0_len, - locinput - pref_len, PL_colors[5], - PL_colors[2], pref_len - pref0_len, - locinput - pref_len + pref0_len, PL_colors[3], - (docolor ? "" : "> <"), - PL_colors[0], l, locinput, PL_colors[1], - 15 - l - pref_len + 1, - "", - (IV)(scan - PL_regprogram), PL_regindent*2, "", - SvPVX(prop)); - } ); + { + char *s0 = + do_utf8 && OP(scan) != CANY ? + pv_uni_display(dsv0, (U8*)(locinput - pref_len), + pref0_len, 60, UNI_DISPLAY_REGEX) : + locinput - pref_len; + int len0 = do_utf8 ? strlen(s0) : pref0_len; + char *s1 = do_utf8 && OP(scan) != CANY ? + pv_uni_display(dsv1, (U8*)(locinput - pref_len + pref0_len), + pref_len - pref0_len, 60, UNI_DISPLAY_REGEX) : + locinput - pref_len + pref0_len; + int len1 = do_utf8 ? strlen(s1) : pref_len - pref0_len; + char *s2 = do_utf8 && OP(scan) != CANY ? + pv_uni_display(dsv2, (U8*)locinput, + PL_regeol - locinput, 60, UNI_DISPLAY_REGEX) : + locinput; + int len2 = do_utf8 ? strlen(s2) : l; + PerlIO_printf(Perl_debug_log, + "%4"IVdf" <%s%.*s%s%s%.*s%s%s%s%.*s%s>%*s|%3"IVdf":%*s%s\n", + (IV)(locinput - PL_bostr), + PL_colors[4], + len0, s0, + PL_colors[5], + PL_colors[2], + len1, s1, + PL_colors[3], + (docolor ? "" : "> <"), + PL_colors[0], + len2, s2, + PL_colors[1], + 15 - l - pref_len + 1, + "", + (IV)(scan - PL_regprogram), PL_regindent*2, "", + SvPVX(prop)); + } + }); next = scan + NEXT_OFF(scan); if (next == scan) @@ -2101,6 +2409,18 @@ S_regmatch(pTHX_ regnode *prog) case SANY: if (!nextchr && locinput >= PL_regeol) sayNO; + if (do_utf8) { + locinput += PL_utf8skip[nextchr]; + if (locinput > PL_regeol) + sayNO; + nextchr = UCHARAT(locinput); + } + else + nextchr = UCHARAT(++locinput); + break; + case CANY: + if (!nextchr && locinput >= PL_regeol) + sayNO; nextchr = UCHARAT(++locinput); break; case REG_ANY: @@ -2118,32 +2438,45 @@ S_regmatch(pTHX_ regnode *prog) case EXACT: s = STRING(scan); ln = STR_LEN(scan); - if (do_utf8 != (UTF!=0)) { + if (do_utf8 != UTF) { + /* The target and the pattern have differing utf8ness. */ char *l = locinput; char *e = s + ln; - STRLEN len; - if (do_utf8) + STRLEN ulen; + + if (do_utf8) { + /* The target is utf8, the pattern is not utf8. */ while (s < e) { if (l >= PL_regeol) - sayNO; - if (*((U8*)s) != utf8_to_uvchr((U8*)l, &len)) - sayNO; - s++; - l += len; + sayNO; + if (NATIVE_TO_UNI(*(U8*)s) != + utf8n_to_uvuni((U8*)l, UTF8_MAXLEN, &ulen, + ckWARN(WARN_UTF8) ? + 0 : UTF8_ALLOW_ANY)) + sayNO; + l += ulen; + s ++; } - else + } + else { + /* The target is not utf8, the pattern is utf8. */ while (s < e) { if (l >= PL_regeol) sayNO; - if (*((U8*)l) != utf8_to_uvchr((U8*)s, &len)) + if (NATIVE_TO_UNI(*((U8*)l)) != + utf8n_to_uvuni((U8*)s, UTF8_MAXLEN, &ulen, + ckWARN(WARN_UTF8) ? + 0 : UTF8_ALLOW_ANY)) sayNO; - s += len; - l++; + s += ulen; + l ++; } + } locinput = l; nextchr = UCHARAT(locinput); break; } + /* The target and the pattern have the same utf8ness. */ /* Inline the first character, for speed. */ if (UCHARAT(s) != nextchr) sayNO; @@ -2161,26 +2494,33 @@ S_regmatch(pTHX_ regnode *prog) s = STRING(scan); ln = STR_LEN(scan); - if (do_utf8) { + if (do_utf8 || UTF) { + /* Either target or the pattern are utf8. */ char *l = locinput; - char *e; - e = s + ln; - c1 = OP(scan) == EXACTF; - while (s < e) { - if (l >= PL_regeol) { - sayNO; - } - if ((UTF ? utf8n_to_uvchr((U8*)s, e - s, 0, 0) : *((U8*)s)) != - (c1 ? toLOWER_utf8((U8*)l) : toLOWER_LC_utf8((U8*)l))) - sayNO; - s += UTF ? UTF8SKIP(s) : 1; - l += UTF8SKIP(l); + char *e = PL_regeol; + + if (ibcmp_utf8(s, 0, ln, (bool)UTF, + l, &e, 0, do_utf8)) { + /* One more case for the sharp s: + * pack("U0U*", 0xDF) =~ /ss/i, + * the 0xC3 0x9F are the UTF-8 + * byte sequence for the U+00DF. */ + if (!(do_utf8 && + toLOWER(s[0]) == 's' && + ln >= 2 && + toLOWER(s[1]) == 's' && + (U8)l[0] == 0xC3 && + e - l >= 2 && + (U8)l[1] == 0x9F)) + sayNO; } - locinput = l; + locinput = e; nextchr = UCHARAT(locinput); break; } + /* Neither the target and the pattern are utf8. */ + /* Inline the first character, for speed. */ if (UCHARAT(s) != nextchr && UCHARAT(s) != ((OP(scan) == EXACTF) @@ -2197,22 +2537,36 @@ S_regmatch(pTHX_ regnode *prog) break; case ANYOF: if (do_utf8) { - if (!reginclass(scan, (U8*)locinput, do_utf8)) - sayNO; + STRLEN inclasslen = PL_regeol - locinput; + + if (!reginclass(scan, (U8*)locinput, &inclasslen, do_utf8)) + sayNO_ANYOF; if (locinput >= PL_regeol) sayNO; - locinput += PL_utf8skip[nextchr]; + locinput += inclasslen ? inclasslen : UTF8SKIP(locinput); nextchr = UCHARAT(locinput); + break; } else { if (nextchr < 0) nextchr = UCHARAT(locinput); - if (!reginclass(scan, (U8*)locinput, do_utf8)) - sayNO; + if (!REGINCLASS(scan, (U8*)locinput)) + sayNO_ANYOF; if (!nextchr && locinput >= PL_regeol) sayNO; nextchr = UCHARAT(++locinput); + break; + } + no_anyof: + /* If we might have the case of the German sharp s + * in a casefolding Unicode character class. */ + + if (ANYOF_FOLD_SHARP_S(scan, locinput, PL_regeol)) { + locinput += SHARP_S_SKIP; + nextchr = UCHARAT(locinput); } + else + sayNO; break; case ALNUML: PL_reg_flags |= RF_tainted; @@ -2271,9 +2625,9 @@ S_regmatch(pTHX_ regnode *prog) if (locinput == PL_bostr) ln = '\n'; else { - U8 *r = reghop((U8*)locinput, -1); + U8 *r = reghop3((U8*)locinput, -1, (U8*)PL_bostr); - ln = utf8n_to_uvchr(r, s - (char*)r, 0, 0); + ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, 0); } if (OP(scan) == BOUND || OP(scan) == NBOUND) { ln = isALNUM_uni(ln); @@ -2402,16 +2756,21 @@ S_regmatch(pTHX_ regnode *prog) nextchr = UCHARAT(++locinput); break; case CLUMP: - LOAD_UTF8_CHARCLASS(mark,"~"); - if (locinput >= PL_regeol || - swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8)) - sayNO; - locinput += PL_utf8skip[nextchr]; - while (locinput < PL_regeol && - swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8)) - locinput += UTF8SKIP(locinput); - if (locinput > PL_regeol) + if (locinput >= PL_regeol) sayNO; + if (do_utf8) { + LOAD_UTF8_CHARCLASS(mark,"~"); + if (swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8)) + sayNO; + locinput += PL_utf8skip[nextchr]; + while (locinput < PL_regeol && + swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8)) + locinput += UTF8SKIP(locinput); + if (locinput > PL_regeol) + sayNO; + } + else + locinput++; nextchr = UCHARAT(locinput); break; case REFFL: @@ -2422,7 +2781,7 @@ S_regmatch(pTHX_ regnode *prog) n = ARG(scan); /* which paren pair */ ln = PL_regstartp[n]; PL_reg_leftiter = PL_reg_maxiter; /* Void cache */ - if (*PL_reglastparen < n || ln == -1) + if ((I32)*PL_reglastparen < n || ln == -1) sayNO; /* Do not match unless seen CLOSEn. */ if (ln == PL_regendp[n]) break; @@ -2437,23 +2796,18 @@ S_regmatch(pTHX_ regnode *prog) * have to map both upper and title case to lower case. */ if (OP(scan) == REFF) { + STRLEN ulen1, ulen2; + U8 tmpbuf1[UTF8_MAXLEN_UCLC+1]; + U8 tmpbuf2[UTF8_MAXLEN_UCLC+1]; while (s < e) { if (l >= PL_regeol) sayNO; - if (toLOWER_utf8((U8*)s) != toLOWER_utf8((U8*)l)) - sayNO; - s += UTF8SKIP(s); - l += UTF8SKIP(l); - } - } - else { - while (s < e) { - if (l >= PL_regeol) - sayNO; - if (toLOWER_LC_utf8((U8*)s) != toLOWER_LC_utf8((U8*)l)) + toLOWER_utf8((U8*)s, tmpbuf1, &ulen1); + toLOWER_utf8((U8*)l, tmpbuf2, &ulen2); + if (ulen1 != ulen2 || memNE((char *)tmpbuf1, (char *)tmpbuf2, ulen1)) sayNO; - s += UTF8SKIP(s); - l += UTF8SKIP(l); + s += ulen1; + l += ulen2; } } locinput = l; @@ -2490,22 +2844,30 @@ S_regmatch(pTHX_ regnode *prog) dSP; OP_4tree *oop = PL_op; COP *ocurcop = PL_curcop; - SV **ocurpad = PL_curpad; + PAD *old_comppad; SV *ret; + struct regexp *oreg = PL_reg_re; n = ARG(scan); PL_op = (OP_4tree*)PL_regdata->data[n]; DEBUG_r( PerlIO_printf(Perl_debug_log, " re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) ); - PL_curpad = AvARRAY((AV*)PL_regdata->data[n + 2]); + PAD_SAVE_LOCAL(old_comppad, (PAD*)PL_regdata->data[n + 2]); PL_regendp[0] = PL_reg_magic->mg_len = locinput - PL_bostr; - CALLRUNOPS(aTHX); /* Scalar context. */ - SPAGAIN; - ret = POPs; - PUTBACK; - + { + SV **before = SP; + CALLRUNOPS(aTHX); /* Scalar context. */ + SPAGAIN; + if (SP == before) + ret = &PL_sv_undef; /* protect against empty (?{}) blocks. */ + else { + ret = POPs; + PUTBACK; + } + } + PL_op = oop; - PL_curpad = ocurpad; + PAD_RESTORE_LOCAL(old_comppad); PL_curcop = ocurcop; if (logical) { if (logical == 2) { /* Postponed subexpression. */ @@ -2513,13 +2875,18 @@ S_regmatch(pTHX_ regnode *prog) MAGIC *mg = Null(MAGIC*); re_cc_state state; CHECKPOINT cp, lastcp; - - if(SvROK(ret) || SvRMAGICAL(ret)) { - SV *sv = SvROK(ret) ? SvRV(ret) : ret; - - if(SvMAGICAL(sv)) - mg = mg_find(sv, PERL_MAGIC_qr); + int toggleutf; + register SV *sv; + + if(SvROK(ret) && SvSMAGICAL(sv = SvRV(ret))) + mg = mg_find(sv, PERL_MAGIC_qr); + else if (SvSMAGICAL(ret)) { + if (SvGMAGICAL(ret)) + sv_unmagic(ret, PERL_MAGIC_qr); + else + mg = mg_find(ret, PERL_MAGIC_qr); } + if (mg) { re = (regexp *)mg->mg_obj; (void)ReREFCNT_inc(re); @@ -2533,9 +2900,11 @@ S_regmatch(pTHX_ regnode *prog) I32 onpar = PL_regnpar; Zero(&pm, 1, PMOP); + if (DO_UTF8(ret)) pm.op_pmdynflags |= PMdf_DYN_UTF8; re = CALLREGCOMP(aTHX_ t, t + len, &pm); if (!(SvFLAGS(ret) - & (SVs_TEMP | SVs_PADTMP | SVf_READONLY))) + & (SVs_TEMP | SVs_PADTMP | SVf_READONLY + | SVs_GMG))) sv_magic(ret,(SV*)ReREFCNT_inc(re), PERL_MAGIC_qr,0,0); PL_regprecomp = oprecomp; @@ -2562,8 +2931,12 @@ S_regmatch(pTHX_ regnode *prog) cache_re(re); state.ss = PL_savestack_ix; *PL_reglastparen = 0; + *PL_reglastcloseparen = 0; PL_reg_call_cc = &state; PL_reginput = locinput; + toggleutf = ((PL_reg_flags & RF_utf8) != 0) ^ + ((re->reganch & ROPT_UTF8) != 0); + if (toggleutf) PL_reg_flags ^= RF_utf8; /* XXXX This is too dramatic a measure... */ PL_reg_maxiter = 0; @@ -2578,6 +2951,7 @@ S_regmatch(pTHX_ regnode *prog) PL_regcc = state.cc; PL_reg_re = state.re; cache_re(PL_reg_re); + if (toggleutf) PL_reg_flags ^= RF_utf8; /* XXXX This is too dramatic a measure... */ PL_reg_maxiter = 0; @@ -2594,17 +2968,21 @@ S_regmatch(pTHX_ regnode *prog) PL_regcc = state.cc; PL_reg_re = state.re; cache_re(PL_reg_re); + if (toggleutf) PL_reg_flags ^= RF_utf8; /* XXXX This is too dramatic a measure... */ PL_reg_maxiter = 0; + logical = 0; sayNO; } sw = SvTRUE(ret); logical = 0; } - else + else { sv_setsv(save_scalar(PL_replgv), ret); + cache_re(oreg); + } break; } case OPEN: @@ -2617,12 +2995,13 @@ S_regmatch(pTHX_ regnode *prog) n = ARG(scan); /* which paren pair */ PL_regstartp[n] = PL_reg_start_tmp[n] - PL_bostr; PL_regendp[n] = locinput - PL_bostr; - if (n > *PL_reglastparen) + if (n > (I32)*PL_reglastparen) *PL_reglastparen = n; + *PL_reglastcloseparen = n; break; case GROUPP: n = ARG(scan); /* which paren pair */ - sw = (*PL_reglastparen >= n && PL_regendp[n] != -1); + sw = ((I32)*PL_reglastparen >= n && PL_regendp[n] != -1); break; case IFTHEN: PL_reg_leftiter = PL_reg_maxiter; /* Void cache */ @@ -2724,7 +3103,7 @@ S_regmatch(pTHX_ regnode *prog) PL_regcc = &cc; /* XXXX Probably it is better to teach regpush to support parenfloor > PL_regsize... */ - if (parenfloor > *PL_reglastparen) + if (parenfloor > (I32)*PL_reglastparen) parenfloor = *PL_reglastparen; /* Pessimization... */ cc.parenfloor = parenfloor; cc.cur = -1; @@ -2760,10 +3139,10 @@ S_regmatch(pTHX_ regnode *prog) DEBUG_r( PerlIO_printf(Perl_debug_log, - "%*s %ld out of %ld..%ld cc=%lx\n", + "%*s %ld out of %ld..%ld cc=%"UVxf"\n", REPORT_CODE_OFF+PL_regindent*2, "", (long)n, (long)cc->min, - (long)cc->max, (long)cc) + (long)cc->max, PTR2UV(cc)) ); /* If degenerate scan matches "", assume scan done. */ @@ -2808,7 +3187,7 @@ S_regmatch(pTHX_ regnode *prog) if (PL_reg_leftiter-- == 0) { I32 size = (PL_reg_maxiter + 7)/8; if (PL_reg_poscache) { - if (PL_reg_poscache_size < size) { + if ((I32)PL_reg_poscache_size < size) { Renew(PL_reg_poscache, size, char); PL_reg_poscache_size = size; } @@ -2836,7 +3215,10 @@ S_regmatch(pTHX_ regnode *prog) "%*s already tried at this position...\n", REPORT_CODE_OFF+PL_regindent*2, "") ); - sayNO_SILENT; + if (PL_reg_flags & RF_false) + sayYES; + else + sayNO_SILENT; } PL_reg_poscache[o] |= (1<= REG_INFTY && !(PL_reg_flags & RF_warned)) { PL_reg_flags |= RF_warned; - Perl_warner(aTHX_ WARN_REGEXP, "%s limit (%d) exceeded", + Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded", "Complex regular subexpression recursion", REG_INFTY - 1); } @@ -2916,7 +3298,7 @@ S_regmatch(pTHX_ regnode *prog) if (ckWARN(WARN_REGEXP) && n >= REG_INFTY && !(PL_reg_flags & RF_warned)) { PL_reg_flags |= RF_warned; - Perl_warner(aTHX_ WARN_REGEXP, "%s limit (%d) exceeded", + Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded", "Complex regular subexpression recursion", REG_INFTY - 1); } @@ -2985,7 +3367,7 @@ S_regmatch(pTHX_ regnode *prog) CHECKPOINT lastcp; /* We suppose that the next guy does not need - backtracking: in particular, it is of constant length, + backtracking: in particular, it is of constant non-zero length, and has no parenths to influence future backrefs. */ ln = ARG1(scan); /* min to match */ n = ARG2(scan); /* max to match */ @@ -2993,7 +3375,7 @@ S_regmatch(pTHX_ regnode *prog) if (paren) { if (paren > PL_regsize) PL_regsize = paren; - if (paren > *PL_reglastparen) + if (paren > (I32)*PL_reglastparen) *PL_reglastparen = paren; } scan = NEXTOPER(scan) + NODE_STEP_REGNODE; @@ -3004,34 +3386,39 @@ S_regmatch(pTHX_ regnode *prog) minmod = 0; if (ln && regrepeat_hard(scan, ln, &l) < ln) sayNO; - if (ln && l == 0 && n >= ln - /* In fact, this is tricky. If paren, then the - fact that we did/didnot match may influence - future execution. */ - && !(paren && ln == 0)) - ln = n; locinput = PL_reginput; - if (PL_regkind[(U8)OP(next)] == EXACT) { - c1 = (U8)*STRING(next); - if (OP(next) == EXACTF) - c2 = PL_fold[c1]; - else if (OP(next) == EXACTFL) - c2 = PL_fold_locale[c1]; - else - c2 = c1; + if (HAS_TEXT(next) || JUMPABLE(next)) { + regnode *text_node = next; + + if (! HAS_TEXT(text_node)) FIND_NEXT_IMPT(text_node); + + if (! HAS_TEXT(text_node)) c1 = c2 = -1000; + else { + if (PL_regkind[(U8)OP(text_node)] == REF) { + c1 = c2 = -1000; + goto assume_ok_MM; + } + else { c1 = (U8)*STRING(text_node); } + if (OP(text_node) == EXACTF || OP(text_node) == REFF) + c2 = PL_fold[c1]; + else if (OP(text_node) == EXACTFL || OP(text_node) == REFFL) + c2 = PL_fold_locale[c1]; + else + c2 = c1; + } } else c1 = c2 = -1000; + assume_ok_MM: REGCP_SET(lastcp); - /* This may be improved if l == 0. */ - while (n >= ln || (n == REG_INFTY && ln > 0 && l)) { /* ln overflow ? */ + while (n >= ln || (n == REG_INFTY && ln > 0)) { /* ln overflow ? */ /* If it could work, try it. */ if (c1 == -1000 || UCHARAT(PL_reginput) == c1 || UCHARAT(PL_reginput) == c2) { if (paren) { - if (n) { + if (ln) { PL_regstartp[paren] = HOPc(PL_reginput, -l) - PL_bostr; PL_regendp[paren] = PL_reginput - PL_bostr; @@ -3055,12 +3442,6 @@ S_regmatch(pTHX_ regnode *prog) } else { n = regrepeat_hard(scan, n, &l); - if (n != 0 && l == 0 - /* In fact, this is tricky. If paren, then the - fact that we did/didnot match may influence - future execution. */ - && !(paren && ln == 0)) - ln = n; locinput = PL_reginput; DEBUG_r( PerlIO_printf(Perl_debug_log, @@ -3069,18 +3450,31 @@ S_regmatch(pTHX_ regnode *prog) (IV) n, (IV)l) ); if (n >= ln) { - if (PL_regkind[(U8)OP(next)] == EXACT) { - c1 = (U8)*STRING(next); - if (OP(next) == EXACTF) - c2 = PL_fold[c1]; - else if (OP(next) == EXACTFL) - c2 = PL_fold_locale[c1]; - else - c2 = c1; + if (HAS_TEXT(next) || JUMPABLE(next)) { + regnode *text_node = next; + + if (! HAS_TEXT(text_node)) FIND_NEXT_IMPT(text_node); + + if (! HAS_TEXT(text_node)) c1 = c2 = -1000; + else { + if (PL_regkind[(U8)OP(text_node)] == REF) { + c1 = c2 = -1000; + goto assume_ok_REG; + } + else { c1 = (U8)*STRING(text_node); } + + if (OP(text_node) == EXACTF || OP(text_node) == REFF) + c2 = PL_fold[c1]; + else if (OP(text_node) == EXACTFL || OP(text_node) == REFFL) + c2 = PL_fold_locale[c1]; + else + c2 = c1; + } } else c1 = c2 = -1000; } + assume_ok_REG: REGCP_SET(lastcp); while (n >= ln) { /* If it could work, try it. */ @@ -3118,7 +3512,7 @@ S_regmatch(pTHX_ regnode *prog) paren = scan->flags; /* Which paren to set */ if (paren > PL_regsize) PL_regsize = paren; - if (paren > *PL_reglastparen) + if (paren > (I32)*PL_reglastparen) *PL_reglastparen = paren; ln = ARG1(scan); /* min to match */ n = ARG2(scan); /* max to match */ @@ -3146,27 +3540,61 @@ S_regmatch(pTHX_ regnode *prog) * Lookahead to avoid useless match attempts * when we know what character comes next. */ - if (PL_regkind[(U8)OP(next)] == EXACT) { - U8 *s = (U8*)STRING(next); - if (!UTF) { - c2 = c1 = *s; - if (OP(next) == EXACTF) - c2 = PL_fold[c1]; - else if (OP(next) == EXACTFL) - c2 = PL_fold_locale[c1]; - } - else { /* UTF */ - if (OP(next) == EXACTF) { - c1 = to_utf8_lower(s); - c2 = to_utf8_upper(s); + + /* + * Used to only do .*x and .*?x, but now it allows + * for )'s, ('s and (?{ ... })'s to be in the way + * of the quantifier and the EXACT-like node. -- japhy + */ + + if (HAS_TEXT(next) || JUMPABLE(next)) { + U8 *s; + regnode *text_node = next; + + if (! HAS_TEXT(text_node)) FIND_NEXT_IMPT(text_node); + + if (! HAS_TEXT(text_node)) c1 = c2 = -1000; + else { + if (PL_regkind[(U8)OP(text_node)] == REF) { + c1 = c2 = -1000; + goto assume_ok_easy; } - else { - c2 = c1 = utf8_to_uvchr(s, NULL); + else { s = (U8*)STRING(text_node); } + + if (!UTF) { + c2 = c1 = *s; + if (OP(text_node) == EXACTF || OP(text_node) == REFF) + c2 = PL_fold[c1]; + else if (OP(text_node) == EXACTFL || OP(text_node) == REFFL) + c2 = PL_fold_locale[c1]; + } + else { /* UTF */ + if (OP(text_node) == EXACTF || OP(text_node) == REFF) { + STRLEN ulen1, ulen2; + U8 tmpbuf1[UTF8_MAXLEN_UCLC+1]; + U8 tmpbuf2[UTF8_MAXLEN_UCLC+1]; + + to_utf8_lower((U8*)s, tmpbuf1, &ulen1); + to_utf8_upper((U8*)s, tmpbuf2, &ulen2); + + c1 = utf8n_to_uvuni(tmpbuf1, UTF8_MAXLEN, 0, + ckWARN(WARN_UTF8) ? + 0 : UTF8_ALLOW_ANY); + c2 = utf8n_to_uvuni(tmpbuf2, UTF8_MAXLEN, 0, + ckWARN(WARN_UTF8) ? + 0 : UTF8_ALLOW_ANY); + } + else { + c2 = c1 = utf8n_to_uvchr(s, UTF8_MAXLEN, 0, + ckWARN(WARN_UTF8) ? + 0 : UTF8_ALLOW_ANY); + } } } } else c1 = c2 = -1000; + assume_ok_easy: PL_reginput = locinput; if (minmod) { CHECKPOINT lastcp; @@ -3178,6 +3606,7 @@ S_regmatch(pTHX_ regnode *prog) if (c1 != -1000) { char *e; /* Should not check after this */ char *old = locinput; + int count = 0; if (n == REG_INFTY) { e = PL_regeol - 1; @@ -3197,16 +3626,16 @@ S_regmatch(pTHX_ regnode *prog) e = PL_regeol - 1; } while (1) { - int count; /* Find place 'next' could work */ if (!do_utf8) { if (c1 == c2) { - while (locinput <= e && *locinput != c1) + while (locinput <= e && + UCHARAT(locinput) != c1) locinput++; } else { while (locinput <= e - && *locinput != c1 - && *locinput != c2) + && UCHARAT(locinput) != c1 + && UCHARAT(locinput) != c2) locinput++; } count = locinput - old; @@ -3214,18 +3643,28 @@ S_regmatch(pTHX_ regnode *prog) else { STRLEN len; if (c1 == c2) { - for (count = 0; - locinput <= e && - utf8_to_uvchr((U8*)locinput, &len) != c1; - count++) + /* count initialised to + * utf8_distance(old, locinput) */ + while (locinput <= e && + utf8n_to_uvchr((U8*)locinput, + UTF8_MAXLEN, &len, + ckWARN(WARN_UTF8) ? + 0 : UTF8_ALLOW_ANY) != (UV)c1) { locinput += len; - + count++; + } } else { - for (count = 0; locinput <= e; count++) { - UV c = utf8_to_uvchr((U8*)locinput, &len); - if (c == c1 || c == c2) + /* count initialised to + * utf8_distance(old, locinput) */ + while (locinput <= e) { + UV c = utf8n_to_uvchr((U8*)locinput, + UTF8_MAXLEN, &len, + ckWARN(WARN_UTF8) ? + 0 : UTF8_ALLOW_ANY); + if (c == (UV)c1 || c == (UV)c2) break; - locinput += len; + locinput += len; + count++; } } } @@ -3247,6 +3686,7 @@ S_regmatch(pTHX_ regnode *prog) locinput += UTF8SKIP(locinput); else locinput++; + count = 1; } } else @@ -3254,20 +3694,23 @@ S_regmatch(pTHX_ regnode *prog) UV c; if (c1 != -1000) { if (do_utf8) - c = utf8_to_uvchr((U8*)PL_reginput, NULL); + c = utf8n_to_uvchr((U8*)PL_reginput, + UTF8_MAXLEN, 0, + ckWARN(WARN_UTF8) ? + 0 : UTF8_ALLOW_ANY); else c = UCHARAT(PL_reginput); /* If it could work, try it. */ - if (c == c1 || c == c2) + if (c == (UV)c1 || c == (UV)c2) { - TRYPAREN(paren, n, PL_reginput); + TRYPAREN(paren, ln, PL_reginput); REGCP_UNWIND(lastcp); } } /* If it could work, try it. */ else if (c1 == -1000) { - TRYPAREN(paren, n, PL_reginput); + TRYPAREN(paren, ln, PL_reginput); REGCP_UNWIND(lastcp); } /* Couldn't or didn't -- move forward. */ @@ -3285,7 +3728,9 @@ S_regmatch(pTHX_ regnode *prog) n = regrepeat(scan, n); locinput = PL_reginput; if (ln < n && PL_regkind[(U8)OP(next)] == EOL && - (!PL_multiline || OP(next) == SEOL || OP(next) == EOS)) { + ((!PL_multiline && OP(next) != MEOL) || + OP(next) == SEOL || OP(next) == EOS)) + { ln = n; /* why back off? */ /* ...because $ and \Z can match before *and* after newline at the end. Consider "\n\n" =~ /\n+\Z\n/. @@ -3299,12 +3744,15 @@ S_regmatch(pTHX_ regnode *prog) while (n >= ln) { if (c1 != -1000) { if (do_utf8) - c = utf8_to_uvchr((U8*)PL_reginput, NULL); + c = utf8n_to_uvchr((U8*)PL_reginput, + UTF8_MAXLEN, 0, + ckWARN(WARN_UTF8) ? + 0 : UTF8_ALLOW_ANY); else c = UCHARAT(PL_reginput); } /* If it could work, try it. */ - if (c1 == -1000 || c == c1 || c == c2) + if (c1 == -1000 || c == (UV)c1 || c == (UV)c2) { TRYPAREN(paren, n, PL_reginput); REGCP_UNWIND(lastcp); @@ -3319,12 +3767,15 @@ S_regmatch(pTHX_ regnode *prog) while (n >= ln) { if (c1 != -1000) { if (do_utf8) - c = utf8_to_uvchr((U8*)PL_reginput, NULL); + c = utf8n_to_uvchr((U8*)PL_reginput, + UTF8_MAXLEN, 0, + ckWARN(WARN_UTF8) ? + 0 : UTF8_ALLOW_ANY); else c = UCHARAT(PL_reginput); } /* If it could work, try it. */ - if (c1 == -1000 || c == c1 || c == c2) + if (c1 == -1000 || c == (UV)c1 || c == (UV)c2) { TRYPAREN(paren, n, PL_reginput); REGCP_UNWIND(lastcp); @@ -3400,6 +3851,7 @@ S_regmatch(pTHX_ regnode *prog) } else PL_reginput = locinput; + PL_reg_flags ^= RF_false; goto do_ifmatch; case IFMATCH: n = 1; @@ -3415,6 +3867,8 @@ S_regmatch(pTHX_ regnode *prog) do_ifmatch: inner = NEXTOPER(NEXTOPER(scan)); if (regmatch(inner) != n) { + if (n == 0) + PL_reg_flags ^= RF_false; say_no: if (logical) { logical = 0; @@ -3424,6 +3878,8 @@ S_regmatch(pTHX_ regnode *prog) else sayNO; } + if (n == 0) + PL_reg_flags ^= RF_false; say_yes: if (logical) { logical = 0; @@ -3557,10 +4013,12 @@ S_regrepeat(pTHX_ regnode *p, I32 max) register I32 c; register char *loceol = PL_regeol; register I32 hardcount = 0; - register bool do_utf8 = DO_UTF8(PL_reg_sv); + register bool do_utf8 = PL_reg_match_utf8; scan = PL_reginput; - if (max != REG_INFTY && max < loceol - scan) + if (max == REG_INFTY) + max = I32_MAX; + else if (max < loceol - scan) loceol = scan + max; switch (OP(p)) { case REG_ANY: @@ -3576,6 +4034,17 @@ S_regrepeat(pTHX_ regnode *p, I32 max) } break; case SANY: + if (do_utf8) { + loceol = PL_regeol; + while (scan < loceol && hardcount < max) { + scan += UTF8SKIP(scan); + hardcount++; + } + } + else + scan = loceol; + break; + case CANY: scan = loceol; break; case EXACT: /* length of string is 1 */ @@ -3600,12 +4069,12 @@ S_regrepeat(pTHX_ regnode *p, I32 max) if (do_utf8) { loceol = PL_regeol; while (hardcount < max && scan < loceol && - reginclass(p, (U8*)scan, do_utf8)) { + reginclass(p, (U8*)scan, 0, do_utf8)) { scan += UTF8SKIP(scan); hardcount++; } } else { - while (scan < loceol && reginclass(p, (U8*)scan, do_utf8)) + while (scan < loceol && REGINCLASS(p, (U8*)scan)) scan++; } break; @@ -3777,7 +4246,7 @@ S_regrepeat(pTHX_ regnode *p, I32 max) /* - regrepeat_hard - repeatedly match something, report total lenth and length * - * The repeater is supposed to have constant length. + * The repeater is supposed to have constant non-zero length. */ STATIC I32 @@ -3793,7 +4262,7 @@ S_regrepeat_hard(pTHX_ regnode *p, I32 max, I32 *lp) return 0; start = PL_reginput; - if (DO_UTF8(PL_reg_sv)) { + if (PL_reg_match_utf8) { while (PL_reginput < loceol && (scan = PL_reginput, res = regmatch(p))) { if (!count++) { l = 0; @@ -3831,10 +4300,11 @@ S_regrepeat_hard(pTHX_ regnode *p, I32 max, I32 *lp) */ SV * -Perl_regclass_swash(pTHX_ register regnode* node, bool doinit, SV** initsvp) +Perl_regclass_swash(pTHX_ register regnode* node, bool doinit, SV** listsvp, SV **altsvp) { - SV *sw = NULL; - SV *si = NULL; + SV *sw = NULL; + SV *si = NULL; + SV *alt = NULL; if (PL_regdata && PL_regdata->count) { U32 n = ARG(node); @@ -3842,41 +4312,62 @@ Perl_regclass_swash(pTHX_ register regnode* node, bool doinit, SV** initsvp) if (PL_regdata->what[n] == 's') { SV *rv = (SV*)PL_regdata->data[n]; AV *av = (AV*)SvRV((SV*)rv); - SV **a; - - si = *av_fetch(av, 0, FALSE); - a = av_fetch(av, 1, FALSE); + SV **ary = AvARRAY(av); + SV **a, **b; + /* See the end of regcomp.c:S_reglass() for + * documentation of these array elements. */ + + si = *ary; + a = SvTYPE(ary[1]) == SVt_RV ? &ary[1] : 0; + b = SvTYPE(ary[2]) == SVt_PVAV ? &ary[2] : 0; + if (a) sw = *a; else if (si && doinit) { sw = swash_init("utf8", "", si, 1, 0); (void)av_store(av, 1, sw); } + if (b) + alt = *b; } } - if (initsvp) - *initsvp = si; + if (listsvp) + *listsvp = si; + if (altsvp) + *altsvp = alt; return sw; } /* - reginclass - determine if a character falls into a character class + + The n is the ANYOF regnode, the p is the target string, lenp + is pointer to the maximum length of how far to go in the p + (if the lenp is zero, UTF8SKIP(p) is used), + do_utf8 tells whether the target string is in UTF-8. + */ STATIC bool -S_reginclass(pTHX_ register regnode *n, register U8* p, register bool do_utf8) +S_reginclass(pTHX_ register regnode *n, register U8* p, STRLEN* lenp, register bool do_utf8) { char flags = ANYOF_FLAGS(n); bool match = FALSE; - UV c; + UV c = *p; STRLEN len = 0; + STRLEN plen; - c = do_utf8 ? utf8_to_uvchr(p, &len) : *p; + if (do_utf8 && !UTF8_IS_INVARIANT(c)) + c = utf8n_to_uvchr(p, UTF8_MAXLEN, &len, + ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY); + plen = lenp ? *lenp : UNISKIP(NATIVE_TO_UNI(c)); if (do_utf8 || (flags & ANYOF_UNICODE)) { + if (lenp) + *lenp = 0; if (do_utf8 && !ANYOF_RUNTIME(n)) { if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c)) match = TRUE; @@ -3884,31 +4375,47 @@ S_reginclass(pTHX_ register regnode *n, register U8* p, register bool do_utf8) if (!match && do_utf8 && (flags & ANYOF_UNICODE_ALL) && c >= 256) match = TRUE; if (!match) { - SV *sw = regclass_swash(n, TRUE, 0); + AV *av; + SV *sw = regclass_swash(n, TRUE, 0, (SV**)&av); if (sw) { if (swash_fetch(sw, p, do_utf8)) match = TRUE; else if (flags & ANYOF_FOLD) { - U8 tmpbuf[UTF8_MAXLEN+1]; - - if (flags & ANYOF_LOCALE) { - PL_reg_flags |= RF_tainted; - uvchr_to_utf8(tmpbuf, toLOWER_LC_utf8(p)); + if (!match && lenp && av) { + I32 i; + + for (i = 0; i <= av_len(av); i++) { + SV* sv = *av_fetch(av, i, FALSE); + STRLEN len; + char *s = SvPV(sv, len); + + if (len <= plen && memEQ(s, (char*)p, len)) { + *lenp = len; + match = TRUE; + break; + } + } + } + if (!match) { + U8 tmpbuf[UTF8_MAXLEN_FOLD+1]; + STRLEN tmplen; + + to_utf8_fold(p, tmpbuf, &tmplen); + if (swash_fetch(sw, tmpbuf, do_utf8)) + match = TRUE; } - else - uvchr_to_utf8(tmpbuf, toLOWER_utf8(p)); - if (swash_fetch(sw, tmpbuf, do_utf8)) - match = TRUE; } } } + if (match && lenp && *lenp == 0) + *lenp = UNISKIP(NATIVE_TO_UNI(c)); } if (!match && c < 256) { if (ANYOF_BITMAP_TEST(n, c)) match = TRUE; else if (flags & ANYOF_FOLD) { - I32 f; + U8 f; if (flags & ANYOF_LOCALE) { PL_reg_flags |= RF_tainted; @@ -4029,17 +4536,16 @@ S_reghopmaybe3(pTHX_ U8* s, I32 off, U8* lim) return s; } -#ifdef PERL_OBJECT -#include "XSUB.h" -#endif - static void -restore_pos(pTHXo_ void *arg) +restore_pos(pTHX_ void *arg) { if (PL_reg_eval_set) { if (PL_reg_oldsaved) { PL_reg_re->subbeg = PL_reg_oldsaved; PL_reg_re->sublen = PL_reg_oldsavedlen; +#ifdef PERL_COPY_ON_WRITE + PL_reg_re->saved_copy = PL_nrs; +#endif RX_MATCH_COPIED_on(PL_reg_re); } PL_reg_magic->mg_len = PL_reg_oldpos; @@ -4047,3 +4553,59 @@ restore_pos(pTHXo_ void *arg) PL_curpm = PL_reg_oldcurpm; } } + +STATIC void +S_to_utf8_substr(pTHX_ register regexp *prog) +{ + SV* sv; + if (prog->float_substr && !prog->float_utf8) { + prog->float_utf8 = sv = NEWSV(117, 0); + SvSetSV(sv, prog->float_substr); + sv_utf8_upgrade(sv); + if (SvTAIL(prog->float_substr)) + SvTAIL_on(sv); + if (prog->float_substr == prog->check_substr) + prog->check_utf8 = sv; + } + if (prog->anchored_substr && !prog->anchored_utf8) { + prog->anchored_utf8 = sv = NEWSV(118, 0); + SvSetSV(sv, prog->anchored_substr); + sv_utf8_upgrade(sv); + if (SvTAIL(prog->anchored_substr)) + SvTAIL_on(sv); + if (prog->anchored_substr == prog->check_substr) + prog->check_utf8 = sv; + } +} + +STATIC void +S_to_byte_substr(pTHX_ register regexp *prog) +{ + SV* sv; + if (prog->float_utf8 && !prog->float_substr) { + prog->float_substr = sv = NEWSV(117, 0); + SvSetSV(sv, prog->float_utf8); + if (sv_utf8_downgrade(sv, TRUE)) { + if (SvTAIL(prog->float_utf8)) + SvTAIL_on(sv); + } else { + SvREFCNT_dec(sv); + prog->float_substr = sv = &PL_sv_undef; + } + if (prog->float_utf8 == prog->check_utf8) + prog->check_substr = sv; + } + if (prog->anchored_utf8 && !prog->anchored_substr) { + prog->anchored_substr = sv = NEWSV(118, 0); + SvSetSV(sv, prog->anchored_utf8); + if (sv_utf8_downgrade(sv, TRUE)) { + if (SvTAIL(prog->anchored_utf8)) + SvTAIL_on(sv); + } else { + SvREFCNT_dec(sv); + prog->anchored_substr = sv = &PL_sv_undef; + } + if (prog->anchored_utf8 == prog->check_utf8) + prog->check_substr = sv; + } +}