[p5sagit/p5-mst-13.2.git] / ext / Devel / PPPort / parts / inc / pv_tools

################################################################################
##
##  $Revision: 5 $
##  $Author: mhx $
##  $Date: 2009/01/18 14:10:51 +0100 $
##
################################################################################
##
##  Version 3.x, Copyright (C) 2004-2009, Marcus Holland-Moritz.
##  Version 2.x, Copyright (C) 2001, Paul Marquess.
##  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
##
##  This program is free software; you can redistribute it and/or
##  modify it under the same terms as Perl itself.
##
################################################################################

=provides

__UNDEFINED__
pv_escape
pv_pretty
pv_display

=implementation

__UNDEFINED__ PERL_PV_ESCAPE_QUOTE		0x0001
__UNDEFINED__ PERL_PV_PRETTY_QUOTE		PERL_PV_ESCAPE_QUOTE
__UNDEFINED__ PERL_PV_PRETTY_ELLIPSES		0x0002
__UNDEFINED__ PERL_PV_PRETTY_LTGT		0x0004
__UNDEFINED__ PERL_PV_ESCAPE_FIRSTCHAR		0x0008
__UNDEFINED__ PERL_PV_ESCAPE_UNI		0x0100
__UNDEFINED__ PERL_PV_ESCAPE_UNI_DETECT		0x0200
__UNDEFINED__ PERL_PV_ESCAPE_ALL		0x1000
__UNDEFINED__ PERL_PV_ESCAPE_NOBACKSLASH	0x2000
__UNDEFINED__ PERL_PV_ESCAPE_NOCLEAR		0x4000
__UNDEFINED__ PERL_PV_ESCAPE_RE			0x8000
__UNDEFINED__ PERL_PV_PRETTY_NOCLEAR		PERL_PV_ESCAPE_NOCLEAR

__UNDEFINED__ PERL_PV_PRETTY_DUMP		PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE
__UNDEFINED__ PERL_PV_PRETTY_REGPROP		PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE

/* Hint: pv_escape
 * Note that unicode functionality is only backported to
 * those perl versions that support it. For older perl
 * versions, the implementation will fall back to bytes.
 */

#ifndef pv_escape
#if { NEED pv_escape }

char *
pv_escape(pTHX_ SV *dsv, char const * const str,
  const STRLEN count, const STRLEN max,
  STRLEN * const escaped, const U32 flags)
{
    const char esc = flags & PERL_PV_ESCAPE_RE ? '%' : '\\';
    const char dq = flags & PERL_PV_ESCAPE_QUOTE ? '"' : esc;
    char octbuf[32] = "%123456789ABCDF";
    STRLEN wrote = 0;
    STRLEN chsize = 0;
    STRLEN readsize = 1;
#if defined(is_utf8_string) && defined(utf8_to_uvchr)
    bool isuni = flags & PERL_PV_ESCAPE_UNI ? 1 : 0;
#endif
    const char *pv  = str;
    const char * const end = pv + count;
    octbuf[0] = esc;

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

#if defined(is_utf8_string) && defined(utf8_to_uvchr)
    if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
        isuni = 1;
#endif

    for (; pv < end && (!max || wrote < max) ; pv += readsize) {
        const UV u =
#if defined(is_utf8_string) && defined(utf8_to_uvchr)
		     isuni ? utf8_to_uvchr((U8*)pv, &readsize) :
#endif
			     (U8)*pv;
        const U8 c = (U8)u & 0xFF;

        if (u > 255 || (flags & PERL_PV_ESCAPE_ALL)) {
            if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
                chsize = my_snprintf(octbuf, sizeof octbuf,
                                      "%"UVxf, u);
            else
                chsize = my_snprintf(octbuf, sizeof octbuf,
                                      "%cx{%"UVxf"}", esc, u);
        } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
            chsize = 1;
        } else {
            if (c == dq || c == esc || !isPRINT(c)) {
	        chsize = 2;
                switch (c) {
		case '\\' : /* fallthrough */
		case '%'  : if (c == esc)
		                octbuf[1] = esc;
		            else
		                chsize = 1;
		            break;
		case '\v' : octbuf[1] = 'v'; break;
		case '\t' : octbuf[1] = 't'; break;
		case '\r' : octbuf[1] = 'r'; break;
		case '\n' : octbuf[1] = 'n'; break;
		case '\f' : octbuf[1] = 'f'; break;
                case '"'  : if (dq == '"')
				octbuf[1] = '"';
			    else
				chsize = 1;
			    break;
		default:    chsize = my_snprintf(octbuf, sizeof octbuf,
				pv < end && isDIGIT((U8)*(pv+readsize))
				? "%c%03o" : "%c%o", esc, c);
                }
            } else {
                chsize = 1;
            }
	}
	if (max && wrote + chsize > max) {
	    break;
        } else if (chsize > 1) {
            sv_catpvn(dsv, octbuf, chsize);
            wrote += chsize;
	} else {
	    char tmp[2];
	    my_snprintf(tmp, sizeof tmp, "%c", c);
            sv_catpvn(dsv, tmp, 1);
	    wrote++;
	}
        if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
            break;
    }
    if (escaped != NULL)
        *escaped= pv - str;
    return SvPVX(dsv);
}

#endif
#endif

#ifndef pv_pretty
#if { NEED pv_pretty }

char *
pv_pretty(pTHX_ SV *dsv, char const * const str, const STRLEN count,
  const STRLEN max, char const * const start_color, char const * const end_color,
  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)
		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 ? $] >= 5.006 : $] < 5.008);

my @r;

@r = &Devel::PPPort::pv_pretty();
ok($r[0], $r[1]);
ok($r[0], "foobarbaz");
ok($r[2], $r[3]);
ok($r[2], '<leftpv_p\retty\nright>');
ok($r[4], $r[5]);
ok($r[4], $uni ? 'N\375 Batter\355' : 'N\303\275 Batter\303');
ok($r[6], $r[7]);
ok($r[6], $uni ? '\301g\346tis Byrju...' : '\303\201g\303\246t...');

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