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 */
#define MY_CXT_KEY "Opcode::_guts" XS_VERSION

typedef struct {
    HV *        x_op_named_bits;        /* cache shared for whole process */
    SV *        x_opset_all;            /* mask with all bits set       */
    IV          x_opset_len;            /* length of opmasks in bytes   */
    int         x_opcode_debug;
} my_cxt_t;

START_MY_CXT

#define op_named_bits           (MY_CXT.x_op_named_bits)
#define opset_all               (MY_CXT.x_opset_all)
#define opset_len               (MY_CXT.x_opset_len)
#define opcode_debug            (MY_CXT.x_opcode_debug)

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

    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] = (char)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;
    dMY_CXT;

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

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

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

    if      (!SvOK(opset))              err = "undefined";
    else if (!SvPOK(opset))             err = "wrong type";
    else if (SvCUR(opset) != (STRLEN)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)
{
    dMY_CXT;

    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) == (STRLEN)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;
    dMY_CXT;

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

    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:
{
    MY_CXT_INIT;
    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;
    HV *dummy_hv;

    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 */
    dummy_hv = save_hash(PL_incgv);
    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 */
    sv_free( (SV *) dummy_hv);  /* get rid of what save_hash gave us*/
    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;
    dMY_CXT;
    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();
    dMY_CXT;

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

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

    /* 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) == (STRLEN)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:
    dMY_CXT;
    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);
        }
    }

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