[perl5.git] / builtin.c

/*    builtin.c
 *
 *    Copyright (C) 2021 by Paul Evans and others
 *
 *    You may distribute under the terms of either the GNU General Public
 *    License or the Artistic License, as specified in the README file.
 *
 */

/* This file contains the code that implements functions in perl's "builtin::"
 * namespace
 */

#include "EXTERN.h"
#include "perl.h"

#include "XSUB.h"

/* copied from op.c */
#define SHORTVER(maj,min) (((maj) << 8) | (min))

struct BuiltinFuncDescriptor {
    const char *name;
    U16 since_ver;
    XSUBADDR_t xsub;
    OP *(*checker)(pTHX_ OP *, GV *, SV *);
    IV ckval;
    bool is_experimental;
};

#define warn_experimental_builtin(name) S_warn_experimental_builtin(aTHX_ name)
static void S_warn_experimental_builtin(pTHX_ const char *name)
{
    /* diag_listed_as: Built-in function '%s' is experimental */
    Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BUILTIN),
                     "Built-in function 'builtin::%s' is experimental", name);
}

/* These three utilities might want to live elsewhere to be reused from other
 * code sometime
 */
#define prepare_export_lexical()  S_prepare_export_lexical(aTHX)
static void S_prepare_export_lexical(pTHX)
{
    assert(PL_compcv);

    /* We need to have PL_comppad / PL_curpad set correctly for lexical importing */
    ENTER;
    SAVESPTR(PL_comppad_name); PL_comppad_name = PadlistNAMES(CvPADLIST(PL_compcv));
    SAVESPTR(PL_comppad);      PL_comppad      = PadlistARRAY(CvPADLIST(PL_compcv))[1];
    SAVESPTR(PL_curpad);       PL_curpad       = PadARRAY(PL_comppad);
}

#define export_lexical(name, sv)  S_export_lexical(aTHX_ name, sv)
static void S_export_lexical(pTHX_ SV *name, SV *sv)
{
    PADOFFSET off = pad_add_name_sv(name, padadd_STATE, 0, 0);
    SvREFCNT_dec(PL_curpad[off]);
    PL_curpad[off] = SvREFCNT_inc(sv);
}

#define finish_export_lexical()  S_finish_export_lexical(aTHX)
static void S_finish_export_lexical(pTHX)
{
    intro_my();

    LEAVE;
}


XS(XS_builtin_true);
XS(XS_builtin_true)
{
    dXSARGS;
    if(items)
        croak_xs_usage(cv, "");
    XSRETURN_YES;
}

XS(XS_builtin_false);
XS(XS_builtin_false)
{
    dXSARGS;
    if(items)
        croak_xs_usage(cv, "");
    XSRETURN_NO;
}

enum {
    BUILTIN_CONST_FALSE,
    BUILTIN_CONST_TRUE,
};

static OP *ck_builtin_const(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
{
    const struct BuiltinFuncDescriptor *builtin = NUM2PTR(const struct BuiltinFuncDescriptor *, SvUV(ckobj));

    SV *prototype = newSVpvs("");
    SAVEFREESV(prototype);

    assert(entersubop->op_type == OP_ENTERSUB);

    entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);

    SV *constval;
    switch(builtin->ckval) {
        case BUILTIN_CONST_FALSE: constval = &PL_sv_no; break;
        case BUILTIN_CONST_TRUE:  constval = &PL_sv_yes; break;
        default:
            DIE(aTHX_ "panic: unrecognised builtin_const value %" IVdf,
                      builtin->ckval);
            break;
    }

    op_free(entersubop);

    return newSVOP(OP_CONST, 0, constval);
}

XS(XS_builtin_func1_scalar);
XS(XS_builtin_func1_scalar)
{
    dXSARGS;
    dXSI32;

    if(items != 1)
        croak_xs_usage(cv, "arg");

    switch(ix) {
        case OP_IS_BOOL:
            warn_experimental_builtin(PL_op_name[ix]);
            Perl_pp_is_bool(aTHX);
            break;

        case OP_IS_WEAK:
            Perl_pp_is_weak(aTHX);
            break;

        case OP_BLESSED:
            Perl_pp_blessed(aTHX);
            break;

        case OP_REFADDR:
            Perl_pp_refaddr(aTHX);
            break;

        case OP_REFTYPE:
            Perl_pp_reftype(aTHX);
            break;

        case OP_CEIL:
            Perl_pp_ceil(aTHX);
            break;

        case OP_FLOOR:
            Perl_pp_floor(aTHX);
            break;

        case OP_IS_TAINTED:
            Perl_pp_is_tainted(aTHX);
            break;

        case OP_STRINGIFY:
            Perl_pp_stringify(aTHX);
            break;

        default:
            Perl_die(aTHX_ "panic: unhandled opcode %" IVdf
                           " for xs_builtin_func1_scalar()", (IV) ix);
    }

    XSRETURN(1);
}

XS(XS_builtin_trim);
XS(XS_builtin_trim)
{
    dXSARGS;

    if (items != 1) {
        croak_xs_usage(cv, "arg");
    }

    dTARGET;
    SV *source = TOPs;
    STRLEN len;
    const U8 *start;
    SV *dest;

    SvGETMAGIC(source);

    if (SvOK(source))
        start = (const U8*)SvPV_nomg_const(source, len);
    else {
        if (ckWARN(WARN_UNINITIALIZED))
            report_uninit(source);
        start = (const U8*)"";
        len = 0;
    }

    if (DO_UTF8(source)) {
        const U8 *end = start + len;

        /* Find the first non-space */
        while(len) {
            STRLEN thislen;
            if (!isSPACE_utf8_safe(start, end))
                break;
            start += (thislen = UTF8SKIP(start));
            len -= thislen;
        }

        /* Find the final non-space */
        STRLEN thislen;
        const U8 *cur_end = end;
        while ((thislen = is_SPACE_utf8_safe_backwards(cur_end, start))) {
            cur_end -= thislen;
        }
        len -= (end - cur_end);
    }
    else if (len) {
        while(len) {
            if (!isSPACE_L1(*start))
                break;
            start++;
            len--;
        }

        while(len) {
            if (!isSPACE_L1(start[len-1]))
                break;
            len--;
        }
    }

    dest = TARG;

    if (SvPOK(dest) && (dest == source)) {
        sv_chop(dest, (const char *)start);
        SvCUR_set(dest, len);
    }
    else {
        SvUPGRADE(dest, SVt_PV);
        SvGROW(dest, len + 1);

        Copy(start, SvPVX(dest), len, U8);
        SvPVX(dest)[len] = '\0';
        SvPOK_on(dest);
        SvCUR_set(dest, len);

        if (DO_UTF8(source))
            SvUTF8_on(dest);
        else
            SvUTF8_off(dest);

        if (SvTAINTED(source))
            SvTAINT(dest);
    }

    SvSETMAGIC(dest);

    SETs(dest);

    XSRETURN(1);
}

XS(XS_builtin_export_lexically);
XS(XS_builtin_export_lexically)
{
    dXSARGS;

    warn_experimental_builtin("export_lexically");

    if(!PL_compcv)
        Perl_croak(aTHX_
                "export_lexically can only be called at compile time");

    if(items % 2)
        Perl_croak(aTHX_ "Odd number of elements in export_lexically");

    for(int i = 0; i < items; i += 2) {
        SV *name = ST(i);
        SV *ref  = ST(i+1);

        if(!SvROK(ref))
            /* diag_listed_as: Expected %s reference in export_lexically */
            Perl_croak(aTHX_ "Expected a reference in export_lexically");

        char sigil = SvPVX(name)[0];
        SV *rv = SvRV(ref);

        const char *bad = NULL;
        switch(sigil) {
            default:
                /* overwrites the pointer on the stack; but this is fine, the
                 * caller's value isn't modified */
                ST(i) = name = sv_2mortal(Perl_newSVpvf(aTHX_ "&%" SVf, SVfARG(name)));

                /* FALLTHROUGH */
            case '&':
                if(SvTYPE(rv) != SVt_PVCV)
                    bad = "a CODE";
                break;

            case '$':
                /* Permit any of SVt_NULL to SVt_PVMG. Technically this also
                 * includes SVt_INVLIST but it isn't thought possible for pureperl
                 * code to ever manage to see one of those. */
                if(SvTYPE(rv) > SVt_PVMG)
                    bad = "a SCALAR";
                break;

            case '@':
                if(SvTYPE(rv) != SVt_PVAV)
                    bad = "an ARRAY";
                break;

            case '%':
                if(SvTYPE(rv) != SVt_PVHV)
                    bad = "a HASH";
                break;
        }

        if(bad)
            Perl_croak(aTHX_ "Expected %s reference in export_lexically", bad);
    }

    prepare_export_lexical();

    for(int i = 0; i < items; i += 2) {
        SV *name = ST(i);
        SV *ref  = ST(i+1);

        export_lexical(name, SvRV(ref));
    }

    finish_export_lexical();
}

XS(XS_builtin_func1_void);
XS(XS_builtin_func1_void)
{
    dXSARGS;
    dXSI32;

    if(items != 1)
        croak_xs_usage(cv, "arg");

    switch(ix) {
        case OP_WEAKEN:
            Perl_pp_weaken(aTHX);
            break;

        case OP_UNWEAKEN:
            Perl_pp_unweaken(aTHX);
            break;

        default:
            Perl_die(aTHX_ "panic: unhandled opcode %" IVdf
                           " for xs_builtin_func1_void()", (IV) ix);
    }

    XSRETURN(0);
}

XS(XS_builtin_created_as_string)
{
    dXSARGS;

    if(items != 1)
        croak_xs_usage(cv, "arg");

    SV *arg = ST(0);
    SvGETMAGIC(arg);

    /* SV was created as string if it has POK and isn't bool */
    ST(0) = boolSV(SvPOK(arg) && !SvIsBOOL(arg));
    XSRETURN(1);
}

XS(XS_builtin_created_as_number)
{
    dXSARGS;

    if(items != 1)
        croak_xs_usage(cv, "arg");

    SV *arg = ST(0);
    SvGETMAGIC(arg);

    /* SV was created as number if it has NOK or IOK but not POK and is not bool */
    ST(0) = boolSV(SvNIOK(arg) && !SvPOK(arg) && !SvIsBOOL(arg));
    XSRETURN(1);
}

static OP *ck_builtin_func1(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
{
    const struct BuiltinFuncDescriptor *builtin = NUM2PTR(const struct BuiltinFuncDescriptor *, SvUV(ckobj));

    if(builtin->is_experimental)
        warn_experimental_builtin(builtin->name);

    SV *prototype = newSVpvs("$");
    SAVEFREESV(prototype);

    assert(entersubop->op_type == OP_ENTERSUB);

    entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);

    OPCODE opcode = builtin->ckval;
    if(!opcode)
        return entersubop;

    OP *parent = entersubop, *pushop, *argop;

    pushop = cUNOPx(entersubop)->op_first;
    if (!OpHAS_SIBLING(pushop)) {
        pushop = cUNOPx(pushop)->op_first;
    }

    argop = OpSIBLING(pushop);

    if (!argop || !OpHAS_SIBLING(argop) || OpHAS_SIBLING(OpSIBLING(argop)))
        return entersubop;

    (void)op_sibling_splice(parent, pushop, 1, NULL);

    U8 wantflags = entersubop->op_flags & OPf_WANT;

    op_free(entersubop);

    if(opcode == OP_STRINGIFY)
        /* Even though pp_stringify only looks at TOPs and conceptually works
         * on a single argument, it happens to be a LISTOP. I've no idea why
         */
        return newLISTOPn(opcode, wantflags,
            argop,
            NULL);
    else
        return newUNOP(opcode, wantflags, argop);
}

XS(XS_builtin_indexed)
{
    dXSARGS;

    switch(GIMME_V) {
        case G_VOID:
            Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
                "Useless use of %s in void context", "builtin::indexed");
            XSRETURN(0);

        case G_SCALAR:
            Perl_ck_warner(aTHX_ packWARN(WARN_SCALAR),
                "Useless use of %s in scalar context", "builtin::indexed");
            ST(0) = sv_2mortal(newSViv(items * 2));
            XSRETURN(1);

        case G_LIST:
            break;
    }

    SSize_t retcount = items * 2;
    EXTEND(SP, retcount);

    /* Copy from [items-1] down to [0] so we don't have to make
     * temporary copies */
    for(SSize_t index = items - 1; index >= 0; index--) {
        /* Copy, not alias */
        ST(index * 2 + 1) = sv_mortalcopy(ST(index));
        ST(index * 2)     = sv_2mortal(newSViv(index));
    }

    XSRETURN(retcount);
}

XS(XS_builtin_load_module);
XS(XS_builtin_load_module)
{
    dXSARGS;
    if (items != 1)
        croak_xs_usage(cv, "arg");
    SV *module_name = newSVsv(ST(0));
    if (!SvPOK(module_name)) {
        SvREFCNT_dec(module_name);
        croak_xs_usage(cv, "defined string");
    }
    load_module(PERL_LOADMOD_NOIMPORT, module_name, NULL, NULL);
    /* The loaded module's name is left intentionally on the stack for the
     * caller's benefit, and becomes load_module's return value. */
    XSRETURN(1);
}

static OP *ck_builtin_funcN(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
{
    const struct BuiltinFuncDescriptor *builtin = NUM2PTR(const struct BuiltinFuncDescriptor *, SvUV(ckobj));

    if(builtin->is_experimental)
        warn_experimental_builtin(builtin->name);

    SV *prototype = newSVpvs("@");
    SAVEFREESV(prototype);

    assert(entersubop->op_type == OP_ENTERSUB);

    entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);
    return entersubop;
}

static const char builtin_not_recognised[] = "'%" SVf "' is not recognised as a builtin function";

#define NO_BUNDLE SHORTVER(255,255)

static const struct BuiltinFuncDescriptor builtins[] = {
    /* constants */
    { "true",  SHORTVER(5,39), &XS_builtin_true,   &ck_builtin_const, BUILTIN_CONST_TRUE,  false },
    { "false", SHORTVER(5,39), &XS_builtin_false,  &ck_builtin_const, BUILTIN_CONST_FALSE, false },

    /* unary functions */
    { "is_bool",         NO_BUNDLE, &XS_builtin_func1_scalar, &ck_builtin_func1, OP_IS_BOOL,    true  },
    { "weaken",     SHORTVER(5,39), &XS_builtin_func1_void,   &ck_builtin_func1, OP_WEAKEN,     false },
    { "unweaken",   SHORTVER(5,39), &XS_builtin_func1_void,   &ck_builtin_func1, OP_UNWEAKEN,   false },
    { "is_weak",    SHORTVER(5,39), &XS_builtin_func1_scalar, &ck_builtin_func1, OP_IS_WEAK,    false },
    { "blessed",    SHORTVER(5,39), &XS_builtin_func1_scalar, &ck_builtin_func1, OP_BLESSED,    false },
    { "refaddr",    SHORTVER(5,39), &XS_builtin_func1_scalar, &ck_builtin_func1, OP_REFADDR,    false },
    { "reftype",    SHORTVER(5,39), &XS_builtin_func1_scalar, &ck_builtin_func1, OP_REFTYPE,    false },
    { "ceil",       SHORTVER(5,39), &XS_builtin_func1_scalar, &ck_builtin_func1, OP_CEIL,       false },
    { "floor",      SHORTVER(5,39), &XS_builtin_func1_scalar, &ck_builtin_func1, OP_FLOOR,      false },
    { "is_tainted", SHORTVER(5,39), &XS_builtin_func1_scalar, &ck_builtin_func1, OP_IS_TAINTED, false },
    { "trim",       SHORTVER(5,39), &XS_builtin_trim,         &ck_builtin_func1, 0,             false },
    { "stringify",       NO_BUNDLE, &XS_builtin_func1_scalar, &ck_builtin_func1, OP_STRINGIFY,  true },

    { "created_as_string", NO_BUNDLE, &XS_builtin_created_as_string, &ck_builtin_func1, 0, true },
    { "created_as_number", NO_BUNDLE, &XS_builtin_created_as_number, &ck_builtin_func1, 0, true },

    { "load_module", NO_BUNDLE, &XS_builtin_load_module, &ck_builtin_func1, 0, true },

    /* list functions */
    { "indexed",          SHORTVER(5,39), &XS_builtin_indexed,          &ck_builtin_funcN, 0, false },
    { "export_lexically",      NO_BUNDLE, &XS_builtin_export_lexically, NULL,              0, true },

    { NULL, 0, NULL, NULL, 0, false }
};

static bool S_parse_version(const char *vstr, const char *vend, UV *vmajor, UV *vminor)
{
    /* Parse a string like "5.35" to yield 5 and 35. Ignores an optional
     * trailing third component e.g. "5.35.7". Returns false on parse errors.
     */

    const char *end = vend;
    if (!grok_atoUV(vstr, vmajor, &end))
        return FALSE;

    vstr = end;
    if (*vstr++ != '.')
        return FALSE;

    end = vend;
    if (!grok_atoUV(vstr, vminor, &end))
        return FALSE;

    if(*vminor > 255)
        return FALSE;

    vstr = end;

    if(vstr[0] == '.') {
        vstr++;

        UV _dummy;
        if(!grok_atoUV(vstr, &_dummy, &end))
            return FALSE;
        if(_dummy > 255)
            return FALSE;

        vstr = end;
    }

    if(vstr != vend)
        return FALSE;

    return TRUE;
}

#define import_sym(sym)  S_import_sym(aTHX_ sym)
static void S_import_sym(pTHX_ SV *sym)
{
    SV *ampname = sv_2mortal(Perl_newSVpvf(aTHX_ "&%" SVf, SVfARG(sym)));
    SV *fqname = sv_2mortal(Perl_newSVpvf(aTHX_ "builtin::%" SVf, SVfARG(sym)));

    CV *cv = get_cv(SvPV_nolen(fqname), SvUTF8(fqname) ? SVf_UTF8 : 0);
    if(!cv)
        Perl_croak(aTHX_ builtin_not_recognised, sym);

    export_lexical(ampname, (SV *)cv);
}

#define import_builtin_bundle(ver)  S_import_builtin_bundle(aTHX_ ver)
static void S_import_builtin_bundle(pTHX_ U16 ver)
{
    for(int i = 0; builtins[i].name; i++) {
        if(builtins[i].since_ver <= ver)
            import_sym(newSVpvn_flags(builtins[i].name, strlen(builtins[i].name), SVs_TEMP));
    }
}

XS(XS_builtin_import);
XS(XS_builtin_import)
{
    dXSARGS;

    if(!PL_compcv)
        Perl_croak(aTHX_
                "builtin::import can only be called at compile time");

    prepare_export_lexical();

    for(int i = 1; i < items; i++) {
        SV *sym = ST(i);
        STRLEN symlen;
        const char *sympv = SvPV(sym, symlen);
        if(strEQ(sympv, "import") || strEQ(sympv, "unimport"))
            Perl_croak(aTHX_ builtin_not_recognised, sym);

        if(sympv[0] == ':') {
            UV vmajor, vminor;
            if(!S_parse_version(sympv + 1, sympv + symlen, &vmajor, &vminor))
                Perl_croak(aTHX_ "Invalid version bundle %" SVf_QUOTEDPREFIX, sym);

            U16 want_ver = SHORTVER(vmajor, vminor);

            if(want_ver < SHORTVER(5,39) ||
                    /* round up devel version to next major release; e.g. 5.39 => 5.40 */
                    want_ver > SHORTVER(PERL_REVISION, PERL_VERSION + (PERL_VERSION % 2)))
                Perl_croak(aTHX_ "Builtin version bundle \"%s\" is not supported by Perl " PERL_VERSION_STRING,
                        sympv);

            import_builtin_bundle(want_ver);

            continue;
        }

        import_sym(sym);
    }

    finish_export_lexical();
}

XS(XS_builtin_unimport);
XS(XS_builtin_unimport)
{
    dXSARGS;

    if(!PL_compcv)
        Perl_croak(aTHX_
                "builtin::unimport can only be called at compile time");

    prepare_export_lexical();

    for(int i = 1; i < items; i++) {
        SV *sym = ST(i);
        const char *sympv = SvPV_nolen(sym);
        if(strEQ(sympv, "import") || strEQ(sympv, "unimport"))
            Perl_croak(aTHX_ builtin_not_recognised, sym);

        SV *ampname = sv_2mortal(Perl_newSVpvf(aTHX_ "&%" SVf, SVfARG(sym)));
        SV *fqname = sv_2mortal(Perl_newSVpvf(aTHX_ "builtin::%" SVf, SVfARG(sym)));

        CV *cv = get_cv(SvPV_nolen(fqname), SvUTF8(fqname) ? SVf_UTF8 : 0);
        if(!cv)
            Perl_croak(aTHX_ builtin_not_recognised, sym);

        PADOFFSET off = pad_findmy_sv(ampname, 0);
        if((off == NOT_IN_PAD) ||
                (PL_curpad[off] != (SV *)cv))
            Perl_croak(aTHX_
                    "'%" SVf "' does not appear to be an imported builtin function", SVfARG(ampname));

        /* Add a tombstone entry */
        /* TODO: If the pad entry we found is going to go out of scope at the
         * same time as this tombstone would, we could not bother adding the
         * tombstone and instead COP_SEQ_MAX_HIGH_set() on the padname to
         * clear it.
         */
        off = pad_add_name_sv(ampname, padadd_STATE|padadd_TOMBSTONE, 0, 0);
        SvREFCNT_dec(PL_curpad[off]);
    }

    COP_SEQMAX_INC;
    finish_export_lexical();
}

void
Perl_boot_core_builtin(pTHX)
{
    I32 i;
    for(i = 0; builtins[i].name; i++) {
        const struct BuiltinFuncDescriptor *builtin = &builtins[i];

        const char *proto = NULL;
        if(builtin->checker == &ck_builtin_const)
            proto = "";
        else if(builtin->checker == &ck_builtin_func1)
            proto = "$";
        else if(builtin->checker == &ck_builtin_funcN)
            proto = "@";

        SV *name = newSVpvs_flags("builtin::", SVs_TEMP);
        sv_catpv(name, builtin->name);
        CV *cv = newXS_flags(SvPV_nolen(name), builtin->xsub, __FILE__, proto, 0);
        XSANY.any_i32 = builtin->ckval;

        if (   builtin->xsub == &XS_builtin_func1_void
            || builtin->xsub == &XS_builtin_func1_scalar)
        {
            /* these XS functions just call out to the relevant pp()
             * functions, so they must operate with a reference-counted
             * stack if the pp() do too.
             */
                CvXS_RCSTACK_on(cv);
        }

        if(builtin->checker) {
            cv_set_call_checker_flags(cv, builtin->checker, newSVuv(PTR2UV(builtin)), 0);
        }
    }

    newXS_flags("builtin::import",   &XS_builtin_import,   __FILE__, NULL, 0);
    newXS_flags("builtin::unimport", &XS_builtin_unimport, __FILE__, NULL, 0);
}

/*
 * ex: set ts=8 sts=4 sw=4 et:
 */
Commit	Line	Data
6a2e756f PE	1	/* builtin.c
	2	*
	3	* Copyright (C) 2021 by Paul Evans and others
	4	*
	5	* You may distribute under the terms of either the GNU General Public
	6	* License or the Artistic License, as specified in the README file.
	7	*
	8	*/
	9
	10	/* This file contains the code that implements functions in perl's "builtin::"
	11	* namespace
	12	*/
	13
	14	#include "EXTERN.h"
	15	#include "perl.h"
	16
	17	#include "XSUB.h"
	18
5a94e094 PE	19	/* copied from op.c */
	20	#define SHORTVER(maj,min) (((maj) << 8) \| (min))
	21
852c1a84 PE	22	struct BuiltinFuncDescriptor {
852c1a84 PE	23	const char *name;
5a94e094	24	U16 since_ver;
852c1a84 PE	25	XSUBADDR_t xsub;
	26	OP (checker)(pTHX_ OP , GV , SV *);
	27	IV ckval;
edd58c23	28	bool is_experimental;
852c1a84 PE	29	};
852c1a84 PE	30
d0364e1b PE	31	#define warn_experimental_builtin(name) S_warn_experimental_builtin(aTHX_ name)
d0364e1b PE	32	static void S_warn_experimental_builtin(pTHX_ const char *name)
929db505 DIM	33	{
	34	/* diag_listed_as: Built-in function '%s' is experimental */
	35	Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BUILTIN),
d0364e1b	36	"Built-in function 'builtin::%s' is experimental", name);
929db505 DIM	37	}
929db505 DIM	38
bb0dc1a9 PE	39	/* These three utilities might want to live elsewhere to be reused from other
	40	* code sometime
	41	*/
	42	#define prepare_export_lexical() S_prepare_export_lexical(aTHX)
	43	static void S_prepare_export_lexical(pTHX)
	44	{
	45	assert(PL_compcv);
	46
	47	/* We need to have PL_comppad / PL_curpad set correctly for lexical importing */
	48	ENTER;
	49	SAVESPTR(PL_comppad_name); PL_comppad_name = PadlistNAMES(CvPADLIST(PL_compcv));
	50	SAVESPTR(PL_comppad); PL_comppad = PadlistARRAY(CvPADLIST(PL_compcv))[1];
	51	SAVESPTR(PL_curpad); PL_curpad = PadARRAY(PL_comppad);
	52	}
	53
	54	#define export_lexical(name, sv) S_export_lexical(aTHX_ name, sv)
	55	static void S_export_lexical(pTHX_ SV name, SV sv)
	56	{
	57	PADOFFSET off = pad_add_name_sv(name, padadd_STATE, 0, 0);
	58	SvREFCNT_dec(PL_curpad[off]);
	59	PL_curpad[off] = SvREFCNT_inc(sv);
	60	}
	61
	62	#define finish_export_lexical() S_finish_export_lexical(aTHX)
	63	static void S_finish_export_lexical(pTHX)
	64	{
	65	intro_my();
	66
	67	LEAVE;
	68	}
	69
	70
6a2e756f PE	71	XS(XS_builtin_true);
	72	XS(XS_builtin_true)
	73	{
	74	dXSARGS;
	75	if(items)
	76	croak_xs_usage(cv, "");
	77	XSRETURN_YES;
	78	}
	79
	80	XS(XS_builtin_false);
	81	XS(XS_builtin_false)
	82	{
	83	dXSARGS;
	84	if(items)
	85	croak_xs_usage(cv, "");
	86	XSRETURN_NO;
	87	}
	88
852c1a84 PE	89	enum {
	90	BUILTIN_CONST_FALSE,
	91	BUILTIN_CONST_TRUE,
	92	};
	93
	94	static OP ck_builtin_const(pTHX_ OP entersubop, GV namegv, SV ckobj)
	95	{
	96	const struct BuiltinFuncDescriptor builtin = NUM2PTR(const struct BuiltinFuncDescriptor , SvUV(ckobj));
	97
	98	SV *prototype = newSVpvs("");
	99	SAVEFREESV(prototype);
	100
	101	assert(entersubop->op_type == OP_ENTERSUB);
	102
	103	entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);
	104
	105	SV *constval;
	106	switch(builtin->ckval) {
	107	case BUILTIN_CONST_FALSE: constval = &PL_sv_no; break;
	108	case BUILTIN_CONST_TRUE: constval = &PL_sv_yes; break;
	109	default:
c0e63b13 KW	110	DIE(aTHX_ "panic: unrecognised builtin_const value %" IVdf,
c0e63b13 KW	111	builtin->ckval);
852c1a84 PE	112	break;
	113	}
	114
	115	op_free(entersubop);
	116
	117	return newSVOP(OP_CONST, 0, constval);
	118	}
	119
6ac93b49 PE	120	XS(XS_builtin_func1_scalar);
6ac93b49 PE	121	XS(XS_builtin_func1_scalar)
6a2e756f PE	122	{
6a2e756f PE	123	dXSARGS;
852c1a84 PE	124	dXSI32;
852c1a84 PE	125
6a2e756f	126	if(items != 1)
852c1a84 PE	127	croak_xs_usage(cv, "arg");
	128
	129	switch(ix) {
5a94615f	130	case OP_IS_BOOL:
d0364e1b	131	warn_experimental_builtin(PL_op_name[ix]);
5a94615f	132	Perl_pp_is_bool(aTHX);
852c1a84	133	break;
6a2e756f	134
5a94615f PE	135	case OP_IS_WEAK:
5a94615f PE	136	Perl_pp_is_weak(aTHX);
6ac93b49 PE	137	break;
6ac93b49 PE	138
d2817bd7 PE	139	case OP_BLESSED:
	140	Perl_pp_blessed(aTHX);
	141	break;
	142
	143	case OP_REFADDR:
	144	Perl_pp_refaddr(aTHX);
	145	break;
	146
	147	case OP_REFTYPE:
	148	Perl_pp_reftype(aTHX);
	149	break;
	150
17a8df70 JR	151	case OP_CEIL:
	152	Perl_pp_ceil(aTHX);
	153	break;
	154
	155	case OP_FLOOR:
	156	Perl_pp_floor(aTHX);
	157	break;
	158
a02b8151 JR	159	case OP_IS_TAINTED:
	160	Perl_pp_is_tainted(aTHX);
	161	break;
	162
7c60f1f7 PE	163	case OP_STRINGIFY:
	164	Perl_pp_stringify(aTHX);
	165	break;
	166
852c1a84	167	default:
c0e63b13	168	Perl_die(aTHX_ "panic: unhandled opcode %" IVdf
730f927d	169	" for xs_builtin_func1_scalar()", (IV) ix);
852c1a84 PE	170	}
	171
	172	XSRETURN(1);
	173	}
	174
42a429a3 KW	175	XS(XS_builtin_trim);
	176	XS(XS_builtin_trim)
	177	{
	178	dXSARGS;
	179
42a429a3 KW	180	if (items != 1) {
	181	croak_xs_usage(cv, "arg");
	182	}
	183
	184	dTARGET;
	185	SV *source = TOPs;
	186	STRLEN len;
	187	const U8 *start;
	188	SV *dest;
	189
	190	SvGETMAGIC(source);
	191
	192	if (SvOK(source))
	193	start = (const U8*)SvPV_nomg_const(source, len);
	194	else {
	195	if (ckWARN(WARN_UNINITIALIZED))
	196	report_uninit(source);
	197	start = (const U8*)"";
	198	len = 0;
	199	}
	200
	201	if (DO_UTF8(source)) {
	202	const U8 *end = start + len;
	203
	204	/* Find the first non-space */
	205	while(len) {
	206	STRLEN thislen;
	207	if (!isSPACE_utf8_safe(start, end))
	208	break;
	209	start += (thislen = UTF8SKIP(start));
	210	len -= thislen;
	211	}
	212
	213	/* Find the final non-space */
	214	STRLEN thislen;
	215	const U8 *cur_end = end;
	216	while ((thislen = is_SPACE_utf8_safe_backwards(cur_end, start))) {
	217	cur_end -= thislen;
	218	}
	219	len -= (end - cur_end);
	220	}
	221	else if (len) {
	222	while(len) {
	223	if (!isSPACE_L1(*start))
	224	break;
	225	start++;
	226	len--;
	227	}
	228
	229	while(len) {
	230	if (!isSPACE_L1(start[len-1]))
	231	break;
	232	len--;
	233	}
	234	}
	235
	236	dest = TARG;
	237
	238	if (SvPOK(dest) && (dest == source)) {
	239	sv_chop(dest, (const char *)start);
	240	SvCUR_set(dest, len);
	241	}
	242	else {
	243	SvUPGRADE(dest, SVt_PV);
244	SvGROW(dest, len + 1);
245
246	Copy(start, SvPVX(dest), len, U8);
247	SvPVX(dest)[len] = '\0';
248	SvPOK_on(dest);
249	SvCUR_set(dest, len);
250
251	if (DO_UTF8(source))
252	SvUTF8_on(dest);
253	else
254	SvUTF8_off(dest);
255
256	if (SvTAINTED(source))
257	SvTAINT(dest);
258	}
259
260	SvSETMAGIC(dest);
261
262	SETs(dest);
263
264	XSRETURN(1);
265	}
266
f846dd12 PE	267	XS(XS_builtin_export_lexically);
	268	XS(XS_builtin_export_lexically)
	269	{
	270	dXSARGS;
	271
d0364e1b	272	warn_experimental_builtin("export_lexically");
f846dd12 PE	273
	274	if(!PL_compcv)
	275	Perl_croak(aTHX_
	276	"export_lexically can only be called at compile time");
	277
	278	if(items % 2)
	279	Perl_croak(aTHX_ "Odd number of elements in export_lexically");
	280
	281	for(int i = 0; i < items; i += 2) {
	282	SV *name = ST(i);
	283	SV *ref = ST(i+1);
	284
	285	if(!SvROK(ref))
	286	/* diag_listed_as: Expected %s reference in export_lexically */
	287	Perl_croak(aTHX_ "Expected a reference in export_lexically");
	288
	289	char sigil = SvPVX(name)[0];
	290	SV *rv = SvRV(ref);
	291
	292	const char *bad = NULL;
	293	switch(sigil) {
	294	default:
	295	/* overwrites the pointer on the stack; but this is fine, the
	296	* caller's value isn't modified */
	297	ST(i) = name = sv_2mortal(Perl_newSVpvf(aTHX_ "&%" SVf, SVfARG(name)));
	298
	299	/* FALLTHROUGH */
	300	case '&':
	301	if(SvTYPE(rv) != SVt_PVCV)
	302	bad = "a CODE";
	303	break;
	304
	305	case '$':
	306	/* Permit any of SVt_NULL to SVt_PVMG. Technically this also
	307	* includes SVt_INVLIST but it isn't thought possible for pureperl
	308	* code to ever manage to see one of those. */
	309	if(SvTYPE(rv) > SVt_PVMG)
	310	bad = "a SCALAR";
	311	break;
	312
	313	case '@':
	314	if(SvTYPE(rv) != SVt_PVAV)
	315	bad = "an ARRAY";
	316	break;
	317
	318	case '%':
	319	if(SvTYPE(rv) != SVt_PVHV)
	320	bad = "a HASH";
	321	break;
	322	}
	323
	324	if(bad)
	325	Perl_croak(aTHX_ "Expected %s reference in export_lexically", bad);
	326	}
	327
	328	prepare_export_lexical();
	329
	330	for(int i = 0; i < items; i += 2) {
	331	SV *name = ST(i);
	332	SV *ref = ST(i+1);
	333
	334	export_lexical(name, SvRV(ref));
	335	}
	336
337	finish_export_lexical();
338	}
339
6ac93b49 PE	340	XS(XS_builtin_func1_void);
	341	XS(XS_builtin_func1_void)
	342	{
	343	dXSARGS;
	344	dXSI32;
	345
	346	if(items != 1)
	347	croak_xs_usage(cv, "arg");
	348
	349	switch(ix) {
	350	case OP_WEAKEN:
	351	Perl_pp_weaken(aTHX);
	352	break;
	353
	354	case OP_UNWEAKEN:
	355	Perl_pp_unweaken(aTHX);
	356	break;
	357
	358	default:
730f927d KW	359	Perl_die(aTHX_ "panic: unhandled opcode %" IVdf
730f927d KW	360	" for xs_builtin_func1_void()", (IV) ix);
6ac93b49 PE	361	}
	362
	363	XSRETURN(0);
	364	}
	365
bd79e3f7 PE	366	XS(XS_builtin_created_as_string)
	367	{
	368	dXSARGS;
	369
	370	if(items != 1)
	371	croak_xs_usage(cv, "arg");
	372
	373	SV *arg = ST(0);
	374	SvGETMAGIC(arg);
	375
	376	/* SV was created as string if it has POK and isn't bool */
	377	ST(0) = boolSV(SvPOK(arg) && !SvIsBOOL(arg));
	378	XSRETURN(1);
	379	}
	380
	381	XS(XS_builtin_created_as_number)
	382	{
	383	dXSARGS;
	384
	385	if(items != 1)
	386	croak_xs_usage(cv, "arg");
	387
	388	SV *arg = ST(0);
	389	SvGETMAGIC(arg);
	390
	391	/* SV was created as number if it has NOK or IOK but not POK and is not bool */
	392	ST(0) = boolSV(SvNIOK(arg) && !SvPOK(arg) && !SvIsBOOL(arg));
	393	XSRETURN(1);
	394	}
	395
852c1a84 PE	396	static OP ck_builtin_func1(pTHX_ OP entersubop, GV namegv, SV ckobj)
	397	{
	398	const struct BuiltinFuncDescriptor builtin = NUM2PTR(const struct BuiltinFuncDescriptor , SvUV(ckobj));
	399
edd58c23	400	if(builtin->is_experimental)
d0364e1b	401	warn_experimental_builtin(builtin->name);
cc4aa213	402
852c1a84 PE	403	SV *prototype = newSVpvs("$");
	404	SAVEFREESV(prototype);
	405
	406	assert(entersubop->op_type == OP_ENTERSUB);
	407
	408	entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);
	409
bd79e3f7 PE	410	OPCODE opcode = builtin->ckval;
	411	if(!opcode)
	412	return entersubop;
	413
852c1a84 PE	414	OP parent = entersubop, pushop, *argop;
	415
	416	pushop = cUNOPx(entersubop)->op_first;
	417	if (!OpHAS_SIBLING(pushop)) {
	418	pushop = cUNOPx(pushop)->op_first;
	419	}
	420
	421	argop = OpSIBLING(pushop);
	422
	423	if (!argop \|\| !OpHAS_SIBLING(argop) \|\| OpHAS_SIBLING(OpSIBLING(argop)))
	424	return entersubop;
	425
	426	(void)op_sibling_splice(parent, pushop, 1, NULL);
	427
1c57e396	428	U8 wantflags = entersubop->op_flags & OPf_WANT;
852c1a84 PE	429
	430	op_free(entersubop);
	431
7c60f1f7 PE	432	if(opcode == OP_STRINGIFY)
	433	/* Even though pp_stringify only looks at TOPs and conceptually works
	434	* on a single argument, it happens to be a LISTOP. I've no idea why
	435	*/
	436	return newLISTOPn(opcode, wantflags,
	437	argop,
	438	NULL);
	439	else
	440	return newUNOP(opcode, wantflags, argop);
6a2e756f PE	441	}
6a2e756f PE	442
10bccff2 PE	443	XS(XS_builtin_indexed)
	444	{
	445	dXSARGS;
	446
	447	switch(GIMME_V) {
	448	case G_VOID:
	449	Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
	450	"Useless use of %s in void context", "builtin::indexed");
	451	XSRETURN(0);
	452
	453	case G_SCALAR:
	454	Perl_ck_warner(aTHX_ packWARN(WARN_SCALAR),
	455	"Useless use of %s in scalar context", "builtin::indexed");
	456	ST(0) = sv_2mortal(newSViv(items * 2));
	457	XSRETURN(1);
	458
	459	case G_LIST:
	460	break;
	461	}
	462
	463	SSize_t retcount = items * 2;
	464	EXTEND(SP, retcount);
	465
	466	/* Copy from [items-1] down to [0] so we don't have to make
	467	* temporary copies */
	468	for(SSize_t index = items - 1; index >= 0; index--) {
	469	/* Copy, not alias */
	470	ST(index * 2 + 1) = sv_mortalcopy(ST(index));
	471	ST(index * 2) = sv_2mortal(newSViv(index));
	472	}
	473
	474	XSRETURN(retcount);
	475	}
	476
3c48288d MF	477	XS(XS_builtin_load_module);
	478	XS(XS_builtin_load_module)
	479	{
	480	dXSARGS;
	481	if (items != 1)
	482	croak_xs_usage(cv, "arg");
	483	SV *module_name = newSVsv(ST(0));
	484	if (!SvPOK(module_name)) {
	485	SvREFCNT_dec(module_name);
	486	croak_xs_usage(cv, "defined string");
	487	}
	488	load_module(PERL_LOADMOD_NOIMPORT, module_name, NULL, NULL);
	489	/* The loaded module's name is left intentionally on the stack for the
	490	* caller's benefit, and becomes load_module's return value. */
	491	XSRETURN(1);
	492	}
	493
10bccff2 PE	494	static OP ck_builtin_funcN(pTHX_ OP entersubop, GV namegv, SV ckobj)
	495	{
	496	const struct BuiltinFuncDescriptor builtin = NUM2PTR(const struct BuiltinFuncDescriptor , SvUV(ckobj));
	497
edd58c23	498	if(builtin->is_experimental)
d0364e1b	499	warn_experimental_builtin(builtin->name);
10bccff2 PE	500
	501	SV *prototype = newSVpvs("@");
	502	SAVEFREESV(prototype);
	503
	504	assert(entersubop->op_type == OP_ENTERSUB);
	505
	506	entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);
	507	return entersubop;
	508	}
	509
a64a1b91 DIM	510	static const char builtin_not_recognised[] = "'%" SVf "' is not recognised as a builtin function";
a64a1b91 DIM	511
5a94e094 PE	512	#define NO_BUNDLE SHORTVER(255,255)
5a94e094 PE	513
852c1a84 PE	514	static const struct BuiltinFuncDescriptor builtins[] = {
852c1a84 PE	515	/* constants */
5a94e094 PE	516	{ "true", SHORTVER(5,39), &XS_builtin_true, &ck_builtin_const, BUILTIN_CONST_TRUE, false },
5a94e094 PE	517	{ "false", SHORTVER(5,39), &XS_builtin_false, &ck_builtin_const, BUILTIN_CONST_FALSE, false },
852c1a84 PE	518
852c1a84 PE	519	/* unary functions */
5a94e094 PE	520	{ "is_bool", NO_BUNDLE, &XS_builtin_func1_scalar, &ck_builtin_func1, OP_IS_BOOL, true },
	521	{ "weaken", SHORTVER(5,39), &XS_builtin_func1_void, &ck_builtin_func1, OP_WEAKEN, false },
	522	{ "unweaken", SHORTVER(5,39), &XS_builtin_func1_void, &ck_builtin_func1, OP_UNWEAKEN, false },
	523	{ "is_weak", SHORTVER(5,39), &XS_builtin_func1_scalar, &ck_builtin_func1, OP_IS_WEAK, false },
	524	{ "blessed", SHORTVER(5,39), &XS_builtin_func1_scalar, &ck_builtin_func1, OP_BLESSED, false },
	525	{ "refaddr", SHORTVER(5,39), &XS_builtin_func1_scalar, &ck_builtin_func1, OP_REFADDR, false },
	526	{ "reftype", SHORTVER(5,39), &XS_builtin_func1_scalar, &ck_builtin_func1, OP_REFTYPE, false },
	527	{ "ceil", SHORTVER(5,39), &XS_builtin_func1_scalar, &ck_builtin_func1, OP_CEIL, false },
	528	{ "floor", SHORTVER(5,39), &XS_builtin_func1_scalar, &ck_builtin_func1, OP_FLOOR, false },
	529	{ "is_tainted", SHORTVER(5,39), &XS_builtin_func1_scalar, &ck_builtin_func1, OP_IS_TAINTED, false },
	530	{ "trim", SHORTVER(5,39), &XS_builtin_trim, &ck_builtin_func1, 0, false },
	531	{ "stringify", NO_BUNDLE, &XS_builtin_func1_scalar, &ck_builtin_func1, OP_STRINGIFY, true },
	532
	533	{ "created_as_string", NO_BUNDLE, &XS_builtin_created_as_string, &ck_builtin_func1, 0, true },
	534	{ "created_as_number", NO_BUNDLE, &XS_builtin_created_as_number, &ck_builtin_func1, 0, true },
bd79e3f7	535
3c48288d MF	536	{ "load_module", NO_BUNDLE, &XS_builtin_load_module, &ck_builtin_func1, 0, true },
3c48288d MF	537
10bccff2	538	/* list functions */
5a94e094 PE	539	{ "indexed", SHORTVER(5,39), &XS_builtin_indexed, &ck_builtin_funcN, 0, false },
5a94e094 PE	540	{ "export_lexically", NO_BUNDLE, &XS_builtin_export_lexically, NULL, 0, true },
cb6b3bdb	541
5a94e094	542	{ NULL, 0, NULL, NULL, 0, false }
852c1a84 PE	543	};
852c1a84 PE	544
4f5a4bf5	545	static bool S_parse_version(const char vstr, const char vend, UV vmajor, UV vminor)
5a94e094 PE	546	{
	547	/* Parse a string like "5.35" to yield 5 and 35. Ignores an optional
	548	* trailing third component e.g. "5.35.7". Returns false on parse errors.
	549	*/
	550
4f5a4bf5 TC	551	const char *end = vend;
	552	if (!grok_atoUV(vstr, vmajor, &end))
	553	return FALSE;
	554
	555	vstr = end;
	556	if (*vstr++ != '.')
	557	return FALSE;
5a94e094	558
4f5a4bf5 TC	559	end = vend;
4f5a4bf5 TC	560	if (!grok_atoUV(vstr, vminor, &end))
5a94e094 PE	561	return FALSE;
	562
	563	if(*vminor > 255)
	564	return FALSE;
	565
4f5a4bf5	566	vstr = end;
5a94e094 PE	567
	568	if(vstr[0] == '.') {
	569	vstr++;
	570
4f5a4bf5 TC	571	UV _dummy;
4f5a4bf5 TC	572	if(!grok_atoUV(vstr, &_dummy, &end))
5a94e094 PE	573	return FALSE;
	574	if(_dummy > 255)
	575	return FALSE;
	576
4f5a4bf5	577	vstr = end;
5a94e094 PE	578	}
5a94e094 PE	579
c728cf57	580	if(vstr != vend)
5a94e094 PE	581	return FALSE;
	582
	583	return TRUE;
	584	}
	585
	586	#define import_sym(sym) S_import_sym(aTHX_ sym)
	587	static void S_import_sym(pTHX_ SV *sym)
	588	{
	589	SV *ampname = sv_2mortal(Perl_newSVpvf(aTHX_ "&%" SVf, SVfARG(sym)));
	590	SV *fqname = sv_2mortal(Perl_newSVpvf(aTHX_ "builtin::%" SVf, SVfARG(sym)));
	591
	592	CV *cv = get_cv(SvPV_nolen(fqname), SvUTF8(fqname) ? SVf_UTF8 : 0);
	593	if(!cv)
	594	Perl_croak(aTHX_ builtin_not_recognised, sym);
	595
	596	export_lexical(ampname, (SV *)cv);
	597	}
	598
	599	#define import_builtin_bundle(ver) S_import_builtin_bundle(aTHX_ ver)
	600	static void S_import_builtin_bundle(pTHX_ U16 ver)
	601	{
	602	for(int i = 0; builtins[i].name; i++) {
	603	if(builtins[i].since_ver <= ver)
	604	import_sym(newSVpvn_flags(builtins[i].name, strlen(builtins[i].name), SVs_TEMP));
	605	}
	606	}
	607
6a2e756f PE	608	XS(XS_builtin_import);
	609	XS(XS_builtin_import)
	610	{
	611	dXSARGS;
	612
	613	if(!PL_compcv)
	614	Perl_croak(aTHX_
2302ea7b	615	"builtin::import can only be called at compile time");
6a2e756f	616
bb0dc1a9	617	prepare_export_lexical();
6a2e756f PE	618
	619	for(int i = 1; i < items; i++) {
	620	SV *sym = ST(i);
4f5a4bf5 TC	621	STRLEN symlen;
4f5a4bf5 TC	622	const char *sympv = SvPV(sym, symlen);
92ddeac0	623	if(strEQ(sympv, "import") \|\| strEQ(sympv, "unimport"))
a64a1b91	624	Perl_croak(aTHX_ builtin_not_recognised, sym);
6a2e756f	625
5a94e094	626	if(sympv[0] == ':') {
4f5a4bf5 TC	627	UV vmajor, vminor;
4f5a4bf5 TC	628	if(!S_parse_version(sympv + 1, sympv + symlen, &vmajor, &vminor))
c728cf57	629	Perl_croak(aTHX_ "Invalid version bundle %" SVf_QUOTEDPREFIX, sym);
6a2e756f	630
5a94e094 PE	631	U16 want_ver = SHORTVER(vmajor, vminor);
	632
	633	if(want_ver < SHORTVER(5,39) \|\|
	634	/* round up devel version to next major release; e.g. 5.39 => 5.40 */
	635	want_ver > SHORTVER(PERL_REVISION, PERL_VERSION + (PERL_VERSION % 2)))
	636	Perl_croak(aTHX_ "Builtin version bundle \"%s\" is not supported by Perl " PERL_VERSION_STRING,
	637	sympv);
	638
	639	import_builtin_bundle(want_ver);
	640
	641	continue;
	642	}
6a2e756f	643
5a94e094	644	import_sym(sym);
6a2e756f PE	645	}
6a2e756f PE	646
bb0dc1a9	647	finish_export_lexical();
6a2e756f PE	648	}
6a2e756f PE	649
92ddeac0 PE	650	XS(XS_builtin_unimport);
	651	XS(XS_builtin_unimport)
	652	{
	653	dXSARGS;
	654
	655	if(!PL_compcv)
	656	Perl_croak(aTHX_
	657	"builtin::unimport can only be called at compile time");
	658
	659	prepare_export_lexical();
	660
	661	for(int i = 1; i < items; i++) {
	662	SV *sym = ST(i);
	663	const char *sympv = SvPV_nolen(sym);
	664	if(strEQ(sympv, "import") \|\| strEQ(sympv, "unimport"))
	665	Perl_croak(aTHX_ builtin_not_recognised, sym);
	666
	667	SV *ampname = sv_2mortal(Perl_newSVpvf(aTHX_ "&%" SVf, SVfARG(sym)));
	668	SV *fqname = sv_2mortal(Perl_newSVpvf(aTHX_ "builtin::%" SVf, SVfARG(sym)));
	669
	670	CV *cv = get_cv(SvPV_nolen(fqname), SvUTF8(fqname) ? SVf_UTF8 : 0);
	671	if(!cv)
	672	Perl_croak(aTHX_ builtin_not_recognised, sym);
	673
	674	PADOFFSET off = pad_findmy_sv(ampname, 0);
	675	if((off == NOT_IN_PAD) \|\|
	676	(PL_curpad[off] != (SV *)cv))
	677	Perl_croak(aTHX_
	678	"'%" SVf "' does not appear to be an imported builtin function", SVfARG(ampname));
	679
	680	/* Add a tombstone entry */
	681	/* TODO: If the pad entry we found is going to go out of scope at the
	682	* same time as this tombstone would, we could not bother adding the
	683	* tombstone and instead COP_SEQ_MAX_HIGH_set() on the padname to
	684	* clear it.
	685	*/
	686	off = pad_add_name_sv(ampname, padadd_STATE\|padadd_TOMBSTONE, 0, 0);
	687	SvREFCNT_dec(PL_curpad[off]);
	688	}
	689
	690	COP_SEQMAX_INC;
	691	finish_export_lexical();
	692	}
	693
6a2e756f PE	694	void
	695	Perl_boot_core_builtin(pTHX)
	696	{
852c1a84 PE	697	I32 i;
	698	for(i = 0; builtins[i].name; i++) {
	699	const struct BuiltinFuncDescriptor *builtin = &builtins[i];
	700
	701	const char *proto = NULL;
	702	if(builtin->checker == &ck_builtin_const)
	703	proto = "";
	704	else if(builtin->checker == &ck_builtin_func1)
	705	proto = "$";
8be87d1d JR	706	else if(builtin->checker == &ck_builtin_funcN)
8be87d1d JR	707	proto = "@";
852c1a84	708
d0364e1b PE	709	SV *name = newSVpvs_flags("builtin::", SVs_TEMP);
	710	sv_catpv(name, builtin->name);
	711	CV *cv = newXS_flags(SvPV_nolen(name), builtin->xsub, __FILE__, proto, 0);
852c1a84 PE	712	XSANY.any_i32 = builtin->ckval;
852c1a84 PE	713
a5773895 DM	714	if ( builtin->xsub == &XS_builtin_func1_void
	715	\|\| builtin->xsub == &XS_builtin_func1_scalar)
	716	{
	717	/* these XS functions just call out to the relevant pp()
	718	* functions, so they must operate with a reference-counted
	719	* stack if the pp() do too.
	720	*/
	721	CvXS_RCSTACK_on(cv);
	722	}
	723
852c1a84 PE	724	if(builtin->checker) {
	725	cv_set_call_checker_flags(cv, builtin->checker, newSVuv(PTR2UV(builtin)), 0);
	726	}
	727	}
6a2e756f	728
92ddeac0 PE	729	newXS_flags("builtin::import", &XS_builtin_import, __FILE__, NULL, 0);
92ddeac0 PE	730	newXS_flags("builtin::unimport", &XS_builtin_unimport, __FILE__, NULL, 0);
6a2e756f PE	731	}
	732
	733	/*
	734	* ex: set ts=8 sts=4 sw=4 et:
	735	*/