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