Linearized the release-manager's guide to make it less of a choose-your-own-adventure...
[perl.git] / mro.c
1 /*    mro.c
2  *
3  *    Copyright (c) 2007 Brandon L Black
4  *    Copyright (c) 2007, 2008 Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  * 'Which order shall we go in?' said Frodo.  'Eldest first, or quickest first?
13  *  You'll be last either way, Master Peregrin.'
14  *
15  *     [p.101 of _The Lord of the Rings_, I/iii: "A Conspiracy Unmasked"]
16  */
17
18 /*
19 =head1 MRO Functions
20
21 These functions are related to the method resolution order of perl classes
22
23 =cut
24 */
25
26 #include "EXTERN.h"
27 #define PERL_IN_MRO_C
28 #include "perl.h"
29
30 static const struct mro_alg dfs_alg =
31     {S_mro_get_linear_isa_dfs, "dfs", 3, 0, 0};
32
33 SV *
34 Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta,
35                           const struct mro_alg *const which)
36 {
37     SV **data;
38     PERL_ARGS_ASSERT_MRO_GET_PRIVATE_DATA;
39
40     data = (SV **)Perl_hv_common(aTHX_ MUTABLE_HV(smeta->mro_linear_dfs), NULL,
41                                 which->name, which->length, which->kflags,
42                                 HV_FETCH_JUST_SV, NULL, which->hash);
43     if (!data)
44         return NULL;
45
46     /* If we've been asked to look up the private data for the current MRO, then
47        cache it.  */
48     if (smeta->mro_which == which)
49         smeta->mro_linear_c3 = MUTABLE_AV(*data);
50
51     return *data;
52 }
53
54 SV *
55 Perl_mro_set_private_data(pTHX_ struct mro_meta *const smeta,
56                           const struct mro_alg *const which, SV *const data)
57 {
58     PERL_ARGS_ASSERT_MRO_SET_PRIVATE_DATA;
59
60     if (!smeta->mro_linear_dfs) {
61         if (smeta->mro_which == which) {
62             /* If all we need to store is the current MRO's data, then don't use
63                memory on a hash with 1 element - store it direct, and signal
64                this by leaving the would-be-hash NULL.  */
65             smeta->mro_linear_c3 = MUTABLE_AV(data);
66             return data;
67         } else {
68             HV *const hv = newHV();
69             /* Start with 2 buckets. It's unlikely we'll need more. */
70             HvMAX(hv) = 1;      
71             smeta->mro_linear_dfs = MUTABLE_AV(hv);
72
73             if (smeta->mro_linear_c3) {
74                 /* If we were storing something directly, put it in the hash
75                    before we lose it. */
76                 Perl_mro_set_private_data(aTHX_ smeta, smeta->mro_which, 
77                                           MUTABLE_SV(smeta->mro_linear_c3));
78             }
79         }
80     }
81
82     /* We get here if we're storing more than one linearisation for this stash,
83        or the linearisation we are storing is not that if its current MRO.  */
84
85     if (smeta->mro_which == which) {
86         /* If we've been asked to store the private data for the current MRO,
87            then cache it.  */
88         smeta->mro_linear_c3 = MUTABLE_AV(data);
89     }
90
91     if (!Perl_hv_common(aTHX_ MUTABLE_HV(smeta->mro_linear_dfs), NULL,
92                         which->name, which->length, which->kflags,
93                         HV_FETCH_ISSTORE, data, which->hash)) {
94         Perl_croak(aTHX_ "panic: hv_store() failed in set_mro_private_data() "
95                    "for '%.*s' %d", (int) which->length, which->name,
96                    which->kflags);
97     }
98
99     return data;
100 }
101
102 const struct mro_alg *
103 Perl_mro_get_from_name(pTHX_ SV *name) {
104     SV **data;
105
106     PERL_ARGS_ASSERT_MRO_GET_FROM_NAME;
107
108     data = (SV **)Perl_hv_common(aTHX_ PL_registered_mros, name, NULL, 0, 0,
109                                 HV_FETCH_JUST_SV, NULL, 0);
110     if (!data)
111         return NULL;
112     assert(SvTYPE(*data) == SVt_IV);
113     assert(SvIOK(*data));
114     return INT2PTR(const struct mro_alg *, SvUVX(*data));
115 }
116
117 void
118 Perl_mro_register(pTHX_ const struct mro_alg *mro) {
119     SV *wrapper = newSVuv(PTR2UV(mro));
120
121     PERL_ARGS_ASSERT_MRO_REGISTER;
122
123     
124     if (!Perl_hv_common(aTHX_ PL_registered_mros, NULL,
125                         mro->name, mro->length, mro->kflags,
126                         HV_FETCH_ISSTORE, wrapper, mro->hash)) {
127         SvREFCNT_dec(wrapper);
128         Perl_croak(aTHX_ "panic: hv_store() failed in mro_register() "
129                    "for '%.*s' %d", (int) mro->length, mro->name, mro->kflags);
130     }
131 }
132
133 struct mro_meta*
134 Perl_mro_meta_init(pTHX_ HV* stash)
135 {
136     struct mro_meta* newmeta;
137
138     PERL_ARGS_ASSERT_MRO_META_INIT;
139     assert(HvAUX(stash));
140     assert(!(HvAUX(stash)->xhv_mro_meta));
141     Newxz(newmeta, 1, struct mro_meta);
142     HvAUX(stash)->xhv_mro_meta = newmeta;
143     newmeta->cache_gen = 1;
144     newmeta->pkg_gen = 1;
145     newmeta->mro_which = &dfs_alg;
146
147     return newmeta;
148 }
149
150 #if defined(USE_ITHREADS)
151
152 /* for sv_dup on new threads */
153 struct mro_meta*
154 Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
155 {
156     struct mro_meta* newmeta;
157
158     PERL_ARGS_ASSERT_MRO_META_DUP;
159
160     Newx(newmeta, 1, struct mro_meta);
161     Copy(smeta, newmeta, 1, struct mro_meta);
162
163     if (newmeta->mro_linear_dfs) {
164         newmeta->mro_linear_dfs
165             = MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_linear_dfs, param)));
166         /* This is just acting as a shortcut pointer, and will be automatically
167            updated on the first get.  */
168         newmeta->mro_linear_c3 = NULL;
169     } else if (newmeta->mro_linear_c3) {
170         /* Only the current MRO is stored, so this owns the data.  */
171         newmeta->mro_linear_c3
172             = MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_linear_c3, param)));
173     }
174
175     if (newmeta->mro_nextmethod)
176         newmeta->mro_nextmethod
177             = MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_nextmethod, param)));
178     if (newmeta->isa)
179         newmeta->isa
180             = MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)newmeta->isa, param)));
181
182     return newmeta;
183 }
184
185 #endif /* USE_ITHREADS */
186
187 /*
188 =for apidoc mro_get_linear_isa_dfs
189
190 Returns the Depth-First Search linearization of @ISA
191 the given stash.  The return value is a read-only AV*.
192 C<level> should be 0 (it is used internally in this
193 function's recursion).
194
195 You are responsible for C<SvREFCNT_inc()> on the
196 return value if you plan to store it anywhere
197 semi-permanently (otherwise it might be deleted
198 out from under you the next time the cache is
199 invalidated).
200
201 =cut
202 */
203 static AV*
204 S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
205 {
206     AV* retval;
207     GV** gvp;
208     GV* gv;
209     AV* av;
210     const HEK* stashhek;
211     struct mro_meta* meta;
212     SV *our_name;
213     HV *stored;
214
215     PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
216     assert(HvAUX(stash));
217
218     stashhek = HvNAME_HEK(stash);
219     if (!stashhek)
220       Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
221
222     if (level > 100)
223         Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
224                    HEK_KEY(stashhek));
225
226     meta = HvMROMETA(stash);
227
228     /* return cache if valid */
229     if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) {
230         return retval;
231     }
232
233     /* not in cache, make a new one */
234
235     retval = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
236     /* We use this later in this function, but don't need a reference to it
237        beyond the end of this function, so reference count is fine.  */
238     our_name = newSVhek(stashhek);
239     av_push(retval, our_name); /* add ourselves at the top */
240
241     /* fetch our @ISA */
242     gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
243     av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
244
245     /* "stored" is used to keep track of all of the classnames we have added to
246        the MRO so far, so we can do a quick exists check and avoid adding
247        duplicate classnames to the MRO as we go.
248        It's then retained to be re-used as a fast lookup for ->isa(), by adding
249        our own name and "UNIVERSAL" to it.  */
250
251     stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
252
253     if(av && AvFILLp(av) >= 0) {
254
255         SV **svp = AvARRAY(av);
256         I32 items = AvFILLp(av) + 1;
257
258         /* foreach(@ISA) */
259         while (items--) {
260             SV* const sv = *svp++;
261             HV* const basestash = gv_stashsv(sv, 0);
262             SV *const *subrv_p;
263             I32 subrv_items;
264
265             if (!basestash) {
266                 /* if no stash exists for this @ISA member,
267                    simply add it to the MRO and move on */
268                 subrv_p = &sv;
269                 subrv_items = 1;
270             }
271             else {
272                 /* otherwise, recurse into ourselves for the MRO
273                    of this @ISA member, and append their MRO to ours.
274                    The recursive call could throw an exception, which
275                    has memory management implications here, hence the use of
276                    the mortal.  */
277                 const AV *const subrv
278                     = mro_get_linear_isa_dfs(basestash, level + 1);
279
280                 subrv_p = AvARRAY(subrv);
281                 subrv_items = AvFILLp(subrv) + 1;
282             }
283             while(subrv_items--) {
284                 SV *const subsv = *subrv_p++;
285                 /* LVALUE fetch will create a new undefined SV if necessary
286                  */
287                 HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
288                 assert(he);
289                 if(HeVAL(he) != &PL_sv_undef) {
290                     /* It was newly created.  Steal it for our new SV, and
291                        replace it in the hash with the "real" thing.  */
292                     SV *const val = HeVAL(he);
293                     HEK *const key = HeKEY_hek(he);
294
295                     HeVAL(he) = &PL_sv_undef;
296                     /* Save copying by making a shared hash key scalar. We
297                        inline this here rather than calling Perl_newSVpvn_share
298                        because we already have the scalar, and we already have
299                        the hash key.  */
300                     assert(SvTYPE(val) == SVt_NULL);
301                     sv_upgrade(val, SVt_PV);
302                     SvPV_set(val, HEK_KEY(share_hek_hek(key)));
303                     SvCUR_set(val, HEK_LEN(key));
304                     SvREADONLY_on(val);
305                     SvFAKE_on(val);
306                     SvPOK_on(val);
307                     if (HEK_UTF8(key))
308                         SvUTF8_on(val);
309
310                     av_push(retval, val);
311                 }
312             }
313         }
314     }
315
316     (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
317     (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
318
319     SvREFCNT_inc_simple_void_NN(stored);
320     SvTEMP_off(stored);
321     SvREADONLY_on(stored);
322
323     meta->isa = stored;
324
325     /* now that we're past the exception dangers, grab our own reference to
326        the AV we're about to use for the result. The reference owned by the
327        mortals' stack will be released soon, so everything will balance.  */
328     SvREFCNT_inc_simple_void_NN(retval);
329     SvTEMP_off(retval);
330
331     /* we don't want anyone modifying the cache entry but us,
332        and we do so by replacing it completely */
333     SvREADONLY_on(retval);
334
335     return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg,
336                                                 MUTABLE_SV(retval)));
337 }
338
339 /*
340 =for apidoc mro_get_linear_isa
341
342 Returns either C<mro_get_linear_isa_c3> or
343 C<mro_get_linear_isa_dfs> for the given stash,
344 dependant upon which MRO is in effect
345 for that stash.  The return value is a
346 read-only AV*.
347
348 You are responsible for C<SvREFCNT_inc()> on the
349 return value if you plan to store it anywhere
350 semi-permanently (otherwise it might be deleted
351 out from under you the next time the cache is
352 invalidated).
353
354 =cut
355 */
356 AV*
357 Perl_mro_get_linear_isa(pTHX_ HV *stash)
358 {
359     struct mro_meta* meta;
360
361     PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;
362     if(!SvOOK(stash))
363         Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
364
365     meta = HvMROMETA(stash);
366     if (!meta->mro_which)
367         Perl_croak(aTHX_ "panic: invalid MRO!");
368     return meta->mro_which->resolve(aTHX_ stash, 0);
369 }
370
371 /*
372 =for apidoc mro_isa_changed_in
373
374 Takes the necessary steps (cache invalidations, mostly)
375 when the @ISA of the given package has changed.  Invoked
376 by the C<setisa> magic, should not need to invoke directly.
377
378 =cut
379 */
380 void
381 Perl_mro_isa_changed_in(pTHX_ HV* stash)
382 {
383     dVAR;
384     HV* isarev;
385     AV* linear_mro;
386     HE* iter;
387     SV** svp;
388     I32 items;
389     bool is_universal;
390     struct mro_meta * meta;
391
392     const char * const stashname = HvNAME_get(stash);
393     const STRLEN stashname_len = HvNAMELEN_get(stash);
394
395     PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
396
397     if(!stashname)
398         Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
399
400     /* wipe out the cached linearizations for this stash */
401     meta = HvMROMETA(stash);
402     if (meta->mro_linear_dfs) {
403         SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_dfs));
404         meta->mro_linear_dfs = NULL;
405         /* This is just acting as a shortcut pointer.  */
406         meta->mro_linear_c3 = NULL;
407     } else if (meta->mro_linear_c3) {
408         /* Only the current MRO is stored, so this owns the data.  */
409         SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_c3));
410         meta->mro_linear_c3 = NULL;
411     }
412     if (meta->isa) {
413         SvREFCNT_dec(meta->isa);
414         meta->isa = NULL;
415     }
416
417     /* Inc the package generation, since our @ISA changed */
418     meta->pkg_gen++;
419
420     /* Wipe the global method cache if this package
421        is UNIVERSAL or one of its parents */
422
423     svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
424     isarev = svp ? MUTABLE_HV(*svp) : NULL;
425
426     if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
427         || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
428         PL_sub_generation++;
429         is_universal = TRUE;
430     }
431     else { /* Wipe the local method cache otherwise */
432         meta->cache_gen++;
433         is_universal = FALSE;
434     }
435
436     /* wipe next::method cache too */
437     if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
438
439     /* Iterate the isarev (classes that are our children),
440        wiping out their linearization, method and isa caches */
441     if(isarev) {
442         hv_iterinit(isarev);
443         while((iter = hv_iternext(isarev))) {
444             I32 len;
445             const char* const revkey = hv_iterkey(iter, &len);
446             HV* revstash = gv_stashpvn(revkey, len, 0);
447             struct mro_meta* revmeta;
448
449             if(!revstash) continue;
450             revmeta = HvMROMETA(revstash);
451             if (revmeta->mro_linear_dfs) {
452                 SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_dfs));
453                 revmeta->mro_linear_dfs = NULL;
454                 /* This is just acting as a shortcut pointer.  */
455                 revmeta->mro_linear_c3 = NULL;
456             } else if (revmeta->mro_linear_c3) {
457                 /* Only the current MRO is stored, so this owns the data.  */
458                 SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_c3));
459                 revmeta->mro_linear_c3 = NULL;
460             }
461             if(!is_universal)
462                 revmeta->cache_gen++;
463             if(revmeta->mro_nextmethod)
464                 hv_clear(revmeta->mro_nextmethod);
465             if (revmeta->isa) {
466                 SvREFCNT_dec(revmeta->isa);
467                 revmeta->isa = NULL;
468             }
469         }
470     }
471
472     /* Now iterate our MRO (parents), and do a few things:
473          1) instantiate with the "fake" flag if they don't exist
474          2) flag them as universal if we are universal
475          3) Add everything from our isarev to their isarev
476     */
477
478     /* We're starting at the 2nd element, skipping ourselves here */
479     linear_mro = mro_get_linear_isa(stash);
480     svp = AvARRAY(linear_mro) + 1;
481     items = AvFILLp(linear_mro);
482
483     while (items--) {
484         SV* const sv = *svp++;
485         HV* mroisarev;
486
487         HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
488
489         /* That fetch should not fail.  But if it had to create a new SV for
490            us, then we can detect it, because it will not be the correct type.
491            Probably faster and cleaner for us to free that scalar [very little
492            code actually executed to free it] and create a new HV than to
493            copy&paste [SIN!] the code from newHV() to allow us to upgrade the
494            new SV from SVt_NULL.  */
495
496         mroisarev = MUTABLE_HV(HeVAL(he));
497
498         if(SvTYPE(mroisarev) != SVt_PVHV) {
499             SvREFCNT_dec(mroisarev);
500             mroisarev = newHV();
501             HeVAL(he) = MUTABLE_SV(mroisarev);
502         }
503
504         /* This hash only ever contains PL_sv_yes. Storing it over itself is
505            almost as cheap as calling hv_exists, so on aggregate we expect to
506            save time by not making two calls to the common HV code for the
507            case where it doesn't exist.  */
508            
509         (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
510
511         if(isarev) {
512             hv_iterinit(isarev);
513             while((iter = hv_iternext(isarev))) {
514                 I32 revkeylen;
515                 char* const revkey = hv_iterkey(iter, &revkeylen);
516                 (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
517             }
518         }
519     }
520 }
521
522 /*
523 =for apidoc mro_method_changed_in
524
525 Invalidates method caching on any child classes
526 of the given stash, so that they might notice
527 the changes in this one.
528
529 Ideally, all instances of C<PL_sub_generation++> in
530 perl source outside of C<mro.c> should be
531 replaced by calls to this.
532
533 Perl automatically handles most of the common
534 ways a method might be redefined.  However, there
535 are a few ways you could change a method in a stash
536 without the cache code noticing, in which case you
537 need to call this method afterwards:
538
539 1) Directly manipulating the stash HV entries from
540 XS code.
541
542 2) Assigning a reference to a readonly scalar
543 constant into a stash entry in order to create
544 a constant subroutine (like constant.pm
545 does).
546
547 This same method is available from pure perl
548 via, C<mro::method_changed_in(classname)>.
549
550 =cut
551 */
552 void
553 Perl_mro_method_changed_in(pTHX_ HV *stash)
554 {
555     const char * const stashname = HvNAME_get(stash);
556     const STRLEN stashname_len = HvNAMELEN_get(stash);
557
558     SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
559     HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
560
561     PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
562
563     if(!stashname)
564         Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
565
566     /* Inc the package generation, since a local method changed */
567     HvMROMETA(stash)->pkg_gen++;
568
569     /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
570        invalidate all method caches globally */
571     if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
572         || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
573         PL_sub_generation++;
574         return;
575     }
576
577     /* else, invalidate the method caches of all child classes,
578        but not itself */
579     if(isarev) {
580         HE* iter;
581
582         hv_iterinit(isarev);
583         while((iter = hv_iternext(isarev))) {
584             I32 len;
585             const char* const revkey = hv_iterkey(iter, &len);
586             HV* const revstash = gv_stashpvn(revkey, len, 0);
587             struct mro_meta* mrometa;
588
589             if(!revstash) continue;
590             mrometa = HvMROMETA(revstash);
591             mrometa->cache_gen++;
592             if(mrometa->mro_nextmethod)
593                 hv_clear(mrometa->mro_nextmethod);
594         }
595     }
596 }
597
598 void
599 Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
600 {
601     const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name);
602  
603     PERL_ARGS_ASSERT_MRO_SET_MRO;
604
605     if (!which)
606         Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name);
607
608     if(meta->mro_which != which) {
609         if (meta->mro_linear_c3 && !meta->mro_linear_dfs) {
610             /* If we were storing something directly, put it in the hash before
611                we lose it. */
612             Perl_mro_set_private_data(aTHX_ meta, meta->mro_which, 
613                                       MUTABLE_SV(meta->mro_linear_c3));
614         }
615         meta->mro_which = which;
616         /* Scrub our cached pointer to the private data.  */
617         meta->mro_linear_c3 = NULL;
618         /* Only affects local method cache, not
619            even child classes */
620         meta->cache_gen++;
621         if(meta->mro_nextmethod)
622             hv_clear(meta->mro_nextmethod);
623     }
624 }
625
626 #include "XSUB.h"
627
628 XS(XS_mro_get_linear_isa);
629 XS(XS_mro_set_mro);
630 XS(XS_mro_get_mro);
631 XS(XS_mro_get_isarev);
632 XS(XS_mro_is_universal);
633 XS(XS_mro_invalidate_method_caches);
634 XS(XS_mro_method_changed_in);
635 XS(XS_mro_get_pkg_gen);
636
637 void
638 Perl_boot_core_mro(pTHX)
639 {
640     dVAR;
641     static const char file[] = __FILE__;
642
643     Perl_mro_register(aTHX_ &dfs_alg);
644
645     newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
646     newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
647     newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
648     newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
649     newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
650     newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
651     newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
652     newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$");
653 }
654
655 XS(XS_mro_get_linear_isa) {
656     dVAR;
657     dXSARGS;
658     AV* RETVAL;
659     HV* class_stash;
660     SV* classname;
661
662     if(items < 1 || items > 2)
663         croak_xs_usage(cv, "classname [, type ]");
664
665     classname = ST(0);
666     class_stash = gv_stashsv(classname, 0);
667
668     if(!class_stash) {
669         /* No stash exists yet, give them just the classname */
670         AV* isalin = newAV();
671         av_push(isalin, newSVsv(classname));
672         ST(0) = sv_2mortal(newRV_noinc(MUTABLE_SV(isalin)));
673         XSRETURN(1);
674     }
675     else if(items > 1) {
676         const struct mro_alg *const algo = Perl_mro_get_from_name(aTHX_ ST(1));
677         if (!algo)
678             Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", ST(1));
679         RETVAL = algo->resolve(aTHX_ class_stash, 0);
680     }
681     else {
682         RETVAL = mro_get_linear_isa(class_stash);
683     }
684
685     ST(0) = newRV_inc(MUTABLE_SV(RETVAL));
686     sv_2mortal(ST(0));
687     XSRETURN(1);
688 }
689
690 XS(XS_mro_set_mro)
691 {
692     dVAR;
693     dXSARGS;
694     SV* classname;
695     HV* class_stash;
696     struct mro_meta* meta;
697
698     if (items != 2)
699         croak_xs_usage(cv, "classname, type");
700
701     classname = ST(0);
702     class_stash = gv_stashsv(classname, GV_ADD);
703     if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
704     meta = HvMROMETA(class_stash);
705
706     Perl_mro_set_mro(aTHX_ meta, ST(1));
707
708     XSRETURN_EMPTY;
709 }
710
711
712 XS(XS_mro_get_mro)
713 {
714     dVAR;
715     dXSARGS;
716     SV* classname;
717     HV* class_stash;
718
719     if (items != 1)
720         croak_xs_usage(cv, "classname");
721
722     classname = ST(0);
723     class_stash = gv_stashsv(classname, 0);
724
725     ST(0) = sv_2mortal(newSVpv(class_stash
726                                ? HvMROMETA(class_stash)->mro_which->name
727                                : "dfs", 0));
728     XSRETURN(1);
729 }
730
731 XS(XS_mro_get_isarev)
732 {
733     dVAR;
734     dXSARGS;
735     SV* classname;
736     HE* he;
737     HV* isarev;
738     AV* ret_array;
739
740     if (items != 1)
741         croak_xs_usage(cv, "classname");
742
743     classname = ST(0);
744
745     SP -= items;
746
747     
748     he = hv_fetch_ent(PL_isarev, classname, 0, 0);
749     isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
750
751     ret_array = newAV();
752     if(isarev) {
753         HE* iter;
754         hv_iterinit(isarev);
755         while((iter = hv_iternext(isarev)))
756             av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
757     }
758     mXPUSHs(newRV_noinc(MUTABLE_SV(ret_array)));
759
760     PUTBACK;
761     return;
762 }
763
764 XS(XS_mro_is_universal)
765 {
766     dVAR;
767     dXSARGS;
768     SV* classname;
769     HV* isarev;
770     char* classname_pv;
771     STRLEN classname_len;
772     HE* he;
773
774     if (items != 1)
775         croak_xs_usage(cv, "classname");
776
777     classname = ST(0);
778
779     classname_pv = SvPV(classname,classname_len);
780
781     he = hv_fetch_ent(PL_isarev, classname, 0, 0);
782     isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
783
784     if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
785         || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
786         XSRETURN_YES;
787     else
788         XSRETURN_NO;
789 }
790
791 XS(XS_mro_invalidate_method_caches)
792 {
793     dVAR;
794     dXSARGS;
795
796     if (items != 0)
797         croak_xs_usage(cv, "");
798
799     PL_sub_generation++;
800
801     XSRETURN_EMPTY;
802 }
803
804 XS(XS_mro_method_changed_in)
805 {
806     dVAR;
807     dXSARGS;
808     SV* classname;
809     HV* class_stash;
810
811     if(items != 1)
812         croak_xs_usage(cv, "classname");
813     
814     classname = ST(0);
815
816     class_stash = gv_stashsv(classname, 0);
817     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
818
819     mro_method_changed_in(class_stash);
820
821     XSRETURN_EMPTY;
822 }
823
824 XS(XS_mro_get_pkg_gen)
825 {
826     dVAR;
827     dXSARGS;
828     SV* classname;
829     HV* class_stash;
830
831     if(items != 1)
832         croak_xs_usage(cv, "classname");
833     
834     classname = ST(0);
835
836     class_stash = gv_stashsv(classname, 0);
837
838     SP -= items;
839
840     mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0);
841     
842     PUTBACK;
843     return;
844 }
845
846 /*
847  * Local variables:
848  * c-indentation-style: bsd
849  * c-basic-offset: 4
850  * indent-tabs-mode: t
851  * End:
852  *
853  * ex: set ts=8 sts=4 sw=4 noet:
854  */