2 ==================================================================
3 --- Makefile.micro (/local/perl-current) (revision 30412)
4 +++ Makefile.micro (/local/perl-c3-subg) (revision 30412)
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 30412)
27 +++ embed.h (/local/perl-c3-subg) (revision 30412)
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 30412)
59 +++ pod/perlapi.pod (/local/perl-c3-subg) (revision 30412)
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 30412)
72 +++ pp_ctl.c (/local/perl-c3-subg) (revision 30412)
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 30412)
88 +++ global.sym (/local/perl-c3-subg) (revision 30412)
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 30412)
106 +++ perl.c (/local/perl-c3-subg) (revision 30412)
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 30412)
118 +++ universal.c (/local/perl-c3-subg) (revision 30412)
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 30412)
230 +++ scope.c (/local/perl-c3-subg) (revision 30412)
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 30412)
252 +++ gv.c (/local/perl-c3-subg) (revision 30412)
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 @@ -1443,7 +1460,8 @@
523 /* Adding a new name to a subroutine invalidates method cache */
524 - PL_sub_generation++;
525 + PL_sub_generation++; /* XXX *Foo::bar = *Baz::Quux, but we have no reference to the destination here ... */
526 + /* need to track down gp_ref users, fix it there, and kill this (also wtf is going on above with the refdec? */
530 @@ -1466,7 +1484,7 @@
533 /* Deleting the name of a subroutine invalidates method cache */
534 - PL_sub_generation++;
535 + PL_sub_generation++; /* XXX as above???, or not??? */
537 if (--gp->gp_refcnt > 0) {
538 if (gp->gp_egv == gv)
539 @@ -1523,11 +1541,13 @@
541 MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
545 + newgen = PL_sub_generation + HvMROMETA(stash)->sub_generation;
547 const AMT * const amtp = (AMT*)mg->mg_ptr;
548 if (amtp->was_ok_am == PL_amagic_generation
549 - && amtp->was_ok_sub == PL_sub_generation) {
550 + && amtp->was_ok_sub == newgen) {
551 return (bool)AMT_OVERLOADED(amtp);
553 sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
554 @@ -1537,7 +1557,7 @@
557 amt.was_ok_am = PL_amagic_generation;
558 - amt.was_ok_sub = PL_sub_generation;
559 + amt.was_ok_sub = newgen;
560 amt.fallback = AMGfallNO;
563 @@ -1649,9 +1669,13 @@
569 if (!stash || !HvNAME_get(stash))
572 + newgen = PL_sub_generation + HvMROMETA(stash)->sub_generation;
574 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
577 @@ -1661,7 +1685,7 @@
579 amtp = (AMT*)mg->mg_ptr;
580 if ( amtp->was_ok_am != PL_amagic_generation
581 - || amtp->was_ok_sub != PL_sub_generation )
582 + || amtp->was_ok_sub != newgen )
584 if (AMT_AMAGIC(amtp)) {
585 CV * const ret = amtp->table[id];
587 ==================================================================
588 --- lib/constant.pm (/local/perl-current) (revision 30412)
589 +++ lib/constant.pm (/local/perl-c3-subg) (revision 30412)
591 use warnings::register;
593 our($VERSION, %declared);
597 #=======================================================================
600 # constants from cv_const_sv are read only. So we have to:
601 Internals::SvREADONLY($scalar, 1);
602 $symtab->{$name} = \$scalar;
603 - &Internals::inc_sub_generation;
604 + mro::invalidate_all_method_caches();
606 *$full_name = sub () { $scalar };
609 ==================================================================
610 --- lib/overload.pm (/local/perl-current) (revision 30412)
611 +++ lib/overload.pm (/local/perl-c3-subg) (revision 30412)
615 -our $VERSION = '1.04';
616 +our $VERSION = '1.05';
622 sub mycan { # Real can would leave stubs.
623 my ($package, $meth) = @_;
624 - return \*{$package . "::$meth"} if defined &{$package . "::$meth"};
626 - foreach $p (@{$package . "::ISA"}) {
627 - my $out = mycan($p, $meth);
628 - return $out if $out;
630 + my $mro = mro::get_linear_isa($package);
631 + foreach my $p (@$mro) {
632 + my $fqmeth = $p . q{::} . $meth;
633 + return \*{$fqmeth} if defined &{$fqmeth};
640 ==================================================================
641 --- lib/mro.pm (/local/perl-current) (revision 30412)
642 +++ lib/mro.pm (/local/perl-c3-subg) (revision 30412)
646 +# Copyright (c) 2007 Brandon L Black
648 +# You may distribute under the terms of either the GNU General Public
649 +# License or the Artistic License, as specified in the README file.
655 +our $VERSION = '0.01';
658 + mro::set_mro(scalar(caller), $_[1]) if $_[1];
667 +mro - Method Resolution Order
671 + use mro 'dfs'; # enable DFS mro for this class (Perl default)
672 + use mro 'c3'; # enable C3 mro for this class
684 +NOTE: These are built into the perl core, there is no need
685 +to do C<use mro> to access these functions.
687 +=head2 mro::get_linear_isa
689 +Arguments: classname[, type]
691 +Return an arrayref which is the linearized MRO of the given class.
692 +Uses whichever MRO is currently in effect for that class by default,
693 +or the given mro (either C<c3> or C<dfs> if specified as C<type>.
697 +Arguments: classname, type
699 +Sets the MRO of the given class to the C<type> argument (either
704 +Arguments: classname
706 +Returns the MRO of the given class (either C<c3> or C<dfs>)
708 +=head2 mro::get_global_sub_generation
712 +Returns the current value of C<PL_sub_generation>.
714 +=head2 mro::invalidate_all_method_caches
718 +Increments C<PL_sub_generation>, which invalidates method
719 +caching in all packages.
721 +=head2 mro::get_sub_generation
723 +Arguments: classname
725 +Returns the current value of a given package's C<sub_generation>.
726 +This is only incremented when necessary for that package.
728 +If one is trying to determine whether significant (method/cache-
729 +affecting) changes have occured for a given stash since you last
730 +checked, you should check both this and the global one above.
732 +=head2 mro::invalidate_method_cache
734 +Arguments: classname
736 +Invalidates the method cache of the given stash and any dependant
741 +Similar in concept to C<SUPER>, but substantially different in
742 +practice on C3-enabled classes. One generally uses it like so:
747 + my $superclass_answer = $self->next::method(@_);
748 + return $superclass_answer + 1;
751 +One major difference in invocation is that you don't
752 +(re-)specify the method name. It forces you to always
753 +use the same method name as the method you started in.
755 +It can be called on an object or a class, of course.
757 +The way it resolves which actual method to call is:
759 +1) First, it determines the linearized MRO of the
760 +object or class it is being called on.
762 +2) Then, it determines the class and method name
763 +of the context it was invoked from.
765 +3) Finally, it searches down the MRO list until
766 +it reaches the contextually enclosing class, then
767 +searches further down the MRO list for the next
768 +method with the same name as the contextually
771 +Failure to find a next method will result in an
772 +exception being thrown (see below for alternatives).
774 +With the Perl-default DFS MRO, this doesn't
775 +result in any substantial difference from the
776 +method resolution behavior of C<SUPER>, but it
777 +changes everything under C3 (this becomes obvious
778 +when one realizes that the common classes in the
779 +C3 linearizations of a given class and one of its
780 +parents will not always be ordered the same for
781 +both). C<next::method>'s resolution behavior
782 +gives the most consistent results (an object's
783 +methods always resolve in that object's MRO
788 +Like C<next::method>, but just returns either
789 +a code reference or C<undef> to indicate that
790 +no further methods of this name exist.
792 +=head2 maybe::next::method
794 +In simple cases it is equivalent to:
796 + $self->next::method(@_) if $self->next_can;
798 +But there are some cases where only this solution
799 +works (like "goto &maybe::next::method");
803 +Brandon L Black, C<blblack@gmail.com>
807 ==================================================================
808 --- win32/Makefile (/local/perl-current) (revision 30412)
809 +++ win32/Makefile (/local/perl-c3-subg) (revision 30412)
818 === win32/makefile.mk
819 ==================================================================
820 --- win32/makefile.mk (/local/perl-current) (revision 30412)
821 +++ win32/makefile.mk (/local/perl-c3-subg) (revision 30412)
830 === win32/Makefile.ce
831 ==================================================================
832 --- win32/Makefile.ce (/local/perl-current) (revision 30412)
833 +++ win32/Makefile.ce (/local/perl-c3-subg) (revision 30412)
844 $(DLLDIR)\globals.obj \
848 $(DLLDIR)\locale.obj \
849 $(DLLDIR)\mathoms.obj \
851 ==================================================================
852 --- t/TEST (/local/perl-current) (revision 30412)
853 +++ t/TEST (/local/perl-c3-subg) (revision 30412)
858 - foreach my $dir (qw(base comp cmd run io op uni)) {
859 + foreach my $dir (qw(base comp cmd run io op uni mro)) {
862 _find_tests("lib") unless $::core;
863 === t/mro (new directory)
864 ==================================================================
865 === t/mro/basic_01_dfs.t
866 ==================================================================
867 --- t/mro/basic_01_dfs.t (/local/perl-current) (revision 30412)
868 +++ t/mro/basic_01_dfs.t (/local/perl-c3-subg) (revision 30412)
875 + unless (-d 'blib') {
876 + chdir 't' if -d 't';
881 +use Test::More tests => 4;
885 +This tests the classic diamond inheritence pattern.
897 + sub hello { 'Diamond_A::hello' }
901 + use base 'Diamond_A';
905 + use base 'Diamond_A';
907 + sub hello { 'Diamond_C::hello' }
911 + use base ('Diamond_B', 'Diamond_C');
916 + mro::get_linear_isa('Diamond_D'),
917 + [ qw(Diamond_D Diamond_B Diamond_A Diamond_C) ],
918 + '... got the right MRO for Diamond_D');
920 +is(Diamond_D->hello, 'Diamond_A::hello', '... method resolved itself as expected');
921 +is(Diamond_D->can('hello')->(), 'Diamond_A::hello', '... can(method) resolved itself as expected');
922 +is(UNIVERSAL::can("Diamond_D", 'hello')->(), 'Diamond_A::hello', '... can(method) resolved itself as expected');
923 === t/mro/vulcan_c3.t
924 ==================================================================
925 --- t/mro/vulcan_c3.t (/local/perl-current) (revision 30412)
926 +++ t/mro/vulcan_c3.t (/local/perl-c3-subg) (revision 30412)
933 + unless (-d 'blib') {
934 + chdir 't' if -d 't';
939 +use Test::More tests => 1;
944 +example taken from: L<http://gauss.gwydiondylan.org/books/drm/drm_50.html>
955 + Intelligent Humanoid
960 + define class <sentient> (<life-form>) end class;
961 + define class <bipedal> (<life-form>) end class;
962 + define class <intelligent> (<sentient>) end class;
963 + define class <humanoid> (<bipedal>) end class;
964 + define class <vulcan> (<intelligent>, <humanoid>) end class;
978 + use base 'LifeForm';
982 + use base 'LifeForm';
984 + package Intelligent;
986 + use base 'Sentient';
990 + use base 'BiPedal';
994 + use base ('Intelligent', 'Humanoid');
998 + mro::get_linear_isa('Vulcan'),
999 + [ qw(Vulcan Intelligent Sentient Humanoid BiPedal LifeForm Object) ],
1000 + '... got the right MRO for the Vulcan Dylan Example');
1001 === t/mro/basic_02_dfs.t
1002 ==================================================================
1003 --- t/mro/basic_02_dfs.t (/local/perl-current) (revision 30412)
1004 +++ t/mro/basic_02_dfs.t (/local/perl-c3-subg) (revision 30412)
1011 + unless (-d 'blib') {
1012 + chdir 't' if -d 't';
1017 +use Test::More tests => 10;
1021 +This example is take from: http://www.python.org/2.3/mro.html
1035 +Level 3 | O | (more general)
1041 +Level 2 3 | D | 4| E | | F | 5 |
1047 +Level 1 1 | B | | C | 2 |
1052 +Level 0 0 | A | (more specialized)
1063 + use base 'Test::O';
1066 + use base 'Test::O';
1069 + sub C_or_E { 'Test::E' }
1073 + use base 'Test::O';
1075 + sub C_or_D { 'Test::D' }
1078 + use base ('Test::D', 'Test::F');
1081 + sub C_or_D { 'Test::C' }
1082 + sub C_or_E { 'Test::C' }
1086 + use base ('Test::D', 'Test::E');
1089 + use base ('Test::B', 'Test::C');
1094 + mro::get_linear_isa('Test::F'),
1095 + [ qw(Test::F Test::O) ],
1096 + '... got the right MRO for Test::F');
1099 + mro::get_linear_isa('Test::E'),
1100 + [ qw(Test::E Test::O) ],
1101 + '... got the right MRO for Test::E');
1104 + mro::get_linear_isa('Test::D'),
1105 + [ qw(Test::D Test::O) ],
1106 + '... got the right MRO for Test::D');
1109 + mro::get_linear_isa('Test::C'),
1110 + [ qw(Test::C Test::D Test::O Test::F) ],
1111 + '... got the right MRO for Test::C');
1114 + mro::get_linear_isa('Test::B'),
1115 + [ qw(Test::B Test::D Test::O Test::E) ],
1116 + '... got the right MRO for Test::B');
1119 + mro::get_linear_isa('Test::A'),
1120 + [ qw(Test::A Test::B Test::D Test::O Test::E Test::C Test::F) ],
1121 + '... got the right MRO for Test::A');
1123 +is(Test::A->C_or_D, 'Test::D', '... got the expected method output');
1124 +is(Test::A->can('C_or_D')->(), 'Test::D', '... can got the expected method output');
1125 +is(Test::A->C_or_E, 'Test::E', '... got the expected method output');
1126 +is(Test::A->can('C_or_E')->(), 'Test::E', '... can got the expected method output');
1127 === t/mro/basic_03_dfs.t
1128 ==================================================================
1129 --- t/mro/basic_03_dfs.t (/local/perl-current) (revision 30412)
1130 +++ t/mro/basic_03_dfs.t (/local/perl-c3-subg) (revision 30412)
1137 + unless (-d 'blib') {
1138 + chdir 't' if -d 't';
1143 +use Test::More tests => 4;
1147 +This example is take from: http://www.python.org/2.3/mro.html
1149 +"My second example"
1166 +Level 2 2 | E | 4 | D | | F | 5
1172 +Level 1 1 | B | | C | 3
1181 +(<class '__main__.A'>, <class '__main__.B'>, <class '__main__.E'>,
1182 +<class '__main__.C'>, <class '__main__.D'>, <class '__main__.F'>,
1191 + sub O_or_D { 'Test::O' }
1192 + sub O_or_F { 'Test::O' }
1195 + use base 'Test::O';
1198 + sub O_or_F { 'Test::F' }
1201 + use base 'Test::O';
1205 + use base 'Test::O';
1208 + sub O_or_D { 'Test::D' }
1209 + sub C_or_D { 'Test::D' }
1212 + use base ('Test::D', 'Test::F');
1215 + sub C_or_D { 'Test::C' }
1218 + use base ('Test::E', 'Test::D');
1222 + use base ('Test::B', 'Test::C');
1227 + mro::get_linear_isa('Test::A'),
1228 + [ qw(Test::A Test::B Test::E Test::O Test::D Test::C Test::F) ],
1229 + '... got the right MRO for Test::A');
1231 +is(Test::A->O_or_D, 'Test::O', '... got the right method dispatch');
1232 +is(Test::A->O_or_F, 'Test::O', '... got the right method dispatch');
1235 +# this test is particularly interesting because the p5 dispatch
1236 +# would actually call Test::D before Test::C and Test::D is a
1237 +# subclass of Test::C
1238 +is(Test::A->C_or_D, 'Test::D', '... got the right method dispatch');
1239 === t/mro/basic_04_dfs.t
1240 ==================================================================
1241 --- t/mro/basic_04_dfs.t (/local/perl-current) (revision 30412)
1242 +++ t/mro/basic_04_dfs.t (/local/perl-c3-subg) (revision 30412)
1249 + unless (-d 'blib') {
1250 + chdir 't' if -d 't';
1255 +use Test::More tests => 1;
1259 +From the parrot test t/pmc/object-meths.t
1271 + package t::lib::A; use mro 'dfs';
1272 + package t::lib::B; use mro 'dfs';
1273 + package t::lib::E; use mro 'dfs';
1274 + package t::lib::C; use mro 'dfs'; use base ('t::lib::A', 't::lib::B');
1275 + package t::lib::D; use mro 'dfs'; use base ('t::lib::A', 't::lib::E');
1276 + package t::lib::F; use mro 'dfs'; use base ('t::lib::C', 't::lib::D');
1280 + mro::get_linear_isa('t::lib::F'),
1281 + [ qw(t::lib::F t::lib::C t::lib::A t::lib::B t::lib::D t::lib::E) ],
1282 + '... got the right MRO for t::lib::F');
1284 === t/mro/basic_05_dfs.t
1285 ==================================================================
1286 --- t/mro/basic_05_dfs.t (/local/perl-current) (revision 30412)
1287 +++ t/mro/basic_05_dfs.t (/local/perl-c3-subg) (revision 30412)
1294 + unless (-d 'blib') {
1295 + chdir 't' if -d 't';
1300 +use Test::More tests => 2;
1304 +This tests a strange bug found by Matt S. Trout
1305 +while building DBIx::Class. Thanks Matt!!!!
1316 + package Diamond_A;
1319 + sub foo { 'Diamond_A::foo' }
1322 + package Diamond_B;
1323 + use base 'Diamond_A';
1326 + sub foo { 'Diamond_B::foo => ' . (shift)->SUPER::foo }
1329 + package Diamond_C;
1331 + use base 'Diamond_A';
1335 + package Diamond_D;
1336 + use base ('Diamond_C', 'Diamond_B');
1339 + sub foo { 'Diamond_D::foo => ' . (shift)->SUPER::foo }
1343 + mro::get_linear_isa('Diamond_D'),
1344 + [ qw(Diamond_D Diamond_C Diamond_A Diamond_B) ],
1345 + '... got the right MRO for Diamond_D');
1348 + 'Diamond_D::foo => Diamond_A::foo',
1349 + '... got the right next::method dispatch path');
1350 === t/mro/vulcan_dfs.t
1351 ==================================================================
1352 --- t/mro/vulcan_dfs.t (/local/perl-current) (revision 30412)
1353 +++ t/mro/vulcan_dfs.t (/local/perl-c3-subg) (revision 30412)
1360 + unless (-d 'blib') {
1361 + chdir 't' if -d 't';
1366 +use Test::More tests => 1;
1371 +example taken from: L<http://gauss.gwydiondylan.org/books/drm/drm_50.html>
1382 + Intelligent Humanoid
1387 + define class <sentient> (<life-form>) end class;
1388 + define class <bipedal> (<life-form>) end class;
1389 + define class <intelligent> (<sentient>) end class;
1390 + define class <humanoid> (<bipedal>) end class;
1391 + define class <vulcan> (<intelligent>, <humanoid>) end class;
1401 + use base 'Object';
1405 + use base 'LifeForm';
1409 + use base 'LifeForm';
1411 + package Intelligent;
1413 + use base 'Sentient';
1417 + use base 'BiPedal';
1421 + use base ('Intelligent', 'Humanoid');
1425 + mro::get_linear_isa('Vulcan'),
1426 + [ qw(Vulcan Intelligent Sentient LifeForm Object Humanoid BiPedal) ],
1427 + '... got the right MRO for the Vulcan Dylan Example');
1429 ==================================================================
1430 --- t/mro/dbic_c3.t (/local/perl-current) (revision 30412)
1431 +++ t/mro/dbic_c3.t (/local/perl-c3-subg) (revision 30412)
1438 + unless (-d 'blib') {
1439 + chdir 't' if -d 't';
1444 +use Test::More tests => 1;
1448 +This example is taken from the inheritance graph of DBIx::Class::Core in DBIx::Class v0.07002:
1449 +(No ASCII art this time, this graph is insane)
1451 +The xx:: prefixes are just to be sure these bogus declarations never stomp on real ones
1456 + package xx::DBIx::Class::Core; use mro 'c3';
1458 + xx::DBIx::Class::Serialize::Storable
1459 + xx::DBIx::Class::InflateColumn
1460 + xx::DBIx::Class::Relationship
1461 + xx::DBIx::Class::PK::Auto
1462 + xx::DBIx::Class::PK
1463 + xx::DBIx::Class::Row
1464 + xx::DBIx::Class::ResultSourceProxy::Table
1465 + xx::DBIx::Class::AccessorGroup
1468 + package xx::DBIx::Class::InflateColumn; use mro 'c3';
1469 + our @ISA = qw/ xx::DBIx::Class::Row /;
1471 + package xx::DBIx::Class::Row; use mro 'c3';
1472 + our @ISA = qw/ xx::DBIx::Class /;
1474 + package xx::DBIx::Class; use mro 'c3';
1476 + xx::DBIx::Class::Componentised
1477 + xx::Class::Data::Accessor
1480 + package xx::DBIx::Class::Relationship; use mro 'c3';
1482 + xx::DBIx::Class::Relationship::Helpers
1483 + xx::DBIx::Class::Relationship::Accessor
1484 + xx::DBIx::Class::Relationship::CascadeActions
1485 + xx::DBIx::Class::Relationship::ProxyMethods
1486 + xx::DBIx::Class::Relationship::Base
1490 + package xx::DBIx::Class::Relationship::Helpers; use mro 'c3';
1492 + xx::DBIx::Class::Relationship::HasMany
1493 + xx::DBIx::Class::Relationship::HasOne
1494 + xx::DBIx::Class::Relationship::BelongsTo
1495 + xx::DBIx::Class::Relationship::ManyToMany
1498 + package xx::DBIx::Class::Relationship::ProxyMethods; use mro 'c3';
1499 + our @ISA = qw/ xx::DBIx::Class /;
1501 + package xx::DBIx::Class::Relationship::Base; use mro 'c3';
1502 + our @ISA = qw/ xx::DBIx::Class /;
1504 + package xx::DBIx::Class::PK::Auto; use mro 'c3';
1505 + our @ISA = qw/ xx::DBIx::Class /;
1507 + package xx::DBIx::Class::PK; use mro 'c3';
1508 + our @ISA = qw/ xx::DBIx::Class::Row /;
1510 + package xx::DBIx::Class::ResultSourceProxy::Table; use mro 'c3';
1512 + xx::DBIx::Class::AccessorGroup
1513 + xx::DBIx::Class::ResultSourceProxy
1516 + package xx::DBIx::Class::ResultSourceProxy; use mro 'c3';
1517 + our @ISA = qw/ xx::DBIx::Class /;
1519 + package xx::Class::Data::Accessor; our @ISA = (); use mro 'c3';
1520 + package xx::DBIx::Class::Relationship::HasMany; our @ISA = (); use mro 'c3';
1521 + package xx::DBIx::Class::Relationship::HasOne; our @ISA = (); use mro 'c3';
1522 + package xx::DBIx::Class::Relationship::BelongsTo; our @ISA = (); use mro 'c3';
1523 + package xx::DBIx::Class::Relationship::ManyToMany; our @ISA = (); use mro 'c3';
1524 + package xx::DBIx::Class::Componentised; our @ISA = (); use mro 'c3';
1525 + package xx::DBIx::Class::AccessorGroup; our @ISA = (); use mro 'c3';
1526 + package xx::DBIx::Class::Serialize::Storable; our @ISA = (); use mro 'c3';
1527 + package xx::DBIx::Class::Relationship::Accessor; our @ISA = (); use mro 'c3';
1528 + package xx::DBIx::Class::Relationship::CascadeActions; our @ISA = (); use mro 'c3';
1532 + mro::get_linear_isa('xx::DBIx::Class::Core'),
1534 + xx::DBIx::Class::Core
1535 + xx::DBIx::Class::Serialize::Storable
1536 + xx::DBIx::Class::InflateColumn
1537 + xx::DBIx::Class::Relationship
1538 + xx::DBIx::Class::Relationship::Helpers
1539 + xx::DBIx::Class::Relationship::HasMany
1540 + xx::DBIx::Class::Relationship::HasOne
1541 + xx::DBIx::Class::Relationship::BelongsTo
1542 + xx::DBIx::Class::Relationship::ManyToMany
1543 + xx::DBIx::Class::Relationship::Accessor
1544 + xx::DBIx::Class::Relationship::CascadeActions
1545 + xx::DBIx::Class::Relationship::ProxyMethods
1546 + xx::DBIx::Class::Relationship::Base
1547 + xx::DBIx::Class::PK::Auto
1548 + xx::DBIx::Class::PK
1549 + xx::DBIx::Class::Row
1550 + xx::DBIx::Class::ResultSourceProxy::Table
1551 + xx::DBIx::Class::AccessorGroup
1552 + xx::DBIx::Class::ResultSourceProxy
1554 + xx::DBIx::Class::Componentised
1555 + xx::Class::Data::Accessor
1557 + '... got the right C3 merge order for xx::DBIx::Class::Core');
1558 === t/mro/method_caching.t
1559 ==================================================================
1560 --- t/mro/method_caching.t (/local/perl-current) (revision 30412)
1561 +++ t/mro/method_caching.t (/local/perl-c3-subg) (revision 30412)
1567 +no warnings 'redefine'; # we do a lot of this
1568 +no warnings 'prototype'; # we do a lot of this
1571 + unless (-d 'blib') {
1572 + chdir 't' if -d 't';
1580 + package MCTest::Base;
1581 + sub foo { return $_[1]+1 };
1584 + package MCTest::Derived;
1585 + our @ISA = qw/MCTest::Base/;
1588 +# These are various ways of re-defining MCTest::Base::foo and checking whether the method is cached when it shouldn't be
1590 + sub { eval 'sub MCTest::Base::foo { return $_[1]+2 }'; is(MCTest::Derived->foo(0), 2); },
1591 + sub { eval 'sub MCTest::Base::foo($) { return $_[1]+3 }'; is(MCTest::Derived->foo(0), 3); },
1592 + sub { eval 'sub MCTest::Base::foo($) { 4 }'; is(MCTest::Derived->foo(0), 4); },
1593 + sub { *MCTest::Base::foo = sub { $_[1]+5 }; is(MCTest::Derived->foo(0), 5); },
1594 + sub { local *MCTest::Base::foo = sub { $_[1]+6 }; is(MCTest::Derived->foo(0), 6); },
1595 + sub { is(MCTest::Derived->foo(0), 5); },
1596 + sub { *ASDF::asdf = sub { $_[1]+7 }; *MCTest::Base::foo = \&ASDF::asdf; is(MCTest::Derived->foo(0), 7); },
1597 + sub { *ASDF::asdf = sub { $_[1]+7 }; *MCTest::Base::foo = \&ASDF::asdf; is(MCTest::Derived->foo(0), 7); },
1598 + sub { undef *MCTest::Base::foo; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); },
1599 + sub { sub MCTest::Base::foo($); *MCTest::Base::foo = \&ASDF::asdf; is(MCTest::Derived->foo(0), 7); },
1600 + sub { *XYZ = sub { $_[1]+8 }; ${MCTest::Base::}{foo} = \&XYZ; is(MCTest::Derived->foo(0), 8); },
1603 +plan tests => scalar(@testsubs) + 1;
1605 +is(MCTest::Derived->foo(0), 1);
1606 +$_->() for (@testsubs);
1607 === t/mro/complex_c3.t
1608 ==================================================================
1609 --- t/mro/complex_c3.t (/local/perl-current) (revision 30412)
1610 +++ t/mro/complex_c3.t (/local/perl-c3-subg) (revision 30412)
1617 + unless (-d 'blib') {
1618 + chdir 't' if -d 't';
1623 +use Test::More tests => 12;
1627 +This example is taken from: http://rt.cpan.org/Public/Bug/Display.html?id=20879
1630 +Level 5 8 | A | 9 | B | A | C | (More General)
1642 +Level 3 4 | G | 6 | E | |
1647 +Level 2 3 | H | 5 | F | |
1655 +Level 1 1 | J | 2 | I | |
1660 +Level 0 0 | K | (More Specialized)
1670 + package Test::A; use mro 'c3';
1672 + package Test::B; use mro 'c3';
1674 + package Test::C; use mro 'c3';
1676 + package Test::D; use mro 'c3';
1677 + use base qw/Test::A Test::B Test::C/;
1679 + package Test::E; use mro 'c3';
1680 + use base qw/Test::D/;
1682 + package Test::F; use mro 'c3';
1683 + use base qw/Test::E/;
1684 + sub testmeth { "wrong" }
1686 + package Test::G; use mro 'c3';
1687 + use base qw/Test::D/;
1689 + package Test::H; use mro 'c3';
1690 + use base qw/Test::G/;
1692 + package Test::I; use mro 'c3';
1693 + use base qw/Test::H Test::F/;
1694 + sub testmeth { "right" }
1696 + package Test::J; use mro 'c3';
1697 + use base qw/Test::F/;
1699 + package Test::K; use mro 'c3';
1700 + use base qw/Test::J Test::I/;
1701 + sub testmeth { shift->next::method }
1705 + mro::get_linear_isa('Test::A'),
1707 + '... got the right C3 merge order for Test::A');
1710 + mro::get_linear_isa('Test::B'),
1712 + '... got the right C3 merge order for Test::B');
1715 + mro::get_linear_isa('Test::C'),
1717 + '... got the right C3 merge order for Test::C');
1720 + mro::get_linear_isa('Test::D'),
1721 + [ qw(Test::D Test::A Test::B Test::C) ],
1722 + '... got the right C3 merge order for Test::D');
1725 + mro::get_linear_isa('Test::E'),
1726 + [ qw(Test::E Test::D Test::A Test::B Test::C) ],
1727 + '... got the right C3 merge order for Test::E');
1730 + mro::get_linear_isa('Test::F'),
1731 + [ qw(Test::F Test::E Test::D Test::A Test::B Test::C) ],
1732 + '... got the right C3 merge order for Test::F');
1735 + mro::get_linear_isa('Test::G'),
1736 + [ qw(Test::G Test::D Test::A Test::B Test::C) ],
1737 + '... got the right C3 merge order for Test::G');
1740 + mro::get_linear_isa('Test::H'),
1741 + [ qw(Test::H Test::G Test::D Test::A Test::B Test::C) ],
1742 + '... got the right C3 merge order for Test::H');
1745 + mro::get_linear_isa('Test::I'),
1746 + [ qw(Test::I Test::H Test::G Test::F Test::E Test::D Test::A Test::B Test::C) ],
1747 + '... got the right C3 merge order for Test::I');
1750 + mro::get_linear_isa('Test::J'),
1751 + [ qw(Test::J Test::F Test::E Test::D Test::A Test::B Test::C) ],
1752 + '... got the right C3 merge order for Test::J');
1755 + mro::get_linear_isa('Test::K'),
1756 + [ qw(Test::K Test::J Test::I Test::H Test::G Test::F Test::E Test::D Test::A Test::B Test::C) ],
1757 + '... got the right C3 merge order for Test::K');
1759 +is(Test::K->testmeth(), "right", 'next::method working ok');
1760 === t/mro/dbic_dfs.t
1761 ==================================================================
1762 --- t/mro/dbic_dfs.t (/local/perl-current) (revision 30412)
1763 +++ t/mro/dbic_dfs.t (/local/perl-c3-subg) (revision 30412)
1770 + unless (-d 'blib') {
1771 + chdir 't' if -d 't';
1776 +use Test::More tests => 1;
1780 +This example is taken from the inheritance graph of DBIx::Class::Core in DBIx::Class v0.07002:
1781 +(No ASCII art this time, this graph is insane)
1783 +The xx:: prefixes are just to be sure these bogus declarations never stomp on real ones
1788 + package xx::DBIx::Class::Core; use mro 'dfs';
1790 + xx::DBIx::Class::Serialize::Storable
1791 + xx::DBIx::Class::InflateColumn
1792 + xx::DBIx::Class::Relationship
1793 + xx::DBIx::Class::PK::Auto
1794 + xx::DBIx::Class::PK
1795 + xx::DBIx::Class::Row
1796 + xx::DBIx::Class::ResultSourceProxy::Table
1797 + xx::DBIx::Class::AccessorGroup
1800 + package xx::DBIx::Class::InflateColumn; use mro 'dfs';
1801 + our @ISA = qw/ xx::DBIx::Class::Row /;
1803 + package xx::DBIx::Class::Row; use mro 'dfs';
1804 + our @ISA = qw/ xx::DBIx::Class /;
1806 + package xx::DBIx::Class; use mro 'dfs';
1808 + xx::DBIx::Class::Componentised
1809 + xx::Class::Data::Accessor
1812 + package xx::DBIx::Class::Relationship; use mro 'dfs';
1814 + xx::DBIx::Class::Relationship::Helpers
1815 + xx::DBIx::Class::Relationship::Accessor
1816 + xx::DBIx::Class::Relationship::CascadeActions
1817 + xx::DBIx::Class::Relationship::ProxyMethods
1818 + xx::DBIx::Class::Relationship::Base
1822 + package xx::DBIx::Class::Relationship::Helpers; use mro 'dfs';
1824 + xx::DBIx::Class::Relationship::HasMany
1825 + xx::DBIx::Class::Relationship::HasOne
1826 + xx::DBIx::Class::Relationship::BelongsTo
1827 + xx::DBIx::Class::Relationship::ManyToMany
1830 + package xx::DBIx::Class::Relationship::ProxyMethods; use mro 'dfs';
1831 + our @ISA = qw/ xx::DBIx::Class /;
1833 + package xx::DBIx::Class::Relationship::Base; use mro 'dfs';
1834 + our @ISA = qw/ xx::DBIx::Class /;
1836 + package xx::DBIx::Class::PK::Auto; use mro 'dfs';
1837 + our @ISA = qw/ xx::DBIx::Class /;
1839 + package xx::DBIx::Class::PK; use mro 'dfs';
1840 + our @ISA = qw/ xx::DBIx::Class::Row /;
1842 + package xx::DBIx::Class::ResultSourceProxy::Table; use mro 'dfs';
1844 + xx::DBIx::Class::AccessorGroup
1845 + xx::DBIx::Class::ResultSourceProxy
1848 + package xx::DBIx::Class::ResultSourceProxy; use mro 'dfs';
1849 + our @ISA = qw/ xx::DBIx::Class /;
1851 + package xx::Class::Data::Accessor; our @ISA = (); use mro 'dfs';
1852 + package xx::DBIx::Class::Relationship::HasMany; our @ISA = (); use mro 'dfs';
1853 + package xx::DBIx::Class::Relationship::HasOne; our @ISA = (); use mro 'dfs';
1854 + package xx::DBIx::Class::Relationship::BelongsTo; our @ISA = (); use mro 'dfs';
1855 + package xx::DBIx::Class::Relationship::ManyToMany; our @ISA = (); use mro 'dfs';
1856 + package xx::DBIx::Class::Componentised; our @ISA = (); use mro 'dfs';
1857 + package xx::DBIx::Class::AccessorGroup; our @ISA = (); use mro 'dfs';
1858 + package xx::DBIx::Class::Serialize::Storable; our @ISA = (); use mro 'dfs';
1859 + package xx::DBIx::Class::Relationship::Accessor; our @ISA = (); use mro 'dfs';
1860 + package xx::DBIx::Class::Relationship::CascadeActions; our @ISA = (); use mro 'dfs';
1864 + mro::get_linear_isa('xx::DBIx::Class::Core'),
1866 + xx::DBIx::Class::Core
1867 + xx::DBIx::Class::Serialize::Storable
1868 + xx::DBIx::Class::InflateColumn
1869 + xx::DBIx::Class::Row
1871 + xx::DBIx::Class::Componentised
1872 + xx::Class::Data::Accessor
1873 + xx::DBIx::Class::Relationship
1874 + xx::DBIx::Class::Relationship::Helpers
1875 + xx::DBIx::Class::Relationship::HasMany
1876 + xx::DBIx::Class::Relationship::HasOne
1877 + xx::DBIx::Class::Relationship::BelongsTo
1878 + xx::DBIx::Class::Relationship::ManyToMany
1879 + xx::DBIx::Class::Relationship::Accessor
1880 + xx::DBIx::Class::Relationship::CascadeActions
1881 + xx::DBIx::Class::Relationship::ProxyMethods
1882 + xx::DBIx::Class::Relationship::Base
1883 + xx::DBIx::Class::PK::Auto
1884 + xx::DBIx::Class::PK
1885 + xx::DBIx::Class::ResultSourceProxy::Table
1886 + xx::DBIx::Class::AccessorGroup
1887 + xx::DBIx::Class::ResultSourceProxy
1889 + '... got the right DFS merge order for xx::DBIx::Class::Core');
1890 === t/mro/recursion_c3.t
1891 ==================================================================
1892 --- t/mro/recursion_c3.t (/local/perl-current) (revision 30412)
1893 +++ t/mro/recursion_c3.t (/local/perl-c3-subg) (revision 30412)
1900 + unless (-d 'blib') {
1901 + chdir 't' if -d 't';
1909 +# XXX needs translation back to classes, etc
1911 +plan skip_all => "Your system has no SIGALRM" if !exists $SIG{ALRM};
1916 +These are like the 010_complex_merge_classless test,
1917 +but an infinite loop has been made in the heirarchy,
1918 +to test that we can fail cleanly instead of going
1919 +into an infinite loop
1923 +# initial setup, everything sane
1926 + our @ISA = qw/J I/;
1930 + our @ISA = qw/H F/;
1940 + our @ISA = qw/A B C/;
1949 +# A series of 8 abberations that would cause infinite loops,
1950 +# each one undoing the work of the previous
1952 + sub { @E::ISA = qw/F/ },
1953 + sub { @E::ISA = qw/D/; @C::ISA = qw/F/ },
1954 + sub { @C::ISA = qw//; @A::ISA = qw/K/ },
1955 + sub { @A::ISA = qw//; @J::ISA = qw/F K/ },
1956 + sub { @J::ISA = qw/F/; @H::ISA = qw/K G/ },
1957 + sub { @H::ISA = qw/G/; @B::ISA = qw/B/ },
1958 + sub { @B::ISA = qw//; @K::ISA = qw/K J I/ },
1959 + sub { @K::ISA = qw/J I/; @D::ISA = qw/A H B C/ },
1962 +foreach my $loopy (@loopies) {
1964 + local $SIG{ALRM} = sub { die "ALRMTimeout" };
1967 + mro::get_linear_isa('K', 'c3');
1970 + if(my $err = $@) {
1971 + if($err =~ /ALRMTimeout/) {
1972 + ok(0, "Loop terminated by SIGALRM");
1974 + elsif($err =~ /Recursive inheritance detected/) {
1975 + ok(1, "Graceful exception thrown");
1978 + ok(0, "Unrecognized exception: $err");
1982 + ok(0, "Infinite loop apparently succeeded???");
1985 === t/mro/overload_c3.t
1986 ==================================================================
1987 --- t/mro/overload_c3.t (/local/perl-current) (revision 30412)
1988 +++ t/mro/overload_c3.t (/local/perl-c3-subg) (revision 30412)
1995 + unless (-d 'blib') {
1996 + chdir 't' if -d 't';
2001 +use Test::More tests => 7;
2009 + package OverloadingTest;
2013 + use base 'BaseTest';
2014 + use overload '""' => sub { ref(shift) . " stringified" },
2017 + sub new { bless {} => shift }
2019 + package InheritingFromOverloadedTest;
2022 + use base 'OverloadingTest';
2026 +my $x = InheritingFromOverloadedTest->new();
2027 +isa_ok($x, 'InheritingFromOverloadedTest');
2029 +my $y = OverloadingTest->new();
2030 +isa_ok($y, 'OverloadingTest');
2032 +is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing');
2033 +is("$y", 'OverloadingTest stringified', '... got the right value when stringifing');
2035 +ok(($y eq 'OverloadingTest stringified'), '... eq was handled correctly');
2039 + $result = $x eq 'InheritingFromOverloadedTest stringified'
2041 +ok(!$@, '... this should not throw an exception');
2042 +ok($result, '... and we should get the true value');
2044 === t/mro/complex_dfs.t
2045 ==================================================================
2046 --- t/mro/complex_dfs.t (/local/perl-current) (revision 30412)
2047 +++ t/mro/complex_dfs.t (/local/perl-c3-subg) (revision 30412)
2054 + unless (-d 'blib') {
2055 + chdir 't' if -d 't';
2060 +use Test::More tests => 11;
2064 +This example is taken from: http://rt.cpan.org/Public/Bug/Display.html?id=20879
2067 +Level 5 8 | A | 9 | B | A | C | (More General)
2079 +Level 3 4 | G | 6 | E | |
2084 +Level 2 3 | H | 5 | F | |
2092 +Level 1 1 | J | 2 | I | |
2097 +Level 0 0 | K | (More Specialized)
2107 + package Test::A; use mro 'dfs';
2109 + package Test::B; use mro 'dfs';
2111 + package Test::C; use mro 'dfs';
2113 + package Test::D; use mro 'dfs';
2114 + use base qw/Test::A Test::B Test::C/;
2116 + package Test::E; use mro 'dfs';
2117 + use base qw/Test::D/;
2119 + package Test::F; use mro 'dfs';
2120 + use base qw/Test::E/;
2122 + package Test::G; use mro 'dfs';
2123 + use base qw/Test::D/;
2125 + package Test::H; use mro 'dfs';
2126 + use base qw/Test::G/;
2128 + package Test::I; use mro 'dfs';
2129 + use base qw/Test::H Test::F/;
2131 + package Test::J; use mro 'dfs';
2132 + use base qw/Test::F/;
2134 + package Test::K; use mro 'dfs';
2135 + use base qw/Test::J Test::I/;
2139 + mro::get_linear_isa('Test::A'),
2141 + '... got the right DFS merge order for Test::A');
2144 + mro::get_linear_isa('Test::B'),
2146 + '... got the right DFS merge order for Test::B');
2149 + mro::get_linear_isa('Test::C'),
2151 + '... got the right DFS merge order for Test::C');
2154 + mro::get_linear_isa('Test::D'),
2155 + [ qw(Test::D Test::A Test::B Test::C) ],
2156 + '... got the right DFS merge order for Test::D');
2159 + mro::get_linear_isa('Test::E'),
2160 + [ qw(Test::E Test::D Test::A Test::B Test::C) ],
2161 + '... got the right DFS merge order for Test::E');
2164 + mro::get_linear_isa('Test::F'),
2165 + [ qw(Test::F Test::E Test::D Test::A Test::B Test::C) ],
2166 + '... got the right DFS merge order for Test::F');
2169 + mro::get_linear_isa('Test::G'),
2170 + [ qw(Test::G Test::D Test::A Test::B Test::C) ],
2171 + '... got the right DFS merge order for Test::G');
2174 + mro::get_linear_isa('Test::H'),
2175 + [ qw(Test::H Test::G Test::D Test::A Test::B Test::C) ],
2176 + '... got the right DFS merge order for Test::H');
2179 + mro::get_linear_isa('Test::I'),
2180 + [ qw(Test::I Test::H Test::G Test::D Test::A Test::B Test::C Test::F Test::E) ],
2181 + '... got the right DFS merge order for Test::I');
2184 + mro::get_linear_isa('Test::J'),
2185 + [ qw(Test::J Test::F Test::E Test::D Test::A Test::B Test::C) ],
2186 + '... got the right DFS merge order for Test::J');
2189 + mro::get_linear_isa('Test::K'),
2190 + [ qw(Test::K Test::J Test::F Test::E Test::D Test::A Test::B Test::C Test::I Test::H Test::G) ],
2191 + '... got the right DFS merge order for Test::K');
2192 === t/mro/inconsistent_c3.t
2193 ==================================================================
2194 --- t/mro/inconsistent_c3.t (/local/perl-current) (revision 30412)
2195 +++ t/mro/inconsistent_c3.t (/local/perl-c3-subg) (revision 30412)
2202 + unless (-d 'blib') {
2203 + chdir 't' if -d 't';
2208 +use Test::More tests => 1;
2212 +This example is take from: http://www.python.org/2.3/mro.html
2214 +"Serious order disagreement" # From Guido
2221 + class Z(A,B): pass #creates Z(A,B) in Python 2.2
2223 + pass # Z(A,B) cannot be created in Python 2.3
2233 + our @ISA = ('X', 'Y');
2236 + our @ISA = ('Y', 'X');
2239 + our @ISA = ('XY', 'YX');
2242 +eval { mro::get_linear_isa('Z', 'c3') };
2243 +like($@, qr/^Inconsistent /, '... got the right error with an inconsistent hierarchy');
2244 === t/mro/recursion_dfs.t
2245 ==================================================================
2246 --- t/mro/recursion_dfs.t (/local/perl-current) (revision 30412)
2247 +++ t/mro/recursion_dfs.t (/local/perl-c3-subg) (revision 30412)
2254 + unless (-d 'blib') {
2255 + chdir 't' if -d 't';
2263 +# XXX needs translation back to classes, etc
2265 +plan skip_all => "Your system has no SIGALRM" if !exists $SIG{ALRM};
2270 +These are like the 010_complex_merge_classless test,
2271 +but an infinite loop has been made in the heirarchy,
2272 +to test that we can fail cleanly instead of going
2273 +into an infinite loop
2277 +# initial setup, everything sane
2280 + our @ISA = qw/J I/;
2284 + our @ISA = qw/H F/;
2294 + our @ISA = qw/A B C/;
2303 +# A series of 8 abberations that would cause infinite loops,
2304 +# each one undoing the work of the previous
2306 + sub { @E::ISA = qw/F/ },
2307 + sub { @E::ISA = qw/D/; @C::ISA = qw/F/ },
2308 + sub { @C::ISA = qw//; @A::ISA = qw/K/ },
2309 + sub { @A::ISA = qw//; @J::ISA = qw/F K/ },
2310 + sub { @J::ISA = qw/F/; @H::ISA = qw/K G/ },
2311 + sub { @H::ISA = qw/G/; @B::ISA = qw/B/ },
2312 + sub { @B::ISA = qw//; @K::ISA = qw/K J I/ },
2313 + sub { @K::ISA = qw/J I/; @D::ISA = qw/A H B C/ },
2316 +foreach my $loopy (@loopies) {
2318 + local $SIG{ALRM} = sub { die "ALRMTimeout" };
2321 + mro::get_linear_isa('K', 'dfs');
2324 + if(my $err = $@) {
2325 + if($err =~ /ALRMTimeout/) {
2326 + ok(0, "Loop terminated by SIGALRM");
2328 + elsif($err =~ /Recursive inheritance detected/) {
2329 + ok(1, "Graceful exception thrown");
2332 + ok(0, "Unrecognized exception: $err");
2336 + ok(0, "Infinite loop apparently succeeded???");
2339 === t/mro/basic_01_c3.t
2340 ==================================================================
2341 --- t/mro/basic_01_c3.t (/local/perl-current) (revision 30412)
2342 +++ t/mro/basic_01_c3.t (/local/perl-c3-subg) (revision 30412)
2349 + unless (-d 'blib') {
2350 + chdir 't' if -d 't';
2355 +use Test::More tests => 4;
2359 +This tests the classic diamond inheritence pattern.
2370 + package Diamond_A;
2371 + sub hello { 'Diamond_A::hello' }
2374 + package Diamond_B;
2375 + use base 'Diamond_A';
2378 + package Diamond_C;
2379 + use base 'Diamond_A';
2381 + sub hello { 'Diamond_C::hello' }
2384 + package Diamond_D;
2385 + use base ('Diamond_B', 'Diamond_C');
2390 + mro::get_linear_isa('Diamond_D'),
2391 + [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ],
2392 + '... got the right MRO for Diamond_D');
2394 +is(Diamond_D->hello, 'Diamond_C::hello', '... method resolved itself as expected');
2395 +is(Diamond_D->can('hello')->(), 'Diamond_C::hello', '... can(method) resolved itself as expected');
2396 +is(UNIVERSAL::can("Diamond_D", 'hello')->(), 'Diamond_C::hello', '... can(method) resolved itself as expected');
2397 === t/mro/basic_02_c3.t
2398 ==================================================================
2399 --- t/mro/basic_02_c3.t (/local/perl-current) (revision 30412)
2400 +++ t/mro/basic_02_c3.t (/local/perl-c3-subg) (revision 30412)
2407 + unless (-d 'blib') {
2408 + chdir 't' if -d 't';
2413 +use Test::More tests => 10;
2417 +This example is take from: http://www.python.org/2.3/mro.html
2431 +Level 3 | O | (more general)
2437 +Level 2 3 | D | 4| E | | F | 5 |
2443 +Level 1 1 | B | | C | 2 |
2448 +Level 0 0 | A | (more specialized)
2459 + use base 'Test::O';
2462 + use base 'Test::O';
2465 + sub C_or_E { 'Test::E' }
2469 + use base 'Test::O';
2471 + sub C_or_D { 'Test::D' }
2474 + use base ('Test::D', 'Test::F');
2477 + sub C_or_D { 'Test::C' }
2478 + sub C_or_E { 'Test::C' }
2482 + use base ('Test::D', 'Test::E');
2485 + use base ('Test::B', 'Test::C');
2490 + mro::get_linear_isa('Test::F'),
2491 + [ qw(Test::F Test::O) ],
2492 + '... got the right MRO for Test::F');
2495 + mro::get_linear_isa('Test::E'),
2496 + [ qw(Test::E Test::O) ],
2497 + '... got the right MRO for Test::E');
2500 + mro::get_linear_isa('Test::D'),
2501 + [ qw(Test::D Test::O) ],
2502 + '... got the right MRO for Test::D');
2505 + mro::get_linear_isa('Test::C'),
2506 + [ qw(Test::C Test::D Test::F Test::O) ],
2507 + '... got the right MRO for Test::C');
2510 + mro::get_linear_isa('Test::B'),
2511 + [ qw(Test::B Test::D Test::E Test::O) ],
2512 + '... got the right MRO for Test::B');
2515 + mro::get_linear_isa('Test::A'),
2516 + [ qw(Test::A Test::B Test::C Test::D Test::E Test::F Test::O) ],
2517 + '... got the right MRO for Test::A');
2519 +is(Test::A->C_or_D, 'Test::C', '... got the expected method output');
2520 +is(Test::A->can('C_or_D')->(), 'Test::C', '... can got the expected method output');
2521 +is(Test::A->C_or_E, 'Test::C', '... got the expected method output');
2522 +is(Test::A->can('C_or_E')->(), 'Test::C', '... can got the expected method output');
2523 === t/mro/overload_dfs.t
2524 ==================================================================
2525 --- t/mro/overload_dfs.t (/local/perl-current) (revision 30412)
2526 +++ t/mro/overload_dfs.t (/local/perl-c3-subg) (revision 30412)
2533 + unless (-d 'blib') {
2534 + chdir 't' if -d 't';
2539 +use Test::More tests => 7;
2547 + package OverloadingTest;
2551 + use base 'BaseTest';
2552 + use overload '""' => sub { ref(shift) . " stringified" },
2555 + sub new { bless {} => shift }
2557 + package InheritingFromOverloadedTest;
2560 + use base 'OverloadingTest';
2564 +my $x = InheritingFromOverloadedTest->new();
2565 +isa_ok($x, 'InheritingFromOverloadedTest');
2567 +my $y = OverloadingTest->new();
2568 +isa_ok($y, 'OverloadingTest');
2570 +is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing');
2571 +is("$y", 'OverloadingTest stringified', '... got the right value when stringifing');
2573 +ok(($y eq 'OverloadingTest stringified'), '... eq was handled correctly');
2577 + $result = $x eq 'InheritingFromOverloadedTest stringified'
2579 +ok(!$@, '... this should not throw an exception');
2580 +ok($result, '... and we should get the true value');
2582 === t/mro/basic_03_c3.t
2583 ==================================================================
2584 --- t/mro/basic_03_c3.t (/local/perl-current) (revision 30412)
2585 +++ t/mro/basic_03_c3.t (/local/perl-c3-subg) (revision 30412)
2592 + unless (-d 'blib') {
2593 + chdir 't' if -d 't';
2598 +use Test::More tests => 4;
2602 +This example is take from: http://www.python.org/2.3/mro.html
2604 +"My second example"
2621 +Level 2 2 | E | 4 | D | | F | 5
2627 +Level 1 1 | B | | C | 3
2636 +(<class '__main__.A'>, <class '__main__.B'>, <class '__main__.E'>,
2637 +<class '__main__.C'>, <class '__main__.D'>, <class '__main__.F'>,
2646 + sub O_or_D { 'Test::O' }
2647 + sub O_or_F { 'Test::O' }
2650 + use base 'Test::O';
2653 + sub O_or_F { 'Test::F' }
2656 + use base 'Test::O';
2660 + use base 'Test::O';
2663 + sub O_or_D { 'Test::D' }
2664 + sub C_or_D { 'Test::D' }
2667 + use base ('Test::D', 'Test::F');
2670 + sub C_or_D { 'Test::C' }
2673 + use base ('Test::E', 'Test::D');
2677 + use base ('Test::B', 'Test::C');
2682 + mro::get_linear_isa('Test::A'),
2683 + [ qw(Test::A Test::B Test::E Test::C Test::D Test::F Test::O) ],
2684 + '... got the right MRO for Test::A');
2686 +is(Test::A->O_or_D, 'Test::D', '... got the right method dispatch');
2687 +is(Test::A->O_or_F, 'Test::F', '... got the right method dispatch');
2690 +# this test is particularly interesting because the p5 dispatch
2691 +# would actually call Test::D before Test::C and Test::D is a
2692 +# subclass of Test::C
2693 +is(Test::A->C_or_D, 'Test::C', '... got the right method dispatch');
2694 === t/mro/basic_04_c3.t
2695 ==================================================================
2696 --- t/mro/basic_04_c3.t (/local/perl-current) (revision 30412)
2697 +++ t/mro/basic_04_c3.t (/local/perl-c3-subg) (revision 30412)
2704 + unless (-d 'blib') {
2705 + chdir 't' if -d 't';
2710 +use Test::More tests => 1;
2714 +From the parrot test t/pmc/object-meths.t
2726 + package t::lib::A; use mro 'c3';
2727 + package t::lib::B; use mro 'c3';
2728 + package t::lib::E; use mro 'c3';
2729 + package t::lib::C; use mro 'c3'; use base ('t::lib::A', 't::lib::B');
2730 + package t::lib::D; use mro 'c3'; use base ('t::lib::A', 't::lib::E');
2731 + package t::lib::F; use mro 'c3'; use base ('t::lib::C', 't::lib::D');
2735 + mro::get_linear_isa('t::lib::F'),
2736 + [ qw(t::lib::F t::lib::C t::lib::D t::lib::A t::lib::B t::lib::E) ],
2737 + '... got the right MRO for t::lib::F');
2739 === t/mro/basic_05_c3.t
2740 ==================================================================
2741 --- t/mro/basic_05_c3.t (/local/perl-current) (revision 30412)
2742 +++ t/mro/basic_05_c3.t (/local/perl-c3-subg) (revision 30412)
2749 + unless (-d 'blib') {
2750 + chdir 't' if -d 't';
2755 +use Test::More tests => 2;
2759 +This tests a strange bug found by Matt S. Trout
2760 +while building DBIx::Class. Thanks Matt!!!!
2771 + package Diamond_A;
2774 + sub foo { 'Diamond_A::foo' }
2777 + package Diamond_B;
2778 + use base 'Diamond_A';
2781 + sub foo { 'Diamond_B::foo => ' . (shift)->SUPER::foo }
2784 + package Diamond_C;
2786 + use base 'Diamond_A';
2790 + package Diamond_D;
2791 + use base ('Diamond_C', 'Diamond_B');
2794 + sub foo { 'Diamond_D::foo => ' . (shift)->SUPER::foo }
2798 + mro::get_linear_isa('Diamond_D'),
2799 + [ qw(Diamond_D Diamond_C Diamond_B Diamond_A) ],
2800 + '... got the right MRO for Diamond_D');
2803 + 'Diamond_D::foo => Diamond_B::foo => Diamond_A::foo',
2804 + '... got the right next::method dispatch path');
2806 ==================================================================
2807 --- t/op/magic.t (/local/perl-current) (revision 30412)
2808 +++ t/op/magic.t (/local/perl-c3-subg) (revision 30412)
2809 @@ -440,7 +440,10 @@
2813 - eval { push @ISA, __PACKAGE__ };
2814 + # This used to be __PACKAGE__, but that causes recursive
2815 + # inheritance, which is detected earlier now and broke
2817 + eval { push @ISA, __FILE__ };
2818 ok( $@ eq '', 'Push a constant on a magic array');
2819 $@ and print "# $@";
2820 eval { %ENV = (PATH => __PACKAGE__) };
2821 === NetWare/Makefile
2822 ==================================================================
2823 --- NetWare/Makefile (/local/perl-current) (revision 30412)
2824 +++ NetWare/Makefile (/local/perl-c3-subg) (revision 30412)
2833 === vms/descrip_mms.template
2834 ==================================================================
2835 --- vms/descrip_mms.template (/local/perl-current) (revision 30412)
2836 +++ vms/descrip_mms.template (/local/perl-c3-subg) (revision 30412)
2837 @@ -279,13 +279,13 @@
2839 #### End of system configuration section. ####
2841 -c0 = $(MALLOC_C) $(SOCKC) av.c deb.c doio.c doop.c dump.c globals.c gv.c hv.c
2842 +c0 = $(MALLOC_C) $(SOCKC) av.c deb.c doio.c doop.c dump.c globals.c gv.c hv.c mro.c
2843 c1 = mg.c locale.c mathoms.c miniperlmain.c numeric.c op.c pad.c perl.c perlapi.c perlio.c
2844 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
2845 c3 = run.c scope.c sv.c taint.c toke.c universal.c utf8.c util.c vms.c xsutils.c
2846 c = $(c0) $(c1) $(c2) $(c3)
2848 -obj0 = $(MALLOC_O) $(SOCKO) av$(O) deb$(O) doio$(O) doop$(O) dump$(O)
2849 +obj0 = $(MALLOC_O) $(SOCKO) av$(O) deb$(O) doio$(O) doop$(O) dump$(O) mro$(O)
2850 obj1 = globals$(O) gv$(O) hv$(O) locale$(O) mathoms$(O) mg$(O) miniperlmain$(O) numeric$(O) op$(O) pad$(O)
2851 obj2 = perl$(O) perlapi$(O) perlio$(O) perly$(O) pp$(O) pp_ctl$(O) pp_hot$(O) reentr$(O)
2852 obj3 = pp_pack$(O) pp_sort$(O) pp_sys$(O) regcomp$(O) regexec$(O) run$(O) scope$(O) sv$(O) taint$(O) toke$(O)
2853 @@ -1615,6 +1615,8 @@
2854 $(CC) $(CORECFLAGS) $(MMS$SOURCE)
2856 $(CC) $(CORECFLAGS) $(MMS$SOURCE)
2857 +mro$(O) : mro.c $(h)
2858 + $(CC) $(CORECFLAGS) $(MMS$SOURCE)
2860 $(CC) $(CORECFLAGS) $(MMS$SOURCE)
2861 locale$(O) : locale.c $(h)
2863 ==================================================================
2864 --- Makefile.SH (/local/perl-current) (revision 30412)
2865 +++ Makefile.SH (/local/perl-c3-subg) (revision 30412)
2867 h5 = utf8.h warnings.h
2868 h = $(h1) $(h2) $(h3) $(h4) $(h5)
2870 -c1 = av.c scope.c op.c doop.c doio.c dump.c gv.c hv.c mg.c reentr.c perl.c
2871 +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
2872 c2 = perly.c pp.c pp_hot.c pp_ctl.c pp_sys.c regcomp.c regexec.c utf8.c sv.c
2873 c3 = taint.c toke.c util.c deb.c run.c universal.c xsutils.c pad.c globals.c
2874 c4 = perlio.c perlapi.c numeric.c mathoms.c locale.c pp_pack.c pp_sort.c
2877 c = $(c1) $(c2) $(c3) $(c4) $(c5) miniperlmain.c perlmain.c opmini.c
2879 -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)
2880 +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)
2881 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)
2882 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)
2885 ==================================================================
2886 --- proto.h (/local/perl-current) (revision 30412)
2887 +++ proto.h (/local/perl-c3-subg) (revision 30412)
2888 @@ -635,6 +635,25 @@
2889 PERL_CALLCONV GV* Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN len, const U32 flags)
2890 __attribute__nonnull__(pTHX_1);
2892 +PERL_CALLCONV struct mro_meta* Perl_mro_meta_init(pTHX_ HV* stash)
2893 + __attribute__nonnull__(pTHX_1);
2895 +PERL_CALLCONV AV* Perl_mro_linear(pTHX_ HV* stash)
2896 + __attribute__nonnull__(pTHX_1);
2898 +PERL_CALLCONV AV* Perl_mro_linear_c3(pTHX_ HV* stash, I32 level)
2899 + __attribute__nonnull__(pTHX_1);
2901 +PERL_CALLCONV AV* Perl_mro_linear_dfs(pTHX_ HV* stash, I32 level)
2902 + __attribute__nonnull__(pTHX_1);
2904 +PERL_CALLCONV void Perl_mro_isa_changed_in(pTHX_ HV* stash)
2905 + __attribute__nonnull__(pTHX_1);
2907 +PERL_CALLCONV void Perl_mro_method_changed_in(pTHX_ HV* stash)
2908 + __attribute__nonnull__(pTHX_1);
2910 +PERL_CALLCONV void Perl_boot_core_mro(pTHX);
2911 PERL_CALLCONV GV* Perl_gv_fetchmeth(pTHX_ HV* stash, const char* name, STRLEN len, I32 level)
2912 __attribute__nonnull__(pTHX_2);
2915 ==================================================================
2916 --- ext/B/t/b.t (/local/perl-current) (revision 30412)
2917 +++ ext/B/t/b.t (/local/perl-c3-subg) (revision 30412)
2921 my $sg = B::sub_generation();
2922 - *Whatever::hand_waving = sub { };
2923 + *UNIVERSAL::hand_waving = sub { };
2924 ok( $sg < B::sub_generation, "sub_generation increments" );
2928 ==================================================================
2929 --- MANIFEST (/local/perl-current) (revision 30412)
2930 +++ MANIFEST (/local/perl-c3-subg) (revision 30412)
2931 @@ -2252,6 +2252,7 @@
2932 lib/Module/Pluggable/t/lib/OddTest/Plugin/-Dodgy.pm Module::Pluggable tests
2933 lib/Module/Pluggable/t/lib/OddTest/Plugin/Foo.pm Module::Pluggable tests
2934 lib/Module/Pluggable/t/lib/TA/C/A/I.pm Module::Pluggable tests
2935 +lib/mro.pm mro extension
2936 lib/Net/Changes.libnet libnet
2937 lib/Net/Cmd.pm libnet
2938 lib/Net/Config.eg libnet
2939 @@ -2953,6 +2954,7 @@
2940 mpeix/mpeix_setjmp.c MPE/iX port
2941 mpeix/nm MPE/iX port
2942 mpeix/relink MPE/iX port
2943 +mro.c Method Resolution Order code
2944 myconfig.SH Prints summary of the current configuration
2945 NetWare/bat/Buildtype.bat NetWare port
2946 NetWare/bat/SetCodeWar.bat NetWare port
2947 @@ -3618,6 +3620,28 @@
2948 t/lib/warnings/universal Tests for universal.c for warnings.t
2949 t/lib/warnings/utf8 Tests for utf8.c for warnings.t
2950 t/lib/warnings/util Tests for util.c for warnings.t
2951 +t/mro/basic_01_c3.t mro tests
2952 +t/mro/basic_01_dfs.t mro tests
2953 +t/mro/basic_02_c3.t mro tests
2954 +t/mro/basic_02_dfs.t mro tests
2955 +t/mro/basic_03_c3.t mro tests
2956 +t/mro/basic_03_dfs.t mro tests
2957 +t/mro/basic_04_c3.t mro tests
2958 +t/mro/basic_04_dfs.t mro tests
2959 +t/mro/basic_05_c3.t mro tests
2960 +t/mro/basic_05_dfs.t mro tests
2961 +t/mro/complex_c3.t mro tests
2962 +t/mro/complex_dfs.t mro tests
2963 +t/mro/dbic_c3.t mro tests
2964 +t/mro/dbic_dfs.t mro tests
2965 +t/mro/inconsistent_c3.t mro tests
2966 +t/mro/overload_c3.t mro tests
2967 +t/mro/overload_dfs.t mro tests
2968 +t/mro/recursion_c3.t mro tests
2969 +t/mro/recursion_dfs.t mro tests
2970 +t/mro/vulcan_c3.t mro tests
2971 +t/mro/vulcan_dfs.t mro tests
2972 +t/mro/method_caching.t mro tests
2973 Todo.micro The Wishlist for microperl
2975 t/op/64bitint.t See if 64 bit integers work
2977 ==================================================================
2978 --- mro.c (/local/perl-current) (revision 30412)
2979 +++ mro.c (/local/perl-c3-subg) (revision 30412)
2983 + * Copyright (c) 2007 Brandon L Black
2985 + * You may distribute under the terms of either the GNU General Public
2986 + * License or the Artistic License, as specified in the README file.
2991 +=head1 MRO Functions
2993 +These functions are related to the method resolution order of perl classes
2998 +#include "EXTERN.h"
3002 +Perl_mro_meta_init(pTHX_ HV* stash)
3007 + assert(HvAUX(stash));
3008 + assert(!(HvAUX(stash)->xhv_mro_meta));
3009 + Newxz(newmeta, sizeof(struct mro_meta), char);
3010 + HvAUX(stash)->xhv_mro_meta = (struct mro_meta*)newmeta;
3011 + ((struct mro_meta*)newmeta)->sub_generation = 1;
3013 + /* Manually flag UNIVERSAL as being universal.
3014 + This happens early in perl booting (when universal.c
3015 + does the newXS calls for UNIVERSAL::*), and infects
3016 + other packages as they are added to UNIVERSAL's MRO
3018 + if(HvNAMELEN_get(stash) == 9
3019 + && strEQ(HEK_KEY(HvAUX(stash)->xhv_name), "UNIVERSAL")) {
3020 + HvMROMETA(stash)->is_universal = 1;
3027 +=for apidoc mro_linear_dfs
3029 +Returns the Depth-First Search linearization of @ISA
3030 +the given stash. The return value is a read-only AV*.
3031 +C<level> should be 0 (it is used internally in this
3032 +function's recursion).
3037 +Perl_mro_linear_dfs(pTHX_ HV *stash, I32 level)
3048 + const char* stashname;
3049 + struct mro_meta* meta;
3052 + assert(HvAUX(stash));
3054 + stashname = HvNAME_get(stash);
3057 + "Can't linearize anonymous symbol table");
3060 + Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
3063 + meta = HvMROMETA(stash);
3064 + if((retval = meta->mro_linear_dfs)) {
3065 + /* return cache if valid */
3066 + SvREFCNT_inc_simple_void_NN(retval);
3070 + /* not in cache, make a new one */
3071 + retval = (AV*)sv_2mortal((SV*)newAV());
3072 + av_push(retval, newSVpv(stashname, 0)); /* add ourselves at the top */
3074 + gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
3075 + av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
3078 + HV* stored = (HV*)sv_2mortal((SV*)newHV());
3079 + svp = AvARRAY(av);
3080 + items = AvFILLp(av) + 1;
3082 + SV* const sv = *svp++;
3083 + HV* const basestash = gv_stashsv(sv, 0);
3086 + if(!hv_exists_ent(stored, sv, 0)) {
3087 + av_push(retval, newSVsv(sv));
3088 + hv_store_ent(stored, sv, &PL_sv_undef, 0);
3092 + subrv = (AV*)sv_2mortal((SV*)mro_linear_dfs(basestash, level + 1));
3093 + subrv_p = AvARRAY(subrv);
3094 + subrv_items = AvFILLp(subrv) + 1;
3095 + while(subrv_items--) {
3096 + SV* subsv = *subrv_p++;
3097 + if(!hv_exists_ent(stored, subsv, 0)) {
3098 + av_push(retval, newSVsv(subsv));
3099 + hv_store_ent(stored, subsv, &PL_sv_undef, 0);
3106 + SvREADONLY_on(retval);
3107 + SvREFCNT_inc_simple_void_NN(retval); /* for meta storage */
3108 + SvREFCNT_inc_simple_void_NN(retval); /* for return to caller */
3109 + meta->mro_linear_dfs = retval;
3114 +=for apidoc mro_linear_c3
3116 +Returns the C3 linearization of @ISA
3117 +the given stash. The return value is a read-only AV*.
3118 +C<level> should be 0 (it is used internally in this
3119 +function's recursion).
3125 +Perl_mro_linear_c3(pTHX_ HV* stash, I32 level)
3131 + const char* stashname;
3132 + STRLEN stashname_len;
3133 + struct mro_meta* meta;
3136 + assert(HvAUX(stash));
3138 + stashname = HvNAME_get(stash);
3139 + stashname_len = HvNAMELEN_get(stash);
3142 + "Can't linearize anonymous symbol table");
3145 + Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
3148 + meta = HvMROMETA(stash);
3149 + if((retval = meta->mro_linear_c3)) {
3150 + /* return cache if valid */
3151 + SvREFCNT_inc_simple_void_NN(retval);
3155 + /* not in cache, make a new one */
3157 + retval = (AV*)sv_2mortal((SV*)newAV());
3158 + av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
3160 + gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
3161 + isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
3163 + if(isa && AvFILLp(isa) >= 0) {
3166 + HV* tails = (HV*)sv_2mortal((SV*)newHV());
3167 + AV* seqs = (AV*)sv_2mortal((SV*)newAV());
3168 + I32 items = AvFILLp(isa) + 1;
3169 + SV** isa_ptr = AvARRAY(isa);
3172 + SV* isa_item = *isa_ptr++;
3173 + HV* isa_item_stash = gv_stashsv(isa_item, 0);
3174 + if(!isa_item_stash) {
3175 + isa_lin = newAV();
3176 + av_push(isa_lin, newSVsv(isa_item));
3179 + isa_lin = (AV*)sv_2mortal((SV*)mro_linear_c3(isa_item_stash, level + 1)); /* recursion */
3181 + av_push(seqs, (SV*)av_make(AvFILLp(isa_lin)+1, AvARRAY(isa_lin)));
3183 + av_push(seqs, (SV*)av_make(AvFILLp(isa)+1, AvARRAY(isa)));
3185 + seqs_ptr = AvARRAY(seqs);
3186 + seqs_items = AvFILLp(seqs) + 1;
3187 + while(seqs_items--) {
3188 + AV* seq = (AV*)*seqs_ptr++;
3189 + I32 seq_items = AvFILLp(seq);
3190 + if(seq_items > 0) {
3191 + SV** seq_ptr = AvARRAY(seq) + 1;
3192 + while(seq_items--) {
3193 + SV* seqitem = *seq_ptr++;
3194 + HE* he = hv_fetch_ent(tails, seqitem, 0, 0);
3196 + hv_store_ent(tails, seqitem, newSViv(1), 0);
3199 + SV* val = HeVAL(he);
3207 + SV* seqhead = NULL;
3209 + SV* winner = NULL;
3213 + SV** avptr = AvARRAY(seqs);
3214 + items = AvFILLp(seqs)+1;
3217 + seq = (AV*)*avptr++;
3218 + if(AvFILLp(seq) < 0) continue;
3219 + svp = av_fetch(seq, 0, 0);
3223 + if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
3224 + && (val = HeVAL(tail_entry))
3225 + && (SvIVx(val) > 0))
3227 + winner = newSVsv(cand);
3228 + av_push(retval, winner);
3230 + if(!sv_cmp(seqhead, winner)) {
3232 + /* this is basically shift(@seq) in void context */
3233 + SvREFCNT_dec(*AvARRAY(seq));
3234 + *AvARRAY(seq) = &PL_sv_undef;
3235 + AvARRAY(seq) = AvARRAY(seq) + 1;
3239 + if(AvFILLp(seq) < 0) continue;
3240 + svp = av_fetch(seq, 0, 0);
3242 + tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
3243 + val = HeVAL(tail_entry);
3249 + Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
3250 + "merging failed on parent '%"SVf"'", stashname, SVfARG(cand));
3254 + SvREADONLY_on(retval);
3255 + SvREFCNT_inc_simple_void_NN(retval); /* for meta storage */
3256 + SvREFCNT_inc_simple_void_NN(retval); /* for return to caller */
3257 + meta->mro_linear_c3 = retval;
3262 +=for apidoc mro_linear
3264 +Returns either C<mro_linear_c3> or C<mro_linear_dfs> for
3265 +the given stash, dependant upon which MRO is in effect
3266 +for that stash. The return value is a read-only AV*.
3271 +Perl_mro_linear(pTHX_ HV *stash)
3273 + struct mro_meta* meta;
3275 + assert(HvAUX(stash));
3277 + meta = HvMROMETA(stash);
3278 + if(meta->mro_which == MRO_DFS) {
3279 + return mro_linear_dfs(stash, 0);
3280 + } else if(meta->mro_which == MRO_C3) {
3281 + return mro_linear_c3(stash, 0);
3283 + Perl_croak(aTHX_ "Internal error: invalid MRO!");
3288 +=for apidoc mro_isa_changed_in
3290 +Takes the neccesary steps (cache invalidations, mostly)
3291 +when the @ISA of the given package has changed. Invoked
3292 +by the C<setisa> magic, should not need to invoke directly.
3297 +Perl_mro_isa_changed_in(pTHX_ HV* stash)
3305 + struct mro_meta* meta;
3308 + stashname = HvNAME_get(stash);
3310 + /* wipe out the cached linearizations for this stash */
3311 + meta = HvMROMETA(stash);
3312 + sv_2mortal((SV*)meta->mro_linear_dfs);
3313 + sv_2mortal((SV*)meta->mro_linear_c3);
3314 + meta->mro_linear_dfs = NULL;
3315 + meta->mro_linear_c3 = NULL;
3317 + /* Wipe the global method cache if this package
3318 + is UNIVERSAL or one of its parents */
3319 + if(meta->is_universal)
3320 + PL_sub_generation++;
3322 + /* Wipe the local method cache otherwise */
3324 + meta->sub_generation++;
3326 + /* wipe next::method cache too */
3327 + if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
3329 + /* Recalcs whichever of the above two cleared linearizations
3330 + are in effect and gives it to us */
3331 + linear_mro = mro_linear(stash);
3332 + isarev = meta->mro_isarev;
3334 + /* Iterate the isarev (classes that are our children),
3335 + wiping out their linearization and method caches */
3337 + hv_iterinit(isarev);
3338 + while((iter = hv_iternext(isarev))) {
3339 + SV* revkey = hv_iterkeysv(iter);
3340 + HV* revstash = gv_stashsv(revkey, 0);
3341 + struct mro_meta* revmeta = HvMROMETA(revstash);
3342 + sv_2mortal((SV*)revmeta->mro_linear_dfs);
3343 + sv_2mortal((SV*)revmeta->mro_linear_c3);
3344 + revmeta->mro_linear_dfs = NULL;
3345 + revmeta->mro_linear_c3 = NULL;
3346 + if(!meta->is_universal)
3347 + revmeta->sub_generation++;
3348 + if(revmeta->mro_nextmethod)
3349 + hv_clear(revmeta->mro_nextmethod);
3353 + /* we're starting at the 2nd element, skipping ourselves here */
3354 + svp = AvARRAY(linear_mro) + 1;
3355 + items = AvFILLp(linear_mro);
3357 + SV* const sv = *svp++;
3358 + struct mro_meta* mrometa;
3361 + HV* mrostash = gv_stashsv(sv, 0);
3363 + mrostash = gv_stashsv(sv, GV_ADD);
3365 + We created the package on the fly, so
3366 + that we could store isarev information.
3367 + This flag lets gv_fetchmeth know about it,
3368 + so that it can still generate the very useful
3369 + "Can't locate package Foo for @Bar::ISA" warning.
3371 + HvMROMETA(mrostash)->fake = 1;
3374 + mrometa = HvMROMETA(mrostash);
3375 + mroisarev = mrometa->mro_isarev;
3377 + /* is_universal is viral */
3378 + if(meta->is_universal)
3379 + mrometa->is_universal = 1;
3382 + mroisarev = mrometa->mro_isarev = newHV();
3384 + if(!hv_exists(mroisarev, stashname, strlen(stashname)))
3385 + hv_store(mroisarev, stashname, strlen(stashname), &PL_sv_yes, 0);
3388 + hv_iterinit(isarev);
3389 + while((iter = hv_iternext(isarev))) {
3390 + SV* revkey = hv_iterkeysv(iter);
3391 + if(!hv_exists_ent(mroisarev, revkey, 0))
3392 + hv_store_ent(mroisarev, revkey, &PL_sv_yes, 0);
3399 +=for apidoc mro_method_changed_in
3401 +Like C<mro_isa_changed_in>, but invalidates method
3402 +caching on any child classes of the given stash, so
3403 +that they might notice the changes in this one.
3405 +Ideally, all instances of C<PL_sub_generation++> in
3406 +the perl source should be replaced by calls to this.
3407 +Some already are, but some are more difficult to
3413 +Perl_mro_method_changed_in(pTHX_ HV *stash)
3415 + struct mro_meta* meta = HvMROMETA(stash);
3419 + /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
3420 + invalidate all method caches globally */
3421 + if(meta->is_universal) {
3422 + PL_sub_generation++;
3426 + /* else, invalidate the method caches of all child classes,
3428 + if((isarev = meta->mro_isarev)) {
3429 + hv_iterinit(isarev);
3430 + while((iter = hv_iternext(isarev))) {
3431 + SV* revkey = hv_iterkeysv(iter);
3432 + HV* revstash = gv_stashsv(revkey, 0);
3433 + struct mro_meta* mrometa = HvMROMETA(revstash);
3434 + mrometa->sub_generation++;
3435 + if(mrometa->mro_nextmethod)
3436 + hv_clear(mrometa->mro_nextmethod);
3441 +/* These two are static helpers for next::method and friends,
3442 + and re-implement a bunch of the code from pp_caller() in
3443 + a more efficient manner for this particular usage.
3447 +__dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
3449 + for (i = startingblock; i >= 0; i--) {
3450 + register const PERL_CONTEXT * const cx = &cxstk[i];
3451 + if(CxTYPE(cx) == CXt_SUB) {
3452 + DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
3460 +__nextcan(pTHX_ SV* self, I32 barf)
3462 + register I32 cxix = __dopoptosub_at(cxstack, cxstack_ix);
3463 + register const PERL_CONTEXT *cx;
3464 + register const PERL_CONTEXT *ccstack = cxstack;
3465 + const PERL_SI *top_si = PL_curstackinfo;
3469 + const char *fq_subname;
3470 + const char *subname;
3471 + STRLEN fq_subname_len;
3472 + STRLEN stashname_len;
3473 + STRLEN subname_len;
3480 + GV* candidate = NULL;
3481 + CV* cand_cv = NULL;
3482 + const char *hvname;
3484 + struct mro_meta* selfmeta;
3488 + if(sv_isobject(self))
3489 + selfstash = SvSTASH(SvRV(self));
3491 + selfstash = gv_stashsv(self, 0);
3493 + assert(selfstash);
3496 + /* we may be in a higher stacklevel, so dig down deeper */
3497 + while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
3498 + top_si = top_si->si_prev;
3499 + ccstack = top_si->si_cxstack;
3500 + cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
3504 + croak("next::method/next::can/maybe::next::method must be used in method context");
3507 + /* caller() should not report the automatic calls to &DB::sub */
3508 + if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
3511 + cx = &ccstack[cxix];
3512 + if(CxTYPE(cx) != CXt_SUB) {
3513 + cxix = __dopoptosub_at(ccstack, cxix - 1);
3518 + const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
3519 + /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
3520 + field below is defined for any cx. */
3521 + /* caller() should not report the automatic calls to &DB::sub */
3522 + if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
3523 + cx = &ccstack[dbcxix];
3524 + if(CxTYPE(cx) != CXt_SUB) {
3525 + cxix = __dopoptosub_at(ccstack, cxix - 1);
3531 + cvgv = CvGV(ccstack[cxix].blk_sub.cv);
3534 + cxix = __dopoptosub_at(ccstack, cxix - 1);
3538 + /* we found a real sub here */
3539 + sv = sv_2mortal(newSV(0));
3541 + gv_efullname3(sv, cvgv, NULL);
3543 + fq_subname = SvPVX(sv);
3544 + fq_subname_len = SvCUR(sv);
3546 + selfmeta = HvMROMETA(selfstash);
3547 + if(!(nmcache = selfmeta->mro_nextmethod)) {
3548 + nmcache = selfmeta->mro_nextmethod = newHV();
3551 + if((cache_entry = hv_fetch_ent(nmcache, sv, 0, 0))) {
3552 + return SvREFCNT_inc_simple_NN(HeVAL(cache_entry));
3555 + subname = strrchr(fq_subname, ':');
3557 + croak("next::method/next::can/maybe::next::method cannot find enclosing method");
3560 + subname_len = fq_subname_len - (subname - fq_subname);
3561 + if(subname_len == 8 && strEQ(subname, "__ANON__")) {
3562 + cxix = __dopoptosub_at(ccstack, cxix - 1);
3565 + stashname_len = subname - fq_subname - 2;
3566 + stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
3568 + hvname = HvNAME_get(selfstash);
3570 + croak("Can't use anonymous symbol table for method lookup");
3572 + linear_av = mro_linear_c3(selfstash, 0); /* has ourselves at the top of the list */
3573 + sv_2mortal((SV*)linear_av);
3575 + linear_svp = AvARRAY(linear_av);
3576 + items = AvFILLp(linear_av) + 1;
3579 + linear_sv = *linear_svp++;
3580 + assert(linear_sv);
3581 + if(sv_eq(linear_sv, stashname))
3585 + if(items < 0) goto no_next_method;
3588 + linear_sv = *linear_svp++;
3589 + assert(linear_sv);
3590 + curstash = gv_stashsv(linear_sv, FALSE);
3592 + if (!curstash || (HvMROMETA(curstash)->fake && !HvFILL(curstash))) {
3593 + if (ckWARN(WARN_MISC))
3594 + Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
3595 + (void*)linear_sv, hvname);
3601 + gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
3602 + if (!gvp) continue;
3605 + assert(candidate);
3607 + if (SvTYPE(candidate) != SVt_PVGV)
3608 + gv_init(candidate, curstash, subname, subname_len, TRUE);
3609 + if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
3610 + SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
3611 + hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
3612 + return (SV*)cand_cv;
3617 + hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
3618 + if(!barf) return &PL_sv_undef;
3619 + croak("No next::method '%s' found for %s", subname, hvname);
3625 +XS(XS_mro_get_linear_isa);
3626 +XS(XS_mro_set_mro);
3627 +XS(XS_mro_get_mro);
3628 +XS(XS_mro_get_global_sub_generation);
3629 +XS(XS_mro_invalidate_all_method_caches);
3630 +XS(XS_mro_get_sub_generation);
3631 +XS(XS_mro_invalidate_method_cache);
3633 +XS(XS_next_method);
3634 +XS(XS_maybe_next_method);
3637 +Perl_boot_core_mro(pTHX)
3640 + static const char file[] = __FILE__;
3642 + newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
3643 + newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
3644 + newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
3645 + newXSproto("mro::get_global_sub_generation", XS_mro_get_global_sub_generation, file, "");
3646 + newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_all_method_caches, file, "");
3647 + newXSproto("mro::get_sub_generation", XS_mro_get_sub_generation, file, "$");
3648 + newXSproto("mro::invalidate_method_cache", XS_mro_invalidate_method_cache, file, "$");
3649 + newXS("next::can", XS_next_can, file);
3650 + newXS("next::method", XS_next_method, file);
3651 + newXS("maybe::next::method", XS_maybe_next_method, file);
3654 +XS(XS_mro_get_linear_isa) {
3661 + if(items < 1 || items > 2)
3662 + croak("Usage: mro::get_linear_isa(classname [, type ])");
3664 + classname = ST(0);
3665 + class_stash = gv_stashsv(classname, 0);
3666 + if(!class_stash) croak("No such class: '%"SVf"'!", SVfARG(classname));
3669 + char* which = SvPV_nolen(ST(1));
3670 + if(strEQ(which, "dfs"))
3671 + RETVAL = mro_linear_dfs(class_stash, 0);
3672 + else if(strEQ(which, "c3"))
3673 + RETVAL = mro_linear_c3(class_stash, 0);
3675 + croak("Invalid mro name: '%s'", which);
3678 + RETVAL = mro_linear(class_stash);
3681 + ST(0) = newRV_noinc((SV*)RETVAL);
3682 + sv_2mortal(ST(0));
3694 + struct mro_meta* meta;
3697 + croak("Usage: mro::set_mro(classname, type)");
3699 + classname = ST(0);
3700 + whichstr = SvPV_nolen(ST(1));
3701 + class_stash = gv_stashsv(classname, GV_ADD);
3702 + if(!class_stash) croak("Cannot create class: '%"SVf"'!", SVfARG(classname));
3703 + meta = HvMROMETA(class_stash);
3705 + if(strEQ(whichstr, "dfs"))
3707 + else if(strEQ(whichstr, "c3"))
3710 + croak("Invalid mro name: '%s'", whichstr);
3712 + if(meta->mro_which != which) {
3713 + meta->mro_which = which;
3714 + /* Only affects local method cache, not
3715 + even child classes */
3716 + meta->sub_generation++;
3717 + if(meta->mro_nextmethod)
3718 + hv_clear(meta->mro_nextmethod);
3731 + struct mro_meta* meta;
3734 + croak("Usage: mro::get_mro(classname)");
3736 + classname = ST(0);
3737 + class_stash = gv_stashsv(classname, 0);
3738 + if(!class_stash) croak("No such class: '%"SVf"'!", SVfARG(classname));
3739 + meta = HvMROMETA(class_stash);
3741 + if(meta->mro_which == MRO_DFS)
3742 + ST(0) = sv_2mortal(newSVpvn("dfs", 3));
3744 + ST(0) = sv_2mortal(newSVpvn("c3", 2));
3749 +XS(XS_mro_get_global_sub_generation)
3755 + croak("Usage: mro::get_global_sub_generation()");
3757 + ST(0) = sv_2mortal(newSViv(PL_sub_generation));
3761 +XS(XS_mro_invalidate_all_method_caches)
3767 + croak("Usage: mro::invalidate_all_method_caches()");
3769 + PL_sub_generation++;
3774 +XS(XS_mro_get_sub_generation)
3782 + croak("Usage: mro::get_sub_generation(classname)");
3784 + classname = ST(0);
3785 + class_stash = gv_stashsv(classname, 0);
3786 + if(!class_stash) croak("No such class: '%"SVf"'!", SVfARG(classname));
3788 + ST(0) = sv_2mortal(newSViv(HvMROMETA(class_stash)->sub_generation));
3792 +XS(XS_mro_invalidate_method_cache)
3800 + croak("Usage: mro::invalidate_method_cache(classname)");
3802 + classname = ST(0);
3804 + class_stash = gv_stashsv(classname, 0);
3805 + if(!class_stash) croak("No such class: '%"SVf"'!", SVfARG(classname));
3807 + mro_method_changed_in(class_stash);
3817 + SV* methcv = __nextcan(self, 0);
3819 + PERL_UNUSED_VAR(items);
3821 + if(methcv == &PL_sv_undef) {
3822 + ST(0) = &PL_sv_undef;
3825 + ST(0) = sv_2mortal(newRV_inc(methcv));
3836 + SV* methcv = __nextcan(self, 1);
3838 + PL_markstack_ptr++;
3839 + call_sv(methcv, GIMME_V);
3842 +XS(XS_maybe_next_method)
3847 + SV* methcv = __nextcan(self, 0);
3849 + if(methcv == &PL_sv_undef) {
3850 + ST(0) = &PL_sv_undef;
3854 + PL_markstack_ptr++;
3855 + call_sv(methcv, GIMME_V);
3859 + * Local variables:
3860 + * c-indentation-style: bsd
3861 + * c-basic-offset: 4
3862 + * indent-tabs-mode: t
3865 + * ex: set ts=8 sts=4 sw=4 noet:
3868 ==================================================================
3869 --- hv.c (/local/perl-current) (revision 30412)
3870 +++ hv.c (/local/perl-c3-subg) (revision 30412)
3871 @@ -1531,7 +1531,7 @@
3874 if (val && isGV(val) && GvCVu(val) && HvNAME_get(hv))
3875 - PL_sub_generation++; /* may be deletion of method from stash */
3876 + mro_method_changed_in(hv); /* deletion of method from stash */
3878 if (HeKLEN(entry) == HEf_SVKEY) {
3879 SvREFCNT_dec(HeKEY_sv(entry));
3880 @@ -1726,6 +1726,7 @@
3884 + struct mro_meta *meta;
3885 struct xpvhv_aux *iter = HvAUX(hv);
3886 /* If there are weak references to this HV, we need to avoid
3887 freeing them up here. In particular we need to keep the AV
3888 @@ -1757,6 +1758,15 @@
3889 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
3890 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
3892 + if((meta = iter->xhv_mro_meta)) {
3893 + if(meta->mro_linear_dfs) SvREFCNT_dec(meta->mro_linear_dfs);
3894 + if(meta->mro_linear_c3) SvREFCNT_dec(meta->mro_linear_c3);
3895 + if(meta->mro_isarev) SvREFCNT_dec(meta->mro_isarev);
3896 + if(meta->mro_nextmethod) SvREFCNT_dec(meta->mro_nextmethod);
3898 + iter->xhv_mro_meta = NULL;
3901 /* There are now no allocated pointers in the aux structure. */
3903 SvFLAGS(hv) &= ~SVf_OOK; /* Goodbye, aux structure. */
3904 @@ -1878,6 +1888,7 @@
3905 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
3907 iter->xhv_backreferences = 0;
3908 + iter->xhv_mro_meta = NULL;
3913 ==================================================================
3914 --- hv.h (/local/perl-current) (revision 30412)
3915 +++ hv.h (/local/perl-c3-subg) (revision 30412)
3918 /* Subject to change.
3919 Don't access this directly.
3920 + Use the funcs in mro.c
3929 + AV *mro_linear_dfs; /* cached dfs @ISA linearization */
3930 + AV *mro_linear_c3; /* cached c3 @ISA linearization */
3931 + HV *mro_isarev; /* reverse @ISA dependencies (who depends on us?) */
3932 + HV *mro_nextmethod; /* next::method caching */
3933 + mro_alg mro_which; /* which mro alg is in use? */
3934 + U32 sub_generation; /* Like PL_sub_generation, but stash-local */
3935 + I32 is_universal; /* We are UNIVERSAL or a potentially indirect
3936 + member of @UNIVERSAL::ISA */
3937 + I32 fake; /* setisa made this fake package,
3938 + gv_fetchmeth pays attention to this,
3939 + and "package" sets it back to zero */
3942 +/* Subject to change.
3943 + Don't access this directly.
3947 HEK *xhv_name; /* name, if a symbol table */
3948 AV *xhv_backreferences; /* back references for weak references */
3949 HE *xhv_eiter; /* current entry of iterator */
3950 I32 xhv_riter; /* current root of iterator */
3951 + struct mro_meta *xhv_mro_meta;
3954 /* hash structure: */
3956 #define HvRITER_get(hv) (SvOOK(hv) ? HvAUX(hv)->xhv_riter : -1)
3957 #define HvEITER_get(hv) (SvOOK(hv) ? HvAUX(hv)->xhv_eiter : 0)
3958 #define HvNAME(hv) HvNAME_get(hv)
3959 +#define HvMROMETA(hv) (HvAUX(hv)->xhv_mro_meta ? HvAUX(hv)->xhv_mro_meta : mro_meta_init(hv))
3960 /* FIXME - all of these should use a UTF8 aware API, which should also involve
3961 getting the length. */
3962 /* This macro may go away without notice. */
3964 ==================================================================
3965 --- mg.c (/local/perl-current) (revision 30412)
3966 +++ mg.c (/local/perl-c3-subg) (revision 30412)
3967 @@ -1530,8 +1530,18 @@
3970 PERL_UNUSED_ARG(sv);
3971 - PERL_UNUSED_ARG(mg);
3972 - PL_sub_generation++;
3974 + /* The first case occurs via setisa,
3975 + the second via setisa_elem, which
3976 + calls this same magic */
3977 + mro_isa_changed_in(
3979 + SvTYPE(mg->mg_obj) == SVt_PVGV
3981 + : (GV*)SvMAGIC(mg->mg_obj)->mg_obj
3988 @@ -1541,7 +1551,6 @@
3990 PERL_UNUSED_ARG(sv);
3991 PERL_UNUSED_ARG(mg);
3992 - /* HV_badAMAGIC_on(Sv_STASH(sv)); */
3993 PL_amagic_generation++;
3997 ==================================================================
3998 --- op.c (/local/perl-current) (revision 30412)
3999 +++ op.c (/local/perl-c3-subg) (revision 30412)
4000 @@ -3648,6 +3648,11 @@
4001 save_item(PL_curstname);
4003 PL_curstash = gv_stashsv(sv, GV_ADD);
4005 + /* In case mg.c:Perl_magic_setisa faked
4006 + this package earlier, we clear the fake flag */
4007 + HvMROMETA(PL_curstash)->fake = 0;
4009 sv_setsv(PL_curstname, sv);
4011 PL_hints |= HINT_BLOCK_SCOPE;
4012 @@ -5290,9 +5295,9 @@
4013 sv_setpvn((SV*)gv, ps, ps_len);
4015 sv_setiv((SV*)gv, -1);
4017 SvREFCNT_dec(PL_compcv);
4018 cv = PL_compcv = NULL;
4019 - PL_sub_generation++;
4023 @@ -5386,7 +5391,13 @@
4025 cv = newCONSTSUB(NULL, name, const_sv);
4027 - PL_sub_generation++;
4028 + mro_method_changed_in( /* sub Foo::Bar () { 123 } */
4029 + (CvGV(cv) && GvSTASH(CvGV(cv)))
4030 + ? GvSTASH(CvGV(cv))
4038 @@ -5456,7 +5467,7 @@
4039 SvREFCNT_dec(PL_compcv);
4041 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4042 - ++PL_sub_generation;
4043 + ++PL_sub_generation; /* why? -- blblack */
4047 @@ -5469,7 +5480,7 @@
4051 - PL_sub_generation++;
4052 + mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
4056 @@ -5801,7 +5812,7 @@
4060 - PL_sub_generation++;
4061 + mro_method_changed_in(GvSTASH(gv)); /* newXS */
4066 ==================================================================
4067 --- sv.c (/local/perl-current) (revision 30412)
4068 +++ sv.c (/local/perl-c3-subg) (revision 30412)
4069 @@ -3245,7 +3245,7 @@
4070 SvREFCNT_dec(GvCV(dstr));
4072 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4073 - PL_sub_generation++;
4074 + mro_method_changed_in(GvSTASH(dstr));
4077 SAVEGENERICSV(*location);
4078 @@ -3291,7 +3291,7 @@
4080 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4081 GvASSUMECV_on(dstr);
4082 - PL_sub_generation++;
4083 + mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
4086 if (import_flag && !(GvFLAGS(dstr) & import_flag)
4088 ==================================================================
4089 --- pp_hot.c (/local/perl-current) (revision 30412)
4090 +++ pp_hot.c (/local/perl-c3-subg) (revision 30412)
4093 if (strEQ(GvNAME(right),"isa")) {
4095 - ++PL_sub_generation;
4096 + ++PL_sub_generation; /* I don't get this at all --blblack */
4099 SvSetMagicSV(right, left);
4100 @@ -3060,7 +3060,8 @@
4102 gv = (GV*)HeVAL(he);
4103 if (isGV(gv) && GvCV(gv) &&
4104 - (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
4105 + (!GvCVGEN(gv) || GvCVGEN(gv)
4106 + == (PL_sub_generation + HvMROMETA(stash)->sub_generation)))
4107 return (SV*)GvCV(gv);
4111 ==================================================================
4112 --- embed.fnc (/local/perl-current) (revision 30412)
4113 +++ embed.fnc (/local/perl-c3-subg) (revision 30412)
4114 @@ -282,6 +282,13 @@
4115 Ap |GV* |gv_fetchfile |NN const char* name
4116 Ap |GV* |gv_fetchfile_flags|NN const char *const name|const STRLEN len\
4118 +ApM |struct mro_meta* |mro_meta_init |NN HV* stash
4119 +ApM |AV* |mro_linear |NN HV* stash
4120 +ApM |AV* |mro_linear_c3 |NN HV* stash|I32 level
4121 +ApM |AV* |mro_linear_dfs |NN HV* stash|I32 level
4122 +ApM |void |mro_isa_changed_in|NN HV* stash
4123 +ApM |void |mro_method_changed_in |NN HV* stash
4124 +ApM |void |boot_core_mro
4125 Apd |GV* |gv_fetchmeth |NULLOK HV* stash|NN const char* name|STRLEN len|I32 level
4126 Apd |GV* |gv_fetchmeth_autoload |NULLOK HV* stash|NN const char* name|STRLEN len|I32 level
4127 Apdmb |GV* |gv_fetchmethod |NULLOK HV* stash|NN const char* name
4129 Property changes on:
4130 ___________________________________________________________________
4132 +bc823f99-e23a-42ae-8890-ba2193b93f74:/local/perl-c3:30402
4133 +bc823f99-e23a-42ae-8890-ba2193b93f74:/local/perl-c3-isarev:29720
4134 +bc823f99-e23a-42ae-8890-ba2193b93f74:/local/perl-current:30396