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
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);
1a1d29aa 28 const char *gv_name = GvNAME(gv);
e94ea821 29 CODE:
1a1d29aa
VF
30 SvRV_set(rv, newSVuv(
31 strEQ(gv_name, "-") || strEQ(gv_name, "\003APTURE_ALL")
32 ? RXapif_ALL : RXapif_ONE));
63f281fa 33 SvROK_on(rv);
e94ea821 34 sv_bless(rv, GvSTASH(CvGV(cv)));
4b5ae309
NC
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. */
4b5ae309 39
f8088870
NC
40SV *
41TIEHASH(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
8cf6f931 59void
8dcfe2e9
NC
60FETCH(...)
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)
cb077ed2 82 Perl_croak_no_modify();
8dcfe2e9
NC
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
102void
610f2345
NC
103FIRSTKEY(...)
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
129void
8cf6f931
NC
130flags(...)
131 PPCODE:
132 EXTEND(SP, 2);
133 mPUSHu(RXapif_ONE);
134 mPUSHu(RXapif_ALL);