*/
#define PERL_NO_GET_CONTEXT
+#define PERL_EXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
static const char* const svclassnames[] = {
"B::NULL",
-#if PERL_VERSION < 19
- "B::BIND",
-#endif
"B::IV",
"B::NV",
-#if PERL_VERSION <= 10
- "B::RV",
-#endif
"B::PV",
-#if PERL_VERSION >= 19
"B::INVLIST",
-#endif
"B::PVIV",
"B::PVNV",
"B::PVMG",
-#if PERL_VERSION >= 11
"B::REGEXP",
-#endif
"B::GV",
"B::PVLV",
"B::AV",
OPc_PADOP, /* 8 */
OPc_PVOP, /* 9 */
OPc_LOOP, /* 10 */
- OPc_COP /* 11 */
+ OPc_COP, /* 11 */
+ OPc_METHOP, /* 12 */
+ OPc_UNOP_AUX /* 13 */
} opclass;
static const char* const opclassnames[] = {
"B::PADOP",
"B::PVOP",
"B::LOOP",
- "B::COP"
+ "B::COP",
+ "B::METHOP",
+ "B::UNOP_AUX"
};
static const size_t opsizes[] = {
sizeof(PADOP),
sizeof(PVOP),
sizeof(LOOP),
- sizeof(COP)
+ sizeof(COP),
+ sizeof(METHOP),
+ sizeof(UNOP_AUX),
};
#define MY_CXT_KEY "B::_guts" XS_VERSION
typedef struct {
- int x_walkoptree_debug; /* Flag for walkoptree debug hook */
SV * x_specialsv_list[7];
+ int x_walkoptree_debug; /* Flag for walkoptree debug hook */
} my_cxt_t;
START_MY_CXT
#define walkoptree_debug (MY_CXT.x_walkoptree_debug)
#define specialsv_list (MY_CXT.x_specialsv_list)
+
+static void B_init_my_cxt(pTHX_ my_cxt_t * cxt) {
+ cxt->x_specialsv_list[0] = Nullsv;
+ cxt->x_specialsv_list[1] = &PL_sv_undef;
+ cxt->x_specialsv_list[2] = &PL_sv_yes;
+ cxt->x_specialsv_list[3] = &PL_sv_no;
+ cxt->x_specialsv_list[4] = (SV *) pWARN_ALL;
+ cxt->x_specialsv_list[5] = (SV *) pWARN_NONE;
+ cxt->x_specialsv_list[6] = (SV *) pWARN_STD;
+}
+
static opclass
cc_opclass(pTHX_ const OP *o)
{
if (!o)
return OPc_NULL;
- if (o->op_type == 0)
+ if (o->op_type == 0) {
+ if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
+ return OPc_COP;
return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
+ }
if (o->op_type == OP_SASSIGN)
return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
if (o->op_type == OP_AELEMFAST) {
-#if PERL_VERSION <= 14
- if (o->op_flags & OPf_SPECIAL)
- return OPc_BASEOP;
- else
-#endif
#ifdef USE_ITHREADS
return OPc_PADOP;
#else
return OPc_BASEOP;
else
return OPc_PVOP;
+ case OA_METHOP:
+ return OPc_METHOP;
+ case OA_UNOP_AUX:
+ return OPc_UNOP_AUX;
}
warn("can't determine class of operator %s, assuming BASEOP\n",
OP_NAME(o));
PUTBACK;
perl_call_method(method, G_DISCARD);
if (o && (o->op_flags & OPf_KIDS)) {
- for (kid = ((UNOP*)o)->op_first; kid; kid = OP_SIBLING(kid)) {
+ for (kid = ((UNOP*)o)->op_first; kid; kid = OpSIBLING(kid)) {
ref = walkoptree(aTHX_ kid, method, ref);
}
}
continue;
case OP_SORT:
if (o->op_flags & OPf_STACKED && o->op_flags & OPf_SPECIAL) {
- OP *kid = OP_SIBLING(cLISTOPo->op_first); /* pass pushmark */
+ OP *kid = OpSIBLING(cLISTOPo->op_first); /* pass pushmark */
kid = kUNOP->op_first; /* pass rv2gv */
kid = kUNOP->op_first; /* pass leave */
SP = oplist(aTHX_ kid->op_next, SP);
typedef PVOP *B__PVOP;
typedef LOOP *B__LOOP;
typedef COP *B__COP;
+typedef METHOP *B__METHOP;
typedef SV *B__SV;
typedef SV *B__IV;
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;
#ifdef PadlistARRAY
typedef PADLIST *B__PADLIST;
#endif
+typedef PADNAMELIST *B__PADNAMELIST;
+typedef PADNAME *B__PADNAME;
+
#ifdef MULTIPLICITY
# define ASSIGN_COMMON_ALIAS(prefix, var) \
/* table that drives most of the B::*OP methods */
-struct OP_methods {
+static const struct OP_methods {
const char *name;
U8 namelen;
U8 type; /* if op_offset_special, access is handled on a case-by-case basis */
{ STR_WITH_LEN("nextop"), OPp, STRUCT_OFFSET(struct loop, op_nextop), },/*10*/
{ STR_WITH_LEN("lastop"), OPp, STRUCT_OFFSET(struct loop, op_lastop), },/*11*/
{ STR_WITH_LEN("pmflags"), U32p, STRUCT_OFFSET(struct pmop, op_pmflags),},/*12*/
-#if PERL_VERSION >= 17
{ STR_WITH_LEN("code_list"),OPp, STRUCT_OFFSET(struct pmop, op_code_list),},/*13*/
-#else
- { STR_WITH_LEN("code_list"),op_offset_special, 0, }, /*13*/
-#endif
{ STR_WITH_LEN("sv"), SVp, STRUCT_OFFSET(struct svop, op_sv), },/*14*/
{ STR_WITH_LEN("gv"), SVp, STRUCT_OFFSET(struct svop, op_sv), },/*15*/
{ STR_WITH_LEN("padix"), PADOFFSETp,STRUCT_OFFSET(struct padop, op_padix),},/*16*/
{ STR_WITH_LEN("filegv"), op_offset_special, 0, },/*21*/
{ STR_WITH_LEN("file"), char_pp, STRUCT_OFFSET(struct cop, cop_file), },/*22*/
{ STR_WITH_LEN("stash"), op_offset_special, 0, },/*23*/
-# if PERL_VERSION < 17
- { STR_WITH_LEN("stashpv"), char_pp, STRUCT_OFFSET(struct cop, cop_stashpv),}, /*24*/
- { STR_WITH_LEN("stashoff"),op_offset_special, 0, },/*25*/
-# else
{ STR_WITH_LEN("stashpv"), op_offset_special, 0, },/*24*/
{ STR_WITH_LEN("stashoff"),PADOFFSETp,STRUCT_OFFSET(struct cop,cop_stashoff),},/*25*/
-# endif
#else
{ STR_WITH_LEN("pmoffset"),op_offset_special, 0, },/*20*/
{ STR_WITH_LEN("filegv"), SVp, STRUCT_OFFSET(struct cop, cop_filegv),},/*21*/
{ STR_WITH_LEN("warnings"),op_offset_special, 0, },/*44*/
{ STR_WITH_LEN("io"), op_offset_special, 0, },/*45*/
{ STR_WITH_LEN("hints_hash"),op_offset_special, 0, },/*46*/
-#if PERL_VERSION >= 17
{ STR_WITH_LEN("slabbed"), op_offset_special, 0, },/*47*/
{ STR_WITH_LEN("savefree"),op_offset_special, 0, },/*48*/
{ STR_WITH_LEN("static"), op_offset_special, 0, },/*49*/
-# if PERL_VERSION >= 19
{ STR_WITH_LEN("folded"), op_offset_special, 0, },/*50*/
- { STR_WITH_LEN("lastsib"), op_offset_special, 0, },/*51*/
+ { STR_WITH_LEN("moresib"), op_offset_special, 0, },/*51*/
{ STR_WITH_LEN("parent"), op_offset_special, 0, },/*52*/
+ { STR_WITH_LEN("first"), op_offset_special, 0, },/*53*/
+ { STR_WITH_LEN("meth_sv"), op_offset_special, 0, },/*54*/
+ { STR_WITH_LEN("pmregexp"),op_offset_special, 0, },/*55*/
+# ifdef USE_ITHREADS
+ { STR_WITH_LEN("rclass"), op_offset_special, 0, },/*56*/
+# else
+ { STR_WITH_LEN("rclass"), op_offset_special, 0, },/*56*/
# endif
-#endif
};
#include "const-c.inc"
{
CV *cv;
const char *file = __FILE__;
+ SV *sv;
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] = (SV *) pWARN_ALL;
- specialsv_list[5] = (SV *) pWARN_NONE;
- specialsv_list[6] = (SV *) pWARN_STD;
-
+ B_init_my_cxt(aTHX_ &(MY_CXT));
cv = newXS("B::init_av", intrpvar_sv_common, file);
ASSIGN_COMMON_ALIAS(I, initav);
cv = newXS("B::check_av", intrpvar_sv_common, file);
ASSIGN_COMMON_ALIAS(I, warnhook);
cv = newXS("B::diehook", intrpvar_sv_common, file);
ASSIGN_COMMON_ALIAS(I, diehook);
+ sv = get_sv("B::OP::does_parent", GV_ADDMULTI);
+#ifdef PERL_OP_PARENT
+ sv_setsv(sv, &PL_sv_yes);
+#else
+ sv_setsv(sv, &PL_sv_no);
+#endif
}
#ifndef PL_formfeed
PPCODE:
+#ifdef USE_ITHREADS
+void
+CLONE(...)
+PPCODE:
+ PUTBACK; /* some vars go out of scope now in machine code */
+ {
+ MY_CXT_CLONE;
+ B_init_my_cxt(aTHX_ &(MY_CXT));
+ }
+ return; /* dont execute another implied XSPP PUTBACK */
+#endif
MODULE = B PACKAGE = B::OP
B::OP::savefree = 48
B::OP::static = 49
B::OP::folded = 50
- B::OP::lastsib = 51
+ B::OP::moresib = 51
B::OP::parent = 52
+ B::METHOP::first = 53
+ B::METHOP::meth_sv = 54
+ B::PMOP::pmregexp = 55
+ B::METHOP::rclass = 56
PREINIT:
SV *ret;
PPCODE:
if (op_methods[ix].type == op_offset_special)
switch (ix) {
case 1: /* B::OP::op_sibling */
- ret = make_op_object(aTHX_ OP_SIBLING(o));
+ ret = make_op_object(aTHX_ OpSIBLING(o));
break;
case 8: /* B::PMOP::pmreplstart */
ret = make_sv_object(aTHX_ (SV *)CopSTASH((COP*)o));
break;
#endif
-#if PERL_VERSION >= 17 || !defined USE_ITHREADS
case 24: /* B::COP::stashpv */
-# if PERL_VERSION >= 17
ret = sv_2mortal(CopSTASH((COP*)o)
&& SvTYPE(CopSTASH((COP*)o)) == SVt_PVHV
? newSVhek(HvNAME_HEK(CopSTASH((COP*)o)))
: &PL_sv_undef);
-# else
- ret = sv_2mortal(newSVpv(CopSTASHPV((COP*)o), 0));
-# endif
break;
-#endif
case 26: /* B::OP::size */
ret = sv_2mortal(newSVuv((UV)(opsizes[cc_opclass(aTHX_ o)])));
break;
case 30: /* B::OP::type */
case 31: /* B::OP::opt */
case 32: /* B::OP::spare */
-#if PERL_VERSION >= 17
case 47: /* B::OP::slabbed */
case 48: /* B::OP::savefree */
case 49: /* B::OP::static */
-#if PERL_VERSION >= 19
case 50: /* B::OP::folded */
- case 51: /* B::OP::lastsib */
-#endif
-#endif
+ case 51: /* B::OP::moresib */
/* These are all bitfields, so we can't take their addresses */
ret = sv_2mortal(newSVuv((UV)(
ix == 30 ? o->op_type
: ix == 48 ? o->op_savefree
: ix == 49 ? o->op_static
: ix == 50 ? o->op_folded
- : ix == 51 ? o->op_lastsib
+ : ix == 51 ? o->op_moresib
: o->op_spare)));
break;
case 33: /* B::LISTOP::children */
{
OP *kid;
UV i = 0;
- for (kid = ((LISTOP*)o)->op_first; kid; kid = OP_SIBLING(kid))
+ for (kid = ((LISTOP*)o)->op_first; kid; kid = OpSIBLING(kid))
i++;
ret = sv_2mortal(newSVuv(i));
}
PTR2IV(CopHINTHASH_get(cCOPo)));
break;
case 52: /* B::OP::parent */
+#ifdef PERL_OP_PARENT
ret = make_op_object(aTHX_ op_parent(o));
+#else
+ ret = make_op_object(aTHX_ NULL);
+#endif
+ break;
+ case 53: /* B::METHOP::first */
+ /* METHOP struct has an op_first/op_meth_sv union
+ * as its first extra field. How to interpret the
+ * union depends on the op type. For the purposes of
+ * B, we treat it as a struct with both fields present,
+ * where one of the fields always happens to be null
+ * (i.e. we return NULL in preference to croaking with
+ * 'method not implemented').
+ */
+ ret = make_op_object(aTHX_
+ o->op_type == OP_METHOD
+ ? cMETHOPx(o)->op_u.op_first : NULL);
+ break;
+ case 54: /* B::METHOP::meth_sv */
+ /* see comment above about METHOP */
+ ret = make_sv_object(aTHX_
+ o->op_type == OP_METHOD
+ ? NULL : cMETHOPx(o)->op_u.op_meth_sv);
+ break;
+ case 55: /* B::PMOP::pmregexp */
+ ret = make_sv_object(aTHX_ (SV *)PM_GETRE(cPMOPo));
+ break;
+ case 56: /* B::METHOP::rclass */
+#ifdef USE_ITHREADS
+ ret = sv_2mortal(newSVuv(
+ (o->op_type == OP_METHOD_REDIR ||
+ o->op_type == OP_METHOD_REDIR_SUPER) ?
+ cMETHOPx(o)->op_rclass_targ : 0
+ ));
+#else
+ ret = make_sv_object(aTHX_
+ (o->op_type == OP_METHOD_REDIR ||
+ o->op_type == OP_METHOD_REDIR_SUPER) ?
+ cMETHOPx(o)->op_rclass_sv : NULL
+ );
+#endif
break;
default:
croak("method %s not implemented", op_methods[ix].name);
SP = oplist(aTHX_ o, SP);
+
+MODULE = B PACKAGE = B::UNOP_AUX
+
+# UNOP_AUX class ops are like UNOPs except that they have an extra
+# op_aux pointer that points to an array of UNOP_AUX_item unions.
+# Element -1 of the array contains the length
+
+
+# return a string representation of op_aux where possible The op's CV is
+# needed as an extra arg to allow GVs and SVs moved into the pad to be
+# accessed okay.
+
+void
+string(o, cv)
+ B::OP o
+ B::CV cv
+ PREINIT:
+ SV *ret;
+ UNOP_AUX_item *aux;
+ PPCODE:
+ aux = cUNOP_AUXo->op_aux;
+ switch (o->op_type) {
+ case OP_MULTIDEREF:
+ ret = multideref_stringify(o, cv);
+ break;
+
+ case OP_ARGELEM:
+ ret = sv_2mortal(Perl_newSVpvf(aTHX_ "%"UVuf,
+ PTR2UV(aux)));
+ break;
+
+ case OP_ARGCHECK:
+ ret = Perl_newSVpvf(aTHX_ "%"UVuf",%"UVuf, aux[0].uv, aux[1].uv);
+ if (aux[2].iv)
+ Perl_sv_catpvf(aTHX_ ret, ",%c", (char)aux[2].iv);
+ ret = sv_2mortal(ret);
+ break;
+
+ default:
+ ret = sv_2mortal(newSVpvn("", 0));
+ }
+
+ ST(0) = ret;
+ XSRETURN(1);
+
+
+# Return the contents of the op_aux array as a list of IV/GV/etc objects.
+# How to interpret each array element is op-dependent. The op's CV is
+# needed as an extra arg to allow GVs and SVs which have been moved into
+# the pad to be accessed okay.
+
+void
+aux_list(o, cv)
+ B::OP o
+ B::CV cv
+ PREINIT:
+ UNOP_AUX_item *aux;
+ PPCODE:
+ PERL_UNUSED_VAR(cv); /* not needed on unthreaded builds */
+ aux = cUNOP_AUXo->op_aux;
+ switch (o->op_type) {
+ default:
+ XSRETURN(0); /* by default, an empty list */
+
+ case OP_ARGELEM:
+ XPUSHs(sv_2mortal(newSVuv(PTR2UV(aux))));
+ XSRETURN(1);
+ break;
+
+ case OP_ARGCHECK:
+ EXTEND(SP, 3);
+ PUSHs(sv_2mortal(newSVuv(aux[0].uv)));
+ PUSHs(sv_2mortal(newSVuv(aux[1].uv)));
+ PUSHs(sv_2mortal(aux[2].iv ? Perl_newSVpvf(aTHX_ "%c",
+ (char)aux[2].iv) : &PL_sv_no));
+ break;
+
+ case OP_MULTIDEREF:
+#ifdef USE_ITHREADS
+# define ITEM_SV(item) *av_fetch(comppad, (item)->pad_offset, FALSE);
+#else
+# define ITEM_SV(item) UNOP_AUX_item_sv(item)
+#endif
+ {
+ UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
+ UV actions = items->uv;
+ UV len = items[-1].uv;
+ SV *sv;
+ bool last = 0;
+ bool is_hash = FALSE;
+#ifdef USE_ITHREADS
+ PADLIST * const padlist = CvPADLIST(cv);
+ PAD *comppad = PadlistARRAY(padlist)[1];
+#endif
+
+ /* len should never be big enough to truncate or wrap */
+ assert(len <= SSize_t_MAX);
+ EXTEND(SP, (SSize_t)len);
+ PUSHs(sv_2mortal(newSViv(actions)));
+
+ while (!last) {
+ switch (actions & MDEREF_ACTION_MASK) {
+
+ case MDEREF_reload:
+ actions = (++items)->uv;
+ PUSHs(sv_2mortal(newSVuv(actions)));
+ continue;
+ NOT_REACHED; /* NOTREACHED */
+
+ case MDEREF_HV_padhv_helem:
+ is_hash = TRUE;
+ /* FALLTHROUGH */
+ case MDEREF_AV_padav_aelem:
+ PUSHs(sv_2mortal(newSVuv((++items)->pad_offset)));
+ goto do_elem;
+ NOT_REACHED; /* NOTREACHED */
+
+ case MDEREF_HV_gvhv_helem:
+ is_hash = TRUE;
+ /* FALLTHROUGH */
+ case MDEREF_AV_gvav_aelem:
+ sv = ITEM_SV(++items);
+ PUSHs(make_sv_object(aTHX_ sv));
+ goto do_elem;
+ NOT_REACHED; /* NOTREACHED */
+
+ case MDEREF_HV_gvsv_vivify_rv2hv_helem:
+ is_hash = TRUE;
+ /* FALLTHROUGH */
+ case MDEREF_AV_gvsv_vivify_rv2av_aelem:
+ sv = ITEM_SV(++items);
+ PUSHs(make_sv_object(aTHX_ sv));
+ goto do_vivify_rv2xv_elem;
+ NOT_REACHED; /* NOTREACHED */
+
+ case MDEREF_HV_padsv_vivify_rv2hv_helem:
+ is_hash = TRUE;
+ /* FALLTHROUGH */
+ case MDEREF_AV_padsv_vivify_rv2av_aelem:
+ PUSHs(sv_2mortal(newSVuv((++items)->pad_offset)));
+ goto do_vivify_rv2xv_elem;
+ NOT_REACHED; /* NOTREACHED */
+
+ case MDEREF_HV_pop_rv2hv_helem:
+ case MDEREF_HV_vivify_rv2hv_helem:
+ is_hash = TRUE;
+ /* FALLTHROUGH */
+ do_vivify_rv2xv_elem:
+ case MDEREF_AV_pop_rv2av_aelem:
+ case MDEREF_AV_vivify_rv2av_aelem:
+ do_elem:
+ switch (actions & MDEREF_INDEX_MASK) {
+ case MDEREF_INDEX_none:
+ last = 1;
+ break;
+ case MDEREF_INDEX_const:
+ if (is_hash) {
+ sv = ITEM_SV(++items);
+ PUSHs(make_sv_object(aTHX_ sv));
+ }
+ else
+ PUSHs(sv_2mortal(newSViv((++items)->iv)));
+ break;
+ case MDEREF_INDEX_padsv:
+ PUSHs(sv_2mortal(newSVuv((++items)->pad_offset)));
+ break;
+ case MDEREF_INDEX_gvsv:
+ sv = ITEM_SV(++items);
+ PUSHs(make_sv_object(aTHX_ sv));
+ break;
+ }
+ if (actions & MDEREF_FLAG_last)
+ last = 1;
+ is_hash = FALSE;
+
+ break;
+ } /* switch */
+
+ actions >>= MDEREF_SHIFT;
+ } /* while */
+ XSRETURN(len);
+
+ } /* OP_MULTIDEREF */
+ } /* switch */
+
+
+
MODULE = B PACKAGE = B::SV
#define MAGICAL_FLAG_BITS (SVs_GMG|SVs_SMG|SVs_RMG)
#define IV_uvx_ix sv_UVp | STRUCT_OFFSET(struct xpvuv, xuv_uv)
#define NV_nvx_ix sv_NVp | STRUCT_OFFSET(struct xpvnv, xnv_u.xnv_nv)
-#define NV_cop_seq_range_low_ix \
- sv_U32p | STRUCT_OFFSET(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
-#define NV_cop_seq_range_high_ix \
- sv_U32p | STRUCT_OFFSET(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
-#define NV_parent_pad_index_ix \
- sv_U32p | STRUCT_OFFSET(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
-#define NV_parent_fakelex_flags_ix \
- sv_U32p | STRUCT_OFFSET(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
-
#define PV_cur_ix sv_STRLENp | STRUCT_OFFSET(struct xpv, xpv_cur)
#define PV_len_ix sv_STRLENp | STRUCT_OFFSET(struct xpv, xpv_len)
#define PVMG_stash_ix sv_SVp | STRUCT_OFFSET(struct xpvmg, xmg_stash)
-#if PERL_VERSION > 18
-# define PVBM_useful_ix sv_IVp | STRUCT_OFFSET(struct xpviv, xiv_u.xivu_iv)
-#elif PERL_VERSION > 14
-# define PVBM_useful_ix sv_I32p | STRUCT_OFFSET(struct xpvgv, xnv_u.xbm_s.xbm_useful)
-#else
-#define PVBM_useful_ix sv_I32p | STRUCT_OFFSET(struct xpvgv, xiv_u.xivu_i32)
-#endif
+#define PVBM_useful_ix sv_IVp | STRUCT_OFFSET(struct xpviv, xiv_u.xivu_iv)
#define PVLV_targoff_ix sv_U32p | STRUCT_OFFSET(struct xpvlv, xlv_targoff)
#define PVLV_targlen_ix sv_U32p | STRUCT_OFFSET(struct xpvlv, xlv_targlen)
#define PVAV_max_ix sv_SSize_tp | STRUCT_OFFSET(struct xpvav, xav_max)
#define PVCV_stash_ix sv_SVp | STRUCT_OFFSET(struct xpvcv, xcv_stash)
-#if PERL_VERSION > 17 || (PERL_VERSION == 17 && PERL_SUBVERSION >= 3)
-# define PVCV_gv_ix sv_SVp | STRUCT_OFFSET(struct xpvcv, xcv_gv_u.xcv_gv)
-#else
-# define PVCV_gv_ix sv_SVp | STRUCT_OFFSET(struct xpvcv, xcv_gv)
-#endif
+#define PVCV_gv_ix sv_SVp | STRUCT_OFFSET(struct xpvcv, xcv_gv_u.xcv_gv)
#define PVCV_file_ix sv_char_pp | STRUCT_OFFSET(struct xpvcv, xcv_file)
#define PVCV_outside_ix sv_SVp | STRUCT_OFFSET(struct xpvcv, xcv_outside)
#define PVCV_outside_seq_ix sv_U32p | STRUCT_OFFSET(struct xpvcv, xcv_outside_seq)
#define PVCV_flags_ix sv_U32p | STRUCT_OFFSET(struct xpvcv, xcv_flags)
#define PVHV_max_ix sv_STRLENp | STRUCT_OFFSET(struct xpvhv, xhv_max)
-
-#if PERL_VERSION > 12
#define PVHV_keys_ix sv_STRLENp | STRUCT_OFFSET(struct xpvhv, xhv_keys)
-#else
-#define PVHV_keys_ix sv_IVp | STRUCT_OFFSET(struct xpvhv, xhv_keys)
-#endif
# The type checking code in B has always been identical for all SV types,
# irrespective of whether the action is actually defined on that SV.
B::IV::IVX = IV_ivx_ix
B::IV::UVX = IV_uvx_ix
B::NV::NVX = NV_nvx_ix
- B::NV::COP_SEQ_RANGE_LOW = NV_cop_seq_range_low_ix
- B::NV::COP_SEQ_RANGE_HIGH = NV_cop_seq_range_high_ix
- B::NV::PARENT_PAD_INDEX = NV_parent_pad_index_ix
- B::NV::PARENT_FAKELEX_FLAGS = NV_parent_fakelex_flags_ix
B::PV::CUR = PV_cur_ix
B::PV::LEN = PV_len_ix
B::PVMG::SvSTASH = PVMG_stash_ix
SvNV(sv)
B::NV sv
-#if PERL_VERSION < 11
-
-MODULE = B PACKAGE = B::RV PREFIX = Sv
-
-void
-SvRV(sv)
- B::RV sv
- PPCODE:
- PUSHs(make_sv_object(aTHX_ SvRV(sv)));
-
-#else
-
MODULE = B PACKAGE = B::REGEXP
void
B::REGEXP sv
ALIAS:
precomp = 1
+ qr_anoncv = 2
+ compflags = 3
PPCODE:
- if (ix) {
+ if (ix == 1) {
PUSHs(newSVpvn_flags(RX_PRECOMP(sv), RX_PRELEN(sv), SVs_TEMP));
+ } else if (ix == 2) {
+ PUSHs(make_sv_object(aTHX_ (SV *)ReANY(sv)->qr_anoncv));
} else {
dXSTARG;
+ if (ix)
+ PUSHu(RX_COMPFLAGS(sv));
+ else
/* FIXME - can we code this method more efficiently? */
- PUSHi(PTR2IV(sv));
+ PUSHi(PTR2IV(sv));
}
-#endif
-
MODULE = B PACKAGE = B::PV
void
BmPREVIOUS(sv)
B::BM sv
CODE:
-#if PERL_VERSION >= 19
PERL_UNUSED_VAR(sv);
-#endif
RETVAL = BmPREVIOUS(sv);
OUTPUT:
RETVAL
BmRARE(sv)
B::BM sv
CODE:
-#if PERL_VERSION >= 19
PERL_UNUSED_VAR(sv);
-#endif
RETVAL = BmRARE(sv);
OUTPUT:
RETVAL
B::PADLIST
CvPADLIST(cv)
B::CV cv
+ CODE:
+ RETVAL = CvISXSUB(cv) ? NULL : CvPADLIST(cv);
+ OUTPUT:
+ RETVAL
#else
#endif
+SV *
+CvHSCXT(cv)
+ B::CV cv
+ CODE:
+ RETVAL = newSVuv(CvISXSUB(cv) ? PTR2UV(CvHSCXT(cv)) : 0);
+ OUTPUT:
+ RETVAL
+
void
CvXSUB(cv)
B::CV cv
CODE:
ST(0) = make_sv_object(aTHX_ (SV*)CvGV(cv));
-#if PERL_VERSION > 17
-
SV *
NAME_HEK(cv)
B::CV cv
OUTPUT:
RETVAL
-#endif
-
MODULE = B PACKAGE = B::HV PREFIX = Hv
STRLEN
PPCODE:
if (HvUSEDKEYS(hv) > 0) {
HE *he;
+ SSize_t extend_size;
(void)hv_iterinit(hv);
- EXTEND(sp, HvUSEDKEYS(hv) * 2);
+ /* 2*HvUSEDKEYS() should never be big enough to truncate or wrap */
+ assert(HvUSEDKEYS(hv) <= (SSize_t_MAX >> 1));
+ extend_size = (SSize_t)HvUSEDKEYS(hv) * 2;
+ EXTEND(sp, extend_size);
while ((he = hv_iternext(hv))) {
if (HeSVKEY(he)) {
mPUSHs(HeSVKEY(he));
SSize_t
PadlistMAX(padlist)
B::PADLIST padlist
+ ALIAS: B::PADNAMELIST::MAX = 0
+ CODE:
+ PERL_UNUSED_VAR(ix);
+ RETVAL = PadlistMAX(padlist);
+ OUTPUT:
+ RETVAL
+
+B::PADNAMELIST
+PadlistNAMES(padlist)
+ B::PADLIST padlist
void
PadlistARRAY(padlist)
B::PADLIST padlist
PPCODE:
if (PadlistMAX(padlist) >= 0) {
+ dXSTARG;
PAD **padp = PadlistARRAY(padlist);
SSize_t i;
- for (i = 0; i <= PadlistMAX(padlist); i++)
+ sv_setiv(newSVrv(TARG, PadlistNAMES(padlist)
+ ? "B::PADNAMELIST"
+ : "B::NULL"),
+ PTR2IV(PadlistNAMES(padlist)));
+ XPUSHTARG;
+ for (i = 1; i <= PadlistMAX(padlist); i++)
XPUSHs(make_sv_object(aTHX_ (SV *)padp[i]));
}
B::PADLIST padlist
SSize_t idx
PPCODE:
- if (PadlistMAX(padlist) >= 0
- && idx <= PadlistMAX(padlist))
+ if (idx < 0 || idx > PadlistMAX(padlist))
+ XPUSHs(make_sv_object(aTHX_ NULL));
+ else if (!idx) {
+ PL_stack_sp--;
+ PUSHMARK(PL_stack_sp-1);
+ XS_B__PADLIST_NAMES(aTHX_ cv);
+ return;
+ }
+ else
XPUSHs(make_sv_object(aTHX_
(SV *)PadlistARRAY(padlist)[idx]));
- else
- XPUSHs(make_sv_object(aTHX_ NULL));
U32
PadlistREFCNT(padlist)
RETVAL
#endif
+
+MODULE = B PACKAGE = B::PADNAMELIST PREFIX = Padnamelist
+
+void
+PadnamelistARRAY(pnl)
+ B::PADNAMELIST pnl
+ PPCODE:
+ if (PadnamelistMAX(pnl) >= 0) {
+ PADNAME **padp = PadnamelistARRAY(pnl);
+ SSize_t i = 0;
+ for (; i <= PadnamelistMAX(pnl); i++)
+ {
+ SV *rv = sv_newmortal();
+ sv_setiv(newSVrv(rv,padp[i] ? "B::PADNAME" : "B::SPECIAL"),
+ PTR2IV(padp[i]));
+ XPUSHs(rv);
+ }
+ }
+
+B::PADNAME
+PadnamelistARRAYelt(pnl, idx)
+ B::PADNAMELIST pnl
+ SSize_t idx
+ CODE:
+ if (idx < 0 || idx > PadnamelistMAX(pnl))
+ RETVAL = NULL;
+ else
+ RETVAL = PadnamelistARRAY(pnl)[idx];
+ OUTPUT:
+ RETVAL
+
+MODULE = B PACKAGE = B::PADNAME PREFIX = Padname
+
+#define PN_type_ix \
+ sv_SVp | STRUCT_OFFSET(struct padname,xpadn_type_u.xpadn_typestash)
+#define PN_ourstash_ix \
+ sv_SVp | STRUCT_OFFSET(struct padname,xpadn_ourstash)
+#define PN_len_ix \
+ sv_U8p | STRUCT_OFFSET(struct padname,xpadn_len)
+#define PN_refcnt_ix \
+ sv_U32p | STRUCT_OFFSET(struct padname, xpadn_refcnt)
+#define PN_cop_seq_range_low_ix \
+ sv_U32p | STRUCT_OFFSET(struct padname, xpadn_low)
+#define PN_cop_seq_range_high_ix \
+ sv_U32p | STRUCT_OFFSET(struct padname, xpadn_high)
+#define PNL_refcnt_ix \
+ sv_U32p | STRUCT_OFFSET(struct padnamelist, xpadnl_refcnt)
+#define PL_id_ix \
+ sv_U32p | STRUCT_OFFSET(struct padlist, xpadl_id)
+#define PL_outid_ix \
+ sv_U32p | STRUCT_OFFSET(struct padlist, xpadl_outid)
+
+
+void
+PadnameTYPE(pn)
+ B::PADNAME pn
+ ALIAS:
+ B::PADNAME::TYPE = PN_type_ix
+ B::PADNAME::OURSTASH = PN_ourstash_ix
+ B::PADNAME::LEN = PN_len_ix
+ B::PADNAME::REFCNT = PN_refcnt_ix
+ B::PADNAME::COP_SEQ_RANGE_LOW = PN_cop_seq_range_low_ix
+ B::PADNAME::COP_SEQ_RANGE_HIGH = PN_cop_seq_range_high_ix
+ B::PADNAMELIST::REFCNT = PNL_refcnt_ix
+ B::PADLIST::id = PL_id_ix
+ B::PADLIST::outid = PL_outid_ix
+ PREINIT:
+ char *ptr;
+ SV *ret;
+ PPCODE:
+ ptr = (ix & 0xFFFF) + (char *)pn;
+ switch ((U8)(ix >> 16)) {
+ case (U8)(sv_SVp >> 16):
+ ret = make_sv_object(aTHX_ *((SV **)ptr));
+ break;
+ case (U8)(sv_U32p >> 16):
+ ret = sv_2mortal(newSVuv(*((U32 *)ptr)));
+ break;
+ case (U8)(sv_U8p >> 16):
+ ret = sv_2mortal(newSVuv(*((U8 *)ptr)));
+ break;
+ default:
+ NOT_REACHED;
+ }
+ ST(0) = ret;
+ XSRETURN(1);
+
+SV *
+PadnamePV(pn)
+ B::PADNAME pn
+ PREINIT:
+ dXSTARG;
+ PPCODE:
+ PERL_UNUSED_ARG(RETVAL);
+ sv_setpvn(TARG, PadnamePV(pn), PadnameLEN(pn));
+ SvUTF8_on(TARG);
+ XPUSHTARG;
+
+BOOT:
+{
+ /* Uses less memory than an ALIAS. */
+ GV *gv = gv_fetchpvs("B::PADNAME::TYPE", 1, SVt_PVGV);
+ sv_setsv((SV *)gv_fetchpvs("B::PADNAME::SvSTASH",1,SVt_PVGV),(SV *)gv);
+ sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PROTOCV",1,SVt_PVGV),(SV *)gv);
+ sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PVX",1,SVt_PVGV),
+ (SV *)gv_fetchpvs("B::PADNAME::PV" ,1,SVt_PVGV));
+ sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PARENT_PAD_INDEX" ,1,SVt_PVGV),
+ (SV *)gv_fetchpvs("B::PADNAME::COP_SEQ_RANGE_LOW",1,
+ SVt_PVGV));
+ sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PARENT_FAKELEX_FLAGS",1,
+ SVt_PVGV),
+ (SV *)gv_fetchpvs("B::PADNAME::COP_SEQ_RANGE_HIGH" ,1,
+ SVt_PVGV));
+}
+
+U32
+PadnameFLAGS(pn)
+ B::PADNAME pn
+ CODE:
+ RETVAL = PadnameFLAGS(pn);
+ /* backward-compatibility hack, which should be removed if the
+ flags field becomes large enough to hold SVf_FAKE (and
+ PADNAMEt_OUTER should be renumbered to match SVf_FAKE) */
+ STATIC_ASSERT_STMT(SVf_FAKE >= 1<<(sizeof(PadnameFLAGS((B__PADNAME)NULL)) * 8));
+ if (PadnameOUTER(pn))
+ RETVAL |= SVf_FAKE;
+ OUTPUT:
+ RETVAL
https://perl5.git.perl.org / perl5.git / blobdiff