#endif
-static char *svclassnames[] = {
+static const char* const svclassnames[] = {
"B::NULL",
+#if PERL_VERSION >= 9
+ "B::BIND",
+#endif
"B::IV",
"B::NV",
+#if PERL_VERSION <= 10
"B::RV",
+#endif
"B::PV",
"B::PVIV",
"B::PVNV",
"B::PVMG",
+#if PERL_VERSION <= 8
"B::BM",
+#endif
+#if PERL_VERSION >= 11
+ "B::REGEXP",
+#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",
};
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",
"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 {
#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;
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
- if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
+ 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_RCATLINE)
return OPc_PADOP;
#endif
}
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;
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)
{
static 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 */
+ SV *sstr = newSVpvs("");
if (!SvOK(sv))
- sv_setpvn(sstr, "0", 1);
- else if (perlstyle && SvUTF8(sv))
- {
+ sv_setpvs(sstr, "0");
+ 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,"\"");
+ const STRLEN len = SvCUR(sv);
+ const char *s = sv_uni_display(tmpsv, sv, 8*len, UNI_DISPLAY_QQ);
+ sv_setpvs(sstr,"\"");
while (*s)
{
if (*s == '"')
- sv_catpv(sstr, "\\\"");
+ sv_catpvs(sstr, "\\\"");
else if (*s == '$')
- sv_catpv(sstr, "\\$");
+ sv_catpvs(sstr, "\\$");
else if (*s == '@')
- sv_catpv(sstr, "\\@");
+ sv_catpvs(sstr, "\\@");
else if (*s == '\\')
{
if (strchr("nrftax\\",*(s+1)))
sv_catpvn(sstr, s++, 2);
else
- sv_catpv(sstr, "\\\\");
+ sv_catpvs(sstr, "\\\\");
}
else /* should always be printable */
sv_catpvn(sstr, s, 1);
++s;
}
- sv_catpv(sstr, "\"");
+ sv_catpvs(sstr, "\"");
return sstr;
}
else
{
/* XXX Optimise? */
- s = SvPV(sv, len);
- sv_catpv(sstr, "\"");
+ STRLEN len;
+ const char *s = SvPV(sv, len);
+ sv_catpvs(sstr, "\"");
for (; len; len--, s++)
{
/* At least try a little for readability */
if (*s == '"')
- sv_catpv(sstr, "\\\"");
+ sv_catpvs(sstr, "\\\"");
else if (*s == '\\')
- sv_catpv(sstr, "\\\\");
+ sv_catpvs(sstr, "\\\\");
/* trigraphs - bleagh */
- else if (!perlstyle && *s == '?' && len>=3 && s[1] == '?')
- {
- sprintf(escbuff, "\\%03o", '?');
- sv_catpv(sstr, escbuff);
+ else if (!perlstyle && *s == '?' && len>=3 && s[1] == '?') {
+ Perl_sv_catpvf(aTHX_ sstr, "\\%03o", '?');
}
else if (perlstyle && *s == '$')
- sv_catpv(sstr, "\\$");
+ sv_catpvs(sstr, "\\$");
else if (perlstyle && *s == '@')
- sv_catpv(sstr, "\\@");
+ sv_catpvs(sstr, "\\@");
#ifdef EBCDIC
else if (isPRINT(*s))
#else
#endif /* EBCDIC */
sv_catpvn(sstr, s, 1);
else if (*s == '\n')
- sv_catpv(sstr, "\\n");
+ sv_catpvs(sstr, "\\n");
else if (*s == '\r')
- sv_catpv(sstr, "\\r");
+ sv_catpvs(sstr, "\\r");
else if (*s == '\t')
- sv_catpv(sstr, "\\t");
+ sv_catpvs(sstr, "\\t");
else if (*s == '\a')
- sv_catpv(sstr, "\\a");
+ sv_catpvs(sstr, "\\a");
else if (*s == '\b')
- sv_catpv(sstr, "\\b");
+ sv_catpvs(sstr, "\\b");
else if (*s == '\f')
- sv_catpv(sstr, "\\f");
+ sv_catpvs(sstr, "\\f");
else if (!perlstyle && *s == '\v')
- sv_catpv(sstr, "\\v");
+ sv_catpvs(sstr, "\\v");
else
{
/* Don't want promotion of a signed -1 char in sprintf args */
- unsigned char c = (unsigned char) *s;
- sprintf(escbuff, "\\%03o", c);
- sv_catpv(sstr, escbuff);
+ const unsigned char c = (unsigned char) *s;
+ Perl_sv_catpvf(aTHX_ sstr, "\\%03o", c);
}
/* XXX Add line breaks if string is long */
}
- sv_catpv(sstr, "\"");
+ sv_catpvs(sstr, "\"");
}
return sstr;
}
static SV *
cchar(pTHX_ SV *sv)
{
- SV *sstr = newSVpvn("'", 1);
- STRLEN n_a;
- char *s = SvPV(sv, n_a);
+ SV *sstr = newSVpvs("'");
+ const char *s = SvPV_nolen(sv);
if (*s == '\'')
- sv_catpv(sstr, "\\'");
+ sv_catpvs(sstr, "\\'");
else if (*s == '\\')
- sv_catpv(sstr, "\\\\");
+ sv_catpvs(sstr, "\\\\");
#ifdef EBCDIC
else if (isPRINT(*s))
#else
#endif /* EBCDIC */
sv_catpvn(sstr, s, 1);
else if (*s == '\n')
- sv_catpv(sstr, "\\n");
+ sv_catpvs(sstr, "\\n");
else if (*s == '\r')
- sv_catpv(sstr, "\\r");
+ sv_catpvs(sstr, "\\r");
else if (*s == '\t')
- sv_catpv(sstr, "\\t");
+ sv_catpvs(sstr, "\\t");
else if (*s == '\a')
- sv_catpv(sstr, "\\a");
+ sv_catpvs(sstr, "\\a");
else if (*s == '\b')
- sv_catpv(sstr, "\\b");
+ sv_catpvs(sstr, "\\b");
else if (*s == '\f')
- sv_catpv(sstr, "\\f");
+ sv_catpvs(sstr, "\\f");
else if (*s == '\v')
- sv_catpv(sstr, "\\v");
+ sv_catpvs(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);
- sv_catpv(sstr, escbuff);
+ const STRLEN oct_len = my_sprintf(escbuff, "\\%03o", c);
+ sv_catpvn(sstr, escbuff, oct_len);
}
- sv_catpv(sstr, "'");
+ sv_catpvs(sstr, "'");
return sstr;
}
-void
-walkoptree(pTHX_ SV *opsv, char *method)
+#if PERL_VERSION >= 9
+# define PMOP_pmreplstart(o) o->op_pmstashstartu.op_pmreplstart
+# define PMOP_pmreplroot(o) o->op_pmreplrootu.op_pmreplroot
+#else
+# define PMOP_pmreplstart(o) o->op_pmreplstart
+# define PMOP_pmreplroot(o) o->op_pmreplroot
+# define PMOP_pmpermflags(o) o->op_pmpermflags
+# define PMOP_pmdynflags(o) o->op_pmdynflags
+#endif
+
+static void
+walkoptree(pTHX_ SV *opsv, const char *method)
{
dSP;
OP *o, *kid;
walkoptree(aTHX_ opsv, method);
}
}
- if (o && (cc_opclass(aTHX_ o) == OPc_PMOP)
- && (kid = cPMOPo->op_pmreplroot))
+ if (o && (cc_opclass(aTHX_ o) == OPc_PMOP) && o->op_type != OP_PUSHRE
+ && (kid = PMOP_pmreplroot(cPMOPo)))
{
- sv_setiv(newSVrv(opsv, opclassnames[OPc_PMOP]), PTR2IV(kid));
+ 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_ PMOP_pmreplstart(cPMOPo), 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 SV *B__PV;
typedef SV *B__NV;
typedef SV *B__PVMG;
+#if PERL_VERSION >= 11
+typedef SV *B__REGEXP;
+#endif
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;
typedef IO *B__IO;
typedef MAGIC *B__MAGIC;
+typedef HE *B__HE;
+#if PERL_VERSION >= 9
+typedef struct refcounted_he *B__RHE;
+#endif
+
+#include "const-c.inc"
MODULE = B PACKAGE = B PREFIX = B_
+INCLUDE: const-xs.inc
+
PROTOTYPES: DISABLE
BOOT:
{
- HV *stash = gv_stashpvn("B", 1, TRUE);
- AV *export_ok = perl_get_av("B::EXPORT_OK",TRUE);
+ HV *stash = gv_stashpvs("B", GV_ADD);
+ AV *export_ok = perl_get_av("B::EXPORT_OK", GV_ADD);
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"
+ 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
}
#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
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
long
B_amagic_generation()
+long
+B_sub_generation()
+
B::AV
B_comppadlist()
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);
void
opnumber(name)
-char * name
+const char * name
CODE:
{
int i;
CODE:
ST(0) = sv_newmortal();
if (opnum >= 0 && opnum < PL_maxo) {
- sv_setpvn(ST(0), "pp_", 3);
+ sv_setpvs(ST(0), "pp_");
sv_catpv(ST(0), PL_op_name[opnum]);
}
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));
+ len = my_sprintf(hexhash, "0x%"UVxf, (UV)hash);
+ ST(0) = newSVpvn_flags(hexhash, len, SVs_TEMP);
#define cast_I32(foo) (I32)foo
IV
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)));
+ PUSHs(newSVpvn_flags(&PL_threadsv_names[i], 1, SVs_TEMP));
+# 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
+#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
OP_name(o)
B::OP o
CODE:
- RETVAL = PL_op_name[o->op_type];
+ RETVAL = (char *)PL_op_name[o->op_type];
OUTPUT:
RETVAL
int i;
SV *sv = sv_newmortal();
CODE:
- sv_setpvn(sv, "PL_ppaddr[OP_", 13);
+ sv_setpvs(sv, "PL_ppaddr[OP_");
sv_catpv(sv, PL_op_name[o->op_type]);
- for (i=13; i<SvCUR(sv); ++i)
+ for (i=13; (STRLEN)i < SvCUR(sv); ++i)
SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]);
- sv_catpv(sv, "]");
+ sv_catpvs(sv, "]");
ST(0) = sv;
char *
OP_type(o)
B::OP o
+#if PERL_VERSION >= 9
+
+U16
+OP_opt(o)
+ B::OP o
+
+#else
+
U16
OP_seq(o)
B::OP o
+#endif
+
U8
OP_flags(o)
B::OP o
OP_private(o)
B::OP o
+#if PERL_VERSION >= 9
+
+U16
+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_
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) 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
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
PMOP_pmdynflags(o)
B::PMOP o
+#endif
+
void
PMOP_precomp(o)
B::PMOP o
ST(0) = sv_newmortal();
rx = PM_GETRE(o);
if (rx)
- sv_setpvn(ST(0), rx->precomp, rx->prelen);
+ sv_setpvn(ST(0), RX_PRECOMP(rx), RX_PRELEN(rx));
+
+#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(rx));
+
+#endif
#define SVOP_sv(o) cSVOPo->op_sv
#define SVOP_gv(o) ((GV*)cSVOPo->op_sv)
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) : (GV *)NULL)
MODULE = B PACKAGE = B::PADOP PREFIX = PADOP_
(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)));
+ const short* const tbl = (short*)o->op_pv;
+ const short entries = 257 + tbl[256];
+ ST(0) = newSVpvn_flags(o->op_pv, entries * sizeof(short), SVs_TEMP);
}
else if (o->op_type == OP_TRANS) {
- ST(0) = sv_2mortal(newSVpv(o->op_pv, 256 * sizeof(short)));
+ ST(0) = newSVpvn_flags(o->op_pv, 256 * sizeof(short), SVs_TEMP);
}
else
- ST(0) = sv_2mortal(newSVpv(o->op_pv, 0));
+ ST(0) = newSVpvn_flags(o->op_pv, strlen(o->op_pv), SVs_TEMP);
#define LOOP_redoop(o) o->op_redoop
#define LOOP_nextop(o) o->op_nextop
LOOP_lastop(o)
B::LOOP o
-#define COP_label(o) o->cop_label
+#define COP_label(o) CopLABEL(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_
+#if PERL_VERSION >= 11
+
+const char *
+COP_label(o)
+ B::COP o
+
+#else
+
char *
COP_label(o)
B::COP o
+#endif
+
char *
COP_stashpv(o)
B::COP o
COP_file(o)
B::COP o
+B::GV
+COP_filegv(o)
+ B::COP o
+
+
U32
COP_cop_seq(o)
B::COP o
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 = CopHINTHASH_get(o);
+ 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
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
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
wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
#endif
wp[1] = htonl(iv & 0xffffffff);
- ST(0) = sv_2mortal(newSVpvn((char *)wp, 8));
+ ST(0) = newSVpvn_flags((char *)wp, 8, SVs_TEMP);
} else {
U32 w = htonl((U32)SvIVX(sv));
- ST(0) = sv_2mortal(newSVpvn((char *)&w, 4));
+ ST(0) = newSVpvn_flags((char *)&w, 4, SVs_TEMP);
}
+
+#if PERL_VERSION >= 11
+
+B::SV
+RV(sv)
+ B::IV sv
+ CODE:
+ if( SvROK(sv) ) {
+ RETVAL = SvRV(sv);
+ }
+ else {
+ croak( "argument is not SvROK" );
+ }
+ OUTPUT:
+ RETVAL
+
+#endif
+
MODULE = B PACKAGE = B::NV PREFIX = Sv
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
+
+#if PERL_VERSION < 11
+
MODULE = B PACKAGE = B::RV PREFIX = Sv
B::SV
SvRV(sv)
B::RV sv
+#endif
+
MODULE = B PACKAGE = B::PV PREFIX = Sv
char*
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 {
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
SvSTASH(sv)
B::PVMG sv
+MODULE = B PACKAGE = B::REGEXP
+
+#if PERL_VERSION >= 11
+
+IV
+REGEX(sv)
+ B::REGEXP sv
+ CODE:
+ /* FIXME - can we code this method more efficiently? */
+ RETVAL = PTR2IV(sv);
+ OUTPUT:
+ RETVAL
+
+SV*
+precomp(sv)
+ B::REGEXP sv
+ CODE:
+ RETVAL = newSVpvn( RX_PRECOMP(sv), RX_PRELEN(sv) );
+ OUTPUT:
+ RETVAL
+
+#endif
+
#define MgMOREMAGIC(mg) mg->mg_moremagic
#define MgPRIVATE(mg) mg->mg_private
#define MgTYPE(mg) mg->mg_type
B::MAGIC
MgMOREMAGIC(mg)
B::MAGIC mg
+ CODE:
+ if( MgMOREMAGIC(mg) ) {
+ RETVAL = MgMOREMAGIC(mg);
+ }
+ else {
+ XSRETURN_UNDEF;
+ }
+ OUTPUT:
+ RETVAL
U16
MgPRIVATE(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 {
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 );
+ RETVAL = newSVpvn( RX_PRECOMP(rx), RX_PRELEN(rx) );
}
else {
croak( "precomp is only meaningful on r-magic" );
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);
}
}
BmUSEFUL(sv)
B::BM sv
-U16
+U32
BmPREVIOUS(sv)
B::BM 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) = newSVpvn_flags(str + len + PERL_FBM_TABLE_OFFSET, 256, SVs_TEMP);
MODULE = B PACKAGE = B::GV PREFIX = Gv
GvNAME(gv)
B::GV gv
CODE:
- ST(0) = sv_2mortal(newSVpvn(GvNAME(gv), GvNAMELEN(gv)));
+#if PERL_VERSION >= 10
+ ST(0) = sv_2mortal(newSVhek(GvNAME_HEK(gv)));
+#else
+ ST(0) = newSVpvn_flags(GvNAME(gv), GvNAMELEN(gv), SVs_TEMP);
+#endif
bool
is_empty(gv)
OUTPUT:
RETVAL
+bool
+isGV_with_GP(gv)
+ B::GV gv
+ CODE:
+#if PERL_VERSION >= 9
+ RETVAL = isGV_with_GP(gv) ? TRUE : FALSE;
+#else
+ RETVAL = TRUE; /* In 5.8 and earlier they all are. */
+#endif
+ OUTPUT:
+ RETVAL
+
+void*
+GvGP(gv)
+ B::GV gv
+
B::HV
GvSTASH(gv)
B::GV gv
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)
GvCVGEN(gv)
B::GV gv
-U16
+U32
GvLINE(gv)
B::GV gv
IoBOTTOM_GV(io)
B::IO io
+#if PERL_VERSION <= 8
+
short
IoSUBPROCESS(io)
B::IO io
+#endif
+
bool
IsSTD(io,name)
B::IO io
- char* name
+ const char* name
PREINIT:
PerlIO* handle = 0;
CODE:
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
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
B::OP
CvSTART(cv)
B::CV cv
-
-B::OP
-CvROOT(cv)
- B::CV cv
+ ALIAS:
+ ROOT = 1
+ CODE:
+ RETVAL = CvISXSUB(cv) ? NULL : ix ? CvROOT(cv) : CvSTART(cv);
+ OUTPUT:
+ RETVAL
B::GV
CvGV(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
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
HvNAME(hv)
B::HV hv
+#if PERL_VERSION < 9
+
B::PMOP
HvPMROOT(hv)
B::HV hv
+#endif
+
void
HvARRAY(hv)
B::HV hv
(void)hv_iterinit(hv);
EXTEND(sp, HvKEYS(hv) * 2);
while ((sv = hv_iternextsv(hv, &key, &len))) {
- PUSHs(newSVpvn(key, len));
+ mPUSHp(key, len);
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*)cophh_2hv(h, 0) );
+ OUTPUT:
+ RETVAL
+
+#endif
https://perl5.git.perl.org / perl5.git / blobdiff