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