view release on metacpan or  search on metacpan

lib/Package/Prototype.xs  view on Meta::CPAN

static CV *
make_closure(pTHX_ SV *retval)
{
    CV *xsub;
    xsub = newXS(NULL /* anonymous */, XS_prototype_getter, __FILE__);
    CvXSUBANY(xsub).any_ptr = (void *)retval;
    return xsub;
}

static void
push_values(pTHX_ SV *retval)
{
    dSP;
    if (WANT_ARRAY && IsArrayRef(retval)) {
        AV *av  = (AV *)SvRV(retval);
        I32 len = av_len(av) + 1;
        EXTEND(SP, len);
        for (I32 i = 0; i < len; i++){
            SV **const svp = av_fetch(av, i, FALSE);
            PUSHs(svp ? *svp : &PL_sv_undef);
        }
    } else if (WANT_ARRAY && IsHashRef(retval)) {
        HV *hv = (HV *)SvRV(retval);
        HE *he;
        hv_iterinit(hv);
        while ((he = hv_iternext(hv)) != NULL){
            EXTEND(SP, 2);
            PUSHs(hv_iterkeysv(he));
            PUSHs(hv_iterval(hv, he));
        }
    } else {
        XPUSHs(retval ? retval : &PL_sv_undef);
    }
    PUTBACK;
}

static CV *
make_prototype_method(pTHX_ HV *stash)
{
    CV *xsub;
    xsub = newXS(NULL /* anonymous */, XS_prototype_method, __FILE__);
    CvXSUBANY(xsub).any_ptr = (void *)stash;
    return xsub;
}

static void
install_prototype_method(pTHX_ HV *stash)
{
    char *prototype = "prototype";
    CV *prototype_cv = make_prototype_method(aTHX_ stash);
    GV *prototype_glob = prototype_gv_pvn(aTHX_ stash, prototype, 9, 0);
    GvCV_set(prototype_glob, prototype_cv);
    hv_store(stash, prototype, 9, (SV *)prototype_glob, 0);
}

XS(XS_prototype_getter)
{
    dVAR; dXSARGS;
    SV *retval = (SV *)CvXSUBANY(cv).any_ptr;
    SP -= items; /* PPCODE */
    PUTBACK;
    push_values(aTHX_ retval);
}

XS(XS_prototype_method)
{
    dVAR; dXSARGS;
    if ((items - 1) % 2 != 0)
        Perl_croak(aTHX_ "Argument isn't hash type");
    
    HV *stash = (HV *)CvXSUBANY(cv).any_ptr;
    I32 i = 1; /* First argument is skip: `my $self = shift;` */
    while (i < items) {
        SV *method = ST(i++);
        SV *val = ST(i++);
        CV *cv = IsCodeRef(val) ? (CV *)SvREFCNT_inc(SvRV(val)) : make_closure(aTHX_ val);
        add_method_sv(aTHX_ stash, method, cv);
    }
    XSRETURN(0);
}

MODULE = Package::Prototype    PACKAGE = Package::Prototype
PROTOTYPES: DISABLE

void *
bless(klass, ref, pkgsv=NULL)
    SV *klass;
    SV *ref;
    SV *pkgsv;
PREINIT:
    char *pkg;
    STRLEN pkglen;
    HE* entry;
    HV *stash;
PPCODE:
{
    if (!IsHashRef(ref))
         Perl_croak(aTHX_ "Please pass an hash reference to the first argument");

    if (pkgsv) {
        pkg = SvPV(pkgsv, pkglen);
    } else {
        pkg = "__ANON__";
        pkglen = 8;
    }

    stash = (HV *)sv_2mortal((SV *)newHV());
    hv_name_set(stash, pkg, pkglen, 0);

    install_prototype_method(aTHX_ stash);

    HV *hv = (HV *)SvRV(ref);
    hv_iterinit(hv);
    while ((entry = hv_iternext(hv)) != NULL){
        I32 keylen;
        char* key = hv_iterkey(entry, &keylen);
        if (0 < keylen && key[0] != '_') {
            SV *method = hv_iterkeysv(entry);
            SV *val = hv_delete(hv, key, keylen, 1);
            SvREFCNT_inc(val); /* was made mortal by hv_delete */
            CV *cv = IsCodeRef(val) ? (CV *)SvRV(val) : make_closure(aTHX_ val);
            add_method(aTHX_ stash, method, cv, key, keylen);
        }
    }

    ST(0) = sv_bless(ref, stash);
    XSRETURN(1);
}