projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
Eliminate SVt_RV, and use SVt_IV to store plain references.
[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
40 "B::ORANGE",
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;
572typedef SV *B__PVLV;
573typedef SV *B__BM;
574typedef SV *B__RV;
1df34986 575typedef SV *B__FM;
a8a597b2 576typedef AV *B__AV;
577typedef HV *B__HV;
578typedef CV *B__CV;
579typedef GV *B__GV;
580typedef IO *B__IO;
581
582typedef MAGIC *B__MAGIC;
fd9f6265 583typedef HE *B__HE;
e412117e 584#if PERL_VERSION >= 9
fd9f6265 585typedef struct refcounted_he *B__RHE;
e412117e 586#endif
a8a597b2 587
588MODULE = B PACKAGE = B PREFIX = B_
589
590PROTOTYPES: DISABLE
591
592BOOT:
4c1f658f 593{
da51bb9b 594 HV *stash = gv_stashpvn("B", 1, GV_ADD);
4c1f658f 595 AV *export_ok = perl_get_av("B::EXPORT_OK",TRUE);
89ca4ac7 596 MY_CXT_INIT;
e8edd1e6 597 specialsv_list[0] = Nullsv;
598 specialsv_list[1] = &PL_sv_undef;
599 specialsv_list[2] = &PL_sv_yes;
600 specialsv_list[3] = &PL_sv_no;
5c3c3f81 601 specialsv_list[4] = (SV *) pWARN_ALL;
602 specialsv_list[5] = (SV *) pWARN_NONE;
603 specialsv_list[6] = (SV *) pWARN_STD;
f5ba1307 604#if PERL_VERSION <= 8
e6663653 605# define OPpPAD_STATE 0
7252851f 606#endif
4c1f658f 607#include "defsubs.h"
608}
a8a597b2 609
3280af22 610#define B_main_cv() PL_main_cv
31d7d75a 611#define B_init_av() PL_initav
651aa52e 612#define B_inc_gv() PL_incgv
ece599bd 613#define B_check_av() PL_checkav_save
e6663653 614#if PERL_VERSION > 8
615# define B_unitcheck_av() PL_unitcheckav_save
616#else
617# define B_unitcheck_av() NULL
618#endif
059a8bb7 619#define B_begin_av() PL_beginav_save
620#define B_end_av() PL_endav
3280af22 621#define B_main_root() PL_main_root
622#define B_main_start() PL_main_start
56eca212 623#define B_amagic_generation() PL_amagic_generation
5ce57cc0 624#define B_sub_generation() PL_sub_generation
651aa52e 625#define B_defstash() PL_defstash
626#define B_curstash() PL_curstash
627#define B_dowarn() PL_dowarn
3280af22 628#define B_comppadlist() (PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv))
629#define B_sv_undef() &PL_sv_undef
630#define B_sv_yes() &PL_sv_yes
631#define B_sv_no() &PL_sv_no
1df34986 632#define B_formfeed() PL_formfeed
9d2bbe64 633#ifdef USE_ITHREADS
634#define B_regex_padav() PL_regex_padav
635#endif
a8a597b2 636
31d7d75a 637B::AV
638B_init_av()
639
059a8bb7 640B::AV
ece599bd 641B_check_av()
642
e412117e 643#if PERL_VERSION >= 9
644
ece599bd 645B::AV
676456c2 646B_unitcheck_av()
647
e412117e 648#endif
649
676456c2 650B::AV
059a8bb7 651B_begin_av()
652
653B::AV
654B_end_av()
655
651aa52e 656B::GV
657B_inc_gv()
658
9d2bbe64 659#ifdef USE_ITHREADS
660
661B::AV
662B_regex_padav()
663
664#endif
665
a8a597b2 666B::CV
667B_main_cv()
668
669B::OP
670B_main_root()
671
672B::OP
673B_main_start()
674
56eca212 675long
676B_amagic_generation()
677
5ce57cc0 678long
679B_sub_generation()
680
a8a597b2 681B::AV
682B_comppadlist()
683
684B::SV
685B_sv_undef()
686
687B::SV
688B_sv_yes()
689
690B::SV
691B_sv_no()
692
651aa52e 693B::HV
694B_curstash()
695
696B::HV
697B_defstash()
a8a597b2 698
651aa52e 699U8
700B_dowarn()
701
1df34986 702B::SV
703B_formfeed()
704
651aa52e 705void
706B_warnhook()
707 CODE:
708 ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_warnhook);
709
710void
711B_diehook()
712 CODE:
713 ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_diehook);
714
715MODULE = B PACKAGE = B
a8a597b2 716
717void
718walkoptree(opsv, method)
719 SV * opsv
5d7488b2 720 const char * method
cea2e8a9 721 CODE:
722 walkoptree(aTHX_ opsv, method);
a8a597b2 723
724int
725walkoptree_debug(...)
726 CODE:
89ca4ac7 727 dMY_CXT;
a8a597b2 728 RETVAL = walkoptree_debug;
729 if (items > 0 && SvTRUE(ST(1)))
730 walkoptree_debug = 1;
731 OUTPUT:
732 RETVAL
733
56431972 734#define address(sv) PTR2IV(sv)
a8a597b2 735
736IV
737address(sv)
738 SV * sv
739
740B::SV
741svref_2object(sv)
742 SV * sv
743 CODE:
744 if (!SvROK(sv))
745 croak("argument is not a reference");
746 RETVAL = (SV*)SvRV(sv);
747 OUTPUT:
0cc1d052 748 RETVAL
749
750void
751opnumber(name)
5d7488b2 752const char * name
0cc1d052 753CODE:
754{
755 int i;
756 IV result = -1;
757 ST(0) = sv_newmortal();
758 if (strncmp(name,"pp_",3) == 0)
759 name += 3;
760 for (i = 0; i < PL_maxo; i++)
761 {
762 if (strcmp(name, PL_op_name[i]) == 0)
763 {
764 result = i;
765 break;
766 }
767 }
768 sv_setiv(ST(0),result);
769}
a8a597b2 770
771void
772ppname(opnum)
773 int opnum
774 CODE:
775 ST(0) = sv_newmortal();
3280af22 776 if (opnum >= 0 && opnum < PL_maxo) {
a8a597b2 777 sv_setpvn(ST(0), "pp_", 3);
22c35a8c 778 sv_catpv(ST(0), PL_op_name[opnum]);
a8a597b2 779 }
780
781void
782hash(sv)
783 SV * sv
784 CODE:
a8a597b2 785 STRLEN len;
786 U32 hash = 0;
faccc32b 787 char hexhash[19]; /* must fit "0xffffffffffffffff" plus trailing \0 */
5d7488b2 788 const char *s = SvPV(sv, len);
c32d3395 789 PERL_HASH(hash, s, len);
faccc32b 790 sprintf(hexhash, "0x%"UVxf, (UV)hash);
a8a597b2 791 ST(0) = sv_2mortal(newSVpv(hexhash, 0));
792
793#define cast_I32(foo) (I32)foo
794IV
795cast_I32(i)
796 IV i
797
798void
799minus_c()
800 CODE:
3280af22 801 PL_minus_c = TRUE;
a8a597b2 802
059a8bb7 803void
804save_BEGINs()
805 CODE:
aefff11f 806 PL_savebegin = TRUE;
059a8bb7 807
a8a597b2 808SV *
809cstring(sv)
810 SV * sv
cea2e8a9 811 CODE:
52ad86de 812 RETVAL = cstring(aTHX_ sv, 0);
813 OUTPUT:
814 RETVAL
815
816SV *
817perlstring(sv)
818 SV * sv
819 CODE:
820 RETVAL = cstring(aTHX_ sv, 1);
cea2e8a9 821 OUTPUT:
822 RETVAL
a8a597b2 823
824SV *
825cchar(sv)
826 SV * sv
cea2e8a9 827 CODE:
828 RETVAL = cchar(aTHX_ sv);
829 OUTPUT:
830 RETVAL
a8a597b2 831
832void
833threadsv_names()
834 PPCODE:
f5ba1307 835#if PERL_VERSION <= 8
836# ifdef USE_5005THREADS
837 int i;
5d7488b2 838 const STRLEN len = strlen(PL_threadsv_names);
f5ba1307 839
840 EXTEND(sp, len);
841 for (i = 0; i < len; i++)
842 PUSHs(sv_2mortal(newSVpvn(&PL_threadsv_names[i], 1)));
843# endif
844#endif
a8a597b2 845
846#define OP_next(o) o->op_next
847#define OP_sibling(o) o->op_sibling
27da23d5 848#define OP_desc(o) (char *)PL_op_desc[o->op_type]
a8a597b2 849#define OP_targ(o) o->op_targ
850#define OP_type(o) o->op_type
7252851f 851#if PERL_VERSION >= 9
852# define OP_opt(o) o->op_opt
7252851f 853#else
854# define OP_seq(o) o->op_seq
855#endif
a8a597b2 856#define OP_flags(o) o->op_flags
857#define OP_private(o) o->op_private
a60ba18b 858#define OP_spare(o) o->op_spare
a8a597b2 859
860MODULE = B PACKAGE = B::OP PREFIX = OP_
861
651aa52e 862size_t
863OP_size(o)
864 B::OP o
865 CODE:
866 RETVAL = opsizes[cc_opclass(aTHX_ o)];
867 OUTPUT:
868 RETVAL
869
a8a597b2 870B::OP
871OP_next(o)
872 B::OP o
873
874B::OP
875OP_sibling(o)
876 B::OP o
877
878char *
3f872cb9 879OP_name(o)
880 B::OP o
881 CODE:
27da23d5 882 RETVAL = (char *)PL_op_name[o->op_type];
8063af02 883 OUTPUT:
884 RETVAL
3f872cb9 885
886
8063af02 887void
a8a597b2 888OP_ppaddr(o)
889 B::OP o
dc333d64 890 PREINIT:
891 int i;
892 SV *sv = sv_newmortal();
a8a597b2 893 CODE:
dc333d64 894 sv_setpvn(sv, "PL_ppaddr[OP_", 13);
895 sv_catpv(sv, PL_op_name[o->op_type]);
7c436af3 896 for (i=13; (STRLEN)i < SvCUR(sv); ++i)
dc333d64 897 SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]);
898 sv_catpv(sv, "]");
899 ST(0) = sv;
a8a597b2 900
901char *
902OP_desc(o)
903 B::OP o
904
7934575e 905PADOFFSET
a8a597b2 906OP_targ(o)
907 B::OP o
908
909U16
910OP_type(o)
911 B::OP o
912
7252851f 913#if PERL_VERSION >= 9
914
2814eb74 915U8
916OP_opt(o)
917 B::OP o
918
7252851f 919#else
920
921U16
922OP_seq(o)
923 B::OP o
924
925#endif
926
a8a597b2 927U8
928OP_flags(o)
929 B::OP o
930
931U8
932OP_private(o)
933 B::OP o
934
7252851f 935#if PERL_VERSION >= 9
936
a60ba18b 937U8
938OP_spare(o)
939 B::OP o
940
7252851f 941#endif
942
1df34986 943void
944OP_oplist(o)
945 B::OP o
946 PPCODE:
947 SP = oplist(aTHX_ o, SP);
948
a8a597b2 949#define UNOP_first(o) o->op_first
950
951MODULE = B PACKAGE = B::UNOP PREFIX = UNOP_
952
953B::OP
954UNOP_first(o)
955 B::UNOP o
956
957#define BINOP_last(o) o->op_last
958
959MODULE = B PACKAGE = B::BINOP PREFIX = BINOP_
960
961B::OP
962BINOP_last(o)
963 B::BINOP o
964
965#define LOGOP_other(o) o->op_other
966
967MODULE = B PACKAGE = B::LOGOP PREFIX = LOGOP_
968
969B::OP
970LOGOP_other(o)
971 B::LOGOP o
972
a8a597b2 973MODULE = B PACKAGE = B::LISTOP PREFIX = LISTOP_
974
c03c2844 975U32
976LISTOP_children(o)
977 B::LISTOP o
978 OP * kid = NO_INIT
979 int i = NO_INIT
980 CODE:
c03c2844 981 i = 0;
982 for (kid = o->op_first; kid; kid = kid->op_sibling)
983 i++;
8063af02 984 RETVAL = i;
985 OUTPUT:
986 RETVAL
c03c2844 987
29f2e912 988#if PERL_VERSION >= 9
989# define PMOP_pmreplstart(o) o->op_pmstashstartu.op_pmreplstart
990#else
991# define PMOP_pmreplstart(o) o->op_pmreplstart
7c1f70cb 992# define PMOP_pmpermflags(o) o->op_pmpermflags
993# define PMOP_pmdynflags(o) o->op_pmdynflags
29f2e912 994#endif
a8a597b2 995#define PMOP_pmnext(o) o->op_pmnext
aaa362c4 996#define PMOP_pmregexp(o) PM_GETRE(o)
9d2bbe64 997#ifdef USE_ITHREADS
998#define PMOP_pmoffset(o) o->op_pmoffset
29f2e912 999#define PMOP_pmstashpv(o) PmopSTASHPV(o);
651aa52e 1000#else
29f2e912 1001#define PMOP_pmstash(o) PmopSTASH(o);
9d2bbe64 1002#endif
a8a597b2 1003#define PMOP_pmflags(o) o->op_pmflags
a8a597b2 1004
1005MODULE = B PACKAGE = B::PMOP PREFIX = PMOP_
1006
20e98b0f 1007#if PERL_VERSION <= 8
1008
a8a597b2 1009void
1010PMOP_pmreplroot(o)
1011 B::PMOP o
1012 OP * root = NO_INIT
1013 CODE:
1014 ST(0) = sv_newmortal();
1015 root = o->op_pmreplroot;
1016 /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */
1017 if (o->op_type == OP_PUSHRE) {
20e98b0f 1018# ifdef USE_ITHREADS
9d2bbe64 1019 sv_setiv(ST(0), INT2PTR(PADOFFSET,root) );
20e98b0f 1020# else
a8a597b2 1021 sv_setiv(newSVrv(ST(0), root ?
1022 svclassnames[SvTYPE((SV*)root)] : "B::SV"),
56431972 1023 PTR2IV(root));
20e98b0f 1024# endif
a8a597b2 1025 }
1026 else {
56431972 1027 sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root));
a8a597b2 1028 }
1029
20e98b0f 1030#else
1031
1032void
1033PMOP_pmreplroot(o)
1034 B::PMOP o
1035 CODE:
1036 ST(0) = sv_newmortal();
1037 if (o->op_type == OP_PUSHRE) {
1038# ifdef USE_ITHREADS
1039 sv_setiv(ST(0), o->op_pmreplrootu.op_pmtargetoff);
1040# else
1041 GV *const target = o->op_pmreplrootu.op_pmtargetgv;
1042 sv_setiv(newSVrv(ST(0), target ?
1043 svclassnames[SvTYPE((SV*)target)] : "B::SV"),
1044 PTR2IV(target));
1045# endif
1046 }
1047 else {
1048 OP *const root = o->op_pmreplrootu.op_pmreplroot;
1049 sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)),
1050 PTR2IV(root));
1051 }
1052
1053#endif
1054
a8a597b2 1055B::OP
1056PMOP_pmreplstart(o)
1057 B::PMOP o
1058
c2b1997a 1059#if PERL_VERSION < 9
1060
a8a597b2 1061B::PMOP
1062PMOP_pmnext(o)
1063 B::PMOP o
1064
c2b1997a 1065#endif
1066
9d2bbe64 1067#ifdef USE_ITHREADS
1068
1069IV
1070PMOP_pmoffset(o)
1071 B::PMOP o
1072
651aa52e 1073char*
1074PMOP_pmstashpv(o)
1075 B::PMOP o
1076
1077#else
1078
1079B::HV
1080PMOP_pmstash(o)
1081 B::PMOP o
1082
9d2bbe64 1083#endif
1084
6e21dc91 1085U32
a8a597b2 1086PMOP_pmflags(o)
1087 B::PMOP o
1088
7c1f70cb 1089#if PERL_VERSION < 9
1090
1091U32
1092PMOP_pmpermflags(o)
1093 B::PMOP o
1094
1095U8
1096PMOP_pmdynflags(o)
1097 B::PMOP o
1098
1099#endif
1100
a8a597b2 1101void
1102PMOP_precomp(o)
1103 B::PMOP o
1104 REGEXP * rx = NO_INIT
1105 CODE:
1106 ST(0) = sv_newmortal();
aaa362c4 1107 rx = PM_GETRE(o);
a8a597b2 1108 if (rx)
1109 sv_setpvn(ST(0), rx->precomp, rx->prelen);
1110
7c1f70cb 1111#if PERL_VERSION >= 9
1112
c737faaf 1113void
1114PMOP_reflags(o)
1115 B::PMOP o
1116 REGEXP * rx = NO_INIT
1117 CODE:
1118 ST(0) = sv_newmortal();
1119 rx = PM_GETRE(o);
1120 if (rx)
1121 sv_setuv(ST(0), rx->extflags);
1122
7c1f70cb 1123#endif
1124
ac33dcd1 1125#define SVOP_sv(o) cSVOPo->op_sv
1126#define SVOP_gv(o) ((GV*)cSVOPo->op_sv)
a8a597b2 1127
1128MODULE = B PACKAGE = B::SVOP PREFIX = SVOP_
1129
a8a597b2 1130B::SV
1131SVOP_sv(o)
1132 B::SVOP o
1133
f22444f5 1134B::GV
065a1863 1135SVOP_gv(o)
1136 B::SVOP o
1137
7934575e 1138#define PADOP_padix(o) o->op_padix
dd2155a4 1139#define PADOP_sv(o) (o->op_padix ? PAD_SVl(o->op_padix) : Nullsv)
7934575e 1140#define PADOP_gv(o) ((o->op_padix \
dd2155a4 1141 && SvTYPE(PAD_SVl(o->op_padix)) == SVt_PVGV) \
1142 ? (GV*)PAD_SVl(o->op_padix) : Nullgv)
a8a597b2 1143
7934575e 1144MODULE = B PACKAGE = B::PADOP PREFIX = PADOP_
1145
1146PADOFFSET
1147PADOP_padix(o)
1148 B::PADOP o
1149
1150B::SV
1151PADOP_sv(o)
1152 B::PADOP o
a8a597b2 1153
1154B::GV
7934575e 1155PADOP_gv(o)
1156 B::PADOP o
a8a597b2 1157
1158MODULE = B PACKAGE = B::PVOP PREFIX = PVOP_
1159
1160void
1161PVOP_pv(o)
1162 B::PVOP o
1163 CODE:
1164 /*
bec89253 1165 * OP_TRANS uses op_pv to point to a table of 256 or >=258 shorts
a8a597b2 1166 * whereas other PVOPs point to a null terminated string.
1167 */
bec89253 1168 if (o->op_type == OP_TRANS &&
1169 (o->op_private & OPpTRANS_COMPLEMENT) &&
1170 !(o->op_private & OPpTRANS_DELETE))
1171 {
5d7488b2 1172 const short* const tbl = (short*)o->op_pv;
1173 const short entries = 257 + tbl[256];
bec89253 1174 ST(0) = sv_2mortal(newSVpv(o->op_pv, entries * sizeof(short)));
1175 }
1176 else if (o->op_type == OP_TRANS) {
1177 ST(0) = sv_2mortal(newSVpv(o->op_pv, 256 * sizeof(short)));
1178 }
1179 else
1180 ST(0) = sv_2mortal(newSVpv(o->op_pv, 0));
a8a597b2 1181
1182#define LOOP_redoop(o) o->op_redoop
1183#define LOOP_nextop(o) o->op_nextop
1184#define LOOP_lastop(o) o->op_lastop
1185
1186MODULE = B PACKAGE = B::LOOP PREFIX = LOOP_
1187
1188
1189B::OP
1190LOOP_redoop(o)
1191 B::LOOP o
1192
1193B::OP
1194LOOP_nextop(o)
1195 B::LOOP o
1196
1197B::OP
1198LOOP_lastop(o)
1199 B::LOOP o
1200
1201#define COP_label(o) o->cop_label
11faa288 1202#define COP_stashpv(o) CopSTASHPV(o)
1203#define COP_stash(o) CopSTASH(o)
57843af0 1204#define COP_file(o) CopFILE(o)
1df34986 1205#define COP_filegv(o) CopFILEGV(o)
a8a597b2 1206#define COP_cop_seq(o) o->cop_seq
fc15ae8f 1207#define COP_arybase(o) CopARYBASE_get(o)
57843af0 1208#define COP_line(o) CopLINE(o)
d5ec2987 1209#define COP_hints(o) CopHINTS_get(o)
e412117e 1210#if PERL_VERSION < 9
1211# define COP_warnings(o) o->cop_warnings
1212# define COP_io(o) o->cop_io
1213#endif
a8a597b2 1214
1215MODULE = B PACKAGE = B::COP PREFIX = COP_
1216
1217char *
1218COP_label(o)
1219 B::COP o
1220
11faa288 1221char *
1222COP_stashpv(o)
1223 B::COP o
1224
a8a597b2 1225B::HV
1226COP_stash(o)
1227 B::COP o
1228
57843af0 1229char *
1230COP_file(o)
a8a597b2 1231 B::COP o
1232
1df34986 1233B::GV
1234COP_filegv(o)
1235 B::COP o
1236
1237
a8a597b2 1238U32
1239COP_cop_seq(o)
1240 B::COP o
1241
1242I32
1243COP_arybase(o)
1244 B::COP o
1245
8bafa735 1246U32
a8a597b2 1247COP_line(o)
1248 B::COP o
1249
e412117e 1250#if PERL_VERSION >= 9
1251
5c3c3f81 1252void
b295d113 1253COP_warnings(o)
1254 B::COP o
5c3c3f81 1255 PPCODE:
1256 ST(0) = make_warnings_object(aTHX_ sv_newmortal(), o->cop_warnings);
1257 XSRETURN(1);
b295d113 1258
670f1322 1259void
6e6a1aef 1260COP_io(o)
1261 B::COP o
11bcd5da 1262 PPCODE:
8e01d9a6 1263 ST(0) = make_cop_io_object(aTHX_ sv_newmortal(), o);
11bcd5da 1264 XSRETURN(1);
6e6a1aef 1265
fd9f6265 1266B::RHE
1267COP_hints_hash(o)
1268 B::COP o
1269 CODE:
1270 RETVAL = o->cop_hints_hash;
1271 OUTPUT:
1272 RETVAL
1273
e412117e 1274#else
1275
1276B::SV
1277COP_warnings(o)
1278 B::COP o
1279
1280B::SV
1281COP_io(o)
1282 B::COP o
1283
1284#endif
1285
1286U32
1287COP_hints(o)
1288 B::COP o
1289
651aa52e 1290MODULE = B PACKAGE = B::SV
1291
1292U32
1293SvTYPE(sv)
1294 B::SV sv
1295
429a5ce7 1296#define object_2svref(sv) sv
1297#define SVREF SV *
1298
1299SVREF
1300object_2svref(sv)
1301 B::SV sv
1302
a8a597b2 1303MODULE = B PACKAGE = B::SV PREFIX = Sv
1304
1305U32
1306SvREFCNT(sv)
1307 B::SV sv
1308
1309U32
1310SvFLAGS(sv)
1311 B::SV sv
1312
651aa52e 1313U32
1314SvPOK(sv)
1315 B::SV sv
1316
1317U32
1318SvROK(sv)
1319 B::SV sv
1320
1321U32
1322SvMAGICAL(sv)
1323 B::SV sv
1324
a8a597b2 1325MODULE = B PACKAGE = B::IV PREFIX = Sv
1326
1327IV
1328SvIV(sv)
1329 B::IV sv
1330
1331IV
1332SvIVX(sv)
1333 B::IV sv
1334
0ca04487 1335UV
1336SvUVX(sv)
1337 B::IV sv
1338
1339
a8a597b2 1340MODULE = B PACKAGE = B::IV
1341
1342#define needs64bits(sv) ((I32)SvIVX(sv) != SvIVX(sv))
1343
1344int
1345needs64bits(sv)
1346 B::IV sv
1347
1348void
1349packiv(sv)
1350 B::IV sv
1351 CODE:
1352 if (sizeof(IV) == 8) {
1353 U32 wp[2];
5d7488b2 1354 const IV iv = SvIVX(sv);
a8a597b2 1355 /*
1356 * The following way of spelling 32 is to stop compilers on
1357 * 32-bit architectures from moaning about the shift count
1358 * being >= the width of the type. Such architectures don't
1359 * reach this code anyway (unless sizeof(IV) > 8 but then
1360 * everything else breaks too so I'm not fussed at the moment).
1361 */
42718184 1362#ifdef UV_IS_QUAD
1363 wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1364#else
1365 wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1366#endif
a8a597b2 1367 wp[1] = htonl(iv & 0xffffffff);
79cb57f6 1368 ST(0) = sv_2mortal(newSVpvn((char *)wp, 8));
a8a597b2 1369 } else {
1370 U32 w = htonl((U32)SvIVX(sv));
79cb57f6 1371 ST(0) = sv_2mortal(newSVpvn((char *)&w, 4));
a8a597b2 1372 }
1373
4df7f6af 1374
1375#if PERL_VERSION >= 11
1376
1377B::SV
1378RV(sv)
1379 B::IV sv
1380 CODE:
1381 if( SvROK(sv) ) {
1382 RETVAL = SvRV(sv);
1383 }
1384 else {
1385 croak( "argument is not SvROK" );
1386 }
1387 OUTPUT:
1388 RETVAL
1389
1390#endif
1391
a8a597b2 1392MODULE = B PACKAGE = B::NV PREFIX = Sv
1393
76ef7183 1394NV
a8a597b2 1395SvNV(sv)
1396 B::NV sv
1397
76ef7183 1398NV
a8a597b2 1399SvNVX(sv)
1400 B::NV sv
1401
809abb02 1402U32
1403COP_SEQ_RANGE_LOW(sv)
1404 B::NV sv
1405
1406U32
1407COP_SEQ_RANGE_HIGH(sv)
1408 B::NV sv
1409
1410U32
1411PARENT_PAD_INDEX(sv)
1412 B::NV sv
1413
1414U32
1415PARENT_FAKELEX_FLAGS(sv)
1416 B::NV sv
1417
4df7f6af 1418#if PERL_VERSION < 11
1419
a8a597b2 1420MODULE = B PACKAGE = B::RV PREFIX = Sv
1421
1422B::SV
1423SvRV(sv)
1424 B::RV sv
1425
4df7f6af 1426#endif
1427
a8a597b2 1428MODULE = B PACKAGE = B::PV PREFIX = Sv
1429
0b40bd6d 1430char*
1431SvPVX(sv)
1432 B::PV sv
1433
b326da91 1434B::SV
1435SvRV(sv)
1436 B::PV sv
1437 CODE:
1438 if( SvROK(sv) ) {
1439 RETVAL = SvRV(sv);
1440 }
1441 else {
1442 croak( "argument is not SvROK" );
1443 }
1444 OUTPUT:
1445 RETVAL
1446
a8a597b2 1447void
1448SvPV(sv)
1449 B::PV sv
1450 CODE:
b326da91 1451 ST(0) = sv_newmortal();
c0b20461 1452 if( SvPOK(sv) ) {
b55685ae 1453 /* FIXME - we need a better way for B to identify PVs that are
1454 in the pads as variable names. */
1455 if((SvLEN(sv) && SvCUR(sv) >= SvLEN(sv))) {
1456 /* It claims to be longer than the space allocated for it -
1457 presuambly it's a variable name in the pad */
1458 sv_setpv(ST(0), SvPV_nolen_const(sv));
1459 } else {
1460 sv_setpvn(ST(0), SvPVX_const(sv), SvCUR(sv));
1461 }
b326da91 1462 SvFLAGS(ST(0)) |= SvUTF8(sv);
1463 }
1464 else {
1465 /* XXX for backward compatibility, but should fail */
1466 /* croak( "argument is not SvPOK" ); */
1467 sv_setpvn(ST(0), NULL, 0);
1468 }
a8a597b2 1469
5a44e503 1470# This used to read 257. I think that that was buggy - should have been 258.
1471# (The "\0", the flags byte, and 256 for the table. Not that anything
1472# anywhere calls this method. NWC.
651aa52e 1473void
1474SvPVBM(sv)
1475 B::PV sv
1476 CODE:
1477 ST(0) = sv_newmortal();
aa07b2f6 1478 sv_setpvn(ST(0), SvPVX_const(sv),
5a44e503 1479 SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0));
651aa52e 1480
1481
445a12f6 1482STRLEN
1483SvLEN(sv)
1484 B::PV sv
1485
1486STRLEN
1487SvCUR(sv)
1488 B::PV sv
1489
a8a597b2 1490MODULE = B PACKAGE = B::PVMG PREFIX = Sv
1491
1492void
1493SvMAGIC(sv)
1494 B::PVMG sv
1495 MAGIC * mg = NO_INIT
1496 PPCODE:
1497 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
cea2e8a9 1498 XPUSHs(make_mg_object(aTHX_ sv_newmortal(), mg));
a8a597b2 1499
1500MODULE = B PACKAGE = B::PVMG
1501
1502B::HV
1503SvSTASH(sv)
1504 B::PVMG sv
1505
1506#define MgMOREMAGIC(mg) mg->mg_moremagic
1507#define MgPRIVATE(mg) mg->mg_private
1508#define MgTYPE(mg) mg->mg_type
1509#define MgFLAGS(mg) mg->mg_flags
1510#define MgOBJ(mg) mg->mg_obj
88b39979 1511#define MgLENGTH(mg) mg->mg_len
bde7177d 1512#define MgREGEX(mg) PTR2IV(mg->mg_obj)
a8a597b2 1513
1514MODULE = B PACKAGE = B::MAGIC PREFIX = Mg
1515
1516B::MAGIC
1517MgMOREMAGIC(mg)
1518 B::MAGIC mg
c5f0f3aa 1519 CODE:
1520 if( MgMOREMAGIC(mg) ) {
1521 RETVAL = MgMOREMAGIC(mg);
1522 }
1523 else {
1524 XSRETURN_UNDEF;
1525 }
1526 OUTPUT:
1527 RETVAL
a8a597b2 1528
1529U16
1530MgPRIVATE(mg)
1531 B::MAGIC mg
1532
1533char
1534MgTYPE(mg)
1535 B::MAGIC mg
1536
1537U8
1538MgFLAGS(mg)
1539 B::MAGIC mg
1540
1541B::SV
1542MgOBJ(mg)
1543 B::MAGIC mg
b326da91 1544
9d2bbe64 1545IV
1546MgREGEX(mg)
1547 B::MAGIC mg
1548 CODE:
a8248b05 1549 if(mg->mg_type == PERL_MAGIC_qr) {
9d2bbe64 1550 RETVAL = MgREGEX(mg);
1551 }
1552 else {
1553 croak( "REGEX is only meaningful on r-magic" );
1554 }
1555 OUTPUT:
1556 RETVAL
1557
b326da91 1558SV*
1559precomp(mg)
1560 B::MAGIC mg
1561 CODE:
a8248b05 1562 if (mg->mg_type == PERL_MAGIC_qr) {
b326da91 1563 REGEXP* rx = (REGEXP*)mg->mg_obj;
ef35129c 1564 RETVAL = Nullsv;
b326da91 1565 if( rx )
1566 RETVAL = newSVpvn( rx->precomp, rx->prelen );
1567 }
1568 else {
1569 croak( "precomp is only meaningful on r-magic" );
1570 }
1571 OUTPUT:
1572 RETVAL
a8a597b2 1573
88b39979 1574I32
1575MgLENGTH(mg)
1576 B::MAGIC mg
1577
a8a597b2 1578void
1579MgPTR(mg)
1580 B::MAGIC mg
1581 CODE:
1582 ST(0) = sv_newmortal();
88b39979 1583 if (mg->mg_ptr){
1584 if (mg->mg_len >= 0){
1585 sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len);
651aa52e 1586 } else if (mg->mg_len == HEf_SVKEY) {
1587 ST(0) = make_sv_object(aTHX_
1588 sv_newmortal(), (SV*)mg->mg_ptr);
88b39979 1589 }
1590 }
a8a597b2 1591
1592MODULE = B PACKAGE = B::PVLV PREFIX = Lv
1593
1594U32
1595LvTARGOFF(sv)
1596 B::PVLV sv
1597
1598U32
1599LvTARGLEN(sv)
1600 B::PVLV sv
1601
1602char
1603LvTYPE(sv)
1604 B::PVLV sv
1605
1606B::SV
1607LvTARG(sv)
1608 B::PVLV sv
1609
1610MODULE = B PACKAGE = B::BM PREFIX = Bm
1611
1612I32
1613BmUSEFUL(sv)
1614 B::BM sv
1615
85c508c3 1616U32
a8a597b2 1617BmPREVIOUS(sv)
1618 B::BM sv
1619
1620U8
1621BmRARE(sv)
1622 B::BM sv
1623
1624void
1625BmTABLE(sv)
1626 B::BM sv
1627 STRLEN len = NO_INIT
1628 char * str = NO_INIT
1629 CODE:
1630 str = SvPV(sv, len);
1631 /* Boyer-Moore table is just after string and its safety-margin \0 */
5a44e503 1632 ST(0) = sv_2mortal(newSVpvn(str + len + PERL_FBM_TABLE_OFFSET, 256));
a8a597b2 1633
1634MODULE = B PACKAGE = B::GV PREFIX = Gv
1635
1636void
1637GvNAME(gv)
1638 B::GV gv
1639 CODE:
79cb57f6 1640 ST(0) = sv_2mortal(newSVpvn(GvNAME(gv), GvNAMELEN(gv)));
a8a597b2 1641
87d7fd28 1642bool
1643is_empty(gv)
1644 B::GV gv
1645 CODE:
1646 RETVAL = GvGP(gv) == Null(GP*);
1647 OUTPUT:
1648 RETVAL
1649
50786ba8 1650bool
1651isGV_with_GP(gv)
1652 B::GV gv
1653 CODE:
1654#if PERL_VERSION >= 9
1655 RETVAL = isGV_with_GP(gv) ? TRUE : FALSE;
1656#else
1657 RETVAL = TRUE; /* In 5.8 and earlier they all are. */
1658#endif
1659 OUTPUT:
1660 RETVAL
1661
651aa52e 1662void*
1663GvGP(gv)
1664 B::GV gv
1665
a8a597b2 1666B::HV
1667GvSTASH(gv)
1668 B::GV gv
1669
1670B::SV
1671GvSV(gv)
1672 B::GV gv
1673
1674B::IO
1675GvIO(gv)
1676 B::GV gv
1677
1df34986 1678B::FM
a8a597b2 1679GvFORM(gv)
1680 B::GV gv
1df34986 1681 CODE:
1682 RETVAL = (SV*)GvFORM(gv);
1683 OUTPUT:
1684 RETVAL
a8a597b2 1685
1686B::AV
1687GvAV(gv)
1688 B::GV gv
1689
1690B::HV
1691GvHV(gv)
1692 B::GV gv
1693
1694B::GV
1695GvEGV(gv)
1696 B::GV gv
1697
1698B::CV
1699GvCV(gv)
1700 B::GV gv
1701
1702U32
1703GvCVGEN(gv)
1704 B::GV gv
1705
8bafa735 1706U32
a8a597b2 1707GvLINE(gv)
1708 B::GV gv
1709
b195d487 1710char *
1711GvFILE(gv)
1712 B::GV gv
1713
a8a597b2 1714B::GV
1715GvFILEGV(gv)
1716 B::GV gv
1717
1718MODULE = B PACKAGE = B::GV
1719
1720U32
1721GvREFCNT(gv)
1722 B::GV gv
1723
1724U8
1725GvFLAGS(gv)
1726 B::GV gv
1727
1728MODULE = B PACKAGE = B::IO PREFIX = Io
1729
1730long
1731IoLINES(io)
1732 B::IO io
1733
1734long
1735IoPAGE(io)
1736 B::IO io
1737
1738long
1739IoPAGE_LEN(io)
1740 B::IO io
1741
1742long
1743IoLINES_LEFT(io)
1744 B::IO io
1745
1746char *
1747IoTOP_NAME(io)
1748 B::IO io
1749
1750B::GV
1751IoTOP_GV(io)
1752 B::IO io
1753
1754char *
1755IoFMT_NAME(io)
1756 B::IO io
1757
1758B::GV
1759IoFMT_GV(io)
1760 B::IO io
1761
1762char *
1763IoBOTTOM_NAME(io)
1764 B::IO io
1765
1766B::GV
1767IoBOTTOM_GV(io)
1768 B::IO io
1769
04071355 1770#if PERL_VERSION <= 8
1771
a8a597b2 1772short
1773IoSUBPROCESS(io)
1774 B::IO io
1775
04071355 1776#endif
1777
b326da91 1778bool
1779IsSTD(io,name)
1780 B::IO io
5d7488b2 1781 const char* name
b326da91 1782 PREINIT:
1783 PerlIO* handle = 0;
1784 CODE:
1785 if( strEQ( name, "stdin" ) ) {
1786 handle = PerlIO_stdin();
1787 }
1788 else if( strEQ( name, "stdout" ) ) {
1789 handle = PerlIO_stdout();
1790 }
1791 else if( strEQ( name, "stderr" ) ) {
1792 handle = PerlIO_stderr();
1793 }
1794 else {
1795 croak( "Invalid value '%s'", name );
1796 }
1797 RETVAL = handle == IoIFP(io);
1798 OUTPUT:
1799 RETVAL
1800
a8a597b2 1801MODULE = B PACKAGE = B::IO
1802
1803char
1804IoTYPE(io)
1805 B::IO io
1806
1807U8
1808IoFLAGS(io)
1809 B::IO io
1810
1811MODULE = B PACKAGE = B::AV PREFIX = Av
1812
1813SSize_t
1814AvFILL(av)
1815 B::AV av
1816
1817SSize_t
1818AvMAX(av)
1819 B::AV av
1820
edcc7c74 1821#if PERL_VERSION < 9
1822
1823
1824#define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1825
1826IV
1827AvOFF(av)
1828 B::AV av
1829
1830#endif
1831
a8a597b2 1832void
1833AvARRAY(av)
1834 B::AV av
1835 PPCODE:
1836 if (AvFILL(av) >= 0) {
1837 SV **svp = AvARRAY(av);
1838 I32 i;
1839 for (i = 0; i <= AvFILL(av); i++)
cea2e8a9 1840 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), svp[i]));
a8a597b2 1841 }
1842
429a5ce7 1843void
1844AvARRAYelt(av, idx)
1845 B::AV av
1846 int idx
1847 PPCODE:
1848 if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
1849 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), (AvARRAY(av)[idx])));
1850 else
1851 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), NULL));
1852
edcc7c74 1853#if PERL_VERSION < 9
1854
1855MODULE = B PACKAGE = B::AV
1856
1857U8
1858AvFLAGS(av)
1859 B::AV av
1860
1861#endif
1862
1df34986 1863MODULE = B PACKAGE = B::FM PREFIX = Fm
1864
1865IV
1866FmLINES(form)
1867 B::FM form
1868
a8a597b2 1869MODULE = B PACKAGE = B::CV PREFIX = Cv
1870
651aa52e 1871U32
1872CvCONST(cv)
1873 B::CV cv
1874
a8a597b2 1875B::HV
1876CvSTASH(cv)
1877 B::CV cv
1878
1879B::OP
1880CvSTART(cv)
1881 B::CV cv
bf53b3a5 1882 CODE:
1883 RETVAL = CvISXSUB(cv) ? NULL : CvSTART(cv);
1884 OUTPUT:
1885 RETVAL
a8a597b2 1886
1887B::OP
1888CvROOT(cv)
1889 B::CV cv
d04ba589 1890 CODE:
1891 RETVAL = CvISXSUB(cv) ? NULL : CvROOT(cv);
1892 OUTPUT:
1893 RETVAL
a8a597b2 1894
1895B::GV
1896CvGV(cv)
1897 B::CV cv
1898
57843af0 1899char *
1900CvFILE(cv)
1901 B::CV cv
1902
a8a597b2 1903long
1904CvDEPTH(cv)
1905 B::CV cv
1906
1907B::AV
1908CvPADLIST(cv)
1909 B::CV cv
1910
1911B::CV
1912CvOUTSIDE(cv)
1913 B::CV cv
1914
a3985cdc 1915U32
1916CvOUTSIDE_SEQ(cv)
1917 B::CV cv
1918
a8a597b2 1919void
1920CvXSUB(cv)
1921 B::CV cv
1922 CODE:
d04ba589 1923 ST(0) = sv_2mortal(newSViv(CvISXSUB(cv) ? PTR2IV(CvXSUB(cv)) : 0));
a8a597b2 1924
1925
1926void
1927CvXSUBANY(cv)
1928 B::CV cv
1929 CODE:
b326da91 1930 ST(0) = CvCONST(cv) ?
07409e01 1931 make_sv_object(aTHX_ sv_newmortal(),(SV *)CvXSUBANY(cv).any_ptr) :
bf53b3a5 1932 sv_2mortal(newSViv(CvISXSUB(cv) ? CvXSUBANY(cv).any_iv : 0));
a8a597b2 1933
5cfd8ad4 1934MODULE = B PACKAGE = B::CV
1935
6aaf4108 1936U16
5cfd8ad4 1937CvFLAGS(cv)
1938 B::CV cv
1939
de3f1649 1940MODULE = B PACKAGE = B::CV PREFIX = cv_
1941
1942B::SV
1943cv_const_sv(cv)
1944 B::CV cv
1945
5cfd8ad4 1946
a8a597b2 1947MODULE = B PACKAGE = B::HV PREFIX = Hv
1948
1949STRLEN
1950HvFILL(hv)
1951 B::HV hv
1952
1953STRLEN
1954HvMAX(hv)
1955 B::HV hv
1956
1957I32
1958HvKEYS(hv)
1959 B::HV hv
1960
1961I32
1962HvRITER(hv)
1963 B::HV hv
1964
1965char *
1966HvNAME(hv)
1967 B::HV hv
1968
edcc7c74 1969#if PERL_VERSION < 9
1970
1971B::PMOP
1972HvPMROOT(hv)
1973 B::HV hv
1974
1975#endif
1976
a8a597b2 1977void
1978HvARRAY(hv)
1979 B::HV hv
1980 PPCODE:
1981 if (HvKEYS(hv) > 0) {
1982 SV *sv;
1983 char *key;
1984 I32 len;
1985 (void)hv_iterinit(hv);
1986 EXTEND(sp, HvKEYS(hv) * 2);
8063af02 1987 while ((sv = hv_iternextsv(hv, &key, &len))) {
79cb57f6 1988 PUSHs(newSVpvn(key, len));
cea2e8a9 1989 PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv));
a8a597b2 1990 }
1991 }
fd9f6265 1992
1993MODULE = B PACKAGE = B::HE PREFIX = He
1994
1995B::SV
1996HeVAL(he)
1997 B::HE he
1998
1999U32
2000HeHASH(he)
2001 B::HE he
2002
2003B::SV
2004HeSVKEY_force(he)
2005 B::HE he
2006
2007MODULE = B PACKAGE = B::RHE PREFIX = RHE_
2008
e412117e 2009#if PERL_VERSION >= 9
2010
fd9f6265 2011SV*
2012RHE_HASH(h)
2013 B::RHE h
2014 CODE:
38d45822 2015 RETVAL = newRV( (SV*)Perl_refcounted_he_chain_2hv(aTHX_ h) );
fd9f6265 2016 OUTPUT:
2017 RETVAL
e412117e 2018
2019#endif
Unnamed repository; edit this file to name it for gitweb.