From: Gurusamy Sarathy Date: Thu, 2 Dec 1999 06:04:57 +0000 (+0000) Subject: fixes for bugs in change#4586 and OS/2 pod tweak, from Ilya X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=66e933abe4c687207c84b01b9d96f575c3699b8e;p=p5sagit%2Fp5-mst-13.2.git fixes for bugs in change#4586 and OS/2 pod tweak, from Ilya p4raw-link: @4586 on //depot/cfgperl: 6eb5f6b9f48454b7ad64225a5bab0de7fdff695c p4raw-id: //depot/perl@4617 --- diff --git a/os2/OS2/REXX/REXX.pm b/os2/OS2/REXX/REXX.pm index 5c6dfd2..144dd37 100644 --- a/os2/OS2/REXX/REXX.pm +++ b/os2/OS2/REXX/REXX.pm @@ -335,6 +335,11 @@ which access REXX queues or REXX variables in signal handlers. See C for examples. +=head1 ENVIRONMENT + +If C is set, prints trace info on calls to REXX runtime +environment. + =head1 AUTHOR Andreas Kaiser ak@ananke.s.bawue.de, with additions by Ilya Zakharevich diff --git a/regexec.c b/regexec.c index 9c0ef17..333f842 100644 --- a/regexec.c +++ b/regexec.c @@ -650,8 +650,10 @@ 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) { /* boo */ + && prog->check_substr == prog->float_substr) + { /* If flags & SOMETHING - do not do it many times on the same match */ SvREFCNT_dec(prog->check_substr); prog->check_substr = Nullsv; /* disable */ @@ -677,9 +679,12 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, regstclass does not come from lookahead... */ /* If regstclass takes bytelength more than 1: If charlength==1, OK. This leaves EXACTF only, which is dealt with in find_byclass(). */ + int cl_l = (PL_regkind[(U8)OP(prog->regstclass)] == EXACT + ? STR_LEN(prog->regstclass) + : 1); char *endpos = (prog->anchored_substr || ml_anch) - ? s + (prog->minlen? 1 : 0) - : (prog->float_substr ? check_at - start_shift + 1 + ? s + (prog->minlen? cl_l : 0) + : (prog->float_substr ? check_at - start_shift + cl_l : strend) ; char *startpos = sv ? strend - SvCUR(sv) : s; @@ -694,30 +699,43 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, "Could not match STCLASS...\n") ); goto fail; } + DEBUG_r( PerlIO_printf(Perl_debug_log, + "This position contradicts STCLASS...\n") ); /* Contradict one of substrings */ if (prog->anchored_substr) { - DEBUG_r( PerlIO_printf(Perl_debug_log, - "This position contradicts STCLASS...\n") ); if (prog->anchored_substr == check) { DEBUG_r( what = "anchored" ); hop_and_restart: PL_regeol = strend; /* Used in HOP() */ s = HOPc(t, 1); + if (s + start_shift + end_shift > strend) { + /* XXXX Should be taken into account earlier? */ + DEBUG_r( PerlIO_printf(Perl_debug_log, + "Could not match STCLASS...\n") ); + goto fail; + } DEBUG_r( PerlIO_printf(Perl_debug_log, - "trying %s substr starting at offset %ld...\n", + "Trying %s substr starting at offset %ld...\n", what, (long)(s + start_shift - i_strpos)) ); goto restart; } - /* Have both, check is floating */ + /* Have both, check_string is floating */ if (t + start_shift >= check_at) /* Contradicts floating=check */ goto retry_floating_check; /* Recheck anchored substring, but not floating... */ s = check_at; DEBUG_r( PerlIO_printf(Perl_debug_log, - "trying anchored substr starting at offset %ld...\n", + "Trying anchored substr starting at offset %ld...\n", (long)(other_last - i_strpos)) ); goto do_other_anchored; } + if (!prog->float_substr) { /* Could have been deleted */ + if (ml_anch) { + s = t = t + 1; + goto try_at_offset; + } + goto fail; + } /* Check is floating subtring. */ retry_floating_check: t = check_at - start_shift; @@ -737,7 +755,8 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, return s; fail_finish: /* Substring not found */ - BmUSEFUL(prog->check_substr) += 5; /* hooray */ + if (prog->check_substr) /* could be removed already */ + BmUSEFUL(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])); @@ -804,9 +823,9 @@ S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *sta if (c1 == c2) { while (s <= e) { if ( *s == c1 - && (ln == 1 || (OP(c) == EXACTF - ? ibcmp(s, m, ln) - : ibcmp_locale(s, m, ln))) + && (ln == 1 || !(OP(c) == EXACTF + ? ibcmp(s, m, ln) + : ibcmp_locale(s, m, ln))) && (norun || regtry(prog, s)) ) goto got_it; s++; @@ -814,9 +833,9 @@ S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *sta } else { while (s <= e) { if ( (*s == c1 || *s == c2) - && (ln == 1 || (OP(c) == EXACTF - ? ibcmp(s, m, ln) - : ibcmp_locale(s, m, ln))) + && (ln == 1 || !(OP(c) == EXACTF + ? ibcmp(s, m, ln) + : ibcmp_locale(s, m, ln))) && (norun || regtry(prog, s)) ) goto got_it; s++; @@ -1488,7 +1507,8 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * goto phooey; } else if (c = prog->regstclass) { - if (minlen) /* don't bother with what can't match */ + if (minlen && PL_regkind[(U8)OP(prog->regstclass)] != EXACT) + /* don't bother with what can't match */ strend = HOPc(strend, -(minlen - 1)); if (find_byclass(prog, c, s, strend, startpos, 0)) goto got_it; diff --git a/t/op/re_tests b/t/op/re_tests index f866385..20b2d63 100644 --- a/t/op/re_tests +++ b/t/op/re_tests @@ -744,3 +744,6 @@ tt+$ xxxtt y - - \GX.*X aaaXbX n - - (\d+\.\d+) 3.1415926 y $1 3.1415926 (\ba.{0,10}br) have a web browser y $1 a web br +'\.c(pp|xx|c)?$'i Changes n - - +'\.c(pp|xx|c)?$'i IO.c y - - +'(\.c(pp|xx|c)?$)'i IO.c y $1 .c