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