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