X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=regexec.c;h=5a6d72db8cecc59b6f839881a5159e5853319763;hb=696235b60874be65fe029a39969f44a0133ec2f8;hp=900b49150238240caabccdf219f0446ac005ba85;hpb=8e0fc1cdff8c4d07f11a5b0bd5056e1acbe2a68a;p=p5sagit%2Fp5-mst-13.2.git diff --git a/regexec.c b/regexec.c index 900b491..5a6d72d 100644 --- a/regexec.c +++ b/regexec.c @@ -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)) @@ -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) ( \ @@ -390,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 */ @@ -435,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) @@ -541,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), @@ -564,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 */ @@ -591,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, @@ -631,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; + } } } @@ -701,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 @@ -741,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, @@ -765,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 @@ -800,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); @@ -828,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); @@ -869,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: @@ -896,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])); @@ -921,9 +959,11 @@ S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *sta switch (OP(c)) { case ANYOF: while (s < strend) { - STRLEN skip = do_utf8 ? UTF8SKIP(s) : 1; - - 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. */ @@ -935,7 +975,7 @@ S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *sta tmp = doevery; } else - tmp = 1; + tmp = 1; s += skip; } break; @@ -959,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; @@ -984,9 +1024,10 @@ 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; @@ -1621,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; @@ -1672,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) { @@ -1708,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) { @@ -1746,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); @@ -1810,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)), @@ -1850,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) @@ -2049,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*/ @@ -2420,18 +2477,18 @@ S_regmatch(pTHX_ regnode *prog) if (do_utf8) { STRLEN inclasslen = PL_regeol - locinput; - if (!reginclasslen(scan, (U8*)locinput, &inclasslen, do_utf8)) + if (!reginclass(scan, (U8*)locinput, &inclasslen, do_utf8)) sayNO_ANYOF; if (locinput >= PL_regeol) sayNO; - locinput += inclasslen; + locinput += inclasslen ? inclasslen : UTF8SKIP(locinput); nextchr = UCHARAT(locinput); break; } else { if (nextchr < 0) nextchr = UCHARAT(locinput); - if (!reginclass(scan, (U8*)locinput, do_utf8)) + if (!REGINCLASS(scan, (U8*)locinput)) sayNO_ANYOF; if (!nextchr && locinput >= PL_regeol) sayNO; @@ -3109,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); } @@ -3161,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); } @@ -3949,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; @@ -4221,7 +4278,7 @@ Perl_regclass_swash(pTHX_ register regnode* node, bool doinit, SV** listsvp, SV } /* - - reginclasslen - determine if a character falls into a character class + - 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 @@ -4231,7 +4288,7 @@ Perl_regclass_swash(pTHX_ register regnode* node, bool doinit, SV** listsvp, SV */ STATIC bool -S_reginclasslen(pTHX_ register regnode *n, register U8* p, STRLEN* lenp, 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; @@ -4241,7 +4298,7 @@ S_reginclasslen(pTHX_ register regnode *n, register U8* p, STRLEN* lenp, registe c = do_utf8 ? utf8_to_uvchr(p, &len) : *p; - plen = lenp ? *lenp : UNISKIP(c); + plen = lenp ? *lenp : UNISKIP(NATIVE_TO_UNI(c)); if (do_utf8 || (flags & ANYOF_UNICODE)) { if (lenp) *lenp = 0; @@ -4259,9 +4316,6 @@ S_reginclasslen(pTHX_ register regnode *n, register U8* p, STRLEN* lenp, registe if (swash_fetch(sw, p, do_utf8)) match = TRUE; else if (flags & ANYOF_FOLD) { - U8 tmpbuf[UTF8_MAXLEN_FOLD+1]; - STRLEN tmplen; - if (!match && lenp && av) { I32 i; @@ -4270,7 +4324,7 @@ S_reginclasslen(pTHX_ register regnode *n, register U8* p, STRLEN* lenp, registe STRLEN len; char *s = SvPV(sv, len); - if (len <= plen && memEQ(s, p, len)) { + if (len <= plen && memEQ(s, (char*)p, len)) { *lenp = len; match = TRUE; break; @@ -4278,20 +4332,18 @@ S_reginclasslen(pTHX_ register regnode *n, register U8* p, STRLEN* lenp, registe } } 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) { - to_utf8_upper(p, tmpbuf, &tmplen); - if (swash_fetch(sw, tmpbuf, do_utf8)) - match = TRUE; - } } } } if (match && lenp && *lenp == 0) - *lenp = UNISKIP(c); + *lenp = UNISKIP(NATIVE_TO_UNI(c)); } if (!match && c < 256) { if (ANYOF_BITMAP_TEST(n, c)) @@ -4352,20 +4404,6 @@ S_reginclasslen(pTHX_ register regnode *n, register U8* p, STRLEN* lenp, registe return (flags & ANYOF_INVERT) ? !match : match; } -/* - - reginclass - determine if a character falls into a character class - - The n is the ANYOF regnode, the p is the target string, 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) -{ - return S_reginclasslen(aTHX_ n, p, 0, do_utf8); -} - STATIC U8 * S_reghop(pTHX_ U8 *s, I32 off) { @@ -4446,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; + } +}