2 ==================================================================
3 --- Makefile.micro (/local/perl-current) (revision 29701)
4 +++ Makefile.micro (/local/perl-c3) (revision 29701)
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) \
16 $(CC) -c -o $@ $(CFLAGS) gv.c
18 +umro$(_O): $(HE) mro.c
19 + $(CC) -c -o $@ $(CFLAGS) mro.c
22 $(CC) -c -o $@ $(CFLAGS) hv.c
25 ==================================================================
26 --- embed.h (/local/perl-current) (revision 29701)
27 +++ embed.h (/local/perl-c3) (revision 29701)
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)
51 ==================================================================
52 --- embedvar.h (/local/perl-current) (revision 29701)
53 +++ embedvar.h (/local/perl-c3) (revision 29701)
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)
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
71 ==================================================================
72 --- pod/perlapi.pod (/local/perl-current) (revision 29701)
73 +++ pod/perlapi.pod (/local/perl-c3) (revision 29701)
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.
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
84 ==================================================================
85 --- global.sym (/local/perl-current) (revision 29701)
86 +++ global.sym (/local/perl-c3) (revision 29701)
90 Perl_gv_fetchfile_flags
96 Perl_gv_fetchmeth_autoload
99 ==================================================================
100 --- universal.c (/local/perl-current) (revision 29701)
101 +++ universal.c (/local/perl-c3) (revision 29701)
111 + AV* stash_linear_isa;
115 + PERL_UNUSED_ARG(len);
116 + PERL_UNUSED_ARG(level);
118 /* A stash/class can go by many names (ie. User == main::User), so
119 we compare the stash itself just in case */
121 if (strEQ(name, "UNIVERSAL"))
125 - Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
128 - gvp = (GV**)hv_fetchs(stash, "::ISA::CACHE::", FALSE);
130 - if (gvp && (gv = *gvp) && isGV_with_GP(gv) && (subgen = GvSV(gv))
131 - && (hv = GvHV(gv)))
133 - if (SvIV(subgen) == (IV)PL_sub_generation) {
134 - SV** const svp = (SV**)hv_fetch(hv, name, len, FALSE);
136 - SV * const sv = *svp;
138 - if (sv != &PL_sv_undef)
139 - DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
142 - return (sv == &PL_sv_yes);
144 + stash_linear_isa = (AV*)sv_2mortal((SV*)mro_linear(stash));
145 + svp = AvARRAY(stash_linear_isa) + 1;
146 + items = AvFILLp(stash_linear_isa);
148 + SV* const basename_sv = *svp++;
149 + HV* basestash = gv_stashsv(basename_sv, 0);
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);
158 - DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
161 - sv_setiv(subgen, PL_sub_generation);
163 + if(name_stash == basestash || strEQ(name, SvPVX(basename_sv)))
167 - gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
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);
175 - if (SvTYPE(gv) != SVt_PVGV)
176 - gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
181 - subgen = newSViv(PL_sub_generation);
186 - SV** svp = AvARRAY(av);
187 - /* NOTE: No support for tied ISA */
188 - I32 items = AvFILLp(av) + 1;
190 - SV* const sv = *svp++;
191 - HV* const basestash = gv_stashsv(sv, 0);
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);
199 - if (isa_lookup(basestash, name, name_stash, len, level + 1)) {
200 - (void)hv_store(hv,name,len,&PL_sv_yes,0);
204 - (void)hv_store(hv,name,len,&PL_sv_no,0);
211 ==================================================================
212 --- gv.c (/local/perl-current) (revision 29701)
213 +++ gv.c (/local/perl-c3) (revision 29701)
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.
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 @@
227 +/* NOTE: No support for tied ISA */
230 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
242 + GV* candidate = NULL;
243 + CV* cand_cv = NULL;
247 - HV* lastchance = NULL;
248 + I32 create = (level >= 0) ? 1 : 0;
252 /* UNIVERSAL methods should be callable without a stash */
254 - level = -1; /* probably appropriate */
255 + create = 0; /* probably appropriate */
256 if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
262 hvname = HvNAME_get(stash);
265 - "Can't use anonymous symbol table for method lookup");
266 + Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
268 - if ((level > 100) || (level < -100))
269 - Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
275 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) );
277 - gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
280 + /* check locally for a real method or a cache entry */
281 + gvp = (GV**)hv_fetch(stash, name, len, create);
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) {
293 + /* stale cache entry, junk it and move on */
294 + SvREFCNT_dec(cand_cv);
295 + GvCV(topgv) = cand_cv = NULL;
296 + GvCVGEN(topgv) = 0;
299 + else if (GvCVGEN(topgv) == PL_sub_generation) {
300 + /* cache indicates no such method definitively */
305 + packlen = HvNAMELEN_get(stash);
306 + if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
309 + basestash = gv_stashpvn(hvname, packlen, GV_ADD);
310 + linear_av = mro_linear(basestash);
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)
320 - /* Stale cached entry: junk it */
322 - GvCV(topgv) = cv = NULL;
323 - GvCVGEN(topgv) = 0;
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 */
329 + sv_2mortal((SV*)linear_av);
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 */
336 + linear_sv = *linear_svp++;
338 + curstash = gv_stashsv(linear_sv, 0);
340 - /* create and re-create @.*::SUPER::ISA on demand */
341 - if (!av || !SvMAGIC(av)) {
342 - STRLEN packlen = HvNAMELEN_get(stash);
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);
350 - if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
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);
367 + gvp = (GV**)hv_fetch(curstash, name, len, 0);
368 + if (!gvp) continue;
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)) {
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)
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;
389 - SV** svp = AvARRAY(av);
390 - /* NOTE: No support for tied ISA */
391 - I32 items = AvFILLp(av) + 1;
393 - SV* const sv = *svp++;
394 - HV* const basestash = gv_stashsv(sv, 0);
396 - if (ckWARN(WARN_MISC))
397 - Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
398 - SVfARG(sv), hvname);
401 - gv = gv_fetchmeth(basestash, name, len,
402 - (level >= 0) ? level + 1 : level - 1);
406 + /* Check UNIVERSAL without caching */
407 + if(level == 0 || level == -1) {
408 + candidate = gv_fetchmeth(NULL, name, len, 1);
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;
421 - /* if at top level, try UNIVERSAL */
423 - if (level == 0 || level == -1) {
424 - lastchance = gv_stashpvs("UNIVERSAL", 0);
427 - if ((gv = gv_fetchmeth(lastchance, name, len,
428 - (level >= 0) ? level + 1 : level - 1)))
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)
437 - GvREFCNT(topgv) == 1 &&
439 - (CvROOT(cv) || CvXSUB(cv)))
441 - if ((cv = GvCV(topgv)))
443 - GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
444 - GvCVGEN(topgv) = PL_sub_generation;
448 - else if (topgv && GvREFCNT(topgv) == 1) {
449 - /* cache the fact that the method is not defined */
450 - GvCVGEN(topgv) = PL_sub_generation;
453 + if (topgv && GvREFCNT(topgv) == 1) {
454 + /* cache the fact that the method is not defined */
455 + GvCVGEN(topgv) = PL_sub_generation;
460 ==================================================================
461 --- perlapi.h (/local/perl-current) (revision 29701)
462 +++ perlapi.h (/local/perl-c3) (revision 29701)
464 #define PL_initav (*Perl_Iinitav_ptr(aTHX))
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))
473 ==================================================================
474 --- win32/Makefile (/local/perl-current) (revision 29701)
475 +++ win32/Makefile (/local/perl-c3) (revision 29701)
484 === win32/makefile.mk
485 ==================================================================
486 --- win32/makefile.mk (/local/perl-current) (revision 29701)
487 +++ win32/makefile.mk (/local/perl-c3) (revision 29701)
496 === win32/Makefile.ce
497 ==================================================================
498 --- win32/Makefile.ce (/local/perl-current) (revision 29701)
499 +++ win32/Makefile.ce (/local/perl-c3) (revision 29701)
510 $(DLLDIR)\globals.obj \
514 $(DLLDIR)\locale.obj \
515 $(DLLDIR)\mathoms.obj \
517 ==================================================================
518 --- NetWare/Makefile (/local/perl-current) (revision 29701)
519 +++ NetWare/Makefile (/local/perl-c3) (revision 29701)
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 @@
534 #### End of system configuration section. ####
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)
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)
551 $(CC) $(CORECFLAGS) $(MMS$SOURCE)
552 +mro$(O) : mro.c $(h)
553 + $(CC) $(CORECFLAGS) $(MMS$SOURCE)
555 $(CC) $(CORECFLAGS) $(MMS$SOURCE)
556 locale$(O) : locale.c $(h)
558 ==================================================================
559 --- Makefile.SH (/local/perl-current) (revision 29701)
560 +++ Makefile.SH (/local/perl-c3) (revision 29701)
562 h5 = utf8.h warnings.h
563 h = $(h1) $(h2) $(h3) $(h4) $(h5)
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
572 c = $(c1) $(c2) $(c3) $(c4) $(c5) miniperlmain.c perlmain.c opmini.c
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)
580 ==================================================================
581 --- proto.h (/local/perl-current) (revision 29701)
582 +++ proto.h (/local/perl-c3) (revision 29701)
584 PERL_CALLCONV GV* Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN len, const U32 flags)
585 __attribute__nonnull__(pTHX_1);
587 +PERL_CALLCONV struct mro_meta* Perl_mro_meta_init(pTHX_ HV* stash)
588 + __attribute__nonnull__(pTHX_1);
590 +PERL_CALLCONV AV* Perl_mro_linear(pTHX_ HV* stash)
591 + __attribute__nonnull__(pTHX_1);
593 +PERL_CALLCONV AV* Perl_mro_linear_c3(pTHX_ HV* stash, I32 level)
594 + __attribute__nonnull__(pTHX_1);
596 +PERL_CALLCONV AV* Perl_mro_linear_dfs(pTHX_ HV* stash, I32 level)
597 + __attribute__nonnull__(pTHX_1);
599 PERL_CALLCONV GV* Perl_gv_fetchmeth(pTHX_ HV* stash, const char* name, STRLEN len, I32 level)
600 __attribute__nonnull__(pTHX_2);
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)
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
614 + 17 * ($] >= 5.009003)
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') : ()],
623 B::Deparse => { dflt => 'perl', # 235 functions
625 ==================================================================
626 --- ext/B/B.xs (/local/perl-current) (revision 29701)
627 +++ ext/B/B.xs (/local/perl-c3) (revision 29701)
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
647 ==================================================================
648 --- ext/B/B.pm (/local/perl-current) (revision 29701)
649 +++ ext/B/B.pm (/local/perl-c3) (revision 29701)
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
656 push @EXPORT_OK, qw(unitcheck_av) if $] > 5.009;
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)
672 + unless (-d 'blib') {
673 + chdir 't' if -d 't';
678 +use Test::More tests => 4;
683 +This tests the classic diamond inheritence pattern.
695 + sub hello { 'Diamond_A::hello' }
699 + use base 'Diamond_A';
703 + use base 'Diamond_A';
705 + sub hello { 'Diamond_C::hello' }
709 + use base ('Diamond_B', 'Diamond_C');
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');
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)
731 + unless (-d 'blib') {
732 + chdir 't' if -d 't';
737 +use Test::More tests => 1;
742 +example taken from: L<http://gauss.gwydiondylan.org/books/drm/drm_50.html>
753 + Intelligent Humanoid
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;
776 + use base 'LifeForm';
780 + use base 'LifeForm';
782 + package Intelligent;
784 + use base 'Sentient';
788 + use base 'BiPedal';
792 + use base ('Intelligent', 'Humanoid');
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)
809 + unless (-d 'blib') {
810 + chdir 't' if -d 't';
815 +use Test::More tests => 10;
820 +This example is take from: http://www.python.org/2.3/mro.html
834 +Level 3 | O | (more general)
840 +Level 2 3 | D | 4| E | | F | 5 |
846 +Level 1 1 | B | | C | 2 |
851 +Level 0 0 | A | (more specialized)
862 + use base 'Test::O';
865 + use base 'Test::O';
868 + sub C_or_E { 'Test::E' }
872 + use base 'Test::O';
874 + sub C_or_D { 'Test::D' }
877 + use base ('Test::D', 'Test::F');
880 + sub C_or_D { 'Test::C' }
881 + sub C_or_E { 'Test::C' }
885 + use base ('Test::D', 'Test::E');
888 + use base ('Test::B', 'Test::C');
893 + mro::get_mro_linear('Test::F'),
894 + [ qw(Test::F Test::O) ],
895 + '... got the right MRO for Test::F');
898 + mro::get_mro_linear('Test::E'),
899 + [ qw(Test::E Test::O) ],
900 + '... got the right MRO for Test::E');
903 + mro::get_mro_linear('Test::D'),
904 + [ qw(Test::D Test::O) ],
905 + '... got the right MRO for Test::D');
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');
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');
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');
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)
936 + unless (-d 'blib') {
937 + chdir 't' if -d 't';
942 +use Test::More tests => 4;
947 +This example is take from: http://www.python.org/2.3/mro.html
966 +Level 2 2 | E | 4 | D | | F | 5
972 +Level 1 1 | B | | C | 3
981 +(<class '__main__.A'>, <class '__main__.B'>, <class '__main__.E'>,
982 +<class '__main__.C'>, <class '__main__.D'>, <class '__main__.F'>,
991 + sub O_or_D { 'Test::O' }
992 + sub O_or_F { 'Test::O' }
995 + use base 'Test::O';
998 + sub O_or_F { 'Test::F' }
1001 + use base 'Test::O';
1005 + use base 'Test::O';
1008 + sub O_or_D { 'Test::D' }
1009 + sub C_or_D { 'Test::D' }
1012 + use base ('Test::D', 'Test::F');
1015 + sub C_or_D { 'Test::C' }
1018 + use base ('Test::E', 'Test::D');
1022 + use base ('Test::B', 'Test::C');
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');
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');
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)
1049 + unless (-d 'blib') {
1050 + chdir 't' if -d 't';
1055 +use Test::More tests => 1;
1060 +From the parrot test t/pmc/object-meths.t
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');
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');
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)
1095 + unless (-d 'blib') {
1096 + chdir 't' if -d 't';
1101 +use Test::More tests => 2;
1106 +This tests a strange bug found by Matt S. Trout
1107 +while building DBIx::Class. Thanks Matt!!!!
1118 + package Diamond_A;
1121 + sub foo { 'Diamond_A::foo' }
1124 + package Diamond_B;
1125 + use base 'Diamond_A';
1128 + sub foo { 'Diamond_B::foo => ' . (shift)->SUPER::foo }
1131 + package Diamond_C;
1133 + use base 'Diamond_A';
1137 + package Diamond_D;
1138 + use base ('Diamond_C', 'Diamond_B');
1141 + sub foo { 'Diamond_D::foo => ' . (shift)->SUPER::foo }
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');
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)
1162 + unless (-d 'blib') {
1163 + chdir 't' if -d 't';
1168 +use Test::More tests => 1;
1173 +example taken from: L<http://gauss.gwydiondylan.org/books/drm/drm_50.html>
1184 + Intelligent Humanoid
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;
1203 + use base 'Object';
1207 + use base 'LifeForm';
1211 + use base 'LifeForm';
1213 + package Intelligent;
1215 + use base 'Sentient';
1219 + use base 'BiPedal';
1223 + use base ('Intelligent', 'Humanoid');
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)
1240 + unless (-d 'blib') {
1241 + chdir 't' if -d 't';
1246 +use Test::More tests => 1;
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)
1254 +The xx:: prefixes are just to be sure these bogus declarations never stomp on real ones
1259 + package xx::DBIx::Class::Core; use mro 'c3';
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
1271 + package xx::DBIx::Class::InflateColumn; use mro 'c3';
1272 + our @ISA = qw/ xx::DBIx::Class::Row /;
1274 + package xx::DBIx::Class::Row; use mro 'c3';
1275 + our @ISA = qw/ xx::DBIx::Class /;
1277 + package xx::DBIx::Class; use mro 'c3';
1279 + xx::DBIx::Class::Componentised
1280 + xx::Class::Data::Accessor
1283 + package xx::DBIx::Class::Relationship; use mro 'c3';
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
1293 + package xx::DBIx::Class::Relationship::Helpers; use mro 'c3';
1295 + xx::DBIx::Class::Relationship::HasMany
1296 + xx::DBIx::Class::Relationship::HasOne
1297 + xx::DBIx::Class::Relationship::BelongsTo
1298 + xx::DBIx::Class::Relationship::ManyToMany
1301 + package xx::DBIx::Class::Relationship::ProxyMethods; use mro 'c3';
1302 + our @ISA = qw/ xx::DBIx::Class /;
1304 + package xx::DBIx::Class::Relationship::Base; use mro 'c3';
1305 + our @ISA = qw/ xx::DBIx::Class /;
1307 + package xx::DBIx::Class::PK::Auto; use mro 'c3';
1308 + our @ISA = qw/ xx::DBIx::Class /;
1310 + package xx::DBIx::Class::PK; use mro 'c3';
1311 + our @ISA = qw/ xx::DBIx::Class::Row /;
1313 + package xx::DBIx::Class::ResultSourceProxy::Table; use mro 'c3';
1315 + xx::DBIx::Class::AccessorGroup
1316 + xx::DBIx::Class::ResultSourceProxy
1319 + package xx::DBIx::Class::ResultSourceProxy; use mro 'c3';
1320 + our @ISA = qw/ xx::DBIx::Class /;
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';
1335 + mro::get_mro_linear('xx::DBIx::Class::Core'),
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
1357 + xx::DBIx::Class::Componentised
1358 + xx::Class::Data::Accessor
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)
1371 + unless (-d 'blib') {
1372 + chdir 't' if -d 't';
1377 +use Test::More tests => 11;
1382 +This example is taken from: http://rt.cpan.org/Public/Bug/Display.html?id=20879
1385 +Level 5 8 | A | 9 | B | A | C | (More General)
1397 +Level 3 4 | G | 6 | E | |
1402 +Level 2 3 | H | 5 | F | |
1410 +Level 1 1 | J | 2 | I | |
1415 +Level 0 0 | K | (More Specialized)
1425 + package Test::A; use mro 'c3';
1427 + package Test::B; use mro 'c3';
1429 + package Test::C; use mro 'c3';
1431 + package Test::D; use mro 'c3';
1432 + use base qw/Test::A Test::B Test::C/;
1434 + package Test::E; use mro 'c3';
1435 + use base qw/Test::D/;
1437 + package Test::F; use mro 'c3';
1438 + use base qw/Test::E/;
1440 + package Test::G; use mro 'c3';
1441 + use base qw/Test::D/;
1443 + package Test::H; use mro 'c3';
1444 + use base qw/Test::G/;
1446 + package Test::I; use mro 'c3';
1447 + use base qw/Test::H Test::F/;
1449 + package Test::J; use mro 'c3';
1450 + use base qw/Test::F/;
1452 + package Test::K; use mro 'c3';
1453 + use base qw/Test::J Test::I/;
1457 + mro::get_mro_linear('Test::A'),
1459 + '... got the right C3 merge order for Test::A');
1462 + mro::get_mro_linear('Test::B'),
1464 + '... got the right C3 merge order for Test::B');
1467 + mro::get_mro_linear('Test::C'),
1469 + '... got the right C3 merge order for Test::C');
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');
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');
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');
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');
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');
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');
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');
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)
1520 + unless (-d 'blib') {
1521 + chdir 't' if -d 't';
1526 +use Test::More tests => 1;
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)
1534 +The xx:: prefixes are just to be sure these bogus declarations never stomp on real ones
1539 + package xx::DBIx::Class::Core; use mro 'dfs';
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
1551 + package xx::DBIx::Class::InflateColumn; use mro 'dfs';
1552 + our @ISA = qw/ xx::DBIx::Class::Row /;
1554 + package xx::DBIx::Class::Row; use mro 'dfs';
1555 + our @ISA = qw/ xx::DBIx::Class /;
1557 + package xx::DBIx::Class; use mro 'dfs';
1559 + xx::DBIx::Class::Componentised
1560 + xx::Class::Data::Accessor
1563 + package xx::DBIx::Class::Relationship; use mro 'dfs';
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
1573 + package xx::DBIx::Class::Relationship::Helpers; use mro 'dfs';
1575 + xx::DBIx::Class::Relationship::HasMany
1576 + xx::DBIx::Class::Relationship::HasOne
1577 + xx::DBIx::Class::Relationship::BelongsTo
1578 + xx::DBIx::Class::Relationship::ManyToMany
1581 + package xx::DBIx::Class::Relationship::ProxyMethods; use mro 'dfs';
1582 + our @ISA = qw/ xx::DBIx::Class /;
1584 + package xx::DBIx::Class::Relationship::Base; use mro 'dfs';
1585 + our @ISA = qw/ xx::DBIx::Class /;
1587 + package xx::DBIx::Class::PK::Auto; use mro 'dfs';
1588 + our @ISA = qw/ xx::DBIx::Class /;
1590 + package xx::DBIx::Class::PK; use mro 'dfs';
1591 + our @ISA = qw/ xx::DBIx::Class::Row /;
1593 + package xx::DBIx::Class::ResultSourceProxy::Table; use mro 'dfs';
1595 + xx::DBIx::Class::AccessorGroup
1596 + xx::DBIx::Class::ResultSourceProxy
1599 + package xx::DBIx::Class::ResultSourceProxy; use mro 'dfs';
1600 + our @ISA = qw/ xx::DBIx::Class /;
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';
1615 + mro::get_mro_linear('xx::DBIx::Class::Core'),
1617 + xx::DBIx::Class::Core
1618 + xx::DBIx::Class::Serialize::Storable
1619 + xx::DBIx::Class::InflateColumn
1620 + xx::DBIx::Class::Row
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
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)
1651 + unless (-d 'blib') {
1652 + chdir 't' if -d 't';
1660 +# XXX needs translation back to classes, etc
1662 +plan skip_all => "Your system has no SIGALRM" if !exists $SIG{ALRM};
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
1674 +# initial setup, everything sane
1677 + our @ISA = qw/J I/;
1681 + our @ISA = qw/H F/;
1691 + our @ISA = qw/A B C/;
1700 +# A series of 8 abberations that would cause infinite loops,
1701 +# each one undoing the work of the previous
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/ },
1713 +foreach my $loopy (@loopies) {
1715 + local $SIG{ALRM} = sub { die "ALRMTimeout" };
1718 + mro::get_mro_linear_c3('K');
1721 + if(my $err = $@) {
1722 + if($err =~ /ALRMTimeout/) {
1723 + ok(0, "Loop terminated by SIGALRM");
1725 + elsif($err =~ /Recursive inheritance detected/) {
1726 + ok(1, "Graceful exception thrown");
1729 + ok(0, "Unrecognized exception: $err");
1733 + ok(0, "Infinite loop apparently succeeded???");
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)
1746 + unless (-d 'blib') {
1747 + chdir 't' if -d 't';
1752 +use Test::More tests => 7;
1761 + package OverloadingTest;
1765 + use base 'BaseTest';
1766 + use overload '""' => sub { ref(shift) . " stringified" },
1769 + sub new { bless {} => shift }
1771 + package InheritingFromOverloadedTest;
1774 + use base 'OverloadingTest';
1778 +my $x = InheritingFromOverloadedTest->new();
1779 +isa_ok($x, 'InheritingFromOverloadedTest');
1781 +my $y = OverloadingTest->new();
1782 +isa_ok($y, 'OverloadingTest');
1784 +is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing');
1785 +is("$y", 'OverloadingTest stringified', '... got the right value when stringifing');
1787 +ok(($y eq 'OverloadingTest stringified'), '... eq was handled correctly');
1791 + $result = $x eq 'InheritingFromOverloadedTest stringified'
1793 +ok(!$@, '... this should not throw an exception');
1794 +ok($result, '... and we should get the true value');
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)
1806 + unless (-d 'blib') {
1807 + chdir 't' if -d 't';
1812 +use Test::More tests => 11;
1817 +This example is taken from: http://rt.cpan.org/Public/Bug/Display.html?id=20879
1820 +Level 5 8 | A | 9 | B | A | C | (More General)
1832 +Level 3 4 | G | 6 | E | |
1837 +Level 2 3 | H | 5 | F | |
1845 +Level 1 1 | J | 2 | I | |
1850 +Level 0 0 | K | (More Specialized)
1860 + package Test::A; use mro 'dfs';
1862 + package Test::B; use mro 'dfs';
1864 + package Test::C; use mro 'dfs';
1866 + package Test::D; use mro 'dfs';
1867 + use base qw/Test::A Test::B Test::C/;
1869 + package Test::E; use mro 'dfs';
1870 + use base qw/Test::D/;
1872 + package Test::F; use mro 'dfs';
1873 + use base qw/Test::E/;
1875 + package Test::G; use mro 'dfs';
1876 + use base qw/Test::D/;
1878 + package Test::H; use mro 'dfs';
1879 + use base qw/Test::G/;
1881 + package Test::I; use mro 'dfs';
1882 + use base qw/Test::H Test::F/;
1884 + package Test::J; use mro 'dfs';
1885 + use base qw/Test::F/;
1887 + package Test::K; use mro 'dfs';
1888 + use base qw/Test::J Test::I/;
1892 + mro::get_mro_linear('Test::A'),
1894 + '... got the right DFS merge order for Test::A');
1897 + mro::get_mro_linear('Test::B'),
1899 + '... got the right DFS merge order for Test::B');
1902 + mro::get_mro_linear('Test::C'),
1904 + '... got the right DFS merge order for Test::C');
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');
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');
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');
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');
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');
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');
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');
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)
1955 + unless (-d 'blib') {
1956 + chdir 't' if -d 't';
1961 +use Test::More tests => 1;
1966 +This example is take from: http://www.python.org/2.3/mro.html
1968 +"Serious order disagreement" # From Guido
1975 + class Z(A,B): pass #creates Z(A,B) in Python 2.2
1977 + pass # Z(A,B) cannot be created in Python 2.3
1987 + our @ISA = ('X', 'Y');
1990 + our @ISA = ('Y', 'X');
1993 + our @ISA = ('XY', 'YX');
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)
2008 + unless (-d 'blib') {
2009 + chdir 't' if -d 't';
2017 +# XXX needs translation back to classes, etc
2019 +plan skip_all => "Your system has no SIGALRM" if !exists $SIG{ALRM};
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
2031 +# initial setup, everything sane
2034 + our @ISA = qw/J I/;
2038 + our @ISA = qw/H F/;
2048 + our @ISA = qw/A B C/;
2057 +# A series of 8 abberations that would cause infinite loops,
2058 +# each one undoing the work of the previous
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/ },
2070 +foreach my $loopy (@loopies) {
2072 + local $SIG{ALRM} = sub { die "ALRMTimeout" };
2075 + mro::get_mro_linear_dfs('K');
2078 + if(my $err = $@) {
2079 + if($err =~ /ALRMTimeout/) {
2080 + ok(0, "Loop terminated by SIGALRM");
2082 + elsif($err =~ /Recursive inheritance detected/) {
2083 + ok(1, "Graceful exception thrown");
2086 + ok(0, "Unrecognized exception: $err");
2090 + ok(0, "Infinite loop apparently succeeded???");
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)
2103 + unless (-d 'blib') {
2104 + chdir 't' if -d 't';
2109 +use Test::More tests => 4;
2114 +This tests the classic diamond inheritence pattern.
2125 + package Diamond_A;
2126 + sub hello { 'Diamond_A::hello' }
2129 + package Diamond_B;
2130 + use base 'Diamond_A';
2133 + package Diamond_C;
2134 + use base 'Diamond_A';
2136 + sub hello { 'Diamond_C::hello' }
2139 + package Diamond_D;
2140 + use base ('Diamond_B', 'Diamond_C');
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');
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)
2162 + unless (-d 'blib') {
2163 + chdir 't' if -d 't';
2168 +use Test::More tests => 10;
2173 +This example is take from: http://www.python.org/2.3/mro.html
2187 +Level 3 | O | (more general)
2193 +Level 2 3 | D | 4| E | | F | 5 |
2199 +Level 1 1 | B | | C | 2 |
2204 +Level 0 0 | A | (more specialized)
2215 + use base 'Test::O';
2218 + use base 'Test::O';
2221 + sub C_or_E { 'Test::E' }
2225 + use base 'Test::O';
2227 + sub C_or_D { 'Test::D' }
2230 + use base ('Test::D', 'Test::F');
2233 + sub C_or_D { 'Test::C' }
2234 + sub C_or_E { 'Test::C' }
2238 + use base ('Test::D', 'Test::E');
2241 + use base ('Test::B', 'Test::C');
2246 + mro::get_mro_linear('Test::F'),
2247 + [ qw(Test::F Test::O) ],
2248 + '... got the right MRO for Test::F');
2251 + mro::get_mro_linear('Test::E'),
2252 + [ qw(Test::E Test::O) ],
2253 + '... got the right MRO for Test::E');
2256 + mro::get_mro_linear('Test::D'),
2257 + [ qw(Test::D Test::O) ],
2258 + '... got the right MRO for Test::D');
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');
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');
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');
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)
2289 + unless (-d 'blib') {
2290 + chdir 't' if -d 't';
2295 +use Test::More tests => 7;
2304 + package OverloadingTest;
2308 + use base 'BaseTest';
2309 + use overload '""' => sub { ref(shift) . " stringified" },
2312 + sub new { bless {} => shift }
2314 + package InheritingFromOverloadedTest;
2317 + use base 'OverloadingTest';
2321 +my $x = InheritingFromOverloadedTest->new();
2322 +isa_ok($x, 'InheritingFromOverloadedTest');
2324 +my $y = OverloadingTest->new();
2325 +isa_ok($y, 'OverloadingTest');
2327 +is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing');
2328 +is("$y", 'OverloadingTest stringified', '... got the right value when stringifing');
2330 +ok(($y eq 'OverloadingTest stringified'), '... eq was handled correctly');
2334 + $result = $x eq 'InheritingFromOverloadedTest stringified'
2336 +ok(!$@, '... this should not throw an exception');
2337 +ok($result, '... and we should get the true value');
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)
2349 + unless (-d 'blib') {
2350 + chdir 't' if -d 't';
2355 +use Test::More tests => 4;
2360 +This example is take from: http://www.python.org/2.3/mro.html
2362 +"My second example"
2379 +Level 2 2 | E | 4 | D | | F | 5
2385 +Level 1 1 | B | | C | 3
2394 +(<class '__main__.A'>, <class '__main__.B'>, <class '__main__.E'>,
2395 +<class '__main__.C'>, <class '__main__.D'>, <class '__main__.F'>,
2404 + sub O_or_D { 'Test::O' }
2405 + sub O_or_F { 'Test::O' }
2408 + use base 'Test::O';
2411 + sub O_or_F { 'Test::F' }
2414 + use base 'Test::O';
2418 + use base 'Test::O';
2421 + sub O_or_D { 'Test::D' }
2422 + sub C_or_D { 'Test::D' }
2425 + use base ('Test::D', 'Test::F');
2428 + sub C_or_D { 'Test::C' }
2431 + use base ('Test::E', 'Test::D');
2435 + use base ('Test::B', 'Test::C');
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');
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');
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)
2462 + unless (-d 'blib') {
2463 + chdir 't' if -d 't';
2468 +use Test::More tests => 1;
2473 +From the parrot test t/pmc/object-meths.t
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');
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');
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)
2508 + unless (-d 'blib') {
2509 + chdir 't' if -d 't';
2514 +use Test::More tests => 2;
2519 +This tests a strange bug found by Matt S. Trout
2520 +while building DBIx::Class. Thanks Matt!!!!
2531 + package Diamond_A;
2534 + sub foo { 'Diamond_A::foo' }
2537 + package Diamond_B;
2538 + use base 'Diamond_A';
2541 + sub foo { 'Diamond_B::foo => ' . (shift)->SUPER::foo }
2544 + package Diamond_C;
2546 + use base 'Diamond_A';
2550 + package Diamond_D;
2551 + use base ('Diamond_C', 'Diamond_B');
2554 + sub foo { 'Diamond_D::foo => ' . (shift)->SUPER::foo }
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');
2563 + 'Diamond_D::foo => Diamond_B::foo => Diamond_A::foo',
2564 + '... got the right next::method dispatch path');
2566 ==================================================================
2567 --- ext/mro/mro.xs (/local/perl-current) (revision 29701)
2568 +++ ext/mro/mro.xs (/local/perl-c3) (revision 29701)
2572 + * Copyright (c) 2006 Brandon L Black
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.
2579 +#define PERL_NO_GET_CONTEXT
2580 +#include "EXTERN.h"
2584 +MODULE = mro PACKAGE = mro
2587 +get_mro_linear(classname)
2591 + class_stash = gv_stashsv(classname, 0);
2592 + if(!class_stash) croak("No such class: '%"SVf"'!", SVfARG(classname));
2593 + RETVAL = mro_linear(class_stash);
2598 +get_mro_linear_dfs(classname)
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);
2609 +get_mro_linear_c3(classname)
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);
2620 +set_mro_dfs(classname)
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++;
2634 +set_mro_c3(classname)
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++;
2648 +is_mro_dfs(classname)
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);
2661 +is_mro_c3(classname)
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);
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)
2677 +use ExtUtils::MakeMaker;
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';
2688 + elsif ($Config{'cc'} =~ /^bcc/i) {
2689 + $exeout_flag = '-e';
2695 + VERSION_FROM => "mro.pm",
2698 + FILES => "perl$e *$o mro.c *~"
2704 +sub post_constants {
2705 + "\nLIBS = $Config::Config{libs}\n"
2709 + File::Spec->catfile(File::Spec->updir,
2710 + File::Spec->updir, $_[0]);
2713 ==================================================================
2714 --- ext/mro/mro.pm (/local/perl-current) (revision 29701)
2715 +++ ext/mro/mro.pm (/local/perl-c3) (revision 29701)
2719 +# Copyright (c) 2006 Brandon L Black
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.
2728 +our $VERSION = '0.01';
2735 + if($arg eq 'c3') {
2736 + set_mro_c3(scalar(caller));
2738 + elsif($arg eq 'dfs') {
2739 + set_mro_dfs(scalar(caller));
2744 +XSLoader::load 'mro';
2752 +mro - Method Resolution Order
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)
2770 +All of these take a scalar classname as the only argument
2774 +Return an arrayref which is the linearized MRO of the given class.
2775 +Uses whichever MRO is currently in effect for that class.
2777 +=head2 mro_linear_dfs
2779 +Return an arrayref which is the linearized MRO of the given classname.
2780 +Uses the DFS (perl default) MRO algorithm.
2782 +=head2 mro_linear_c3
2784 +Return an arrayref which is the linearized MRO of the given class.
2785 +Uses the C3 MRO algorithm.
2789 +Sets the MRO of the given class to DFS (perl default).
2793 +Sets the MRO of the given class to C3.
2797 +Return boolean indicating whether the given class is using the DFS (Perl default) MRO.
2801 +Return boolean indicating whether the given class is using the C3 MRO.
2805 +Brandon L Black, C<blblack@gmail.com>
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
2852 ==================================================================
2853 --- mro.c (/local/perl-current) (revision 29701)
2854 +++ mro.c (/local/perl-c3) (revision 29701)
2858 + * Copyright (C) 2006 by Larry Wall and others
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.
2866 +=head1 MRO Functions
2868 +These functions are related to the method resolution order of perl classes
2873 +#include "EXTERN.h"
2877 +Perl_mro_meta_init(pTHX_ HV* stash) {
2878 + struct mro_meta* newmeta;
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;
2888 +=for apidoc mro_linear_dfs
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
2899 +Perl_mro_linear_dfs(pTHX_ HV *stash, I32 level) {
2909 + const char* stashname;
2910 + struct mro_meta* meta;
2913 + assert(HvAUX(stash));
2915 + stashname = HvNAME_get(stash);
2918 + "Can't linearize anonymous symbol table");
2921 + Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
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);
2931 + /* decref old cache and forget it */
2932 + SvREFCNT_dec(retval);
2933 + meta->mro_linear_dfs = NULL;
2936 + /* make a new one */
2938 + retval = (AV*)sv_2mortal((SV*)newAV());
2939 + av_push(retval, newSVpv(stashname, 0)); /* add ourselves at the top */
2941 + gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
2942 + av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
2945 + HV* stored = (HV*)sv_2mortal((SV*)newHV());
2946 + svp = AvARRAY(av);
2947 + items = AvFILLp(av) + 1;
2949 + SV* const sv = *svp++;
2950 + HV* const basestash = gv_stashsv(sv, 0);
2953 + if (ckWARN(WARN_MISC))
2954 + Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
2955 + SVfARG(sv), stashname);
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);
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;
2980 +=for apidoc mro_linear_c3
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
2992 +Perl_mro_linear_c3(pTHX_ HV* stash, I32 level) {
2997 + const char* stashname;
2998 + STRLEN stashname_len;
2999 + struct mro_meta* meta;
3002 + assert(HvAUX(stash));
3004 + stashname = HvNAME_get(stash);
3005 + stashname_len = HvNAMELEN_get(stash);
3008 + "Can't linearize anonymous symbol table");
3011 + Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
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);
3021 + /* decref old cache and forget it */
3022 + SvREFCNT_dec(retval);
3023 + meta->mro_linear_c3 = NULL;
3026 + retval = (AV*)sv_2mortal((SV*)newAV());
3027 + av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
3029 + gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
3030 + isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
3032 + if(isa && AvFILLp(isa) >= 0) {
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);
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)));
3048 + av_push(seqs, (SV*)av_make(AvFILLp(isa)+1, AvARRAY(isa)));
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);
3061 + hv_store_ent(tails, seqitem, newSViv(1), 0);
3064 + SV* val = HeVAL(he);
3072 + SV* seqhead = NULL;
3074 + SV* winner = NULL;
3078 + SV** avptr = AvARRAY(seqs);
3079 + items = AvFILLp(seqs)+1;
3082 + seq = (AV*)*avptr++;
3083 + if(AvFILLp(seq) < 0) continue;
3084 + svp = av_fetch(seq, 0, 0);
3088 + if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
3089 + && (val = HeVAL(tail_entry))
3090 + && (SvIVx(val) > 0))
3092 + winner = newSVsv(cand);
3093 + av_push(retval, winner);
3095 + if(!sv_cmp(seqhead, winner)) {
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;
3104 + if(AvFILLp(seq) < 0) continue;
3105 + svp = av_fetch(seq, 0, 0);
3107 + tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
3108 + val = HeVAL(tail_entry);
3114 + Perl_croak(aTHX_ "Inconsistent inheritance hierarchy during C3 merge of class '%s': "
3115 + "merging failed on parent '%"SVf"'", stashname, SVfARG(cand));
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;
3128 +=for apidoc mro_linear
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>.
3138 +Perl_mro_linear(pTHX_ HV *stash)
3140 + struct mro_meta* meta;
3142 + assert(HvAUX(stash));
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);
3150 + Perl_croak(aTHX_ "Internal error: invalid MRO!");
3155 + * Local variables:
3156 + * c-indentation-style: bsd
3157 + * c-basic-offset: 4
3158 + * indent-tabs-mode: t
3161 + * ex: set ts=8 sts=4 sw=4 noet:
3164 ==================================================================
3165 --- hv.c (/local/perl-current) (revision 29701)
3166 +++ hv.c (/local/perl-c3) (revision 29701)
3167 @@ -1726,6 +1726,7 @@
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 */
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);
3183 + iter->xhv_mro_meta = NULL;
3186 /* There are now no allocated pointers in the aux structure. */
3188 SvFLAGS(hv) &= ~SVf_OOK; /* Goodbye, aux structure. */
3189 @@ -1878,6 +1886,7 @@
3190 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
3192 iter->xhv_backreferences = 0;
3193 + iter->xhv_mro_meta = NULL;
3198 ==================================================================
3199 --- hv.h (/local/perl-current) (revision 29701)
3200 +++ hv.h (/local/perl-c3) (revision 29701)
3203 /* Subject to change.
3204 Don't access this directly.
3205 + Use the funcs in mro.c
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? */
3221 +/* Subject to change.
3222 + Don't access this directly.
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;
3233 /* hash structure: */
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. */
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++;
3255 ==================================================================
3256 --- intrpvar.h (/local/perl-current) (revision 29701)
3257 +++ intrpvar.h (/local/perl-c3) (revision 29701)
3259 PERLVARI(Islab_count, U32, 0) /* Size of the array */
3262 +PERLVARI(Iisa_generation,U32,1) /* incr to invalidate @ISA linearization cache */
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()!)
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);
3274 PL_sub_generation = proto_perl->Isub_generation;
3275 + PL_isa_generation = proto_perl->Iisa_generation;
3277 /* funky return mechanisms */
3278 PL_forkprocess = proto_perl->Iforkprocess;
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\
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
3295 Property changes on:
3296 ___________________________________________________________________
3298 +bc823f99-e23a-42ae-8890-ba2193b93f74:/local/perl-current:29691