X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FB%2FB.xs;h=39e381d6f569a7d1c16eec246cc159c6bbf7a5ef;hb=445a12f622bad7d38f7d9dd52674ccc07f19205c;hp=3b8a7e35dea702788ca69d184a3872f21ac57dc4;hpb=cf86991c04b212c029b30807ecab507b784fd8ad;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/ext/B/B.xs b/ext/B/B.xs
index 3b8a7e3..39e381d 100644
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -10,15 +10,14 @@
 #include "EXTERN.h"
 #include "perl.h"
 #include "XSUB.h"
-#include "INTERN.h"
 
 #ifdef PERL_OBJECT
 #undef PL_op_name
 #undef PL_opargs 
 #undef PL_op_desc
-#define PL_op_name (pPerl->Perl_get_op_names())
-#define PL_opargs (pPerl->Perl_get_opargs())
-#define PL_op_desc (pPerl->Perl_get_op_descs())
+#define PL_op_name (get_op_names())
+#define PL_opargs (get_opargs())
+#define PL_op_desc (get_op_descs())
 #endif
 
 #ifdef PerlIO
@@ -53,15 +52,14 @@ typedef enum {
     OPc_UNOP,	/* 2 */
     OPc_BINOP,	/* 3 */
     OPc_LOGOP,	/* 4 */
-    OPc_CONDOP,	/* 5 */
-    OPc_LISTOP,	/* 6 */
-    OPc_PMOP,	/* 7 */
-    OPc_SVOP,	/* 8 */
-    OPc_GVOP,	/* 9 */
-    OPc_PVOP,	/* 10 */
-    OPc_CVOP,	/* 11 */
-    OPc_LOOP,	/* 12 */
-    OPc_COP	/* 13 */
+    OPc_LISTOP,	/* 5 */
+    OPc_PMOP,	/* 6 */
+    OPc_SVOP,	/* 7 */
+    OPc_GVOP,	/* 8 */
+    OPc_PVOP,	/* 9 */
+    OPc_CVOP,	/* 10 */
+    OPc_LOOP,	/* 11 */
+    OPc_COP	/* 12 */
 } opclass;
 
 static char *opclassnames[] = {
@@ -70,7 +68,6 @@ static char *opclassnames[] = {
     "B::UNOP",
     "B::BINOP",
     "B::LOGOP",
-    "B::CONDOP",
     "B::LISTOP",
     "B::PMOP",
     "B::SVOP",
@@ -83,8 +80,10 @@ static char *opclassnames[] = {
 
 static int walkoptree_debug = 0;	/* Flag for walkoptree debug hook */
 
+static SV *specialsv_list[4];
+
 static opclass
-cc_opclass(OP *o)
+cc_opclass(pTHX_ OP *o)
 {
     if (!o)
 	return OPc_NULL;
@@ -108,9 +107,6 @@ cc_opclass(OP *o)
     case OA_LOGOP:
 	return OPc_LOGOP;
 
-    case OA_CONDOP:
-	return OPc_CONDOP;
-
     case OA_LISTOP:
 	return OPc_LISTOP;
 
@@ -123,8 +119,16 @@ cc_opclass(OP *o)
     case OA_GVOP:
 	return OPc_GVOP;
 
-    case OA_PVOP:
-	return OPc_PVOP;
+    case OA_PVOP_OR_SVOP:
+        /*
+         * Character translations (tr///) are usually a PVOP, keeping a 
+         * pointer to a table of shorts used to look up translations.
+         * Under utf8, however, a simple table isn't practical; instead,
+         * the OP is an SVOP, and the SV is a reference to a swash
+         * (i.e., an RV pointing to an HV).
+         */
+	return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
+		? OPc_SVOP : OPc_PVOP;
 
     case OA_LOOP:
 	return OPc_LOOP;
@@ -178,19 +182,19 @@ cc_opclass(OP *o)
 }
 
 static char *
-cc_opclassname(OP *o)
+cc_opclassname(pTHX_ OP *o)
 {
-    return opclassnames[cc_opclass(o)];
+    return opclassnames[cc_opclass(aTHX_ o)];
 }
 
 static SV *
-make_sv_object(SV *arg, SV *sv)
+make_sv_object(pTHX_ SV *arg, SV *sv)
 {
     char *type = 0;
     IV iv;
     
-    for (iv = 0; iv < sizeof(PL_specialsv_list)/sizeof(SV*); iv++) {
-	if (sv == PL_specialsv_list[iv]) {
+    for (iv = 0; iv < sizeof(specialsv_list)/sizeof(SV*); iv++) {
+	if (sv == specialsv_list[iv]) {
 	    type = "B::SPECIAL";
 	    break;
 	}
@@ -204,16 +208,16 @@ make_sv_object(SV *arg, SV *sv)
 }
 
 static SV *
-make_mg_object(SV *arg, MAGIC *mg)
+make_mg_object(pTHX_ SV *arg, MAGIC *mg)
 {
     sv_setiv(newSVrv(arg, "B::MAGIC"), (IV)mg);
     return arg;
 }
 
 static SV *
-cstring(SV *sv)
+cstring(pTHX_ SV *sv)
 {
-    SV *sstr = newSVpv("", 0);
+    SV *sstr = newSVpvn("", 0);
     STRLEN len;
     char *s;
 
@@ -264,9 +268,9 @@ cstring(SV *sv)
 }
 
 static SV *
-cchar(SV *sv)
+cchar(pTHX_ SV *sv)
 {
-    SV *sstr = newSVpv("'", 0);
+    SV *sstr = newSVpvn("'", 1);
     STRLEN n_a;
     char *s = SvPV(sv, n_a);
 
@@ -303,76 +307,8 @@ cchar(SV *sv)
     return sstr;
 }
 
-#ifdef INDIRECT_BGET_MACROS
-void freadpv(U32 len, void *data)
-{
-    New(666, pv.xpv_pv, len, char);
-    fread(pv.xpv_pv, 1, len, (FILE*)data);
-    pv.xpv_len = len;
-    pv.xpv_cur = len - 1;
-}
-
-void byteload_fh(InputStream fp)
-{
-    struct bytestream bs;
-    bs.data = fp;
-    bs.fgetc = (int(*) _((void*)))fgetc;
-    bs.fread = (int(*) _((char*,size_t,size_t,void*)))fread;
-    bs.freadpv = freadpv;
-    byterun(bs);
-}
-
-static int fgetc_fromstring(void *data)
-{
-    char **strp = (char **)data;
-    return *(*strp)++;
-}
-
-static int fread_fromstring(char *argp, size_t elemsize, size_t nelem,
-			    void *data)
-{
-    char **strp = (char **)data;
-    size_t len = elemsize * nelem;
-    
-    memcpy(argp, *strp, len);
-    *strp += len;
-    return (int)len;
-}
-
-static void freadpv_fromstring(U32 len, void *data)
-{
-    char **strp = (char **)data;
-    
-    New(666, pv.xpv_pv, len, char);
-    memcpy(pv.xpv_pv, *strp, len);
-    pv.xpv_len = len;
-    pv.xpv_cur = len - 1;
-    *strp += len;
-}    
-
-void byteload_string(char *str)
-{
-    struct bytestream bs;
-    bs.data = &str;
-    bs.fgetc = fgetc_fromstring;
-    bs.fread = fread_fromstring;
-    bs.freadpv = freadpv_fromstring;
-    byterun(bs);
-}
-#else
-void byteload_fh(InputStream fp)
-{
-    byterun(fp);
-}
-
-void byteload_string(char *str)
-{
-    croak("Must compile with -DINDIRECT_BGET_MACROS for byteload_string");
-}    
-#endif /* INDIRECT_BGET_MACROS */
-
 void
-walkoptree(SV *opsv, char *method)
+walkoptree(pTHX_ SV *opsv, char *method)
 {
     dSP;
     OP *o;
@@ -395,8 +331,8 @@ walkoptree(SV *opsv, char *method)
 	OP *kid;
 	for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) {
 	    /* Use the same opsv. Rely on methods not to mess it up. */
-	    sv_setiv(newSVrv(opsv, cc_opclassname(kid)), (IV)kid);
-	    walkoptree(opsv, method);
+	    sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), (IV)kid);
+	    walkoptree(aTHX_ opsv, method);
 	}
     }
 }
@@ -405,7 +341,6 @@ typedef OP	*B__OP;
 typedef UNOP	*B__UNOP;
 typedef BINOP	*B__BINOP;
 typedef LOGOP	*B__LOGOP;
-typedef CONDOP	*B__CONDOP;
 typedef LISTOP	*B__LISTOP;
 typedef PMOP	*B__PMOP;
 typedef SVOP	*B__SVOP;
@@ -435,12 +370,21 @@ MODULE = B	PACKAGE = B	PREFIX = B_
 PROTOTYPES: DISABLE
 
 BOOT:
-    INIT_SPECIALSV_LIST;
+{
+    HV *stash = gv_stashpvn("B", 1, TRUE);
+    AV *export_ok = perl_get_av("B::EXPORT_OK",TRUE);
+    specialsv_list[0] = Nullsv;
+    specialsv_list[1] = &PL_sv_undef;
+    specialsv_list[2] = &PL_sv_yes;
+    specialsv_list[3] = &PL_sv_no;
+#include "defsubs.h"
+}
 
 #define B_main_cv()	PL_main_cv
 #define B_init_av()	PL_initav
 #define B_main_root()	PL_main_root
 #define B_main_start()	PL_main_start
+#define B_amagic_generation()	PL_amagic_generation
 #define B_comppadlist()	(PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv))
 #define B_sv_undef()	&PL_sv_undef
 #define B_sv_yes()	&PL_sv_yes
@@ -458,6 +402,9 @@ B_main_root()
 B::OP
 B_main_start()
 
+long 
+B_amagic_generation()
+
 B::AV
 B_comppadlist()
 
@@ -477,6 +424,8 @@ void
 walkoptree(opsv, method)
 	SV *	opsv
 	char *	method
+    CODE:
+	walkoptree(aTHX_ opsv, method);
 
 int
 walkoptree_debug(...)
@@ -487,19 +436,6 @@ walkoptree_debug(...)
     OUTPUT:
 	RETVAL
 
-int
-byteload_fh(fp)
-	InputStream    fp
-    CODE:
-	byteload_fh(fp);
-	RETVAL = 1;
-    OUTPUT:
-	RETVAL
-
-void
-byteload_string(str)
-	char *	str
-
 #define address(sv) (IV)sv
 
 IV
@@ -514,7 +450,28 @@ svref_2object(sv)
 	    croak("argument is not a reference");
 	RETVAL = (SV*)SvRV(sv);
     OUTPUT:
-	RETVAL
+	RETVAL              
+
+void
+opnumber(name)
+char *	name
+CODE:
+{
+ int i; 
+ IV  result = -1;
+ ST(0) = sv_newmortal();
+ if (strncmp(name,"pp_",3) == 0)
+   name += 3;
+ for (i = 0; i < PL_maxo; i++)
+  {
+   if (strcmp(name, PL_op_name[i]) == 0)
+    {
+     result = i;
+     break;
+    }
+  }
+ sv_setiv(ST(0),result);
+}
 
 void
 ppname(opnum)
@@ -552,10 +509,18 @@ minus_c()
 SV *
 cstring(sv)
 	SV *	sv
+    CODE:
+	RETVAL = cstring(aTHX_ sv);
+    OUTPUT:
+	RETVAL
 
 SV *
 cchar(sv)
 	SV *	sv
+    CODE:
+	RETVAL = cchar(aTHX_ sv);
+    OUTPUT:
+	RETVAL
 
 void
 threadsv_names()
@@ -566,7 +531,7 @@ threadsv_names()
 
 	EXTEND(sp, len);
 	for (i = 0; i < len; i++)
-	    PUSHs(sv_2mortal(newSVpv(&PL_threadsv_names[i], 1)));
+	    PUSHs(sv_2mortal(newSVpvn(&PL_threadsv_names[i], 1)));
 #endif
 
 
@@ -645,19 +610,6 @@ B::OP
 LOGOP_other(o)
 	B::LOGOP	o
 
-#define CONDOP_true(o)	o->op_true
-#define CONDOP_false(o)	o->op_false
-
-MODULE = B	PACKAGE = B::CONDOP		PREFIX = CONDOP_
-
-B::OP
-CONDOP_true(o)
-	B::CONDOP	o
-
-B::OP
-CONDOP_false(o)
-	B::CONDOP	o
-
 #define LISTOP_children(o)	o->op_children
 
 MODULE = B	PACKAGE = B::LISTOP		PREFIX = LISTOP_
@@ -689,7 +641,7 @@ PMOP_pmreplroot(o)
 		     (IV)root);
 	}
 	else {
-	    sv_setiv(newSVrv(ST(0), cc_opclassname(root)), (IV)root);
+	    sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), (IV)root);
 	}
 
 B::OP
@@ -774,6 +726,7 @@ LOOP_lastop(o)
 #define COP_cop_seq(o)	o->cop_seq
 #define COP_arybase(o)	o->cop_arybase
 #define COP_line(o)	o->cop_line
+#define COP_warnings(o)	o->cop_warnings
 
 MODULE = B	PACKAGE = B::COP		PREFIX = COP_
 
@@ -801,6 +754,10 @@ U16
 COP_line(o)
 	B::COP	o
 
+B::SV
+COP_warnings(o)
+	B::COP	o
+
 MODULE = B	PACKAGE = B::SV		PREFIX = Sv
 
 U32
@@ -821,6 +778,11 @@ IV
 SvIVX(sv)
 	B::IV	sv
 
+UV 
+SvUVX(sv) 
+	B::IV   sv
+                      
+
 MODULE = B	PACKAGE = B::IV
 
 #define needs64bits(sv) ((I32)SvIVX(sv) != SvIVX(sv))
@@ -845,10 +807,10 @@ packiv(sv)
 	     */
 	    wp[0] = htonl(((U32)iv) >> (sizeof(IV)*4));
 	    wp[1] = htonl(iv & 0xffffffff);
-	    ST(0) = sv_2mortal(newSVpv((char *)wp, 8));
+	    ST(0) = sv_2mortal(newSVpvn((char *)wp, 8));
 	} else {
 	    U32 w = htonl((U32)SvIVX(sv));
-	    ST(0) = sv_2mortal(newSVpv((char *)&w, 4));
+	    ST(0) = sv_2mortal(newSVpvn((char *)&w, 4));
 	}
 
 MODULE = B	PACKAGE = B::NV		PREFIX = Sv
@@ -876,6 +838,14 @@ SvPV(sv)
 	ST(0) = sv_newmortal();
 	sv_setpvn(ST(0), SvPVX(sv), SvCUR(sv));
 
+STRLEN
+SvLEN(sv)
+	B::PV	sv
+
+STRLEN
+SvCUR(sv)
+	B::PV	sv
+
 MODULE = B	PACKAGE = B::PVMG	PREFIX = Sv
 
 void
@@ -884,7 +854,7 @@ SvMAGIC(sv)
 	MAGIC *	mg = NO_INIT
     PPCODE:
 	for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
-	    XPUSHs(make_mg_object(sv_newmortal(), mg));
+	    XPUSHs(make_mg_object(aTHX_ sv_newmortal(), mg));
 
 MODULE = B	PACKAGE = B::PVMG
 
@@ -897,6 +867,7 @@ SvSTASH(sv)
 #define MgTYPE(mg) mg->mg_type
 #define MgFLAGS(mg) mg->mg_flags
 #define MgOBJ(mg) mg->mg_obj
+#define MgLENGTH(mg) mg->mg_len
 
 MODULE = B	PACKAGE = B::MAGIC	PREFIX = Mg	
 
@@ -920,13 +891,23 @@ B::SV
 MgOBJ(mg)
 	B::MAGIC	mg
 
+I32 
+MgLENGTH(mg)
+	B::MAGIC	mg
+ 
 void
 MgPTR(mg)
 	B::MAGIC	mg
     CODE:
 	ST(0) = sv_newmortal();
-	if (mg->mg_ptr)
-	    sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len);
+ 	if (mg->mg_ptr){
+		if (mg->mg_len >= 0){
+	    		sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len);
+		} else {
+			if (mg->mg_len == HEf_SVKEY)	
+				sv_setsv(ST(0),newRV((SV*)mg->mg_ptr));
+		}
+	}
 
 MODULE = B	PACKAGE = B::PVLV	PREFIX = Lv
 
@@ -968,7 +949,7 @@ BmTABLE(sv)
     CODE:
 	str = SvPV(sv, len);
 	/* Boyer-Moore table is just after string and its safety-margin \0 */
-	ST(0) = sv_2mortal(newSVpv(str + len + 1, 256));
+	ST(0) = sv_2mortal(newSVpvn(str + len + 1, 256));
 
 MODULE = B	PACKAGE = B::GV		PREFIX = Gv
 
@@ -976,7 +957,7 @@ void
 GvNAME(gv)
 	B::GV	gv
     CODE:
-	ST(0) = sv_2mortal(newSVpv(GvNAME(gv), GvNAMELEN(gv)));
+	ST(0) = sv_2mortal(newSVpvn(GvNAME(gv), GvNAMELEN(gv)));
 
 B::HV
 GvSTASH(gv)
@@ -1112,7 +1093,7 @@ AvARRAY(av)
 	    SV **svp = AvARRAY(av);
 	    I32 i;
 	    for (i = 0; i <= AvFILL(av); i++)
-		XPUSHs(make_sv_object(sv_newmortal(), svp[i]));
+		XPUSHs(make_sv_object(aTHX_ sv_newmortal(), svp[i]));
 	}
 
 MODULE = B	PACKAGE = B::AV
@@ -1212,7 +1193,7 @@ HvARRAY(hv)
 	    (void)hv_iterinit(hv);
 	    EXTEND(sp, HvKEYS(hv) * 2);
 	    while (sv = hv_iternextsv(hv, &key, &len)) {
-		PUSHs(newSVpv(key, len));
-		PUSHs(make_sv_object(sv_newmortal(), sv));
+		PUSHs(newSVpvn(key, len));
+		PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv));
 	    }
 	}