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