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