This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add Perl_op_class(o) API function
[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
fedf30e1 11#define PERL_EXT
a8a597b2
MB
12#include "EXTERN.h"
13#include "perl.h"
14#include "XSUB.h"
a8a597b2 15
51aa15f3
GS
16#ifdef PerlIO
17typedef PerlIO * InputStream;
18#else
19typedef FILE * InputStream;
20#endif
21
22
27da23d5 23static const char* const svclassnames[] = {
a8a597b2 24 "B::NULL",
1cb9cd50 25 "B::IV",
b53eecb4 26 "B::NV",
a8a597b2 27 "B::PV",
e94d9b54 28 "B::INVLIST",
a8a597b2
MB
29 "B::PVIV",
30 "B::PVNV",
31 "B::PVMG",
5c35adbb 32 "B::REGEXP",
4ce457a6 33 "B::GV",
a8a597b2
MB
34 "B::PVLV",
35 "B::AV",
36 "B::HV",
37 "B::CV",
a8a597b2
MB
38 "B::FM",
39 "B::IO",
40};
41
a8a597b2 42
27da23d5 43static const char* const opclassnames[] = {
a8a597b2
MB
44 "B::NULL",
45 "B::OP",
46 "B::UNOP",
47 "B::BINOP",
48 "B::LOGOP",
a8a597b2
MB
49 "B::LISTOP",
50 "B::PMOP",
51 "B::SVOP",
7934575e 52 "B::PADOP",
a8a597b2 53 "B::PVOP",
a8a597b2 54 "B::LOOP",
b46e009d 55 "B::COP",
2f7c6295
DM
56 "B::METHOP",
57 "B::UNOP_AUX"
a8a597b2
MB
58};
59
27da23d5 60static const size_t opsizes[] = {
651aa52e
AE
61 0,
62 sizeof(OP),
63 sizeof(UNOP),
64 sizeof(BINOP),
65 sizeof(LOGOP),
66 sizeof(LISTOP),
67 sizeof(PMOP),
68 sizeof(SVOP),
69 sizeof(PADOP),
70 sizeof(PVOP),
71 sizeof(LOOP),
b46e009d 72 sizeof(COP),
2f7c6295
DM
73 sizeof(METHOP),
74 sizeof(UNOP_AUX),
651aa52e
AE
75};
76
df3728a2 77#define MY_CXT_KEY "B::_guts" XS_VERSION
a8a597b2 78
89ca4ac7 79typedef struct {
b326da91 80 SV * x_specialsv_list[7];
a462fa00 81 int x_walkoptree_debug; /* Flag for walkoptree debug hook */
89ca4ac7
JH
82} my_cxt_t;
83
84START_MY_CXT
85
86#define walkoptree_debug (MY_CXT.x_walkoptree_debug)
87#define specialsv_list (MY_CXT.x_specialsv_list)
e8edd1e6 88
a462fa00
DD
89
90static void B_init_my_cxt(pTHX_ my_cxt_t * cxt) {
91 cxt->x_specialsv_list[0] = Nullsv;
92 cxt->x_specialsv_list[1] = &PL_sv_undef;
93 cxt->x_specialsv_list[2] = &PL_sv_yes;
94 cxt->x_specialsv_list[3] = &PL_sv_no;
95 cxt->x_specialsv_list[4] = (SV *) pWARN_ALL;
96 cxt->x_specialsv_list[5] = (SV *) pWARN_NONE;
97 cxt->x_specialsv_list[6] = (SV *) pWARN_STD;
98}
99
a8a597b2 100
6079961f
NC
101static SV *
102make_op_object(pTHX_ const OP *o)
a8a597b2 103{
6079961f 104 SV *opsv = sv_newmortal();
1e85b658 105 sv_setiv(newSVrv(opsv, opclassnames[op_class(o)]), PTR2IV(o));
6079961f 106 return opsv;
a8a597b2
MB
107}
108
71324a3b
DM
109
110static SV *
111get_overlay_object(pTHX_ const OP *o, const char * const name, U32 namelen)
112{
113 HE *he;
114 SV **svp;
115 SV *key;
116 SV *sv =get_sv("B::overlay", 0);
117 if (!sv || !SvROK(sv))
118 return NULL;
119 sv = SvRV(sv);
120 if (SvTYPE(sv) != SVt_PVHV)
121 return NULL;
122 key = newSViv(PTR2IV(o));
123 he = hv_fetch_ent((HV*)sv, key, 0, 0);
124 SvREFCNT_dec(key);
125 if (!he)
126 return NULL;
127 sv = HeVAL(he);
128 if (!sv || !SvROK(sv))
129 return NULL;
130 sv = SvRV(sv);
131 if (SvTYPE(sv) != SVt_PVHV)
132 return NULL;
133 svp = hv_fetch((HV*)sv, name, namelen, 0);
134 if (!svp)
135 return NULL;
136 sv = *svp;
137 return sv;
138}
139
140
a8a597b2 141static SV *
0c74f67f 142make_sv_object(pTHX_ SV *sv)
a8a597b2 143{
0c74f67f 144 SV *const arg = sv_newmortal();
27da23d5 145 const char *type = 0;
a8a597b2 146 IV iv;
89ca4ac7 147 dMY_CXT;
9496d2e5 148
c33e8be1 149 for (iv = 0; iv < (IV)(sizeof(specialsv_list)/sizeof(SV*)); iv++) {
e8edd1e6 150 if (sv == specialsv_list[iv]) {
a8a597b2
MB
151 type = "B::SPECIAL";
152 break;
153 }
154 }
155 if (!type) {
156 type = svclassnames[SvTYPE(sv)];
56431972 157 iv = PTR2IV(sv);
a8a597b2
MB
158 }
159 sv_setiv(newSVrv(arg, type), iv);
160 return arg;
161}
162
163static SV *
9496d2e5 164make_temp_object(pTHX_ SV *temp)
8e01d9a6
NC
165{
166 SV *target;
9496d2e5 167 SV *arg = sv_newmortal();
8e01d9a6
NC
168 const char *const type = svclassnames[SvTYPE(temp)];
169 const IV iv = PTR2IV(temp);
170
171 target = newSVrv(arg, type);
172 sv_setiv(target, iv);
173
174 /* Need to keep our "temp" around as long as the target exists.
175 Simplest way seems to be to hang it from magic, and let that clear
176 it up. No vtable, so won't actually get in the way of anything. */
177 sv_magicext(target, temp, PERL_MAGIC_sv, NULL, NULL, 0);
178 /* magic object has had its reference count increased, so we must drop
179 our reference. */
180 SvREFCNT_dec(temp);
181 return arg;
182}
183
184static SV *
d2b4c688 185make_warnings_object(pTHX_ const COP *const cop)
5c3c3f81 186{
d2b4c688 187 const STRLEN *const warnings = cop->cop_warnings;
5c3c3f81
NC
188 const char *type = 0;
189 dMY_CXT;
190 IV iv = sizeof(specialsv_list)/sizeof(SV*);
191
192 /* Counting down is deliberate. Before the split between make_sv_object
193 and make_warnings_obj there appeared to be a bug - Nullsv and pWARN_STD
194 were both 0, so you could never get a B::SPECIAL for pWARN_STD */
195
196 while (iv--) {
197 if ((SV*)warnings == specialsv_list[iv]) {
198 type = "B::SPECIAL";
199 break;
200 }
201 }
202 if (type) {
9496d2e5 203 SV *arg = sv_newmortal();
5c3c3f81 204 sv_setiv(newSVrv(arg, type), iv);
8e01d9a6 205 return arg;
5c3c3f81
NC
206 } else {
207 /* B assumes that warnings are a regular SV. Seems easier to keep it
208 happy by making them into a regular SV. */
9496d2e5 209 return make_temp_object(aTHX_ newSVpvn((char *)(warnings + 1), *warnings));
8e01d9a6
NC
210 }
211}
212
213static SV *
9496d2e5 214make_cop_io_object(pTHX_ COP *cop)
8e01d9a6 215{
8b850bd5
NC
216 SV *const value = newSV(0);
217
33972ad6 218 Perl_emulate_cop_io(aTHX_ cop, value);
8b850bd5
NC
219
220 if(SvOK(value)) {
0c74f67f 221 return make_sv_object(aTHX_ value);
8e01d9a6 222 } else {
8b850bd5 223 SvREFCNT_dec(value);
0c74f67f 224 return make_sv_object(aTHX_ NULL);
5c3c3f81 225 }
5c3c3f81
NC
226}
227
228static SV *
9496d2e5 229make_mg_object(pTHX_ MAGIC *mg)
a8a597b2 230{
9496d2e5 231 SV *arg = sv_newmortal();
56431972 232 sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg));
a8a597b2
MB
233 return arg;
234}
235
236static SV *
52ad86de 237cstring(pTHX_ SV *sv, bool perlstyle)
a8a597b2 238{
09e97b95 239 SV *sstr;
a8a597b2
MB
240
241 if (!SvOK(sv))
09e97b95
NC
242 return newSVpvs_flags("0", SVs_TEMP);
243
244 sstr = newSVpvs_flags("\"", SVs_TEMP);
245
246 if (perlstyle && SvUTF8(sv)) {
d79a7a3d 247 SV *tmpsv = sv_newmortal(); /* Temporary SV to feed sv_uni_display */
5d7488b2
AL
248 const STRLEN len = SvCUR(sv);
249 const char *s = sv_uni_display(tmpsv, sv, 8*len, UNI_DISPLAY_QQ);
d79a7a3d
RGS
250 while (*s)
251 {
252 if (*s == '"')
6beb30a6 253 sv_catpvs(sstr, "\\\"");
d79a7a3d 254 else if (*s == '$')
6beb30a6 255 sv_catpvs(sstr, "\\$");
d79a7a3d 256 else if (*s == '@')
6beb30a6 257 sv_catpvs(sstr, "\\@");
d79a7a3d
RGS
258 else if (*s == '\\')
259 {
260 if (strchr("nrftax\\",*(s+1)))
261 sv_catpvn(sstr, s++, 2);
262 else
6beb30a6 263 sv_catpvs(sstr, "\\\\");
d79a7a3d
RGS
264 }
265 else /* should always be printable */
266 sv_catpvn(sstr, s, 1);
267 ++s;
268 }
d79a7a3d 269 }
a8a597b2
MB
270 else
271 {
272 /* XXX Optimise? */
5d7488b2
AL
273 STRLEN len;
274 const char *s = SvPV(sv, len);
a8a597b2
MB
275 for (; len; len--, s++)
276 {
277 /* At least try a little for readability */
278 if (*s == '"')
6beb30a6 279 sv_catpvs(sstr, "\\\"");
a8a597b2 280 else if (*s == '\\')
6beb30a6 281 sv_catpvs(sstr, "\\\\");
b326da91 282 /* trigraphs - bleagh */
5d7488b2 283 else if (!perlstyle && *s == '?' && len>=3 && s[1] == '?') {
47bf35fa 284 Perl_sv_catpvf(aTHX_ sstr, "\\%03o", '?');
b326da91 285 }
52ad86de 286 else if (perlstyle && *s == '$')
6beb30a6 287 sv_catpvs(sstr, "\\$");
52ad86de 288 else if (perlstyle && *s == '@')
6beb30a6 289 sv_catpvs(sstr, "\\@");
ce561ef2 290 else if (isPRINT(*s))
a8a597b2
MB
291 sv_catpvn(sstr, s, 1);
292 else if (*s == '\n')
6beb30a6 293 sv_catpvs(sstr, "\\n");
a8a597b2 294 else if (*s == '\r')
6beb30a6 295 sv_catpvs(sstr, "\\r");
a8a597b2 296 else if (*s == '\t')
6beb30a6 297 sv_catpvs(sstr, "\\t");
a8a597b2 298 else if (*s == '\a')
6beb30a6 299 sv_catpvs(sstr, "\\a");
a8a597b2 300 else if (*s == '\b')
6beb30a6 301 sv_catpvs(sstr, "\\b");
a8a597b2 302 else if (*s == '\f')
6beb30a6 303 sv_catpvs(sstr, "\\f");
52ad86de 304 else if (!perlstyle && *s == '\v')
6beb30a6 305 sv_catpvs(sstr, "\\v");
a8a597b2
MB
306 else
307 {
a8a597b2 308 /* Don't want promotion of a signed -1 char in sprintf args */
5d7488b2 309 const unsigned char c = (unsigned char) *s;
47bf35fa 310 Perl_sv_catpvf(aTHX_ sstr, "\\%03o", c);
a8a597b2
MB
311 }
312 /* XXX Add line breaks if string is long */
313 }
a8a597b2 314 }
09e97b95 315 sv_catpvs(sstr, "\"");
a8a597b2
MB
316 return sstr;
317}
318
319static SV *
cea2e8a9 320cchar(pTHX_ SV *sv)
a8a597b2 321{
422d053b 322 SV *sstr = newSVpvs_flags("'", SVs_TEMP);
5d7488b2 323 const char *s = SvPV_nolen(sv);
422d053b
NC
324 /* Don't want promotion of a signed -1 char in sprintf args */
325 const unsigned char c = (unsigned char) *s;
a8a597b2 326
422d053b 327 if (c == '\'')
6beb30a6 328 sv_catpvs(sstr, "\\'");
422d053b 329 else if (c == '\\')
6beb30a6 330 sv_catpvs(sstr, "\\\\");
422d053b 331 else if (isPRINT(c))
a8a597b2 332 sv_catpvn(sstr, s, 1);
422d053b 333 else if (c == '\n')
6beb30a6 334 sv_catpvs(sstr, "\\n");
422d053b 335 else if (c == '\r')
6beb30a6 336 sv_catpvs(sstr, "\\r");
422d053b 337 else if (c == '\t')
6beb30a6 338 sv_catpvs(sstr, "\\t");
422d053b 339 else if (c == '\a')
6beb30a6 340 sv_catpvs(sstr, "\\a");
422d053b 341 else if (c == '\b')
6beb30a6 342 sv_catpvs(sstr, "\\b");
422d053b 343 else if (c == '\f')
6beb30a6 344 sv_catpvs(sstr, "\\f");
422d053b 345 else if (c == '\v')
6beb30a6 346 sv_catpvs(sstr, "\\v");
a8a597b2 347 else
422d053b 348 Perl_sv_catpvf(aTHX_ sstr, "\\%03o", c);
6beb30a6 349 sv_catpvs(sstr, "'");
a8a597b2
MB
350 return sstr;
351}
352
35633035
DM
353#define PMOP_pmreplstart(o) o->op_pmstashstartu.op_pmreplstart
354#define PMOP_pmreplroot(o) o->op_pmreplrootu.op_pmreplroot
8f3d514b 355
20f7624e
NC
356static SV *
357walkoptree(pTHX_ OP *o, const char *method, SV *ref)
a8a597b2
MB
358{
359 dSP;
20f7624e
NC
360 OP *kid;
361 SV *object;
1e85b658 362 const char *const classname = opclassnames[op_class(o)];
89ca4ac7
JH
363 dMY_CXT;
364
20f7624e
NC
365 /* Check that no-one has changed our reference, or is holding a reference
366 to it. */
367 if (SvREFCNT(ref) == 1 && SvROK(ref) && SvTYPE(ref) == SVt_RV
368 && (object = SvRV(ref)) && SvREFCNT(object) == 1
369 && SvTYPE(object) == SVt_PVMG && SvIOK_only(object)
370 && !SvMAGICAL(object) && !SvMAGIC(object) && SvSTASH(object)) {
371 /* Looks good, so rebless it for the class we need: */
372 sv_bless(ref, gv_stashpv(classname, GV_ADD));
373 } else {
374 /* Need to make a new one. */
375 ref = sv_newmortal();
376 object = newSVrv(ref, classname);
377 }
378 sv_setiv(object, PTR2IV(o));
379
a8a597b2
MB
380 if (walkoptree_debug) {
381 PUSHMARK(sp);
20f7624e 382 XPUSHs(ref);
a8a597b2
MB
383 PUTBACK;
384 perl_call_method("walkoptree_debug", G_DISCARD);
385 }
386 PUSHMARK(sp);
20f7624e 387 XPUSHs(ref);
a8a597b2
MB
388 PUTBACK;
389 perl_call_method(method, G_DISCARD);
390 if (o && (o->op_flags & OPf_KIDS)) {
e6dae479 391 for (kid = ((UNOP*)o)->op_first; kid; kid = OpSIBLING(kid)) {
20f7624e 392 ref = walkoptree(aTHX_ kid, method, ref);
a8a597b2
MB
393 }
394 }
1e85b658 395 if (o && (op_class(o) == OPclass_PMOP) && o->op_type != OP_SPLIT
8f3d514b 396 && (kid = PMOP_pmreplroot(cPMOPo)))
f3be9b72 397 {
20f7624e 398 ref = walkoptree(aTHX_ kid, method, ref);
f3be9b72 399 }
20f7624e 400 return ref;
a8a597b2
MB
401}
402
5d7488b2 403static SV **
1df34986
AE
404oplist(pTHX_ OP *o, SV **SP)
405{
406 for(; o; o = o->op_next) {
7252851f 407 if (o->op_opt == 0)
1df34986 408 break;
2814eb74 409 o->op_opt = 0;
6079961f 410 XPUSHs(make_op_object(aTHX_ o));
1df34986
AE
411 switch (o->op_type) {
412 case OP_SUBST:
8f3d514b 413 SP = oplist(aTHX_ PMOP_pmreplstart(cPMOPo), SP);
1df34986
AE
414 continue;
415 case OP_SORT:
f66c782a 416 if (o->op_flags & OPf_STACKED && o->op_flags & OPf_SPECIAL) {
e6dae479 417 OP *kid = OpSIBLING(cLISTOPo->op_first); /* pass pushmark */
1df34986
AE
418 kid = kUNOP->op_first; /* pass rv2gv */
419 kid = kUNOP->op_first; /* pass leave */
f66c782a 420 SP = oplist(aTHX_ kid->op_next, SP);
1df34986
AE
421 }
422 continue;
423 }
424 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
425 case OA_LOGOP:
426 SP = oplist(aTHX_ cLOGOPo->op_other, SP);
427 break;
428 case OA_LOOP:
429 SP = oplist(aTHX_ cLOOPo->op_lastop, SP);
430 SP = oplist(aTHX_ cLOOPo->op_nextop, SP);
431 SP = oplist(aTHX_ cLOOPo->op_redoop, SP);
432 break;
433 }
434 }
435 return SP;
436}
437
a8a597b2
MB
438typedef OP *B__OP;
439typedef UNOP *B__UNOP;
440typedef BINOP *B__BINOP;
441typedef LOGOP *B__LOGOP;
a8a597b2
MB
442typedef LISTOP *B__LISTOP;
443typedef PMOP *B__PMOP;
444typedef SVOP *B__SVOP;
7934575e 445typedef PADOP *B__PADOP;
a8a597b2
MB
446typedef PVOP *B__PVOP;
447typedef LOOP *B__LOOP;
448typedef COP *B__COP;
b46e009d 449typedef METHOP *B__METHOP;
a8a597b2
MB
450
451typedef SV *B__SV;
452typedef SV *B__IV;
453typedef SV *B__PV;
454typedef SV *B__NV;
455typedef SV *B__PVMG;
5c35adbb 456typedef SV *B__REGEXP;
a8a597b2
MB
457typedef SV *B__PVLV;
458typedef SV *B__BM;
459typedef SV *B__RV;
1df34986 460typedef SV *B__FM;
a8a597b2
MB
461typedef AV *B__AV;
462typedef HV *B__HV;
463typedef CV *B__CV;
464typedef GV *B__GV;
465typedef IO *B__IO;
466
467typedef MAGIC *B__MAGIC;
fd9f6265
JJ
468typedef HE *B__HE;
469typedef struct refcounted_he *B__RHE;
86d2498c 470#ifdef PadlistARRAY
7261499d
FC
471typedef PADLIST *B__PADLIST;
472#endif
9b7476d7 473typedef PADNAMELIST *B__PADNAMELIST;
0f94cb1f 474typedef PADNAME *B__PADNAME;
9b7476d7 475
a8a597b2 476
3486ec84 477#ifdef MULTIPLICITY
115ff745 478# define ASSIGN_COMMON_ALIAS(prefix, var) \
3800c318 479 STMT_START { XSANY.any_i32 = STRUCT_OFFSET(struct interpreter, prefix##var); } STMT_END
32855229 480#else
115ff745 481# define ASSIGN_COMMON_ALIAS(prefix, var) \
32855229
NC
482 STMT_START { XSANY.any_ptr = (void *)&PL_##var; } STMT_END
483#endif
484
485/* This needs to be ALIASed in a custom way, hence can't easily be defined as
486 a regular XSUB. */
487static XSPROTO(intrpvar_sv_common); /* prototype to pass -Wmissing-prototypes */
488static XSPROTO(intrpvar_sv_common)
489{
490 dVAR;
491 dXSARGS;
492 SV *ret;
493 if (items != 0)
494 croak_xs_usage(cv, "");
3486ec84 495#ifdef MULTIPLICITY
32855229
NC
496 ret = *(SV **)(XSANY.any_i32 + (char *)my_perl);
497#else
498 ret = *(SV **)(XSANY.any_ptr);
499#endif
0c74f67f 500 ST(0) = make_sv_object(aTHX_ ret);
32855229
NC
501 XSRETURN(1);
502}
503
bec746fe
DM
504
505
0508288e
NC
506#define SVp 0x0
507#define U32p 0x1
508#define line_tp 0x2
509#define OPp 0x3
510#define PADOFFSETp 0x4
511#define U8p 0x5
512#define IVp 0x6
513#define char_pp 0x7
514/* Keep this last: */
515#define op_offset_special 0x8
bec746fe
DM
516
517/* table that drives most of the B::*OP methods */
518
0b057af7 519static const struct OP_methods {
bec746fe 520 const char *name;
7d6d3fb7 521 U8 namelen;
0508288e
NC
522 U8 type; /* if op_offset_special, access is handled on a case-by-case basis */
523 U16 offset;
bec746fe 524} op_methods[] = {
3800c318 525 { STR_WITH_LEN("next"), OPp, STRUCT_OFFSET(struct op, op_next), },/* 0*/
1ed44841 526 { STR_WITH_LEN("sibling"), op_offset_special, 0, },/* 1*/
3800c318
JH
527 { STR_WITH_LEN("targ"), PADOFFSETp, STRUCT_OFFSET(struct op, op_targ), },/* 2*/
528 { STR_WITH_LEN("flags"), U8p, STRUCT_OFFSET(struct op, op_flags), },/* 3*/
529 { STR_WITH_LEN("private"), U8p, STRUCT_OFFSET(struct op, op_private), },/* 4*/
530 { STR_WITH_LEN("first"), OPp, STRUCT_OFFSET(struct unop, op_first), },/* 5*/
531 { STR_WITH_LEN("last"), OPp, STRUCT_OFFSET(struct binop, op_last), },/* 6*/
532 { STR_WITH_LEN("other"), OPp, STRUCT_OFFSET(struct logop, op_other), },/* 7*/
99639b5b 533 { STR_WITH_LEN("pmreplstart"), op_offset_special, 0, },/* 8*/
3800c318
JH
534 { STR_WITH_LEN("redoop"), OPp, STRUCT_OFFSET(struct loop, op_redoop), },/* 9*/
535 { STR_WITH_LEN("nextop"), OPp, STRUCT_OFFSET(struct loop, op_nextop), },/*10*/
536 { STR_WITH_LEN("lastop"), OPp, STRUCT_OFFSET(struct loop, op_lastop), },/*11*/
537 { STR_WITH_LEN("pmflags"), U32p, STRUCT_OFFSET(struct pmop, op_pmflags),},/*12*/
3800c318 538 { STR_WITH_LEN("code_list"),OPp, STRUCT_OFFSET(struct pmop, op_code_list),},/*13*/
3800c318
JH
539 { STR_WITH_LEN("sv"), SVp, STRUCT_OFFSET(struct svop, op_sv), },/*14*/
540 { STR_WITH_LEN("gv"), SVp, STRUCT_OFFSET(struct svop, op_sv), },/*15*/
541 { STR_WITH_LEN("padix"), PADOFFSETp,STRUCT_OFFSET(struct padop, op_padix),},/*16*/
542 { STR_WITH_LEN("cop_seq"), U32p, STRUCT_OFFSET(struct cop, cop_seq), },/*17*/
543 { STR_WITH_LEN("line"), line_tp, STRUCT_OFFSET(struct cop, cop_line), },/*18*/
544 { STR_WITH_LEN("hints"), U32p, STRUCT_OFFSET(struct cop, cop_hints), },/*19*/
bec746fe 545#ifdef USE_ITHREADS
3800c318 546 { STR_WITH_LEN("pmoffset"),IVp, STRUCT_OFFSET(struct pmop, op_pmoffset),},/*20*/
99639b5b 547 { STR_WITH_LEN("filegv"), op_offset_special, 0, },/*21*/
3800c318 548 { STR_WITH_LEN("file"), char_pp, STRUCT_OFFSET(struct cop, cop_file), },/*22*/
99639b5b 549 { STR_WITH_LEN("stash"), op_offset_special, 0, },/*23*/
99639b5b 550 { STR_WITH_LEN("stashpv"), op_offset_special, 0, },/*24*/
3800c318 551 { STR_WITH_LEN("stashoff"),PADOFFSETp,STRUCT_OFFSET(struct cop,cop_stashoff),},/*25*/
bec746fe 552#else
99639b5b 553 { STR_WITH_LEN("pmoffset"),op_offset_special, 0, },/*20*/
3800c318 554 { STR_WITH_LEN("filegv"), SVp, STRUCT_OFFSET(struct cop, cop_filegv),},/*21*/
99639b5b 555 { STR_WITH_LEN("file"), op_offset_special, 0, },/*22*/
3800c318 556 { STR_WITH_LEN("stash"), SVp, STRUCT_OFFSET(struct cop, cop_stash), },/*23*/
99639b5b
DM
557 { STR_WITH_LEN("stashpv"), op_offset_special, 0, },/*24*/
558 { STR_WITH_LEN("stashoff"),op_offset_special, 0, },/*25*/
bec746fe 559#endif
99639b5b
DM
560 { STR_WITH_LEN("size"), op_offset_special, 0, },/*26*/
561 { STR_WITH_LEN("name"), op_offset_special, 0, },/*27*/
562 { STR_WITH_LEN("desc"), op_offset_special, 0, },/*28*/
563 { STR_WITH_LEN("ppaddr"), op_offset_special, 0, },/*29*/
564 { STR_WITH_LEN("type"), op_offset_special, 0, },/*30*/
565 { STR_WITH_LEN("opt"), op_offset_special, 0, },/*31*/
566 { STR_WITH_LEN("spare"), op_offset_special, 0, },/*32*/
567 { STR_WITH_LEN("children"),op_offset_special, 0, },/*33*/
568 { STR_WITH_LEN("pmreplroot"), op_offset_special, 0, },/*34*/
569 { STR_WITH_LEN("pmstashpv"), op_offset_special, 0, },/*35*/
570 { STR_WITH_LEN("pmstash"), op_offset_special, 0, },/*36*/
571 { STR_WITH_LEN("precomp"), op_offset_special, 0, },/*37*/
572 { STR_WITH_LEN("reflags"), op_offset_special, 0, },/*38*/
573 { STR_WITH_LEN("sv"), op_offset_special, 0, },/*39*/
574 { STR_WITH_LEN("gv"), op_offset_special, 0, },/*40*/
575 { STR_WITH_LEN("pv"), op_offset_special, 0, },/*41*/
576 { STR_WITH_LEN("label"), op_offset_special, 0, },/*42*/
577 { STR_WITH_LEN("arybase"), op_offset_special, 0, },/*43*/
578 { STR_WITH_LEN("warnings"),op_offset_special, 0, },/*44*/
579 { STR_WITH_LEN("io"), op_offset_special, 0, },/*45*/
580 { STR_WITH_LEN("hints_hash"),op_offset_special, 0, },/*46*/
99639b5b
DM
581 { STR_WITH_LEN("slabbed"), op_offset_special, 0, },/*47*/
582 { STR_WITH_LEN("savefree"),op_offset_special, 0, },/*48*/
583 { STR_WITH_LEN("static"), op_offset_special, 0, },/*49*/
99639b5b 584 { STR_WITH_LEN("folded"), op_offset_special, 0, },/*50*/
87b5a8b9 585 { STR_WITH_LEN("moresib"), op_offset_special, 0, },/*51*/
29e61fd9 586 { STR_WITH_LEN("parent"), op_offset_special, 0, },/*52*/
b46e009d 587 { STR_WITH_LEN("first"), op_offset_special, 0, },/*53*/
588 { STR_WITH_LEN("meth_sv"), op_offset_special, 0, },/*54*/
429ba3b2 589 { STR_WITH_LEN("pmregexp"),op_offset_special, 0, },/*55*/
810bd8b7 590# ifdef USE_ITHREADS
591 { STR_WITH_LEN("rclass"), op_offset_special, 0, },/*56*/
592# else
593 { STR_WITH_LEN("rclass"), op_offset_special, 0, },/*56*/
594# endif
bec746fe
DM
595};
596
b1826b71
NC
597#include "const-c.inc"
598
7a2c16aa 599MODULE = B PACKAGE = B
a8a597b2 600
b1826b71
NC
601INCLUDE: const-xs.inc
602
a8a597b2
MB
603PROTOTYPES: DISABLE
604
605BOOT:
4c1f658f 606{
7a2c16aa
NC
607 CV *cv;
608 const char *file = __FILE__;
c3890f9c 609 SV *sv;
89ca4ac7 610 MY_CXT_INIT;
a462fa00 611 B_init_my_cxt(aTHX_ &(MY_CXT));
32855229 612 cv = newXS("B::init_av", intrpvar_sv_common, file);
115ff745 613 ASSIGN_COMMON_ALIAS(I, initav);
32855229 614 cv = newXS("B::check_av", intrpvar_sv_common, file);
115ff745 615 ASSIGN_COMMON_ALIAS(I, checkav_save);
32855229 616 cv = newXS("B::unitcheck_av", intrpvar_sv_common, file);
115ff745 617 ASSIGN_COMMON_ALIAS(I, unitcheckav_save);
32855229 618 cv = newXS("B::begin_av", intrpvar_sv_common, file);
115ff745 619 ASSIGN_COMMON_ALIAS(I, beginav_save);
32855229 620 cv = newXS("B::end_av", intrpvar_sv_common, file);
115ff745 621 ASSIGN_COMMON_ALIAS(I, endav);
32855229 622 cv = newXS("B::main_cv", intrpvar_sv_common, file);
115ff745 623 ASSIGN_COMMON_ALIAS(I, main_cv);
32855229 624 cv = newXS("B::inc_gv", intrpvar_sv_common, file);
115ff745 625 ASSIGN_COMMON_ALIAS(I, incgv);
32855229 626 cv = newXS("B::defstash", intrpvar_sv_common, file);
115ff745 627 ASSIGN_COMMON_ALIAS(I, defstash);
32855229 628 cv = newXS("B::curstash", intrpvar_sv_common, file);
115ff745 629 ASSIGN_COMMON_ALIAS(I, curstash);
5f7e30c4 630#ifdef PL_formfeed
32855229 631 cv = newXS("B::formfeed", intrpvar_sv_common, file);
115ff745 632 ASSIGN_COMMON_ALIAS(I, formfeed);
5f7e30c4 633#endif
32855229
NC
634#ifdef USE_ITHREADS
635 cv = newXS("B::regex_padav", intrpvar_sv_common, file);
115ff745 636 ASSIGN_COMMON_ALIAS(I, regex_padav);
32855229
NC
637#endif
638 cv = newXS("B::warnhook", intrpvar_sv_common, file);
115ff745 639 ASSIGN_COMMON_ALIAS(I, warnhook);
32855229 640 cv = newXS("B::diehook", intrpvar_sv_common, file);
115ff745 641 ASSIGN_COMMON_ALIAS(I, diehook);
c3890f9c 642 sv = get_sv("B::OP::does_parent", GV_ADDMULTI);
c3890f9c 643#ifdef PERL_OP_PARENT
e1812838 644 sv_setsv(sv, &PL_sv_yes);
c3890f9c 645#else
e1812838 646 sv_setsv(sv, &PL_sv_no);
c3890f9c 647#endif
32855229
NC
648}
649
5f7e30c4
NC
650#ifndef PL_formfeed
651
652void
653formfeed()
654 PPCODE:
655 PUSHs(make_sv_object(aTHX_ GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV))));
656
657#endif
658
7a2c16aa
NC
659long
660amagic_generation()
661 CODE:
662 RETVAL = PL_amagic_generation;
663 OUTPUT:
664 RETVAL
665
8ae5a962 666void
7a2c16aa 667comppadlist()
7261499d
FC
668 PREINIT:
669 PADLIST *padlist = CvPADLIST(PL_main_cv ? PL_main_cv : PL_compcv);
8ae5a962 670 PPCODE:
86d2498c 671#ifdef PadlistARRAY
7261499d
FC
672 {
673 SV * const rv = sv_newmortal();
674 sv_setiv(newSVrv(rv, padlist ? "B::PADLIST" : "B::NULL"),
675 PTR2IV(padlist));
676 PUSHs(rv);
677 }
678#else
679 PUSHs(make_sv_object(aTHX_ (SV *)padlist));
680#endif
7a2c16aa 681
8ae5a962 682void
a4aabc83
NC
683sv_undef()
684 ALIAS:
685 sv_no = 1
686 sv_yes = 2
8ae5a962 687 PPCODE:
0c74f67f
NC
688 PUSHs(make_sv_object(aTHX_ ix > 1 ? &PL_sv_yes
689 : ix < 1 ? &PL_sv_undef
690 : &PL_sv_no));
a4aabc83 691
6079961f 692void
e97701b4
NC
693main_root()
694 ALIAS:
695 main_start = 1
6079961f
NC
696 PPCODE:
697 PUSHs(make_op_object(aTHX_ ix ? PL_main_start : PL_main_root));
e97701b4 698
2edf0c1d
NC
699UV
700sub_generation()
701 ALIAS:
702 dowarn = 1
703 CODE:
704 RETVAL = ix ? PL_dowarn : PL_sub_generation;
705 OUTPUT:
706 RETVAL
707
a8a597b2 708void
20f7624e
NC
709walkoptree(op, method)
710 B::OP op
5d7488b2 711 const char * method
cea2e8a9 712 CODE:
20f7624e 713 (void) walkoptree(aTHX_ op, method, &PL_sv_undef);
a8a597b2
MB
714
715int
716walkoptree_debug(...)
717 CODE:
89ca4ac7 718 dMY_CXT;
a8a597b2
MB
719 RETVAL = walkoptree_debug;
720 if (items > 0 && SvTRUE(ST(1)))
721 walkoptree_debug = 1;
722 OUTPUT:
723 RETVAL
724
56431972 725#define address(sv) PTR2IV(sv)
a8a597b2
MB
726
727IV
728address(sv)
729 SV * sv
730
8ae5a962 731void
a8a597b2
MB
732svref_2object(sv)
733 SV * sv
8ae5a962 734 PPCODE:
a8a597b2
MB
735 if (!SvROK(sv))
736 croak("argument is not a reference");
0c74f67f 737 PUSHs(make_sv_object(aTHX_ SvRV(sv)));
0cc1d052
NIS
738
739void
740opnumber(name)
5d7488b2 741const char * name
0cc1d052
NIS
742CODE:
743{
744 int i;
745 IV result = -1;
746 ST(0) = sv_newmortal();
752602b1 747 if (strEQs(name,"pp_"))
0cc1d052
NIS
748 name += 3;
749 for (i = 0; i < PL_maxo; i++)
750 {
752602b1 751 if (strEQ(name, PL_op_name[i]))
0cc1d052
NIS
752 {
753 result = i;
754 break;
755 }
756 }
757 sv_setiv(ST(0),result);
758}
a8a597b2
MB
759
760void
761ppname(opnum)
762 int opnum
763 CODE:
764 ST(0) = sv_newmortal();
cc5b6bab
NC
765 if (opnum >= 0 && opnum < PL_maxo)
766 Perl_sv_setpvf(aTHX_ ST(0), "pp_%s", PL_op_name[opnum]);
a8a597b2
MB
767
768void
769hash(sv)
770 SV * sv
771 CODE:
a8a597b2
MB
772 STRLEN len;
773 U32 hash = 0;
8c5b7c71 774 const char *s = SvPVbyte(sv, len);
c32d3395 775 PERL_HASH(hash, s, len);
147e3846 776 ST(0) = sv_2mortal(Perl_newSVpvf(aTHX_ "0x%" UVxf, (UV)hash));
a8a597b2
MB
777
778#define cast_I32(foo) (I32)foo
779IV
780cast_I32(i)
781 IV i
782
783void
784minus_c()
651233d2
NC
785 ALIAS:
786 save_BEGINs = 1
a8a597b2 787 CODE:
651233d2
NC
788 if (ix)
789 PL_savebegin = TRUE;
790 else
791 PL_minus_c = TRUE;
059a8bb7 792
847ded71 793void
a8a597b2
MB
794cstring(sv)
795 SV * sv
84556172
NC
796 ALIAS:
797 perlstring = 1
9e380ad4 798 cchar = 2
09e97b95 799 PPCODE:
847ded71 800 PUSHs(ix == 2 ? cchar(aTHX_ sv) : cstring(aTHX_ sv, (bool)ix));
a8a597b2
MB
801
802void
803threadsv_names()
804 PPCODE:
f5ba1307 805
a8a597b2 806
a462fa00
DD
807#ifdef USE_ITHREADS
808void
809CLONE(...)
810PPCODE:
811 PUTBACK; /* some vars go out of scope now in machine code */
812 {
813 MY_CXT_CLONE;
814 B_init_my_cxt(aTHX_ &(MY_CXT));
815 }
816 return; /* dont execute another implied XSPP PUTBACK */
9488fb36 817
a462fa00 818#endif
a9ed1a44 819
fdbacc68 820MODULE = B PACKAGE = B::OP
a8a597b2 821
651aa52e 822
9b1961be
NC
823# The type checking code in B has always been identical for all OP types,
824# irrespective of whether the action is actually defined on that OP.
825# We should fix this
086f9b42 826void
9b1961be 827next(o)
a8a597b2 828 B::OP o
9b1961be 829 ALIAS:
bec746fe
DM
830 B::OP::next = 0
831 B::OP::sibling = 1
832 B::OP::targ = 2
833 B::OP::flags = 3
834 B::OP::private = 4
835 B::UNOP::first = 5
836 B::BINOP::last = 6
837 B::LOGOP::other = 7
838 B::PMOP::pmreplstart = 8
839 B::LOOP::redoop = 9
840 B::LOOP::nextop = 10
841 B::LOOP::lastop = 11
842 B::PMOP::pmflags = 12
843 B::PMOP::code_list = 13
844 B::SVOP::sv = 14
845 B::SVOP::gv = 15
846 B::PADOP::padix = 16
847 B::COP::cop_seq = 17
848 B::COP::line = 18
849 B::COP::hints = 19
850 B::PMOP::pmoffset = 20
851 B::COP::filegv = 21
852 B::COP::file = 22
853 B::COP::stash = 23
854 B::COP::stashpv = 24
855 B::COP::stashoff = 25
287ce0d8
DM
856 B::OP::size = 26
857 B::OP::name = 27
858 B::OP::desc = 28
859 B::OP::ppaddr = 29
860 B::OP::type = 30
861 B::OP::opt = 31
862 B::OP::spare = 32
863 B::LISTOP::children = 33
864 B::PMOP::pmreplroot = 34
865 B::PMOP::pmstashpv = 35
866 B::PMOP::pmstash = 36
867 B::PMOP::precomp = 37
868 B::PMOP::reflags = 38
869 B::PADOP::sv = 39
870 B::PADOP::gv = 40
871 B::PVOP::pv = 41
872 B::COP::label = 42
873 B::COP::arybase = 43
874 B::COP::warnings = 44
875 B::COP::io = 45
876 B::COP::hints_hash = 46
3164fde4
RU
877 B::OP::slabbed = 47
878 B::OP::savefree = 48
879 B::OP::static = 49
880 B::OP::folded = 50
87b5a8b9 881 B::OP::moresib = 51
29e61fd9 882 B::OP::parent = 52
b46e009d 883 B::METHOP::first = 53
884 B::METHOP::meth_sv = 54
429ba3b2 885 B::PMOP::pmregexp = 55
810bd8b7 886 B::METHOP::rclass = 56
9b1961be 887 PREINIT:
086f9b42
NC
888 SV *ret;
889 PPCODE:
99639b5b 890 if (ix < 0 || (U32)ix >= C_ARRAY_LENGTH(op_methods))
287ce0d8 891 croak("Illegal alias %d for B::*OP::next", (int)ix);
71324a3b
DM
892 ret = get_overlay_object(aTHX_ o,
893 op_methods[ix].name, op_methods[ix].namelen);
894 if (ret) {
895 ST(0) = ret;
896 XSRETURN(1);
897 }
bec746fe
DM
898
899 /* handle non-direct field access */
900
0508288e 901 if (op_methods[ix].type == op_offset_special)
bec746fe 902 switch (ix) {
9d28cd7b 903 case 1: /* B::OP::op_sibling */
e6dae479 904 ret = make_op_object(aTHX_ OpSIBLING(o));
1ed44841
DM
905 break;
906
9d28cd7b 907 case 8: /* B::PMOP::pmreplstart */
2721a2ca
DM
908 ret = make_op_object(aTHX_
909 cPMOPo->op_type == OP_SUBST
910 ? cPMOPo->op_pmstashstartu.op_pmreplstart
911 : NULL
912 );
913 break;
bec746fe 914#ifdef USE_ITHREADS
9d28cd7b 915 case 21: /* B::COP::filegv */
bec746fe
DM
916 ret = make_sv_object(aTHX_ (SV *)CopFILEGV((COP*)o));
917 break;
918#endif
1dc74fdb 919#ifndef USE_ITHREADS
9d28cd7b 920 case 22: /* B::COP::file */
bec746fe
DM
921 ret = sv_2mortal(newSVpv(CopFILE((COP*)o), 0));
922 break;
923#endif
924#ifdef USE_ITHREADS
9d28cd7b 925 case 23: /* B::COP::stash */
bec746fe
DM
926 ret = make_sv_object(aTHX_ (SV *)CopSTASH((COP*)o));
927 break;
928#endif
9d28cd7b 929 case 24: /* B::COP::stashpv */
bec746fe
DM
930 ret = sv_2mortal(CopSTASH((COP*)o)
931 && SvTYPE(CopSTASH((COP*)o)) == SVt_PVHV
932 ? newSVhek(HvNAME_HEK(CopSTASH((COP*)o)))
933 : &PL_sv_undef);
bec746fe 934 break;
9d28cd7b 935 case 26: /* B::OP::size */
1e85b658 936 ret = sv_2mortal(newSVuv((UV)(opsizes[op_class(o)])));
287ce0d8 937 break;
9d28cd7b
DM
938 case 27: /* B::OP::name */
939 case 28: /* B::OP::desc */
287ce0d8
DM
940 ret = sv_2mortal(newSVpv(
941 (char *)(ix == 28 ? OP_DESC(o) : OP_NAME(o)), 0));
942 break;
9d28cd7b 943 case 29: /* B::OP::ppaddr */
287ce0d8
DM
944 {
945 int i;
946 ret = sv_2mortal(Perl_newSVpvf(aTHX_ "PL_ppaddr[OP_%s]",
947 PL_op_name[o->op_type]));
948 for (i=13; (STRLEN)i < SvCUR(ret); ++i)
949 SvPVX(ret)[i] = toUPPER(SvPVX(ret)[i]);
950 }
951 break;
9d28cd7b
DM
952 case 30: /* B::OP::type */
953 case 31: /* B::OP::opt */
954 case 32: /* B::OP::spare */
9d28cd7b
DM
955 case 47: /* B::OP::slabbed */
956 case 48: /* B::OP::savefree */
957 case 49: /* B::OP::static */
9d28cd7b 958 case 50: /* B::OP::folded */
87b5a8b9 959 case 51: /* B::OP::moresib */
3164fde4 960 /* These are all bitfields, so we can't take their addresses */
287ce0d8
DM
961 ret = sv_2mortal(newSVuv((UV)(
962 ix == 30 ? o->op_type
963 : ix == 31 ? o->op_opt
3164fde4
RU
964 : ix == 47 ? o->op_slabbed
965 : ix == 48 ? o->op_savefree
966 : ix == 49 ? o->op_static
967 : ix == 50 ? o->op_folded
87b5a8b9 968 : ix == 51 ? o->op_moresib
287ce0d8
DM
969 : o->op_spare)));
970 break;
9d28cd7b 971 case 33: /* B::LISTOP::children */
287ce0d8
DM
972 {
973 OP *kid;
974 UV i = 0;
e6dae479 975 for (kid = ((LISTOP*)o)->op_first; kid; kid = OpSIBLING(kid))
287ce0d8
DM
976 i++;
977 ret = sv_2mortal(newSVuv(i));
978 }
979 break;
9d28cd7b 980 case 34: /* B::PMOP::pmreplroot */
5012eebe 981 if (cPMOPo->op_type == OP_SPLIT) {
287ce0d8 982 ret = sv_newmortal();
5012eebe
DM
983#ifndef USE_ITHREADS
984 if (o->op_private & OPpSPLIT_LEX)
985#endif
986 sv_setiv(ret, cPMOPo->op_pmreplrootu.op_pmtargetoff);
987#ifndef USE_ITHREADS
988 else {
989 GV *const target = cPMOPo->op_pmreplrootu.op_pmtargetgv;
990 sv_setiv(newSVrv(ret, target ?
991 svclassnames[SvTYPE((SV*)target)] : "B::SV"),
992 PTR2IV(target));
993 }
287ce0d8
DM
994#endif
995 }
996 else {
997 OP *const root = cPMOPo->op_pmreplrootu.op_pmreplroot;
998 ret = make_op_object(aTHX_ root);
999 }
1000 break;
1001#ifdef USE_ITHREADS
9d28cd7b 1002 case 35: /* B::PMOP::pmstashpv */
287ce0d8
DM
1003 ret = sv_2mortal(newSVpv(PmopSTASHPV(cPMOPo),0));
1004 break;
1005#else
9d28cd7b 1006 case 36: /* B::PMOP::pmstash */
287ce0d8
DM
1007 ret = make_sv_object(aTHX_ (SV *) PmopSTASH(cPMOPo));
1008 break;
1009#endif
9d28cd7b
DM
1010 case 37: /* B::PMOP::precomp */
1011 case 38: /* B::PMOP::reflags */
287ce0d8
DM
1012 {
1013 REGEXP *rx = PM_GETRE(cPMOPo);
1014 ret = sv_newmortal();
1015 if (rx) {
1016 if (ix==38) {
1017 sv_setuv(ret, RX_EXTFLAGS(rx));
1018 }
1019 else {
1020 sv_setpvn(ret, RX_PRECOMP(rx), RX_PRELEN(rx));
fea7fb25
DM
1021 if (RX_UTF8(rx))
1022 SvUTF8_on(ret);
287ce0d8
DM
1023 }
1024 }
1025 }
1026 break;
3a23d767
DM
1027 case 39: /* B::PADOP::sv */
1028 case 40: /* B::PADOP::gv */
1029 /* PADOPs should only be created on threaded builds.
1030 * They don't have an sv or gv field, just an op_padix
1031 * field. Leave it to the caller to retrieve padix
1032 * and look up th value in the pad. Don't do it here,
1033 * becuase PL_curpad is the pad of the caller, not the
1034 * pad of the sub the op is part of */
1035 ret = make_sv_object(aTHX_ NULL);
287ce0d8 1036 break;
9d28cd7b 1037 case 41: /* B::PVOP::pv */
287ce0d8
DM
1038 /* OP_TRANS uses op_pv to point to a table of 256 or >=258
1039 * shorts whereas other PVOPs point to a null terminated
1040 * string. */
1041 if ( (cPVOPo->op_type == OP_TRANS
1042 || cPVOPo->op_type == OP_TRANSR) &&
1043 (cPVOPo->op_private & OPpTRANS_COMPLEMENT) &&
1044 !(cPVOPo->op_private & OPpTRANS_DELETE))
1045 {
1046 const short* const tbl = (short*)cPVOPo->op_pv;
1047 const short entries = 257 + tbl[256];
1048 ret = newSVpvn_flags(cPVOPo->op_pv, entries * sizeof(short), SVs_TEMP);
1049 }
1050 else if (cPVOPo->op_type == OP_TRANS || cPVOPo->op_type == OP_TRANSR) {
1051 ret = newSVpvn_flags(cPVOPo->op_pv, 256 * sizeof(short), SVs_TEMP);
1052 }
1053 else
1054 ret = newSVpvn_flags(cPVOPo->op_pv, strlen(cPVOPo->op_pv), SVs_TEMP);
1055 break;
9d28cd7b 1056 case 42: /* B::COP::label */
287ce0d8
DM
1057 ret = sv_2mortal(newSVpv(CopLABEL(cCOPo),0));
1058 break;
9d28cd7b 1059 case 43: /* B::COP::arybase */
287ce0d8
DM
1060 ret = sv_2mortal(newSVuv(0));
1061 break;
9d28cd7b 1062 case 44: /* B::COP::warnings */
287ce0d8
DM
1063 ret = make_warnings_object(aTHX_ cCOPo);
1064 break;
9d28cd7b 1065 case 45: /* B::COP::io */
287ce0d8
DM
1066 ret = make_cop_io_object(aTHX_ cCOPo);
1067 break;
9d28cd7b 1068 case 46: /* B::COP::hints_hash */
287ce0d8
DM
1069 ret = sv_newmortal();
1070 sv_setiv(newSVrv(ret, "B::RHE"),
1071 PTR2IV(CopHINTHASH_get(cCOPo)));
1072 break;
9d28cd7b 1073 case 52: /* B::OP::parent */
1fafe688 1074#ifdef PERL_OP_PARENT
29e61fd9 1075 ret = make_op_object(aTHX_ op_parent(o));
1fafe688
DM
1076#else
1077 ret = make_op_object(aTHX_ NULL);
1078#endif
29e61fd9 1079 break;
b46e009d 1080 case 53: /* B::METHOP::first */
1081 /* METHOP struct has an op_first/op_meth_sv union
1082 * as its first extra field. How to interpret the
1083 * union depends on the op type. For the purposes of
1084 * B, we treat it as a struct with both fields present,
1085 * where one of the fields always happens to be null
1086 * (i.e. we return NULL in preference to croaking with
1087 * 'method not implemented').
1088 */
1089 ret = make_op_object(aTHX_
1090 o->op_type == OP_METHOD
1091 ? cMETHOPx(o)->op_u.op_first : NULL);
1092 break;
1093 case 54: /* B::METHOP::meth_sv */
1094 /* see comment above about METHOP */
1095 ret = make_sv_object(aTHX_
1096 o->op_type == OP_METHOD
1097 ? NULL : cMETHOPx(o)->op_u.op_meth_sv);
1098 break;
429ba3b2
FC
1099 case 55: /* B::PMOP::pmregexp */
1100 ret = make_sv_object(aTHX_ (SV *)PM_GETRE(cPMOPo));
1101 break;
810bd8b7 1102 case 56: /* B::METHOP::rclass */
1103#ifdef USE_ITHREADS
1104 ret = sv_2mortal(newSVuv(
1105 (o->op_type == OP_METHOD_REDIR ||
1106 o->op_type == OP_METHOD_REDIR_SUPER) ?
1107 cMETHOPx(o)->op_rclass_targ : 0
1108 ));
1109#else
1110 ret = make_sv_object(aTHX_
1111 (o->op_type == OP_METHOD_REDIR ||
1112 o->op_type == OP_METHOD_REDIR_SUPER) ?
1113 cMETHOPx(o)->op_rclass_sv : NULL
1114 );
1115#endif
1116 break;
bec746fe
DM
1117 default:
1118 croak("method %s not implemented", op_methods[ix].name);
0508288e
NC
1119 } else {
1120 /* do a direct structure offset lookup */
1121 const char *const ptr = (char *)o + op_methods[ix].offset;
f68c0b4a
NC
1122 switch (op_methods[ix].type) {
1123 case OPp:
1124 ret = make_op_object(aTHX_ *((OP **)ptr));
1125 break;
1126 case PADOFFSETp:
1127 ret = sv_2mortal(newSVuv(*((PADOFFSET*)ptr)));
1128 break;
1129 case U8p:
1130 ret = sv_2mortal(newSVuv(*((U8*)ptr)));
1131 break;
1132 case U32p:
1133 ret = sv_2mortal(newSVuv(*((U32*)ptr)));
1134 break;
1135 case SVp:
1136 ret = make_sv_object(aTHX_ *((SV **)ptr));
1137 break;
1138 case line_tp:
1139 ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
1140 break;
1141 case IVp:
1142 ret = sv_2mortal(newSViv(*((IV*)ptr)));
1143 break;
1144 case char_pp:
1145 ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
1146 break;
1147 default:
0508288e 1148 croak("Illegal type 0x%x for B::*OP::%s",
f68c0b4a 1149 (unsigned)op_methods[ix].type, op_methods[ix].name);
0508288e 1150 }
086f9b42
NC
1151 }
1152 ST(0) = ret;
1153 XSRETURN(1);
a8a597b2 1154
7252851f 1155
1df34986 1156void
fdbacc68 1157oplist(o)
1df34986
AE
1158 B::OP o
1159 PPCODE:
1160 SP = oplist(aTHX_ o, SP);
1161
e412117e 1162
2f7c6295
DM
1163
1164MODULE = B PACKAGE = B::UNOP_AUX
1165
1166# UNOP_AUX class ops are like UNOPs except that they have an extra
1167# op_aux pointer that points to an array of UNOP_AUX_item unions.
1168# Element -1 of the array contains the length
1169
1170
1171# return a string representation of op_aux where possible The op's CV is
1172# needed as an extra arg to allow GVs and SVs moved into the pad to be
1173# accessed okay.
1174
1175void
1176string(o, cv)
1177 B::OP o
1178 B::CV cv
1179 PREINIT:
1180 SV *ret;
4fa06845 1181 UNOP_AUX_item *aux;
2f7c6295 1182 PPCODE:
4fa06845 1183 aux = cUNOP_AUXo->op_aux;
2f7c6295 1184 switch (o->op_type) {
fedf30e1 1185 case OP_MULTIDEREF:
48ee9c0e 1186 ret = multideref_stringify(o, cv);
fedf30e1 1187 break;
4fa06845
DM
1188
1189 case OP_ARGELEM:
147e3846 1190 ret = sv_2mortal(Perl_newSVpvf(aTHX_ "%" IVdf,
6daeaaa3 1191 PTR2IV(aux)));
4fa06845
DM
1192 break;
1193
1194 case OP_ARGCHECK:
147e3846 1195 ret = Perl_newSVpvf(aTHX_ "%" IVdf ",%" IVdf, aux[0].iv, aux[1].iv);
4fa06845
DM
1196 if (aux[2].iv)
1197 Perl_sv_catpvf(aTHX_ ret, ",%c", (char)aux[2].iv);
1198 ret = sv_2mortal(ret);
1199 break;
1200
2f7c6295
DM
1201 default:
1202 ret = sv_2mortal(newSVpvn("", 0));
1203 }
4fa06845 1204
2f7c6295
DM
1205 ST(0) = ret;
1206 XSRETURN(1);
1207
1208
1209# Return the contents of the op_aux array as a list of IV/GV/etc objects.
1210# How to interpret each array element is op-dependent. The op's CV is
1211# needed as an extra arg to allow GVs and SVs which have been moved into
1212# the pad to be accessed okay.
1213
1214void
1215aux_list(o, cv)
1216 B::OP o
1217 B::CV cv
4fa06845
DM
1218 PREINIT:
1219 UNOP_AUX_item *aux;
2f7c6295 1220 PPCODE:
fedf30e1 1221 PERL_UNUSED_VAR(cv); /* not needed on unthreaded builds */
4fa06845 1222 aux = cUNOP_AUXo->op_aux;
2f7c6295
DM
1223 switch (o->op_type) {
1224 default:
1225 XSRETURN(0); /* by default, an empty list */
fedf30e1 1226
4fa06845 1227 case OP_ARGELEM:
6daeaaa3 1228 XPUSHs(sv_2mortal(newSViv(PTR2IV(aux))));
4fa06845
DM
1229 XSRETURN(1);
1230 break;
1231
1232 case OP_ARGCHECK:
1233 EXTEND(SP, 3);
6daeaaa3
DM
1234 PUSHs(sv_2mortal(newSViv(aux[0].iv)));
1235 PUSHs(sv_2mortal(newSViv(aux[1].iv)));
4fa06845
DM
1236 PUSHs(sv_2mortal(aux[2].iv ? Perl_newSVpvf(aTHX_ "%c",
1237 (char)aux[2].iv) : &PL_sv_no));
1238 break;
1239
fedf30e1
DM
1240 case OP_MULTIDEREF:
1241#ifdef USE_ITHREADS
1242# define ITEM_SV(item) *av_fetch(comppad, (item)->pad_offset, FALSE);
1243#else
1244# define ITEM_SV(item) UNOP_AUX_item_sv(item)
1245#endif
1246 {
1247 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1248 UV actions = items->uv;
1249 UV len = items[-1].uv;
1250 SV *sv;
1251 bool last = 0;
1252 bool is_hash = FALSE;
1253#ifdef USE_ITHREADS
1254 PADLIST * const padlist = CvPADLIST(cv);
9cdf4efd 1255 PAD *comppad = PadlistARRAY(padlist)[1];
fedf30e1
DM
1256#endif
1257
052a7c76
DM
1258 /* len should never be big enough to truncate or wrap */
1259 assert(len <= SSize_t_MAX);
1260 EXTEND(SP, (SSize_t)len);
fedf30e1
DM
1261 PUSHs(sv_2mortal(newSViv(actions)));
1262
1263 while (!last) {
1264 switch (actions & MDEREF_ACTION_MASK) {
1265
1266 case MDEREF_reload:
1267 actions = (++items)->uv;
1268 PUSHs(sv_2mortal(newSVuv(actions)));
1269 continue;
2b5060ae 1270 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM
1271
1272 case MDEREF_HV_padhv_helem:
1273 is_hash = TRUE;
2b5060ae 1274 /* FALLTHROUGH */
fedf30e1
DM
1275 case MDEREF_AV_padav_aelem:
1276 PUSHs(sv_2mortal(newSVuv((++items)->pad_offset)));
1277 goto do_elem;
2b5060ae 1278 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM
1279
1280 case MDEREF_HV_gvhv_helem:
1281 is_hash = TRUE;
2b5060ae 1282 /* FALLTHROUGH */
fedf30e1
DM
1283 case MDEREF_AV_gvav_aelem:
1284 sv = ITEM_SV(++items);
1285 PUSHs(make_sv_object(aTHX_ sv));
1286 goto do_elem;
2b5060ae 1287 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM
1288
1289 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1290 is_hash = TRUE;
2b5060ae 1291 /* FALLTHROUGH */
fedf30e1
DM
1292 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1293 sv = ITEM_SV(++items);
1294 PUSHs(make_sv_object(aTHX_ sv));
1295 goto do_vivify_rv2xv_elem;
2b5060ae 1296 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM
1297
1298 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1299 is_hash = TRUE;
2b5060ae 1300 /* FALLTHROUGH */
fedf30e1
DM
1301 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1302 PUSHs(sv_2mortal(newSVuv((++items)->pad_offset)));
1303 goto do_vivify_rv2xv_elem;
2b5060ae 1304 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM
1305
1306 case MDEREF_HV_pop_rv2hv_helem:
1307 case MDEREF_HV_vivify_rv2hv_helem:
1308 is_hash = TRUE;
2b5060ae 1309 /* FALLTHROUGH */
fedf30e1
DM
1310 do_vivify_rv2xv_elem:
1311 case MDEREF_AV_pop_rv2av_aelem:
1312 case MDEREF_AV_vivify_rv2av_aelem:
1313 do_elem:
1314 switch (actions & MDEREF_INDEX_MASK) {
1315 case MDEREF_INDEX_none:
1316 last = 1;
1317 break;
1318 case MDEREF_INDEX_const:
1319 if (is_hash) {
1320 sv = ITEM_SV(++items);
1321 PUSHs(make_sv_object(aTHX_ sv));
1322 }
1323 else
1324 PUSHs(sv_2mortal(newSViv((++items)->iv)));
1325 break;
1326 case MDEREF_INDEX_padsv:
1327 PUSHs(sv_2mortal(newSVuv((++items)->pad_offset)));
1328 break;
1329 case MDEREF_INDEX_gvsv:
1330 sv = ITEM_SV(++items);
1331 PUSHs(make_sv_object(aTHX_ sv));
1332 break;
1333 }
1334 if (actions & MDEREF_FLAG_last)
1335 last = 1;
1336 is_hash = FALSE;
1337
1338 break;
1339 } /* switch */
1340
1341 actions >>= MDEREF_SHIFT;
1342 } /* while */
1343 XSRETURN(len);
1344
1345 } /* OP_MULTIDEREF */
2f7c6295
DM
1346 } /* switch */
1347
1348
1349
651aa52e
AE
1350MODULE = B PACKAGE = B::SV
1351
de64752d
NC
1352#define MAGICAL_FLAG_BITS (SVs_GMG|SVs_SMG|SVs_RMG)
1353
651aa52e 1354U32
de64752d 1355REFCNT(sv)
651aa52e 1356 B::SV sv
de64752d
NC
1357 ALIAS:
1358 FLAGS = 0xFFFFFFFF
1359 SvTYPE = SVTYPEMASK
1360 POK = SVf_POK
1361 ROK = SVf_ROK
1362 MAGICAL = MAGICAL_FLAG_BITS
1363 CODE:
1364 RETVAL = ix ? (SvFLAGS(sv) & (U32)ix) : SvREFCNT(sv);
1365 OUTPUT:
1366 RETVAL
651aa52e 1367
9efba5c8 1368void
429a5ce7
SM
1369object_2svref(sv)
1370 B::SV sv
9efba5c8
NC
1371 PPCODE:
1372 ST(0) = sv_2mortal(newRV(sv));
1373 XSRETURN(1);
1374
a8a597b2
MB
1375MODULE = B PACKAGE = B::IV PREFIX = Sv
1376
1377IV
1378SvIV(sv)
1379 B::IV sv
1380
e4da9d6a 1381MODULE = B PACKAGE = B::IV
a8a597b2 1382
e4da9d6a
NC
1383#define sv_SVp 0x00000
1384#define sv_IVp 0x10000
1385#define sv_UVp 0x20000
1386#define sv_STRLENp 0x30000
1387#define sv_U32p 0x40000
1388#define sv_U8p 0x50000
1389#define sv_char_pp 0x60000
1390#define sv_NVp 0x70000
6782c6e0 1391#define sv_char_p 0x80000
3da43c35 1392#define sv_SSize_tp 0x90000
ffc5d9fc
NC
1393#define sv_I32p 0xA0000
1394#define sv_U16p 0xB0000
e4da9d6a 1395
3800c318
JH
1396#define IV_ivx_ix sv_IVp | STRUCT_OFFSET(struct xpviv, xiv_iv)
1397#define IV_uvx_ix sv_UVp | STRUCT_OFFSET(struct xpvuv, xuv_uv)
1398#define NV_nvx_ix sv_NVp | STRUCT_OFFSET(struct xpvnv, xnv_u.xnv_nv)
e4da9d6a 1399
3800c318
JH
1400#define PV_cur_ix sv_STRLENp | STRUCT_OFFSET(struct xpv, xpv_cur)
1401#define PV_len_ix sv_STRLENp | STRUCT_OFFSET(struct xpv, xpv_len)
6782c6e0 1402
3800c318 1403#define PVMG_stash_ix sv_SVp | STRUCT_OFFSET(struct xpvmg, xmg_stash)
6782c6e0 1404
9ca4b7ea 1405#define PVBM_useful_ix sv_IVp | STRUCT_OFFSET(struct xpviv, xiv_u.xivu_iv)
91a71e08 1406
3800c318
JH
1407#define PVLV_targoff_ix sv_U32p | STRUCT_OFFSET(struct xpvlv, xlv_targoff)
1408#define PVLV_targlen_ix sv_U32p | STRUCT_OFFSET(struct xpvlv, xlv_targlen)
1409#define PVLV_targ_ix sv_SVp | STRUCT_OFFSET(struct xpvlv, xlv_targ)
1410#define PVLV_type_ix sv_char_p | STRUCT_OFFSET(struct xpvlv, xlv_type)
1411
1412#define PVGV_stash_ix sv_SVp | STRUCT_OFFSET(struct xpvgv, xnv_u.xgv_stash)
1413#define PVGV_flags_ix sv_STRLENp | STRUCT_OFFSET(struct xpvgv, xpv_cur)
1414#define PVIO_lines_ix sv_IVp | STRUCT_OFFSET(struct xpvio, xiv_iv)
1415
1416#define PVIO_page_ix sv_IVp | STRUCT_OFFSET(struct xpvio, xio_page)
1417#define PVIO_page_len_ix sv_IVp | STRUCT_OFFSET(struct xpvio, xio_page_len)
1418#define PVIO_lines_left_ix sv_IVp | STRUCT_OFFSET(struct xpvio, xio_lines_left)
1419#define PVIO_top_name_ix sv_char_pp | STRUCT_OFFSET(struct xpvio, xio_top_name)
1420#define PVIO_top_gv_ix sv_SVp | STRUCT_OFFSET(struct xpvio, xio_top_gv)
1421#define PVIO_fmt_name_ix sv_char_pp | STRUCT_OFFSET(struct xpvio, xio_fmt_name)
1422#define PVIO_fmt_gv_ix sv_SVp | STRUCT_OFFSET(struct xpvio, xio_fmt_gv)
1423#define PVIO_bottom_name_ix sv_char_pp | STRUCT_OFFSET(struct xpvio, xio_bottom_name)
1424#define PVIO_bottom_gv_ix sv_SVp | STRUCT_OFFSET(struct xpvio, xio_bottom_gv)
1425#define PVIO_type_ix sv_char_p | STRUCT_OFFSET(struct xpvio, xio_type)
1426#define PVIO_flags_ix sv_U8p | STRUCT_OFFSET(struct xpvio, xio_flags)
1427
1428#define PVAV_max_ix sv_SSize_tp | STRUCT_OFFSET(struct xpvav, xav_max)
1429
1430#define PVCV_stash_ix sv_SVp | STRUCT_OFFSET(struct xpvcv, xcv_stash)
9ca4b7ea 1431#define PVCV_gv_ix sv_SVp | STRUCT_OFFSET(struct xpvcv, xcv_gv_u.xcv_gv)
3800c318
JH
1432#define PVCV_file_ix sv_char_pp | STRUCT_OFFSET(struct xpvcv, xcv_file)
1433#define PVCV_outside_ix sv_SVp | STRUCT_OFFSET(struct xpvcv, xcv_outside)
1434#define PVCV_outside_seq_ix sv_U32p | STRUCT_OFFSET(struct xpvcv, xcv_outside_seq)
1435#define PVCV_flags_ix sv_U32p | STRUCT_OFFSET(struct xpvcv, xcv_flags)
ffc5d9fc 1436
3800c318 1437#define PVHV_max_ix sv_STRLENp | STRUCT_OFFSET(struct xpvhv, xhv_max)
3800c318 1438#define PVHV_keys_ix sv_STRLENp | STRUCT_OFFSET(struct xpvhv, xhv_keys)
d65a2b0a 1439
e4da9d6a
NC
1440# The type checking code in B has always been identical for all SV types,
1441# irrespective of whether the action is actually defined on that SV.
1442# We should fix this
1443void
1444IVX(sv)
1445 B::SV sv
1446 ALIAS:
1447 B::IV::IVX = IV_ivx_ix
1448 B::IV::UVX = IV_uvx_ix
1449 B::NV::NVX = NV_nvx_ix
6782c6e0
NC
1450 B::PV::CUR = PV_cur_ix
1451 B::PV::LEN = PV_len_ix
1452 B::PVMG::SvSTASH = PVMG_stash_ix
1453 B::PVLV::TARGOFF = PVLV_targoff_ix
1454 B::PVLV::TARGLEN = PVLV_targlen_ix
1455 B::PVLV::TARG = PVLV_targ_ix
1456 B::PVLV::TYPE = PVLV_type_ix
f1f19364
NC
1457 B::GV::STASH = PVGV_stash_ix
1458 B::GV::GvFLAGS = PVGV_flags_ix
91a71e08 1459 B::BM::USEFUL = PVBM_useful_ix
55440d31
NC
1460 B::IO::LINES = PVIO_lines_ix
1461 B::IO::PAGE = PVIO_page_ix
1462 B::IO::PAGE_LEN = PVIO_page_len_ix
1463 B::IO::LINES_LEFT = PVIO_lines_left_ix
1464 B::IO::TOP_NAME = PVIO_top_name_ix
1465 B::IO::TOP_GV = PVIO_top_gv_ix
1466 B::IO::FMT_NAME = PVIO_fmt_name_ix
1467 B::IO::FMT_GV = PVIO_fmt_gv_ix
1468 B::IO::BOTTOM_NAME = PVIO_bottom_name_ix
1469 B::IO::BOTTOM_GV = PVIO_bottom_gv_ix
1470 B::IO::IoTYPE = PVIO_type_ix
1471 B::IO::IoFLAGS = PVIO_flags_ix
3da43c35 1472 B::AV::MAX = PVAV_max_ix
ffc5d9fc 1473 B::CV::STASH = PVCV_stash_ix
ffc5d9fc 1474 B::CV::FILE = PVCV_file_ix
ffc5d9fc
NC
1475 B::CV::OUTSIDE = PVCV_outside_ix
1476 B::CV::OUTSIDE_SEQ = PVCV_outside_seq_ix
1477 B::CV::CvFLAGS = PVCV_flags_ix
d65a2b0a
NC
1478 B::HV::MAX = PVHV_max_ix
1479 B::HV::KEYS = PVHV_keys_ix
e4da9d6a
NC
1480 PREINIT:
1481 char *ptr;
1482 SV *ret;
1483 PPCODE:
1484 ptr = (ix & 0xFFFF) + (char *)SvANY(sv);
1485 switch ((U8)(ix >> 16)) {
1486 case (U8)(sv_SVp >> 16):
428744c7 1487 ret = make_sv_object(aTHX_ *((SV **)ptr));
e4da9d6a
NC
1488 break;
1489 case (U8)(sv_IVp >> 16):
1490 ret = sv_2mortal(newSViv(*((IV *)ptr)));
1491 break;
1492 case (U8)(sv_UVp >> 16):
1493 ret = sv_2mortal(newSVuv(*((UV *)ptr)));
1494 break;
6782c6e0
NC
1495 case (U8)(sv_STRLENp >> 16):
1496 ret = sv_2mortal(newSVuv(*((STRLEN *)ptr)));
1497 break;
e4da9d6a
NC
1498 case (U8)(sv_U32p >> 16):
1499 ret = sv_2mortal(newSVuv(*((U32 *)ptr)));
1500 break;
1501 case (U8)(sv_U8p >> 16):
1502 ret = sv_2mortal(newSVuv(*((U8 *)ptr)));
1503 break;
1504 case (U8)(sv_char_pp >> 16):
1505 ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
1506 break;
1507 case (U8)(sv_NVp >> 16):
1508 ret = sv_2mortal(newSVnv(*((NV *)ptr)));
1509 break;
6782c6e0
NC
1510 case (U8)(sv_char_p >> 16):
1511 ret = newSVpvn_flags((char *)ptr, 1, SVs_TEMP);
1512 break;
3da43c35
NC
1513 case (U8)(sv_SSize_tp >> 16):
1514 ret = sv_2mortal(newSViv(*((SSize_t *)ptr)));
1515 break;
ffc5d9fc
NC
1516 case (U8)(sv_I32p >> 16):
1517 ret = sv_2mortal(newSVuv(*((I32 *)ptr)));
1518 break;
1519 case (U8)(sv_U16p >> 16):
1520 ret = sv_2mortal(newSVuv(*((U16 *)ptr)));
1521 break;
c33e8be1
Z
1522 default:
1523 croak("Illegal alias 0x%08x for B::*IVX", (unsigned)ix);
e4da9d6a
NC
1524 }
1525 ST(0) = ret;
1526 XSRETURN(1);
a8a597b2 1527
a8a597b2
MB
1528void
1529packiv(sv)
1530 B::IV sv
6829f5e2
NC
1531 ALIAS:
1532 needs64bits = 1
a8a597b2 1533 CODE:
6829f5e2
NC
1534 if (ix) {
1535 ST(0) = boolSV((I32)SvIVX(sv) != SvIVX(sv));
1536 } else if (sizeof(IV) == 8) {
a8a597b2 1537 U32 wp[2];
5d7488b2 1538 const IV iv = SvIVX(sv);
a8a597b2
MB
1539 /*
1540 * The following way of spelling 32 is to stop compilers on
1541 * 32-bit architectures from moaning about the shift count
1542 * being >= the width of the type. Such architectures don't
1543 * reach this code anyway (unless sizeof(IV) > 8 but then
1544 * everything else breaks too so I'm not fussed at the moment).
1545 */
42718184
RB
1546#ifdef UV_IS_QUAD
1547 wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1548#else
1549 wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1550#endif
a8a597b2 1551 wp[1] = htonl(iv & 0xffffffff);
d3d34884 1552 ST(0) = newSVpvn_flags((char *)wp, 8, SVs_TEMP);
a8a597b2
MB
1553 } else {
1554 U32 w = htonl((U32)SvIVX(sv));
d3d34884 1555 ST(0) = newSVpvn_flags((char *)&w, 4, SVs_TEMP);
a8a597b2
MB
1556 }
1557
1558MODULE = B PACKAGE = B::NV PREFIX = Sv
1559
76ef7183 1560NV
a8a597b2
MB
1561SvNV(sv)
1562 B::NV sv
1563
89c6bc13
NC
1564MODULE = B PACKAGE = B::REGEXP
1565
154b8842 1566void
81e413dd 1567REGEX(sv)
89c6bc13 1568 B::REGEXP sv
81e413dd
NC
1569 ALIAS:
1570 precomp = 1
6190dd99 1571 qr_anoncv = 2
1f306347 1572 compflags = 3
154b8842 1573 PPCODE:
6190dd99 1574 if (ix == 1) {
81e413dd 1575 PUSHs(newSVpvn_flags(RX_PRECOMP(sv), RX_PRELEN(sv), SVs_TEMP));
1f306347 1576 } else if (ix == 2) {
6190dd99 1577 PUSHs(make_sv_object(aTHX_ (SV *)ReANY(sv)->qr_anoncv));
81e413dd
NC
1578 } else {
1579 dXSTARG;
17d6506d
DD
1580 if (ix)
1581 PUSHu(RX_COMPFLAGS(sv));
1582 else
81e413dd 1583 /* FIXME - can we code this method more efficiently? */
17d6506d 1584 PUSHi(PTR2IV(sv));
81e413dd 1585 }
89c6bc13 1586
fdbacc68 1587MODULE = B PACKAGE = B::PV
a8a597b2 1588
8ae5a962 1589void
fdbacc68 1590RV(sv)
b326da91 1591 B::PV sv
8ae5a962
NC
1592 PPCODE:
1593 if (!SvROK(sv))
b326da91 1594 croak( "argument is not SvROK" );
0c74f67f 1595 PUSHs(make_sv_object(aTHX_ SvRV(sv)));
b326da91 1596
a8a597b2 1597void
fdbacc68 1598PV(sv)
a8a597b2 1599 B::PV sv
3d665704
NC
1600 ALIAS:
1601 PVX = 1
f4c36584 1602 PVBM = 2
84fea184 1603 B::BM::TABLE = 3
a804b0fe
NC
1604 PREINIT:
1605 const char *p;
1606 STRLEN len = 0;
1607 U32 utf8 = 0;
a8a597b2 1608 CODE:
84fea184 1609 if (ix == 3) {
2bda37ba
NC
1610#ifndef PERL_FBM_TABLE_OFFSET
1611 const MAGIC *const mg = mg_find(sv, PERL_MAGIC_bm);
1612
1613 if (!mg)
1614 croak("argument to B::BM::TABLE is not a PVBM");
1615 p = mg->mg_ptr;
1616 len = mg->mg_len;
1617#else
84fea184
NC
1618 p = SvPV(sv, len);
1619 /* Boyer-Moore table is just after string and its safety-margin \0 */
1620 p += len + PERL_FBM_TABLE_OFFSET;
1621 len = 256;
2bda37ba 1622#endif
84fea184 1623 } else if (ix == 2) {
f4c36584 1624 /* This used to read 257. I think that that was buggy - should have
26ec7981
NC
1625 been 258. (The "\0", the flags byte, and 256 for the table.)
1626 The only user of this method is B::Bytecode in B::PV::bsave.
1627 I'm guessing that nothing tested the runtime correctness of
1628 output of bytecompiled string constant arguments to index (etc).
1629
1630 Note the start pointer is and has always been SvPVX(sv), not
1631 SvPVX(sv) + SvCUR(sv) PVBM was added in 651aa52ea1faa806, and
1632 first used by the compiler in 651aa52ea1faa806. It's used to
1633 get a "complete" dump of the buffer at SvPVX(), not just the
1634 PVBM table. This permits the generated bytecode to "load"
2bda37ba
NC
1635 SvPVX in "one" hit.
1636
1637 5.15 and later store the BM table via MAGIC, so the compiler
1638 should handle this just fine without changes if PVBM now
1639 always returns the SvPVX() buffer. */
8d919b0a
FC
1640#ifdef isREGEXP
1641 p = isREGEXP(sv)
1642 ? RX_WRAPPED_const((REGEXP*)sv)
1643 : SvPVX_const(sv);
1644#else
f4c36584 1645 p = SvPVX_const(sv);
8d919b0a 1646#endif
2bda37ba 1647#ifdef PERL_FBM_TABLE_OFFSET
f4c36584 1648 len = SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0);
2bda37ba
NC
1649#else
1650 len = SvCUR(sv);
1651#endif
f4c36584 1652 } else if (ix) {
8d919b0a
FC
1653#ifdef isREGEXP
1654 p = isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX(sv);
1655#else
3d665704 1656 p = SvPVX(sv);
8d919b0a 1657#endif
3d665704
NC
1658 len = strlen(p);
1659 } else if (SvPOK(sv)) {
a804b0fe
NC
1660 len = SvCUR(sv);
1661 p = SvPVX_const(sv);
1662 utf8 = SvUTF8(sv);
b326da91 1663 }
8d919b0a
FC
1664#ifdef isREGEXP
1665 else if (isREGEXP(sv)) {
1666 len = SvCUR(sv);
1667 p = RX_WRAPPED_const((REGEXP*)sv);
1668 utf8 = SvUTF8(sv);
1669 }
1670#endif
b326da91
MB
1671 else {
1672 /* XXX for backward compatibility, but should fail */
1673 /* croak( "argument is not SvPOK" ); */
a804b0fe 1674 p = NULL;
b326da91 1675 }
a804b0fe 1676 ST(0) = newSVpvn_flags(p, len, SVs_TEMP | utf8);
a8a597b2 1677
fdbacc68 1678MODULE = B PACKAGE = B::PVMG
a8a597b2
MB
1679
1680void
fdbacc68 1681MAGIC(sv)
a8a597b2
MB
1682 B::PVMG sv
1683 MAGIC * mg = NO_INIT
1684 PPCODE:
1685 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
9496d2e5 1686 XPUSHs(make_mg_object(aTHX_ mg));
a8a597b2 1687
b2adfa9b 1688MODULE = B PACKAGE = B::MAGIC
a8a597b2
MB
1689
1690void
b2adfa9b 1691MOREMAGIC(mg)
a8a597b2 1692 B::MAGIC mg
b2adfa9b
NC
1693 ALIAS:
1694 PRIVATE = 1
1695 TYPE = 2
1696 FLAGS = 3
fb6620c6 1697 LENGTH = 4
b2adfa9b
NC
1698 OBJ = 5
1699 PTR = 6
1700 REGEX = 7
1701 precomp = 8
1702 PPCODE:
1703 switch (ix) {
1704 case 0:
1705 XPUSHs(mg->mg_moremagic ? make_mg_object(aTHX_ mg->mg_moremagic)
1706 : &PL_sv_undef);
1707 break;
1708 case 1:
1709 mPUSHu(mg->mg_private);
1710 break;
1711 case 2:
1712 PUSHs(newSVpvn_flags(&(mg->mg_type), 1, SVs_TEMP));
1713 break;
1714 case 3:
1715 mPUSHu(mg->mg_flags);
1716 break;
1717 case 4:
1718 mPUSHi(mg->mg_len);
1719 break;
1720 case 5:
0c74f67f 1721 PUSHs(make_sv_object(aTHX_ mg->mg_obj));
b2adfa9b
NC
1722 break;
1723 case 6:
1724 if (mg->mg_ptr) {
1725 if (mg->mg_len >= 0) {
1726 PUSHs(newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP));
651aa52e 1727 } else if (mg->mg_len == HEf_SVKEY) {
0c74f67f 1728 PUSHs(make_sv_object(aTHX_ (SV*)mg->mg_ptr));
fdbd1d64 1729 } else
b2adfa9b
NC
1730 PUSHs(sv_newmortal());
1731 } else
1732 PUSHs(sv_newmortal());
1733 break;
1734 case 7:
1735 if(mg->mg_type == PERL_MAGIC_qr) {
1736 mPUSHi(PTR2IV(mg->mg_obj));
1737 } else {
1738 croak("REGEX is only meaningful on r-magic");
1739 }
1740 break;
1741 case 8:
1742 if (mg->mg_type == PERL_MAGIC_qr) {
1743 REGEXP *rx = (REGEXP *)mg->mg_obj;
227aaa42
NC
1744 PUSHs(newSVpvn_flags(rx ? RX_PRECOMP(rx) : NULL,
1745 rx ? RX_PRELEN(rx) : 0, SVs_TEMP));
b2adfa9b
NC
1746 } else {
1747 croak( "precomp is only meaningful on r-magic" );
1748 }
1749 break;
1750 }
a8a597b2 1751
8922e438
FC
1752MODULE = B PACKAGE = B::BM PREFIX = Bm
1753
1754U32
1755BmPREVIOUS(sv)
1756 B::BM sv
99639b5b 1757 CODE:
99639b5b 1758 PERL_UNUSED_VAR(sv);
99639b5b
DM
1759 RETVAL = BmPREVIOUS(sv);
1760 OUTPUT:
1761 RETVAL
1762
8922e438
FC
1763
1764U8
1765BmRARE(sv)
1766 B::BM sv
99639b5b 1767 CODE:
99639b5b 1768 PERL_UNUSED_VAR(sv);
99639b5b
DM
1769 RETVAL = BmRARE(sv);
1770 OUTPUT:
1771 RETVAL
1772
8922e438 1773
a8a597b2
MB
1774MODULE = B PACKAGE = B::GV PREFIX = Gv
1775
1776void
1777GvNAME(gv)
1778 B::GV gv
cbf9c13f
NC
1779 ALIAS:
1780 FILE = 1
435e8dd0 1781 B::HV::NAME = 2
a8a597b2 1782 CODE:
435e8dd0
NC
1783 ST(0) = sv_2mortal(newSVhek(!ix ? GvNAME_HEK(gv)
1784 : (ix == 1 ? GvFILE_HEK(gv)
1785 : HvNAME_HEK((HV *)gv))));
a8a597b2 1786
87d7fd28
GS
1787bool
1788is_empty(gv)
1789 B::GV gv
711fbbf0
NC
1790 ALIAS:
1791 isGV_with_GP = 1
87d7fd28 1792 CODE:
711fbbf0 1793 if (ix) {
711fbbf0 1794 RETVAL = isGV_with_GP(gv) ? TRUE : FALSE;
711fbbf0
NC
1795 } else {
1796 RETVAL = GvGP(gv) == Null(GP*);
1797 }
50786ba8 1798 OUTPUT:
711fbbf0 1799 RETVAL
50786ba8 1800
651aa52e
AE
1801void*
1802GvGP(gv)
1803 B::GV gv
1804
3800c318
JH
1805#define GP_sv_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_sv)
1806#define GP_io_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_io)
1807#define GP_cv_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_cv)
1808#define GP_cvgen_ix (U32p << 16) | STRUCT_OFFSET(struct gp, gp_cvgen)
1809#define GP_refcnt_ix (U32p << 16) | STRUCT_OFFSET(struct gp, gp_refcnt)
1810#define GP_hv_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_hv)
1811#define GP_av_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_av)
1812#define GP_form_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_form)
1813#define GP_egv_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_egv)
a8a597b2 1814
257e0650
NC
1815void
1816SV(gv)
a8a597b2 1817 B::GV gv
257e0650
NC
1818 ALIAS:
1819 SV = GP_sv_ix
1820 IO = GP_io_ix
1821 CV = GP_cv_ix
1822 CVGEN = GP_cvgen_ix
1823 GvREFCNT = GP_refcnt_ix
1824 HV = GP_hv_ix
1825 AV = GP_av_ix
1826 FORM = GP_form_ix
1827 EGV = GP_egv_ix
257e0650
NC
1828 PREINIT:
1829 GP *gp;
1830 char *ptr;
1831 SV *ret;
1832 PPCODE:
1833 gp = GvGP(gv);
1834 if (!gp) {
1835 const GV *const gv = CvGV(cv);
46c3f339 1836 Perl_croak(aTHX_ "NULL gp in B::GV::%s", gv ? GvNAME(gv) : "???");
257e0650
NC
1837 }
1838 ptr = (ix & 0xFFFF) + (char *)gp;
1839 switch ((U8)(ix >> 16)) {
7d6d3fb7 1840 case SVp:
0c74f67f 1841 ret = make_sv_object(aTHX_ *((SV **)ptr));
257e0650 1842 break;
7d6d3fb7 1843 case U32p:
257e0650
NC
1844 ret = sv_2mortal(newSVuv(*((U32*)ptr)));
1845 break;
c33e8be1
Z
1846 default:
1847 croak("Illegal alias 0x%08x for B::*SV", (unsigned)ix);
257e0650
NC
1848 }
1849 ST(0) = ret;
1850 XSRETURN(1);
a8a597b2 1851
39ff6c37
FC
1852U32
1853GvLINE(gv)
1854 B::GV gv
1855
bb1efdce
FC
1856U32
1857GvGPFLAGS(gv)
1858 B::GV gv
1859
8ae5a962
NC
1860void
1861FILEGV(gv)
a8a597b2 1862 B::GV gv
8ae5a962 1863 PPCODE:
0c74f67f 1864 PUSHs(make_sv_object(aTHX_ (SV *)GvFILEGV(gv)));
a8a597b2 1865
a8a597b2
MB
1866MODULE = B PACKAGE = B::IO PREFIX = Io
1867
04071355 1868
b326da91
MB
1869bool
1870IsSTD(io,name)
1871 B::IO io
5d7488b2 1872 const char* name
b326da91
MB
1873 PREINIT:
1874 PerlIO* handle = 0;
1875 CODE:
1876 if( strEQ( name, "stdin" ) ) {
1877 handle = PerlIO_stdin();
1878 }
1879 else if( strEQ( name, "stdout" ) ) {
1880 handle = PerlIO_stdout();
1881 }
1882 else if( strEQ( name, "stderr" ) ) {
1883 handle = PerlIO_stderr();
1884 }
1885 else {
1886 croak( "Invalid value '%s'", name );
1887 }
1888 RETVAL = handle == IoIFP(io);
1889 OUTPUT:
1890 RETVAL
1891
a8a597b2
MB
1892MODULE = B PACKAGE = B::AV PREFIX = Av
1893
1894SSize_t
1895AvFILL(av)
1896 B::AV av
1897
a8a597b2
MB
1898void
1899AvARRAY(av)
1900 B::AV av
1901 PPCODE:
1902 if (AvFILL(av) >= 0) {
1903 SV **svp = AvARRAY(av);
1904 I32 i;
1905 for (i = 0; i <= AvFILL(av); i++)
0c74f67f 1906 XPUSHs(make_sv_object(aTHX_ svp[i]));
a8a597b2
MB
1907 }
1908
429a5ce7
SM
1909void
1910AvARRAYelt(av, idx)
1911 B::AV av
1912 int idx
1913 PPCODE:
1914 if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
0c74f67f 1915 XPUSHs(make_sv_object(aTHX_ (AvARRAY(av)[idx])));
429a5ce7 1916 else
0c74f67f 1917 XPUSHs(make_sv_object(aTHX_ NULL));
429a5ce7 1918
edcc7c74 1919
f2da823f
FC
1920MODULE = B PACKAGE = B::FM PREFIX = Fm
1921
f2da823f 1922IV
99639b5b
DM
1923FmLINES(format)
1924 B::FM format
1925 CODE:
1926 PERL_UNUSED_VAR(format);
1927 RETVAL = 0;
1928 OUTPUT:
1929 RETVAL
1930
f2da823f 1931
a8a597b2
MB
1932MODULE = B PACKAGE = B::CV PREFIX = Cv
1933
651aa52e
AE
1934U32
1935CvCONST(cv)
1936 B::CV cv
1937
6079961f 1938void
a8a597b2
MB
1939CvSTART(cv)
1940 B::CV cv
a0da4400
NC
1941 ALIAS:
1942 ROOT = 1
6079961f
NC
1943 PPCODE:
1944 PUSHs(make_op_object(aTHX_ CvISXSUB(cv) ? NULL
1945 : ix ? CvROOT(cv) : CvSTART(cv)));
a8a597b2 1946
bb02a38f
FC
1947I32
1948CvDEPTH(cv)
1949 B::CV cv
1950
86d2498c 1951#ifdef PadlistARRAY
7261499d
FC
1952
1953B::PADLIST
1954CvPADLIST(cv)
1955 B::CV cv
eacbb379
DD
1956 CODE:
1957 RETVAL = CvISXSUB(cv) ? NULL : CvPADLIST(cv);
1958 OUTPUT:
1959 RETVAL
7261499d
FC
1960
1961#else
1962
1963B::AV
1964CvPADLIST(cv)
1965 B::CV cv
82aeefe1
DM
1966 PPCODE:
1967 PUSHs(make_sv_object(aTHX_ (SV *)CvPADLIST(cv)));
1968
7261499d
FC
1969
1970#endif
1971
eacbb379 1972SV *
db6e00bd 1973CvHSCXT(cv)
eacbb379
DD
1974 B::CV cv
1975 CODE:
db6e00bd 1976 RETVAL = newSVuv(CvISXSUB(cv) ? PTR2UV(CvHSCXT(cv)) : 0);
eacbb379
DD
1977 OUTPUT:
1978 RETVAL
1979
a8a597b2
MB
1980void
1981CvXSUB(cv)
1982 B::CV cv
96819e59
NC
1983 ALIAS:
1984 XSUBANY = 1
a8a597b2 1985 CODE:
96819e59 1986 ST(0) = ix && CvCONST(cv)
0c74f67f 1987 ? make_sv_object(aTHX_ (SV *)CvXSUBANY(cv).any_ptr)
96819e59
NC
1988 : sv_2mortal(newSViv(CvISXSUB(cv)
1989 ? (ix ? CvXSUBANY(cv).any_iv
1990 : PTR2IV(CvXSUB(cv)))
1991 : 0));
a8a597b2 1992
8ae5a962
NC
1993void
1994const_sv(cv)
de3f1649 1995 B::CV cv
8ae5a962 1996 PPCODE:
0c74f67f 1997 PUSHs(make_sv_object(aTHX_ (SV *)cv_const_sv(cv)));
de3f1649 1998
486b1e7f
TC
1999void
2000GV(cv)
2001 B::CV cv
486b1e7f 2002 CODE:
f244b085 2003 ST(0) = make_sv_object(aTHX_ (SV*)CvGV(cv));
486b1e7f 2004
486b1e7f
TC
2005SV *
2006NAME_HEK(cv)
2007 B::CV cv
2008 CODE:
2009 RETVAL = CvNAMED(cv) ? newSVhek(CvNAME_HEK(cv)) : &PL_sv_undef;
2010 OUTPUT:
2011 RETVAL
2012
a8a597b2
MB
2013MODULE = B PACKAGE = B::HV PREFIX = Hv
2014
2015STRLEN
2016HvFILL(hv)
2017 B::HV hv
2018
a8a597b2
MB
2019I32
2020HvRITER(hv)
2021 B::HV hv
2022
a8a597b2
MB
2023void
2024HvARRAY(hv)
2025 B::HV hv
2026 PPCODE:
1b95d04f 2027 if (HvUSEDKEYS(hv) > 0) {
fa0789a7 2028 HE *he;
052a7c76 2029 SSize_t extend_size;
a8a597b2 2030 (void)hv_iterinit(hv);
052a7c76
DM
2031 /* 2*HvUSEDKEYS() should never be big enough to truncate or wrap */
2032 assert(HvUSEDKEYS(hv) <= (SSize_t_MAX >> 1));
2033 extend_size = (SSize_t)HvUSEDKEYS(hv) * 2;
2034 EXTEND(sp, extend_size);
fa0789a7
RU
2035 while ((he = hv_iternext(hv))) {
2036 if (HeSVKEY(he)) {
2037 mPUSHs(HeSVKEY(he));
2038 } else if (HeKUTF8(he)) {
2039 PUSHs(newSVpvn_flags(HeKEY(he), HeKLEN(he), SVf_UTF8|SVs_TEMP));
2040 } else {
2041 mPUSHp(HeKEY(he), HeKLEN(he));
2042 }
2043 PUSHs(make_sv_object(aTHX_ HeVAL(he)));
a8a597b2
MB
2044 }
2045 }
fd9f6265
JJ
2046
2047MODULE = B PACKAGE = B::HE PREFIX = He
2048
8ae5a962 2049void
fd9f6265
JJ
2050HeVAL(he)
2051 B::HE he
b2619626
NC
2052 ALIAS:
2053 SVKEY_force = 1
8ae5a962 2054 PPCODE:
0c74f67f 2055 PUSHs(make_sv_object(aTHX_ ix ? HeSVKEY_force(he) : HeVAL(he)));
fd9f6265
JJ
2056
2057U32
2058HeHASH(he)
2059 B::HE he
2060
fdbacc68 2061MODULE = B PACKAGE = B::RHE
fd9f6265
JJ
2062
2063SV*
fdbacc68 2064HASH(h)
fd9f6265
JJ
2065 B::RHE h
2066 CODE:
20439bc7 2067 RETVAL = newRV( (SV*)cophh_2hv(h, 0) );
fd9f6265
JJ
2068 OUTPUT:
2069 RETVAL
e412117e 2070
7261499d 2071
86d2498c 2072#ifdef PadlistARRAY
7261499d 2073
86d2498c 2074MODULE = B PACKAGE = B::PADLIST PREFIX = Padlist
7261499d
FC
2075
2076SSize_t
86d2498c 2077PadlistMAX(padlist)
7261499d 2078 B::PADLIST padlist
9b7476d7
FC
2079 ALIAS: B::PADNAMELIST::MAX = 0
2080 CODE:
2081 PERL_UNUSED_VAR(ix);
2082 RETVAL = PadlistMAX(padlist);
2083 OUTPUT:
2084 RETVAL
2085
2086B::PADNAMELIST
2087PadlistNAMES(padlist)
2088 B::PADLIST padlist
7261499d
FC
2089
2090void
86d2498c 2091PadlistARRAY(padlist)
7261499d
FC
2092 B::PADLIST padlist
2093 PPCODE:
86d2498c 2094 if (PadlistMAX(padlist) >= 0) {
9b7476d7 2095 dXSTARG;
86d2498c 2096 PAD **padp = PadlistARRAY(padlist);
99639b5b 2097 SSize_t i;
9b7476d7
FC
2098 sv_setiv(newSVrv(TARG, PadlistNAMES(padlist)
2099 ? "B::PADNAMELIST"
2100 : "B::NULL"),
2101 PTR2IV(PadlistNAMES(padlist)));
2102 XPUSHTARG;
2103 for (i = 1; i <= PadlistMAX(padlist); i++)
7261499d
FC
2104 XPUSHs(make_sv_object(aTHX_ (SV *)padp[i]));
2105 }
2106
2107void
86d2498c 2108PadlistARRAYelt(padlist, idx)
7261499d 2109 B::PADLIST padlist
99639b5b 2110 SSize_t idx
7261499d 2111 PPCODE:
9b7476d7
FC
2112 if (idx < 0 || idx > PadlistMAX(padlist))
2113 XPUSHs(make_sv_object(aTHX_ NULL));
2114 else if (!idx) {
2115 PL_stack_sp--;
2116 PUSHMARK(PL_stack_sp-1);
2117 XS_B__PADLIST_NAMES(aTHX_ cv);
2118 return;
2119 }
2120 else
7261499d 2121 XPUSHs(make_sv_object(aTHX_
86d2498c 2122 (SV *)PadlistARRAY(padlist)[idx]));
7261499d
FC
2123
2124U32
86d2498c 2125PadlistREFCNT(padlist)
7261499d
FC
2126 B::PADLIST padlist
2127 CODE:
99639b5b 2128 PERL_UNUSED_VAR(padlist);
86d2498c 2129 RETVAL = PadlistREFCNT(padlist);
7261499d
FC
2130 OUTPUT:
2131 RETVAL
2132
2133#endif
9b7476d7
FC
2134
2135MODULE = B PACKAGE = B::PADNAMELIST PREFIX = Padnamelist
2136
2137void
2138PadnamelistARRAY(pnl)
2139 B::PADNAMELIST pnl
2140 PPCODE:
2141 if (PadnamelistMAX(pnl) >= 0) {
2142 PADNAME **padp = PadnamelistARRAY(pnl);
2143 SSize_t i = 0;
2144 for (; i <= PadnamelistMAX(pnl); i++)
0f94cb1f
FC
2145 {
2146 SV *rv = sv_newmortal();
2147 sv_setiv(newSVrv(rv,padp[i] ? "B::PADNAME" : "B::SPECIAL"),
2148 PTR2IV(padp[i]));
2149 XPUSHs(rv);
2150 }
9b7476d7
FC
2151 }
2152
0f94cb1f 2153B::PADNAME
9b7476d7
FC
2154PadnamelistARRAYelt(pnl, idx)
2155 B::PADNAMELIST pnl
2156 SSize_t idx
0f94cb1f 2157 CODE:
9b7476d7 2158 if (idx < 0 || idx > PadnamelistMAX(pnl))
0f94cb1f 2159 RETVAL = NULL;
9b7476d7 2160 else
0f94cb1f
FC
2161 RETVAL = PadnamelistARRAY(pnl)[idx];
2162 OUTPUT:
2163 RETVAL
9b7476d7 2164
0f94cb1f
FC
2165MODULE = B PACKAGE = B::PADNAME PREFIX = Padname
2166
2167#define PN_type_ix \
2168 sv_SVp | STRUCT_OFFSET(struct padname,xpadn_type_u.xpadn_typestash)
2169#define PN_ourstash_ix \
2170 sv_SVp | STRUCT_OFFSET(struct padname,xpadn_ourstash)
2171#define PN_len_ix \
2172 sv_U8p | STRUCT_OFFSET(struct padname,xpadn_len)
2173#define PN_refcnt_ix \
2174 sv_U32p | STRUCT_OFFSET(struct padname, xpadn_refcnt)
2175#define PN_cop_seq_range_low_ix \
2176 sv_U32p | STRUCT_OFFSET(struct padname, xpadn_low)
2177#define PN_cop_seq_range_high_ix \
2178 sv_U32p | STRUCT_OFFSET(struct padname, xpadn_high)
d8fed09d
FC
2179#define PNL_refcnt_ix \
2180 sv_U32p | STRUCT_OFFSET(struct padnamelist, xpadnl_refcnt)
58480c3b
FC
2181#define PL_id_ix \
2182 sv_U32p | STRUCT_OFFSET(struct padlist, xpadl_id)
2183#define PL_outid_ix \
2184 sv_U32p | STRUCT_OFFSET(struct padlist, xpadl_outid)
2185
0f94cb1f
FC
2186
2187void
2188PadnameTYPE(pn)
2189 B::PADNAME pn
2190 ALIAS:
2191 B::PADNAME::TYPE = PN_type_ix
2192 B::PADNAME::OURSTASH = PN_ourstash_ix
2193 B::PADNAME::LEN = PN_len_ix
2194 B::PADNAME::REFCNT = PN_refcnt_ix
2195 B::PADNAME::COP_SEQ_RANGE_LOW = PN_cop_seq_range_low_ix
2196 B::PADNAME::COP_SEQ_RANGE_HIGH = PN_cop_seq_range_high_ix
d8fed09d 2197 B::PADNAMELIST::REFCNT = PNL_refcnt_ix
58480c3b
FC
2198 B::PADLIST::id = PL_id_ix
2199 B::PADLIST::outid = PL_outid_ix
0f94cb1f
FC
2200 PREINIT:
2201 char *ptr;
2202 SV *ret;
2203 PPCODE:
2204 ptr = (ix & 0xFFFF) + (char *)pn;
2205 switch ((U8)(ix >> 16)) {
2206 case (U8)(sv_SVp >> 16):
2207 ret = make_sv_object(aTHX_ *((SV **)ptr));
2208 break;
2209 case (U8)(sv_U32p >> 16):
2210 ret = sv_2mortal(newSVuv(*((U32 *)ptr)));
2211 break;
2212 case (U8)(sv_U8p >> 16):
2213 ret = sv_2mortal(newSVuv(*((U8 *)ptr)));
2214 break;
2215 default:
2216 NOT_REACHED;
2217 }
2218 ST(0) = ret;
2219 XSRETURN(1);
2220
2221SV *
2222PadnamePV(pn)
2223 B::PADNAME pn
2224 PREINIT:
2225 dXSTARG;
2226 PPCODE:
2227 PERL_UNUSED_ARG(RETVAL);
2228 sv_setpvn(TARG, PadnamePV(pn), PadnameLEN(pn));
2229 SvUTF8_on(TARG);
2230 XPUSHTARG;
2231
2232BOOT:
2233{
2234 /* Uses less memory than an ALIAS. */
2235 GV *gv = gv_fetchpvs("B::PADNAME::TYPE", 1, SVt_PVGV);
2236 sv_setsv((SV *)gv_fetchpvs("B::PADNAME::SvSTASH",1,SVt_PVGV),(SV *)gv);
2237 sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PROTOCV",1,SVt_PVGV),(SV *)gv);
2238 sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PVX",1,SVt_PVGV),
2239 (SV *)gv_fetchpvs("B::PADNAME::PV" ,1,SVt_PVGV));
43a4fb14
FC
2240 sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PARENT_PAD_INDEX" ,1,SVt_PVGV),
2241 (SV *)gv_fetchpvs("B::PADNAME::COP_SEQ_RANGE_LOW",1,
2242 SVt_PVGV));
2243 sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PARENT_FAKELEX_FLAGS",1,
2244 SVt_PVGV),
2245 (SV *)gv_fetchpvs("B::PADNAME::COP_SEQ_RANGE_HIGH" ,1,
2246 SVt_PVGV));
0f94cb1f
FC
2247}
2248
2249U32
2250PadnameFLAGS(pn)
2251 B::PADNAME pn
2252 CODE:
2253 RETVAL = PadnameFLAGS(pn);
2254 /* backward-compatibility hack, which should be removed if the
2255 flags field becomes large enough to hold SVf_FAKE (and
2256 PADNAMEt_OUTER should be renumbered to match SVf_FAKE) */
d28cce60 2257 STATIC_ASSERT_STMT(SVf_FAKE >= 1<<(sizeof(PadnameFLAGS((B__PADNAME)NULL)) * 8));
0f94cb1f
FC
2258 if (PadnameOUTER(pn))
2259 RETVAL |= SVf_FAKE;
2260 OUTPUT:
2261 RETVAL