File Coverage

lib/PerlIO/bom.xs
Criterion Covered Total %
statement 43 47 91.4
branch 43 78 55.1
condition n/a
subroutine n/a
pod n/a
total 86 125 68.8


line stmt bran cond sub pod time code
1             #define PERL_NO_GET_CONTEXT
2             #include "EXTERN.h"
3             #include "perl.h"
4             #include "XSUB.h"
5             #include "perliol.h"
6              
7             #ifndef STR_WITH_LEN
8             #define STR_WITH_LEN(s) (s ""), (sizeof(s)-1)
9             #endif
10              
11 3           static IV S_push_utf8(pTHX_ PerlIO* f, const char* mode) {
12 3           PerlIO_funcs* encoding = PerlIO_find_layer(aTHX_ STR_WITH_LEN("utf8_strict"), 1);
13 3 50         return PerlIO_push(aTHX_ f, encoding, mode, NULL) == f ? 0 : -1;
14             }
15             #define push_utf8(f, mode) S_push_utf8(aTHX_ f, mode)
16              
17 12           static IV S_push_encoding_sv(pTHX_ PerlIO* f, const char* mode, SV* encoding) {
18 12           PerlIO_funcs* layer = PerlIO_find_layer(aTHX_ STR_WITH_LEN("encoding"), 1);
19 12 50         return PerlIO_push(aTHX_ f, layer , mode, encoding) == f ? 0 : -1;
20             }
21             #define push_encoding_sv(f, mode, encoding) S_push_encoding_sv(aTHX_ f, mode, encoding)
22             #define push_encoding_pvs(f, mode, encoding) push_encoding_sv(f, mode, sv_2mortal(newSVpvs(encoding)))
23              
24 10           int S_is_utf8(pTHX_ SV* arg) {
25 10 50         if (!arg || !SvOK(arg))
    50          
    0          
    0          
26             return TRUE;
27              
28             STRLEN len;
29 10 50         const char* fallback = SvPV(arg, len);
30 10 50         return len >= 4 &&
31 10 50         (memcmp(fallback, "utf", 3) == 0 || memcmp(fallback, "UTF", 3) == 0) &&
    50          
32 20 50         fallback[3] == '8' || (len >= 5 && fallback[3] == '-' && fallback[4] == '8');
    50          
    50          
    100          
33             }
34             #define is_utf8(arg) S_is_utf8(aTHX_ arg)
35              
36 15           static IV PerlIOBom_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) {
37 15 50         if (!PerlIOValid(f))
    50          
38             return -1;
39 15 50         else if (!PerlIO_fast_gets(f)) {
40             char mode[8];
41 0           PerlIO_push(aTHX_ f, &PerlIO_perlio, PerlIO_modestr(f,mode), Nullsv);
42 0 0         if (!f) {
43 0           Perl_warn(aTHX_ "panic: cannot push :perlio for %p",f);
44 0           return -1;
45             }
46             }
47 15 100         if (mode[0] == 'r' || mode[0] == 'w' && mode[1] == '+') {
    50          
    50          
48 10           PerlIO_fill(f);
49 10           Size_t count = PerlIO_get_cnt(f);
50 10           char* buffer = PerlIO_get_ptr(f);
51 10 50         if (count >= 3 && memcmp(buffer, "\xEF\xBB\xBF", 3) == 0) {
    100          
52 1           PerlIO_set_ptrcnt(f, buffer + 3, count - 3);
53 1           return push_utf8(f, mode);
54             }
55 9 50         else if (count >= 4 && memcmp(buffer, "\x00\x00\xFE\xFF", 4) == 0) {
    100          
56 1           PerlIO_set_ptrcnt(f, buffer + 4, count - 4);
57 1           return push_encoding_pvs(f, mode, "UTF32-BE");
58             }
59 8 50         else if (count >= 4 && memcmp(buffer, "\xFF\xFE\x00\x00", 4) == 0) {
    100          
60 1           PerlIO_set_ptrcnt(f, buffer + 4, count - 4);
61 1           return push_encoding_pvs(f, mode, "UTF32-LE");
62             }
63 7 50         else if (count >= 2 && memcmp(buffer, "\xFE\xFF", 2) == 0) {
    100          
64 1           PerlIO_set_ptrcnt(f, buffer + 2, count - 2);
65 1           return push_encoding_pvs(f, mode, "UTF16-BE");
66             }
67 6 50         else if (count >= 2 && memcmp(buffer, "\xFF\xFE", 2) == 0) {
    100          
68 1           PerlIO_set_ptrcnt(f, buffer + 2, count - 2);
69 1           return push_encoding_pvs(f, mode, "UTF16-LE");
70             }
71 5 100         if (is_utf8(arg))
72 1           return push_utf8(f, mode);
73             else
74 4           return push_encoding_sv(f, mode, arg);
75             }
76 5 50         else if (mode[0] == 'w') {
77 5 50         if (!arg || SvOK(arg) && !is_utf8(arg))
    50          
    0          
    0          
    100          
78 4           push_encoding_sv(f, mode, arg);
79             else
80 1           push_utf8(f, mode);
81              
82 5 50         return PerlIO_write(f, "\xEF\xBB\xBF", 3) == 3 ? 0 : -1;
83             }
84             else
85             return -1;
86             }
87              
88             PerlIO_funcs PerlIO_bom = {
89             sizeof(PerlIO_funcs),
90             "bom",
91             0,
92             0,
93             PerlIOBom_pushed,
94             NULL,
95             #if PERL_VERSION >= 14
96             PerlIOBase_open,
97             #else
98             PerlIOBuf_open,
99             #endif
100             };
101              
102             MODULE = PerlIO::bom PACKAGE = PerlIO::bom
103              
104             PROTOTYPES: DISABLED
105              
106             BOOT:
107 1           PerlIO_define_layer(aTHX_ &PerlIO_bom);
108