1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
|
#include <assert.h>
#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "ppport.h"
static OP *convert_arg(pTHX_ OP *op)
{
OP *op1 = op;
if (op1->op_type != OP_RV2SV)
return op;
SVOP *op2 = (SVOP *) cUNOPx(op)->op_first;
if (op2->op_type != OP_GV)
return op;
GV *gv = cGVOPx_gv(op2);
STRLEN len = GvNAMELEN(gv);
if (len != 1)
return op;
const char *name = GvNAME(gv);
SVOP *newop = NULL;
if (*name == '\017') /* $^O */
newop = (SVOP *) newSVOP(OP_CONST, 0, newSVpvs_share(OSNAME));
if (*name == '\026') /* $^V */
newop = (SVOP *) newSVOP(OP_CONST, 0, new_version(PL_patchlevel));
if (*name == ']') /* $] */
newop = (SVOP *) newSVOP(OP_CONST, 0, vnumify(PL_patchlevel));
if (newop) {
OpMAYBESIB_set(newop, OpSIBLING(op1), op_parent(op1));
newop->op_next = (OP *) newop;
op_free(op);
return (OP *) newop;
}
return op;
}
static OP *my_ck_op(pTHX_ OP *op)
{
OP *argp = cUNOPx(op)->op_first;
OP *prev;
if (!argp)
return op;
cUNOPx(op)->op_first = argp = convert_arg(aTHX_ argp);
while (OpHAS_SIBLING(argp)) {
prev = argp;
argp = OpSIBLING(argp);
argp = convert_arg(aTHX_ argp);
OpMORESIB_set(prev, argp);
}
return op;
}
#define doOPs() \
/* binops */ \
doOP(LT) /* numeric lt (<) */ \
doOP(GT) /* numeric gt (>) */ \
doOP(LE) /* numeric le (<=) */ \
doOP(GE) /* numeric ge (>=) */ \
doOP(EQ) /* numeric eq (==) */ \
doOP(NE) /* numeric ne (!=) */ \
doOP(NCMP) /* numeric comparison (<=>) */ \
doOP(SLT) /* string lt */ \
doOP(SGT) /* string gt */ \
doOP(SLE) /* string le */ \
doOP(SGE) /* string ge */ \
doOP(SEQ) /* string eq */ \
doOP(SNE) /* string ne */ \
doOP(SCMP) /* string comparison (cmp) */
/* make op handlers */
#define doOP(NAME) \
static Perl_check_t orig_ck_ ## NAME; \
static OP *my_ck_ ## NAME(pTHX_ OP *op) { \
return orig_ck_ ## NAME(aTHX_ my_ck_op(aTHX_ op)); \
}
doOPs()
#undef doOP
/* install op handlers */
static void boot_ops()
{
#define doOP(NAME) \
orig_ck_ ## NAME = PL_check[OP_ ## NAME]; \
PL_check[OP_ ## NAME] = my_ck_ ## NAME;
doOPs()
#undef doOP
}
MODULE = B::ConstOptree PACKAGE = B::ConstOptree
BOOT:
boot_ops();
/* ex: set ts=8 sts=4 sw=4 noet: */
|
