c3.patch

   1 === Makefile.micro
   2 ==================================================================
   3 --- Makefile.micro      (/local/perl-current)   (revision 12599)
   4 +++ Makefile.micro      (/local/perl-c3)        (revision 12599)
   5 @@ -9,7 +9,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 @@ -70,6 +70,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 12599)
  27 +++ embed.h     (/local/perl-c3)        (revision 12599)
  28 @@ -266,6 +266,10 @@
  29  #define gv_efullname           Perl_gv_efullname
  30  #define gv_efullname4          Perl_gv_efullname4
  31  #define gv_fetchfile           Perl_gv_fetchfile
  32 +#define mro_meta_init          Perl_mro_meta_init
  33 +#define mro_linear             Perl_mro_linear
  34 +#define mro_linear_c3          Perl_mro_linear_c3
  35 +#define mro_linear_dfs         Perl_mro_linear_dfs
  36  #define gv_fetchmeth           Perl_gv_fetchmeth
  37  #define gv_fetchmeth_autoload  Perl_gv_fetchmeth_autoload
  38  #define gv_fetchmethod_autoload        Perl_gv_fetchmethod_autoload
  39 @@ -2474,6 +2478,10 @@
  40  #define gv_efullname(a,b)      Perl_gv_efullname(aTHX_ a,b)
  41  #define gv_efullname4(a,b,c,d) Perl_gv_efullname4(aTHX_ a,b,c,d)
  42  #define gv_fetchfile(a)                Perl_gv_fetchfile(aTHX_ a)
  43 +#define mro_meta_init(a)       Perl_mro_meta_init(aTHX_ a)
  44 +#define mro_linear(a)          Perl_mro_linear(aTHX_ a)
  45 +#define mro_linear_c3(a,b)     Perl_mro_linear_c3(aTHX_ a,b)
  46 +#define mro_linear_dfs(a,b)    Perl_mro_linear_dfs(aTHX_ a,b)
  47  #define gv_fetchmeth(a,b,c,d)  Perl_gv_fetchmeth(aTHX_ a,b,c,d)
  48  #define gv_fetchmeth_autoload(a,b,c,d) Perl_gv_fetchmeth_autoload(aTHX_ a,b,c,d)
  49  #define gv_fetchmethod_autoload(a,b,c) Perl_gv_fetchmethod_autoload(aTHX_ a,b,c)
  50 === embedvar.h
  51 ==================================================================
  52 --- embedvar.h  (/local/perl-current)   (revision 12599)
  53 +++ embedvar.h  (/local/perl-c3)        (revision 12599)
  54 @@ -227,6 +227,7 @@
  55  #define PL_incgv               (vTHX->Iincgv)
  56  #define PL_initav              (vTHX->Iinitav)
  57  #define PL_inplace             (vTHX->Iinplace)
  58 +#define PL_isa_generation      (vTHX->Iisa_generation)
  59  #define PL_known_layers                (vTHX->Iknown_layers)
  60  #define PL_last_lop            (vTHX->Ilast_lop)
  61  #define PL_last_lop_op         (vTHX->Ilast_lop_op)
  62 @@ -493,6 +494,7 @@
  63  #define PL_Iincgv              PL_incgv
  64  #define PL_Iinitav             PL_initav
  65  #define PL_Iinplace            PL_inplace
  66 +#define PL_Iisa_generation     PL_isa_generation
  67  #define PL_Iknown_layers       PL_known_layers
  68  #define PL_Ilast_lop           PL_last_lop
  69  #define PL_Ilast_lop_op                PL_last_lop_op
  70 === pod/perlapi.pod
  71 ==================================================================
  72 --- pod/perlapi.pod     (/local/perl-current)   (revision 12599)
  73 +++ pod/perlapi.pod     (/local/perl-c3)        (revision 12599)
  74 @@ -1280,7 +1280,7 @@
  75  The argument C<level> should be either 0 or -1.  If C<level==0>, as a
  76  side-effect creates a glob with the given C<name> in the given C<stash>
  77  which in the case of success contains an alias for the subroutine, and sets
  78 -up caching info for this glob.  Similarly for all the searched stashes.
  79 +up caching info for this glob.
  80
  81  This function grants C<"SUPER"> token as a postfix of the stash name. The
  82  GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
  83 === global.sym
  84 ==================================================================
  85 --- global.sym  (/local/perl-current)   (revision 12599)
  86 +++ global.sym  (/local/perl-c3)        (revision 12599)
  87 @@ -133,6 +133,10 @@
  88  Perl_gv_efullname3
  89  Perl_gv_efullname4
  90  Perl_gv_fetchfile
  91 +Perl_mro_meta_init
  92 +Perl_mro_linear
  93 +Perl_mro_linear_c3
  94 +Perl_mro_linear_dfs
  95  Perl_gv_fetchmeth
  96  Perl_gv_fetchmeth_autoload
  97  Perl_gv_fetchmethod
  98 === universal.c
  99 ==================================================================
 100 --- universal.c (/local/perl-current)   (revision 12599)
 101 +++ universal.c (/local/perl-c3)        (revision 12599)
 102 @@ -36,12 +36,10 @@
 103               int len, int level)
 104  {
 105      dVAR;
 106 -    AV* av;
 107 -    GV* gv;
 108 -    GV** gvp;
 109 -    HV* hv = NULL;
 110 -    SV* subgen = NULL;
 111 +    AV* stash_linear_isa;
 112 +    SV** svp;
 113      const char *hvname;
 114 +    I32 items;
 115
 116      /* A stash/class can go by many names (ie. User == main::User), so
 117         we compare the stash itself just in case */
 118 @@ -56,75 +54,23 @@
 119      if (strEQ(name, "UNIVERSAL"))
 120         return TRUE;
 121
 122 -    if (level > 100)
 123 -       Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
 124 -                  hvname);
 125 -
 126 -    gvp = (GV**)hv_fetchs(stash, "::ISA::CACHE::", FALSE);
 127 -
 128 -    if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv))
 129 -       && (hv = GvHV(gv)))
 130 -    {
 131 -       if (SvIV(subgen) == (IV)PL_sub_generation) {
 132 -           SV** const svp = (SV**)hv_fetch(hv, name, len, FALSE);
 133 -           if (svp) {
 134 -               SV * const sv = *svp;
 135 -#ifdef DEBUGGING
 136 -               if (sv != &PL_sv_undef)
 137 -                   DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
 138 -                                   name, hvname) );
 139 -#endif
 140 -               return (sv == &PL_sv_yes);
 141 -           }
 142 +    stash_linear_isa = sv_2mortal(mro_linear(stash));
 143 +    svp = AvARRAY(stash_linear_isa) + 1;
 144 +    items = AvFILLp(stash_linear_isa);
 145 +    while (items--) {
 146 +       SV* const basename_sv = *svp++;
 147 +        HV* basestash = gv_stashsv(basename_sv, FALSE);
 148 +       if (!basestash) {
 149 +           if (ckWARN(WARN_MISC))
 150 +               Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 151 +                           "Can't locate package %"SVf" for the parents of %s",
 152 +                           (void*)basename_sv, hvname);
 153 +           continue;
 154         }
 155 -       else {
 156 -           DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
 157 -                             hvname) );
 158 -           hv_clear(hv);
 159 -           sv_setiv(subgen, PL_sub_generation);
 160 -       }
 161 +        if(name_stash == basestash || strEQ(name, SvPVX(basename_sv)))
 162 +           return TRUE;
 163      }
 164
 165 -    gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
 166 -
 167 -    if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
 168 -       if (!hv || !subgen) {
 169 -           gvp = (GV**)hv_fetchs(stash, "::ISA::CACHE::", TRUE);
 170 -
 171 -           gv = *gvp;
 172 -
 173 -           if (SvTYPE(gv) != SVt_PVGV)
 174 -               gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
 175 -
 176 -           if (!hv)
 177 -               hv = GvHVn(gv);
 178 -           if (!subgen) {
 179 -               subgen = newSViv(PL_sub_generation);
 180 -               GvSV(gv) = subgen;
 181 -           }
 182 -       }
 183 -       if (hv) {
 184 -           SV** svp = AvARRAY(av);
 185 -           /* NOTE: No support for tied ISA */
 186 -           I32 items = AvFILLp(av) + 1;
 187 -           while (items--) {
 188 -               SV* const sv = *svp++;
 189 -               HV* const basestash = gv_stashsv(sv, FALSE);
 190 -               if (!basestash) {
 191 -                   if (ckWARN(WARN_MISC))
 192 -                       Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 193 -                                   "Can't locate package %"SVf" for @%s::ISA",
 194 -                                   (void*)sv, hvname);
 195 -                   continue;
 196 -               }
 197 -               if (isa_lookup(basestash, name, name_stash, len, level + 1)) {
 198 -                   (void)hv_store(hv,name,len,&PL_sv_yes,0);
 199 -                   return TRUE;
 200 -               }
 201 -           }
 202 -           (void)hv_store(hv,name,len,&PL_sv_no,0);
 203 -       }
 204 -    }
 205      return FALSE;
 206  }
 207
 208 === gv.c
 209 ==================================================================
 210 --- gv.c        (/local/perl-current)   (revision 12599)
 211 +++ gv.c        (/local/perl-c3)        (revision 12599)
 212 @@ -298,7 +298,7 @@
 213  The argument C<level> should be either 0 or -1.  If C<level==0>, as a
 214  side-effect creates a glob with the given C<name> in the given C<stash>
 215  which in the case of success contains an alias for the subroutine, and sets
 216 -up caching info for this glob.  Similarly for all the searched stashes.
 217 +up caching info for this glob.
 218
 219  This function grants C<"SUPER"> token as a postfix of the stash name. The
 220  GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
 221 @@ -309,133 +309,137 @@
 222  =cut
 223  */
 224
 225 +/* NOTE: No support for tied ISA */
 226 +
 227  GV *
 228  Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 229  {
 230      dVAR;
 231 -    AV* av;
 232 -    GV* topgv;
 233 -    GV* gv;
 234      GV** gvp;
 235 -    CV* cv;
 236 +    AV* linear_av;
 237 +    SV** linear_svp;
 238 +    SV* linear_sv;
 239 +    HV* curstash;
 240 +    GV* candidate = NULL;
 241 +    CV* cand_cv = NULL;
 242 +    CV* old_cv;
 243 +    GV* topgv = NULL;
 244      const char *hvname;
 245 -    HV* lastchance = NULL;
 246 +    I32 create = (level >= 0) ? 1 : 0;
 247 +    I32 items;
 248 +    STRLEN packlen;
 249
 250      /* UNIVERSAL methods should be callable without a stash */
 251      if (!stash) {
 252 -       level = -1;  /* probably appropriate */
 253 +       create = 0;  /* probably appropriate */
 254         if(!(stash = gv_stashpvs("UNIVERSAL", FALSE)))
 255             return 0;
 256      }
 257
 258 +    assert(stash);
 259 +
 260      hvname = HvNAME_get(stash);
 261      if (!hvname)
 262 -      Perl_croak(aTHX_
 263 -                "Can't use anonymous symbol table for method lookup");
 264 +      Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
 265
 266 -    if ((level > 100) || (level < -100))
 267 -       Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
 268 -             name, hvname);
 269 +    assert(hvname);
 270 +    assert(name);
 271 +    assert(len >= 0);
 272
 273      DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) );
 274
 275 -    gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
 276 -    if (!gvp)
 277 -       topgv = NULL;
 278 +    /* check locally for a real method or a cache entry */
 279 +    gvp = (GV**)hv_fetch(stash, name, len, create);
 280 +    if(gvp) {
 281 +        topgv = *gvp;
 282 +        assert(topgv);
 283 +        if (SvTYPE(topgv) != SVt_PVGV)
 284 +            gv_init(topgv, stash, name, len, TRUE);
 285 +        if ((cand_cv = GvCV(topgv))) {
 286 +            /* If genuine method or valid cache entry, use it */
 287 +            if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation) {
 288 +                return topgv;
 289 +            }
 290 +            else {
 291 +                /* stale cache entry, junk it and move on */
 292 +               SvREFCNT_dec(cand_cv);
 293 +               GvCV(topgv) = cand_cv = NULL;
 294 +               GvCVGEN(topgv) = 0;
 295 +            }
 296 +        }
 297 +        else if (GvCVGEN(topgv) == PL_sub_generation) {
 298 +            /* cache indicates no such method definitively */
 299 +            return 0;
 300 +        }
 301 +    }
 302 +
 303 +    packlen = HvNAMELEN_get(stash);
 304 +    if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
 305 +        HV* basestash;
 306 +        packlen -= 7;
 307 +        basestash = gv_stashpvn(hvname, packlen, TRUE);
 308 +        linear_av = mro_linear(basestash);
 309 +    }
 310      else {
 311 -       topgv = *gvp;
 312 -       if (SvTYPE(topgv) != SVt_PVGV)
 313 -           gv_init(topgv, stash, name, len, TRUE);
 314 -       if ((cv = GvCV(topgv))) {
 315 -           /* If genuine method or valid cache entry, use it */
 316 -           if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
 317 -               return topgv;
 318 -           /* Stale cached entry: junk it */
 319 -           SvREFCNT_dec(cv);
 320 -           GvCV(topgv) = cv = NULL;
 321 -           GvCVGEN(topgv) = 0;
 322 -       }
 323 -       else if (GvCVGEN(topgv) == PL_sub_generation)
 324 -           return 0;  /* cache indicates sub doesn't exist */
 325 +        linear_av = mro_linear(stash); /* has ourselves at the top of the list */
 326      }
 327 +    sv_2mortal((SV*)linear_av);
 328
 329 -    gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
 330 -    av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : NULL;
 331 +    linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
 332 +    items = AvFILLp(linear_av); /* no +1, to skip over self */
 333 +    while (items--) {
 334 +        linear_sv = *linear_svp++;
 335 +        assert(linear_sv);
 336 +        curstash = gv_stashsv(linear_sv, FALSE);
 337
 338 -    /* create and re-create @.*::SUPER::ISA on demand */
 339 -    if (!av || !SvMAGIC(av)) {
 340 -       STRLEN packlen = HvNAMELEN_get(stash);
 341 +        if (!curstash) {
 342 +            if (ckWARN(WARN_MISC))
 343 +                Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
 344 +                    (void*)linear_sv, hvname);
 345 +            continue;
 346 +        }
 347
 348 -       if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
 349 -           HV* basestash;
 350 +        assert(curstash);
 351
 352 -           packlen -= 7;
 353 -           basestash = gv_stashpvn(hvname, packlen, TRUE);
 354 -           gvp = (GV**)hv_fetchs(basestash, "ISA", FALSE);
 355 -           if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
 356 -               gvp = (GV**)hv_fetchs(stash, "ISA", TRUE);
 357 -               if (!gvp || !(gv = *gvp))
 358 -                   Perl_croak(aTHX_ "Cannot create %s::ISA", hvname);
 359 -               if (SvTYPE(gv) != SVt_PVGV)
 360 -                   gv_init(gv, stash, "ISA", 3, TRUE);
 361 -               SvREFCNT_dec(GvAV(gv));
 362 -               GvAV(gv) = (AV*)SvREFCNT_inc_simple(av);
 363 -           }
 364 -       }
 365 +        gvp = (GV**)hv_fetch(curstash, name, len, 0);
 366 +        if (!gvp) continue;
 367 +        candidate = *gvp;
 368 +        assert(candidate);
 369 +        if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, curstash, name, len, TRUE);
 370 +        if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
 371 +            /*
 372 +             * Found real method, cache method in topgv if:
 373 +             *  1. topgv has no synonyms (else inheritance crosses wires)
 374 +             *  2. method isn't a stub (else AUTOLOAD fails spectacularly)
 375 +             */
 376 +            if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
 377 +                  if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv);
 378 +                  SvREFCNT_inc_simple_void_NN(cand_cv);
 379 +                  GvCV(topgv) = cand_cv;
 380 +                  GvCVGEN(topgv) = PL_sub_generation;
 381 +            }
 382 +           return candidate;
 383 +        }
 384      }
 385
 386 -    if (av) {
 387 -       SV** svp = AvARRAY(av);
 388 -       /* NOTE: No support for tied ISA */
 389 -       I32 items = AvFILLp(av) + 1;
 390 -       while (items--) {
 391 -           SV* const sv = *svp++;
 392 -           HV* const basestash = gv_stashsv(sv, FALSE);
 393 -           if (!basestash) {
 394 -               if (ckWARN(WARN_MISC))
 395 -                   Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
 396 -                       (void*)sv, hvname);
 397 -               continue;
 398 -           }
 399 -           gv = gv_fetchmeth(basestash, name, len,
 400 -                             (level >= 0) ? level + 1 : level - 1);
 401 -           if (gv)
 402 -               goto gotcha;
 403 -       }
 404 +    /* Check UNIVERSAL without caching */
 405 +    if(level == 0 || level == -1) {
 406 +        candidate = gv_fetchmeth(NULL, name, len, 1);
 407 +        if(candidate) {
 408 +            cand_cv = GvCV(candidate);
 409 +            if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
 410 +                  if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv);
 411 +                  SvREFCNT_inc_simple_void_NN(cand_cv);
 412 +                  GvCV(topgv) = cand_cv;
 413 +                  GvCVGEN(topgv) = PL_sub_generation;
 414 +            }
 415 +            return candidate;
 416 +        }
 417      }
 418
 419 -    /* if at top level, try UNIVERSAL */
 420 -
 421 -    if (level == 0 || level == -1) {
 422 -       lastchance = gv_stashpvs("UNIVERSAL", FALSE);
 423 -
 424 -       if (lastchance) {
 425 -           if ((gv = gv_fetchmeth(lastchance, name, len,
 426 -                                 (level >= 0) ? level + 1 : level - 1)))
 427 -           {
 428 -         gotcha:
 429 -               /*
 430 -                * Cache method in topgv if:
 431 -                *  1. topgv has no synonyms (else inheritance crosses wires)
 432 -                *  2. method isn't a stub (else AUTOLOAD fails spectacularly)
 433 -                */
 434 -               if (topgv &&
 435 -                   GvREFCNT(topgv) == 1 &&
 436 -                   (cv = GvCV(gv)) &&
 437 -                   (CvROOT(cv) || CvXSUB(cv)))
 438 -               {
 439 -                   if ((cv = GvCV(topgv)))
 440 -                       SvREFCNT_dec(cv);
 441 -                   GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
 442 -                   GvCVGEN(topgv) = PL_sub_generation;
 443 -               }
 444 -               return gv;
 445 -           }
 446 -           else if (topgv && GvREFCNT(topgv) == 1) {
 447 -               /* cache the fact that the method is not defined */
 448 -               GvCVGEN(topgv) = PL_sub_generation;
 449 -           }
 450 -       }
 451 +    if (topgv && GvREFCNT(topgv) == 1) {
 452 +        /* cache the fact that the method is not defined */
 453 +        GvCVGEN(topgv) = PL_sub_generation;
 454      }
 455
 456      return 0;
 457 === perlapi.h
 458 ==================================================================
 459 --- perlapi.h   (/local/perl-current)   (revision 12599)
 460 +++ perlapi.h   (/local/perl-c3)        (revision 12599)
 461 @@ -332,6 +332,8 @@
 462  #define PL_initav              (*Perl_Iinitav_ptr(aTHX))
 463  #undef  PL_inplace
 464  #define PL_inplace             (*Perl_Iinplace_ptr(aTHX))
 465 +#undef  PL_isa_generation
 466 +#define PL_isa_generation      (*Perl_Iisa_generation_ptr(aTHX))
 467  #undef  PL_known_layers
 468  #define PL_known_layers                (*Perl_Iknown_layers_ptr(aTHX))
 469  #undef  PL_last_lop
 470 === win32/Makefile
 471 ==================================================================
 472 --- win32/Makefile      (/local/perl-current)   (revision 12599)
 473 +++ win32/Makefile      (/local/perl-c3)        (revision 12599)
 474 @@ -644,6 +644,7 @@
 475                 ..\dump.c       \
 476                 ..\globals.c    \
 477                 ..\gv.c         \
 478 +               ..\mro.c        \
 479                 ..\hv.c         \
 480                 ..\locale.c     \
 481                 ..\mathoms.c    \
 482 === win32/makefile.mk
 483 ==================================================================
 484 --- win32/makefile.mk   (/local/perl-current)   (revision 12599)
 485 +++ win32/makefile.mk   (/local/perl-c3)        (revision 12599)
 486 @@ -813,6 +813,7 @@
 487                 ..\dump.c       \
 488                 ..\globals.c    \
 489                 ..\gv.c         \
 490 +               ..\mro.c        \
 491                 ..\hv.c         \
 492                 ..\locale.c     \
 493                 ..\mathoms.c    \
 494 === win32/Makefile.ce
 495 ==================================================================
 496 --- win32/Makefile.ce   (/local/perl-current)   (revision 12599)
 497 +++ win32/Makefile.ce   (/local/perl-c3)        (revision 12599)
 498 @@ -571,6 +571,7 @@
 499                 ..\dump.c       \
 500                 ..\globals.c    \
 501                 ..\gv.c         \
 502 +               ..\mro.c        \
 503                 ..\hv.c         \
 504                 ..\mg.c         \
 505                 ..\op.c         \
 506 @@ -790,6 +791,7 @@
 507  $(DLLDIR)\dump.obj \
 508  $(DLLDIR)\globals.obj \
 509  $(DLLDIR)\gv.obj \
 510 +$(DLLDIR)\mro.obj \
 511  $(DLLDIR)\hv.obj \
 512  $(DLLDIR)\locale.obj \
 513  $(DLLDIR)\mathoms.obj \
 514 === NetWare/Makefile
 515 ==================================================================
 516 --- NetWare/Makefile    (/local/perl-current)   (revision 12599)
 517 +++ NetWare/Makefile    (/local/perl-c3)        (revision 12599)
 518 @@ -701,6 +701,7 @@
 519                 ..\dump.c       \
 520                 ..\globals.c    \
 521                 ..\gv.c         \
 522 +               ..\mro.c        \
 523                 ..\hv.c         \
 524                 ..\locale.c     \
 525                  ..\mathoms.c    \
 526 === vms/descrip_mms.template
 527 ==================================================================
 528 --- vms/descrip_mms.template    (/local/perl-current)   (revision 12599)
 529 +++ vms/descrip_mms.template    (/local/perl-c3)        (revision 12599)
 530 @@ -279,13 +279,13 @@
 531
 532  #### End of system configuration section. ####
 533
 534 -c0 = $(MALLOC_C) $(SOCKC) av.c deb.c doio.c doop.c dump.c globals.c gv.c hv.c
 535 +c0 = $(MALLOC_C) $(SOCKC) av.c deb.c doio.c doop.c dump.c globals.c gv.c hv.c mro.c
 536  c1 = mg.c locale.c mathoms.c miniperlmain.c numeric.c op.c pad.c perl.c perlapi.c perlio.c
 537  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
 538  c3 = run.c scope.c sv.c taint.c toke.c universal.c utf8.c util.c vms.c xsutils.c
 539  c = $(c0) $(c1) $(c2) $(c3)
 540
 541 -obj0 = $(MALLOC_O) $(SOCKO) av$(O) deb$(O) doio$(O) doop$(O) dump$(O)
 542 +obj0 = $(MALLOC_O) $(SOCKO) av$(O) deb$(O) doio$(O) doop$(O) dump$(O) mro$(O)
 543  obj1 = globals$(O) gv$(O) hv$(O) locale$(O) mathoms$(O) mg$(O) miniperlmain$(O) numeric$(O) op$(O) pad$(O)
 544  obj2 = perl$(O) perlapi$(O) perlio$(O) perly$(O) pp$(O) pp_ctl$(O) pp_hot$(O) reentr$(O)
 545  obj3 = pp_pack$(O) pp_sort$(O) pp_sys$(O) regcomp$(O) regexec$(O) run$(O) scope$(O) sv$(O) taint$(O) toke$(O)
 546 @@ -1594,6 +1594,8 @@
 547         $(CC) $(CORECFLAGS) $(MMS$SOURCE)
 548  gv$(O) : gv.c $(h)
 549         $(CC) $(CORECFLAGS) $(MMS$SOURCE)
 550 +mro$(O) : mro.c $(h)
 551 +       $(CC) $(CORECFLAGS) $(MMS$SOURCE)
 552  hv$(O) : hv.c $(h)
 553         $(CC) $(CORECFLAGS) $(MMS$SOURCE)
 554  locale$(O) : locale.c $(h)
 555 === Makefile.SH
 556 ==================================================================
 557 --- Makefile.SH (/local/perl-current)   (revision 12599)
 558 +++ Makefile.SH (/local/perl-c3)        (revision 12599)
 559 @@ -364,7 +364,7 @@
 560  h5 = utf8.h warnings.h
 561  h = $(h1) $(h2) $(h3) $(h4) $(h5)
 562
 563 -c1 = av.c scope.c op.c doop.c doio.c dump.c gv.c hv.c mg.c reentr.c  perl.c
 564 +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
 565  c2 = perly.c pp.c pp_hot.c pp_ctl.c pp_sys.c regcomp.c regexec.c utf8.c sv.c
 566  c3 = taint.c toke.c util.c deb.c run.c universal.c xsutils.c pad.c globals.c
 567  c4 = perlio.c perlapi.c numeric.c mathoms.c locale.c pp_pack.c pp_sort.c
 568 @@ -372,7 +372,7 @@
 569
 570  c = $(c1) $(c2) $(c3) $(c4) $(c5) miniperlmain.c perlmain.c opmini.c
 571
 572 -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)
 573 +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)
 574  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)
 575  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)
 576
 577 === proto.h
 578 ==================================================================
 579 --- proto.h     (/local/perl-current)   (revision 12599)
 580 +++ proto.h     (/local/perl-c3)        (revision 12599)
 581 @@ -624,6 +624,18 @@
 582  PERL_CALLCONV GV*      Perl_gv_fetchfile(pTHX_ const char* name)
 583                         __attribute__nonnull__(pTHX_1);
 584
 585 +PERL_CALLCONV struct mro_meta* Perl_mro_meta_init(pTHX_ HV* stash)
 586 +                       __attribute__nonnull__(pTHX_1);
 587 +
 588 +PERL_CALLCONV AV*      Perl_mro_linear(pTHX_ HV* stash)
 589 +                       __attribute__nonnull__(pTHX_1);
 590 +
 591 +PERL_CALLCONV AV*      Perl_mro_linear_c3(pTHX_ HV* stash, I32 level)
 592 +                       __attribute__nonnull__(pTHX_1);
 593 +
 594 +PERL_CALLCONV AV*      Perl_mro_linear_dfs(pTHX_ HV* stash, I32 level)
 595 +                       __attribute__nonnull__(pTHX_1);
 596 +
 597  PERL_CALLCONV GV*      Perl_gv_fetchmeth(pTHX_ HV* stash, const char* name, STRLEN len, I32 level)
 598                         __attribute__nonnull__(pTHX_2);
 599
 600 === ext/B/t/concise-xs.t
 601 ==================================================================
 602 --- ext/B/t/concise-xs.t        (/local/perl-current)   (revision 12599)
 603 +++ ext/B/t/concise-xs.t        (/local/perl-c3)        (revision 12599)
 604 @@ -117,7 +117,7 @@
 605  use Carp;
 606  use Test::More tests => ( # per-pkg tests (function ct + require_ok)
 607                           40 + 16       # Data::Dumper, Digest::MD5
 608 -                         + 517 + 238   # B::Deparse, B
 609 +                         + 517 + 239   # B::Deparse, B
 610                           + 595 + 190   # POSIX, IO::Socket
 611                           + 3 * ($] > 5.009)
 612                           + 16 * ($] >= 5.009003)
 613 @@ -157,7 +157,7 @@
 614                   formfeed end_av dowarn diehook defstash curstash
 615                   cstring comppadlist check_av cchar cast_I32 bootstrap
 616                   begin_av amagic_generation sub_generation address
 617 -                 unitcheck_av
 618 +                 unitcheck_av isa_generation
 619                   )],
 620      },
 621
 622 === ext/B/B.xs
 623 ==================================================================
 624 --- ext/B/B.xs  (/local/perl-current)   (revision 12599)
 625 +++ ext/B/B.xs  (/local/perl-c3)        (revision 12599)
 626 @@ -604,6 +604,7 @@
 627  #define B_main_start() PL_main_start
 628  #define B_amagic_generation()  PL_amagic_generation
 629  #define B_sub_generation()     PL_sub_generation
 630 +#define B_isa_generation()     PL_isa_generation
 631  #define B_defstash()   PL_defstash
 632  #define B_curstash()   PL_curstash
 633  #define B_dowarn()     PL_dowarn
 634 @@ -656,6 +657,9 @@
 635  long
 636  B_sub_generation()
 637
 638 +long
 639 +B_isa_generation()
 640 +
 641  B::AV
 642  B_comppadlist()
 643
 644 === ext/B/B.pm
 645 ==================================================================
 646 --- ext/B/B.pm  (/local/perl-current)   (revision 12599)
 647 +++ ext/B/B.pm  (/local/perl-c3)        (revision 12599)
 648 @@ -23,6 +23,7 @@
 649                 parents comppadlist sv_undef compile_stats timing_info
 650                 begin_av init_av unitcheck_av check_av end_av regex_padav
 651                 dowarn defstash curstash warnhook diehook inc_gv
 652 +               isa_generation
 653                 );
 654
 655  sub OPf_KIDS ();
 656 === ext/mro/t/basic_01_dfs.t
 657 ==================================================================
 658 --- ext/mro/t/basic_01_dfs.t    (/local/perl-current)   (revision 12599)
 659 +++ ext/mro/t/basic_01_dfs.t    (/local/perl-c3)        (revision 12599)
 660 @@ -0,0 +1,54 @@
 661 +#!./perl
 662 +
 663 +use strict;
 664 +use warnings;
 665 +BEGIN {
 666 +    unless (-d 'blib') {
 667 +        chdir 't' if -d 't';
 668 +        @INC = '../lib';
 669 +    }
 670 +}
 671 +
 672 +use Test::More tests => 4;
 673 +use mro;
 674 +
 675 +=pod
 676 +
 677 +This tests the classic diamond inheritence pattern.
 678 +
 679 +   <A>
 680 +  /   \
 681 +<B>   <C>
 682 +  \   /
 683 +   <D>
 684 +
 685 +=cut
 686 +
 687 +{
 688 +    package Diamond_A;
 689 +    sub hello { 'Diamond_A::hello' }
 690 +}
 691 +{
 692 +    package Diamond_B;
 693 +    use base 'Diamond_A';
 694 +}
 695 +{
 696 +    package Diamond_C;
 697 +    use base 'Diamond_A';
 698 +
 699 +    sub hello { 'Diamond_C::hello' }
 700 +}
 701 +{
 702 +    package Diamond_D;
 703 +    use base ('Diamond_B', 'Diamond_C');
 704 +    use mro 'dfs';
 705 +}
 706 +
 707 +is_deeply(
 708 +    mro::get_mro_linear('Diamond_D'),
 709 +    [ qw(Diamond_D Diamond_B Diamond_A Diamond_C Diamond_A) ],
 710 +    '... got the right MRO for Diamond_D');
 711 +
 712 +is(Diamond_D->hello, 'Diamond_A::hello', '... method resolved itself as expected');
 713 +is(Diamond_D->can('hello')->(), 'Diamond_A::hello', '... can(method) resolved itself as expected');
 714 +is(UNIVERSAL::can("Diamond_D", 'hello')->(), 'Diamond_A::hello', '... can(method) resolved itself as expected');
 715 === ext/mro/t/vulcan_c3.t
 716 ==================================================================
 717 --- ext/mro/t/vulcan_c3.t       (/local/perl-current)   (revision 12599)
 718 +++ ext/mro/t/vulcan_c3.t       (/local/perl-c3)        (revision 12599)
 719 @@ -0,0 +1,73 @@
 720 +#!./perl
 721 +
 722 +use strict;
 723 +use warnings;
 724 +BEGIN {
 725 +    unless (-d 'blib') {
 726 +        chdir 't' if -d 't';
 727 +        @INC = '../lib';
 728 +    }
 729 +}
 730 +
 731 +use Test::More tests => 1;
 732 +use mro;
 733 +
 734 +=pod
 735 +
 736 +example taken from: L<http://gauss.gwydiondylan.org/books/drm/drm_50.html>
 737 +
 738 +         Object
 739 +           ^
 740 +           |
 741 +        LifeForm
 742 +         ^    ^
 743 +        /      \
 744 +   Sentient    BiPedal
 745 +      ^          ^
 746 +      |          |
 747 + Intelligent  Humanoid
 748 +       ^        ^
 749 +        \      /
 750 +         Vulcan
 751 +
 752 + define class <sentient> (<life-form>) end class;
 753 + define class <bipedal> (<life-form>) end class;
 754 + define class <intelligent> (<sentient>) end class;
 755 + define class <humanoid> (<bipedal>) end class;
 756 + define class <vulcan> (<intelligent>, <humanoid>) end class;
 757 +
 758 +=cut
 759 +
 760 +{
 761 +    package Object;
 762 +    use mro 'c3';
 763 +
 764 +    package LifeForm;
 765 +    use mro 'c3';
 766 +    use base 'Object';
 767 +
 768 +    package Sentient;
 769 +    use mro 'c3';
 770 +    use base 'LifeForm';
 771 +
 772 +    package BiPedal;
 773 +    use mro 'c3';
 774 +    use base 'LifeForm';
 775 +
 776 +    package Intelligent;
 777 +    use mro 'c3';
 778 +    use base 'Sentient';
 779 +
 780 +    package Humanoid;
 781 +    use mro 'c3';
 782 +    use base 'BiPedal';
 783 +
 784 +    package Vulcan;
 785 +    use mro 'c3';
 786 +    use base ('Intelligent', 'Humanoid');
 787 +}
 788 +
 789 +is_deeply(
 790 +    mro::get_mro_linear('Vulcan'),
 791 +    [ qw(Vulcan Intelligent Sentient Humanoid BiPedal LifeForm Object) ],
 792 +    '... got the right MRO for the Vulcan Dylan Example');
 793 === ext/mro/t/basic_02_dfs.t
 794 ==================================================================
 795 --- ext/mro/t/basic_02_dfs.t    (/local/perl-current)   (revision 12599)
 796 +++ ext/mro/t/basic_02_dfs.t    (/local/perl-c3)        (revision 12599)
 797 @@ -0,0 +1,122 @@
 798 +#!./perl
 799 +
 800 +use strict;
 801 +use warnings;
 802 +BEGIN {
 803 +    unless (-d 'blib') {
 804 +        chdir 't' if -d 't';
 805 +        @INC = '../lib';
 806 +    }
 807 +}
 808 +
 809 +use Test::More tests => 10;
 810 +use mro;
 811 +
 812 +=pod
 813 +
 814 +This example is take from: http://www.python.org/2.3/mro.html
 815 +
 816 +"My first example"
 817 +class O: pass
 818 +class F(O): pass
 819 +class E(O): pass
 820 +class D(O): pass
 821 +class C(D,F): pass
 822 +class B(D,E): pass
 823 +class A(B,C): pass
 824 +
 825 +
 826 +                          6
 827 +                         ---
 828 +Level 3                 | O |                  (more general)
 829 +                      /  ---  \
 830 +                     /    |    \                      |
 831 +                    /     |     \                     |
 832 +                   /      |      \                    |
 833 +                  ---    ---    ---                   |
 834 +Level 2        3 | D | 4| E |  | F | 5                |
 835 +                  ---    ---    ---                   |
 836 +                   \  \ _ /       |                   |
 837 +                    \    / \ _    |                   |
 838 +                     \  /      \  |                   |
 839 +                      ---      ---                    |
 840 +Level 1            1 | B |    | C | 2                 |
 841 +                      ---      ---                    |
 842 +                        \      /                      |
 843 +                         \    /                      \ /
 844 +                           ---
 845 +Level 0                 0 | A |                (more specialized)
 846 +                           ---
 847 +
 848 +=cut
 849 +
 850 +{
 851 +    package Test::O;
 852 +    use mro 'dfs';
 853 +
 854 +    package Test::F;
 855 +    use mro 'dfs';
 856 +    use base 'Test::O';
 857 +
 858 +    package Test::E;
 859 +    use base 'Test::O';
 860 +    use mro 'dfs';
 861 +
 862 +    sub C_or_E { 'Test::E' }
 863 +
 864 +    package Test::D;
 865 +    use mro 'dfs';
 866 +    use base 'Test::O';
 867 +
 868 +    sub C_or_D { 'Test::D' }
 869 +
 870 +    package Test::C;
 871 +    use base ('Test::D', 'Test::F');
 872 +    use mro 'dfs';
 873 +
 874 +    sub C_or_D { 'Test::C' }
 875 +    sub C_or_E { 'Test::C' }
 876 +
 877 +    package Test::B;
 878 +    use mro 'dfs';
 879 +    use base ('Test::D', 'Test::E');
 880 +
 881 +    package Test::A;
 882 +    use base ('Test::B', 'Test::C');
 883 +    use mro 'dfs';
 884 +}
 885 +
 886 +is_deeply(
 887 +    mro::get_mro_linear('Test::F'),
 888 +    [ qw(Test::F Test::O) ],
 889 +    '... got the right MRO for Test::F');
 890 +
 891 +is_deeply(
 892 +    mro::get_mro_linear('Test::E'),
 893 +    [ qw(Test::E Test::O) ],
 894 +    '... got the right MRO for Test::E');
 895 +
 896 +is_deeply(
 897 +    mro::get_mro_linear('Test::D'),
 898 +    [ qw(Test::D Test::O) ],
 899 +    '... got the right MRO for Test::D');
 900 +
 901 +is_deeply(
 902 +    mro::get_mro_linear('Test::C'),
 903 +    [ qw(Test::C Test::D Test::O Test::F Test::O) ],
 904 +    '... got the right MRO for Test::C');
 905 +
 906 +is_deeply(
 907 +    mro::get_mro_linear('Test::B'),
 908 +    [ qw(Test::B Test::D Test::O Test::E Test::O) ],
 909 +    '... got the right MRO for Test::B');
 910 +
 911 +is_deeply(
 912 +    mro::get_mro_linear('Test::A'),
 913 +    [ qw(Test::A Test::B Test::D Test::O Test::E Test::O Test::C Test::D Test::O Test::F Test::O) ],
 914 +    '... got the right MRO for Test::A');
 915 +
 916 +is(Test::A->C_or_D, 'Test::D', '... got the expected method output');
 917 +is(Test::A->can('C_or_D')->(), 'Test::D', '... can got the expected method output');
 918 +is(Test::A->C_or_E, 'Test::E', '... got the expected method output');
 919 +is(Test::A->can('C_or_E')->(), 'Test::E', '... can got the expected method output');
 920 === ext/mro/t/basic_03_dfs.t
 921 ==================================================================
 922 --- ext/mro/t/basic_03_dfs.t    (/local/perl-current)   (revision 12599)
 923 +++ ext/mro/t/basic_03_dfs.t    (/local/perl-c3)        (revision 12599)
 924 @@ -0,0 +1,108 @@
 925 +#!./perl
 926 +
 927 +use strict;
 928 +use warnings;
 929 +BEGIN {
 930 +    unless (-d 'blib') {
 931 +        chdir 't' if -d 't';
 932 +        @INC = '../lib';
 933 +    }
 934 +}
 935 +
 936 +use Test::More tests => 4;
 937 +use mro;
 938 +
 939 +=pod
 940 +
 941 +This example is take from: http://www.python.org/2.3/mro.html
 942 +
 943 +"My second example"
 944 +class O: pass
 945 +class F(O): pass
 946 +class E(O): pass
 947 +class D(O): pass
 948 +class C(D,F): pass
 949 +class B(E,D): pass
 950 +class A(B,C): pass
 951 +
 952 +                           6
 953 +                          ---
 954 +Level 3                  | O |
 955 +                       /  ---  \
 956 +                      /    |    \
 957 +                     /     |     \
 958 +                    /      |      \
 959 +                  ---     ---    ---
 960 +Level 2        2 | E | 4 | D |  | F | 5
 961 +                  ---     ---    ---
 962 +                   \      / \     /
 963 +                    \    /   \   /
 964 +                     \  /     \ /
 965 +                      ---     ---
 966 +Level 1            1 | B |   | C | 3
 967 +                      ---     ---
 968 +                       \       /
 969 +                        \     /
 970 +                          ---
 971 +Level 0                0 | A |
 972 +                          ---
 973 +
 974 +>>> A.mro()
 975 +(<class '__main__.A'>, <class '__main__.B'>, <class '__main__.E'>,
 976 +<class '__main__.C'>, <class '__main__.D'>, <class '__main__.F'>,
 977 +<type 'object'>)
 978 +
 979 +=cut
 980 +
 981 +{
 982 +    package Test::O;
 983 +    use mro 'dfs';
 984 +
 985 +    sub O_or_D { 'Test::O' }
 986 +    sub O_or_F { 'Test::O' }
 987 +
 988 +    package Test::F;
 989 +    use base 'Test::O';
 990 +    use mro 'dfs';
 991 +
 992 +    sub O_or_F { 'Test::F' }
 993 +
 994 +    package Test::E;
 995 +    use base 'Test::O';
 996 +    use mro 'dfs';
 997 +
 998 +    package Test::D;
 999 +    use base 'Test::O';
1000 +    use mro 'dfs';
1001 +
1002 +    sub O_or_D { 'Test::D' }
1003 +    sub C_or_D { 'Test::D' }
1004 +
1005 +    package Test::C;
1006 +    use base ('Test::D', 'Test::F');
1007 +    use mro 'dfs';
1008 +
1009 +    sub C_or_D { 'Test::C' }
1010 +
1011 +    package Test::B;
1012 +    use base ('Test::E', 'Test::D');
1013 +    use mro 'dfs';
1014 +
1015 +    package Test::A;
1016 +    use base ('Test::B', 'Test::C');
1017 +    use mro 'dfs';
1018 +}
1019 +
1020 +is_deeply(
1021 +    mro::get_mro_linear('Test::A'),
1022 +    [ qw(Test::A Test::B Test::E Test::O Test::D Test::O Test::C Test::D Test::O Test::F Test::O) ],
1023 +    '... got the right MRO for Test::A');
1024 +
1025 +is(Test::A->O_or_D, 'Test::O', '... got the right method dispatch');
1026 +is(Test::A->O_or_F, 'Test::O', '... got the right method dispatch');
1027 +
1028 +# NOTE:
1029 +# this test is particularly interesting because the p5 dispatch
1030 +# would actually call Test::D before Test::C and Test::D is a
1031 +# subclass of Test::C
1032 +is(Test::A->C_or_D, 'Test::D', '... got the right method dispatch');
1033 === ext/mro/t/basic_04_dfs.t
1034 ==================================================================
1035 --- ext/mro/t/basic_04_dfs.t    (/local/perl-current)   (revision 12599)
1036 +++ ext/mro/t/basic_04_dfs.t    (/local/perl-c3)        (revision 12599)
1037 @@ -0,0 +1,41 @@
1038 +#!./perl
1039 +
1040 +use strict;
1041 +use warnings;
1042 +BEGIN {
1043 +    unless (-d 'blib') {
1044 +        chdir 't' if -d 't';
1045 +        @INC = '../lib';
1046 +    }
1047 +}
1048 +
1049 +use Test::More tests => 1;
1050 +use mro;
1051 +
1052 +=pod
1053 +
1054 +From the parrot test t/pmc/object-meths.t
1055 +
1056 + A   B A   E
1057 +  \ /   \ /
1058 +   C     D
1059 +    \   /
1060 +     \ /
1061 +      F
1062 +
1063 +=cut
1064 +
1065 +{
1066 +    package t::lib::A; use mro 'dfs';
1067 +    package t::lib::B; use mro 'dfs';
1068 +    package t::lib::E; use mro 'dfs';
1069 +    package t::lib::C; use mro 'dfs'; use base ('t::lib::A', 't::lib::B');
1070 +    package t::lib::D; use mro 'dfs'; use base ('t::lib::A', 't::lib::E');
1071 +    package t::lib::F; use mro 'dfs'; use base ('t::lib::C', 't::lib::D');
1072 +}
1073 +
1074 +is_deeply(
1075 +    mro::get_mro_linear('t::lib::F'),
1076 +    [ qw(t::lib::F t::lib::C t::lib::A t::lib::B t::lib::D t::lib::A t::lib::E) ],
1077 +    '... got the right MRO for t::lib::F');
1078 +
1079 === ext/mro/t/basic_05_dfs.t
1080 ==================================================================
1081 --- ext/mro/t/basic_05_dfs.t    (/local/perl-current)   (revision 12599)
1082 +++ ext/mro/t/basic_05_dfs.t    (/local/perl-c3)        (revision 12599)
1083 @@ -0,0 +1,62 @@
1084 +#!./perl
1085 +
1086 +use strict;
1087 +use warnings;
1088 +BEGIN {
1089 +    unless (-d 'blib') {
1090 +        chdir 't' if -d 't';
1091 +        @INC = '../lib';
1092 +    }
1093 +}
1094 +
1095 +use Test::More tests => 2;
1096 +use mro;
1097 +
1098 +=pod
1099 +
1100 +This tests a strange bug found by Matt S. Trout
1101 +while building DBIx::Class. Thanks Matt!!!!
1102 +
1103 +   <A>
1104 +  /   \
1105 +<C>   <B>
1106 +  \   /
1107 +   <D>
1108 +
1109 +=cut
1110 +
1111 +{
1112 +    package Diamond_A;
1113 +    use mro 'dfs';
1114 +
1115 +    sub foo { 'Diamond_A::foo' }
1116 +}
1117 +{
1118 +    package Diamond_B;
1119 +    use base 'Diamond_A';
1120 +    use mro 'dfs';
1121 +
1122 +    sub foo { 'Diamond_B::foo => ' . (shift)->SUPER::foo }
1123 +}
1124 +{
1125 +    package Diamond_C;
1126 +    use mro 'dfs';
1127 +    use base 'Diamond_A';
1128 +
1129 +}
1130 +{
1131 +    package Diamond_D;
1132 +    use base ('Diamond_C', 'Diamond_B');
1133 +    use mro 'dfs';
1134 +
1135 +    sub foo { 'Diamond_D::foo => ' . (shift)->SUPER::foo }
1136 +}
1137 +
1138 +is_deeply(
1139 +    mro::get_mro_linear('Diamond_D'),
1140 +    [ qw(Diamond_D Diamond_C Diamond_A Diamond_B Diamond_A) ],
1141 +    '... got the right MRO for Diamond_D');
1142 +
1143 +is(Diamond_D->foo,
1144 +   'Diamond_D::foo => Diamond_A::foo',
1145 +   '... got the right next::method dispatch path');
1146 === ext/mro/t/vulcan_dfs.t
1147 ==================================================================
1148 --- ext/mro/t/vulcan_dfs.t      (/local/perl-current)   (revision 12599)
1149 +++ ext/mro/t/vulcan_dfs.t      (/local/perl-c3)        (revision 12599)
1150 @@ -0,0 +1,73 @@
1151 +#!./perl
1152 +
1153 +use strict;
1154 +use warnings;
1155 +BEGIN {
1156 +    unless (-d 'blib') {
1157 +        chdir 't' if -d 't';
1158 +        @INC = '../lib';
1159 +    }
1160 +}
1161 +
1162 +use Test::More tests => 1;
1163 +use mro;
1164 +
1165 +=pod
1166 +
1167 +example taken from: L<http://gauss.gwydiondylan.org/books/drm/drm_50.html>
1168 +
1169 +         Object
1170 +           ^
1171 +           |
1172 +        LifeForm
1173 +         ^    ^
1174 +        /      \
1175 +   Sentient    BiPedal
1176 +      ^          ^
1177 +      |          |
1178 + Intelligent  Humanoid
1179 +       ^        ^
1180 +        \      /
1181 +         Vulcan
1182 +
1183 + define class <sentient> (<life-form>) end class;
1184 + define class <bipedal> (<life-form>) end class;
1185 + define class <intelligent> (<sentient>) end class;
1186 + define class <humanoid> (<bipedal>) end class;
1187 + define class <vulcan> (<intelligent>, <humanoid>) end class;
1188 +
1189 +=cut
1190 +
1191 +{
1192 +    package Object;
1193 +    use mro 'dfs';
1194 +
1195 +    package LifeForm;
1196 +    use mro 'dfs';
1197 +    use base 'Object';
1198 +
1199 +    package Sentient;
1200 +    use mro 'dfs';
1201 +    use base 'LifeForm';
1202 +
1203 +    package BiPedal;
1204 +    use mro 'dfs';
1205 +    use base 'LifeForm';
1206 +
1207 +    package Intelligent;
1208 +    use mro 'dfs';
1209 +    use base 'Sentient';
1210 +
1211 +    package Humanoid;
1212 +    use mro 'dfs';
1213 +    use base 'BiPedal';
1214 +
1215 +    package Vulcan;
1216 +    use mro 'dfs';
1217 +    use base ('Intelligent', 'Humanoid');
1218 +}
1219 +
1220 +is_deeply(
1221 +    mro::get_mro_linear('Vulcan'),
1222 +    [ qw(Vulcan Intelligent Sentient LifeForm Object Humanoid BiPedal LifeForm Object) ],
1223 +    '... got the right MRO for the Vulcan Dylan Example');
1224 === ext/mro/t/dbic_c3.t
1225 ==================================================================
1226 --- ext/mro/t/dbic_c3.t (/local/perl-current)   (revision 12599)
1227 +++ ext/mro/t/dbic_c3.t (/local/perl-c3)        (revision 12599)
1228 @@ -0,0 +1,126 @@
1229 +#!./perl
1230 +
1231 +use strict;
1232 +use warnings;
1233 +BEGIN {
1234 +    unless (-d 'blib') {
1235 +        chdir 't' if -d 't';
1236 +        @INC = '../lib';
1237 +    }
1238 +}
1239 +
1240 +use Test::More tests => 1;
1241 +use mro;
1242 +
1243 +=pod
1244 +
1245 +This example is taken from the inheritance graph of DBIx::Class::Core in DBIx::Class v0.07002:
1246 +(No ASCII art this time, this graph is insane)
1247 +
1248 +The xx:: prefixes are just to be sure these bogus declarations never stomp on real ones
1249 +
1250 +=cut
1251 +
1252 +{
1253 +    package xx::DBIx::Class::Core; use mro 'c3';
1254 +    our @ISA = qw/
1255 +      xx::DBIx::Class::Serialize::Storable
1256 +      xx::DBIx::Class::InflateColumn
1257 +      xx::DBIx::Class::Relationship
1258 +      xx::DBIx::Class::PK::Auto
1259 +      xx::DBIx::Class::PK
1260 +      xx::DBIx::Class::Row
1261 +      xx::DBIx::Class::ResultSourceProxy::Table
1262 +      xx::DBIx::Class::AccessorGroup
1263 +    /;
1264 +
1265 +    package xx::DBIx::Class::InflateColumn; use mro 'c3';
1266 +    our @ISA = qw/ xx::DBIx::Class::Row /;
1267 +
1268 +    package xx::DBIx::Class::Row; use mro 'c3';
1269 +    our @ISA = qw/ xx::DBIx::Class /;
1270 +
1271 +    package xx::DBIx::Class; use mro 'c3';
1272 +    our @ISA = qw/
1273 +      xx::DBIx::Class::Componentised
1274 +      xx::Class::Data::Accessor
1275 +    /;
1276 +
1277 +    package xx::DBIx::Class::Relationship; use mro 'c3';
1278 +    our @ISA = qw/
1279 +      xx::DBIx::Class::Relationship::Helpers
1280 +      xx::DBIx::Class::Relationship::Accessor
1281 +      xx::DBIx::Class::Relationship::CascadeActions
1282 +      xx::DBIx::Class::Relationship::ProxyMethods
1283 +      xx::DBIx::Class::Relationship::Base
1284 +      xx::DBIx::Class
1285 +    /;
1286 +
1287 +    package xx::DBIx::Class::Relationship::Helpers; use mro 'c3';
1288 +    our @ISA = qw/
1289 +      xx::DBIx::Class::Relationship::HasMany
1290 +      xx::DBIx::Class::Relationship::HasOne
1291 +      xx::DBIx::Class::Relationship::BelongsTo
1292 +      xx::DBIx::Class::Relationship::ManyToMany
1293 +    /;
1294 +
1295 +    package xx::DBIx::Class::Relationship::ProxyMethods; use mro 'c3';
1296 +    our @ISA = qw/ xx::DBIx::Class /;
1297 +
1298 +    package xx::DBIx::Class::Relationship::Base; use mro 'c3';
1299 +    our @ISA = qw/ xx::DBIx::Class /;
1300 +
1301 +    package xx::DBIx::Class::PK::Auto; use mro 'c3';
1302 +    our @ISA = qw/ xx::DBIx::Class /;
1303 +
1304 +    package xx::DBIx::Class::PK; use mro 'c3';
1305 +    our @ISA = qw/ xx::DBIx::Class::Row /;
1306 +
1307 +    package xx::DBIx::Class::ResultSourceProxy::Table; use mro 'c3';
1308 +    our @ISA = qw/
1309 +      xx::DBIx::Class::AccessorGroup
1310 +      xx::DBIx::Class::ResultSourceProxy
1311 +    /;
1312 +
1313 +    package xx::DBIx::Class::ResultSourceProxy; use mro 'c3';
1314 +    our @ISA = qw/ xx::DBIx::Class /;
1315 +
1316 +    package xx::Class::Data::Accessor; our @ISA = (); use mro 'c3';
1317 +    package xx::DBIx::Class::Relationship::HasMany; our @ISA = (); use mro 'c3';
1318 +    package xx::DBIx::Class::Relationship::HasOne; our @ISA = (); use mro 'c3';
1319 +    package xx::DBIx::Class::Relationship::BelongsTo; our @ISA = (); use mro 'c3';
1320 +    package xx::DBIx::Class::Relationship::ManyToMany; our @ISA = (); use mro 'c3';
1321 +    package xx::DBIx::Class::Componentised; our @ISA = (); use mro 'c3';
1322 +    package xx::DBIx::Class::AccessorGroup; our @ISA = (); use mro 'c3';
1323 +    package xx::DBIx::Class::Serialize::Storable; our @ISA = (); use mro 'c3';
1324 +    package xx::DBIx::Class::Relationship::Accessor; our @ISA = (); use mro 'c3';
1325 +    package xx::DBIx::Class::Relationship::CascadeActions; our @ISA = (); use mro 'c3';
1326 +}
1327 +
1328 +is_deeply(
1329 +    mro::get_mro_linear('xx::DBIx::Class::Core'),
1330 +    [qw/
1331 +        xx::DBIx::Class::Core
1332 +        xx::DBIx::Class::Serialize::Storable
1333 +        xx::DBIx::Class::InflateColumn
1334 +        xx::DBIx::Class::Relationship
1335 +        xx::DBIx::Class::Relationship::Helpers
1336 +        xx::DBIx::Class::Relationship::HasMany
1337 +        xx::DBIx::Class::Relationship::HasOne
1338 +        xx::DBIx::Class::Relationship::BelongsTo
1339 +        xx::DBIx::Class::Relationship::ManyToMany
1340 +        xx::DBIx::Class::Relationship::Accessor
1341 +        xx::DBIx::Class::Relationship::CascadeActions
1342 +        xx::DBIx::Class::Relationship::ProxyMethods
1343 +        xx::DBIx::Class::Relationship::Base
1344 +        xx::DBIx::Class::PK::Auto
1345 +        xx::DBIx::Class::PK
1346 +        xx::DBIx::Class::Row
1347 +        xx::DBIx::Class::ResultSourceProxy::Table
1348 +        xx::DBIx::Class::AccessorGroup
1349 +        xx::DBIx::Class::ResultSourceProxy
1350 +        xx::DBIx::Class
1351 +        xx::DBIx::Class::Componentised
1352 +        xx::Class::Data::Accessor
1353 +    /],
1354 +    '... got the right C3 merge order for xx::DBIx::Class::Core');
1355 === ext/mro/t/complex_c3.t
1356 ==================================================================
1357 --- ext/mro/t/complex_c3.t      (/local/perl-current)   (revision 12599)
1358 +++ ext/mro/t/complex_c3.t      (/local/perl-c3)        (revision 12599)
1359 @@ -0,0 +1,144 @@
1360 +#!./perl
1361 +
1362 +use strict;
1363 +use warnings;
1364 +BEGIN {
1365 +    unless (-d 'blib') {
1366 +        chdir 't' if -d 't';
1367 +        @INC = '../lib';
1368 +    }
1369 +}
1370 +
1371 +use Test::More tests => 11;
1372 +use mro;
1373 +
1374 +=pod
1375 +
1376 +This example is taken from: http://rt.cpan.org/Public/Bug/Display.html?id=20879
1377 +
1378 +               ---     ---     ---
1379 +Level 5     8 | A | 9 | B | A | C |    (More General)
1380 +               ---     ---     ---       V
1381 +                  \     |     /          |
1382 +                   \    |    /           |
1383 +                    \   |   /            |
1384 +                     \  |  /             |
1385 +                       ---               |
1386 +Level 4             7 | D |              |
1387 +                       ---               |
1388 +                      /   \              |
1389 +                     /     \             |
1390 +                  ---       ---          |
1391 +Level 3        4 | G |   6 | E |         |
1392 +                  ---       ---          |
1393 +                   |         |           |
1394 +                   |         |           |
1395 +                  ---       ---          |
1396 +Level 2        3 | H |   5 | F |         |
1397 +                  ---       ---          |
1398 +                      \   /  |           |
1399 +                       \ /   |           |
1400 +                        \    |           |
1401 +                       / \   |           |
1402 +                      /   \  |           |
1403 +                  ---       ---          |
1404 +Level 1        1 | J |   2 | I |         |
1405 +                  ---       ---          |
1406 +                    \       /            |
1407 +                     \     /             |
1408 +                       ---               v
1409 +Level 0             0 | K |            (More Specialized)
1410 +                       ---
1411 +
1412 +
1413 +0123456789A
1414 +KJIHGFEDABC
1415 +
1416 +=cut
1417 +
1418 +{
1419 +    package Test::A; use mro 'c3';
1420 +
1421 +    package Test::B; use mro 'c3';
1422 +
1423 +    package Test::C; use mro 'c3';
1424 +
1425 +    package Test::D; use mro 'c3';
1426 +    use base qw/Test::A Test::B Test::C/;
1427 +
1428 +    package Test::E; use mro 'c3';
1429 +    use base qw/Test::D/;
1430 +
1431 +    package Test::F; use mro 'c3';
1432 +    use base qw/Test::E/;
1433 +
1434 +    package Test::G; use mro 'c3';
1435 +    use base qw/Test::D/;
1436 +
1437 +    package Test::H; use mro 'c3';
1438 +    use base qw/Test::G/;
1439 +
1440 +    package Test::I; use mro 'c3';
1441 +    use base qw/Test::H Test::F/;
1442 +
1443 +    package Test::J; use mro 'c3';
1444 +    use base qw/Test::F/;
1445 +
1446 +    package Test::K; use mro 'c3';
1447 +    use base qw/Test::J Test::I/;
1448 +}
1449 +
1450 +is_deeply(
1451 +    mro::get_mro_linear('Test::A'),
1452 +    [ qw(Test::A) ],
1453 +    '... got the right C3 merge order for Test::A');
1454 +
1455 +is_deeply(
1456 +    mro::get_mro_linear('Test::B'),
1457 +    [ qw(Test::B) ],
1458 +    '... got the right C3 merge order for Test::B');
1459 +
1460 +is_deeply(
1461 +    mro::get_mro_linear('Test::C'),
1462 +    [ qw(Test::C) ],
1463 +    '... got the right C3 merge order for Test::C');
1464 +
1465 +is_deeply(
1466 +    mro::get_mro_linear('Test::D'),
1467 +    [ qw(Test::D Test::A Test::B Test::C) ],
1468 +    '... got the right C3 merge order for Test::D');
1469 +
1470 +is_deeply(
1471 +    mro::get_mro_linear('Test::E'),
1472 +    [ qw(Test::E Test::D Test::A Test::B Test::C) ],
1473 +    '... got the right C3 merge order for Test::E');
1474 +
1475 +is_deeply(
1476 +    mro::get_mro_linear('Test::F'),
1477 +    [ qw(Test::F Test::E Test::D Test::A Test::B Test::C) ],
1478 +    '... got the right C3 merge order for Test::F');
1479 +
1480 +is_deeply(
1481 +    mro::get_mro_linear('Test::G'),
1482 +    [ qw(Test::G Test::D Test::A Test::B Test::C) ],
1483 +    '... got the right C3 merge order for Test::G');
1484 +
1485 +is_deeply(
1486 +    mro::get_mro_linear('Test::H'),
1487 +    [ qw(Test::H Test::G Test::D Test::A Test::B Test::C) ],
1488 +    '... got the right C3 merge order for Test::H');
1489 +
1490 +is_deeply(
1491 +    mro::get_mro_linear('Test::I'),
1492 +    [ qw(Test::I Test::H Test::G Test::F Test::E Test::D Test::A Test::B Test::C) ],
1493 +    '... got the right C3 merge order for Test::I');
1494 +
1495 +is_deeply(
1496 +    mro::get_mro_linear('Test::J'),
1497 +    [ qw(Test::J Test::F Test::E Test::D Test::A Test::B Test::C) ],
1498 +    '... got the right C3 merge order for Test::J');
1499 +
1500 +is_deeply(
1501 +    mro::get_mro_linear('Test::K'),
1502 +    [ qw(Test::K Test::J Test::I Test::H Test::G Test::F Test::E Test::D Test::A Test::B Test::C) ],
1503 +    '... got the right C3 merge order for Test::K');
1504 === ext/mro/t/dbic_dfs.t
1505 ==================================================================
1506 --- ext/mro/t/dbic_dfs.t        (/local/perl-current)   (revision 12599)
1507 +++ ext/mro/t/dbic_dfs.t        (/local/perl-c3)        (revision 12599)
1508 @@ -0,0 +1,150 @@
1509 +#!./perl
1510 +
1511 +use strict;
1512 +use warnings;
1513 +BEGIN {
1514 +    unless (-d 'blib') {
1515 +        chdir 't' if -d 't';
1516 +        @INC = '../lib';
1517 +    }
1518 +}
1519 +
1520 +use Test::More tests => 1;
1521 +use mro;
1522 +
1523 +=pod
1524 +
1525 +This example is taken from the inheritance graph of DBIx::Class::Core in DBIx::Class v0.07002:
1526 +(No ASCII art this time, this graph is insane)
1527 +
1528 +The xx:: prefixes are just to be sure these bogus declarations never stomp on real ones
1529 +
1530 +=cut
1531 +
1532 +{
1533 +    package xx::DBIx::Class::Core; use mro 'dfs';
1534 +    our @ISA = qw/
1535 +      xx::DBIx::Class::Serialize::Storable
1536 +      xx::DBIx::Class::InflateColumn
1537 +      xx::DBIx::Class::Relationship
1538 +      xx::DBIx::Class::PK::Auto
1539 +      xx::DBIx::Class::PK
1540 +      xx::DBIx::Class::Row
1541 +      xx::DBIx::Class::ResultSourceProxy::Table
1542 +      xx::DBIx::Class::AccessorGroup
1543 +    /;
1544 +
1545 +    package xx::DBIx::Class::InflateColumn; use mro 'dfs';
1546 +    our @ISA = qw/ xx::DBIx::Class::Row /;
1547 +
1548 +    package xx::DBIx::Class::Row; use mro 'dfs';
1549 +    our @ISA = qw/ xx::DBIx::Class /;
1550 +
1551 +    package xx::DBIx::Class; use mro 'dfs';
1552 +    our @ISA = qw/
1553 +      xx::DBIx::Class::Componentised
1554 +      xx::Class::Data::Accessor
1555 +    /;
1556 +
1557 +    package xx::DBIx::Class::Relationship; use mro 'dfs';
1558 +    our @ISA = qw/
1559 +      xx::DBIx::Class::Relationship::Helpers
1560 +      xx::DBIx::Class::Relationship::Accessor
1561 +      xx::DBIx::Class::Relationship::CascadeActions
1562 +      xx::DBIx::Class::Relationship::ProxyMethods
1563 +      xx::DBIx::Class::Relationship::Base
1564 +      xx::DBIx::Class
1565 +    /;
1566 +
1567 +    package xx::DBIx::Class::Relationship::Helpers; use mro 'dfs';
1568 +    our @ISA = qw/
1569 +      xx::DBIx::Class::Relationship::HasMany
1570 +      xx::DBIx::Class::Relationship::HasOne
1571 +      xx::DBIx::Class::Relationship::BelongsTo
1572 +      xx::DBIx::Class::Relationship::ManyToMany
1573 +    /;
1574 +
1575 +    package xx::DBIx::Class::Relationship::ProxyMethods; use mro 'dfs';
1576 +    our @ISA = qw/ xx::DBIx::Class /;
1577 +
1578 +    package xx::DBIx::Class::Relationship::Base; use mro 'dfs';
1579 +    our @ISA = qw/ xx::DBIx::Class /;
1580 +
1581 +    package xx::DBIx::Class::PK::Auto; use mro 'dfs';
1582 +    our @ISA = qw/ xx::DBIx::Class /;
1583 +
1584 +    package xx::DBIx::Class::PK; use mro 'dfs';
1585 +    our @ISA = qw/ xx::DBIx::Class::Row /;
1586 +
1587 +    package xx::DBIx::Class::ResultSourceProxy::Table; use mro 'dfs';
1588 +    our @ISA = qw/
1589 +      xx::DBIx::Class::AccessorGroup
1590 +      xx::DBIx::Class::ResultSourceProxy
1591 +    /;
1592 +
1593 +    package xx::DBIx::Class::ResultSourceProxy; use mro 'dfs';
1594 +    our @ISA = qw/ xx::DBIx::Class /;
1595 +
1596 +    package xx::Class::Data::Accessor; our @ISA = (); use mro 'dfs';
1597 +    package xx::DBIx::Class::Relationship::HasMany; our @ISA = (); use mro 'dfs';
1598 +    package xx::DBIx::Class::Relationship::HasOne; our @ISA = (); use mro 'dfs';
1599 +    package xx::DBIx::Class::Relationship::BelongsTo; our @ISA = (); use mro 'dfs';
1600 +    package xx::DBIx::Class::Relationship::ManyToMany; our @ISA = (); use mro 'dfs';
1601 +    package xx::DBIx::Class::Componentised; our @ISA = (); use mro 'dfs';
1602 +    package xx::DBIx::Class::AccessorGroup; our @ISA = (); use mro 'dfs';
1603 +    package xx::DBIx::Class::Serialize::Storable; our @ISA = (); use mro 'dfs';
1604 +    package xx::DBIx::Class::Relationship::Accessor; our @ISA = (); use mro 'dfs';
1605 +    package xx::DBIx::Class::Relationship::CascadeActions; our @ISA = (); use mro 'dfs';
1606 +}
1607 +
1608 +is_deeply(
1609 +    mro::get_mro_linear('xx::DBIx::Class::Core'),
1610 +    [qw/
1611 +        xx::DBIx::Class::Core
1612 +        xx::DBIx::Class::Serialize::Storable
1613 +        xx::DBIx::Class::InflateColumn
1614 +        xx::DBIx::Class::Row
1615 +        xx::DBIx::Class
1616 +        xx::DBIx::Class::Componentised
1617 +        xx::Class::Data::Accessor
1618 +        xx::DBIx::Class::Relationship
1619 +        xx::DBIx::Class::Relationship::Helpers
1620 +        xx::DBIx::Class::Relationship::HasMany
1621 +        xx::DBIx::Class::Relationship::HasOne
1622 +        xx::DBIx::Class::Relationship::BelongsTo
1623 +        xx::DBIx::Class::Relationship::ManyToMany
1624 +        xx::DBIx::Class::Relationship::Accessor
1625 +        xx::DBIx::Class::Relationship::CascadeActions
1626 +        xx::DBIx::Class::Relationship::ProxyMethods
1627 +        xx::DBIx::Class
1628 +        xx::DBIx::Class::Componentised
1629 +        xx::Class::Data::Accessor
1630 +        xx::DBIx::Class::Relationship::Base
1631 +        xx::DBIx::Class
1632 +        xx::DBIx::Class::Componentised
1633 +        xx::Class::Data::Accessor
1634 +        xx::DBIx::Class
1635 +        xx::DBIx::Class::Componentised
1636 +        xx::Class::Data::Accessor
1637 +        xx::DBIx::Class::PK::Auto
1638 +        xx::DBIx::Class
1639 +        xx::DBIx::Class::Componentised
1640 +        xx::Class::Data::Accessor
1641 +        xx::DBIx::Class::PK
1642 +        xx::DBIx::Class::Row
1643 +        xx::DBIx::Class
1644 +        xx::DBIx::Class::Componentised
1645 +        xx::Class::Data::Accessor
1646 +        xx::DBIx::Class::Row
1647 +        xx::DBIx::Class
1648 +        xx::DBIx::Class::Componentised
1649 +        xx::Class::Data::Accessor
1650 +        xx::DBIx::Class::ResultSourceProxy::Table
1651 +        xx::DBIx::Class::AccessorGroup
1652 +        xx::DBIx::Class::ResultSourceProxy
1653 +        xx::DBIx::Class
1654 +        xx::DBIx::Class::Componentised
1655 +        xx::Class::Data::Accessor
1656 +        xx::DBIx::Class::AccessorGroup
1657 +    /],
1658 +    '... got the right DFS merge order for xx::DBIx::Class::Core');
1659 === ext/mro/t/recursion_c3.t
1660 ==================================================================
1661 --- ext/mro/t/recursion_c3.t    (/local/perl-current)   (revision 12599)
1662 +++ ext/mro/t/recursion_c3.t    (/local/perl-c3)        (revision 12599)
1663 @@ -0,0 +1,90 @@
1664 +#!./perl
1665 +
1666 +use strict;
1667 +use warnings;
1668 +BEGIN {
1669 +    unless (-d 'blib') {
1670 +        chdir 't' if -d 't';
1671 +        @INC = '../lib';
1672 +    }
1673 +}
1674 +
1675 +use Test::More;
1676 +use mro;
1677 +
1678 +# XXX needs translation back to classes, etc
1679 +
1680 +plan skip_all => "Your system has no SIGALRM" if !exists $SIG{ALRM};
1681 +plan tests => 8;
1682 +
1683 +=pod
1684 +
1685 +These are like the 010_complex_merge_classless test,
1686 +but an infinite loop has been made in the heirarchy,
1687 +to test that we can fail cleanly instead of going
1688 +into an infinite loop
1689 +
1690 +=cut
1691 +
1692 +# initial setup, everything sane
1693 +{
1694 +    package K;
1695 +    our @ISA = qw/J I/;
1696 +    package J;
1697 +    our @ISA = qw/F/;
1698 +    package I;
1699 +    our @ISA = qw/H F/;
1700 +    package H;
1701 +    our @ISA = qw/G/;
1702 +    package G;
1703 +    our @ISA = qw/D/;
1704 +    package F;
1705 +    our @ISA = qw/E/;
1706 +    package E;
1707 +    our @ISA = qw/D/;
1708 +    package D;
1709 +    our @ISA = qw/A B C/;
1710 +    package C;
1711 +    our @ISA = qw//;
1712 +    package B;
1713 +    our @ISA = qw//;
1714 +    package A;
1715 +    our @ISA = qw//;
1716 +}
1717 +
1718 +# A series of 8 abberations that would cause infinite loops,
1719 +#  each one undoing the work of the previous
1720 +my @loopies = (
1721 +    sub { @E::ISA = qw/F/ },
1722 +    sub { @E::ISA = qw/D/; @C::ISA = qw/F/ },
1723 +    sub { @C::ISA = qw//; @A::ISA = qw/K/ },
1724 +    sub { @A::ISA = qw//; @J::ISA = qw/F K/ },
1725 +    sub { @J::ISA = qw/F/; @H::ISA = qw/K G/ },
1726 +    sub { @H::ISA = qw/G/; @B::ISA = qw/B/ },
1727 +    sub { @B::ISA = qw//; @K::ISA = qw/K J I/ },
1728 +    sub { @K::ISA = qw/J I/; @D::ISA = qw/A H B C/ },
1729 +);
1730 +
1731 +foreach my $loopy (@loopies) {
1732 +    eval {
1733 +        local $SIG{ALRM} = sub { die "ALRMTimeout" };
1734 +        alarm(3);
1735 +        $loopy->();
1736 +        mro::get_mro_linear_c3('K');
1737 +    };
1738 +
1739 +    if(my $err = $@) {
1740 +        if($err =~ /ALRMTimeout/) {
1741 +            ok(0, "Loop terminated by SIGALRM");
1742 +        }
1743 +        elsif($err =~ /Recursive inheritance detected/) {
1744 +            ok(1, "Graceful exception thrown");
1745 +        }
1746 +        else {
1747 +            ok(0, "Unrecognized exception: $err");
1748 +        }
1749 +    }
1750 +    else {
1751 +        ok(0, "Infinite loop apparently succeeded???");
1752 +    }
1753 +}
1754 === ext/mro/t/overload_c3.t
1755 ==================================================================
1756 --- ext/mro/t/overload_c3.t     (/local/perl-current)   (revision 12599)
1757 +++ ext/mro/t/overload_c3.t     (/local/perl-c3)        (revision 12599)
1758 @@ -0,0 +1,55 @@
1759 +#!./perl
1760 +
1761 +use strict;
1762 +use warnings;
1763 +BEGIN {
1764 +    unless (-d 'blib') {
1765 +        chdir 't' if -d 't';
1766 +        @INC = '../lib';
1767 +    }
1768 +}
1769 +
1770 +use Test::More tests => 7;
1771 +use mro;
1772 +
1773 +{
1774 +    package BaseTest;
1775 +    use strict;
1776 +    use warnings;
1777 +    use mro 'c3';
1778 +
1779 +    package OverloadingTest;
1780 +    use strict;
1781 +    use warnings;
1782 +    use mro 'c3';
1783 +    use base 'BaseTest';
1784 +    use overload '""' => sub { ref(shift) . " stringified" },
1785 +                 fallback => 1;
1786 +
1787 +    sub new { bless {} => shift }
1788 +
1789 +    package InheritingFromOverloadedTest;
1790 +    use strict;
1791 +    use warnings;
1792 +    use base 'OverloadingTest';
1793 +    use mro 'c3';
1794 +}
1795 +
1796 +my $x = InheritingFromOverloadedTest->new();
1797 +isa_ok($x, 'InheritingFromOverloadedTest');
1798 +
1799 +my $y = OverloadingTest->new();
1800 +isa_ok($y, 'OverloadingTest');
1801 +
1802 +is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing');
1803 +is("$y", 'OverloadingTest stringified', '... got the right value when stringifing');
1804 +
1805 +ok(($y eq 'OverloadingTest stringified'), '... eq was handled correctly');
1806 +
1807 +my $result;
1808 +eval {
1809 +    $result = $x eq 'InheritingFromOverloadedTest stringified'
1810 +};
1811 +ok(!$@, '... this should not throw an exception');
1812 +ok($result, '... and we should get the true value');
1813 +
1814 === ext/mro/t/complex_dfs.t
1815 ==================================================================
1816 --- ext/mro/t/complex_dfs.t     (/local/perl-current)   (revision 12599)
1817 +++ ext/mro/t/complex_dfs.t     (/local/perl-c3)        (revision 12599)
1818 @@ -0,0 +1,144 @@
1819 +#!./perl
1820 +
1821 +use strict;
1822 +use warnings;
1823 +BEGIN {
1824 +    unless (-d 'blib') {
1825 +        chdir 't' if -d 't';
1826 +        @INC = '../lib';
1827 +    }
1828 +}
1829 +
1830 +use Test::More tests => 11;
1831 +use mro;
1832 +
1833 +=pod
1834 +
1835 +This example is taken from: http://rt.cpan.org/Public/Bug/Display.html?id=20879
1836 +
1837 +               ---     ---     ---
1838 +Level 5     8 | A | 9 | B | A | C |    (More General)
1839 +               ---     ---     ---       V
1840 +                  \     |     /          |
1841 +                   \    |    /           |
1842 +                    \   |   /            |
1843 +                     \  |  /             |
1844 +                       ---               |
1845 +Level 4             7 | D |              |
1846 +                       ---               |
1847 +                      /   \              |
1848 +                     /     \             |
1849 +                  ---       ---          |
1850 +Level 3        4 | G |   6 | E |         |
1851 +                  ---       ---          |
1852 +                   |         |           |
1853 +                   |         |           |
1854 +                  ---       ---          |
1855 +Level 2        3 | H |   5 | F |         |
1856 +                  ---       ---          |
1857 +                      \   /  |           |
1858 +                       \ /   |           |
1859 +                        \    |           |
1860 +                       / \   |           |
1861 +                      /   \  |           |
1862 +                  ---       ---          |
1863 +Level 1        1 | J |   2 | I |         |
1864 +                  ---       ---          |
1865 +                    \       /            |
1866 +                     \     /             |
1867 +                       ---               v
1868 +Level 0             0 | K |            (More Specialized)
1869 +                       ---
1870 +
1871 +
1872 +0123456789A
1873 +KJIHGFEDABC
1874 +
1875 +=cut
1876 +
1877 +{
1878 +    package Test::A; use mro 'dfs';
1879 +
1880 +    package Test::B; use mro 'dfs';
1881 +
1882 +    package Test::C; use mro 'dfs';
1883 +
1884 +    package Test::D; use mro 'dfs';
1885 +    use base qw/Test::A Test::B Test::C/;
1886 +
1887 +    package Test::E; use mro 'dfs';
1888 +    use base qw/Test::D/;
1889 +
1890 +    package Test::F; use mro 'dfs';
1891 +    use base qw/Test::E/;
1892 +
1893 +    package Test::G; use mro 'dfs';
1894 +    use base qw/Test::D/;
1895 +
1896 +    package Test::H; use mro 'dfs';
1897 +    use base qw/Test::G/;
1898 +
1899 +    package Test::I; use mro 'dfs';
1900 +    use base qw/Test::H Test::F/;
1901 +
1902 +    package Test::J; use mro 'dfs';
1903 +    use base qw/Test::F/;
1904 +
1905 +    package Test::K; use mro 'dfs';
1906 +    use base qw/Test::J Test::I/;
1907 +}
1908 +
1909 +is_deeply(
1910 +    mro::get_mro_linear('Test::A'),
1911 +    [ qw(Test::A) ],
1912 +    '... got the right DFS merge order for Test::A');
1913 +
1914 +is_deeply(
1915 +    mro::get_mro_linear('Test::B'),
1916 +    [ qw(Test::B) ],
1917 +    '... got the right DFS merge order for Test::B');
1918 +
1919 +is_deeply(
1920 +    mro::get_mro_linear('Test::C'),
1921 +    [ qw(Test::C) ],
1922 +    '... got the right DFS merge order for Test::C');
1923 +
1924 +is_deeply(
1925 +    mro::get_mro_linear('Test::D'),
1926 +    [ qw(Test::D Test::A Test::B Test::C) ],
1927 +    '... got the right DFS merge order for Test::D');
1928 +
1929 +is_deeply(
1930 +    mro::get_mro_linear('Test::E'),
1931 +    [ qw(Test::E Test::D Test::A Test::B Test::C) ],
1932 +    '... got the right DFS merge order for Test::E');
1933 +
1934 +is_deeply(
1935 +    mro::get_mro_linear('Test::F'),
1936 +    [ qw(Test::F Test::E Test::D Test::A Test::B Test::C) ],
1937 +    '... got the right DFS merge order for Test::F');
1938 +
1939 +is_deeply(
1940 +    mro::get_mro_linear('Test::G'),
1941 +    [ qw(Test::G Test::D Test::A Test::B Test::C) ],
1942 +    '... got the right DFS merge order for Test::G');
1943 +
1944 +is_deeply(
1945 +    mro::get_mro_linear('Test::H'),
1946 +    [ qw(Test::H Test::G Test::D Test::A Test::B Test::C) ],
1947 +    '... got the right DFS merge order for Test::H');
1948 +
1949 +is_deeply(
1950 +    mro::get_mro_linear('Test::I'),
1951 +    [ qw(Test::I Test::H Test::G Test::D Test::A Test::B Test::C Test::F Test::E Test::D Test::A Test::B Test::C) ],
1952 +    '... got the right DFS merge order for Test::I');
1953 +
1954 +is_deeply(
1955 +    mro::get_mro_linear('Test::J'),
1956 +    [ qw(Test::J Test::F Test::E Test::D Test::A Test::B Test::C) ],
1957 +    '... got the right DFS merge order for Test::J');
1958 +
1959 +is_deeply(
1960 +    mro::get_mro_linear('Test::K'),
1961 +    [ qw(Test::K Test::J Test::F Test::E Test::D Test::A Test::B Test::C Test::I Test::H Test::G Test::D Test::A Test::B Test::C Test::F Test::E Test::D Test::A Test::B Test::C) ],
1962 +    '... got the right DFS merge order for Test::K');
1963 === ext/mro/t/inconsistent_c3.t
1964 ==================================================================
1965 --- ext/mro/t/inconsistent_c3.t (/local/perl-current)   (revision 12599)
1966 +++ ext/mro/t/inconsistent_c3.t (/local/perl-c3)        (revision 12599)
1967 @@ -0,0 +1,48 @@
1968 +#!./perl
1969 +
1970 +use strict;
1971 +use warnings;
1972 +BEGIN {
1973 +    unless (-d 'blib') {
1974 +        chdir 't' if -d 't';
1975 +        @INC = '../lib';
1976 +    }
1977 +}
1978 +
1979 +use Test::More tests => 1;
1980 +use mro;
1981 +
1982 +=pod
1983 +
1984 +This example is take from: http://www.python.org/2.3/mro.html
1985 +
1986 +"Serious order disagreement" # From Guido
1987 +class O: pass
1988 +class X(O): pass
1989 +class Y(O): pass
1990 +class A(X,Y): pass
1991 +class B(Y,X): pass
1992 +try:
1993 +    class Z(A,B): pass #creates Z(A,B) in Python 2.2
1994 +except TypeError:
1995 +    pass # Z(A,B) cannot be created in Python 2.3
1996 +
1997 +=cut
1998 +
1999 +{
2000 +    package X;
2001 +
2002 +    package Y;
2003 +
2004 +    package XY;
2005 +    our @ISA = ('X', 'Y');
2006 +
2007 +    package YX;
2008 +    our @ISA = ('Y', 'X');
2009 +
2010 +    package Z;
2011 +    our @ISA = ('XY', 'YX');
2012 +}
2013 +
2014 +eval { mro::get_mro_linear_c3('Z') };
2015 +like($@, qr/^Inconsistent /, '... got the right error with an inconsistent hierarchy');
2016 === ext/mro/t/recursion_dfs.t
2017 ==================================================================
2018 --- ext/mro/t/recursion_dfs.t   (/local/perl-current)   (revision 12599)
2019 +++ ext/mro/t/recursion_dfs.t   (/local/perl-c3)        (revision 12599)
2020 @@ -0,0 +1,90 @@
2021 +#!./perl
2022 +
2023 +use strict;
2024 +use warnings;
2025 +BEGIN {
2026 +    unless (-d 'blib') {
2027 +        chdir 't' if -d 't';
2028 +        @INC = '../lib';
2029 +    }
2030 +}
2031 +
2032 +use Test::More;
2033 +use mro;
2034 +
2035 +# XXX needs translation back to classes, etc
2036 +
2037 +plan skip_all => "Your system has no SIGALRM" if !exists $SIG{ALRM};
2038 +plan tests => 8;
2039 +
2040 +=pod
2041 +
2042 +These are like the 010_complex_merge_classless test,
2043 +but an infinite loop has been made in the heirarchy,
2044 +to test that we can fail cleanly instead of going
2045 +into an infinite loop
2046 +
2047 +=cut
2048 +
2049 +# initial setup, everything sane
2050 +{
2051 +    package K;
2052 +    our @ISA = qw/J I/;
2053 +    package J;
2054 +    our @ISA = qw/F/;
2055 +    package I;
2056 +    our @ISA = qw/H F/;
2057 +    package H;
2058 +    our @ISA = qw/G/;
2059 +    package G;
2060 +    our @ISA = qw/D/;
2061 +    package F;
2062 +    our @ISA = qw/E/;
2063 +    package E;
2064 +    our @ISA = qw/D/;
2065 +    package D;
2066 +    our @ISA = qw/A B C/;
2067 +    package C;
2068 +    our @ISA = qw//;
2069 +    package B;
2070 +    our @ISA = qw//;
2071 +    package A;
2072 +    our @ISA = qw//;
2073 +}
2074 +
2075 +# A series of 8 abberations that would cause infinite loops,
2076 +#  each one undoing the work of the previous
2077 +my @loopies = (
2078 +    sub { @E::ISA = qw/F/ },
2079 +    sub { @E::ISA = qw/D/; @C::ISA = qw/F/ },
2080 +    sub { @C::ISA = qw//; @A::ISA = qw/K/ },
2081 +    sub { @A::ISA = qw//; @J::ISA = qw/F K/ },
2082 +    sub { @J::ISA = qw/F/; @H::ISA = qw/K G/ },
2083 +    sub { @H::ISA = qw/G/; @B::ISA = qw/B/ },
2084 +    sub { @B::ISA = qw//; @K::ISA = qw/K J I/ },
2085 +    sub { @K::ISA = qw/J I/; @D::ISA = qw/A H B C/ },
2086 +);
2087 +
2088 +foreach my $loopy (@loopies) {
2089 +    eval {
2090 +        local $SIG{ALRM} = sub { die "ALRMTimeout" };
2091 +        alarm(3);
2092 +        $loopy->();
2093 +        mro::get_mro_linear_dfs('K');
2094 +    };
2095 +
2096 +    if(my $err = $@) {
2097 +        if($err =~ /ALRMTimeout/) {
2098 +            ok(0, "Loop terminated by SIGALRM");
2099 +        }
2100 +        elsif($err =~ /Recursive inheritance detected/) {
2101 +            ok(1, "Graceful exception thrown");
2102 +        }
2103 +        else {
2104 +            ok(0, "Unrecognized exception: $err");
2105 +        }
2106 +    }
2107 +    else {
2108 +        ok(0, "Infinite loop apparently succeeded???");
2109 +    }
2110 +}
2111 === ext/mro/t/basic_01_c3.t
2112 ==================================================================
2113 --- ext/mro/t/basic_01_c3.t     (/local/perl-current)   (revision 12599)
2114 +++ ext/mro/t/basic_01_c3.t     (/local/perl-c3)        (revision 12599)
2115 @@ -0,0 +1,54 @@
2116 +#!./perl
2117 +
2118 +use strict;
2119 +use warnings;
2120 +BEGIN {
2121 +    unless (-d 'blib') {
2122 +        chdir 't' if -d 't';
2123 +        @INC = '../lib';
2124 +    }
2125 +}
2126 +
2127 +use Test::More tests => 4;
2128 +use mro;
2129 +
2130 +=pod
2131 +
2132 +This tests the classic diamond inheritence pattern.
2133 +
2134 +   <A>
2135 +  /   \
2136 +<B>   <C>
2137 +  \   /
2138 +   <D>
2139 +
2140 +=cut
2141 +
2142 +{
2143 +    package Diamond_A;
2144 +    sub hello { 'Diamond_A::hello' }
2145 +}
2146 +{
2147 +    package Diamond_B;
2148 +    use base 'Diamond_A';
2149 +}
2150 +{
2151 +    package Diamond_C;
2152 +    use base 'Diamond_A';
2153 +
2154 +    sub hello { 'Diamond_C::hello' }
2155 +}
2156 +{
2157 +    package Diamond_D;
2158 +    use base ('Diamond_B', 'Diamond_C');
2159 +    use mro 'c3';
2160 +}
2161 +
2162 +is_deeply(
2163 +    mro::get_mro_linear('Diamond_D'),
2164 +    [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ],
2165 +    '... got the right MRO for Diamond_D');
2166 +
2167 +is(Diamond_D->hello, 'Diamond_C::hello', '... method resolved itself as expected');
2168 +is(Diamond_D->can('hello')->(), 'Diamond_C::hello', '... can(method) resolved itself as expected');
2169 +is(UNIVERSAL::can("Diamond_D", 'hello')->(), 'Diamond_C::hello', '... can(method) resolved itself as expected');
2170 === ext/mro/t/basic_02_c3.t
2171 ==================================================================
2172 --- ext/mro/t/basic_02_c3.t     (/local/perl-current)   (revision 12599)
2173 +++ ext/mro/t/basic_02_c3.t     (/local/perl-c3)        (revision 12599)
2174 @@ -0,0 +1,122 @@
2175 +#!./perl
2176 +
2177 +use strict;
2178 +use warnings;
2179 +BEGIN {
2180 +    unless (-d 'blib') {
2181 +        chdir 't' if -d 't';
2182 +        @INC = '../lib';
2183 +    }
2184 +}
2185 +
2186 +use Test::More tests => 10;
2187 +use mro;
2188 +
2189 +=pod
2190 +
2191 +This example is take from: http://www.python.org/2.3/mro.html
2192 +
2193 +"My first example"
2194 +class O: pass
2195 +class F(O): pass
2196 +class E(O): pass
2197 +class D(O): pass
2198 +class C(D,F): pass
2199 +class B(D,E): pass
2200 +class A(B,C): pass
2201 +
2202 +
2203 +                          6
2204 +                         ---
2205 +Level 3                 | O |                  (more general)
2206 +                      /  ---  \
2207 +                     /    |    \                      |
2208 +                    /     |     \                     |
2209 +                   /      |      \                    |
2210 +                  ---    ---    ---                   |
2211 +Level 2        3 | D | 4| E |  | F | 5                |
2212 +                  ---    ---    ---                   |
2213 +                   \  \ _ /       |                   |
2214 +                    \    / \ _    |                   |
2215 +                     \  /      \  |                   |
2216 +                      ---      ---                    |
2217 +Level 1            1 | B |    | C | 2                 |
2218 +                      ---      ---                    |
2219 +                        \      /                      |
2220 +                         \    /                      \ /
2221 +                           ---
2222 +Level 0                 0 | A |                (more specialized)
2223 +                           ---
2224 +
2225 +=cut
2226 +
2227 +{
2228 +    package Test::O;
2229 +    use mro 'c3';
2230 +
2231 +    package Test::F;
2232 +    use mro 'c3';
2233 +    use base 'Test::O';
2234 +
2235 +    package Test::E;
2236 +    use base 'Test::O';
2237 +    use mro 'c3';
2238 +
2239 +    sub C_or_E { 'Test::E' }
2240 +
2241 +    package Test::D;
2242 +    use mro 'c3';
2243 +    use base 'Test::O';
2244 +
2245 +    sub C_or_D { 'Test::D' }
2246 +
2247 +    package Test::C;
2248 +    use base ('Test::D', 'Test::F');
2249 +    use mro 'c3';
2250 +
2251 +    sub C_or_D { 'Test::C' }
2252 +    sub C_or_E { 'Test::C' }
2253 +
2254 +    package Test::B;
2255 +    use mro 'c3';
2256 +    use base ('Test::D', 'Test::E');
2257 +
2258 +    package Test::A;
2259 +    use base ('Test::B', 'Test::C');
2260 +    use mro 'c3';
2261 +}
2262 +
2263 +is_deeply(
2264 +    mro::get_mro_linear('Test::F'),
2265 +    [ qw(Test::F Test::O) ],
2266 +    '... got the right MRO for Test::F');
2267 +
2268 +is_deeply(
2269 +    mro::get_mro_linear('Test::E'),
2270 +    [ qw(Test::E Test::O) ],
2271 +    '... got the right MRO for Test::E');
2272 +
2273 +is_deeply(
2274 +    mro::get_mro_linear('Test::D'),
2275 +    [ qw(Test::D Test::O) ],
2276 +    '... got the right MRO for Test::D');
2277 +
2278 +is_deeply(
2279 +    mro::get_mro_linear('Test::C'),
2280 +    [ qw(Test::C Test::D Test::F Test::O) ],
2281 +    '... got the right MRO for Test::C');
2282 +
2283 +is_deeply(
2284 +    mro::get_mro_linear('Test::B'),
2285 +    [ qw(Test::B Test::D Test::E Test::O) ],
2286 +    '... got the right MRO for Test::B');
2287 +
2288 +is_deeply(
2289 +    mro::get_mro_linear('Test::A'),
2290 +    [ qw(Test::A Test::B Test::C Test::D Test::E Test::F Test::O) ],
2291 +    '... got the right MRO for Test::A');
2292 +
2293 +is(Test::A->C_or_D, 'Test::C', '... got the expected method output');
2294 +is(Test::A->can('C_or_D')->(), 'Test::C', '... can got the expected method output');
2295 +is(Test::A->C_or_E, 'Test::C', '... got the expected method output');
2296 +is(Test::A->can('C_or_E')->(), 'Test::C', '... can got the expected method output');
2297 === ext/mro/t/overload_dfs.t
2298 ==================================================================
2299 --- ext/mro/t/overload_dfs.t    (/local/perl-current)   (revision 12599)
2300 +++ ext/mro/t/overload_dfs.t    (/local/perl-c3)        (revision 12599)
2301 @@ -0,0 +1,55 @@
2302 +#!./perl
2303 +
2304 +use strict;
2305 +use warnings;
2306 +BEGIN {
2307 +    unless (-d 'blib') {
2308 +        chdir 't' if -d 't';
2309 +        @INC = '../lib';
2310 +    }
2311 +}
2312 +
2313 +use Test::More tests => 7;
2314 +use mro;
2315 +
2316 +{
2317 +    package BaseTest;
2318 +    use strict;
2319 +    use warnings;
2320 +    use mro 'dfs';
2321 +
2322 +    package OverloadingTest;
2323 +    use strict;
2324 +    use warnings;
2325 +    use mro 'dfs';
2326 +    use base 'BaseTest';
2327 +    use overload '""' => sub { ref(shift) . " stringified" },
2328 +                 fallback => 1;
2329 +
2330 +    sub new { bless {} => shift }
2331 +
2332 +    package InheritingFromOverloadedTest;
2333 +    use strict;
2334 +    use warnings;
2335 +    use base 'OverloadingTest';
2336 +    use mro 'dfs';
2337 +}
2338 +
2339 +my $x = InheritingFromOverloadedTest->new();
2340 +isa_ok($x, 'InheritingFromOverloadedTest');
2341 +
2342 +my $y = OverloadingTest->new();
2343 +isa_ok($y, 'OverloadingTest');
2344 +
2345 +is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing');
2346 +is("$y", 'OverloadingTest stringified', '... got the right value when stringifing');
2347 +
2348 +ok(($y eq 'OverloadingTest stringified'), '... eq was handled correctly');
2349 +
2350 +my $result;
2351 +eval {
2352 +    $result = $x eq 'InheritingFromOverloadedTest stringified'
2353 +};
2354 +ok(!$@, '... this should not throw an exception');
2355 +ok($result, '... and we should get the true value');
2356 +
2357 === ext/mro/t/basic_03_c3.t
2358 ==================================================================
2359 --- ext/mro/t/basic_03_c3.t     (/local/perl-current)   (revision 12599)
2360 +++ ext/mro/t/basic_03_c3.t     (/local/perl-c3)        (revision 12599)
2361 @@ -0,0 +1,108 @@
2362 +#!./perl
2363 +
2364 +use strict;
2365 +use warnings;
2366 +BEGIN {
2367 +    unless (-d 'blib') {
2368 +        chdir 't' if -d 't';
2369 +        @INC = '../lib';
2370 +    }
2371 +}
2372 +
2373 +use Test::More tests => 4;
2374 +use mro;
2375 +
2376 +=pod
2377 +
2378 +This example is take from: http://www.python.org/2.3/mro.html
2379 +
2380 +"My second example"
2381 +class O: pass
2382 +class F(O): pass
2383 +class E(O): pass
2384 +class D(O): pass
2385 +class C(D,F): pass
2386 +class B(E,D): pass
2387 +class A(B,C): pass
2388 +
2389 +                           6
2390 +                          ---
2391 +Level 3                  | O |
2392 +                       /  ---  \
2393 +                      /    |    \
2394 +                     /     |     \
2395 +                    /      |      \
2396 +                  ---     ---    ---
2397 +Level 2        2 | E | 4 | D |  | F | 5
2398 +                  ---     ---    ---
2399 +                   \      / \     /
2400 +                    \    /   \   /
2401 +                     \  /     \ /
2402 +                      ---     ---
2403 +Level 1            1 | B |   | C | 3
2404 +                      ---     ---
2405 +                       \       /
2406 +                        \     /
2407 +                          ---
2408 +Level 0                0 | A |
2409 +                          ---
2410 +
2411 +>>> A.mro()
2412 +(<class '__main__.A'>, <class '__main__.B'>, <class '__main__.E'>,
2413 +<class '__main__.C'>, <class '__main__.D'>, <class '__main__.F'>,
2414 +<type 'object'>)
2415 +
2416 +=cut
2417 +
2418 +{
2419 +    package Test::O;
2420 +    use mro 'c3';
2421 +
2422 +    sub O_or_D { 'Test::O' }
2423 +    sub O_or_F { 'Test::O' }
2424 +
2425 +    package Test::F;
2426 +    use base 'Test::O';
2427 +    use mro 'c3';
2428 +
2429 +    sub O_or_F { 'Test::F' }
2430 +
2431 +    package Test::E;
2432 +    use base 'Test::O';
2433 +    use mro 'c3';
2434 +
2435 +    package Test::D;
2436 +    use base 'Test::O';
2437 +    use mro 'c3';
2438 +
2439 +    sub O_or_D { 'Test::D' }
2440 +    sub C_or_D { 'Test::D' }
2441 +
2442 +    package Test::C;
2443 +    use base ('Test::D', 'Test::F');
2444 +    use mro 'c3';
2445 +
2446 +    sub C_or_D { 'Test::C' }
2447 +
2448 +    package Test::B;
2449 +    use base ('Test::E', 'Test::D');
2450 +    use mro 'c3';
2451 +
2452 +    package Test::A;
2453 +    use base ('Test::B', 'Test::C');
2454 +    use mro 'c3';
2455 +}
2456 +
2457 +is_deeply(
2458 +    mro::get_mro_linear('Test::A'),
2459 +    [ qw(Test::A Test::B Test::E Test::C Test::D Test::F Test::O) ],
2460 +    '... got the right MRO for Test::A');
2461 +
2462 +is(Test::A->O_or_D, 'Test::D', '... got the right method dispatch');
2463 +is(Test::A->O_or_F, 'Test::F', '... got the right method dispatch');
2464 +
2465 +# NOTE:
2466 +# this test is particularly interesting because the p5 dispatch
2467 +# would actually call Test::D before Test::C and Test::D is a
2468 +# subclass of Test::C
2469 +is(Test::A->C_or_D, 'Test::C', '... got the right method dispatch');
2470 === ext/mro/t/basic_04_c3.t
2471 ==================================================================
2472 --- ext/mro/t/basic_04_c3.t     (/local/perl-current)   (revision 12599)
2473 +++ ext/mro/t/basic_04_c3.t     (/local/perl-c3)        (revision 12599)
2474 @@ -0,0 +1,41 @@
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 => 1;
2487 +use mro;
2488 +
2489 +=pod
2490 +
2491 +From the parrot test t/pmc/object-meths.t
2492 +
2493 + A   B A   E
2494 +  \ /   \ /
2495 +   C     D
2496 +    \   /
2497 +     \ /
2498 +      F
2499 +
2500 +=cut
2501 +
2502 +{
2503 +    package t::lib::A; use mro 'c3';
2504 +    package t::lib::B; use mro 'c3';
2505 +    package t::lib::E; use mro 'c3';
2506 +    package t::lib::C; use mro 'c3'; use base ('t::lib::A', 't::lib::B');
2507 +    package t::lib::D; use mro 'c3'; use base ('t::lib::A', 't::lib::E');
2508 +    package t::lib::F; use mro 'c3'; use base ('t::lib::C', 't::lib::D');
2509 +}
2510 +
2511 +is_deeply(
2512 +    mro::get_mro_linear('t::lib::F'),
2513 +    [ qw(t::lib::F t::lib::C t::lib::D t::lib::A t::lib::B t::lib::E) ],
2514 +    '... got the right MRO for t::lib::F');
2515 +
2516 === ext/mro/t/basic_05_c3.t
2517 ==================================================================
2518 --- ext/mro/t/basic_05_c3.t     (/local/perl-current)   (revision 12599)
2519 +++ ext/mro/t/basic_05_c3.t     (/local/perl-c3)        (revision 12599)
2520 @@ -0,0 +1,62 @@
2521 +#!./perl
2522 +
2523 +use strict;
2524 +use warnings;
2525 +BEGIN {
2526 +    unless (-d 'blib') {
2527 +        chdir 't' if -d 't';
2528 +        @INC = '../lib';
2529 +    }
2530 +}
2531 +
2532 +use Test::More tests => 2;
2533 +use mro;
2534 +
2535 +=pod
2536 +
2537 +This tests a strange bug found by Matt S. Trout
2538 +while building DBIx::Class. Thanks Matt!!!!
2539 +
2540 +   <A>
2541 +  /   \
2542 +<C>   <B>
2543 +  \   /
2544 +   <D>
2545 +
2546 +=cut
2547 +
2548 +{
2549 +    package Diamond_A;
2550 +    use mro 'c3';
2551 +
2552 +    sub foo { 'Diamond_A::foo' }
2553 +}
2554 +{
2555 +    package Diamond_B;
2556 +    use base 'Diamond_A';
2557 +    use mro 'c3';
2558 +
2559 +    sub foo { 'Diamond_B::foo => ' . (shift)->SUPER::foo }
2560 +}
2561 +{
2562 +    package Diamond_C;
2563 +    use mro 'c3';
2564 +    use base 'Diamond_A';
2565 +
2566 +}
2567 +{
2568 +    package Diamond_D;
2569 +    use base ('Diamond_C', 'Diamond_B');
2570 +    use mro 'c3';
2571 +
2572 +    sub foo { 'Diamond_D::foo => ' . (shift)->SUPER::foo }
2573 +}
2574 +
2575 +is_deeply(
2576 +    mro::get_mro_linear('Diamond_D'),
2577 +    [ qw(Diamond_D Diamond_C Diamond_B Diamond_A) ],
2578 +    '... got the right MRO for Diamond_D');
2579 +
2580 +is(Diamond_D->foo,
2581 +   'Diamond_D::foo => Diamond_B::foo => Diamond_A::foo',
2582 +   '... got the right next::method dispatch path');
2583 === ext/mro/mro.xs
2584 ==================================================================
2585 --- ext/mro/mro.xs      (/local/perl-current)   (revision 12599)
2586 +++ ext/mro/mro.xs      (/local/perl-c3)        (revision 12599)
2587 @@ -0,0 +1,98 @@
2588 +/*     mro.xs
2589 + *
2590 + *     Copyright (c) 2006 Brandon L Black
2591 + *
2592 + *     You may distribute under the terms of either the GNU General Public
2593 + *     License or the Artistic License, as specified in the README file.
2594 + *
2595 + */
2596 +
2597 +#define PERL_NO_GET_CONTEXT
2598 +#include "EXTERN.h"
2599 +#include "perl.h"
2600 +#include "XSUB.h"
2601 +
2602 +MODULE = mro   PACKAGE = mro
2603 +
2604 +AV*
2605 +get_mro_linear(classname)
2606 +        SV* classname
2607 +    CODE:
2608 +        HV* class_stash;
2609 +        class_stash = gv_stashsv(classname, 0);
2610 +        if(!class_stash) croak("No such class: '%"SVf"'!", classname);
2611 +        RETVAL = mro_linear(class_stash);
2612 +    OUTPUT:
2613 +        RETVAL
2614 +
2615 +AV*
2616 +get_mro_linear_dfs(classname)
2617 +        SV* classname
2618 +    CODE:
2619 +        HV* class_stash;
2620 +        class_stash = gv_stashsv(classname, 0);
2621 +        if(!class_stash) croak("No such class: '%"SVf"'!", classname);
2622 +        RETVAL = mro_linear_dfs(class_stash, 0);
2623 +    OUTPUT:
2624 +        RETVAL
2625 +
2626 +AV*
2627 +get_mro_linear_c3(classname)
2628 +        SV* classname
2629 +    CODE:
2630 +        HV* class_stash;
2631 +        class_stash = gv_stashsv(classname, 0);
2632 +        if(!class_stash) croak("No such class: '%"SVf"'!", classname);
2633 +        RETVAL = mro_linear_c3(class_stash, 0);
2634 +    OUTPUT:
2635 +        RETVAL
2636 +
2637 +void
2638 +set_mro_dfs(classname)
2639 +        SV* classname
2640 +    CODE:
2641 +        HV* class_stash;
2642 +        struct mro_meta* meta;
2643 +        class_stash = gv_stashsv(classname, 1);
2644 +        if(!class_stash) croak("Cannot create class: '%"SVf"'!", classname);
2645 +        meta = HvMROMETA(class_stash);
2646 +        meta->mro_which = MRO_DFS;
2647 +       PL_sub_generation++;
2648 +
2649 +void
2650 +set_mro_c3(classname)
2651 +        SV* classname
2652 +    CODE:
2653 +        HV* class_stash;
2654 +        struct mro_meta* meta;
2655 +        class_stash = gv_stashsv(classname, 1);
2656 +        if(!class_stash) croak("Cannot create class: '%"SVf"'!", classname);
2657 +        meta = HvMROMETA(class_stash);
2658 +        meta->mro_which = MRO_C3;
2659 +       PL_sub_generation++;
2660 +
2661 +bool
2662 +is_mro_dfs(classname)
2663 +        SV* classname
2664 +    CODE:
2665 +        HV* class_stash;
2666 +        struct mro_meta* meta;
2667 +        class_stash = gv_stashsv(classname, 0);
2668 +        if(!class_stash) croak("No such class: '%"SVf"'!", classname);
2669 +        meta = HvMROMETA(class_stash);
2670 +       RETVAL = (meta->mro_which == MRO_DFS);
2671 +    OUTPUT:
2672 +        RETVAL
2673 +
2674 +bool
2675 +is_mro_c3(classname)
2676 +        SV* classname
2677 +    CODE:
2678 +        HV* class_stash;
2679 +        struct mro_meta* meta;
2680 +        class_stash = gv_stashsv(classname, 0);
2681 +        if(!class_stash) croak("No such class: '%"SVf"'!", classname);
2682 +        meta = HvMROMETA(class_stash);
2683 +       RETVAL = (meta->mro_which == MRO_C3);
2684 +    OUTPUT:
2685 +        RETVAL
2686 === ext/mro/Makefile.PL
2687 ==================================================================
2688 --- ext/mro/Makefile.PL (/local/perl-current)   (revision 12599)
2689 +++ ext/mro/Makefile.PL (/local/perl-c3)        (revision 12599)
2690 @@ -0,0 +1,35 @@
2691 +use ExtUtils::MakeMaker;
2692 +use Config;
2693 +use File::Spec;
2694 +
2695 +my $e = $Config{'exe_ext'};
2696 +my $o = $Config{'obj_ext'};
2697 +my $exeout_flag = '-o ';
2698 +if ($^O eq 'MSWin32') {
2699 +    if ($Config{'cc'} =~ /^cl/i) {
2700 +       $exeout_flag = '-Fe';
2701 +    }
2702 +    elsif ($Config{'cc'} =~ /^bcc/i) {
2703 +       $exeout_flag = '-e';
2704 +    }
2705 +}
2706 +
2707 +WriteMakefile(
2708 +    NAME           => "mro",
2709 +    VERSION_FROM    => "mro.pm",
2710 +    MAN3PODS       => {},
2711 +    clean          => {
2712 +       FILES       => "perl$e *$o mro.c *~"
2713 +    }
2714 +);
2715 +
2716 +package MY;
2717 +
2718 +sub post_constants {
2719 +    "\nLIBS = $Config::Config{libs}\n"
2720 +}
2721 +
2722 +sub upupfile {
2723 +    File::Spec->catfile(File::Spec->updir,
2724 +                       File::Spec->updir, $_[0]);
2725 +}
2726 === ext/mro/mro.pm
2727 ==================================================================
2728 --- ext/mro/mro.pm      (/local/perl-current)   (revision 12599)
2729 +++ ext/mro/mro.pm      (/local/perl-c3)        (revision 12599)
2730 @@ -0,0 +1,91 @@
2731 +#      mro.pm
2732 +#
2733 +#      Copyright (c) 2006 Brandon L Black
2734 +#
2735 +#      You may distribute under the terms of either the GNU General Public
2736 +#      License or the Artistic License, as specified in the README file.
2737 +#
2738 +package mro;
2739 +use strict;
2740 +use warnings;
2741 +
2742 +our $VERSION = '0.01';
2743 +
2744 +use XSLoader ();
2745 +
2746 +sub import {
2747 +    my $arg = $_[1];
2748 +    if($arg) {
2749 +        if($arg eq 'c3') {
2750 +            set_mro_c3(scalar(caller));
2751 +        }
2752 +        elsif($arg eq 'dfs') {
2753 +            set_mro_dfs(scalar(caller));
2754 +        }
2755 +    }
2756 +}
2757 +
2758 +XSLoader::load 'mro';
2759 +
2760 +1;
2761 +
2762 +__END__
2763 +
2764 +=head1 NAME
2765 +
2766 +mro - Method Resolution Order
2767 +
2768 +=head1 SYNOPSIS
2769 +
2770 +       use mro; # just gain access to mro::* functions
2771 +        use mro 'c3'; # enable C3 mro for this class
2772 +        use mro 'dfs'; # enable DFS mro for this class (Perl default)
2773 +
2774 +=head1 DESCRIPTION
2775 +
2776 +TODO
2777 +
2778 +=head1 OVERVIEW
2779 +
2780 +TODO
2781 +
2782 +=head1 Functions
2783 +
2784 +All of these take a scalar classname as the only argument
2785 +
2786 +=head2 mro_linear
2787 +
2788 +Return an arrayref which is the linearized MRO of the given class.
2789 +Uses whichever MRO is currently in effect for that class.
2790 +
2791 +=head2 mro_linear_dfs
2792 +
2793 +Return an arrayref which is the linearized MRO of the given classname.
2794 +Uses the DFS (perl default) MRO algorithm.
2795 +
2796 +=head2 mro_linear_c3
2797 +
2798 +Return an arrayref which is the linearized MRO of the given class.
2799 +Uses the C3 MRO algorithm.
2800 +
2801 +=head2 set_mro_dfs
2802 +
2803 +Sets the MRO of the given class to DFS (perl default).
2804 +
2805 +=head2 set_mro_c3
2806 +
2807 +Sets the MRO of the given class to C3.
2808 +
2809 +=head2 is_mro_dfs
2810 +
2811 +Return boolean indicating whether the given class is using the DFS (Perl default) MRO.
2812 +
2813 +=head2 is_mro_c3
2814 +
2815 +Return boolean indicating whether the given class is using the C3 MRO.
2816 +
2817 +=head1 AUTHOR
2818 +
2819 +Brandon L Black, C<blblack@gmail.com>
2820 +
2821 +=cut
2822 === MANIFEST
2823 ==================================================================
2824 --- MANIFEST    (/local/perl-current)   (revision 12599)
2825 +++ MANIFEST    (/local/perl-c3)        (revision 12599)
2826 @@ -893,6 +893,30 @@
2827  ext/MIME/Base64/t/quoted-print.t       See whether MIME::QuotedPrint works
2828  ext/MIME/Base64/t/unicode.t    See whether MIME::Base64 works
2829  ext/MIME/Base64/t/warn.t       See whether MIME::Base64 works
2830 +ext/mro/Makefile.PL            mro extension
2831 +ext/mro/mro.xs                 mro extension
2832 +ext/mro/mro.pm                 mro extension
2833 +ext/mro/t/basic_01_c3.t                mro tests
2834 +ext/mro/t/basic_01_dfs.t               mro tests
2835 +ext/mro/t/basic_02_c3.t                mro tests
2836 +ext/mro/t/basic_02_dfs.t               mro tests
2837 +ext/mro/t/basic_03_c3.t                mro tests
2838 +ext/mro/t/basic_03_dfs.t               mro tests
2839 +ext/mro/t/basic_04_c3.t                mro tests
2840 +ext/mro/t/basic_04_dfs.t               mro tests
2841 +ext/mro/t/basic_05_c3.t                mro tests
2842 +ext/mro/t/basic_05_dfs.t               mro tests
2843 +ext/mro/t/complex_c3.t         mro tests
2844 +ext/mro/t/complex_dfs.t                mro tests
2845 +ext/mro/t/dbic_c3.t            mro tests
2846 +ext/mro/t/dbic_dfs.t           mro tests
2847 +ext/mro/t/inconsistent_c3.t    mro tests
2848 +ext/mro/t/overload_c3.t                mro tests
2849 +ext/mro/t/overload_dfs.t               mro tests
2850 +ext/mro/t/recursion_c3.t               mro tests
2851 +ext/mro/t/recursion_dfs.t              mro tests
2852 +ext/mro/t/vulcan_c3.t          mro tests
2853 +ext/mro/t/vulcan_dfs.t         mro tests
2854  ext/NDBM_File/hints/cygwin.pl  Hint for NDBM_File for named architecture
2855  ext/NDBM_File/hints/dec_osf.pl Hint for NDBM_File for named architecture
2856  ext/NDBM_File/hints/dynixptx.pl        Hint for NDBM_File for named architecture
2857 @@ -2796,6 +2820,7 @@
2858  mpeix/mpeix_setjmp.c           MPE/iX port
2859  mpeix/nm                       MPE/iX port
2860  mpeix/relink                   MPE/iX port
2861 +mro.c                          Method Resolution Order code
2862  myconfig.SH                    Prints summary of the current configuration
2863  NetWare/bat/Buildtype.bat      NetWare port
2864  NetWare/bat/SetCodeWar.bat     NetWare port
2865 === mro.c
2866 ==================================================================
2867 --- mro.c       (/local/perl-current)   (revision 12599)
2868 +++ mro.c       (/local/perl-c3)        (revision 12599)
2869 @@ -0,0 +1,298 @@
2870 +/*    mro.c
2871 + *
2872 + *    Copyright (C) 2006 by Larry Wall and others
2873 + *
2874 + *    You may distribute under the terms of either the GNU General Public
2875 + *    License or the Artistic License, as specified in the README file.
2876 + *
2877 + */
2878 +
2879 +/*
2880 +=head1 MRO Functions
2881 +
2882 +These functions are related to the method resolution order of perl classes
2883 +
2884 +=cut
2885 +*/
2886 +
2887 +#include "EXTERN.h"
2888 +#include "perl.h"
2889 +
2890 +struct mro_meta*
2891 +Perl_mro_meta_init(pTHX_ HV* stash) {
2892 +    struct mro_meta* newmeta;
2893 +
2894 +    assert(HvAUX(stash));
2895 +    assert(!(HvAUX(stash)->xhv_mro_meta));
2896 +    Newxz(newmeta, sizeof(struct mro_meta), char);
2897 +    HvAUX(stash)->xhv_mro_meta = newmeta;
2898 +    return newmeta;
2899 +}
2900 +
2901 +/*
2902 +=for apidoc mro_linear_dfs
2903 +
2904 +Returns the Depth-First Search linearization of @ISA
2905 +the given stash.  The return value is a read-only AV*,
2906 +and is cached based on C<PL_isa_generation>.
2907 +
2908 +=cut
2909 +*/
2910 +AV*
2911 +Perl_mro_linear_dfs(pTHX_ HV *stash, I32 level) {
2912 +    AV* retval;
2913 +    GV** gvp;
2914 +    GV* gv;
2915 +    AV* av;
2916 +    SV** svp;
2917 +    I32 items;
2918 +    AV* subrv;
2919 +    SV** subrv_p;
2920 +    I32 subrv_items;
2921 +    const char* stashname;
2922 +    struct mro_meta* meta;
2923 +
2924 +    assert(stash);
2925 +    assert(HvAUX(stash));
2926 +
2927 +    stashname = HvNAME_get(stash);
2928 +    if (!stashname)
2929 +      Perl_croak(aTHX_
2930 +                "Can't linearize anonymous symbol table");
2931 +
2932 +    if (level > 100)
2933 +       Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
2934 +             stashname);
2935 +
2936 +    meta = HvMROMETA(stash);
2937 +    if((retval = meta->mro_linear_dfs)) {
2938 +        if(meta->mro_linear_dfs_gen == PL_isa_generation) {
2939 +            /* return the cached linearization if valid */
2940 +            SvREFCNT_inc_simple_void_NN(retval);
2941 +            return retval;
2942 +        }
2943 +        /* decref old cache and forget it */
2944 +        SvREFCNT_dec(retval);
2945 +        meta->mro_linear_dfs = NULL;
2946 +    }
2947 +
2948 +    /* make a new one */
2949 +
2950 +    retval = (AV*)sv_2mortal((SV*)newAV());
2951 +    av_push(retval, newSVpv(stashname, 0)); /* add ourselves at the top */
2952 +
2953 +    gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
2954 +    av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : NULL;
2955 +
2956 +    if(av) {
2957 +        svp = AvARRAY(av);
2958 +        items = AvFILLp(av) + 1;
2959 +        while (items--) {
2960 +            SV* const sv = *svp++;
2961 +            HV* const basestash = gv_stashsv(sv, FALSE);
2962 +            if (!basestash) {
2963 +                if (ckWARN(WARN_MISC))
2964 +                    Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
2965 +                        (void*)sv, stashname);
2966 +                continue;
2967 +            }
2968 +            subrv = (AV*)sv_2mortal((SV*)mro_linear_dfs(basestash, level + 1));
2969 +            subrv_p = AvARRAY(subrv);
2970 +            subrv_items = AvFILLp(subrv) + 1;
2971 +            while(subrv_items--) {
2972 +                SV* subsv = *subrv_p++;
2973 +                av_push(retval, newSVsv(subsv));
2974 +            }
2975 +        }
2976 +    }
2977 +
2978 +    SvREADONLY_on(retval);
2979 +    SvREFCNT_inc_simple_void_NN(retval); /* for meta storage */
2980 +    SvREFCNT_inc_simple_void_NN(retval); /* for return to caller */
2981 +    meta->mro_linear_dfs = retval;
2982 +    meta->mro_linear_dfs_gen = PL_isa_generation;
2983 +    return retval;
2984 +}
2985 +
2986 +/*
2987 +=for apidoc mro_linear_c3
2988 +
2989 +Returns the C3 linearization of @ISA
2990 +the given stash.  The return value is a read-only AV*,
2991 +and is cached based on C<PL_isa_generation>.
2992 +
2993 +=cut
2994 +*/
2995 +
2996 +AV*
2997 +Perl_mro_linear_c3(pTHX_ HV* stash, I32 level) {
2998 +    AV* retval;
2999 +    GV** gvp;
3000 +    GV* gv;
3001 +    AV* isa;
3002 +    const char* stashname;
3003 +    STRLEN stashname_len;
3004 +    struct mro_meta* meta;
3005 +
3006 +    assert(stash);
3007 +    assert(HvAUX(stash));
3008 +
3009 +    stashname = HvNAME_get(stash);
3010 +    stashname_len = HvNAMELEN_get(stash);
3011 +    if (!stashname)
3012 +      Perl_croak(aTHX_
3013 +                "Can't linearize anonymous symbol table");
3014 +
3015 +    if (level > 100)
3016 +       Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
3017 +             stashname);
3018 +
3019 +    meta = HvMROMETA(stash);
3020 +    if((retval = meta->mro_linear_c3)) {
3021 +        if(meta->mro_linear_c3_gen == PL_isa_generation) {
3022 +            /* return cache if valid */
3023 +            SvREFCNT_inc_simple_void_NN(retval);
3024 +            return retval;
3025 +        }
3026 +        /* decref old cache and forget it */
3027 +        SvREFCNT_dec(retval);
3028 +        meta->mro_linear_c3 = NULL;
3029 +    }
3030 +
3031 +    retval = (AV*)sv_2mortal((SV*)newAV());
3032 +    av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
3033 +
3034 +    gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
3035 +    isa = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : NULL;
3036 +
3037 +    if(isa && AvFILLp(isa) >= 0) {
3038 +        SV** seqs_ptr;
3039 +        I32 seqs_items;
3040 +        HV* tails = (HV*)sv_2mortal((SV*)newHV());
3041 +        AV* seqs = (AV*)sv_2mortal((SV*)newAV());
3042 +        I32 items = AvFILLp(isa) + 1;
3043 +        SV** isa_ptr = AvARRAY(isa);
3044 +        while(items--) {
3045 +            AV* isa_lin;
3046 +            SV* isa_item = *isa_ptr++;
3047 +            HV* isa_item_stash = gv_stashsv(isa_item, FALSE);
3048 +            if(!isa_item_stash)
3049 +                Perl_croak(aTHX_ "Cannot find class %"SVf" for @%s::ISA", isa_item, stashname);
3050 +            isa_lin = (AV*)sv_2mortal((SV*)mro_linear_c3(isa_item_stash, level + 1)); /* recursion */
3051 +            av_push(seqs, (SV*)av_make(AvFILLp(isa_lin)+1, AvARRAY(isa_lin)));
3052 +        }
3053 +        av_push(seqs, (SV*)av_make(AvFILLp(isa)+1, AvARRAY(isa)));
3054 +
3055 +        seqs_ptr = AvARRAY(seqs);
3056 +        seqs_items = AvFILLp(seqs) + 1;
3057 +        while(seqs_items--) {
3058 +            AV* seq = (AV*)*seqs_ptr++;
3059 +            I32 seq_items = AvFILLp(seq);
3060 +            if(seq_items > 0) {
3061 +                SV** seq_ptr = AvARRAY(seq) + 1;
3062 +                while(seq_items--) {
3063 +                    SV* seqitem = *seq_ptr++;
3064 +                    HE* he = hv_fetch_ent(tails, seqitem, 0, 0);
3065 +                    if(!he) {
3066 +                        hv_store_ent(tails, seqitem, newSViv(1), 0);
3067 +                    }
3068 +                    else {
3069 +                        SV* val = HeVAL(he);
3070 +                        sv_inc(val);
3071 +                    }
3072 +                }
3073 +            }
3074 +        }
3075 +
3076 +        while(1) {
3077 +            SV* seqhead = NULL;
3078 +            SV* cand = NULL;
3079 +            SV* winner = NULL;
3080 +            SV* val;
3081 +            HE* tail_entry;
3082 +            AV* seq;
3083 +            SV** avptr = AvARRAY(seqs);
3084 +            items = AvFILLp(seqs)+1;
3085 +            while(items--) {
3086 +                SV** svp;
3087 +                seq = (AV*)*avptr++;
3088 +                if(AvFILLp(seq) < 0) continue;
3089 +                svp = av_fetch(seq, 0, 0);
3090 +                seqhead = *svp;
3091 +                if(!winner) {
3092 +                    cand = seqhead;
3093 +                    if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
3094 +                       && (val = HeVAL(tail_entry))
3095 +                       && (SvIVx(val) > 0))
3096 +                           continue;
3097 +                    winner = newSVsv(cand);
3098 +                    av_push(retval, winner);
3099 +                }
3100 +                if(!sv_cmp(seqhead, winner)) {
3101 +
3102 +                    /* this is basically shift(@seq) in void context */
3103 +                    SvREFCNT_dec(*AvARRAY(seq));
3104 +                    *AvARRAY(seq) = &PL_sv_undef;
3105 +                    AvARRAY(seq) = AvARRAY(seq) + 1;
3106 +                    AvMAX(seq)--;
3107 +                    AvFILLp(seq)--;
3108 +
3109 +                    if(AvFILLp(seq) < 0) continue;
3110 +                    svp = av_fetch(seq, 0, 0);
3111 +                    seqhead = *svp;
3112 +                    tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
3113 +                    val = HeVAL(tail_entry);
3114 +                    sv_dec(val);
3115 +                }
3116 +            }
3117 +            if(!cand) break;
3118 +            if(!winner)
3119 +                Perl_croak(aTHX_ "Inconsistent inheritance hierarchy during C3 merge of class '%s': "
3120 +                    "merging failed on parent '%"SVf"'", stashname, cand);
3121 +        }
3122 +    }
3123 +
3124 +    SvREADONLY_on(retval);
3125 +    SvREFCNT_inc_simple_void_NN(retval); /* for meta storage */
3126 +    SvREFCNT_inc_simple_void_NN(retval); /* for return to caller */
3127 +    meta->mro_linear_c3 = retval;
3128 +    meta->mro_linear_c3_gen = PL_isa_generation;
3129 +    return retval;
3130 +}
3131 +
3132 +/*
3133 +=for apidoc mro_linear
3134 +
3135 +Returns either C<mro_linear_c3> or C<mro_linear_dfs> for
3136 +the given stash, dependant upon which MRO is in effect
3137 +for that stash.  The return value is a read-only AV*,
3138 +and is cached based on C<PL_isa_generation>.
3139 +
3140 +=cut
3141 +*/
3142 +AV*
3143 +Perl_mro_linear(pTHX_ HV *stash)
3144 +{
3145 +    struct mro_meta* meta;
3146 +    assert(stash);
3147 +    assert(HvAUX(stash));
3148 +
3149 +    meta = HvMROMETA(stash);
3150 +    if(meta->mro_which == MRO_DFS) {
3151 +        return mro_linear_dfs(stash, 0);
3152 +    } else if(meta->mro_which == MRO_C3) {
3153 +        return mro_linear_c3(stash, 0);
3154 +    } else {
3155 +        Perl_croak(aTHX_ "Internal error: invalid MRO!");
3156 +    }
3157 +}
3158 +
3159 +/*
3160 + * Local variables:
3161 + * c-indentation-style: bsd
3162 + * c-basic-offset: 4
3163 + * indent-tabs-mode: t
3164 + * End:
3165 + *
3166 + * ex: set ts=8 sts=4 sw=4 noet:
3167 + */
3168 === hv.c
3169 ==================================================================
3170 --- hv.c        (/local/perl-current)   (revision 12599)
3171 +++ hv.c        (/local/perl-c3)        (revision 12599)
3172 @@ -1743,6 +1743,7 @@
3173
3174         if (SvOOK(hv)) {
3175             HE *entry;
3176 +            struct mro_meta *meta;
3177             struct xpvhv_aux *iter = HvAUX(hv);
3178             /* If there are weak references to this HV, we need to avoid
3179                freeing them up here.  In particular we need to keep the AV
3180 @@ -1774,6 +1775,13 @@
3181             iter->xhv_riter = -1;       /* HvRITER(hv) = -1 */
3182             iter->xhv_eiter = NULL;     /* HvEITER(hv) = NULL */
3183
3184 +            if(meta = iter->xhv_mro_meta) {
3185 +                if(meta->mro_linear_dfs) SvREFCNT_dec(meta->mro_linear_dfs);
3186 +                if(meta->mro_linear_c3)  SvREFCNT_dec(meta->mro_linear_c3);
3187 +                Safefree(meta);
3188 +                iter->xhv_mro_meta = NULL;
3189 +            }
3190 +
3191             /* There are now no allocated pointers in the aux structure.  */
3192
3193             SvFLAGS(hv) &= ~SVf_OOK; /* Goodbye, aux structure.  */
3194 @@ -1895,6 +1903,7 @@
3195      iter->xhv_eiter = NULL;    /* HvEITER(hv) = NULL */
3196      iter->xhv_name = 0;
3197      iter->xhv_backreferences = 0;
3198 +    iter->xhv_mro_meta = NULL;
3199      return iter;
3200  }
3201
3202 === hv.h
3203 ==================================================================
3204 --- hv.h        (/local/perl-current)   (revision 12599)
3205 +++ hv.h        (/local/perl-c3)        (revision 12599)
3206 @@ -38,12 +38,32 @@
3207
3208  /* Subject to change.
3209     Don't access this directly.
3210 +   Use the funcs in mro.c
3211  */
3212 +
3213 +typedef enum {
3214 +    MRO_DFS, /* 0 */
3215 +    MRO_C3   /* 1 */
3216 +} mro_alg;
3217 +
3218 +struct mro_meta {
3219 +    AV          *mro_linear_dfs; /* cached dfs @ISA linearization */
3220 +    AV          *mro_linear_c3; /* cached c3 @ISA linearization */
3221 +    U32         mro_linear_dfs_gen;    /* PL_isa_generation for above */
3222 +    U32         mro_linear_c3_gen;    /* PL_isa_generation for above */
3223 +    mro_alg     mro_which;      /* which mro alg is in use? */
3224 +};
3225 +
3226 +/* Subject to change.
3227 +   Don't access this directly.
3228 +*/
3229 +
3230  struct xpvhv_aux {
3231      HEK                *xhv_name;      /* name, if a symbol table */
3232      AV         *xhv_backreferences; /* back references for weak references */
3233      HE         *xhv_eiter;     /* current entry of iterator */
3234      I32                xhv_riter;      /* current root of iterator */
3235 +    struct mro_meta *xhv_mro_meta;
3236  };
3237
3238  /* hash structure: */
3239 @@ -240,6 +260,7 @@
3240  #define HvRITER_get(hv)        (SvOOK(hv) ? HvAUX(hv)->xhv_riter : -1)
3241  #define HvEITER_get(hv)        (SvOOK(hv) ? HvAUX(hv)->xhv_eiter : 0)
3242  #define HvNAME(hv)     HvNAME_get(hv)
3243 +#define HvMROMETA(hv)  (HvAUX(hv)->xhv_mro_meta ? HvAUX(hv)->xhv_mro_meta : mro_meta_init(hv))
3244  /* FIXME - all of these should use a UTF8 aware API, which should also involve
3245     getting the length. */
3246  /* This macro may go away without notice.  */
3247 === mg.c
3248 ==================================================================
3249 --- mg.c        (/local/perl-current)   (revision 12599)
3250 +++ mg.c        (/local/perl-c3)        (revision 12599)
3251 @@ -1520,6 +1520,7 @@
3252      PERL_UNUSED_ARG(sv);
3253      PERL_UNUSED_ARG(mg);
3254      PL_sub_generation++;
3255 +    PL_isa_generation++;
3256      return 0;
3257  }
3258
3259 === intrpvar.h
3260 ==================================================================
3261 --- intrpvar.h  (/local/perl-current)   (revision 12599)
3262 +++ intrpvar.h  (/local/perl-c3)        (revision 12599)
3263 @@ -529,6 +529,7 @@
3264  PERLVARI(Iutf8cache, I8, 1)    /* Is the utf8 caching code enabled? */
3265  #endif
3266
3267 +PERLVARI(Iisa_generation,U32,1)                /* incr to invalidate @ISA linearization cache */
3268  /* New variables must be added to the very end, before this comment,
3269   * for binary compatibility (the offsets of the old members must not change).
3270   * (Don't forget to add your variable also to perl_clone()!)
3271 === sv.c
3272 ==================================================================
3273 --- sv.c        (/local/perl-current)   (revision 12599)
3274 +++ sv.c        (/local/perl-c3)        (revision 12599)
3275 @@ -11061,6 +11061,7 @@
3276      PL_initav          = av_dup_inc(proto_perl->Iinitav, param);
3277
3278      PL_sub_generation  = proto_perl->Isub_generation;
3279 +    PL_isa_generation  = proto_perl->Iisa_generation;
3280
3281      /* funky return mechanisms */
3282      PL_forkprocess     = proto_perl->Iforkprocess;
3283 === embed.fnc
3284 ==================================================================
3285 --- embed.fnc   (/local/perl-current)   (revision 12599)
3286 +++ embed.fnc   (/local/perl-c3)        (revision 12599)
3287 @@ -278,6 +278,10 @@
3288  Apmb   |void   |gv_efullname3  |NN SV* sv|NN const GV* gv|NULLOK const char* prefix
3289  Ap     |void   |gv_efullname4  |NN SV* sv|NN const GV* gv|NULLOK const char* prefix|bool keepmain
3290  Ap     |GV*    |gv_fetchfile   |NN const char* name
3291 +ApM    |struct mro_meta*       |mro_meta_init  |NN HV* stash
3292 +ApM    |AV*    |mro_linear     |NN HV* stash
3293 +ApM    |AV*    |mro_linear_c3  |NN HV* stash|I32 level
3294 +ApM    |AV*    |mro_linear_dfs |NN HV* stash|I32 level
3295  Apd    |GV*    |gv_fetchmeth   |NULLOK HV* stash|NN const char* name|STRLEN len|I32 level
3296  Apd    |GV*    |gv_fetchmeth_autoload  |NULLOK HV* stash|NN const char* name|STRLEN len|I32 level
3297  Apdmb  |GV*    |gv_fetchmethod |NULLOK HV* stash|NN const char* name
3298
3299 Property changes on:
3300 ___________________________________________________________________
3301 Name: svk:merge
3302  +2679d79f-d018-0410-a353-0f906ad2929c:/local/perl-current:12598
3303