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__
15pv_escape
16pv_pretty
17pv_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
46char *
47pv_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_buf)
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_buf)
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_buf)
75                     isuni ? utf8_to_uvchr_buf((U8*)pv, end, &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
142char *
143pv_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
183char *
184pv_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
203void
204pv_escape_can_unicode()
205        PPCODE:
206#if defined(is_utf8_string) && defined(utf8_to_uvchr_buf)
207                XSRETURN_YES;
208#else
209                XSRETURN_NO;
210#endif
211
212void
213pv_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
236void
237pv_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
252my $uni = &Devel::PPPort::pv_escape_can_unicode();
253
254# sanity check
255ok($uni ? ivers($]) >= ivers("5.006") : ivers($]) < ivers("5.008"));
256
257my @r;
258
259@r = &Devel::PPPort::pv_pretty();
260is($r[0], $r[1]);
261is($r[0], "foobarbaz");
262is($r[2], $r[3]);
263is($r[2], '<leftpv_p\retty\nright>');
264is($r[4], $r[5]);
265if(ord("A") == 65) {
266    is($r[4], $uni ? 'N\375 Batter\355' : 'N\303\275 Batter\303');
267}
268else {
269    skip("Skip for non-ASCII platform");
270}
271is($r[6], $r[7]);
272if(ord("A") == 65) {
273    is($r[6], $uni ? '\301g\346tis Byrju...' : '\303\201g\303\246t...');
274}
275else {
276    skip("Skip for non-ASCII platform");
277}
278
279@r = &Devel::PPPort::pv_display();
280is($r[0], $r[1]);
281is($r[0], '"foob\0rbaz"\0');
282is($r[2], $r[3]);
283ok($r[2] eq '"pv_di"...\0' ||
284   $r[2] eq '"pv_d"...\0');  # some perl implementations are broken... :(
285