X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FB%2FB.xs;h=f9c8647b963a6bc408869c4187f89615a196866f;hb=00baac8f3bcc04befcd869d03d8fa7c580011507;hp=d525e4e79837dd0d7f39911674c42464289fdce8;hpb=be59e445a231e0102a0fd9822727ddbe3e12d0bb;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/B/B.xs b/ext/B/B.xs index d525e4e..f9c8647 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -7,19 +7,10 @@ * */ +#define PERL_NO_GET_CONTEXT #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()) -#endif #ifdef PerlIO typedef PerlIO * InputStream; @@ -28,7 +19,7 @@ typedef FILE * InputStream; #endif -static char *svclassnames[] = { +static const char* const svclassnames[] = { "B::NULL", "B::IV", "B::NV", @@ -38,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", }; @@ -53,38 +49,59 @@ 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_PADOP, /* 8 */ + OPc_PVOP, /* 9 */ + OPc_LOOP, /* 10 */ + OPc_COP /* 11 */ } opclass; -static char *opclassnames[] = { +static const char* const opclassnames[] = { "B::NULL", "B::OP", "B::UNOP", "B::BINOP", "B::LOGOP", - "B::CONDOP", "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 + +#define walkoptree_debug (MY_CXT.x_walkoptree_debug) +#define specialsv_list (MY_CXT.x_specialsv_list) static opclass -cc_opclass(OP *o) +cc_opclass(pTHX_ const OP *o) { if (!o) return OPc_NULL; @@ -95,6 +112,12 @@ cc_opclass(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; @@ -108,9 +131,6 @@ cc_opclass(OP *o) case OA_LOGOP: return OPc_LOGOP; - case OA_CONDOP: - return OPc_CONDOP; - case OA_LISTOP: return OPc_LISTOP; @@ -120,11 +140,19 @@ cc_opclass(OP *o) case OA_SVOP: return OPc_SVOP; - case OA_GVOP: - return OPc_GVOP; + case OA_PADOP: + return OPc_PADOP; - 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; @@ -150,11 +178,14 @@ cc_opclass(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 @@ -178,51 +209,78 @@ cc_opclass(OP *o) } static char * -cc_opclassname(OP *o) +cc_opclassname(pTHX_ const OP *o) { - return opclassnames[cc_opclass(o)]; + return (char *)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; + const char *type = 0; IV iv; + dMY_CXT; - 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; } } if (!type) { type = svclassnames[SvTYPE(sv)]; - iv = (IV)sv; + iv = PTR2IV(sv); } sv_setiv(newSVrv(arg, type), iv); return arg; } 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); + sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg)); return arg; } static SV * -cstring(SV *sv) +cstring(pTHX_ SV *sv, bool perlstyle) { - SV *sstr = newSVpv("", 0); - STRLEN len; - char *s; + SV *sstr = newSVpvn("", 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++) { @@ -231,7 +289,21 @@ cstring(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"); @@ -245,14 +317,13 @@ cstring(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); } @@ -264,32 +335,35 @@ cstring(SV *sv) } static SV * -cchar(SV *sv) +cchar(pTHX_ SV *sv) { - SV *sstr = newSVpv("'", 0); - STRLEN n_a; - char *s = SvPV(sv, n_a); + SV *sstr = newSVpvn("'", 1); + 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 */ @@ -299,88 +373,21 @@ cchar(SV *sv) sprintf(escbuff, "\\%03o", c); sv_catpv(sstr, escbuff); } - sv_catpv(sstr, "'"); + sv_catpvn(sstr, "'", 1); 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) +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); @@ -392,24 +399,72 @@ walkoptree(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(kid)), (IV)kid); - walkoptree(opsv, method); + 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; 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; -typedef GVOP *B__GVOP; +typedef PADOP *B__PADOP; typedef PVOP *B__PVOP; typedef LOOP *B__LOOP; typedef COP *B__COP; @@ -422,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; @@ -438,22 +494,63 @@ BOOT: { HV *stash = gv_stashpvn("B", 1, TRUE); AV *export_ok = perl_get_av("B::EXPORT_OK",TRUE); - INIT_SPECIALSV_LIST; + 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() @@ -463,6 +560,9 @@ B_main_root() B::OP B_main_start() +long +B_amagic_generation() + B::AV B_comppadlist() @@ -475,37 +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 -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 +#define address(sv) PTR2IV(sv) IV address(sv) @@ -523,7 +634,7 @@ svref_2object(sv) void opnumber(name) -char * name +const char * name CODE: { int i; @@ -556,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 @@ -575,38 +685,74 @@ minus_c() CODE: PL_minus_c = TRUE; +void +save_BEGINs() + CODE: + PL_savebegin = TRUE; + SV * cstring(sv) SV * sv + CODE: + RETVAL = cstring(aTHX_ sv, 0); + OUTPUT: + RETVAL + +SV * +perlstring(sv) + SV * sv + CODE: + RETVAL = cstring(aTHX_ sv, 1); + OUTPUT: + RETVAL SV * cchar(sv) SV * sv + CODE: + RETVAL = cchar(aTHX_ sv); + OUTPUT: + RETVAL 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(newSVpv(&PL_threadsv_names[i], 1))); + 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 @@ -616,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 @@ -635,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 @@ -647,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_ @@ -671,33 +860,34 @@ 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_ 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_ @@ -710,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(root)), (IV)root); + sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root)); } B::OP @@ -726,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::PADOP PREFIX = PADOP_ -MODULE = B PACKAGE = B::GVOP PREFIX = GVOP_ +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_ @@ -769,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 @@ -795,11 +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_ @@ -807,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) @@ -823,10 +1078,31 @@ I32 COP_arybase(o) B::COP o -U16 +U32 COP_line(o) B::COP o +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 @@ -837,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 @@ -847,6 +1135,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)) @@ -861,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 @@ -869,21 +1162,25 @@ 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(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 -double +NV SvNV(sv) B::NV sv -double +NV SvNVX(sv) B::NV sv @@ -895,12 +1192,62 @@ 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) + B::PV sv + +STRLEN +SvCUR(sv) + B::PV sv MODULE = B PACKAGE = B::PVMG PREFIX = Sv @@ -910,7 +1257,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 @@ -924,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) @@ -947,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 @@ -959,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); } } @@ -1005,7 +1390,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 @@ -1013,7 +1398,19 @@ 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))); + +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) @@ -1027,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) @@ -1051,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 @@ -1115,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 @@ -1135,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 @@ -1149,17 +1571,31 @@ 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 - -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 @@ -1176,8 +1612,8 @@ B::GV CvGV(cv) B::CV cv -B::GV -CvFILEGV(cv) +char * +CvFILE(cv) B::CV cv long @@ -1192,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 @@ -1234,10 +1682,6 @@ char * HvNAME(hv) B::HV hv -B::PMOP -HvPMROOT(hv) - B::HV hv - void HvARRAY(hv) B::HV hv @@ -1248,8 +1692,8 @@ HvARRAY(hv) I32 len; (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)); + while ((sv = hv_iternextsv(hv, &key, &len))) { + PUSHs(newSVpvn(key, len)); + PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv)); } }