xs-src/MouseUtil.xs

   1 #include "mouse.h"
   2
   3 #define MY_CXT_KEY "Mouse::Util::_guts" XS_VERSION
   4 typedef struct {
   5     HV* metas;
   6 } my_cxt_t;
   7 START_MY_CXT
   8
   9 #define ISA_CACHE "::LINEALIZED_ISA_CACHE::"
  10
  11 #ifdef no_mro_get_linear_isa
  12 AV*
  13 mouse_mro_get_linear_isa(pTHX_ HV* const stash){
  14     GV* const cachegv = *(GV**)hv_fetchs(stash, ISA_CACHE, TRUE);
  15     AV* isa;
  16     SV* gen;
  17     CV* get_linear_isa;
  18
  19     if(!isGV(cachegv))
  20         gv_init(cachegv, stash, ISA_CACHE, sizeof(ISA_CACHE)-1, TRUE);
  21
  22     isa = GvAVn(cachegv);
  23     gen = GvSVn(cachegv);
  24
  25
  26     if(SvIOK(gen) && SvIVX(gen) == (IV)mro_get_pkg_gen(stash)){
  27         return isa; /* returns the cache if available */
  28     }
  29     else{
  30         SvREFCNT_dec(isa);
  31         GvAV(cachegv) = isa = newAV();
  32     }
  33
  34     get_linear_isa = get_cv("Mouse::Util::get_linear_isa", TRUE);
  35
  36     {
  37         SV* avref;
  38         dSP;
  39
  40         ENTER;
  41         SAVETMPS;
  42
  43         PUSHMARK(SP);
  44         mXPUSHp(HvNAME_get(stash), HvNAMELEN_get(stash));
  45         PUTBACK;
  46
  47         call_sv((SV*)get_linear_isa, G_SCALAR);
  48
  49         SPAGAIN;
  50         avref = POPs;
  51         PUTBACK;
  52
  53         if(IsArrayRef(avref)){
  54             AV* const av  = (AV*)SvRV(avref);
  55             I32 const len = AvFILLp(av) + 1;
  56             I32 i;
  57
  58             for(i = 0; i < len; i++){
  59                 HV* const stash = gv_stashsv(AvARRAY(av)[i], FALSE);
  60                 if(stash)
  61                     av_push(isa, newSVpv(HvNAME(stash), 0));
  62             }
  63             SvREADONLY_on(isa);
  64         }
  65         else{
  66             Perl_croak(aTHX_ "Mouse:Util::get_linear_isa() didn't return an ARRAY reference");
  67         }
  68
  69         FREETMPS;
  70         LEAVE;
  71     }
  72
  73     sv_setiv(gen, (IV)mro_get_pkg_gen(stash));
  74     return isa;
  75 }
  76 #endif /* !no_mor_get_linear_isa */
  77
  78 #ifdef DEBUGGING
  79 SV**
  80 mouse_av_at_safe(pTHX_ AV* const av, I32 const ix){
  81     assert(av);
  82     assert(SvTYPE(av) == SVt_PVAV);
  83     assert(AvMAX(av) >= ix);
  84     return &AvARRAY(av)[ix];
  85 }
  86 #endif
  87
  88 void
  89 mouse_throw_error(SV* const metaobject, SV* const data /* not used */, const char* const fmt, ...){
  90     dTHX;
  91     va_list args;
  92     SV* message;
  93
  94     assert(metaobject);
  95     assert(fmt);
  96
  97     va_start(args, fmt);
  98     message = vnewSVpvf(fmt, &args);
  99     va_end(args);
 100
 101     {
 102         dSP;
 103         PUSHMARK(SP);
 104         EXTEND(SP, 6);
 105
 106         PUSHs(metaobject);
 107         mPUSHs(message);
 108
 109         if(data){ /* extra arg, might be useful for debugging */
 110             mPUSHs(newSVpvs("data"));
 111             PUSHs(data);
 112             mPUSHs(newSVpvs("depth"));
 113             mPUSHi(-1);
 114         }
 115
 116         PUTBACK;
 117
 118         call_method("throw_error", G_VOID);
 119         croak("throw_error() did not throw the error (%"SVf")", message);
 120     }
 121 }
 122
 123 bool
 124 mouse_is_class_loaded(pTHX_ SV * const klass){
 125     HV *stash;
 126     GV** gvp;
 127     HE* he;
 128
 129     if (!(SvPOKp(klass) && SvCUR(klass))) { /* XXX: SvPOK does not work with magical scalars */
 130         return FALSE;
 131     }
 132
 133     stash = gv_stashsv(klass, FALSE);
 134     if (!stash) {
 135         return FALSE;
 136     }
 137
 138     if (( gvp = (GV**)hv_fetchs(stash, "VERSION", FALSE) )) {
 139         if(isGV(*gvp) && GvSV(*gvp) && SvOK(GvSV(*gvp))){
 140             return TRUE;
 141         }
 142     }
 143
 144     if (( gvp = (GV**)hv_fetchs(stash, "ISA", FALSE) )) {
 145         if(isGV(*gvp) && GvAV(*gvp) && av_len(GvAV(*gvp)) != -1){
 146             return TRUE;
 147         }
 148     }
 149
 150     hv_iterinit(stash);
 151     while(( he = hv_iternext(stash) )){
 152         GV* const gv = (GV*)HeVAL(he);
 153
 154         if(isGV(gv)){
 155             if(GvCVu(gv)){
 156                 return TRUE;
 157             }
 158         }
 159         else if(SvOK(gv)){
 160             return TRUE;
 161         }
 162     }
 163     return FALSE;
 164 }
 165
 166
 167 SV*
 168 mouse_call0 (pTHX_ SV* const self, SV* const method) {
 169     dSP;
 170     SV *ret;
 171
 172     PUSHMARK(SP);
 173     XPUSHs(self);
 174     PUTBACK;
 175
 176     call_sv(method, G_SCALAR | G_METHOD);
 177
 178     SPAGAIN;
 179     ret = POPs;
 180     PUTBACK;
 181
 182     return ret;
 183 }
 184
 185 SV*
 186 mouse_call1 (pTHX_ SV* const self, SV* const method, SV* const arg1) {
 187     dSP;
 188     SV *ret;
 189
 190     PUSHMARK(SP);
 191     EXTEND(SP, 2);
 192     PUSHs(self);
 193     PUSHs(arg1);
 194     PUTBACK;
 195
 196     call_sv(method, G_SCALAR | G_METHOD);
 197
 198     SPAGAIN;
 199     ret = POPs;
 200     PUTBACK;
 201
 202     return ret;
 203 }
 204
 205 int
 206 mouse_predicate_call(pTHX_ SV* const self, SV* const method) {
 207     return sv_true( mcall0(self, method) );
 208 }
 209
 210 SV*
 211 mouse_get_metaclass(pTHX_ SV* metaclass_name){
 212     dMY_CXT;
 213     HE* he;
 214
 215     assert(metaclass_name);
 216     assert(MY_CXT.metas);
 217
 218     if(IsObject(metaclass_name)){
 219         HV* const stash = SvSTASH(SvRV(metaclass_name));
 220
 221         metaclass_name = newSVpvn_share(HvNAME_get(stash), HvNAMELEN_get(stash), 0U);
 222         sv_2mortal(metaclass_name);
 223     }
 224
 225     he = hv_fetch_ent(MY_CXT.metas, metaclass_name, FALSE, 0U);
 226
 227     return he ? HeVAL(he) : &PL_sv_undef;
 228 }
 229
 230 MAGIC*
 231 mouse_mg_find(pTHX_ SV* const sv, const MGVTBL* const vtbl, I32 const flags){
 232     MAGIC* mg;
 233
 234     assert(sv != NULL);
 235     for(mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic){
 236         if(mg->mg_virtual == vtbl){
 237             return mg;
 238         }
 239     }
 240
 241     if(flags & MOUSEf_DIE_ON_FAIL){
 242         croak("mouse_mg_find: no MAGIC found for %"SVf, sv_2mortal(newRV_inc(sv)));
 243     }
 244     return NULL;
 245 }
 246
 247 GV*
 248 mouse_stash_fetch(pTHX_ HV* const stash, const char* const name, I32 const namelen, I32 const create) {
 249     GV** const gvp = (GV**)hv_fetch(stash, name, namelen, create);
 250
 251     if(gvp){
 252         if(!isGV(*gvp)){
 253             gv_init(*gvp, stash, name, namelen, GV_ADDMULTI);
 254         }
 255         return *gvp;
 256     }
 257     else{
 258         return NULL;
 259     }
 260 }
 261
 262 void
 263 mouse_install_sub(pTHX_ GV* const gv, SV* const code_ref) {
 264     CV* cv;
 265
 266     assert(gv != NULL);
 267     assert(code_ref != NULL);
 268     assert(isGV(gv));
 269     assert(IsCodeRef(code_ref));
 270
 271     if(GvCVu(gv)){ /* delete *slot{gv} to work around "redefine" warning */
 272         SvREFCNT_dec(GvCV(gv));
 273         GvCV(gv) = NULL;
 274     }
 275     sv_setsv_mg((SV*)gv, code_ref); /* *gv = $code_ref */
 276
 277     /* name the CODE ref if it's anonymous */
 278     cv = (CV*)SvRV(code_ref);
 279     if(CvANON(cv)
 280         && CvGV(cv) /* a cv under construction has no gv */ ){
 281         HV* dbsub;
 282
 283         /* update %DB::sub to make NYTProf happy */
 284         if((PL_perldb & (PERLDBf_SUBLINE|PERLDB_NAMEANON))
 285             && PL_DBsub && (dbsub = GvHV(PL_DBsub))
 286         ){
 287             /* see Perl_newATTRSUB() in op.c */
 288             SV* const subname = sv_newmortal();
 289             HE* orig;
 290
 291             gv_efullname3(subname, CvGV(cv), NULL);
 292             orig = hv_fetch_ent(dbsub, subname, FALSE, 0U);
 293             if(orig){
 294                 gv_efullname3(subname, gv, NULL);
 295                 (void)hv_store_ent(dbsub, subname, HeVAL(orig), 0U);
 296                 SvREFCNT_inc_simple_void_NN(HeVAL(orig));
 297             }
 298         }
 299
 300         CvGV(cv) = gv;
 301         CvANON_off(cv);
 302     }
 303 }
 304
 305 MODULE = Mouse::Util  PACKAGE = Mouse::Util
 306
 307 PROTOTYPES:   DISABLE
 308 VERSIONCHECK: DISABLE
 309
 310 BOOT:
 311 {
 312     MY_CXT_INIT;
 313     MY_CXT.metas = NULL;
 314 }
 315
 316 void
 317 __register_metaclass_storage(HV* metas, bool cloning)
 318 CODE:
 319 {
 320     if(cloning){
 321         MY_CXT_CLONE;
 322         MY_CXT.metas = NULL;
 323     }
 324     {
 325         dMY_CXT;
 326         if(MY_CXT.metas) croak("Cannot set metaclass storage more than once");
 327         MY_CXT.metas = metas;
 328         SvREFCNT_inc_simple_void_NN(metas);
 329     }
 330 }
 331
 332 bool
 333 is_valid_class_name(SV* sv)
 334 CODE:
 335 {
 336     SvGETMAGIC(sv);
 337     if(SvPOKp(sv) && SvCUR(sv) > 0){
 338         UV i;
 339         RETVAL = TRUE;
 340         for(i = 0; i < SvCUR(sv); i++){
 341             char const c = SvPVX(sv)[i];
 342             if(!(isALNUM(c) || c == ':')){
 343                 RETVAL = FALSE;
 344                 break;
 345             }
 346         }
 347     }
 348     else{
 349         RETVAL = SvNIOKp(sv) ? TRUE : FALSE;
 350     }
 351 }
 352 OUTPUT:
 353     RETVAL
 354
 355 bool
 356 is_class_loaded(SV* sv)
 357
 358 void
 359 get_code_info(CV* code)
 360 PREINIT:
 361     GV* gv;
 362     HV* stash;
 363 PPCODE:
 364     if((gv = CvGV(code)) && isGV(gv) && (stash = GvSTASH(gv))){
 365         EXTEND(SP, 2);
 366         mPUSHs(newSVpvn_share(HvNAME_get(stash), HvNAMELEN_get(stash), 0U));
 367         mPUSHs(newSVpvn_share(GvNAME_get(gv), GvNAMELEN_get(gv), 0U));
 368     }
 369
 370 SV*
 371 get_code_package(CV* code)
 372 PREINIT:
 373     HV* stash;
 374 CODE:
 375     if(CvGV(code) && isGV(CvGV(code)) && (stash = GvSTASH(CvGV(code)))){
 376         RETVAL = newSVpvn_share(HvNAME_get(stash), HvNAMELEN_get(stash), 0U);
 377     }
 378     else{
 379         RETVAL = &PL_sv_no;
 380     }
 381 OUTPUT:
 382     RETVAL
 383
 384 CV*
 385 get_code_ref(SV* package, SV* name)
 386 CODE:
 387 {
 388     HV* stash;
 389     STRLEN name_len;
 390     const char* name_pv;
 391     GV* gv;
 392
 393     if(!SvOK(package)){
 394         croak("You must define %s", "a package name");
 395     }
 396     if(!SvOK(name)){
 397         croak("You must define %s", "a subroutine name");
 398     }
 399
 400     stash = gv_stashsv(package, FALSE);
 401     if(!stash){
 402         XSRETURN_UNDEF;
 403     }
 404
 405     name_pv = SvPV_const(name, name_len);
 406     gv = stash_fetch(stash, name_pv, name_len, FALSE);
 407     RETVAL = gv ? GvCVu(gv) : NULL;
 408
 409     if(!RETVAL){
 410         XSRETURN_UNDEF;
 411     }
 412 }
 413 OUTPUT:
 414     RETVAL
 415
 416 void
 417 generate_isa_predicate_for(SV* arg, SV* predicate_name = NULL)
 418 ALIAS:
 419     generate_isa_predicate_for = 0
 420     generate_can_predicate_for = 1
 421 PPCODE:
 422 {
 423     const char* name_pv = NULL;
 424     CV* xsub;
 425
 426     SvGETMAGIC(arg);
 427
 428     if(!SvOK(arg)){
 429         croak("You must define %s", ix == 0 ? "a class name" : "method names");
 430     }
 431
 432     if(predicate_name){
 433         SvGETMAGIC(predicate_name);
 434         if(!SvOK(predicate_name)){
 435             croak("You must define %s", "a predicate name");
 436         }
 437         name_pv = SvPV_nolen_const(predicate_name);
 438     }
 439
 440     if(ix == 0){
 441         xsub = mouse_generate_isa_predicate_for(aTHX_ arg, name_pv);
 442     }
 443     else{
 444         xsub = mouse_generate_can_predicate_for(aTHX_ arg, name_pv);
 445     }
 446
 447     if(predicate_name == NULL){ /* anonymous predicate */
 448         mXPUSHs( newRV_inc((SV*)xsub) );
 449     }
 450 }
 451
 452 # This xsub will redefine &Mouse::Util::install_subroutines()
 453 void
 454 install_subroutines(SV* into, ...)
 455 CODE:
 456 {
 457     HV* stash;
 458     I32 i;
 459
 460     SvGETMAGIC(into);
 461     if(!SvOK(into)){
 462         croak("You must define %s", "a package name");
 463     }
 464     stash = gv_stashsv(into, TRUE);
 465
 466     if( ((items-1) % 2) != 0 ){
 467         croak_xs_usage(cv, "into, name => coderef [, other_name, other_coderef ...]");
 468     }
 469
 470     for(i = 1; i < items; i += 2) {
 471         SV* const name = ST(i);
 472         SV* const code = ST(i+1);
 473         STRLEN len;
 474         const char* pv;
 475         GV* gv;
 476
 477         SvGETMAGIC(name);
 478         if(!SvOK(name)){
 479             croak("You must define %s", "a subroutine name");
 480         }
 481         SvGETMAGIC(code);
 482         if(!IsCodeRef(code)){
 483             croak("You must define %s", "a CODE reference");
 484         }
 485
 486         pv = SvPV_const(name, len);
 487         gv = stash_fetch(stash, pv, len, TRUE);
 488
 489         mouse_install_sub(aTHX_ gv, code);
 490     }
 491 }