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