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