Blame parts/inc/pv_tools

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