c3.patch

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