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