view release on metacpan or  search on metacpan

Attribute.xs  view on Meta::CPAN

        FREETMPS;
    }

    LEAVE;

    av_clear(MY_CXT.queue);
    return 0;
}

static SV*
sa_newSVsv_share(pTHX_ SV* const sv){
    STRLEN len;
    const char* const pv = SvPV_const(sv, len);
    return newSVpvn_share(pv, len, 0U);
}

static MGVTBL hook_scope_vtbl = {
    NULL, /* get */
    NULL, /* set */
    NULL, /* len */
    NULL, /* clear */
    sa_process_queue, /* free */
    NULL, /* copy */
    NULL, /* dup */
#ifdef MGf_LOCAL
    NULL,  /* local */
#endif
};


static MGVTBL attr_handler_vtbl;


MODULE = Sub::Attribute    PACKAGE = Sub::Attribute

PROTOTYPES: DISABLE

BOOT:
{
    const char* const d = PerlEnv_getenv("SUB_ATTRIBUTE_DEBUG");
    MY_CXT_INIT;
    MY_CXT.queue      = newAV();
    MY_CXT.debug      = (d && *d != '\0' && strNE(d, "0"));
}

void
CLONE(...)
CODE:
    MY_CXT_CLONE;
    MY_CXT.queue = newAV();
    PERL_UNUSED_VAR(items);

void
MODIFY_CODE_ATTRIBUTES(SV* klass, CV* code, ...)
PREINIT:
    dMY_CXT;
    HV* const hinthv = GvHVn(PL_hintgv);
    HV* stash;
    MAGIC* mg;
    I32 i;
PPCODE:
    mg = mg_find_by_vtbl((SV*)hinthv, &hook_scope_vtbl);
    if(!mg){
        sv_magicext((SV*)hinthv, NULL, PERL_MAGIC_ext, &hook_scope_vtbl, NULL, 0);
        PL_hints |= HINT_LOCALIZE_HH;
    }
    stash = gv_stashsv(klass, TRUE);
    klass = sa_newSVsv_share(aTHX_ klass);

    for(i = 2; i < items; i++){
        STRLEN attrlen;
        const char* const attr = SvPV_const(ST(i), attrlen);
        const char* data       = strchr(attr, '(');
        STRLEN  datalen        = attrlen - (data - attr) - 2;
        STRLEN const namelen   = data ? (STRLEN)(data - attr) : attrlen;
        GV* meth;

        if(data){
            data++; /* skip '(' */
            while(isSPACE(*data)){
                data++;
                datalen--;
            }
            while(isSPACE(data[datalen-1])){
                datalen--;
            }
        }

        if(strnEQ(attr, META_ATTR, sizeof(META_ATTR))){ /* meta attribute */
            if(!MgFind((SV*)code, &attr_handler_vtbl)){
                sv_magicext(
                    (SV*)code,
                    NULL, PERL_MAGIC_ext, &attr_handler_vtbl,
                    PACKAGE, 0
                );

                if(MY_CXT.debug){
                    warn("install attribute handler %"SVf"\n", PL_subname);
                }
            }
            continue;
        }

        meth = gv_fetchmeth_autoload(stash, attr, namelen, 0 /* special zero */);
        if(meth && MgFind((SV*)GvCV(meth), &attr_handler_vtbl)){
            AV* const handler = newAV();

            av_store(handler, SA_METHOD, SvREFCNT_inc_simple_NN((SV*)GvCV(meth)));
            av_store(handler, SA_KLASS,  SvREFCNT_inc_simple_NN(klass));
            av_store(handler, SA_CODE,   newRV_inc((SV*)code));
            av_store(handler, SA_NAME,   newSVpvn_share(attr, namelen, 0U));

            if(data){
                av_store(handler, SA_DATA,  newSVpvn(data, datalen));
            }

            av_push(MY_CXT.queue, (SV*)handler);
        }
        else{
            if(MY_CXT.debug){
                warn("ignore unrecognized attribute :%"SVf"\n", ST(i));