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