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