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