#ifdef __cplusplus
extern
"C"
{
#endif
#define PERL_NO_GET_CONTEXT /* we want efficiency */
#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>
#ifdef __cplusplus
}
#endif
#define NEED_newSVpvn_flags
#include "ppport.h"
static
XOP my_xop_tap;
static
XOP my_xop_push_sv;
static
OP *XS_B_Tap_pp_push_sv(pTHX) {
dXSARGS; dORIGMARK;
SV*
const
sv = cSVOP_sv;
SV * tmp = get_sv(
"B::Tap::_TMP"
, GV_ADD);
sv_setsv(tmp, sv);
PUSHMARK(ORIGMARK);
RETURN;
}
static
OP *XS_B_Tap_pp_tap(pTHX) {
dXSARGS; dORIGMARK;
int
i;
SV *tmp;
AV *ret = newAV();
av_push(ret, newSViv(GIMME_V));
if
(GIMME_V == G_SCALAR) {
SvREFCNT_inc(ST(0));
av_push(ret, ST(0));
}
else
if
(GIMME_V == G_VOID) {
}
else
{
AV * av = newAV();
for
(i=0; i<items; i++) {
SvREFCNT_inc(ST(i));
av_push(av, ST(i));
}
av_push(ret, newRV_noinc((SV*)av));
}
tmp = get_sv(
"B::Tap::_TMP"
, GV_ADD);
if
(SvROK(tmp) && SvTYPE(SvRV(tmp)) == SVt_PVAV) {
av_push((AV*)SvRV(tmp), newRV_noinc((SV*)ret));
}
else
{
sv_dump(tmp);
croak(
"ArrayRef is expected, but it's not ArrayRef."
);
}
PUSHMARK(ORIGMARK);
RETURN;
}
static
char
tap_oa_char(
int
oa_class) {
switch
(oa_class) {
case
OA_UNOP:
return
'1'
;
case
OA_BINOP:
return
'2'
;
case
OA_LOGOP:
return
'|'
;
case
OA_LISTOP:
return
'@'
;
case
OA_PMOP:
return
'/'
;
case
OA_SVOP:
return
'$'
;
case
OA_LOOP:
return
'{'
;
case
OA_COP:
return
';'
;
case
OA_PADOP:
return
'#'
;
default
:
return
'-'
;
}
}
#define OP_CLASS_EX(op) \
((op)->op_type == OP_NULL ? (PL_opargs[(op)->op_targ] & OA_CLASS_MASK) : OP_CLASS((op)))
static
char
OA_CHAR(pTHX_ OP *op) {
return
tap_oa_char(OP_CLASS_EX(op));
}
#define TAP_TRACE(op, depth) \
{ \
int
i; \
for
(i=0;i<depth; i++) { \
PerlIO_printf(PerlIO_stderr(),
" "
); \
} \
PerlIO_printf(PerlIO_stderr(),
" rewriting: <%c"
, OA_CHAR(aTHX_ op)); \
PerlIO_printf(PerlIO_stderr(),
"> "
); \
if
(op->op_type == OP_NULL) { \
PerlIO_printf(PerlIO_stderr(),
"ex-%s"
, PL_op_name[op->op_targ]); \
}
else
{ \
PerlIO_printf(PerlIO_stderr(),
"%s"
, OP_NAME(op)); \
} \
PerlIO_printf(PerlIO_stderr(),
"\n"
); \
}
#define RECURSE(next) rewrite_op(aTHX_ (OP*)next, orig, replacement, depth+1)
#define REPLACE(type, meth) \
if
(((type)target)->meth == orig) { \
((type)target)->meth = replacement; \
}
else
{\
RECURSE(((type)target)->meth); \
}
static
void
rewrite_op(pTHX_ OP* target, OP* orig, OP* replacement,
int
depth) {
switch
(OP_CLASS_EX(target)) {
case
OA_UNOP:
REPLACE(UNOP*, op_first);
break
;
case
OA_BINOP:
REPLACE(BINOP*, op_first);
break
;
case
OA_LOGOP:
REPLACE(LOGOP*, op_first);
REPLACE(LOGOP*, op_other);
break
;
case
OA_LISTOP:
REPLACE(LOGOP*, op_first);
break
;
}
if
(target->op_sibling) {
if
(target->op_sibling == orig) {
target->op_sibling = replacement;
}
else
{
rewrite_op(aTHX_ (OP*)target->op_sibling, orig, replacement, depth);
}
}
}
#undef RECURSE
MODULE = B::Tap PACKAGE = B::Tap
PROTOTYPES: DISABLE
BOOT:
XopENTRY_set(&my_xop_tap, xop_name,
"b_tap_tap"
);
XopENTRY_set(&my_xop_tap, xop_desc,
"b_tap_tap"
);
XopENTRY_set(&my_xop_tap, xop_class, OA_BINOP);
Perl_custom_op_register(aTHX_ XS_B_Tap_pp_tap, &my_xop_tap);
XopENTRY_set(&my_xop_push_sv, xop_name,
"b_tap_push_sv"
);
XopENTRY_set(&my_xop_push_sv, xop_desc,
"b_Tap_push_sv"
);
XopENTRY_set(&my_xop_push_sv, xop_class, OA_SVOP);
Perl_custom_op_register(aTHX_ XS_B_Tap_pp_push_sv, &my_xop_push_sv);
HV* stash = gv_stashpvn(
"B::Tap"
,
strlen
(
"B::Tap"
), TRUE);
newCONSTSUB(stash,
"G_SCALAR"
, newSViv(G_SCALAR));
newCONSTSUB(stash,
"G_ARRAY"
, newSViv(G_ARRAY));
newCONSTSUB(stash,
"G_VOID"
, newSViv(G_VOID));
void
_tap(opp, root_opp, buf)
void
* opp;
void
* root_opp;
SV * buf;
CODE:
{
OP * orig_op = (OP*)opp;
OP * next_op = orig_op->op_next;
OP * sibling_op = orig_op->op_sibling;
SVOP * push_sv = (SVOP*)newSVOP(OP_CUSTOM, 0, buf);
push_sv->op_ppaddr = XS_B_Tap_pp_push_sv;
push_sv->op_flags = OPf_WANT_LIST;
push_sv->op_sv = buf;
SvREFCNT_inc(buf);
BINOP * b_tap = (BINOP*)newBINOP(OP_CUSTOM, 0, orig_op, (OP*)push_sv);
b_tap->op_ppaddr = XS_B_Tap_pp_tap;
b_tap->op_flags = (orig_op->op_flags & OPf_WANT) | OPf_KIDS;
b_tap->op_first = orig_op;
b_tap->op_last = (OP*)push_sv;
b_tap->op_sibling = sibling_op;
orig_op->op_next = (OP*)push_sv;
push_sv->op_next = (OP*)b_tap;
b_tap->op_next = next_op;
rewrite_op(aTHX_ (OP*)root_opp, (OP*)orig_op, (OP*)b_tap, 0);
}