This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
B::Concise was failing to traverse some children of PMOPs
[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",
cecf5685
NC
24#if PERL_VERSION >= 9
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
MB
32 "B::PV",
33 "B::PVIV",
34 "B::PVNV",
35 "B::PVMG",
cecf5685 36#if PERL_VERSION <= 8
a8a597b2 37 "B::BM",
cecf5685 38#endif
4df7f6af 39#if PERL_VERSION >= 11
5c35adbb 40 "B::REGEXP",
4df7f6af 41#endif
7252851f 42#if PERL_VERSION >= 9
4ce457a6 43 "B::GV",
7252851f 44#endif
a8a597b2
MB
45 "B::PVLV",
46 "B::AV",
47 "B::HV",
48 "B::CV",
7252851f
NC
49#if PERL_VERSION <= 8
50 "B::GV",
51#endif
a8a597b2
MB
52 "B::FM",
53 "B::IO",
54};
55
56typedef enum {
57 OPc_NULL, /* 0 */
58 OPc_BASEOP, /* 1 */
59 OPc_UNOP, /* 2 */
60 OPc_BINOP, /* 3 */
61 OPc_LOGOP, /* 4 */
1a67a97c
SM
62 OPc_LISTOP, /* 5 */
63 OPc_PMOP, /* 6 */
64 OPc_SVOP, /* 7 */
7934575e 65 OPc_PADOP, /* 8 */
1a67a97c 66 OPc_PVOP, /* 9 */
651aa52e
AE
67 OPc_LOOP, /* 10 */
68 OPc_COP /* 11 */
a8a597b2
MB
69} opclass;
70
27da23d5 71static const char* const opclassnames[] = {
a8a597b2
MB
72 "B::NULL",
73 "B::OP",
74 "B::UNOP",
75 "B::BINOP",
76 "B::LOGOP",
a8a597b2
MB
77 "B::LISTOP",
78 "B::PMOP",
79 "B::SVOP",
7934575e 80 "B::PADOP",
a8a597b2 81 "B::PVOP",
a8a597b2
MB
82 "B::LOOP",
83 "B::COP"
84};
85
27da23d5 86static 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),
98 sizeof(COP)
99};
100
df3728a2 101#define MY_CXT_KEY "B::_guts" XS_VERSION
a8a597b2 102
89ca4ac7
JH
103typedef struct {
104 int x_walkoptree_debug; /* Flag for walkoptree debug hook */
b326da91 105 SV * x_specialsv_list[7];
89ca4ac7
JH
106} my_cxt_t;
107
108START_MY_CXT
109
110#define walkoptree_debug (MY_CXT.x_walkoptree_debug)
111#define specialsv_list (MY_CXT.x_specialsv_list)
e8edd1e6 112
a8a597b2 113static opclass
5d7488b2 114cc_opclass(pTHX_ const OP *o)
a8a597b2
MB
115{
116 if (!o)
117 return OPc_NULL;
118
119 if (o->op_type == 0)
120 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
121
122 if (o->op_type == OP_SASSIGN)
123 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
124
c60fdceb
SM
125 if (o->op_type == OP_AELEMFAST) {
126 if (o->op_flags & OPf_SPECIAL)
127 return OPc_BASEOP;
128 else
129#ifdef USE_ITHREADS
130 return OPc_PADOP;
131#else
132 return OPc_SVOP;
133#endif
134 }
135
18228111 136#ifdef USE_ITHREADS
31b49ad4 137 if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
c60fdceb 138 o->op_type == OP_RCATLINE)
18228111
GS
139 return OPc_PADOP;
140#endif
141
22c35a8c 142 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
a8a597b2
MB
143 case OA_BASEOP:
144 return OPc_BASEOP;
145
146 case OA_UNOP:
147 return OPc_UNOP;
148
149 case OA_BINOP:
150 return OPc_BINOP;
151
152 case OA_LOGOP:
153 return OPc_LOGOP;
154
a8a597b2
MB
155 case OA_LISTOP:
156 return OPc_LISTOP;
157
158 case OA_PMOP:
159 return OPc_PMOP;
160
161 case OA_SVOP:
162 return OPc_SVOP;
163
7934575e
GS
164 case OA_PADOP:
165 return OPc_PADOP;
a8a597b2 166
293d3ffa
SM
167 case OA_PVOP_OR_SVOP:
168 /*
169 * Character translations (tr///) are usually a PVOP, keeping a
170 * pointer to a table of shorts used to look up translations.
171 * Under utf8, however, a simple table isn't practical; instead,
512ba29b
FC
172 * the OP is an SVOP (or, under threads, a PADOP),
173 * and the SV is a reference to a swash
293d3ffa
SM
174 * (i.e., an RV pointing to an HV).
175 */
176 return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
512ba29b
FC
177#if defined(USE_ITHREADS) \
178 && (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION >= 9))
179 ? OPc_PADOP : OPc_PVOP;
180#else
293d3ffa 181 ? OPc_SVOP : OPc_PVOP;
512ba29b 182#endif
a8a597b2
MB
183
184 case OA_LOOP:
185 return OPc_LOOP;
186
187 case OA_COP:
188 return OPc_COP;
189
190 case OA_BASEOP_OR_UNOP:
191 /*
192 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
45f6cd40
SM
193 * whether parens were seen. perly.y uses OPf_SPECIAL to
194 * signal whether a BASEOP had empty parens or none.
195 * Some other UNOPs are created later, though, so the best
196 * test is OPf_KIDS, which is set in newUNOP.
a8a597b2 197 */
45f6cd40 198 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
a8a597b2
MB
199
200 case OA_FILESTATOP:
201 /*
202 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
203 * the OPf_REF flag to distinguish between OP types instead of the
204 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
205 * return OPc_UNOP so that walkoptree can find our children. If
206 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
207 * (no argument to the operator) it's an OP; with OPf_REF set it's
7934575e 208 * an SVOP (and op_sv is the GV for the filehandle argument).
a8a597b2
MB
209 */
210 return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
93865851
GS
211#ifdef USE_ITHREADS
212 (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
213#else
7934575e 214 (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
93865851 215#endif
a8a597b2
MB
216 case OA_LOOPEXOP:
217 /*
218 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
219 * label was omitted (in which case it's a BASEOP) or else a term was
220 * seen. In this last case, all except goto are definitely PVOP but
221 * goto is either a PVOP (with an ordinary constant label), an UNOP
222 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
223 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
224 * get set.
225 */
226 if (o->op_flags & OPf_STACKED)
227 return OPc_UNOP;
228 else if (o->op_flags & OPf_SPECIAL)
229 return OPc_BASEOP;
230 else
231 return OPc_PVOP;
232 }
233 warn("can't determine class of operator %s, assuming BASEOP\n",
22c35a8c 234 PL_op_name[o->op_type]);
a8a597b2
MB
235 return OPc_BASEOP;
236}
237
238static char *
5d7488b2 239cc_opclassname(pTHX_ const OP *o)
a8a597b2 240{
27da23d5 241 return (char *)opclassnames[cc_opclass(aTHX_ o)];
a8a597b2
MB
242}
243
9496d2e5
NC
244/* FIXME - figure out how to get the typemap to assign this to ST(0), rather
245 than creating a new mortal for ST(0) then passing it in as the first
246 argument. */
a8a597b2 247static SV *
cea2e8a9 248make_sv_object(pTHX_ SV *arg, SV *sv)
a8a597b2 249{
27da23d5 250 const char *type = 0;
a8a597b2 251 IV iv;
89ca4ac7 252 dMY_CXT;
9496d2e5
NC
253
254 if (!arg)
255 arg = sv_newmortal();
256
e8edd1e6
TH
257 for (iv = 0; iv < sizeof(specialsv_list)/sizeof(SV*); iv++) {
258 if (sv == specialsv_list[iv]) {
a8a597b2
MB
259 type = "B::SPECIAL";
260 break;
261 }
262 }
263 if (!type) {
264 type = svclassnames[SvTYPE(sv)];
56431972 265 iv = PTR2IV(sv);
a8a597b2
MB
266 }
267 sv_setiv(newSVrv(arg, type), iv);
268 return arg;
269}
270
e412117e 271#if PERL_VERSION >= 9
a8a597b2 272static SV *
9496d2e5 273make_temp_object(pTHX_ SV *temp)
8e01d9a6
NC
274{
275 SV *target;
9496d2e5 276 SV *arg = sv_newmortal();
8e01d9a6
NC
277 const char *const type = svclassnames[SvTYPE(temp)];
278 const IV iv = PTR2IV(temp);
279
280 target = newSVrv(arg, type);
281 sv_setiv(target, iv);
282
283 /* Need to keep our "temp" around as long as the target exists.
284 Simplest way seems to be to hang it from magic, and let that clear
285 it up. No vtable, so won't actually get in the way of anything. */
286 sv_magicext(target, temp, PERL_MAGIC_sv, NULL, NULL, 0);
287 /* magic object has had its reference count increased, so we must drop
288 our reference. */
289 SvREFCNT_dec(temp);
290 return arg;
291}
292
293static SV *
9496d2e5 294make_warnings_object(pTHX_ STRLEN *warnings)
5c3c3f81
NC
295{
296 const char *type = 0;
297 dMY_CXT;
298 IV iv = sizeof(specialsv_list)/sizeof(SV*);
299
300 /* Counting down is deliberate. Before the split between make_sv_object
301 and make_warnings_obj there appeared to be a bug - Nullsv and pWARN_STD
302 were both 0, so you could never get a B::SPECIAL for pWARN_STD */
303
304 while (iv--) {
305 if ((SV*)warnings == specialsv_list[iv]) {
306 type = "B::SPECIAL";
307 break;
308 }
309 }
310 if (type) {
9496d2e5 311 SV *arg = sv_newmortal();
5c3c3f81 312 sv_setiv(newSVrv(arg, type), iv);
8e01d9a6 313 return arg;
5c3c3f81
NC
314 } else {
315 /* B assumes that warnings are a regular SV. Seems easier to keep it
316 happy by making them into a regular SV. */
9496d2e5 317 return make_temp_object(aTHX_ newSVpvn((char *)(warnings + 1), *warnings));
8e01d9a6
NC
318 }
319}
320
321static SV *
9496d2e5 322make_cop_io_object(pTHX_ COP *cop)
8e01d9a6 323{
8b850bd5
NC
324 SV *const value = newSV(0);
325
33972ad6 326 Perl_emulate_cop_io(aTHX_ cop, value);
8b850bd5
NC
327
328 if(SvOK(value)) {
23098a26 329 return make_sv_object(aTHX_ NULL, value);
8e01d9a6 330 } else {
8b850bd5 331 SvREFCNT_dec(value);
9496d2e5 332 return make_sv_object(aTHX_ NULL, NULL);
5c3c3f81 333 }
5c3c3f81 334}
e412117e 335#endif
5c3c3f81
NC
336
337static SV *
9496d2e5 338make_mg_object(pTHX_ MAGIC *mg)
a8a597b2 339{
9496d2e5 340 SV *arg = sv_newmortal();
56431972 341 sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg));
a8a597b2
MB
342 return arg;
343}
344
345static SV *
52ad86de 346cstring(pTHX_ SV *sv, bool perlstyle)
a8a597b2 347{
09e97b95 348 SV *sstr;
a8a597b2
MB
349
350 if (!SvOK(sv))
09e97b95
NC
351 return newSVpvs_flags("0", SVs_TEMP);
352
353 sstr = newSVpvs_flags("\"", SVs_TEMP);
354
355 if (perlstyle && SvUTF8(sv)) {
d79a7a3d 356 SV *tmpsv = sv_newmortal(); /* Temporary SV to feed sv_uni_display */
5d7488b2
AL
357 const STRLEN len = SvCUR(sv);
358 const char *s = sv_uni_display(tmpsv, sv, 8*len, UNI_DISPLAY_QQ);
d79a7a3d
RGS
359 while (*s)
360 {
361 if (*s == '"')
6beb30a6 362 sv_catpvs(sstr, "\\\"");
d79a7a3d 363 else if (*s == '$')
6beb30a6 364 sv_catpvs(sstr, "\\$");
d79a7a3d 365 else if (*s == '@')
6beb30a6 366 sv_catpvs(sstr, "\\@");
d79a7a3d
RGS
367 else if (*s == '\\')
368 {
369 if (strchr("nrftax\\",*(s+1)))
370 sv_catpvn(sstr, s++, 2);
371 else
6beb30a6 372 sv_catpvs(sstr, "\\\\");
d79a7a3d
RGS
373 }
374 else /* should always be printable */
375 sv_catpvn(sstr, s, 1);
376 ++s;
377 }
d79a7a3d 378 }
a8a597b2
MB
379 else
380 {
381 /* XXX Optimise? */
5d7488b2
AL
382 STRLEN len;
383 const char *s = SvPV(sv, len);
a8a597b2
MB
384 for (; len; len--, s++)
385 {
386 /* At least try a little for readability */
387 if (*s == '"')
6beb30a6 388 sv_catpvs(sstr, "\\\"");
a8a597b2 389 else if (*s == '\\')
6beb30a6 390 sv_catpvs(sstr, "\\\\");
b326da91 391 /* trigraphs - bleagh */
5d7488b2 392 else if (!perlstyle && *s == '?' && len>=3 && s[1] == '?') {
47bf35fa 393 Perl_sv_catpvf(aTHX_ sstr, "\\%03o", '?');
b326da91 394 }
52ad86de 395 else if (perlstyle && *s == '$')
6beb30a6 396 sv_catpvs(sstr, "\\$");
52ad86de 397 else if (perlstyle && *s == '@')
6beb30a6 398 sv_catpvs(sstr, "\\@");
ce561ef2
JH
399#ifdef EBCDIC
400 else if (isPRINT(*s))
401#else
402 else if (*s >= ' ' && *s < 127)
403#endif /* EBCDIC */
a8a597b2
MB
404 sv_catpvn(sstr, s, 1);
405 else if (*s == '\n')
6beb30a6 406 sv_catpvs(sstr, "\\n");
a8a597b2 407 else if (*s == '\r')
6beb30a6 408 sv_catpvs(sstr, "\\r");
a8a597b2 409 else if (*s == '\t')
6beb30a6 410 sv_catpvs(sstr, "\\t");
a8a597b2 411 else if (*s == '\a')
6beb30a6 412 sv_catpvs(sstr, "\\a");
a8a597b2 413 else if (*s == '\b')
6beb30a6 414 sv_catpvs(sstr, "\\b");
a8a597b2 415 else if (*s == '\f')
6beb30a6 416 sv_catpvs(sstr, "\\f");
52ad86de 417 else if (!perlstyle && *s == '\v')
6beb30a6 418 sv_catpvs(sstr, "\\v");
a8a597b2
MB
419 else
420 {
a8a597b2 421 /* Don't want promotion of a signed -1 char in sprintf args */
5d7488b2 422 const unsigned char c = (unsigned char) *s;
47bf35fa 423 Perl_sv_catpvf(aTHX_ sstr, "\\%03o", c);
a8a597b2
MB
424 }
425 /* XXX Add line breaks if string is long */
426 }
a8a597b2 427 }
09e97b95 428 sv_catpvs(sstr, "\"");
a8a597b2
MB
429 return sstr;
430}
431
432static SV *
cea2e8a9 433cchar(pTHX_ SV *sv)
a8a597b2 434{
422d053b 435 SV *sstr = newSVpvs_flags("'", SVs_TEMP);
5d7488b2 436 const char *s = SvPV_nolen(sv);
422d053b
NC
437 /* Don't want promotion of a signed -1 char in sprintf args */
438 const unsigned char c = (unsigned char) *s;
a8a597b2 439
422d053b 440 if (c == '\'')
6beb30a6 441 sv_catpvs(sstr, "\\'");
422d053b 442 else if (c == '\\')
6beb30a6 443 sv_catpvs(sstr, "\\\\");
ce561ef2 444#ifdef EBCDIC
422d053b 445 else if (isPRINT(c))
ce561ef2 446#else
422d053b 447 else if (c >= ' ' && c < 127)
ce561ef2 448#endif /* EBCDIC */
a8a597b2 449 sv_catpvn(sstr, s, 1);
422d053b 450 else if (c == '\n')
6beb30a6 451 sv_catpvs(sstr, "\\n");
422d053b 452 else if (c == '\r')
6beb30a6 453 sv_catpvs(sstr, "\\r");
422d053b 454 else if (c == '\t')
6beb30a6 455 sv_catpvs(sstr, "\\t");
422d053b 456 else if (c == '\a')
6beb30a6 457 sv_catpvs(sstr, "\\a");
422d053b 458 else if (c == '\b')
6beb30a6 459 sv_catpvs(sstr, "\\b");
422d053b 460 else if (c == '\f')
6beb30a6 461 sv_catpvs(sstr, "\\f");
422d053b 462 else if (c == '\v')
6beb30a6 463 sv_catpvs(sstr, "\\v");
a8a597b2 464 else
422d053b 465 Perl_sv_catpvf(aTHX_ sstr, "\\%03o", c);
6beb30a6 466 sv_catpvs(sstr, "'");
a8a597b2
MB
467 return sstr;
468}
469
8f3d514b
JC
470#if PERL_VERSION >= 9
471# define PMOP_pmreplstart(o) o->op_pmstashstartu.op_pmreplstart
472# define PMOP_pmreplroot(o) o->op_pmreplrootu.op_pmreplroot
473#else
474# define PMOP_pmreplstart(o) o->op_pmreplstart
475# define PMOP_pmreplroot(o) o->op_pmreplroot
476# define PMOP_pmpermflags(o) o->op_pmpermflags
477# define PMOP_pmdynflags(o) o->op_pmdynflags
478#endif
479
5d7488b2
AL
480static void
481walkoptree(pTHX_ SV *opsv, const char *method)
a8a597b2
MB
482{
483 dSP;
f3be9b72 484 OP *o, *kid;
89ca4ac7
JH
485 dMY_CXT;
486
a8a597b2
MB
487 if (!SvROK(opsv))
488 croak("opsv is not a reference");
489 opsv = sv_mortalcopy(opsv);
56431972 490 o = INT2PTR(OP*,SvIV((SV*)SvRV(opsv)));
a8a597b2
MB
491 if (walkoptree_debug) {
492 PUSHMARK(sp);
493 XPUSHs(opsv);
494 PUTBACK;
495 perl_call_method("walkoptree_debug", G_DISCARD);
496 }
497 PUSHMARK(sp);
498 XPUSHs(opsv);
499 PUTBACK;
500 perl_call_method(method, G_DISCARD);
501 if (o && (o->op_flags & OPf_KIDS)) {
a8a597b2
MB
502 for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) {
503 /* Use the same opsv. Rely on methods not to mess it up. */
56431972 504 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
cea2e8a9 505 walkoptree(aTHX_ opsv, method);
a8a597b2
MB
506 }
507 }
5464c149 508 if (o && (cc_opclass(aTHX_ o) == OPc_PMOP) && o->op_type != OP_PUSHRE
8f3d514b 509 && (kid = PMOP_pmreplroot(cPMOPo)))
f3be9b72 510 {
5464c149 511 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
f3be9b72
RGS
512 walkoptree(aTHX_ opsv, method);
513 }
a8a597b2
MB
514}
515
5d7488b2 516static SV **
1df34986
AE
517oplist(pTHX_ OP *o, SV **SP)
518{
519 for(; o; o = o->op_next) {
520 SV *opsv;
7252851f
NC
521#if PERL_VERSION >= 9
522 if (o->op_opt == 0)
1df34986 523 break;
2814eb74 524 o->op_opt = 0;
7252851f
NC
525#else
526 if (o->op_seq == 0)
527 break;
528 o->op_seq = 0;
529#endif
1df34986
AE
530 opsv = sv_newmortal();
531 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ (OP*)o)), PTR2IV(o));
532 XPUSHs(opsv);
533 switch (o->op_type) {
534 case OP_SUBST:
8f3d514b 535 SP = oplist(aTHX_ PMOP_pmreplstart(cPMOPo), SP);
1df34986
AE
536 continue;
537 case OP_SORT:
f66c782a 538 if (o->op_flags & OPf_STACKED && o->op_flags & OPf_SPECIAL) {
1df34986
AE
539 OP *kid = cLISTOPo->op_first->op_sibling; /* pass pushmark */
540 kid = kUNOP->op_first; /* pass rv2gv */
541 kid = kUNOP->op_first; /* pass leave */
f66c782a 542 SP = oplist(aTHX_ kid->op_next, SP);
1df34986
AE
543 }
544 continue;
545 }
546 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
547 case OA_LOGOP:
548 SP = oplist(aTHX_ cLOGOPo->op_other, SP);
549 break;
550 case OA_LOOP:
551 SP = oplist(aTHX_ cLOOPo->op_lastop, SP);
552 SP = oplist(aTHX_ cLOOPo->op_nextop, SP);
553 SP = oplist(aTHX_ cLOOPo->op_redoop, SP);
554 break;
555 }
556 }
557 return SP;
558}
559
a8a597b2
MB
560typedef OP *B__OP;
561typedef UNOP *B__UNOP;
562typedef BINOP *B__BINOP;
563typedef LOGOP *B__LOGOP;
a8a597b2
MB
564typedef LISTOP *B__LISTOP;
565typedef PMOP *B__PMOP;
566typedef SVOP *B__SVOP;
7934575e 567typedef PADOP *B__PADOP;
a8a597b2
MB
568typedef PVOP *B__PVOP;
569typedef LOOP *B__LOOP;
570typedef COP *B__COP;
571
572typedef SV *B__SV;
573typedef SV *B__IV;
574typedef SV *B__PV;
575typedef SV *B__NV;
576typedef SV *B__PVMG;
5c35adbb
NC
577#if PERL_VERSION >= 11
578typedef SV *B__REGEXP;
579#endif
a8a597b2
MB
580typedef SV *B__PVLV;
581typedef SV *B__BM;
582typedef SV *B__RV;
1df34986 583typedef SV *B__FM;
a8a597b2
MB
584typedef AV *B__AV;
585typedef HV *B__HV;
586typedef CV *B__CV;
587typedef GV *B__GV;
588typedef IO *B__IO;
589
590typedef MAGIC *B__MAGIC;
fd9f6265 591typedef HE *B__HE;
e412117e 592#if PERL_VERSION >= 9
fd9f6265 593typedef struct refcounted_he *B__RHE;
e412117e 594#endif
a8a597b2 595
32855229
NC
596#ifdef USE_ITHREADS
597# define ASSIGN_COMMON_ALIAS(var) \
598 STMT_START { XSANY.any_i32 = offsetof(struct interpreter, var); } STMT_END
599#else
600# define ASSIGN_COMMON_ALIAS(var) \
601 STMT_START { XSANY.any_ptr = (void *)&PL_##var; } STMT_END
602#endif
603
604/* This needs to be ALIASed in a custom way, hence can't easily be defined as
605 a regular XSUB. */
606static XSPROTO(intrpvar_sv_common); /* prototype to pass -Wmissing-prototypes */
607static XSPROTO(intrpvar_sv_common)
608{
609 dVAR;
610 dXSARGS;
611 SV *ret;
612 if (items != 0)
613 croak_xs_usage(cv, "");
614#ifdef USE_ITHREADS
615 ret = *(SV **)(XSANY.any_i32 + (char *)my_perl);
616#else
617 ret = *(SV **)(XSANY.any_ptr);
618#endif
619 ST(0) = make_sv_object(aTHX_ NULL, ret);
620 XSRETURN(1);
621}
622
b1826b71
NC
623#include "const-c.inc"
624
7a2c16aa 625MODULE = B PACKAGE = B
a8a597b2 626
b1826b71
NC
627INCLUDE: const-xs.inc
628
a8a597b2
MB
629PROTOTYPES: DISABLE
630
631BOOT:
4c1f658f 632{
7a2c16aa
NC
633 CV *cv;
634 const char *file = __FILE__;
89ca4ac7 635 MY_CXT_INIT;
e8edd1e6
TH
636 specialsv_list[0] = Nullsv;
637 specialsv_list[1] = &PL_sv_undef;
638 specialsv_list[2] = &PL_sv_yes;
639 specialsv_list[3] = &PL_sv_no;
5c3c3f81
NC
640 specialsv_list[4] = (SV *) pWARN_ALL;
641 specialsv_list[5] = (SV *) pWARN_NONE;
642 specialsv_list[6] = (SV *) pWARN_STD;
32855229
NC
643
644 cv = newXS("B::init_av", intrpvar_sv_common, file);
645 ASSIGN_COMMON_ALIAS(Iinitav);
646 cv = newXS("B::check_av", intrpvar_sv_common, file);
647 ASSIGN_COMMON_ALIAS(Icheckav_save);
648#if PERL_VERSION >= 9
649 cv = newXS("B::unitcheck_av", intrpvar_sv_common, file);
650 ASSIGN_COMMON_ALIAS(Iunitcheckav_save);
651#endif
652 cv = newXS("B::begin_av", intrpvar_sv_common, file);
653 ASSIGN_COMMON_ALIAS(Ibeginav_save);
654 cv = newXS("B::end_av", intrpvar_sv_common, file);
655 ASSIGN_COMMON_ALIAS(Iendav);
656 cv = newXS("B::main_cv", intrpvar_sv_common, file);
657 ASSIGN_COMMON_ALIAS(Imain_cv);
658 cv = newXS("B::inc_gv", intrpvar_sv_common, file);
659 ASSIGN_COMMON_ALIAS(Iincgv);
660 cv = newXS("B::defstash", intrpvar_sv_common, file);
661 ASSIGN_COMMON_ALIAS(Idefstash);
662 cv = newXS("B::curstash", intrpvar_sv_common, file);
663 ASSIGN_COMMON_ALIAS(Icurstash);
664 cv = newXS("B::formfeed", intrpvar_sv_common, file);
665 ASSIGN_COMMON_ALIAS(Iformfeed);
666#ifdef USE_ITHREADS
667 cv = newXS("B::regex_padav", intrpvar_sv_common, file);
668 ASSIGN_COMMON_ALIAS(Iregex_padav);
669#endif
670 cv = newXS("B::warnhook", intrpvar_sv_common, file);
671 ASSIGN_COMMON_ALIAS(Iwarnhook);
672 cv = newXS("B::diehook", intrpvar_sv_common, file);
673 ASSIGN_COMMON_ALIAS(Idiehook);
674}
675
7a2c16aa
NC
676long
677amagic_generation()
678 CODE:
679 RETVAL = PL_amagic_generation;
680 OUTPUT:
681 RETVAL
682
683B::AV
684comppadlist()
685 CODE:
686 RETVAL = PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv);
687 OUTPUT:
688 RETVAL
689
a4aabc83
NC
690B::SV
691sv_undef()
692 ALIAS:
693 sv_no = 1
694 sv_yes = 2
695 CODE:
696 RETVAL = ix > 1 ? &PL_sv_yes : ix < 1 ? &PL_sv_undef : &PL_sv_no;
697 OUTPUT:
698 RETVAL
699
e97701b4
NC
700B::OP
701main_root()
702 ALIAS:
703 main_start = 1
704 CODE:
705 RETVAL = ix ? PL_main_start : PL_main_root;
706 OUTPUT:
707 RETVAL
708
2edf0c1d
NC
709UV
710sub_generation()
711 ALIAS:
712 dowarn = 1
713 CODE:
714 RETVAL = ix ? PL_dowarn : PL_sub_generation;
715 OUTPUT:
716 RETVAL
717
a8a597b2
MB
718void
719walkoptree(opsv, method)
720 SV * opsv
5d7488b2 721 const char * method
cea2e8a9
GS
722 CODE:
723 walkoptree(aTHX_ opsv, method);
a8a597b2
MB
724
725int
726walkoptree_debug(...)
727 CODE:
89ca4ac7 728 dMY_CXT;
a8a597b2
MB
729 RETVAL = walkoptree_debug;
730 if (items > 0 && SvTRUE(ST(1)))
731 walkoptree_debug = 1;
732 OUTPUT:
733 RETVAL
734
56431972 735#define address(sv) PTR2IV(sv)
a8a597b2
MB
736
737IV
738address(sv)
739 SV * sv
740
741B::SV
742svref_2object(sv)
743 SV * sv
744 CODE:
745 if (!SvROK(sv))
746 croak("argument is not a reference");
747 RETVAL = (SV*)SvRV(sv);
748 OUTPUT:
0cc1d052
NIS
749 RETVAL
750
751void
752opnumber(name)
5d7488b2 753const char * name
0cc1d052
NIS
754CODE:
755{
756 int i;
757 IV result = -1;
758 ST(0) = sv_newmortal();
759 if (strncmp(name,"pp_",3) == 0)
760 name += 3;
761 for (i = 0; i < PL_maxo; i++)
762 {
763 if (strcmp(name, PL_op_name[i]) == 0)
764 {
765 result = i;
766 break;
767 }
768 }
769 sv_setiv(ST(0),result);
770}
a8a597b2
MB
771
772void
773ppname(opnum)
774 int opnum
775 CODE:
776 ST(0) = sv_newmortal();
3280af22 777 if (opnum >= 0 && opnum < PL_maxo) {
6beb30a6 778 sv_setpvs(ST(0), "pp_");
22c35a8c 779 sv_catpv(ST(0), PL_op_name[opnum]);
a8a597b2
MB
780 }
781
782void
783hash(sv)
784 SV * sv
785 CODE:
a8a597b2
MB
786 STRLEN len;
787 U32 hash = 0;
8c5b7c71 788 const char *s = SvPVbyte(sv, len);
c32d3395 789 PERL_HASH(hash, s, len);
90b16320 790 ST(0) = sv_2mortal(Perl_newSVpvf(aTHX_ "0x%"UVxf, (UV)hash));
a8a597b2
MB
791
792#define cast_I32(foo) (I32)foo
793IV
794cast_I32(i)
795 IV i
796
797void
798minus_c()
651233d2
NC
799 ALIAS:
800 save_BEGINs = 1
a8a597b2 801 CODE:
651233d2
NC
802 if (ix)
803 PL_savebegin = TRUE;
804 else
805 PL_minus_c = TRUE;
059a8bb7 806
a8a597b2
MB
807SV *
808cstring(sv)
809 SV * sv
84556172
NC
810 ALIAS:
811 perlstring = 1
9e380ad4 812 cchar = 2
09e97b95 813 PPCODE:
9e380ad4 814 PUSHs(ix == 2 ? cchar(aTHX_ sv) : cstring(aTHX_ sv, ix));
a8a597b2
MB
815
816void
817threadsv_names()
818 PPCODE:
f5ba1307
NC
819#if PERL_VERSION <= 8
820# ifdef USE_5005THREADS
821 int i;
5d7488b2 822 const STRLEN len = strlen(PL_threadsv_names);
f5ba1307
NC
823
824 EXTEND(sp, len);
825 for (i = 0; i < len; i++)
d3d34884 826 PUSHs(newSVpvn_flags(&PL_threadsv_names[i], 1, SVs_TEMP));
f5ba1307
NC
827# endif
828#endif
a8a597b2 829
257e0650
NC
830#define SVp 0x00000
831#define U32p 0x10000
832#define line_tp 0x20000
833#define OPp 0x30000
834#define PADOFFSETp 0x40000
835#define U8p 0x50000
39e120c1 836#define IVp 0x60000
a9ed1a44 837#define char_pp 0x70000
086f9b42
NC
838
839#define OP_next_ix OPp | offsetof(struct op, op_next)
840#define OP_sibling_ix OPp | offsetof(struct op, op_sibling)
841#define UNOP_first_ix OPp | offsetof(struct unop, op_first)
842#define BINOP_last_ix OPp | offsetof(struct binop, op_last)
843#define LOGOP_other_ix OPp | offsetof(struct logop, op_other)
9b1961be 844#if PERL_VERSION >= 9
086f9b42
NC
845# define PMOP_pmreplstart_ix \
846 OPp | offsetof(struct pmop, op_pmstashstartu.op_pmreplstart)
9b1961be 847#else
086f9b42 848# define PMOP_pmreplstart_ix OPp | offsetof(struct pmop, op_pmreplstart)
9b1961be 849#endif
086f9b42
NC
850#define LOOP_redoop_ix OPp | offsetof(struct loop, op_redoop)
851#define LOOP_nextop_ix OPp | offsetof(struct loop, op_nextop)
852#define LOOP_lastop_ix OPp | offsetof(struct loop, op_lastop)
853
854#define OP_targ_ix PADOFFSETp | offsetof(struct op, op_targ)
855#define OP_flags_ix U8p | offsetof(struct op, op_flags)
856#define OP_private_ix U8p | offsetof(struct op, op_private)
9b1961be 857
a78b89ef
NC
858#define PMOP_pmflags_ix U32p | offsetof(struct pmop, op_pmflags)
859
657e3fc2
NC
860#ifdef USE_ITHREADS
861#define PMOP_pmoffset_ix IVp | offsetof(struct pmop, op_pmoffset)
862#endif
863
ba7298e3
NC
864# Yes, B::SV::sv and B::SV::gv really do end up generating identical code.
865#define SVOP_sv_ix SVp | offsetof(struct svop, op_sv)
866#define SVOP_gv_ix SVp | offsetof(struct svop, op_sv)
867
9488fb36
NC
868#define PADOP_padix_ix PADOFFSETp | offsetof(struct padop, op_padix)
869
39e120c1
NC
870#define COP_seq_ix U32p | offsetof(struct cop, cop_seq)
871#define COP_line_ix line_tp | offsetof(struct cop, cop_line)
872#if PERL_VERSION >= 9
873#define COP_hints_ix U32p | offsetof(struct cop, cop_hints)
874#else
875#define COP_hints_ix U8p | offsetof(struct cop, op_private)
876#endif
877
a9ed1a44
NC
878#ifdef USE_ITHREADS
879#define COP_stashpv_ix char_pp | offsetof(struct cop, cop_stashpv)
880#define COP_file_ix char_pp | offsetof(struct cop, cop_file)
881#else
882#define COP_stash_ix SVp | offsetof(struct cop, cop_stash)
883#define COP_filegv_ix SVp | offsetof(struct cop, cop_filegv)
884#endif
885
a8a597b2
MB
886MODULE = B PACKAGE = B::OP PREFIX = OP_
887
651aa52e
AE
888size_t
889OP_size(o)
890 B::OP o
891 CODE:
892 RETVAL = opsizes[cc_opclass(aTHX_ o)];
893 OUTPUT:
894 RETVAL
895
9b1961be
NC
896# The type checking code in B has always been identical for all OP types,
897# irrespective of whether the action is actually defined on that OP.
898# We should fix this
086f9b42 899void
9b1961be 900next(o)
a8a597b2 901 B::OP o
9b1961be 902 ALIAS:
086f9b42
NC
903 B::OP::next = OP_next_ix
904 B::OP::sibling = OP_sibling_ix
905 B::OP::targ = OP_targ_ix
906 B::OP::flags = OP_flags_ix
907 B::OP::private = OP_private_ix
908 B::UNOP::first = UNOP_first_ix
909 B::BINOP::last = BINOP_last_ix
910 B::LOGOP::other = LOGOP_other_ix
911 B::PMOP::pmreplstart = PMOP_pmreplstart_ix
912 B::LOOP::redoop = LOOP_redoop_ix
913 B::LOOP::nextop = LOOP_nextop_ix
914 B::LOOP::lastop = LOOP_lastop_ix
a78b89ef 915 B::PMOP::pmflags = PMOP_pmflags_ix
ba7298e3
NC
916 B::SVOP::sv = SVOP_sv_ix
917 B::SVOP::gv = SVOP_gv_ix
9488fb36 918 B::PADOP::padix = PADOP_padix_ix
39e120c1
NC
919 B::COP::cop_seq = COP_seq_ix
920 B::COP::line = COP_line_ix
921 B::COP::hints = COP_hints_ix
9b1961be
NC
922 PREINIT:
923 char *ptr;
086f9b42
NC
924 SV *ret;
925 PPCODE:
926 ptr = (ix & 0xFFFF) + (char *)o;
927 switch ((U8)(ix >> 16)) {
928 case (U8)(OPp >> 16):
929 {
930 OP *const o2 = *((OP **)ptr);
931 ret = sv_newmortal();
932 sv_setiv(newSVrv(ret, cc_opclassname(aTHX_ o2)), PTR2IV(o2));
933 break;
934 }
935 case (U8)(PADOFFSETp >> 16):
936 ret = sv_2mortal(newSVuv(*((PADOFFSET*)ptr)));
937 break;
938 case (U8)(U8p >> 16):
939 ret = sv_2mortal(newSVuv(*((U8*)ptr)));
940 break;
a78b89ef
NC
941 case (U8)(U32p >> 16):
942 ret = sv_2mortal(newSVuv(*((U32*)ptr)));
943 break;
ba7298e3
NC
944 case (U8)(SVp >> 16):
945 ret = make_sv_object(aTHX_ NULL, *((SV **)ptr));
946 break;
39e120c1
NC
947 case (U8)(line_tp >> 16):
948 ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
949 break;
657e3fc2
NC
950#ifdef USE_ITHREADS
951 case (U8)(IVp >> 16):
952 ret = sv_2mortal(newSViv(*((IV*)ptr)));
953 break;
a9ed1a44
NC
954 case (U8)(char_pp >> 16):
955 ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
956 break;
657e3fc2 957#endif
086f9b42
NC
958 }
959 ST(0) = ret;
960 XSRETURN(1);
a8a597b2
MB
961
962char *
3f872cb9
GS
963OP_name(o)
964 B::OP o
d2b33dc1
NC
965 ALIAS:
966 desc = 1
3f872cb9 967 CODE:
d2b33dc1 968 RETVAL = (char *)(ix ? PL_op_desc : PL_op_name)[o->op_type];
8063af02
DM
969 OUTPUT:
970 RETVAL
3f872cb9 971
8063af02 972void
a8a597b2
MB
973OP_ppaddr(o)
974 B::OP o
dc333d64
GS
975 PREINIT:
976 int i;
fdbd1d64 977 SV *sv = newSVpvs_flags("PL_ppaddr[OP_", SVs_TEMP);
a8a597b2 978 CODE:
dc333d64 979 sv_catpv(sv, PL_op_name[o->op_type]);
7c436af3 980 for (i=13; (STRLEN)i < SvCUR(sv); ++i)
dc333d64 981 SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]);
6beb30a6 982 sv_catpvs(sv, "]");
dc333d64 983 ST(0) = sv;
a8a597b2 984
7252851f 985#if PERL_VERSION >= 9
dd8be0e4
NC
986# These 3 are all bitfields, so we can't take their addresses.
987UV
988OP_type(o)
2814eb74 989 B::OP o
dd8be0e4
NC
990 ALIAS:
991 opt = 1
992 spare = 2
993 CODE:
994 switch(ix) {
995 case 1:
996 RETVAL = o->op_opt;
997 break;
998 case 2:
999 RETVAL = o->op_spare;
1000 break;
1001 default:
1002 RETVAL = o->op_type;
1003 }
1004 OUTPUT:
1005 RETVAL
2814eb74 1006
7252851f
NC
1007#else
1008
dd8be0e4
NC
1009UV
1010OP_type(o)
7252851f 1011 B::OP o
dd8be0e4
NC
1012 ALIAS:
1013 seq = 1
1014 CODE:
1015 switch(ix) {
1016 case 1:
1017 RETVAL = o->op_seq;
1018 break;
1019 default:
1020 RETVAL = o->op_type;
1021 }
1022 OUTPUT:
1023 RETVAL
7252851f
NC
1024
1025#endif
1026
1df34986
AE
1027void
1028OP_oplist(o)
1029 B::OP o
1030 PPCODE:
1031 SP = oplist(aTHX_ o, SP);
1032
a8a597b2
MB
1033MODULE = B PACKAGE = B::LISTOP PREFIX = LISTOP_
1034
c03c2844
SM
1035U32
1036LISTOP_children(o)
1037 B::LISTOP o
1038 OP * kid = NO_INIT
1039 int i = NO_INIT
1040 CODE:
c03c2844
SM
1041 i = 0;
1042 for (kid = o->op_first; kid; kid = kid->op_sibling)
1043 i++;
8063af02
DM
1044 RETVAL = i;
1045 OUTPUT:
016e8ce0 1046 RETVAL
a8a597b2
MB
1047
1048MODULE = B PACKAGE = B::PMOP PREFIX = PMOP_
1049
20e98b0f
NC
1050#if PERL_VERSION <= 8
1051
a8a597b2
MB
1052void
1053PMOP_pmreplroot(o)
1054 B::PMOP o
1055 OP * root = NO_INIT
1056 CODE:
1057 ST(0) = sv_newmortal();
1058 root = o->op_pmreplroot;
1059 /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */
1060 if (o->op_type == OP_PUSHRE) {
20e98b0f 1061# ifdef USE_ITHREADS
9d2bbe64 1062 sv_setiv(ST(0), INT2PTR(PADOFFSET,root) );
20e98b0f 1063# else
a8a597b2
MB
1064 sv_setiv(newSVrv(ST(0), root ?
1065 svclassnames[SvTYPE((SV*)root)] : "B::SV"),
56431972 1066 PTR2IV(root));
20e98b0f 1067# endif
a8a597b2
MB
1068 }
1069 else {
56431972 1070 sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root));
a8a597b2
MB
1071 }
1072
20e98b0f
NC
1073#else
1074
1075void
1076PMOP_pmreplroot(o)
1077 B::PMOP o
1078 CODE:
1079 ST(0) = sv_newmortal();
1080 if (o->op_type == OP_PUSHRE) {
1081# ifdef USE_ITHREADS
1082 sv_setiv(ST(0), o->op_pmreplrootu.op_pmtargetoff);
1083# else
1084 GV *const target = o->op_pmreplrootu.op_pmtargetgv;
1085 sv_setiv(newSVrv(ST(0), target ?
1086 svclassnames[SvTYPE((SV*)target)] : "B::SV"),
1087 PTR2IV(target));
1088# endif
1089 }
1090 else {
1091 OP *const root = o->op_pmreplrootu.op_pmreplroot;
1092 sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)),
1093 PTR2IV(root));
1094 }
1095
1096#endif
1097
9d2bbe64 1098#ifdef USE_ITHREADS
016e8ce0 1099#define PMOP_pmstashpv(o) PmopSTASHPV(o);
9d2bbe64 1100
651aa52e
AE
1101char*
1102PMOP_pmstashpv(o)
1103 B::PMOP o
1104
1105#else
016e8ce0 1106#define PMOP_pmstash(o) PmopSTASH(o);
651aa52e
AE
1107
1108B::HV
1109PMOP_pmstash(o)
1110 B::PMOP o
1111
9d2bbe64
MB
1112#endif
1113
7c1f70cb 1114#if PERL_VERSION < 9
5b02c205
NC
1115#define PMOP_pmnext(o) o->op_pmnext
1116
1117B::PMOP
1118PMOP_pmnext(o)
1119 B::PMOP o
7c1f70cb
NC
1120
1121U32
1122PMOP_pmpermflags(o)
1123 B::PMOP o
1124
1125U8
1126PMOP_pmdynflags(o)
1127 B::PMOP o
1128
1129#endif
1130
a8a597b2
MB
1131void
1132PMOP_precomp(o)
1133 B::PMOP o
021d294f
NC
1134 PREINIT:
1135 dXSI32;
1136 REGEXP *rx;
a8a597b2 1137 CODE:
aaa362c4 1138 rx = PM_GETRE(o);
c737faaf 1139 ST(0) = sv_newmortal();
021d294f
NC
1140 if (rx) {
1141#if PERL_VERSION >= 9
1142 if (ix) {
1143 sv_setuv(ST(0), RX_EXTFLAGS(rx));
1144 } else
1145#endif
1146 {
1147 sv_setpvn(ST(0), RX_PRECOMP(rx), RX_PRELEN(rx));
1148 }
1149 }
c737faaf 1150
021d294f
NC
1151BOOT:
1152{
1153 CV *cv;
1154#ifdef USE_ITHREADS
1155 cv = newXS("B::PMOP::pmoffset", XS_B__OP_next, __FILE__);
1156 XSANY.any_i32 = PMOP_pmoffset_ix;
a9ed1a44
NC
1157 cv = newXS("B::COP::stashpv", XS_B__OP_next, __FILE__);
1158 XSANY.any_i32 = COP_stashpv_ix;
1159 cv = newXS("B::COP::file", XS_B__OP_next, __FILE__);
1160 XSANY.any_i32 = COP_file_ix;
1161#else
1162 cv = newXS("B::COP::stash", XS_B__OP_next, __FILE__);
1163 XSANY.any_i32 = COP_stash_ix;
1164 cv = newXS("B::COP::filegv", XS_B__OP_next, __FILE__);
1165 XSANY.any_i32 = COP_filegv_ix;
7c1f70cb 1166#endif
021d294f
NC
1167#if PERL_VERSION >= 9
1168 cv = newXS("B::PMOP::reflags", XS_B__PMOP_precomp, __FILE__);
1169 XSANY.any_i32 = 1;
1170#endif
1171}
1172
c518d492 1173MODULE = B PACKAGE = B::PADOP
7934575e 1174
7934575e 1175B::SV
c518d492 1176sv(o)
7934575e 1177 B::PADOP o
c518d492
NC
1178 ALIAS:
1179 gv = 1
1180 CODE:
1181 /* It happens that the output typemaps for B::SV and B::GV are
1182 identical. The "smarts" are in make_sv_object(), which determines
1183 which class to use based on SvTYPE(), rather than anything baked in
1184 at compile time. */
1185 if (o->op_padix) {
1186 RETVAL = PAD_SVl(o->op_padix);
1187 if (ix && SvTYPE(RETVAL) != SVt_PVGV)
1188 RETVAL = NULL;
1189 } else {
1190 RETVAL = NULL;
1191 }
1192 OUTPUT:
1193 RETVAL
a8a597b2
MB
1194
1195MODULE = B PACKAGE = B::PVOP PREFIX = PVOP_
1196
1197void
1198PVOP_pv(o)
1199 B::PVOP o
1200 CODE:
1201 /*
bec89253 1202 * OP_TRANS uses op_pv to point to a table of 256 or >=258 shorts
a8a597b2
MB
1203 * whereas other PVOPs point to a null terminated string.
1204 */
bb16bae8 1205 if ((o->op_type == OP_TRANS || o->op_type == OP_TRANSR) &&
bec89253
RH
1206 (o->op_private & OPpTRANS_COMPLEMENT) &&
1207 !(o->op_private & OPpTRANS_DELETE))
1208 {
5d7488b2
AL
1209 const short* const tbl = (short*)o->op_pv;
1210 const short entries = 257 + tbl[256];
d3d34884 1211 ST(0) = newSVpvn_flags(o->op_pv, entries * sizeof(short), SVs_TEMP);
bec89253 1212 }
bb16bae8 1213 else if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
d3d34884 1214 ST(0) = newSVpvn_flags(o->op_pv, 256 * sizeof(short), SVs_TEMP);
bec89253
RH
1215 }
1216 else
d3d34884 1217 ST(0) = newSVpvn_flags(o->op_pv, strlen(o->op_pv), SVs_TEMP);
a8a597b2 1218
4b65a919 1219#define COP_label(o) CopLABEL(o)
fc15ae8f 1220#define COP_arybase(o) CopARYBASE_get(o)
a8a597b2
MB
1221
1222MODULE = B PACKAGE = B::COP PREFIX = COP_
1223
d5b8ed54
NC
1224const char *
1225COP_label(o)
1226 B::COP o
1227
a9ed1a44
NC
1228# Both pairs of accessors are provided for both ithreads and not, but for each,
1229# one pair is direct structure access, and 1 pair "faked up" with a more complex
1230# macro. We implement the direct structure access pair using the common code
1231# above (B::OP::next)
1232
1233#ifdef USE_ITHREADS
1234#define COP_stash(o) CopSTASH(o)
1235#define COP_filegv(o) CopFILEGV(o)
11faa288 1236
a8a597b2
MB
1237B::HV
1238COP_stash(o)
1239 B::COP o
1240
a9ed1a44
NC
1241B::GV
1242COP_filegv(o)
1243 B::COP o
1244
1245#else
1246#define COP_stashpv(o) CopSTASHPV(o)
1247#define COP_file(o) CopFILE(o)
1248
1249char *
1250COP_stashpv(o)
1251 B::COP o
1252
57843af0
GS
1253char *
1254COP_file(o)
a8a597b2
MB
1255 B::COP o
1256
a9ed1a44 1257#endif
1df34986 1258
a8a597b2
MB
1259I32
1260COP_arybase(o)
1261 B::COP o
1262
5c3c3f81 1263void
b295d113
TH
1264COP_warnings(o)
1265 B::COP o
5c3c3f81 1266 PPCODE:
13d356f3 1267#if PERL_VERSION >= 9
9496d2e5 1268 ST(0) = make_warnings_object(aTHX_ o->cop_warnings);
13d356f3
NC
1269#else
1270 ST(0) = make_sv_object(aTHX_ NULL, o->cop_warnings);
1271#endif
5c3c3f81 1272 XSRETURN(1);
b295d113 1273
670f1322 1274void
6e6a1aef
RGS
1275COP_io(o)
1276 B::COP o
11bcd5da 1277 PPCODE:
13d356f3 1278#if PERL_VERSION >= 9
9496d2e5 1279 ST(0) = make_cop_io_object(aTHX_ o);
13d356f3
NC
1280#else
1281 ST(0) = make_sv_object(aTHX_ NULL, o->cop_io);
1282#endif
11bcd5da 1283 XSRETURN(1);
6e6a1aef 1284
13d356f3
NC
1285#if PERL_VERSION >= 9
1286
fd9f6265
JJ
1287B::RHE
1288COP_hints_hash(o)
1289 B::COP o
1290 CODE:
20439bc7 1291 RETVAL = CopHINTHASH_get(o);
fd9f6265
JJ
1292 OUTPUT:
1293 RETVAL
1294
e412117e
NC
1295#endif
1296
651aa52e
AE
1297MODULE = B PACKAGE = B::SV
1298
de64752d
NC
1299#define MAGICAL_FLAG_BITS (SVs_GMG|SVs_SMG|SVs_RMG)
1300
651aa52e 1301U32
de64752d 1302REFCNT(sv)
651aa52e 1303 B::SV sv
de64752d
NC
1304 ALIAS:
1305 FLAGS = 0xFFFFFFFF
1306 SvTYPE = SVTYPEMASK
1307 POK = SVf_POK
1308 ROK = SVf_ROK
1309 MAGICAL = MAGICAL_FLAG_BITS
1310 CODE:
1311 RETVAL = ix ? (SvFLAGS(sv) & (U32)ix) : SvREFCNT(sv);
1312 OUTPUT:
1313 RETVAL
651aa52e 1314
9efba5c8 1315void
429a5ce7
SM
1316object_2svref(sv)
1317 B::SV sv
9efba5c8
NC
1318 PPCODE:
1319 ST(0) = sv_2mortal(newRV(sv));
1320 XSRETURN(1);
1321
a8a597b2
MB
1322MODULE = B PACKAGE = B::IV PREFIX = Sv
1323
1324IV
1325SvIV(sv)
1326 B::IV sv
1327
e4da9d6a 1328MODULE = B PACKAGE = B::IV
a8a597b2 1329
e4da9d6a
NC
1330#define sv_SVp 0x00000
1331#define sv_IVp 0x10000
1332#define sv_UVp 0x20000
1333#define sv_STRLENp 0x30000
1334#define sv_U32p 0x40000
1335#define sv_U8p 0x50000
1336#define sv_char_pp 0x60000
1337#define sv_NVp 0x70000
6782c6e0 1338#define sv_char_p 0x80000
3da43c35 1339#define sv_SSize_tp 0x90000
ffc5d9fc
NC
1340#define sv_I32p 0xA0000
1341#define sv_U16p 0xB0000
e4da9d6a
NC
1342
1343#define IV_ivx_ix sv_IVp | offsetof(struct xpviv, xiv_iv)
1344#define IV_uvx_ix sv_UVp | offsetof(struct xpvuv, xuv_uv)
1345#define NV_nvx_ix sv_NVp | offsetof(struct xpvnv, xnv_u.xnv_nv)
1346
1347#if PERL_VERSION >= 10
1348#define NV_cop_seq_range_low_ix \
1349 sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
1350#define NV_cop_seq_range_high_ix \
1351 sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
1352#define NV_parent_pad_index_ix \
1353 sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
1354#define NV_parent_fakelex_flags_ix \
1355 sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
1356#else
1357#define NV_cop_seq_range_low_ix \
1358 sv_NVp | offsetof(struct xpvnv, xnv_nv)
1359#define NV_cop_seq_range_high_ix \
1360 sv_UVp | offsetof(struct xpvnv, xuv_uv)
1361#define NV_parent_pad_index_ix \
1362 sv_NVp | offsetof(struct xpvnv, xnv_nv)
1363#define NV_parent_fakelex_flags_ix \
1364 sv_UVp | offsetof(struct xpvnv, xuv_uv)
1365#endif
0ca04487 1366
6782c6e0
NC
1367#define PV_cur_ix sv_STRLENp | offsetof(struct xpv, xpv_cur)
1368#define PV_len_ix sv_STRLENp | offsetof(struct xpv, xpv_len)
1369
1370#define PVMG_stash_ix sv_SVp | offsetof(struct xpvmg, xmg_stash)
1371
91a71e08
NC
1372#if PERL_VERSION >= 10
1373#define PVBM_useful_ix sv_I32p | offsetof(struct xpvgv, xiv_u.xivu_i32)
1374#define PVBM_previous_ix sv_U32p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_previous)
1375#define PVBM_rare_ix sv_U8p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_rare)
1376#else
1377#define PVBM_useful_ix sv_I32p | offsetof(struct xpvbm, xbm_useful)
1378#define PVBM_previous_ix sv_U16p | offsetof(struct xpvbm, xbm_previous)
1379#define PVBM_rare_ix sv_U8p | offsetof(struct xpvbm, xbm_rare)
1380#endif
1381
6782c6e0
NC
1382#define PVLV_targoff_ix sv_U32p | offsetof(struct xpvlv, xlv_targoff)
1383#define PVLV_targlen_ix sv_U32p | offsetof(struct xpvlv, xlv_targlen)
1384#define PVLV_targ_ix sv_SVp | offsetof(struct xpvlv, xlv_targ)
1385#define PVLV_type_ix sv_char_p | offsetof(struct xpvlv, xlv_type)
1386
f1f19364
NC
1387#if PERL_VERSION >= 10
1388#define PVGV_stash_ix sv_SVp | offsetof(struct xpvgv, xnv_u.xgv_stash)
1389#define PVGV_flags_ix sv_STRLENp | offsetof(struct xpvgv, xpv_cur)
55440d31 1390#define PVIO_lines_ix sv_IVp | offsetof(struct xpvio, xiv_iv)
f1f19364
NC
1391#else
1392#define PVGV_stash_ix sv_SVp | offsetof(struct xpvgv, xgv_stash)
1393#define PVGV_flags_ix sv_U8p | offsetof(struct xpvgv, xgv_flags)
55440d31 1394#define PVIO_lines_ix sv_IVp | offsetof(struct xpvio, xio_lines)
f1f19364
NC
1395#endif
1396
55440d31
NC
1397#define PVIO_page_ix sv_IVp | offsetof(struct xpvio, xio_page)
1398#define PVIO_page_len_ix sv_IVp | offsetof(struct xpvio, xio_page_len)
1399#define PVIO_lines_left_ix sv_IVp | offsetof(struct xpvio, xio_lines_left)
1400#define PVIO_top_name_ix sv_char_pp | offsetof(struct xpvio, xio_top_name)
1401#define PVIO_top_gv_ix sv_SVp | offsetof(struct xpvio, xio_top_gv)
1402#define PVIO_fmt_name_ix sv_char_pp | offsetof(struct xpvio, xio_fmt_name)
1403#define PVIO_fmt_gv_ix sv_SVp | offsetof(struct xpvio, xio_fmt_gv)
1404#define PVIO_bottom_name_ix sv_char_pp | offsetof(struct xpvio, xio_bottom_name)
1405#define PVIO_bottom_gv_ix sv_SVp | offsetof(struct xpvio, xio_bottom_gv)
1406#define PVIO_type_ix sv_char_p | offsetof(struct xpvio, xio_type)
1407#define PVIO_flags_ix sv_U8p | offsetof(struct xpvio, xio_flags)
1408
3da43c35
NC
1409#define PVAV_max_ix sv_SSize_tp | offsetof(struct xpvav, xav_max)
1410
1411#define PVFM_lines_ix sv_IVp | offsetof(struct xpvfm, xfm_lines)
1412
ffc5d9fc
NC
1413#define PVCV_stash_ix sv_SVp | offsetof(struct xpvcv, xcv_stash)
1414#define PVCV_gv_ix sv_SVp | offsetof(struct xpvcv, xcv_gv)
1415#define PVCV_file_ix sv_char_pp | offsetof(struct xpvcv, xcv_file)
1416#define PVCV_depth_ix sv_I32p | offsetof(struct xpvcv, xcv_depth)
1417#define PVCV_padlist_ix sv_SVp | offsetof(struct xpvcv, xcv_padlist)
1418#define PVCV_outside_ix sv_SVp | offsetof(struct xpvcv, xcv_outside)
1419#define PVCV_outside_seq_ix sv_U32p | offsetof(struct xpvcv, xcv_outside_seq)
1420#define PVCV_flags_ix sv_U16p | offsetof(struct xpvcv, xcv_flags)
1421
d65a2b0a
NC
1422#define PVHV_max_ix sv_STRLENp | offsetof(struct xpvhv, xhv_max)
1423
1424#if PERL_VERSION > 12
1425#define PVHV_keys_ix sv_STRLENp | offsetof(struct xpvhv, xhv_keys)
1426#else
1427#define PVHV_keys_ix sv_IVp | offsetof(struct xpvhv, xhv_keys)
1428#endif
1429
e4da9d6a
NC
1430# The type checking code in B has always been identical for all SV types,
1431# irrespective of whether the action is actually defined on that SV.
1432# We should fix this
1433void
1434IVX(sv)
1435 B::SV sv
1436 ALIAS:
1437 B::IV::IVX = IV_ivx_ix
1438 B::IV::UVX = IV_uvx_ix
1439 B::NV::NVX = NV_nvx_ix
1440 B::NV::COP_SEQ_RANGE_LOW = NV_cop_seq_range_low_ix
1441 B::NV::COP_SEQ_RANGE_HIGH = NV_cop_seq_range_high_ix
1442 B::NV::PARENT_PAD_INDEX = NV_parent_pad_index_ix
1443 B::NV::PARENT_FAKELEX_FLAGS = NV_parent_fakelex_flags_ix
6782c6e0
NC
1444 B::PV::CUR = PV_cur_ix
1445 B::PV::LEN = PV_len_ix
1446 B::PVMG::SvSTASH = PVMG_stash_ix
1447 B::PVLV::TARGOFF = PVLV_targoff_ix
1448 B::PVLV::TARGLEN = PVLV_targlen_ix
1449 B::PVLV::TARG = PVLV_targ_ix
1450 B::PVLV::TYPE = PVLV_type_ix
f1f19364
NC
1451 B::GV::STASH = PVGV_stash_ix
1452 B::GV::GvFLAGS = PVGV_flags_ix
91a71e08
NC
1453 B::BM::USEFUL = PVBM_useful_ix
1454 B::BM::PREVIOUS = PVBM_previous_ix
1455 B::BM::RARE = PVBM_rare_ix
55440d31
NC
1456 B::IO::LINES = PVIO_lines_ix
1457 B::IO::PAGE = PVIO_page_ix
1458 B::IO::PAGE_LEN = PVIO_page_len_ix
1459 B::IO::LINES_LEFT = PVIO_lines_left_ix
1460 B::IO::TOP_NAME = PVIO_top_name_ix
1461 B::IO::TOP_GV = PVIO_top_gv_ix
1462 B::IO::FMT_NAME = PVIO_fmt_name_ix
1463 B::IO::FMT_GV = PVIO_fmt_gv_ix
1464 B::IO::BOTTOM_NAME = PVIO_bottom_name_ix
1465 B::IO::BOTTOM_GV = PVIO_bottom_gv_ix
1466 B::IO::IoTYPE = PVIO_type_ix
1467 B::IO::IoFLAGS = PVIO_flags_ix
3da43c35
NC
1468 B::AV::MAX = PVAV_max_ix
1469 B::FM::LINES = PVFM_lines_ix
ffc5d9fc
NC
1470 B::CV::STASH = PVCV_stash_ix
1471 B::CV::GV = PVCV_gv_ix
1472 B::CV::FILE = PVCV_file_ix
1473 B::CV::DEPTH = PVCV_depth_ix
1474 B::CV::PADLIST = PVCV_padlist_ix
1475 B::CV::OUTSIDE = PVCV_outside_ix
1476 B::CV::OUTSIDE_SEQ = PVCV_outside_seq_ix
1477 B::CV::CvFLAGS = PVCV_flags_ix
d65a2b0a
NC
1478 B::HV::MAX = PVHV_max_ix
1479 B::HV::KEYS = PVHV_keys_ix
e4da9d6a
NC
1480 PREINIT:
1481 char *ptr;
1482 SV *ret;
1483 PPCODE:
1484 ptr = (ix & 0xFFFF) + (char *)SvANY(sv);
1485 switch ((U8)(ix >> 16)) {
1486 case (U8)(sv_SVp >> 16):
1487 ret = make_sv_object(aTHX_ NULL, *((SV **)ptr));
1488 break;
1489 case (U8)(sv_IVp >> 16):
1490 ret = sv_2mortal(newSViv(*((IV *)ptr)));
1491 break;
1492 case (U8)(sv_UVp >> 16):
1493 ret = sv_2mortal(newSVuv(*((UV *)ptr)));
1494 break;
6782c6e0
NC
1495 case (U8)(sv_STRLENp >> 16):
1496 ret = sv_2mortal(newSVuv(*((STRLEN *)ptr)));
1497 break;
e4da9d6a
NC
1498 case (U8)(sv_U32p >> 16):
1499 ret = sv_2mortal(newSVuv(*((U32 *)ptr)));
1500 break;
1501 case (U8)(sv_U8p >> 16):
1502 ret = sv_2mortal(newSVuv(*((U8 *)ptr)));
1503 break;
1504 case (U8)(sv_char_pp >> 16):
1505 ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
1506 break;
1507 case (U8)(sv_NVp >> 16):
1508 ret = sv_2mortal(newSVnv(*((NV *)ptr)));
1509 break;
6782c6e0
NC
1510 case (U8)(sv_char_p >> 16):
1511 ret = newSVpvn_flags((char *)ptr, 1, SVs_TEMP);
1512 break;
3da43c35
NC
1513 case (U8)(sv_SSize_tp >> 16):
1514 ret = sv_2mortal(newSViv(*((SSize_t *)ptr)));
1515 break;
ffc5d9fc
NC
1516 case (U8)(sv_I32p >> 16):
1517 ret = sv_2mortal(newSVuv(*((I32 *)ptr)));
1518 break;
1519 case (U8)(sv_U16p >> 16):
1520 ret = sv_2mortal(newSVuv(*((U16 *)ptr)));
1521 break;
e4da9d6a
NC
1522 }
1523 ST(0) = ret;
1524 XSRETURN(1);
a8a597b2 1525
a8a597b2
MB
1526void
1527packiv(sv)
1528 B::IV sv
6829f5e2
NC
1529 ALIAS:
1530 needs64bits = 1
a8a597b2 1531 CODE:
6829f5e2
NC
1532 if (ix) {
1533 ST(0) = boolSV((I32)SvIVX(sv) != SvIVX(sv));
1534 } else if (sizeof(IV) == 8) {
a8a597b2 1535 U32 wp[2];
5d7488b2 1536 const IV iv = SvIVX(sv);
a8a597b2
MB
1537 /*
1538 * The following way of spelling 32 is to stop compilers on
1539 * 32-bit architectures from moaning about the shift count
1540 * being >= the width of the type. Such architectures don't
1541 * reach this code anyway (unless sizeof(IV) > 8 but then
1542 * everything else breaks too so I'm not fussed at the moment).
1543 */
42718184
RB
1544#ifdef UV_IS_QUAD
1545 wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1546#else
1547 wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1548#endif
a8a597b2 1549 wp[1] = htonl(iv & 0xffffffff);
d3d34884 1550 ST(0) = newSVpvn_flags((char *)wp, 8, SVs_TEMP);
a8a597b2
MB
1551 } else {
1552 U32 w = htonl((U32)SvIVX(sv));
d3d34884 1553 ST(0) = newSVpvn_flags((char *)&w, 4, SVs_TEMP);
a8a597b2
MB
1554 }
1555
4df7f6af 1556#if PERL_VERSION >= 11
f046b1bd
NC
1557# The input typemap checking makes no distinction between different SV types,
1558# so the XS body will generate the same C code, despite the different XS
1559# "types". So there is no change in behaviour from doing newXS like this,
1560# compared with the old approach of having a (near) duplicate XS body.
1561# We should fix the typemap checking.
4df7f6af 1562
f046b1bd
NC
1563BOOT:
1564 newXS("B::IV::RV", XS_B__PV_RV, __FILE__);
4df7f6af
NC
1565
1566#endif
1567
a8a597b2
MB
1568MODULE = B PACKAGE = B::NV PREFIX = Sv
1569
76ef7183 1570NV
a8a597b2
MB
1571SvNV(sv)
1572 B::NV sv
1573
4df7f6af
NC
1574#if PERL_VERSION < 11
1575
a8a597b2
MB
1576MODULE = B PACKAGE = B::RV PREFIX = Sv
1577
1578B::SV
1579SvRV(sv)
1580 B::RV sv
1581
4df7f6af
NC
1582#endif
1583
a8a597b2
MB
1584MODULE = B PACKAGE = B::PV PREFIX = Sv
1585
0b40bd6d
RH
1586char*
1587SvPVX(sv)
1588 B::PV sv
1589
b326da91
MB
1590B::SV
1591SvRV(sv)
1592 B::PV sv
1593 CODE:
1594 if( SvROK(sv) ) {
1595 RETVAL = SvRV(sv);
1596 }
1597 else {
1598 croak( "argument is not SvROK" );
1599 }
1600 OUTPUT:
1601 RETVAL
1602
a8a597b2
MB
1603void
1604SvPV(sv)
1605 B::PV sv
1606 CODE:
c0b20461 1607 if( SvPOK(sv) ) {
fdbd1d64
NC
1608 STRLEN len = SvCUR(sv);
1609 const char *p = SvPVX_const(sv);
0eaead75
NC
1610#if PERL_VERSION < 10
1611 /* Before 5.10 (well 931b58fb28fa5ca7), PAD_COMPNAME_GEN was stored
1612 in SvCUR(), which meant we had to attempt this special casing
1613 to avoid tripping up over variable names in the pads. */
fdbd1d64 1614 if((SvLEN(sv) && len >= SvLEN(sv))) {
b55685ae
NC
1615 /* It claims to be longer than the space allocated for it -
1616 presuambly it's a variable name in the pad */
fdbd1d64 1617 len = strlen(p);
b55685ae 1618 }
0eaead75 1619#endif
fdbd1d64 1620 ST(0) = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
b326da91
MB
1621 }
1622 else {
1623 /* XXX for backward compatibility, but should fail */
1624 /* croak( "argument is not SvPOK" ); */
fdbd1d64 1625 ST(0) = sv_newmortal();
b326da91 1626 }
a8a597b2 1627
5a44e503
NC
1628# This used to read 257. I think that that was buggy - should have been 258.
1629# (The "\0", the flags byte, and 256 for the table. Not that anything
1630# anywhere calls this method. NWC.
651aa52e
AE
1631void
1632SvPVBM(sv)
1633 B::PV sv
1634 CODE:
fdbd1d64
NC
1635 ST(0) = newSVpvn_flags(SvPVX_const(sv),
1636 SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0),
1637 SVs_TEMP);
651aa52e 1638
a8a597b2
MB
1639MODULE = B PACKAGE = B::PVMG PREFIX = Sv
1640
1641void
1642SvMAGIC(sv)
1643 B::PVMG sv
1644 MAGIC * mg = NO_INIT
1645 PPCODE:
1646 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
9496d2e5 1647 XPUSHs(make_mg_object(aTHX_ mg));
a8a597b2 1648
5c35adbb
NC
1649MODULE = B PACKAGE = B::REGEXP
1650
1651#if PERL_VERSION >= 11
1652
1653IV
1654REGEX(sv)
07bc277f 1655 B::REGEXP sv
5c35adbb 1656 CODE:
288b8c02
NC
1657 /* FIXME - can we code this method more efficiently? */
1658 RETVAL = PTR2IV(sv);
5c35adbb
NC
1659 OUTPUT:
1660 RETVAL
1661
1662SV*
1663precomp(sv)
07bc277f 1664 B::REGEXP sv
5c35adbb 1665 CODE:
288b8c02 1666 RETVAL = newSVpvn( RX_PRECOMP(sv), RX_PRELEN(sv) );
5c35adbb
NC
1667 OUTPUT:
1668 RETVAL
1669
1670#endif
1671
b2adfa9b 1672MODULE = B PACKAGE = B::MAGIC
a8a597b2
MB
1673
1674void
b2adfa9b 1675MOREMAGIC(mg)
a8a597b2 1676 B::MAGIC mg
b2adfa9b
NC
1677 ALIAS:
1678 PRIVATE = 1
1679 TYPE = 2
1680 FLAGS = 3
1681 LEN = 4
1682 OBJ = 5
1683 PTR = 6
1684 REGEX = 7
1685 precomp = 8
1686 PPCODE:
1687 switch (ix) {
1688 case 0:
1689 XPUSHs(mg->mg_moremagic ? make_mg_object(aTHX_ mg->mg_moremagic)
1690 : &PL_sv_undef);
1691 break;
1692 case 1:
1693 mPUSHu(mg->mg_private);
1694 break;
1695 case 2:
1696 PUSHs(newSVpvn_flags(&(mg->mg_type), 1, SVs_TEMP));
1697 break;
1698 case 3:
1699 mPUSHu(mg->mg_flags);
1700 break;
1701 case 4:
1702 mPUSHi(mg->mg_len);
1703 break;
1704 case 5:
1705 PUSHs(make_sv_object(aTHX_ NULL, mg->mg_obj));
1706 break;
1707 case 6:
1708 if (mg->mg_ptr) {
1709 if (mg->mg_len >= 0) {
1710 PUSHs(newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP));
651aa52e 1711 } else if (mg->mg_len == HEf_SVKEY) {
b2adfa9b 1712 PUSHs(make_sv_object(aTHX_ NULL, (SV*)mg->mg_ptr));
fdbd1d64 1713 } else
b2adfa9b
NC
1714 PUSHs(sv_newmortal());
1715 } else
1716 PUSHs(sv_newmortal());
1717 break;
1718 case 7:
1719 if(mg->mg_type == PERL_MAGIC_qr) {
1720 mPUSHi(PTR2IV(mg->mg_obj));
1721 } else {
1722 croak("REGEX is only meaningful on r-magic");
1723 }
1724 break;
1725 case 8:
1726 if (mg->mg_type == PERL_MAGIC_qr) {
1727 REGEXP *rx = (REGEXP *)mg->mg_obj;
227aaa42
NC
1728 PUSHs(newSVpvn_flags(rx ? RX_PRECOMP(rx) : NULL,
1729 rx ? RX_PRELEN(rx) : 0, SVs_TEMP));
b2adfa9b
NC
1730 } else {
1731 croak( "precomp is only meaningful on r-magic" );
1732 }
1733 break;
1734 }
a8a597b2 1735
a8a597b2
MB
1736MODULE = B PACKAGE = B::BM PREFIX = Bm
1737
a8a597b2
MB
1738void
1739BmTABLE(sv)
1740 B::BM sv
1741 STRLEN len = NO_INIT
1742 char * str = NO_INIT
1743 CODE:
1744 str = SvPV(sv, len);
1745 /* Boyer-Moore table is just after string and its safety-margin \0 */
d3d34884 1746 ST(0) = newSVpvn_flags(str + len + PERL_FBM_TABLE_OFFSET, 256, SVs_TEMP);
a8a597b2
MB
1747
1748MODULE = B PACKAGE = B::GV PREFIX = Gv
1749
1750void
1751GvNAME(gv)
1752 B::GV gv
cbf9c13f
NC
1753 ALIAS:
1754 FILE = 1
435e8dd0 1755 B::HV::NAME = 2
a8a597b2 1756 CODE:
6beb30a6 1757#if PERL_VERSION >= 10
435e8dd0
NC
1758 ST(0) = sv_2mortal(newSVhek(!ix ? GvNAME_HEK(gv)
1759 : (ix == 1 ? GvFILE_HEK(gv)
1760 : HvNAME_HEK((HV *)gv))));
6beb30a6 1761#else
435e8dd0
NC
1762 ST(0) = !ix ? newSVpvn_flags(GvNAME(gv), GvNAMELEN(gv), SVs_TEMP)
1763 : sv_2mortal(newSVpv(ix == 1 ? GvFILE(gv) : HvNAME((HV *)gv), 0))
6beb30a6 1764#endif
a8a597b2 1765
87d7fd28
GS
1766bool
1767is_empty(gv)
1768 B::GV gv
711fbbf0
NC
1769 ALIAS:
1770 isGV_with_GP = 1
87d7fd28 1771 CODE:
711fbbf0 1772 if (ix) {
50786ba8 1773#if PERL_VERSION >= 9
711fbbf0 1774 RETVAL = isGV_with_GP(gv) ? TRUE : FALSE;
50786ba8 1775#else
711fbbf0 1776 RETVAL = TRUE; /* In 5.8 and earlier they all are. */
50786ba8 1777#endif
711fbbf0
NC
1778 } else {
1779 RETVAL = GvGP(gv) == Null(GP*);
1780 }
50786ba8 1781 OUTPUT:
711fbbf0 1782 RETVAL
50786ba8 1783
651aa52e
AE
1784void*
1785GvGP(gv)
1786 B::GV gv
1787
257e0650
NC
1788#define GP_sv_ix SVp | offsetof(struct gp, gp_sv)
1789#define GP_io_ix SVp | offsetof(struct gp, gp_io)
1790#define GP_cv_ix SVp | offsetof(struct gp, gp_cv)
1791#define GP_cvgen_ix U32p | offsetof(struct gp, gp_cvgen)
1792#define GP_refcnt_ix U32p | offsetof(struct gp, gp_refcnt)
1793#define GP_hv_ix SVp | offsetof(struct gp, gp_hv)
1794#define GP_av_ix SVp | offsetof(struct gp, gp_av)
1795#define GP_form_ix SVp | offsetof(struct gp, gp_form)
1796#define GP_egv_ix SVp | offsetof(struct gp, gp_egv)
1797#define GP_line_ix line_tp | offsetof(struct gp, gp_line)
a8a597b2 1798
257e0650
NC
1799void
1800SV(gv)
a8a597b2 1801 B::GV gv
257e0650
NC
1802 ALIAS:
1803 SV = GP_sv_ix
1804 IO = GP_io_ix
1805 CV = GP_cv_ix
1806 CVGEN = GP_cvgen_ix
1807 GvREFCNT = GP_refcnt_ix
1808 HV = GP_hv_ix
1809 AV = GP_av_ix
1810 FORM = GP_form_ix
1811 EGV = GP_egv_ix
1812 LINE = GP_line_ix
1813 PREINIT:
1814 GP *gp;
1815 char *ptr;
1816 SV *ret;
1817 PPCODE:
1818 gp = GvGP(gv);
1819 if (!gp) {
1820 const GV *const gv = CvGV(cv);
46c3f339 1821 Perl_croak(aTHX_ "NULL gp in B::GV::%s", gv ? GvNAME(gv) : "???");
257e0650
NC
1822 }
1823 ptr = (ix & 0xFFFF) + (char *)gp;
1824 switch ((U8)(ix >> 16)) {
1825 case (U8)(SVp >> 16):
1826 ret = make_sv_object(aTHX_ NULL, *((SV **)ptr));
1827 break;
1828 case (U8)(U32p >> 16):
1829 ret = sv_2mortal(newSVuv(*((U32*)ptr)));
1830 break;
1831 case (U8)(line_tp >> 16):
1832 ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
1833 break;
1834 }
1835 ST(0) = ret;
1836 XSRETURN(1);
a8a597b2
MB
1837
1838B::GV
1839GvFILEGV(gv)
1840 B::GV gv
1841
a8a597b2
MB
1842MODULE = B PACKAGE = B::IO PREFIX = Io
1843
04071355
NC
1844#if PERL_VERSION <= 8
1845
a8a597b2
MB
1846short
1847IoSUBPROCESS(io)
1848 B::IO io
1849
04071355
NC
1850#endif
1851
b326da91
MB
1852bool
1853IsSTD(io,name)
1854 B::IO io
5d7488b2 1855 const char* name
b326da91
MB
1856 PREINIT:
1857 PerlIO* handle = 0;
1858 CODE:
1859 if( strEQ( name, "stdin" ) ) {
1860 handle = PerlIO_stdin();
1861 }
1862 else if( strEQ( name, "stdout" ) ) {
1863 handle = PerlIO_stdout();
1864 }
1865 else if( strEQ( name, "stderr" ) ) {
1866 handle = PerlIO_stderr();
1867 }
1868 else {
1869 croak( "Invalid value '%s'", name );
1870 }
1871 RETVAL = handle == IoIFP(io);
1872 OUTPUT:
1873 RETVAL
1874
a8a597b2
MB
1875MODULE = B PACKAGE = B::AV PREFIX = Av
1876
1877SSize_t
1878AvFILL(av)
1879 B::AV av
1880
a8a597b2
MB
1881void
1882AvARRAY(av)
1883 B::AV av
1884 PPCODE:
1885 if (AvFILL(av) >= 0) {
1886 SV **svp = AvARRAY(av);
1887 I32 i;
1888 for (i = 0; i <= AvFILL(av); i++)
9496d2e5 1889 XPUSHs(make_sv_object(aTHX_ NULL, svp[i]));
a8a597b2
MB
1890 }
1891
429a5ce7
SM
1892void
1893AvARRAYelt(av, idx)
1894 B::AV av
1895 int idx
1896 PPCODE:
1897 if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
9496d2e5 1898 XPUSHs(make_sv_object(aTHX_ NULL, (AvARRAY(av)[idx])));
429a5ce7 1899 else
9496d2e5 1900 XPUSHs(make_sv_object(aTHX_ NULL, NULL));
429a5ce7 1901
edcc7c74
NC
1902#if PERL_VERSION < 9
1903
5b02c205
NC
1904#define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1905
1906IV
1907AvOFF(av)
1908 B::AV av
1909
edcc7c74
NC
1910MODULE = B PACKAGE = B::AV
1911
1912U8
1913AvFLAGS(av)
1914 B::AV av
1915
1916#endif
1917
a8a597b2
MB
1918MODULE = B PACKAGE = B::CV PREFIX = Cv
1919
651aa52e
AE
1920U32
1921CvCONST(cv)
1922 B::CV cv
1923
a8a597b2
MB
1924B::OP
1925CvSTART(cv)
1926 B::CV cv
a0da4400
NC
1927 ALIAS:
1928 ROOT = 1
bf53b3a5 1929 CODE:
a0da4400 1930 RETVAL = CvISXSUB(cv) ? NULL : ix ? CvROOT(cv) : CvSTART(cv);
d04ba589
NC
1931 OUTPUT:
1932 RETVAL
a8a597b2 1933
a8a597b2
MB
1934void
1935CvXSUB(cv)
1936 B::CV cv
96819e59
NC
1937 ALIAS:
1938 XSUBANY = 1
a8a597b2 1939 CODE:
96819e59 1940 ST(0) = ix && CvCONST(cv)
9496d2e5 1941 ? make_sv_object(aTHX_ NULL, (SV *)CvXSUBANY(cv).any_ptr)
96819e59
NC
1942 : sv_2mortal(newSViv(CvISXSUB(cv)
1943 ? (ix ? CvXSUBANY(cv).any_iv
1944 : PTR2IV(CvXSUB(cv)))
1945 : 0));
a8a597b2 1946
de3f1649
JT
1947MODULE = B PACKAGE = B::CV PREFIX = cv_
1948
1949B::SV
1950cv_const_sv(cv)
1951 B::CV cv
1952
a8a597b2
MB
1953MODULE = B PACKAGE = B::HV PREFIX = Hv
1954
1955STRLEN
1956HvFILL(hv)
1957 B::HV hv
1958
a8a597b2
MB
1959I32
1960HvRITER(hv)
1961 B::HV hv
1962
edcc7c74
NC
1963#if PERL_VERSION < 9
1964
1965B::PMOP
1966HvPMROOT(hv)
1967 B::HV hv
1968
1969#endif
1970
a8a597b2
MB
1971void
1972HvARRAY(hv)
1973 B::HV hv
1974 PPCODE:
1975 if (HvKEYS(hv) > 0) {
1976 SV *sv;
1977 char *key;
1978 I32 len;
1979 (void)hv_iterinit(hv);
1980 EXTEND(sp, HvKEYS(hv) * 2);
8063af02 1981 while ((sv = hv_iternextsv(hv, &key, &len))) {
22f1178f 1982 mPUSHp(key, len);
9496d2e5 1983 PUSHs(make_sv_object(aTHX_ NULL, sv));
a8a597b2
MB
1984 }
1985 }
fd9f6265
JJ
1986
1987MODULE = B PACKAGE = B::HE PREFIX = He
1988
1989B::SV
1990HeVAL(he)
1991 B::HE he
b2619626
NC
1992 ALIAS:
1993 SVKEY_force = 1
1994 CODE:
1995 RETVAL = ix ? HeSVKEY_force(he) : HeVAL(he);
1996 OUTPUT:
1997 RETVAL
fd9f6265
JJ
1998
1999U32
2000HeHASH(he)
2001 B::HE he
2002
fd9f6265
JJ
2003MODULE = B PACKAGE = B::RHE PREFIX = RHE_
2004
e412117e
NC
2005#if PERL_VERSION >= 9
2006
fd9f6265
JJ
2007SV*
2008RHE_HASH(h)
2009 B::RHE h
2010 CODE:
20439bc7 2011 RETVAL = newRV( (SV*)cophh_2hv(h, 0) );
fd9f6265
JJ
2012 OUTPUT:
2013 RETVAL
e412117e
NC
2014
2015#endif