projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
Remove support for assertions and -A
[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
848# define OP_static(o) o->op_static
849#else
850# define OP_seq(o) o->op_seq
851#endif
a8a597b2 852#define OP_flags(o) o->op_flags
853#define OP_private(o) o->op_private
a60ba18b 854#define OP_spare(o) o->op_spare
a8a597b2 855
856MODULE = B PACKAGE = B::OP PREFIX = OP_
857
651aa52e 858size_t
859OP_size(o)
860 B::OP o
861 CODE:
862 RETVAL = opsizes[cc_opclass(aTHX_ o)];
863 OUTPUT:
864 RETVAL
865
a8a597b2 866B::OP
867OP_next(o)
868 B::OP o
869
870B::OP
871OP_sibling(o)
872 B::OP o
873
874char *
3f872cb9 875OP_name(o)
876 B::OP o
877 CODE:
27da23d5 878 RETVAL = (char *)PL_op_name[o->op_type];
8063af02 879 OUTPUT:
880 RETVAL
3f872cb9 881
882
8063af02 883void
a8a597b2 884OP_ppaddr(o)
885 B::OP o
dc333d64 886 PREINIT:
887 int i;
888 SV *sv = sv_newmortal();
a8a597b2 889 CODE:
dc333d64 890 sv_setpvn(sv, "PL_ppaddr[OP_", 13);
891 sv_catpv(sv, PL_op_name[o->op_type]);
7c436af3 892 for (i=13; (STRLEN)i < SvCUR(sv); ++i)
dc333d64 893 SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]);
894 sv_catpv(sv, "]");
895 ST(0) = sv;
a8a597b2 896
897char *
898OP_desc(o)
899 B::OP o
900
7934575e 901PADOFFSET
a8a597b2 902OP_targ(o)
903 B::OP o
904
905U16
906OP_type(o)
907 B::OP o
908
7252851f 909#if PERL_VERSION >= 9
910
2814eb74 911U8
912OP_opt(o)
913 B::OP o
914
915U8
916OP_static(o)
a8a597b2 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
1374MODULE = B PACKAGE = B::NV PREFIX = Sv
1375
76ef7183 1376NV
a8a597b2 1377SvNV(sv)
1378 B::NV sv
1379
76ef7183 1380NV
a8a597b2 1381SvNVX(sv)
1382 B::NV sv
1383
809abb02 1384U32
1385COP_SEQ_RANGE_LOW(sv)
1386 B::NV sv
1387
1388U32
1389COP_SEQ_RANGE_HIGH(sv)
1390 B::NV sv
1391
1392U32
1393PARENT_PAD_INDEX(sv)
1394 B::NV sv
1395
1396U32
1397PARENT_FAKELEX_FLAGS(sv)
1398 B::NV sv
1399
a8a597b2 1400MODULE = B PACKAGE = B::RV PREFIX = Sv
1401
1402B::SV
1403SvRV(sv)
1404 B::RV sv
1405
1406MODULE = B PACKAGE = B::PV PREFIX = Sv
1407
0b40bd6d 1408char*
1409SvPVX(sv)
1410 B::PV sv
1411
b326da91 1412B::SV
1413SvRV(sv)
1414 B::PV sv
1415 CODE:
1416 if( SvROK(sv) ) {
1417 RETVAL = SvRV(sv);
1418 }
1419 else {
1420 croak( "argument is not SvROK" );
1421 }
1422 OUTPUT:
1423 RETVAL
1424
a8a597b2 1425void
1426SvPV(sv)
1427 B::PV sv
1428 CODE:
b326da91 1429 ST(0) = sv_newmortal();
c0b20461 1430 if( SvPOK(sv) ) {
b55685ae 1431 /* FIXME - we need a better way for B to identify PVs that are
1432 in the pads as variable names. */
1433 if((SvLEN(sv) && SvCUR(sv) >= SvLEN(sv))) {
1434 /* It claims to be longer than the space allocated for it -
1435 presuambly it's a variable name in the pad */
1436 sv_setpv(ST(0), SvPV_nolen_const(sv));
1437 } else {
1438 sv_setpvn(ST(0), SvPVX_const(sv), SvCUR(sv));
1439 }
b326da91 1440 SvFLAGS(ST(0)) |= SvUTF8(sv);
1441 }
1442 else {
1443 /* XXX for backward compatibility, but should fail */
1444 /* croak( "argument is not SvPOK" ); */
1445 sv_setpvn(ST(0), NULL, 0);
1446 }
a8a597b2 1447
5a44e503 1448# This used to read 257. I think that that was buggy - should have been 258.
1449# (The "\0", the flags byte, and 256 for the table. Not that anything
1450# anywhere calls this method. NWC.
651aa52e 1451void
1452SvPVBM(sv)
1453 B::PV sv
1454 CODE:
1455 ST(0) = sv_newmortal();
aa07b2f6 1456 sv_setpvn(ST(0), SvPVX_const(sv),
5a44e503 1457 SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0));
651aa52e 1458
1459
445a12f6 1460STRLEN
1461SvLEN(sv)
1462 B::PV sv
1463
1464STRLEN
1465SvCUR(sv)
1466 B::PV sv
1467
a8a597b2 1468MODULE = B PACKAGE = B::PVMG PREFIX = Sv
1469
1470void
1471SvMAGIC(sv)
1472 B::PVMG sv
1473 MAGIC * mg = NO_INIT
1474 PPCODE:
1475 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
cea2e8a9 1476 XPUSHs(make_mg_object(aTHX_ sv_newmortal(), mg));
a8a597b2 1477
1478MODULE = B PACKAGE = B::PVMG
1479
1480B::HV
1481SvSTASH(sv)
1482 B::PVMG sv
1483
1484#define MgMOREMAGIC(mg) mg->mg_moremagic
1485#define MgPRIVATE(mg) mg->mg_private
1486#define MgTYPE(mg) mg->mg_type
1487#define MgFLAGS(mg) mg->mg_flags
1488#define MgOBJ(mg) mg->mg_obj
88b39979 1489#define MgLENGTH(mg) mg->mg_len
bde7177d 1490#define MgREGEX(mg) PTR2IV(mg->mg_obj)
a8a597b2 1491
1492MODULE = B PACKAGE = B::MAGIC PREFIX = Mg
1493
1494B::MAGIC
1495MgMOREMAGIC(mg)
1496 B::MAGIC mg
c5f0f3aa 1497 CODE:
1498 if( MgMOREMAGIC(mg) ) {
1499 RETVAL = MgMOREMAGIC(mg);
1500 }
1501 else {
1502 XSRETURN_UNDEF;
1503 }
1504 OUTPUT:
1505 RETVAL
a8a597b2 1506
1507U16
1508MgPRIVATE(mg)
1509 B::MAGIC mg
1510
1511char
1512MgTYPE(mg)
1513 B::MAGIC mg
1514
1515U8
1516MgFLAGS(mg)
1517 B::MAGIC mg
1518
1519B::SV
1520MgOBJ(mg)
1521 B::MAGIC mg
b326da91 1522
9d2bbe64 1523IV
1524MgREGEX(mg)
1525 B::MAGIC mg
1526 CODE:
a8248b05 1527 if(mg->mg_type == PERL_MAGIC_qr) {
9d2bbe64 1528 RETVAL = MgREGEX(mg);
1529 }
1530 else {
1531 croak( "REGEX is only meaningful on r-magic" );
1532 }
1533 OUTPUT:
1534 RETVAL
1535
b326da91 1536SV*
1537precomp(mg)
1538 B::MAGIC mg
1539 CODE:
a8248b05 1540 if (mg->mg_type == PERL_MAGIC_qr) {
b326da91 1541 REGEXP* rx = (REGEXP*)mg->mg_obj;
ef35129c 1542 RETVAL = Nullsv;
b326da91 1543 if( rx )
1544 RETVAL = newSVpvn( rx->precomp, rx->prelen );
1545 }
1546 else {
1547 croak( "precomp is only meaningful on r-magic" );
1548 }
1549 OUTPUT:
1550 RETVAL
a8a597b2 1551
88b39979 1552I32
1553MgLENGTH(mg)
1554 B::MAGIC mg
1555
a8a597b2 1556void
1557MgPTR(mg)
1558 B::MAGIC mg
1559 CODE:
1560 ST(0) = sv_newmortal();
88b39979 1561 if (mg->mg_ptr){
1562 if (mg->mg_len >= 0){
1563 sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len);
651aa52e 1564 } else if (mg->mg_len == HEf_SVKEY) {
1565 ST(0) = make_sv_object(aTHX_
1566 sv_newmortal(), (SV*)mg->mg_ptr);
88b39979 1567 }
1568 }
a8a597b2 1569
1570MODULE = B PACKAGE = B::PVLV PREFIX = Lv
1571
1572U32
1573LvTARGOFF(sv)
1574 B::PVLV sv
1575
1576U32
1577LvTARGLEN(sv)
1578 B::PVLV sv
1579
1580char
1581LvTYPE(sv)
1582 B::PVLV sv
1583
1584B::SV
1585LvTARG(sv)
1586 B::PVLV sv
1587
1588MODULE = B PACKAGE = B::BM PREFIX = Bm
1589
1590I32
1591BmUSEFUL(sv)
1592 B::BM sv
1593
85c508c3 1594U32
a8a597b2 1595BmPREVIOUS(sv)
1596 B::BM sv
1597
1598U8
1599BmRARE(sv)
1600 B::BM sv
1601
1602void
1603BmTABLE(sv)
1604 B::BM sv
1605 STRLEN len = NO_INIT
1606 char * str = NO_INIT
1607 CODE:
1608 str = SvPV(sv, len);
1609 /* Boyer-Moore table is just after string and its safety-margin \0 */
5a44e503 1610 ST(0) = sv_2mortal(newSVpvn(str + len + PERL_FBM_TABLE_OFFSET, 256));
a8a597b2 1611
1612MODULE = B PACKAGE = B::GV PREFIX = Gv
1613
1614void
1615GvNAME(gv)
1616 B::GV gv
1617 CODE:
79cb57f6 1618 ST(0) = sv_2mortal(newSVpvn(GvNAME(gv), GvNAMELEN(gv)));
a8a597b2 1619
87d7fd28 1620bool
1621is_empty(gv)
1622 B::GV gv
1623 CODE:
1624 RETVAL = GvGP(gv) == Null(GP*);
1625 OUTPUT:
1626 RETVAL
1627
651aa52e 1628void*
1629GvGP(gv)
1630 B::GV gv
1631
a8a597b2 1632B::HV
1633GvSTASH(gv)
1634 B::GV gv
1635
1636B::SV
1637GvSV(gv)
1638 B::GV gv
1639
1640B::IO
1641GvIO(gv)
1642 B::GV gv
1643
1df34986 1644B::FM
a8a597b2 1645GvFORM(gv)
1646 B::GV gv
1df34986 1647 CODE:
1648 RETVAL = (SV*)GvFORM(gv);
1649 OUTPUT:
1650 RETVAL
a8a597b2 1651
1652B::AV
1653GvAV(gv)
1654 B::GV gv
1655
1656B::HV
1657GvHV(gv)
1658 B::GV gv
1659
1660B::GV
1661GvEGV(gv)
1662 B::GV gv
1663
1664B::CV
1665GvCV(gv)
1666 B::GV gv
1667
1668U32
1669GvCVGEN(gv)
1670 B::GV gv
1671
8bafa735 1672U32
a8a597b2 1673GvLINE(gv)
1674 B::GV gv
1675
b195d487 1676char *
1677GvFILE(gv)
1678 B::GV gv
1679
a8a597b2 1680B::GV
1681GvFILEGV(gv)
1682 B::GV gv
1683
1684MODULE = B PACKAGE = B::GV
1685
1686U32
1687GvREFCNT(gv)
1688 B::GV gv
1689
1690U8
1691GvFLAGS(gv)
1692 B::GV gv
1693
1694MODULE = B PACKAGE = B::IO PREFIX = Io
1695
1696long
1697IoLINES(io)
1698 B::IO io
1699
1700long
1701IoPAGE(io)
1702 B::IO io
1703
1704long
1705IoPAGE_LEN(io)
1706 B::IO io
1707
1708long
1709IoLINES_LEFT(io)
1710 B::IO io
1711
1712char *
1713IoTOP_NAME(io)
1714 B::IO io
1715
1716B::GV
1717IoTOP_GV(io)
1718 B::IO io
1719
1720char *
1721IoFMT_NAME(io)
1722 B::IO io
1723
1724B::GV
1725IoFMT_GV(io)
1726 B::IO io
1727
1728char *
1729IoBOTTOM_NAME(io)
1730 B::IO io
1731
1732B::GV
1733IoBOTTOM_GV(io)
1734 B::IO io
1735
1736short
1737IoSUBPROCESS(io)
1738 B::IO io
1739
b326da91 1740bool
1741IsSTD(io,name)
1742 B::IO io
5d7488b2 1743 const char* name
b326da91 1744 PREINIT:
1745 PerlIO* handle = 0;
1746 CODE:
1747 if( strEQ( name, "stdin" ) ) {
1748 handle = PerlIO_stdin();
1749 }
1750 else if( strEQ( name, "stdout" ) ) {
1751 handle = PerlIO_stdout();
1752 }
1753 else if( strEQ( name, "stderr" ) ) {
1754 handle = PerlIO_stderr();
1755 }
1756 else {
1757 croak( "Invalid value '%s'", name );
1758 }
1759 RETVAL = handle == IoIFP(io);
1760 OUTPUT:
1761 RETVAL
1762
a8a597b2 1763MODULE = B PACKAGE = B::IO
1764
1765char
1766IoTYPE(io)
1767 B::IO io
1768
1769U8
1770IoFLAGS(io)
1771 B::IO io
1772
1773MODULE = B PACKAGE = B::AV PREFIX = Av
1774
1775SSize_t
1776AvFILL(av)
1777 B::AV av
1778
1779SSize_t
1780AvMAX(av)
1781 B::AV av
1782
edcc7c74 1783#if PERL_VERSION < 9
1784
1785
1786#define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1787
1788IV
1789AvOFF(av)
1790 B::AV av
1791
1792#endif
1793
a8a597b2 1794void
1795AvARRAY(av)
1796 B::AV av
1797 PPCODE:
1798 if (AvFILL(av) >= 0) {
1799 SV **svp = AvARRAY(av);
1800 I32 i;
1801 for (i = 0; i <= AvFILL(av); i++)
cea2e8a9 1802 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), svp[i]));
a8a597b2 1803 }
1804
429a5ce7 1805void
1806AvARRAYelt(av, idx)
1807 B::AV av
1808 int idx
1809 PPCODE:
1810 if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
1811 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), (AvARRAY(av)[idx])));
1812 else
1813 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), NULL));
1814
edcc7c74 1815#if PERL_VERSION < 9
1816
1817MODULE = B PACKAGE = B::AV
1818
1819U8
1820AvFLAGS(av)
1821 B::AV av
1822
1823#endif
1824
1df34986 1825MODULE = B PACKAGE = B::FM PREFIX = Fm
1826
1827IV
1828FmLINES(form)
1829 B::FM form
1830
a8a597b2 1831MODULE = B PACKAGE = B::CV PREFIX = Cv
1832
651aa52e 1833U32
1834CvCONST(cv)
1835 B::CV cv
1836
a8a597b2 1837B::HV
1838CvSTASH(cv)
1839 B::CV cv
1840
1841B::OP
1842CvSTART(cv)
1843 B::CV cv
bf53b3a5 1844 CODE:
1845 RETVAL = CvISXSUB(cv) ? NULL : CvSTART(cv);
1846 OUTPUT:
1847 RETVAL
a8a597b2 1848
1849B::OP
1850CvROOT(cv)
1851 B::CV cv
d04ba589 1852 CODE:
1853 RETVAL = CvISXSUB(cv) ? NULL : CvROOT(cv);
1854 OUTPUT:
1855 RETVAL
a8a597b2 1856
1857B::GV
1858CvGV(cv)
1859 B::CV cv
1860
57843af0 1861char *
1862CvFILE(cv)
1863 B::CV cv
1864
a8a597b2 1865long
1866CvDEPTH(cv)
1867 B::CV cv
1868
1869B::AV
1870CvPADLIST(cv)
1871 B::CV cv
1872
1873B::CV
1874CvOUTSIDE(cv)
1875 B::CV cv
1876
a3985cdc 1877U32
1878CvOUTSIDE_SEQ(cv)
1879 B::CV cv
1880
a8a597b2 1881void
1882CvXSUB(cv)
1883 B::CV cv
1884 CODE:
d04ba589 1885 ST(0) = sv_2mortal(newSViv(CvISXSUB(cv) ? PTR2IV(CvXSUB(cv)) : 0));
a8a597b2 1886
1887
1888void
1889CvXSUBANY(cv)
1890 B::CV cv
1891 CODE:
b326da91 1892 ST(0) = CvCONST(cv) ?
07409e01 1893 make_sv_object(aTHX_ sv_newmortal(),(SV *)CvXSUBANY(cv).any_ptr) :
bf53b3a5 1894 sv_2mortal(newSViv(CvISXSUB(cv) ? CvXSUBANY(cv).any_iv : 0));
a8a597b2 1895
5cfd8ad4 1896MODULE = B PACKAGE = B::CV
1897
6aaf4108 1898U16
5cfd8ad4 1899CvFLAGS(cv)
1900 B::CV cv
1901
de3f1649 1902MODULE = B PACKAGE = B::CV PREFIX = cv_
1903
1904B::SV
1905cv_const_sv(cv)
1906 B::CV cv
1907
5cfd8ad4 1908
a8a597b2 1909MODULE = B PACKAGE = B::HV PREFIX = Hv
1910
1911STRLEN
1912HvFILL(hv)
1913 B::HV hv
1914
1915STRLEN
1916HvMAX(hv)
1917 B::HV hv
1918
1919I32
1920HvKEYS(hv)
1921 B::HV hv
1922
1923I32
1924HvRITER(hv)
1925 B::HV hv
1926
1927char *
1928HvNAME(hv)
1929 B::HV hv
1930
edcc7c74 1931#if PERL_VERSION < 9
1932
1933B::PMOP
1934HvPMROOT(hv)
1935 B::HV hv
1936
1937#endif
1938
a8a597b2 1939void
1940HvARRAY(hv)
1941 B::HV hv
1942 PPCODE:
1943 if (HvKEYS(hv) > 0) {
1944 SV *sv;
1945 char *key;
1946 I32 len;
1947 (void)hv_iterinit(hv);
1948 EXTEND(sp, HvKEYS(hv) * 2);
8063af02 1949 while ((sv = hv_iternextsv(hv, &key, &len))) {
79cb57f6 1950 PUSHs(newSVpvn(key, len));
cea2e8a9 1951 PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv));
a8a597b2 1952 }
1953 }
fd9f6265 1954
1955MODULE = B PACKAGE = B::HE PREFIX = He
1956
1957B::SV
1958HeVAL(he)
1959 B::HE he
1960
1961U32
1962HeHASH(he)
1963 B::HE he
1964
1965B::SV
1966HeSVKEY_force(he)
1967 B::HE he
1968
1969MODULE = B PACKAGE = B::RHE PREFIX = RHE_
1970
e412117e 1971#if PERL_VERSION >= 9
1972
fd9f6265 1973SV*
1974RHE_HASH(h)
1975 B::RHE h
1976 CODE:
38d45822 1977 RETVAL = newRV( (SV*)Perl_refcounted_he_chain_2hv(aTHX_ h) );
fd9f6265 1978 OUTPUT:
1979 RETVAL
e412117e 1980
1981#endif
Unnamed repository; edit this file to name it for gitweb.