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