[p5sagit/p5-mst-13.2.git] / ext / Opcode / Opcode.xs

#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

/* PL_maxo shouldn't differ from MAXO but leave room anyway (see BOOT:)	*/
#define OP_MASK_BUF_SIZE (MAXO + 100)

/* XXX op_named_bits and opset_all are never freed */
static HV *op_named_bits;	/* cache shared for whole process	*/
static SV *opset_all;		/* mask with all bits set		*/
static IV  opset_len;		/* length of opmasks in bytes		*/
static int opcode_debug = 0;

static SV  *new_opset (pTHX_ SV *old_opset);
static int  verify_opset (pTHX_ SV *opset, int fatal);
static void set_opset_bits (pTHX_ char *bitmap, SV *bitspec, int on, char *opname);
static void put_op_bitspec (pTHX_ char *optag,  STRLEN len, SV *opset);
static SV  *get_op_bitspec (pTHX_ char *opname, STRLEN len, int fatal);


/* Initialise our private op_named_bits HV.
 * It is first loaded with the name and number of each perl operator.
 * Then the builtin tags :none and :all are added.
 * Opcode.pm loads the standard optags from __DATA__
 * XXX leak-alert: data allocated here is never freed, call this
 *     at most once
 */

static void
op_names_init(pTHX)
{
    int i;
    STRLEN len;
    char **op_names;
    char *bitmap;

    op_named_bits = newHV();
    op_names = get_op_names();
    for(i=0; i < PL_maxo; ++i) {
	SV *sv;
	sv = newSViv(i);
	SvREADONLY_on(sv);
	hv_store(op_named_bits, op_names[i], strlen(op_names[i]), sv, 0);
    }

    put_op_bitspec(aTHX_ ":none",0, sv_2mortal(new_opset(aTHX_ Nullsv)));

    opset_all = new_opset(aTHX_ Nullsv);
    bitmap = SvPV(opset_all, len);
    i = len-1; /* deal with last byte specially, see below */
    while(i-- > 0)
	bitmap[i] = 0xFF;
    /* Take care to set the right number of bits in the last byte */
    bitmap[len-1] = (PL_maxo & 0x07) ? ~(0xFF << (PL_maxo & 0x07)) : 0xFF;
    put_op_bitspec(aTHX_ ":all",0, opset_all); /* don't mortalise */
}


/* Store a new tag definition. Always a mask.
 * The tag must not already be defined.
 * SV *mask is copied not referenced.
 */

static void
put_op_bitspec(pTHX_ char *optag, STRLEN len, SV *mask)
{
    SV **svp;
    verify_opset(aTHX_ mask,1);
    if (!len)
	len = strlen(optag);
    svp = hv_fetch(op_named_bits, optag, len, 1);
    if (SvOK(*svp))
	croak("Opcode tag \"%s\" already defined", optag);
    sv_setsv(*svp, mask);
    SvREADONLY_on(*svp);
}


/* Fetch a 'bits' entry for an opname or optag (IV/PV).
 * Note that we return the actual entry for speed.
 * Always sv_mortalcopy() if returing it to user code.
 */

static SV *
get_op_bitspec(pTHX_ char *opname, STRLEN len, int fatal)
{
    SV **svp;
    if (!len)
	len = strlen(opname);
    svp = hv_fetch(op_named_bits, opname, len, 0);
    if (!svp || !SvOK(*svp)) {
	if (!fatal)
	    return Nullsv;
	if (*opname == ':')
	    croak("Unknown operator tag \"%s\"", opname);
	if (*opname == '!')	/* XXX here later, or elsewhere? */
	    croak("Can't negate operators here (\"%s\")", opname);
	if (isALPHA(*opname))
	    croak("Unknown operator name \"%s\"", opname);
	croak("Unknown operator prefix \"%s\"", opname);
    }
    return *svp;
}


static SV *
new_opset(pTHX_ SV *old_opset)
{
    SV *opset;
    if (old_opset) {
	verify_opset(aTHX_ old_opset,1);
	opset = newSVsv(old_opset);
    }
    else {
	opset = NEWSV(1156, opset_len);
	Zero(SvPVX(opset), opset_len + 1, char);
	SvCUR_set(opset, opset_len);
	(void)SvPOK_only(opset);
    }
    /* not mortalised here */
    return opset;
}


static int
verify_opset(pTHX_ SV *opset, int fatal)
{
    char *err = Nullch;
    if      (!SvOK(opset))              err = "undefined";
    else if (!SvPOK(opset))             err = "wrong type";
    else if (SvCUR(opset) != opset_len) err = "wrong size";
    if (err && fatal) {
	croak("Invalid opset: %s", err);
    }
    return !err;
}


static void
set_opset_bits(pTHX_ char *bitmap, SV *bitspec, int on, char *opname)
{
    if (SvIOK(bitspec)) {
	int myopcode = SvIV(bitspec);
	int offset = myopcode >> 3;
	int bit    = myopcode & 0x07;
	if (myopcode >= PL_maxo || myopcode < 0)
	    croak("panic: opcode \"%s\" value %d is invalid", opname, myopcode);
	if (opcode_debug >= 2)
	    warn("set_opset_bits bit %2d (off=%d, bit=%d) %s %s\n",
			myopcode, offset, bit, opname, (on)?"on":"off");
	if (on)
	    bitmap[offset] |= 1 << bit;
	else
	    bitmap[offset] &= ~(1 << bit);
    }
    else if (SvPOK(bitspec) && SvCUR(bitspec) == opset_len) {

	STRLEN len;
	char *specbits = SvPV(bitspec, len);
	if (opcode_debug >= 2)
	    warn("set_opset_bits opset %s %s\n", opname, (on)?"on":"off");
	if (on) 
	    while(len-- > 0) bitmap[len] |=  specbits[len];
	else
	    while(len-- > 0) bitmap[len] &= ~specbits[len];
    }
    else
	croak("panic: invalid bitspec for \"%s\" (type %u)",
		opname, (unsigned)SvTYPE(bitspec));
}


static void
opmask_add(pTHX_ SV *opset)	/* THE ONLY FUNCTION TO EDIT PL_op_mask ITSELF	*/
{
    int i,j;
    char *bitmask;
    STRLEN len;
    int myopcode = 0;

    verify_opset(aTHX_ opset,1);		/* croaks on bad opset	*/

    if (!PL_op_mask)		/* caller must ensure PL_op_mask exists	*/
	croak("Can't add to uninitialised PL_op_mask");

    /* OPCODES ALREADY MASKED ARE NEVER UNMASKED. See opmask_addlocal()	*/

    bitmask = SvPV(opset, len);
    for (i=0; i < opset_len; i++) {
	U16 bits = bitmask[i];
	if (!bits) {	/* optimise for sparse masks */
	    myopcode += 8;
	    continue;
	}
	for (j=0; j < 8 && myopcode < PL_maxo; )
	    PL_op_mask[myopcode++] |= bits & (1 << j++);
    }
}

static void
opmask_addlocal(pTHX_ SV *opset, char *op_mask_buf) /* Localise PL_op_mask then opmask_add() */
{
    char *orig_op_mask = PL_op_mask;
    SAVEVPTR(PL_op_mask);
    /* XXX casting to an ordinary function ptr from a member function ptr
     * is disallowed by Borland
     */
    if (opcode_debug >= 2)
	SAVEDESTRUCTOR((void(*)(void*))Perl_warn,"PL_op_mask restored");
    PL_op_mask = &op_mask_buf[0];
    if (orig_op_mask)
	Copy(orig_op_mask, PL_op_mask, PL_maxo, char);
    else
	Zero(PL_op_mask, PL_maxo, char);
    opmask_add(aTHX_ opset);
}


MODULE = Opcode	PACKAGE = Opcode

PROTOTYPES: ENABLE

BOOT:
    assert(PL_maxo < OP_MASK_BUF_SIZE);
    opset_len = (PL_maxo + 7) / 8;
    if (opcode_debug >= 1)
	warn("opset_len %ld\n", (long)opset_len);
    op_names_init(aTHX);

void
_safe_pkg_prep(Package)
    char *	Package
PPCODE:
    HV *hv; 
    ENTER;
   
    hv = gv_stashpv(Package, GV_ADDWARN); /* should exist already	*/

    if (strNE(HvNAME(hv),"main")) {
        Safefree(HvNAME(hv));         
        HvNAME(hv) = savepv("main"); /* make it think it's in main:: */
        hv_store(hv,"_",1,(SV *)PL_defgv,0);  /* connect _ to global */
        SvREFCNT_inc((SV *)PL_defgv);  /* want to keep _ around! */
    }
    LEAVE;


void
_safe_call_sv(Package, mask, codesv)
    char *	Package
    SV *	mask
    SV *	codesv
PPCODE:
    char op_mask_buf[OP_MASK_BUF_SIZE];
    GV *gv;

    ENTER;

    opmask_addlocal(aTHX_ mask, op_mask_buf);

    save_aptr(&PL_endav);
    PL_endav = (AV*)sv_2mortal((SV*)newAV()); /* ignore END blocks for now	*/

    save_hptr(&PL_defstash);		/* save current default stash	*/
    /* the assignment to global defstash changes our sense of 'main'	*/
    PL_defstash = gv_stashpv(Package, GV_ADDWARN); /* should exist already	*/

    save_hptr(&PL_curstash);
    PL_curstash = PL_defstash;

    /* defstash must itself contain a main:: so we'll add that now	*/
    /* take care with the ref counts (was cause of long standing bug)	*/
    /* XXX I'm still not sure if this is right, GV_ADDWARN should warn!	*/
    gv = gv_fetchpv("main::", GV_ADDWARN, SVt_PVHV);
    sv_free((SV*)GvHV(gv));
    GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);

    /* %INC must be clean for use/require in compartment */
    save_hash(PL_incgv);
    sv_free((SV*)GvHV(PL_incgv));  /* get rid of what save_hash gave us*/
    GvHV(PL_incgv) = (HV*)SvREFCNT_inc(GvHV(gv_HVadd(gv_fetchpv("INC",TRUE,SVt_PVHV))));

    PUSHMARK(SP);
    perl_call_sv(codesv, GIMME|G_EVAL|G_KEEPERR); /* use callers context */
    SPAGAIN; /* for the PUTBACK added by xsubpp */
    LEAVE;


int
verify_opset(opset, fatal = 0)
    SV *opset
    int fatal
CODE:
    RETVAL = verify_opset(aTHX_ opset,fatal);
OUTPUT:
    RETVAL

void
invert_opset(opset)
    SV *opset
CODE:
    {
    char *bitmap;
    STRLEN len = opset_len;
    opset = sv_2mortal(new_opset(aTHX_ opset));	/* verify and clone opset */
    bitmap = SvPVX(opset);
    while(len-- > 0)
	bitmap[len] = ~bitmap[len];
    /* take care of extra bits beyond PL_maxo in last byte	*/
    if (PL_maxo & 07)
	bitmap[opset_len-1] &= ~(0xFF << (PL_maxo & 0x07));
    }
    ST(0) = opset;


void
opset_to_ops(opset, desc = 0)
    SV *opset
    int	desc
PPCODE:
    {
    STRLEN len;
    int i, j, myopcode;
    char *bitmap = SvPV(opset, len);
    char **names = (desc) ? get_op_descs() : get_op_names();
    verify_opset(aTHX_ opset,1);
    for (myopcode=0, i=0; i < opset_len; i++) {
	U16 bits = bitmap[i];
	for (j=0; j < 8 && myopcode < PL_maxo; j++, myopcode++) {
	    if ( bits & (1 << j) )
		XPUSHs(sv_2mortal(newSVpv(names[myopcode], 0)));
	}
    }
    }


void
opset(...)
CODE:
    int i;
    SV *bitspec, *opset;
    char *bitmap;
    STRLEN len, on;
    opset = sv_2mortal(new_opset(aTHX_ Nullsv));
    bitmap = SvPVX(opset);
    for (i = 0; i < items; i++) {
	char *opname;
	on = 1;
	if (verify_opset(aTHX_ ST(i),0)) {
	    opname = "(opset)";
	    bitspec = ST(i);
	}
	else {
	    opname = SvPV(ST(i), len);
	    if (*opname == '!') { on=0; ++opname;--len; }
	    bitspec = get_op_bitspec(aTHX_ opname, len, 1);
	}
	set_opset_bits(aTHX_ bitmap, bitspec, on, opname);
    }
    ST(0) = opset;


#define PERMITING  (ix == 0 || ix == 1)
#define ONLY_THESE (ix == 0 || ix == 2)

void
permit_only(safe, ...)
    SV *safe
ALIAS:
	permit    = 1
	deny_only = 2
	deny      = 3
CODE:
    int i, on;
    SV *bitspec, *mask;
    char *bitmap, *opname;
    STRLEN len;

    if (!SvROK(safe) || !SvOBJECT(SvRV(safe)) || SvTYPE(SvRV(safe))!=SVt_PVHV)
	croak("Not a Safe object");
    mask = *hv_fetch((HV*)SvRV(safe), "Mask",4, 1);
    if (ONLY_THESE)	/* *_only = new mask, else edit current	*/
	sv_setsv(mask, sv_2mortal(new_opset(aTHX_ PERMITING ? opset_all : Nullsv)));
    else
	verify_opset(aTHX_ mask,1); /* croaks */
    bitmap = SvPVX(mask);
    for (i = 1; i < items; i++) {
	on = PERMITING ? 0 : 1;		/* deny = mask bit on	*/
	if (verify_opset(aTHX_ ST(i),0)) {	/* it's a valid mask	*/
	    opname = "(opset)";
	    bitspec = ST(i);
	}
	else {				/* it's an opname/optag	*/
	    opname = SvPV(ST(i), len);
	    /* invert if op has ! prefix (only one allowed)	*/
	    if (*opname == '!') { on = !on; ++opname; --len; }
	    bitspec = get_op_bitspec(aTHX_ opname, len, 1); /* croaks */
	}
	set_opset_bits(aTHX_ bitmap, bitspec, on, opname);
    }
    ST(0) = &PL_sv_yes;


void
opdesc(...)
PPCODE:
    int i, myopcode;
    STRLEN len;
    SV **args;
    char **op_desc = get_op_descs(); 
    /* copy args to a scratch area since we may push output values onto	*/
    /* the stack faster than we read values off it if masks are used.	*/
    args = (SV**)SvPVX(sv_2mortal(newSVpvn((char*)&ST(0), items*sizeof(SV*))));
    for (i = 0; i < items; i++) {
	char *opname = SvPV(args[i], len);
	SV *bitspec = get_op_bitspec(aTHX_ opname, len, 1);
	if (SvIOK(bitspec)) {
	    myopcode = SvIV(bitspec);
	    if (myopcode < 0 || myopcode >= PL_maxo)
		croak("panic: opcode %d (%s) out of range",myopcode,opname);
	    XPUSHs(sv_2mortal(newSVpv(op_desc[myopcode], 0)));
	}
	else if (SvPOK(bitspec) && SvCUR(bitspec) == opset_len) {
	    int b, j;
	    STRLEN n_a;
	    char *bitmap = SvPV(bitspec,n_a);
	    myopcode = 0;
	    for (b=0; b < opset_len; b++) {
		U16 bits = bitmap[b];
		for (j=0; j < 8 && myopcode < PL_maxo; j++, myopcode++)
		    if (bits & (1 << j))
			XPUSHs(sv_2mortal(newSVpv(op_desc[myopcode], 0)));
	    }
	}
	else
	    croak("panic: invalid bitspec for \"%s\" (type %u)",
		opname, (unsigned)SvTYPE(bitspec));
    }


void
define_optag(optagsv, mask)
    SV *optagsv
    SV *mask
CODE:
    STRLEN len;
    char *optag = SvPV(optagsv, len);
    put_op_bitspec(aTHX_ optag, len, mask); /* croaks */
    ST(0) = &PL_sv_yes;


void
empty_opset()
CODE:
    ST(0) = sv_2mortal(new_opset(aTHX_ Nullsv));

void
full_opset()
CODE:
    ST(0) = sv_2mortal(new_opset(aTHX_ opset_all));

void
opmask_add(opset)
    SV *opset
PREINIT:
    if (!PL_op_mask)
	Newz(0, PL_op_mask, PL_maxo, char);
CODE:
    opmask_add(aTHX_ opset);

void
opcodes()
PPCODE:
    if (GIMME == G_ARRAY) {
	croak("opcodes in list context not yet implemented"); /* XXX */
    }
    else {
	XPUSHs(sv_2mortal(newSViv(PL_maxo)));
    }

void
opmask()
CODE:
    ST(0) = sv_2mortal(new_opset(aTHX_ Nullsv));
    if (PL_op_mask) {
	char *bitmap = SvPVX(ST(0));
	int myopcode;
	for(myopcode=0; myopcode < PL_maxo; ++myopcode) {
	    if (PL_op_mask[myopcode])
		bitmap[myopcode >> 3] |= 1 << (myopcode & 0x07);
	}
    }
Commit	Line	Data
c5be433b	1	#define PERL_NO_GET_CONTEXT
6badd1a5	2	#include "EXTERN.h"
	3	#include "perl.h"
	4	#include "XSUB.h"
	5
3280af22	6	/* PL_maxo shouldn't differ from MAXO but leave room anyway (see BOOT:) */
6badd1a5	7	#define OP_MASK_BUF_SIZE (MAXO + 100)
6badd1a5	8
4d8e9581	9	/* XXX op_named_bits and opset_all are never freed */
6badd1a5	10	static HV op_named_bits; / cache shared for whole process */
	11	static SV opset_all; / mask with all bits set */
	12	static IV opset_len; /* length of opmasks in bytes */
	13	static int opcode_debug = 0;
	14
cea2e8a9	15	static SV new_opset (pTHX_ SV old_opset);
	16	static int verify_opset (pTHX_ SV *opset, int fatal);
	17	static void set_opset_bits (pTHX_ char bitmap, SV bitspec, int on, char *opname);
	18	static void put_op_bitspec (pTHX_ char optag, STRLEN len, SV opset);
	19	static SV get_op_bitspec (pTHX_ char opname, STRLEN len, int fatal);
6badd1a5	20
	21
	22	/* Initialise our private op_named_bits HV.
	23	* It is first loaded with the name and number of each perl operator.
	24	* Then the builtin tags :none and :all are added.
	25	* Opcode.pm loads the standard optags from __DATA__
4d8e9581	26	* XXX leak-alert: data allocated here is never freed, call this
4d8e9581	27	* at most once
6badd1a5	28	*/
	29
	30	static void
cea2e8a9	31	op_names_init(pTHX)
6badd1a5	32	{
	33	int i;
	34	STRLEN len;
31fb1209	35	char **op_names;
6badd1a5	36	char *bitmap;
	37
	38	op_named_bits = newHV();
31fb1209	39	op_names = get_op_names();
3280af22	40	for(i=0; i < PL_maxo; ++i) {
e858de61	41	SV *sv;
	42	sv = newSViv(i);
	43	SvREADONLY_on(sv);
31fb1209	44	hv_store(op_named_bits, op_names[i], strlen(op_names[i]), sv, 0);
6badd1a5	45	}
6badd1a5	46
cea2e8a9	47	put_op_bitspec(aTHX_ ":none",0, sv_2mortal(new_opset(aTHX_ Nullsv)));
6badd1a5	48
cea2e8a9	49	opset_all = new_opset(aTHX_ Nullsv);
6badd1a5	50	bitmap = SvPV(opset_all, len);
	51	i = len-1; /* deal with last byte specially, see below */
	52	while(i-- > 0)
	53	bitmap[i] = 0xFF;
	54	/* Take care to set the right number of bits in the last byte */
3280af22	55	bitmap[len-1] = (PL_maxo & 0x07) ? ~(0xFF << (PL_maxo & 0x07)) : 0xFF;
cea2e8a9	56	put_op_bitspec(aTHX_ ":all",0, opset_all); /* don't mortalise */
6badd1a5	57	}
	58
	59
	60	/* Store a new tag definition. Always a mask.
	61	* The tag must not already be defined.
	62	* SV *mask is copied not referenced.
	63	*/
	64
	65	static void
cea2e8a9	66	put_op_bitspec(pTHX_ char optag, STRLEN len, SV mask)
6badd1a5	67	{
6badd1a5	68	SV **svp;
cea2e8a9	69	verify_opset(aTHX_ mask,1);
6badd1a5	70	if (!len)
	71	len = strlen(optag);
	72	svp = hv_fetch(op_named_bits, optag, len, 1);
	73	if (SvOK(*svp))
	74	croak("Opcode tag \"%s\" already defined", optag);
	75	sv_setsv(*svp, mask);
	76	SvREADONLY_on(*svp);
	77	}
	78
	79
	80
	81	/* Fetch a 'bits' entry for an opname or optag (IV/PV).
	82	* Note that we return the actual entry for speed.
	83	* Always sv_mortalcopy() if returing it to user code.
	84	*/
	85
	86	static SV *
cea2e8a9	87	get_op_bitspec(pTHX_ char *opname, STRLEN len, int fatal)
6badd1a5	88	{
	89	SV **svp;
	90	if (!len)
	91	len = strlen(opname);
	92	svp = hv_fetch(op_named_bits, opname, len, 0);
	93	if (!svp \|\| !SvOK(*svp)) {
	94	if (!fatal)
	95	return Nullsv;
	96	if (*opname == ':')
	97	croak("Unknown operator tag \"%s\"", opname);
	98	if (opname == '!') / XXX here later, or elsewhere? */
	99	croak("Can't negate operators here (\"%s\")", opname);
	100	if (isALPHA(*opname))
	101	croak("Unknown operator name \"%s\"", opname);
	102	croak("Unknown operator prefix \"%s\"", opname);
	103	}
	104	return *svp;
	105	}
	106
	107
	108
	109	static SV *
cea2e8a9	110	new_opset(pTHX_ SV *old_opset)
6badd1a5	111	{
	112	SV *opset;
	113	if (old_opset) {
cea2e8a9	114	verify_opset(aTHX_ old_opset,1);
6badd1a5	115	opset = newSVsv(old_opset);
	116	}
	117	else {
8c52afec	118	opset = NEWSV(1156, opset_len);
67a5ea69	119	Zero(SvPVX(opset), opset_len + 1, char);
6badd1a5	120	SvCUR_set(opset, opset_len);
	121	(void)SvPOK_only(opset);
	122	}
	123	/* not mortalised here */
	124	return opset;
	125	}
	126
	127
	128	static int
cea2e8a9	129	verify_opset(pTHX_ SV *opset, int fatal)
6badd1a5	130	{
	131	char *err = Nullch;
	132	if (!SvOK(opset)) err = "undefined";
	133	else if (!SvPOK(opset)) err = "wrong type";
	134	else if (SvCUR(opset) != opset_len) err = "wrong size";
	135	if (err && fatal) {
	136	croak("Invalid opset: %s", err);
	137	}
	138	return !err;
	139	}
	140
	141
	142	static void
cea2e8a9	143	set_opset_bits(pTHX_ char bitmap, SV bitspec, int on, char *opname)
6badd1a5	144	{
	145	if (SvIOK(bitspec)) {
	146	int myopcode = SvIV(bitspec);
	147	int offset = myopcode >> 3;
	148	int bit = myopcode & 0x07;
3280af22	149	if (myopcode >= PL_maxo \|\| myopcode < 0)
6badd1a5	150	croak("panic: opcode \"%s\" value %d is invalid", opname, myopcode);
6badd1a5	151	if (opcode_debug >= 2)
ff0cee69	152	warn("set_opset_bits bit %2d (off=%d, bit=%d) %s %s\n",
6badd1a5	153	myopcode, offset, bit, opname, (on)?"on":"off");
	154	if (on)
	155	bitmap[offset] \|= 1 << bit;
	156	else
	157	bitmap[offset] &= ~(1 << bit);
	158	}
	159	else if (SvPOK(bitspec) && SvCUR(bitspec) == opset_len) {
	160
	161	STRLEN len;
	162	char *specbits = SvPV(bitspec, len);
	163	if (opcode_debug >= 2)
	164	warn("set_opset_bits opset %s %s\n", opname, (on)?"on":"off");
	165	if (on)
	166	while(len-- > 0) bitmap[len] \|= specbits[len];
	167	else
	168	while(len-- > 0) bitmap[len] &= ~specbits[len];
	169	}
	170	else
ff0cee69	171	croak("panic: invalid bitspec for \"%s\" (type %u)",
ff0cee69	172	opname, (unsigned)SvTYPE(bitspec));
6badd1a5	173	}
	174
	175
	176	static void
cea2e8a9	177	opmask_add(pTHX_ SV opset) / THE ONLY FUNCTION TO EDIT PL_op_mask ITSELF */
6badd1a5	178	{
	179	int i,j;
	180	char *bitmask;
	181	STRLEN len;
	182	int myopcode = 0;
	183
cea2e8a9	184	verify_opset(aTHX_ opset,1); /* croaks on bad opset */
6badd1a5	185
3280af22	186	if (!PL_op_mask) /* caller must ensure PL_op_mask exists */
3280af22	187	croak("Can't add to uninitialised PL_op_mask");
6badd1a5	188
	189	/* OPCODES ALREADY MASKED ARE NEVER UNMASKED. See opmask_addlocal() */
	190
	191	bitmask = SvPV(opset, len);
	192	for (i=0; i < opset_len; i++) {
	193	U16 bits = bitmask[i];
	194	if (!bits) { /* optimise for sparse masks */
	195	myopcode += 8;
	196	continue;
	197	}
3280af22	198	for (j=0; j < 8 && myopcode < PL_maxo; )
3280af22	199	PL_op_mask[myopcode++] \|= bits & (1 << j++);
6badd1a5	200	}
	201	}
	202
	203	static void
cea2e8a9	204	opmask_addlocal(pTHX_ SV opset, char op_mask_buf) /* Localise PL_op_mask then opmask_add() */
6badd1a5	205	{
3280af22	206	char *orig_op_mask = PL_op_mask;
7766f137	207	SAVEVPTR(PL_op_mask);
ac4c12e7	208	/* XXX casting to an ordinary function ptr from a member function ptr
	209	* is disallowed by Borland
	210	*/
6badd1a5	211	if (opcode_debug >= 2)
51371543	212	SAVEDESTRUCTOR((void()(void))Perl_warn,"PL_op_mask restored");
3280af22	213	PL_op_mask = &op_mask_buf[0];
6badd1a5	214	if (orig_op_mask)
3280af22	215	Copy(orig_op_mask, PL_op_mask, PL_maxo, char);
6badd1a5	216	else
3280af22	217	Zero(PL_op_mask, PL_maxo, char);
cea2e8a9	218	opmask_add(aTHX_ opset);
6badd1a5	219	}
	220
	221
	222
	223	MODULE = Opcode PACKAGE = Opcode
	224
	225	PROTOTYPES: ENABLE
	226
	227	BOOT:
3280af22	228	assert(PL_maxo < OP_MASK_BUF_SIZE);
3280af22	229	opset_len = (PL_maxo + 7) / 8;
6badd1a5	230	if (opcode_debug >= 1)
ff0cee69	231	warn("opset_len %ld\n", (long)opset_len);
cea2e8a9	232	op_names_init(aTHX);
6badd1a5	233
8c7314f9	234	void
	235	_safe_pkg_prep(Package)
	236	char * Package
	237	PPCODE:
	238	HV *hv;
	239	ENTER;
	240
	241	hv = gv_stashpv(Package, GV_ADDWARN); /* should exist already */
	242
	243	if (strNE(HvNAME(hv),"main")) {
	244	Safefree(HvNAME(hv));
	245	HvNAME(hv) = savepv("main"); /* make it think it's in main:: */
	246	hv_store(hv,"_",1,(SV )PL_defgv,0); / connect _ to global */
	247	SvREFCNT_inc((SV )PL_defgv); / want to keep _ around! */
	248	}
	249	LEAVE;
	250
	251
	252
	253
6badd1a5	254
6badd1a5	255	void
9d8a25dc	256	_safe_call_sv(Package, mask, codesv)
9d8a25dc	257	char * Package
6badd1a5	258	SV * mask
6badd1a5	259	SV * codesv
4d8e9581	260	PPCODE:
6badd1a5	261	char op_mask_buf[OP_MASK_BUF_SIZE];
	262	GV *gv;
	263
	264	ENTER;
	265
cea2e8a9	266	opmask_addlocal(aTHX_ mask, op_mask_buf);
6badd1a5	267
3280af22	268	save_aptr(&PL_endav);
3280af22	269	PL_endav = (AV)sv_2mortal((SV)newAV()); /* ignore END blocks for now */
6badd1a5	270
e5125a24	271	save_hptr(&PL_defstash); /* save current default stash */
6badd1a5	272	/* the assignment to global defstash changes our sense of 'main' */
3280af22	273	PL_defstash = gv_stashpv(Package, GV_ADDWARN); /* should exist already */
8c7314f9	274
ed094faf	275	save_hptr(&PL_curstash);
ed094faf	276	PL_curstash = PL_defstash;
6badd1a5	277
	278	/* defstash must itself contain a main:: so we'll add that now */
	279	/* take care with the ref counts (was cause of long standing bug) */
	280	/* XXX I'm still not sure if this is right, GV_ADDWARN should warn! */
	281	gv = gv_fetchpv("main::", GV_ADDWARN, SVt_PVHV);
	282	sv_free((SV*)GvHV(gv));
3280af22	283	GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
6badd1a5	284
e5125a24	285	/* %INC must be clean for use/require in compartment */
e5125a24	286	save_hash(PL_incgv);
7ec3aa30	287	sv_free((SV)GvHV(PL_incgv)); / get rid of what save_hash gave us*/
e5125a24	288	GvHV(PL_incgv) = (HV*)SvREFCNT_inc(GvHV(gv_HVadd(gv_fetchpv("INC",TRUE,SVt_PVHV))));
e5125a24	289
924508f0	290	PUSHMARK(SP);
6badd1a5	291	perl_call_sv(codesv, GIMME\|G_EVAL\|G_KEEPERR); /* use callers context */
	292	SPAGAIN; /* for the PUTBACK added by xsubpp */
	293	LEAVE;
	294
	295
	296	int
	297	verify_opset(opset, fatal = 0)
	298	SV *opset
	299	int fatal
cea2e8a9	300	CODE:
	301	RETVAL = verify_opset(aTHX_ opset,fatal);
	302	OUTPUT:
	303	RETVAL
6badd1a5	304
	305	void
	306	invert_opset(opset)
	307	SV *opset
4d8e9581	308	CODE:
6badd1a5	309	{
	310	char *bitmap;
	311	STRLEN len = opset_len;
cea2e8a9	312	opset = sv_2mortal(new_opset(aTHX_ opset)); /* verify and clone opset */
6badd1a5	313	bitmap = SvPVX(opset);
	314	while(len-- > 0)
	315	bitmap[len] = ~bitmap[len];
3280af22	316	/* take care of extra bits beyond PL_maxo in last byte */
	317	if (PL_maxo & 07)
	318	bitmap[opset_len-1] &= ~(0xFF << (PL_maxo & 0x07));
6badd1a5	319	}
	320	ST(0) = opset;
	321
	322
	323	void
	324	opset_to_ops(opset, desc = 0)
	325	SV *opset
	326	int desc
4d8e9581	327	PPCODE:
6badd1a5	328	{
	329	STRLEN len;
	330	int i, j, myopcode;
	331	char *bitmap = SvPV(opset, len);
31fb1209	332	char **names = (desc) ? get_op_descs() : get_op_names();
cea2e8a9	333	verify_opset(aTHX_ opset,1);
6badd1a5	334	for (myopcode=0, i=0; i < opset_len; i++) {
6badd1a5	335	U16 bits = bitmap[i];
3280af22	336	for (j=0; j < 8 && myopcode < PL_maxo; j++, myopcode++) {
6badd1a5	337	if ( bits & (1 << j) )
	338	XPUSHs(sv_2mortal(newSVpv(names[myopcode], 0)));
	339	}
	340	}
	341	}
	342
	343
	344	void
	345	opset(...)
4d8e9581	346	CODE:
8063af02	347	int i;
6badd1a5	348	SV bitspec, opset;
	349	char *bitmap;
	350	STRLEN len, on;
cea2e8a9	351	opset = sv_2mortal(new_opset(aTHX_ Nullsv));
6badd1a5	352	bitmap = SvPVX(opset);
	353	for (i = 0; i < items; i++) {
	354	char *opname;
	355	on = 1;
cea2e8a9	356	if (verify_opset(aTHX_ ST(i),0)) {
6badd1a5	357	opname = "(opset)";
	358	bitspec = ST(i);
	359	}
	360	else {
	361	opname = SvPV(ST(i), len);
	362	if (*opname == '!') { on=0; ++opname;--len; }
cea2e8a9	363	bitspec = get_op_bitspec(aTHX_ opname, len, 1);
6badd1a5	364	}
cea2e8a9	365	set_opset_bits(aTHX_ bitmap, bitspec, on, opname);
6badd1a5	366	}
	367	ST(0) = opset;
	368
	369
	370	#define PERMITING (ix == 0 \|\| ix == 1)
	371	#define ONLY_THESE (ix == 0 \|\| ix == 2)
	372
	373	void
	374	permit_only(safe, ...)
	375	SV *safe
4d8e9581	376	ALIAS:
6badd1a5	377	permit = 1
	378	deny_only = 2
	379	deny = 3
4d8e9581	380	CODE:
6badd1a5	381	int i, on;
	382	SV bitspec, mask;
	383	char bitmap, opname;
	384	STRLEN len;
	385
	386	if (!SvROK(safe) \|\| !SvOBJECT(SvRV(safe)) \|\| SvTYPE(SvRV(safe))!=SVt_PVHV)
	387	croak("Not a Safe object");
	388	mask = hv_fetch((HV)SvRV(safe), "Mask",4, 1);
	389	if (ONLY_THESE) /* _only = new mask, else edit current /
cea2e8a9	390	sv_setsv(mask, sv_2mortal(new_opset(aTHX_ PERMITING ? opset_all : Nullsv)));
4d8e9581	391	else
cea2e8a9	392	verify_opset(aTHX_ mask,1); /* croaks */
6badd1a5	393	bitmap = SvPVX(mask);
	394	for (i = 1; i < items; i++) {
	395	on = PERMITING ? 0 : 1; /* deny = mask bit on */
cea2e8a9	396	if (verify_opset(aTHX_ ST(i),0)) { /* it's a valid mask */
6badd1a5	397	opname = "(opset)";
	398	bitspec = ST(i);
	399	}
	400	else { /* it's an opname/optag */
	401	opname = SvPV(ST(i), len);
	402	/* invert if op has ! prefix (only one allowed) */
	403	if (*opname == '!') { on = !on; ++opname; --len; }
cea2e8a9	404	bitspec = get_op_bitspec(aTHX_ opname, len, 1); /* croaks */
6badd1a5	405	}
cea2e8a9	406	set_opset_bits(aTHX_ bitmap, bitspec, on, opname);
6badd1a5	407	}
6b88bc9c	408	ST(0) = &PL_sv_yes;
6badd1a5	409
	410
	411
	412	void
	413	opdesc(...)
4d8e9581	414	PPCODE:
6badd1a5	415	int i, myopcode;
	416	STRLEN len;
	417	SV **args;
31fb1209	418	char **op_desc = get_op_descs();
6badd1a5	419	/* copy args to a scratch area since we may push output values onto */
6badd1a5	420	/* the stack faster than we read values off it if masks are used. */
79cb57f6	421	args = (SV*)SvPVX(sv_2mortal(newSVpvn((char)&ST(0), itemssizeof(SV))));
6badd1a5	422	for (i = 0; i < items; i++) {
6badd1a5	423	char *opname = SvPV(args[i], len);
cea2e8a9	424	SV *bitspec = get_op_bitspec(aTHX_ opname, len, 1);
6badd1a5	425	if (SvIOK(bitspec)) {
6badd1a5	426	myopcode = SvIV(bitspec);
3280af22	427	if (myopcode < 0 \|\| myopcode >= PL_maxo)
6badd1a5	428	croak("panic: opcode %d (%s) out of range",myopcode,opname);
	429	XPUSHs(sv_2mortal(newSVpv(op_desc[myopcode], 0)));
	430	}
	431	else if (SvPOK(bitspec) && SvCUR(bitspec) == opset_len) {
	432	int b, j;
2d8e6c8d	433	STRLEN n_a;
2d8e6c8d	434	char *bitmap = SvPV(bitspec,n_a);
6badd1a5	435	myopcode = 0;
	436	for (b=0; b < opset_len; b++) {
	437	U16 bits = bitmap[b];
3280af22	438	for (j=0; j < 8 && myopcode < PL_maxo; j++, myopcode++)
6badd1a5	439	if (bits & (1 << j))
	440	XPUSHs(sv_2mortal(newSVpv(op_desc[myopcode], 0)));
	441	}
	442	}
	443	else
ff0cee69	444	croak("panic: invalid bitspec for \"%s\" (type %u)",
ff0cee69	445	opname, (unsigned)SvTYPE(bitspec));
6badd1a5	446	}
	447
	448
	449	void
	450	define_optag(optagsv, mask)
	451	SV *optagsv
	452	SV *mask
4d8e9581	453	CODE:
6badd1a5	454	STRLEN len;
6badd1a5	455	char *optag = SvPV(optagsv, len);
cea2e8a9	456	put_op_bitspec(aTHX_ optag, len, mask); /* croaks */
6b88bc9c	457	ST(0) = &PL_sv_yes;
6badd1a5	458
	459
	460	void
	461	empty_opset()
4d8e9581	462	CODE:
cea2e8a9	463	ST(0) = sv_2mortal(new_opset(aTHX_ Nullsv));
6badd1a5	464
	465	void
	466	full_opset()
4d8e9581	467	CODE:
cea2e8a9	468	ST(0) = sv_2mortal(new_opset(aTHX_ opset_all));
6badd1a5	469
	470	void
	471	opmask_add(opset)
	472	SV *opset
4d8e9581	473	PREINIT:
3280af22	474	if (!PL_op_mask)
3280af22	475	Newz(0, PL_op_mask, PL_maxo, char);
cea2e8a9	476	CODE:
cea2e8a9	477	opmask_add(aTHX_ opset);
6badd1a5	478
	479	void
	480	opcodes()
4d8e9581	481	PPCODE:
6badd1a5	482	if (GIMME == G_ARRAY) {
	483	croak("opcodes in list context not yet implemented"); /* XXX */
	484	}
	485	else {
3280af22	486	XPUSHs(sv_2mortal(newSViv(PL_maxo)));
6badd1a5	487	}
	488
	489	void
	490	opmask()
4d8e9581	491	CODE:
cea2e8a9	492	ST(0) = sv_2mortal(new_opset(aTHX_ Nullsv));
3280af22	493	if (PL_op_mask) {
6badd1a5	494	char *bitmap = SvPVX(ST(0));
6badd1a5	495	int myopcode;
3280af22	496	for(myopcode=0; myopcode < PL_maxo; ++myopcode) {
3280af22	497	if (PL_op_mask[myopcode])
6badd1a5	498	bitmap[myopcode >> 3] \|= 1 << (myopcode & 0x07);
	499	}
	500	}
	501