X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=regexec.c;h=5a6d72db8cecc59b6f839881a5159e5853319763;hb=696235b60874be65fe029a39969f44a0133ec2f8;hp=cf33abb51ddd6e79b2a79129541df46b83482e00;hpb=60a8b682cede796bc3c248d2778db979d6f9b9ff;p=p5sagit%2Fp5-mst-13.2.git diff --git a/regexec.c b/regexec.c index cf33abb..5a6d72d 100644 --- a/regexec.c +++ b/regexec.c @@ -67,7 +67,7 @@ * **** Alterations to Henry's code are... **** - **** Copyright (c) 1991-2001, Larry Wall + **** Copyright (c) 1991-2002, Larry Wall **** **** You may distribute under the terms of either the GNU General Public **** License or the Artistic License, as specified in the README file. @@ -96,11 +96,13 @@ #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_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)) @@ -111,7 +113,7 @@ #define HOPMAYBEc(pos,off) ((char*)HOPMAYBE(pos,off)) #define HOPBACK(pos, off) ( \ - (UTF && PL_reg_match_utf8) \ + (PL_reg_match_utf8) \ ? reghopmaybe((U8*)pos, -off) \ : (pos - off >= PL_bostr) \ ? (U8*)(pos - off) \ @@ -126,7 +128,7 @@ #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) ( \ @@ -140,13 +142,18 @@ PL_regkind[(U8)OP(rn)] == EXACT || PL_regkind[(U8)OP(rn)] == REF \ ) +/* + 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 || OP(rn) == IFMATCH || \ - PL_regkind[(U8)OP(rn)] == CURLY) \ + 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 @@ -385,6 +392,7 @@ 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 */ @@ -401,7 +409,8 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, DEBUG_r({ char *s = PL_reg_match_utf8 ? - sv_uni_display(dsv, sv, 60, 0) : strpos; + sv_uni_display(dsv, sv, 60, UNI_DISPLAY_REGEX) : + strpos; int len = PL_reg_match_utf8 ? strlen(s) : strend - strpos; if (!PL_colorset) @@ -429,7 +438,20 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, } 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) @@ -535,7 +557,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), @@ -558,16 +580,17 @@ 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 */ @@ -585,20 +608,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, @@ -625,54 +655,60 @@ 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; + } } } @@ -695,7 +731,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 @@ -735,7 +771,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, @@ -759,15 +795,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 @@ -794,9 +838,9 @@ 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); @@ -822,8 +866,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); @@ -863,7 +907,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: @@ -890,8 +934,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])); @@ -915,15 +959,24 @@ S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *sta switch (OP(c)) { case ANYOF: while (s < strend) { - if (reginclass(c, (U8*)s, do_utf8)) { + STRLEN skip = do_utf8 ? UTF8SKIP(s) : 1; + + if (do_utf8 ? + reginclass(c, (U8*)s, 0, do_utf8) : + REGINCLASS(c, (U8*)s) || + (ANYOF_FOLD_SHARP_S(c, s, strend) && + /* The assignment of 2 is intentional: + * for the sharp s, the skip is 2. */ + (skip = SHARP_S_SKIP) + )) { if (tmp && (norun || regtry(prog, s))) goto got_it; else tmp = doevery; } - else + else tmp = 1; - s += do_utf8 ? UTF8SKIP(s) : 1; + s += skip; } break; case CANY: @@ -946,8 +999,8 @@ S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *sta to_utf8_lower((U8*)m, tmpbuf1, &ulen1); to_utf8_upper((U8*)m, tmpbuf2, &ulen2); - c1 = utf8_to_uvuni(tmpbuf1, 0); - c2 = utf8_to_uvuni(tmpbuf2, 0); + c1 = utf8_to_uvchr(tmpbuf1, 0); + c2 = utf8_to_uvchr(tmpbuf2, 0); } else { c1 = *(U8*)m; @@ -960,7 +1013,7 @@ S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *sta c1 = *(U8*)m; c2 = PL_fold_locale[c1]; do_exactf: - e = strend - ln; + e = do_utf8 ? s + ln : strend - ln; if (norun && e < s) e = s; /* Due to minlen logic of intuit() */ @@ -971,44 +1024,36 @@ S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *sta * 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 is really supposed - * to use the so-called folding case for case-insensitive - * matching (called "loose matching" in Unicode). */ + * 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) { UV c, f; U8 tmpbuf [UTF8_MAXLEN+1]; U8 foldbuf[UTF8_MAXLEN_FOLD+1]; STRLEN len, foldlen; - - /* The ibcmp_utf8() uses to_uni_fold() which is more - * correct folding for Unicode than using lowercase. - * However, it doesn't work quite fully since the folding - * is a one-to-many mapping and the regex optimizer is - * unaware of this, so it may throw out good matches. - * Fortunately, not getting this right is allowed - * for Unicode Regular Expression Support level 1, - * only one-to-one matching is required. --jhi */ - + if (c1 == c2) { while (s <= e) { c = utf8_to_uvchr((U8*)s, &len); if ( c == c1 && (ln == len || - !ibcmp_utf8(s, do_utf8, strend - s, - m, UTF, ln)) + ibcmp_utf8(s, (char **)0, 0, do_utf8, + m, (char **)0, ln, UTF)) && (norun || regtry(prog, s)) ) goto got_it; else { uvchr_to_utf8(tmpbuf, c); - to_utf8_fold(tmpbuf, foldbuf, &foldlen); - f = utf8_to_uvchr(foldbuf, 0); + f = to_utf8_fold(tmpbuf, foldbuf, &foldlen); if ( f != c && (f == c1 || f == c2) && (ln == foldlen || - !ibcmp_utf8((char *)foldbuf, - do_utf8, foldlen, - m, UTF, ln)) + !ibcmp_utf8((char *) foldbuf, + (char **)0, foldlen, do_utf8, + m, + (char **)0, ln, UTF)) && (norun || regtry(prog, s)) ) goto got_it; } @@ -1020,32 +1065,32 @@ S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *sta c = utf8_to_uvchr((U8*)s, &len); /* Handle some of the three Greek sigmas cases. - * Note that not all the possible combinations - * are handled here: some of them are handled - * 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(). */ + * 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, do_utf8, strend - s, - m, UTF, ln)) + ibcmp_utf8(s, (char **)0, 0, do_utf8, + m, (char **)0, ln, UTF)) && (norun || regtry(prog, s)) ) goto got_it; else { uvchr_to_utf8(tmpbuf, c); - to_utf8_fold(tmpbuf, foldbuf, &foldlen); - f = utf8_to_uvchr(foldbuf, 0); + f = to_utf8_fold(tmpbuf, foldbuf, &foldlen); if ( f != c && (f == c1 || f == c2) && (ln == foldlen || - !ibcmp_utf8((char *)foldbuf, - do_utf8, foldlen, - m, UTF, ln)) + !ibcmp_utf8((char *) foldbuf, + (char **)0, foldlen, do_utf8, + m, + (char **)0, ln, UTF)) && (norun || regtry(prog, s)) ) goto got_it; } @@ -1544,7 +1589,8 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * SV* oreplsv = GvSV(PL_replgv); bool do_utf8 = DO_UTF8(sv); #ifdef DEBUGGING - SV *dsv = PERL_DEBUG_PAD_ZERO(0); + SV *dsv0 = PERL_DEBUG_PAD_ZERO(0); + SV *dsv1 = PERL_DEBUG_PAD_ZERO(1); #endif PL_regcc = 0; @@ -1616,8 +1662,7 @@ 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; @@ -1630,20 +1675,26 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * } DEBUG_r({ - char *s = do_utf8 ? sv_uni_display(dsv, sv, 60, 0) : startpos; - int len = do_utf8 ? strlen(s) : strend - startpos; + 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%.60s%s%s' against `%s%.*s%s%s'\n", + "%sMatching REx%s `%s%*.*s%s%s' against `%s%.*s%s%s'\n", PL_colors[4],PL_colors[5],PL_colors[0], - prog->precomp, + len0, len0, s0, PL_colors[1], - (strlen(prog->precomp) > 60 ? "..." : ""), + len0 > 60 ? "..." : "", PL_colors[0], - (int)(len > 60 ? 60 : len), - s, PL_colors[1], - (len > 60 ? "..." : "") + (int)(len1 > 60 ? 60 : len1), + s1, PL_colors[1], + (len1 > 60 ? "..." : "") ); }); @@ -1661,7 +1712,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) { @@ -1697,13 +1748,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) { @@ -1735,23 +1789,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); @@ -1799,7 +1867,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)), @@ -1814,8 +1882,24 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * 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), UTF ? sv_uni_display(dsv, sv, 60, 0) : 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; @@ -1823,20 +1907,26 @@ 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. */ } 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) @@ -2022,12 +2112,6 @@ S_regtry(pTHX_ regexp *prog, char *startpos) New(22,PL_reg_start_tmp, PL_reg_start_tmpl, char*); } -#ifdef DEBUGGING - sv_setpvn(PERL_DEBUG_PAD(0), "", 0); - sv_setpvn(PERL_DEBUG_PAD(1), "", 0); - sv_setpvn(PERL_DEBUG_PAD(2), "", 0); -#endif - /* XXXX What this code is doing here?!!! There should be no need to do this again and again, PL_reglastparen should take care of this! --ilya*/ @@ -2093,6 +2177,7 @@ typedef union 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 @@ -2181,17 +2266,17 @@ S_regmatch(pTHX_ regnode *prog) char *s0 = do_utf8 ? pv_uni_display(dsv0, (U8*)(locinput - pref_len), - pref0_len, 60, 0) : + pref0_len, 60, UNI_DISPLAY_REGEX) : locinput - pref_len; int len0 = do_utf8 ? strlen(s0) : pref0_len; char *s1 = do_utf8 ? pv_uni_display(dsv1, (U8*)(locinput - pref_len + pref0_len), - pref_len - pref0_len, 60, 0) : + 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 ? pv_uni_display(dsv2, (U8*)locinput, - PL_regeol - locinput, 60, 0) : + PL_regeol - locinput, 60, UNI_DISPLAY_REGEX) : locinput; int len2 = do_utf8 ? strlen(s2) : l; PerlIO_printf(Perl_debug_log, @@ -2307,7 +2392,7 @@ S_regmatch(pTHX_ regnode *prog) if (l >= PL_regeol) sayNO; if (NATIVE_TO_UNI(*(U8*)s) != - utf8_to_uvchr((U8*)l, &ulen)) + utf8_to_uvuni((U8*)l, &ulen)) sayNO; l += ulen; s ++; @@ -2319,7 +2404,7 @@ S_regmatch(pTHX_ regnode *prog) if (l >= PL_regeol) sayNO; if (NATIVE_TO_UNI(*((U8*)l)) != - utf8_to_uvchr((U8*)s, &ulen)) + utf8_to_uvuni((U8*)s, &ulen)) sayNO; s += ulen; l ++; @@ -2347,96 +2432,29 @@ S_regmatch(pTHX_ regnode *prog) s = STRING(scan); ln = STR_LEN(scan); - { + if (do_utf8 || UTF) { + /* Either target or the pattern are utf8. */ char *l = locinput; - char *e = s + ln; - U8 tmpbuf[UTF8_MAXLEN_FOLD+1]; - - if (do_utf8 != (UTF!=0)) { - /* The target and the pattern have differing utf8ness. */ - STRLEN ulen1, ulen2; - UV cs, cl; - - if (do_utf8) { - /* The target is utf8, the pattern is not utf8. */ - while (s < e) { - if (l >= PL_regeol) - sayNO; - - cs = to_uni_fold(NATIVE_TO_UNI(*(U8*)s), - (U8*)s, &ulen1); - cl = utf8_to_uvchr((U8*)l, &ulen2); - - if (cs != cl) { - cl = to_uni_fold(cl, (U8*)l, &ulen2); - if (ulen1 != ulen2 || cs != cl) - sayNO; - } - l += ulen1; - s ++; - } - } - else { - /* The target is not utf8, the pattern is utf8. */ - while (s < e) { - if (l >= PL_regeol) - sayNO; - - cs = utf8_to_uvchr((U8*)s, &ulen1); - - cl = to_uni_fold(NATIVE_TO_UNI(*(U8*)l), - (U8*)l, &ulen2); - - if (cs != cl) { - cs = to_uni_fold(cs, (U8*)s, &ulen1); - if (ulen1 != ulen2 || cs != cl) - sayNO; - } - l ++; - s += ulen1; - } - } - locinput = l; - nextchr = UCHARAT(locinput); - break; - } - - if (do_utf8 && UTF) { - /* Both the target and the pattern are utf8. */ - STRLEN ulen; - - while (s < e) { - if (l >= PL_regeol) - sayNO; - if (UTF8SKIP(s) != UTF8SKIP(l) || - memNE(s, (char*)l, UTF8SKIP(s))) { - U8 lfoldbuf[UTF8_MAXLEN_FOLD+1]; - STRLEN lfoldlen; - - /* Try one of them folded. */ - - to_utf8_fold((U8*)l, lfoldbuf, &lfoldlen); - if (UTF8SKIP(s) != lfoldlen || - memNE(s, (char*)lfoldbuf, lfoldlen)) { - U8 sfoldbuf[UTF8_MAXLEN_FOLD+1]; - STRLEN sfoldlen; - - /* Try both of them folded. */ - - to_utf8_fold((U8*)s, sfoldbuf, &sfoldlen); - if (sfoldlen != lfoldlen || - memNE((char*)sfoldbuf, - (char*)lfoldbuf, lfoldlen)) - sayNO; - } - } - l += UTF8SKIP(l); - s += UTF8SKIP(s); - } - locinput = l; - nextchr = UCHARAT(locinput); - break; + char *e = PL_regeol; + + if (ibcmp_utf8(s, 0, ln, 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 = e; + nextchr = UCHARAT(locinput); + break; } /* Neither the target and the pattern are utf8. */ @@ -2457,22 +2475,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; @@ -3134,7 +3166,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); } @@ -3186,7 +3218,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); } @@ -3646,7 +3678,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/. @@ -3937,7 +3971,15 @@ S_regrepeat(pTHX_ regnode *p, I32 max) } break; case SANY: - scan = loceol; + if (do_utf8) { + loceol = PL_regeol; + while (scan < loceol && hardcount < max) { + scan += UTF8SKIP(scan); + hardcount++; + } + } + else + scan = loceol; break; case CANY: scan = loceol; @@ -3964,12 +4006,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; @@ -4195,10 +4237,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); @@ -4206,10 +4249,14 @@ 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; + SV **a, **b; - si = *av_fetch(av, 0, FALSE); - a = av_fetch(av, 1, FALSE); + /* See the end of regcomp.c:S_reglass() for + * documentation of these array elements. */ + + si = *av_fetch(av, 0, FALSE); + a = av_fetch(av, 1, FALSE); + b = av_fetch(av, 2, FALSE); if (a) sw = *a; @@ -4217,30 +4264,44 @@ Perl_regclass_swash(pTHX_ register regnode* node, bool doinit, SV** initsvp) 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; STRLEN len = 0; + STRLEN plen; c = do_utf8 ? utf8_to_uvchr(p, &len) : *p; + 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; @@ -4248,24 +4309,41 @@ 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) { - STRLEN ulen; - U8 tmpbuf[UTF8_MAXLEN_FOLD+1]; - - to_utf8_fold(p, tmpbuf, &ulen); - if (swash_fetch(sw, tmpbuf, do_utf8)) - match = TRUE; - to_utf8_upper(p, tmpbuf, &ulen); - if (swash_fetch(sw, tmpbuf, do_utf8)) - match = TRUE; + 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; + } } } } + if (match && lenp && *lenp == 0) + *lenp = UNISKIP(NATIVE_TO_UNI(c)); } if (!match && c < 256) { if (ANYOF_BITMAP_TEST(n, c)) @@ -4406,3 +4484,59 @@ restore_pos(pTHX_ 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); + SvSetMagicSV(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); + SvSetMagicSV(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); + SvSetMagicSV(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); + SvSetMagicSV(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; + } +}