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