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