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