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