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