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