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