return (char *)opclassnames[cc_opclass(aTHX_ o)];
}
+/* FIXME - figure out how to get the typemap to assign this to ST(0), rather
+ than creating a new mortal for ST(0) then passing it in as the first
+ argument. */
static SV *
make_sv_object(pTHX_ SV *arg, SV *sv)
{
const char *type = 0;
IV iv;
dMY_CXT;
-
+
+ if (!arg)
+ arg = sv_newmortal();
+
for (iv = 0; iv < sizeof(specialsv_list)/sizeof(SV*); iv++) {
if (sv == specialsv_list[iv]) {
type = "B::SPECIAL";
#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_ STRLEN *warnings)
{
const char *type = 0;
dMY_CXT;
}
}
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_ NULL, value);
} else {
SvREFCNT_dec(value);
- return make_sv_object(aTHX_ arg, NULL);
+ return make_sv_object(aTHX_ NULL, 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;
}
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, GV_ADD);
- 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;
#if PERL_VERSION <= 8
# define OPpPAD_STATE 0
#endif
-#include "defsubs.h"
}
#define B_main_cv() PL_main_cv
void
B_warnhook()
CODE:
- ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_warnhook);
+ ST(0) = make_sv_object(aTHX_ NULL, PL_warnhook);
void
B_diehook()
CODE:
- ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_diehook);
+ ST(0) = make_sv_object(aTHX_ NULL, PL_diehook);
MODULE = B PACKAGE = B
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
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, 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
-#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_
char *
OP_name(o)
B::OP o
+ ALIAS:
+ desc = 1
CODE:
- RETVAL = (char *)PL_op_name[o->op_type];
+ RETVAL = (char *)(ix ? PL_op_desc : PL_op_name)[o->op_type];
OUTPUT:
RETVAL
-
void
OP_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
-
-U16
-OP_opt(o)
+# These 3 are all bitfields, so we can't take their addresses.
+UV
+OP_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)
+UV
+OP_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
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
{
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)));
+ 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
#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_
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);
+#if PERL_VERSION >= 9
+ ST(0) = make_warnings_object(aTHX_ o->cop_warnings);
+#else
+ ST(0) = make_sv_object(aTHX_ NULL, o->cop_warnings);
+#endif
XSRETURN(1);
void
COP_io(o)
B::COP o
PPCODE:
- ST(0) = make_cop_io_object(aTHX_ sv_newmortal(), o);
+#if PERL_VERSION >= 9
+ ST(0) = make_cop_io_object(aTHX_ o);
+#else
+ ST(0) = make_sv_object(aTHX_ NULL, o->cop_io);
+#endif
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
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);
}
SvPV(sv)
B::PV sv
CODE:
- ST(0) = sv_newmortal();
if( SvPOK(sv) ) {
+ STRLEN len = SvCUR(sv);
+ const char *p = SvPVX_const(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((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);
+ ST(0) = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
}
else {
/* XXX for backward compatibility, but should fail */
/* croak( "argument is not SvPOK" ); */
- sv_setpvn(ST(0), NULL, 0);
+ ST(0) = sv_newmortal();
}
# This used to read 257. I think that that was buggy - should have been 258.
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));
+ ST(0) = newSVpvn_flags(SvPVX_const(sv),
+ SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0),
+ SVs_TEMP);
STRLEN
MAGIC * mg = NO_INIT
PPCODE:
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
- XPUSHs(make_mg_object(aTHX_ sv_newmortal(), mg));
+ XPUSHs(make_mg_object(aTHX_ mg));
MODULE = B PACKAGE = B::PVMG
MgPTR(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);
+ ST(0) = 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);
- }
- }
+ ST(0) = make_sv_object(aTHX_ NULL, (SV*)mg->mg_ptr);
+ } else
+ ST(0) = sv_newmortal();
+ } else
+ ST(0) = sv_newmortal();
MODULE = B PACKAGE = B::PVLV PREFIX = Lv
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));
+ 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)
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_ NULL, 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_ NULL, (AvARRAY(av)[idx])));
else
- XPUSHs(make_sv_object(aTHX_ sv_newmortal(), NULL));
+ XPUSHs(make_sv_object(aTHX_ NULL, NULL));
#if PERL_VERSION < 9
B::OP
CvSTART(cv)
B::CV cv
+ ALIAS:
+ ROOT = 1
CODE:
- RETVAL = CvISXSUB(cv) ? NULL : CvSTART(cv);
- OUTPUT:
- RETVAL
-
-B::OP
-CvROOT(cv)
- B::CV cv
- CODE:
- RETVAL = CvISXSUB(cv) ? NULL : CvROOT(cv);
+ RETVAL = CvISXSUB(cv) ? NULL : ix ? CvROOT(cv) : CvSTART(cv);
OUTPUT:
RETVAL
CvXSUBANY(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));
+ ST(0) = CvCONST(cv)
+ ? make_sv_object(aTHX_ NULL, (SV *)CvXSUBANY(cv).any_ptr)
+ : sv_2mortal(newSViv(CvISXSUB(cv) ? CvXSUBANY(cv).any_iv : 0));
MODULE = B PACKAGE = B::CV
EXTEND(sp, HvKEYS(hv) * 2);
while ((sv = hv_iternextsv(hv, &key, &len))) {
mPUSHp(key, len);
- PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv));
+ PUSHs(make_sv_object(aTHX_ NULL, sv));
}
}
RHE_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