This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Test NUL bytes with B::cstring() and B::perlstring().
[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
238static SV *
cea2e8a9 239make_sv_object(pTHX_ SV *arg, SV *sv)
a8a597b2 240{
27da23d5 241 const char *type = 0;
a8a597b2 242 IV iv;
89ca4ac7 243 dMY_CXT;
a8a597b2 244
e8edd1e6
TH
245 for (iv = 0; iv < sizeof(specialsv_list)/sizeof(SV*); iv++) {
246 if (sv == specialsv_list[iv]) {
a8a597b2
MB
247 type = "B::SPECIAL";
248 break;
249 }
250 }
251 if (!type) {
252 type = svclassnames[SvTYPE(sv)];
56431972 253 iv = PTR2IV(sv);
a8a597b2
MB
254 }
255 sv_setiv(newSVrv(arg, type), iv);
256 return arg;
257}
258
e412117e 259#if PERL_VERSION >= 9
a8a597b2 260static SV *
8e01d9a6
NC
261make_temp_object(pTHX_ SV *arg, SV *temp)
262{
263 SV *target;
264 const char *const type = svclassnames[SvTYPE(temp)];
265 const IV iv = PTR2IV(temp);
266
267 target = newSVrv(arg, type);
268 sv_setiv(target, iv);
269
270 /* Need to keep our "temp" around as long as the target exists.
271 Simplest way seems to be to hang it from magic, and let that clear
272 it up. No vtable, so won't actually get in the way of anything. */
273 sv_magicext(target, temp, PERL_MAGIC_sv, NULL, NULL, 0);
274 /* magic object has had its reference count increased, so we must drop
275 our reference. */
276 SvREFCNT_dec(temp);
277 return arg;
278}
279
280static SV *
5c3c3f81
NC
281make_warnings_object(pTHX_ SV *arg, STRLEN *warnings)
282{
283 const char *type = 0;
284 dMY_CXT;
285 IV iv = sizeof(specialsv_list)/sizeof(SV*);
286
287 /* Counting down is deliberate. Before the split between make_sv_object
288 and make_warnings_obj there appeared to be a bug - Nullsv and pWARN_STD
289 were both 0, so you could never get a B::SPECIAL for pWARN_STD */
290
291 while (iv--) {
292 if ((SV*)warnings == specialsv_list[iv]) {
293 type = "B::SPECIAL";
294 break;
295 }
296 }
297 if (type) {
298 sv_setiv(newSVrv(arg, type), iv);
8e01d9a6 299 return arg;
5c3c3f81
NC
300 } else {
301 /* B assumes that warnings are a regular SV. Seems easier to keep it
302 happy by making them into a regular SV. */
8e01d9a6
NC
303 return make_temp_object(aTHX_ arg,
304 newSVpvn((char *)(warnings + 1), *warnings));
305 }
306}
307
308static SV *
309make_cop_io_object(pTHX_ SV *arg, COP *cop)
310{
8b850bd5
NC
311 SV *const value = newSV(0);
312
33972ad6 313 Perl_emulate_cop_io(aTHX_ cop, value);
8b850bd5
NC
314
315 if(SvOK(value)) {
8e01d9a6
NC
316 return make_temp_object(aTHX_ arg, newSVsv(value));
317 } else {
8b850bd5 318 SvREFCNT_dec(value);
8e01d9a6 319 return make_sv_object(aTHX_ arg, NULL);
5c3c3f81 320 }
5c3c3f81 321}
e412117e 322#endif
5c3c3f81
NC
323
324static SV *
cea2e8a9 325make_mg_object(pTHX_ SV *arg, MAGIC *mg)
a8a597b2 326{
56431972 327 sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg));
a8a597b2
MB
328 return arg;
329}
330
331static SV *
52ad86de 332cstring(pTHX_ SV *sv, bool perlstyle)
a8a597b2 333{
6beb30a6 334 SV *sstr = newSVpvs("");
a8a597b2
MB
335
336 if (!SvOK(sv))
6beb30a6 337 sv_setpvs(sstr, "0");
5d7488b2 338 else if (perlstyle && SvUTF8(sv)) {
d79a7a3d 339 SV *tmpsv = sv_newmortal(); /* Temporary SV to feed sv_uni_display */
5d7488b2
AL
340 const STRLEN len = SvCUR(sv);
341 const char *s = sv_uni_display(tmpsv, sv, 8*len, UNI_DISPLAY_QQ);
6beb30a6 342 sv_setpvs(sstr,"\"");
d79a7a3d
RGS
343 while (*s)
344 {
345 if (*s == '"')
6beb30a6 346 sv_catpvs(sstr, "\\\"");
d79a7a3d 347 else if (*s == '$')
6beb30a6 348 sv_catpvs(sstr, "\\$");
d79a7a3d 349 else if (*s == '@')
6beb30a6 350 sv_catpvs(sstr, "\\@");
d79a7a3d
RGS
351 else if (*s == '\\')
352 {
353 if (strchr("nrftax\\",*(s+1)))
354 sv_catpvn(sstr, s++, 2);
355 else
6beb30a6 356 sv_catpvs(sstr, "\\\\");
d79a7a3d
RGS
357 }
358 else /* should always be printable */
359 sv_catpvn(sstr, s, 1);
360 ++s;
361 }
6beb30a6 362 sv_catpvs(sstr, "\"");
d79a7a3d
RGS
363 return sstr;
364 }
a8a597b2
MB
365 else
366 {
367 /* XXX Optimise? */
5d7488b2
AL
368 STRLEN len;
369 const char *s = SvPV(sv, len);
6beb30a6 370 sv_catpvs(sstr, "\"");
a8a597b2
MB
371 for (; len; len--, s++)
372 {
373 /* At least try a little for readability */
374 if (*s == '"')
6beb30a6 375 sv_catpvs(sstr, "\\\"");
a8a597b2 376 else if (*s == '\\')
6beb30a6 377 sv_catpvs(sstr, "\\\\");
b326da91 378 /* trigraphs - bleagh */
5d7488b2 379 else if (!perlstyle && *s == '?' && len>=3 && s[1] == '?') {
47bf35fa 380 Perl_sv_catpvf(aTHX_ sstr, "\\%03o", '?');
b326da91 381 }
52ad86de 382 else if (perlstyle && *s == '$')
6beb30a6 383 sv_catpvs(sstr, "\\$");
52ad86de 384 else if (perlstyle && *s == '@')
6beb30a6 385 sv_catpvs(sstr, "\\@");
ce561ef2
JH
386#ifdef EBCDIC
387 else if (isPRINT(*s))
388#else
389 else if (*s >= ' ' && *s < 127)
390#endif /* EBCDIC */
a8a597b2
MB
391 sv_catpvn(sstr, s, 1);
392 else if (*s == '\n')
6beb30a6 393 sv_catpvs(sstr, "\\n");
a8a597b2 394 else if (*s == '\r')
6beb30a6 395 sv_catpvs(sstr, "\\r");
a8a597b2 396 else if (*s == '\t')
6beb30a6 397 sv_catpvs(sstr, "\\t");
a8a597b2 398 else if (*s == '\a')
6beb30a6 399 sv_catpvs(sstr, "\\a");
a8a597b2 400 else if (*s == '\b')
6beb30a6 401 sv_catpvs(sstr, "\\b");
a8a597b2 402 else if (*s == '\f')
6beb30a6 403 sv_catpvs(sstr, "\\f");
52ad86de 404 else if (!perlstyle && *s == '\v')
6beb30a6 405 sv_catpvs(sstr, "\\v");
a8a597b2
MB
406 else
407 {
a8a597b2 408 /* Don't want promotion of a signed -1 char in sprintf args */
5d7488b2 409 const unsigned char c = (unsigned char) *s;
47bf35fa 410 Perl_sv_catpvf(aTHX_ sstr, "\\%03o", c);
a8a597b2
MB
411 }
412 /* XXX Add line breaks if string is long */
413 }
6beb30a6 414 sv_catpvs(sstr, "\"");
a8a597b2
MB
415 }
416 return sstr;
417}
418
419static SV *
cea2e8a9 420cchar(pTHX_ SV *sv)
a8a597b2 421{
6beb30a6 422 SV *sstr = newSVpvs("'");
5d7488b2 423 const char *s = SvPV_nolen(sv);
a8a597b2
MB
424
425 if (*s == '\'')
6beb30a6 426 sv_catpvs(sstr, "\\'");
a8a597b2 427 else if (*s == '\\')
6beb30a6 428 sv_catpvs(sstr, "\\\\");
ce561ef2 429#ifdef EBCDIC
133b4094 430 else if (isPRINT(*s))
ce561ef2
JH
431#else
432 else if (*s >= ' ' && *s < 127)
433#endif /* EBCDIC */
a8a597b2
MB
434 sv_catpvn(sstr, s, 1);
435 else if (*s == '\n')
6beb30a6 436 sv_catpvs(sstr, "\\n");
a8a597b2 437 else if (*s == '\r')
6beb30a6 438 sv_catpvs(sstr, "\\r");
a8a597b2 439 else if (*s == '\t')
6beb30a6 440 sv_catpvs(sstr, "\\t");
a8a597b2 441 else if (*s == '\a')
6beb30a6 442 sv_catpvs(sstr, "\\a");
a8a597b2 443 else if (*s == '\b')
6beb30a6 444 sv_catpvs(sstr, "\\b");
a8a597b2 445 else if (*s == '\f')
6beb30a6 446 sv_catpvs(sstr, "\\f");
a8a597b2 447 else if (*s == '\v')
6beb30a6 448 sv_catpvs(sstr, "\\v");
a8a597b2
MB
449 else
450 {
451 /* no trigraph support */
452 char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
453 /* Don't want promotion of a signed -1 char in sprintf args */
454 unsigned char c = (unsigned char) *s;
6beb30a6
NC
455 const STRLEN oct_len = my_sprintf(escbuff, "\\%03o", c);
456 sv_catpvn(sstr, escbuff, oct_len);
a8a597b2 457 }
6beb30a6 458 sv_catpvs(sstr, "'");
a8a597b2
MB
459 return sstr;
460}
461
8f3d514b
JC
462#if PERL_VERSION >= 9
463# define PMOP_pmreplstart(o) o->op_pmstashstartu.op_pmreplstart
464# define PMOP_pmreplroot(o) o->op_pmreplrootu.op_pmreplroot
465#else
466# define PMOP_pmreplstart(o) o->op_pmreplstart
467# define PMOP_pmreplroot(o) o->op_pmreplroot
468# define PMOP_pmpermflags(o) o->op_pmpermflags
469# define PMOP_pmdynflags(o) o->op_pmdynflags
470#endif
471
5d7488b2
AL
472static void
473walkoptree(pTHX_ SV *opsv, const char *method)
a8a597b2
MB
474{
475 dSP;
f3be9b72 476 OP *o, *kid;
89ca4ac7
JH
477 dMY_CXT;
478
a8a597b2
MB
479 if (!SvROK(opsv))
480 croak("opsv is not a reference");
481 opsv = sv_mortalcopy(opsv);
56431972 482 o = INT2PTR(OP*,SvIV((SV*)SvRV(opsv)));
a8a597b2
MB
483 if (walkoptree_debug) {
484 PUSHMARK(sp);
485 XPUSHs(opsv);
486 PUTBACK;
487 perl_call_method("walkoptree_debug", G_DISCARD);
488 }
489 PUSHMARK(sp);
490 XPUSHs(opsv);
491 PUTBACK;
492 perl_call_method(method, G_DISCARD);
493 if (o && (o->op_flags & OPf_KIDS)) {
a8a597b2
MB
494 for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) {
495 /* Use the same opsv. Rely on methods not to mess it up. */
56431972 496 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
cea2e8a9 497 walkoptree(aTHX_ opsv, method);
a8a597b2
MB
498 }
499 }
5464c149 500 if (o && (cc_opclass(aTHX_ o) == OPc_PMOP) && o->op_type != OP_PUSHRE
8f3d514b 501 && (kid = PMOP_pmreplroot(cPMOPo)))
f3be9b72 502 {
5464c149 503 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
f3be9b72
RGS
504 walkoptree(aTHX_ opsv, method);
505 }
a8a597b2
MB
506}
507
5d7488b2 508static SV **
1df34986
AE
509oplist(pTHX_ OP *o, SV **SP)
510{
511 for(; o; o = o->op_next) {
512 SV *opsv;
7252851f
NC
513#if PERL_VERSION >= 9
514 if (o->op_opt == 0)
1df34986 515 break;
2814eb74 516 o->op_opt = 0;
7252851f
NC
517#else
518 if (o->op_seq == 0)
519 break;
520 o->op_seq = 0;
521#endif
1df34986
AE
522 opsv = sv_newmortal();
523 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ (OP*)o)), PTR2IV(o));
524 XPUSHs(opsv);
525 switch (o->op_type) {
526 case OP_SUBST:
8f3d514b 527 SP = oplist(aTHX_ PMOP_pmreplstart(cPMOPo), SP);
1df34986
AE
528 continue;
529 case OP_SORT:
f66c782a 530 if (o->op_flags & OPf_STACKED && o->op_flags & OPf_SPECIAL) {
1df34986
AE
531 OP *kid = cLISTOPo->op_first->op_sibling; /* pass pushmark */
532 kid = kUNOP->op_first; /* pass rv2gv */
533 kid = kUNOP->op_first; /* pass leave */
f66c782a 534 SP = oplist(aTHX_ kid->op_next, SP);
1df34986
AE
535 }
536 continue;
537 }
538 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
539 case OA_LOGOP:
540 SP = oplist(aTHX_ cLOGOPo->op_other, SP);
541 break;
542 case OA_LOOP:
543 SP = oplist(aTHX_ cLOOPo->op_lastop, SP);
544 SP = oplist(aTHX_ cLOOPo->op_nextop, SP);
545 SP = oplist(aTHX_ cLOOPo->op_redoop, SP);
546 break;
547 }
548 }
549 return SP;
550}
551
a8a597b2
MB
552typedef OP *B__OP;
553typedef UNOP *B__UNOP;
554typedef BINOP *B__BINOP;
555typedef LOGOP *B__LOGOP;
a8a597b2
MB
556typedef LISTOP *B__LISTOP;
557typedef PMOP *B__PMOP;
558typedef SVOP *B__SVOP;
7934575e 559typedef PADOP *B__PADOP;
a8a597b2
MB
560typedef PVOP *B__PVOP;
561typedef LOOP *B__LOOP;
562typedef COP *B__COP;
563
564typedef SV *B__SV;
565typedef SV *B__IV;
566typedef SV *B__PV;
567typedef SV *B__NV;
568typedef SV *B__PVMG;
5c35adbb
NC
569#if PERL_VERSION >= 11
570typedef SV *B__REGEXP;
571#endif
a8a597b2
MB
572typedef SV *B__PVLV;
573typedef SV *B__BM;
574typedef SV *B__RV;
1df34986 575typedef SV *B__FM;
a8a597b2
MB
576typedef AV *B__AV;
577typedef HV *B__HV;
578typedef CV *B__CV;
579typedef GV *B__GV;
580typedef IO *B__IO;
581
582typedef MAGIC *B__MAGIC;
fd9f6265 583typedef HE *B__HE;
e412117e 584#if PERL_VERSION >= 9
fd9f6265 585typedef struct refcounted_he *B__RHE;
e412117e 586#endif
a8a597b2 587
b1826b71
NC
588#include "const-c.inc"
589
a8a597b2
MB
590MODULE = B PACKAGE = B PREFIX = B_
591
b1826b71
NC
592INCLUDE: const-xs.inc
593
a8a597b2
MB
594PROTOTYPES: DISABLE
595
596BOOT:
4c1f658f 597{
6beb30a6 598 HV *stash = gv_stashpvs("B", GV_ADD);
cbfd0a87 599 AV *export_ok = perl_get_av("B::EXPORT_OK", GV_ADD);
89ca4ac7 600 MY_CXT_INIT;
e8edd1e6
TH
601 specialsv_list[0] = Nullsv;
602 specialsv_list[1] = &PL_sv_undef;
603 specialsv_list[2] = &PL_sv_yes;
604 specialsv_list[3] = &PL_sv_no;
5c3c3f81
NC
605 specialsv_list[4] = (SV *) pWARN_ALL;
606 specialsv_list[5] = (SV *) pWARN_NONE;
607 specialsv_list[6] = (SV *) pWARN_STD;
f5ba1307 608#if PERL_VERSION <= 8
e6663653 609# define OPpPAD_STATE 0
7252851f 610#endif
4c1f658f 611}
a8a597b2 612
3280af22 613#define B_main_cv() PL_main_cv
31d7d75a 614#define B_init_av() PL_initav
651aa52e 615#define B_inc_gv() PL_incgv
ece599bd 616#define B_check_av() PL_checkav_save
e6663653
NC
617#if PERL_VERSION > 8
618# define B_unitcheck_av() PL_unitcheckav_save
619#else
620# define B_unitcheck_av() NULL
621#endif
059a8bb7
JH
622#define B_begin_av() PL_beginav_save
623#define B_end_av() PL_endav
3280af22
NIS
624#define B_main_root() PL_main_root
625#define B_main_start() PL_main_start
56eca212 626#define B_amagic_generation() PL_amagic_generation
5ce57cc0 627#define B_sub_generation() PL_sub_generation
651aa52e
AE
628#define B_defstash() PL_defstash
629#define B_curstash() PL_curstash
630#define B_dowarn() PL_dowarn
3280af22
NIS
631#define B_comppadlist() (PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv))
632#define B_sv_undef() &PL_sv_undef
633#define B_sv_yes() &PL_sv_yes
634#define B_sv_no() &PL_sv_no
1df34986 635#define B_formfeed() PL_formfeed
9d2bbe64
MB
636#ifdef USE_ITHREADS
637#define B_regex_padav() PL_regex_padav
638#endif
a8a597b2 639
31d7d75a
NIS
640B::AV
641B_init_av()
642
059a8bb7 643B::AV
ece599bd
RGS
644B_check_av()
645
e412117e
NC
646#if PERL_VERSION >= 9
647
ece599bd 648B::AV
676456c2
AG
649B_unitcheck_av()
650
e412117e
NC
651#endif
652
676456c2 653B::AV
059a8bb7
JH
654B_begin_av()
655
656B::AV
657B_end_av()
658
651aa52e
AE
659B::GV
660B_inc_gv()
661
9d2bbe64
MB
662#ifdef USE_ITHREADS
663
664B::AV
665B_regex_padav()
666
667#endif
668
a8a597b2
MB
669B::CV
670B_main_cv()
671
672B::OP
673B_main_root()
674
675B::OP
676B_main_start()
677
56eca212
GS
678long
679B_amagic_generation()
680
5ce57cc0
JJ
681long
682B_sub_generation()
683
a8a597b2
MB
684B::AV
685B_comppadlist()
686
687B::SV
688B_sv_undef()
689
690B::SV
691B_sv_yes()
692
693B::SV
694B_sv_no()
695
651aa52e
AE
696B::HV
697B_curstash()
698
699B::HV
700B_defstash()
a8a597b2 701
651aa52e
AE
702U8
703B_dowarn()
704
1df34986
AE
705B::SV
706B_formfeed()
707
651aa52e
AE
708void
709B_warnhook()
710 CODE:
711 ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_warnhook);
712
713void
714B_diehook()
715 CODE:
716 ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_diehook);
717
718MODULE = B PACKAGE = B
a8a597b2
MB
719
720void
721walkoptree(opsv, method)
722 SV * opsv
5d7488b2 723 const char * method
cea2e8a9
GS
724 CODE:
725 walkoptree(aTHX_ opsv, method);
a8a597b2
MB
726
727int
728walkoptree_debug(...)
729 CODE:
89ca4ac7 730 dMY_CXT;
a8a597b2
MB
731 RETVAL = walkoptree_debug;
732 if (items > 0 && SvTRUE(ST(1)))
733 walkoptree_debug = 1;
734 OUTPUT:
735 RETVAL
736
56431972 737#define address(sv) PTR2IV(sv)
a8a597b2
MB
738
739IV
740address(sv)
741 SV * sv
742
743B::SV
744svref_2object(sv)
745 SV * sv
746 CODE:
747 if (!SvROK(sv))
748 croak("argument is not a reference");
749 RETVAL = (SV*)SvRV(sv);
750 OUTPUT:
0cc1d052
NIS
751 RETVAL
752
753void
754opnumber(name)
5d7488b2 755const char * name
0cc1d052
NIS
756CODE:
757{
758 int i;
759 IV result = -1;
760 ST(0) = sv_newmortal();
761 if (strncmp(name,"pp_",3) == 0)
762 name += 3;
763 for (i = 0; i < PL_maxo; i++)
764 {
765 if (strcmp(name, PL_op_name[i]) == 0)
766 {
767 result = i;
768 break;
769 }
770 }
771 sv_setiv(ST(0),result);
772}
a8a597b2
MB
773
774void
775ppname(opnum)
776 int opnum
777 CODE:
778 ST(0) = sv_newmortal();
3280af22 779 if (opnum >= 0 && opnum < PL_maxo) {
6beb30a6 780 sv_setpvs(ST(0), "pp_");
22c35a8c 781 sv_catpv(ST(0), PL_op_name[opnum]);
a8a597b2
MB
782 }
783
784void
785hash(sv)
786 SV * sv
787 CODE:
a8a597b2
MB
788 STRLEN len;
789 U32 hash = 0;
faccc32b 790 char hexhash[19]; /* must fit "0xffffffffffffffff" plus trailing \0 */
5d7488b2 791 const char *s = SvPV(sv, len);
c32d3395 792 PERL_HASH(hash, s, len);
6beb30a6 793 len = my_sprintf(hexhash, "0x%"UVxf, (UV)hash);
d3d34884 794 ST(0) = newSVpvn_flags(hexhash, len, SVs_TEMP);
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
cea2e8a9 816 CODE:
84556172 817 RETVAL = cstring(aTHX_ sv, ix);
cea2e8a9
GS
818 OUTPUT:
819 RETVAL
a8a597b2
MB
820
821SV *
822cchar(sv)
823 SV * sv
cea2e8a9
GS
824 CODE:
825 RETVAL = cchar(aTHX_ sv);
826 OUTPUT:
827 RETVAL
a8a597b2
MB
828
829void
830threadsv_names()
831 PPCODE:
f5ba1307
NC
832#if PERL_VERSION <= 8
833# ifdef USE_5005THREADS
834 int i;
5d7488b2 835 const STRLEN len = strlen(PL_threadsv_names);
f5ba1307
NC
836
837 EXTEND(sp, len);
838 for (i = 0; i < len; i++)
d3d34884 839 PUSHs(newSVpvn_flags(&PL_threadsv_names[i], 1, SVs_TEMP));
f5ba1307
NC
840# endif
841#endif
a8a597b2
MB
842
843#define OP_next(o) o->op_next
844#define OP_sibling(o) o->op_sibling
27da23d5 845#define OP_desc(o) (char *)PL_op_desc[o->op_type]
a8a597b2
MB
846#define OP_targ(o) o->op_targ
847#define OP_type(o) o->op_type
7252851f
NC
848#if PERL_VERSION >= 9
849# define OP_opt(o) o->op_opt
7252851f
NC
850#else
851# define OP_seq(o) o->op_seq
852#endif
a8a597b2
MB
853#define OP_flags(o) o->op_flags
854#define OP_private(o) o->op_private
a60ba18b 855#define OP_spare(o) o->op_spare
a8a597b2
MB
856
857MODULE = B PACKAGE = B::OP PREFIX = OP_
858
651aa52e
AE
859size_t
860OP_size(o)
861 B::OP o
862 CODE:
863 RETVAL = opsizes[cc_opclass(aTHX_ o)];
864 OUTPUT:
865 RETVAL
866
a8a597b2
MB
867B::OP
868OP_next(o)
869 B::OP o
870
871B::OP
872OP_sibling(o)
873 B::OP o
874
875char *
3f872cb9
GS
876OP_name(o)
877 B::OP o
878 CODE:
27da23d5 879 RETVAL = (char *)PL_op_name[o->op_type];
8063af02
DM
880 OUTPUT:
881 RETVAL
3f872cb9
GS
882
883
8063af02 884void
a8a597b2
MB
885OP_ppaddr(o)
886 B::OP o
dc333d64
GS
887 PREINIT:
888 int i;
889 SV *sv = sv_newmortal();
a8a597b2 890 CODE:
6beb30a6 891 sv_setpvs(sv, "PL_ppaddr[OP_");
dc333d64 892 sv_catpv(sv, PL_op_name[o->op_type]);
7c436af3 893 for (i=13; (STRLEN)i < SvCUR(sv); ++i)
dc333d64 894 SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]);
6beb30a6 895 sv_catpvs(sv, "]");
dc333d64 896 ST(0) = sv;
a8a597b2
MB
897
898char *
899OP_desc(o)
900 B::OP o
901
7934575e 902PADOFFSET
a8a597b2
MB
903OP_targ(o)
904 B::OP o
905
906U16
907OP_type(o)
908 B::OP o
909
7252851f
NC
910#if PERL_VERSION >= 9
911
0053d415 912U16
2814eb74
PJ
913OP_opt(o)
914 B::OP o
915
7252851f
NC
916#else
917
918U16
919OP_seq(o)
920 B::OP o
921
922#endif
923
a8a597b2
MB
924U8
925OP_flags(o)
926 B::OP o
927
928U8
929OP_private(o)
930 B::OP o
931
7252851f
NC
932#if PERL_VERSION >= 9
933
0053d415 934U16
a60ba18b
JC
935OP_spare(o)
936 B::OP o
937
7252851f
NC
938#endif
939
1df34986
AE
940void
941OP_oplist(o)
942 B::OP o
943 PPCODE:
944 SP = oplist(aTHX_ o, SP);
945
a8a597b2
MB
946#define UNOP_first(o) o->op_first
947
948MODULE = B PACKAGE = B::UNOP PREFIX = UNOP_
949
950B::OP
951UNOP_first(o)
952 B::UNOP o
953
954#define BINOP_last(o) o->op_last
955
956MODULE = B PACKAGE = B::BINOP PREFIX = BINOP_
957
958B::OP
959BINOP_last(o)
960 B::BINOP o
961
962#define LOGOP_other(o) o->op_other
963
964MODULE = B PACKAGE = B::LOGOP PREFIX = LOGOP_
965
966B::OP
967LOGOP_other(o)
968 B::LOGOP o
969
a8a597b2
MB
970MODULE = B PACKAGE = B::LISTOP PREFIX = LISTOP_
971
c03c2844
SM
972U32
973LISTOP_children(o)
974 B::LISTOP o
975 OP * kid = NO_INIT
976 int i = NO_INIT
977 CODE:
c03c2844
SM
978 i = 0;
979 for (kid = o->op_first; kid; kid = kid->op_sibling)
980 i++;
8063af02
DM
981 RETVAL = i;
982 OUTPUT:
983 RETVAL
c03c2844 984
a8a597b2 985#define PMOP_pmnext(o) o->op_pmnext
aaa362c4 986#define PMOP_pmregexp(o) PM_GETRE(o)
9d2bbe64
MB
987#ifdef USE_ITHREADS
988#define PMOP_pmoffset(o) o->op_pmoffset
29f2e912 989#define PMOP_pmstashpv(o) PmopSTASHPV(o);
651aa52e 990#else
29f2e912 991#define PMOP_pmstash(o) PmopSTASH(o);
9d2bbe64 992#endif
a8a597b2 993#define PMOP_pmflags(o) o->op_pmflags
a8a597b2
MB
994
995MODULE = B PACKAGE = B::PMOP PREFIX = PMOP_
996
20e98b0f
NC
997#if PERL_VERSION <= 8
998
a8a597b2
MB
999void
1000PMOP_pmreplroot(o)
1001 B::PMOP o
1002 OP * root = NO_INIT
1003 CODE:
1004 ST(0) = sv_newmortal();
1005 root = o->op_pmreplroot;
1006 /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */
1007 if (o->op_type == OP_PUSHRE) {
20e98b0f 1008# ifdef USE_ITHREADS
9d2bbe64 1009 sv_setiv(ST(0), INT2PTR(PADOFFSET,root) );
20e98b0f 1010# else
a8a597b2
MB
1011 sv_setiv(newSVrv(ST(0), root ?
1012 svclassnames[SvTYPE((SV*)root)] : "B::SV"),
56431972 1013 PTR2IV(root));
20e98b0f 1014# endif
a8a597b2
MB
1015 }
1016 else {
56431972 1017 sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root));
a8a597b2
MB
1018 }
1019
20e98b0f
NC
1020#else
1021
1022void
1023PMOP_pmreplroot(o)
1024 B::PMOP o
1025 CODE:
1026 ST(0) = sv_newmortal();
1027 if (o->op_type == OP_PUSHRE) {
1028# ifdef USE_ITHREADS
1029 sv_setiv(ST(0), o->op_pmreplrootu.op_pmtargetoff);
1030# else
1031 GV *const target = o->op_pmreplrootu.op_pmtargetgv;
1032 sv_setiv(newSVrv(ST(0), target ?
1033 svclassnames[SvTYPE((SV*)target)] : "B::SV"),
1034 PTR2IV(target));
1035# endif
1036 }
1037 else {
1038 OP *const root = o->op_pmreplrootu.op_pmreplroot;
1039 sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)),
1040 PTR2IV(root));
1041 }
1042
1043#endif
1044
a8a597b2
MB
1045B::OP
1046PMOP_pmreplstart(o)
1047 B::PMOP o
1048
c2b1997a
NC
1049#if PERL_VERSION < 9
1050
a8a597b2
MB
1051B::PMOP
1052PMOP_pmnext(o)
1053 B::PMOP o
1054
c2b1997a
NC
1055#endif
1056
9d2bbe64
MB
1057#ifdef USE_ITHREADS
1058
1059IV
1060PMOP_pmoffset(o)
1061 B::PMOP o
1062
651aa52e
AE
1063char*
1064PMOP_pmstashpv(o)
1065 B::PMOP o
1066
1067#else
1068
1069B::HV
1070PMOP_pmstash(o)
1071 B::PMOP o
1072
9d2bbe64
MB
1073#endif
1074
6e21dc91 1075U32
a8a597b2
MB
1076PMOP_pmflags(o)
1077 B::PMOP o
1078
7c1f70cb
NC
1079#if PERL_VERSION < 9
1080
1081U32
1082PMOP_pmpermflags(o)
1083 B::PMOP o
1084
1085U8
1086PMOP_pmdynflags(o)
1087 B::PMOP o
1088
1089#endif
1090
a8a597b2
MB
1091void
1092PMOP_precomp(o)
1093 B::PMOP o
1094 REGEXP * rx = NO_INIT
1095 CODE:
1096 ST(0) = sv_newmortal();
aaa362c4 1097 rx = PM_GETRE(o);
a8a597b2 1098 if (rx)
220fc49f 1099 sv_setpvn(ST(0), RX_PRECOMP(rx), RX_PRELEN(rx));
a8a597b2 1100
7c1f70cb
NC
1101#if PERL_VERSION >= 9
1102
c737faaf
YO
1103void
1104PMOP_reflags(o)
1105 B::PMOP o
1106 REGEXP * rx = NO_INIT
1107 CODE:
1108 ST(0) = sv_newmortal();
1109 rx = PM_GETRE(o);
1110 if (rx)
07bc277f 1111 sv_setuv(ST(0), RX_EXTFLAGS(rx));
c737faaf 1112
7c1f70cb
NC
1113#endif
1114
ac33dcd1
JH
1115#define SVOP_sv(o) cSVOPo->op_sv
1116#define SVOP_gv(o) ((GV*)cSVOPo->op_sv)
a8a597b2
MB
1117
1118MODULE = B PACKAGE = B::SVOP PREFIX = SVOP_
1119
a8a597b2
MB
1120B::SV
1121SVOP_sv(o)
1122 B::SVOP o
1123
f22444f5 1124B::GV
065a1863
GS
1125SVOP_gv(o)
1126 B::SVOP o
1127
7934575e 1128#define PADOP_padix(o) o->op_padix
dd2155a4 1129#define PADOP_sv(o) (o->op_padix ? PAD_SVl(o->op_padix) : Nullsv)
7934575e 1130#define PADOP_gv(o) ((o->op_padix \
dd2155a4 1131 && SvTYPE(PAD_SVl(o->op_padix)) == SVt_PVGV) \
3ae1b226 1132 ? (GV*)PAD_SVl(o->op_padix) : (GV *)NULL)
a8a597b2 1133
7934575e
GS
1134MODULE = B PACKAGE = B::PADOP PREFIX = PADOP_
1135
1136PADOFFSET
1137PADOP_padix(o)
1138 B::PADOP o
1139
1140B::SV
1141PADOP_sv(o)
1142 B::PADOP o
a8a597b2
MB
1143
1144B::GV
7934575e
GS
1145PADOP_gv(o)
1146 B::PADOP o
a8a597b2
MB
1147
1148MODULE = B PACKAGE = B::PVOP PREFIX = PVOP_
1149
1150void
1151PVOP_pv(o)
1152 B::PVOP o
1153 CODE:
1154 /*
bec89253 1155 * OP_TRANS uses op_pv to point to a table of 256 or >=258 shorts
a8a597b2
MB
1156 * whereas other PVOPs point to a null terminated string.
1157 */
bec89253
RH
1158 if (o->op_type == OP_TRANS &&
1159 (o->op_private & OPpTRANS_COMPLEMENT) &&
1160 !(o->op_private & OPpTRANS_DELETE))
1161 {
5d7488b2
AL
1162 const short* const tbl = (short*)o->op_pv;
1163 const short entries = 257 + tbl[256];
d3d34884 1164 ST(0) = newSVpvn_flags(o->op_pv, entries * sizeof(short), SVs_TEMP);
bec89253
RH
1165 }
1166 else if (o->op_type == OP_TRANS) {
d3d34884 1167 ST(0) = newSVpvn_flags(o->op_pv, 256 * sizeof(short), SVs_TEMP);
bec89253
RH
1168 }
1169 else
d3d34884 1170 ST(0) = newSVpvn_flags(o->op_pv, strlen(o->op_pv), SVs_TEMP);
a8a597b2
MB
1171
1172#define LOOP_redoop(o) o->op_redoop
1173#define LOOP_nextop(o) o->op_nextop
1174#define LOOP_lastop(o) o->op_lastop
1175
1176MODULE = B PACKAGE = B::LOOP PREFIX = LOOP_
1177
1178
1179B::OP
1180LOOP_redoop(o)
1181 B::LOOP o
1182
1183B::OP
1184LOOP_nextop(o)
1185 B::LOOP o
1186
1187B::OP
1188LOOP_lastop(o)
1189 B::LOOP o
1190
4b65a919 1191#define COP_label(o) CopLABEL(o)
11faa288
GS
1192#define COP_stashpv(o) CopSTASHPV(o)
1193#define COP_stash(o) CopSTASH(o)
57843af0 1194#define COP_file(o) CopFILE(o)
1df34986 1195#define COP_filegv(o) CopFILEGV(o)
a8a597b2 1196#define COP_cop_seq(o) o->cop_seq
fc15ae8f 1197#define COP_arybase(o) CopARYBASE_get(o)
57843af0 1198#define COP_line(o) CopLINE(o)
d5ec2987 1199#define COP_hints(o) CopHINTS_get(o)
e412117e
NC
1200#if PERL_VERSION < 9
1201# define COP_warnings(o) o->cop_warnings
1202# define COP_io(o) o->cop_io
1203#endif
a8a597b2
MB
1204
1205MODULE = B PACKAGE = B::COP PREFIX = COP_
1206
d5b8ed54
NC
1207#if PERL_VERSION >= 11
1208
1209const char *
1210COP_label(o)
1211 B::COP o
1212
1213#else
1214
a8a597b2
MB
1215char *
1216COP_label(o)
1217 B::COP o
1218
d5b8ed54
NC
1219#endif
1220
11faa288
GS
1221char *
1222COP_stashpv(o)
1223 B::COP o
1224
a8a597b2
MB
1225B::HV
1226COP_stash(o)
1227 B::COP o
1228
57843af0
GS
1229char *
1230COP_file(o)
a8a597b2
MB
1231 B::COP o
1232
1df34986
AE
1233B::GV
1234COP_filegv(o)
1235 B::COP o
1236
1237
a8a597b2
MB
1238U32
1239COP_cop_seq(o)
1240 B::COP o
1241
1242I32
1243COP_arybase(o)
1244 B::COP o
1245
8bafa735 1246U32
a8a597b2
MB
1247COP_line(o)
1248 B::COP o
1249
e412117e
NC
1250#if PERL_VERSION >= 9
1251
5c3c3f81 1252void
b295d113
TH
1253COP_warnings(o)
1254 B::COP o
5c3c3f81
NC
1255 PPCODE:
1256 ST(0) = make_warnings_object(aTHX_ sv_newmortal(), o->cop_warnings);
1257 XSRETURN(1);
b295d113 1258
670f1322 1259void
6e6a1aef
RGS
1260COP_io(o)
1261 B::COP o
11bcd5da 1262 PPCODE:
8e01d9a6 1263 ST(0) = make_cop_io_object(aTHX_ sv_newmortal(), o);
11bcd5da 1264 XSRETURN(1);
6e6a1aef 1265
fd9f6265
JJ
1266B::RHE
1267COP_hints_hash(o)
1268 B::COP o
1269 CODE:
20439bc7 1270 RETVAL = CopHINTHASH_get(o);
fd9f6265
JJ
1271 OUTPUT:
1272 RETVAL
1273
e412117e
NC
1274#else
1275
1276B::SV
1277COP_warnings(o)
1278 B::COP o
1279
1280B::SV
1281COP_io(o)
1282 B::COP o
1283
1284#endif
1285
1286U32
1287COP_hints(o)
1288 B::COP o
1289
651aa52e
AE
1290MODULE = B PACKAGE = B::SV
1291
1292U32
1293SvTYPE(sv)
1294 B::SV sv
1295
429a5ce7
SM
1296#define object_2svref(sv) sv
1297#define SVREF SV *
1298
1299SVREF
1300object_2svref(sv)
1301 B::SV sv
1302
a8a597b2
MB
1303MODULE = B PACKAGE = B::SV PREFIX = Sv
1304
1305U32
1306SvREFCNT(sv)
1307 B::SV sv
1308
1309U32
1310SvFLAGS(sv)
1311 B::SV sv
1312
651aa52e
AE
1313U32
1314SvPOK(sv)
1315 B::SV sv
1316
1317U32
1318SvROK(sv)
1319 B::SV sv
1320
1321U32
1322SvMAGICAL(sv)
1323 B::SV sv
1324
a8a597b2
MB
1325MODULE = B PACKAGE = B::IV PREFIX = Sv
1326
1327IV
1328SvIV(sv)
1329 B::IV sv
1330
1331IV
1332SvIVX(sv)
1333 B::IV sv
1334
0ca04487
VB
1335UV
1336SvUVX(sv)
1337 B::IV sv
1338
1339
a8a597b2
MB
1340MODULE = B PACKAGE = B::IV
1341
1342#define needs64bits(sv) ((I32)SvIVX(sv) != SvIVX(sv))
1343
1344int
1345needs64bits(sv)
1346 B::IV sv
1347
1348void
1349packiv(sv)
1350 B::IV sv
1351 CODE:
1352 if (sizeof(IV) == 8) {
1353 U32 wp[2];
5d7488b2 1354 const IV iv = SvIVX(sv);
a8a597b2
MB
1355 /*
1356 * The following way of spelling 32 is to stop compilers on
1357 * 32-bit architectures from moaning about the shift count
1358 * being >= the width of the type. Such architectures don't
1359 * reach this code anyway (unless sizeof(IV) > 8 but then
1360 * everything else breaks too so I'm not fussed at the moment).
1361 */
42718184
RB
1362#ifdef UV_IS_QUAD
1363 wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1364#else
1365 wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1366#endif
a8a597b2 1367 wp[1] = htonl(iv & 0xffffffff);
d3d34884 1368 ST(0) = newSVpvn_flags((char *)wp, 8, SVs_TEMP);
a8a597b2
MB
1369 } else {
1370 U32 w = htonl((U32)SvIVX(sv));
d3d34884 1371 ST(0) = newSVpvn_flags((char *)&w, 4, SVs_TEMP);
a8a597b2
MB
1372 }
1373
4df7f6af
NC
1374
1375#if PERL_VERSION >= 11
1376
1377B::SV
1378RV(sv)
1379 B::IV sv
1380 CODE:
1381 if( SvROK(sv) ) {
1382 RETVAL = SvRV(sv);
1383 }
1384 else {
1385 croak( "argument is not SvROK" );
1386 }
1387 OUTPUT:
1388 RETVAL
1389
1390#endif
1391
a8a597b2
MB
1392MODULE = B PACKAGE = B::NV PREFIX = Sv
1393
76ef7183 1394NV
a8a597b2
MB
1395SvNV(sv)
1396 B::NV sv
1397
76ef7183 1398NV
a8a597b2
MB
1399SvNVX(sv)
1400 B::NV sv
1401
809abb02
NC
1402U32
1403COP_SEQ_RANGE_LOW(sv)
1404 B::NV sv
1405
1406U32
1407COP_SEQ_RANGE_HIGH(sv)
1408 B::NV sv
1409
1410U32
1411PARENT_PAD_INDEX(sv)
1412 B::NV sv
1413
1414U32
1415PARENT_FAKELEX_FLAGS(sv)
1416 B::NV sv
1417
4df7f6af
NC
1418#if PERL_VERSION < 11
1419
a8a597b2
MB
1420MODULE = B PACKAGE = B::RV PREFIX = Sv
1421
1422B::SV
1423SvRV(sv)
1424 B::RV sv
1425
4df7f6af
NC
1426#endif
1427
a8a597b2
MB
1428MODULE = B PACKAGE = B::PV PREFIX = Sv
1429
0b40bd6d
RH
1430char*
1431SvPVX(sv)
1432 B::PV sv
1433
b326da91
MB
1434B::SV
1435SvRV(sv)
1436 B::PV sv
1437 CODE:
1438 if( SvROK(sv) ) {
1439 RETVAL = SvRV(sv);
1440 }
1441 else {
1442 croak( "argument is not SvROK" );
1443 }
1444 OUTPUT:
1445 RETVAL
1446
a8a597b2
MB
1447void
1448SvPV(sv)
1449 B::PV sv
1450 CODE:
b326da91 1451 ST(0) = sv_newmortal();
c0b20461 1452 if( SvPOK(sv) ) {
b55685ae
NC
1453 /* FIXME - we need a better way for B to identify PVs that are
1454 in the pads as variable names. */
1455 if((SvLEN(sv) && SvCUR(sv) >= SvLEN(sv))) {
1456 /* It claims to be longer than the space allocated for it -
1457 presuambly it's a variable name in the pad */
1458 sv_setpv(ST(0), SvPV_nolen_const(sv));
1459 } else {
1460 sv_setpvn(ST(0), SvPVX_const(sv), SvCUR(sv));
1461 }
b326da91
MB
1462 SvFLAGS(ST(0)) |= SvUTF8(sv);
1463 }
1464 else {
1465 /* XXX for backward compatibility, but should fail */
1466 /* croak( "argument is not SvPOK" ); */
1467 sv_setpvn(ST(0), NULL, 0);
1468 }
a8a597b2 1469
5a44e503
NC
1470# This used to read 257. I think that that was buggy - should have been 258.
1471# (The "\0", the flags byte, and 256 for the table. Not that anything
1472# anywhere calls this method. NWC.
651aa52e
AE
1473void
1474SvPVBM(sv)
1475 B::PV sv
1476 CODE:
1477 ST(0) = sv_newmortal();
aa07b2f6 1478 sv_setpvn(ST(0), SvPVX_const(sv),
5a44e503 1479 SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0));
651aa52e
AE
1480
1481
445a12f6
DM
1482STRLEN
1483SvLEN(sv)
1484 B::PV sv
1485
1486STRLEN
1487SvCUR(sv)
1488 B::PV sv
1489
a8a597b2
MB
1490MODULE = B PACKAGE = B::PVMG PREFIX = Sv
1491
1492void
1493SvMAGIC(sv)
1494 B::PVMG sv
1495 MAGIC * mg = NO_INIT
1496 PPCODE:
1497 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
cea2e8a9 1498 XPUSHs(make_mg_object(aTHX_ sv_newmortal(), mg));
a8a597b2
MB
1499
1500MODULE = B PACKAGE = B::PVMG
1501
1502B::HV
1503SvSTASH(sv)
1504 B::PVMG sv
1505
5c35adbb
NC
1506MODULE = B PACKAGE = B::REGEXP
1507
1508#if PERL_VERSION >= 11
1509
1510IV
1511REGEX(sv)
07bc277f 1512 B::REGEXP sv
5c35adbb 1513 CODE:
288b8c02
NC
1514 /* FIXME - can we code this method more efficiently? */
1515 RETVAL = PTR2IV(sv);
5c35adbb
NC
1516 OUTPUT:
1517 RETVAL
1518
1519SV*
1520precomp(sv)
07bc277f 1521 B::REGEXP sv
5c35adbb 1522 CODE:
288b8c02 1523 RETVAL = newSVpvn( RX_PRECOMP(sv), RX_PRELEN(sv) );
5c35adbb
NC
1524 OUTPUT:
1525 RETVAL
1526
1527#endif
1528
a8a597b2
MB
1529#define MgMOREMAGIC(mg) mg->mg_moremagic
1530#define MgPRIVATE(mg) mg->mg_private
1531#define MgTYPE(mg) mg->mg_type
1532#define MgFLAGS(mg) mg->mg_flags
1533#define MgOBJ(mg) mg->mg_obj
88b39979 1534#define MgLENGTH(mg) mg->mg_len
bde7177d 1535#define MgREGEX(mg) PTR2IV(mg->mg_obj)
a8a597b2
MB
1536
1537MODULE = B PACKAGE = B::MAGIC PREFIX = Mg
1538
1539B::MAGIC
1540MgMOREMAGIC(mg)
1541 B::MAGIC mg
c5f0f3aa
RGS
1542 CODE:
1543 if( MgMOREMAGIC(mg) ) {
1544 RETVAL = MgMOREMAGIC(mg);
1545 }
1546 else {
1547 XSRETURN_UNDEF;
1548 }
1549 OUTPUT:
1550 RETVAL
a8a597b2
MB
1551
1552U16
1553MgPRIVATE(mg)
1554 B::MAGIC mg
1555
1556char
1557MgTYPE(mg)
1558 B::MAGIC mg
1559
1560U8
1561MgFLAGS(mg)
1562 B::MAGIC mg
1563
1564B::SV
1565MgOBJ(mg)
1566 B::MAGIC mg
b326da91 1567
9d2bbe64
MB
1568IV
1569MgREGEX(mg)
1570 B::MAGIC mg
1571 CODE:
a8248b05 1572 if(mg->mg_type == PERL_MAGIC_qr) {
9d2bbe64
MB
1573 RETVAL = MgREGEX(mg);
1574 }
1575 else {
1576 croak( "REGEX is only meaningful on r-magic" );
1577 }
1578 OUTPUT:
1579 RETVAL
1580
b326da91
MB
1581SV*
1582precomp(mg)
1583 B::MAGIC mg
1584 CODE:
a8248b05 1585 if (mg->mg_type == PERL_MAGIC_qr) {
b326da91 1586 REGEXP* rx = (REGEXP*)mg->mg_obj;
ef35129c 1587 RETVAL = Nullsv;
b326da91 1588 if( rx )
220fc49f 1589 RETVAL = newSVpvn( RX_PRECOMP(rx), RX_PRELEN(rx) );
b326da91
MB
1590 }
1591 else {
1592 croak( "precomp is only meaningful on r-magic" );
1593 }
1594 OUTPUT:
1595 RETVAL
a8a597b2 1596
88b39979
VB
1597I32
1598MgLENGTH(mg)
1599 B::MAGIC mg
1600
a8a597b2
MB
1601void
1602MgPTR(mg)
1603 B::MAGIC mg
1604 CODE:
1605 ST(0) = sv_newmortal();
88b39979
VB
1606 if (mg->mg_ptr){
1607 if (mg->mg_len >= 0){
1608 sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len);
651aa52e
AE
1609 } else if (mg->mg_len == HEf_SVKEY) {
1610 ST(0) = make_sv_object(aTHX_
1611 sv_newmortal(), (SV*)mg->mg_ptr);
88b39979
VB
1612 }
1613 }
a8a597b2
MB
1614
1615MODULE = B PACKAGE = B::PVLV PREFIX = Lv
1616
1617U32
1618LvTARGOFF(sv)
1619 B::PVLV sv
1620
1621U32
1622LvTARGLEN(sv)
1623 B::PVLV sv
1624
1625char
1626LvTYPE(sv)
1627 B::PVLV sv
1628
1629B::SV
1630LvTARG(sv)
1631 B::PVLV sv
1632
1633MODULE = B PACKAGE = B::BM PREFIX = Bm
1634
1635I32
1636BmUSEFUL(sv)
1637 B::BM sv
1638
85c508c3 1639U32
a8a597b2
MB
1640BmPREVIOUS(sv)
1641 B::BM sv
1642
1643U8
1644BmRARE(sv)
1645 B::BM sv
1646
1647void
1648BmTABLE(sv)
1649 B::BM sv
1650 STRLEN len = NO_INIT
1651 char * str = NO_INIT
1652 CODE:
1653 str = SvPV(sv, len);
1654 /* Boyer-Moore table is just after string and its safety-margin \0 */
d3d34884 1655 ST(0) = newSVpvn_flags(str + len + PERL_FBM_TABLE_OFFSET, 256, SVs_TEMP);
a8a597b2
MB
1656
1657MODULE = B PACKAGE = B::GV PREFIX = Gv
1658
1659void
1660GvNAME(gv)
1661 B::GV gv
1662 CODE:
6beb30a6
NC
1663#if PERL_VERSION >= 10
1664 ST(0) = sv_2mortal(newSVhek(GvNAME_HEK(gv)));
1665#else
d3d34884 1666 ST(0) = newSVpvn_flags(GvNAME(gv), GvNAMELEN(gv), SVs_TEMP);
6beb30a6 1667#endif
a8a597b2 1668
87d7fd28
GS
1669bool
1670is_empty(gv)
1671 B::GV gv
1672 CODE:
1673 RETVAL = GvGP(gv) == Null(GP*);
1674 OUTPUT:
1675 RETVAL
1676
50786ba8
NC
1677bool
1678isGV_with_GP(gv)
1679 B::GV gv
1680 CODE:
1681#if PERL_VERSION >= 9
1682 RETVAL = isGV_with_GP(gv) ? TRUE : FALSE;
1683#else
1684 RETVAL = TRUE; /* In 5.8 and earlier they all are. */
1685#endif
1686 OUTPUT:
1687 RETVAL
1688
651aa52e
AE
1689void*
1690GvGP(gv)
1691 B::GV gv
1692
a8a597b2
MB
1693B::HV
1694GvSTASH(gv)
1695 B::GV gv
1696
1697B::SV
1698GvSV(gv)
1699 B::GV gv
1700
1701B::IO
1702GvIO(gv)
1703 B::GV gv
1704
1df34986 1705B::FM
a8a597b2
MB
1706GvFORM(gv)
1707 B::GV gv
1df34986
AE
1708 CODE:
1709 RETVAL = (SV*)GvFORM(gv);
1710 OUTPUT:
1711 RETVAL
a8a597b2
MB
1712
1713B::AV
1714GvAV(gv)
1715 B::GV gv
1716
1717B::HV
1718GvHV(gv)
1719 B::GV gv
1720
1721B::GV
1722GvEGV(gv)
1723 B::GV gv
1724
1725B::CV
1726GvCV(gv)
1727 B::GV gv
1728
1729U32
1730GvCVGEN(gv)
1731 B::GV gv
1732
8bafa735 1733U32
a8a597b2
MB
1734GvLINE(gv)
1735 B::GV gv
1736
b195d487
GS
1737char *
1738GvFILE(gv)
1739 B::GV gv
1740
a8a597b2
MB
1741B::GV
1742GvFILEGV(gv)
1743 B::GV gv
1744
1745MODULE = B PACKAGE = B::GV
1746
1747U32
1748GvREFCNT(gv)
1749 B::GV gv
1750
1751U8
1752GvFLAGS(gv)
1753 B::GV gv
1754
1755MODULE = B PACKAGE = B::IO PREFIX = Io
1756
1757long
1758IoLINES(io)
1759 B::IO io
1760
1761long
1762IoPAGE(io)
1763 B::IO io
1764
1765long
1766IoPAGE_LEN(io)
1767 B::IO io
1768
1769long
1770IoLINES_LEFT(io)
1771 B::IO io
1772
1773char *
1774IoTOP_NAME(io)
1775 B::IO io
1776
1777B::GV
1778IoTOP_GV(io)
1779 B::IO io
1780
1781char *
1782IoFMT_NAME(io)
1783 B::IO io
1784
1785B::GV
1786IoFMT_GV(io)
1787 B::IO io
1788
1789char *
1790IoBOTTOM_NAME(io)
1791 B::IO io
1792
1793B::GV
1794IoBOTTOM_GV(io)
1795 B::IO io
1796
04071355
NC
1797#if PERL_VERSION <= 8
1798
a8a597b2
MB
1799short
1800IoSUBPROCESS(io)
1801 B::IO io
1802
04071355
NC
1803#endif
1804
b326da91
MB
1805bool
1806IsSTD(io,name)
1807 B::IO io
5d7488b2 1808 const char* name
b326da91
MB
1809 PREINIT:
1810 PerlIO* handle = 0;
1811 CODE:
1812 if( strEQ( name, "stdin" ) ) {
1813 handle = PerlIO_stdin();
1814 }
1815 else if( strEQ( name, "stdout" ) ) {
1816 handle = PerlIO_stdout();
1817 }
1818 else if( strEQ( name, "stderr" ) ) {
1819 handle = PerlIO_stderr();
1820 }
1821 else {
1822 croak( "Invalid value '%s'", name );
1823 }
1824 RETVAL = handle == IoIFP(io);
1825 OUTPUT:
1826 RETVAL
1827
a8a597b2
MB
1828MODULE = B PACKAGE = B::IO
1829
1830char
1831IoTYPE(io)
1832 B::IO io
1833
1834U8
1835IoFLAGS(io)
1836 B::IO io
1837
1838MODULE = B PACKAGE = B::AV PREFIX = Av
1839
1840SSize_t
1841AvFILL(av)
1842 B::AV av
1843
1844SSize_t
1845AvMAX(av)
1846 B::AV av
1847
edcc7c74
NC
1848#if PERL_VERSION < 9
1849
1850
1851#define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1852
1853IV
1854AvOFF(av)
1855 B::AV av
1856
1857#endif
1858
a8a597b2
MB
1859void
1860AvARRAY(av)
1861 B::AV av
1862 PPCODE:
1863 if (AvFILL(av) >= 0) {
1864 SV **svp = AvARRAY(av);
1865 I32 i;
1866 for (i = 0; i <= AvFILL(av); i++)
cea2e8a9 1867 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), svp[i]));
a8a597b2
MB
1868 }
1869
429a5ce7
SM
1870void
1871AvARRAYelt(av, idx)
1872 B::AV av
1873 int idx
1874 PPCODE:
1875 if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
1876 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), (AvARRAY(av)[idx])));
1877 else
1878 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), NULL));
1879
edcc7c74
NC
1880#if PERL_VERSION < 9
1881
1882MODULE = B PACKAGE = B::AV
1883
1884U8
1885AvFLAGS(av)
1886 B::AV av
1887
1888#endif
1889
1df34986
AE
1890MODULE = B PACKAGE = B::FM PREFIX = Fm
1891
1892IV
1893FmLINES(form)
1894 B::FM form
1895
a8a597b2
MB
1896MODULE = B PACKAGE = B::CV PREFIX = Cv
1897
651aa52e
AE
1898U32
1899CvCONST(cv)
1900 B::CV cv
1901
a8a597b2
MB
1902B::HV
1903CvSTASH(cv)
1904 B::CV cv
1905
1906B::OP
1907CvSTART(cv)
1908 B::CV cv
a0da4400
NC
1909 ALIAS:
1910 ROOT = 1
bf53b3a5 1911 CODE:
a0da4400 1912 RETVAL = CvISXSUB(cv) ? NULL : ix ? CvROOT(cv) : CvSTART(cv);
d04ba589
NC
1913 OUTPUT:
1914 RETVAL
a8a597b2
MB
1915
1916B::GV
1917CvGV(cv)
1918 B::CV cv
1919
57843af0
GS
1920char *
1921CvFILE(cv)
1922 B::CV cv
1923
a8a597b2
MB
1924long
1925CvDEPTH(cv)
1926 B::CV cv
1927
1928B::AV
1929CvPADLIST(cv)
1930 B::CV cv
1931
1932B::CV
1933CvOUTSIDE(cv)
1934 B::CV cv
1935
a3985cdc
DM
1936U32
1937CvOUTSIDE_SEQ(cv)
1938 B::CV cv
1939
a8a597b2
MB
1940void
1941CvXSUB(cv)
1942 B::CV cv
1943 CODE:
d04ba589 1944 ST(0) = sv_2mortal(newSViv(CvISXSUB(cv) ? PTR2IV(CvXSUB(cv)) : 0));
a8a597b2
MB
1945
1946
1947void
1948CvXSUBANY(cv)
1949 B::CV cv
1950 CODE:
b326da91 1951 ST(0) = CvCONST(cv) ?
07409e01 1952 make_sv_object(aTHX_ sv_newmortal(),(SV *)CvXSUBANY(cv).any_ptr) :
bf53b3a5 1953 sv_2mortal(newSViv(CvISXSUB(cv) ? CvXSUBANY(cv).any_iv : 0));
a8a597b2 1954
5cfd8ad4
VB
1955MODULE = B PACKAGE = B::CV
1956
6aaf4108 1957U16
5cfd8ad4
VB
1958CvFLAGS(cv)
1959 B::CV cv
1960
de3f1649
JT
1961MODULE = B PACKAGE = B::CV PREFIX = cv_
1962
1963B::SV
1964cv_const_sv(cv)
1965 B::CV cv
1966
5cfd8ad4 1967
a8a597b2
MB
1968MODULE = B PACKAGE = B::HV PREFIX = Hv
1969
1970STRLEN
1971HvFILL(hv)
1972 B::HV hv
1973
1974STRLEN
1975HvMAX(hv)
1976 B::HV hv
1977
1978I32
1979HvKEYS(hv)
1980 B::HV hv
1981
1982I32
1983HvRITER(hv)
1984 B::HV hv
1985
1986char *
1987HvNAME(hv)
1988 B::HV hv
1989
edcc7c74
NC
1990#if PERL_VERSION < 9
1991
1992B::PMOP
1993HvPMROOT(hv)
1994 B::HV hv
1995
1996#endif
1997
a8a597b2
MB
1998void
1999HvARRAY(hv)
2000 B::HV hv
2001 PPCODE:
2002 if (HvKEYS(hv) > 0) {
2003 SV *sv;
2004 char *key;
2005 I32 len;
2006 (void)hv_iterinit(hv);
2007 EXTEND(sp, HvKEYS(hv) * 2);
8063af02 2008 while ((sv = hv_iternextsv(hv, &key, &len))) {
22f1178f 2009 mPUSHp(key, len);
cea2e8a9 2010 PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv));
a8a597b2
MB
2011 }
2012 }
fd9f6265
JJ
2013
2014MODULE = B PACKAGE = B::HE PREFIX = He
2015
2016B::SV
2017HeVAL(he)
2018 B::HE he
2019
2020U32
2021HeHASH(he)
2022 B::HE he
2023
2024B::SV
2025HeSVKEY_force(he)
2026 B::HE he
2027
2028MODULE = B PACKAGE = B::RHE PREFIX = RHE_
2029
e412117e
NC
2030#if PERL_VERSION >= 9
2031
fd9f6265
JJ
2032SV*
2033RHE_HASH(h)
2034 B::RHE h
2035 CODE:
20439bc7 2036 RETVAL = newRV( (SV*)cophh_2hv(h, 0) );
fd9f6265
JJ
2037 OUTPUT:
2038 RETVAL
e412117e
NC
2039
2040#endif