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
 
 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.
 
 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,
 
 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
 */
 
 =cut
 */
-
+#define PV_ESCAPE_OCTBUFSIZE 32
 char *
 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);
            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;
            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 '\\' : 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] = '"';
                                octbuf[1] = '"';
+                        else 
+                            chsize = 1;
                                break;
                                break;
-                           }
                default:
                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
                            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;
            }
            if ( max && (wrote + chsize > max) ) {
                break;
-           } else {
+        } else if (chsize > 1) {
                sv_catpvn(dsv, octbuf, chsize);
                wrote += chsize;
                sv_catpvn(dsv, octbuf, chsize);
                wrote += chsize;
-           }
        } else {
        } else {
-           sv_catpvn(dsv, pv, 1);
+            Perl_sv_catpvf( aTHX_ dsv, "%c", c);
            wrote++;
        }
            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 );
        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 );
            sv_catpvn( dsv, "...", 3 );
-    } else if ( max && (flags & PERL_PV_ESCAPE_PADR) ) {
-       for ( ; wrote < max ; wrote++ )
-           sv_catpvn( dsv, " ", 1 );
-    }
     return SvPVX(dsv);
 }
 
     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)
 {
 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);
     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
 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
 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   |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
 
 #  endif
 #endif
 
index 08abfa1..51545ac 100644 (file)
@@ -233,6 +233,7 @@ my %flags = (
     EXTRA           => 0xFF0000,
     TRIE_MORE       => 0x010000,
     OFFSETS_DEBUG   => 0x020000,
     EXTRA           => 0xFF0000,
     TRIE_MORE       => 0x010000,
     OFFSETS_DEBUG   => 0x020000,
+    STATE           => 0x040000,
 );
 $flags{ALL} = $flags{COMPILE} | $flags{EXECUTE};
 $flags{All} = $flags{all} = $flags{DUMP} | $flags{EXECUTE};
 );
 $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. */
 
 
    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 */
 
 
 #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 );               \
 #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
 
        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;
 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;
 
     GET_RE_DEBUG_FLAGS_DECL;
 
+
     PerlIO_printf( Perl_debug_log, "%*sChar : %-6s%-6s%-4s ",
         (int)depth * 2 + 2,"",
         "Match","Base","Ofs" );
     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 ) {
     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, "\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++ ) {
     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 )
                 {
                      ( 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 {
                     (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;
 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.  */
     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;
     
     
     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| ","");
             (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);
         }
         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
             );
         }
                 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;
 {
     U32 state;
     U16 charid;
+    SV *sv=sv_newmortal();
+    int colwidth= trie->widecharmap ? 6 : 4;
     GET_RE_DEBUG_FLAGS_DECL;
     
     /*
     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 ) {
     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, "\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" );
     }
 
     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++ ) {
             (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 );
         }
         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({
     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;
     });
     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();
 #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. */
 
     (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,
        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);
                      (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,
        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);
                      (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,
        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);
                      (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,
        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);
                      (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
     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(""));
 
     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
     } 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;
 
     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();
        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
     });
 
     /* 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);
 
            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)), "",
                       (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];
 
            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_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 */
 
 #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  )
 /* 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 )
 #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
 })
 
 #ifdef DEBUGGING
+
 #define GET_RE_DEBUG_FLAGS_DECL IV re_debug_flags = 0; GET_RE_DEBUG_FLAGS;
 #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)
     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 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_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)
 
 
 #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: */
 }
 
 /* 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",    \
                             "  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", \
                                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)
 
 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) {
     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;
     }
        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) {
 
     /* 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.  */
 
     /* 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"),
                          (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;
 
     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
                    );
                        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"),
                        (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,
                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);
                              (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"),
                    (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,
            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] */
 
     /* 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"),
                              ((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)) {
        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);
            {
            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,
                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))
            }
        });
         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
 #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)
 
 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;
 
     {
        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),
                    (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,
 
        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),
                    (IV)(locinput - PL_bostr),
-                   PL_colors[4],
                    len0, s0,
                    len0, s0,
-                   PL_colors[5],
-                   PL_colors[2],
                    len1, s1,
                    len1, s1,
-                   PL_colors[3],
                    (docolor ? "" : "> <"),
                    (docolor ? "" : "> <"),
-                   PL_colors[0],
                    len2, s2,
                    len2, s2,
-                   PL_colors[1],
                    15 - l - pref_len + 1,
                    "");
     }
                    15 - l - pref_len + 1,
                    "");
     }
@@ -3237,14 +3228,9 @@ S_regmatch(pTHX_ const regmatch_info *reginfo, regnode *prog)
                }
 
                /* run the pattern returned from (??{...}) */
                }
 
                /* run the pattern returned from (??{...}) */
-
                DEBUG_EXECUTE_r(
                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. */
                    );
 
                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",
            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)
            );
 
                          (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",
            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
                    "", (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++;
            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; 
                        "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);
            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;
            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 */
      * 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)) {
        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 */
 
     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)) {
        depth--;
        st--;
        if (st < SLAB_FIRST(PL_regmatch_slab)) {