This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Updated escaping code. utf8 regex debug output improvements
authorYves Orton <demerphq@gmail.com>
Sat, 15 Jul 2006 18:56:03 +0000 (20:56 +0200)
committerDave Mitchell <davem@fdisolutions.com>
Sat, 15 Jul 2006 21:59:43 +0000 (21:59 +0000)
Message-Id:  <9b18b3110607150956o6273a16clb1518911d1945d4@mail.gmail.com>

p4raw-id: //depot/perl@28582

dump.c
embed.fnc
ext/re/re.pm
perl.h
regcomp.c
regcomp.h
regexec.c

diff --git a/dump.c b/dump.c
index 98405c6..f9cd28d 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -121,92 +121,179 @@ Perl_dump_eval(pTHX)
 
 
 /*
-=for apidoc Apd|char*|pv_escape|NN SV *dsv|NN const char *pv|const STRLEN count|const STRLEN max|const U32 flags
+=for apidoc Apd|char*|pv_escape|NN SV *dsv|NN const U8 const *str\
+               |const STRLEN count|const STRLEN max
+               |STRLEN const *escaped, const U32 flags
 
 Escapes at most the first "count" chars of pv and puts the results into
-buf such that the size of the escaped string will not exceed "max" chars
+dsv such that the size of the escaped string will not exceed "max" chars
 and will not contain any incomplete escape sequences.
 
-If flags contains PERL_PV_ESCAPE_QUOTE then the string will have quotes
-placed around it; moreover, if the number of chars converted was less than
-"count" then a trailing elipses (...) will be added after the closing
-quote.
-
-If PERL_PV_ESCAPE_QUOTE is not set, but PERL_PV_ESCAPE_PADR is, then the
-returned string will be right padded with spaces such that it is max chars
-long.
+If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
+will also be escaped.
 
 Normally the SV will be cleared before the escaped string is prepared,
-but when PERL_PV_ESCAPE_CAT is set this will not occur.
+but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
+
+If PERL_PV_ESCAPE_UNI is set then the input string is treated as unicode,
+if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
+using C<is_utf8_string()> to determine if it is unicode.
+
+If PERL_PV_ESCAPE_ALL is set then all input chars will be output
+using C<\x01F1> style escapes, otherwise only chars above 255 will be
+escaped using this style, other non printable chars will use octal or
+common escaped patterns like C<\n>. If PERL_PV_ESCAPE_NOBACKSLASH
+then all chars below 255 will be treated as printable and 
+will be output as literals.
 
-Returns a pointer to the string contained by SV.
+If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
+string will be escaped, regardles of max. If the string is utf8 and 
+the chars value is >255 then it will be returned as a plain hex 
+sequence. Thus the output will either be a single char, 
+an octal escape sequence, a special escape like C<\n> or a 3 or 
+more digit hex value. 
+
+Returns a pointer to the escaped text as held by dsv.
 
 =cut
 */
-
+#define PV_ESCAPE_OCTBUFSIZE 32
 char *
-Perl_pv_escape( pTHX_ SV *dsv, const char *pv, const STRLEN count, const STRLEN max, const U32 flags ) {
-    char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : '\\';
-    char octbuf[8] = "\\0123456";
-    STRLEN wrote = 0;
-    STRLEN chsize = 0;
-    const char *end = pv + count;
-
-    if (flags & PERL_PV_ESCAPE_CAT) {
-       if ( dq == '"' )
-           sv_catpvn(dsv, "\"", 1);
-    } else {
-       if ( dq == '"' )
-           sv_setpvn(dsv, "\"", 1);
-       else
+Perl_pv_escape( pTHX_ SV *dsv, U8 const * const str, 
+                const STRLEN count, const STRLEN max, 
+                STRLEN * const escaped, const U32 flags ) 
+{
+    U8 dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : '\\';
+    U8 octbuf[PV_ESCAPE_OCTBUFSIZE] = "\\123456789ABCDF";
+    STRLEN wrote = 0;    /* chars written so far */
+    STRLEN chsize = 0;   /* size of data to be written */
+    STRLEN readsize = 1; /* size of data just read */
+    bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this unicode */
+    const U8 *pv  = str;
+    const U8 *end = pv + count; /* end of string */
+
+    if (!flags & PERL_PV_ESCAPE_NOCLEAR) 
            sv_setpvn(dsv, "", 0);
-    }
-    for ( ; (pv < end && (!max || (wrote < max))) ; pv++ ) {
-       if ( (*pv == dq) || (*pv == '\\') || isCNTRL(*pv) ) {
+    
+    if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string(pv, count))
+        isuni = 1;
+    
+    for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
+        const UV u= (isuni) ? utf8_to_uvchr(pv, &readsize) : *pv;            
+        const U8 c = (U8)u & 0xFF;
+        
+        if ( ( u > 255 ) || (flags & PERL_PV_ESCAPE_ALL)) {
+            if (flags & PERL_PV_ESCAPE_FIRSTCHAR) 
+                chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, 
+                                      "%"UVxf, u);
+            else
+                chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, 
+                                      "\\x{%"UVxf"}", u);
+        } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
+            chsize = 1;            
+        } else {         
+            if ( (c == dq) || (c == '\\') || !isPRINT(c) ) {
            chsize = 2;
-           switch (*pv) {
+                switch (c) {
                case '\\' : octbuf[1] = '\\'; break;
                case '\v' : octbuf[1] = 'v';  break;
                case '\t' : octbuf[1] = 't';  break;
                case '\r' : octbuf[1] = 'r';  break;
                case '\n' : octbuf[1] = 'n';  break;
                case '\f' : octbuf[1] = 'f';  break;
-               case '"'  : if ( dq == *pv ) {
+                    case '"'  : 
+                        if ( dq == '"' ) 
                                octbuf[1] = '"';
+                        else 
+                            chsize = 1;
                                break;
-                           }
                default:
-                           /* note the (U8*) casts here are important.
-                            * if they are omitted we can produce the octal
-                            * for a negative number which could produce a
-                            * buffer overrun in octbuf, with it on we are
-                            * guaranteed that the longest the string could be
-                            * is 5, (we reserve 8 just because its the first
-                            * power of 2 larger than 5.)*/
-                           if ( (pv < end) && isDIGIT(*(pv+1)) )
-                               chsize = sprintf( octbuf, "\\%03o", (U8)*pv);
+                        if ( (pv < end) && isDIGIT(*(pv+readsize)) )
+                            chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, 
+                                                  "\\%03o", c);
                            else
-                               chsize = sprintf( octbuf, "\\%o", (U8)*pv);
+                            chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, 
+                                                  "\\%o", c);
+                }
+            } else {
+                chsize=1;
+            }
            }
            if ( max && (wrote + chsize > max) ) {
                break;
-           } else {
+        } else if (chsize > 1) {
                sv_catpvn(dsv, octbuf, chsize);
                wrote += chsize;
-           }
        } else {
-           sv_catpvn(dsv, pv, 1);
+            Perl_sv_catpvf( aTHX_ dsv, "%c", c);
            wrote++;
        }
+        if ( flags & PERL_PV_ESCAPE_FIRSTCHAR ) 
+            break;
     }
-    if ( dq == '"' ) {
+    if (escaped != NULL)
+        *escaped= pv - str;
+    return SvPVX(dsv);
+}
+/*
+=for apidoc Apd|char *|pv_pretty|NN SV *dsv|NN const U8 const *str\
+           |const STRLEN count|const STRLEN max\
+           |const U8 const *start_color| const U8 const *end_color\
+           |const U32 flags
+
+Converts a string into something presentable, handling escaping via
+pv_escape() and supporting quoting and elipses. 
+
+If the PERL_PV_PRETTY_QUOTE flag is set then the result will be 
+double quoted with any double quotes in the string escaped. Otherwise
+if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
+angle brackets. 
+           
+If the PERL_PV_PRETTY_ELIPSES flag is set and not all characters in
+string were output then an elipses C<...> will be appended to the 
+string. Note that this happens AFTER it has been quoted.
+           
+If start_color is non-null then it will be inserted after the opening
+quote (if there is one) but before the escaped text. If end_color
+is non-null then it will be inserted after the escaped text but before
+any quotes or elipses.
+
+Returns a pointer to the prettified text as held by dsv.
+           
+=cut           
+*/
+
+char *
+Perl_pv_pretty( pTHX_ SV *dsv, U8 const * const str, const STRLEN count, 
+  const STRLEN max, U8 const * const start_color, U8 const * const end_color, 
+  const U32 flags ) 
+{
+    U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '\\';
+    STRLEN escaped;
+    
+    if ( dq == '"' )
+        sv_setpvn(dsv, "\"", 1);
+    else if ( flags & PERL_PV_PRETTY_LTGT )
+        sv_setpvn(dsv, "<", 1);
+    else 
+        sv_setpvn(dsv, "", 0);
+        
+    if ( start_color != NULL ) 
+        Perl_sv_catpvf( aTHX_ dsv, "%s", start_color);
+    
+    pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );    
+    
+    if ( end_color != NULL ) 
+        Perl_sv_catpvf( aTHX_ dsv, "%s", end_color);
+
+    if ( dq == '"' ) 
        sv_catpvn( dsv, "\"", 1 );
-       if ( pv < end )
+    else if ( flags & PERL_PV_PRETTY_LTGT )
+        sv_catpvn( dsv, ">", 1);         
+    
+    if ( (flags & PERL_PV_PRETTY_ELIPSES) && ( escaped < count ) )
            sv_catpvn( dsv, "...", 3 );
-    } else if ( max && (flags & PERL_PV_ESCAPE_PADR) ) {
-       for ( ; wrote < max ; wrote++ )
-           sv_catpvn( dsv, " ", 1 );
-    }
     return SvPVX(dsv);
 }
 
@@ -231,7 +318,7 @@ Note that the final string may be up to 7 chars longer than pvlim.
 char *
 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
 {
-    pv_escape( dsv, pv, cur, pvlim, PERL_PV_ESCAPE_QUOTE);
+    pv_pretty( dsv, pv, cur, pvlim, 0, 0, PERL_PV_PRETTY_DUMP);
     if (len > cur && pv[cur] == '\0')
             sv_catpvn( dsv, "\\0", 2 );
     return SvPVX(dsv);
index bfd7dce..f57cf92 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -982,8 +982,15 @@ Apdbm      |void   |sv_usepvn_mg   |NN SV *sv|NULLOK char *ptr|STRLEN len
 ApR    |MGVTBL*|get_vtbl       |int vtbl_id
 Apd    |char*  |pv_display     |NN SV *dsv|NN const char *pv|STRLEN cur|STRLEN len \
                                |STRLEN pvlim
-Apd    |char*  |pv_escape      |NN SV *dsv|NN const char *pv|const STRLEN count \
-                               |const STRLEN max|const U32 flags
+Apd    |char*  |pv_escape      |NN SV *dsv|NN U8 const * const str\
+                                |const STRLEN count|const STRLEN max\
+                                |NULLOK STRLEN * const escaped\
+                                |const U32 flags                               
+Apd     |char*  |pv_pretty      |NN SV *dsv|NN U8 const * const str\
+                                |const STRLEN count|const STRLEN max\
+                                |NULLOK U8 const * const start_color\
+                                |NULLOK U8 const * const end_color\
+                                |const U32 flags                               
 Afp    |void   |dump_indent    |I32 level|NN PerlIO *file|NN const char* pat|...
 Ap     |void   |dump_vindent   |I32 level|NN PerlIO *file|NN const char* pat \
                                |NULLOK va_list *args
@@ -1354,6 +1361,7 @@ Es        |void   |to_utf8_substr |NN regexp * prog
 Es     |void   |to_byte_substr |NN regexp * prog
 #  ifdef DEBUGGING
 Es     |void   |dump_exec_pos  |NN const char *locinput|NN const regnode *scan|const bool do_utf8
+Es     |void   |debug_start_match|NN const regexp *prog|const bool do_utf8|NN const char *start|NN const char *end|NN const char *blurb
 #  endif
 #endif
 
index 08abfa1..51545ac 100644 (file)
@@ -233,6 +233,7 @@ my %flags = (
     EXTRA           => 0xFF0000,
     TRIE_MORE       => 0x010000,
     OFFSETS_DEBUG   => 0x020000,
+    STATE           => 0x040000,
 );
 $flags{ALL} = $flags{COMPILE} | $flags{EXECUTE};
 $flags{All} = $flags{all} = $flags{DUMP} | $flags{EXECUTE};
diff --git a/perl.h b/perl.h
index e4c8755..949fb51 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -5646,12 +5646,32 @@ extern void moncontrol(int);
 
    so that Configure picks them up. */
 
-/* these are used by Perl_pv_escape() and are here so that they
- * are available throughout the core */
+/* These are used by Perl_pv_escape() and Perl_pv_pretty() 
+ * are here so that they are available throughout the core 
+ * NOTE that even though some are for _escape and some for _pretty
+ * there must not be any clashes as the flags from _pretty are
+ * passed straight through to _escape.
+ */
+
+#define PERL_PV_ESCAPE_QUOTE        0x0001
+#define PERL_PV_PRETTY_QUOTE        PERL_PV_ESCAPE_QUOTE
+
+
+#define PERL_PV_PRETTY_ELIPSES      0x0002
+#define PERL_PV_PRETTY_LTGT         0x0004
+
+#define PERL_PV_ESCAPE_FIRSTCHAR    0x0008
+
+#define PERL_PV_ESCAPE_UNI          0x0100     
+#define PERL_PV_ESCAPE_UNI_DETECT   0x0200
+
+#define PERL_PV_ESCAPE_ALL         0x1000
+#define PERL_PV_ESCAPE_NOBACKSLASH  0x2000
+#define PERL_PV_ESCAPE_NOCLEAR      0x4000
 
-#define PERL_PV_ESCAPE_QUOTE  1
-#define PERL_PV_ESCAPE_PADR   2
-#define PERL_PV_ESCAPE_CAT    4
+/* used by pv_display in dump.c*/
+#define PERL_PV_PRETTY_DUMP  PERL_PV_PRETTY_ELIPSES|PERL_PV_PRETTY_QUOTE
+#define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELIPSES|PERL_PV_PRETTY_LTGT
 
 #endif /* Include guard */
 
index 10c6682..0842448 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -754,6 +754,7 @@ is the recommended Unicode-aware way of saying
 #define TRIE_STORE_REVCHAR                                                    \
     STMT_START {                                                           \
        SV *tmp = Perl_newSVpvf_nocontext( "%c", (int)uvc );               \
+       if (UTF) SvUTF8_on(tmp);                                           \
        av_push( TRIE_REVCHARMAP(trie), tmp );                             \
     } STMT_END
 
@@ -852,8 +853,11 @@ STATIC void
 S_dump_trie(pTHX_ const struct _reg_trie_data *trie,U32 depth)
 {
     U32 state;
+    SV *sv=sv_newmortal();
+    int colwidth= trie->widecharmap ? 6 : 4;
     GET_RE_DEBUG_FLAGS_DECL;
 
+
     PerlIO_printf( Perl_debug_log, "%*sChar : %-6s%-6s%-4s ",
         (int)depth * 2 + 2,"",
         "Match","Base","Ofs" );
@@ -861,14 +865,21 @@ S_dump_trie(pTHX_ const struct _reg_trie_data *trie,U32 depth)
     for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
        SV ** const tmp = av_fetch( trie->revcharmap, state, 0);
         if ( tmp ) {
-          PerlIO_printf( Perl_debug_log, "%4.4s ", SvPV_nolen_const( *tmp ) );
+            PerlIO_printf( Perl_debug_log, "%*s", 
+                colwidth,
+                pv_pretty(sv, (U8*)SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
+                           PL_colors[0], PL_colors[1],
+                           (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
+                           PERL_PV_ESCAPE_FIRSTCHAR 
+                ) 
+            );
         }
     }
     PerlIO_printf( Perl_debug_log, "\n%*sState|-----------------------",
         (int)depth * 2 + 2,"");
 
     for( state = 0 ; state < trie->uniquecharcount ; state++ )
-        PerlIO_printf( Perl_debug_log, "-----");
+        PerlIO_printf( Perl_debug_log, "%.*s", colwidth, "--------");
     PerlIO_printf( Perl_debug_log, "\n");
 
     for( state = 1 ; state < TRIE_LASTSTATE(trie) ; state++ ) {
@@ -899,10 +910,11 @@ S_dump_trie(pTHX_ const struct _reg_trie_data *trie,U32 depth)
                      ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
                      trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
                 {
-                   PerlIO_printf( Perl_debug_log, "%4"UVXf" ",
+                   PerlIO_printf( Perl_debug_log, "%*"UVXf,
+                    colwidth,
                     (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next );
                 } else {
-                    PerlIO_printf( Perl_debug_log, "%4s ","   ." );
+                    PerlIO_printf( Perl_debug_log, "%*s",colwidth,"   ." );
                 }
             }
 
@@ -923,16 +935,18 @@ STATIC void
 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie, U32 next_alloc,U32 depth)
 {
     U32 state;
+    SV *sv=sv_newmortal();
+    int colwidth= trie->widecharmap ? 6 : 4;
     GET_RE_DEBUG_FLAGS_DECL;
     /* print out the table precompression.  */
-    PerlIO_printf( Perl_debug_log, "%*sState :Word | Transition Data\n%*s",
-        (int)depth * 2 + 2,"", (int)depth * 2 + 2,"");
-    PerlIO_printf( Perl_debug_log,   "------:-----+-----------------" );
+    PerlIO_printf( Perl_debug_log, "%*sState :Word | Transition Data\n%*s%s",
+        (int)depth * 2 + 2,"", (int)depth * 2 + 2,"",
+        "------:-----+-----------------\n" );
     
     for( state=1 ; state < next_alloc ; state ++ ) {
         U16 charid;
     
-        PerlIO_printf( Perl_debug_log, "\n%*s %4"UVXf" :",
+        PerlIO_printf( Perl_debug_log, "%*s %4"UVXf" :",
             (int)depth * 2 + 2,"", (UV)state  );
         if ( ! trie->states[ state ].wordnum ) {
             PerlIO_printf( Perl_debug_log, "%5s| ","");
@@ -943,13 +957,20 @@ S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie, U32 next_alloc
         }
         for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
            SV ** const tmp = av_fetch( trie->revcharmap, TRIE_LIST_ITEM(state,charid).forid, 0);
-            PerlIO_printf( Perl_debug_log, "%s:%3X=%4"UVXf" | ",
-                SvPV_nolen_const( *tmp ),
+           if ( tmp ) {
+                PerlIO_printf( Perl_debug_log, "%*s:%3X=%4"UVXf" | ",
+                    colwidth,
+                    pv_pretty(sv, (U8*)SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
+                           PL_colors[0], PL_colors[1],
+                           (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
+                           PERL_PV_ESCAPE_FIRSTCHAR 
+                    ) ,
                 TRIE_LIST_ITEM(state,charid).forid,
                 (UV)TRIE_LIST_ITEM(state,charid).newstate
             );
         }
-    
+        }
+        PerlIO_printf( Perl_debug_log, "\n");
     }
 }    
 
@@ -965,6 +986,8 @@ S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie, U32 next_allo
 {
     U32 state;
     U16 charid;
+    SV *sv=sv_newmortal();
+    int colwidth= trie->widecharmap ? 6 : 4;
     GET_RE_DEBUG_FLAGS_DECL;
     
     /*
@@ -977,14 +1000,21 @@ S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie, U32 next_allo
     for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
        SV ** const tmp = av_fetch( trie->revcharmap, charid, 0);
         if ( tmp ) {
-          PerlIO_printf( Perl_debug_log, "%4.4s ", SvPV_nolen_const( *tmp ) );
+            PerlIO_printf( Perl_debug_log, "%*s", 
+                colwidth,
+                pv_pretty(sv, (U8*)SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
+                           PL_colors[0], PL_colors[1],
+                           (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
+                           PERL_PV_ESCAPE_FIRSTCHAR 
+                ) 
+            );
         }
     }
 
     PerlIO_printf( Perl_debug_log, "\n%*sState+-",(int)depth * 2 + 2,"" );
 
     for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
-        PerlIO_printf( Perl_debug_log, "%4s-", "----" );
+        PerlIO_printf( Perl_debug_log, "%.*s", colwidth,"--------");
     }
 
     PerlIO_printf( Perl_debug_log, "\n" );
@@ -996,8 +1026,11 @@ S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie, U32 next_allo
             (UV)TRIE_NODENUM( state ) );
 
         for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
-            PerlIO_printf( Perl_debug_log, "%4"UVXf" ",
-                (UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next ) );
+            UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
+            if (v)
+                PerlIO_printf( Perl_debug_log, "%*"UVXf, colwidth, v );
+            else
+                PerlIO_printf( Perl_debug_log, "%*s", colwidth, "." );
         }
         if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
             PerlIO_printf( Perl_debug_log, " (%4"UVXf")\n", (UV)trie->trans[ state ].check );
@@ -3231,9 +3264,11 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
     RExC_precomp = exp;
     DEBUG_r(if (!PL_colorset) reginitcolors());
     DEBUG_COMPILE_r({
-        PerlIO_printf(Perl_debug_log, "%sCompiling REx%s \"%s%*s%s\"\n",
-                      PL_colors[4],PL_colors[5],PL_colors[0],
-                      (int)(xend - exp), RExC_precomp, PL_colors[1]);
+        SV *dsv= sv_newmortal();
+        RE_PV_QUOTED_DECL(s, RExC_utf8,
+            dsv, RExC_precomp, (xend - exp), 60);
+        PerlIO_printf(Perl_debug_log, "%sCompiling REx%s %s\n",
+                      PL_colors[4],PL_colors[5],s);
     });
     RExC_flags = pm->op_pmflags;
     RExC_sawback = 0;
@@ -6314,46 +6349,41 @@ Perl_regdump(pTHX_ const regexp *r)
 #ifdef DEBUGGING
     dVAR;
     SV * const sv = sv_newmortal();
+    SV *dsv= sv_newmortal();
 
     (void)dumpuntil(r, r->program, r->program + 1, NULL, sv, 0);
 
     /* Header fields of interest. */
-    if (r->anchored_substr)
+    if (r->anchored_substr) {
+       RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr), 
+           RE_SV_DUMPLEN(r->anchored_substr), 30);
        PerlIO_printf(Perl_debug_log,
-                     "anchored \"%s%.*s%s\"%s at %"IVdf" ",
-                     PL_colors[0],
-                     (int)(SvCUR(r->anchored_substr) - (SvTAIL(r->anchored_substr)!=0)),
-                     SvPVX_const(r->anchored_substr),
-                     PL_colors[1],
-                     SvTAIL(r->anchored_substr) ? "$" : "",
+                     "anchored %s%s at %"IVdf" ",
+                     s, RE_SV_TAIL(r->anchored_substr),
                      (IV)r->anchored_offset);
-    else if (r->anchored_utf8)
+    } else if (r->anchored_utf8) {
+       RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8), 
+           RE_SV_DUMPLEN(r->anchored_utf8), 30);
        PerlIO_printf(Perl_debug_log,
-                     "anchored utf8 \"%s%.*s%s\"%s at %"IVdf" ",
-                     PL_colors[0],
-                     (int)(SvCUR(r->anchored_utf8) - (SvTAIL(r->anchored_utf8)!=0)),
-                     SvPVX_const(r->anchored_utf8),
-                     PL_colors[1],
-                     SvTAIL(r->anchored_utf8) ? "$" : "",
+                     "anchored utf8 %s%s at %"IVdf" ",
+                     s, RE_SV_TAIL(r->anchored_utf8),
                      (IV)r->anchored_offset);
-    if (r->float_substr)
+    }                
+    if (r->float_substr) {
+       RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr), 
+           RE_SV_DUMPLEN(r->float_substr), 30);
        PerlIO_printf(Perl_debug_log,
-                     "floating \"%s%.*s%s\"%s at %"IVdf"..%"UVuf" ",
-                     PL_colors[0],
-                     (int)(SvCUR(r->float_substr) - (SvTAIL(r->float_substr)!=0)),
-                     SvPVX_const(r->float_substr),
-                     PL_colors[1],
-                     SvTAIL(r->float_substr) ? "$" : "",
+                     "floating %s%s at %"IVdf"..%"UVuf" ",
+                     s, RE_SV_TAIL(r->float_substr),
                      (IV)r->float_min_offset, (UV)r->float_max_offset);
-    else if (r->float_utf8)
+    } else if (r->float_utf8) {
+       RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8), 
+           RE_SV_DUMPLEN(r->float_utf8), 30);
        PerlIO_printf(Perl_debug_log,
-                     "floating utf8 \"%s%.*s%s\"%s at %"IVdf"..%"UVuf" ",
-                     PL_colors[0],
-                     (int)(SvCUR(r->float_utf8) - (SvTAIL(r->float_utf8)!=0)),
-                     SvPVX_const(r->float_utf8),
-                     PL_colors[1],
-                     SvTAIL(r->float_utf8) ? "$" : "",
+                     "floating utf8 %s%s at %"IVdf"..%"UVuf" ",
+                     s, RE_SV_TAIL(r->float_utf8),
                      (IV)r->float_min_offset, (UV)r->float_max_offset);
+    }
     if (r->check_substr || r->check_utf8)
        PerlIO_printf(Perl_debug_log,
                      r->check_substr == r->float_substr
@@ -6419,16 +6449,18 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o)
 
     if (k == EXACT) {
        SV * const dsv = sv_2mortal(newSVpvs(""));
-       /* Using is_utf8_string() is a crude hack but it may
-        * be the best for now since we have no flag "this EXACTish
-        * node was UTF-8" --jhi */
-       const bool do_utf8 = is_utf8_string((U8*)STRING(o), STR_LEN(o));
-       RE_PV_DISPLAY_DECL(s, len, do_utf8, dsv, STRING(o), STR_LEN(o), 60);
-
-       Perl_sv_catpvf(aTHX_ sv, " <%s%.*s%s>",
-                      PL_colors[0],
-                      len, s,
-                      PL_colors[1]);
+       /* Using is_utf8_string() (via PERL_PV_UNI_DETECT) 
+        * is a crude hack but it may be the best for now since 
+        * we have no flag "this EXACTish node was UTF-8" 
+        * --jhi */
+       const char * const s = 
+           pv_pretty(dsv, (U8*)STRING(o), STR_LEN(o), 60, 
+               PL_colors[0], PL_colors[1],
+               PERL_PV_ESCAPE_UNI_DETECT |
+               PERL_PV_PRETTY_ELIPSES    |
+               PERL_PV_PRETTY_LTGT    
+            ); 
+       Perl_sv_catpvf(aTHX_ sv, " %s", s );
     } else if (k == TRIE) {
         Perl_sv_catpvf(aTHX_ sv, "-%s",reg_name[o->flags]);
        /* print the details of the trie in dumpuntil instead, as
@@ -6630,18 +6662,16 @@ Perl_pregfree(pTHX_ struct regexp *r)
 
     if (!r || (--r->refcnt > 0))
        return;
-    DEBUG_COMPILE_r(if (RX_DEBUG(r)){
-       RE_PV_DISPLAY_DECL(s, len, (r->reganch & ROPT_UTF8),
-           PERL_DEBUG_PAD_ZERO(0), r->precomp, r->prelen, 60);
-
+    DEBUG_COMPILE_r({
        if (!PL_colorset)
            reginitcolors();
-       PerlIO_printf(Perl_debug_log,
-           "%sFreeing REx:%s %s%*.*s%s%s\n",
-           PL_colors[4],PL_colors[5],PL_colors[0],
-           len, len, s,
-           PL_colors[1],
-           len > 60 ? "..." : "");
+       if (RX_DEBUG(r)){
+            SV *dsv= sv_newmortal();
+            RE_PV_QUOTED_DECL(s, (r->reganch & ROPT_UTF8),
+                dsv, r->precomp, r->prelen, 60);
+            PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n", 
+                PL_colors[4],PL_colors[5],s);
+        }
     });
 
     /* gcov results gave these as non-null 100% of the time, so there's no
@@ -6996,15 +7026,17 @@ S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
 
            for (word_idx=0; word_idx < arry_len; word_idx++) {
                SV ** const elem_ptr = av_fetch(trie->words,word_idx,0);
-               if (elem_ptr) {
-                   PerlIO_printf(Perl_debug_log, "%*s<%s%s%s>\n",
+               if (elem_ptr) 
+                   PerlIO_printf(Perl_debug_log, "%*s%s\n",
                       (int)(2*(l+4)), "",
-                      PL_colors[0],
-                      SvPV_nolen_const(*elem_ptr),
-                      PL_colors[1]
+                       pv_pretty(sv, (U8*)SvPV_nolen_const(*elem_ptr), SvCUR(*elem_ptr), 60, 
+                           PL_colors[0], PL_colors[1],
+                           (SvUTF8(*elem_ptr) ? PERL_PV_ESCAPE_UNI : 0) |
+                           PERL_PV_PRETTY_ELIPSES    |
+                           PERL_PV_PRETTY_LTGT    
+                        )
                    );
                }
-           }
 
            node = NEXTOPER(node);
            node += regarglen[(U8)op];
index 535897f..e46f6f4 100644 (file)
--- a/regcomp.h
+++ b/regcomp.h
@@ -567,6 +567,7 @@ re.pm, especially to the documentation.
 #define RE_DEBUG_EXTRA_MASK        0xFF0000
 #define RE_DEBUG_EXTRA_TRIE        0x010000
 #define RE_DEBUG_EXTRA_OFFSETS     0x020000
+#define RE_DEBUG_EXTRA_STATE       0x040000
 
 #define RE_DEBUG_FLAG(x) (re_debug_flags & x)
 /* Compile */
@@ -598,6 +599,8 @@ re.pm, especially to the documentation.
 /* Extra */
 #define DEBUG_EXTRA_r(x) DEBUG_r( \
     if (re_debug_flags & RE_DEBUG_EXTRA_MASK) x  )
+#define DEBUG_STATE_r(x) DEBUG_r( \
+    if (re_debug_flags & RE_DEBUG_EXTRA_STATE) x )
 #define MJD_OFFSET_DEBUG(x) DEBUG_r( \
     if (re_debug_flags & RE_DEBUG_EXTRA_OFFSETS) \
         Perl_warn_nocontext x )
@@ -623,14 +626,41 @@ re.pm, especially to the documentation.
 })
 
 #ifdef DEBUGGING
+
 #define GET_RE_DEBUG_FLAGS_DECL IV re_debug_flags = 0; GET_RE_DEBUG_FLAGS;
-#define RE_PV_DISPLAY_DECL(rpv,rlen,isuni,dsv,pv,l,m) \
-    const char * const rpv = (isuni) ?  \
-           pv_uni_display(dsv, (U8*)(pv), l, m, UNI_DISPLAY_REGEX) : \
-           pv_escape(dsv, pv, l, m, 0); \
+
+#define RE_PV_COLOR_DECL(rpv,rlen,isuni,dsv,pv,l,m,c1,c2) \
+    const char * const rpv =                          \
+        pv_pretty((dsv), (U8*)(pv), (l), (m), \
+            PL_colors[(c1)],PL_colors[(c2)], \
+            ((isuni) ? PERL_PV_ESCAPE_UNI : 0) );         \
     const int rlen = SvCUR(dsv)
-#else
+
+#define RE_SV_ESCAPE(rpv,isuni,dsv,sv,m) \
+    const char * const rpv =                          \
+        pv_pretty((dsv), (U8*)(SvPV_nolen_const(sv)), (SvCUR(sv)), (m), \
+            PL_colors[(c1)],PL_colors[(c2)], \
+            ((isuni) ? PERL_PV_ESCAPE_UNI : 0) )
+
+#define RE_PV_QUOTED_DECL(rpv,isuni,dsv,pv,l,m)                    \
+    const char * const rpv =                                       \
+        pv_pretty((dsv), (U8*)(pv), (l), (m), \
+            PL_colors[0], PL_colors[1], \
+            ( PERL_PV_PRETTY_QUOTE | PERL_PV_PRETTY_ELIPSES |      \
+              ((isuni) ? PERL_PV_ESCAPE_UNI : 0))                  \
+        )                                                  
+
+#define RE_SV_DUMPLEN(ItEm) (SvCUR(ItEm) - (SvTAIL(ItEm)!=0))
+#define RE_SV_TAIL(ItEm) (SvTAIL(ItEm) ? "$" : "")
+    
+#else /* if not DEBUGGING */
+
 #define GET_RE_DEBUG_FLAGS_DECL
-#define RE_PV_DISPLAY_DECL
-#endif
+#define RE_PV_COLOR_DECL(rpv,rlen,isuni,dsv,pv,l,m,c1,c2)
+#define RE_SV_ESCAPE(rpv,isuni,dsv,sv,m)
+#define RE_PV_QUOTED_DECL(rpv,isuni,dsv,pv,l,m)
+#define RE_SV_DUMPLEN(ItEm)
+#define RE_SV_TAIL(ItEm)
+
+#endif /* DEBUG RELATED DEFINES */
 
index 44f893e..3eee31e 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -78,7 +78,7 @@
 #define RF_tainted     1               /* tainted information used? */
 #define RF_warned      2               /* warned about big count? */
 #define RF_evaled      4               /* Did an EVAL with setting? */
-#define RF_utf8                8               /* String contains multibyte chars? */
+#define RF_utf8                8               /* Pattern contains multibyte chars? */
 
 #define UTF ((PL_reg_flags & RF_utf8) != 0)
 
@@ -195,14 +195,21 @@ S_regcppush(pTHX_ I32 parenfloor)
 }
 
 /* These are needed since we do not localize EVAL nodes: */
-#  define REGCP_SET(cp)  DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,         \
+#define REGCP_SET(cp)                                           \
+    DEBUG_STATE_r(                                              \
+        if (cp != PL_savestack_ix)                             \
+            PerlIO_printf(Perl_debug_log,                      \
                             "  Setting an EVAL scope, savestack=%"IVdf"\n",    \
-                            (IV)PL_savestack_ix)); cp = PL_savestack_ix
+               (IV)PL_savestack_ix));                          \
+    cp = PL_savestack_ix
 
-#  define REGCP_UNWIND(cp)  DEBUG_EXECUTE_r(cp != PL_savestack_ix ?            \
+#define REGCP_UNWIND(cp)                                        \
+    DEBUG_EXECUTE_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) : 0); regcpblow(cp)
+               (IV)(cp), (IV)PL_savestack_ix));                \
+    regcpblow(cp)
 
 STATIC char *
 S_regcppop(pTHX_ const regexp *rex)
@@ -364,32 +371,12 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
     RX_MATCH_UTF8_set(prog,do_utf8);
 
     if (prog->reganch & ROPT_UTF8) {
-       DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
-                             "UTF-8 regex...\n"));
        PL_reg_flags |= RF_utf8;
     }
-
-    DEBUG_EXECUTE_r({
-         RE_PV_DISPLAY_DECL(s, len, PL_reg_match_utf8,
-            PERL_DEBUG_PAD_ZERO(0), strpos, strend - strpos, 60);
-
-        if (!PL_colorset)
-             reginitcolors();
-        if (PL_reg_match_utf8)
-            DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
-                                  "UTF-8 target...\n"));
-        PerlIO_printf(Perl_debug_log,
-                      "%sGuessing start of match, REx%s \"%s%.60s%s%s\" against \"%s%.*s%s%s\"...\n",
-                      PL_colors[4], PL_colors[5], PL_colors[0],
-                      prog->precomp,
-                      PL_colors[1],
-                      (strlen(prog->precomp) > 60 ? "..." : ""),
-                      PL_colors[0],
-                      (int)(len > 60 ? 60 : len),
-                      s, PL_colors[1],
-                      (len > 60 ? "..." : "")
+    DEBUG_EXECUTE_r( 
+        debug_start_match(prog, do_utf8, strpos, strend, 
+            "Guessing start of match for");
              );
-    });
 
     /* CHR_DIST() would be more correct here but it makes things slow. */
     if (prog->minlen > strend - strpos) {
@@ -520,14 +507,17 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
     /* Update the count-of-usability, remove useless subpatterns,
        unshift s.  */
 
-    DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s %s substr \"%s%.*s%s\"%s%s",
+    DEBUG_EXECUTE_r({
+        RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0), 
+            SvPVX_const(check), RE_SV_DUMPLEN(check), 30);
+        PerlIO_printf(Perl_debug_log, "%s %s substr %s%s%s",
                          (s ? "Found" : "Did not find"),
-                         (check == (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) ? "anchored" : "floating"),
-                         PL_colors[0],
-                         (int)(SvCUR(check) - (SvTAIL(check)!=0)),
-                         SvPVX_const(check),
-                         PL_colors[1], (SvTAIL(check) ? "$" : ""),
-                         (s ? " at offset " : "...\n") ) );
+           (check == (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) 
+               ? "anchored" : "floating"),
+           quoted,
+           RE_SV_TAIL(check),
+           (s ? " at offset " : "...\n") ); 
+    });
 
     if (!s)
        goto fail_finish;
@@ -587,14 +577,15 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
                        must,
                        multiline ? FBMrf_MULTILINE : 0
                    );
-               DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
-                       "%s anchored substr \"%s%.*s%s\"%s",
+                DEBUG_EXECUTE_r({
+                    RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0), 
+                        SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
+                    PerlIO_printf(Perl_debug_log, "%s anchored substr %s%s",
                        (s ? "Found" : "Contradicts"),
-                       PL_colors[0],
-                         (int)(SvCUR(must)
-                         - (SvTAIL(must)!=0)),
-                         SvPVX_const(must),
-                         PL_colors[1], (SvTAIL(must) ? "$" : "")));
+                        quoted, RE_SV_TAIL(must));
+                });                
+               
+                           
                if (!s) {
                    if (last1 >= last2) {
                        DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
@@ -647,12 +638,13 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
                              (unsigned char*)last + SvCUR(must)
                                  - (SvTAIL(must)!=0),
                              must, multiline ? FBMrf_MULTILINE : 0);
-           DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s floating substr \"%s%.*s%s\"%s",
+           DEBUG_EXECUTE_r({
+               RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0), 
+                   SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
+               PerlIO_printf(Perl_debug_log, "%s floating substr %s%s",
                    (s ? "Found" : "Contradicts"),
-                   PL_colors[0],
-                     (int)(SvCUR(must) - (SvTAIL(must)!=0)),
-                     SvPVX_const(must),
-                     PL_colors[1], (SvTAIL(must) ? "$" : "")));
+                   quoted, RE_SV_TAIL(must));
+            });
            if (!s) {
                if (last1 == last) {
                    DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
@@ -1603,26 +1595,10 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
        }
     }
 
-    DEBUG_EXECUTE_r({
-        RE_PV_DISPLAY_DECL(s0, len0, UTF,
-            PERL_DEBUG_PAD_ZERO(0), prog->precomp, prog->prelen, 60);
-        RE_PV_DISPLAY_DECL(s1, len1, do_utf8,
-            PERL_DEBUG_PAD_ZERO(1), startpos, strend - startpos, 60);
-
-        if (!PL_colorset)
-            reginitcolors();
-        PerlIO_printf(Perl_debug_log,
-                      "%sMatching REx%s \"%s%*.*s%s%s\" against \"%s%.*s%s%s\"\n",
-                      PL_colors[4], PL_colors[5], PL_colors[0],
-                      len0, len0, s0,
-                      PL_colors[1],
-                      len0 > 60 ? "..." : "",
-                      PL_colors[0],
-                      (int)(len1 > 60 ? 60 : len1),
-                      s1, PL_colors[1],
-                      (len1 > 60 ? "..." : "")
+    DEBUG_EXECUTE_r( 
+        debug_start_match(prog, do_utf8, startpos, strend, 
+            "Matching");
              );
-    });
 
     /* Simplest case:  anchored match need be tried only once. */
     /*  [unless only anchor is BOL and multiline is set] */
@@ -1790,16 +1766,14 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
                }
            }
        }
-       DEBUG_EXECUTE_r(if (!did_match)
-                    PerlIO_printf(Perl_debug_log, 
-                                  "Did not find %s substr \"%s%.*s%s\"%s...\n",
+       DEBUG_EXECUTE_r(if (!did_match) {
+            RE_PV_QUOTED_DECL(quoted, do_utf8, 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",
                              ((must == prog->anchored_substr || must == prog->anchored_utf8)
                               ? "anchored" : "floating"),
-                             PL_colors[0],
-                             (int)(SvCUR(must) - (SvTAIL(must)!=0)),
-                             SvPVX_const(must),
-                                  PL_colors[1], (SvTAIL(must) ? "$" : ""))
-               );
+                quoted, RE_SV_TAIL(must));
+        });                
        goto phooey;
     }
     else if ((c = prog->regstclass)) {
@@ -1813,14 +1787,12 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
            SV * const prop = sv_newmortal();
            regprop(prog, prop, c);
            {
-               RE_PV_DISPLAY_DECL(s0,len0,UTF,
-                   PERL_DEBUG_PAD_ZERO(0),SvPVX_const(prop),SvCUR(prop),60);
-               RE_PV_DISPLAY_DECL(s1,len1,UTF,
-                   PERL_DEBUG_PAD_ZERO(1),s,strend-s,60);
+               RE_PV_QUOTED_DECL(quoted,UTF,PERL_DEBUG_PAD_ZERO(1),
+                   s,strend-s,60);
                PerlIO_printf(Perl_debug_log,
-                   "Matching stclass \"%*.*s\" against \"%*.*s\" (%d chars)\n",
-                   len0, len0, s0,
-                   len1, len1, s1, (int)(strend - s));
+                   "Matching stclass %.*s against %s (%d chars)\n",
+                   SvCUR(prop), SvPVX_const(prop),
+                    quoted, (int)(strend - s));
            }
        });
         if (find_byclass(prog, c, s, strend, &reginfo))
@@ -2305,6 +2277,31 @@ S_push_slab(pTHX)
 #define REG_NODE_NUM(x) ((x) ? (int)((x)-prog) : -1)
 
 #ifdef DEBUGGING
+STATIC void
+S_debug_start_match(pTHX_ const regexp *prog, const bool do_utf8, 
+    const char *start, const char *end, const char *blurb)
+{
+    const bool utf8_pat= prog->reganch & ROPT_UTF8 ? 1 : 0;
+    if (!PL_colorset)   
+            reginitcolors();    
+    {
+        RE_PV_QUOTED_DECL(s0, utf8_pat, PERL_DEBUG_PAD_ZERO(0), 
+            prog->precomp, prog->prelen, 60);   
+        
+        RE_PV_QUOTED_DECL(s1, do_utf8, PERL_DEBUG_PAD_ZERO(1), 
+            start, end - start, 60); 
+        
+        PerlIO_printf(Perl_debug_log, 
+            "%s%s REx%s %s against %s\n", 
+                      PL_colors[4], blurb, PL_colors[5], s0, s1); 
+        
+        if (do_utf8||utf8_pat) 
+            PerlIO_printf(Perl_debug_log, "UTF-8 %s...\n",
+                !do_utf8 ? "pattern" : !utf8_pat ? "string" : 
+                    "pattern and string"
+            ); 
+    }
+}
 
 STATIC void
 S_dump_exec_pos(pTHX_ const char *locinput, const regnode *scan, const bool do_utf8)
@@ -2337,29 +2334,23 @@ S_dump_exec_pos(pTHX_ const char *locinput, const regnode *scan, const bool do_u
     {
        const int is_uni = (do_utf8 && OP(scan) != CANY) ? 1 : 0;
 
-       RE_PV_DISPLAY_DECL(s0,len0,is_uni,PERL_DEBUG_PAD(0),
-           (locinput - pref_len),pref0_len, 60);
+       RE_PV_COLOR_DECL(s0,len0,is_uni,PERL_DEBUG_PAD(0),
+           (locinput - pref_len),pref0_len, 60, 4, 5);
        
-       RE_PV_DISPLAY_DECL(s1,len1,is_uni,PERL_DEBUG_PAD(1),
+       RE_PV_COLOR_DECL(s1,len1,is_uni,PERL_DEBUG_PAD(1),
                    (locinput - pref_len + pref0_len),
-                   pref_len - pref0_len, 60);
+                   pref_len - pref0_len, 60, 2, 3);
        
-       RE_PV_DISPLAY_DECL(s2,len2,is_uni,PERL_DEBUG_PAD(2),
-                   locinput, PL_regeol - locinput, 60);
+       RE_PV_COLOR_DECL(s2,len2,is_uni,PERL_DEBUG_PAD(2),
+                   locinput, PL_regeol - locinput, 60, 0, 1);
 
        PerlIO_printf(Perl_debug_log,
-                   "%4"IVdf" <%s%.*s%s%s%.*s%s%s%s%.*s%s>%*s|",
+                   "%4"IVdf" <%.*s%.*s%s%.*s>%*s|",
                    (IV)(locinput - PL_bostr),
-                   PL_colors[4],
                    len0, s0,
-                   PL_colors[5],
-                   PL_colors[2],
                    len1, s1,
-                   PL_colors[3],
                    (docolor ? "" : "> <"),
-                   PL_colors[0],
                    len2, s2,
-                   PL_colors[1],
                    15 - l - pref_len + 1,
                    "");
     }
@@ -3237,14 +3228,9 @@ S_regmatch(pTHX_ const regmatch_info *reginfo, regnode *prog)
                }
 
                /* run the pattern returned from (??{...}) */
-
                DEBUG_EXECUTE_r(
-                   PerlIO_printf(Perl_debug_log,
-                                 "Entering embedded \"%s%.60s%s%s\"\n",
-                                 PL_colors[0],
-                                 re->precomp,
-                                 PL_colors[1],
-                                 (strlen(re->precomp) > 60 ? "..." : ""))
+                    debug_start_match(re, do_utf8, locinput, PL_regeol, 
+                        "Matching embedded");
                    );
 
                ST.cp = regcppush(0);   /* Save *all* the positions. */
@@ -3790,7 +3776,7 @@ S_regmatch(pTHX_ const regmatch_info *reginfo, regnode *prog)
            DEBUG_EXECUTE_r(
                PerlIO_printf(Perl_debug_log,
                          "%*s  CURLYM now matched %"IVdf" times, len=%"IVdf"...\n",
-                         (int)(REPORT_CODE_OFF+PL_regindent*2), "",
+                         (int)(REPORT_CODE_OFF+(PL_regindent*2)), "",
                          (IV) ST.count, (IV)ST.alen)
            );
 
@@ -3831,7 +3817,7 @@ S_regmatch(pTHX_ const regmatch_info *reginfo, regnode *prog)
            DEBUG_EXECUTE_r(
                PerlIO_printf(Perl_debug_log,
                    "%*s  CURLYM trying tail with matches=%"IVdf"...\n",
-                   (int)(REPORT_CODE_OFF+PL_regindent*2),
+                   (int)(REPORT_CODE_OFF+(PL_regindent*2)),
                    "", (IV)ST.count)
                );
            if (ST.c1 != CHRTEST_VOID
@@ -4273,7 +4259,7 @@ S_regmatch(pTHX_ const regmatch_info *reginfo, regnode *prog)
            regmatch_state *newst;
 
            depth++;
-           DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
+           DEBUG_STATE_r(PerlIO_printf(Perl_debug_log,
                        "PUSH STATE(%d)\n", depth));
            st->locinput = locinput;
            newst = st+1; 
@@ -4354,7 +4340,7 @@ yes_final:
            st = SLAB_LAST(PL_regmatch_slab);
        }
        depth -= (st - yes_state);
-       DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "POP STATES (%d..%d)\n",
+       DEBUG_STATE_r(PerlIO_printf(Perl_debug_log, "POP STATES (%d..%d)\n",
            depth+1, depth+(st - yes_state)));
        st = yes_state;
        yes_state = st->u.yes.prev_yes_state;
@@ -4388,7 +4374,7 @@ yes:
      * will disappear when REGFMATCH goes */
     if (depth) {
        /* restore previous state and re-enter */
-       DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "POP STATE(%d)\n", depth));
+       DEBUG_STATE_r(PerlIO_printf(Perl_debug_log, "POP STATE(%d)\n", depth));
        depth--;
        st--;
        if (st < SLAB_FIRST(PL_regmatch_slab)) {
@@ -4451,7 +4437,7 @@ do_no:
 
     if (depth) {
        /* there's a previous state to backtrack to */
-       DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "POP STATE(%d)\n", depth));
+       DEBUG_STATE_r(PerlIO_printf(Perl_debug_log, "POP STATE(%d)\n", depth));
        depth--;
        st--;
        if (st < SLAB_FIRST(PL_regmatch_slab)) {