Commit | Line | Data |
db42c902 |
1 | ################################################################################ |
2 | ## |
bfc37ff7 |
3 | ## $Revision: 6 $ |
db42c902 |
4 | ## $Author: mhx $ |
bfc37ff7 |
5 | ## $Date: 2010/03/07 13:15:44 +0100 $ |
db42c902 |
6 | ## |
7 | ################################################################################ |
8 | ## |
bfc37ff7 |
9 | ## Version 3.x, Copyright (C) 2004-2010, 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 | |