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