cpan/Devel-PPPort/parts/inc/pv_tools

   1 ################################################################################
   2 ##
   3 ##  $Revision: 6 $
   4 ##  $Author: mhx $
   5 ##  $Date: 2010/03/07 13:15:44 +0100 $
   6 ##
   7 ################################################################################
   8 ##
   9 ##  Version 3.x, Copyright (C) 2004-2010, Marcus Holland-Moritz.
  10 ##  Version 2.x, Copyright (C) 2001, Paul Marquess.
  11 ##  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
  12 ##
  13 ##  This program is free software; you can redistribute it and/or
  14 ##  modify it under the same terms as Perl itself.
  15 ##
  16 ################################################################################
  17
  18 =provides
  19
  20 __UNDEFINED__
  21 pv_escape
  22 pv_pretty
  23 pv_display
  24
  25 =implementation
  26
  27 __UNDEFINED__ PERL_PV_ESCAPE_QUOTE              0x0001
  28 __UNDEFINED__ PERL_PV_PRETTY_QUOTE              PERL_PV_ESCAPE_QUOTE
  29 __UNDEFINED__ PERL_PV_PRETTY_ELLIPSES           0x0002
  30 __UNDEFINED__ PERL_PV_PRETTY_LTGT               0x0004
  31 __UNDEFINED__ PERL_PV_ESCAPE_FIRSTCHAR          0x0008
  32 __UNDEFINED__ PERL_PV_ESCAPE_UNI                0x0100
  33 __UNDEFINED__ PERL_PV_ESCAPE_UNI_DETECT         0x0200
  34 __UNDEFINED__ PERL_PV_ESCAPE_ALL                0x1000
  35 __UNDEFINED__ PERL_PV_ESCAPE_NOBACKSLASH        0x2000
  36 __UNDEFINED__ PERL_PV_ESCAPE_NOCLEAR            0x4000
  37 __UNDEFINED__ PERL_PV_ESCAPE_RE                 0x8000
  38 __UNDEFINED__ PERL_PV_PRETTY_NOCLEAR            PERL_PV_ESCAPE_NOCLEAR
  39
  40 __UNDEFINED__ PERL_PV_PRETTY_DUMP               PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE
  41 __UNDEFINED__ PERL_PV_PRETTY_REGPROP            PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE
  42
  43 /* Hint: pv_escape
  44  * Note that unicode functionality is only backported to
  45  * those perl versions that support it. For older perl
  46  * versions, the implementation will fall back to bytes.
  47  */
  48
  49 #ifndef pv_escape
  50 #if { NEED pv_escape }
  51
  52 char *
  53 pv_escape(pTHX_ SV *dsv, char const * const str,
  54   const STRLEN count, const STRLEN max,
  55   STRLEN * const escaped, const U32 flags)
  56 {
  57     const char esc = flags & PERL_PV_ESCAPE_RE ? '%' : '\\';
  58     const char dq = flags & PERL_PV_ESCAPE_QUOTE ? '"' : esc;
  59     char octbuf[32] = "%123456789ABCDF";
  60     STRLEN wrote = 0;
  61     STRLEN chsize = 0;
  62     STRLEN readsize = 1;
  63 #if defined(is_utf8_string) && defined(utf8_to_uvchr)
  64     bool isuni = flags & PERL_PV_ESCAPE_UNI ? 1 : 0;
  65 #endif
  66     const char *pv  = str;
  67     const char * const end = pv + count;
  68     octbuf[0] = esc;
  69
  70     if (!(flags & PERL_PV_ESCAPE_NOCLEAR))
  71         sv_setpvs(dsv, "");
  72
  73 #if defined(is_utf8_string) && defined(utf8_to_uvchr)
  74     if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
  75         isuni = 1;
  76 #endif
  77
  78     for (; pv < end && (!max || wrote < max) ; pv += readsize) {
  79         const UV u =
  80 #if defined(is_utf8_string) && defined(utf8_to_uvchr)
  81                      isuni ? utf8_to_uvchr((U8*)pv, &readsize) :
  82 #endif
  83                              (U8)*pv;
  84         const U8 c = (U8)u & 0xFF;
  85
  86         if (u > 255 || (flags & PERL_PV_ESCAPE_ALL)) {
  87             if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
  88                 chsize = my_snprintf(octbuf, sizeof octbuf,
  89                                       "%"UVxf, u);
  90             else
  91                 chsize = my_snprintf(octbuf, sizeof octbuf,
  92                                       "%cx{%"UVxf"}", esc, u);
  93         } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
  94             chsize = 1;
  95         } else {
  96             if (c == dq || c == esc || !isPRINT(c)) {
  97                 chsize = 2;
  98                 switch (c) {
  99                 case '\\' : /* fallthrough */
 100                 case '%'  : if (c == esc)
 101                                 octbuf[1] = esc;
 102                             else
 103                                 chsize = 1;
 104                             break;
 105                 case '\v' : octbuf[1] = 'v'; break;
 106                 case '\t' : octbuf[1] = 't'; break;
 107                 case '\r' : octbuf[1] = 'r'; break;
 108                 case '\n' : octbuf[1] = 'n'; break;
 109                 case '\f' : octbuf[1] = 'f'; break;
 110                 case '"'  : if (dq == '"')
 111                                 octbuf[1] = '"';
 112                             else
 113                                 chsize = 1;
 114                             break;
 115                 default:    chsize = my_snprintf(octbuf, sizeof octbuf,
 116                                 pv < end && isDIGIT((U8)*(pv+readsize))
 117                                 ? "%c%03o" : "%c%o", esc, c);
 118                 }
 119             } else {
 120                 chsize = 1;
 121             }
 122         }
 123         if (max && wrote + chsize > max) {
 124             break;
 125         } else if (chsize > 1) {
 126             sv_catpvn(dsv, octbuf, chsize);
 127             wrote += chsize;
 128         } else {
 129             char tmp[2];
 130             my_snprintf(tmp, sizeof tmp, "%c", c);
 131             sv_catpvn(dsv, tmp, 1);
 132             wrote++;
 133         }
 134         if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
 135             break;
 136     }
 137     if (escaped != NULL)
 138         *escaped= pv - str;
 139     return SvPVX(dsv);
 140 }
 141
 142 #endif
 143 #endif
 144
 145 #ifndef pv_pretty
 146 #if { NEED pv_pretty }
 147
 148 char *
 149 pv_pretty(pTHX_ SV *dsv, char const * const str, const STRLEN count,
 150   const STRLEN max, char const * const start_color, char const * const end_color,
 151   const U32 flags)
 152 {
 153     const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
 154     STRLEN escaped;
 155
 156     if (!(flags & PERL_PV_PRETTY_NOCLEAR))
 157         sv_setpvs(dsv, "");
 158
 159     if (dq == '"')
 160         sv_catpvs(dsv, "\"");
 161     else if (flags & PERL_PV_PRETTY_LTGT)
 162         sv_catpvs(dsv, "<");
 163
 164     if (start_color != NULL)
 165         sv_catpv(dsv, D_PPP_CONSTPV_ARG(start_color));
 166
 167     pv_escape(dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR);
 168
 169     if (end_color != NULL)
 170         sv_catpv(dsv, D_PPP_CONSTPV_ARG(end_color));
 171
 172     if (dq == '"')
 173         sv_catpvs(dsv, "\"");
 174     else if (flags & PERL_PV_PRETTY_LTGT)
 175         sv_catpvs(dsv, ">");
 176
 177     if ((flags & PERL_PV_PRETTY_ELLIPSES) && escaped < count)
 178         sv_catpvs(dsv, "...");
 179
 180     return SvPVX(dsv);
 181 }
 182
 183 #endif
 184 #endif
 185
 186 #ifndef pv_display
 187 #if { NEED pv_display }
 188
 189 char *
 190 pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
 191 {
 192     pv_pretty(dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
 193     if (len > cur && pv[cur] == '\0')
 194         sv_catpvs(dsv, "\\0");
 195     return SvPVX(dsv);
 196 }
 197
 198 #endif
 199 #endif
 200
 201 =xsinit
 202
 203 #define NEED_pv_escape
 204 #define NEED_pv_pretty
 205 #define NEED_pv_display
 206
 207 =xsubs
 208
 209 void
 210 pv_escape_can_unicode()
 211         PPCODE:
 212 #if defined(is_utf8_string) && defined(utf8_to_uvchr)
 213                 XSRETURN_YES;
 214 #else
 215                 XSRETURN_NO;
 216 #endif
 217
 218 void
 219 pv_pretty()
 220         PREINIT:
 221                 char *rv;
 222         PPCODE:
 223                 EXTEND(SP, 8);
 224                 ST(0) = sv_newmortal();
 225                 rv = pv_pretty(ST(0), "foobarbaz",
 226                                 9, 40, NULL, NULL, 0);
 227                 ST(1) = sv_2mortal(newSVpv(rv, 0));
 228                 ST(2) = sv_newmortal();
 229                 rv = pv_pretty(ST(2), "pv_p\retty\n",
 230                                 10, 40, "left", "right", PERL_PV_PRETTY_LTGT);
 231                 ST(3) = sv_2mortal(newSVpv(rv, 0));
 232                 ST(4) = sv_newmortal();
 233                 rv = pv_pretty(ST(4), "N\303\275 Batter\303\255",
 234                                 12, 20, NULL, NULL, PERL_PV_ESCAPE_UNI_DETECT);
 235                 ST(5) = sv_2mortal(newSVpv(rv, 0));
 236                 ST(6) = sv_newmortal();
 237                 rv = pv_pretty(ST(6), "\303\201g\303\246tis Byrjun",
 238                                 15, 18, NULL, NULL, PERL_PV_ESCAPE_UNI_DETECT|PERL_PV_PRETTY_ELLIPSES);
 239                 ST(7) = sv_2mortal(newSVpv(rv, 0));
 240                 XSRETURN(8);
 241
 242 void
 243 pv_display()
 244         PREINIT:
 245                 char *rv;
 246         PPCODE:
 247                 EXTEND(SP, 4);
 248                 ST(0) = sv_newmortal();
 249                 rv = pv_display(ST(0), "foob\0rbaz", 9, 10, 20);
 250                 ST(1) = sv_2mortal(newSVpv(rv, 0));
 251                 ST(2) = sv_newmortal();
 252                 rv = pv_display(ST(2), "pv_display", 10, 11, 5);
 253                 ST(3) = sv_2mortal(newSVpv(rv, 0));
 254                 XSRETURN(4);
 255
 256 =tests plan => 13
 257
 258 my $uni = &Devel::PPPort::pv_escape_can_unicode();
 259
 260 # sanity check
 261 ok($uni ? $] >= 5.006 : $] < 5.008);
 262
 263 my @r;
 264
 265 @r = &Devel::PPPort::pv_pretty();
 266 ok($r[0], $r[1]);
 267 ok($r[0], "foobarbaz");
 268 ok($r[2], $r[3]);
 269 ok($r[2], '<leftpv_p\retty\nright>');
 270 ok($r[4], $r[5]);
 271 ok($r[4], $uni ? 'N\375 Batter\355' : 'N\303\275 Batter\303');
 272 ok($r[6], $r[7]);
 273 ok($r[6], $uni ? '\301g\346tis Byrju...' : '\303\201g\303\246t...');
 274
 275 @r = &Devel::PPPort::pv_display();
 276 ok($r[0], $r[1]);
 277 ok($r[0], '"foob\0rbaz"\0');
 278 ok($r[2], $r[3]);
 279 ok($r[2] eq '"pv_di"...\0' ||
 280    $r[2] eq '"pv_d"...\0');  # some perl implementations are broken... :(
 281