projects / gitmo/Class-C3.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
newer c3.patch
[gitmo/Class-C3.git] / c3.patch
CommitLineData
e74fb2d2 1=== Makefile.micro
2==================================================================
b594e700 3--- Makefile.micro (/local/perl-current) (revision 12474)
4+++ Makefile.micro (/local/perl-c3) (revision 12474)
e74fb2d2 5@@ -9,7 +9,7 @@
6 all: microperl
7
8 O = uav$(_O) udeb$(_O) udoio$(_O) udoop$(_O) udump$(_O) \
9- uglobals$(_O) ugv$(_O) uhv$(_O) \
10+ uglobals$(_O) ugv$(_O) uhv$(_O) umro$(_O)\
11 umg$(_O) uperlmain$(_O) uop$(_O) ureentr$(_O) \
12 upad$(_O) uperl$(_O) uperlio$(_O) uperly$(_O) upp$(_O) \
13 upp_ctl$(_O) upp_hot$(_O) upp_sys$(_O) upp_pack$(_O) upp_sort$(_O) \
14@@ -70,6 +70,9 @@
15 ugv$(_O): $(HE) gv.c
16 $(CC) -c -o $@ $(CFLAGS) gv.c
17
18+umro$(_O): $(HE) mro.c
19+ $(CC) -c -o $@ $(CFLAGS) mro.c
20+
21 uhv$(_O): $(HE) hv.c
22 $(CC) -c -o $@ $(CFLAGS) hv.c
23
f8b2ed66 24=== embed.h
25==================================================================
b594e700 26--- embed.h (/local/perl-current) (revision 12474)
27+++ embed.h (/local/perl-c3) (revision 12474)
e74fb2d2 28@@ -266,6 +266,9 @@
f8b2ed66 29 #define gv_efullname Perl_gv_efullname
30 #define gv_efullname4 Perl_gv_efullname4
31 #define gv_fetchfile Perl_gv_fetchfile
e74fb2d2 32+#define mro_linear Perl_mro_linear
33+#define mro_linear_c3 Perl_mro_linear_c3
34+#define mro_linear_dfs Perl_mro_linear_dfs
f8b2ed66 35 #define gv_fetchmeth Perl_gv_fetchmeth
36 #define gv_fetchmeth_autoload Perl_gv_fetchmeth_autoload
37 #define gv_fetchmethod_autoload Perl_gv_fetchmethod_autoload
e74fb2d2 38@@ -2470,6 +2473,9 @@
f8b2ed66 39 #define gv_efullname(a,b) Perl_gv_efullname(aTHX_ a,b)
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)
e74fb2d2 42+#define mro_linear(a) Perl_mro_linear(aTHX_ a)
78b39005 43+#define mro_linear_c3(a,b) Perl_mro_linear_c3(aTHX_ a,b)
e74fb2d2 44+#define mro_linear_dfs(a,b) Perl_mro_linear_dfs(aTHX_ a,b)
f8b2ed66 45 #define gv_fetchmeth(a,b,c,d) Perl_gv_fetchmeth(aTHX_ a,b,c,d)
46 #define gv_fetchmeth_autoload(a,b,c,d) Perl_gv_fetchmeth_autoload(aTHX_ a,b,c,d)
47 #define gv_fetchmethod_autoload(a,b,c) Perl_gv_fetchmethod_autoload(aTHX_ a,b,c)
48=== embedvar.h
49==================================================================
b594e700 50--- embedvar.h (/local/perl-current) (revision 12474)
51+++ embedvar.h (/local/perl-c3) (revision 12474)
f8b2ed66 52@@ -229,6 +229,7 @@
53 #define PL_incgv (vTHX->Iincgv)
54 #define PL_initav (vTHX->Iinitav)
55 #define PL_inplace (vTHX->Iinplace)
56+#define PL_isa_generation (vTHX->Iisa_generation)
57 #define PL_known_layers (vTHX->Iknown_layers)
58 #define PL_last_lop (vTHX->Ilast_lop)
59 #define PL_last_lop_op (vTHX->Ilast_lop_op)
78b39005 60@@ -526,6 +527,7 @@
f8b2ed66 61 #define PL_Iincgv PL_incgv
62 #define PL_Iinitav PL_initav
63 #define PL_Iinplace PL_inplace
64+#define PL_Iisa_generation PL_isa_generation
65 #define PL_Iknown_layers PL_known_layers
66 #define PL_Ilast_lop PL_last_lop
67 #define PL_Ilast_lop_op PL_last_lop_op
e74fb2d2 68=== pod/perlapi.pod
f8b2ed66 69==================================================================
b594e700 70--- pod/perlapi.pod (/local/perl-current) (revision 12474)
71+++ pod/perlapi.pod (/local/perl-c3) (revision 12474)
e74fb2d2 72@@ -1280,7 +1280,7 @@
73 The argument C<level> should be either 0 or -1. If C<level==0>, as a
74 side-effect creates a glob with the given C<name> in the given C<stash>
75 which in the case of success contains an alias for the subroutine, and sets
76-up caching info for this glob. Similarly for all the searched stashes.
77+up caching info for this glob.
f8b2ed66 78
e74fb2d2 79 This function grants C<"SUPER"> token as a postfix of the stash name. The
80 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
81=== global.sym
82==================================================================
b594e700 83--- global.sym (/local/perl-current) (revision 12474)
84+++ global.sym (/local/perl-c3) (revision 12474)
e74fb2d2 85@@ -133,6 +133,9 @@
86 Perl_gv_efullname3
87 Perl_gv_efullname4
88 Perl_gv_fetchfile
89+Perl_mro_linear
90+Perl_mro_linear_c3
91+Perl_mro_linear_dfs
92 Perl_gv_fetchmeth
93 Perl_gv_fetchmeth_autoload
94 Perl_gv_fetchmethod
95=== universal.c
96==================================================================
b594e700 97--- universal.c (/local/perl-current) (revision 12474)
98+++ universal.c (/local/perl-c3) (revision 12474)
e74fb2d2 99@@ -36,12 +36,10 @@
100 int len, int level)
101 {
102 dVAR;
103- AV* av;
104- GV* gv;
105- GV** gvp;
106- HV* hv = NULL;
107- SV* subgen = NULL;
108+ AV* stash_linear_isa;
f8b2ed66 109+ SV** svp;
e74fb2d2 110 const char *hvname;
f8b2ed66 111+ I32 items;
e74fb2d2 112
113 /* A stash/class can go by many names (ie. User == main::User), so
114 we compare the stash itself just in case */
115@@ -56,75 +54,27 @@
116 if (strEQ(name, "UNIVERSAL"))
117 return TRUE;
118
119- if (level > 100)
120- Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
121- hvname);
122-
123- gvp = (GV**)hv_fetchs(stash, "::ISA::CACHE::", FALSE);
124-
125- if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv))
126- && (hv = GvHV(gv)))
127- {
128- if (SvIV(subgen) == (IV)PL_sub_generation) {
129- SV** const svp = (SV**)hv_fetch(hv, name, len, FALSE);
130- if (svp) {
131- SV * const sv = *svp;
132-#ifdef DEBUGGING
133- if (sv != &PL_sv_undef)
134- DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
135- name, hvname) );
136-#endif
137- return (sv == &PL_sv_yes);
138- }
139+ stash_linear_isa = mro_linear(stash);
140+ svp = AvARRAY(stash_linear_isa) + 1;
141+ items = AvFILLp(stash_linear_isa);
142+ while (items--) {
143+ SV* const basename_sv = *svp++;
144+ HV* basestash = gv_stashsv(basename_sv, FALSE);
145+ if (!basestash) {
146+ if (ckWARN(WARN_MISC))
147+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
148+ "Can't locate package %"SVf" for the parents of %s",
149+ (void*)basename_sv, hvname);
150+ continue;
151 }
152- else {
153- DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
154- hvname) );
155- hv_clear(hv);
156- sv_setiv(subgen, PL_sub_generation);
157+ if(name_stash == basestash
158+ || strEQ(name, SvPVX(basename_sv))) {
159+ SvREFCNT_dec(stash_linear_isa);
160+ return TRUE;
161 }
162 }
163
164- gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
165-
166- if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
167- if (!hv || !subgen) {
168- gvp = (GV**)hv_fetchs(stash, "::ISA::CACHE::", TRUE);
169-
170- gv = *gvp;
171-
172- if (SvTYPE(gv) != SVt_PVGV)
173- gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
174-
175- if (!hv)
176- hv = GvHVn(gv);
177- if (!subgen) {
178- subgen = newSViv(PL_sub_generation);
179- GvSV(gv) = subgen;
180- }
181- }
182- if (hv) {
183- SV** svp = AvARRAY(av);
184- /* NOTE: No support for tied ISA */
185- I32 items = AvFILLp(av) + 1;
186- while (items--) {
187- SV* const sv = *svp++;
188- HV* const basestash = gv_stashsv(sv, FALSE);
189- if (!basestash) {
190- if (ckWARN(WARN_MISC))
191- Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
192- "Can't locate package %"SVf" for @%s::ISA",
193- (void*)sv, hvname);
194- continue;
195- }
196- if (isa_lookup(basestash, name, name_stash, len, level + 1)) {
197- (void)hv_store(hv,name,len,&PL_sv_yes,0);
198- return TRUE;
199- }
200- }
201- (void)hv_store(hv,name,len,&PL_sv_no,0);
202- }
203- }
204+ SvREFCNT_dec(stash_linear_isa);
205 return FALSE;
206 }
207
208=== gv.c
209==================================================================
b594e700 210--- gv.c (/local/perl-current) (revision 12474)
211+++ gv.c (/local/perl-c3) (revision 12474)
e74fb2d2 212@@ -298,7 +298,7 @@
213 The argument C<level> should be either 0 or -1. If C<level==0>, as a
214 side-effect creates a glob with the given C<name> in the given C<stash>
215 which in the case of success contains an alias for the subroutine, and sets
216-up caching info for this glob. Similarly for all the searched stashes.
217+up caching info for this glob.
218
219 This function grants C<"SUPER"> token as a postfix of the stash name. The
220 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
221@@ -309,133 +309,139 @@
222 =cut
223 */
224
225+/* NOTE: No support for tied ISA */
f8b2ed66 226+
e74fb2d2 227 GV *
228 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
229 {
230 dVAR;
231- AV* av;
232- GV* topgv;
233- GV* gv;
234 GV** gvp;
235- CV* cv;
236+ AV* linear_av;
237+ SV** linear_svp;
238+ SV* linear_sv;
239+ HV* curstash;
240+ GV* candidate = NULL;
241+ CV* cand_cv = NULL;
242+ CV* old_cv;
243+ GV* topgv = NULL;
244 const char *hvname;
245- HV* lastchance = NULL;
246+ I32 create = (level >= 0) ? 1 : 0;
247+ I32 items;
248+ STRLEN packlen;
249
250 /* UNIVERSAL methods should be callable without a stash */
251 if (!stash) {
252- level = -1; /* probably appropriate */
253+ create = 0; /* probably appropriate */
254 if(!(stash = gv_stashpvs("UNIVERSAL", FALSE)))
255 return 0;
256 }
257
f8b2ed66 258+ assert(stash);
f8b2ed66 259+
e74fb2d2 260 hvname = HvNAME_get(stash);
261 if (!hvname)
262- Perl_croak(aTHX_
263- "Can't use anonymous symbol table for method lookup");
264+ Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
265
266- if ((level > 100) || (level < -100))
267- Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
268- name, hvname);
269+ assert(hvname);
270+ assert(name);
271+ assert(len >= 0);
272
273 DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) );
274
275- gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
276- if (!gvp)
277- topgv = NULL;
278+ /* check locally for a real method or a cache entry */
279+ gvp = (GV**)hv_fetch(stash, name, len, create);
280+ if(gvp) {
281+ topgv = *gvp;
282+ assert(topgv);
283+ if (SvTYPE(topgv) != SVt_PVGV)
284+ gv_init(topgv, stash, name, len, TRUE);
285+ if ((cand_cv = GvCV(topgv))) {
286+ /* If genuine method or valid cache entry, use it */
287+ if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation) {
288+ return topgv;
f8b2ed66 289+ }
e74fb2d2 290+ else {
291+ /* stale cache entry, junk it and move on */
292+ SvREFCNT_dec(cand_cv);
293+ GvCV(topgv) = cand_cv = NULL;
294+ GvCVGEN(topgv) = 0;
f8b2ed66 295+ }
e74fb2d2 296+ }
297+ else if (GvCVGEN(topgv) == PL_sub_generation) {
298+ /* cache indicates no such method definitively */
299+ return 0;
f8b2ed66 300+ }
301+ }
302+
e74fb2d2 303+ packlen = HvNAMELEN_get(stash);
304+ if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
305+ HV* basestash;
306+ packlen -= 7;
307+ basestash = gv_stashpvn(hvname, packlen, TRUE);
308+ linear_av = mro_linear(basestash);
f8b2ed66 309+ }
310 else {
311- topgv = *gvp;
312- if (SvTYPE(topgv) != SVt_PVGV)
313- gv_init(topgv, stash, name, len, TRUE);
314- if ((cv = GvCV(topgv))) {
315- /* If genuine method or valid cache entry, use it */
316- if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
317- return topgv;
318- /* Stale cached entry: junk it */
319- SvREFCNT_dec(cv);
320- GvCV(topgv) = cv = NULL;
321- GvCVGEN(topgv) = 0;
322- }
323- else if (GvCVGEN(topgv) == PL_sub_generation)
324- return 0; /* cache indicates sub doesn't exist */
e74fb2d2 325+ linear_av = mro_linear(stash); /* has ourselves at the top of the list */
f8b2ed66 326 }
327
328- gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
329- av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : NULL;
e74fb2d2 330+ linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
331+ items = AvFILLp(linear_av); /* no +1, to skip over self */
f8b2ed66 332+ while (items--) {
e74fb2d2 333+ linear_sv = *linear_svp++;
334+ assert(linear_sv);
335+ curstash = gv_stashsv(linear_sv, FALSE);
f8b2ed66 336
337- /* create and re-create @.*::SUPER::ISA on demand */
338- if (!av || !SvMAGIC(av)) {
339- STRLEN packlen = HvNAMELEN_get(stash);
340+ if (!curstash) {
341+ if (ckWARN(WARN_MISC))
342+ Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
e74fb2d2 343+ (void*)linear_sv, hvname);
f8b2ed66 344+ continue;
345+ }
346
347- if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
348- HV* basestash;
349+ assert(curstash);
350
351- packlen -= 7;
352- basestash = gv_stashpvn(hvname, packlen, TRUE);
353- gvp = (GV**)hv_fetchs(basestash, "ISA", FALSE);
354- if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
355- gvp = (GV**)hv_fetchs(stash, "ISA", TRUE);
356- if (!gvp || !(gv = *gvp))
357- Perl_croak(aTHX_ "Cannot create %s::ISA", hvname);
358- if (SvTYPE(gv) != SVt_PVGV)
359- gv_init(gv, stash, "ISA", 3, TRUE);
360- SvREFCNT_dec(GvAV(gv));
361- GvAV(gv) = (AV*)SvREFCNT_inc_simple(av);
362- }
363- }
364+ gvp = (GV**)hv_fetch(curstash, name, len, 0);
365+ if (!gvp) continue;
366+ candidate = *gvp;
367+ assert(candidate);
368+ if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, curstash, name, len, TRUE);
369+ if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
370+ /*
371+ * Found real method, cache method in topgv if:
372+ * 1. topgv has no synonyms (else inheritance crosses wires)
373+ * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
374+ */
375+ if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
376+ if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv);
377+ SvREFCNT_inc_simple_void_NN(cand_cv);
378+ GvCV(topgv) = cand_cv;
379+ GvCVGEN(topgv) = PL_sub_generation;
380+ }
e74fb2d2 381+ SvREFCNT_dec(linear_av);
f8b2ed66 382+ return candidate;
383+ }
384 }
385
386- if (av) {
387- SV** svp = AvARRAY(av);
388- /* NOTE: No support for tied ISA */
389- I32 items = AvFILLp(av) + 1;
390- while (items--) {
391- SV* const sv = *svp++;
392- HV* const basestash = gv_stashsv(sv, FALSE);
393- if (!basestash) {
394- if (ckWARN(WARN_MISC))
395- Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
396- (void*)sv, hvname);
397- continue;
398- }
399- gv = gv_fetchmeth(basestash, name, len,
400- (level >= 0) ? level + 1 : level - 1);
401- if (gv)
402- goto gotcha;
403- }
e74fb2d2 404+ SvREFCNT_dec(linear_av);
f8b2ed66 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", FALSE);
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;
f8b2ed66 459=== perlapi.h
460==================================================================
b594e700 461--- perlapi.h (/local/perl-current) (revision 12474)
462+++ perlapi.h (/local/perl-c3) (revision 12474)
f8b2ed66 463@@ -336,6 +336,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
e74fb2d2 472=== win32/Makefile
473==================================================================
b594e700 474--- win32/Makefile (/local/perl-current) (revision 12474)
475+++ win32/Makefile (/local/perl-c3) (revision 12474)
e74fb2d2 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==================================================================
b594e700 486--- win32/makefile.mk (/local/perl-current) (revision 12474)
487+++ win32/makefile.mk (/local/perl-c3) (revision 12474)
e74fb2d2 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==================================================================
b594e700 498--- win32/Makefile.ce (/local/perl-current) (revision 12474)
499+++ win32/Makefile.ce (/local/perl-c3) (revision 12474)
e74fb2d2 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==================================================================
b594e700 518--- NetWare/Makefile (/local/perl-current) (revision 12474)
519+++ NetWare/Makefile (/local/perl-c3) (revision 12474)
e74fb2d2 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==================================================================
b594e700 530--- vms/descrip_mms.template (/local/perl-current) (revision 12474)
531+++ vms/descrip_mms.template (/local/perl-c3) (revision 12474)
e74fb2d2 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@@ -1594,6 +1594,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==================================================================
b594e700 559--- Makefile.SH (/local/perl-current) (revision 12474)
560+++ Makefile.SH (/local/perl-c3) (revision 12474)
e74fb2d2 561@@ -364,7 +364,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@@ -372,7 +372,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
f8b2ed66 579=== proto.h
580==================================================================
b594e700 581--- proto.h (/local/perl-current) (revision 12474)
582+++ proto.h (/local/perl-c3) (revision 12474)
f8b2ed66 583@@ -624,6 +624,15 @@
584 PERL_CALLCONV GV* Perl_gv_fetchfile(pTHX_ const char* name)
585 __attribute__nonnull__(pTHX_1);
586
e74fb2d2 587+PERL_CALLCONV AV* Perl_mro_linear(pTHX_ HV* stash)
f8b2ed66 588+ __attribute__nonnull__(pTHX_1);
589+
78b39005 590+PERL_CALLCONV AV* Perl_mro_linear_c3(pTHX_ HV* stash, I32 level)
f8b2ed66 591+ __attribute__nonnull__(pTHX_1);
592+
e74fb2d2 593+PERL_CALLCONV AV* Perl_mro_linear_dfs(pTHX_ HV* stash, I32 level)
f8b2ed66 594+ __attribute__nonnull__(pTHX_1);
595+
596 PERL_CALLCONV GV* Perl_gv_fetchmeth(pTHX_ HV* stash, const char* name, STRLEN len, I32 level)
597 __attribute__nonnull__(pTHX_2);
598
599=== ext/B/t/concise-xs.t
600==================================================================
b594e700 601--- ext/B/t/concise-xs.t (/local/perl-current) (revision 12474)
602+++ ext/B/t/concise-xs.t (/local/perl-c3) (revision 12474)
f8b2ed66 603@@ -117,7 +117,7 @@
604 use Carp;
605 use Test::More tests => ( # per-pkg tests (function ct + require_ok)
606 40 + 16 # Data::Dumper, Digest::MD5
607- + 517 + 236 # B::Deparse, B
e74fb2d2 608+ + 517 + 237 # B::Deparse, B
f8b2ed66 609 + 595 + 190 # POSIX, IO::Socket
610 + 3 * ($] > 5.009)
611 + 16 * ($] >= 5.009003)
e74fb2d2 612@@ -157,7 +157,7 @@
f8b2ed66 613 formfeed end_av dowarn diehook defstash curstash
614 cstring comppadlist check_av cchar cast_I32 bootstrap
615 begin_av amagic_generation sub_generation address
616- unitcheck_av
e74fb2d2 617+ unitcheck_av isa_generation
f8b2ed66 618 )],
619 },
620
621=== ext/B/B.xs
622==================================================================
b594e700 623--- ext/B/B.xs (/local/perl-current) (revision 12474)
624+++ ext/B/B.xs (/local/perl-c3) (revision 12474)
f8b2ed66 625@@ -604,6 +604,7 @@
626 #define B_main_start() PL_main_start
627 #define B_amagic_generation() PL_amagic_generation
628 #define B_sub_generation() PL_sub_generation
629+#define B_isa_generation() PL_isa_generation
630 #define B_defstash() PL_defstash
631 #define B_curstash() PL_curstash
632 #define B_dowarn() PL_dowarn
633@@ -656,6 +657,9 @@
634 long
635 B_sub_generation()
636
637+long
638+B_isa_generation()
639+
640 B::AV
641 B_comppadlist()
642
e74fb2d2 643=== ext/B/B.pm
644==================================================================
b594e700 645--- ext/B/B.pm (/local/perl-current) (revision 12474)
646+++ ext/B/B.pm (/local/perl-c3) (revision 12474)
e74fb2d2 647@@ -23,6 +23,7 @@
648 parents comppadlist sv_undef compile_stats timing_info
649 begin_av init_av unitcheck_av check_av end_av regex_padav
650 dowarn defstash curstash warnhook diehook inc_gv
651+ isa_generation
652 );
f8b2ed66 653
e74fb2d2 654 sub OPf_KIDS ();
655=== ext/mro/mro.xs
656==================================================================
b594e700 657--- ext/mro/mro.xs (/local/perl-current) (revision 12474)
658+++ ext/mro/mro.xs (/local/perl-c3) (revision 12474)
e74fb2d2 659@@ -0,0 +1,90 @@
660+/* mro.xs
661+ *
662+ * Copyright (c) 2006 Brandon L Black
663+ *
664+ * You may distribute under the terms of either the GNU General Public
665+ * License or the Artistic License, as specified in the README file.
666+ *
667+ */
668+
669+#define PERL_NO_GET_CONTEXT
670+#include "EXTERN.h"
671+#include "perl.h"
672+#include "XSUB.h"
673+
674+MODULE = mro PACKAGE = mro
675+
f8b2ed66 676+AV*
e74fb2d2 677+get_mro_linear(classname)
f8b2ed66 678+ SV* classname
679+ CODE:
680+ HV* class_stash;
681+ class_stash = gv_stashsv(classname, 0);
e74fb2d2 682+ if(!class_stash) croak("No such class: '%"SVf"'!", classname);
683+ RETVAL = mro_linear(class_stash);
f8b2ed66 684+ OUTPUT:
685+ RETVAL
686+
687+AV*
e74fb2d2 688+get_mro_linear_dfs(classname)
f8b2ed66 689+ SV* classname
690+ CODE:
691+ HV* class_stash;
692+ class_stash = gv_stashsv(classname, 0);
e74fb2d2 693+ if(!class_stash) croak("No such class: '%"SVf"'!", classname);
694+ RETVAL = mro_linear_dfs(class_stash, 0);
f8b2ed66 695+ OUTPUT:
696+ RETVAL
697+
698+AV*
e74fb2d2 699+get_mro_linear_c3(classname)
f8b2ed66 700+ SV* classname
701+ CODE:
702+ HV* class_stash;
703+ class_stash = gv_stashsv(classname, 0);
e74fb2d2 704+ if(!class_stash) croak("No such class: '%"SVf"'!", classname);
78b39005 705+ RETVAL = mro_linear_c3(class_stash, 0);
f8b2ed66 706+ OUTPUT:
707+ RETVAL
708+
709+void
e74fb2d2 710+set_mro_dfs(classname)
f8b2ed66 711+ SV* classname
712+ CODE:
713+ HV* class_stash;
714+ class_stash = gv_stashsv(classname, 1);
e74fb2d2 715+ if(!class_stash) croak("Cannot create class: '%"SVf"'!", classname);
716+ HvAUX(class_stash)->xhv_mro = 0;
f8b2ed66 717+ PL_sub_generation++;
718+
719+void
e74fb2d2 720+set_mro_c3(classname)
f8b2ed66 721+ SV* classname
722+ CODE:
723+ HV* class_stash;
724+ class_stash = gv_stashsv(classname, 1);
e74fb2d2 725+ if(!class_stash) croak("Cannot create class: '%"SVf"'!", classname);
726+ HvAUX(class_stash)->xhv_mro = 1;
f8b2ed66 727+ PL_sub_generation++;
728+
729+bool
e74fb2d2 730+is_mro_dfs(classname)
f8b2ed66 731+ SV* classname
732+ CODE:
733+ HV* class_stash;
734+ class_stash = gv_stashsv(classname, 0);
e74fb2d2 735+ if(!class_stash) croak("No such class: '%"SVf"'!", classname);
736+ RETVAL = (HvAUX(class_stash)->xhv_mro == 0);
f8b2ed66 737+ OUTPUT:
738+ RETVAL
e74fb2d2 739+
740+bool
741+is_mro_c3(classname)
742+ SV* classname
743+ CODE:
744+ HV* class_stash;
745+ class_stash = gv_stashsv(classname, 0);
746+ if(!class_stash) croak("No such class: '%"SVf"'!", classname);
747+ RETVAL = (HvAUX(class_stash)->xhv_mro == 1);
748+ OUTPUT:
749+ RETVAL
750=== ext/mro/Makefile.PL
f8b2ed66 751==================================================================
b594e700 752--- ext/mro/Makefile.PL (/local/perl-current) (revision 12474)
753+++ ext/mro/Makefile.PL (/local/perl-c3) (revision 12474)
e74fb2d2 754@@ -0,0 +1,35 @@
755+use ExtUtils::MakeMaker;
756+use Config;
757+use File::Spec;
758+
759+my $e = $Config{'exe_ext'};
760+my $o = $Config{'obj_ext'};
761+my $exeout_flag = '-o ';
762+if ($^O eq 'MSWin32') {
763+ if ($Config{'cc'} =~ /^cl/i) {
764+ $exeout_flag = '-Fe';
765+ }
766+ elsif ($Config{'cc'} =~ /^bcc/i) {
767+ $exeout_flag = '-e';
768+ }
769+}
770+
771+WriteMakefile(
772+ NAME => "mro",
773+ VERSION_FROM => "mro.pm",
774+ MAN3PODS => {},
775+ clean => {
776+ FILES => "perl$e *$o mro.c *~"
777+ }
778+);
779+
780+package MY;
781+
782+sub post_constants {
783+ "\nLIBS = $Config::Config{libs}\n"
784+}
785+
786+sub upupfile {
787+ File::Spec->catfile(File::Spec->updir,
788+ File::Spec->updir, $_[0]);
789+}
790=== ext/mro/mro.pm
791==================================================================
b594e700 792--- ext/mro/mro.pm (/local/perl-current) (revision 12474)
793+++ ext/mro/mro.pm (/local/perl-c3) (revision 12474)
e74fb2d2 794@@ -0,0 +1,91 @@
795+# mro.pm
796+#
797+# Copyright (c) 2006 Brandon L Black
798+#
799+# You may distribute under the terms of either the GNU General Public
800+# License or the Artistic License, as specified in the README file.
801+#
802+package mro;
803+use strict;
804+use warnings;
805+
806+our $VERSION = '0.01';
807+
808+use XSLoader ();
809+
810+sub import {
811+ my $arg = $_[1];
812+ if($arg) {
813+ if($arg eq 'c3') {
814+ set_mro_c3(scalar(caller));
815+ }
816+ elsif($arg eq 'dfs') {
817+ set_mro_dfs(scalar(caller));
818+ }
819+ }
820+}
821+
822+XSLoader::load 'mro';
823+
824+1;
825+
826+__END__
827+
828+=head1 NAME
829+
830+mro - Method Resolution Order
831+
832+=head1 SYNOPSIS
833+
834+ use mro; # just gain access to mro::* functions
835+ use mro 'c3'; # enable C3 mro for this class
836+ use mro 'dfs'; # enable DFS mro for this class (Perl default)
837+
838+=head1 DESCRIPTION
839+
840+TODO
841+
842+=head1 OVERVIEW
843+
844+TODO
845+
846+=head1 Functions
847+
848+All of these take a scalar classname as the only argument
849+
850+=head2 mro_linear
851+
852+Return an arrayref which is the linearized MRO of the given class.
853+Uses whichever MRO is currently in effect for that class.
854+
855+=head2 mro_linear_dfs
856+
857+Return an arrayref which is the linearized MRO of the given classname.
858+Uses the DFS (perl default) MRO algorithm.
859+
860+=head2 mro_linear_c3
861+
862+Return an arrayref which is the linearized MRO of the given class.
863+Uses the C3 MRO algorithm.
864+
865+=head2 set_mro_dfs
866+
867+Sets the MRO of the given class to DFS (perl default).
868+
869+=head2 set_mro_c3
870+
871+Sets the MRO of the given class to C3.
872+
873+=head2 is_mro_dfs
874+
875+Return boolean indicating whether the given class is using the DFS (Perl default) MRO.
876+
877+=head2 is_mro_c3
878+
879+Return boolean indicating whether the given class is using the C3 MRO.
880+
881+=head1 AUTHOR
882+
883+Brandon L Black, C<blblack@gmail.com>
884+
885+=cut
886=== MANIFEST
887==================================================================
b594e700 888--- MANIFEST (/local/perl-current) (revision 12474)
889+++ MANIFEST (/local/perl-c3) (revision 12474)
e74fb2d2 890@@ -893,6 +893,9 @@
891 ext/MIME/Base64/t/quoted-print.t See whether MIME::QuotedPrint works
892 ext/MIME/Base64/t/unicode.t See whether MIME::Base64 works
893 ext/MIME/Base64/t/warn.t See whether MIME::Base64 works
894+ext/mro/Makefile.PL mro extension
895+ext/mro/mro.xs mro extension
896+ext/mro/mro.pm mro extension
897 ext/NDBM_File/hints/cygwin.pl Hint for NDBM_File for named architecture
898 ext/NDBM_File/hints/dec_osf.pl Hint for NDBM_File for named architecture
899 ext/NDBM_File/hints/dynixptx.pl Hint for NDBM_File for named architecture
900@@ -2792,6 +2795,7 @@
901 mpeix/mpeix_setjmp.c MPE/iX port
902 mpeix/nm MPE/iX port
903 mpeix/relink MPE/iX port
904+mro.c Method Resolution Order code
905 myconfig.SH Prints summary of the current configuration
906 NetWare/bat/Buildtype.bat NetWare port
907 NetWare/bat/SetCodeWar.bat NetWare port
908=== mro.c
909==================================================================
b594e700 910--- mro.c (/local/perl-current) (revision 12474)
911+++ mro.c (/local/perl-c3) (revision 12474)
78b39005 912@@ -0,0 +1,278 @@
e74fb2d2 913+/* mro.c
914+ *
915+ * Copyright (C) 2006 by Larry Wall and others
916+ *
917+ * You may distribute under the terms of either the GNU General Public
918+ * License or the Artistic License, as specified in the README file.
919+ *
920+ */
921+
922+/*
923+=head1 MRO Functions
924+
925+These functions are related to the method resolution order of perl classes
926+
927+=cut
928+*/
929+
930+#include "EXTERN.h"
931+#include "perl.h"
932+
933+/*
934+=for apidoc mro_linear_dfs
935+
936+Returns the Depth-First Search linearization of @ISA
937+the given stash. The return value is a read-only AV*,
938+and is cached based on C<PL_isa_generation>.
939+
940+=cut
941+*/
942+AV*
943+Perl_mro_linear_dfs(pTHX_ HV *stash, I32 level) {
944+ AV* retval;
945+ GV** gvp;
946+ GV* gv;
947+ AV* av;
948+ SV** svp;
949+ I32 items;
950+ AV* subrv;
951+ SV** subrv_p;
952+ I32 subrv_items;
953+ const char* stashname;
954+
955+ assert(stash);
956+ assert(HvAUX(stash));
957+
958+ stashname = HvNAME_get(stash);
959+ if (!stashname)
960+ Perl_croak(aTHX_
961+ "Can't linearize anonymous symbol table");
962+
963+ if (level > 100)
964+ Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
965+ stashname);
966+
967+ /* return the cached linearization if valid */
968+ if((retval = HvAUX(stash)->xhv_mro_linear_dfs)
969+ && HvAUX(stash)->xhv_mro_linear_dfs_gen == PL_isa_generation) {
970+ SvREFCNT_inc_simple_void_NN(retval);
971+ return retval;
972+ }
973+
974+ /* make a new one */
975+
976+ if(retval) SvREFCNT_dec(retval);
977+ HvAUX(stash)->xhv_mro_linear_dfs = retval = newAV();
978+ HvAUX(stash)->xhv_mro_linear_dfs_gen = PL_isa_generation;
979+ av_push(retval, newSVpv(stashname, 0)); /* add ourselves at the top */
980+
981+ gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
982+ av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : NULL;
983+
984+ if(av) {
985+ svp = AvARRAY(av);
986+ items = AvFILLp(av) + 1;
987+ while (items--) {
988+ SV* const sv = *svp++;
989+ HV* const basestash = gv_stashsv(sv, FALSE);
990+ if (!basestash) {
991+ if (ckWARN(WARN_MISC))
992+ Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
993+ (void*)sv, stashname);
994+ continue;
995+ }
996+ subrv = mro_linear_dfs(basestash, level + 1);
997+ subrv_p = AvARRAY(subrv);
998+ subrv_items = AvFILLp(subrv) + 1;
999+ while(subrv_items--) {
1000+ SV* subsv = *subrv_p++;
1001+ SvREFCNT_inc_simple_void_NN(subsv);
1002+ av_push(retval, subsv);
1003+ }
1004+ SvREFCNT_dec(subrv);
1005+ }
1006+ }
1007+
1008+ SvREADONLY_on(retval);
1009+ SvREFCNT_inc_simple_void_NN(retval);
1010+ return retval;
1011+}
1012+
1013+/*
1014+=for apidoc mro_linear_c3
1015+
1016+Returns the C3 linearization of @ISA
1017+the given stash. The return value is a read-only AV*,
1018+and is cached based on C<PL_isa_generation>.
1019+
1020+=cut
1021+*/
78b39005 1022+
e74fb2d2 1023+AV*
78b39005 1024+Perl_mro_linear_c3(pTHX_ HV* root, I32 level) {
e74fb2d2 1025+ AV* retval;
1026+ GV** gvp;
1027+ GV* gv;
78b39005 1028+ AV* isa;
e74fb2d2 1029+ const char* rootname;
78b39005 1030+ STRLEN rootname_len;
e74fb2d2 1031+
1032+ assert(root);
1033+ assert(HvAUX(root));
1034+
1035+ rootname = HvNAME_get(root);
78b39005 1036+ rootname_len = HvNAMELEN_get(root);
e74fb2d2 1037+ if (!rootname)
1038+ Perl_croak(aTHX_
1039+ "Can't linearize anonymous symbol table");
1040+
78b39005 1041+ if (level > 100)
1042+ Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
1043+ rootname);
e74fb2d2 1044+
78b39005 1045+ if((retval = HvAUX(root)->xhv_mro_linear_c3)) {
1046+ if(HvAUX(root)->xhv_mro_linear_c3_gen == PL_isa_generation) {
1047+ /* return cache if valid */
1048+ SvREFCNT_inc_simple_void_NN(retval);
1049+ return retval;
e74fb2d2 1050+ }
78b39005 1051+ /* decref old cache and forget it */
1052+ SvREFCNT_dec(retval);
1053+ HvAUX(root)->xhv_mro_linear_c3 = NULL;
1054+ }
e74fb2d2 1055+
78b39005 1056+ retval = (AV*)sv_2mortal((SV*)newAV());
1057+ av_push(retval, newSVpvn(rootname, rootname_len)); /* root first */
1058+
1059+ gvp = (GV**)hv_fetchs(root, "ISA", FALSE);
1060+ isa = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : NULL;
1061+
1062+ if(isa && AvFILLp(isa) >= 0) {
1063+ SV** seqs_ptr;
1064+ I32 seqs_items;
1065+ HV* tails = (HV*)sv_2mortal((SV*)newHV());
1066+ AV* seqs = (AV*)sv_2mortal((SV*)newAV());
1067+ I32 items = AvFILLp(isa) + 1;
1068+ SV** isa_ptr = AvARRAY(isa);
1069+ while(items--) {
1070+ AV* isa_lin;
1071+ SV* isa_item = *isa_ptr++;
1072+ HV* isa_item_stash = gv_stashsv(isa_item, FALSE);
1073+ if(!isa_item_stash)
1074+ Perl_croak(aTHX_ "Cannot find class %"SVf" for @%s::ISA", isa_item, rootname);
1075+ isa_lin = mro_linear_c3(isa_item_stash, level + 1); /* recursion */
1076+ av_push(seqs, (SV*)av_make(AvFILLp(isa_lin)+1, AvARRAY(isa_lin)));
1077+ SvREFCNT_dec(isa_lin);
1078+ }
1079+ av_push(seqs, (SV*)av_make(AvFILLp(isa)+1, AvARRAY(isa)));
1080+
1081+ seqs_ptr = AvARRAY(seqs);
1082+ seqs_items = AvFILLp(seqs) + 1;
1083+ while(seqs_items--) {
1084+ AV* seq = (AV*)*seqs_ptr++;
1085+ I32 seq_items = AvFILLp(seq);
1086+ if(seq_items > 0) {
1087+ SV** seq_ptr = AvARRAY(seq) + 1;
1088+ while(seq_items--) {
1089+ SV* seqitem = *seq_ptr++;
e74fb2d2 1090+ HE* he = hv_fetch_ent(tails, seqitem, 0, 0);
1091+ if(!he) {
1092+ hv_store_ent(tails, seqitem, newSViv(1), 0);
1093+ }
1094+ else {
1095+ SV* val = HeVAL(he);
1096+ sv_inc(val);
1097+ }
1098+ }
1099+ }
78b39005 1100+ }
e74fb2d2 1101+
78b39005 1102+ while(1) {
1103+ SV* seqhead = NULL;
1104+ SV* cand = NULL;
1105+ SV* winner = NULL;
1106+ SV* val;
1107+ HE* tail_entry;
1108+ AV* seq;
1109+ SV** avptr = AvARRAY(seqs);
1110+ items = AvFILLp(seqs)+1;
1111+ while(items--) {
1112+ SV** svp;
1113+ seq = (AV*)*avptr++;
1114+ if(AvFILLp(seq) < 0) continue;
1115+ svp = av_fetch(seq, 0, 0);
1116+ seqhead = *svp;
1117+ if(!winner) {
1118+ cand = seqhead;
1119+ if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
1120+ && (val = HeVAL(tail_entry))
1121+ && (SvIVx(val) > 0))
1122+ continue;
1123+ winner = newSVsv(cand);
1124+ av_push(retval, winner);
e74fb2d2 1125+ }
78b39005 1126+ if(!sv_cmp(seqhead, winner)) {
e74fb2d2 1127+
78b39005 1128+ /* this is basically shift(@seq) in void context */
1129+ SvREFCNT_dec(*AvARRAY(seq));
1130+ *AvARRAY(seq) = &PL_sv_undef;
1131+ AvARRAY(seq) = AvARRAY(seq) + 1;
1132+ AvMAX(seq)--;
1133+ AvFILLp(seq)--;
e74fb2d2 1134+
e74fb2d2 1135+ if(AvFILLp(seq) < 0) continue;
1136+ svp = av_fetch(seq, 0, 0);
1137+ seqhead = *svp;
78b39005 1138+ tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
1139+ val = HeVAL(tail_entry);
1140+ sv_dec(val);
e74fb2d2 1141+ }
e74fb2d2 1142+ }
78b39005 1143+ if(!cand) break;
1144+ if(!winner)
1145+ Perl_croak(aTHX_ "Inconsistent hierarchy XXX");
e74fb2d2 1146+ }
78b39005 1147+ }
e74fb2d2 1148+
78b39005 1149+ SvREADONLY_on(retval);
1150+ HvAUX(root)->xhv_mro_linear_c3_gen = PL_isa_generation;
1151+ HvAUX(root)->xhv_mro_linear_c3 = retval;
e74fb2d2 1152+
78b39005 1153+ SvREFCNT_inc_simple_void_NN(retval); /* for _aux storage above */
1154+ SvREFCNT_inc_simple_void_NN(retval); /* for return to caller */
1155+ return retval;
e74fb2d2 1156+}
1157+
1158+/*
1159+=for apidoc mro_linear
1160+
1161+Returns either C<mro_linear_c3> or C<mro_linear_dfs> for
1162+the given stash, dependant upon which MRO is in effect
1163+for that stash. The return value is a read-only AV*,
1164+and is cached based on C<PL_isa_generation>.
1165+
1166+=cut
1167+*/
1168+AV*
1169+Perl_mro_linear(pTHX_ HV *stash)
1170+{
1171+ assert(stash);
1172+ assert(HvAUX(stash));
1173+ /* ->xhv_mro values: 0 is dfs, 1 is c3
1174+ this code must be updated if a 3rd one ever exists */
1175+ if(!HvAUX(stash)->xhv_mro) {
1176+ return mro_linear_dfs(stash, 0);
1177+ } else {
78b39005 1178+ return mro_linear_c3(stash, 0);
e74fb2d2 1179+ }
1180+}
1181+
1182+/*
1183+ * Local variables:
1184+ * c-indentation-style: bsd
1185+ * c-basic-offset: 4
1186+ * indent-tabs-mode: t
1187+ * End:
1188+ *
1189+ * ex: set ts=8 sts=4 sw=4 noet:
1190+ */
f8b2ed66 1191=== hv.c
1192==================================================================
b594e700 1193--- hv.c (/local/perl-current) (revision 12474)
1194+++ hv.c (/local/perl-c3) (revision 12474)
f8b2ed66 1195@@ -1895,6 +1895,11 @@
1196 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
1197 iter->xhv_name = 0;
1198 iter->xhv_backreferences = 0;
e74fb2d2 1199+ iter->xhv_mro_linear_dfs = NULL;
1200+ iter->xhv_mro_linear_dfs_gen = 0;
1201+ iter->xhv_mro_linear_c3 = NULL;
1202+ iter->xhv_mro_linear_c3_gen = 0;
1203+ iter->xhv_mro = 0;
f8b2ed66 1204 return iter;
1205 }
1206
1207=== hv.h
1208==================================================================
b594e700 1209--- hv.h (/local/perl-current) (revision 12474)
1210+++ hv.h (/local/perl-c3) (revision 12474)
f8b2ed66 1211@@ -44,6 +44,11 @@
1212 AV *xhv_backreferences; /* back references for weak references */
1213 HE *xhv_eiter; /* current entry of iterator */
1214 I32 xhv_riter; /* current root of iterator */
e74fb2d2 1215+ AV *xhv_mro_linear_dfs; /* cached dfs @ISA linearization */
1216+ AV *xhv_mro_linear_c3; /* cached c3 @ISA linearization */
1217+ U32 xhv_mro_linear_dfs_gen; /* PL_isa_generation for above */
1218+ U32 xhv_mro_linear_c3_gen; /* PL_isa_generation for above */
1219+ U32 xhv_mro; /* which mro is in use? 0 == dfs, 1 == c3, .... */
f8b2ed66 1220 };
1221
1222 /* hash structure: */
f8b2ed66 1223=== mg.c
1224==================================================================
b594e700 1225--- mg.c (/local/perl-current) (revision 12474)
1226+++ mg.c (/local/perl-c3) (revision 12474)
a8513908 1227@@ -1517,6 +1517,7 @@
f8b2ed66 1228 PERL_UNUSED_ARG(sv);
1229 PERL_UNUSED_ARG(mg);
1230 PL_sub_generation++;
1231+ PL_isa_generation++;
1232 return 0;
1233 }
1234
1235=== intrpvar.h
1236==================================================================
b594e700 1237--- intrpvar.h (/local/perl-current) (revision 12474)
1238+++ intrpvar.h (/local/perl-c3) (revision 12474)
78b39005 1239@@ -558,6 +558,7 @@
f8b2ed66 1240 PERLVARI(Iutf8cache, I8, 1) /* Is the utf8 caching code enabled? */
1241 #endif
1242
1243+PERLVARI(Iisa_generation,U32,1) /* incr to invalidate @ISA linearization cache */
1244 /* New variables must be added to the very end, before this comment,
1245 * for binary compatibility (the offsets of the old members must not change).
1246 * (Don't forget to add your variable also to perl_clone()!)
1247=== sv.c
1248==================================================================
b594e700 1249--- sv.c (/local/perl-current) (revision 12474)
1250+++ sv.c (/local/perl-c3) (revision 12474)
e74fb2d2 1251@@ -10985,6 +10985,7 @@
f8b2ed66 1252 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
1253
1254 PL_sub_generation = proto_perl->Isub_generation;
1255+ PL_isa_generation = proto_perl->Iisa_generation;
1256
1257 /* funky return mechanisms */
1258 PL_forkprocess = proto_perl->Iforkprocess;
1259=== embed.fnc
1260==================================================================
b594e700 1261--- embed.fnc (/local/perl-current) (revision 12474)
1262+++ embed.fnc (/local/perl-c3) (revision 12474)
f8b2ed66 1263@@ -278,6 +278,9 @@
1264 Apmb |void |gv_efullname3 |NN SV* sv|NN const GV* gv|NULLOK const char* prefix
1265 Ap |void |gv_efullname4 |NN SV* sv|NN const GV* gv|NULLOK const char* prefix|bool keepmain
1266 Ap |GV* |gv_fetchfile |NN const char* name
e74fb2d2 1267+ApM |AV* |mro_linear |NN HV* stash
78b39005 1268+ApM |AV* |mro_linear_c3 |NN HV* stash|I32 level
e74fb2d2 1269+ApM |AV* |mro_linear_dfs |NN HV* stash|I32 level
f8b2ed66 1270 Apd |GV* |gv_fetchmeth |NULLOK HV* stash|NN const char* name|STRLEN len|I32 level
1271 Apd |GV* |gv_fetchmeth_autoload |NULLOK HV* stash|NN const char* name|STRLEN len|I32 level
1272 Apdmb |GV* |gv_fetchmethod |NULLOK HV* stash|NN const char* name
1273
1274Property changes on:
1275___________________________________________________________________
1276Name: svk:merge
b594e700 1277 +2679d79f-d018-0410-a353-0f906ad2929c:/local/perl-current:12473
f8b2ed66 1278
Unnamed repository; edit this file to name it for gitweb.