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