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