My favorites | Sign in
Project Home Wiki Issues Source
Repository:
Checkout   Browse   Changes   Clones  
Changes to /ByteLoader/bytecode.h
6d13808c7bc8 vs. deb074e57e61 Compare: vs.  Format:
Revision deb074e57e61
Go to: 
Project members, sign in to write a code review
/ByteLoader/bytecode.h   6d13808c7bc8 /ByteLoader/bytecode.h   deb074e57e61
1 typedef char *pvcontents; 1 typedef char *pvcontents;
2 typedef char *strconst; 2 typedef char *strconst;
3 typedef U32 PV; /* hack */ 3 typedef U32 PV; /* hack */
4 typedef char *op_tr_array; 4 typedef char *op_tr_array;
5 typedef int comment_t; 5 typedef int comment_t;
6 typedef SV *svindex; 6 typedef SV *svindex;
7 typedef OP *opindex; 7 typedef OP *opindex;
8 typedef char *pvindex; 8 typedef char *pvindex;
9 /*typedef HEK *hekindex;*/ 9 /*typedef HEK *hekindex;*/
10 typedef IV IV64; 10 typedef IV IV64;
11 #if PERL_VERSION < 13 11 #if PERL_VERSION < 13
12 typedef U16 pmflags; 12 typedef U16 pmflags;
13 #else 13 #else
14 typedef U32 pmflags; 14 typedef U32 pmflags;
15 #endif 15 #endif
16 16
17 17
18 static int force = 0; 18 static int force = 0;
19 /* need to swab bytes to the target byteorder */ 19 /* need to swab bytes to the target byteorder */
20 static int bget_swab = 0; 20 static int bget_swab = 0;
21 21
22 #if (PERL_VERSION <= 8) && (PERL_SUBVERSION < 8) 22 #if (PERL_VERSION <= 8) && (PERL_SUBVERSION < 8)
23 #include "ppport.h" 23 #include "ppport.h"
24 #endif 24 #endif
25 25
26 #ifndef GvCV_set 26 #ifndef GvCV_set
27 # define GvCV_set(gv,cv) (GvCV(gv) = (cv)) 27 # define GvCV_set(gv,cv) (GvCV(gv) = (cv))
28 #endif 28 #endif
29 #ifndef GvGP_set 29 #ifndef GvGP_set
30 # define GvGP_set(gv,gp) (GvGP(gv) = (gp)) 30 # define GvGP_set(gv,gp) (GvGP(gv) = (gp))
31 #endif 31 #endif
32 32
33 #define BGET_FREAD(argp, len, nelem) \ 33 #define BGET_FREAD(argp, len, nelem) \
34 bl_read(bstate->bs_fdata,(char*)(argp),(len),(nelem)) 34 bl_read(bstate->bs_fdata,(char*)(argp),(len),(nelem))
35 #define BGET_FGETC() bl_getc(bstate->bs_fdata) 35 #define BGET_FGETC() bl_getc(bstate->bs_fdata)
36 36
37 #define BGET_U8(arg) STMT_START { \ 37 #define BGET_U8(arg) STMT_START { \
38 const int _arg = BGET_FGETC(); \ 38 const int _arg = BGET_FGETC(); \
39 if (_arg < 0) { \ 39 if (_arg < 0) { \
40 Perl_croak(aTHX_ \ 40 Perl_croak(aTHX_ \
41 "EOF or error while trying to read 1 byte for U8"); \ 41 "EOF or error while trying to read 1 byte for U8"); \
42 } \ 42 } \
43 arg = (U8) _arg; \ 43 arg = (U8) _arg; \
44 } STMT_END 44 } STMT_END
45 45
46 /* with platform conversion from bl_header. */ 46 /* with platform conversion from bl_header. */
47 #define BGET_U16(arg) STMT_START { \ 47 #define BGET_U16(arg) STMT_START { \
48 BGET_OR_CROAK(arg, U16); \ 48 BGET_OR_CROAK(arg, U16); \
49 if (bget_swab) {arg=_swab_16_(arg);} \ 49 if (bget_swab) {arg=_swab_16_(arg);} \
50 } STMT_END 50 } STMT_END
51 #define BGET_I32(arg) STMT_START { \ 51 #define BGET_I32(arg) STMT_START { \
52 BGET_OR_CROAK(arg, U32); \ 52 BGET_OR_CROAK(arg, U32); \
53 if (bget_swab) {arg=_swab_32_(arg);} \ 53 if (bget_swab) {arg=_swab_32_(arg);} \
54 } STMT_END 54 } STMT_END
55 #define BGET_U32(arg) STMT_START { \ 55 #define BGET_U32(arg) STMT_START { \
56 BGET_OR_CROAK(arg, U32); \ 56 BGET_OR_CROAK(arg, U32); \
57 if (bget_swab) {arg=_swab_32_(arg);} \ 57 if (bget_swab) {arg=_swab_32_(arg);} \
58 } STMT_END 58 } STMT_END
59 #define BGET_IV(arg) STMT_START { \ 59 #define BGET_IV(arg) STMT_START { \
60 if (BGET_FREAD(&arg, bl_header.ivsize, 1) < 1) { \ 60 if (BGET_FREAD(&arg, bl_header.ivsize, 1) < 1) { \
61 Perl_croak(aTHX_ \ 61 Perl_croak(aTHX_ \
62 "EOF or error while trying to read %d bytes for %s", \ 62 "EOF or error while trying to read %d bytes for %s", \
63 bl_header.ivsize, "IV"); \ 63 bl_header.ivsize, "IV"); \
64 } \ 64 } \
65 if (bl_header.ivsize != IVSIZE) { \ 65 if (bl_header.ivsize != IVSIZE) { \
66 Perl_warn(aTHX_ \ 66 Perl_warn(aTHX_ \
67 "Different IVSIZE: .plc %d, perl %d", \ 67 "Different IVSIZE: .plc %d, perl %d", \
68 bl_header.ivsize, IVSIZE); \ 68 bl_header.ivsize, IVSIZE); \
69 } \ 69 } \
70 if (bget_swab) {arg = _swab_iv_(arg, IVSIZE);} \ 70 if (bget_swab) {arg = _swab_iv_(arg, IVSIZE);} \
71 } STMT_END 71 } STMT_END
72 /* 72 /*
73 * In the following, sizeof(IV)*4 is just a way of encoding 32 on 64-bit-IV 73 * In the following, sizeof(IV)*4 is just a way of encoding 32 on 64-bit-IV
74 * machines such that 32-bit machine compilers don't whine about the shift 74 * machines such that 32-bit machine compilers don't whine about the shift
75 * count being too high even though the code is never reached there. 75 * count being too high even though the code is never reached there.
76 */ 76 */
77 #define BGET_IV64(arg) STMT_START { \ 77 #define BGET_IV64(arg) STMT_START { \
78 U32 hi, lo; \ 78 U32 hi, lo; \
79 BGET_U32(hi); \ 79 BGET_U32(hi); \
80 BGET_U32(lo); \ 80 BGET_U32(lo); \
81 if (bget_swab) { U32 tmp=hi; hi=lo; lo=tmp; } \ 81 if (bget_swab) { U32 tmp=hi; hi=lo; lo=tmp; } \
82 if (sizeof(IV) == 8) { \ 82 if (sizeof(IV) == 8) { \
83 arg = ((IV)hi << (sizeof(IV)*4) | (IV)lo); \ 83 arg = ((IV)hi << (sizeof(IV)*4) | (IV)lo); \
84 } else if (((I32)hi == -1 && (I32)lo < 0) \ 84 } else if (((I32)hi == -1 && (I32)lo < 0) \
85 || ((I32)hi == 0 && (I32)lo >= 0)) { \ 85 || ((I32)hi == 0 && (I32)lo >= 0)) { \
86 arg = (I32)lo; \ 86 arg = (I32)lo; \
87 } \ 87 } \
88 else { \ 88 else { \
89 bstate->bs_iv_overflows++; \ 89 bstate->bs_iv_overflows++; \
90 arg = 0; \ 90 arg = 0; \
91 } \ 91 } \
92 } STMT_END 92 } STMT_END
93 93
94 #define BGET_PADOFFSET(arg) STMT_START { \ 94 #define BGET_PADOFFSET(arg) STMT_START { \
95 BGET_OR_CROAK(arg, PADOFFSET); \ 95 BGET_OR_CROAK(arg, PADOFFSET); \
96 if (bget_swab) { \ 96 if (bget_swab) { \
97 arg=(sizeof(PADOFFSET)==4)?_swab_32_(arg):_swab_64_(arg); } \ 97 arg=(sizeof(PADOFFSET)==4)?_swab_32_(arg):_swab_64_(arg); } \
98 } STMT_END 98 } STMT_END
99 99
100 #define BGET_long(arg) STMT_START { \ 100 #define BGET_long(arg) STMT_START { \
101 if (BGET_FREAD(&arg, bl_header.longsize, 1) < 1) { \ 101 if (BGET_FREAD(&arg, bl_header.longsize, 1) < 1) { \
102 Perl_croak(aTHX_ \ 102 Perl_croak(aTHX_ \
103 "EOF or error while trying to read %d bytes for %s", \ 103 "EOF or error while trying to read %d bytes for %s", \
104 bl_header.ivsize, "IV"); \ 104 bl_header.ivsize, "IV"); \
105 } \ 105 } \
106 if (bget_swab) { arg = _swab_iv_(arg, bl_header.longsize); } \ 106 if (bget_swab) { arg = _swab_iv_(arg, bl_header.longsize); } \
107 if (bl_header.longsize != LONGSIZE) { \ 107 if (bl_header.longsize != LONGSIZE) { \
108 Perl_warn(aTHX_ \ 108 Perl_warn(aTHX_ \
109 "Different LONGSIZE .plc %d, perl %d", \ 109 "Different LONGSIZE .plc %d, perl %d", \
110 bl_header.longsize, LONGSIZE); \ 110 bl_header.longsize, LONGSIZE); \
111 } \ 111 } \
112 } STMT_END 112 } STMT_END
113 113
114 /* svtype is an enum of 16 values. 32bit or 16bit? */ 114 /* svtype is an enum of 16 values. 32bit or 16bit? */
115 #define BGET_svtype(arg) STMT_START { \ 115 #define BGET_svtype(arg) STMT_START { \
116 BGET_OR_CROAK(arg, svtype); \ 116 BGET_OR_CROAK(arg, svtype); \
117 if (bget_swab) {arg = _swab_iv_(arg, sizeof(svtype))} \ 117 if (bget_swab) {arg = _swab_iv_(arg, sizeof(svtype))} \
118 } STMT_END 118 } STMT_END
119 119
120 #define BGET_OR_CROAK(arg, type) STMT_START { \ 120 #define BGET_OR_CROAK(arg, type) STMT_START { \
121 if (BGET_FREAD(&arg, sizeof(type), 1) < 1) { \ 121 if (BGET_FREAD(&arg, sizeof(type), 1) < 1) { \
122 Perl_croak(aTHX_ \ 122 Perl_croak(aTHX_ \
123 "EOF or error while trying to read %lu bytes for %s", \ 123 "EOF or error while trying to read %lu bytes for %s", \
124 sizeof(type), STRINGIFY(type)); \ 124 sizeof(type), STRINGIFY(type)); \
125 } \ 125 } \
126 } STMT_END 126 } STMT_END
127 127
128 #define BGET_PV(arg) STMT_START { \ 128 #define BGET_PV(arg) STMT_START { \
129 BGET_U32(arg); \ 129 BGET_U32(arg); \
130 if (arg) { \ 130 if (arg) { \
131 New(666, bstate->bs_pv.xpv_pv, (U32)arg, char); \ 131 New(666, bstate->bs_pv.xpv_pv, (U32)arg, char); \
132 bl_read(bstate->bs_fdata, bstate->bs_pv.xpv_pv, (U32)arg, 1); \ 132 bl_read(bstate->bs_fdata, bstate->bs_pv.xpv_pv, (U32)arg, 1); \
133 bstate->bs_pv.xpv_len = (U32)arg; \ 133 bstate->bs_pv.xpv_len = (U32)arg; \
134 bstate->bs_pv.xpv_cur = (U32)arg - 1; \ 134 bstate->bs_pv.xpv_cur = (U32)arg - 1; \
135 } else { \ 135 } else { \
136 bstate->bs_pv.xpv_pv = 0; \ 136 bstate->bs_pv.xpv_pv = 0; \
137 bstate->bs_pv.xpv_len = 0; \ 137 bstate->bs_pv.xpv_len = 0; \
138 bstate->bs_pv.xpv_cur = 0; \ 138 bstate->bs_pv.xpv_cur = 0; \
139 } \ 139 } \
140 } STMT_END 140 } STMT_END
141 141
142 #ifdef BYTELOADER_LOG_COMMENTS 142 #ifdef BYTELOADER_LOG_COMMENTS
143 # define BGET_comment_t(arg) \ 143 # define BGET_comment_t(arg) \
144 STMT_START { \ 144 STMT_START { \
145 char buf[1024]; \ 145 char buf[1024]; \
146 int i = 0; \ 146 int i = 0; \
147 do { \ 147 do { \
148 arg = BGET_FGETC(); \ 148 arg = BGET_FGETC(); \
149 buf[i++] = (char)arg; \ 149 buf[i++] = (char)arg; \
150 } while (arg != '\n' && arg != EOF); \ 150 } while (arg != '\n' && arg != EOF); \
151 buf[i] = '\0'; \ 151 buf[i] = '\0'; \
152 PerlIO_printf(PerlIO_stderr(), "%s", buf); \ 152 PerlIO_printf(PerlIO_stderr(), "%s", buf); \
153 } STMT_END 153 } STMT_END
154 #else 154 #else
155 # define BGET_comment_t(arg) \ 155 # define BGET_comment_t(arg) \
156 do { arg = BGET_FGETC(); } while (arg != '\n' && arg != EOF) 156 do { arg = BGET_FGETC(); } while (arg != '\n' && arg != EOF)
157 #endif 157 #endif
158 158
159 #define BGET_op_tr_array(arg) do { \ 159 #define BGET_op_tr_array(arg) do { \
160 unsigned short *ary, len; \ 160 unsigned short *ary, len; \
161 BGET_U16(len); \ 161 BGET_U16(len); \
162 New(666, ary, len, unsigned short); \ 162 New(666, ary, len, unsigned short); \
163 BGET_FREAD(ary, sizeof(unsigned short), len); \ 163 BGET_FREAD(ary, sizeof(unsigned short), len); \
164 arg = (char *) ary; \ 164 arg = (char *) ary; \
165 } while (0) 165 } while (0)
166 166
167 #define BGET_pvcontents(arg) arg = bstate->bs_pv.xpv_pv 167 #define BGET_pvcontents(arg) arg = bstate->bs_pv.xpv_pv
168 /* read until \0. optionally limit the max stringsize for buffer overflow attempts */ 168 /* read until \0. optionally limit the max stringsize for buffer overflow attempts */
169 #define BGET_strconst(arg, maxsize) STMT_START { \ 169 #define BGET_strconst(arg, maxsize) STMT_START { \
170 char *end = NULL; \ 170 char *end = NULL; \
171 if (maxsize) { end = PL_tokenbuf+maxsize; } \ 171 if (maxsize) { end = PL_tokenbuf+maxsize; } \
172 for (arg = PL_tokenbuf; \ 172 for (arg = PL_tokenbuf; \
173 (*arg = BGET_FGETC()) && (maxsize ? arg<end : 1); \ 173 (*arg = BGET_FGETC()) && (maxsize ? arg<end : 1); \
174 arg++) /* nothing */; \ 174 arg++) /* nothing */; \
175 arg = PL_tokenbuf; \ 175 arg = PL_tokenbuf; \
176 } STMT_END 176 } STMT_END
177 177
178 #define BGET_NV(arg) STMT_START { \ 178 #define BGET_NV(arg) STMT_START { \
179 char *str; \ 179 char *str; \
180 BGET_strconst(str,80); \ 180 BGET_strconst(str,80); \
181 arg = Atof(str); \ 181 arg = Atof(str); \
182 } STMT_END 182 } STMT_END
183 183
184 #define BGET_objindex(arg, type) STMT_START { \ 184 #define BGET_objindex(arg, type) STMT_START { \
185 BGET_U32(ix); \ 185 BGET_U32(ix); \
186 arg = (type)bstate->bs_obj_list[ix]; \ 186 arg = (type)bstate->bs_obj_list[ix]; \
187 } STMT_END 187 } STMT_END
188 #define BGET_svindex(arg) BGET_objindex(arg, svindex) 188 #define BGET_svindex(arg) BGET_objindex(arg, svindex)
189 #define BGET_opindex(arg) BGET_objindex(arg, opindex) 189 #define BGET_opindex(arg) BGET_objindex(arg, opindex)
190 /*#define BGET_hekindex(arg) BGET_objindex(arg, hekindex)*/ 190 /*#define BGET_hekindex(arg) BGET_objindex(arg, hekindex)*/
191 #define BGET_pvindex(arg) STMT_START { \ 191 #define BGET_pvindex(arg) STMT_START { \
192 BGET_objindex(arg, pvindex); \ 192 BGET_objindex(arg, pvindex); \
193 arg = arg ? savepv(arg) : arg; \ 193 arg = arg ? savepv(arg) : arg; \
194 } STMT_END 194 } STMT_END
195 /* old bytecode compiler only had U16, new reads U32 since 5.13 */ 195 /* old bytecode compiler only had U16, new reads U32 since 5.13 */
196 #define BGET_pmflags(arg) STMT_START { \ 196 #define BGET_pmflags(arg) STMT_START { \
197 if (strncmp(bl_header.version,"0.07",4)>=0) { \ 197 if (strncmp(bl_header.version,"0.07",4)>=0) { \
198 if (strncmp(bl_header.perlversion,"5.013",5)>=0) { \ 198 if (strncmp(bl_header.perlversion,"5.013",5)>=0) { \
199 BGET_U32(arg); \ 199 BGET_U32(arg); \
200 } else { \ 200 } else { \
201 BGET_U16(arg); \ 201 BGET_U16(arg); \
202 } \ 202 } \
203 } else { \ 203 } else { \
204 BGET_U16(arg); \ 204 BGET_U16(arg); \
205 } \ 205 } \
206 } STMT_END 206 } STMT_END
207 207
208 #define BSET_ldspecsv(sv, arg) STMT_START { \ 208 #define BSET_ldspecsv(sv, arg) STMT_START { \
209 if(arg >= sizeof(specialsv_list) / sizeof(specialsv_list[0])) { \ 209 if(arg >= sizeof(specialsv_list) / sizeof(specialsv_list[0])) { \
210 Perl_croak(aTHX_ "Out of range special SV number %d", arg); \ 210 Perl_croak(aTHX_ "Out of range special SV number %d", arg); \
211 } \ 211 } \
212 sv = specialsv_list[arg]; \ 212 sv = specialsv_list[arg]; \
213 } STMT_END 213 } STMT_END
214 214
215 #define BSET_ldspecsvx(sv, arg) STMT_START { \ 215 #define BSET_ldspecsvx(sv, arg) STMT_START { \
216 BSET_ldspecsv(sv, arg); \ 216 BSET_ldspecsv(sv, arg); \
217 BSET_OBJ_STOREX(sv); \ 217 BSET_OBJ_STOREX(sv); \
218 } STMT_END 218 } STMT_END
219 219
220 #define BSET_stpv(pv, arg) STMT_START { \ 220 #define BSET_stpv(pv, arg) STMT_START { \
221 BSET_OBJ_STORE(pv, arg); \ 221 BSET_OBJ_STORE(pv, arg); \
222 SAVEFREEPV(pv); \ 222 SAVEFREEPV(pv); \
223 } STMT_END 223 } STMT_END
224 224
225 #define BSET_sv_refcnt_add(svrefcnt, arg) svrefcnt += arg 225 #define BSET_sv_refcnt_add(svrefcnt, arg) svrefcnt += arg
226 #define BSET_gp_refcnt_add(gprefcnt, arg) gprefcnt += arg 226 #define BSET_gp_refcnt_add(gprefcnt, arg) gprefcnt += arg
227 #define BSET_gp_share(sv, arg) STMT_START { \ 227 #define BSET_gp_share(sv, arg) STMT_START { \
228 gp_free((GV*)sv); \ 228 gp_free((GV*)sv); \
229 GvGP_set(sv, GvGP(arg)); \ 229 GvGP_set(sv, GvGP(arg)); \
230 } STMT_END 230 } STMT_END
231 231
232 /* New GV's are stored as HE+HEK, which is alloc'ed anew */ 232 /* New GV's are stored as HE+HEK, which is alloc'ed anew */
233 #define BSET_gv_fetchpv(sv, arg) sv = (SV*)gv_fetchpv(savepv(arg), GV_ADD, SVt_PV) 233 #define BSET_gv_fetchpv(sv, arg) sv = (SV*)gv_fetchpv(savepv(arg), GV_ADD, SVt_PV)
234 #define BSET_gv_fetchpvx(sv, arg) STMT_START { \ 234 #define BSET_gv_fetchpvx(sv, arg) STMT_START { \
235 BSET_gv_fetchpv(sv, arg); \ 235 BSET_gv_fetchpv(sv, arg); \
236 BSET_OBJ_STOREX(sv); \ 236 BSET_OBJ_STOREX(sv); \
237 } STMT_END 237 } STMT_END
238 #define BSET_gv_fetchpvn_flags(sv, arg) STMT_START { \ 238 #define BSET_gv_fetchpvn_flags(sv, arg) STMT_START { \
239 int flags = (arg & 0xff80) >> 7; int type = arg & 0x7f; \ 239 int flags = (arg & 0xff80) >> 7; int type = arg & 0x7f; \
240 sv = (SV*)gv_fetchpv(savepv(bstate->bs_pv.xpv_pv), flags, type); \ 240 sv = (SV*)gv_fetchpv(savepv(bstate->bs_pv.xpv_pv), flags, type); \
241 BSET_OBJ_STOREX(sv); \ 241 BSET_OBJ_STOREX(sv); \
242 } STMT_END 242 } STMT_END
243 243
244 #define BSET_gv_stashpv(sv, arg) sv = (SV*)gv_stashpv(arg, GV_ADD) 244 #define BSET_gv_stashpv(sv, arg) sv = (SV*)gv_stashpv(arg, GV_ADD)
245 #define BSET_gv_stashpvx(sv, arg) STMT_START { \ 245 #define BSET_gv_stashpvx(sv, arg) STMT_START { \
246 BSET_gv_stashpv(sv, arg); \ 246 BSET_gv_stashpv(sv, arg); \
247 BSET_OBJ_STOREX(sv); \ 247 BSET_OBJ_STOREX(sv); \
248 } STMT_END 248 } STMT_END
249 249
250 #define BSET_sv_magic(sv, arg) sv_magic(sv, Nullsv, arg, 0, 0) 250 #define BSET_sv_magic(sv, arg) sv_magic(sv, Nullsv, arg, 0, 0)
251 /* mg_name was previously called mg_pv. we keep the new name and the old index */ 251 /* mg_name was previously called mg_pv. we keep the new name and the old index */
252 #define BSET_mg_name(mg, arg) mg->mg_ptr = arg; mg->mg_len = bstate->bs_pv.xpv_cur 252 #define BSET_mg_name(mg, arg) mg->mg_ptr = arg; mg->mg_len = bstate->bs_pv.xpv_cur
253 #define BSET_mg_namex(mg, arg) \ 253 #define BSET_mg_namex(mg, arg) \
254 (mg->mg_ptr = (char*)SvREFCNT_inc((SV*)arg), \ 254 (mg->mg_ptr = (char*)SvREFCNT_inc((SV*)arg), \
255 mg->mg_len = HEf_SVKEY) 255 mg->mg_len = HEf_SVKEY)
256 #define BSET_xmg_stash(sv, arg) *(SV**)&(((XPVMG*)SvANY(sv))->xmg_stash) = (arg) 256 #define BSET_xmg_stash(sv, arg) *(SV**)&(((XPVMG*)SvANY(sv))->xmg_stash) = (arg)
257 #define BSET_sv_upgrade(sv, arg) (void)SvUPGRADE(sv, arg) 257 #define BSET_sv_upgrade(sv, arg) (void)SvUPGRADE(sv, arg)
258 #define BSET_xrv(sv, arg) SvRV_set(sv, arg) 258 #define BSET_xrv(sv, arg) SvRV_set(sv, arg)
259 #define BSET_xpv(sv) do { \ 259 #define BSET_xpv(sv) do { \
260 SvPV_set(sv, bstate->bs_pv.xpv_pv); \ 260 SvPV_set(sv, bstate->bs_pv.xpv_pv); \
261 SvCUR_set(sv, bstate->bs_pv.xpv_cur); \ 261 SvCUR_set(sv, bstate->bs_pv.xpv_cur); \
262 SvLEN_set(sv, bstate->bs_pv.xpv_len); \ 262 SvLEN_set(sv, bstate->bs_pv.xpv_len); \
263 } while (0) 263 } while (0)
264 #if PERL_VERSION > 8 264 #if PERL_VERSION > 8
265 #define BSET_xpvshared(sv) do { \ 265 #define BSET_xpvshared(sv) do { \
266 U32 hash; \ 266 U32 hash; \
267 PERL_HASH(hash, bstate->bs_pv.xpv_pv, bstate->bs_pv.xpv_cur); \ 267 PERL_HASH(hash, bstate->bs_pv.xpv_pv, bstate->bs_pv.xpv_cur); \
268 SvPV_set(sv, HEK_KEY(share_hek(bstate->bs_pv.xpv_pv,bstate->bs_pv.xpv_cur,hash))); \ 268 SvPV_set(sv, HEK_KEY(share_hek(bstate->bs_pv.xpv_pv,bstate->bs_pv.xpv_cur,hash))); \
269 SvCUR_set(sv, bstate->bs_pv.xpv_cur); \ 269 SvCUR_set(sv, bstate->bs_pv.xpv_cur); \
270 SvLEN_set(sv, 0); \ 270 SvLEN_set(sv, 0); \
271 } while (0) 271 } while (0)
272 #else 272 #else
273 #define BSET_xpvshared(sv) BSET_xpv(sv) 273 #define BSET_xpvshared(sv) BSET_xpv(sv)
274 #endif 274 #endif
275 #define BSET_xpv_cur(sv, arg) SvCUR_set(sv, arg) 275 #define BSET_xpv_cur(sv, arg) SvCUR_set(sv, arg)
276 #define BSET_xpv_len(sv, arg) SvLEN_set(sv, arg) 276 #define BSET_xpv_len(sv, arg) SvLEN_set(sv, arg)
277 #define BSET_xiv(sv, arg) SvIV_set(sv, arg) 277 #define BSET_xiv(sv, arg) SvIV_set(sv, arg)
278 #define BSET_xnv(sv, arg) SvNV_set(sv, arg) 278 #define BSET_xnv(sv, arg) SvNV_set(sv, arg)
279 279
280 #define BSET_av_extend(sv, arg) av_extend((AV*)sv, arg) 280 #define BSET_av_extend(sv, arg) av_extend((AV*)sv, arg)
281 281
282 #define BSET_av_push(sv, arg) av_push((AV*)sv, arg) 282 #define BSET_av_push(sv, arg) av_push((AV*)sv, arg)
283 #define BSET_av_pushx(sv, arg) (AvARRAY(sv)[++AvFILLp(sv)] = arg) 283 #define BSET_av_pushx(sv, arg) (AvARRAY(sv)[++AvFILLp(sv)] = arg)
284 #define BSET_hv_store(sv, arg) \ 284 #define BSET_hv_store(sv, arg) \
285 hv_store((HV*)sv, bstate->bs_pv.xpv_pv, bstate->bs_pv.xpv_cur, arg, 0) 285 hv_store((HV*)sv, bstate->bs_pv.xpv_pv, bstate->bs_pv.xpv_cur, arg, 0)
286 #define BSET_pv_free(pv) Safefree(pv.xpv_pv) 286 #define BSET_pv_free(pv) Safefree(pv.xpv_pv)
287 287
288 #if PERL_VERSION > 13 || defined(CvGV_set) 288 #if PERL_VERSION > 13 || defined(CvGV_set)
289 #define BSET_xcv_gv(sv, arg) ((SvANY((CV*)bstate->bs_sv))->xcv_gv = (GV*)arg) 289 #define BSET_xcv_gv(sv, arg) ((SvANY((CV*)bstate->bs_sv))->xcv_gv = (GV*)arg)
290 #else 290 #else
291 #define BSET_xcv_gv(sv, arg) (*(SV**)&CvGV(bstate->bs_sv) = arg) 291 #define BSET_xcv_gv(sv, arg) (*(SV**)&CvGV(bstate->bs_sv) = arg)
292 #endif 292 #endif
293 #if PERL_VERSION > 13 || defined(GvCV_set) 293 #if PERL_VERSION > 13 || defined(GvCV_set)
294 #define BSET_gp_cv(sv, arg) GvCV_set(bstate->bs_sv, (CV*)arg) 294 #define BSET_gp_cv(sv, arg) GvCV_set(bstate->bs_sv, (CV*)arg)
295 #else 295 #else
296 #define BSET_gp_cv(sv, arg) (*(SV**)&GvCV(bstate->bs_sv) = arg) 296 #define BSET_gp_cv(sv, arg) (*(SV**)&GvCV(bstate->bs_sv) = arg)
297 #endif 297 #endif
298 #if PERL_VERSION > 13 || defined(CvSTASH_set) 298 #if PERL_VERSION > 13 || defined(CvSTASH_set)
299 #define BSET_xcv_stash(sv, arg) (CvSTASH_set((CV*)bstate->bs_sv, (HV*)arg)) 299 #define BSET_xcv_stash(sv, arg) (CvSTASH_set((CV*)bstate->bs_sv, (HV*)arg))
300 #else 300 #else
301 #define BSET_xcv_stash(sv, arg) (*(SV**)&CvSTASH(bstate->bs_sv) = arg) 301 #define BSET_xcv_stash(sv, arg) (*(SV**)&CvSTASH(bstate->bs_sv) = arg)
302 #endif 302 #endif
303 303
304 #ifdef USE_ITHREADS 304 #ifdef USE_ITHREADS
305 305
306 /* Copied after the code in newPMOP(). 306 /* Copied after the code in newPMOP().
307 Since 5.13d PM_SETRE(op, NULL) fails 307 Since 5.13d PM_SETRE(op, NULL) fails
308 */ 308 */
309 #if (PERL_VERSION >= 11) 309 #if (PERL_VERSION >= 11)
310 #define BSET_pregcomp(o, arg) \ 310 #define BSET_pregcomp(o, arg) \
311 STMT_START { \ 311 STMT_START { \
312 if (arg) { \ 312 if (arg) { \
313 SV * const repointer = &PL_sv_undef; \ 313 SV * const repointer = &PL_sv_undef; \
314 av_push(PL_regex_padav, repointer); \ 314 av_push(PL_regex_padav, repointer); \
315 cPMOPx(o)->op_pmoffset = av_len(PL_regex_padav); \ 315 cPMOPx(o)->op_pmoffset = av_len(PL_regex_padav); \
316 PL_regex_pad = AvARRAY(PL_regex_padav); \ 316 PL_regex_pad = AvARRAY(PL_regex_padav); \
317 PM_SETRE(cPMOPx(o), \ 317 PM_SETRE(cPMOPx(o), \
318 CALLREGCOMP(newSVpvn(arg, strlen(arg)), cPMOPx(o)->op_pmflags)); \ 318 CALLREGCOMP(newSVpvn(arg, strlen(arg)), cPMOPx(o)->op_pmflags)); \
319 if (SvCUR(PL_regex_pad[0])) { \
320 SV * const repointer = PL_regex_pad[0]; \
321 if (SvCUR(repointer) % sizeof(IV)) { \
322 SvCUR_set(repointer, SvEND(repointer)); \
323 } \
324 } \
325 } \ 319 } \
326 } STMT_END 320 } STMT_END
327 #endif 321 #endif
328 #if (PERL_VERSION >= 10) && (PERL_VERSION < 11) 322 #if (PERL_VERSION >= 10) && (PERL_VERSION < 11)
329 /* see op.c:newPMOP 323 /* see op.c:newPMOP
330 * Must use a SV now. build it on the fly from the given pv. 324 * Must use a SV now. build it on the fly from the given pv.
331 * TODO: 5.11 could use newSVpvn_flags with SVf_TEMP 325 * TODO: 5.11 could use newSVpvn_flags with SVf_TEMP
332 * PM_SETRE does not adjust PL_regex_pad, so repoint manually. 326 * PM_SETRE does not adjust PL_regex_pad, so repoint manually.
333 */ 327 */
334 #define BSET_pregcomp(o, arg) \ 328 #define BSET_pregcomp(o, arg) \
335 STMT_START { \ 329 STMT_START { \
336 SV* repointer; \ 330 SV* repointer; \
337 REGEXP* rx = arg \ 331 REGEXP* rx = arg \
338 ? CALLREGCOMP(newSVpvn(arg, strlen(arg)), cPMOPx(o)->op_pmflags) \ 332 ? CALLREGCOMP(newSVpvn(arg, strlen(arg)), cPMOPx(o)->op_pmflags) \
339 : Null(REGEXP*); \ 333 : Null(REGEXP*); \
340 if(av_len((AV*)PL_regex_pad[0]) > -1) { \ 334 if(av_len((AV*)PL_regex_pad[0]) > -1) { \
341 repointer = av_pop((AV*)PL_regex_pad[0]); \ 335 repointer = av_pop((AV*)PL_regex_pad[0]); \
342 cPMOPx(o)->op_pmoffset = SvIV(repointer); \ 336 cPMOPx(o)->op_pmoffset = SvIV(repointer); \
343 SvREPADTMP_off(repointer); \ 337 SvREPADTMP_off(repointer); \
344 sv_setiv(repointer, PTR2IV(rx)); \ 338 sv_setiv(repointer, PTR2IV(rx)); \
345 } else { \ 339 } else { \
346 repointer = newSViv(PTR2IV(rx)); \ 340 repointer = newSViv(PTR2IV(rx)); \
347 av_push(PL_regex_padav, SvREFCNT_inc(repointer)); \ 341 av_push(PL_regex_padav, SvREFCNT_inc(repointer)); \
348 cPMOPx(o)->op_pmoffset = av_len(PL_regex_padav); \ 342 cPMOPx(o)->op_pmoffset = av_len(PL_regex_padav); \
349 PL_regex_pad = AvARRAY(PL_regex_padav); \ 343 PL_regex_pad = AvARRAY(PL_regex_padav); \
350 } \ 344 } \
351 } STMT_END 345 } STMT_END
352 #endif 346 #endif
353 /* 5.8 and earlier had no PM_SETRE, so repoint manually */ 347 /* 5.8 and earlier had no PM_SETRE, so repoint manually */
354 #if (PERL_VERSION > 7) && (PERL_VERSION < 10) 348 #if (PERL_VERSION > 7) && (PERL_VERSION < 10)
355 #define BSET_pregcomp(o, arg) \ 349 #define BSET_pregcomp(o, arg) \
356 STMT_START { \ 350 STMT_START { \
357 SV* repointer; \ 351 SV* repointer; \
358 REGEXP* rx = arg \ 352 REGEXP* rx = arg \
359 ? CALLREGCOMP(aTHX_ arg, arg + bstate->bs_pv.xpv_cur, cPMOPx(o)) \ 353 ? CALLREGCOMP(aTHX_ arg, arg + bstate->bs_pv.xpv_cur, cPMOPx(o)) \
360 : Null(REGEXP*); \ 354 : Null(REGEXP*); \
361 if(av_len((AV*)PL_regex_pad[0]) > -1) { \ 355 if(av_len((AV*)PL_regex_pad[0]) > -1) { \
362 repointer = av_pop((AV*)PL_regex_pad[0]); \ 356 repointer = av_pop((AV*)PL_regex_pad[0]); \
363 cPMOPx(o)->op_pmoffset = SvIV(repointer); \ 357 cPMOPx(o)->op_pmoffset = SvIV(repointer); \
364 SvREPADTMP_off(repointer); \ 358 SvREPADTMP_off(repointer); \
365 sv_setiv(repointer, PTR2IV(rx)); \ 359 sv_setiv(repointer, PTR2IV(rx)); \
366 } else { \ 360 } else { \
367 repointer = newSViv(PTR2IV(rx)); \ 361 repointer = newSViv(PTR2IV(rx)); \
368 av_push(PL_regex_padav, SvREFCNT_inc(repointer)); \ 362 av_push(PL_regex_padav, SvREFCNT_inc(repointer)); \
369 cPMOPx(o)->op_pmoffset = av_len(PL_regex_padav); \ 363 cPMOPx(o)->op_pmoffset = av_len(PL_regex_padav); \
370 PL_regex_pad = AvARRAY(PL_regex_padav); \ 364 PL_regex_pad = AvARRAY(PL_regex_padav); \
371 } \ 365 } \
372 } STMT_END 366 } STMT_END
373 367
374 #endif 368 #endif
375 369
376 #else /* ! USE_ITHREADS */ 370 #else /* ! USE_ITHREADS */
377 371
378 #if (PERL_VERSION >= 8) && (PERL_VERSION < 10) 372 #if (PERL_VERSION >= 8) && (PERL_VERSION < 10)
379 /* PM_SETRE only since 5.8 */ 373 /* PM_SETRE only since 5.8 */
380 #define BSET_pregcomp(o, arg) \ 374 #define BSET_pregcomp(o, arg) \
381 STMT_START { \ 375 STMT_START { \
382 (((PMOP*)o)->op_pmregexp = (arg \ 376 (((PMOP*)o)->op_pmregexp = (arg \
383 ? CALLREGCOMP(aTHX_ arg, arg + bstate->bs_pv.xpv_cur, cPMOPx(o)) \ 377 ? CALLREGCOMP(aTHX_ arg, arg + bstate->bs_pv.xpv_cur, cPMOPx(o)) \
384 : Null(REGEXP*))); \ 378 : Null(REGEXP*))); \
385 } STMT_END 379 } STMT_END
386 #endif 380 #endif
387 #if (PERL_VERSION >= 10) 381 #if (PERL_VERSION >= 10)
388 #define BSET_pregcomp(o, arg) \ 382 #define BSET_pregcomp(o, arg) \
389 STMT_START { \ 383 STMT_START { \
390 if (arg) { \ 384 if (arg) { \
391 PM_SETRE((PMOP*)(o), \ 385 PM_SETRE((PMOP*)(o), \
392 CALLREGCOMP(newSVpvn(arg, strlen(arg)), cPMOPx(o)->op_pmflags)); \ 386 CALLREGCOMP(newSVpvn(arg, strlen(arg)), cPMOPx(o)->op_pmflags)); \
393 } \ 387 } \
394 } STMT_END 388 } STMT_END
395 #endif 389 #endif
396 390
397 #endif /* USE_ITHREADS */ 391 #endif /* USE_ITHREADS */
398 392
399 #if PERL_VERSION < 8 393 #if PERL_VERSION < 8
400 #define BSET_pregcomp(o, arg) \ 394 #define BSET_pregcomp(o, arg) \
401 ((PMOP*)o)->op_pmregexp = arg \ 395 ((PMOP*)o)->op_pmregexp = arg \
402 ? CALLREGCOMP(aTHX_ arg, arg + bstate->bs_pv.xpv_cur, ((PMOP*)o)) : 0 396 ? CALLREGCOMP(aTHX_ arg, arg + bstate->bs_pv.xpv_cur, ((PMOP*)o)) : 0
403 #endif 397 #endif
404 398
405 399
406 #define BSET_newsv(sv, arg) \ 400 #define BSET_newsv(sv, arg) \
407 switch(arg) { \ 401 switch(arg) { \
408 case SVt_PVAV: \ 402 case SVt_PVAV: \
409 sv = (SV*)newAV(); \ 403 sv = (SV*)newAV(); \
410 break; \ 404 break; \
411 case SVt_PVHV: \ 405 case SVt_PVHV: \
412 sv = (SV*)newHV(); \ 406 sv = (SV*)newHV(); \
413 break; \ 407 break; \
414 default: \ 408 default: \
415 sv = newSV(0); \ 409 sv = newSV(0); \
416 SvUPGRADE(sv, (arg)); \ 410 SvUPGRADE(sv, (arg)); \
417 } 411 }
418 #define BSET_newsvx(sv, arg) STMT_START { \ 412 #define BSET_newsvx(sv, arg) STMT_START { \
419 BSET_newsv(sv, arg & SVTYPEMASK); \ 413 BSET_newsv(sv, arg & SVTYPEMASK); \
420 SvFLAGS(sv) = arg; \ 414 SvFLAGS(sv) = arg; \
421 BSET_OBJ_STOREX(sv); \ 415 BSET_OBJ_STOREX(sv); \
422 } STMT_END 416 } STMT_END
423 417
424 #if (PERL_VERSION > 6) 418 #if (PERL_VERSION > 6)
425 #define BSET_newop(o, size) NewOpSz(666, o, size) 419 #define BSET_newop(o, size) NewOpSz(666, o, size)
426 #else 420 #else
427 #define BSET_newop(o, size) (o=(OP*)safemalloc(size), memzero(o, size)) 421 #define BSET_newop(o, size) (o=(OP*)safemalloc(size), memzero(o, size))
428 #endif 422 #endif
429 /* arg is encoded as type <<7 and size */ 423 /* arg is encoded as type <<7 and size */
430 #define BSET_newopx(o, arg) STMT_START { \ 424 #define BSET_newopx(o, arg) STMT_START { \
431 register int size = arg & 0x7f; \ 425 register int size = arg & 0x7f; \
432 register OP* newop; \ 426 register OP* newop; \
433 BSET_newop(newop, size); \ 427 BSET_newop(newop, size); \
434 /* newop->op_next = o; XXX */ \ 428 /* newop->op_next = o; XXX */ \
435 o = newop; \ 429 o = newop; \
436 arg >>= 7; \ 430 arg >>= 7; \
437 BSET_op_type(o, arg); \ 431 BSET_op_type(o, arg); \
438 BSET_OBJ_STOREX(o); \ 432 BSET_OBJ_STOREX(o); \
439 } STMT_END 433 } STMT_END
440 434
441 #define BSET_newopn(o, arg) STMT_START { \ 435 #define BSET_newopn(o, arg) STMT_START { \
442 OP *oldop = o; \ 436 OP *oldop = o; \
443 BSET_newop(o, arg); \ 437 BSET_newop(o, arg); \
444 oldop->op_next = o; \ 438 oldop->op_next = o; \
445 } STMT_END 439 } STMT_END
446 440
447 #define BSET_ret(foo) STMT_START { \ 441 #define BSET_ret(foo) STMT_START { \
448 Safefree(bstate->bs_obj_list); \ 442 Safefree(bstate->bs_obj_list); \
449 return 0; \ 443 return 0; \
450 } STMT_END 444 } STMT_END
451 445
452 #define BSET_op_pmstashpv(op, arg) PmopSTASHPV_set(op, arg) 446 #define BSET_op_pmstashpv(op, arg) PmopSTASHPV_set(op, arg)
453 447
454 /* 448 /*
455 * stolen from toke.c: better if that was a function. 449 * stolen from toke.c: better if that was a function.
456 * in toke.c there are also #ifdefs for dosish systems and i/o layers 450 * in toke.c there are also #ifdefs for dosish systems and i/o layers
457 */ 451 */
458 452
459 #if defined(HAS_FCNTL) && defined(F_SETFD) 453 #if defined(HAS_FCNTL) && defined(F_SETFD)
460 #define set_clonex(fp) \ 454 #define set_clonex(fp) \
461 STMT_START { \ 455 STMT_START { \
462 int fd = PerlIO_fileno(fp); \ 456 int fd = PerlIO_fileno(fp); \
463 fcntl(fd,F_SETFD,fd >= 3); \ 457 fcntl(fd,F_SETFD,fd >= 3); \
464 } STMT_END 458 } STMT_END
465 #else 459 #else
466 #define set_clonex(fp) 460 #define set_clonex(fp)
467 #endif 461 #endif
468 462
469 #ifndef PL_preprocess 463 #ifndef PL_preprocess
470 #define PL_preprocess 0 464 #define PL_preprocess 0
471 #endif 465 #endif
472 466
473 #define BSET_data(dummy,arg) \ 467 #define BSET_data(dummy,arg) \
474 STMT_START { \ 468 STMT_START { \
475 GV *gv; \ 469 GV *gv; \
476 char *pname = "main"; \ 470 char *pname = "main"; \
477 if (arg == 'D') \ 471 if (arg == 'D') \
478 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash); \ 472 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash); \
479 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), GV_ADD, SVt_PVIO);\ 473 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), GV_ADD, SVt_PVIO);\
480 GvMULTI_on(gv); \ 474 GvMULTI_on(gv); \
481 if (!GvIO(gv)) \ 475 if (!GvIO(gv)) \
482 GvIOp(gv) = newIO(); \ 476 GvIOp(gv) = newIO(); \
483 IoIFP(GvIOp(gv)) = PL_RSFP; \ 477 IoIFP(GvIOp(gv)) = PL_RSFP; \
484 set_clonex(PL_RSFP); \ 478 set_clonex(PL_RSFP); \
485 /* Mark this internal pseudo-handle as clean */ \ 479 /* Mark this internal pseudo-handle as clean */ \
486 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT; \ 480 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT; \
487 if ((PERL_VERSION < 11) && PL_preprocess) \ 481 if ((PERL_VERSION < 11) && PL_preprocess) \
488 IoTYPE(GvIOp(gv)) = IoTYPE_PIPE; \ 482 IoTYPE(GvIOp(gv)) = IoTYPE_PIPE; \
489 else if ((PerlIO*)PL_RSFP == PerlIO_stdin()) \ 483 else if ((PerlIO*)PL_RSFP == PerlIO_stdin()) \
490 IoTYPE(GvIOp(gv)) = IoTYPE_STD; \ 484 IoTYPE(GvIOp(gv)) = IoTYPE_STD; \
491 else \ 485 else \
492 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY; \ 486 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY; \
493 Safefree(bstate->bs_obj_list); \ 487 Safefree(bstate->bs_obj_list); \
494 return 1; \ 488 return 1; \
495 } STMT_END 489 } STMT_END
496 490
497 /* stolen from op.c */ 491 /* stolen from op.c */
498 #define BSET_load_glob(foo, gv) \ 492 #define BSET_load_glob(foo, gv) \
499 STMT_START { \ 493 STMT_START { \
500 GV *glob_gv; \ 494 GV *glob_gv; \
501 ENTER; \ 495 ENTER; \
502 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, \ 496 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, \
503 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv); \ 497 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv); \
504 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV); \ 498 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV); \
505 GvCV_set(gv, GvCV(glob_gv)); \ 499 GvCV_set(gv, GvCV(glob_gv)); \
506 SvREFCNT_inc((SV*)GvCV(gv)); \ 500 SvREFCNT_inc((SV*)GvCV(gv)); \
507 GvIMPORTED_CV_on(gv); \ 501 GvIMPORTED_CV_on(gv); \
508 LEAVE; \ 502 LEAVE; \
509 } STMT_END 503 } STMT_END
510 504
511 /* 505 /*
512 * Kludge special-case workaround for OP_MAPSTART 506 * Kludge special-case workaround for OP_MAPSTART
513 * which needs the ppaddr for OP_GREPSTART. Blech. 507 * which needs the ppaddr for OP_GREPSTART. Blech.
514 */ 508 */
515 #define BSET_op_type(o, arg) STMT_START { \ 509 #define BSET_op_type(o, arg) STMT_START { \
516 o->op_type = arg; \ 510 o->op_type = arg; \
517 if (arg == OP_MAPSTART) \ 511 if (arg == OP_MAPSTART) \
518 arg = OP_GREPSTART; \ 512 arg = OP_GREPSTART; \
519 o->op_ppaddr = PL_ppaddr[arg]; \ 513 o->op_ppaddr = PL_ppaddr[arg]; \
520 } STMT_END 514 } STMT_END
521 #define BSET_op_ppaddr(o, arg) Perl_croak(aTHX_ "op_ppaddr not yet implemented") 515 #define BSET_op_ppaddr(o, arg) Perl_croak(aTHX_ "op_ppaddr not yet implemented")
522 #define BSET_curpad(pad, arg) STMT_START { \ 516 #define BSET_curpad(pad, arg) STMT_START { \
523 PL_comppad = (AV *)arg; \ 517 PL_comppad = (AV *)arg; \
524 PL_curpad = AvARRAY(arg); \ 518 PL_curpad = AvARRAY(arg); \
525 } STMT_END 519 } STMT_END
526 520
527 #ifdef USE_ITHREADS 521 #ifdef USE_ITHREADS
528 #define BSET_cop_file(cop, arg) CopFILE_set(cop,arg) 522 #define BSET_cop_file(cop, arg) CopFILE_set(cop,arg)
529 #define BSET_cop_stashpv(cop, arg) CopSTASHPV_set(cop,arg) 523 #define BSET_cop_stashpv(cop, arg) CopSTASHPV_set(cop,arg)
530 /* only warn, not croak, because those are not really important. stash could be. */ 524 /* only warn, not croak, because those are not really important. stash could be. */
531 #define BSET_cop_filegv(cop, arg) Perl_warn(aTHX_ "cop_filegv with ITHREADS not yet implemented") 525 #define BSET_cop_filegv(cop, arg) Perl_warn(aTHX_ "cop_filegv with ITHREADS not yet implemented")
532 #define BSET_cop_stash(cop,arg) Perl_warn(aTHX_ "cop_stash with ITHREADS not yet implemented") 526 #define BSET_cop_stash(cop,arg) Perl_warn(aTHX_ "cop_stash with ITHREADS not yet implemented")
533 #else 527 #else
534 /* this works now that Sarathy's changed the CopFILE_set macro to do the SvREFCNT_inc() 528 /* this works now that Sarathy's changed the CopFILE_set macro to do the SvREFCNT_inc()
535 -- BKS 6-2-2000 */ 529 -- BKS 6-2-2000 */
536 /* that really meant the actual CopFILEGV_set */ 530 /* that really meant the actual CopFILEGV_set */
537 #define BSET_cop_filegv(cop, arg) CopFILEGV_set(cop,arg) 531 #define BSET_cop_filegv(cop, arg) CopFILEGV_set(cop,arg)
538 #define BSET_cop_stash(cop,arg) CopSTASH_set(cop,(HV*)arg) 532 #define BSET_cop_stash(cop,arg) CopSTASH_set(cop,(HV*)arg)
539 #define BSET_cop_file(cop, arg) Perl_warn(aTHX_ "cop_file without ITHREADS not yet implemented") 533 #define BSET_cop_file(cop, arg) Perl_warn(aTHX_ "cop_file without ITHREADS not yet implemented")
540 #define BSET_cop_stashpv(cop, arg) Perl_warn(aTHX_ "cop_stashpv without ITHREADS not yet implemented") 534 #define BSET_cop_stashpv(cop, arg) Perl_warn(aTHX_ "cop_stashpv without ITHREADS not yet implemented")
541 #endif 535 #endif
542 #if PERL_VERSION < 11 536 #if PERL_VERSION < 11
543 # define BSET_cop_label(cop, arg) (cop)->cop_label = arg 537 # define BSET_cop_label(cop, arg) (cop)->cop_label = arg
544 #else 538 #else
545 /* See op.c:Perl_newSTATEOP. Test 21 */ 539 /* See op.c:Perl_newSTATEOP. Test 21 */
546 # if (PERL_VERSION < 13) || ((PERL_VERSION == 13) && (PERL_SUBVERSION < 5)) 540 # if (PERL_VERSION < 13) || ((PERL_VERSION == 13) && (PERL_SUBVERSION < 5))
547 # if defined(_WIN32) || defined(AIX) 541 # if defined(_WIN32) || defined(AIX)
548 # define BSET_cop_label(cop, arg) /* Unlucky. Not exported with 5.12 and 5.14 */ 542 # define BSET_cop_label(cop, arg) /* Unlucky. Not exported with 5.12 and 5.14 */
549 /* XXX Check in Makefile.PL if patched. cygwin has -Wl=export-all-symbols */ 543 /* XXX Check in Makefile.PL if patched. cygwin has -Wl=export-all-symbols */
550 # error "cop_label is not part of the public API for your perl. Try a perl <5.12 or >5.15" 544 # error "cop_label is not part of the public API for your perl. Try a perl <5.12 or >5.15"
551 # else 545 # else
552 # define BSET_cop_label(cop, arg) (cop)->cop_hints_hash = \ 546 # define BSET_cop_label(cop, arg) (cop)->cop_hints_hash = \
553 Perl_store_cop_label(aTHX_ (cop)->cop_hints_hash, arg) 547 Perl_store_cop_label(aTHX_ (cop)->cop_hints_hash, arg)
554 # endif 548 # endif
555 # else /* officially added with 5.15.1 aebc0cbee */ 549 # else /* officially added with 5.15.1 aebc0cbee */
556 # if (PERL_VERSION > 15) || ((PERL_VERSION == 15) && (PERL_SUBVERSION > 0)) 550 # if (PERL_VERSION > 15) || ((PERL_VERSION == 15) && (PERL_SUBVERSION > 0))
557 # define BSET_cop_label(cop, arg) Perl_cop_store_label(aTHX_ (cop), arg, strlen(arg), 0) 551 # define BSET_cop_label(cop, arg) Perl_cop_store_label(aTHX_ (cop), arg, strlen(arg), 0)
558 # else 552 # else
559 /* changed (macro -> function) with 5.13.4-5 a77ac40c5b8. Windows still out of luck. 553 /* changed (macro -> function) with 5.13.4-5 a77ac40c5b8. Windows still out of luck.
560 XXX Check in Makefile.PL if patched. cygwin has -Wl=export-all-symbols */ 554 XXX Check in Makefile.PL if patched. cygwin has -Wl=export-all-symbols */
561 # if defined(_WIN32) || defined(AIX) 555 # if defined(_WIN32) || defined(AIX)
562 # define BSET_cop_label(cop, arg) 556 # define BSET_cop_label(cop, arg)
563 # error "cop_label is not part of the public API for your perl. Try a perl <5.12 or >5.15" 557 # error "cop_label is not part of the public API for your perl. Try a perl <5.12 or >5.15"
564 # else 558 # else
565 # define BSET_cop_label(cop, arg) Perl_store_cop_label(aTHX_ (cop), arg, strlen(arg), 0) 559 # define BSET_cop_label(cop, arg) Perl_store_cop_label(aTHX_ (cop), arg, strlen(arg), 0)
566 # endif 560 # endif
567 # endif 561 # endif
568 # endif 562 # endif
569 #endif 563 #endif
570 564
571 /* This is stolen from the code in newATTRSUB() */ 565 /* This is stolen from the code in newATTRSUB() */
572 #if PERL_VERSION < 10 566 #if PERL_VERSION < 10
573 #define PL_HINTS_PRIVATE (PL_hints & HINT_PRIVATE_MASK) 567 #define PL_HINTS_PRIVATE (PL_hints & HINT_PRIVATE_MASK)
574 #else 568 #else
575 /* Hints are now stored in a dedicated U32, so the bottom 8 bits are no longer 569 /* Hints are now stored in a dedicated U32, so the bottom 8 bits are no longer
576 special and there is no need for HINT_PRIVATE_MASK for COPs. */ 570 special and there is no need for HINT_PRIVATE_MASK for COPs. */
577 #define PL_HINTS_PRIVATE (PL_hints) 571 #define PL_HINTS_PRIVATE (PL_hints)
578 #endif 572 #endif
579 573
580 #if (PERL_VERSION < 8) 574 #if (PERL_VERSION < 8)
581 /* this is simply stolen from the code in newATTRSUB() */ 575 /* this is simply stolen from the code in newATTRSUB() */
582 #define BSET_push_begin(ary,cv) \ 576 #define BSET_push_begin(ary,cv) \
583 STMT_START { \ 577 STMT_START { \
584 I32 oldscope = PL_scopestack_ix; \ 578 I32 oldscope = PL_scopestack_ix; \
585 ENTER; \ 579 ENTER; \
586 SAVECOPFILE(&PL_compiling); \ 580 SAVECOPFILE(&PL_compiling); \
587 SAVECOPLINE(&PL_compiling); \ 581 SAVECOPLINE(&PL_compiling); \
588 save_svref(&PL_rs); \ 582 save_svref(&PL_rs); \
589 sv_setsv(PL_rs, PL_nrs); \ 583 sv_setsv(PL_rs, PL_nrs); \
590 if (!PL_beginav) \ 584 if (!PL_beginav) \
591 PL_beginav = newAV(); \ 585 PL_beginav = newAV(); \
592 av_push(PL_beginav, cv); \ 586 av_push(PL_beginav, cv); \
593 call_list(oldscope, PL_beginav); \ 587 call_list(oldscope, PL_beginav); \
594 PL_curcop = &PL_compiling; \ 588 PL_curcop = &PL_compiling; \
595 PL_compiling.op_private = PL_hints; \ 589 PL_compiling.op_private = PL_hints; \
596 LEAVE; \ 590 LEAVE; \
597 } STMT_END 591 } STMT_END
598 #endif 592 #endif
599 #if (PERL_VERSION >= 8) && (PERL_VERSION < 10) 593 #if (PERL_VERSION >= 8) && (PERL_VERSION < 10)
600 #define BSET_push_begin(ary,cv) \ 594 #define BSET_push_begin(ary,cv) \
601 STMT_START { \ 595 STMT_START { \
602 I32 oldscope = PL_scopestack_ix; \ 596 I32 oldscope = PL_scopestack_ix; \
603 ENTER; \ 597 ENTER; \
604 SAVECOPFILE(&PL_compiling); \ 598 SAVECOPFILE(&PL_compiling); \
605 SAVECOPLINE(&PL_compiling); \ 599 SAVECOPLINE(&PL_compiling); \
606 if (!PL_beginav) \ 600 if (!PL_beginav) \
607 PL_beginav = newAV(); \ 601 PL_beginav = newAV(); \
608 av_push(PL_beginav, (SV*)cv); \ 602 av_push(PL_beginav, (SV*)cv); \
609 GvCV(CvGV(cv)) = 0; /* cv has been hijacked */\ 603 GvCV(CvGV(cv)) = 0; /* cv has been hijacked */\
610 call_list(oldscope, PL_beginav); \ 604 call_list(oldscope, PL_beginav); \
611 PL_curcop = &PL_compiling; \ 605 PL_curcop = &PL_compiling; \
612 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);\ 606 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);\
613 LEAVE; \ 607 LEAVE; \
614 } STMT_END 608 } STMT_END
615 #endif 609 #endif
616 #if (PERL_VERSION >= 10) 610 #if (PERL_VERSION >= 10)
617 #define BSET_push_begin(ary,cv) \ 611 #define BSET_push_begin(ary,cv) \
618 STMT_START { \ 612 STMT_START { \
619 I32 oldscope = PL_scopestack_ix; \ 613 I32 oldscope = PL_scopestack_ix; \
620 ENTER; \ 614 ENTER; \
621 SAVECOPFILE(&PL_compiling); \ 615 SAVECOPFILE(&PL_compiling); \
622 SAVECOPLINE(&PL_compiling); \ 616 SAVECOPLINE(&PL_compiling); \
623 if (!PL_beginav) \ 617 if (!PL_beginav) \
624 PL_beginav = newAV(); \ 618 PL_beginav = newAV(); \
625 av_push(PL_beginav, (SV*)cv); \ 619 av_push(PL_beginav, (SV*)cv); \
626 SvANY((CV*)cv)->xcv_gv = 0;/* cv has been hijacked */ \ 620 SvANY((CV*)cv)->xcv_gv = 0;/* cv has been hijacked */ \
627 call_list(oldscope, PL_beginav); \ 621 call_list(oldscope, PL_beginav); \
628 PL_curcop = &PL_compiling; \ 622 PL_curcop = &PL_compiling; \
629 CopHINTS_set(&PL_compiling, (U8)PL_HINTS_PRIVATE); \ 623 CopHINTS_set(&PL_compiling, (U8)PL_HINTS_PRIVATE); \
630 LEAVE; \ 624 LEAVE; \
631 } STMT_END 625 } STMT_END
632 #endif 626 #endif
633 #define BSET_push_init(ary,cv) \ 627 #define BSET_push_init(ary,cv) \
634 STMT_START { \ 628 STMT_START { \
635 av_unshift((PL_initav ? PL_initav : \ 629 av_unshift((PL_initav ? PL_initav : \
636 (PL_initav = newAV(), PL_initav)), 1); \ 630 (PL_initav = newAV(), PL_initav)), 1); \
637 av_store(PL_initav, 0, cv); \ 631 av_store(PL_initav, 0, cv); \
638 } STMT_END 632 } STMT_END
639 #define BSET_push_end(ary,cv) \ 633 #define BSET_push_end(ary,cv) \
640 STMT_START { \ 634 STMT_START { \
641 av_unshift((PL_endav ? PL_endav : \ 635 av_unshift((PL_endav ? PL_endav : \
642 (PL_endav = newAV(), PL_endav)), 1); \ 636 (PL_endav = newAV(), PL_endav)), 1); \
643 av_store(PL_endav, 0, cv); \ 637 av_store(PL_endav, 0, cv); \
644 } STMT_END 638 } STMT_END
645 #define BSET_OBJ_STORE(obj, ix) \ 639 #define BSET_OBJ_STORE(obj, ix) \
646 ((I32)ix > bstate->bs_obj_list_fill ? \ 640 ((I32)ix > bstate->bs_obj_list_fill ? \
647 bset_obj_store(aTHX_ bstate, obj, (I32)ix) : \ 641 bset_obj_store(aTHX_ bstate, obj, (I32)ix) : \
648 (bstate->bs_obj_list[ix] = obj), \ 642 (bstate->bs_obj_list[ix] = obj), \
649 bstate->bs_ix = ix+1) 643 bstate->bs_ix = ix+1)
650 #define BSET_OBJ_STOREX(obj) \ 644 #define BSET_OBJ_STOREX(obj) \
651 (bstate->bs_ix > bstate->bs_obj_list_fill ? \ 645 (bstate->bs_ix > bstate->bs_obj_list_fill ? \
652 bset_obj_store(aTHX_ bstate, obj, bstate->bs_ix) : \ 646 bset_obj_store(aTHX_ bstate, obj, bstate->bs_ix) : \
653 (bstate->bs_obj_list[bstate->bs_ix] = obj), \ 647 (bstate->bs_obj_list[bstate->bs_ix] = obj), \
654 bstate->bs_ix++) 648 bstate->bs_ix++)
655 649
656 #define BSET_signal(cv, name) \ 650 #define BSET_signal(cv, name) \
657 mg_set(*hv_store(GvHV(gv_fetchpv("SIG", GV_ADD, SVt_PVHV)), \ 651 mg_set(*hv_store(GvHV(gv_fetchpv("SIG", GV_ADD, SVt_PVHV)), \
658 name, strlen(name), cv, 0)) 652 name, strlen(name), cv, 0))
659 /* 5.008? */ 653 /* 5.008? */
660 #ifndef hv_name_set 654 #ifndef hv_name_set
661 #define hv_name_set(hv,name,length,flags) \ 655 #define hv_name_set(hv,name,length,flags) \
662 (HvNAME((hv)) = (name) ? savepvn(name, length) : 0) 656 (HvNAME((hv)) = (name) ? savepvn(name, length) : 0)
663 #endif 657 #endif
664 #define BSET_xhv_name(hv, name) hv_name_set((HV*)hv, name, strlen(name), 0) 658 #define BSET_xhv_name(hv, name) hv_name_set((HV*)hv, name, strlen(name), 0)
665 #define BSET_cop_arybase(c, b) CopARYBASE_set(c, b) 659 #define BSET_cop_arybase(c, b) CopARYBASE_set(c, b)
666 #if PERL_VERSION < 10 660 #if PERL_VERSION < 10
667 #define BSET_cop_warnings(c, sv) c->cop_warnings = sv; 661 #define BSET_cop_warnings(c, sv) c->cop_warnings = sv;
668 #else 662 #else
669 #define BSET_cop_warnings(c, w) \ 663 #define BSET_cop_warnings(c, w) \
670 STMT_START { \ 664 STMT_START { \
671 if (specialWARN((STRLEN *)w)) { \ 665 if (specialWARN((STRLEN *)w)) { \
672 c->cop_warnings = (STRLEN *)w; \ 666 c->cop_warnings = (STRLEN *)w; \
673 } else { \ 667 } else { \
674 STRLEN len; \ 668 STRLEN len; \
675 const char *const p = SvPV_const(w, len); \ 669 const char *const p = SvPV_const(w, len); \
676 c->cop_warnings = \ 670 c->cop_warnings = \
677 Perl_new_warnings_bitfield(aTHX_ NULL, p, len); \ 671 Perl_new_warnings_bitfield(aTHX_ NULL, p, len); \
678 SvREFCNT_dec(w); \ 672 SvREFCNT_dec(w); \
679 } \ 673 } \
680 } STMT_END 674 } STMT_END
681 #endif 675 #endif
682 676
683 #if PERL_VERSION < 10 677 #if PERL_VERSION < 10
684 #define BSET_gp_sv(gv, arg) GvSV((GV*)gv) = arg 678 #define BSET_gp_sv(gv, arg) GvSV((GV*)gv) = arg
685 #else 679 #else
686 #define BSET_gp_sv(gv, arg) \ 680 #define BSET_gp_sv(gv, arg) \
687 isGV_with_GP_on((GV*)gv); \ 681 isGV_with_GP_on((GV*)gv); \
688 GvSVn((GV*)gv) = arg 682 GvSVn((GV*)gv) = arg
689 #endif 683 #endif
690 684
691 #if PERL_VERSION < 10 685 #if PERL_VERSION < 10
692 # define BSET_gp_file(gv, file) GvFILE((GV*)gv) = file 686 # define BSET_gp_file(gv, file) GvFILE((GV*)gv) = file
693 #else 687 #else
694 /* unshare_hek not public */ 688 /* unshare_hek not public */
695 # if defined(WIN32) 689 # if defined(WIN32)
696 # define BSET_gp_file(gv, file) \ 690 # define BSET_gp_file(gv, file) \
697 STMT_START { \ 691 STMT_START { \
698 STRLEN len = strlen(file); \ 692 STRLEN len = strlen(file); \
699 U32 hash; \ 693 U32 hash; \
700 PERL_HASH(hash, file, len); \ 694 PERL_HASH(hash, file, len); \
701 GvFILE_HEK(gv) = share_hek(file, len, hash); \ 695 GvFILE_HEK(gv) = share_hek(file, len, hash); \
702 Safefree(file); \ 696 Safefree(file); \
703 } STMT_END 697 } STMT_END
704 # else 698 # else
705 # define BSET_gp_file(gv, file) \ 699 # define BSET_gp_file(gv, file) \
706 STMT_START { \ 700 STMT_START { \
707 STRLEN len = strlen(file); \ 701 STRLEN len = strlen(file); \
708 U32 hash; \ 702 U32 hash; \
709 PERL_HASH(hash, file, len); \ 703 PERL_HASH(hash, file, len); \
710 if(GvFILE_HEK(gv)) { \ 704 if(GvFILE_HEK(gv)) { \
711 Perl_unshare_hek(aTHX_ GvFILE_HEK(gv)); \ 705 Perl_unshare_hek(aTHX_ GvFILE_HEK(gv)); \
712 } \ 706 } \
713 GvFILE_HEK(gv) = share_hek(file, len, hash); \ 707 GvFILE_HEK(gv) = share_hek(file, len, hash); \
714 Safefree(file); \ 708 Safefree(file); \
715 } STMT_END 709 } STMT_END
716 # endif 710 # endif
717 #endif 711 #endif
718 712
719 /* old reading new + new reading old */ 713 /* old reading new + new reading old */
720 #define BSET_op_pmflags(r, arg) STMT_START { \ 714 #define BSET_op_pmflags(r, arg) STMT_START { \
721 r = arg; \ 715 r = arg; \
722 } STMT_END 716 } STMT_END
723 717
724 /* restore dups for stdin, stdout and stderr */ 718 /* restore dups for stdin, stdout and stderr */
725 #define BSET_xio_ifp(sv,fd) \ 719 #define BSET_xio_ifp(sv,fd) \
726 STMT_START { \ 720 STMT_START { \
727 if (fd == 0) { \ 721 if (fd == 0) { \
728 IoIFP(sv) = IoOFP(sv) = PerlIO_stdin(); \ 722 IoIFP(sv) = IoOFP(sv) = PerlIO_stdin(); \
729 } else if (fd == 1) { \ 723 } else if (fd == 1) { \
730 IoIFP(sv) = IoOFP(sv) = PerlIO_stdout(); \ 724 IoIFP(sv) = IoOFP(sv) = PerlIO_stdout(); \
731 } else if (fd == 2) { \ 725 } else if (fd == 2) { \
732 IoIFP(sv) = IoOFP(sv) = PerlIO_stderr(); \ 726 IoIFP(sv) = IoOFP(sv) = PerlIO_stderr(); \
733 } \ 727 } \
734 } STMT_END 728 } STMT_END
735 729
736 730
737 /* NOTE: The bytecode header only sanity-checks the bytecode. If a script cares about 731 /* NOTE: The bytecode header only sanity-checks the bytecode. If a script cares about
738 * what version of Perl it's being called under, it should do a 'use 5.006_001' or 732 * what version of Perl it's being called under, it should do a 'use 5.006_001' or
739 * equivalent. However, since the header includes checks required an exact match in 733 * equivalent. However, since the header includes checks required an exact match in
740 * ByteLoader versions (we can't guarantee forward compatibility), you don't 734 * ByteLoader versions (we can't guarantee forward compatibility), you don't
741 * need to specify one. 735 * need to specify one.
742 * use ByteLoader; 736 * use ByteLoader;
743 * is all you need. 737 * is all you need.
744 * -- BKS, June 2000 738 * -- BKS, June 2000
745 * TODO: Want to guarantee backwards compatibility. -- rurban 2008-02 739 * TODO: Want to guarantee backwards compatibility. -- rurban 2008-02
746 * Just need to verify the valid opcode version table (syntax enhancement 8-10 ?), 740 * Just need to verify the valid opcode version table (syntax enhancement 8-10 ?),
747 * the perl opnum table and to define the converters. 741 * the perl opnum table and to define the converters.
748 */ 742 */
749 743
750 #define HEADER_FAIL(f) \ 744 #define HEADER_FAIL(f) \
751 Perl_croak(aTHX_ "ERROR Invalid bytecode: " f) 745 Perl_croak(aTHX_ "ERROR Invalid bytecode: " f)
752 #define HEADER_FAIL1(f, arg1) \ 746 #define HEADER_FAIL1(f, arg1) \
753 Perl_croak(aTHX_ "ERROR Invalid bytecode: " f, arg1) 747 Perl_croak(aTHX_ "ERROR Invalid bytecode: " f, arg1)
754 #define HEADER_FAIL2(f, arg1, arg2) \ 748 #define HEADER_FAIL2(f, arg1, arg2) \
755 Perl_croak(aTHX_ "ERROR Invalid bytecode: " f, arg1, arg2) 749 Perl_croak(aTHX_ "ERROR Invalid bytecode: " f, arg1, arg2)
756 #define HEADER_WARN(f) \ 750 #define HEADER_WARN(f) \
757 Perl_warn(aTHX_ "WARNING Convert bytecode: " f) 751 Perl_warn(aTHX_ "WARNING Convert bytecode: " f)
758 #define HEADER_WARN1(f, arg1) \ 752 #define HEADER_WARN1(f, arg1) \
759 Perl_warn(aTHX_ "WARNING Convert bytecode: " f, arg1) 753 Perl_warn(aTHX_ "WARNING Convert bytecode: " f, arg1)
760 #define HEADER_WARN2(f, arg1, arg2) \ 754 #define HEADER_WARN2(f, arg1, arg2) \
761 Perl_warn(aTHX_ "WARNING Convert bytecode: " f, arg1, arg2) 755 Perl_warn(aTHX_ "WARNING Convert bytecode: " f, arg1, arg2)
762 756
763 /* 757 /*
764 * Local variables: 758 * Local variables:
765 * c-indent-level: 4 759 * c-indent-level: 4
766 * End: 760 * End:
767 * vim: expandtab shiftwidth=4: 761 * vim: expandtab shiftwidth=4:
768 */ 762 */
Powered by Google Project Hosting