File Coverage

XString.xs
Criterion Covered Total %
statement 52 54 96.3
branch 54 64 84.3
condition n/a
subroutine n/a
pod n/a
total 106 118 89.8


line stmt bran cond sub pod time code
1             /*
2             *
3             * Copyright (c) 2019, cPanel, LLC.
4             * All rights reserved.
5             * http://cpanel.net
6             *
7             * This is free software; you can redistribute it and/or modify it under the
8             * same terms as Perl itself.
9             *
10             */
11              
12             #include
13             #include
14             #include
15             #include
16             #include
17             #include "ppport.h"
18              
19             /* stolen from B::cstring */
20             static SV *
21 1557           cstring(pTHX_ SV *sv, bool perlstyle)
22             {
23             SV *sstr;
24              
25 1557 50         if (!SvOK(sv))
    0          
    0          
26 0           return newSVpvs_flags("0", SVs_TEMP);
27              
28 1557           sstr = newSVpvs_flags("\"", SVs_TEMP);
29              
30 2838 100         if (perlstyle && SvUTF8(sv)) {
    100          
31 1281           SV *tmpsv = sv_newmortal(); /* Temporary SV to feed sv_uni_display */
32 1281           const STRLEN len = SvCUR(sv);
33 1281           const char *s = sv_uni_display(tmpsv, sv, 8*len, UNI_DISPLAY_QQ);
34 7633 100         while (*s)
35             {
36 6352 100         if (*s == '"')
37 2           sv_catpvs(sstr, "\\\"");
38 6350 100         else if (*s == '$')
39 2           sv_catpvs(sstr, "\\$");
40 6348 100         else if (*s == '@')
41 2           sv_catpvs(sstr, "\\@");
42 6346 100         else if (*s == '\\')
43             {
44 1093 50         if (memCHRs("nrftaebx\\",*(s+1)))
45 1093           sv_catpvn(sstr, s++, 2);
46             else
47 1093           sv_catpvs(sstr, "\\\\");
48             }
49             else /* should always be printable */
50 5253           sv_catpvn(sstr, s, 1);
51 6352           ++s;
52             }
53             }
54             else
55             {
56             /* XXX Optimise? */
57             STRLEN len;
58 276 50         const char *s = SvPV(sv, len);
59 692 100         for (; len; len--, s++)
60             {
61             /* At least try a little for readability */
62 416 100         if (*s == '"')
63 8           sv_catpvs(sstr, "\\\"");
64 408 100         else if (*s == '\\')
65 2           sv_catpvs(sstr, "\\\\");
66             /* trigraphs - bleagh */
67 406 100         else if (!perlstyle && *s == '?' && len>=3 && s[1] == '?') {
    100          
    50          
    0          
68 0           Perl_sv_catpvf(aTHX_ sstr, "\\%03o", '?');
69             }
70 406 100         else if (perlstyle && *s == '$')
    100          
71 1           sv_catpvs(sstr, "\\$");
72 405 100         else if (perlstyle && *s == '@')
    100          
73 1           sv_catpvs(sstr, "\\@");
74 404 100         else if (isPRINT(*s))
75 328           sv_catpvn(sstr, s, 1);
76 76 100         else if (*s == '\n')
77 6           sv_catpvs(sstr, "\\n");
78 70 100         else if (*s == '\r')
79 2           sv_catpvs(sstr, "\\r");
80 68 100         else if (*s == '\t')
81 2           sv_catpvs(sstr, "\\t");
82 66 100         else if (*s == '\a')
83 4           sv_catpvs(sstr, "\\a");
84 62 100         else if (*s == '\b')
85 2           sv_catpvs(sstr, "\\b");
86 60 100         else if (*s == '\f')
87 2           sv_catpvs(sstr, "\\f");
88 58 100         else if (!perlstyle && *s == '\v')
    100          
89 1           sv_catpvs(sstr, "\\v");
90             else
91             {
92             /* Don't want promotion of a signed -1 char in sprintf args */
93 57           const unsigned char c = (unsigned char) *s;
94 57           Perl_sv_catpvf(aTHX_ sstr, "\\%03o", c);
95             }
96             /* XXX Add line breaks if string is long */
97             }
98             }
99 1557           sv_catpvs(sstr, "\"");
100 1557           return sstr;
101             }
102              
103             MODULE = XString PACKAGE = XString
104              
105             void
106             cstring(sv)
107             SV * sv
108             ALIAS:
109             perlstring = 1
110             PPCODE:
111 1557           PUSHs( cstring(aTHX_ sv, (bool)ix) );