This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Bump the version of PerlIO::encoding following 1c2e8ccaafb0b2b1.
[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
NC
1372#if PERL_VERSION >= 10
1373#define PVBM_useful_ix sv_I32p | offsetof(struct xpvgv, xiv_u.xivu_i32)
1374#define PVBM_previous_ix sv_U32p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_previous)
1375#define PVBM_rare_ix sv_U8p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_rare)
1376#else
1377#define PVBM_useful_ix sv_I32p | offsetof(struct xpvbm, xbm_useful)
1378#define PVBM_previous_ix sv_U16p | offsetof(struct xpvbm, xbm_previous)
1379#define PVBM_rare_ix sv_U8p | offsetof(struct xpvbm, xbm_rare)
1380#endif
1381
6782c6e0
NC
1382#define PVLV_targoff_ix sv_U32p | offsetof(struct xpvlv, xlv_targoff)
1383#define PVLV_targlen_ix sv_U32p | offsetof(struct xpvlv, xlv_targlen)
1384#define PVLV_targ_ix sv_SVp | offsetof(struct xpvlv, xlv_targ)
1385#define PVLV_type_ix sv_char_p | offsetof(struct xpvlv, xlv_type)
1386
f1f19364
NC
1387#if PERL_VERSION >= 10
1388#define PVGV_stash_ix sv_SVp | offsetof(struct xpvgv, xnv_u.xgv_stash)
1389#define PVGV_flags_ix sv_STRLENp | offsetof(struct xpvgv, xpv_cur)
55440d31 1390#define PVIO_lines_ix sv_IVp | offsetof(struct xpvio, xiv_iv)
f1f19364
NC
1391#else
1392#define PVGV_stash_ix sv_SVp | offsetof(struct xpvgv, xgv_stash)
1393#define PVGV_flags_ix sv_U8p | offsetof(struct xpvgv, xgv_flags)
55440d31 1394#define PVIO_lines_ix sv_IVp | offsetof(struct xpvio, xio_lines)
f1f19364
NC
1395#endif
1396
55440d31
NC
1397#define PVIO_page_ix sv_IVp | offsetof(struct xpvio, xio_page)
1398#define PVIO_page_len_ix sv_IVp | offsetof(struct xpvio, xio_page_len)
1399#define PVIO_lines_left_ix sv_IVp | offsetof(struct xpvio, xio_lines_left)
1400#define PVIO_top_name_ix sv_char_pp | offsetof(struct xpvio, xio_top_name)
1401#define PVIO_top_gv_ix sv_SVp | offsetof(struct xpvio, xio_top_gv)
1402#define PVIO_fmt_name_ix sv_char_pp | offsetof(struct xpvio, xio_fmt_name)
1403#define PVIO_fmt_gv_ix sv_SVp | offsetof(struct xpvio, xio_fmt_gv)
1404#define PVIO_bottom_name_ix sv_char_pp | offsetof(struct xpvio, xio_bottom_name)
1405#define PVIO_bottom_gv_ix sv_SVp | offsetof(struct xpvio, xio_bottom_gv)
1406#define PVIO_type_ix sv_char_p | offsetof(struct xpvio, xio_type)
1407#define PVIO_flags_ix sv_U8p | offsetof(struct xpvio, xio_flags)
1408
3da43c35
NC
1409#define PVAV_max_ix sv_SSize_tp | offsetof(struct xpvav, xav_max)
1410
1411#define PVFM_lines_ix sv_IVp | offsetof(struct xpvfm, xfm_lines)
1412
ffc5d9fc
NC
1413#define PVCV_stash_ix sv_SVp | offsetof(struct xpvcv, xcv_stash)
1414#define PVCV_gv_ix sv_SVp | offsetof(struct xpvcv, xcv_gv)
1415#define PVCV_file_ix sv_char_pp | offsetof(struct xpvcv, xcv_file)
1416#define PVCV_depth_ix sv_I32p | offsetof(struct xpvcv, xcv_depth)
1417#define PVCV_padlist_ix sv_SVp | offsetof(struct xpvcv, xcv_padlist)
1418#define PVCV_outside_ix sv_SVp | offsetof(struct xpvcv, xcv_outside)
1419#define PVCV_outside_seq_ix sv_U32p | offsetof(struct xpvcv, xcv_outside_seq)
1420#define PVCV_flags_ix sv_U16p | offsetof(struct xpvcv, xcv_flags)
1421
d65a2b0a
NC
1422#define PVHV_max_ix sv_STRLENp | offsetof(struct xpvhv, xhv_max)
1423
1424#if PERL_VERSION > 12
1425#define PVHV_keys_ix sv_STRLENp | offsetof(struct xpvhv, xhv_keys)
1426#else
1427#define PVHV_keys_ix sv_IVp | offsetof(struct xpvhv, xhv_keys)
1428#endif
1429
e4da9d6a
NC
1430# The type checking code in B has always been identical for all SV types,
1431# irrespective of whether the action is actually defined on that SV.
1432# We should fix this
1433void
1434IVX(sv)
1435 B::SV sv
1436 ALIAS:
1437 B::IV::IVX = IV_ivx_ix
1438 B::IV::UVX = IV_uvx_ix
1439 B::NV::NVX = NV_nvx_ix
1440 B::NV::COP_SEQ_RANGE_LOW = NV_cop_seq_range_low_ix
1441 B::NV::COP_SEQ_RANGE_HIGH = NV_cop_seq_range_high_ix
1442 B::NV::PARENT_PAD_INDEX = NV_parent_pad_index_ix
1443 B::NV::PARENT_FAKELEX_FLAGS = NV_parent_fakelex_flags_ix
6782c6e0
NC
1444 B::PV::CUR = PV_cur_ix
1445 B::PV::LEN = PV_len_ix
1446 B::PVMG::SvSTASH = PVMG_stash_ix
1447 B::PVLV::TARGOFF = PVLV_targoff_ix
1448 B::PVLV::TARGLEN = PVLV_targlen_ix
1449 B::PVLV::TARG = PVLV_targ_ix
1450 B::PVLV::TYPE = PVLV_type_ix
f1f19364
NC
1451 B::GV::STASH = PVGV_stash_ix
1452 B::GV::GvFLAGS = PVGV_flags_ix
91a71e08
NC
1453 B::BM::USEFUL = PVBM_useful_ix
1454 B::BM::PREVIOUS = PVBM_previous_ix
1455 B::BM::RARE = PVBM_rare_ix
55440d31
NC
1456 B::IO::LINES = PVIO_lines_ix
1457 B::IO::PAGE = PVIO_page_ix
1458 B::IO::PAGE_LEN = PVIO_page_len_ix
1459 B::IO::LINES_LEFT = PVIO_lines_left_ix
1460 B::IO::TOP_NAME = PVIO_top_name_ix
1461 B::IO::TOP_GV = PVIO_top_gv_ix
1462 B::IO::FMT_NAME = PVIO_fmt_name_ix
1463 B::IO::FMT_GV = PVIO_fmt_gv_ix
1464 B::IO::BOTTOM_NAME = PVIO_bottom_name_ix
1465 B::IO::BOTTOM_GV = PVIO_bottom_gv_ix
1466 B::IO::IoTYPE = PVIO_type_ix
1467 B::IO::IoFLAGS = PVIO_flags_ix
3da43c35
NC
1468 B::AV::MAX = PVAV_max_ix
1469 B::FM::LINES = PVFM_lines_ix
ffc5d9fc
NC
1470 B::CV::STASH = PVCV_stash_ix
1471 B::CV::GV = PVCV_gv_ix
1472 B::CV::FILE = PVCV_file_ix
1473 B::CV::DEPTH = PVCV_depth_ix
1474 B::CV::PADLIST = PVCV_padlist_ix
1475 B::CV::OUTSIDE = PVCV_outside_ix
1476 B::CV::OUTSIDE_SEQ = PVCV_outside_seq_ix
1477 B::CV::CvFLAGS = PVCV_flags_ix
d65a2b0a
NC
1478 B::HV::MAX = PVHV_max_ix
1479 B::HV::KEYS = PVHV_keys_ix
e4da9d6a
NC
1480 PREINIT:
1481 char *ptr;
1482 SV *ret;
1483 PPCODE:
1484 ptr = (ix & 0xFFFF) + (char *)SvANY(sv);
1485 switch ((U8)(ix >> 16)) {
1486 case (U8)(sv_SVp >> 16):
0c74f67f 1487 ret = make_sv_object(aTHX_ *((SV **)ptr));
e4da9d6a
NC
1488 break;
1489 case (U8)(sv_IVp >> 16):
1490 ret = sv_2mortal(newSViv(*((IV *)ptr)));
1491 break;
1492 case (U8)(sv_UVp >> 16):
1493 ret = sv_2mortal(newSVuv(*((UV *)ptr)));
1494 break;
6782c6e0
NC
1495 case (U8)(sv_STRLENp >> 16):
1496 ret = sv_2mortal(newSVuv(*((STRLEN *)ptr)));
1497 break;
e4da9d6a
NC
1498 case (U8)(sv_U32p >> 16):
1499 ret = sv_2mortal(newSVuv(*((U32 *)ptr)));
1500 break;
1501 case (U8)(sv_U8p >> 16):
1502 ret = sv_2mortal(newSVuv(*((U8 *)ptr)));
1503 break;
1504 case (U8)(sv_char_pp >> 16):
1505 ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
1506 break;
1507 case (U8)(sv_NVp >> 16):
1508 ret = sv_2mortal(newSVnv(*((NV *)ptr)));
1509 break;
6782c6e0
NC
1510 case (U8)(sv_char_p >> 16):
1511 ret = newSVpvn_flags((char *)ptr, 1, SVs_TEMP);
1512 break;
3da43c35
NC
1513 case (U8)(sv_SSize_tp >> 16):
1514 ret = sv_2mortal(newSViv(*((SSize_t *)ptr)));
1515 break;
ffc5d9fc
NC
1516 case (U8)(sv_I32p >> 16):
1517 ret = sv_2mortal(newSVuv(*((I32 *)ptr)));
1518 break;
1519 case (U8)(sv_U16p >> 16):
1520 ret = sv_2mortal(newSVuv(*((U16 *)ptr)));
1521 break;
c33e8be1
Z
1522 default:
1523 croak("Illegal alias 0x%08x for B::*IVX", (unsigned)ix);
e4da9d6a
NC
1524 }
1525 ST(0) = ret;
1526 XSRETURN(1);
a8a597b2 1527
a8a597b2
MB
1528void
1529packiv(sv)
1530 B::IV sv
6829f5e2
NC
1531 ALIAS:
1532 needs64bits = 1
a8a597b2 1533 CODE:
6829f5e2
NC
1534 if (ix) {
1535 ST(0) = boolSV((I32)SvIVX(sv) != SvIVX(sv));
1536 } else if (sizeof(IV) == 8) {
a8a597b2 1537 U32 wp[2];
5d7488b2 1538 const IV iv = SvIVX(sv);
a8a597b2
MB
1539 /*
1540 * The following way of spelling 32 is to stop compilers on
1541 * 32-bit architectures from moaning about the shift count
1542 * being >= the width of the type. Such architectures don't
1543 * reach this code anyway (unless sizeof(IV) > 8 but then
1544 * everything else breaks too so I'm not fussed at the moment).
1545 */
42718184
RB
1546#ifdef UV_IS_QUAD
1547 wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1548#else
1549 wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1550#endif
a8a597b2 1551 wp[1] = htonl(iv & 0xffffffff);
d3d34884 1552 ST(0) = newSVpvn_flags((char *)wp, 8, SVs_TEMP);
a8a597b2
MB
1553 } else {
1554 U32 w = htonl((U32)SvIVX(sv));
d3d34884 1555 ST(0) = newSVpvn_flags((char *)&w, 4, SVs_TEMP);
a8a597b2
MB
1556 }
1557
1558MODULE = B PACKAGE = B::NV PREFIX = Sv
1559
76ef7183 1560NV
a8a597b2
MB
1561SvNV(sv)
1562 B::NV sv
1563
4df7f6af
NC
1564#if PERL_VERSION < 11
1565
a8a597b2
MB
1566MODULE = B PACKAGE = B::RV PREFIX = Sv
1567
8ae5a962 1568void
a8a597b2
MB
1569SvRV(sv)
1570 B::RV sv
8ae5a962 1571 PPCODE:
0c74f67f 1572 PUSHs(make_sv_object(aTHX_ SvRV(sv)));
a8a597b2 1573
89c6bc13
NC
1574#else
1575
1576MODULE = B PACKAGE = B::REGEXP
1577
154b8842 1578void
81e413dd 1579REGEX(sv)
89c6bc13 1580 B::REGEXP sv
81e413dd
NC
1581 ALIAS:
1582 precomp = 1
154b8842 1583 PPCODE:
81e413dd
NC
1584 if (ix) {
1585 PUSHs(newSVpvn_flags(RX_PRECOMP(sv), RX_PRELEN(sv), SVs_TEMP));
1586 } else {
1587 dXSTARG;
1588 /* FIXME - can we code this method more efficiently? */
1589 PUSHi(PTR2IV(sv));
1590 }
89c6bc13 1591
4df7f6af
NC
1592#endif
1593
fdbacc68 1594MODULE = B PACKAGE = B::PV
a8a597b2 1595
8ae5a962 1596void
fdbacc68 1597RV(sv)
b326da91 1598 B::PV sv
8ae5a962
NC
1599 PPCODE:
1600 if (!SvROK(sv))
b326da91 1601 croak( "argument is not SvROK" );
0c74f67f 1602 PUSHs(make_sv_object(aTHX_ SvRV(sv)));
b326da91 1603
a8a597b2 1604void
fdbacc68 1605PV(sv)
a8a597b2 1606 B::PV sv
3d665704
NC
1607 ALIAS:
1608 PVX = 1
f4c36584 1609 PVBM = 2
84fea184 1610 B::BM::TABLE = 3
a804b0fe
NC
1611 PREINIT:
1612 const char *p;
1613 STRLEN len = 0;
1614 U32 utf8 = 0;
a8a597b2 1615 CODE:
84fea184
NC
1616 if (ix == 3) {
1617 p = SvPV(sv, len);
1618 /* Boyer-Moore table is just after string and its safety-margin \0 */
1619 p += len + PERL_FBM_TABLE_OFFSET;
1620 len = 256;
1621 } else if (ix == 2) {
f4c36584
NC
1622 /* This used to read 257. I think that that was buggy - should have
1623 been 258. (The "\0", the flags byte, and 256 for the table. Not
1624 that anything anywhere calls this method. NWC. */
1625 /* Also, the start pointer has always been SvPVX(sv). Surely it
1626 should be SvPVX(sv) + SvCUR(sv)? The code has faithfully been
1627 refactored with this behaviour, since PVBM was added in
1628 651aa52ea1faa806. */
1629 p = SvPVX_const(sv);
1630 len = SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0);
1631 } else if (ix) {
3d665704
NC
1632 p = SvPVX(sv);
1633 len = strlen(p);
1634 } else if (SvPOK(sv)) {
a804b0fe
NC
1635 len = SvCUR(sv);
1636 p = SvPVX_const(sv);
1637 utf8 = SvUTF8(sv);
0eaead75
NC
1638#if PERL_VERSION < 10
1639 /* Before 5.10 (well 931b58fb28fa5ca7), PAD_COMPNAME_GEN was stored
1640 in SvCUR(), which meant we had to attempt this special casing
1641 to avoid tripping up over variable names in the pads. */
fdbd1d64 1642 if((SvLEN(sv) && len >= SvLEN(sv))) {
b55685ae 1643 /* It claims to be longer than the space allocated for it -
b7b1e41b 1644 presumably it's a variable name in the pad */
fdbd1d64 1645 len = strlen(p);
b55685ae 1646 }
0eaead75 1647#endif
b326da91
MB
1648 }
1649 else {
1650 /* XXX for backward compatibility, but should fail */
1651 /* croak( "argument is not SvPOK" ); */
a804b0fe 1652 p = NULL;
b326da91 1653 }
a804b0fe 1654 ST(0) = newSVpvn_flags(p, len, SVs_TEMP | utf8);
a8a597b2 1655
fdbacc68 1656MODULE = B PACKAGE = B::PVMG
a8a597b2
MB
1657
1658void
fdbacc68 1659MAGIC(sv)
a8a597b2
MB
1660 B::PVMG sv
1661 MAGIC * mg = NO_INIT
1662 PPCODE:
1663 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
9496d2e5 1664 XPUSHs(make_mg_object(aTHX_ mg));
a8a597b2 1665
b2adfa9b 1666MODULE = B PACKAGE = B::MAGIC
a8a597b2
MB
1667
1668void
b2adfa9b 1669MOREMAGIC(mg)
a8a597b2 1670 B::MAGIC mg
b2adfa9b
NC
1671 ALIAS:
1672 PRIVATE = 1
1673 TYPE = 2
1674 FLAGS = 3
fb6620c6 1675 LENGTH = 4
b2adfa9b
NC
1676 OBJ = 5
1677 PTR = 6
1678 REGEX = 7
1679 precomp = 8
1680 PPCODE:
1681 switch (ix) {
1682 case 0:
1683 XPUSHs(mg->mg_moremagic ? make_mg_object(aTHX_ mg->mg_moremagic)
1684 : &PL_sv_undef);
1685 break;
1686 case 1:
1687 mPUSHu(mg->mg_private);
1688 break;
1689 case 2:
1690 PUSHs(newSVpvn_flags(&(mg->mg_type), 1, SVs_TEMP));
1691 break;
1692 case 3:
1693 mPUSHu(mg->mg_flags);
1694 break;
1695 case 4:
1696 mPUSHi(mg->mg_len);
1697 break;
1698 case 5:
0c74f67f 1699 PUSHs(make_sv_object(aTHX_ mg->mg_obj));
b2adfa9b
NC
1700 break;
1701 case 6:
1702 if (mg->mg_ptr) {
1703 if (mg->mg_len >= 0) {
1704 PUSHs(newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP));
651aa52e 1705 } else if (mg->mg_len == HEf_SVKEY) {
0c74f67f 1706 PUSHs(make_sv_object(aTHX_ (SV*)mg->mg_ptr));
fdbd1d64 1707 } else
b2adfa9b
NC
1708 PUSHs(sv_newmortal());
1709 } else
1710 PUSHs(sv_newmortal());
1711 break;
1712 case 7:
1713 if(mg->mg_type == PERL_MAGIC_qr) {
1714 mPUSHi(PTR2IV(mg->mg_obj));
1715 } else {
1716 croak("REGEX is only meaningful on r-magic");
1717 }
1718 break;
1719 case 8:
1720 if (mg->mg_type == PERL_MAGIC_qr) {
1721 REGEXP *rx = (REGEXP *)mg->mg_obj;
227aaa42
NC
1722 PUSHs(newSVpvn_flags(rx ? RX_PRECOMP(rx) : NULL,
1723 rx ? RX_PRELEN(rx) : 0, SVs_TEMP));
b2adfa9b
NC
1724 } else {
1725 croak( "precomp is only meaningful on r-magic" );
1726 }
1727 break;
1728 }
a8a597b2 1729
a8a597b2
MB
1730MODULE = B PACKAGE = B::GV PREFIX = Gv
1731
1732void
1733GvNAME(gv)
1734 B::GV gv
cbf9c13f
NC
1735 ALIAS:
1736 FILE = 1
435e8dd0 1737 B::HV::NAME = 2
a8a597b2 1738 CODE:
6beb30a6 1739#if PERL_VERSION >= 10
435e8dd0
NC
1740 ST(0) = sv_2mortal(newSVhek(!ix ? GvNAME_HEK(gv)
1741 : (ix == 1 ? GvFILE_HEK(gv)
1742 : HvNAME_HEK((HV *)gv))));
6beb30a6 1743#else
435e8dd0
NC
1744 ST(0) = !ix ? newSVpvn_flags(GvNAME(gv), GvNAMELEN(gv), SVs_TEMP)
1745 : sv_2mortal(newSVpv(ix == 1 ? GvFILE(gv) : HvNAME((HV *)gv), 0))
6beb30a6 1746#endif
a8a597b2 1747
87d7fd28
GS
1748bool
1749is_empty(gv)
1750 B::GV gv
711fbbf0
NC
1751 ALIAS:
1752 isGV_with_GP = 1
87d7fd28 1753 CODE:
711fbbf0 1754 if (ix) {
50786ba8 1755#if PERL_VERSION >= 9
711fbbf0 1756 RETVAL = isGV_with_GP(gv) ? TRUE : FALSE;
50786ba8 1757#else
711fbbf0 1758 RETVAL = TRUE; /* In 5.8 and earlier they all are. */
50786ba8 1759#endif
711fbbf0
NC
1760 } else {
1761 RETVAL = GvGP(gv) == Null(GP*);
1762 }
50786ba8 1763 OUTPUT:
711fbbf0 1764 RETVAL
50786ba8 1765
651aa52e
AE
1766void*
1767GvGP(gv)
1768 B::GV gv
1769
257e0650
NC
1770#define GP_sv_ix SVp | offsetof(struct gp, gp_sv)
1771#define GP_io_ix SVp | offsetof(struct gp, gp_io)
1772#define GP_cv_ix SVp | offsetof(struct gp, gp_cv)
1773#define GP_cvgen_ix U32p | offsetof(struct gp, gp_cvgen)
1774#define GP_refcnt_ix U32p | offsetof(struct gp, gp_refcnt)
1775#define GP_hv_ix SVp | offsetof(struct gp, gp_hv)
1776#define GP_av_ix SVp | offsetof(struct gp, gp_av)
1777#define GP_form_ix SVp | offsetof(struct gp, gp_form)
1778#define GP_egv_ix SVp | offsetof(struct gp, gp_egv)
1779#define GP_line_ix line_tp | offsetof(struct gp, gp_line)
a8a597b2 1780
257e0650
NC
1781void
1782SV(gv)
a8a597b2 1783 B::GV gv
257e0650
NC
1784 ALIAS:
1785 SV = GP_sv_ix
1786 IO = GP_io_ix
1787 CV = GP_cv_ix
1788 CVGEN = GP_cvgen_ix
1789 GvREFCNT = GP_refcnt_ix
1790 HV = GP_hv_ix
1791 AV = GP_av_ix
1792 FORM = GP_form_ix
1793 EGV = GP_egv_ix
1794 LINE = GP_line_ix
1795 PREINIT:
1796 GP *gp;
1797 char *ptr;
1798 SV *ret;
1799 PPCODE:
1800 gp = GvGP(gv);
1801 if (!gp) {
1802 const GV *const gv = CvGV(cv);
46c3f339 1803 Perl_croak(aTHX_ "NULL gp in B::GV::%s", gv ? GvNAME(gv) : "???");
257e0650
NC
1804 }
1805 ptr = (ix & 0xFFFF) + (char *)gp;
1806 switch ((U8)(ix >> 16)) {
1807 case (U8)(SVp >> 16):
0c74f67f 1808 ret = make_sv_object(aTHX_ *((SV **)ptr));
257e0650
NC
1809 break;
1810 case (U8)(U32p >> 16):
1811 ret = sv_2mortal(newSVuv(*((U32*)ptr)));
1812 break;
1813 case (U8)(line_tp >> 16):
1814 ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
1815 break;
c33e8be1
Z
1816 default:
1817 croak("Illegal alias 0x%08x for B::*SV", (unsigned)ix);
257e0650
NC
1818 }
1819 ST(0) = ret;
1820 XSRETURN(1);
a8a597b2 1821
8ae5a962
NC
1822void
1823FILEGV(gv)
a8a597b2 1824 B::GV gv
8ae5a962 1825 PPCODE:
0c74f67f 1826 PUSHs(make_sv_object(aTHX_ (SV *)GvFILEGV(gv)));
a8a597b2 1827
a8a597b2
MB
1828MODULE = B PACKAGE = B::IO PREFIX = Io
1829
04071355
NC
1830#if PERL_VERSION <= 8
1831
a8a597b2
MB
1832short
1833IoSUBPROCESS(io)
1834 B::IO io
1835
04071355
NC
1836#endif
1837
b326da91
MB
1838bool
1839IsSTD(io,name)
1840 B::IO io
5d7488b2 1841 const char* name
b326da91
MB
1842 PREINIT:
1843 PerlIO* handle = 0;
1844 CODE:
1845 if( strEQ( name, "stdin" ) ) {
1846 handle = PerlIO_stdin();
1847 }
1848 else if( strEQ( name, "stdout" ) ) {
1849 handle = PerlIO_stdout();
1850 }
1851 else if( strEQ( name, "stderr" ) ) {
1852 handle = PerlIO_stderr();
1853 }
1854 else {
1855 croak( "Invalid value '%s'", name );
1856 }
1857 RETVAL = handle == IoIFP(io);
1858 OUTPUT:
1859 RETVAL
1860
a8a597b2
MB
1861MODULE = B PACKAGE = B::AV PREFIX = Av
1862
1863SSize_t
1864AvFILL(av)
1865 B::AV av
1866
a8a597b2
MB
1867void
1868AvARRAY(av)
1869 B::AV av
1870 PPCODE:
1871 if (AvFILL(av) >= 0) {
1872 SV **svp = AvARRAY(av);
1873 I32 i;
1874 for (i = 0; i <= AvFILL(av); i++)
0c74f67f 1875 XPUSHs(make_sv_object(aTHX_ svp[i]));
a8a597b2
MB
1876 }
1877
429a5ce7
SM
1878void
1879AvARRAYelt(av, idx)
1880 B::AV av
1881 int idx
1882 PPCODE:
1883 if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
0c74f67f 1884 XPUSHs(make_sv_object(aTHX_ (AvARRAY(av)[idx])));
429a5ce7 1885 else
0c74f67f 1886 XPUSHs(make_sv_object(aTHX_ NULL));
429a5ce7 1887
edcc7c74
NC
1888#if PERL_VERSION < 9
1889
5b02c205
NC
1890#define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1891
1892IV
1893AvOFF(av)
1894 B::AV av
1895
edcc7c74
NC
1896MODULE = B PACKAGE = B::AV
1897
1898U8
1899AvFLAGS(av)
1900 B::AV av
1901
1902#endif
1903
a8a597b2
MB
1904MODULE = B PACKAGE = B::CV PREFIX = Cv
1905
651aa52e
AE
1906U32
1907CvCONST(cv)
1908 B::CV cv
1909
6079961f 1910void
a8a597b2
MB
1911CvSTART(cv)
1912 B::CV cv
a0da4400
NC
1913 ALIAS:
1914 ROOT = 1
6079961f
NC
1915 PPCODE:
1916 PUSHs(make_op_object(aTHX_ CvISXSUB(cv) ? NULL
1917 : ix ? CvROOT(cv) : CvSTART(cv)));
a8a597b2 1918
a8a597b2
MB
1919void
1920CvXSUB(cv)
1921 B::CV cv
96819e59
NC
1922 ALIAS:
1923 XSUBANY = 1
a8a597b2 1924 CODE:
96819e59 1925 ST(0) = ix && CvCONST(cv)
0c74f67f 1926 ? make_sv_object(aTHX_ (SV *)CvXSUBANY(cv).any_ptr)
96819e59
NC
1927 : sv_2mortal(newSViv(CvISXSUB(cv)
1928 ? (ix ? CvXSUBANY(cv).any_iv
1929 : PTR2IV(CvXSUB(cv)))
1930 : 0));
a8a597b2 1931
8ae5a962
NC
1932void
1933const_sv(cv)
de3f1649 1934 B::CV cv
8ae5a962 1935 PPCODE:
0c74f67f 1936 PUSHs(make_sv_object(aTHX_ (SV *)cv_const_sv(cv)));
de3f1649 1937
a8a597b2
MB
1938MODULE = B PACKAGE = B::HV PREFIX = Hv
1939
1940STRLEN
1941HvFILL(hv)
1942 B::HV hv
1943
a8a597b2
MB
1944I32
1945HvRITER(hv)
1946 B::HV hv
1947
edcc7c74
NC
1948#if PERL_VERSION < 9
1949
1950B::PMOP
1951HvPMROOT(hv)
1952 B::HV hv
6079961f 1953 PPCODE:
8ae5a962 1954 PUSHs(make_op_object(aTHX_ HvPMROOT(hv)));
edcc7c74
NC
1955
1956#endif
1957
a8a597b2
MB
1958void
1959HvARRAY(hv)
1960 B::HV hv
1961 PPCODE:
1b95d04f 1962 if (HvUSEDKEYS(hv) > 0) {
a8a597b2
MB
1963 SV *sv;
1964 char *key;
1965 I32 len;
1966 (void)hv_iterinit(hv);
1b95d04f 1967 EXTEND(sp, HvUSEDKEYS(hv) * 2);
8063af02 1968 while ((sv = hv_iternextsv(hv, &key, &len))) {
22f1178f 1969 mPUSHp(key, len);
0c74f67f 1970 PUSHs(make_sv_object(aTHX_ sv));
a8a597b2
MB
1971 }
1972 }
fd9f6265
JJ
1973
1974MODULE = B PACKAGE = B::HE PREFIX = He
1975
8ae5a962 1976void
fd9f6265
JJ
1977HeVAL(he)
1978 B::HE he
b2619626
NC
1979 ALIAS:
1980 SVKEY_force = 1
8ae5a962 1981 PPCODE:
0c74f67f 1982 PUSHs(make_sv_object(aTHX_ ix ? HeSVKEY_force(he) : HeVAL(he)));
fd9f6265
JJ
1983
1984U32
1985HeHASH(he)
1986 B::HE he
1987
fdbacc68 1988MODULE = B PACKAGE = B::RHE
fd9f6265 1989
e412117e
NC
1990#if PERL_VERSION >= 9
1991
fd9f6265 1992SV*
fdbacc68 1993HASH(h)
fd9f6265
JJ
1994 B::RHE h
1995 CODE:
20439bc7 1996 RETVAL = newRV( (SV*)cophh_2hv(h, 0) );
fd9f6265
JJ
1997 OUTPUT:
1998 RETVAL
e412117e
NC
1999
2000#endif