[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"

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

#define warn_experimental_builtin(name, prefix) S_warn_experimental_builtin(aTHX_ name, prefix)
static void S_warn_experimental_builtin(pTHX_ const char *name, bool prefix)
{
    /* diag_listed_as: Built-in function '%s' is experimental */
    Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BUILTIN),
                     "Built-in function '%s%s' is experimental",
                     prefix ? "builtin::" : "", 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;
    warn_experimental_builtin("true", true);
    if(items)
        croak_xs_usage(cv, "");
    XSRETURN_YES;
}

XS(XS_builtin_false);
XS(XS_builtin_false)
{
    dXSARGS;
    warn_experimental_builtin("false", true);
    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));

    warn_experimental_builtin(builtin->name, false);

    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;

    warn_experimental_builtin(PL_op_name[ix], true);

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

    switch(ix) {
        case OP_IS_BOOL:
            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;

        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;

    warn_experimental_builtin("trim", true);

    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", true);

    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;

    warn_experimental_builtin(PL_op_name[ix], true);

    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));

    warn_experimental_builtin(builtin->name, false);

    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);

    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);
}

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

    warn_experimental_builtin(builtin->name, false);

    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";

static const struct BuiltinFuncDescriptor builtins[] = {
    /* constants */
    { "builtin::true",   &XS_builtin_true,   &ck_builtin_const, BUILTIN_CONST_TRUE  },
    { "builtin::false",  &XS_builtin_false,  &ck_builtin_const, BUILTIN_CONST_FALSE },

    /* unary functions */
    { "builtin::is_bool",    &XS_builtin_func1_scalar, &ck_builtin_func1, OP_IS_BOOL    },
    { "builtin::weaken",     &XS_builtin_func1_void,   &ck_builtin_func1, OP_WEAKEN     },
    { "builtin::unweaken",   &XS_builtin_func1_void,   &ck_builtin_func1, OP_UNWEAKEN   },
    { "builtin::is_weak",    &XS_builtin_func1_scalar, &ck_builtin_func1, OP_IS_WEAK    },
    { "builtin::blessed",    &XS_builtin_func1_scalar, &ck_builtin_func1, OP_BLESSED    },
    { "builtin::refaddr",    &XS_builtin_func1_scalar, &ck_builtin_func1, OP_REFADDR    },
    { "builtin::reftype",    &XS_builtin_func1_scalar, &ck_builtin_func1, OP_REFTYPE    },
    { "builtin::ceil",       &XS_builtin_func1_scalar, &ck_builtin_func1, OP_CEIL       },
    { "builtin::floor",      &XS_builtin_func1_scalar, &ck_builtin_func1, OP_FLOOR      },
    { "builtin::is_tainted", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_IS_TAINTED },
    { "builtin::trim",       &XS_builtin_trim,         &ck_builtin_func1, 0 },

    { "builtin::created_as_string", &XS_builtin_created_as_string, &ck_builtin_func1, 0 },
    { "builtin::created_as_number", &XS_builtin_created_as_number, &ck_builtin_func1, 0 },

    /* list functions */
    { "builtin::indexed", &XS_builtin_indexed, &ck_builtin_funcN, 0 },
    { "builtin::export_lexically", &XS_builtin_export_lexically, NULL, 0 },
    { 0 }
};

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);
        if(strEQ(SvPV_nolen(sym), "import"))
            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);

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

    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 = "$";

        CV *cv = newXS_flags(builtin->name, builtin->xsub, __FILE__, proto, 0);
        XSANY.any_i32 = builtin->ckval;

        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);
}

/*
 * 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
852c1a84 PE	19	struct BuiltinFuncDescriptor {
	20	const char *name;
	21	XSUBADDR_t xsub;
	22	OP (checker)(pTHX_ OP , GV , SV *);
	23	IV ckval;
	24	};
	25
929db505 DIM	26	#define warn_experimental_builtin(name, prefix) S_warn_experimental_builtin(aTHX_ name, prefix)
	27	static void S_warn_experimental_builtin(pTHX_ const char *name, bool prefix)
	28	{
	29	/* diag_listed_as: Built-in function '%s' is experimental */
	30	Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BUILTIN),
	31	"Built-in function '%s%s' is experimental",
	32	prefix ? "builtin::" : "", name);
	33	}
	34
bb0dc1a9 PE	35	/* These three utilities might want to live elsewhere to be reused from other
	36	* code sometime
	37	*/
	38	#define prepare_export_lexical() S_prepare_export_lexical(aTHX)
	39	static void S_prepare_export_lexical(pTHX)
	40	{
	41	assert(PL_compcv);
	42
	43	/* We need to have PL_comppad / PL_curpad set correctly for lexical importing */
	44	ENTER;
	45	SAVESPTR(PL_comppad_name); PL_comppad_name = PadlistNAMES(CvPADLIST(PL_compcv));
	46	SAVESPTR(PL_comppad); PL_comppad = PadlistARRAY(CvPADLIST(PL_compcv))[1];
	47	SAVESPTR(PL_curpad); PL_curpad = PadARRAY(PL_comppad);
	48	}
	49
	50	#define export_lexical(name, sv) S_export_lexical(aTHX_ name, sv)
	51	static void S_export_lexical(pTHX_ SV name, SV sv)
	52	{
	53	PADOFFSET off = pad_add_name_sv(name, padadd_STATE, 0, 0);
	54	SvREFCNT_dec(PL_curpad[off]);
	55	PL_curpad[off] = SvREFCNT_inc(sv);
	56	}
	57
	58	#define finish_export_lexical() S_finish_export_lexical(aTHX)
	59	static void S_finish_export_lexical(pTHX)
	60	{
	61	intro_my();
	62
	63	LEAVE;
	64	}
	65
	66
6a2e756f PE	67	XS(XS_builtin_true);
	68	XS(XS_builtin_true)
	69	{
	70	dXSARGS;
929db505	71	warn_experimental_builtin("true", true);
6a2e756f PE	72	if(items)
	73	croak_xs_usage(cv, "");
	74	XSRETURN_YES;
	75	}
	76
	77	XS(XS_builtin_false);
	78	XS(XS_builtin_false)
	79	{
	80	dXSARGS;
929db505	81	warn_experimental_builtin("false", true);
6a2e756f PE	82	if(items)
	83	croak_xs_usage(cv, "");
	84	XSRETURN_NO;
	85	}
	86
852c1a84 PE	87	enum {
	88	BUILTIN_CONST_FALSE,
	89	BUILTIN_CONST_TRUE,
	90	};
	91
	92	static OP ck_builtin_const(pTHX_ OP entersubop, GV namegv, SV ckobj)
	93	{
	94	const struct BuiltinFuncDescriptor builtin = NUM2PTR(const struct BuiltinFuncDescriptor , SvUV(ckobj));
	95
929db505	96	warn_experimental_builtin(builtin->name, false);
cc4aa213	97
852c1a84 PE	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
929db505 DIM	126	warn_experimental_builtin(PL_op_name[ix], true);
929db505 DIM	127
6a2e756f	128	if(items != 1)
852c1a84 PE	129	croak_xs_usage(cv, "arg");
	130
	131	switch(ix) {
5a94615f PE	132	case OP_IS_BOOL:
5a94615f PE	133	Perl_pp_is_bool(aTHX);
852c1a84	134	break;
6a2e756f	135
5a94615f PE	136	case OP_IS_WEAK:
5a94615f PE	137	Perl_pp_is_weak(aTHX);
6ac93b49 PE	138	break;
6ac93b49 PE	139
d2817bd7 PE	140	case OP_BLESSED:
	141	Perl_pp_blessed(aTHX);
	142	break;
	143
	144	case OP_REFADDR:
	145	Perl_pp_refaddr(aTHX);
	146	break;
	147
	148	case OP_REFTYPE:
	149	Perl_pp_reftype(aTHX);
	150	break;
	151
17a8df70 JR	152	case OP_CEIL:
	153	Perl_pp_ceil(aTHX);
	154	break;
	155
	156	case OP_FLOOR:
	157	Perl_pp_floor(aTHX);
	158	break;
	159
a02b8151 JR	160	case OP_IS_TAINTED:
	161	Perl_pp_is_tainted(aTHX);
	162	break;
	163
852c1a84	164	default:
c0e63b13	165	Perl_die(aTHX_ "panic: unhandled opcode %" IVdf
730f927d	166	" for xs_builtin_func1_scalar()", (IV) ix);
852c1a84 PE	167	}
	168
	169	XSRETURN(1);
	170	}
	171
42a429a3 KW	172	XS(XS_builtin_trim);
	173	XS(XS_builtin_trim)
	174	{
	175	dXSARGS;
	176
	177	warn_experimental_builtin("trim", true);
	178
	179	if (items != 1) {
	180	croak_xs_usage(cv, "arg");
	181	}
	182
	183	dTARGET;
	184	SV *source = TOPs;
	185	STRLEN len;
	186	const U8 *start;
	187	SV *dest;
	188
	189	SvGETMAGIC(source);
	190
	191	if (SvOK(source))
	192	start = (const U8*)SvPV_nomg_const(source, len);
	193	else {
	194	if (ckWARN(WARN_UNINITIALIZED))
	195	report_uninit(source);
	196	start = (const U8*)"";
	197	len = 0;
	198	}
	199
	200	if (DO_UTF8(source)) {
	201	const U8 *end = start + len;
	202
	203	/* Find the first non-space */
	204	while(len) {
	205	STRLEN thislen;
	206	if (!isSPACE_utf8_safe(start, end))
	207	break;
	208	start += (thislen = UTF8SKIP(start));
	209	len -= thislen;
	210	}
	211
	212	/* Find the final non-space */
	213	STRLEN thislen;
	214	const U8 *cur_end = end;
	215	while ((thislen = is_SPACE_utf8_safe_backwards(cur_end, start))) {
	216	cur_end -= thislen;
	217	}
	218	len -= (end - cur_end);
	219	}
	220	else if (len) {
	221	while(len) {
	222	if (!isSPACE_L1(*start))
	223	break;
	224	start++;
	225	len--;
	226	}
	227
	228	while(len) {
	229	if (!isSPACE_L1(start[len-1]))
	230	break;
	231	len--;
	232	}
	233	}
	234
	235	dest = TARG;
236
237	if (SvPOK(dest) && (dest == source)) {
238	sv_chop(dest, (const char *)start);
239	SvCUR_set(dest, len);
240	}
241	else {
242	SvUPGRADE(dest, SVt_PV);
243	SvGROW(dest, len + 1);
244
245	Copy(start, SvPVX(dest), len, U8);
246	SvPVX(dest)[len] = '\0';
247	SvPOK_on(dest);
248	SvCUR_set(dest, len);
249
250	if (DO_UTF8(source))
251	SvUTF8_on(dest);
252	else
253	SvUTF8_off(dest);
254
255	if (SvTAINTED(source))
256	SvTAINT(dest);
257	}
258
259	SvSETMAGIC(dest);
260
261	SETs(dest);
262
263	XSRETURN(1);
264	}
265
f846dd12 PE	266	XS(XS_builtin_export_lexically);
	267	XS(XS_builtin_export_lexically)
	268	{
	269	dXSARGS;
	270
	271	warn_experimental_builtin("export_lexically", true);
	272
	273	if(!PL_compcv)
	274	Perl_croak(aTHX_
	275	"export_lexically can only be called at compile time");
	276
	277	if(items % 2)
	278	Perl_croak(aTHX_ "Odd number of elements in export_lexically");
	279
	280	for(int i = 0; i < items; i += 2) {
	281	SV *name = ST(i);
	282	SV *ref = ST(i+1);
	283
	284	if(!SvROK(ref))
	285	/* diag_listed_as: Expected %s reference in export_lexically */
	286	Perl_croak(aTHX_ "Expected a reference in export_lexically");
	287
	288	char sigil = SvPVX(name)[0];
	289	SV *rv = SvRV(ref);
	290
	291	const char *bad = NULL;
	292	switch(sigil) {
	293	default:
	294	/* overwrites the pointer on the stack; but this is fine, the
	295	* caller's value isn't modified */
	296	ST(i) = name = sv_2mortal(Perl_newSVpvf(aTHX_ "&%" SVf, SVfARG(name)));
	297
	298	/* FALLTHROUGH */
	299	case '&':
	300	if(SvTYPE(rv) != SVt_PVCV)
	301	bad = "a CODE";
	302	break;
	303
	304	case '$':
	305	/* Permit any of SVt_NULL to SVt_PVMG. Technically this also
	306	* includes SVt_INVLIST but it isn't thought possible for pureperl
	307	* code to ever manage to see one of those. */
	308	if(SvTYPE(rv) > SVt_PVMG)
	309	bad = "a SCALAR";
	310	break;
	311
	312	case '@':
	313	if(SvTYPE(rv) != SVt_PVAV)
	314	bad = "an ARRAY";
	315	break;
	316
	317	case '%':
	318	if(SvTYPE(rv) != SVt_PVHV)
	319	bad = "a HASH";
	320	break;
	321	}
	322
	323	if(bad)
	324	Perl_croak(aTHX_ "Expected %s reference in export_lexically", bad);
	325	}
	326
	327	prepare_export_lexical();
	328
	329	for(int i = 0; i < items; i += 2) {
330	SV *name = ST(i);
331	SV *ref = ST(i+1);
332
333	export_lexical(name, SvRV(ref));
334	}
335
336	finish_export_lexical();
337	}
338
6ac93b49 PE	339	XS(XS_builtin_func1_void);
	340	XS(XS_builtin_func1_void)
	341	{
	342	dXSARGS;
	343	dXSI32;
	344
929db505 DIM	345	warn_experimental_builtin(PL_op_name[ix], true);
929db505 DIM	346
6ac93b49 PE	347	if(items != 1)
	348	croak_xs_usage(cv, "arg");
	349
	350	switch(ix) {
	351	case OP_WEAKEN:
	352	Perl_pp_weaken(aTHX);
	353	break;
	354
	355	case OP_UNWEAKEN:
	356	Perl_pp_unweaken(aTHX);
	357	break;
	358
	359	default:
730f927d KW	360	Perl_die(aTHX_ "panic: unhandled opcode %" IVdf
730f927d KW	361	" for xs_builtin_func1_void()", (IV) ix);
6ac93b49 PE	362	}
	363
	364	XSRETURN(0);
	365	}
	366
bd79e3f7 PE	367	XS(XS_builtin_created_as_string)
	368	{
	369	dXSARGS;
	370
	371	if(items != 1)
	372	croak_xs_usage(cv, "arg");
	373
	374	SV *arg = ST(0);
	375	SvGETMAGIC(arg);
	376
	377	/* SV was created as string if it has POK and isn't bool */
	378	ST(0) = boolSV(SvPOK(arg) && !SvIsBOOL(arg));
	379	XSRETURN(1);
	380	}
	381
	382	XS(XS_builtin_created_as_number)
	383	{
	384	dXSARGS;
	385
	386	if(items != 1)
	387	croak_xs_usage(cv, "arg");
	388
	389	SV *arg = ST(0);
	390	SvGETMAGIC(arg);
	391
	392	/* SV was created as number if it has NOK or IOK but not POK and is not bool */
	393	ST(0) = boolSV(SvNIOK(arg) && !SvPOK(arg) && !SvIsBOOL(arg));
	394	XSRETURN(1);
	395	}
	396
852c1a84 PE	397	static OP ck_builtin_func1(pTHX_ OP entersubop, GV namegv, SV ckobj)
	398	{
	399	const struct BuiltinFuncDescriptor builtin = NUM2PTR(const struct BuiltinFuncDescriptor , SvUV(ckobj));
	400
929db505	401	warn_experimental_builtin(builtin->name, false);
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
1c57e396	432	return newUNOP(opcode, wantflags, argop);
6a2e756f PE	433	}
6a2e756f PE	434
10bccff2 PE	435	XS(XS_builtin_indexed)
	436	{
	437	dXSARGS;
	438
	439	switch(GIMME_V) {
	440	case G_VOID:
	441	Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
	442	"Useless use of %s in void context", "builtin::indexed");
	443	XSRETURN(0);
	444
	445	case G_SCALAR:
	446	Perl_ck_warner(aTHX_ packWARN(WARN_SCALAR),
	447	"Useless use of %s in scalar context", "builtin::indexed");
	448	ST(0) = sv_2mortal(newSViv(items * 2));
	449	XSRETURN(1);
	450
	451	case G_LIST:
	452	break;
	453	}
	454
	455	SSize_t retcount = items * 2;
	456	EXTEND(SP, retcount);
	457
	458	/* Copy from [items-1] down to [0] so we don't have to make
	459	* temporary copies */
	460	for(SSize_t index = items - 1; index >= 0; index--) {
	461	/* Copy, not alias */
	462	ST(index * 2 + 1) = sv_mortalcopy(ST(index));
	463	ST(index * 2) = sv_2mortal(newSViv(index));
	464	}
	465
	466	XSRETURN(retcount);
	467	}
	468
	469	static OP ck_builtin_funcN(pTHX_ OP entersubop, GV namegv, SV ckobj)
	470	{
	471	const struct BuiltinFuncDescriptor builtin = NUM2PTR(const struct BuiltinFuncDescriptor , SvUV(ckobj));
	472
	473	warn_experimental_builtin(builtin->name, false);
	474
	475	SV *prototype = newSVpvs("@");
	476	SAVEFREESV(prototype);
	477
	478	assert(entersubop->op_type == OP_ENTERSUB);
	479
	480	entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);
	481	return entersubop;
	482	}
	483
a64a1b91 DIM	484	static const char builtin_not_recognised[] = "'%" SVf "' is not recognised as a builtin function";
a64a1b91 DIM	485
852c1a84 PE	486	static const struct BuiltinFuncDescriptor builtins[] = {
	487	/* constants */
	488	{ "builtin::true", &XS_builtin_true, &ck_builtin_const, BUILTIN_CONST_TRUE },
	489	{ "builtin::false", &XS_builtin_false, &ck_builtin_const, BUILTIN_CONST_FALSE },
	490
	491	/* unary functions */
a02b8151 JR	492	{ "builtin::is_bool", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_IS_BOOL },
	493	{ "builtin::weaken", &XS_builtin_func1_void, &ck_builtin_func1, OP_WEAKEN },
	494	{ "builtin::unweaken", &XS_builtin_func1_void, &ck_builtin_func1, OP_UNWEAKEN },
	495	{ "builtin::is_weak", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_IS_WEAK },
	496	{ "builtin::blessed", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_BLESSED },
	497	{ "builtin::refaddr", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_REFADDR },
	498	{ "builtin::reftype", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_REFTYPE },
	499	{ "builtin::ceil", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_CEIL },
	500	{ "builtin::floor", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_FLOOR },
	501	{ "builtin::is_tainted", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_IS_TAINTED },
35c98d68	502	{ "builtin::trim", &XS_builtin_trim, &ck_builtin_func1, 0 },
10bccff2	503
bd79e3f7 PE	504	{ "builtin::created_as_string", &XS_builtin_created_as_string, &ck_builtin_func1, 0 },
	505	{ "builtin::created_as_number", &XS_builtin_created_as_number, &ck_builtin_func1, 0 },
	506
10bccff2 PE	507	/* list functions */
10bccff2 PE	508	{ "builtin::indexed", &XS_builtin_indexed, &ck_builtin_funcN, 0 },
f846dd12	509	{ "builtin::export_lexically", &XS_builtin_export_lexically, NULL, 0 },
852c1a84 PE	510	{ 0 }
	511	};
	512
6a2e756f PE	513	XS(XS_builtin_import);
	514	XS(XS_builtin_import)
	515	{
	516	dXSARGS;
	517
	518	if(!PL_compcv)
	519	Perl_croak(aTHX_
2302ea7b	520	"builtin::import can only be called at compile time");
6a2e756f	521
bb0dc1a9	522	prepare_export_lexical();
6a2e756f PE	523
	524	for(int i = 1; i < items; i++) {
	525	SV *sym = ST(i);
a64a1b91 DIM	526	if(strEQ(SvPV_nolen(sym), "import"))
a64a1b91 DIM	527	Perl_croak(aTHX_ builtin_not_recognised, sym);
6a2e756f PE	528
6a2e756f PE	529	SV *ampname = sv_2mortal(Perl_newSVpvf(aTHX_ "&%" SVf, SVfARG(sym)));
bb0dc1a9	530	SV *fqname = sv_2mortal(Perl_newSVpvf(aTHX_ "builtin::%" SVf, SVfARG(sym)));
6a2e756f PE	531
6a2e756f PE	532	CV *cv = get_cv(SvPV_nolen(fqname), SvUTF8(fqname) ? SVf_UTF8 : 0);
a64a1b91 DIM	533	if(!cv)
a64a1b91 DIM	534	Perl_croak(aTHX_ builtin_not_recognised, sym);
6a2e756f	535
bb0dc1a9	536	export_lexical(ampname, (SV *)cv);
6a2e756f PE	537	}
6a2e756f PE	538
bb0dc1a9	539	finish_export_lexical();
6a2e756f PE	540	}
	541
	542	void
	543	Perl_boot_core_builtin(pTHX)
	544	{
852c1a84 PE	545	I32 i;
	546	for(i = 0; builtins[i].name; i++) {
	547	const struct BuiltinFuncDescriptor *builtin = &builtins[i];
	548
	549	const char *proto = NULL;
	550	if(builtin->checker == &ck_builtin_const)
	551	proto = "";
	552	else if(builtin->checker == &ck_builtin_func1)
	553	proto = "$";
	554
	555	CV *cv = newXS_flags(builtin->name, builtin->xsub, __FILE__, proto, 0);
	556	XSANY.any_i32 = builtin->ckval;
	557
	558	if(builtin->checker) {
	559	cv_set_call_checker_flags(cv, builtin->checker, newSVuv(PTR2UV(builtin)), 0);
	560	}
	561	}
6a2e756f PE	562
	563	newXS_flags("builtin::import", &XS_builtin_import, __FILE__, NULL, 0);
	564	}
	565
	566	/*
	567	* ex: set ts=8 sts=4 sw=4 et:
	568	*/