2 ==================================================================
3 --- Makefile.micro (/local/perl-current) (revision 30426)
4 +++ Makefile.micro (/local/perl-c3-subg) (revision 30426)
8 O = uav$(_O) udeb$(_O) udoio$(_O) udoop$(_O) udump$(_O) \
9 - uglobals$(_O) ugv$(_O) uhv$(_O) \
10 + uglobals$(_O) ugv$(_O) uhv$(_O) umro$(_O)\
11 umg$(_O) uperlmain$(_O) uop$(_O) ureentr$(_O) \
12 upad$(_O) uperl$(_O) uperlio$(_O) uperly$(_O) upp$(_O) \
13 upp_ctl$(_O) upp_hot$(_O) upp_sys$(_O) upp_pack$(_O) upp_sort$(_O) \
16 $(CC) -c -o $@ $(CFLAGS) gv.c
18 +umro$(_O): $(HE) mro.c
19 + $(CC) -c -o $@ $(CFLAGS) mro.c
22 $(CC) -c -o $@ $(CFLAGS) hv.c
25 ==================================================================
26 --- embed.h (/local/perl-current) (revision 30426)
27 +++ embed.h (/local/perl-c3-subg) (revision 30426)
29 #define gv_efullname4 Perl_gv_efullname4
30 #define gv_fetchfile Perl_gv_fetchfile
31 #define gv_fetchfile_flags Perl_gv_fetchfile_flags
32 +#define mro_meta_init Perl_mro_meta_init
33 +#define mro_linear Perl_mro_linear
34 +#define mro_linear_c3 Perl_mro_linear_c3
35 +#define mro_linear_dfs Perl_mro_linear_dfs
36 +#define mro_isa_changed_in Perl_mro_isa_changed_in
37 +#define mro_method_changed_in Perl_mro_method_changed_in
38 +#define boot_core_mro Perl_boot_core_mro
39 #define gv_fetchmeth Perl_gv_fetchmeth
40 #define gv_fetchmeth_autoload Perl_gv_fetchmeth_autoload
41 #define gv_fetchmethod_autoload Perl_gv_fetchmethod_autoload
42 @@ -2511,6 +2518,13 @@
43 #define gv_efullname4(a,b,c,d) Perl_gv_efullname4(aTHX_ a,b,c,d)
44 #define gv_fetchfile(a) Perl_gv_fetchfile(aTHX_ a)
45 #define gv_fetchfile_flags(a,b,c) Perl_gv_fetchfile_flags(aTHX_ a,b,c)
46 +#define mro_meta_init(a) Perl_mro_meta_init(aTHX_ a)
47 +#define mro_linear(a) Perl_mro_linear(aTHX_ a)
48 +#define mro_linear_c3(a,b) Perl_mro_linear_c3(aTHX_ a,b)
49 +#define mro_linear_dfs(a,b) Perl_mro_linear_dfs(aTHX_ a,b)
50 +#define mro_isa_changed_in(a) Perl_mro_isa_changed_in(aTHX_ a)
51 +#define mro_method_changed_in(a) Perl_mro_method_changed_in(aTHX_ a)
52 +#define boot_core_mro() Perl_boot_core_mro(aTHX)
53 #define gv_fetchmeth(a,b,c,d) Perl_gv_fetchmeth(aTHX_ a,b,c,d)
54 #define gv_fetchmeth_autoload(a,b,c,d) Perl_gv_fetchmeth_autoload(aTHX_ a,b,c,d)
55 #define gv_fetchmethod_autoload(a,b,c) Perl_gv_fetchmethod_autoload(aTHX_ a,b,c)
57 ==================================================================
58 --- pod/perlapi.pod (/local/perl-current) (revision 30426)
59 +++ pod/perlapi.pod (/local/perl-c3-subg) (revision 30426)
61 The argument C<level> should be either 0 or -1. If C<level==0>, as a
62 side-effect creates a glob with the given C<name> in the given C<stash>
63 which in the case of success contains an alias for the subroutine, and sets
64 -up caching info for this glob. Similarly for all the searched stashes.
65 +up caching info for this glob.
67 This function grants C<"SUPER"> token as a postfix of the stash name. The
68 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
70 ==================================================================
71 --- pp_ctl.c (/local/perl-current) (revision 30426)
72 +++ pp_ctl.c (/local/perl-c3-subg) (revision 30426)
73 @@ -3511,6 +3511,11 @@
74 && ret != PL_op->op_next) { /* Successive compilation. */
75 /* Copy in anything fake and short. */
76 my_strlcpy(safestr, fakestr, fakelen);
77 + /* XXX blblack - I don't understand what's going on here,
78 + but its not going to work like it used to, as PL_sub_generation
79 + is no longer incremented for all sub definitions. In any case
80 + this is a debugger-only thing
86 ==================================================================
87 --- global.sym (/local/perl-current) (revision 30426)
88 +++ global.sym (/local/perl-c3-subg) (revision 30426)
92 Perl_gv_fetchfile_flags
97 +Perl_mro_isa_changed_in
98 +Perl_mro_method_changed_in
101 Perl_gv_fetchmeth_autoload
104 ==================================================================
105 --- perl.c (/local/perl-current) (revision 30426)
106 +++ perl.c (/local/perl-c3-subg) (revision 30426)
107 @@ -2163,6 +2163,7 @@
109 boot_core_UNIVERSAL();
114 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
116 ==================================================================
117 --- universal.c (/local/perl-current) (revision 30426)
118 +++ universal.c (/local/perl-c3-subg) (revision 30426)
128 + AV* stash_linear_isa;
132 + PERL_UNUSED_ARG(len);
133 + PERL_UNUSED_ARG(level);
135 /* A stash/class can go by many names (ie. User == main::User), so
136 we compare the stash itself just in case */
138 if (strEQ(name, "UNIVERSAL"))
142 - Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
145 - gvp = (GV**)hv_fetchs(stash, "::ISA::CACHE::", FALSE);
147 - if (gvp && (gv = *gvp) && isGV_with_GP(gv) && (subgen = GvSV(gv))
148 - && (hv = GvHV(gv)))
150 - if (SvIV(subgen) == (IV)PL_sub_generation) {
151 - SV** const svp = (SV**)hv_fetch(hv, name, len, FALSE);
153 - SV * const sv = *svp;
155 - if (sv != &PL_sv_undef)
156 - DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
159 - return (sv == &PL_sv_yes);
161 + stash_linear_isa = (AV*)sv_2mortal((SV*)mro_linear(stash));
162 + svp = AvARRAY(stash_linear_isa) + 1;
163 + items = AvFILLp(stash_linear_isa);
165 + SV* const basename_sv = *svp++;
166 + HV* basestash = gv_stashsv(basename_sv, 0);
168 + if (ckWARN(WARN_MISC))
169 + Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
170 + "Can't locate package %"SVf" for the parents of %s",
171 + SVfARG(basename_sv), hvname);
175 - DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
178 - sv_setiv(subgen, PL_sub_generation);
180 + if(name_stash == basestash || strEQ(name, SvPVX(basename_sv)))
184 - gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
186 - if (gvp && (gv = *gvp) && isGV_with_GP(gv) && (av = GvAV(gv))) {
187 - if (!hv || !subgen) {
188 - gvp = (GV**)hv_fetchs(stash, "::ISA::CACHE::", TRUE);
192 - if (SvTYPE(gv) != SVt_PVGV)
193 - gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
198 - subgen = newSViv(PL_sub_generation);
203 - SV** svp = AvARRAY(av);
204 - /* NOTE: No support for tied ISA */
205 - I32 items = AvFILLp(av) + 1;
207 - SV* const sv = *svp++;
208 - HV* const basestash = gv_stashsv(sv, 0);
210 - if (ckWARN(WARN_MISC))
211 - Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
212 - "Can't locate package %"SVf" for @%s::ISA",
213 - SVfARG(sv), hvname);
216 - if (isa_lookup(basestash, name, name_stash, len, level + 1)) {
217 - (void)hv_store(hv,name,len,&PL_sv_yes,0);
221 - (void)hv_store(hv,name,len,&PL_sv_no,0);
228 ==================================================================
229 --- scope.c (/local/perl-current) (revision 30426)
230 +++ scope.c (/local/perl-c3-subg) (revision 30426)
232 GP *gp = Perl_newGP(aTHX_ gv);
235 - PL_sub_generation++; /* taking a method out of circulation */
236 + mro_method_changed_in(GvSTASH(gv)); /* taking a method out of circulation ("local")*/
237 if (GvIOp(gv) && (IoFLAGS(GvIOp(gv)) & IOf_ARGV)) {
239 IoFLAGS(gp->gp_io) |= IOf_ARGV|IOf_START;
244 - PL_sub_generation++; /* putting a method back into circulation */
245 + mro_method_changed_in(GvSTASH(gv)); /* putting a method back into circulation ("local")*/
250 ==================================================================
251 --- gv.c (/local/perl-current) (revision 30426)
252 +++ gv.c (/local/perl-c3-subg) (revision 30426)
257 - PL_sub_generation++;
258 + mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub ASDF::baz($); *ASDF::baz = \&Foo::bar */
260 CvFILE_set_from_cop(GvCV(gv), PL_curcop);
261 CvSTASH(GvCV(gv)) = PL_curstash;
263 The argument C<level> should be either 0 or -1. If C<level==0>, as a
264 side-effect creates a glob with the given C<name> in the given C<stash>
265 which in the case of success contains an alias for the subroutine, and sets
266 -up caching info for this glob. Similarly for all the searched stashes.
267 +up caching info for this glob.
269 This function grants C<"SUPER"> token as a postfix of the stash name. The
270 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
271 @@ -321,133 +321,150 @@
275 +/* NOTE: No support for tied ISA */
278 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
290 + GV* candidate = NULL;
291 + CV* cand_cv = NULL;
295 - HV* lastchance = NULL;
296 + I32 create = (level >= 0) ? 1 : 0;
301 /* UNIVERSAL methods should be callable without a stash */
303 - level = -1; /* probably appropriate */
304 + create = 0; /* probably appropriate */
305 if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
311 hvname = HvNAME_get(stash);
314 - "Can't use anonymous symbol table for method lookup");
315 + Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
317 - if ((level > 100) || (level < -100))
318 - Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
324 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) );
326 - gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
329 + topgen_cmp = HvMROMETA(stash)->sub_generation + PL_sub_generation;
331 + /* check locally for a real method or a cache entry */
332 + gvp = (GV**)hv_fetch(stash, name, len, create);
336 + if (SvTYPE(topgv) != SVt_PVGV)
337 + gv_init(topgv, stash, name, len, TRUE);
338 + if ((cand_cv = GvCV(topgv))) {
339 + /* If genuine method or valid cache entry, use it */
340 + if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
344 + /* stale cache entry, junk it and move on */
345 + SvREFCNT_dec(cand_cv);
346 + GvCV(topgv) = cand_cv = NULL;
347 + GvCVGEN(topgv) = 0;
350 + else if (GvCVGEN(topgv) == topgen_cmp) {
351 + /* cache indicates no such method definitively */
356 + packlen = HvNAMELEN_get(stash);
357 + if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
360 + basestash = gv_stashpvn(hvname, packlen, GV_ADD);
361 + linear_av = mro_linear(basestash);
365 - if (SvTYPE(topgv) != SVt_PVGV)
366 - gv_init(topgv, stash, name, len, TRUE);
367 - if ((cv = GvCV(topgv))) {
368 - /* If genuine method or valid cache entry, use it */
369 - if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
371 - /* Stale cached entry: junk it */
373 - GvCV(topgv) = cv = NULL;
374 - GvCVGEN(topgv) = 0;
376 - else if (GvCVGEN(topgv) == PL_sub_generation)
377 - return 0; /* cache indicates sub doesn't exist */
378 + linear_av = mro_linear(stash); /* has ourselves at the top of the list */
380 + sv_2mortal((SV*)linear_av);
382 - gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
383 - av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
384 + linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
385 + items = AvFILLp(linear_av); /* no +1, to skip over self */
387 + linear_sv = *linear_svp++;
389 + curstash = gv_stashsv(linear_sv, 0);
391 - /* create and re-create @.*::SUPER::ISA on demand */
392 - if (!av || !SvMAGIC(av)) {
393 - STRLEN packlen = HvNAMELEN_get(stash);
394 + /* mg.c:Perl_magic_setisa sets the fake flag on packages it had
395 + to create that the user did not. The "package" statement
396 + clears it. We also check if there's anything in the symbol
397 + table at all, which would indicate a previously "fake" package
398 + where someone adding things via $Foo::Bar = 1 without ever
399 + using a "package" statement.
400 + This was all neccesary because magic_setisa needs a place to
401 + keep isarev information on packages that aren't yet defined,
402 + yet we still need to issue this warning when appropriate.
404 + if (!curstash || (HvMROMETA(curstash)->fake && !HvFILL(curstash))) {
405 + if (ckWARN(WARN_MISC))
406 + Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
407 + SVfARG(linear_sv), hvname);
411 - if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
416 - basestash = gv_stashpvn(hvname, packlen, GV_ADD);
417 - gvp = (GV**)hv_fetchs(basestash, "ISA", FALSE);
418 - if (gvp && (gv = *gvp) && isGV_with_GP(gv) && (av = GvAV(gv))) {
419 - gvp = (GV**)hv_fetchs(stash, "ISA", TRUE);
420 - if (!gvp || !(gv = *gvp))
421 - Perl_croak(aTHX_ "Cannot create %s::ISA", hvname);
422 - if (SvTYPE(gv) != SVt_PVGV)
423 - gv_init(gv, stash, "ISA", 3, TRUE);
424 - SvREFCNT_dec(GvAV(gv));
425 - GvAV(gv) = (AV*)SvREFCNT_inc_simple(av);
428 + gvp = (GV**)hv_fetch(curstash, name, len, 0);
429 + if (!gvp) continue;
432 + if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, curstash, name, len, TRUE);
433 + if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
435 + * Found real method, cache method in topgv if:
436 + * 1. topgv has no synonyms (else inheritance crosses wires)
437 + * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
439 + if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
440 + if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv);
441 + SvREFCNT_inc_simple_void_NN(cand_cv);
442 + GvCV(topgv) = cand_cv;
443 + GvCVGEN(topgv) = topgen_cmp;
450 - SV** svp = AvARRAY(av);
451 - /* NOTE: No support for tied ISA */
452 - I32 items = AvFILLp(av) + 1;
454 - SV* const sv = *svp++;
455 - HV* const basestash = gv_stashsv(sv, 0);
457 - if (ckWARN(WARN_MISC))
458 - Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
459 - SVfARG(sv), hvname);
462 - gv = gv_fetchmeth(basestash, name, len,
463 - (level >= 0) ? level + 1 : level - 1);
467 + /* Check UNIVERSAL without caching */
468 + if(level == 0 || level == -1) {
469 + candidate = gv_fetchmeth(NULL, name, len, 1);
471 + cand_cv = GvCV(candidate);
472 + if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
473 + if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv);
474 + SvREFCNT_inc_simple_void_NN(cand_cv);
475 + GvCV(topgv) = cand_cv;
476 + GvCVGEN(topgv) = topgen_cmp;
482 - /* if at top level, try UNIVERSAL */
484 - if (level == 0 || level == -1) {
485 - lastchance = gv_stashpvs("UNIVERSAL", 0);
488 - if ((gv = gv_fetchmeth(lastchance, name, len,
489 - (level >= 0) ? level + 1 : level - 1)))
493 - * Cache method in topgv if:
494 - * 1. topgv has no synonyms (else inheritance crosses wires)
495 - * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
498 - GvREFCNT(topgv) == 1 &&
500 - (CvROOT(cv) || CvXSUB(cv)))
502 - if ((cv = GvCV(topgv)))
504 - GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
505 - GvCVGEN(topgv) = PL_sub_generation;
509 - else if (topgv && GvREFCNT(topgv) == 1) {
510 - /* cache the fact that the method is not defined */
511 - GvCVGEN(topgv) = PL_sub_generation;
514 + if (topgv && GvREFCNT(topgv) == 1) {
515 + /* cache the fact that the method is not defined */
516 + GvCVGEN(topgv) = topgen_cmp;
520 @@ -1436,15 +1453,22 @@
524 - /* multi-named GPs cannot be used for method cache */
525 + /* If the GP they asked for a reference to contains
526 + a method cache entry, clear it first, so that we
527 + don't infect them with our cached entry */
528 SvREFCNT_dec(gp->gp_cv);
533 - /* Adding a new name to a subroutine invalidates method cache */
534 - PL_sub_generation++;
536 + /* XXX if anyone finds a method cache regression with
537 + the "mro" stuff, turning this else block back on
538 + is probably the first place to look --blblack
542 + PL_sub_generation++;
548 @@ -1465,8 +1489,7 @@
552 - /* Deleting the name of a subroutine invalidates method cache */
553 - PL_sub_generation++;
554 + PL_sub_generation++;
556 if (--gp->gp_refcnt > 0) {
557 if (gp->gp_egv == gv)
558 @@ -1523,11 +1546,13 @@
560 MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
564 + newgen = PL_sub_generation + HvMROMETA(stash)->sub_generation;
566 const AMT * const amtp = (AMT*)mg->mg_ptr;
567 if (amtp->was_ok_am == PL_amagic_generation
568 - && amtp->was_ok_sub == PL_sub_generation) {
569 + && amtp->was_ok_sub == newgen) {
570 return (bool)AMT_OVERLOADED(amtp);
572 sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
573 @@ -1537,7 +1562,7 @@
576 amt.was_ok_am = PL_amagic_generation;
577 - amt.was_ok_sub = PL_sub_generation;
578 + amt.was_ok_sub = newgen;
579 amt.fallback = AMGfallNO;
582 @@ -1649,9 +1674,13 @@
588 if (!stash || !HvNAME_get(stash))
591 + newgen = PL_sub_generation + HvMROMETA(stash)->sub_generation;
593 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
596 @@ -1661,7 +1690,7 @@
598 amtp = (AMT*)mg->mg_ptr;
599 if ( amtp->was_ok_am != PL_amagic_generation
600 - || amtp->was_ok_sub != PL_sub_generation )
601 + || amtp->was_ok_sub != newgen )
603 if (AMT_AMAGIC(amtp)) {
604 CV * const ret = amtp->table[id];
606 ==================================================================
607 --- lib/constant.pm (/local/perl-current) (revision 30426)
608 +++ lib/constant.pm (/local/perl-c3-subg) (revision 30426)
610 use warnings::register;
612 our($VERSION, %declared);
616 #=======================================================================
619 # constants from cv_const_sv are read only. So we have to:
620 Internals::SvREADONLY($scalar, 1);
621 $symtab->{$name} = \$scalar;
622 - &Internals::inc_sub_generation;
623 + mro::invalidate_method_cache($pkg);
625 *$full_name = sub () { $scalar };
628 ==================================================================
629 --- lib/overload.pm (/local/perl-current) (revision 30426)
630 +++ lib/overload.pm (/local/perl-c3-subg) (revision 30426)
634 -our $VERSION = '1.04';
635 +our $VERSION = '1.05';
641 sub mycan { # Real can would leave stubs.
642 my ($package, $meth) = @_;
643 - return \*{$package . "::$meth"} if defined &{$package . "::$meth"};
645 - foreach $p (@{$package . "::ISA"}) {
646 - my $out = mycan($p, $meth);
647 - return $out if $out;
649 + my $mro = mro::get_linear_isa($package);
650 + foreach my $p (@$mro) {
651 + my $fqmeth = $p . q{::} . $meth;
652 + return \*{$fqmeth} if defined &{$fqmeth};
659 ==================================================================
660 --- lib/mro.pm (/local/perl-current) (revision 30426)
661 +++ lib/mro.pm (/local/perl-c3-subg) (revision 30426)
665 +# Copyright (c) 2007 Brandon L Black
667 +# You may distribute under the terms of either the GNU General Public
668 +# License or the Artistic License, as specified in the README file.
674 +our $VERSION = '0.01';
677 + mro::set_mro(scalar(caller), $_[1]) if $_[1];
686 +mro - Method Resolution Order
690 + use mro 'dfs'; # enable DFS mro for this class (Perl default)
691 + use mro 'c3'; # enable C3 mro for this class
703 +NOTE: These are built into the perl core, there is no need
704 +to do C<use mro> to access these functions.
706 +=head2 mro::get_linear_isa
708 +Arguments: classname[, type]
710 +Return an arrayref which is the linearized MRO of the given class.
711 +Uses whichever MRO is currently in effect for that class by default,
712 +or the given mro (either C<c3> or C<dfs> if specified as C<type>.
716 +Arguments: classname, type
718 +Sets the MRO of the given class to the C<type> argument (either
723 +Arguments: classname
725 +Returns the MRO of the given class (either C<c3> or C<dfs>)
727 +=head2 mro::get_global_sub_generation
731 +Returns the current value of C<PL_sub_generation>.
733 +=head2 mro::invalidate_all_method_caches
737 +Increments C<PL_sub_generation>, which invalidates method
738 +caching in all packages.
740 +=head2 mro::get_sub_generation
742 +Arguments: classname
744 +Returns the current value of a given package's C<sub_generation>.
745 +This is only incremented when necessary for that package.
747 +If one is trying to determine whether significant (method/cache-
748 +affecting) changes have occured for a given stash since you last
749 +checked, you should check both this and the global one above.
751 +=head2 mro::invalidate_method_cache
753 +Arguments: classname
755 +Invalidates the method cache of the given stash and any dependant
760 +Similar in concept to C<SUPER>, but substantially different in
761 +practice on C3-enabled classes. One generally uses it like so:
766 + my $superclass_answer = $self->next::method(@_);
767 + return $superclass_answer + 1;
770 +One major difference in invocation is that you don't
771 +(re-)specify the method name. It forces you to always
772 +use the same method name as the method you started in.
774 +It can be called on an object or a class, of course.
776 +The way it resolves which actual method to call is:
778 +1) First, it determines the linearized MRO of the
779 +object or class it is being called on.
781 +2) Then, it determines the class and method name
782 +of the context it was invoked from.
784 +3) Finally, it searches down the MRO list until
785 +it reaches the contextually enclosing class, then
786 +searches further down the MRO list for the next
787 +method with the same name as the contextually
790 +Failure to find a next method will result in an
791 +exception being thrown (see below for alternatives).
793 +With the Perl-default DFS MRO, this doesn't
794 +result in any substantial difference from the
795 +method resolution behavior of C<SUPER>, but it
796 +changes everything under C3 (this becomes obvious
797 +when one realizes that the common classes in the
798 +C3 linearizations of a given class and one of its
799 +parents will not always be ordered the same for
800 +both). C<next::method>'s resolution behavior
801 +gives the most consistent results (an object's
802 +methods always resolve in that object's MRO
807 +Like C<next::method>, but just returns either
808 +a code reference or C<undef> to indicate that
809 +no further methods of this name exist.
811 +=head2 maybe::next::method
813 +In simple cases it is equivalent to:
815 + $self->next::method(@_) if $self->next_can;
817 +But there are some cases where only this solution
818 +works (like "goto &maybe::next::method");
822 +Brandon L Black, C<blblack@gmail.com>
826 ==================================================================
827 --- win32/Makefile (/local/perl-current) (revision 30426)
828 +++ win32/Makefile (/local/perl-c3-subg) (revision 30426)
837 === win32/makefile.mk
838 ==================================================================
839 --- win32/makefile.mk (/local/perl-current) (revision 30426)
840 +++ win32/makefile.mk (/local/perl-c3-subg) (revision 30426)
849 === win32/Makefile.ce
850 ==================================================================
851 --- win32/Makefile.ce (/local/perl-current) (revision 30426)
852 +++ win32/Makefile.ce (/local/perl-c3-subg) (revision 30426)
863 $(DLLDIR)\globals.obj \
867 $(DLLDIR)\locale.obj \
868 $(DLLDIR)\mathoms.obj \
870 ==================================================================
871 --- t/TEST (/local/perl-current) (revision 30426)
872 +++ t/TEST (/local/perl-c3-subg) (revision 30426)
877 - foreach my $dir (qw(base comp cmd run io op uni)) {
878 + foreach my $dir (qw(base comp cmd run io op uni mro)) {
881 _find_tests("lib") unless $::core;
882 === t/mro (new directory)
883 ==================================================================
884 === t/mro/basic_01_dfs.t
885 ==================================================================
886 --- t/mro/basic_01_dfs.t (/local/perl-current) (revision 30426)
887 +++ t/mro/basic_01_dfs.t (/local/perl-c3-subg) (revision 30426)
894 + unless (-d 'blib') {
895 + chdir 't' if -d 't';
900 +use Test::More tests => 4;
904 +This tests the classic diamond inheritence pattern.
916 + sub hello { 'Diamond_A::hello' }
920 + use base 'Diamond_A';
924 + use base 'Diamond_A';
926 + sub hello { 'Diamond_C::hello' }
930 + use base ('Diamond_B', 'Diamond_C');
935 + mro::get_linear_isa('Diamond_D'),
936 + [ qw(Diamond_D Diamond_B Diamond_A Diamond_C) ],
937 + '... got the right MRO for Diamond_D');
939 +is(Diamond_D->hello, 'Diamond_A::hello', '... method resolved itself as expected');
940 +is(Diamond_D->can('hello')->(), 'Diamond_A::hello', '... can(method) resolved itself as expected');
941 +is(UNIVERSAL::can("Diamond_D", 'hello')->(), 'Diamond_A::hello', '... can(method) resolved itself as expected');
942 === t/mro/vulcan_c3.t
943 ==================================================================
944 --- t/mro/vulcan_c3.t (/local/perl-current) (revision 30426)
945 +++ t/mro/vulcan_c3.t (/local/perl-c3-subg) (revision 30426)
952 + unless (-d 'blib') {
953 + chdir 't' if -d 't';
958 +use Test::More tests => 1;
963 +example taken from: L<http://gauss.gwydiondylan.org/books/drm/drm_50.html>
974 + Intelligent Humanoid
979 + define class <sentient> (<life-form>) end class;
980 + define class <bipedal> (<life-form>) end class;
981 + define class <intelligent> (<sentient>) end class;
982 + define class <humanoid> (<bipedal>) end class;
983 + define class <vulcan> (<intelligent>, <humanoid>) end class;
997 + use base 'LifeForm';
1001 + use base 'LifeForm';
1003 + package Intelligent;
1005 + use base 'Sentient';
1009 + use base 'BiPedal';
1013 + use base ('Intelligent', 'Humanoid');
1017 + mro::get_linear_isa('Vulcan'),
1018 + [ qw(Vulcan Intelligent Sentient Humanoid BiPedal LifeForm Object) ],
1019 + '... got the right MRO for the Vulcan Dylan Example');
1020 === t/mro/basic_02_dfs.t
1021 ==================================================================
1022 --- t/mro/basic_02_dfs.t (/local/perl-current) (revision 30426)
1023 +++ t/mro/basic_02_dfs.t (/local/perl-c3-subg) (revision 30426)
1030 + unless (-d 'blib') {
1031 + chdir 't' if -d 't';
1036 +use Test::More tests => 10;
1040 +This example is take from: http://www.python.org/2.3/mro.html
1054 +Level 3 | O | (more general)
1060 +Level 2 3 | D | 4| E | | F | 5 |
1066 +Level 1 1 | B | | C | 2 |
1071 +Level 0 0 | A | (more specialized)
1082 + use base 'Test::O';
1085 + use base 'Test::O';
1088 + sub C_or_E { 'Test::E' }
1092 + use base 'Test::O';
1094 + sub C_or_D { 'Test::D' }
1097 + use base ('Test::D', 'Test::F');
1100 + sub C_or_D { 'Test::C' }
1101 + sub C_or_E { 'Test::C' }
1105 + use base ('Test::D', 'Test::E');
1108 + use base ('Test::B', 'Test::C');
1113 + mro::get_linear_isa('Test::F'),
1114 + [ qw(Test::F Test::O) ],
1115 + '... got the right MRO for Test::F');
1118 + mro::get_linear_isa('Test::E'),
1119 + [ qw(Test::E Test::O) ],
1120 + '... got the right MRO for Test::E');
1123 + mro::get_linear_isa('Test::D'),
1124 + [ qw(Test::D Test::O) ],
1125 + '... got the right MRO for Test::D');
1128 + mro::get_linear_isa('Test::C'),
1129 + [ qw(Test::C Test::D Test::O Test::F) ],
1130 + '... got the right MRO for Test::C');
1133 + mro::get_linear_isa('Test::B'),
1134 + [ qw(Test::B Test::D Test::O Test::E) ],
1135 + '... got the right MRO for Test::B');
1138 + mro::get_linear_isa('Test::A'),
1139 + [ qw(Test::A Test::B Test::D Test::O Test::E Test::C Test::F) ],
1140 + '... got the right MRO for Test::A');
1142 +is(Test::A->C_or_D, 'Test::D', '... got the expected method output');
1143 +is(Test::A->can('C_or_D')->(), 'Test::D', '... can got the expected method output');
1144 +is(Test::A->C_or_E, 'Test::E', '... got the expected method output');
1145 +is(Test::A->can('C_or_E')->(), 'Test::E', '... can got the expected method output');
1146 === t/mro/basic_03_dfs.t
1147 ==================================================================
1148 --- t/mro/basic_03_dfs.t (/local/perl-current) (revision 30426)
1149 +++ t/mro/basic_03_dfs.t (/local/perl-c3-subg) (revision 30426)
1156 + unless (-d 'blib') {
1157 + chdir 't' if -d 't';
1162 +use Test::More tests => 4;
1166 +This example is take from: http://www.python.org/2.3/mro.html
1168 +"My second example"
1185 +Level 2 2 | E | 4 | D | | F | 5
1191 +Level 1 1 | B | | C | 3
1200 +(<class '__main__.A'>, <class '__main__.B'>, <class '__main__.E'>,
1201 +<class '__main__.C'>, <class '__main__.D'>, <class '__main__.F'>,
1210 + sub O_or_D { 'Test::O' }
1211 + sub O_or_F { 'Test::O' }
1214 + use base 'Test::O';
1217 + sub O_or_F { 'Test::F' }
1220 + use base 'Test::O';
1224 + use base 'Test::O';
1227 + sub O_or_D { 'Test::D' }
1228 + sub C_or_D { 'Test::D' }
1231 + use base ('Test::D', 'Test::F');
1234 + sub C_or_D { 'Test::C' }
1237 + use base ('Test::E', 'Test::D');
1241 + use base ('Test::B', 'Test::C');
1246 + mro::get_linear_isa('Test::A'),
1247 + [ qw(Test::A Test::B Test::E Test::O Test::D Test::C Test::F) ],
1248 + '... got the right MRO for Test::A');
1250 +is(Test::A->O_or_D, 'Test::O', '... got the right method dispatch');
1251 +is(Test::A->O_or_F, 'Test::O', '... got the right method dispatch');
1254 +# this test is particularly interesting because the p5 dispatch
1255 +# would actually call Test::D before Test::C and Test::D is a
1256 +# subclass of Test::C
1257 +is(Test::A->C_or_D, 'Test::D', '... got the right method dispatch');
1258 === t/mro/basic_04_dfs.t
1259 ==================================================================
1260 --- t/mro/basic_04_dfs.t (/local/perl-current) (revision 30426)
1261 +++ t/mro/basic_04_dfs.t (/local/perl-c3-subg) (revision 30426)
1268 + unless (-d 'blib') {
1269 + chdir 't' if -d 't';
1274 +use Test::More tests => 1;
1278 +From the parrot test t/pmc/object-meths.t
1290 + package t::lib::A; use mro 'dfs';
1291 + package t::lib::B; use mro 'dfs';
1292 + package t::lib::E; use mro 'dfs';
1293 + package t::lib::C; use mro 'dfs'; use base ('t::lib::A', 't::lib::B');
1294 + package t::lib::D; use mro 'dfs'; use base ('t::lib::A', 't::lib::E');
1295 + package t::lib::F; use mro 'dfs'; use base ('t::lib::C', 't::lib::D');
1299 + mro::get_linear_isa('t::lib::F'),
1300 + [ qw(t::lib::F t::lib::C t::lib::A t::lib::B t::lib::D t::lib::E) ],
1301 + '... got the right MRO for t::lib::F');
1303 === t/mro/basic_05_dfs.t
1304 ==================================================================
1305 --- t/mro/basic_05_dfs.t (/local/perl-current) (revision 30426)
1306 +++ t/mro/basic_05_dfs.t (/local/perl-c3-subg) (revision 30426)
1313 + unless (-d 'blib') {
1314 + chdir 't' if -d 't';
1319 +use Test::More tests => 2;
1323 +This tests a strange bug found by Matt S. Trout
1324 +while building DBIx::Class. Thanks Matt!!!!
1335 + package Diamond_A;
1338 + sub foo { 'Diamond_A::foo' }
1341 + package Diamond_B;
1342 + use base 'Diamond_A';
1345 + sub foo { 'Diamond_B::foo => ' . (shift)->SUPER::foo }
1348 + package Diamond_C;
1350 + use base 'Diamond_A';
1354 + package Diamond_D;
1355 + use base ('Diamond_C', 'Diamond_B');
1358 + sub foo { 'Diamond_D::foo => ' . (shift)->SUPER::foo }
1362 + mro::get_linear_isa('Diamond_D'),
1363 + [ qw(Diamond_D Diamond_C Diamond_A Diamond_B) ],
1364 + '... got the right MRO for Diamond_D');
1367 + 'Diamond_D::foo => Diamond_A::foo',
1368 + '... got the right next::method dispatch path');
1369 === t/mro/vulcan_dfs.t
1370 ==================================================================
1371 --- t/mro/vulcan_dfs.t (/local/perl-current) (revision 30426)
1372 +++ t/mro/vulcan_dfs.t (/local/perl-c3-subg) (revision 30426)
1379 + unless (-d 'blib') {
1380 + chdir 't' if -d 't';
1385 +use Test::More tests => 1;
1390 +example taken from: L<http://gauss.gwydiondylan.org/books/drm/drm_50.html>
1401 + Intelligent Humanoid
1406 + define class <sentient> (<life-form>) end class;
1407 + define class <bipedal> (<life-form>) end class;
1408 + define class <intelligent> (<sentient>) end class;
1409 + define class <humanoid> (<bipedal>) end class;
1410 + define class <vulcan> (<intelligent>, <humanoid>) end class;
1420 + use base 'Object';
1424 + use base 'LifeForm';
1428 + use base 'LifeForm';
1430 + package Intelligent;
1432 + use base 'Sentient';
1436 + use base 'BiPedal';
1440 + use base ('Intelligent', 'Humanoid');
1444 + mro::get_linear_isa('Vulcan'),
1445 + [ qw(Vulcan Intelligent Sentient LifeForm Object Humanoid BiPedal) ],
1446 + '... got the right MRO for the Vulcan Dylan Example');
1448 ==================================================================
1449 --- t/mro/dbic_c3.t (/local/perl-current) (revision 30426)
1450 +++ t/mro/dbic_c3.t (/local/perl-c3-subg) (revision 30426)
1457 + unless (-d 'blib') {
1458 + chdir 't' if -d 't';
1463 +use Test::More tests => 1;
1467 +This example is taken from the inheritance graph of DBIx::Class::Core in DBIx::Class v0.07002:
1468 +(No ASCII art this time, this graph is insane)
1470 +The xx:: prefixes are just to be sure these bogus declarations never stomp on real ones
1475 + package xx::DBIx::Class::Core; use mro 'c3';
1477 + xx::DBIx::Class::Serialize::Storable
1478 + xx::DBIx::Class::InflateColumn
1479 + xx::DBIx::Class::Relationship
1480 + xx::DBIx::Class::PK::Auto
1481 + xx::DBIx::Class::PK
1482 + xx::DBIx::Class::Row
1483 + xx::DBIx::Class::ResultSourceProxy::Table
1484 + xx::DBIx::Class::AccessorGroup
1487 + package xx::DBIx::Class::InflateColumn; use mro 'c3';
1488 + our @ISA = qw/ xx::DBIx::Class::Row /;
1490 + package xx::DBIx::Class::Row; use mro 'c3';
1491 + our @ISA = qw/ xx::DBIx::Class /;
1493 + package xx::DBIx::Class; use mro 'c3';
1495 + xx::DBIx::Class::Componentised
1496 + xx::Class::Data::Accessor
1499 + package xx::DBIx::Class::Relationship; use mro 'c3';
1501 + xx::DBIx::Class::Relationship::Helpers
1502 + xx::DBIx::Class::Relationship::Accessor
1503 + xx::DBIx::Class::Relationship::CascadeActions
1504 + xx::DBIx::Class::Relationship::ProxyMethods
1505 + xx::DBIx::Class::Relationship::Base
1509 + package xx::DBIx::Class::Relationship::Helpers; use mro 'c3';
1511 + xx::DBIx::Class::Relationship::HasMany
1512 + xx::DBIx::Class::Relationship::HasOne
1513 + xx::DBIx::Class::Relationship::BelongsTo
1514 + xx::DBIx::Class::Relationship::ManyToMany
1517 + package xx::DBIx::Class::Relationship::ProxyMethods; use mro 'c3';
1518 + our @ISA = qw/ xx::DBIx::Class /;
1520 + package xx::DBIx::Class::Relationship::Base; use mro 'c3';
1521 + our @ISA = qw/ xx::DBIx::Class /;
1523 + package xx::DBIx::Class::PK::Auto; use mro 'c3';
1524 + our @ISA = qw/ xx::DBIx::Class /;
1526 + package xx::DBIx::Class::PK; use mro 'c3';
1527 + our @ISA = qw/ xx::DBIx::Class::Row /;
1529 + package xx::DBIx::Class::ResultSourceProxy::Table; use mro 'c3';
1531 + xx::DBIx::Class::AccessorGroup
1532 + xx::DBIx::Class::ResultSourceProxy
1535 + package xx::DBIx::Class::ResultSourceProxy; use mro 'c3';
1536 + our @ISA = qw/ xx::DBIx::Class /;
1538 + package xx::Class::Data::Accessor; our @ISA = (); use mro 'c3';
1539 + package xx::DBIx::Class::Relationship::HasMany; our @ISA = (); use mro 'c3';
1540 + package xx::DBIx::Class::Relationship::HasOne; our @ISA = (); use mro 'c3';
1541 + package xx::DBIx::Class::Relationship::BelongsTo; our @ISA = (); use mro 'c3';
1542 + package xx::DBIx::Class::Relationship::ManyToMany; our @ISA = (); use mro 'c3';
1543 + package xx::DBIx::Class::Componentised; our @ISA = (); use mro 'c3';
1544 + package xx::DBIx::Class::AccessorGroup; our @ISA = (); use mro 'c3';
1545 + package xx::DBIx::Class::Serialize::Storable; our @ISA = (); use mro 'c3';
1546 + package xx::DBIx::Class::Relationship::Accessor; our @ISA = (); use mro 'c3';
1547 + package xx::DBIx::Class::Relationship::CascadeActions; our @ISA = (); use mro 'c3';
1551 + mro::get_linear_isa('xx::DBIx::Class::Core'),
1553 + xx::DBIx::Class::Core
1554 + xx::DBIx::Class::Serialize::Storable
1555 + xx::DBIx::Class::InflateColumn
1556 + xx::DBIx::Class::Relationship
1557 + xx::DBIx::Class::Relationship::Helpers
1558 + xx::DBIx::Class::Relationship::HasMany
1559 + xx::DBIx::Class::Relationship::HasOne
1560 + xx::DBIx::Class::Relationship::BelongsTo
1561 + xx::DBIx::Class::Relationship::ManyToMany
1562 + xx::DBIx::Class::Relationship::Accessor
1563 + xx::DBIx::Class::Relationship::CascadeActions
1564 + xx::DBIx::Class::Relationship::ProxyMethods
1565 + xx::DBIx::Class::Relationship::Base
1566 + xx::DBIx::Class::PK::Auto
1567 + xx::DBIx::Class::PK
1568 + xx::DBIx::Class::Row
1569 + xx::DBIx::Class::ResultSourceProxy::Table
1570 + xx::DBIx::Class::AccessorGroup
1571 + xx::DBIx::Class::ResultSourceProxy
1573 + xx::DBIx::Class::Componentised
1574 + xx::Class::Data::Accessor
1576 + '... got the right C3 merge order for xx::DBIx::Class::Core');
1577 === t/mro/method_caching.t
1578 ==================================================================
1579 --- t/mro/method_caching.t (/local/perl-current) (revision 30426)
1580 +++ t/mro/method_caching.t (/local/perl-c3-subg) (revision 30426)
1586 +no warnings 'redefine'; # we do a lot of this
1587 +no warnings 'prototype'; # we do a lot of this
1590 + unless (-d 'blib') {
1591 + chdir 't' if -d 't';
1599 + package MCTest::Base;
1600 + sub foo { return $_[1]+1 };
1603 + package MCTest::Derived;
1604 + our @ISA = qw/MCTest::Base/;
1607 +# These are various ways of re-defining MCTest::Base::foo and checking whether the method is cached when it shouldn't be
1609 + sub { eval 'sub MCTest::Base::foo { return $_[1]+2 }'; is(MCTest::Derived->foo(0), 2); },
1610 + sub { eval 'sub MCTest::Base::foo($) { return $_[1]+3 }'; is(MCTest::Derived->foo(0), 3); },
1611 + sub { eval 'sub MCTest::Base::foo($) { 4 }'; is(MCTest::Derived->foo(0), 4); },
1612 + sub { *MCTest::Base::foo = sub { $_[1]+5 }; is(MCTest::Derived->foo(0), 5); },
1613 + sub { local *MCTest::Base::foo = sub { $_[1]+6 }; is(MCTest::Derived->foo(0), 6); },
1614 + sub { is(MCTest::Derived->foo(0), 5); },
1615 + sub { sub FFF { $_[1]+9 }; local *MCTest::Base::foo = *FFF; is(MCTest::Derived->foo(0), 9); },
1616 + sub { is(MCTest::Derived->foo(0), 5); },
1617 + sub { *ASDF::asdf = sub { $_[1]+7 }; *MCTest::Base::foo = \&ASDF::asdf; is(MCTest::Derived->foo(0), 7); },
1618 + sub { *ASDF::asdf = sub { $_[1]+7 }; *MCTest::Base::foo = \&ASDF::asdf; is(MCTest::Derived->foo(0), 7); },
1619 + sub { undef *MCTest::Base::foo; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); },
1620 + sub { sub MCTest::Base::foo($); *MCTest::Base::foo = \&ASDF::asdf; is(MCTest::Derived->foo(0), 7); },
1621 + sub { *XYZ = sub { $_[1]+8 }; ${MCTest::Base::}{foo} = \&XYZ; is(MCTest::Derived->foo(0), 8); },
1624 +plan tests => scalar(@testsubs) + 1;
1626 +is(MCTest::Derived->foo(0), 1);
1627 +$_->() for (@testsubs);
1628 === t/mro/complex_c3.t
1629 ==================================================================
1630 --- t/mro/complex_c3.t (/local/perl-current) (revision 30426)
1631 +++ t/mro/complex_c3.t (/local/perl-c3-subg) (revision 30426)
1638 + unless (-d 'blib') {
1639 + chdir 't' if -d 't';
1644 +use Test::More tests => 12;
1648 +This example is taken from: http://rt.cpan.org/Public/Bug/Display.html?id=20879
1651 +Level 5 8 | A | 9 | B | A | C | (More General)
1663 +Level 3 4 | G | 6 | E | |
1668 +Level 2 3 | H | 5 | F | |
1676 +Level 1 1 | J | 2 | I | |
1681 +Level 0 0 | K | (More Specialized)
1691 + package Test::A; use mro 'c3';
1693 + package Test::B; use mro 'c3';
1695 + package Test::C; use mro 'c3';
1697 + package Test::D; use mro 'c3';
1698 + use base qw/Test::A Test::B Test::C/;
1700 + package Test::E; use mro 'c3';
1701 + use base qw/Test::D/;
1703 + package Test::F; use mro 'c3';
1704 + use base qw/Test::E/;
1705 + sub testmeth { "wrong" }
1707 + package Test::G; use mro 'c3';
1708 + use base qw/Test::D/;
1710 + package Test::H; use mro 'c3';
1711 + use base qw/Test::G/;
1713 + package Test::I; use mro 'c3';
1714 + use base qw/Test::H Test::F/;
1715 + sub testmeth { "right" }
1717 + package Test::J; use mro 'c3';
1718 + use base qw/Test::F/;
1720 + package Test::K; use mro 'c3';
1721 + use base qw/Test::J Test::I/;
1722 + sub testmeth { shift->next::method }
1726 + mro::get_linear_isa('Test::A'),
1728 + '... got the right C3 merge order for Test::A');
1731 + mro::get_linear_isa('Test::B'),
1733 + '... got the right C3 merge order for Test::B');
1736 + mro::get_linear_isa('Test::C'),
1738 + '... got the right C3 merge order for Test::C');
1741 + mro::get_linear_isa('Test::D'),
1742 + [ qw(Test::D Test::A Test::B Test::C) ],
1743 + '... got the right C3 merge order for Test::D');
1746 + mro::get_linear_isa('Test::E'),
1747 + [ qw(Test::E Test::D Test::A Test::B Test::C) ],
1748 + '... got the right C3 merge order for Test::E');
1751 + mro::get_linear_isa('Test::F'),
1752 + [ qw(Test::F Test::E Test::D Test::A Test::B Test::C) ],
1753 + '... got the right C3 merge order for Test::F');
1756 + mro::get_linear_isa('Test::G'),
1757 + [ qw(Test::G Test::D Test::A Test::B Test::C) ],
1758 + '... got the right C3 merge order for Test::G');
1761 + mro::get_linear_isa('Test::H'),
1762 + [ qw(Test::H Test::G Test::D Test::A Test::B Test::C) ],
1763 + '... got the right C3 merge order for Test::H');
1766 + mro::get_linear_isa('Test::I'),
1767 + [ qw(Test::I Test::H Test::G Test::F Test::E Test::D Test::A Test::B Test::C) ],
1768 + '... got the right C3 merge order for Test::I');
1771 + mro::get_linear_isa('Test::J'),
1772 + [ qw(Test::J Test::F Test::E Test::D Test::A Test::B Test::C) ],
1773 + '... got the right C3 merge order for Test::J');
1776 + mro::get_linear_isa('Test::K'),
1777 + [ qw(Test::K Test::J Test::I Test::H Test::G Test::F Test::E Test::D Test::A Test::B Test::C) ],
1778 + '... got the right C3 merge order for Test::K');
1780 +is(Test::K->testmeth(), "right", 'next::method working ok');
1781 === t/mro/dbic_dfs.t
1782 ==================================================================
1783 --- t/mro/dbic_dfs.t (/local/perl-current) (revision 30426)
1784 +++ t/mro/dbic_dfs.t (/local/perl-c3-subg) (revision 30426)
1791 + unless (-d 'blib') {
1792 + chdir 't' if -d 't';
1797 +use Test::More tests => 1;
1801 +This example is taken from the inheritance graph of DBIx::Class::Core in DBIx::Class v0.07002:
1802 +(No ASCII art this time, this graph is insane)
1804 +The xx:: prefixes are just to be sure these bogus declarations never stomp on real ones
1809 + package xx::DBIx::Class::Core; use mro 'dfs';
1811 + xx::DBIx::Class::Serialize::Storable
1812 + xx::DBIx::Class::InflateColumn
1813 + xx::DBIx::Class::Relationship
1814 + xx::DBIx::Class::PK::Auto
1815 + xx::DBIx::Class::PK
1816 + xx::DBIx::Class::Row
1817 + xx::DBIx::Class::ResultSourceProxy::Table
1818 + xx::DBIx::Class::AccessorGroup
1821 + package xx::DBIx::Class::InflateColumn; use mro 'dfs';
1822 + our @ISA = qw/ xx::DBIx::Class::Row /;
1824 + package xx::DBIx::Class::Row; use mro 'dfs';
1825 + our @ISA = qw/ xx::DBIx::Class /;
1827 + package xx::DBIx::Class; use mro 'dfs';
1829 + xx::DBIx::Class::Componentised
1830 + xx::Class::Data::Accessor
1833 + package xx::DBIx::Class::Relationship; use mro 'dfs';
1835 + xx::DBIx::Class::Relationship::Helpers
1836 + xx::DBIx::Class::Relationship::Accessor
1837 + xx::DBIx::Class::Relationship::CascadeActions
1838 + xx::DBIx::Class::Relationship::ProxyMethods
1839 + xx::DBIx::Class::Relationship::Base
1843 + package xx::DBIx::Class::Relationship::Helpers; use mro 'dfs';
1845 + xx::DBIx::Class::Relationship::HasMany
1846 + xx::DBIx::Class::Relationship::HasOne
1847 + xx::DBIx::Class::Relationship::BelongsTo
1848 + xx::DBIx::Class::Relationship::ManyToMany
1851 + package xx::DBIx::Class::Relationship::ProxyMethods; use mro 'dfs';
1852 + our @ISA = qw/ xx::DBIx::Class /;
1854 + package xx::DBIx::Class::Relationship::Base; use mro 'dfs';
1855 + our @ISA = qw/ xx::DBIx::Class /;
1857 + package xx::DBIx::Class::PK::Auto; use mro 'dfs';
1858 + our @ISA = qw/ xx::DBIx::Class /;
1860 + package xx::DBIx::Class::PK; use mro 'dfs';
1861 + our @ISA = qw/ xx::DBIx::Class::Row /;
1863 + package xx::DBIx::Class::ResultSourceProxy::Table; use mro 'dfs';
1865 + xx::DBIx::Class::AccessorGroup
1866 + xx::DBIx::Class::ResultSourceProxy
1869 + package xx::DBIx::Class::ResultSourceProxy; use mro 'dfs';
1870 + our @ISA = qw/ xx::DBIx::Class /;
1872 + package xx::Class::Data::Accessor; our @ISA = (); use mro 'dfs';
1873 + package xx::DBIx::Class::Relationship::HasMany; our @ISA = (); use mro 'dfs';
1874 + package xx::DBIx::Class::Relationship::HasOne; our @ISA = (); use mro 'dfs';
1875 + package xx::DBIx::Class::Relationship::BelongsTo; our @ISA = (); use mro 'dfs';
1876 + package xx::DBIx::Class::Relationship::ManyToMany; our @ISA = (); use mro 'dfs';
1877 + package xx::DBIx::Class::Componentised; our @ISA = (); use mro 'dfs';
1878 + package xx::DBIx::Class::AccessorGroup; our @ISA = (); use mro 'dfs';
1879 + package xx::DBIx::Class::Serialize::Storable; our @ISA = (); use mro 'dfs';
1880 + package xx::DBIx::Class::Relationship::Accessor; our @ISA = (); use mro 'dfs';
1881 + package xx::DBIx::Class::Relationship::CascadeActions; our @ISA = (); use mro 'dfs';
1885 + mro::get_linear_isa('xx::DBIx::Class::Core'),
1887 + xx::DBIx::Class::Core
1888 + xx::DBIx::Class::Serialize::Storable
1889 + xx::DBIx::Class::InflateColumn
1890 + xx::DBIx::Class::Row
1892 + xx::DBIx::Class::Componentised
1893 + xx::Class::Data::Accessor
1894 + xx::DBIx::Class::Relationship
1895 + xx::DBIx::Class::Relationship::Helpers
1896 + xx::DBIx::Class::Relationship::HasMany
1897 + xx::DBIx::Class::Relationship::HasOne
1898 + xx::DBIx::Class::Relationship::BelongsTo
1899 + xx::DBIx::Class::Relationship::ManyToMany
1900 + xx::DBIx::Class::Relationship::Accessor
1901 + xx::DBIx::Class::Relationship::CascadeActions
1902 + xx::DBIx::Class::Relationship::ProxyMethods
1903 + xx::DBIx::Class::Relationship::Base
1904 + xx::DBIx::Class::PK::Auto
1905 + xx::DBIx::Class::PK
1906 + xx::DBIx::Class::ResultSourceProxy::Table
1907 + xx::DBIx::Class::AccessorGroup
1908 + xx::DBIx::Class::ResultSourceProxy
1910 + '... got the right DFS merge order for xx::DBIx::Class::Core');
1911 === t/mro/recursion_c3.t
1912 ==================================================================
1913 --- t/mro/recursion_c3.t (/local/perl-current) (revision 30426)
1914 +++ t/mro/recursion_c3.t (/local/perl-c3-subg) (revision 30426)
1921 + unless (-d 'blib') {
1922 + chdir 't' if -d 't';
1930 +# XXX needs translation back to classes, etc
1932 +plan skip_all => "Your system has no SIGALRM" if !exists $SIG{ALRM};
1937 +These are like the 010_complex_merge_classless test,
1938 +but an infinite loop has been made in the heirarchy,
1939 +to test that we can fail cleanly instead of going
1940 +into an infinite loop
1944 +# initial setup, everything sane
1947 + our @ISA = qw/J I/;
1951 + our @ISA = qw/H F/;
1961 + our @ISA = qw/A B C/;
1970 +# A series of 8 abberations that would cause infinite loops,
1971 +# each one undoing the work of the previous
1973 + sub { @E::ISA = qw/F/ },
1974 + sub { @E::ISA = qw/D/; @C::ISA = qw/F/ },
1975 + sub { @C::ISA = qw//; @A::ISA = qw/K/ },
1976 + sub { @A::ISA = qw//; @J::ISA = qw/F K/ },
1977 + sub { @J::ISA = qw/F/; @H::ISA = qw/K G/ },
1978 + sub { @H::ISA = qw/G/; @B::ISA = qw/B/ },
1979 + sub { @B::ISA = qw//; @K::ISA = qw/K J I/ },
1980 + sub { @K::ISA = qw/J I/; @D::ISA = qw/A H B C/ },
1983 +foreach my $loopy (@loopies) {
1985 + local $SIG{ALRM} = sub { die "ALRMTimeout" };
1988 + mro::get_linear_isa('K', 'c3');
1991 + if(my $err = $@) {
1992 + if($err =~ /ALRMTimeout/) {
1993 + ok(0, "Loop terminated by SIGALRM");
1995 + elsif($err =~ /Recursive inheritance detected/) {
1996 + ok(1, "Graceful exception thrown");
1999 + ok(0, "Unrecognized exception: $err");
2003 + ok(0, "Infinite loop apparently succeeded???");
2006 === t/mro/overload_c3.t
2007 ==================================================================
2008 --- t/mro/overload_c3.t (/local/perl-current) (revision 30426)
2009 +++ t/mro/overload_c3.t (/local/perl-c3-subg) (revision 30426)
2016 + unless (-d 'blib') {
2017 + chdir 't' if -d 't';
2022 +use Test::More tests => 7;
2030 + package OverloadingTest;
2034 + use base 'BaseTest';
2035 + use overload '""' => sub { ref(shift) . " stringified" },
2038 + sub new { bless {} => shift }
2040 + package InheritingFromOverloadedTest;
2043 + use base 'OverloadingTest';
2047 +my $x = InheritingFromOverloadedTest->new();
2048 +isa_ok($x, 'InheritingFromOverloadedTest');
2050 +my $y = OverloadingTest->new();
2051 +isa_ok($y, 'OverloadingTest');
2053 +is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing');
2054 +is("$y", 'OverloadingTest stringified', '... got the right value when stringifing');
2056 +ok(($y eq 'OverloadingTest stringified'), '... eq was handled correctly');
2060 + $result = $x eq 'InheritingFromOverloadedTest stringified'
2062 +ok(!$@, '... this should not throw an exception');
2063 +ok($result, '... and we should get the true value');
2065 === t/mro/complex_dfs.t
2066 ==================================================================
2067 --- t/mro/complex_dfs.t (/local/perl-current) (revision 30426)
2068 +++ t/mro/complex_dfs.t (/local/perl-c3-subg) (revision 30426)
2075 + unless (-d 'blib') {
2076 + chdir 't' if -d 't';
2081 +use Test::More tests => 11;
2085 +This example is taken from: http://rt.cpan.org/Public/Bug/Display.html?id=20879
2088 +Level 5 8 | A | 9 | B | A | C | (More General)
2100 +Level 3 4 | G | 6 | E | |
2105 +Level 2 3 | H | 5 | F | |
2113 +Level 1 1 | J | 2 | I | |
2118 +Level 0 0 | K | (More Specialized)
2128 + package Test::A; use mro 'dfs';
2130 + package Test::B; use mro 'dfs';
2132 + package Test::C; use mro 'dfs';
2134 + package Test::D; use mro 'dfs';
2135 + use base qw/Test::A Test::B Test::C/;
2137 + package Test::E; use mro 'dfs';
2138 + use base qw/Test::D/;
2140 + package Test::F; use mro 'dfs';
2141 + use base qw/Test::E/;
2143 + package Test::G; use mro 'dfs';
2144 + use base qw/Test::D/;
2146 + package Test::H; use mro 'dfs';
2147 + use base qw/Test::G/;
2149 + package Test::I; use mro 'dfs';
2150 + use base qw/Test::H Test::F/;
2152 + package Test::J; use mro 'dfs';
2153 + use base qw/Test::F/;
2155 + package Test::K; use mro 'dfs';
2156 + use base qw/Test::J Test::I/;
2160 + mro::get_linear_isa('Test::A'),
2162 + '... got the right DFS merge order for Test::A');
2165 + mro::get_linear_isa('Test::B'),
2167 + '... got the right DFS merge order for Test::B');
2170 + mro::get_linear_isa('Test::C'),
2172 + '... got the right DFS merge order for Test::C');
2175 + mro::get_linear_isa('Test::D'),
2176 + [ qw(Test::D Test::A Test::B Test::C) ],
2177 + '... got the right DFS merge order for Test::D');
2180 + mro::get_linear_isa('Test::E'),
2181 + [ qw(Test::E Test::D Test::A Test::B Test::C) ],
2182 + '... got the right DFS merge order for Test::E');
2185 + mro::get_linear_isa('Test::F'),
2186 + [ qw(Test::F Test::E Test::D Test::A Test::B Test::C) ],
2187 + '... got the right DFS merge order for Test::F');
2190 + mro::get_linear_isa('Test::G'),
2191 + [ qw(Test::G Test::D Test::A Test::B Test::C) ],
2192 + '... got the right DFS merge order for Test::G');
2195 + mro::get_linear_isa('Test::H'),
2196 + [ qw(Test::H Test::G Test::D Test::A Test::B Test::C) ],
2197 + '... got the right DFS merge order for Test::H');
2200 + mro::get_linear_isa('Test::I'),
2201 + [ qw(Test::I Test::H Test::G Test::D Test::A Test::B Test::C Test::F Test::E) ],
2202 + '... got the right DFS merge order for Test::I');
2205 + mro::get_linear_isa('Test::J'),
2206 + [ qw(Test::J Test::F Test::E Test::D Test::A Test::B Test::C) ],
2207 + '... got the right DFS merge order for Test::J');
2210 + mro::get_linear_isa('Test::K'),
2211 + [ qw(Test::K Test::J Test::F Test::E Test::D Test::A Test::B Test::C Test::I Test::H Test::G) ],
2212 + '... got the right DFS merge order for Test::K');
2213 === t/mro/inconsistent_c3.t
2214 ==================================================================
2215 --- t/mro/inconsistent_c3.t (/local/perl-current) (revision 30426)
2216 +++ t/mro/inconsistent_c3.t (/local/perl-c3-subg) (revision 30426)
2223 + unless (-d 'blib') {
2224 + chdir 't' if -d 't';
2229 +use Test::More tests => 1;
2233 +This example is take from: http://www.python.org/2.3/mro.html
2235 +"Serious order disagreement" # From Guido
2242 + class Z(A,B): pass #creates Z(A,B) in Python 2.2
2244 + pass # Z(A,B) cannot be created in Python 2.3
2254 + our @ISA = ('X', 'Y');
2257 + our @ISA = ('Y', 'X');
2260 + our @ISA = ('XY', 'YX');
2263 +eval { mro::get_linear_isa('Z', 'c3') };
2264 +like($@, qr/^Inconsistent /, '... got the right error with an inconsistent hierarchy');
2265 === t/mro/recursion_dfs.t
2266 ==================================================================
2267 --- t/mro/recursion_dfs.t (/local/perl-current) (revision 30426)
2268 +++ t/mro/recursion_dfs.t (/local/perl-c3-subg) (revision 30426)
2275 + unless (-d 'blib') {
2276 + chdir 't' if -d 't';
2284 +# XXX needs translation back to classes, etc
2286 +plan skip_all => "Your system has no SIGALRM" if !exists $SIG{ALRM};
2291 +These are like the 010_complex_merge_classless test,
2292 +but an infinite loop has been made in the heirarchy,
2293 +to test that we can fail cleanly instead of going
2294 +into an infinite loop
2298 +# initial setup, everything sane
2301 + our @ISA = qw/J I/;
2305 + our @ISA = qw/H F/;
2315 + our @ISA = qw/A B C/;
2324 +# A series of 8 abberations that would cause infinite loops,
2325 +# each one undoing the work of the previous
2327 + sub { @E::ISA = qw/F/ },
2328 + sub { @E::ISA = qw/D/; @C::ISA = qw/F/ },
2329 + sub { @C::ISA = qw//; @A::ISA = qw/K/ },
2330 + sub { @A::ISA = qw//; @J::ISA = qw/F K/ },
2331 + sub { @J::ISA = qw/F/; @H::ISA = qw/K G/ },
2332 + sub { @H::ISA = qw/G/; @B::ISA = qw/B/ },
2333 + sub { @B::ISA = qw//; @K::ISA = qw/K J I/ },
2334 + sub { @K::ISA = qw/J I/; @D::ISA = qw/A H B C/ },
2337 +foreach my $loopy (@loopies) {
2339 + local $SIG{ALRM} = sub { die "ALRMTimeout" };
2342 + mro::get_linear_isa('K', 'dfs');
2345 + if(my $err = $@) {
2346 + if($err =~ /ALRMTimeout/) {
2347 + ok(0, "Loop terminated by SIGALRM");
2349 + elsif($err =~ /Recursive inheritance detected/) {
2350 + ok(1, "Graceful exception thrown");
2353 + ok(0, "Unrecognized exception: $err");
2357 + ok(0, "Infinite loop apparently succeeded???");
2360 === t/mro/basic_01_c3.t
2361 ==================================================================
2362 --- t/mro/basic_01_c3.t (/local/perl-current) (revision 30426)
2363 +++ t/mro/basic_01_c3.t (/local/perl-c3-subg) (revision 30426)
2370 + unless (-d 'blib') {
2371 + chdir 't' if -d 't';
2376 +use Test::More tests => 4;
2380 +This tests the classic diamond inheritence pattern.
2391 + package Diamond_A;
2392 + sub hello { 'Diamond_A::hello' }
2395 + package Diamond_B;
2396 + use base 'Diamond_A';
2399 + package Diamond_C;
2400 + use base 'Diamond_A';
2402 + sub hello { 'Diamond_C::hello' }
2405 + package Diamond_D;
2406 + use base ('Diamond_B', 'Diamond_C');
2411 + mro::get_linear_isa('Diamond_D'),
2412 + [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ],
2413 + '... got the right MRO for Diamond_D');
2415 +is(Diamond_D->hello, 'Diamond_C::hello', '... method resolved itself as expected');
2416 +is(Diamond_D->can('hello')->(), 'Diamond_C::hello', '... can(method) resolved itself as expected');
2417 +is(UNIVERSAL::can("Diamond_D", 'hello')->(), 'Diamond_C::hello', '... can(method) resolved itself as expected');
2418 === t/mro/basic_02_c3.t
2419 ==================================================================
2420 --- t/mro/basic_02_c3.t (/local/perl-current) (revision 30426)
2421 +++ t/mro/basic_02_c3.t (/local/perl-c3-subg) (revision 30426)
2428 + unless (-d 'blib') {
2429 + chdir 't' if -d 't';
2434 +use Test::More tests => 10;
2438 +This example is take from: http://www.python.org/2.3/mro.html
2452 +Level 3 | O | (more general)
2458 +Level 2 3 | D | 4| E | | F | 5 |
2464 +Level 1 1 | B | | C | 2 |
2469 +Level 0 0 | A | (more specialized)
2480 + use base 'Test::O';
2483 + use base 'Test::O';
2486 + sub C_or_E { 'Test::E' }
2490 + use base 'Test::O';
2492 + sub C_or_D { 'Test::D' }
2495 + use base ('Test::D', 'Test::F');
2498 + sub C_or_D { 'Test::C' }
2499 + sub C_or_E { 'Test::C' }
2503 + use base ('Test::D', 'Test::E');
2506 + use base ('Test::B', 'Test::C');
2511 + mro::get_linear_isa('Test::F'),
2512 + [ qw(Test::F Test::O) ],
2513 + '... got the right MRO for Test::F');
2516 + mro::get_linear_isa('Test::E'),
2517 + [ qw(Test::E Test::O) ],
2518 + '... got the right MRO for Test::E');
2521 + mro::get_linear_isa('Test::D'),
2522 + [ qw(Test::D Test::O) ],
2523 + '... got the right MRO for Test::D');
2526 + mro::get_linear_isa('Test::C'),
2527 + [ qw(Test::C Test::D Test::F Test::O) ],
2528 + '... got the right MRO for Test::C');
2531 + mro::get_linear_isa('Test::B'),
2532 + [ qw(Test::B Test::D Test::E Test::O) ],
2533 + '... got the right MRO for Test::B');
2536 + mro::get_linear_isa('Test::A'),
2537 + [ qw(Test::A Test::B Test::C Test::D Test::E Test::F Test::O) ],
2538 + '... got the right MRO for Test::A');
2540 +is(Test::A->C_or_D, 'Test::C', '... got the expected method output');
2541 +is(Test::A->can('C_or_D')->(), 'Test::C', '... can got the expected method output');
2542 +is(Test::A->C_or_E, 'Test::C', '... got the expected method output');
2543 +is(Test::A->can('C_or_E')->(), 'Test::C', '... can got the expected method output');
2544 === t/mro/overload_dfs.t
2545 ==================================================================
2546 --- t/mro/overload_dfs.t (/local/perl-current) (revision 30426)
2547 +++ t/mro/overload_dfs.t (/local/perl-c3-subg) (revision 30426)
2554 + unless (-d 'blib') {
2555 + chdir 't' if -d 't';
2560 +use Test::More tests => 7;
2568 + package OverloadingTest;
2572 + use base 'BaseTest';
2573 + use overload '""' => sub { ref(shift) . " stringified" },
2576 + sub new { bless {} => shift }
2578 + package InheritingFromOverloadedTest;
2581 + use base 'OverloadingTest';
2585 +my $x = InheritingFromOverloadedTest->new();
2586 +isa_ok($x, 'InheritingFromOverloadedTest');
2588 +my $y = OverloadingTest->new();
2589 +isa_ok($y, 'OverloadingTest');
2591 +is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing');
2592 +is("$y", 'OverloadingTest stringified', '... got the right value when stringifing');
2594 +ok(($y eq 'OverloadingTest stringified'), '... eq was handled correctly');
2598 + $result = $x eq 'InheritingFromOverloadedTest stringified'
2600 +ok(!$@, '... this should not throw an exception');
2601 +ok($result, '... and we should get the true value');
2603 === t/mro/basic_03_c3.t
2604 ==================================================================
2605 --- t/mro/basic_03_c3.t (/local/perl-current) (revision 30426)
2606 +++ t/mro/basic_03_c3.t (/local/perl-c3-subg) (revision 30426)
2613 + unless (-d 'blib') {
2614 + chdir 't' if -d 't';
2619 +use Test::More tests => 4;
2623 +This example is take from: http://www.python.org/2.3/mro.html
2625 +"My second example"
2642 +Level 2 2 | E | 4 | D | | F | 5
2648 +Level 1 1 | B | | C | 3
2657 +(<class '__main__.A'>, <class '__main__.B'>, <class '__main__.E'>,
2658 +<class '__main__.C'>, <class '__main__.D'>, <class '__main__.F'>,
2667 + sub O_or_D { 'Test::O' }
2668 + sub O_or_F { 'Test::O' }
2671 + use base 'Test::O';
2674 + sub O_or_F { 'Test::F' }
2677 + use base 'Test::O';
2681 + use base 'Test::O';
2684 + sub O_or_D { 'Test::D' }
2685 + sub C_or_D { 'Test::D' }
2688 + use base ('Test::D', 'Test::F');
2691 + sub C_or_D { 'Test::C' }
2694 + use base ('Test::E', 'Test::D');
2698 + use base ('Test::B', 'Test::C');
2703 + mro::get_linear_isa('Test::A'),
2704 + [ qw(Test::A Test::B Test::E Test::C Test::D Test::F Test::O) ],
2705 + '... got the right MRO for Test::A');
2707 +is(Test::A->O_or_D, 'Test::D', '... got the right method dispatch');
2708 +is(Test::A->O_or_F, 'Test::F', '... got the right method dispatch');
2711 +# this test is particularly interesting because the p5 dispatch
2712 +# would actually call Test::D before Test::C and Test::D is a
2713 +# subclass of Test::C
2714 +is(Test::A->C_or_D, 'Test::C', '... got the right method dispatch');
2715 === t/mro/basic_04_c3.t
2716 ==================================================================
2717 --- t/mro/basic_04_c3.t (/local/perl-current) (revision 30426)
2718 +++ t/mro/basic_04_c3.t (/local/perl-c3-subg) (revision 30426)
2725 + unless (-d 'blib') {
2726 + chdir 't' if -d 't';
2731 +use Test::More tests => 1;
2735 +From the parrot test t/pmc/object-meths.t
2747 + package t::lib::A; use mro 'c3';
2748 + package t::lib::B; use mro 'c3';
2749 + package t::lib::E; use mro 'c3';
2750 + package t::lib::C; use mro 'c3'; use base ('t::lib::A', 't::lib::B');
2751 + package t::lib::D; use mro 'c3'; use base ('t::lib::A', 't::lib::E');
2752 + package t::lib::F; use mro 'c3'; use base ('t::lib::C', 't::lib::D');
2756 + mro::get_linear_isa('t::lib::F'),
2757 + [ qw(t::lib::F t::lib::C t::lib::D t::lib::A t::lib::B t::lib::E) ],
2758 + '... got the right MRO for t::lib::F');
2760 === t/mro/basic_05_c3.t
2761 ==================================================================
2762 --- t/mro/basic_05_c3.t (/local/perl-current) (revision 30426)
2763 +++ t/mro/basic_05_c3.t (/local/perl-c3-subg) (revision 30426)
2770 + unless (-d 'blib') {
2771 + chdir 't' if -d 't';
2776 +use Test::More tests => 2;
2780 +This tests a strange bug found by Matt S. Trout
2781 +while building DBIx::Class. Thanks Matt!!!!
2792 + package Diamond_A;
2795 + sub foo { 'Diamond_A::foo' }
2798 + package Diamond_B;
2799 + use base 'Diamond_A';
2802 + sub foo { 'Diamond_B::foo => ' . (shift)->SUPER::foo }
2805 + package Diamond_C;
2807 + use base 'Diamond_A';
2811 + package Diamond_D;
2812 + use base ('Diamond_C', 'Diamond_B');
2815 + sub foo { 'Diamond_D::foo => ' . (shift)->SUPER::foo }
2819 + mro::get_linear_isa('Diamond_D'),
2820 + [ qw(Diamond_D Diamond_C Diamond_B Diamond_A) ],
2821 + '... got the right MRO for Diamond_D');
2824 + 'Diamond_D::foo => Diamond_B::foo => Diamond_A::foo',
2825 + '... got the right next::method dispatch path');
2827 ==================================================================
2828 --- t/op/magic.t (/local/perl-current) (revision 30426)
2829 +++ t/op/magic.t (/local/perl-c3-subg) (revision 30426)
2830 @@ -440,7 +440,10 @@
2834 - eval { push @ISA, __PACKAGE__ };
2835 + # This used to be __PACKAGE__, but that causes recursive
2836 + # inheritance, which is detected earlier now and broke
2838 + eval { push @ISA, __FILE__ };
2839 ok( $@ eq '', 'Push a constant on a magic array');
2840 $@ and print "# $@";
2841 eval { %ENV = (PATH => __PACKAGE__) };
2842 === NetWare/Makefile
2843 ==================================================================
2844 --- NetWare/Makefile (/local/perl-current) (revision 30426)
2845 +++ NetWare/Makefile (/local/perl-c3-subg) (revision 30426)
2854 === vms/descrip_mms.template
2855 ==================================================================
2856 --- vms/descrip_mms.template (/local/perl-current) (revision 30426)
2857 +++ vms/descrip_mms.template (/local/perl-c3-subg) (revision 30426)
2858 @@ -279,13 +279,13 @@
2860 #### End of system configuration section. ####
2862 -c0 = $(MALLOC_C) $(SOCKC) av.c deb.c doio.c doop.c dump.c globals.c gv.c hv.c
2863 +c0 = $(MALLOC_C) $(SOCKC) av.c deb.c doio.c doop.c dump.c globals.c gv.c hv.c mro.c
2864 c1 = mg.c locale.c mathoms.c miniperlmain.c numeric.c op.c pad.c perl.c perlapi.c perlio.c
2865 c2 = perly.c pp.c pp_ctl.c pp_hot.c pp_pack.c pp_sort.c pp_sys.c regcomp.c regexec.c reentr.c
2866 c3 = run.c scope.c sv.c taint.c toke.c universal.c utf8.c util.c vms.c xsutils.c
2867 c = $(c0) $(c1) $(c2) $(c3)
2869 -obj0 = $(MALLOC_O) $(SOCKO) av$(O) deb$(O) doio$(O) doop$(O) dump$(O)
2870 +obj0 = $(MALLOC_O) $(SOCKO) av$(O) deb$(O) doio$(O) doop$(O) dump$(O) mro$(O)
2871 obj1 = globals$(O) gv$(O) hv$(O) locale$(O) mathoms$(O) mg$(O) miniperlmain$(O) numeric$(O) op$(O) pad$(O)
2872 obj2 = perl$(O) perlapi$(O) perlio$(O) perly$(O) pp$(O) pp_ctl$(O) pp_hot$(O) reentr$(O)
2873 obj3 = pp_pack$(O) pp_sort$(O) pp_sys$(O) regcomp$(O) regexec$(O) run$(O) scope$(O) sv$(O) taint$(O) toke$(O)
2874 @@ -1619,6 +1619,8 @@
2875 $(CC) $(CORECFLAGS) $(MMS$SOURCE)
2877 $(CC) $(CORECFLAGS) $(MMS$SOURCE)
2878 +mro$(O) : mro.c $(h)
2879 + $(CC) $(CORECFLAGS) $(MMS$SOURCE)
2881 $(CC) $(CORECFLAGS) $(MMS$SOURCE)
2882 locale$(O) : locale.c $(h)
2884 ==================================================================
2885 --- Makefile.SH (/local/perl-current) (revision 30426)
2886 +++ Makefile.SH (/local/perl-c3-subg) (revision 30426)
2888 h5 = utf8.h warnings.h
2889 h = $(h1) $(h2) $(h3) $(h4) $(h5)
2891 -c1 = av.c scope.c op.c doop.c doio.c dump.c gv.c hv.c mg.c reentr.c perl.c
2892 +c1 = av.c scope.c op.c doop.c doio.c dump.c gv.c hv.c mg.c reentr.c mro.c perl.c
2893 c2 = perly.c pp.c pp_hot.c pp_ctl.c pp_sys.c regcomp.c regexec.c utf8.c sv.c
2894 c3 = taint.c toke.c util.c deb.c run.c universal.c xsutils.c pad.c globals.c
2895 c4 = perlio.c perlapi.c numeric.c mathoms.c locale.c pp_pack.c pp_sort.c
2898 c = $(c1) $(c2) $(c3) $(c4) $(c5) miniperlmain.c perlmain.c opmini.c
2900 -obj1 = $(madlyobj) $(mallocobj) gv$(OBJ_EXT) toke$(OBJ_EXT) perly$(OBJ_EXT) op$(OBJ_EXT) pad$(OBJ_EXT) regcomp$(OBJ_EXT) dump$(OBJ_EXT) util$(OBJ_EXT) mg$(OBJ_EXT) reentr$(OBJ_EXT)
2901 +obj1 = $(madlyobj) $(mallocobj) gv$(OBJ_EXT) toke$(OBJ_EXT) perly$(OBJ_EXT) op$(OBJ_EXT) pad$(OBJ_EXT) regcomp$(OBJ_EXT) dump$(OBJ_EXT) util$(OBJ_EXT) mg$(OBJ_EXT) reentr$(OBJ_EXT) mro$(OBJ_EXT)
2902 obj2 = hv$(OBJ_EXT) av$(OBJ_EXT) perl$(OBJ_EXT) run$(OBJ_EXT) pp_hot$(OBJ_EXT) sv$(OBJ_EXT) pp$(OBJ_EXT) scope$(OBJ_EXT) pp_ctl$(OBJ_EXT) pp_sys$(OBJ_EXT)
2903 obj3 = doop$(OBJ_EXT) doio$(OBJ_EXT) regexec$(OBJ_EXT) utf8$(OBJ_EXT) taint$(OBJ_EXT) deb$(OBJ_EXT) universal$(OBJ_EXT) xsutils$(OBJ_EXT) globals$(OBJ_EXT) perlio$(OBJ_EXT) perlapi$(OBJ_EXT) numeric$(OBJ_EXT) mathoms$(OBJ_EXT) locale$(OBJ_EXT) pp_pack$(OBJ_EXT) pp_sort$(OBJ_EXT)
2906 ==================================================================
2907 --- proto.h (/local/perl-current) (revision 30426)
2908 +++ proto.h (/local/perl-c3-subg) (revision 30426)
2909 @@ -635,6 +635,25 @@
2910 PERL_CALLCONV GV* Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN len, const U32 flags)
2911 __attribute__nonnull__(pTHX_1);
2913 +PERL_CALLCONV struct mro_meta* Perl_mro_meta_init(pTHX_ HV* stash)
2914 + __attribute__nonnull__(pTHX_1);
2916 +PERL_CALLCONV AV* Perl_mro_linear(pTHX_ HV* stash)
2917 + __attribute__nonnull__(pTHX_1);
2919 +PERL_CALLCONV AV* Perl_mro_linear_c3(pTHX_ HV* stash, I32 level)
2920 + __attribute__nonnull__(pTHX_1);
2922 +PERL_CALLCONV AV* Perl_mro_linear_dfs(pTHX_ HV* stash, I32 level)
2923 + __attribute__nonnull__(pTHX_1);
2925 +PERL_CALLCONV void Perl_mro_isa_changed_in(pTHX_ HV* stash)
2926 + __attribute__nonnull__(pTHX_1);
2928 +PERL_CALLCONV void Perl_mro_method_changed_in(pTHX_ HV* stash)
2929 + __attribute__nonnull__(pTHX_1);
2931 +PERL_CALLCONV void Perl_boot_core_mro(pTHX);
2932 PERL_CALLCONV GV* Perl_gv_fetchmeth(pTHX_ HV* stash, const char* name, STRLEN len, I32 level)
2933 __attribute__nonnull__(pTHX_2);
2936 ==================================================================
2937 --- ext/B/t/b.t (/local/perl-current) (revision 30426)
2938 +++ ext/B/t/b.t (/local/perl-c3-subg) (revision 30426)
2942 my $sg = B::sub_generation();
2943 - *Whatever::hand_waving = sub { };
2944 + *UNIVERSAL::hand_waving = sub { };
2945 ok( $sg < B::sub_generation, "sub_generation increments" );
2949 ==================================================================
2950 --- MANIFEST (/local/perl-current) (revision 30426)
2951 +++ MANIFEST (/local/perl-c3-subg) (revision 30426)
2952 @@ -2252,6 +2252,7 @@
2953 lib/Module/Pluggable/t/lib/OddTest/Plugin/-Dodgy.pm Module::Pluggable tests
2954 lib/Module/Pluggable/t/lib/OddTest/Plugin/Foo.pm Module::Pluggable tests
2955 lib/Module/Pluggable/t/lib/TA/C/A/I.pm Module::Pluggable tests
2956 +lib/mro.pm mro extension
2957 lib/Net/Changes.libnet libnet
2958 lib/Net/Cmd.pm libnet
2959 lib/Net/Config.eg libnet
2960 @@ -2953,6 +2954,7 @@
2961 mpeix/mpeix_setjmp.c MPE/iX port
2962 mpeix/nm MPE/iX port
2963 mpeix/relink MPE/iX port
2964 +mro.c Method Resolution Order code
2965 myconfig.SH Prints summary of the current configuration
2966 NetWare/bat/Buildtype.bat NetWare port
2967 NetWare/bat/SetCodeWar.bat NetWare port
2968 @@ -3619,6 +3621,28 @@
2969 t/lib/warnings/universal Tests for universal.c for warnings.t
2970 t/lib/warnings/utf8 Tests for utf8.c for warnings.t
2971 t/lib/warnings/util Tests for util.c for warnings.t
2972 +t/mro/basic_01_c3.t mro tests
2973 +t/mro/basic_01_dfs.t mro tests
2974 +t/mro/basic_02_c3.t mro tests
2975 +t/mro/basic_02_dfs.t mro tests
2976 +t/mro/basic_03_c3.t mro tests
2977 +t/mro/basic_03_dfs.t mro tests
2978 +t/mro/basic_04_c3.t mro tests
2979 +t/mro/basic_04_dfs.t mro tests
2980 +t/mro/basic_05_c3.t mro tests
2981 +t/mro/basic_05_dfs.t mro tests
2982 +t/mro/complex_c3.t mro tests
2983 +t/mro/complex_dfs.t mro tests
2984 +t/mro/dbic_c3.t mro tests
2985 +t/mro/dbic_dfs.t mro tests
2986 +t/mro/inconsistent_c3.t mro tests
2987 +t/mro/overload_c3.t mro tests
2988 +t/mro/overload_dfs.t mro tests
2989 +t/mro/recursion_c3.t mro tests
2990 +t/mro/recursion_dfs.t mro tests
2991 +t/mro/vulcan_c3.t mro tests
2992 +t/mro/vulcan_dfs.t mro tests
2993 +t/mro/method_caching.t mro tests
2994 Todo.micro The Wishlist for microperl
2996 t/op/64bitint.t See if 64 bit integers work
2998 ==================================================================
2999 --- mro.c (/local/perl-current) (revision 30426)
3000 +++ mro.c (/local/perl-c3-subg) (revision 30426)
3004 + * Copyright (c) 2007 Brandon L Black
3006 + * You may distribute under the terms of either the GNU General Public
3007 + * License or the Artistic License, as specified in the README file.
3012 +=head1 MRO Functions
3014 +These functions are related to the method resolution order of perl classes
3019 +#include "EXTERN.h"
3023 +Perl_mro_meta_init(pTHX_ HV* stash)
3028 + assert(HvAUX(stash));
3029 + assert(!(HvAUX(stash)->xhv_mro_meta));
3030 + Newxz(newmeta, sizeof(struct mro_meta), char);
3031 + HvAUX(stash)->xhv_mro_meta = (struct mro_meta*)newmeta;
3032 + ((struct mro_meta*)newmeta)->sub_generation = 1;
3034 + /* Manually flag UNIVERSAL as being universal.
3035 + This happens early in perl booting (when universal.c
3036 + does the newXS calls for UNIVERSAL::*), and infects
3037 + other packages as they are added to UNIVERSAL's MRO
3039 + if(HvNAMELEN_get(stash) == 9
3040 + && strEQ(HEK_KEY(HvAUX(stash)->xhv_name), "UNIVERSAL")) {
3041 + HvMROMETA(stash)->is_universal = 1;
3048 +=for apidoc mro_linear_dfs
3050 +Returns the Depth-First Search linearization of @ISA
3051 +the given stash. The return value is a read-only AV*.
3052 +C<level> should be 0 (it is used internally in this
3053 +function's recursion).
3058 +Perl_mro_linear_dfs(pTHX_ HV *stash, I32 level)
3069 + const char* stashname;
3070 + struct mro_meta* meta;
3073 + assert(HvAUX(stash));
3075 + stashname = HvNAME_get(stash);
3078 + "Can't linearize anonymous symbol table");
3081 + Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
3084 + meta = HvMROMETA(stash);
3085 + if((retval = meta->mro_linear_dfs)) {
3086 + /* return cache if valid */
3087 + SvREFCNT_inc_simple_void_NN(retval);
3091 + /* not in cache, make a new one */
3092 + retval = (AV*)sv_2mortal((SV*)newAV());
3093 + av_push(retval, newSVpv(stashname, 0)); /* add ourselves at the top */
3095 + gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
3096 + av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
3099 + HV* stored = (HV*)sv_2mortal((SV*)newHV());
3100 + svp = AvARRAY(av);
3101 + items = AvFILLp(av) + 1;
3103 + SV* const sv = *svp++;
3104 + HV* const basestash = gv_stashsv(sv, 0);
3107 + if(!hv_exists_ent(stored, sv, 0)) {
3108 + av_push(retval, newSVsv(sv));
3109 + hv_store_ent(stored, sv, &PL_sv_undef, 0);
3113 + subrv = (AV*)sv_2mortal((SV*)mro_linear_dfs(basestash, level + 1));
3114 + subrv_p = AvARRAY(subrv);
3115 + subrv_items = AvFILLp(subrv) + 1;
3116 + while(subrv_items--) {
3117 + SV* subsv = *subrv_p++;
3118 + if(!hv_exists_ent(stored, subsv, 0)) {
3119 + av_push(retval, newSVsv(subsv));
3120 + hv_store_ent(stored, subsv, &PL_sv_undef, 0);
3127 + SvREADONLY_on(retval);
3128 + SvREFCNT_inc_simple_void_NN(retval); /* for meta storage */
3129 + SvREFCNT_inc_simple_void_NN(retval); /* for return to caller */
3130 + meta->mro_linear_dfs = retval;
3135 +=for apidoc mro_linear_c3
3137 +Returns the C3 linearization of @ISA
3138 +the given stash. The return value is a read-only AV*.
3139 +C<level> should be 0 (it is used internally in this
3140 +function's recursion).
3146 +Perl_mro_linear_c3(pTHX_ HV* stash, I32 level)
3152 + const char* stashname;
3153 + STRLEN stashname_len;
3154 + struct mro_meta* meta;
3157 + assert(HvAUX(stash));
3159 + stashname = HvNAME_get(stash);
3160 + stashname_len = HvNAMELEN_get(stash);
3163 + "Can't linearize anonymous symbol table");
3166 + Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
3169 + meta = HvMROMETA(stash);
3170 + if((retval = meta->mro_linear_c3)) {
3171 + /* return cache if valid */
3172 + SvREFCNT_inc_simple_void_NN(retval);
3176 + /* not in cache, make a new one */
3178 + retval = (AV*)sv_2mortal((SV*)newAV());
3179 + av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
3181 + gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
3182 + isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
3184 + if(isa && AvFILLp(isa) >= 0) {
3187 + HV* tails = (HV*)sv_2mortal((SV*)newHV());
3188 + AV* seqs = (AV*)sv_2mortal((SV*)newAV());
3189 + I32 items = AvFILLp(isa) + 1;
3190 + SV** isa_ptr = AvARRAY(isa);
3193 + SV* isa_item = *isa_ptr++;
3194 + HV* isa_item_stash = gv_stashsv(isa_item, 0);
3195 + if(!isa_item_stash) {
3196 + isa_lin = newAV();
3197 + av_push(isa_lin, newSVsv(isa_item));
3200 + isa_lin = (AV*)sv_2mortal((SV*)mro_linear_c3(isa_item_stash, level + 1)); /* recursion */
3202 + av_push(seqs, (SV*)av_make(AvFILLp(isa_lin)+1, AvARRAY(isa_lin)));
3204 + av_push(seqs, (SV*)av_make(AvFILLp(isa)+1, AvARRAY(isa)));
3206 + seqs_ptr = AvARRAY(seqs);
3207 + seqs_items = AvFILLp(seqs) + 1;
3208 + while(seqs_items--) {
3209 + AV* seq = (AV*)*seqs_ptr++;
3210 + I32 seq_items = AvFILLp(seq);
3211 + if(seq_items > 0) {
3212 + SV** seq_ptr = AvARRAY(seq) + 1;
3213 + while(seq_items--) {
3214 + SV* seqitem = *seq_ptr++;
3215 + HE* he = hv_fetch_ent(tails, seqitem, 0, 0);
3217 + hv_store_ent(tails, seqitem, newSViv(1), 0);
3220 + SV* val = HeVAL(he);
3228 + SV* seqhead = NULL;
3230 + SV* winner = NULL;
3234 + SV** avptr = AvARRAY(seqs);
3235 + items = AvFILLp(seqs)+1;
3238 + seq = (AV*)*avptr++;
3239 + if(AvFILLp(seq) < 0) continue;
3240 + svp = av_fetch(seq, 0, 0);
3244 + if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
3245 + && (val = HeVAL(tail_entry))
3246 + && (SvIVx(val) > 0))
3248 + winner = newSVsv(cand);
3249 + av_push(retval, winner);
3251 + if(!sv_cmp(seqhead, winner)) {
3253 + /* this is basically shift(@seq) in void context */
3254 + SvREFCNT_dec(*AvARRAY(seq));
3255 + *AvARRAY(seq) = &PL_sv_undef;
3256 + AvARRAY(seq) = AvARRAY(seq) + 1;
3260 + if(AvFILLp(seq) < 0) continue;
3261 + svp = av_fetch(seq, 0, 0);
3263 + tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
3264 + val = HeVAL(tail_entry);
3270 + Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
3271 + "merging failed on parent '%"SVf"'", stashname, SVfARG(cand));
3275 + SvREADONLY_on(retval);
3276 + SvREFCNT_inc_simple_void_NN(retval); /* for meta storage */
3277 + SvREFCNT_inc_simple_void_NN(retval); /* for return to caller */
3278 + meta->mro_linear_c3 = retval;
3283 +=for apidoc mro_linear
3285 +Returns either C<mro_linear_c3> or C<mro_linear_dfs> for
3286 +the given stash, dependant upon which MRO is in effect
3287 +for that stash. The return value is a read-only AV*.
3292 +Perl_mro_linear(pTHX_ HV *stash)
3294 + struct mro_meta* meta;
3296 + assert(HvAUX(stash));
3298 + meta = HvMROMETA(stash);
3299 + if(meta->mro_which == MRO_DFS) {
3300 + return mro_linear_dfs(stash, 0);
3301 + } else if(meta->mro_which == MRO_C3) {
3302 + return mro_linear_c3(stash, 0);
3304 + Perl_croak(aTHX_ "Internal error: invalid MRO!");
3309 +=for apidoc mro_isa_changed_in
3311 +Takes the neccesary steps (cache invalidations, mostly)
3312 +when the @ISA of the given package has changed. Invoked
3313 +by the C<setisa> magic, should not need to invoke directly.
3318 +Perl_mro_isa_changed_in(pTHX_ HV* stash)
3326 + struct mro_meta* meta;
3329 + stashname = HvNAME_get(stash);
3331 + /* wipe out the cached linearizations for this stash */
3332 + meta = HvMROMETA(stash);
3333 + sv_2mortal((SV*)meta->mro_linear_dfs);
3334 + sv_2mortal((SV*)meta->mro_linear_c3);
3335 + meta->mro_linear_dfs = NULL;
3336 + meta->mro_linear_c3 = NULL;
3338 + /* Wipe the global method cache if this package
3339 + is UNIVERSAL or one of its parents */
3340 + if(meta->is_universal)
3341 + PL_sub_generation++;
3343 + /* Wipe the local method cache otherwise */
3345 + meta->sub_generation++;
3347 + /* wipe next::method cache too */
3348 + if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
3350 + /* Recalcs whichever of the above two cleared linearizations
3351 + are in effect and gives it to us */
3352 + linear_mro = mro_linear(stash);
3353 + isarev = meta->mro_isarev;
3355 + /* Iterate the isarev (classes that are our children),
3356 + wiping out their linearization and method caches */
3358 + hv_iterinit(isarev);
3359 + while((iter = hv_iternext(isarev))) {
3360 + SV* revkey = hv_iterkeysv(iter);
3361 + HV* revstash = gv_stashsv(revkey, 0);
3362 + struct mro_meta* revmeta = HvMROMETA(revstash);
3363 + sv_2mortal((SV*)revmeta->mro_linear_dfs);
3364 + sv_2mortal((SV*)revmeta->mro_linear_c3);
3365 + revmeta->mro_linear_dfs = NULL;
3366 + revmeta->mro_linear_c3 = NULL;
3367 + if(!meta->is_universal)
3368 + revmeta->sub_generation++;
3369 + if(revmeta->mro_nextmethod)
3370 + hv_clear(revmeta->mro_nextmethod);
3374 + /* we're starting at the 2nd element, skipping ourselves here */
3375 + svp = AvARRAY(linear_mro) + 1;
3376 + items = AvFILLp(linear_mro);
3378 + SV* const sv = *svp++;
3379 + struct mro_meta* mrometa;
3382 + HV* mrostash = gv_stashsv(sv, 0);
3384 + mrostash = gv_stashsv(sv, GV_ADD);
3386 + We created the package on the fly, so
3387 + that we could store isarev information.
3388 + This flag lets gv_fetchmeth know about it,
3389 + so that it can still generate the very useful
3390 + "Can't locate package Foo for @Bar::ISA" warning.
3392 + HvMROMETA(mrostash)->fake = 1;
3395 + mrometa = HvMROMETA(mrostash);
3396 + mroisarev = mrometa->mro_isarev;
3398 + /* is_universal is viral */
3399 + if(meta->is_universal)
3400 + mrometa->is_universal = 1;
3403 + mroisarev = mrometa->mro_isarev = newHV();
3405 + if(!hv_exists(mroisarev, stashname, strlen(stashname)))
3406 + hv_store(mroisarev, stashname, strlen(stashname), &PL_sv_yes, 0);
3409 + hv_iterinit(isarev);
3410 + while((iter = hv_iternext(isarev))) {
3411 + SV* revkey = hv_iterkeysv(iter);
3412 + if(!hv_exists_ent(mroisarev, revkey, 0))
3413 + hv_store_ent(mroisarev, revkey, &PL_sv_yes, 0);
3420 +=for apidoc mro_method_changed_in
3422 +Like C<mro_isa_changed_in>, but invalidates method
3423 +caching on any child classes of the given stash, so
3424 +that they might notice the changes in this one.
3426 +Ideally, all instances of C<PL_sub_generation++> in
3427 +the perl source should be replaced by calls to this.
3428 +Some already are, but some are more difficult to
3434 +Perl_mro_method_changed_in(pTHX_ HV *stash)
3436 + struct mro_meta* meta = HvMROMETA(stash);
3440 + /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
3441 + invalidate all method caches globally */
3442 + if(meta->is_universal) {
3443 + PL_sub_generation++;
3447 + /* else, invalidate the method caches of all child classes,
3449 + if((isarev = meta->mro_isarev)) {
3450 + hv_iterinit(isarev);
3451 + while((iter = hv_iternext(isarev))) {
3452 + SV* revkey = hv_iterkeysv(iter);
3453 + HV* revstash = gv_stashsv(revkey, 0);
3454 + struct mro_meta* mrometa = HvMROMETA(revstash);
3455 + mrometa->sub_generation++;
3456 + if(mrometa->mro_nextmethod)
3457 + hv_clear(mrometa->mro_nextmethod);
3462 +/* These two are static helpers for next::method and friends,
3463 + and re-implement a bunch of the code from pp_caller() in
3464 + a more efficient manner for this particular usage.
3468 +__dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
3470 + for (i = startingblock; i >= 0; i--) {
3471 + if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
3477 +__nextcan(pTHX_ SV* self, I32 throw_nomethod)
3479 + register I32 cxix;
3480 + register const PERL_CONTEXT *ccstack = cxstack;
3481 + const PERL_SI *top_si = PL_curstackinfo;
3485 + const char *fq_subname;
3486 + const char *subname;
3487 + STRLEN fq_subname_len;
3488 + STRLEN stashname_len;
3489 + STRLEN subname_len;
3496 + GV* candidate = NULL;
3497 + CV* cand_cv = NULL;
3498 + const char *hvname;
3500 + struct mro_meta* selfmeta;
3504 + if(sv_isobject(self))
3505 + selfstash = SvSTASH(SvRV(self));
3507 + selfstash = gv_stashsv(self, 0);
3509 + assert(selfstash);
3511 + hvname = HvNAME_get(selfstash);
3513 + croak("Can't use anonymous symbol table for method lookup");
3515 + cxix = __dopoptosub_at(cxstack, cxstack_ix);
3517 + /* This block finds the contextually-enclosing fully-qualified subname,
3518 + much like looking at (caller($i))[3] until you find a real sub that
3519 + isn't ANON, etc */
3521 + /* we may be in a higher stacklevel, so dig down deeper */
3522 + while (cxix < 0) {
3523 + if(top_si->si_type == PERLSI_MAIN)
3524 + croak("next::method/next::can/maybe::next::method must be used in method context");
3525 + top_si = top_si->si_prev;
3526 + ccstack = top_si->si_cxstack;
3527 + cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
3530 + if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
3531 + || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
3532 + cxix = __dopoptosub_at(ccstack, cxix - 1);
3537 + const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
3538 + if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
3539 + if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
3546 + cvgv = CvGV(ccstack[cxix].blk_sub.cv);
3549 + cxix = __dopoptosub_at(ccstack, cxix - 1);
3553 + /* we found a real sub here */
3554 + sv = sv_2mortal(newSV(0));
3556 + gv_efullname3(sv, cvgv, NULL);
3558 + fq_subname = SvPVX(sv);
3559 + fq_subname_len = SvCUR(sv);
3561 + subname = strrchr(fq_subname, ':');
3563 + croak("next::method/next::can/maybe::next::method cannot find enclosing method");
3566 + subname_len = fq_subname_len - (subname - fq_subname);
3567 + if(subname_len == 8 && strEQ(subname, "__ANON__")) {
3568 + cxix = __dopoptosub_at(ccstack, cxix - 1);
3574 + /* If we made it to here, we found our context */
3576 + selfmeta = HvMROMETA(selfstash);
3577 + if(!(nmcache = selfmeta->mro_nextmethod)) {
3578 + nmcache = selfmeta->mro_nextmethod = newHV();
3581 + if((cache_entry = hv_fetch_ent(nmcache, sv, 0, 0))) {
3582 + SV* val = HeVAL(cache_entry);
3583 + if(val == &PL_sv_undef) {
3584 + if(throw_nomethod)
3585 + croak("No next::method '%s' found for %s", subname, hvname);
3586 + return &PL_sv_undef;
3588 + return SvREFCNT_inc_simple_NN(val);
3591 + /* beyond here is just for cache misses, so perf isn't as critical */
3593 + stashname_len = subname - fq_subname - 2;
3594 + stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
3596 + linear_av = mro_linear(selfstash); /* has ourselves at the top of the list */
3597 + sv_2mortal((SV*)linear_av);
3599 + linear_svp = AvARRAY(linear_av);
3600 + items = AvFILLp(linear_av) + 1;
3603 + linear_sv = *linear_svp++;
3604 + assert(linear_sv);
3605 + if(sv_eq(linear_sv, stashname))
3611 + linear_sv = *linear_svp++;
3612 + assert(linear_sv);
3613 + curstash = gv_stashsv(linear_sv, FALSE);
3615 + if (!curstash || (HvMROMETA(curstash)->fake && !HvFILL(curstash))) {
3616 + if (ckWARN(WARN_MISC))
3617 + Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
3618 + (void*)linear_sv, hvname);
3624 + gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
3625 + if (!gvp) continue;
3628 + assert(candidate);
3630 + if (SvTYPE(candidate) != SVt_PVGV)
3631 + gv_init(candidate, curstash, subname, subname_len, TRUE);
3632 + if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
3633 + SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
3634 + hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
3635 + return (SV*)cand_cv;
3640 + hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
3641 + if(throw_nomethod)
3642 + croak("No next::method '%s' found for %s", subname, hvname);
3643 + return &PL_sv_undef;
3648 +XS(XS_mro_get_linear_isa);
3649 +XS(XS_mro_set_mro);
3650 +XS(XS_mro_get_mro);
3651 +XS(XS_mro_get_global_sub_generation);
3652 +XS(XS_mro_invalidate_all_method_caches);
3653 +XS(XS_mro_get_sub_generation);
3654 +XS(XS_mro_invalidate_method_cache);
3656 +XS(XS_next_method);
3657 +XS(XS_maybe_next_method);
3660 +Perl_boot_core_mro(pTHX)
3663 + static const char file[] = __FILE__;
3665 + newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
3666 + newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
3667 + newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
3668 + newXSproto("mro::get_global_sub_generation", XS_mro_get_global_sub_generation, file, "");
3669 + newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_all_method_caches, file, "");
3670 + newXSproto("mro::get_sub_generation", XS_mro_get_sub_generation, file, "$");
3671 + newXSproto("mro::invalidate_method_cache", XS_mro_invalidate_method_cache, file, "$");
3672 + newXS("next::can", XS_next_can, file);
3673 + newXS("next::method", XS_next_method, file);
3674 + newXS("maybe::next::method", XS_maybe_next_method, file);
3677 +XS(XS_mro_get_linear_isa) {
3684 + if(items < 1 || items > 2)
3685 + croak("Usage: mro::get_linear_isa(classname [, type ])");
3687 + classname = ST(0);
3688 + class_stash = gv_stashsv(classname, 0);
3689 + if(!class_stash) croak("No such class: '%"SVf"'!", SVfARG(classname));
3692 + char* which = SvPV_nolen(ST(1));
3693 + if(strEQ(which, "dfs"))
3694 + RETVAL = mro_linear_dfs(class_stash, 0);
3695 + else if(strEQ(which, "c3"))
3696 + RETVAL = mro_linear_c3(class_stash, 0);
3698 + croak("Invalid mro name: '%s'", which);
3701 + RETVAL = mro_linear(class_stash);
3704 + ST(0) = newRV_noinc((SV*)RETVAL);
3705 + sv_2mortal(ST(0));
3717 + struct mro_meta* meta;
3720 + croak("Usage: mro::set_mro(classname, type)");
3722 + classname = ST(0);
3723 + whichstr = SvPV_nolen(ST(1));
3724 + class_stash = gv_stashsv(classname, GV_ADD);
3725 + if(!class_stash) croak("Cannot create class: '%"SVf"'!", SVfARG(classname));
3726 + meta = HvMROMETA(class_stash);
3728 + if(strEQ(whichstr, "dfs"))
3730 + else if(strEQ(whichstr, "c3"))
3733 + croak("Invalid mro name: '%s'", whichstr);
3735 + if(meta->mro_which != which) {
3736 + meta->mro_which = which;
3737 + /* Only affects local method cache, not
3738 + even child classes */
3739 + meta->sub_generation++;
3740 + if(meta->mro_nextmethod)
3741 + hv_clear(meta->mro_nextmethod);
3754 + struct mro_meta* meta;
3757 + croak("Usage: mro::get_mro(classname)");
3759 + classname = ST(0);
3760 + class_stash = gv_stashsv(classname, 0);
3761 + if(!class_stash) croak("No such class: '%"SVf"'!", SVfARG(classname));
3762 + meta = HvMROMETA(class_stash);
3764 + if(meta->mro_which == MRO_DFS)
3765 + ST(0) = sv_2mortal(newSVpvn("dfs", 3));
3767 + ST(0) = sv_2mortal(newSVpvn("c3", 2));
3772 +XS(XS_mro_get_global_sub_generation)
3778 + croak("Usage: mro::get_global_sub_generation()");
3780 + ST(0) = sv_2mortal(newSViv(PL_sub_generation));
3784 +XS(XS_mro_invalidate_all_method_caches)
3790 + croak("Usage: mro::invalidate_all_method_caches()");
3792 + PL_sub_generation++;
3797 +XS(XS_mro_get_sub_generation)
3805 + croak("Usage: mro::get_sub_generation(classname)");
3807 + classname = ST(0);
3808 + class_stash = gv_stashsv(classname, 0);
3809 + if(!class_stash) croak("No such class: '%"SVf"'!", SVfARG(classname));
3811 + ST(0) = sv_2mortal(newSViv(HvMROMETA(class_stash)->sub_generation));
3815 +XS(XS_mro_invalidate_method_cache)
3823 + croak("Usage: mro::invalidate_method_cache(classname)");
3825 + classname = ST(0);
3827 + class_stash = gv_stashsv(classname, 0);
3828 + if(!class_stash) croak("No such class: '%"SVf"'!", SVfARG(classname));
3830 + mro_method_changed_in(class_stash);
3840 + SV* methcv = __nextcan(self, 0);
3842 + PERL_UNUSED_VAR(items);
3844 + if(methcv == &PL_sv_undef) {
3845 + ST(0) = &PL_sv_undef;
3848 + ST(0) = sv_2mortal(newRV_inc(methcv));
3859 + SV* methcv = __nextcan(self, 1);
3861 + PL_markstack_ptr++;
3862 + call_sv(methcv, GIMME_V);
3865 +XS(XS_maybe_next_method)
3870 + SV* methcv = __nextcan(self, 0);
3872 + if(methcv == &PL_sv_undef) {
3873 + ST(0) = &PL_sv_undef;
3877 + PL_markstack_ptr++;
3878 + call_sv(methcv, GIMME_V);
3882 + * Local variables:
3883 + * c-indentation-style: bsd
3884 + * c-basic-offset: 4
3885 + * indent-tabs-mode: t
3888 + * ex: set ts=8 sts=4 sw=4 noet:
3891 ==================================================================
3892 --- hv.c (/local/perl-current) (revision 30426)
3893 +++ hv.c (/local/perl-c3-subg) (revision 30426)
3894 @@ -1531,7 +1531,7 @@
3897 if (val && isGV(val) && GvCVu(val) && HvNAME_get(hv))
3898 - PL_sub_generation++; /* may be deletion of method from stash */
3899 + mro_method_changed_in(hv); /* deletion of method from stash */
3901 if (HeKLEN(entry) == HEf_SVKEY) {
3902 SvREFCNT_dec(HeKEY_sv(entry));
3903 @@ -1726,6 +1726,7 @@
3907 + struct mro_meta *meta;
3908 struct xpvhv_aux *iter = HvAUX(hv);
3909 /* If there are weak references to this HV, we need to avoid
3910 freeing them up here. In particular we need to keep the AV
3911 @@ -1757,6 +1758,15 @@
3912 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
3913 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
3915 + if((meta = iter->xhv_mro_meta)) {
3916 + if(meta->mro_linear_dfs) SvREFCNT_dec(meta->mro_linear_dfs);
3917 + if(meta->mro_linear_c3) SvREFCNT_dec(meta->mro_linear_c3);
3918 + if(meta->mro_isarev) SvREFCNT_dec(meta->mro_isarev);
3919 + if(meta->mro_nextmethod) SvREFCNT_dec(meta->mro_nextmethod);
3921 + iter->xhv_mro_meta = NULL;
3924 /* There are now no allocated pointers in the aux structure. */
3926 SvFLAGS(hv) &= ~SVf_OOK; /* Goodbye, aux structure. */
3927 @@ -1878,6 +1888,7 @@
3928 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
3930 iter->xhv_backreferences = 0;
3931 + iter->xhv_mro_meta = NULL;
3936 ==================================================================
3937 --- hv.h (/local/perl-current) (revision 30426)
3938 +++ hv.h (/local/perl-c3-subg) (revision 30426)
3941 /* Subject to change.
3942 Don't access this directly.
3943 + Use the funcs in mro.c
3952 + AV *mro_linear_dfs; /* cached dfs @ISA linearization */
3953 + AV *mro_linear_c3; /* cached c3 @ISA linearization */
3954 + HV *mro_isarev; /* reverse @ISA dependencies (who depends on us?) */
3955 + HV *mro_nextmethod; /* next::method caching */
3956 + mro_alg mro_which; /* which mro alg is in use? */
3957 + U32 sub_generation; /* Like PL_sub_generation, but stash-local */
3958 + I32 is_universal; /* We are UNIVERSAL or a potentially indirect
3959 + member of @UNIVERSAL::ISA */
3960 + I32 fake; /* setisa made this fake package,
3961 + gv_fetchmeth pays attention to this,
3962 + and "package" sets it back to zero */
3965 +/* Subject to change.
3966 + Don't access this directly.
3970 HEK *xhv_name; /* name, if a symbol table */
3971 AV *xhv_backreferences; /* back references for weak references */
3972 HE *xhv_eiter; /* current entry of iterator */
3973 I32 xhv_riter; /* current root of iterator */
3974 + struct mro_meta *xhv_mro_meta;
3977 /* hash structure: */
3979 #define HvRITER_get(hv) (SvOOK(hv) ? HvAUX(hv)->xhv_riter : -1)
3980 #define HvEITER_get(hv) (SvOOK(hv) ? HvAUX(hv)->xhv_eiter : 0)
3981 #define HvNAME(hv) HvNAME_get(hv)
3982 +#define HvMROMETA(hv) (HvAUX(hv)->xhv_mro_meta ? HvAUX(hv)->xhv_mro_meta : mro_meta_init(hv))
3983 /* FIXME - all of these should use a UTF8 aware API, which should also involve
3984 getting the length. */
3985 /* This macro may go away without notice. */
3987 ==================================================================
3988 --- mg.c (/local/perl-current) (revision 30426)
3989 +++ mg.c (/local/perl-c3-subg) (revision 30426)
3990 @@ -1530,8 +1530,18 @@
3993 PERL_UNUSED_ARG(sv);
3994 - PERL_UNUSED_ARG(mg);
3995 - PL_sub_generation++;
3997 + /* The first case occurs via setisa,
3998 + the second via setisa_elem, which
3999 + calls this same magic */
4000 + mro_isa_changed_in(
4002 + SvTYPE(mg->mg_obj) == SVt_PVGV
4004 + : (GV*)SvMAGIC(mg->mg_obj)->mg_obj
4011 @@ -1541,7 +1551,6 @@
4013 PERL_UNUSED_ARG(sv);
4014 PERL_UNUSED_ARG(mg);
4015 - /* HV_badAMAGIC_on(Sv_STASH(sv)); */
4016 PL_amagic_generation++;
4020 ==================================================================
4021 --- op.c (/local/perl-current) (revision 30426)
4022 +++ op.c (/local/perl-c3-subg) (revision 30426)
4023 @@ -3648,6 +3648,11 @@
4024 save_item(PL_curstname);
4026 PL_curstash = gv_stashsv(sv, GV_ADD);
4028 + /* In case mg.c:Perl_magic_setisa faked
4029 + this package earlier, we clear the fake flag */
4030 + HvMROMETA(PL_curstash)->fake = 0;
4032 sv_setsv(PL_curstname, sv);
4034 PL_hints |= HINT_BLOCK_SCOPE;
4035 @@ -5290,9 +5295,9 @@
4036 sv_setpvn((SV*)gv, ps, ps_len);
4038 sv_setiv((SV*)gv, -1);
4040 SvREFCNT_dec(PL_compcv);
4041 cv = PL_compcv = NULL;
4042 - PL_sub_generation++;
4046 @@ -5386,7 +5391,13 @@
4048 cv = newCONSTSUB(NULL, name, const_sv);
4050 - PL_sub_generation++;
4051 + mro_method_changed_in( /* sub Foo::Bar () { 123 } */
4052 + (CvGV(cv) && GvSTASH(CvGV(cv)))
4053 + ? GvSTASH(CvGV(cv))
4061 @@ -5456,7 +5467,7 @@
4062 SvREFCNT_dec(PL_compcv);
4064 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4065 - ++PL_sub_generation;
4066 + ++PL_sub_generation; /* why? -- blblack */
4070 @@ -5469,7 +5480,7 @@
4074 - PL_sub_generation++;
4075 + mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
4079 @@ -5801,7 +5812,7 @@
4083 - PL_sub_generation++;
4084 + mro_method_changed_in(GvSTASH(gv)); /* newXS */
4089 ==================================================================
4090 --- sv.c (/local/perl-current) (revision 30426)
4091 +++ sv.c (/local/perl-c3-subg) (revision 30426)
4092 @@ -3245,7 +3245,7 @@
4093 SvREFCNT_dec(GvCV(dstr));
4095 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4096 - PL_sub_generation++;
4097 + mro_method_changed_in(GvSTASH(dstr));
4100 SAVEGENERICSV(*location);
4101 @@ -3291,7 +3291,7 @@
4103 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4104 GvASSUMECV_on(dstr);
4105 - PL_sub_generation++;
4106 + mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
4109 if (import_flag && !(GvFLAGS(dstr) & import_flag)
4111 ==================================================================
4112 --- pp_hot.c (/local/perl-current) (revision 30426)
4113 +++ pp_hot.c (/local/perl-c3-subg) (revision 30426)
4116 if (strEQ(GvNAME(right),"isa")) {
4118 - ++PL_sub_generation;
4119 + ++PL_sub_generation; /* I don't get this at all --blblack */
4122 SvSetMagicSV(right, left);
4123 @@ -3060,7 +3060,8 @@
4125 gv = (GV*)HeVAL(he);
4126 if (isGV(gv) && GvCV(gv) &&
4127 - (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
4128 + (!GvCVGEN(gv) || GvCVGEN(gv)
4129 + == (PL_sub_generation + HvMROMETA(stash)->sub_generation)))
4130 return (SV*)GvCV(gv);
4134 ==================================================================
4135 --- embed.fnc (/local/perl-current) (revision 30426)
4136 +++ embed.fnc (/local/perl-c3-subg) (revision 30426)
4137 @@ -282,6 +282,13 @@
4138 Ap |GV* |gv_fetchfile |NN const char* name
4139 Ap |GV* |gv_fetchfile_flags|NN const char *const name|const STRLEN len\
4141 +ApM |struct mro_meta* |mro_meta_init |NN HV* stash
4142 +ApM |AV* |mro_linear |NN HV* stash
4143 +ApM |AV* |mro_linear_c3 |NN HV* stash|I32 level
4144 +ApM |AV* |mro_linear_dfs |NN HV* stash|I32 level
4145 +ApM |void |mro_isa_changed_in|NN HV* stash
4146 +ApM |void |mro_method_changed_in |NN HV* stash
4147 +ApM |void |boot_core_mro
4148 Apd |GV* |gv_fetchmeth |NULLOK HV* stash|NN const char* name|STRLEN len|I32 level
4149 Apd |GV* |gv_fetchmeth_autoload |NULLOK HV* stash|NN const char* name|STRLEN len|I32 level
4150 Apdmb |GV* |gv_fetchmethod |NULLOK HV* stash|NN const char* name
4152 Property changes on:
4153 ___________________________________________________________________
4155 +bc823f99-e23a-42ae-8890-ba2193b93f74:/local/perl-c3:30425
4156 +bc823f99-e23a-42ae-8890-ba2193b93f74:/local/perl-c3-isarev:29720
4157 +bc823f99-e23a-42ae-8890-ba2193b93f74:/local/perl-current:30424