X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FB%2FB.xs;h=99c1409f9eccda02bb8b3a9f0178ebefd0c7fb6d;hb=584420f022db57225e9644b9c6668ff9f567984a;hp=c9ca8b196224862a234ed5f6bf5fb2a5ac8cfeae;hpb=9d2bbe64880a61780d874de13a887a9237f604de;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/B/B.xs b/ext/B/B.xs index c9ca8b1..99c1409 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -19,8 +19,11 @@ typedef FILE * InputStream; #endif -static char *svclassnames[] = { +static const char* const svclassnames[] = { "B::NULL", +#if PERL_VERSION >= 9 + "B::BIND", +#endif "B::IV", "B::NV", "B::RV", @@ -28,12 +31,19 @@ static char *svclassnames[] = { "B::PVIV", "B::PVNV", "B::PVMG", +#if PERL_VERSION <= 8 "B::BM", +#endif +#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", }; @@ -49,12 +59,11 @@ typedef enum { OPc_SVOP, /* 7 */ 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", @@ -65,11 +74,25 @@ static char *opclassnames[] = { "B::SVOP", "B::PADOP", "B::PVOP", - "B::CVOP", "B::LOOP", "B::COP" }; +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 { @@ -83,7 +106,7 @@ START_MY_CXT #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,8 +117,20 @@ cc_opclass(pTHX_ OP *o) if (o->op_type == OP_SASSIGN) return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP); + if (o->op_type == OP_AELEMFAST) { + if (o->op_flags & OPf_SPECIAL) + return OPc_BASEOP; + else +#ifdef USE_ITHREADS + return OPc_PADOP; +#else + return OPc_SVOP; +#endif + } + #ifdef USE_ITHREADS - if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST) + if (o->op_type == OP_GV || o->op_type == OP_GVSV || + o->op_type == OP_RCATLINE) return OPc_PADOP; #endif @@ -190,15 +225,15 @@ 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; @@ -216,6 +251,71 @@ make_sv_object(pTHX_ SV *arg, SV *sv) return arg; } +#if PERL_VERSION >= 9 +static SV * +make_temp_object(pTHX_ SV *arg, SV *temp) +{ + SV *target; + const char *const type = svclassnames[SvTYPE(temp)]; + const IV iv = PTR2IV(temp); + + target = newSVrv(arg, type); + sv_setiv(target, iv); + + /* Need to keep our "temp" around as long as the target exists. + Simplest way seems to be to hang it from magic, and let that clear + it up. No vtable, so won't actually get in the way of anything. */ + sv_magicext(target, temp, PERL_MAGIC_sv, NULL, NULL, 0); + /* magic object has had its reference count increased, so we must drop + our reference. */ + SvREFCNT_dec(temp); + return arg; +} + +static SV * +make_warnings_object(pTHX_ SV *arg, STRLEN *warnings) +{ + const char *type = 0; + dMY_CXT; + IV iv = sizeof(specialsv_list)/sizeof(SV*); + + /* Counting down is deliberate. Before the split between make_sv_object + and make_warnings_obj there appeared to be a bug - Nullsv and pWARN_STD + were both 0, so you could never get a B::SPECIAL for pWARN_STD */ + + while (iv--) { + if ((SV*)warnings == specialsv_list[iv]) { + type = "B::SPECIAL"; + break; + } + } + if (type) { + sv_setiv(newSVrv(arg, type), iv); + return arg; + } else { + /* B assumes that warnings are a regular SV. Seems easier to keep it + happy by making them into a regular SV. */ + return make_temp_object(aTHX_ arg, + newSVpvn((char *)(warnings + 1), *warnings)); + } +} + +static SV * +make_cop_io_object(pTHX_ SV *arg, COP *cop) +{ + SV *const value = newSV(0); + + Perl_emulate_cop_io(aTHX_ cop, value); + + if(SvOK(value)) { + return make_temp_object(aTHX_ arg, newSVsv(value)); + } else { + SvREFCNT_dec(value); + return make_sv_object(aTHX_ arg, NULL); + } +} +#endif + static SV * make_mg_object(pTHX_ SV *arg, MAGIC *mg) { @@ -224,19 +324,44 @@ 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 */ + 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++) { @@ -246,12 +371,20 @@ cstring(pTHX_ SV *sv) else if (*s == '\\') sv_catpv(sstr, "\\\\"); /* trigraphs - bleagh */ - else if (*s == '?' && len>=3 && s[1] == '?') - { + 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 (*s >= ' ' && *s < 127) /* XXX not portable */ + 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"); @@ -265,12 +398,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 { /* 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); } @@ -285,29 +419,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 */ @@ -317,15 +454,15 @@ 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)) @@ -343,13 +480,71 @@ 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) && o->op_type != OP_PUSHRE +#if PERL_VERSION >= 9 + && (kid = cPMOPo->op_pmreplrootu.op_pmreplroot) +#else + && (kid = cPMOPo->op_pmreplroot) +#endif + ) + { + 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: +#if PERL_VERSION >= 9 + SP = oplist(aTHX_ cPMOPo->op_pmstashstartu.op_pmreplstart, SP); +#else + SP = oplist(aTHX_ cPMOPo->op_pmreplstart, SP); +#endif + 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; @@ -372,6 +567,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; @@ -379,6 +575,10 @@ typedef GV *B__GV; typedef IO *B__IO; typedef MAGIC *B__MAGIC; +typedef HE *B__HE; +#if PERL_VERSION >= 9 +typedef struct refcounted_he *B__RHE; +#endif MODULE = B PACKAGE = B PREFIX = B_ @@ -386,30 +586,45 @@ PROTOTYPES: DISABLE BOOT: { - HV *stash = gv_stashpvn("B", 1, TRUE); + HV *stash = gv_stashpvn("B", 1, GV_ADD); 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; + specialsv_list[4] = (SV *) pWARN_ALL; + specialsv_list[5] = (SV *) pWARN_NONE; + specialsv_list[6] = (SV *) pWARN_STD; +#if PERL_VERSION <= 8 +# define OPpPAD_STATE 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 +#if PERL_VERSION > 8 +# define B_unitcheck_av() PL_unitcheckav_save +#else +# define B_unitcheck_av() NULL +#endif #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_sub_generation() PL_sub_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 @@ -418,11 +633,24 @@ B::AV B_init_av() B::AV +B_check_av() + +#if PERL_VERSION >= 9 + +B::AV +B_unitcheck_av() + +#endif + +B::AV B_begin_av() B::AV B_end_av() +B::GV +B_inc_gv() + #ifdef USE_ITHREADS B::AV @@ -442,6 +670,9 @@ B_main_start() long B_amagic_generation() +long +B_sub_generation() + B::AV B_comppadlist() @@ -454,13 +685,34 @@ 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); @@ -492,7 +744,7 @@ svref_2object(sv) void opnumber(name) -char * name +const char * name CODE: { int i; @@ -525,11 +777,10 @@ void hash(sv) SV * sv CODE: - char *s; STRLEN len; U32 hash = 0; char hexhash[19]; /* must fit "0xffffffffffffffff" plus trailing \0 */ - s = SvPV(sv, len); + const char *s = SvPV(sv, len); PERL_HASH(hash, s, len); sprintf(hexhash, "0x%"UVxf, (UV)hash); ST(0) = sv_2mortal(newSVpv(hexhash, 0)); @@ -553,7 +804,15 @@ 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 @@ -568,27 +827,42 @@ cchar(sv) void threadsv_names() PPCODE: -#ifdef USE_5005THREADS +#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 @@ -601,7 +875,7 @@ char * OP_name(o) B::OP o CODE: - RETVAL = PL_op_name[o->op_type]; + RETVAL = (char *)PL_op_name[o->op_type]; OUTPUT: RETVAL @@ -615,7 +889,7 @@ OP_ppaddr(o) CODE: sv_setpvn(sv, "PL_ppaddr[OP_", 13); sv_catpv(sv, PL_op_name[o->op_type]); - for (i=13; i= 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 @@ -644,6 +932,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_ @@ -683,19 +985,27 @@ LISTOP_children(o) OUTPUT: RETVAL -#define PMOP_pmreplroot(o) o->op_pmreplroot -#define PMOP_pmreplstart(o) o->op_pmreplstart +#if PERL_VERSION >= 9 +# define PMOP_pmreplstart(o) o->op_pmstashstartu.op_pmreplstart +#else +# define PMOP_pmreplstart(o) o->op_pmreplstart +# define PMOP_pmpermflags(o) o->op_pmpermflags +# define PMOP_pmdynflags(o) o->op_pmdynflags +#endif #define PMOP_pmnext(o) o->op_pmnext #define PMOP_pmregexp(o) PM_GETRE(o) #ifdef USE_ITHREADS #define PMOP_pmoffset(o) o->op_pmoffset +#define PMOP_pmstashpv(o) PmopSTASHPV(o); +#else +#define PMOP_pmstash(o) PmopSTASH(o); #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_ +#if PERL_VERSION <= 8 + void PMOP_pmreplroot(o) B::PMOP o @@ -705,39 +1015,80 @@ 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 +# ifdef USE_ITHREADS sv_setiv(ST(0), INT2PTR(PADOFFSET,root) ); -#else +# else sv_setiv(newSVrv(ST(0), root ? svclassnames[SvTYPE((SV*)root)] : "B::SV"), PTR2IV(root)); -#endif +# endif } else { sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root)); } +#else + +void +PMOP_pmreplroot(o) + B::PMOP o + CODE: + ST(0) = sv_newmortal(); + if (o->op_type == OP_PUSHRE) { +# ifdef USE_ITHREADS + sv_setiv(ST(0), o->op_pmreplrootu.op_pmtargetoff); +# else + GV *const target = o->op_pmreplrootu.op_pmtargetgv; + sv_setiv(newSVrv(ST(0), target ? + svclassnames[SvTYPE((SV*)target)] : "B::SV"), + PTR2IV(target)); +# endif + } + else { + OP *const root = o->op_pmreplrootu.op_pmreplroot; + sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), + PTR2IV(root)); + } + +#endif + B::OP PMOP_pmreplstart(o) B::PMOP o +#if PERL_VERSION < 9 + B::PMOP PMOP_pmnext(o) B::PMOP o +#endif + #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 -U16 +U32 PMOP_pmflags(o) B::PMOP o -U16 +#if PERL_VERSION < 9 + +U32 PMOP_pmpermflags(o) B::PMOP o @@ -745,6 +1096,8 @@ U8 PMOP_pmdynflags(o) B::PMOP o +#endif + void PMOP_precomp(o) B::PMOP o @@ -755,6 +1108,20 @@ PMOP_precomp(o) if (rx) sv_setpvn(ST(0), rx->precomp, rx->prelen); +#if PERL_VERSION >= 9 + +void +PMOP_reflags(o) + B::PMOP o + REGEXP * rx = NO_INIT + CODE: + ST(0) = sv_newmortal(); + rx = PM_GETRE(o); + if (rx) + sv_setuv(ST(0), rx->extflags); + +#endif + #define SVOP_sv(o) cSVOPo->op_sv #define SVOP_gv(o) ((GV*)cSVOPo->op_sv) @@ -769,10 +1136,10 @@ SVOP_gv(o) B::SVOP o #define PADOP_padix(o) o->op_padix -#define PADOP_sv(o) (o->op_padix ? PL_curpad[o->op_padix] : Nullsv) +#define PADOP_sv(o) (o->op_padix ? PAD_SVl(o->op_padix) : Nullsv) #define PADOP_gv(o) ((o->op_padix \ - && SvTYPE(PL_curpad[o->op_padix]) == SVt_PVGV) \ - ? (GV*)PL_curpad[o->op_padix] : Nullgv) + && SvTYPE(PAD_SVl(o->op_padix)) == SVt_PVGV) \ + ? (GV*)PAD_SVl(o->op_padix) : Nullgv) MODULE = B PACKAGE = B::PADOP PREFIX = PADOP_ @@ -802,8 +1169,8 @@ PVOP_pv(o) (o->op_private & OPpTRANS_COMPLEMENT) && !(o->op_private & OPpTRANS_DELETE)) { - short* tbl = (short*)o->op_pv; - short entries = 257 + tbl[256]; + 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) { @@ -835,10 +1202,15 @@ LOOP_lastop(o) #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_arybase(o) CopARYBASE_get(o) #define COP_line(o) CopLINE(o) -#define COP_warnings(o) o->cop_warnings +#define COP_hints(o) CopHINTS_get(o) +#if PERL_VERSION < 9 +# define COP_warnings(o) o->cop_warnings +# define COP_io(o) o->cop_io +#endif MODULE = B PACKAGE = B::COP PREFIX = COP_ @@ -858,6 +1230,11 @@ char * COP_file(o) B::COP o +B::GV +COP_filegv(o) + B::COP o + + U32 COP_cop_seq(o) B::COP o @@ -866,14 +1243,63 @@ I32 COP_arybase(o) B::COP o -U16 +U32 COP_line(o) B::COP o +#if PERL_VERSION >= 9 + +void +COP_warnings(o) + B::COP o + PPCODE: + ST(0) = make_warnings_object(aTHX_ sv_newmortal(), o->cop_warnings); + XSRETURN(1); + +void +COP_io(o) + B::COP o + PPCODE: + ST(0) = make_cop_io_object(aTHX_ sv_newmortal(), o); + XSRETURN(1); + +B::RHE +COP_hints_hash(o) + B::COP o + CODE: + RETVAL = o->cop_hints_hash; + OUTPUT: + RETVAL + +#else + B::SV COP_warnings(o) B::COP o +B::SV +COP_io(o) + B::COP o + +#endif + +U32 +COP_hints(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 @@ -884,6 +1310,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 @@ -913,7 +1351,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 @@ -943,6 +1381,22 @@ NV SvNVX(sv) B::NV sv +U32 +COP_SEQ_RANGE_LOW(sv) + B::NV sv + +U32 +COP_SEQ_RANGE_HIGH(sv) + B::NV sv + +U32 +PARENT_PAD_INDEX(sv) + B::NV sv + +U32 +PARENT_FAKELEX_FLAGS(sv) + B::NV sv + MODULE = B PACKAGE = B::RV PREFIX = Sv B::SV @@ -973,8 +1427,16 @@ SvPV(sv) B::PV sv CODE: ST(0) = sv_newmortal(); - if( SvPOK(sv) ) { - sv_setpvn(ST(0), SvPVX(sv), SvCUR(sv)); + 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 { @@ -983,6 +1445,18 @@ SvPV(sv) sv_setpvn(ST(0), NULL, 0); } +# This used to read 257. I think that that was buggy - should have been 258. +# (The "\0", the flags byte, and 256 for the table. Not that anything +# anywhere calls this method. NWC. +void +SvPVBM(sv) + B::PV sv + CODE: + ST(0) = sv_newmortal(); + sv_setpvn(ST(0), SvPVX_const(sv), + SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0)); + + STRLEN SvLEN(sv) B::PV sv @@ -1013,13 +1487,22 @@ SvSTASH(sv) #define MgFLAGS(mg) mg->mg_flags #define MgOBJ(mg) mg->mg_obj #define MgLENGTH(mg) mg->mg_len -#define MgREGEX(mg) ((IV)(mg->mg_obj)) +#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) @@ -1036,21 +1519,12 @@ 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' ) { + if(mg->mg_type == PERL_MAGIC_qr) { RETVAL = MgREGEX(mg); } else { @@ -1063,8 +1537,9 @@ SV* precomp(mg) B::MAGIC mg CODE: - if (mg->mg_type == 'r') { + if (mg->mg_type == PERL_MAGIC_qr) { REGEXP* rx = (REGEXP*)mg->mg_obj; + RETVAL = Nullsv; if( rx ) RETVAL = newSVpvn( rx->precomp, rx->prelen ); } @@ -1086,9 +1561,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); } } @@ -1116,7 +1591,7 @@ I32 BmUSEFUL(sv) B::BM sv -U16 +U32 BmPREVIOUS(sv) B::BM sv @@ -1132,7 +1607,7 @@ BmTABLE(sv) CODE: str = SvPV(sv, len); /* Boyer-Moore table is just after string and its safety-margin \0 */ - ST(0) = sv_2mortal(newSVpvn(str + len + 1, 256)); + ST(0) = sv_2mortal(newSVpvn(str + len + PERL_FBM_TABLE_OFFSET, 256)); MODULE = B PACKAGE = B::GV PREFIX = Gv @@ -1150,6 +1625,10 @@ is_empty(gv) OUTPUT: RETVAL +void* +GvGP(gv) + B::GV gv + B::HV GvSTASH(gv) B::GV gv @@ -1162,9 +1641,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) @@ -1186,7 +1669,7 @@ U32 GvCVGEN(gv) B::GV gv -U16 +U32 GvLINE(gv) B::GV gv @@ -1257,7 +1740,7 @@ IoSUBPROCESS(io) bool IsSTD(io,name) B::IO io - char* name + const char* name PREINIT: PerlIO* handle = 0; CODE: @@ -1297,12 +1780,17 @@ SSize_t AvMAX(av) B::AV av +#if PERL_VERSION < 9 + + #define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off IV AvOFF(av) B::AV av +#endif + void AvARRAY(av) B::AV av @@ -1314,14 +1802,38 @@ AvARRAY(av) XPUSHs(make_sv_object(aTHX_ sv_newmortal(), svp[i])); } +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)); + +#if PERL_VERSION < 9 + MODULE = B PACKAGE = B::AV U8 AvFLAGS(av) B::AV av +#endif + +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 @@ -1329,10 +1841,18 @@ CvSTASH(cv) B::OP CvSTART(cv) B::CV cv + CODE: + RETVAL = CvISXSUB(cv) ? NULL : CvSTART(cv); + OUTPUT: + RETVAL B::OP CvROOT(cv) B::CV cv + CODE: + RETVAL = CvISXSUB(cv) ? NULL : CvROOT(cv); + OUTPUT: + RETVAL B::GV CvGV(cv) @@ -1354,11 +1874,15 @@ 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(PTR2IV(CvXSUB(cv)))); + ST(0) = sv_2mortal(newSViv(CvISXSUB(cv) ? PTR2IV(CvXSUB(cv)) : 0)); void @@ -1366,8 +1890,8 @@ CvXSUBANY(cv) B::CV cv CODE: ST(0) = CvCONST(cv) ? - make_sv_object(aTHX_ sv_newmortal(),CvXSUBANY(cv).any_ptr) : - sv_2mortal(newSViv(CvXSUBANY(cv).any_iv)); + make_sv_object(aTHX_ sv_newmortal(),(SV *)CvXSUBANY(cv).any_ptr) : + sv_2mortal(newSViv(CvISXSUB(cv) ? CvXSUBANY(cv).any_iv : 0)); MODULE = B PACKAGE = B::CV @@ -1404,10 +1928,14 @@ char * HvNAME(hv) B::HV hv +#if PERL_VERSION < 9 + B::PMOP HvPMROOT(hv) B::HV hv +#endif + void HvARRAY(hv) B::HV hv @@ -1423,3 +1951,31 @@ HvARRAY(hv) PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv)); } } + +MODULE = B PACKAGE = B::HE PREFIX = He + +B::SV +HeVAL(he) + B::HE he + +U32 +HeHASH(he) + B::HE he + +B::SV +HeSVKEY_force(he) + B::HE he + +MODULE = B PACKAGE = B::RHE PREFIX = RHE_ + +#if PERL_VERSION >= 9 + +SV* +RHE_HASH(h) + B::RHE h + CODE: + RETVAL = newRV( (SV*)Perl_refcounted_he_chain_2hv(aTHX_ h) ); + OUTPUT: + RETVAL + +#endif