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