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