dump.c: Add PERL_PV_PRETTY_EXACTSIZE option

Sometimes we want things to fit exactly into a specific number
of chars, elipses, quotes and all. Includes make regen update
to make dsv argument nullok.

diff --git a/dump.c b/dump.c
index fe1c01b..4c5c76e 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -96,7 +96,10 @@ S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start,
 
 Escapes at most the first "count" chars of pv and puts the results into
 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. The number of bytes
+escaped will be returned in the STRLEN *escaped parameter if it is not null.
+When the dsv parameter is null no escaping actually occurs, but the number
+of bytes that would be escaped were it not null will be calculated.
 
 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
 will also be escaped.
@@ -151,7 +154,7 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
 
     PERL_ARGS_ASSERT_PV_ESCAPE;
 
-    if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) {
+    if (dsv && !(flags & PERL_PV_ESCAPE_NOCLEAR)) {
            /* This won't alter the UTF-8 flag */
            sv_setpvs(dsv, "");
     }
@@ -221,7 +224,8 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
        if ( max && (wrote + chsize > max) ) {
            break;
         } else if (chsize > 1) {
-            sv_catpvn(dsv, octbuf, chsize);
+            if (dsv)
+                sv_catpvn(dsv, octbuf, chsize);
             wrote += chsize;
        } else {
            /* If PERL_PV_ESCAPE_NOBACKSLASH is set then non-ASCII bytes
@@ -230,7 +234,8 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
               Or add a new API call sv_catpvc(). Think about that name, and
               how to keep it clear that it's unlike the s of catpvs, which is
               really an array of octets, not a string.  */
-            Perl_sv_catpvf( aTHX_ dsv, "%c", c);
+            if (dsv)
+                Perl_sv_catpvf( aTHX_ dsv, "%c", c);
            wrote++;
        }
         if ( flags & PERL_PV_ESCAPE_FIRSTCHAR ) 
@@ -238,7 +243,7 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
     }
     if (escaped != NULL)
         *escaped= pv - str;
-    return SvPVX(dsv);
+    return dsv ? SvPVX(dsv) : NULL;
 }
 /*
 =for apidoc pv_pretty
@@ -270,36 +275,51 @@ Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
   const STRLEN max, char const * const start_color, char const * const end_color, 
   const U32 flags ) 
 {
-    const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
+    const U8 *quotes = (flags & PERL_PV_PRETTY_QUOTE) ? "\"\"" :
+                       (flags & PERL_PV_PRETTY_LTGT)  ? "<>" : NULL;
     STRLEN escaped;
+    STRLEN max_adjust= 0;
+    STRLEN orig_cur;
  
     PERL_ARGS_ASSERT_PV_PRETTY;
    
     if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
-           /* This won't alter the UTF-8 flag */
-           sv_setpvs(dsv, "");
+        /* This won't alter the UTF-8 flag */
+        sv_setpvs(dsv, "");
     }
+    orig_cur= SvCUR(dsv);
 
-    if ( dq == '"' )
-        sv_catpvs(dsv, "\"");
-    else if ( flags & PERL_PV_PRETTY_LTGT )
-        sv_catpvs(dsv, "<");
+    if ( quotes )
+        Perl_sv_catpvf(aTHX_ dsv, "%c", quotes[0]);
         
     if ( start_color != NULL ) 
         sv_catpv(dsv, start_color);
-    
-    pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );    
-    
+
+    if ((flags & PERL_PV_PRETTY_EXACTSIZE)) {
+        if (quotes)
+            max_adjust += 2;
+        assert(max > max_adjust);
+        pv_escape( NULL, str, count, max - max_adjust, &escaped, flags );
+        if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
+            max_adjust += 3;
+        assert(max > max_adjust);
+    }
+
+    pv_escape( dsv, str, count, max - max_adjust, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
+
     if ( end_color != NULL ) 
         sv_catpv(dsv, end_color);
 
-    if ( dq == '"' ) 
-       sv_catpvs( dsv, "\"");
-    else if ( flags & PERL_PV_PRETTY_LTGT )
-        sv_catpvs(dsv, ">");         
+    if ( quotes )
+        Perl_sv_catpvf(aTHX_ dsv, "%c", quotes[1]);
     
     if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
            sv_catpvs(dsv, "...");
+
+    if ((flags & PERL_PV_PRETTY_EXACTSIZE)) {
+        while( SvCUR(dsv) - orig_cur < max )
+            sv_catpvs(dsv," ");
+    }
  
     return SvPVX(dsv);
 }

diff --git a/embed.fnc b/embed.fnc
index 016583f..faef450 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1749,7 +1749,7 @@ 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 char const * const str\
+Apd    |char*  |pv_escape      |NULLOK SV *dsv|NN char const * const str\
                                 |const STRLEN count|const STRLEN max\
                                 |NULLOK STRLEN * const escaped\
                                 |const U32 flags                               

diff --git a/perl.h b/perl.h
index 0bd8a53..27aa70b 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -6295,26 +6295,26 @@ extern void moncontrol(int);
  * passed straight through to _escape.
  */
 
-#define PERL_PV_ESCAPE_QUOTE        0x0001
+#define PERL_PV_ESCAPE_QUOTE        0x000001
 #define PERL_PV_PRETTY_QUOTE        PERL_PV_ESCAPE_QUOTE
 
-#define PERL_PV_PRETTY_ELLIPSES     0x0002
-#define PERL_PV_PRETTY_LTGT         0x0004
+#define PERL_PV_PRETTY_ELLIPSES     0x000002
+#define PERL_PV_PRETTY_LTGT         0x000004
+#define PERL_PV_PRETTY_EXACTSIZE    0x000008
 
-#define PERL_PV_ESCAPE_FIRSTCHAR    0x0008
+#define PERL_PV_ESCAPE_UNI          0x000100
+#define PERL_PV_ESCAPE_UNI_DETECT   0x000200
+#define PERL_PV_ESCAPE_NONASCII     0x000400
+#define PERL_PV_ESCAPE_FIRSTCHAR    0x000800
 
-#define PERL_PV_ESCAPE_UNI          0x0100
-#define PERL_PV_ESCAPE_UNI_DETECT   0x0200
-#define PERL_PV_ESCAPE_NONASCII     0x0400
-
-#define PERL_PV_ESCAPE_ALL         0x1000
-#define PERL_PV_ESCAPE_NOBACKSLASH  0x2000
-#define PERL_PV_ESCAPE_NOCLEAR      0x4000
-#define PERL_PV_ESCAPE_RE           0x8000
+#define PERL_PV_ESCAPE_ALL            0x001000
+#define PERL_PV_ESCAPE_NOBACKSLASH  0x002000
+#define PERL_PV_ESCAPE_NOCLEAR      0x004000
+#define PERL_PV_PRETTY_NOCLEAR      PERL_PV_ESCAPE_NOCLEAR
+#define PERL_PV_ESCAPE_RE           0x008000
 
-#define PERL_PV_ESCAPE_DWIM         0x10000
+#define PERL_PV_ESCAPE_DWIM         0x010000
 
-#define PERL_PV_PRETTY_NOCLEAR      PERL_PV_ESCAPE_NOCLEAR
 
 /* used by pv_display in dump.c*/
 #define PERL_PV_PRETTY_DUMP  PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE

diff --git a/proto.h b/proto.h
index 097c65c..b9e3048 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -3439,10 +3439,9 @@ PERL_CALLCONV char*      Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, S
        assert(dsv); assert(pv)
 
 PERL_CALLCONV char*    Perl_pv_escape(pTHX_ SV *dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags)
-                       __attribute__nonnull__(pTHX_1)
                        __attribute__nonnull__(pTHX_2);
 #define PERL_ARGS_ASSERT_PV_ESCAPE     \
-       assert(dsv); assert(str)
+       assert(str)
 
 PERL_CALLCONV char*    Perl_pv_pretty(pTHX_ SV *dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags)
                        __attribute__nonnull__(pTHX_1)