File Coverage

ext/Tie-Hash-NamedCapture/NamedCapture.xs
Criterion Covered Total %
statement 52 56 92.9
branch n/a
condition n/a
subroutine n/a
total 52 56 92.9


line stmt bran cond sub time code
1           #define PERL_NO_GET_CONTEXT /* we want efficiency */
2           #include "EXTERN.h"
3           #include "perl.h"
4           #include "XSUB.h"
5            
6           /* These are tightly coupled to the RXapif_* flags defined in regexp.h */
7           #define UNDEF_FATAL 0x80000
8           #define DISCARD 0x40000
9           #define EXPECT_SHIFT 24
10           #define ACTION_MASK 0x000FF
11            
12           #define FETCH_ALIAS (RXapif_FETCH | (2 << EXPECT_SHIFT))
13           #define STORE_ALIAS (RXapif_STORE | (3 << EXPECT_SHIFT) | UNDEF_FATAL | DISCARD)
14           #define DELETE_ALIAS (RXapif_DELETE | (2 << EXPECT_SHIFT) | UNDEF_FATAL)
15           #define CLEAR_ALIAS (RXapif_CLEAR | (1 << EXPECT_SHIFT) | UNDEF_FATAL | DISCARD)
16           #define EXISTS_ALIAS (RXapif_EXISTS | (2 << EXPECT_SHIFT))
17           #define SCALAR_ALIAS (RXapif_SCALAR | (1 << EXPECT_SHIFT))
18            
19           static void
20 1812         tie_it(pTHX_ const char name, UV flag, HV *const stash)
21           {
22 1812         GV *const gv = gv_fetchpvn(&name, 1, GV_ADDMULTI|GV_NOTQUAL, SVt_PVHV);
23 1812         HV *const hv = GvHV(gv);
24 1812         SV *rv = newSV_type(SVt_RV);
25            
26 1812         SvRV_set(rv, newSVuv(flag));
27 1812         SvROK_on(rv);
28 1812         sv_bless(rv, stash);
29            
30 1812         sv_unmagic((SV *)hv, PERL_MAGIC_tied);
31 1812         sv_magic((SV *)hv, rv, PERL_MAGIC_tied, NULL, 0);
32 1812         SvREFCNT_dec(rv); /* As sv_magic increased it by one. */
33 1812         }
34            
35           MODULE = Tie::Hash::NamedCapture PACKAGE = Tie::Hash::NamedCapture
36           PROTOTYPES: DISABLE
37            
38           BOOT:
39           {
40 906         HV *const stash = GvSTASH(CvGV(cv));
41 906         tie_it(aTHX_ '-', RXapif_ALL, stash);
42 906         tie_it(aTHX_ '+', RXapif_ONE, stash);
43           }
44            
45           SV *
46           TIEHASH(package, ...)
47           const char *package;
48           PREINIT:
49           UV flag = RXapif_ONE;
50           CODE:
51 10         mark += 2;
52 30         while(mark < sp) {
53           STRLEN len;
54 10         const char *p = SvPV_const(*mark, len);
55 10         if(memEQs(p, len, "all"))
56 6         flag = SvTRUE(mark[1]) ? RXapif_ALL : RXapif_ONE;
57 10         mark += 2;
58           }
59 10         RETVAL = newSV_type(SVt_RV);
60 10         sv_setuv(newSVrv(RETVAL, package), flag);
61           OUTPUT:
62           RETVAL
63            
64           void
65           FETCH(...)
66           ALIAS:
67           Tie::Hash::NamedCapture::FETCH = FETCH_ALIAS
68           Tie::Hash::NamedCapture::STORE = STORE_ALIAS
69           Tie::Hash::NamedCapture::DELETE = DELETE_ALIAS
70           Tie::Hash::NamedCapture::CLEAR = CLEAR_ALIAS
71           Tie::Hash::NamedCapture::EXISTS = EXISTS_ALIAS
72           Tie::Hash::NamedCapture::SCALAR = SCALAR_ALIAS
73           PREINIT:
74 8620         REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
75           U32 flags;
76           SV *ret;
77 8620         const U32 action = ix & ACTION_MASK;
78 8620         const int expect = ix >> EXPECT_SHIFT;
79           PPCODE:
80 8620         if (items != expect)
81 24         croak_xs_usage(cv, expect == 2 ? "$key"
82 6         : (expect == 3 ? "$key, $value"
83           : ""));
84            
85 8608         if (!rx || !SvROK(ST(0))) {
86 12         if (ix & UNDEF_FATAL)
87 6         Perl_croak_no_modify();
88           else
89 6         XSRETURN_UNDEF;
90           }
91            
92 8596         flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
93            
94 8596         PUTBACK;
95 8598         ret = RX_ENGINE(rx)->named_buff(aTHX_ (rx), expect >= 2 ? ST(1) : NULL,
96 2         expect >= 3 ? ST(2) : NULL, flags | action);
97 8590         SPAGAIN;
98            
99 8590         if (ix & DISCARD) {
100           /* Called with G_DISCARD, so our return stack state is thrown away.
101           Hence if we were returned anything, free it immediately. */
102 0         SvREFCNT_dec(ret);
103           } else {
104 8590         PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
105           }
106            
107           void
108           FIRSTKEY(...)
109           ALIAS:
110           Tie::Hash::NamedCapture::NEXTKEY = 1
111           PREINIT:
112 182         REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
113           U32 flags;
114           SV *ret;
115 182         const int expect = ix ? 2 : 1;
116 182         const U32 action = ix ? RXapif_NEXTKEY : RXapif_FIRSTKEY;
117           PPCODE:
118 182         if (items != expect)
119 4         croak_xs_usage(cv, expect == 2 ? "$lastkey" : "");
120            
121 178         if (!rx || !SvROK(ST(0)))
122 6         XSRETURN_UNDEF;
123            
124 172         flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
125            
126 172         PUTBACK;
127 288         ret = RX_ENGINE(rx)->named_buff_iter(aTHX_ (rx),
128 116         expect >= 2 ? ST(1) : NULL,
129           flags | action);
130 172         SPAGAIN;
131            
132 172         PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
133            
134           void
135           flags(...)
136           PPCODE:
137 0         EXTEND(SP, 2);
138 0         mPUSHu(RXapif_ONE);
139 0         mPUSHu(RXapif_ALL);