source: trunk/essentials/dev-lang/perl/ext/Opcode/Opcode.xs

Last change on this file was 3181, checked in by bird, 18 years ago

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