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
All callers of get_op_bitspec() in Opcode.xs pass len, so don't call strlen().
[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,
172 * the OP is an SVOP, and the SV is a reference to a swash
173 * (i.e., an RV pointing to an HV).
174 */
175 return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
176 ? OPc_SVOP : OPc_PVOP;
a8a597b2
MB		 177
178 case OA_LOOP:
179 return OPc_LOOP;
180
181 case OA_COP:
182 return OPc_COP;
183
184 case OA_BASEOP_OR_UNOP:
185 /*
186 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
45f6cd40
SM		 187 * whether parens were seen. perly.y uses OPf_SPECIAL to
188 * signal whether a BASEOP had empty parens or none.
189 * Some other UNOPs are created later, though, so the best
190 * test is OPf_KIDS, which is set in newUNOP.
a8a597b2 191 */
45f6cd40 192 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
a8a597b2
MB		 193
194 case OA_FILESTATOP:
195 /*
196 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
197 * the OPf_REF flag to distinguish between OP types instead of the
198 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
199 * return OPc_UNOP so that walkoptree can find our children. If
200 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
201 * (no argument to the operator) it's an OP; with OPf_REF set it's
7934575e 202 * an SVOP (and op_sv is the GV for the filehandle argument).
a8a597b2
MB		 203 */
204 return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
93865851
GS		 205#ifdef USE_ITHREADS
206 (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
207#else
7934575e 208 (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
93865851 209#endif
a8a597b2
MB		 210 case OA_LOOPEXOP:
211 /*
212 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
213 * label was omitted (in which case it's a BASEOP) or else a term was
214 * seen. In this last case, all except goto are definitely PVOP but
215 * goto is either a PVOP (with an ordinary constant label), an UNOP
216 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
217 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
218 * get set.
219 */
220 if (o->op_flags & OPf_STACKED)
221 return OPc_UNOP;
222 else if (o->op_flags & OPf_SPECIAL)
223 return OPc_BASEOP;
224 else
225 return OPc_PVOP;
226 }
227 warn("can't determine class of operator %s, assuming BASEOP\n",
22c35a8c 228 PL_op_name[o->op_type]);
a8a597b2
MB		 229 return OPc_BASEOP;
230}
231
232static char *
5d7488b2 233cc_opclassname(pTHX_ const OP *o)
a8a597b2 234{
27da23d5 235 return (char *)opclassnames[cc_opclass(aTHX_ o)];
a8a597b2
MB		 236}
237
9496d2e5
NC		 238/* FIXME - figure out how to get the typemap to assign this to ST(0), rather
239 than creating a new mortal for ST(0) then passing it in as the first
240 argument. */
a8a597b2 241static SV *
cea2e8a9 242make_sv_object(pTHX_ SV *arg, SV *sv)
a8a597b2 243{
27da23d5 244 const char *type = 0;
a8a597b2 245 IV iv;
89ca4ac7 246 dMY_CXT;
9496d2e5
NC		 247
248 if (!arg)
249 arg = sv_newmortal();
250
e8edd1e6
TH		 251 for (iv = 0; iv < sizeof(specialsv_list)/sizeof(SV*); iv++) {
252 if (sv == specialsv_list[iv]) {
a8a597b2
MB		 253 type = "B::SPECIAL";
254 break;
255 }
256 }
257 if (!type) {
258 type = svclassnames[SvTYPE(sv)];
56431972 259 iv = PTR2IV(sv);
a8a597b2
MB		 260 }
261 sv_setiv(newSVrv(arg, type), iv);
262 return arg;
263}
264
e412117e 265#if PERL_VERSION >= 9
a8a597b2 266static SV *
9496d2e5 267make_temp_object(pTHX_ SV *temp)
8e01d9a6
NC		 268{
269 SV *target;
9496d2e5 270 SV *arg = sv_newmortal();
8e01d9a6
NC		 271 const char *const type = svclassnames[SvTYPE(temp)];
272 const IV iv = PTR2IV(temp);
273
274 target = newSVrv(arg, type);
275 sv_setiv(target, iv);
276
277 /* Need to keep our "temp" around as long as the target exists.
278 Simplest way seems to be to hang it from magic, and let that clear
279 it up. No vtable, so won't actually get in the way of anything. */
280 sv_magicext(target, temp, PERL_MAGIC_sv, NULL, NULL, 0);
281 /* magic object has had its reference count increased, so we must drop
282 our reference. */
283 SvREFCNT_dec(temp);
284 return arg;
285}
286
287static SV *
9496d2e5 288make_warnings_object(pTHX_ STRLEN *warnings)
5c3c3f81
NC		 289{
290 const char *type = 0;
291 dMY_CXT;
292 IV iv = sizeof(specialsv_list)/sizeof(SV*);
293
294 /* Counting down is deliberate. Before the split between make_sv_object
295 and make_warnings_obj there appeared to be a bug - Nullsv and pWARN_STD
296 were both 0, so you could never get a B::SPECIAL for pWARN_STD */
297
298 while (iv--) {
299 if ((SV*)warnings == specialsv_list[iv]) {
300 type = "B::SPECIAL";
301 break;
302 }
303 }
304 if (type) {
9496d2e5 305 SV *arg = sv_newmortal();
5c3c3f81 306 sv_setiv(newSVrv(arg, type), iv);
8e01d9a6 307 return arg;
5c3c3f81
NC		 308 } else {
309 /* B assumes that warnings are a regular SV. Seems easier to keep it
310 happy by making them into a regular SV. */
9496d2e5 311 return make_temp_object(aTHX_ newSVpvn((char *)(warnings + 1), *warnings));
8e01d9a6
NC		 312 }
313}
314
315static SV *
9496d2e5 316make_cop_io_object(pTHX_ COP *cop)
8e01d9a6 317{
8b850bd5
NC		 318 SV *const value = newSV(0);
319
33972ad6 320 Perl_emulate_cop_io(aTHX_ cop, value);
8b850bd5
NC		 321
322 if(SvOK(value)) {
23098a26 323 return make_sv_object(aTHX_ NULL, value);
8e01d9a6 324 } else {
8b850bd5 325 SvREFCNT_dec(value);
9496d2e5 326 return make_sv_object(aTHX_ NULL, NULL);
5c3c3f81 327 }
5c3c3f81 328}
e412117e 329#endif
5c3c3f81
NC		 330
331static SV *
9496d2e5 332make_mg_object(pTHX_ MAGIC *mg)
a8a597b2 333{
9496d2e5 334 SV *arg = sv_newmortal();
56431972 335 sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg));
a8a597b2
MB		 336 return arg;
337}
338
339static SV *
52ad86de 340cstring(pTHX_ SV *sv, bool perlstyle)
a8a597b2 341{
09e97b95 342 SV *sstr;
a8a597b2
MB		 343
344 if (!SvOK(sv))
09e97b95
NC		 345 return newSVpvs_flags("0", SVs_TEMP);
346
347 sstr = newSVpvs_flags("\"", SVs_TEMP);
348
349 if (perlstyle && SvUTF8(sv)) {
d79a7a3d 350 SV *tmpsv = sv_newmortal(); /* Temporary SV to feed sv_uni_display */
5d7488b2
AL		 351 const STRLEN len = SvCUR(sv);
352 const char *s = sv_uni_display(tmpsv, sv, 8*len, UNI_DISPLAY_QQ);
d79a7a3d
RGS		 353 while (*s)
354 {
355 if (*s == '"')
6beb30a6 356 sv_catpvs(sstr, "\\\"");
d79a7a3d 357 else if (*s == '$')
6beb30a6 358 sv_catpvs(sstr, "\\$");
d79a7a3d 359 else if (*s == '@')
6beb30a6 360 sv_catpvs(sstr, "\\@");
d79a7a3d
RGS		 361 else if (*s == '\\')
362 {
363 if (strchr("nrftax\\",*(s+1)))
364 sv_catpvn(sstr, s++, 2);
365 else
6beb30a6 366 sv_catpvs(sstr, "\\\\");
d79a7a3d
RGS		 367 }
368 else /* should always be printable */
369 sv_catpvn(sstr, s, 1);
370 ++s;
371 }
d79a7a3d 372 }
a8a597b2
MB		 373 else
374 {
375 /* XXX Optimise? */
5d7488b2
AL		 376 STRLEN len;
377 const char *s = SvPV(sv, len);
a8a597b2
MB		 378 for (; len; len--, s++)
379 {
380 /* At least try a little for readability */
381 if (*s == '"')
6beb30a6 382 sv_catpvs(sstr, "\\\"");
a8a597b2 383 else if (*s == '\\')
6beb30a6 384 sv_catpvs(sstr, "\\\\");
b326da91 385 /* trigraphs - bleagh */
5d7488b2 386 else if (!perlstyle && *s == '?' && len>=3 && s[1] == '?') {
47bf35fa 387 Perl_sv_catpvf(aTHX_ sstr, "\\%03o", '?');
b326da91 388 }
52ad86de 389 else if (perlstyle && *s == '$')
6beb30a6 390 sv_catpvs(sstr, "\\$");
52ad86de 391 else if (perlstyle && *s == '@')
6beb30a6 392 sv_catpvs(sstr, "\\@");
ce561ef2
JH		 393#ifdef EBCDIC
394 else if (isPRINT(*s))
395#else
396 else if (*s >= ' ' && *s < 127)
397#endif /* EBCDIC */
a8a597b2
MB		 398 sv_catpvn(sstr, s, 1);
399 else if (*s == '\n')
6beb30a6 400 sv_catpvs(sstr, "\\n");
a8a597b2 401 else if (*s == '\r')
6beb30a6 402 sv_catpvs(sstr, "\\r");
a8a597b2 403 else if (*s == '\t')
6beb30a6 404 sv_catpvs(sstr, "\\t");
a8a597b2 405 else if (*s == '\a')
6beb30a6 406 sv_catpvs(sstr, "\\a");
a8a597b2 407 else if (*s == '\b')
6beb30a6 408 sv_catpvs(sstr, "\\b");
a8a597b2 409 else if (*s == '\f')
6beb30a6 410 sv_catpvs(sstr, "\\f");
52ad86de 411 else if (!perlstyle && *s == '\v')
6beb30a6 412 sv_catpvs(sstr, "\\v");
a8a597b2
MB		 413 else
414 {
a8a597b2 415 /* Don't want promotion of a signed -1 char in sprintf args */
5d7488b2 416 const unsigned char c = (unsigned char) *s;
47bf35fa 417 Perl_sv_catpvf(aTHX_ sstr, "\\%03o", c);
a8a597b2
MB		 418 }
419 /* XXX Add line breaks if string is long */
420 }
a8a597b2 421 }
09e97b95 422 sv_catpvs(sstr, "\"");
a8a597b2
MB		 423 return sstr;
424}
425
426static SV *
cea2e8a9 427cchar(pTHX_ SV *sv)
a8a597b2 428{
422d053b 429 SV *sstr = newSVpvs_flags("'", SVs_TEMP);
5d7488b2 430 const char *s = SvPV_nolen(sv);
422d053b
NC		 431 /* Don't want promotion of a signed -1 char in sprintf args */
432 const unsigned char c = (unsigned char) *s;
a8a597b2 433
422d053b 434 if (c == '\'')
6beb30a6 435 sv_catpvs(sstr, "\\'");
422d053b 436 else if (c == '\\')
6beb30a6 437 sv_catpvs(sstr, "\\\\");
ce561ef2 438#ifdef EBCDIC
422d053b 439 else if (isPRINT(c))
ce561ef2 440#else
422d053b 441 else if (c >= ' ' && c < 127)
ce561ef2 442#endif /* EBCDIC */
a8a597b2 443 sv_catpvn(sstr, s, 1);
422d053b 444 else if (c == '\n')
6beb30a6 445 sv_catpvs(sstr, "\\n");
422d053b 446 else if (c == '\r')
6beb30a6 447 sv_catpvs(sstr, "\\r");
422d053b 448 else if (c == '\t')
6beb30a6 449 sv_catpvs(sstr, "\\t");
422d053b 450 else if (c == '\a')
6beb30a6 451 sv_catpvs(sstr, "\\a");
422d053b 452 else if (c == '\b')
6beb30a6 453 sv_catpvs(sstr, "\\b");
422d053b 454 else if (c == '\f')
6beb30a6 455 sv_catpvs(sstr, "\\f");
422d053b 456 else if (c == '\v')
6beb30a6 457 sv_catpvs(sstr, "\\v");
a8a597b2 458 else
422d053b 459 Perl_sv_catpvf(aTHX_ sstr, "\\%03o", c);
6beb30a6 460 sv_catpvs(sstr, "'");
a8a597b2
MB		 461 return sstr;
462}
463
8f3d514b
JC		 464#if PERL_VERSION >= 9
465# define PMOP_pmreplstart(o) o->op_pmstashstartu.op_pmreplstart
466# define PMOP_pmreplroot(o) o->op_pmreplrootu.op_pmreplroot
467#else
468# define PMOP_pmreplstart(o) o->op_pmreplstart
469# define PMOP_pmreplroot(o) o->op_pmreplroot
470# define PMOP_pmpermflags(o) o->op_pmpermflags
471# define PMOP_pmdynflags(o) o->op_pmdynflags
472#endif
473
5d7488b2
AL		 474static void
475walkoptree(pTHX_ SV *opsv, const char *method)
a8a597b2
MB		 476{
477 dSP;
f3be9b72 478 OP *o, *kid;
89ca4ac7
JH		 479 dMY_CXT;
480
a8a597b2
MB		 481 if (!SvROK(opsv))
482 croak("opsv is not a reference");
483 opsv = sv_mortalcopy(opsv);
56431972 484 o = INT2PTR(OP*,SvIV((SV*)SvRV(opsv)));
a8a597b2
MB		 485 if (walkoptree_debug) {
486 PUSHMARK(sp);
487 XPUSHs(opsv);
488 PUTBACK;
489 perl_call_method("walkoptree_debug", G_DISCARD);
490 }
491 PUSHMARK(sp);
492 XPUSHs(opsv);
493 PUTBACK;
494 perl_call_method(method, G_DISCARD);
495 if (o && (o->op_flags & OPf_KIDS)) {
a8a597b2
MB		 496 for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) {
497 /* Use the same opsv. Rely on methods not to mess it up. */
56431972 498 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
cea2e8a9 499 walkoptree(aTHX_ opsv, method);
a8a597b2
MB		 500 }
501 }
5464c149 502 if (o && (cc_opclass(aTHX_ o) == OPc_PMOP) && o->op_type != OP_PUSHRE
8f3d514b 503 && (kid = PMOP_pmreplroot(cPMOPo)))
f3be9b72 504 {
5464c149 505 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
f3be9b72
RGS		 506 walkoptree(aTHX_ opsv, method);
507 }
a8a597b2
MB		 508}
509
5d7488b2 510static SV **
1df34986
AE		 511oplist(pTHX_ OP *o, SV **SP)
512{
513 for(; o; o = o->op_next) {
514 SV *opsv;
7252851f
NC		 515#if PERL_VERSION >= 9
516 if (o->op_opt == 0)
1df34986 517 break;
2814eb74 518 o->op_opt = 0;
7252851f
NC		 519#else
520 if (o->op_seq == 0)
521 break;
522 o->op_seq = 0;
523#endif
1df34986
AE		 524 opsv = sv_newmortal();
525 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ (OP*)o)), PTR2IV(o));
526 XPUSHs(opsv);
527 switch (o->op_type) {
528 case OP_SUBST:
8f3d514b 529 SP = oplist(aTHX_ PMOP_pmreplstart(cPMOPo), SP);
1df34986
AE		 530 continue;
531 case OP_SORT:
f66c782a 532 if (o->op_flags & OPf_STACKED && o->op_flags & OPf_SPECIAL) {
1df34986
AE		 533 OP *kid = cLISTOPo->op_first->op_sibling; /* pass pushmark */
534 kid = kUNOP->op_first; /* pass rv2gv */
535 kid = kUNOP->op_first; /* pass leave */
f66c782a 536 SP = oplist(aTHX_ kid->op_next, SP);
1df34986
AE		 537 }
538 continue;
539 }
540 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
541 case OA_LOGOP:
542 SP = oplist(aTHX_ cLOGOPo->op_other, SP);
543 break;
544 case OA_LOOP:
545 SP = oplist(aTHX_ cLOOPo->op_lastop, SP);
546 SP = oplist(aTHX_ cLOOPo->op_nextop, SP);
547 SP = oplist(aTHX_ cLOOPo->op_redoop, SP);
548 break;
549 }
550 }
551 return SP;
552}
553
a8a597b2
MB		 554typedef OP *B__OP;
555typedef UNOP *B__UNOP;
556typedef BINOP *B__BINOP;
557typedef LOGOP *B__LOGOP;
a8a597b2
MB		 558typedef LISTOP *B__LISTOP;
559typedef PMOP *B__PMOP;
560typedef SVOP *B__SVOP;
7934575e 561typedef PADOP *B__PADOP;
a8a597b2
MB		 562typedef PVOP *B__PVOP;
563typedef LOOP *B__LOOP;
564typedef COP *B__COP;
565
566typedef SV *B__SV;
567typedef SV *B__IV;
568typedef SV *B__PV;
569typedef SV *B__NV;
570typedef SV *B__PVMG;
5c35adbb
NC		 571#if PERL_VERSION >= 11
572typedef SV *B__REGEXP;
573#endif
a8a597b2
MB		 574typedef SV *B__PVLV;
575typedef SV *B__BM;
576typedef SV *B__RV;
1df34986 577typedef SV *B__FM;
a8a597b2
MB		 578typedef AV *B__AV;
579typedef HV *B__HV;
580typedef CV *B__CV;
581typedef GV *B__GV;
582typedef IO *B__IO;
583
584typedef MAGIC *B__MAGIC;
fd9f6265 585typedef HE *B__HE;
e412117e 586#if PERL_VERSION >= 9
fd9f6265 587typedef struct refcounted_he *B__RHE;
e412117e 588#endif
a8a597b2 589
b1826b71
NC		 590#include "const-c.inc"
591
a8a597b2
MB		 592MODULE = B PACKAGE = B PREFIX = B_
593
b1826b71
NC		 594INCLUDE: const-xs.inc
595
a8a597b2
MB		 596PROTOTYPES: DISABLE
597
598BOOT:
4c1f658f 599{
89ca4ac7 600 MY_CXT_INIT;
e8edd1e6
TH		 601 specialsv_list[0] = Nullsv;
602 specialsv_list[1] = &PL_sv_undef;
603 specialsv_list[2] = &PL_sv_yes;
604 specialsv_list[3] = &PL_sv_no;
5c3c3f81
NC		 605 specialsv_list[4] = (SV *) pWARN_ALL;
606 specialsv_list[5] = (SV *) pWARN_NONE;
607 specialsv_list[6] = (SV *) pWARN_STD;
4c1f658f 608}
a8a597b2 609
3280af22 610#define B_main_cv() PL_main_cv
31d7d75a 611#define B_init_av() PL_initav
651aa52e 612#define B_inc_gv() PL_incgv
ece599bd 613#define B_check_av() PL_checkav_save
e6663653
NC		 614#if PERL_VERSION > 8
615# define B_unitcheck_av() PL_unitcheckav_save
616#else
617# define B_unitcheck_av() NULL
618#endif
059a8bb7
JH		 619#define B_begin_av() PL_beginav_save
620#define B_end_av() PL_endav
56eca212 621#define B_amagic_generation() PL_amagic_generation
651aa52e
AE		 622#define B_defstash() PL_defstash
623#define B_curstash() PL_curstash
3280af22 624#define B_comppadlist() (PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv))
1df34986 625#define B_formfeed() PL_formfeed
9d2bbe64
MB		 626#ifdef USE_ITHREADS
627#define B_regex_padav() PL_regex_padav
628#endif
a8a597b2 629
31d7d75a
NIS		 630B::AV
631B_init_av()
632
059a8bb7 633B::AV
ece599bd
RGS		 634B_check_av()
635
e412117e
NC		 636#if PERL_VERSION >= 9
637
ece599bd 638B::AV
676456c2
AG		 639B_unitcheck_av()
640
e412117e
NC		 641#endif
642
676456c2 643B::AV
059a8bb7
JH		 644B_begin_av()
645
646B::AV
647B_end_av()
648
651aa52e
AE		 649B::GV
650B_inc_gv()
651
9d2bbe64
MB		 652#ifdef USE_ITHREADS
653
654B::AV
655B_regex_padav()
656
657#endif
658
a8a597b2
MB		 659B::CV
660B_main_cv()
661
56eca212
GS		 662long
663B_amagic_generation()
664
a8a597b2
MB		 665B::AV
666B_comppadlist()
667
651aa52e
AE		 668B::HV
669B_curstash()
670
671B::HV
672B_defstash()
a8a597b2 673
1df34986
AE		 674B::SV
675B_formfeed()
676
651aa52e
AE		 677void
678B_warnhook()
679 CODE:
9496d2e5 680 ST(0) = make_sv_object(aTHX_ NULL, PL_warnhook);
651aa52e
AE		 681
682void
683B_diehook()
684 CODE:
9496d2e5 685 ST(0) = make_sv_object(aTHX_ NULL, PL_diehook);
651aa52e
AE		 686
687MODULE = B PACKAGE = B
a8a597b2 688
a4aabc83
NC		 689B::SV
690sv_undef()
691 ALIAS:
692 sv_no = 1
693 sv_yes = 2
694 CODE:
695 RETVAL = ix > 1 ? &PL_sv_yes : ix < 1 ? &PL_sv_undef : &PL_sv_no;
696 OUTPUT:
697 RETVAL
698
e97701b4
NC		 699B::OP
700main_root()
701 ALIAS:
702 main_start = 1
703 CODE:
704 RETVAL = ix ? PL_main_start : PL_main_root;
705 OUTPUT:
706 RETVAL
707
2edf0c1d
NC		 708UV
709sub_generation()
710 ALIAS:
711 dowarn = 1
712 CODE:
713 RETVAL = ix ? PL_dowarn : PL_sub_generation;
714 OUTPUT:
715 RETVAL
716
a8a597b2
MB		 717void
718walkoptree(opsv, method)
719 SV * opsv
5d7488b2 720 const char * method
cea2e8a9
GS		 721 CODE:
722 walkoptree(aTHX_ opsv, method);
a8a597b2
MB		 723
724int
725walkoptree_debug(...)
726 CODE:
89ca4ac7 727 dMY_CXT;
a8a597b2
MB		 728 RETVAL = walkoptree_debug;
729 if (items > 0 && SvTRUE(ST(1)))
730 walkoptree_debug = 1;
731 OUTPUT:
732 RETVAL
733
56431972 734#define address(sv) PTR2IV(sv)
a8a597b2
MB		 735
736IV
737address(sv)
738 SV * sv
739
740B::SV
741svref_2object(sv)
742 SV * sv
743 CODE:
744 if (!SvROK(sv))
745 croak("argument is not a reference");
746 RETVAL = (SV*)SvRV(sv);
747 OUTPUT:
0cc1d052
NIS		 748 RETVAL
749
750void
751opnumber(name)
5d7488b2 752const char * name
0cc1d052
NIS		 753CODE:
754{
755 int i;
756 IV result = -1;
757 ST(0) = sv_newmortal();
758 if (strncmp(name,"pp_",3) == 0)
759 name += 3;
760 for (i = 0; i < PL_maxo; i++)
761 {
762 if (strcmp(name, PL_op_name[i]) == 0)
763 {
764 result = i;
765 break;
766 }
767 }
768 sv_setiv(ST(0),result);
769}
a8a597b2
MB		 770
771void
772ppname(opnum)
773 int opnum
774 CODE:
775 ST(0) = sv_newmortal();
3280af22 776 if (opnum >= 0 && opnum < PL_maxo) {
6beb30a6 777 sv_setpvs(ST(0), "pp_");
22c35a8c 778 sv_catpv(ST(0), PL_op_name[opnum]);
a8a597b2
MB		 779 }
780
781void
782hash(sv)
783 SV * sv
784 CODE:
a8a597b2
MB		 785 STRLEN len;
786 U32 hash = 0;
8c5b7c71 787 const char *s = SvPVbyte(sv, len);
c32d3395 788 PERL_HASH(hash, s, len);
90b16320 789 ST(0) = sv_2mortal(Perl_newSVpvf(aTHX_ "0x%"UVxf, (UV)hash));
a8a597b2
MB		 790
791#define cast_I32(foo) (I32)foo
792IV
793cast_I32(i)
794 IV i
795
796void
797minus_c()
651233d2
NC		 798 ALIAS:
799 save_BEGINs = 1
a8a597b2 800 CODE:
651233d2
NC		 801 if (ix)
802 PL_savebegin = TRUE;
803 else
804 PL_minus_c = TRUE;
059a8bb7 805
a8a597b2
MB		 806SV *
807cstring(sv)
808 SV * sv
84556172
NC		 809 ALIAS:
810 perlstring = 1
9e380ad4 811 cchar = 2
09e97b95 812 PPCODE:
9e380ad4 813 PUSHs(ix == 2 ? cchar(aTHX_ sv) : cstring(aTHX_ sv, ix));
a8a597b2
MB		 814
815void
816threadsv_names()
817 PPCODE:
f5ba1307
NC		 818#if PERL_VERSION <= 8
819# ifdef USE_5005THREADS
820 int i;
5d7488b2 821 const STRLEN len = strlen(PL_threadsv_names);
f5ba1307
NC		 822
823 EXTEND(sp, len);
824 for (i = 0; i < len; i++)
d3d34884 825 PUSHs(newSVpvn_flags(&PL_threadsv_names[i], 1, SVs_TEMP));
f5ba1307
NC		 826# endif
827#endif
a8a597b2 828
257e0650
NC		 829#define SVp 0x00000
830#define U32p 0x10000
831#define line_tp 0x20000
832#define OPp 0x30000
833#define PADOFFSETp 0x40000
834#define U8p 0x50000
39e120c1 835#define IVp 0x60000
a9ed1a44 836#define char_pp 0x70000
086f9b42
NC		 837
838#define OP_next_ix OPp | offsetof(struct op, op_next)
839#define OP_sibling_ix OPp | offsetof(struct op, op_sibling)
840#define UNOP_first_ix OPp | offsetof(struct unop, op_first)
841#define BINOP_last_ix OPp | offsetof(struct binop, op_last)
842#define LOGOP_other_ix OPp | offsetof(struct logop, op_other)
9b1961be 843#if PERL_VERSION >= 9
086f9b42
NC		 844# define PMOP_pmreplstart_ix \
845 OPp | offsetof(struct pmop, op_pmstashstartu.op_pmreplstart)
9b1961be 846#else
086f9b42 847# define PMOP_pmreplstart_ix OPp | offsetof(struct pmop, op_pmreplstart)
9b1961be 848#endif
086f9b42
NC		 849#define LOOP_redoop_ix OPp | offsetof(struct loop, op_redoop)
850#define LOOP_nextop_ix OPp | offsetof(struct loop, op_nextop)
851#define LOOP_lastop_ix OPp | offsetof(struct loop, op_lastop)
852
853#define OP_targ_ix PADOFFSETp | offsetof(struct op, op_targ)
854#define OP_flags_ix U8p | offsetof(struct op, op_flags)
855#define OP_private_ix U8p | offsetof(struct op, op_private)
9b1961be 856
a78b89ef
NC		 857#define PMOP_pmflags_ix U32p | offsetof(struct pmop, op_pmflags)
858
657e3fc2
NC		 859#ifdef USE_ITHREADS
860#define PMOP_pmoffset_ix IVp | offsetof(struct pmop, op_pmoffset)
861#endif
862
ba7298e3
NC		 863# Yes, B::SV::sv and B::SV::gv really do end up generating identical code.
864#define SVOP_sv_ix SVp | offsetof(struct svop, op_sv)
865#define SVOP_gv_ix SVp | offsetof(struct svop, op_sv)
866
9488fb36
NC		 867#define PADOP_padix_ix PADOFFSETp | offsetof(struct padop, op_padix)
868
39e120c1
NC		 869#define COP_seq_ix U32p | offsetof(struct cop, cop_seq)
870#define COP_line_ix line_tp | offsetof(struct cop, cop_line)
871#if PERL_VERSION >= 9
872#define COP_hints_ix U32p | offsetof(struct cop, cop_hints)
873#else
874#define COP_hints_ix U8p | offsetof(struct cop, op_private)
875#endif
876
a9ed1a44
NC		 877#ifdef USE_ITHREADS
878#define COP_stashpv_ix char_pp | offsetof(struct cop, cop_stashpv)
879#define COP_file_ix char_pp | offsetof(struct cop, cop_file)
880#else
881#define COP_stash_ix SVp | offsetof(struct cop, cop_stash)
882#define COP_filegv_ix SVp | offsetof(struct cop, cop_filegv)
883#endif
884
a8a597b2
MB		 885MODULE = B PACKAGE = B::OP PREFIX = OP_
886
651aa52e
AE		 887size_t
888OP_size(o)
889 B::OP o
890 CODE:
891 RETVAL = opsizes[cc_opclass(aTHX_ o)];
892 OUTPUT:
893 RETVAL
894
9b1961be
NC		 895# The type checking code in B has always been identical for all OP types,
896# irrespective of whether the action is actually defined on that OP.
897# We should fix this
086f9b42 898void
9b1961be 899next(o)
a8a597b2 900 B::OP o
9b1961be 901 ALIAS:
086f9b42
NC		 902 B::OP::next = OP_next_ix
903 B::OP::sibling = OP_sibling_ix
904 B::OP::targ = OP_targ_ix
905 B::OP::flags = OP_flags_ix
906 B::OP::private = OP_private_ix
907 B::UNOP::first = UNOP_first_ix
908 B::BINOP::last = BINOP_last_ix
909 B::LOGOP::other = LOGOP_other_ix
910 B::PMOP::pmreplstart = PMOP_pmreplstart_ix
911 B::LOOP::redoop = LOOP_redoop_ix
912 B::LOOP::nextop = LOOP_nextop_ix
913 B::LOOP::lastop = LOOP_lastop_ix
a78b89ef 914 B::PMOP::pmflags = PMOP_pmflags_ix
ba7298e3
NC		 915 B::SVOP::sv = SVOP_sv_ix
916 B::SVOP::gv = SVOP_gv_ix
9488fb36 917 B::PADOP::padix = PADOP_padix_ix
39e120c1
NC		 918 B::COP::cop_seq = COP_seq_ix
919 B::COP::line = COP_line_ix
920 B::COP::hints = COP_hints_ix
9b1961be
NC		 921 PREINIT:
922 char *ptr;
086f9b42
NC		 923 SV *ret;
924 PPCODE:
925 ptr = (ix & 0xFFFF) + (char *)o;
926 switch ((U8)(ix >> 16)) {
927 case (U8)(OPp >> 16):
928 {
929 OP *const o2 = *((OP **)ptr);
930 ret = sv_newmortal();
931 sv_setiv(newSVrv(ret, cc_opclassname(aTHX_ o2)), PTR2IV(o2));
932 break;
933 }
934 case (U8)(PADOFFSETp >> 16):
935 ret = sv_2mortal(newSVuv(*((PADOFFSET*)ptr)));
936 break;
937 case (U8)(U8p >> 16):
938 ret = sv_2mortal(newSVuv(*((U8*)ptr)));
939 break;
a78b89ef
NC		 940 case (U8)(U32p >> 16):
941 ret = sv_2mortal(newSVuv(*((U32*)ptr)));
942 break;
ba7298e3
NC		 943 case (U8)(SVp >> 16):
944 ret = make_sv_object(aTHX_ NULL, *((SV **)ptr));
945 break;
39e120c1
NC		 946 case (U8)(line_tp >> 16):
947 ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
948 break;
657e3fc2
NC		 949#ifdef USE_ITHREADS
950 case (U8)(IVp >> 16):
951 ret = sv_2mortal(newSViv(*((IV*)ptr)));
952 break;
a9ed1a44
NC		 953 case (U8)(char_pp >> 16):
954 ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
955 break;
657e3fc2 956#endif
086f9b42
NC		 957 }
958 ST(0) = ret;
959 XSRETURN(1);
a8a597b2
MB		 960
961char *
3f872cb9
GS		 962OP_name(o)
963 B::OP o
d2b33dc1
NC		 964 ALIAS:
965 desc = 1
3f872cb9 966 CODE:
d2b33dc1 967 RETVAL = (char *)(ix ? PL_op_desc : PL_op_name)[o->op_type];
8063af02
DM		 968 OUTPUT:
969 RETVAL
3f872cb9 970
8063af02 971void
a8a597b2
MB		 972OP_ppaddr(o)
973 B::OP o
dc333d64
GS		 974 PREINIT:
975 int i;
fdbd1d64 976 SV *sv = newSVpvs_flags("PL_ppaddr[OP_", SVs_TEMP);
a8a597b2 977 CODE:
dc333d64 978 sv_catpv(sv, PL_op_name[o->op_type]);
7c436af3 979 for (i=13; (STRLEN)i < SvCUR(sv); ++i)
dc333d64 980 SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]);
6beb30a6 981 sv_catpvs(sv, "]");
dc333d64 982 ST(0) = sv;
a8a597b2 983
7252851f 984#if PERL_VERSION >= 9
dd8be0e4
NC		 985# These 3 are all bitfields, so we can't take their addresses.
986UV
987OP_type(o)
2814eb74 988 B::OP o
dd8be0e4
NC		 989 ALIAS:
990 opt = 1
991 spare = 2
992 CODE:
993 switch(ix) {
994 case 1:
995 RETVAL = o->op_opt;
996 break;
997 case 2:
998 RETVAL = o->op_spare;
999 break;
1000 default:
1001 RETVAL = o->op_type;
1002 }
1003 OUTPUT:
1004 RETVAL
2814eb74 1005
7252851f
NC		 1006#else
1007
dd8be0e4
NC		 1008UV
1009OP_type(o)
7252851f 1010 B::OP o
dd8be0e4
NC		 1011 ALIAS:
1012 seq = 1
1013 CODE:
1014 switch(ix) {
1015 case 1:
1016 RETVAL = o->op_seq;
1017 break;
1018 default:
1019 RETVAL = o->op_type;
1020 }
1021 OUTPUT:
1022 RETVAL
7252851f
NC		 1023
1024#endif
1025
1df34986
AE		 1026void
1027OP_oplist(o)
1028 B::OP o
1029 PPCODE:
1030 SP = oplist(aTHX_ o, SP);
1031
a8a597b2
MB		 1032MODULE = B PACKAGE = B::LISTOP PREFIX = LISTOP_
1033
c03c2844
SM		 1034U32
1035LISTOP_children(o)
1036 B::LISTOP o
1037 OP * kid = NO_INIT
1038 int i = NO_INIT
1039 CODE:
c03c2844
SM		 1040 i = 0;
1041 for (kid = o->op_first; kid; kid = kid->op_sibling)
1042 i++;
8063af02
DM		 1043 RETVAL = i;
1044 OUTPUT:
016e8ce0 1045 RETVAL
a8a597b2
MB		 1046
1047MODULE = B PACKAGE = B::PMOP PREFIX = PMOP_
1048
20e98b0f
NC		 1049#if PERL_VERSION <= 8
1050
a8a597b2
MB		 1051void
1052PMOP_pmreplroot(o)
1053 B::PMOP o
1054 OP * root = NO_INIT
1055 CODE:
1056 ST(0) = sv_newmortal();
1057 root = o->op_pmreplroot;
1058 /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */
1059 if (o->op_type == OP_PUSHRE) {
20e98b0f 1060# ifdef USE_ITHREADS
9d2bbe64 1061 sv_setiv(ST(0), INT2PTR(PADOFFSET,root) );
20e98b0f 1062# else
a8a597b2
MB		 1063 sv_setiv(newSVrv(ST(0), root ?
1064 svclassnames[SvTYPE((SV*)root)] : "B::SV"),
56431972 1065 PTR2IV(root));
20e98b0f 1066# endif
a8a597b2
MB		 1067 }
1068 else {
56431972 1069 sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root));
a8a597b2
MB		 1070 }
1071
20e98b0f
NC		 1072#else
1073
1074void
1075PMOP_pmreplroot(o)
1076 B::PMOP o
1077 CODE:
1078 ST(0) = sv_newmortal();
1079 if (o->op_type == OP_PUSHRE) {
1080# ifdef USE_ITHREADS
1081 sv_setiv(ST(0), o->op_pmreplrootu.op_pmtargetoff);
1082# else
1083 GV *const target = o->op_pmreplrootu.op_pmtargetgv;
1084 sv_setiv(newSVrv(ST(0), target ?
1085 svclassnames[SvTYPE((SV*)target)] : "B::SV"),
1086 PTR2IV(target));
1087# endif
1088 }
1089 else {
1090 OP *const root = o->op_pmreplrootu.op_pmreplroot;
1091 sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)),
1092 PTR2IV(root));
1093 }
1094
1095#endif
1096
9d2bbe64 1097#ifdef USE_ITHREADS
016e8ce0 1098#define PMOP_pmstashpv(o) PmopSTASHPV(o);
9d2bbe64 1099
651aa52e
AE		 1100char*
1101PMOP_pmstashpv(o)
1102 B::PMOP o
1103
1104#else
016e8ce0 1105#define PMOP_pmstash(o) PmopSTASH(o);
651aa52e
AE		 1106
1107B::HV
1108PMOP_pmstash(o)
1109 B::PMOP o
1110
9d2bbe64
MB		 1111#endif
1112
7c1f70cb 1113#if PERL_VERSION < 9
5b02c205
NC		 1114#define PMOP_pmnext(o) o->op_pmnext
1115
1116B::PMOP
1117PMOP_pmnext(o)
1118 B::PMOP o
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
7934575e 1174B::SV
c518d492 1175sv(o)
7934575e 1176 B::PADOP o
c518d492
NC		 1177 ALIAS:
1178 gv = 1
1179 CODE:
1180 /* It happens that the output typemaps for B::SV and B::GV are
1181 identical. The "smarts" are in make_sv_object(), which determines
1182 which class to use based on SvTYPE(), rather than anything baked in
1183 at compile time. */
1184 if (o->op_padix) {
1185 RETVAL = PAD_SVl(o->op_padix);
1186 if (ix && SvTYPE(RETVAL) != SVt_PVGV)
1187 RETVAL = NULL;
1188 } else {
1189 RETVAL = NULL;
1190 }
1191 OUTPUT:
1192 RETVAL
a8a597b2
MB		 1193
1194MODULE = B PACKAGE = B::PVOP PREFIX = PVOP_
1195
1196void
1197PVOP_pv(o)
1198 B::PVOP o
1199 CODE:
1200 /*
bec89253 1201 * OP_TRANS uses op_pv to point to a table of 256 or >=258 shorts
a8a597b2
MB		 1202 * whereas other PVOPs point to a null terminated string.
1203 */
bec89253
RH		 1204 if (o->op_type == OP_TRANS &&
1205 (o->op_private & OPpTRANS_COMPLEMENT) &&
1206 !(o->op_private & OPpTRANS_DELETE))
1207 {
5d7488b2
AL		 1208 const short* const tbl = (short*)o->op_pv;
1209 const short entries = 257 + tbl[256];
d3d34884 1210 ST(0) = newSVpvn_flags(o->op_pv, entries * sizeof(short), SVs_TEMP);
bec89253
RH		 1211 }
1212 else if (o->op_type == OP_TRANS) {
d3d34884 1213 ST(0) = newSVpvn_flags(o->op_pv, 256 * sizeof(short), SVs_TEMP);
bec89253
RH		 1214 }
1215 else
d3d34884 1216 ST(0) = newSVpvn_flags(o->op_pv, strlen(o->op_pv), SVs_TEMP);
a8a597b2 1217
4b65a919 1218#define COP_label(o) CopLABEL(o)
fc15ae8f 1219#define COP_arybase(o) CopARYBASE_get(o)
a8a597b2
MB		 1220
1221MODULE = B PACKAGE = B::COP PREFIX = COP_
1222
d5b8ed54
NC		 1223const char *
1224COP_label(o)
1225 B::COP o
1226
a9ed1a44
NC		 1227# Both pairs of accessors are provided for both ithreads and not, but for each,
1228# one pair is direct structure access, and 1 pair "faked up" with a more complex
1229# macro. We implement the direct structure access pair using the common code
1230# above (B::OP::next)
1231
1232#ifdef USE_ITHREADS
1233#define COP_stash(o) CopSTASH(o)
1234#define COP_filegv(o) CopFILEGV(o)
11faa288 1235
a8a597b2
MB		 1236B::HV
1237COP_stash(o)
1238 B::COP o
1239
a9ed1a44
NC		 1240B::GV
1241COP_filegv(o)
1242 B::COP o
1243
1244#else
1245#define COP_stashpv(o) CopSTASHPV(o)
1246#define COP_file(o) CopFILE(o)
1247
1248char *
1249COP_stashpv(o)
1250 B::COP o
1251
57843af0
GS		 1252char *
1253COP_file(o)
a8a597b2
MB		 1254 B::COP o
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
5c3c3f81 1265 PPCODE:
13d356f3 1266#if PERL_VERSION >= 9
9496d2e5 1267 ST(0) = make_warnings_object(aTHX_ o->cop_warnings);
13d356f3
NC		 1268#else
1269 ST(0) = make_sv_object(aTHX_ NULL, o->cop_warnings);
1270#endif
5c3c3f81 1271 XSRETURN(1);
b295d113 1272
670f1322 1273void
6e6a1aef
RGS		 1274COP_io(o)
1275 B::COP o
11bcd5da 1276 PPCODE:
13d356f3 1277#if PERL_VERSION >= 9
9496d2e5 1278 ST(0) = make_cop_io_object(aTHX_ o);
13d356f3
NC		 1279#else
1280 ST(0) = make_sv_object(aTHX_ NULL, o->cop_io);
1281#endif
11bcd5da 1282 XSRETURN(1);
6e6a1aef 1283
13d356f3
NC		 1284#if PERL_VERSION >= 9
1285
fd9f6265
JJ		 1286B::RHE
1287COP_hints_hash(o)
1288 B::COP o
1289 CODE:
20439bc7 1290 RETVAL = CopHINTHASH_get(o);
fd9f6265
JJ		 1291 OUTPUT:
1292 RETVAL
1293
e412117e
NC		 1294#endif
1295
651aa52e
AE		 1296MODULE = B PACKAGE = B::SV
1297
de64752d
NC		 1298#define MAGICAL_FLAG_BITS (SVs_GMG|SVs_SMG|SVs_RMG)
1299
651aa52e 1300U32
de64752d 1301REFCNT(sv)
651aa52e 1302 B::SV sv
de64752d
NC		 1303 ALIAS:
1304 FLAGS = 0xFFFFFFFF
1305 SvTYPE = SVTYPEMASK
1306 POK = SVf_POK
1307 ROK = SVf_ROK
1308 MAGICAL = MAGICAL_FLAG_BITS
1309 CODE:
1310 RETVAL = ix ? (SvFLAGS(sv) & (U32)ix) : SvREFCNT(sv);
1311 OUTPUT:
1312 RETVAL
651aa52e 1313
9efba5c8 1314void
429a5ce7
SM		 1315object_2svref(sv)
1316 B::SV sv
9efba5c8
NC		 1317 PPCODE:
1318 ST(0) = sv_2mortal(newRV(sv));
1319 XSRETURN(1);
1320
a8a597b2
MB		 1321MODULE = B PACKAGE = B::IV PREFIX = Sv
1322
1323IV
1324SvIV(sv)
1325 B::IV sv
1326
e4da9d6a 1327MODULE = B PACKAGE = B::IV
a8a597b2 1328
e4da9d6a
NC		 1329#define sv_SVp 0x00000
1330#define sv_IVp 0x10000
1331#define sv_UVp 0x20000
1332#define sv_STRLENp 0x30000
1333#define sv_U32p 0x40000
1334#define sv_U8p 0x50000
1335#define sv_char_pp 0x60000
1336#define sv_NVp 0x70000
6782c6e0 1337#define sv_char_p 0x80000
3da43c35 1338#define sv_SSize_tp 0x90000
ffc5d9fc
NC		 1339#define sv_I32p 0xA0000
1340#define sv_U16p 0xB0000
e4da9d6a
NC		 1341
1342#define IV_ivx_ix sv_IVp | offsetof(struct xpviv, xiv_iv)
1343#define IV_uvx_ix sv_UVp | offsetof(struct xpvuv, xuv_uv)
1344#define NV_nvx_ix sv_NVp | offsetof(struct xpvnv, xnv_u.xnv_nv)
1345
1346#if PERL_VERSION >= 10
1347#define NV_cop_seq_range_low_ix \
1348 sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
1349#define NV_cop_seq_range_high_ix \
1350 sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
1351#define NV_parent_pad_index_ix \
1352 sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
1353#define NV_parent_fakelex_flags_ix \
1354 sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
1355#else
1356#define NV_cop_seq_range_low_ix \
1357 sv_NVp | offsetof(struct xpvnv, xnv_nv)
1358#define NV_cop_seq_range_high_ix \
1359 sv_UVp | offsetof(struct xpvnv, xuv_uv)
1360#define NV_parent_pad_index_ix \
1361 sv_NVp | offsetof(struct xpvnv, xnv_nv)
1362#define NV_parent_fakelex_flags_ix \
1363 sv_UVp | offsetof(struct xpvnv, xuv_uv)
1364#endif
0ca04487 1365
6782c6e0
NC		 1366#define PV_cur_ix sv_STRLENp | offsetof(struct xpv, xpv_cur)
1367#define PV_len_ix sv_STRLENp | offsetof(struct xpv, xpv_len)
1368
1369#define PVMG_stash_ix sv_SVp | offsetof(struct xpvmg, xmg_stash)
1370
91a71e08
NC		 1371#if PERL_VERSION >= 10
1372#define PVBM_useful_ix sv_I32p | offsetof(struct xpvgv, xiv_u.xivu_i32)
1373#define PVBM_previous_ix sv_U32p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_previous)
1374#define PVBM_rare_ix sv_U8p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_rare)
1375#else
1376#define PVBM_useful_ix sv_I32p | offsetof(struct xpvbm, xbm_useful)
1377#define PVBM_previous_ix sv_U16p | offsetof(struct xpvbm, xbm_previous)
1378#define PVBM_rare_ix sv_U8p | offsetof(struct xpvbm, xbm_rare)
1379#endif
1380
6782c6e0
NC		 1381#define PVLV_targoff_ix sv_U32p | offsetof(struct xpvlv, xlv_targoff)
1382#define PVLV_targlen_ix sv_U32p | offsetof(struct xpvlv, xlv_targlen)
1383#define PVLV_targ_ix sv_SVp | offsetof(struct xpvlv, xlv_targ)
1384#define PVLV_type_ix sv_char_p | offsetof(struct xpvlv, xlv_type)
1385
f1f19364
NC		 1386#if PERL_VERSION >= 10
1387#define PVGV_stash_ix sv_SVp | offsetof(struct xpvgv, xnv_u.xgv_stash)
1388#define PVGV_flags_ix sv_STRLENp | offsetof(struct xpvgv, xpv_cur)
55440d31 1389#define PVIO_lines_ix sv_IVp | offsetof(struct xpvio, xiv_iv)
f1f19364
NC		 1390#else
1391#define PVGV_stash_ix sv_SVp | offsetof(struct xpvgv, xgv_stash)
1392#define PVGV_flags_ix sv_U8p | offsetof(struct xpvgv, xgv_flags)
55440d31 1393#define PVIO_lines_ix sv_IVp | offsetof(struct xpvio, xio_lines)
f1f19364
NC		 1394#endif
1395
55440d31
NC		 1396#define PVIO_page_ix sv_IVp | offsetof(struct xpvio, xio_page)
1397#define PVIO_page_len_ix sv_IVp | offsetof(struct xpvio, xio_page_len)
1398#define PVIO_lines_left_ix sv_IVp | offsetof(struct xpvio, xio_lines_left)
1399#define PVIO_top_name_ix sv_char_pp | offsetof(struct xpvio, xio_top_name)
1400#define PVIO_top_gv_ix sv_SVp | offsetof(struct xpvio, xio_top_gv)
1401#define PVIO_fmt_name_ix sv_char_pp | offsetof(struct xpvio, xio_fmt_name)
1402#define PVIO_fmt_gv_ix sv_SVp | offsetof(struct xpvio, xio_fmt_gv)
1403#define PVIO_bottom_name_ix sv_char_pp | offsetof(struct xpvio, xio_bottom_name)
1404#define PVIO_bottom_gv_ix sv_SVp | offsetof(struct xpvio, xio_bottom_gv)
1405#define PVIO_type_ix sv_char_p | offsetof(struct xpvio, xio_type)
1406#define PVIO_flags_ix sv_U8p | offsetof(struct xpvio, xio_flags)
1407
3da43c35
NC		 1408#define PVAV_max_ix sv_SSize_tp | offsetof(struct xpvav, xav_max)
1409
1410#define PVFM_lines_ix sv_IVp | offsetof(struct xpvfm, xfm_lines)
1411
ffc5d9fc
NC		 1412#define PVCV_stash_ix sv_SVp | offsetof(struct xpvcv, xcv_stash)
1413#define PVCV_gv_ix sv_SVp | offsetof(struct xpvcv, xcv_gv)
1414#define PVCV_file_ix sv_char_pp | offsetof(struct xpvcv, xcv_file)
1415#define PVCV_depth_ix sv_I32p | offsetof(struct xpvcv, xcv_depth)
1416#define PVCV_padlist_ix sv_SVp | offsetof(struct xpvcv, xcv_padlist)
1417#define PVCV_outside_ix sv_SVp | offsetof(struct xpvcv, xcv_outside)
1418#define PVCV_outside_seq_ix sv_U32p | offsetof(struct xpvcv, xcv_outside_seq)
1419#define PVCV_flags_ix sv_U16p | offsetof(struct xpvcv, xcv_flags)
1420
d65a2b0a
NC		 1421#define PVHV_max_ix sv_STRLENp | offsetof(struct xpvhv, xhv_max)
1422
1423#if PERL_VERSION > 12
1424#define PVHV_keys_ix sv_STRLENp | offsetof(struct xpvhv, xhv_keys)
1425#else
1426#define PVHV_keys_ix sv_IVp | offsetof(struct xpvhv, xhv_keys)
1427#endif
1428
e4da9d6a
NC		 1429# The type checking code in B has always been identical for all SV types,
1430# irrespective of whether the action is actually defined on that SV.
1431# We should fix this
1432void
1433IVX(sv)
1434 B::SV sv
1435 ALIAS:
1436 B::IV::IVX = IV_ivx_ix
1437 B::IV::UVX = IV_uvx_ix
1438 B::NV::NVX = NV_nvx_ix
1439 B::NV::COP_SEQ_RANGE_LOW = NV_cop_seq_range_low_ix
1440 B::NV::COP_SEQ_RANGE_HIGH = NV_cop_seq_range_high_ix
1441 B::NV::PARENT_PAD_INDEX = NV_parent_pad_index_ix
1442 B::NV::PARENT_FAKELEX_FLAGS = NV_parent_fakelex_flags_ix
6782c6e0
NC		 1443 B::PV::CUR = PV_cur_ix
1444 B::PV::LEN = PV_len_ix
1445 B::PVMG::SvSTASH = PVMG_stash_ix
1446 B::PVLV::TARGOFF = PVLV_targoff_ix
1447 B::PVLV::TARGLEN = PVLV_targlen_ix
1448 B::PVLV::TARG = PVLV_targ_ix
1449 B::PVLV::TYPE = PVLV_type_ix
f1f19364
NC		 1450 B::GV::STASH = PVGV_stash_ix
1451 B::GV::GvFLAGS = PVGV_flags_ix
91a71e08
NC		 1452 B::BM::USEFUL = PVBM_useful_ix
1453 B::BM::PREVIOUS = PVBM_previous_ix
1454 B::BM::RARE = PVBM_rare_ix
55440d31
NC		 1455 B::IO::LINES = PVIO_lines_ix
1456 B::IO::PAGE = PVIO_page_ix
1457 B::IO::PAGE_LEN = PVIO_page_len_ix
1458 B::IO::LINES_LEFT = PVIO_lines_left_ix
1459 B::IO::TOP_NAME = PVIO_top_name_ix
1460 B::IO::TOP_GV = PVIO_top_gv_ix
1461 B::IO::FMT_NAME = PVIO_fmt_name_ix
1462 B::IO::FMT_GV = PVIO_fmt_gv_ix
1463 B::IO::BOTTOM_NAME = PVIO_bottom_name_ix
1464 B::IO::BOTTOM_GV = PVIO_bottom_gv_ix
1465 B::IO::IoTYPE = PVIO_type_ix
1466 B::IO::IoFLAGS = PVIO_flags_ix
3da43c35
NC		 1467 B::AV::MAX = PVAV_max_ix
1468 B::FM::LINES = PVFM_lines_ix
ffc5d9fc
NC		 1469 B::CV::STASH = PVCV_stash_ix
1470 B::CV::GV = PVCV_gv_ix
1471 B::CV::FILE = PVCV_file_ix
1472 B::CV::DEPTH = PVCV_depth_ix
1473 B::CV::PADLIST = PVCV_padlist_ix
1474 B::CV::OUTSIDE = PVCV_outside_ix
1475 B::CV::OUTSIDE_SEQ = PVCV_outside_seq_ix
1476 B::CV::CvFLAGS = PVCV_flags_ix
d65a2b0a
NC		 1477 B::HV::MAX = PVHV_max_ix
1478 B::HV::KEYS = PVHV_keys_ix
e4da9d6a
NC		 1479 PREINIT:
1480 char *ptr;
1481 SV *ret;
1482 PPCODE:
1483 ptr = (ix & 0xFFFF) + (char *)SvANY(sv);
1484 switch ((U8)(ix >> 16)) {
1485 case (U8)(sv_SVp >> 16):
1486 ret = make_sv_object(aTHX_ NULL, *((SV **)ptr));
1487 break;
1488 case (U8)(sv_IVp >> 16):
1489 ret = sv_2mortal(newSViv(*((IV *)ptr)));
1490 break;
1491 case (U8)(sv_UVp >> 16):
1492 ret = sv_2mortal(newSVuv(*((UV *)ptr)));
1493 break;
6782c6e0
NC		 1494 case (U8)(sv_STRLENp >> 16):
1495 ret = sv_2mortal(newSVuv(*((STRLEN *)ptr)));
1496 break;
e4da9d6a
NC		 1497 case (U8)(sv_U32p >> 16):
1498 ret = sv_2mortal(newSVuv(*((U32 *)ptr)));
1499 break;
1500 case (U8)(sv_U8p >> 16):
1501 ret = sv_2mortal(newSVuv(*((U8 *)ptr)));
1502 break;
1503 case (U8)(sv_char_pp >> 16):
1504 ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
1505 break;
1506 case (U8)(sv_NVp >> 16):
1507 ret = sv_2mortal(newSVnv(*((NV *)ptr)));
1508 break;
6782c6e0
NC		 1509 case (U8)(sv_char_p >> 16):
1510 ret = newSVpvn_flags((char *)ptr, 1, SVs_TEMP);
1511 break;
3da43c35
NC		 1512 case (U8)(sv_SSize_tp >> 16):
1513 ret = sv_2mortal(newSViv(*((SSize_t *)ptr)));
1514 break;
ffc5d9fc
NC		 1515 case (U8)(sv_I32p >> 16):
1516 ret = sv_2mortal(newSVuv(*((I32 *)ptr)));
1517 break;
1518 case (U8)(sv_U16p >> 16):
1519 ret = sv_2mortal(newSVuv(*((U16 *)ptr)));
1520 break;
e4da9d6a
NC		 1521 }
1522 ST(0) = ret;
1523 XSRETURN(1);
a8a597b2 1524
a8a597b2
MB		 1525void
1526packiv(sv)
1527 B::IV sv
6829f5e2
NC		 1528 ALIAS:
1529 needs64bits = 1
a8a597b2 1530 CODE:
6829f5e2
NC		 1531 if (ix) {
1532 ST(0) = boolSV((I32)SvIVX(sv) != SvIVX(sv));
1533 } else if (sizeof(IV) == 8) {
a8a597b2 1534 U32 wp[2];
5d7488b2 1535 const IV iv = SvIVX(sv);
a8a597b2
MB		 1536 /*
1537 * The following way of spelling 32 is to stop compilers on
1538 * 32-bit architectures from moaning about the shift count
1539 * being >= the width of the type. Such architectures don't
1540 * reach this code anyway (unless sizeof(IV) > 8 but then
1541 * everything else breaks too so I'm not fussed at the moment).
1542 */
42718184
RB		 1543#ifdef UV_IS_QUAD
1544 wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1545#else
1546 wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1547#endif
a8a597b2 1548 wp[1] = htonl(iv & 0xffffffff);
d3d34884 1549 ST(0) = newSVpvn_flags((char *)wp, 8, SVs_TEMP);
a8a597b2
MB		 1550 } else {
1551 U32 w = htonl((U32)SvIVX(sv));
d3d34884 1552 ST(0) = newSVpvn_flags((char *)&w, 4, SVs_TEMP);
a8a597b2
MB		 1553 }
1554
4df7f6af 1555#if PERL_VERSION >= 11
f046b1bd
NC		 1556# The input typemap checking makes no distinction between different SV types,
1557# so the XS body will generate the same C code, despite the different XS
1558# "types". So there is no change in behaviour from doing newXS like this,
1559# compared with the old approach of having a (near) duplicate XS body.
1560# We should fix the typemap checking.
4df7f6af 1561
f046b1bd
NC		 1562BOOT:
1563 newXS("B::IV::RV", XS_B__PV_RV, __FILE__);
4df7f6af
NC		 1564
1565#endif
1566
a8a597b2
MB		 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
4df7f6af
NC		 1581#endif
1582
a8a597b2
MB		 1583MODULE = B PACKAGE = B::PV PREFIX = Sv
1584
0b40bd6d
RH		 1585char*
1586SvPVX(sv)
1587 B::PV sv
1588
b326da91
MB		 1589B::SV
1590SvRV(sv)
1591 B::PV sv
1592 CODE:
1593 if( SvROK(sv) ) {
1594 RETVAL = SvRV(sv);
1595 }
1596 else {
1597 croak( "argument is not SvROK" );
1598 }
1599 OUTPUT:
1600 RETVAL
1601
a8a597b2
MB		 1602void
1603SvPV(sv)
1604 B::PV sv
1605 CODE:
c0b20461 1606 if( SvPOK(sv) ) {
fdbd1d64
NC		 1607 STRLEN len = SvCUR(sv);
1608 const char *p = SvPVX_const(sv);
0eaead75
NC		 1609#if PERL_VERSION < 10
1610 /* Before 5.10 (well 931b58fb28fa5ca7), PAD_COMPNAME_GEN was stored
1611 in SvCUR(), which meant we had to attempt this special casing
1612 to avoid tripping up over variable names in the pads. */
fdbd1d64 1613 if((SvLEN(sv) && len >= SvLEN(sv))) {
b55685ae
NC		 1614 /* It claims to be longer than the space allocated for it -
1615 presuambly it's a variable name in the pad */
fdbd1d64 1616 len = strlen(p);
b55685ae 1617 }
0eaead75 1618#endif
fdbd1d64 1619 ST(0) = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
b326da91
MB		 1620 }
1621 else {
1622 /* XXX for backward compatibility, but should fail */
1623 /* croak( "argument is not SvPOK" ); */
fdbd1d64 1624 ST(0) = sv_newmortal();
b326da91 1625 }
a8a597b2 1626
5a44e503
NC		 1627# This used to read 257. I think that that was buggy - should have been 258.
1628# (The "\0", the flags byte, and 256 for the table. Not that anything
1629# anywhere calls this method. NWC.
651aa52e
AE		 1630void
1631SvPVBM(sv)
1632 B::PV sv
1633 CODE:
fdbd1d64
NC		 1634 ST(0) = newSVpvn_flags(SvPVX_const(sv),
1635 SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0),
1636 SVs_TEMP);
651aa52e 1637
a8a597b2
MB		 1638MODULE = B PACKAGE = B::PVMG PREFIX = Sv
1639
1640void
1641SvMAGIC(sv)
1642 B::PVMG sv
1643 MAGIC * mg = NO_INIT
1644 PPCODE:
1645 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
9496d2e5 1646 XPUSHs(make_mg_object(aTHX_ mg));
a8a597b2 1647
5c35adbb
NC		 1648MODULE = B PACKAGE = B::REGEXP
1649
1650#if PERL_VERSION >= 11
1651
1652IV
1653REGEX(sv)
07bc277f 1654 B::REGEXP sv
5c35adbb 1655 CODE:
288b8c02
NC		 1656 /* FIXME - can we code this method more efficiently? */
1657 RETVAL = PTR2IV(sv);
5c35adbb
NC		 1658 OUTPUT:
1659 RETVAL
1660
1661SV*
1662precomp(sv)
07bc277f 1663 B::REGEXP sv
5c35adbb 1664 CODE:
288b8c02 1665 RETVAL = newSVpvn( RX_PRECOMP(sv), RX_PRELEN(sv) );
5c35adbb
NC		 1666 OUTPUT:
1667 RETVAL
1668
1669#endif
1670
b2adfa9b 1671MODULE = B PACKAGE = B::MAGIC
a8a597b2
MB		 1672
1673void
b2adfa9b 1674MOREMAGIC(mg)
a8a597b2 1675 B::MAGIC mg
b2adfa9b
NC		 1676 ALIAS:
1677 PRIVATE = 1
1678 TYPE = 2
1679 FLAGS = 3
1680 LEN = 4
1681 OBJ = 5
1682 PTR = 6
1683 REGEX = 7
1684 precomp = 8
1685 PPCODE:
1686 switch (ix) {
1687 case 0:
1688 XPUSHs(mg->mg_moremagic ? make_mg_object(aTHX_ mg->mg_moremagic)
1689 : &PL_sv_undef);
1690 break;
1691 case 1:
1692 mPUSHu(mg->mg_private);
1693 break;
1694 case 2:
1695 PUSHs(newSVpvn_flags(&(mg->mg_type), 1, SVs_TEMP));
1696 break;
1697 case 3:
1698 mPUSHu(mg->mg_flags);
1699 break;
1700 case 4:
1701 mPUSHi(mg->mg_len);
1702 break;
1703 case 5:
1704 PUSHs(make_sv_object(aTHX_ NULL, mg->mg_obj));
1705 break;
1706 case 6:
1707 if (mg->mg_ptr) {
1708 if (mg->mg_len >= 0) {
1709 PUSHs(newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP));
651aa52e 1710 } else if (mg->mg_len == HEf_SVKEY) {
b2adfa9b 1711 PUSHs(make_sv_object(aTHX_ NULL, (SV*)mg->mg_ptr));
fdbd1d64 1712 } else
b2adfa9b
NC		 1713 PUSHs(sv_newmortal());
1714 } else
1715 PUSHs(sv_newmortal());
1716 break;
1717 case 7:
1718 if(mg->mg_type == PERL_MAGIC_qr) {
1719 mPUSHi(PTR2IV(mg->mg_obj));
1720 } else {
1721 croak("REGEX is only meaningful on r-magic");
1722 }
1723 break;
1724 case 8:
1725 if (mg->mg_type == PERL_MAGIC_qr) {
1726 REGEXP *rx = (REGEXP *)mg->mg_obj;
1727 PUSHs(make_sv_object(aTHX_ NULL,
1728 rx ? newSVpvn( RX_PRECOMP(rx), RX_PRELEN(rx))
1729 : NULL));
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.