mro_compat.h

   1 /*
   2 ----------------------------------------------------------------------------
   3
   4     Devel::MRO/mro_compat.h - Provides mro functions for XS modules
   5
   6     Copyright (c) 2008-2009, Goro Fuji (gfx) <gfuji(at)cpan.org>.
   7
   8     This program is free software; you can redistribute it and/or
   9     modify it under the same terms as Perl itself.
  10
  11 ----------------------------------------------------------------------------
  12
  13 Usage:
  14         #include "mro_compat.h"
  15
  16 Functions:
  17         AV*  mro_get_linear_isa(HV* stash)
  18         UV   mro_get_pkg_gen(HV* stash)
  19         void mro_method_changed_in(HV* stash)
  20
  21
  22     See "perldoc Devel::MRO" for details.
  23  */
  24
  25
  26 #ifdef mro_get_linear_isa /* >= 5.10.0 */
  27
  28 /* NOTE:
  29         Because ActivePerl 5.10.0 does not provide Perl_mro_meta_init(),
  30         which is used in HvMROMETA() macro, this mro_get_pkg_gen() refers
  31         to xhv_mro_meta directly.
  32 */
  33 /* compatible with &mro::get_pkg_gen() */
  34 #ifndef mro_get_pkg_gen
  35 #define mro_get_pkg_gen(stash) (HvAUX(stash) ? HvAUX(stash)->xhv_mro_meta->pkg_gen : (U32)0)
  36 #endif
  37
  38 #ifndef mro_get_cache_gen
  39 #define mro_get_cache_gen(stash) (HvAUX(stash) ? HvAUX(stash)->xhv_mro_meta->cache_gen : (U32)0)
  40 #endif
  41
  42 #ifndef mro_get_gen
  43 #define mro_get_gen(stash) (HvAUX(stash) ? (HvAUX(stash)->xhv_mro_meta->pkg_gen + HvAUX(stash)->xhv_mro_meta->cache_gen) : (U32)0)
  44 #endif
  45
  46 #else /* < 5.10.0  */
  47 #define mro_get_linear_isa(stash) my_mro_get_linear_isa(aTHX_ stash)
  48
  49 #define mro_method_changed_in(stash) ((void)stash, (void)PL_sub_generation++)
  50 #define mro_get_pkg_gen(stash)   ((void)stash, PL_sub_generation)
  51 #define mro_get_cache_gen(stash) ((void)stash, (U32)0)
  52 #define mro_get_gen(stash)       ((void)stash, PL_sub_generation)
  53
  54
  55 #if defined(NEED_mro_get_linear_isa) && !defined(NEED_mro_get_linear_isa_GLOBAL)
  56 static AV* my_mro_get_linear_isa(pTHX_ HV* const stash);
  57 static
  58 #else
  59 extern AV* my_mro_get_linear_isa(pTHX_ HV* const stash);
  60 #endif /* !NEED_mro_get_linear_isa */
  61
  62 #if defined(NEED_mro_get_linear_isa) || defined(NEED_mro_get_linear_isa_GLOBAL)
  63 #define ISA_CACHE "::LINEALIZED_ISA_CACHE::"
  64
  65 /* call &mro::get_linear_isa, which is actually &MRO::Compat::__get_linear_isa */
  66 AV*
  67 my_mro_get_linear_isa(pTHX_ HV* const stash){
  68         GV* cachegv;
  69         AV* isa;  /* linearized ISA cache */
  70         SV* gen;  /* package generation */
  71         CV* get_linear_isa;
  72
  73         assert(stash != NULL);
  74         assert(SvTYPE(stash) == SVt_PVHV);
  75
  76         cachegv = *(GV**)hv_fetchs(stash, ISA_CACHE, TRUE);
  77         if(!isGV(cachegv))
  78                 gv_init(cachegv, stash, ISA_CACHE, sizeof(ISA_CACHE)-1, GV_ADD);
  79
  80         isa = GvAVn(cachegv);
  81 #ifdef GvSVn
  82         gen = GvSVn(cachegv);
  83 #else
  84         gen = GvSV(cachegv);
  85 #endif
  86
  87         if(SvIOK(gen) && SvIVX(gen) == (IV)mro_get_pkg_gen(stash)){
  88                 return isa; /* returns the cache if available */
  89         }
  90         else{
  91                 SvREADONLY_off(isa);
  92                 av_clear(isa);
  93         }
  94
  95         get_linear_isa = get_cv("mro::get_linear_isa", FALSE);
  96         if(!get_linear_isa){
  97                 ENTER;
  98                 SAVETMPS;
  99
 100                 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvs("MRO::Compat"), NULL, NULL);
 101                 get_linear_isa = get_cv("mro::get_linear_isa", TRUE);
 102
 103                 FREETMPS;
 104                 LEAVE;
 105         }
 106
 107         {
 108                 SV* avref;
 109                 dSP;
 110
 111                 ENTER;
 112                 SAVETMPS;
 113
 114                 PUSHMARK(SP);
 115                 mXPUSHp(HvNAME(stash), strlen(HvNAME(stash)));
 116                 PUTBACK;
 117
 118                 call_sv((SV*)get_linear_isa, G_SCALAR);
 119
 120                 SPAGAIN;
 121                 avref = POPs;
 122                 PUTBACK;
 123
 124                 if(SvROK(avref) && SvTYPE(SvRV(avref)) == SVt_PVAV){
 125                         AV* const av  = (AV*)SvRV(avref);
 126                         I32 const len = AvFILLp(av) + 1;
 127                         I32 i;
 128
 129                         for(i = 0; i < len; i++){
 130                                 HV* const st = gv_stashsv(AvARRAY(av)[i], FALSE);
 131                                 if(st)
 132                                         av_push(isa, newSVpv(HvNAME(st), 0));
 133                         }
 134                         SvREADONLY_on(isa);
 135                 }
 136                 else{
 137                         Perl_croak(aTHX_ "panic: mro::get_linear_isa() didn't return an ARRAY reference");
 138                 }
 139
 140                 FREETMPS;
 141                 LEAVE;
 142         }
 143
 144         sv_setiv(gen, (IV)mro_get_pkg_gen(stash));
 145         return isa;
 146 }
 147 #undef ISA_CACHE
 148
 149 #endif /* !(defined(NEED_mro_get_linear_isa) || defined(NEED_mro_get_linear_isa_GLOBAL)) */
 150
 151 #endif /* end of the file */