This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Avoid my_regdupe type mismatch warning after #29430
[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
MB
23 "B::NULL",
24 "B::IV",
25 "B::NV",
26 "B::RV",
27 "B::PV",
28 "B::PVIV",
29 "B::PVNV",
30 "B::PVMG",
31 "B::BM",
7252851f 32#if PERL_VERSION >= 9
4ce457a6 33 "B::GV",
7252851f 34#endif
a8a597b2
MB
35 "B::PVLV",
36 "B::AV",
37 "B::HV",
38 "B::CV",
7252851f
NC
39#if PERL_VERSION <= 8
40 "B::GV",
41#endif
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
MB
105{
106 if (!o)
107 return OPc_NULL;
108
109 if (o->op_type == 0)
110 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
111
112 if (o->op_type == OP_SASSIGN)
113 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
114
c60fdceb
SM
115 if (o->op_type == OP_AELEMFAST) {
116 if (o->op_flags & OPf_SPECIAL)
117 return OPc_BASEOP;
118 else
119#ifdef USE_ITHREADS
120 return OPc_PADOP;
121#else
122 return OPc_SVOP;
123#endif
124 }
125
18228111 126#ifdef USE_ITHREADS
31b49ad4 127 if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
c60fdceb 128 o->op_type == OP_RCATLINE)
18228111
GS
129 return OPc_PADOP;
130#endif
131
22c35a8c 132 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
a8a597b2
MB
133 case OA_BASEOP:
134 return OPc_BASEOP;
135
136 case OA_UNOP:
137 return OPc_UNOP;
138
139 case OA_BINOP:
140 return OPc_BINOP;
141
142 case OA_LOGOP:
143 return OPc_LOGOP;
144
a8a597b2
MB
145 case OA_LISTOP:
146 return OPc_LISTOP;
147
148 case OA_PMOP:
149 return OPc_PMOP;
150
151 case OA_SVOP:
152 return OPc_SVOP;
153
7934575e
GS
154 case OA_PADOP:
155 return OPc_PADOP;
a8a597b2 156
293d3ffa
SM
157 case OA_PVOP_OR_SVOP:
158 /*
159 * Character translations (tr///) are usually a PVOP, keeping a
160 * pointer to a table of shorts used to look up translations.
161 * Under utf8, however, a simple table isn't practical; instead,
162 * the OP is an SVOP, and the SV is a reference to a swash
163 * (i.e., an RV pointing to an HV).
164 */
165 return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
166 ? OPc_SVOP : OPc_PVOP;
a8a597b2
MB
167
168 case OA_LOOP:
169 return OPc_LOOP;
170
171 case OA_COP:
172 return OPc_COP;
173
174 case OA_BASEOP_OR_UNOP:
175 /*
176 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
45f6cd40
SM
177 * whether parens were seen. perly.y uses OPf_SPECIAL to
178 * signal whether a BASEOP had empty parens or none.
179 * Some other UNOPs are created later, though, so the best
180 * test is OPf_KIDS, which is set in newUNOP.
a8a597b2 181 */
45f6cd40 182 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
a8a597b2
MB
183
184 case OA_FILESTATOP:
185 /*
186 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
187 * the OPf_REF flag to distinguish between OP types instead of the
188 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
189 * return OPc_UNOP so that walkoptree can find our children. If
190 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
191 * (no argument to the operator) it's an OP; with OPf_REF set it's
7934575e 192 * an SVOP (and op_sv is the GV for the filehandle argument).
a8a597b2
MB
193 */
194 return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
93865851
GS
195#ifdef USE_ITHREADS
196 (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
197#else
7934575e 198 (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
93865851 199#endif
a8a597b2
MB
200 case OA_LOOPEXOP:
201 /*
202 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
203 * label was omitted (in which case it's a BASEOP) or else a term was
204 * seen. In this last case, all except goto are definitely PVOP but
205 * goto is either a PVOP (with an ordinary constant label), an UNOP
206 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
207 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
208 * get set.
209 */
210 if (o->op_flags & OPf_STACKED)
211 return OPc_UNOP;
212 else if (o->op_flags & OPf_SPECIAL)
213 return OPc_BASEOP;
214 else
215 return OPc_PVOP;
216 }
217 warn("can't determine class of operator %s, assuming BASEOP\n",
22c35a8c 218 PL_op_name[o->op_type]);
a8a597b2
MB
219 return OPc_BASEOP;
220}
221
222static char *
5d7488b2 223cc_opclassname(pTHX_ const OP *o)
a8a597b2 224{
27da23d5 225 return (char *)opclassnames[cc_opclass(aTHX_ o)];
a8a597b2
MB
226}
227
228static SV *
cea2e8a9 229make_sv_object(pTHX_ SV *arg, SV *sv)
a8a597b2 230{
27da23d5 231 const char *type = 0;
a8a597b2 232 IV iv;
89ca4ac7 233 dMY_CXT;
a8a597b2 234
e8edd1e6
TH
235 for (iv = 0; iv < sizeof(specialsv_list)/sizeof(SV*); iv++) {
236 if (sv == specialsv_list[iv]) {
a8a597b2
MB
237 type = "B::SPECIAL";
238 break;
239 }
240 }
241 if (!type) {
242 type = svclassnames[SvTYPE(sv)];
56431972 243 iv = PTR2IV(sv);
a8a597b2
MB
244 }
245 sv_setiv(newSVrv(arg, type), iv);
246 return arg;
247}
248
249static SV *
8e01d9a6
NC
250make_temp_object(pTHX_ SV *arg, SV *temp)
251{
252 SV *target;
253 const char *const type = svclassnames[SvTYPE(temp)];
254 const IV iv = PTR2IV(temp);
255
256 target = newSVrv(arg, type);
257 sv_setiv(target, iv);
258
259 /* Need to keep our "temp" around as long as the target exists.
260 Simplest way seems to be to hang it from magic, and let that clear
261 it up. No vtable, so won't actually get in the way of anything. */
262 sv_magicext(target, temp, PERL_MAGIC_sv, NULL, NULL, 0);
263 /* magic object has had its reference count increased, so we must drop
264 our reference. */
265 SvREFCNT_dec(temp);
266 return arg;
267}
268
269static SV *
5c3c3f81
NC
270make_warnings_object(pTHX_ SV *arg, STRLEN *warnings)
271{
272 const char *type = 0;
273 dMY_CXT;
274 IV iv = sizeof(specialsv_list)/sizeof(SV*);
275
276 /* Counting down is deliberate. Before the split between make_sv_object
277 and make_warnings_obj there appeared to be a bug - Nullsv and pWARN_STD
278 were both 0, so you could never get a B::SPECIAL for pWARN_STD */
279
280 while (iv--) {
281 if ((SV*)warnings == specialsv_list[iv]) {
282 type = "B::SPECIAL";
283 break;
284 }
285 }
286 if (type) {
287 sv_setiv(newSVrv(arg, type), iv);
8e01d9a6 288 return arg;
5c3c3f81
NC
289 } else {
290 /* B assumes that warnings are a regular SV. Seems easier to keep it
291 happy by making them into a regular SV. */
8e01d9a6
NC
292 return make_temp_object(aTHX_ arg,
293 newSVpvn((char *)(warnings + 1), *warnings));
294 }
295}
296
297static SV *
298make_cop_io_object(pTHX_ SV *arg, COP *cop)
299{
300 if (CopHINTS_get(cop) & HINT_LEXICAL_IO) {
301 /* I feel you should be able to simply SvREFCNT_inc the return value
302 from this, but if you do (and restore the line
303 my $ioix = $cop->io->ix;
304 in B::COP::bsave in Bytecode.pm, then you get errors about
305 "attempt to free temp prematurely ... during global destruction.
306 The SV's flags are consistent with the error, but quite how the
307 temp escaped from the save stack is not clear. */
308 SV *value = Perl_refcounted_he_fetch(aTHX_ cop->cop_hints_hash,
309 0, "open", 4, 0, 0);
310 return make_temp_object(aTHX_ arg, newSVsv(value));
311 } else {
312 return make_sv_object(aTHX_ arg, NULL);
5c3c3f81 313 }
5c3c3f81
NC
314}
315
316static SV *
cea2e8a9 317make_mg_object(pTHX_ SV *arg, MAGIC *mg)
a8a597b2 318{
56431972 319 sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg));
a8a597b2
MB
320 return arg;
321}
322
323static SV *
52ad86de 324cstring(pTHX_ SV *sv, bool perlstyle)
a8a597b2 325{
79cb57f6 326 SV *sstr = newSVpvn("", 0);
a8a597b2
MB
327
328 if (!SvOK(sv))
329 sv_setpvn(sstr, "0", 1);
5d7488b2 330 else if (perlstyle && SvUTF8(sv)) {
d79a7a3d 331 SV *tmpsv = sv_newmortal(); /* Temporary SV to feed sv_uni_display */
5d7488b2
AL
332 const STRLEN len = SvCUR(sv);
333 const char *s = sv_uni_display(tmpsv, sv, 8*len, UNI_DISPLAY_QQ);
c69006e4 334 sv_setpvn(sstr,"\"",1);
d79a7a3d
RGS
335 while (*s)
336 {
337 if (*s == '"')
5d7488b2 338 sv_catpvn(sstr, "\\\"", 2);
d79a7a3d 339 else if (*s == '$')
5d7488b2 340 sv_catpvn(sstr, "\\$", 2);
d79a7a3d 341 else if (*s == '@')
5d7488b2 342 sv_catpvn(sstr, "\\@", 2);
d79a7a3d
RGS
343 else if (*s == '\\')
344 {
345 if (strchr("nrftax\\",*(s+1)))
346 sv_catpvn(sstr, s++, 2);
347 else
5d7488b2 348 sv_catpvn(sstr, "\\\\", 2);
d79a7a3d
RGS
349 }
350 else /* should always be printable */
351 sv_catpvn(sstr, s, 1);
352 ++s;
353 }
354 sv_catpv(sstr, "\"");
355 return sstr;
356 }
a8a597b2
MB
357 else
358 {
359 /* XXX Optimise? */
5d7488b2
AL
360 STRLEN len;
361 const char *s = SvPV(sv, len);
a8a597b2
MB
362 sv_catpv(sstr, "\"");
363 for (; len; len--, s++)
364 {
365 /* At least try a little for readability */
366 if (*s == '"')
367 sv_catpv(sstr, "\\\"");
368 else if (*s == '\\')
369 sv_catpv(sstr, "\\\\");
b326da91 370 /* trigraphs - bleagh */
5d7488b2
AL
371 else if (!perlstyle && *s == '?' && len>=3 && s[1] == '?') {
372 char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
b326da91
MB
373 sprintf(escbuff, "\\%03o", '?');
374 sv_catpv(sstr, escbuff);
375 }
52ad86de
JH
376 else if (perlstyle && *s == '$')
377 sv_catpv(sstr, "\\$");
378 else if (perlstyle && *s == '@')
379 sv_catpv(sstr, "\\@");
ce561ef2
JH
380#ifdef EBCDIC
381 else if (isPRINT(*s))
382#else
383 else if (*s >= ' ' && *s < 127)
384#endif /* EBCDIC */
a8a597b2
MB
385 sv_catpvn(sstr, s, 1);
386 else if (*s == '\n')
387 sv_catpv(sstr, "\\n");
388 else if (*s == '\r')
389 sv_catpv(sstr, "\\r");
390 else if (*s == '\t')
391 sv_catpv(sstr, "\\t");
392 else if (*s == '\a')
393 sv_catpv(sstr, "\\a");
394 else if (*s == '\b')
395 sv_catpv(sstr, "\\b");
396 else if (*s == '\f')
397 sv_catpv(sstr, "\\f");
52ad86de 398 else if (!perlstyle && *s == '\v')
a8a597b2
MB
399 sv_catpv(sstr, "\\v");
400 else
401 {
a8a597b2 402 /* Don't want promotion of a signed -1 char in sprintf args */
5d7488b2
AL
403 char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
404 const unsigned char c = (unsigned char) *s;
a8a597b2
MB
405 sprintf(escbuff, "\\%03o", c);
406 sv_catpv(sstr, escbuff);
407 }
408 /* XXX Add line breaks if string is long */
409 }
410 sv_catpv(sstr, "\"");
411 }
412 return sstr;
413}
414
415static SV *
cea2e8a9 416cchar(pTHX_ SV *sv)
a8a597b2 417{
79cb57f6 418 SV *sstr = newSVpvn("'", 1);
5d7488b2 419 const char *s = SvPV_nolen(sv);
a8a597b2
MB
420
421 if (*s == '\'')
5d7488b2 422 sv_catpvn(sstr, "\\'", 2);
a8a597b2 423 else if (*s == '\\')
5d7488b2 424 sv_catpvn(sstr, "\\\\", 2);
ce561ef2 425#ifdef EBCDIC
133b4094 426 else if (isPRINT(*s))
ce561ef2
JH
427#else
428 else if (*s >= ' ' && *s < 127)
429#endif /* EBCDIC */
a8a597b2
MB
430 sv_catpvn(sstr, s, 1);
431 else if (*s == '\n')
5d7488b2 432 sv_catpvn(sstr, "\\n", 2);
a8a597b2 433 else if (*s == '\r')
5d7488b2 434 sv_catpvn(sstr, "\\r", 2);
a8a597b2 435 else if (*s == '\t')
5d7488b2 436 sv_catpvn(sstr, "\\t", 2);
a8a597b2 437 else if (*s == '\a')
5d7488b2 438 sv_catpvn(sstr, "\\a", 2);
a8a597b2 439 else if (*s == '\b')
5d7488b2 440 sv_catpvn(sstr, "\\b", 2);
a8a597b2 441 else if (*s == '\f')
5d7488b2 442 sv_catpvn(sstr, "\\f", 2);
a8a597b2 443 else if (*s == '\v')
5d7488b2 444 sv_catpvn(sstr, "\\v", 2);
a8a597b2
MB
445 else
446 {
447 /* no trigraph support */
448 char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
449 /* Don't want promotion of a signed -1 char in sprintf args */
450 unsigned char c = (unsigned char) *s;
451 sprintf(escbuff, "\\%03o", c);
452 sv_catpv(sstr, escbuff);
453 }
5d7488b2 454 sv_catpvn(sstr, "'", 1);
a8a597b2
MB
455 return sstr;
456}
457
5d7488b2
AL
458static void
459walkoptree(pTHX_ SV *opsv, const char *method)
a8a597b2
MB
460{
461 dSP;
f3be9b72 462 OP *o, *kid;
89ca4ac7
JH
463 dMY_CXT;
464
a8a597b2
MB
465 if (!SvROK(opsv))
466 croak("opsv is not a reference");
467 opsv = sv_mortalcopy(opsv);
56431972 468 o = INT2PTR(OP*,SvIV((SV*)SvRV(opsv)));
a8a597b2
MB
469 if (walkoptree_debug) {
470 PUSHMARK(sp);
471 XPUSHs(opsv);
472 PUTBACK;
473 perl_call_method("walkoptree_debug", G_DISCARD);
474 }
475 PUSHMARK(sp);
476 XPUSHs(opsv);
477 PUTBACK;
478 perl_call_method(method, G_DISCARD);
479 if (o && (o->op_flags & OPf_KIDS)) {
a8a597b2
MB
480 for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) {
481 /* Use the same opsv. Rely on methods not to mess it up. */
56431972 482 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
cea2e8a9 483 walkoptree(aTHX_ opsv, method);
a8a597b2
MB
484 }
485 }
5464c149 486 if (o && (cc_opclass(aTHX_ o) == OPc_PMOP) && o->op_type != OP_PUSHRE
f3be9b72
RGS
487 && (kid = cPMOPo->op_pmreplroot))
488 {
5464c149 489 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
f3be9b72
RGS
490 walkoptree(aTHX_ opsv, method);
491 }
a8a597b2
MB
492}
493
5d7488b2 494static SV **
1df34986
AE
495oplist(pTHX_ OP *o, SV **SP)
496{
497 for(; o; o = o->op_next) {
498 SV *opsv;
7252851f
NC
499#if PERL_VERSION >= 9
500 if (o->op_opt == 0)
1df34986 501 break;
2814eb74 502 o->op_opt = 0;
7252851f
NC
503#else
504 if (o->op_seq == 0)
505 break;
506 o->op_seq = 0;
507#endif
1df34986
AE
508 opsv = sv_newmortal();
509 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ (OP*)o)), PTR2IV(o));
510 XPUSHs(opsv);
511 switch (o->op_type) {
512 case OP_SUBST:
513 SP = oplist(aTHX_ cPMOPo->op_pmreplstart, SP);
514 continue;
515 case OP_SORT:
f66c782a 516 if (o->op_flags & OPf_STACKED && o->op_flags & OPf_SPECIAL) {
1df34986
AE
517 OP *kid = cLISTOPo->op_first->op_sibling; /* pass pushmark */
518 kid = kUNOP->op_first; /* pass rv2gv */
519 kid = kUNOP->op_first; /* pass leave */
f66c782a 520 SP = oplist(aTHX_ kid->op_next, SP);
1df34986
AE
521 }
522 continue;
523 }
524 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
525 case OA_LOGOP:
526 SP = oplist(aTHX_ cLOGOPo->op_other, SP);
527 break;
528 case OA_LOOP:
529 SP = oplist(aTHX_ cLOOPo->op_lastop, SP);
530 SP = oplist(aTHX_ cLOOPo->op_nextop, SP);
531 SP = oplist(aTHX_ cLOOPo->op_redoop, SP);
532 break;
533 }
534 }
535 return SP;
536}
537
a8a597b2
MB
538typedef OP *B__OP;
539typedef UNOP *B__UNOP;
540typedef BINOP *B__BINOP;
541typedef LOGOP *B__LOGOP;
a8a597b2
MB
542typedef LISTOP *B__LISTOP;
543typedef PMOP *B__PMOP;
544typedef SVOP *B__SVOP;
7934575e 545typedef PADOP *B__PADOP;
a8a597b2
MB
546typedef PVOP *B__PVOP;
547typedef LOOP *B__LOOP;
548typedef COP *B__COP;
549
550typedef SV *B__SV;
551typedef SV *B__IV;
552typedef SV *B__PV;
553typedef SV *B__NV;
554typedef SV *B__PVMG;
555typedef SV *B__PVLV;
556typedef SV *B__BM;
557typedef SV *B__RV;
1df34986 558typedef SV *B__FM;
a8a597b2
MB
559typedef AV *B__AV;
560typedef HV *B__HV;
561typedef CV *B__CV;
562typedef GV *B__GV;
563typedef IO *B__IO;
564
565typedef MAGIC *B__MAGIC;
566
567MODULE = B PACKAGE = B PREFIX = B_
568
569PROTOTYPES: DISABLE
570
571BOOT:
4c1f658f
NIS
572{
573 HV *stash = gv_stashpvn("B", 1, TRUE);
574 AV *export_ok = perl_get_av("B::EXPORT_OK",TRUE);
89ca4ac7 575 MY_CXT_INIT;
e8edd1e6
TH
576 specialsv_list[0] = Nullsv;
577 specialsv_list[1] = &PL_sv_undef;
578 specialsv_list[2] = &PL_sv_yes;
579 specialsv_list[3] = &PL_sv_no;
5c3c3f81
NC
580 specialsv_list[4] = (SV *) pWARN_ALL;
581 specialsv_list[5] = (SV *) pWARN_NONE;
582 specialsv_list[6] = (SV *) pWARN_STD;
f5ba1307 583#if PERL_VERSION <= 8
7252851f
NC
584# define CVf_ASSERTION 0
585#endif
4c1f658f
NIS
586#include "defsubs.h"
587}
a8a597b2 588
3280af22 589#define B_main_cv() PL_main_cv
31d7d75a 590#define B_init_av() PL_initav
651aa52e 591#define B_inc_gv() PL_incgv
ece599bd 592#define B_check_av() PL_checkav_save
676456c2 593#define B_unitcheck_av() PL_unitcheckav_save
059a8bb7
JH
594#define B_begin_av() PL_beginav_save
595#define B_end_av() PL_endav
3280af22
NIS
596#define B_main_root() PL_main_root
597#define B_main_start() PL_main_start
56eca212 598#define B_amagic_generation() PL_amagic_generation
5ce57cc0 599#define B_sub_generation() PL_sub_generation
651aa52e
AE
600#define B_defstash() PL_defstash
601#define B_curstash() PL_curstash
602#define B_dowarn() PL_dowarn
3280af22
NIS
603#define B_comppadlist() (PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv))
604#define B_sv_undef() &PL_sv_undef
605#define B_sv_yes() &PL_sv_yes
606#define B_sv_no() &PL_sv_no
1df34986 607#define B_formfeed() PL_formfeed
9d2bbe64
MB
608#ifdef USE_ITHREADS
609#define B_regex_padav() PL_regex_padav
610#endif
a8a597b2 611
31d7d75a
NIS
612B::AV
613B_init_av()
614
059a8bb7 615B::AV
ece599bd
RGS
616B_check_av()
617
618B::AV
676456c2
AG
619B_unitcheck_av()
620
621B::AV
059a8bb7
JH
622B_begin_av()
623
624B::AV
625B_end_av()
626
651aa52e
AE
627B::GV
628B_inc_gv()
629
9d2bbe64
MB
630#ifdef USE_ITHREADS
631
632B::AV
633B_regex_padav()
634
635#endif
636
a8a597b2
MB
637B::CV
638B_main_cv()
639
640B::OP
641B_main_root()
642
643B::OP
644B_main_start()
645
56eca212
GS
646long
647B_amagic_generation()
648
5ce57cc0
JJ
649long
650B_sub_generation()
651
a8a597b2
MB
652B::AV
653B_comppadlist()
654
655B::SV
656B_sv_undef()
657
658B::SV
659B_sv_yes()
660
661B::SV
662B_sv_no()
663
651aa52e
AE
664B::HV
665B_curstash()
666
667B::HV
668B_defstash()
a8a597b2 669
651aa52e
AE
670U8
671B_dowarn()
672
1df34986
AE
673B::SV
674B_formfeed()
675
651aa52e
AE
676void
677B_warnhook()
678 CODE:
679 ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_warnhook);
680
681void
682B_diehook()
683 CODE:
684 ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_diehook);
685
686MODULE = B PACKAGE = B
a8a597b2
MB
687
688void
689walkoptree(opsv, method)
690 SV * opsv
5d7488b2 691 const char * method
cea2e8a9
GS
692 CODE:
693 walkoptree(aTHX_ opsv, method);
a8a597b2
MB
694
695int
696walkoptree_debug(...)
697 CODE:
89ca4ac7 698 dMY_CXT;
a8a597b2
MB
699 RETVAL = walkoptree_debug;
700 if (items > 0 && SvTRUE(ST(1)))
701 walkoptree_debug = 1;
702 OUTPUT:
703 RETVAL
704
56431972 705#define address(sv) PTR2IV(sv)
a8a597b2
MB
706
707IV
708address(sv)
709 SV * sv
710
711B::SV
712svref_2object(sv)
713 SV * sv
714 CODE:
715 if (!SvROK(sv))
716 croak("argument is not a reference");
717 RETVAL = (SV*)SvRV(sv);
718 OUTPUT:
0cc1d052
NIS
719 RETVAL
720
721void
722opnumber(name)
5d7488b2 723const char * name
0cc1d052
NIS
724CODE:
725{
726 int i;
727 IV result = -1;
728 ST(0) = sv_newmortal();
729 if (strncmp(name,"pp_",3) == 0)
730 name += 3;
731 for (i = 0; i < PL_maxo; i++)
732 {
733 if (strcmp(name, PL_op_name[i]) == 0)
734 {
735 result = i;
736 break;
737 }
738 }
739 sv_setiv(ST(0),result);
740}
a8a597b2
MB
741
742void
743ppname(opnum)
744 int opnum
745 CODE:
746 ST(0) = sv_newmortal();
3280af22 747 if (opnum >= 0 && opnum < PL_maxo) {
a8a597b2 748 sv_setpvn(ST(0), "pp_", 3);
22c35a8c 749 sv_catpv(ST(0), PL_op_name[opnum]);
a8a597b2
MB
750 }
751
752void
753hash(sv)
754 SV * sv
755 CODE:
a8a597b2
MB
756 STRLEN len;
757 U32 hash = 0;
faccc32b 758 char hexhash[19]; /* must fit "0xffffffffffffffff" plus trailing \0 */
5d7488b2 759 const char *s = SvPV(sv, len);
c32d3395 760 PERL_HASH(hash, s, len);
faccc32b 761 sprintf(hexhash, "0x%"UVxf, (UV)hash);
a8a597b2
MB
762 ST(0) = sv_2mortal(newSVpv(hexhash, 0));
763
764#define cast_I32(foo) (I32)foo
765IV
766cast_I32(i)
767 IV i
768
769void
770minus_c()
771 CODE:
3280af22 772 PL_minus_c = TRUE;
a8a597b2 773
059a8bb7
JH
774void
775save_BEGINs()
776 CODE:
aefff11f 777 PL_savebegin = TRUE;
059a8bb7 778
a8a597b2
MB
779SV *
780cstring(sv)
781 SV * sv
cea2e8a9 782 CODE:
52ad86de
JH
783 RETVAL = cstring(aTHX_ sv, 0);
784 OUTPUT:
785 RETVAL
786
787SV *
788perlstring(sv)
789 SV * sv
790 CODE:
791 RETVAL = cstring(aTHX_ sv, 1);
cea2e8a9
GS
792 OUTPUT:
793 RETVAL
a8a597b2
MB
794
795SV *
796cchar(sv)
797 SV * sv
cea2e8a9
GS
798 CODE:
799 RETVAL = cchar(aTHX_ sv);
800 OUTPUT:
801 RETVAL
a8a597b2
MB
802
803void
804threadsv_names()
805 PPCODE:
f5ba1307
NC
806#if PERL_VERSION <= 8
807# ifdef USE_5005THREADS
808 int i;
5d7488b2 809 const STRLEN len = strlen(PL_threadsv_names);
f5ba1307
NC
810
811 EXTEND(sp, len);
812 for (i = 0; i < len; i++)
813 PUSHs(sv_2mortal(newSVpvn(&PL_threadsv_names[i], 1)));
814# endif
815#endif
a8a597b2
MB
816
817#define OP_next(o) o->op_next
818#define OP_sibling(o) o->op_sibling
27da23d5 819#define OP_desc(o) (char *)PL_op_desc[o->op_type]
a8a597b2
MB
820#define OP_targ(o) o->op_targ
821#define OP_type(o) o->op_type
7252851f
NC
822#if PERL_VERSION >= 9
823# define OP_opt(o) o->op_opt
824# define OP_static(o) o->op_static
825#else
826# define OP_seq(o) o->op_seq
827#endif
a8a597b2
MB
828#define OP_flags(o) o->op_flags
829#define OP_private(o) o->op_private
a60ba18b 830#define OP_spare(o) o->op_spare
a8a597b2
MB
831
832MODULE = B PACKAGE = B::OP PREFIX = OP_
833
651aa52e
AE
834size_t
835OP_size(o)
836 B::OP o
837 CODE:
838 RETVAL = opsizes[cc_opclass(aTHX_ o)];
839 OUTPUT:
840 RETVAL
841
a8a597b2
MB
842B::OP
843OP_next(o)
844 B::OP o
845
846B::OP
847OP_sibling(o)
848 B::OP o
849
850char *
3f872cb9
GS
851OP_name(o)
852 B::OP o
853 CODE:
27da23d5 854 RETVAL = (char *)PL_op_name[o->op_type];
8063af02
DM
855 OUTPUT:
856 RETVAL
3f872cb9
GS
857
858
8063af02 859void
a8a597b2
MB
860OP_ppaddr(o)
861 B::OP o
dc333d64
GS
862 PREINIT:
863 int i;
864 SV *sv = sv_newmortal();
a8a597b2 865 CODE:
dc333d64
GS
866 sv_setpvn(sv, "PL_ppaddr[OP_", 13);
867 sv_catpv(sv, PL_op_name[o->op_type]);
7c436af3 868 for (i=13; (STRLEN)i < SvCUR(sv); ++i)
dc333d64
GS
869 SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]);
870 sv_catpv(sv, "]");
871 ST(0) = sv;
a8a597b2
MB
872
873char *
874OP_desc(o)
875 B::OP o
876
7934575e 877PADOFFSET
a8a597b2
MB
878OP_targ(o)
879 B::OP o
880
881U16
882OP_type(o)
883 B::OP o
884
7252851f
NC
885#if PERL_VERSION >= 9
886
2814eb74
PJ
887U8
888OP_opt(o)
889 B::OP o
890
891U8
892OP_static(o)
a8a597b2
MB
893 B::OP o
894
7252851f
NC
895#else
896
897U16
898OP_seq(o)
899 B::OP o
900
901#endif
902
a8a597b2
MB
903U8
904OP_flags(o)
905 B::OP o
906
907U8
908OP_private(o)
909 B::OP o
910
7252851f
NC
911#if PERL_VERSION >= 9
912
a60ba18b
JC
913U8
914OP_spare(o)
915 B::OP o
916
7252851f
NC
917#endif
918
1df34986
AE
919void
920OP_oplist(o)
921 B::OP o
922 PPCODE:
923 SP = oplist(aTHX_ o, SP);
924
a8a597b2
MB
925#define UNOP_first(o) o->op_first
926
927MODULE = B PACKAGE = B::UNOP PREFIX = UNOP_
928
929B::OP
930UNOP_first(o)
931 B::UNOP o
932
933#define BINOP_last(o) o->op_last
934
935MODULE = B PACKAGE = B::BINOP PREFIX = BINOP_
936
937B::OP
938BINOP_last(o)
939 B::BINOP o
940
941#define LOGOP_other(o) o->op_other
942
943MODULE = B PACKAGE = B::LOGOP PREFIX = LOGOP_
944
945B::OP
946LOGOP_other(o)
947 B::LOGOP o
948
a8a597b2
MB
949MODULE = B PACKAGE = B::LISTOP PREFIX = LISTOP_
950
c03c2844
SM
951U32
952LISTOP_children(o)
953 B::LISTOP o
954 OP * kid = NO_INIT
955 int i = NO_INIT
956 CODE:
c03c2844
SM
957 i = 0;
958 for (kid = o->op_first; kid; kid = kid->op_sibling)
959 i++;
8063af02
DM
960 RETVAL = i;
961 OUTPUT:
962 RETVAL
c03c2844 963
a8a597b2
MB
964#define PMOP_pmreplroot(o) o->op_pmreplroot
965#define PMOP_pmreplstart(o) o->op_pmreplstart
966#define PMOP_pmnext(o) o->op_pmnext
aaa362c4 967#define PMOP_pmregexp(o) PM_GETRE(o)
9d2bbe64
MB
968#ifdef USE_ITHREADS
969#define PMOP_pmoffset(o) o->op_pmoffset
651aa52e
AE
970#define PMOP_pmstashpv(o) o->op_pmstashpv
971#else
972#define PMOP_pmstash(o) o->op_pmstash
9d2bbe64 973#endif
a8a597b2
MB
974#define PMOP_pmflags(o) o->op_pmflags
975#define PMOP_pmpermflags(o) o->op_pmpermflags
9d2bbe64 976#define PMOP_pmdynflags(o) o->op_pmdynflags
a8a597b2
MB
977
978MODULE = B PACKAGE = B::PMOP PREFIX = PMOP_
979
980void
981PMOP_pmreplroot(o)
982 B::PMOP o
983 OP * root = NO_INIT
984 CODE:
985 ST(0) = sv_newmortal();
986 root = o->op_pmreplroot;
987 /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */
988 if (o->op_type == OP_PUSHRE) {
9d2bbe64
MB
989#ifdef USE_ITHREADS
990 sv_setiv(ST(0), INT2PTR(PADOFFSET,root) );
991#else
a8a597b2
MB
992 sv_setiv(newSVrv(ST(0), root ?
993 svclassnames[SvTYPE((SV*)root)] : "B::SV"),
56431972 994 PTR2IV(root));
9d2bbe64 995#endif
a8a597b2
MB
996 }
997 else {
56431972 998 sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root));
a8a597b2
MB
999 }
1000
1001B::OP
1002PMOP_pmreplstart(o)
1003 B::PMOP o
1004
1005B::PMOP
1006PMOP_pmnext(o)
1007 B::PMOP o
1008
9d2bbe64
MB
1009#ifdef USE_ITHREADS
1010
1011IV
1012PMOP_pmoffset(o)
1013 B::PMOP o
1014
651aa52e
AE
1015char*
1016PMOP_pmstashpv(o)
1017 B::PMOP o
1018
1019#else
1020
1021B::HV
1022PMOP_pmstash(o)
1023 B::PMOP o
1024
9d2bbe64
MB
1025#endif
1026
6e21dc91 1027U32
a8a597b2
MB
1028PMOP_pmflags(o)
1029 B::PMOP o
1030
6e21dc91 1031U32
a8a597b2
MB
1032PMOP_pmpermflags(o)
1033 B::PMOP o
1034
9d2bbe64
MB
1035U8
1036PMOP_pmdynflags(o)
1037 B::PMOP o
1038
a8a597b2
MB
1039void
1040PMOP_precomp(o)
1041 B::PMOP o
1042 REGEXP * rx = NO_INIT
1043 CODE:
1044 ST(0) = sv_newmortal();
aaa362c4 1045 rx = PM_GETRE(o);
a8a597b2
MB
1046 if (rx)
1047 sv_setpvn(ST(0), rx->precomp, rx->prelen);
1048
ac33dcd1
JH
1049#define SVOP_sv(o) cSVOPo->op_sv
1050#define SVOP_gv(o) ((GV*)cSVOPo->op_sv)
a8a597b2
MB
1051
1052MODULE = B PACKAGE = B::SVOP PREFIX = SVOP_
1053
a8a597b2
MB
1054B::SV
1055SVOP_sv(o)
1056 B::SVOP o
1057
f22444f5 1058B::GV
065a1863
GS
1059SVOP_gv(o)
1060 B::SVOP o
1061
7934575e 1062#define PADOP_padix(o) o->op_padix
dd2155a4 1063#define PADOP_sv(o) (o->op_padix ? PAD_SVl(o->op_padix) : Nullsv)
7934575e 1064#define PADOP_gv(o) ((o->op_padix \
dd2155a4
DM
1065 && SvTYPE(PAD_SVl(o->op_padix)) == SVt_PVGV) \
1066 ? (GV*)PAD_SVl(o->op_padix) : Nullgv)
a8a597b2 1067
7934575e
GS
1068MODULE = B PACKAGE = B::PADOP PREFIX = PADOP_
1069
1070PADOFFSET
1071PADOP_padix(o)
1072 B::PADOP o
1073
1074B::SV
1075PADOP_sv(o)
1076 B::PADOP o
a8a597b2
MB
1077
1078B::GV
7934575e
GS
1079PADOP_gv(o)
1080 B::PADOP o
a8a597b2
MB
1081
1082MODULE = B PACKAGE = B::PVOP PREFIX = PVOP_
1083
1084void
1085PVOP_pv(o)
1086 B::PVOP o
1087 CODE:
1088 /*
bec89253 1089 * OP_TRANS uses op_pv to point to a table of 256 or >=258 shorts
a8a597b2
MB
1090 * whereas other PVOPs point to a null terminated string.
1091 */
bec89253
RH
1092 if (o->op_type == OP_TRANS &&
1093 (o->op_private & OPpTRANS_COMPLEMENT) &&
1094 !(o->op_private & OPpTRANS_DELETE))
1095 {
5d7488b2
AL
1096 const short* const tbl = (short*)o->op_pv;
1097 const short entries = 257 + tbl[256];
bec89253
RH
1098 ST(0) = sv_2mortal(newSVpv(o->op_pv, entries * sizeof(short)));
1099 }
1100 else if (o->op_type == OP_TRANS) {
1101 ST(0) = sv_2mortal(newSVpv(o->op_pv, 256 * sizeof(short)));
1102 }
1103 else
1104 ST(0) = sv_2mortal(newSVpv(o->op_pv, 0));
a8a597b2
MB
1105
1106#define LOOP_redoop(o) o->op_redoop
1107#define LOOP_nextop(o) o->op_nextop
1108#define LOOP_lastop(o) o->op_lastop
1109
1110MODULE = B PACKAGE = B::LOOP PREFIX = LOOP_
1111
1112
1113B::OP
1114LOOP_redoop(o)
1115 B::LOOP o
1116
1117B::OP
1118LOOP_nextop(o)
1119 B::LOOP o
1120
1121B::OP
1122LOOP_lastop(o)
1123 B::LOOP o
1124
1125#define COP_label(o) o->cop_label
11faa288
GS
1126#define COP_stashpv(o) CopSTASHPV(o)
1127#define COP_stash(o) CopSTASH(o)
57843af0 1128#define COP_file(o) CopFILE(o)
1df34986 1129#define COP_filegv(o) CopFILEGV(o)
a8a597b2 1130#define COP_cop_seq(o) o->cop_seq
fc15ae8f 1131#define COP_arybase(o) CopARYBASE_get(o)
57843af0 1132#define COP_line(o) CopLINE(o)
d5ec2987 1133#define COP_hints(o) CopHINTS_get(o)
a8a597b2
MB
1134
1135MODULE = B PACKAGE = B::COP PREFIX = COP_
1136
1137char *
1138COP_label(o)
1139 B::COP o
1140
11faa288
GS
1141char *
1142COP_stashpv(o)
1143 B::COP o
1144
a8a597b2
MB
1145B::HV
1146COP_stash(o)
1147 B::COP o
1148
57843af0
GS
1149char *
1150COP_file(o)
a8a597b2
MB
1151 B::COP o
1152
1df34986
AE
1153B::GV
1154COP_filegv(o)
1155 B::COP o
1156
1157
a8a597b2
MB
1158U32
1159COP_cop_seq(o)
1160 B::COP o
1161
1162I32
1163COP_arybase(o)
1164 B::COP o
1165
8bafa735 1166U32
a8a597b2
MB
1167COP_line(o)
1168 B::COP o
1169
5c3c3f81 1170void
b295d113
TH
1171COP_warnings(o)
1172 B::COP o
5c3c3f81
NC
1173 PPCODE:
1174 ST(0) = make_warnings_object(aTHX_ sv_newmortal(), o->cop_warnings);
1175 XSRETURN(1);
b295d113 1176
670f1322 1177void
6e6a1aef
RGS
1178COP_io(o)
1179 B::COP o
11bcd5da 1180 PPCODE:
8e01d9a6 1181 ST(0) = make_cop_io_object(aTHX_ sv_newmortal(), o);
11bcd5da 1182 XSRETURN(1);
6e6a1aef 1183
d5ec2987
NC
1184U32
1185COP_hints(o)
1186 B::COP o
1187
651aa52e
AE
1188MODULE = B PACKAGE = B::SV
1189
1190U32
1191SvTYPE(sv)
1192 B::SV sv
1193
429a5ce7
SM
1194#define object_2svref(sv) sv
1195#define SVREF SV *
1196
1197SVREF
1198object_2svref(sv)
1199 B::SV sv
1200
a8a597b2
MB
1201MODULE = B PACKAGE = B::SV PREFIX = Sv
1202
1203U32
1204SvREFCNT(sv)
1205 B::SV sv
1206
1207U32
1208SvFLAGS(sv)
1209 B::SV sv
1210
651aa52e
AE
1211U32
1212SvPOK(sv)
1213 B::SV sv
1214
1215U32
1216SvROK(sv)
1217 B::SV sv
1218
1219U32
1220SvMAGICAL(sv)
1221 B::SV sv
1222
a8a597b2
MB
1223MODULE = B PACKAGE = B::IV PREFIX = Sv
1224
1225IV
1226SvIV(sv)
1227 B::IV sv
1228
1229IV
1230SvIVX(sv)
1231 B::IV sv
1232
0ca04487
VB
1233UV
1234SvUVX(sv)
1235 B::IV sv
1236
1237
a8a597b2
MB
1238MODULE = B PACKAGE = B::IV
1239
1240#define needs64bits(sv) ((I32)SvIVX(sv) != SvIVX(sv))
1241
1242int
1243needs64bits(sv)
1244 B::IV sv
1245
1246void
1247packiv(sv)
1248 B::IV sv
1249 CODE:
1250 if (sizeof(IV) == 8) {
1251 U32 wp[2];
5d7488b2 1252 const IV iv = SvIVX(sv);
a8a597b2
MB
1253 /*
1254 * The following way of spelling 32 is to stop compilers on
1255 * 32-bit architectures from moaning about the shift count
1256 * being >= the width of the type. Such architectures don't
1257 * reach this code anyway (unless sizeof(IV) > 8 but then
1258 * everything else breaks too so I'm not fussed at the moment).
1259 */
42718184
RB
1260#ifdef UV_IS_QUAD
1261 wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1262#else
1263 wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1264#endif
a8a597b2 1265 wp[1] = htonl(iv & 0xffffffff);
79cb57f6 1266 ST(0) = sv_2mortal(newSVpvn((char *)wp, 8));
a8a597b2
MB
1267 } else {
1268 U32 w = htonl((U32)SvIVX(sv));
79cb57f6 1269 ST(0) = sv_2mortal(newSVpvn((char *)&w, 4));
a8a597b2
MB
1270 }
1271
1272MODULE = B PACKAGE = B::NV PREFIX = Sv
1273
76ef7183 1274NV
a8a597b2
MB
1275SvNV(sv)
1276 B::NV sv
1277
76ef7183 1278NV
a8a597b2
MB
1279SvNVX(sv)
1280 B::NV sv
1281
1282MODULE = B PACKAGE = B::RV PREFIX = Sv
1283
1284B::SV
1285SvRV(sv)
1286 B::RV sv
1287
1288MODULE = B PACKAGE = B::PV PREFIX = Sv
1289
0b40bd6d
RH
1290char*
1291SvPVX(sv)
1292 B::PV sv
1293
b326da91
MB
1294B::SV
1295SvRV(sv)
1296 B::PV sv
1297 CODE:
1298 if( SvROK(sv) ) {
1299 RETVAL = SvRV(sv);
1300 }
1301 else {
1302 croak( "argument is not SvROK" );
1303 }
1304 OUTPUT:
1305 RETVAL
1306
a8a597b2
MB
1307void
1308SvPV(sv)
1309 B::PV sv
1310 CODE:
b326da91 1311 ST(0) = sv_newmortal();
c0b20461 1312 if( SvPOK(sv) ) {
b55685ae
NC
1313 /* FIXME - we need a better way for B to identify PVs that are
1314 in the pads as variable names. */
1315 if((SvLEN(sv) && SvCUR(sv) >= SvLEN(sv))) {
1316 /* It claims to be longer than the space allocated for it -
1317 presuambly it's a variable name in the pad */
1318 sv_setpv(ST(0), SvPV_nolen_const(sv));
1319 } else {
1320 sv_setpvn(ST(0), SvPVX_const(sv), SvCUR(sv));
1321 }
b326da91
MB
1322 SvFLAGS(ST(0)) |= SvUTF8(sv);
1323 }
1324 else {
1325 /* XXX for backward compatibility, but should fail */
1326 /* croak( "argument is not SvPOK" ); */
1327 sv_setpvn(ST(0), NULL, 0);
1328 }
a8a597b2 1329
651aa52e
AE
1330void
1331SvPVBM(sv)
1332 B::PV sv
1333 CODE:
1334 ST(0) = sv_newmortal();
aa07b2f6 1335 sv_setpvn(ST(0), SvPVX_const(sv),
651aa52e
AE
1336 SvCUR(sv) + (SvTYPE(sv) == SVt_PVBM ? 257 : 0));
1337
1338
445a12f6
DM
1339STRLEN
1340SvLEN(sv)
1341 B::PV sv
1342
1343STRLEN
1344SvCUR(sv)
1345 B::PV sv
1346
a8a597b2
MB
1347MODULE = B PACKAGE = B::PVMG PREFIX = Sv
1348
1349void
1350SvMAGIC(sv)
1351 B::PVMG sv
1352 MAGIC * mg = NO_INIT
1353 PPCODE:
1354 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
cea2e8a9 1355 XPUSHs(make_mg_object(aTHX_ sv_newmortal(), mg));
a8a597b2
MB
1356
1357MODULE = B PACKAGE = B::PVMG
1358
1359B::HV
1360SvSTASH(sv)
1361 B::PVMG sv
1362
1363#define MgMOREMAGIC(mg) mg->mg_moremagic
1364#define MgPRIVATE(mg) mg->mg_private
1365#define MgTYPE(mg) mg->mg_type
1366#define MgFLAGS(mg) mg->mg_flags
1367#define MgOBJ(mg) mg->mg_obj
88b39979 1368#define MgLENGTH(mg) mg->mg_len
bde7177d 1369#define MgREGEX(mg) PTR2IV(mg->mg_obj)
a8a597b2
MB
1370
1371MODULE = B PACKAGE = B::MAGIC PREFIX = Mg
1372
1373B::MAGIC
1374MgMOREMAGIC(mg)
1375 B::MAGIC mg
c5f0f3aa
RGS
1376 CODE:
1377 if( MgMOREMAGIC(mg) ) {
1378 RETVAL = MgMOREMAGIC(mg);
1379 }
1380 else {
1381 XSRETURN_UNDEF;
1382 }
1383 OUTPUT:
1384 RETVAL
a8a597b2
MB
1385
1386U16
1387MgPRIVATE(mg)
1388 B::MAGIC mg
1389
1390char
1391MgTYPE(mg)
1392 B::MAGIC mg
1393
1394U8
1395MgFLAGS(mg)
1396 B::MAGIC mg
1397
1398B::SV
1399MgOBJ(mg)
1400 B::MAGIC mg
b326da91 1401
9d2bbe64
MB
1402IV
1403MgREGEX(mg)
1404 B::MAGIC mg
1405 CODE:
a8248b05 1406 if(mg->mg_type == PERL_MAGIC_qr) {
9d2bbe64
MB
1407 RETVAL = MgREGEX(mg);
1408 }
1409 else {
1410 croak( "REGEX is only meaningful on r-magic" );
1411 }
1412 OUTPUT:
1413 RETVAL
1414
b326da91
MB
1415SV*
1416precomp(mg)
1417 B::MAGIC mg
1418 CODE:
a8248b05 1419 if (mg->mg_type == PERL_MAGIC_qr) {
b326da91 1420 REGEXP* rx = (REGEXP*)mg->mg_obj;
ef35129c 1421 RETVAL = Nullsv;
b326da91
MB
1422 if( rx )
1423 RETVAL = newSVpvn( rx->precomp, rx->prelen );
1424 }
1425 else {
1426 croak( "precomp is only meaningful on r-magic" );
1427 }
1428 OUTPUT:
1429 RETVAL
a8a597b2 1430
88b39979
VB
1431I32
1432MgLENGTH(mg)
1433 B::MAGIC mg
1434
a8a597b2
MB
1435void
1436MgPTR(mg)
1437 B::MAGIC mg
1438 CODE:
1439 ST(0) = sv_newmortal();
88b39979
VB
1440 if (mg->mg_ptr){
1441 if (mg->mg_len >= 0){
1442 sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len);
651aa52e
AE
1443 } else if (mg->mg_len == HEf_SVKEY) {
1444 ST(0) = make_sv_object(aTHX_
1445 sv_newmortal(), (SV*)mg->mg_ptr);
88b39979
VB
1446 }
1447 }
a8a597b2
MB
1448
1449MODULE = B PACKAGE = B::PVLV PREFIX = Lv
1450
1451U32
1452LvTARGOFF(sv)
1453 B::PVLV sv
1454
1455U32
1456LvTARGLEN(sv)
1457 B::PVLV sv
1458
1459char
1460LvTYPE(sv)
1461 B::PVLV sv
1462
1463B::SV
1464LvTARG(sv)
1465 B::PVLV sv
1466
1467MODULE = B PACKAGE = B::BM PREFIX = Bm
1468
1469I32
1470BmUSEFUL(sv)
1471 B::BM sv
1472
1473U16
1474BmPREVIOUS(sv)
1475 B::BM sv
1476
1477U8
1478BmRARE(sv)
1479 B::BM sv
1480
1481void
1482BmTABLE(sv)
1483 B::BM sv
1484 STRLEN len = NO_INIT
1485 char * str = NO_INIT
1486 CODE:
1487 str = SvPV(sv, len);
1488 /* Boyer-Moore table is just after string and its safety-margin \0 */
79cb57f6 1489 ST(0) = sv_2mortal(newSVpvn(str + len + 1, 256));
a8a597b2
MB
1490
1491MODULE = B PACKAGE = B::GV PREFIX = Gv
1492
1493void
1494GvNAME(gv)
1495 B::GV gv
1496 CODE:
79cb57f6 1497 ST(0) = sv_2mortal(newSVpvn(GvNAME(gv), GvNAMELEN(gv)));
a8a597b2 1498
87d7fd28
GS
1499bool
1500is_empty(gv)
1501 B::GV gv
1502 CODE:
1503 RETVAL = GvGP(gv) == Null(GP*);
1504 OUTPUT:
1505 RETVAL
1506
651aa52e
AE
1507void*
1508GvGP(gv)
1509 B::GV gv
1510
a8a597b2
MB
1511B::HV
1512GvSTASH(gv)
1513 B::GV gv
1514
1515B::SV
1516GvSV(gv)
1517 B::GV gv
1518
1519B::IO
1520GvIO(gv)
1521 B::GV gv
1522
1df34986 1523B::FM
a8a597b2
MB
1524GvFORM(gv)
1525 B::GV gv
1df34986
AE
1526 CODE:
1527 RETVAL = (SV*)GvFORM(gv);
1528 OUTPUT:
1529 RETVAL
a8a597b2
MB
1530
1531B::AV
1532GvAV(gv)
1533 B::GV gv
1534
1535B::HV
1536GvHV(gv)
1537 B::GV gv
1538
1539B::GV
1540GvEGV(gv)
1541 B::GV gv
1542
1543B::CV
1544GvCV(gv)
1545 B::GV gv
1546
1547U32
1548GvCVGEN(gv)
1549 B::GV gv
1550
8bafa735 1551U32
a8a597b2
MB
1552GvLINE(gv)
1553 B::GV gv
1554
b195d487
GS
1555char *
1556GvFILE(gv)
1557 B::GV gv
1558
a8a597b2
MB
1559B::GV
1560GvFILEGV(gv)
1561 B::GV gv
1562
1563MODULE = B PACKAGE = B::GV
1564
1565U32
1566GvREFCNT(gv)
1567 B::GV gv
1568
1569U8
1570GvFLAGS(gv)
1571 B::GV gv
1572
1573MODULE = B PACKAGE = B::IO PREFIX = Io
1574
1575long
1576IoLINES(io)
1577 B::IO io
1578
1579long
1580IoPAGE(io)
1581 B::IO io
1582
1583long
1584IoPAGE_LEN(io)
1585 B::IO io
1586
1587long
1588IoLINES_LEFT(io)
1589 B::IO io
1590
1591char *
1592IoTOP_NAME(io)
1593 B::IO io
1594
1595B::GV
1596IoTOP_GV(io)
1597 B::IO io
1598
1599char *
1600IoFMT_NAME(io)
1601 B::IO io
1602
1603B::GV
1604IoFMT_GV(io)
1605 B::IO io
1606
1607char *
1608IoBOTTOM_NAME(io)
1609 B::IO io
1610
1611B::GV
1612IoBOTTOM_GV(io)
1613 B::IO io
1614
1615short
1616IoSUBPROCESS(io)
1617 B::IO io
1618
b326da91
MB
1619bool
1620IsSTD(io,name)
1621 B::IO io
5d7488b2 1622 const char* name
b326da91
MB
1623 PREINIT:
1624 PerlIO* handle = 0;
1625 CODE:
1626 if( strEQ( name, "stdin" ) ) {
1627 handle = PerlIO_stdin();
1628 }
1629 else if( strEQ( name, "stdout" ) ) {
1630 handle = PerlIO_stdout();
1631 }
1632 else if( strEQ( name, "stderr" ) ) {
1633 handle = PerlIO_stderr();
1634 }
1635 else {
1636 croak( "Invalid value '%s'", name );
1637 }
1638 RETVAL = handle == IoIFP(io);
1639 OUTPUT:
1640 RETVAL
1641
a8a597b2
MB
1642MODULE = B PACKAGE = B::IO
1643
1644char
1645IoTYPE(io)
1646 B::IO io
1647
1648U8
1649IoFLAGS(io)
1650 B::IO io
1651
1652MODULE = B PACKAGE = B::AV PREFIX = Av
1653
1654SSize_t
1655AvFILL(av)
1656 B::AV av
1657
1658SSize_t
1659AvMAX(av)
1660 B::AV av
1661
edcc7c74
NC
1662#if PERL_VERSION < 9
1663
1664
1665#define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1666
1667IV
1668AvOFF(av)
1669 B::AV av
1670
1671#endif
1672
a8a597b2
MB
1673void
1674AvARRAY(av)
1675 B::AV av
1676 PPCODE:
1677 if (AvFILL(av) >= 0) {
1678 SV **svp = AvARRAY(av);
1679 I32 i;
1680 for (i = 0; i <= AvFILL(av); i++)
cea2e8a9 1681 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), svp[i]));
a8a597b2
MB
1682 }
1683
429a5ce7
SM
1684void
1685AvARRAYelt(av, idx)
1686 B::AV av
1687 int idx
1688 PPCODE:
1689 if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
1690 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), (AvARRAY(av)[idx])));
1691 else
1692 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), NULL));
1693
edcc7c74
NC
1694#if PERL_VERSION < 9
1695
1696MODULE = B PACKAGE = B::AV
1697
1698U8
1699AvFLAGS(av)
1700 B::AV av
1701
1702#endif
1703
1df34986
AE
1704MODULE = B PACKAGE = B::FM PREFIX = Fm
1705
1706IV
1707FmLINES(form)
1708 B::FM form
1709
a8a597b2
MB
1710MODULE = B PACKAGE = B::CV PREFIX = Cv
1711
651aa52e
AE
1712U32
1713CvCONST(cv)
1714 B::CV cv
1715
a8a597b2
MB
1716B::HV
1717CvSTASH(cv)
1718 B::CV cv
1719
1720B::OP
1721CvSTART(cv)
1722 B::CV cv
bf53b3a5
NC
1723 CODE:
1724 RETVAL = CvISXSUB(cv) ? NULL : CvSTART(cv);
1725 OUTPUT:
1726 RETVAL
a8a597b2
MB
1727
1728B::OP
1729CvROOT(cv)
1730 B::CV cv
d04ba589
NC
1731 CODE:
1732 RETVAL = CvISXSUB(cv) ? NULL : CvROOT(cv);
1733 OUTPUT:
1734 RETVAL
a8a597b2
MB
1735
1736B::GV
1737CvGV(cv)
1738 B::CV cv
1739
57843af0
GS
1740char *
1741CvFILE(cv)
1742 B::CV cv
1743
a8a597b2
MB
1744long
1745CvDEPTH(cv)
1746 B::CV cv
1747
1748B::AV
1749CvPADLIST(cv)
1750 B::CV cv
1751
1752B::CV
1753CvOUTSIDE(cv)
1754 B::CV cv
1755
a3985cdc
DM
1756U32
1757CvOUTSIDE_SEQ(cv)
1758 B::CV cv
1759
a8a597b2
MB
1760void
1761CvXSUB(cv)
1762 B::CV cv
1763 CODE:
d04ba589 1764 ST(0) = sv_2mortal(newSViv(CvISXSUB(cv) ? PTR2IV(CvXSUB(cv)) : 0));
a8a597b2
MB
1765
1766
1767void
1768CvXSUBANY(cv)
1769 B::CV cv
1770 CODE:
b326da91 1771 ST(0) = CvCONST(cv) ?
07409e01 1772 make_sv_object(aTHX_ sv_newmortal(),(SV *)CvXSUBANY(cv).any_ptr) :
bf53b3a5 1773 sv_2mortal(newSViv(CvISXSUB(cv) ? CvXSUBANY(cv).any_iv : 0));
a8a597b2 1774
5cfd8ad4
VB
1775MODULE = B PACKAGE = B::CV
1776
6aaf4108 1777U16
5cfd8ad4
VB
1778CvFLAGS(cv)
1779 B::CV cv
1780
de3f1649
JT
1781MODULE = B PACKAGE = B::CV PREFIX = cv_
1782
1783B::SV
1784cv_const_sv(cv)
1785 B::CV cv
1786
5cfd8ad4 1787
a8a597b2
MB
1788MODULE = B PACKAGE = B::HV PREFIX = Hv
1789
1790STRLEN
1791HvFILL(hv)
1792 B::HV hv
1793
1794STRLEN
1795HvMAX(hv)
1796 B::HV hv
1797
1798I32
1799HvKEYS(hv)
1800 B::HV hv
1801
1802I32
1803HvRITER(hv)
1804 B::HV hv
1805
1806char *
1807HvNAME(hv)
1808 B::HV hv
1809
edcc7c74
NC
1810#if PERL_VERSION < 9
1811
1812B::PMOP
1813HvPMROOT(hv)
1814 B::HV hv
1815
1816#endif
1817
a8a597b2
MB
1818void
1819HvARRAY(hv)
1820 B::HV hv
1821 PPCODE:
1822 if (HvKEYS(hv) > 0) {
1823 SV *sv;
1824 char *key;
1825 I32 len;
1826 (void)hv_iterinit(hv);
1827 EXTEND(sp, HvKEYS(hv) * 2);
8063af02 1828 while ((sv = hv_iternextsv(hv, &key, &len))) {
79cb57f6 1829 PUSHs(newSVpvn(key, len));
cea2e8a9 1830 PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv));
a8a597b2
MB
1831 }
1832 }