autobox.xs

#define PERL_CORE

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#define NEED_sv_2pv_flags
#include "ppport.h"

#include "ptable.h"

static PTABLE_t *AUTOBOX_OP_MAP = NULL;
static U32 AUTOBOX_SCOPE_DEPTH = 0;
static OP *(*autobox_old_ck_subr)(pTHX_ OP *op) = NULL;
static SV * autobox_method_common(pTHX_ SV *meth, U32 *hashp);
static const char * autobox_type(pTHX_ SV * const sv, STRLEN *len);

OP * autobox_ck_subr(pTHX_ OP *o);
OP * autobox_method_named(pTHX);
OP * autobox_method(pTHX);

OP * autobox_ck_subr(pTHX_ OP *o) {
    /*
     * work around a %^H scoping bug by checking that PL_hints (which is properly scoped) & an unused
     * PL_hints bit (0x100000) is true
     *
     * XXX this is fixed in #33311: http://www.nntp.perl.org/group/perl.perl5.porters/2008/02/msg134131.html
     */
    if ((PL_hints & 0x80020000) == 0x80020000) {
        OP *prev = ((cUNOPo->op_first->op_sibling) ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
        OP *o2 = prev->op_sibling;
        OP *cvop;

        for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling);

        /* don't autobox if the receiver is a bareword */
        if ((cvop->op_type == OP_METHOD) || ((cvop->op_type == OP_METHOD_NAMED) && !(o2->op_private & OPpCONST_BARE))) {
            const char * meth;
            /*
             * the bareword flag is not set on the receivers of the import, unimport
             * and VERSION messages faked up by use() and no(), so exempt them
             */
            if ((cvop->op_type == OP_METHOD) ||
                (((meth = SvPVX_const(((SVOP *)cvop)->op_sv))) && /* SvPVX_const should be sane for method_named */
                strNE(meth, "import") && strNE(meth, "unimport") && strNE(meth, "VERSION"))) {
                HV *table = GvHV(PL_hintgv);
                SV **svp;

                /* if there are bindings for this scope */
                if (table && (svp = hv_fetch(table, "autobox", 7, FALSE)) && *svp && SvOK(*svp)) {
                    /*
                     * if the receiver is an @array, %hash, @{ ... } or %{ ... }, then "autoref" it
                     * i.e. the op tree equivalent of inserting a backslash before it
                     */
                    OP *refgen;
                    U32 toggled = 0;

                    switch (o2->op_type) {
                        case OP_PADAV:
                        case OP_PADHV:
                        case OP_RV2AV:
                        case OP_RV2HV:
                            /*
                             * perlref:
                             *
                             *   As a special case, "\(@foo)" returns a list of references to the contents of @foo,
                             *   not a reference to @foo itself. Likewise for %foo, except that the key references
                             *   are to copies (since the keys are just strings rather than full-fledged scalars).
                             *
                             * we don't want that (it results in the receiver being a reference to the last element
                             * in the list), so we toggle the parentheses off while creating the reference
                             * then toggle them back on in case they're needed elsewhere
                             *
                             */
                            if (o2->op_flags & OPf_PARENS) {
                                o2->op_flags &= ~OPf_PARENS;
                                toggled = 1;
                            }

                            refgen = newUNOP(OP_REFGEN, 0, o2);
                            prev->op_sibling = refgen;
                            refgen->op_sibling = o2->op_sibling;
                            o2->op_sibling = NULL;

                            /* Restore the parentheses in case something else expects them */
                            if (toggled) {
                                o2->op_flags |= OPf_PARENS;
                            }
                        /* otherwise do nothing */
                    }

                    cvop->op_flags |= OPf_SPECIAL;
                    cvop->op_ppaddr = cvop->op_type == OP_METHOD ? autobox_method : autobox_method_named;
                    PTABLE_store(AUTOBOX_OP_MAP, cvop, SvRV(*svp));
                }
            }
        }
    }

    return autobox_old_ck_subr(aTHX_ o);
}

OP* autobox_method(pTHX) {
    dVAR; dSP;
    SV * const sv = TOPs;
    SV * cv;

    if (SvROK(sv)) {
        cv = SvRV(sv);
        if (SvTYPE(cv) == SVt_PVCV) {
            SETs(cv);
            RETURN;
        }
    }

    cv = autobox_method_common(aTHX_ sv, NULL);

    if (cv) {
        SETs(cv);
        RETURN;
    } else {
        return PL_ppaddr[OP_METHOD](aTHXR);
    }
}

OP* autobox_method_named(pTHX) {
    dVAR; dSP;
    SV * const sv = cSVOP_sv;
    U32 hash = SvSHARED_HASH(sv);
    SV * cv;

    cv = autobox_method_common(aTHX_ sv, &hash);

    if (cv) {
        XPUSHs(cv);
        RETURN;
    } else {
        return PL_ppaddr[OP_METHOD_NAMED](aTHXR);
    }
}

#define AUTOBOX_TYPE_RETURN(type) STMT_START { *len = (sizeof(type) - 1); return type; } STMT_END

static const char *autobox_type(pTHX_ SV * const sv, STRLEN *len) {
    switch (SvTYPE(sv)) {
        case SVt_NULL:
            AUTOBOX_TYPE_RETURN("UNDEF");
        case SVt_IV:
            AUTOBOX_TYPE_RETURN("INTEGER");
        case SVt_PVIV:
            if (SvIOK(sv)) {
                AUTOBOX_TYPE_RETURN("INTEGER");
            } else {
                AUTOBOX_TYPE_RETURN("STRING");
            }
        case SVt_NV:
            if (SvIOK(sv)) {
                AUTOBOX_TYPE_RETURN("INTEGER");
            } else {
                AUTOBOX_TYPE_RETURN("FLOAT");
            }
        case SVt_PVNV:
            /* integer before float: https://rt.cpan.org/Ticket/Display.html?id=46814 */
            if (SvIOK(sv)) {
                AUTOBOX_TYPE_RETURN("INTEGER");
            } else if (SvNOK(sv)) {
                AUTOBOX_TYPE_RETURN("FLOAT");
            } else {
                AUTOBOX_TYPE_RETURN("STRING");
            }
#ifdef SVt_RV /* no longer defined by default if PERL_CORE is defined */
        case SVt_RV:
#endif
        case SVt_PV:
        case SVt_PVMG:
#ifdef SvVOK
            if (SvVOK(sv)) {
                AUTOBOX_TYPE_RETURN("VSTRING");
            }
#endif
            if (SvROK(sv)) {
                AUTOBOX_TYPE_RETURN("REF");
            } else {
                AUTOBOX_TYPE_RETURN("STRING");
            }
        case SVt_PVLV:
            if (SvROK(sv)) {
                AUTOBOX_TYPE_RETURN("REF");
            } else if (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T') { /* tied lvalue */
                if (SvIOK(sv)) {
                    AUTOBOX_TYPE_RETURN("INTEGER");
                } else if (SvNOK(sv)) {
                    AUTOBOX_TYPE_RETURN("FLOAT");
                } else {
                    AUTOBOX_TYPE_RETURN("STRING");
                }
            } else {
                AUTOBOX_TYPE_RETURN("LVALUE");
            }
        case SVt_PVAV:
            AUTOBOX_TYPE_RETURN("ARRAY");
        case SVt_PVHV:
            AUTOBOX_TYPE_RETURN("HASH");
        case SVt_PVCV:
            AUTOBOX_TYPE_RETURN("CODE");
        case SVt_PVGV:
            AUTOBOX_TYPE_RETURN("GLOB");
        case SVt_PVFM:
            AUTOBOX_TYPE_RETURN("FORMAT");
        case SVt_PVIO:
            AUTOBOX_TYPE_RETURN("IO");
#ifdef SVt_BIND
        case SVt_BIND:
            AUTOBOX_TYPE_RETURN("BIND");
#endif
#ifdef SVt_REGEXP
        case SVt_REGEXP:
            AUTOBOX_TYPE_RETURN("REGEXP");
#endif
        default:
            AUTOBOX_TYPE_RETURN("UNKNOWN");
    }
}

/* returns either the method, or NULL, meaning delegate to the original op */
static SV * autobox_method_common(pTHX_ SV * meth, U32* hashp) {
    SV * const sv = *(PL_stack_base + TOPMARK + 1);

    /* if autobox is enabled (in scope) for this op and the receiver isn't an object... */
    /* don't use sv_isobject - we don't want to call SvGETMAGIC twice */
    if ((PL_op->op_flags & OPf_SPECIAL) && ((!SvROK(sv)) || !SvOBJECT(SvRV(sv)))) {
        HV * autobox_bindings;

        SvGETMAGIC(sv);

        /* this is the "bindings hash" that maps datatypes to package names */
        autobox_bindings = (HV *)(PTABLE_fetch(AUTOBOX_OP_MAP, PL_op));

        if (autobox_bindings) {
            const char * reftype; /* autobox_bindings key */
            SV **svp; /* pointer to autobox_bindings value */
            STRLEN typelen = 0;

            /*
             * the type is either the receiver's reftype(), a subtype of SCALAR if it's not a ref, or UNDEF if
             * it's not defined
             */

            if (SvOK(sv)) {
                reftype = autobox_type(aTHX_ (SvROK(sv) ? SvRV(sv) : sv), &typelen);
            } else {
                reftype = "UNDEF";
                typelen = sizeof("UNDEF") - 1;
            }

            svp = hv_fetch(autobox_bindings, reftype, typelen, 0);

            if (svp && SvOK(*svp)) {
                SV * packsv = *svp;
                STRLEN packlen;
                HV * stash;
                GV * gv;
                const char * packname = SvPV_const(packsv, packlen);

                stash = gv_stashpvn(packname, packlen, FALSE);

                if (hashp) {
                    const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);  /* shortcut for simple names */

                    if (he) {
                        gv = (GV*)HeVAL(he);
                        if (isGV(gv) && GvCV(gv) && (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation)) {
                            return ((SV*)GvCV(gv));
                        }
                    }
                }

                /*
                 * SvPV_nolen_const returns the method name as a const char *, stringifying names that
                 * are not strings (e.g. undef, SvIV,  SvNV &c.) - see name.t
                 */
                gv = gv_fetchmethod(stash ? stash : (HV*)packsv, SvPV_nolen_const(meth));

                if (gv) {
                    return(isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv);
                }
            }
        }
    }

    return NULL;
}

MODULE = autobox                PACKAGE = autobox

PROTOTYPES: ENABLE

BOOT:
AUTOBOX_OP_MAP = PTABLE_new(); if (!AUTOBOX_OP_MAP) Perl_croak(aTHX_ "Can't initialize op map");

void
_enter()
    PROTOTYPE:
    CODE:
        if (AUTOBOX_SCOPE_DEPTH > 0) {
            ++AUTOBOX_SCOPE_DEPTH;
        } else {
            AUTOBOX_SCOPE_DEPTH = 1;
            /*
             * capture the check routine in scope when autobox is used.
             * usually, this will be Perl_ck_subr, though, in principle,
             * it could be a bespoke checker spliced in by another module.
             */
            autobox_old_ck_subr = PL_check[OP_ENTERSUB];
            PL_check[OP_ENTERSUB] = autobox_ck_subr;
        }

void
_leave()
    PROTOTYPE:
    CODE:
        if (AUTOBOX_SCOPE_DEPTH == 0) {
            Perl_warn(aTHX_ "scope underflow");
        }

        if (AUTOBOX_SCOPE_DEPTH > 1) {
            --AUTOBOX_SCOPE_DEPTH;
        } else {
            AUTOBOX_SCOPE_DEPTH = 0;
            PL_check[OP_ENTERSUB] = autobox_old_ck_subr;
        }

void
_scope()
    PROTOTYPE:
    CODE:
        XSRETURN_UV(PTR2UV(GvHV(PL_hintgv)));

void
END()
    PROTOTYPE:
    CODE:
        if (autobox_old_ck_subr) { /* make sure we got as far as initializing it */
            PL_check[OP_ENTERSUB] = autobox_old_ck_subr;
        }

        PTABLE_free(AUTOBOX_OP_MAP);
        AUTOBOX_OP_MAP = NULL;

MODULE = autobox                PACKAGE = autobox::universal

SV *
type(SV * sv)
    PROTOTYPE:$
    PREINIT:
        STRLEN len = 0;
        const char *type;
    CODE:
        if (SvOK(sv)) {
            type = autobox_type(aTHX_ (SvROK(sv) ? SvRV(sv) : sv), &len);
            RETVAL = newSVpv(type, len);
        } else {
            RETVAL = newSVpv("UNDEF", sizeof("UNDEF") - 1);
        }
    OUTPUT:
        RETVAL