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
CommitLineData
5322d43e 1#define PERL_NO_GET_CONTEXT /* we want efficiency */
8cf6f931
NC
2#include "EXTERN.h"
3#include "perl.h"
4#include "XSUB.h"
5
8dcfe2e9
NC
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
e94ea821
FC
19MODULE = Tie::Hash::NamedCapture PACKAGE = Tie::Hash::NamedCapture
20PROTOTYPES: DISABLE
4b5ae309 21
e94ea821
FC
22void
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));
63f281fa 30 SvROK_on(rv);
e94ea821 31 sv_bless(rv, GvSTASH(CvGV(cv)));
4b5ae309
NC
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. */
4b5ae309 36
f8088870
NC
37SV *
38TIEHASH(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
8cf6f931 56void
8dcfe2e9
NC
57FETCH(...)
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)
cb077ed2 79 Perl_croak_no_modify();
8dcfe2e9
NC
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
99void
610f2345
NC
100FIRSTKEY(...)
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
126void
8cf6f931
NC
127flags(...)
128 PPCODE:
129 EXTEND(SP, 2);
130 mPUSHu(RXapif_ONE);
131 mPUSHu(RXapif_ALL);