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

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

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

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 _((SV *old_opset));
static int  verify_opset _((SV *opset, int fatal));
static void set_opset_bits _((char *bitmap, SV *bitspec, int on, char *opname));
static void put_op_bitspec _((char *optag,  STRLEN len, SV *opset));
static SV  *get_op_bitspec _((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__
 */

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

    op_named_bits = newHV();
    for(i=0; i < maxo; ++i) {
	hv_store(op_named_bits, op_name[i],strlen(op_name[i]),
		Sv=newSViv(i), 0);
	SvREADONLY_on(Sv);
    }

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

    opset_all = new_opset(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] = (maxo & 0x07) ? ~(0xFF << (maxo & 0x07)) : 0xFF;
    put_op_bitspec(":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(optag, len, mask)
    char *optag;
    STRLEN len;
    SV *mask;
{
    SV **svp;
    verify_opset(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(opname, len, fatal)
    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(old_opset)
    SV *old_opset;
{
    SV *opset;
    if (old_opset) {
	verify_opset(old_opset,1);
	opset = newSVsv(old_opset);
    }
    else {
	opset = newSV(opset_len);
	Zero(SvPVX(opset), opset_len, char);
	SvCUR_set(opset, opset_len);
	(void)SvPOK_only(opset);
    }
    /* not mortalised here */
    return opset;
}


static int
verify_opset(opset, fatal)
    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(bitmap, bitspec, on, opname)
    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 >= 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(opset)	/* THE ONLY FUNCTION TO EDIT op_mask ITSELF	*/
    SV *opset;
{
    int i,j;
    char *bitmask;
    STRLEN len;
    int myopcode = 0;

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

    if (!op_mask)		/* caller must ensure op_mask exists	*/
	croak("Can't add to uninitialised 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 < maxo; )
	    op_mask[myopcode++] |= bits & (1 << j++);
    }
}

static void
opmask_addlocal(opset, op_mask_buf) /* Localise op_mask then opmask_add() */
    SV *opset;
    char *op_mask_buf;
{
    char *orig_op_mask = op_mask;
    SAVEPPTR(op_mask);
    if (opcode_debug >= 2)
	SAVEDESTRUCTOR((void(*)_((void*)))warn,"op_mask restored");
    op_mask = &op_mask_buf[0];
    if (orig_op_mask)
	Copy(orig_op_mask, op_mask, maxo, char);
    else
	Zero(op_mask, maxo, char);
    opmask_add(opset);
}


MODULE = Opcode	PACKAGE = Opcode

PROTOTYPES: ENABLE

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


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(mask, op_mask_buf);

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

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

    /* 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(defstash);

    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


void
invert_opset(opset)
    SV *opset
    CODE:
    {
    char *bitmap;
    STRLEN len = opset_len;
    opset = new_opset(opset);	/* verify and clone opset */
    bitmap = SvPVX(opset);
    while(len-- > 0)
	bitmap[len] = ~bitmap[len];
    /* take care of extra bits beyond maxo in last byte	*/
    if (maxo & 07)
	bitmap[opset_len-1] &= ~(0xFF << (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) ? op_desc : op_name;
    verify_opset(opset,1);
    for (myopcode=0, i=0; i < opset_len; i++) {
	U16 bits = bitmap[i];
	for (j=0; j < 8 && myopcode < maxo; j++, myopcode++) {
	    if ( bits & (1 << j) )
		XPUSHs(sv_2mortal(newSVpv(names[myopcode], 0)));
	}
    }
    }


void
opset(...)
    CODE:
    int i, j;
    SV *bitspec, *opset;
    char *bitmap;
    STRLEN len, on;
    opset = new_opset(Nullsv);
    bitmap = SvPVX(opset);
    for (i = 0; i < items; i++) {
	char *opname;
	on = 1;
	if (verify_opset(ST(i),0)) {
	    opname = "(opset)";
	    bitspec = ST(i);
	}
	else {
	    opname = SvPV(ST(i), len);
	    if (*opname == '!') { on=0; ++opname;--len; }
	    bitspec = get_op_bitspec(opname, len, 1);
	}
	set_opset_bits(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, new_opset(PERMITING ? opset_all : Nullsv));
    else verify_opset(mask,1); /* croaks */
    bitmap = SvPVX(mask);
    for (i = 1; i < items; i++) {
	on = PERMITING ? 0 : 1;		/* deny = mask bit on	*/
	if (verify_opset(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(opname, len, 1); /* croaks */
	}
	set_opset_bits(bitmap, bitspec, on, opname);
    }
    ST(0) = &sv_yes;


void
opdesc(...)
    PPCODE:
    int i, myopcode;
    STRLEN len;
    SV **args;
    /* 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(newSVpv((char*)&ST(0), items*sizeof(SV*))));
    for (i = 0; i < items; i++) {
	char *opname = SvPV(args[i], len);
	SV *bitspec = get_op_bitspec(opname, len, 1);
	if (SvIOK(bitspec)) {
	    myopcode = SvIV(bitspec);
	    if (myopcode < 0 || myopcode >= 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;
	    char *bitmap = SvPV(bitspec,na);
	    myopcode = 0;
	    for (b=0; b < opset_len; b++) {
		U16 bits = bitmap[b];
		for (j=0; j < 8 && myopcode < 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(optag, len, mask); /* croaks */
    ST(0) = &sv_yes;


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

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

void
opmask_add(opset)
    SV *opset
    PREINIT:
    if (!op_mask)
	Newz(0, op_mask, maxo, char);

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

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