#endif
-static char *svclassnames[] = {
+static const char* const svclassnames[] = {
"B::NULL",
+#if PERL_VERSION >= 9
+ "B::BIND",
+#endif
"B::IV",
"B::NV",
"B::RV",
"B::PVIV",
"B::PVNV",
"B::PVMG",
+#if PERL_VERSION <= 8
"B::BM",
+#endif
#if PERL_VERSION >= 9
"B::GV",
#endif
OPc_COP /* 11 */
} opclass;
-static char *opclassnames[] = {
+static const char* const opclassnames[] = {
"B::NULL",
"B::OP",
"B::UNOP",
"B::COP"
};
-static size_t opsizes[] = {
+static const size_t opsizes[] = {
0,
sizeof(OP),
sizeof(UNOP),
#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
+ return OPc_PADOP;
+#else
+ return OPc_SVOP;
+#endif
+ }
+
#ifdef USE_ITHREADS
if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
- o->op_type == OP_AELEMFAST || o->op_type == OP_RCATLINE)
+ 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;
}
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)
+{
+ if (CopHINTS_get(cop) & HINT_LEXICAL_IO) {
+ /* I feel you should be able to simply SvREFCNT_inc the return value
+ from this, but if you do (and restore the line
+ my $ioix = $cop->io->ix;
+ in B::COP::bsave in Bytecode.pm, then you get errors about
+ "attempt to free temp prematurely ... during global destruction.
+ The SV's flags are consistent with the error, but quite how the
+ temp escaped from the save stack is not clear. */
+ SV *value = Perl_refcounted_he_fetch(aTHX_ cop->cop_hints_hash,
+ 0, "open", 4, 0, 0);
+ return make_temp_object(aTHX_ arg, newSVsv(value));
+ } else {
+ return make_sv_object(aTHX_ arg, NULL);
+ }
+}
+
+static SV *
make_mg_object(pTHX_ SV *arg, MAGIC *mg)
{
sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg));
cstring(pTHX_ SV *sv, bool perlstyle)
{
SV *sstr = newSVpvn("", 0);
- STRLEN len;
- char *s;
- char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
if (!SvOK(sv))
sv_setpvn(sstr, "0", 1);
- else if (perlstyle && SvUTF8(sv))
- {
+ 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_setpvn(sstr,"\"",1);
while (*s)
{
if (*s == '"')
- sv_catpv(sstr, "\\\"");
+ sv_catpvn(sstr, "\\\"", 2);
else if (*s == '$')
- sv_catpv(sstr, "\\$");
+ sv_catpvn(sstr, "\\$", 2);
else if (*s == '@')
- sv_catpv(sstr, "\\@");
+ sv_catpvn(sstr, "\\@", 2);
else if (*s == '\\')
{
if (strchr("nrftax\\",*(s+1)))
sv_catpvn(sstr, s++, 2);
else
- sv_catpv(sstr, "\\\\");
+ sv_catpvn(sstr, "\\\\", 2);
}
else /* should always be printable */
sv_catpvn(sstr, s, 1);
else
{
/* XXX Optimise? */
- s = SvPV(sv, len);
+ STRLEN len;
+ const char *s = SvPV(sv, len);
sv_catpv(sstr, "\"");
for (; len; len--, s++)
{
else if (*s == '\\')
sv_catpv(sstr, "\\\\");
/* trigraphs - bleagh */
- else if (!perlstyle && *s == '?' && len>=3 && s[1] == '?')
- {
+ else if (!perlstyle && *s == '?' && len>=3 && s[1] == '?') {
+ char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
sprintf(escbuff, "\\%03o", '?');
sv_catpv(sstr, escbuff);
}
else
{
/* Don't want promotion of a signed -1 char in sprintf args */
- unsigned char c = (unsigned char) *s;
+ char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
+ const unsigned char c = (unsigned char) *s;
sprintf(escbuff, "\\%03o", c);
sv_catpv(sstr, escbuff);
}
cchar(pTHX_ SV *sv)
{
SV *sstr = newSVpvn("'", 1);
- STRLEN n_a;
- char *s = SvPV(sv, n_a);
+ const char *s = SvPV_nolen(sv);
if (*s == '\'')
- sv_catpv(sstr, "\\'");
+ sv_catpvn(sstr, "\\'", 2);
else if (*s == '\\')
- sv_catpv(sstr, "\\\\");
+ sv_catpvn(sstr, "\\\\", 2);
#ifdef EBCDIC
else if (isPRINT(*s))
#else
#endif /* EBCDIC */
sv_catpvn(sstr, s, 1);
else if (*s == '\n')
- sv_catpv(sstr, "\\n");
+ sv_catpvn(sstr, "\\n", 2);
else if (*s == '\r')
- sv_catpv(sstr, "\\r");
+ sv_catpvn(sstr, "\\r", 2);
else if (*s == '\t')
- sv_catpv(sstr, "\\t");
+ sv_catpvn(sstr, "\\t", 2);
else if (*s == '\a')
- sv_catpv(sstr, "\\a");
+ sv_catpvn(sstr, "\\a", 2);
else if (*s == '\b')
- sv_catpv(sstr, "\\b");
+ sv_catpvn(sstr, "\\b", 2);
else if (*s == '\f')
- sv_catpv(sstr, "\\f");
+ sv_catpvn(sstr, "\\f", 2);
else if (*s == '\v')
- sv_catpv(sstr, "\\v");
+ sv_catpvn(sstr, "\\v", 2);
else
{
/* no trigraph support */
sprintf(escbuff, "\\%03o", c);
sv_catpv(sstr, escbuff);
}
- sv_catpv(sstr, "'");
+ sv_catpvn(sstr, "'", 1);
return sstr;
}
-void
-walkoptree(pTHX_ SV *opsv, char *method)
+static void
+walkoptree(pTHX_ SV *opsv, const char *method)
{
dSP;
OP *o, *kid;
}
}
-SV **
+static SV **
oplist(pTHX_ OP *o, SV **SP)
{
for(; o; o = o->op_next) {
typedef IO *B__IO;
typedef MAGIC *B__MAGIC;
+typedef HE *B__HE;
+typedef struct refcounted_he *B__RHE;
MODULE = B PACKAGE = B PREFIX = B_
specialsv_list[1] = &PL_sv_undef;
specialsv_list[2] = &PL_sv_yes;
specialsv_list[3] = &PL_sv_no;
- specialsv_list[4] = pWARN_ALL;
- specialsv_list[5] = pWARN_NONE;
- specialsv_list[6] = pWARN_STD;
+ specialsv_list[4] = (SV *) pWARN_ALL;
+ specialsv_list[5] = (SV *) pWARN_NONE;
+ specialsv_list[6] = (SV *) pWARN_STD;
#if PERL_VERSION <= 8
# define CVf_ASSERTION 0
#endif
#define B_init_av() PL_initav
#define B_inc_gv() PL_incgv
#define B_check_av() PL_checkav_save
+#define B_unitcheck_av() PL_unitcheckav_save
#define B_begin_av() PL_beginav_save
#define B_end_av() PL_endav
#define B_main_root() PL_main_root
#define B_main_start() PL_main_start
#define B_amagic_generation() PL_amagic_generation
+#define B_sub_generation() PL_sub_generation
#define B_defstash() PL_defstash
#define B_curstash() PL_curstash
#define B_dowarn() PL_dowarn
B_check_av()
B::AV
+B_unitcheck_av()
+
+B::AV
B_begin_av()
B::AV
long
B_amagic_generation()
+long
+B_sub_generation()
+
B::AV
B_comppadlist()
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;
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));
#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++)
#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
#if PERL_VERSION >= 9
OP_name(o)
B::OP o
CODE:
- RETVAL = PL_op_name[o->op_type];
+ RETVAL = (char *)PL_op_name[o->op_type];
OUTPUT:
RETVAL
(o->op_private & OPpTRANS_COMPLEMENT) &&
!(o->op_private & OPpTRANS_DELETE))
{
- short* tbl = (short*)o->op_pv;
- short entries = 257 + tbl[256];
+ const short* const tbl = (short*)o->op_pv;
+ const short entries = 257 + tbl[256];
ST(0) = sv_2mortal(newSVpv(o->op_pv, entries * sizeof(short)));
}
else if (o->op_type == OP_TRANS) {
#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_io(o) o->cop_io
+#define COP_hints(o) CopHINTS_get(o)
MODULE = B PACKAGE = B::COP PREFIX = COP_
COP_line(o)
B::COP o
-B::SV
+void
COP_warnings(o)
B::COP o
+ PPCODE:
+ ST(0) = make_warnings_object(aTHX_ sv_newmortal(), o->cop_warnings);
+ XSRETURN(1);
-B::SV
+void
COP_io(o)
B::COP o
+ PPCODE:
+ ST(0) = make_cop_io_object(aTHX_ sv_newmortal(), o);
+ XSRETURN(1);
+
+U32
+COP_hints(o)
+ B::COP o
+
+B::RHE
+COP_hints_hash(o)
+ B::COP o
+ CODE:
+ RETVAL = o->cop_hints_hash;
+ OUTPUT:
+ RETVAL
MODULE = B PACKAGE = B::SV
CODE:
if (sizeof(IV) == 8) {
U32 wp[2];
- IV iv = SvIVX(sv);
+ const IV iv = SvIVX(sv);
/*
* The following way of spelling 32 is to stop compilers on
* 32-bit architectures from moaning about the shift count
SvNVX(sv)
B::NV sv
+U32
+COP_SEQ_RANGE_LOW(sv)
+ B::NV sv
+
+U32
+COP_SEQ_RANGE_HIGH(sv)
+ B::NV sv
+
+U32
+PARENT_PAD_INDEX(sv)
+ B::NV sv
+
+U32
+PARENT_FAKELEX_FLAGS(sv)
+ B::NV sv
+
MODULE = B PACKAGE = B::RV PREFIX = Sv
B::SV
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(sv),
- SvCUR(sv) + (SvTYPE(sv) == SVt_PVBM ? 257 : 0));
+ sv_setpvn(ST(0), SvPVX_const(sv),
+ SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0));
STRLEN
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 );
}
CODE:
str = SvPV(sv, len);
/* Boyer-Moore table is just after string and its safety-margin \0 */
- ST(0) = sv_2mortal(newSVpvn(str + len + 1, 256));
+ ST(0) = sv_2mortal(newSVpvn(str + len + PERL_FBM_TABLE_OFFSET, 256));
MODULE = B PACKAGE = B::GV PREFIX = Gv
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
else
XPUSHs(make_sv_object(aTHX_ sv_newmortal(), NULL));
+#if PERL_VERSION < 9
MODULE = B PACKAGE = B::AV
AvFLAGS(av)
B::AV av
+#endif
+
MODULE = B PACKAGE = B::FM PREFIX = Fm
IV
B::OP
CvSTART(cv)
B::CV cv
+ CODE:
+ RETVAL = CvISXSUB(cv) ? NULL : CvSTART(cv);
+ OUTPUT:
+ RETVAL
B::OP
CvROOT(cv)
B::CV cv
+ CODE:
+ RETVAL = CvISXSUB(cv) ? NULL : CvROOT(cv);
+ OUTPUT:
+ RETVAL
B::GV
CvGV(cv)
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
CODE:
ST(0) = CvCONST(cv) ?
make_sv_object(aTHX_ sv_newmortal(),(SV *)CvXSUBANY(cv).any_ptr) :
- sv_2mortal(newSViv(CvXSUBANY(cv).any_iv));
+ 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
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_
+
+SV*
+RHE_HASH(h)
+ B::RHE h
+ CODE:
+ RETVAL = newRV( (SV*)Perl_refcounted_he_chain_2hv(aTHX_ h) );
+ OUTPUT:
+ RETVAL
projects / p5sagit/p5-mst-13.2.git / blobdiff