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