This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Regenerate Configure and friends after metaconfig changes
[perl5.git] / ext / Tie-Hash-NamedCapture / NamedCapture.xs
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 MODULE = Tie::Hash::NamedCapture        PACKAGE = Tie::Hash::NamedCapture
20 PROTOTYPES: DISABLE
21
22 void
23 _tie_it(SV *sv)
24   INIT:
25     GV * const gv = (GV *)sv;
26     HV * const hv = GvHVn(gv);
27     SV *rv = newSV_type(SVt_RV);
28     const char *gv_name = GvNAME(gv);
29   CODE:
30     SvRV_set(rv, newSVuv(
31         strEQ(gv_name, "-") || strEQ(gv_name, "\003APTURE_ALL")
32             ? RXapif_ALL : RXapif_ONE));
33     SvROK_on(rv);
34     sv_bless(rv, GvSTASH(CvGV(cv)));
35
36     sv_unmagic((SV *)hv, PERL_MAGIC_tied);
37     sv_magic((SV *)hv, rv, PERL_MAGIC_tied, NULL, 0);
38     SvREFCNT_dec(rv); /* As sv_magic increased it by one.  */
39
40 SV *
41 TIEHASH(package, ...)
42         const char *package;
43     PREINIT:
44         UV flag = RXapif_ONE;
45     CODE:
46         mark += 2;
47         while(mark < sp) {
48             STRLEN len;
49             const char *p = SvPV_const(*mark, len);
50             if(memEQs(p, len, "all"))
51                 flag = SvTRUE(mark[1]) ? RXapif_ALL : RXapif_ONE;
52             mark += 2;
53         }
54         RETVAL = newSV_type(SVt_RV);
55         sv_setuv(newSVrv(RETVAL, package), flag);
56     OUTPUT:
57         RETVAL
58
59 void
60 FETCH(...)
61     ALIAS:
62         Tie::Hash::NamedCapture::FETCH  = FETCH_ALIAS
63         Tie::Hash::NamedCapture::STORE  = STORE_ALIAS
64         Tie::Hash::NamedCapture::DELETE = DELETE_ALIAS
65         Tie::Hash::NamedCapture::CLEAR  = CLEAR_ALIAS
66         Tie::Hash::NamedCapture::EXISTS = EXISTS_ALIAS
67         Tie::Hash::NamedCapture::SCALAR = SCALAR_ALIAS
68     PREINIT:
69         REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
70         U32 flags;
71         SV *ret;
72         const U32 action = ix & ACTION_MASK;
73         const int expect = ix >> EXPECT_SHIFT;
74     PPCODE:
75         if (items != expect)
76             croak_xs_usage(cv, expect == 2 ? "$key"
77                                            : (expect == 3 ? "$key, $value"
78                                                           : ""));
79
80         if (!rx || !SvROK(ST(0))) {
81             if (ix & UNDEF_FATAL)
82                 Perl_croak_no_modify();
83             else
84                 XSRETURN_UNDEF;
85         }
86
87         flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
88
89         PUTBACK;
90         ret = RX_ENGINE(rx)->named_buff(aTHX_ (rx), expect >= 2 ? ST(1) : NULL,
91                                     expect >= 3 ? ST(2) : NULL, flags | action);
92         SPAGAIN;
93
94         if (ix & DISCARD) {
95             /* Called with G_DISCARD, so our return stack state is thrown away.
96                Hence if we were returned anything, free it immediately.  */
97             SvREFCNT_dec(ret);
98         } else {
99             PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
100         }
101
102 void
103 FIRSTKEY(...)
104     ALIAS:
105         Tie::Hash::NamedCapture::NEXTKEY = 1
106     PREINIT:
107         REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
108         U32 flags;
109         SV *ret;
110         const int expect = ix ? 2 : 1;
111         const U32 action = ix ? RXapif_NEXTKEY : RXapif_FIRSTKEY;
112     PPCODE:
113         if (items != expect)
114             croak_xs_usage(cv, expect == 2 ? "$lastkey" : "");
115
116         if (!rx || !SvROK(ST(0)))
117             XSRETURN_UNDEF;
118
119         flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
120
121         PUTBACK;
122         ret = RX_ENGINE(rx)->named_buff_iter(aTHX_ (rx),
123                                              expect >= 2 ? ST(1) : NULL,
124                                              flags | action);
125         SPAGAIN;
126
127         PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
128
129 void
130 flags(...)
131     PPCODE:
132         EXTEND(SP, 2);
133         mPUSHu(RXapif_ONE);
134         mPUSHu(RXapif_ALL);