Commit | Line | Data |
---|---|---|
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 |
19 | MODULE = Tie::Hash::NamedCapture PACKAGE = Tie::Hash::NamedCapture |
20 | PROTOTYPES: DISABLE | |
4b5ae309 | 21 | |
e94ea821 FC |
22 | void |
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 |
37 | SV * |
38 | TIEHASH(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 | 56 | void |
8dcfe2e9 NC |
57 | FETCH(...) |
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 | ||
99 | void | |
610f2345 NC |
100 | FIRSTKEY(...) |
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 | ||
126 | void | |
8cf6f931 NC |
127 | flags(...) |
128 | PPCODE: | |
129 | EXTEND(SP, 2); | |
130 | mPUSHu(RXapif_ONE); | |
131 | mPUSHu(RXapif_ALL); |