1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
|
#define PERL_NO_GET_CONTEXT /* we want efficiency */
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
/* These are tightly coupled to the RXapif_* flags defined in regexp.h */
#define UNDEF_FATAL 0x80000
#define DISCARD 0x40000
#define EXPECT_SHIFT 24
#define ACTION_MASK 0x000FF
#define FETCH_ALIAS (RXapif_FETCH | (2 << EXPECT_SHIFT))
#define STORE_ALIAS (RXapif_STORE | (3 << EXPECT_SHIFT) | UNDEF_FATAL | DISCARD)
#define DELETE_ALIAS (RXapif_DELETE | (2 << EXPECT_SHIFT) | UNDEF_FATAL)
#define CLEAR_ALIAS (RXapif_CLEAR | (1 << EXPECT_SHIFT) | UNDEF_FATAL | DISCARD)
#define EXISTS_ALIAS (RXapif_EXISTS | (2 << EXPECT_SHIFT))
#define SCALAR_ALIAS (RXapif_SCALAR | (1 << EXPECT_SHIFT))
static void
tie_it(pTHX_ const char name, UV flag, HV *const stash)
{
GV *const gv = gv_fetchpvn(&name, 1, GV_ADDMULTI|GV_NOTQUAL, SVt_PVHV);
HV *const hv = GvHV(gv);
SV *rv = newSV_type(SVt_RV);
SvRV_set(rv, newSVuv(flag));
SvROK_on(rv);
sv_bless(rv, stash);
sv_unmagic((SV *)hv, PERL_MAGIC_tied);
sv_magic((SV *)hv, rv, PERL_MAGIC_tied, NULL, 0);
SvREFCNT_dec(rv); /* As sv_magic increased it by one. */
}
MODULE = Tie::Hash::NamedCapture PACKAGE = Tie::Hash::NamedCapture
PROTOTYPES: DISABLE
BOOT:
{
HV *const stash = GvSTASH(CvGV(cv));
tie_it(aTHX_ '-', RXapif_ALL, stash);
tie_it(aTHX_ '+', RXapif_ONE, stash);
}
SV *
TIEHASH(package, ...)
const char *package;
PREINIT:
UV flag = RXapif_ONE;
CODE:
mark += 2;
while(mark < sp) {
STRLEN len;
const char *p = SvPV_const(*mark, len);
if(memEQs(p, len, "all"))
flag = SvTRUE(mark[1]) ? RXapif_ALL : RXapif_ONE;
mark += 2;
}
RETVAL = newSV_type(SVt_RV);
sv_setuv(newSVrv(RETVAL, package), flag);
OUTPUT:
RETVAL
void
FETCH(...)
ALIAS:
Tie::Hash::NamedCapture::FETCH = FETCH_ALIAS
Tie::Hash::NamedCapture::STORE = STORE_ALIAS
Tie::Hash::NamedCapture::DELETE = DELETE_ALIAS
Tie::Hash::NamedCapture::CLEAR = CLEAR_ALIAS
Tie::Hash::NamedCapture::EXISTS = EXISTS_ALIAS
Tie::Hash::NamedCapture::SCALAR = SCALAR_ALIAS
PREINIT:
REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
U32 flags;
SV *ret;
const U32 action = ix & ACTION_MASK;
const int expect = ix >> EXPECT_SHIFT;
PPCODE:
if (items != expect)
croak_xs_usage(cv, expect == 2 ? "$key"
: (expect == 3 ? "$key, $value"
: ""));
if (!rx || !SvROK(ST(0))) {
if (ix & UNDEF_FATAL)
Perl_croak_no_modify();
else
XSRETURN_UNDEF;
}
flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
PUTBACK;
ret = RX_ENGINE(rx)->named_buff(aTHX_ (rx), expect >= 2 ? ST(1) : NULL,
expect >= 3 ? ST(2) : NULL, flags | action);
SPAGAIN;
if (ix & DISCARD) {
/* Called with G_DISCARD, so our return stack state is thrown away.
Hence if we were returned anything, free it immediately. */
SvREFCNT_dec(ret);
} else {
PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
}
void
FIRSTKEY(...)
ALIAS:
Tie::Hash::NamedCapture::NEXTKEY = 1
PREINIT:
REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
U32 flags;
SV *ret;
const int expect = ix ? 2 : 1;
const U32 action = ix ? RXapif_NEXTKEY : RXapif_FIRSTKEY;
PPCODE:
if (items != expect)
croak_xs_usage(cv, expect == 2 ? "$lastkey" : "");
if (!rx || !SvROK(ST(0)))
XSRETURN_UNDEF;
flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
PUTBACK;
ret = RX_ENGINE(rx)->named_buff_iter(aTHX_ (rx),
expect >= 2 ? ST(1) : NULL,
flags | action);
SPAGAIN;
PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
void
flags(...)
PPCODE:
EXTEND(SP, 2);
mPUSHu(RXapif_ONE);
mPUSHu(RXapif_ALL);
|
