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