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