*
*/
+#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
-#include "INTERN.h"
-
-#ifdef PERL_OBJECT
-#undef op_name
-#undef opargs
-#undef op_desc
-#define op_name (pPerl->Perl_get_op_names())
-#define opargs (pPerl->Perl_get_opargs())
-#define op_desc (pPerl->Perl_get_op_descs())
-#endif
#ifdef PerlIO
typedef PerlIO * InputStream;
OPc_UNOP, /* 2 */
OPc_BINOP, /* 3 */
OPc_LOGOP, /* 4 */
- OPc_CONDOP, /* 5 */
- OPc_LISTOP, /* 6 */
- OPc_PMOP, /* 7 */
- OPc_SVOP, /* 8 */
- OPc_GVOP, /* 9 */
- OPc_PVOP, /* 10 */
- OPc_CVOP, /* 11 */
- OPc_LOOP, /* 12 */
- OPc_COP /* 13 */
+ OPc_LISTOP, /* 5 */
+ OPc_PMOP, /* 6 */
+ OPc_SVOP, /* 7 */
+ OPc_PADOP, /* 8 */
+ OPc_PVOP, /* 9 */
+ OPc_CVOP, /* 10 */
+ OPc_LOOP, /* 11 */
+ OPc_COP /* 12 */
} opclass;
static char *opclassnames[] = {
"B::UNOP",
"B::BINOP",
"B::LOGOP",
- "B::CONDOP",
"B::LISTOP",
"B::PMOP",
"B::SVOP",
- "B::GVOP",
+ "B::PADOP",
"B::PVOP",
"B::CVOP",
"B::LOOP",
"B::COP"
};
-static int walkoptree_debug = 0; /* Flag for walkoptree debug hook */
+#define MY_CXT_KEY "B::_guts" XS_VERSION
+
+typedef struct {
+ int x_walkoptree_debug; /* Flag for walkoptree debug hook */
+ SV * x_specialsv_list[7];
+} my_cxt_t;
+
+START_MY_CXT
+
+#define walkoptree_debug (MY_CXT.x_walkoptree_debug)
+#define specialsv_list (MY_CXT.x_specialsv_list)
static opclass
-cc_opclass(OP *o)
+cc_opclass(pTHX_ OP *o)
{
if (!o)
return OPc_NULL;
if (o->op_type == OP_SASSIGN)
return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
- switch (opargs[o->op_type] & OA_CLASS_MASK) {
+#ifdef USE_ITHREADS
+ if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
+ o->op_type == OP_AELEMFAST || o->op_type == OP_RCATLINE)
+ return OPc_PADOP;
+#endif
+
+ switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
case OA_BASEOP:
return OPc_BASEOP;
case OA_LOGOP:
return OPc_LOGOP;
- case OA_CONDOP:
- return OPc_CONDOP;
-
case OA_LISTOP:
return OPc_LISTOP;
case OA_SVOP:
return OPc_SVOP;
- case OA_GVOP:
- return OPc_GVOP;
+ case OA_PADOP:
+ return OPc_PADOP;
- case OA_PVOP:
- return OPc_PVOP;
+ case OA_PVOP_OR_SVOP:
+ /*
+ * 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
+ * (i.e., an RV pointing to an HV).
+ */
+ return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
+ ? OPc_SVOP : OPc_PVOP;
case OA_LOOP:
return OPc_LOOP;
* return OPc_UNOP so that walkoptree can find our children. If
* OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
* (no argument to the operator) it's an OP; with OPf_REF set it's
- * a GVOP (and op_gv is the GV for the filehandle argument).
+ * an SVOP (and op_sv is the GV for the filehandle argument).
*/
return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
- (o->op_flags & OPf_REF) ? OPc_GVOP : OPc_BASEOP);
-
+#ifdef USE_ITHREADS
+ (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
+#else
+ (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
+#endif
case OA_LOOPEXOP:
/*
* next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
return OPc_PVOP;
}
warn("can't determine class of operator %s, assuming BASEOP\n",
- op_name[o->op_type]);
+ PL_op_name[o->op_type]);
return OPc_BASEOP;
}
static char *
-cc_opclassname(OP *o)
+cc_opclassname(pTHX_ OP *o)
{
- return opclassnames[cc_opclass(o)];
+ return opclassnames[cc_opclass(aTHX_ o)];
}
static SV *
-make_sv_object(SV *arg, SV *sv)
+make_sv_object(pTHX_ SV *arg, SV *sv)
{
char *type = 0;
IV iv;
+ dMY_CXT;
for (iv = 0; iv < sizeof(specialsv_list)/sizeof(SV*); iv++) {
if (sv == specialsv_list[iv]) {
}
if (!type) {
type = svclassnames[SvTYPE(sv)];
- iv = (IV)sv;
+ iv = PTR2IV(sv);
}
sv_setiv(newSVrv(arg, type), iv);
return arg;
}
static SV *
-make_mg_object(SV *arg, MAGIC *mg)
+make_mg_object(pTHX_ SV *arg, MAGIC *mg)
{
- sv_setiv(newSVrv(arg, "B::MAGIC"), (IV)mg);
+ sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg));
return arg;
}
static SV *
-cstring(SV *sv)
+cstring(pTHX_ SV *sv, bool perlstyle)
{
- SV *sstr = newSVpv("", 0);
+ 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))
+ {
+ 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,"\"");
+ while (*s)
+ {
+ if (*s == '"')
+ sv_catpv(sstr, "\\\"");
+ else if (*s == '$')
+ sv_catpv(sstr, "\\$");
+ else if (*s == '@')
+ sv_catpv(sstr, "\\@");
+ else if (*s == '\\')
+ {
+ if (strchr("nrftax\\",*(s+1)))
+ sv_catpvn(sstr, s++, 2);
+ else
+ sv_catpv(sstr, "\\\\");
+ }
+ else /* should always be printable */
+ sv_catpvn(sstr, s, 1);
+ ++s;
+ }
+ sv_catpv(sstr, "\"");
+ return sstr;
+ }
else
{
/* XXX Optimise? */
sv_catpv(sstr, "\\\"");
else if (*s == '\\')
sv_catpv(sstr, "\\\\");
- else if (*s >= ' ' && *s < 127) /* XXX not portable */
+ /* trigraphs - bleagh */
+ else if (!perlstyle && *s == '?' && len>=3 && s[1] == '?')
+ {
+ sprintf(escbuff, "\\%03o", '?');
+ sv_catpv(sstr, escbuff);
+ }
+ else if (perlstyle && *s == '$')
+ sv_catpv(sstr, "\\$");
+ else if (perlstyle && *s == '@')
+ sv_catpv(sstr, "\\@");
+#ifdef EBCDIC
+ else if (isPRINT(*s))
+#else
+ else if (*s >= ' ' && *s < 127)
+#endif /* EBCDIC */
sv_catpvn(sstr, s, 1);
else if (*s == '\n')
sv_catpv(sstr, "\\n");
sv_catpv(sstr, "\\b");
else if (*s == '\f')
sv_catpv(sstr, "\\f");
- else if (*s == '\v')
+ else if (!perlstyle && *s == '\v')
sv_catpv(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);
}
static SV *
-cchar(SV *sv)
+cchar(pTHX_ SV *sv)
{
- SV *sstr = newSVpv("'", 0);
- char *s = SvPV(sv, na);
+ SV *sstr = newSVpvn("'", 1);
+ STRLEN n_a;
+ char *s = SvPV(sv, n_a);
if (*s == '\'')
sv_catpv(sstr, "\\'");
else if (*s == '\\')
sv_catpv(sstr, "\\\\");
- else if (*s >= ' ' && *s < 127) /* XXX not portable */
+#ifdef EBCDIC
+ else if (isPRINT(*s))
+#else
+ else if (*s >= ' ' && *s < 127)
+#endif /* EBCDIC */
sv_catpvn(sstr, s, 1);
else if (*s == '\n')
sv_catpv(sstr, "\\n");
return sstr;
}
-#ifdef INDIRECT_BGET_MACROS
-void freadpv(U32 len, void *data)
-{
- New(666, pv.xpv_pv, len, char);
- fread(pv.xpv_pv, 1, len, (FILE*)data);
- pv.xpv_len = len;
- pv.xpv_cur = len - 1;
-}
-
-void byteload_fh(InputStream fp)
-{
- struct bytestream bs;
- bs.data = fp;
- bs.fgetc = (int(*) _((void*)))fgetc;
- bs.fread = (int(*) _((char*,size_t,size_t,void*)))fread;
- bs.freadpv = freadpv;
- byterun(bs);
-}
-
-static int fgetc_fromstring(void *data)
-{
- char **strp = (char **)data;
- return *(*strp)++;
-}
-
-static int fread_fromstring(char *argp, size_t elemsize, size_t nelem,
- void *data)
-{
- char **strp = (char **)data;
- size_t len = elemsize * nelem;
-
- memcpy(argp, *strp, len);
- *strp += len;
- return (int)len;
-}
-
-static void freadpv_fromstring(U32 len, void *data)
-{
- char **strp = (char **)data;
-
- New(666, pv.xpv_pv, len, char);
- memcpy(pv.xpv_pv, *strp, len);
- pv.xpv_len = len;
- pv.xpv_cur = len - 1;
- *strp += len;
-}
-
-void byteload_string(char *str)
-{
- struct bytestream bs;
- bs.data = &str;
- bs.fgetc = fgetc_fromstring;
- bs.fread = fread_fromstring;
- bs.freadpv = freadpv_fromstring;
- byterun(bs);
-}
-#else
-void byteload_fh(InputStream fp)
-{
- byterun(fp);
-}
-
-void byteload_string(char *str)
-{
- croak("Must compile with -DINDIRECT_BGET_MACROS for byteload_string");
-}
-#endif /* INDIRECT_BGET_MACROS */
-
void
-walkoptree(SV *opsv, char *method)
+walkoptree(pTHX_ SV *opsv, char *method)
{
dSP;
- OP *o;
-
+ OP *o, *kid;
+ dMY_CXT;
+
if (!SvROK(opsv))
croak("opsv is not a reference");
opsv = sv_mortalcopy(opsv);
- o = (OP*)SvIV((SV*)SvRV(opsv));
+ o = INT2PTR(OP*,SvIV((SV*)SvRV(opsv)));
if (walkoptree_debug) {
PUSHMARK(sp);
XPUSHs(opsv);
PUTBACK;
perl_call_method(method, G_DISCARD);
if (o && (o->op_flags & OPf_KIDS)) {
- OP *kid;
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(kid)), (IV)kid);
- walkoptree(opsv, method);
+ sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
+ walkoptree(aTHX_ opsv, method);
}
}
+ if (o && (cc_opclass(aTHX_ o) == OPc_PMOP)
+ && (kid = cPMOPo->op_pmreplroot))
+ {
+ sv_setiv(newSVrv(opsv, opclassnames[OPc_PMOP]), PTR2IV(kid));
+ walkoptree(aTHX_ opsv, method);
+ }
}
typedef OP *B__OP;
typedef UNOP *B__UNOP;
typedef BINOP *B__BINOP;
typedef LOGOP *B__LOGOP;
-typedef CONDOP *B__CONDOP;
typedef LISTOP *B__LISTOP;
typedef PMOP *B__PMOP;
typedef SVOP *B__SVOP;
-typedef GVOP *B__GVOP;
+typedef PADOP *B__PADOP;
typedef PVOP *B__PVOP;
typedef LOOP *B__LOOP;
typedef COP *B__COP;
PROTOTYPES: DISABLE
BOOT:
- INIT_SPECIALSV_LIST;
+{
+ HV *stash = gv_stashpvn("B", 1, TRUE);
+ AV *export_ok = perl_get_av("B::EXPORT_OK",TRUE);
+ MY_CXT_INIT;
+ specialsv_list[0] = Nullsv;
+ specialsv_list[1] = &PL_sv_undef;
+ specialsv_list[2] = &PL_sv_yes;
+ specialsv_list[3] = &PL_sv_no;
+ specialsv_list[4] = pWARN_ALL;
+ specialsv_list[5] = pWARN_NONE;
+ specialsv_list[6] = pWARN_STD;
+#include "defsubs.h"
+}
-#define B_main_cv() main_cv
-#define B_main_root() main_root
-#define B_main_start() main_start
-#define B_comppadlist() (main_cv ? CvPADLIST(main_cv) : CvPADLIST(compcv))
-#define B_sv_undef() &sv_undef
-#define B_sv_yes() &sv_yes
-#define B_sv_no() &sv_no
+#define B_main_cv() PL_main_cv
+#define B_init_av() PL_initav
+#define B_check_av() PL_checkav_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_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
+#ifdef USE_ITHREADS
+#define B_regex_padav() PL_regex_padav
+#endif
+
+B::AV
+B_init_av()
+
+B::AV
+B_check_av()
+
+B::AV
+B_begin_av()
+
+B::AV
+B_end_av()
+
+#ifdef USE_ITHREADS
+
+B::AV
+B_regex_padav()
+
+#endif
B::CV
B_main_cv()
B::OP
B_main_start()
+long
+B_amagic_generation()
+
B::AV
B_comppadlist()
walkoptree(opsv, method)
SV * opsv
char * method
+ CODE:
+ walkoptree(aTHX_ opsv, method);
int
walkoptree_debug(...)
CODE:
+ dMY_CXT;
RETVAL = walkoptree_debug;
if (items > 0 && SvTRUE(ST(1)))
walkoptree_debug = 1;
OUTPUT:
RETVAL
-int
-byteload_fh(fp)
- InputStream fp
- CODE:
- byteload_fh(fp);
- RETVAL = 1;
- OUTPUT:
- RETVAL
-
-void
-byteload_string(str)
- char * str
-
-#define address(sv) (IV)sv
+#define address(sv) PTR2IV(sv)
IV
address(sv)
croak("argument is not a reference");
RETVAL = (SV*)SvRV(sv);
OUTPUT:
- RETVAL
+ RETVAL
+
+void
+opnumber(name)
+char * name
+CODE:
+{
+ int i;
+ IV result = -1;
+ ST(0) = sv_newmortal();
+ if (strncmp(name,"pp_",3) == 0)
+ name += 3;
+ for (i = 0; i < PL_maxo; i++)
+ {
+ if (strcmp(name, PL_op_name[i]) == 0)
+ {
+ result = i;
+ break;
+ }
+ }
+ sv_setiv(ST(0),result);
+}
void
ppname(opnum)
int opnum
CODE:
ST(0) = sv_newmortal();
- if (opnum >= 0 && opnum < maxo) {
+ if (opnum >= 0 && opnum < PL_maxo) {
sv_setpvn(ST(0), "pp_", 3);
- sv_catpv(ST(0), op_name[opnum]);
+ sv_catpv(ST(0), PL_op_name[opnum]);
}
void
char *s;
STRLEN len;
U32 hash = 0;
- char hexhash[11]; /* must fit "0xffffffff" plus trailing \0 */
+ char hexhash[19]; /* must fit "0xffffffffffffffff" plus trailing \0 */
s = SvPV(sv, len);
- while (len--)
- hash = hash * 33 + *s++;
- sprintf(hexhash, "0x%x", hash);
+ PERL_HASH(hash, s, len);
+ sprintf(hexhash, "0x%"UVxf, (UV)hash);
ST(0) = sv_2mortal(newSVpv(hexhash, 0));
#define cast_I32(foo) (I32)foo
void
minus_c()
CODE:
- minus_c = TRUE;
+ 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
void
threadsv_names()
PPCODE:
-#ifdef USE_THREADS
- int i;
- STRLEN len = strlen(threadsv_names);
-
- EXTEND(sp, len);
- for (i = 0; i < len; i++)
- PUSHs(sv_2mortal(newSVpv(&threadsv_names[i], 1)));
-#endif
#define OP_next(o) o->op_next
#define OP_sibling(o) o->op_sibling
-#define OP_desc(o) op_desc[o->op_type]
+#define OP_desc(o) PL_op_desc[o->op_type]
#define OP_targ(o) o->op_targ
#define OP_type(o) o->op_type
#define OP_seq(o) o->op_seq
B::OP o
char *
+OP_name(o)
+ B::OP o
+ CODE:
+ RETVAL = PL_op_name[o->op_type];
+ OUTPUT:
+ RETVAL
+
+
+void
OP_ppaddr(o)
B::OP o
+ PREINIT:
+ int i;
+ SV *sv = sv_newmortal();
CODE:
- ST(0) = sv_newmortal();
- sv_setpvn(ST(0), "pp_", 3);
- sv_catpv(ST(0), op_name[o->op_type]);
+ 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, "]");
+ ST(0) = sv;
char *
OP_desc(o)
B::OP o
-U16
+PADOFFSET
OP_targ(o)
B::OP o
LOGOP_other(o)
B::LOGOP o
-#define CONDOP_true(o) o->op_true
-#define CONDOP_false(o) o->op_false
-
-MODULE = B PACKAGE = B::CONDOP PREFIX = CONDOP_
-
-B::OP
-CONDOP_true(o)
- B::CONDOP o
-
-B::OP
-CONDOP_false(o)
- B::CONDOP o
-
-#define LISTOP_children(o) o->op_children
-
MODULE = B PACKAGE = B::LISTOP PREFIX = LISTOP_
U32
LISTOP_children(o)
B::LISTOP o
+ OP * kid = NO_INIT
+ int i = NO_INIT
+ CODE:
+ i = 0;
+ for (kid = o->op_first; kid; kid = kid->op_sibling)
+ i++;
+ RETVAL = i;
+ OUTPUT:
+ RETVAL
#define PMOP_pmreplroot(o) o->op_pmreplroot
#define PMOP_pmreplstart(o) o->op_pmreplstart
#define PMOP_pmnext(o) o->op_pmnext
-#define PMOP_pmregexp(o) o->op_pmregexp
+#define PMOP_pmregexp(o) PM_GETRE(o)
+#ifdef USE_ITHREADS
+#define PMOP_pmoffset(o) o->op_pmoffset
+#endif
#define PMOP_pmflags(o) o->op_pmflags
#define PMOP_pmpermflags(o) o->op_pmpermflags
+#define PMOP_pmdynflags(o) o->op_pmdynflags
MODULE = B PACKAGE = B::PMOP PREFIX = PMOP_
root = o->op_pmreplroot;
/* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */
if (o->op_type == OP_PUSHRE) {
+#ifdef USE_ITHREADS
+ sv_setiv(ST(0), INT2PTR(PADOFFSET,root) );
+#else
sv_setiv(newSVrv(ST(0), root ?
svclassnames[SvTYPE((SV*)root)] : "B::SV"),
- (IV)root);
+ PTR2IV(root));
+#endif
}
else {
- sv_setiv(newSVrv(ST(0), cc_opclassname(root)), (IV)root);
+ sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root));
}
B::OP
PMOP_pmnext(o)
B::PMOP o
-U16
+#ifdef USE_ITHREADS
+
+IV
+PMOP_pmoffset(o)
+ B::PMOP o
+
+#endif
+
+U32
PMOP_pmflags(o)
B::PMOP o
-U16
+U32
PMOP_pmpermflags(o)
B::PMOP o
+U8
+PMOP_pmdynflags(o)
+ B::PMOP o
+
void
PMOP_precomp(o)
B::PMOP o
REGEXP * rx = NO_INIT
CODE:
ST(0) = sv_newmortal();
- rx = o->op_pmregexp;
+ rx = PM_GETRE(o);
if (rx)
sv_setpvn(ST(0), rx->precomp, rx->prelen);
-#define SVOP_sv(o) o->op_sv
+#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
-#define GVOP_gv(o) o->op_gv
+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)
-MODULE = B PACKAGE = B::GVOP PREFIX = GVOP_
+MODULE = B PACKAGE = B::PADOP PREFIX = PADOP_
+PADOFFSET
+PADOP_padix(o)
+ B::PADOP o
+
+B::SV
+PADOP_sv(o)
+ B::PADOP o
B::GV
-GVOP_gv(o)
- B::GVOP o
+PADOP_gv(o)
+ B::PADOP o
MODULE = B PACKAGE = B::PVOP PREFIX = PVOP_
B::PVOP o
CODE:
/*
- * OP_TRANS uses op_pv to point to a table of 256 shorts
+ * OP_TRANS uses op_pv to point to a table of 256 or >=258 shorts
* whereas other PVOPs point to a null terminated string.
*/
- ST(0) = sv_2mortal(newSVpv(o->op_pv, (o->op_type == OP_TRANS) ?
- 256 * sizeof(short) : 0));
+ if (o->op_type == OP_TRANS &&
+ (o->op_private & OPpTRANS_COMPLEMENT) &&
+ !(o->op_private & OPpTRANS_DELETE))
+ {
+ short* tbl = (short*)o->op_pv;
+ short entries = 257 + tbl[256];
+ ST(0) = sv_2mortal(newSVpv(o->op_pv, entries * sizeof(short)));
+ }
+ else if (o->op_type == OP_TRANS) {
+ ST(0) = sv_2mortal(newSVpv(o->op_pv, 256 * sizeof(short)));
+ }
+ else
+ ST(0) = sv_2mortal(newSVpv(o->op_pv, 0));
#define LOOP_redoop(o) o->op_redoop
#define LOOP_nextop(o) o->op_nextop
B::LOOP o
#define COP_label(o) o->cop_label
-#define COP_stash(o) o->cop_stash
-#define COP_filegv(o) o->cop_filegv
+#define COP_stashpv(o) CopSTASHPV(o)
+#define COP_stash(o) CopSTASH(o)
+#define COP_file(o) CopFILE(o)
#define COP_cop_seq(o) o->cop_seq
#define COP_arybase(o) o->cop_arybase
-#define COP_line(o) o->cop_line
+#define COP_line(o) CopLINE(o)
+#define COP_warnings(o) o->cop_warnings
+#define COP_io(o) o->cop_io
MODULE = B PACKAGE = B::COP PREFIX = COP_
COP_label(o)
B::COP o
+char *
+COP_stashpv(o)
+ B::COP o
+
B::HV
COP_stash(o)
B::COP o
-B::GV
-COP_filegv(o)
+char *
+COP_file(o)
B::COP o
U32
COP_line(o)
B::COP o
+B::SV
+COP_warnings(o)
+ B::COP o
+
+B::SV
+COP_io(o)
+ B::COP o
+
MODULE = B PACKAGE = B::SV PREFIX = Sv
U32
SvIVX(sv)
B::IV sv
+UV
+SvUVX(sv)
+ B::IV sv
+
+
MODULE = B PACKAGE = B::IV
#define needs64bits(sv) ((I32)SvIVX(sv) != SvIVX(sv))
* reach this code anyway (unless sizeof(IV) > 8 but then
* everything else breaks too so I'm not fussed at the moment).
*/
- wp[0] = htonl(((U32)iv) >> (sizeof(IV)*4));
+#ifdef UV_IS_QUAD
+ wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
+#else
+ wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
+#endif
wp[1] = htonl(iv & 0xffffffff);
- ST(0) = sv_2mortal(newSVpv((char *)wp, 8));
+ ST(0) = sv_2mortal(newSVpvn((char *)wp, 8));
} else {
U32 w = htonl((U32)SvIVX(sv));
- ST(0) = sv_2mortal(newSVpv((char *)&w, 4));
+ ST(0) = sv_2mortal(newSVpvn((char *)&w, 4));
}
MODULE = B PACKAGE = B::NV PREFIX = Sv
-double
+NV
SvNV(sv)
B::NV sv
-double
+NV
SvNVX(sv)
B::NV sv
MODULE = B PACKAGE = B::PV PREFIX = Sv
+char*
+SvPVX(sv)
+ B::PV sv
+
+B::SV
+SvRV(sv)
+ B::PV sv
+ CODE:
+ if( SvROK(sv) ) {
+ RETVAL = SvRV(sv);
+ }
+ else {
+ croak( "argument is not SvROK" );
+ }
+ OUTPUT:
+ RETVAL
+
void
SvPV(sv)
B::PV sv
CODE:
- ST(0) = sv_newmortal();
- sv_setpvn(ST(0), SvPVX(sv), SvCUR(sv));
+ ST(0) = sv_newmortal();
+ if( SvPOK(sv) ) {
+ sv_setpvn(ST(0), SvPVX(sv), SvCUR(sv));
+ SvFLAGS(ST(0)) |= SvUTF8(sv);
+ }
+ else {
+ /* XXX for backward compatibility, but should fail */
+ /* croak( "argument is not SvPOK" ); */
+ sv_setpvn(ST(0), NULL, 0);
+ }
+
+STRLEN
+SvLEN(sv)
+ B::PV sv
+
+STRLEN
+SvCUR(sv)
+ B::PV sv
MODULE = B PACKAGE = B::PVMG PREFIX = Sv
MAGIC * mg = NO_INIT
PPCODE:
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
- XPUSHs(make_mg_object(sv_newmortal(), mg));
+ XPUSHs(make_mg_object(aTHX_ sv_newmortal(), mg));
MODULE = B PACKAGE = B::PVMG
#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::SV
MgOBJ(mg)
B::MAGIC mg
+ CODE:
+ if( mg->mg_type != 'r' ) {
+ RETVAL = MgOBJ(mg);
+ }
+ else {
+ croak( "OBJ is not meaningful on r-magic" );
+ }
+ OUTPUT:
+ RETVAL
+IV
+MgREGEX(mg)
+ B::MAGIC mg
+ CODE:
+ if( mg->mg_type == 'r' ) {
+ 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 == 'r') {
+ REGEXP* rx = (REGEXP*)mg->mg_obj;
+ if( rx )
+ RETVAL = newSVpvn( rx->precomp, rx->prelen );
+ }
+ else {
+ croak( "precomp is only meaningful on r-magic" );
+ }
+ OUTPUT:
+ RETVAL
+
+I32
+MgLENGTH(mg)
+ B::MAGIC mg
+
void
MgPTR(mg)
B::MAGIC mg
CODE:
ST(0) = sv_newmortal();
- if (mg->mg_ptr)
- sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len);
+ if (mg->mg_ptr){
+ if (mg->mg_len >= 0){
+ sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len);
+ } else {
+ if (mg->mg_len == HEf_SVKEY)
+ sv_setsv(ST(0),newRV((SV*)mg->mg_ptr));
+ }
+ }
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(newSVpv(str + len + 1, 256));
+ ST(0) = sv_2mortal(newSVpvn(str + len + 1, 256));
MODULE = B PACKAGE = B::GV PREFIX = Gv
GvNAME(gv)
B::GV gv
CODE:
- ST(0) = sv_2mortal(newSVpv(GvNAME(gv), GvNAMELEN(gv)));
+ ST(0) = sv_2mortal(newSVpvn(GvNAME(gv), GvNAMELEN(gv)));
+
+bool
+is_empty(gv)
+ B::GV gv
+ CODE:
+ RETVAL = GvGP(gv) == Null(GP*);
+ OUTPUT:
+ RETVAL
B::HV
GvSTASH(gv)
GvLINE(gv)
B::GV gv
+char *
+GvFILE(gv)
+ B::GV gv
+
B::GV
GvFILEGV(gv)
B::GV gv
IoSUBPROCESS(io)
B::IO io
+bool
+IsSTD(io,name)
+ B::IO io
+ char* name
+ PREINIT:
+ PerlIO* handle = 0;
+ CODE:
+ if( strEQ( name, "stdin" ) ) {
+ handle = PerlIO_stdin();
+ }
+ else if( strEQ( name, "stdout" ) ) {
+ handle = PerlIO_stdout();
+ }
+ else if( strEQ( name, "stderr" ) ) {
+ handle = PerlIO_stderr();
+ }
+ else {
+ croak( "Invalid value '%s'", name );
+ }
+ RETVAL = handle == IoIFP(io);
+ OUTPUT:
+ RETVAL
+
MODULE = B PACKAGE = B::IO
char
SV **svp = AvARRAY(av);
I32 i;
for (i = 0; i <= AvFILL(av); i++)
- XPUSHs(make_sv_object(sv_newmortal(), svp[i]));
+ XPUSHs(make_sv_object(aTHX_ sv_newmortal(), svp[i]));
}
MODULE = B PACKAGE = B::AV
CvGV(cv)
B::CV cv
-B::GV
-CvFILEGV(cv)
+char *
+CvFILE(cv)
B::CV cv
long
CvOUTSIDE(cv)
B::CV cv
+U32
+CvOUTSIDE_SEQ(cv)
+ B::CV cv
+
void
CvXSUB(cv)
B::CV cv
CODE:
- ST(0) = sv_2mortal(newSViv((IV)CvXSUB(cv)));
+ ST(0) = sv_2mortal(newSViv(PTR2IV(CvXSUB(cv))));
void
CvXSUBANY(cv)
B::CV cv
CODE:
- ST(0) = sv_2mortal(newSViv(CvXSUBANY(cv).any_iv));
+ ST(0) = CvCONST(cv) ?
+ make_sv_object(aTHX_ sv_newmortal(),CvXSUBANY(cv).any_ptr) :
+ sv_2mortal(newSViv(CvXSUBANY(cv).any_iv));
+
+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
+
MODULE = B PACKAGE = B::HV PREFIX = Hv
I32 len;
(void)hv_iterinit(hv);
EXTEND(sp, HvKEYS(hv) * 2);
- while (sv = hv_iternextsv(hv, &key, &len)) {
- PUSHs(newSVpv(key, len));
- PUSHs(make_sv_object(sv_newmortal(), sv));
+ while ((sv = hv_iternextsv(hv, &key, &len))) {
+ PUSHs(newSVpvn(key, len));
+ PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv));
}
}