This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
CvGV is no longer a simple struct member access
[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 1402 B::CV::STASH = PVCV_stash_ix
ffc5d9fc 1403 B::CV::FILE = PVCV_file_ix
ffc5d9fc
NC
1404 B::CV::OUTSIDE = PVCV_outside_ix
1405 B::CV::OUTSIDE_SEQ = PVCV_outside_seq_ix
1406 B::CV::CvFLAGS = PVCV_flags_ix
d65a2b0a
NC
1407 B::HV::MAX = PVHV_max_ix
1408 B::HV::KEYS = PVHV_keys_ix
e4da9d6a
NC
1409 PREINIT:
1410 char *ptr;
1411 SV *ret;
1412 PPCODE:
1413 ptr = (ix & 0xFFFF) + (char *)SvANY(sv);
1414 switch ((U8)(ix >> 16)) {
1415 case (U8)(sv_SVp >> 16):
428744c7 1416 ret = make_sv_object(aTHX_ *((SV **)ptr));
e4da9d6a
NC
1417 break;
1418 case (U8)(sv_IVp >> 16):
1419 ret = sv_2mortal(newSViv(*((IV *)ptr)));
1420 break;
1421 case (U8)(sv_UVp >> 16):
1422 ret = sv_2mortal(newSVuv(*((UV *)ptr)));
1423 break;
6782c6e0
NC
1424 case (U8)(sv_STRLENp >> 16):
1425 ret = sv_2mortal(newSVuv(*((STRLEN *)ptr)));
1426 break;
e4da9d6a
NC
1427 case (U8)(sv_U32p >> 16):
1428 ret = sv_2mortal(newSVuv(*((U32 *)ptr)));
1429 break;
1430 case (U8)(sv_U8p >> 16):
1431 ret = sv_2mortal(newSVuv(*((U8 *)ptr)));
1432 break;
1433 case (U8)(sv_char_pp >> 16):
1434 ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
1435 break;
1436 case (U8)(sv_NVp >> 16):
1437 ret = sv_2mortal(newSVnv(*((NV *)ptr)));
1438 break;
6782c6e0
NC
1439 case (U8)(sv_char_p >> 16):
1440 ret = newSVpvn_flags((char *)ptr, 1, SVs_TEMP);
1441 break;
3da43c35
NC
1442 case (U8)(sv_SSize_tp >> 16):
1443 ret = sv_2mortal(newSViv(*((SSize_t *)ptr)));
1444 break;
ffc5d9fc
NC
1445 case (U8)(sv_I32p >> 16):
1446 ret = sv_2mortal(newSVuv(*((I32 *)ptr)));
1447 break;
1448 case (U8)(sv_U16p >> 16):
1449 ret = sv_2mortal(newSVuv(*((U16 *)ptr)));
1450 break;
c33e8be1
Z
1451 default:
1452 croak("Illegal alias 0x%08x for B::*IVX", (unsigned)ix);
e4da9d6a
NC
1453 }
1454 ST(0) = ret;
1455 XSRETURN(1);
a8a597b2 1456
a8a597b2
MB
1457void
1458packiv(sv)
1459 B::IV sv
6829f5e2
NC
1460 ALIAS:
1461 needs64bits = 1
a8a597b2 1462 CODE:
6829f5e2
NC
1463 if (ix) {
1464 ST(0) = boolSV((I32)SvIVX(sv) != SvIVX(sv));
1465 } else if (sizeof(IV) == 8) {
a8a597b2 1466 U32 wp[2];
5d7488b2 1467 const IV iv = SvIVX(sv);
a8a597b2
MB
1468 /*
1469 * The following way of spelling 32 is to stop compilers on
1470 * 32-bit architectures from moaning about the shift count
1471 * being >= the width of the type. Such architectures don't
1472 * reach this code anyway (unless sizeof(IV) > 8 but then
1473 * everything else breaks too so I'm not fussed at the moment).
1474 */
42718184
RB
1475#ifdef UV_IS_QUAD
1476 wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1477#else
1478 wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1479#endif
a8a597b2 1480 wp[1] = htonl(iv & 0xffffffff);
d3d34884 1481 ST(0) = newSVpvn_flags((char *)wp, 8, SVs_TEMP);
a8a597b2
MB
1482 } else {
1483 U32 w = htonl((U32)SvIVX(sv));
d3d34884 1484 ST(0) = newSVpvn_flags((char *)&w, 4, SVs_TEMP);
a8a597b2
MB
1485 }
1486
1487MODULE = B PACKAGE = B::NV PREFIX = Sv
1488
76ef7183 1489NV
a8a597b2
MB
1490SvNV(sv)
1491 B::NV sv
1492
4df7f6af
NC
1493#if PERL_VERSION < 11
1494
a8a597b2
MB
1495MODULE = B PACKAGE = B::RV PREFIX = Sv
1496
8ae5a962 1497void
a8a597b2
MB
1498SvRV(sv)
1499 B::RV sv
8ae5a962 1500 PPCODE:
0c74f67f 1501 PUSHs(make_sv_object(aTHX_ SvRV(sv)));
a8a597b2 1502
89c6bc13
NC
1503#else
1504
1505MODULE = B PACKAGE = B::REGEXP
1506
154b8842 1507void
81e413dd 1508REGEX(sv)
89c6bc13 1509 B::REGEXP sv
81e413dd
NC
1510 ALIAS:
1511 precomp = 1
154b8842 1512 PPCODE:
81e413dd
NC
1513 if (ix) {
1514 PUSHs(newSVpvn_flags(RX_PRECOMP(sv), RX_PRELEN(sv), SVs_TEMP));
1515 } else {
1516 dXSTARG;
1517 /* FIXME - can we code this method more efficiently? */
1518 PUSHi(PTR2IV(sv));
1519 }
89c6bc13 1520
4df7f6af
NC
1521#endif
1522
fdbacc68 1523MODULE = B PACKAGE = B::PV
a8a597b2 1524
8ae5a962 1525void
fdbacc68 1526RV(sv)
b326da91 1527 B::PV sv
8ae5a962
NC
1528 PPCODE:
1529 if (!SvROK(sv))
b326da91 1530 croak( "argument is not SvROK" );
0c74f67f 1531 PUSHs(make_sv_object(aTHX_ SvRV(sv)));
b326da91 1532
a8a597b2 1533void
fdbacc68 1534PV(sv)
a8a597b2 1535 B::PV sv
3d665704
NC
1536 ALIAS:
1537 PVX = 1
f4c36584 1538 PVBM = 2
84fea184 1539 B::BM::TABLE = 3
a804b0fe
NC
1540 PREINIT:
1541 const char *p;
1542 STRLEN len = 0;
1543 U32 utf8 = 0;
a8a597b2 1544 CODE:
84fea184 1545 if (ix == 3) {
2bda37ba
NC
1546#ifndef PERL_FBM_TABLE_OFFSET
1547 const MAGIC *const mg = mg_find(sv, PERL_MAGIC_bm);
1548
1549 if (!mg)
1550 croak("argument to B::BM::TABLE is not a PVBM");
1551 p = mg->mg_ptr;
1552 len = mg->mg_len;
1553#else
84fea184
NC
1554 p = SvPV(sv, len);
1555 /* Boyer-Moore table is just after string and its safety-margin \0 */
1556 p += len + PERL_FBM_TABLE_OFFSET;
1557 len = 256;
2bda37ba 1558#endif
84fea184 1559 } else if (ix == 2) {
f4c36584 1560 /* This used to read 257. I think that that was buggy - should have
26ec7981
NC
1561 been 258. (The "\0", the flags byte, and 256 for the table.)
1562 The only user of this method is B::Bytecode in B::PV::bsave.
1563 I'm guessing that nothing tested the runtime correctness of
1564 output of bytecompiled string constant arguments to index (etc).
1565
1566 Note the start pointer is and has always been SvPVX(sv), not
1567 SvPVX(sv) + SvCUR(sv) PVBM was added in 651aa52ea1faa806, and
1568 first used by the compiler in 651aa52ea1faa806. It's used to
1569 get a "complete" dump of the buffer at SvPVX(), not just the
1570 PVBM table. This permits the generated bytecode to "load"
2bda37ba
NC
1571 SvPVX in "one" hit.
1572
1573 5.15 and later store the BM table via MAGIC, so the compiler
1574 should handle this just fine without changes if PVBM now
1575 always returns the SvPVX() buffer. */
8d919b0a
FC
1576#ifdef isREGEXP
1577 p = isREGEXP(sv)
1578 ? RX_WRAPPED_const((REGEXP*)sv)
1579 : SvPVX_const(sv);
1580#else
f4c36584 1581 p = SvPVX_const(sv);
8d919b0a 1582#endif
2bda37ba 1583#ifdef PERL_FBM_TABLE_OFFSET
f4c36584 1584 len = SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0);
2bda37ba
NC
1585#else
1586 len = SvCUR(sv);
1587#endif
f4c36584 1588 } else if (ix) {
8d919b0a
FC
1589#ifdef isREGEXP
1590 p = isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX(sv);
1591#else
3d665704 1592 p = SvPVX(sv);
8d919b0a 1593#endif
3d665704
NC
1594 len = strlen(p);
1595 } else if (SvPOK(sv)) {
a804b0fe
NC
1596 len = SvCUR(sv);
1597 p = SvPVX_const(sv);
1598 utf8 = SvUTF8(sv);
b326da91 1599 }
8d919b0a
FC
1600#ifdef isREGEXP
1601 else if (isREGEXP(sv)) {
1602 len = SvCUR(sv);
1603 p = RX_WRAPPED_const((REGEXP*)sv);
1604 utf8 = SvUTF8(sv);
1605 }
1606#endif
b326da91
MB
1607 else {
1608 /* XXX for backward compatibility, but should fail */
1609 /* croak( "argument is not SvPOK" ); */
a804b0fe 1610 p = NULL;
b326da91 1611 }
a804b0fe 1612 ST(0) = newSVpvn_flags(p, len, SVs_TEMP | utf8);
a8a597b2 1613
fdbacc68 1614MODULE = B PACKAGE = B::PVMG
a8a597b2
MB
1615
1616void
fdbacc68 1617MAGIC(sv)
a8a597b2
MB
1618 B::PVMG sv
1619 MAGIC * mg = NO_INIT
1620 PPCODE:
1621 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
9496d2e5 1622 XPUSHs(make_mg_object(aTHX_ mg));
a8a597b2 1623
b2adfa9b 1624MODULE = B PACKAGE = B::MAGIC
a8a597b2
MB
1625
1626void
b2adfa9b 1627MOREMAGIC(mg)
a8a597b2 1628 B::MAGIC mg
b2adfa9b
NC
1629 ALIAS:
1630 PRIVATE = 1
1631 TYPE = 2
1632 FLAGS = 3
fb6620c6 1633 LENGTH = 4
b2adfa9b
NC
1634 OBJ = 5
1635 PTR = 6
1636 REGEX = 7
1637 precomp = 8
1638 PPCODE:
1639 switch (ix) {
1640 case 0:
1641 XPUSHs(mg->mg_moremagic ? make_mg_object(aTHX_ mg->mg_moremagic)
1642 : &PL_sv_undef);
1643 break;
1644 case 1:
1645 mPUSHu(mg->mg_private);
1646 break;
1647 case 2:
1648 PUSHs(newSVpvn_flags(&(mg->mg_type), 1, SVs_TEMP));
1649 break;
1650 case 3:
1651 mPUSHu(mg->mg_flags);
1652 break;
1653 case 4:
1654 mPUSHi(mg->mg_len);
1655 break;
1656 case 5:
0c74f67f 1657 PUSHs(make_sv_object(aTHX_ mg->mg_obj));
b2adfa9b
NC
1658 break;
1659 case 6:
1660 if (mg->mg_ptr) {
1661 if (mg->mg_len >= 0) {
1662 PUSHs(newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP));
651aa52e 1663 } else if (mg->mg_len == HEf_SVKEY) {
0c74f67f 1664 PUSHs(make_sv_object(aTHX_ (SV*)mg->mg_ptr));
fdbd1d64 1665 } else
b2adfa9b
NC
1666 PUSHs(sv_newmortal());
1667 } else
1668 PUSHs(sv_newmortal());
1669 break;
1670 case 7:
1671 if(mg->mg_type == PERL_MAGIC_qr) {
1672 mPUSHi(PTR2IV(mg->mg_obj));
1673 } else {
1674 croak("REGEX is only meaningful on r-magic");
1675 }
1676 break;
1677 case 8:
1678 if (mg->mg_type == PERL_MAGIC_qr) {
1679 REGEXP *rx = (REGEXP *)mg->mg_obj;
227aaa42
NC
1680 PUSHs(newSVpvn_flags(rx ? RX_PRECOMP(rx) : NULL,
1681 rx ? RX_PRELEN(rx) : 0, SVs_TEMP));
b2adfa9b
NC
1682 } else {
1683 croak( "precomp is only meaningful on r-magic" );
1684 }
1685 break;
1686 }
a8a597b2 1687
8922e438
FC
1688MODULE = B PACKAGE = B::BM PREFIX = Bm
1689
1690U32
1691BmPREVIOUS(sv)
1692 B::BM sv
1693
1694U8
1695BmRARE(sv)
1696 B::BM sv
1697
a8a597b2
MB
1698MODULE = B PACKAGE = B::GV PREFIX = Gv
1699
1700void
1701GvNAME(gv)
1702 B::GV gv
cbf9c13f
NC
1703 ALIAS:
1704 FILE = 1
435e8dd0 1705 B::HV::NAME = 2
a8a597b2 1706 CODE:
435e8dd0
NC
1707 ST(0) = sv_2mortal(newSVhek(!ix ? GvNAME_HEK(gv)
1708 : (ix == 1 ? GvFILE_HEK(gv)
1709 : HvNAME_HEK((HV *)gv))));
a8a597b2 1710
87d7fd28
GS
1711bool
1712is_empty(gv)
1713 B::GV gv
711fbbf0
NC
1714 ALIAS:
1715 isGV_with_GP = 1
87d7fd28 1716 CODE:
711fbbf0 1717 if (ix) {
711fbbf0 1718 RETVAL = isGV_with_GP(gv) ? TRUE : FALSE;
711fbbf0
NC
1719 } else {
1720 RETVAL = GvGP(gv) == Null(GP*);
1721 }
50786ba8 1722 OUTPUT:
711fbbf0 1723 RETVAL
50786ba8 1724
651aa52e
AE
1725void*
1726GvGP(gv)
1727 B::GV gv
1728
257e0650
NC
1729#define GP_sv_ix SVp | offsetof(struct gp, gp_sv)
1730#define GP_io_ix SVp | offsetof(struct gp, gp_io)
1731#define GP_cv_ix SVp | offsetof(struct gp, gp_cv)
1732#define GP_cvgen_ix U32p | offsetof(struct gp, gp_cvgen)
1733#define GP_refcnt_ix U32p | offsetof(struct gp, gp_refcnt)
1734#define GP_hv_ix SVp | offsetof(struct gp, gp_hv)
1735#define GP_av_ix SVp | offsetof(struct gp, gp_av)
1736#define GP_form_ix SVp | offsetof(struct gp, gp_form)
1737#define GP_egv_ix SVp | offsetof(struct gp, gp_egv)
1738#define GP_line_ix line_tp | offsetof(struct gp, gp_line)
a8a597b2 1739
257e0650
NC
1740void
1741SV(gv)
a8a597b2 1742 B::GV gv
257e0650
NC
1743 ALIAS:
1744 SV = GP_sv_ix
1745 IO = GP_io_ix
1746 CV = GP_cv_ix
1747 CVGEN = GP_cvgen_ix
1748 GvREFCNT = GP_refcnt_ix
1749 HV = GP_hv_ix
1750 AV = GP_av_ix
1751 FORM = GP_form_ix
1752 EGV = GP_egv_ix
1753 LINE = GP_line_ix
1754 PREINIT:
1755 GP *gp;
1756 char *ptr;
1757 SV *ret;
1758 PPCODE:
1759 gp = GvGP(gv);
1760 if (!gp) {
1761 const GV *const gv = CvGV(cv);
46c3f339 1762 Perl_croak(aTHX_ "NULL gp in B::GV::%s", gv ? GvNAME(gv) : "???");
257e0650
NC
1763 }
1764 ptr = (ix & 0xFFFF) + (char *)gp;
1765 switch ((U8)(ix >> 16)) {
1766 case (U8)(SVp >> 16):
0c74f67f 1767 ret = make_sv_object(aTHX_ *((SV **)ptr));
257e0650
NC
1768 break;
1769 case (U8)(U32p >> 16):
1770 ret = sv_2mortal(newSVuv(*((U32*)ptr)));
1771 break;
1772 case (U8)(line_tp >> 16):
1773 ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
1774 break;
c33e8be1
Z
1775 default:
1776 croak("Illegal alias 0x%08x for B::*SV", (unsigned)ix);
257e0650
NC
1777 }
1778 ST(0) = ret;
1779 XSRETURN(1);
a8a597b2 1780
8ae5a962
NC
1781void
1782FILEGV(gv)
a8a597b2 1783 B::GV gv
8ae5a962 1784 PPCODE:
0c74f67f 1785 PUSHs(make_sv_object(aTHX_ (SV *)GvFILEGV(gv)));
a8a597b2 1786
a8a597b2
MB
1787MODULE = B PACKAGE = B::IO PREFIX = Io
1788
04071355 1789
b326da91
MB
1790bool
1791IsSTD(io,name)
1792 B::IO io
5d7488b2 1793 const char* name
b326da91
MB
1794 PREINIT:
1795 PerlIO* handle = 0;
1796 CODE:
1797 if( strEQ( name, "stdin" ) ) {
1798 handle = PerlIO_stdin();
1799 }
1800 else if( strEQ( name, "stdout" ) ) {
1801 handle = PerlIO_stdout();
1802 }
1803 else if( strEQ( name, "stderr" ) ) {
1804 handle = PerlIO_stderr();
1805 }
1806 else {
1807 croak( "Invalid value '%s'", name );
1808 }
1809 RETVAL = handle == IoIFP(io);
1810 OUTPUT:
1811 RETVAL
1812
a8a597b2
MB
1813MODULE = B PACKAGE = B::AV PREFIX = Av
1814
1815SSize_t
1816AvFILL(av)
1817 B::AV av
1818
a8a597b2
MB
1819void
1820AvARRAY(av)
1821 B::AV av
1822 PPCODE:
1823 if (AvFILL(av) >= 0) {
1824 SV **svp = AvARRAY(av);
1825 I32 i;
1826 for (i = 0; i <= AvFILL(av); i++)
0c74f67f 1827 XPUSHs(make_sv_object(aTHX_ svp[i]));
a8a597b2
MB
1828 }
1829
429a5ce7
SM
1830void
1831AvARRAYelt(av, idx)
1832 B::AV av
1833 int idx
1834 PPCODE:
1835 if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
0c74f67f 1836 XPUSHs(make_sv_object(aTHX_ (AvARRAY(av)[idx])));
429a5ce7 1837 else
0c74f67f 1838 XPUSHs(make_sv_object(aTHX_ NULL));
429a5ce7 1839
edcc7c74 1840
f2da823f
FC
1841MODULE = B PACKAGE = B::FM PREFIX = Fm
1842
35633035
DM
1843#undef FmLINES
1844#define FmLINES(sv) 0
f2da823f
FC
1845
1846IV
1847FmLINES(form)
1848 B::FM form
1849
a8a597b2
MB
1850MODULE = B PACKAGE = B::CV PREFIX = Cv
1851
651aa52e
AE
1852U32
1853CvCONST(cv)
1854 B::CV cv
1855
6079961f 1856void
a8a597b2
MB
1857CvSTART(cv)
1858 B::CV cv
a0da4400
NC
1859 ALIAS:
1860 ROOT = 1
6079961f
NC
1861 PPCODE:
1862 PUSHs(make_op_object(aTHX_ CvISXSUB(cv) ? NULL
1863 : ix ? CvROOT(cv) : CvSTART(cv)));
a8a597b2 1864
bb02a38f
FC
1865I32
1866CvDEPTH(cv)
1867 B::CV cv
1868
86d2498c 1869#ifdef PadlistARRAY
7261499d
FC
1870
1871B::PADLIST
1872CvPADLIST(cv)
1873 B::CV cv
1874
1875#else
1876
1877B::AV
1878CvPADLIST(cv)
1879 B::CV cv
82aeefe1
DM
1880 PPCODE:
1881 PUSHs(make_sv_object(aTHX_ (SV *)CvPADLIST(cv)));
1882
7261499d
FC
1883
1884#endif
1885
a8a597b2
MB
1886void
1887CvXSUB(cv)
1888 B::CV cv
96819e59
NC
1889 ALIAS:
1890 XSUBANY = 1
a8a597b2 1891 CODE:
96819e59 1892 ST(0) = ix && CvCONST(cv)
0c74f67f 1893 ? make_sv_object(aTHX_ (SV *)CvXSUBANY(cv).any_ptr)
96819e59
NC
1894 : sv_2mortal(newSViv(CvISXSUB(cv)
1895 ? (ix ? CvXSUBANY(cv).any_iv
1896 : PTR2IV(CvXSUB(cv)))
1897 : 0));
a8a597b2 1898
8ae5a962
NC
1899void
1900const_sv(cv)
de3f1649 1901 B::CV cv
8ae5a962 1902 PPCODE:
0c74f67f 1903 PUSHs(make_sv_object(aTHX_ (SV *)cv_const_sv(cv)));
de3f1649 1904
486b1e7f
TC
1905void
1906GV(cv)
1907 B::CV cv
1908 PREINIT:
1909 GV *gv;
1910 CODE:
1911 gv = CvGV(cv);
1912 ST(0) = gv ? make_sv_object((SV*)gv) : &PL_sv_undef;
1913
1914#if PERL_VERSION > 17
1915
1916SV *
1917NAME_HEK(cv)
1918 B::CV cv
1919 CODE:
1920 RETVAL = CvNAMED(cv) ? newSVhek(CvNAME_HEK(cv)) : &PL_sv_undef;
1921 OUTPUT:
1922 RETVAL
1923
1924#endif
1925
a8a597b2
MB
1926MODULE = B PACKAGE = B::HV PREFIX = Hv
1927
1928STRLEN
1929HvFILL(hv)
1930 B::HV hv
1931
a8a597b2
MB
1932I32
1933HvRITER(hv)
1934 B::HV hv
1935
a8a597b2
MB
1936void
1937HvARRAY(hv)
1938 B::HV hv
1939 PPCODE:
1b95d04f 1940 if (HvUSEDKEYS(hv) > 0) {
a8a597b2
MB
1941 SV *sv;
1942 char *key;
1943 I32 len;
1944 (void)hv_iterinit(hv);
1b95d04f 1945 EXTEND(sp, HvUSEDKEYS(hv) * 2);
8063af02 1946 while ((sv = hv_iternextsv(hv, &key, &len))) {
22f1178f 1947 mPUSHp(key, len);
0c74f67f 1948 PUSHs(make_sv_object(aTHX_ sv));
a8a597b2
MB
1949 }
1950 }
fd9f6265
JJ
1951
1952MODULE = B PACKAGE = B::HE PREFIX = He
1953
8ae5a962 1954void
fd9f6265
JJ
1955HeVAL(he)
1956 B::HE he
b2619626
NC
1957 ALIAS:
1958 SVKEY_force = 1
8ae5a962 1959 PPCODE:
0c74f67f 1960 PUSHs(make_sv_object(aTHX_ ix ? HeSVKEY_force(he) : HeVAL(he)));
fd9f6265
JJ
1961
1962U32
1963HeHASH(he)
1964 B::HE he
1965
fdbacc68 1966MODULE = B PACKAGE = B::RHE
fd9f6265
JJ
1967
1968SV*
fdbacc68 1969HASH(h)
fd9f6265
JJ
1970 B::RHE h
1971 CODE:
20439bc7 1972 RETVAL = newRV( (SV*)cophh_2hv(h, 0) );
fd9f6265
JJ
1973 OUTPUT:
1974 RETVAL
e412117e 1975
7261499d 1976
86d2498c 1977#ifdef PadlistARRAY
7261499d 1978
86d2498c 1979MODULE = B PACKAGE = B::PADLIST PREFIX = Padlist
7261499d
FC
1980
1981SSize_t
86d2498c 1982PadlistMAX(padlist)
7261499d
FC
1983 B::PADLIST padlist
1984
1985void
86d2498c 1986PadlistARRAY(padlist)
7261499d
FC
1987 B::PADLIST padlist
1988 PPCODE:
86d2498c
FC
1989 if (PadlistMAX(padlist) >= 0) {
1990 PAD **padp = PadlistARRAY(padlist);
7261499d 1991 PADOFFSET i;
86d2498c 1992 for (i = 0; i <= PadlistMAX(padlist); i++)
7261499d
FC
1993 XPUSHs(make_sv_object(aTHX_ (SV *)padp[i]));
1994 }
1995
1996void
86d2498c 1997PadlistARRAYelt(padlist, idx)
7261499d
FC
1998 B::PADLIST padlist
1999 PADOFFSET idx
2000 PPCODE:
71446f2d 2001 if (PadlistMAX(padlist) >= 0
86d2498c 2002 && idx <= PadlistMAX(padlist))
7261499d 2003 XPUSHs(make_sv_object(aTHX_
86d2498c 2004 (SV *)PadlistARRAY(padlist)[idx]));
7261499d
FC
2005 else
2006 XPUSHs(make_sv_object(aTHX_ NULL));
2007
2008U32
86d2498c 2009PadlistREFCNT(padlist)
7261499d
FC
2010 B::PADLIST padlist
2011 CODE:
86d2498c 2012 RETVAL = PadlistREFCNT(padlist);
7261499d
FC
2013 OUTPUT:
2014 RETVAL
2015
2016#endif