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