(Retracted by #11223.)

[perl5.git] / ext / Opcode / Opcode.xs

diff --git a/ext/Opcode/Opcode.xs b/ext/Opcode/Opcode.xs
index e853cf1..5f091f8 100644 (file)
--- a/ext/Opcode/Opcode.xs
+++ b/ext/Opcode/Opcode.xs
@@ -1,3 +1,4 @@
+#define PERL_NO_GET_CONTEXT

 #include "EXTERN.h"
 #include "perl.h"
 #include "XSUB.h"
 #include "EXTERN.h"
 #include "perl.h"
 #include "XSUB.h"


@@ -11,11 +12,11 @@ static SV *opset_all;               /* mask with all bits set               */
 static IV  opset_len;          /* length of opmasks in bytes           */
 static int opcode_debug = 0;
 
 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.
 
 
 /* Initialise our private op_named_bits HV.


@@ -27,7 +28,7 @@ static SV  *get_op_bitspec _((char *opname, STRLEN len, int fatal));
  */
 
 static void
  */
 
 static void

-op_names_init(void)
+op_names_init(pTHX)

 {
     int i;
     STRLEN len;
 {
     int i;
     STRLEN len;


@@ -43,16 +44,16 @@ op_names_init(void)
        hv_store(op_named_bits, op_names[i], strlen(op_names[i]), sv, 0);
     }
 
        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] = (PL_maxo & 0x07) ? ~(0xFF << (PL_maxo & 0x07)) : 0xFF;
     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] = (PL_maxo & 0x07) ? ~(0xFF << (PL_maxo & 0x07)) : 0xFF;

-    put_op_bitspec(":all",0, opset_all); /* don't mortalise */
+    put_op_bitspec(aTHX_ ":all",0, opset_all); /* don't mortalise */

 }
 
 
 }
 
 


@@ -62,10 +63,10 @@ op_names_init(void)
  */
 
 static void
  */
 
 static void

-put_op_bitspec(char *optag, STRLEN len, SV *mask)
+put_op_bitspec(pTHX_ char *optag, STRLEN len, SV *mask)

 {
     SV **svp;
 {
     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);
     if (!len)
        len = strlen(optag);
     svp = hv_fetch(op_named_bits, optag, len, 1);


@@ -83,7 +84,7 @@ put_op_bitspec(char *optag, STRLEN len, SV *mask)
  */
 
 static SV *
  */
 
 static SV *

-get_op_bitspec(char *opname, STRLEN len, int fatal)
+get_op_bitspec(pTHX_ char *opname, STRLEN len, int fatal)

 {
     SV **svp;
     if (!len)
 {
     SV **svp;
     if (!len)


@@ -106,11 +107,11 @@ get_op_bitspec(char *opname, STRLEN len, int fatal)
 
 
 static SV *
 
 
 static SV *

-new_opset(SV *old_opset)
+new_opset(pTHX_ SV *old_opset)

 {
     SV *opset;
     if (old_opset) {
 {
     SV *opset;
     if (old_opset) {

-       verify_opset(old_opset,1);
+       verify_opset(aTHX_ old_opset,1);

        opset = newSVsv(old_opset);
     }
     else {
        opset = newSVsv(old_opset);
     }
     else {


@@ -125,7 +126,7 @@ new_opset(SV *old_opset)
 
 
 static int
 
 
 static int

-verify_opset(SV *opset, int fatal)
+verify_opset(pTHX_ SV *opset, int fatal)

 {
     char *err = Nullch;
     if      (!SvOK(opset))              err = "undefined";
 {
     char *err = Nullch;
     if      (!SvOK(opset))              err = "undefined";


@@ -139,7 +140,7 @@ verify_opset(SV *opset, int fatal)
 
 
 static void
 
 
 static void

-set_opset_bits(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);
 {
     if (SvIOK(bitspec)) {
        int myopcode = SvIV(bitspec);


@@ -173,14 +174,14 @@ set_opset_bits(char *bitmap, SV *bitspec, int on, char *opname)
 
 
 static void
 
 
 static void

-opmask_add(SV *opset)  /* THE ONLY FUNCTION TO EDIT PL_op_mask ITSELF  */
+opmask_add(pTHX_ SV *opset)    /* THE ONLY FUNCTION TO EDIT PL_op_mask ITSELF  */

 {
     int i,j;
     char *bitmask;
     STRLEN len;
     int myopcode = 0;
 
 {
     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 (!PL_op_mask)           /* caller must ensure PL_op_mask exists */
        croak("Can't add to uninitialised PL_op_mask");
 
     if (!PL_op_mask)           /* caller must ensure PL_op_mask exists */
        croak("Can't add to uninitialised PL_op_mask");


@@ -200,23 +201,23 @@ opmask_add(SV *opset)     /* THE ONLY FUNCTION TO EDIT PL_op_mask ITSELF  */
 }
 
 static void
 }
 
 static void

-opmask_addlocal(SV *opset, char *op_mask_buf) /* Localise PL_op_mask then opmask_add() */
+opmask_addlocal(pTHX_ SV *opset, char *op_mask_buf) /* Localise PL_op_mask then opmask_add() */

 {
     char *orig_op_mask = PL_op_mask;
 {
     char *orig_op_mask = PL_op_mask;

-    SAVEPPTR(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)
 #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(CPERLscope(*))_((void*)))warn,"PL_op_mask restored");
+       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, PL_op_mask, PL_maxo, char);
     else
        Zero(PL_op_mask, PL_maxo, char);
 #endif
     PL_op_mask = &op_mask_buf[0];
     if (orig_op_mask)
        Copy(orig_op_mask, PL_op_mask, PL_maxo, char);
     else
        Zero(PL_op_mask, PL_maxo, char);

-    opmask_add(opset);
+    opmask_add(aTHX_ opset);

 }
 
 
 }
 
 


@@ -230,7 +231,27 @@ BOOT:
     opset_len = (PL_maxo + 7) / 8;
     if (opcode_debug >= 1)
        warn("opset_len %ld\n", (long)opset_len);
     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
 
 
 void


@@ -244,15 +265,18 @@ PPCODE:
 
     ENTER;
 
 
     ENTER;
 

-    opmask_addlocal(mask, op_mask_buf);
+    opmask_addlocal(aTHX_ mask, op_mask_buf);

 
     save_aptr(&PL_endav);
     PL_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(&PL_defstash);           /* save current default stack   */
+    save_hptr(&PL_defstash);           /* save current default stash   */

     /* the assignment to global defstash changes our sense of 'main'   */
     PL_defstash = gv_stashpv(Package, GV_ADDWARN); /* should exist already     */
 
     /* the assignment to global defstash changes our sense of 'main'   */
     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!        */
     /* 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!        */


@@ -260,7 +284,13 @@ PPCODE:
     sv_free((SV*)GvHV(gv));
     GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
 
     sv_free((SV*)GvHV(gv));
     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);

+    CvDEFSTASH(SvRV(codesv)) = PL_defstash;

     perl_call_sv(codesv, GIMME|G_EVAL|G_KEEPERR); /* use callers context */
     SPAGAIN; /* for the PUTBACK added by xsubpp */
     LEAVE;
     perl_call_sv(codesv, GIMME|G_EVAL|G_KEEPERR); /* use callers context */
     SPAGAIN; /* for the PUTBACK added by xsubpp */
     LEAVE;


@@ -270,7 +300,10 @@ int
 verify_opset(opset, fatal = 0)
     SV *opset
     int fatal
 verify_opset(opset, fatal = 0)
     SV *opset
     int fatal

-
+CODE:
+    RETVAL = verify_opset(aTHX_ opset,fatal);
+OUTPUT:
+    RETVAL

 
 void
 invert_opset(opset)
 
 void
 invert_opset(opset)


@@ -279,7 +312,7 @@ CODE:
     {
     char *bitmap;
     STRLEN len = opset_len;
     {
     char *bitmap;
     STRLEN len = opset_len;

-    opset = sv_2mortal(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];
     bitmap = SvPVX(opset);
     while(len-- > 0)
        bitmap[len] = ~bitmap[len];


@@ -300,7 +333,7 @@ PPCODE:
     int i, j, myopcode;
     char *bitmap = SvPV(opset, len);
     char **names = (desc) ? get_op_descs() : get_op_names();
     int i, j, myopcode;
     char *bitmap = SvPV(opset, len);
     char **names = (desc) ? get_op_descs() : get_op_names();

-    verify_opset(opset,1);
+    verify_opset(aTHX_ opset,1);

     for (myopcode=0, i=0; i < opset_len; i++) {
        U16 bits = bitmap[i];
        for (j=0; j < 8 && myopcode < PL_maxo; j++, myopcode++) {
     for (myopcode=0, i=0; i < opset_len; i++) {
        U16 bits = bitmap[i];
        for (j=0; j < 8 && myopcode < PL_maxo; j++, myopcode++) {


@@ -314,25 +347,25 @@ PPCODE:
 void
 opset(...)
 CODE:
 void
 opset(...)
 CODE:

-    int i, j;
+    int i;

     SV *bitspec, *opset;
     char *bitmap;
     STRLEN len, on;
     SV *bitspec, *opset;
     char *bitmap;
     STRLEN len, on;

-    opset = sv_2mortal(new_opset(Nullsv));
+    opset = sv_2mortal(new_opset(aTHX_ Nullsv));

     bitmap = SvPVX(opset);
     for (i = 0; i < items; i++) {
        char *opname;
        on = 1;
     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; }
            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;
 
     }
     ST(0) = opset;
 


@@ -357,13 +390,13 @@ CODE:
        croak("Not a Safe object");
     mask = *hv_fetch((HV*)SvRV(safe), "Mask",4, 1);
     if (ONLY_THESE)    /* *_only = new mask, else edit current */
        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(PERMITING ? opset_all : Nullsv)));
+       sv_setsv(mask, sv_2mortal(new_opset(aTHX_ PERMITING ? opset_all : Nullsv)));

     else
     else

-       verify_opset(mask,1); /* croaks */
+       verify_opset(aTHX_ mask,1); /* croaks */

     bitmap = SvPVX(mask);
     for (i = 1; i < items; i++) {
        on = PERMITING ? 0 : 1;         /* deny = mask bit on   */
     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);
        }
            opname = "(opset)";
            bitspec = ST(i);
        }


@@ -371,9 +404,9 @@ CODE:
            opname = SvPV(ST(i), len);
            /* invert if op has ! prefix (only one allowed)     */
            if (*opname == '!') { on = !on; ++opname; --len; }
            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) = &PL_sv_yes;
 
     }
     ST(0) = &PL_sv_yes;
 


@@ -388,10 +421,10 @@ PPCODE:
     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.  */
     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);
     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 >= PL_maxo)
        if (SvIOK(bitspec)) {
            myopcode = SvIV(bitspec);
            if (myopcode < 0 || myopcode >= PL_maxo)


@@ -400,7 +433,8 @@ PPCODE:
        }
        else if (SvPOK(bitspec) && SvCUR(bitspec) == opset_len) {
            int b, j;
        }
        else if (SvPOK(bitspec) && SvCUR(bitspec) == opset_len) {
            int b, j;

-           char *bitmap = SvPV(bitspec,PL_na);
+           STRLEN n_a;
+           char *bitmap = SvPV(bitspec,n_a);

            myopcode = 0;
            for (b=0; b < opset_len; b++) {
                U16 bits = bitmap[b];
            myopcode = 0;
            for (b=0; b < opset_len; b++) {
                U16 bits = bitmap[b];


@@ -422,19 +456,19 @@ define_optag(optagsv, mask)
 CODE:
     STRLEN len;
     char *optag = SvPV(optagsv, len);
 CODE:
     STRLEN len;
     char *optag = SvPV(optagsv, len);

-    put_op_bitspec(optag, len, mask); /* croaks */
+    put_op_bitspec(aTHX_ optag, len, mask); /* croaks */

     ST(0) = &PL_sv_yes;
 
 
 void
 empty_opset()
 CODE:
     ST(0) = &PL_sv_yes;
 
 
 void
 empty_opset()
 CODE:

-    ST(0) = sv_2mortal(new_opset(Nullsv));
+    ST(0) = sv_2mortal(new_opset(aTHX_ Nullsv));

 
 void
 full_opset()
 CODE:
 
 void
 full_opset()
 CODE:

-    ST(0) = sv_2mortal(new_opset(opset_all));
+    ST(0) = sv_2mortal(new_opset(aTHX_ opset_all));

 
 void
 opmask_add(opset)
 
 void
 opmask_add(opset)


@@ -442,6 +476,8 @@ opmask_add(opset)
 PREINIT:
     if (!PL_op_mask)
        Newz(0, PL_op_mask, PL_maxo, char);
 PREINIT:
     if (!PL_op_mask)
        Newz(0, PL_op_mask, PL_maxo, char);

+CODE:
+    opmask_add(aTHX_ opset);

 
 void
 opcodes()
 
 void
 opcodes()


@@ -456,7 +492,7 @@ PPCODE:
 void
 opmask()
 CODE:
 void
 opmask()
 CODE:

-    ST(0) = sv_2mortal(new_opset(Nullsv));
+    ST(0) = sv_2mortal(new_opset(aTHX_ Nullsv));

     if (PL_op_mask) {
        char *bitmap = SvPVX(ST(0));
        int myopcode;
     if (PL_op_mask) {
        char *bitmap = SvPVX(ST(0));
        int myopcode;