static opclass
cc_opclass(pTHX_ const OP *o)
{
+ bool custom = 0;
+
if (!o)
return OPc_NULL;
return OPc_PADOP;
#endif
- switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
+ if (o->op_type == OP_CUSTOM)
+ custom = 1;
+
+ switch (OP_CLASS(o)) {
case OA_BASEOP:
return OPc_BASEOP;
* 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
+ * the OP is an SVOP (or, under threads, a PADOP),
+ * 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))
+ return (!custom &&
+ (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
+ )
+#if defined(USE_ITHREADS) \
+ && (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION >= 9))
+ ? OPc_PADOP : OPc_PVOP;
+#else
? OPc_SVOP : OPc_PVOP;
+#endif
case OA_LOOP:
return OPc_LOOP;
return OPc_PVOP;
}
warn("can't determine class of operator %s, assuming BASEOP\n",
- PL_op_name[o->op_type]);
+ OP_NAME(o));
return OPc_BASEOP;
}
-static char *
-cc_opclassname(pTHX_ const OP *o)
+static SV *
+make_op_object(pTHX_ const OP *o)
{
- return (char *)opclassnames[cc_opclass(aTHX_ o)];
+ SV *opsv = sv_newmortal();
+ sv_setiv(newSVrv(opsv, opclassnames[cc_opclass(aTHX_ o)]), PTR2IV(o));
+ return opsv;
}
static SV *
-make_sv_object(pTHX_ SV *arg, SV *sv)
+make_sv_object(pTHX_ SV *sv)
{
+ SV *const arg = sv_newmortal();
const char *type = 0;
IV iv;
dMY_CXT;
-
- for (iv = 0; iv < sizeof(specialsv_list)/sizeof(SV*); iv++) {
+
+ for (iv = 0; iv < (IV)(sizeof(specialsv_list)/sizeof(SV*)); iv++) {
if (sv == specialsv_list[iv]) {
type = "B::SPECIAL";
break;
#if PERL_VERSION >= 9
static SV *
-make_temp_object(pTHX_ SV *arg, SV *temp)
+make_temp_object(pTHX_ SV *temp)
{
SV *target;
+ SV *arg = sv_newmortal();
const char *const type = svclassnames[SvTYPE(temp)];
const IV iv = PTR2IV(temp);
}
static SV *
-make_warnings_object(pTHX_ SV *arg, STRLEN *warnings)
+make_warnings_object(pTHX_ const COP *const cop)
{
+ const STRLEN *const warnings = cop->cop_warnings;
const char *type = 0;
dMY_CXT;
IV iv = sizeof(specialsv_list)/sizeof(SV*);
}
}
if (type) {
+ SV *arg = sv_newmortal();
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));
+ return make_temp_object(aTHX_ newSVpvn((char *)(warnings + 1), *warnings));
}
}
static SV *
-make_cop_io_object(pTHX_ SV *arg, COP *cop)
+make_cop_io_object(pTHX_ 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));
+ return make_sv_object(aTHX_ value);
} else {
SvREFCNT_dec(value);
- return make_sv_object(aTHX_ arg, NULL);
+ return make_sv_object(aTHX_ NULL);
}
}
#endif
static SV *
-make_mg_object(pTHX_ SV *arg, MAGIC *mg)
+make_mg_object(pTHX_ MAGIC *mg)
{
+ SV *arg = sv_newmortal();
sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg));
return arg;
}
static SV *
cstring(pTHX_ SV *sv, bool perlstyle)
{
- SV *sstr = newSVpvn("", 0);
+ SV *sstr;
if (!SvOK(sv))
- sv_setpvn(sstr, "0", 1);
- else if (perlstyle && SvUTF8(sv)) {
+ return newSVpvs_flags("0", SVs_TEMP);
+
+ sstr = newSVpvs_flags("\"", SVs_TEMP);
+
+ 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);
+ sv_catpvs(sstr, "\\\"");
else if (*s == '$')
- sv_catpvn(sstr, "\\$", 2);
+ sv_catpvs(sstr, "\\$");
else if (*s == '@')
- sv_catpvn(sstr, "\\@", 2);
+ sv_catpvs(sstr, "\\@");
else if (*s == '\\')
{
if (strchr("nrftax\\",*(s+1)))
sv_catpvn(sstr, s++, 2);
else
- sv_catpvn(sstr, "\\\\", 2);
+ sv_catpvs(sstr, "\\\\");
}
else /* should always be printable */
sv_catpvn(sstr, s, 1);
++s;
}
- sv_catpv(sstr, "\"");
- return sstr;
}
else
{
/* XXX Optimise? */
STRLEN len;
const char *s = SvPV(sv, len);
- sv_catpv(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] == '?') {
- char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
- sprintf(escbuff, "\\%03o", '?');
- sv_catpv(sstr, escbuff);
+ 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 */
- 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);
+ 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);
+ SV *sstr = newSVpvs_flags("'", SVs_TEMP);
const char *s = SvPV_nolen(sv);
+ /* Don't want promotion of a signed -1 char in sprintf args */
+ const unsigned char c = (unsigned char) *s;
- if (*s == '\'')
- sv_catpvn(sstr, "\\'", 2);
- else if (*s == '\\')
- sv_catpvn(sstr, "\\\\", 2);
+ if (c == '\'')
+ sv_catpvs(sstr, "\\'");
+ else if (c == '\\')
+ sv_catpvs(sstr, "\\\\");
#ifdef EBCDIC
- else if (isPRINT(*s))
+ else if (isPRINT(c))
#else
- else if (*s >= ' ' && *s < 127)
+ else if (c >= ' ' && c < 127)
#endif /* EBCDIC */
sv_catpvn(sstr, s, 1);
- else if (*s == '\n')
- sv_catpvn(sstr, "\\n", 2);
- else if (*s == '\r')
- sv_catpvn(sstr, "\\r", 2);
- else if (*s == '\t')
- sv_catpvn(sstr, "\\t", 2);
- else if (*s == '\a')
- sv_catpvn(sstr, "\\a", 2);
- else if (*s == '\b')
- sv_catpvn(sstr, "\\b", 2);
- else if (*s == '\f')
- sv_catpvn(sstr, "\\f", 2);
- else if (*s == '\v')
- sv_catpvn(sstr, "\\v", 2);
+ else if (c == '\n')
+ sv_catpvs(sstr, "\\n");
+ else if (c == '\r')
+ sv_catpvs(sstr, "\\r");
+ else if (c == '\t')
+ sv_catpvs(sstr, "\\t");
+ else if (c == '\a')
+ sv_catpvs(sstr, "\\a");
+ else if (c == '\b')
+ sv_catpvs(sstr, "\\b");
+ else if (c == '\f')
+ sv_catpvs(sstr, "\\f");
+ else if (c == '\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);
- }
- sv_catpvn(sstr, "'", 1);
+ Perl_sv_catpvf(aTHX_ sstr, "\\%03o", c);
+ sv_catpvs(sstr, "'");
return sstr;
}
-static void
-walkoptree(pTHX_ SV *opsv, const 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 SV *
+walkoptree(pTHX_ OP *o, const char *method, SV *ref)
{
dSP;
- OP *o, *kid;
+ OP *kid;
+ SV *object;
+ const char *const classname = opclassnames[cc_opclass(aTHX_ o)];
dMY_CXT;
- if (!SvROK(opsv))
- croak("opsv is not a reference");
- opsv = sv_mortalcopy(opsv);
- o = INT2PTR(OP*,SvIV((SV*)SvRV(opsv)));
+ /* Check that no-one has changed our reference, or is holding a reference
+ to it. */
+ if (SvREFCNT(ref) == 1 && SvROK(ref) && SvTYPE(ref) == SVt_RV
+ && (object = SvRV(ref)) && SvREFCNT(object) == 1
+ && SvTYPE(object) == SVt_PVMG && SvIOK_only(object)
+ && !SvMAGICAL(object) && !SvMAGIC(object) && SvSTASH(object)) {
+ /* Looks good, so rebless it for the class we need: */
+ sv_bless(ref, gv_stashpv(classname, GV_ADD));
+ } else {
+ /* Need to make a new one. */
+ ref = sv_newmortal();
+ object = newSVrv(ref, classname);
+ }
+ sv_setiv(object, PTR2IV(o));
+
if (walkoptree_debug) {
PUSHMARK(sp);
- XPUSHs(opsv);
+ XPUSHs(ref);
PUTBACK;
perl_call_method("walkoptree_debug", G_DISCARD);
}
PUSHMARK(sp);
- XPUSHs(opsv);
+ XPUSHs(ref);
PUTBACK;
perl_call_method(method, G_DISCARD);
if (o && (o->op_flags & OPf_KIDS)) {
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);
+ ref = walkoptree(aTHX_ kid, method, ref);
}
}
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
- )
+ && (kid = PMOP_pmreplroot(cPMOPo)))
{
- sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
- walkoptree(aTHX_ opsv, method);
+ ref = walkoptree(aTHX_ kid, method, ref);
}
+ return ref;
}
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;
break;
o->op_seq = 0;
#endif
- opsv = sv_newmortal();
- sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ (OP*)o)), PTR2IV(o));
- XPUSHs(opsv);
+ XPUSHs(make_op_object(aTHX_ o));
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
+ SP = oplist(aTHX_ PMOP_pmreplstart(cPMOPo), SP);
continue;
case OP_SORT:
if (o->op_flags & OPf_STACKED && o->op_flags & OPf_SPECIAL) {
typedef struct refcounted_he *B__RHE;
#endif
-MODULE = B PACKAGE = B PREFIX = B_
+#ifdef MULTIPLICITY
+# define ASSIGN_COMMON_ALIAS(var) \
+ STMT_START { XSANY.any_i32 = offsetof(struct interpreter, var); } STMT_END
+#else
+# define ASSIGN_COMMON_ALIAS(var) \
+ STMT_START { XSANY.any_ptr = (void *)&PL_##var; } STMT_END
+#endif
+
+/* This needs to be ALIASed in a custom way, hence can't easily be defined as
+ a regular XSUB. */
+static XSPROTO(intrpvar_sv_common); /* prototype to pass -Wmissing-prototypes */
+static XSPROTO(intrpvar_sv_common)
+{
+ dVAR;
+ dXSARGS;
+ SV *ret;
+ if (items != 0)
+ croak_xs_usage(cv, "");
+#ifdef MULTIPLICITY
+ ret = *(SV **)(XSANY.any_i32 + (char *)my_perl);
+#else
+ ret = *(SV **)(XSANY.any_ptr);
+#endif
+ ST(0) = make_sv_object(aTHX_ ret);
+ XSRETURN(1);
+}
+
+#include "const-c.inc"
+
+MODULE = B PACKAGE = B
+
+INCLUDE: const-xs.inc
PROTOTYPES: DISABLE
BOOT:
{
- HV *stash = gv_stashpvn("B", 1, GV_ADD);
- AV *export_ok = perl_get_av("B::EXPORT_OK",TRUE);
+ CV *cv;
+ const char *file = __FILE__;
MY_CXT_INIT;
specialsv_list[0] = Nullsv;
specialsv_list[1] = &PL_sv_undef;
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
-
-B::AV
-B_init_av()
-
-B::AV
-B_check_av()
-
+
+ cv = newXS("B::init_av", intrpvar_sv_common, file);
+ ASSIGN_COMMON_ALIAS(Iinitav);
+ cv = newXS("B::check_av", intrpvar_sv_common, file);
+ ASSIGN_COMMON_ALIAS(Icheckav_save);
#if PERL_VERSION >= 9
-
-B::AV
-B_unitcheck_av()
-
+ cv = newXS("B::unitcheck_av", intrpvar_sv_common, file);
+ ASSIGN_COMMON_ALIAS(Iunitcheckav_save);
#endif
-
-B::AV
-B_begin_av()
-
-B::AV
-B_end_av()
-
-B::GV
-B_inc_gv()
-
+ cv = newXS("B::begin_av", intrpvar_sv_common, file);
+ ASSIGN_COMMON_ALIAS(Ibeginav_save);
+ cv = newXS("B::end_av", intrpvar_sv_common, file);
+ ASSIGN_COMMON_ALIAS(Iendav);
+ cv = newXS("B::main_cv", intrpvar_sv_common, file);
+ ASSIGN_COMMON_ALIAS(Imain_cv);
+ cv = newXS("B::inc_gv", intrpvar_sv_common, file);
+ ASSIGN_COMMON_ALIAS(Iincgv);
+ cv = newXS("B::defstash", intrpvar_sv_common, file);
+ ASSIGN_COMMON_ALIAS(Idefstash);
+ cv = newXS("B::curstash", intrpvar_sv_common, file);
+ ASSIGN_COMMON_ALIAS(Icurstash);
+ cv = newXS("B::formfeed", intrpvar_sv_common, file);
+ ASSIGN_COMMON_ALIAS(Iformfeed);
#ifdef USE_ITHREADS
-
-B::AV
-B_regex_padav()
-
+ cv = newXS("B::regex_padav", intrpvar_sv_common, file);
+ ASSIGN_COMMON_ALIAS(Iregex_padav);
#endif
-
-B::CV
-B_main_cv()
-
-B::OP
-B_main_root()
-
-B::OP
-B_main_start()
+ cv = newXS("B::warnhook", intrpvar_sv_common, file);
+ ASSIGN_COMMON_ALIAS(Iwarnhook);
+ cv = newXS("B::diehook", intrpvar_sv_common, file);
+ ASSIGN_COMMON_ALIAS(Idiehook);
+}
long
-B_amagic_generation()
-
-long
-B_sub_generation()
-
-B::AV
-B_comppadlist()
-
-B::SV
-B_sv_undef()
-
-B::SV
-B_sv_yes()
-
-B::SV
-B_sv_no()
-
-B::HV
-B_curstash()
-
-B::HV
-B_defstash()
-
-U8
-B_dowarn()
+amagic_generation()
+ CODE:
+ RETVAL = PL_amagic_generation;
+ OUTPUT:
+ RETVAL
-B::SV
-B_formfeed()
+void
+comppadlist()
+ PPCODE:
+ PUSHs(make_sv_object(aTHX_ (SV *)(PL_main_cv ? CvPADLIST(PL_main_cv)
+ : CvPADLIST(PL_compcv))));
void
-B_warnhook()
- CODE:
- ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_warnhook);
+sv_undef()
+ ALIAS:
+ sv_no = 1
+ sv_yes = 2
+ PPCODE:
+ PUSHs(make_sv_object(aTHX_ ix > 1 ? &PL_sv_yes
+ : ix < 1 ? &PL_sv_undef
+ : &PL_sv_no));
void
-B_diehook()
- CODE:
- ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_diehook);
+main_root()
+ ALIAS:
+ main_start = 1
+ PPCODE:
+ PUSHs(make_op_object(aTHX_ ix ? PL_main_start : PL_main_root));
-MODULE = B PACKAGE = B
+UV
+sub_generation()
+ ALIAS:
+ dowarn = 1
+ CODE:
+ RETVAL = ix ? PL_dowarn : PL_sub_generation;
+ OUTPUT:
+ RETVAL
void
-walkoptree(opsv, method)
- SV * opsv
+walkoptree(op, method)
+ B::OP op
const char * method
CODE:
- walkoptree(aTHX_ opsv, method);
+ (void) walkoptree(aTHX_ op, method, &PL_sv_undef);
int
walkoptree_debug(...)
address(sv)
SV * sv
-B::SV
+void
svref_2object(sv)
SV * sv
- CODE:
+ PPCODE:
if (!SvROK(sv))
croak("argument is not a reference");
- RETVAL = (SV*)SvRV(sv);
- OUTPUT:
- RETVAL
+ PUSHs(make_sv_object(aTHX_ SvRV(sv)));
void
opnumber(name)
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]);
}
CODE:
STRLEN len;
U32 hash = 0;
- char hexhash[19]; /* must fit "0xffffffffffffffff" plus trailing \0 */
- const char *s = SvPV(sv, len);
+ const char *s = SvPVbyte(sv, len);
PERL_HASH(hash, s, len);
- sprintf(hexhash, "0x%"UVxf, (UV)hash);
- ST(0) = sv_2mortal(newSVpv(hexhash, 0));
+ ST(0) = sv_2mortal(Perl_newSVpvf(aTHX_ "0x%"UVxf, (UV)hash));
#define cast_I32(foo) (I32)foo
IV
void
minus_c()
+ ALIAS:
+ save_BEGINs = 1
CODE:
- PL_minus_c = TRUE;
+ if (ix)
+ PL_savebegin = TRUE;
+ else
+ 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
+ ALIAS:
+ perlstring = 1
+ cchar = 2
+ PPCODE:
+ PUSHs(ix == 2 ? cchar(aTHX_ sv) : cstring(aTHX_ sv, (bool)ix));
void
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) (char *)PL_op_desc[o->op_type]
-#define OP_targ(o) o->op_targ
-#define OP_type(o) o->op_type
+#define SVp 0x00000
+#define U32p 0x10000
+#define line_tp 0x20000
+#define OPp 0x30000
+#define PADOFFSETp 0x40000
+#define U8p 0x50000
+#define IVp 0x60000
+#define char_pp 0x70000
+
+#define OP_next_ix OPp | offsetof(struct op, op_next)
+#define OP_sibling_ix OPp | offsetof(struct op, op_sibling)
+#define UNOP_first_ix OPp | offsetof(struct unop, op_first)
+#define BINOP_last_ix OPp | offsetof(struct binop, op_last)
+#define LOGOP_other_ix OPp | offsetof(struct logop, op_other)
+#if PERL_VERSION >= 9
+# define PMOP_pmreplstart_ix \
+ OPp | offsetof(struct pmop, op_pmstashstartu.op_pmreplstart)
+#else
+# define PMOP_pmreplstart_ix OPp | offsetof(struct pmop, op_pmreplstart)
+#endif
+#define LOOP_redoop_ix OPp | offsetof(struct loop, op_redoop)
+#define LOOP_nextop_ix OPp | offsetof(struct loop, op_nextop)
+#define LOOP_lastop_ix OPp | offsetof(struct loop, op_lastop)
+
+#define OP_targ_ix PADOFFSETp | offsetof(struct op, op_targ)
+#define OP_flags_ix U8p | offsetof(struct op, op_flags)
+#define OP_private_ix U8p | offsetof(struct op, op_private)
+
+#define PMOP_pmflags_ix U32p | offsetof(struct pmop, op_pmflags)
+
+#ifdef USE_ITHREADS
+#define PMOP_pmoffset_ix IVp | offsetof(struct pmop, op_pmoffset)
+#endif
+
+# Yes, B::SV::sv and B::SV::gv really do end up generating identical code.
+#define SVOP_sv_ix SVp | offsetof(struct svop, op_sv)
+#define SVOP_gv_ix SVp | offsetof(struct svop, op_sv)
+
+#define PADOP_padix_ix PADOFFSETp | offsetof(struct padop, op_padix)
+
+#define COP_seq_ix U32p | offsetof(struct cop, cop_seq)
+#define COP_line_ix line_tp | offsetof(struct cop, cop_line)
#if PERL_VERSION >= 9
-# define OP_opt(o) o->op_opt
+#define COP_hints_ix U32p | offsetof(struct cop, cop_hints)
+#else
+#define COP_hints_ix U8p | offsetof(struct cop, op_private)
+#endif
+
+#ifdef USE_ITHREADS
+#define COP_stashpv_ix char_pp | offsetof(struct cop, cop_stashpv)
+#define COP_file_ix char_pp | offsetof(struct cop, cop_file)
#else
-# define OP_seq(o) o->op_seq
+#define COP_stash_ix SVp | offsetof(struct cop, cop_stash)
+#define COP_filegv_ix SVp | offsetof(struct cop, cop_filegv)
#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_
+MODULE = B PACKAGE = B::OP
size_t
-OP_size(o)
+size(o)
B::OP o
CODE:
RETVAL = opsizes[cc_opclass(aTHX_ o)];
OUTPUT:
RETVAL
-B::OP
-OP_next(o)
+# The type checking code in B has always been identical for all OP types,
+# irrespective of whether the action is actually defined on that OP.
+# We should fix this
+void
+next(o)
B::OP o
+ ALIAS:
+ B::OP::next = OP_next_ix
+ B::OP::sibling = OP_sibling_ix
+ B::OP::targ = OP_targ_ix
+ B::OP::flags = OP_flags_ix
+ B::OP::private = OP_private_ix
+ B::UNOP::first = UNOP_first_ix
+ B::BINOP::last = BINOP_last_ix
+ B::LOGOP::other = LOGOP_other_ix
+ B::PMOP::pmreplstart = PMOP_pmreplstart_ix
+ B::LOOP::redoop = LOOP_redoop_ix
+ B::LOOP::nextop = LOOP_nextop_ix
+ B::LOOP::lastop = LOOP_lastop_ix
+ B::PMOP::pmflags = PMOP_pmflags_ix
+ B::SVOP::sv = SVOP_sv_ix
+ B::SVOP::gv = SVOP_gv_ix
+ B::PADOP::padix = PADOP_padix_ix
+ B::COP::cop_seq = COP_seq_ix
+ B::COP::line = COP_line_ix
+ B::COP::hints = COP_hints_ix
+ PREINIT:
+ char *ptr;
+ SV *ret;
+ PPCODE:
+ ptr = (ix & 0xFFFF) + (char *)o;
+ switch ((U8)(ix >> 16)) {
+ case (U8)(OPp >> 16):
+ ret = make_op_object(aTHX_ *((OP **)ptr));
+ break;
+ case (U8)(PADOFFSETp >> 16):
+ ret = sv_2mortal(newSVuv(*((PADOFFSET*)ptr)));
+ break;
+ case (U8)(U8p >> 16):
+ ret = sv_2mortal(newSVuv(*((U8*)ptr)));
+ break;
+ case (U8)(U32p >> 16):
+ ret = sv_2mortal(newSVuv(*((U32*)ptr)));
+ break;
+ case (U8)(SVp >> 16):
+ ret = make_sv_object(aTHX_ *((SV **)ptr));
+ break;
+ case (U8)(line_tp >> 16):
+ ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
+ break;
+#ifdef USE_ITHREADS
+ case (U8)(IVp >> 16):
+ ret = sv_2mortal(newSViv(*((IV*)ptr)));
+ break;
+ case (U8)(char_pp >> 16):
+ ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
+ break;
+#endif
+ default:
+ croak("Illegal alias 0x%08x for B::*next", (unsigned)ix);
-B::OP
-OP_sibling(o)
- B::OP o
+ }
+ ST(0) = ret;
+ XSRETURN(1);
char *
-OP_name(o)
+name(o)
B::OP o
+ ALIAS:
+ desc = 1
CODE:
- RETVAL = (char *)PL_op_name[o->op_type];
+ RETVAL = (char *)(ix ? OP_DESC(o) : OP_NAME(o));
OUTPUT:
RETVAL
-
void
-OP_ppaddr(o)
+ppaddr(o)
B::OP o
PREINIT:
int i;
- SV *sv = sv_newmortal();
+ SV *sv = newSVpvs_flags("PL_ppaddr[OP_", SVs_TEMP);
CODE:
- 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, "]");
+ sv_catpvs(sv, "]");
ST(0) = sv;
-char *
-OP_desc(o)
- B::OP o
-
-PADOFFSET
-OP_targ(o)
- B::OP o
-
-U16
-OP_type(o)
- B::OP o
-
#if PERL_VERSION >= 9
-
-U8
-OP_opt(o)
+# These 3 are all bitfields, so we can't take their addresses.
+UV
+type(o)
B::OP o
+ ALIAS:
+ opt = 1
+ spare = 2
+ CODE:
+ switch(ix) {
+ case 1:
+ RETVAL = o->op_opt;
+ break;
+ case 2:
+ RETVAL = o->op_spare;
+ break;
+ default:
+ RETVAL = o->op_type;
+ }
+ OUTPUT:
+ RETVAL
#else
-U16
-OP_seq(o)
- B::OP o
-
-#endif
-
-U8
-OP_flags(o)
- B::OP o
-
-U8
-OP_private(o)
- B::OP o
-
-#if PERL_VERSION >= 9
-
-U8
-OP_spare(o)
+UV
+type(o)
B::OP o
+ ALIAS:
+ seq = 1
+ CODE:
+ switch(ix) {
+ case 1:
+ RETVAL = o->op_seq;
+ break;
+ default:
+ RETVAL = o->op_type;
+ }
+ OUTPUT:
+ RETVAL
#endif
void
-OP_oplist(o)
+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_
-
-B::OP
-UNOP_first(o)
- B::UNOP o
-
-#define BINOP_last(o) o->op_last
-
-MODULE = B PACKAGE = B::BINOP PREFIX = BINOP_
-
-B::OP
-BINOP_last(o)
- B::BINOP o
-
-#define LOGOP_other(o) o->op_other
-
-MODULE = B PACKAGE = B::LOGOP PREFIX = LOGOP_
-
-B::OP
-LOGOP_other(o)
- B::LOGOP o
-
-MODULE = B PACKAGE = B::LISTOP PREFIX = LISTOP_
+MODULE = B PACKAGE = B::LISTOP
U32
-LISTOP_children(o)
+children(o)
B::LISTOP o
OP * kid = NO_INIT
int i = NO_INIT
i++;
RETVAL = i;
OUTPUT:
- RETVAL
-
-#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
+ RETVAL
MODULE = B PACKAGE = B::PMOP PREFIX = PMOP_
B::PMOP o
OP * root = NO_INIT
CODE:
- ST(0) = sv_newmortal();
root = o->op_pmreplroot;
/* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */
if (o->op_type == OP_PUSHRE) {
+ ST(0) = sv_newmortal();
# ifdef USE_ITHREADS
sv_setiv(ST(0), INT2PTR(PADOFFSET,root) );
# else
# endif
}
else {
- sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root));
+ ST(0) = make_op_object(aTHX_ root);
}
#else
PMOP_pmreplroot(o)
B::PMOP o
CODE:
- ST(0) = sv_newmortal();
if (o->op_type == OP_PUSHRE) {
# ifdef USE_ITHREADS
+ ST(0) = sv_newmortal();
sv_setiv(ST(0), o->op_pmreplrootu.op_pmtargetoff);
# else
GV *const target = o->op_pmreplrootu.op_pmtargetgv;
+ ST(0) = sv_newmortal();
sv_setiv(newSVrv(ST(0), target ?
svclassnames[SvTYPE((SV*)target)] : "B::SV"),
PTR2IV(target));
}
else {
OP *const root = o->op_pmreplrootu.op_pmreplroot;
- sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)),
- PTR2IV(root));
+ ST(0) = make_op_object(aTHX_ 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
+#define PMOP_pmstashpv(o) PmopSTASHPV(o);
char*
PMOP_pmstashpv(o)
#else
-B::HV
+void
PMOP_pmstash(o)
B::PMOP o
+ PPCODE:
+ PUSHs(make_sv_object(aTHX_ (SV *) PmopSTASH(o)));
#endif
-U32
-PMOP_pmflags(o)
- B::PMOP o
-
#if PERL_VERSION < 9
+void
+PMOP_pmnext(o)
+ B::PMOP o
+ PPCODE:
+ PUSHs(make_op_object(aTHX_ o->op_pmnext));
+
U32
PMOP_pmpermflags(o)
B::PMOP o
void
PMOP_precomp(o)
B::PMOP o
- REGEXP * rx = NO_INIT
+ PREINIT:
+ dXSI32;
+ REGEXP *rx;
CODE:
- ST(0) = sv_newmortal();
rx = PM_GETRE(o);
- if (rx)
- 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));
-
+ if (rx) {
+#if PERL_VERSION >= 9
+ if (ix) {
+ sv_setuv(ST(0), RX_EXTFLAGS(rx));
+ } else
#endif
+ {
+ sv_setpvn(ST(0), RX_PRECOMP(rx), RX_PRELEN(rx));
+ }
+ }
-#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
-
-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)
+BOOT:
+{
+ CV *cv;
+#ifdef USE_ITHREADS
+ cv = newXS("B::PMOP::pmoffset", XS_B__OP_next, __FILE__);
+ XSANY.any_i32 = PMOP_pmoffset_ix;
+ cv = newXS("B::COP::stashpv", XS_B__OP_next, __FILE__);
+ XSANY.any_i32 = COP_stashpv_ix;
+ cv = newXS("B::COP::file", XS_B__OP_next, __FILE__);
+ XSANY.any_i32 = COP_file_ix;
+#else
+ cv = newXS("B::COP::stash", XS_B__OP_next, __FILE__);
+ XSANY.any_i32 = COP_stash_ix;
+ cv = newXS("B::COP::filegv", XS_B__OP_next, __FILE__);
+ XSANY.any_i32 = COP_filegv_ix;
+#endif
+#if PERL_VERSION >= 9
+ cv = newXS("B::PMOP::reflags", XS_B__PMOP_precomp, __FILE__);
+ XSANY.any_i32 = 1;
+#endif
+}
-MODULE = B PACKAGE = B::PADOP PREFIX = PADOP_
+MODULE = B PACKAGE = B::PADOP
-PADOFFSET
-PADOP_padix(o)
+void
+sv(o)
B::PADOP o
+ PREINIT:
+ SV *ret;
+ ALIAS:
+ gv = 1
+ PPCODE:
+ /* It happens that the output typemaps for B::SV and B::GV are
+ identical. The "smarts" are in make_sv_object(), which determines
+ which class to use based on SvTYPE(), rather than anything baked in
+ at compile time. */
+ if (o->op_padix) {
+ ret = PAD_SVl(o->op_padix);
+ if (ix && SvTYPE(ret) != SVt_PVGV)
+ ret = NULL;
+ } else {
+ ret = NULL;
+ }
+ PUSHs(make_sv_object(aTHX_ ret));
-B::SV
-PADOP_sv(o)
- B::PADOP o
-
-B::GV
-PADOP_gv(o)
- B::PADOP o
-
-MODULE = B PACKAGE = B::PVOP PREFIX = PVOP_
+MODULE = B PACKAGE = B::PVOP
void
-PVOP_pv(o)
+pv(o)
B::PVOP o
CODE:
/*
* OP_TRANS uses op_pv to point to a table of 256 or >=258 shorts
* whereas other PVOPs point to a null terminated string.
*/
- if (o->op_type == OP_TRANS &&
+ if ((o->op_type == OP_TRANS || o->op_type == OP_TRANSR) &&
(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)));
+ 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)));
+ else if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
+ ST(0) = newSVpvn_flags(o->op_pv, 256 * sizeof(short), SVs_TEMP);
}
else
- ST(0) = sv_2mortal(newSVpv(o->op_pv, 0));
-
-#define LOOP_redoop(o) o->op_redoop
-#define LOOP_nextop(o) o->op_nextop
-#define LOOP_lastop(o) o->op_lastop
-
-MODULE = B PACKAGE = B::LOOP PREFIX = LOOP_
-
-
-B::OP
-LOOP_redoop(o)
- B::LOOP o
-
-B::OP
-LOOP_nextop(o)
- B::LOOP o
+ ST(0) = newSVpvn_flags(o->op_pv, strlen(o->op_pv), SVs_TEMP);
-B::OP
-LOOP_lastop(o)
- B::LOOP o
-
-#define COP_label(o) o->cop_label
-#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_label(o) CopLABEL(o)
#define COP_arybase(o) CopARYBASE_get(o)
-#define COP_line(o) CopLINE(o)
-#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_
-char *
+const char *
COP_label(o)
B::COP o
-char *
-COP_stashpv(o)
- B::COP o
+# Both pairs of accessors are provided for both ithreads and not, but for each,
+# one pair is direct structure access, and 1 pair "faked up" with a more complex
+# macro. We implement the direct structure access pair using the common code
+# above (B::OP::next)
+
+#ifdef USE_ITHREADS
-B::HV
+void
COP_stash(o)
B::COP o
+ ALIAS:
+ filegv = 1
+ PPCODE:
+ PUSHs(make_sv_object(aTHX_
+ ix ? (SV *)CopFILEGV(o) : (SV *)CopSTASH(o)));
+
+#else
char *
-COP_file(o)
+COP_stashpv(o)
B::COP o
+ ALIAS:
+ file = 1
+ CODE:
+ RETVAL = ix ? CopFILE(o) : CopSTASHPV(o);
+ OUTPUT:
+ RETVAL
-B::GV
-COP_filegv(o)
- B::COP o
-
-
-U32
-COP_cop_seq(o)
- B::COP o
+#endif
I32
COP_arybase(o)
B::COP o
-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);
+ ALIAS:
+ io = 1
+ PPCODE:
+#if PERL_VERSION >= 9
+ ST(0) = ix ? make_cop_io_object(aTHX_ o) : make_warnings_object(aTHX_ o);
+#else
+ ST(0) = make_sv_object(aTHX_ ix ? o->cop_io : o->cop_warnings);
+#endif
XSRETURN(1);
-void
-COP_io(o)
- B::COP o
- PPCODE:
- ST(0) = make_cop_io_object(aTHX_ sv_newmortal(), o);
- XSRETURN(1);
+#if PERL_VERSION >= 9
B::RHE
COP_hints_hash(o)
B::COP o
CODE:
- RETVAL = o->cop_hints_hash;
+ 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
-SvREFCNT(sv)
- B::SV sv
-
-U32
-SvFLAGS(sv)
- B::SV sv
-
-U32
-SvPOK(sv)
- B::SV sv
+#define MAGICAL_FLAG_BITS (SVs_GMG|SVs_SMG|SVs_RMG)
U32
-SvROK(sv)
+REFCNT(sv)
B::SV sv
+ ALIAS:
+ FLAGS = 0xFFFFFFFF
+ SvTYPE = SVTYPEMASK
+ POK = SVf_POK
+ ROK = SVf_ROK
+ MAGICAL = MAGICAL_FLAG_BITS
+ CODE:
+ RETVAL = ix ? (SvFLAGS(sv) & (U32)ix) : SvREFCNT(sv);
+ OUTPUT:
+ RETVAL
-U32
-SvMAGICAL(sv)
+void
+object_2svref(sv)
B::SV sv
-
+ PPCODE:
+ ST(0) = sv_2mortal(newRV(sv));
+ XSRETURN(1);
+
MODULE = B PACKAGE = B::IV PREFIX = Sv
IV
SvIV(sv)
B::IV sv
-IV
-SvIVX(sv)
- B::IV sv
+MODULE = B PACKAGE = B::IV
-UV
-SvUVX(sv)
- B::IV sv
-
+#define sv_SVp 0x00000
+#define sv_IVp 0x10000
+#define sv_UVp 0x20000
+#define sv_STRLENp 0x30000
+#define sv_U32p 0x40000
+#define sv_U8p 0x50000
+#define sv_char_pp 0x60000
+#define sv_NVp 0x70000
+#define sv_char_p 0x80000
+#define sv_SSize_tp 0x90000
+#define sv_I32p 0xA0000
+#define sv_U16p 0xB0000
+
+#define IV_ivx_ix sv_IVp | offsetof(struct xpviv, xiv_iv)
+#define IV_uvx_ix sv_UVp | offsetof(struct xpvuv, xuv_uv)
+#define NV_nvx_ix sv_NVp | offsetof(struct xpvnv, xnv_u.xnv_nv)
+
+#if PERL_VERSION >= 10
+#define NV_cop_seq_range_low_ix \
+ sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
+#define NV_cop_seq_range_high_ix \
+ sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
+#define NV_parent_pad_index_ix \
+ sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
+#define NV_parent_fakelex_flags_ix \
+ sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
+#else
+#define NV_cop_seq_range_low_ix \
+ sv_NVp | offsetof(struct xpvnv, xnv_nv)
+#define NV_cop_seq_range_high_ix \
+ sv_UVp | offsetof(struct xpvnv, xuv_uv)
+#define NV_parent_pad_index_ix \
+ sv_NVp | offsetof(struct xpvnv, xnv_nv)
+#define NV_parent_fakelex_flags_ix \
+ sv_UVp | offsetof(struct xpvnv, xuv_uv)
+#endif
-MODULE = B PACKAGE = B::IV
+#define PV_cur_ix sv_STRLENp | offsetof(struct xpv, xpv_cur)
+#define PV_len_ix sv_STRLENp | offsetof(struct xpv, xpv_len)
-#define needs64bits(sv) ((I32)SvIVX(sv) != SvIVX(sv))
+#define PVMG_stash_ix sv_SVp | offsetof(struct xpvmg, xmg_stash)
-int
-needs64bits(sv)
- B::IV sv
+#if PERL_VERSION >= 10
+#define PVBM_useful_ix sv_I32p | offsetof(struct xpvgv, xiv_u.xivu_i32)
+#define PVBM_previous_ix sv_U32p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_previous)
+#define PVBM_rare_ix sv_U8p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_rare)
+#else
+#define PVBM_useful_ix sv_I32p | offsetof(struct xpvbm, xbm_useful)
+#define PVBM_previous_ix sv_U16p | offsetof(struct xpvbm, xbm_previous)
+#define PVBM_rare_ix sv_U8p | offsetof(struct xpvbm, xbm_rare)
+#endif
+
+#define PVLV_targoff_ix sv_U32p | offsetof(struct xpvlv, xlv_targoff)
+#define PVLV_targlen_ix sv_U32p | offsetof(struct xpvlv, xlv_targlen)
+#define PVLV_targ_ix sv_SVp | offsetof(struct xpvlv, xlv_targ)
+#define PVLV_type_ix sv_char_p | offsetof(struct xpvlv, xlv_type)
+
+#if PERL_VERSION >= 10
+#define PVGV_stash_ix sv_SVp | offsetof(struct xpvgv, xnv_u.xgv_stash)
+#define PVGV_flags_ix sv_STRLENp | offsetof(struct xpvgv, xpv_cur)
+#define PVIO_lines_ix sv_IVp | offsetof(struct xpvio, xiv_iv)
+#else
+#define PVGV_stash_ix sv_SVp | offsetof(struct xpvgv, xgv_stash)
+#define PVGV_flags_ix sv_U8p | offsetof(struct xpvgv, xgv_flags)
+#define PVIO_lines_ix sv_IVp | offsetof(struct xpvio, xio_lines)
+#endif
+
+#define PVIO_page_ix sv_IVp | offsetof(struct xpvio, xio_page)
+#define PVIO_page_len_ix sv_IVp | offsetof(struct xpvio, xio_page_len)
+#define PVIO_lines_left_ix sv_IVp | offsetof(struct xpvio, xio_lines_left)
+#define PVIO_top_name_ix sv_char_pp | offsetof(struct xpvio, xio_top_name)
+#define PVIO_top_gv_ix sv_SVp | offsetof(struct xpvio, xio_top_gv)
+#define PVIO_fmt_name_ix sv_char_pp | offsetof(struct xpvio, xio_fmt_name)
+#define PVIO_fmt_gv_ix sv_SVp | offsetof(struct xpvio, xio_fmt_gv)
+#define PVIO_bottom_name_ix sv_char_pp | offsetof(struct xpvio, xio_bottom_name)
+#define PVIO_bottom_gv_ix sv_SVp | offsetof(struct xpvio, xio_bottom_gv)
+#define PVIO_type_ix sv_char_p | offsetof(struct xpvio, xio_type)
+#define PVIO_flags_ix sv_U8p | offsetof(struct xpvio, xio_flags)
+
+#define PVAV_max_ix sv_SSize_tp | offsetof(struct xpvav, xav_max)
+
+#define PVFM_lines_ix sv_IVp | offsetof(struct xpvfm, xfm_lines)
+
+#define PVCV_stash_ix sv_SVp | offsetof(struct xpvcv, xcv_stash)
+#define PVCV_gv_ix sv_SVp | offsetof(struct xpvcv, xcv_gv)
+#define PVCV_file_ix sv_char_pp | offsetof(struct xpvcv, xcv_file)
+#define PVCV_depth_ix sv_I32p | offsetof(struct xpvcv, xcv_depth)
+#define PVCV_padlist_ix sv_SVp | offsetof(struct xpvcv, xcv_padlist)
+#define PVCV_outside_ix sv_SVp | offsetof(struct xpvcv, xcv_outside)
+#define PVCV_outside_seq_ix sv_U32p | offsetof(struct xpvcv, xcv_outside_seq)
+#define PVCV_flags_ix sv_U16p | offsetof(struct xpvcv, xcv_flags)
+
+#define PVHV_max_ix sv_STRLENp | offsetof(struct xpvhv, xhv_max)
+
+#if PERL_VERSION > 12
+#define PVHV_keys_ix sv_STRLENp | offsetof(struct xpvhv, xhv_keys)
+#else
+#define PVHV_keys_ix sv_IVp | offsetof(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.
+# We should fix this
+void
+IVX(sv)
+ B::SV sv
+ ALIAS:
+ 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
+ B::PVLV::TARGOFF = PVLV_targoff_ix
+ B::PVLV::TARGLEN = PVLV_targlen_ix
+ B::PVLV::TARG = PVLV_targ_ix
+ B::PVLV::TYPE = PVLV_type_ix
+ B::GV::STASH = PVGV_stash_ix
+ B::GV::GvFLAGS = PVGV_flags_ix
+ B::BM::USEFUL = PVBM_useful_ix
+ B::BM::PREVIOUS = PVBM_previous_ix
+ B::BM::RARE = PVBM_rare_ix
+ B::IO::LINES = PVIO_lines_ix
+ B::IO::PAGE = PVIO_page_ix
+ B::IO::PAGE_LEN = PVIO_page_len_ix
+ B::IO::LINES_LEFT = PVIO_lines_left_ix
+ B::IO::TOP_NAME = PVIO_top_name_ix
+ B::IO::TOP_GV = PVIO_top_gv_ix
+ B::IO::FMT_NAME = PVIO_fmt_name_ix
+ B::IO::FMT_GV = PVIO_fmt_gv_ix
+ B::IO::BOTTOM_NAME = PVIO_bottom_name_ix
+ B::IO::BOTTOM_GV = PVIO_bottom_gv_ix
+ B::IO::IoTYPE = PVIO_type_ix
+ B::IO::IoFLAGS = PVIO_flags_ix
+ B::AV::MAX = PVAV_max_ix
+ B::FM::LINES = PVFM_lines_ix
+ B::CV::STASH = PVCV_stash_ix
+ B::CV::GV = PVCV_gv_ix
+ B::CV::FILE = PVCV_file_ix
+ B::CV::DEPTH = PVCV_depth_ix
+ B::CV::PADLIST = PVCV_padlist_ix
+ B::CV::OUTSIDE = PVCV_outside_ix
+ B::CV::OUTSIDE_SEQ = PVCV_outside_seq_ix
+ B::CV::CvFLAGS = PVCV_flags_ix
+ B::HV::MAX = PVHV_max_ix
+ B::HV::KEYS = PVHV_keys_ix
+ PREINIT:
+ char *ptr;
+ SV *ret;
+ PPCODE:
+ ptr = (ix & 0xFFFF) + (char *)SvANY(sv);
+ switch ((U8)(ix >> 16)) {
+ case (U8)(sv_SVp >> 16):
+ ret = make_sv_object(aTHX_ *((SV **)ptr));
+ break;
+ case (U8)(sv_IVp >> 16):
+ ret = sv_2mortal(newSViv(*((IV *)ptr)));
+ break;
+ case (U8)(sv_UVp >> 16):
+ ret = sv_2mortal(newSVuv(*((UV *)ptr)));
+ break;
+ case (U8)(sv_STRLENp >> 16):
+ ret = sv_2mortal(newSVuv(*((STRLEN *)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;
+ case (U8)(sv_char_pp >> 16):
+ ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
+ break;
+ case (U8)(sv_NVp >> 16):
+ ret = sv_2mortal(newSVnv(*((NV *)ptr)));
+ break;
+ case (U8)(sv_char_p >> 16):
+ ret = newSVpvn_flags((char *)ptr, 1, SVs_TEMP);
+ break;
+ case (U8)(sv_SSize_tp >> 16):
+ ret = sv_2mortal(newSViv(*((SSize_t *)ptr)));
+ break;
+ case (U8)(sv_I32p >> 16):
+ ret = sv_2mortal(newSVuv(*((I32 *)ptr)));
+ break;
+ case (U8)(sv_U16p >> 16):
+ ret = sv_2mortal(newSVuv(*((U16 *)ptr)));
+ break;
+ default:
+ croak("Illegal alias 0x%08x for B::*IVX", (unsigned)ix);
+ }
+ ST(0) = ret;
+ XSRETURN(1);
void
packiv(sv)
B::IV sv
+ ALIAS:
+ needs64bits = 1
CODE:
- if (sizeof(IV) == 8) {
+ if (ix) {
+ ST(0) = boolSV((I32)SvIVX(sv) != SvIVX(sv));
+ } else if (sizeof(IV) == 8) {
U32 wp[2];
const IV iv = SvIVX(sv);
/*
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
SvNV(sv)
B::NV 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
+void
SvRV(sv)
B::RV sv
+ PPCODE:
+ PUSHs(make_sv_object(aTHX_ SvRV(sv)));
-#endif
+#else
-MODULE = B PACKAGE = B::PV PREFIX = Sv
+MODULE = B PACKAGE = B::REGEXP
-char*
-SvPVX(sv)
- B::PV sv
+void
+REGEX(sv)
+ B::REGEXP sv
+ ALIAS:
+ precomp = 1
+ PPCODE:
+ if (ix) {
+ PUSHs(newSVpvn_flags(RX_PRECOMP(sv), RX_PRELEN(sv), SVs_TEMP));
+ } else {
+ dXSTARG;
+ /* FIXME - can we code this method more efficiently? */
+ PUSHi(PTR2IV(sv));
+ }
-B::SV
-SvRV(sv)
+#endif
+
+MODULE = B PACKAGE = B::PV
+
+void
+RV(sv)
B::PV sv
- CODE:
- if( SvROK(sv) ) {
- RETVAL = SvRV(sv);
- }
- else {
+ PPCODE:
+ if (!SvROK(sv))
croak( "argument is not SvROK" );
- }
- OUTPUT:
- RETVAL
+ PUSHs(make_sv_object(aTHX_ SvRV(sv)));
void
-SvPV(sv)
+PV(sv)
B::PV sv
+ ALIAS:
+ PVX = 1
+ PVBM = 2
+ B::BM::TABLE = 3
+ PREINIT:
+ const char *p;
+ STRLEN len = 0;
+ U32 utf8 = 0;
CODE:
- 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))) {
+ if (ix == 3) {
+ p = SvPV(sv, len);
+ /* Boyer-Moore table is just after string and its safety-margin \0 */
+ p += len + PERL_FBM_TABLE_OFFSET;
+ len = 256;
+ } else if (ix == 2) {
+ /* 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. */
+ /* Also, the start pointer has always been SvPVX(sv). Surely it
+ should be SvPVX(sv) + SvCUR(sv)? The code has faithfully been
+ refactored with this behaviour, since PVBM was added in
+ 651aa52ea1faa806. */
+ p = SvPVX_const(sv);
+ len = SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0);
+ } else if (ix) {
+ p = SvPVX(sv);
+ len = strlen(p);
+ } else if (SvPOK(sv)) {
+ len = SvCUR(sv);
+ p = SvPVX_const(sv);
+ utf8 = SvUTF8(sv);
+#if PERL_VERSION < 10
+ /* Before 5.10 (well 931b58fb28fa5ca7), PAD_COMPNAME_GEN was stored
+ in SvCUR(), which meant we had to attempt this special casing
+ to avoid tripping up over variable names in the pads. */
+ if((SvLEN(sv) && len >= 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));
+ len = strlen(p);
}
- SvFLAGS(ST(0)) |= SvUTF8(sv);
+#endif
}
else {
/* XXX for backward compatibility, but should fail */
/* croak( "argument is not SvPOK" ); */
- sv_setpvn(ST(0), NULL, 0);
+ p = NULL;
}
+ ST(0) = newSVpvn_flags(p, len, SVs_TEMP | utf8);
-# 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
-
-STRLEN
-SvCUR(sv)
- B::PV sv
-
-MODULE = B PACKAGE = B::PVMG PREFIX = Sv
+MODULE = B PACKAGE = B::PVMG
void
-SvMAGIC(sv)
+MAGIC(sv)
B::PVMG sv
MAGIC * mg = NO_INIT
PPCODE:
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
- XPUSHs(make_mg_object(aTHX_ sv_newmortal(), mg));
-
-MODULE = B PACKAGE = B::PVMG
-
-B::HV
-SvSTASH(sv)
- B::PVMG sv
-
-MODULE = B PACKAGE = B::REGEXP
+ XPUSHs(make_mg_object(aTHX_ mg));
-#if PERL_VERSION >= 11
-
-IV
-REGEX(sv)
- B::REGEXP sv
- CODE:
- RETVAL = PTR2IV(((struct xregexp *)SvANY(sv))->xrx_regexp);
- OUTPUT:
- RETVAL
-
-SV*
-precomp(sv)
- B::REGEXP sv
- REGEXP* rx = NO_INIT
- CODE:
- rx = ((struct xregexp *)SvANY(sv))->xrx_regexp;
- /* FIXME - UTF-8? And the equivalent precomp methods? */
- RETVAL = newSVpvn( RX_PRECOMP(rx), RX_PRELEN(rx) );
- OUTPUT:
- RETVAL
-
-#endif
-
-#define MgMOREMAGIC(mg) mg->mg_moremagic
-#define MgPRIVATE(mg) mg->mg_private
-#define MgTYPE(mg) mg->mg_type
-#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)
- B::MAGIC mg
+MODULE = B PACKAGE = B::MAGIC
-char
-MgTYPE(mg)
- B::MAGIC mg
-
-U8
-MgFLAGS(mg)
- B::MAGIC mg
-
-B::SV
-MgOBJ(mg)
- B::MAGIC mg
-
-IV
-MgREGEX(mg)
- B::MAGIC mg
- CODE:
- if(mg->mg_type == PERL_MAGIC_qr) {
- 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 == PERL_MAGIC_qr) {
- REGEXP* rx = (REGEXP*)mg->mg_obj;
- RETVAL = Nullsv;
- if( rx )
- RETVAL = newSVpvn( RX_PRECOMP(rx), RX_PRELEN(rx) );
- }
- else {
- croak( "precomp is only meaningful on r-magic" );
- }
- OUTPUT:
- RETVAL
-
-I32
-MgLENGTH(mg)
- B::MAGIC mg
-
void
-MgPTR(mg)
+MOREMAGIC(mg)
B::MAGIC mg
- CODE:
- ST(0) = sv_newmortal();
- if (mg->mg_ptr){
- if (mg->mg_len >= 0){
- sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len);
+ ALIAS:
+ PRIVATE = 1
+ TYPE = 2
+ FLAGS = 3
+ LENGTH = 4
+ OBJ = 5
+ PTR = 6
+ REGEX = 7
+ precomp = 8
+ PPCODE:
+ switch (ix) {
+ case 0:
+ XPUSHs(mg->mg_moremagic ? make_mg_object(aTHX_ mg->mg_moremagic)
+ : &PL_sv_undef);
+ break;
+ case 1:
+ mPUSHu(mg->mg_private);
+ break;
+ case 2:
+ PUSHs(newSVpvn_flags(&(mg->mg_type), 1, SVs_TEMP));
+ break;
+ case 3:
+ mPUSHu(mg->mg_flags);
+ break;
+ case 4:
+ mPUSHi(mg->mg_len);
+ break;
+ case 5:
+ PUSHs(make_sv_object(aTHX_ mg->mg_obj));
+ break;
+ case 6:
+ if (mg->mg_ptr) {
+ if (mg->mg_len >= 0) {
+ PUSHs(newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP));
} else if (mg->mg_len == HEf_SVKEY) {
- ST(0) = make_sv_object(aTHX_
- sv_newmortal(), (SV*)mg->mg_ptr);
- }
+ PUSHs(make_sv_object(aTHX_ (SV*)mg->mg_ptr));
+ } else
+ PUSHs(sv_newmortal());
+ } else
+ PUSHs(sv_newmortal());
+ break;
+ case 7:
+ if(mg->mg_type == PERL_MAGIC_qr) {
+ mPUSHi(PTR2IV(mg->mg_obj));
+ } else {
+ croak("REGEX is only meaningful on r-magic");
+ }
+ break;
+ case 8:
+ if (mg->mg_type == PERL_MAGIC_qr) {
+ REGEXP *rx = (REGEXP *)mg->mg_obj;
+ PUSHs(newSVpvn_flags(rx ? RX_PRECOMP(rx) : NULL,
+ rx ? RX_PRELEN(rx) : 0, SVs_TEMP));
+ } else {
+ croak( "precomp is only meaningful on r-magic" );
+ }
+ break;
}
-MODULE = B PACKAGE = B::PVLV PREFIX = Lv
-
-U32
-LvTARGOFF(sv)
- B::PVLV sv
-
-U32
-LvTARGLEN(sv)
- B::PVLV sv
-
-char
-LvTYPE(sv)
- B::PVLV sv
-
-B::SV
-LvTARG(sv)
- B::PVLV sv
-
-MODULE = B PACKAGE = B::BM PREFIX = Bm
-
-I32
-BmUSEFUL(sv)
- B::BM sv
-
-U32
-BmPREVIOUS(sv)
- B::BM sv
-
-U8
-BmRARE(sv)
- B::BM sv
-
-void
-BmTABLE(sv)
- B::BM sv
- STRLEN len = NO_INIT
- char * str = NO_INIT
- CODE:
- str = SvPV(sv, len);
- /* Boyer-Moore table is just after string and its safety-margin \0 */
- ST(0) = sv_2mortal(newSVpvn(str + len + PERL_FBM_TABLE_OFFSET, 256));
-
MODULE = B PACKAGE = B::GV PREFIX = Gv
void
GvNAME(gv)
B::GV gv
+ ALIAS:
+ FILE = 1
+ B::HV::NAME = 2
CODE:
- ST(0) = sv_2mortal(newSVpvn(GvNAME(gv), GvNAMELEN(gv)));
+#if PERL_VERSION >= 10
+ ST(0) = sv_2mortal(newSVhek(!ix ? GvNAME_HEK(gv)
+ : (ix == 1 ? GvFILE_HEK(gv)
+ : HvNAME_HEK((HV *)gv))));
+#else
+ ST(0) = !ix ? newSVpvn_flags(GvNAME(gv), GvNAMELEN(gv), SVs_TEMP)
+ : sv_2mortal(newSVpv(ix == 1 ? GvFILE(gv) : HvNAME((HV *)gv), 0))
+#endif
bool
is_empty(gv)
B::GV gv
+ ALIAS:
+ isGV_with_GP = 1
CODE:
- RETVAL = GvGP(gv) == Null(GP*);
- OUTPUT:
- RETVAL
-
-bool
-isGV_with_GP(gv)
- B::GV gv
- CODE:
+ if (ix) {
#if PERL_VERSION >= 9
- RETVAL = isGV_with_GP(gv) ? TRUE : FALSE;
+ RETVAL = isGV_with_GP(gv) ? TRUE : FALSE;
#else
- RETVAL = TRUE; /* In 5.8 and earlier they all are. */
+ RETVAL = TRUE; /* In 5.8 and earlier they all are. */
#endif
+ } else {
+ RETVAL = GvGP(gv) == Null(GP*);
+ }
OUTPUT:
- RETVAL
+ RETVAL
void*
GvGP(gv)
B::GV gv
-B::HV
-GvSTASH(gv)
- B::GV gv
-
-B::SV
-GvSV(gv)
- B::GV gv
-
-B::IO
-GvIO(gv)
- B::GV gv
-
-B::FM
-GvFORM(gv)
- B::GV gv
- CODE:
- RETVAL = (SV*)GvFORM(gv);
- OUTPUT:
- RETVAL
+#define GP_sv_ix SVp | offsetof(struct gp, gp_sv)
+#define GP_io_ix SVp | offsetof(struct gp, gp_io)
+#define GP_cv_ix SVp | offsetof(struct gp, gp_cv)
+#define GP_cvgen_ix U32p | offsetof(struct gp, gp_cvgen)
+#define GP_refcnt_ix U32p | offsetof(struct gp, gp_refcnt)
+#define GP_hv_ix SVp | offsetof(struct gp, gp_hv)
+#define GP_av_ix SVp | offsetof(struct gp, gp_av)
+#define GP_form_ix SVp | offsetof(struct gp, gp_form)
+#define GP_egv_ix SVp | offsetof(struct gp, gp_egv)
+#define GP_line_ix line_tp | offsetof(struct gp, gp_line)
-B::AV
-GvAV(gv)
- B::GV gv
-
-B::HV
-GvHV(gv)
- B::GV gv
-
-B::GV
-GvEGV(gv)
- B::GV gv
-
-B::CV
-GvCV(gv)
- B::GV gv
-
-U32
-GvCVGEN(gv)
- B::GV gv
-
-U32
-GvLINE(gv)
- B::GV gv
-
-char *
-GvFILE(gv)
- B::GV gv
-
-B::GV
-GvFILEGV(gv)
- B::GV gv
-
-MODULE = B PACKAGE = B::GV
-
-U32
-GvREFCNT(gv)
+void
+SV(gv)
B::GV gv
+ ALIAS:
+ SV = GP_sv_ix
+ IO = GP_io_ix
+ CV = GP_cv_ix
+ CVGEN = GP_cvgen_ix
+ GvREFCNT = GP_refcnt_ix
+ HV = GP_hv_ix
+ AV = GP_av_ix
+ FORM = GP_form_ix
+ EGV = GP_egv_ix
+ LINE = GP_line_ix
+ PREINIT:
+ GP *gp;
+ char *ptr;
+ SV *ret;
+ PPCODE:
+ gp = GvGP(gv);
+ if (!gp) {
+ const GV *const gv = CvGV(cv);
+ Perl_croak(aTHX_ "NULL gp in B::GV::%s", gv ? GvNAME(gv) : "???");
+ }
+ ptr = (ix & 0xFFFF) + (char *)gp;
+ switch ((U8)(ix >> 16)) {
+ case (U8)(SVp >> 16):
+ ret = make_sv_object(aTHX_ *((SV **)ptr));
+ break;
+ case (U8)(U32p >> 16):
+ ret = sv_2mortal(newSVuv(*((U32*)ptr)));
+ break;
+ case (U8)(line_tp >> 16):
+ ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
+ break;
+ default:
+ croak("Illegal alias 0x%08x for B::*SV", (unsigned)ix);
+ }
+ ST(0) = ret;
+ XSRETURN(1);
-U8
-GvFLAGS(gv)
+void
+FILEGV(gv)
B::GV gv
+ PPCODE:
+ PUSHs(make_sv_object(aTHX_ (SV *)GvFILEGV(gv)));
MODULE = B PACKAGE = B::IO PREFIX = Io
-long
-IoLINES(io)
- B::IO io
-
-long
-IoPAGE(io)
- B::IO io
-
-long
-IoPAGE_LEN(io)
- B::IO io
-
-long
-IoLINES_LEFT(io)
- B::IO io
-
-char *
-IoTOP_NAME(io)
- B::IO io
-
-B::GV
-IoTOP_GV(io)
- B::IO io
-
-char *
-IoFMT_NAME(io)
- B::IO io
-
-B::GV
-IoFMT_GV(io)
- B::IO io
-
-char *
-IoBOTTOM_NAME(io)
- B::IO io
-
-B::GV
-IoBOTTOM_GV(io)
- B::IO io
-
#if PERL_VERSION <= 8
short
OUTPUT:
RETVAL
-MODULE = B PACKAGE = B::IO
-
-char
-IoTYPE(io)
- B::IO io
-
-U8
-IoFLAGS(io)
- B::IO io
-
MODULE = B PACKAGE = B::AV PREFIX = Av
SSize_t
AvFILL(av)
B::AV av
-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
SV **svp = AvARRAY(av);
I32 i;
for (i = 0; i <= AvFILL(av); i++)
- XPUSHs(make_sv_object(aTHX_ sv_newmortal(), svp[i]));
+ XPUSHs(make_sv_object(aTHX_ svp[i]));
}
void
int idx
PPCODE:
if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
- XPUSHs(make_sv_object(aTHX_ sv_newmortal(), (AvARRAY(av)[idx])));
+ XPUSHs(make_sv_object(aTHX_ (AvARRAY(av)[idx])));
else
- XPUSHs(make_sv_object(aTHX_ sv_newmortal(), NULL));
+ XPUSHs(make_sv_object(aTHX_ NULL));
#if PERL_VERSION < 9
+#define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
+
+IV
+AvOFF(av)
+ B::AV av
+
MODULE = B PACKAGE = B::AV
U8
#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
+void
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)
- B::CV cv
-
-char *
-CvFILE(cv)
- B::CV cv
-
-long
-CvDEPTH(cv)
- B::CV cv
-
-B::AV
-CvPADLIST(cv)
- B::CV cv
-
-B::CV
-CvOUTSIDE(cv)
- B::CV cv
-
-U32
-CvOUTSIDE_SEQ(cv)
- B::CV cv
+ ALIAS:
+ ROOT = 1
+ PPCODE:
+ PUSHs(make_op_object(aTHX_ CvISXSUB(cv) ? NULL
+ : ix ? CvROOT(cv) : CvSTART(cv)));
void
CvXSUB(cv)
B::CV cv
+ ALIAS:
+ XSUBANY = 1
CODE:
- ST(0) = sv_2mortal(newSViv(CvISXSUB(cv) ? PTR2IV(CvXSUB(cv)) : 0));
-
+ ST(0) = ix && CvCONST(cv)
+ ? make_sv_object(aTHX_ (SV *)CvXSUBANY(cv).any_ptr)
+ : sv_2mortal(newSViv(CvISXSUB(cv)
+ ? (ix ? CvXSUBANY(cv).any_iv
+ : PTR2IV(CvXSUB(cv)))
+ : 0));
void
-CvXSUBANY(cv)
+const_sv(cv)
B::CV cv
- CODE:
- ST(0) = CvCONST(cv) ?
- 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
-
-U16
-CvFLAGS(cv)
- B::CV cv
-
-MODULE = B PACKAGE = B::CV PREFIX = cv_
-
-B::SV
-cv_const_sv(cv)
- B::CV cv
-
+ PPCODE:
+ PUSHs(make_sv_object(aTHX_ (SV *)cv_const_sv(cv)));
MODULE = B PACKAGE = B::HV PREFIX = Hv
HvFILL(hv)
B::HV hv
-STRLEN
-HvMAX(hv)
- B::HV hv
-
-I32
-HvKEYS(hv)
- B::HV hv
-
I32
HvRITER(hv)
B::HV hv
-char *
-HvNAME(hv)
- B::HV hv
-
#if PERL_VERSION < 9
B::PMOP
HvPMROOT(hv)
B::HV hv
+ PPCODE:
+ PUSHs(make_op_object(aTHX_ HvPMROOT(hv)));
#endif
(void)hv_iterinit(hv);
EXTEND(sp, HvKEYS(hv) * 2);
while ((sv = hv_iternextsv(hv, &key, &len))) {
- PUSHs(newSVpvn(key, len));
- PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv));
+ mPUSHp(key, len);
+ PUSHs(make_sv_object(aTHX_ sv));
}
}
MODULE = B PACKAGE = B::HE PREFIX = He
-B::SV
+void
HeVAL(he)
B::HE he
+ ALIAS:
+ SVKEY_force = 1
+ PPCODE:
+ PUSHs(make_sv_object(aTHX_ ix ? HeSVKEY_force(he) : HeVAL(he)));
U32
HeHASH(he)
B::HE he
-B::SV
-HeSVKEY_force(he)
- B::HE he
-
-MODULE = B PACKAGE = B::RHE PREFIX = RHE_
+MODULE = B PACKAGE = B::RHE
#if PERL_VERSION >= 9
SV*
-RHE_HASH(h)
+HASH(h)
B::RHE h
CODE:
- RETVAL = newRV( (SV*)Perl_refcounted_he_chain_2hv(aTHX_ h) );
+ RETVAL = newRV( (SV*)cophh_2hv(h, 0) );
OUTPUT:
RETVAL
https://perl5.git.perl.org / perl5.git / blobdiff