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
CommitLineData
8cf6f931
NC
1#include "EXTERN.h"
2#include "perl.h"
3#include "XSUB.h"
4
8dcfe2e9
NC
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
4b5ae309 18static
63f281fa 19tie_it(pTHX_ const char name, UV flag, HV *const stash)
4b5ae309
NC
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
63f281fa
NC
25 SvRV_set(rv, newSVuv(flag));
26 SvROK_on(rv);
27 sv_bless(rv, stash);
4b5ae309
NC
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
8cf6f931
NC
34MODULE = Tie::Hash::NamedCapture PACKAGE = Tie::Hash::NamedCapture
35PROTOTYPES: DISABLE
36
4b5ae309 37BOOT:
63f281fa
NC
38 {
39 HV *const stash = GvSTASH(CvGV(cv));
40 tie_it(aTHX_ '-', RXapif_ALL, stash);
41 tie_it(aTHX_ '+', RXapif_ONE, stash);
42 }
4b5ae309 43
f8088870
NC
44SV *
45TIEHASH(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
8cf6f931 63void
8dcfe2e9
NC
64FETCH(...)
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
106void
610f2345
NC
107FIRSTKEY(...)
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
133void
8cf6f931
NC
134flags(...)
135 PPCODE:
136 EXTEND(SP, 2);
137 mPUSHu(RXapif_ONE);
138 mPUSHu(RXapif_ALL);