c3.patch

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