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