This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add $B::overlay feature
[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 24 "B::BIND",
1cb9cd50 25 "B::IV",
b53eecb4 26 "B::NV",
4df7f6af
NC
27#if PERL_VERSION <= 10
28 "B::RV",
29#endif
a8a597b2
MB
30 "B::PV",
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*/
664 STR_WITH_LEN("pmreplstart"), OPp,
665 offsetof(struct pmop, op_pmstashstartu.op_pmreplstart), /* 8*/
666 STR_WITH_LEN("redoop"), OPp, offsetof(struct loop, op_redoop), /* 9*/
667 STR_WITH_LEN("nextop"), OPp, offsetof(struct loop, op_nextop), /*10*/
668 STR_WITH_LEN("lastop"), OPp, offsetof(struct loop, op_lastop), /*11*/
669 STR_WITH_LEN("pmflags"), U32p, offsetof(struct pmop, op_pmflags), /*12*/
670#if PERL_VERSION >= 17
671 STR_WITH_LEN("code_list"),OPp, offsetof(struct pmop, op_code_list),/*13*/
672#else
673 STR_WITH_LEN("code_list"),0, -1,
674#endif
675 STR_WITH_LEN("sv"), SVp, offsetof(struct svop, op_sv), /*14*/
676 STR_WITH_LEN("gv"), SVp, offsetof(struct svop, op_sv), /*15*/
677 STR_WITH_LEN("padix"), PADOFFSETp,offsetof(struct padop, op_padix),/*16*/
678 STR_WITH_LEN("cop_seq"), U32p, offsetof(struct cop, cop_seq), /*17*/
679 STR_WITH_LEN("line"), line_tp, offsetof(struct cop, cop_line), /*18*/
680 STR_WITH_LEN("hints"), U32p, offsetof(struct cop, cop_hints), /*19*/
681#ifdef USE_ITHREADS
682 STR_WITH_LEN("pmoffset"),IVp, offsetof(struct pmop, op_pmoffset),/*20*/
683 STR_WITH_LEN("filegv"), 0, -1, /*21*/
684 STR_WITH_LEN("file"), char_pp, offsetof(struct cop, cop_file), /*22*/
685 STR_WITH_LEN("stash"), 0, -1, /*23*/
686# if PERL_VERSION < 17
687 STR_WITH_LEN("stashpv"), char_pp, offsetof(struct cop, cop_stashpv), /*24*/
688 STR_WITH_LEN("stashoff"),0, -1, /*25*/
689# else
690 STR_WITH_LEN("stashpv"), 0, -1, /*24*/
691 STR_WITH_LEN("stashoff"),PADOFFSETp,offsetof(struct cop, cop_stashoff),/*25*/
692# endif
693#else
694 STR_WITH_LEN("pmoffset"),0, -1, /*20*/
695 STR_WITH_LEN("filegv"), SVp, offsetof(struct cop, cop_filegv), /*21*/
696 STR_WITH_LEN("file"), 0, -1, /*22*/
697 STR_WITH_LEN("stash"), SVp, offsetof(struct cop, cop_stash), /*23*/
698 STR_WITH_LEN("stashpv"), 0, -1, /*24*/
287ce0d8 699 STR_WITH_LEN("stashoff"),0, -1, /*25*/
bec746fe 700#endif
287ce0d8
DM
701 STR_WITH_LEN("size"), 0, -1, /*26*/
702 STR_WITH_LEN("name"), 0, -1, /*27*/
703 STR_WITH_LEN("desc"), 0, -1, /*28*/
704 STR_WITH_LEN("ppaddr"), 0, -1, /*29*/
705 STR_WITH_LEN("type"), 0, -1, /*30*/
706 STR_WITH_LEN("opt"), 0, -1, /*31*/
707 STR_WITH_LEN("spare"), 0, -1, /*32*/
708 STR_WITH_LEN("children"),0, -1, /*33*/
709 STR_WITH_LEN("pmreplroot"), 0, -1, /*34*/
710 STR_WITH_LEN("pmstashpv"), 0, -1, /*35*/
711 STR_WITH_LEN("pmstash"), 0, -1, /*36*/
712 STR_WITH_LEN("precomp"), 0, -1, /*37*/
713 STR_WITH_LEN("reflags"), 0, -1, /*38*/
714 STR_WITH_LEN("sv"), 0, -1, /*39*/
715 STR_WITH_LEN("gv"), 0, -1, /*40*/
716 STR_WITH_LEN("pv"), 0, -1, /*41*/
717 STR_WITH_LEN("label"), 0, -1, /*42*/
718 STR_WITH_LEN("arybase"), 0, -1, /*43*/
719 STR_WITH_LEN("warnings"),0, -1, /*44*/
720 STR_WITH_LEN("io"), 0, -1, /*45*/
721 STR_WITH_LEN("hints_hash"),0, -1, /*46*/
bec746fe
DM
722};
723
b1826b71
NC
724#include "const-c.inc"
725
7a2c16aa 726MODULE = B PACKAGE = B
a8a597b2 727
b1826b71
NC
728INCLUDE: const-xs.inc
729
a8a597b2
MB
730PROTOTYPES: DISABLE
731
732BOOT:
4c1f658f 733{
7a2c16aa
NC
734 CV *cv;
735 const char *file = __FILE__;
89ca4ac7 736 MY_CXT_INIT;
e8edd1e6
TH
737 specialsv_list[0] = Nullsv;
738 specialsv_list[1] = &PL_sv_undef;
739 specialsv_list[2] = &PL_sv_yes;
740 specialsv_list[3] = &PL_sv_no;
5c3c3f81
NC
741 specialsv_list[4] = (SV *) pWARN_ALL;
742 specialsv_list[5] = (SV *) pWARN_NONE;
743 specialsv_list[6] = (SV *) pWARN_STD;
32855229
NC
744
745 cv = newXS("B::init_av", intrpvar_sv_common, file);
115ff745 746 ASSIGN_COMMON_ALIAS(I, initav);
32855229 747 cv = newXS("B::check_av", intrpvar_sv_common, file);
115ff745 748 ASSIGN_COMMON_ALIAS(I, checkav_save);
32855229 749 cv = newXS("B::unitcheck_av", intrpvar_sv_common, file);
115ff745 750 ASSIGN_COMMON_ALIAS(I, unitcheckav_save);
32855229 751 cv = newXS("B::begin_av", intrpvar_sv_common, file);
115ff745 752 ASSIGN_COMMON_ALIAS(I, beginav_save);
32855229 753 cv = newXS("B::end_av", intrpvar_sv_common, file);
115ff745 754 ASSIGN_COMMON_ALIAS(I, endav);
32855229 755 cv = newXS("B::main_cv", intrpvar_sv_common, file);
115ff745 756 ASSIGN_COMMON_ALIAS(I, main_cv);
32855229 757 cv = newXS("B::inc_gv", intrpvar_sv_common, file);
115ff745 758 ASSIGN_COMMON_ALIAS(I, incgv);
32855229 759 cv = newXS("B::defstash", intrpvar_sv_common, file);
115ff745 760 ASSIGN_COMMON_ALIAS(I, defstash);
32855229 761 cv = newXS("B::curstash", intrpvar_sv_common, file);
115ff745 762 ASSIGN_COMMON_ALIAS(I, curstash);
5f7e30c4 763#ifdef PL_formfeed
32855229 764 cv = newXS("B::formfeed", intrpvar_sv_common, file);
115ff745 765 ASSIGN_COMMON_ALIAS(I, formfeed);
5f7e30c4 766#endif
32855229
NC
767#ifdef USE_ITHREADS
768 cv = newXS("B::regex_padav", intrpvar_sv_common, file);
115ff745 769 ASSIGN_COMMON_ALIAS(I, regex_padav);
32855229
NC
770#endif
771 cv = newXS("B::warnhook", intrpvar_sv_common, file);
115ff745 772 ASSIGN_COMMON_ALIAS(I, warnhook);
32855229 773 cv = newXS("B::diehook", intrpvar_sv_common, file);
115ff745 774 ASSIGN_COMMON_ALIAS(I, diehook);
32855229
NC
775}
776
5f7e30c4
NC
777#ifndef PL_formfeed
778
779void
780formfeed()
781 PPCODE:
782 PUSHs(make_sv_object(aTHX_ GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV))));
783
784#endif
785
7a2c16aa
NC
786long
787amagic_generation()
788 CODE:
789 RETVAL = PL_amagic_generation;
790 OUTPUT:
791 RETVAL
792
8ae5a962 793void
7a2c16aa 794comppadlist()
7261499d
FC
795 PREINIT:
796 PADLIST *padlist = CvPADLIST(PL_main_cv ? PL_main_cv : PL_compcv);
8ae5a962 797 PPCODE:
86d2498c 798#ifdef PadlistARRAY
7261499d
FC
799 {
800 SV * const rv = sv_newmortal();
801 sv_setiv(newSVrv(rv, padlist ? "B::PADLIST" : "B::NULL"),
802 PTR2IV(padlist));
803 PUSHs(rv);
804 }
805#else
806 PUSHs(make_sv_object(aTHX_ (SV *)padlist));
807#endif
7a2c16aa 808
8ae5a962 809void
a4aabc83
NC
810sv_undef()
811 ALIAS:
812 sv_no = 1
813 sv_yes = 2
8ae5a962 814 PPCODE:
0c74f67f
NC
815 PUSHs(make_sv_object(aTHX_ ix > 1 ? &PL_sv_yes
816 : ix < 1 ? &PL_sv_undef
817 : &PL_sv_no));
a4aabc83 818
6079961f 819void
e97701b4
NC
820main_root()
821 ALIAS:
822 main_start = 1
6079961f
NC
823 PPCODE:
824 PUSHs(make_op_object(aTHX_ ix ? PL_main_start : PL_main_root));
e97701b4 825
2edf0c1d
NC
826UV
827sub_generation()
828 ALIAS:
829 dowarn = 1
830 CODE:
831 RETVAL = ix ? PL_dowarn : PL_sub_generation;
832 OUTPUT:
833 RETVAL
834
a8a597b2 835void
20f7624e
NC
836walkoptree(op, method)
837 B::OP op
5d7488b2 838 const char * method
cea2e8a9 839 CODE:
20f7624e 840 (void) walkoptree(aTHX_ op, method, &PL_sv_undef);
a8a597b2
MB
841
842int
843walkoptree_debug(...)
844 CODE:
89ca4ac7 845 dMY_CXT;
a8a597b2
MB
846 RETVAL = walkoptree_debug;
847 if (items > 0 && SvTRUE(ST(1)))
848 walkoptree_debug = 1;
849 OUTPUT:
850 RETVAL
851
56431972 852#define address(sv) PTR2IV(sv)
a8a597b2
MB
853
854IV
855address(sv)
856 SV * sv
857
8ae5a962 858void
a8a597b2
MB
859svref_2object(sv)
860 SV * sv
8ae5a962 861 PPCODE:
a8a597b2
MB
862 if (!SvROK(sv))
863 croak("argument is not a reference");
0c74f67f 864 PUSHs(make_sv_object(aTHX_ SvRV(sv)));
0cc1d052
NIS
865
866void
867opnumber(name)
5d7488b2 868const char * name
0cc1d052
NIS
869CODE:
870{
871 int i;
872 IV result = -1;
873 ST(0) = sv_newmortal();
874 if (strncmp(name,"pp_",3) == 0)
875 name += 3;
876 for (i = 0; i < PL_maxo; i++)
877 {
878 if (strcmp(name, PL_op_name[i]) == 0)
879 {
880 result = i;
881 break;
882 }
883 }
884 sv_setiv(ST(0),result);
885}
a8a597b2
MB
886
887void
888ppname(opnum)
889 int opnum
890 CODE:
891 ST(0) = sv_newmortal();
cc5b6bab
NC
892 if (opnum >= 0 && opnum < PL_maxo)
893 Perl_sv_setpvf(aTHX_ ST(0), "pp_%s", PL_op_name[opnum]);
a8a597b2
MB
894
895void
896hash(sv)
897 SV * sv
898 CODE:
a8a597b2
MB
899 STRLEN len;
900 U32 hash = 0;
8c5b7c71 901 const char *s = SvPVbyte(sv, len);
c32d3395 902 PERL_HASH(hash, s, len);
90b16320 903 ST(0) = sv_2mortal(Perl_newSVpvf(aTHX_ "0x%"UVxf, (UV)hash));
a8a597b2
MB
904
905#define cast_I32(foo) (I32)foo
906IV
907cast_I32(i)
908 IV i
909
910void
911minus_c()
651233d2
NC
912 ALIAS:
913 save_BEGINs = 1
a8a597b2 914 CODE:
651233d2
NC
915 if (ix)
916 PL_savebegin = TRUE;
917 else
918 PL_minus_c = TRUE;
059a8bb7 919
847ded71 920void
a8a597b2
MB
921cstring(sv)
922 SV * sv
84556172
NC
923 ALIAS:
924 perlstring = 1
9e380ad4 925 cchar = 2
09e97b95 926 PPCODE:
847ded71 927 PUSHs(ix == 2 ? cchar(aTHX_ sv) : cstring(aTHX_ sv, (bool)ix));
a8a597b2
MB
928
929void
930threadsv_names()
931 PPCODE:
f5ba1307 932
a8a597b2 933
9488fb36 934
a9ed1a44 935
fdbacc68 936MODULE = B PACKAGE = B::OP
a8a597b2 937
651aa52e 938
9b1961be
NC
939# The type checking code in B has always been identical for all OP types,
940# irrespective of whether the action is actually defined on that OP.
941# We should fix this
086f9b42 942void
9b1961be 943next(o)
a8a597b2 944 B::OP o
9b1961be 945 ALIAS:
bec746fe
DM
946 B::OP::next = 0
947 B::OP::sibling = 1
948 B::OP::targ = 2
949 B::OP::flags = 3
950 B::OP::private = 4
951 B::UNOP::first = 5
952 B::BINOP::last = 6
953 B::LOGOP::other = 7
954 B::PMOP::pmreplstart = 8
955 B::LOOP::redoop = 9
956 B::LOOP::nextop = 10
957 B::LOOP::lastop = 11
958 B::PMOP::pmflags = 12
959 B::PMOP::code_list = 13
960 B::SVOP::sv = 14
961 B::SVOP::gv = 15
962 B::PADOP::padix = 16
963 B::COP::cop_seq = 17
964 B::COP::line = 18
965 B::COP::hints = 19
966 B::PMOP::pmoffset = 20
967 B::COP::filegv = 21
968 B::COP::file = 22
969 B::COP::stash = 23
970 B::COP::stashpv = 24
971 B::COP::stashoff = 25
287ce0d8
DM
972 B::OP::size = 26
973 B::OP::name = 27
974 B::OP::desc = 28
975 B::OP::ppaddr = 29
976 B::OP::type = 30
977 B::OP::opt = 31
978 B::OP::spare = 32
979 B::LISTOP::children = 33
980 B::PMOP::pmreplroot = 34
981 B::PMOP::pmstashpv = 35
982 B::PMOP::pmstash = 36
983 B::PMOP::precomp = 37
984 B::PMOP::reflags = 38
985 B::PADOP::sv = 39
986 B::PADOP::gv = 40
987 B::PVOP::pv = 41
988 B::COP::label = 42
989 B::COP::arybase = 43
990 B::COP::warnings = 44
991 B::COP::io = 45
992 B::COP::hints_hash = 46
9b1961be
NC
993 PREINIT:
994 char *ptr;
086f9b42 995 SV *ret;
bec746fe
DM
996 I32 type;
997 I32 offset;
998 STRLEN len;
086f9b42 999 PPCODE:
287ce0d8
DM
1000 if (ix < 0 || ix > 46)
1001 croak("Illegal alias %d for B::*OP::next", (int)ix);
71324a3b
DM
1002 ret = get_overlay_object(aTHX_ o,
1003 op_methods[ix].name, op_methods[ix].namelen);
1004 if (ret) {
1005 ST(0) = ret;
1006 XSRETURN(1);
1007 }
bec746fe
DM
1008
1009 /* handle non-direct field access */
1010
71324a3b 1011 offset = op_methods[ix].offset;
bec746fe
DM
1012 if (offset < 0) {
1013 switch (ix) {
1014#ifdef USE_ITHREADS
1015 case 21: /* filegv */
1016 ret = make_sv_object(aTHX_ (SV *)CopFILEGV((COP*)o));
1017 break;
1018#endif
1019#ifndef USE_ITHREADS
1020 case 22: /* file */
1021 ret = sv_2mortal(newSVpv(CopFILE((COP*)o), 0));
1022 break;
1023#endif
1024#ifdef USE_ITHREADS
1025 case 23: /* stash */
1026 ret = make_sv_object(aTHX_ (SV *)CopSTASH((COP*)o));
1027 break;
1028#endif
1029#if PERL_VERSION >= 17 || !defined USE_ITHREADS
1030 case 24: /* stashpv */
1031# if PERL_VERSION >= 17
1032 ret = sv_2mortal(CopSTASH((COP*)o)
1033 && SvTYPE(CopSTASH((COP*)o)) == SVt_PVHV
1034 ? newSVhek(HvNAME_HEK(CopSTASH((COP*)o)))
1035 : &PL_sv_undef);
1036# else
1037 ret = sv_2mortal(newSVpv(CopSTASHPV((COP*)o), 0));
1038# endif
1039 break;
1040#endif
287ce0d8
DM
1041 case 26: /* size */
1042 ret = sv_2mortal(newSVuv((UV)(opsizes[cc_opclass(aTHX_ o)])));
1043 break;
1044 case 27: /* name */
1045 case 28: /* desc */
1046 ret = sv_2mortal(newSVpv(
1047 (char *)(ix == 28 ? OP_DESC(o) : OP_NAME(o)), 0));
1048 break;
1049 case 29: /* ppaddr */
1050 {
1051 int i;
1052 ret = sv_2mortal(Perl_newSVpvf(aTHX_ "PL_ppaddr[OP_%s]",
1053 PL_op_name[o->op_type]));
1054 for (i=13; (STRLEN)i < SvCUR(ret); ++i)
1055 SvPVX(ret)[i] = toUPPER(SvPVX(ret)[i]);
1056 }
1057 break;
1058 case 30: /* type */
1059 case 31: /* opt */
1060 case 32: /* spare */
1061 /* These 3 are all bitfields, so we can't take their addresses */
1062 ret = sv_2mortal(newSVuv((UV)(
1063 ix == 30 ? o->op_type
1064 : ix == 31 ? o->op_opt
1065 : o->op_spare)));
1066 break;
1067 case 33: /* children */
1068 {
1069 OP *kid;
1070 UV i = 0;
1071 for (kid = ((LISTOP*)o)->op_first; kid; kid = kid->op_sibling)
1072 i++;
1073 ret = sv_2mortal(newSVuv(i));
1074 }
1075 break;
1076 case 34: /* pmreplroot */
1077 if (cPMOPo->op_type == OP_PUSHRE) {
1078#ifdef USE_ITHREADS
1079 ret = sv_newmortal();
1080 sv_setiv(ret, cPMOPo->op_pmreplrootu.op_pmtargetoff);
1081#else
1082 GV *const target = cPMOPo->op_pmreplrootu.op_pmtargetgv;
1083 ret = sv_newmortal();
1084 sv_setiv(newSVrv(ret, target ?
1085 svclassnames[SvTYPE((SV*)target)] : "B::SV"),
1086 PTR2IV(target));
1087#endif
1088 }
1089 else {
1090 OP *const root = cPMOPo->op_pmreplrootu.op_pmreplroot;
1091 ret = make_op_object(aTHX_ root);
1092 }
1093 break;
1094#ifdef USE_ITHREADS
1095 case 35: /* pmstashpv */
1096 ret = sv_2mortal(newSVpv(PmopSTASHPV(cPMOPo),0));
1097 break;
1098#else
1099 case 36: /* pmstash */
1100 ret = make_sv_object(aTHX_ (SV *) PmopSTASH(cPMOPo));
1101 break;
1102#endif
1103 case 37: /* precomp */
1104 case 38: /* reflags */
1105 {
1106 REGEXP *rx = PM_GETRE(cPMOPo);
1107 ret = sv_newmortal();
1108 if (rx) {
1109 if (ix==38) {
1110 sv_setuv(ret, RX_EXTFLAGS(rx));
1111 }
1112 else {
1113 sv_setpvn(ret, RX_PRECOMP(rx), RX_PRELEN(rx));
1114 }
1115 }
1116 }
1117 break;
1118 case 39: /* sv */
1119 case 40: /* gv */
1120 /* It happens that the output typemaps for B::SV and B::GV
1121 * are identical. The "smarts" are in make_sv_object(),
1122 * which determines which class to use based on SvTYPE(),
1123 * rather than anything baked in at compile time. */
1124 if (cPADOPo->op_padix) {
1125 ret = PAD_SVl(cPADOPo->op_padix);
1126 if (ix == 40 && SvTYPE(ret) != SVt_PVGV)
1127 ret = NULL;
1128 } else {
1129 ret = NULL;
1130 }
1131 ret = make_sv_object(aTHX_ ret);
1132 break;
1133 case 41: /* pv */
1134 /* OP_TRANS uses op_pv to point to a table of 256 or >=258
1135 * shorts whereas other PVOPs point to a null terminated
1136 * string. */
1137 if ( (cPVOPo->op_type == OP_TRANS
1138 || cPVOPo->op_type == OP_TRANSR) &&
1139 (cPVOPo->op_private & OPpTRANS_COMPLEMENT) &&
1140 !(cPVOPo->op_private & OPpTRANS_DELETE))
1141 {
1142 const short* const tbl = (short*)cPVOPo->op_pv;
1143 const short entries = 257 + tbl[256];
1144 ret = newSVpvn_flags(cPVOPo->op_pv, entries * sizeof(short), SVs_TEMP);
1145 }
1146 else if (cPVOPo->op_type == OP_TRANS || cPVOPo->op_type == OP_TRANSR) {
1147 ret = newSVpvn_flags(cPVOPo->op_pv, 256 * sizeof(short), SVs_TEMP);
1148 }
1149 else
1150 ret = newSVpvn_flags(cPVOPo->op_pv, strlen(cPVOPo->op_pv), SVs_TEMP);
1151 break;
1152 case 42: /* label */
1153 ret = sv_2mortal(newSVpv(CopLABEL(cCOPo),0));
1154 break;
1155 case 43: /* arybase */
1156 ret = sv_2mortal(newSVuv(0));
1157 break;
1158 case 44: /* warnings */
1159 ret = make_warnings_object(aTHX_ cCOPo);
1160 break;
1161 case 45: /* io */
1162 ret = make_cop_io_object(aTHX_ cCOPo);
1163 break;
1164 case 46: /* hints_hash */
1165 ret = sv_newmortal();
1166 sv_setiv(newSVrv(ret, "B::RHE"),
1167 PTR2IV(CopHINTHASH_get(cCOPo)));
1168 break;
bec746fe
DM
1169 default:
1170 croak("method %s not implemented", op_methods[ix].name);
1171 }
1172 ST(0) = ret;
1173 XSRETURN(1);
1174 }
1175
1176 /* do a direct structure offset lookup */
1177
1178 ptr = (char *)o + offset;
1179 type = op_methods[ix].type;
1180 switch ((U8)(type >> 16)) {
1181 case (U8)(OPp >> 16):
6079961f
NC
1182 ret = make_op_object(aTHX_ *((OP **)ptr));
1183 break;
bec746fe 1184 case (U8)(PADOFFSETp >> 16):
086f9b42
NC
1185 ret = sv_2mortal(newSVuv(*((PADOFFSET*)ptr)));
1186 break;
1187 case (U8)(U8p >> 16):
1188 ret = sv_2mortal(newSVuv(*((U8*)ptr)));
1189 break;
a78b89ef
NC
1190 case (U8)(U32p >> 16):
1191 ret = sv_2mortal(newSVuv(*((U32*)ptr)));
1192 break;
ba7298e3 1193 case (U8)(SVp >> 16):
0c74f67f 1194 ret = make_sv_object(aTHX_ *((SV **)ptr));
ba7298e3 1195 break;
39e120c1
NC
1196 case (U8)(line_tp >> 16):
1197 ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
1198 break;
657e3fc2
NC
1199 case (U8)(IVp >> 16):
1200 ret = sv_2mortal(newSViv(*((IV*)ptr)));
1201 break;
a9ed1a44
NC
1202 case (U8)(char_pp >> 16):
1203 ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
1204 break;
c33e8be1 1205 default:
287ce0d8
DM
1206 croak("Illegal type 0x%08x for B::*OP::%s",
1207 (unsigned)type, op_methods[ix].name);
c33e8be1 1208
086f9b42
NC
1209 }
1210 ST(0) = ret;
1211 XSRETURN(1);
a8a597b2 1212
7252851f 1213
1df34986 1214void
fdbacc68 1215oplist(o)
1df34986
AE
1216 B::OP o
1217 PPCODE:
1218 SP = oplist(aTHX_ o, SP);
1219
e412117e 1220
651aa52e
AE
1221MODULE = B PACKAGE = B::SV
1222
de64752d
NC
1223#define MAGICAL_FLAG_BITS (SVs_GMG|SVs_SMG|SVs_RMG)
1224
651aa52e 1225U32
de64752d 1226REFCNT(sv)
651aa52e 1227 B::SV sv
de64752d
NC
1228 ALIAS:
1229 FLAGS = 0xFFFFFFFF
1230 SvTYPE = SVTYPEMASK
1231 POK = SVf_POK
1232 ROK = SVf_ROK
1233 MAGICAL = MAGICAL_FLAG_BITS
1234 CODE:
1235 RETVAL = ix ? (SvFLAGS(sv) & (U32)ix) : SvREFCNT(sv);
1236 OUTPUT:
1237 RETVAL
651aa52e 1238
9efba5c8 1239void
429a5ce7
SM
1240object_2svref(sv)
1241 B::SV sv
9efba5c8
NC
1242 PPCODE:
1243 ST(0) = sv_2mortal(newRV(sv));
1244 XSRETURN(1);
1245
a8a597b2
MB
1246MODULE = B PACKAGE = B::IV PREFIX = Sv
1247
1248IV
1249SvIV(sv)
1250 B::IV sv
1251
e4da9d6a 1252MODULE = B PACKAGE = B::IV
a8a597b2 1253
e4da9d6a
NC
1254#define sv_SVp 0x00000
1255#define sv_IVp 0x10000
1256#define sv_UVp 0x20000
1257#define sv_STRLENp 0x30000
1258#define sv_U32p 0x40000
1259#define sv_U8p 0x50000
1260#define sv_char_pp 0x60000
1261#define sv_NVp 0x70000
6782c6e0 1262#define sv_char_p 0x80000
3da43c35 1263#define sv_SSize_tp 0x90000
ffc5d9fc
NC
1264#define sv_I32p 0xA0000
1265#define sv_U16p 0xB0000
e4da9d6a
NC
1266
1267#define IV_ivx_ix sv_IVp | offsetof(struct xpviv, xiv_iv)
1268#define IV_uvx_ix sv_UVp | offsetof(struct xpvuv, xuv_uv)
1269#define NV_nvx_ix sv_NVp | offsetof(struct xpvnv, xnv_u.xnv_nv)
1270
e4da9d6a
NC
1271#define NV_cop_seq_range_low_ix \
1272 sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
1273#define NV_cop_seq_range_high_ix \
1274 sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
1275#define NV_parent_pad_index_ix \
1276 sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
1277#define NV_parent_fakelex_flags_ix \
1278 sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
0ca04487 1279
6782c6e0
NC
1280#define PV_cur_ix sv_STRLENp | offsetof(struct xpv, xpv_cur)
1281#define PV_len_ix sv_STRLENp | offsetof(struct xpv, xpv_len)
1282
1283#define PVMG_stash_ix sv_SVp | offsetof(struct xpvmg, xmg_stash)
1284
35633035 1285#if PERL_VERSION > 14
ced45495
NC
1286# define PVBM_useful_ix sv_I32p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_useful)
1287# define PVBM_previous_ix sv_UVp | offsetof(struct xpvuv, xuv_uv)
35633035 1288#else
91a71e08
NC
1289#define PVBM_useful_ix sv_I32p | offsetof(struct xpvgv, xiv_u.xivu_i32)
1290#define PVBM_previous_ix sv_U32p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_previous)
91a71e08
NC
1291#endif
1292
35633035
DM
1293#define PVBM_rare_ix sv_U8p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_rare)
1294
6782c6e0
NC
1295#define PVLV_targoff_ix sv_U32p | offsetof(struct xpvlv, xlv_targoff)
1296#define PVLV_targlen_ix sv_U32p | offsetof(struct xpvlv, xlv_targlen)
1297#define PVLV_targ_ix sv_SVp | offsetof(struct xpvlv, xlv_targ)
1298#define PVLV_type_ix sv_char_p | offsetof(struct xpvlv, xlv_type)
1299
f1f19364
NC
1300#define PVGV_stash_ix sv_SVp | offsetof(struct xpvgv, xnv_u.xgv_stash)
1301#define PVGV_flags_ix sv_STRLENp | offsetof(struct xpvgv, xpv_cur)
55440d31 1302#define PVIO_lines_ix sv_IVp | offsetof(struct xpvio, xiv_iv)
f1f19364 1303
55440d31
NC
1304#define PVIO_page_ix sv_IVp | offsetof(struct xpvio, xio_page)
1305#define PVIO_page_len_ix sv_IVp | offsetof(struct xpvio, xio_page_len)
1306#define PVIO_lines_left_ix sv_IVp | offsetof(struct xpvio, xio_lines_left)
1307#define PVIO_top_name_ix sv_char_pp | offsetof(struct xpvio, xio_top_name)
1308#define PVIO_top_gv_ix sv_SVp | offsetof(struct xpvio, xio_top_gv)
1309#define PVIO_fmt_name_ix sv_char_pp | offsetof(struct xpvio, xio_fmt_name)
1310#define PVIO_fmt_gv_ix sv_SVp | offsetof(struct xpvio, xio_fmt_gv)
1311#define PVIO_bottom_name_ix sv_char_pp | offsetof(struct xpvio, xio_bottom_name)
1312#define PVIO_bottom_gv_ix sv_SVp | offsetof(struct xpvio, xio_bottom_gv)
1313#define PVIO_type_ix sv_char_p | offsetof(struct xpvio, xio_type)
1314#define PVIO_flags_ix sv_U8p | offsetof(struct xpvio, xio_flags)
1315
3da43c35
NC
1316#define PVAV_max_ix sv_SSize_tp | offsetof(struct xpvav, xav_max)
1317
ffc5d9fc 1318#define PVCV_stash_ix sv_SVp | offsetof(struct xpvcv, xcv_stash)
b290562e
FC
1319#if PERL_VERSION > 17 || (PERL_VERSION == 17 && PERL_SUBVERSION >= 3)
1320# define PVCV_gv_ix sv_SVp | offsetof(struct xpvcv, xcv_gv_u.xcv_gv)
1321#else
1322# define PVCV_gv_ix sv_SVp | offsetof(struct xpvcv, xcv_gv)
1323#endif
ffc5d9fc 1324#define PVCV_file_ix sv_char_pp | offsetof(struct xpvcv, xcv_file)
ffc5d9fc
NC
1325#define PVCV_outside_ix sv_SVp | offsetof(struct xpvcv, xcv_outside)
1326#define PVCV_outside_seq_ix sv_U32p | offsetof(struct xpvcv, xcv_outside_seq)
1327#define PVCV_flags_ix sv_U16p | offsetof(struct xpvcv, xcv_flags)
1328
d65a2b0a
NC
1329#define PVHV_max_ix sv_STRLENp | offsetof(struct xpvhv, xhv_max)
1330
1331#if PERL_VERSION > 12
1332#define PVHV_keys_ix sv_STRLENp | offsetof(struct xpvhv, xhv_keys)
1333#else
1334#define PVHV_keys_ix sv_IVp | offsetof(struct xpvhv, xhv_keys)
1335#endif
1336
e4da9d6a
NC
1337# The type checking code in B has always been identical for all SV types,
1338# irrespective of whether the action is actually defined on that SV.
1339# We should fix this
1340void
1341IVX(sv)
1342 B::SV sv
1343 ALIAS:
1344 B::IV::IVX = IV_ivx_ix
1345 B::IV::UVX = IV_uvx_ix
1346 B::NV::NVX = NV_nvx_ix
1347 B::NV::COP_SEQ_RANGE_LOW = NV_cop_seq_range_low_ix
1348 B::NV::COP_SEQ_RANGE_HIGH = NV_cop_seq_range_high_ix
1349 B::NV::PARENT_PAD_INDEX = NV_parent_pad_index_ix
1350 B::NV::PARENT_FAKELEX_FLAGS = NV_parent_fakelex_flags_ix
6782c6e0
NC
1351 B::PV::CUR = PV_cur_ix
1352 B::PV::LEN = PV_len_ix
1353 B::PVMG::SvSTASH = PVMG_stash_ix
1354 B::PVLV::TARGOFF = PVLV_targoff_ix
1355 B::PVLV::TARGLEN = PVLV_targlen_ix
1356 B::PVLV::TARG = PVLV_targ_ix
1357 B::PVLV::TYPE = PVLV_type_ix
f1f19364
NC
1358 B::GV::STASH = PVGV_stash_ix
1359 B::GV::GvFLAGS = PVGV_flags_ix
91a71e08
NC
1360 B::BM::USEFUL = PVBM_useful_ix
1361 B::BM::PREVIOUS = PVBM_previous_ix
1362 B::BM::RARE = PVBM_rare_ix
55440d31
NC
1363 B::IO::LINES = PVIO_lines_ix
1364 B::IO::PAGE = PVIO_page_ix
1365 B::IO::PAGE_LEN = PVIO_page_len_ix
1366 B::IO::LINES_LEFT = PVIO_lines_left_ix
1367 B::IO::TOP_NAME = PVIO_top_name_ix
1368 B::IO::TOP_GV = PVIO_top_gv_ix
1369 B::IO::FMT_NAME = PVIO_fmt_name_ix
1370 B::IO::FMT_GV = PVIO_fmt_gv_ix
1371 B::IO::BOTTOM_NAME = PVIO_bottom_name_ix
1372 B::IO::BOTTOM_GV = PVIO_bottom_gv_ix
1373 B::IO::IoTYPE = PVIO_type_ix
1374 B::IO::IoFLAGS = PVIO_flags_ix
3da43c35 1375 B::AV::MAX = PVAV_max_ix
ffc5d9fc
NC
1376 B::CV::STASH = PVCV_stash_ix
1377 B::CV::GV = PVCV_gv_ix
1378 B::CV::FILE = PVCV_file_ix
ffc5d9fc
NC
1379 B::CV::OUTSIDE = PVCV_outside_ix
1380 B::CV::OUTSIDE_SEQ = PVCV_outside_seq_ix
1381 B::CV::CvFLAGS = PVCV_flags_ix
d65a2b0a
NC
1382 B::HV::MAX = PVHV_max_ix
1383 B::HV::KEYS = PVHV_keys_ix
e4da9d6a
NC
1384 PREINIT:
1385 char *ptr;
1386 SV *ret;
1387 PPCODE:
1388 ptr = (ix & 0xFFFF) + (char *)SvANY(sv);
1389 switch ((U8)(ix >> 16)) {
1390 case (U8)(sv_SVp >> 16):
0c74f67f 1391 ret = make_sv_object(aTHX_ *((SV **)ptr));
e4da9d6a
NC
1392 break;
1393 case (U8)(sv_IVp >> 16):
1394 ret = sv_2mortal(newSViv(*((IV *)ptr)));
1395 break;
1396 case (U8)(sv_UVp >> 16):
1397 ret = sv_2mortal(newSVuv(*((UV *)ptr)));
1398 break;
6782c6e0
NC
1399 case (U8)(sv_STRLENp >> 16):
1400 ret = sv_2mortal(newSVuv(*((STRLEN *)ptr)));
1401 break;
e4da9d6a
NC
1402 case (U8)(sv_U32p >> 16):
1403 ret = sv_2mortal(newSVuv(*((U32 *)ptr)));
1404 break;
1405 case (U8)(sv_U8p >> 16):
1406 ret = sv_2mortal(newSVuv(*((U8 *)ptr)));
1407 break;
1408 case (U8)(sv_char_pp >> 16):
1409 ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
1410 break;
1411 case (U8)(sv_NVp >> 16):
1412 ret = sv_2mortal(newSVnv(*((NV *)ptr)));
1413 break;
6782c6e0
NC
1414 case (U8)(sv_char_p >> 16):
1415 ret = newSVpvn_flags((char *)ptr, 1, SVs_TEMP);
1416 break;
3da43c35
NC
1417 case (U8)(sv_SSize_tp >> 16):
1418 ret = sv_2mortal(newSViv(*((SSize_t *)ptr)));
1419 break;
ffc5d9fc
NC
1420 case (U8)(sv_I32p >> 16):
1421 ret = sv_2mortal(newSVuv(*((I32 *)ptr)));
1422 break;
1423 case (U8)(sv_U16p >> 16):
1424 ret = sv_2mortal(newSVuv(*((U16 *)ptr)));
1425 break;
c33e8be1
Z
1426 default:
1427 croak("Illegal alias 0x%08x for B::*IVX", (unsigned)ix);
e4da9d6a
NC
1428 }
1429 ST(0) = ret;
1430 XSRETURN(1);
a8a597b2 1431
a8a597b2
MB
1432void
1433packiv(sv)
1434 B::IV sv
6829f5e2
NC
1435 ALIAS:
1436 needs64bits = 1
a8a597b2 1437 CODE:
6829f5e2
NC
1438 if (ix) {
1439 ST(0) = boolSV((I32)SvIVX(sv) != SvIVX(sv));
1440 } else if (sizeof(IV) == 8) {
a8a597b2 1441 U32 wp[2];
5d7488b2 1442 const IV iv = SvIVX(sv);
a8a597b2
MB
1443 /*
1444 * The following way of spelling 32 is to stop compilers on
1445 * 32-bit architectures from moaning about the shift count
1446 * being >= the width of the type. Such architectures don't
1447 * reach this code anyway (unless sizeof(IV) > 8 but then
1448 * everything else breaks too so I'm not fussed at the moment).
1449 */
42718184
RB
1450#ifdef UV_IS_QUAD
1451 wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1452#else
1453 wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1454#endif
a8a597b2 1455 wp[1] = htonl(iv & 0xffffffff);
d3d34884 1456 ST(0) = newSVpvn_flags((char *)wp, 8, SVs_TEMP);
a8a597b2
MB
1457 } else {
1458 U32 w = htonl((U32)SvIVX(sv));
d3d34884 1459 ST(0) = newSVpvn_flags((char *)&w, 4, SVs_TEMP);
a8a597b2
MB
1460 }
1461
1462MODULE = B PACKAGE = B::NV PREFIX = Sv
1463
76ef7183 1464NV
a8a597b2
MB
1465SvNV(sv)
1466 B::NV sv
1467
4df7f6af
NC
1468#if PERL_VERSION < 11
1469
a8a597b2
MB
1470MODULE = B PACKAGE = B::RV PREFIX = Sv
1471
8ae5a962 1472void
a8a597b2
MB
1473SvRV(sv)
1474 B::RV sv
8ae5a962 1475 PPCODE:
0c74f67f 1476 PUSHs(make_sv_object(aTHX_ SvRV(sv)));
a8a597b2 1477
89c6bc13
NC
1478#else
1479
1480MODULE = B PACKAGE = B::REGEXP
1481
154b8842 1482void
81e413dd 1483REGEX(sv)
89c6bc13 1484 B::REGEXP sv
81e413dd
NC
1485 ALIAS:
1486 precomp = 1
154b8842 1487 PPCODE:
81e413dd
NC
1488 if (ix) {
1489 PUSHs(newSVpvn_flags(RX_PRECOMP(sv), RX_PRELEN(sv), SVs_TEMP));
1490 } else {
1491 dXSTARG;
1492 /* FIXME - can we code this method more efficiently? */
1493 PUSHi(PTR2IV(sv));
1494 }
89c6bc13 1495
4df7f6af
NC
1496#endif
1497
fdbacc68 1498MODULE = B PACKAGE = B::PV
a8a597b2 1499
8ae5a962 1500void
fdbacc68 1501RV(sv)
b326da91 1502 B::PV sv
8ae5a962
NC
1503 PPCODE:
1504 if (!SvROK(sv))
b326da91 1505 croak( "argument is not SvROK" );
0c74f67f 1506 PUSHs(make_sv_object(aTHX_ SvRV(sv)));
b326da91 1507
a8a597b2 1508void
fdbacc68 1509PV(sv)
a8a597b2 1510 B::PV sv
3d665704
NC
1511 ALIAS:
1512 PVX = 1
f4c36584 1513 PVBM = 2
84fea184 1514 B::BM::TABLE = 3
a804b0fe
NC
1515 PREINIT:
1516 const char *p;
1517 STRLEN len = 0;
1518 U32 utf8 = 0;
a8a597b2 1519 CODE:
84fea184 1520 if (ix == 3) {
2bda37ba
NC
1521#ifndef PERL_FBM_TABLE_OFFSET
1522 const MAGIC *const mg = mg_find(sv, PERL_MAGIC_bm);
1523
1524 if (!mg)
1525 croak("argument to B::BM::TABLE is not a PVBM");
1526 p = mg->mg_ptr;
1527 len = mg->mg_len;
1528#else
84fea184
NC
1529 p = SvPV(sv, len);
1530 /* Boyer-Moore table is just after string and its safety-margin \0 */
1531 p += len + PERL_FBM_TABLE_OFFSET;
1532 len = 256;
2bda37ba 1533#endif
84fea184 1534 } else if (ix == 2) {
f4c36584 1535 /* This used to read 257. I think that that was buggy - should have
26ec7981
NC
1536 been 258. (The "\0", the flags byte, and 256 for the table.)
1537 The only user of this method is B::Bytecode in B::PV::bsave.
1538 I'm guessing that nothing tested the runtime correctness of
1539 output of bytecompiled string constant arguments to index (etc).
1540
1541 Note the start pointer is and has always been SvPVX(sv), not
1542 SvPVX(sv) + SvCUR(sv) PVBM was added in 651aa52ea1faa806, and
1543 first used by the compiler in 651aa52ea1faa806. It's used to
1544 get a "complete" dump of the buffer at SvPVX(), not just the
1545 PVBM table. This permits the generated bytecode to "load"
2bda37ba
NC
1546 SvPVX in "one" hit.
1547
1548 5.15 and later store the BM table via MAGIC, so the compiler
1549 should handle this just fine without changes if PVBM now
1550 always returns the SvPVX() buffer. */
8d919b0a
FC
1551#ifdef isREGEXP
1552 p = isREGEXP(sv)
1553 ? RX_WRAPPED_const((REGEXP*)sv)
1554 : SvPVX_const(sv);
1555#else
f4c36584 1556 p = SvPVX_const(sv);
8d919b0a 1557#endif
2bda37ba 1558#ifdef PERL_FBM_TABLE_OFFSET
f4c36584 1559 len = SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0);
2bda37ba
NC
1560#else
1561 len = SvCUR(sv);
1562#endif
f4c36584 1563 } else if (ix) {
8d919b0a
FC
1564#ifdef isREGEXP
1565 p = isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX(sv);
1566#else
3d665704 1567 p = SvPVX(sv);
8d919b0a 1568#endif
3d665704
NC
1569 len = strlen(p);
1570 } else if (SvPOK(sv)) {
a804b0fe
NC
1571 len = SvCUR(sv);
1572 p = SvPVX_const(sv);
1573 utf8 = SvUTF8(sv);
b326da91 1574 }
8d919b0a
FC
1575#ifdef isREGEXP
1576 else if (isREGEXP(sv)) {
1577 len = SvCUR(sv);
1578 p = RX_WRAPPED_const((REGEXP*)sv);
1579 utf8 = SvUTF8(sv);
1580 }
1581#endif
b326da91
MB
1582 else {
1583 /* XXX for backward compatibility, but should fail */
1584 /* croak( "argument is not SvPOK" ); */
a804b0fe 1585 p = NULL;
b326da91 1586 }
a804b0fe 1587 ST(0) = newSVpvn_flags(p, len, SVs_TEMP | utf8);
a8a597b2 1588
fdbacc68 1589MODULE = B PACKAGE = B::PVMG
a8a597b2
MB
1590
1591void
fdbacc68 1592MAGIC(sv)
a8a597b2
MB
1593 B::PVMG sv
1594 MAGIC * mg = NO_INIT
1595 PPCODE:
1596 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
9496d2e5 1597 XPUSHs(make_mg_object(aTHX_ mg));
a8a597b2 1598
b2adfa9b 1599MODULE = B PACKAGE = B::MAGIC
a8a597b2
MB
1600
1601void
b2adfa9b 1602MOREMAGIC(mg)
a8a597b2 1603 B::MAGIC mg
b2adfa9b
NC
1604 ALIAS:
1605 PRIVATE = 1
1606 TYPE = 2
1607 FLAGS = 3
fb6620c6 1608 LENGTH = 4
b2adfa9b
NC
1609 OBJ = 5
1610 PTR = 6
1611 REGEX = 7
1612 precomp = 8
1613 PPCODE:
1614 switch (ix) {
1615 case 0:
1616 XPUSHs(mg->mg_moremagic ? make_mg_object(aTHX_ mg->mg_moremagic)
1617 : &PL_sv_undef);
1618 break;
1619 case 1:
1620 mPUSHu(mg->mg_private);
1621 break;
1622 case 2:
1623 PUSHs(newSVpvn_flags(&(mg->mg_type), 1, SVs_TEMP));
1624 break;
1625 case 3:
1626 mPUSHu(mg->mg_flags);
1627 break;
1628 case 4:
1629 mPUSHi(mg->mg_len);
1630 break;
1631 case 5:
0c74f67f 1632 PUSHs(make_sv_object(aTHX_ mg->mg_obj));
b2adfa9b
NC
1633 break;
1634 case 6:
1635 if (mg->mg_ptr) {
1636 if (mg->mg_len >= 0) {
1637 PUSHs(newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP));
651aa52e 1638 } else if (mg->mg_len == HEf_SVKEY) {
0c74f67f 1639 PUSHs(make_sv_object(aTHX_ (SV*)mg->mg_ptr));
fdbd1d64 1640 } else
b2adfa9b
NC
1641 PUSHs(sv_newmortal());
1642 } else
1643 PUSHs(sv_newmortal());
1644 break;
1645 case 7:
1646 if(mg->mg_type == PERL_MAGIC_qr) {
1647 mPUSHi(PTR2IV(mg->mg_obj));
1648 } else {
1649 croak("REGEX is only meaningful on r-magic");
1650 }
1651 break;
1652 case 8:
1653 if (mg->mg_type == PERL_MAGIC_qr) {
1654 REGEXP *rx = (REGEXP *)mg->mg_obj;
227aaa42
NC
1655 PUSHs(newSVpvn_flags(rx ? RX_PRECOMP(rx) : NULL,
1656 rx ? RX_PRELEN(rx) : 0, SVs_TEMP));
b2adfa9b
NC
1657 } else {
1658 croak( "precomp is only meaningful on r-magic" );
1659 }
1660 break;
1661 }
a8a597b2 1662
a8a597b2
MB
1663MODULE = B PACKAGE = B::GV PREFIX = Gv
1664
1665void
1666GvNAME(gv)
1667 B::GV gv
cbf9c13f
NC
1668 ALIAS:
1669 FILE = 1
435e8dd0 1670 B::HV::NAME = 2
a8a597b2 1671 CODE:
435e8dd0
NC
1672 ST(0) = sv_2mortal(newSVhek(!ix ? GvNAME_HEK(gv)
1673 : (ix == 1 ? GvFILE_HEK(gv)
1674 : HvNAME_HEK((HV *)gv))));
a8a597b2 1675
87d7fd28
GS
1676bool
1677is_empty(gv)
1678 B::GV gv
711fbbf0
NC
1679 ALIAS:
1680 isGV_with_GP = 1
87d7fd28 1681 CODE:
711fbbf0 1682 if (ix) {
711fbbf0 1683 RETVAL = isGV_with_GP(gv) ? TRUE : FALSE;
711fbbf0
NC
1684 } else {
1685 RETVAL = GvGP(gv) == Null(GP*);
1686 }
50786ba8 1687 OUTPUT:
711fbbf0 1688 RETVAL
50786ba8 1689
651aa52e
AE
1690void*
1691GvGP(gv)
1692 B::GV gv
1693
257e0650
NC
1694#define GP_sv_ix SVp | offsetof(struct gp, gp_sv)
1695#define GP_io_ix SVp | offsetof(struct gp, gp_io)
1696#define GP_cv_ix SVp | offsetof(struct gp, gp_cv)
1697#define GP_cvgen_ix U32p | offsetof(struct gp, gp_cvgen)
1698#define GP_refcnt_ix U32p | offsetof(struct gp, gp_refcnt)
1699#define GP_hv_ix SVp | offsetof(struct gp, gp_hv)
1700#define GP_av_ix SVp | offsetof(struct gp, gp_av)
1701#define GP_form_ix SVp | offsetof(struct gp, gp_form)
1702#define GP_egv_ix SVp | offsetof(struct gp, gp_egv)
1703#define GP_line_ix line_tp | offsetof(struct gp, gp_line)
a8a597b2 1704
257e0650
NC
1705void
1706SV(gv)
a8a597b2 1707 B::GV gv
257e0650
NC
1708 ALIAS:
1709 SV = GP_sv_ix
1710 IO = GP_io_ix
1711 CV = GP_cv_ix
1712 CVGEN = GP_cvgen_ix
1713 GvREFCNT = GP_refcnt_ix
1714 HV = GP_hv_ix
1715 AV = GP_av_ix
1716 FORM = GP_form_ix
1717 EGV = GP_egv_ix
1718 LINE = GP_line_ix
1719 PREINIT:
1720 GP *gp;
1721 char *ptr;
1722 SV *ret;
1723 PPCODE:
1724 gp = GvGP(gv);
1725 if (!gp) {
1726 const GV *const gv = CvGV(cv);
46c3f339 1727 Perl_croak(aTHX_ "NULL gp in B::GV::%s", gv ? GvNAME(gv) : "???");
257e0650
NC
1728 }
1729 ptr = (ix & 0xFFFF) + (char *)gp;
1730 switch ((U8)(ix >> 16)) {
1731 case (U8)(SVp >> 16):
0c74f67f 1732 ret = make_sv_object(aTHX_ *((SV **)ptr));
257e0650
NC
1733 break;
1734 case (U8)(U32p >> 16):
1735 ret = sv_2mortal(newSVuv(*((U32*)ptr)));
1736 break;
1737 case (U8)(line_tp >> 16):
1738 ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
1739 break;
c33e8be1
Z
1740 default:
1741 croak("Illegal alias 0x%08x for B::*SV", (unsigned)ix);
257e0650
NC
1742 }
1743 ST(0) = ret;
1744 XSRETURN(1);
a8a597b2 1745
8ae5a962
NC
1746void
1747FILEGV(gv)
a8a597b2 1748 B::GV gv
8ae5a962 1749 PPCODE:
0c74f67f 1750 PUSHs(make_sv_object(aTHX_ (SV *)GvFILEGV(gv)));
a8a597b2 1751
a8a597b2
MB
1752MODULE = B PACKAGE = B::IO PREFIX = Io
1753
04071355 1754
b326da91
MB
1755bool
1756IsSTD(io,name)
1757 B::IO io
5d7488b2 1758 const char* name
b326da91
MB
1759 PREINIT:
1760 PerlIO* handle = 0;
1761 CODE:
1762 if( strEQ( name, "stdin" ) ) {
1763 handle = PerlIO_stdin();
1764 }
1765 else if( strEQ( name, "stdout" ) ) {
1766 handle = PerlIO_stdout();
1767 }
1768 else if( strEQ( name, "stderr" ) ) {
1769 handle = PerlIO_stderr();
1770 }
1771 else {
1772 croak( "Invalid value '%s'", name );
1773 }
1774 RETVAL = handle == IoIFP(io);
1775 OUTPUT:
1776 RETVAL
1777
a8a597b2
MB
1778MODULE = B PACKAGE = B::AV PREFIX = Av
1779
1780SSize_t
1781AvFILL(av)
1782 B::AV av
1783
a8a597b2
MB
1784void
1785AvARRAY(av)
1786 B::AV av
1787 PPCODE:
1788 if (AvFILL(av) >= 0) {
1789 SV **svp = AvARRAY(av);
1790 I32 i;
1791 for (i = 0; i <= AvFILL(av); i++)
0c74f67f 1792 XPUSHs(make_sv_object(aTHX_ svp[i]));
a8a597b2
MB
1793 }
1794
429a5ce7
SM
1795void
1796AvARRAYelt(av, idx)
1797 B::AV av
1798 int idx
1799 PPCODE:
1800 if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
0c74f67f 1801 XPUSHs(make_sv_object(aTHX_ (AvARRAY(av)[idx])));
429a5ce7 1802 else
0c74f67f 1803 XPUSHs(make_sv_object(aTHX_ NULL));
429a5ce7 1804
edcc7c74 1805
f2da823f
FC
1806MODULE = B PACKAGE = B::FM PREFIX = Fm
1807
35633035
DM
1808#undef FmLINES
1809#define FmLINES(sv) 0
f2da823f
FC
1810
1811IV
1812FmLINES(form)
1813 B::FM form
1814
a8a597b2
MB
1815MODULE = B PACKAGE = B::CV PREFIX = Cv
1816
651aa52e
AE
1817U32
1818CvCONST(cv)
1819 B::CV cv
1820
6079961f 1821void
a8a597b2
MB
1822CvSTART(cv)
1823 B::CV cv
a0da4400
NC
1824 ALIAS:
1825 ROOT = 1
6079961f
NC
1826 PPCODE:
1827 PUSHs(make_op_object(aTHX_ CvISXSUB(cv) ? NULL
1828 : ix ? CvROOT(cv) : CvSTART(cv)));
a8a597b2 1829
bb02a38f
FC
1830I32
1831CvDEPTH(cv)
1832 B::CV cv
1833
86d2498c 1834#ifdef PadlistARRAY
7261499d
FC
1835
1836B::PADLIST
1837CvPADLIST(cv)
1838 B::CV cv
1839
1840#else
1841
1842B::AV
1843CvPADLIST(cv)
1844 B::CV cv
82aeefe1
DM
1845 PPCODE:
1846 PUSHs(make_sv_object(aTHX_ (SV *)CvPADLIST(cv)));
1847
7261499d
FC
1848
1849#endif
1850
a8a597b2
MB
1851void
1852CvXSUB(cv)
1853 B::CV cv
96819e59
NC
1854 ALIAS:
1855 XSUBANY = 1
a8a597b2 1856 CODE:
96819e59 1857 ST(0) = ix && CvCONST(cv)
0c74f67f 1858 ? make_sv_object(aTHX_ (SV *)CvXSUBANY(cv).any_ptr)
96819e59
NC
1859 : sv_2mortal(newSViv(CvISXSUB(cv)
1860 ? (ix ? CvXSUBANY(cv).any_iv
1861 : PTR2IV(CvXSUB(cv)))
1862 : 0));
a8a597b2 1863
8ae5a962
NC
1864void
1865const_sv(cv)
de3f1649 1866 B::CV cv
8ae5a962 1867 PPCODE:
0c74f67f 1868 PUSHs(make_sv_object(aTHX_ (SV *)cv_const_sv(cv)));
de3f1649 1869
a8a597b2
MB
1870MODULE = B PACKAGE = B::HV PREFIX = Hv
1871
1872STRLEN
1873HvFILL(hv)
1874 B::HV hv
1875
a8a597b2
MB
1876I32
1877HvRITER(hv)
1878 B::HV hv
1879
a8a597b2
MB
1880void
1881HvARRAY(hv)
1882 B::HV hv
1883 PPCODE:
1b95d04f 1884 if (HvUSEDKEYS(hv) > 0) {
a8a597b2
MB
1885 SV *sv;
1886 char *key;
1887 I32 len;
1888 (void)hv_iterinit(hv);
1b95d04f 1889 EXTEND(sp, HvUSEDKEYS(hv) * 2);
8063af02 1890 while ((sv = hv_iternextsv(hv, &key, &len))) {
22f1178f 1891 mPUSHp(key, len);
0c74f67f 1892 PUSHs(make_sv_object(aTHX_ sv));
a8a597b2
MB
1893 }
1894 }
fd9f6265
JJ
1895
1896MODULE = B PACKAGE = B::HE PREFIX = He
1897
8ae5a962 1898void
fd9f6265
JJ
1899HeVAL(he)
1900 B::HE he
b2619626
NC
1901 ALIAS:
1902 SVKEY_force = 1
8ae5a962 1903 PPCODE:
0c74f67f 1904 PUSHs(make_sv_object(aTHX_ ix ? HeSVKEY_force(he) : HeVAL(he)));
fd9f6265
JJ
1905
1906U32
1907HeHASH(he)
1908 B::HE he
1909
fdbacc68 1910MODULE = B PACKAGE = B::RHE
fd9f6265
JJ
1911
1912SV*
fdbacc68 1913HASH(h)
fd9f6265
JJ
1914 B::RHE h
1915 CODE:
20439bc7 1916 RETVAL = newRV( (SV*)cophh_2hv(h, 0) );
fd9f6265
JJ
1917 OUTPUT:
1918 RETVAL
e412117e 1919
7261499d 1920
86d2498c 1921#ifdef PadlistARRAY
7261499d 1922
86d2498c 1923MODULE = B PACKAGE = B::PADLIST PREFIX = Padlist
7261499d
FC
1924
1925SSize_t
86d2498c 1926PadlistMAX(padlist)
7261499d
FC
1927 B::PADLIST padlist
1928
1929void
86d2498c 1930PadlistARRAY(padlist)
7261499d
FC
1931 B::PADLIST padlist
1932 PPCODE:
86d2498c
FC
1933 if (PadlistMAX(padlist) >= 0) {
1934 PAD **padp = PadlistARRAY(padlist);
7261499d 1935 PADOFFSET i;
86d2498c 1936 for (i = 0; i <= PadlistMAX(padlist); i++)
7261499d
FC
1937 XPUSHs(make_sv_object(aTHX_ (SV *)padp[i]));
1938 }
1939
1940void
86d2498c 1941PadlistARRAYelt(padlist, idx)
7261499d
FC
1942 B::PADLIST padlist
1943 PADOFFSET idx
1944 PPCODE:
86d2498c
FC
1945 if (idx >= 0 && PadlistMAX(padlist) >= 0
1946 && idx <= PadlistMAX(padlist))
7261499d 1947 XPUSHs(make_sv_object(aTHX_
86d2498c 1948 (SV *)PadlistARRAY(padlist)[idx]));
7261499d
FC
1949 else
1950 XPUSHs(make_sv_object(aTHX_ NULL));
1951
1952U32
86d2498c 1953PadlistREFCNT(padlist)
7261499d
FC
1954 B::PADLIST padlist
1955 CODE:
86d2498c 1956 RETVAL = PadlistREFCNT(padlist);
7261499d
FC
1957 OUTPUT:
1958 RETVAL
1959
1960#endif