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