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