This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
In B.xs refactor cc_opclassname() to make_op_object().
[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
694B::AV
695comppadlist()
696 CODE:
697 RETVAL = PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv);
698 OUTPUT:
699 RETVAL
700
a4aabc83
NC
701B::SV
702sv_undef()
703 ALIAS:
704 sv_no = 1
705 sv_yes = 2
706 CODE:
707 RETVAL = ix > 1 ? &PL_sv_yes : ix < 1 ? &PL_sv_undef : &PL_sv_no;
708 OUTPUT:
709 RETVAL
710
6079961f 711void
e97701b4
NC
712main_root()
713 ALIAS:
714 main_start = 1
6079961f
NC
715 PPCODE:
716 PUSHs(make_op_object(aTHX_ ix ? PL_main_start : PL_main_root));
e97701b4 717
2edf0c1d
NC
718UV
719sub_generation()
720 ALIAS:
721 dowarn = 1
722 CODE:
723 RETVAL = ix ? PL_dowarn : PL_sub_generation;
724 OUTPUT:
725 RETVAL
726
a8a597b2 727void
20f7624e
NC
728walkoptree(op, method)
729 B::OP op
5d7488b2 730 const char * method
cea2e8a9 731 CODE:
20f7624e 732 (void) walkoptree(aTHX_ op, method, &PL_sv_undef);
a8a597b2
MB
733
734int
735walkoptree_debug(...)
736 CODE:
89ca4ac7 737 dMY_CXT;
a8a597b2
MB
738 RETVAL = walkoptree_debug;
739 if (items > 0 && SvTRUE(ST(1)))
740 walkoptree_debug = 1;
741 OUTPUT:
742 RETVAL
743
56431972 744#define address(sv) PTR2IV(sv)
a8a597b2
MB
745
746IV
747address(sv)
748 SV * sv
749
750B::SV
751svref_2object(sv)
752 SV * sv
753 CODE:
754 if (!SvROK(sv))
755 croak("argument is not a reference");
756 RETVAL = (SV*)SvRV(sv);
757 OUTPUT:
0cc1d052
NIS
758 RETVAL
759
760void
761opnumber(name)
5d7488b2 762const char * name
0cc1d052
NIS
763CODE:
764{
765 int i;
766 IV result = -1;
767 ST(0) = sv_newmortal();
768 if (strncmp(name,"pp_",3) == 0)
769 name += 3;
770 for (i = 0; i < PL_maxo; i++)
771 {
772 if (strcmp(name, PL_op_name[i]) == 0)
773 {
774 result = i;
775 break;
776 }
777 }
778 sv_setiv(ST(0),result);
779}
a8a597b2
MB
780
781void
782ppname(opnum)
783 int opnum
784 CODE:
785 ST(0) = sv_newmortal();
3280af22 786 if (opnum >= 0 && opnum < PL_maxo) {
6beb30a6 787 sv_setpvs(ST(0), "pp_");
22c35a8c 788 sv_catpv(ST(0), PL_op_name[opnum]);
a8a597b2
MB
789 }
790
791void
792hash(sv)
793 SV * sv
794 CODE:
a8a597b2
MB
795 STRLEN len;
796 U32 hash = 0;
8c5b7c71 797 const char *s = SvPVbyte(sv, len);
c32d3395 798 PERL_HASH(hash, s, len);
90b16320 799 ST(0) = sv_2mortal(Perl_newSVpvf(aTHX_ "0x%"UVxf, (UV)hash));
a8a597b2
MB
800
801#define cast_I32(foo) (I32)foo
802IV
803cast_I32(i)
804 IV i
805
806void
807minus_c()
651233d2
NC
808 ALIAS:
809 save_BEGINs = 1
a8a597b2 810 CODE:
651233d2
NC
811 if (ix)
812 PL_savebegin = TRUE;
813 else
814 PL_minus_c = TRUE;
059a8bb7 815
a8a597b2
MB
816SV *
817cstring(sv)
818 SV * sv
84556172
NC
819 ALIAS:
820 perlstring = 1
9e380ad4 821 cchar = 2
09e97b95 822 PPCODE:
9e380ad4 823 PUSHs(ix == 2 ? cchar(aTHX_ sv) : cstring(aTHX_ sv, ix));
a8a597b2
MB
824
825void
826threadsv_names()
827 PPCODE:
f5ba1307
NC
828#if PERL_VERSION <= 8
829# ifdef USE_5005THREADS
830 int i;
5d7488b2 831 const STRLEN len = strlen(PL_threadsv_names);
f5ba1307
NC
832
833 EXTEND(sp, len);
834 for (i = 0; i < len; i++)
d3d34884 835 PUSHs(newSVpvn_flags(&PL_threadsv_names[i], 1, SVs_TEMP));
f5ba1307
NC
836# endif
837#endif
a8a597b2 838
257e0650
NC
839#define SVp 0x00000
840#define U32p 0x10000
841#define line_tp 0x20000
842#define OPp 0x30000
843#define PADOFFSETp 0x40000
844#define U8p 0x50000
39e120c1 845#define IVp 0x60000
a9ed1a44 846#define char_pp 0x70000
086f9b42
NC
847
848#define OP_next_ix OPp | offsetof(struct op, op_next)
849#define OP_sibling_ix OPp | offsetof(struct op, op_sibling)
850#define UNOP_first_ix OPp | offsetof(struct unop, op_first)
851#define BINOP_last_ix OPp | offsetof(struct binop, op_last)
852#define LOGOP_other_ix OPp | offsetof(struct logop, op_other)
9b1961be 853#if PERL_VERSION >= 9
086f9b42
NC
854# define PMOP_pmreplstart_ix \
855 OPp | offsetof(struct pmop, op_pmstashstartu.op_pmreplstart)
9b1961be 856#else
086f9b42 857# define PMOP_pmreplstart_ix OPp | offsetof(struct pmop, op_pmreplstart)
9b1961be 858#endif
086f9b42
NC
859#define LOOP_redoop_ix OPp | offsetof(struct loop, op_redoop)
860#define LOOP_nextop_ix OPp | offsetof(struct loop, op_nextop)
861#define LOOP_lastop_ix OPp | offsetof(struct loop, op_lastop)
862
863#define OP_targ_ix PADOFFSETp | offsetof(struct op, op_targ)
864#define OP_flags_ix U8p | offsetof(struct op, op_flags)
865#define OP_private_ix U8p | offsetof(struct op, op_private)
9b1961be 866
a78b89ef
NC
867#define PMOP_pmflags_ix U32p | offsetof(struct pmop, op_pmflags)
868
657e3fc2
NC
869#ifdef USE_ITHREADS
870#define PMOP_pmoffset_ix IVp | offsetof(struct pmop, op_pmoffset)
871#endif
872
ba7298e3
NC
873# Yes, B::SV::sv and B::SV::gv really do end up generating identical code.
874#define SVOP_sv_ix SVp | offsetof(struct svop, op_sv)
875#define SVOP_gv_ix SVp | offsetof(struct svop, op_sv)
876
9488fb36
NC
877#define PADOP_padix_ix PADOFFSETp | offsetof(struct padop, op_padix)
878
39e120c1
NC
879#define COP_seq_ix U32p | offsetof(struct cop, cop_seq)
880#define COP_line_ix line_tp | offsetof(struct cop, cop_line)
881#if PERL_VERSION >= 9
882#define COP_hints_ix U32p | offsetof(struct cop, cop_hints)
883#else
884#define COP_hints_ix U8p | offsetof(struct cop, op_private)
885#endif
886
a9ed1a44
NC
887#ifdef USE_ITHREADS
888#define COP_stashpv_ix char_pp | offsetof(struct cop, cop_stashpv)
889#define COP_file_ix char_pp | offsetof(struct cop, cop_file)
890#else
891#define COP_stash_ix SVp | offsetof(struct cop, cop_stash)
892#define COP_filegv_ix SVp | offsetof(struct cop, cop_filegv)
893#endif
894
fdbacc68 895MODULE = B PACKAGE = B::OP
a8a597b2 896
651aa52e 897size_t
fdbacc68 898size(o)
651aa52e
AE
899 B::OP o
900 CODE:
901 RETVAL = opsizes[cc_opclass(aTHX_ o)];
902 OUTPUT:
903 RETVAL
904
9b1961be
NC
905# The type checking code in B has always been identical for all OP types,
906# irrespective of whether the action is actually defined on that OP.
907# We should fix this
086f9b42 908void
9b1961be 909next(o)
a8a597b2 910 B::OP o
9b1961be 911 ALIAS:
086f9b42
NC
912 B::OP::next = OP_next_ix
913 B::OP::sibling = OP_sibling_ix
914 B::OP::targ = OP_targ_ix
915 B::OP::flags = OP_flags_ix
916 B::OP::private = OP_private_ix
917 B::UNOP::first = UNOP_first_ix
918 B::BINOP::last = BINOP_last_ix
919 B::LOGOP::other = LOGOP_other_ix
920 B::PMOP::pmreplstart = PMOP_pmreplstart_ix
921 B::LOOP::redoop = LOOP_redoop_ix
922 B::LOOP::nextop = LOOP_nextop_ix
923 B::LOOP::lastop = LOOP_lastop_ix
a78b89ef 924 B::PMOP::pmflags = PMOP_pmflags_ix
ba7298e3
NC
925 B::SVOP::sv = SVOP_sv_ix
926 B::SVOP::gv = SVOP_gv_ix
9488fb36 927 B::PADOP::padix = PADOP_padix_ix
39e120c1
NC
928 B::COP::cop_seq = COP_seq_ix
929 B::COP::line = COP_line_ix
930 B::COP::hints = COP_hints_ix
9b1961be
NC
931 PREINIT:
932 char *ptr;
086f9b42
NC
933 SV *ret;
934 PPCODE:
935 ptr = (ix & 0xFFFF) + (char *)o;
936 switch ((U8)(ix >> 16)) {
937 case (U8)(OPp >> 16):
6079961f
NC
938 ret = make_op_object(aTHX_ *((OP **)ptr));
939 break;
086f9b42
NC
940 case (U8)(PADOFFSETp >> 16):
941 ret = sv_2mortal(newSVuv(*((PADOFFSET*)ptr)));
942 break;
943 case (U8)(U8p >> 16):
944 ret = sv_2mortal(newSVuv(*((U8*)ptr)));
945 break;
a78b89ef
NC
946 case (U8)(U32p >> 16):
947 ret = sv_2mortal(newSVuv(*((U32*)ptr)));
948 break;
ba7298e3
NC
949 case (U8)(SVp >> 16):
950 ret = make_sv_object(aTHX_ NULL, *((SV **)ptr));
951 break;
39e120c1
NC
952 case (U8)(line_tp >> 16):
953 ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
954 break;
657e3fc2
NC
955#ifdef USE_ITHREADS
956 case (U8)(IVp >> 16):
957 ret = sv_2mortal(newSViv(*((IV*)ptr)));
958 break;
a9ed1a44
NC
959 case (U8)(char_pp >> 16):
960 ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
961 break;
657e3fc2 962#endif
086f9b42
NC
963 }
964 ST(0) = ret;
965 XSRETURN(1);
a8a597b2
MB
966
967char *
fdbacc68 968name(o)
3f872cb9 969 B::OP o
d2b33dc1
NC
970 ALIAS:
971 desc = 1
3f872cb9 972 CODE:
d2b33dc1 973 RETVAL = (char *)(ix ? PL_op_desc : PL_op_name)[o->op_type];
8063af02
DM
974 OUTPUT:
975 RETVAL
3f872cb9 976
8063af02 977void
fdbacc68 978ppaddr(o)
a8a597b2 979 B::OP o
dc333d64
GS
980 PREINIT:
981 int i;
fdbd1d64 982 SV *sv = newSVpvs_flags("PL_ppaddr[OP_", SVs_TEMP);
a8a597b2 983 CODE:
dc333d64 984 sv_catpv(sv, PL_op_name[o->op_type]);
7c436af3 985 for (i=13; (STRLEN)i < SvCUR(sv); ++i)
dc333d64 986 SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]);
6beb30a6 987 sv_catpvs(sv, "]");
dc333d64 988 ST(0) = sv;
a8a597b2 989
7252851f 990#if PERL_VERSION >= 9
dd8be0e4
NC
991# These 3 are all bitfields, so we can't take their addresses.
992UV
fdbacc68 993type(o)
2814eb74 994 B::OP o
dd8be0e4
NC
995 ALIAS:
996 opt = 1
997 spare = 2
998 CODE:
999 switch(ix) {
1000 case 1:
1001 RETVAL = o->op_opt;
1002 break;
1003 case 2:
1004 RETVAL = o->op_spare;
1005 break;
1006 default:
1007 RETVAL = o->op_type;
1008 }
1009 OUTPUT:
1010 RETVAL
2814eb74 1011
7252851f
NC
1012#else
1013
dd8be0e4 1014UV
fdbacc68 1015type(o)
7252851f 1016 B::OP o
dd8be0e4
NC
1017 ALIAS:
1018 seq = 1
1019 CODE:
1020 switch(ix) {
1021 case 1:
1022 RETVAL = o->op_seq;
1023 break;
1024 default:
1025 RETVAL = o->op_type;
1026 }
1027 OUTPUT:
1028 RETVAL
7252851f
NC
1029
1030#endif
1031
1df34986 1032void
fdbacc68 1033oplist(o)
1df34986
AE
1034 B::OP o
1035 PPCODE:
1036 SP = oplist(aTHX_ o, SP);
1037
fdbacc68 1038MODULE = B PACKAGE = B::LISTOP
a8a597b2 1039
c03c2844 1040U32
fdbacc68 1041children(o)
c03c2844
SM
1042 B::LISTOP o
1043 OP * kid = NO_INIT
1044 int i = NO_INIT
1045 CODE:
c03c2844
SM
1046 i = 0;
1047 for (kid = o->op_first; kid; kid = kid->op_sibling)
1048 i++;
8063af02
DM
1049 RETVAL = i;
1050 OUTPUT:
016e8ce0 1051 RETVAL
a8a597b2
MB
1052
1053MODULE = B PACKAGE = B::PMOP PREFIX = PMOP_
1054
20e98b0f
NC
1055#if PERL_VERSION <= 8
1056
a8a597b2
MB
1057void
1058PMOP_pmreplroot(o)
1059 B::PMOP o
1060 OP * root = NO_INIT
1061 CODE:
a8a597b2
MB
1062 root = o->op_pmreplroot;
1063 /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */
1064 if (o->op_type == OP_PUSHRE) {
6079961f 1065 ST(0) = sv_newmortal();
20e98b0f 1066# ifdef USE_ITHREADS
9d2bbe64 1067 sv_setiv(ST(0), INT2PTR(PADOFFSET,root) );
20e98b0f 1068# else
a8a597b2
MB
1069 sv_setiv(newSVrv(ST(0), root ?
1070 svclassnames[SvTYPE((SV*)root)] : "B::SV"),
56431972 1071 PTR2IV(root));
20e98b0f 1072# endif
a8a597b2
MB
1073 }
1074 else {
6079961f 1075 ST(0) = make_op_object(aTHX_ root);
a8a597b2
MB
1076 }
1077
20e98b0f
NC
1078#else
1079
1080void
1081PMOP_pmreplroot(o)
1082 B::PMOP o
1083 CODE:
20e98b0f 1084 if (o->op_type == OP_PUSHRE) {
6079961f 1085 ST(0) = sv_newmortal();
20e98b0f
NC
1086# ifdef USE_ITHREADS
1087 sv_setiv(ST(0), o->op_pmreplrootu.op_pmtargetoff);
1088# else
1089 GV *const target = o->op_pmreplrootu.op_pmtargetgv;
1090 sv_setiv(newSVrv(ST(0), target ?
1091 svclassnames[SvTYPE((SV*)target)] : "B::SV"),
1092 PTR2IV(target));
1093# endif
1094 }
1095 else {
1096 OP *const root = o->op_pmreplrootu.op_pmreplroot;
6079961f 1097 ST(0) = make_op_object(aTHX_ root);
20e98b0f
NC
1098 }
1099
1100#endif
1101
9d2bbe64 1102#ifdef USE_ITHREADS
016e8ce0 1103#define PMOP_pmstashpv(o) PmopSTASHPV(o);
9d2bbe64 1104
651aa52e
AE
1105char*
1106PMOP_pmstashpv(o)
1107 B::PMOP o
1108
1109#else
016e8ce0 1110#define PMOP_pmstash(o) PmopSTASH(o);
651aa52e
AE
1111
1112B::HV
1113PMOP_pmstash(o)
1114 B::PMOP o
1115
9d2bbe64
MB
1116#endif
1117
7c1f70cb 1118#if PERL_VERSION < 9
5b02c205 1119
6079961f 1120void
5b02c205
NC
1121PMOP_pmnext(o)
1122 B::PMOP o
6079961f
NC
1123 PPCODE:
1124 PUSHs(make_op_object(aTHX_ o->op_pmnext));
7c1f70cb
NC
1125
1126U32
1127PMOP_pmpermflags(o)
1128 B::PMOP o
1129
1130U8
1131PMOP_pmdynflags(o)
1132 B::PMOP o
1133
1134#endif
1135
a8a597b2
MB
1136void
1137PMOP_precomp(o)
1138 B::PMOP o
021d294f
NC
1139 PREINIT:
1140 dXSI32;
1141 REGEXP *rx;
a8a597b2 1142 CODE:
aaa362c4 1143 rx = PM_GETRE(o);
c737faaf 1144 ST(0) = sv_newmortal();
021d294f
NC
1145 if (rx) {
1146#if PERL_VERSION >= 9
1147 if (ix) {
1148 sv_setuv(ST(0), RX_EXTFLAGS(rx));
1149 } else
1150#endif
1151 {
1152 sv_setpvn(ST(0), RX_PRECOMP(rx), RX_PRELEN(rx));
1153 }
1154 }
c737faaf 1155
021d294f
NC
1156BOOT:
1157{
1158 CV *cv;
1159#ifdef USE_ITHREADS
1160 cv = newXS("B::PMOP::pmoffset", XS_B__OP_next, __FILE__);
1161 XSANY.any_i32 = PMOP_pmoffset_ix;
a9ed1a44
NC
1162 cv = newXS("B::COP::stashpv", XS_B__OP_next, __FILE__);
1163 XSANY.any_i32 = COP_stashpv_ix;
1164 cv = newXS("B::COP::file", XS_B__OP_next, __FILE__);
1165 XSANY.any_i32 = COP_file_ix;
1166#else
1167 cv = newXS("B::COP::stash", XS_B__OP_next, __FILE__);
1168 XSANY.any_i32 = COP_stash_ix;
1169 cv = newXS("B::COP::filegv", XS_B__OP_next, __FILE__);
1170 XSANY.any_i32 = COP_filegv_ix;
7c1f70cb 1171#endif
021d294f
NC
1172#if PERL_VERSION >= 9
1173 cv = newXS("B::PMOP::reflags", XS_B__PMOP_precomp, __FILE__);
1174 XSANY.any_i32 = 1;
1175#endif
1176}
1177
c518d492 1178MODULE = B PACKAGE = B::PADOP
7934575e 1179
7934575e 1180B::SV
c518d492 1181sv(o)
7934575e 1182 B::PADOP o
c518d492
NC
1183 ALIAS:
1184 gv = 1
1185 CODE:
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) {
1191 RETVAL = PAD_SVl(o->op_padix);
1192 if (ix && SvTYPE(RETVAL) != SVt_PVGV)
1193 RETVAL = NULL;
1194 } else {
1195 RETVAL = NULL;
1196 }
1197 OUTPUT:
1198 RETVAL
a8a597b2 1199
fdbacc68 1200MODULE = B PACKAGE = B::PVOP
a8a597b2
MB
1201
1202void
fdbacc68 1203pv(o)
a8a597b2
MB
1204 B::PVOP o
1205 CODE:
1206 /*
bec89253 1207 * OP_TRANS uses op_pv to point to a table of 256 or >=258 shorts
a8a597b2
MB
1208 * whereas other PVOPs point to a null terminated string.
1209 */
bb16bae8 1210 if ((o->op_type == OP_TRANS || o->op_type == OP_TRANSR) &&
bec89253
RH
1211 (o->op_private & OPpTRANS_COMPLEMENT) &&
1212 !(o->op_private & OPpTRANS_DELETE))
1213 {
5d7488b2
AL
1214 const short* const tbl = (short*)o->op_pv;
1215 const short entries = 257 + tbl[256];
d3d34884 1216 ST(0) = newSVpvn_flags(o->op_pv, entries * sizeof(short), SVs_TEMP);
bec89253 1217 }
bb16bae8 1218 else if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
d3d34884 1219 ST(0) = newSVpvn_flags(o->op_pv, 256 * sizeof(short), SVs_TEMP);
bec89253
RH
1220 }
1221 else
d3d34884 1222 ST(0) = newSVpvn_flags(o->op_pv, strlen(o->op_pv), SVs_TEMP);
a8a597b2 1223
4b65a919 1224#define COP_label(o) CopLABEL(o)
fc15ae8f 1225#define COP_arybase(o) CopARYBASE_get(o)
a8a597b2
MB
1226
1227MODULE = B PACKAGE = B::COP PREFIX = COP_
1228
d5b8ed54
NC
1229const char *
1230COP_label(o)
1231 B::COP o
1232
a9ed1a44
NC
1233# Both pairs of accessors are provided for both ithreads and not, but for each,
1234# one pair is direct structure access, and 1 pair "faked up" with a more complex
1235# macro. We implement the direct structure access pair using the common code
1236# above (B::OP::next)
1237
1238#ifdef USE_ITHREADS
11faa288 1239
4b9177c9 1240B::SV
a8a597b2
MB
1241COP_stash(o)
1242 B::COP o
4b9177c9
NC
1243 ALIAS:
1244 filegv = 1
1245 CODE:
1246 RETVAL = ix ? (SV *)CopFILEGV(o) : (SV *)CopSTASH(o);
1247 OUTPUT:
1248 RETVAL
a9ed1a44
NC
1249
1250#else
a9ed1a44
NC
1251
1252char *
1253COP_stashpv(o)
1254 B::COP o
dde513e7
NC
1255 ALIAS:
1256 file = 1
1257 CODE:
1258 RETVAL = ix ? CopFILE(o) : CopSTASHPV(o);
1259 OUTPUT:
1260 RETVAL
a8a597b2 1261
a9ed1a44 1262#endif
1df34986 1263
a8a597b2
MB
1264I32
1265COP_arybase(o)
1266 B::COP o
1267
5c3c3f81 1268void
b295d113
TH
1269COP_warnings(o)
1270 B::COP o
0a49bb24
NC
1271 ALIAS:
1272 io = 1
1273 PPCODE:
13d356f3 1274#if PERL_VERSION >= 9
0a49bb24 1275 ST(0) = ix ? make_cop_io_object(aTHX_ o) : make_warnings_object(aTHX_ o);
13d356f3 1276#else
0a49bb24 1277 ST(0) = make_sv_object(aTHX_ NULL, ix ? o->cop_io : o->cop_warnings);
13d356f3 1278#endif
11bcd5da 1279 XSRETURN(1);
6e6a1aef 1280
13d356f3
NC
1281#if PERL_VERSION >= 9
1282
fd9f6265
JJ
1283B::RHE
1284COP_hints_hash(o)
1285 B::COP o
1286 CODE:
20439bc7 1287 RETVAL = CopHINTHASH_get(o);
fd9f6265
JJ
1288 OUTPUT:
1289 RETVAL
1290
e412117e
NC
1291#endif
1292
651aa52e
AE
1293MODULE = B PACKAGE = B::SV
1294
de64752d
NC
1295#define MAGICAL_FLAG_BITS (SVs_GMG|SVs_SMG|SVs_RMG)
1296
651aa52e 1297U32
de64752d 1298REFCNT(sv)
651aa52e 1299 B::SV sv
de64752d
NC
1300 ALIAS:
1301 FLAGS = 0xFFFFFFFF
1302 SvTYPE = SVTYPEMASK
1303 POK = SVf_POK
1304 ROK = SVf_ROK
1305 MAGICAL = MAGICAL_FLAG_BITS
1306 CODE:
1307 RETVAL = ix ? (SvFLAGS(sv) & (U32)ix) : SvREFCNT(sv);
1308 OUTPUT:
1309 RETVAL
651aa52e 1310
9efba5c8 1311void
429a5ce7
SM
1312object_2svref(sv)
1313 B::SV sv
9efba5c8
NC
1314 PPCODE:
1315 ST(0) = sv_2mortal(newRV(sv));
1316 XSRETURN(1);
1317
a8a597b2
MB
1318MODULE = B PACKAGE = B::IV PREFIX = Sv
1319
1320IV
1321SvIV(sv)
1322 B::IV sv
1323
e4da9d6a 1324MODULE = B PACKAGE = B::IV
a8a597b2 1325
e4da9d6a
NC
1326#define sv_SVp 0x00000
1327#define sv_IVp 0x10000
1328#define sv_UVp 0x20000
1329#define sv_STRLENp 0x30000
1330#define sv_U32p 0x40000
1331#define sv_U8p 0x50000
1332#define sv_char_pp 0x60000
1333#define sv_NVp 0x70000
6782c6e0 1334#define sv_char_p 0x80000
3da43c35 1335#define sv_SSize_tp 0x90000
ffc5d9fc
NC
1336#define sv_I32p 0xA0000
1337#define sv_U16p 0xB0000
e4da9d6a
NC
1338
1339#define IV_ivx_ix sv_IVp | offsetof(struct xpviv, xiv_iv)
1340#define IV_uvx_ix sv_UVp | offsetof(struct xpvuv, xuv_uv)
1341#define NV_nvx_ix sv_NVp | offsetof(struct xpvnv, xnv_u.xnv_nv)
1342
1343#if PERL_VERSION >= 10
1344#define NV_cop_seq_range_low_ix \
1345 sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
1346#define NV_cop_seq_range_high_ix \
1347 sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
1348#define NV_parent_pad_index_ix \
1349 sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
1350#define NV_parent_fakelex_flags_ix \
1351 sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
1352#else
1353#define NV_cop_seq_range_low_ix \
1354 sv_NVp | offsetof(struct xpvnv, xnv_nv)
1355#define NV_cop_seq_range_high_ix \
1356 sv_UVp | offsetof(struct xpvnv, xuv_uv)
1357#define NV_parent_pad_index_ix \
1358 sv_NVp | offsetof(struct xpvnv, xnv_nv)
1359#define NV_parent_fakelex_flags_ix \
1360 sv_UVp | offsetof(struct xpvnv, xuv_uv)
1361#endif
0ca04487 1362
6782c6e0
NC
1363#define PV_cur_ix sv_STRLENp | offsetof(struct xpv, xpv_cur)
1364#define PV_len_ix sv_STRLENp | offsetof(struct xpv, xpv_len)
1365
1366#define PVMG_stash_ix sv_SVp | offsetof(struct xpvmg, xmg_stash)
1367
91a71e08
NC
1368#if PERL_VERSION >= 10
1369#define PVBM_useful_ix sv_I32p | offsetof(struct xpvgv, xiv_u.xivu_i32)
1370#define PVBM_previous_ix sv_U32p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_previous)
1371#define PVBM_rare_ix sv_U8p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_rare)
1372#else
1373#define PVBM_useful_ix sv_I32p | offsetof(struct xpvbm, xbm_useful)
1374#define PVBM_previous_ix sv_U16p | offsetof(struct xpvbm, xbm_previous)
1375#define PVBM_rare_ix sv_U8p | offsetof(struct xpvbm, xbm_rare)
1376#endif
1377
6782c6e0
NC
1378#define PVLV_targoff_ix sv_U32p | offsetof(struct xpvlv, xlv_targoff)
1379#define PVLV_targlen_ix sv_U32p | offsetof(struct xpvlv, xlv_targlen)
1380#define PVLV_targ_ix sv_SVp | offsetof(struct xpvlv, xlv_targ)
1381#define PVLV_type_ix sv_char_p | offsetof(struct xpvlv, xlv_type)
1382
f1f19364
NC
1383#if PERL_VERSION >= 10
1384#define PVGV_stash_ix sv_SVp | offsetof(struct xpvgv, xnv_u.xgv_stash)
1385#define PVGV_flags_ix sv_STRLENp | offsetof(struct xpvgv, xpv_cur)
55440d31 1386#define PVIO_lines_ix sv_IVp | offsetof(struct xpvio, xiv_iv)
f1f19364
NC
1387#else
1388#define PVGV_stash_ix sv_SVp | offsetof(struct xpvgv, xgv_stash)
1389#define PVGV_flags_ix sv_U8p | offsetof(struct xpvgv, xgv_flags)
55440d31 1390#define PVIO_lines_ix sv_IVp | offsetof(struct xpvio, xio_lines)
f1f19364
NC
1391#endif
1392
55440d31
NC
1393#define PVIO_page_ix sv_IVp | offsetof(struct xpvio, xio_page)
1394#define PVIO_page_len_ix sv_IVp | offsetof(struct xpvio, xio_page_len)
1395#define PVIO_lines_left_ix sv_IVp | offsetof(struct xpvio, xio_lines_left)
1396#define PVIO_top_name_ix sv_char_pp | offsetof(struct xpvio, xio_top_name)
1397#define PVIO_top_gv_ix sv_SVp | offsetof(struct xpvio, xio_top_gv)
1398#define PVIO_fmt_name_ix sv_char_pp | offsetof(struct xpvio, xio_fmt_name)
1399#define PVIO_fmt_gv_ix sv_SVp | offsetof(struct xpvio, xio_fmt_gv)
1400#define PVIO_bottom_name_ix sv_char_pp | offsetof(struct xpvio, xio_bottom_name)
1401#define PVIO_bottom_gv_ix sv_SVp | offsetof(struct xpvio, xio_bottom_gv)
1402#define PVIO_type_ix sv_char_p | offsetof(struct xpvio, xio_type)
1403#define PVIO_flags_ix sv_U8p | offsetof(struct xpvio, xio_flags)
1404
3da43c35
NC
1405#define PVAV_max_ix sv_SSize_tp | offsetof(struct xpvav, xav_max)
1406
1407#define PVFM_lines_ix sv_IVp | offsetof(struct xpvfm, xfm_lines)
1408
ffc5d9fc
NC
1409#define PVCV_stash_ix sv_SVp | offsetof(struct xpvcv, xcv_stash)
1410#define PVCV_gv_ix sv_SVp | offsetof(struct xpvcv, xcv_gv)
1411#define PVCV_file_ix sv_char_pp | offsetof(struct xpvcv, xcv_file)
1412#define PVCV_depth_ix sv_I32p | offsetof(struct xpvcv, xcv_depth)
1413#define PVCV_padlist_ix sv_SVp | offsetof(struct xpvcv, xcv_padlist)
1414#define PVCV_outside_ix sv_SVp | offsetof(struct xpvcv, xcv_outside)
1415#define PVCV_outside_seq_ix sv_U32p | offsetof(struct xpvcv, xcv_outside_seq)
1416#define PVCV_flags_ix sv_U16p | offsetof(struct xpvcv, xcv_flags)
1417
d65a2b0a
NC
1418#define PVHV_max_ix sv_STRLENp | offsetof(struct xpvhv, xhv_max)
1419
1420#if PERL_VERSION > 12
1421#define PVHV_keys_ix sv_STRLENp | offsetof(struct xpvhv, xhv_keys)
1422#else
1423#define PVHV_keys_ix sv_IVp | offsetof(struct xpvhv, xhv_keys)
1424#endif
1425
e4da9d6a
NC
1426# The type checking code in B has always been identical for all SV types,
1427# irrespective of whether the action is actually defined on that SV.
1428# We should fix this
1429void
1430IVX(sv)
1431 B::SV sv
1432 ALIAS:
1433 B::IV::IVX = IV_ivx_ix
1434 B::IV::UVX = IV_uvx_ix
1435 B::NV::NVX = NV_nvx_ix
1436 B::NV::COP_SEQ_RANGE_LOW = NV_cop_seq_range_low_ix
1437 B::NV::COP_SEQ_RANGE_HIGH = NV_cop_seq_range_high_ix
1438 B::NV::PARENT_PAD_INDEX = NV_parent_pad_index_ix
1439 B::NV::PARENT_FAKELEX_FLAGS = NV_parent_fakelex_flags_ix
6782c6e0
NC
1440 B::PV::CUR = PV_cur_ix
1441 B::PV::LEN = PV_len_ix
1442 B::PVMG::SvSTASH = PVMG_stash_ix
1443 B::PVLV::TARGOFF = PVLV_targoff_ix
1444 B::PVLV::TARGLEN = PVLV_targlen_ix
1445 B::PVLV::TARG = PVLV_targ_ix
1446 B::PVLV::TYPE = PVLV_type_ix
f1f19364
NC
1447 B::GV::STASH = PVGV_stash_ix
1448 B::GV::GvFLAGS = PVGV_flags_ix
91a71e08
NC
1449 B::BM::USEFUL = PVBM_useful_ix
1450 B::BM::PREVIOUS = PVBM_previous_ix
1451 B::BM::RARE = PVBM_rare_ix
55440d31
NC
1452 B::IO::LINES = PVIO_lines_ix
1453 B::IO::PAGE = PVIO_page_ix
1454 B::IO::PAGE_LEN = PVIO_page_len_ix
1455 B::IO::LINES_LEFT = PVIO_lines_left_ix
1456 B::IO::TOP_NAME = PVIO_top_name_ix
1457 B::IO::TOP_GV = PVIO_top_gv_ix
1458 B::IO::FMT_NAME = PVIO_fmt_name_ix
1459 B::IO::FMT_GV = PVIO_fmt_gv_ix
1460 B::IO::BOTTOM_NAME = PVIO_bottom_name_ix
1461 B::IO::BOTTOM_GV = PVIO_bottom_gv_ix
1462 B::IO::IoTYPE = PVIO_type_ix
1463 B::IO::IoFLAGS = PVIO_flags_ix
3da43c35
NC
1464 B::AV::MAX = PVAV_max_ix
1465 B::FM::LINES = PVFM_lines_ix
ffc5d9fc
NC
1466 B::CV::STASH = PVCV_stash_ix
1467 B::CV::GV = PVCV_gv_ix
1468 B::CV::FILE = PVCV_file_ix
1469 B::CV::DEPTH = PVCV_depth_ix
1470 B::CV::PADLIST = PVCV_padlist_ix
1471 B::CV::OUTSIDE = PVCV_outside_ix
1472 B::CV::OUTSIDE_SEQ = PVCV_outside_seq_ix
1473 B::CV::CvFLAGS = PVCV_flags_ix
d65a2b0a
NC
1474 B::HV::MAX = PVHV_max_ix
1475 B::HV::KEYS = PVHV_keys_ix
e4da9d6a
NC
1476 PREINIT:
1477 char *ptr;
1478 SV *ret;
1479 PPCODE:
1480 ptr = (ix & 0xFFFF) + (char *)SvANY(sv);
1481 switch ((U8)(ix >> 16)) {
1482 case (U8)(sv_SVp >> 16):
1483 ret = make_sv_object(aTHX_ NULL, *((SV **)ptr));
1484 break;
1485 case (U8)(sv_IVp >> 16):
1486 ret = sv_2mortal(newSViv(*((IV *)ptr)));
1487 break;
1488 case (U8)(sv_UVp >> 16):
1489 ret = sv_2mortal(newSVuv(*((UV *)ptr)));
1490 break;
6782c6e0
NC
1491 case (U8)(sv_STRLENp >> 16):
1492 ret = sv_2mortal(newSVuv(*((STRLEN *)ptr)));
1493 break;
e4da9d6a
NC
1494 case (U8)(sv_U32p >> 16):
1495 ret = sv_2mortal(newSVuv(*((U32 *)ptr)));
1496 break;
1497 case (U8)(sv_U8p >> 16):
1498 ret = sv_2mortal(newSVuv(*((U8 *)ptr)));
1499 break;
1500 case (U8)(sv_char_pp >> 16):
1501 ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
1502 break;
1503 case (U8)(sv_NVp >> 16):
1504 ret = sv_2mortal(newSVnv(*((NV *)ptr)));
1505 break;
6782c6e0
NC
1506 case (U8)(sv_char_p >> 16):
1507 ret = newSVpvn_flags((char *)ptr, 1, SVs_TEMP);
1508 break;
3da43c35
NC
1509 case (U8)(sv_SSize_tp >> 16):
1510 ret = sv_2mortal(newSViv(*((SSize_t *)ptr)));
1511 break;
ffc5d9fc
NC
1512 case (U8)(sv_I32p >> 16):
1513 ret = sv_2mortal(newSVuv(*((I32 *)ptr)));
1514 break;
1515 case (U8)(sv_U16p >> 16):
1516 ret = sv_2mortal(newSVuv(*((U16 *)ptr)));
1517 break;
e4da9d6a
NC
1518 }
1519 ST(0) = ret;
1520 XSRETURN(1);
a8a597b2 1521
a8a597b2
MB
1522void
1523packiv(sv)
1524 B::IV sv
6829f5e2
NC
1525 ALIAS:
1526 needs64bits = 1
a8a597b2 1527 CODE:
6829f5e2
NC
1528 if (ix) {
1529 ST(0) = boolSV((I32)SvIVX(sv) != SvIVX(sv));
1530 } else if (sizeof(IV) == 8) {
a8a597b2 1531 U32 wp[2];
5d7488b2 1532 const IV iv = SvIVX(sv);
a8a597b2
MB
1533 /*
1534 * The following way of spelling 32 is to stop compilers on
1535 * 32-bit architectures from moaning about the shift count
1536 * being >= the width of the type. Such architectures don't
1537 * reach this code anyway (unless sizeof(IV) > 8 but then
1538 * everything else breaks too so I'm not fussed at the moment).
1539 */
42718184
RB
1540#ifdef UV_IS_QUAD
1541 wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1542#else
1543 wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1544#endif
a8a597b2 1545 wp[1] = htonl(iv & 0xffffffff);
d3d34884 1546 ST(0) = newSVpvn_flags((char *)wp, 8, SVs_TEMP);
a8a597b2
MB
1547 } else {
1548 U32 w = htonl((U32)SvIVX(sv));
d3d34884 1549 ST(0) = newSVpvn_flags((char *)&w, 4, SVs_TEMP);
a8a597b2
MB
1550 }
1551
1552MODULE = B PACKAGE = B::NV PREFIX = Sv
1553
76ef7183 1554NV
a8a597b2
MB
1555SvNV(sv)
1556 B::NV sv
1557
4df7f6af
NC
1558#if PERL_VERSION < 11
1559
a8a597b2
MB
1560MODULE = B PACKAGE = B::RV PREFIX = Sv
1561
1562B::SV
1563SvRV(sv)
1564 B::RV sv
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
b326da91 1588B::SV
fdbacc68 1589RV(sv)
b326da91
MB
1590 B::PV sv
1591 CODE:
1592 if( SvROK(sv) ) {
1593 RETVAL = SvRV(sv);
1594 }
1595 else {
1596 croak( "argument is not SvROK" );
1597 }
1598 OUTPUT:
1599 RETVAL
1600
a8a597b2 1601void
fdbacc68 1602PV(sv)
a8a597b2 1603 B::PV sv
3d665704
NC
1604 ALIAS:
1605 PVX = 1
f4c36584 1606 PVBM = 2
84fea184 1607 B::BM::TABLE = 3
a804b0fe
NC
1608 PREINIT:
1609 const char *p;
1610 STRLEN len = 0;
1611 U32 utf8 = 0;
a8a597b2 1612 CODE:
84fea184
NC
1613 if (ix == 3) {
1614 p = SvPV(sv, len);
1615 /* Boyer-Moore table is just after string and its safety-margin \0 */
1616 p += len + PERL_FBM_TABLE_OFFSET;
1617 len = 256;
1618 } else if (ix == 2) {
f4c36584
NC
1619 /* This used to read 257. I think that that was buggy - should have
1620 been 258. (The "\0", the flags byte, and 256 for the table. Not
1621 that anything anywhere calls this method. NWC. */
1622 /* Also, the start pointer has always been SvPVX(sv). Surely it
1623 should be SvPVX(sv) + SvCUR(sv)? The code has faithfully been
1624 refactored with this behaviour, since PVBM was added in
1625 651aa52ea1faa806. */
1626 p = SvPVX_const(sv);
1627 len = SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0);
1628 } else if (ix) {
3d665704
NC
1629 p = SvPVX(sv);
1630 len = strlen(p);
1631 } else if (SvPOK(sv)) {
a804b0fe
NC
1632 len = SvCUR(sv);
1633 p = SvPVX_const(sv);
1634 utf8 = SvUTF8(sv);
0eaead75
NC
1635#if PERL_VERSION < 10
1636 /* Before 5.10 (well 931b58fb28fa5ca7), PAD_COMPNAME_GEN was stored
1637 in SvCUR(), which meant we had to attempt this special casing
1638 to avoid tripping up over variable names in the pads. */
fdbd1d64 1639 if((SvLEN(sv) && len >= SvLEN(sv))) {
b55685ae
NC
1640 /* It claims to be longer than the space allocated for it -
1641 presuambly it's a variable name in the pad */
fdbd1d64 1642 len = strlen(p);
b55685ae 1643 }
0eaead75 1644#endif
b326da91
MB
1645 }
1646 else {
1647 /* XXX for backward compatibility, but should fail */
1648 /* croak( "argument is not SvPOK" ); */
a804b0fe 1649 p = NULL;
b326da91 1650 }
a804b0fe 1651 ST(0) = newSVpvn_flags(p, len, SVs_TEMP | utf8);
a8a597b2 1652
fdbacc68 1653MODULE = B PACKAGE = B::PVMG
a8a597b2
MB
1654
1655void
fdbacc68 1656MAGIC(sv)
a8a597b2
MB
1657 B::PVMG sv
1658 MAGIC * mg = NO_INIT
1659 PPCODE:
1660 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
9496d2e5 1661 XPUSHs(make_mg_object(aTHX_ mg));
a8a597b2 1662
b2adfa9b 1663MODULE = B PACKAGE = B::MAGIC
a8a597b2
MB
1664
1665void
b2adfa9b 1666MOREMAGIC(mg)
a8a597b2 1667 B::MAGIC mg
b2adfa9b
NC
1668 ALIAS:
1669 PRIVATE = 1
1670 TYPE = 2
1671 FLAGS = 3
1672 LEN = 4
1673 OBJ = 5
1674 PTR = 6
1675 REGEX = 7
1676 precomp = 8
1677 PPCODE:
1678 switch (ix) {
1679 case 0:
1680 XPUSHs(mg->mg_moremagic ? make_mg_object(aTHX_ mg->mg_moremagic)
1681 : &PL_sv_undef);
1682 break;
1683 case 1:
1684 mPUSHu(mg->mg_private);
1685 break;
1686 case 2:
1687 PUSHs(newSVpvn_flags(&(mg->mg_type), 1, SVs_TEMP));
1688 break;
1689 case 3:
1690 mPUSHu(mg->mg_flags);
1691 break;
1692 case 4:
1693 mPUSHi(mg->mg_len);
1694 break;
1695 case 5:
1696 PUSHs(make_sv_object(aTHX_ NULL, mg->mg_obj));
1697 break;
1698 case 6:
1699 if (mg->mg_ptr) {
1700 if (mg->mg_len >= 0) {
1701 PUSHs(newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP));
651aa52e 1702 } else if (mg->mg_len == HEf_SVKEY) {
b2adfa9b 1703 PUSHs(make_sv_object(aTHX_ NULL, (SV*)mg->mg_ptr));
fdbd1d64 1704 } else
b2adfa9b
NC
1705 PUSHs(sv_newmortal());
1706 } else
1707 PUSHs(sv_newmortal());
1708 break;
1709 case 7:
1710 if(mg->mg_type == PERL_MAGIC_qr) {
1711 mPUSHi(PTR2IV(mg->mg_obj));
1712 } else {
1713 croak("REGEX is only meaningful on r-magic");
1714 }
1715 break;
1716 case 8:
1717 if (mg->mg_type == PERL_MAGIC_qr) {
1718 REGEXP *rx = (REGEXP *)mg->mg_obj;
227aaa42
NC
1719 PUSHs(newSVpvn_flags(rx ? RX_PRECOMP(rx) : NULL,
1720 rx ? RX_PRELEN(rx) : 0, SVs_TEMP));
b2adfa9b
NC
1721 } else {
1722 croak( "precomp is only meaningful on r-magic" );
1723 }
1724 break;
1725 }
a8a597b2 1726
a8a597b2
MB
1727MODULE = B PACKAGE = B::GV PREFIX = Gv
1728
1729void
1730GvNAME(gv)
1731 B::GV gv
cbf9c13f
NC
1732 ALIAS:
1733 FILE = 1
435e8dd0 1734 B::HV::NAME = 2
a8a597b2 1735 CODE:
6beb30a6 1736#if PERL_VERSION >= 10
435e8dd0
NC
1737 ST(0) = sv_2mortal(newSVhek(!ix ? GvNAME_HEK(gv)
1738 : (ix == 1 ? GvFILE_HEK(gv)
1739 : HvNAME_HEK((HV *)gv))));
6beb30a6 1740#else
435e8dd0
NC
1741 ST(0) = !ix ? newSVpvn_flags(GvNAME(gv), GvNAMELEN(gv), SVs_TEMP)
1742 : sv_2mortal(newSVpv(ix == 1 ? GvFILE(gv) : HvNAME((HV *)gv), 0))
6beb30a6 1743#endif
a8a597b2 1744
87d7fd28
GS
1745bool
1746is_empty(gv)
1747 B::GV gv
711fbbf0
NC
1748 ALIAS:
1749 isGV_with_GP = 1
87d7fd28 1750 CODE:
711fbbf0 1751 if (ix) {
50786ba8 1752#if PERL_VERSION >= 9
711fbbf0 1753 RETVAL = isGV_with_GP(gv) ? TRUE : FALSE;
50786ba8 1754#else
711fbbf0 1755 RETVAL = TRUE; /* In 5.8 and earlier they all are. */
50786ba8 1756#endif
711fbbf0
NC
1757 } else {
1758 RETVAL = GvGP(gv) == Null(GP*);
1759 }
50786ba8 1760 OUTPUT:
711fbbf0 1761 RETVAL
50786ba8 1762
651aa52e
AE
1763void*
1764GvGP(gv)
1765 B::GV gv
1766
257e0650
NC
1767#define GP_sv_ix SVp | offsetof(struct gp, gp_sv)
1768#define GP_io_ix SVp | offsetof(struct gp, gp_io)
1769#define GP_cv_ix SVp | offsetof(struct gp, gp_cv)
1770#define GP_cvgen_ix U32p | offsetof(struct gp, gp_cvgen)
1771#define GP_refcnt_ix U32p | offsetof(struct gp, gp_refcnt)
1772#define GP_hv_ix SVp | offsetof(struct gp, gp_hv)
1773#define GP_av_ix SVp | offsetof(struct gp, gp_av)
1774#define GP_form_ix SVp | offsetof(struct gp, gp_form)
1775#define GP_egv_ix SVp | offsetof(struct gp, gp_egv)
1776#define GP_line_ix line_tp | offsetof(struct gp, gp_line)
a8a597b2 1777
257e0650
NC
1778void
1779SV(gv)
a8a597b2 1780 B::GV gv
257e0650
NC
1781 ALIAS:
1782 SV = GP_sv_ix
1783 IO = GP_io_ix
1784 CV = GP_cv_ix
1785 CVGEN = GP_cvgen_ix
1786 GvREFCNT = GP_refcnt_ix
1787 HV = GP_hv_ix
1788 AV = GP_av_ix
1789 FORM = GP_form_ix
1790 EGV = GP_egv_ix
1791 LINE = GP_line_ix
1792 PREINIT:
1793 GP *gp;
1794 char *ptr;
1795 SV *ret;
1796 PPCODE:
1797 gp = GvGP(gv);
1798 if (!gp) {
1799 const GV *const gv = CvGV(cv);
46c3f339 1800 Perl_croak(aTHX_ "NULL gp in B::GV::%s", gv ? GvNAME(gv) : "???");
257e0650
NC
1801 }
1802 ptr = (ix & 0xFFFF) + (char *)gp;
1803 switch ((U8)(ix >> 16)) {
1804 case (U8)(SVp >> 16):
1805 ret = make_sv_object(aTHX_ NULL, *((SV **)ptr));
1806 break;
1807 case (U8)(U32p >> 16):
1808 ret = sv_2mortal(newSVuv(*((U32*)ptr)));
1809 break;
1810 case (U8)(line_tp >> 16):
1811 ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
1812 break;
1813 }
1814 ST(0) = ret;
1815 XSRETURN(1);
a8a597b2
MB
1816
1817B::GV
1818GvFILEGV(gv)
1819 B::GV gv
1820
a8a597b2
MB
1821MODULE = B PACKAGE = B::IO PREFIX = Io
1822
04071355
NC
1823#if PERL_VERSION <= 8
1824
a8a597b2
MB
1825short
1826IoSUBPROCESS(io)
1827 B::IO io
1828
04071355
NC
1829#endif
1830
b326da91
MB
1831bool
1832IsSTD(io,name)
1833 B::IO io
5d7488b2 1834 const char* name
b326da91
MB
1835 PREINIT:
1836 PerlIO* handle = 0;
1837 CODE:
1838 if( strEQ( name, "stdin" ) ) {
1839 handle = PerlIO_stdin();
1840 }
1841 else if( strEQ( name, "stdout" ) ) {
1842 handle = PerlIO_stdout();
1843 }
1844 else if( strEQ( name, "stderr" ) ) {
1845 handle = PerlIO_stderr();
1846 }
1847 else {
1848 croak( "Invalid value '%s'", name );
1849 }
1850 RETVAL = handle == IoIFP(io);
1851 OUTPUT:
1852 RETVAL
1853
a8a597b2
MB
1854MODULE = B PACKAGE = B::AV PREFIX = Av
1855
1856SSize_t
1857AvFILL(av)
1858 B::AV av
1859
a8a597b2
MB
1860void
1861AvARRAY(av)
1862 B::AV av
1863 PPCODE:
1864 if (AvFILL(av) >= 0) {
1865 SV **svp = AvARRAY(av);
1866 I32 i;
1867 for (i = 0; i <= AvFILL(av); i++)
9496d2e5 1868 XPUSHs(make_sv_object(aTHX_ NULL, svp[i]));
a8a597b2
MB
1869 }
1870
429a5ce7
SM
1871void
1872AvARRAYelt(av, idx)
1873 B::AV av
1874 int idx
1875 PPCODE:
1876 if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
9496d2e5 1877 XPUSHs(make_sv_object(aTHX_ NULL, (AvARRAY(av)[idx])));
429a5ce7 1878 else
9496d2e5 1879 XPUSHs(make_sv_object(aTHX_ NULL, NULL));
429a5ce7 1880
edcc7c74
NC
1881#if PERL_VERSION < 9
1882
5b02c205
NC
1883#define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1884
1885IV
1886AvOFF(av)
1887 B::AV av
1888
edcc7c74
NC
1889MODULE = B PACKAGE = B::AV
1890
1891U8
1892AvFLAGS(av)
1893 B::AV av
1894
1895#endif
1896
a8a597b2
MB
1897MODULE = B PACKAGE = B::CV PREFIX = Cv
1898
651aa52e
AE
1899U32
1900CvCONST(cv)
1901 B::CV cv
1902
6079961f 1903void
a8a597b2
MB
1904CvSTART(cv)
1905 B::CV cv
a0da4400
NC
1906 ALIAS:
1907 ROOT = 1
6079961f
NC
1908 PPCODE:
1909 PUSHs(make_op_object(aTHX_ CvISXSUB(cv) ? NULL
1910 : ix ? CvROOT(cv) : CvSTART(cv)));
a8a597b2 1911
a8a597b2
MB
1912void
1913CvXSUB(cv)
1914 B::CV cv
96819e59
NC
1915 ALIAS:
1916 XSUBANY = 1
a8a597b2 1917 CODE:
96819e59 1918 ST(0) = ix && CvCONST(cv)
9496d2e5 1919 ? make_sv_object(aTHX_ NULL, (SV *)CvXSUBANY(cv).any_ptr)
96819e59
NC
1920 : sv_2mortal(newSViv(CvISXSUB(cv)
1921 ? (ix ? CvXSUBANY(cv).any_iv
1922 : PTR2IV(CvXSUB(cv)))
1923 : 0));
a8a597b2 1924
de3f1649
JT
1925MODULE = B PACKAGE = B::CV PREFIX = cv_
1926
1927B::SV
1928cv_const_sv(cv)
1929 B::CV cv
1930
a8a597b2
MB
1931MODULE = B PACKAGE = B::HV PREFIX = Hv
1932
1933STRLEN
1934HvFILL(hv)
1935 B::HV hv
1936
a8a597b2
MB
1937I32
1938HvRITER(hv)
1939 B::HV hv
1940
edcc7c74
NC
1941#if PERL_VERSION < 9
1942
1943B::PMOP
1944HvPMROOT(hv)
1945 B::HV hv
6079961f
NC
1946 PPCODE:
1947 PUSHs(make_op_object(aTHX_ HvPMROOT(hv));
edcc7c74
NC
1948
1949#endif
1950
a8a597b2
MB
1951void
1952HvARRAY(hv)
1953 B::HV hv
1954 PPCODE:
1955 if (HvKEYS(hv) > 0) {
1956 SV *sv;
1957 char *key;
1958 I32 len;
1959 (void)hv_iterinit(hv);
1960 EXTEND(sp, HvKEYS(hv) * 2);
8063af02 1961 while ((sv = hv_iternextsv(hv, &key, &len))) {
22f1178f 1962 mPUSHp(key, len);
9496d2e5 1963 PUSHs(make_sv_object(aTHX_ NULL, sv));
a8a597b2
MB
1964 }
1965 }
fd9f6265
JJ
1966
1967MODULE = B PACKAGE = B::HE PREFIX = He
1968
1969B::SV
1970HeVAL(he)
1971 B::HE he
b2619626
NC
1972 ALIAS:
1973 SVKEY_force = 1
1974 CODE:
1975 RETVAL = ix ? HeSVKEY_force(he) : HeVAL(he);
1976 OUTPUT:
1977 RETVAL
fd9f6265
JJ
1978
1979U32
1980HeHASH(he)
1981 B::HE he
1982
fdbacc68 1983MODULE = B PACKAGE = B::RHE
fd9f6265 1984
e412117e
NC
1985#if PERL_VERSION >= 9
1986
fd9f6265 1987SV*
fdbacc68 1988HASH(h)
fd9f6265
JJ
1989 B::RHE h
1990 CODE:
20439bc7 1991 RETVAL = newRV( (SV*)cophh_2hv(h, 0) );
fd9f6265
JJ
1992 OUTPUT:
1993 RETVAL
e412117e
NC
1994
1995#endif