This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Merge the implementation of B::{minus_c,save_BEGINSs} using ALIAS.
[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
9496d2e5
NC
238/* FIXME - figure out how to get the typemap to assign this to ST(0), rather
239 than creating a new mortal for ST(0) then passing it in as the first
240 argument. */
a8a597b2 241static SV *
cea2e8a9 242make_sv_object(pTHX_ SV *arg, SV *sv)
a8a597b2 243{
27da23d5 244 const char *type = 0;
a8a597b2 245 IV iv;
89ca4ac7 246 dMY_CXT;
9496d2e5
NC
247
248 if (!arg)
249 arg = sv_newmortal();
250
e8edd1e6
TH
251 for (iv = 0; iv < sizeof(specialsv_list)/sizeof(SV*); iv++) {
252 if (sv == specialsv_list[iv]) {
a8a597b2
MB
253 type = "B::SPECIAL";
254 break;
255 }
256 }
257 if (!type) {
258 type = svclassnames[SvTYPE(sv)];
56431972 259 iv = PTR2IV(sv);
a8a597b2
MB
260 }
261 sv_setiv(newSVrv(arg, type), iv);
262 return arg;
263}
264
e412117e 265#if PERL_VERSION >= 9
a8a597b2 266static SV *
9496d2e5 267make_temp_object(pTHX_ SV *temp)
8e01d9a6
NC
268{
269 SV *target;
9496d2e5 270 SV *arg = sv_newmortal();
8e01d9a6
NC
271 const char *const type = svclassnames[SvTYPE(temp)];
272 const IV iv = PTR2IV(temp);
273
274 target = newSVrv(arg, type);
275 sv_setiv(target, iv);
276
277 /* Need to keep our "temp" around as long as the target exists.
278 Simplest way seems to be to hang it from magic, and let that clear
279 it up. No vtable, so won't actually get in the way of anything. */
280 sv_magicext(target, temp, PERL_MAGIC_sv, NULL, NULL, 0);
281 /* magic object has had its reference count increased, so we must drop
282 our reference. */
283 SvREFCNT_dec(temp);
284 return arg;
285}
286
287static SV *
9496d2e5 288make_warnings_object(pTHX_ STRLEN *warnings)
5c3c3f81
NC
289{
290 const char *type = 0;
291 dMY_CXT;
292 IV iv = sizeof(specialsv_list)/sizeof(SV*);
293
294 /* Counting down is deliberate. Before the split between make_sv_object
295 and make_warnings_obj there appeared to be a bug - Nullsv and pWARN_STD
296 were both 0, so you could never get a B::SPECIAL for pWARN_STD */
297
298 while (iv--) {
299 if ((SV*)warnings == specialsv_list[iv]) {
300 type = "B::SPECIAL";
301 break;
302 }
303 }
304 if (type) {
9496d2e5 305 SV *arg = sv_newmortal();
5c3c3f81 306 sv_setiv(newSVrv(arg, type), iv);
8e01d9a6 307 return arg;
5c3c3f81
NC
308 } else {
309 /* B assumes that warnings are a regular SV. Seems easier to keep it
310 happy by making them into a regular SV. */
9496d2e5 311 return make_temp_object(aTHX_ newSVpvn((char *)(warnings + 1), *warnings));
8e01d9a6
NC
312 }
313}
314
315static SV *
9496d2e5 316make_cop_io_object(pTHX_ COP *cop)
8e01d9a6 317{
8b850bd5
NC
318 SV *const value = newSV(0);
319
33972ad6 320 Perl_emulate_cop_io(aTHX_ cop, value);
8b850bd5
NC
321
322 if(SvOK(value)) {
23098a26 323 return make_sv_object(aTHX_ NULL, value);
8e01d9a6 324 } else {
8b850bd5 325 SvREFCNT_dec(value);
9496d2e5 326 return make_sv_object(aTHX_ NULL, NULL);
5c3c3f81 327 }
5c3c3f81 328}
e412117e 329#endif
5c3c3f81
NC
330
331static SV *
9496d2e5 332make_mg_object(pTHX_ MAGIC *mg)
a8a597b2 333{
9496d2e5 334 SV *arg = sv_newmortal();
56431972 335 sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg));
a8a597b2
MB
336 return arg;
337}
338
339static SV *
52ad86de 340cstring(pTHX_ SV *sv, bool perlstyle)
a8a597b2 341{
09e97b95 342 SV *sstr;
a8a597b2
MB
343
344 if (!SvOK(sv))
09e97b95
NC
345 return newSVpvs_flags("0", SVs_TEMP);
346
347 sstr = newSVpvs_flags("\"", SVs_TEMP);
348
349 if (perlstyle && SvUTF8(sv)) {
d79a7a3d 350 SV *tmpsv = sv_newmortal(); /* Temporary SV to feed sv_uni_display */
5d7488b2
AL
351 const STRLEN len = SvCUR(sv);
352 const char *s = sv_uni_display(tmpsv, sv, 8*len, UNI_DISPLAY_QQ);
d79a7a3d
RGS
353 while (*s)
354 {
355 if (*s == '"')
6beb30a6 356 sv_catpvs(sstr, "\\\"");
d79a7a3d 357 else if (*s == '$')
6beb30a6 358 sv_catpvs(sstr, "\\$");
d79a7a3d 359 else if (*s == '@')
6beb30a6 360 sv_catpvs(sstr, "\\@");
d79a7a3d
RGS
361 else if (*s == '\\')
362 {
363 if (strchr("nrftax\\",*(s+1)))
364 sv_catpvn(sstr, s++, 2);
365 else
6beb30a6 366 sv_catpvs(sstr, "\\\\");
d79a7a3d
RGS
367 }
368 else /* should always be printable */
369 sv_catpvn(sstr, s, 1);
370 ++s;
371 }
d79a7a3d 372 }
a8a597b2
MB
373 else
374 {
375 /* XXX Optimise? */
5d7488b2
AL
376 STRLEN len;
377 const char *s = SvPV(sv, len);
a8a597b2
MB
378 for (; len; len--, s++)
379 {
380 /* At least try a little for readability */
381 if (*s == '"')
6beb30a6 382 sv_catpvs(sstr, "\\\"");
a8a597b2 383 else if (*s == '\\')
6beb30a6 384 sv_catpvs(sstr, "\\\\");
b326da91 385 /* trigraphs - bleagh */
5d7488b2 386 else if (!perlstyle && *s == '?' && len>=3 && s[1] == '?') {
47bf35fa 387 Perl_sv_catpvf(aTHX_ sstr, "\\%03o", '?');
b326da91 388 }
52ad86de 389 else if (perlstyle && *s == '$')
6beb30a6 390 sv_catpvs(sstr, "\\$");
52ad86de 391 else if (perlstyle && *s == '@')
6beb30a6 392 sv_catpvs(sstr, "\\@");
ce561ef2
JH
393#ifdef EBCDIC
394 else if (isPRINT(*s))
395#else
396 else if (*s >= ' ' && *s < 127)
397#endif /* EBCDIC */
a8a597b2
MB
398 sv_catpvn(sstr, s, 1);
399 else if (*s == '\n')
6beb30a6 400 sv_catpvs(sstr, "\\n");
a8a597b2 401 else if (*s == '\r')
6beb30a6 402 sv_catpvs(sstr, "\\r");
a8a597b2 403 else if (*s == '\t')
6beb30a6 404 sv_catpvs(sstr, "\\t");
a8a597b2 405 else if (*s == '\a')
6beb30a6 406 sv_catpvs(sstr, "\\a");
a8a597b2 407 else if (*s == '\b')
6beb30a6 408 sv_catpvs(sstr, "\\b");
a8a597b2 409 else if (*s == '\f')
6beb30a6 410 sv_catpvs(sstr, "\\f");
52ad86de 411 else if (!perlstyle && *s == '\v')
6beb30a6 412 sv_catpvs(sstr, "\\v");
a8a597b2
MB
413 else
414 {
a8a597b2 415 /* Don't want promotion of a signed -1 char in sprintf args */
5d7488b2 416 const unsigned char c = (unsigned char) *s;
47bf35fa 417 Perl_sv_catpvf(aTHX_ sstr, "\\%03o", c);
a8a597b2
MB
418 }
419 /* XXX Add line breaks if string is long */
420 }
a8a597b2 421 }
09e97b95 422 sv_catpvs(sstr, "\"");
a8a597b2
MB
423 return sstr;
424}
425
426static SV *
cea2e8a9 427cchar(pTHX_ SV *sv)
a8a597b2 428{
422d053b 429 SV *sstr = newSVpvs_flags("'", SVs_TEMP);
5d7488b2 430 const char *s = SvPV_nolen(sv);
422d053b
NC
431 /* Don't want promotion of a signed -1 char in sprintf args */
432 const unsigned char c = (unsigned char) *s;
a8a597b2 433
422d053b 434 if (c == '\'')
6beb30a6 435 sv_catpvs(sstr, "\\'");
422d053b 436 else if (c == '\\')
6beb30a6 437 sv_catpvs(sstr, "\\\\");
ce561ef2 438#ifdef EBCDIC
422d053b 439 else if (isPRINT(c))
ce561ef2 440#else
422d053b 441 else if (c >= ' ' && c < 127)
ce561ef2 442#endif /* EBCDIC */
a8a597b2 443 sv_catpvn(sstr, s, 1);
422d053b 444 else if (c == '\n')
6beb30a6 445 sv_catpvs(sstr, "\\n");
422d053b 446 else if (c == '\r')
6beb30a6 447 sv_catpvs(sstr, "\\r");
422d053b 448 else if (c == '\t')
6beb30a6 449 sv_catpvs(sstr, "\\t");
422d053b 450 else if (c == '\a')
6beb30a6 451 sv_catpvs(sstr, "\\a");
422d053b 452 else if (c == '\b')
6beb30a6 453 sv_catpvs(sstr, "\\b");
422d053b 454 else if (c == '\f')
6beb30a6 455 sv_catpvs(sstr, "\\f");
422d053b 456 else if (c == '\v')
6beb30a6 457 sv_catpvs(sstr, "\\v");
a8a597b2 458 else
422d053b 459 Perl_sv_catpvf(aTHX_ sstr, "\\%03o", c);
6beb30a6 460 sv_catpvs(sstr, "'");
a8a597b2
MB
461 return sstr;
462}
463
8f3d514b
JC
464#if PERL_VERSION >= 9
465# define PMOP_pmreplstart(o) o->op_pmstashstartu.op_pmreplstart
466# define PMOP_pmreplroot(o) o->op_pmreplrootu.op_pmreplroot
467#else
468# define PMOP_pmreplstart(o) o->op_pmreplstart
469# define PMOP_pmreplroot(o) o->op_pmreplroot
470# define PMOP_pmpermflags(o) o->op_pmpermflags
471# define PMOP_pmdynflags(o) o->op_pmdynflags
472#endif
473
5d7488b2
AL
474static void
475walkoptree(pTHX_ SV *opsv, const char *method)
a8a597b2
MB
476{
477 dSP;
f3be9b72 478 OP *o, *kid;
89ca4ac7
JH
479 dMY_CXT;
480
a8a597b2
MB
481 if (!SvROK(opsv))
482 croak("opsv is not a reference");
483 opsv = sv_mortalcopy(opsv);
56431972 484 o = INT2PTR(OP*,SvIV((SV*)SvRV(opsv)));
a8a597b2
MB
485 if (walkoptree_debug) {
486 PUSHMARK(sp);
487 XPUSHs(opsv);
488 PUTBACK;
489 perl_call_method("walkoptree_debug", G_DISCARD);
490 }
491 PUSHMARK(sp);
492 XPUSHs(opsv);
493 PUTBACK;
494 perl_call_method(method, G_DISCARD);
495 if (o && (o->op_flags & OPf_KIDS)) {
a8a597b2
MB
496 for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) {
497 /* Use the same opsv. Rely on methods not to mess it up. */
56431972 498 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
cea2e8a9 499 walkoptree(aTHX_ opsv, method);
a8a597b2
MB
500 }
501 }
5464c149 502 if (o && (cc_opclass(aTHX_ o) == OPc_PMOP) && o->op_type != OP_PUSHRE
8f3d514b 503 && (kid = PMOP_pmreplroot(cPMOPo)))
f3be9b72 504 {
5464c149 505 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
f3be9b72
RGS
506 walkoptree(aTHX_ opsv, method);
507 }
a8a597b2
MB
508}
509
5d7488b2 510static SV **
1df34986
AE
511oplist(pTHX_ OP *o, SV **SP)
512{
513 for(; o; o = o->op_next) {
514 SV *opsv;
7252851f
NC
515#if PERL_VERSION >= 9
516 if (o->op_opt == 0)
1df34986 517 break;
2814eb74 518 o->op_opt = 0;
7252851f
NC
519#else
520 if (o->op_seq == 0)
521 break;
522 o->op_seq = 0;
523#endif
1df34986
AE
524 opsv = sv_newmortal();
525 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ (OP*)o)), PTR2IV(o));
526 XPUSHs(opsv);
527 switch (o->op_type) {
528 case OP_SUBST:
8f3d514b 529 SP = oplist(aTHX_ PMOP_pmreplstart(cPMOPo), SP);
1df34986
AE
530 continue;
531 case OP_SORT:
f66c782a 532 if (o->op_flags & OPf_STACKED && o->op_flags & OPf_SPECIAL) {
1df34986
AE
533 OP *kid = cLISTOPo->op_first->op_sibling; /* pass pushmark */
534 kid = kUNOP->op_first; /* pass rv2gv */
535 kid = kUNOP->op_first; /* pass leave */
f66c782a 536 SP = oplist(aTHX_ kid->op_next, SP);
1df34986
AE
537 }
538 continue;
539 }
540 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
541 case OA_LOGOP:
542 SP = oplist(aTHX_ cLOGOPo->op_other, SP);
543 break;
544 case OA_LOOP:
545 SP = oplist(aTHX_ cLOOPo->op_lastop, SP);
546 SP = oplist(aTHX_ cLOOPo->op_nextop, SP);
547 SP = oplist(aTHX_ cLOOPo->op_redoop, SP);
548 break;
549 }
550 }
551 return SP;
552}
553
a8a597b2
MB
554typedef OP *B__OP;
555typedef UNOP *B__UNOP;
556typedef BINOP *B__BINOP;
557typedef LOGOP *B__LOGOP;
a8a597b2
MB
558typedef LISTOP *B__LISTOP;
559typedef PMOP *B__PMOP;
560typedef SVOP *B__SVOP;
7934575e 561typedef PADOP *B__PADOP;
a8a597b2
MB
562typedef PVOP *B__PVOP;
563typedef LOOP *B__LOOP;
564typedef COP *B__COP;
565
566typedef SV *B__SV;
567typedef SV *B__IV;
568typedef SV *B__PV;
569typedef SV *B__NV;
570typedef SV *B__PVMG;
5c35adbb
NC
571#if PERL_VERSION >= 11
572typedef SV *B__REGEXP;
573#endif
a8a597b2
MB
574typedef SV *B__PVLV;
575typedef SV *B__BM;
576typedef SV *B__RV;
1df34986 577typedef SV *B__FM;
a8a597b2
MB
578typedef AV *B__AV;
579typedef HV *B__HV;
580typedef CV *B__CV;
581typedef GV *B__GV;
582typedef IO *B__IO;
583
584typedef MAGIC *B__MAGIC;
fd9f6265 585typedef HE *B__HE;
e412117e 586#if PERL_VERSION >= 9
fd9f6265 587typedef struct refcounted_he *B__RHE;
e412117e 588#endif
a8a597b2 589
b1826b71
NC
590#include "const-c.inc"
591
a8a597b2
MB
592MODULE = B PACKAGE = B PREFIX = B_
593
b1826b71
NC
594INCLUDE: const-xs.inc
595
a8a597b2
MB
596PROTOTYPES: DISABLE
597
598BOOT:
4c1f658f 599{
89ca4ac7 600 MY_CXT_INIT;
e8edd1e6
TH
601 specialsv_list[0] = Nullsv;
602 specialsv_list[1] = &PL_sv_undef;
603 specialsv_list[2] = &PL_sv_yes;
604 specialsv_list[3] = &PL_sv_no;
5c3c3f81
NC
605 specialsv_list[4] = (SV *) pWARN_ALL;
606 specialsv_list[5] = (SV *) pWARN_NONE;
607 specialsv_list[6] = (SV *) pWARN_STD;
4c1f658f 608}
a8a597b2 609
3280af22 610#define B_main_cv() PL_main_cv
31d7d75a 611#define B_init_av() PL_initav
651aa52e 612#define B_inc_gv() PL_incgv
ece599bd 613#define B_check_av() PL_checkav_save
e6663653
NC
614#if PERL_VERSION > 8
615# define B_unitcheck_av() PL_unitcheckav_save
616#else
617# define B_unitcheck_av() NULL
618#endif
059a8bb7
JH
619#define B_begin_av() PL_beginav_save
620#define B_end_av() PL_endav
3280af22
NIS
621#define B_main_root() PL_main_root
622#define B_main_start() PL_main_start
56eca212 623#define B_amagic_generation() PL_amagic_generation
5ce57cc0 624#define B_sub_generation() PL_sub_generation
651aa52e
AE
625#define B_defstash() PL_defstash
626#define B_curstash() PL_curstash
627#define B_dowarn() PL_dowarn
3280af22
NIS
628#define B_comppadlist() (PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv))
629#define B_sv_undef() &PL_sv_undef
630#define B_sv_yes() &PL_sv_yes
631#define B_sv_no() &PL_sv_no
1df34986 632#define B_formfeed() PL_formfeed
9d2bbe64
MB
633#ifdef USE_ITHREADS
634#define B_regex_padav() PL_regex_padav
635#endif
a8a597b2 636
31d7d75a
NIS
637B::AV
638B_init_av()
639
059a8bb7 640B::AV
ece599bd
RGS
641B_check_av()
642
e412117e
NC
643#if PERL_VERSION >= 9
644
ece599bd 645B::AV
676456c2
AG
646B_unitcheck_av()
647
e412117e
NC
648#endif
649
676456c2 650B::AV
059a8bb7
JH
651B_begin_av()
652
653B::AV
654B_end_av()
655
651aa52e
AE
656B::GV
657B_inc_gv()
658
9d2bbe64
MB
659#ifdef USE_ITHREADS
660
661B::AV
662B_regex_padav()
663
664#endif
665
a8a597b2
MB
666B::CV
667B_main_cv()
668
669B::OP
670B_main_root()
671
672B::OP
673B_main_start()
674
56eca212
GS
675long
676B_amagic_generation()
677
5ce57cc0
JJ
678long
679B_sub_generation()
680
a8a597b2
MB
681B::AV
682B_comppadlist()
683
684B::SV
685B_sv_undef()
686
687B::SV
688B_sv_yes()
689
690B::SV
691B_sv_no()
692
651aa52e
AE
693B::HV
694B_curstash()
695
696B::HV
697B_defstash()
a8a597b2 698
651aa52e
AE
699U8
700B_dowarn()
701
1df34986
AE
702B::SV
703B_formfeed()
704
651aa52e
AE
705void
706B_warnhook()
707 CODE:
9496d2e5 708 ST(0) = make_sv_object(aTHX_ NULL, PL_warnhook);
651aa52e
AE
709
710void
711B_diehook()
712 CODE:
9496d2e5 713 ST(0) = make_sv_object(aTHX_ NULL, PL_diehook);
651aa52e
AE
714
715MODULE = B PACKAGE = B
a8a597b2
MB
716
717void
718walkoptree(opsv, method)
719 SV * opsv
5d7488b2 720 const char * method
cea2e8a9
GS
721 CODE:
722 walkoptree(aTHX_ opsv, method);
a8a597b2
MB
723
724int
725walkoptree_debug(...)
726 CODE:
89ca4ac7 727 dMY_CXT;
a8a597b2
MB
728 RETVAL = walkoptree_debug;
729 if (items > 0 && SvTRUE(ST(1)))
730 walkoptree_debug = 1;
731 OUTPUT:
732 RETVAL
733
56431972 734#define address(sv) PTR2IV(sv)
a8a597b2
MB
735
736IV
737address(sv)
738 SV * sv
739
740B::SV
741svref_2object(sv)
742 SV * sv
743 CODE:
744 if (!SvROK(sv))
745 croak("argument is not a reference");
746 RETVAL = (SV*)SvRV(sv);
747 OUTPUT:
0cc1d052
NIS
748 RETVAL
749
750void
751opnumber(name)
5d7488b2 752const char * name
0cc1d052
NIS
753CODE:
754{
755 int i;
756 IV result = -1;
757 ST(0) = sv_newmortal();
758 if (strncmp(name,"pp_",3) == 0)
759 name += 3;
760 for (i = 0; i < PL_maxo; i++)
761 {
762 if (strcmp(name, PL_op_name[i]) == 0)
763 {
764 result = i;
765 break;
766 }
767 }
768 sv_setiv(ST(0),result);
769}
a8a597b2
MB
770
771void
772ppname(opnum)
773 int opnum
774 CODE:
775 ST(0) = sv_newmortal();
3280af22 776 if (opnum >= 0 && opnum < PL_maxo) {
6beb30a6 777 sv_setpvs(ST(0), "pp_");
22c35a8c 778 sv_catpv(ST(0), PL_op_name[opnum]);
a8a597b2
MB
779 }
780
781void
782hash(sv)
783 SV * sv
784 CODE:
a8a597b2
MB
785 STRLEN len;
786 U32 hash = 0;
8c5b7c71 787 const char *s = SvPVbyte(sv, len);
c32d3395 788 PERL_HASH(hash, s, len);
90b16320 789 ST(0) = sv_2mortal(Perl_newSVpvf(aTHX_ "0x%"UVxf, (UV)hash));
a8a597b2
MB
790
791#define cast_I32(foo) (I32)foo
792IV
793cast_I32(i)
794 IV i
795
796void
797minus_c()
651233d2
NC
798 ALIAS:
799 save_BEGINs = 1
a8a597b2 800 CODE:
651233d2
NC
801 if (ix)
802 PL_savebegin = TRUE;
803 else
804 PL_minus_c = TRUE;
059a8bb7 805
a8a597b2
MB
806SV *
807cstring(sv)
808 SV * sv
84556172
NC
809 ALIAS:
810 perlstring = 1
9e380ad4 811 cchar = 2
09e97b95 812 PPCODE:
9e380ad4 813 PUSHs(ix == 2 ? cchar(aTHX_ sv) : cstring(aTHX_ sv, ix));
a8a597b2
MB
814
815void
816threadsv_names()
817 PPCODE:
f5ba1307
NC
818#if PERL_VERSION <= 8
819# ifdef USE_5005THREADS
820 int i;
5d7488b2 821 const STRLEN len = strlen(PL_threadsv_names);
f5ba1307
NC
822
823 EXTEND(sp, len);
824 for (i = 0; i < len; i++)
d3d34884 825 PUSHs(newSVpvn_flags(&PL_threadsv_names[i], 1, SVs_TEMP));
f5ba1307
NC
826# endif
827#endif
a8a597b2 828
257e0650
NC
829#define SVp 0x00000
830#define U32p 0x10000
831#define line_tp 0x20000
832#define OPp 0x30000
833#define PADOFFSETp 0x40000
834#define U8p 0x50000
39e120c1 835#define IVp 0x60000
a9ed1a44 836#define char_pp 0x70000
086f9b42
NC
837
838#define OP_next_ix OPp | offsetof(struct op, op_next)
839#define OP_sibling_ix OPp | offsetof(struct op, op_sibling)
840#define UNOP_first_ix OPp | offsetof(struct unop, op_first)
841#define BINOP_last_ix OPp | offsetof(struct binop, op_last)
842#define LOGOP_other_ix OPp | offsetof(struct logop, op_other)
9b1961be 843#if PERL_VERSION >= 9
086f9b42
NC
844# define PMOP_pmreplstart_ix \
845 OPp | offsetof(struct pmop, op_pmstashstartu.op_pmreplstart)
9b1961be 846#else
086f9b42 847# define PMOP_pmreplstart_ix OPp | offsetof(struct pmop, op_pmreplstart)
9b1961be 848#endif
086f9b42
NC
849#define LOOP_redoop_ix OPp | offsetof(struct loop, op_redoop)
850#define LOOP_nextop_ix OPp | offsetof(struct loop, op_nextop)
851#define LOOP_lastop_ix OPp | offsetof(struct loop, op_lastop)
852
853#define OP_targ_ix PADOFFSETp | offsetof(struct op, op_targ)
854#define OP_flags_ix U8p | offsetof(struct op, op_flags)
855#define OP_private_ix U8p | offsetof(struct op, op_private)
9b1961be 856
a78b89ef
NC
857#define PMOP_pmflags_ix U32p | offsetof(struct pmop, op_pmflags)
858
657e3fc2
NC
859#ifdef USE_ITHREADS
860#define PMOP_pmoffset_ix IVp | offsetof(struct pmop, op_pmoffset)
861#endif
862
ba7298e3
NC
863# Yes, B::SV::sv and B::SV::gv really do end up generating identical code.
864#define SVOP_sv_ix SVp | offsetof(struct svop, op_sv)
865#define SVOP_gv_ix SVp | offsetof(struct svop, op_sv)
866
9488fb36
NC
867#define PADOP_padix_ix PADOFFSETp | offsetof(struct padop, op_padix)
868
39e120c1
NC
869#define COP_seq_ix U32p | offsetof(struct cop, cop_seq)
870#define COP_line_ix line_tp | offsetof(struct cop, cop_line)
871#if PERL_VERSION >= 9
872#define COP_hints_ix U32p | offsetof(struct cop, cop_hints)
873#else
874#define COP_hints_ix U8p | offsetof(struct cop, op_private)
875#endif
876
a9ed1a44
NC
877#ifdef USE_ITHREADS
878#define COP_stashpv_ix char_pp | offsetof(struct cop, cop_stashpv)
879#define COP_file_ix char_pp | offsetof(struct cop, cop_file)
880#else
881#define COP_stash_ix SVp | offsetof(struct cop, cop_stash)
882#define COP_filegv_ix SVp | offsetof(struct cop, cop_filegv)
883#endif
884
a8a597b2
MB
885MODULE = B PACKAGE = B::OP PREFIX = OP_
886
651aa52e
AE
887size_t
888OP_size(o)
889 B::OP o
890 CODE:
891 RETVAL = opsizes[cc_opclass(aTHX_ o)];
892 OUTPUT:
893 RETVAL
894
9b1961be
NC
895# The type checking code in B has always been identical for all OP types,
896# irrespective of whether the action is actually defined on that OP.
897# We should fix this
086f9b42 898void
9b1961be 899next(o)
a8a597b2 900 B::OP o
9b1961be 901 ALIAS:
086f9b42
NC
902 B::OP::next = OP_next_ix
903 B::OP::sibling = OP_sibling_ix
904 B::OP::targ = OP_targ_ix
905 B::OP::flags = OP_flags_ix
906 B::OP::private = OP_private_ix
907 B::UNOP::first = UNOP_first_ix
908 B::BINOP::last = BINOP_last_ix
909 B::LOGOP::other = LOGOP_other_ix
910 B::PMOP::pmreplstart = PMOP_pmreplstart_ix
911 B::LOOP::redoop = LOOP_redoop_ix
912 B::LOOP::nextop = LOOP_nextop_ix
913 B::LOOP::lastop = LOOP_lastop_ix
a78b89ef 914 B::PMOP::pmflags = PMOP_pmflags_ix
ba7298e3
NC
915 B::SVOP::sv = SVOP_sv_ix
916 B::SVOP::gv = SVOP_gv_ix
9488fb36 917 B::PADOP::padix = PADOP_padix_ix
39e120c1
NC
918 B::COP::cop_seq = COP_seq_ix
919 B::COP::line = COP_line_ix
920 B::COP::hints = COP_hints_ix
9b1961be
NC
921 PREINIT:
922 char *ptr;
086f9b42
NC
923 SV *ret;
924 PPCODE:
925 ptr = (ix & 0xFFFF) + (char *)o;
926 switch ((U8)(ix >> 16)) {
927 case (U8)(OPp >> 16):
928 {
929 OP *const o2 = *((OP **)ptr);
930 ret = sv_newmortal();
931 sv_setiv(newSVrv(ret, cc_opclassname(aTHX_ o2)), PTR2IV(o2));
932 break;
933 }
934 case (U8)(PADOFFSETp >> 16):
935 ret = sv_2mortal(newSVuv(*((PADOFFSET*)ptr)));
936 break;
937 case (U8)(U8p >> 16):
938 ret = sv_2mortal(newSVuv(*((U8*)ptr)));
939 break;
a78b89ef
NC
940 case (U8)(U32p >> 16):
941 ret = sv_2mortal(newSVuv(*((U32*)ptr)));
942 break;
ba7298e3
NC
943 case (U8)(SVp >> 16):
944 ret = make_sv_object(aTHX_ NULL, *((SV **)ptr));
945 break;
39e120c1
NC
946 case (U8)(line_tp >> 16):
947 ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
948 break;
657e3fc2
NC
949#ifdef USE_ITHREADS
950 case (U8)(IVp >> 16):
951 ret = sv_2mortal(newSViv(*((IV*)ptr)));
952 break;
a9ed1a44
NC
953 case (U8)(char_pp >> 16):
954 ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
955 break;
657e3fc2 956#endif
086f9b42
NC
957 }
958 ST(0) = ret;
959 XSRETURN(1);
a8a597b2
MB
960
961char *
3f872cb9
GS
962OP_name(o)
963 B::OP o
d2b33dc1
NC
964 ALIAS:
965 desc = 1
3f872cb9 966 CODE:
d2b33dc1 967 RETVAL = (char *)(ix ? PL_op_desc : PL_op_name)[o->op_type];
8063af02
DM
968 OUTPUT:
969 RETVAL
3f872cb9 970
8063af02 971void
a8a597b2
MB
972OP_ppaddr(o)
973 B::OP o
dc333d64
GS
974 PREINIT:
975 int i;
fdbd1d64 976 SV *sv = newSVpvs_flags("PL_ppaddr[OP_", SVs_TEMP);
a8a597b2 977 CODE:
dc333d64 978 sv_catpv(sv, PL_op_name[o->op_type]);
7c436af3 979 for (i=13; (STRLEN)i < SvCUR(sv); ++i)
dc333d64 980 SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]);
6beb30a6 981 sv_catpvs(sv, "]");
dc333d64 982 ST(0) = sv;
a8a597b2 983
7252851f 984#if PERL_VERSION >= 9
dd8be0e4
NC
985# These 3 are all bitfields, so we can't take their addresses.
986UV
987OP_type(o)
2814eb74 988 B::OP o
dd8be0e4
NC
989 ALIAS:
990 opt = 1
991 spare = 2
992 CODE:
993 switch(ix) {
994 case 1:
995 RETVAL = o->op_opt;
996 break;
997 case 2:
998 RETVAL = o->op_spare;
999 break;
1000 default:
1001 RETVAL = o->op_type;
1002 }
1003 OUTPUT:
1004 RETVAL
2814eb74 1005
7252851f
NC
1006#else
1007
dd8be0e4
NC
1008UV
1009OP_type(o)
7252851f 1010 B::OP o
dd8be0e4
NC
1011 ALIAS:
1012 seq = 1
1013 CODE:
1014 switch(ix) {
1015 case 1:
1016 RETVAL = o->op_seq;
1017 break;
1018 default:
1019 RETVAL = o->op_type;
1020 }
1021 OUTPUT:
1022 RETVAL
7252851f
NC
1023
1024#endif
1025
1df34986
AE
1026void
1027OP_oplist(o)
1028 B::OP o
1029 PPCODE:
1030 SP = oplist(aTHX_ o, SP);
1031
a8a597b2
MB
1032MODULE = B PACKAGE = B::LISTOP PREFIX = LISTOP_
1033
c03c2844
SM
1034U32
1035LISTOP_children(o)
1036 B::LISTOP o
1037 OP * kid = NO_INIT
1038 int i = NO_INIT
1039 CODE:
c03c2844
SM
1040 i = 0;
1041 for (kid = o->op_first; kid; kid = kid->op_sibling)
1042 i++;
8063af02
DM
1043 RETVAL = i;
1044 OUTPUT:
016e8ce0 1045 RETVAL
a8a597b2
MB
1046
1047MODULE = B PACKAGE = B::PMOP PREFIX = PMOP_
1048
20e98b0f
NC
1049#if PERL_VERSION <= 8
1050
a8a597b2
MB
1051void
1052PMOP_pmreplroot(o)
1053 B::PMOP o
1054 OP * root = NO_INIT
1055 CODE:
1056 ST(0) = sv_newmortal();
1057 root = o->op_pmreplroot;
1058 /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */
1059 if (o->op_type == OP_PUSHRE) {
20e98b0f 1060# ifdef USE_ITHREADS
9d2bbe64 1061 sv_setiv(ST(0), INT2PTR(PADOFFSET,root) );
20e98b0f 1062# else
a8a597b2
MB
1063 sv_setiv(newSVrv(ST(0), root ?
1064 svclassnames[SvTYPE((SV*)root)] : "B::SV"),
56431972 1065 PTR2IV(root));
20e98b0f 1066# endif
a8a597b2
MB
1067 }
1068 else {
56431972 1069 sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root));
a8a597b2
MB
1070 }
1071
20e98b0f
NC
1072#else
1073
1074void
1075PMOP_pmreplroot(o)
1076 B::PMOP o
1077 CODE:
1078 ST(0) = sv_newmortal();
1079 if (o->op_type == OP_PUSHRE) {
1080# ifdef USE_ITHREADS
1081 sv_setiv(ST(0), o->op_pmreplrootu.op_pmtargetoff);
1082# else
1083 GV *const target = o->op_pmreplrootu.op_pmtargetgv;
1084 sv_setiv(newSVrv(ST(0), target ?
1085 svclassnames[SvTYPE((SV*)target)] : "B::SV"),
1086 PTR2IV(target));
1087# endif
1088 }
1089 else {
1090 OP *const root = o->op_pmreplrootu.op_pmreplroot;
1091 sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)),
1092 PTR2IV(root));
1093 }
1094
1095#endif
1096
9d2bbe64 1097#ifdef USE_ITHREADS
016e8ce0 1098#define PMOP_pmstashpv(o) PmopSTASHPV(o);
9d2bbe64 1099
651aa52e
AE
1100char*
1101PMOP_pmstashpv(o)
1102 B::PMOP o
1103
1104#else
016e8ce0 1105#define PMOP_pmstash(o) PmopSTASH(o);
651aa52e
AE
1106
1107B::HV
1108PMOP_pmstash(o)
1109 B::PMOP o
1110
9d2bbe64
MB
1111#endif
1112
7c1f70cb 1113#if PERL_VERSION < 9
5b02c205
NC
1114#define PMOP_pmnext(o) o->op_pmnext
1115
1116B::PMOP
1117PMOP_pmnext(o)
1118 B::PMOP o
7c1f70cb
NC
1119
1120U32
1121PMOP_pmpermflags(o)
1122 B::PMOP o
1123
1124U8
1125PMOP_pmdynflags(o)
1126 B::PMOP o
1127
1128#endif
1129
a8a597b2
MB
1130void
1131PMOP_precomp(o)
1132 B::PMOP o
021d294f
NC
1133 PREINIT:
1134 dXSI32;
1135 REGEXP *rx;
a8a597b2 1136 CODE:
aaa362c4 1137 rx = PM_GETRE(o);
c737faaf 1138 ST(0) = sv_newmortal();
021d294f
NC
1139 if (rx) {
1140#if PERL_VERSION >= 9
1141 if (ix) {
1142 sv_setuv(ST(0), RX_EXTFLAGS(rx));
1143 } else
1144#endif
1145 {
1146 sv_setpvn(ST(0), RX_PRECOMP(rx), RX_PRELEN(rx));
1147 }
1148 }
c737faaf 1149
021d294f
NC
1150BOOT:
1151{
1152 CV *cv;
1153#ifdef USE_ITHREADS
1154 cv = newXS("B::PMOP::pmoffset", XS_B__OP_next, __FILE__);
1155 XSANY.any_i32 = PMOP_pmoffset_ix;
a9ed1a44
NC
1156 cv = newXS("B::COP::stashpv", XS_B__OP_next, __FILE__);
1157 XSANY.any_i32 = COP_stashpv_ix;
1158 cv = newXS("B::COP::file", XS_B__OP_next, __FILE__);
1159 XSANY.any_i32 = COP_file_ix;
1160#else
1161 cv = newXS("B::COP::stash", XS_B__OP_next, __FILE__);
1162 XSANY.any_i32 = COP_stash_ix;
1163 cv = newXS("B::COP::filegv", XS_B__OP_next, __FILE__);
1164 XSANY.any_i32 = COP_filegv_ix;
7c1f70cb 1165#endif
021d294f
NC
1166#if PERL_VERSION >= 9
1167 cv = newXS("B::PMOP::reflags", XS_B__PMOP_precomp, __FILE__);
1168 XSANY.any_i32 = 1;
1169#endif
1170}
1171
c518d492 1172MODULE = B PACKAGE = B::PADOP
7934575e 1173
7934575e 1174B::SV
c518d492 1175sv(o)
7934575e 1176 B::PADOP o
c518d492
NC
1177 ALIAS:
1178 gv = 1
1179 CODE:
1180 /* It happens that the output typemaps for B::SV and B::GV are
1181 identical. The "smarts" are in make_sv_object(), which determines
1182 which class to use based on SvTYPE(), rather than anything baked in
1183 at compile time. */
1184 if (o->op_padix) {
1185 RETVAL = PAD_SVl(o->op_padix);
1186 if (ix && SvTYPE(RETVAL) != SVt_PVGV)
1187 RETVAL = NULL;
1188 } else {
1189 RETVAL = NULL;
1190 }
1191 OUTPUT:
1192 RETVAL
a8a597b2
MB
1193
1194MODULE = B PACKAGE = B::PVOP PREFIX = PVOP_
1195
1196void
1197PVOP_pv(o)
1198 B::PVOP o
1199 CODE:
1200 /*
bec89253 1201 * OP_TRANS uses op_pv to point to a table of 256 or >=258 shorts
a8a597b2
MB
1202 * whereas other PVOPs point to a null terminated string.
1203 */
bec89253
RH
1204 if (o->op_type == OP_TRANS &&
1205 (o->op_private & OPpTRANS_COMPLEMENT) &&
1206 !(o->op_private & OPpTRANS_DELETE))
1207 {
5d7488b2
AL
1208 const short* const tbl = (short*)o->op_pv;
1209 const short entries = 257 + tbl[256];
d3d34884 1210 ST(0) = newSVpvn_flags(o->op_pv, entries * sizeof(short), SVs_TEMP);
bec89253
RH
1211 }
1212 else if (o->op_type == OP_TRANS) {
d3d34884 1213 ST(0) = newSVpvn_flags(o->op_pv, 256 * sizeof(short), SVs_TEMP);
bec89253
RH
1214 }
1215 else
d3d34884 1216 ST(0) = newSVpvn_flags(o->op_pv, strlen(o->op_pv), SVs_TEMP);
a8a597b2 1217
4b65a919 1218#define COP_label(o) CopLABEL(o)
fc15ae8f 1219#define COP_arybase(o) CopARYBASE_get(o)
a8a597b2
MB
1220
1221MODULE = B PACKAGE = B::COP PREFIX = COP_
1222
d5b8ed54
NC
1223const char *
1224COP_label(o)
1225 B::COP o
1226
a9ed1a44
NC
1227# Both pairs of accessors are provided for both ithreads and not, but for each,
1228# one pair is direct structure access, and 1 pair "faked up" with a more complex
1229# macro. We implement the direct structure access pair using the common code
1230# above (B::OP::next)
1231
1232#ifdef USE_ITHREADS
1233#define COP_stash(o) CopSTASH(o)
1234#define COP_filegv(o) CopFILEGV(o)
11faa288 1235
a8a597b2
MB
1236B::HV
1237COP_stash(o)
1238 B::COP o
1239
a9ed1a44
NC
1240B::GV
1241COP_filegv(o)
1242 B::COP o
1243
1244#else
1245#define COP_stashpv(o) CopSTASHPV(o)
1246#define COP_file(o) CopFILE(o)
1247
1248char *
1249COP_stashpv(o)
1250 B::COP o
1251
57843af0
GS
1252char *
1253COP_file(o)
a8a597b2
MB
1254 B::COP o
1255
a9ed1a44 1256#endif
1df34986 1257
a8a597b2
MB
1258I32
1259COP_arybase(o)
1260 B::COP o
1261
5c3c3f81 1262void
b295d113
TH
1263COP_warnings(o)
1264 B::COP o
5c3c3f81 1265 PPCODE:
13d356f3 1266#if PERL_VERSION >= 9
9496d2e5 1267 ST(0) = make_warnings_object(aTHX_ o->cop_warnings);
13d356f3
NC
1268#else
1269 ST(0) = make_sv_object(aTHX_ NULL, o->cop_warnings);
1270#endif
5c3c3f81 1271 XSRETURN(1);
b295d113 1272
670f1322 1273void
6e6a1aef
RGS
1274COP_io(o)
1275 B::COP o
11bcd5da 1276 PPCODE:
13d356f3 1277#if PERL_VERSION >= 9
9496d2e5 1278 ST(0) = make_cop_io_object(aTHX_ o);
13d356f3
NC
1279#else
1280 ST(0) = make_sv_object(aTHX_ NULL, o->cop_io);
1281#endif
11bcd5da 1282 XSRETURN(1);
6e6a1aef 1283
13d356f3
NC
1284#if PERL_VERSION >= 9
1285
fd9f6265
JJ
1286B::RHE
1287COP_hints_hash(o)
1288 B::COP o
1289 CODE:
20439bc7 1290 RETVAL = CopHINTHASH_get(o);
fd9f6265
JJ
1291 OUTPUT:
1292 RETVAL
1293
e412117e
NC
1294#endif
1295
651aa52e
AE
1296MODULE = B PACKAGE = B::SV
1297
de64752d
NC
1298#define MAGICAL_FLAG_BITS (SVs_GMG|SVs_SMG|SVs_RMG)
1299
651aa52e 1300U32
de64752d 1301REFCNT(sv)
651aa52e 1302 B::SV sv
de64752d
NC
1303 ALIAS:
1304 FLAGS = 0xFFFFFFFF
1305 SvTYPE = SVTYPEMASK
1306 POK = SVf_POK
1307 ROK = SVf_ROK
1308 MAGICAL = MAGICAL_FLAG_BITS
1309 CODE:
1310 RETVAL = ix ? (SvFLAGS(sv) & (U32)ix) : SvREFCNT(sv);
1311 OUTPUT:
1312 RETVAL
651aa52e 1313
9efba5c8 1314void
429a5ce7
SM
1315object_2svref(sv)
1316 B::SV sv
9efba5c8
NC
1317 PPCODE:
1318 ST(0) = sv_2mortal(newRV(sv));
1319 XSRETURN(1);
1320
a8a597b2
MB
1321MODULE = B PACKAGE = B::IV PREFIX = Sv
1322
1323IV
1324SvIV(sv)
1325 B::IV sv
1326
e4da9d6a 1327MODULE = B PACKAGE = B::IV
a8a597b2 1328
e4da9d6a
NC
1329#define sv_SVp 0x00000
1330#define sv_IVp 0x10000
1331#define sv_UVp 0x20000
1332#define sv_STRLENp 0x30000
1333#define sv_U32p 0x40000
1334#define sv_U8p 0x50000
1335#define sv_char_pp 0x60000
1336#define sv_NVp 0x70000
6782c6e0 1337#define sv_char_p 0x80000
3da43c35 1338#define sv_SSize_tp 0x90000
ffc5d9fc
NC
1339#define sv_I32p 0xA0000
1340#define sv_U16p 0xB0000
e4da9d6a
NC
1341
1342#define IV_ivx_ix sv_IVp | offsetof(struct xpviv, xiv_iv)
1343#define IV_uvx_ix sv_UVp | offsetof(struct xpvuv, xuv_uv)
1344#define NV_nvx_ix sv_NVp | offsetof(struct xpvnv, xnv_u.xnv_nv)
1345
1346#if PERL_VERSION >= 10
1347#define NV_cop_seq_range_low_ix \
1348 sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
1349#define NV_cop_seq_range_high_ix \
1350 sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
1351#define NV_parent_pad_index_ix \
1352 sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
1353#define NV_parent_fakelex_flags_ix \
1354 sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
1355#else
1356#define NV_cop_seq_range_low_ix \
1357 sv_NVp | offsetof(struct xpvnv, xnv_nv)
1358#define NV_cop_seq_range_high_ix \
1359 sv_UVp | offsetof(struct xpvnv, xuv_uv)
1360#define NV_parent_pad_index_ix \
1361 sv_NVp | offsetof(struct xpvnv, xnv_nv)
1362#define NV_parent_fakelex_flags_ix \
1363 sv_UVp | offsetof(struct xpvnv, xuv_uv)
1364#endif
0ca04487 1365
6782c6e0
NC
1366#define PV_cur_ix sv_STRLENp | offsetof(struct xpv, xpv_cur)
1367#define PV_len_ix sv_STRLENp | offsetof(struct xpv, xpv_len)
1368
1369#define PVMG_stash_ix sv_SVp | offsetof(struct xpvmg, xmg_stash)
1370
91a71e08
NC
1371#if PERL_VERSION >= 10
1372#define PVBM_useful_ix sv_I32p | offsetof(struct xpvgv, xiv_u.xivu_i32)
1373#define PVBM_previous_ix sv_U32p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_previous)
1374#define PVBM_rare_ix sv_U8p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_rare)
1375#else
1376#define PVBM_useful_ix sv_I32p | offsetof(struct xpvbm, xbm_useful)
1377#define PVBM_previous_ix sv_U16p | offsetof(struct xpvbm, xbm_previous)
1378#define PVBM_rare_ix sv_U8p | offsetof(struct xpvbm, xbm_rare)
1379#endif
1380
6782c6e0
NC
1381#define PVLV_targoff_ix sv_U32p | offsetof(struct xpvlv, xlv_targoff)
1382#define PVLV_targlen_ix sv_U32p | offsetof(struct xpvlv, xlv_targlen)
1383#define PVLV_targ_ix sv_SVp | offsetof(struct xpvlv, xlv_targ)
1384#define PVLV_type_ix sv_char_p | offsetof(struct xpvlv, xlv_type)
1385
f1f19364
NC
1386#if PERL_VERSION >= 10
1387#define PVGV_stash_ix sv_SVp | offsetof(struct xpvgv, xnv_u.xgv_stash)
1388#define PVGV_flags_ix sv_STRLENp | offsetof(struct xpvgv, xpv_cur)
55440d31 1389#define PVIO_lines_ix sv_IVp | offsetof(struct xpvio, xiv_iv)
f1f19364
NC
1390#else
1391#define PVGV_stash_ix sv_SVp | offsetof(struct xpvgv, xgv_stash)
1392#define PVGV_flags_ix sv_U8p | offsetof(struct xpvgv, xgv_flags)
55440d31 1393#define PVIO_lines_ix sv_IVp | offsetof(struct xpvio, xio_lines)
f1f19364
NC
1394#endif
1395
55440d31
NC
1396#define PVIO_page_ix sv_IVp | offsetof(struct xpvio, xio_page)
1397#define PVIO_page_len_ix sv_IVp | offsetof(struct xpvio, xio_page_len)
1398#define PVIO_lines_left_ix sv_IVp | offsetof(struct xpvio, xio_lines_left)
1399#define PVIO_top_name_ix sv_char_pp | offsetof(struct xpvio, xio_top_name)
1400#define PVIO_top_gv_ix sv_SVp | offsetof(struct xpvio, xio_top_gv)
1401#define PVIO_fmt_name_ix sv_char_pp | offsetof(struct xpvio, xio_fmt_name)
1402#define PVIO_fmt_gv_ix sv_SVp | offsetof(struct xpvio, xio_fmt_gv)
1403#define PVIO_bottom_name_ix sv_char_pp | offsetof(struct xpvio, xio_bottom_name)
1404#define PVIO_bottom_gv_ix sv_SVp | offsetof(struct xpvio, xio_bottom_gv)
1405#define PVIO_type_ix sv_char_p | offsetof(struct xpvio, xio_type)
1406#define PVIO_flags_ix sv_U8p | offsetof(struct xpvio, xio_flags)
1407
3da43c35
NC
1408#define PVAV_max_ix sv_SSize_tp | offsetof(struct xpvav, xav_max)
1409
1410#define PVFM_lines_ix sv_IVp | offsetof(struct xpvfm, xfm_lines)
1411
ffc5d9fc
NC
1412#define PVCV_stash_ix sv_SVp | offsetof(struct xpvcv, xcv_stash)
1413#define PVCV_gv_ix sv_SVp | offsetof(struct xpvcv, xcv_gv)
1414#define PVCV_file_ix sv_char_pp | offsetof(struct xpvcv, xcv_file)
1415#define PVCV_depth_ix sv_I32p | offsetof(struct xpvcv, xcv_depth)
1416#define PVCV_padlist_ix sv_SVp | offsetof(struct xpvcv, xcv_padlist)
1417#define PVCV_outside_ix sv_SVp | offsetof(struct xpvcv, xcv_outside)
1418#define PVCV_outside_seq_ix sv_U32p | offsetof(struct xpvcv, xcv_outside_seq)
1419#define PVCV_flags_ix sv_U16p | offsetof(struct xpvcv, xcv_flags)
1420
d65a2b0a
NC
1421#define PVHV_max_ix sv_STRLENp | offsetof(struct xpvhv, xhv_max)
1422
1423#if PERL_VERSION > 12
1424#define PVHV_keys_ix sv_STRLENp | offsetof(struct xpvhv, xhv_keys)
1425#else
1426#define PVHV_keys_ix sv_IVp | offsetof(struct xpvhv, xhv_keys)
1427#endif
1428
e4da9d6a
NC
1429# The type checking code in B has always been identical for all SV types,
1430# irrespective of whether the action is actually defined on that SV.
1431# We should fix this
1432void
1433IVX(sv)
1434 B::SV sv
1435 ALIAS:
1436 B::IV::IVX = IV_ivx_ix
1437 B::IV::UVX = IV_uvx_ix
1438 B::NV::NVX = NV_nvx_ix
1439 B::NV::COP_SEQ_RANGE_LOW = NV_cop_seq_range_low_ix
1440 B::NV::COP_SEQ_RANGE_HIGH = NV_cop_seq_range_high_ix
1441 B::NV::PARENT_PAD_INDEX = NV_parent_pad_index_ix
1442 B::NV::PARENT_FAKELEX_FLAGS = NV_parent_fakelex_flags_ix
6782c6e0
NC
1443 B::PV::CUR = PV_cur_ix
1444 B::PV::LEN = PV_len_ix
1445 B::PVMG::SvSTASH = PVMG_stash_ix
1446 B::PVLV::TARGOFF = PVLV_targoff_ix
1447 B::PVLV::TARGLEN = PVLV_targlen_ix
1448 B::PVLV::TARG = PVLV_targ_ix
1449 B::PVLV::TYPE = PVLV_type_ix
f1f19364
NC
1450 B::GV::STASH = PVGV_stash_ix
1451 B::GV::GvFLAGS = PVGV_flags_ix
91a71e08
NC
1452 B::BM::USEFUL = PVBM_useful_ix
1453 B::BM::PREVIOUS = PVBM_previous_ix
1454 B::BM::RARE = PVBM_rare_ix
55440d31
NC
1455 B::IO::LINES = PVIO_lines_ix
1456 B::IO::PAGE = PVIO_page_ix
1457 B::IO::PAGE_LEN = PVIO_page_len_ix
1458 B::IO::LINES_LEFT = PVIO_lines_left_ix
1459 B::IO::TOP_NAME = PVIO_top_name_ix
1460 B::IO::TOP_GV = PVIO_top_gv_ix
1461 B::IO::FMT_NAME = PVIO_fmt_name_ix
1462 B::IO::FMT_GV = PVIO_fmt_gv_ix
1463 B::IO::BOTTOM_NAME = PVIO_bottom_name_ix
1464 B::IO::BOTTOM_GV = PVIO_bottom_gv_ix
1465 B::IO::IoTYPE = PVIO_type_ix
1466 B::IO::IoFLAGS = PVIO_flags_ix
3da43c35
NC
1467 B::AV::MAX = PVAV_max_ix
1468 B::FM::LINES = PVFM_lines_ix
ffc5d9fc
NC
1469 B::CV::STASH = PVCV_stash_ix
1470 B::CV::GV = PVCV_gv_ix
1471 B::CV::FILE = PVCV_file_ix
1472 B::CV::DEPTH = PVCV_depth_ix
1473 B::CV::PADLIST = PVCV_padlist_ix
1474 B::CV::OUTSIDE = PVCV_outside_ix
1475 B::CV::OUTSIDE_SEQ = PVCV_outside_seq_ix
1476 B::CV::CvFLAGS = PVCV_flags_ix
d65a2b0a
NC
1477 B::HV::MAX = PVHV_max_ix
1478 B::HV::KEYS = PVHV_keys_ix
e4da9d6a
NC
1479 PREINIT:
1480 char *ptr;
1481 SV *ret;
1482 PPCODE:
1483 ptr = (ix & 0xFFFF) + (char *)SvANY(sv);
1484 switch ((U8)(ix >> 16)) {
1485 case (U8)(sv_SVp >> 16):
1486 ret = make_sv_object(aTHX_ NULL, *((SV **)ptr));
1487 break;
1488 case (U8)(sv_IVp >> 16):
1489 ret = sv_2mortal(newSViv(*((IV *)ptr)));
1490 break;
1491 case (U8)(sv_UVp >> 16):
1492 ret = sv_2mortal(newSVuv(*((UV *)ptr)));
1493 break;
6782c6e0
NC
1494 case (U8)(sv_STRLENp >> 16):
1495 ret = sv_2mortal(newSVuv(*((STRLEN *)ptr)));
1496 break;
e4da9d6a
NC
1497 case (U8)(sv_U32p >> 16):
1498 ret = sv_2mortal(newSVuv(*((U32 *)ptr)));
1499 break;
1500 case (U8)(sv_U8p >> 16):
1501 ret = sv_2mortal(newSVuv(*((U8 *)ptr)));
1502 break;
1503 case (U8)(sv_char_pp >> 16):
1504 ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
1505 break;
1506 case (U8)(sv_NVp >> 16):
1507 ret = sv_2mortal(newSVnv(*((NV *)ptr)));
1508 break;
6782c6e0
NC
1509 case (U8)(sv_char_p >> 16):
1510 ret = newSVpvn_flags((char *)ptr, 1, SVs_TEMP);
1511 break;
3da43c35
NC
1512 case (U8)(sv_SSize_tp >> 16):
1513 ret = sv_2mortal(newSViv(*((SSize_t *)ptr)));
1514 break;
ffc5d9fc
NC
1515 case (U8)(sv_I32p >> 16):
1516 ret = sv_2mortal(newSVuv(*((I32 *)ptr)));
1517 break;
1518 case (U8)(sv_U16p >> 16):
1519 ret = sv_2mortal(newSVuv(*((U16 *)ptr)));
1520 break;
e4da9d6a
NC
1521 }
1522 ST(0) = ret;
1523 XSRETURN(1);
a8a597b2 1524
a8a597b2
MB
1525void
1526packiv(sv)
1527 B::IV sv
6829f5e2
NC
1528 ALIAS:
1529 needs64bits = 1
a8a597b2 1530 CODE:
6829f5e2
NC
1531 if (ix) {
1532 ST(0) = boolSV((I32)SvIVX(sv) != SvIVX(sv));
1533 } else if (sizeof(IV) == 8) {
a8a597b2 1534 U32 wp[2];
5d7488b2 1535 const IV iv = SvIVX(sv);
a8a597b2
MB
1536 /*
1537 * The following way of spelling 32 is to stop compilers on
1538 * 32-bit architectures from moaning about the shift count
1539 * being >= the width of the type. Such architectures don't
1540 * reach this code anyway (unless sizeof(IV) > 8 but then
1541 * everything else breaks too so I'm not fussed at the moment).
1542 */
42718184
RB
1543#ifdef UV_IS_QUAD
1544 wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1545#else
1546 wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1547#endif
a8a597b2 1548 wp[1] = htonl(iv & 0xffffffff);
d3d34884 1549 ST(0) = newSVpvn_flags((char *)wp, 8, SVs_TEMP);
a8a597b2
MB
1550 } else {
1551 U32 w = htonl((U32)SvIVX(sv));
d3d34884 1552 ST(0) = newSVpvn_flags((char *)&w, 4, SVs_TEMP);
a8a597b2
MB
1553 }
1554
4df7f6af 1555#if PERL_VERSION >= 11
f046b1bd
NC
1556# The input typemap checking makes no distinction between different SV types,
1557# so the XS body will generate the same C code, despite the different XS
1558# "types". So there is no change in behaviour from doing newXS like this,
1559# compared with the old approach of having a (near) duplicate XS body.
1560# We should fix the typemap checking.
4df7f6af 1561
f046b1bd
NC
1562BOOT:
1563 newXS("B::IV::RV", XS_B__PV_RV, __FILE__);
4df7f6af
NC
1564
1565#endif
1566
a8a597b2
MB
1567MODULE = B PACKAGE = B::NV PREFIX = Sv
1568
76ef7183 1569NV
a8a597b2
MB
1570SvNV(sv)
1571 B::NV sv
1572
4df7f6af
NC
1573#if PERL_VERSION < 11
1574
a8a597b2
MB
1575MODULE = B PACKAGE = B::RV PREFIX = Sv
1576
1577B::SV
1578SvRV(sv)
1579 B::RV sv
1580
4df7f6af
NC
1581#endif
1582
a8a597b2
MB
1583MODULE = B PACKAGE = B::PV PREFIX = Sv
1584
0b40bd6d
RH
1585char*
1586SvPVX(sv)
1587 B::PV sv
1588
b326da91
MB
1589B::SV
1590SvRV(sv)
1591 B::PV sv
1592 CODE:
1593 if( SvROK(sv) ) {
1594 RETVAL = SvRV(sv);
1595 }
1596 else {
1597 croak( "argument is not SvROK" );
1598 }
1599 OUTPUT:
1600 RETVAL
1601
a8a597b2
MB
1602void
1603SvPV(sv)
1604 B::PV sv
1605 CODE:
c0b20461 1606 if( SvPOK(sv) ) {
fdbd1d64
NC
1607 STRLEN len = SvCUR(sv);
1608 const char *p = SvPVX_const(sv);
0eaead75
NC
1609#if PERL_VERSION < 10
1610 /* Before 5.10 (well 931b58fb28fa5ca7), PAD_COMPNAME_GEN was stored
1611 in SvCUR(), which meant we had to attempt this special casing
1612 to avoid tripping up over variable names in the pads. */
fdbd1d64 1613 if((SvLEN(sv) && len >= SvLEN(sv))) {
b55685ae
NC
1614 /* It claims to be longer than the space allocated for it -
1615 presuambly it's a variable name in the pad */
fdbd1d64 1616 len = strlen(p);
b55685ae 1617 }
0eaead75 1618#endif
fdbd1d64 1619 ST(0) = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
b326da91
MB
1620 }
1621 else {
1622 /* XXX for backward compatibility, but should fail */
1623 /* croak( "argument is not SvPOK" ); */
fdbd1d64 1624 ST(0) = sv_newmortal();
b326da91 1625 }
a8a597b2 1626
5a44e503
NC
1627# This used to read 257. I think that that was buggy - should have been 258.
1628# (The "\0", the flags byte, and 256 for the table. Not that anything
1629# anywhere calls this method. NWC.
651aa52e
AE
1630void
1631SvPVBM(sv)
1632 B::PV sv
1633 CODE:
fdbd1d64
NC
1634 ST(0) = newSVpvn_flags(SvPVX_const(sv),
1635 SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0),
1636 SVs_TEMP);
651aa52e 1637
a8a597b2
MB
1638MODULE = B PACKAGE = B::PVMG PREFIX = Sv
1639
1640void
1641SvMAGIC(sv)
1642 B::PVMG sv
1643 MAGIC * mg = NO_INIT
1644 PPCODE:
1645 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
9496d2e5 1646 XPUSHs(make_mg_object(aTHX_ mg));
a8a597b2 1647
5c35adbb
NC
1648MODULE = B PACKAGE = B::REGEXP
1649
1650#if PERL_VERSION >= 11
1651
1652IV
1653REGEX(sv)
07bc277f 1654 B::REGEXP sv
5c35adbb 1655 CODE:
288b8c02
NC
1656 /* FIXME - can we code this method more efficiently? */
1657 RETVAL = PTR2IV(sv);
5c35adbb
NC
1658 OUTPUT:
1659 RETVAL
1660
1661SV*
1662precomp(sv)
07bc277f 1663 B::REGEXP sv
5c35adbb 1664 CODE:
288b8c02 1665 RETVAL = newSVpvn( RX_PRECOMP(sv), RX_PRELEN(sv) );
5c35adbb
NC
1666 OUTPUT:
1667 RETVAL
1668
1669#endif
1670
a8a597b2
MB
1671#define MgMOREMAGIC(mg) mg->mg_moremagic
1672#define MgPRIVATE(mg) mg->mg_private
1673#define MgTYPE(mg) mg->mg_type
1674#define MgFLAGS(mg) mg->mg_flags
1675#define MgOBJ(mg) mg->mg_obj
88b39979 1676#define MgLENGTH(mg) mg->mg_len
bde7177d 1677#define MgREGEX(mg) PTR2IV(mg->mg_obj)
a8a597b2
MB
1678
1679MODULE = B PACKAGE = B::MAGIC PREFIX = Mg
1680
1681B::MAGIC
1682MgMOREMAGIC(mg)
1683 B::MAGIC mg
c5f0f3aa
RGS
1684 CODE:
1685 if( MgMOREMAGIC(mg) ) {
1686 RETVAL = MgMOREMAGIC(mg);
1687 }
1688 else {
1689 XSRETURN_UNDEF;
1690 }
1691 OUTPUT:
1692 RETVAL
a8a597b2
MB
1693
1694U16
1695MgPRIVATE(mg)
1696 B::MAGIC mg
1697
1698char
1699MgTYPE(mg)
1700 B::MAGIC mg
1701
1702U8
1703MgFLAGS(mg)
1704 B::MAGIC mg
1705
1706B::SV
1707MgOBJ(mg)
1708 B::MAGIC mg
b326da91 1709
9d2bbe64
MB
1710IV
1711MgREGEX(mg)
1712 B::MAGIC mg
1713 CODE:
a8248b05 1714 if(mg->mg_type == PERL_MAGIC_qr) {
9d2bbe64
MB
1715 RETVAL = MgREGEX(mg);
1716 }
1717 else {
1718 croak( "REGEX is only meaningful on r-magic" );
1719 }
1720 OUTPUT:
1721 RETVAL
1722
b326da91
MB
1723SV*
1724precomp(mg)
1725 B::MAGIC mg
1726 CODE:
a8248b05 1727 if (mg->mg_type == PERL_MAGIC_qr) {
b326da91 1728 REGEXP* rx = (REGEXP*)mg->mg_obj;
ef35129c 1729 RETVAL = Nullsv;
b326da91 1730 if( rx )
220fc49f 1731 RETVAL = newSVpvn( RX_PRECOMP(rx), RX_PRELEN(rx) );
b326da91
MB
1732 }
1733 else {
1734 croak( "precomp is only meaningful on r-magic" );
1735 }
1736 OUTPUT:
1737 RETVAL
a8a597b2 1738
88b39979
VB
1739I32
1740MgLENGTH(mg)
1741 B::MAGIC mg
1742
a8a597b2
MB
1743void
1744MgPTR(mg)
1745 B::MAGIC mg
1746 CODE:
88b39979
VB
1747 if (mg->mg_ptr){
1748 if (mg->mg_len >= 0){
fdbd1d64 1749 ST(0) = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
651aa52e 1750 } else if (mg->mg_len == HEf_SVKEY) {
9496d2e5 1751 ST(0) = make_sv_object(aTHX_ NULL, (SV*)mg->mg_ptr);
fdbd1d64
NC
1752 } else
1753 ST(0) = sv_newmortal();
1754 } else
1755 ST(0) = sv_newmortal();
a8a597b2 1756
a8a597b2
MB
1757MODULE = B PACKAGE = B::BM PREFIX = Bm
1758
a8a597b2
MB
1759void
1760BmTABLE(sv)
1761 B::BM sv
1762 STRLEN len = NO_INIT
1763 char * str = NO_INIT
1764 CODE:
1765 str = SvPV(sv, len);
1766 /* Boyer-Moore table is just after string and its safety-margin \0 */
d3d34884 1767 ST(0) = newSVpvn_flags(str + len + PERL_FBM_TABLE_OFFSET, 256, SVs_TEMP);
a8a597b2
MB
1768
1769MODULE = B PACKAGE = B::GV PREFIX = Gv
1770
1771void
1772GvNAME(gv)
1773 B::GV gv
cbf9c13f
NC
1774 ALIAS:
1775 FILE = 1
435e8dd0 1776 B::HV::NAME = 2
a8a597b2 1777 CODE:
6beb30a6 1778#if PERL_VERSION >= 10
435e8dd0
NC
1779 ST(0) = sv_2mortal(newSVhek(!ix ? GvNAME_HEK(gv)
1780 : (ix == 1 ? GvFILE_HEK(gv)
1781 : HvNAME_HEK((HV *)gv))));
6beb30a6 1782#else
435e8dd0
NC
1783 ST(0) = !ix ? newSVpvn_flags(GvNAME(gv), GvNAMELEN(gv), SVs_TEMP)
1784 : sv_2mortal(newSVpv(ix == 1 ? GvFILE(gv) : HvNAME((HV *)gv), 0))
6beb30a6 1785#endif
a8a597b2 1786
87d7fd28
GS
1787bool
1788is_empty(gv)
1789 B::GV gv
711fbbf0
NC
1790 ALIAS:
1791 isGV_with_GP = 1
87d7fd28 1792 CODE:
711fbbf0 1793 if (ix) {
50786ba8 1794#if PERL_VERSION >= 9
711fbbf0 1795 RETVAL = isGV_with_GP(gv) ? TRUE : FALSE;
50786ba8 1796#else
711fbbf0 1797 RETVAL = TRUE; /* In 5.8 and earlier they all are. */
50786ba8 1798#endif
711fbbf0
NC
1799 } else {
1800 RETVAL = GvGP(gv) == Null(GP*);
1801 }
50786ba8 1802 OUTPUT:
711fbbf0 1803 RETVAL
50786ba8 1804
651aa52e
AE
1805void*
1806GvGP(gv)
1807 B::GV gv
1808
257e0650
NC
1809#define GP_sv_ix SVp | offsetof(struct gp, gp_sv)
1810#define GP_io_ix SVp | offsetof(struct gp, gp_io)
1811#define GP_cv_ix SVp | offsetof(struct gp, gp_cv)
1812#define GP_cvgen_ix U32p | offsetof(struct gp, gp_cvgen)
1813#define GP_refcnt_ix U32p | offsetof(struct gp, gp_refcnt)
1814#define GP_hv_ix SVp | offsetof(struct gp, gp_hv)
1815#define GP_av_ix SVp | offsetof(struct gp, gp_av)
1816#define GP_form_ix SVp | offsetof(struct gp, gp_form)
1817#define GP_egv_ix SVp | offsetof(struct gp, gp_egv)
1818#define GP_line_ix line_tp | offsetof(struct gp, gp_line)
a8a597b2 1819
257e0650
NC
1820void
1821SV(gv)
a8a597b2 1822 B::GV gv
257e0650
NC
1823 ALIAS:
1824 SV = GP_sv_ix
1825 IO = GP_io_ix
1826 CV = GP_cv_ix
1827 CVGEN = GP_cvgen_ix
1828 GvREFCNT = GP_refcnt_ix
1829 HV = GP_hv_ix
1830 AV = GP_av_ix
1831 FORM = GP_form_ix
1832 EGV = GP_egv_ix
1833 LINE = GP_line_ix
1834 PREINIT:
1835 GP *gp;
1836 char *ptr;
1837 SV *ret;
1838 PPCODE:
1839 gp = GvGP(gv);
1840 if (!gp) {
1841 const GV *const gv = CvGV(cv);
46c3f339 1842 Perl_croak(aTHX_ "NULL gp in B::GV::%s", gv ? GvNAME(gv) : "???");
257e0650
NC
1843 }
1844 ptr = (ix & 0xFFFF) + (char *)gp;
1845 switch ((U8)(ix >> 16)) {
1846 case (U8)(SVp >> 16):
1847 ret = make_sv_object(aTHX_ NULL, *((SV **)ptr));
1848 break;
1849 case (U8)(U32p >> 16):
1850 ret = sv_2mortal(newSVuv(*((U32*)ptr)));
1851 break;
1852 case (U8)(line_tp >> 16):
1853 ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
1854 break;
1855 }
1856 ST(0) = ret;
1857 XSRETURN(1);
a8a597b2
MB
1858
1859B::GV
1860GvFILEGV(gv)
1861 B::GV gv
1862
a8a597b2
MB
1863MODULE = B PACKAGE = B::IO PREFIX = Io
1864
04071355
NC
1865#if PERL_VERSION <= 8
1866
a8a597b2
MB
1867short
1868IoSUBPROCESS(io)
1869 B::IO io
1870
04071355
NC
1871#endif
1872
b326da91
MB
1873bool
1874IsSTD(io,name)
1875 B::IO io
5d7488b2 1876 const char* name
b326da91
MB
1877 PREINIT:
1878 PerlIO* handle = 0;
1879 CODE:
1880 if( strEQ( name, "stdin" ) ) {
1881 handle = PerlIO_stdin();
1882 }
1883 else if( strEQ( name, "stdout" ) ) {
1884 handle = PerlIO_stdout();
1885 }
1886 else if( strEQ( name, "stderr" ) ) {
1887 handle = PerlIO_stderr();
1888 }
1889 else {
1890 croak( "Invalid value '%s'", name );
1891 }
1892 RETVAL = handle == IoIFP(io);
1893 OUTPUT:
1894 RETVAL
1895
a8a597b2
MB
1896MODULE = B PACKAGE = B::AV PREFIX = Av
1897
1898SSize_t
1899AvFILL(av)
1900 B::AV av
1901
a8a597b2
MB
1902void
1903AvARRAY(av)
1904 B::AV av
1905 PPCODE:
1906 if (AvFILL(av) >= 0) {
1907 SV **svp = AvARRAY(av);
1908 I32 i;
1909 for (i = 0; i <= AvFILL(av); i++)
9496d2e5 1910 XPUSHs(make_sv_object(aTHX_ NULL, svp[i]));
a8a597b2
MB
1911 }
1912
429a5ce7
SM
1913void
1914AvARRAYelt(av, idx)
1915 B::AV av
1916 int idx
1917 PPCODE:
1918 if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
9496d2e5 1919 XPUSHs(make_sv_object(aTHX_ NULL, (AvARRAY(av)[idx])));
429a5ce7 1920 else
9496d2e5 1921 XPUSHs(make_sv_object(aTHX_ NULL, NULL));
429a5ce7 1922
edcc7c74
NC
1923#if PERL_VERSION < 9
1924
5b02c205
NC
1925#define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1926
1927IV
1928AvOFF(av)
1929 B::AV av
1930
edcc7c74
NC
1931MODULE = B PACKAGE = B::AV
1932
1933U8
1934AvFLAGS(av)
1935 B::AV av
1936
1937#endif
1938
a8a597b2
MB
1939MODULE = B PACKAGE = B::CV PREFIX = Cv
1940
651aa52e
AE
1941U32
1942CvCONST(cv)
1943 B::CV cv
1944
a8a597b2
MB
1945B::OP
1946CvSTART(cv)
1947 B::CV cv
a0da4400
NC
1948 ALIAS:
1949 ROOT = 1
bf53b3a5 1950 CODE:
a0da4400 1951 RETVAL = CvISXSUB(cv) ? NULL : ix ? CvROOT(cv) : CvSTART(cv);
d04ba589
NC
1952 OUTPUT:
1953 RETVAL
a8a597b2 1954
a8a597b2
MB
1955void
1956CvXSUB(cv)
1957 B::CV cv
96819e59
NC
1958 ALIAS:
1959 XSUBANY = 1
a8a597b2 1960 CODE:
96819e59 1961 ST(0) = ix && CvCONST(cv)
9496d2e5 1962 ? make_sv_object(aTHX_ NULL, (SV *)CvXSUBANY(cv).any_ptr)
96819e59
NC
1963 : sv_2mortal(newSViv(CvISXSUB(cv)
1964 ? (ix ? CvXSUBANY(cv).any_iv
1965 : PTR2IV(CvXSUB(cv)))
1966 : 0));
a8a597b2 1967
de3f1649
JT
1968MODULE = B PACKAGE = B::CV PREFIX = cv_
1969
1970B::SV
1971cv_const_sv(cv)
1972 B::CV cv
1973
a8a597b2
MB
1974MODULE = B PACKAGE = B::HV PREFIX = Hv
1975
1976STRLEN
1977HvFILL(hv)
1978 B::HV hv
1979
a8a597b2
MB
1980I32
1981HvRITER(hv)
1982 B::HV hv
1983
edcc7c74
NC
1984#if PERL_VERSION < 9
1985
1986B::PMOP
1987HvPMROOT(hv)
1988 B::HV hv
1989
1990#endif
1991
a8a597b2
MB
1992void
1993HvARRAY(hv)
1994 B::HV hv
1995 PPCODE:
1996 if (HvKEYS(hv) > 0) {
1997 SV *sv;
1998 char *key;
1999 I32 len;
2000 (void)hv_iterinit(hv);
2001 EXTEND(sp, HvKEYS(hv) * 2);
8063af02 2002 while ((sv = hv_iternextsv(hv, &key, &len))) {
22f1178f 2003 mPUSHp(key, len);
9496d2e5 2004 PUSHs(make_sv_object(aTHX_ NULL, sv));
a8a597b2
MB
2005 }
2006 }
fd9f6265
JJ
2007
2008MODULE = B PACKAGE = B::HE PREFIX = He
2009
2010B::SV
2011HeVAL(he)
2012 B::HE he
b2619626
NC
2013 ALIAS:
2014 SVKEY_force = 1
2015 CODE:
2016 RETVAL = ix ? HeSVKEY_force(he) : HeVAL(he);
2017 OUTPUT:
2018 RETVAL
fd9f6265
JJ
2019
2020U32
2021HeHASH(he)
2022 B::HE he
2023
fd9f6265
JJ
2024MODULE = B PACKAGE = B::RHE PREFIX = RHE_
2025
e412117e
NC
2026#if PERL_VERSION >= 9
2027
fd9f6265
JJ
2028SV*
2029RHE_HASH(h)
2030 B::RHE h
2031 CODE:
20439bc7 2032 RETVAL = newRV( (SV*)cophh_2hv(h, 0) );
fd9f6265
JJ
2033 OUTPUT:
2034 RETVAL
e412117e
NC
2035
2036#endif