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