| 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... :( |