Commit | Line | Data |
---|---|---|
a8a597b2 MB |
1 | /* B.xs |
2 | * | |
3 | * Copyright (c) 1996 Malcolm Beattie | |
4 | * | |
5 | * You may distribute under the terms of either the GNU General Public | |
6 | * License or the Artistic License, as specified in the README file. | |
7 | * | |
8 | */ | |
9 | ||
c5be433b | 10 | #define PERL_NO_GET_CONTEXT |
fedf30e1 | 11 | #define PERL_EXT |
a8a597b2 MB |
12 | #include "EXTERN.h" |
13 | #include "perl.h" | |
14 | #include "XSUB.h" | |
a8a597b2 | 15 | |
51aa15f3 GS |
16 | #ifdef PerlIO |
17 | typedef PerlIO * InputStream; | |
18 | #else | |
19 | typedef FILE * InputStream; | |
20 | #endif | |
21 | ||
22 | ||
27da23d5 | 23 | static const char* const svclassnames[] = { |
a8a597b2 | 24 | "B::NULL", |
38d2280f RU |
25 | #if PERL_VERSION < 19 |
26 | "B::BIND", | |
27 | #endif | |
1cb9cd50 | 28 | "B::IV", |
b53eecb4 | 29 | "B::NV", |
4df7f6af NC |
30 | #if PERL_VERSION <= 10 |
31 | "B::RV", | |
32 | #endif | |
a8a597b2 | 33 | "B::PV", |
38d2280f | 34 | #if PERL_VERSION >= 19 |
e94d9b54 | 35 | "B::INVLIST", |
38d2280f | 36 | #endif |
a8a597b2 MB |
37 | "B::PVIV", |
38 | "B::PVNV", | |
39 | "B::PVMG", | |
4df7f6af | 40 | #if PERL_VERSION >= 11 |
5c35adbb | 41 | "B::REGEXP", |
4df7f6af | 42 | #endif |
4ce457a6 | 43 | "B::GV", |
a8a597b2 MB |
44 | "B::PVLV", |
45 | "B::AV", | |
46 | "B::HV", | |
47 | "B::CV", | |
a8a597b2 MB |
48 | "B::FM", |
49 | "B::IO", | |
50 | }; | |
51 | ||
52 | typedef enum { | |
53 | OPc_NULL, /* 0 */ | |
54 | OPc_BASEOP, /* 1 */ | |
55 | OPc_UNOP, /* 2 */ | |
56 | OPc_BINOP, /* 3 */ | |
57 | OPc_LOGOP, /* 4 */ | |
1a67a97c SM |
58 | OPc_LISTOP, /* 5 */ |
59 | OPc_PMOP, /* 6 */ | |
60 | OPc_SVOP, /* 7 */ | |
7934575e | 61 | OPc_PADOP, /* 8 */ |
1a67a97c | 62 | OPc_PVOP, /* 9 */ |
651aa52e | 63 | OPc_LOOP, /* 10 */ |
b46e009d | 64 | OPc_COP, /* 11 */ |
2f7c6295 DM |
65 | OPc_METHOP, /* 12 */ |
66 | OPc_UNOP_AUX /* 13 */ | |
a8a597b2 MB |
67 | } opclass; |
68 | ||
27da23d5 | 69 | static const char* const opclassnames[] = { |
a8a597b2 MB |
70 | "B::NULL", |
71 | "B::OP", | |
72 | "B::UNOP", | |
73 | "B::BINOP", | |
74 | "B::LOGOP", | |
a8a597b2 MB |
75 | "B::LISTOP", |
76 | "B::PMOP", | |
77 | "B::SVOP", | |
7934575e | 78 | "B::PADOP", |
a8a597b2 | 79 | "B::PVOP", |
a8a597b2 | 80 | "B::LOOP", |
b46e009d | 81 | "B::COP", |
2f7c6295 DM |
82 | "B::METHOP", |
83 | "B::UNOP_AUX" | |
a8a597b2 MB |
84 | }; |
85 | ||
27da23d5 | 86 | static const size_t opsizes[] = { |
651aa52e AE |
87 | 0, |
88 | sizeof(OP), | |
89 | sizeof(UNOP), | |
90 | sizeof(BINOP), | |
91 | sizeof(LOGOP), | |
92 | sizeof(LISTOP), | |
93 | sizeof(PMOP), | |
94 | sizeof(SVOP), | |
95 | sizeof(PADOP), | |
96 | sizeof(PVOP), | |
97 | sizeof(LOOP), | |
b46e009d | 98 | sizeof(COP), |
2f7c6295 DM |
99 | sizeof(METHOP), |
100 | sizeof(UNOP_AUX), | |
651aa52e AE |
101 | }; |
102 | ||
df3728a2 | 103 | #define MY_CXT_KEY "B::_guts" XS_VERSION |
a8a597b2 | 104 | |
89ca4ac7 | 105 | typedef struct { |
b326da91 | 106 | SV * x_specialsv_list[7]; |
a462fa00 | 107 | int x_walkoptree_debug; /* Flag for walkoptree debug hook */ |
89ca4ac7 JH |
108 | } my_cxt_t; |
109 | ||
110 | START_MY_CXT | |
111 | ||
112 | #define walkoptree_debug (MY_CXT.x_walkoptree_debug) | |
113 | #define specialsv_list (MY_CXT.x_specialsv_list) | |
e8edd1e6 | 114 | |
a462fa00 DD |
115 | |
116 | static void B_init_my_cxt(pTHX_ my_cxt_t * cxt) { | |
117 | cxt->x_specialsv_list[0] = Nullsv; | |
118 | cxt->x_specialsv_list[1] = &PL_sv_undef; | |
119 | cxt->x_specialsv_list[2] = &PL_sv_yes; | |
120 | cxt->x_specialsv_list[3] = &PL_sv_no; | |
121 | cxt->x_specialsv_list[4] = (SV *) pWARN_ALL; | |
122 | cxt->x_specialsv_list[5] = (SV *) pWARN_NONE; | |
123 | cxt->x_specialsv_list[6] = (SV *) pWARN_STD; | |
124 | } | |
125 | ||
a8a597b2 | 126 | static opclass |
5d7488b2 | 127 | cc_opclass(pTHX_ const OP *o) |
a8a597b2 | 128 | { |
1830b3d9 BM |
129 | bool custom = 0; |
130 | ||
a8a597b2 MB |
131 | if (!o) |
132 | return OPc_NULL; | |
133 | ||
619dadb5 FC |
134 | if (o->op_type == 0) { |
135 | if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE) | |
136 | return OPc_COP; | |
a8a597b2 | 137 | return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP; |
619dadb5 | 138 | } |
a8a597b2 MB |
139 | |
140 | if (o->op_type == OP_SASSIGN) | |
141 | return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP); | |
142 | ||
c60fdceb | 143 | if (o->op_type == OP_AELEMFAST) { |
93bad3fd | 144 | #if PERL_VERSION <= 14 |
c60fdceb SM |
145 | if (o->op_flags & OPf_SPECIAL) |
146 | return OPc_BASEOP; | |
147 | else | |
93bad3fd | 148 | #endif |
c60fdceb SM |
149 | #ifdef USE_ITHREADS |
150 | return OPc_PADOP; | |
151 | #else | |
152 | return OPc_SVOP; | |
153 | #endif | |
154 | } | |
155 | ||
18228111 | 156 | #ifdef USE_ITHREADS |
31b49ad4 | 157 | if (o->op_type == OP_GV || o->op_type == OP_GVSV || |
c60fdceb | 158 | o->op_type == OP_RCATLINE) |
18228111 GS |
159 | return OPc_PADOP; |
160 | #endif | |
161 | ||
1830b3d9 BM |
162 | if (o->op_type == OP_CUSTOM) |
163 | custom = 1; | |
164 | ||
165 | switch (OP_CLASS(o)) { | |
a8a597b2 MB |
166 | case OA_BASEOP: |
167 | return OPc_BASEOP; | |
168 | ||
169 | case OA_UNOP: | |
170 | return OPc_UNOP; | |
171 | ||
172 | case OA_BINOP: | |
173 | return OPc_BINOP; | |
174 | ||
175 | case OA_LOGOP: | |
176 | return OPc_LOGOP; | |
177 | ||
a8a597b2 MB |
178 | case OA_LISTOP: |
179 | return OPc_LISTOP; | |
180 | ||
181 | case OA_PMOP: | |
182 | return OPc_PMOP; | |
183 | ||
184 | case OA_SVOP: | |
185 | return OPc_SVOP; | |
186 | ||
7934575e GS |
187 | case OA_PADOP: |
188 | return OPc_PADOP; | |
a8a597b2 | 189 | |
293d3ffa SM |
190 | case OA_PVOP_OR_SVOP: |
191 | /* | |
192 | * Character translations (tr///) are usually a PVOP, keeping a | |
193 | * pointer to a table of shorts used to look up translations. | |
194 | * Under utf8, however, a simple table isn't practical; instead, | |
512ba29b FC |
195 | * the OP is an SVOP (or, under threads, a PADOP), |
196 | * and the SV is a reference to a swash | |
293d3ffa SM |
197 | * (i.e., an RV pointing to an HV). |
198 | */ | |
1830b3d9 BM |
199 | return (!custom && |
200 | (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF)) | |
201 | ) | |
35633035 | 202 | #if defined(USE_ITHREADS) |
512ba29b FC |
203 | ? OPc_PADOP : OPc_PVOP; |
204 | #else | |
293d3ffa | 205 | ? OPc_SVOP : OPc_PVOP; |
512ba29b | 206 | #endif |
a8a597b2 MB |
207 | |
208 | case OA_LOOP: | |
209 | return OPc_LOOP; | |
210 | ||
211 | case OA_COP: | |
212 | return OPc_COP; | |
213 | ||
214 | case OA_BASEOP_OR_UNOP: | |
215 | /* | |
216 | * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on | |
45f6cd40 SM |
217 | * whether parens were seen. perly.y uses OPf_SPECIAL to |
218 | * signal whether a BASEOP had empty parens or none. | |
219 | * Some other UNOPs are created later, though, so the best | |
220 | * test is OPf_KIDS, which is set in newUNOP. | |
a8a597b2 | 221 | */ |
45f6cd40 | 222 | return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP; |
a8a597b2 MB |
223 | |
224 | case OA_FILESTATOP: | |
225 | /* | |
226 | * The file stat OPs are created via UNI(OP_foo) in toke.c but use | |
227 | * the OPf_REF flag to distinguish between OP types instead of the | |
228 | * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we | |
229 | * return OPc_UNOP so that walkoptree can find our children. If | |
230 | * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set | |
231 | * (no argument to the operator) it's an OP; with OPf_REF set it's | |
7934575e | 232 | * an SVOP (and op_sv is the GV for the filehandle argument). |
a8a597b2 MB |
233 | */ |
234 | return ((o->op_flags & OPf_KIDS) ? OPc_UNOP : | |
93865851 GS |
235 | #ifdef USE_ITHREADS |
236 | (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP); | |
237 | #else | |
7934575e | 238 | (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP); |
93865851 | 239 | #endif |
a8a597b2 MB |
240 | case OA_LOOPEXOP: |
241 | /* | |
242 | * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a | |
243 | * label was omitted (in which case it's a BASEOP) or else a term was | |
244 | * seen. In this last case, all except goto are definitely PVOP but | |
245 | * goto is either a PVOP (with an ordinary constant label), an UNOP | |
246 | * with OPf_STACKED (with a non-constant non-sub) or an UNOP for | |
247 | * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to | |
248 | * get set. | |
249 | */ | |
250 | if (o->op_flags & OPf_STACKED) | |
251 | return OPc_UNOP; | |
252 | else if (o->op_flags & OPf_SPECIAL) | |
253 | return OPc_BASEOP; | |
254 | else | |
255 | return OPc_PVOP; | |
b46e009d | 256 | case OA_METHOP: |
257 | return OPc_METHOP; | |
2f7c6295 DM |
258 | case OA_UNOP_AUX: |
259 | return OPc_UNOP_AUX; | |
a8a597b2 MB |
260 | } |
261 | warn("can't determine class of operator %s, assuming BASEOP\n", | |
1830b3d9 | 262 | OP_NAME(o)); |
a8a597b2 MB |
263 | return OPc_BASEOP; |
264 | } | |
265 | ||
6079961f NC |
266 | static SV * |
267 | make_op_object(pTHX_ const OP *o) | |
a8a597b2 | 268 | { |
6079961f NC |
269 | SV *opsv = sv_newmortal(); |
270 | sv_setiv(newSVrv(opsv, opclassnames[cc_opclass(aTHX_ o)]), PTR2IV(o)); | |
271 | return opsv; | |
a8a597b2 MB |
272 | } |
273 | ||
71324a3b DM |
274 | |
275 | static SV * | |
276 | get_overlay_object(pTHX_ const OP *o, const char * const name, U32 namelen) | |
277 | { | |
278 | HE *he; | |
279 | SV **svp; | |
280 | SV *key; | |
281 | SV *sv =get_sv("B::overlay", 0); | |
282 | if (!sv || !SvROK(sv)) | |
283 | return NULL; | |
284 | sv = SvRV(sv); | |
285 | if (SvTYPE(sv) != SVt_PVHV) | |
286 | return NULL; | |
287 | key = newSViv(PTR2IV(o)); | |
288 | he = hv_fetch_ent((HV*)sv, key, 0, 0); | |
289 | SvREFCNT_dec(key); | |
290 | if (!he) | |
291 | return NULL; | |
292 | sv = HeVAL(he); | |
293 | if (!sv || !SvROK(sv)) | |
294 | return NULL; | |
295 | sv = SvRV(sv); | |
296 | if (SvTYPE(sv) != SVt_PVHV) | |
297 | return NULL; | |
298 | svp = hv_fetch((HV*)sv, name, namelen, 0); | |
299 | if (!svp) | |
300 | return NULL; | |
301 | sv = *svp; | |
302 | return sv; | |
303 | } | |
304 | ||
305 | ||
a8a597b2 | 306 | static SV * |
0c74f67f | 307 | make_sv_object(pTHX_ SV *sv) |
a8a597b2 | 308 | { |
0c74f67f | 309 | SV *const arg = sv_newmortal(); |
27da23d5 | 310 | const char *type = 0; |
a8a597b2 | 311 | IV iv; |
89ca4ac7 | 312 | dMY_CXT; |
9496d2e5 | 313 | |
c33e8be1 | 314 | for (iv = 0; iv < (IV)(sizeof(specialsv_list)/sizeof(SV*)); iv++) { |
e8edd1e6 | 315 | if (sv == specialsv_list[iv]) { |
a8a597b2 MB |
316 | type = "B::SPECIAL"; |
317 | break; | |
318 | } | |
319 | } | |
320 | if (!type) { | |
321 | type = svclassnames[SvTYPE(sv)]; | |
56431972 | 322 | iv = PTR2IV(sv); |
a8a597b2 MB |
323 | } |
324 | sv_setiv(newSVrv(arg, type), iv); | |
325 | return arg; | |
326 | } | |
327 | ||
328 | static SV * | |
9496d2e5 | 329 | make_temp_object(pTHX_ SV *temp) |
8e01d9a6 NC |
330 | { |
331 | SV *target; | |
9496d2e5 | 332 | SV *arg = sv_newmortal(); |
8e01d9a6 NC |
333 | const char *const type = svclassnames[SvTYPE(temp)]; |
334 | const IV iv = PTR2IV(temp); | |
335 | ||
336 | target = newSVrv(arg, type); | |
337 | sv_setiv(target, iv); | |
338 | ||
339 | /* Need to keep our "temp" around as long as the target exists. | |
340 | Simplest way seems to be to hang it from magic, and let that clear | |
341 | it up. No vtable, so won't actually get in the way of anything. */ | |
342 | sv_magicext(target, temp, PERL_MAGIC_sv, NULL, NULL, 0); | |
343 | /* magic object has had its reference count increased, so we must drop | |
344 | our reference. */ | |
345 | SvREFCNT_dec(temp); | |
346 | return arg; | |
347 | } | |
348 | ||
349 | static SV * | |
d2b4c688 | 350 | make_warnings_object(pTHX_ const COP *const cop) |
5c3c3f81 | 351 | { |
d2b4c688 | 352 | const STRLEN *const warnings = cop->cop_warnings; |
5c3c3f81 NC |
353 | const char *type = 0; |
354 | dMY_CXT; | |
355 | IV iv = sizeof(specialsv_list)/sizeof(SV*); | |
356 | ||
357 | /* Counting down is deliberate. Before the split between make_sv_object | |
358 | and make_warnings_obj there appeared to be a bug - Nullsv and pWARN_STD | |
359 | were both 0, so you could never get a B::SPECIAL for pWARN_STD */ | |
360 | ||
361 | while (iv--) { | |
362 | if ((SV*)warnings == specialsv_list[iv]) { | |
363 | type = "B::SPECIAL"; | |
364 | break; | |
365 | } | |
366 | } | |
367 | if (type) { | |
9496d2e5 | 368 | SV *arg = sv_newmortal(); |
5c3c3f81 | 369 | sv_setiv(newSVrv(arg, type), iv); |
8e01d9a6 | 370 | return arg; |
5c3c3f81 NC |
371 | } else { |
372 | /* B assumes that warnings are a regular SV. Seems easier to keep it | |
373 | happy by making them into a regular SV. */ | |
9496d2e5 | 374 | return make_temp_object(aTHX_ newSVpvn((char *)(warnings + 1), *warnings)); |
8e01d9a6 NC |
375 | } |
376 | } | |
377 | ||
378 | static SV * | |
9496d2e5 | 379 | make_cop_io_object(pTHX_ COP *cop) |
8e01d9a6 | 380 | { |
8b850bd5 NC |
381 | SV *const value = newSV(0); |
382 | ||
33972ad6 | 383 | Perl_emulate_cop_io(aTHX_ cop, value); |
8b850bd5 NC |
384 | |
385 | if(SvOK(value)) { | |
0c74f67f | 386 | return make_sv_object(aTHX_ value); |
8e01d9a6 | 387 | } else { |
8b850bd5 | 388 | SvREFCNT_dec(value); |
0c74f67f | 389 | return make_sv_object(aTHX_ NULL); |
5c3c3f81 | 390 | } |
5c3c3f81 NC |
391 | } |
392 | ||
393 | static SV * | |
9496d2e5 | 394 | make_mg_object(pTHX_ MAGIC *mg) |
a8a597b2 | 395 | { |
9496d2e5 | 396 | SV *arg = sv_newmortal(); |
56431972 | 397 | sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg)); |
a8a597b2 MB |
398 | return arg; |
399 | } | |
400 | ||
401 | static SV * | |
52ad86de | 402 | cstring(pTHX_ SV *sv, bool perlstyle) |
a8a597b2 | 403 | { |
09e97b95 | 404 | SV *sstr; |
a8a597b2 MB |
405 | |
406 | if (!SvOK(sv)) | |
09e97b95 NC |
407 | return newSVpvs_flags("0", SVs_TEMP); |
408 | ||
409 | sstr = newSVpvs_flags("\"", SVs_TEMP); | |
410 | ||
411 | if (perlstyle && SvUTF8(sv)) { | |
d79a7a3d | 412 | SV *tmpsv = sv_newmortal(); /* Temporary SV to feed sv_uni_display */ |
5d7488b2 AL |
413 | const STRLEN len = SvCUR(sv); |
414 | const char *s = sv_uni_display(tmpsv, sv, 8*len, UNI_DISPLAY_QQ); | |
d79a7a3d RGS |
415 | while (*s) |
416 | { | |
417 | if (*s == '"') | |
6beb30a6 | 418 | sv_catpvs(sstr, "\\\""); |
d79a7a3d | 419 | else if (*s == '$') |
6beb30a6 | 420 | sv_catpvs(sstr, "\\$"); |
d79a7a3d | 421 | else if (*s == '@') |
6beb30a6 | 422 | sv_catpvs(sstr, "\\@"); |
d79a7a3d RGS |
423 | else if (*s == '\\') |
424 | { | |
425 | if (strchr("nrftax\\",*(s+1))) | |
426 | sv_catpvn(sstr, s++, 2); | |
427 | else | |
6beb30a6 | 428 | sv_catpvs(sstr, "\\\\"); |
d79a7a3d RGS |
429 | } |
430 | else /* should always be printable */ | |
431 | sv_catpvn(sstr, s, 1); | |
432 | ++s; | |
433 | } | |
d79a7a3d | 434 | } |
a8a597b2 MB |
435 | else |
436 | { | |
437 | /* XXX Optimise? */ | |
5d7488b2 AL |
438 | STRLEN len; |
439 | const char *s = SvPV(sv, len); | |
a8a597b2 MB |
440 | for (; len; len--, s++) |
441 | { | |
442 | /* At least try a little for readability */ | |
443 | if (*s == '"') | |
6beb30a6 | 444 | sv_catpvs(sstr, "\\\""); |
a8a597b2 | 445 | else if (*s == '\\') |
6beb30a6 | 446 | sv_catpvs(sstr, "\\\\"); |
b326da91 | 447 | /* trigraphs - bleagh */ |
5d7488b2 | 448 | else if (!perlstyle && *s == '?' && len>=3 && s[1] == '?') { |
47bf35fa | 449 | Perl_sv_catpvf(aTHX_ sstr, "\\%03o", '?'); |
b326da91 | 450 | } |
52ad86de | 451 | else if (perlstyle && *s == '$') |
6beb30a6 | 452 | sv_catpvs(sstr, "\\$"); |
52ad86de | 453 | else if (perlstyle && *s == '@') |
6beb30a6 | 454 | sv_catpvs(sstr, "\\@"); |
ce561ef2 | 455 | else if (isPRINT(*s)) |
a8a597b2 MB |
456 | sv_catpvn(sstr, s, 1); |
457 | else if (*s == '\n') | |
6beb30a6 | 458 | sv_catpvs(sstr, "\\n"); |
a8a597b2 | 459 | else if (*s == '\r') |
6beb30a6 | 460 | sv_catpvs(sstr, "\\r"); |
a8a597b2 | 461 | else if (*s == '\t') |
6beb30a6 | 462 | sv_catpvs(sstr, "\\t"); |
a8a597b2 | 463 | else if (*s == '\a') |
6beb30a6 | 464 | sv_catpvs(sstr, "\\a"); |
a8a597b2 | 465 | else if (*s == '\b') |
6beb30a6 | 466 | sv_catpvs(sstr, "\\b"); |
a8a597b2 | 467 | else if (*s == '\f') |
6beb30a6 | 468 | sv_catpvs(sstr, "\\f"); |
52ad86de | 469 | else if (!perlstyle && *s == '\v') |
6beb30a6 | 470 | sv_catpvs(sstr, "\\v"); |
a8a597b2 MB |
471 | else |
472 | { | |
a8a597b2 | 473 | /* Don't want promotion of a signed -1 char in sprintf args */ |
5d7488b2 | 474 | const unsigned char c = (unsigned char) *s; |
47bf35fa | 475 | Perl_sv_catpvf(aTHX_ sstr, "\\%03o", c); |
a8a597b2 MB |
476 | } |
477 | /* XXX Add line breaks if string is long */ | |
478 | } | |
a8a597b2 | 479 | } |
09e97b95 | 480 | sv_catpvs(sstr, "\""); |
a8a597b2 MB |
481 | return sstr; |
482 | } | |
483 | ||
484 | static SV * | |
cea2e8a9 | 485 | cchar(pTHX_ SV *sv) |
a8a597b2 | 486 | { |
422d053b | 487 | SV *sstr = newSVpvs_flags("'", SVs_TEMP); |
5d7488b2 | 488 | const char *s = SvPV_nolen(sv); |
422d053b NC |
489 | /* Don't want promotion of a signed -1 char in sprintf args */ |
490 | const unsigned char c = (unsigned char) *s; | |
a8a597b2 | 491 | |
422d053b | 492 | if (c == '\'') |
6beb30a6 | 493 | sv_catpvs(sstr, "\\'"); |
422d053b | 494 | else if (c == '\\') |
6beb30a6 | 495 | sv_catpvs(sstr, "\\\\"); |
422d053b | 496 | else if (isPRINT(c)) |
a8a597b2 | 497 | sv_catpvn(sstr, s, 1); |
422d053b | 498 | else if (c == '\n') |
6beb30a6 | 499 | sv_catpvs(sstr, "\\n"); |
422d053b | 500 | else if (c == '\r') |
6beb30a6 | 501 | sv_catpvs(sstr, "\\r"); |
422d053b | 502 | else if (c == '\t') |
6beb30a6 | 503 | sv_catpvs(sstr, "\\t"); |
422d053b | 504 | else if (c == '\a') |
6beb30a6 | 505 | sv_catpvs(sstr, "\\a"); |
422d053b | 506 | else if (c == '\b') |
6beb30a6 | 507 | sv_catpvs(sstr, "\\b"); |
422d053b | 508 | else if (c == '\f') |
6beb30a6 | 509 | sv_catpvs(sstr, "\\f"); |
422d053b | 510 | else if (c == '\v') |
6beb30a6 | 511 | sv_catpvs(sstr, "\\v"); |
a8a597b2 | 512 | else |
422d053b | 513 | Perl_sv_catpvf(aTHX_ sstr, "\\%03o", c); |
6beb30a6 | 514 | sv_catpvs(sstr, "'"); |
a8a597b2 MB |
515 | return sstr; |
516 | } | |
517 | ||
35633035 DM |
518 | #define PMOP_pmreplstart(o) o->op_pmstashstartu.op_pmreplstart |
519 | #define PMOP_pmreplroot(o) o->op_pmreplrootu.op_pmreplroot | |
8f3d514b | 520 | |
20f7624e NC |
521 | static SV * |
522 | walkoptree(pTHX_ OP *o, const char *method, SV *ref) | |
a8a597b2 MB |
523 | { |
524 | dSP; | |
20f7624e NC |
525 | OP *kid; |
526 | SV *object; | |
6079961f | 527 | const char *const classname = opclassnames[cc_opclass(aTHX_ o)]; |
89ca4ac7 JH |
528 | dMY_CXT; |
529 | ||
20f7624e NC |
530 | /* Check that no-one has changed our reference, or is holding a reference |
531 | to it. */ | |
532 | if (SvREFCNT(ref) == 1 && SvROK(ref) && SvTYPE(ref) == SVt_RV | |
533 | && (object = SvRV(ref)) && SvREFCNT(object) == 1 | |
534 | && SvTYPE(object) == SVt_PVMG && SvIOK_only(object) | |
535 | && !SvMAGICAL(object) && !SvMAGIC(object) && SvSTASH(object)) { | |
536 | /* Looks good, so rebless it for the class we need: */ | |
537 | sv_bless(ref, gv_stashpv(classname, GV_ADD)); | |
538 | } else { | |
539 | /* Need to make a new one. */ | |
540 | ref = sv_newmortal(); | |
541 | object = newSVrv(ref, classname); | |
542 | } | |
543 | sv_setiv(object, PTR2IV(o)); | |
544 | ||
a8a597b2 MB |
545 | if (walkoptree_debug) { |
546 | PUSHMARK(sp); | |
20f7624e | 547 | XPUSHs(ref); |
a8a597b2 MB |
548 | PUTBACK; |
549 | perl_call_method("walkoptree_debug", G_DISCARD); | |
550 | } | |
551 | PUSHMARK(sp); | |
20f7624e | 552 | XPUSHs(ref); |
a8a597b2 MB |
553 | PUTBACK; |
554 | perl_call_method(method, G_DISCARD); | |
555 | if (o && (o->op_flags & OPf_KIDS)) { | |
e6dae479 | 556 | for (kid = ((UNOP*)o)->op_first; kid; kid = OpSIBLING(kid)) { |
20f7624e | 557 | ref = walkoptree(aTHX_ kid, method, ref); |
a8a597b2 MB |
558 | } |
559 | } | |
5464c149 | 560 | if (o && (cc_opclass(aTHX_ o) == OPc_PMOP) && o->op_type != OP_PUSHRE |
8f3d514b | 561 | && (kid = PMOP_pmreplroot(cPMOPo))) |
f3be9b72 | 562 | { |
20f7624e | 563 | ref = walkoptree(aTHX_ kid, method, ref); |
f3be9b72 | 564 | } |
20f7624e | 565 | return ref; |
a8a597b2 MB |
566 | } |
567 | ||
5d7488b2 | 568 | static SV ** |
1df34986 AE |
569 | oplist(pTHX_ OP *o, SV **SP) |
570 | { | |
571 | for(; o; o = o->op_next) { | |
7252851f | 572 | if (o->op_opt == 0) |
1df34986 | 573 | break; |
2814eb74 | 574 | o->op_opt = 0; |
6079961f | 575 | XPUSHs(make_op_object(aTHX_ o)); |
1df34986 AE |
576 | switch (o->op_type) { |
577 | case OP_SUBST: | |
8f3d514b | 578 | SP = oplist(aTHX_ PMOP_pmreplstart(cPMOPo), SP); |
1df34986 AE |
579 | continue; |
580 | case OP_SORT: | |
f66c782a | 581 | if (o->op_flags & OPf_STACKED && o->op_flags & OPf_SPECIAL) { |
e6dae479 | 582 | OP *kid = OpSIBLING(cLISTOPo->op_first); /* pass pushmark */ |
1df34986 AE |
583 | kid = kUNOP->op_first; /* pass rv2gv */ |
584 | kid = kUNOP->op_first; /* pass leave */ | |
f66c782a | 585 | SP = oplist(aTHX_ kid->op_next, SP); |
1df34986 AE |
586 | } |
587 | continue; | |
588 | } | |
589 | switch (PL_opargs[o->op_type] & OA_CLASS_MASK) { | |
590 | case OA_LOGOP: | |
591 | SP = oplist(aTHX_ cLOGOPo->op_other, SP); | |
592 | break; | |
593 | case OA_LOOP: | |
594 | SP = oplist(aTHX_ cLOOPo->op_lastop, SP); | |
595 | SP = oplist(aTHX_ cLOOPo->op_nextop, SP); | |
596 | SP = oplist(aTHX_ cLOOPo->op_redoop, SP); | |
597 | break; | |
598 | } | |
599 | } | |
600 | return SP; | |
601 | } | |
602 | ||
a8a597b2 MB |
603 | typedef OP *B__OP; |
604 | typedef UNOP *B__UNOP; | |
605 | typedef BINOP *B__BINOP; | |
606 | typedef LOGOP *B__LOGOP; | |
a8a597b2 MB |
607 | typedef LISTOP *B__LISTOP; |
608 | typedef PMOP *B__PMOP; | |
609 | typedef SVOP *B__SVOP; | |
7934575e | 610 | typedef PADOP *B__PADOP; |
a8a597b2 MB |
611 | typedef PVOP *B__PVOP; |
612 | typedef LOOP *B__LOOP; | |
613 | typedef COP *B__COP; | |
b46e009d | 614 | typedef METHOP *B__METHOP; |
a8a597b2 MB |
615 | |
616 | typedef SV *B__SV; | |
617 | typedef SV *B__IV; | |
618 | typedef SV *B__PV; | |
619 | typedef SV *B__NV; | |
620 | typedef SV *B__PVMG; | |
5c35adbb NC |
621 | #if PERL_VERSION >= 11 |
622 | typedef SV *B__REGEXP; | |
623 | #endif | |
a8a597b2 MB |
624 | typedef SV *B__PVLV; |
625 | typedef SV *B__BM; | |
626 | typedef SV *B__RV; | |
1df34986 | 627 | typedef SV *B__FM; |
a8a597b2 MB |
628 | typedef AV *B__AV; |
629 | typedef HV *B__HV; | |
630 | typedef CV *B__CV; | |
631 | typedef GV *B__GV; | |
632 | typedef IO *B__IO; | |
633 | ||
634 | typedef MAGIC *B__MAGIC; | |
fd9f6265 JJ |
635 | typedef HE *B__HE; |
636 | typedef struct refcounted_he *B__RHE; | |
86d2498c | 637 | #ifdef PadlistARRAY |
7261499d FC |
638 | typedef PADLIST *B__PADLIST; |
639 | #endif | |
9b7476d7 | 640 | typedef PADNAMELIST *B__PADNAMELIST; |
0f94cb1f | 641 | typedef PADNAME *B__PADNAME; |
9b7476d7 | 642 | |
a8a597b2 | 643 | |
3486ec84 | 644 | #ifdef MULTIPLICITY |
115ff745 | 645 | # define ASSIGN_COMMON_ALIAS(prefix, var) \ |
3800c318 | 646 | STMT_START { XSANY.any_i32 = STRUCT_OFFSET(struct interpreter, prefix##var); } STMT_END |
32855229 | 647 | #else |
115ff745 | 648 | # define ASSIGN_COMMON_ALIAS(prefix, var) \ |
32855229 NC |
649 | STMT_START { XSANY.any_ptr = (void *)&PL_##var; } STMT_END |
650 | #endif | |
651 | ||
652 | /* This needs to be ALIASed in a custom way, hence can't easily be defined as | |
653 | a regular XSUB. */ | |
654 | static XSPROTO(intrpvar_sv_common); /* prototype to pass -Wmissing-prototypes */ | |
655 | static XSPROTO(intrpvar_sv_common) | |
656 | { | |
657 | dVAR; | |
658 | dXSARGS; | |
659 | SV *ret; | |
660 | if (items != 0) | |
661 | croak_xs_usage(cv, ""); | |
3486ec84 | 662 | #ifdef MULTIPLICITY |
32855229 NC |
663 | ret = *(SV **)(XSANY.any_i32 + (char *)my_perl); |
664 | #else | |
665 | ret = *(SV **)(XSANY.any_ptr); | |
666 | #endif | |
0c74f67f | 667 | ST(0) = make_sv_object(aTHX_ ret); |
32855229 NC |
668 | XSRETURN(1); |
669 | } | |
670 | ||
bec746fe DM |
671 | |
672 | ||
0508288e NC |
673 | #define SVp 0x0 |
674 | #define U32p 0x1 | |
675 | #define line_tp 0x2 | |
676 | #define OPp 0x3 | |
677 | #define PADOFFSETp 0x4 | |
678 | #define U8p 0x5 | |
679 | #define IVp 0x6 | |
680 | #define char_pp 0x7 | |
681 | /* Keep this last: */ | |
682 | #define op_offset_special 0x8 | |
bec746fe DM |
683 | |
684 | /* table that drives most of the B::*OP methods */ | |
685 | ||
4b2bcf2b | 686 | const struct OP_methods { |
bec746fe | 687 | const char *name; |
7d6d3fb7 | 688 | U8 namelen; |
0508288e NC |
689 | U8 type; /* if op_offset_special, access is handled on a case-by-case basis */ |
690 | U16 offset; | |
bec746fe | 691 | } op_methods[] = { |
3800c318 | 692 | { STR_WITH_LEN("next"), OPp, STRUCT_OFFSET(struct op, op_next), },/* 0*/ |
1ed44841 | 693 | { STR_WITH_LEN("sibling"), op_offset_special, 0, },/* 1*/ |
3800c318 JH |
694 | { STR_WITH_LEN("targ"), PADOFFSETp, STRUCT_OFFSET(struct op, op_targ), },/* 2*/ |
695 | { STR_WITH_LEN("flags"), U8p, STRUCT_OFFSET(struct op, op_flags), },/* 3*/ | |
696 | { STR_WITH_LEN("private"), U8p, STRUCT_OFFSET(struct op, op_private), },/* 4*/ | |
697 | { STR_WITH_LEN("first"), OPp, STRUCT_OFFSET(struct unop, op_first), },/* 5*/ | |
698 | { STR_WITH_LEN("last"), OPp, STRUCT_OFFSET(struct binop, op_last), },/* 6*/ | |
699 | { STR_WITH_LEN("other"), OPp, STRUCT_OFFSET(struct logop, op_other), },/* 7*/ | |
99639b5b | 700 | { STR_WITH_LEN("pmreplstart"), op_offset_special, 0, },/* 8*/ |
3800c318 JH |
701 | { STR_WITH_LEN("redoop"), OPp, STRUCT_OFFSET(struct loop, op_redoop), },/* 9*/ |
702 | { STR_WITH_LEN("nextop"), OPp, STRUCT_OFFSET(struct loop, op_nextop), },/*10*/ | |
703 | { STR_WITH_LEN("lastop"), OPp, STRUCT_OFFSET(struct loop, op_lastop), },/*11*/ | |
704 | { STR_WITH_LEN("pmflags"), U32p, STRUCT_OFFSET(struct pmop, op_pmflags),},/*12*/ | |
bec746fe | 705 | #if PERL_VERSION >= 17 |
3800c318 | 706 | { STR_WITH_LEN("code_list"),OPp, STRUCT_OFFSET(struct pmop, op_code_list),},/*13*/ |
bec746fe | 707 | #else |
88938aa8 | 708 | { STR_WITH_LEN("code_list"),op_offset_special, 0, }, /*13*/ |
bec746fe | 709 | #endif |
3800c318 JH |
710 | { STR_WITH_LEN("sv"), SVp, STRUCT_OFFSET(struct svop, op_sv), },/*14*/ |
711 | { STR_WITH_LEN("gv"), SVp, STRUCT_OFFSET(struct svop, op_sv), },/*15*/ | |
712 | { STR_WITH_LEN("padix"), PADOFFSETp,STRUCT_OFFSET(struct padop, op_padix),},/*16*/ | |
713 | { STR_WITH_LEN("cop_seq"), U32p, STRUCT_OFFSET(struct cop, cop_seq), },/*17*/ | |
714 | { STR_WITH_LEN("line"), line_tp, STRUCT_OFFSET(struct cop, cop_line), },/*18*/ | |
715 | { STR_WITH_LEN("hints"), U32p, STRUCT_OFFSET(struct cop, cop_hints), },/*19*/ | |
bec746fe | 716 | #ifdef USE_ITHREADS |
3800c318 | 717 | { STR_WITH_LEN("pmoffset"),IVp, STRUCT_OFFSET(struct pmop, op_pmoffset),},/*20*/ |
99639b5b | 718 | { STR_WITH_LEN("filegv"), op_offset_special, 0, },/*21*/ |
3800c318 | 719 | { STR_WITH_LEN("file"), char_pp, STRUCT_OFFSET(struct cop, cop_file), },/*22*/ |
99639b5b | 720 | { STR_WITH_LEN("stash"), op_offset_special, 0, },/*23*/ |
bec746fe | 721 | # if PERL_VERSION < 17 |
3800c318 | 722 | { STR_WITH_LEN("stashpv"), char_pp, STRUCT_OFFSET(struct cop, cop_stashpv),}, /*24*/ |
99639b5b | 723 | { STR_WITH_LEN("stashoff"),op_offset_special, 0, },/*25*/ |
bec746fe | 724 | # else |
99639b5b | 725 | { STR_WITH_LEN("stashpv"), op_offset_special, 0, },/*24*/ |
3800c318 | 726 | { STR_WITH_LEN("stashoff"),PADOFFSETp,STRUCT_OFFSET(struct cop,cop_stashoff),},/*25*/ |
bec746fe DM |
727 | # endif |
728 | #else | |
99639b5b | 729 | { STR_WITH_LEN("pmoffset"),op_offset_special, 0, },/*20*/ |
3800c318 | 730 | { STR_WITH_LEN("filegv"), SVp, STRUCT_OFFSET(struct cop, cop_filegv),},/*21*/ |
99639b5b | 731 | { STR_WITH_LEN("file"), op_offset_special, 0, },/*22*/ |
3800c318 | 732 | { STR_WITH_LEN("stash"), SVp, STRUCT_OFFSET(struct cop, cop_stash), },/*23*/ |
99639b5b DM |
733 | { STR_WITH_LEN("stashpv"), op_offset_special, 0, },/*24*/ |
734 | { STR_WITH_LEN("stashoff"),op_offset_special, 0, },/*25*/ | |
bec746fe | 735 | #endif |
99639b5b DM |
736 | { STR_WITH_LEN("size"), op_offset_special, 0, },/*26*/ |
737 | { STR_WITH_LEN("name"), op_offset_special, 0, },/*27*/ | |
738 | { STR_WITH_LEN("desc"), op_offset_special, 0, },/*28*/ | |
739 | { STR_WITH_LEN("ppaddr"), op_offset_special, 0, },/*29*/ | |
740 | { STR_WITH_LEN("type"), op_offset_special, 0, },/*30*/ | |
741 | { STR_WITH_LEN("opt"), op_offset_special, 0, },/*31*/ | |
742 | { STR_WITH_LEN("spare"), op_offset_special, 0, },/*32*/ | |
743 | { STR_WITH_LEN("children"),op_offset_special, 0, },/*33*/ | |
744 | { STR_WITH_LEN("pmreplroot"), op_offset_special, 0, },/*34*/ | |
745 | { STR_WITH_LEN("pmstashpv"), op_offset_special, 0, },/*35*/ | |
746 | { STR_WITH_LEN("pmstash"), op_offset_special, 0, },/*36*/ | |
747 | { STR_WITH_LEN("precomp"), op_offset_special, 0, },/*37*/ | |
748 | { STR_WITH_LEN("reflags"), op_offset_special, 0, },/*38*/ | |
749 | { STR_WITH_LEN("sv"), op_offset_special, 0, },/*39*/ | |
750 | { STR_WITH_LEN("gv"), op_offset_special, 0, },/*40*/ | |
751 | { STR_WITH_LEN("pv"), op_offset_special, 0, },/*41*/ | |
752 | { STR_WITH_LEN("label"), op_offset_special, 0, },/*42*/ | |
753 | { STR_WITH_LEN("arybase"), op_offset_special, 0, },/*43*/ | |
754 | { STR_WITH_LEN("warnings"),op_offset_special, 0, },/*44*/ | |
755 | { STR_WITH_LEN("io"), op_offset_special, 0, },/*45*/ | |
756 | { STR_WITH_LEN("hints_hash"),op_offset_special, 0, },/*46*/ | |
3164fde4 | 757 | #if PERL_VERSION >= 17 |
99639b5b DM |
758 | { STR_WITH_LEN("slabbed"), op_offset_special, 0, },/*47*/ |
759 | { STR_WITH_LEN("savefree"),op_offset_special, 0, },/*48*/ | |
760 | { STR_WITH_LEN("static"), op_offset_special, 0, },/*49*/ | |
761 | # if PERL_VERSION >= 19 | |
762 | { STR_WITH_LEN("folded"), op_offset_special, 0, },/*50*/ | |
87b5a8b9 | 763 | { STR_WITH_LEN("moresib"), op_offset_special, 0, },/*51*/ |
29e61fd9 | 764 | { STR_WITH_LEN("parent"), op_offset_special, 0, },/*52*/ |
99639b5b | 765 | # endif |
3164fde4 | 766 | #endif |
b46e009d | 767 | #if PERL_VERSION >= 21 |
768 | { STR_WITH_LEN("first"), op_offset_special, 0, },/*53*/ | |
769 | { STR_WITH_LEN("meth_sv"), op_offset_special, 0, },/*54*/ | |
429ba3b2 | 770 | { STR_WITH_LEN("pmregexp"),op_offset_special, 0, },/*55*/ |
810bd8b7 | 771 | # ifdef USE_ITHREADS |
772 | { STR_WITH_LEN("rclass"), op_offset_special, 0, },/*56*/ | |
773 | # else | |
774 | { STR_WITH_LEN("rclass"), op_offset_special, 0, },/*56*/ | |
775 | # endif | |
b46e009d | 776 | #endif |
bec746fe DM |
777 | }; |
778 | ||
b1826b71 NC |
779 | #include "const-c.inc" |
780 | ||
7a2c16aa | 781 | MODULE = B PACKAGE = B |
a8a597b2 | 782 | |
b1826b71 NC |
783 | INCLUDE: const-xs.inc |
784 | ||
a8a597b2 MB |
785 | PROTOTYPES: DISABLE |
786 | ||
787 | BOOT: | |
4c1f658f | 788 | { |
7a2c16aa NC |
789 | CV *cv; |
790 | const char *file = __FILE__; | |
c3890f9c | 791 | SV *sv; |
89ca4ac7 | 792 | MY_CXT_INIT; |
a462fa00 | 793 | B_init_my_cxt(aTHX_ &(MY_CXT)); |
32855229 | 794 | cv = newXS("B::init_av", intrpvar_sv_common, file); |
115ff745 | 795 | ASSIGN_COMMON_ALIAS(I, initav); |
32855229 | 796 | cv = newXS("B::check_av", intrpvar_sv_common, file); |
115ff745 | 797 | ASSIGN_COMMON_ALIAS(I, checkav_save); |
32855229 | 798 | cv = newXS("B::unitcheck_av", intrpvar_sv_common, file); |
115ff745 | 799 | ASSIGN_COMMON_ALIAS(I, unitcheckav_save); |
32855229 | 800 | cv = newXS("B::begin_av", intrpvar_sv_common, file); |
115ff745 | 801 | ASSIGN_COMMON_ALIAS(I, beginav_save); |
32855229 | 802 | cv = newXS("B::end_av", intrpvar_sv_common, file); |
115ff745 | 803 | ASSIGN_COMMON_ALIAS(I, endav); |
32855229 | 804 | cv = newXS("B::main_cv", intrpvar_sv_common, file); |
115ff745 | 805 | ASSIGN_COMMON_ALIAS(I, main_cv); |
32855229 | 806 | cv = newXS("B::inc_gv", intrpvar_sv_common, file); |
115ff745 | 807 | ASSIGN_COMMON_ALIAS(I, incgv); |
32855229 | 808 | cv = newXS("B::defstash", intrpvar_sv_common, file); |
115ff745 | 809 | ASSIGN_COMMON_ALIAS(I, defstash); |
32855229 | 810 | cv = newXS("B::curstash", intrpvar_sv_common, file); |
115ff745 | 811 | ASSIGN_COMMON_ALIAS(I, curstash); |
5f7e30c4 | 812 | #ifdef PL_formfeed |
32855229 | 813 | cv = newXS("B::formfeed", intrpvar_sv_common, file); |
115ff745 | 814 | ASSIGN_COMMON_ALIAS(I, formfeed); |
5f7e30c4 | 815 | #endif |
32855229 NC |
816 | #ifdef USE_ITHREADS |
817 | cv = newXS("B::regex_padav", intrpvar_sv_common, file); | |
115ff745 | 818 | ASSIGN_COMMON_ALIAS(I, regex_padav); |
32855229 NC |
819 | #endif |
820 | cv = newXS("B::warnhook", intrpvar_sv_common, file); | |
115ff745 | 821 | ASSIGN_COMMON_ALIAS(I, warnhook); |
32855229 | 822 | cv = newXS("B::diehook", intrpvar_sv_common, file); |
115ff745 | 823 | ASSIGN_COMMON_ALIAS(I, diehook); |
c3890f9c | 824 | sv = get_sv("B::OP::does_parent", GV_ADDMULTI); |
c3890f9c | 825 | #ifdef PERL_OP_PARENT |
e1812838 | 826 | sv_setsv(sv, &PL_sv_yes); |
c3890f9c | 827 | #else |
e1812838 | 828 | sv_setsv(sv, &PL_sv_no); |
c3890f9c | 829 | #endif |
32855229 NC |
830 | } |
831 | ||
5f7e30c4 NC |
832 | #ifndef PL_formfeed |
833 | ||
834 | void | |
835 | formfeed() | |
836 | PPCODE: | |
837 | PUSHs(make_sv_object(aTHX_ GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)))); | |
838 | ||
839 | #endif | |
840 | ||
7a2c16aa NC |
841 | long |
842 | amagic_generation() | |
843 | CODE: | |
844 | RETVAL = PL_amagic_generation; | |
845 | OUTPUT: | |
846 | RETVAL | |
847 | ||
8ae5a962 | 848 | void |
7a2c16aa | 849 | comppadlist() |
7261499d FC |
850 | PREINIT: |
851 | PADLIST *padlist = CvPADLIST(PL_main_cv ? PL_main_cv : PL_compcv); | |
8ae5a962 | 852 | PPCODE: |
86d2498c | 853 | #ifdef PadlistARRAY |
7261499d FC |
854 | { |
855 | SV * const rv = sv_newmortal(); | |
856 | sv_setiv(newSVrv(rv, padlist ? "B::PADLIST" : "B::NULL"), | |
857 | PTR2IV(padlist)); | |
858 | PUSHs(rv); | |
859 | } | |
860 | #else | |
861 | PUSHs(make_sv_object(aTHX_ (SV *)padlist)); | |
862 | #endif | |
7a2c16aa | 863 | |
8ae5a962 | 864 | void |
a4aabc83 NC |
865 | sv_undef() |
866 | ALIAS: | |
867 | sv_no = 1 | |
868 | sv_yes = 2 | |
8ae5a962 | 869 | PPCODE: |
0c74f67f NC |
870 | PUSHs(make_sv_object(aTHX_ ix > 1 ? &PL_sv_yes |
871 | : ix < 1 ? &PL_sv_undef | |
872 | : &PL_sv_no)); | |
a4aabc83 | 873 | |
6079961f | 874 | void |
e97701b4 NC |
875 | main_root() |
876 | ALIAS: | |
877 | main_start = 1 | |
6079961f NC |
878 | PPCODE: |
879 | PUSHs(make_op_object(aTHX_ ix ? PL_main_start : PL_main_root)); | |
e97701b4 | 880 | |
2edf0c1d NC |
881 | UV |
882 | sub_generation() | |
883 | ALIAS: | |
884 | dowarn = 1 | |
885 | CODE: | |
886 | RETVAL = ix ? PL_dowarn : PL_sub_generation; | |
887 | OUTPUT: | |
888 | RETVAL | |
889 | ||
a8a597b2 | 890 | void |
20f7624e NC |
891 | walkoptree(op, method) |
892 | B::OP op | |
5d7488b2 | 893 | const char * method |
cea2e8a9 | 894 | CODE: |
20f7624e | 895 | (void) walkoptree(aTHX_ op, method, &PL_sv_undef); |
a8a597b2 MB |
896 | |
897 | int | |
898 | walkoptree_debug(...) | |
899 | CODE: | |
89ca4ac7 | 900 | dMY_CXT; |
a8a597b2 MB |
901 | RETVAL = walkoptree_debug; |
902 | if (items > 0 && SvTRUE(ST(1))) | |
903 | walkoptree_debug = 1; | |
904 | OUTPUT: | |
905 | RETVAL | |
906 | ||
56431972 | 907 | #define address(sv) PTR2IV(sv) |
a8a597b2 MB |
908 | |
909 | IV | |
910 | address(sv) | |
911 | SV * sv | |
912 | ||
8ae5a962 | 913 | void |
a8a597b2 MB |
914 | svref_2object(sv) |
915 | SV * sv | |
8ae5a962 | 916 | PPCODE: |
a8a597b2 MB |
917 | if (!SvROK(sv)) |
918 | croak("argument is not a reference"); | |
0c74f67f | 919 | PUSHs(make_sv_object(aTHX_ SvRV(sv))); |
0cc1d052 NIS |
920 | |
921 | void | |
922 | opnumber(name) | |
5d7488b2 | 923 | const char * name |
0cc1d052 NIS |
924 | CODE: |
925 | { | |
926 | int i; | |
927 | IV result = -1; | |
928 | ST(0) = sv_newmortal(); | |
929 | if (strncmp(name,"pp_",3) == 0) | |
930 | name += 3; | |
931 | for (i = 0; i < PL_maxo; i++) | |
932 | { | |
933 | if (strcmp(name, PL_op_name[i]) == 0) | |
934 | { | |
935 | result = i; | |
936 | break; | |
937 | } | |
938 | } | |
939 | sv_setiv(ST(0),result); | |
940 | } | |
a8a597b2 MB |
941 | |
942 | void | |
943 | ppname(opnum) | |
944 | int opnum | |
945 | CODE: | |
946 | ST(0) = sv_newmortal(); | |
cc5b6bab NC |
947 | if (opnum >= 0 && opnum < PL_maxo) |
948 | Perl_sv_setpvf(aTHX_ ST(0), "pp_%s", PL_op_name[opnum]); | |
a8a597b2 MB |
949 | |
950 | void | |
951 | hash(sv) | |
952 | SV * sv | |
953 | CODE: | |
a8a597b2 MB |
954 | STRLEN len; |
955 | U32 hash = 0; | |
8c5b7c71 | 956 | const char *s = SvPVbyte(sv, len); |
c32d3395 | 957 | PERL_HASH(hash, s, len); |
90b16320 | 958 | ST(0) = sv_2mortal(Perl_newSVpvf(aTHX_ "0x%"UVxf, (UV)hash)); |
a8a597b2 MB |
959 | |
960 | #define cast_I32(foo) (I32)foo | |
961 | IV | |
962 | cast_I32(i) | |
963 | IV i | |
964 | ||
965 | void | |
966 | minus_c() | |
651233d2 NC |
967 | ALIAS: |
968 | save_BEGINs = 1 | |
a8a597b2 | 969 | CODE: |
651233d2 NC |
970 | if (ix) |
971 | PL_savebegin = TRUE; | |
972 | else | |
973 | PL_minus_c = TRUE; | |
059a8bb7 | 974 | |
847ded71 | 975 | void |
a8a597b2 MB |
976 | cstring(sv) |
977 | SV * sv | |
84556172 NC |
978 | ALIAS: |
979 | perlstring = 1 | |
9e380ad4 | 980 | cchar = 2 |
09e97b95 | 981 | PPCODE: |
847ded71 | 982 | PUSHs(ix == 2 ? cchar(aTHX_ sv) : cstring(aTHX_ sv, (bool)ix)); |
a8a597b2 MB |
983 | |
984 | void | |
985 | threadsv_names() | |
986 | PPCODE: | |
f5ba1307 | 987 | |
a8a597b2 | 988 | |
a462fa00 DD |
989 | #ifdef USE_ITHREADS |
990 | void | |
991 | CLONE(...) | |
992 | PPCODE: | |
993 | PUTBACK; /* some vars go out of scope now in machine code */ | |
994 | { | |
995 | MY_CXT_CLONE; | |
996 | B_init_my_cxt(aTHX_ &(MY_CXT)); | |
997 | } | |
998 | return; /* dont execute another implied XSPP PUTBACK */ | |
9488fb36 | 999 | |
a462fa00 | 1000 | #endif |
a9ed1a44 | 1001 | |
fdbacc68 | 1002 | MODULE = B PACKAGE = B::OP |
a8a597b2 | 1003 | |
651aa52e | 1004 | |
9b1961be NC |
1005 | # The type checking code in B has always been identical for all OP types, |
1006 | # irrespective of whether the action is actually defined on that OP. | |
1007 | # We should fix this | |
086f9b42 | 1008 | void |
9b1961be | 1009 | next(o) |
a8a597b2 | 1010 | B::OP o |
9b1961be | 1011 | ALIAS: |
bec746fe DM |
1012 | B::OP::next = 0 |
1013 | B::OP::sibling = 1 | |
1014 | B::OP::targ = 2 | |
1015 | B::OP::flags = 3 | |
1016 | B::OP::private = 4 | |
1017 | B::UNOP::first = 5 | |
1018 | B::BINOP::last = 6 | |
1019 | B::LOGOP::other = 7 | |
1020 | B::PMOP::pmreplstart = 8 | |
1021 | B::LOOP::redoop = 9 | |
1022 | B::LOOP::nextop = 10 | |
1023 | B::LOOP::lastop = 11 | |
1024 | B::PMOP::pmflags = 12 | |
1025 | B::PMOP::code_list = 13 | |
1026 | B::SVOP::sv = 14 | |
1027 | B::SVOP::gv = 15 | |
1028 | B::PADOP::padix = 16 | |
1029 | B::COP::cop_seq = 17 | |
1030 | B::COP::line = 18 | |
1031 | B::COP::hints = 19 | |
1032 | B::PMOP::pmoffset = 20 | |
1033 | B::COP::filegv = 21 | |
1034 | B::COP::file = 22 | |
1035 | B::COP::stash = 23 | |
1036 | B::COP::stashpv = 24 | |
1037 | B::COP::stashoff = 25 | |
287ce0d8 DM |
1038 | B::OP::size = 26 |
1039 | B::OP::name = 27 | |
1040 | B::OP::desc = 28 | |
1041 | B::OP::ppaddr = 29 | |
1042 | B::OP::type = 30 | |
1043 | B::OP::opt = 31 | |
1044 | B::OP::spare = 32 | |
1045 | B::LISTOP::children = 33 | |
1046 | B::PMOP::pmreplroot = 34 | |
1047 | B::PMOP::pmstashpv = 35 | |
1048 | B::PMOP::pmstash = 36 | |
1049 | B::PMOP::precomp = 37 | |
1050 | B::PMOP::reflags = 38 | |
1051 | B::PADOP::sv = 39 | |
1052 | B::PADOP::gv = 40 | |
1053 | B::PVOP::pv = 41 | |
1054 | B::COP::label = 42 | |
1055 | B::COP::arybase = 43 | |
1056 | B::COP::warnings = 44 | |
1057 | B::COP::io = 45 | |
1058 | B::COP::hints_hash = 46 | |
3164fde4 RU |
1059 | B::OP::slabbed = 47 |
1060 | B::OP::savefree = 48 | |
1061 | B::OP::static = 49 | |
1062 | B::OP::folded = 50 | |
87b5a8b9 | 1063 | B::OP::moresib = 51 |
29e61fd9 | 1064 | B::OP::parent = 52 |
b46e009d | 1065 | B::METHOP::first = 53 |
1066 | B::METHOP::meth_sv = 54 | |
429ba3b2 | 1067 | B::PMOP::pmregexp = 55 |
810bd8b7 | 1068 | B::METHOP::rclass = 56 |
9b1961be | 1069 | PREINIT: |
086f9b42 NC |
1070 | SV *ret; |
1071 | PPCODE: | |
99639b5b | 1072 | if (ix < 0 || (U32)ix >= C_ARRAY_LENGTH(op_methods)) |
287ce0d8 | 1073 | croak("Illegal alias %d for B::*OP::next", (int)ix); |
71324a3b DM |
1074 | ret = get_overlay_object(aTHX_ o, |
1075 | op_methods[ix].name, op_methods[ix].namelen); | |
1076 | if (ret) { | |
1077 | ST(0) = ret; | |
1078 | XSRETURN(1); | |
1079 | } | |
bec746fe DM |
1080 | |
1081 | /* handle non-direct field access */ | |
1082 | ||
0508288e | 1083 | if (op_methods[ix].type == op_offset_special) |
bec746fe | 1084 | switch (ix) { |
9d28cd7b | 1085 | case 1: /* B::OP::op_sibling */ |
e6dae479 | 1086 | ret = make_op_object(aTHX_ OpSIBLING(o)); |
1ed44841 DM |
1087 | break; |
1088 | ||
9d28cd7b | 1089 | case 8: /* B::PMOP::pmreplstart */ |
2721a2ca DM |
1090 | ret = make_op_object(aTHX_ |
1091 | cPMOPo->op_type == OP_SUBST | |
1092 | ? cPMOPo->op_pmstashstartu.op_pmreplstart | |
1093 | : NULL | |
1094 | ); | |
1095 | break; | |
bec746fe | 1096 | #ifdef USE_ITHREADS |
9d28cd7b | 1097 | case 21: /* B::COP::filegv */ |
bec746fe DM |
1098 | ret = make_sv_object(aTHX_ (SV *)CopFILEGV((COP*)o)); |
1099 | break; | |
1100 | #endif | |
1dc74fdb | 1101 | #ifndef USE_ITHREADS |
9d28cd7b | 1102 | case 22: /* B::COP::file */ |
bec746fe DM |
1103 | ret = sv_2mortal(newSVpv(CopFILE((COP*)o), 0)); |
1104 | break; | |
1105 | #endif | |
1106 | #ifdef USE_ITHREADS | |
9d28cd7b | 1107 | case 23: /* B::COP::stash */ |
bec746fe DM |
1108 | ret = make_sv_object(aTHX_ (SV *)CopSTASH((COP*)o)); |
1109 | break; | |
1110 | #endif | |
1111 | #if PERL_VERSION >= 17 || !defined USE_ITHREADS | |
9d28cd7b | 1112 | case 24: /* B::COP::stashpv */ |
bec746fe DM |
1113 | # if PERL_VERSION >= 17 |
1114 | ret = sv_2mortal(CopSTASH((COP*)o) | |
1115 | && SvTYPE(CopSTASH((COP*)o)) == SVt_PVHV | |
1116 | ? newSVhek(HvNAME_HEK(CopSTASH((COP*)o))) | |
1117 | : &PL_sv_undef); | |
1118 | # else | |
1119 | ret = sv_2mortal(newSVpv(CopSTASHPV((COP*)o), 0)); | |
1120 | # endif | |
1121 | break; | |
1122 | #endif | |
9d28cd7b | 1123 | case 26: /* B::OP::size */ |
287ce0d8 DM |
1124 | ret = sv_2mortal(newSVuv((UV)(opsizes[cc_opclass(aTHX_ o)]))); |
1125 | break; | |
9d28cd7b DM |
1126 | case 27: /* B::OP::name */ |
1127 | case 28: /* B::OP::desc */ | |
287ce0d8 DM |
1128 | ret = sv_2mortal(newSVpv( |
1129 | (char *)(ix == 28 ? OP_DESC(o) : OP_NAME(o)), 0)); | |
1130 | break; | |
9d28cd7b | 1131 | case 29: /* B::OP::ppaddr */ |
287ce0d8 DM |
1132 | { |
1133 | int i; | |
1134 | ret = sv_2mortal(Perl_newSVpvf(aTHX_ "PL_ppaddr[OP_%s]", | |
1135 | PL_op_name[o->op_type])); | |
1136 | for (i=13; (STRLEN)i < SvCUR(ret); ++i) | |
1137 | SvPVX(ret)[i] = toUPPER(SvPVX(ret)[i]); | |
1138 | } | |
1139 | break; | |
9d28cd7b DM |
1140 | case 30: /* B::OP::type */ |
1141 | case 31: /* B::OP::opt */ | |
1142 | case 32: /* B::OP::spare */ | |
3164fde4 | 1143 | #if PERL_VERSION >= 17 |
9d28cd7b DM |
1144 | case 47: /* B::OP::slabbed */ |
1145 | case 48: /* B::OP::savefree */ | |
1146 | case 49: /* B::OP::static */ | |
3164fde4 | 1147 | #if PERL_VERSION >= 19 |
9d28cd7b | 1148 | case 50: /* B::OP::folded */ |
87b5a8b9 | 1149 | case 51: /* B::OP::moresib */ |
3164fde4 RU |
1150 | #endif |
1151 | #endif | |
1152 | /* These are all bitfields, so we can't take their addresses */ | |
287ce0d8 DM |
1153 | ret = sv_2mortal(newSVuv((UV)( |
1154 | ix == 30 ? o->op_type | |
1155 | : ix == 31 ? o->op_opt | |
3164fde4 RU |
1156 | : ix == 47 ? o->op_slabbed |
1157 | : ix == 48 ? o->op_savefree | |
1158 | : ix == 49 ? o->op_static | |
1159 | : ix == 50 ? o->op_folded | |
87b5a8b9 | 1160 | : ix == 51 ? o->op_moresib |
287ce0d8 DM |
1161 | : o->op_spare))); |
1162 | break; | |
9d28cd7b | 1163 | case 33: /* B::LISTOP::children */ |
287ce0d8 DM |
1164 | { |
1165 | OP *kid; | |
1166 | UV i = 0; | |
e6dae479 | 1167 | for (kid = ((LISTOP*)o)->op_first; kid; kid = OpSIBLING(kid)) |
287ce0d8 DM |
1168 | i++; |
1169 | ret = sv_2mortal(newSVuv(i)); | |
1170 | } | |
1171 | break; | |
9d28cd7b | 1172 | case 34: /* B::PMOP::pmreplroot */ |
287ce0d8 DM |
1173 | if (cPMOPo->op_type == OP_PUSHRE) { |
1174 | #ifdef USE_ITHREADS | |
1175 | ret = sv_newmortal(); | |
1176 | sv_setiv(ret, cPMOPo->op_pmreplrootu.op_pmtargetoff); | |
1177 | #else | |
1178 | GV *const target = cPMOPo->op_pmreplrootu.op_pmtargetgv; | |
1179 | ret = sv_newmortal(); | |
1180 | sv_setiv(newSVrv(ret, target ? | |
1181 | svclassnames[SvTYPE((SV*)target)] : "B::SV"), | |
1182 | PTR2IV(target)); | |
1183 | #endif | |
1184 | } | |
1185 | else { | |
1186 | OP *const root = cPMOPo->op_pmreplrootu.op_pmreplroot; | |
1187 | ret = make_op_object(aTHX_ root); | |
1188 | } | |
1189 | break; | |
1190 | #ifdef USE_ITHREADS | |
9d28cd7b | 1191 | case 35: /* B::PMOP::pmstashpv */ |
287ce0d8 DM |
1192 | ret = sv_2mortal(newSVpv(PmopSTASHPV(cPMOPo),0)); |
1193 | break; | |
1194 | #else | |
9d28cd7b | 1195 | case 36: /* B::PMOP::pmstash */ |
287ce0d8 DM |
1196 | ret = make_sv_object(aTHX_ (SV *) PmopSTASH(cPMOPo)); |
1197 | break; | |
1198 | #endif | |
9d28cd7b DM |
1199 | case 37: /* B::PMOP::precomp */ |
1200 | case 38: /* B::PMOP::reflags */ | |
287ce0d8 DM |
1201 | { |
1202 | REGEXP *rx = PM_GETRE(cPMOPo); | |
1203 | ret = sv_newmortal(); | |
1204 | if (rx) { | |
1205 | if (ix==38) { | |
1206 | sv_setuv(ret, RX_EXTFLAGS(rx)); | |
1207 | } | |
1208 | else { | |
1209 | sv_setpvn(ret, RX_PRECOMP(rx), RX_PRELEN(rx)); | |
fea7fb25 DM |
1210 | if (RX_UTF8(rx)) |
1211 | SvUTF8_on(ret); | |
287ce0d8 DM |
1212 | } |
1213 | } | |
1214 | } | |
1215 | break; | |
3a23d767 DM |
1216 | case 39: /* B::PADOP::sv */ |
1217 | case 40: /* B::PADOP::gv */ | |
1218 | /* PADOPs should only be created on threaded builds. | |
1219 | * They don't have an sv or gv field, just an op_padix | |
1220 | * field. Leave it to the caller to retrieve padix | |
1221 | * and look up th value in the pad. Don't do it here, | |
1222 | * becuase PL_curpad is the pad of the caller, not the | |
1223 | * pad of the sub the op is part of */ | |
1224 | ret = make_sv_object(aTHX_ NULL); | |
287ce0d8 | 1225 | break; |
9d28cd7b | 1226 | case 41: /* B::PVOP::pv */ |
287ce0d8 DM |
1227 | /* OP_TRANS uses op_pv to point to a table of 256 or >=258 |
1228 | * shorts whereas other PVOPs point to a null terminated | |
1229 | * string. */ | |
1230 | if ( (cPVOPo->op_type == OP_TRANS | |
1231 | || cPVOPo->op_type == OP_TRANSR) && | |
1232 | (cPVOPo->op_private & OPpTRANS_COMPLEMENT) && | |
1233 | !(cPVOPo->op_private & OPpTRANS_DELETE)) | |
1234 | { | |
1235 | const short* const tbl = (short*)cPVOPo->op_pv; | |
1236 | const short entries = 257 + tbl[256]; | |
1237 | ret = newSVpvn_flags(cPVOPo->op_pv, entries * sizeof(short), SVs_TEMP); | |
1238 | } | |
1239 | else if (cPVOPo->op_type == OP_TRANS || cPVOPo->op_type == OP_TRANSR) { | |
1240 | ret = newSVpvn_flags(cPVOPo->op_pv, 256 * sizeof(short), SVs_TEMP); | |
1241 | } | |
1242 | else | |
1243 | ret = newSVpvn_flags(cPVOPo->op_pv, strlen(cPVOPo->op_pv), SVs_TEMP); | |
1244 | break; | |
9d28cd7b | 1245 | case 42: /* B::COP::label */ |
287ce0d8 DM |
1246 | ret = sv_2mortal(newSVpv(CopLABEL(cCOPo),0)); |
1247 | break; | |
9d28cd7b | 1248 | case 43: /* B::COP::arybase */ |
287ce0d8 DM |
1249 | ret = sv_2mortal(newSVuv(0)); |
1250 | break; | |
9d28cd7b | 1251 | case 44: /* B::COP::warnings */ |
287ce0d8 DM |
1252 | ret = make_warnings_object(aTHX_ cCOPo); |
1253 | break; | |
9d28cd7b | 1254 | case 45: /* B::COP::io */ |
287ce0d8 DM |
1255 | ret = make_cop_io_object(aTHX_ cCOPo); |
1256 | break; | |
9d28cd7b | 1257 | case 46: /* B::COP::hints_hash */ |
287ce0d8 DM |
1258 | ret = sv_newmortal(); |
1259 | sv_setiv(newSVrv(ret, "B::RHE"), | |
1260 | PTR2IV(CopHINTHASH_get(cCOPo))); | |
1261 | break; | |
9d28cd7b | 1262 | case 52: /* B::OP::parent */ |
1fafe688 | 1263 | #ifdef PERL_OP_PARENT |
29e61fd9 | 1264 | ret = make_op_object(aTHX_ op_parent(o)); |
1fafe688 DM |
1265 | #else |
1266 | ret = make_op_object(aTHX_ NULL); | |
1267 | #endif | |
29e61fd9 | 1268 | break; |
b46e009d | 1269 | case 53: /* B::METHOP::first */ |
1270 | /* METHOP struct has an op_first/op_meth_sv union | |
1271 | * as its first extra field. How to interpret the | |
1272 | * union depends on the op type. For the purposes of | |
1273 | * B, we treat it as a struct with both fields present, | |
1274 | * where one of the fields always happens to be null | |
1275 | * (i.e. we return NULL in preference to croaking with | |
1276 | * 'method not implemented'). | |
1277 | */ | |
1278 | ret = make_op_object(aTHX_ | |
1279 | o->op_type == OP_METHOD | |
1280 | ? cMETHOPx(o)->op_u.op_first : NULL); | |
1281 | break; | |
1282 | case 54: /* B::METHOP::meth_sv */ | |
1283 | /* see comment above about METHOP */ | |
1284 | ret = make_sv_object(aTHX_ | |
1285 | o->op_type == OP_METHOD | |
1286 | ? NULL : cMETHOPx(o)->op_u.op_meth_sv); | |
1287 | break; | |
429ba3b2 FC |
1288 | case 55: /* B::PMOP::pmregexp */ |
1289 | ret = make_sv_object(aTHX_ (SV *)PM_GETRE(cPMOPo)); | |
1290 | break; | |
810bd8b7 | 1291 | case 56: /* B::METHOP::rclass */ |
1292 | #ifdef USE_ITHREADS | |
1293 | ret = sv_2mortal(newSVuv( | |
1294 | (o->op_type == OP_METHOD_REDIR || | |
1295 | o->op_type == OP_METHOD_REDIR_SUPER) ? | |
1296 | cMETHOPx(o)->op_rclass_targ : 0 | |
1297 | )); | |
1298 | #else | |
1299 | ret = make_sv_object(aTHX_ | |
1300 | (o->op_type == OP_METHOD_REDIR || | |
1301 | o->op_type == OP_METHOD_REDIR_SUPER) ? | |
1302 | cMETHOPx(o)->op_rclass_sv : NULL | |
1303 | ); | |
1304 | #endif | |
1305 | break; | |
bec746fe DM |
1306 | default: |
1307 | croak("method %s not implemented", op_methods[ix].name); | |
0508288e NC |
1308 | } else { |
1309 | /* do a direct structure offset lookup */ | |
1310 | const char *const ptr = (char *)o + op_methods[ix].offset; | |
f68c0b4a NC |
1311 | switch (op_methods[ix].type) { |
1312 | case OPp: | |
1313 | ret = make_op_object(aTHX_ *((OP **)ptr)); | |
1314 | break; | |
1315 | case PADOFFSETp: | |
1316 | ret = sv_2mortal(newSVuv(*((PADOFFSET*)ptr))); | |
1317 | break; | |
1318 | case U8p: | |
1319 | ret = sv_2mortal(newSVuv(*((U8*)ptr))); | |
1320 | break; | |
1321 | case U32p: | |
1322 | ret = sv_2mortal(newSVuv(*((U32*)ptr))); | |
1323 | break; | |
1324 | case SVp: | |
1325 | ret = make_sv_object(aTHX_ *((SV **)ptr)); | |
1326 | break; | |
1327 | case line_tp: | |
1328 | ret = sv_2mortal(newSVuv(*((line_t *)ptr))); | |
1329 | break; | |
1330 | case IVp: | |
1331 | ret = sv_2mortal(newSViv(*((IV*)ptr))); | |
1332 | break; | |
1333 | case char_pp: | |
1334 | ret = sv_2mortal(newSVpv(*((char **)ptr), 0)); | |
1335 | break; | |
1336 | default: | |
0508288e | 1337 | croak("Illegal type 0x%x for B::*OP::%s", |
f68c0b4a | 1338 | (unsigned)op_methods[ix].type, op_methods[ix].name); |
0508288e | 1339 | } |
086f9b42 NC |
1340 | } |
1341 | ST(0) = ret; | |
1342 | XSRETURN(1); | |
a8a597b2 | 1343 | |
7252851f | 1344 | |
1df34986 | 1345 | void |
fdbacc68 | 1346 | oplist(o) |
1df34986 AE |
1347 | B::OP o |
1348 | PPCODE: | |
1349 | SP = oplist(aTHX_ o, SP); | |
1350 | ||
e412117e | 1351 | |
2f7c6295 DM |
1352 | |
1353 | MODULE = B PACKAGE = B::UNOP_AUX | |
1354 | ||
1355 | # UNOP_AUX class ops are like UNOPs except that they have an extra | |
1356 | # op_aux pointer that points to an array of UNOP_AUX_item unions. | |
1357 | # Element -1 of the array contains the length | |
1358 | ||
1359 | ||
1360 | # return a string representation of op_aux where possible The op's CV is | |
1361 | # needed as an extra arg to allow GVs and SVs moved into the pad to be | |
1362 | # accessed okay. | |
1363 | ||
1364 | void | |
1365 | string(o, cv) | |
1366 | B::OP o | |
1367 | B::CV cv | |
1368 | PREINIT: | |
1369 | SV *ret; | |
1370 | PPCODE: | |
1371 | switch (o->op_type) { | |
fedf30e1 | 1372 | case OP_MULTIDEREF: |
48ee9c0e | 1373 | ret = multideref_stringify(o, cv); |
fedf30e1 | 1374 | break; |
2f7c6295 DM |
1375 | default: |
1376 | ret = sv_2mortal(newSVpvn("", 0)); | |
1377 | } | |
1378 | ST(0) = ret; | |
1379 | XSRETURN(1); | |
1380 | ||
1381 | ||
1382 | # Return the contents of the op_aux array as a list of IV/GV/etc objects. | |
1383 | # How to interpret each array element is op-dependent. The op's CV is | |
1384 | # needed as an extra arg to allow GVs and SVs which have been moved into | |
1385 | # the pad to be accessed okay. | |
1386 | ||
1387 | void | |
1388 | aux_list(o, cv) | |
1389 | B::OP o | |
1390 | B::CV cv | |
1391 | PPCODE: | |
fedf30e1 | 1392 | PERL_UNUSED_VAR(cv); /* not needed on unthreaded builds */ |
2f7c6295 DM |
1393 | switch (o->op_type) { |
1394 | default: | |
1395 | XSRETURN(0); /* by default, an empty list */ | |
fedf30e1 DM |
1396 | |
1397 | case OP_MULTIDEREF: | |
1398 | #ifdef USE_ITHREADS | |
1399 | # define ITEM_SV(item) *av_fetch(comppad, (item)->pad_offset, FALSE); | |
1400 | #else | |
1401 | # define ITEM_SV(item) UNOP_AUX_item_sv(item) | |
1402 | #endif | |
1403 | { | |
1404 | UNOP_AUX_item *items = cUNOP_AUXo->op_aux; | |
1405 | UV actions = items->uv; | |
1406 | UV len = items[-1].uv; | |
1407 | SV *sv; | |
1408 | bool last = 0; | |
1409 | bool is_hash = FALSE; | |
1410 | #ifdef USE_ITHREADS | |
1411 | PADLIST * const padlist = CvPADLIST(cv); | |
9cdf4efd | 1412 | PAD *comppad = PadlistARRAY(padlist)[1]; |
fedf30e1 DM |
1413 | #endif |
1414 | ||
1415 | EXTEND(SP, len); | |
1416 | PUSHs(sv_2mortal(newSViv(actions))); | |
1417 | ||
1418 | while (!last) { | |
1419 | switch (actions & MDEREF_ACTION_MASK) { | |
1420 | ||
1421 | case MDEREF_reload: | |
1422 | actions = (++items)->uv; | |
1423 | PUSHs(sv_2mortal(newSVuv(actions))); | |
1424 | continue; | |
2b5060ae | 1425 | NOT_REACHED; /* NOTREACHED */ |
fedf30e1 DM |
1426 | |
1427 | case MDEREF_HV_padhv_helem: | |
1428 | is_hash = TRUE; | |
2b5060ae | 1429 | /* FALLTHROUGH */ |
fedf30e1 DM |
1430 | case MDEREF_AV_padav_aelem: |
1431 | PUSHs(sv_2mortal(newSVuv((++items)->pad_offset))); | |
1432 | goto do_elem; | |
2b5060ae | 1433 | NOT_REACHED; /* NOTREACHED */ |
fedf30e1 DM |
1434 | |
1435 | case MDEREF_HV_gvhv_helem: | |
1436 | is_hash = TRUE; | |
2b5060ae | 1437 | /* FALLTHROUGH */ |
fedf30e1 DM |
1438 | case MDEREF_AV_gvav_aelem: |
1439 | sv = ITEM_SV(++items); | |
1440 | PUSHs(make_sv_object(aTHX_ sv)); | |
1441 | goto do_elem; | |
2b5060ae | 1442 | NOT_REACHED; /* NOTREACHED */ |
fedf30e1 DM |
1443 | |
1444 | case MDEREF_HV_gvsv_vivify_rv2hv_helem: | |
1445 | is_hash = TRUE; | |
2b5060ae | 1446 | /* FALLTHROUGH */ |
fedf30e1 DM |
1447 | case MDEREF_AV_gvsv_vivify_rv2av_aelem: |
1448 | sv = ITEM_SV(++items); | |
1449 | PUSHs(make_sv_object(aTHX_ sv)); | |
1450 | goto do_vivify_rv2xv_elem; | |
2b5060ae | 1451 | NOT_REACHED; /* NOTREACHED */ |
fedf30e1 DM |
1452 | |
1453 | case MDEREF_HV_padsv_vivify_rv2hv_helem: | |
1454 | is_hash = TRUE; | |
2b5060ae | 1455 | /* FALLTHROUGH */ |
fedf30e1 DM |
1456 | case MDEREF_AV_padsv_vivify_rv2av_aelem: |
1457 | PUSHs(sv_2mortal(newSVuv((++items)->pad_offset))); | |
1458 | goto do_vivify_rv2xv_elem; | |
2b5060ae | 1459 | NOT_REACHED; /* NOTREACHED */ |
fedf30e1 DM |
1460 | |
1461 | case MDEREF_HV_pop_rv2hv_helem: | |
1462 | case MDEREF_HV_vivify_rv2hv_helem: | |
1463 | is_hash = TRUE; | |
2b5060ae | 1464 | /* FALLTHROUGH */ |
fedf30e1 DM |
1465 | do_vivify_rv2xv_elem: |
1466 | case MDEREF_AV_pop_rv2av_aelem: | |
1467 | case MDEREF_AV_vivify_rv2av_aelem: | |
1468 | do_elem: | |
1469 | switch (actions & MDEREF_INDEX_MASK) { | |
1470 | case MDEREF_INDEX_none: | |
1471 | last = 1; | |
1472 | break; | |
1473 | case MDEREF_INDEX_const: | |
1474 | if (is_hash) { | |
1475 | sv = ITEM_SV(++items); | |
1476 | PUSHs(make_sv_object(aTHX_ sv)); | |
1477 | } | |
1478 | else | |
1479 | PUSHs(sv_2mortal(newSViv((++items)->iv))); | |
1480 | break; | |
1481 | case MDEREF_INDEX_padsv: | |
1482 | PUSHs(sv_2mortal(newSVuv((++items)->pad_offset))); | |
1483 | break; | |
1484 | case MDEREF_INDEX_gvsv: | |
1485 | sv = ITEM_SV(++items); | |
1486 | PUSHs(make_sv_object(aTHX_ sv)); | |
1487 | break; | |
1488 | } | |
1489 | if (actions & MDEREF_FLAG_last) | |
1490 | last = 1; | |
1491 | is_hash = FALSE; | |
1492 | ||
1493 | break; | |
1494 | } /* switch */ | |
1495 | ||
1496 | actions >>= MDEREF_SHIFT; | |
1497 | } /* while */ | |
1498 | XSRETURN(len); | |
1499 | ||
1500 | } /* OP_MULTIDEREF */ | |
2f7c6295 DM |
1501 | } /* switch */ |
1502 | ||
1503 | ||
1504 | ||
651aa52e AE |
1505 | MODULE = B PACKAGE = B::SV |
1506 | ||
de64752d NC |
1507 | #define MAGICAL_FLAG_BITS (SVs_GMG|SVs_SMG|SVs_RMG) |
1508 | ||
651aa52e | 1509 | U32 |
de64752d | 1510 | REFCNT(sv) |
651aa52e | 1511 | B::SV sv |
de64752d NC |
1512 | ALIAS: |
1513 | FLAGS = 0xFFFFFFFF | |
1514 | SvTYPE = SVTYPEMASK | |
1515 | POK = SVf_POK | |
1516 | ROK = SVf_ROK | |
1517 | MAGICAL = MAGICAL_FLAG_BITS | |
1518 | CODE: | |
1519 | RETVAL = ix ? (SvFLAGS(sv) & (U32)ix) : SvREFCNT(sv); | |
1520 | OUTPUT: | |
1521 | RETVAL | |
651aa52e | 1522 | |
9efba5c8 | 1523 | void |
429a5ce7 SM |
1524 | object_2svref(sv) |
1525 | B::SV sv | |
9efba5c8 NC |
1526 | PPCODE: |
1527 | ST(0) = sv_2mortal(newRV(sv)); | |
1528 | XSRETURN(1); | |
1529 | ||
a8a597b2 MB |
1530 | MODULE = B PACKAGE = B::IV PREFIX = Sv |
1531 | ||
1532 | IV | |
1533 | SvIV(sv) | |
1534 | B::IV sv | |
1535 | ||
e4da9d6a | 1536 | MODULE = B PACKAGE = B::IV |
a8a597b2 | 1537 | |
e4da9d6a NC |
1538 | #define sv_SVp 0x00000 |
1539 | #define sv_IVp 0x10000 | |
1540 | #define sv_UVp 0x20000 | |
1541 | #define sv_STRLENp 0x30000 | |
1542 | #define sv_U32p 0x40000 | |
1543 | #define sv_U8p 0x50000 | |
1544 | #define sv_char_pp 0x60000 | |
1545 | #define sv_NVp 0x70000 | |
6782c6e0 | 1546 | #define sv_char_p 0x80000 |
3da43c35 | 1547 | #define sv_SSize_tp 0x90000 |
ffc5d9fc NC |
1548 | #define sv_I32p 0xA0000 |
1549 | #define sv_U16p 0xB0000 | |
e4da9d6a | 1550 | |
3800c318 JH |
1551 | #define IV_ivx_ix sv_IVp | STRUCT_OFFSET(struct xpviv, xiv_iv) |
1552 | #define IV_uvx_ix sv_UVp | STRUCT_OFFSET(struct xpvuv, xuv_uv) | |
1553 | #define NV_nvx_ix sv_NVp | STRUCT_OFFSET(struct xpvnv, xnv_u.xnv_nv) | |
e4da9d6a | 1554 | |
3800c318 JH |
1555 | #define PV_cur_ix sv_STRLENp | STRUCT_OFFSET(struct xpv, xpv_cur) |
1556 | #define PV_len_ix sv_STRLENp | STRUCT_OFFSET(struct xpv, xpv_len) | |
6782c6e0 | 1557 | |
3800c318 | 1558 | #define PVMG_stash_ix sv_SVp | STRUCT_OFFSET(struct xpvmg, xmg_stash) |
6782c6e0 | 1559 | |
8922e438 | 1560 | #if PERL_VERSION > 18 |
3800c318 | 1561 | # define PVBM_useful_ix sv_IVp | STRUCT_OFFSET(struct xpviv, xiv_u.xivu_iv) |
8922e438 | 1562 | #elif PERL_VERSION > 14 |
3800c318 | 1563 | # define PVBM_useful_ix sv_I32p | STRUCT_OFFSET(struct xpvgv, xnv_u.xbm_s.xbm_useful) |
35633035 | 1564 | #else |
3800c318 | 1565 | #define PVBM_useful_ix sv_I32p | STRUCT_OFFSET(struct xpvgv, xiv_u.xivu_i32) |
91a71e08 NC |
1566 | #endif |
1567 | ||
3800c318 JH |
1568 | #define PVLV_targoff_ix sv_U32p | STRUCT_OFFSET(struct xpvlv, xlv_targoff) |
1569 | #define PVLV_targlen_ix sv_U32p | STRUCT_OFFSET(struct xpvlv, xlv_targlen) | |
1570 | #define PVLV_targ_ix sv_SVp | STRUCT_OFFSET(struct xpvlv, xlv_targ) | |
1571 | #define PVLV_type_ix sv_char_p | STRUCT_OFFSET(struct xpvlv, xlv_type) | |
1572 | ||
1573 | #define PVGV_stash_ix sv_SVp | STRUCT_OFFSET(struct xpvgv, xnv_u.xgv_stash) | |
1574 | #define PVGV_flags_ix sv_STRLENp | STRUCT_OFFSET(struct xpvgv, xpv_cur) | |
1575 | #define PVIO_lines_ix sv_IVp | STRUCT_OFFSET(struct xpvio, xiv_iv) | |
1576 | ||
1577 | #define PVIO_page_ix sv_IVp | STRUCT_OFFSET(struct xpvio, xio_page) | |
1578 | #define PVIO_page_len_ix sv_IVp | STRUCT_OFFSET(struct xpvio, xio_page_len) | |
1579 | #define PVIO_lines_left_ix sv_IVp | STRUCT_OFFSET(struct xpvio, xio_lines_left) | |
1580 | #define PVIO_top_name_ix sv_char_pp | STRUCT_OFFSET(struct xpvio, xio_top_name) | |
1581 | #define PVIO_top_gv_ix sv_SVp | STRUCT_OFFSET(struct xpvio, xio_top_gv) | |
1582 | #define PVIO_fmt_name_ix sv_char_pp | STRUCT_OFFSET(struct xpvio, xio_fmt_name) | |
1583 | #define PVIO_fmt_gv_ix sv_SVp | STRUCT_OFFSET(struct xpvio, xio_fmt_gv) | |
1584 | #define PVIO_bottom_name_ix sv_char_pp | STRUCT_OFFSET(struct xpvio, xio_bottom_name) | |
1585 | #define PVIO_bottom_gv_ix sv_SVp | STRUCT_OFFSET(struct xpvio, xio_bottom_gv) | |
1586 | #define PVIO_type_ix sv_char_p | STRUCT_OFFSET(struct xpvio, xio_type) | |
1587 | #define PVIO_flags_ix sv_U8p | STRUCT_OFFSET(struct xpvio, xio_flags) | |
1588 | ||
1589 | #define PVAV_max_ix sv_SSize_tp | STRUCT_OFFSET(struct xpvav, xav_max) | |
1590 | ||
1591 | #define PVCV_stash_ix sv_SVp | STRUCT_OFFSET(struct xpvcv, xcv_stash) | |
b290562e | 1592 | #if PERL_VERSION > 17 || (PERL_VERSION == 17 && PERL_SUBVERSION >= 3) |
3800c318 | 1593 | # define PVCV_gv_ix sv_SVp | STRUCT_OFFSET(struct xpvcv, xcv_gv_u.xcv_gv) |
b290562e | 1594 | #else |
3800c318 | 1595 | # define PVCV_gv_ix sv_SVp | STRUCT_OFFSET(struct xpvcv, xcv_gv) |
b290562e | 1596 | #endif |
3800c318 JH |
1597 | #define PVCV_file_ix sv_char_pp | STRUCT_OFFSET(struct xpvcv, xcv_file) |
1598 | #define PVCV_outside_ix sv_SVp | STRUCT_OFFSET(struct xpvcv, xcv_outside) | |
1599 | #define PVCV_outside_seq_ix sv_U32p | STRUCT_OFFSET(struct xpvcv, xcv_outside_seq) | |
1600 | #define PVCV_flags_ix sv_U32p | STRUCT_OFFSET(struct xpvcv, xcv_flags) | |
ffc5d9fc | 1601 | |
3800c318 | 1602 | #define PVHV_max_ix sv_STRLENp | STRUCT_OFFSET(struct xpvhv, xhv_max) |
d65a2b0a NC |
1603 | |
1604 | #if PERL_VERSION > 12 | |
3800c318 | 1605 | #define PVHV_keys_ix sv_STRLENp | STRUCT_OFFSET(struct xpvhv, xhv_keys) |
d65a2b0a | 1606 | #else |
3800c318 | 1607 | #define PVHV_keys_ix sv_IVp | STRUCT_OFFSET(struct xpvhv, xhv_keys) |
d65a2b0a NC |
1608 | #endif |
1609 | ||
e4da9d6a NC |
1610 | # The type checking code in B has always been identical for all SV types, |
1611 | # irrespective of whether the action is actually defined on that SV. | |
1612 | # We should fix this | |
1613 | void | |
1614 | IVX(sv) | |
1615 | B::SV sv | |
1616 | ALIAS: | |
1617 | B::IV::IVX = IV_ivx_ix | |
1618 | B::IV::UVX = IV_uvx_ix | |
1619 | B::NV::NVX = NV_nvx_ix | |
6782c6e0 NC |
1620 | B::PV::CUR = PV_cur_ix |
1621 | B::PV::LEN = PV_len_ix | |
1622 | B::PVMG::SvSTASH = PVMG_stash_ix | |
1623 | B::PVLV::TARGOFF = PVLV_targoff_ix | |
1624 | B::PVLV::TARGLEN = PVLV_targlen_ix | |
1625 | B::PVLV::TARG = PVLV_targ_ix | |
1626 | B::PVLV::TYPE = PVLV_type_ix | |
f1f19364 NC |
1627 | B::GV::STASH = PVGV_stash_ix |
1628 | B::GV::GvFLAGS = PVGV_flags_ix | |
91a71e08 | 1629 | B::BM::USEFUL = PVBM_useful_ix |
55440d31 NC |
1630 | B::IO::LINES = PVIO_lines_ix |
1631 | B::IO::PAGE = PVIO_page_ix | |
1632 | B::IO::PAGE_LEN = PVIO_page_len_ix | |
1633 | B::IO::LINES_LEFT = PVIO_lines_left_ix | |
1634 | B::IO::TOP_NAME = PVIO_top_name_ix | |
1635 | B::IO::TOP_GV = PVIO_top_gv_ix | |
1636 | B::IO::FMT_NAME = PVIO_fmt_name_ix | |
1637 | B::IO::FMT_GV = PVIO_fmt_gv_ix | |
1638 | B::IO::BOTTOM_NAME = PVIO_bottom_name_ix | |
1639 | B::IO::BOTTOM_GV = PVIO_bottom_gv_ix | |
1640 | B::IO::IoTYPE = PVIO_type_ix | |
1641 | B::IO::IoFLAGS = PVIO_flags_ix | |
3da43c35 | 1642 | B::AV::MAX = PVAV_max_ix |
ffc5d9fc | 1643 | B::CV::STASH = PVCV_stash_ix |
ffc5d9fc | 1644 | B::CV::FILE = PVCV_file_ix |
ffc5d9fc NC |
1645 | B::CV::OUTSIDE = PVCV_outside_ix |
1646 | B::CV::OUTSIDE_SEQ = PVCV_outside_seq_ix | |
1647 | B::CV::CvFLAGS = PVCV_flags_ix | |
d65a2b0a NC |
1648 | B::HV::MAX = PVHV_max_ix |
1649 | B::HV::KEYS = PVHV_keys_ix | |
e4da9d6a NC |
1650 | PREINIT: |
1651 | char *ptr; | |
1652 | SV *ret; | |
1653 | PPCODE: | |
1654 | ptr = (ix & 0xFFFF) + (char *)SvANY(sv); | |
1655 | switch ((U8)(ix >> 16)) { | |
1656 | case (U8)(sv_SVp >> 16): | |
428744c7 | 1657 | ret = make_sv_object(aTHX_ *((SV **)ptr)); |
e4da9d6a NC |
1658 | break; |
1659 | case (U8)(sv_IVp >> 16): | |
1660 | ret = sv_2mortal(newSViv(*((IV *)ptr))); | |
1661 | break; | |
1662 | case (U8)(sv_UVp >> 16): | |
1663 | ret = sv_2mortal(newSVuv(*((UV *)ptr))); | |
1664 | break; | |
6782c6e0 NC |
1665 | case (U8)(sv_STRLENp >> 16): |
1666 | ret = sv_2mortal(newSVuv(*((STRLEN *)ptr))); | |
1667 | break; | |
e4da9d6a NC |
1668 | case (U8)(sv_U32p >> 16): |
1669 | ret = sv_2mortal(newSVuv(*((U32 *)ptr))); | |
1670 | break; | |
1671 | case (U8)(sv_U8p >> 16): | |
1672 | ret = sv_2mortal(newSVuv(*((U8 *)ptr))); | |
1673 | break; | |
1674 | case (U8)(sv_char_pp >> 16): | |
1675 | ret = sv_2mortal(newSVpv(*((char **)ptr), 0)); | |
1676 | break; | |
1677 | case (U8)(sv_NVp >> 16): | |
1678 | ret = sv_2mortal(newSVnv(*((NV *)ptr))); | |
1679 | break; | |
6782c6e0 NC |
1680 | case (U8)(sv_char_p >> 16): |
1681 | ret = newSVpvn_flags((char *)ptr, 1, SVs_TEMP); | |
1682 | break; | |
3da43c35 NC |
1683 | case (U8)(sv_SSize_tp >> 16): |
1684 | ret = sv_2mortal(newSViv(*((SSize_t *)ptr))); | |
1685 | break; | |
ffc5d9fc NC |
1686 | case (U8)(sv_I32p >> 16): |
1687 | ret = sv_2mortal(newSVuv(*((I32 *)ptr))); | |
1688 | break; | |
1689 | case (U8)(sv_U16p >> 16): | |
1690 | ret = sv_2mortal(newSVuv(*((U16 *)ptr))); | |
1691 | break; | |
c33e8be1 Z |
1692 | default: |
1693 | croak("Illegal alias 0x%08x for B::*IVX", (unsigned)ix); | |
e4da9d6a NC |
1694 | } |
1695 | ST(0) = ret; | |
1696 | XSRETURN(1); | |
a8a597b2 | 1697 | |
a8a597b2 MB |
1698 | void |
1699 | packiv(sv) | |
1700 | B::IV sv | |
6829f5e2 NC |
1701 | ALIAS: |
1702 | needs64bits = 1 | |
a8a597b2 | 1703 | CODE: |
6829f5e2 NC |
1704 | if (ix) { |
1705 | ST(0) = boolSV((I32)SvIVX(sv) != SvIVX(sv)); | |
1706 | } else if (sizeof(IV) == 8) { | |
a8a597b2 | 1707 | U32 wp[2]; |
5d7488b2 | 1708 | const IV iv = SvIVX(sv); |
a8a597b2 MB |
1709 | /* |
1710 | * The following way of spelling 32 is to stop compilers on | |
1711 | * 32-bit architectures from moaning about the shift count | |
1712 | * being >= the width of the type. Such architectures don't | |
1713 | * reach this code anyway (unless sizeof(IV) > 8 but then | |
1714 | * everything else breaks too so I'm not fussed at the moment). | |
1715 | */ | |
42718184 RB |
1716 | #ifdef UV_IS_QUAD |
1717 | wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4)); | |
1718 | #else | |
1719 | wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4)); | |
1720 | #endif | |
a8a597b2 | 1721 | wp[1] = htonl(iv & 0xffffffff); |
d3d34884 | 1722 | ST(0) = newSVpvn_flags((char *)wp, 8, SVs_TEMP); |
a8a597b2 MB |
1723 | } else { |
1724 | U32 w = htonl((U32)SvIVX(sv)); | |
d3d34884 | 1725 | ST(0) = newSVpvn_flags((char *)&w, 4, SVs_TEMP); |
a8a597b2 MB |
1726 | } |
1727 | ||
1728 | MODULE = B PACKAGE = B::NV PREFIX = Sv | |
1729 | ||
76ef7183 | 1730 | NV |
a8a597b2 MB |
1731 | SvNV(sv) |
1732 | B::NV sv | |
1733 | ||
4df7f6af NC |
1734 | #if PERL_VERSION < 11 |
1735 | ||
a8a597b2 MB |
1736 | MODULE = B PACKAGE = B::RV PREFIX = Sv |
1737 | ||
8ae5a962 | 1738 | void |
a8a597b2 MB |
1739 | SvRV(sv) |
1740 | B::RV sv | |
8ae5a962 | 1741 | PPCODE: |
0c74f67f | 1742 | PUSHs(make_sv_object(aTHX_ SvRV(sv))); |
a8a597b2 | 1743 | |
89c6bc13 NC |
1744 | #else |
1745 | ||
1746 | MODULE = B PACKAGE = B::REGEXP | |
1747 | ||
154b8842 | 1748 | void |
81e413dd | 1749 | REGEX(sv) |
89c6bc13 | 1750 | B::REGEXP sv |
81e413dd NC |
1751 | ALIAS: |
1752 | precomp = 1 | |
6190dd99 | 1753 | qr_anoncv = 2 |
1f306347 | 1754 | compflags = 3 |
154b8842 | 1755 | PPCODE: |
6190dd99 | 1756 | if (ix == 1) { |
81e413dd | 1757 | PUSHs(newSVpvn_flags(RX_PRECOMP(sv), RX_PRELEN(sv), SVs_TEMP)); |
1f306347 | 1758 | } else if (ix == 2) { |
6190dd99 | 1759 | PUSHs(make_sv_object(aTHX_ (SV *)ReANY(sv)->qr_anoncv)); |
81e413dd NC |
1760 | } else { |
1761 | dXSTARG; | |
17d6506d DD |
1762 | if (ix) |
1763 | PUSHu(RX_COMPFLAGS(sv)); | |
1764 | else | |
81e413dd | 1765 | /* FIXME - can we code this method more efficiently? */ |
17d6506d | 1766 | PUSHi(PTR2IV(sv)); |
81e413dd | 1767 | } |
89c6bc13 | 1768 | |
4df7f6af NC |
1769 | #endif |
1770 | ||
fdbacc68 | 1771 | MODULE = B PACKAGE = B::PV |
a8a597b2 | 1772 | |
8ae5a962 | 1773 | void |
fdbacc68 | 1774 | RV(sv) |
b326da91 | 1775 | B::PV sv |
8ae5a962 NC |
1776 | PPCODE: |
1777 | if (!SvROK(sv)) | |
b326da91 | 1778 | croak( "argument is not SvROK" ); |
0c74f67f | 1779 | PUSHs(make_sv_object(aTHX_ SvRV(sv))); |
b326da91 | 1780 | |
a8a597b2 | 1781 | void |
fdbacc68 | 1782 | PV(sv) |
a8a597b2 | 1783 | B::PV sv |
3d665704 NC |
1784 | ALIAS: |
1785 | PVX = 1 | |
f4c36584 | 1786 | PVBM = 2 |
84fea184 | 1787 | B::BM::TABLE = 3 |
a804b0fe NC |
1788 | PREINIT: |
1789 | const char *p; | |
1790 | STRLEN len = 0; | |
1791 | U32 utf8 = 0; | |
a8a597b2 | 1792 | CODE: |
84fea184 | 1793 | if (ix == 3) { |
2bda37ba NC |
1794 | #ifndef PERL_FBM_TABLE_OFFSET |
1795 | const MAGIC *const mg = mg_find(sv, PERL_MAGIC_bm); | |
1796 | ||
1797 | if (!mg) | |
1798 | croak("argument to B::BM::TABLE is not a PVBM"); | |
1799 | p = mg->mg_ptr; | |
1800 | len = mg->mg_len; | |
1801 | #else | |
84fea184 NC |
1802 | p = SvPV(sv, len); |
1803 | /* Boyer-Moore table is just after string and its safety-margin \0 */ | |
1804 | p += len + PERL_FBM_TABLE_OFFSET; | |
1805 | len = 256; | |
2bda37ba | 1806 | #endif |
84fea184 | 1807 | } else if (ix == 2) { |
f4c36584 | 1808 | /* This used to read 257. I think that that was buggy - should have |
26ec7981 NC |
1809 | been 258. (The "\0", the flags byte, and 256 for the table.) |
1810 | The only user of this method is B::Bytecode in B::PV::bsave. | |
1811 | I'm guessing that nothing tested the runtime correctness of | |
1812 | output of bytecompiled string constant arguments to index (etc). | |
1813 | ||
1814 | Note the start pointer is and has always been SvPVX(sv), not | |
1815 | SvPVX(sv) + SvCUR(sv) PVBM was added in 651aa52ea1faa806, and | |
1816 | first used by the compiler in 651aa52ea1faa806. It's used to | |
1817 | get a "complete" dump of the buffer at SvPVX(), not just the | |
1818 | PVBM table. This permits the generated bytecode to "load" | |
2bda37ba NC |
1819 | SvPVX in "one" hit. |
1820 | ||
1821 | 5.15 and later store the BM table via MAGIC, so the compiler | |
1822 | should handle this just fine without changes if PVBM now | |
1823 | always returns the SvPVX() buffer. */ | |
8d919b0a FC |
1824 | #ifdef isREGEXP |
1825 | p = isREGEXP(sv) | |
1826 | ? RX_WRAPPED_const((REGEXP*)sv) | |
1827 | : SvPVX_const(sv); | |
1828 | #else | |
f4c36584 | 1829 | p = SvPVX_const(sv); |
8d919b0a | 1830 | #endif |
2bda37ba | 1831 | #ifdef PERL_FBM_TABLE_OFFSET |
f4c36584 | 1832 | len = SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0); |
2bda37ba NC |
1833 | #else |
1834 | len = SvCUR(sv); | |
1835 | #endif | |
f4c36584 | 1836 | } else if (ix) { |
8d919b0a FC |
1837 | #ifdef isREGEXP |
1838 | p = isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX(sv); | |
1839 | #else | |
3d665704 | 1840 | p = SvPVX(sv); |
8d919b0a | 1841 | #endif |
3d665704 NC |
1842 | len = strlen(p); |
1843 | } else if (SvPOK(sv)) { | |
a804b0fe NC |
1844 | len = SvCUR(sv); |
1845 | p = SvPVX_const(sv); | |
1846 | utf8 = SvUTF8(sv); | |
b326da91 | 1847 | } |
8d919b0a FC |
1848 | #ifdef isREGEXP |
1849 | else if (isREGEXP(sv)) { | |
1850 | len = SvCUR(sv); | |
1851 | p = RX_WRAPPED_const((REGEXP*)sv); | |
1852 | utf8 = SvUTF8(sv); | |
1853 | } | |
1854 | #endif | |
b326da91 MB |
1855 | else { |
1856 | /* XXX for backward compatibility, but should fail */ | |
1857 | /* croak( "argument is not SvPOK" ); */ | |
a804b0fe | 1858 | p = NULL; |
b326da91 | 1859 | } |
a804b0fe | 1860 | ST(0) = newSVpvn_flags(p, len, SVs_TEMP | utf8); |
a8a597b2 | 1861 | |
fdbacc68 | 1862 | MODULE = B PACKAGE = B::PVMG |
a8a597b2 MB |
1863 | |
1864 | void | |
fdbacc68 | 1865 | MAGIC(sv) |
a8a597b2 MB |
1866 | B::PVMG sv |
1867 | MAGIC * mg = NO_INIT | |
1868 | PPCODE: | |
1869 | for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) | |
9496d2e5 | 1870 | XPUSHs(make_mg_object(aTHX_ mg)); |
a8a597b2 | 1871 | |
b2adfa9b | 1872 | MODULE = B PACKAGE = B::MAGIC |
a8a597b2 MB |
1873 | |
1874 | void | |
b2adfa9b | 1875 | MOREMAGIC(mg) |
a8a597b2 | 1876 | B::MAGIC mg |
b2adfa9b NC |
1877 | ALIAS: |
1878 | PRIVATE = 1 | |
1879 | TYPE = 2 | |
1880 | FLAGS = 3 | |
fb6620c6 | 1881 | LENGTH = 4 |
b2adfa9b NC |
1882 | OBJ = 5 |
1883 | PTR = 6 | |
1884 | REGEX = 7 | |
1885 | precomp = 8 | |
1886 | PPCODE: | |
1887 | switch (ix) { | |
1888 | case 0: | |
1889 | XPUSHs(mg->mg_moremagic ? make_mg_object(aTHX_ mg->mg_moremagic) | |
1890 | : &PL_sv_undef); | |
1891 | break; | |
1892 | case 1: | |
1893 | mPUSHu(mg->mg_private); | |
1894 | break; | |
1895 | case 2: | |
1896 | PUSHs(newSVpvn_flags(&(mg->mg_type), 1, SVs_TEMP)); | |
1897 | break; | |
1898 | case 3: | |
1899 | mPUSHu(mg->mg_flags); | |
1900 | break; | |
1901 | case 4: | |
1902 | mPUSHi(mg->mg_len); | |
1903 | break; | |
1904 | case 5: | |
0c74f67f | 1905 | PUSHs(make_sv_object(aTHX_ mg->mg_obj)); |
b2adfa9b NC |
1906 | break; |
1907 | case 6: | |
1908 | if (mg->mg_ptr) { | |
1909 | if (mg->mg_len >= 0) { | |
1910 | PUSHs(newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP)); | |
651aa52e | 1911 | } else if (mg->mg_len == HEf_SVKEY) { |
0c74f67f | 1912 | PUSHs(make_sv_object(aTHX_ (SV*)mg->mg_ptr)); |
fdbd1d64 | 1913 | } else |
b2adfa9b NC |
1914 | PUSHs(sv_newmortal()); |
1915 | } else | |
1916 | PUSHs(sv_newmortal()); | |
1917 | break; | |
1918 | case 7: | |
1919 | if(mg->mg_type == PERL_MAGIC_qr) { | |
1920 | mPUSHi(PTR2IV(mg->mg_obj)); | |
1921 | } else { | |
1922 | croak("REGEX is only meaningful on r-magic"); | |
1923 | } | |
1924 | break; | |
1925 | case 8: | |
1926 | if (mg->mg_type == PERL_MAGIC_qr) { | |
1927 | REGEXP *rx = (REGEXP *)mg->mg_obj; | |
227aaa42 NC |
1928 | PUSHs(newSVpvn_flags(rx ? RX_PRECOMP(rx) : NULL, |
1929 | rx ? RX_PRELEN(rx) : 0, SVs_TEMP)); | |
b2adfa9b NC |
1930 | } else { |
1931 | croak( "precomp is only meaningful on r-magic" ); | |
1932 | } | |
1933 | break; | |
1934 | } | |
a8a597b2 | 1935 | |
8922e438 FC |
1936 | MODULE = B PACKAGE = B::BM PREFIX = Bm |
1937 | ||
1938 | U32 | |
1939 | BmPREVIOUS(sv) | |
1940 | B::BM sv | |
99639b5b DM |
1941 | CODE: |
1942 | #if PERL_VERSION >= 19 | |
1943 | PERL_UNUSED_VAR(sv); | |
1944 | #endif | |
1945 | RETVAL = BmPREVIOUS(sv); | |
1946 | OUTPUT: | |
1947 | RETVAL | |
1948 | ||
8922e438 FC |
1949 | |
1950 | U8 | |
1951 | BmRARE(sv) | |
1952 | B::BM sv | |
99639b5b DM |
1953 | CODE: |
1954 | #if PERL_VERSION >= 19 | |
1955 | PERL_UNUSED_VAR(sv); | |
1956 | #endif | |
1957 | RETVAL = BmRARE(sv); | |
1958 | OUTPUT: | |
1959 | RETVAL | |
1960 | ||
8922e438 | 1961 | |
a8a597b2 MB |
1962 | MODULE = B PACKAGE = B::GV PREFIX = Gv |
1963 | ||
1964 | void | |
1965 | GvNAME(gv) | |
1966 | B::GV gv | |
cbf9c13f NC |
1967 | ALIAS: |
1968 | FILE = 1 | |
435e8dd0 | 1969 | B::HV::NAME = 2 |
a8a597b2 | 1970 | CODE: |
435e8dd0 NC |
1971 | ST(0) = sv_2mortal(newSVhek(!ix ? GvNAME_HEK(gv) |
1972 | : (ix == 1 ? GvFILE_HEK(gv) | |
1973 | : HvNAME_HEK((HV *)gv)))); | |
a8a597b2 | 1974 | |
87d7fd28 GS |
1975 | bool |
1976 | is_empty(gv) | |
1977 | B::GV gv | |
711fbbf0 NC |
1978 | ALIAS: |
1979 | isGV_with_GP = 1 | |
87d7fd28 | 1980 | CODE: |
711fbbf0 | 1981 | if (ix) { |
711fbbf0 | 1982 | RETVAL = isGV_with_GP(gv) ? TRUE : FALSE; |
711fbbf0 NC |
1983 | } else { |
1984 | RETVAL = GvGP(gv) == Null(GP*); | |
1985 | } | |
50786ba8 | 1986 | OUTPUT: |
711fbbf0 | 1987 | RETVAL |
50786ba8 | 1988 | |
651aa52e AE |
1989 | void* |
1990 | GvGP(gv) | |
1991 | B::GV gv | |
1992 | ||
3800c318 JH |
1993 | #define GP_sv_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_sv) |
1994 | #define GP_io_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_io) | |
1995 | #define GP_cv_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_cv) | |
1996 | #define GP_cvgen_ix (U32p << 16) | STRUCT_OFFSET(struct gp, gp_cvgen) | |
1997 | #define GP_refcnt_ix (U32p << 16) | STRUCT_OFFSET(struct gp, gp_refcnt) | |
1998 | #define GP_hv_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_hv) | |
1999 | #define GP_av_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_av) | |
2000 | #define GP_form_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_form) | |
2001 | #define GP_egv_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_egv) | |
a8a597b2 | 2002 | |
257e0650 NC |
2003 | void |
2004 | SV(gv) | |
a8a597b2 | 2005 | B::GV gv |
257e0650 NC |
2006 | ALIAS: |
2007 | SV = GP_sv_ix | |
2008 | IO = GP_io_ix | |
2009 | CV = GP_cv_ix | |
2010 | CVGEN = GP_cvgen_ix | |
2011 | GvREFCNT = GP_refcnt_ix | |
2012 | HV = GP_hv_ix | |
2013 | AV = GP_av_ix | |
2014 | FORM = GP_form_ix | |
2015 | EGV = GP_egv_ix | |
257e0650 NC |
2016 | PREINIT: |
2017 | GP *gp; | |
2018 | char *ptr; | |
2019 | SV *ret; | |
2020 | PPCODE: | |
2021 | gp = GvGP(gv); | |
2022 | if (!gp) { | |
2023 | const GV *const gv = CvGV(cv); | |
46c3f339 | 2024 | Perl_croak(aTHX_ "NULL gp in B::GV::%s", gv ? GvNAME(gv) : "???"); |
257e0650 NC |
2025 | } |
2026 | ptr = (ix & 0xFFFF) + (char *)gp; | |
2027 | switch ((U8)(ix >> 16)) { | |
7d6d3fb7 | 2028 | case SVp: |
0c74f67f | 2029 | ret = make_sv_object(aTHX_ *((SV **)ptr)); |
257e0650 | 2030 | break; |
7d6d3fb7 | 2031 | case U32p: |
257e0650 NC |
2032 | ret = sv_2mortal(newSVuv(*((U32*)ptr))); |
2033 | break; | |
c33e8be1 Z |
2034 | default: |
2035 | croak("Illegal alias 0x%08x for B::*SV", (unsigned)ix); | |
257e0650 NC |
2036 | } |
2037 | ST(0) = ret; | |
2038 | XSRETURN(1); | |
a8a597b2 | 2039 | |
39ff6c37 FC |
2040 | U32 |
2041 | GvLINE(gv) | |
2042 | B::GV gv | |
2043 | ||
bb1efdce FC |
2044 | U32 |
2045 | GvGPFLAGS(gv) | |
2046 | B::GV gv | |
2047 | ||
8ae5a962 NC |
2048 | void |
2049 | FILEGV(gv) | |
a8a597b2 | 2050 | B::GV gv |
8ae5a962 | 2051 | PPCODE: |
0c74f67f | 2052 | PUSHs(make_sv_object(aTHX_ (SV *)GvFILEGV(gv))); |
a8a597b2 | 2053 | |
a8a597b2 MB |
2054 | MODULE = B PACKAGE = B::IO PREFIX = Io |
2055 | ||
04071355 | 2056 | |
b326da91 MB |
2057 | bool |
2058 | IsSTD(io,name) | |
2059 | B::IO io | |
5d7488b2 | 2060 | const char* name |
b326da91 MB |
2061 | PREINIT: |
2062 | PerlIO* handle = 0; | |
2063 | CODE: | |
2064 | if( strEQ( name, "stdin" ) ) { | |
2065 | handle = PerlIO_stdin(); | |
2066 | } | |
2067 | else if( strEQ( name, "stdout" ) ) { | |
2068 | handle = PerlIO_stdout(); | |
2069 | } | |
2070 | else if( strEQ( name, "stderr" ) ) { | |
2071 | handle = PerlIO_stderr(); | |
2072 | } | |
2073 | else { | |
2074 | croak( "Invalid value '%s'", name ); | |
2075 | } | |
2076 | RETVAL = handle == IoIFP(io); | |
2077 | OUTPUT: | |
2078 | RETVAL | |
2079 | ||
a8a597b2 MB |
2080 | MODULE = B PACKAGE = B::AV PREFIX = Av |
2081 | ||
2082 | SSize_t | |
2083 | AvFILL(av) | |
2084 | B::AV av | |
2085 | ||
a8a597b2 MB |
2086 | void |
2087 | AvARRAY(av) | |
2088 | B::AV av | |
2089 | PPCODE: | |
2090 | if (AvFILL(av) >= 0) { | |
2091 | SV **svp = AvARRAY(av); | |
2092 | I32 i; | |
2093 | for (i = 0; i <= AvFILL(av); i++) | |
0c74f67f | 2094 | XPUSHs(make_sv_object(aTHX_ svp[i])); |
a8a597b2 MB |
2095 | } |
2096 | ||
429a5ce7 SM |
2097 | void |
2098 | AvARRAYelt(av, idx) | |
2099 | B::AV av | |
2100 | int idx | |
2101 | PPCODE: | |
2102 | if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av)) | |
0c74f67f | 2103 | XPUSHs(make_sv_object(aTHX_ (AvARRAY(av)[idx]))); |
429a5ce7 | 2104 | else |
0c74f67f | 2105 | XPUSHs(make_sv_object(aTHX_ NULL)); |
429a5ce7 | 2106 | |
edcc7c74 | 2107 | |
f2da823f FC |
2108 | MODULE = B PACKAGE = B::FM PREFIX = Fm |
2109 | ||
f2da823f | 2110 | IV |
99639b5b DM |
2111 | FmLINES(format) |
2112 | B::FM format | |
2113 | CODE: | |
2114 | PERL_UNUSED_VAR(format); | |
2115 | RETVAL = 0; | |
2116 | OUTPUT: | |
2117 | RETVAL | |
2118 | ||
f2da823f | 2119 | |
a8a597b2 MB |
2120 | MODULE = B PACKAGE = B::CV PREFIX = Cv |
2121 | ||
651aa52e AE |
2122 | U32 |
2123 | CvCONST(cv) | |
2124 | B::CV cv | |
2125 | ||
6079961f | 2126 | void |
a8a597b2 MB |
2127 | CvSTART(cv) |
2128 | B::CV cv | |
a0da4400 NC |
2129 | ALIAS: |
2130 | ROOT = 1 | |
6079961f NC |
2131 | PPCODE: |
2132 | PUSHs(make_op_object(aTHX_ CvISXSUB(cv) ? NULL | |
2133 | : ix ? CvROOT(cv) : CvSTART(cv))); | |
a8a597b2 | 2134 | |
bb02a38f FC |
2135 | I32 |
2136 | CvDEPTH(cv) | |
2137 | B::CV cv | |
2138 | ||
86d2498c | 2139 | #ifdef PadlistARRAY |
7261499d FC |
2140 | |
2141 | B::PADLIST | |
2142 | CvPADLIST(cv) | |
2143 | B::CV cv | |
eacbb379 DD |
2144 | CODE: |
2145 | RETVAL = CvISXSUB(cv) ? NULL : CvPADLIST(cv); | |
2146 | OUTPUT: | |
2147 | RETVAL | |
7261499d FC |
2148 | |
2149 | #else | |
2150 | ||
2151 | B::AV | |
2152 | CvPADLIST(cv) | |
2153 | B::CV cv | |
82aeefe1 DM |
2154 | PPCODE: |
2155 | PUSHs(make_sv_object(aTHX_ (SV *)CvPADLIST(cv))); | |
2156 | ||
7261499d FC |
2157 | |
2158 | #endif | |
2159 | ||
eacbb379 | 2160 | SV * |
db6e00bd | 2161 | CvHSCXT(cv) |
eacbb379 DD |
2162 | B::CV cv |
2163 | CODE: | |
db6e00bd | 2164 | RETVAL = newSVuv(CvISXSUB(cv) ? PTR2UV(CvHSCXT(cv)) : 0); |
eacbb379 DD |
2165 | OUTPUT: |
2166 | RETVAL | |
2167 | ||
a8a597b2 MB |
2168 | void |
2169 | CvXSUB(cv) | |
2170 | B::CV cv | |
96819e59 NC |
2171 | ALIAS: |
2172 | XSUBANY = 1 | |
a8a597b2 | 2173 | CODE: |
96819e59 | 2174 | ST(0) = ix && CvCONST(cv) |
0c74f67f | 2175 | ? make_sv_object(aTHX_ (SV *)CvXSUBANY(cv).any_ptr) |
96819e59 NC |
2176 | : sv_2mortal(newSViv(CvISXSUB(cv) |
2177 | ? (ix ? CvXSUBANY(cv).any_iv | |
2178 | : PTR2IV(CvXSUB(cv))) | |
2179 | : 0)); | |
a8a597b2 | 2180 | |
8ae5a962 NC |
2181 | void |
2182 | const_sv(cv) | |
de3f1649 | 2183 | B::CV cv |
8ae5a962 | 2184 | PPCODE: |
0c74f67f | 2185 | PUSHs(make_sv_object(aTHX_ (SV *)cv_const_sv(cv))); |
de3f1649 | 2186 | |
486b1e7f TC |
2187 | void |
2188 | GV(cv) | |
2189 | B::CV cv | |
486b1e7f | 2190 | CODE: |
f244b085 | 2191 | ST(0) = make_sv_object(aTHX_ (SV*)CvGV(cv)); |
486b1e7f TC |
2192 | |
2193 | #if PERL_VERSION > 17 | |
2194 | ||
2195 | SV * | |
2196 | NAME_HEK(cv) | |
2197 | B::CV cv | |
2198 | CODE: | |
2199 | RETVAL = CvNAMED(cv) ? newSVhek(CvNAME_HEK(cv)) : &PL_sv_undef; | |
2200 | OUTPUT: | |
2201 | RETVAL | |
2202 | ||
2203 | #endif | |
2204 | ||
a8a597b2 MB |
2205 | MODULE = B PACKAGE = B::HV PREFIX = Hv |
2206 | ||
2207 | STRLEN | |
2208 | HvFILL(hv) | |
2209 | B::HV hv | |
2210 | ||
a8a597b2 MB |
2211 | I32 |
2212 | HvRITER(hv) | |
2213 | B::HV hv | |
2214 | ||
a8a597b2 MB |
2215 | void |
2216 | HvARRAY(hv) | |
2217 | B::HV hv | |
2218 | PPCODE: | |
1b95d04f | 2219 | if (HvUSEDKEYS(hv) > 0) { |
fa0789a7 | 2220 | HE *he; |
a8a597b2 | 2221 | (void)hv_iterinit(hv); |
1b95d04f | 2222 | EXTEND(sp, HvUSEDKEYS(hv) * 2); |
fa0789a7 RU |
2223 | while ((he = hv_iternext(hv))) { |
2224 | if (HeSVKEY(he)) { | |
2225 | mPUSHs(HeSVKEY(he)); | |
2226 | } else if (HeKUTF8(he)) { | |
2227 | PUSHs(newSVpvn_flags(HeKEY(he), HeKLEN(he), SVf_UTF8|SVs_TEMP)); | |
2228 | } else { | |
2229 | mPUSHp(HeKEY(he), HeKLEN(he)); | |
2230 | } | |
2231 | PUSHs(make_sv_object(aTHX_ HeVAL(he))); | |
a8a597b2 MB |
2232 | } |
2233 | } | |
fd9f6265 JJ |
2234 | |
2235 | MODULE = B PACKAGE = B::HE PREFIX = He | |
2236 | ||
8ae5a962 | 2237 | void |
fd9f6265 JJ |
2238 | HeVAL(he) |
2239 | B::HE he | |
b2619626 NC |
2240 | ALIAS: |
2241 | SVKEY_force = 1 | |
8ae5a962 | 2242 | PPCODE: |
0c74f67f | 2243 | PUSHs(make_sv_object(aTHX_ ix ? HeSVKEY_force(he) : HeVAL(he))); |
fd9f6265 JJ |
2244 | |
2245 | U32 | |
2246 | HeHASH(he) | |
2247 | B::HE he | |
2248 | ||
fdbacc68 | 2249 | MODULE = B PACKAGE = B::RHE |
fd9f6265 JJ |
2250 | |
2251 | SV* | |
fdbacc68 | 2252 | HASH(h) |
fd9f6265 JJ |
2253 | B::RHE h |
2254 | CODE: | |
20439bc7 | 2255 | RETVAL = newRV( (SV*)cophh_2hv(h, 0) ); |
fd9f6265 JJ |
2256 | OUTPUT: |
2257 | RETVAL | |
e412117e | 2258 | |
7261499d | 2259 | |
86d2498c | 2260 | #ifdef PadlistARRAY |
7261499d | 2261 | |
86d2498c | 2262 | MODULE = B PACKAGE = B::PADLIST PREFIX = Padlist |
7261499d FC |
2263 | |
2264 | SSize_t | |
86d2498c | 2265 | PadlistMAX(padlist) |
7261499d | 2266 | B::PADLIST padlist |
9b7476d7 FC |
2267 | ALIAS: B::PADNAMELIST::MAX = 0 |
2268 | CODE: | |
2269 | PERL_UNUSED_VAR(ix); | |
2270 | RETVAL = PadlistMAX(padlist); | |
2271 | OUTPUT: | |
2272 | RETVAL | |
2273 | ||
2274 | B::PADNAMELIST | |
2275 | PadlistNAMES(padlist) | |
2276 | B::PADLIST padlist | |
7261499d FC |
2277 | |
2278 | void | |
86d2498c | 2279 | PadlistARRAY(padlist) |
7261499d FC |
2280 | B::PADLIST padlist |
2281 | PPCODE: | |
86d2498c | 2282 | if (PadlistMAX(padlist) >= 0) { |
9b7476d7 | 2283 | dXSTARG; |
86d2498c | 2284 | PAD **padp = PadlistARRAY(padlist); |
99639b5b | 2285 | SSize_t i; |
9b7476d7 FC |
2286 | sv_setiv(newSVrv(TARG, PadlistNAMES(padlist) |
2287 | ? "B::PADNAMELIST" | |
2288 | : "B::NULL"), | |
2289 | PTR2IV(PadlistNAMES(padlist))); | |
2290 | XPUSHTARG; | |
2291 | for (i = 1; i <= PadlistMAX(padlist); i++) | |
7261499d FC |
2292 | XPUSHs(make_sv_object(aTHX_ (SV *)padp[i])); |
2293 | } | |
2294 | ||
2295 | void | |
86d2498c | 2296 | PadlistARRAYelt(padlist, idx) |
7261499d | 2297 | B::PADLIST padlist |
99639b5b | 2298 | SSize_t idx |
7261499d | 2299 | PPCODE: |
9b7476d7 FC |
2300 | if (idx < 0 || idx > PadlistMAX(padlist)) |
2301 | XPUSHs(make_sv_object(aTHX_ NULL)); | |
2302 | else if (!idx) { | |
2303 | PL_stack_sp--; | |
2304 | PUSHMARK(PL_stack_sp-1); | |
2305 | XS_B__PADLIST_NAMES(aTHX_ cv); | |
2306 | return; | |
2307 | } | |
2308 | else | |
7261499d | 2309 | XPUSHs(make_sv_object(aTHX_ |
86d2498c | 2310 | (SV *)PadlistARRAY(padlist)[idx])); |
7261499d FC |
2311 | |
2312 | U32 | |
86d2498c | 2313 | PadlistREFCNT(padlist) |
7261499d FC |
2314 | B::PADLIST padlist |
2315 | CODE: | |
99639b5b | 2316 | PERL_UNUSED_VAR(padlist); |
86d2498c | 2317 | RETVAL = PadlistREFCNT(padlist); |
7261499d FC |
2318 | OUTPUT: |
2319 | RETVAL | |
2320 | ||
2321 | #endif | |
9b7476d7 FC |
2322 | |
2323 | MODULE = B PACKAGE = B::PADNAMELIST PREFIX = Padnamelist | |
2324 | ||
2325 | void | |
2326 | PadnamelistARRAY(pnl) | |
2327 | B::PADNAMELIST pnl | |
2328 | PPCODE: | |
2329 | if (PadnamelistMAX(pnl) >= 0) { | |
2330 | PADNAME **padp = PadnamelistARRAY(pnl); | |
2331 | SSize_t i = 0; | |
2332 | for (; i <= PadnamelistMAX(pnl); i++) | |
0f94cb1f FC |
2333 | { |
2334 | SV *rv = sv_newmortal(); | |
2335 | sv_setiv(newSVrv(rv,padp[i] ? "B::PADNAME" : "B::SPECIAL"), | |
2336 | PTR2IV(padp[i])); | |
2337 | XPUSHs(rv); | |
2338 | } | |
9b7476d7 FC |
2339 | } |
2340 | ||
0f94cb1f | 2341 | B::PADNAME |
9b7476d7 FC |
2342 | PadnamelistARRAYelt(pnl, idx) |
2343 | B::PADNAMELIST pnl | |
2344 | SSize_t idx | |
0f94cb1f | 2345 | CODE: |
9b7476d7 | 2346 | if (idx < 0 || idx > PadnamelistMAX(pnl)) |
0f94cb1f | 2347 | RETVAL = NULL; |
9b7476d7 | 2348 | else |
0f94cb1f FC |
2349 | RETVAL = PadnamelistARRAY(pnl)[idx]; |
2350 | OUTPUT: | |
2351 | RETVAL | |
9b7476d7 | 2352 | |
0f94cb1f FC |
2353 | MODULE = B PACKAGE = B::PADNAME PREFIX = Padname |
2354 | ||
2355 | #define PN_type_ix \ | |
2356 | sv_SVp | STRUCT_OFFSET(struct padname,xpadn_type_u.xpadn_typestash) | |
2357 | #define PN_ourstash_ix \ | |
2358 | sv_SVp | STRUCT_OFFSET(struct padname,xpadn_ourstash) | |
2359 | #define PN_len_ix \ | |
2360 | sv_U8p | STRUCT_OFFSET(struct padname,xpadn_len) | |
2361 | #define PN_refcnt_ix \ | |
2362 | sv_U32p | STRUCT_OFFSET(struct padname, xpadn_refcnt) | |
2363 | #define PN_cop_seq_range_low_ix \ | |
2364 | sv_U32p | STRUCT_OFFSET(struct padname, xpadn_low) | |
2365 | #define PN_cop_seq_range_high_ix \ | |
2366 | sv_U32p | STRUCT_OFFSET(struct padname, xpadn_high) | |
d8fed09d FC |
2367 | #define PNL_refcnt_ix \ |
2368 | sv_U32p | STRUCT_OFFSET(struct padnamelist, xpadnl_refcnt) | |
58480c3b FC |
2369 | #define PL_id_ix \ |
2370 | sv_U32p | STRUCT_OFFSET(struct padlist, xpadl_id) | |
2371 | #define PL_outid_ix \ | |
2372 | sv_U32p | STRUCT_OFFSET(struct padlist, xpadl_outid) | |
2373 | ||
0f94cb1f FC |
2374 | |
2375 | void | |
2376 | PadnameTYPE(pn) | |
2377 | B::PADNAME pn | |
2378 | ALIAS: | |
2379 | B::PADNAME::TYPE = PN_type_ix | |
2380 | B::PADNAME::OURSTASH = PN_ourstash_ix | |
2381 | B::PADNAME::LEN = PN_len_ix | |
2382 | B::PADNAME::REFCNT = PN_refcnt_ix | |
2383 | B::PADNAME::COP_SEQ_RANGE_LOW = PN_cop_seq_range_low_ix | |
2384 | B::PADNAME::COP_SEQ_RANGE_HIGH = PN_cop_seq_range_high_ix | |
d8fed09d | 2385 | B::PADNAMELIST::REFCNT = PNL_refcnt_ix |
58480c3b FC |
2386 | B::PADLIST::id = PL_id_ix |
2387 | B::PADLIST::outid = PL_outid_ix | |
0f94cb1f FC |
2388 | PREINIT: |
2389 | char *ptr; | |
2390 | SV *ret; | |
2391 | PPCODE: | |
2392 | ptr = (ix & 0xFFFF) + (char *)pn; | |
2393 | switch ((U8)(ix >> 16)) { | |
2394 | case (U8)(sv_SVp >> 16): | |
2395 | ret = make_sv_object(aTHX_ *((SV **)ptr)); | |
2396 | break; | |
2397 | case (U8)(sv_U32p >> 16): | |
2398 | ret = sv_2mortal(newSVuv(*((U32 *)ptr))); | |
2399 | break; | |
2400 | case (U8)(sv_U8p >> 16): | |
2401 | ret = sv_2mortal(newSVuv(*((U8 *)ptr))); | |
2402 | break; | |
2403 | default: | |
2404 | NOT_REACHED; | |
2405 | } | |
2406 | ST(0) = ret; | |
2407 | XSRETURN(1); | |
2408 | ||
2409 | SV * | |
2410 | PadnamePV(pn) | |
2411 | B::PADNAME pn | |
2412 | PREINIT: | |
2413 | dXSTARG; | |
2414 | PPCODE: | |
2415 | PERL_UNUSED_ARG(RETVAL); | |
2416 | sv_setpvn(TARG, PadnamePV(pn), PadnameLEN(pn)); | |
2417 | SvUTF8_on(TARG); | |
2418 | XPUSHTARG; | |
2419 | ||
2420 | BOOT: | |
2421 | { | |
2422 | /* Uses less memory than an ALIAS. */ | |
2423 | GV *gv = gv_fetchpvs("B::PADNAME::TYPE", 1, SVt_PVGV); | |
2424 | sv_setsv((SV *)gv_fetchpvs("B::PADNAME::SvSTASH",1,SVt_PVGV),(SV *)gv); | |
2425 | sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PROTOCV",1,SVt_PVGV),(SV *)gv); | |
2426 | sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PVX",1,SVt_PVGV), | |
2427 | (SV *)gv_fetchpvs("B::PADNAME::PV" ,1,SVt_PVGV)); | |
43a4fb14 FC |
2428 | sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PARENT_PAD_INDEX" ,1,SVt_PVGV), |
2429 | (SV *)gv_fetchpvs("B::PADNAME::COP_SEQ_RANGE_LOW",1, | |
2430 | SVt_PVGV)); | |
2431 | sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PARENT_FAKELEX_FLAGS",1, | |
2432 | SVt_PVGV), | |
2433 | (SV *)gv_fetchpvs("B::PADNAME::COP_SEQ_RANGE_HIGH" ,1, | |
2434 | SVt_PVGV)); | |
0f94cb1f FC |
2435 | } |
2436 | ||
2437 | U32 | |
2438 | PadnameFLAGS(pn) | |
2439 | B::PADNAME pn | |
2440 | CODE: | |
2441 | RETVAL = PadnameFLAGS(pn); | |
2442 | /* backward-compatibility hack, which should be removed if the | |
2443 | flags field becomes large enough to hold SVf_FAKE (and | |
2444 | PADNAMEt_OUTER should be renumbered to match SVf_FAKE) */ | |
d28cce60 | 2445 | STATIC_ASSERT_STMT(SVf_FAKE >= 1<<(sizeof(PadnameFLAGS((B__PADNAME)NULL)) * 8)); |
0f94cb1f FC |
2446 | if (PadnameOUTER(pn)) |
2447 | RETVAL |= SVf_FAKE; | |
2448 | OUTPUT: | |
2449 | RETVAL |