http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
(later versions go about it differently than this code for speed reasons)
*/
+
if(isa && AvFILLp(isa) >= 0) {
SV** seqs_ptr;
I32 seqs_items;
HV* tails = (HV*)sv_2mortal((SV*)newHV());
AV* seqs = (AV*)sv_2mortal((SV*)newAV());
+ I32* heads;
+
+ /* This builds @seqs, which is an array of arrays.
+ The members of @seqs are the MROs of
+ the members of @ISA, followed by @ISA itself.
+ */
I32 items = AvFILLp(isa) + 1;
SV** isa_ptr = AvARRAY(isa);
while(items--) {
SV* isa_item = *isa_ptr++;
HV* isa_item_stash = gv_stashsv(isa_item, 0);
if(!isa_item_stash) {
- isa_lin = newAV();
+ /* if no stash, make a temporary fake MRO
+ containing just itself */
+ isa_lin = (AV*)sv_2mortal((SV*)newAV());
av_push(isa_lin, newSVsv(isa_item));
}
else {
isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1); /* recursion */
}
- av_push(seqs, (SV*)av_make(AvFILLp(isa_lin)+1, AvARRAY(isa_lin)));
+ av_push(seqs, (SV*)isa_lin);
}
- av_push(seqs, (SV*)av_make(AvFILLp(isa)+1, AvARRAY(isa)));
-
+ av_push(seqs, (SV*)isa);
+
+ /* This builds "heads", which as an array of integer array
+ indices, one per seq, which point at the virtual "head"
+ of the seq (initially zero) */
+ Newxz(heads, AvFILLp(seqs)+1, I32);
+
+ /* This builds %tails, which has one key for every class
+ mentioned in the tail of any sequence in @seqs (tail meaning
+ everything after the first class, the "head"). The value
+ is how many times this key appears in the tails of @seqs.
+ */
seqs_ptr = AvARRAY(seqs);
seqs_items = AvFILLp(seqs) + 1;
while(seqs_items--) {
}
}
+ /* This loop won't terminate until we either finish building
+ the MRO, or get an exception. */
while(1) {
SV* seqhead = NULL;
SV* cand = NULL;
SV* val;
HE* tail_entry;
AV* seq;
+ int s;
+
+ /* "foreach $seq (@seqs)" */
SV** avptr = AvARRAY(seqs);
- items = AvFILLp(seqs)+1;
- while(items--) {
+ for(s = 0; s <= AvFILLp(seqs); s++) {
SV** svp;
- seq = (AV*)*avptr++;
- if(AvFILLp(seq) < 0) continue;
- svp = av_fetch(seq, 0, 0);
- seqhead = *svp;
+ seq = (AV*)(avptr[s]);
+ if(!seq) continue; /* skip empty seqs */
+ svp = av_fetch(seq, heads[s], 0);
+ seqhead = *svp; /* seqhead = head of this seq */
if(!winner) {
+ /* if we haven't found a winner for this round yet,
+ and this seqhead is not in tails (or the count
+ for it in tails has dropped to zero), then this
+ seqhead is our new winner, and is added to the
+ final MRO immediately */
cand = seqhead;
if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
&& (val = HeVAL(tail_entry))
continue;
winner = newSVsv(cand);
av_push(retval, winner);
+ /* note however that even when we find a winner,
+ we continue looping over @seqs to do housekeeping */
}
if(!sv_cmp(seqhead, winner)) {
-
- /* this is basically shift(@seq) in void context */
- SvREFCNT_dec(*AvARRAY(seq));
- *AvARRAY(seq) = &PL_sv_undef;
- AvARRAY(seq) = AvARRAY(seq) + 1;
- AvMAX(seq)--;
- AvFILLp(seq)--;
-
- if(AvFILLp(seq) < 0) continue;
- svp = av_fetch(seq, 0, 0);
- seqhead = *svp;
- tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
- val = HeVAL(tail_entry);
- sv_dec(val);
+ /* Once we have a winner (including the iteration
+ where we first found him), inc the head ptr
+ for any seq which had the winner as a head,
+ NULL out any seq which is now empty,
+ and adjust tails for consistency */
+
+ int new_head = ++heads[s];
+ if(new_head > AvFILLp(seq)) {
+ avptr[s] = NULL;
+ }
+ else {
+ /* Because we know this new seqhead used to be
+ a tail, we can assume it is in tails and has
+ a positive value, which we need to dec */
+ svp = av_fetch(seq, new_head, 0);
+ seqhead = *svp;
+ tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
+ val = HeVAL(tail_entry);
+ sv_dec(val);
+ }
}
}
- if(!cand) break;
+
+ /* if we found no candidates, we are done building the MRO.
+ !cand means no seqs have any entries left to check */
+ if(!cand) {
+ Safefree(heads);
+ break;
+ }
+
+ /* If we had candidates, but nobody won, then the @ISA
+ hierarchy is not C3-incompatible */
if(!winner) {
+ /* we have to do some cleanup before we croak */
+ SV** svp = AvARRAY(seqs);
+ items = AvFILLp(seqs) + 1;
+ while (items--)
+ *svp++ = NULL;
+
SvREFCNT_dec(retval);
+ Safefree(heads);
+
Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
"merging failed on parent '%"SVf"'", stashname, SVfARG(cand));
}
} else {
Perl_croak(aTHX_ "panic: invalid MRO!");
}
+ return NULL; /* NOT REACHED */
}
/*
while((iter = hv_iternext(isarev))) {
SV* revkey = hv_iterkeysv(iter);
HV* revstash = gv_stashsv(revkey, 0);
- struct mro_meta* revmeta = HvMROMETA(revstash);
+ struct mro_meta* revmeta;
+
+ if(!revstash) continue;
+ revmeta = HvMROMETA(revstash);
SvREFCNT_dec((SV*)revmeta->mro_linear_dfs);
SvREFCNT_dec((SV*)revmeta->mro_linear_c3);
revmeta->mro_linear_dfs = NULL;
/*
=for apidoc mro_method_changed_in
-Like C<mro_isa_changed_in>, but invalidates method
-caching on any child classes of the given stash, so
-that they might notice the changes in this one.
+Invalidates method caching on any child classes
+of the given stash, so that they might notice
+the changes in this one.
Ideally, all instances of C<PL_sub_generation++> in
-the perl source should be replaced by calls to this.
-Some already are, but some are more difficult to
-replace.
+the perl source outside of C<mro.c> should be
+replaced by calls to this. This conversion is
+nearly complete.
Perl has always had problems with method caches
getting out of sync when one directly manipulates
while((iter = hv_iternext(isarev))) {
SV* revkey = hv_iterkeysv(iter);
HV* revstash = gv_stashsv(revkey, 0);
- struct mro_meta* mrometa = HvMROMETA(revstash);
+ struct mro_meta* mrometa;
+
+ if(!revstash) continue;
+ mrometa = HvMROMETA(revstash);
mrometa->sub_generation++;
if(mrometa->mro_nextmethod)
hv_clear(mrometa->mro_nextmethod);
https://perl5.git.perl.org / perl5.git / blobdiff