vms.c - Remove .DIR; in UNIX mode.
[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 and method 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         }
466     }
467
468     /* Now iterate our MRO (parents), and do a few things:
469          1) instantiate with the "fake" flag if they don't exist
470          2) flag them as universal if we are universal
471          3) Add everything from our isarev to their isarev
472     */
473
474     /* We're starting at the 2nd element, skipping ourselves here */
475     linear_mro = mro_get_linear_isa(stash);
476     svp = AvARRAY(linear_mro) + 1;
477     items = AvFILLp(linear_mro);
478
479     while (items--) {
480         SV* const sv = *svp++;
481         HV* mroisarev;
482
483         HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
484
485         /* That fetch should not fail.  But if it had to create a new SV for
486            us, then we can detect it, because it will not be the correct type.
487            Probably faster and cleaner for us to free that scalar [very little
488            code actually executed to free it] and create a new HV than to
489            copy&paste [SIN!] the code from newHV() to allow us to upgrade the
490            new SV from SVt_NULL.  */
491
492         mroisarev = MUTABLE_HV(HeVAL(he));
493
494         if(SvTYPE(mroisarev) != SVt_PVHV) {
495             SvREFCNT_dec(mroisarev);
496             mroisarev = newHV();
497             HeVAL(he) = MUTABLE_SV(mroisarev);
498         }
499
500         /* This hash only ever contains PL_sv_yes. Storing it over itself is
501            almost as cheap as calling hv_exists, so on aggregate we expect to
502            save time by not making two calls to the common HV code for the
503            case where it doesn't exist.  */
504            
505         (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
506
507         if(isarev) {
508             hv_iterinit(isarev);
509             while((iter = hv_iternext(isarev))) {
510                 I32 revkeylen;
511                 char* const revkey = hv_iterkey(iter, &revkeylen);
512                 (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
513             }
514         }
515     }
516 }
517
518 /*
519 =for apidoc mro_method_changed_in
520
521 Invalidates method caching on any child classes
522 of the given stash, so that they might notice
523 the changes in this one.
524
525 Ideally, all instances of C<PL_sub_generation++> in
526 perl source outside of C<mro.c> should be
527 replaced by calls to this.
528
529 Perl automatically handles most of the common
530 ways a method might be redefined.  However, there
531 are a few ways you could change a method in a stash
532 without the cache code noticing, in which case you
533 need to call this method afterwards:
534
535 1) Directly manipulating the stash HV entries from
536 XS code.
537
538 2) Assigning a reference to a readonly scalar
539 constant into a stash entry in order to create
540 a constant subroutine (like constant.pm
541 does).
542
543 This same method is available from pure perl
544 via, C<mro::method_changed_in(classname)>.
545
546 =cut
547 */
548 void
549 Perl_mro_method_changed_in(pTHX_ HV *stash)
550 {
551     const char * const stashname = HvNAME_get(stash);
552     const STRLEN stashname_len = HvNAMELEN_get(stash);
553
554     SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
555     HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
556
557     PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
558
559     if(!stashname)
560         Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
561
562     /* Inc the package generation, since a local method changed */
563     HvMROMETA(stash)->pkg_gen++;
564
565     /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
566        invalidate all method caches globally */
567     if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
568         || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
569         PL_sub_generation++;
570         return;
571     }
572
573     /* else, invalidate the method caches of all child classes,
574        but not itself */
575     if(isarev) {
576         HE* iter;
577
578         hv_iterinit(isarev);
579         while((iter = hv_iternext(isarev))) {
580             I32 len;
581             const char* const revkey = hv_iterkey(iter, &len);
582             HV* const revstash = gv_stashpvn(revkey, len, 0);
583             struct mro_meta* mrometa;
584
585             if(!revstash) continue;
586             mrometa = HvMROMETA(revstash);
587             mrometa->cache_gen++;
588             if(mrometa->mro_nextmethod)
589                 hv_clear(mrometa->mro_nextmethod);
590         }
591     }
592 }
593
594 void
595 Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
596 {
597     const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name);
598  
599     PERL_ARGS_ASSERT_MRO_SET_MRO;
600
601     if (!which)
602         Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name);
603
604     if(meta->mro_which != which) {
605         if (meta->mro_linear_c3 && !meta->mro_linear_dfs) {
606             /* If we were storing something directly, put it in the hash before
607                we lose it. */
608             Perl_mro_set_private_data(aTHX_ meta, meta->mro_which, 
609                                       MUTABLE_SV(meta->mro_linear_c3));
610         }
611         meta->mro_which = which;
612         /* Scrub our cached pointer to the private data.  */
613         meta->mro_linear_c3 = NULL;
614         /* Only affects local method cache, not
615            even child classes */
616         meta->cache_gen++;
617         if(meta->mro_nextmethod)
618             hv_clear(meta->mro_nextmethod);
619     }
620 }
621
622 #include "XSUB.h"
623
624 XS(XS_mro_get_linear_isa);
625 XS(XS_mro_set_mro);
626 XS(XS_mro_get_mro);
627 XS(XS_mro_get_isarev);
628 XS(XS_mro_is_universal);
629 XS(XS_mro_invalidate_method_caches);
630 XS(XS_mro_method_changed_in);
631 XS(XS_mro_get_pkg_gen);
632
633 void
634 Perl_boot_core_mro(pTHX)
635 {
636     dVAR;
637     static const char file[] = __FILE__;
638
639     Perl_mro_register(aTHX_ &dfs_alg);
640
641     newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
642     newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
643     newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
644     newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
645     newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
646     newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
647     newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
648     newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$");
649 }
650
651 XS(XS_mro_get_linear_isa) {
652     dVAR;
653     dXSARGS;
654     AV* RETVAL;
655     HV* class_stash;
656     SV* classname;
657
658     if(items < 1 || items > 2)
659         croak_xs_usage(cv, "classname [, type ]");
660
661     classname = ST(0);
662     class_stash = gv_stashsv(classname, 0);
663
664     if(!class_stash) {
665         /* No stash exists yet, give them just the classname */
666         AV* isalin = newAV();
667         av_push(isalin, newSVsv(classname));
668         ST(0) = sv_2mortal(newRV_noinc(MUTABLE_SV(isalin)));
669         XSRETURN(1);
670     }
671     else if(items > 1) {
672         const struct mro_alg *const algo = Perl_mro_get_from_name(aTHX_ ST(1));
673         if (!algo)
674             Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", ST(1));
675         RETVAL = algo->resolve(aTHX_ class_stash, 0);
676     }
677     else {
678         RETVAL = mro_get_linear_isa(class_stash);
679     }
680
681     ST(0) = newRV_inc(MUTABLE_SV(RETVAL));
682     sv_2mortal(ST(0));
683     XSRETURN(1);
684 }
685
686 XS(XS_mro_set_mro)
687 {
688     dVAR;
689     dXSARGS;
690     SV* classname;
691     HV* class_stash;
692     struct mro_meta* meta;
693
694     if (items != 2)
695         croak_xs_usage(cv, "classname, type");
696
697     classname = ST(0);
698     class_stash = gv_stashsv(classname, GV_ADD);
699     if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
700     meta = HvMROMETA(class_stash);
701
702     Perl_mro_set_mro(aTHX_ meta, ST(1));
703
704     XSRETURN_EMPTY;
705 }
706
707
708 XS(XS_mro_get_mro)
709 {
710     dVAR;
711     dXSARGS;
712     SV* classname;
713     HV* class_stash;
714
715     if (items != 1)
716         croak_xs_usage(cv, "classname");
717
718     classname = ST(0);
719     class_stash = gv_stashsv(classname, 0);
720
721     ST(0) = sv_2mortal(newSVpv(class_stash
722                                ? HvMROMETA(class_stash)->mro_which->name
723                                : "dfs", 0));
724     XSRETURN(1);
725 }
726
727 XS(XS_mro_get_isarev)
728 {
729     dVAR;
730     dXSARGS;
731     SV* classname;
732     HE* he;
733     HV* isarev;
734     AV* ret_array;
735
736     if (items != 1)
737         croak_xs_usage(cv, "classname");
738
739     classname = ST(0);
740
741     SP -= items;
742
743     
744     he = hv_fetch_ent(PL_isarev, classname, 0, 0);
745     isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
746
747     ret_array = newAV();
748     if(isarev) {
749         HE* iter;
750         hv_iterinit(isarev);
751         while((iter = hv_iternext(isarev)))
752             av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
753     }
754     mXPUSHs(newRV_noinc(MUTABLE_SV(ret_array)));
755
756     PUTBACK;
757     return;
758 }
759
760 XS(XS_mro_is_universal)
761 {
762     dVAR;
763     dXSARGS;
764     SV* classname;
765     HV* isarev;
766     char* classname_pv;
767     STRLEN classname_len;
768     HE* he;
769
770     if (items != 1)
771         croak_xs_usage(cv, "classname");
772
773     classname = ST(0);
774
775     classname_pv = SvPV(classname,classname_len);
776
777     he = hv_fetch_ent(PL_isarev, classname, 0, 0);
778     isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
779
780     if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
781         || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
782         XSRETURN_YES;
783     else
784         XSRETURN_NO;
785 }
786
787 XS(XS_mro_invalidate_method_caches)
788 {
789     dVAR;
790     dXSARGS;
791
792     if (items != 0)
793         croak_xs_usage(cv, "");
794
795     PL_sub_generation++;
796
797     XSRETURN_EMPTY;
798 }
799
800 XS(XS_mro_method_changed_in)
801 {
802     dVAR;
803     dXSARGS;
804     SV* classname;
805     HV* class_stash;
806
807     if(items != 1)
808         croak_xs_usage(cv, "classname");
809     
810     classname = ST(0);
811
812     class_stash = gv_stashsv(classname, 0);
813     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
814
815     mro_method_changed_in(class_stash);
816
817     XSRETURN_EMPTY;
818 }
819
820 XS(XS_mro_get_pkg_gen)
821 {
822     dVAR;
823     dXSARGS;
824     SV* classname;
825     HV* class_stash;
826
827     if(items != 1)
828         croak_xs_usage(cv, "classname");
829     
830     classname = ST(0);
831
832     class_stash = gv_stashsv(classname, 0);
833
834     SP -= items;
835
836     mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0);
837     
838     PUTBACK;
839     return;
840 }
841
842 /*
843  * Local variables:
844  * c-indentation-style: bsd
845  * c-basic-offset: 4
846  * indent-tabs-mode: t
847  * End:
848  *
849  * ex: set ts=8 sts=4 sw=4 noet:
850  */