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