X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FOpcode%2FOpcode.xs;h=e2940598569e875737ee8cc2da19fd9aa7d73f88;hb=8c7314f9ab22287a19960f7531f5ca7120cc6843;hp=28678ed0f8b3a24f11483153e092fd6fc3fef554;hpb=bf81aadd817bdea29720b072eef945df2da8463b;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/ext/Opcode/Opcode.xs b/ext/Opcode/Opcode.xs
index 28678ed..e294059 100644
--- a/ext/Opcode/Opcode.xs
+++ b/ext/Opcode/Opcode.xs
@@ -1,53 +1,59 @@
+#define PERL_NO_GET_CONTEXT
 #include "EXTERN.h"
 #include "perl.h"
 #include "XSUB.h"
 
-/* maxo shouldn't differ from MAXO but leave room anyway (see BOOT:)	*/
+/* 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 */
 static HV *op_named_bits;	/* cache shared for whole process	*/
 static SV *opset_all;		/* mask with all bits set		*/
 static IV  opset_len;		/* length of opmasks in bytes		*/
 static int opcode_debug = 0;
 
-static SV  *new_opset _((SV *old_opset));
-static int  verify_opset _((SV *opset, int fatal));
-static void set_opset_bits _((char *bitmap, SV *bitspec, int on, char *opname));
-static void put_op_bitspec _((char *optag,  STRLEN len, SV *opset));
-static SV  *get_op_bitspec _((char *opname, STRLEN len, int fatal));
+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, char *opname);
+static void put_op_bitspec (pTHX_ char *optag,  STRLEN len, SV *opset);
+static SV  *get_op_bitspec (pTHX_ 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()
+op_names_init(pTHX)
 {
     int i;
     STRLEN len;
-    char *opname;
+    char **op_names;
     char *bitmap;
 
     op_named_bits = newHV();
-    for(i=0; i < maxo; ++i) {
-	hv_store(op_named_bits, op_name[i],strlen(op_name[i]),
-		Sv=newSViv(i), 0);
-	SvREADONLY_on(Sv);
+    op_names = get_op_names();
+    for(i=0; i < PL_maxo; ++i) {
+	SV *sv;
+	sv = newSViv(i);
+	SvREADONLY_on(sv);
+	hv_store(op_named_bits, op_names[i], strlen(op_names[i]), sv, 0);
     }
 
-    put_op_bitspec(":none",0, sv_2mortal(new_opset(Nullsv)));
+    put_op_bitspec(aTHX_ ":none",0, sv_2mortal(new_opset(aTHX_ Nullsv)));
 
-    opset_all = new_opset(Nullsv);
+    opset_all = new_opset(aTHX_ Nullsv);
     bitmap = SvPV(opset_all, len);
     i = len-1; /* deal with last byte specially, see below */
     while(i-- > 0)
 	bitmap[i] = 0xFF;
     /* Take care to set the right number of bits in the last byte */
-    bitmap[len-1] = (maxo & 0x07) ? ~(~0 << (maxo & 0x07)) : 0xFF;
-    put_op_bitspec(":all",0, opset_all); /* don't mortalise */
+    bitmap[len-1] = (PL_maxo & 0x07) ? ~(0xFF << (PL_maxo & 0x07)) : 0xFF;
+    put_op_bitspec(aTHX_ ":all",0, opset_all); /* don't mortalise */
 }
 
 
@@ -57,13 +63,10 @@ op_names_init()
  */
 
 static void
-put_op_bitspec(optag, len, mask)
-    char *optag;
-    STRLEN len;
-    SV *mask;
+put_op_bitspec(pTHX_ char *optag, STRLEN len, SV *mask)
 {
     SV **svp;
-    verify_opset(mask,1);
+    verify_opset(aTHX_ mask,1);
     if (!len)
 	len = strlen(optag);
     svp = hv_fetch(op_named_bits, optag, len, 1);
@@ -81,10 +84,7 @@ put_op_bitspec(optag, len, mask)
  */
 
 static SV *
-get_op_bitspec(opname, len, fatal)
-    char *opname;
-    STRLEN len;
-    int fatal;
+get_op_bitspec(pTHX_ char *opname, STRLEN len, int fatal)
 {
     SV **svp;
     if (!len)
@@ -107,17 +107,16 @@ get_op_bitspec(opname, len, fatal)
 
 
 static SV *
-new_opset(old_opset)
-    SV *old_opset;
+new_opset(pTHX_ SV *old_opset)
 {
     SV *opset;
     if (old_opset) {
-	verify_opset(old_opset,1);
+	verify_opset(aTHX_ old_opset,1);
 	opset = newSVsv(old_opset);
     }
     else {
-	opset = newSV(opset_len);
-	Zero(SvPVX(opset), opset_len, char);
+	opset = NEWSV(1156, opset_len);
+	Zero(SvPVX(opset), opset_len + 1, char);
 	SvCUR_set(opset, opset_len);
 	(void)SvPOK_only(opset);
     }
@@ -127,9 +126,7 @@ new_opset(old_opset)
 
 
 static int
-verify_opset(opset, fatal)
-    SV *opset;
-    int fatal;
+verify_opset(pTHX_ SV *opset, int fatal)
 {
     char *err = Nullch;
     if      (!SvOK(opset))              err = "undefined";
@@ -143,17 +140,13 @@ verify_opset(opset, fatal)
 
 
 static void
-set_opset_bits(bitmap, bitspec, on, opname)
-    char *bitmap;
-    SV *bitspec;
-    int on;
-    char *opname;
+set_opset_bits(pTHX_ char *bitmap, SV *bitspec, int on, char *opname)
 {
     if (SvIOK(bitspec)) {
 	int myopcode = SvIV(bitspec);
 	int offset = myopcode >> 3;
 	int bit    = myopcode & 0x07;
-	if (myopcode >= maxo || myopcode < 0)
+	if (myopcode >= PL_maxo || myopcode < 0)
 	    croak("panic: opcode \"%s\" value %d is invalid", opname, myopcode);
 	if (opcode_debug >= 2)
 	    warn("set_opset_bits bit %2d (off=%d, bit=%d) %s %s\n",
@@ -175,24 +168,23 @@ set_opset_bits(bitmap, bitspec, on, opname)
 	    while(len-- > 0) bitmap[len] &= ~specbits[len];
     }
     else
-	croak("panic: invalid bitspec for \"%s\" (type %lu)",
-		opname, (unsigned long)SvTYPE(bitspec));
+	croak("panic: invalid bitspec for \"%s\" (type %u)",
+		opname, (unsigned)SvTYPE(bitspec));
 }
 
 
 static void
-opmask_add(opset)	/* THE ONLY FUNCTION TO EDIT op_mask ITSELF	*/
-    SV *opset;
+opmask_add(pTHX_ SV *opset)	/* THE ONLY FUNCTION TO EDIT PL_op_mask ITSELF	*/
 {
     int i,j;
     char *bitmask;
     STRLEN len;
     int myopcode = 0;
 
-    verify_opset(opset,1);			/* croaks on bad opset	*/
+    verify_opset(aTHX_ opset,1);		/* croaks on bad opset	*/
 
-    if (!op_mask)		/* caller must ensure op_mask exists	*/
-	croak("Can't add to uninitialised op_mask");
+    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()	*/
 
@@ -203,26 +195,29 @@ opmask_add(opset)	/* THE ONLY FUNCTION TO EDIT op_mask ITSELF	*/
 	    myopcode += 8;
 	    continue;
 	}
-	for (j=0; j < 8 && myopcode < maxo; )
-	    op_mask[myopcode++] |= bits & (1 << j++);
+	for (j=0; j < 8 && myopcode < PL_maxo; )
+	    PL_op_mask[myopcode++] |= bits & (1 << j++);
     }
 }
 
 static void
-opmask_addlocal(opset, op_mask_buf) /* Localise op_mask then opmask_add() */
-    SV *opset;
-    char *op_mask_buf;
+opmask_addlocal(pTHX_ SV *opset, char *op_mask_buf) /* Localise PL_op_mask then opmask_add() */
 {
-    char *orig_op_mask = op_mask;
-    SAVEPPTR(op_mask);
+    char *orig_op_mask = PL_op_mask;
+    SAVEVPTR(PL_op_mask);
+#if !defined(PERL_OBJECT)
+    /* XXX casting to an ordinary function ptr from a member function ptr
+     * is disallowed by Borland
+     */
     if (opcode_debug >= 2)
-	SAVEDESTRUCTOR((void(*)_((void*)))warn,"op_mask restored");
-    op_mask = &op_mask_buf[0];
+	SAVEDESTRUCTOR((void(*)(void*))Perl_warn,"PL_op_mask restored");
+#endif
+    PL_op_mask = &op_mask_buf[0];
     if (orig_op_mask)
-	Copy(orig_op_mask, op_mask, maxo, char);
+	Copy(orig_op_mask, PL_op_mask, PL_maxo, char);
     else
-	Zero(op_mask, maxo, char);
-    opmask_add(opset);
+	Zero(PL_op_mask, PL_maxo, char);
+    opmask_add(aTHX_ opset);
 }
 
 
@@ -232,41 +227,69 @@ MODULE = Opcode	PACKAGE = Opcode
 PROTOTYPES: ENABLE
 
 BOOT:
-    assert(maxo < OP_MASK_BUF_SIZE);
-    opset_len = (maxo + 7) / 8;
+    assert(PL_maxo < OP_MASK_BUF_SIZE);
+    opset_len = (PL_maxo + 7) / 8;
     if (opcode_debug >= 1)
 	warn("opset_len %ld\n", (long)opset_len);
-    op_names_init();
+    op_names_init(aTHX);
+
+void
+_safe_pkg_prep(Package)
+    char *	Package
+PPCODE:
+    HV *hv; 
+    ENTER;
+   
+    hv = gv_stashpv(Package, GV_ADDWARN); /* should exist already	*/
+
+    if (strNE(HvNAME(hv),"main")) {
+        Safefree(HvNAME(hv));         
+        HvNAME(hv) = savepv("main"); /* make it think it's in main:: */
+        hv_store(hv,"_",1,(SV *)PL_defgv,0);  /* connect _ to global */
+        SvREFCNT_inc((SV *)PL_defgv);  /* want to keep _ around! */
+    }
+    LEAVE;
+
+
+
 
 
 void
-_safe_call_sv(package, mask, codesv)
-    char *	package
+_safe_call_sv(Package, mask, codesv)
+    char *	Package
     SV *	mask
     SV *	codesv
-    PPCODE:
+PPCODE:
     char op_mask_buf[OP_MASK_BUF_SIZE];
     GV *gv;
 
     ENTER;
 
-    opmask_addlocal(mask, op_mask_buf);
+    opmask_addlocal(aTHX_ mask, op_mask_buf);
 
-    save_aptr(&endav);
-    endav = (AV*)sv_2mortal((SV*)newAV()); /* ignore END blocks for now	*/
+    save_aptr(&PL_endav);
+    PL_endav = (AV*)sv_2mortal((SV*)newAV()); /* ignore END blocks for now	*/
 
-    save_hptr(&defstash);		/* save current default stack	*/
+    save_hptr(&PL_defstash);		/* save current default stash	*/
     /* the assignment to global defstash changes our sense of 'main'	*/
-    defstash = gv_stashpv(package, GV_ADDWARN); /* should exist already	*/
+    PL_defstash = gv_stashpv(Package, GV_ADDWARN); /* should exist already	*/
+
+    save_hptr(&PL_curstash);
+    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!	*/
     gv = gv_fetchpv("main::", GV_ADDWARN, SVt_PVHV);
     sv_free((SV*)GvHV(gv));
-    GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
+    GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
+
+    /* %INC must be clean for use/require in compartment */
+    save_hash(PL_incgv);
+    sv_free((SV*)GvHV(PL_incgv));  /* get rid of what save_hash gave us*/
+    GvHV(PL_incgv) = (HV*)SvREFCNT_inc(GvHV(gv_HVadd(gv_fetchpv("INC",TRUE,SVt_PVHV))));
 
-    PUSHMARK(sp);
+    PUSHMARK(SP);
     perl_call_sv(codesv, GIMME|G_EVAL|G_KEEPERR); /* use callers context */
     SPAGAIN; /* for the PUTBACK added by xsubpp */
     LEAVE;
@@ -276,21 +299,25 @@ int
 verify_opset(opset, fatal = 0)
     SV *opset
     int fatal
-
+CODE:
+    RETVAL = verify_opset(aTHX_ opset,fatal);
+OUTPUT:
+    RETVAL
 
 void
 invert_opset(opset)
     SV *opset
-    CODE:
+CODE:
     {
     char *bitmap;
     STRLEN len = opset_len;
-    opset = new_opset(opset);	/* verify and clone opset */
+    opset = sv_2mortal(new_opset(aTHX_ opset));	/* verify and clone opset */
     bitmap = SvPVX(opset);
     while(len-- > 0)
 	bitmap[len] = ~bitmap[len];
-    /* take care of extra bits beyond maxo in last byte	*/
-    bitmap[opset_len-1] &= ~(0xFF << (maxo & 0x0F));
+    /* take care of extra bits beyond PL_maxo in last byte	*/
+    if (PL_maxo & 07)
+	bitmap[opset_len-1] &= ~(0xFF << (PL_maxo & 0x07));
     }
     ST(0) = opset;
 
@@ -299,16 +326,16 @@ void
 opset_to_ops(opset, desc = 0)
     SV *opset
     int	desc
-    PPCODE:
+PPCODE:
     {
     STRLEN len;
     int i, j, myopcode;
     char *bitmap = SvPV(opset, len);
-    char **names = (desc) ? op_desc : op_name;
-    verify_opset(opset,1);
+    char **names = (desc) ? get_op_descs() : get_op_names();
+    verify_opset(aTHX_ opset,1);
     for (myopcode=0, i=0; i < opset_len; i++) {
 	U16 bits = bitmap[i];
-	for (j=0; j < 8 && myopcode < maxo; j++, myopcode++) {
+	for (j=0; j < 8 && myopcode < PL_maxo; j++, myopcode++) {
 	    if ( bits & (1 << j) )
 		XPUSHs(sv_2mortal(newSVpv(names[myopcode], 0)));
 	}
@@ -318,26 +345,26 @@ opset_to_ops(opset, desc = 0)
 
 void
 opset(...)
-    CODE:
+CODE:
     int i, j;
     SV *bitspec, *opset;
     char *bitmap;
     STRLEN len, on;
-    opset = new_opset(Nullsv);
+    opset = sv_2mortal(new_opset(aTHX_ Nullsv));
     bitmap = SvPVX(opset);
     for (i = 0; i < items; i++) {
 	char *opname;
 	on = 1;
-	if (verify_opset(ST(i),0)) {
+	if (verify_opset(aTHX_ ST(i),0)) {
 	    opname = "(opset)";
 	    bitspec = ST(i);
 	}
 	else {
 	    opname = SvPV(ST(i), len);
 	    if (*opname == '!') { on=0; ++opname;--len; }
-	    bitspec = get_op_bitspec(opname, len, 1);
+	    bitspec = get_op_bitspec(aTHX_ opname, len, 1);
 	}
-	set_opset_bits(bitmap, bitspec, on, opname);
+	set_opset_bits(aTHX_ bitmap, bitspec, on, opname);
     }
     ST(0) = opset;
 
@@ -348,11 +375,11 @@ opset(...)
 void
 permit_only(safe, ...)
     SV *safe
-    ALIAS:
+ALIAS:
 	permit    = 1
 	deny_only = 2
 	deny      = 3
-    CODE:
+CODE:
     int i, on;
     SV *bitspec, *mask;
     char *bitmap, *opname;
@@ -362,12 +389,13 @@ permit_only(safe, ...)
 	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, new_opset(PERMITING ? opset_all : Nullsv));
-    else verify_opset(mask,1); /* croaks */
+	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++) {
 	on = PERMITING ? 0 : 1;		/* deny = mask bit on	*/
-	if (verify_opset(ST(i),0)) {	/* it's a valid mask	*/
+	if (verify_opset(aTHX_ ST(i),0)) {	/* it's a valid mask	*/
 	    opname = "(opset)";
 	    bitspec = ST(i);
 	}
@@ -375,46 +403,48 @@ permit_only(safe, ...)
 	    opname = SvPV(ST(i), len);
 	    /* invert if op has ! prefix (only one allowed)	*/
 	    if (*opname == '!') { on = !on; ++opname; --len; }
-	    bitspec = get_op_bitspec(opname, len, 1); /* croaks */
+	    bitspec = get_op_bitspec(aTHX_ opname, len, 1); /* croaks */
 	}
-	set_opset_bits(bitmap, bitspec, on, opname);
+	set_opset_bits(aTHX_ bitmap, bitspec, on, opname);
     }
-    ST(0) = &sv_yes;
+    ST(0) = &PL_sv_yes;
 
 
 
 void
 opdesc(...)
-    PPCODE:
+PPCODE:
     int i, myopcode;
     STRLEN len;
     SV **args;
+    char **op_desc = get_op_descs(); 
     /* 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.	*/
-    args = (SV**)SvPVX(sv_2mortal(newSVpv((char*)&ST(0), items*sizeof(SV*))));
+    args = (SV**)SvPVX(sv_2mortal(newSVpvn((char*)&ST(0), items*sizeof(SV*))));
     for (i = 0; i < items; i++) {
 	char *opname = SvPV(args[i], len);
-	SV *bitspec = get_op_bitspec(opname, len, 1);
+	SV *bitspec = get_op_bitspec(aTHX_ opname, len, 1);
 	if (SvIOK(bitspec)) {
 	    myopcode = SvIV(bitspec);
-	    if (myopcode < 0 || myopcode >= maxo)
+	    if (myopcode < 0 || myopcode >= PL_maxo)
 		croak("panic: opcode %d (%s) out of range",myopcode,opname);
 	    XPUSHs(sv_2mortal(newSVpv(op_desc[myopcode], 0)));
 	}
 	else if (SvPOK(bitspec) && SvCUR(bitspec) == opset_len) {
 	    int b, j;
-	    char *bitmap = SvPV(bitspec,na);
+	    STRLEN n_a;
+	    char *bitmap = SvPV(bitspec,n_a);
 	    myopcode = 0;
 	    for (b=0; b < opset_len; b++) {
 		U16 bits = bitmap[b];
-		for (j=0; j < 8 && myopcode < maxo; j++, myopcode++)
+		for (j=0; j < 8 && myopcode < PL_maxo; j++, myopcode++)
 		    if (bits & (1 << j))
 			XPUSHs(sv_2mortal(newSVpv(op_desc[myopcode], 0)));
 	    }
 	}
 	else
-	    croak("panic: invalid bitspec for \"%s\" (type %lu)",
-		opname, (unsigned long)SvTYPE(bitspec));
+	    croak("panic: invalid bitspec for \"%s\" (type %u)",
+		opname, (unsigned)SvTYPE(bitspec));
     }
 
 
@@ -422,49 +452,51 @@ void
 define_optag(optagsv, mask)
     SV *optagsv
     SV *mask
-    CODE:
+CODE:
     STRLEN len;
     char *optag = SvPV(optagsv, len);
-    put_op_bitspec(optag, len, mask); /* croaks */
-    ST(0) = &sv_yes;
+    put_op_bitspec(aTHX_ optag, len, mask); /* croaks */
+    ST(0) = &PL_sv_yes;
 
 
 void
 empty_opset()
-    CODE:
-    ST(0) = sv_2mortal(new_opset(Nullsv));
+CODE:
+    ST(0) = sv_2mortal(new_opset(aTHX_ Nullsv));
 
 void
 full_opset()
-    CODE:
-    ST(0) = sv_2mortal(new_opset(opset_all));
+CODE:
+    ST(0) = sv_2mortal(new_opset(aTHX_ opset_all));
 
 void
 opmask_add(opset)
     SV *opset
-    PREINIT:
-    if (!op_mask)
-	Newz(0, op_mask, maxo, char);
+PREINIT:
+    if (!PL_op_mask)
+	Newz(0, PL_op_mask, PL_maxo, char);
+CODE:
+    opmask_add(aTHX_ opset);
 
 void
 opcodes()
-    PPCODE:
+PPCODE:
     if (GIMME == G_ARRAY) {
 	croak("opcodes in list context not yet implemented"); /* XXX */
     }
     else {
-	XPUSHs(sv_2mortal(newSViv(maxo)));
+	XPUSHs(sv_2mortal(newSViv(PL_maxo)));
     }
 
 void
 opmask()
-    CODE:
-    ST(0) = sv_2mortal(new_opset(Nullsv));
-    if (op_mask) {
+CODE:
+    ST(0) = sv_2mortal(new_opset(aTHX_ Nullsv));
+    if (PL_op_mask) {
 	char *bitmap = SvPVX(ST(0));
 	int myopcode;
-	for(myopcode=0; myopcode < maxo; ++myopcode) {
-	    if (op_mask[myopcode])
+	for(myopcode=0; myopcode < PL_maxo; ++myopcode) {
+	    if (PL_op_mask[myopcode])
 		bitmap[myopcode >> 3] |= 1 << (myopcode & 0x07);
 	}
     }