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