This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perldelta - Remove all but one XXX notices
[perl5.git] / cpan / Devel-PPPort / parts / inc / pv_tools
CommitLineData
db42c902
MHM
1################################################################################
2##
49ef49fe 3## $Revision: 6 $
db42c902 4## $Author: mhx $
49ef49fe 5## $Date: 2010/03/07 13:15:44 +0100 $
db42c902
MHM
6##
7################################################################################
8##
49ef49fe 9## Version 3.x, Copyright (C) 2004-2010, Marcus Holland-Moritz.
db42c902
MHM
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__
21pv_escape
22pv_pretty
23pv_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
52char *
53pv_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
148char *
149pv_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
189char *
190pv_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
209void
210pv_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
218void
219pv_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
MHM
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
MHM
239 ST(7) = sv_2mortal(newSVpv(rv, 0));
240 XSRETURN(8);
241
242void
243pv_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
258my $uni = &Devel::PPPort::pv_escape_can_unicode();
259
260# sanity check
261ok($uni ? $] >= 5.006 : $] < 5.008);
262
263my @r;
264
265@r = &Devel::PPPort::pv_pretty();
266ok($r[0], $r[1]);
267ok($r[0], "foobarbaz");
268ok($r[2], $r[3]);
269ok($r[2], '<leftpv_p\retty\nright>');
270ok($r[4], $r[5]);
b7e2d8c7 271ok($r[4], $uni ? 'N\375 Batter\355' : 'N\303\275 Batter\303');
db42c902 272ok($r[6], $r[7]);
b7e2d8c7 273ok($r[6], $uni ? '\301g\346tis Byrju...' : '\303\201g\303\246t...');
db42c902
MHM
274
275@r = &Devel::PPPort::pv_display();
276ok($r[0], $r[1]);
277ok($r[0], '"foob\0rbaz"\0');
278ok($r[2], $r[3]);
279ok($r[2] eq '"pv_di"...\0' ||
280 $r[2] eq '"pv_d"...\0'); # some perl implementations are broken... :(
281