2 ==================================================================
3 --- Makefile.micro (/local/perl-current) (revision 30454)
4 +++ Makefile.micro (/local/perl-c3-subg) (revision 30454)
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 30454)
27 +++ embed.h (/local/perl-c3-subg) (revision 30454)
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_get_linear_isa Perl_mro_get_linear_isa
34 +#define mro_get_linear_isa_c3 Perl_mro_get_linear_isa_c3
35 +#define mro_get_linear_isa_dfs Perl_mro_get_linear_isa_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_get_linear_isa(a) Perl_mro_get_linear_isa(aTHX_ a)
48 +#define mro_get_linear_isa_c3(a,b) Perl_mro_get_linear_isa_c3(aTHX_ a,b)
49 +#define mro_get_linear_isa_dfs(a,b) Perl_mro_get_linear_isa_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 30454)
59 +++ pod/perlapi.pod (/local/perl-c3-subg) (revision 30454)
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 --- global.sym (/local/perl-current) (revision 30454)
72 +++ global.sym (/local/perl-c3-subg) (revision 30454)
76 Perl_gv_fetchfile_flags
78 +Perl_mro_get_linear_isa
79 +Perl_mro_get_linear_isa_c3
80 +Perl_mro_get_linear_isa_dfs
81 +Perl_mro_isa_changed_in
82 +Perl_mro_method_changed_in
85 Perl_gv_fetchmeth_autoload
88 ==================================================================
89 --- perl.c (/local/perl-current) (revision 30454)
90 +++ perl.c (/local/perl-c3-subg) (revision 30454)
93 boot_core_UNIVERSAL();
98 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
100 ==================================================================
101 --- universal.c (/local/perl-current) (revision 30454)
102 +++ universal.c (/local/perl-c3-subg) (revision 30454)
112 + AV* stash_linear_isa;
116 + PERL_UNUSED_ARG(len);
117 + PERL_UNUSED_ARG(level);
119 /* A stash/class can go by many names (ie. User == main::User), so
120 we compare the stash itself just in case */
122 if (strEQ(name, "UNIVERSAL"))
126 - Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
129 - gvp = (GV**)hv_fetchs(stash, "::ISA::CACHE::", FALSE);
131 - if (gvp && (gv = *gvp) && isGV_with_GP(gv) && (subgen = GvSV(gv))
132 - && (hv = GvHV(gv)))
134 - if (SvIV(subgen) == (IV)PL_sub_generation) {
135 - SV** const svp = (SV**)hv_fetch(hv, name, len, FALSE);
137 - SV * const sv = *svp;
139 - if (sv != &PL_sv_undef)
140 - DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
143 - return (sv == &PL_sv_yes);
145 + stash_linear_isa = (AV*)sv_2mortal((SV*)mro_get_linear_isa(stash));
146 + svp = AvARRAY(stash_linear_isa) + 1;
147 + items = AvFILLp(stash_linear_isa);
149 + SV* const basename_sv = *svp++;
150 + HV* basestash = gv_stashsv(basename_sv, 0);
152 + if (ckWARN(WARN_MISC))
153 + Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
154 + "Can't locate package %"SVf" for the parents of %s",
155 + SVfARG(basename_sv), hvname);
159 - DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
162 - sv_setiv(subgen, PL_sub_generation);
164 + if(name_stash == basestash || strEQ(name, SvPVX(basename_sv)))
168 - gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
170 - if (gvp && (gv = *gvp) && isGV_with_GP(gv) && (av = GvAV(gv))) {
171 - if (!hv || !subgen) {
172 - gvp = (GV**)hv_fetchs(stash, "::ISA::CACHE::", TRUE);
176 - if (SvTYPE(gv) != SVt_PVGV)
177 - gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
182 - subgen = newSViv(PL_sub_generation);
187 - SV** svp = AvARRAY(av);
188 - /* NOTE: No support for tied ISA */
189 - I32 items = AvFILLp(av) + 1;
191 - SV* const sv = *svp++;
192 - HV* const basestash = gv_stashsv(sv, 0);
194 - if (ckWARN(WARN_MISC))
195 - Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
196 - "Can't locate package %"SVf" for @%s::ISA",
197 - SVfARG(sv), hvname);
200 - if (isa_lookup(basestash, name, name_stash, len, level + 1)) {
201 - (void)hv_store(hv,name,len,&PL_sv_yes,0);
205 - (void)hv_store(hv,name,len,&PL_sv_no,0);
212 ==================================================================
213 --- scope.c (/local/perl-current) (revision 30454)
214 +++ scope.c (/local/perl-c3-subg) (revision 30454)
216 GP *gp = Perl_newGP(aTHX_ gv);
219 - PL_sub_generation++; /* taking a method out of circulation */
220 + mro_method_changed_in(GvSTASH(gv)); /* taking a method out of circulation ("local")*/
221 if (GvIOp(gv) && (IoFLAGS(GvIOp(gv)) & IOf_ARGV)) {
223 IoFLAGS(gp->gp_io) |= IOf_ARGV|IOf_START;
228 - PL_sub_generation++; /* putting a method back into circulation */
229 + mro_method_changed_in(GvSTASH(gv)); /* putting a method back into circulation ("local")*/
234 ==================================================================
235 --- gv.c (/local/perl-current) (revision 30454)
236 +++ gv.c (/local/perl-c3-subg) (revision 30454)
241 - PL_sub_generation++;
242 + mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub ASDF::baz($); *ASDF::baz = \&Foo::bar */
244 CvFILE_set_from_cop(GvCV(gv), PL_curcop);
245 CvSTASH(GvCV(gv)) = PL_curstash;
247 The argument C<level> should be either 0 or -1. If C<level==0>, as a
248 side-effect creates a glob with the given C<name> in the given C<stash>
249 which in the case of success contains an alias for the subroutine, and sets
250 -up caching info for this glob. Similarly for all the searched stashes.
251 +up caching info for this glob.
253 This function grants C<"SUPER"> token as a postfix of the stash name. The
254 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
255 @@ -321,133 +321,150 @@
259 +/* NOTE: No support for tied ISA */
262 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
274 + GV* candidate = NULL;
275 + CV* cand_cv = NULL;
279 - HV* lastchance = NULL;
280 + I32 create = (level >= 0) ? 1 : 0;
285 /* UNIVERSAL methods should be callable without a stash */
287 - level = -1; /* probably appropriate */
288 + create = 0; /* probably appropriate */
289 if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
295 hvname = HvNAME_get(stash);
298 - "Can't use anonymous symbol table for method lookup");
299 + Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
301 - if ((level > 100) || (level < -100))
302 - Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
308 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) );
310 - gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
313 + topgen_cmp = HvMROMETA(stash)->sub_generation + PL_sub_generation;
315 + /* check locally for a real method or a cache entry */
316 + gvp = (GV**)hv_fetch(stash, name, len, create);
320 + if (SvTYPE(topgv) != SVt_PVGV)
321 + gv_init(topgv, stash, name, len, TRUE);
322 + if ((cand_cv = GvCV(topgv))) {
323 + /* If genuine method or valid cache entry, use it */
324 + if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
328 + /* stale cache entry, junk it and move on */
329 + SvREFCNT_dec(cand_cv);
330 + GvCV(topgv) = cand_cv = NULL;
331 + GvCVGEN(topgv) = 0;
334 + else if (GvCVGEN(topgv) == topgen_cmp) {
335 + /* cache indicates no such method definitively */
340 + packlen = HvNAMELEN_get(stash);
341 + if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
344 + basestash = gv_stashpvn(hvname, packlen, GV_ADD);
345 + linear_av = mro_get_linear_isa(basestash);
349 - if (SvTYPE(topgv) != SVt_PVGV)
350 - gv_init(topgv, stash, name, len, TRUE);
351 - if ((cv = GvCV(topgv))) {
352 - /* If genuine method or valid cache entry, use it */
353 - if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
355 - /* Stale cached entry: junk it */
357 - GvCV(topgv) = cv = NULL;
358 - GvCVGEN(topgv) = 0;
360 - else if (GvCVGEN(topgv) == PL_sub_generation)
361 - return 0; /* cache indicates sub doesn't exist */
362 + linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
364 + sv_2mortal((SV*)linear_av);
366 - gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
367 - av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
368 + linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
369 + items = AvFILLp(linear_av); /* no +1, to skip over self */
371 + linear_sv = *linear_svp++;
373 + curstash = gv_stashsv(linear_sv, 0);
375 - /* create and re-create @.*::SUPER::ISA on demand */
376 - if (!av || !SvMAGIC(av)) {
377 - STRLEN packlen = HvNAMELEN_get(stash);
378 + /* mg.c:Perl_magic_setisa sets the fake flag on packages it had
379 + to create that the user did not. The "package" statement
380 + clears it. We also check if there's anything in the symbol
381 + table at all, which would indicate a previously "fake" package
382 + where someone adding things via $Foo::Bar = 1 without ever
383 + using a "package" statement.
384 + This was all neccesary because magic_setisa needs a place to
385 + keep isarev information on packages that aren't yet defined,
386 + yet we still need to issue this warning when appropriate.
388 + if (!curstash || (HvMROMETA(curstash)->fake && !HvFILL(curstash))) {
389 + if (ckWARN(WARN_MISC))
390 + Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
391 + SVfARG(linear_sv), hvname);
395 - if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
400 - basestash = gv_stashpvn(hvname, packlen, GV_ADD);
401 - gvp = (GV**)hv_fetchs(basestash, "ISA", FALSE);
402 - if (gvp && (gv = *gvp) && isGV_with_GP(gv) && (av = GvAV(gv))) {
403 - gvp = (GV**)hv_fetchs(stash, "ISA", TRUE);
404 - if (!gvp || !(gv = *gvp))
405 - Perl_croak(aTHX_ "Cannot create %s::ISA", hvname);
406 - if (SvTYPE(gv) != SVt_PVGV)
407 - gv_init(gv, stash, "ISA", 3, TRUE);
408 - SvREFCNT_dec(GvAV(gv));
409 - GvAV(gv) = (AV*)SvREFCNT_inc_simple(av);
412 + gvp = (GV**)hv_fetch(curstash, name, len, 0);
413 + if (!gvp) continue;
416 + if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, curstash, name, len, TRUE);
417 + if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
419 + * Found real method, cache method in topgv if:
420 + * 1. topgv has no synonyms (else inheritance crosses wires)
421 + * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
423 + if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
424 + if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv);
425 + SvREFCNT_inc_simple_void_NN(cand_cv);
426 + GvCV(topgv) = cand_cv;
427 + GvCVGEN(topgv) = topgen_cmp;
434 - SV** svp = AvARRAY(av);
435 - /* NOTE: No support for tied ISA */
436 - I32 items = AvFILLp(av) + 1;
438 - SV* const sv = *svp++;
439 - HV* const basestash = gv_stashsv(sv, 0);
441 - if (ckWARN(WARN_MISC))
442 - Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
443 - SVfARG(sv), hvname);
446 - gv = gv_fetchmeth(basestash, name, len,
447 - (level >= 0) ? level + 1 : level - 1);
451 + /* Check UNIVERSAL without caching */
452 + if(level == 0 || level == -1) {
453 + candidate = gv_fetchmeth(NULL, name, len, 1);
455 + cand_cv = GvCV(candidate);
456 + if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
457 + if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv);
458 + SvREFCNT_inc_simple_void_NN(cand_cv);
459 + GvCV(topgv) = cand_cv;
460 + GvCVGEN(topgv) = topgen_cmp;
466 - /* if at top level, try UNIVERSAL */
468 - if (level == 0 || level == -1) {
469 - lastchance = gv_stashpvs("UNIVERSAL", 0);
472 - if ((gv = gv_fetchmeth(lastchance, name, len,
473 - (level >= 0) ? level + 1 : level - 1)))
477 - * Cache method in topgv if:
478 - * 1. topgv has no synonyms (else inheritance crosses wires)
479 - * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
482 - GvREFCNT(topgv) == 1 &&
484 - (CvROOT(cv) || CvXSUB(cv)))
486 - if ((cv = GvCV(topgv)))
488 - GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
489 - GvCVGEN(topgv) = PL_sub_generation;
493 - else if (topgv && GvREFCNT(topgv) == 1) {
494 - /* cache the fact that the method is not defined */
495 - GvCVGEN(topgv) = PL_sub_generation;
498 + if (topgv && GvREFCNT(topgv) == 1) {
499 + /* cache the fact that the method is not defined */
500 + GvCVGEN(topgv) = topgen_cmp;
504 @@ -1436,15 +1453,22 @@
508 - /* multi-named GPs cannot be used for method cache */
509 + /* If the GP they asked for a reference to contains
510 + a method cache entry, clear it first, so that we
511 + don't infect them with our cached entry */
512 SvREFCNT_dec(gp->gp_cv);
517 - /* Adding a new name to a subroutine invalidates method cache */
518 - PL_sub_generation++;
520 + /* XXX if anyone finds a method cache regression with
521 + the "mro" stuff, turning this else block back on
522 + is probably the first place to look --blblack
526 + PL_sub_generation++;
532 @@ -1523,11 +1547,13 @@
534 MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
538 + newgen = PL_sub_generation + HvMROMETA(stash)->sub_generation;
540 const AMT * const amtp = (AMT*)mg->mg_ptr;
541 if (amtp->was_ok_am == PL_amagic_generation
542 - && amtp->was_ok_sub == PL_sub_generation) {
543 + && amtp->was_ok_sub == newgen) {
544 return (bool)AMT_OVERLOADED(amtp);
546 sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
547 @@ -1537,7 +1563,7 @@
550 amt.was_ok_am = PL_amagic_generation;
551 - amt.was_ok_sub = PL_sub_generation;
552 + amt.was_ok_sub = newgen;
553 amt.fallback = AMGfallNO;
556 @@ -1649,9 +1675,13 @@
562 if (!stash || !HvNAME_get(stash))
565 + newgen = PL_sub_generation + HvMROMETA(stash)->sub_generation;
567 mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
570 @@ -1661,7 +1691,7 @@
572 amtp = (AMT*)mg->mg_ptr;
573 if ( amtp->was_ok_am != PL_amagic_generation
574 - || amtp->was_ok_sub != PL_sub_generation )
575 + || amtp->was_ok_sub != newgen )
577 if (AMT_AMAGIC(amtp)) {
578 CV * const ret = amtp->table[id];
580 ==================================================================
581 --- lib/constant.pm (/local/perl-current) (revision 30454)
582 +++ lib/constant.pm (/local/perl-c3-subg) (revision 30454)
584 use warnings::register;
586 our($VERSION, %declared);
590 #=======================================================================
593 # constants from cv_const_sv are read only. So we have to:
594 Internals::SvREADONLY($scalar, 1);
595 $symtab->{$name} = \$scalar;
596 - &Internals::inc_sub_generation;
597 + mro::method_changed_in($pkg);
599 *$full_name = sub () { $scalar };
602 ==================================================================
603 --- lib/overload.pm (/local/perl-current) (revision 30454)
604 +++ lib/overload.pm (/local/perl-c3-subg) (revision 30454)
608 -our $VERSION = '1.04';
609 +our $VERSION = '1.05';
615 sub mycan { # Real can would leave stubs.
616 my ($package, $meth) = @_;
617 - return \*{$package . "::$meth"} if defined &{$package . "::$meth"};
619 - foreach $p (@{$package . "::ISA"}) {
620 - my $out = mycan($p, $meth);
621 - return $out if $out;
623 + my $mro = mro::get_linear_isa($package);
624 + foreach my $p (@$mro) {
625 + my $fqmeth = $p . q{::} . $meth;
626 + return \*{$fqmeth} if defined &{$fqmeth};
633 ==================================================================
634 --- lib/mro.pm (/local/perl-current) (revision 30454)
635 +++ lib/mro.pm (/local/perl-c3-subg) (revision 30454)
639 +# Copyright (c) 2007 Brandon L Black
641 +# You may distribute under the terms of either the GNU General Public
642 +# License or the Artistic License, as specified in the README file.
648 +our $VERSION = '0.01';
651 + mro::set_mro(scalar(caller), $_[1]) if $_[1];
660 +mro - Method Resolution Order
664 + use mro 'dfs'; # enable DFS mro for this class (Perl default)
665 + use mro 'c3'; # enable C3 mro for this class
669 +The "mro" namespace provides several utilities for dealing
670 +with method resolution order and method caching in general.
674 +One can change the mro of a given class by either C<use mro>
675 +as shown in the synopsis, or by using the L</mro::set_mro>
676 +function below. The functions below do not require that one
677 +loads the "mro" module, they are provided by the core. The
678 +C<use mro> syntax is just syntax sugar for setting the current
683 +In addition to the traditional Perl default MRO (depth first
684 +search, called C<dfs> here), Perl now offers the C3 MRO as
685 +well. Perl's support for C3 is based on the work done in
686 +Stevan Little's L<Class::C3>, and most of the C3-related
687 +documentation here is ripped directly from there.
691 +C3 is the name of an algorithm which aims to provide a sane method resolution order under multiple
692 +inheritence. It was first introduced in the langauge Dylan (see links in the L<SEE ALSO> section),
693 +and then later adopted as the prefered MRO (Method Resolution Order) for the new-style classes in
694 +Python 2.3. Most recently it has been adopted as the 'canonical' MRO for Perl 6 classes, and the
695 +default MRO for Parrot objects as well.
697 +=head2 How does C3 work.
699 +C3 works by always preserving local precendence ordering. This essentially means that no class will appear before any of it's subclasses. Take the classic diamond inheritence pattern for instance:
707 +The standard Perl 5 MRO would be (D, B, A, C). The result being that B<A> appears before B<C>, even though B<C> is the subclass of B<A>. The C3 MRO algorithm however, produces the following MRO (D, B, C, A), which does not have this same issue.
709 +This example is fairly trival, for more complex examples and a deeper explaination, see the links in the L<SEE ALSO - C3 Links> section.
713 +=head2 mro::get_linear_isa
715 +Arguments: classname[, type]
717 +Return an arrayref which is the linearized MRO of the given class.
718 +Uses whichever MRO is currently in effect for that class by default,
719 +or the given mro (either C<c3> or C<dfs> if specified as C<type>).
723 +Arguments: classname, type
725 +Sets the MRO of the given class to the C<type> argument (either
730 +Arguments: classname
732 +Returns the MRO of the given class (either C<c3> or C<dfs>)
734 +=head2 mro::get_global_sub_generation
738 +Returns the current value of C<PL_sub_generation>.
740 +=head2 mro::invalidate_all_method_caches
744 +Increments C<PL_sub_generation>, which invalidates method
745 +caching in all packages.
747 +=head2 mro::get_sub_generation
749 +Arguments: classname
751 +Returns the current value of a given package's C<sub_generation>.
752 +This is only incremented when necessary for that package.
754 +If one is trying to determine whether significant (method/cache-
755 +affecting) changes have occured for a given stash since you last
756 +checked, you should check both this and the global one above.
758 +=head2 mro::method_changed_in
760 +Arguments: classname
762 +Invalidates the method cache of any classes dependant on the
767 +This is somewhat like C<SUPER>, but it uses the C3 method
768 +resolution order to get better consistency in multiple
769 +inheritance situations. Note that while inheritance in
770 +general follows whichever MRO is in effect for the
771 +given class, C<next::method> only uses the C3 MRO.
773 +One generally uses it like so:
778 + my $superclass_answer = $self->next::method(@_);
779 + return $superclass_answer + 1;
782 +Note that you don't (re-)specify the method name.
783 +It forces you to always use the same method name
784 +as the method you started in.
786 +It can be called on an object or a class, of course.
788 +The way it resolves which actual method to call is:
790 +1) First, it determines the linearized C3 MRO of
791 +the object or class it is being called on.
793 +2) Then, it determines the class and method name
794 +of the context it was invoked from.
796 +3) Finally, it searches down the C3 MRO list until
797 +it reaches the contextually enclosing class, then
798 +searches further down the MRO list for the next
799 +method with the same name as the contextually
802 +Failure to find a next method will result in an
803 +exception being thrown (see below for alternatives).
805 +This is substantially different than the behavior
806 +of C<SUPER> under complex multiple inheritance,
807 +(this becomes obvious when one realizes that the
808 +common superclasses in the C3 linearizations of
809 +a given class and one of its parents will not
810 +always be ordered the same for both).
812 +Caveat - Calling C<next::method> from methods defined outside the class:
814 +There is an edge case when using C<next::method> from within a subroutine which was created in a different module than the one it is called from. It sounds complicated, but it really isn't. Here is an example which will not work correctly:
816 + *Foo::foo = sub { (shift)->next::method(@_) };
818 +The problem exists because the anonymous subroutine being assigned to the glob C<*Foo::foo> will show up in the call stack as being called C<__ANON__> and not C<foo> as you might expect. Since C<next::method> uses C<caller> to find the name of the method it was called in, it will fail in this case.
820 +But fear not, there is a simple solution. The module C<Sub::Name> will reach into the perl internals and assign a name to an anonymous subroutine for you. Simply do this:
822 + use Sub::Name 'subname';
823 + *Foo::foo = subname 'Foo::foo' => sub { (shift)->next::method(@_) };
825 +and things will Just Work.
829 +Like C<next::method>, but just returns either
830 +a code reference or C<undef> to indicate that
831 +no further methods of this name exist.
833 +=head2 maybe::next::method
835 +In simple cases it is equivalent to:
837 + $self->next::method(@_) if $self->next_can;
839 +But there are some cases where only this solution
840 +works (like "goto &maybe::next::method");
842 +=head1 SEE ALSO - C3 Links
844 +=head2 The original Dylan paper
848 +=item L<http://www.webcom.com/haahr/dylan/linearization-oopsla96.html>
852 +=head2 The prototype Perl 6 Object Model uses C3
856 +=item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel/>
860 +=head2 Parrot now uses C3
864 +=item L<http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631>
866 +=item L<http://use.perl.org/~autrijus/journal/25768>
870 +=head2 Python 2.3 MRO related links
874 +=item L<http://www.python.org/2.3/mro.html>
876 +=item L<http://www.python.org/2.2.2/descrintro.html#mro>
880 +=head2 C3 for TinyCLOS
884 +=item L<http://www.call-with-current-continuation.org/eggs/c3.html>
898 +Brandon L. Black, E<lt>blblack@gmail.comE<gt>
900 +Based on Stevan Little's L<Class::C3>
904 ==================================================================
905 --- win32/Makefile (/local/perl-current) (revision 30454)
906 +++ win32/Makefile (/local/perl-c3-subg) (revision 30454)
915 === win32/makefile.mk
916 ==================================================================
917 --- win32/makefile.mk (/local/perl-current) (revision 30454)
918 +++ win32/makefile.mk (/local/perl-c3-subg) (revision 30454)
927 === win32/Makefile.ce
928 ==================================================================
929 --- win32/Makefile.ce (/local/perl-current) (revision 30454)
930 +++ win32/Makefile.ce (/local/perl-c3-subg) (revision 30454)
941 $(DLLDIR)\globals.obj \
945 $(DLLDIR)\locale.obj \
946 $(DLLDIR)\mathoms.obj \
948 ==================================================================
949 --- t/TEST (/local/perl-current) (revision 30454)
950 +++ t/TEST (/local/perl-c3-subg) (revision 30454)
955 - foreach my $dir (qw(base comp cmd run io op uni)) {
956 + foreach my $dir (qw(base comp cmd run io op uni mro)) {
959 _find_tests("lib") unless $::core;
960 === t/mro (new directory)
961 ==================================================================
962 === t/mro/basic_01_dfs.t
963 ==================================================================
964 --- t/mro/basic_01_dfs.t (/local/perl-current) (revision 30454)
965 +++ t/mro/basic_01_dfs.t (/local/perl-c3-subg) (revision 30454)
972 + unless (-d 'blib') {
973 + chdir 't' if -d 't';
978 +use Test::More tests => 4;
982 +This tests the classic diamond inheritence pattern.
994 + sub hello { 'Diamond_A::hello' }
998 + use base 'Diamond_A';
1001 + package Diamond_C;
1002 + use base 'Diamond_A';
1004 + sub hello { 'Diamond_C::hello' }
1007 + package Diamond_D;
1008 + use base ('Diamond_B', 'Diamond_C');
1013 + mro::get_linear_isa('Diamond_D'),
1014 + [ qw(Diamond_D Diamond_B Diamond_A Diamond_C) ],
1015 + '... got the right MRO for Diamond_D');
1017 +is(Diamond_D->hello, 'Diamond_A::hello', '... method resolved itself as expected');
1018 +is(Diamond_D->can('hello')->(), 'Diamond_A::hello', '... can(method) resolved itself as expected');
1019 +is(UNIVERSAL::can("Diamond_D", 'hello')->(), 'Diamond_A::hello', '... can(method) resolved itself as expected');
1020 === t/mro/vulcan_c3.t
1021 ==================================================================
1022 --- t/mro/vulcan_c3.t (/local/perl-current) (revision 30454)
1023 +++ t/mro/vulcan_c3.t (/local/perl-c3-subg) (revision 30454)
1030 + unless (-d 'blib') {
1031 + chdir 't' if -d 't';
1036 +use Test::More tests => 1;
1041 +example taken from: L<http://gauss.gwydiondylan.org/books/drm/drm_50.html>
1052 + Intelligent Humanoid
1057 + define class <sentient> (<life-form>) end class;
1058 + define class <bipedal> (<life-form>) end class;
1059 + define class <intelligent> (<sentient>) end class;
1060 + define class <humanoid> (<bipedal>) end class;
1061 + define class <vulcan> (<intelligent>, <humanoid>) end class;
1071 + use base 'Object';
1075 + use base 'LifeForm';
1079 + use base 'LifeForm';
1081 + package Intelligent;
1083 + use base 'Sentient';
1087 + use base 'BiPedal';
1091 + use base ('Intelligent', 'Humanoid');
1095 + mro::get_linear_isa('Vulcan'),
1096 + [ qw(Vulcan Intelligent Sentient Humanoid BiPedal LifeForm Object) ],
1097 + '... got the right MRO for the Vulcan Dylan Example');
1098 === t/mro/basic_02_dfs.t
1099 ==================================================================
1100 --- t/mro/basic_02_dfs.t (/local/perl-current) (revision 30454)
1101 +++ t/mro/basic_02_dfs.t (/local/perl-c3-subg) (revision 30454)
1108 + unless (-d 'blib') {
1109 + chdir 't' if -d 't';
1114 +use Test::More tests => 10;
1118 +This example is take from: http://www.python.org/2.3/mro.html
1132 +Level 3 | O | (more general)
1138 +Level 2 3 | D | 4| E | | F | 5 |
1144 +Level 1 1 | B | | C | 2 |
1149 +Level 0 0 | A | (more specialized)
1160 + use base 'Test::O';
1163 + use base 'Test::O';
1166 + sub C_or_E { 'Test::E' }
1170 + use base 'Test::O';
1172 + sub C_or_D { 'Test::D' }
1175 + use base ('Test::D', 'Test::F');
1178 + sub C_or_D { 'Test::C' }
1179 + sub C_or_E { 'Test::C' }
1183 + use base ('Test::D', 'Test::E');
1186 + use base ('Test::B', 'Test::C');
1191 + mro::get_linear_isa('Test::F'),
1192 + [ qw(Test::F Test::O) ],
1193 + '... got the right MRO for Test::F');
1196 + mro::get_linear_isa('Test::E'),
1197 + [ qw(Test::E Test::O) ],
1198 + '... got the right MRO for Test::E');
1201 + mro::get_linear_isa('Test::D'),
1202 + [ qw(Test::D Test::O) ],
1203 + '... got the right MRO for Test::D');
1206 + mro::get_linear_isa('Test::C'),
1207 + [ qw(Test::C Test::D Test::O Test::F) ],
1208 + '... got the right MRO for Test::C');
1211 + mro::get_linear_isa('Test::B'),
1212 + [ qw(Test::B Test::D Test::O Test::E) ],
1213 + '... got the right MRO for Test::B');
1216 + mro::get_linear_isa('Test::A'),
1217 + [ qw(Test::A Test::B Test::D Test::O Test::E Test::C Test::F) ],
1218 + '... got the right MRO for Test::A');
1220 +is(Test::A->C_or_D, 'Test::D', '... got the expected method output');
1221 +is(Test::A->can('C_or_D')->(), 'Test::D', '... can got the expected method output');
1222 +is(Test::A->C_or_E, 'Test::E', '... got the expected method output');
1223 +is(Test::A->can('C_or_E')->(), 'Test::E', '... can got the expected method output');
1224 === t/mro/next_method.t
1225 ==================================================================
1226 --- t/mro/next_method.t (/local/perl-current) (revision 30454)
1227 +++ t/mro/next_method.t (/local/perl-c3-subg) (revision 30454)
1234 +use Test::More tests => 5;
1238 +This tests the classic diamond inheritence pattern.
1249 + package Diamond_A;
1251 + sub hello { 'Diamond_A::hello' }
1252 + sub foo { 'Diamond_A::foo' }
1255 + package Diamond_B;
1256 + use base 'Diamond_A';
1258 + sub foo { 'Diamond_B::foo => ' . (shift)->next::method() }
1261 + package Diamond_C;
1263 + use base 'Diamond_A';
1265 + sub hello { 'Diamond_C::hello => ' . (shift)->next::method() }
1266 + sub foo { 'Diamond_C::foo => ' . (shift)->next::method() }
1269 + package Diamond_D;
1270 + use base ('Diamond_B', 'Diamond_C');
1273 + sub foo { 'Diamond_D::foo => ' . (shift)->next::method() }
1277 + mro::get_linear_isa('Diamond_D'),
1278 + [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ],
1279 + '... got the right MRO for Diamond_D');
1281 +is(Diamond_D->hello, 'Diamond_C::hello => Diamond_A::hello', '... method resolved itself as expected');
1283 +is(Diamond_D->can('hello')->('Diamond_D'),
1284 + 'Diamond_C::hello => Diamond_A::hello',
1285 + '... can(method) resolved itself as expected');
1287 +is(UNIVERSAL::can("Diamond_D", 'hello')->('Diamond_D'),
1288 + 'Diamond_C::hello => Diamond_A::hello',
1289 + '... can(method) resolved itself as expected');
1292 + 'Diamond_D::foo => Diamond_B::foo => Diamond_C::foo => Diamond_A::foo',
1293 + '... method foo resolved itself as expected');
1294 === t/mro/basic_03_dfs.t
1295 ==================================================================
1296 --- t/mro/basic_03_dfs.t (/local/perl-current) (revision 30454)
1297 +++ t/mro/basic_03_dfs.t (/local/perl-c3-subg) (revision 30454)
1304 + unless (-d 'blib') {
1305 + chdir 't' if -d 't';
1310 +use Test::More tests => 4;
1314 +This example is take from: http://www.python.org/2.3/mro.html
1316 +"My second example"
1333 +Level 2 2 | E | 4 | D | | F | 5
1339 +Level 1 1 | B | | C | 3
1348 +(<class '__main__.A'>, <class '__main__.B'>, <class '__main__.E'>,
1349 +<class '__main__.C'>, <class '__main__.D'>, <class '__main__.F'>,
1358 + sub O_or_D { 'Test::O' }
1359 + sub O_or_F { 'Test::O' }
1362 + use base 'Test::O';
1365 + sub O_or_F { 'Test::F' }
1368 + use base 'Test::O';
1372 + use base 'Test::O';
1375 + sub O_or_D { 'Test::D' }
1376 + sub C_or_D { 'Test::D' }
1379 + use base ('Test::D', 'Test::F');
1382 + sub C_or_D { 'Test::C' }
1385 + use base ('Test::E', 'Test::D');
1389 + use base ('Test::B', 'Test::C');
1394 + mro::get_linear_isa('Test::A'),
1395 + [ qw(Test::A Test::B Test::E Test::O Test::D Test::C Test::F) ],
1396 + '... got the right MRO for Test::A');
1398 +is(Test::A->O_or_D, 'Test::O', '... got the right method dispatch');
1399 +is(Test::A->O_or_F, 'Test::O', '... got the right method dispatch');
1402 +# this test is particularly interesting because the p5 dispatch
1403 +# would actually call Test::D before Test::C and Test::D is a
1404 +# subclass of Test::C
1405 +is(Test::A->C_or_D, 'Test::D', '... got the right method dispatch');
1406 === t/mro/next_method_in_anon.t
1407 ==================================================================
1408 --- t/mro/next_method_in_anon.t (/local/perl-current) (revision 30454)
1409 +++ t/mro/next_method_in_anon.t (/local/perl-c3-subg) (revision 30454)
1416 +use Test::More tests => 2;
1420 +This tests the successful handling of a next::method call from within an
1421 +anonymous subroutine.
1445 + return 'B::foo => ' . (shift)->next::method();
1447 + return (shift)->$code;
1453 + return 'B::bar => ' . (shift)->next::method();
1455 + return (shift)->$code2;
1457 + return (shift)->$code1;
1461 +is(B->foo, "B::foo => A::foo",
1462 + 'method resolved inside anonymous sub');
1464 +is(B->bar, "B::bar => A::bar",
1465 + 'method resolved inside nested anonymous subs');
1468 === t/mro/basic_04_dfs.t
1469 ==================================================================
1470 --- t/mro/basic_04_dfs.t (/local/perl-current) (revision 30454)
1471 +++ t/mro/basic_04_dfs.t (/local/perl-c3-subg) (revision 30454)
1478 + unless (-d 'blib') {
1479 + chdir 't' if -d 't';
1484 +use Test::More tests => 1;
1488 +From the parrot test t/pmc/object-meths.t
1500 + package t::lib::A; use mro 'dfs';
1501 + package t::lib::B; use mro 'dfs';
1502 + package t::lib::E; use mro 'dfs';
1503 + package t::lib::C; use mro 'dfs'; use base ('t::lib::A', 't::lib::B');
1504 + package t::lib::D; use mro 'dfs'; use base ('t::lib::A', 't::lib::E');
1505 + package t::lib::F; use mro 'dfs'; use base ('t::lib::C', 't::lib::D');
1509 + mro::get_linear_isa('t::lib::F'),
1510 + [ qw(t::lib::F t::lib::C t::lib::A t::lib::B t::lib::D t::lib::E) ],
1511 + '... got the right MRO for t::lib::F');
1513 === t/mro/next_method_edge_cases.t
1514 ==================================================================
1515 --- t/mro/next_method_edge_cases.t (/local/perl-current) (revision 30454)
1516 +++ t/mro/next_method_edge_cases.t (/local/perl-c3-subg) (revision 30454)
1523 +use Test::More tests => 11;
1532 + sub new { bless {}, $_[0] }
1533 + sub bar { 'Foo::bar' }
1536 + # call the submethod in the direct instance
1538 + my $foo = Foo->new();
1539 + isa_ok($foo, 'Foo');
1541 + can_ok($foo, 'bar');
1542 + is($foo->bar(), 'Foo::bar', '... got the right return value');
1544 + # fail calling it from a subclass
1551 + our @ISA = ('Foo');
1554 + my $bar = Bar->new();
1555 + isa_ok($bar, 'Bar');
1556 + isa_ok($bar, 'Foo');
1558 + # test it working with with Sub::Name
1560 + eval 'use Sub::Name';
1561 + skip "Sub::Name is required for this test", 3 if $@;
1563 + my $m = sub { (shift)->next::method() };
1564 + Sub::Name::subname('Bar::bar', $m);
1567 + *{'Bar::bar'} = $m;
1570 + can_ok($bar, 'bar');
1571 + my $value = eval { $bar->bar() };
1572 + ok(!$@, '... calling bar() succedded') || diag $@;
1573 + is($value, 'Foo::bar', '... got the right return value too');
1576 + # test it failing without Sub::Name
1582 + our @ISA = ('Foo');
1585 + my $baz = Baz->new();
1586 + isa_ok($baz, 'Baz');
1587 + isa_ok($baz, 'Foo');
1590 + my $m = sub { (shift)->next::method() };
1593 + *{'Baz::bar'} = $m;
1596 + eval { $baz->bar() };
1597 + ok($@, '... calling bar() with next::method failed') || diag $@;
1600 === t/mro/basic_05_dfs.t
1601 ==================================================================
1602 --- t/mro/basic_05_dfs.t (/local/perl-current) (revision 30454)
1603 +++ t/mro/basic_05_dfs.t (/local/perl-c3-subg) (revision 30454)
1610 + unless (-d 'blib') {
1611 + chdir 't' if -d 't';
1616 +use Test::More tests => 2;
1620 +This tests a strange bug found by Matt S. Trout
1621 +while building DBIx::Class. Thanks Matt!!!!
1632 + package Diamond_A;
1635 + sub foo { 'Diamond_A::foo' }
1638 + package Diamond_B;
1639 + use base 'Diamond_A';
1642 + sub foo { 'Diamond_B::foo => ' . (shift)->SUPER::foo }
1645 + package Diamond_C;
1647 + use base 'Diamond_A';
1651 + package Diamond_D;
1652 + use base ('Diamond_C', 'Diamond_B');
1655 + sub foo { 'Diamond_D::foo => ' . (shift)->SUPER::foo }
1659 + mro::get_linear_isa('Diamond_D'),
1660 + [ qw(Diamond_D Diamond_C Diamond_A Diamond_B) ],
1661 + '... got the right MRO for Diamond_D');
1664 + 'Diamond_D::foo => Diamond_A::foo',
1665 + '... got the right next::method dispatch path');
1666 === t/mro/vulcan_dfs.t
1667 ==================================================================
1668 --- t/mro/vulcan_dfs.t (/local/perl-current) (revision 30454)
1669 +++ t/mro/vulcan_dfs.t (/local/perl-c3-subg) (revision 30454)
1676 + unless (-d 'blib') {
1677 + chdir 't' if -d 't';
1682 +use Test::More tests => 1;
1687 +example taken from: L<http://gauss.gwydiondylan.org/books/drm/drm_50.html>
1698 + Intelligent Humanoid
1703 + define class <sentient> (<life-form>) end class;
1704 + define class <bipedal> (<life-form>) end class;
1705 + define class <intelligent> (<sentient>) end class;
1706 + define class <humanoid> (<bipedal>) end class;
1707 + define class <vulcan> (<intelligent>, <humanoid>) end class;
1717 + use base 'Object';
1721 + use base 'LifeForm';
1725 + use base 'LifeForm';
1727 + package Intelligent;
1729 + use base 'Sentient';
1733 + use base 'BiPedal';
1737 + use base ('Intelligent', 'Humanoid');
1741 + mro::get_linear_isa('Vulcan'),
1742 + [ qw(Vulcan Intelligent Sentient LifeForm Object Humanoid BiPedal) ],
1743 + '... got the right MRO for the Vulcan Dylan Example');
1745 ==================================================================
1746 --- t/mro/dbic_c3.t (/local/perl-current) (revision 30454)
1747 +++ t/mro/dbic_c3.t (/local/perl-c3-subg) (revision 30454)
1754 + unless (-d 'blib') {
1755 + chdir 't' if -d 't';
1760 +use Test::More tests => 1;
1764 +This example is taken from the inheritance graph of DBIx::Class::Core in DBIx::Class v0.07002:
1765 +(No ASCII art this time, this graph is insane)
1767 +The xx:: prefixes are just to be sure these bogus declarations never stomp on real ones
1772 + package xx::DBIx::Class::Core; use mro 'c3';
1774 + xx::DBIx::Class::Serialize::Storable
1775 + xx::DBIx::Class::InflateColumn
1776 + xx::DBIx::Class::Relationship
1777 + xx::DBIx::Class::PK::Auto
1778 + xx::DBIx::Class::PK
1779 + xx::DBIx::Class::Row
1780 + xx::DBIx::Class::ResultSourceProxy::Table
1781 + xx::DBIx::Class::AccessorGroup
1784 + package xx::DBIx::Class::InflateColumn; use mro 'c3';
1785 + our @ISA = qw/ xx::DBIx::Class::Row /;
1787 + package xx::DBIx::Class::Row; use mro 'c3';
1788 + our @ISA = qw/ xx::DBIx::Class /;
1790 + package xx::DBIx::Class; use mro 'c3';
1792 + xx::DBIx::Class::Componentised
1793 + xx::Class::Data::Accessor
1796 + package xx::DBIx::Class::Relationship; use mro 'c3';
1798 + xx::DBIx::Class::Relationship::Helpers
1799 + xx::DBIx::Class::Relationship::Accessor
1800 + xx::DBIx::Class::Relationship::CascadeActions
1801 + xx::DBIx::Class::Relationship::ProxyMethods
1802 + xx::DBIx::Class::Relationship::Base
1806 + package xx::DBIx::Class::Relationship::Helpers; use mro 'c3';
1808 + xx::DBIx::Class::Relationship::HasMany
1809 + xx::DBIx::Class::Relationship::HasOne
1810 + xx::DBIx::Class::Relationship::BelongsTo
1811 + xx::DBIx::Class::Relationship::ManyToMany
1814 + package xx::DBIx::Class::Relationship::ProxyMethods; use mro 'c3';
1815 + our @ISA = qw/ xx::DBIx::Class /;
1817 + package xx::DBIx::Class::Relationship::Base; use mro 'c3';
1818 + our @ISA = qw/ xx::DBIx::Class /;
1820 + package xx::DBIx::Class::PK::Auto; use mro 'c3';
1821 + our @ISA = qw/ xx::DBIx::Class /;
1823 + package xx::DBIx::Class::PK; use mro 'c3';
1824 + our @ISA = qw/ xx::DBIx::Class::Row /;
1826 + package xx::DBIx::Class::ResultSourceProxy::Table; use mro 'c3';
1828 + xx::DBIx::Class::AccessorGroup
1829 + xx::DBIx::Class::ResultSourceProxy
1832 + package xx::DBIx::Class::ResultSourceProxy; use mro 'c3';
1833 + our @ISA = qw/ xx::DBIx::Class /;
1835 + package xx::Class::Data::Accessor; our @ISA = (); use mro 'c3';
1836 + package xx::DBIx::Class::Relationship::HasMany; our @ISA = (); use mro 'c3';
1837 + package xx::DBIx::Class::Relationship::HasOne; our @ISA = (); use mro 'c3';
1838 + package xx::DBIx::Class::Relationship::BelongsTo; our @ISA = (); use mro 'c3';
1839 + package xx::DBIx::Class::Relationship::ManyToMany; our @ISA = (); use mro 'c3';
1840 + package xx::DBIx::Class::Componentised; our @ISA = (); use mro 'c3';
1841 + package xx::DBIx::Class::AccessorGroup; our @ISA = (); use mro 'c3';
1842 + package xx::DBIx::Class::Serialize::Storable; our @ISA = (); use mro 'c3';
1843 + package xx::DBIx::Class::Relationship::Accessor; our @ISA = (); use mro 'c3';
1844 + package xx::DBIx::Class::Relationship::CascadeActions; our @ISA = (); use mro 'c3';
1848 + mro::get_linear_isa('xx::DBIx::Class::Core'),
1850 + xx::DBIx::Class::Core
1851 + xx::DBIx::Class::Serialize::Storable
1852 + xx::DBIx::Class::InflateColumn
1853 + xx::DBIx::Class::Relationship
1854 + xx::DBIx::Class::Relationship::Helpers
1855 + xx::DBIx::Class::Relationship::HasMany
1856 + xx::DBIx::Class::Relationship::HasOne
1857 + xx::DBIx::Class::Relationship::BelongsTo
1858 + xx::DBIx::Class::Relationship::ManyToMany
1859 + xx::DBIx::Class::Relationship::Accessor
1860 + xx::DBIx::Class::Relationship::CascadeActions
1861 + xx::DBIx::Class::Relationship::ProxyMethods
1862 + xx::DBIx::Class::Relationship::Base
1863 + xx::DBIx::Class::PK::Auto
1864 + xx::DBIx::Class::PK
1865 + xx::DBIx::Class::Row
1866 + xx::DBIx::Class::ResultSourceProxy::Table
1867 + xx::DBIx::Class::AccessorGroup
1868 + xx::DBIx::Class::ResultSourceProxy
1870 + xx::DBIx::Class::Componentised
1871 + xx::Class::Data::Accessor
1873 + '... got the right C3 merge order for xx::DBIx::Class::Core');
1874 === t/mro/next_method_used_with_NEXT.t
1875 ==================================================================
1876 --- t/mro/next_method_used_with_NEXT.t (/local/perl-current) (revision 30454)
1877 +++ t/mro/next_method_used_with_NEXT.t (/local/perl-c3-subg) (revision 30454)
1888 + plan skip_all => "NEXT required for this test" if $@;
1898 + sub foo { 'Foo::foo' }
1906 + sub foo { 'Fuz::foo => ' . (shift)->next::method }
1914 + sub foo { 'Bar::foo => ' . (shift)->next::method }
1919 + require NEXT; # load this as late as possible so we can catch the test skip
1921 + use base 'Bar', 'Fuz';
1923 + sub foo { 'Baz::foo => ' . (shift)->NEXT::foo }
1926 +is(Foo->foo, 'Foo::foo', '... got the right value from Foo->foo');
1927 +is(Fuz->foo, 'Fuz::foo => Foo::foo', '... got the right value from Fuz->foo');
1928 +is(Bar->foo, 'Bar::foo => Foo::foo', '... got the right value from Bar->foo');
1930 +is(Baz->foo, 'Baz::foo => Bar::foo => Fuz::foo => Foo::foo', '... got the right value using NEXT in a subclass of a C3 class');
1932 === t/mro/c3_with_overload.t
1933 ==================================================================
1934 --- t/mro/c3_with_overload.t (/local/perl-current) (revision 30454)
1935 +++ t/mro/c3_with_overload.t (/local/perl-c3-subg) (revision 30454)
1942 +use Test::More tests => 7;
1950 + package OverloadingTest;
1954 + use base 'BaseTest';
1955 + use overload '""' => sub { ref(shift) . " stringified" },
1958 + sub new { bless {} => shift }
1960 + package InheritingFromOverloadedTest;
1963 + use base 'OverloadingTest';
1967 +my $x = InheritingFromOverloadedTest->new();
1968 +isa_ok($x, 'InheritingFromOverloadedTest');
1970 +my $y = OverloadingTest->new();
1971 +isa_ok($y, 'OverloadingTest');
1973 +is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing');
1974 +is("$y", 'OverloadingTest stringified', '... got the right value when stringifing');
1976 +ok(($y eq 'OverloadingTest stringified'), '... eq was handled correctly');
1980 + $result = $x eq 'InheritingFromOverloadedTest stringified'
1982 +ok(!$@, '... this should not throw an exception');
1983 +ok($result, '... and we should get the true value');
1984 === t/mro/complex_c3.t
1985 ==================================================================
1986 --- t/mro/complex_c3.t (/local/perl-current) (revision 30454)
1987 +++ t/mro/complex_c3.t (/local/perl-c3-subg) (revision 30454)
1994 + unless (-d 'blib') {
1995 + chdir 't' if -d 't';
2000 +use Test::More tests => 12;
2004 +This example is taken from: http://rt.cpan.org/Public/Bug/Display.html?id=20879
2007 +Level 5 8 | A | 9 | B | A | C | (More General)
2019 +Level 3 4 | G | 6 | E | |
2024 +Level 2 3 | H | 5 | F | |
2032 +Level 1 1 | J | 2 | I | |
2037 +Level 0 0 | K | (More Specialized)
2047 + package Test::A; use mro 'c3';
2049 + package Test::B; use mro 'c3';
2051 + package Test::C; use mro 'c3';
2053 + package Test::D; use mro 'c3';
2054 + use base qw/Test::A Test::B Test::C/;
2056 + package Test::E; use mro 'c3';
2057 + use base qw/Test::D/;
2059 + package Test::F; use mro 'c3';
2060 + use base qw/Test::E/;
2061 + sub testmeth { "wrong" }
2063 + package Test::G; use mro 'c3';
2064 + use base qw/Test::D/;
2066 + package Test::H; use mro 'c3';
2067 + use base qw/Test::G/;
2069 + package Test::I; use mro 'c3';
2070 + use base qw/Test::H Test::F/;
2071 + sub testmeth { "right" }
2073 + package Test::J; use mro 'c3';
2074 + use base qw/Test::F/;
2076 + package Test::K; use mro 'c3';
2077 + use base qw/Test::J Test::I/;
2078 + sub testmeth { shift->next::method }
2082 + mro::get_linear_isa('Test::A'),
2084 + '... got the right C3 merge order for Test::A');
2087 + mro::get_linear_isa('Test::B'),
2089 + '... got the right C3 merge order for Test::B');
2092 + mro::get_linear_isa('Test::C'),
2094 + '... got the right C3 merge order for Test::C');
2097 + mro::get_linear_isa('Test::D'),
2098 + [ qw(Test::D Test::A Test::B Test::C) ],
2099 + '... got the right C3 merge order for Test::D');
2102 + mro::get_linear_isa('Test::E'),
2103 + [ qw(Test::E Test::D Test::A Test::B Test::C) ],
2104 + '... got the right C3 merge order for Test::E');
2107 + mro::get_linear_isa('Test::F'),
2108 + [ qw(Test::F Test::E Test::D Test::A Test::B Test::C) ],
2109 + '... got the right C3 merge order for Test::F');
2112 + mro::get_linear_isa('Test::G'),
2113 + [ qw(Test::G Test::D Test::A Test::B Test::C) ],
2114 + '... got the right C3 merge order for Test::G');
2117 + mro::get_linear_isa('Test::H'),
2118 + [ qw(Test::H Test::G Test::D Test::A Test::B Test::C) ],
2119 + '... got the right C3 merge order for Test::H');
2122 + mro::get_linear_isa('Test::I'),
2123 + [ qw(Test::I Test::H Test::G Test::F Test::E Test::D Test::A Test::B Test::C) ],
2124 + '... got the right C3 merge order for Test::I');
2127 + mro::get_linear_isa('Test::J'),
2128 + [ qw(Test::J Test::F Test::E Test::D Test::A Test::B Test::C) ],
2129 + '... got the right C3 merge order for Test::J');
2132 + mro::get_linear_isa('Test::K'),
2133 + [ qw(Test::K Test::J Test::I Test::H Test::G Test::F Test::E Test::D Test::A Test::B Test::C) ],
2134 + '... got the right C3 merge order for Test::K');
2136 +is(Test::K->testmeth(), "right", 'next::method working ok');
2137 === t/mro/method_caching.t
2138 ==================================================================
2139 --- t/mro/method_caching.t (/local/perl-current) (revision 30454)
2140 +++ t/mro/method_caching.t (/local/perl-c3-subg) (revision 30454)
2146 +no warnings 'redefine'; # we do a lot of this
2147 +no warnings 'prototype'; # we do a lot of this
2150 + unless (-d 'blib') {
2151 + chdir 't' if -d 't';
2159 + package MCTest::Base;
2160 + sub foo { return $_[1]+1 };
2163 + package MCTest::Derived;
2164 + our @ISA = qw/MCTest::Base/;
2167 +# These are various ways of re-defining MCTest::Base::foo and checking whether the method is cached when it shouldn't be
2169 + sub { eval 'sub MCTest::Base::foo { return $_[1]+2 }'; is(MCTest::Derived->foo(0), 2); },
2170 + sub { eval 'sub MCTest::Base::foo($) { return $_[1]+3 }'; is(MCTest::Derived->foo(0), 3); },
2171 + sub { eval 'sub MCTest::Base::foo($) { 4 }'; is(MCTest::Derived->foo(0), 4); },
2172 + sub { *MCTest::Base::foo = sub { $_[1]+5 }; is(MCTest::Derived->foo(0), 5); },
2173 + sub { local *MCTest::Base::foo = sub { $_[1]+6 }; is(MCTest::Derived->foo(0), 6); },
2174 + sub { is(MCTest::Derived->foo(0), 5); },
2175 + sub { sub FFF { $_[1]+9 }; local *MCTest::Base::foo = *FFF; is(MCTest::Derived->foo(0), 9); },
2176 + sub { is(MCTest::Derived->foo(0), 5); },
2177 + sub { *ASDF::asdf = sub { $_[1]+7 }; *MCTest::Base::foo = \&ASDF::asdf; is(MCTest::Derived->foo(0), 7); },
2178 + sub { *ASDF::asdf = sub { $_[1]+7 }; *MCTest::Base::foo = \&ASDF::asdf; is(MCTest::Derived->foo(0), 7); },
2179 + sub { undef *MCTest::Base::foo; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); },
2180 + sub { sub MCTest::Base::foo($); *MCTest::Base::foo = \&ASDF::asdf; is(MCTest::Derived->foo(0), 7); },
2181 + sub { *XYZ = sub { $_[1]+8 }; ${MCTest::Base::}{foo} = \&XYZ; is(MCTest::Derived->foo(0), 8); },
2184 +plan tests => scalar(@testsubs) + 1;
2186 +is(MCTest::Derived->foo(0), 1);
2187 +$_->() for (@testsubs);
2188 === t/mro/dbic_dfs.t
2189 ==================================================================
2190 --- t/mro/dbic_dfs.t (/local/perl-current) (revision 30454)
2191 +++ t/mro/dbic_dfs.t (/local/perl-c3-subg) (revision 30454)
2198 + unless (-d 'blib') {
2199 + chdir 't' if -d 't';
2204 +use Test::More tests => 1;
2208 +This example is taken from the inheritance graph of DBIx::Class::Core in DBIx::Class v0.07002:
2209 +(No ASCII art this time, this graph is insane)
2211 +The xx:: prefixes are just to be sure these bogus declarations never stomp on real ones
2216 + package xx::DBIx::Class::Core; use mro 'dfs';
2218 + xx::DBIx::Class::Serialize::Storable
2219 + xx::DBIx::Class::InflateColumn
2220 + xx::DBIx::Class::Relationship
2221 + xx::DBIx::Class::PK::Auto
2222 + xx::DBIx::Class::PK
2223 + xx::DBIx::Class::Row
2224 + xx::DBIx::Class::ResultSourceProxy::Table
2225 + xx::DBIx::Class::AccessorGroup
2228 + package xx::DBIx::Class::InflateColumn; use mro 'dfs';
2229 + our @ISA = qw/ xx::DBIx::Class::Row /;
2231 + package xx::DBIx::Class::Row; use mro 'dfs';
2232 + our @ISA = qw/ xx::DBIx::Class /;
2234 + package xx::DBIx::Class; use mro 'dfs';
2236 + xx::DBIx::Class::Componentised
2237 + xx::Class::Data::Accessor
2240 + package xx::DBIx::Class::Relationship; use mro 'dfs';
2242 + xx::DBIx::Class::Relationship::Helpers
2243 + xx::DBIx::Class::Relationship::Accessor
2244 + xx::DBIx::Class::Relationship::CascadeActions
2245 + xx::DBIx::Class::Relationship::ProxyMethods
2246 + xx::DBIx::Class::Relationship::Base
2250 + package xx::DBIx::Class::Relationship::Helpers; use mro 'dfs';
2252 + xx::DBIx::Class::Relationship::HasMany
2253 + xx::DBIx::Class::Relationship::HasOne
2254 + xx::DBIx::Class::Relationship::BelongsTo
2255 + xx::DBIx::Class::Relationship::ManyToMany
2258 + package xx::DBIx::Class::Relationship::ProxyMethods; use mro 'dfs';
2259 + our @ISA = qw/ xx::DBIx::Class /;
2261 + package xx::DBIx::Class::Relationship::Base; use mro 'dfs';
2262 + our @ISA = qw/ xx::DBIx::Class /;
2264 + package xx::DBIx::Class::PK::Auto; use mro 'dfs';
2265 + our @ISA = qw/ xx::DBIx::Class /;
2267 + package xx::DBIx::Class::PK; use mro 'dfs';
2268 + our @ISA = qw/ xx::DBIx::Class::Row /;
2270 + package xx::DBIx::Class::ResultSourceProxy::Table; use mro 'dfs';
2272 + xx::DBIx::Class::AccessorGroup
2273 + xx::DBIx::Class::ResultSourceProxy
2276 + package xx::DBIx::Class::ResultSourceProxy; use mro 'dfs';
2277 + our @ISA = qw/ xx::DBIx::Class /;
2279 + package xx::Class::Data::Accessor; our @ISA = (); use mro 'dfs';
2280 + package xx::DBIx::Class::Relationship::HasMany; our @ISA = (); use mro 'dfs';
2281 + package xx::DBIx::Class::Relationship::HasOne; our @ISA = (); use mro 'dfs';
2282 + package xx::DBIx::Class::Relationship::BelongsTo; our @ISA = (); use mro 'dfs';
2283 + package xx::DBIx::Class::Relationship::ManyToMany; our @ISA = (); use mro 'dfs';
2284 + package xx::DBIx::Class::Componentised; our @ISA = (); use mro 'dfs';
2285 + package xx::DBIx::Class::AccessorGroup; our @ISA = (); use mro 'dfs';
2286 + package xx::DBIx::Class::Serialize::Storable; our @ISA = (); use mro 'dfs';
2287 + package xx::DBIx::Class::Relationship::Accessor; our @ISA = (); use mro 'dfs';
2288 + package xx::DBIx::Class::Relationship::CascadeActions; our @ISA = (); use mro 'dfs';
2292 + mro::get_linear_isa('xx::DBIx::Class::Core'),
2294 + xx::DBIx::Class::Core
2295 + xx::DBIx::Class::Serialize::Storable
2296 + xx::DBIx::Class::InflateColumn
2297 + xx::DBIx::Class::Row
2299 + xx::DBIx::Class::Componentised
2300 + xx::Class::Data::Accessor
2301 + xx::DBIx::Class::Relationship
2302 + xx::DBIx::Class::Relationship::Helpers
2303 + xx::DBIx::Class::Relationship::HasMany
2304 + xx::DBIx::Class::Relationship::HasOne
2305 + xx::DBIx::Class::Relationship::BelongsTo
2306 + xx::DBIx::Class::Relationship::ManyToMany
2307 + xx::DBIx::Class::Relationship::Accessor
2308 + xx::DBIx::Class::Relationship::CascadeActions
2309 + xx::DBIx::Class::Relationship::ProxyMethods
2310 + xx::DBIx::Class::Relationship::Base
2311 + xx::DBIx::Class::PK::Auto
2312 + xx::DBIx::Class::PK
2313 + xx::DBIx::Class::ResultSourceProxy::Table
2314 + xx::DBIx::Class::AccessorGroup
2315 + xx::DBIx::Class::ResultSourceProxy
2317 + '... got the right DFS merge order for xx::DBIx::Class::Core');
2318 === t/mro/recursion_c3.t
2319 ==================================================================
2320 --- t/mro/recursion_c3.t (/local/perl-current) (revision 30454)
2321 +++ t/mro/recursion_c3.t (/local/perl-c3-subg) (revision 30454)
2328 + unless (-d 'blib') {
2329 + chdir 't' if -d 't';
2337 +plan skip_all => "Your system has no SIGALRM" if !exists $SIG{ALRM};
2342 +These are like the 010_complex_merge_classless test,
2343 +but an infinite loop has been made in the heirarchy,
2344 +to test that we can fail cleanly instead of going
2345 +into an infinite loop
2349 +# initial setup, everything sane
2352 + our @ISA = qw/J I/;
2356 + our @ISA = qw/H F/;
2366 + our @ISA = qw/A B C/;
2375 +# A series of 8 abberations that would cause infinite loops,
2376 +# each one undoing the work of the previous
2378 + sub { @E::ISA = qw/F/ },
2379 + sub { @E::ISA = qw/D/; @C::ISA = qw/F/ },
2380 + sub { @C::ISA = qw//; @A::ISA = qw/K/ },
2381 + sub { @A::ISA = qw//; @J::ISA = qw/F K/ },
2382 + sub { @J::ISA = qw/F/; @H::ISA = qw/K G/ },
2383 + sub { @H::ISA = qw/G/; @B::ISA = qw/B/ },
2384 + sub { @B::ISA = qw//; @K::ISA = qw/K J I/ },
2385 + sub { @K::ISA = qw/J I/; @D::ISA = qw/A H B C/ },
2388 +foreach my $loopy (@loopies) {
2390 + local $SIG{ALRM} = sub { die "ALRMTimeout" };
2393 + mro::get_linear_isa('K', 'c3');
2396 + if(my $err = $@) {
2397 + if($err =~ /ALRMTimeout/) {
2398 + ok(0, "Loop terminated by SIGALRM");
2400 + elsif($err =~ /Recursive inheritance detected/) {
2401 + ok(1, "Graceful exception thrown");
2404 + ok(0, "Unrecognized exception: $err");
2408 + ok(0, "Infinite loop apparently succeeded???");
2411 === t/mro/overload_c3.t
2412 ==================================================================
2413 --- t/mro/overload_c3.t (/local/perl-current) (revision 30454)
2414 +++ t/mro/overload_c3.t (/local/perl-c3-subg) (revision 30454)
2421 + unless (-d 'blib') {
2422 + chdir 't' if -d 't';
2427 +use Test::More tests => 7;
2435 + package OverloadingTest;
2439 + use base 'BaseTest';
2440 + use overload '""' => sub { ref(shift) . " stringified" },
2443 + sub new { bless {} => shift }
2445 + package InheritingFromOverloadedTest;
2448 + use base 'OverloadingTest';
2452 +my $x = InheritingFromOverloadedTest->new();
2453 +isa_ok($x, 'InheritingFromOverloadedTest');
2455 +my $y = OverloadingTest->new();
2456 +isa_ok($y, 'OverloadingTest');
2458 +is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing');
2459 +is("$y", 'OverloadingTest stringified', '... got the right value when stringifing');
2461 +ok(($y eq 'OverloadingTest stringified'), '... eq was handled correctly');
2465 + $result = $x eq 'InheritingFromOverloadedTest stringified'
2467 +ok(!$@, '... this should not throw an exception');
2468 +ok($result, '... and we should get the true value');
2470 === t/mro/complex_dfs.t
2471 ==================================================================
2472 --- t/mro/complex_dfs.t (/local/perl-current) (revision 30454)
2473 +++ t/mro/complex_dfs.t (/local/perl-c3-subg) (revision 30454)
2480 + unless (-d 'blib') {
2481 + chdir 't' if -d 't';
2486 +use Test::More tests => 11;
2490 +This example is taken from: http://rt.cpan.org/Public/Bug/Display.html?id=20879
2493 +Level 5 8 | A | 9 | B | A | C | (More General)
2505 +Level 3 4 | G | 6 | E | |
2510 +Level 2 3 | H | 5 | F | |
2518 +Level 1 1 | J | 2 | I | |
2523 +Level 0 0 | K | (More Specialized)
2533 + package Test::A; use mro 'dfs';
2535 + package Test::B; use mro 'dfs';
2537 + package Test::C; use mro 'dfs';
2539 + package Test::D; use mro 'dfs';
2540 + use base qw/Test::A Test::B Test::C/;
2542 + package Test::E; use mro 'dfs';
2543 + use base qw/Test::D/;
2545 + package Test::F; use mro 'dfs';
2546 + use base qw/Test::E/;
2548 + package Test::G; use mro 'dfs';
2549 + use base qw/Test::D/;
2551 + package Test::H; use mro 'dfs';
2552 + use base qw/Test::G/;
2554 + package Test::I; use mro 'dfs';
2555 + use base qw/Test::H Test::F/;
2557 + package Test::J; use mro 'dfs';
2558 + use base qw/Test::F/;
2560 + package Test::K; use mro 'dfs';
2561 + use base qw/Test::J Test::I/;
2565 + mro::get_linear_isa('Test::A'),
2567 + '... got the right DFS merge order for Test::A');
2570 + mro::get_linear_isa('Test::B'),
2572 + '... got the right DFS merge order for Test::B');
2575 + mro::get_linear_isa('Test::C'),
2577 + '... got the right DFS merge order for Test::C');
2580 + mro::get_linear_isa('Test::D'),
2581 + [ qw(Test::D Test::A Test::B Test::C) ],
2582 + '... got the right DFS merge order for Test::D');
2585 + mro::get_linear_isa('Test::E'),
2586 + [ qw(Test::E Test::D Test::A Test::B Test::C) ],
2587 + '... got the right DFS merge order for Test::E');
2590 + mro::get_linear_isa('Test::F'),
2591 + [ qw(Test::F Test::E Test::D Test::A Test::B Test::C) ],
2592 + '... got the right DFS merge order for Test::F');
2595 + mro::get_linear_isa('Test::G'),
2596 + [ qw(Test::G Test::D Test::A Test::B Test::C) ],
2597 + '... got the right DFS merge order for Test::G');
2600 + mro::get_linear_isa('Test::H'),
2601 + [ qw(Test::H Test::G Test::D Test::A Test::B Test::C) ],
2602 + '... got the right DFS merge order for Test::H');
2605 + mro::get_linear_isa('Test::I'),
2606 + [ qw(Test::I Test::H Test::G Test::D Test::A Test::B Test::C Test::F Test::E) ],
2607 + '... got the right DFS merge order for Test::I');
2610 + mro::get_linear_isa('Test::J'),
2611 + [ qw(Test::J Test::F Test::E Test::D Test::A Test::B Test::C) ],
2612 + '... got the right DFS merge order for Test::J');
2615 + mro::get_linear_isa('Test::K'),
2616 + [ qw(Test::K Test::J Test::F Test::E Test::D Test::A Test::B Test::C Test::I Test::H Test::G) ],
2617 + '... got the right DFS merge order for Test::K');
2618 === t/mro/next_method_skip.t
2619 ==================================================================
2620 --- t/mro/next_method_skip.t (/local/perl-current) (revision 30454)
2621 +++ t/mro/next_method_skip.t (/local/perl-c3-subg) (revision 30454)
2628 +use Test::More tests => 10;
2632 +This tests the classic diamond inheritence pattern.
2643 + package Diamond_A;
2645 + sub bar { 'Diamond_A::bar' }
2646 + sub baz { 'Diamond_A::baz' }
2649 + package Diamond_B;
2650 + use base 'Diamond_A';
2652 + sub baz { 'Diamond_B::baz => ' . (shift)->next::method() }
2655 + package Diamond_C;
2657 + use base 'Diamond_A';
2658 + sub foo { 'Diamond_C::foo' }
2659 + sub buz { 'Diamond_C::buz' }
2661 + sub woz { 'Diamond_C::woz' }
2662 + sub maybe { 'Diamond_C::maybe' }
2665 + package Diamond_D;
2666 + use base ('Diamond_B', 'Diamond_C');
2668 + sub foo { 'Diamond_D::foo => ' . (shift)->next::method() }
2669 + sub bar { 'Diamond_D::bar => ' . (shift)->next::method() }
2670 + sub buz { 'Diamond_D::buz => ' . (shift)->baz() }
2671 + sub fuz { 'Diamond_D::fuz => ' . (shift)->next::method() }
2673 + sub woz { 'Diamond_D::woz can => ' . ((shift)->next::can() ? 1 : 0) }
2674 + sub noz { 'Diamond_D::noz can => ' . ((shift)->next::can() ? 1 : 0) }
2676 + sub maybe { 'Diamond_D::maybe => ' . ((shift)->maybe::next::method() || 0) }
2677 + sub moybe { 'Diamond_D::moybe => ' . ((shift)->maybe::next::method() || 0) }
2682 + mro::get_linear_isa('Diamond_D'),
2683 + [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ],
2684 + '... got the right MRO for Diamond_D');
2686 +is(Diamond_D->foo, 'Diamond_D::foo => Diamond_C::foo', '... skipped B and went to C correctly');
2687 +is(Diamond_D->bar, 'Diamond_D::bar => Diamond_A::bar', '... skipped B & C and went to A correctly');
2688 +is(Diamond_D->baz, 'Diamond_B::baz => Diamond_A::baz', '... called B method, skipped C and went to A correctly');
2689 +is(Diamond_D->buz, 'Diamond_D::buz => Diamond_B::baz => Diamond_A::baz', '... called D method dispatched to , different method correctly');
2690 +eval { Diamond_D->fuz };
2691 +like($@, qr/^No next::method 'fuz' found for Diamond_D/, '... cannot re-dispatch to a method which is not there');
2693 +is(Diamond_D->woz, 'Diamond_D::woz can => 1', '... can re-dispatch figured out correctly');
2694 +is(Diamond_D->noz, 'Diamond_D::noz can => 0', '... cannot re-dispatch figured out correctly');
2696 +is(Diamond_D->maybe, 'Diamond_D::maybe => Diamond_C::maybe', '... redispatched D to C when it exists');
2697 +is(Diamond_D->moybe, 'Diamond_D::moybe => 0', '... quietly failed redispatch from D');
2698 === t/mro/inconsistent_c3.t
2699 ==================================================================
2700 --- t/mro/inconsistent_c3.t (/local/perl-current) (revision 30454)
2701 +++ t/mro/inconsistent_c3.t (/local/perl-c3-subg) (revision 30454)
2708 + unless (-d 'blib') {
2709 + chdir 't' if -d 't';
2714 +use Test::More tests => 1;
2718 +This example is take from: http://www.python.org/2.3/mro.html
2720 +"Serious order disagreement" # From Guido
2727 + class Z(A,B): pass #creates Z(A,B) in Python 2.2
2729 + pass # Z(A,B) cannot be created in Python 2.3
2739 + our @ISA = ('X', 'Y');
2742 + our @ISA = ('Y', 'X');
2745 + our @ISA = ('XY', 'YX');
2748 +eval { mro::get_linear_isa('Z', 'c3') };
2749 +like($@, qr/^Inconsistent /, '... got the right error with an inconsistent hierarchy');
2750 === t/mro/recursion_dfs.t
2751 ==================================================================
2752 --- t/mro/recursion_dfs.t (/local/perl-current) (revision 30454)
2753 +++ t/mro/recursion_dfs.t (/local/perl-c3-subg) (revision 30454)
2760 + unless (-d 'blib') {
2761 + chdir 't' if -d 't';
2769 +plan skip_all => "Your system has no SIGALRM" if !exists $SIG{ALRM};
2774 +These are like the 010_complex_merge_classless test,
2775 +but an infinite loop has been made in the heirarchy,
2776 +to test that we can fail cleanly instead of going
2777 +into an infinite loop
2781 +# initial setup, everything sane
2784 + our @ISA = qw/J I/;
2788 + our @ISA = qw/H F/;
2798 + our @ISA = qw/A B C/;
2807 +# A series of 8 abberations that would cause infinite loops,
2808 +# each one undoing the work of the previous
2810 + sub { @E::ISA = qw/F/ },
2811 + sub { @E::ISA = qw/D/; @C::ISA = qw/F/ },
2812 + sub { @C::ISA = qw//; @A::ISA = qw/K/ },
2813 + sub { @A::ISA = qw//; @J::ISA = qw/F K/ },
2814 + sub { @J::ISA = qw/F/; @H::ISA = qw/K G/ },
2815 + sub { @H::ISA = qw/G/; @B::ISA = qw/B/ },
2816 + sub { @B::ISA = qw//; @K::ISA = qw/K J I/ },
2817 + sub { @K::ISA = qw/J I/; @D::ISA = qw/A H B C/ },
2820 +foreach my $loopy (@loopies) {
2822 + local $SIG{ALRM} = sub { die "ALRMTimeout" };
2825 + mro::get_linear_isa('K', 'dfs');
2828 + if(my $err = $@) {
2829 + if($err =~ /ALRMTimeout/) {
2830 + ok(0, "Loop terminated by SIGALRM");
2832 + elsif($err =~ /Recursive inheritance detected/) {
2833 + ok(1, "Graceful exception thrown");
2836 + ok(0, "Unrecognized exception: $err");
2840 + ok(0, "Infinite loop apparently succeeded???");
2843 === t/mro/basic_01_c3.t
2844 ==================================================================
2845 --- t/mro/basic_01_c3.t (/local/perl-current) (revision 30454)
2846 +++ t/mro/basic_01_c3.t (/local/perl-c3-subg) (revision 30454)
2853 + unless (-d 'blib') {
2854 + chdir 't' if -d 't';
2859 +use Test::More tests => 4;
2863 +This tests the classic diamond inheritence pattern.
2874 + package Diamond_A;
2875 + sub hello { 'Diamond_A::hello' }
2878 + package Diamond_B;
2879 + use base 'Diamond_A';
2882 + package Diamond_C;
2883 + use base 'Diamond_A';
2885 + sub hello { 'Diamond_C::hello' }
2888 + package Diamond_D;
2889 + use base ('Diamond_B', 'Diamond_C');
2894 + mro::get_linear_isa('Diamond_D'),
2895 + [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ],
2896 + '... got the right MRO for Diamond_D');
2898 +is(Diamond_D->hello, 'Diamond_C::hello', '... method resolved itself as expected');
2899 +is(Diamond_D->can('hello')->(), 'Diamond_C::hello', '... can(method) resolved itself as expected');
2900 +is(UNIVERSAL::can("Diamond_D", 'hello')->(), 'Diamond_C::hello', '... can(method) resolved itself as expected');
2901 === t/mro/basic_02_c3.t
2902 ==================================================================
2903 --- t/mro/basic_02_c3.t (/local/perl-current) (revision 30454)
2904 +++ t/mro/basic_02_c3.t (/local/perl-c3-subg) (revision 30454)
2911 + unless (-d 'blib') {
2912 + chdir 't' if -d 't';
2917 +use Test::More tests => 10;
2921 +This example is take from: http://www.python.org/2.3/mro.html
2935 +Level 3 | O | (more general)
2941 +Level 2 3 | D | 4| E | | F | 5 |
2947 +Level 1 1 | B | | C | 2 |
2952 +Level 0 0 | A | (more specialized)
2963 + use base 'Test::O';
2966 + use base 'Test::O';
2969 + sub C_or_E { 'Test::E' }
2973 + use base 'Test::O';
2975 + sub C_or_D { 'Test::D' }
2978 + use base ('Test::D', 'Test::F');
2981 + sub C_or_D { 'Test::C' }
2982 + sub C_or_E { 'Test::C' }
2986 + use base ('Test::D', 'Test::E');
2989 + use base ('Test::B', 'Test::C');
2994 + mro::get_linear_isa('Test::F'),
2995 + [ qw(Test::F Test::O) ],
2996 + '... got the right MRO for Test::F');
2999 + mro::get_linear_isa('Test::E'),
3000 + [ qw(Test::E Test::O) ],
3001 + '... got the right MRO for Test::E');
3004 + mro::get_linear_isa('Test::D'),
3005 + [ qw(Test::D Test::O) ],
3006 + '... got the right MRO for Test::D');
3009 + mro::get_linear_isa('Test::C'),
3010 + [ qw(Test::C Test::D Test::F Test::O) ],
3011 + '... got the right MRO for Test::C');
3014 + mro::get_linear_isa('Test::B'),
3015 + [ qw(Test::B Test::D Test::E Test::O) ],
3016 + '... got the right MRO for Test::B');
3019 + mro::get_linear_isa('Test::A'),
3020 + [ qw(Test::A Test::B Test::C Test::D Test::E Test::F Test::O) ],
3021 + '... got the right MRO for Test::A');
3023 +is(Test::A->C_or_D, 'Test::C', '... got the expected method output');
3024 +is(Test::A->can('C_or_D')->(), 'Test::C', '... can got the expected method output');
3025 +is(Test::A->C_or_E, 'Test::C', '... got the expected method output');
3026 +is(Test::A->can('C_or_E')->(), 'Test::C', '... can got the expected method output');
3027 === t/mro/overload_dfs.t
3028 ==================================================================
3029 --- t/mro/overload_dfs.t (/local/perl-current) (revision 30454)
3030 +++ t/mro/overload_dfs.t (/local/perl-c3-subg) (revision 30454)
3037 + unless (-d 'blib') {
3038 + chdir 't' if -d 't';
3043 +use Test::More tests => 7;
3051 + package OverloadingTest;
3055 + use base 'BaseTest';
3056 + use overload '""' => sub { ref(shift) . " stringified" },
3059 + sub new { bless {} => shift }
3061 + package InheritingFromOverloadedTest;
3064 + use base 'OverloadingTest';
3068 +my $x = InheritingFromOverloadedTest->new();
3069 +isa_ok($x, 'InheritingFromOverloadedTest');
3071 +my $y = OverloadingTest->new();
3072 +isa_ok($y, 'OverloadingTest');
3074 +is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing');
3075 +is("$y", 'OverloadingTest stringified', '... got the right value when stringifing');
3077 +ok(($y eq 'OverloadingTest stringified'), '... eq was handled correctly');
3081 + $result = $x eq 'InheritingFromOverloadedTest stringified'
3083 +ok(!$@, '... this should not throw an exception');
3084 +ok($result, '... and we should get the true value');
3086 === t/mro/basic_03_c3.t
3087 ==================================================================
3088 --- t/mro/basic_03_c3.t (/local/perl-current) (revision 30454)
3089 +++ t/mro/basic_03_c3.t (/local/perl-c3-subg) (revision 30454)
3096 + unless (-d 'blib') {
3097 + chdir 't' if -d 't';
3102 +use Test::More tests => 4;
3106 +This example is take from: http://www.python.org/2.3/mro.html
3108 +"My second example"
3125 +Level 2 2 | E | 4 | D | | F | 5
3131 +Level 1 1 | B | | C | 3
3140 +(<class '__main__.A'>, <class '__main__.B'>, <class '__main__.E'>,
3141 +<class '__main__.C'>, <class '__main__.D'>, <class '__main__.F'>,
3150 + sub O_or_D { 'Test::O' }
3151 + sub O_or_F { 'Test::O' }
3154 + use base 'Test::O';
3157 + sub O_or_F { 'Test::F' }
3160 + use base 'Test::O';
3164 + use base 'Test::O';
3167 + sub O_or_D { 'Test::D' }
3168 + sub C_or_D { 'Test::D' }
3171 + use base ('Test::D', 'Test::F');
3174 + sub C_or_D { 'Test::C' }
3177 + use base ('Test::E', 'Test::D');
3181 + use base ('Test::B', 'Test::C');
3186 + mro::get_linear_isa('Test::A'),
3187 + [ qw(Test::A Test::B Test::E Test::C Test::D Test::F Test::O) ],
3188 + '... got the right MRO for Test::A');
3190 +is(Test::A->O_or_D, 'Test::D', '... got the right method dispatch');
3191 +is(Test::A->O_or_F, 'Test::F', '... got the right method dispatch');
3194 +# this test is particularly interesting because the p5 dispatch
3195 +# would actually call Test::D before Test::C and Test::D is a
3196 +# subclass of Test::C
3197 +is(Test::A->C_or_D, 'Test::C', '... got the right method dispatch');
3198 === t/mro/basic_04_c3.t
3199 ==================================================================
3200 --- t/mro/basic_04_c3.t (/local/perl-current) (revision 30454)
3201 +++ t/mro/basic_04_c3.t (/local/perl-c3-subg) (revision 30454)
3208 + unless (-d 'blib') {
3209 + chdir 't' if -d 't';
3214 +use Test::More tests => 1;
3218 +From the parrot test t/pmc/object-meths.t
3230 + package t::lib::A; use mro 'c3';
3231 + package t::lib::B; use mro 'c3';
3232 + package t::lib::E; use mro 'c3';
3233 + package t::lib::C; use mro 'c3'; use base ('t::lib::A', 't::lib::B');
3234 + package t::lib::D; use mro 'c3'; use base ('t::lib::A', 't::lib::E');
3235 + package t::lib::F; use mro 'c3'; use base ('t::lib::C', 't::lib::D');
3239 + mro::get_linear_isa('t::lib::F'),
3240 + [ qw(t::lib::F t::lib::C t::lib::D t::lib::A t::lib::B t::lib::E) ],
3241 + '... got the right MRO for t::lib::F');
3243 === t/mro/basic_05_c3.t
3244 ==================================================================
3245 --- t/mro/basic_05_c3.t (/local/perl-current) (revision 30454)
3246 +++ t/mro/basic_05_c3.t (/local/perl-c3-subg) (revision 30454)
3253 + unless (-d 'blib') {
3254 + chdir 't' if -d 't';
3259 +use Test::More tests => 2;
3263 +This tests a strange bug found by Matt S. Trout
3264 +while building DBIx::Class. Thanks Matt!!!!
3275 + package Diamond_A;
3278 + sub foo { 'Diamond_A::foo' }
3281 + package Diamond_B;
3282 + use base 'Diamond_A';
3285 + sub foo { 'Diamond_B::foo => ' . (shift)->SUPER::foo }
3288 + package Diamond_C;
3290 + use base 'Diamond_A';
3294 + package Diamond_D;
3295 + use base ('Diamond_C', 'Diamond_B');
3298 + sub foo { 'Diamond_D::foo => ' . (shift)->SUPER::foo }
3302 + mro::get_linear_isa('Diamond_D'),
3303 + [ qw(Diamond_D Diamond_C Diamond_B Diamond_A) ],
3304 + '... got the right MRO for Diamond_D');
3307 + 'Diamond_D::foo => Diamond_B::foo => Diamond_A::foo',
3308 + '... got the right next::method dispatch path');
3309 === t/mro/next_method_in_eval.t
3310 ==================================================================
3311 --- t/mro/next_method_in_eval.t (/local/perl-current) (revision 30454)
3312 +++ t/mro/next_method_in_eval.t (/local/perl-c3-subg) (revision 30454)
3319 +use Test::More tests => 1;
3323 +This tests the use of an eval{} block to wrap a next::method call.
3332 + die 'A::foo died';
3333 + return 'A::foo succeeded';
3344 + return 'B::foo => ' . (shift)->next::method();
3355 + 'method resolved inside eval{}');
3359 ==================================================================
3360 --- t/op/magic.t (/local/perl-current) (revision 30454)
3361 +++ t/op/magic.t (/local/perl-c3-subg) (revision 30454)
3362 @@ -440,7 +440,10 @@
3366 - eval { push @ISA, __PACKAGE__ };
3367 + # This used to be __PACKAGE__, but that causes recursive
3368 + # inheritance, which is detected earlier now and broke
3370 + eval { push @ISA, __FILE__ };
3371 ok( $@ eq '', 'Push a constant on a magic array');
3372 $@ and print "# $@";
3373 eval { %ENV = (PATH => __PACKAGE__) };
3374 === NetWare/Makefile
3375 ==================================================================
3376 --- NetWare/Makefile (/local/perl-current) (revision 30454)
3377 +++ NetWare/Makefile (/local/perl-c3-subg) (revision 30454)
3386 === vms/descrip_mms.template
3387 ==================================================================
3388 --- vms/descrip_mms.template (/local/perl-current) (revision 30454)
3389 +++ vms/descrip_mms.template (/local/perl-c3-subg) (revision 30454)
3390 @@ -279,13 +279,13 @@
3392 #### End of system configuration section. ####
3394 -c0 = $(MALLOC_C) $(SOCKC) av.c deb.c doio.c doop.c dump.c globals.c gv.c hv.c
3395 +c0 = $(MALLOC_C) $(SOCKC) av.c deb.c doio.c doop.c dump.c globals.c gv.c hv.c mro.c
3396 c1 = mg.c locale.c mathoms.c miniperlmain.c numeric.c op.c pad.c perl.c perlapi.c perlio.c
3397 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
3398 c3 = run.c scope.c sv.c taint.c toke.c universal.c utf8.c util.c vms.c xsutils.c
3399 c = $(c0) $(c1) $(c2) $(c3)
3401 -obj0 = $(MALLOC_O) $(SOCKO) av$(O) deb$(O) doio$(O) doop$(O) dump$(O)
3402 +obj0 = $(MALLOC_O) $(SOCKO) av$(O) deb$(O) doio$(O) doop$(O) dump$(O) mro$(O)
3403 obj1 = globals$(O) gv$(O) hv$(O) locale$(O) mathoms$(O) mg$(O) miniperlmain$(O) numeric$(O) op$(O) pad$(O)
3404 obj2 = perl$(O) perlapi$(O) perlio$(O) perly$(O) pp$(O) pp_ctl$(O) pp_hot$(O) reentr$(O)
3405 obj3 = pp_pack$(O) pp_sort$(O) pp_sys$(O) regcomp$(O) regexec$(O) run$(O) scope$(O) sv$(O) taint$(O) toke$(O)
3406 @@ -1619,6 +1619,8 @@
3407 $(CC) $(CORECFLAGS) $(MMS$SOURCE)
3409 $(CC) $(CORECFLAGS) $(MMS$SOURCE)
3410 +mro$(O) : mro.c $(h)
3411 + $(CC) $(CORECFLAGS) $(MMS$SOURCE)
3413 $(CC) $(CORECFLAGS) $(MMS$SOURCE)
3414 locale$(O) : locale.c $(h)
3416 ==================================================================
3417 --- Makefile.SH (/local/perl-current) (revision 30454)
3418 +++ Makefile.SH (/local/perl-c3-subg) (revision 30454)
3420 h5 = utf8.h warnings.h
3421 h = $(h1) $(h2) $(h3) $(h4) $(h5)
3423 -c1 = av.c scope.c op.c doop.c doio.c dump.c gv.c hv.c mg.c reentr.c perl.c
3424 +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
3425 c2 = perly.c pp.c pp_hot.c pp_ctl.c pp_sys.c regcomp.c regexec.c utf8.c sv.c
3426 c3 = taint.c toke.c util.c deb.c run.c universal.c xsutils.c pad.c globals.c
3427 c4 = perlio.c perlapi.c numeric.c mathoms.c locale.c pp_pack.c pp_sort.c
3430 c = $(c1) $(c2) $(c3) $(c4) $(c5) miniperlmain.c perlmain.c opmini.c
3432 -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)
3433 +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)
3434 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)
3435 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)
3438 ==================================================================
3439 --- proto.h (/local/perl-current) (revision 30454)
3440 +++ proto.h (/local/perl-c3-subg) (revision 30454)
3441 @@ -635,6 +635,25 @@
3442 PERL_CALLCONV GV* Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN len, const U32 flags)
3443 __attribute__nonnull__(pTHX_1);
3445 +PERL_CALLCONV struct mro_meta* Perl_mro_meta_init(pTHX_ HV* stash)
3446 + __attribute__nonnull__(pTHX_1);
3448 +PERL_CALLCONV AV* Perl_mro_get_linear_isa(pTHX_ HV* stash)
3449 + __attribute__nonnull__(pTHX_1);
3451 +PERL_CALLCONV AV* Perl_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level)
3452 + __attribute__nonnull__(pTHX_1);
3454 +PERL_CALLCONV AV* Perl_mro_get_linear_isa_dfs(pTHX_ HV* stash, I32 level)
3455 + __attribute__nonnull__(pTHX_1);
3457 +PERL_CALLCONV void Perl_mro_isa_changed_in(pTHX_ HV* stash)
3458 + __attribute__nonnull__(pTHX_1);
3460 +PERL_CALLCONV void Perl_mro_method_changed_in(pTHX_ HV* stash)
3461 + __attribute__nonnull__(pTHX_1);
3463 +PERL_CALLCONV void Perl_boot_core_mro(pTHX);
3464 PERL_CALLCONV GV* Perl_gv_fetchmeth(pTHX_ HV* stash, const char* name, STRLEN len, I32 level)
3465 __attribute__nonnull__(pTHX_2);
3468 ==================================================================
3469 --- ext/B/t/b.t (/local/perl-current) (revision 30454)
3470 +++ ext/B/t/b.t (/local/perl-c3-subg) (revision 30454)
3474 my $sg = B::sub_generation();
3475 - *Whatever::hand_waving = sub { };
3476 + *UNIVERSAL::hand_waving = sub { };
3477 ok( $sg < B::sub_generation, "sub_generation increments" );
3481 ==================================================================
3482 --- MANIFEST (/local/perl-current) (revision 30454)
3483 +++ MANIFEST (/local/perl-c3-subg) (revision 30454)
3484 @@ -2252,6 +2252,7 @@
3485 lib/Module/Pluggable/t/lib/OddTest/Plugin/-Dodgy.pm Module::Pluggable tests
3486 lib/Module/Pluggable/t/lib/OddTest/Plugin/Foo.pm Module::Pluggable tests
3487 lib/Module/Pluggable/t/lib/TA/C/A/I.pm Module::Pluggable tests
3488 +lib/mro.pm mro extension
3489 lib/Net/Changes.libnet libnet
3490 lib/Net/Cmd.pm libnet
3491 lib/Net/Config.eg libnet
3492 @@ -2953,6 +2954,7 @@
3493 mpeix/mpeix_setjmp.c MPE/iX port
3494 mpeix/nm MPE/iX port
3495 mpeix/relink MPE/iX port
3496 +mro.c Method Resolution Order code
3497 myconfig.SH Prints summary of the current configuration
3498 NetWare/bat/Buildtype.bat NetWare port
3499 NetWare/bat/SetCodeWar.bat NetWare port
3500 @@ -3619,6 +3621,35 @@
3501 t/lib/warnings/universal Tests for universal.c for warnings.t
3502 t/lib/warnings/utf8 Tests for utf8.c for warnings.t
3503 t/lib/warnings/util Tests for util.c for warnings.t
3504 +t/mro/basic_01_c3.t mro tests
3505 +t/mro/basic_01_dfs.t mro tests
3506 +t/mro/basic_02_c3.t mro tests
3507 +t/mro/basic_02_dfs.t mro tests
3508 +t/mro/basic_03_c3.t mro tests
3509 +t/mro/basic_03_dfs.t mro tests
3510 +t/mro/basic_04_c3.t mro tests
3511 +t/mro/basic_04_dfs.t mro tests
3512 +t/mro/basic_05_c3.t mro tests
3513 +t/mro/basic_05_dfs.t mro tests
3514 +t/mro/c3_with_overload.t mro tests
3515 +t/mro/complex_c3.t mro tests
3516 +t/mro/complex_dfs.t mro tests
3517 +t/mro/dbic_c3.t mro tests
3518 +t/mro/dbic_dfs.t mro tests
3519 +t/mro/inconsistent_c3.t mro tests
3520 +t/mro/next_method.t mro tests
3521 +t/mro/next_method_edge_cases.t mro tests
3522 +t/mro/next_method_in_anon.t mro tests
3523 +t/mro/next_method_in_eval.t mro tests
3524 +t/mro/next_method_skip.t mro tests
3525 +t/mro/next_method_used_with_NEXT.t mro tests
3526 +t/mro/overload_c3.t mro tests
3527 +t/mro/overload_dfs.t mro tests
3528 +t/mro/recursion_c3.t mro tests
3529 +t/mro/recursion_dfs.t mro tests
3530 +t/mro/vulcan_c3.t mro tests
3531 +t/mro/vulcan_dfs.t mro tests
3532 +t/mro/method_caching.t mro tests
3533 Todo.micro The Wishlist for microperl
3535 t/op/64bitint.t See if 64 bit integers work
3537 ==================================================================
3538 --- mro.c (/local/perl-current) (revision 30454)
3539 +++ mro.c (/local/perl-c3-subg) (revision 30454)
3543 + * Copyright (c) 2007 Brandon L Black
3545 + * You may distribute under the terms of either the GNU General Public
3546 + * License or the Artistic License, as specified in the README file.
3551 +=head1 MRO Functions
3553 +These functions are related to the method resolution order of perl classes
3558 +#include "EXTERN.h"
3562 +Perl_mro_meta_init(pTHX_ HV* stash)
3567 + assert(HvAUX(stash));
3568 + assert(!(HvAUX(stash)->xhv_mro_meta));
3569 + Newxz(newmeta, sizeof(struct mro_meta), char);
3570 + HvAUX(stash)->xhv_mro_meta = (struct mro_meta*)newmeta;
3571 + ((struct mro_meta*)newmeta)->sub_generation = 1;
3573 + /* Manually flag UNIVERSAL as being universal.
3574 + This happens early in perl booting (when universal.c
3575 + does the newXS calls for UNIVERSAL::*), and infects
3576 + other packages as they are added to UNIVERSAL's MRO
3578 + if(HvNAMELEN_get(stash) == 9
3579 + && strEQ(HEK_KEY(HvAUX(stash)->xhv_name), "UNIVERSAL")) {
3580 + HvMROMETA(stash)->is_universal = 1;
3587 +=for apidoc mro_get_linear_isa_dfs
3589 +Returns the Depth-First Search linearization of @ISA
3590 +the given stash. The return value is a read-only AV*.
3591 +C<level> should be 0 (it is used internally in this
3592 +function's recursion).
3597 +Perl_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level)
3608 + const char* stashname;
3609 + struct mro_meta* meta;
3612 + assert(HvAUX(stash));
3614 + stashname = HvNAME_get(stash);
3617 + "Can't linearize anonymous symbol table");
3620 + Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
3623 + meta = HvMROMETA(stash);
3624 + if((retval = meta->mro_linear_dfs)) {
3625 + /* return cache if valid */
3626 + SvREFCNT_inc_simple_void_NN(retval);
3630 + /* not in cache, make a new one */
3631 + retval = (AV*)sv_2mortal((SV*)newAV());
3632 + av_push(retval, newSVpv(stashname, 0)); /* add ourselves at the top */
3634 + gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
3635 + av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
3638 + HV* stored = (HV*)sv_2mortal((SV*)newHV());
3639 + svp = AvARRAY(av);
3640 + items = AvFILLp(av) + 1;
3642 + SV* const sv = *svp++;
3643 + HV* const basestash = gv_stashsv(sv, 0);
3646 + if(!hv_exists_ent(stored, sv, 0)) {
3647 + av_push(retval, newSVsv(sv));
3648 + hv_store_ent(stored, sv, &PL_sv_undef, 0);
3652 + subrv = (AV*)sv_2mortal((SV*)mro_get_linear_isa_dfs(basestash, level + 1));
3653 + subrv_p = AvARRAY(subrv);
3654 + subrv_items = AvFILLp(subrv) + 1;
3655 + while(subrv_items--) {
3656 + SV* subsv = *subrv_p++;
3657 + if(!hv_exists_ent(stored, subsv, 0)) {
3658 + av_push(retval, newSVsv(subsv));
3659 + hv_store_ent(stored, subsv, &PL_sv_undef, 0);
3666 + SvREADONLY_on(retval);
3667 + SvREFCNT_inc_simple_void_NN(retval); /* for meta storage */
3668 + SvREFCNT_inc_simple_void_NN(retval); /* for return to caller */
3669 + meta->mro_linear_dfs = retval;
3674 +=for apidoc mro_get_linear_isa_c3
3676 +Returns the C3 linearization of @ISA
3677 +the given stash. The return value is a read-only AV*.
3678 +C<level> should be 0 (it is used internally in this
3679 +function's recursion).
3685 +Perl_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level)
3691 + const char* stashname;
3692 + STRLEN stashname_len;
3693 + struct mro_meta* meta;
3696 + assert(HvAUX(stash));
3698 + stashname = HvNAME_get(stash);
3699 + stashname_len = HvNAMELEN_get(stash);
3702 + "Can't linearize anonymous symbol table");
3705 + Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
3708 + meta = HvMROMETA(stash);
3709 + if((retval = meta->mro_linear_c3)) {
3710 + /* return cache if valid */
3711 + SvREFCNT_inc_simple_void_NN(retval);
3715 + /* not in cache, make a new one */
3717 + retval = (AV*)sv_2mortal((SV*)newAV());
3718 + av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
3720 + gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
3721 + isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
3723 + if(isa && AvFILLp(isa) >= 0) {
3726 + HV* tails = (HV*)sv_2mortal((SV*)newHV());
3727 + AV* seqs = (AV*)sv_2mortal((SV*)newAV());
3728 + I32 items = AvFILLp(isa) + 1;
3729 + SV** isa_ptr = AvARRAY(isa);
3732 + SV* isa_item = *isa_ptr++;
3733 + HV* isa_item_stash = gv_stashsv(isa_item, 0);
3734 + if(!isa_item_stash) {
3735 + isa_lin = newAV();
3736 + av_push(isa_lin, newSVsv(isa_item));
3739 + isa_lin = (AV*)sv_2mortal((SV*)mro_get_linear_isa_c3(isa_item_stash, level + 1)); /* recursion */
3741 + av_push(seqs, (SV*)av_make(AvFILLp(isa_lin)+1, AvARRAY(isa_lin)));
3743 + av_push(seqs, (SV*)av_make(AvFILLp(isa)+1, AvARRAY(isa)));
3745 + seqs_ptr = AvARRAY(seqs);
3746 + seqs_items = AvFILLp(seqs) + 1;
3747 + while(seqs_items--) {
3748 + AV* seq = (AV*)*seqs_ptr++;
3749 + I32 seq_items = AvFILLp(seq);
3750 + if(seq_items > 0) {
3751 + SV** seq_ptr = AvARRAY(seq) + 1;
3752 + while(seq_items--) {
3753 + SV* seqitem = *seq_ptr++;
3754 + HE* he = hv_fetch_ent(tails, seqitem, 0, 0);
3756 + hv_store_ent(tails, seqitem, newSViv(1), 0);
3759 + SV* val = HeVAL(he);
3767 + SV* seqhead = NULL;
3769 + SV* winner = NULL;
3773 + SV** avptr = AvARRAY(seqs);
3774 + items = AvFILLp(seqs)+1;
3777 + seq = (AV*)*avptr++;
3778 + if(AvFILLp(seq) < 0) continue;
3779 + svp = av_fetch(seq, 0, 0);
3783 + if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
3784 + && (val = HeVAL(tail_entry))
3785 + && (SvIVx(val) > 0))
3787 + winner = newSVsv(cand);
3788 + av_push(retval, winner);
3790 + if(!sv_cmp(seqhead, winner)) {
3792 + /* this is basically shift(@seq) in void context */
3793 + SvREFCNT_dec(*AvARRAY(seq));
3794 + *AvARRAY(seq) = &PL_sv_undef;
3795 + AvARRAY(seq) = AvARRAY(seq) + 1;
3799 + if(AvFILLp(seq) < 0) continue;
3800 + svp = av_fetch(seq, 0, 0);
3802 + tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
3803 + val = HeVAL(tail_entry);
3809 + Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
3810 + "merging failed on parent '%"SVf"'", stashname, SVfARG(cand));
3814 + SvREADONLY_on(retval);
3815 + SvREFCNT_inc_simple_void_NN(retval); /* for meta storage */
3816 + SvREFCNT_inc_simple_void_NN(retval); /* for return to caller */
3817 + meta->mro_linear_c3 = retval;
3822 +=for apidoc mro_get_linear_isa
3824 +Returns either C<mro_get_linear_isa_c3> or
3825 +C<mro_get_linear_isa_dfs> for the given stash,
3826 +dependant upon which MRO is in effect
3827 +for that stash. The return value is a
3833 +Perl_mro_get_linear_isa(pTHX_ HV *stash)
3835 + struct mro_meta* meta;
3837 + assert(HvAUX(stash));
3839 + meta = HvMROMETA(stash);
3840 + if(meta->mro_which == MRO_DFS) {
3841 + return mro_get_linear_isa_dfs(stash, 0);
3842 + } else if(meta->mro_which == MRO_C3) {
3843 + return mro_get_linear_isa_c3(stash, 0);
3845 + Perl_croak(aTHX_ "Internal error: invalid MRO!");
3850 +=for apidoc mro_isa_changed_in
3852 +Takes the neccesary steps (cache invalidations, mostly)
3853 +when the @ISA of the given package has changed. Invoked
3854 +by the C<setisa> magic, should not need to invoke directly.
3859 +Perl_mro_isa_changed_in(pTHX_ HV* stash)
3867 + struct mro_meta* meta;
3870 + stashname = HvNAME_get(stash);
3872 + /* wipe out the cached linearizations for this stash */
3873 + meta = HvMROMETA(stash);
3874 + sv_2mortal((SV*)meta->mro_linear_dfs);
3875 + sv_2mortal((SV*)meta->mro_linear_c3);
3876 + meta->mro_linear_dfs = NULL;
3877 + meta->mro_linear_c3 = NULL;
3879 + /* Wipe the global method cache if this package
3880 + is UNIVERSAL or one of its parents */
3881 + if(meta->is_universal)
3882 + PL_sub_generation++;
3884 + /* Wipe the local method cache otherwise */
3886 + meta->sub_generation++;
3888 + /* wipe next::method cache too */
3889 + if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
3891 + /* Recalcs whichever of the above two cleared linearizations
3892 + are in effect and gives it to us */
3893 + linear_mro = mro_get_linear_isa(stash);
3894 + isarev = meta->mro_isarev;
3896 + /* Iterate the isarev (classes that are our children),
3897 + wiping out their linearization and method caches */
3899 + hv_iterinit(isarev);
3900 + while((iter = hv_iternext(isarev))) {
3901 + SV* revkey = hv_iterkeysv(iter);
3902 + HV* revstash = gv_stashsv(revkey, 0);
3903 + struct mro_meta* revmeta = HvMROMETA(revstash);
3904 + sv_2mortal((SV*)revmeta->mro_linear_dfs);
3905 + sv_2mortal((SV*)revmeta->mro_linear_c3);
3906 + revmeta->mro_linear_dfs = NULL;
3907 + revmeta->mro_linear_c3 = NULL;
3908 + if(!meta->is_universal)
3909 + revmeta->sub_generation++;
3910 + if(revmeta->mro_nextmethod)
3911 + hv_clear(revmeta->mro_nextmethod);
3915 + /* we're starting at the 2nd element, skipping ourselves here */
3916 + svp = AvARRAY(linear_mro) + 1;
3917 + items = AvFILLp(linear_mro);
3919 + SV* const sv = *svp++;
3920 + struct mro_meta* mrometa;
3923 + HV* mrostash = gv_stashsv(sv, 0);
3925 + mrostash = gv_stashsv(sv, GV_ADD);
3927 + We created the package on the fly, so
3928 + that we could store isarev information.
3929 + This flag lets gv_fetchmeth know about it,
3930 + so that it can still generate the very useful
3931 + "Can't locate package Foo for @Bar::ISA" warning.
3933 + HvMROMETA(mrostash)->fake = 1;
3936 + mrometa = HvMROMETA(mrostash);
3937 + mroisarev = mrometa->mro_isarev;
3939 + /* is_universal is viral */
3940 + if(meta->is_universal)
3941 + mrometa->is_universal = 1;
3944 + mroisarev = mrometa->mro_isarev = newHV();
3946 + if(!hv_exists(mroisarev, stashname, strlen(stashname)))
3947 + hv_store(mroisarev, stashname, strlen(stashname), &PL_sv_yes, 0);
3950 + hv_iterinit(isarev);
3951 + while((iter = hv_iternext(isarev))) {
3952 + SV* revkey = hv_iterkeysv(iter);
3953 + if(!hv_exists_ent(mroisarev, revkey, 0))
3954 + hv_store_ent(mroisarev, revkey, &PL_sv_yes, 0);
3961 +=for apidoc mro_method_changed_in
3963 +Like C<mro_isa_changed_in>, but invalidates method
3964 +caching on any child classes of the given stash, so
3965 +that they might notice the changes in this one.
3967 +Ideally, all instances of C<PL_sub_generation++> in
3968 +the perl source should be replaced by calls to this.
3969 +Some already are, but some are more difficult to
3972 +Perl has always had problems with method caches
3973 +getting out of sync when one directly manipulates
3974 +stashes via things like C<%{Foo::} = %{Bar::}> or
3975 +C<${Foo::}{bar} = ...> or the equivalent. If
3976 +you do this in core or XS code, call this afterwards
3977 +on the destination stash to get things back in sync.
3979 +If you're doing such a thing from pure perl, use
3980 +C<mro::method_changed_in(classname)>, which
3986 +Perl_mro_method_changed_in(pTHX_ HV *stash)
3988 + struct mro_meta* meta = HvMROMETA(stash);
3992 + /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
3993 + invalidate all method caches globally */
3994 + if(meta->is_universal) {
3995 + PL_sub_generation++;
3999 + /* else, invalidate the method caches of all child classes,
4001 + if((isarev = meta->mro_isarev)) {
4002 + hv_iterinit(isarev);
4003 + while((iter = hv_iternext(isarev))) {
4004 + SV* revkey = hv_iterkeysv(iter);
4005 + HV* revstash = gv_stashsv(revkey, 0);
4006 + struct mro_meta* mrometa = HvMROMETA(revstash);
4007 + mrometa->sub_generation++;
4008 + if(mrometa->mro_nextmethod)
4009 + hv_clear(mrometa->mro_nextmethod);
4014 +/* These two are static helpers for next::method and friends,
4015 + and re-implement a bunch of the code from pp_caller() in
4016 + a more efficient manner for this particular usage.
4020 +__dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
4022 + for (i = startingblock; i >= 0; i--) {
4023 + if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
4029 +__nextcan(pTHX_ SV* self, I32 throw_nomethod)
4031 + register I32 cxix;
4032 + register const PERL_CONTEXT *ccstack = cxstack;
4033 + const PERL_SI *top_si = PL_curstackinfo;
4037 + const char *fq_subname;
4038 + const char *subname;
4039 + STRLEN fq_subname_len;
4040 + STRLEN stashname_len;
4041 + STRLEN subname_len;
4048 + GV* candidate = NULL;
4049 + CV* cand_cv = NULL;
4050 + const char *hvname;
4052 + struct mro_meta* selfmeta;
4056 + if(sv_isobject(self))
4057 + selfstash = SvSTASH(SvRV(self));
4059 + selfstash = gv_stashsv(self, 0);
4061 + assert(selfstash);
4063 + hvname = HvNAME_get(selfstash);
4065 + croak("Can't use anonymous symbol table for method lookup");
4067 + cxix = __dopoptosub_at(cxstack, cxstack_ix);
4069 + /* This block finds the contextually-enclosing fully-qualified subname,
4070 + much like looking at (caller($i))[3] until you find a real sub that
4071 + isn't ANON, etc */
4073 + /* we may be in a higher stacklevel, so dig down deeper */
4074 + while (cxix < 0) {
4075 + if(top_si->si_type == PERLSI_MAIN)
4076 + croak("next::method/next::can/maybe::next::method must be used in method context");
4077 + top_si = top_si->si_prev;
4078 + ccstack = top_si->si_cxstack;
4079 + cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
4082 + if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
4083 + || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
4084 + cxix = __dopoptosub_at(ccstack, cxix - 1);
4089 + const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
4090 + if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
4091 + if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
4098 + cvgv = CvGV(ccstack[cxix].blk_sub.cv);
4101 + cxix = __dopoptosub_at(ccstack, cxix - 1);
4105 + /* we found a real sub here */
4106 + sv = sv_2mortal(newSV(0));
4108 + gv_efullname3(sv, cvgv, NULL);
4110 + fq_subname = SvPVX(sv);
4111 + fq_subname_len = SvCUR(sv);
4113 + subname = strrchr(fq_subname, ':');
4115 + croak("next::method/next::can/maybe::next::method cannot find enclosing method");
4118 + subname_len = fq_subname_len - (subname - fq_subname);
4119 + if(subname_len == 8 && strEQ(subname, "__ANON__")) {
4120 + cxix = __dopoptosub_at(ccstack, cxix - 1);
4126 + /* If we made it to here, we found our context */
4128 + selfmeta = HvMROMETA(selfstash);
4129 + if(!(nmcache = selfmeta->mro_nextmethod)) {
4130 + nmcache = selfmeta->mro_nextmethod = newHV();
4133 + if((cache_entry = hv_fetch_ent(nmcache, sv, 0, 0))) {
4134 + SV* val = HeVAL(cache_entry);
4135 + if(val == &PL_sv_undef) {
4136 + if(throw_nomethod)
4137 + croak("No next::method '%s' found for %s", subname, hvname);
4138 + return &PL_sv_undef;
4140 + return SvREFCNT_inc_simple_NN(val);
4143 + /* beyond here is just for cache misses, so perf isn't as critical */
4145 + stashname_len = subname - fq_subname - 2;
4146 + stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
4148 + linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
4149 + sv_2mortal((SV*)linear_av);
4151 + linear_svp = AvARRAY(linear_av);
4152 + items = AvFILLp(linear_av) + 1;
4155 + linear_sv = *linear_svp++;
4156 + assert(linear_sv);
4157 + if(sv_eq(linear_sv, stashname))
4163 + linear_sv = *linear_svp++;
4164 + assert(linear_sv);
4165 + curstash = gv_stashsv(linear_sv, FALSE);
4167 + if (!curstash || (HvMROMETA(curstash)->fake && !HvFILL(curstash))) {
4168 + if (ckWARN(WARN_MISC))
4169 + Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
4170 + (void*)linear_sv, hvname);
4176 + gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
4177 + if (!gvp) continue;
4180 + assert(candidate);
4182 + if (SvTYPE(candidate) != SVt_PVGV)
4183 + gv_init(candidate, curstash, subname, subname_len, TRUE);
4184 + if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
4185 + SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
4186 + hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
4187 + return (SV*)cand_cv;
4192 + hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
4193 + if(throw_nomethod)
4194 + croak("No next::method '%s' found for %s", subname, hvname);
4195 + return &PL_sv_undef;
4200 +XS(XS_mro_get_linear_isa);
4201 +XS(XS_mro_set_mro);
4202 +XS(XS_mro_get_mro);
4203 +XS(XS_mro_get_global_sub_generation);
4204 +XS(XS_mro_invalidate_all_method_caches);
4205 +XS(XS_mro_get_sub_generation);
4206 +XS(XS_mro_method_changed_in);
4208 +XS(XS_next_method);
4209 +XS(XS_maybe_next_method);
4212 +Perl_boot_core_mro(pTHX)
4215 + static const char file[] = __FILE__;
4217 + newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
4218 + newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
4219 + newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
4220 + newXSproto("mro::get_global_sub_generation", XS_mro_get_global_sub_generation, file, "");
4221 + newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_all_method_caches, file, "");
4222 + newXSproto("mro::get_sub_generation", XS_mro_get_sub_generation, file, "$");
4223 + newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
4224 + newXS("next::can", XS_next_can, file);
4225 + newXS("next::method", XS_next_method, file);
4226 + newXS("maybe::next::method", XS_maybe_next_method, file);
4229 +XS(XS_mro_get_linear_isa) {
4236 + if(items < 1 || items > 2)
4237 + croak("Usage: mro::get_linear_isa(classname [, type ])");
4239 + classname = ST(0);
4240 + class_stash = gv_stashsv(classname, 0);
4241 + if(!class_stash) croak("No such class: '%"SVf"'!", SVfARG(classname));
4244 + char* which = SvPV_nolen(ST(1));
4245 + if(strEQ(which, "dfs"))
4246 + RETVAL = mro_get_linear_isa_dfs(class_stash, 0);
4247 + else if(strEQ(which, "c3"))
4248 + RETVAL = mro_get_linear_isa_c3(class_stash, 0);
4250 + croak("Invalid mro name: '%s'", which);
4253 + RETVAL = mro_get_linear_isa(class_stash);
4256 + ST(0) = newRV_noinc((SV*)RETVAL);
4257 + sv_2mortal(ST(0));
4269 + struct mro_meta* meta;
4272 + croak("Usage: mro::set_mro(classname, type)");
4274 + classname = ST(0);
4275 + whichstr = SvPV_nolen(ST(1));
4276 + class_stash = gv_stashsv(classname, GV_ADD);
4277 + if(!class_stash) croak("Cannot create class: '%"SVf"'!", SVfARG(classname));
4278 + meta = HvMROMETA(class_stash);
4280 + if(strEQ(whichstr, "dfs"))
4282 + else if(strEQ(whichstr, "c3"))
4285 + croak("Invalid mro name: '%s'", whichstr);
4287 + if(meta->mro_which != which) {
4288 + meta->mro_which = which;
4289 + /* Only affects local method cache, not
4290 + even child classes */
4291 + meta->sub_generation++;
4292 + if(meta->mro_nextmethod)
4293 + hv_clear(meta->mro_nextmethod);
4306 + struct mro_meta* meta;
4309 + croak("Usage: mro::get_mro(classname)");
4311 + classname = ST(0);
4312 + class_stash = gv_stashsv(classname, 0);
4313 + if(!class_stash) croak("No such class: '%"SVf"'!", SVfARG(classname));
4314 + meta = HvMROMETA(class_stash);
4316 + if(meta->mro_which == MRO_DFS)
4317 + ST(0) = sv_2mortal(newSVpvn("dfs", 3));
4319 + ST(0) = sv_2mortal(newSVpvn("c3", 2));
4324 +XS(XS_mro_get_global_sub_generation)
4330 + croak("Usage: mro::get_global_sub_generation()");
4332 + ST(0) = sv_2mortal(newSViv(PL_sub_generation));
4336 +XS(XS_mro_invalidate_all_method_caches)
4342 + croak("Usage: mro::invalidate_all_method_caches()");
4344 + PL_sub_generation++;
4349 +XS(XS_mro_get_sub_generation)
4357 + croak("Usage: mro::get_sub_generation(classname)");
4359 + classname = ST(0);
4360 + class_stash = gv_stashsv(classname, 0);
4361 + if(!class_stash) croak("No such class: '%"SVf"'!", SVfARG(classname));
4363 + ST(0) = sv_2mortal(newSViv(HvMROMETA(class_stash)->sub_generation));
4367 +XS(XS_mro_method_changed_in)
4375 + croak("Usage: mro::method_changed_in(classname)");
4377 + classname = ST(0);
4379 + class_stash = gv_stashsv(classname, 0);
4380 + if(!class_stash) croak("No such class: '%"SVf"'!", SVfARG(classname));
4382 + mro_method_changed_in(class_stash);
4392 + SV* methcv = __nextcan(self, 0);
4394 + PERL_UNUSED_VAR(items);
4396 + if(methcv == &PL_sv_undef) {
4397 + ST(0) = &PL_sv_undef;
4400 + ST(0) = sv_2mortal(newRV_inc(methcv));
4411 + SV* methcv = __nextcan(self, 1);
4413 + PL_markstack_ptr++;
4414 + call_sv(methcv, GIMME_V);
4417 +XS(XS_maybe_next_method)
4422 + SV* methcv = __nextcan(self, 0);
4424 + if(methcv == &PL_sv_undef) {
4425 + ST(0) = &PL_sv_undef;
4429 + PL_markstack_ptr++;
4430 + call_sv(methcv, GIMME_V);
4434 + * Local variables:
4435 + * c-indentation-style: bsd
4436 + * c-basic-offset: 4
4437 + * indent-tabs-mode: t
4440 + * ex: set ts=8 sts=4 sw=4 noet:
4443 ==================================================================
4444 --- hv.c (/local/perl-current) (revision 30454)
4445 +++ hv.c (/local/perl-c3-subg) (revision 30454)
4446 @@ -1531,7 +1531,7 @@
4449 if (val && isGV(val) && GvCVu(val) && HvNAME_get(hv))
4450 - PL_sub_generation++; /* may be deletion of method from stash */
4451 + mro_method_changed_in(hv); /* deletion of method from stash */
4453 if (HeKLEN(entry) == HEf_SVKEY) {
4454 SvREFCNT_dec(HeKEY_sv(entry));
4455 @@ -1726,6 +1726,7 @@
4459 + struct mro_meta *meta;
4460 struct xpvhv_aux *iter = HvAUX(hv);
4461 /* If there are weak references to this HV, we need to avoid
4462 freeing them up here. In particular we need to keep the AV
4463 @@ -1757,6 +1758,15 @@
4464 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
4465 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
4467 + if((meta = iter->xhv_mro_meta)) {
4468 + if(meta->mro_linear_dfs) SvREFCNT_dec(meta->mro_linear_dfs);
4469 + if(meta->mro_linear_c3) SvREFCNT_dec(meta->mro_linear_c3);
4470 + if(meta->mro_isarev) SvREFCNT_dec(meta->mro_isarev);
4471 + if(meta->mro_nextmethod) SvREFCNT_dec(meta->mro_nextmethod);
4473 + iter->xhv_mro_meta = NULL;
4476 /* There are now no allocated pointers in the aux structure. */
4478 SvFLAGS(hv) &= ~SVf_OOK; /* Goodbye, aux structure. */
4479 @@ -1878,6 +1888,7 @@
4480 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
4482 iter->xhv_backreferences = 0;
4483 + iter->xhv_mro_meta = NULL;
4488 ==================================================================
4489 --- hv.h (/local/perl-current) (revision 30454)
4490 +++ hv.h (/local/perl-c3-subg) (revision 30454)
4493 /* Subject to change.
4494 Don't access this directly.
4495 + Use the funcs in mro.c
4504 + AV *mro_linear_dfs; /* cached dfs @ISA linearization */
4505 + AV *mro_linear_c3; /* cached c3 @ISA linearization */
4506 + HV *mro_isarev; /* reverse @ISA dependencies (who depends on us?) */
4507 + HV *mro_nextmethod; /* next::method caching */
4508 + mro_alg mro_which; /* which mro alg is in use? */
4509 + U32 sub_generation; /* Like PL_sub_generation, but stash-local */
4510 + I32 is_universal; /* We are UNIVERSAL or a potentially indirect
4511 + member of @UNIVERSAL::ISA */
4512 + I32 fake; /* setisa made this fake package,
4513 + gv_fetchmeth pays attention to this,
4514 + and "package" sets it back to zero */
4517 +/* Subject to change.
4518 + Don't access this directly.
4522 HEK *xhv_name; /* name, if a symbol table */
4523 AV *xhv_backreferences; /* back references for weak references */
4524 HE *xhv_eiter; /* current entry of iterator */
4525 I32 xhv_riter; /* current root of iterator */
4526 + struct mro_meta *xhv_mro_meta;
4529 /* hash structure: */
4531 #define HvRITER_get(hv) (SvOOK(hv) ? HvAUX(hv)->xhv_riter : -1)
4532 #define HvEITER_get(hv) (SvOOK(hv) ? HvAUX(hv)->xhv_eiter : 0)
4533 #define HvNAME(hv) HvNAME_get(hv)
4534 +#define HvMROMETA(hv) (HvAUX(hv)->xhv_mro_meta ? HvAUX(hv)->xhv_mro_meta : mro_meta_init(hv))
4535 /* FIXME - all of these should use a UTF8 aware API, which should also involve
4536 getting the length. */
4537 /* This macro may go away without notice. */
4539 ==================================================================
4540 --- mg.c (/local/perl-current) (revision 30454)
4541 +++ mg.c (/local/perl-c3-subg) (revision 30454)
4542 @@ -1530,8 +1530,18 @@
4545 PERL_UNUSED_ARG(sv);
4546 - PERL_UNUSED_ARG(mg);
4547 - PL_sub_generation++;
4549 + /* The first case occurs via setisa,
4550 + the second via setisa_elem, which
4551 + calls this same magic */
4552 + mro_isa_changed_in(
4554 + SvTYPE(mg->mg_obj) == SVt_PVGV
4556 + : (GV*)SvMAGIC(mg->mg_obj)->mg_obj
4563 @@ -1541,7 +1551,6 @@
4565 PERL_UNUSED_ARG(sv);
4566 PERL_UNUSED_ARG(mg);
4567 - /* HV_badAMAGIC_on(Sv_STASH(sv)); */
4568 PL_amagic_generation++;
4572 ==================================================================
4573 --- op.c (/local/perl-current) (revision 30454)
4574 +++ op.c (/local/perl-c3-subg) (revision 30454)
4575 @@ -3649,6 +3649,11 @@
4576 save_item(PL_curstname);
4578 PL_curstash = gv_stashsv(sv, GV_ADD);
4580 + /* In case mg.c:Perl_magic_setisa faked
4581 + this package earlier, we clear the fake flag */
4582 + HvMROMETA(PL_curstash)->fake = 0;
4584 sv_setsv(PL_curstname, sv);
4586 PL_hints |= HINT_BLOCK_SCOPE;
4587 @@ -5291,9 +5296,9 @@
4588 sv_setpvn((SV*)gv, ps, ps_len);
4590 sv_setiv((SV*)gv, -1);
4592 SvREFCNT_dec(PL_compcv);
4593 cv = PL_compcv = NULL;
4594 - PL_sub_generation++;
4598 @@ -5387,7 +5392,13 @@
4600 cv = newCONSTSUB(NULL, name, const_sv);
4602 - PL_sub_generation++;
4603 + mro_method_changed_in( /* sub Foo::Bar () { 123 } */
4604 + (CvGV(cv) && GvSTASH(CvGV(cv)))
4605 + ? GvSTASH(CvGV(cv))
4613 @@ -5470,7 +5481,7 @@
4617 - PL_sub_generation++;
4618 + mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
4622 @@ -5802,7 +5813,7 @@
4626 - PL_sub_generation++;
4627 + mro_method_changed_in(GvSTASH(gv)); /* newXS */
4632 ==================================================================
4633 --- sv.c (/local/perl-current) (revision 30454)
4634 +++ sv.c (/local/perl-c3-subg) (revision 30454)
4635 @@ -3245,7 +3245,7 @@
4636 SvREFCNT_dec(GvCV(dstr));
4638 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4639 - PL_sub_generation++;
4640 + mro_method_changed_in(GvSTASH(dstr));
4643 SAVEGENERICSV(*location);
4644 @@ -3291,7 +3291,7 @@
4646 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4647 GvASSUMECV_on(dstr);
4648 - PL_sub_generation++;
4649 + mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
4652 if (import_flag && !(GvFLAGS(dstr) & import_flag)
4654 ==================================================================
4655 --- pp_hot.c (/local/perl-current) (revision 30454)
4656 +++ pp_hot.c (/local/perl-c3-subg) (revision 30454)
4659 if (strEQ(GvNAME(right),"isa")) {
4661 - ++PL_sub_generation;
4662 + ++PL_sub_generation; /* I don't get this at all --blblack */
4665 SvSetMagicSV(right, left);
4666 @@ -3060,7 +3060,8 @@
4668 gv = (GV*)HeVAL(he);
4669 if (isGV(gv) && GvCV(gv) &&
4670 - (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
4671 + (!GvCVGEN(gv) || GvCVGEN(gv)
4672 + == (PL_sub_generation + HvMROMETA(stash)->sub_generation)))
4673 return (SV*)GvCV(gv);
4677 ==================================================================
4678 --- embed.fnc (/local/perl-current) (revision 30454)
4679 +++ embed.fnc (/local/perl-c3-subg) (revision 30454)
4680 @@ -282,6 +282,13 @@
4681 Ap |GV* |gv_fetchfile |NN const char* name
4682 Ap |GV* |gv_fetchfile_flags|NN const char *const name|const STRLEN len\
4684 +ApM |struct mro_meta* |mro_meta_init |NN HV* stash
4685 +ApM |AV* |mro_get_linear_isa|NN HV* stash
4686 +ApM |AV* |mro_get_linear_isa_c3|NN HV* stash|I32 level
4687 +ApM |AV* |mro_get_linear_isa_dfs|NN HV* stash|I32 level
4688 +ApM |void |mro_isa_changed_in|NN HV* stash
4689 +ApM |void |mro_method_changed_in |NN HV* stash
4690 +ApM |void |boot_core_mro
4691 Apd |GV* |gv_fetchmeth |NULLOK HV* stash|NN const char* name|STRLEN len|I32 level
4692 Apd |GV* |gv_fetchmeth_autoload |NULLOK HV* stash|NN const char* name|STRLEN len|I32 level
4693 Apdmb |GV* |gv_fetchmethod |NULLOK HV* stash|NN const char* name
4695 Property changes on:
4696 ___________________________________________________________________
4698 +bc823f99-e23a-42ae-8890-ba2193b93f74:/local/perl-c3:30450
4699 +bc823f99-e23a-42ae-8890-ba2193b93f74:/local/perl-c3-isarev:29720
4700 +bc823f99-e23a-42ae-8890-ba2193b93f74:/local/perl-current:30449