view release on metacpan or  search on metacpan

parts/inc/pv_tools  view on Meta::CPAN

  const U32 flags)
{
    const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
    STRLEN escaped;

    if (!(flags & PERL_PV_PRETTY_NOCLEAR))
        sv_setpvs(dsv, "");

    if (dq == '"')
        sv_catpvs(dsv, "\"");
    else if (flags & PERL_PV_PRETTY_LTGT)
        sv_catpvs(dsv, "<");

    if (start_color != NULL)
        sv_catpv(dsv, D_PPP_CONSTPV_ARG(start_color));

    pv_escape(dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR);

    if (end_color != NULL)
        sv_catpv(dsv, D_PPP_CONSTPV_ARG(end_color));

    if (dq == '"')
        sv_catpvs(dsv, "\"");
    else if (flags & PERL_PV_PRETTY_LTGT)
        sv_catpvs(dsv, ">");

    if ((flags & PERL_PV_PRETTY_ELLIPSES) && escaped < count)
        sv_catpvs(dsv, "...");

    return SvPVX(dsv);
}

#endif
#endif

#ifndef pv_display
#if { NEED pv_display }

char *
pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
{
    pv_pretty(dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
    if (len > cur && pv[cur] == '\0')
        sv_catpvs(dsv, "\\0");
    return SvPVX(dsv);
}

#endif
#endif

=xsinit

#define NEED_pv_escape
#define NEED_pv_pretty
#define NEED_pv_display

=xsubs

void
pv_escape_can_unicode()
        PPCODE:
#if defined(is_utf8_string) && defined(utf8_to_uvchr_buf)
                XSRETURN_YES;
#else
                XSRETURN_NO;
#endif

void
pv_pretty()
        PREINIT:
                char *rv;
        PPCODE:
                EXTEND(SP, 8);
                ST(0) = sv_newmortal();
                rv = pv_pretty(ST(0), "foobarbaz",
                                9, 40, NULL, NULL, 0);
                ST(1) = sv_2mortal(newSVpv(rv, 0));
                ST(2) = sv_newmortal();
                rv = pv_pretty(ST(2), "pv_p\retty\n",
                                10, 40, "left", "right", PERL_PV_PRETTY_LTGT);
                ST(3) = sv_2mortal(newSVpv(rv, 0));
                ST(4) = sv_newmortal();
                rv = pv_pretty(ST(4), "N\303\275 Batter\303\255",
                                12, 20, NULL, NULL, PERL_PV_ESCAPE_UNI_DETECT);
                ST(5) = sv_2mortal(newSVpv(rv, 0));
                ST(6) = sv_newmortal();
                rv = pv_pretty(ST(6), "\303\201g\303\246tis Byrjun",
                                15, 18, NULL, NULL, PERL_PV_ESCAPE_UNI_DETECT|PERL_PV_PRETTY_ELLIPSES);
                ST(7) = sv_2mortal(newSVpv(rv, 0));
                XSRETURN(8);

void
pv_display()
        PREINIT:
                char *rv;
        PPCODE:
                EXTEND(SP, 4);
                ST(0) = sv_newmortal();
                rv = pv_display(ST(0), "foob\0rbaz", 9, 10, 20);
                ST(1) = sv_2mortal(newSVpv(rv, 0));
                ST(2) = sv_newmortal();
                rv = pv_display(ST(2), "pv_display", 10, 11, 5);
                ST(3) = sv_2mortal(newSVpv(rv, 0));
                XSRETURN(4);

=tests plan => 13

my $uni = &Devel::PPPort::pv_escape_can_unicode();

# sanity check
ok($uni ? ivers($]) >= ivers("5.006") : ivers($]) < ivers("5.008"));

my @r;

@r = &Devel::PPPort::pv_pretty();
is($r[0], $r[1]);
is($r[0], "foobarbaz");
is($r[2], $r[3]);
is($r[2], '<leftpv_p\retty\nright>');
is($r[4], $r[5]);
if(ord("A") == 65) {
    is($r[4], $uni ? 'N\375 Batter\355' : 'N\303\275 Batter\303');
}
else {
    skip("Skip for non-ASCII platform");
}
is($r[6], $r[7]);
if(ord("A") == 65) {
    is($r[6], $uni ? '\301g\346tis Byrju...' : '\303\201g\303\246t...');
}
else {
    skip("Skip for non-ASCII platform");
}

@r = &Devel::PPPort::pv_display();
is($r[0], $r[1]);
is($r[0], '"foob\0rbaz"\0');
is($r[2], $r[3]);
ok($r[2] eq '"pv_di"...\0' ||
   $r[2] eq '"pv_d"...\0');  # some perl implementations are broken... :(