c3.patch

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