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