This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
In B::REGEX::precomp, use newSVpvn_flags() instead of newSVpvn().
[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
20f7624e
NC
480static SV *
481walkoptree(pTHX_ OP *o, const char *method, SV *ref)
a8a597b2
MB
482{
483 dSP;
20f7624e
NC
484 OP *kid;
485 SV *object;
486 const char *const classname = cc_opclassname(aTHX_ o);
89ca4ac7
JH
487 dMY_CXT;
488
20f7624e
NC
489 /* Check that no-one has changed our reference, or is holding a reference
490 to it. */
491 if (SvREFCNT(ref) == 1 && SvROK(ref) && SvTYPE(ref) == SVt_RV
492 && (object = SvRV(ref)) && SvREFCNT(object) == 1
493 && SvTYPE(object) == SVt_PVMG && SvIOK_only(object)
494 && !SvMAGICAL(object) && !SvMAGIC(object) && SvSTASH(object)) {
495 /* Looks good, so rebless it for the class we need: */
496 sv_bless(ref, gv_stashpv(classname, GV_ADD));
497 } else {
498 /* Need to make a new one. */
499 ref = sv_newmortal();
500 object = newSVrv(ref, classname);
501 }
502 sv_setiv(object, PTR2IV(o));
503
a8a597b2
MB
504 if (walkoptree_debug) {
505 PUSHMARK(sp);
20f7624e 506 XPUSHs(ref);
a8a597b2
MB
507 PUTBACK;
508 perl_call_method("walkoptree_debug", G_DISCARD);
509 }
510 PUSHMARK(sp);
20f7624e 511 XPUSHs(ref);
a8a597b2
MB
512 PUTBACK;
513 perl_call_method(method, G_DISCARD);
514 if (o && (o->op_flags & OPf_KIDS)) {
a8a597b2 515 for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) {
20f7624e 516 ref = walkoptree(aTHX_ kid, method, ref);
a8a597b2
MB
517 }
518 }
5464c149 519 if (o && (cc_opclass(aTHX_ o) == OPc_PMOP) && o->op_type != OP_PUSHRE
8f3d514b 520 && (kid = PMOP_pmreplroot(cPMOPo)))
f3be9b72 521 {
20f7624e 522 ref = walkoptree(aTHX_ kid, method, ref);
f3be9b72 523 }
20f7624e 524 return ref;
a8a597b2
MB
525}
526
5d7488b2 527static SV **
1df34986
AE
528oplist(pTHX_ OP *o, SV **SP)
529{
530 for(; o; o = o->op_next) {
531 SV *opsv;
7252851f
NC
532#if PERL_VERSION >= 9
533 if (o->op_opt == 0)
1df34986 534 break;
2814eb74 535 o->op_opt = 0;
7252851f
NC
536#else
537 if (o->op_seq == 0)
538 break;
539 o->op_seq = 0;
540#endif
1df34986
AE
541 opsv = sv_newmortal();
542 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ (OP*)o)), PTR2IV(o));
543 XPUSHs(opsv);
544 switch (o->op_type) {
545 case OP_SUBST:
8f3d514b 546 SP = oplist(aTHX_ PMOP_pmreplstart(cPMOPo), SP);
1df34986
AE
547 continue;
548 case OP_SORT:
f66c782a 549 if (o->op_flags & OPf_STACKED && o->op_flags & OPf_SPECIAL) {
1df34986
AE
550 OP *kid = cLISTOPo->op_first->op_sibling; /* pass pushmark */
551 kid = kUNOP->op_first; /* pass rv2gv */
552 kid = kUNOP->op_first; /* pass leave */
f66c782a 553 SP = oplist(aTHX_ kid->op_next, SP);
1df34986
AE
554 }
555 continue;
556 }
557 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
558 case OA_LOGOP:
559 SP = oplist(aTHX_ cLOGOPo->op_other, SP);
560 break;
561 case OA_LOOP:
562 SP = oplist(aTHX_ cLOOPo->op_lastop, SP);
563 SP = oplist(aTHX_ cLOOPo->op_nextop, SP);
564 SP = oplist(aTHX_ cLOOPo->op_redoop, SP);
565 break;
566 }
567 }
568 return SP;
569}
570
a8a597b2
MB
571typedef OP *B__OP;
572typedef UNOP *B__UNOP;
573typedef BINOP *B__BINOP;
574typedef LOGOP *B__LOGOP;
a8a597b2
MB
575typedef LISTOP *B__LISTOP;
576typedef PMOP *B__PMOP;
577typedef SVOP *B__SVOP;
7934575e 578typedef PADOP *B__PADOP;
a8a597b2
MB
579typedef PVOP *B__PVOP;
580typedef LOOP *B__LOOP;
581typedef COP *B__COP;
582
583typedef SV *B__SV;
584typedef SV *B__IV;
585typedef SV *B__PV;
586typedef SV *B__NV;
587typedef SV *B__PVMG;
5c35adbb
NC
588#if PERL_VERSION >= 11
589typedef SV *B__REGEXP;
590#endif
a8a597b2
MB
591typedef SV *B__PVLV;
592typedef SV *B__BM;
593typedef SV *B__RV;
1df34986 594typedef SV *B__FM;
a8a597b2
MB
595typedef AV *B__AV;
596typedef HV *B__HV;
597typedef CV *B__CV;
598typedef GV *B__GV;
599typedef IO *B__IO;
600
601typedef MAGIC *B__MAGIC;
fd9f6265 602typedef HE *B__HE;
e412117e 603#if PERL_VERSION >= 9
fd9f6265 604typedef struct refcounted_he *B__RHE;
e412117e 605#endif
a8a597b2 606
32855229
NC
607#ifdef USE_ITHREADS
608# define ASSIGN_COMMON_ALIAS(var) \
609 STMT_START { XSANY.any_i32 = offsetof(struct interpreter, var); } STMT_END
610#else
611# define ASSIGN_COMMON_ALIAS(var) \
612 STMT_START { XSANY.any_ptr = (void *)&PL_##var; } STMT_END
613#endif
614
615/* This needs to be ALIASed in a custom way, hence can't easily be defined as
616 a regular XSUB. */
617static XSPROTO(intrpvar_sv_common); /* prototype to pass -Wmissing-prototypes */
618static XSPROTO(intrpvar_sv_common)
619{
620 dVAR;
621 dXSARGS;
622 SV *ret;
623 if (items != 0)
624 croak_xs_usage(cv, "");
625#ifdef USE_ITHREADS
626 ret = *(SV **)(XSANY.any_i32 + (char *)my_perl);
627#else
628 ret = *(SV **)(XSANY.any_ptr);
629#endif
630 ST(0) = make_sv_object(aTHX_ NULL, ret);
631 XSRETURN(1);
632}
633
b1826b71
NC
634#include "const-c.inc"
635
7a2c16aa 636MODULE = B PACKAGE = B
a8a597b2 637
b1826b71
NC
638INCLUDE: const-xs.inc
639
a8a597b2
MB
640PROTOTYPES: DISABLE
641
642BOOT:
4c1f658f 643{
7a2c16aa
NC
644 CV *cv;
645 const char *file = __FILE__;
89ca4ac7 646 MY_CXT_INIT;
e8edd1e6
TH
647 specialsv_list[0] = Nullsv;
648 specialsv_list[1] = &PL_sv_undef;
649 specialsv_list[2] = &PL_sv_yes;
650 specialsv_list[3] = &PL_sv_no;
5c3c3f81
NC
651 specialsv_list[4] = (SV *) pWARN_ALL;
652 specialsv_list[5] = (SV *) pWARN_NONE;
653 specialsv_list[6] = (SV *) pWARN_STD;
32855229
NC
654
655 cv = newXS("B::init_av", intrpvar_sv_common, file);
656 ASSIGN_COMMON_ALIAS(Iinitav);
657 cv = newXS("B::check_av", intrpvar_sv_common, file);
658 ASSIGN_COMMON_ALIAS(Icheckav_save);
659#if PERL_VERSION >= 9
660 cv = newXS("B::unitcheck_av", intrpvar_sv_common, file);
661 ASSIGN_COMMON_ALIAS(Iunitcheckav_save);
662#endif
663 cv = newXS("B::begin_av", intrpvar_sv_common, file);
664 ASSIGN_COMMON_ALIAS(Ibeginav_save);
665 cv = newXS("B::end_av", intrpvar_sv_common, file);
666 ASSIGN_COMMON_ALIAS(Iendav);
667 cv = newXS("B::main_cv", intrpvar_sv_common, file);
668 ASSIGN_COMMON_ALIAS(Imain_cv);
669 cv = newXS("B::inc_gv", intrpvar_sv_common, file);
670 ASSIGN_COMMON_ALIAS(Iincgv);
671 cv = newXS("B::defstash", intrpvar_sv_common, file);
672 ASSIGN_COMMON_ALIAS(Idefstash);
673 cv = newXS("B::curstash", intrpvar_sv_common, file);
674 ASSIGN_COMMON_ALIAS(Icurstash);
675 cv = newXS("B::formfeed", intrpvar_sv_common, file);
676 ASSIGN_COMMON_ALIAS(Iformfeed);
677#ifdef USE_ITHREADS
678 cv = newXS("B::regex_padav", intrpvar_sv_common, file);
679 ASSIGN_COMMON_ALIAS(Iregex_padav);
680#endif
681 cv = newXS("B::warnhook", intrpvar_sv_common, file);
682 ASSIGN_COMMON_ALIAS(Iwarnhook);
683 cv = newXS("B::diehook", intrpvar_sv_common, file);
684 ASSIGN_COMMON_ALIAS(Idiehook);
685}
686
7a2c16aa
NC
687long
688amagic_generation()
689 CODE:
690 RETVAL = PL_amagic_generation;
691 OUTPUT:
692 RETVAL
693
694B::AV
695comppadlist()
696 CODE:
697 RETVAL = PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv);
698 OUTPUT:
699 RETVAL
700
a4aabc83
NC
701B::SV
702sv_undef()
703 ALIAS:
704 sv_no = 1
705 sv_yes = 2
706 CODE:
707 RETVAL = ix > 1 ? &PL_sv_yes : ix < 1 ? &PL_sv_undef : &PL_sv_no;
708 OUTPUT:
709 RETVAL
710
e97701b4
NC
711B::OP
712main_root()
713 ALIAS:
714 main_start = 1
715 CODE:
716 RETVAL = ix ? PL_main_start : PL_main_root;
717 OUTPUT:
718 RETVAL
719
2edf0c1d
NC
720UV
721sub_generation()
722 ALIAS:
723 dowarn = 1
724 CODE:
725 RETVAL = ix ? PL_dowarn : PL_sub_generation;
726 OUTPUT:
727 RETVAL
728
a8a597b2 729void
20f7624e
NC
730walkoptree(op, method)
731 B::OP op
5d7488b2 732 const char * method
cea2e8a9 733 CODE:
20f7624e 734 (void) walkoptree(aTHX_ op, method, &PL_sv_undef);
a8a597b2
MB
735
736int
737walkoptree_debug(...)
738 CODE:
89ca4ac7 739 dMY_CXT;
a8a597b2
MB
740 RETVAL = walkoptree_debug;
741 if (items > 0 && SvTRUE(ST(1)))
742 walkoptree_debug = 1;
743 OUTPUT:
744 RETVAL
745
56431972 746#define address(sv) PTR2IV(sv)
a8a597b2
MB
747
748IV
749address(sv)
750 SV * sv
751
752B::SV
753svref_2object(sv)
754 SV * sv
755 CODE:
756 if (!SvROK(sv))
757 croak("argument is not a reference");
758 RETVAL = (SV*)SvRV(sv);
759 OUTPUT:
0cc1d052
NIS
760 RETVAL
761
762void
763opnumber(name)
5d7488b2 764const char * name
0cc1d052
NIS
765CODE:
766{
767 int i;
768 IV result = -1;
769 ST(0) = sv_newmortal();
770 if (strncmp(name,"pp_",3) == 0)
771 name += 3;
772 for (i = 0; i < PL_maxo; i++)
773 {
774 if (strcmp(name, PL_op_name[i]) == 0)
775 {
776 result = i;
777 break;
778 }
779 }
780 sv_setiv(ST(0),result);
781}
a8a597b2
MB
782
783void
784ppname(opnum)
785 int opnum
786 CODE:
787 ST(0) = sv_newmortal();
3280af22 788 if (opnum >= 0 && opnum < PL_maxo) {
6beb30a6 789 sv_setpvs(ST(0), "pp_");
22c35a8c 790 sv_catpv(ST(0), PL_op_name[opnum]);
a8a597b2
MB
791 }
792
793void
794hash(sv)
795 SV * sv
796 CODE:
a8a597b2
MB
797 STRLEN len;
798 U32 hash = 0;
8c5b7c71 799 const char *s = SvPVbyte(sv, len);
c32d3395 800 PERL_HASH(hash, s, len);
90b16320 801 ST(0) = sv_2mortal(Perl_newSVpvf(aTHX_ "0x%"UVxf, (UV)hash));
a8a597b2
MB
802
803#define cast_I32(foo) (I32)foo
804IV
805cast_I32(i)
806 IV i
807
808void
809minus_c()
651233d2
NC
810 ALIAS:
811 save_BEGINs = 1
a8a597b2 812 CODE:
651233d2
NC
813 if (ix)
814 PL_savebegin = TRUE;
815 else
816 PL_minus_c = TRUE;
059a8bb7 817
a8a597b2
MB
818SV *
819cstring(sv)
820 SV * sv
84556172
NC
821 ALIAS:
822 perlstring = 1
9e380ad4 823 cchar = 2
09e97b95 824 PPCODE:
9e380ad4 825 PUSHs(ix == 2 ? cchar(aTHX_ sv) : cstring(aTHX_ sv, ix));
a8a597b2
MB
826
827void
828threadsv_names()
829 PPCODE:
f5ba1307
NC
830#if PERL_VERSION <= 8
831# ifdef USE_5005THREADS
832 int i;
5d7488b2 833 const STRLEN len = strlen(PL_threadsv_names);
f5ba1307
NC
834
835 EXTEND(sp, len);
836 for (i = 0; i < len; i++)
d3d34884 837 PUSHs(newSVpvn_flags(&PL_threadsv_names[i], 1, SVs_TEMP));
f5ba1307
NC
838# endif
839#endif
a8a597b2 840
257e0650
NC
841#define SVp 0x00000
842#define U32p 0x10000
843#define line_tp 0x20000
844#define OPp 0x30000
845#define PADOFFSETp 0x40000
846#define U8p 0x50000
39e120c1 847#define IVp 0x60000
a9ed1a44 848#define char_pp 0x70000
086f9b42
NC
849
850#define OP_next_ix OPp | offsetof(struct op, op_next)
851#define OP_sibling_ix OPp | offsetof(struct op, op_sibling)
852#define UNOP_first_ix OPp | offsetof(struct unop, op_first)
853#define BINOP_last_ix OPp | offsetof(struct binop, op_last)
854#define LOGOP_other_ix OPp | offsetof(struct logop, op_other)
9b1961be 855#if PERL_VERSION >= 9
086f9b42
NC
856# define PMOP_pmreplstart_ix \
857 OPp | offsetof(struct pmop, op_pmstashstartu.op_pmreplstart)
9b1961be 858#else
086f9b42 859# define PMOP_pmreplstart_ix OPp | offsetof(struct pmop, op_pmreplstart)
9b1961be 860#endif
086f9b42
NC
861#define LOOP_redoop_ix OPp | offsetof(struct loop, op_redoop)
862#define LOOP_nextop_ix OPp | offsetof(struct loop, op_nextop)
863#define LOOP_lastop_ix OPp | offsetof(struct loop, op_lastop)
864
865#define OP_targ_ix PADOFFSETp | offsetof(struct op, op_targ)
866#define OP_flags_ix U8p | offsetof(struct op, op_flags)
867#define OP_private_ix U8p | offsetof(struct op, op_private)
9b1961be 868
a78b89ef
NC
869#define PMOP_pmflags_ix U32p | offsetof(struct pmop, op_pmflags)
870
657e3fc2
NC
871#ifdef USE_ITHREADS
872#define PMOP_pmoffset_ix IVp | offsetof(struct pmop, op_pmoffset)
873#endif
874
ba7298e3
NC
875# Yes, B::SV::sv and B::SV::gv really do end up generating identical code.
876#define SVOP_sv_ix SVp | offsetof(struct svop, op_sv)
877#define SVOP_gv_ix SVp | offsetof(struct svop, op_sv)
878
9488fb36
NC
879#define PADOP_padix_ix PADOFFSETp | offsetof(struct padop, op_padix)
880
39e120c1
NC
881#define COP_seq_ix U32p | offsetof(struct cop, cop_seq)
882#define COP_line_ix line_tp | offsetof(struct cop, cop_line)
883#if PERL_VERSION >= 9
884#define COP_hints_ix U32p | offsetof(struct cop, cop_hints)
885#else
886#define COP_hints_ix U8p | offsetof(struct cop, op_private)
887#endif
888
a9ed1a44
NC
889#ifdef USE_ITHREADS
890#define COP_stashpv_ix char_pp | offsetof(struct cop, cop_stashpv)
891#define COP_file_ix char_pp | offsetof(struct cop, cop_file)
892#else
893#define COP_stash_ix SVp | offsetof(struct cop, cop_stash)
894#define COP_filegv_ix SVp | offsetof(struct cop, cop_filegv)
895#endif
896
a8a597b2
MB
897MODULE = B PACKAGE = B::OP PREFIX = OP_
898
651aa52e
AE
899size_t
900OP_size(o)
901 B::OP o
902 CODE:
903 RETVAL = opsizes[cc_opclass(aTHX_ o)];
904 OUTPUT:
905 RETVAL
906
9b1961be
NC
907# The type checking code in B has always been identical for all OP types,
908# irrespective of whether the action is actually defined on that OP.
909# We should fix this
086f9b42 910void
9b1961be 911next(o)
a8a597b2 912 B::OP o
9b1961be 913 ALIAS:
086f9b42
NC
914 B::OP::next = OP_next_ix
915 B::OP::sibling = OP_sibling_ix
916 B::OP::targ = OP_targ_ix
917 B::OP::flags = OP_flags_ix
918 B::OP::private = OP_private_ix
919 B::UNOP::first = UNOP_first_ix
920 B::BINOP::last = BINOP_last_ix
921 B::LOGOP::other = LOGOP_other_ix
922 B::PMOP::pmreplstart = PMOP_pmreplstart_ix
923 B::LOOP::redoop = LOOP_redoop_ix
924 B::LOOP::nextop = LOOP_nextop_ix
925 B::LOOP::lastop = LOOP_lastop_ix
a78b89ef 926 B::PMOP::pmflags = PMOP_pmflags_ix
ba7298e3
NC
927 B::SVOP::sv = SVOP_sv_ix
928 B::SVOP::gv = SVOP_gv_ix
9488fb36 929 B::PADOP::padix = PADOP_padix_ix
39e120c1
NC
930 B::COP::cop_seq = COP_seq_ix
931 B::COP::line = COP_line_ix
932 B::COP::hints = COP_hints_ix
9b1961be
NC
933 PREINIT:
934 char *ptr;
086f9b42
NC
935 SV *ret;
936 PPCODE:
937 ptr = (ix & 0xFFFF) + (char *)o;
938 switch ((U8)(ix >> 16)) {
939 case (U8)(OPp >> 16):
940 {
941 OP *const o2 = *((OP **)ptr);
942 ret = sv_newmortal();
943 sv_setiv(newSVrv(ret, cc_opclassname(aTHX_ o2)), PTR2IV(o2));
944 break;
945 }
946 case (U8)(PADOFFSETp >> 16):
947 ret = sv_2mortal(newSVuv(*((PADOFFSET*)ptr)));
948 break;
949 case (U8)(U8p >> 16):
950 ret = sv_2mortal(newSVuv(*((U8*)ptr)));
951 break;
a78b89ef
NC
952 case (U8)(U32p >> 16):
953 ret = sv_2mortal(newSVuv(*((U32*)ptr)));
954 break;
ba7298e3
NC
955 case (U8)(SVp >> 16):
956 ret = make_sv_object(aTHX_ NULL, *((SV **)ptr));
957 break;
39e120c1
NC
958 case (U8)(line_tp >> 16):
959 ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
960 break;
657e3fc2
NC
961#ifdef USE_ITHREADS
962 case (U8)(IVp >> 16):
963 ret = sv_2mortal(newSViv(*((IV*)ptr)));
964 break;
a9ed1a44
NC
965 case (U8)(char_pp >> 16):
966 ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
967 break;
657e3fc2 968#endif
086f9b42
NC
969 }
970 ST(0) = ret;
971 XSRETURN(1);
a8a597b2
MB
972
973char *
3f872cb9
GS
974OP_name(o)
975 B::OP o
d2b33dc1
NC
976 ALIAS:
977 desc = 1
3f872cb9 978 CODE:
d2b33dc1 979 RETVAL = (char *)(ix ? PL_op_desc : PL_op_name)[o->op_type];
8063af02
DM
980 OUTPUT:
981 RETVAL
3f872cb9 982
8063af02 983void
a8a597b2
MB
984OP_ppaddr(o)
985 B::OP o
dc333d64
GS
986 PREINIT:
987 int i;
fdbd1d64 988 SV *sv = newSVpvs_flags("PL_ppaddr[OP_", SVs_TEMP);
a8a597b2 989 CODE:
dc333d64 990 sv_catpv(sv, PL_op_name[o->op_type]);
7c436af3 991 for (i=13; (STRLEN)i < SvCUR(sv); ++i)
dc333d64 992 SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]);
6beb30a6 993 sv_catpvs(sv, "]");
dc333d64 994 ST(0) = sv;
a8a597b2 995
7252851f 996#if PERL_VERSION >= 9
dd8be0e4
NC
997# These 3 are all bitfields, so we can't take their addresses.
998UV
999OP_type(o)
2814eb74 1000 B::OP o
dd8be0e4
NC
1001 ALIAS:
1002 opt = 1
1003 spare = 2
1004 CODE:
1005 switch(ix) {
1006 case 1:
1007 RETVAL = o->op_opt;
1008 break;
1009 case 2:
1010 RETVAL = o->op_spare;
1011 break;
1012 default:
1013 RETVAL = o->op_type;
1014 }
1015 OUTPUT:
1016 RETVAL
2814eb74 1017
7252851f
NC
1018#else
1019
dd8be0e4
NC
1020UV
1021OP_type(o)
7252851f 1022 B::OP o
dd8be0e4
NC
1023 ALIAS:
1024 seq = 1
1025 CODE:
1026 switch(ix) {
1027 case 1:
1028 RETVAL = o->op_seq;
1029 break;
1030 default:
1031 RETVAL = o->op_type;
1032 }
1033 OUTPUT:
1034 RETVAL
7252851f
NC
1035
1036#endif
1037
1df34986
AE
1038void
1039OP_oplist(o)
1040 B::OP o
1041 PPCODE:
1042 SP = oplist(aTHX_ o, SP);
1043
a8a597b2
MB
1044MODULE = B PACKAGE = B::LISTOP PREFIX = LISTOP_
1045
c03c2844
SM
1046U32
1047LISTOP_children(o)
1048 B::LISTOP o
1049 OP * kid = NO_INIT
1050 int i = NO_INIT
1051 CODE:
c03c2844
SM
1052 i = 0;
1053 for (kid = o->op_first; kid; kid = kid->op_sibling)
1054 i++;
8063af02
DM
1055 RETVAL = i;
1056 OUTPUT:
016e8ce0 1057 RETVAL
a8a597b2
MB
1058
1059MODULE = B PACKAGE = B::PMOP PREFIX = PMOP_
1060
20e98b0f
NC
1061#if PERL_VERSION <= 8
1062
a8a597b2
MB
1063void
1064PMOP_pmreplroot(o)
1065 B::PMOP o
1066 OP * root = NO_INIT
1067 CODE:
1068 ST(0) = sv_newmortal();
1069 root = o->op_pmreplroot;
1070 /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */
1071 if (o->op_type == OP_PUSHRE) {
20e98b0f 1072# ifdef USE_ITHREADS
9d2bbe64 1073 sv_setiv(ST(0), INT2PTR(PADOFFSET,root) );
20e98b0f 1074# else
a8a597b2
MB
1075 sv_setiv(newSVrv(ST(0), root ?
1076 svclassnames[SvTYPE((SV*)root)] : "B::SV"),
56431972 1077 PTR2IV(root));
20e98b0f 1078# endif
a8a597b2
MB
1079 }
1080 else {
56431972 1081 sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root));
a8a597b2
MB
1082 }
1083
20e98b0f
NC
1084#else
1085
1086void
1087PMOP_pmreplroot(o)
1088 B::PMOP o
1089 CODE:
1090 ST(0) = sv_newmortal();
1091 if (o->op_type == OP_PUSHRE) {
1092# ifdef USE_ITHREADS
1093 sv_setiv(ST(0), o->op_pmreplrootu.op_pmtargetoff);
1094# else
1095 GV *const target = o->op_pmreplrootu.op_pmtargetgv;
1096 sv_setiv(newSVrv(ST(0), target ?
1097 svclassnames[SvTYPE((SV*)target)] : "B::SV"),
1098 PTR2IV(target));
1099# endif
1100 }
1101 else {
1102 OP *const root = o->op_pmreplrootu.op_pmreplroot;
1103 sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)),
1104 PTR2IV(root));
1105 }
1106
1107#endif
1108
9d2bbe64 1109#ifdef USE_ITHREADS
016e8ce0 1110#define PMOP_pmstashpv(o) PmopSTASHPV(o);
9d2bbe64 1111
651aa52e
AE
1112char*
1113PMOP_pmstashpv(o)
1114 B::PMOP o
1115
1116#else
016e8ce0 1117#define PMOP_pmstash(o) PmopSTASH(o);
651aa52e
AE
1118
1119B::HV
1120PMOP_pmstash(o)
1121 B::PMOP o
1122
9d2bbe64
MB
1123#endif
1124
7c1f70cb 1125#if PERL_VERSION < 9
5b02c205
NC
1126#define PMOP_pmnext(o) o->op_pmnext
1127
1128B::PMOP
1129PMOP_pmnext(o)
1130 B::PMOP o
7c1f70cb
NC
1131
1132U32
1133PMOP_pmpermflags(o)
1134 B::PMOP o
1135
1136U8
1137PMOP_pmdynflags(o)
1138 B::PMOP o
1139
1140#endif
1141
a8a597b2
MB
1142void
1143PMOP_precomp(o)
1144 B::PMOP o
021d294f
NC
1145 PREINIT:
1146 dXSI32;
1147 REGEXP *rx;
a8a597b2 1148 CODE:
aaa362c4 1149 rx = PM_GETRE(o);
c737faaf 1150 ST(0) = sv_newmortal();
021d294f
NC
1151 if (rx) {
1152#if PERL_VERSION >= 9
1153 if (ix) {
1154 sv_setuv(ST(0), RX_EXTFLAGS(rx));
1155 } else
1156#endif
1157 {
1158 sv_setpvn(ST(0), RX_PRECOMP(rx), RX_PRELEN(rx));
1159 }
1160 }
c737faaf 1161
021d294f
NC
1162BOOT:
1163{
1164 CV *cv;
1165#ifdef USE_ITHREADS
1166 cv = newXS("B::PMOP::pmoffset", XS_B__OP_next, __FILE__);
1167 XSANY.any_i32 = PMOP_pmoffset_ix;
a9ed1a44
NC
1168 cv = newXS("B::COP::stashpv", XS_B__OP_next, __FILE__);
1169 XSANY.any_i32 = COP_stashpv_ix;
1170 cv = newXS("B::COP::file", XS_B__OP_next, __FILE__);
1171 XSANY.any_i32 = COP_file_ix;
1172#else
1173 cv = newXS("B::COP::stash", XS_B__OP_next, __FILE__);
1174 XSANY.any_i32 = COP_stash_ix;
1175 cv = newXS("B::COP::filegv", XS_B__OP_next, __FILE__);
1176 XSANY.any_i32 = COP_filegv_ix;
7c1f70cb 1177#endif
021d294f
NC
1178#if PERL_VERSION >= 9
1179 cv = newXS("B::PMOP::reflags", XS_B__PMOP_precomp, __FILE__);
1180 XSANY.any_i32 = 1;
1181#endif
1182}
1183
c518d492 1184MODULE = B PACKAGE = B::PADOP
7934575e 1185
7934575e 1186B::SV
c518d492 1187sv(o)
7934575e 1188 B::PADOP o
c518d492
NC
1189 ALIAS:
1190 gv = 1
1191 CODE:
1192 /* It happens that the output typemaps for B::SV and B::GV are
1193 identical. The "smarts" are in make_sv_object(), which determines
1194 which class to use based on SvTYPE(), rather than anything baked in
1195 at compile time. */
1196 if (o->op_padix) {
1197 RETVAL = PAD_SVl(o->op_padix);
1198 if (ix && SvTYPE(RETVAL) != SVt_PVGV)
1199 RETVAL = NULL;
1200 } else {
1201 RETVAL = NULL;
1202 }
1203 OUTPUT:
1204 RETVAL
a8a597b2
MB
1205
1206MODULE = B PACKAGE = B::PVOP PREFIX = PVOP_
1207
1208void
1209PVOP_pv(o)
1210 B::PVOP o
1211 CODE:
1212 /*
bec89253 1213 * OP_TRANS uses op_pv to point to a table of 256 or >=258 shorts
a8a597b2
MB
1214 * whereas other PVOPs point to a null terminated string.
1215 */
bb16bae8 1216 if ((o->op_type == OP_TRANS || o->op_type == OP_TRANSR) &&
bec89253
RH
1217 (o->op_private & OPpTRANS_COMPLEMENT) &&
1218 !(o->op_private & OPpTRANS_DELETE))
1219 {
5d7488b2
AL
1220 const short* const tbl = (short*)o->op_pv;
1221 const short entries = 257 + tbl[256];
d3d34884 1222 ST(0) = newSVpvn_flags(o->op_pv, entries * sizeof(short), SVs_TEMP);
bec89253 1223 }
bb16bae8 1224 else if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
d3d34884 1225 ST(0) = newSVpvn_flags(o->op_pv, 256 * sizeof(short), SVs_TEMP);
bec89253
RH
1226 }
1227 else
d3d34884 1228 ST(0) = newSVpvn_flags(o->op_pv, strlen(o->op_pv), SVs_TEMP);
a8a597b2 1229
4b65a919 1230#define COP_label(o) CopLABEL(o)
fc15ae8f 1231#define COP_arybase(o) CopARYBASE_get(o)
a8a597b2
MB
1232
1233MODULE = B PACKAGE = B::COP PREFIX = COP_
1234
d5b8ed54
NC
1235const char *
1236COP_label(o)
1237 B::COP o
1238
a9ed1a44
NC
1239# Both pairs of accessors are provided for both ithreads and not, but for each,
1240# one pair is direct structure access, and 1 pair "faked up" with a more complex
1241# macro. We implement the direct structure access pair using the common code
1242# above (B::OP::next)
1243
1244#ifdef USE_ITHREADS
1245#define COP_stash(o) CopSTASH(o)
1246#define COP_filegv(o) CopFILEGV(o)
11faa288 1247
a8a597b2
MB
1248B::HV
1249COP_stash(o)
1250 B::COP o
1251
a9ed1a44
NC
1252B::GV
1253COP_filegv(o)
1254 B::COP o
1255
1256#else
1257#define COP_stashpv(o) CopSTASHPV(o)
1258#define COP_file(o) CopFILE(o)
1259
1260char *
1261COP_stashpv(o)
1262 B::COP o
1263
57843af0
GS
1264char *
1265COP_file(o)
a8a597b2
MB
1266 B::COP o
1267
a9ed1a44 1268#endif
1df34986 1269
a8a597b2
MB
1270I32
1271COP_arybase(o)
1272 B::COP o
1273
5c3c3f81 1274void
b295d113
TH
1275COP_warnings(o)
1276 B::COP o
5c3c3f81 1277 PPCODE:
13d356f3 1278#if PERL_VERSION >= 9
9496d2e5 1279 ST(0) = make_warnings_object(aTHX_ o->cop_warnings);
13d356f3
NC
1280#else
1281 ST(0) = make_sv_object(aTHX_ NULL, o->cop_warnings);
1282#endif
5c3c3f81 1283 XSRETURN(1);
b295d113 1284
670f1322 1285void
6e6a1aef
RGS
1286COP_io(o)
1287 B::COP o
11bcd5da 1288 PPCODE:
13d356f3 1289#if PERL_VERSION >= 9
9496d2e5 1290 ST(0) = make_cop_io_object(aTHX_ o);
13d356f3
NC
1291#else
1292 ST(0) = make_sv_object(aTHX_ NULL, o->cop_io);
1293#endif
11bcd5da 1294 XSRETURN(1);
6e6a1aef 1295
13d356f3
NC
1296#if PERL_VERSION >= 9
1297
fd9f6265
JJ
1298B::RHE
1299COP_hints_hash(o)
1300 B::COP o
1301 CODE:
20439bc7 1302 RETVAL = CopHINTHASH_get(o);
fd9f6265
JJ
1303 OUTPUT:
1304 RETVAL
1305
e412117e
NC
1306#endif
1307
651aa52e
AE
1308MODULE = B PACKAGE = B::SV
1309
de64752d
NC
1310#define MAGICAL_FLAG_BITS (SVs_GMG|SVs_SMG|SVs_RMG)
1311
651aa52e 1312U32
de64752d 1313REFCNT(sv)
651aa52e 1314 B::SV sv
de64752d
NC
1315 ALIAS:
1316 FLAGS = 0xFFFFFFFF
1317 SvTYPE = SVTYPEMASK
1318 POK = SVf_POK
1319 ROK = SVf_ROK
1320 MAGICAL = MAGICAL_FLAG_BITS
1321 CODE:
1322 RETVAL = ix ? (SvFLAGS(sv) & (U32)ix) : SvREFCNT(sv);
1323 OUTPUT:
1324 RETVAL
651aa52e 1325
9efba5c8 1326void
429a5ce7
SM
1327object_2svref(sv)
1328 B::SV sv
9efba5c8
NC
1329 PPCODE:
1330 ST(0) = sv_2mortal(newRV(sv));
1331 XSRETURN(1);
1332
a8a597b2
MB
1333MODULE = B PACKAGE = B::IV PREFIX = Sv
1334
1335IV
1336SvIV(sv)
1337 B::IV sv
1338
e4da9d6a 1339MODULE = B PACKAGE = B::IV
a8a597b2 1340
e4da9d6a
NC
1341#define sv_SVp 0x00000
1342#define sv_IVp 0x10000
1343#define sv_UVp 0x20000
1344#define sv_STRLENp 0x30000
1345#define sv_U32p 0x40000
1346#define sv_U8p 0x50000
1347#define sv_char_pp 0x60000
1348#define sv_NVp 0x70000
6782c6e0 1349#define sv_char_p 0x80000
3da43c35 1350#define sv_SSize_tp 0x90000
ffc5d9fc
NC
1351#define sv_I32p 0xA0000
1352#define sv_U16p 0xB0000
e4da9d6a
NC
1353
1354#define IV_ivx_ix sv_IVp | offsetof(struct xpviv, xiv_iv)
1355#define IV_uvx_ix sv_UVp | offsetof(struct xpvuv, xuv_uv)
1356#define NV_nvx_ix sv_NVp | offsetof(struct xpvnv, xnv_u.xnv_nv)
1357
1358#if PERL_VERSION >= 10
1359#define NV_cop_seq_range_low_ix \
1360 sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
1361#define NV_cop_seq_range_high_ix \
1362 sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
1363#define NV_parent_pad_index_ix \
1364 sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
1365#define NV_parent_fakelex_flags_ix \
1366 sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
1367#else
1368#define NV_cop_seq_range_low_ix \
1369 sv_NVp | offsetof(struct xpvnv, xnv_nv)
1370#define NV_cop_seq_range_high_ix \
1371 sv_UVp | offsetof(struct xpvnv, xuv_uv)
1372#define NV_parent_pad_index_ix \
1373 sv_NVp | offsetof(struct xpvnv, xnv_nv)
1374#define NV_parent_fakelex_flags_ix \
1375 sv_UVp | offsetof(struct xpvnv, xuv_uv)
1376#endif
0ca04487 1377
6782c6e0
NC
1378#define PV_cur_ix sv_STRLENp | offsetof(struct xpv, xpv_cur)
1379#define PV_len_ix sv_STRLENp | offsetof(struct xpv, xpv_len)
1380
1381#define PVMG_stash_ix sv_SVp | offsetof(struct xpvmg, xmg_stash)
1382
91a71e08
NC
1383#if PERL_VERSION >= 10
1384#define PVBM_useful_ix sv_I32p | offsetof(struct xpvgv, xiv_u.xivu_i32)
1385#define PVBM_previous_ix sv_U32p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_previous)
1386#define PVBM_rare_ix sv_U8p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_rare)
1387#else
1388#define PVBM_useful_ix sv_I32p | offsetof(struct xpvbm, xbm_useful)
1389#define PVBM_previous_ix sv_U16p | offsetof(struct xpvbm, xbm_previous)
1390#define PVBM_rare_ix sv_U8p | offsetof(struct xpvbm, xbm_rare)
1391#endif
1392
6782c6e0
NC
1393#define PVLV_targoff_ix sv_U32p | offsetof(struct xpvlv, xlv_targoff)
1394#define PVLV_targlen_ix sv_U32p | offsetof(struct xpvlv, xlv_targlen)
1395#define PVLV_targ_ix sv_SVp | offsetof(struct xpvlv, xlv_targ)
1396#define PVLV_type_ix sv_char_p | offsetof(struct xpvlv, xlv_type)
1397
f1f19364
NC
1398#if PERL_VERSION >= 10
1399#define PVGV_stash_ix sv_SVp | offsetof(struct xpvgv, xnv_u.xgv_stash)
1400#define PVGV_flags_ix sv_STRLENp | offsetof(struct xpvgv, xpv_cur)
55440d31 1401#define PVIO_lines_ix sv_IVp | offsetof(struct xpvio, xiv_iv)
f1f19364
NC
1402#else
1403#define PVGV_stash_ix sv_SVp | offsetof(struct xpvgv, xgv_stash)
1404#define PVGV_flags_ix sv_U8p | offsetof(struct xpvgv, xgv_flags)
55440d31 1405#define PVIO_lines_ix sv_IVp | offsetof(struct xpvio, xio_lines)
f1f19364
NC
1406#endif
1407
55440d31
NC
1408#define PVIO_page_ix sv_IVp | offsetof(struct xpvio, xio_page)
1409#define PVIO_page_len_ix sv_IVp | offsetof(struct xpvio, xio_page_len)
1410#define PVIO_lines_left_ix sv_IVp | offsetof(struct xpvio, xio_lines_left)
1411#define PVIO_top_name_ix sv_char_pp | offsetof(struct xpvio, xio_top_name)
1412#define PVIO_top_gv_ix sv_SVp | offsetof(struct xpvio, xio_top_gv)
1413#define PVIO_fmt_name_ix sv_char_pp | offsetof(struct xpvio, xio_fmt_name)
1414#define PVIO_fmt_gv_ix sv_SVp | offsetof(struct xpvio, xio_fmt_gv)
1415#define PVIO_bottom_name_ix sv_char_pp | offsetof(struct xpvio, xio_bottom_name)
1416#define PVIO_bottom_gv_ix sv_SVp | offsetof(struct xpvio, xio_bottom_gv)
1417#define PVIO_type_ix sv_char_p | offsetof(struct xpvio, xio_type)
1418#define PVIO_flags_ix sv_U8p | offsetof(struct xpvio, xio_flags)
1419
3da43c35
NC
1420#define PVAV_max_ix sv_SSize_tp | offsetof(struct xpvav, xav_max)
1421
1422#define PVFM_lines_ix sv_IVp | offsetof(struct xpvfm, xfm_lines)
1423
ffc5d9fc
NC
1424#define PVCV_stash_ix sv_SVp | offsetof(struct xpvcv, xcv_stash)
1425#define PVCV_gv_ix sv_SVp | offsetof(struct xpvcv, xcv_gv)
1426#define PVCV_file_ix sv_char_pp | offsetof(struct xpvcv, xcv_file)
1427#define PVCV_depth_ix sv_I32p | offsetof(struct xpvcv, xcv_depth)
1428#define PVCV_padlist_ix sv_SVp | offsetof(struct xpvcv, xcv_padlist)
1429#define PVCV_outside_ix sv_SVp | offsetof(struct xpvcv, xcv_outside)
1430#define PVCV_outside_seq_ix sv_U32p | offsetof(struct xpvcv, xcv_outside_seq)
1431#define PVCV_flags_ix sv_U16p | offsetof(struct xpvcv, xcv_flags)
1432
d65a2b0a
NC
1433#define PVHV_max_ix sv_STRLENp | offsetof(struct xpvhv, xhv_max)
1434
1435#if PERL_VERSION > 12
1436#define PVHV_keys_ix sv_STRLENp | offsetof(struct xpvhv, xhv_keys)
1437#else
1438#define PVHV_keys_ix sv_IVp | offsetof(struct xpvhv, xhv_keys)
1439#endif
1440
e4da9d6a
NC
1441# The type checking code in B has always been identical for all SV types,
1442# irrespective of whether the action is actually defined on that SV.
1443# We should fix this
1444void
1445IVX(sv)
1446 B::SV sv
1447 ALIAS:
1448 B::IV::IVX = IV_ivx_ix
1449 B::IV::UVX = IV_uvx_ix
1450 B::NV::NVX = NV_nvx_ix
1451 B::NV::COP_SEQ_RANGE_LOW = NV_cop_seq_range_low_ix
1452 B::NV::COP_SEQ_RANGE_HIGH = NV_cop_seq_range_high_ix
1453 B::NV::PARENT_PAD_INDEX = NV_parent_pad_index_ix
1454 B::NV::PARENT_FAKELEX_FLAGS = NV_parent_fakelex_flags_ix
6782c6e0
NC
1455 B::PV::CUR = PV_cur_ix
1456 B::PV::LEN = PV_len_ix
1457 B::PVMG::SvSTASH = PVMG_stash_ix
1458 B::PVLV::TARGOFF = PVLV_targoff_ix
1459 B::PVLV::TARGLEN = PVLV_targlen_ix
1460 B::PVLV::TARG = PVLV_targ_ix
1461 B::PVLV::TYPE = PVLV_type_ix
f1f19364
NC
1462 B::GV::STASH = PVGV_stash_ix
1463 B::GV::GvFLAGS = PVGV_flags_ix
91a71e08
NC
1464 B::BM::USEFUL = PVBM_useful_ix
1465 B::BM::PREVIOUS = PVBM_previous_ix
1466 B::BM::RARE = PVBM_rare_ix
55440d31
NC
1467 B::IO::LINES = PVIO_lines_ix
1468 B::IO::PAGE = PVIO_page_ix
1469 B::IO::PAGE_LEN = PVIO_page_len_ix
1470 B::IO::LINES_LEFT = PVIO_lines_left_ix
1471 B::IO::TOP_NAME = PVIO_top_name_ix
1472 B::IO::TOP_GV = PVIO_top_gv_ix
1473 B::IO::FMT_NAME = PVIO_fmt_name_ix
1474 B::IO::FMT_GV = PVIO_fmt_gv_ix
1475 B::IO::BOTTOM_NAME = PVIO_bottom_name_ix
1476 B::IO::BOTTOM_GV = PVIO_bottom_gv_ix
1477 B::IO::IoTYPE = PVIO_type_ix
1478 B::IO::IoFLAGS = PVIO_flags_ix
3da43c35
NC
1479 B::AV::MAX = PVAV_max_ix
1480 B::FM::LINES = PVFM_lines_ix
ffc5d9fc
NC
1481 B::CV::STASH = PVCV_stash_ix
1482 B::CV::GV = PVCV_gv_ix
1483 B::CV::FILE = PVCV_file_ix
1484 B::CV::DEPTH = PVCV_depth_ix
1485 B::CV::PADLIST = PVCV_padlist_ix
1486 B::CV::OUTSIDE = PVCV_outside_ix
1487 B::CV::OUTSIDE_SEQ = PVCV_outside_seq_ix
1488 B::CV::CvFLAGS = PVCV_flags_ix
d65a2b0a
NC
1489 B::HV::MAX = PVHV_max_ix
1490 B::HV::KEYS = PVHV_keys_ix
e4da9d6a
NC
1491 PREINIT:
1492 char *ptr;
1493 SV *ret;
1494 PPCODE:
1495 ptr = (ix & 0xFFFF) + (char *)SvANY(sv);
1496 switch ((U8)(ix >> 16)) {
1497 case (U8)(sv_SVp >> 16):
1498 ret = make_sv_object(aTHX_ NULL, *((SV **)ptr));
1499 break;
1500 case (U8)(sv_IVp >> 16):
1501 ret = sv_2mortal(newSViv(*((IV *)ptr)));
1502 break;
1503 case (U8)(sv_UVp >> 16):
1504 ret = sv_2mortal(newSVuv(*((UV *)ptr)));
1505 break;
6782c6e0
NC
1506 case (U8)(sv_STRLENp >> 16):
1507 ret = sv_2mortal(newSVuv(*((STRLEN *)ptr)));
1508 break;
e4da9d6a
NC
1509 case (U8)(sv_U32p >> 16):
1510 ret = sv_2mortal(newSVuv(*((U32 *)ptr)));
1511 break;
1512 case (U8)(sv_U8p >> 16):
1513 ret = sv_2mortal(newSVuv(*((U8 *)ptr)));
1514 break;
1515 case (U8)(sv_char_pp >> 16):
1516 ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
1517 break;
1518 case (U8)(sv_NVp >> 16):
1519 ret = sv_2mortal(newSVnv(*((NV *)ptr)));
1520 break;
6782c6e0
NC
1521 case (U8)(sv_char_p >> 16):
1522 ret = newSVpvn_flags((char *)ptr, 1, SVs_TEMP);
1523 break;
3da43c35
NC
1524 case (U8)(sv_SSize_tp >> 16):
1525 ret = sv_2mortal(newSViv(*((SSize_t *)ptr)));
1526 break;
ffc5d9fc
NC
1527 case (U8)(sv_I32p >> 16):
1528 ret = sv_2mortal(newSVuv(*((I32 *)ptr)));
1529 break;
1530 case (U8)(sv_U16p >> 16):
1531 ret = sv_2mortal(newSVuv(*((U16 *)ptr)));
1532 break;
e4da9d6a
NC
1533 }
1534 ST(0) = ret;
1535 XSRETURN(1);
a8a597b2 1536
a8a597b2
MB
1537void
1538packiv(sv)
1539 B::IV sv
6829f5e2
NC
1540 ALIAS:
1541 needs64bits = 1
a8a597b2 1542 CODE:
6829f5e2
NC
1543 if (ix) {
1544 ST(0) = boolSV((I32)SvIVX(sv) != SvIVX(sv));
1545 } else if (sizeof(IV) == 8) {
a8a597b2 1546 U32 wp[2];
5d7488b2 1547 const IV iv = SvIVX(sv);
a8a597b2
MB
1548 /*
1549 * The following way of spelling 32 is to stop compilers on
1550 * 32-bit architectures from moaning about the shift count
1551 * being >= the width of the type. Such architectures don't
1552 * reach this code anyway (unless sizeof(IV) > 8 but then
1553 * everything else breaks too so I'm not fussed at the moment).
1554 */
42718184
RB
1555#ifdef UV_IS_QUAD
1556 wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1557#else
1558 wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1559#endif
a8a597b2 1560 wp[1] = htonl(iv & 0xffffffff);
d3d34884 1561 ST(0) = newSVpvn_flags((char *)wp, 8, SVs_TEMP);
a8a597b2
MB
1562 } else {
1563 U32 w = htonl((U32)SvIVX(sv));
d3d34884 1564 ST(0) = newSVpvn_flags((char *)&w, 4, SVs_TEMP);
a8a597b2
MB
1565 }
1566
1567MODULE = B PACKAGE = B::NV PREFIX = Sv
1568
76ef7183 1569NV
a8a597b2
MB
1570SvNV(sv)
1571 B::NV sv
1572
4df7f6af
NC
1573#if PERL_VERSION < 11
1574
a8a597b2
MB
1575MODULE = B PACKAGE = B::RV PREFIX = Sv
1576
1577B::SV
1578SvRV(sv)
1579 B::RV sv
1580
89c6bc13
NC
1581#else
1582
1583MODULE = B PACKAGE = B::REGEXP
1584
1585IV
1586REGEX(sv)
1587 B::REGEXP sv
1588 CODE:
1589 /* FIXME - can we code this method more efficiently? */
1590 RETVAL = PTR2IV(sv);
1591 OUTPUT:
1592 RETVAL
1593
154b8842 1594void
89c6bc13
NC
1595precomp(sv)
1596 B::REGEXP sv
154b8842
NC
1597 PPCODE:
1598 PUSHs(newSVpvn_flags(RX_PRECOMP(sv), RX_PRELEN(sv), SVs_TEMP));
89c6bc13 1599
4df7f6af
NC
1600#endif
1601
a8a597b2
MB
1602MODULE = B PACKAGE = B::PV PREFIX = Sv
1603
0b40bd6d
RH
1604char*
1605SvPVX(sv)
1606 B::PV sv
1607
b326da91
MB
1608B::SV
1609SvRV(sv)
1610 B::PV sv
1611 CODE:
1612 if( SvROK(sv) ) {
1613 RETVAL = SvRV(sv);
1614 }
1615 else {
1616 croak( "argument is not SvROK" );
1617 }
1618 OUTPUT:
1619 RETVAL
1620
a8a597b2
MB
1621void
1622SvPV(sv)
1623 B::PV sv
1624 CODE:
c0b20461 1625 if( SvPOK(sv) ) {
fdbd1d64
NC
1626 STRLEN len = SvCUR(sv);
1627 const char *p = SvPVX_const(sv);
0eaead75
NC
1628#if PERL_VERSION < 10
1629 /* Before 5.10 (well 931b58fb28fa5ca7), PAD_COMPNAME_GEN was stored
1630 in SvCUR(), which meant we had to attempt this special casing
1631 to avoid tripping up over variable names in the pads. */
fdbd1d64 1632 if((SvLEN(sv) && len >= SvLEN(sv))) {
b55685ae
NC
1633 /* It claims to be longer than the space allocated for it -
1634 presuambly it's a variable name in the pad */
fdbd1d64 1635 len = strlen(p);
b55685ae 1636 }
0eaead75 1637#endif
fdbd1d64 1638 ST(0) = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
b326da91
MB
1639 }
1640 else {
1641 /* XXX for backward compatibility, but should fail */
1642 /* croak( "argument is not SvPOK" ); */
fdbd1d64 1643 ST(0) = sv_newmortal();
b326da91 1644 }
a8a597b2 1645
5a44e503
NC
1646# This used to read 257. I think that that was buggy - should have been 258.
1647# (The "\0", the flags byte, and 256 for the table. Not that anything
1648# anywhere calls this method. NWC.
651aa52e
AE
1649void
1650SvPVBM(sv)
1651 B::PV sv
1652 CODE:
fdbd1d64
NC
1653 ST(0) = newSVpvn_flags(SvPVX_const(sv),
1654 SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0),
1655 SVs_TEMP);
651aa52e 1656
a8a597b2
MB
1657MODULE = B PACKAGE = B::PVMG PREFIX = Sv
1658
1659void
1660SvMAGIC(sv)
1661 B::PVMG sv
1662 MAGIC * mg = NO_INIT
1663 PPCODE:
1664 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
9496d2e5 1665 XPUSHs(make_mg_object(aTHX_ mg));
a8a597b2 1666
b2adfa9b 1667MODULE = B PACKAGE = B::MAGIC
a8a597b2
MB
1668
1669void
b2adfa9b 1670MOREMAGIC(mg)
a8a597b2 1671 B::MAGIC mg
b2adfa9b
NC
1672 ALIAS:
1673 PRIVATE = 1
1674 TYPE = 2
1675 FLAGS = 3
1676 LEN = 4
1677 OBJ = 5
1678 PTR = 6
1679 REGEX = 7
1680 precomp = 8
1681 PPCODE:
1682 switch (ix) {
1683 case 0:
1684 XPUSHs(mg->mg_moremagic ? make_mg_object(aTHX_ mg->mg_moremagic)
1685 : &PL_sv_undef);
1686 break;
1687 case 1:
1688 mPUSHu(mg->mg_private);
1689 break;
1690 case 2:
1691 PUSHs(newSVpvn_flags(&(mg->mg_type), 1, SVs_TEMP));
1692 break;
1693 case 3:
1694 mPUSHu(mg->mg_flags);
1695 break;
1696 case 4:
1697 mPUSHi(mg->mg_len);
1698 break;
1699 case 5:
1700 PUSHs(make_sv_object(aTHX_ NULL, mg->mg_obj));
1701 break;
1702 case 6:
1703 if (mg->mg_ptr) {
1704 if (mg->mg_len >= 0) {
1705 PUSHs(newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP));
651aa52e 1706 } else if (mg->mg_len == HEf_SVKEY) {
b2adfa9b 1707 PUSHs(make_sv_object(aTHX_ NULL, (SV*)mg->mg_ptr));
fdbd1d64 1708 } else
b2adfa9b
NC
1709 PUSHs(sv_newmortal());
1710 } else
1711 PUSHs(sv_newmortal());
1712 break;
1713 case 7:
1714 if(mg->mg_type == PERL_MAGIC_qr) {
1715 mPUSHi(PTR2IV(mg->mg_obj));
1716 } else {
1717 croak("REGEX is only meaningful on r-magic");
1718 }
1719 break;
1720 case 8:
1721 if (mg->mg_type == PERL_MAGIC_qr) {
1722 REGEXP *rx = (REGEXP *)mg->mg_obj;
227aaa42
NC
1723 PUSHs(newSVpvn_flags(rx ? RX_PRECOMP(rx) : NULL,
1724 rx ? RX_PRELEN(rx) : 0, SVs_TEMP));
b2adfa9b
NC
1725 } else {
1726 croak( "precomp is only meaningful on r-magic" );
1727 }
1728 break;
1729 }
a8a597b2 1730
a8a597b2
MB
1731MODULE = B PACKAGE = B::BM PREFIX = Bm
1732
a8a597b2
MB
1733void
1734BmTABLE(sv)
1735 B::BM sv
1736 STRLEN len = NO_INIT
1737 char * str = NO_INIT
1738 CODE:
1739 str = SvPV(sv, len);
1740 /* Boyer-Moore table is just after string and its safety-margin \0 */
d3d34884 1741 ST(0) = newSVpvn_flags(str + len + PERL_FBM_TABLE_OFFSET, 256, SVs_TEMP);
a8a597b2
MB
1742
1743MODULE = B PACKAGE = B::GV PREFIX = Gv
1744
1745void
1746GvNAME(gv)
1747 B::GV gv
cbf9c13f
NC
1748 ALIAS:
1749 FILE = 1
435e8dd0 1750 B::HV::NAME = 2
a8a597b2 1751 CODE:
6beb30a6 1752#if PERL_VERSION >= 10
435e8dd0
NC
1753 ST(0) = sv_2mortal(newSVhek(!ix ? GvNAME_HEK(gv)
1754 : (ix == 1 ? GvFILE_HEK(gv)
1755 : HvNAME_HEK((HV *)gv))));
6beb30a6 1756#else
435e8dd0
NC
1757 ST(0) = !ix ? newSVpvn_flags(GvNAME(gv), GvNAMELEN(gv), SVs_TEMP)
1758 : sv_2mortal(newSVpv(ix == 1 ? GvFILE(gv) : HvNAME((HV *)gv), 0))
6beb30a6 1759#endif
a8a597b2 1760
87d7fd28
GS
1761bool
1762is_empty(gv)
1763 B::GV gv
711fbbf0
NC
1764 ALIAS:
1765 isGV_with_GP = 1
87d7fd28 1766 CODE:
711fbbf0 1767 if (ix) {
50786ba8 1768#if PERL_VERSION >= 9
711fbbf0 1769 RETVAL = isGV_with_GP(gv) ? TRUE : FALSE;
50786ba8 1770#else
711fbbf0 1771 RETVAL = TRUE; /* In 5.8 and earlier they all are. */
50786ba8 1772#endif
711fbbf0
NC
1773 } else {
1774 RETVAL = GvGP(gv) == Null(GP*);
1775 }
50786ba8 1776 OUTPUT:
711fbbf0 1777 RETVAL
50786ba8 1778
651aa52e
AE
1779void*
1780GvGP(gv)
1781 B::GV gv
1782
257e0650
NC
1783#define GP_sv_ix SVp | offsetof(struct gp, gp_sv)
1784#define GP_io_ix SVp | offsetof(struct gp, gp_io)
1785#define GP_cv_ix SVp | offsetof(struct gp, gp_cv)
1786#define GP_cvgen_ix U32p | offsetof(struct gp, gp_cvgen)
1787#define GP_refcnt_ix U32p | offsetof(struct gp, gp_refcnt)
1788#define GP_hv_ix SVp | offsetof(struct gp, gp_hv)
1789#define GP_av_ix SVp | offsetof(struct gp, gp_av)
1790#define GP_form_ix SVp | offsetof(struct gp, gp_form)
1791#define GP_egv_ix SVp | offsetof(struct gp, gp_egv)
1792#define GP_line_ix line_tp | offsetof(struct gp, gp_line)
a8a597b2 1793
257e0650
NC
1794void
1795SV(gv)
a8a597b2 1796 B::GV gv
257e0650
NC
1797 ALIAS:
1798 SV = GP_sv_ix
1799 IO = GP_io_ix
1800 CV = GP_cv_ix
1801 CVGEN = GP_cvgen_ix
1802 GvREFCNT = GP_refcnt_ix
1803 HV = GP_hv_ix
1804 AV = GP_av_ix
1805 FORM = GP_form_ix
1806 EGV = GP_egv_ix
1807 LINE = GP_line_ix
1808 PREINIT:
1809 GP *gp;
1810 char *ptr;
1811 SV *ret;
1812 PPCODE:
1813 gp = GvGP(gv);
1814 if (!gp) {
1815 const GV *const gv = CvGV(cv);
46c3f339 1816 Perl_croak(aTHX_ "NULL gp in B::GV::%s", gv ? GvNAME(gv) : "???");
257e0650
NC
1817 }
1818 ptr = (ix & 0xFFFF) + (char *)gp;
1819 switch ((U8)(ix >> 16)) {
1820 case (U8)(SVp >> 16):
1821 ret = make_sv_object(aTHX_ NULL, *((SV **)ptr));
1822 break;
1823 case (U8)(U32p >> 16):
1824 ret = sv_2mortal(newSVuv(*((U32*)ptr)));
1825 break;
1826 case (U8)(line_tp >> 16):
1827 ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
1828 break;
1829 }
1830 ST(0) = ret;
1831 XSRETURN(1);
a8a597b2
MB
1832
1833B::GV
1834GvFILEGV(gv)
1835 B::GV gv
1836
a8a597b2
MB
1837MODULE = B PACKAGE = B::IO PREFIX = Io
1838
04071355
NC
1839#if PERL_VERSION <= 8
1840
a8a597b2
MB
1841short
1842IoSUBPROCESS(io)
1843 B::IO io
1844
04071355
NC
1845#endif
1846
b326da91
MB
1847bool
1848IsSTD(io,name)
1849 B::IO io
5d7488b2 1850 const char* name
b326da91
MB
1851 PREINIT:
1852 PerlIO* handle = 0;
1853 CODE:
1854 if( strEQ( name, "stdin" ) ) {
1855 handle = PerlIO_stdin();
1856 }
1857 else if( strEQ( name, "stdout" ) ) {
1858 handle = PerlIO_stdout();
1859 }
1860 else if( strEQ( name, "stderr" ) ) {
1861 handle = PerlIO_stderr();
1862 }
1863 else {
1864 croak( "Invalid value '%s'", name );
1865 }
1866 RETVAL = handle == IoIFP(io);
1867 OUTPUT:
1868 RETVAL
1869
a8a597b2
MB
1870MODULE = B PACKAGE = B::AV PREFIX = Av
1871
1872SSize_t
1873AvFILL(av)
1874 B::AV av
1875
a8a597b2
MB
1876void
1877AvARRAY(av)
1878 B::AV av
1879 PPCODE:
1880 if (AvFILL(av) >= 0) {
1881 SV **svp = AvARRAY(av);
1882 I32 i;
1883 for (i = 0; i <= AvFILL(av); i++)
9496d2e5 1884 XPUSHs(make_sv_object(aTHX_ NULL, svp[i]));
a8a597b2
MB
1885 }
1886
429a5ce7
SM
1887void
1888AvARRAYelt(av, idx)
1889 B::AV av
1890 int idx
1891 PPCODE:
1892 if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
9496d2e5 1893 XPUSHs(make_sv_object(aTHX_ NULL, (AvARRAY(av)[idx])));
429a5ce7 1894 else
9496d2e5 1895 XPUSHs(make_sv_object(aTHX_ NULL, NULL));
429a5ce7 1896
edcc7c74
NC
1897#if PERL_VERSION < 9
1898
5b02c205
NC
1899#define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1900
1901IV
1902AvOFF(av)
1903 B::AV av
1904
edcc7c74
NC
1905MODULE = B PACKAGE = B::AV
1906
1907U8
1908AvFLAGS(av)
1909 B::AV av
1910
1911#endif
1912
a8a597b2
MB
1913MODULE = B PACKAGE = B::CV PREFIX = Cv
1914
651aa52e
AE
1915U32
1916CvCONST(cv)
1917 B::CV cv
1918
a8a597b2
MB
1919B::OP
1920CvSTART(cv)
1921 B::CV cv
a0da4400
NC
1922 ALIAS:
1923 ROOT = 1
bf53b3a5 1924 CODE:
a0da4400 1925 RETVAL = CvISXSUB(cv) ? NULL : ix ? CvROOT(cv) : CvSTART(cv);
d04ba589
NC
1926 OUTPUT:
1927 RETVAL
a8a597b2 1928
a8a597b2
MB
1929void
1930CvXSUB(cv)
1931 B::CV cv
96819e59
NC
1932 ALIAS:
1933 XSUBANY = 1
a8a597b2 1934 CODE:
96819e59 1935 ST(0) = ix && CvCONST(cv)
9496d2e5 1936 ? make_sv_object(aTHX_ NULL, (SV *)CvXSUBANY(cv).any_ptr)
96819e59
NC
1937 : sv_2mortal(newSViv(CvISXSUB(cv)
1938 ? (ix ? CvXSUBANY(cv).any_iv
1939 : PTR2IV(CvXSUB(cv)))
1940 : 0));
a8a597b2 1941
de3f1649
JT
1942MODULE = B PACKAGE = B::CV PREFIX = cv_
1943
1944B::SV
1945cv_const_sv(cv)
1946 B::CV cv
1947
a8a597b2
MB
1948MODULE = B PACKAGE = B::HV PREFIX = Hv
1949
1950STRLEN
1951HvFILL(hv)
1952 B::HV hv
1953
a8a597b2
MB
1954I32
1955HvRITER(hv)
1956 B::HV hv
1957
edcc7c74
NC
1958#if PERL_VERSION < 9
1959
1960B::PMOP
1961HvPMROOT(hv)
1962 B::HV hv
1963
1964#endif
1965
a8a597b2
MB
1966void
1967HvARRAY(hv)
1968 B::HV hv
1969 PPCODE:
1970 if (HvKEYS(hv) > 0) {
1971 SV *sv;
1972 char *key;
1973 I32 len;
1974 (void)hv_iterinit(hv);
1975 EXTEND(sp, HvKEYS(hv) * 2);
8063af02 1976 while ((sv = hv_iternextsv(hv, &key, &len))) {
22f1178f 1977 mPUSHp(key, len);
9496d2e5 1978 PUSHs(make_sv_object(aTHX_ NULL, sv));
a8a597b2
MB
1979 }
1980 }
fd9f6265
JJ
1981
1982MODULE = B PACKAGE = B::HE PREFIX = He
1983
1984B::SV
1985HeVAL(he)
1986 B::HE he
b2619626
NC
1987 ALIAS:
1988 SVKEY_force = 1
1989 CODE:
1990 RETVAL = ix ? HeSVKEY_force(he) : HeVAL(he);
1991 OUTPUT:
1992 RETVAL
fd9f6265
JJ
1993
1994U32
1995HeHASH(he)
1996 B::HE he
1997
fd9f6265
JJ
1998MODULE = B PACKAGE = B::RHE PREFIX = RHE_
1999
e412117e
NC
2000#if PERL_VERSION >= 9
2001
fd9f6265
JJ
2002SV*
2003RHE_HASH(h)
2004 B::RHE h
2005 CODE:
20439bc7 2006 RETVAL = newRV( (SV*)cophh_2hv(h, 0) );
fd9f6265
JJ
2007 OUTPUT:
2008 RETVAL
e412117e
NC
2009
2010#endif