This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Merge the implementation of B::COP::{file,stashpv} using ALIAS.
[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
fdbacc68 897MODULE = B PACKAGE = B::OP
a8a597b2 898
651aa52e 899size_t
fdbacc68 900size(o)
651aa52e
AE
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 *
fdbacc68 974name(o)
3f872cb9 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
fdbacc68 984ppaddr(o)
a8a597b2 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
fdbacc68 999type(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 1020UV
fdbacc68 1021type(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 1038void
fdbacc68 1039oplist(o)
1df34986
AE
1040 B::OP o
1041 PPCODE:
1042 SP = oplist(aTHX_ o, SP);
1043
fdbacc68 1044MODULE = B PACKAGE = B::LISTOP
a8a597b2 1045
c03c2844 1046U32
fdbacc68 1047children(o)
c03c2844
SM
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 1205
fdbacc68 1206MODULE = B PACKAGE = B::PVOP
a8a597b2
MB
1207
1208void
fdbacc68 1209pv(o)
a8a597b2
MB
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
a9ed1a44
NC
1257
1258char *
1259COP_stashpv(o)
1260 B::COP o
dde513e7
NC
1261 ALIAS:
1262 file = 1
1263 CODE:
1264 RETVAL = ix ? CopFILE(o) : CopSTASHPV(o);
1265 OUTPUT:
1266 RETVAL
a8a597b2 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
154b8842 1585void
81e413dd 1586REGEX(sv)
89c6bc13 1587 B::REGEXP sv
81e413dd
NC
1588 ALIAS:
1589 precomp = 1
154b8842 1590 PPCODE:
81e413dd
NC
1591 if (ix) {
1592 PUSHs(newSVpvn_flags(RX_PRECOMP(sv), RX_PRELEN(sv), SVs_TEMP));
1593 } else {
1594 dXSTARG;
1595 /* FIXME - can we code this method more efficiently? */
1596 PUSHi(PTR2IV(sv));
1597 }
89c6bc13 1598
4df7f6af
NC
1599#endif
1600
fdbacc68 1601MODULE = B PACKAGE = B::PV
a8a597b2 1602
b326da91 1603B::SV
fdbacc68 1604RV(sv)
b326da91
MB
1605 B::PV sv
1606 CODE:
1607 if( SvROK(sv) ) {
1608 RETVAL = SvRV(sv);
1609 }
1610 else {
1611 croak( "argument is not SvROK" );
1612 }
1613 OUTPUT:
1614 RETVAL
1615
a8a597b2 1616void
fdbacc68 1617PV(sv)
a8a597b2 1618 B::PV sv
3d665704
NC
1619 ALIAS:
1620 PVX = 1
f4c36584 1621 PVBM = 2
84fea184 1622 B::BM::TABLE = 3
a804b0fe
NC
1623 PREINIT:
1624 const char *p;
1625 STRLEN len = 0;
1626 U32 utf8 = 0;
a8a597b2 1627 CODE:
84fea184
NC
1628 if (ix == 3) {
1629 p = SvPV(sv, len);
1630 /* Boyer-Moore table is just after string and its safety-margin \0 */
1631 p += len + PERL_FBM_TABLE_OFFSET;
1632 len = 256;
1633 } else if (ix == 2) {
f4c36584
NC
1634 /* This used to read 257. I think that that was buggy - should have
1635 been 258. (The "\0", the flags byte, and 256 for the table. Not
1636 that anything anywhere calls this method. NWC. */
1637 /* Also, the start pointer has always been SvPVX(sv). Surely it
1638 should be SvPVX(sv) + SvCUR(sv)? The code has faithfully been
1639 refactored with this behaviour, since PVBM was added in
1640 651aa52ea1faa806. */
1641 p = SvPVX_const(sv);
1642 len = SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0);
1643 } else if (ix) {
3d665704
NC
1644 p = SvPVX(sv);
1645 len = strlen(p);
1646 } else if (SvPOK(sv)) {
a804b0fe
NC
1647 len = SvCUR(sv);
1648 p = SvPVX_const(sv);
1649 utf8 = SvUTF8(sv);
0eaead75
NC
1650#if PERL_VERSION < 10
1651 /* Before 5.10 (well 931b58fb28fa5ca7), PAD_COMPNAME_GEN was stored
1652 in SvCUR(), which meant we had to attempt this special casing
1653 to avoid tripping up over variable names in the pads. */
fdbd1d64 1654 if((SvLEN(sv) && len >= SvLEN(sv))) {
b55685ae
NC
1655 /* It claims to be longer than the space allocated for it -
1656 presuambly it's a variable name in the pad */
fdbd1d64 1657 len = strlen(p);
b55685ae 1658 }
0eaead75 1659#endif
b326da91
MB
1660 }
1661 else {
1662 /* XXX for backward compatibility, but should fail */
1663 /* croak( "argument is not SvPOK" ); */
a804b0fe 1664 p = NULL;
b326da91 1665 }
a804b0fe 1666 ST(0) = newSVpvn_flags(p, len, SVs_TEMP | utf8);
a8a597b2 1667
fdbacc68 1668MODULE = B PACKAGE = B::PVMG
a8a597b2
MB
1669
1670void
fdbacc68 1671MAGIC(sv)
a8a597b2
MB
1672 B::PVMG sv
1673 MAGIC * mg = NO_INIT
1674 PPCODE:
1675 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
9496d2e5 1676 XPUSHs(make_mg_object(aTHX_ mg));
a8a597b2 1677
b2adfa9b 1678MODULE = B PACKAGE = B::MAGIC
a8a597b2
MB
1679
1680void
b2adfa9b 1681MOREMAGIC(mg)
a8a597b2 1682 B::MAGIC mg
b2adfa9b
NC
1683 ALIAS:
1684 PRIVATE = 1
1685 TYPE = 2
1686 FLAGS = 3
1687 LEN = 4
1688 OBJ = 5
1689 PTR = 6
1690 REGEX = 7
1691 precomp = 8
1692 PPCODE:
1693 switch (ix) {
1694 case 0:
1695 XPUSHs(mg->mg_moremagic ? make_mg_object(aTHX_ mg->mg_moremagic)
1696 : &PL_sv_undef);
1697 break;
1698 case 1:
1699 mPUSHu(mg->mg_private);
1700 break;
1701 case 2:
1702 PUSHs(newSVpvn_flags(&(mg->mg_type), 1, SVs_TEMP));
1703 break;
1704 case 3:
1705 mPUSHu(mg->mg_flags);
1706 break;
1707 case 4:
1708 mPUSHi(mg->mg_len);
1709 break;
1710 case 5:
1711 PUSHs(make_sv_object(aTHX_ NULL, mg->mg_obj));
1712 break;
1713 case 6:
1714 if (mg->mg_ptr) {
1715 if (mg->mg_len >= 0) {
1716 PUSHs(newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP));
651aa52e 1717 } else if (mg->mg_len == HEf_SVKEY) {
b2adfa9b 1718 PUSHs(make_sv_object(aTHX_ NULL, (SV*)mg->mg_ptr));
fdbd1d64 1719 } else
b2adfa9b
NC
1720 PUSHs(sv_newmortal());
1721 } else
1722 PUSHs(sv_newmortal());
1723 break;
1724 case 7:
1725 if(mg->mg_type == PERL_MAGIC_qr) {
1726 mPUSHi(PTR2IV(mg->mg_obj));
1727 } else {
1728 croak("REGEX is only meaningful on r-magic");
1729 }
1730 break;
1731 case 8:
1732 if (mg->mg_type == PERL_MAGIC_qr) {
1733 REGEXP *rx = (REGEXP *)mg->mg_obj;
227aaa42
NC
1734 PUSHs(newSVpvn_flags(rx ? RX_PRECOMP(rx) : NULL,
1735 rx ? RX_PRELEN(rx) : 0, SVs_TEMP));
b2adfa9b
NC
1736 } else {
1737 croak( "precomp is only meaningful on r-magic" );
1738 }
1739 break;
1740 }
a8a597b2 1741
a8a597b2
MB
1742MODULE = B PACKAGE = B::GV PREFIX = Gv
1743
1744void
1745GvNAME(gv)
1746 B::GV gv
cbf9c13f
NC
1747 ALIAS:
1748 FILE = 1
435e8dd0 1749 B::HV::NAME = 2
a8a597b2 1750 CODE:
6beb30a6 1751#if PERL_VERSION >= 10
435e8dd0
NC
1752 ST(0) = sv_2mortal(newSVhek(!ix ? GvNAME_HEK(gv)
1753 : (ix == 1 ? GvFILE_HEK(gv)
1754 : HvNAME_HEK((HV *)gv))));
6beb30a6 1755#else
435e8dd0
NC
1756 ST(0) = !ix ? newSVpvn_flags(GvNAME(gv), GvNAMELEN(gv), SVs_TEMP)
1757 : sv_2mortal(newSVpv(ix == 1 ? GvFILE(gv) : HvNAME((HV *)gv), 0))
6beb30a6 1758#endif
a8a597b2 1759
87d7fd28
GS
1760bool
1761is_empty(gv)
1762 B::GV gv
711fbbf0
NC
1763 ALIAS:
1764 isGV_with_GP = 1
87d7fd28 1765 CODE:
711fbbf0 1766 if (ix) {
50786ba8 1767#if PERL_VERSION >= 9
711fbbf0 1768 RETVAL = isGV_with_GP(gv) ? TRUE : FALSE;
50786ba8 1769#else
711fbbf0 1770 RETVAL = TRUE; /* In 5.8 and earlier they all are. */
50786ba8 1771#endif
711fbbf0
NC
1772 } else {
1773 RETVAL = GvGP(gv) == Null(GP*);
1774 }
50786ba8 1775 OUTPUT:
711fbbf0 1776 RETVAL
50786ba8 1777
651aa52e
AE
1778void*
1779GvGP(gv)
1780 B::GV gv
1781
257e0650
NC
1782#define GP_sv_ix SVp | offsetof(struct gp, gp_sv)
1783#define GP_io_ix SVp | offsetof(struct gp, gp_io)
1784#define GP_cv_ix SVp | offsetof(struct gp, gp_cv)
1785#define GP_cvgen_ix U32p | offsetof(struct gp, gp_cvgen)
1786#define GP_refcnt_ix U32p | offsetof(struct gp, gp_refcnt)
1787#define GP_hv_ix SVp | offsetof(struct gp, gp_hv)
1788#define GP_av_ix SVp | offsetof(struct gp, gp_av)
1789#define GP_form_ix SVp | offsetof(struct gp, gp_form)
1790#define GP_egv_ix SVp | offsetof(struct gp, gp_egv)
1791#define GP_line_ix line_tp | offsetof(struct gp, gp_line)
a8a597b2 1792
257e0650
NC
1793void
1794SV(gv)
a8a597b2 1795 B::GV gv
257e0650
NC
1796 ALIAS:
1797 SV = GP_sv_ix
1798 IO = GP_io_ix
1799 CV = GP_cv_ix
1800 CVGEN = GP_cvgen_ix
1801 GvREFCNT = GP_refcnt_ix
1802 HV = GP_hv_ix
1803 AV = GP_av_ix
1804 FORM = GP_form_ix
1805 EGV = GP_egv_ix
1806 LINE = GP_line_ix
1807 PREINIT:
1808 GP *gp;
1809 char *ptr;
1810 SV *ret;
1811 PPCODE:
1812 gp = GvGP(gv);
1813 if (!gp) {
1814 const GV *const gv = CvGV(cv);
46c3f339 1815 Perl_croak(aTHX_ "NULL gp in B::GV::%s", gv ? GvNAME(gv) : "???");
257e0650
NC
1816 }
1817 ptr = (ix & 0xFFFF) + (char *)gp;
1818 switch ((U8)(ix >> 16)) {
1819 case (U8)(SVp >> 16):
1820 ret = make_sv_object(aTHX_ NULL, *((SV **)ptr));
1821 break;
1822 case (U8)(U32p >> 16):
1823 ret = sv_2mortal(newSVuv(*((U32*)ptr)));
1824 break;
1825 case (U8)(line_tp >> 16):
1826 ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
1827 break;
1828 }
1829 ST(0) = ret;
1830 XSRETURN(1);
a8a597b2
MB
1831
1832B::GV
1833GvFILEGV(gv)
1834 B::GV gv
1835
a8a597b2
MB
1836MODULE = B PACKAGE = B::IO PREFIX = Io
1837
04071355
NC
1838#if PERL_VERSION <= 8
1839
a8a597b2
MB
1840short
1841IoSUBPROCESS(io)
1842 B::IO io
1843
04071355
NC
1844#endif
1845
b326da91
MB
1846bool
1847IsSTD(io,name)
1848 B::IO io
5d7488b2 1849 const char* name
b326da91
MB
1850 PREINIT:
1851 PerlIO* handle = 0;
1852 CODE:
1853 if( strEQ( name, "stdin" ) ) {
1854 handle = PerlIO_stdin();
1855 }
1856 else if( strEQ( name, "stdout" ) ) {
1857 handle = PerlIO_stdout();
1858 }
1859 else if( strEQ( name, "stderr" ) ) {
1860 handle = PerlIO_stderr();
1861 }
1862 else {
1863 croak( "Invalid value '%s'", name );
1864 }
1865 RETVAL = handle == IoIFP(io);
1866 OUTPUT:
1867 RETVAL
1868
a8a597b2
MB
1869MODULE = B PACKAGE = B::AV PREFIX = Av
1870
1871SSize_t
1872AvFILL(av)
1873 B::AV av
1874
a8a597b2
MB
1875void
1876AvARRAY(av)
1877 B::AV av
1878 PPCODE:
1879 if (AvFILL(av) >= 0) {
1880 SV **svp = AvARRAY(av);
1881 I32 i;
1882 for (i = 0; i <= AvFILL(av); i++)
9496d2e5 1883 XPUSHs(make_sv_object(aTHX_ NULL, svp[i]));
a8a597b2
MB
1884 }
1885
429a5ce7
SM
1886void
1887AvARRAYelt(av, idx)
1888 B::AV av
1889 int idx
1890 PPCODE:
1891 if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
9496d2e5 1892 XPUSHs(make_sv_object(aTHX_ NULL, (AvARRAY(av)[idx])));
429a5ce7 1893 else
9496d2e5 1894 XPUSHs(make_sv_object(aTHX_ NULL, NULL));
429a5ce7 1895
edcc7c74
NC
1896#if PERL_VERSION < 9
1897
5b02c205
NC
1898#define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1899
1900IV
1901AvOFF(av)
1902 B::AV av
1903
edcc7c74
NC
1904MODULE = B PACKAGE = B::AV
1905
1906U8
1907AvFLAGS(av)
1908 B::AV av
1909
1910#endif
1911
a8a597b2
MB
1912MODULE = B PACKAGE = B::CV PREFIX = Cv
1913
651aa52e
AE
1914U32
1915CvCONST(cv)
1916 B::CV cv
1917
a8a597b2
MB
1918B::OP
1919CvSTART(cv)
1920 B::CV cv
a0da4400
NC
1921 ALIAS:
1922 ROOT = 1
bf53b3a5 1923 CODE:
a0da4400 1924 RETVAL = CvISXSUB(cv) ? NULL : ix ? CvROOT(cv) : CvSTART(cv);
d04ba589
NC
1925 OUTPUT:
1926 RETVAL
a8a597b2 1927
a8a597b2
MB
1928void
1929CvXSUB(cv)
1930 B::CV cv
96819e59
NC
1931 ALIAS:
1932 XSUBANY = 1
a8a597b2 1933 CODE:
96819e59 1934 ST(0) = ix && CvCONST(cv)
9496d2e5 1935 ? make_sv_object(aTHX_ NULL, (SV *)CvXSUBANY(cv).any_ptr)
96819e59
NC
1936 : sv_2mortal(newSViv(CvISXSUB(cv)
1937 ? (ix ? CvXSUBANY(cv).any_iv
1938 : PTR2IV(CvXSUB(cv)))
1939 : 0));
a8a597b2 1940
de3f1649
JT
1941MODULE = B PACKAGE = B::CV PREFIX = cv_
1942
1943B::SV
1944cv_const_sv(cv)
1945 B::CV cv
1946
a8a597b2
MB
1947MODULE = B PACKAGE = B::HV PREFIX = Hv
1948
1949STRLEN
1950HvFILL(hv)
1951 B::HV hv
1952
a8a597b2
MB
1953I32
1954HvRITER(hv)
1955 B::HV hv
1956
edcc7c74
NC
1957#if PERL_VERSION < 9
1958
1959B::PMOP
1960HvPMROOT(hv)
1961 B::HV hv
1962
1963#endif
1964
a8a597b2
MB
1965void
1966HvARRAY(hv)
1967 B::HV hv
1968 PPCODE:
1969 if (HvKEYS(hv) > 0) {
1970 SV *sv;
1971 char *key;
1972 I32 len;
1973 (void)hv_iterinit(hv);
1974 EXTEND(sp, HvKEYS(hv) * 2);
8063af02 1975 while ((sv = hv_iternextsv(hv, &key, &len))) {
22f1178f 1976 mPUSHp(key, len);
9496d2e5 1977 PUSHs(make_sv_object(aTHX_ NULL, sv));
a8a597b2
MB
1978 }
1979 }
fd9f6265
JJ
1980
1981MODULE = B PACKAGE = B::HE PREFIX = He
1982
1983B::SV
1984HeVAL(he)
1985 B::HE he
b2619626
NC
1986 ALIAS:
1987 SVKEY_force = 1
1988 CODE:
1989 RETVAL = ix ? HeSVKEY_force(he) : HeVAL(he);
1990 OUTPUT:
1991 RETVAL
fd9f6265
JJ
1992
1993U32
1994HeHASH(he)
1995 B::HE he
1996
fdbacc68 1997MODULE = B PACKAGE = B::RHE
fd9f6265 1998
e412117e
NC
1999#if PERL_VERSION >= 9
2000
fd9f6265 2001SV*
fdbacc68 2002HASH(h)
fd9f6265
JJ
2003 B::RHE h
2004 CODE:
20439bc7 2005 RETVAL = newRV( (SV*)cophh_2hv(h, 0) );
fd9f6265
JJ
2006 OUTPUT:
2007 RETVAL
e412117e
NC
2008
2009#endif