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