This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Abolish xbm_rare. Move BmUSEFUL() to union _xnvu and BmPREVIOUS() to the UV.
[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
NC
1621 if (ix == 3) {
1622 p = SvPV(sv, len);
1623 /* Boyer-Moore table is just after string and its safety-margin \0 */
1624 p += len + PERL_FBM_TABLE_OFFSET;
1625 len = 256;
1626 } else if (ix == 2) {
f4c36584 1627 /* This used to read 257. I think that that was buggy - should have
26ec7981
NC
1628 been 258. (The "\0", the flags byte, and 256 for the table.)
1629 The only user of this method is B::Bytecode in B::PV::bsave.
1630 I'm guessing that nothing tested the runtime correctness of
1631 output of bytecompiled string constant arguments to index (etc).
1632
1633 Note the start pointer is and has always been SvPVX(sv), not
1634 SvPVX(sv) + SvCUR(sv) PVBM was added in 651aa52ea1faa806, and
1635 first used by the compiler in 651aa52ea1faa806. It's used to
1636 get a "complete" dump of the buffer at SvPVX(), not just the
1637 PVBM table. This permits the generated bytecode to "load"
1638 SvPVX in "one" hit. */
f4c36584
NC
1639 p = SvPVX_const(sv);
1640 len = SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0);
1641 } else if (ix) {
3d665704
NC
1642 p = SvPVX(sv);
1643 len = strlen(p);
1644 } else if (SvPOK(sv)) {
a804b0fe
NC
1645 len = SvCUR(sv);
1646 p = SvPVX_const(sv);
1647 utf8 = SvUTF8(sv);
0eaead75
NC
1648#if PERL_VERSION < 10
1649 /* Before 5.10 (well 931b58fb28fa5ca7), PAD_COMPNAME_GEN was stored
1650 in SvCUR(), which meant we had to attempt this special casing
1651 to avoid tripping up over variable names in the pads. */
fdbd1d64 1652 if((SvLEN(sv) && len >= SvLEN(sv))) {
b55685ae 1653 /* It claims to be longer than the space allocated for it -
b7b1e41b 1654 presumably it's a variable name in the pad */
fdbd1d64 1655 len = strlen(p);
b55685ae 1656 }
0eaead75 1657#endif
b326da91
MB
1658 }
1659 else {
1660 /* XXX for backward compatibility, but should fail */
1661 /* croak( "argument is not SvPOK" ); */
a804b0fe 1662 p = NULL;
b326da91 1663 }
a804b0fe 1664 ST(0) = newSVpvn_flags(p, len, SVs_TEMP | utf8);
a8a597b2 1665
fdbacc68 1666MODULE = B PACKAGE = B::PVMG
a8a597b2
MB
1667
1668void
fdbacc68 1669MAGIC(sv)
a8a597b2
MB
1670 B::PVMG sv
1671 MAGIC * mg = NO_INIT
1672 PPCODE:
1673 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
9496d2e5 1674 XPUSHs(make_mg_object(aTHX_ mg));
a8a597b2 1675
b2adfa9b 1676MODULE = B PACKAGE = B::MAGIC
a8a597b2
MB
1677
1678void
b2adfa9b 1679MOREMAGIC(mg)
a8a597b2 1680 B::MAGIC mg
b2adfa9b
NC
1681 ALIAS:
1682 PRIVATE = 1
1683 TYPE = 2
1684 FLAGS = 3
fb6620c6 1685 LENGTH = 4
b2adfa9b
NC
1686 OBJ = 5
1687 PTR = 6
1688 REGEX = 7
1689 precomp = 8
1690 PPCODE:
1691 switch (ix) {
1692 case 0:
1693 XPUSHs(mg->mg_moremagic ? make_mg_object(aTHX_ mg->mg_moremagic)
1694 : &PL_sv_undef);
1695 break;
1696 case 1:
1697 mPUSHu(mg->mg_private);
1698 break;
1699 case 2:
1700 PUSHs(newSVpvn_flags(&(mg->mg_type), 1, SVs_TEMP));
1701 break;
1702 case 3:
1703 mPUSHu(mg->mg_flags);
1704 break;
1705 case 4:
1706 mPUSHi(mg->mg_len);
1707 break;
1708 case 5:
0c74f67f 1709 PUSHs(make_sv_object(aTHX_ mg->mg_obj));
b2adfa9b
NC
1710 break;
1711 case 6:
1712 if (mg->mg_ptr) {
1713 if (mg->mg_len >= 0) {
1714 PUSHs(newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP));
651aa52e 1715 } else if (mg->mg_len == HEf_SVKEY) {
0c74f67f 1716 PUSHs(make_sv_object(aTHX_ (SV*)mg->mg_ptr));
fdbd1d64 1717 } else
b2adfa9b
NC
1718 PUSHs(sv_newmortal());
1719 } else
1720 PUSHs(sv_newmortal());
1721 break;
1722 case 7:
1723 if(mg->mg_type == PERL_MAGIC_qr) {
1724 mPUSHi(PTR2IV(mg->mg_obj));
1725 } else {
1726 croak("REGEX is only meaningful on r-magic");
1727 }
1728 break;
1729 case 8:
1730 if (mg->mg_type == PERL_MAGIC_qr) {
1731 REGEXP *rx = (REGEXP *)mg->mg_obj;
227aaa42
NC
1732 PUSHs(newSVpvn_flags(rx ? RX_PRECOMP(rx) : NULL,
1733 rx ? RX_PRELEN(rx) : 0, SVs_TEMP));
b2adfa9b
NC
1734 } else {
1735 croak( "precomp is only meaningful on r-magic" );
1736 }
1737 break;
1738 }
a8a597b2 1739
a8a597b2
MB
1740MODULE = B PACKAGE = B::GV PREFIX = Gv
1741
1742void
1743GvNAME(gv)
1744 B::GV gv
cbf9c13f
NC
1745 ALIAS:
1746 FILE = 1
435e8dd0 1747 B::HV::NAME = 2
a8a597b2 1748 CODE:
6beb30a6 1749#if PERL_VERSION >= 10
435e8dd0
NC
1750 ST(0) = sv_2mortal(newSVhek(!ix ? GvNAME_HEK(gv)
1751 : (ix == 1 ? GvFILE_HEK(gv)
1752 : HvNAME_HEK((HV *)gv))));
6beb30a6 1753#else
435e8dd0
NC
1754 ST(0) = !ix ? newSVpvn_flags(GvNAME(gv), GvNAMELEN(gv), SVs_TEMP)
1755 : sv_2mortal(newSVpv(ix == 1 ? GvFILE(gv) : HvNAME((HV *)gv), 0))
6beb30a6 1756#endif
a8a597b2 1757
87d7fd28
GS
1758bool
1759is_empty(gv)
1760 B::GV gv
711fbbf0
NC
1761 ALIAS:
1762 isGV_with_GP = 1
87d7fd28 1763 CODE:
711fbbf0 1764 if (ix) {
50786ba8 1765#if PERL_VERSION >= 9
711fbbf0 1766 RETVAL = isGV_with_GP(gv) ? TRUE : FALSE;
50786ba8 1767#else
711fbbf0 1768 RETVAL = TRUE; /* In 5.8 and earlier they all are. */
50786ba8 1769#endif
711fbbf0
NC
1770 } else {
1771 RETVAL = GvGP(gv) == Null(GP*);
1772 }
50786ba8 1773 OUTPUT:
711fbbf0 1774 RETVAL
50786ba8 1775
651aa52e
AE
1776void*
1777GvGP(gv)
1778 B::GV gv
1779
257e0650
NC
1780#define GP_sv_ix SVp | offsetof(struct gp, gp_sv)
1781#define GP_io_ix SVp | offsetof(struct gp, gp_io)
1782#define GP_cv_ix SVp | offsetof(struct gp, gp_cv)
1783#define GP_cvgen_ix U32p | offsetof(struct gp, gp_cvgen)
1784#define GP_refcnt_ix U32p | offsetof(struct gp, gp_refcnt)
1785#define GP_hv_ix SVp | offsetof(struct gp, gp_hv)
1786#define GP_av_ix SVp | offsetof(struct gp, gp_av)
1787#define GP_form_ix SVp | offsetof(struct gp, gp_form)
1788#define GP_egv_ix SVp | offsetof(struct gp, gp_egv)
1789#define GP_line_ix line_tp | offsetof(struct gp, gp_line)
a8a597b2 1790
257e0650
NC
1791void
1792SV(gv)
a8a597b2 1793 B::GV gv
257e0650
NC
1794 ALIAS:
1795 SV = GP_sv_ix
1796 IO = GP_io_ix
1797 CV = GP_cv_ix
1798 CVGEN = GP_cvgen_ix
1799 GvREFCNT = GP_refcnt_ix
1800 HV = GP_hv_ix
1801 AV = GP_av_ix
1802 FORM = GP_form_ix
1803 EGV = GP_egv_ix
1804 LINE = GP_line_ix
1805 PREINIT:
1806 GP *gp;
1807 char *ptr;
1808 SV *ret;
1809 PPCODE:
1810 gp = GvGP(gv);
1811 if (!gp) {
1812 const GV *const gv = CvGV(cv);
46c3f339 1813 Perl_croak(aTHX_ "NULL gp in B::GV::%s", gv ? GvNAME(gv) : "???");
257e0650
NC
1814 }
1815 ptr = (ix & 0xFFFF) + (char *)gp;
1816 switch ((U8)(ix >> 16)) {
1817 case (U8)(SVp >> 16):
0c74f67f 1818 ret = make_sv_object(aTHX_ *((SV **)ptr));
257e0650
NC
1819 break;
1820 case (U8)(U32p >> 16):
1821 ret = sv_2mortal(newSVuv(*((U32*)ptr)));
1822 break;
1823 case (U8)(line_tp >> 16):
1824 ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
1825 break;
c33e8be1
Z
1826 default:
1827 croak("Illegal alias 0x%08x for B::*SV", (unsigned)ix);
257e0650
NC
1828 }
1829 ST(0) = ret;
1830 XSRETURN(1);
a8a597b2 1831
8ae5a962
NC
1832void
1833FILEGV(gv)
a8a597b2 1834 B::GV gv
8ae5a962 1835 PPCODE:
0c74f67f 1836 PUSHs(make_sv_object(aTHX_ (SV *)GvFILEGV(gv)));
a8a597b2 1837
a8a597b2
MB
1838MODULE = B PACKAGE = B::IO PREFIX = Io
1839
04071355
NC
1840#if PERL_VERSION <= 8
1841
a8a597b2
MB
1842short
1843IoSUBPROCESS(io)
1844 B::IO io
1845
04071355
NC
1846#endif
1847
b326da91
MB
1848bool
1849IsSTD(io,name)
1850 B::IO io
5d7488b2 1851 const char* name
b326da91
MB
1852 PREINIT:
1853 PerlIO* handle = 0;
1854 CODE:
1855 if( strEQ( name, "stdin" ) ) {
1856 handle = PerlIO_stdin();
1857 }
1858 else if( strEQ( name, "stdout" ) ) {
1859 handle = PerlIO_stdout();
1860 }
1861 else if( strEQ( name, "stderr" ) ) {
1862 handle = PerlIO_stderr();
1863 }
1864 else {
1865 croak( "Invalid value '%s'", name );
1866 }
1867 RETVAL = handle == IoIFP(io);
1868 OUTPUT:
1869 RETVAL
1870
a8a597b2
MB
1871MODULE = B PACKAGE = B::AV PREFIX = Av
1872
1873SSize_t
1874AvFILL(av)
1875 B::AV av
1876
a8a597b2
MB
1877void
1878AvARRAY(av)
1879 B::AV av
1880 PPCODE:
1881 if (AvFILL(av) >= 0) {
1882 SV **svp = AvARRAY(av);
1883 I32 i;
1884 for (i = 0; i <= AvFILL(av); i++)
0c74f67f 1885 XPUSHs(make_sv_object(aTHX_ svp[i]));
a8a597b2
MB
1886 }
1887
429a5ce7
SM
1888void
1889AvARRAYelt(av, idx)
1890 B::AV av
1891 int idx
1892 PPCODE:
1893 if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
0c74f67f 1894 XPUSHs(make_sv_object(aTHX_ (AvARRAY(av)[idx])));
429a5ce7 1895 else
0c74f67f 1896 XPUSHs(make_sv_object(aTHX_ NULL));
429a5ce7 1897
edcc7c74
NC
1898#if PERL_VERSION < 9
1899
5b02c205
NC
1900#define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1901
1902IV
1903AvOFF(av)
1904 B::AV av
1905
edcc7c74
NC
1906MODULE = B PACKAGE = B::AV
1907
1908U8
1909AvFLAGS(av)
1910 B::AV av
1911
1912#endif
1913
a8a597b2
MB
1914MODULE = B PACKAGE = B::CV PREFIX = Cv
1915
651aa52e
AE
1916U32
1917CvCONST(cv)
1918 B::CV cv
1919
6079961f 1920void
a8a597b2
MB
1921CvSTART(cv)
1922 B::CV cv
a0da4400
NC
1923 ALIAS:
1924 ROOT = 1
6079961f
NC
1925 PPCODE:
1926 PUSHs(make_op_object(aTHX_ CvISXSUB(cv) ? NULL
1927 : ix ? CvROOT(cv) : CvSTART(cv)));
a8a597b2 1928
a8a597b2
MB
1929void
1930CvXSUB(cv)
1931 B::CV cv
96819e59
NC
1932 ALIAS:
1933 XSUBANY = 1
a8a597b2 1934 CODE:
96819e59 1935 ST(0) = ix && CvCONST(cv)
0c74f67f 1936 ? make_sv_object(aTHX_ (SV *)CvXSUBANY(cv).any_ptr)
96819e59
NC
1937 : sv_2mortal(newSViv(CvISXSUB(cv)
1938 ? (ix ? CvXSUBANY(cv).any_iv
1939 : PTR2IV(CvXSUB(cv)))
1940 : 0));
a8a597b2 1941
8ae5a962
NC
1942void
1943const_sv(cv)
de3f1649 1944 B::CV cv
8ae5a962 1945 PPCODE:
0c74f67f 1946 PUSHs(make_sv_object(aTHX_ (SV *)cv_const_sv(cv)));
de3f1649 1947
a8a597b2
MB
1948MODULE = B PACKAGE = B::HV PREFIX = Hv
1949
1950STRLEN
1951HvFILL(hv)
1952 B::HV hv
1953
a8a597b2
MB
1954I32
1955HvRITER(hv)
1956 B::HV hv
1957
edcc7c74
NC
1958#if PERL_VERSION < 9
1959
1960B::PMOP
1961HvPMROOT(hv)
1962 B::HV hv
6079961f 1963 PPCODE:
8ae5a962 1964 PUSHs(make_op_object(aTHX_ HvPMROOT(hv)));
edcc7c74
NC
1965
1966#endif
1967
a8a597b2
MB
1968void
1969HvARRAY(hv)
1970 B::HV hv
1971 PPCODE:
1b95d04f 1972 if (HvUSEDKEYS(hv) > 0) {
a8a597b2
MB
1973 SV *sv;
1974 char *key;
1975 I32 len;
1976 (void)hv_iterinit(hv);
1b95d04f 1977 EXTEND(sp, HvUSEDKEYS(hv) * 2);
8063af02 1978 while ((sv = hv_iternextsv(hv, &key, &len))) {
22f1178f 1979 mPUSHp(key, len);
0c74f67f 1980 PUSHs(make_sv_object(aTHX_ sv));
a8a597b2
MB
1981 }
1982 }
fd9f6265
JJ
1983
1984MODULE = B PACKAGE = B::HE PREFIX = He
1985
8ae5a962 1986void
fd9f6265
JJ
1987HeVAL(he)
1988 B::HE he
b2619626
NC
1989 ALIAS:
1990 SVKEY_force = 1
8ae5a962 1991 PPCODE:
0c74f67f 1992 PUSHs(make_sv_object(aTHX_ ix ? HeSVKEY_force(he) : HeVAL(he)));
fd9f6265
JJ
1993
1994U32
1995HeHASH(he)
1996 B::HE he
1997
fdbacc68 1998MODULE = B PACKAGE = B::RHE
fd9f6265 1999
e412117e
NC
2000#if PERL_VERSION >= 9
2001
fd9f6265 2002SV*
fdbacc68 2003HASH(h)
fd9f6265
JJ
2004 B::RHE h
2005 CODE:
20439bc7 2006 RETVAL = newRV( (SV*)cophh_2hv(h, 0) );
fd9f6265
JJ
2007 OUTPUT:
2008 RETVAL
e412117e
NC
2009
2010#endif