This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Typo fix by Abigail
[perl5.git] / mro.c
CommitLineData
e1a479c5
BB
1/* mro.c
2 *
3 * Copyright (c) 2007 Brandon L Black
4 *
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
7 *
8 */
9
10/*
cac98860
RGS
11 * "Which order shall we go in?" said Frodo. "Eldest first, or quickest first?
12 * You'll be last either way, Master Peregrin."
13 */
14
15/*
e1a479c5
BB
16=head1 MRO Functions
17
18These functions are related to the method resolution order of perl classes
19
20=cut
21*/
22
23#include "EXTERN.h"
24#include "perl.h"
25
26struct mro_meta*
27Perl_mro_meta_init(pTHX_ HV* stash)
28{
9fe4aecf 29 struct mro_meta* newmeta;
e1a479c5
BB
30
31 assert(stash);
32 assert(HvAUX(stash));
33 assert(!(HvAUX(stash)->xhv_mro_meta));
183086be 34 Newxz(newmeta, 1, struct mro_meta);
9fe4aecf
RGS
35 HvAUX(stash)->xhv_mro_meta = newmeta;
36 newmeta->sub_generation = 1;
e1a479c5
BB
37
38 /* Manually flag UNIVERSAL as being universal.
39 This happens early in perl booting (when universal.c
40 does the newXS calls for UNIVERSAL::*), and infects
41 other packages as they are added to UNIVERSAL's MRO
42 */
43 if(HvNAMELEN_get(stash) == 9
44 && strEQ(HEK_KEY(HvAUX(stash)->xhv_name), "UNIVERSAL")) {
45 HvMROMETA(stash)->is_universal = 1;
46 }
47
48 return newmeta;
49}
50
51#if defined(USE_ITHREADS)
52
53/* for sv_dup on new threads */
54struct mro_meta*
55Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
56{
e1a479c5
BB
57 struct mro_meta* newmeta;
58
59 assert(smeta);
60
33e12d9d
NC
61 Newx(newmeta, 1, struct mro_meta);
62 Copy(smeta, newmeta, 1, struct mro_meta);
63
64 if (newmeta->mro_linear_dfs)
65 newmeta->mro_linear_dfs
66 = (AV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_linear_dfs, param));
67 if (newmeta->mro_linear_c3)
68 newmeta->mro_linear_c3
69 = (AV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_linear_c3, param));
70 if (newmeta->mro_isarev)
71 newmeta->mro_isarev
72 = (HV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_isarev, param));
73 if (newmeta->mro_nextmethod)
74 newmeta->mro_nextmethod
75 = (HV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_nextmethod, param));
e1a479c5
BB
76
77 return newmeta;
78}
79
80#endif /* USE_ITHREADS */
81
82/*
83=for apidoc mro_get_linear_isa_dfs
84
85Returns the Depth-First Search linearization of @ISA
86the given stash. The return value is a read-only AV*.
87C<level> should be 0 (it is used internally in this
88function's recursion).
89
1c908217
RGS
90You are responsible for C<SvREFCNT_inc()> on the
91return value if you plan to store it anywhere
92semi-permanently (otherwise it might be deleted
93out from under you the next time the cache is
94invalidated).
95
e1a479c5
BB
96=cut
97*/
98AV*
99Perl_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level)
100{
101 AV* retval;
102 GV** gvp;
103 GV* gv;
104 AV* av;
105 SV** svp;
106 I32 items;
107 AV* subrv;
108 SV** subrv_p;
109 I32 subrv_items;
110 const char* stashname;
111 struct mro_meta* meta;
112
113 assert(stash);
114 assert(HvAUX(stash));
115
116 stashname = HvNAME_get(stash);
117 if (!stashname)
118 Perl_croak(aTHX_
119 "Can't linearize anonymous symbol table");
120
121 if (level > 100)
122 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
123 stashname);
124
125 meta = HvMROMETA(stash);
1c908217
RGS
126
127 /* return cache if valid */
e1a479c5 128 if((retval = meta->mro_linear_dfs)) {
e1a479c5
BB
129 return retval;
130 }
131
132 /* not in cache, make a new one */
1c908217 133
e1a479c5
BB
134 retval = newAV();
135 av_push(retval, newSVpv(stashname, 0)); /* add ourselves at the top */
136
1c908217 137 /* fetch our @ISA */
e1a479c5
BB
138 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
139 av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
140
640da897 141 if(av && AvFILLp(av) >= 0) {
1c908217
RGS
142
143 /* "stored" is used to keep track of all of the classnames
144 we have added to the MRO so far, so we can do a quick
145 exists check and avoid adding duplicate classnames to
146 the MRO as we go. */
147
e1a479c5
BB
148 HV* stored = (HV*)sv_2mortal((SV*)newHV());
149 svp = AvARRAY(av);
150 items = AvFILLp(av) + 1;
1c908217
RGS
151
152 /* foreach(@ISA) */
e1a479c5
BB
153 while (items--) {
154 SV* const sv = *svp++;
155 HV* const basestash = gv_stashsv(sv, 0);
156
157 if (!basestash) {
1c908217
RGS
158 /* if no stash exists for this @ISA member,
159 simply add it to the MRO and move on */
e1a479c5
BB
160 if(!hv_exists_ent(stored, sv, 0)) {
161 av_push(retval, newSVsv(sv));
162 hv_store_ent(stored, sv, &PL_sv_undef, 0);
163 }
164 }
165 else {
1c908217
RGS
166 /* otherwise, recurse into ourselves for the MRO
167 of this @ISA member, and append their MRO to ours */
e1a479c5
BB
168 subrv = mro_get_linear_isa_dfs(basestash, level + 1);
169 subrv_p = AvARRAY(subrv);
170 subrv_items = AvFILLp(subrv) + 1;
171 while(subrv_items--) {
172 SV* subsv = *subrv_p++;
173 if(!hv_exists_ent(stored, subsv, 0)) {
174 av_push(retval, newSVsv(subsv));
175 hv_store_ent(stored, subsv, &PL_sv_undef, 0);
176 }
177 }
178 }
179 }
180 }
181
1c908217
RGS
182 /* we don't want anyone modifying the cache entry but us,
183 and we do so by replacing it completely */
e1a479c5 184 SvREADONLY_on(retval);
1c908217 185
e1a479c5
BB
186 meta->mro_linear_dfs = retval;
187 return retval;
188}
189
190/*
191=for apidoc mro_get_linear_isa_c3
192
193Returns the C3 linearization of @ISA
194the given stash. The return value is a read-only AV*.
195C<level> should be 0 (it is used internally in this
196function's recursion).
197
1c908217
RGS
198You are responsible for C<SvREFCNT_inc()> on the
199return value if you plan to store it anywhere
200semi-permanently (otherwise it might be deleted
201out from under you the next time the cache is
202invalidated).
203
e1a479c5
BB
204=cut
205*/
206
207AV*
208Perl_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level)
209{
210 AV* retval;
211 GV** gvp;
212 GV* gv;
213 AV* isa;
214 const char* stashname;
215 STRLEN stashname_len;
216 struct mro_meta* meta;
217
218 assert(stash);
219 assert(HvAUX(stash));
220
221 stashname = HvNAME_get(stash);
222 stashname_len = HvNAMELEN_get(stash);
223 if (!stashname)
224 Perl_croak(aTHX_
225 "Can't linearize anonymous symbol table");
226
227 if (level > 100)
228 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
229 stashname);
230
231 meta = HvMROMETA(stash);
1c908217
RGS
232
233 /* return cache if valid */
e1a479c5 234 if((retval = meta->mro_linear_c3)) {
e1a479c5
BB
235 return retval;
236 }
237
238 /* not in cache, make a new one */
239
240 retval = newAV();
241 av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
242
243 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
244 isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
245
1c908217
RGS
246 /* For a better idea how the rest of this works, see the much clearer
247 pure perl version in Algorithm::C3 0.01:
248 http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
249 (later versions go about it differently than this code for speed reasons)
250 */
e1a479c5
BB
251 if(isa && AvFILLp(isa) >= 0) {
252 SV** seqs_ptr;
253 I32 seqs_items;
254 HV* tails = (HV*)sv_2mortal((SV*)newHV());
255 AV* seqs = (AV*)sv_2mortal((SV*)newAV());
256 I32 items = AvFILLp(isa) + 1;
257 SV** isa_ptr = AvARRAY(isa);
258 while(items--) {
259 AV* isa_lin;
260 SV* isa_item = *isa_ptr++;
261 HV* isa_item_stash = gv_stashsv(isa_item, 0);
262 if(!isa_item_stash) {
263 isa_lin = newAV();
264 av_push(isa_lin, newSVsv(isa_item));
265 }
266 else {
267 isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1); /* recursion */
268 }
269 av_push(seqs, (SV*)av_make(AvFILLp(isa_lin)+1, AvARRAY(isa_lin)));
270 }
271 av_push(seqs, (SV*)av_make(AvFILLp(isa)+1, AvARRAY(isa)));
272
273 seqs_ptr = AvARRAY(seqs);
274 seqs_items = AvFILLp(seqs) + 1;
275 while(seqs_items--) {
276 AV* seq = (AV*)*seqs_ptr++;
277 I32 seq_items = AvFILLp(seq);
278 if(seq_items > 0) {
279 SV** seq_ptr = AvARRAY(seq) + 1;
280 while(seq_items--) {
281 SV* seqitem = *seq_ptr++;
282 HE* he = hv_fetch_ent(tails, seqitem, 0, 0);
283 if(!he) {
284 hv_store_ent(tails, seqitem, newSViv(1), 0);
285 }
286 else {
287 SV* val = HeVAL(he);
288 sv_inc(val);
289 }
290 }
291 }
292 }
293
294 while(1) {
295 SV* seqhead = NULL;
296 SV* cand = NULL;
297 SV* winner = NULL;
298 SV* val;
299 HE* tail_entry;
300 AV* seq;
301 SV** avptr = AvARRAY(seqs);
302 items = AvFILLp(seqs)+1;
303 while(items--) {
304 SV** svp;
305 seq = (AV*)*avptr++;
306 if(AvFILLp(seq) < 0) continue;
307 svp = av_fetch(seq, 0, 0);
308 seqhead = *svp;
309 if(!winner) {
310 cand = seqhead;
311 if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
312 && (val = HeVAL(tail_entry))
313 && (SvIVx(val) > 0))
314 continue;
315 winner = newSVsv(cand);
316 av_push(retval, winner);
317 }
318 if(!sv_cmp(seqhead, winner)) {
319
320 /* this is basically shift(@seq) in void context */
321 SvREFCNT_dec(*AvARRAY(seq));
322 *AvARRAY(seq) = &PL_sv_undef;
323 AvARRAY(seq) = AvARRAY(seq) + 1;
324 AvMAX(seq)--;
325 AvFILLp(seq)--;
326
327 if(AvFILLp(seq) < 0) continue;
328 svp = av_fetch(seq, 0, 0);
329 seqhead = *svp;
330 tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
331 val = HeVAL(tail_entry);
332 sv_dec(val);
333 }
334 }
335 if(!cand) break;
336 if(!winner) {
337 SvREFCNT_dec(retval);
338 Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
339 "merging failed on parent '%"SVf"'", stashname, SVfARG(cand));
340 }
341 }
342 }
343
1c908217
RGS
344 /* we don't want anyone modifying the cache entry but us,
345 and we do so by replacing it completely */
e1a479c5 346 SvREADONLY_on(retval);
1c908217 347
e1a479c5
BB
348 meta->mro_linear_c3 = retval;
349 return retval;
350}
351
352/*
353=for apidoc mro_get_linear_isa
354
355Returns either C<mro_get_linear_isa_c3> or
356C<mro_get_linear_isa_dfs> for the given stash,
357dependant upon which MRO is in effect
358for that stash. The return value is a
359read-only AV*.
360
1c908217
RGS
361You are responsible for C<SvREFCNT_inc()> on the
362return value if you plan to store it anywhere
363semi-permanently (otherwise it might be deleted
364out from under you the next time the cache is
365invalidated).
366
e1a479c5
BB
367=cut
368*/
369AV*
370Perl_mro_get_linear_isa(pTHX_ HV *stash)
371{
372 struct mro_meta* meta;
373 assert(stash);
374 assert(HvAUX(stash));
375
376 meta = HvMROMETA(stash);
377 if(meta->mro_which == MRO_DFS) {
378 return mro_get_linear_isa_dfs(stash, 0);
379 } else if(meta->mro_which == MRO_C3) {
380 return mro_get_linear_isa_c3(stash, 0);
381 } else {
14f97ce6 382 Perl_croak(aTHX_ "panic: invalid MRO!");
e1a479c5
BB
383 }
384}
385
386/*
387=for apidoc mro_isa_changed_in
388
1c908217 389Takes the necessary steps (cache invalidations, mostly)
e1a479c5
BB
390when the @ISA of the given package has changed. Invoked
391by the C<setisa> magic, should not need to invoke directly.
392
393=cut
394*/
395void
396Perl_mro_isa_changed_in(pTHX_ HV* stash)
397{
398 dVAR;
399 HV* isarev;
400 AV* linear_mro;
401 HE* iter;
402 SV** svp;
403 I32 items;
404 struct mro_meta* meta;
405 char* stashname;
406
407 stashname = HvNAME_get(stash);
408
409 /* wipe out the cached linearizations for this stash */
410 meta = HvMROMETA(stash);
411 SvREFCNT_dec((SV*)meta->mro_linear_dfs);
412 SvREFCNT_dec((SV*)meta->mro_linear_c3);
413 meta->mro_linear_dfs = NULL;
414 meta->mro_linear_c3 = NULL;
415
416 /* Wipe the global method cache if this package
417 is UNIVERSAL or one of its parents */
418 if(meta->is_universal)
419 PL_sub_generation++;
420
421 /* Wipe the local method cache otherwise */
422 else
423 meta->sub_generation++;
424
425 /* wipe next::method cache too */
426 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
427
428 /* Iterate the isarev (classes that are our children),
429 wiping out their linearization and method caches */
430 if((isarev = meta->mro_isarev)) {
431 hv_iterinit(isarev);
432 while((iter = hv_iternext(isarev))) {
433 SV* revkey = hv_iterkeysv(iter);
434 HV* revstash = gv_stashsv(revkey, 0);
435 struct mro_meta* revmeta = HvMROMETA(revstash);
436 SvREFCNT_dec((SV*)revmeta->mro_linear_dfs);
437 SvREFCNT_dec((SV*)revmeta->mro_linear_c3);
438 revmeta->mro_linear_dfs = NULL;
439 revmeta->mro_linear_c3 = NULL;
440 if(!meta->is_universal)
441 revmeta->sub_generation++;
442 if(revmeta->mro_nextmethod)
443 hv_clear(revmeta->mro_nextmethod);
444 }
445 }
446
1c908217
RGS
447 /* Now iterate our MRO (parents), and do a few things:
448 1) instantiate with the "fake" flag if they don't exist
449 2) flag them as universal if we are universal
450 3) Add everything from our isarev to their isarev
451 */
452
453 /* We're starting at the 2nd element, skipping ourselves here */
e1a479c5
BB
454 linear_mro = mro_get_linear_isa(stash);
455 svp = AvARRAY(linear_mro) + 1;
456 items = AvFILLp(linear_mro);
1c908217 457
e1a479c5
BB
458 while (items--) {
459 SV* const sv = *svp++;
460 struct mro_meta* mrometa;
461 HV* mroisarev;
462
463 HV* mrostash = gv_stashsv(sv, 0);
464 if(!mrostash) {
465 mrostash = gv_stashsv(sv, GV_ADD);
466 /*
467 We created the package on the fly, so
468 that we could store isarev information.
469 This flag lets gv_fetchmeth know about it,
470 so that it can still generate the very useful
471 "Can't locate package Foo for @Bar::ISA" warning.
472 */
473 HvMROMETA(mrostash)->fake = 1;
474 }
475
476 mrometa = HvMROMETA(mrostash);
477 mroisarev = mrometa->mro_isarev;
478
479 /* is_universal is viral */
480 if(meta->is_universal)
481 mrometa->is_universal = 1;
482
483 if(!mroisarev)
484 mroisarev = mrometa->mro_isarev = newHV();
485
486 if(!hv_exists(mroisarev, stashname, strlen(stashname)))
487 hv_store(mroisarev, stashname, strlen(stashname), &PL_sv_yes, 0);
488
489 if(isarev) {
490 hv_iterinit(isarev);
491 while((iter = hv_iternext(isarev))) {
492 SV* revkey = hv_iterkeysv(iter);
493 if(!hv_exists_ent(mroisarev, revkey, 0))
494 hv_store_ent(mroisarev, revkey, &PL_sv_yes, 0);
495 }
496 }
497 }
498}
499
500/*
501=for apidoc mro_method_changed_in
502
503Like C<mro_isa_changed_in>, but invalidates method
504caching on any child classes of the given stash, so
505that they might notice the changes in this one.
506
507Ideally, all instances of C<PL_sub_generation++> in
508the perl source should be replaced by calls to this.
509Some already are, but some are more difficult to
510replace.
511
512Perl has always had problems with method caches
513getting out of sync when one directly manipulates
514stashes via things like C<%{Foo::} = %{Bar::}> or
515C<${Foo::}{bar} = ...> or the equivalent. If
516you do this in core or XS code, call this afterwards
517on the destination stash to get things back in sync.
518
519If you're doing such a thing from pure perl, use
520C<mro::method_changed_in(classname)>, which
521just calls this.
522
523=cut
524*/
525void
526Perl_mro_method_changed_in(pTHX_ HV *stash)
527{
528 struct mro_meta* meta = HvMROMETA(stash);
529 HV* isarev;
530 HE* iter;
531
532 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
533 invalidate all method caches globally */
534 if(meta->is_universal) {
535 PL_sub_generation++;
536 return;
537 }
538
539 /* else, invalidate the method caches of all child classes,
540 but not itself */
541 if((isarev = meta->mro_isarev)) {
542 hv_iterinit(isarev);
543 while((iter = hv_iternext(isarev))) {
544 SV* revkey = hv_iterkeysv(iter);
545 HV* revstash = gv_stashsv(revkey, 0);
546 struct mro_meta* mrometa = HvMROMETA(revstash);
547 mrometa->sub_generation++;
548 if(mrometa->mro_nextmethod)
549 hv_clear(mrometa->mro_nextmethod);
550 }
551 }
552}
553
554/* These two are static helpers for next::method and friends,
555 and re-implement a bunch of the code from pp_caller() in
556 a more efficient manner for this particular usage.
557*/
558
559STATIC I32
560__dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
561 I32 i;
562 for (i = startingblock; i >= 0; i--) {
563 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
564 }
565 return i;
566}
567
568STATIC SV*
569__nextcan(pTHX_ SV* self, I32 throw_nomethod)
570{
571 register I32 cxix;
572 register const PERL_CONTEXT *ccstack = cxstack;
573 const PERL_SI *top_si = PL_curstackinfo;
574 HV* selfstash;
575 GV* cvgv;
576 SV *stashname;
577 const char *fq_subname;
578 const char *subname;
579 STRLEN fq_subname_len;
580 STRLEN stashname_len;
581 STRLEN subname_len;
582 SV* sv;
583 GV** gvp;
584 AV* linear_av;
585 SV** linear_svp;
586 SV* linear_sv;
587 HV* curstash;
588 GV* candidate = NULL;
589 CV* cand_cv = NULL;
590 const char *hvname;
591 I32 items;
592 struct mro_meta* selfmeta;
593 HV* nmcache;
594 HE* cache_entry;
595
596 if(sv_isobject(self))
597 selfstash = SvSTASH(SvRV(self));
598 else
599 selfstash = gv_stashsv(self, 0);
600
601 assert(selfstash);
602
603 hvname = HvNAME_get(selfstash);
604 if (!hvname)
605 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
606
607 cxix = __dopoptosub_at(cxstack, cxstack_ix);
608
609 /* This block finds the contextually-enclosing fully-qualified subname,
610 much like looking at (caller($i))[3] until you find a real sub that
611 isn't ANON, etc */
612 for (;;) {
613 /* we may be in a higher stacklevel, so dig down deeper */
614 while (cxix < 0) {
615 if(top_si->si_type == PERLSI_MAIN)
616 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
617 top_si = top_si->si_prev;
618 ccstack = top_si->si_cxstack;
619 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
620 }
621
622 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
623 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
624 cxix = __dopoptosub_at(ccstack, cxix - 1);
625 continue;
626 }
627
628 {
629 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
630 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
631 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
632 cxix = dbcxix;
633 continue;
634 }
635 }
636 }
637
638 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
639
640 if(!isGV(cvgv)) {
641 cxix = __dopoptosub_at(ccstack, cxix - 1);
642 continue;
643 }
644
645 /* we found a real sub here */
646 sv = sv_2mortal(newSV(0));
647
648 gv_efullname3(sv, cvgv, NULL);
649
650 fq_subname = SvPVX(sv);
651 fq_subname_len = SvCUR(sv);
652
653 subname = strrchr(fq_subname, ':');
654 if(!subname)
655 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
656
657 subname++;
658 subname_len = fq_subname_len - (subname - fq_subname);
659 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
660 cxix = __dopoptosub_at(ccstack, cxix - 1);
661 continue;
662 }
663 break;
664 }
665
666 /* If we made it to here, we found our context */
667
1c908217
RGS
668 /* Initialize the next::method cache for this stash
669 if necessary */
e1a479c5
BB
670 selfmeta = HvMROMETA(selfstash);
671 if(!(nmcache = selfmeta->mro_nextmethod)) {
672 nmcache = selfmeta->mro_nextmethod = newHV();
673 }
674
1c908217 675 /* Use the cached coderef if it exists */
640da897 676 else if((cache_entry = hv_fetch_ent(nmcache, sv, 0, 0))) {
e1a479c5
BB
677 SV* val = HeVAL(cache_entry);
678 if(val == &PL_sv_undef) {
679 if(throw_nomethod)
680 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
681 }
682 return val;
683 }
684
685 /* beyond here is just for cache misses, so perf isn't as critical */
686
687 stashname_len = subname - fq_subname - 2;
688 stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
689
690 linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
691
692 linear_svp = AvARRAY(linear_av);
693 items = AvFILLp(linear_av) + 1;
694
1c908217
RGS
695 /* Walk down our MRO, skipping everything up
696 to the contextually enclosing class */
e1a479c5
BB
697 while (items--) {
698 linear_sv = *linear_svp++;
699 assert(linear_sv);
700 if(sv_eq(linear_sv, stashname))
701 break;
702 }
703
1c908217
RGS
704 /* Now search the remainder of the MRO for the
705 same method name as the contextually enclosing
706 method */
e1a479c5
BB
707 if(items > 0) {
708 while (items--) {
709 linear_sv = *linear_svp++;
710 assert(linear_sv);
711 curstash = gv_stashsv(linear_sv, FALSE);
712
713 if (!curstash || (HvMROMETA(curstash)->fake && !HvFILL(curstash))) {
b0c482e3
RGS
714 if (ckWARN(WARN_SYNTAX))
715 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
e1a479c5
BB
716 (void*)linear_sv, hvname);
717 continue;
718 }
719
720 assert(curstash);
721
722 gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
723 if (!gvp) continue;
724
725 candidate = *gvp;
726 assert(candidate);
727
728 if (SvTYPE(candidate) != SVt_PVGV)
729 gv_init(candidate, curstash, subname, subname_len, TRUE);
1c908217
RGS
730
731 /* Notably, we only look for real entries, not method cache
732 entries, because in C3 the method cache of a parent is not
733 valid for the child */
e1a479c5
BB
734 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
735 SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
736 hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
737 return (SV*)cand_cv;
738 }
739 }
740 }
741
742 hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
743 if(throw_nomethod)
744 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
745 return &PL_sv_undef;
746}
747
748#include "XSUB.h"
749
750XS(XS_mro_get_linear_isa);
751XS(XS_mro_set_mro);
752XS(XS_mro_get_mro);
753XS(XS_mro_get_isarev);
754XS(XS_mro_is_universal);
755XS(XS_mro_get_global_sub_generation);
756XS(XS_mro_invalidate_all_method_caches);
757XS(XS_mro_get_sub_generation);
758XS(XS_mro_method_changed_in);
759XS(XS_next_can);
760XS(XS_next_method);
761XS(XS_maybe_next_method);
762
763void
764Perl_boot_core_mro(pTHX)
765{
766 dVAR;
767 static const char file[] = __FILE__;
768
769 newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
770 newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
771 newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
772 newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
773 newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
774 newXSproto("mro::get_global_sub_generation", XS_mro_get_global_sub_generation, file, "");
775 newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_all_method_caches, file, "");
776 newXSproto("mro::get_sub_generation", XS_mro_get_sub_generation, file, "$");
777 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
778 newXS("next::can", XS_next_can, file);
779 newXS("next::method", XS_next_method, file);
780 newXS("maybe::next::method", XS_maybe_next_method, file);
781}
782
783XS(XS_mro_get_linear_isa) {
784 dVAR;
785 dXSARGS;
786 AV* RETVAL;
787 HV* class_stash;
788 SV* classname;
789
790 PERL_UNUSED_ARG(cv);
791
792 if(items < 1 || items > 2)
793 Perl_croak(aTHX_ "Usage: mro::get_linear_isa(classname [, type ])");
794
795 classname = ST(0);
796 class_stash = gv_stashsv(classname, 0);
797 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
798
799 if(items > 1) {
800 char* which = SvPV_nolen(ST(1));
801 if(strEQ(which, "dfs"))
802 RETVAL = mro_get_linear_isa_dfs(class_stash, 0);
803 else if(strEQ(which, "c3"))
804 RETVAL = mro_get_linear_isa_c3(class_stash, 0);
805 else
806 Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
807 }
808 else {
809 RETVAL = mro_get_linear_isa(class_stash);
810 }
811
812 ST(0) = newRV_inc((SV*)RETVAL);
813 sv_2mortal(ST(0));
814 XSRETURN(1);
815}
816
817XS(XS_mro_set_mro)
818{
819 dVAR;
820 dXSARGS;
821 SV* classname;
822 char* whichstr;
823 mro_alg which;
824 HV* class_stash;
825 struct mro_meta* meta;
826
827 PERL_UNUSED_ARG(cv);
828
829 if (items != 2)
830 Perl_croak(aTHX_ "Usage: mro::set_mro(classname, type)");
831
832 classname = ST(0);
833 whichstr = SvPV_nolen(ST(1));
834 class_stash = gv_stashsv(classname, GV_ADD);
835 if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
836 meta = HvMROMETA(class_stash);
837
838 if(strEQ(whichstr, "dfs"))
839 which = MRO_DFS;
840 else if(strEQ(whichstr, "c3"))
841 which = MRO_C3;
842 else
843 Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
844
845 if(meta->mro_which != which) {
846 meta->mro_which = which;
847 /* Only affects local method cache, not
848 even child classes */
849 meta->sub_generation++;
850 if(meta->mro_nextmethod)
851 hv_clear(meta->mro_nextmethod);
852 }
853
854 XSRETURN_EMPTY;
855}
856
857
858XS(XS_mro_get_mro)
859{
860 dVAR;
861 dXSARGS;
862 SV* classname;
863 HV* class_stash;
864 struct mro_meta* meta;
865
866 PERL_UNUSED_ARG(cv);
867
868 if (items != 1)
869 Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
870
871 classname = ST(0);
872 class_stash = gv_stashsv(classname, 0);
873 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
874 meta = HvMROMETA(class_stash);
875
876 if(meta->mro_which == MRO_DFS)
877 ST(0) = sv_2mortal(newSVpvn("dfs", 3));
878 else
879 ST(0) = sv_2mortal(newSVpvn("c3", 2));
880
881 XSRETURN(1);
882}
883
884XS(XS_mro_get_isarev)
885{
886 dVAR;
887 dXSARGS;
888 SV* classname;
889 HV* class_stash;
890 HV* isarev;
891
892 PERL_UNUSED_ARG(cv);
893
894 if (items != 1)
895 Perl_croak(aTHX_ "Usage: mro::get_isarev(classname)");
896
897 classname = ST(0);
898
899 class_stash = gv_stashsv(classname, 0);
900 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
901
902 SP -= items;
903
904 if((isarev = HvMROMETA(class_stash)->mro_isarev)) {
905 HE* iter;
906 hv_iterinit(isarev);
907 while((iter = hv_iternext(isarev)))
908 XPUSHs(hv_iterkeysv(iter));
909 }
910
911 PUTBACK;
912 return;
913}
914
915XS(XS_mro_is_universal)
916{
917 dVAR;
918 dXSARGS;
919 SV* classname;
920 HV* class_stash;
921
922 PERL_UNUSED_ARG(cv);
923
924 if (items != 1)
925 Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
926
927 classname = ST(0);
928 class_stash = gv_stashsv(classname, 0);
929 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
930
9edc5bb8
RGS
931 if (HvMROMETA(class_stash)->is_universal)
932 XSRETURN_YES;
933 else
934 XSRETURN_NO;
e1a479c5
BB
935}
936
937XS(XS_mro_get_global_sub_generation)
938{
939 dVAR;
940 dXSARGS;
941
942 PERL_UNUSED_ARG(cv);
943
944 if (items != 0)
945 Perl_croak(aTHX_ "Usage: mro::get_global_sub_generation()");
946
947 ST(0) = sv_2mortal(newSViv(PL_sub_generation));
948 XSRETURN(1);
949}
950
951XS(XS_mro_invalidate_all_method_caches)
952{
953 dVAR;
954 dXSARGS;
955
956 PERL_UNUSED_ARG(cv);
957
958 if (items != 0)
959 Perl_croak(aTHX_ "Usage: mro::invalidate_all_method_caches()");
960
961 PL_sub_generation++;
962
963 XSRETURN_EMPTY;
964}
965
966XS(XS_mro_get_sub_generation)
967{
968 dVAR;
969 dXSARGS;
970 SV* classname;
971 HV* class_stash;
972
973 PERL_UNUSED_ARG(cv);
974
975 if(items != 1)
976 Perl_croak(aTHX_ "Usage: mro::get_sub_generation(classname)");
977
978 classname = ST(0);
979 class_stash = gv_stashsv(classname, 0);
980 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
981
982 ST(0) = sv_2mortal(newSViv(HvMROMETA(class_stash)->sub_generation));
983 XSRETURN(1);
984}
985
986XS(XS_mro_method_changed_in)
987{
988 dVAR;
989 dXSARGS;
990 SV* classname;
991 HV* class_stash;
992
993 PERL_UNUSED_ARG(cv);
994
995 if(items != 1)
996 Perl_croak(aTHX_ "Usage: mro::method_changed_in(classname)");
997
998 classname = ST(0);
999
1000 class_stash = gv_stashsv(classname, 0);
1001 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
1002
1003 mro_method_changed_in(class_stash);
1004
1005 XSRETURN_EMPTY;
1006}
1007
1008XS(XS_next_can)
1009{
1010 dVAR;
1011 dXSARGS;
1012 SV* self = ST(0);
1013 SV* methcv = __nextcan(aTHX_ self, 0);
1014
1015 PERL_UNUSED_ARG(cv);
1016 PERL_UNUSED_VAR(items);
1017
1018 if(methcv == &PL_sv_undef) {
1019 ST(0) = &PL_sv_undef;
1020 }
1021 else {
1022 ST(0) = sv_2mortal(newRV_inc(methcv));
1023 }
1024
1025 XSRETURN(1);
1026}
1027
1028XS(XS_next_method)
1029{
1030 dMARK;
1031 dAX;
1032 SV* self = ST(0);
1033 SV* methcv = __nextcan(aTHX_ self, 1);
1034
1035 PERL_UNUSED_ARG(cv);
1036
1037 PL_markstack_ptr++;
1038 call_sv(methcv, GIMME_V);
1039}
1040
1041XS(XS_maybe_next_method)
1042{
1043 dMARK;
1044 dAX;
1045 SV* self = ST(0);
1046 SV* methcv = __nextcan(aTHX_ self, 0);
1047
1048 PERL_UNUSED_ARG(cv);
1049
1050 if(methcv == &PL_sv_undef) {
1051 ST(0) = &PL_sv_undef;
1052 XSRETURN(1);
1053 }
1054
1055 PL_markstack_ptr++;
1056 call_sv(methcv, GIMME_V);
1057}
1058
1059/*
1060 * Local variables:
1061 * c-indentation-style: bsd
1062 * c-basic-offset: 4
1063 * indent-tabs-mode: t
1064 * End:
1065 *
1066 * ex: set ts=8 sts=4 sw=4 noet:
1067 */