This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Don't fold constants in sprintf() if locales are used
[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
MB
833
834#define OP_next(o) o->op_next
835#define OP_sibling(o) o->op_sibling
27da23d5 836#define OP_desc(o) (char *)PL_op_desc[o->op_type]
a8a597b2
MB
837#define OP_targ(o) o->op_targ
838#define OP_type(o) o->op_type
7252851f
NC
839#if PERL_VERSION >= 9
840# define OP_opt(o) o->op_opt
7252851f
NC
841#else
842# define OP_seq(o) o->op_seq
843#endif
a8a597b2
MB
844#define OP_flags(o) o->op_flags
845#define OP_private(o) o->op_private
a60ba18b 846#define OP_spare(o) o->op_spare
a8a597b2
MB
847
848MODULE = B PACKAGE = B::OP PREFIX = OP_
849
651aa52e
AE
850size_t
851OP_size(o)
852 B::OP o
853 CODE:
854 RETVAL = opsizes[cc_opclass(aTHX_ o)];
855 OUTPUT:
856 RETVAL
857
a8a597b2
MB
858B::OP
859OP_next(o)
860 B::OP o
861
862B::OP
863OP_sibling(o)
864 B::OP o
865
866char *
3f872cb9
GS
867OP_name(o)
868 B::OP o
869 CODE:
27da23d5 870 RETVAL = (char *)PL_op_name[o->op_type];
8063af02
DM
871 OUTPUT:
872 RETVAL
3f872cb9
GS
873
874
8063af02 875void
a8a597b2
MB
876OP_ppaddr(o)
877 B::OP o
dc333d64
GS
878 PREINIT:
879 int i;
fdbd1d64 880 SV *sv = newSVpvs_flags("PL_ppaddr[OP_", SVs_TEMP);
a8a597b2 881 CODE:
dc333d64 882 sv_catpv(sv, PL_op_name[o->op_type]);
7c436af3 883 for (i=13; (STRLEN)i < SvCUR(sv); ++i)
dc333d64 884 SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]);
6beb30a6 885 sv_catpvs(sv, "]");
dc333d64 886 ST(0) = sv;
a8a597b2
MB
887
888char *
889OP_desc(o)
890 B::OP o
891
7934575e 892PADOFFSET
a8a597b2
MB
893OP_targ(o)
894 B::OP o
895
896U16
897OP_type(o)
898 B::OP o
899
7252851f
NC
900#if PERL_VERSION >= 9
901
0053d415 902U16
2814eb74
PJ
903OP_opt(o)
904 B::OP o
905
7252851f
NC
906#else
907
908U16
909OP_seq(o)
910 B::OP o
911
912#endif
913
a8a597b2
MB
914U8
915OP_flags(o)
916 B::OP o
917
918U8
919OP_private(o)
920 B::OP o
921
7252851f
NC
922#if PERL_VERSION >= 9
923
0053d415 924U16
a60ba18b
JC
925OP_spare(o)
926 B::OP o
927
7252851f
NC
928#endif
929
1df34986
AE
930void
931OP_oplist(o)
932 B::OP o
933 PPCODE:
934 SP = oplist(aTHX_ o, SP);
935
a8a597b2
MB
936#define UNOP_first(o) o->op_first
937
938MODULE = B PACKAGE = B::UNOP PREFIX = UNOP_
939
940B::OP
941UNOP_first(o)
942 B::UNOP o
943
944#define BINOP_last(o) o->op_last
945
946MODULE = B PACKAGE = B::BINOP PREFIX = BINOP_
947
948B::OP
949BINOP_last(o)
950 B::BINOP o
951
952#define LOGOP_other(o) o->op_other
953
954MODULE = B PACKAGE = B::LOGOP PREFIX = LOGOP_
955
956B::OP
957LOGOP_other(o)
958 B::LOGOP o
959
a8a597b2
MB
960MODULE = B PACKAGE = B::LISTOP PREFIX = LISTOP_
961
c03c2844
SM
962U32
963LISTOP_children(o)
964 B::LISTOP o
965 OP * kid = NO_INIT
966 int i = NO_INIT
967 CODE:
c03c2844
SM
968 i = 0;
969 for (kid = o->op_first; kid; kid = kid->op_sibling)
970 i++;
8063af02
DM
971 RETVAL = i;
972 OUTPUT:
973 RETVAL
c03c2844 974
a8a597b2 975#define PMOP_pmnext(o) o->op_pmnext
aaa362c4 976#define PMOP_pmregexp(o) PM_GETRE(o)
9d2bbe64
MB
977#ifdef USE_ITHREADS
978#define PMOP_pmoffset(o) o->op_pmoffset
29f2e912 979#define PMOP_pmstashpv(o) PmopSTASHPV(o);
651aa52e 980#else
29f2e912 981#define PMOP_pmstash(o) PmopSTASH(o);
9d2bbe64 982#endif
a8a597b2 983#define PMOP_pmflags(o) o->op_pmflags
a8a597b2
MB
984
985MODULE = B PACKAGE = B::PMOP PREFIX = PMOP_
986
20e98b0f
NC
987#if PERL_VERSION <= 8
988
a8a597b2
MB
989void
990PMOP_pmreplroot(o)
991 B::PMOP o
992 OP * root = NO_INIT
993 CODE:
994 ST(0) = sv_newmortal();
995 root = o->op_pmreplroot;
996 /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */
997 if (o->op_type == OP_PUSHRE) {
20e98b0f 998# ifdef USE_ITHREADS
9d2bbe64 999 sv_setiv(ST(0), INT2PTR(PADOFFSET,root) );
20e98b0f 1000# else
a8a597b2
MB
1001 sv_setiv(newSVrv(ST(0), root ?
1002 svclassnames[SvTYPE((SV*)root)] : "B::SV"),
56431972 1003 PTR2IV(root));
20e98b0f 1004# endif
a8a597b2
MB
1005 }
1006 else {
56431972 1007 sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root));
a8a597b2
MB
1008 }
1009
20e98b0f
NC
1010#else
1011
1012void
1013PMOP_pmreplroot(o)
1014 B::PMOP o
1015 CODE:
1016 ST(0) = sv_newmortal();
1017 if (o->op_type == OP_PUSHRE) {
1018# ifdef USE_ITHREADS
1019 sv_setiv(ST(0), o->op_pmreplrootu.op_pmtargetoff);
1020# else
1021 GV *const target = o->op_pmreplrootu.op_pmtargetgv;
1022 sv_setiv(newSVrv(ST(0), target ?
1023 svclassnames[SvTYPE((SV*)target)] : "B::SV"),
1024 PTR2IV(target));
1025# endif
1026 }
1027 else {
1028 OP *const root = o->op_pmreplrootu.op_pmreplroot;
1029 sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)),
1030 PTR2IV(root));
1031 }
1032
1033#endif
1034
a8a597b2
MB
1035B::OP
1036PMOP_pmreplstart(o)
1037 B::PMOP o
1038
c2b1997a
NC
1039#if PERL_VERSION < 9
1040
a8a597b2
MB
1041B::PMOP
1042PMOP_pmnext(o)
1043 B::PMOP o
1044
c2b1997a
NC
1045#endif
1046
9d2bbe64
MB
1047#ifdef USE_ITHREADS
1048
1049IV
1050PMOP_pmoffset(o)
1051 B::PMOP o
1052
651aa52e
AE
1053char*
1054PMOP_pmstashpv(o)
1055 B::PMOP o
1056
1057#else
1058
1059B::HV
1060PMOP_pmstash(o)
1061 B::PMOP o
1062
9d2bbe64
MB
1063#endif
1064
6e21dc91 1065U32
a8a597b2
MB
1066PMOP_pmflags(o)
1067 B::PMOP o
1068
7c1f70cb
NC
1069#if PERL_VERSION < 9
1070
1071U32
1072PMOP_pmpermflags(o)
1073 B::PMOP o
1074
1075U8
1076PMOP_pmdynflags(o)
1077 B::PMOP o
1078
1079#endif
1080
a8a597b2
MB
1081void
1082PMOP_precomp(o)
1083 B::PMOP o
1084 REGEXP * rx = NO_INIT
1085 CODE:
1086 ST(0) = sv_newmortal();
aaa362c4 1087 rx = PM_GETRE(o);
a8a597b2 1088 if (rx)
220fc49f 1089 sv_setpvn(ST(0), RX_PRECOMP(rx), RX_PRELEN(rx));
a8a597b2 1090
7c1f70cb
NC
1091#if PERL_VERSION >= 9
1092
c737faaf
YO
1093void
1094PMOP_reflags(o)
1095 B::PMOP o
1096 REGEXP * rx = NO_INIT
1097 CODE:
1098 ST(0) = sv_newmortal();
1099 rx = PM_GETRE(o);
1100 if (rx)
07bc277f 1101 sv_setuv(ST(0), RX_EXTFLAGS(rx));
c737faaf 1102
7c1f70cb
NC
1103#endif
1104
ac33dcd1
JH
1105#define SVOP_sv(o) cSVOPo->op_sv
1106#define SVOP_gv(o) ((GV*)cSVOPo->op_sv)
a8a597b2
MB
1107
1108MODULE = B PACKAGE = B::SVOP PREFIX = SVOP_
1109
a8a597b2
MB
1110B::SV
1111SVOP_sv(o)
1112 B::SVOP o
1113
f22444f5 1114B::GV
065a1863
GS
1115SVOP_gv(o)
1116 B::SVOP o
1117
7934575e 1118#define PADOP_padix(o) o->op_padix
dd2155a4 1119#define PADOP_sv(o) (o->op_padix ? PAD_SVl(o->op_padix) : Nullsv)
7934575e 1120#define PADOP_gv(o) ((o->op_padix \
dd2155a4 1121 && SvTYPE(PAD_SVl(o->op_padix)) == SVt_PVGV) \
3ae1b226 1122 ? (GV*)PAD_SVl(o->op_padix) : (GV *)NULL)
a8a597b2 1123
7934575e
GS
1124MODULE = B PACKAGE = B::PADOP PREFIX = PADOP_
1125
1126PADOFFSET
1127PADOP_padix(o)
1128 B::PADOP o
1129
1130B::SV
1131PADOP_sv(o)
1132 B::PADOP o
a8a597b2
MB
1133
1134B::GV
7934575e
GS
1135PADOP_gv(o)
1136 B::PADOP o
a8a597b2
MB
1137
1138MODULE = B PACKAGE = B::PVOP PREFIX = PVOP_
1139
1140void
1141PVOP_pv(o)
1142 B::PVOP o
1143 CODE:
1144 /*
bec89253 1145 * OP_TRANS uses op_pv to point to a table of 256 or >=258 shorts
a8a597b2
MB
1146 * whereas other PVOPs point to a null terminated string.
1147 */
bec89253
RH
1148 if (o->op_type == OP_TRANS &&
1149 (o->op_private & OPpTRANS_COMPLEMENT) &&
1150 !(o->op_private & OPpTRANS_DELETE))
1151 {
5d7488b2
AL
1152 const short* const tbl = (short*)o->op_pv;
1153 const short entries = 257 + tbl[256];
d3d34884 1154 ST(0) = newSVpvn_flags(o->op_pv, entries * sizeof(short), SVs_TEMP);
bec89253
RH
1155 }
1156 else if (o->op_type == OP_TRANS) {
d3d34884 1157 ST(0) = newSVpvn_flags(o->op_pv, 256 * sizeof(short), SVs_TEMP);
bec89253
RH
1158 }
1159 else
d3d34884 1160 ST(0) = newSVpvn_flags(o->op_pv, strlen(o->op_pv), SVs_TEMP);
a8a597b2
MB
1161
1162#define LOOP_redoop(o) o->op_redoop
1163#define LOOP_nextop(o) o->op_nextop
1164#define LOOP_lastop(o) o->op_lastop
1165
1166MODULE = B PACKAGE = B::LOOP PREFIX = LOOP_
1167
1168
1169B::OP
1170LOOP_redoop(o)
1171 B::LOOP o
1172
1173B::OP
1174LOOP_nextop(o)
1175 B::LOOP o
1176
1177B::OP
1178LOOP_lastop(o)
1179 B::LOOP o
1180
4b65a919 1181#define COP_label(o) CopLABEL(o)
11faa288
GS
1182#define COP_stashpv(o) CopSTASHPV(o)
1183#define COP_stash(o) CopSTASH(o)
57843af0 1184#define COP_file(o) CopFILE(o)
1df34986 1185#define COP_filegv(o) CopFILEGV(o)
a8a597b2 1186#define COP_cop_seq(o) o->cop_seq
fc15ae8f 1187#define COP_arybase(o) CopARYBASE_get(o)
57843af0 1188#define COP_line(o) CopLINE(o)
d5ec2987 1189#define COP_hints(o) CopHINTS_get(o)
e412117e
NC
1190#if PERL_VERSION < 9
1191# define COP_warnings(o) o->cop_warnings
1192# define COP_io(o) o->cop_io
1193#endif
a8a597b2
MB
1194
1195MODULE = B PACKAGE = B::COP PREFIX = COP_
1196
d5b8ed54
NC
1197#if PERL_VERSION >= 11
1198
1199const char *
1200COP_label(o)
1201 B::COP o
1202
1203#else
1204
a8a597b2
MB
1205char *
1206COP_label(o)
1207 B::COP o
1208
d5b8ed54
NC
1209#endif
1210
11faa288
GS
1211char *
1212COP_stashpv(o)
1213 B::COP o
1214
a8a597b2
MB
1215B::HV
1216COP_stash(o)
1217 B::COP o
1218
57843af0
GS
1219char *
1220COP_file(o)
a8a597b2
MB
1221 B::COP o
1222
1df34986
AE
1223B::GV
1224COP_filegv(o)
1225 B::COP o
1226
1227
a8a597b2
MB
1228U32
1229COP_cop_seq(o)
1230 B::COP o
1231
1232I32
1233COP_arybase(o)
1234 B::COP o
1235
8bafa735 1236U32
a8a597b2
MB
1237COP_line(o)
1238 B::COP o
1239
e412117e
NC
1240#if PERL_VERSION >= 9
1241
5c3c3f81 1242void
b295d113
TH
1243COP_warnings(o)
1244 B::COP o
5c3c3f81 1245 PPCODE:
9496d2e5 1246 ST(0) = make_warnings_object(aTHX_ o->cop_warnings);
5c3c3f81 1247 XSRETURN(1);
b295d113 1248
670f1322 1249void
6e6a1aef
RGS
1250COP_io(o)
1251 B::COP o
11bcd5da 1252 PPCODE:
9496d2e5 1253 ST(0) = make_cop_io_object(aTHX_ o);
11bcd5da 1254 XSRETURN(1);
6e6a1aef 1255
fd9f6265
JJ
1256B::RHE
1257COP_hints_hash(o)
1258 B::COP o
1259 CODE:
20439bc7 1260 RETVAL = CopHINTHASH_get(o);
fd9f6265
JJ
1261 OUTPUT:
1262 RETVAL
1263
e412117e
NC
1264#else
1265
1266B::SV
1267COP_warnings(o)
1268 B::COP o
1269
1270B::SV
1271COP_io(o)
1272 B::COP o
1273
1274#endif
1275
1276U32
1277COP_hints(o)
1278 B::COP o
1279
651aa52e
AE
1280MODULE = B PACKAGE = B::SV
1281
1282U32
1283SvTYPE(sv)
1284 B::SV sv
1285
429a5ce7
SM
1286#define object_2svref(sv) sv
1287#define SVREF SV *
1288
1289SVREF
1290object_2svref(sv)
1291 B::SV sv
1292
a8a597b2
MB
1293MODULE = B PACKAGE = B::SV PREFIX = Sv
1294
1295U32
1296SvREFCNT(sv)
1297 B::SV sv
1298
1299U32
1300SvFLAGS(sv)
1301 B::SV sv
1302
651aa52e
AE
1303U32
1304SvPOK(sv)
1305 B::SV sv
1306
1307U32
1308SvROK(sv)
1309 B::SV sv
1310
1311U32
1312SvMAGICAL(sv)
1313 B::SV sv
1314
a8a597b2
MB
1315MODULE = B PACKAGE = B::IV PREFIX = Sv
1316
1317IV
1318SvIV(sv)
1319 B::IV sv
1320
1321IV
1322SvIVX(sv)
1323 B::IV sv
1324
0ca04487
VB
1325UV
1326SvUVX(sv)
1327 B::IV sv
1328
1329
a8a597b2
MB
1330MODULE = B PACKAGE = B::IV
1331
1332#define needs64bits(sv) ((I32)SvIVX(sv) != SvIVX(sv))
1333
1334int
1335needs64bits(sv)
1336 B::IV sv
1337
1338void
1339packiv(sv)
1340 B::IV sv
1341 CODE:
1342 if (sizeof(IV) == 8) {
1343 U32 wp[2];
5d7488b2 1344 const IV iv = SvIVX(sv);
a8a597b2
MB
1345 /*
1346 * The following way of spelling 32 is to stop compilers on
1347 * 32-bit architectures from moaning about the shift count
1348 * being >= the width of the type. Such architectures don't
1349 * reach this code anyway (unless sizeof(IV) > 8 but then
1350 * everything else breaks too so I'm not fussed at the moment).
1351 */
42718184
RB
1352#ifdef UV_IS_QUAD
1353 wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1354#else
1355 wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1356#endif
a8a597b2 1357 wp[1] = htonl(iv & 0xffffffff);
d3d34884 1358 ST(0) = newSVpvn_flags((char *)wp, 8, SVs_TEMP);
a8a597b2
MB
1359 } else {
1360 U32 w = htonl((U32)SvIVX(sv));
d3d34884 1361 ST(0) = newSVpvn_flags((char *)&w, 4, SVs_TEMP);
a8a597b2
MB
1362 }
1363
4df7f6af
NC
1364
1365#if PERL_VERSION >= 11
1366
1367B::SV
1368RV(sv)
1369 B::IV sv
1370 CODE:
1371 if( SvROK(sv) ) {
1372 RETVAL = SvRV(sv);
1373 }
1374 else {
1375 croak( "argument is not SvROK" );
1376 }
1377 OUTPUT:
1378 RETVAL
1379
1380#endif
1381
a8a597b2
MB
1382MODULE = B PACKAGE = B::NV PREFIX = Sv
1383
76ef7183 1384NV
a8a597b2
MB
1385SvNV(sv)
1386 B::NV sv
1387
76ef7183 1388NV
a8a597b2
MB
1389SvNVX(sv)
1390 B::NV sv
1391
809abb02
NC
1392U32
1393COP_SEQ_RANGE_LOW(sv)
1394 B::NV sv
1395
1396U32
1397COP_SEQ_RANGE_HIGH(sv)
1398 B::NV sv
1399
1400U32
1401PARENT_PAD_INDEX(sv)
1402 B::NV sv
1403
1404U32
1405PARENT_FAKELEX_FLAGS(sv)
1406 B::NV sv
1407
4df7f6af
NC
1408#if PERL_VERSION < 11
1409
a8a597b2
MB
1410MODULE = B PACKAGE = B::RV PREFIX = Sv
1411
1412B::SV
1413SvRV(sv)
1414 B::RV sv
1415
4df7f6af
NC
1416#endif
1417
a8a597b2
MB
1418MODULE = B PACKAGE = B::PV PREFIX = Sv
1419
0b40bd6d
RH
1420char*
1421SvPVX(sv)
1422 B::PV sv
1423
b326da91
MB
1424B::SV
1425SvRV(sv)
1426 B::PV sv
1427 CODE:
1428 if( SvROK(sv) ) {
1429 RETVAL = SvRV(sv);
1430 }
1431 else {
1432 croak( "argument is not SvROK" );
1433 }
1434 OUTPUT:
1435 RETVAL
1436
a8a597b2
MB
1437void
1438SvPV(sv)
1439 B::PV sv
1440 CODE:
c0b20461 1441 if( SvPOK(sv) ) {
fdbd1d64
NC
1442 STRLEN len = SvCUR(sv);
1443 const char *p = SvPVX_const(sv);
b55685ae
NC
1444 /* FIXME - we need a better way for B to identify PVs that are
1445 in the pads as variable names. */
fdbd1d64 1446 if((SvLEN(sv) && len >= SvLEN(sv))) {
b55685ae
NC
1447 /* It claims to be longer than the space allocated for it -
1448 presuambly it's a variable name in the pad */
fdbd1d64 1449 len = strlen(p);
b55685ae 1450 }
fdbd1d64 1451 ST(0) = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
b326da91
MB
1452 }
1453 else {
1454 /* XXX for backward compatibility, but should fail */
1455 /* croak( "argument is not SvPOK" ); */
fdbd1d64 1456 ST(0) = sv_newmortal();
b326da91 1457 }
a8a597b2 1458
5a44e503
NC
1459# This used to read 257. I think that that was buggy - should have been 258.
1460# (The "\0", the flags byte, and 256 for the table. Not that anything
1461# anywhere calls this method. NWC.
651aa52e
AE
1462void
1463SvPVBM(sv)
1464 B::PV sv
1465 CODE:
fdbd1d64
NC
1466 ST(0) = newSVpvn_flags(SvPVX_const(sv),
1467 SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0),
1468 SVs_TEMP);
651aa52e
AE
1469
1470
445a12f6
DM
1471STRLEN
1472SvLEN(sv)
1473 B::PV sv
1474
1475STRLEN
1476SvCUR(sv)
1477 B::PV sv
1478
a8a597b2
MB
1479MODULE = B PACKAGE = B::PVMG PREFIX = Sv
1480
1481void
1482SvMAGIC(sv)
1483 B::PVMG sv
1484 MAGIC * mg = NO_INIT
1485 PPCODE:
1486 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
9496d2e5 1487 XPUSHs(make_mg_object(aTHX_ mg));
a8a597b2
MB
1488
1489MODULE = B PACKAGE = B::PVMG
1490
1491B::HV
1492SvSTASH(sv)
1493 B::PVMG sv
1494
5c35adbb
NC
1495MODULE = B PACKAGE = B::REGEXP
1496
1497#if PERL_VERSION >= 11
1498
1499IV
1500REGEX(sv)
07bc277f 1501 B::REGEXP sv
5c35adbb 1502 CODE:
288b8c02
NC
1503 /* FIXME - can we code this method more efficiently? */
1504 RETVAL = PTR2IV(sv);
5c35adbb
NC
1505 OUTPUT:
1506 RETVAL
1507
1508SV*
1509precomp(sv)
07bc277f 1510 B::REGEXP sv
5c35adbb 1511 CODE:
288b8c02 1512 RETVAL = newSVpvn( RX_PRECOMP(sv), RX_PRELEN(sv) );
5c35adbb
NC
1513 OUTPUT:
1514 RETVAL
1515
1516#endif
1517
a8a597b2
MB
1518#define MgMOREMAGIC(mg) mg->mg_moremagic
1519#define MgPRIVATE(mg) mg->mg_private
1520#define MgTYPE(mg) mg->mg_type
1521#define MgFLAGS(mg) mg->mg_flags
1522#define MgOBJ(mg) mg->mg_obj
88b39979 1523#define MgLENGTH(mg) mg->mg_len
bde7177d 1524#define MgREGEX(mg) PTR2IV(mg->mg_obj)
a8a597b2
MB
1525
1526MODULE = B PACKAGE = B::MAGIC PREFIX = Mg
1527
1528B::MAGIC
1529MgMOREMAGIC(mg)
1530 B::MAGIC mg
c5f0f3aa
RGS
1531 CODE:
1532 if( MgMOREMAGIC(mg) ) {
1533 RETVAL = MgMOREMAGIC(mg);
1534 }
1535 else {
1536 XSRETURN_UNDEF;
1537 }
1538 OUTPUT:
1539 RETVAL
a8a597b2
MB
1540
1541U16
1542MgPRIVATE(mg)
1543 B::MAGIC mg
1544
1545char
1546MgTYPE(mg)
1547 B::MAGIC mg
1548
1549U8
1550MgFLAGS(mg)
1551 B::MAGIC mg
1552
1553B::SV
1554MgOBJ(mg)
1555 B::MAGIC mg
b326da91 1556
9d2bbe64
MB
1557IV
1558MgREGEX(mg)
1559 B::MAGIC mg
1560 CODE:
a8248b05 1561 if(mg->mg_type == PERL_MAGIC_qr) {
9d2bbe64
MB
1562 RETVAL = MgREGEX(mg);
1563 }
1564 else {
1565 croak( "REGEX is only meaningful on r-magic" );
1566 }
1567 OUTPUT:
1568 RETVAL
1569
b326da91
MB
1570SV*
1571precomp(mg)
1572 B::MAGIC mg
1573 CODE:
a8248b05 1574 if (mg->mg_type == PERL_MAGIC_qr) {
b326da91 1575 REGEXP* rx = (REGEXP*)mg->mg_obj;
ef35129c 1576 RETVAL = Nullsv;
b326da91 1577 if( rx )
220fc49f 1578 RETVAL = newSVpvn( RX_PRECOMP(rx), RX_PRELEN(rx) );
b326da91
MB
1579 }
1580 else {
1581 croak( "precomp is only meaningful on r-magic" );
1582 }
1583 OUTPUT:
1584 RETVAL
a8a597b2 1585
88b39979
VB
1586I32
1587MgLENGTH(mg)
1588 B::MAGIC mg
1589
a8a597b2
MB
1590void
1591MgPTR(mg)
1592 B::MAGIC mg
1593 CODE:
88b39979
VB
1594 if (mg->mg_ptr){
1595 if (mg->mg_len >= 0){
fdbd1d64 1596 ST(0) = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
651aa52e 1597 } else if (mg->mg_len == HEf_SVKEY) {
9496d2e5 1598 ST(0) = make_sv_object(aTHX_ NULL, (SV*)mg->mg_ptr);
fdbd1d64
NC
1599 } else
1600 ST(0) = sv_newmortal();
1601 } else
1602 ST(0) = sv_newmortal();
a8a597b2
MB
1603
1604MODULE = B PACKAGE = B::PVLV PREFIX = Lv
1605
1606U32
1607LvTARGOFF(sv)
1608 B::PVLV sv
1609
1610U32
1611LvTARGLEN(sv)
1612 B::PVLV sv
1613
1614char
1615LvTYPE(sv)
1616 B::PVLV sv
1617
1618B::SV
1619LvTARG(sv)
1620 B::PVLV sv
1621
1622MODULE = B PACKAGE = B::BM PREFIX = Bm
1623
1624I32
1625BmUSEFUL(sv)
1626 B::BM sv
1627
85c508c3 1628U32
a8a597b2
MB
1629BmPREVIOUS(sv)
1630 B::BM sv
1631
1632U8
1633BmRARE(sv)
1634 B::BM sv
1635
1636void
1637BmTABLE(sv)
1638 B::BM sv
1639 STRLEN len = NO_INIT
1640 char * str = NO_INIT
1641 CODE:
1642 str = SvPV(sv, len);
1643 /* Boyer-Moore table is just after string and its safety-margin \0 */
d3d34884 1644 ST(0) = newSVpvn_flags(str + len + PERL_FBM_TABLE_OFFSET, 256, SVs_TEMP);
a8a597b2
MB
1645
1646MODULE = B PACKAGE = B::GV PREFIX = Gv
1647
1648void
1649GvNAME(gv)
1650 B::GV gv
1651 CODE:
6beb30a6
NC
1652#if PERL_VERSION >= 10
1653 ST(0) = sv_2mortal(newSVhek(GvNAME_HEK(gv)));
1654#else
d3d34884 1655 ST(0) = newSVpvn_flags(GvNAME(gv), GvNAMELEN(gv), SVs_TEMP);
6beb30a6 1656#endif
a8a597b2 1657
87d7fd28
GS
1658bool
1659is_empty(gv)
1660 B::GV gv
1661 CODE:
1662 RETVAL = GvGP(gv) == Null(GP*);
1663 OUTPUT:
1664 RETVAL
1665
50786ba8
NC
1666bool
1667isGV_with_GP(gv)
1668 B::GV gv
1669 CODE:
1670#if PERL_VERSION >= 9
1671 RETVAL = isGV_with_GP(gv) ? TRUE : FALSE;
1672#else
1673 RETVAL = TRUE; /* In 5.8 and earlier they all are. */
1674#endif
1675 OUTPUT:
1676 RETVAL
1677
651aa52e
AE
1678void*
1679GvGP(gv)
1680 B::GV gv
1681
a8a597b2
MB
1682B::HV
1683GvSTASH(gv)
1684 B::GV gv
1685
1686B::SV
1687GvSV(gv)
1688 B::GV gv
1689
1690B::IO
1691GvIO(gv)
1692 B::GV gv
1693
1df34986 1694B::FM
a8a597b2
MB
1695GvFORM(gv)
1696 B::GV gv
1df34986
AE
1697 CODE:
1698 RETVAL = (SV*)GvFORM(gv);
1699 OUTPUT:
1700 RETVAL
a8a597b2
MB
1701
1702B::AV
1703GvAV(gv)
1704 B::GV gv
1705
1706B::HV
1707GvHV(gv)
1708 B::GV gv
1709
1710B::GV
1711GvEGV(gv)
1712 B::GV gv
1713
1714B::CV
1715GvCV(gv)
1716 B::GV gv
1717
1718U32
1719GvCVGEN(gv)
1720 B::GV gv
1721
8bafa735 1722U32
a8a597b2
MB
1723GvLINE(gv)
1724 B::GV gv
1725
b195d487
GS
1726char *
1727GvFILE(gv)
1728 B::GV gv
1729
a8a597b2
MB
1730B::GV
1731GvFILEGV(gv)
1732 B::GV gv
1733
1734MODULE = B PACKAGE = B::GV
1735
1736U32
1737GvREFCNT(gv)
1738 B::GV gv
1739
1740U8
1741GvFLAGS(gv)
1742 B::GV gv
1743
1744MODULE = B PACKAGE = B::IO PREFIX = Io
1745
1746long
1747IoLINES(io)
1748 B::IO io
1749
1750long
1751IoPAGE(io)
1752 B::IO io
1753
1754long
1755IoPAGE_LEN(io)
1756 B::IO io
1757
1758long
1759IoLINES_LEFT(io)
1760 B::IO io
1761
1762char *
1763IoTOP_NAME(io)
1764 B::IO io
1765
1766B::GV
1767IoTOP_GV(io)
1768 B::IO io
1769
1770char *
1771IoFMT_NAME(io)
1772 B::IO io
1773
1774B::GV
1775IoFMT_GV(io)
1776 B::IO io
1777
1778char *
1779IoBOTTOM_NAME(io)
1780 B::IO io
1781
1782B::GV
1783IoBOTTOM_GV(io)
1784 B::IO io
1785
04071355
NC
1786#if PERL_VERSION <= 8
1787
a8a597b2
MB
1788short
1789IoSUBPROCESS(io)
1790 B::IO io
1791
04071355
NC
1792#endif
1793
b326da91
MB
1794bool
1795IsSTD(io,name)
1796 B::IO io
5d7488b2 1797 const char* name
b326da91
MB
1798 PREINIT:
1799 PerlIO* handle = 0;
1800 CODE:
1801 if( strEQ( name, "stdin" ) ) {
1802 handle = PerlIO_stdin();
1803 }
1804 else if( strEQ( name, "stdout" ) ) {
1805 handle = PerlIO_stdout();
1806 }
1807 else if( strEQ( name, "stderr" ) ) {
1808 handle = PerlIO_stderr();
1809 }
1810 else {
1811 croak( "Invalid value '%s'", name );
1812 }
1813 RETVAL = handle == IoIFP(io);
1814 OUTPUT:
1815 RETVAL
1816
a8a597b2
MB
1817MODULE = B PACKAGE = B::IO
1818
1819char
1820IoTYPE(io)
1821 B::IO io
1822
1823U8
1824IoFLAGS(io)
1825 B::IO io
1826
1827MODULE = B PACKAGE = B::AV PREFIX = Av
1828
1829SSize_t
1830AvFILL(av)
1831 B::AV av
1832
1833SSize_t
1834AvMAX(av)
1835 B::AV av
1836
edcc7c74
NC
1837#if PERL_VERSION < 9
1838
1839
1840#define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1841
1842IV
1843AvOFF(av)
1844 B::AV av
1845
1846#endif
1847
a8a597b2
MB
1848void
1849AvARRAY(av)
1850 B::AV av
1851 PPCODE:
1852 if (AvFILL(av) >= 0) {
1853 SV **svp = AvARRAY(av);
1854 I32 i;
1855 for (i = 0; i <= AvFILL(av); i++)
9496d2e5 1856 XPUSHs(make_sv_object(aTHX_ NULL, svp[i]));
a8a597b2
MB
1857 }
1858
429a5ce7
SM
1859void
1860AvARRAYelt(av, idx)
1861 B::AV av
1862 int idx
1863 PPCODE:
1864 if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
9496d2e5 1865 XPUSHs(make_sv_object(aTHX_ NULL, (AvARRAY(av)[idx])));
429a5ce7 1866 else
9496d2e5 1867 XPUSHs(make_sv_object(aTHX_ NULL, NULL));
429a5ce7 1868
edcc7c74
NC
1869#if PERL_VERSION < 9
1870
1871MODULE = B PACKAGE = B::AV
1872
1873U8
1874AvFLAGS(av)
1875 B::AV av
1876
1877#endif
1878
1df34986
AE
1879MODULE = B PACKAGE = B::FM PREFIX = Fm
1880
1881IV
1882FmLINES(form)
1883 B::FM form
1884
a8a597b2
MB
1885MODULE = B PACKAGE = B::CV PREFIX = Cv
1886
651aa52e
AE
1887U32
1888CvCONST(cv)
1889 B::CV cv
1890
a8a597b2
MB
1891B::HV
1892CvSTASH(cv)
1893 B::CV cv
1894
1895B::OP
1896CvSTART(cv)
1897 B::CV cv
a0da4400
NC
1898 ALIAS:
1899 ROOT = 1
bf53b3a5 1900 CODE:
a0da4400 1901 RETVAL = CvISXSUB(cv) ? NULL : ix ? CvROOT(cv) : CvSTART(cv);
d04ba589
NC
1902 OUTPUT:
1903 RETVAL
a8a597b2
MB
1904
1905B::GV
1906CvGV(cv)
1907 B::CV cv
1908
57843af0
GS
1909char *
1910CvFILE(cv)
1911 B::CV cv
1912
a8a597b2
MB
1913long
1914CvDEPTH(cv)
1915 B::CV cv
1916
1917B::AV
1918CvPADLIST(cv)
1919 B::CV cv
1920
1921B::CV
1922CvOUTSIDE(cv)
1923 B::CV cv
1924
a3985cdc
DM
1925U32
1926CvOUTSIDE_SEQ(cv)
1927 B::CV cv
1928
a8a597b2
MB
1929void
1930CvXSUB(cv)
1931 B::CV cv
1932 CODE:
d04ba589 1933 ST(0) = sv_2mortal(newSViv(CvISXSUB(cv) ? PTR2IV(CvXSUB(cv)) : 0));
a8a597b2
MB
1934
1935
1936void
1937CvXSUBANY(cv)
1938 B::CV cv
1939 CODE:
9496d2e5
NC
1940 ST(0) = CvCONST(cv)
1941 ? make_sv_object(aTHX_ NULL, (SV *)CvXSUBANY(cv).any_ptr)
1942 : sv_2mortal(newSViv(CvISXSUB(cv) ? CvXSUBANY(cv).any_iv : 0));
a8a597b2 1943
5cfd8ad4
VB
1944MODULE = B PACKAGE = B::CV
1945
6aaf4108 1946U16
5cfd8ad4
VB
1947CvFLAGS(cv)
1948 B::CV cv
1949
de3f1649
JT
1950MODULE = B PACKAGE = B::CV PREFIX = cv_
1951
1952B::SV
1953cv_const_sv(cv)
1954 B::CV cv
1955
5cfd8ad4 1956
a8a597b2
MB
1957MODULE = B PACKAGE = B::HV PREFIX = Hv
1958
1959STRLEN
1960HvFILL(hv)
1961 B::HV hv
1962
1963STRLEN
1964HvMAX(hv)
1965 B::HV hv
1966
1967I32
1968HvKEYS(hv)
1969 B::HV hv
1970
1971I32
1972HvRITER(hv)
1973 B::HV hv
1974
1975char *
1976HvNAME(hv)
1977 B::HV hv
1978
edcc7c74
NC
1979#if PERL_VERSION < 9
1980
1981B::PMOP
1982HvPMROOT(hv)
1983 B::HV hv
1984
1985#endif
1986
a8a597b2
MB
1987void
1988HvARRAY(hv)
1989 B::HV hv
1990 PPCODE:
1991 if (HvKEYS(hv) > 0) {
1992 SV *sv;
1993 char *key;
1994 I32 len;
1995 (void)hv_iterinit(hv);
1996 EXTEND(sp, HvKEYS(hv) * 2);
8063af02 1997 while ((sv = hv_iternextsv(hv, &key, &len))) {
22f1178f 1998 mPUSHp(key, len);
9496d2e5 1999 PUSHs(make_sv_object(aTHX_ NULL, sv));
a8a597b2
MB
2000 }
2001 }
fd9f6265
JJ
2002
2003MODULE = B PACKAGE = B::HE PREFIX = He
2004
2005B::SV
2006HeVAL(he)
2007 B::HE he
2008
2009U32
2010HeHASH(he)
2011 B::HE he
2012
2013B::SV
2014HeSVKEY_force(he)
2015 B::HE he
2016
2017MODULE = B PACKAGE = B::RHE PREFIX = RHE_
2018
e412117e
NC
2019#if PERL_VERSION >= 9
2020
fd9f6265
JJ
2021SV*
2022RHE_HASH(h)
2023 B::RHE h
2024 CODE:
20439bc7 2025 RETVAL = newRV( (SV*)cophh_2hv(h, 0) );
fd9f6265
JJ
2026 OUTPUT:
2027 RETVAL
e412117e
NC
2028
2029#endif