#define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" /* PL_maxo shouldn't differ from MAXO but leave room anyway (see BOOT:) */ #define OP_MASK_BUF_SIZE (MAXO + 100) /* XXX op_named_bits and opset_all are never freed */ #define MY_CXT_KEY "Opcode::_guts" XS_VERSION typedef struct { HV * x_op_named_bits; /* cache shared for whole process */ SV * x_opset_all; /* mask with all bits set */ IV x_opset_len; /* length of opmasks in bytes */ int x_opcode_debug; } my_cxt_t; START_MY_CXT #define op_named_bits (MY_CXT.x_op_named_bits) #define opset_all (MY_CXT.x_opset_all) #define opset_len (MY_CXT.x_opset_len) #define opcode_debug (MY_CXT.x_opcode_debug) static SV *new_opset (pTHX_ SV *old_opset); static int verify_opset (pTHX_ SV *opset, int fatal); static void set_opset_bits (pTHX_ char *bitmap, SV *bitspec, int on, const char *opname); static void put_op_bitspec (pTHX_ const char *optag, STRLEN len, SV *opset); static SV *get_op_bitspec (pTHX_ const char *opname, STRLEN len, int fatal); /* Initialise our private op_named_bits HV. * It is first loaded with the name and number of each perl operator. * Then the builtin tags :none and :all are added. * Opcode.pm loads the standard optags from __DATA__ * XXX leak-alert: data allocated here is never freed, call this * at most once */ static void op_names_init(pTHX) 10 { 10 int i; 10 STRLEN len; 10 char **op_names; 10 char *bitmap; dMY_CXT; 10 op_named_bits = newHV(); 10 op_names = get_op_names(); 3550 for(i=0; i < PL_maxo; ++i) { 3540 SV * const sv = newSViv(i); 3540 SvREADONLY_on(sv); 3540 hv_store(op_named_bits, op_names[i], strlen(op_names[i]), sv, 0); } 10 put_op_bitspec(aTHX_ ":none",0, sv_2mortal(new_opset(aTHX_ Nullsv))); 10 opset_all = new_opset(aTHX_ Nullsv); 10 bitmap = SvPV(opset_all, len); 10 i = len-1; /* deal with last byte specially, see below */ 450 while(i-- > 0) 440 bitmap[i] = (char)0xFF; /* Take care to set the right number of bits in the last byte */ 10 bitmap[len-1] = (PL_maxo & 0x07) ? ~(0xFF << (PL_maxo & 0x07)) : 0xFF; 10 put_op_bitspec(aTHX_ ":all",0, opset_all); /* don't mortalise */ } /* Store a new tag definition. Always a mask. * The tag must not already be defined. * SV *mask is copied not referenced. */ static void put_op_bitspec(pTHX_ const char *optag, STRLEN len, SV *mask) 201 { 201 SV **svp; dMY_CXT; 201 verify_opset(aTHX_ mask,1); 201 if (!len) 20 len = strlen(optag); 201 svp = hv_fetch(op_named_bits, optag, len, 1); 201 if (SvOK(*svp)) ###### croak("Opcode tag \"%s\" already defined", optag); 201 sv_setsv(*svp, mask); 201 SvREADONLY_on(*svp); } /* Fetch a 'bits' entry for an opname or optag (IV/PV). * Note that we return the actual entry for speed. * Always sv_mortalcopy() if returing it to user code. */ static SV * get_op_bitspec(pTHX_ const char *opname, STRLEN len, int fatal) 4406 { 4406 SV **svp; dMY_CXT; 4406 if (!len) ###### len = strlen(opname); 4406 svp = hv_fetch(op_named_bits, opname, len, 0); 4406 if (!svp || !SvOK(*svp)) { 2 if (!fatal) ###### return Nullsv; 2 if (*opname == ':') 1 croak("Unknown operator tag \"%s\"", opname); 1 if (*opname == '!') /* XXX here later, or elsewhere? */ ###### croak("Can't negate operators here (\"%s\")", opname); 1 if (isALPHA(*opname)) 1 croak("Unknown operator name \"%s\"", opname); ###### croak("Unknown operator prefix \"%s\"", opname); } 4404 return *svp; } static SV * new_opset(pTHX_ SV *old_opset) 1158 { 1158 SV *opset; dMY_CXT; 1158 if (old_opset) { 323 verify_opset(aTHX_ old_opset,1); 323 opset = newSVsv(old_opset); } else { 835 opset = NEWSV(1156, opset_len); 835 Zero(SvPVX_const(opset), opset_len + 1, char); 835 SvCUR_set(opset, opset_len); 835 (void)SvPOK_only(opset); } /* not mortalised here */ 1158 return opset; } static int verify_opset(pTHX_ SV *opset, int fatal) 5288 { 5288 const char *err = Nullch; dMY_CXT; 5288 if (!SvOK(opset)) err = "undefined"; 5288 else if (!SvPOK(opset)) err = "wrong type"; 5287 else if (SvCUR(opset) != (STRLEN)opset_len) err = "wrong size"; 5288 if (err && fatal) { ###### croak("Invalid opset: %s", err); } 5288 return !err; } static void set_opset_bits(pTHX_ char *bitmap, SV *bitspec, int on, const char *opname) 4407 { dMY_CXT; 4407 if (SvIOK(bitspec)) { 3998 const int myopcode = SvIV(bitspec); 3998 const int offset = myopcode >> 3; 3998 const int bit = myopcode & 0x07; 3998 if (myopcode >= PL_maxo || myopcode < 0) ###### croak("panic: opcode \"%s\" value %d is invalid", opname, myopcode); 3998 if (opcode_debug >= 2) ###### warn("set_opset_bits bit %2d (off=%d, bit=%d) %s %s\n", myopcode, offset, bit, opname, (on)?"on":"off"); 3998 if (on) 3997 bitmap[offset] |= 1 << bit; else 1 bitmap[offset] &= ~(1 << bit); } 409 else if (SvPOK(bitspec) && SvCUR(bitspec) == (STRLEN)opset_len) { 409 STRLEN len; 409 const char * const specbits = SvPV(bitspec, len); 409 if (opcode_debug >= 2) ###### warn("set_opset_bits opset %s %s\n", opname, (on)?"on":"off"); 409 if (on) 18814 while(len-- > 0) bitmap[len] |= specbits[len]; else ###### while(len-- > 0) bitmap[len] &= ~specbits[len]; } else ###### croak("panic: invalid bitspec for \"%s\" (type %u)", opname, (unsigned)SvTYPE(bitspec)); } static void opmask_add(pTHX_ SV *opset) /* THE ONLY FUNCTION TO EDIT PL_op_mask ITSELF */ 335 { 335 int i,j; 335 char *bitmask; 335 STRLEN len; 335 int myopcode = 0; dMY_CXT; 335 verify_opset(aTHX_ opset,1); /* croaks on bad opset */ 335 if (!PL_op_mask) /* caller must ensure PL_op_mask exists */ ###### croak("Can't add to uninitialised PL_op_mask"); /* OPCODES ALREADY MASKED ARE NEVER UNMASKED. See opmask_addlocal() */ 335 bitmask = SvPV(opset, len); 15410 for (i=0; i < opset_len; i++) { 15075 const U16 bits = bitmask[i]; 15075 if (!bits) { /* optimise for sparse masks */ 13965 myopcode += 8; 13965 continue; } 9984 for (j=0; j < 8 && myopcode < PL_maxo; ) 8874 PL_op_mask[myopcode++] |= bits & (1 << j++); } } static void opmask_addlocal(pTHX_ SV *opset, char *op_mask_buf) /* Localise PL_op_mask then opmask_add() */ 332 { 332 char *orig_op_mask = PL_op_mask; dMY_CXT; 332 SAVEVPTR(PL_op_mask); /* XXX casting to an ordinary function ptr from a member function ptr * is disallowed by Borland */ 332 if (opcode_debug >= 2) ###### SAVEDESTRUCTOR((void(*)(void*))Perl_warn,"PL_op_mask restored"); 332 PL_op_mask = &op_mask_buf[0]; 332 if (orig_op_mask) ###### Copy(orig_op_mask, PL_op_mask, PL_maxo, char); else 332 Zero(PL_op_mask, PL_maxo, char); 332 opmask_add(aTHX_ opset); } MODULE = Opcode PACKAGE = Opcode PROTOTYPES: ENABLE BOOT: { 10 MY_CXT_INIT; 10 assert(PL_maxo < OP_MASK_BUF_SIZE); 10 opset_len = (PL_maxo + 7) / 8; 10 if (opcode_debug >= 1) ###### warn("opset_len %ld\n", (long)opset_len); 10 op_names_init(aTHX); } void _safe_pkg_prep(Package) const char *Package PPCODE: 308 HV *hv; 308 ENTER; 308 hv = gv_stashpv(Package, GV_ADDWARN); /* should exist already */ 308 if (strNE(HvNAME_get(hv),"main")) { /* make it think it's in main:: */ 308 Perl_hv_name_set(aTHX_ hv, "main", 4, 0); 308 hv_store(hv,"_",1,(SV *)PL_defgv,0); /* connect _ to global */ 308 SvREFCNT_inc((SV *)PL_defgv); /* want to keep _ around! */ } 308 LEAVE; void _safe_call_sv(Package, mask, codesv) char * Package SV * mask SV * codesv PPCODE: 332 char op_mask_buf[OP_MASK_BUF_SIZE]; 332 GV *gv; 332 HV *dummy_hv; 332 ENTER; 332 opmask_addlocal(aTHX_ mask, op_mask_buf); 332 save_aptr(&PL_endav); 332 PL_endav = (AV*)sv_2mortal((SV*)newAV()); /* ignore END blocks for now */ 332 save_hptr(&PL_defstash); /* save current default stash */ /* the assignment to global defstash changes our sense of 'main' */ 332 PL_defstash = gv_stashpv(Package, GV_ADDWARN); /* should exist already */ 332 save_hptr(&PL_curstash); 332 PL_curstash = PL_defstash; /* defstash must itself contain a main:: so we'll add that now */ /* take care with the ref counts (was cause of long standing bug) */ /* XXX I'm still not sure if this is right, GV_ADDWARN should warn! */ 332 gv = gv_fetchpv("main::", GV_ADDWARN, SVt_PVHV); 332 sv_free((SV*)GvHV(gv)); 332 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash); /* %INC must be clean for use/require in compartment */ 332 dummy_hv = save_hash(PL_incgv); 332 GvHV(PL_incgv) = (HV*)SvREFCNT_inc(GvHV(gv_HVadd(gv_fetchpv("INC",TRUE,SVt_PVHV)))); 332 PUSHMARK(SP); 332 perl_call_sv(codesv, GIMME|G_EVAL|G_KEEPERR); /* use callers context */ 332 sv_free( (SV *) dummy_hv); /* get rid of what save_hash gave us*/ 332 SPAGAIN; /* for the PUTBACK added by xsubpp */ 332 LEAVE; int verify_opset(opset, fatal = 0) SV *opset int fatal CODE: 2 RETVAL = verify_opset(aTHX_ opset,fatal); OUTPUT: RETVAL void invert_opset(opset) SV *opset CODE: { 312 char *bitmap; dMY_CXT; 312 STRLEN len = opset_len; 312 opset = sv_2mortal(new_opset(aTHX_ opset)); /* verify and clone opset */ 312 bitmap = SvPVX(opset); 14352 while(len-- > 0) 14040 bitmap[len] = ~bitmap[len]; /* take care of extra bits beyond PL_maxo in last byte */ 312 if (PL_maxo & 07) 312 bitmap[opset_len-1] &= ~(0xFF << (PL_maxo & 0x07)); } 312 ST(0) = opset; void opset_to_ops(opset, desc = 0) SV *opset int desc PPCODE: { 18 STRLEN len; 18 int i, j, myopcode; 18 const char * const bitmap = SvPV(opset, len); 18 char **names = (desc) ? get_op_descs() : get_op_names(); dMY_CXT; 18 verify_opset(aTHX_ opset,1); 828 for (myopcode=0, i=0; i < opset_len; i++) { 810 const U16 bits = bitmap[i]; 7182 for (j=0; j < 8 && myopcode < PL_maxo; j++, myopcode++) { 6372 if ( bits & (1 << j) ) 5439 XPUSHs(sv_2mortal(newSVpv(names[myopcode], 0))); } } } void opset(...) CODE: 810 int i; 810 SV *bitspec; 810 STRLEN len, on; 810 SV * const opset = sv_2mortal(new_opset(aTHX_ Nullsv)); 810 char * const bitmap = SvPVX(opset); 5217 for (i = 0; i < items; i++) { 4409 const char *opname; 4409 on = 1; 4409 if (verify_opset(aTHX_ ST(i),0)) { 6 opname = "(opset)"; 6 bitspec = ST(i); } else { 4403 opname = SvPV(ST(i), len); 4403 if (*opname == '!') { on=0; ++opname;--len; } 4403 bitspec = get_op_bitspec(aTHX_ opname, len, 1); } 4407 set_opset_bits(aTHX_ bitmap, bitspec, on, opname); } 808 ST(0) = opset; #define PERMITING (ix == 0 || ix == 1) #define ONLY_THESE (ix == 0 || ix == 2) void permit_only(safe, ...) SV *safe ALIAS: permit = 1 deny_only = 2 deny = 3 CODE: ###### int i; ###### SV *bitspec, *mask; ###### char *bitmap; ###### STRLEN len; dMY_CXT; ###### if (!SvROK(safe) || !SvOBJECT(SvRV(safe)) || SvTYPE(SvRV(safe))!=SVt_PVHV) ###### croak("Not a Safe object"); ###### mask = *hv_fetch((HV*)SvRV(safe), "Mask",4, 1); ###### if (ONLY_THESE) /* *_only = new mask, else edit current */ ###### sv_setsv(mask, sv_2mortal(new_opset(aTHX_ PERMITING ? opset_all : Nullsv))); else ###### verify_opset(aTHX_ mask,1); /* croaks */ ###### bitmap = SvPVX(mask); ###### for (i = 1; i < items; i++) { ###### const char *opname; ###### int on = PERMITING ? 0 : 1; /* deny = mask bit on */ ###### if (verify_opset(aTHX_ ST(i),0)) { /* it's a valid mask */ ###### opname = "(opset)"; ###### bitspec = ST(i); } else { /* it's an opname/optag */ ###### opname = SvPV(ST(i), len); /* invert if op has ! prefix (only one allowed) */ ###### if (*opname == '!') { on = !on; ++opname; --len; } ###### bitspec = get_op_bitspec(aTHX_ opname, len, 1); /* croaks */ } ###### set_opset_bits(aTHX_ bitmap, bitspec, on, opname); } ###### ST(0) = &PL_sv_yes; void opdesc(...) PPCODE: 2 int i; 2 STRLEN len; 2 SV **args; 2 char **op_desc = get_op_descs(); dMY_CXT; /* copy args to a scratch area since we may push output values onto */ /* the stack faster than we read values off it if masks are used. */ 2 args = (SV**)SvPVX(sv_2mortal(newSVpvn((char*)&ST(0), items*sizeof(SV*)))); 5 for (i = 0; i < items; i++) { 3 const char * const opname = SvPV(args[i], len); 3 SV *bitspec = get_op_bitspec(aTHX_ opname, len, 1); 3 if (SvIOK(bitspec)) { 2 const int myopcode = SvIV(bitspec); 2 if (myopcode < 0 || myopcode >= PL_maxo) ###### croak("panic: opcode %d (%s) out of range",myopcode,opname); 2 XPUSHs(sv_2mortal(newSVpv(op_desc[myopcode], 0))); } 1 else if (SvPOK(bitspec) && SvCUR(bitspec) == (STRLEN)opset_len) { 1 int b, j; 1 STRLEN n_a; 1 const char * const bitmap = SvPV(bitspec,n_a); 1 int myopcode = 0; 46 for (b=0; b < opset_len; b++) { 45 const U16 bits = bitmap[b]; 399 for (j=0; j < 8 && myopcode < PL_maxo; j++, myopcode++) 354 if (bits & (1 << j)) 3 XPUSHs(sv_2mortal(newSVpv(op_desc[myopcode], 0))); } } else ###### croak("panic: invalid bitspec for \"%s\" (type %u)", opname, (unsigned)SvTYPE(bitspec)); } void define_optag(optagsv, mask) SV *optagsv SV *mask CODE: 181 STRLEN len; 181 const char *optag = SvPV(optagsv, len); 181 put_op_bitspec(aTHX_ optag, len, mask); /* croaks */ 181 ST(0) = &PL_sv_yes; void empty_opset() CODE: 3 ST(0) = sv_2mortal(new_opset(aTHX_ Nullsv)); void full_opset() CODE: dMY_CXT; 11 ST(0) = sv_2mortal(new_opset(aTHX_ opset_all)); void opmask_add(opset) SV *opset PREINIT: 3 if (!PL_op_mask) 2 Newz(0, PL_op_mask, PL_maxo, char); CODE: 3 opmask_add(aTHX_ opset); void opcodes() PPCODE: 5 if (GIMME == G_ARRAY) { ###### croak("opcodes in list context not yet implemented"); /* XXX */ } else { 5 XPUSHs(sv_2mortal(newSViv(PL_maxo))); } void opmask() CODE: 2 ST(0) = sv_2mortal(new_opset(aTHX_ Nullsv)); 2 if (PL_op_mask) { ###### char * const bitmap = SvPVX(ST(0)); ###### int myopcode; ###### for(myopcode=0; myopcode < PL_maxo; ++myopcode) { ###### if (PL_op_mask[myopcode]) ###### bitmap[myopcode >> 3] |= 1 << (myopcode & 0x07); } }