This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: [PATCH] Cleanup of the regexp API
[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 */
8638e433 248
e1a479c5
BB
249 if(isa && AvFILLp(isa) >= 0) {
250 SV** seqs_ptr;
251 I32 seqs_items;
252 HV* tails = (HV*)sv_2mortal((SV*)newHV());
253 AV* seqs = (AV*)sv_2mortal((SV*)newAV());
8638e433
RGS
254 I32* heads;
255
256 /* This builds @seqs, which is an array of arrays.
257 The members of @seqs are the MROs of
258 the members of @ISA, followed by @ISA itself.
259 */
e1a479c5
BB
260 I32 items = AvFILLp(isa) + 1;
261 SV** isa_ptr = AvARRAY(isa);
262 while(items--) {
263 AV* isa_lin;
264 SV* isa_item = *isa_ptr++;
265 HV* isa_item_stash = gv_stashsv(isa_item, 0);
266 if(!isa_item_stash) {
8638e433
RGS
267 /* if no stash, make a temporary fake MRO
268 containing just itself */
269 isa_lin = (AV*)sv_2mortal((SV*)newAV());
e1a479c5
BB
270 av_push(isa_lin, newSVsv(isa_item));
271 }
272 else {
273 isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1); /* recursion */
274 }
8638e433 275 av_push(seqs, (SV*)isa_lin);
e1a479c5 276 }
8638e433
RGS
277 av_push(seqs, (SV*)isa);
278
279 /* This builds "heads", which as an array of integer array
280 indices, one per seq, which point at the virtual "head"
281 of the seq (initially zero) */
282 Newxz(heads, AvFILLp(seqs)+1, I32);
283
284 /* This builds %tails, which has one key for every class
285 mentioned in the tail of any sequence in @seqs (tail meaning
286 everything after the first class, the "head"). The value
287 is how many times this key appears in the tails of @seqs.
288 */
e1a479c5
BB
289 seqs_ptr = AvARRAY(seqs);
290 seqs_items = AvFILLp(seqs) + 1;
291 while(seqs_items--) {
292 AV* seq = (AV*)*seqs_ptr++;
293 I32 seq_items = AvFILLp(seq);
294 if(seq_items > 0) {
295 SV** seq_ptr = AvARRAY(seq) + 1;
296 while(seq_items--) {
297 SV* seqitem = *seq_ptr++;
298 HE* he = hv_fetch_ent(tails, seqitem, 0, 0);
299 if(!he) {
300 hv_store_ent(tails, seqitem, newSViv(1), 0);
301 }
302 else {
303 SV* val = HeVAL(he);
304 sv_inc(val);
305 }
306 }
307 }
308 }
309
8638e433
RGS
310 /* This loop won't terminate until we either finish building
311 the MRO, or get an exception. */
e1a479c5
BB
312 while(1) {
313 SV* seqhead = NULL;
314 SV* cand = NULL;
315 SV* winner = NULL;
316 SV* val;
317 HE* tail_entry;
318 AV* seq;
8638e433
RGS
319 int s;
320
321 /* "foreach $seq (@seqs)" */
e1a479c5 322 SV** avptr = AvARRAY(seqs);
8638e433 323 for(s = 0; s <= AvFILLp(seqs); s++) {
e1a479c5 324 SV** svp;
8638e433
RGS
325 seq = (AV*)(avptr[s]);
326 if(!seq) continue; /* skip empty seqs */
327 svp = av_fetch(seq, heads[s], 0);
328 seqhead = *svp; /* seqhead = head of this seq */
e1a479c5 329 if(!winner) {
8638e433
RGS
330 /* if we haven't found a winner for this round yet,
331 and this seqhead is not in tails (or the count
332 for it in tails has dropped to zero), then this
333 seqhead is our new winner, and is added to the
334 final MRO immediately */
e1a479c5
BB
335 cand = seqhead;
336 if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
337 && (val = HeVAL(tail_entry))
25270bc0 338 && (SvIVX(val) > 0))
e1a479c5
BB
339 continue;
340 winner = newSVsv(cand);
341 av_push(retval, winner);
8638e433
RGS
342 /* note however that even when we find a winner,
343 we continue looping over @seqs to do housekeeping */
e1a479c5
BB
344 }
345 if(!sv_cmp(seqhead, winner)) {
8638e433
RGS
346 /* Once we have a winner (including the iteration
347 where we first found him), inc the head ptr
348 for any seq which had the winner as a head,
349 NULL out any seq which is now empty,
350 and adjust tails for consistency */
351
352 int new_head = ++heads[s];
353 if(new_head > AvFILLp(seq)) {
354 avptr[s] = NULL;
355 }
356 else {
357 /* Because we know this new seqhead used to be
358 a tail, we can assume it is in tails and has
359 a positive value, which we need to dec */
360 svp = av_fetch(seq, new_head, 0);
361 seqhead = *svp;
362 tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
363 val = HeVAL(tail_entry);
364 sv_dec(val);
365 }
e1a479c5
BB
366 }
367 }
8638e433
RGS
368
369 /* if we found no candidates, we are done building the MRO.
370 !cand means no seqs have any entries left to check */
371 if(!cand) {
372 Safefree(heads);
373 break;
374 }
375
376 /* If we had candidates, but nobody won, then the @ISA
377 hierarchy is not C3-incompatible */
e1a479c5 378 if(!winner) {
8638e433
RGS
379 /* we have to do some cleanup before we croak */
380 SV** svp = AvARRAY(seqs);
381 items = AvFILLp(seqs) + 1;
382 while (items--)
383 *svp++ = NULL;
384
e1a479c5 385 SvREFCNT_dec(retval);
8638e433
RGS
386 Safefree(heads);
387
e1a479c5
BB
388 Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
389 "merging failed on parent '%"SVf"'", stashname, SVfARG(cand));
390 }
391 }
392 }
393
1c908217
RGS
394 /* we don't want anyone modifying the cache entry but us,
395 and we do so by replacing it completely */
e1a479c5 396 SvREADONLY_on(retval);
1c908217 397
e1a479c5
BB
398 meta->mro_linear_c3 = retval;
399 return retval;
400}
401
402/*
403=for apidoc mro_get_linear_isa
404
405Returns either C<mro_get_linear_isa_c3> or
406C<mro_get_linear_isa_dfs> for the given stash,
407dependant upon which MRO is in effect
408for that stash. The return value is a
409read-only AV*.
410
1c908217
RGS
411You are responsible for C<SvREFCNT_inc()> on the
412return value if you plan to store it anywhere
413semi-permanently (otherwise it might be deleted
414out from under you the next time the cache is
415invalidated).
416
e1a479c5
BB
417=cut
418*/
419AV*
420Perl_mro_get_linear_isa(pTHX_ HV *stash)
421{
422 struct mro_meta* meta;
423 assert(stash);
424 assert(HvAUX(stash));
425
426 meta = HvMROMETA(stash);
427 if(meta->mro_which == MRO_DFS) {
428 return mro_get_linear_isa_dfs(stash, 0);
429 } else if(meta->mro_which == MRO_C3) {
430 return mro_get_linear_isa_c3(stash, 0);
431 } else {
14f97ce6 432 Perl_croak(aTHX_ "panic: invalid MRO!");
e1a479c5 433 }
7caa839c 434 return NULL; /* NOT REACHED */
e1a479c5
BB
435}
436
437/*
438=for apidoc mro_isa_changed_in
439
1c908217 440Takes the necessary steps (cache invalidations, mostly)
e1a479c5
BB
441when the @ISA of the given package has changed. Invoked
442by the C<setisa> magic, should not need to invoke directly.
443
444=cut
445*/
446void
447Perl_mro_isa_changed_in(pTHX_ HV* stash)
448{
449 dVAR;
450 HV* isarev;
451 AV* linear_mro;
452 HE* iter;
453 SV** svp;
454 I32 items;
455 struct mro_meta* meta;
456 char* stashname;
457
458 stashname = HvNAME_get(stash);
459
460 /* wipe out the cached linearizations for this stash */
461 meta = HvMROMETA(stash);
462 SvREFCNT_dec((SV*)meta->mro_linear_dfs);
463 SvREFCNT_dec((SV*)meta->mro_linear_c3);
464 meta->mro_linear_dfs = NULL;
465 meta->mro_linear_c3 = NULL;
466
467 /* Wipe the global method cache if this package
468 is UNIVERSAL or one of its parents */
469 if(meta->is_universal)
470 PL_sub_generation++;
471
472 /* Wipe the local method cache otherwise */
473 else
474 meta->sub_generation++;
475
476 /* wipe next::method cache too */
477 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
478
479 /* Iterate the isarev (classes that are our children),
480 wiping out their linearization and method caches */
481 if((isarev = meta->mro_isarev)) {
482 hv_iterinit(isarev);
483 while((iter = hv_iternext(isarev))) {
484 SV* revkey = hv_iterkeysv(iter);
485 HV* revstash = gv_stashsv(revkey, 0);
bc2cbbac
BB
486 struct mro_meta* revmeta;
487
488 if(!revstash) continue;
489 revmeta = HvMROMETA(revstash);
e1a479c5
BB
490 SvREFCNT_dec((SV*)revmeta->mro_linear_dfs);
491 SvREFCNT_dec((SV*)revmeta->mro_linear_c3);
492 revmeta->mro_linear_dfs = NULL;
493 revmeta->mro_linear_c3 = NULL;
494 if(!meta->is_universal)
495 revmeta->sub_generation++;
496 if(revmeta->mro_nextmethod)
497 hv_clear(revmeta->mro_nextmethod);
498 }
499 }
500
1c908217
RGS
501 /* Now iterate our MRO (parents), and do a few things:
502 1) instantiate with the "fake" flag if they don't exist
503 2) flag them as universal if we are universal
504 3) Add everything from our isarev to their isarev
505 */
506
507 /* We're starting at the 2nd element, skipping ourselves here */
e1a479c5
BB
508 linear_mro = mro_get_linear_isa(stash);
509 svp = AvARRAY(linear_mro) + 1;
510 items = AvFILLp(linear_mro);
1c908217 511
e1a479c5
BB
512 while (items--) {
513 SV* const sv = *svp++;
514 struct mro_meta* mrometa;
515 HV* mroisarev;
516
517 HV* mrostash = gv_stashsv(sv, 0);
518 if(!mrostash) {
519 mrostash = gv_stashsv(sv, GV_ADD);
520 /*
521 We created the package on the fly, so
522 that we could store isarev information.
523 This flag lets gv_fetchmeth know about it,
524 so that it can still generate the very useful
525 "Can't locate package Foo for @Bar::ISA" warning.
526 */
527 HvMROMETA(mrostash)->fake = 1;
528 }
529
530 mrometa = HvMROMETA(mrostash);
531 mroisarev = mrometa->mro_isarev;
532
533 /* is_universal is viral */
534 if(meta->is_universal)
535 mrometa->is_universal = 1;
536
537 if(!mroisarev)
538 mroisarev = mrometa->mro_isarev = newHV();
539
25270bc0
NC
540 /* This hash only ever contains PL_sv_yes. Storing it over itself is
541 almost as cheap as calling hv_exists, so on aggregate we expect to
542 save time by not making two calls to the common HV code for the
543 case where it doesn't exist. */
544
545 hv_store(mroisarev, stashname, strlen(stashname), &PL_sv_yes, 0);
e1a479c5
BB
546
547 if(isarev) {
548 hv_iterinit(isarev);
549 while((iter = hv_iternext(isarev))) {
550 SV* revkey = hv_iterkeysv(iter);
25270bc0 551 hv_store_ent(mroisarev, revkey, &PL_sv_yes, 0);
e1a479c5
BB
552 }
553 }
554 }
555}
556
557/*
558=for apidoc mro_method_changed_in
559
47c9dd14
BB
560Invalidates method caching on any child classes
561of the given stash, so that they might notice
562the changes in this one.
e1a479c5
BB
563
564Ideally, all instances of C<PL_sub_generation++> in
47c9dd14
BB
565the perl source outside of C<mro.c> should be
566replaced by calls to this. This conversion is
567nearly complete.
e1a479c5
BB
568
569Perl has always had problems with method caches
570getting out of sync when one directly manipulates
571stashes via things like C<%{Foo::} = %{Bar::}> or
572C<${Foo::}{bar} = ...> or the equivalent. If
573you do this in core or XS code, call this afterwards
574on the destination stash to get things back in sync.
575
576If you're doing such a thing from pure perl, use
577C<mro::method_changed_in(classname)>, which
578just calls this.
579
580=cut
581*/
582void
583Perl_mro_method_changed_in(pTHX_ HV *stash)
584{
585 struct mro_meta* meta = HvMROMETA(stash);
586 HV* isarev;
587 HE* iter;
588
589 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
590 invalidate all method caches globally */
591 if(meta->is_universal) {
592 PL_sub_generation++;
593 return;
594 }
595
596 /* else, invalidate the method caches of all child classes,
597 but not itself */
598 if((isarev = meta->mro_isarev)) {
599 hv_iterinit(isarev);
600 while((iter = hv_iternext(isarev))) {
601 SV* revkey = hv_iterkeysv(iter);
602 HV* revstash = gv_stashsv(revkey, 0);
bc2cbbac
BB
603 struct mro_meta* mrometa;
604
605 if(!revstash) continue;
606 mrometa = HvMROMETA(revstash);
e1a479c5
BB
607 mrometa->sub_generation++;
608 if(mrometa->mro_nextmethod)
609 hv_clear(mrometa->mro_nextmethod);
610 }
611 }
612}
613
614/* These two are static helpers for next::method and friends,
615 and re-implement a bunch of the code from pp_caller() in
616 a more efficient manner for this particular usage.
617*/
618
619STATIC I32
620__dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
621 I32 i;
622 for (i = startingblock; i >= 0; i--) {
623 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
624 }
625 return i;
626}
627
628STATIC SV*
629__nextcan(pTHX_ SV* self, I32 throw_nomethod)
630{
631 register I32 cxix;
632 register const PERL_CONTEXT *ccstack = cxstack;
633 const PERL_SI *top_si = PL_curstackinfo;
634 HV* selfstash;
635 GV* cvgv;
636 SV *stashname;
637 const char *fq_subname;
638 const char *subname;
639 STRLEN fq_subname_len;
640 STRLEN stashname_len;
641 STRLEN subname_len;
642 SV* sv;
643 GV** gvp;
644 AV* linear_av;
645 SV** linear_svp;
646 SV* linear_sv;
647 HV* curstash;
648 GV* candidate = NULL;
649 CV* cand_cv = NULL;
650 const char *hvname;
651 I32 items;
652 struct mro_meta* selfmeta;
653 HV* nmcache;
654 HE* cache_entry;
655
656 if(sv_isobject(self))
657 selfstash = SvSTASH(SvRV(self));
658 else
659 selfstash = gv_stashsv(self, 0);
660
661 assert(selfstash);
662
663 hvname = HvNAME_get(selfstash);
664 if (!hvname)
665 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
666
667 cxix = __dopoptosub_at(cxstack, cxstack_ix);
668
669 /* This block finds the contextually-enclosing fully-qualified subname,
670 much like looking at (caller($i))[3] until you find a real sub that
671 isn't ANON, etc */
672 for (;;) {
673 /* we may be in a higher stacklevel, so dig down deeper */
674 while (cxix < 0) {
675 if(top_si->si_type == PERLSI_MAIN)
676 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
677 top_si = top_si->si_prev;
678 ccstack = top_si->si_cxstack;
679 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
680 }
681
682 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
683 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
684 cxix = __dopoptosub_at(ccstack, cxix - 1);
685 continue;
686 }
687
688 {
689 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
690 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
691 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
692 cxix = dbcxix;
693 continue;
694 }
695 }
696 }
697
698 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
699
700 if(!isGV(cvgv)) {
701 cxix = __dopoptosub_at(ccstack, cxix - 1);
702 continue;
703 }
704
705 /* we found a real sub here */
706 sv = sv_2mortal(newSV(0));
707
708 gv_efullname3(sv, cvgv, NULL);
709
710 fq_subname = SvPVX(sv);
711 fq_subname_len = SvCUR(sv);
712
713 subname = strrchr(fq_subname, ':');
714 if(!subname)
715 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
716
717 subname++;
718 subname_len = fq_subname_len - (subname - fq_subname);
719 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
720 cxix = __dopoptosub_at(ccstack, cxix - 1);
721 continue;
722 }
723 break;
724 }
725
726 /* If we made it to here, we found our context */
727
1c908217
RGS
728 /* Initialize the next::method cache for this stash
729 if necessary */
e1a479c5
BB
730 selfmeta = HvMROMETA(selfstash);
731 if(!(nmcache = selfmeta->mro_nextmethod)) {
732 nmcache = selfmeta->mro_nextmethod = newHV();
733 }
734
1c908217 735 /* Use the cached coderef if it exists */
640da897 736 else if((cache_entry = hv_fetch_ent(nmcache, sv, 0, 0))) {
e1a479c5
BB
737 SV* val = HeVAL(cache_entry);
738 if(val == &PL_sv_undef) {
739 if(throw_nomethod)
740 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
741 }
742 return val;
743 }
744
745 /* beyond here is just for cache misses, so perf isn't as critical */
746
747 stashname_len = subname - fq_subname - 2;
748 stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
749
750 linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
751
752 linear_svp = AvARRAY(linear_av);
753 items = AvFILLp(linear_av) + 1;
754
1c908217
RGS
755 /* Walk down our MRO, skipping everything up
756 to the contextually enclosing class */
e1a479c5
BB
757 while (items--) {
758 linear_sv = *linear_svp++;
759 assert(linear_sv);
760 if(sv_eq(linear_sv, stashname))
761 break;
762 }
763
1c908217
RGS
764 /* Now search the remainder of the MRO for the
765 same method name as the contextually enclosing
766 method */
e1a479c5
BB
767 if(items > 0) {
768 while (items--) {
769 linear_sv = *linear_svp++;
770 assert(linear_sv);
771 curstash = gv_stashsv(linear_sv, FALSE);
772
773 if (!curstash || (HvMROMETA(curstash)->fake && !HvFILL(curstash))) {
b0c482e3
RGS
774 if (ckWARN(WARN_SYNTAX))
775 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
e1a479c5
BB
776 (void*)linear_sv, hvname);
777 continue;
778 }
779
780 assert(curstash);
781
782 gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
783 if (!gvp) continue;
784
785 candidate = *gvp;
786 assert(candidate);
787
788 if (SvTYPE(candidate) != SVt_PVGV)
789 gv_init(candidate, curstash, subname, subname_len, TRUE);
1c908217
RGS
790
791 /* Notably, we only look for real entries, not method cache
792 entries, because in C3 the method cache of a parent is not
793 valid for the child */
e1a479c5
BB
794 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
795 SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
796 hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
797 return (SV*)cand_cv;
798 }
799 }
800 }
801
802 hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
803 if(throw_nomethod)
804 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
805 return &PL_sv_undef;
806}
807
808#include "XSUB.h"
809
810XS(XS_mro_get_linear_isa);
811XS(XS_mro_set_mro);
812XS(XS_mro_get_mro);
813XS(XS_mro_get_isarev);
814XS(XS_mro_is_universal);
c5860d66
CB
815XS(XS_mro_get_global_sub_gen);
816XS(XS_mro_invalidate_method_caches);
e1a479c5
BB
817XS(XS_mro_get_sub_generation);
818XS(XS_mro_method_changed_in);
819XS(XS_next_can);
820XS(XS_next_method);
821XS(XS_maybe_next_method);
822
823void
824Perl_boot_core_mro(pTHX)
825{
826 dVAR;
827 static const char file[] = __FILE__;
828
829 newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
830 newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
831 newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
832 newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
833 newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
c5860d66
CB
834 newXSproto("mro::get_global_sub_generation", XS_mro_get_global_sub_gen, file, "");
835 newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
e1a479c5
BB
836 newXSproto("mro::get_sub_generation", XS_mro_get_sub_generation, file, "$");
837 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
838 newXS("next::can", XS_next_can, file);
839 newXS("next::method", XS_next_method, file);
840 newXS("maybe::next::method", XS_maybe_next_method, file);
841}
842
843XS(XS_mro_get_linear_isa) {
844 dVAR;
845 dXSARGS;
846 AV* RETVAL;
847 HV* class_stash;
848 SV* classname;
849
850 PERL_UNUSED_ARG(cv);
851
852 if(items < 1 || items > 2)
853 Perl_croak(aTHX_ "Usage: mro::get_linear_isa(classname [, type ])");
854
855 classname = ST(0);
856 class_stash = gv_stashsv(classname, 0);
857 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
858
859 if(items > 1) {
860 char* which = SvPV_nolen(ST(1));
861 if(strEQ(which, "dfs"))
862 RETVAL = mro_get_linear_isa_dfs(class_stash, 0);
863 else if(strEQ(which, "c3"))
864 RETVAL = mro_get_linear_isa_c3(class_stash, 0);
865 else
866 Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
867 }
868 else {
869 RETVAL = mro_get_linear_isa(class_stash);
870 }
871
872 ST(0) = newRV_inc((SV*)RETVAL);
873 sv_2mortal(ST(0));
874 XSRETURN(1);
875}
876
877XS(XS_mro_set_mro)
878{
879 dVAR;
880 dXSARGS;
881 SV* classname;
882 char* whichstr;
883 mro_alg which;
884 HV* class_stash;
885 struct mro_meta* meta;
886
887 PERL_UNUSED_ARG(cv);
888
889 if (items != 2)
890 Perl_croak(aTHX_ "Usage: mro::set_mro(classname, type)");
891
892 classname = ST(0);
893 whichstr = SvPV_nolen(ST(1));
894 class_stash = gv_stashsv(classname, GV_ADD);
895 if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
896 meta = HvMROMETA(class_stash);
897
898 if(strEQ(whichstr, "dfs"))
899 which = MRO_DFS;
900 else if(strEQ(whichstr, "c3"))
901 which = MRO_C3;
902 else
903 Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
904
905 if(meta->mro_which != which) {
906 meta->mro_which = which;
907 /* Only affects local method cache, not
908 even child classes */
909 meta->sub_generation++;
910 if(meta->mro_nextmethod)
911 hv_clear(meta->mro_nextmethod);
912 }
913
914 XSRETURN_EMPTY;
915}
916
917
918XS(XS_mro_get_mro)
919{
920 dVAR;
921 dXSARGS;
922 SV* classname;
923 HV* class_stash;
924 struct mro_meta* meta;
925
926 PERL_UNUSED_ARG(cv);
927
928 if (items != 1)
929 Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
930
931 classname = ST(0);
932 class_stash = gv_stashsv(classname, 0);
933 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
934 meta = HvMROMETA(class_stash);
935
936 if(meta->mro_which == MRO_DFS)
937 ST(0) = sv_2mortal(newSVpvn("dfs", 3));
938 else
939 ST(0) = sv_2mortal(newSVpvn("c3", 2));
940
941 XSRETURN(1);
942}
943
944XS(XS_mro_get_isarev)
945{
946 dVAR;
947 dXSARGS;
948 SV* classname;
949 HV* class_stash;
950 HV* isarev;
951
952 PERL_UNUSED_ARG(cv);
953
954 if (items != 1)
955 Perl_croak(aTHX_ "Usage: mro::get_isarev(classname)");
956
957 classname = ST(0);
958
959 class_stash = gv_stashsv(classname, 0);
960 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
961
962 SP -= items;
963
964 if((isarev = HvMROMETA(class_stash)->mro_isarev)) {
965 HE* iter;
966 hv_iterinit(isarev);
967 while((iter = hv_iternext(isarev)))
968 XPUSHs(hv_iterkeysv(iter));
969 }
970
971 PUTBACK;
972 return;
973}
974
975XS(XS_mro_is_universal)
976{
977 dVAR;
978 dXSARGS;
979 SV* classname;
980 HV* class_stash;
981
982 PERL_UNUSED_ARG(cv);
983
984 if (items != 1)
985 Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
986
987 classname = ST(0);
988 class_stash = gv_stashsv(classname, 0);
989 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
990
9edc5bb8
RGS
991 if (HvMROMETA(class_stash)->is_universal)
992 XSRETURN_YES;
993 else
994 XSRETURN_NO;
e1a479c5
BB
995}
996
c5860d66 997XS(XS_mro_get_global_sub_gen)
e1a479c5
BB
998{
999 dVAR;
1000 dXSARGS;
1001
1002 PERL_UNUSED_ARG(cv);
1003
1004 if (items != 0)
1005 Perl_croak(aTHX_ "Usage: mro::get_global_sub_generation()");
1006
1007 ST(0) = sv_2mortal(newSViv(PL_sub_generation));
1008 XSRETURN(1);
1009}
1010
c5860d66 1011XS(XS_mro_invalidate_method_caches)
e1a479c5
BB
1012{
1013 dVAR;
1014 dXSARGS;
1015
1016 PERL_UNUSED_ARG(cv);
1017
1018 if (items != 0)
1019 Perl_croak(aTHX_ "Usage: mro::invalidate_all_method_caches()");
1020
1021 PL_sub_generation++;
1022
1023 XSRETURN_EMPTY;
1024}
1025
1026XS(XS_mro_get_sub_generation)
1027{
1028 dVAR;
1029 dXSARGS;
1030 SV* classname;
1031 HV* class_stash;
1032
1033 PERL_UNUSED_ARG(cv);
1034
1035 if(items != 1)
1036 Perl_croak(aTHX_ "Usage: mro::get_sub_generation(classname)");
1037
1038 classname = ST(0);
1039 class_stash = gv_stashsv(classname, 0);
1040 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
1041
1042 ST(0) = sv_2mortal(newSViv(HvMROMETA(class_stash)->sub_generation));
1043 XSRETURN(1);
1044}
1045
1046XS(XS_mro_method_changed_in)
1047{
1048 dVAR;
1049 dXSARGS;
1050 SV* classname;
1051 HV* class_stash;
1052
1053 PERL_UNUSED_ARG(cv);
1054
1055 if(items != 1)
1056 Perl_croak(aTHX_ "Usage: mro::method_changed_in(classname)");
1057
1058 classname = ST(0);
1059
1060 class_stash = gv_stashsv(classname, 0);
1061 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
1062
1063 mro_method_changed_in(class_stash);
1064
1065 XSRETURN_EMPTY;
1066}
1067
1068XS(XS_next_can)
1069{
1070 dVAR;
1071 dXSARGS;
1072 SV* self = ST(0);
1073 SV* methcv = __nextcan(aTHX_ self, 0);
1074
1075 PERL_UNUSED_ARG(cv);
1076 PERL_UNUSED_VAR(items);
1077
1078 if(methcv == &PL_sv_undef) {
1079 ST(0) = &PL_sv_undef;
1080 }
1081 else {
1082 ST(0) = sv_2mortal(newRV_inc(methcv));
1083 }
1084
1085 XSRETURN(1);
1086}
1087
1088XS(XS_next_method)
1089{
1090 dMARK;
1091 dAX;
1092 SV* self = ST(0);
1093 SV* methcv = __nextcan(aTHX_ self, 1);
1094
1095 PERL_UNUSED_ARG(cv);
1096
1097 PL_markstack_ptr++;
1098 call_sv(methcv, GIMME_V);
1099}
1100
1101XS(XS_maybe_next_method)
1102{
1103 dMARK;
1104 dAX;
1105 SV* self = ST(0);
1106 SV* methcv = __nextcan(aTHX_ self, 0);
1107
1108 PERL_UNUSED_ARG(cv);
1109
1110 if(methcv == &PL_sv_undef) {
1111 ST(0) = &PL_sv_undef;
1112 XSRETURN(1);
1113 }
1114
1115 PL_markstack_ptr++;
1116 call_sv(methcv, GIMME_V);
1117}
1118
1119/*
1120 * Local variables:
1121 * c-indentation-style: bsd
1122 * c-basic-offset: 4
1123 * indent-tabs-mode: t
1124 * End:
1125 *
1126 * ex: set ts=8 sts=4 sw=4 noet:
1127 */