dist/Devel-PPPort/parts/inc/pv_tools

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