diff options
author | Yves Orton <demerphq@gmail.com> | 2016-03-11 10:36:25 +0100 |
---|---|---|
committer | Yves Orton <demerphq@gmail.com> | 2016-03-13 12:39:23 +0100 |
commit | cb41e5d6f2193df9fd06cf60a96285694ec458ba (patch) | |
tree | 3c3d1c14ff4fa8705920eaeb1ab6378977d4948c /regexec.c | |
parent | febe9c7a66e3a16aba6a75e5550c8005ecb52f10 (diff) | |
download | perl-cb41e5d6f2193df9fd06cf60a96285694ec458ba.tar.gz |
Rework diagnostics in the regex engine
This introduces three new subs:
Perl_re_printf() which is a wrapper for
PerlIO_printf( Perl_debug_log, ... ),
which cuts down on clutter in the code. Arguably this could be moved
to util.c and renamed something like PerlIO_debugf() and then we could
declutter all the statements that write to the Perl_debug_log
filehandle. But that is a bit too ambituous for me right now, so
I leave this as a regex engine only sub for now.
Perl_re_indentf() which is a wrapper for PerlIO_re_printf(),
which adds an indent argument and automatically indents the
line appropriately, and is used in regcomp.c for trace diagnostics
during compilation.
Perl_re_indentfo() which is similar to Perl_re_indentf() but
is used in regexec.c which adds a specific prefix to each indented
line to account for the fact that during execution we normally have
string position information on the left.
The end result of this patch is that a lot of clutter in the debugging
statements in the regex engine is reduced, exposing what is actually
going on. It should also now be easier to add new diagnostics which
"do the right thing".
Over time the debugging trace output in regexec has become
very cluttered and confusing. This patch cleans much of it up,
if something happens at a given recursion depth it is output
at the right depth, etc, and formats have been changed to not have
leading spaces so you can actually see the indentation properly.
Diffstat (limited to 'regexec.c')
-rw-r--r-- | regexec.c | 417 |
1 files changed, 211 insertions, 206 deletions
@@ -97,7 +97,7 @@ static const char* const non_utf8_target_but_utf8_required #endif #define NON_UTF8_TARGET_BUT_UTF8_REQUIRED(target) STMT_START { \ - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s", non_utf8_target_but_utf8_required));\ + DEBUG_EXECUTE_r(Perl_re_printf( "%s", non_utf8_target_but_utf8_required));\ goto target; \ } STMT_END @@ -300,7 +300,7 @@ S_regcppush(pTHX_ const regexp *rex, I32 parenfloor, U32 maxopenparen) DEBUG_BUFFERS_r( if ((int)maxopenparen > (int)parenfloor) - PerlIO_printf(Perl_debug_log, + Perl_re_printf( "rex=0x%"UVxf" offs=0x%"UVxf": saving capture indices:\n", PTR2UV(rex), PTR2UV(rex->offs) @@ -311,7 +311,7 @@ S_regcppush(pTHX_ const regexp *rex, I32 parenfloor, U32 maxopenparen) SSPUSHIV(rex->offs[p].end); SSPUSHIV(rex->offs[p].start); SSPUSHINT(rex->offs[p].start_tmp); - DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log, + DEBUG_BUFFERS_r(Perl_re_printf( " \\%"UVuf": %"IVdf"(%"IVdf")..%"IVdf"\n", (UV)p, (IV)rex->offs[p].start, @@ -331,17 +331,21 @@ S_regcppush(pTHX_ const regexp *rex, I32 parenfloor, U32 maxopenparen) /* These are needed since we do not localize EVAL nodes: */ #define REGCP_SET(cp) \ DEBUG_STATE_r( \ - PerlIO_printf(Perl_debug_log, \ - " Setting an EVAL scope, savestack=%"IVdf"\n", \ - (IV)PL_savestack_ix)); \ + Perl_re_indentfo( \ + "Setting an EVAL scope, savestack=%"IVdf",\n", \ + depth, (IV)PL_savestack_ix \ + ) \ + ); \ cp = PL_savestack_ix #define REGCP_UNWIND(cp) \ DEBUG_STATE_r( \ - if (cp != PL_savestack_ix) \ - PerlIO_printf(Perl_debug_log, \ - " Clearing an EVAL scope, savestack=%"IVdf"..%"IVdf"\n", \ - (IV)(cp), (IV)PL_savestack_ix)); \ + if (cp != PL_savestack_ix) \ + Perl_re_indentfo( \ + "Clearing an EVAL scope, savestack=%"IVdf"..%"IVdf"\n",\ + depth, (IV)(cp), (IV)PL_savestack_ix \ + ) \ + ); \ regcpblow(cp) #define UNWIND_PAREN(lp, lcp) \ @@ -372,7 +376,7 @@ S_regcppop(pTHX_ regexp *rex, U32 *maxopenparen_p) /* Now restore the parentheses context. */ DEBUG_BUFFERS_r( if (i || rex->lastparen + 1 <= rex->nparens) - PerlIO_printf(Perl_debug_log, + Perl_re_printf( "rex=0x%"UVxf" offs=0x%"UVxf": restoring capture indices to:\n", PTR2UV(rex), PTR2UV(rex->offs) @@ -386,7 +390,7 @@ S_regcppop(pTHX_ regexp *rex, U32 *maxopenparen_p) tmps = SSPOPIV; if (paren <= rex->lastparen) rex->offs[paren].end = tmps; - DEBUG_BUFFERS_r( PerlIO_printf(Perl_debug_log, + DEBUG_BUFFERS_r( Perl_re_printf( " \\%"UVuf": %"IVdf"(%"IVdf")..%"IVdf"%s\n", (UV)paren, (IV)rex->offs[paren].start, @@ -410,7 +414,7 @@ S_regcppop(pTHX_ regexp *rex, U32 *maxopenparen_p) if (i > *maxopenparen_p) rex->offs[i].start = -1; rex->offs[i].end = -1; - DEBUG_BUFFERS_r( PerlIO_printf(Perl_debug_log, + DEBUG_BUFFERS_r( Perl_re_printf( " \\%"UVuf": %s ..-1 undeffing\n", (UV)i, (i > *maxopenparen_p) ? "-1" : " " @@ -652,7 +656,7 @@ Perl_re_intuit_start(pTHX_ PERL_UNUSED_ARG(flags); PERL_UNUSED_ARG(data); - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( "Intuit: trying to determine minimum start position...\n")); /* for now, assume that all substr offsets are positive. If at some point @@ -683,7 +687,7 @@ Perl_re_intuit_start(pTHX_ * to quickly reject some cases that can't match, but will reject * them later after doing full char arithmetic */ if (prog->minlen > strend - strpos) { - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( " String too short...\n")); goto fail; } @@ -720,7 +724,7 @@ Perl_re_intuit_start(pTHX_ if (!sv) continue; - PerlIO_printf(Perl_debug_log, + Perl_re_printf( " substrs[%d]: min=%"IVdf" max=%"IVdf" end shift=%"IVdf " useful=%"IVdf" utf8=%d [%s]\n", i, @@ -760,7 +764,7 @@ Perl_re_intuit_start(pTHX_ if ( strpos != strbeg && (prog->intflags & PREGf_ANCH_SBOL)) { - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( " Not at start...\n")); goto fail; } @@ -780,7 +784,7 @@ Perl_re_intuit_start(pTHX_ SSize_t slen = SvCUR(check); char *s = HOP3c(strpos, prog->check_offset_min, strend); - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( " Looking for check substr at fixed offset %"IVdf"...\n", (IV)prog->check_offset_min)); @@ -794,7 +798,7 @@ Perl_re_intuit_start(pTHX_ || strend - s < slen - 1 || (strend - s == slen && strend[-1] != '\n'))) { - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( " String too long...\n")); goto fail_finish; } @@ -804,7 +808,7 @@ Perl_re_intuit_start(pTHX_ if (slen && (*SvPVX_const(check) != *s || (slen > 1 && memNE(SvPVX_const(check), s, slen)))) { - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( " String not equal...\n")); goto fail_finish; } @@ -855,7 +859,7 @@ Perl_re_intuit_start(pTHX_ U8* end_point; DEBUG_OPTIMISE_MORE_r({ - PerlIO_printf(Perl_debug_log, + Perl_re_printf( " At restart: rx_origin=%"IVdf" Check offset min: %"IVdf " Start shift: %"IVdf" End shift %"IVdf " Real end Shift: %"IVdf"\n", @@ -903,7 +907,7 @@ Perl_re_intuit_start(pTHX_ check_at = fbm_instr( start_point, end_point, check, multiline ? FBMrf_MULTILINE : 0); - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( " doing 'check' fbm scan, [%"IVdf"..%"IVdf"] gave %"IVdf"\n", (IV)((char*)start_point - strbeg), (IV)((char*)end_point - strbeg), @@ -916,7 +920,7 @@ Perl_re_intuit_start(pTHX_ DEBUG_EXECUTE_r({ RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0), SvPVX_const(check), RE_SV_DUMPLEN(check), 30); - PerlIO_printf(Perl_debug_log, " %s %s substr %s%s%s", + Perl_re_printf( " %s %s substr %s%s%s", (check_at ? "Found" : "Did not find"), (check == (utf8_target ? prog->anchored_utf8 : prog->anchored_substr) ? "anchored" : "floating"), @@ -935,7 +939,7 @@ Perl_re_intuit_start(pTHX_ if (check_at - rx_origin > prog->check_offset_max) rx_origin = HOP3c(check_at, -prog->check_offset_max, rx_origin); /* Finish the diagnostic message */ - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( "%ld (rx_origin now %"IVdf")...\n", (long)(check_at - strbeg), (IV)(rx_origin - strbeg) @@ -1049,7 +1053,7 @@ Perl_re_intuit_start(pTHX_ if (from > to) { s = NULL; - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( " skipping 'other' fbm scan: %"IVdf" > %"IVdf"\n", (IV)(from - strbeg), (IV)(to - strbeg) @@ -1062,7 +1066,7 @@ Perl_re_intuit_start(pTHX_ must, multiline ? FBMrf_MULTILINE : 0 ); - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( " doing 'other' fbm scan, [%"IVdf"..%"IVdf"] gave %"IVdf"\n", (IV)(from - strbeg), (IV)(to - strbeg), @@ -1074,7 +1078,7 @@ Perl_re_intuit_start(pTHX_ DEBUG_EXECUTE_r({ RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0), SvPVX_const(must), RE_SV_DUMPLEN(must), 30); - PerlIO_printf(Perl_debug_log, " %s %s substr %s%s", + Perl_re_printf( " %s %s substr %s%s", s ? "Found" : "Contradicts", other_ix ? "floating" : "anchored", quoted, RE_SV_TAIL(must)); @@ -1085,7 +1089,7 @@ Perl_re_intuit_start(pTHX_ /* last1 is latest possible substr location. If we didn't * find it before there, we never will */ if (last >= last1) { - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( "; giving up...\n")); goto fail_finish; } @@ -1098,7 +1102,7 @@ Perl_re_intuit_start(pTHX_ other_ix /* i.e. if other-is-float */ ? HOP3c(rx_origin, 1, strend) : HOP4c(last, 1 - other->min_offset, strbeg, strend); - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( "; about to retry %s at offset %ld (rx_origin now %"IVdf")...\n", (other_ix ? "floating" : "anchored"), (long)(HOP3c(check_at, 1, strend) - strbeg), @@ -1122,7 +1126,7 @@ Perl_re_intuit_start(pTHX_ rx_origin = HOP3c(s, -other->min_offset, strbeg); other_last = HOP3c(s, 1, strend); } - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( " at offset %ld (rx_origin now %"IVdf")...\n", (long)(s - strbeg), (IV)(rx_origin - strbeg) @@ -1132,7 +1136,7 @@ Perl_re_intuit_start(pTHX_ } else { DEBUG_OPTIMISE_MORE_r( - PerlIO_printf(Perl_debug_log, + Perl_re_printf( " Check-only match: offset min:%"IVdf" max:%"IVdf " check_at:%"IVdf" rx_origin:%"IVdf" rx_origin-check_at:%"IVdf " strend:%"IVdf"\n", @@ -1153,7 +1157,7 @@ Perl_re_intuit_start(pTHX_ if (ml_anch && rx_origin != strbeg && rx_origin[-1] != '\n') { char *s; - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( " looking for /^/m anchor")); /* we have failed the constraint of a \n before rx_origin. @@ -1173,7 +1177,7 @@ Perl_re_intuit_start(pTHX_ if (s <= rx_origin || ! ( rx_origin = (char *)memchr(rx_origin, '\n', s - rx_origin))) { - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( " Did not find /%s^%s/m...\n", PL_colors[0], PL_colors[1])); goto fail_finish; @@ -1190,7 +1194,7 @@ Perl_re_intuit_start(pTHX_ /* Position contradicts check-string; either because * check was anchored (and thus has no wiggle room), * or check was float and rx_origin is above the float range */ - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( " Found /%s^%s/m, about to restart lookup for check-string with rx_origin %ld...\n", PL_colors[0], PL_colors[1], (long)(rx_origin - strbeg))); goto restart; @@ -1206,7 +1210,7 @@ Perl_re_intuit_start(pTHX_ * contradict. On the other hand, the float "check" substr * didn't contradict, so just retry the anchored "other" * substr */ - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( " Found /%s^%s/m, rescanning for anchored from offset %"IVdf" (rx_origin now %"IVdf")...\n", PL_colors[0], PL_colors[1], (IV)(rx_origin - strbeg + prog->anchored_offset), @@ -1217,12 +1221,12 @@ Perl_re_intuit_start(pTHX_ /* success: we don't contradict the found floating substring * (and there's no anchored substr). */ - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( " Found /%s^%s/m with rx_origin %ld...\n", PL_colors[0], PL_colors[1], (long)(rx_origin - strbeg))); } else { - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( " (multiline anchor test skipped)\n")); } @@ -1280,7 +1284,7 @@ Perl_re_intuit_start(pTHX_ else endpos= strend; - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( " looking for class: start_shift: %"IVdf" check_at: %"IVdf " rx_origin: %"IVdf" endpos: %"IVdf"\n", (IV)start_shift, (IV)(check_at - strbeg), @@ -1290,11 +1294,11 @@ Perl_re_intuit_start(pTHX_ reginfo); if (!s) { if (endpos == strend) { - DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r( Perl_re_printf( " Could not match STCLASS...\n") ); goto fail; } - DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r( Perl_re_printf( " This position contradicts STCLASS...\n") ); if ((prog->intflags & PREGf_ANCH) && !ml_anch && !(prog->intflags & PREGf_IMPLICIT)) @@ -1315,7 +1319,7 @@ Perl_re_intuit_start(pTHX_ * an extra anchored search may get done, but in * practice the extra fbm_instr() is likely to * get skipped anyway. */ - DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r( Perl_re_printf( " about to retry anchored at offset %ld (rx_origin now %"IVdf")...\n", (long)(other_last - strbeg), (IV)(rx_origin - strbeg) @@ -1336,7 +1340,7 @@ Perl_re_intuit_start(pTHX_ * but since we goto a block of code that's going to * search for the next \n if any, its safe here */ rx_origin++; - DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r( Perl_re_printf( " about to look for /%s^%s/m starting at rx_origin %ld...\n", PL_colors[0], PL_colors[1], (long)(rx_origin - strbeg)) ); @@ -1360,11 +1364,11 @@ Perl_re_intuit_start(pTHX_ * It's conservative: it errs on the side of doing 'goto restart', * where there is code that does a proper char-based test */ if (rx_origin + start_shift + end_shift > strend) { - DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r( Perl_re_printf( " Could not match STCLASS...\n") ); goto fail; } - DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r( Perl_re_printf( " about to look for %s substr starting at offset %ld (rx_origin now %"IVdf")...\n", (prog->substrs->check_ix ? "floating" : "anchored"), (long)(rx_origin + start_shift - strbeg), @@ -1376,13 +1380,13 @@ Perl_re_intuit_start(pTHX_ /* Success !!! */ if (rx_origin != s) { - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( " By STCLASS: moving %ld --> %ld\n", (long)(rx_origin - strbeg), (long)(s - strbeg)) ); } else { - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( " Does not contradict STCLASS...\n"); ); } @@ -1394,7 +1398,7 @@ Perl_re_intuit_start(pTHX_ /* Fixed substring is found far enough so that the match cannot start at strpos. */ - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " try at offset...\n")); + DEBUG_EXECUTE_r(Perl_re_printf( " try at offset...\n")); ++BmUSEFUL(utf8_target ? prog->check_utf8 : prog->check_substr); /* hooray/5 */ } else { @@ -1414,7 +1418,7 @@ Perl_re_intuit_start(pTHX_ ))) { /* If flags & SOMETHING - do not do it many times on the same match */ - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " ... Disabling check substring...\n")); + DEBUG_EXECUTE_r(Perl_re_printf( " ... Disabling check substring...\n")); /* XXX Does the destruction order has to change with utf8_target? */ SvREFCNT_dec(utf8_target ? prog->check_utf8 : prog->check_substr); SvREFCNT_dec(utf8_target ? prog->check_substr : prog->check_utf8); @@ -1428,7 +1432,7 @@ Perl_re_intuit_start(pTHX_ } } - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( "Intuit: %sSuccessfully guessed:%s match at offset %ld\n", PL_colors[4], PL_colors[5], (long)(rx_origin - strbeg)) ); @@ -1438,7 +1442,7 @@ Perl_re_intuit_start(pTHX_ if (prog->check_substr || prog->check_utf8) /* could be removed already */ BmUSEFUL(utf8_target ? prog->check_utf8 : prog->check_substr) += 5; /* hooray */ fail: - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n", + DEBUG_EXECUTE_r(Perl_re_printf( "%sMatch rejected by optimizer%s\n", PL_colors[4], PL_colors[5])); return NULL; } @@ -1535,9 +1539,9 @@ STMT_START { } \ } STMT_END -#define DUMP_EXEC_POS(li,s,doutf8) \ +#define DUMP_EXEC_POS(li,s,doutf8,depth) \ dump_exec_pos(li,s,(reginfo->strend),(reginfo->strbeg), \ - startpos, doutf8) + startpos, doutf8, depth) #define REXEC_FBC_EXACTISH_SCAN(COND) \ STMT_START { \ @@ -2565,8 +2569,8 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, DEBUG_TRIE_EXECUTE_r( if ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) { dump_exec_pos( (char *)uc, c, strend, real_start, - (char *)uc, utf8_target ); - PerlIO_printf( Perl_debug_log, + (char *)uc, utf8_target, 0 ); + Perl_re_printf( " Scanning for legal start char...\n"); } ); @@ -2601,8 +2605,8 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, foldbuf, uniflags); DEBUG_TRIE_EXECUTE_r({ dump_exec_pos( (char *)uc, c, strend, - real_start, s, utf8_target); - PerlIO_printf(Perl_debug_log, + real_start, s, utf8_target, 0); + Perl_re_printf( " Charid:%3u CP:%4"UVxf" ", charid, uvc); }); @@ -2622,8 +2626,8 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, DEBUG_TRIE_EXECUTE_r({ if (failed) dump_exec_pos( (char *)uc, c, strend, real_start, - s, utf8_target ); - PerlIO_printf( Perl_debug_log, + s, utf8_target, 0 ); + Perl_re_printf( "%sState: %4"UVxf", word=%"UVxf, failed ? " Fail transition to " : "", (UV)state, (UV)word); @@ -2639,13 +2643,13 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, && (tmp=trie->trans[offset].next)) { DEBUG_TRIE_EXECUTE_r( - PerlIO_printf( Perl_debug_log," - legal\n")); + Perl_re_printf(" - legal\n")); state = tmp; break; } else { DEBUG_TRIE_EXECUTE_r( - PerlIO_printf( Perl_debug_log," - fail\n")); + Perl_re_printf(" - fail\n")); failed = 1; state = aho->fail[state]; } @@ -2653,7 +2657,7 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, else { /* we must be accepting here */ DEBUG_TRIE_EXECUTE_r( - PerlIO_printf( Perl_debug_log," - accepting\n")); + Perl_re_printf(" - accepting\n")); failed = 1; break; } @@ -2675,8 +2679,7 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, if (leftmost) { s = (char*)leftmost; DEBUG_TRIE_EXECUTE_r({ - PerlIO_printf( - Perl_debug_log,"Matches word #%"UVxf" at position %"IVdf". Trying full pattern...\n", + Perl_re_printf( "Matches word #%"UVxf" at position %"IVdf". Trying full pattern...\n", (UV)accepted_word, (IV)(s - real_start) ); }); @@ -2687,11 +2690,11 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, } s = HOPc(s,1); DEBUG_TRIE_EXECUTE_r({ - PerlIO_printf( Perl_debug_log,"Pattern failed. Looking for new start point...\n"); + Perl_re_printf("Pattern failed. Looking for new start point...\n"); }); } else { DEBUG_TRIE_EXECUTE_r( - PerlIO_printf( Perl_debug_log,"No match.\n")); + Perl_re_printf("No match.\n")); break; } } @@ -2724,7 +2727,7 @@ S_reg_set_capture_string(pTHX_ REGEXP * const rx, #ifdef PERL_ANY_COW if (SvCANCOW(sv)) { if (DEBUG_C_TEST) { - PerlIO_printf(Perl_debug_log, + Perl_re_printf( "Copy on write: regexp capture, type %d\n", (int) SvTYPE(sv)); } @@ -2923,7 +2926,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, ? strbeg + MgBYTEPOS(mg, sv, strbeg, strend-strbeg) : strbeg; /* pos() not defined; use start of string */ - DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log, + DEBUG_GPOS_r(Perl_re_printf( "GPOS ganch set to strbeg[%"IVdf"]\n", (IV)(reginfo->ganch - strbeg))); /* in the presence of \G, we may need to start looking earlier in @@ -2942,7 +2945,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, if (!startpos || ((flags & REXEC_FAIL_ON_UNDERFLOW) && startpos < stringarg)) { - DEBUG_r(PerlIO_printf(Perl_debug_log, + DEBUG_r(Perl_re_printf( "fail: ganch-gofs before earliest possible start\n")); return 0; } @@ -2961,7 +2964,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, minlen = prog->minlen; if ((startpos + minlen) > strend || startpos < strbeg) { - DEBUG_r(PerlIO_printf(Perl_debug_log, + DEBUG_r(Perl_re_printf( "Regex match can't succeed, so not even tried\n")); return 0; } @@ -2996,7 +2999,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, { /* this should only be possible under \G */ assert(prog->intflags & PREGf_GPOS_SEEN); - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( "matched, but failing for REXEC_FAIL_ON_UNDERFLOW\n")); goto phooey; } @@ -3021,7 +3024,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, multiline = prog->extflags & RXf_PMf_MULTILINE; if (strend - s < (minlen+(prog->check_offset_min<0?prog->check_offset_min:0))) { - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( "String too short [regexec_flags]...\n")); goto phooey; } @@ -3118,7 +3121,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, swap = prog->offs; /* do we need a save destructor here for eval dies? */ Newxz(prog->offs, (prog->nparens + 1), regexp_paren_pair); - DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log, + DEBUG_BUFFERS_r(Perl_re_printf( "rex=0x%"UVxf" saving offs: orig=0x%"UVxf" new=0x%"UVxf"\n", PTR2UV(prog), PTR2UV(swap), @@ -3229,7 +3232,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, ); } DEBUG_EXECUTE_r(if (!did_match) - PerlIO_printf(Perl_debug_log, + Perl_re_printf( "Did not find anchored character...\n") ); } @@ -3334,7 +3337,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, DEBUG_EXECUTE_r(if (!did_match) { RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0), SvPVX_const(must), RE_SV_DUMPLEN(must), 30); - PerlIO_printf(Perl_debug_log, "Did not find %s substr %s%s...\n", + Perl_re_printf( "Did not find %s substr %s%s...\n", ((must == prog->anchored_substr || must == prog->anchored_utf8) ? "anchored" : "floating"), quoted, RE_SV_TAIL(must)); @@ -3354,7 +3357,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, { RE_PV_QUOTED_DECL(quoted,utf8_target,PERL_DEBUG_PAD_ZERO(1), s,strend-s,60); - PerlIO_printf(Perl_debug_log, + Perl_re_printf( "Matching stclass %.*s against %s (%d bytes)\n", (int)SvCUR(prop), SvPVX_const(prop), quoted, (int)(strend - s)); @@ -3362,7 +3365,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, }); if (find_byclass(prog, c, s, strend, reginfo)) goto got_it; - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass... [regexec_flags]\n")); + DEBUG_EXECUTE_r(Perl_re_printf( "Contradicts stclass... [regexec_flags]\n")); } else { dontbother = 0; @@ -3401,14 +3404,14 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, * the \n. */ char *checkpos= strend - len; DEBUG_OPTIMISE_r( - PerlIO_printf(Perl_debug_log, + Perl_re_printf( "%sChecking for float_real.%s\n", PL_colors[4], PL_colors[5])); if (checkpos + 1 < strbeg) { /* can't match, even if we remove the trailing \n * string is too short to match */ DEBUG_EXECUTE_r( - PerlIO_printf(Perl_debug_log, + Perl_re_printf( "%sString shorter than required trailing substring, cannot match.%s\n", PL_colors[4], PL_colors[5])); goto phooey; @@ -3420,7 +3423,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, /* cant match, string is too short when the "\n" is * included */ DEBUG_EXECUTE_r( - PerlIO_printf(Perl_debug_log, + Perl_re_printf( "%sString does not contain required trailing substring, cannot match.%s\n", PL_colors[4], PL_colors[5])); goto phooey; @@ -3431,7 +3434,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, last= checkpos; } else { DEBUG_EXECUTE_r( - PerlIO_printf(Perl_debug_log, + Perl_re_printf( "%sString does not contain required trailing substring, cannot match.%s\n", PL_colors[4], PL_colors[5])); goto phooey; @@ -3455,7 +3458,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, * pretty sure it is not anymore, so I have removed the comment * and replaced it with this one. Yves */ DEBUG_EXECUTE_r( - PerlIO_printf(Perl_debug_log, + Perl_re_printf( "%sString does not contain required substring, cannot match.%s\n", PL_colors[4], PL_colors[5] )); @@ -3495,14 +3498,14 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, { /* this should only be possible under \G */ assert(prog->intflags & PREGf_GPOS_SEEN); - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( "matched, but failing for REXEC_FAIL_ON_UNDERFLOW\n")); goto phooey; } DEBUG_BUFFERS_r( if (swap) - PerlIO_printf(Perl_debug_log, + Perl_re_printf( "rex=0x%"UVxf" freeing offs: 0x%"UVxf"\n", PTR2UV(prog), PTR2UV(swap) @@ -3528,7 +3531,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, return 1; phooey: - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n", + DEBUG_EXECUTE_r(Perl_re_printf( "%sMatch failed%s\n", PL_colors[4], PL_colors[5])); /* clean up; this will trigger destructors that will free all slabs @@ -3539,7 +3542,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, if (swap) { /* we failed :-( roll it back */ - DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log, + DEBUG_BUFFERS_r(Perl_re_printf( "rex=0x%"UVxf" rolling back offs: freeing=0x%"UVxf" restoring=0x%"UVxf"\n", PTR2UV(prog), PTR2UV(prog->offs), @@ -3572,6 +3575,9 @@ S_regtry(pTHX_ regmatch_info *reginfo, char **startposp) REGEXP *const rx = reginfo->prog; regexp *const prog = ReANY(rx); SSize_t result; +#ifdef DEBUGGING + U32 depth = 0; /* used by REGCP_SET */ +#endif RXi_GET_DECL(prog,progi); GET_RE_DEBUG_FLAGS_DECL; @@ -3632,10 +3638,26 @@ S_regtry(pTHX_ regmatch_info *reginfo, char **startposp) sayNO /* this is used to determine how far from the left messages like - 'failed...' are printed. It should be set such that messages - are inline with the regop output that created them. + 'failed...' are printed in regexec.c. It should be set such that + messages are inline with the regop output that created them. */ -#define REPORT_CODE_OFF 32 +#define REPORT_CODE_OFF 29 +#define INDENT_CHARS(depth) ((depth) % 20) +#ifdef DEBUGGING +int +Perl_re_indentfo(const char *fmt, U32 depth, ...) +{ + va_list ap; + int result; + PerlIO *f= Perl_debug_log; + PERL_ARGS_ASSERT_RE_INDENTFO; + va_start(ap, depth); + PerlIO_printf(f, "%*s|%4d| %*s", REPORT_CODE_OFF, "", depth, INDENT_CHARS(depth), "" ); + result = PerlIO_vprintf(f, fmt, ap); + va_end(ap); + return result; +} +#endif /* DEBUGGING */ #define CHRTEST_UNINIT -1001 /* c1/c2 haven't been calculated yet */ @@ -3816,18 +3838,18 @@ regmatch(), slabs allocated since entry are freed. */ -#define DEBUG_STATE_pp(pp) \ - DEBUG_STATE_r({ \ - DUMP_EXEC_POS(locinput, scan, utf8_target); \ - PerlIO_printf(Perl_debug_log, \ - " %*s"pp" %s%s%s%s%s\n", \ - depth*2, "", \ - PL_reg_name[st->resume_state], \ - ((st==yes_state||st==mark_state) ? "[" : ""), \ - ((st==yes_state) ? "Y" : ""), \ - ((st==mark_state) ? "M" : ""), \ - ((st==yes_state||st==mark_state) ? "]" : "") \ - ); \ +#define DEBUG_STATE_pp(pp) \ + DEBUG_STATE_r({ \ + DUMP_EXEC_POS(locinput, scan, utf8_target,depth); \ + Perl_re_printf( \ + "%*s" pp " %s%s%s%s%s\n", \ + INDENT_CHARS(depth), "", \ + PL_reg_name[st->resume_state], \ + ((st==yes_state||st==mark_state) ? "[" : ""), \ + ((st==yes_state) ? "Y" : ""), \ + ((st==mark_state) ? "M" : ""), \ + ((st==yes_state||st==mark_state) ? "]" : "") \ + ); \ }); @@ -3852,12 +3874,12 @@ S_debug_start_match(pTHX_ const REGEXP *prog, const bool utf8_target, RE_PV_QUOTED_DECL(s1, utf8_target, PERL_DEBUG_PAD_ZERO(1), start, end - start, 60); - PerlIO_printf(Perl_debug_log, + Perl_re_printf( "%s%s REx%s %s against %s\n", PL_colors[4], blurb, PL_colors[5], s0, s1); if (utf8_target||utf8_pat) - PerlIO_printf(Perl_debug_log, "UTF-8 %s%s%s...\n", + Perl_re_printf( "UTF-8 %s%s%s...\n", utf8_pat ? "pattern" : "", utf8_pat && utf8_target ? " and " : "", utf8_target ? "string" : "" @@ -3871,7 +3893,9 @@ S_dump_exec_pos(pTHX_ const char *locinput, const char *loc_regeol, const char *loc_bostr, const char *loc_reg_starttry, - const bool utf8_target) + const bool utf8_target, + const U32 depth + ) { const int docolor = *PL_colors[0] || *PL_colors[2] || *PL_colors[4]; const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */ @@ -3914,15 +3938,16 @@ S_dump_exec_pos(pTHX_ const char *locinput, locinput, loc_regeol - locinput, 10, 0, 1); const STRLEN tlen=len0+len1+len2; - PerlIO_printf(Perl_debug_log, - "%4"IVdf" <%.*s%.*s%s%.*s>%*s|", + Perl_re_printf( + "%4"IVdf" <%.*s%.*s%s%.*s>%*s|%4u| ", (IV)(locinput - loc_bostr), len0, s0, len1, s1, (docolor ? "" : "> <"), len2, s2, (int)(tlen > 19 ? 0 : 19 - tlen), - ""); + "", + depth); } } @@ -4482,7 +4507,7 @@ S_isLB(pTHX_ LB_enum before, } #ifdef DEBUGGING - PerlIO_printf(Perl_error_log, "Unhandled LB pair: LB_table[%d, %d] = %d\n", + Perl_re_printf( "Unhandled LB pair: LB_table[%d, %d] = %d\n", before, after, LB_table[before][after]); assert(0); #endif @@ -4989,7 +5014,7 @@ S_isWB(pTHX_ WB_enum previous, } #ifdef DEBUGGING - PerlIO_printf(Perl_error_log, "Unhandled WB pair: WB_table[%d, %d] = %d\n", + Perl_re_printf( "Unhandled WB pair: WB_table[%d, %d] = %d\n", before, after, WB_table[before][after]); assert(0); #endif @@ -5201,7 +5226,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) PERL_ARGS_ASSERT_REGMATCH; DEBUG_OPTIMISE_r( DEBUG_EXECUTE_r({ - PerlIO_printf(Perl_debug_log,"regmatch start\n"); + Perl_re_printf("regmatch start\n"); })); st = PL_regmatch_state; @@ -5211,19 +5236,6 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) scan = prog; while (scan != NULL) { - DEBUG_EXECUTE_r( { - SV * const prop = sv_newmortal(); - regnode *rnext=regnext(scan); - DUMP_EXEC_POS( locinput, scan, utf8_target ); - regprop(rex, prop, scan, reginfo, NULL); - - PerlIO_printf(Perl_debug_log, - "%3"IVdf":%*s%s(%"IVdf")\n", - (IV)(scan - rexi->program), depth*2, "", - SvPVX_const(prop), - (PL_regkind[OP(scan)] == END || !rnext) ? - 0 : (IV)(rnext - rexi->program)); - }); next = scan + NEXT_OFF(scan); if (next == scan) @@ -5231,6 +5243,23 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) state_num = OP(scan); reenter_switch: + DEBUG_EXECUTE_r( + if (state_num <= REGNODE_MAX) { + SV * const prop = sv_newmortal(); + regnode *rnext = regnext(scan); + + DUMP_EXEC_POS( locinput, scan, utf8_target, depth ); + regprop(rex, prop, scan, reginfo, NULL); + Perl_re_printf( + "%*s%"IVdf":%s(%"IVdf")\n", + INDENT_CHARS(depth), "", + (IV)(scan - rexi->program), + SvPVX_const(prop), + (PL_regkind[OP(scan)] == END || !rnext) ? + 0 : (IV)(rnext - rexi->program)); + } + ); + to_complement = 0; SET_nextchr; @@ -5304,9 +5333,8 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) */ if(!NEXTCHR_IS_EOS && !ANYOF_BITMAP_TEST(scan, nextchr)) { DEBUG_EXECUTE_r( - PerlIO_printf(Perl_debug_log, - "%*s %sfailed to match trie start class...%s\n", - REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5]) + Perl_re_indentfo( "%sfailed to match trie start class...%s\n", + depth, PL_colors[4], PL_colors[5]) ); sayNO_SILENT; NOT_REACHED; /* NOTREACHED */ @@ -5385,17 +5413,15 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) { if (trie->states[ state ].wordnum) { DEBUG_EXECUTE_r( - PerlIO_printf(Perl_debug_log, - "%*s %smatched empty string...%s\n", - REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5]) + Perl_re_indentfo( "%smatched empty string...%s\n", + depth, PL_colors[4], PL_colors[5]) ); if (!trie->jump) break; } else { DEBUG_EXECUTE_r( - PerlIO_printf(Perl_debug_log, - "%*s %sfailed to match trie start class...%s\n", - REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5]) + Perl_re_indentfo( "%sfailed to match trie start class...%s\n", + depth, PL_colors[4], PL_colors[5]) ); sayNO_SILENT; } @@ -5447,10 +5473,10 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) } DEBUG_TRIE_EXECUTE_r({ - DUMP_EXEC_POS( (char *)uc, scan, utf8_target ); - PerlIO_printf( Perl_debug_log, - "%*s %sState: %4"UVxf" Accepted: %c ", - 2+depth * 2, "", PL_colors[4], + DUMP_EXEC_POS( (char *)uc, scan, utf8_target, depth ); + Perl_re_indentfo( + "%sState: %4"UVxf" Accepted: %c ", + depth, PL_colors[4], (UV)state, (accepted ? 'Y' : 'N')); }); @@ -5482,7 +5508,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) state = 0; } DEBUG_TRIE_EXECUTE_r( - PerlIO_printf( Perl_debug_log, + Perl_re_printf( "Charid:%3x CP:%4"UVxf" After State: %4"UVxf"%s\n", charid, uvc, (UV)state, PL_colors[5] ); ); @@ -5502,9 +5528,8 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) } DEBUG_EXECUTE_r( - PerlIO_printf( Perl_debug_log, - "%*s %sgot %"IVdf" possible matches%s\n", - REPORT_CODE_OFF + depth * 2, "", + Perl_re_indentfo( "%sgot %"IVdf" possible matches%s\n", + depth, PL_colors[4], (IV)ST.accepted, PL_colors[5] ); ); goto trie_first_try; /* jump into the fail handler */ @@ -5520,9 +5545,8 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) } if (!--ST.accepted) { DEBUG_EXECUTE_r({ - PerlIO_printf( Perl_debug_log, - "%*s %sTRIE failed...%s\n", - REPORT_CODE_OFF+depth*2, "", + Perl_re_indentfo( "%sTRIE failed...%s\n", + depth, PL_colors[4], PL_colors[5] ); }); @@ -5612,9 +5636,8 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) : NEXT_OFF(ST.me)); DEBUG_EXECUTE_r({ - PerlIO_printf( Perl_debug_log, - "%*s %sTRIE matched word #%d, continuing%s\n", - REPORT_CODE_OFF+depth*2, "", + Perl_re_indentfo( "%sTRIE matched word #%d, continuing%s\n", + depth, PL_colors[4], ST.nextword, PL_colors[5] @@ -5633,9 +5656,8 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) ? av_fetch(trie_words, ST.nextword - 1, 0) : NULL; SV *sv= tmp ? sv_newmortal() : NULL; - PerlIO_printf( Perl_debug_log, - "%*s %sonly one match left, short-circuiting: #%d <%s>%s\n", - REPORT_CODE_OFF+depth*2, "", PL_colors[4], + Perl_re_indentfo( "%sonly one match left, short-circuiting: #%d <%s>%s\n", + depth, PL_colors[4], ST.nextword, tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0, PL_colors[0], PL_colors[1], @@ -6527,9 +6549,8 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) DEBUG_r({ GET_RE_DEBUG_FLAGS_DECL; DEBUG_EXECUTE_r({ - PerlIO_printf(Perl_debug_log, - "%*s pattern left-recursion without consuming input always fails...\n", - REPORT_CODE_OFF + depth*2, ""); + Perl_re_indentfo( " pattern left-recursion without consuming input always fails...\n", + depth); }); }); /* this would be infinite recursion, so we fail */ @@ -6656,7 +6677,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) } nop = nop->op_next; - DEBUG_STATE_r( PerlIO_printf(Perl_debug_log, + DEBUG_STATE_r( Perl_re_printf( " re EVAL PL_op=0x%"UVxf"\n", PTR2UV(nop)) ); rex->offs[0].end = locinput - reginfo->strbeg; @@ -6892,7 +6913,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) rex->offs[n].start_tmp = locinput - reginfo->strbeg; if (n > maxopenparen) maxopenparen = n; - DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log, + DEBUG_BUFFERS_r(Perl_re_printf( "rex=0x%"UVxf" offs=0x%"UVxf": \\%"UVuf": set %"IVdf" tmp; maxopenparen=%"UVuf"\n", PTR2UV(rex), PTR2UV(rex->offs), @@ -6907,7 +6928,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) #define CLOSE_CAPTURE \ rex->offs[n].start = rex->offs[n].start_tmp; \ rex->offs[n].end = locinput - reginfo->strbeg; \ - DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log, \ + DEBUG_BUFFERS_r(Perl_re_printf( \ "rex=0x%"UVxf" offs=0x%"UVxf": \\%"UVuf": set %"IVdf"..%"IVdf"\n", \ PTR2UV(rex), \ PTR2UV(rex->offs), \ @@ -7136,9 +7157,8 @@ NULL ST.cache_mask = 0; - DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, - "%*s whilem: matched %ld out of %d..%d\n", - REPORT_CODE_OFF+depth*2, "", (long)n, min, max) + DEBUG_EXECUTE_r( Perl_re_indentfo( "whilem: matched %ld out of %d..%d\n", + depth, (long)n, min, max) ); /* First just match a string of min A's. */ @@ -7156,9 +7176,8 @@ NULL /* If degenerate A matches "", assume A done. */ if (locinput == cur_curlyx->u.curlyx.lastloc) { - DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, - "%*s whilem: empty match detected, trying continuation...\n", - REPORT_CODE_OFF+depth*2, "") + DEBUG_EXECUTE_r( Perl_re_indentfo( "whilem: empty match detected, trying continuation...\n", + depth) ); goto do_whilem_B_max; } @@ -7224,7 +7243,7 @@ NULL reginfo->poscache_size = size; Newxz(aux->poscache, size, char); } - DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r( Perl_re_printf( "%swhilem: Detected a super-linear match, switching on caching%s...\n", PL_colors[4], PL_colors[5]) ); @@ -7241,9 +7260,8 @@ NULL mask = 1 << (offset % 8); offset /= 8; if (reginfo->info_aux->poscache[offset] & mask) { - DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, - "%*s whilem: (cache) already tried at this position...\n", - REPORT_CODE_OFF+depth*2, "") + DEBUG_EXECUTE_r( Perl_re_indentfo( "whilem: (cache) already tried at this position...\n", + depth) ); sayNO; /* cache records failure */ } @@ -7305,9 +7323,8 @@ NULL case WHILEM_A_max_fail: /* just failed to match A in a maximal match */ REGCP_UNWIND(ST.lastcp); regcppop(rex, &maxopenparen); /* Restore some previous $<digit>s? */ - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, - "%*s whilem: failed, trying continuation...\n", - REPORT_CODE_OFF+depth*2, "") + DEBUG_EXECUTE_r(Perl_re_indentfo( "whilem: failed, trying continuation...\n", + depth) ); do_whilem_B_max: if (cur_curlyx->u.curlyx.count >= REG_INFTY @@ -7349,8 +7366,7 @@ NULL CACHEsayNO; } - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, - "%*s trying longer...\n", REPORT_CODE_OFF+depth*2, "") + DEBUG_EXECUTE_r(Perl_re_indentfo( "trying longer...\n", depth) ); /* Try grabbing another A and see if it helps. */ cur_curlyx->u.curlyx.lastloc = locinput; @@ -7417,9 +7433,8 @@ NULL /* no more branches? */ if (!scan || (OP(scan) != BRANCH && OP(scan) != BRANCHJ)) { DEBUG_EXECUTE_r({ - PerlIO_printf( Perl_debug_log, - "%*s %sBRANCH failed...%s\n", - REPORT_CODE_OFF+depth*2, "", + Perl_re_indentfo( "%sBRANCH failed...%s\n", + depth, PL_colors[4], PL_colors[5] ); }); @@ -7490,10 +7505,8 @@ NULL ST.count = ST.minmod ? ARG1(ST.me) : ARG2(ST.me); } DEBUG_EXECUTE_r( - PerlIO_printf(Perl_debug_log, - "%*s CURLYM now matched %"IVdf" times, len=%"IVdf"...\n", - (int)(REPORT_CODE_OFF+(depth*2)), "", - (IV) ST.count, (IV)ST.alen) + Perl_re_indentfo( "CURLYM now matched %"IVdf" times, len=%"IVdf"...\n", + depth, (IV) ST.count, (IV)ST.alen) ); if (EVAL_CLOSE_PAREN_IS(cur_eval,(U32)ST.me->flags)) @@ -7545,10 +7558,8 @@ NULL } DEBUG_EXECUTE_r( - PerlIO_printf(Perl_debug_log, - "%*s CURLYM trying tail with matches=%"IVdf"...\n", - (int)(REPORT_CODE_OFF+(depth*2)), - "", (IV)ST.count) + Perl_re_indentfo( "CURLYM trying tail with matches=%"IVdf"...\n", + depth, (IV)ST.count) ); if (! NEXTCHR_IS_EOS && ST.c1 != CHRTEST_VOID) { if (! UTF8_IS_INVARIANT(nextchr) && utf8_target) { @@ -7557,9 +7568,8 @@ NULL { /* simulate B failing */ DEBUG_OPTIMISE_r( - PerlIO_printf(Perl_debug_log, - "%*s CURLYM Fast bail next target=0x%"UVXf" c1=0x%"UVXf" c2=0x%"UVXf"\n", - (int)(REPORT_CODE_OFF+(depth*2)),"", + Perl_re_indentfo( "CURLYM Fast bail next target=0x%"UVXf" c1=0x%"UVXf" c2=0x%"UVXf"\n", + depth, valid_utf8_to_uvchr((U8 *) locinput, NULL), valid_utf8_to_uvchr(ST.c1_utf8, NULL), valid_utf8_to_uvchr(ST.c2_utf8, NULL)) @@ -7571,9 +7581,8 @@ NULL else if (nextchr != ST.c1 && nextchr != ST.c2) { /* simulate B failing */ DEBUG_OPTIMISE_r( - PerlIO_printf(Perl_debug_log, - "%*s CURLYM Fast bail next target=0x%X c1=0x%X c2=0x%X\n", - (int)(REPORT_CODE_OFF+(depth*2)),"", + Perl_re_indentfo( "CURLYM Fast bail next target=0x%X c1=0x%X c2=0x%X\n", + depth, (int) nextchr, ST.c1, ST.c2) ); state_num = CURLYM_B_fail; @@ -7962,8 +7971,8 @@ NULL st->u.eval.prev_eval = cur_eval; cur_eval = cur_eval->u.eval.prev_eval; DEBUG_EXECUTE_r( - PerlIO_printf(Perl_debug_log, "%*s EVAL trying tail ... %"UVxf"\n", - REPORT_CODE_OFF+depth*2, "",PTR2UV(cur_eval));); + Perl_re_indentfo( " EVAL trying tail ... %"UVxf"\n", + depth,PTR2UV(cur_eval));); if ( nochange_depth ) nochange_depth--; @@ -7972,8 +7981,8 @@ NULL } if (locinput < reginfo->till) { - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, - "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n", + DEBUG_EXECUTE_r(Perl_re_printf( + "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n", PL_colors[4], (long)(locinput - startpos), (long)(reginfo->till - startpos), @@ -7985,9 +7994,8 @@ NULL case SUCCEED: /* successful SUSPEND/UNLESSM/IFMATCH/CURLYM */ DEBUG_EXECUTE_r( - PerlIO_printf(Perl_debug_log, - "%*s %ssubpattern success...%s\n", - REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])); + Perl_re_indentfo( "%ssubpattern success...%s\n", + depth, PL_colors[4], PL_colors[5])); sayYES; /* Success! */ #undef ST @@ -8121,9 +8129,8 @@ NULL sv_commit = ST.mark_name; DEBUG_EXECUTE_r({ - PerlIO_printf(Perl_debug_log, - "%*s %ssetting cutpoint to mark:%"SVf"...%s\n", - REPORT_CODE_OFF+depth*2, "", + Perl_re_indentfo( "%ssetting cutpoint to mark:%"SVf"...%s\n", + depth, PL_colors[4], SVfARG(sv_commit), PL_colors[5]); }); } @@ -8227,13 +8234,13 @@ NULL regmatch_state *curyes = yes_state; int curd = depth; regmatch_slab *slab = PL_regmatch_slab; - for (;curd > -1;cur--,curd--) { + for (;curd > -1 && (depth-curd < 3);cur--,curd--) { if (cur < SLAB_FIRST(slab)) { slab = slab->prev; cur = SLAB_LAST(slab); } - PerlIO_printf(Perl_error_log, "%*s#%-3d %-10s %s\n", - REPORT_CODE_OFF + 2 + depth * 2,"", + Perl_re_indentfo("#%-3d %-10s %s\n", + depth, curd, PL_reg_name[cur->resume_state], (curyes == cur) ? "yes" : "" ); @@ -8306,7 +8313,7 @@ NULL goto reenter_switch; } - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n", + DEBUG_EXECUTE_r(Perl_re_printf( "%sMatch successful!%s\n", PL_colors[4], PL_colors[5])); if (reginfo->info_aux_eval) { @@ -8327,9 +8334,8 @@ NULL no: DEBUG_EXECUTE_r( - PerlIO_printf(Perl_debug_log, - "%*s %sfailed...%s\n", - REPORT_CODE_OFF+depth*2, "", + Perl_re_indentfo( "%sfailed...%s\n", + depth, PL_colors[4], PL_colors[5]) ); @@ -8915,9 +8921,8 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, DEBUG_EXECUTE_r({ SV * const prop = sv_newmortal(); regprop(prog, prop, p, reginfo, NULL); - PerlIO_printf(Perl_debug_log, - "%*s %s can match %"IVdf" times out of %"IVdf"...\n", - REPORT_CODE_OFF + depth*2, "", SvPVX_const(prop),(IV)c,(IV)max); + Perl_re_indentfo( "%s can match %"IVdf" times out of %"IVdf"...\n", + depth, SvPVX_const(prop),(IV)c,(IV)max); }); }); |