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