This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Restore full name of mro::mro_invalidate_all_method_caches.
[perl5.git] / ext / mro / mro.xs
1 #include "EXTERN.h"
2 #include "perl.h"
3 #include "XSUB.h"
4
5 static AV*
6 S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level);
7
8 static const struct mro_alg c3_alg =
9     {S_mro_get_linear_isa_c3, "c3", 2, 0, 0};
10
11 /*
12 =for apidoc mro_get_linear_isa_c3
13
14 Returns the C3 linearization of @ISA
15 the given stash.  The return value is a read-only AV*.
16 C<level> should be 0 (it is used internally in this
17 function's recursion).
18
19 You are responsible for C<SvREFCNT_inc()> on the
20 return value if you plan to store it anywhere
21 semi-permanently (otherwise it might be deleted
22 out from under you the next time the cache is
23 invalidated).
24
25 =cut
26 */
27
28 static AV*
29 S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level)
30 {
31     AV* retval;
32     GV** gvp;
33     GV* gv;
34     AV* isa;
35     const HEK* stashhek;
36     struct mro_meta* meta;
37
38     assert(HvAUX(stash));
39
40     stashhek = HvNAME_HEK(stash);
41     if (!stashhek)
42       Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
43
44     if (level > 100)
45         Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
46                    HEK_KEY(stashhek));
47
48     meta = HvMROMETA(stash);
49
50     /* return cache if valid */
51     if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &c3_alg)))) {
52         return retval;
53     }
54
55     /* not in cache, make a new one */
56
57     gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
58     isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
59
60     /* For a better idea how the rest of this works, see the much clearer
61        pure perl version in Algorithm::C3 0.01:
62        http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
63        (later versions go about it differently than this code for speed reasons)
64     */
65
66     if(isa && AvFILLp(isa) >= 0) {
67         SV** seqs_ptr;
68         I32 seqs_items;
69         HV* const tails = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
70         AV *const seqs = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
71         I32* heads;
72
73         /* This builds @seqs, which is an array of arrays.
74            The members of @seqs are the MROs of
75            the members of @ISA, followed by @ISA itself.
76         */
77         I32 items = AvFILLp(isa) + 1;
78         SV** isa_ptr = AvARRAY(isa);
79         while(items--) {
80             SV* const isa_item = *isa_ptr++;
81             HV* const isa_item_stash = gv_stashsv(isa_item, 0);
82             if(!isa_item_stash) {
83                 /* if no stash, make a temporary fake MRO
84                    containing just itself */
85                 AV* const isa_lin = newAV();
86                 av_push(isa_lin, newSVsv(isa_item));
87                 av_push(seqs, MUTABLE_SV(isa_lin));
88             }
89             else {
90                 /* recursion */
91                 AV* const isa_lin
92                   = S_mro_get_linear_isa_c3(aTHX_ isa_item_stash, level + 1);
93                 av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa_lin)));
94             }
95         }
96         av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa)));
97
98         /* This builds "heads", which as an array of integer array
99            indices, one per seq, which point at the virtual "head"
100            of the seq (initially zero) */
101         Newxz(heads, AvFILLp(seqs)+1, I32);
102
103         /* This builds %tails, which has one key for every class
104            mentioned in the tail of any sequence in @seqs (tail meaning
105            everything after the first class, the "head").  The value
106            is how many times this key appears in the tails of @seqs.
107         */
108         seqs_ptr = AvARRAY(seqs);
109         seqs_items = AvFILLp(seqs) + 1;
110         while(seqs_items--) {
111             AV *const seq = MUTABLE_AV(*seqs_ptr++);
112             I32 seq_items = AvFILLp(seq);
113             if(seq_items > 0) {
114                 SV** seq_ptr = AvARRAY(seq) + 1;
115                 while(seq_items--) {
116                     SV* const seqitem = *seq_ptr++;
117                     /* LVALUE fetch will create a new undefined SV if necessary
118                      */
119                     HE* const he = hv_fetch_ent(tails, seqitem, 1, 0);
120                     if(he) {
121                         SV* const val = HeVAL(he);
122                         /* This will increment undef to 1, which is what we
123                            want for a newly created entry.  */
124                         sv_inc(val);
125                     }
126                 }
127             }
128         }
129
130         /* Initialize retval to build the return value in */
131         retval = newAV();
132         av_push(retval, newSVhek(stashhek)); /* us first */
133
134         /* This loop won't terminate until we either finish building
135            the MRO, or get an exception. */
136         while(1) {
137             SV* cand = NULL;
138             SV* winner = NULL;
139             int s;
140
141             /* "foreach $seq (@seqs)" */
142             SV** const avptr = AvARRAY(seqs);
143             for(s = 0; s <= AvFILLp(seqs); s++) {
144                 SV** svp;
145                 AV * const seq = MUTABLE_AV(avptr[s]);
146                 SV* seqhead;
147                 if(!seq) continue; /* skip empty seqs */
148                 svp = av_fetch(seq, heads[s], 0);
149                 seqhead = *svp; /* seqhead = head of this seq */
150                 if(!winner) {
151                     HE* tail_entry;
152                     SV* val;
153                     /* if we haven't found a winner for this round yet,
154                        and this seqhead is not in tails (or the count
155                        for it in tails has dropped to zero), then this
156                        seqhead is our new winner, and is added to the
157                        final MRO immediately */
158                     cand = seqhead;
159                     if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
160                        && (val = HeVAL(tail_entry))
161                        && (SvIVX(val) > 0))
162                            continue;
163                     winner = newSVsv(cand);
164                     av_push(retval, winner);
165                     /* note however that even when we find a winner,
166                        we continue looping over @seqs to do housekeeping */
167                 }
168                 if(!sv_cmp(seqhead, winner)) {
169                     /* Once we have a winner (including the iteration
170                        where we first found him), inc the head ptr
171                        for any seq which had the winner as a head,
172                        NULL out any seq which is now empty,
173                        and adjust tails for consistency */
174
175                     const int new_head = ++heads[s];
176                     if(new_head > AvFILLp(seq)) {
177                         SvREFCNT_dec(avptr[s]);
178                         avptr[s] = NULL;
179                     }
180                     else {
181                         HE* tail_entry;
182                         SV* val;
183                         /* Because we know this new seqhead used to be
184                            a tail, we can assume it is in tails and has
185                            a positive value, which we need to dec */
186                         svp = av_fetch(seq, new_head, 0);
187                         seqhead = *svp;
188                         tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
189                         val = HeVAL(tail_entry);
190                         sv_dec(val);
191                     }
192                 }
193             }
194
195             /* if we found no candidates, we are done building the MRO.
196                !cand means no seqs have any entries left to check */
197             if(!cand) {
198                 Safefree(heads);
199                 break;
200             }
201
202             /* If we had candidates, but nobody won, then the @ISA
203                hierarchy is not C3-incompatible */
204             if(!winner) {
205                 SV *errmsg;
206                 I32 i;
207
208                 errmsg = newSVpvf("Inconsistent hierarchy during C3 merge of class '%s':\n\t"
209                                   "current merge results [\n", HEK_KEY(stashhek));
210                 for (i = 0; i <= av_len(retval); i++) {
211                     SV **elem = av_fetch(retval, i, 0);
212                     sv_catpvf(errmsg, "\t\t%"SVf",\n", SVfARG(*elem));
213                 }
214                 sv_catpvf(errmsg, "\t]\n\tmerging failed on '%"SVf"'", SVfARG(cand));
215
216                 /* we have to do some cleanup before we croak */
217
218                 SvREFCNT_dec(retval);
219                 Safefree(heads);
220
221                 Perl_croak(aTHX_ "%"SVf, SVfARG(errmsg));
222             }
223         }
224     }
225     else { /* @ISA was undefined or empty */
226         /* build a retval containing only ourselves */
227         retval = newAV();
228         av_push(retval, newSVhek(stashhek));
229     }
230
231     /* we don't want anyone modifying the cache entry but us,
232        and we do so by replacing it completely */
233     SvREADONLY_on(retval);
234
235     return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &c3_alg,
236                                                 MUTABLE_SV(retval)));
237 }
238
239
240 /* These two are static helpers for next::method and friends,
241    and re-implement a bunch of the code from pp_caller() in
242    a more efficient manner for this particular usage.
243 */
244
245 static I32
246 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
247     I32 i;
248     for (i = startingblock; i >= 0; i--) {
249         if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
250     }
251     return i;
252 }
253
254 MODULE = mro            PACKAGE = mro           PREFIX = mro_
255
256 void
257 mro_get_linear_isa(...)
258   PROTOTYPE: $;$
259   PREINIT:
260     AV* RETVAL;
261     HV* class_stash;
262     SV* classname;
263   PPCODE:
264     if(items < 1 || items > 2)
265         croak_xs_usage(cv, "classname [, type ]");
266
267     classname = ST(0);
268     class_stash = gv_stashsv(classname, 0);
269
270     if(!class_stash) {
271         /* No stash exists yet, give them just the classname */
272         AV* isalin = newAV();
273         av_push(isalin, newSVsv(classname));
274         ST(0) = sv_2mortal(newRV_noinc(MUTABLE_SV(isalin)));
275         XSRETURN(1);
276     }
277     else if(items > 1) {
278         const struct mro_alg *const algo = Perl_mro_get_from_name(aTHX_ ST(1));
279         if (!algo)
280             Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", ST(1));
281         RETVAL = algo->resolve(aTHX_ class_stash, 0);
282     }
283     else {
284         RETVAL = mro_get_linear_isa(class_stash);
285     }
286     ST(0) = newRV_inc(MUTABLE_SV(RETVAL));
287     sv_2mortal(ST(0));
288     XSRETURN(1);
289
290 void
291 mro_set_mro(...)
292   PROTOTYPE: $$
293   PREINIT:
294     SV* classname;
295     HV* class_stash;
296     struct mro_meta* meta;
297   PPCODE:
298     if (items != 2)
299         croak_xs_usage(cv, "classname, type");
300
301     classname = ST(0);
302     class_stash = gv_stashsv(classname, GV_ADD);
303     if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
304     meta = HvMROMETA(class_stash);
305
306     Perl_mro_set_mro(aTHX_ meta, ST(1));
307
308     XSRETURN_EMPTY;
309
310 void
311 mro_get_mro(...)
312   PROTOTYPE: $
313   PREINIT:
314     SV* classname;
315     HV* class_stash;
316   PPCODE:
317     if (items != 1)
318         croak_xs_usage(cv, "classname");
319
320     classname = ST(0);
321     class_stash = gv_stashsv(classname, 0);
322
323     if (class_stash) {
324         const struct mro_alg *const meta = HvMROMETA(class_stash)->mro_which;
325         ST(0) = newSVpvn_flags(meta->name, meta->length,
326                                SVs_TEMP
327                                | ((meta->kflags & HVhek_UTF8) ? SVf_UTF8 : 0));
328     } else {
329       ST(0) = newSVpvn_flags("dfs", 3, SVs_TEMP);
330     }
331     XSRETURN(1);
332
333 void
334 mro_get_isarev(...)
335   PROTOTYPE: $
336   PREINIT:
337     SV* classname;
338     HE* he;
339     HV* isarev;
340     AV* ret_array;
341   PPCODE:
342     if (items != 1)
343         croak_xs_usage(cv, "classname");
344
345     classname = ST(0);
346
347     he = hv_fetch_ent(PL_isarev, classname, 0, 0);
348     isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
349
350     ret_array = newAV();
351     if(isarev) {
352         HE* iter;
353         hv_iterinit(isarev);
354         while((iter = hv_iternext(isarev)))
355             av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
356     }
357     mXPUSHs(newRV_noinc(MUTABLE_SV(ret_array)));
358
359     PUTBACK;
360
361 void
362 mro_is_universal(...)
363   PROTOTYPE: $
364   PREINIT:
365     SV* classname;
366     HV* isarev;
367     char* classname_pv;
368     STRLEN classname_len;
369     HE* he;
370   PPCODE:
371     if (items != 1)
372         croak_xs_usage(cv, "classname");
373
374     classname = ST(0);
375
376     classname_pv = SvPV(classname,classname_len);
377
378     he = hv_fetch_ent(PL_isarev, classname, 0, 0);
379     isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
380
381     if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
382         || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
383         XSRETURN_YES;
384     else
385         XSRETURN_NO;
386
387
388 void
389 mro_invalidate_all_method_caches(...)
390   PROTOTYPE: 
391   PPCODE:
392     if (items != 0)
393         croak_xs_usage(cv, "");
394
395     PL_sub_generation++;
396
397     XSRETURN_EMPTY;
398
399 void
400 mro_get_pkg_gen(...)
401   PROTOTYPE: $
402   PREINIT:
403     SV* classname;
404     HV* class_stash;
405   PPCODE:
406     if(items != 1)
407         croak_xs_usage(cv, "classname");
408     
409     classname = ST(0);
410
411     class_stash = gv_stashsv(classname, 0);
412
413     mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0);
414     
415     PUTBACK;
416
417 void
418 mro__nextcan(...)
419   PREINIT:
420     SV* self = ST(0);
421     const I32 throw_nomethod = SvIVX(ST(1));
422     register I32 cxix = cxstack_ix;
423     register const PERL_CONTEXT *ccstack = cxstack;
424     const PERL_SI *top_si = PL_curstackinfo;
425     HV* selfstash;
426     SV *stashname;
427     const char *fq_subname;
428     const char *subname;
429     STRLEN stashname_len;
430     STRLEN subname_len;
431     SV* sv;
432     GV** gvp;
433     AV* linear_av;
434     SV** linear_svp;
435     const char *hvname;
436     I32 entries;
437     struct mro_meta* selfmeta;
438     HV* nmcache;
439     I32 i;
440   PPCODE:
441     PERL_UNUSED_ARG(cv);
442
443     if(sv_isobject(self))
444         selfstash = SvSTASH(SvRV(self));
445     else
446         selfstash = gv_stashsv(self, GV_ADD);
447
448     assert(selfstash);
449
450     hvname = HvNAME_get(selfstash);
451     if (!hvname)
452         Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
453
454     /* This block finds the contextually-enclosing fully-qualified subname,
455        much like looking at (caller($i))[3] until you find a real sub that
456        isn't ANON, etc (also skips over pureperl next::method, etc) */
457     for(i = 0; i < 2; i++) {
458         cxix = __dopoptosub_at(ccstack, cxix);
459         for (;;) {
460             GV* cvgv;
461             STRLEN fq_subname_len;
462
463             /* we may be in a higher stacklevel, so dig down deeper */
464             while (cxix < 0) {
465                 if(top_si->si_type == PERLSI_MAIN)
466                     Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
467                 top_si = top_si->si_prev;
468                 ccstack = top_si->si_cxstack;
469                 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
470             }
471
472             if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
473               || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
474                 cxix = __dopoptosub_at(ccstack, cxix - 1);
475                 continue;
476             }
477
478             {
479                 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
480                 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
481                     if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
482                         cxix = dbcxix;
483                         continue;
484                     }
485                 }
486             }
487
488             cvgv = CvGV(ccstack[cxix].blk_sub.cv);
489
490             if(!isGV(cvgv)) {
491                 cxix = __dopoptosub_at(ccstack, cxix - 1);
492                 continue;
493             }
494
495             /* we found a real sub here */
496             sv = sv_2mortal(newSV(0));
497
498             gv_efullname3(sv, cvgv, NULL);
499
500             fq_subname = SvPVX(sv);
501             fq_subname_len = SvCUR(sv);
502
503             subname = strrchr(fq_subname, ':');
504             if(!subname)
505                 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
506
507             subname++;
508             subname_len = fq_subname_len - (subname - fq_subname);
509             if(subname_len == 8 && strEQ(subname, "__ANON__")) {
510                 cxix = __dopoptosub_at(ccstack, cxix - 1);
511                 continue;
512             }
513             break;
514         }
515         cxix--;
516     }
517
518     /* If we made it to here, we found our context */
519
520     /* Initialize the next::method cache for this stash
521        if necessary */
522     selfmeta = HvMROMETA(selfstash);
523     if(!(nmcache = selfmeta->mro_nextmethod)) {
524         nmcache = selfmeta->mro_nextmethod = newHV();
525     }
526     else { /* Use the cached coderef if it exists */
527         HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
528         if (cache_entry) {
529             SV* const val = HeVAL(cache_entry);
530             if(val == &PL_sv_undef) {
531                 if(throw_nomethod)
532                     Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
533                 XSRETURN_EMPTY;
534             }
535             mXPUSHs(newRV_inc(val));
536             XSRETURN(1);
537         }
538     }
539
540     /* beyond here is just for cache misses, so perf isn't as critical */
541
542     stashname_len = subname - fq_subname - 2;
543     stashname = newSVpvn_flags(fq_subname, stashname_len, SVs_TEMP);
544
545     /* has ourselves at the top of the list */
546     linear_av = S_mro_get_linear_isa_c3(aTHX_ selfstash, 0);
547
548     linear_svp = AvARRAY(linear_av);
549     entries = AvFILLp(linear_av) + 1;
550
551     /* Walk down our MRO, skipping everything up
552        to the contextually enclosing class */
553     while (entries--) {
554         SV * const linear_sv = *linear_svp++;
555         assert(linear_sv);
556         if(sv_eq(linear_sv, stashname))
557             break;
558     }
559
560     /* Now search the remainder of the MRO for the
561        same method name as the contextually enclosing
562        method */
563     if(entries > 0) {
564         while (entries--) {
565             SV * const linear_sv = *linear_svp++;
566             HV* curstash;
567             GV* candidate;
568             CV* cand_cv;
569
570             assert(linear_sv);
571             curstash = gv_stashsv(linear_sv, FALSE);
572
573             if (!curstash) {
574                 if (ckWARN(WARN_SYNTAX))
575                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
576                         (void*)linear_sv, hvname);
577                 continue;
578             }
579
580             assert(curstash);
581
582             gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
583             if (!gvp) continue;
584
585             candidate = *gvp;
586             assert(candidate);
587
588             if (SvTYPE(candidate) != SVt_PVGV)
589                 gv_init(candidate, curstash, subname, subname_len, TRUE);
590
591             /* Notably, we only look for real entries, not method cache
592                entries, because in C3 the method cache of a parent is not
593                valid for the child */
594             if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
595                 SvREFCNT_inc_simple_void_NN(MUTABLE_SV(cand_cv));
596                 (void)hv_store_ent(nmcache, newSVsv(sv), MUTABLE_SV(cand_cv), 0);
597                 mXPUSHs(newRV_inc(MUTABLE_SV(cand_cv)));
598                 XSRETURN(1);
599             }
600         }
601     }
602
603     (void)hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
604     if(throw_nomethod)
605         Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
606     XSRETURN_EMPTY;
607
608 BOOT:
609     Perl_mro_register(aTHX_ &c3_alg);