c3.patch

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