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