c3.patch

   1 === Makefile.micro
   2 ==================================================================
   3 --- Makefile.micro      (/local/perl-current)   (revision 30426)
   4 +++ Makefile.micro      (/local/perl-c3-subg)   (revision 30426)
   5 @@ -10,7 +10,7 @@
   6  all:   microperl
   7
   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) \
  14 @@ -76,6 +76,9 @@
  15  ugv$(_O):      $(HE) gv.c
  16         $(CC) -c -o $@ $(CFLAGS) gv.c
  17
  18 +umro$(_O):     $(HE) mro.c
  19 +       $(CC) -c -o $@ $(CFLAGS) mro.c
  20 +
  21  uhv$(_O):      $(HE) hv.c
  22         $(CC) -c -o $@ $(CFLAGS) hv.c
  23
  24 === embed.h
  25 ==================================================================
  26 --- embed.h     (/local/perl-current)   (revision 30426)
  27 +++ embed.h     (/local/perl-c3-subg)   (revision 30426)
  28 @@ -267,6 +267,13 @@
  29  #define gv_efullname4          Perl_gv_efullname4
  30  #define gv_fetchfile           Perl_gv_fetchfile
  31  #define gv_fetchfile_flags     Perl_gv_fetchfile_flags
  32 +#define mro_meta_init          Perl_mro_meta_init
  33 +#define mro_linear             Perl_mro_linear
  34 +#define mro_linear_c3          Perl_mro_linear_c3
  35 +#define mro_linear_dfs         Perl_mro_linear_dfs
  36 +#define mro_isa_changed_in     Perl_mro_isa_changed_in
  37 +#define mro_method_changed_in  Perl_mro_method_changed_in
  38 +#define boot_core_mro          Perl_boot_core_mro
  39  #define gv_fetchmeth           Perl_gv_fetchmeth
  40  #define gv_fetchmeth_autoload  Perl_gv_fetchmeth_autoload
  41  #define gv_fetchmethod_autoload        Perl_gv_fetchmethod_autoload
  42 @@ -2511,6 +2518,13 @@
  43  #define gv_efullname4(a,b,c,d) Perl_gv_efullname4(aTHX_ a,b,c,d)
  44  #define gv_fetchfile(a)                Perl_gv_fetchfile(aTHX_ a)
  45  #define gv_fetchfile_flags(a,b,c)      Perl_gv_fetchfile_flags(aTHX_ a,b,c)
  46 +#define mro_meta_init(a)       Perl_mro_meta_init(aTHX_ a)
  47 +#define mro_linear(a)          Perl_mro_linear(aTHX_ a)
  48 +#define mro_linear_c3(a,b)     Perl_mro_linear_c3(aTHX_ a,b)
  49 +#define mro_linear_dfs(a,b)    Perl_mro_linear_dfs(aTHX_ a,b)
  50 +#define mro_isa_changed_in(a)  Perl_mro_isa_changed_in(aTHX_ a)
  51 +#define mro_method_changed_in(a)       Perl_mro_method_changed_in(aTHX_ a)
  52 +#define boot_core_mro()                Perl_boot_core_mro(aTHX)
  53  #define gv_fetchmeth(a,b,c,d)  Perl_gv_fetchmeth(aTHX_ a,b,c,d)
  54  #define gv_fetchmeth_autoload(a,b,c,d) Perl_gv_fetchmeth_autoload(aTHX_ a,b,c,d)
  55  #define gv_fetchmethod_autoload(a,b,c) Perl_gv_fetchmethod_autoload(aTHX_ a,b,c)
  56 === pod/perlapi.pod
  57 ==================================================================
  58 --- pod/perlapi.pod     (/local/perl-current)   (revision 30426)
  59 +++ pod/perlapi.pod     (/local/perl-c3-subg)   (revision 30426)
  60 @@ -1326,7 +1326,7 @@
  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.
  66
  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
  69 === pp_ctl.c
  70 ==================================================================
  71 --- pp_ctl.c    (/local/perl-current)   (revision 30426)
  72 +++ pp_ctl.c    (/local/perl-c3-subg)   (revision 30426)
  73 @@ -3511,6 +3511,11 @@
  74         && ret != PL_op->op_next) {     /* Successive compilation. */
  75         /* Copy in anything fake and short. */
  76         my_strlcpy(safestr, fakestr, fakelen);
  77 +        /* XXX blblack - I don't understand what's going on here,
  78 +           but its not going to work like it used to, as PL_sub_generation
  79 +           is no longer incremented for all sub definitions.  In any case
  80 +           this is a debugger-only thing
  81 +        */
  82      }
  83      return DOCATCH(ret);
  84  }
  85 === global.sym
  86 ==================================================================
  87 --- global.sym  (/local/perl-current)   (revision 30426)
  88 +++ global.sym  (/local/perl-c3-subg)   (revision 30426)
  89 @@ -135,6 +135,13 @@
  90  Perl_gv_efullname4
  91  Perl_gv_fetchfile
  92  Perl_gv_fetchfile_flags
  93 +Perl_mro_meta_init
  94 +Perl_mro_linear
  95 +Perl_mro_linear_c3
  96 +Perl_mro_linear_dfs
  97 +Perl_mro_isa_changed_in
  98 +Perl_mro_method_changed_in
  99 +Perl_boot_core_mro
 100  Perl_gv_fetchmeth
 101  Perl_gv_fetchmeth_autoload
 102  Perl_gv_fetchmethod
 103 === perl.c
 104 ==================================================================
 105 --- perl.c      (/local/perl-current)   (revision 30426)
 106 +++ perl.c      (/local/perl-c3-subg)   (revision 30426)
 107 @@ -2163,6 +2163,7 @@
 108      boot_core_PerlIO();
 109      boot_core_UNIVERSAL();
 110      boot_core_xsutils();
 111 +    boot_core_mro();
 112
 113      if (xsinit)
 114         (*xsinit)(aTHX);        /* in case linked C routines want magical variables */
 115 === universal.c
 116 ==================================================================
 117 --- universal.c (/local/perl-current)   (revision 30426)
 118 +++ universal.c (/local/perl-c3-subg)   (revision 30426)
 119 @@ -36,12 +36,12 @@
 120               int len, int level)
 121  {
 122      dVAR;
 123 -    AV* av;
 124 -    GV* gv;
 125 -    GV** gvp;
 126 -    HV* hv = NULL;
 127 -    SV* subgen = NULL;
 128 +    AV* stash_linear_isa;
 129 +    SV** svp;
 130      const char *hvname;
 131 +    I32 items;
 132 +    PERL_UNUSED_ARG(len);
 133 +    PERL_UNUSED_ARG(level);
 134
 135      /* A stash/class can go by many names (ie. User == main::User), so
 136         we compare the stash itself just in case */
 137 @@ -56,75 +56,23 @@
 138      if (strEQ(name, "UNIVERSAL"))
 139         return TRUE;
 140
 141 -    if (level > 100)
 142 -       Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
 143 -                  hvname);
 144 -
 145 -    gvp = (GV**)hv_fetchs(stash, "::ISA::CACHE::", FALSE);
 146 -
 147 -    if (gvp && (gv = *gvp) && isGV_with_GP(gv) && (subgen = GvSV(gv))
 148 -       && (hv = GvHV(gv)))
 149 -    {
 150 -       if (SvIV(subgen) == (IV)PL_sub_generation) {
 151 -           SV** const svp = (SV**)hv_fetch(hv, name, len, FALSE);
 152 -           if (svp) {
 153 -               SV * const sv = *svp;
 154 -#ifdef DEBUGGING
 155 -               if (sv != &PL_sv_undef)
 156 -                   DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
 157 -                                   name, hvname) );
 158 -#endif
 159 -               return (sv == &PL_sv_yes);
 160 -           }
 161 +    stash_linear_isa = (AV*)sv_2mortal((SV*)mro_linear(stash));
 162 +    svp = AvARRAY(stash_linear_isa) + 1;
 163 +    items = AvFILLp(stash_linear_isa);
 164 +    while (items--) {
 165 +       SV* const basename_sv = *svp++;
 166 +        HV* basestash = gv_stashsv(basename_sv, 0);
 167 +       if (!basestash) {
 168 +           if (ckWARN(WARN_MISC))
 169 +               Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 170 +                           "Can't locate package %"SVf" for the parents of %s",
 171 +                           SVfARG(basename_sv), hvname);
 172 +           continue;
 173         }
 174 -       else {
 175 -           DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
 176 -                             hvname) );
 177 -           hv_clear(hv);
 178 -           sv_setiv(subgen, PL_sub_generation);
 179 -       }
 180 +        if(name_stash == basestash || strEQ(name, SvPVX(basename_sv)))
 181 +           return TRUE;
 182      }
 183
 184 -    gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
 185 -
 186 -    if (gvp && (gv = *gvp) && isGV_with_GP(gv) && (av = GvAV(gv))) {
 187 -       if (!hv || !subgen) {
 188 -           gvp = (GV**)hv_fetchs(stash, "::ISA::CACHE::", TRUE);
 189 -
 190 -           gv = *gvp;
 191 -
 192 -           if (SvTYPE(gv) != SVt_PVGV)
 193 -               gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
 194 -
 195 -           if (!hv)
 196 -               hv = GvHVn(gv);
 197 -           if (!subgen) {
 198 -               subgen = newSViv(PL_sub_generation);
 199 -               GvSV(gv) = subgen;
 200 -           }
 201 -       }
 202 -       if (hv) {
 203 -           SV** svp = AvARRAY(av);
 204 -           /* NOTE: No support for tied ISA */
 205 -           I32 items = AvFILLp(av) + 1;
 206 -           while (items--) {
 207 -               SV* const sv = *svp++;
 208 -               HV* const basestash = gv_stashsv(sv, 0);
 209 -               if (!basestash) {
 210 -                   if (ckWARN(WARN_MISC))
 211 -                       Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 212 -                                   "Can't locate package %"SVf" for @%s::ISA",
 213 -                                   SVfARG(sv), hvname);
 214 -                   continue;
 215 -               }
 216 -               if (isa_lookup(basestash, name, name_stash, len, level + 1)) {
 217 -                   (void)hv_store(hv,name,len,&PL_sv_yes,0);
 218 -                   return TRUE;
 219 -               }
 220 -           }
 221 -           (void)hv_store(hv,name,len,&PL_sv_no,0);
 222 -       }
 223 -    }
 224      return FALSE;
 225  }
 226
 227 === scope.c
 228 ==================================================================
 229 --- scope.c     (/local/perl-current)   (revision 30426)
 230 +++ scope.c     (/local/perl-c3-subg)   (revision 30426)
 231 @@ -256,7 +256,7 @@
 232         GP *gp = Perl_newGP(aTHX_ gv);
 233
 234         if (GvCVu(gv))
 235 -           PL_sub_generation++;        /* taking a method out of circulation */
 236 +            mro_method_changed_in(GvSTASH(gv)); /* taking a method out of circulation ("local")*/
 237         if (GvIOp(gv) && (IoFLAGS(GvIOp(gv)) & IOf_ARGV)) {
 238             gp->gp_io = newIO();
 239             IoFLAGS(gp->gp_io) |= IOf_ARGV|IOf_START;
 240 @@ -740,7 +740,7 @@
 241             gp_free(gv);
 242             GvGP(gv) = (GP*)ptr;
 243             if (GvCVu(gv))
 244 -               PL_sub_generation++;  /* putting a method back into circulation */
 245 +                mro_method_changed_in(GvSTASH(gv)); /* putting a method back into circulation ("local")*/
 246             SvREFCNT_dec(gv);
 247             break;
 248         case SAVEt_FREESV:
 249 === gv.c
 250 ==================================================================
 251 --- gv.c        (/local/perl-current)   (revision 30426)
 252 +++ gv.c        (/local/perl-c3-subg)   (revision 30426)
 253 @@ -260,7 +260,7 @@
 254         }
 255         LEAVE;
 256
 257 -       PL_sub_generation++;
 258 +        mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub ASDF::baz($); *ASDF::baz = \&Foo::bar */
 259         CvGV(GvCV(gv)) = gv;
 260         CvFILE_set_from_cop(GvCV(gv), PL_curcop);
 261         CvSTASH(GvCV(gv)) = PL_curstash;
 262 @@ -310,7 +310,7 @@
 263  The argument C<level> should be either 0 or -1.  If C<level==0>, as a
 264  side-effect creates a glob with the given C<name> in the given C<stash>
 265  which in the case of success contains an alias for the subroutine, and sets
 266 -up caching info for this glob.  Similarly for all the searched stashes.
 267 +up caching info for this glob.
 268
 269  This function grants C<"SUPER"> token as a postfix of the stash name. The
 270  GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
 271 @@ -321,133 +321,150 @@
 272  =cut
 273  */
 274
 275 +/* NOTE: No support for tied ISA */
 276 +
 277  GV *
 278  Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 279  {
 280      dVAR;
 281 -    AV* av;
 282 -    GV* topgv;
 283 -    GV* gv;
 284      GV** gvp;
 285 -    CV* cv;
 286 +    AV* linear_av;
 287 +    SV** linear_svp;
 288 +    SV* linear_sv;
 289 +    HV* curstash;
 290 +    GV* candidate = NULL;
 291 +    CV* cand_cv = NULL;
 292 +    CV* old_cv;
 293 +    GV* topgv = NULL;
 294      const char *hvname;
 295 -    HV* lastchance = NULL;
 296 +    I32 create = (level >= 0) ? 1 : 0;
 297 +    I32 items;
 298 +    STRLEN packlen;
 299 +    U32 topgen_cmp;
 300
 301      /* UNIVERSAL methods should be callable without a stash */
 302      if (!stash) {
 303 -       level = -1;  /* probably appropriate */
 304 +       create = 0;  /* probably appropriate */
 305         if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
 306             return 0;
 307      }
 308
 309 +    assert(stash);
 310 +
 311      hvname = HvNAME_get(stash);
 312      if (!hvname)
 313 -      Perl_croak(aTHX_
 314 -                "Can't use anonymous symbol table for method lookup");
 315 +      Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
 316
 317 -    if ((level > 100) || (level < -100))
 318 -       Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
 319 -             name, hvname);
 320 +    assert(hvname);
 321 +    assert(name);
 322 +    assert(len >= 0);
 323
 324      DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) );
 325
 326 -    gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
 327 -    if (!gvp)
 328 -       topgv = NULL;
 329 +    topgen_cmp = HvMROMETA(stash)->sub_generation + PL_sub_generation;
 330 +
 331 +    /* check locally for a real method or a cache entry */
 332 +    gvp = (GV**)hv_fetch(stash, name, len, create);
 333 +    if(gvp) {
 334 +        topgv = *gvp;
 335 +        assert(topgv);
 336 +        if (SvTYPE(topgv) != SVt_PVGV)
 337 +            gv_init(topgv, stash, name, len, TRUE);
 338 +        if ((cand_cv = GvCV(topgv))) {
 339 +            /* If genuine method or valid cache entry, use it */
 340 +            if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
 341 +                return topgv;
 342 +            }
 343 +            else {
 344 +                /* stale cache entry, junk it and move on */
 345 +               SvREFCNT_dec(cand_cv);
 346 +               GvCV(topgv) = cand_cv = NULL;
 347 +               GvCVGEN(topgv) = 0;
 348 +            }
 349 +        }
 350 +        else if (GvCVGEN(topgv) == topgen_cmp) {
 351 +            /* cache indicates no such method definitively */
 352 +            return 0;
 353 +        }
 354 +    }
 355 +
 356 +    packlen = HvNAMELEN_get(stash);
 357 +    if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
 358 +        HV* basestash;
 359 +        packlen -= 7;
 360 +        basestash = gv_stashpvn(hvname, packlen, GV_ADD);
 361 +        linear_av = mro_linear(basestash);
 362 +    }
 363      else {
 364 -       topgv = *gvp;
 365 -       if (SvTYPE(topgv) != SVt_PVGV)
 366 -           gv_init(topgv, stash, name, len, TRUE);
 367 -       if ((cv = GvCV(topgv))) {
 368 -           /* If genuine method or valid cache entry, use it */
 369 -           if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
 370 -               return topgv;
 371 -           /* Stale cached entry: junk it */
 372 -           SvREFCNT_dec(cv);
 373 -           GvCV(topgv) = cv = NULL;
 374 -           GvCVGEN(topgv) = 0;
 375 -       }
 376 -       else if (GvCVGEN(topgv) == PL_sub_generation)
 377 -           return 0;  /* cache indicates sub doesn't exist */
 378 +        linear_av = mro_linear(stash); /* has ourselves at the top of the list */
 379      }
 380 +    sv_2mortal((SV*)linear_av);
 381
 382 -    gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
 383 -    av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
 384 +    linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
 385 +    items = AvFILLp(linear_av); /* no +1, to skip over self */
 386 +    while (items--) {
 387 +        linear_sv = *linear_svp++;
 388 +        assert(linear_sv);
 389 +        curstash = gv_stashsv(linear_sv, 0);
 390
 391 -    /* create and re-create @.*::SUPER::ISA on demand */
 392 -    if (!av || !SvMAGIC(av)) {
 393 -       STRLEN packlen = HvNAMELEN_get(stash);
 394 +        /* mg.c:Perl_magic_setisa sets the fake flag on packages it had
 395 +           to create that the user did not.  The "package" statement
 396 +           clears it.  We also check if there's anything in the symbol
 397 +           table at all, which would indicate a previously "fake" package
 398 +           where someone adding things via $Foo::Bar = 1 without ever
 399 +           using a "package" statement.
 400 +           This was all neccesary because magic_setisa needs a place to
 401 +           keep isarev information on packages that aren't yet defined,
 402 +           yet we still need to issue this warning when appropriate.
 403 +        */
 404 +        if (!curstash || (HvMROMETA(curstash)->fake && !HvFILL(curstash))) {
 405 +            if (ckWARN(WARN_MISC))
 406 +                Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
 407 +                    SVfARG(linear_sv), hvname);
 408 +            continue;
 409 +        }
 410
 411 -       if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
 412 -           HV* basestash;
 413 +        assert(curstash);
 414
 415 -           packlen -= 7;
 416 -           basestash = gv_stashpvn(hvname, packlen, GV_ADD);
 417 -           gvp = (GV**)hv_fetchs(basestash, "ISA", FALSE);
 418 -           if (gvp && (gv = *gvp) && isGV_with_GP(gv) && (av = GvAV(gv))) {
 419 -               gvp = (GV**)hv_fetchs(stash, "ISA", TRUE);
 420 -               if (!gvp || !(gv = *gvp))
 421 -                   Perl_croak(aTHX_ "Cannot create %s::ISA", hvname);
 422 -               if (SvTYPE(gv) != SVt_PVGV)
 423 -                   gv_init(gv, stash, "ISA", 3, TRUE);
 424 -               SvREFCNT_dec(GvAV(gv));
 425 -               GvAV(gv) = (AV*)SvREFCNT_inc_simple(av);
 426 -           }
 427 -       }
 428 +        gvp = (GV**)hv_fetch(curstash, name, len, 0);
 429 +        if (!gvp) continue;
 430 +        candidate = *gvp;
 431 +        assert(candidate);
 432 +        if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, curstash, name, len, TRUE);
 433 +        if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
 434 +            /*
 435 +             * Found real method, cache method in topgv if:
 436 +             *  1. topgv has no synonyms (else inheritance crosses wires)
 437 +             *  2. method isn't a stub (else AUTOLOAD fails spectacularly)
 438 +             */
 439 +            if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
 440 +                  if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv);
 441 +                  SvREFCNT_inc_simple_void_NN(cand_cv);
 442 +                  GvCV(topgv) = cand_cv;
 443 +                  GvCVGEN(topgv) = topgen_cmp;
 444 +            }
 445 +           return candidate;
 446 +        }
 447      }
 448
 449 -    if (av) {
 450 -       SV** svp = AvARRAY(av);
 451 -       /* NOTE: No support for tied ISA */
 452 -       I32 items = AvFILLp(av) + 1;
 453 -       while (items--) {
 454 -           SV* const sv = *svp++;
 455 -           HV* const basestash = gv_stashsv(sv, 0);
 456 -           if (!basestash) {
 457 -               if (ckWARN(WARN_MISC))
 458 -                   Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
 459 -                       SVfARG(sv), hvname);
 460 -               continue;
 461 -           }
 462 -           gv = gv_fetchmeth(basestash, name, len,
 463 -                             (level >= 0) ? level + 1 : level - 1);
 464 -           if (gv)
 465 -               goto gotcha;
 466 -       }
 467 +    /* Check UNIVERSAL without caching */
 468 +    if(level == 0 || level == -1) {
 469 +        candidate = gv_fetchmeth(NULL, name, len, 1);
 470 +        if(candidate) {
 471 +            cand_cv = GvCV(candidate);
 472 +            if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
 473 +                  if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv);
 474 +                  SvREFCNT_inc_simple_void_NN(cand_cv);
 475 +                  GvCV(topgv) = cand_cv;
 476 +                  GvCVGEN(topgv) = topgen_cmp;
 477 +            }
 478 +            return candidate;
 479 +        }
 480      }
 481
 482 -    /* if at top level, try UNIVERSAL */
 483 -
 484 -    if (level == 0 || level == -1) {
 485 -       lastchance = gv_stashpvs("UNIVERSAL", 0);
 486 -
 487 -       if (lastchance) {
 488 -           if ((gv = gv_fetchmeth(lastchance, name, len,
 489 -                                 (level >= 0) ? level + 1 : level - 1)))
 490 -           {
 491 -         gotcha:
 492 -               /*
 493 -                * Cache method in topgv if:
 494 -                *  1. topgv has no synonyms (else inheritance crosses wires)
 495 -                *  2. method isn't a stub (else AUTOLOAD fails spectacularly)
 496 -                */
 497 -               if (topgv &&
 498 -                   GvREFCNT(topgv) == 1 &&
 499 -                   (cv = GvCV(gv)) &&
 500 -                   (CvROOT(cv) || CvXSUB(cv)))
 501 -               {
 502 -                   if ((cv = GvCV(topgv)))
 503 -                       SvREFCNT_dec(cv);
 504 -                   GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
 505 -                   GvCVGEN(topgv) = PL_sub_generation;
 506 -               }
 507 -               return gv;
 508 -           }
 509 -           else if (topgv && GvREFCNT(topgv) == 1) {
 510 -               /* cache the fact that the method is not defined */
 511 -               GvCVGEN(topgv) = PL_sub_generation;
 512 -           }
 513 -       }
 514 +    if (topgv && GvREFCNT(topgv) == 1) {
 515 +        /* cache the fact that the method is not defined */
 516 +        GvCVGEN(topgv) = topgen_cmp;
 517      }
 518
 519      return 0;
 520 @@ -1436,15 +1453,22 @@
 521      gp->gp_refcnt++;
 522      if (gp->gp_cv) {
 523         if (gp->gp_cvgen) {
 524 -           /* multi-named GPs cannot be used for method cache */
 525 +           /* If the GP they asked for a reference to contains
 526 +               a method cache entry, clear it first, so that we
 527 +               don't infect them with our cached entry */
 528             SvREFCNT_dec(gp->gp_cv);
 529             gp->gp_cv = NULL;
 530             gp->gp_cvgen = 0;
 531         }
 532 -       else {
 533 -           /* Adding a new name to a subroutine invalidates method cache */
 534 -           PL_sub_generation++;
 535 -       }
 536 +        /* XXX if anyone finds a method cache regression with
 537 +           the "mro" stuff, turning this else block back on
 538 +           is probably the first place to look --blblack
 539 +        */
 540 +        /*
 541 +        else {
 542 +            PL_sub_generation++;
 543 +        }
 544 +        */
 545      }
 546      return gp;
 547  }
 548 @@ -1465,8 +1489,7 @@
 549          return;
 550      }
 551      if (gp->gp_cv) {
 552 -       /* Deleting the name of a subroutine invalidates method cache */
 553 -       PL_sub_generation++;
 554 +        PL_sub_generation++;
 555      }
 556      if (--gp->gp_refcnt > 0) {
 557         if (gp->gp_egv == gv)
 558 @@ -1523,11 +1546,13 @@
 559    dVAR;
 560    MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
 561    AMT amt;
 562 +  U32 newgen;
 563
 564 +  newgen = PL_sub_generation + HvMROMETA(stash)->sub_generation;
 565    if (mg) {
 566        const AMT * const amtp = (AMT*)mg->mg_ptr;
 567        if (amtp->was_ok_am == PL_amagic_generation
 568 -         && amtp->was_ok_sub == PL_sub_generation) {
 569 +         && amtp->was_ok_sub == newgen) {
 570           return (bool)AMT_OVERLOADED(amtp);
 571        }
 572        sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
 573 @@ -1537,7 +1562,7 @@
 574
 575    Zero(&amt,1,AMT);
 576    amt.was_ok_am = PL_amagic_generation;
 577 -  amt.was_ok_sub = PL_sub_generation;
 578 +  amt.was_ok_sub = newgen;
 579    amt.fallback = AMGfallNO;
 580    amt.flags = 0;
 581
 582 @@ -1649,9 +1674,13 @@
 583      dVAR;
 584      MAGIC *mg;
 585      AMT *amtp;
 586 +    U32 newgen;
 587
 588      if (!stash || !HvNAME_get(stash))
 589          return NULL;
 590 +
 591 +    newgen = PL_sub_generation + HvMROMETA(stash)->sub_generation;
 592 +
 593      mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
 594      if (!mg) {
 595        do_update:
 596 @@ -1661,7 +1690,7 @@
 597      assert(mg);
 598      amtp = (AMT*)mg->mg_ptr;
 599      if ( amtp->was_ok_am != PL_amagic_generation
 600 -        || amtp->was_ok_sub != PL_sub_generation )
 601 +        || amtp->was_ok_sub != newgen )
 602         goto do_update;
 603      if (AMT_AMAGIC(amtp)) {
 604         CV * const ret = amtp->table[id];
 605 === lib/constant.pm
 606 ==================================================================
 607 --- lib/constant.pm     (/local/perl-current)   (revision 30426)
 608 +++ lib/constant.pm     (/local/perl-c3-subg)   (revision 30426)
 609 @@ -5,7 +5,7 @@
 610  use warnings::register;
 611
 612  our($VERSION, %declared);
 613 -$VERSION = '1.09';
 614 +$VERSION = '1.10';
 615
 616  #=======================================================================
 617
 618 @@ -109,7 +109,7 @@
 619                     # constants from cv_const_sv are read only. So we have to:
 620                     Internals::SvREADONLY($scalar, 1);
 621                     $symtab->{$name} = \$scalar;
 622 -                   &Internals::inc_sub_generation;
 623 +                   mro::invalidate_method_cache($pkg);
 624                 } else {
 625                     *$full_name = sub () { $scalar };
 626                 }
 627 === lib/overload.pm
 628 ==================================================================
 629 --- lib/overload.pm     (/local/perl-current)   (revision 30426)
 630 +++ lib/overload.pm     (/local/perl-c3-subg)   (revision 30426)
 631 @@ -1,6 +1,6 @@
 632  package overload;
 633
 634 -our $VERSION = '1.04';
 635 +our $VERSION = '1.05';
 636
 637  sub nil {}
 638
 639 @@ -95,12 +95,13 @@
 640
 641  sub mycan {                            # Real can would leave stubs.
 642    my ($package, $meth) = @_;
 643 -  return \*{$package . "::$meth"} if defined &{$package . "::$meth"};
 644 -  my $p;
 645 -  foreach $p (@{$package . "::ISA"}) {
 646 -    my $out = mycan($p, $meth);
 647 -    return $out if $out;
 648 +
 649 +  my $mro = mro::get_linear_isa($package);
 650 +  foreach my $p (@$mro) {
 651 +    my $fqmeth = $p . q{::} . $meth;
 652 +    return \*{$fqmeth} if defined &{$fqmeth};
 653    }
 654 +
 655    return undef;
 656  }
 657
 658 === lib/mro.pm
 659 ==================================================================
 660 --- lib/mro.pm  (/local/perl-current)   (revision 30426)
 661 +++ lib/mro.pm  (/local/perl-c3-subg)   (revision 30426)
 662 @@ -0,0 +1,162 @@
 663 +#      mro.pm
 664 +#
 665 +#      Copyright (c) 2007 Brandon L Black
 666 +#
 667 +#      You may distribute under the terms of either the GNU General Public
 668 +#      License or the Artistic License, as specified in the README file.
 669 +#
 670 +package mro;
 671 +use strict;
 672 +use warnings;
 673 +
 674 +our $VERSION = '0.01';
 675 +
 676 +sub import {
 677 +    mro::set_mro(scalar(caller), $_[1]) if $_[1];
 678 +}
 679 +
 680 +1;
 681 +
 682 +__END__
 683 +
 684 +=head1 NAME
 685 +
 686 +mro - Method Resolution Order
 687 +
 688 +=head1 SYNOPSIS
 689 +
 690 +  use mro 'dfs'; # enable DFS mro for this class (Perl default)
 691 +  use mro 'c3'; # enable C3 mro for this class
 692 +
 693 +=head1 DESCRIPTION
 694 +
 695 +TODO
 696 +
 697 +=head1 OVERVIEW
 698 +
 699 +TODO
 700 +
 701 +=head1 Functions
 702 +
 703 +NOTE: These are built into the perl core, there is no need
 704 +to do C<use mro> to access these functions.
 705 +
 706 +=head2 mro::get_linear_isa
 707 +
 708 +Arguments: classname[, type]
 709 +
 710 +Return an arrayref which is the linearized MRO of the given class.
 711 +Uses whichever MRO is currently in effect for that class by default,
 712 +or the given mro (either C<c3> or C<dfs> if specified as C<type>.
 713 +
 714 +=head2 mro::set_mro
 715 +
 716 +Arguments: classname, type
 717 +
 718 +Sets the MRO of the given class to the C<type> argument (either
 719 +C<c3> or C<dfs>).
 720 +
 721 +=head2 mro::get_mro
 722 +
 723 +Arguments: classname
 724 +
 725 +Returns the MRO of the given class (either C<c3> or C<dfs>)
 726 +
 727 +=head2 mro::get_global_sub_generation
 728 +
 729 +Arguments: none
 730 +
 731 +Returns the current value of C<PL_sub_generation>.
 732 +
 733 +=head2 mro::invalidate_all_method_caches
 734 +
 735 +Arguments: none
 736 +
 737 +Increments C<PL_sub_generation>, which invalidates method
 738 +caching in all packages.
 739 +
 740 +=head2 mro::get_sub_generation
 741 +
 742 +Arguments: classname
 743 +
 744 +Returns the current value of a given package's C<sub_generation>.
 745 +This is only incremented when necessary for that package.
 746 +
 747 +If one is trying to determine whether significant (method/cache-
 748 +affecting) changes have occured for a given stash since you last
 749 +checked, you should check both this and the global one above.
 750 +
 751 +=head2 mro::invalidate_method_cache
 752 +
 753 +Arguments: classname
 754 +
 755 +Invalidates the method cache of the given stash and any dependant
 756 +classes.
 757 +
 758 +=head2 next::method
 759 +
 760 +Similar in concept to C<SUPER>, but substantially different in
 761 +practice on C3-enabled classes.  One generally uses it like so:
 762 +
 763 +  sub some_method {
 764 +    my $self = shift;
 765 +
 766 +    my $superclass_answer = $self->next::method(@_);
 767 +    return $superclass_answer + 1;
 768 +  }
 769 +
 770 +One major difference in invocation is that you don't
 771 +(re-)specify the method name.  It forces you to always
 772 +use the same method name as the method you started in.
 773 +
 774 +It can be called on an object or a class, of course.
 775 +
 776 +The way it resolves which actual method to call is:
 777 +
 778 +1) First, it determines the linearized MRO of the
 779 +object or class it is being called on.
 780 +
 781 +2) Then, it determines the class and method name
 782 +of the context it was invoked from.
 783 +
 784 +3) Finally, it searches down the MRO list until
 785 +it reaches the contextually enclosing class, then
 786 +searches further down the MRO list for the next
 787 +method with the same name as the contextually
 788 +enclosing method.
 789 +
 790 +Failure to find a next method will result in an
 791 +exception being thrown (see below for alternatives).
 792 +
 793 +With the Perl-default DFS MRO, this doesn't
 794 +result in any substantial difference from the
 795 +method resolution behavior of C<SUPER>, but it
 796 +changes everything under C3 (this becomes obvious
 797 +when one realizes that the common classes in the
 798 +C3 linearizations of a given class and one of its
 799 +parents will not always be ordered the same for
 800 +both).  C<next::method>'s resolution behavior
 801 +gives the most consistent results (an object's
 802 +methods always resolve in that object's MRO
 803 +order).
 804 +
 805 +=head2 next::can
 806 +
 807 +Like C<next::method>, but just returns either
 808 +a code reference or C<undef> to indicate that
 809 +no further methods of this name exist.
 810 +
 811 +=head2 maybe::next::method
 812 +
 813 +In simple cases it is equivalent to:
 814 +
 815 +   $self->next::method(@_) if $self->next_can;
 816 +
 817 +But there are some cases where only this solution
 818 +works (like "goto &maybe::next::method");
 819 +
 820 +=head1 AUTHOR
 821 +
 822 +Brandon L Black, C<blblack@gmail.com>
 823 +
 824 +=cut
 825 === win32/Makefile
 826 ==================================================================
 827 --- win32/Makefile      (/local/perl-current)   (revision 30426)
 828 +++ win32/Makefile      (/local/perl-c3-subg)   (revision 30426)
 829 @@ -647,6 +647,7 @@
 830                 ..\dump.c       \
 831                 ..\globals.c    \
 832                 ..\gv.c         \
 833 +               ..\mro.c        \
 834                 ..\hv.c         \
 835                 ..\locale.c     \
 836                 ..\mathoms.c    \
 837 === win32/makefile.mk
 838 ==================================================================
 839 --- win32/makefile.mk   (/local/perl-current)   (revision 30426)
 840 +++ win32/makefile.mk   (/local/perl-c3-subg)   (revision 30426)
 841 @@ -816,6 +816,7 @@
 842                 ..\dump.c       \
 843                 ..\globals.c    \
 844                 ..\gv.c         \
 845 +               ..\mro.c        \
 846                 ..\hv.c         \
 847                 ..\locale.c     \
 848                 ..\mathoms.c    \
 849 === win32/Makefile.ce
 850 ==================================================================
 851 --- win32/Makefile.ce   (/local/perl-current)   (revision 30426)
 852 +++ win32/Makefile.ce   (/local/perl-c3-subg)   (revision 30426)
 853 @@ -571,6 +571,7 @@
 854                 ..\dump.c       \
 855                 ..\globals.c    \
 856                 ..\gv.c         \
 857 +               ..\mro.c        \
 858                 ..\hv.c         \
 859                 ..\mg.c         \
 860                 ..\op.c         \
 861 @@ -790,6 +791,7 @@
 862  $(DLLDIR)\dump.obj \
 863  $(DLLDIR)\globals.obj \
 864  $(DLLDIR)\gv.obj \
 865 +$(DLLDIR)\mro.obj \
 866  $(DLLDIR)\hv.obj \
 867  $(DLLDIR)\locale.obj \
 868  $(DLLDIR)\mathoms.obj \
 869 === t/TEST
 870 ==================================================================
 871 --- t/TEST      (/local/perl-current)   (revision 30426)
 872 +++ t/TEST      (/local/perl-c3-subg)   (revision 30426)
 873 @@ -104,7 +104,7 @@
 874  }
 875
 876  unless (@ARGV) {
 877 -    foreach my $dir (qw(base comp cmd run io op uni)) {
 878 +    foreach my $dir (qw(base comp cmd run io op uni mro)) {
 879         _find_tests($dir);
 880      }
 881      _find_tests("lib") unless $::core;
 882 === t/mro       (new directory)
 883 ==================================================================
 884 === t/mro/basic_01_dfs.t
 885 ==================================================================
 886 --- t/mro/basic_01_dfs.t        (/local/perl-current)   (revision 30426)
 887 +++ t/mro/basic_01_dfs.t        (/local/perl-c3-subg)   (revision 30426)
 888 @@ -0,0 +1,53 @@
 889 +#!./perl
 890 +
 891 +use strict;
 892 +use warnings;
 893 +BEGIN {
 894 +    unless (-d 'blib') {
 895 +        chdir 't' if -d 't';
 896 +        @INC = '../lib';
 897 +    }
 898 +}
 899 +
 900 +use Test::More tests => 4;
 901 +
 902 +=pod
 903 +
 904 +This tests the classic diamond inheritence pattern.
 905 +
 906 +   <A>
 907 +  /   \
 908 +<B>   <C>
 909 +  \   /
 910 +   <D>
 911 +
 912 +=cut
 913 +
 914 +{
 915 +    package Diamond_A;
 916 +    sub hello { 'Diamond_A::hello' }
 917 +}
 918 +{
 919 +    package Diamond_B;
 920 +    use base 'Diamond_A';
 921 +}
 922 +{
 923 +    package Diamond_C;
 924 +    use base 'Diamond_A';
 925 +
 926 +    sub hello { 'Diamond_C::hello' }
 927 +}
 928 +{
 929 +    package Diamond_D;
 930 +    use base ('Diamond_B', 'Diamond_C');
 931 +    use mro 'dfs';
 932 +}
 933 +
 934 +is_deeply(
 935 +    mro::get_linear_isa('Diamond_D'),
 936 +    [ qw(Diamond_D Diamond_B Diamond_A Diamond_C) ],
 937 +    '... got the right MRO for Diamond_D');
 938 +
 939 +is(Diamond_D->hello, 'Diamond_A::hello', '... method resolved itself as expected');
 940 +is(Diamond_D->can('hello')->(), 'Diamond_A::hello', '... can(method) resolved itself as expected');
 941 +is(UNIVERSAL::can("Diamond_D", 'hello')->(), 'Diamond_A::hello', '... can(method) resolved itself as expected');
 942 === t/mro/vulcan_c3.t
 943 ==================================================================
 944 --- t/mro/vulcan_c3.t   (/local/perl-current)   (revision 30426)
 945 +++ t/mro/vulcan_c3.t   (/local/perl-c3-subg)   (revision 30426)
 946 @@ -0,0 +1,73 @@
 947 +#!./perl
 948 +
 949 +use strict;
 950 +use warnings;
 951 +BEGIN {
 952 +    unless (-d 'blib') {
 953 +        chdir 't' if -d 't';
 954 +        @INC = '../lib';
 955 +    }
 956 +}
 957 +
 958 +use Test::More tests => 1;
 959 +use mro;
 960 +
 961 +=pod
 962 +
 963 +example taken from: L<http://gauss.gwydiondylan.org/books/drm/drm_50.html>
 964 +
 965 +         Object
 966 +           ^
 967 +           |
 968 +        LifeForm
 969 +         ^    ^
 970 +        /      \
 971 +   Sentient    BiPedal
 972 +      ^          ^
 973 +      |          |
 974 + Intelligent  Humanoid
 975 +       ^        ^
 976 +        \      /
 977 +         Vulcan
 978 +
 979 + define class <sentient> (<life-form>) end class;
 980 + define class <bipedal> (<life-form>) end class;
 981 + define class <intelligent> (<sentient>) end class;
 982 + define class <humanoid> (<bipedal>) end class;
 983 + define class <vulcan> (<intelligent>, <humanoid>) end class;
 984 +
 985 +=cut
 986 +
 987 +{
 988 +    package Object;
 989 +    use mro 'c3';
 990 +
 991 +    package LifeForm;
 992 +    use mro 'c3';
 993 +    use base 'Object';
 994 +
 995 +    package Sentient;
 996 +    use mro 'c3';
 997 +    use base 'LifeForm';
 998 +
 999 +    package BiPedal;
1000 +    use mro 'c3';
1001 +    use base 'LifeForm';
1002 +
1003 +    package Intelligent;
1004 +    use mro 'c3';
1005 +    use base 'Sentient';
1006 +
1007 +    package Humanoid;
1008 +    use mro 'c3';
1009 +    use base 'BiPedal';
1010 +
1011 +    package Vulcan;
1012 +    use mro 'c3';
1013 +    use base ('Intelligent', 'Humanoid');
1014 +}
1015 +
1016 +is_deeply(
1017 +    mro::get_linear_isa('Vulcan'),
1018 +    [ qw(Vulcan Intelligent Sentient Humanoid BiPedal LifeForm Object) ],
1019 +    '... got the right MRO for the Vulcan Dylan Example');
1020 === t/mro/basic_02_dfs.t
1021 ==================================================================
1022 --- t/mro/basic_02_dfs.t        (/local/perl-current)   (revision 30426)
1023 +++ t/mro/basic_02_dfs.t        (/local/perl-c3-subg)   (revision 30426)
1024 @@ -0,0 +1,121 @@
1025 +#!./perl
1026 +
1027 +use strict;
1028 +use warnings;
1029 +BEGIN {
1030 +    unless (-d 'blib') {
1031 +        chdir 't' if -d 't';
1032 +        @INC = '../lib';
1033 +    }
1034 +}
1035 +
1036 +use Test::More tests => 10;
1037 +
1038 +=pod
1039 +
1040 +This example is take from: http://www.python.org/2.3/mro.html
1041 +
1042 +"My first example"
1043 +class O: pass
1044 +class F(O): pass
1045 +class E(O): pass
1046 +class D(O): pass
1047 +class C(D,F): pass
1048 +class B(D,E): pass
1049 +class A(B,C): pass
1050 +
1051 +
1052 +                          6
1053 +                         ---
1054 +Level 3                 | O |                  (more general)
1055 +                      /  ---  \
1056 +                     /    |    \                      |
1057 +                    /     |     \                     |
1058 +                   /      |      \                    |
1059 +                  ---    ---    ---                   |
1060 +Level 2        3 | D | 4| E |  | F | 5                |
1061 +                  ---    ---    ---                   |
1062 +                   \  \ _ /       |                   |
1063 +                    \    / \ _    |                   |
1064 +                     \  /      \  |                   |
1065 +                      ---      ---                    |
1066 +Level 1            1 | B |    | C | 2                 |
1067 +                      ---      ---                    |
1068 +                        \      /                      |
1069 +                         \    /                      \ /
1070 +                           ---
1071 +Level 0                 0 | A |                (more specialized)
1072 +                           ---
1073 +
1074 +=cut
1075 +
1076 +{
1077 +    package Test::O;
1078 +    use mro 'dfs';
1079 +
1080 +    package Test::F;
1081 +    use mro 'dfs';
1082 +    use base 'Test::O';
1083 +
1084 +    package Test::E;
1085 +    use base 'Test::O';
1086 +    use mro 'dfs';
1087 +
1088 +    sub C_or_E { 'Test::E' }
1089 +
1090 +    package Test::D;
1091 +    use mro 'dfs';
1092 +    use base 'Test::O';
1093 +
1094 +    sub C_or_D { 'Test::D' }
1095 +
1096 +    package Test::C;
1097 +    use base ('Test::D', 'Test::F');
1098 +    use mro 'dfs';
1099 +
1100 +    sub C_or_D { 'Test::C' }
1101 +    sub C_or_E { 'Test::C' }
1102 +
1103 +    package Test::B;
1104 +    use mro 'dfs';
1105 +    use base ('Test::D', 'Test::E');
1106 +
1107 +    package Test::A;
1108 +    use base ('Test::B', 'Test::C');
1109 +    use mro 'dfs';
1110 +}
1111 +
1112 +is_deeply(
1113 +    mro::get_linear_isa('Test::F'),
1114 +    [ qw(Test::F Test::O) ],
1115 +    '... got the right MRO for Test::F');
1116 +
1117 +is_deeply(
1118 +    mro::get_linear_isa('Test::E'),
1119 +    [ qw(Test::E Test::O) ],
1120 +    '... got the right MRO for Test::E');
1121 +
1122 +is_deeply(
1123 +    mro::get_linear_isa('Test::D'),
1124 +    [ qw(Test::D Test::O) ],
1125 +    '... got the right MRO for Test::D');
1126 +
1127 +is_deeply(
1128 +    mro::get_linear_isa('Test::C'),
1129 +    [ qw(Test::C Test::D Test::O Test::F) ],
1130 +    '... got the right MRO for Test::C');
1131 +
1132 +is_deeply(
1133 +    mro::get_linear_isa('Test::B'),
1134 +    [ qw(Test::B Test::D Test::O Test::E) ],
1135 +    '... got the right MRO for Test::B');
1136 +
1137 +is_deeply(
1138 +    mro::get_linear_isa('Test::A'),
1139 +    [ qw(Test::A Test::B Test::D Test::O Test::E Test::C Test::F) ],
1140 +    '... got the right MRO for Test::A');
1141 +
1142 +is(Test::A->C_or_D, 'Test::D', '... got the expected method output');
1143 +is(Test::A->can('C_or_D')->(), 'Test::D', '... can got the expected method output');
1144 +is(Test::A->C_or_E, 'Test::E', '... got the expected method output');
1145 +is(Test::A->can('C_or_E')->(), 'Test::E', '... can got the expected method output');
1146 === t/mro/basic_03_dfs.t
1147 ==================================================================
1148 --- t/mro/basic_03_dfs.t        (/local/perl-current)   (revision 30426)
1149 +++ t/mro/basic_03_dfs.t        (/local/perl-c3-subg)   (revision 30426)
1150 @@ -0,0 +1,107 @@
1151 +#!./perl
1152 +
1153 +use strict;
1154 +use warnings;
1155 +BEGIN {
1156 +    unless (-d 'blib') {
1157 +        chdir 't' if -d 't';
1158 +        @INC = '../lib';
1159 +    }
1160 +}
1161 +
1162 +use Test::More tests => 4;
1163 +
1164 +=pod
1165 +
1166 +This example is take from: http://www.python.org/2.3/mro.html
1167 +
1168 +"My second example"
1169 +class O: pass
1170 +class F(O): pass
1171 +class E(O): pass
1172 +class D(O): pass
1173 +class C(D,F): pass
1174 +class B(E,D): pass
1175 +class A(B,C): pass
1176 +
1177 +                           6
1178 +                          ---
1179 +Level 3                  | O |
1180 +                       /  ---  \
1181 +                      /    |    \
1182 +                     /     |     \
1183 +                    /      |      \
1184 +                  ---     ---    ---
1185 +Level 2        2 | E | 4 | D |  | F | 5
1186 +                  ---     ---    ---
1187 +                   \      / \     /
1188 +                    \    /   \   /
1189 +                     \  /     \ /
1190 +                      ---     ---
1191 +Level 1            1 | B |   | C | 3
1192 +                      ---     ---
1193 +                       \       /
1194 +                        \     /
1195 +                          ---
1196 +Level 0                0 | A |
1197 +                          ---
1198 +
1199 +>>> A.mro()
1200 +(<class '__main__.A'>, <class '__main__.B'>, <class '__main__.E'>,
1201 +<class '__main__.C'>, <class '__main__.D'>, <class '__main__.F'>,
1202 +<type 'object'>)
1203 +
1204 +=cut
1205 +
1206 +{
1207 +    package Test::O;
1208 +    use mro 'dfs';
1209 +
1210 +    sub O_or_D { 'Test::O' }
1211 +    sub O_or_F { 'Test::O' }
1212 +
1213 +    package Test::F;
1214 +    use base 'Test::O';
1215 +    use mro 'dfs';
1216 +
1217 +    sub O_or_F { 'Test::F' }
1218 +
1219 +    package Test::E;
1220 +    use base 'Test::O';
1221 +    use mro 'dfs';
1222 +
1223 +    package Test::D;
1224 +    use base 'Test::O';
1225 +    use mro 'dfs';
1226 +
1227 +    sub O_or_D { 'Test::D' }
1228 +    sub C_or_D { 'Test::D' }
1229 +
1230 +    package Test::C;
1231 +    use base ('Test::D', 'Test::F');
1232 +    use mro 'dfs';
1233 +
1234 +    sub C_or_D { 'Test::C' }
1235 +
1236 +    package Test::B;
1237 +    use base ('Test::E', 'Test::D');
1238 +    use mro 'dfs';
1239 +
1240 +    package Test::A;
1241 +    use base ('Test::B', 'Test::C');
1242 +    use mro 'dfs';
1243 +}
1244 +
1245 +is_deeply(
1246 +    mro::get_linear_isa('Test::A'),
1247 +    [ qw(Test::A Test::B Test::E Test::O Test::D Test::C Test::F) ],
1248 +    '... got the right MRO for Test::A');
1249 +
1250 +is(Test::A->O_or_D, 'Test::O', '... got the right method dispatch');
1251 +is(Test::A->O_or_F, 'Test::O', '... got the right method dispatch');
1252 +
1253 +# NOTE:
1254 +# this test is particularly interesting because the p5 dispatch
1255 +# would actually call Test::D before Test::C and Test::D is a
1256 +# subclass of Test::C
1257 +is(Test::A->C_or_D, 'Test::D', '... got the right method dispatch');
1258 === t/mro/basic_04_dfs.t
1259 ==================================================================
1260 --- t/mro/basic_04_dfs.t        (/local/perl-current)   (revision 30426)
1261 +++ t/mro/basic_04_dfs.t        (/local/perl-c3-subg)   (revision 30426)
1262 @@ -0,0 +1,40 @@
1263 +#!./perl
1264 +
1265 +use strict;
1266 +use warnings;
1267 +BEGIN {
1268 +    unless (-d 'blib') {
1269 +        chdir 't' if -d 't';
1270 +        @INC = '../lib';
1271 +    }
1272 +}
1273 +
1274 +use Test::More tests => 1;
1275 +
1276 +=pod
1277 +
1278 +From the parrot test t/pmc/object-meths.t
1279 +
1280 + A   B A   E
1281 +  \ /   \ /
1282 +   C     D
1283 +    \   /
1284 +     \ /
1285 +      F
1286 +
1287 +=cut
1288 +
1289 +{
1290 +    package t::lib::A; use mro 'dfs';
1291 +    package t::lib::B; use mro 'dfs';
1292 +    package t::lib::E; use mro 'dfs';
1293 +    package t::lib::C; use mro 'dfs'; use base ('t::lib::A', 't::lib::B');
1294 +    package t::lib::D; use mro 'dfs'; use base ('t::lib::A', 't::lib::E');
1295 +    package t::lib::F; use mro 'dfs'; use base ('t::lib::C', 't::lib::D');
1296 +}
1297 +
1298 +is_deeply(
1299 +    mro::get_linear_isa('t::lib::F'),
1300 +    [ qw(t::lib::F t::lib::C t::lib::A t::lib::B t::lib::D t::lib::E) ],
1301 +    '... got the right MRO for t::lib::F');
1302 +
1303 === t/mro/basic_05_dfs.t
1304 ==================================================================
1305 --- t/mro/basic_05_dfs.t        (/local/perl-current)   (revision 30426)
1306 +++ t/mro/basic_05_dfs.t        (/local/perl-c3-subg)   (revision 30426)
1307 @@ -0,0 +1,61 @@
1308 +#!./perl
1309 +
1310 +use strict;
1311 +use warnings;
1312 +BEGIN {
1313 +    unless (-d 'blib') {
1314 +        chdir 't' if -d 't';
1315 +        @INC = '../lib';
1316 +    }
1317 +}
1318 +
1319 +use Test::More tests => 2;
1320 +
1321 +=pod
1322 +
1323 +This tests a strange bug found by Matt S. Trout
1324 +while building DBIx::Class. Thanks Matt!!!!
1325 +
1326 +   <A>
1327 +  /   \
1328 +<C>   <B>
1329 +  \   /
1330 +   <D>
1331 +
1332 +=cut
1333 +
1334 +{
1335 +    package Diamond_A;
1336 +    use mro 'dfs';
1337 +
1338 +    sub foo { 'Diamond_A::foo' }
1339 +}
1340 +{
1341 +    package Diamond_B;
1342 +    use base 'Diamond_A';
1343 +    use mro 'dfs';
1344 +
1345 +    sub foo { 'Diamond_B::foo => ' . (shift)->SUPER::foo }
1346 +}
1347 +{
1348 +    package Diamond_C;
1349 +    use mro 'dfs';
1350 +    use base 'Diamond_A';
1351 +
1352 +}
1353 +{
1354 +    package Diamond_D;
1355 +    use base ('Diamond_C', 'Diamond_B');
1356 +    use mro 'dfs';
1357 +
1358 +    sub foo { 'Diamond_D::foo => ' . (shift)->SUPER::foo }
1359 +}
1360 +
1361 +is_deeply(
1362 +    mro::get_linear_isa('Diamond_D'),
1363 +    [ qw(Diamond_D Diamond_C Diamond_A Diamond_B) ],
1364 +    '... got the right MRO for Diamond_D');
1365 +
1366 +is(Diamond_D->foo,
1367 +   'Diamond_D::foo => Diamond_A::foo',
1368 +   '... got the right next::method dispatch path');
1369 === t/mro/vulcan_dfs.t
1370 ==================================================================
1371 --- t/mro/vulcan_dfs.t  (/local/perl-current)   (revision 30426)
1372 +++ t/mro/vulcan_dfs.t  (/local/perl-c3-subg)   (revision 30426)
1373 @@ -0,0 +1,73 @@
1374 +#!./perl
1375 +
1376 +use strict;
1377 +use warnings;
1378 +BEGIN {
1379 +    unless (-d 'blib') {
1380 +        chdir 't' if -d 't';
1381 +        @INC = '../lib';
1382 +    }
1383 +}
1384 +
1385 +use Test::More tests => 1;
1386 +use mro;
1387 +
1388 +=pod
1389 +
1390 +example taken from: L<http://gauss.gwydiondylan.org/books/drm/drm_50.html>
1391 +
1392 +         Object
1393 +           ^
1394 +           |
1395 +        LifeForm
1396 +         ^    ^
1397 +        /      \
1398 +   Sentient    BiPedal
1399 +      ^          ^
1400 +      |          |
1401 + Intelligent  Humanoid
1402 +       ^        ^
1403 +        \      /
1404 +         Vulcan
1405 +
1406 + define class <sentient> (<life-form>) end class;
1407 + define class <bipedal> (<life-form>) end class;
1408 + define class <intelligent> (<sentient>) end class;
1409 + define class <humanoid> (<bipedal>) end class;
1410 + define class <vulcan> (<intelligent>, <humanoid>) end class;
1411 +
1412 +=cut
1413 +
1414 +{
1415 +    package Object;
1416 +    use mro 'dfs';
1417 +
1418 +    package LifeForm;
1419 +    use mro 'dfs';
1420 +    use base 'Object';
1421 +
1422 +    package Sentient;
1423 +    use mro 'dfs';
1424 +    use base 'LifeForm';
1425 +
1426 +    package BiPedal;
1427 +    use mro 'dfs';
1428 +    use base 'LifeForm';
1429 +
1430 +    package Intelligent;
1431 +    use mro 'dfs';
1432 +    use base 'Sentient';
1433 +
1434 +    package Humanoid;
1435 +    use mro 'dfs';
1436 +    use base 'BiPedal';
1437 +
1438 +    package Vulcan;
1439 +    use mro 'dfs';
1440 +    use base ('Intelligent', 'Humanoid');
1441 +}
1442 +
1443 +is_deeply(
1444 +    mro::get_linear_isa('Vulcan'),
1445 +    [ qw(Vulcan Intelligent Sentient LifeForm Object Humanoid BiPedal) ],
1446 +    '... got the right MRO for the Vulcan Dylan Example');
1447 === t/mro/dbic_c3.t
1448 ==================================================================
1449 --- t/mro/dbic_c3.t     (/local/perl-current)   (revision 30426)
1450 +++ t/mro/dbic_c3.t     (/local/perl-c3-subg)   (revision 30426)
1451 @@ -0,0 +1,125 @@
1452 +#!./perl
1453 +
1454 +use strict;
1455 +use warnings;
1456 +BEGIN {
1457 +    unless (-d 'blib') {
1458 +        chdir 't' if -d 't';
1459 +        @INC = '../lib';
1460 +    }
1461 +}
1462 +
1463 +use Test::More tests => 1;
1464 +
1465 +=pod
1466 +
1467 +This example is taken from the inheritance graph of DBIx::Class::Core in DBIx::Class v0.07002:
1468 +(No ASCII art this time, this graph is insane)
1469 +
1470 +The xx:: prefixes are just to be sure these bogus declarations never stomp on real ones
1471 +
1472 +=cut
1473 +
1474 +{
1475 +    package xx::DBIx::Class::Core; use mro 'c3';
1476 +    our @ISA = qw/
1477 +      xx::DBIx::Class::Serialize::Storable
1478 +      xx::DBIx::Class::InflateColumn
1479 +      xx::DBIx::Class::Relationship
1480 +      xx::DBIx::Class::PK::Auto
1481 +      xx::DBIx::Class::PK
1482 +      xx::DBIx::Class::Row
1483 +      xx::DBIx::Class::ResultSourceProxy::Table
1484 +      xx::DBIx::Class::AccessorGroup
1485 +    /;
1486 +
1487 +    package xx::DBIx::Class::InflateColumn; use mro 'c3';
1488 +    our @ISA = qw/ xx::DBIx::Class::Row /;
1489 +
1490 +    package xx::DBIx::Class::Row; use mro 'c3';
1491 +    our @ISA = qw/ xx::DBIx::Class /;
1492 +
1493 +    package xx::DBIx::Class; use mro 'c3';
1494 +    our @ISA = qw/
1495 +      xx::DBIx::Class::Componentised
1496 +      xx::Class::Data::Accessor
1497 +    /;
1498 +
1499 +    package xx::DBIx::Class::Relationship; use mro 'c3';
1500 +    our @ISA = qw/
1501 +      xx::DBIx::Class::Relationship::Helpers
1502 +      xx::DBIx::Class::Relationship::Accessor
1503 +      xx::DBIx::Class::Relationship::CascadeActions
1504 +      xx::DBIx::Class::Relationship::ProxyMethods
1505 +      xx::DBIx::Class::Relationship::Base
1506 +      xx::DBIx::Class
1507 +    /;
1508 +
1509 +    package xx::DBIx::Class::Relationship::Helpers; use mro 'c3';
1510 +    our @ISA = qw/
1511 +      xx::DBIx::Class::Relationship::HasMany
1512 +      xx::DBIx::Class::Relationship::HasOne
1513 +      xx::DBIx::Class::Relationship::BelongsTo
1514 +      xx::DBIx::Class::Relationship::ManyToMany
1515 +    /;
1516 +
1517 +    package xx::DBIx::Class::Relationship::ProxyMethods; use mro 'c3';
1518 +    our @ISA = qw/ xx::DBIx::Class /;
1519 +
1520 +    package xx::DBIx::Class::Relationship::Base; use mro 'c3';
1521 +    our @ISA = qw/ xx::DBIx::Class /;
1522 +
1523 +    package xx::DBIx::Class::PK::Auto; use mro 'c3';
1524 +    our @ISA = qw/ xx::DBIx::Class /;
1525 +
1526 +    package xx::DBIx::Class::PK; use mro 'c3';
1527 +    our @ISA = qw/ xx::DBIx::Class::Row /;
1528 +
1529 +    package xx::DBIx::Class::ResultSourceProxy::Table; use mro 'c3';
1530 +    our @ISA = qw/
1531 +      xx::DBIx::Class::AccessorGroup
1532 +      xx::DBIx::Class::ResultSourceProxy
1533 +    /;
1534 +
1535 +    package xx::DBIx::Class::ResultSourceProxy; use mro 'c3';
1536 +    our @ISA = qw/ xx::DBIx::Class /;
1537 +
1538 +    package xx::Class::Data::Accessor; our @ISA = (); use mro 'c3';
1539 +    package xx::DBIx::Class::Relationship::HasMany; our @ISA = (); use mro 'c3';
1540 +    package xx::DBIx::Class::Relationship::HasOne; our @ISA = (); use mro 'c3';
1541 +    package xx::DBIx::Class::Relationship::BelongsTo; our @ISA = (); use mro 'c3';
1542 +    package xx::DBIx::Class::Relationship::ManyToMany; our @ISA = (); use mro 'c3';
1543 +    package xx::DBIx::Class::Componentised; our @ISA = (); use mro 'c3';
1544 +    package xx::DBIx::Class::AccessorGroup; our @ISA = (); use mro 'c3';
1545 +    package xx::DBIx::Class::Serialize::Storable; our @ISA = (); use mro 'c3';
1546 +    package xx::DBIx::Class::Relationship::Accessor; our @ISA = (); use mro 'c3';
1547 +    package xx::DBIx::Class::Relationship::CascadeActions; our @ISA = (); use mro 'c3';
1548 +}
1549 +
1550 +is_deeply(
1551 +    mro::get_linear_isa('xx::DBIx::Class::Core'),
1552 +    [qw/
1553 +        xx::DBIx::Class::Core
1554 +        xx::DBIx::Class::Serialize::Storable
1555 +        xx::DBIx::Class::InflateColumn
1556 +        xx::DBIx::Class::Relationship
1557 +        xx::DBIx::Class::Relationship::Helpers
1558 +        xx::DBIx::Class::Relationship::HasMany
1559 +        xx::DBIx::Class::Relationship::HasOne
1560 +        xx::DBIx::Class::Relationship::BelongsTo
1561 +        xx::DBIx::Class::Relationship::ManyToMany
1562 +        xx::DBIx::Class::Relationship::Accessor
1563 +        xx::DBIx::Class::Relationship::CascadeActions
1564 +        xx::DBIx::Class::Relationship::ProxyMethods
1565 +        xx::DBIx::Class::Relationship::Base
1566 +        xx::DBIx::Class::PK::Auto
1567 +        xx::DBIx::Class::PK
1568 +        xx::DBIx::Class::Row
1569 +        xx::DBIx::Class::ResultSourceProxy::Table
1570 +        xx::DBIx::Class::AccessorGroup
1571 +        xx::DBIx::Class::ResultSourceProxy
1572 +        xx::DBIx::Class
1573 +        xx::DBIx::Class::Componentised
1574 +        xx::Class::Data::Accessor
1575 +    /],
1576 +    '... got the right C3 merge order for xx::DBIx::Class::Core');
1577 === t/mro/method_caching.t
1578 ==================================================================
1579 --- t/mro/method_caching.t      (/local/perl-current)   (revision 30426)
1580 +++ t/mro/method_caching.t      (/local/perl-c3-subg)   (revision 30426)
1581 @@ -0,0 +1,46 @@
1582 +#!./perl
1583 +
1584 +use strict;
1585 +use warnings;
1586 +no warnings 'redefine'; # we do a lot of this
1587 +no warnings 'prototype'; # we do a lot of this
1588 +
1589 +BEGIN {
1590 +    unless (-d 'blib') {
1591 +        chdir 't' if -d 't';
1592 +        @INC = '../lib';
1593 +    }
1594 +}
1595 +
1596 +use Test::More;
1597 +
1598 +{
1599 +    package MCTest::Base;
1600 +    sub foo { return $_[1]+1 };
1601 +    sub bar { 42 };
1602 +
1603 +    package MCTest::Derived;
1604 +    our @ISA = qw/MCTest::Base/;
1605 +}
1606 +
1607 +# These are various ways of re-defining MCTest::Base::foo and checking whether the method is cached when it shouldn't be
1608 +my @testsubs = (
1609 +    sub { eval 'sub MCTest::Base::foo { return $_[1]+2 }'; is(MCTest::Derived->foo(0), 2); },
1610 +    sub { eval 'sub MCTest::Base::foo($) { return $_[1]+3 }'; is(MCTest::Derived->foo(0), 3); },
1611 +    sub { eval 'sub MCTest::Base::foo($) { 4 }'; is(MCTest::Derived->foo(0), 4); },
1612 +    sub { *MCTest::Base::foo = sub { $_[1]+5 }; is(MCTest::Derived->foo(0), 5); },
1613 +    sub { local *MCTest::Base::foo = sub { $_[1]+6 }; is(MCTest::Derived->foo(0), 6); },
1614 +    sub { is(MCTest::Derived->foo(0), 5); },
1615 +    sub { sub FFF { $_[1]+9 }; local *MCTest::Base::foo = *FFF; is(MCTest::Derived->foo(0), 9); },
1616 +    sub { is(MCTest::Derived->foo(0), 5); },
1617 +    sub { *ASDF::asdf = sub { $_[1]+7 }; *MCTest::Base::foo = \&ASDF::asdf; is(MCTest::Derived->foo(0), 7); },
1618 +    sub { *ASDF::asdf = sub { $_[1]+7 }; *MCTest::Base::foo = \&ASDF::asdf; is(MCTest::Derived->foo(0), 7); },
1619 +    sub { undef *MCTest::Base::foo; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); },
1620 +    sub { sub MCTest::Base::foo($); *MCTest::Base::foo = \&ASDF::asdf; is(MCTest::Derived->foo(0), 7); },
1621 +    sub { *XYZ = sub { $_[1]+8 }; ${MCTest::Base::}{foo} = \&XYZ; is(MCTest::Derived->foo(0), 8); },
1622 +);
1623 +
1624 +plan tests => scalar(@testsubs) + 1;
1625 +
1626 +is(MCTest::Derived->foo(0), 1);
1627 +$_->() for (@testsubs);
1628 === t/mro/complex_c3.t
1629 ==================================================================
1630 --- t/mro/complex_c3.t  (/local/perl-current)   (revision 30426)
1631 +++ t/mro/complex_c3.t  (/local/perl-c3-subg)   (revision 30426)
1632 @@ -0,0 +1,148 @@
1633 +#!./perl
1634 +
1635 +use strict;
1636 +use warnings;
1637 +BEGIN {
1638 +    unless (-d 'blib') {
1639 +        chdir 't' if -d 't';
1640 +        @INC = '../lib';
1641 +    }
1642 +}
1643 +
1644 +use Test::More tests => 12;
1645 +
1646 +=pod
1647 +
1648 +This example is taken from: http://rt.cpan.org/Public/Bug/Display.html?id=20879
1649 +
1650 +               ---     ---     ---
1651 +Level 5     8 | A | 9 | B | A | C |    (More General)
1652 +               ---     ---     ---       V
1653 +                  \     |     /          |
1654 +                   \    |    /           |
1655 +                    \   |   /            |
1656 +                     \  |  /             |
1657 +                       ---               |
1658 +Level 4             7 | D |              |
1659 +                       ---               |
1660 +                      /   \              |
1661 +                     /     \             |
1662 +                  ---       ---          |
1663 +Level 3        4 | G |   6 | E |         |
1664 +                  ---       ---          |
1665 +                   |         |           |
1666 +                   |         |           |
1667 +                  ---       ---          |
1668 +Level 2        3 | H |   5 | F |         |
1669 +                  ---       ---          |
1670 +                      \   /  |           |
1671 +                       \ /   |           |
1672 +                        \    |           |
1673 +                       / \   |           |
1674 +                      /   \  |           |
1675 +                  ---       ---          |
1676 +Level 1        1 | J |   2 | I |         |
1677 +                  ---       ---          |
1678 +                    \       /            |
1679 +                     \     /             |
1680 +                       ---               v
1681 +Level 0             0 | K |            (More Specialized)
1682 +                       ---
1683 +
1684 +
1685 +0123456789A
1686 +KJIHGFEDABC
1687 +
1688 +=cut
1689 +
1690 +{
1691 +    package Test::A; use mro 'c3';
1692 +
1693 +    package Test::B; use mro 'c3';
1694 +
1695 +    package Test::C; use mro 'c3';
1696 +
1697 +    package Test::D; use mro 'c3';
1698 +    use base qw/Test::A Test::B Test::C/;
1699 +
1700 +    package Test::E; use mro 'c3';
1701 +    use base qw/Test::D/;
1702 +
1703 +    package Test::F; use mro 'c3';
1704 +    use base qw/Test::E/;
1705 +    sub testmeth { "wrong" }
1706 +
1707 +    package Test::G; use mro 'c3';
1708 +    use base qw/Test::D/;
1709 +
1710 +    package Test::H; use mro 'c3';
1711 +    use base qw/Test::G/;
1712 +
1713 +    package Test::I; use mro 'c3';
1714 +    use base qw/Test::H Test::F/;
1715 +    sub testmeth { "right" }
1716 +
1717 +    package Test::J; use mro 'c3';
1718 +    use base qw/Test::F/;
1719 +
1720 +    package Test::K; use mro 'c3';
1721 +    use base qw/Test::J Test::I/;
1722 +    sub testmeth { shift->next::method }
1723 +}
1724 +
1725 +is_deeply(
1726 +    mro::get_linear_isa('Test::A'),
1727 +    [ qw(Test::A) ],
1728 +    '... got the right C3 merge order for Test::A');
1729 +
1730 +is_deeply(
1731 +    mro::get_linear_isa('Test::B'),
1732 +    [ qw(Test::B) ],
1733 +    '... got the right C3 merge order for Test::B');
1734 +
1735 +is_deeply(
1736 +    mro::get_linear_isa('Test::C'),
1737 +    [ qw(Test::C) ],
1738 +    '... got the right C3 merge order for Test::C');
1739 +
1740 +is_deeply(
1741 +    mro::get_linear_isa('Test::D'),
1742 +    [ qw(Test::D Test::A Test::B Test::C) ],
1743 +    '... got the right C3 merge order for Test::D');
1744 +
1745 +is_deeply(
1746 +    mro::get_linear_isa('Test::E'),
1747 +    [ qw(Test::E Test::D Test::A Test::B Test::C) ],
1748 +    '... got the right C3 merge order for Test::E');
1749 +
1750 +is_deeply(
1751 +    mro::get_linear_isa('Test::F'),
1752 +    [ qw(Test::F Test::E Test::D Test::A Test::B Test::C) ],
1753 +    '... got the right C3 merge order for Test::F');
1754 +
1755 +is_deeply(
1756 +    mro::get_linear_isa('Test::G'),
1757 +    [ qw(Test::G Test::D Test::A Test::B Test::C) ],
1758 +    '... got the right C3 merge order for Test::G');
1759 +
1760 +is_deeply(
1761 +    mro::get_linear_isa('Test::H'),
1762 +    [ qw(Test::H Test::G Test::D Test::A Test::B Test::C) ],
1763 +    '... got the right C3 merge order for Test::H');
1764 +
1765 +is_deeply(
1766 +    mro::get_linear_isa('Test::I'),
1767 +    [ qw(Test::I Test::H Test::G Test::F Test::E Test::D Test::A Test::B Test::C) ],
1768 +    '... got the right C3 merge order for Test::I');
1769 +
1770 +is_deeply(
1771 +    mro::get_linear_isa('Test::J'),
1772 +    [ qw(Test::J Test::F Test::E Test::D Test::A Test::B Test::C) ],
1773 +    '... got the right C3 merge order for Test::J');
1774 +
1775 +is_deeply(
1776 +    mro::get_linear_isa('Test::K'),
1777 +    [ qw(Test::K Test::J Test::I Test::H Test::G Test::F Test::E Test::D Test::A Test::B Test::C) ],
1778 +    '... got the right C3 merge order for Test::K');
1779 +
1780 +is(Test::K->testmeth(), "right", 'next::method working ok');
1781 === t/mro/dbic_dfs.t
1782 ==================================================================
1783 --- t/mro/dbic_dfs.t    (/local/perl-current)   (revision 30426)
1784 +++ t/mro/dbic_dfs.t    (/local/perl-c3-subg)   (revision 30426)
1785 @@ -0,0 +1,125 @@
1786 +#!./perl
1787 +
1788 +use strict;
1789 +use warnings;
1790 +BEGIN {
1791 +    unless (-d 'blib') {
1792 +        chdir 't' if -d 't';
1793 +        @INC = '../lib';
1794 +    }
1795 +}
1796 +
1797 +use Test::More tests => 1;
1798 +
1799 +=pod
1800 +
1801 +This example is taken from the inheritance graph of DBIx::Class::Core in DBIx::Class v0.07002:
1802 +(No ASCII art this time, this graph is insane)
1803 +
1804 +The xx:: prefixes are just to be sure these bogus declarations never stomp on real ones
1805 +
1806 +=cut
1807 +
1808 +{
1809 +    package xx::DBIx::Class::Core; use mro 'dfs';
1810 +    our @ISA = qw/
1811 +      xx::DBIx::Class::Serialize::Storable
1812 +      xx::DBIx::Class::InflateColumn
1813 +      xx::DBIx::Class::Relationship
1814 +      xx::DBIx::Class::PK::Auto
1815 +      xx::DBIx::Class::PK
1816 +      xx::DBIx::Class::Row
1817 +      xx::DBIx::Class::ResultSourceProxy::Table
1818 +      xx::DBIx::Class::AccessorGroup
1819 +    /;
1820 +
1821 +    package xx::DBIx::Class::InflateColumn; use mro 'dfs';
1822 +    our @ISA = qw/ xx::DBIx::Class::Row /;
1823 +
1824 +    package xx::DBIx::Class::Row; use mro 'dfs';
1825 +    our @ISA = qw/ xx::DBIx::Class /;
1826 +
1827 +    package xx::DBIx::Class; use mro 'dfs';
1828 +    our @ISA = qw/
1829 +      xx::DBIx::Class::Componentised
1830 +      xx::Class::Data::Accessor
1831 +    /;
1832 +
1833 +    package xx::DBIx::Class::Relationship; use mro 'dfs';
1834 +    our @ISA = qw/
1835 +      xx::DBIx::Class::Relationship::Helpers
1836 +      xx::DBIx::Class::Relationship::Accessor
1837 +      xx::DBIx::Class::Relationship::CascadeActions
1838 +      xx::DBIx::Class::Relationship::ProxyMethods
1839 +      xx::DBIx::Class::Relationship::Base
1840 +      xx::DBIx::Class
1841 +    /;
1842 +
1843 +    package xx::DBIx::Class::Relationship::Helpers; use mro 'dfs';
1844 +    our @ISA = qw/
1845 +      xx::DBIx::Class::Relationship::HasMany
1846 +      xx::DBIx::Class::Relationship::HasOne
1847 +      xx::DBIx::Class::Relationship::BelongsTo
1848 +      xx::DBIx::Class::Relationship::ManyToMany
1849 +    /;
1850 +
1851 +    package xx::DBIx::Class::Relationship::ProxyMethods; use mro 'dfs';
1852 +    our @ISA = qw/ xx::DBIx::Class /;
1853 +
1854 +    package xx::DBIx::Class::Relationship::Base; use mro 'dfs';
1855 +    our @ISA = qw/ xx::DBIx::Class /;
1856 +
1857 +    package xx::DBIx::Class::PK::Auto; use mro 'dfs';
1858 +    our @ISA = qw/ xx::DBIx::Class /;
1859 +
1860 +    package xx::DBIx::Class::PK; use mro 'dfs';
1861 +    our @ISA = qw/ xx::DBIx::Class::Row /;
1862 +
1863 +    package xx::DBIx::Class::ResultSourceProxy::Table; use mro 'dfs';
1864 +    our @ISA = qw/
1865 +      xx::DBIx::Class::AccessorGroup
1866 +      xx::DBIx::Class::ResultSourceProxy
1867 +    /;
1868 +
1869 +    package xx::DBIx::Class::ResultSourceProxy; use mro 'dfs';
1870 +    our @ISA = qw/ xx::DBIx::Class /;
1871 +
1872 +    package xx::Class::Data::Accessor; our @ISA = (); use mro 'dfs';
1873 +    package xx::DBIx::Class::Relationship::HasMany; our @ISA = (); use mro 'dfs';
1874 +    package xx::DBIx::Class::Relationship::HasOne; our @ISA = (); use mro 'dfs';
1875 +    package xx::DBIx::Class::Relationship::BelongsTo; our @ISA = (); use mro 'dfs';
1876 +    package xx::DBIx::Class::Relationship::ManyToMany; our @ISA = (); use mro 'dfs';
1877 +    package xx::DBIx::Class::Componentised; our @ISA = (); use mro 'dfs';
1878 +    package xx::DBIx::Class::AccessorGroup; our @ISA = (); use mro 'dfs';
1879 +    package xx::DBIx::Class::Serialize::Storable; our @ISA = (); use mro 'dfs';
1880 +    package xx::DBIx::Class::Relationship::Accessor; our @ISA = (); use mro 'dfs';
1881 +    package xx::DBIx::Class::Relationship::CascadeActions; our @ISA = (); use mro 'dfs';
1882 +}
1883 +
1884 +is_deeply(
1885 +    mro::get_linear_isa('xx::DBIx::Class::Core'),
1886 +    [qw/
1887 +        xx::DBIx::Class::Core
1888 +        xx::DBIx::Class::Serialize::Storable
1889 +        xx::DBIx::Class::InflateColumn
1890 +        xx::DBIx::Class::Row
1891 +        xx::DBIx::Class
1892 +        xx::DBIx::Class::Componentised
1893 +        xx::Class::Data::Accessor
1894 +        xx::DBIx::Class::Relationship
1895 +        xx::DBIx::Class::Relationship::Helpers
1896 +        xx::DBIx::Class::Relationship::HasMany
1897 +        xx::DBIx::Class::Relationship::HasOne
1898 +        xx::DBIx::Class::Relationship::BelongsTo
1899 +        xx::DBIx::Class::Relationship::ManyToMany
1900 +        xx::DBIx::Class::Relationship::Accessor
1901 +        xx::DBIx::Class::Relationship::CascadeActions
1902 +        xx::DBIx::Class::Relationship::ProxyMethods
1903 +        xx::DBIx::Class::Relationship::Base
1904 +        xx::DBIx::Class::PK::Auto
1905 +        xx::DBIx::Class::PK
1906 +        xx::DBIx::Class::ResultSourceProxy::Table
1907 +        xx::DBIx::Class::AccessorGroup
1908 +        xx::DBIx::Class::ResultSourceProxy
1909 +    /],
1910 +    '... got the right DFS merge order for xx::DBIx::Class::Core');
1911 === t/mro/recursion_c3.t
1912 ==================================================================
1913 --- t/mro/recursion_c3.t        (/local/perl-current)   (revision 30426)
1914 +++ t/mro/recursion_c3.t        (/local/perl-c3-subg)   (revision 30426)
1915 @@ -0,0 +1,90 @@
1916 +#!./perl
1917 +
1918 +use strict;
1919 +use warnings;
1920 +BEGIN {
1921 +    unless (-d 'blib') {
1922 +        chdir 't' if -d 't';
1923 +        @INC = '../lib';
1924 +    }
1925 +}
1926 +
1927 +use Test::More;
1928 +use mro;
1929 +
1930 +# XXX needs translation back to classes, etc
1931 +
1932 +plan skip_all => "Your system has no SIGALRM" if !exists $SIG{ALRM};
1933 +plan tests => 8;
1934 +
1935 +=pod
1936 +
1937 +These are like the 010_complex_merge_classless test,
1938 +but an infinite loop has been made in the heirarchy,
1939 +to test that we can fail cleanly instead of going
1940 +into an infinite loop
1941 +
1942 +=cut
1943 +
1944 +# initial setup, everything sane
1945 +{
1946 +    package K;
1947 +    our @ISA = qw/J I/;
1948 +    package J;
1949 +    our @ISA = qw/F/;
1950 +    package I;
1951 +    our @ISA = qw/H F/;
1952 +    package H;
1953 +    our @ISA = qw/G/;
1954 +    package G;
1955 +    our @ISA = qw/D/;
1956 +    package F;
1957 +    our @ISA = qw/E/;
1958 +    package E;
1959 +    our @ISA = qw/D/;
1960 +    package D;
1961 +    our @ISA = qw/A B C/;
1962 +    package C;
1963 +    our @ISA = qw//;
1964 +    package B;
1965 +    our @ISA = qw//;
1966 +    package A;
1967 +    our @ISA = qw//;
1968 +}
1969 +
1970 +# A series of 8 abberations that would cause infinite loops,
1971 +#  each one undoing the work of the previous
1972 +my @loopies = (
1973 +    sub { @E::ISA = qw/F/ },
1974 +    sub { @E::ISA = qw/D/; @C::ISA = qw/F/ },
1975 +    sub { @C::ISA = qw//; @A::ISA = qw/K/ },
1976 +    sub { @A::ISA = qw//; @J::ISA = qw/F K/ },
1977 +    sub { @J::ISA = qw/F/; @H::ISA = qw/K G/ },
1978 +    sub { @H::ISA = qw/G/; @B::ISA = qw/B/ },
1979 +    sub { @B::ISA = qw//; @K::ISA = qw/K J I/ },
1980 +    sub { @K::ISA = qw/J I/; @D::ISA = qw/A H B C/ },
1981 +);
1982 +
1983 +foreach my $loopy (@loopies) {
1984 +    eval {
1985 +        local $SIG{ALRM} = sub { die "ALRMTimeout" };
1986 +        alarm(3);
1987 +        $loopy->();
1988 +        mro::get_linear_isa('K', 'c3');
1989 +    };
1990 +
1991 +    if(my $err = $@) {
1992 +        if($err =~ /ALRMTimeout/) {
1993 +            ok(0, "Loop terminated by SIGALRM");
1994 +        }
1995 +        elsif($err =~ /Recursive inheritance detected/) {
1996 +            ok(1, "Graceful exception thrown");
1997 +        }
1998 +        else {
1999 +            ok(0, "Unrecognized exception: $err");
2000 +        }
2001 +    }
2002 +    else {
2003 +        ok(0, "Infinite loop apparently succeeded???");
2004 +    }
2005 +}
2006 === t/mro/overload_c3.t
2007 ==================================================================
2008 --- t/mro/overload_c3.t (/local/perl-current)   (revision 30426)
2009 +++ t/mro/overload_c3.t (/local/perl-c3-subg)   (revision 30426)
2010 @@ -0,0 +1,54 @@
2011 +#!./perl
2012 +
2013 +use strict;
2014 +use warnings;
2015 +BEGIN {
2016 +    unless (-d 'blib') {
2017 +        chdir 't' if -d 't';
2018 +        @INC = '../lib';
2019 +    }
2020 +}
2021 +
2022 +use Test::More tests => 7;
2023 +
2024 +{
2025 +    package BaseTest;
2026 +    use strict;
2027 +    use warnings;
2028 +    use mro 'c3';
2029 +
2030 +    package OverloadingTest;
2031 +    use strict;
2032 +    use warnings;
2033 +    use mro 'c3';
2034 +    use base 'BaseTest';
2035 +    use overload '""' => sub { ref(shift) . " stringified" },
2036 +                 fallback => 1;
2037 +
2038 +    sub new { bless {} => shift }
2039 +
2040 +    package InheritingFromOverloadedTest;
2041 +    use strict;
2042 +    use warnings;
2043 +    use base 'OverloadingTest';
2044 +    use mro 'c3';
2045 +}
2046 +
2047 +my $x = InheritingFromOverloadedTest->new();
2048 +isa_ok($x, 'InheritingFromOverloadedTest');
2049 +
2050 +my $y = OverloadingTest->new();
2051 +isa_ok($y, 'OverloadingTest');
2052 +
2053 +is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing');
2054 +is("$y", 'OverloadingTest stringified', '... got the right value when stringifing');
2055 +
2056 +ok(($y eq 'OverloadingTest stringified'), '... eq was handled correctly');
2057 +
2058 +my $result;
2059 +eval {
2060 +    $result = $x eq 'InheritingFromOverloadedTest stringified'
2061 +};
2062 +ok(!$@, '... this should not throw an exception');
2063 +ok($result, '... and we should get the true value');
2064 +
2065 === t/mro/complex_dfs.t
2066 ==================================================================
2067 --- t/mro/complex_dfs.t (/local/perl-current)   (revision 30426)
2068 +++ t/mro/complex_dfs.t (/local/perl-c3-subg)   (revision 30426)
2069 @@ -0,0 +1,143 @@
2070 +#!./perl
2071 +
2072 +use strict;
2073 +use warnings;
2074 +BEGIN {
2075 +    unless (-d 'blib') {
2076 +        chdir 't' if -d 't';
2077 +        @INC = '../lib';
2078 +    }
2079 +}
2080 +
2081 +use Test::More tests => 11;
2082 +
2083 +=pod
2084 +
2085 +This example is taken from: http://rt.cpan.org/Public/Bug/Display.html?id=20879
2086 +
2087 +               ---     ---     ---
2088 +Level 5     8 | A | 9 | B | A | C |    (More General)
2089 +               ---     ---     ---       V
2090 +                  \     |     /          |
2091 +                   \    |    /           |
2092 +                    \   |   /            |
2093 +                     \  |  /             |
2094 +                       ---               |
2095 +Level 4             7 | D |              |
2096 +                       ---               |
2097 +                      /   \              |
2098 +                     /     \             |
2099 +                  ---       ---          |
2100 +Level 3        4 | G |   6 | E |         |
2101 +                  ---       ---          |
2102 +                   |         |           |
2103 +                   |         |           |
2104 +                  ---       ---          |
2105 +Level 2        3 | H |   5 | F |         |
2106 +                  ---       ---          |
2107 +                      \   /  |           |
2108 +                       \ /   |           |
2109 +                        \    |           |
2110 +                       / \   |           |
2111 +                      /   \  |           |
2112 +                  ---       ---          |
2113 +Level 1        1 | J |   2 | I |         |
2114 +                  ---       ---          |
2115 +                    \       /            |
2116 +                     \     /             |
2117 +                       ---               v
2118 +Level 0             0 | K |            (More Specialized)
2119 +                       ---
2120 +
2121 +
2122 +0123456789A
2123 +KJIHGFEDABC
2124 +
2125 +=cut
2126 +
2127 +{
2128 +    package Test::A; use mro 'dfs';
2129 +
2130 +    package Test::B; use mro 'dfs';
2131 +
2132 +    package Test::C; use mro 'dfs';
2133 +
2134 +    package Test::D; use mro 'dfs';
2135 +    use base qw/Test::A Test::B Test::C/;
2136 +
2137 +    package Test::E; use mro 'dfs';
2138 +    use base qw/Test::D/;
2139 +
2140 +    package Test::F; use mro 'dfs';
2141 +    use base qw/Test::E/;
2142 +
2143 +    package Test::G; use mro 'dfs';
2144 +    use base qw/Test::D/;
2145 +
2146 +    package Test::H; use mro 'dfs';
2147 +    use base qw/Test::G/;
2148 +
2149 +    package Test::I; use mro 'dfs';
2150 +    use base qw/Test::H Test::F/;
2151 +
2152 +    package Test::J; use mro 'dfs';
2153 +    use base qw/Test::F/;
2154 +
2155 +    package Test::K; use mro 'dfs';
2156 +    use base qw/Test::J Test::I/;
2157 +}
2158 +
2159 +is_deeply(
2160 +    mro::get_linear_isa('Test::A'),
2161 +    [ qw(Test::A) ],
2162 +    '... got the right DFS merge order for Test::A');
2163 +
2164 +is_deeply(
2165 +    mro::get_linear_isa('Test::B'),
2166 +    [ qw(Test::B) ],
2167 +    '... got the right DFS merge order for Test::B');
2168 +
2169 +is_deeply(
2170 +    mro::get_linear_isa('Test::C'),
2171 +    [ qw(Test::C) ],
2172 +    '... got the right DFS merge order for Test::C');
2173 +
2174 +is_deeply(
2175 +    mro::get_linear_isa('Test::D'),
2176 +    [ qw(Test::D Test::A Test::B Test::C) ],
2177 +    '... got the right DFS merge order for Test::D');
2178 +
2179 +is_deeply(
2180 +    mro::get_linear_isa('Test::E'),
2181 +    [ qw(Test::E Test::D Test::A Test::B Test::C) ],
2182 +    '... got the right DFS merge order for Test::E');
2183 +
2184 +is_deeply(
2185 +    mro::get_linear_isa('Test::F'),
2186 +    [ qw(Test::F Test::E Test::D Test::A Test::B Test::C) ],
2187 +    '... got the right DFS merge order for Test::F');
2188 +
2189 +is_deeply(
2190 +    mro::get_linear_isa('Test::G'),
2191 +    [ qw(Test::G Test::D Test::A Test::B Test::C) ],
2192 +    '... got the right DFS merge order for Test::G');
2193 +
2194 +is_deeply(
2195 +    mro::get_linear_isa('Test::H'),
2196 +    [ qw(Test::H Test::G Test::D Test::A Test::B Test::C) ],
2197 +    '... got the right DFS merge order for Test::H');
2198 +
2199 +is_deeply(
2200 +    mro::get_linear_isa('Test::I'),
2201 +    [ qw(Test::I Test::H Test::G Test::D Test::A Test::B Test::C Test::F Test::E) ],
2202 +    '... got the right DFS merge order for Test::I');
2203 +
2204 +is_deeply(
2205 +    mro::get_linear_isa('Test::J'),
2206 +    [ qw(Test::J Test::F Test::E Test::D Test::A Test::B Test::C) ],
2207 +    '... got the right DFS merge order for Test::J');
2208 +
2209 +is_deeply(
2210 +    mro::get_linear_isa('Test::K'),
2211 +    [ qw(Test::K Test::J Test::F Test::E Test::D Test::A Test::B Test::C Test::I Test::H Test::G) ],
2212 +    '... got the right DFS merge order for Test::K');
2213 === t/mro/inconsistent_c3.t
2214 ==================================================================
2215 --- t/mro/inconsistent_c3.t     (/local/perl-current)   (revision 30426)
2216 +++ t/mro/inconsistent_c3.t     (/local/perl-c3-subg)   (revision 30426)
2217 @@ -0,0 +1,47 @@
2218 +#!./perl
2219 +
2220 +use strict;
2221 +use warnings;
2222 +BEGIN {
2223 +    unless (-d 'blib') {
2224 +        chdir 't' if -d 't';
2225 +        @INC = '../lib';
2226 +    }
2227 +}
2228 +
2229 +use Test::More tests => 1;
2230 +
2231 +=pod
2232 +
2233 +This example is take from: http://www.python.org/2.3/mro.html
2234 +
2235 +"Serious order disagreement" # From Guido
2236 +class O: pass
2237 +class X(O): pass
2238 +class Y(O): pass
2239 +class A(X,Y): pass
2240 +class B(Y,X): pass
2241 +try:
2242 +    class Z(A,B): pass #creates Z(A,B) in Python 2.2
2243 +except TypeError:
2244 +    pass # Z(A,B) cannot be created in Python 2.3
2245 +
2246 +=cut
2247 +
2248 +{
2249 +    package X;
2250 +
2251 +    package Y;
2252 +
2253 +    package XY;
2254 +    our @ISA = ('X', 'Y');
2255 +
2256 +    package YX;
2257 +    our @ISA = ('Y', 'X');
2258 +
2259 +    package Z;
2260 +    our @ISA = ('XY', 'YX');
2261 +}
2262 +
2263 +eval { mro::get_linear_isa('Z', 'c3') };
2264 +like($@, qr/^Inconsistent /, '... got the right error with an inconsistent hierarchy');
2265 === t/mro/recursion_dfs.t
2266 ==================================================================
2267 --- t/mro/recursion_dfs.t       (/local/perl-current)   (revision 30426)
2268 +++ t/mro/recursion_dfs.t       (/local/perl-c3-subg)   (revision 30426)
2269 @@ -0,0 +1,90 @@
2270 +#!./perl
2271 +
2272 +use strict;
2273 +use warnings;
2274 +BEGIN {
2275 +    unless (-d 'blib') {
2276 +        chdir 't' if -d 't';
2277 +        @INC = '../lib';
2278 +    }
2279 +}
2280 +
2281 +use Test::More;
2282 +use mro;
2283 +
2284 +# XXX needs translation back to classes, etc
2285 +
2286 +plan skip_all => "Your system has no SIGALRM" if !exists $SIG{ALRM};
2287 +plan tests => 8;
2288 +
2289 +=pod
2290 +
2291 +These are like the 010_complex_merge_classless test,
2292 +but an infinite loop has been made in the heirarchy,
2293 +to test that we can fail cleanly instead of going
2294 +into an infinite loop
2295 +
2296 +=cut
2297 +
2298 +# initial setup, everything sane
2299 +{
2300 +    package K;
2301 +    our @ISA = qw/J I/;
2302 +    package J;
2303 +    our @ISA = qw/F/;
2304 +    package I;
2305 +    our @ISA = qw/H F/;
2306 +    package H;
2307 +    our @ISA = qw/G/;
2308 +    package G;
2309 +    our @ISA = qw/D/;
2310 +    package F;
2311 +    our @ISA = qw/E/;
2312 +    package E;
2313 +    our @ISA = qw/D/;
2314 +    package D;
2315 +    our @ISA = qw/A B C/;
2316 +    package C;
2317 +    our @ISA = qw//;
2318 +    package B;
2319 +    our @ISA = qw//;
2320 +    package A;
2321 +    our @ISA = qw//;
2322 +}
2323 +
2324 +# A series of 8 abberations that would cause infinite loops,
2325 +#  each one undoing the work of the previous
2326 +my @loopies = (
2327 +    sub { @E::ISA = qw/F/ },
2328 +    sub { @E::ISA = qw/D/; @C::ISA = qw/F/ },
2329 +    sub { @C::ISA = qw//; @A::ISA = qw/K/ },
2330 +    sub { @A::ISA = qw//; @J::ISA = qw/F K/ },
2331 +    sub { @J::ISA = qw/F/; @H::ISA = qw/K G/ },
2332 +    sub { @H::ISA = qw/G/; @B::ISA = qw/B/ },
2333 +    sub { @B::ISA = qw//; @K::ISA = qw/K J I/ },
2334 +    sub { @K::ISA = qw/J I/; @D::ISA = qw/A H B C/ },
2335 +);
2336 +
2337 +foreach my $loopy (@loopies) {
2338 +    eval {
2339 +        local $SIG{ALRM} = sub { die "ALRMTimeout" };
2340 +        alarm(3);
2341 +        $loopy->();
2342 +        mro::get_linear_isa('K', 'dfs');
2343 +    };
2344 +
2345 +    if(my $err = $@) {
2346 +        if($err =~ /ALRMTimeout/) {
2347 +            ok(0, "Loop terminated by SIGALRM");
2348 +        }
2349 +        elsif($err =~ /Recursive inheritance detected/) {
2350 +            ok(1, "Graceful exception thrown");
2351 +        }
2352 +        else {
2353 +            ok(0, "Unrecognized exception: $err");
2354 +        }
2355 +    }
2356 +    else {
2357 +        ok(0, "Infinite loop apparently succeeded???");
2358 +    }
2359 +}
2360 === t/mro/basic_01_c3.t
2361 ==================================================================
2362 --- t/mro/basic_01_c3.t (/local/perl-current)   (revision 30426)
2363 +++ t/mro/basic_01_c3.t (/local/perl-c3-subg)   (revision 30426)
2364 @@ -0,0 +1,53 @@
2365 +#!./perl
2366 +
2367 +use strict;
2368 +use warnings;
2369 +BEGIN {
2370 +    unless (-d 'blib') {
2371 +        chdir 't' if -d 't';
2372 +        @INC = '../lib';
2373 +    }
2374 +}
2375 +
2376 +use Test::More tests => 4;
2377 +
2378 +=pod
2379 +
2380 +This tests the classic diamond inheritence pattern.
2381 +
2382 +   <A>
2383 +  /   \
2384 +<B>   <C>
2385 +  \   /
2386 +   <D>
2387 +
2388 +=cut
2389 +
2390 +{
2391 +    package Diamond_A;
2392 +    sub hello { 'Diamond_A::hello' }
2393 +}
2394 +{
2395 +    package Diamond_B;
2396 +    use base 'Diamond_A';
2397 +}
2398 +{
2399 +    package Diamond_C;
2400 +    use base 'Diamond_A';
2401 +
2402 +    sub hello { 'Diamond_C::hello' }
2403 +}
2404 +{
2405 +    package Diamond_D;
2406 +    use base ('Diamond_B', 'Diamond_C');
2407 +    use mro 'c3';
2408 +}
2409 +
2410 +is_deeply(
2411 +    mro::get_linear_isa('Diamond_D'),
2412 +    [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ],
2413 +    '... got the right MRO for Diamond_D');
2414 +
2415 +is(Diamond_D->hello, 'Diamond_C::hello', '... method resolved itself as expected');
2416 +is(Diamond_D->can('hello')->(), 'Diamond_C::hello', '... can(method) resolved itself as expected');
2417 +is(UNIVERSAL::can("Diamond_D", 'hello')->(), 'Diamond_C::hello', '... can(method) resolved itself as expected');
2418 === t/mro/basic_02_c3.t
2419 ==================================================================
2420 --- t/mro/basic_02_c3.t (/local/perl-current)   (revision 30426)
2421 +++ t/mro/basic_02_c3.t (/local/perl-c3-subg)   (revision 30426)
2422 @@ -0,0 +1,121 @@
2423 +#!./perl
2424 +
2425 +use strict;
2426 +use warnings;
2427 +BEGIN {
2428 +    unless (-d 'blib') {
2429 +        chdir 't' if -d 't';
2430 +        @INC = '../lib';
2431 +    }
2432 +}
2433 +
2434 +use Test::More tests => 10;
2435 +
2436 +=pod
2437 +
2438 +This example is take from: http://www.python.org/2.3/mro.html
2439 +
2440 +"My first example"
2441 +class O: pass
2442 +class F(O): pass
2443 +class E(O): pass
2444 +class D(O): pass
2445 +class C(D,F): pass
2446 +class B(D,E): pass
2447 +class A(B,C): pass
2448 +
2449 +
2450 +                          6
2451 +                         ---
2452 +Level 3                 | O |                  (more general)
2453 +                      /  ---  \
2454 +                     /    |    \                      |
2455 +                    /     |     \                     |
2456 +                   /      |      \                    |
2457 +                  ---    ---    ---                   |
2458 +Level 2        3 | D | 4| E |  | F | 5                |
2459 +                  ---    ---    ---                   |
2460 +                   \  \ _ /       |                   |
2461 +                    \    / \ _    |                   |
2462 +                     \  /      \  |                   |
2463 +                      ---      ---                    |
2464 +Level 1            1 | B |    | C | 2                 |
2465 +                      ---      ---                    |
2466 +                        \      /                      |
2467 +                         \    /                      \ /
2468 +                           ---
2469 +Level 0                 0 | A |                (more specialized)
2470 +                           ---
2471 +
2472 +=cut
2473 +
2474 +{
2475 +    package Test::O;
2476 +    use mro 'c3';
2477 +
2478 +    package Test::F;
2479 +    use mro 'c3';
2480 +    use base 'Test::O';
2481 +
2482 +    package Test::E;
2483 +    use base 'Test::O';
2484 +    use mro 'c3';
2485 +
2486 +    sub C_or_E { 'Test::E' }
2487 +
2488 +    package Test::D;
2489 +    use mro 'c3';
2490 +    use base 'Test::O';
2491 +
2492 +    sub C_or_D { 'Test::D' }
2493 +
2494 +    package Test::C;
2495 +    use base ('Test::D', 'Test::F');
2496 +    use mro 'c3';
2497 +
2498 +    sub C_or_D { 'Test::C' }
2499 +    sub C_or_E { 'Test::C' }
2500 +
2501 +    package Test::B;
2502 +    use mro 'c3';
2503 +    use base ('Test::D', 'Test::E');
2504 +
2505 +    package Test::A;
2506 +    use base ('Test::B', 'Test::C');
2507 +    use mro 'c3';
2508 +}
2509 +
2510 +is_deeply(
2511 +    mro::get_linear_isa('Test::F'),
2512 +    [ qw(Test::F Test::O) ],
2513 +    '... got the right MRO for Test::F');
2514 +
2515 +is_deeply(
2516 +    mro::get_linear_isa('Test::E'),
2517 +    [ qw(Test::E Test::O) ],
2518 +    '... got the right MRO for Test::E');
2519 +
2520 +is_deeply(
2521 +    mro::get_linear_isa('Test::D'),
2522 +    [ qw(Test::D Test::O) ],
2523 +    '... got the right MRO for Test::D');
2524 +
2525 +is_deeply(
2526 +    mro::get_linear_isa('Test::C'),
2527 +    [ qw(Test::C Test::D Test::F Test::O) ],
2528 +    '... got the right MRO for Test::C');
2529 +
2530 +is_deeply(
2531 +    mro::get_linear_isa('Test::B'),
2532 +    [ qw(Test::B Test::D Test::E Test::O) ],
2533 +    '... got the right MRO for Test::B');
2534 +
2535 +is_deeply(
2536 +    mro::get_linear_isa('Test::A'),
2537 +    [ qw(Test::A Test::B Test::C Test::D Test::E Test::F Test::O) ],
2538 +    '... got the right MRO for Test::A');
2539 +
2540 +is(Test::A->C_or_D, 'Test::C', '... got the expected method output');
2541 +is(Test::A->can('C_or_D')->(), 'Test::C', '... can got the expected method output');
2542 +is(Test::A->C_or_E, 'Test::C', '... got the expected method output');
2543 +is(Test::A->can('C_or_E')->(), 'Test::C', '... can got the expected method output');
2544 === t/mro/overload_dfs.t
2545 ==================================================================
2546 --- t/mro/overload_dfs.t        (/local/perl-current)   (revision 30426)
2547 +++ t/mro/overload_dfs.t        (/local/perl-c3-subg)   (revision 30426)
2548 @@ -0,0 +1,54 @@
2549 +#!./perl
2550 +
2551 +use strict;
2552 +use warnings;
2553 +BEGIN {
2554 +    unless (-d 'blib') {
2555 +        chdir 't' if -d 't';
2556 +        @INC = '../lib';
2557 +    }
2558 +}
2559 +
2560 +use Test::More tests => 7;
2561 +
2562 +{
2563 +    package BaseTest;
2564 +    use strict;
2565 +    use warnings;
2566 +    use mro 'dfs';
2567 +
2568 +    package OverloadingTest;
2569 +    use strict;
2570 +    use warnings;
2571 +    use mro 'dfs';
2572 +    use base 'BaseTest';
2573 +    use overload '""' => sub { ref(shift) . " stringified" },
2574 +                 fallback => 1;
2575 +
2576 +    sub new { bless {} => shift }
2577 +
2578 +    package InheritingFromOverloadedTest;
2579 +    use strict;
2580 +    use warnings;
2581 +    use base 'OverloadingTest';
2582 +    use mro 'dfs';
2583 +}
2584 +
2585 +my $x = InheritingFromOverloadedTest->new();
2586 +isa_ok($x, 'InheritingFromOverloadedTest');
2587 +
2588 +my $y = OverloadingTest->new();
2589 +isa_ok($y, 'OverloadingTest');
2590 +
2591 +is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing');
2592 +is("$y", 'OverloadingTest stringified', '... got the right value when stringifing');
2593 +
2594 +ok(($y eq 'OverloadingTest stringified'), '... eq was handled correctly');
2595 +
2596 +my $result;
2597 +eval {
2598 +    $result = $x eq 'InheritingFromOverloadedTest stringified'
2599 +};
2600 +ok(!$@, '... this should not throw an exception');
2601 +ok($result, '... and we should get the true value');
2602 +
2603 === t/mro/basic_03_c3.t
2604 ==================================================================
2605 --- t/mro/basic_03_c3.t (/local/perl-current)   (revision 30426)
2606 +++ t/mro/basic_03_c3.t (/local/perl-c3-subg)   (revision 30426)
2607 @@ -0,0 +1,107 @@
2608 +#!./perl
2609 +
2610 +use strict;
2611 +use warnings;
2612 +BEGIN {
2613 +    unless (-d 'blib') {
2614 +        chdir 't' if -d 't';
2615 +        @INC = '../lib';
2616 +    }
2617 +}
2618 +
2619 +use Test::More tests => 4;
2620 +
2621 +=pod
2622 +
2623 +This example is take from: http://www.python.org/2.3/mro.html
2624 +
2625 +"My second example"
2626 +class O: pass
2627 +class F(O): pass
2628 +class E(O): pass
2629 +class D(O): pass
2630 +class C(D,F): pass
2631 +class B(E,D): pass
2632 +class A(B,C): pass
2633 +
2634 +                           6
2635 +                          ---
2636 +Level 3                  | O |
2637 +                       /  ---  \
2638 +                      /    |    \
2639 +                     /     |     \
2640 +                    /      |      \
2641 +                  ---     ---    ---
2642 +Level 2        2 | E | 4 | D |  | F | 5
2643 +                  ---     ---    ---
2644 +                   \      / \     /
2645 +                    \    /   \   /
2646 +                     \  /     \ /
2647 +                      ---     ---
2648 +Level 1            1 | B |   | C | 3
2649 +                      ---     ---
2650 +                       \       /
2651 +                        \     /
2652 +                          ---
2653 +Level 0                0 | A |
2654 +                          ---
2655 +
2656 +>>> A.mro()
2657 +(<class '__main__.A'>, <class '__main__.B'>, <class '__main__.E'>,
2658 +<class '__main__.C'>, <class '__main__.D'>, <class '__main__.F'>,
2659 +<type 'object'>)
2660 +
2661 +=cut
2662 +
2663 +{
2664 +    package Test::O;
2665 +    use mro 'c3';
2666 +
2667 +    sub O_or_D { 'Test::O' }
2668 +    sub O_or_F { 'Test::O' }
2669 +
2670 +    package Test::F;
2671 +    use base 'Test::O';
2672 +    use mro 'c3';
2673 +
2674 +    sub O_or_F { 'Test::F' }
2675 +
2676 +    package Test::E;
2677 +    use base 'Test::O';
2678 +    use mro 'c3';
2679 +
2680 +    package Test::D;
2681 +    use base 'Test::O';
2682 +    use mro 'c3';
2683 +
2684 +    sub O_or_D { 'Test::D' }
2685 +    sub C_or_D { 'Test::D' }
2686 +
2687 +    package Test::C;
2688 +    use base ('Test::D', 'Test::F');
2689 +    use mro 'c3';
2690 +
2691 +    sub C_or_D { 'Test::C' }
2692 +
2693 +    package Test::B;
2694 +    use base ('Test::E', 'Test::D');
2695 +    use mro 'c3';
2696 +
2697 +    package Test::A;
2698 +    use base ('Test::B', 'Test::C');
2699 +    use mro 'c3';
2700 +}
2701 +
2702 +is_deeply(
2703 +    mro::get_linear_isa('Test::A'),
2704 +    [ qw(Test::A Test::B Test::E Test::C Test::D Test::F Test::O) ],
2705 +    '... got the right MRO for Test::A');
2706 +
2707 +is(Test::A->O_or_D, 'Test::D', '... got the right method dispatch');
2708 +is(Test::A->O_or_F, 'Test::F', '... got the right method dispatch');
2709 +
2710 +# NOTE:
2711 +# this test is particularly interesting because the p5 dispatch
2712 +# would actually call Test::D before Test::C and Test::D is a
2713 +# subclass of Test::C
2714 +is(Test::A->C_or_D, 'Test::C', '... got the right method dispatch');
2715 === t/mro/basic_04_c3.t
2716 ==================================================================
2717 --- t/mro/basic_04_c3.t (/local/perl-current)   (revision 30426)
2718 +++ t/mro/basic_04_c3.t (/local/perl-c3-subg)   (revision 30426)
2719 @@ -0,0 +1,40 @@
2720 +#!./perl
2721 +
2722 +use strict;
2723 +use warnings;
2724 +BEGIN {
2725 +    unless (-d 'blib') {
2726 +        chdir 't' if -d 't';
2727 +        @INC = '../lib';
2728 +    }
2729 +}
2730 +
2731 +use Test::More tests => 1;
2732 +
2733 +=pod
2734 +
2735 +From the parrot test t/pmc/object-meths.t
2736 +
2737 + A   B A   E
2738 +  \ /   \ /
2739 +   C     D
2740 +    \   /
2741 +     \ /
2742 +      F
2743 +
2744 +=cut
2745 +
2746 +{
2747 +    package t::lib::A; use mro 'c3';
2748 +    package t::lib::B; use mro 'c3';
2749 +    package t::lib::E; use mro 'c3';
2750 +    package t::lib::C; use mro 'c3'; use base ('t::lib::A', 't::lib::B');
2751 +    package t::lib::D; use mro 'c3'; use base ('t::lib::A', 't::lib::E');
2752 +    package t::lib::F; use mro 'c3'; use base ('t::lib::C', 't::lib::D');
2753 +}
2754 +
2755 +is_deeply(
2756 +    mro::get_linear_isa('t::lib::F'),
2757 +    [ qw(t::lib::F t::lib::C t::lib::D t::lib::A t::lib::B t::lib::E) ],
2758 +    '... got the right MRO for t::lib::F');
2759 +
2760 === t/mro/basic_05_c3.t
2761 ==================================================================
2762 --- t/mro/basic_05_c3.t (/local/perl-current)   (revision 30426)
2763 +++ t/mro/basic_05_c3.t (/local/perl-c3-subg)   (revision 30426)
2764 @@ -0,0 +1,61 @@
2765 +#!./perl
2766 +
2767 +use strict;
2768 +use warnings;
2769 +BEGIN {
2770 +    unless (-d 'blib') {
2771 +        chdir 't' if -d 't';
2772 +        @INC = '../lib';
2773 +    }
2774 +}
2775 +
2776 +use Test::More tests => 2;
2777 +
2778 +=pod
2779 +
2780 +This tests a strange bug found by Matt S. Trout
2781 +while building DBIx::Class. Thanks Matt!!!!
2782 +
2783 +   <A>
2784 +  /   \
2785 +<C>   <B>
2786 +  \   /
2787 +   <D>
2788 +
2789 +=cut
2790 +
2791 +{
2792 +    package Diamond_A;
2793 +    use mro 'c3';
2794 +
2795 +    sub foo { 'Diamond_A::foo' }
2796 +}
2797 +{
2798 +    package Diamond_B;
2799 +    use base 'Diamond_A';
2800 +    use mro 'c3';
2801 +
2802 +    sub foo { 'Diamond_B::foo => ' . (shift)->SUPER::foo }
2803 +}
2804 +{
2805 +    package Diamond_C;
2806 +    use mro 'c3';
2807 +    use base 'Diamond_A';
2808 +
2809 +}
2810 +{
2811 +    package Diamond_D;
2812 +    use base ('Diamond_C', 'Diamond_B');
2813 +    use mro 'c3';
2814 +
2815 +    sub foo { 'Diamond_D::foo => ' . (shift)->SUPER::foo }
2816 +}
2817 +
2818 +is_deeply(
2819 +    mro::get_linear_isa('Diamond_D'),
2820 +    [ qw(Diamond_D Diamond_C Diamond_B Diamond_A) ],
2821 +    '... got the right MRO for Diamond_D');
2822 +
2823 +is(Diamond_D->foo,
2824 +   'Diamond_D::foo => Diamond_B::foo => Diamond_A::foo',
2825 +   '... got the right next::method dispatch path');
2826 === t/op/magic.t
2827 ==================================================================
2828 --- t/op/magic.t        (/local/perl-current)   (revision 30426)
2829 +++ t/op/magic.t        (/local/perl-c3-subg)   (revision 30426)
2830 @@ -440,7 +440,10 @@
2831  if (!$Is_VMS) {
2832      local @ISA;
2833      local %ENV;
2834 -    eval { push @ISA, __PACKAGE__ };
2835 +    # This used to be __PACKAGE__, but that causes recursive
2836 +    #  inheritance, which is detected earlier now and broke
2837 +    #  this test
2838 +    eval { push @ISA, __FILE__ };
2839      ok( $@ eq '', 'Push a constant on a magic array');
2840      $@ and print "# $@";
2841      eval { %ENV = (PATH => __PACKAGE__) };
2842 === NetWare/Makefile
2843 ==================================================================
2844 --- NetWare/Makefile    (/local/perl-current)   (revision 30426)
2845 +++ NetWare/Makefile    (/local/perl-c3-subg)   (revision 30426)
2846 @@ -701,6 +701,7 @@
2847                 ..\dump.c       \
2848                 ..\globals.c    \
2849                 ..\gv.c         \
2850 +               ..\mro.c        \
2851                 ..\hv.c         \
2852                 ..\locale.c     \
2853                  ..\mathoms.c    \
2854 === vms/descrip_mms.template
2855 ==================================================================
2856 --- vms/descrip_mms.template    (/local/perl-current)   (revision 30426)
2857 +++ vms/descrip_mms.template    (/local/perl-c3-subg)   (revision 30426)
2858 @@ -279,13 +279,13 @@
2859
2860  #### End of system configuration section. ####
2861
2862 -c0 = $(MALLOC_C) $(SOCKC) av.c deb.c doio.c doop.c dump.c globals.c gv.c hv.c
2863 +c0 = $(MALLOC_C) $(SOCKC) av.c deb.c doio.c doop.c dump.c globals.c gv.c hv.c mro.c
2864  c1 = mg.c locale.c mathoms.c miniperlmain.c numeric.c op.c pad.c perl.c perlapi.c perlio.c
2865  c2 = perly.c pp.c pp_ctl.c pp_hot.c pp_pack.c pp_sort.c pp_sys.c regcomp.c regexec.c reentr.c
2866  c3 = run.c scope.c sv.c taint.c toke.c universal.c utf8.c util.c vms.c xsutils.c
2867  c = $(c0) $(c1) $(c2) $(c3)
2868
2869 -obj0 = $(MALLOC_O) $(SOCKO) av$(O) deb$(O) doio$(O) doop$(O) dump$(O)
2870 +obj0 = $(MALLOC_O) $(SOCKO) av$(O) deb$(O) doio$(O) doop$(O) dump$(O) mro$(O)
2871  obj1 = globals$(O) gv$(O) hv$(O) locale$(O) mathoms$(O) mg$(O) miniperlmain$(O) numeric$(O) op$(O) pad$(O)
2872  obj2 = perl$(O) perlapi$(O) perlio$(O) perly$(O) pp$(O) pp_ctl$(O) pp_hot$(O) reentr$(O)
2873  obj3 = pp_pack$(O) pp_sort$(O) pp_sys$(O) regcomp$(O) regexec$(O) run$(O) scope$(O) sv$(O) taint$(O) toke$(O)
2874 @@ -1619,6 +1619,8 @@
2875         $(CC) $(CORECFLAGS) $(MMS$SOURCE)
2876  gv$(O) : gv.c $(h)
2877         $(CC) $(CORECFLAGS) $(MMS$SOURCE)
2878 +mro$(O) : mro.c $(h)
2879 +       $(CC) $(CORECFLAGS) $(MMS$SOURCE)
2880  hv$(O) : hv.c $(h)
2881         $(CC) $(CORECFLAGS) $(MMS$SOURCE)
2882  locale$(O) : locale.c $(h)
2883 === Makefile.SH
2884 ==================================================================
2885 --- Makefile.SH (/local/perl-current)   (revision 30426)
2886 +++ Makefile.SH (/local/perl-c3-subg)   (revision 30426)
2887 @@ -367,7 +367,7 @@
2888  h5 = utf8.h warnings.h
2889  h = $(h1) $(h2) $(h3) $(h4) $(h5)
2890
2891 -c1 = av.c scope.c op.c doop.c doio.c dump.c gv.c hv.c mg.c reentr.c  perl.c
2892 +c1 = av.c scope.c op.c doop.c doio.c dump.c gv.c hv.c mg.c reentr.c mro.c perl.c
2893  c2 = perly.c pp.c pp_hot.c pp_ctl.c pp_sys.c regcomp.c regexec.c utf8.c sv.c
2894  c3 = taint.c toke.c util.c deb.c run.c universal.c xsutils.c pad.c globals.c
2895  c4 = perlio.c perlapi.c numeric.c mathoms.c locale.c pp_pack.c pp_sort.c
2896 @@ -375,7 +375,7 @@
2897
2898  c = $(c1) $(c2) $(c3) $(c4) $(c5) miniperlmain.c perlmain.c opmini.c
2899
2900 -obj1 = $(madlyobj) $(mallocobj) gv$(OBJ_EXT) toke$(OBJ_EXT) perly$(OBJ_EXT) op$(OBJ_EXT) pad$(OBJ_EXT) regcomp$(OBJ_EXT) dump$(OBJ_EXT) util$(OBJ_EXT) mg$(OBJ_EXT) reentr$(OBJ_EXT)
2901 +obj1 = $(madlyobj) $(mallocobj) gv$(OBJ_EXT) toke$(OBJ_EXT) perly$(OBJ_EXT) op$(OBJ_EXT) pad$(OBJ_EXT) regcomp$(OBJ_EXT) dump$(OBJ_EXT) util$(OBJ_EXT) mg$(OBJ_EXT) reentr$(OBJ_EXT) mro$(OBJ_EXT)
2902  obj2 = hv$(OBJ_EXT) av$(OBJ_EXT) perl$(OBJ_EXT) run$(OBJ_EXT) pp_hot$(OBJ_EXT) sv$(OBJ_EXT) pp$(OBJ_EXT) scope$(OBJ_EXT) pp_ctl$(OBJ_EXT) pp_sys$(OBJ_EXT)
2903  obj3 = doop$(OBJ_EXT) doio$(OBJ_EXT) regexec$(OBJ_EXT) utf8$(OBJ_EXT) taint$(OBJ_EXT) deb$(OBJ_EXT) universal$(OBJ_EXT) xsutils$(OBJ_EXT) globals$(OBJ_EXT) perlio$(OBJ_EXT) perlapi$(OBJ_EXT) numeric$(OBJ_EXT) mathoms$(OBJ_EXT) locale$(OBJ_EXT) pp_pack$(OBJ_EXT) pp_sort$(OBJ_EXT)
2904
2905 === proto.h
2906 ==================================================================
2907 --- proto.h     (/local/perl-current)   (revision 30426)
2908 +++ proto.h     (/local/perl-c3-subg)   (revision 30426)
2909 @@ -635,6 +635,25 @@
2910  PERL_CALLCONV GV*      Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN len, const U32 flags)
2911                         __attribute__nonnull__(pTHX_1);
2912
2913 +PERL_CALLCONV struct mro_meta* Perl_mro_meta_init(pTHX_ HV* stash)
2914 +                       __attribute__nonnull__(pTHX_1);
2915 +
2916 +PERL_CALLCONV AV*      Perl_mro_linear(pTHX_ HV* stash)
2917 +                       __attribute__nonnull__(pTHX_1);
2918 +
2919 +PERL_CALLCONV AV*      Perl_mro_linear_c3(pTHX_ HV* stash, I32 level)
2920 +                       __attribute__nonnull__(pTHX_1);
2921 +
2922 +PERL_CALLCONV AV*      Perl_mro_linear_dfs(pTHX_ HV* stash, I32 level)
2923 +                       __attribute__nonnull__(pTHX_1);
2924 +
2925 +PERL_CALLCONV void     Perl_mro_isa_changed_in(pTHX_ HV* stash)
2926 +                       __attribute__nonnull__(pTHX_1);
2927 +
2928 +PERL_CALLCONV void     Perl_mro_method_changed_in(pTHX_ HV* stash)
2929 +                       __attribute__nonnull__(pTHX_1);
2930 +
2931 +PERL_CALLCONV void     Perl_boot_core_mro(pTHX);
2932  PERL_CALLCONV GV*      Perl_gv_fetchmeth(pTHX_ HV* stash, const char* name, STRLEN len, I32 level)
2933                         __attribute__nonnull__(pTHX_2);
2934
2935 === ext/B/t/b.t
2936 ==================================================================
2937 --- ext/B/t/b.t (/local/perl-current)   (revision 30426)
2938 +++ ext/B/t/b.t (/local/perl-c3-subg)   (revision 30426)
2939 @@ -169,7 +169,7 @@
2940  {
2941      no warnings 'once';
2942      my $sg = B::sub_generation();
2943 -    *Whatever::hand_waving = sub { };
2944 +    *UNIVERSAL::hand_waving = sub { };
2945      ok( $sg < B::sub_generation, "sub_generation increments" );
2946  }
2947
2948 === MANIFEST
2949 ==================================================================
2950 --- MANIFEST    (/local/perl-current)   (revision 30426)
2951 +++ MANIFEST    (/local/perl-c3-subg)   (revision 30426)
2952 @@ -2252,6 +2252,7 @@
2953  lib/Module/Pluggable/t/lib/OddTest/Plugin/-Dodgy.pm    Module::Pluggable tests
2954  lib/Module/Pluggable/t/lib/OddTest/Plugin/Foo.pm       Module::Pluggable tests
2955  lib/Module/Pluggable/t/lib/TA/C/A/I.pm Module::Pluggable tests
2956 +lib/mro.pm                     mro extension
2957  lib/Net/Changes.libnet         libnet
2958  lib/Net/Cmd.pm                 libnet
2959  lib/Net/Config.eg              libnet
2960 @@ -2953,6 +2954,7 @@
2961  mpeix/mpeix_setjmp.c           MPE/iX port
2962  mpeix/nm                       MPE/iX port
2963  mpeix/relink                   MPE/iX port
2964 +mro.c                          Method Resolution Order code
2965  myconfig.SH                    Prints summary of the current configuration
2966  NetWare/bat/Buildtype.bat      NetWare port
2967  NetWare/bat/SetCodeWar.bat     NetWare port
2968 @@ -3619,6 +3621,28 @@
2969  t/lib/warnings/universal       Tests for universal.c for warnings.t
2970  t/lib/warnings/utf8            Tests for utf8.c for warnings.t
2971  t/lib/warnings/util            Tests for util.c for warnings.t
2972 +t/mro/basic_01_c3.t            mro tests
2973 +t/mro/basic_01_dfs.t           mro tests
2974 +t/mro/basic_02_c3.t            mro tests
2975 +t/mro/basic_02_dfs.t           mro tests
2976 +t/mro/basic_03_c3.t            mro tests
2977 +t/mro/basic_03_dfs.t           mro tests
2978 +t/mro/basic_04_c3.t            mro tests
2979 +t/mro/basic_04_dfs.t           mro tests
2980 +t/mro/basic_05_c3.t            mro tests
2981 +t/mro/basic_05_dfs.t           mro tests
2982 +t/mro/complex_c3.t             mro tests
2983 +t/mro/complex_dfs.t            mro tests
2984 +t/mro/dbic_c3.t                        mro tests
2985 +t/mro/dbic_dfs.t               mro tests
2986 +t/mro/inconsistent_c3.t                mro tests
2987 +t/mro/overload_c3.t            mro tests
2988 +t/mro/overload_dfs.t           mro tests
2989 +t/mro/recursion_c3.t           mro tests
2990 +t/mro/recursion_dfs.t          mro tests
2991 +t/mro/vulcan_c3.t              mro tests
2992 +t/mro/vulcan_dfs.t             mro tests
2993 +t/mro/method_caching.t         mro tests
2994  Todo.micro                     The Wishlist for microperl
2995  toke.c                         The tokener
2996  t/op/64bitint.t                        See if 64 bit integers work
2997 === mro.c
2998 ==================================================================
2999 --- mro.c       (/local/perl-current)   (revision 30426)
3000 +++ mro.c       (/local/perl-c3-subg)   (revision 30426)
3001 @@ -0,0 +1,888 @@
3002 +/*    mro.c
3003 + *
3004 + *    Copyright (c) 2007 Brandon L Black
3005 + *
3006 + *    You may distribute under the terms of either the GNU General Public
3007 + *    License or the Artistic License, as specified in the README file.
3008 + *
3009 + */
3010 +
3011 +/*
3012 +=head1 MRO Functions
3013 +
3014 +These functions are related to the method resolution order of perl classes
3015 +
3016 +=cut
3017 +*/
3018 +
3019 +#include "EXTERN.h"
3020 +#include "perl.h"
3021 +
3022 +struct mro_meta*
3023 +Perl_mro_meta_init(pTHX_ HV* stash)
3024 +{
3025 +    void* newmeta;
3026 +
3027 +    assert(stash);
3028 +    assert(HvAUX(stash));
3029 +    assert(!(HvAUX(stash)->xhv_mro_meta));
3030 +    Newxz(newmeta, sizeof(struct mro_meta), char);
3031 +    HvAUX(stash)->xhv_mro_meta = (struct mro_meta*)newmeta;
3032 +    ((struct mro_meta*)newmeta)->sub_generation = 1;
3033 +
3034 +    /* Manually flag UNIVERSAL as being universal.
3035 +       This happens early in perl booting (when universal.c
3036 +       does the newXS calls for UNIVERSAL::*), and infects
3037 +       other packages as they are added to UNIVERSAL's MRO
3038 +    */
3039 +    if(HvNAMELEN_get(stash) == 9
3040 +       && strEQ(HEK_KEY(HvAUX(stash)->xhv_name), "UNIVERSAL")) {
3041 +            HvMROMETA(stash)->is_universal = 1;
3042 +    }
3043 +
3044 +    return newmeta;
3045 +}
3046 +
3047 +/*
3048 +=for apidoc mro_linear_dfs
3049 +
3050 +Returns the Depth-First Search linearization of @ISA
3051 +the given stash.  The return value is a read-only AV*.
3052 +C<level> should be 0 (it is used internally in this
3053 +function's recursion).
3054 +
3055 +=cut
3056 +*/
3057 +AV*
3058 +Perl_mro_linear_dfs(pTHX_ HV *stash, I32 level)
3059 +{
3060 +    AV* retval;
3061 +    GV** gvp;
3062 +    GV* gv;
3063 +    AV* av;
3064 +    SV** svp;
3065 +    I32 items;
3066 +    AV* subrv;
3067 +    SV** subrv_p;
3068 +    I32 subrv_items;
3069 +    const char* stashname;
3070 +    struct mro_meta* meta;
3071 +
3072 +    assert(stash);
3073 +    assert(HvAUX(stash));
3074 +
3075 +    stashname = HvNAME_get(stash);
3076 +    if (!stashname)
3077 +      Perl_croak(aTHX_
3078 +                 "Can't linearize anonymous symbol table");
3079 +
3080 +    if (level > 100)
3081 +        Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
3082 +              stashname);
3083 +
3084 +    meta = HvMROMETA(stash);
3085 +    if((retval = meta->mro_linear_dfs)) {
3086 +        /* return cache if valid */
3087 +        SvREFCNT_inc_simple_void_NN(retval);
3088 +        return retval;
3089 +    }
3090 +
3091 +    /* not in cache, make a new one */
3092 +    retval = (AV*)sv_2mortal((SV*)newAV());
3093 +    av_push(retval, newSVpv(stashname, 0)); /* add ourselves at the top */
3094 +
3095 +    gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
3096 +    av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
3097 +
3098 +    if(av) {
3099 +        HV* stored = (HV*)sv_2mortal((SV*)newHV());
3100 +        svp = AvARRAY(av);
3101 +        items = AvFILLp(av) + 1;
3102 +        while (items--) {
3103 +            SV* const sv = *svp++;
3104 +            HV* const basestash = gv_stashsv(sv, 0);
3105 +
3106 +            if (!basestash) {
3107 +                if(!hv_exists_ent(stored, sv, 0)) {
3108 +                    av_push(retval, newSVsv(sv));
3109 +                    hv_store_ent(stored, sv, &PL_sv_undef, 0);
3110 +                }
3111 +            }
3112 +            else {
3113 +                subrv = (AV*)sv_2mortal((SV*)mro_linear_dfs(basestash, level + 1));
3114 +                subrv_p = AvARRAY(subrv);
3115 +                subrv_items = AvFILLp(subrv) + 1;
3116 +                while(subrv_items--) {
3117 +                    SV* subsv = *subrv_p++;
3118 +                    if(!hv_exists_ent(stored, subsv, 0)) {
3119 +                        av_push(retval, newSVsv(subsv));
3120 +                        hv_store_ent(stored, subsv, &PL_sv_undef, 0);
3121 +                    }
3122 +                }
3123 +            }
3124 +        }
3125 +    }
3126 +
3127 +    SvREADONLY_on(retval);
3128 +    SvREFCNT_inc_simple_void_NN(retval); /* for meta storage */
3129 +    SvREFCNT_inc_simple_void_NN(retval); /* for return to caller */
3130 +    meta->mro_linear_dfs = retval;
3131 +    return retval;
3132 +}
3133 +
3134 +/*
3135 +=for apidoc mro_linear_c3
3136 +
3137 +Returns the C3 linearization of @ISA
3138 +the given stash.  The return value is a read-only AV*.
3139 +C<level> should be 0 (it is used internally in this
3140 +function's recursion).
3141 +
3142 +=cut
3143 +*/
3144 +
3145 +AV*
3146 +Perl_mro_linear_c3(pTHX_ HV* stash, I32 level)
3147 +{
3148 +    AV* retval;
3149 +    GV** gvp;
3150 +    GV* gv;
3151 +    AV* isa;
3152 +    const char* stashname;
3153 +    STRLEN stashname_len;
3154 +    struct mro_meta* meta;
3155 +
3156 +    assert(stash);
3157 +    assert(HvAUX(stash));
3158 +
3159 +    stashname = HvNAME_get(stash);
3160 +    stashname_len = HvNAMELEN_get(stash);
3161 +    if (!stashname)
3162 +      Perl_croak(aTHX_
3163 +                 "Can't linearize anonymous symbol table");
3164 +
3165 +    if (level > 100)
3166 +        Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
3167 +              stashname);
3168 +
3169 +    meta = HvMROMETA(stash);
3170 +    if((retval = meta->mro_linear_c3)) {
3171 +        /* return cache if valid */
3172 +        SvREFCNT_inc_simple_void_NN(retval);
3173 +        return retval;
3174 +    }
3175 +
3176 +    /* not in cache, make a new one */
3177 +
3178 +    retval = (AV*)sv_2mortal((SV*)newAV());
3179 +    av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
3180 +
3181 +    gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
3182 +    isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
3183 +
3184 +    if(isa && AvFILLp(isa) >= 0) {
3185 +        SV** seqs_ptr;
3186 +        I32 seqs_items;
3187 +        HV* tails = (HV*)sv_2mortal((SV*)newHV());
3188 +        AV* seqs = (AV*)sv_2mortal((SV*)newAV());
3189 +        I32 items = AvFILLp(isa) + 1;
3190 +        SV** isa_ptr = AvARRAY(isa);
3191 +        while(items--) {
3192 +            AV* isa_lin;
3193 +            SV* isa_item = *isa_ptr++;
3194 +            HV* isa_item_stash = gv_stashsv(isa_item, 0);
3195 +            if(!isa_item_stash) {
3196 +                isa_lin = newAV();
3197 +                av_push(isa_lin, newSVsv(isa_item));
3198 +            }
3199 +            else {
3200 +                isa_lin = (AV*)sv_2mortal((SV*)mro_linear_c3(isa_item_stash, level + 1)); /* recursion */
3201 +            }
3202 +            av_push(seqs, (SV*)av_make(AvFILLp(isa_lin)+1, AvARRAY(isa_lin)));
3203 +        }
3204 +        av_push(seqs, (SV*)av_make(AvFILLp(isa)+1, AvARRAY(isa)));
3205 +
3206 +        seqs_ptr = AvARRAY(seqs);
3207 +        seqs_items = AvFILLp(seqs) + 1;
3208 +        while(seqs_items--) {
3209 +            AV* seq = (AV*)*seqs_ptr++;
3210 +            I32 seq_items = AvFILLp(seq);
3211 +            if(seq_items > 0) {
3212 +                SV** seq_ptr = AvARRAY(seq) + 1;
3213 +                while(seq_items--) {
3214 +                    SV* seqitem = *seq_ptr++;
3215 +                    HE* he = hv_fetch_ent(tails, seqitem, 0, 0);
3216 +                    if(!he) {
3217 +                        hv_store_ent(tails, seqitem, newSViv(1), 0);
3218 +                    }
3219 +                    else {
3220 +                        SV* val = HeVAL(he);
3221 +                        sv_inc(val);
3222 +                    }
3223 +                }
3224 +            }
3225 +        }
3226 +
3227 +        while(1) {
3228 +            SV* seqhead = NULL;
3229 +            SV* cand = NULL;
3230 +            SV* winner = NULL;
3231 +            SV* val;
3232 +            HE* tail_entry;
3233 +            AV* seq;
3234 +            SV** avptr = AvARRAY(seqs);
3235 +            items = AvFILLp(seqs)+1;
3236 +            while(items--) {
3237 +                SV** svp;
3238 +                seq = (AV*)*avptr++;
3239 +                if(AvFILLp(seq) < 0) continue;
3240 +                svp = av_fetch(seq, 0, 0);
3241 +                seqhead = *svp;
3242 +                if(!winner) {
3243 +                    cand = seqhead;
3244 +                    if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
3245 +                       && (val = HeVAL(tail_entry))
3246 +                       && (SvIVx(val) > 0))
3247 +                           continue;
3248 +                    winner = newSVsv(cand);
3249 +                    av_push(retval, winner);
3250 +                }
3251 +                if(!sv_cmp(seqhead, winner)) {
3252 +
3253 +                    /* this is basically shift(@seq) in void context */
3254 +                    SvREFCNT_dec(*AvARRAY(seq));
3255 +                    *AvARRAY(seq) = &PL_sv_undef;
3256 +                    AvARRAY(seq) = AvARRAY(seq) + 1;
3257 +                    AvMAX(seq)--;
3258 +                    AvFILLp(seq)--;
3259 +
3260 +                    if(AvFILLp(seq) < 0) continue;
3261 +                    svp = av_fetch(seq, 0, 0);
3262 +                    seqhead = *svp;
3263 +                    tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
3264 +                    val = HeVAL(tail_entry);
3265 +                    sv_dec(val);
3266 +                }
3267 +            }
3268 +            if(!cand) break;
3269 +            if(!winner)
3270 +                Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
3271 +                    "merging failed on parent '%"SVf"'", stashname, SVfARG(cand));
3272 +        }
3273 +    }
3274 +
3275 +    SvREADONLY_on(retval);
3276 +    SvREFCNT_inc_simple_void_NN(retval); /* for meta storage */
3277 +    SvREFCNT_inc_simple_void_NN(retval); /* for return to caller */
3278 +    meta->mro_linear_c3 = retval;
3279 +    return retval;
3280 +}
3281 +
3282 +/*
3283 +=for apidoc mro_linear
3284 +
3285 +Returns either C<mro_linear_c3> or C<mro_linear_dfs> for
3286 +the given stash, dependant upon which MRO is in effect
3287 +for that stash.  The return value is a read-only AV*.
3288 +
3289 +=cut
3290 +*/
3291 +AV*
3292 +Perl_mro_linear(pTHX_ HV *stash)
3293 +{
3294 +    struct mro_meta* meta;
3295 +    assert(stash);
3296 +    assert(HvAUX(stash));
3297 +
3298 +    meta = HvMROMETA(stash);
3299 +    if(meta->mro_which == MRO_DFS) {
3300 +        return mro_linear_dfs(stash, 0);
3301 +    } else if(meta->mro_which == MRO_C3) {
3302 +        return mro_linear_c3(stash, 0);
3303 +    } else {
3304 +        Perl_croak(aTHX_ "Internal error: invalid MRO!");
3305 +    }
3306 +}
3307 +
3308 +/*
3309 +=for apidoc mro_isa_changed_in
3310 +
3311 +Takes the neccesary steps (cache invalidations, mostly)
3312 +when the @ISA of the given package has changed.  Invoked
3313 +by the C<setisa> magic, should not need to invoke directly.
3314 +
3315 +=cut
3316 +*/
3317 +void
3318 +Perl_mro_isa_changed_in(pTHX_ HV* stash)
3319 +{
3320 +    dVAR;
3321 +    HV* isarev;
3322 +    AV* linear_mro;
3323 +    HE* iter;
3324 +    SV** svp;
3325 +    I32 items;
3326 +    struct mro_meta* meta;
3327 +    char* stashname;
3328 +
3329 +    stashname = HvNAME_get(stash);
3330 +
3331 +    /* wipe out the cached linearizations for this stash */
3332 +    meta = HvMROMETA(stash);
3333 +    sv_2mortal((SV*)meta->mro_linear_dfs);
3334 +    sv_2mortal((SV*)meta->mro_linear_c3);
3335 +    meta->mro_linear_dfs = NULL;
3336 +    meta->mro_linear_c3 = NULL;
3337 +
3338 +    /* Wipe the global method cache if this package
3339 +       is UNIVERSAL or one of its parents */
3340 +    if(meta->is_universal)
3341 +        PL_sub_generation++;
3342 +
3343 +    /* Wipe the local method cache otherwise */
3344 +    else
3345 +        meta->sub_generation++;
3346 +
3347 +    /* wipe next::method cache too */
3348 +    if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
3349 +
3350 +    /* Recalcs whichever of the above two cleared linearizations
3351 +       are in effect and gives it to us */
3352 +    linear_mro = mro_linear(stash);
3353 +    isarev = meta->mro_isarev;
3354 +
3355 +    /* Iterate the isarev (classes that are our children),
3356 +       wiping out their linearization and method caches */
3357 +    if(isarev) {
3358 +        hv_iterinit(isarev);
3359 +        while((iter = hv_iternext(isarev))) {
3360 +            SV* revkey = hv_iterkeysv(iter);
3361 +            HV* revstash = gv_stashsv(revkey, 0);
3362 +            struct mro_meta* revmeta = HvMROMETA(revstash);
3363 +            sv_2mortal((SV*)revmeta->mro_linear_dfs);
3364 +            sv_2mortal((SV*)revmeta->mro_linear_c3);
3365 +            revmeta->mro_linear_dfs = NULL;
3366 +            revmeta->mro_linear_c3 = NULL;
3367 +            if(!meta->is_universal)
3368 +                revmeta->sub_generation++;
3369 +            if(revmeta->mro_nextmethod)
3370 +                hv_clear(revmeta->mro_nextmethod);
3371 +        }
3372 +    }
3373 +
3374 +    /* we're starting at the 2nd element, skipping ourselves here */
3375 +    svp = AvARRAY(linear_mro) + 1;
3376 +    items = AvFILLp(linear_mro);
3377 +    while (items--) {
3378 +        SV* const sv = *svp++;
3379 +        struct mro_meta* mrometa;
3380 +        HV* mroisarev;
3381 +
3382 +        HV* mrostash = gv_stashsv(sv, 0);
3383 +        if(!mrostash) {
3384 +            mrostash = gv_stashsv(sv, GV_ADD);
3385 +            /*
3386 +               We created the package on the fly, so
3387 +               that we could store isarev information.
3388 +               This flag lets gv_fetchmeth know about it,
3389 +               so that it can still generate the very useful
3390 +               "Can't locate package Foo for @Bar::ISA" warning.
3391 +            */
3392 +            HvMROMETA(mrostash)->fake = 1;
3393 +        }
3394 +
3395 +        mrometa = HvMROMETA(mrostash);
3396 +        mroisarev = mrometa->mro_isarev;
3397 +
3398 +        /* is_universal is viral */
3399 +        if(meta->is_universal)
3400 +            mrometa->is_universal = 1;
3401 +
3402 +        if(!mroisarev)
3403 +            mroisarev = mrometa->mro_isarev = newHV();
3404 +
3405 +        if(!hv_exists(mroisarev, stashname, strlen(stashname)))
3406 +            hv_store(mroisarev, stashname, strlen(stashname), &PL_sv_yes, 0);
3407 +
3408 +        if(isarev) {
3409 +            hv_iterinit(isarev);
3410 +            while((iter = hv_iternext(isarev))) {
3411 +                SV* revkey = hv_iterkeysv(iter);
3412 +                if(!hv_exists_ent(mroisarev, revkey, 0))
3413 +                    hv_store_ent(mroisarev, revkey, &PL_sv_yes, 0);
3414 +            }
3415 +        }
3416 +    }
3417 +}
3418 +
3419 +/*
3420 +=for apidoc mro_method_changed_in
3421 +
3422 +Like C<mro_isa_changed_in>, but invalidates method
3423 +caching on any child classes of the given stash, so
3424 +that they might notice the changes in this one.
3425 +
3426 +Ideally, all instances of C<PL_sub_generation++> in
3427 +the perl source should be replaced by calls to this.
3428 +Some already are, but some are more difficult to
3429 +replace.
3430 +
3431 +=cut
3432 +*/
3433 +void
3434 +Perl_mro_method_changed_in(pTHX_ HV *stash)
3435 +{
3436 +    struct mro_meta* meta = HvMROMETA(stash);
3437 +    HV* isarev;
3438 +    HE* iter;
3439 +
3440 +    /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
3441 +       invalidate all method caches globally */
3442 +    if(meta->is_universal) {
3443 +        PL_sub_generation++;
3444 +        return;
3445 +    }
3446 +
3447 +    /* else, invalidate the method caches of all child classes,
3448 +       but not itself */
3449 +    if((isarev = meta->mro_isarev)) {
3450 +        hv_iterinit(isarev);
3451 +        while((iter = hv_iternext(isarev))) {
3452 +            SV* revkey = hv_iterkeysv(iter);
3453 +            HV* revstash = gv_stashsv(revkey, 0);
3454 +            struct mro_meta* mrometa = HvMROMETA(revstash);
3455 +            mrometa->sub_generation++;
3456 +            if(mrometa->mro_nextmethod)
3457 +                hv_clear(mrometa->mro_nextmethod);
3458 +        }
3459 +    }
3460 +}
3461 +
3462 +/* These two are static helpers for next::method and friends,
3463 +   and re-implement a bunch of the code from pp_caller() in
3464 +   a more efficient manner for this particular usage.
3465 +*/
3466 +
3467 +STATIC I32
3468 +__dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
3469 +    I32 i;
3470 +    for (i = startingblock; i >= 0; i--) {
3471 +        if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
3472 +    }
3473 +    return i;
3474 +}
3475 +
3476 +STATIC SV*
3477 +__nextcan(pTHX_ SV* self, I32 throw_nomethod)
3478 +{
3479 +    register I32 cxix;
3480 +    register const PERL_CONTEXT *ccstack = cxstack;
3481 +    const PERL_SI *top_si = PL_curstackinfo;
3482 +    HV* selfstash;
3483 +    GV* cvgv;
3484 +    SV *stashname;
3485 +    const char *fq_subname;
3486 +    const char *subname;
3487 +    STRLEN fq_subname_len;
3488 +    STRLEN stashname_len;
3489 +    STRLEN subname_len;
3490 +    SV* sv;
3491 +    GV** gvp;
3492 +    AV* linear_av;
3493 +    SV** linear_svp;
3494 +    SV* linear_sv;
3495 +    HV* curstash;
3496 +    GV* candidate = NULL;
3497 +    CV* cand_cv = NULL;
3498 +    const char *hvname;
3499 +    I32 items;
3500 +    struct mro_meta* selfmeta;
3501 +    HV* nmcache;
3502 +    HE* cache_entry;
3503 +
3504 +    if(sv_isobject(self))
3505 +        selfstash = SvSTASH(SvRV(self));
3506 +    else
3507 +        selfstash = gv_stashsv(self, 0);
3508 +
3509 +    assert(selfstash);
3510 +
3511 +    hvname = HvNAME_get(selfstash);
3512 +    if (!hvname)
3513 +        croak("Can't use anonymous symbol table for method lookup");
3514 +
3515 +    cxix = __dopoptosub_at(cxstack, cxstack_ix);
3516 +
3517 +    /* This block finds the contextually-enclosing fully-qualified subname,
3518 +       much like looking at (caller($i))[3] until you find a real sub that
3519 +       isn't ANON, etc */
3520 +    for (;;) {
3521 +        /* we may be in a higher stacklevel, so dig down deeper */
3522 +        while (cxix < 0) {
3523 +            if(top_si->si_type == PERLSI_MAIN)
3524 +                croak("next::method/next::can/maybe::next::method must be used in method context");
3525 +            top_si = top_si->si_prev;
3526 +            ccstack = top_si->si_cxstack;
3527 +            cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
3528 +        }
3529 +
3530 +        if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
3531 +          || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
3532 +            cxix = __dopoptosub_at(ccstack, cxix - 1);
3533 +            continue;
3534 +        }
3535 +
3536 +        {
3537 +            const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
3538 +            if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
3539 +                if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
3540 +                    cxix = dbcxix;
3541 +                    continue;
3542 +                }
3543 +            }
3544 +        }
3545 +
3546 +        cvgv = CvGV(ccstack[cxix].blk_sub.cv);
3547 +
3548 +        if(!isGV(cvgv)) {
3549 +            cxix = __dopoptosub_at(ccstack, cxix - 1);
3550 +            continue;
3551 +        }
3552 +
3553 +        /* we found a real sub here */
3554 +        sv = sv_2mortal(newSV(0));
3555 +
3556 +        gv_efullname3(sv, cvgv, NULL);
3557 +
3558 +        fq_subname = SvPVX(sv);
3559 +        fq_subname_len = SvCUR(sv);
3560 +
3561 +        subname = strrchr(fq_subname, ':');
3562 +        if(!subname)
3563 +            croak("next::method/next::can/maybe::next::method cannot find enclosing method");
3564 +
3565 +        subname++;
3566 +        subname_len = fq_subname_len - (subname - fq_subname);
3567 +        if(subname_len == 8 && strEQ(subname, "__ANON__")) {
3568 +            cxix = __dopoptosub_at(ccstack, cxix - 1);
3569 +            continue;
3570 +        }
3571 +        break;
3572 +    }
3573 +
3574 +    /* If we made it to here, we found our context */
3575 +
3576 +    selfmeta = HvMROMETA(selfstash);
3577 +    if(!(nmcache = selfmeta->mro_nextmethod)) {
3578 +        nmcache = selfmeta->mro_nextmethod = newHV();
3579 +    }
3580 +
3581 +    if((cache_entry = hv_fetch_ent(nmcache, sv, 0, 0))) {
3582 +        SV* val = HeVAL(cache_entry);
3583 +        if(val == &PL_sv_undef) {
3584 +            if(throw_nomethod)
3585 +                croak("No next::method '%s' found for %s", subname, hvname);
3586 +            return &PL_sv_undef;
3587 +        }
3588 +        return SvREFCNT_inc_simple_NN(val);
3589 +    }
3590 +
3591 +    /* beyond here is just for cache misses, so perf isn't as critical */
3592 +
3593 +    stashname_len = subname - fq_subname - 2;
3594 +    stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
3595 +
3596 +    linear_av = mro_linear(selfstash); /* has ourselves at the top of the list */
3597 +    sv_2mortal((SV*)linear_av);
3598 +
3599 +    linear_svp = AvARRAY(linear_av);
3600 +    items = AvFILLp(linear_av) + 1;
3601 +
3602 +    while (items--) {
3603 +        linear_sv = *linear_svp++;
3604 +        assert(linear_sv);
3605 +        if(sv_eq(linear_sv, stashname))
3606 +            break;
3607 +    }
3608 +
3609 +    if(items > 0) {
3610 +        while (items--) {
3611 +            linear_sv = *linear_svp++;
3612 +            assert(linear_sv);
3613 +            curstash = gv_stashsv(linear_sv, FALSE);
3614 +
3615 +            if (!curstash || (HvMROMETA(curstash)->fake && !HvFILL(curstash))) {
3616 +                if (ckWARN(WARN_MISC))
3617 +                    Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
3618 +                        (void*)linear_sv, hvname);
3619 +                continue;
3620 +            }
3621 +
3622 +            assert(curstash);
3623 +
3624 +            gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
3625 +            if (!gvp) continue;
3626 +
3627 +            candidate = *gvp;
3628 +            assert(candidate);
3629 +
3630 +            if (SvTYPE(candidate) != SVt_PVGV)
3631 +                gv_init(candidate, curstash, subname, subname_len, TRUE);
3632 +            if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
3633 +                SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
3634 +                hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
3635 +                return (SV*)cand_cv;
3636 +            }
3637 +        }
3638 +    }
3639 +
3640 +    hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
3641 +    if(throw_nomethod)
3642 +        croak("No next::method '%s' found for %s", subname, hvname);
3643 +    return &PL_sv_undef;
3644 +}
3645 +
3646 +#include "XSUB.h"
3647 +
3648 +XS(XS_mro_get_linear_isa);
3649 +XS(XS_mro_set_mro);
3650 +XS(XS_mro_get_mro);
3651 +XS(XS_mro_get_global_sub_generation);
3652 +XS(XS_mro_invalidate_all_method_caches);
3653 +XS(XS_mro_get_sub_generation);
3654 +XS(XS_mro_invalidate_method_cache);
3655 +XS(XS_next_can);
3656 +XS(XS_next_method);
3657 +XS(XS_maybe_next_method);
3658 +
3659 +void
3660 +Perl_boot_core_mro(pTHX)
3661 +{
3662 +    dVAR;
3663 +    static const char file[] = __FILE__;
3664 +
3665 +    newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
3666 +    newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
3667 +    newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
3668 +    newXSproto("mro::get_global_sub_generation", XS_mro_get_global_sub_generation, file, "");
3669 +    newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_all_method_caches, file, "");
3670 +    newXSproto("mro::get_sub_generation", XS_mro_get_sub_generation, file, "$");
3671 +    newXSproto("mro::invalidate_method_cache", XS_mro_invalidate_method_cache, file, "$");
3672 +    newXS("next::can", XS_next_can, file);
3673 +    newXS("next::method", XS_next_method, file);
3674 +    newXS("maybe::next::method", XS_maybe_next_method, file);
3675 +}
3676 +
3677 +XS(XS_mro_get_linear_isa) {
3678 +    dVAR;
3679 +    dXSARGS;
3680 +    AV* RETVAL;
3681 +    HV* class_stash;
3682 +    SV* classname;
3683 +
3684 +    if(items < 1 || items > 2)
3685 +       croak("Usage: mro::get_linear_isa(classname [, type ])");
3686 +
3687 +    classname = ST(0);
3688 +    class_stash = gv_stashsv(classname, 0);
3689 +    if(!class_stash) croak("No such class: '%"SVf"'!", SVfARG(classname));
3690 +
3691 +    if(items > 1) {
3692 +        char* which = SvPV_nolen(ST(1));
3693 +        if(strEQ(which, "dfs"))
3694 +            RETVAL = mro_linear_dfs(class_stash, 0);
3695 +        else if(strEQ(which, "c3"))
3696 +            RETVAL = mro_linear_c3(class_stash, 0);
3697 +        else
3698 +            croak("Invalid mro name: '%s'", which);
3699 +    }
3700 +    else {
3701 +        RETVAL = mro_linear(class_stash);
3702 +    }
3703 +
3704 +    ST(0) = newRV_noinc((SV*)RETVAL);
3705 +    sv_2mortal(ST(0));
3706 +    XSRETURN(1);
3707 +}
3708 +
3709 +XS(XS_mro_set_mro)
3710 +{
3711 +    dVAR;
3712 +    dXSARGS;
3713 +    SV* classname;
3714 +    char* whichstr;
3715 +    mro_alg which;
3716 +    HV* class_stash;
3717 +    struct mro_meta* meta;
3718 +
3719 +    if (items != 2)
3720 +       croak("Usage: mro::set_mro(classname, type)");
3721 +
3722 +    classname = ST(0);
3723 +    whichstr = SvPV_nolen(ST(1));
3724 +    class_stash = gv_stashsv(classname, GV_ADD);
3725 +    if(!class_stash) croak("Cannot create class: '%"SVf"'!", SVfARG(classname));
3726 +    meta = HvMROMETA(class_stash);
3727 +
3728 +    if(strEQ(whichstr, "dfs"))
3729 +        which = MRO_DFS;
3730 +    else if(strEQ(whichstr, "c3"))
3731 +        which = MRO_C3;
3732 +    else
3733 +        croak("Invalid mro name: '%s'", whichstr);
3734 +
3735 +    if(meta->mro_which != which) {
3736 +        meta->mro_which = which;
3737 +        /* Only affects local method cache, not
3738 +           even child classes */
3739 +        meta->sub_generation++;
3740 +        if(meta->mro_nextmethod)
3741 +            hv_clear(meta->mro_nextmethod);
3742 +    }
3743 +
3744 +    XSRETURN_EMPTY;
3745 +}
3746 +
3747 +
3748 +XS(XS_mro_get_mro)
3749 +{
3750 +    dVAR;
3751 +    dXSARGS;
3752 +    SV* classname;
3753 +    HV* class_stash;
3754 +    struct mro_meta* meta;
3755 +
3756 +    if (items != 1)
3757 +       croak("Usage: mro::get_mro(classname)");
3758 +
3759 +    classname = ST(0);
3760 +    class_stash = gv_stashsv(classname, 0);
3761 +    if(!class_stash) croak("No such class: '%"SVf"'!", SVfARG(classname));
3762 +    meta = HvMROMETA(class_stash);
3763 +
3764 +    if(meta->mro_which == MRO_DFS)
3765 +        ST(0) = sv_2mortal(newSVpvn("dfs", 3));
3766 +    else
3767 +        ST(0) = sv_2mortal(newSVpvn("c3", 2));
3768 +
3769 +    XSRETURN(1);
3770 +}
3771 +
3772 +XS(XS_mro_get_global_sub_generation)
3773 +{
3774 +    dVAR;
3775 +    dXSARGS;
3776 +
3777 +    if (items != 0)
3778 +        croak("Usage: mro::get_global_sub_generation()");
3779 +
3780 +    ST(0) = sv_2mortal(newSViv(PL_sub_generation));
3781 +    XSRETURN(1);
3782 +}
3783 +
3784 +XS(XS_mro_invalidate_all_method_caches)
3785 +{
3786 +    dVAR;
3787 +    dXSARGS;
3788 +
3789 +    if (items != 0)
3790 +        croak("Usage: mro::invalidate_all_method_caches()");
3791 +
3792 +    PL_sub_generation++;
3793 +
3794 +    XSRETURN_EMPTY;
3795 +}
3796 +
3797 +XS(XS_mro_get_sub_generation)
3798 +{
3799 +    dVAR;
3800 +    dXSARGS;
3801 +    SV* classname;
3802 +    HV* class_stash;
3803 +
3804 +    if(items != 1)
3805 +        croak("Usage: mro::get_sub_generation(classname)");
3806 +
3807 +    classname = ST(0);
3808 +    class_stash = gv_stashsv(classname, 0);
3809 +    if(!class_stash) croak("No such class: '%"SVf"'!", SVfARG(classname));
3810 +
3811 +    ST(0) = sv_2mortal(newSViv(HvMROMETA(class_stash)->sub_generation));
3812 +    XSRETURN(1);
3813 +}
3814 +
3815 +XS(XS_mro_invalidate_method_cache)
3816 +{
3817 +    dVAR;
3818 +    dXSARGS;
3819 +    SV* classname;
3820 +    HV* class_stash;
3821 +
3822 +    if(items != 1)
3823 +        croak("Usage: mro::invalidate_method_cache(classname)");
3824 +
3825 +    classname = ST(0);
3826 +
3827 +    class_stash = gv_stashsv(classname, 0);
3828 +    if(!class_stash) croak("No such class: '%"SVf"'!", SVfARG(classname));
3829 +
3830 +    mro_method_changed_in(class_stash);
3831 +
3832 +    XSRETURN_EMPTY;
3833 +}
3834 +
3835 +XS(XS_next_can)
3836 +{
3837 +    dVAR;
3838 +    dXSARGS;
3839 +    SV* self = ST(0);
3840 +    SV* methcv = __nextcan(self, 0);
3841 +
3842 +    PERL_UNUSED_VAR(items);
3843 +
3844 +    if(methcv == &PL_sv_undef) {
3845 +        ST(0) = &PL_sv_undef;
3846 +    }
3847 +    else {
3848 +        ST(0) = sv_2mortal(newRV_inc(methcv));
3849 +    }
3850 +
3851 +    XSRETURN(1);
3852 +}
3853 +
3854 +XS(XS_next_method)
3855 +{
3856 +    dMARK;
3857 +    dAX;
3858 +    SV* self = ST(0);
3859 +    SV* methcv = __nextcan(self, 1);
3860 +
3861 +    PL_markstack_ptr++;
3862 +    call_sv(methcv, GIMME_V);
3863 +}
3864 +
3865 +XS(XS_maybe_next_method)
3866 +{
3867 +    dMARK;
3868 +    dAX;
3869 +    SV* self = ST(0);
3870 +    SV* methcv = __nextcan(self, 0);
3871 +
3872 +    if(methcv == &PL_sv_undef) {
3873 +        ST(0) = &PL_sv_undef;
3874 +        XSRETURN(1);
3875 +    }
3876 +
3877 +    PL_markstack_ptr++;
3878 +    call_sv(methcv, GIMME_V);
3879 +}
3880 +
3881 +/*
3882 + * Local variables:
3883 + * c-indentation-style: bsd
3884 + * c-basic-offset: 4
3885 + * indent-tabs-mode: t
3886 + * End:
3887 + *
3888 + * ex: set ts=8 sts=4 sw=4 noet:
3889 + */
3890 === hv.c
3891 ==================================================================
3892 --- hv.c        (/local/perl-current)   (revision 30426)
3893 +++ hv.c        (/local/perl-c3-subg)   (revision 30426)
3894 @@ -1531,7 +1531,7 @@
3895         return;
3896      val = HeVAL(entry);
3897      if (val && isGV(val) && GvCVu(val) && HvNAME_get(hv))
3898 -       PL_sub_generation++;    /* may be deletion of method from stash */
3899 +        mro_method_changed_in(hv);     /* deletion of method from stash */
3900      SvREFCNT_dec(val);
3901      if (HeKLEN(entry) == HEf_SVKEY) {
3902         SvREFCNT_dec(HeKEY_sv(entry));
3903 @@ -1726,6 +1726,7 @@
3904
3905         if (SvOOK(hv)) {
3906             HE *entry;
3907 +            struct mro_meta *meta;
3908             struct xpvhv_aux *iter = HvAUX(hv);
3909             /* If there are weak references to this HV, we need to avoid
3910                freeing them up here.  In particular we need to keep the AV
3911 @@ -1757,6 +1758,15 @@
3912             iter->xhv_riter = -1;       /* HvRITER(hv) = -1 */
3913             iter->xhv_eiter = NULL;     /* HvEITER(hv) = NULL */
3914
3915 +            if((meta = iter->xhv_mro_meta)) {
3916 +                if(meta->mro_linear_dfs) SvREFCNT_dec(meta->mro_linear_dfs);
3917 +                if(meta->mro_linear_c3)  SvREFCNT_dec(meta->mro_linear_c3);
3918 +                if(meta->mro_isarev)     SvREFCNT_dec(meta->mro_isarev);
3919 +                if(meta->mro_nextmethod) SvREFCNT_dec(meta->mro_nextmethod);
3920 +                Safefree(meta);
3921 +                iter->xhv_mro_meta = NULL;
3922 +            }
3923 +
3924             /* There are now no allocated pointers in the aux structure.  */
3925
3926             SvFLAGS(hv) &= ~SVf_OOK; /* Goodbye, aux structure.  */
3927 @@ -1878,6 +1888,7 @@
3928      iter->xhv_eiter = NULL;    /* HvEITER(hv) = NULL */
3929      iter->xhv_name = 0;
3930      iter->xhv_backreferences = 0;
3931 +    iter->xhv_mro_meta = NULL;
3932      return iter;
3933  }
3934
3935 === hv.h
3936 ==================================================================
3937 --- hv.h        (/local/perl-current)   (revision 30426)
3938 +++ hv.h        (/local/perl-c3-subg)   (revision 30426)
3939 @@ -38,12 +38,38 @@
3940
3941  /* Subject to change.
3942     Don't access this directly.
3943 +   Use the funcs in mro.c
3944  */
3945 +
3946 +typedef enum {
3947 +    MRO_DFS, /* 0 */
3948 +    MRO_C3   /* 1 */
3949 +} mro_alg;
3950 +
3951 +struct mro_meta {
3952 +    AV          *mro_linear_dfs; /* cached dfs @ISA linearization */
3953 +    AV          *mro_linear_c3; /* cached c3 @ISA linearization */
3954 +    HV         *mro_isarev;    /* reverse @ISA dependencies (who depends on us?) */
3955 +    HV         *mro_nextmethod; /* next::method caching */
3956 +    mro_alg     mro_which;      /* which mro alg is in use? */
3957 +    U32         sub_generation; /* Like PL_sub_generation, but stash-local */
3958 +    I32         is_universal;   /* We are UNIVERSAL or a potentially indirect
3959 +                                   member of @UNIVERSAL::ISA */
3960 +    I32         fake;           /* setisa made this fake package,
3961 +                                   gv_fetchmeth pays attention to this,
3962 +                                   and "package" sets it back to zero */
3963 +};
3964 +
3965 +/* Subject to change.
3966 +   Don't access this directly.
3967 +*/
3968 +
3969  struct xpvhv_aux {
3970      HEK                *xhv_name;      /* name, if a symbol table */
3971      AV         *xhv_backreferences; /* back references for weak references */
3972      HE         *xhv_eiter;     /* current entry of iterator */
3973      I32                xhv_riter;      /* current root of iterator */
3974 +    struct mro_meta *xhv_mro_meta;
3975  };
3976
3977  /* hash structure: */
3978 @@ -240,6 +266,7 @@
3979  #define HvRITER_get(hv)        (SvOOK(hv) ? HvAUX(hv)->xhv_riter : -1)
3980  #define HvEITER_get(hv)        (SvOOK(hv) ? HvAUX(hv)->xhv_eiter : 0)
3981  #define HvNAME(hv)     HvNAME_get(hv)
3982 +#define HvMROMETA(hv)  (HvAUX(hv)->xhv_mro_meta ? HvAUX(hv)->xhv_mro_meta : mro_meta_init(hv))
3983  /* FIXME - all of these should use a UTF8 aware API, which should also involve
3984     getting the length. */
3985  /* This macro may go away without notice.  */
3986 === mg.c
3987 ==================================================================
3988 --- mg.c        (/local/perl-current)   (revision 30426)
3989 +++ mg.c        (/local/perl-c3-subg)   (revision 30426)
3990 @@ -1530,8 +1530,18 @@
3991  {
3992      dVAR;
3993      PERL_UNUSED_ARG(sv);
3994 -    PERL_UNUSED_ARG(mg);
3995 -    PL_sub_generation++;
3996 +
3997 +    /* The first case occurs via setisa,
3998 +       the second via setisa_elem, which
3999 +       calls this same magic */
4000 +    mro_isa_changed_in(
4001 +        GvSTASH(
4002 +            SvTYPE(mg->mg_obj) == SVt_PVGV
4003 +                ? (GV*)mg->mg_obj
4004 +                : (GV*)SvMAGIC(mg->mg_obj)->mg_obj
4005 +        )
4006 +    );
4007 +
4008      return 0;
4009  }
4010
4011 @@ -1541,7 +1551,6 @@
4012      dVAR;
4013      PERL_UNUSED_ARG(sv);
4014      PERL_UNUSED_ARG(mg);
4015 -    /* HV_badAMAGIC_on(Sv_STASH(sv)); */
4016      PL_amagic_generation++;
4017
4018      return 0;
4019 === op.c
4020 ==================================================================
4021 --- op.c        (/local/perl-current)   (revision 30426)
4022 +++ op.c        (/local/perl-c3-subg)   (revision 30426)
4023 @@ -3648,6 +3648,11 @@
4024      save_item(PL_curstname);
4025
4026      PL_curstash = gv_stashsv(sv, GV_ADD);
4027 +
4028 +    /* In case mg.c:Perl_magic_setisa faked
4029 +       this package earlier, we clear the fake flag */
4030 +    HvMROMETA(PL_curstash)->fake = 0;
4031 +
4032      sv_setsv(PL_curstname, sv);
4033
4034      PL_hints |= HINT_BLOCK_SCOPE;
4035 @@ -5290,9 +5295,9 @@
4036             sv_setpvn((SV*)gv, ps, ps_len);
4037         else
4038             sv_setiv((SV*)gv, -1);
4039 +
4040         SvREFCNT_dec(PL_compcv);
4041         cv = PL_compcv = NULL;
4042 -       PL_sub_generation++;
4043         goto done;
4044      }
4045
4046 @@ -5386,7 +5391,13 @@
4047             GvCV(gv) = NULL;
4048             cv = newCONSTSUB(NULL, name, const_sv);
4049         }
4050 -       PL_sub_generation++;
4051 +        mro_method_changed_in( /* sub Foo::Bar () { 123 } */
4052 +            (CvGV(cv) && GvSTASH(CvGV(cv)))
4053 +                ? GvSTASH(CvGV(cv))
4054 +                : CvSTASH(cv)
4055 +                    ? CvSTASH(cv)
4056 +                    : PL_curstash
4057 +        );
4058         if (PL_madskills)
4059             goto install_block;
4060         op_free(block);
4061 @@ -5456,7 +5467,7 @@
4062         SvREFCNT_dec(PL_compcv);
4063         PL_compcv = cv;
4064         if (PERLDB_INTER)/* Advice debugger on the new sub. */
4065 -         ++PL_sub_generation;
4066 +         ++PL_sub_generation; /* why? -- blblack */
4067      }
4068      else {
4069         cv = PL_compcv;
4070 @@ -5469,7 +5480,7 @@
4071                 }
4072             }
4073             GvCVGEN(gv) = 0;
4074 -           PL_sub_generation++;
4075 +            mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
4076         }
4077      }
4078      CvGV(cv) = gv;
4079 @@ -5801,7 +5812,7 @@
4080         if (name) {
4081             GvCV(gv) = cv;
4082             GvCVGEN(gv) = 0;
4083 -           PL_sub_generation++;
4084 +            mro_method_changed_in(GvSTASH(gv)); /* newXS */
4085         }
4086      }
4087      CvGV(cv) = gv;
4088 === sv.c
4089 ==================================================================
4090 --- sv.c        (/local/perl-current)   (revision 30426)
4091 +++ sv.c        (/local/perl-c3-subg)   (revision 30426)
4092 @@ -3245,7 +3245,7 @@
4093                     SvREFCNT_dec(GvCV(dstr));
4094                     GvCV(dstr) = NULL;
4095                     GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4096 -                   PL_sub_generation++;
4097 +                   mro_method_changed_in(GvSTASH(dstr));
4098                 }
4099             }
4100             SAVEGENERICSV(*location);
4101 @@ -3291,7 +3291,7 @@
4102             }
4103             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4104             GvASSUMECV_on(dstr);
4105 -           PL_sub_generation++;
4106 +           mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
4107         }
4108         *location = sref;
4109         if (import_flag && !(GvFLAGS(dstr) & import_flag)
4110 === pp_hot.c
4111 ==================================================================
4112 --- pp_hot.c    (/local/perl-current)   (revision 30426)
4113 +++ pp_hot.c    (/local/perl-c3-subg)   (revision 30426)
4114 @@ -192,7 +192,7 @@
4115
4116         if (strEQ(GvNAME(right),"isa")) {
4117             GvCVGEN(right) = 0;
4118 -           ++PL_sub_generation;
4119 +           ++PL_sub_generation; /* I don't get this at all --blblack */
4120         }
4121      }
4122      SvSetMagicSV(right, left);
4123 @@ -3060,7 +3060,8 @@
4124         if (he) {
4125             gv = (GV*)HeVAL(he);
4126             if (isGV(gv) && GvCV(gv) &&
4127 -               (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
4128 +               (!GvCVGEN(gv) || GvCVGEN(gv)
4129 +                  == (PL_sub_generation + HvMROMETA(stash)->sub_generation)))
4130                 return (SV*)GvCV(gv);
4131         }
4132      }
4133 === embed.fnc
4134 ==================================================================
4135 --- embed.fnc   (/local/perl-current)   (revision 30426)
4136 +++ embed.fnc   (/local/perl-c3-subg)   (revision 30426)
4137 @@ -282,6 +282,13 @@
4138  Ap     |GV*    |gv_fetchfile   |NN const char* name
4139  Ap     |GV*    |gv_fetchfile_flags|NN const char *const name|const STRLEN len\
4140                                 |const U32 flags
4141 +ApM    |struct mro_meta*       |mro_meta_init  |NN HV* stash
4142 +ApM    |AV*    |mro_linear     |NN HV* stash
4143 +ApM    |AV*    |mro_linear_c3  |NN HV* stash|I32 level
4144 +ApM    |AV*    |mro_linear_dfs |NN HV* stash|I32 level
4145 +ApM     |void   |mro_isa_changed_in|NN HV* stash
4146 +ApM    |void   |mro_method_changed_in  |NN HV* stash
4147 +ApM     |void   |boot_core_mro
4148  Apd    |GV*    |gv_fetchmeth   |NULLOK HV* stash|NN const char* name|STRLEN len|I32 level
4149  Apd    |GV*    |gv_fetchmeth_autoload  |NULLOK HV* stash|NN const char* name|STRLEN len|I32 level
4150  Apdmb  |GV*    |gv_fetchmethod |NULLOK HV* stash|NN const char* name
4151
4152 Property changes on:
4153 ___________________________________________________________________
4154 Name: svk:merge
4155  +bc823f99-e23a-42ae-8890-ba2193b93f74:/local/perl-c3:30425
4156  +bc823f99-e23a-42ae-8890-ba2193b93f74:/local/perl-c3-isarev:29720
4157  +bc823f99-e23a-42ae-8890-ba2193b93f74:/local/perl-current:30424
4158