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