projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
Re: [PATCH] User pragmas now accessible from B
[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",
24 "B::IV",
25 "B::NV",
26 "B::RV",
27 "B::PV",
28 "B::PVIV",
29 "B::PVNV",
30 "B::PVMG",
31 "B::BM",
7252851f 32#if PERL_VERSION >= 9
4ce457a6 33 "B::GV",
7252851f 34#endif
a8a597b2 35 "B::PVLV",
36 "B::AV",
37 "B::HV",
38 "B::CV",
7252851f 39#if PERL_VERSION <= 8
40 "B::GV",
41#endif
a8a597b2 42 "B::FM",
43 "B::IO",
44};
45
46typedef enum {
47 OPc_NULL, /* 0 */
48 OPc_BASEOP, /* 1 */
49 OPc_UNOP, /* 2 */
50 OPc_BINOP, /* 3 */
51 OPc_LOGOP, /* 4 */
1a67a97c 52 OPc_LISTOP, /* 5 */
53 OPc_PMOP, /* 6 */
54 OPc_SVOP, /* 7 */
7934575e 55 OPc_PADOP, /* 8 */
1a67a97c 56 OPc_PVOP, /* 9 */
651aa52e 57 OPc_LOOP, /* 10 */
58 OPc_COP /* 11 */
a8a597b2 59} opclass;
60
27da23d5 61static const char* const opclassnames[] = {
a8a597b2 62 "B::NULL",
63 "B::OP",
64 "B::UNOP",
65 "B::BINOP",
66 "B::LOGOP",
a8a597b2 67 "B::LISTOP",
68 "B::PMOP",
69 "B::SVOP",
7934575e 70 "B::PADOP",
a8a597b2 71 "B::PVOP",
a8a597b2 72 "B::LOOP",
73 "B::COP"
74};
75
27da23d5 76static const size_t opsizes[] = {
651aa52e 77 0,
78 sizeof(OP),
79 sizeof(UNOP),
80 sizeof(BINOP),
81 sizeof(LOGOP),
82 sizeof(LISTOP),
83 sizeof(PMOP),
84 sizeof(SVOP),
85 sizeof(PADOP),
86 sizeof(PVOP),
87 sizeof(LOOP),
88 sizeof(COP)
89};
90
df3728a2 91#define MY_CXT_KEY "B::_guts" XS_VERSION
a8a597b2 92
89ca4ac7 93typedef struct {
94 int x_walkoptree_debug; /* Flag for walkoptree debug hook */
b326da91 95 SV * x_specialsv_list[7];
89ca4ac7 96} my_cxt_t;
97
98START_MY_CXT
99
100#define walkoptree_debug (MY_CXT.x_walkoptree_debug)
101#define specialsv_list (MY_CXT.x_specialsv_list)
e8edd1e6 102
a8a597b2 103static opclass
5d7488b2 104cc_opclass(pTHX_ const OP *o)
a8a597b2 105{
106 if (!o)
107 return OPc_NULL;
108
109 if (o->op_type == 0)
110 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
111
112 if (o->op_type == OP_SASSIGN)
113 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
114
c60fdceb 115 if (o->op_type == OP_AELEMFAST) {
116 if (o->op_flags & OPf_SPECIAL)
117 return OPc_BASEOP;
118 else
119#ifdef USE_ITHREADS
120 return OPc_PADOP;
121#else
122 return OPc_SVOP;
123#endif
124 }
125
18228111 126#ifdef USE_ITHREADS
31b49ad4 127 if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
c60fdceb 128 o->op_type == OP_RCATLINE)
18228111 129 return OPc_PADOP;
130#endif
131
22c35a8c 132 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
a8a597b2 133 case OA_BASEOP:
134 return OPc_BASEOP;
135
136 case OA_UNOP:
137 return OPc_UNOP;
138
139 case OA_BINOP:
140 return OPc_BINOP;
141
142 case OA_LOGOP:
143 return OPc_LOGOP;
144
a8a597b2 145 case OA_LISTOP:
146 return OPc_LISTOP;
147
148 case OA_PMOP:
149 return OPc_PMOP;
150
151 case OA_SVOP:
152 return OPc_SVOP;
153
7934575e 154 case OA_PADOP:
155 return OPc_PADOP;
a8a597b2 156
293d3ffa 157 case OA_PVOP_OR_SVOP:
158 /*
159 * Character translations (tr///) are usually a PVOP, keeping a
160 * pointer to a table of shorts used to look up translations.
161 * Under utf8, however, a simple table isn't practical; instead,
162 * the OP is an SVOP, and the SV is a reference to a swash
163 * (i.e., an RV pointing to an HV).
164 */
165 return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
166 ? OPc_SVOP : OPc_PVOP;
a8a597b2 167
168 case OA_LOOP:
169 return OPc_LOOP;
170
171 case OA_COP:
172 return OPc_COP;
173
174 case OA_BASEOP_OR_UNOP:
175 /*
176 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
45f6cd40 177 * whether parens were seen. perly.y uses OPf_SPECIAL to
178 * signal whether a BASEOP had empty parens or none.
179 * Some other UNOPs are created later, though, so the best
180 * test is OPf_KIDS, which is set in newUNOP.
a8a597b2 181 */
45f6cd40 182 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
a8a597b2 183
184 case OA_FILESTATOP:
185 /*
186 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
187 * the OPf_REF flag to distinguish between OP types instead of the
188 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
189 * return OPc_UNOP so that walkoptree can find our children. If
190 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
191 * (no argument to the operator) it's an OP; with OPf_REF set it's
7934575e 192 * an SVOP (and op_sv is the GV for the filehandle argument).
a8a597b2 193 */
194 return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
93865851 195#ifdef USE_ITHREADS
196 (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
197#else
7934575e 198 (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
93865851 199#endif
a8a597b2 200 case OA_LOOPEXOP:
201 /*
202 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
203 * label was omitted (in which case it's a BASEOP) or else a term was
204 * seen. In this last case, all except goto are definitely PVOP but
205 * goto is either a PVOP (with an ordinary constant label), an UNOP
206 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
207 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
208 * get set.
209 */
210 if (o->op_flags & OPf_STACKED)
211 return OPc_UNOP;
212 else if (o->op_flags & OPf_SPECIAL)
213 return OPc_BASEOP;
214 else
215 return OPc_PVOP;
216 }
217 warn("can't determine class of operator %s, assuming BASEOP\n",
22c35a8c 218 PL_op_name[o->op_type]);
a8a597b2 219 return OPc_BASEOP;
220}
221
222static char *
5d7488b2 223cc_opclassname(pTHX_ const OP *o)
a8a597b2 224{
27da23d5 225 return (char *)opclassnames[cc_opclass(aTHX_ o)];
a8a597b2 226}
227
228static SV *
cea2e8a9 229make_sv_object(pTHX_ SV *arg, SV *sv)
a8a597b2 230{
27da23d5 231 const char *type = 0;
a8a597b2 232 IV iv;
89ca4ac7 233 dMY_CXT;
a8a597b2 234
e8edd1e6 235 for (iv = 0; iv < sizeof(specialsv_list)/sizeof(SV*); iv++) {
236 if (sv == specialsv_list[iv]) {
a8a597b2 237 type = "B::SPECIAL";
238 break;
239 }
240 }
241 if (!type) {
242 type = svclassnames[SvTYPE(sv)];
56431972 243 iv = PTR2IV(sv);
a8a597b2 244 }
245 sv_setiv(newSVrv(arg, type), iv);
246 return arg;
247}
248
249static SV *
8e01d9a6 250make_temp_object(pTHX_ SV *arg, SV *temp)
251{
252 SV *target;
253 const char *const type = svclassnames[SvTYPE(temp)];
254 const IV iv = PTR2IV(temp);
255
256 target = newSVrv(arg, type);
257 sv_setiv(target, iv);
258
259 /* Need to keep our "temp" around as long as the target exists.
260 Simplest way seems to be to hang it from magic, and let that clear
261 it up. No vtable, so won't actually get in the way of anything. */
262 sv_magicext(target, temp, PERL_MAGIC_sv, NULL, NULL, 0);
263 /* magic object has had its reference count increased, so we must drop
264 our reference. */
265 SvREFCNT_dec(temp);
266 return arg;
267}
268
269static SV *
5c3c3f81 270make_warnings_object(pTHX_ SV *arg, STRLEN *warnings)
271{
272 const char *type = 0;
273 dMY_CXT;
274 IV iv = sizeof(specialsv_list)/sizeof(SV*);
275
276 /* Counting down is deliberate. Before the split between make_sv_object
277 and make_warnings_obj there appeared to be a bug - Nullsv and pWARN_STD
278 were both 0, so you could never get a B::SPECIAL for pWARN_STD */
279
280 while (iv--) {
281 if ((SV*)warnings == specialsv_list[iv]) {
282 type = "B::SPECIAL";
283 break;
284 }
285 }
286 if (type) {
287 sv_setiv(newSVrv(arg, type), iv);
8e01d9a6 288 return arg;
5c3c3f81 289 } else {
290 /* B assumes that warnings are a regular SV. Seems easier to keep it
291 happy by making them into a regular SV. */
8e01d9a6 292 return make_temp_object(aTHX_ arg,
293 newSVpvn((char *)(warnings + 1), *warnings));
294 }
295}
296
297static SV *
298make_cop_io_object(pTHX_ SV *arg, COP *cop)
299{
300 if (CopHINTS_get(cop) & HINT_LEXICAL_IO) {
301 /* I feel you should be able to simply SvREFCNT_inc the return value
302 from this, but if you do (and restore the line
303 my $ioix = $cop->io->ix;
304 in B::COP::bsave in Bytecode.pm, then you get errors about
305 "attempt to free temp prematurely ... during global destruction.
306 The SV's flags are consistent with the error, but quite how the
307 temp escaped from the save stack is not clear. */
308 SV *value = Perl_refcounted_he_fetch(aTHX_ cop->cop_hints_hash,
309 0, "open", 4, 0, 0);
310 return make_temp_object(aTHX_ arg, newSVsv(value));
311 } else {
312 return make_sv_object(aTHX_ arg, NULL);
5c3c3f81 313 }
5c3c3f81 314}
315
316static SV *
cea2e8a9 317make_mg_object(pTHX_ SV *arg, MAGIC *mg)
a8a597b2 318{
56431972 319 sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg));
a8a597b2 320 return arg;
321}
322
323static SV *
52ad86de 324cstring(pTHX_ SV *sv, bool perlstyle)
a8a597b2 325{
79cb57f6 326 SV *sstr = newSVpvn("", 0);
a8a597b2 327
328 if (!SvOK(sv))
329 sv_setpvn(sstr, "0", 1);
5d7488b2 330 else if (perlstyle && SvUTF8(sv)) {
d79a7a3d 331 SV *tmpsv = sv_newmortal(); /* Temporary SV to feed sv_uni_display */
5d7488b2 332 const STRLEN len = SvCUR(sv);
333 const char *s = sv_uni_display(tmpsv, sv, 8*len, UNI_DISPLAY_QQ);
c69006e4 334 sv_setpvn(sstr,"\"",1);
d79a7a3d 335 while (*s)
336 {
337 if (*s == '"')
5d7488b2 338 sv_catpvn(sstr, "\\\"", 2);
d79a7a3d 339 else if (*s == '$')
5d7488b2 340 sv_catpvn(sstr, "\\$", 2);
d79a7a3d 341 else if (*s == '@')
5d7488b2 342 sv_catpvn(sstr, "\\@", 2);
d79a7a3d 343 else if (*s == '\\')
344 {
345 if (strchr("nrftax\\",*(s+1)))
346 sv_catpvn(sstr, s++, 2);
347 else
5d7488b2 348 sv_catpvn(sstr, "\\\\", 2);
d79a7a3d 349 }
350 else /* should always be printable */
351 sv_catpvn(sstr, s, 1);
352 ++s;
353 }
354 sv_catpv(sstr, "\"");
355 return sstr;
356 }
a8a597b2 357 else
358 {
359 /* XXX Optimise? */
5d7488b2 360 STRLEN len;
361 const char *s = SvPV(sv, len);
a8a597b2 362 sv_catpv(sstr, "\"");
363 for (; len; len--, s++)
364 {
365 /* At least try a little for readability */
366 if (*s == '"')
367 sv_catpv(sstr, "\\\"");
368 else if (*s == '\\')
369 sv_catpv(sstr, "\\\\");
b326da91 370 /* trigraphs - bleagh */
5d7488b2 371 else if (!perlstyle && *s == '?' && len>=3 && s[1] == '?') {
372 char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
b326da91 373 sprintf(escbuff, "\\%03o", '?');
374 sv_catpv(sstr, escbuff);
375 }
52ad86de 376 else if (perlstyle && *s == '$')
377 sv_catpv(sstr, "\\$");
378 else if (perlstyle && *s == '@')
379 sv_catpv(sstr, "\\@");
ce561ef2 380#ifdef EBCDIC
381 else if (isPRINT(*s))
382#else
383 else if (*s >= ' ' && *s < 127)
384#endif /* EBCDIC */
a8a597b2 385 sv_catpvn(sstr, s, 1);
386 else if (*s == '\n')
387 sv_catpv(sstr, "\\n");
388 else if (*s == '\r')
389 sv_catpv(sstr, "\\r");
390 else if (*s == '\t')
391 sv_catpv(sstr, "\\t");
392 else if (*s == '\a')
393 sv_catpv(sstr, "\\a");
394 else if (*s == '\b')
395 sv_catpv(sstr, "\\b");
396 else if (*s == '\f')
397 sv_catpv(sstr, "\\f");
52ad86de 398 else if (!perlstyle && *s == '\v')
a8a597b2 399 sv_catpv(sstr, "\\v");
400 else
401 {
a8a597b2 402 /* Don't want promotion of a signed -1 char in sprintf args */
5d7488b2 403 char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
404 const unsigned char c = (unsigned char) *s;
a8a597b2 405 sprintf(escbuff, "\\%03o", c);
406 sv_catpv(sstr, escbuff);
407 }
408 /* XXX Add line breaks if string is long */
409 }
410 sv_catpv(sstr, "\"");
411 }
412 return sstr;
413}
414
415static SV *
cea2e8a9 416cchar(pTHX_ SV *sv)
a8a597b2 417{
79cb57f6 418 SV *sstr = newSVpvn("'", 1);
5d7488b2 419 const char *s = SvPV_nolen(sv);
a8a597b2 420
421 if (*s == '\'')
5d7488b2 422 sv_catpvn(sstr, "\\'", 2);
a8a597b2 423 else if (*s == '\\')
5d7488b2 424 sv_catpvn(sstr, "\\\\", 2);
ce561ef2 425#ifdef EBCDIC
133b4094 426 else if (isPRINT(*s))
ce561ef2 427#else
428 else if (*s >= ' ' && *s < 127)
429#endif /* EBCDIC */
a8a597b2 430 sv_catpvn(sstr, s, 1);
431 else if (*s == '\n')
5d7488b2 432 sv_catpvn(sstr, "\\n", 2);
a8a597b2 433 else if (*s == '\r')
5d7488b2 434 sv_catpvn(sstr, "\\r", 2);
a8a597b2 435 else if (*s == '\t')
5d7488b2 436 sv_catpvn(sstr, "\\t", 2);
a8a597b2 437 else if (*s == '\a')
5d7488b2 438 sv_catpvn(sstr, "\\a", 2);
a8a597b2 439 else if (*s == '\b')
5d7488b2 440 sv_catpvn(sstr, "\\b", 2);
a8a597b2 441 else if (*s == '\f')
5d7488b2 442 sv_catpvn(sstr, "\\f", 2);
a8a597b2 443 else if (*s == '\v')
5d7488b2 444 sv_catpvn(sstr, "\\v", 2);
a8a597b2 445 else
446 {
447 /* no trigraph support */
448 char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
449 /* Don't want promotion of a signed -1 char in sprintf args */
450 unsigned char c = (unsigned char) *s;
451 sprintf(escbuff, "\\%03o", c);
452 sv_catpv(sstr, escbuff);
453 }
5d7488b2 454 sv_catpvn(sstr, "'", 1);
a8a597b2 455 return sstr;
456}
457
5d7488b2 458static void
459walkoptree(pTHX_ SV *opsv, const char *method)
a8a597b2 460{
461 dSP;
f3be9b72 462 OP *o, *kid;
89ca4ac7 463 dMY_CXT;
464
a8a597b2 465 if (!SvROK(opsv))
466 croak("opsv is not a reference");
467 opsv = sv_mortalcopy(opsv);
56431972 468 o = INT2PTR(OP*,SvIV((SV*)SvRV(opsv)));
a8a597b2 469 if (walkoptree_debug) {
470 PUSHMARK(sp);
471 XPUSHs(opsv);
472 PUTBACK;
473 perl_call_method("walkoptree_debug", G_DISCARD);
474 }
475 PUSHMARK(sp);
476 XPUSHs(opsv);
477 PUTBACK;
478 perl_call_method(method, G_DISCARD);
479 if (o && (o->op_flags & OPf_KIDS)) {
a8a597b2 480 for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) {
481 /* Use the same opsv. Rely on methods not to mess it up. */
56431972 482 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
cea2e8a9 483 walkoptree(aTHX_ opsv, method);
a8a597b2 484 }
485 }
5464c149 486 if (o && (cc_opclass(aTHX_ o) == OPc_PMOP) && o->op_type != OP_PUSHRE
f3be9b72 487 && (kid = cPMOPo->op_pmreplroot))
488 {
5464c149 489 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
f3be9b72 490 walkoptree(aTHX_ opsv, method);
491 }
a8a597b2 492}
493
5d7488b2 494static SV **
1df34986 495oplist(pTHX_ OP *o, SV **SP)
496{
497 for(; o; o = o->op_next) {
498 SV *opsv;
7252851f 499#if PERL_VERSION >= 9
500 if (o->op_opt == 0)
1df34986 501 break;
2814eb74 502 o->op_opt = 0;
7252851f 503#else
504 if (o->op_seq == 0)
505 break;
506 o->op_seq = 0;
507#endif
1df34986 508 opsv = sv_newmortal();
509 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ (OP*)o)), PTR2IV(o));
510 XPUSHs(opsv);
511 switch (o->op_type) {
512 case OP_SUBST:
513 SP = oplist(aTHX_ cPMOPo->op_pmreplstart, SP);
514 continue;
515 case OP_SORT:
f66c782a 516 if (o->op_flags & OPf_STACKED && o->op_flags & OPf_SPECIAL) {
1df34986 517 OP *kid = cLISTOPo->op_first->op_sibling; /* pass pushmark */
518 kid = kUNOP->op_first; /* pass rv2gv */
519 kid = kUNOP->op_first; /* pass leave */
f66c782a 520 SP = oplist(aTHX_ kid->op_next, SP);
1df34986 521 }
522 continue;
523 }
524 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
525 case OA_LOGOP:
526 SP = oplist(aTHX_ cLOGOPo->op_other, SP);
527 break;
528 case OA_LOOP:
529 SP = oplist(aTHX_ cLOOPo->op_lastop, SP);
530 SP = oplist(aTHX_ cLOOPo->op_nextop, SP);
531 SP = oplist(aTHX_ cLOOPo->op_redoop, SP);
532 break;
533 }
534 }
535 return SP;
536}
537
a8a597b2 538typedef OP *B__OP;
539typedef UNOP *B__UNOP;
540typedef BINOP *B__BINOP;
541typedef LOGOP *B__LOGOP;
a8a597b2 542typedef LISTOP *B__LISTOP;
543typedef PMOP *B__PMOP;
544typedef SVOP *B__SVOP;
7934575e 545typedef PADOP *B__PADOP;
a8a597b2 546typedef PVOP *B__PVOP;
547typedef LOOP *B__LOOP;
548typedef COP *B__COP;
549
550typedef SV *B__SV;
551typedef SV *B__IV;
552typedef SV *B__PV;
553typedef SV *B__NV;
554typedef SV *B__PVMG;
555typedef SV *B__PVLV;
556typedef SV *B__BM;
557typedef SV *B__RV;
1df34986 558typedef SV *B__FM;
a8a597b2 559typedef AV *B__AV;
560typedef HV *B__HV;
561typedef CV *B__CV;
562typedef GV *B__GV;
563typedef IO *B__IO;
564
565typedef MAGIC *B__MAGIC;
fd9f6265 566typedef HE *B__HE;
567typedef struct refcounted_he *B__RHE;
a8a597b2 568
569MODULE = B PACKAGE = B PREFIX = B_
570
571PROTOTYPES: DISABLE
572
573BOOT:
4c1f658f 574{
575 HV *stash = gv_stashpvn("B", 1, TRUE);
576 AV *export_ok = perl_get_av("B::EXPORT_OK",TRUE);
89ca4ac7 577 MY_CXT_INIT;
e8edd1e6 578 specialsv_list[0] = Nullsv;
579 specialsv_list[1] = &PL_sv_undef;
580 specialsv_list[2] = &PL_sv_yes;
581 specialsv_list[3] = &PL_sv_no;
5c3c3f81 582 specialsv_list[4] = (SV *) pWARN_ALL;
583 specialsv_list[5] = (SV *) pWARN_NONE;
584 specialsv_list[6] = (SV *) pWARN_STD;
f5ba1307 585#if PERL_VERSION <= 8
7252851f 586# define CVf_ASSERTION 0
587#endif
4c1f658f 588#include "defsubs.h"
589}
a8a597b2 590
3280af22 591#define B_main_cv() PL_main_cv
31d7d75a 592#define B_init_av() PL_initav
651aa52e 593#define B_inc_gv() PL_incgv
ece599bd 594#define B_check_av() PL_checkav_save
676456c2 595#define B_unitcheck_av() PL_unitcheckav_save
059a8bb7 596#define B_begin_av() PL_beginav_save
597#define B_end_av() PL_endav
3280af22 598#define B_main_root() PL_main_root
599#define B_main_start() PL_main_start
56eca212 600#define B_amagic_generation() PL_amagic_generation
5ce57cc0 601#define B_sub_generation() PL_sub_generation
651aa52e 602#define B_defstash() PL_defstash
603#define B_curstash() PL_curstash
604#define B_dowarn() PL_dowarn
3280af22 605#define B_comppadlist() (PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv))
606#define B_sv_undef() &PL_sv_undef
607#define B_sv_yes() &PL_sv_yes
608#define B_sv_no() &PL_sv_no
1df34986 609#define B_formfeed() PL_formfeed
9d2bbe64 610#ifdef USE_ITHREADS
611#define B_regex_padav() PL_regex_padav
612#endif
a8a597b2 613
31d7d75a 614B::AV
615B_init_av()
616
059a8bb7 617B::AV
ece599bd 618B_check_av()
619
620B::AV
676456c2 621B_unitcheck_av()
622
623B::AV
059a8bb7 624B_begin_av()
625
626B::AV
627B_end_av()
628
651aa52e 629B::GV
630B_inc_gv()
631
9d2bbe64 632#ifdef USE_ITHREADS
633
634B::AV
635B_regex_padav()
636
637#endif
638
a8a597b2 639B::CV
640B_main_cv()
641
642B::OP
643B_main_root()
644
645B::OP
646B_main_start()
647
56eca212 648long
649B_amagic_generation()
650
5ce57cc0 651long
652B_sub_generation()
653
a8a597b2 654B::AV
655B_comppadlist()
656
657B::SV
658B_sv_undef()
659
660B::SV
661B_sv_yes()
662
663B::SV
664B_sv_no()
665
651aa52e 666B::HV
667B_curstash()
668
669B::HV
670B_defstash()
a8a597b2 671
651aa52e 672U8
673B_dowarn()
674
1df34986 675B::SV
676B_formfeed()
677
651aa52e 678void
679B_warnhook()
680 CODE:
681 ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_warnhook);
682
683void
684B_diehook()
685 CODE:
686 ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_diehook);
687
688MODULE = B PACKAGE = B
a8a597b2 689
690void
691walkoptree(opsv, method)
692 SV * opsv
5d7488b2 693 const char * method
cea2e8a9 694 CODE:
695 walkoptree(aTHX_ opsv, method);
a8a597b2 696
697int
698walkoptree_debug(...)
699 CODE:
89ca4ac7 700 dMY_CXT;
a8a597b2 701 RETVAL = walkoptree_debug;
702 if (items > 0 && SvTRUE(ST(1)))
703 walkoptree_debug = 1;
704 OUTPUT:
705 RETVAL
706
56431972 707#define address(sv) PTR2IV(sv)
a8a597b2 708
709IV
710address(sv)
711 SV * sv
712
713B::SV
714svref_2object(sv)
715 SV * sv
716 CODE:
717 if (!SvROK(sv))
718 croak("argument is not a reference");
719 RETVAL = (SV*)SvRV(sv);
720 OUTPUT:
0cc1d052 721 RETVAL
722
723void
724opnumber(name)
5d7488b2 725const char * name
0cc1d052 726CODE:
727{
728 int i;
729 IV result = -1;
730 ST(0) = sv_newmortal();
731 if (strncmp(name,"pp_",3) == 0)
732 name += 3;
733 for (i = 0; i < PL_maxo; i++)
734 {
735 if (strcmp(name, PL_op_name[i]) == 0)
736 {
737 result = i;
738 break;
739 }
740 }
741 sv_setiv(ST(0),result);
742}
a8a597b2 743
744void
745ppname(opnum)
746 int opnum
747 CODE:
748 ST(0) = sv_newmortal();
3280af22 749 if (opnum >= 0 && opnum < PL_maxo) {
a8a597b2 750 sv_setpvn(ST(0), "pp_", 3);
22c35a8c 751 sv_catpv(ST(0), PL_op_name[opnum]);
a8a597b2 752 }
753
754void
755hash(sv)
756 SV * sv
757 CODE:
a8a597b2 758 STRLEN len;
759 U32 hash = 0;
faccc32b 760 char hexhash[19]; /* must fit "0xffffffffffffffff" plus trailing \0 */
5d7488b2 761 const char *s = SvPV(sv, len);
c32d3395 762 PERL_HASH(hash, s, len);
faccc32b 763 sprintf(hexhash, "0x%"UVxf, (UV)hash);
a8a597b2 764 ST(0) = sv_2mortal(newSVpv(hexhash, 0));
765
766#define cast_I32(foo) (I32)foo
767IV
768cast_I32(i)
769 IV i
770
771void
772minus_c()
773 CODE:
3280af22 774 PL_minus_c = TRUE;
a8a597b2 775
059a8bb7 776void
777save_BEGINs()
778 CODE:
aefff11f 779 PL_savebegin = TRUE;
059a8bb7 780
a8a597b2 781SV *
782cstring(sv)
783 SV * sv
cea2e8a9 784 CODE:
52ad86de 785 RETVAL = cstring(aTHX_ sv, 0);
786 OUTPUT:
787 RETVAL
788
789SV *
790perlstring(sv)
791 SV * sv
792 CODE:
793 RETVAL = cstring(aTHX_ sv, 1);
cea2e8a9 794 OUTPUT:
795 RETVAL
a8a597b2 796
797SV *
798cchar(sv)
799 SV * sv
cea2e8a9 800 CODE:
801 RETVAL = cchar(aTHX_ sv);
802 OUTPUT:
803 RETVAL
a8a597b2 804
805void
806threadsv_names()
807 PPCODE:
f5ba1307 808#if PERL_VERSION <= 8
809# ifdef USE_5005THREADS
810 int i;
5d7488b2 811 const STRLEN len = strlen(PL_threadsv_names);
f5ba1307 812
813 EXTEND(sp, len);
814 for (i = 0; i < len; i++)
815 PUSHs(sv_2mortal(newSVpvn(&PL_threadsv_names[i], 1)));
816# endif
817#endif
a8a597b2 818
819#define OP_next(o) o->op_next
820#define OP_sibling(o) o->op_sibling
27da23d5 821#define OP_desc(o) (char *)PL_op_desc[o->op_type]
a8a597b2 822#define OP_targ(o) o->op_targ
823#define OP_type(o) o->op_type
7252851f 824#if PERL_VERSION >= 9
825# define OP_opt(o) o->op_opt
826# define OP_static(o) o->op_static
827#else
828# define OP_seq(o) o->op_seq
829#endif
a8a597b2 830#define OP_flags(o) o->op_flags
831#define OP_private(o) o->op_private
a60ba18b 832#define OP_spare(o) o->op_spare
a8a597b2 833
834MODULE = B PACKAGE = B::OP PREFIX = OP_
835
651aa52e 836size_t
837OP_size(o)
838 B::OP o
839 CODE:
840 RETVAL = opsizes[cc_opclass(aTHX_ o)];
841 OUTPUT:
842 RETVAL
843
a8a597b2 844B::OP
845OP_next(o)
846 B::OP o
847
848B::OP
849OP_sibling(o)
850 B::OP o
851
852char *
3f872cb9 853OP_name(o)
854 B::OP o
855 CODE:
27da23d5 856 RETVAL = (char *)PL_op_name[o->op_type];
8063af02 857 OUTPUT:
858 RETVAL
3f872cb9 859
860
8063af02 861void
a8a597b2 862OP_ppaddr(o)
863 B::OP o
dc333d64 864 PREINIT:
865 int i;
866 SV *sv = sv_newmortal();
a8a597b2 867 CODE:
dc333d64 868 sv_setpvn(sv, "PL_ppaddr[OP_", 13);
869 sv_catpv(sv, PL_op_name[o->op_type]);
7c436af3 870 for (i=13; (STRLEN)i < SvCUR(sv); ++i)
dc333d64 871 SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]);
872 sv_catpv(sv, "]");
873 ST(0) = sv;
a8a597b2 874
875char *
876OP_desc(o)
877 B::OP o
878
7934575e 879PADOFFSET
a8a597b2 880OP_targ(o)
881 B::OP o
882
883U16
884OP_type(o)
885 B::OP o
886
7252851f 887#if PERL_VERSION >= 9
888
2814eb74 889U8
890OP_opt(o)
891 B::OP o
892
893U8
894OP_static(o)
a8a597b2 895 B::OP o
896
7252851f 897#else
898
899U16
900OP_seq(o)
901 B::OP o
902
903#endif
904
a8a597b2 905U8
906OP_flags(o)
907 B::OP o
908
909U8
910OP_private(o)
911 B::OP o
912
7252851f 913#if PERL_VERSION >= 9
914
a60ba18b 915U8
916OP_spare(o)
917 B::OP o
918
7252851f 919#endif
920
1df34986 921void
922OP_oplist(o)
923 B::OP o
924 PPCODE:
925 SP = oplist(aTHX_ o, SP);
926
a8a597b2 927#define UNOP_first(o) o->op_first
928
929MODULE = B PACKAGE = B::UNOP PREFIX = UNOP_
930
931B::OP
932UNOP_first(o)
933 B::UNOP o
934
935#define BINOP_last(o) o->op_last
936
937MODULE = B PACKAGE = B::BINOP PREFIX = BINOP_
938
939B::OP
940BINOP_last(o)
941 B::BINOP o
942
943#define LOGOP_other(o) o->op_other
944
945MODULE = B PACKAGE = B::LOGOP PREFIX = LOGOP_
946
947B::OP
948LOGOP_other(o)
949 B::LOGOP o
950
a8a597b2 951MODULE = B PACKAGE = B::LISTOP PREFIX = LISTOP_
952
c03c2844 953U32
954LISTOP_children(o)
955 B::LISTOP o
956 OP * kid = NO_INIT
957 int i = NO_INIT
958 CODE:
c03c2844 959 i = 0;
960 for (kid = o->op_first; kid; kid = kid->op_sibling)
961 i++;
8063af02 962 RETVAL = i;
963 OUTPUT:
964 RETVAL
c03c2844 965
a8a597b2 966#define PMOP_pmreplroot(o) o->op_pmreplroot
967#define PMOP_pmreplstart(o) o->op_pmreplstart
968#define PMOP_pmnext(o) o->op_pmnext
aaa362c4 969#define PMOP_pmregexp(o) PM_GETRE(o)
9d2bbe64 970#ifdef USE_ITHREADS
971#define PMOP_pmoffset(o) o->op_pmoffset
651aa52e 972#define PMOP_pmstashpv(o) o->op_pmstashpv
973#else
974#define PMOP_pmstash(o) o->op_pmstash
9d2bbe64 975#endif
a8a597b2 976#define PMOP_pmflags(o) o->op_pmflags
977#define PMOP_pmpermflags(o) o->op_pmpermflags
9d2bbe64 978#define PMOP_pmdynflags(o) o->op_pmdynflags
a8a597b2 979
980MODULE = B PACKAGE = B::PMOP PREFIX = PMOP_
981
982void
983PMOP_pmreplroot(o)
984 B::PMOP o
985 OP * root = NO_INIT
986 CODE:
987 ST(0) = sv_newmortal();
988 root = o->op_pmreplroot;
989 /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */
990 if (o->op_type == OP_PUSHRE) {
9d2bbe64 991#ifdef USE_ITHREADS
992 sv_setiv(ST(0), INT2PTR(PADOFFSET,root) );
993#else
a8a597b2 994 sv_setiv(newSVrv(ST(0), root ?
995 svclassnames[SvTYPE((SV*)root)] : "B::SV"),
56431972 996 PTR2IV(root));
9d2bbe64 997#endif
a8a597b2 998 }
999 else {
56431972 1000 sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root));
a8a597b2 1001 }
1002
1003B::OP
1004PMOP_pmreplstart(o)
1005 B::PMOP o
1006
1007B::PMOP
1008PMOP_pmnext(o)
1009 B::PMOP o
1010
9d2bbe64 1011#ifdef USE_ITHREADS
1012
1013IV
1014PMOP_pmoffset(o)
1015 B::PMOP o
1016
651aa52e 1017char*
1018PMOP_pmstashpv(o)
1019 B::PMOP o
1020
1021#else
1022
1023B::HV
1024PMOP_pmstash(o)
1025 B::PMOP o
1026
9d2bbe64 1027#endif
1028
6e21dc91 1029U32
a8a597b2 1030PMOP_pmflags(o)
1031 B::PMOP o
1032
6e21dc91 1033U32
a8a597b2 1034PMOP_pmpermflags(o)
1035 B::PMOP o
1036
9d2bbe64 1037U8
1038PMOP_pmdynflags(o)
1039 B::PMOP o
1040
a8a597b2 1041void
1042PMOP_precomp(o)
1043 B::PMOP o
1044 REGEXP * rx = NO_INIT
1045 CODE:
1046 ST(0) = sv_newmortal();
aaa362c4 1047 rx = PM_GETRE(o);
a8a597b2 1048 if (rx)
1049 sv_setpvn(ST(0), rx->precomp, rx->prelen);
1050
ac33dcd1 1051#define SVOP_sv(o) cSVOPo->op_sv
1052#define SVOP_gv(o) ((GV*)cSVOPo->op_sv)
a8a597b2 1053
1054MODULE = B PACKAGE = B::SVOP PREFIX = SVOP_
1055
a8a597b2 1056B::SV
1057SVOP_sv(o)
1058 B::SVOP o
1059
f22444f5 1060B::GV
065a1863 1061SVOP_gv(o)
1062 B::SVOP o
1063
7934575e 1064#define PADOP_padix(o) o->op_padix
dd2155a4 1065#define PADOP_sv(o) (o->op_padix ? PAD_SVl(o->op_padix) : Nullsv)
7934575e 1066#define PADOP_gv(o) ((o->op_padix \
dd2155a4 1067 && SvTYPE(PAD_SVl(o->op_padix)) == SVt_PVGV) \
1068 ? (GV*)PAD_SVl(o->op_padix) : Nullgv)
a8a597b2 1069
7934575e 1070MODULE = B PACKAGE = B::PADOP PREFIX = PADOP_
1071
1072PADOFFSET
1073PADOP_padix(o)
1074 B::PADOP o
1075
1076B::SV
1077PADOP_sv(o)
1078 B::PADOP o
a8a597b2 1079
1080B::GV
7934575e 1081PADOP_gv(o)
1082 B::PADOP o
a8a597b2 1083
1084MODULE = B PACKAGE = B::PVOP PREFIX = PVOP_
1085
1086void
1087PVOP_pv(o)
1088 B::PVOP o
1089 CODE:
1090 /*
bec89253 1091 * OP_TRANS uses op_pv to point to a table of 256 or >=258 shorts
a8a597b2 1092 * whereas other PVOPs point to a null terminated string.
1093 */
bec89253 1094 if (o->op_type == OP_TRANS &&
1095 (o->op_private & OPpTRANS_COMPLEMENT) &&
1096 !(o->op_private & OPpTRANS_DELETE))
1097 {
5d7488b2 1098 const short* const tbl = (short*)o->op_pv;
1099 const short entries = 257 + tbl[256];
bec89253 1100 ST(0) = sv_2mortal(newSVpv(o->op_pv, entries * sizeof(short)));
1101 }
1102 else if (o->op_type == OP_TRANS) {
1103 ST(0) = sv_2mortal(newSVpv(o->op_pv, 256 * sizeof(short)));
1104 }
1105 else
1106 ST(0) = sv_2mortal(newSVpv(o->op_pv, 0));
a8a597b2 1107
1108#define LOOP_redoop(o) o->op_redoop
1109#define LOOP_nextop(o) o->op_nextop
1110#define LOOP_lastop(o) o->op_lastop
1111
1112MODULE = B PACKAGE = B::LOOP PREFIX = LOOP_
1113
1114
1115B::OP
1116LOOP_redoop(o)
1117 B::LOOP o
1118
1119B::OP
1120LOOP_nextop(o)
1121 B::LOOP o
1122
1123B::OP
1124LOOP_lastop(o)
1125 B::LOOP o
1126
1127#define COP_label(o) o->cop_label
11faa288 1128#define COP_stashpv(o) CopSTASHPV(o)
1129#define COP_stash(o) CopSTASH(o)
57843af0 1130#define COP_file(o) CopFILE(o)
1df34986 1131#define COP_filegv(o) CopFILEGV(o)
a8a597b2 1132#define COP_cop_seq(o) o->cop_seq
fc15ae8f 1133#define COP_arybase(o) CopARYBASE_get(o)
57843af0 1134#define COP_line(o) CopLINE(o)
d5ec2987 1135#define COP_hints(o) CopHINTS_get(o)
a8a597b2 1136
1137MODULE = B PACKAGE = B::COP PREFIX = COP_
1138
1139char *
1140COP_label(o)
1141 B::COP o
1142
11faa288 1143char *
1144COP_stashpv(o)
1145 B::COP o
1146
a8a597b2 1147B::HV
1148COP_stash(o)
1149 B::COP o
1150
57843af0 1151char *
1152COP_file(o)
a8a597b2 1153 B::COP o
1154
1df34986 1155B::GV
1156COP_filegv(o)
1157 B::COP o
1158
1159
a8a597b2 1160U32
1161COP_cop_seq(o)
1162 B::COP o
1163
1164I32
1165COP_arybase(o)
1166 B::COP o
1167
8bafa735 1168U32
a8a597b2 1169COP_line(o)
1170 B::COP o
1171
5c3c3f81 1172void
b295d113 1173COP_warnings(o)
1174 B::COP o
5c3c3f81 1175 PPCODE:
1176 ST(0) = make_warnings_object(aTHX_ sv_newmortal(), o->cop_warnings);
1177 XSRETURN(1);
b295d113 1178
670f1322 1179void
6e6a1aef 1180COP_io(o)
1181 B::COP o
11bcd5da 1182 PPCODE:
8e01d9a6 1183 ST(0) = make_cop_io_object(aTHX_ sv_newmortal(), o);
11bcd5da 1184 XSRETURN(1);
6e6a1aef 1185
d5ec2987 1186U32
1187COP_hints(o)
1188 B::COP o
1189
fd9f6265 1190B::RHE
1191COP_hints_hash(o)
1192 B::COP o
1193 CODE:
1194 RETVAL = o->cop_hints_hash;
1195 OUTPUT:
1196 RETVAL
1197
651aa52e 1198MODULE = B PACKAGE = B::SV
1199
1200U32
1201SvTYPE(sv)
1202 B::SV sv
1203
429a5ce7 1204#define object_2svref(sv) sv
1205#define SVREF SV *
1206
1207SVREF
1208object_2svref(sv)
1209 B::SV sv
1210
a8a597b2 1211MODULE = B PACKAGE = B::SV PREFIX = Sv
1212
1213U32
1214SvREFCNT(sv)
1215 B::SV sv
1216
1217U32
1218SvFLAGS(sv)
1219 B::SV sv
1220
651aa52e 1221U32
1222SvPOK(sv)
1223 B::SV sv
1224
1225U32
1226SvROK(sv)
1227 B::SV sv
1228
1229U32
1230SvMAGICAL(sv)
1231 B::SV sv
1232
a8a597b2 1233MODULE = B PACKAGE = B::IV PREFIX = Sv
1234
1235IV
1236SvIV(sv)
1237 B::IV sv
1238
1239IV
1240SvIVX(sv)
1241 B::IV sv
1242
0ca04487 1243UV
1244SvUVX(sv)
1245 B::IV sv
1246
1247
a8a597b2 1248MODULE = B PACKAGE = B::IV
1249
1250#define needs64bits(sv) ((I32)SvIVX(sv) != SvIVX(sv))
1251
1252int
1253needs64bits(sv)
1254 B::IV sv
1255
1256void
1257packiv(sv)
1258 B::IV sv
1259 CODE:
1260 if (sizeof(IV) == 8) {
1261 U32 wp[2];
5d7488b2 1262 const IV iv = SvIVX(sv);
a8a597b2 1263 /*
1264 * The following way of spelling 32 is to stop compilers on
1265 * 32-bit architectures from moaning about the shift count
1266 * being >= the width of the type. Such architectures don't
1267 * reach this code anyway (unless sizeof(IV) > 8 but then
1268 * everything else breaks too so I'm not fussed at the moment).
1269 */
42718184 1270#ifdef UV_IS_QUAD
1271 wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1272#else
1273 wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1274#endif
a8a597b2 1275 wp[1] = htonl(iv & 0xffffffff);
79cb57f6 1276 ST(0) = sv_2mortal(newSVpvn((char *)wp, 8));
a8a597b2 1277 } else {
1278 U32 w = htonl((U32)SvIVX(sv));
79cb57f6 1279 ST(0) = sv_2mortal(newSVpvn((char *)&w, 4));
a8a597b2 1280 }
1281
1282MODULE = B PACKAGE = B::NV PREFIX = Sv
1283
76ef7183 1284NV
a8a597b2 1285SvNV(sv)
1286 B::NV sv
1287
76ef7183 1288NV
a8a597b2 1289SvNVX(sv)
1290 B::NV sv
1291
1292MODULE = B PACKAGE = B::RV PREFIX = Sv
1293
1294B::SV
1295SvRV(sv)
1296 B::RV sv
1297
1298MODULE = B PACKAGE = B::PV PREFIX = Sv
1299
0b40bd6d 1300char*
1301SvPVX(sv)
1302 B::PV sv
1303
b326da91 1304B::SV
1305SvRV(sv)
1306 B::PV sv
1307 CODE:
1308 if( SvROK(sv) ) {
1309 RETVAL = SvRV(sv);
1310 }
1311 else {
1312 croak( "argument is not SvROK" );
1313 }
1314 OUTPUT:
1315 RETVAL
1316
a8a597b2 1317void
1318SvPV(sv)
1319 B::PV sv
1320 CODE:
b326da91 1321 ST(0) = sv_newmortal();
c0b20461 1322 if( SvPOK(sv) ) {
b55685ae 1323 /* FIXME - we need a better way for B to identify PVs that are
1324 in the pads as variable names. */
1325 if((SvLEN(sv) && SvCUR(sv) >= SvLEN(sv))) {
1326 /* It claims to be longer than the space allocated for it -
1327 presuambly it's a variable name in the pad */
1328 sv_setpv(ST(0), SvPV_nolen_const(sv));
1329 } else {
1330 sv_setpvn(ST(0), SvPVX_const(sv), SvCUR(sv));
1331 }
b326da91 1332 SvFLAGS(ST(0)) |= SvUTF8(sv);
1333 }
1334 else {
1335 /* XXX for backward compatibility, but should fail */
1336 /* croak( "argument is not SvPOK" ); */
1337 sv_setpvn(ST(0), NULL, 0);
1338 }
a8a597b2 1339
651aa52e 1340void
1341SvPVBM(sv)
1342 B::PV sv
1343 CODE:
1344 ST(0) = sv_newmortal();
aa07b2f6 1345 sv_setpvn(ST(0), SvPVX_const(sv),
651aa52e 1346 SvCUR(sv) + (SvTYPE(sv) == SVt_PVBM ? 257 : 0));
1347
1348
445a12f6 1349STRLEN
1350SvLEN(sv)
1351 B::PV sv
1352
1353STRLEN
1354SvCUR(sv)
1355 B::PV sv
1356
a8a597b2 1357MODULE = B PACKAGE = B::PVMG PREFIX = Sv
1358
1359void
1360SvMAGIC(sv)
1361 B::PVMG sv
1362 MAGIC * mg = NO_INIT
1363 PPCODE:
1364 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
cea2e8a9 1365 XPUSHs(make_mg_object(aTHX_ sv_newmortal(), mg));
a8a597b2 1366
1367MODULE = B PACKAGE = B::PVMG
1368
1369B::HV
1370SvSTASH(sv)
1371 B::PVMG sv
1372
1373#define MgMOREMAGIC(mg) mg->mg_moremagic
1374#define MgPRIVATE(mg) mg->mg_private
1375#define MgTYPE(mg) mg->mg_type
1376#define MgFLAGS(mg) mg->mg_flags
1377#define MgOBJ(mg) mg->mg_obj
88b39979 1378#define MgLENGTH(mg) mg->mg_len
bde7177d 1379#define MgREGEX(mg) PTR2IV(mg->mg_obj)
a8a597b2 1380
1381MODULE = B PACKAGE = B::MAGIC PREFIX = Mg
1382
1383B::MAGIC
1384MgMOREMAGIC(mg)
1385 B::MAGIC mg
c5f0f3aa 1386 CODE:
1387 if( MgMOREMAGIC(mg) ) {
1388 RETVAL = MgMOREMAGIC(mg);
1389 }
1390 else {
1391 XSRETURN_UNDEF;
1392 }
1393 OUTPUT:
1394 RETVAL
a8a597b2 1395
1396U16
1397MgPRIVATE(mg)
1398 B::MAGIC mg
1399
1400char
1401MgTYPE(mg)
1402 B::MAGIC mg
1403
1404U8
1405MgFLAGS(mg)
1406 B::MAGIC mg
1407
1408B::SV
1409MgOBJ(mg)
1410 B::MAGIC mg
b326da91 1411
9d2bbe64 1412IV
1413MgREGEX(mg)
1414 B::MAGIC mg
1415 CODE:
a8248b05 1416 if(mg->mg_type == PERL_MAGIC_qr) {
9d2bbe64 1417 RETVAL = MgREGEX(mg);
1418 }
1419 else {
1420 croak( "REGEX is only meaningful on r-magic" );
1421 }
1422 OUTPUT:
1423 RETVAL
1424
b326da91 1425SV*
1426precomp(mg)
1427 B::MAGIC mg
1428 CODE:
a8248b05 1429 if (mg->mg_type == PERL_MAGIC_qr) {
b326da91 1430 REGEXP* rx = (REGEXP*)mg->mg_obj;
ef35129c 1431 RETVAL = Nullsv;
b326da91 1432 if( rx )
1433 RETVAL = newSVpvn( rx->precomp, rx->prelen );
1434 }
1435 else {
1436 croak( "precomp is only meaningful on r-magic" );
1437 }
1438 OUTPUT:
1439 RETVAL
a8a597b2 1440
88b39979 1441I32
1442MgLENGTH(mg)
1443 B::MAGIC mg
1444
a8a597b2 1445void
1446MgPTR(mg)
1447 B::MAGIC mg
1448 CODE:
1449 ST(0) = sv_newmortal();
88b39979 1450 if (mg->mg_ptr){
1451 if (mg->mg_len >= 0){
1452 sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len);
651aa52e 1453 } else if (mg->mg_len == HEf_SVKEY) {
1454 ST(0) = make_sv_object(aTHX_
1455 sv_newmortal(), (SV*)mg->mg_ptr);
88b39979 1456 }
1457 }
a8a597b2 1458
1459MODULE = B PACKAGE = B::PVLV PREFIX = Lv
1460
1461U32
1462LvTARGOFF(sv)
1463 B::PVLV sv
1464
1465U32
1466LvTARGLEN(sv)
1467 B::PVLV sv
1468
1469char
1470LvTYPE(sv)
1471 B::PVLV sv
1472
1473B::SV
1474LvTARG(sv)
1475 B::PVLV sv
1476
1477MODULE = B PACKAGE = B::BM PREFIX = Bm
1478
1479I32
1480BmUSEFUL(sv)
1481 B::BM sv
1482
1483U16
1484BmPREVIOUS(sv)
1485 B::BM sv
1486
1487U8
1488BmRARE(sv)
1489 B::BM sv
1490
1491void
1492BmTABLE(sv)
1493 B::BM sv
1494 STRLEN len = NO_INIT
1495 char * str = NO_INIT
1496 CODE:
1497 str = SvPV(sv, len);
1498 /* Boyer-Moore table is just after string and its safety-margin \0 */
79cb57f6 1499 ST(0) = sv_2mortal(newSVpvn(str + len + 1, 256));
a8a597b2 1500
1501MODULE = B PACKAGE = B::GV PREFIX = Gv
1502
1503void
1504GvNAME(gv)
1505 B::GV gv
1506 CODE:
79cb57f6 1507 ST(0) = sv_2mortal(newSVpvn(GvNAME(gv), GvNAMELEN(gv)));
a8a597b2 1508
87d7fd28 1509bool
1510is_empty(gv)
1511 B::GV gv
1512 CODE:
1513 RETVAL = GvGP(gv) == Null(GP*);
1514 OUTPUT:
1515 RETVAL
1516
651aa52e 1517void*
1518GvGP(gv)
1519 B::GV gv
1520
a8a597b2 1521B::HV
1522GvSTASH(gv)
1523 B::GV gv
1524
1525B::SV
1526GvSV(gv)
1527 B::GV gv
1528
1529B::IO
1530GvIO(gv)
1531 B::GV gv
1532
1df34986 1533B::FM
a8a597b2 1534GvFORM(gv)
1535 B::GV gv
1df34986 1536 CODE:
1537 RETVAL = (SV*)GvFORM(gv);
1538 OUTPUT:
1539 RETVAL
a8a597b2 1540
1541B::AV
1542GvAV(gv)
1543 B::GV gv
1544
1545B::HV
1546GvHV(gv)
1547 B::GV gv
1548
1549B::GV
1550GvEGV(gv)
1551 B::GV gv
1552
1553B::CV
1554GvCV(gv)
1555 B::GV gv
1556
1557U32
1558GvCVGEN(gv)
1559 B::GV gv
1560
8bafa735 1561U32
a8a597b2 1562GvLINE(gv)
1563 B::GV gv
1564
b195d487 1565char *
1566GvFILE(gv)
1567 B::GV gv
1568
a8a597b2 1569B::GV
1570GvFILEGV(gv)
1571 B::GV gv
1572
1573MODULE = B PACKAGE = B::GV
1574
1575U32
1576GvREFCNT(gv)
1577 B::GV gv
1578
1579U8
1580GvFLAGS(gv)
1581 B::GV gv
1582
1583MODULE = B PACKAGE = B::IO PREFIX = Io
1584
1585long
1586IoLINES(io)
1587 B::IO io
1588
1589long
1590IoPAGE(io)
1591 B::IO io
1592
1593long
1594IoPAGE_LEN(io)
1595 B::IO io
1596
1597long
1598IoLINES_LEFT(io)
1599 B::IO io
1600
1601char *
1602IoTOP_NAME(io)
1603 B::IO io
1604
1605B::GV
1606IoTOP_GV(io)
1607 B::IO io
1608
1609char *
1610IoFMT_NAME(io)
1611 B::IO io
1612
1613B::GV
1614IoFMT_GV(io)
1615 B::IO io
1616
1617char *
1618IoBOTTOM_NAME(io)
1619 B::IO io
1620
1621B::GV
1622IoBOTTOM_GV(io)
1623 B::IO io
1624
1625short
1626IoSUBPROCESS(io)
1627 B::IO io
1628
b326da91 1629bool
1630IsSTD(io,name)
1631 B::IO io
5d7488b2 1632 const char* name
b326da91 1633 PREINIT:
1634 PerlIO* handle = 0;
1635 CODE:
1636 if( strEQ( name, "stdin" ) ) {
1637 handle = PerlIO_stdin();
1638 }
1639 else if( strEQ( name, "stdout" ) ) {
1640 handle = PerlIO_stdout();
1641 }
1642 else if( strEQ( name, "stderr" ) ) {
1643 handle = PerlIO_stderr();
1644 }
1645 else {
1646 croak( "Invalid value '%s'", name );
1647 }
1648 RETVAL = handle == IoIFP(io);
1649 OUTPUT:
1650 RETVAL
1651
a8a597b2 1652MODULE = B PACKAGE = B::IO
1653
1654char
1655IoTYPE(io)
1656 B::IO io
1657
1658U8
1659IoFLAGS(io)
1660 B::IO io
1661
1662MODULE = B PACKAGE = B::AV PREFIX = Av
1663
1664SSize_t
1665AvFILL(av)
1666 B::AV av
1667
1668SSize_t
1669AvMAX(av)
1670 B::AV av
1671
edcc7c74 1672#if PERL_VERSION < 9
1673
1674
1675#define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1676
1677IV
1678AvOFF(av)
1679 B::AV av
1680
1681#endif
1682
a8a597b2 1683void
1684AvARRAY(av)
1685 B::AV av
1686 PPCODE:
1687 if (AvFILL(av) >= 0) {
1688 SV **svp = AvARRAY(av);
1689 I32 i;
1690 for (i = 0; i <= AvFILL(av); i++)
cea2e8a9 1691 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), svp[i]));
a8a597b2 1692 }
1693
429a5ce7 1694void
1695AvARRAYelt(av, idx)
1696 B::AV av
1697 int idx
1698 PPCODE:
1699 if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
1700 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), (AvARRAY(av)[idx])));
1701 else
1702 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), NULL));
1703
edcc7c74 1704#if PERL_VERSION < 9
1705
1706MODULE = B PACKAGE = B::AV
1707
1708U8
1709AvFLAGS(av)
1710 B::AV av
1711
1712#endif
1713
1df34986 1714MODULE = B PACKAGE = B::FM PREFIX = Fm
1715
1716IV
1717FmLINES(form)
1718 B::FM form
1719
a8a597b2 1720MODULE = B PACKAGE = B::CV PREFIX = Cv
1721
651aa52e 1722U32
1723CvCONST(cv)
1724 B::CV cv
1725
a8a597b2 1726B::HV
1727CvSTASH(cv)
1728 B::CV cv
1729
1730B::OP
1731CvSTART(cv)
1732 B::CV cv
bf53b3a5 1733 CODE:
1734 RETVAL = CvISXSUB(cv) ? NULL : CvSTART(cv);
1735 OUTPUT:
1736 RETVAL
a8a597b2 1737
1738B::OP
1739CvROOT(cv)
1740 B::CV cv
d04ba589 1741 CODE:
1742 RETVAL = CvISXSUB(cv) ? NULL : CvROOT(cv);
1743 OUTPUT:
1744 RETVAL
a8a597b2 1745
1746B::GV
1747CvGV(cv)
1748 B::CV cv
1749
57843af0 1750char *
1751CvFILE(cv)
1752 B::CV cv
1753
a8a597b2 1754long
1755CvDEPTH(cv)
1756 B::CV cv
1757
1758B::AV
1759CvPADLIST(cv)
1760 B::CV cv
1761
1762B::CV
1763CvOUTSIDE(cv)
1764 B::CV cv
1765
a3985cdc 1766U32
1767CvOUTSIDE_SEQ(cv)
1768 B::CV cv
1769
a8a597b2 1770void
1771CvXSUB(cv)
1772 B::CV cv
1773 CODE:
d04ba589 1774 ST(0) = sv_2mortal(newSViv(CvISXSUB(cv) ? PTR2IV(CvXSUB(cv)) : 0));
a8a597b2 1775
1776
1777void
1778CvXSUBANY(cv)
1779 B::CV cv
1780 CODE:
b326da91 1781 ST(0) = CvCONST(cv) ?
07409e01 1782 make_sv_object(aTHX_ sv_newmortal(),(SV *)CvXSUBANY(cv).any_ptr) :
bf53b3a5 1783 sv_2mortal(newSViv(CvISXSUB(cv) ? CvXSUBANY(cv).any_iv : 0));
a8a597b2 1784
5cfd8ad4 1785MODULE = B PACKAGE = B::CV
1786
6aaf4108 1787U16
5cfd8ad4 1788CvFLAGS(cv)
1789 B::CV cv
1790
de3f1649 1791MODULE = B PACKAGE = B::CV PREFIX = cv_
1792
1793B::SV
1794cv_const_sv(cv)
1795 B::CV cv
1796
5cfd8ad4 1797
a8a597b2 1798MODULE = B PACKAGE = B::HV PREFIX = Hv
1799
1800STRLEN
1801HvFILL(hv)
1802 B::HV hv
1803
1804STRLEN
1805HvMAX(hv)
1806 B::HV hv
1807
1808I32
1809HvKEYS(hv)
1810 B::HV hv
1811
1812I32
1813HvRITER(hv)
1814 B::HV hv
1815
1816char *
1817HvNAME(hv)
1818 B::HV hv
1819
edcc7c74 1820#if PERL_VERSION < 9
1821
1822B::PMOP
1823HvPMROOT(hv)
1824 B::HV hv
1825
1826#endif
1827
a8a597b2 1828void
1829HvARRAY(hv)
1830 B::HV hv
1831 PPCODE:
1832 if (HvKEYS(hv) > 0) {
1833 SV *sv;
1834 char *key;
1835 I32 len;
1836 (void)hv_iterinit(hv);
1837 EXTEND(sp, HvKEYS(hv) * 2);
8063af02 1838 while ((sv = hv_iternextsv(hv, &key, &len))) {
79cb57f6 1839 PUSHs(newSVpvn(key, len));
cea2e8a9 1840 PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv));
a8a597b2 1841 }
1842 }
fd9f6265 1843
1844MODULE = B PACKAGE = B::HE PREFIX = He
1845
1846B::SV
1847HeVAL(he)
1848 B::HE he
1849
1850U32
1851HeHASH(he)
1852 B::HE he
1853
1854B::SV
1855HeSVKEY_force(he)
1856 B::HE he
1857
1858MODULE = B PACKAGE = B::RHE PREFIX = RHE_
1859
1860SV*
1861RHE_HASH(h)
1862 B::RHE h
1863 CODE:
38d45822 1864 RETVAL = newRV( (SV*)Perl_refcounted_he_chain_2hv(aTHX_ h) );
fd9f6265 1865 OUTPUT:
1866 RETVAL
Unnamed repository; edit this file to name it for gitweb.