|
Packit |
7d6a7d |
################################################################################
|
|
Packit |
7d6a7d |
##
|
|
Packit |
7d6a7d |
## Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
|
|
Packit |
7d6a7d |
## Version 2.x, Copyright (C) 2001, Paul Marquess.
|
|
Packit |
7d6a7d |
## Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
|
|
Packit |
7d6a7d |
##
|
|
Packit |
7d6a7d |
## This program is free software; you can redistribute it and/or
|
|
Packit |
7d6a7d |
## modify it under the same terms as Perl itself.
|
|
Packit |
7d6a7d |
##
|
|
Packit |
7d6a7d |
################################################################################
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
=provides
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
__UNDEFINED__
|
|
Packit |
7d6a7d |
pv_escape
|
|
Packit |
7d6a7d |
pv_pretty
|
|
Packit |
7d6a7d |
pv_display
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
=implementation
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
__UNDEFINED__ PERL_PV_ESCAPE_QUOTE 0x0001
|
|
Packit |
7d6a7d |
__UNDEFINED__ PERL_PV_PRETTY_QUOTE PERL_PV_ESCAPE_QUOTE
|
|
Packit |
7d6a7d |
__UNDEFINED__ PERL_PV_PRETTY_ELLIPSES 0x0002
|
|
Packit |
7d6a7d |
__UNDEFINED__ PERL_PV_PRETTY_LTGT 0x0004
|
|
Packit |
7d6a7d |
__UNDEFINED__ PERL_PV_ESCAPE_FIRSTCHAR 0x0008
|
|
Packit |
7d6a7d |
__UNDEFINED__ PERL_PV_ESCAPE_UNI 0x0100
|
|
Packit |
7d6a7d |
__UNDEFINED__ PERL_PV_ESCAPE_UNI_DETECT 0x0200
|
|
Packit |
7d6a7d |
__UNDEFINED__ PERL_PV_ESCAPE_ALL 0x1000
|
|
Packit |
7d6a7d |
__UNDEFINED__ PERL_PV_ESCAPE_NOBACKSLASH 0x2000
|
|
Packit |
7d6a7d |
__UNDEFINED__ PERL_PV_ESCAPE_NOCLEAR 0x4000
|
|
Packit |
7d6a7d |
__UNDEFINED__ PERL_PV_ESCAPE_RE 0x8000
|
|
Packit |
7d6a7d |
__UNDEFINED__ PERL_PV_PRETTY_NOCLEAR PERL_PV_ESCAPE_NOCLEAR
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
__UNDEFINED__ PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE
|
|
Packit |
7d6a7d |
__UNDEFINED__ PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
/* Hint: pv_escape
|
|
Packit |
7d6a7d |
* Note that unicode functionality is only backported to
|
|
Packit |
7d6a7d |
* those perl versions that support it. For older perl
|
|
Packit |
7d6a7d |
* versions, the implementation will fall back to bytes.
|
|
Packit |
7d6a7d |
*/
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
#ifndef pv_escape
|
|
Packit |
7d6a7d |
#if { NEED pv_escape }
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
char *
|
|
Packit |
7d6a7d |
pv_escape(pTHX_ SV *dsv, char const * const str,
|
|
Packit |
7d6a7d |
const STRLEN count, const STRLEN max,
|
|
Packit |
7d6a7d |
STRLEN * const escaped, const U32 flags)
|
|
Packit |
7d6a7d |
{
|
|
Packit |
7d6a7d |
const char esc = flags & PERL_PV_ESCAPE_RE ? '%' : '\\';
|
|
Packit |
7d6a7d |
const char dq = flags & PERL_PV_ESCAPE_QUOTE ? '"' : esc;
|
|
Packit |
7d6a7d |
char octbuf[32] = "%123456789ABCDF";
|
|
Packit |
7d6a7d |
STRLEN wrote = 0;
|
|
Packit |
7d6a7d |
STRLEN chsize = 0;
|
|
Packit |
7d6a7d |
STRLEN readsize = 1;
|
|
Packit |
7d6a7d |
#if defined(is_utf8_string) && defined(utf8_to_uvchr)
|
|
Packit |
7d6a7d |
bool isuni = flags & PERL_PV_ESCAPE_UNI ? 1 : 0;
|
|
Packit |
7d6a7d |
#endif
|
|
Packit |
7d6a7d |
const char *pv = str;
|
|
Packit |
7d6a7d |
const char * const end = pv + count;
|
|
Packit |
7d6a7d |
octbuf[0] = esc;
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
if (!(flags & PERL_PV_ESCAPE_NOCLEAR))
|
|
Packit |
7d6a7d |
sv_setpvs(dsv, "");
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
#if defined(is_utf8_string) && defined(utf8_to_uvchr)
|
|
Packit |
7d6a7d |
if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
|
|
Packit |
7d6a7d |
isuni = 1;
|
|
Packit |
7d6a7d |
#endif
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
for (; pv < end && (!max || wrote < max) ; pv += readsize) {
|
|
Packit |
7d6a7d |
const UV u =
|
|
Packit |
7d6a7d |
#if defined(is_utf8_string) && defined(utf8_to_uvchr)
|
|
Packit |
7d6a7d |
isuni ? utf8_to_uvchr((U8*)pv, &readsize) :
|
|
Packit |
7d6a7d |
#endif
|
|
Packit |
7d6a7d |
(U8)*pv;
|
|
Packit |
7d6a7d |
const U8 c = (U8)u & 0xFF;
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
if (u > 255 || (flags & PERL_PV_ESCAPE_ALL)) {
|
|
Packit |
7d6a7d |
if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
|
|
Packit |
7d6a7d |
chsize = my_snprintf(octbuf, sizeof octbuf,
|
|
Packit |
7d6a7d |
"%" UVxf, u);
|
|
Packit |
7d6a7d |
else
|
|
Packit |
7d6a7d |
chsize = my_snprintf(octbuf, sizeof octbuf,
|
|
Packit |
7d6a7d |
"%cx{%" UVxf "}", esc, u);
|
|
Packit |
7d6a7d |
} else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
|
|
Packit |
7d6a7d |
chsize = 1;
|
|
Packit |
7d6a7d |
} else {
|
|
Packit |
7d6a7d |
if (c == dq || c == esc || !isPRINT(c)) {
|
|
Packit |
7d6a7d |
chsize = 2;
|
|
Packit |
7d6a7d |
switch (c) {
|
|
Packit |
7d6a7d |
case '\\' : /* fallthrough */
|
|
Packit |
7d6a7d |
case '%' : if (c == esc)
|
|
Packit |
7d6a7d |
octbuf[1] = esc;
|
|
Packit |
7d6a7d |
else
|
|
Packit |
7d6a7d |
chsize = 1;
|
|
Packit |
7d6a7d |
break;
|
|
Packit |
7d6a7d |
case '\v' : octbuf[1] = 'v'; break;
|
|
Packit |
7d6a7d |
case '\t' : octbuf[1] = 't'; break;
|
|
Packit |
7d6a7d |
case '\r' : octbuf[1] = 'r'; break;
|
|
Packit |
7d6a7d |
case '\n' : octbuf[1] = 'n'; break;
|
|
Packit |
7d6a7d |
case '\f' : octbuf[1] = 'f'; break;
|
|
Packit |
7d6a7d |
case '"' : if (dq == '"')
|
|
Packit |
7d6a7d |
octbuf[1] = '"';
|
|
Packit |
7d6a7d |
else
|
|
Packit |
7d6a7d |
chsize = 1;
|
|
Packit |
7d6a7d |
break;
|
|
Packit |
7d6a7d |
default: chsize = my_snprintf(octbuf, sizeof octbuf,
|
|
Packit |
7d6a7d |
pv < end && isDIGIT((U8)*(pv+readsize))
|
|
Packit |
7d6a7d |
? "%c%03o" : "%c%o", esc, c);
|
|
Packit |
7d6a7d |
}
|
|
Packit |
7d6a7d |
} else {
|
|
Packit |
7d6a7d |
chsize = 1;
|
|
Packit |
7d6a7d |
}
|
|
Packit |
7d6a7d |
}
|
|
Packit |
7d6a7d |
if (max && wrote + chsize > max) {
|
|
Packit |
7d6a7d |
break;
|
|
Packit |
7d6a7d |
} else if (chsize > 1) {
|
|
Packit |
7d6a7d |
sv_catpvn(dsv, octbuf, chsize);
|
|
Packit |
7d6a7d |
wrote += chsize;
|
|
Packit |
7d6a7d |
} else {
|
|
Packit |
7d6a7d |
char tmp[2];
|
|
Packit |
7d6a7d |
my_snprintf(tmp, sizeof tmp, "%c", c);
|
|
Packit |
7d6a7d |
sv_catpvn(dsv, tmp, 1);
|
|
Packit |
7d6a7d |
wrote++;
|
|
Packit |
7d6a7d |
}
|
|
Packit |
7d6a7d |
if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
|
|
Packit |
7d6a7d |
break;
|
|
Packit |
7d6a7d |
}
|
|
Packit |
7d6a7d |
if (escaped != NULL)
|
|
Packit |
7d6a7d |
*escaped= pv - str;
|
|
Packit |
7d6a7d |
return SvPVX(dsv);
|
|
Packit |
7d6a7d |
}
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
#endif
|
|
Packit |
7d6a7d |
#endif
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
#ifndef pv_pretty
|
|
Packit |
7d6a7d |
#if { NEED pv_pretty }
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
char *
|
|
Packit |
7d6a7d |
pv_pretty(pTHX_ SV *dsv, char const * const str, const STRLEN count,
|
|
Packit |
7d6a7d |
const STRLEN max, char const * const start_color, char const * const end_color,
|
|
Packit |
7d6a7d |
const U32 flags)
|
|
Packit |
7d6a7d |
{
|
|
Packit |
7d6a7d |
const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
|
|
Packit |
7d6a7d |
STRLEN escaped;
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
if (!(flags & PERL_PV_PRETTY_NOCLEAR))
|
|
Packit |
7d6a7d |
sv_setpvs(dsv, "");
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
if (dq == '"')
|
|
Packit |
7d6a7d |
sv_catpvs(dsv, "\"");
|
|
Packit |
7d6a7d |
else if (flags & PERL_PV_PRETTY_LTGT)
|
|
Packit |
7d6a7d |
sv_catpvs(dsv, "<");
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
if (start_color != NULL)
|
|
Packit |
7d6a7d |
sv_catpv(dsv, D_PPP_CONSTPV_ARG(start_color));
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
pv_escape(dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR);
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
if (end_color != NULL)
|
|
Packit |
7d6a7d |
sv_catpv(dsv, D_PPP_CONSTPV_ARG(end_color));
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
if (dq == '"')
|
|
Packit |
7d6a7d |
sv_catpvs(dsv, "\"");
|
|
Packit |
7d6a7d |
else if (flags & PERL_PV_PRETTY_LTGT)
|
|
Packit |
7d6a7d |
sv_catpvs(dsv, ">");
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
if ((flags & PERL_PV_PRETTY_ELLIPSES) && escaped < count)
|
|
Packit |
7d6a7d |
sv_catpvs(dsv, "...");
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
return SvPVX(dsv);
|
|
Packit |
7d6a7d |
}
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
#endif
|
|
Packit |
7d6a7d |
#endif
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
#ifndef pv_display
|
|
Packit |
7d6a7d |
#if { NEED pv_display }
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
char *
|
|
Packit |
7d6a7d |
pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
|
|
Packit |
7d6a7d |
{
|
|
Packit |
7d6a7d |
pv_pretty(dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
|
|
Packit |
7d6a7d |
if (len > cur && pv[cur] == '\0')
|
|
Packit |
7d6a7d |
sv_catpvs(dsv, "\\0");
|
|
Packit |
7d6a7d |
return SvPVX(dsv);
|
|
Packit |
7d6a7d |
}
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
#endif
|
|
Packit |
7d6a7d |
#endif
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
=xsinit
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
#define NEED_pv_escape
|
|
Packit |
7d6a7d |
#define NEED_pv_pretty
|
|
Packit |
7d6a7d |
#define NEED_pv_display
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
=xsubs
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
void
|
|
Packit |
7d6a7d |
pv_escape_can_unicode()
|
|
Packit |
7d6a7d |
PPCODE:
|
|
Packit |
7d6a7d |
#if defined(is_utf8_string) && defined(utf8_to_uvchr)
|
|
Packit |
7d6a7d |
XSRETURN_YES;
|
|
Packit |
7d6a7d |
#else
|
|
Packit |
7d6a7d |
XSRETURN_NO;
|
|
Packit |
7d6a7d |
#endif
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
void
|
|
Packit |
7d6a7d |
pv_pretty()
|
|
Packit |
7d6a7d |
PREINIT:
|
|
Packit |
7d6a7d |
char *rv;
|
|
Packit |
7d6a7d |
PPCODE:
|
|
Packit |
7d6a7d |
EXTEND(SP, 8);
|
|
Packit |
7d6a7d |
ST(0) = sv_newmortal();
|
|
Packit |
7d6a7d |
rv = pv_pretty(ST(0), "foobarbaz",
|
|
Packit |
7d6a7d |
9, 40, NULL, NULL, 0);
|
|
Packit |
7d6a7d |
ST(1) = sv_2mortal(newSVpv(rv, 0));
|
|
Packit |
7d6a7d |
ST(2) = sv_newmortal();
|
|
Packit |
7d6a7d |
rv = pv_pretty(ST(2), "pv_p\retty\n",
|
|
Packit |
7d6a7d |
10, 40, "left", "right", PERL_PV_PRETTY_LTGT);
|
|
Packit |
7d6a7d |
ST(3) = sv_2mortal(newSVpv(rv, 0));
|
|
Packit |
7d6a7d |
ST(4) = sv_newmortal();
|
|
Packit |
7d6a7d |
rv = pv_pretty(ST(4), "N\303\275 Batter\303\255",
|
|
Packit |
7d6a7d |
12, 20, NULL, NULL, PERL_PV_ESCAPE_UNI_DETECT);
|
|
Packit |
7d6a7d |
ST(5) = sv_2mortal(newSVpv(rv, 0));
|
|
Packit |
7d6a7d |
ST(6) = sv_newmortal();
|
|
Packit |
7d6a7d |
rv = pv_pretty(ST(6), "\303\201g\303\246tis Byrjun",
|
|
Packit |
7d6a7d |
15, 18, NULL, NULL, PERL_PV_ESCAPE_UNI_DETECT|PERL_PV_PRETTY_ELLIPSES);
|
|
Packit |
7d6a7d |
ST(7) = sv_2mortal(newSVpv(rv, 0));
|
|
Packit |
7d6a7d |
XSRETURN(8);
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
void
|
|
Packit |
7d6a7d |
pv_display()
|
|
Packit |
7d6a7d |
PREINIT:
|
|
Packit |
7d6a7d |
char *rv;
|
|
Packit |
7d6a7d |
PPCODE:
|
|
Packit |
7d6a7d |
EXTEND(SP, 4);
|
|
Packit |
7d6a7d |
ST(0) = sv_newmortal();
|
|
Packit |
7d6a7d |
rv = pv_display(ST(0), "foob\0rbaz", 9, 10, 20);
|
|
Packit |
7d6a7d |
ST(1) = sv_2mortal(newSVpv(rv, 0));
|
|
Packit |
7d6a7d |
ST(2) = sv_newmortal();
|
|
Packit |
7d6a7d |
rv = pv_display(ST(2), "pv_display", 10, 11, 5);
|
|
Packit |
7d6a7d |
ST(3) = sv_2mortal(newSVpv(rv, 0));
|
|
Packit |
7d6a7d |
XSRETURN(4);
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
=tests plan => 13
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
my $uni = &Devel::PPPort::pv_escape_can_unicode();
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
# sanity check
|
|
Packit |
7d6a7d |
ok($uni ? $] >= 5.006 : $] < 5.008);
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
my @r;
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
@r = &Devel::PPPort::pv_pretty();
|
|
Packit |
7d6a7d |
ok($r[0], $r[1]);
|
|
Packit |
7d6a7d |
ok($r[0], "foobarbaz");
|
|
Packit |
7d6a7d |
ok($r[2], $r[3]);
|
|
Packit |
7d6a7d |
ok($r[2], '<leftpv_p\retty\nright>');
|
|
Packit |
7d6a7d |
ok($r[4], $r[5]);
|
|
Packit |
7d6a7d |
ok($r[4], $uni ? 'N\375 Batter\355' : 'N\303\275 Batter\303');
|
|
Packit |
7d6a7d |
ok($r[6], $r[7]);
|
|
Packit |
7d6a7d |
ok($r[6], $uni ? '\301g\346tis Byrju...' : '\303\201g\303\246t...');
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
@r = &Devel::PPPort::pv_display();
|
|
Packit |
7d6a7d |
ok($r[0], $r[1]);
|
|
Packit |
7d6a7d |
ok($r[0], '"foob\0rbaz"\0');
|
|
Packit |
7d6a7d |
ok($r[2], $r[3]);
|
|
Packit |
7d6a7d |
ok($r[2] eq '"pv_di"...\0' ||
|
|
Packit |
7d6a7d |
$r[2] eq '"pv_d"...\0'); # some perl implementations are broken... :(
|