X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FB%2FB.xs;h=f9c8647b963a6bc408869c4187f89615a196866f;hb=00baac8f3bcc04befcd869d03d8fa7c580011507;hp=39e381d6f569a7d1c16eec246cc159c6bbf7a5ef;hpb=445a12f622bad7d38f7d9dd52674ccc07f19205c;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/B/B.xs b/ext/B/B.xs index 39e381d..f9c8647 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -7,19 +7,11 @@ * */ +#define PERL_NO_GET_CONTEXT #include "EXTERN.h" #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 @@ -27,7 +19,7 @@ typedef FILE * InputStream; #endif -static char *svclassnames[] = { +static const char* const svclassnames[] = { "B::NULL", "B::IV", "B::NV", @@ -37,11 +29,16 @@ static char *svclassnames[] = { "B::PVNV", "B::PVMG", "B::BM", +#if PERL_VERSION >= 9 + "B::GV", +#endif "B::PVLV", "B::AV", "B::HV", "B::CV", +#if PERL_VERSION <= 8 "B::GV", +#endif "B::FM", "B::IO", }; @@ -55,14 +52,13 @@ typedef enum { OPc_LISTOP, /* 5 */ OPc_PMOP, /* 6 */ OPc_SVOP, /* 7 */ - OPc_GVOP, /* 8 */ + OPc_PADOP, /* 8 */ OPc_PVOP, /* 9 */ - OPc_CVOP, /* 10 */ - OPc_LOOP, /* 11 */ - OPc_COP /* 12 */ + OPc_LOOP, /* 10 */ + OPc_COP /* 11 */ } opclass; -static char *opclassnames[] = { +static const char* const opclassnames[] = { "B::NULL", "B::OP", "B::UNOP", @@ -71,19 +67,41 @@ static char *opclassnames[] = { "B::LISTOP", "B::PMOP", "B::SVOP", - "B::GVOP", + "B::PADOP", "B::PVOP", - "B::CVOP", "B::LOOP", "B::COP" }; -static int walkoptree_debug = 0; /* Flag for walkoptree debug hook */ +static const size_t opsizes[] = { + 0, + sizeof(OP), + sizeof(UNOP), + sizeof(BINOP), + sizeof(LOGOP), + sizeof(LISTOP), + sizeof(PMOP), + sizeof(SVOP), + sizeof(PADOP), + sizeof(PVOP), + sizeof(LOOP), + sizeof(COP) +}; + +#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) +cc_opclass(pTHX_ const OP *o) { if (!o) return OPc_NULL; @@ -94,6 +112,12 @@ 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 || o->op_type == OP_RCATLINE) + return OPc_PADOP; +#endif + switch (PL_opargs[o->op_type] & OA_CLASS_MASK) { case OA_BASEOP: return OPc_BASEOP; @@ -116,8 +140,8 @@ cc_opclass(pTHX_ OP *o) case OA_SVOP: return OPc_SVOP; - case OA_GVOP: - return OPc_GVOP; + case OA_PADOP: + return OPc_PADOP; case OA_PVOP_OR_SVOP: /* @@ -154,11 +178,14 @@ cc_opclass(pTHX_ OP *o) * return OPc_UNOP so that walkoptree can find our children. If * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set * (no argument to the operator) it's an OP; with OPf_REF set it's - * a GVOP (and op_gv is the GV for the filehandle argument). + * an SVOP (and op_sv is the GV for the filehandle argument). */ return ((o->op_flags & OPf_KIDS) ? OPc_UNOP : - (o->op_flags & OPf_REF) ? OPc_GVOP : OPc_BASEOP); - +#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 @@ -182,16 +209,17 @@ cc_opclass(pTHX_ OP *o) } static char * -cc_opclassname(pTHX_ OP *o) +cc_opclassname(pTHX_ const OP *o) { - return opclassnames[cc_opclass(aTHX_ o)]; + return (char *)opclassnames[cc_opclass(aTHX_ o)]; } static SV * make_sv_object(pTHX_ SV *arg, SV *sv) { - char *type = 0; + const char *type = 0; IV iv; + dMY_CXT; for (iv = 0; iv < sizeof(specialsv_list)/sizeof(SV*); iv++) { if (sv == specialsv_list[iv]) { @@ -201,7 +229,7 @@ make_sv_object(pTHX_ SV *arg, SV *sv) } if (!type) { type = svclassnames[SvTYPE(sv)]; - iv = (IV)sv; + iv = PTR2IV(sv); } sv_setiv(newSVrv(arg, type), iv); return arg; @@ -210,23 +238,49 @@ make_sv_object(pTHX_ SV *arg, SV *sv) static SV * make_mg_object(pTHX_ SV *arg, MAGIC *mg) { - sv_setiv(newSVrv(arg, "B::MAGIC"), (IV)mg); + sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg)); return arg; } static SV * -cstring(pTHX_ SV *sv) +cstring(pTHX_ SV *sv, bool perlstyle) { SV *sstr = newSVpvn("", 0); - STRLEN len; - char *s; if (!SvOK(sv)) sv_setpvn(sstr, "0", 1); + else if (perlstyle && SvUTF8(sv)) { + SV *tmpsv = sv_newmortal(); /* Temporary SV to feed sv_uni_display */ + const STRLEN len = SvCUR(sv); + const char *s = sv_uni_display(tmpsv, sv, 8*len, UNI_DISPLAY_QQ); + sv_setpvn(sstr,"\"",1); + while (*s) + { + if (*s == '"') + sv_catpvn(sstr, "\\\"", 2); + else if (*s == '$') + sv_catpvn(sstr, "\\$", 2); + else if (*s == '@') + sv_catpvn(sstr, "\\@", 2); + else if (*s == '\\') + { + if (strchr("nrftax\\",*(s+1))) + sv_catpvn(sstr, s++, 2); + else + sv_catpvn(sstr, "\\\\", 2); + } + else /* should always be printable */ + sv_catpvn(sstr, s, 1); + ++s; + } + sv_catpv(sstr, "\""); + return sstr; + } else { /* XXX Optimise? */ - s = SvPV(sv, len); + STRLEN len; + const char *s = SvPV(sv, len); sv_catpv(sstr, "\""); for (; len; len--, s++) { @@ -235,7 +289,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] == '?') { + char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */ + 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"); @@ -249,14 +317,13 @@ 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; + char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */ + const unsigned char c = (unsigned char) *s; sprintf(escbuff, "\\%03o", c); sv_catpv(sstr, escbuff); } @@ -271,29 +338,32 @@ static SV * cchar(pTHX_ SV *sv) { SV *sstr = newSVpvn("'", 1); - STRLEN n_a; - char *s = SvPV(sv, n_a); + const char *s = SvPV_nolen(sv); if (*s == '\'') - sv_catpv(sstr, "\\'"); + sv_catpvn(sstr, "\\'", 2); else if (*s == '\\') - sv_catpv(sstr, "\\\\"); - else if (*s >= ' ' && *s < 127) /* XXX not portable */ + sv_catpvn(sstr, "\\\\", 2); +#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"); + sv_catpvn(sstr, "\\n", 2); else if (*s == '\r') - sv_catpv(sstr, "\\r"); + sv_catpvn(sstr, "\\r", 2); else if (*s == '\t') - sv_catpv(sstr, "\\t"); + sv_catpvn(sstr, "\\t", 2); else if (*s == '\a') - sv_catpv(sstr, "\\a"); + sv_catpvn(sstr, "\\a", 2); else if (*s == '\b') - sv_catpv(sstr, "\\b"); + sv_catpvn(sstr, "\\b", 2); else if (*s == '\f') - sv_catpv(sstr, "\\f"); + sv_catpvn(sstr, "\\f", 2); else if (*s == '\v') - sv_catpv(sstr, "\\v"); + sv_catpvn(sstr, "\\v", 2); else { /* no trigraph support */ @@ -303,20 +373,21 @@ cchar(pTHX_ SV *sv) sprintf(escbuff, "\\%03o", c); sv_catpv(sstr, escbuff); } - sv_catpv(sstr, "'"); + sv_catpvn(sstr, "'", 1); return sstr; } -void -walkoptree(pTHX_ SV *opsv, char *method) +static void +walkoptree(pTHX_ SV *opsv, const char *method) { dSP; - OP *o; - + OP *o, *kid; + dMY_CXT; + if (!SvROK(opsv)) croak("opsv is not a reference"); opsv = sv_mortalcopy(opsv); - o = (OP*)SvIV((SV*)SvRV(opsv)); + o = INT2PTR(OP*,SvIV((SV*)SvRV(opsv))); if (walkoptree_debug) { PUSHMARK(sp); XPUSHs(opsv); @@ -328,13 +399,62 @@ 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)), (IV)kid); + sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid)); walkoptree(aTHX_ opsv, method); } } + if (o && (cc_opclass(aTHX_ o) == OPc_PMOP) && o->op_type != OP_PUSHRE + && (kid = cPMOPo->op_pmreplroot)) + { + sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid)); + walkoptree(aTHX_ opsv, method); + } +} + +static SV ** +oplist(pTHX_ OP *o, SV **SP) +{ + for(; o; o = o->op_next) { + SV *opsv; +#if PERL_VERSION >= 9 + if (o->op_opt == 0) + break; + o->op_opt = 0; +#else + if (o->op_seq == 0) + break; + o->op_seq = 0; +#endif + opsv = sv_newmortal(); + sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ (OP*)o)), PTR2IV(o)); + XPUSHs(opsv); + switch (o->op_type) { + case OP_SUBST: + SP = oplist(aTHX_ cPMOPo->op_pmreplstart, SP); + continue; + case OP_SORT: + if (o->op_flags & OPf_STACKED && o->op_flags & OPf_SPECIAL) { + OP *kid = cLISTOPo->op_first->op_sibling; /* pass pushmark */ + kid = kUNOP->op_first; /* pass rv2gv */ + kid = kUNOP->op_first; /* pass leave */ + SP = oplist(aTHX_ kid->op_next, SP); + } + continue; + } + switch (PL_opargs[o->op_type] & OA_CLASS_MASK) { + case OA_LOGOP: + SP = oplist(aTHX_ cLOGOPo->op_other, SP); + break; + case OA_LOOP: + SP = oplist(aTHX_ cLOOPo->op_lastop, SP); + SP = oplist(aTHX_ cLOOPo->op_nextop, SP); + SP = oplist(aTHX_ cLOOPo->op_redoop, SP); + break; + } + } + return SP; } typedef OP *B__OP; @@ -344,7 +464,7 @@ typedef LOGOP *B__LOGOP; typedef LISTOP *B__LISTOP; typedef PMOP *B__PMOP; typedef SVOP *B__SVOP; -typedef GVOP *B__GVOP; +typedef PADOP *B__PADOP; typedef PVOP *B__PVOP; typedef LOOP *B__LOOP; typedef COP *B__COP; @@ -357,6 +477,7 @@ typedef SV *B__PVMG; typedef SV *B__PVLV; typedef SV *B__BM; typedef SV *B__RV; +typedef SV *B__FM; typedef AV *B__AV; typedef HV *B__HV; typedef CV *B__CV; @@ -373,26 +494,63 @@ 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; +#if PERL_VERSION <= 8 +# define CVf_ASSERTION 0 +#endif #include "defsubs.h" } #define B_main_cv() PL_main_cv #define B_init_av() PL_initav +#define B_inc_gv() PL_incgv +#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 +#define B_defstash() PL_defstash +#define B_curstash() PL_curstash +#define B_dowarn() PL_dowarn #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 #define B_sv_no() &PL_sv_no +#define B_formfeed() PL_formfeed +#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() + +B::GV +B_inc_gv() + +#ifdef USE_ITHREADS + +B::AV +B_regex_padav() + +#endif + B::CV B_main_cv() @@ -417,26 +575,48 @@ B_sv_yes() B::SV B_sv_no() -MODULE = B PACKAGE = B +B::HV +B_curstash() + +B::HV +B_defstash() + +U8 +B_dowarn() + +B::SV +B_formfeed() +void +B_warnhook() + CODE: + ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_warnhook); + +void +B_diehook() + CODE: + ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_diehook); + +MODULE = B PACKAGE = B void walkoptree(opsv, method) SV * opsv - char * method + const char * method CODE: walkoptree(aTHX_ opsv, method); int walkoptree_debug(...) CODE: + dMY_CXT; RETVAL = walkoptree_debug; if (items > 0 && SvTRUE(ST(1))) walkoptree_debug = 1; OUTPUT: RETVAL -#define address(sv) (IV)sv +#define address(sv) PTR2IV(sv) IV address(sv) @@ -454,7 +634,7 @@ svref_2object(sv) void opnumber(name) -char * name +const char * name CODE: { int i; @@ -487,13 +667,12 @@ void hash(sv) SV * sv CODE: - char *s; STRLEN len; U32 hash = 0; - char hexhash[19]; /* must fit "0xffffffff" plus trailing \0 */ - s = SvPV(sv, len); + char hexhash[19]; /* must fit "0xffffffffffffffff" plus trailing \0 */ + const char *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 @@ -506,11 +685,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 @@ -525,27 +717,42 @@ cchar(sv) void threadsv_names() PPCODE: -#ifdef USE_THREADS +#if PERL_VERSION <= 8 +# ifdef USE_5005THREADS int i; - STRLEN len = strlen(PL_threadsv_names); + const STRLEN len = strlen(PL_threadsv_names); EXTEND(sp, len); for (i = 0; i < len; i++) PUSHs(sv_2mortal(newSVpvn(&PL_threadsv_names[i], 1))); +# endif #endif - #define OP_next(o) o->op_next #define OP_sibling(o) o->op_sibling -#define OP_desc(o) PL_op_desc[o->op_type] +#define OP_desc(o) (char *)PL_op_desc[o->op_type] #define OP_targ(o) o->op_targ #define OP_type(o) o->op_type -#define OP_seq(o) o->op_seq +#if PERL_VERSION >= 9 +# define OP_opt(o) o->op_opt +# define OP_static(o) o->op_static +#else +# define OP_seq(o) o->op_seq +#endif #define OP_flags(o) o->op_flags #define OP_private(o) o->op_private +#define OP_spare(o) o->op_spare MODULE = B PACKAGE = B::OP PREFIX = OP_ +size_t +OP_size(o) + B::OP o + CODE: + RETVAL = opsizes[cc_opclass(aTHX_ o)]; + OUTPUT: + RETVAL + B::OP OP_next(o) B::OP o @@ -555,18 +762,33 @@ OP_sibling(o) B::OP o char * +OP_name(o) + B::OP o + CODE: + RETVAL = (char *)PL_op_name[o->op_type]; + OUTPUT: + RETVAL + + +void OP_ppaddr(o) B::OP o + PREINIT: + int i; + SV *sv = sv_newmortal(); CODE: - ST(0) = sv_newmortal(); - sv_setpvn(ST(0), "pp_", 3); - 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) B::OP o -U16 +PADOFFSET OP_targ(o) B::OP o @@ -574,10 +796,24 @@ U16 OP_type(o) B::OP o +#if PERL_VERSION >= 9 + +U8 +OP_opt(o) + B::OP o + +U8 +OP_static(o) + B::OP o + +#else + U16 OP_seq(o) B::OP o +#endif + U8 OP_flags(o) B::OP o @@ -586,6 +822,20 @@ U8 OP_private(o) B::OP o +#if PERL_VERSION >= 9 + +U8 +OP_spare(o) + B::OP o + +#endif + +void +OP_oplist(o) + B::OP o + PPCODE: + SP = oplist(aTHX_ o, SP); + #define UNOP_first(o) o->op_first MODULE = B PACKAGE = B::UNOP PREFIX = UNOP_ @@ -610,20 +860,34 @@ 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 +#define PMOP_pmstashpv(o) o->op_pmstashpv +#else +#define PMOP_pmstash(o) o->op_pmstash +#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_ @@ -636,12 +900,16 @@ 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"), - (IV)root); + PTR2IV(root)); +#endif } else { - sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), (IV)root); + sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root)); } B::OP @@ -652,41 +920,78 @@ B::PMOP PMOP_pmnext(o) B::PMOP o -U16 +#ifdef USE_ITHREADS + +IV +PMOP_pmoffset(o) + B::PMOP o + +char* +PMOP_pmstashpv(o) + B::PMOP o + +#else + +B::HV +PMOP_pmstash(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_sv(o) cSVOPo->op_sv +#define SVOP_gv(o) ((GV*)cSVOPo->op_sv) MODULE = B PACKAGE = B::SVOP PREFIX = SVOP_ - B::SV SVOP_sv(o) B::SVOP o -#define GVOP_gv(o) o->op_gv +B::GV +SVOP_gv(o) + B::SVOP o + +#define PADOP_padix(o) o->op_padix +#define PADOP_sv(o) (o->op_padix ? PAD_SVl(o->op_padix) : Nullsv) +#define PADOP_gv(o) ((o->op_padix \ + && SvTYPE(PAD_SVl(o->op_padix)) == SVt_PVGV) \ + ? (GV*)PAD_SVl(o->op_padix) : Nullgv) -MODULE = B PACKAGE = B::GVOP PREFIX = GVOP_ +MODULE = B PACKAGE = B::PADOP PREFIX = PADOP_ +PADOFFSET +PADOP_padix(o) + B::PADOP o + +B::SV +PADOP_sv(o) + B::PADOP o B::GV -GVOP_gv(o) - B::GVOP o +PADOP_gv(o) + B::PADOP o MODULE = B PACKAGE = B::PVOP PREFIX = PVOP_ @@ -695,11 +1000,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)) + { + const short* const tbl = (short*)o->op_pv; + const 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 @@ -721,12 +1037,15 @@ LOOP_lastop(o) B::LOOP o #define COP_label(o) o->cop_label -#define COP_stash(o) o->cop_stash -#define COP_filegv(o) o->cop_filegv +#define COP_stashpv(o) CopSTASHPV(o) +#define COP_stash(o) CopSTASH(o) +#define COP_file(o) CopFILE(o) +#define COP_filegv(o) CopFILEGV(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_line(o) CopLINE(o) #define COP_warnings(o) o->cop_warnings +#define COP_io(o) o->cop_io MODULE = B PACKAGE = B::COP PREFIX = COP_ @@ -734,13 +1053,22 @@ char * COP_label(o) B::COP o +char * +COP_stashpv(o) + B::COP o + B::HV COP_stash(o) B::COP o +char * +COP_file(o) + B::COP o + B::GV COP_filegv(o) - B::COP o + B::COP o + U32 COP_cop_seq(o) @@ -750,7 +1078,7 @@ I32 COP_arybase(o) B::COP o -U16 +U32 COP_line(o) B::COP o @@ -758,6 +1086,23 @@ B::SV COP_warnings(o) B::COP o +B::SV +COP_io(o) + B::COP o + +MODULE = B PACKAGE = B::SV + +U32 +SvTYPE(sv) + B::SV sv + +#define object_2svref(sv) sv +#define SVREF SV * + +SVREF +object_2svref(sv) + B::SV sv + MODULE = B PACKAGE = B::SV PREFIX = Sv U32 @@ -768,6 +1113,18 @@ U32 SvFLAGS(sv) B::SV sv +U32 +SvPOK(sv) + B::SV sv + +U32 +SvROK(sv) + B::SV sv + +U32 +SvMAGICAL(sv) + B::SV sv + MODULE = B PACKAGE = B::IV PREFIX = Sv IV @@ -797,7 +1154,7 @@ packiv(sv) CODE: if (sizeof(IV) == 8) { U32 wp[2]; - IV iv = SvIVX(sv); + const IV iv = SvIVX(sv); /* * The following way of spelling 32 is to stop compilers on * 32-bit architectures from moaning about the shift count @@ -805,7 +1162,11 @@ packiv(sv) * reach this code anyway (unless sizeof(IV) > 8 but then * everything else breaks too so I'm not fussed at the moment). */ - wp[0] = htonl(((U32)iv) >> (sizeof(IV)*4)); +#ifdef UV_IS_QUAD + wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4)); +#else + wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4)); +#endif wp[1] = htonl(iv & 0xffffffff); ST(0) = sv_2mortal(newSVpvn((char *)wp, 8)); } else { @@ -815,11 +1176,11 @@ packiv(sv) MODULE = B PACKAGE = B::NV PREFIX = Sv -double +NV SvNV(sv) B::NV sv -double +NV SvNVX(sv) B::NV sv @@ -831,12 +1192,54 @@ 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) ) { + /* FIXME - we need a better way for B to identify PVs that are + in the pads as variable names. */ + if((SvLEN(sv) && SvCUR(sv) >= SvLEN(sv))) { + /* It claims to be longer than the space allocated for it - + presuambly it's a variable name in the pad */ + sv_setpv(ST(0), SvPV_nolen_const(sv)); + } else { + sv_setpvn(ST(0), SvPVX_const(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); + } + +void +SvPVBM(sv) + B::PV sv + CODE: + ST(0) = sv_newmortal(); + sv_setpvn(ST(0), SvPVX_const(sv), + SvCUR(sv) + (SvTYPE(sv) == SVt_PVBM ? 257 : 0)); + STRLEN SvLEN(sv) @@ -868,12 +1271,22 @@ 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 B::MAGIC MgMOREMAGIC(mg) B::MAGIC mg + CODE: + if( MgMOREMAGIC(mg) ) { + RETVAL = MgMOREMAGIC(mg); + } + else { + XSRETURN_UNDEF; + } + OUTPUT: + RETVAL U16 MgPRIVATE(mg) @@ -891,6 +1304,34 @@ B::SV MgOBJ(mg) B::MAGIC mg +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) B::MAGIC mg @@ -903,9 +1344,9 @@ MgPTR(mg) 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)); + } else if (mg->mg_len == HEf_SVKEY) { + ST(0) = make_sv_object(aTHX_ + sv_newmortal(), (SV*)mg->mg_ptr); } } @@ -959,6 +1400,18 @@ 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 + +void* +GvGP(gv) + B::GV gv + B::HV GvSTASH(gv) B::GV gv @@ -971,9 +1424,13 @@ B::IO GvIO(gv) B::GV gv -B::CV +B::FM GvFORM(gv) B::GV gv + CODE: + RETVAL = (SV*)GvFORM(gv); + OUTPUT: + RETVAL B::AV GvAV(gv) @@ -995,10 +1452,14 @@ U32 GvCVGEN(gv) B::GV gv -U16 +U32 GvLINE(gv) B::GV gv +char * +GvFILE(gv) + B::GV gv + B::GV GvFILEGV(gv) B::GV gv @@ -1059,6 +1520,29 @@ short IoSUBPROCESS(io) B::IO io +bool +IsSTD(io,name) + B::IO io + const 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 @@ -1079,12 +1563,6 @@ SSize_t AvMAX(av) B::AV av -#define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off - -IV -AvOFF(av) - B::AV av - void AvARRAY(av) B::AV av @@ -1096,14 +1574,28 @@ AvARRAY(av) XPUSHs(make_sv_object(aTHX_ sv_newmortal(), svp[i])); } -MODULE = B PACKAGE = B::AV - -U8 -AvFLAGS(av) +void +AvARRAYelt(av, idx) B::AV av + int idx + PPCODE: + if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av)) + XPUSHs(make_sv_object(aTHX_ sv_newmortal(), (AvARRAY(av)[idx]))); + else + XPUSHs(make_sv_object(aTHX_ sv_newmortal(), NULL)); + +MODULE = B PACKAGE = B::FM PREFIX = Fm + +IV +FmLINES(form) + B::FM form MODULE = B PACKAGE = B::CV PREFIX = Cv +U32 +CvCONST(cv) + B::CV cv + B::HV CvSTASH(cv) B::CV cv @@ -1120,8 +1612,8 @@ B::GV CvGV(cv) B::CV cv -B::GV -CvFILEGV(cv) +char * +CvFILE(cv) B::CV cv long @@ -1136,25 +1628,37 @@ B::CV CvOUTSIDE(cv) B::CV cv +U32 +CvOUTSIDE_SEQ(cv) + B::CV cv + void CvXSUB(cv) B::CV cv CODE: - ST(0) = sv_2mortal(newSViv((IV)CvXSUB(cv))); + ST(0) = sv_2mortal(newSViv(PTR2IV(CvXSUB(cv)))); 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(),(SV *)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 @@ -1178,10 +1682,6 @@ char * HvNAME(hv) B::HV hv -B::PMOP -HvPMROOT(hv) - B::HV hv - void HvARRAY(hv) B::HV hv @@ -1192,7 +1692,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)); }