X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FB%2FB.xs;h=d7ae0f11014291b1b7b80f9027fa32929f6ca8e8;hb=ece599bdb7307c953714bad8b5a320ffa2cd0857;hp=4867e71291fc6a50049de079dac7986b00409e7d;hpb=11faa288e292c27cb2ddc4ccdc483b523d26ce19;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/B/B.xs b/ext/B/B.xs index 4867e71..d7ae0f1 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -12,15 +12,6 @@ #include "perl.h" #include "XSUB.h" -#ifdef PERL_OBJECT -#undef PL_op_name -#undef PL_opargs -#undef PL_op_desc -#define PL_op_name (get_op_names()) -#define PL_opargs (get_opargs()) -#define PL_op_desc (get_op_descs()) -#endif - #ifdef PerlIO typedef PerlIO * InputStream; #else @@ -79,9 +70,17 @@ static char *opclassnames[] = { "B::COP" }; -static int walkoptree_debug = 0; /* Flag for walkoptree debug hook */ +#define MY_CXT_KEY "B::_guts" XS_VERSION + +typedef struct { + int x_walkoptree_debug; /* Flag for walkoptree debug hook */ + SV * x_specialsv_list[7]; +} my_cxt_t; + +START_MY_CXT -static SV *specialsv_list[4]; +#define walkoptree_debug (MY_CXT.x_walkoptree_debug) +#define specialsv_list (MY_CXT.x_specialsv_list) static opclass cc_opclass(pTHX_ OP *o) @@ -95,6 +94,11 @@ cc_opclass(pTHX_ OP *o) if (o->op_type == OP_SASSIGN) return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP); +#ifdef USE_ITHREADS + if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST) + return OPc_PADOP; +#endif + switch (PL_opargs[o->op_type] & OA_CLASS_MASK) { case OA_BASEOP: return OPc_BASEOP; @@ -158,8 +162,11 @@ cc_opclass(pTHX_ OP *o) * an SVOP (and op_sv is the GV for the filehandle argument). */ return ((o->op_flags & OPf_KIDS) ? OPc_UNOP : +#ifdef USE_ITHREADS + (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP); +#else (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP); - +#endif case OA_LOOPEXOP: /* * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a @@ -193,6 +200,7 @@ make_sv_object(pTHX_ SV *arg, SV *sv) { char *type = 0; IV iv; + dMY_CXT; for (iv = 0; iv < sizeof(specialsv_list)/sizeof(SV*); iv++) { if (sv == specialsv_list[iv]) { @@ -216,14 +224,43 @@ make_mg_object(pTHX_ SV *arg, MAGIC *mg) } static SV * -cstring(pTHX_ SV *sv) +cstring(pTHX_ SV *sv, bool perlstyle) { SV *sstr = newSVpvn("", 0); STRLEN len; char *s; + char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */ if (!SvOK(sv)) sv_setpvn(sstr, "0", 1); + else if (perlstyle && SvUTF8(sv)) + { + SV *tmpsv = sv_newmortal(); /* Temporary SV to feed sv_uni_display */ + len = SvCUR(sv); + s = sv_uni_display(tmpsv, sv, 8*len, UNI_DISPLAY_QQ); + sv_setpv(sstr,"\""); + while (*s) + { + if (*s == '"') + sv_catpv(sstr, "\\\""); + else if (*s == '$') + sv_catpv(sstr, "\\$"); + else if (*s == '@') + sv_catpv(sstr, "\\@"); + else if (*s == '\\') + { + if (strchr("nrftax\\",*(s+1))) + sv_catpvn(sstr, s++, 2); + else + sv_catpv(sstr, "\\\\"); + } + else /* should always be printable */ + sv_catpvn(sstr, s, 1); + ++s; + } + sv_catpv(sstr, "\""); + return sstr; + } else { /* XXX Optimise? */ @@ -236,7 +273,21 @@ cstring(pTHX_ SV *sv) sv_catpv(sstr, "\\\""); else if (*s == '\\') sv_catpv(sstr, "\\\\"); - else if (*s >= ' ' && *s < 127) /* XXX not portable */ + /* trigraphs - bleagh */ + else if (!perlstyle && *s == '?' && len>=3 && s[1] == '?') + { + sprintf(escbuff, "\\%03o", '?'); + sv_catpv(sstr, escbuff); + } + else if (perlstyle && *s == '$') + sv_catpv(sstr, "\\$"); + else if (perlstyle && *s == '@') + sv_catpv(sstr, "\\@"); +#ifdef EBCDIC + else if (isPRINT(*s)) +#else + else if (*s >= ' ' && *s < 127) +#endif /* EBCDIC */ sv_catpvn(sstr, s, 1); else if (*s == '\n') sv_catpv(sstr, "\\n"); @@ -250,12 +301,10 @@ cstring(pTHX_ SV *sv) sv_catpv(sstr, "\\b"); else if (*s == '\f') sv_catpv(sstr, "\\f"); - else if (*s == '\v') + else if (!perlstyle && *s == '\v') sv_catpv(sstr, "\\v"); else { - /* no trigraph support */ - char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */ /* Don't want promotion of a signed -1 char in sprintf args */ unsigned char c = (unsigned char) *s; sprintf(escbuff, "\\%03o", c); @@ -279,7 +328,11 @@ cchar(pTHX_ SV *sv) sv_catpv(sstr, "\\'"); else if (*s == '\\') sv_catpv(sstr, "\\\\"); - else if (*s >= ' ' && *s < 127) /* XXX not portable */ +#ifdef EBCDIC + else if (isPRINT(*s)) +#else + else if (*s >= ' ' && *s < 127) +#endif /* EBCDIC */ sv_catpvn(sstr, s, 1); else if (*s == '\n') sv_catpv(sstr, "\\n"); @@ -312,8 +365,9 @@ void walkoptree(pTHX_ SV *opsv, char *method) { dSP; - OP *o; - + OP *o, *kid; + dMY_CXT; + if (!SvROK(opsv)) croak("opsv is not a reference"); opsv = sv_mortalcopy(opsv); @@ -329,13 +383,18 @@ walkoptree(pTHX_ SV *opsv, char *method) PUTBACK; perl_call_method(method, G_DISCARD); if (o && (o->op_flags & OPf_KIDS)) { - 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(aTHX_ kid)), PTR2IV(kid)); walkoptree(aTHX_ opsv, method); } } + if (o && (cc_opclass(aTHX_ o) == OPc_PMOP) + && (kid = cPMOPo->op_pmreplroot)) + { + sv_setiv(newSVrv(opsv, opclassnames[OPc_PMOP]), PTR2IV(kid)); + walkoptree(aTHX_ opsv, method); + } } typedef OP *B__OP; @@ -374,15 +433,22 @@ BOOT: { HV *stash = gv_stashpvn("B", 1, TRUE); AV *export_ok = perl_get_av("B::EXPORT_OK",TRUE); + MY_CXT_INIT; specialsv_list[0] = Nullsv; specialsv_list[1] = &PL_sv_undef; specialsv_list[2] = &PL_sv_yes; specialsv_list[3] = &PL_sv_no; + specialsv_list[4] = pWARN_ALL; + specialsv_list[5] = pWARN_NONE; + specialsv_list[6] = pWARN_STD; #include "defsubs.h" } #define B_main_cv() PL_main_cv #define B_init_av() PL_initav +#define B_check_av() PL_checkav_save +#define B_begin_av() PL_beginav_save +#define B_end_av() PL_endav #define B_main_root() PL_main_root #define B_main_start() PL_main_start #define B_amagic_generation() PL_amagic_generation @@ -390,10 +456,29 @@ BOOT: #define B_sv_undef() &PL_sv_undef #define B_sv_yes() &PL_sv_yes #define B_sv_no() &PL_sv_no +#ifdef USE_ITHREADS +#define B_regex_padav() PL_regex_padav +#endif B::AV B_init_av() +B::AV +B_check_av() + +B::AV +B_begin_av() + +B::AV +B_end_av() + +#ifdef USE_ITHREADS + +B::AV +B_regex_padav() + +#endif + B::CV B_main_cv() @@ -431,6 +516,7 @@ walkoptree(opsv, method) int walkoptree_debug(...) CODE: + dMY_CXT; RETVAL = walkoptree_debug; if (items > 0 && SvTRUE(ST(1))) walkoptree_debug = 1; @@ -491,10 +577,10 @@ hash(sv) char *s; STRLEN len; U32 hash = 0; - char hexhash[19]; /* must fit "0xffffffff" plus trailing \0 */ + char hexhash[19]; /* must fit "0xffffffffffffffff" plus trailing \0 */ s = SvPV(sv, len); PERL_HASH(hash, s, len); - sprintf(hexhash, "0x%x", hash); + sprintf(hexhash, "0x%"UVxf, (UV)hash); ST(0) = sv_2mortal(newSVpv(hexhash, 0)); #define cast_I32(foo) (I32)foo @@ -507,11 +593,24 @@ minus_c() CODE: PL_minus_c = TRUE; +void +save_BEGINs() + CODE: + PL_savebegin = TRUE; + SV * cstring(sv) SV * sv CODE: - RETVAL = cstring(aTHX_ sv); + RETVAL = cstring(aTHX_ sv, 0); + OUTPUT: + RETVAL + +SV * +perlstring(sv) + SV * sv + CODE: + RETVAL = cstring(aTHX_ sv, 1); OUTPUT: RETVAL @@ -526,7 +625,7 @@ cchar(sv) void threadsv_names() PPCODE: -#ifdef USE_THREADS +#ifdef USE_5005THREADS int i; STRLEN len = strlen(PL_threadsv_names); @@ -559,17 +658,24 @@ char * OP_name(o) B::OP o CODE: - ST(0) = sv_newmortal(); - sv_setpv(ST(0), PL_op_name[o->op_type]); + RETVAL = PL_op_name[o->op_type]; + OUTPUT: + RETVAL -char * +void OP_ppaddr(o) B::OP o + PREINIT: + int i; + SV *sv = sv_newmortal(); CODE: - ST(0) = sv_newmortal(); - sv_setpvn(ST(0), "Perl_pp_", 8); - sv_catpv(ST(0), PL_op_name[o->op_type]); + sv_setpvn(sv, "PL_ppaddr[OP_", 13); + sv_catpv(sv, PL_op_name[o->op_type]); + for (i=13; (STRLEN)i < SvCUR(sv); ++i) + SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]); + sv_catpv(sv, "]"); + ST(0) = sv; char * OP_desc(o) @@ -619,20 +725,31 @@ B::OP LOGOP_other(o) B::LOGOP o -#define LISTOP_children(o) o->op_children - MODULE = B PACKAGE = B::LISTOP PREFIX = LISTOP_ U32 LISTOP_children(o) B::LISTOP o + OP * kid = NO_INIT + int i = NO_INIT + CODE: + i = 0; + for (kid = o->op_first; kid; kid = kid->op_sibling) + i++; + RETVAL = i; + OUTPUT: + RETVAL #define PMOP_pmreplroot(o) o->op_pmreplroot #define PMOP_pmreplstart(o) o->op_pmreplstart #define PMOP_pmnext(o) o->op_pmnext -#define PMOP_pmregexp(o) o->op_pmregexp +#define PMOP_pmregexp(o) PM_GETRE(o) +#ifdef USE_ITHREADS +#define PMOP_pmoffset(o) o->op_pmoffset +#endif #define PMOP_pmflags(o) o->op_pmflags #define PMOP_pmpermflags(o) o->op_pmpermflags +#define PMOP_pmdynflags(o) o->op_pmdynflags MODULE = B PACKAGE = B::PMOP PREFIX = PMOP_ @@ -645,9 +762,13 @@ PMOP_pmreplroot(o) root = o->op_pmreplroot; /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */ if (o->op_type == OP_PUSHRE) { +#ifdef USE_ITHREADS + sv_setiv(ST(0), INT2PTR(PADOFFSET,root) ); +#else sv_setiv(newSVrv(ST(0), root ? svclassnames[SvTYPE((SV*)root)] : "B::SV"), PTR2IV(root)); +#endif } else { sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root)); @@ -661,27 +782,38 @@ B::PMOP PMOP_pmnext(o) B::PMOP o -U16 +#ifdef USE_ITHREADS + +IV +PMOP_pmoffset(o) + B::PMOP o + +#endif + +U32 PMOP_pmflags(o) B::PMOP o -U16 +U32 PMOP_pmpermflags(o) B::PMOP o +U8 +PMOP_pmdynflags(o) + B::PMOP o + void PMOP_precomp(o) B::PMOP o REGEXP * rx = NO_INIT CODE: ST(0) = sv_newmortal(); - rx = o->op_pmregexp; + rx = PM_GETRE(o); if (rx) sv_setpvn(ST(0), rx->precomp, rx->prelen); -#define SVOP_sv(o) o->op_sv -#define SVOP_gv(o) ((SvTYPE(o->op_sv) == SVt_PVGV) \ - ? (GV*)o->op_sv : Nullgv) +#define SVOP_sv(o) cSVOPo->op_sv +#define SVOP_gv(o) ((GV*)cSVOPo->op_sv) MODULE = B PACKAGE = B::SVOP PREFIX = SVOP_ @@ -720,11 +852,22 @@ PVOP_pv(o) B::PVOP o CODE: /* - * OP_TRANS uses op_pv to point to a table of 256 shorts + * OP_TRANS uses op_pv to point to a table of 256 or >=258 shorts * whereas other PVOPs point to a null terminated string. */ - ST(0) = sv_2mortal(newSVpv(o->op_pv, (o->op_type == OP_TRANS) ? - 256 * sizeof(short) : 0)); + if (o->op_type == OP_TRANS && + (o->op_private & OPpTRANS_COMPLEMENT) && + !(o->op_private & OPpTRANS_DELETE)) + { + short* tbl = (short*)o->op_pv; + short entries = 257 + tbl[256]; + ST(0) = sv_2mortal(newSVpv(o->op_pv, entries * sizeof(short))); + } + else if (o->op_type == OP_TRANS) { + ST(0) = sv_2mortal(newSVpv(o->op_pv, 256 * sizeof(short))); + } + else + ST(0) = sv_2mortal(newSVpv(o->op_pv, 0)); #define LOOP_redoop(o) o->op_redoop #define LOOP_nextop(o) o->op_nextop @@ -849,11 +992,11 @@ packiv(sv) MODULE = B PACKAGE = B::NV PREFIX = Sv -double +NV SvNV(sv) B::NV sv -double +NV SvNVX(sv) B::NV sv @@ -865,12 +1008,37 @@ SvRV(sv) MODULE = B PACKAGE = B::PV PREFIX = Sv +char* +SvPVX(sv) + B::PV sv + +B::SV +SvRV(sv) + B::PV sv + CODE: + if( SvROK(sv) ) { + RETVAL = SvRV(sv); + } + else { + croak( "argument is not SvROK" ); + } + OUTPUT: + RETVAL + void SvPV(sv) B::PV sv CODE: - ST(0) = sv_newmortal(); - sv_setpvn(ST(0), SvPVX(sv), SvCUR(sv)); + ST(0) = sv_newmortal(); + if( SvPOK(sv) ) { + sv_setpvn(ST(0), SvPVX(sv), SvCUR(sv)); + SvFLAGS(ST(0)) |= SvUTF8(sv); + } + else { + /* XXX for backward compatibility, but should fail */ + /* croak( "argument is not SvPOK" ); */ + sv_setpvn(ST(0), NULL, 0); + } STRLEN SvLEN(sv) @@ -902,6 +1070,7 @@ SvSTASH(sv) #define MgFLAGS(mg) mg->mg_flags #define MgOBJ(mg) mg->mg_obj #define MgLENGTH(mg) mg->mg_len +#define MgREGEX(mg) PTR2IV(mg->mg_obj) MODULE = B PACKAGE = B::MAGIC PREFIX = Mg @@ -924,6 +1093,43 @@ MgFLAGS(mg) B::SV MgOBJ(mg) B::MAGIC mg + CODE: + if( mg->mg_type != 'r' ) { + RETVAL = MgOBJ(mg); + } + else { + croak( "OBJ is not meaningful on r-magic" ); + } + OUTPUT: + RETVAL + +IV +MgREGEX(mg) + B::MAGIC mg + CODE: + if( mg->mg_type == 'r' ) { + RETVAL = MgREGEX(mg); + } + else { + croak( "REGEX is only meaningful on r-magic" ); + } + OUTPUT: + RETVAL + +SV* +precomp(mg) + B::MAGIC mg + CODE: + if (mg->mg_type == 'r') { + REGEXP* rx = (REGEXP*)mg->mg_obj; + if( rx ) + RETVAL = newSVpvn( rx->precomp, rx->prelen ); + } + else { + croak( "precomp is only meaningful on r-magic" ); + } + OUTPUT: + RETVAL I32 MgLENGTH(mg) @@ -993,6 +1199,14 @@ GvNAME(gv) CODE: ST(0) = sv_2mortal(newSVpvn(GvNAME(gv), GvNAMELEN(gv))); +bool +is_empty(gv) + B::GV gv + CODE: + RETVAL = GvGP(gv) == Null(GP*); + OUTPUT: + RETVAL + B::HV GvSTASH(gv) B::GV gv @@ -1097,6 +1311,29 @@ short IoSUBPROCESS(io) B::IO io +bool +IsSTD(io,name) + B::IO io + char* name + PREINIT: + PerlIO* handle = 0; + CODE: + if( strEQ( name, "stdin" ) ) { + handle = PerlIO_stdin(); + } + else if( strEQ( name, "stdout" ) ) { + handle = PerlIO_stdout(); + } + else if( strEQ( name, "stderr" ) ) { + handle = PerlIO_stderr(); + } + else { + croak( "Invalid value '%s'", name ); + } + RETVAL = handle == IoIFP(io); + OUTPUT: + RETVAL + MODULE = B PACKAGE = B::IO char @@ -1185,14 +1422,22 @@ void CvXSUBANY(cv) B::CV cv CODE: - ST(0) = sv_2mortal(newSViv(CvXSUBANY(cv).any_iv)); + ST(0) = CvCONST(cv) ? + make_sv_object(aTHX_ sv_newmortal(),CvXSUBANY(cv).any_ptr) : + sv_2mortal(newSViv(CvXSUBANY(cv).any_iv)); MODULE = B PACKAGE = B::CV -U8 +U16 CvFLAGS(cv) B::CV cv +MODULE = B PACKAGE = B::CV PREFIX = cv_ + +B::SV +cv_const_sv(cv) + B::CV cv + MODULE = B PACKAGE = B::HV PREFIX = Hv @@ -1230,7 +1475,7 @@ HvARRAY(hv) I32 len; (void)hv_iterinit(hv); EXTEND(sp, HvKEYS(hv) * 2); - while (sv = hv_iternextsv(hv, &key, &len)) { + while ((sv = hv_iternextsv(hv, &key, &len))) { PUSHs(newSVpvn(key, len)); PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv)); }