line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
/* You may distribute under the terms of either the GNU General Public License |
2
|
|
|
|
|
|
|
* or the Artistic License (the same terms as Perl itself) |
3
|
|
|
|
|
|
|
* |
4
|
|
|
|
|
|
|
* (C) Paul Evans, 2021 -- leonerd@leonerd.org.uk |
5
|
|
|
|
|
|
|
*/ |
6
|
|
|
|
|
|
|
#include "EXTERN.h" |
7
|
|
|
|
|
|
|
#include "perl.h" |
8
|
|
|
|
|
|
|
#include "XSUB.h" |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
#include "XSParseSublike.h" |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
#include "perl-backcompat.c.inc" |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
#include "newOP_CUSTOM.c.inc" |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
struct MultiSubOption { |
17
|
|
|
|
|
|
|
int args_min, args_max; |
18
|
|
|
|
|
|
|
CV *cv; |
19
|
|
|
|
|
|
|
}; |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
#define get_optionsav(cv, padix) S_get_optionsav(aTHX_ cv, padix) |
22
|
|
|
|
|
|
|
static AV *S_get_optionsav(pTHX_ CV *cv, PADOFFSET padix) |
23
|
|
|
|
|
|
|
{ |
24
|
16
|
|
|
|
|
|
PADLIST *pl = CvPADLIST(cv); |
25
|
16
|
|
|
|
|
|
AV *optionsav = (AV *)PadARRAY(PadlistARRAY(pl)[1])[padix]; |
26
|
|
|
|
|
|
|
return optionsav; |
27
|
|
|
|
|
|
|
} |
28
|
|
|
|
|
|
|
|
29
|
9
|
|
|
|
|
|
static OP *pp_dispatch_multisub(pTHX) |
30
|
|
|
|
|
|
|
{ |
31
|
9
|
50
|
|
|
|
|
IV nargs = av_count(GvAV(PL_defgv)); |
32
|
9
|
|
|
|
|
|
CV *runcv = find_runcv(0); |
33
|
18
|
|
|
|
|
|
AV *optionsav = get_optionsav(runcv, PL_op->op_targ); |
34
|
|
|
|
|
|
|
|
35
|
9
|
|
|
|
|
|
CV *jumpcv = NULL; |
36
|
|
|
|
|
|
|
|
37
|
9
|
50
|
|
|
|
|
IV noptions = av_count(optionsav); |
38
|
|
|
|
|
|
|
IV optioni; |
39
|
19
|
100
|
|
|
|
|
for(optioni = 0; optioni < noptions; optioni++) { |
40
|
18
|
|
|
|
|
|
struct MultiSubOption *option = (struct MultiSubOption *)AvARRAY(optionsav)[optioni]; |
41
|
|
|
|
|
|
|
|
42
|
18
|
100
|
|
|
|
|
if(nargs < option->args_min) |
43
|
1
|
|
|
|
|
|
continue; |
44
|
17
|
100
|
|
|
|
|
if(option->args_max > -1 && nargs > option->args_max) |
|
|
100
|
|
|
|
|
|
45
|
9
|
|
|
|
|
|
continue; |
46
|
|
|
|
|
|
|
|
47
|
8
|
|
|
|
|
|
jumpcv = option->cv; |
48
|
8
|
|
|
|
|
|
break; |
49
|
|
|
|
|
|
|
} |
50
|
|
|
|
|
|
|
|
51
|
9
|
100
|
|
|
|
|
if(!jumpcv) |
52
|
3
|
50
|
|
|
|
|
croak("Unable to find a function body for a call to &%s::%s having %d arguments", |
|
|
50
|
|
|
|
|
|
53
|
2
|
50
|
|
|
|
|
HvNAME(CvSTASH(runcv)), GvNAME(CvGV(runcv)), nargs); |
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
/* Now pretend to be goto &$cv |
56
|
|
|
|
|
|
|
* Reuse the same PL_op structure and just call that ppfunc */ |
57
|
|
|
|
|
|
|
assert(PL_op->op_flags & OPf_STACKED); |
58
|
8
|
|
|
|
|
|
dSP; |
59
|
8
|
|
|
|
|
|
mPUSHs(newRV_inc((SV *)jumpcv)); |
60
|
8
|
|
|
|
|
|
PUTBACK; |
61
|
|
|
|
|
|
|
assert(SvROK(TOPs) && SvTYPE(SvRV(TOPs)) == SVt_PVCV); |
62
|
8
|
|
|
|
|
|
return (PL_ppaddr[OP_GOTO])(aTHX); |
63
|
|
|
|
|
|
|
} |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
/* XSParseSublikeContext moddata keys */ |
66
|
|
|
|
|
|
|
#define MODDATA_KEY_NAME "Syntax::Keyword::MultiSub/name" |
67
|
|
|
|
|
|
|
#define MODDATA_KEY_COMPMULTICV "Syntax::Keyword::MultiSub/compmulticv" |
68
|
|
|
|
|
|
|
|
69
|
7
|
|
|
|
|
|
static void parse_pre_subparse(pTHX_ struct XSParseSublikeContext *ctx, void *hookdata) |
70
|
|
|
|
|
|
|
{ |
71
|
7
|
|
|
|
|
|
SV *name = ctx->name; |
72
|
|
|
|
|
|
|
|
73
|
7
|
|
|
|
|
|
CV *multicv = get_cvn_flags(SvPVX(name), SvCUR(name), SvUTF8(name) ? SVf_UTF8 : 0); |
74
|
7
|
100
|
|
|
|
|
if(!multicv) { |
75
|
3
|
|
|
|
|
|
ENTER; |
76
|
|
|
|
|
|
|
|
77
|
3
|
|
|
|
|
|
I32 floor_ix = start_subparse(FALSE, 0); |
78
|
3
|
|
|
|
|
|
SAVEFREESV(PL_compcv); |
79
|
|
|
|
|
|
|
|
80
|
3
|
|
|
|
|
|
I32 save_ix = block_start(TRUE); |
81
|
|
|
|
|
|
|
|
82
|
3
|
|
|
|
|
|
PADOFFSET padix = pad_add_name_pvs("@(Syntax::Keyword::MultiSub/options)", 0, NULL, NULL); |
83
|
3
|
|
|
|
|
|
intro_my(); |
84
|
|
|
|
|
|
|
|
85
|
3
|
|
|
|
|
|
OP *dispatchop = newOP_CUSTOM(&pp_dispatch_multisub, OPf_STACKED); |
86
|
3
|
|
|
|
|
|
dispatchop->op_targ = padix; |
87
|
|
|
|
|
|
|
|
88
|
3
|
|
|
|
|
|
OP *body = block_end(save_ix, dispatchop); |
89
|
|
|
|
|
|
|
|
90
|
6
|
|
|
|
|
|
SvREFCNT_inc(PL_compcv); |
91
|
|
|
|
|
|
|
|
92
|
3
|
|
|
|
|
|
multicv = newATTRSUB(floor_ix, newSVOP(OP_CONST, 0, SvREFCNT_inc(name)), NULL, NULL, body); |
93
|
|
|
|
|
|
|
|
94
|
3
|
|
|
|
|
|
LEAVE; |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
|
97
|
7
|
|
|
|
|
|
hv_stores(ctx->moddata, MODDATA_KEY_NAME, SvREFCNT_inc(name)); |
98
|
7
|
|
|
|
|
|
hv_stores(ctx->moddata, MODDATA_KEY_COMPMULTICV, SvREFCNT_inc(multicv)); |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
/* Do not let this sub be installed as a named symbol */ |
101
|
7
|
|
|
|
|
|
ctx->actions &= ~XS_PARSE_SUBLIKE_ACTION_INSTALL_SYMBOL; |
102
|
7
|
|
|
|
|
|
} |
103
|
|
|
|
|
|
|
|
104
|
7
|
|
|
|
|
|
static void parse_post_newcv(pTHX_ struct XSParseSublikeContext *ctx, void *hookdata) |
105
|
|
|
|
|
|
|
{ |
106
|
7
|
|
|
|
|
|
CV *cv = ctx->cv; |
107
|
7
|
50
|
|
|
|
|
if(!cv) |
108
|
|
|
|
|
|
|
return; |
109
|
|
|
|
|
|
|
|
110
|
7
|
|
|
|
|
|
SV *name = *hv_fetchs(ctx->moddata, MODDATA_KEY_NAME, 0); |
111
|
7
|
|
|
|
|
|
CV *multicv = (CV *)*hv_fetchs(ctx->moddata, MODDATA_KEY_COMPMULTICV, 0); |
112
|
|
|
|
|
|
|
|
113
|
7
|
|
|
|
|
|
PADNAMELIST *pln = PadlistNAMES(CvPADLIST(multicv)); |
114
|
|
|
|
|
|
|
/* We can't use pad_findmy_pvn() because it gets upset about seqnums */ |
115
|
|
|
|
|
|
|
PADOFFSET padix; |
116
|
7
|
50
|
|
|
|
|
for(padix = 1; padix <= PadnamelistMAX(pln); padix++) |
117
|
7
|
50
|
|
|
|
|
if(strEQ(PadnamePV(PadnamelistARRAY(pln)[padix]), "@(Syntax::Keyword::MultiSub/options)")) |
118
|
|
|
|
|
|
|
break; |
119
|
|
|
|
|
|
|
assert(padix <= PadnamelistMAX(pln)); |
120
|
|
|
|
|
|
|
|
121
|
14
|
|
|
|
|
|
AV *optionsav = get_optionsav(multicv, padix); |
122
|
11
|
50
|
|
|
|
|
bool final_is_slurpy = av_count(optionsav) && |
|
|
0
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
123
|
4
|
50
|
|
|
|
|
(((struct MultiSubOption *)AvARRAY(optionsav)[AvFILL(optionsav)])->args_max == -1); |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
int args_min, args_max; |
126
|
|
|
|
|
|
|
|
127
|
7
|
|
|
|
|
|
OP *o = CvSTART(cv); |
128
|
7
|
50
|
|
|
|
|
while(o) { |
129
|
|
|
|
|
|
|
redo: |
130
|
14
|
|
|
|
|
|
switch(o->op_type) { |
131
|
|
|
|
|
|
|
case OP_NEXTSTATE: |
132
|
|
|
|
|
|
|
case OP_DBSTATE: |
133
|
7
|
|
|
|
|
|
o = o->op_next; |
134
|
7
|
|
|
|
|
|
goto redo; |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
case OP_ARGCHECK: { |
137
|
|
|
|
|
|
|
#if HAVE_PERL_VERSION(5, 31, 5) |
138
|
|
|
|
|
|
|
struct op_argcheck_aux *aux = (struct op_argcheck_aux *)cUNOP_AUXo->op_aux; |
139
|
|
|
|
|
|
|
char slurpy = aux->slurpy; |
140
|
|
|
|
|
|
|
args_max = aux->params; |
141
|
|
|
|
|
|
|
args_min = args_max - aux->opt_params; |
142
|
|
|
|
|
|
|
#else |
143
|
7
|
|
|
|
|
|
UNOP_AUX_item *aux = cUNOP_AUXo->op_aux; |
144
|
7
|
|
|
|
|
|
char slurpy = aux[2].iv; |
145
|
|
|
|
|
|
|
|
146
|
7
|
|
|
|
|
|
args_max = aux[0].iv; |
147
|
7
|
|
|
|
|
|
args_min = args_max - aux[1].iv; |
148
|
|
|
|
|
|
|
#endif |
149
|
7
|
100
|
|
|
|
|
if(slurpy) { |
150
|
1
|
50
|
|
|
|
|
if(final_is_slurpy) |
151
|
0
|
|
|
|
|
|
croak("Already have a slurpy function body for multi sub %" SVf, name); |
152
|
|
|
|
|
|
|
args_max = -1; |
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
goto done; |
155
|
|
|
|
|
|
|
} |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
default: |
158
|
0
|
|
|
|
|
|
croak("TODO: Unsure how to find argcheck op within %s", PL_op_name[o->op_type]); |
159
|
|
|
|
|
|
|
} |
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
done: ; |
162
|
|
|
|
|
|
|
|
163
|
7
|
50
|
|
|
|
|
IV noptions = av_count(optionsav); |
164
|
|
|
|
|
|
|
IV optioni; |
165
|
12
|
100
|
|
|
|
|
for(optioni = 0; optioni < noptions; optioni++) { |
166
|
5
|
|
|
|
|
|
struct MultiSubOption *option = (struct MultiSubOption *)AvARRAY(optionsav)[optioni]; |
167
|
|
|
|
|
|
|
|
168
|
5
|
50
|
|
|
|
|
if(option->args_max == -1 || args_min > option->args_max) |
|
|
100
|
|
|
|
|
|
169
|
4
|
|
|
|
|
|
continue; |
170
|
1
|
50
|
|
|
|
|
if(args_max < option->args_min) |
171
|
1
|
|
|
|
|
|
continue; |
172
|
|
|
|
|
|
|
|
173
|
0
|
|
|
|
|
|
croak("Ambiguous argument count for multi sub %" SVf, name); |
174
|
|
|
|
|
|
|
} |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
struct MultiSubOption *option; |
177
|
7
|
|
|
|
|
|
Newx(option, 1, struct MultiSubOption); |
178
|
|
|
|
|
|
|
|
179
|
7
|
|
|
|
|
|
option->args_min = args_min; |
180
|
7
|
|
|
|
|
|
option->args_max = args_max; |
181
|
7
|
|
|
|
|
|
option->cv = cv_clone(cv); /* Because it is currently a protosub */ |
182
|
|
|
|
|
|
|
|
183
|
7
|
|
|
|
|
|
av_push(optionsav, (SV *)option); |
184
|
|
|
|
|
|
|
} |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
static struct XSParseSublikeHooks hooks_multi = { |
187
|
|
|
|
|
|
|
.permit_hintkey = "Syntax::Keyword::MultiSub/multi", |
188
|
|
|
|
|
|
|
.flags = XS_PARSE_SUBLIKE_FLAG_PREFIX|XS_PARSE_SUBLIKE_COMPAT_FLAG_DYNAMIC_ACTIONS, |
189
|
|
|
|
|
|
|
.require_parts = XS_PARSE_SUBLIKE_PART_NAME, |
190
|
|
|
|
|
|
|
.pre_subparse = parse_pre_subparse, |
191
|
|
|
|
|
|
|
.post_newcv = parse_post_newcv, |
192
|
|
|
|
|
|
|
}; |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
MODULE = Syntax::Keyword::MultiSub PACKAGE = Syntax::Keyword::MultiSub |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
BOOT: |
197
|
2
|
|
|
|
|
|
boot_xs_parse_sublike(0.15); |
198
|
|
|
|
|
|
|
|
199
|
2
|
|
|
|
|
|
register_xs_parse_sublike("multi", &hooks_multi, NULL); |