This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Shorten long symbols in mro.c to avoid name mangling on VMS.
[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;
e1a479c5
BB
105 const char* stashname;
106 struct mro_meta* meta;
107
108 assert(stash);
109 assert(HvAUX(stash));
110
111 stashname = HvNAME_get(stash);
112 if (!stashname)
113 Perl_croak(aTHX_
114 "Can't linearize anonymous symbol table");
115
116 if (level > 100)
117 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
118 stashname);
119
120 meta = HvMROMETA(stash);
1c908217
RGS
121
122 /* return cache if valid */
e1a479c5 123 if((retval = meta->mro_linear_dfs)) {
e1a479c5
BB
124 return retval;
125 }
126
127 /* not in cache, make a new one */
1c908217 128
e1a479c5
BB
129 retval = newAV();
130 av_push(retval, newSVpv(stashname, 0)); /* add ourselves at the top */
131
1c908217 132 /* fetch our @ISA */
e1a479c5
BB
133 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
134 av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
135
640da897 136 if(av && AvFILLp(av) >= 0) {
1c908217
RGS
137
138 /* "stored" is used to keep track of all of the classnames
139 we have added to the MRO so far, so we can do a quick
140 exists check and avoid adding duplicate classnames to
141 the MRO as we go. */
142
e1a479c5 143 HV* stored = (HV*)sv_2mortal((SV*)newHV());
ffd8da72
NC
144 SV **svp = AvARRAY(av);
145 I32 items = AvFILLp(av) + 1;
1c908217
RGS
146
147 /* foreach(@ISA) */
e1a479c5
BB
148 while (items--) {
149 SV* const sv = *svp++;
150 HV* const basestash = gv_stashsv(sv, 0);
ffd8da72
NC
151 SV *const *subrv_p;
152 I32 subrv_items;
e1a479c5
BB
153
154 if (!basestash) {
1c908217
RGS
155 /* if no stash exists for this @ISA member,
156 simply add it to the MRO and move on */
ffd8da72
NC
157 subrv_p = &sv;
158 subrv_items = 1;
e1a479c5
BB
159 }
160 else {
1c908217
RGS
161 /* otherwise, recurse into ourselves for the MRO
162 of this @ISA member, and append their MRO to ours */
ffd8da72
NC
163 const AV *const subrv
164 = mro_get_linear_isa_dfs(basestash, level + 1);
165
166 subrv_p = AvARRAY(subrv);
167 subrv_items = AvFILLp(subrv) + 1;
168 }
169 while(subrv_items--) {
170 SV *const subsv = *subrv_p++;
171 if(!hv_exists_ent(stored, subsv, 0)) {
ffd8da72 172 hv_store_ent(stored, subsv, &PL_sv_undef, 0);
25270bc0 173 av_push(retval, newSVsv(subsv));
ffd8da72 174 }
e1a479c5
BB
175 }
176 }
177 }
178
1c908217
RGS
179 /* we don't want anyone modifying the cache entry but us,
180 and we do so by replacing it completely */
e1a479c5 181 SvREADONLY_on(retval);
1c908217 182
e1a479c5
BB
183 meta->mro_linear_dfs = retval;
184 return retval;
185}
186
187/*
188=for apidoc mro_get_linear_isa_c3
189
190Returns the C3 linearization of @ISA
191the given stash. The return value is a read-only AV*.
192C<level> should be 0 (it is used internally in this
193function's recursion).
194
1c908217
RGS
195You are responsible for C<SvREFCNT_inc()> on the
196return value if you plan to store it anywhere
197semi-permanently (otherwise it might be deleted
198out from under you the next time the cache is
199invalidated).
200
e1a479c5
BB
201=cut
202*/
203
204AV*
205Perl_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level)
206{
207 AV* retval;
208 GV** gvp;
209 GV* gv;
210 AV* isa;
211 const char* stashname;
212 STRLEN stashname_len;
213 struct mro_meta* meta;
214
215 assert(stash);
216 assert(HvAUX(stash));
217
218 stashname = HvNAME_get(stash);
219 stashname_len = HvNAMELEN_get(stash);
220 if (!stashname)
221 Perl_croak(aTHX_
222 "Can't linearize anonymous symbol table");
223
224 if (level > 100)
225 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
226 stashname);
227
228 meta = HvMROMETA(stash);
1c908217
RGS
229
230 /* return cache if valid */
e1a479c5 231 if((retval = meta->mro_linear_c3)) {
e1a479c5
BB
232 return retval;
233 }
234
235 /* not in cache, make a new one */
236
237 retval = newAV();
238 av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
239
240 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
241 isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
242
1c908217
RGS
243 /* For a better idea how the rest of this works, see the much clearer
244 pure perl version in Algorithm::C3 0.01:
245 http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
246 (later versions go about it differently than this code for speed reasons)
247 */
e1a479c5
BB
248 if(isa && AvFILLp(isa) >= 0) {
249 SV** seqs_ptr;
250 I32 seqs_items;
251 HV* tails = (HV*)sv_2mortal((SV*)newHV());
252 AV* seqs = (AV*)sv_2mortal((SV*)newAV());
253 I32 items = AvFILLp(isa) + 1;
254 SV** isa_ptr = AvARRAY(isa);
255 while(items--) {
256 AV* isa_lin;
257 SV* isa_item = *isa_ptr++;
258 HV* isa_item_stash = gv_stashsv(isa_item, 0);
259 if(!isa_item_stash) {
260 isa_lin = newAV();
261 av_push(isa_lin, newSVsv(isa_item));
262 }
263 else {
264 isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1); /* recursion */
265 }
266 av_push(seqs, (SV*)av_make(AvFILLp(isa_lin)+1, AvARRAY(isa_lin)));
267 }
268 av_push(seqs, (SV*)av_make(AvFILLp(isa)+1, AvARRAY(isa)));
269
270 seqs_ptr = AvARRAY(seqs);
271 seqs_items = AvFILLp(seqs) + 1;
272 while(seqs_items--) {
273 AV* seq = (AV*)*seqs_ptr++;
274 I32 seq_items = AvFILLp(seq);
275 if(seq_items > 0) {
276 SV** seq_ptr = AvARRAY(seq) + 1;
277 while(seq_items--) {
278 SV* seqitem = *seq_ptr++;
279 HE* he = hv_fetch_ent(tails, seqitem, 0, 0);
280 if(!he) {
281 hv_store_ent(tails, seqitem, newSViv(1), 0);
282 }
283 else {
284 SV* val = HeVAL(he);
285 sv_inc(val);
286 }
287 }
288 }
289 }
290
291 while(1) {
292 SV* seqhead = NULL;
293 SV* cand = NULL;
294 SV* winner = NULL;
295 SV* val;
296 HE* tail_entry;
297 AV* seq;
298 SV** avptr = AvARRAY(seqs);
299 items = AvFILLp(seqs)+1;
300 while(items--) {
301 SV** svp;
302 seq = (AV*)*avptr++;
303 if(AvFILLp(seq) < 0) continue;
304 svp = av_fetch(seq, 0, 0);
305 seqhead = *svp;
306 if(!winner) {
307 cand = seqhead;
308 if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
309 && (val = HeVAL(tail_entry))
25270bc0 310 && (SvIVX(val) > 0))
e1a479c5
BB
311 continue;
312 winner = newSVsv(cand);
313 av_push(retval, winner);
314 }
315 if(!sv_cmp(seqhead, winner)) {
316
317 /* this is basically shift(@seq) in void context */
318 SvREFCNT_dec(*AvARRAY(seq));
319 *AvARRAY(seq) = &PL_sv_undef;
320 AvARRAY(seq) = AvARRAY(seq) + 1;
321 AvMAX(seq)--;
322 AvFILLp(seq)--;
323
324 if(AvFILLp(seq) < 0) continue;
325 svp = av_fetch(seq, 0, 0);
326 seqhead = *svp;
327 tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
328 val = HeVAL(tail_entry);
329 sv_dec(val);
330 }
331 }
332 if(!cand) break;
333 if(!winner) {
334 SvREFCNT_dec(retval);
335 Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
336 "merging failed on parent '%"SVf"'", stashname, SVfARG(cand));
337 }
338 }
339 }
340
1c908217
RGS
341 /* we don't want anyone modifying the cache entry but us,
342 and we do so by replacing it completely */
e1a479c5 343 SvREADONLY_on(retval);
1c908217 344
e1a479c5
BB
345 meta->mro_linear_c3 = retval;
346 return retval;
347}
348
349/*
350=for apidoc mro_get_linear_isa
351
352Returns either C<mro_get_linear_isa_c3> or
353C<mro_get_linear_isa_dfs> for the given stash,
354dependant upon which MRO is in effect
355for that stash. The return value is a
356read-only AV*.
357
1c908217
RGS
358You are responsible for C<SvREFCNT_inc()> on the
359return value if you plan to store it anywhere
360semi-permanently (otherwise it might be deleted
361out from under you the next time the cache is
362invalidated).
363
e1a479c5
BB
364=cut
365*/
366AV*
367Perl_mro_get_linear_isa(pTHX_ HV *stash)
368{
369 struct mro_meta* meta;
370 assert(stash);
371 assert(HvAUX(stash));
372
373 meta = HvMROMETA(stash);
374 if(meta->mro_which == MRO_DFS) {
375 return mro_get_linear_isa_dfs(stash, 0);
376 } else if(meta->mro_which == MRO_C3) {
377 return mro_get_linear_isa_c3(stash, 0);
378 } else {
14f97ce6 379 Perl_croak(aTHX_ "panic: invalid MRO!");
e1a479c5
BB
380 }
381}
382
383/*
384=for apidoc mro_isa_changed_in
385
1c908217 386Takes the necessary steps (cache invalidations, mostly)
e1a479c5
BB
387when the @ISA of the given package has changed. Invoked
388by the C<setisa> magic, should not need to invoke directly.
389
390=cut
391*/
392void
393Perl_mro_isa_changed_in(pTHX_ HV* stash)
394{
395 dVAR;
396 HV* isarev;
397 AV* linear_mro;
398 HE* iter;
399 SV** svp;
400 I32 items;
401 struct mro_meta* meta;
402 char* stashname;
403
404 stashname = HvNAME_get(stash);
405
406 /* wipe out the cached linearizations for this stash */
407 meta = HvMROMETA(stash);
408 SvREFCNT_dec((SV*)meta->mro_linear_dfs);
409 SvREFCNT_dec((SV*)meta->mro_linear_c3);
410 meta->mro_linear_dfs = NULL;
411 meta->mro_linear_c3 = NULL;
412
413 /* Wipe the global method cache if this package
414 is UNIVERSAL or one of its parents */
415 if(meta->is_universal)
416 PL_sub_generation++;
417
418 /* Wipe the local method cache otherwise */
419 else
420 meta->sub_generation++;
421
422 /* wipe next::method cache too */
423 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
424
425 /* Iterate the isarev (classes that are our children),
426 wiping out their linearization and method caches */
427 if((isarev = meta->mro_isarev)) {
428 hv_iterinit(isarev);
429 while((iter = hv_iternext(isarev))) {
430 SV* revkey = hv_iterkeysv(iter);
431 HV* revstash = gv_stashsv(revkey, 0);
432 struct mro_meta* revmeta = HvMROMETA(revstash);
433 SvREFCNT_dec((SV*)revmeta->mro_linear_dfs);
434 SvREFCNT_dec((SV*)revmeta->mro_linear_c3);
435 revmeta->mro_linear_dfs = NULL;
436 revmeta->mro_linear_c3 = NULL;
437 if(!meta->is_universal)
438 revmeta->sub_generation++;
439 if(revmeta->mro_nextmethod)
440 hv_clear(revmeta->mro_nextmethod);
441 }
442 }
443
1c908217
RGS
444 /* Now iterate our MRO (parents), and do a few things:
445 1) instantiate with the "fake" flag if they don't exist
446 2) flag them as universal if we are universal
447 3) Add everything from our isarev to their isarev
448 */
449
450 /* We're starting at the 2nd element, skipping ourselves here */
e1a479c5
BB
451 linear_mro = mro_get_linear_isa(stash);
452 svp = AvARRAY(linear_mro) + 1;
453 items = AvFILLp(linear_mro);
1c908217 454
e1a479c5
BB
455 while (items--) {
456 SV* const sv = *svp++;
457 struct mro_meta* mrometa;
458 HV* mroisarev;
459
460 HV* mrostash = gv_stashsv(sv, 0);
461 if(!mrostash) {
462 mrostash = gv_stashsv(sv, GV_ADD);
463 /*
464 We created the package on the fly, so
465 that we could store isarev information.
466 This flag lets gv_fetchmeth know about it,
467 so that it can still generate the very useful
468 "Can't locate package Foo for @Bar::ISA" warning.
469 */
470 HvMROMETA(mrostash)->fake = 1;
471 }
472
473 mrometa = HvMROMETA(mrostash);
474 mroisarev = mrometa->mro_isarev;
475
476 /* is_universal is viral */
477 if(meta->is_universal)
478 mrometa->is_universal = 1;
479
480 if(!mroisarev)
481 mroisarev = mrometa->mro_isarev = newHV();
482
25270bc0
NC
483 /* This hash only ever contains PL_sv_yes. Storing it over itself is
484 almost as cheap as calling hv_exists, so on aggregate we expect to
485 save time by not making two calls to the common HV code for the
486 case where it doesn't exist. */
487
488 hv_store(mroisarev, stashname, strlen(stashname), &PL_sv_yes, 0);
e1a479c5
BB
489
490 if(isarev) {
491 hv_iterinit(isarev);
492 while((iter = hv_iternext(isarev))) {
493 SV* revkey = hv_iterkeysv(iter);
25270bc0 494 hv_store_ent(mroisarev, revkey, &PL_sv_yes, 0);
e1a479c5
BB
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);
c5860d66
CB
755XS(XS_mro_get_global_sub_gen);
756XS(XS_mro_invalidate_method_caches);
e1a479c5
BB
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, "$");
c5860d66
CB
774 newXSproto("mro::get_global_sub_generation", XS_mro_get_global_sub_gen, file, "");
775 newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
e1a479c5
BB
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
c5860d66 937XS(XS_mro_get_global_sub_gen)
e1a479c5
BB
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
c5860d66 951XS(XS_mro_invalidate_method_caches)
e1a479c5
BB
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 */