Commit | Line | Data |
---|---|---|
6ed7834e NC |
1 | #define PERL_NO_GET_CONTEXT |
2 | ||
b2685f0c NC |
3 | #include "EXTERN.h" |
4 | #include "perl.h" | |
5 | #include "XSUB.h" | |
6 | ||
7 | static AV* | |
8 | S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level); | |
9 | ||
10 | static const struct mro_alg c3_alg = | |
11 | {S_mro_get_linear_isa_c3, "c3", 2, 0, 0}; | |
12 | ||
13 | /* | |
14 | =for apidoc mro_get_linear_isa_c3 | |
15 | ||
796b6530 | 16 | Returns the C3 linearization of C<@ISA> |
b2685f0c NC |
17 | the given stash. The return value is a read-only AV*. |
18 | C<level> should be 0 (it is used internally in this | |
19 | function's recursion). | |
20 | ||
21 | You are responsible for C<SvREFCNT_inc()> on the | |
22 | return value if you plan to store it anywhere | |
23 | semi-permanently (otherwise it might be deleted | |
24 | out from under you the next time the cache is | |
25 | invalidated). | |
26 | ||
27 | =cut | |
28 | */ | |
29 | ||
30 | static AV* | |
31 | S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level) | |
32 | { | |
33 | AV* retval; | |
34 | GV** gvp; | |
35 | GV* gv; | |
36 | AV* isa; | |
37 | const HEK* stashhek; | |
38 | struct mro_meta* meta; | |
39 | ||
40 | assert(HvAUX(stash)); | |
41 | ||
eed1db8e FC |
42 | stashhek = HvENAME_HEK(stash); |
43 | if (!stashhek) stashhek = HvNAME_HEK(stash); | |
b2685f0c NC |
44 | if (!stashhek) |
45 | Perl_croak(aTHX_ "Can't linearize anonymous symbol table"); | |
46 | ||
47 | if (level > 100) | |
147e3846 | 48 | Perl_croak(aTHX_ "Recursive inheritance detected in package '%" HEKf |
65c5495a FC |
49 | "'", |
50 | HEKfARG(stashhek)); | |
b2685f0c NC |
51 | |
52 | meta = HvMROMETA(stash); | |
53 | ||
54 | /* return cache if valid */ | |
55 | if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &c3_alg)))) { | |
56 | return retval; | |
57 | } | |
58 | ||
59 | /* not in cache, make a new one */ | |
60 | ||
61 | gvp = (GV**)hv_fetchs(stash, "ISA", FALSE); | |
62 | isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL; | |
63 | ||
64 | /* For a better idea how the rest of this works, see the much clearer | |
65 | pure perl version in Algorithm::C3 0.01: | |
66 | http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm | |
67 | (later versions go about it differently than this code for speed reasons) | |
68 | */ | |
69 | ||
70 | if(isa && AvFILLp(isa) >= 0) { | |
71 | SV** seqs_ptr; | |
72 | I32 seqs_items; | |
b0413f46 | 73 | HV *tails; |
b2685f0c NC |
74 | AV *const seqs = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV()))); |
75 | I32* heads; | |
76 | ||
77 | /* This builds @seqs, which is an array of arrays. | |
78 | The members of @seqs are the MROs of | |
79 | the members of @ISA, followed by @ISA itself. | |
80 | */ | |
c70927a6 | 81 | SSize_t items = AvFILLp(isa) + 1; |
b2685f0c NC |
82 | SV** isa_ptr = AvARRAY(isa); |
83 | while(items--) { | |
3df5c4b5 | 84 | SV* const isa_item = *isa_ptr ? *isa_ptr : &PL_sv_undef; |
b2685f0c | 85 | HV* const isa_item_stash = gv_stashsv(isa_item, 0); |
3df5c4b5 | 86 | isa_ptr++; |
b2685f0c NC |
87 | if(!isa_item_stash) { |
88 | /* if no stash, make a temporary fake MRO | |
89 | containing just itself */ | |
90 | AV* const isa_lin = newAV(); | |
91 | av_push(isa_lin, newSVsv(isa_item)); | |
92 | av_push(seqs, MUTABLE_SV(isa_lin)); | |
93 | } | |
94 | else { | |
95 | /* recursion */ | |
96 | AV* const isa_lin | |
97 | = S_mro_get_linear_isa_c3(aTHX_ isa_item_stash, level + 1); | |
b0413f46 | 98 | |
a18d9f20 | 99 | if(items == 0 && AvFILLp(seqs) == -1) { |
b0413f46 NC |
100 | /* Only one parent class. For this case, the C3 |
101 | linearisation is this class followed by the parent's | |
b7b1e41b | 102 | linearisation, so don't bother with the expensive |
b0413f46 NC |
103 | calculation. */ |
104 | SV **svp; | |
105 | I32 subrv_items = AvFILLp(isa_lin) + 1; | |
106 | SV *const *subrv_p = AvARRAY(isa_lin); | |
107 | ||
108 | /* Hijack the allocated but unused array seqs to be the | |
109 | return value. It's currently mortalised. */ | |
110 | ||
111 | retval = seqs; | |
112 | ||
113 | av_extend(retval, subrv_items); | |
114 | AvFILLp(retval) = subrv_items; | |
115 | svp = AvARRAY(retval); | |
116 | ||
117 | /* First entry is this class. We happen to make a shared | |
118 | hash key scalar because it's the cheapest and fastest | |
119 | way to do it. */ | |
120 | *svp++ = newSVhek(stashhek); | |
121 | ||
122 | while(subrv_items--) { | |
123 | /* These values are unlikely to be shared hash key | |
124 | scalars, so no point in adding code to optimising | |
125 | for a case that is unlikely to be true. | |
126 | (Or prove me wrong and do it.) */ | |
127 | ||
128 | SV *const val = *subrv_p++; | |
129 | *svp++ = newSVsv(val); | |
130 | } | |
131 | ||
132 | SvREFCNT_inc(retval); | |
133 | ||
134 | goto done; | |
135 | } | |
b2685f0c NC |
136 | av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa_lin))); |
137 | } | |
138 | } | |
139 | av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa))); | |
b0413f46 | 140 | tails = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV()))); |
b2685f0c NC |
141 | |
142 | /* This builds "heads", which as an array of integer array | |
143 | indices, one per seq, which point at the virtual "head" | |
144 | of the seq (initially zero) */ | |
145 | Newxz(heads, AvFILLp(seqs)+1, I32); | |
146 | ||
147 | /* This builds %tails, which has one key for every class | |
148 | mentioned in the tail of any sequence in @seqs (tail meaning | |
149 | everything after the first class, the "head"). The value | |
150 | is how many times this key appears in the tails of @seqs. | |
151 | */ | |
152 | seqs_ptr = AvARRAY(seqs); | |
153 | seqs_items = AvFILLp(seqs) + 1; | |
154 | while(seqs_items--) { | |
155 | AV *const seq = MUTABLE_AV(*seqs_ptr++); | |
156 | I32 seq_items = AvFILLp(seq); | |
157 | if(seq_items > 0) { | |
158 | SV** seq_ptr = AvARRAY(seq) + 1; | |
159 | while(seq_items--) { | |
160 | SV* const seqitem = *seq_ptr++; | |
161 | /* LVALUE fetch will create a new undefined SV if necessary | |
162 | */ | |
163 | HE* const he = hv_fetch_ent(tails, seqitem, 1, 0); | |
164 | if(he) { | |
165 | SV* const val = HeVAL(he); | |
c9875a61 NC |
166 | /* For 5.8.0 and later, sv_inc() with increment undef to |
167 | an IV of 1, which is what we want for a newly created | |
168 | entry. However, for 5.6.x it will become an NV of | |
169 | 1.0, which confuses the SvIVX() checks above. */ | |
170 | if(SvIOK(val)) { | |
171 | SvIV_set(val, SvIVX(val) + 1); | |
172 | } else { | |
173 | sv_setiv(val, 1); | |
174 | } | |
b2685f0c NC |
175 | } |
176 | } | |
177 | } | |
178 | } | |
179 | ||
180 | /* Initialize retval to build the return value in */ | |
181 | retval = newAV(); | |
182 | av_push(retval, newSVhek(stashhek)); /* us first */ | |
183 | ||
184 | /* This loop won't terminate until we either finish building | |
185 | the MRO, or get an exception. */ | |
186 | while(1) { | |
187 | SV* cand = NULL; | |
188 | SV* winner = NULL; | |
189 | int s; | |
190 | ||
191 | /* "foreach $seq (@seqs)" */ | |
192 | SV** const avptr = AvARRAY(seqs); | |
193 | for(s = 0; s <= AvFILLp(seqs); s++) { | |
194 | SV** svp; | |
195 | AV * const seq = MUTABLE_AV(avptr[s]); | |
196 | SV* seqhead; | |
197 | if(!seq) continue; /* skip empty seqs */ | |
198 | svp = av_fetch(seq, heads[s], 0); | |
199 | seqhead = *svp; /* seqhead = head of this seq */ | |
200 | if(!winner) { | |
201 | HE* tail_entry; | |
202 | SV* val; | |
203 | /* if we haven't found a winner for this round yet, | |
204 | and this seqhead is not in tails (or the count | |
205 | for it in tails has dropped to zero), then this | |
206 | seqhead is our new winner, and is added to the | |
207 | final MRO immediately */ | |
208 | cand = seqhead; | |
209 | if((tail_entry = hv_fetch_ent(tails, cand, 0, 0)) | |
210 | && (val = HeVAL(tail_entry)) | |
211 | && (SvIVX(val) > 0)) | |
212 | continue; | |
213 | winner = newSVsv(cand); | |
214 | av_push(retval, winner); | |
215 | /* note however that even when we find a winner, | |
216 | we continue looping over @seqs to do housekeeping */ | |
217 | } | |
218 | if(!sv_cmp(seqhead, winner)) { | |
219 | /* Once we have a winner (including the iteration | |
220 | where we first found him), inc the head ptr | |
221 | for any seq which had the winner as a head, | |
222 | NULL out any seq which is now empty, | |
223 | and adjust tails for consistency */ | |
224 | ||
225 | const int new_head = ++heads[s]; | |
226 | if(new_head > AvFILLp(seq)) { | |
227 | SvREFCNT_dec(avptr[s]); | |
228 | avptr[s] = NULL; | |
229 | } | |
230 | else { | |
231 | HE* tail_entry; | |
232 | SV* val; | |
233 | /* Because we know this new seqhead used to be | |
234 | a tail, we can assume it is in tails and has | |
235 | a positive value, which we need to dec */ | |
236 | svp = av_fetch(seq, new_head, 0); | |
237 | seqhead = *svp; | |
238 | tail_entry = hv_fetch_ent(tails, seqhead, 0, 0); | |
239 | val = HeVAL(tail_entry); | |
240 | sv_dec(val); | |
241 | } | |
242 | } | |
243 | } | |
244 | ||
245 | /* if we found no candidates, we are done building the MRO. | |
246 | !cand means no seqs have any entries left to check */ | |
247 | if(!cand) { | |
248 | Safefree(heads); | |
249 | break; | |
250 | } | |
251 | ||
252 | /* If we had candidates, but nobody won, then the @ISA | |
253 | hierarchy is not C3-incompatible */ | |
254 | if(!winner) { | |
b1172053 FR |
255 | SV *errmsg; |
256 | I32 i; | |
257 | ||
7ad9a4ff | 258 | errmsg = newSVpvf( |
147e3846 | 259 | "Inconsistent hierarchy during C3 merge of class '%" HEKf "':\n\t" |
7ad9a4ff | 260 | "current merge results [\n", |
65c5495a | 261 | HEKfARG(stashhek)); |
47cbe89d | 262 | for (i = 0; i < av_count(retval); i++) { |
b1172053 | 263 | SV **elem = av_fetch(retval, i, 0); |
147e3846 | 264 | sv_catpvf(errmsg, "\t\t%" SVf ",\n", SVfARG(*elem)); |
b1172053 | 265 | } |
147e3846 | 266 | sv_catpvf(errmsg, "\t]\n\tmerging failed on '%" SVf "'", SVfARG(cand)); |
b1172053 | 267 | |
b2685f0c NC |
268 | /* we have to do some cleanup before we croak */ |
269 | ||
270 | SvREFCNT_dec(retval); | |
271 | Safefree(heads); | |
272 | ||
147e3846 | 273 | Perl_croak(aTHX_ "%" SVf, SVfARG(errmsg)); |
b2685f0c NC |
274 | } |
275 | } | |
276 | } | |
277 | else { /* @ISA was undefined or empty */ | |
278 | /* build a retval containing only ourselves */ | |
279 | retval = newAV(); | |
280 | av_push(retval, newSVhek(stashhek)); | |
281 | } | |
282 | ||
b0413f46 | 283 | done: |
b2685f0c NC |
284 | /* we don't want anyone modifying the cache entry but us, |
285 | and we do so by replacing it completely */ | |
286 | SvREADONLY_on(retval); | |
287 | ||
288 | return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &c3_alg, | |
289 | MUTABLE_SV(retval))); | |
b2685f0c NC |
290 | } |
291 | ||
292 | ||
293 | /* These two are static helpers for next::method and friends, | |
294 | and re-implement a bunch of the code from pp_caller() in | |
295 | a more efficient manner for this particular usage. | |
296 | */ | |
297 | ||
298 | static I32 | |
299 | __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) { | |
300 | I32 i; | |
301 | for (i = startingblock; i >= 0; i--) { | |
302 | if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i; | |
303 | } | |
304 | return i; | |
305 | } | |
306 | ||
1e9bd118 | 307 | MODULE = mro PACKAGE = mro PREFIX = mro_ |
b2685f0c NC |
308 | |
309 | void | |
1e9bd118 NC |
310 | mro_get_linear_isa(...) |
311 | PROTOTYPE: $;$ | |
312 | PREINIT: | |
313 | AV* RETVAL; | |
314 | HV* class_stash; | |
315 | SV* classname; | |
316 | PPCODE: | |
317 | if(items < 1 || items > 2) | |
318 | croak_xs_usage(cv, "classname [, type ]"); | |
319 | ||
320 | classname = ST(0); | |
321 | class_stash = gv_stashsv(classname, 0); | |
322 | ||
323 | if(!class_stash) { | |
324 | /* No stash exists yet, give them just the classname */ | |
325 | AV* isalin = newAV(); | |
326 | av_push(isalin, newSVsv(classname)); | |
327 | ST(0) = sv_2mortal(newRV_noinc(MUTABLE_SV(isalin))); | |
328 | XSRETURN(1); | |
329 | } | |
330 | else if(items > 1) { | |
331 | const struct mro_alg *const algo = Perl_mro_get_from_name(aTHX_ ST(1)); | |
332 | if (!algo) | |
147e3846 | 333 | Perl_croak(aTHX_ "Invalid mro name: '%" SVf "'", ST(1)); |
1e9bd118 NC |
334 | RETVAL = algo->resolve(aTHX_ class_stash, 0); |
335 | } | |
336 | else { | |
337 | RETVAL = mro_get_linear_isa(class_stash); | |
338 | } | |
339 | ST(0) = newRV_inc(MUTABLE_SV(RETVAL)); | |
340 | sv_2mortal(ST(0)); | |
341 | XSRETURN(1); | |
342 | ||
343 | void | |
344 | mro_set_mro(...) | |
345 | PROTOTYPE: $$ | |
346 | PREINIT: | |
347 | SV* classname; | |
1e9bd118 NC |
348 | HV* class_stash; |
349 | struct mro_meta* meta; | |
350 | PPCODE: | |
351 | if (items != 2) | |
352 | croak_xs_usage(cv, "classname, type"); | |
353 | ||
354 | classname = ST(0); | |
355 | class_stash = gv_stashsv(classname, GV_ADD); | |
147e3846 | 356 | if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%" SVf "'!", SVfARG(classname)); |
1e9bd118 NC |
357 | meta = HvMROMETA(class_stash); |
358 | ||
359 | Perl_mro_set_mro(aTHX_ meta, ST(1)); | |
360 | ||
361 | XSRETURN_EMPTY; | |
362 | ||
363 | void | |
364 | mro_get_mro(...) | |
365 | PROTOTYPE: $ | |
366 | PREINIT: | |
367 | SV* classname; | |
368 | HV* class_stash; | |
369 | PPCODE: | |
370 | if (items != 1) | |
371 | croak_xs_usage(cv, "classname"); | |
372 | ||
373 | classname = ST(0); | |
374 | class_stash = gv_stashsv(classname, 0); | |
375 | ||
fbb5a95c NC |
376 | if (class_stash) { |
377 | const struct mro_alg *const meta = HvMROMETA(class_stash)->mro_which; | |
378 | ST(0) = newSVpvn_flags(meta->name, meta->length, | |
379 | SVs_TEMP | |
380 | | ((meta->kflags & HVhek_UTF8) ? SVf_UTF8 : 0)); | |
381 | } else { | |
382 | ST(0) = newSVpvn_flags("dfs", 3, SVs_TEMP); | |
383 | } | |
1e9bd118 NC |
384 | XSRETURN(1); |
385 | ||
386 | void | |
387 | mro_get_isarev(...) | |
388 | PROTOTYPE: $ | |
389 | PREINIT: | |
390 | SV* classname; | |
391 | HE* he; | |
392 | HV* isarev; | |
393 | AV* ret_array; | |
394 | PPCODE: | |
395 | if (items != 1) | |
396 | croak_xs_usage(cv, "classname"); | |
397 | ||
398 | classname = ST(0); | |
399 | ||
400 | he = hv_fetch_ent(PL_isarev, classname, 0, 0); | |
401 | isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL; | |
402 | ||
403 | ret_array = newAV(); | |
404 | if(isarev) { | |
405 | HE* iter; | |
406 | hv_iterinit(isarev); | |
407 | while((iter = hv_iternext(isarev))) | |
408 | av_push(ret_array, newSVsv(hv_iterkeysv(iter))); | |
409 | } | |
410 | mXPUSHs(newRV_noinc(MUTABLE_SV(ret_array))); | |
411 | ||
412 | PUTBACK; | |
413 | ||
414 | void | |
415 | mro_is_universal(...) | |
416 | PROTOTYPE: $ | |
417 | PREINIT: | |
418 | SV* classname; | |
419 | HV* isarev; | |
420 | char* classname_pv; | |
421 | STRLEN classname_len; | |
422 | HE* he; | |
423 | PPCODE: | |
424 | if (items != 1) | |
425 | croak_xs_usage(cv, "classname"); | |
426 | ||
427 | classname = ST(0); | |
428 | ||
429 | classname_pv = SvPV(classname,classname_len); | |
430 | ||
431 | he = hv_fetch_ent(PL_isarev, classname, 0, 0); | |
432 | isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL; | |
433 | ||
a3c1b832 YO |
434 | if((memEQs(classname_pv, classname_len, "UNIVERSAL")) |
435 | || (isarev && hv_existss(isarev, "UNIVERSAL"))) | |
1e9bd118 NC |
436 | XSRETURN_YES; |
437 | else | |
438 | XSRETURN_NO; | |
439 | ||
440 | ||
441 | void | |
a4133167 | 442 | mro_invalidate_all_method_caches(...) |
1e9bd118 NC |
443 | PROTOTYPE: |
444 | PPCODE: | |
445 | if (items != 0) | |
446 | croak_xs_usage(cv, ""); | |
447 | ||
448 | PL_sub_generation++; | |
449 | ||
450 | XSRETURN_EMPTY; | |
451 | ||
452 | void | |
453 | mro_get_pkg_gen(...) | |
454 | PROTOTYPE: $ | |
455 | PREINIT: | |
456 | SV* classname; | |
457 | HV* class_stash; | |
458 | PPCODE: | |
459 | if(items != 1) | |
460 | croak_xs_usage(cv, "classname"); | |
461 | ||
462 | classname = ST(0); | |
463 | ||
464 | class_stash = gv_stashsv(classname, 0); | |
465 | ||
466 | mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0); | |
467 | ||
468 | PUTBACK; | |
469 | ||
470 | void | |
471 | mro__nextcan(...) | |
b2685f0c NC |
472 | PREINIT: |
473 | SV* self = ST(0); | |
474 | const I32 throw_nomethod = SvIVX(ST(1)); | |
5aaab254 KW |
475 | I32 cxix = cxstack_ix; |
476 | const PERL_CONTEXT *ccstack = cxstack; | |
b2685f0c NC |
477 | const PERL_SI *top_si = PL_curstackinfo; |
478 | HV* selfstash; | |
479 | SV *stashname; | |
e34b9a6d JH |
480 | const char *fq_subname = NULL; |
481 | const char *subname = NULL; | |
204e6232 | 482 | bool subname_utf8 = 0; |
b2685f0c NC |
483 | STRLEN stashname_len; |
484 | STRLEN subname_len; | |
485 | SV* sv; | |
486 | GV** gvp; | |
487 | AV* linear_av; | |
488 | SV** linear_svp; | |
489 | const char *hvname; | |
490 | I32 entries; | |
491 | struct mro_meta* selfmeta; | |
492 | HV* nmcache; | |
493 | I32 i; | |
494 | PPCODE: | |
495 | PERL_UNUSED_ARG(cv); | |
496 | ||
497 | if(sv_isobject(self)) | |
498 | selfstash = SvSTASH(SvRV(self)); | |
499 | else | |
500 | selfstash = gv_stashsv(self, GV_ADD); | |
501 | ||
502 | assert(selfstash); | |
503 | ||
504 | hvname = HvNAME_get(selfstash); | |
505 | if (!hvname) | |
506 | Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); | |
507 | ||
508 | /* This block finds the contextually-enclosing fully-qualified subname, | |
509 | much like looking at (caller($i))[3] until you find a real sub that | |
510 | isn't ANON, etc (also skips over pureperl next::method, etc) */ | |
511 | for(i = 0; i < 2; i++) { | |
512 | cxix = __dopoptosub_at(ccstack, cxix); | |
513 | for (;;) { | |
514 | GV* cvgv; | |
515 | STRLEN fq_subname_len; | |
516 | ||
517 | /* we may be in a higher stacklevel, so dig down deeper */ | |
518 | while (cxix < 0) { | |
519 | if(top_si->si_type == PERLSI_MAIN) | |
520 | Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context"); | |
521 | top_si = top_si->si_prev; | |
522 | ccstack = top_si->si_cxstack; | |
523 | cxix = __dopoptosub_at(ccstack, top_si->si_cxix); | |
524 | } | |
525 | ||
526 | if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB | |
527 | || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) { | |
528 | cxix = __dopoptosub_at(ccstack, cxix - 1); | |
529 | continue; | |
530 | } | |
531 | ||
532 | { | |
533 | const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1); | |
534 | if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) { | |
535 | if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) { | |
536 | cxix = dbcxix; | |
537 | continue; | |
538 | } | |
539 | } | |
540 | } | |
541 | ||
542 | cvgv = CvGV(ccstack[cxix].blk_sub.cv); | |
543 | ||
544 | if(!isGV(cvgv)) { | |
545 | cxix = __dopoptosub_at(ccstack, cxix - 1); | |
546 | continue; | |
547 | } | |
548 | ||
549 | /* we found a real sub here */ | |
8e234d89 | 550 | sv = sv_newmortal(); |
b2685f0c NC |
551 | |
552 | gv_efullname3(sv, cvgv, NULL); | |
553 | ||
9c1314f0 NC |
554 | if(SvPOK(sv)) { |
555 | fq_subname = SvPVX(sv); | |
556 | fq_subname_len = SvCUR(sv); | |
557 | ||
204e6232 | 558 | subname_utf8 = SvUTF8(sv) ? 1 : 0; |
9c1314f0 NC |
559 | subname = strrchr(fq_subname, ':'); |
560 | } else { | |
561 | subname = NULL; | |
562 | } | |
b2685f0c | 563 | |
b2685f0c NC |
564 | if(!subname) |
565 | Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method"); | |
566 | ||
567 | subname++; | |
568 | subname_len = fq_subname_len - (subname - fq_subname); | |
a3c1b832 | 569 | if(memEQs(subname, subname_len, "__ANON__")) { |
b2685f0c NC |
570 | cxix = __dopoptosub_at(ccstack, cxix - 1); |
571 | continue; | |
572 | } | |
573 | break; | |
574 | } | |
575 | cxix--; | |
576 | } | |
577 | ||
578 | /* If we made it to here, we found our context */ | |
579 | ||
580 | /* Initialize the next::method cache for this stash | |
581 | if necessary */ | |
582 | selfmeta = HvMROMETA(selfstash); | |
583 | if(!(nmcache = selfmeta->mro_nextmethod)) { | |
584 | nmcache = selfmeta->mro_nextmethod = newHV(); | |
585 | } | |
586 | else { /* Use the cached coderef if it exists */ | |
587 | HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0); | |
588 | if (cache_entry) { | |
589 | SV* const val = HeVAL(cache_entry); | |
590 | if(val == &PL_sv_undef) { | |
591 | if(throw_nomethod) | |
65c5495a | 592 | Perl_croak(aTHX_ |
147e3846 | 593 | "No next::method '%" SVf "' found for %" HEKf, |
7ad9a4ff BF |
594 | SVfARG(newSVpvn_flags(subname, subname_len, |
595 | SVs_TEMP | ( subname_utf8 ? SVf_UTF8 : 0 ) )), | |
65c5495a | 596 | HEKfARG( HvNAME_HEK(selfstash) )); |
b2685f0c NC |
597 | XSRETURN_EMPTY; |
598 | } | |
599 | mXPUSHs(newRV_inc(val)); | |
600 | XSRETURN(1); | |
601 | } | |
602 | } | |
603 | ||
604 | /* beyond here is just for cache misses, so perf isn't as critical */ | |
605 | ||
606 | stashname_len = subname - fq_subname - 2; | |
204e6232 BF |
607 | stashname = newSVpvn_flags(fq_subname, stashname_len, |
608 | SVs_TEMP | (subname_utf8 ? SVf_UTF8 : 0)); | |
b2685f0c NC |
609 | |
610 | /* has ourselves at the top of the list */ | |
611 | linear_av = S_mro_get_linear_isa_c3(aTHX_ selfstash, 0); | |
612 | ||
613 | linear_svp = AvARRAY(linear_av); | |
614 | entries = AvFILLp(linear_av) + 1; | |
615 | ||
616 | /* Walk down our MRO, skipping everything up | |
617 | to the contextually enclosing class */ | |
618 | while (entries--) { | |
619 | SV * const linear_sv = *linear_svp++; | |
620 | assert(linear_sv); | |
621 | if(sv_eq(linear_sv, stashname)) | |
622 | break; | |
623 | } | |
624 | ||
625 | /* Now search the remainder of the MRO for the | |
626 | same method name as the contextually enclosing | |
627 | method */ | |
628 | if(entries > 0) { | |
629 | while (entries--) { | |
630 | SV * const linear_sv = *linear_svp++; | |
631 | HV* curstash; | |
632 | GV* candidate; | |
633 | CV* cand_cv; | |
634 | ||
635 | assert(linear_sv); | |
636 | curstash = gv_stashsv(linear_sv, FALSE); | |
637 | ||
638 | if (!curstash) { | |
639 | if (ckWARN(WARN_SYNTAX)) | |
65c5495a | 640 | Perl_warner(aTHX_ packWARN(WARN_SYNTAX), |
147e3846 | 641 | "Can't locate package %" SVf " for @%" HEKf "::ISA", |
7ad9a4ff | 642 | (void*)linear_sv, |
65c5495a | 643 | HEKfARG( HvNAME_HEK(selfstash) )); |
b2685f0c NC |
644 | continue; |
645 | } | |
646 | ||
647 | assert(curstash); | |
648 | ||
204e6232 | 649 | gvp = (GV**)hv_fetch(curstash, subname, |
c60dbbc3 | 650 | subname_utf8 ? -(I32)subname_len : (I32)subname_len, 0); |
b2685f0c NC |
651 | if (!gvp) continue; |
652 | ||
653 | candidate = *gvp; | |
654 | assert(candidate); | |
655 | ||
656 | if (SvTYPE(candidate) != SVt_PVGV) | |
204e6232 BF |
657 | gv_init_pvn(candidate, curstash, subname, subname_len, |
658 | GV_ADDMULTI|(subname_utf8 ? SVf_UTF8 : 0)); | |
b2685f0c NC |
659 | |
660 | /* Notably, we only look for real entries, not method cache | |
661 | entries, because in C3 the method cache of a parent is not | |
662 | valid for the child */ | |
663 | if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) { | |
664 | SvREFCNT_inc_simple_void_NN(MUTABLE_SV(cand_cv)); | |
59d8e2ce | 665 | (void)hv_store_ent(nmcache, sv, MUTABLE_SV(cand_cv), 0); |
b2685f0c NC |
666 | mXPUSHs(newRV_inc(MUTABLE_SV(cand_cv))); |
667 | XSRETURN(1); | |
668 | } | |
669 | } | |
670 | } | |
671 | ||
59d8e2ce | 672 | (void)hv_store_ent(nmcache, sv, &PL_sv_undef, 0); |
b2685f0c | 673 | if(throw_nomethod) |
147e3846 | 674 | Perl_croak(aTHX_ "No next::method '%" SVf "' found for %" HEKf, |
7ad9a4ff BF |
675 | SVfARG(newSVpvn_flags(subname, subname_len, |
676 | SVs_TEMP | ( subname_utf8 ? SVf_UTF8 : 0 ) )), | |
65c5495a | 677 | HEKfARG( HvNAME_HEK(selfstash) )); |
b2685f0c NC |
678 | XSRETURN_EMPTY; |
679 | ||
680 | BOOT: | |
681 | Perl_mro_register(aTHX_ &c3_alg); |