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 static I32
 124 S_dopoptosub(pTHX_ I32 const startingblock)
 125 {
 126     const PERL_CONTEXT* const cxstk = cxstack;
 127     I32 i;
 128     for (i = startingblock; i >= 0; i--) {
 129         const PERL_CONTEXT* const cx = &cxstk[i];
 130
 131         switch (CxTYPE(cx)) {
 132         case CXt_EVAL:
 133         case CXt_SUB:
 134         case CXt_FORMAT:
 135             return i;
 136         }
 137     }
 138     return i;
 139 }
 140
 141 /* workaround Perl-RT #69939 */
 142 I32
 143 mouse_call_sv_safe(pTHX_ SV* const sv, I32 const flags) {
 144     const PERL_CONTEXT* const cx = &cxstack[S_dopoptosub(aTHX_ cxstack_ix)];
 145     assert( (flags & G_EVAL) == 0 );
 146
 147     //warn("cx_type=0x%02x PL_eval=0x%02x (%"SVf")", (unsigned)cx->cx_type, (unsigned)PL_in_eval, sv);
 148     if(cx->cx_type & CXp_TRYBLOCK) {
 149         return Perl_call_sv(aTHX_ sv, flags);
 150     }
 151     else {
 152         I32 count;
 153         ENTER;
 154         /* Don't do SAVETMPS */
 155
 156         SAVESPTR(ERRSV);
 157         ERRSV = sv_newmortal();
 158
 159         count = Perl_call_sv(aTHX_ sv, flags | G_EVAL);
 160
 161         if(sv_true(ERRSV)){
 162             SV* const err = sv_mortalcopy(ERRSV);
 163             LEAVE;
 164             sv_setsv(ERRSV, err);
 165             croak(NULL); /* rethrow */
 166         }
 167
 168         LEAVE;
 169
 170         return count;
 171     }
 172 }
 173
 174 void
 175 mouse_must_defined(pTHX_ SV* const value, const char* const name) {
 176     assert(value);
 177     assert(name);
 178
 179     SvGETMAGIC(value);
 180     if(!SvOK(value)){
 181         croak("You must define %s", name);
 182     }
 183 }
 184
 185 void
 186 mouse_must_ref(pTHX_ SV* const value, const char* const name, svtype const t) {
 187     assert(value);
 188     assert(name);
 189
 190     SvGETMAGIC(value);
 191     if(!(SvROK(value) && (t == SVt_NULL || SvTYPE(SvRV(value)) == t))) {
 192         croak("You must pass %s, not %s",
 193             name, SvOK(value) ? SvPV_nolen(value) : "undef");
 194     }
 195 }
 196
 197
 198 bool
 199 mouse_is_class_loaded(pTHX_ SV * const klass){
 200     HV *stash;
 201     GV** gvp;
 202     HE* he;
 203
 204     if (!(SvPOKp(klass) && SvCUR(klass))) { /* XXX: SvPOK does not work with magical scalars */
 205         return FALSE;
 206     }
 207
 208     stash = gv_stashsv(klass, FALSE);
 209     if (!stash) {
 210         return FALSE;
 211     }
 212
 213     if (( gvp = (GV**)hv_fetchs(stash, "VERSION", FALSE) )) {
 214         if(isGV(*gvp) && GvSV(*gvp) && SvOK(GvSV(*gvp))){
 215             return TRUE;
 216         }
 217     }
 218
 219     if (( gvp = (GV**)hv_fetchs(stash, "ISA", FALSE) )) {
 220         if(isGV(*gvp) && GvAV(*gvp) && av_len(GvAV(*gvp)) != -1){
 221             return TRUE;
 222         }
 223     }
 224
 225     hv_iterinit(stash);
 226     while(( he = hv_iternext(stash) )){
 227         GV* const gv = (GV*)HeVAL(he);
 228
 229         if(isGV(gv)){
 230             if(GvCVu(gv)){ /* is GV and has CV */
 231                 hv_iterinit(stash); /* reset */
 232                 return TRUE;
 233             }
 234         }
 235         else if(SvOK(gv)){ /* is a stub or constant */
 236             hv_iterinit(stash); /* reset */
 237             return TRUE;
 238         }
 239     }
 240     return FALSE;
 241 }
 242
 243
 244 SV*
 245 mouse_call0 (pTHX_ SV* const self, SV* const method) {
 246     dSP;
 247     SV *ret;
 248
 249     PUSHMARK(SP);
 250     XPUSHs(self);
 251     PUTBACK;
 252
 253     call_sv_safe(method, G_SCALAR | G_METHOD);
 254
 255     SPAGAIN;
 256     ret = POPs;
 257     PUTBACK;
 258
 259     return ret;
 260 }
 261
 262 SV*
 263 mouse_call1 (pTHX_ SV* const self, SV* const method, SV* const arg1) {
 264     dSP;
 265     SV *ret;
 266
 267     PUSHMARK(SP);
 268     EXTEND(SP, 2);
 269     PUSHs(self);
 270     PUSHs(arg1);
 271     PUTBACK;
 272
 273     call_sv_safe(method, G_SCALAR | G_METHOD);
 274
 275     SPAGAIN;
 276     ret = POPs;
 277     PUTBACK;
 278
 279     return ret;
 280 }
 281
 282 int
 283 mouse_predicate_call(pTHX_ SV* const self, SV* const method) {
 284     return sv_true( mcall0(self, method) );
 285 }
 286
 287 SV*
 288 mouse_get_metaclass(pTHX_ SV* metaclass_name){
 289     dMY_CXT;
 290     HE* he;
 291
 292     assert(metaclass_name);
 293     assert(MY_CXT.metas);
 294
 295     if(IsObject(metaclass_name)){
 296         HV* const stash = SvSTASH(SvRV(metaclass_name));
 297
 298         metaclass_name = newSVpvn_share(HvNAME_get(stash), HvNAMELEN_get(stash), 0U);
 299         sv_2mortal(metaclass_name);
 300     }
 301
 302     he = hv_fetch_ent(MY_CXT.metas, metaclass_name, FALSE, 0U);
 303
 304     return he ? HeVAL(he) : &PL_sv_undef;
 305 }
 306
 307 MAGIC*
 308 mouse_mg_find(pTHX_ SV* const sv, const MGVTBL* const vtbl, I32 const flags){
 309     MAGIC* mg;
 310
 311     assert(sv != NULL);
 312     for(mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic){
 313         if(mg->mg_virtual == vtbl){
 314             return mg;
 315         }
 316     }
 317
 318     if(flags & MOUSEf_DIE_ON_FAIL){
 319         croak("mouse_mg_find: no MAGIC found for %"SVf, sv_2mortal(newRV_inc(sv)));
 320     }
 321     return NULL;
 322 }
 323
 324 GV*
 325 mouse_stash_fetch(pTHX_ HV* const stash, const char* const name, I32 const namelen, I32 const create) {
 326     GV** const gvp = (GV**)hv_fetch(stash, name, namelen, create);
 327
 328     if(gvp){
 329         if(!isGV(*gvp)){
 330             gv_init(*gvp, stash, name, namelen, GV_ADDMULTI);
 331         }
 332         return *gvp;
 333     }
 334     else{
 335         return NULL;
 336     }
 337 }
 338
 339 void
 340 mouse_install_sub(pTHX_ GV* const gv, SV* const code_ref) {
 341     CV* cv;
 342
 343     assert(gv != NULL);
 344     assert(code_ref != NULL);
 345     assert(isGV(gv));
 346     assert(IsCodeRef(code_ref));
 347
 348     if(GvCVu(gv)){ /* delete *slot{gv} to work around "redefine" warning */
 349         SvREFCNT_dec(GvCV(gv));
 350         GvCV(gv) = NULL;
 351     }
 352
 353     sv_setsv_mg((SV*)gv, code_ref); /* *gv = $code_ref */
 354
 355     /* name the CODE ref if it's anonymous */
 356     cv = (CV*)SvRV(code_ref);
 357     if(CvANON(cv)
 358         && CvGV(cv) /* a cv under construction has no gv */ ){
 359         HV* dbsub;
 360
 361         /* update %DB::sub to make NYTProf happy */
 362         if((PL_perldb & (PERLDBf_SUBLINE|PERLDB_NAMEANON))
 363             && PL_DBsub && (dbsub = GvHV(PL_DBsub))
 364         ){
 365             /* see Perl_newATTRSUB() in op.c */
 366             SV* const subname = sv_newmortal();
 367             HE* orig;
 368
 369             gv_efullname3(subname, CvGV(cv), NULL);
 370             orig = hv_fetch_ent(dbsub, subname, FALSE, 0U);
 371             if(orig){
 372                 gv_efullname3(subname, gv, NULL);
 373                 (void)hv_store_ent(dbsub, subname, HeVAL(orig), 0U);
 374                 SvREFCNT_inc_simple_void_NN(HeVAL(orig));
 375             }
 376         }
 377
 378         CvGV(cv) = gv;
 379         CvANON_off(cv);
 380     }
 381 }
 382
 383 MODULE = Mouse::Util  PACKAGE = Mouse::Util
 384
 385 PROTOTYPES:   DISABLE
 386 VERSIONCHECK: DISABLE
 387
 388 BOOT:
 389 {
 390     MY_CXT_INIT;
 391     MY_CXT.metas = NULL;
 392 }
 393
 394 void
 395 __register_metaclass_storage(HV* metas, bool cloning)
 396 CODE:
 397 {
 398     if(cloning){
 399         MY_CXT_CLONE;
 400         MY_CXT.metas = NULL;
 401     }
 402     {
 403         dMY_CXT;
 404         if(MY_CXT.metas && ckWARN(WARN_REDEFINE)){
 405             Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Metaclass storage more than once");
 406         }
 407         MY_CXT.metas = metas;
 408         SvREFCNT_inc_simple_void_NN(metas);
 409     }
 410 }
 411
 412 bool
 413 is_valid_class_name(SV* sv)
 414 CODE:
 415 {
 416     SvGETMAGIC(sv);
 417     if(SvPOKp(sv) && SvCUR(sv) > 0){
 418         UV i;
 419         RETVAL = TRUE;
 420         for(i = 0; i < SvCUR(sv); i++){
 421             char const c = SvPVX(sv)[i];
 422             if(!(isALNUM(c) || c == ':')){
 423                 RETVAL = FALSE;
 424                 break;
 425             }
 426         }
 427     }
 428     else{
 429         RETVAL = SvNIOKp(sv) ? TRUE : FALSE;
 430     }
 431 }
 432 OUTPUT:
 433     RETVAL
 434
 435 bool
 436 is_class_loaded(SV* sv)
 437
 438 void
 439 get_code_info(CV* code)
 440 PREINIT:
 441     GV* gv;
 442     HV* stash;
 443 PPCODE:
 444     if((gv = CvGV(code)) && isGV(gv) && (stash = GvSTASH(gv))){
 445         EXTEND(SP, 2);
 446         mPUSHs(newSVpvn_share(HvNAME_get(stash), HvNAMELEN_get(stash), 0U));
 447         mPUSHs(newSVpvn_share(GvNAME_get(gv), GvNAMELEN_get(gv), 0U));
 448     }
 449
 450 SV*
 451 get_code_package(CV* code)
 452 PREINIT:
 453     HV* stash;
 454 CODE:
 455     if(CvGV(code) && isGV(CvGV(code)) && (stash = GvSTASH(CvGV(code)))){
 456         RETVAL = newSVpvn_share(HvNAME_get(stash), HvNAMELEN_get(stash), 0U);
 457     }
 458     else{
 459         RETVAL = &PL_sv_no;
 460     }
 461 OUTPUT:
 462     RETVAL
 463
 464 CV*
 465 get_code_ref(SV* package, SV* name)
 466 CODE:
 467 {
 468     HV* stash;
 469     STRLEN name_len;
 470     const char* name_pv;
 471     GV* gv;
 472
 473     must_defined(package, "a package name");
 474     must_defined(name,    "a subroutine name");
 475
 476     stash = gv_stashsv(package, FALSE);
 477     if(!stash){
 478         XSRETURN_UNDEF;
 479     }
 480
 481     name_pv = SvPV_const(name, name_len);
 482     gv = stash_fetch(stash, name_pv, name_len, FALSE);
 483     RETVAL = gv ? GvCVu(gv) : NULL;
 484
 485     if(!RETVAL){
 486         XSRETURN_UNDEF;
 487     }
 488 }
 489 OUTPUT:
 490     RETVAL
 491
 492 void
 493 generate_isa_predicate_for(SV* arg, SV* predicate_name = NULL)
 494 ALIAS:
 495     generate_isa_predicate_for = 0
 496     generate_can_predicate_for = 1
 497 PPCODE:
 498 {
 499     const char* name_pv = NULL;
 500     CV* xsub;
 501
 502     must_defined(arg, ix == 0 ? "a class_name" : "method names");
 503
 504     if(predicate_name){
 505         must_defined(predicate_name, "a predicate name");
 506         name_pv = SvPV_nolen_const(predicate_name);
 507     }
 508
 509     if(ix == 0){
 510         xsub = mouse_generate_isa_predicate_for(aTHX_ arg, name_pv);
 511     }
 512     else{
 513         xsub = mouse_generate_can_predicate_for(aTHX_ arg, name_pv);
 514     }
 515
 516     if(predicate_name == NULL){ /* anonymous predicate */
 517         mXPUSHs( newRV_inc((SV*)xsub) );
 518     }
 519 }
 520
 521 # This xsub will redefine &Mouse::Util::install_subroutines()
 522 void
 523 install_subroutines(SV* into, ...)
 524 CODE:
 525 {
 526     HV* stash;
 527     I32 i;
 528
 529     must_defined(into, "a package name");
 530     stash = gv_stashsv(into, TRUE);
 531
 532     if( ((items-1) % 2) != 0 ){
 533         croak_xs_usage(cv, "into, name => coderef [, other_name, other_coderef ...]");
 534     }
 535
 536     for(i = 1; i < items; i += 2) {
 537         SV* const name = ST(i);
 538         SV* const code = ST(i+1);
 539         STRLEN len;
 540         const char* pv;
 541         GV* gv;
 542
 543         must_defined(name, "a subroutine name");
 544         must_ref(code, "a CODE reference", SVt_PVCV);
 545
 546         pv = SvPV_const(name, len);
 547         gv = stash_fetch(stash, pv, len, TRUE);
 548
 549         mouse_install_sub(aTHX_ gv, code);
 550     }
 551 }