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