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