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