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