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
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
|
/* vi: set ft=c inde=: */
#ifndef av_count
# define av_count(av) (AvFILL(av) + 1)
#endif
#if HAVE_PERL_VERSION(5, 22, 0)
# define PadnameIsNULL(pn) (!(pn))
#else
# define PadnameIsNULL(pn) (!(pn) || (pn) == &PL_sv_undef)
#endif
#ifndef hv_deletes
# define hv_deletes(hv, skey, flags) hv_delete((hv), ("" skey ""), (sizeof(skey) - 1), flags)
#endif
#if HAVE_PERL_VERSION(5, 22, 0)
# define PadnameOUTER_off(pn) (PadnameFLAGS(pn) &= ~PADNAMEt_OUTER)
#else
/* PadnameOUTER is really the SvFAKE flag */
# define PadnameOUTER_off(pn) SvFAKE_off(pn)
#endif
#define save_strndup(s, l) S_save_strndup(aTHX_ s, l)
static char *S_save_strndup(pTHX_ char *s, STRLEN l)
{
/* savepvn doesn't put anything on the save stack, despite its name */
char *ret = savepvn(s, l);
SAVEFREEPV(ret);
return ret;
}
#define sv_setrv(s, r) S_sv_setrv(aTHX_ s, r)
static void S_sv_setrv(pTHX_ SV *sv, SV *rv)
{
sv_setiv(sv, (IV)rv);
#if !HAVE_PERL_VERSION(5, 24, 0)
SvIOK_off(sv);
#endif
SvROK_on(sv);
}
static OP *newPADxVOP(I32 type, PADOFFSET padix, I32 flags, U32 private)
{
OP *op = newOP(type, flags);
op->op_targ = padix;
op->op_private = private;
return op;
}
/* Before perl 5.22 under -DDEBUGGING, various new*OP() functions throw assert
* failures on OP_CUSTOM.
* https://rt.cpan.org/Ticket/Display.html?id=128562
*/
#define newOP_CUSTOM(func, flags) S_newOP_CUSTOM(aTHX_ func, flags)
#define newUNOP_CUSTOM(func, flags, first) S_newUNOP_CUSTOM(aTHX_ func, flags, first)
#define newSVOP_CUSTOM(func, flags, sv) S_newSVOP_CUSTOM(aTHX_ func, flags, sv)
#define newBINOP_CUSTOM(func, flags, first, last) S_newBINOP_CUSTOM(aTHX_ func, flags, first, last)
#define newLOGOP_CUSTOM(func, flags, first, other) S_newLOGOP_CUSTOM(aTHX_ func, flags, first, other)
static OP *S_newOP_CUSTOM(pTHX_ OP *(*func)(pTHX), U32 flags)
{
OP *op = newOP(OP_CUSTOM, flags);
op->op_ppaddr = func;
return op;
}
static OP *S_newUNOP_CUSTOM(pTHX_ OP *(*func)(pTHX), U32 flags, OP *first)
{
UNOP *unop;
#if HAVE_PERL_VERSION(5,22,0)
unop = (UNOP *)newUNOP(OP_CUSTOM, flags, first);
#else
NewOp(1101, unop, 1, UNOP);
unop->op_type = (OPCODE)OP_CUSTOM;
unop->op_first = first;
unop->op_flags = (U8)(flags | OPf_KIDS);
unop->op_private = (U8)(1 | (flags >> 8));
#endif
unop->op_ppaddr = func;
return (OP *)unop;
}
static OP *S_newSVOP_CUSTOM(pTHX_ OP *(*func)(pTHX), U32 flags, SV *sv)
{
SVOP *svop;
#if HAVE_PERL_VERSION(5,22,0)
svop = (SVOP *)newSVOP(OP_CUSTOM, flags, sv);
#else
NewOp(1101, svop, 1, SVOP);
svop->op_type = (OPCODE)OP_CUSTOM;
svop->op_sv = sv;
svop->op_next = (OP *)svop;
svop->op_flags = 0;
svop->op_private = 0;
#endif
svop->op_ppaddr = func;
return (OP *)svop;
}
static OP *S_newBINOP_CUSTOM(pTHX_ OP *(*func)(pTHX), U32 flags, OP *first, OP *last)
{
BINOP *binop;
#if HAVE_PERL_VERSION(5,22,0)
binop = (BINOP *)newBINOP(OP_CUSTOM, flags, first, last);
#else
NewOp(1101, binop, 1, BINOP);
binop->op_type = (OPCODE)OP_CUSTOM;
binop->op_first = first;
first->op_sibling = last;
binop->op_last = last;
binop->op_flags = (U8)(flags | OPf_KIDS);
binop->op_private = (U8)(2 | (flags >> 8));
#endif
binop->op_ppaddr = func;
return (OP *)binop;
}
static OP *S_newLOGOP_CUSTOM(pTHX_ OP *(*func)(pTHX), U32 flags, OP *first, OP *other)
{
OP *o;
#if HAVE_PERL_VERSION(5,22,0)
o = newLOGOP(OP_CUSTOM, flags, first, other);
#else
/* Parts of this code copypasted from perl 5.20.0's op.c S_new_logop()
*/
LOGOP *logop;
first = op_contextualize(first, G_SCALAR);
NewOp(1101, logop, 1, LOGOP);
logop->op_type = (OPCODE)OP_CUSTOM;
logop->op_ppaddr = NULL; /* Because caller only overrides it anyway */
logop->op_first = first;
logop->op_flags = (U8)(flags | OPf_KIDS);
logop->op_other = LINKLIST(other);
/* logop->op_private has nothing interesting for OP_CUSTOM */
/* Link in postfix order */
logop->op_next = LINKLIST(first);
first->op_next = (OP *)logop;
first->op_sibling = other;
/* No CHECKOP for OP_CUSTOM */
o = newUNOP(OP_NULL, 0, (OP *)logop);
other->op_next = o;
#endif
/* the returned op is actually an UNOP that's either NULL or NOT; the real
* logop is the op_next of it
*/
cUNOPx(o)->op_first->op_ppaddr = func;
return o;
}
|
