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