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