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