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