This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
b503611c64a877f87b401a3ba88babaccc51c4f0
[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     bool custom = 0;
117
118     if (!o)
119         return OPc_NULL;
120
121     if (o->op_type == 0)
122         return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
123
124     if (o->op_type == OP_SASSIGN)
125         return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
126
127     if (o->op_type == OP_AELEMFAST) {
128 #if PERL_VERSION <= 14
129         if (o->op_flags & OPf_SPECIAL)
130             return OPc_BASEOP;
131         else
132 #endif
133 #ifdef USE_ITHREADS
134             return OPc_PADOP;
135 #else
136             return OPc_SVOP;
137 #endif
138     }
139     
140 #ifdef USE_ITHREADS
141     if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
142         o->op_type == OP_RCATLINE)
143         return OPc_PADOP;
144 #endif
145
146     if (o->op_type == OP_CUSTOM)
147         custom = 1;
148
149     switch (OP_CLASS(o)) {
150     case OA_BASEOP:
151         return OPc_BASEOP;
152
153     case OA_UNOP:
154         return OPc_UNOP;
155
156     case OA_BINOP:
157         return OPc_BINOP;
158
159     case OA_LOGOP:
160         return OPc_LOGOP;
161
162     case OA_LISTOP:
163         return OPc_LISTOP;
164
165     case OA_PMOP:
166         return OPc_PMOP;
167
168     case OA_SVOP:
169         return OPc_SVOP;
170
171     case OA_PADOP:
172         return OPc_PADOP;
173
174     case OA_PVOP_OR_SVOP:
175         /*
176          * Character translations (tr///) are usually a PVOP, keeping a 
177          * pointer to a table of shorts used to look up translations.
178          * Under utf8, however, a simple table isn't practical; instead,
179          * the OP is an SVOP (or, under threads, a PADOP),
180          * and the SV is a reference to a swash
181          * (i.e., an RV pointing to an HV).
182          */
183         return (!custom &&
184                    (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
185                )
186 #if  defined(USE_ITHREADS) \
187   && (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION >= 9))
188                 ? OPc_PADOP : OPc_PVOP;
189 #else
190                 ? OPc_SVOP : OPc_PVOP;
191 #endif
192
193     case OA_LOOP:
194         return OPc_LOOP;
195
196     case OA_COP:
197         return OPc_COP;
198
199     case OA_BASEOP_OR_UNOP:
200         /*
201          * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
202          * whether parens were seen. perly.y uses OPf_SPECIAL to
203          * signal whether a BASEOP had empty parens or none.
204          * Some other UNOPs are created later, though, so the best
205          * test is OPf_KIDS, which is set in newUNOP.
206          */
207         return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
208
209     case OA_FILESTATOP:
210         /*
211          * The file stat OPs are created via UNI(OP_foo) in toke.c but use
212          * the OPf_REF flag to distinguish between OP types instead of the
213          * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
214          * return OPc_UNOP so that walkoptree can find our children. If
215          * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
216          * (no argument to the operator) it's an OP; with OPf_REF set it's
217          * an SVOP (and op_sv is the GV for the filehandle argument).
218          */
219         return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
220 #ifdef USE_ITHREADS
221                 (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
222 #else
223                 (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
224 #endif
225     case OA_LOOPEXOP:
226         /*
227          * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
228          * label was omitted (in which case it's a BASEOP) or else a term was
229          * seen. In this last case, all except goto are definitely PVOP but
230          * goto is either a PVOP (with an ordinary constant label), an UNOP
231          * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
232          * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
233          * get set.
234          */
235         if (o->op_flags & OPf_STACKED)
236             return OPc_UNOP;
237         else if (o->op_flags & OPf_SPECIAL)
238             return OPc_BASEOP;
239         else
240             return OPc_PVOP;
241     }
242     warn("can't determine class of operator %s, assuming BASEOP\n",
243          OP_NAME(o));
244     return OPc_BASEOP;
245 }
246
247 static SV *
248 make_op_object(pTHX_ const OP *o)
249 {
250     SV *opsv = sv_newmortal();
251     sv_setiv(newSVrv(opsv, opclassnames[cc_opclass(aTHX_ o)]), PTR2IV(o));
252     return opsv;
253 }
254
255 static SV *
256 make_sv_object(pTHX_ SV *sv)
257 {
258     SV *const arg = sv_newmortal();
259     const char *type = 0;
260     IV iv;
261     dMY_CXT;
262
263     for (iv = 0; iv < (IV)(sizeof(specialsv_list)/sizeof(SV*)); iv++) {
264         if (sv == specialsv_list[iv]) {
265             type = "B::SPECIAL";
266             break;
267         }
268     }
269     if (!type) {
270         type = svclassnames[SvTYPE(sv)];
271         iv = PTR2IV(sv);
272     }
273     sv_setiv(newSVrv(arg, type), iv);
274     return arg;
275 }
276
277 #if PERL_VERSION >= 9
278 static SV *
279 make_temp_object(pTHX_ SV *temp)
280 {
281     SV *target;
282     SV *arg = sv_newmortal();
283     const char *const type = svclassnames[SvTYPE(temp)];
284     const IV iv = PTR2IV(temp);
285
286     target = newSVrv(arg, type);
287     sv_setiv(target, iv);
288
289     /* Need to keep our "temp" around as long as the target exists.
290        Simplest way seems to be to hang it from magic, and let that clear
291        it up.  No vtable, so won't actually get in the way of anything.  */
292     sv_magicext(target, temp, PERL_MAGIC_sv, NULL, NULL, 0);
293     /* magic object has had its reference count increased, so we must drop
294        our reference.  */
295     SvREFCNT_dec(temp);
296     return arg;
297 }
298
299 static SV *
300 make_warnings_object(pTHX_ const COP *const cop)
301 {
302     const STRLEN *const warnings = cop->cop_warnings;
303     const char *type = 0;
304     dMY_CXT;
305     IV iv = sizeof(specialsv_list)/sizeof(SV*);
306
307     /* Counting down is deliberate. Before the split between make_sv_object
308        and make_warnings_obj there appeared to be a bug - Nullsv and pWARN_STD
309        were both 0, so you could never get a B::SPECIAL for pWARN_STD  */
310
311     while (iv--) {
312         if ((SV*)warnings == specialsv_list[iv]) {
313             type = "B::SPECIAL";
314             break;
315         }
316     }
317     if (type) {
318         SV *arg = sv_newmortal();
319         sv_setiv(newSVrv(arg, type), iv);
320         return arg;
321     } else {
322         /* B assumes that warnings are a regular SV. Seems easier to keep it
323            happy by making them into a regular SV.  */
324         return make_temp_object(aTHX_ newSVpvn((char *)(warnings + 1), *warnings));
325     }
326 }
327
328 static SV *
329 make_cop_io_object(pTHX_ COP *cop)
330 {
331     SV *const value = newSV(0);
332
333     Perl_emulate_cop_io(aTHX_ cop, value);
334
335     if(SvOK(value)) {
336         return make_sv_object(aTHX_ value);
337     } else {
338         SvREFCNT_dec(value);
339         return make_sv_object(aTHX_ NULL);
340     }
341 }
342 #endif
343
344 static SV *
345 make_mg_object(pTHX_ MAGIC *mg)
346 {
347     SV *arg = sv_newmortal();
348     sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg));
349     return arg;
350 }
351
352 static SV *
353 cstring(pTHX_ SV *sv, bool perlstyle)
354 {
355     SV *sstr;
356
357     if (!SvOK(sv))
358         return newSVpvs_flags("0", SVs_TEMP);
359
360     sstr = newSVpvs_flags("\"", SVs_TEMP);
361
362     if (perlstyle && SvUTF8(sv)) {
363         SV *tmpsv = sv_newmortal(); /* Temporary SV to feed sv_uni_display */
364         const STRLEN len = SvCUR(sv);
365         const char *s = sv_uni_display(tmpsv, sv, 8*len, UNI_DISPLAY_QQ);
366         while (*s)
367         {
368             if (*s == '"')
369                 sv_catpvs(sstr, "\\\"");
370             else if (*s == '$')
371                 sv_catpvs(sstr, "\\$");
372             else if (*s == '@')
373                 sv_catpvs(sstr, "\\@");
374             else if (*s == '\\')
375             {
376                 if (strchr("nrftax\\",*(s+1)))
377                     sv_catpvn(sstr, s++, 2);
378                 else
379                     sv_catpvs(sstr, "\\\\");
380             }
381             else /* should always be printable */
382                 sv_catpvn(sstr, s, 1);
383             ++s;
384         }
385     }
386     else
387     {
388         /* XXX Optimise? */
389         STRLEN len;
390         const char *s = SvPV(sv, len);
391         for (; len; len--, s++)
392         {
393             /* At least try a little for readability */
394             if (*s == '"')
395                 sv_catpvs(sstr, "\\\"");
396             else if (*s == '\\')
397                 sv_catpvs(sstr, "\\\\");
398             /* trigraphs - bleagh */
399             else if (!perlstyle && *s == '?' && len>=3 && s[1] == '?') {
400                 Perl_sv_catpvf(aTHX_ sstr, "\\%03o", '?');
401             }
402             else if (perlstyle && *s == '$')
403                 sv_catpvs(sstr, "\\$");
404             else if (perlstyle && *s == '@')
405                 sv_catpvs(sstr, "\\@");
406 #ifdef EBCDIC
407             else if (isPRINT(*s))
408 #else
409             else if (*s >= ' ' && *s < 127)
410 #endif /* EBCDIC */
411                 sv_catpvn(sstr, s, 1);
412             else if (*s == '\n')
413                 sv_catpvs(sstr, "\\n");
414             else if (*s == '\r')
415                 sv_catpvs(sstr, "\\r");
416             else if (*s == '\t')
417                 sv_catpvs(sstr, "\\t");
418             else if (*s == '\a')
419                 sv_catpvs(sstr, "\\a");
420             else if (*s == '\b')
421                 sv_catpvs(sstr, "\\b");
422             else if (*s == '\f')
423                 sv_catpvs(sstr, "\\f");
424             else if (!perlstyle && *s == '\v')
425                 sv_catpvs(sstr, "\\v");
426             else
427             {
428                 /* Don't want promotion of a signed -1 char in sprintf args */
429                 const unsigned char c = (unsigned char) *s;
430                 Perl_sv_catpvf(aTHX_ sstr, "\\%03o", c);
431             }
432             /* XXX Add line breaks if string is long */
433         }
434     }
435     sv_catpvs(sstr, "\"");
436     return sstr;
437 }
438
439 static SV *
440 cchar(pTHX_ SV *sv)
441 {
442     SV *sstr = newSVpvs_flags("'", SVs_TEMP);
443     const char *s = SvPV_nolen(sv);
444     /* Don't want promotion of a signed -1 char in sprintf args */
445     const unsigned char c = (unsigned char) *s;
446
447     if (c == '\'')
448         sv_catpvs(sstr, "\\'");
449     else if (c == '\\')
450         sv_catpvs(sstr, "\\\\");
451 #ifdef EBCDIC
452     else if (isPRINT(c))
453 #else
454     else if (c >= ' ' && c < 127)
455 #endif /* EBCDIC */
456         sv_catpvn(sstr, s, 1);
457     else if (c == '\n')
458         sv_catpvs(sstr, "\\n");
459     else if (c == '\r')
460         sv_catpvs(sstr, "\\r");
461     else if (c == '\t')
462         sv_catpvs(sstr, "\\t");
463     else if (c == '\a')
464         sv_catpvs(sstr, "\\a");
465     else if (c == '\b')
466         sv_catpvs(sstr, "\\b");
467     else if (c == '\f')
468         sv_catpvs(sstr, "\\f");
469     else if (c == '\v')
470         sv_catpvs(sstr, "\\v");
471     else
472         Perl_sv_catpvf(aTHX_ sstr, "\\%03o", c);
473     sv_catpvs(sstr, "'");
474     return sstr;
475 }
476
477 #if PERL_VERSION >= 9
478 #  define PMOP_pmreplstart(o)   o->op_pmstashstartu.op_pmreplstart
479 #  define PMOP_pmreplroot(o)    o->op_pmreplrootu.op_pmreplroot
480 #else
481 #  define PMOP_pmreplstart(o)   o->op_pmreplstart
482 #  define PMOP_pmreplroot(o)    o->op_pmreplroot
483 #  define PMOP_pmpermflags(o)   o->op_pmpermflags
484 #  define PMOP_pmdynflags(o)      o->op_pmdynflags
485 #endif
486
487 static SV *
488 walkoptree(pTHX_ OP *o, const char *method, SV *ref)
489 {
490     dSP;
491     OP *kid;
492     SV *object;
493     const char *const classname = opclassnames[cc_opclass(aTHX_ o)];
494     dMY_CXT;
495
496     /* Check that no-one has changed our reference, or is holding a reference
497        to it.  */
498     if (SvREFCNT(ref) == 1 && SvROK(ref) && SvTYPE(ref) == SVt_RV
499         && (object = SvRV(ref)) && SvREFCNT(object) == 1
500         && SvTYPE(object) == SVt_PVMG && SvIOK_only(object)
501         && !SvMAGICAL(object) && !SvMAGIC(object) && SvSTASH(object)) {
502         /* Looks good, so rebless it for the class we need:  */
503         sv_bless(ref, gv_stashpv(classname, GV_ADD));
504     } else {
505         /* Need to make a new one. */
506         ref = sv_newmortal();
507         object = newSVrv(ref, classname);
508     }
509     sv_setiv(object, PTR2IV(o));
510
511     if (walkoptree_debug) {
512         PUSHMARK(sp);
513         XPUSHs(ref);
514         PUTBACK;
515         perl_call_method("walkoptree_debug", G_DISCARD);
516     }
517     PUSHMARK(sp);
518     XPUSHs(ref);
519     PUTBACK;
520     perl_call_method(method, G_DISCARD);
521     if (o && (o->op_flags & OPf_KIDS)) {
522         for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) {
523             ref = walkoptree(aTHX_ kid, method, ref);
524         }
525     }
526     if (o && (cc_opclass(aTHX_ o) == OPc_PMOP) && o->op_type != OP_PUSHRE
527            && (kid = PMOP_pmreplroot(cPMOPo)))
528     {
529         ref = walkoptree(aTHX_ kid, method, ref);
530     }
531     return ref;
532 }
533
534 static SV **
535 oplist(pTHX_ OP *o, SV **SP)
536 {
537     for(; o; o = o->op_next) {
538 #if PERL_VERSION >= 9
539         if (o->op_opt == 0)
540             break;
541         o->op_opt = 0;
542 #else
543         if (o->op_seq == 0)
544             break;
545         o->op_seq = 0;
546 #endif
547         XPUSHs(make_op_object(aTHX_ o));
548         switch (o->op_type) {
549         case OP_SUBST:
550             SP = oplist(aTHX_ PMOP_pmreplstart(cPMOPo), SP);
551             continue;
552         case OP_SORT:
553             if (o->op_flags & OPf_STACKED && o->op_flags & OPf_SPECIAL) {
554                 OP *kid = cLISTOPo->op_first->op_sibling;   /* pass pushmark */
555                 kid = kUNOP->op_first;                      /* pass rv2gv */
556                 kid = kUNOP->op_first;                      /* pass leave */
557                 SP = oplist(aTHX_ kid->op_next, SP);
558             }
559             continue;
560         }
561         switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
562         case OA_LOGOP:
563             SP = oplist(aTHX_ cLOGOPo->op_other, SP);
564             break;
565         case OA_LOOP:
566             SP = oplist(aTHX_ cLOOPo->op_lastop, SP);
567             SP = oplist(aTHX_ cLOOPo->op_nextop, SP);
568             SP = oplist(aTHX_ cLOOPo->op_redoop, SP);
569             break;
570         }
571     }
572     return SP;
573 }
574
575 typedef OP      *B__OP;
576 typedef UNOP    *B__UNOP;
577 typedef BINOP   *B__BINOP;
578 typedef LOGOP   *B__LOGOP;
579 typedef LISTOP  *B__LISTOP;
580 typedef PMOP    *B__PMOP;
581 typedef SVOP    *B__SVOP;
582 typedef PADOP   *B__PADOP;
583 typedef PVOP    *B__PVOP;
584 typedef LOOP    *B__LOOP;
585 typedef COP     *B__COP;
586
587 typedef SV      *B__SV;
588 typedef SV      *B__IV;
589 typedef SV      *B__PV;
590 typedef SV      *B__NV;
591 typedef SV      *B__PVMG;
592 #if PERL_VERSION >= 11
593 typedef SV      *B__REGEXP;
594 #endif
595 typedef SV      *B__PVLV;
596 typedef SV      *B__BM;
597 typedef SV      *B__RV;
598 typedef SV      *B__FM;
599 typedef AV      *B__AV;
600 typedef HV      *B__HV;
601 typedef CV      *B__CV;
602 typedef GV      *B__GV;
603 typedef IO      *B__IO;
604
605 typedef MAGIC   *B__MAGIC;
606 typedef HE      *B__HE;
607 #if PERL_VERSION >= 9
608 typedef struct refcounted_he    *B__RHE;
609 #endif
610
611 #ifdef MULTIPLICITY
612 #  define ASSIGN_COMMON_ALIAS(prefix, var) \
613     STMT_START { XSANY.any_i32 = offsetof(struct interpreter, prefix##var); } STMT_END
614 #else
615 #  define ASSIGN_COMMON_ALIAS(prefix, var) \
616     STMT_START { XSANY.any_ptr = (void *)&PL_##var; } STMT_END
617 #endif
618
619 /* This needs to be ALIASed in a custom way, hence can't easily be defined as
620    a regular XSUB.  */
621 static XSPROTO(intrpvar_sv_common); /* prototype to pass -Wmissing-prototypes */
622 static XSPROTO(intrpvar_sv_common)
623 {
624     dVAR;
625     dXSARGS;
626     SV *ret;
627     if (items != 0)
628        croak_xs_usage(cv,  "");
629 #ifdef MULTIPLICITY
630     ret = *(SV **)(XSANY.any_i32 + (char *)my_perl);
631 #else
632     ret = *(SV **)(XSANY.any_ptr);
633 #endif
634     ST(0) = make_sv_object(aTHX_ ret);
635     XSRETURN(1);
636 }
637
638 #include "const-c.inc"
639
640 MODULE = B      PACKAGE = B
641
642 INCLUDE: const-xs.inc
643
644 PROTOTYPES: DISABLE
645
646 BOOT:
647 {
648     CV *cv;
649     const char *file = __FILE__;
650     MY_CXT_INIT;
651     specialsv_list[0] = Nullsv;
652     specialsv_list[1] = &PL_sv_undef;
653     specialsv_list[2] = &PL_sv_yes;
654     specialsv_list[3] = &PL_sv_no;
655     specialsv_list[4] = (SV *) pWARN_ALL;
656     specialsv_list[5] = (SV *) pWARN_NONE;
657     specialsv_list[6] = (SV *) pWARN_STD;
658     
659     cv = newXS("B::init_av", intrpvar_sv_common, file);
660     ASSIGN_COMMON_ALIAS(I, initav);
661     cv = newXS("B::check_av", intrpvar_sv_common, file);
662     ASSIGN_COMMON_ALIAS(I, checkav_save);
663 #if PERL_VERSION >= 9
664     cv = newXS("B::unitcheck_av", intrpvar_sv_common, file);
665     ASSIGN_COMMON_ALIAS(I, unitcheckav_save);
666 #endif
667     cv = newXS("B::begin_av", intrpvar_sv_common, file);
668     ASSIGN_COMMON_ALIAS(I, beginav_save);
669     cv = newXS("B::end_av", intrpvar_sv_common, file);
670     ASSIGN_COMMON_ALIAS(I, endav);
671     cv = newXS("B::main_cv", intrpvar_sv_common, file);
672     ASSIGN_COMMON_ALIAS(I, main_cv);
673     cv = newXS("B::inc_gv", intrpvar_sv_common, file);
674     ASSIGN_COMMON_ALIAS(I, incgv);
675     cv = newXS("B::defstash", intrpvar_sv_common, file);
676     ASSIGN_COMMON_ALIAS(I, defstash);
677     cv = newXS("B::curstash", intrpvar_sv_common, file);
678     ASSIGN_COMMON_ALIAS(I, curstash);
679     cv = newXS("B::formfeed", intrpvar_sv_common, file);
680     ASSIGN_COMMON_ALIAS(I, formfeed);
681 #ifdef USE_ITHREADS
682     cv = newXS("B::regex_padav", intrpvar_sv_common, file);
683     ASSIGN_COMMON_ALIAS(I, regex_padav);
684 #endif
685     cv = newXS("B::warnhook", intrpvar_sv_common, file);
686     ASSIGN_COMMON_ALIAS(I, warnhook);
687     cv = newXS("B::diehook", intrpvar_sv_common, file);
688     ASSIGN_COMMON_ALIAS(I, diehook);
689 }
690
691 long 
692 amagic_generation()
693     CODE:
694         RETVAL = PL_amagic_generation;
695     OUTPUT:
696         RETVAL
697
698 void
699 comppadlist()
700     PPCODE:
701         PUSHs(make_sv_object(aTHX_ (SV *)(PL_main_cv ? CvPADLIST(PL_main_cv)
702                                                      : CvPADLIST(PL_compcv))));
703
704 void
705 sv_undef()
706     ALIAS:
707         sv_no = 1
708         sv_yes = 2
709     PPCODE:
710         PUSHs(make_sv_object(aTHX_ ix > 1 ? &PL_sv_yes
711                                           : ix < 1 ? &PL_sv_undef
712                                                    : &PL_sv_no));
713
714 void
715 main_root()
716     ALIAS:
717         main_start = 1
718     PPCODE:
719         PUSHs(make_op_object(aTHX_ ix ? PL_main_start : PL_main_root));
720
721 UV
722 sub_generation()
723     ALIAS:
724         dowarn = 1
725     CODE:
726         RETVAL = ix ? PL_dowarn : PL_sub_generation;
727     OUTPUT:
728         RETVAL
729
730 void
731 walkoptree(op, method)
732         B::OP op
733         const char *    method
734     CODE:
735         (void) walkoptree(aTHX_ op, method, &PL_sv_undef);
736
737 int
738 walkoptree_debug(...)
739     CODE:
740         dMY_CXT;
741         RETVAL = walkoptree_debug;
742         if (items > 0 && SvTRUE(ST(1)))
743             walkoptree_debug = 1;
744     OUTPUT:
745         RETVAL
746
747 #define address(sv) PTR2IV(sv)
748
749 IV
750 address(sv)
751         SV *    sv
752
753 void
754 svref_2object(sv)
755         SV *    sv
756     PPCODE:
757         if (!SvROK(sv))
758             croak("argument is not a reference");
759         PUSHs(make_sv_object(aTHX_ SvRV(sv)));
760
761 void
762 opnumber(name)
763 const char *    name
764 CODE:
765 {
766  int i; 
767  IV  result = -1;
768  ST(0) = sv_newmortal();
769  if (strncmp(name,"pp_",3) == 0)
770    name += 3;
771  for (i = 0; i < PL_maxo; i++)
772   {
773    if (strcmp(name, PL_op_name[i]) == 0)
774     {
775      result = i;
776      break;
777     }
778   }
779  sv_setiv(ST(0),result);
780 }
781
782 void
783 ppname(opnum)
784         int     opnum
785     CODE:
786         ST(0) = sv_newmortal();
787         if (opnum >= 0 && opnum < PL_maxo)
788             Perl_sv_setpvf(aTHX_ ST(0), "pp_%s", PL_op_name[opnum]);
789
790 void
791 hash(sv)
792         SV *    sv
793     CODE:
794         STRLEN len;
795         U32 hash = 0;
796         const char *s = SvPVbyte(sv, len);
797         PERL_HASH(hash, s, len);
798         ST(0) = sv_2mortal(Perl_newSVpvf(aTHX_ "0x%"UVxf, (UV)hash));
799
800 #define cast_I32(foo) (I32)foo
801 IV
802 cast_I32(i)
803         IV      i
804
805 void
806 minus_c()
807     ALIAS:
808         save_BEGINs = 1
809     CODE:
810         if (ix)
811             PL_savebegin = TRUE;
812         else
813             PL_minus_c = TRUE;
814
815 void
816 cstring(sv)
817         SV *    sv
818     ALIAS:
819         perlstring = 1
820         cchar = 2
821     PPCODE:
822         PUSHs(ix == 2 ? cchar(aTHX_ sv) : cstring(aTHX_ sv, (bool)ix));
823
824 void
825 threadsv_names()
826     PPCODE:
827 #if PERL_VERSION <= 8
828 # ifdef USE_5005THREADS
829         int i;
830         const STRLEN len = strlen(PL_threadsv_names);
831
832         EXTEND(sp, len);
833         for (i = 0; i < len; i++)
834             PUSHs(newSVpvn_flags(&PL_threadsv_names[i], 1, SVs_TEMP));
835 # endif
836 #endif
837
838 #define SVp             0x00000
839 #define U32p            0x10000
840 #define line_tp         0x20000
841 #define OPp             0x30000
842 #define PADOFFSETp      0x40000
843 #define U8p             0x50000
844 #define IVp             0x60000
845 #define char_pp         0x70000
846
847 #define OP_next_ix              OPp | offsetof(struct op, op_next)
848 #define OP_sibling_ix           OPp | offsetof(struct op, op_sibling)
849 #define UNOP_first_ix           OPp | offsetof(struct unop, op_first)
850 #define BINOP_last_ix           OPp | offsetof(struct binop, op_last)
851 #define LOGOP_other_ix          OPp | offsetof(struct logop, op_other)
852 #if PERL_VERSION >= 9
853 #  define PMOP_pmreplstart_ix \
854                 OPp | offsetof(struct pmop, op_pmstashstartu.op_pmreplstart)
855 #else
856 #  define PMOP_pmreplstart_ix   OPp | offsetof(struct pmop, op_pmreplstart)
857 #endif
858 #define LOOP_redoop_ix          OPp | offsetof(struct loop, op_redoop)
859 #define LOOP_nextop_ix          OPp | offsetof(struct loop, op_nextop)
860 #define LOOP_lastop_ix          OPp | offsetof(struct loop, op_lastop)
861
862 #define OP_targ_ix              PADOFFSETp | offsetof(struct op, op_targ)
863 #define OP_flags_ix             U8p | offsetof(struct op, op_flags)
864 #define OP_private_ix           U8p | offsetof(struct op, op_private)
865
866 #define PMOP_pmflags_ix         U32p | offsetof(struct pmop, op_pmflags)
867 #define PMOP_code_list_ix       OPp | offsetof(struct pmop, op_code_list)
868
869 #ifdef USE_ITHREADS
870 #define PMOP_pmoffset_ix        IVp | offsetof(struct pmop, op_pmoffset)
871 #endif
872
873 #  Yes, B::SV::sv and B::SV::gv really do end up generating identical code.
874 #define SVOP_sv_ix              SVp | offsetof(struct svop, op_sv)
875 #define SVOP_gv_ix              SVp | offsetof(struct svop, op_sv)
876
877 #define PADOP_padix_ix          PADOFFSETp | offsetof(struct padop, op_padix)
878
879 #define COP_seq_ix              U32p | offsetof(struct cop, cop_seq)
880 #define COP_line_ix             line_tp | offsetof(struct cop, cop_line)
881 #if PERL_VERSION >= 9
882 #define COP_hints_ix            U32p | offsetof(struct cop, cop_hints)
883 #else
884 #define COP_hints_ix            U8p | offsetof(struct cop, op_private)
885 #endif
886
887 #ifdef USE_ITHREADS
888 #define COP_stashpv_ix          char_pp | offsetof(struct cop, cop_stashpv)
889 #define COP_stashoff_ix     PADOFFSETp | offsetof(struct cop, cop_stashoff)
890 #define COP_file_ix             char_pp | offsetof(struct cop, cop_file)
891 #else
892 #define COP_stash_ix            SVp | offsetof(struct cop, cop_stash)
893 #define COP_filegv_ix           SVp | offsetof(struct cop, cop_filegv)
894 #endif
895
896 MODULE = B      PACKAGE = B::OP
897
898 size_t
899 size(o)
900         B::OP           o
901     CODE:
902         RETVAL = opsizes[cc_opclass(aTHX_ o)];
903     OUTPUT:
904         RETVAL
905
906 # The type checking code in B has always been identical for all OP types,
907 # irrespective of whether the action is actually defined on that OP.
908 # We should fix this
909 void
910 next(o)
911         B::OP           o
912     ALIAS:
913         B::OP::next = OP_next_ix
914         B::OP::sibling = OP_sibling_ix
915         B::OP::targ = OP_targ_ix
916         B::OP::flags = OP_flags_ix
917         B::OP::private = OP_private_ix
918         B::UNOP::first = UNOP_first_ix
919         B::BINOP::last = BINOP_last_ix
920         B::LOGOP::other = LOGOP_other_ix
921         B::PMOP::pmreplstart = PMOP_pmreplstart_ix
922         B::LOOP::redoop = LOOP_redoop_ix
923         B::LOOP::nextop = LOOP_nextop_ix
924         B::LOOP::lastop = LOOP_lastop_ix
925         B::PMOP::pmflags = PMOP_pmflags_ix
926         B::PMOP::code_list = PMOP_code_list_ix
927         B::SVOP::sv = SVOP_sv_ix
928         B::SVOP::gv = SVOP_gv_ix
929         B::PADOP::padix = PADOP_padix_ix
930         B::COP::cop_seq = COP_seq_ix
931         B::COP::line = COP_line_ix
932         B::COP::hints = COP_hints_ix
933     PREINIT:
934         char *ptr;
935         SV *ret;
936     PPCODE:
937         ptr = (ix & 0xFFFF) + (char *)o;
938         switch ((U8)(ix >> 16)) {
939         case (U8)(OPp >> 16):
940             ret = make_op_object(aTHX_ *((OP **)ptr));
941             break;
942         case (U8)(PADOFFSETp >> 16):
943             ret = sv_2mortal(newSVuv(*((PADOFFSET*)ptr)));
944             break;
945         case (U8)(U8p >> 16):
946             ret = sv_2mortal(newSVuv(*((U8*)ptr)));
947             break;
948         case (U8)(U32p >> 16):
949             ret = sv_2mortal(newSVuv(*((U32*)ptr)));
950             break;
951         case (U8)(SVp >> 16):
952             ret = make_sv_object(aTHX_ *((SV **)ptr));
953             break;
954         case (U8)(line_tp >> 16):
955             ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
956             break;
957 #ifdef USE_ITHREADS
958         case (U8)(IVp >> 16):
959             ret = sv_2mortal(newSViv(*((IV*)ptr)));
960             break;
961         case (U8)(char_pp >> 16):
962             ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
963             break;
964 #endif
965         default:
966             croak("Illegal alias 0x%08x for B::*next", (unsigned)ix);
967
968         }
969         ST(0) = ret;
970         XSRETURN(1);
971
972 char *
973 name(o)
974         B::OP           o
975     ALIAS:
976         desc = 1
977     CODE:
978         RETVAL = (char *)(ix ? OP_DESC(o) : OP_NAME(o));
979     OUTPUT:
980         RETVAL
981
982 void
983 ppaddr(o)
984         B::OP           o
985     PREINIT:
986         int i;
987         SV *sv;
988     CODE:
989         sv = sv_2mortal(Perl_newSVpvf(aTHX_ "PL_ppaddr[OP_%s]",
990                                       PL_op_name[o->op_type]));
991         for (i=13; (STRLEN)i < SvCUR(sv); ++i)
992             SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]);
993         ST(0) = sv;
994
995 #if PERL_VERSION >= 9
996 #  These 3 are all bitfields, so we can't take their addresses.
997 UV
998 type(o)
999         B::OP           o
1000     ALIAS:
1001         opt = 1
1002         spare = 2
1003     CODE:
1004         switch(ix) {
1005           case 1:
1006             RETVAL = o->op_opt;
1007             break;
1008           case 2:
1009             RETVAL = o->op_spare;
1010             break;
1011           default:
1012             RETVAL = o->op_type;
1013         }
1014     OUTPUT:
1015         RETVAL
1016
1017 #else
1018
1019 UV
1020 type(o)
1021         B::OP           o
1022     ALIAS:
1023         seq = 1
1024     CODE:
1025         switch(ix) {
1026           case 1:
1027             RETVAL = o->op_seq;
1028             break;
1029           default:
1030             RETVAL = o->op_type;
1031         }
1032     OUTPUT:
1033         RETVAL
1034
1035 #endif
1036
1037 void
1038 oplist(o)
1039         B::OP           o
1040     PPCODE:
1041         SP = oplist(aTHX_ o, SP);
1042
1043 MODULE = B      PACKAGE = B::LISTOP
1044
1045 U32
1046 children(o)
1047         B::LISTOP       o
1048         OP *            kid = NO_INIT
1049         int             i = NO_INIT
1050     CODE:
1051         i = 0;
1052         for (kid = o->op_first; kid; kid = kid->op_sibling)
1053             i++;
1054         RETVAL = i;
1055     OUTPUT:
1056         RETVAL
1057
1058 MODULE = B      PACKAGE = B::PMOP               PREFIX = PMOP_
1059
1060 #if PERL_VERSION <= 8
1061
1062 void
1063 PMOP_pmreplroot(o)
1064         B::PMOP         o
1065         OP *            root = NO_INIT
1066     CODE:
1067         root = o->op_pmreplroot;
1068         /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */
1069         if (o->op_type == OP_PUSHRE) {
1070             ST(0) = sv_newmortal();
1071 #  ifdef USE_ITHREADS
1072             sv_setiv(ST(0), INT2PTR(PADOFFSET,root) );
1073 #  else
1074             sv_setiv(newSVrv(ST(0), root ?
1075                              svclassnames[SvTYPE((SV*)root)] : "B::SV"),
1076                      PTR2IV(root));
1077 #  endif
1078         }
1079         else {
1080             ST(0) = make_op_object(aTHX_ root);
1081         }
1082
1083 #else
1084
1085 void
1086 PMOP_pmreplroot(o)
1087         B::PMOP         o
1088     CODE:
1089         if (o->op_type == OP_PUSHRE) {
1090 #  ifdef USE_ITHREADS
1091             ST(0) = sv_newmortal();
1092             sv_setiv(ST(0), o->op_pmreplrootu.op_pmtargetoff);
1093 #  else
1094             GV *const target = o->op_pmreplrootu.op_pmtargetgv;
1095             ST(0) = sv_newmortal();
1096             sv_setiv(newSVrv(ST(0), target ?
1097                              svclassnames[SvTYPE((SV*)target)] : "B::SV"),
1098                      PTR2IV(target));
1099 #  endif
1100         }
1101         else {
1102             OP *const root = o->op_pmreplrootu.op_pmreplroot; 
1103             ST(0) = make_op_object(aTHX_ root);
1104         }
1105
1106 #endif
1107
1108 #ifdef USE_ITHREADS
1109 #define PMOP_pmstashpv(o)       PmopSTASHPV(o);
1110
1111 char*
1112 PMOP_pmstashpv(o)
1113         B::PMOP         o
1114
1115 #else
1116
1117 void
1118 PMOP_pmstash(o)
1119         B::PMOP         o
1120     PPCODE:
1121         PUSHs(make_sv_object(aTHX_ (SV *) PmopSTASH(o)));
1122
1123 #endif
1124
1125 #if PERL_VERSION < 9
1126
1127 void
1128 PMOP_pmnext(o)
1129         B::PMOP         o
1130     PPCODE:
1131         PUSHs(make_op_object(aTHX_ o->op_pmnext));
1132
1133 U32
1134 PMOP_pmpermflags(o)
1135         B::PMOP         o
1136
1137 U8
1138 PMOP_pmdynflags(o)
1139         B::PMOP         o
1140
1141 #endif
1142
1143 void
1144 PMOP_precomp(o)
1145         B::PMOP         o
1146     PREINIT:
1147         dXSI32;
1148         REGEXP *rx;
1149     CODE:
1150         rx = PM_GETRE(o);
1151         ST(0) = sv_newmortal();
1152         if (rx) {
1153 #if PERL_VERSION >= 9
1154             if (ix) {
1155                 sv_setuv(ST(0), RX_EXTFLAGS(rx));
1156             } else
1157 #endif
1158             {
1159                 sv_setpvn(ST(0), RX_PRECOMP(rx), RX_PRELEN(rx));
1160             }
1161         }
1162
1163 BOOT:
1164 {
1165         CV *cv;
1166 #ifdef USE_ITHREADS
1167         cv = newXS("B::PMOP::pmoffset", XS_B__OP_next, __FILE__);
1168         XSANY.any_i32 = PMOP_pmoffset_ix;
1169 # if PERL_VERSION < 17 || defined(CopSTASH_len)
1170         cv = newXS("B::COP::stashpv", XS_B__OP_next, __FILE__);
1171         XSANY.any_i32 = COP_stashpv_ix;
1172 # else
1173         cv = newXS("B::COP::stashoff", XS_B__OP_next, __FILE__);
1174         XSANY.any_i32 = COP_stashoff_ix;
1175 # endif
1176         cv = newXS("B::COP::file", XS_B__OP_next, __FILE__);
1177         XSANY.any_i32 = COP_file_ix;
1178 #else
1179         cv = newXS("B::COP::stash", XS_B__OP_next, __FILE__);
1180         XSANY.any_i32 = COP_stash_ix;
1181         cv = newXS("B::COP::filegv", XS_B__OP_next, __FILE__);
1182         XSANY.any_i32 = COP_filegv_ix;
1183 #endif
1184 #if PERL_VERSION >= 9
1185         cv = newXS("B::PMOP::reflags", XS_B__PMOP_precomp, __FILE__);
1186         XSANY.any_i32 = 1;
1187 #endif
1188 }
1189
1190 MODULE = B      PACKAGE = B::PADOP
1191
1192 void
1193 sv(o)
1194         B::PADOP o
1195     PREINIT:
1196         SV *ret;
1197     ALIAS:
1198         gv = 1
1199     PPCODE:
1200         /* It happens that the output typemaps for B::SV and B::GV are
1201            identical. The "smarts" are in make_sv_object(), which determines
1202            which class to use based on SvTYPE(), rather than anything baked in
1203            at compile time.  */    
1204         if (o->op_padix) {
1205             ret = PAD_SVl(o->op_padix);
1206             if (ix && SvTYPE(ret) != SVt_PVGV)
1207                 ret = NULL;
1208         } else {
1209             ret = NULL;
1210         }
1211         PUSHs(make_sv_object(aTHX_ ret));
1212
1213 MODULE = B      PACKAGE = B::PVOP
1214
1215 void
1216 pv(o)
1217         B::PVOP o
1218     CODE:
1219         /*
1220          * OP_TRANS uses op_pv to point to a table of 256 or >=258 shorts
1221          * whereas other PVOPs point to a null terminated string.
1222          */
1223         if ((o->op_type == OP_TRANS || o->op_type == OP_TRANSR) &&
1224                 (o->op_private & OPpTRANS_COMPLEMENT) &&
1225                 !(o->op_private & OPpTRANS_DELETE))
1226         {
1227             const short* const tbl = (short*)o->op_pv;
1228             const short entries = 257 + tbl[256];
1229             ST(0) = newSVpvn_flags(o->op_pv, entries * sizeof(short), SVs_TEMP);
1230         }
1231         else if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
1232             ST(0) = newSVpvn_flags(o->op_pv, 256 * sizeof(short), SVs_TEMP);
1233         }
1234         else
1235             ST(0) = newSVpvn_flags(o->op_pv, strlen(o->op_pv), SVs_TEMP);
1236
1237 #define COP_label(o)    CopLABEL(o)
1238
1239 MODULE = B      PACKAGE = B::COP                PREFIX = COP_
1240
1241 const char *
1242 COP_label(o)
1243         B::COP  o
1244
1245 # Both pairs of accessors are provided for both ithreads and not, but for each,
1246 # one pair is direct structure access, and 1 pair "faked up" with a more complex
1247 # macro. We implement the direct structure access pair using the common code
1248 # above (B::OP::next)
1249  
1250 #ifdef USE_ITHREADS
1251
1252 void
1253 COP_stash(o)
1254         B::COP  o
1255     ALIAS:
1256         filegv = 1
1257     PPCODE:
1258         PUSHs(make_sv_object(aTHX_
1259                              ix ? (SV *)CopFILEGV(o) : (SV *)CopSTASH(o)));
1260
1261 #else
1262
1263 char *
1264 COP_file(o)
1265         B::COP  o
1266     CODE:
1267         RETVAL = CopFILE(o);
1268     OUTPUT:
1269         RETVAL
1270
1271 #endif
1272
1273 #if PERL_VERSION >= 10
1274
1275 SV *
1276 COP_stashpv(o)
1277         B::COP  o
1278     CODE:
1279         RETVAL = CopSTASH(o) && SvTYPE(CopSTASH(o)) == SVt_PVHV
1280             ? newSVhek(HvNAME_HEK(CopSTASH(o)))
1281             : &PL_sv_undef;
1282     OUTPUT:
1283         RETVAL
1284
1285 #else
1286
1287 char *
1288 COP_stashpv(o)
1289         B::COP  o
1290     CODE:
1291         RETVAL = CopSTASHPV(o);
1292     OUTPUT:
1293         RETVAL
1294
1295 #endif
1296
1297 I32
1298 COP_arybase(o)
1299         B::COP  o
1300     CODE:
1301         RETVAL = 0;
1302     OUTPUT:
1303         RETVAL
1304
1305 void
1306 COP_warnings(o)
1307         B::COP  o
1308     ALIAS:
1309         io = 1
1310     PPCODE:
1311 #if PERL_VERSION >= 9
1312         ST(0) = ix ? make_cop_io_object(aTHX_ o) : make_warnings_object(aTHX_ o);
1313 #else
1314         ST(0) = make_sv_object(aTHX_ ix ? o->cop_io : o->cop_warnings);
1315 #endif
1316         XSRETURN(1);
1317
1318 #if PERL_VERSION >= 9
1319
1320 B::RHE
1321 COP_hints_hash(o)
1322         B::COP o
1323     CODE:
1324         RETVAL = CopHINTHASH_get(o);
1325     OUTPUT:
1326         RETVAL
1327
1328 #endif
1329
1330 MODULE = B      PACKAGE = B::SV
1331
1332 #define MAGICAL_FLAG_BITS (SVs_GMG|SVs_SMG|SVs_RMG)
1333
1334 U32
1335 REFCNT(sv)
1336         B::SV   sv
1337     ALIAS:
1338         FLAGS = 0xFFFFFFFF
1339         SvTYPE = SVTYPEMASK
1340         POK = SVf_POK
1341         ROK = SVf_ROK
1342         MAGICAL = MAGICAL_FLAG_BITS
1343     CODE:
1344         RETVAL = ix ? (SvFLAGS(sv) & (U32)ix) : SvREFCNT(sv);
1345     OUTPUT:
1346         RETVAL
1347
1348 void
1349 object_2svref(sv)
1350         B::SV   sv
1351     PPCODE:
1352         ST(0) = sv_2mortal(newRV(sv));
1353         XSRETURN(1);
1354         
1355 MODULE = B      PACKAGE = B::IV         PREFIX = Sv
1356
1357 IV
1358 SvIV(sv)
1359         B::IV   sv
1360
1361 MODULE = B      PACKAGE = B::IV
1362
1363 #define sv_SVp          0x00000
1364 #define sv_IVp          0x10000
1365 #define sv_UVp          0x20000
1366 #define sv_STRLENp      0x30000
1367 #define sv_U32p         0x40000
1368 #define sv_U8p          0x50000
1369 #define sv_char_pp      0x60000
1370 #define sv_NVp          0x70000
1371 #define sv_char_p       0x80000
1372 #define sv_SSize_tp     0x90000
1373 #define sv_I32p         0xA0000
1374 #define sv_U16p         0xB0000
1375
1376 #define IV_ivx_ix       sv_IVp | offsetof(struct xpviv, xiv_iv)
1377 #define IV_uvx_ix       sv_UVp | offsetof(struct xpvuv, xuv_uv)
1378 #define NV_nvx_ix       sv_NVp | offsetof(struct xpvnv, xnv_u.xnv_nv)
1379
1380 #if PERL_VERSION >= 10
1381 #define NV_cop_seq_range_low_ix \
1382                         sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
1383 #define NV_cop_seq_range_high_ix \
1384                         sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
1385 #define NV_parent_pad_index_ix \
1386                         sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
1387 #define NV_parent_fakelex_flags_ix \
1388                         sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
1389 #else
1390 #define NV_cop_seq_range_low_ix \
1391                         sv_NVp | offsetof(struct xpvnv, xnv_nv)
1392 #define NV_cop_seq_range_high_ix \
1393                         sv_UVp | offsetof(struct xpvnv, xuv_uv)
1394 #define NV_parent_pad_index_ix \
1395                         sv_NVp | offsetof(struct xpvnv, xnv_nv)
1396 #define NV_parent_fakelex_flags_ix \
1397                         sv_UVp | offsetof(struct xpvnv, xuv_uv)
1398 #endif
1399
1400 #define PV_cur_ix       sv_STRLENp | offsetof(struct xpv, xpv_cur)
1401 #define PV_len_ix       sv_STRLENp | offsetof(struct xpv, xpv_len)
1402
1403 #define PVMG_stash_ix   sv_SVp | offsetof(struct xpvmg, xmg_stash)
1404
1405 #if PERL_VERSION >= 10
1406 #  if PERL_VERSION > 14
1407 #    define PVBM_useful_ix      sv_I32p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_useful)
1408 #    define PVBM_previous_ix    sv_UVp | offsetof(struct xpvuv, xuv_uv)
1409 #  else
1410 #define PVBM_useful_ix  sv_I32p | offsetof(struct xpvgv, xiv_u.xivu_i32)
1411 #define PVBM_previous_ix    sv_U32p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_previous)
1412 #  endif
1413 #define PVBM_rare_ix    sv_U8p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_rare)
1414 #else
1415 #define PVBM_useful_ix  sv_I32p | offsetof(struct xpvbm, xbm_useful)
1416 #define PVBM_previous_ix    sv_U16p | offsetof(struct xpvbm, xbm_previous)
1417 #define PVBM_rare_ix    sv_U8p | offsetof(struct xpvbm, xbm_rare)
1418 #endif
1419
1420 #define PVLV_targoff_ix sv_U32p | offsetof(struct xpvlv, xlv_targoff)
1421 #define PVLV_targlen_ix sv_U32p | offsetof(struct xpvlv, xlv_targlen)
1422 #define PVLV_targ_ix    sv_SVp | offsetof(struct xpvlv, xlv_targ)
1423 #define PVLV_type_ix    sv_char_p | offsetof(struct xpvlv, xlv_type)
1424
1425 #if PERL_VERSION >= 10
1426 #define PVGV_stash_ix   sv_SVp | offsetof(struct xpvgv, xnv_u.xgv_stash)
1427 #define PVGV_flags_ix   sv_STRLENp | offsetof(struct xpvgv, xpv_cur)
1428 #define PVIO_lines_ix   sv_IVp | offsetof(struct xpvio, xiv_iv)
1429 #else
1430 #define PVGV_stash_ix   sv_SVp | offsetof(struct xpvgv, xgv_stash)
1431 #define PVGV_flags_ix   sv_U8p | offsetof(struct xpvgv, xgv_flags)
1432 #define PVIO_lines_ix   sv_IVp | offsetof(struct xpvio, xio_lines)
1433 #endif
1434
1435 #define PVIO_page_ix        sv_IVp | offsetof(struct xpvio, xio_page)
1436 #define PVIO_page_len_ix    sv_IVp | offsetof(struct xpvio, xio_page_len)
1437 #define PVIO_lines_left_ix  sv_IVp | offsetof(struct xpvio, xio_lines_left)
1438 #define PVIO_top_name_ix    sv_char_pp | offsetof(struct xpvio, xio_top_name)
1439 #define PVIO_top_gv_ix      sv_SVp | offsetof(struct xpvio, xio_top_gv)
1440 #define PVIO_fmt_name_ix    sv_char_pp | offsetof(struct xpvio, xio_fmt_name)
1441 #define PVIO_fmt_gv_ix      sv_SVp | offsetof(struct xpvio, xio_fmt_gv)
1442 #define PVIO_bottom_name_ix sv_char_pp | offsetof(struct xpvio, xio_bottom_name)
1443 #define PVIO_bottom_gv_ix   sv_SVp | offsetof(struct xpvio, xio_bottom_gv)
1444 #define PVIO_type_ix        sv_char_p | offsetof(struct xpvio, xio_type)
1445 #define PVIO_flags_ix       sv_U8p | offsetof(struct xpvio, xio_flags)
1446
1447 #define PVAV_max_ix     sv_SSize_tp | offsetof(struct xpvav, xav_max)
1448
1449 #define PVFM_lines_ix   sv_IVp | offsetof(struct xpvfm, xfm_lines)
1450
1451 #define PVCV_stash_ix   sv_SVp | offsetof(struct xpvcv, xcv_stash) 
1452 #define PVCV_gv_ix      sv_SVp | offsetof(struct xpvcv, xcv_gv)
1453 #define PVCV_file_ix    sv_char_pp | offsetof(struct xpvcv, xcv_file)
1454 #define PVCV_depth_ix   sv_I32p | offsetof(struct xpvcv, xcv_depth)
1455 #define PVCV_padlist_ix sv_SVp | offsetof(struct xpvcv, xcv_padlist)
1456 #define PVCV_outside_ix sv_SVp | offsetof(struct xpvcv, xcv_outside)
1457 #define PVCV_outside_seq_ix sv_U32p | offsetof(struct xpvcv, xcv_outside_seq)
1458 #define PVCV_flags_ix   sv_U16p | offsetof(struct xpvcv, xcv_flags)
1459
1460 #define PVHV_max_ix     sv_STRLENp | offsetof(struct xpvhv, xhv_max)
1461
1462 #if PERL_VERSION > 12
1463 #define PVHV_keys_ix    sv_STRLENp | offsetof(struct xpvhv, xhv_keys)
1464 #else
1465 #define PVHV_keys_ix    sv_IVp | offsetof(struct xpvhv, xhv_keys)
1466 #endif
1467
1468 # The type checking code in B has always been identical for all SV types,
1469 # irrespective of whether the action is actually defined on that SV.
1470 # We should fix this
1471 void
1472 IVX(sv)
1473         B::SV           sv
1474     ALIAS:
1475         B::IV::IVX = IV_ivx_ix
1476         B::IV::UVX = IV_uvx_ix
1477         B::NV::NVX = NV_nvx_ix
1478         B::NV::COP_SEQ_RANGE_LOW = NV_cop_seq_range_low_ix
1479         B::NV::COP_SEQ_RANGE_HIGH = NV_cop_seq_range_high_ix
1480         B::NV::PARENT_PAD_INDEX = NV_parent_pad_index_ix
1481         B::NV::PARENT_FAKELEX_FLAGS = NV_parent_fakelex_flags_ix
1482         B::PV::CUR = PV_cur_ix
1483         B::PV::LEN = PV_len_ix
1484         B::PVMG::SvSTASH = PVMG_stash_ix
1485         B::PVLV::TARGOFF = PVLV_targoff_ix
1486         B::PVLV::TARGLEN = PVLV_targlen_ix
1487         B::PVLV::TARG = PVLV_targ_ix
1488         B::PVLV::TYPE = PVLV_type_ix
1489         B::GV::STASH = PVGV_stash_ix
1490         B::GV::GvFLAGS = PVGV_flags_ix
1491         B::BM::USEFUL = PVBM_useful_ix
1492         B::BM::PREVIOUS = PVBM_previous_ix
1493         B::BM::RARE = PVBM_rare_ix
1494         B::IO::LINES =  PVIO_lines_ix
1495         B::IO::PAGE = PVIO_page_ix
1496         B::IO::PAGE_LEN = PVIO_page_len_ix
1497         B::IO::LINES_LEFT = PVIO_lines_left_ix
1498         B::IO::TOP_NAME = PVIO_top_name_ix
1499         B::IO::TOP_GV = PVIO_top_gv_ix
1500         B::IO::FMT_NAME = PVIO_fmt_name_ix
1501         B::IO::FMT_GV = PVIO_fmt_gv_ix
1502         B::IO::BOTTOM_NAME = PVIO_bottom_name_ix
1503         B::IO::BOTTOM_GV = PVIO_bottom_gv_ix
1504         B::IO::IoTYPE = PVIO_type_ix
1505         B::IO::IoFLAGS = PVIO_flags_ix
1506         B::AV::MAX = PVAV_max_ix
1507         B::FM::LINES = PVFM_lines_ix
1508         B::CV::STASH = PVCV_stash_ix
1509         B::CV::GV = PVCV_gv_ix
1510         B::CV::FILE = PVCV_file_ix
1511         B::CV::DEPTH = PVCV_depth_ix
1512         B::CV::PADLIST = PVCV_padlist_ix
1513         B::CV::OUTSIDE = PVCV_outside_ix
1514         B::CV::OUTSIDE_SEQ = PVCV_outside_seq_ix
1515         B::CV::CvFLAGS = PVCV_flags_ix
1516         B::HV::MAX = PVHV_max_ix
1517         B::HV::KEYS = PVHV_keys_ix
1518     PREINIT:
1519         char *ptr;
1520         SV *ret;
1521     PPCODE:
1522         ptr = (ix & 0xFFFF) + (char *)SvANY(sv);
1523         switch ((U8)(ix >> 16)) {
1524         case (U8)(sv_SVp >> 16):
1525             ret = make_sv_object(aTHX_ *((SV **)ptr));
1526             break;
1527         case (U8)(sv_IVp >> 16):
1528             ret = sv_2mortal(newSViv(*((IV *)ptr)));
1529             break;
1530         case (U8)(sv_UVp >> 16):
1531             ret = sv_2mortal(newSVuv(*((UV *)ptr)));
1532             break;
1533         case (U8)(sv_STRLENp >> 16):
1534             ret = sv_2mortal(newSVuv(*((STRLEN *)ptr)));
1535             break;
1536         case (U8)(sv_U32p >> 16):
1537             ret = sv_2mortal(newSVuv(*((U32 *)ptr)));
1538             break;
1539         case (U8)(sv_U8p >> 16):
1540             ret = sv_2mortal(newSVuv(*((U8 *)ptr)));
1541             break;
1542         case (U8)(sv_char_pp >> 16):
1543             ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
1544             break;
1545         case (U8)(sv_NVp >> 16):
1546             ret = sv_2mortal(newSVnv(*((NV *)ptr)));
1547             break;
1548         case (U8)(sv_char_p >> 16):
1549             ret = newSVpvn_flags((char *)ptr, 1, SVs_TEMP);
1550             break;
1551         case (U8)(sv_SSize_tp >> 16):
1552             ret = sv_2mortal(newSViv(*((SSize_t *)ptr)));
1553             break;
1554         case (U8)(sv_I32p >> 16):
1555             ret = sv_2mortal(newSVuv(*((I32 *)ptr)));
1556             break;
1557         case (U8)(sv_U16p >> 16):
1558             ret = sv_2mortal(newSVuv(*((U16 *)ptr)));
1559             break;
1560         default:
1561             croak("Illegal alias 0x%08x for B::*IVX", (unsigned)ix);
1562         }
1563         ST(0) = ret;
1564         XSRETURN(1);
1565
1566 void
1567 packiv(sv)
1568         B::IV   sv
1569     ALIAS:
1570         needs64bits = 1
1571     CODE:
1572         if (ix) {
1573             ST(0) = boolSV((I32)SvIVX(sv) != SvIVX(sv));
1574         } else if (sizeof(IV) == 8) {
1575             U32 wp[2];
1576             const IV iv = SvIVX(sv);
1577             /*
1578              * The following way of spelling 32 is to stop compilers on
1579              * 32-bit architectures from moaning about the shift count
1580              * being >= the width of the type. Such architectures don't
1581              * reach this code anyway (unless sizeof(IV) > 8 but then
1582              * everything else breaks too so I'm not fussed at the moment).
1583              */
1584 #ifdef UV_IS_QUAD
1585             wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1586 #else
1587             wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1588 #endif
1589             wp[1] = htonl(iv & 0xffffffff);
1590             ST(0) = newSVpvn_flags((char *)wp, 8, SVs_TEMP);
1591         } else {
1592             U32 w = htonl((U32)SvIVX(sv));
1593             ST(0) = newSVpvn_flags((char *)&w, 4, SVs_TEMP);
1594         }
1595
1596 MODULE = B      PACKAGE = B::NV         PREFIX = Sv
1597
1598 NV
1599 SvNV(sv)
1600         B::NV   sv
1601
1602 #if PERL_VERSION < 11
1603
1604 MODULE = B      PACKAGE = B::RV         PREFIX = Sv
1605
1606 void
1607 SvRV(sv)
1608         B::RV   sv
1609     PPCODE:
1610         PUSHs(make_sv_object(aTHX_ SvRV(sv)));
1611
1612 #else
1613
1614 MODULE = B      PACKAGE = B::REGEXP
1615
1616 void
1617 REGEX(sv)
1618         B::REGEXP       sv
1619     ALIAS:
1620         precomp = 1
1621     PPCODE:
1622         if (ix) {
1623             PUSHs(newSVpvn_flags(RX_PRECOMP(sv), RX_PRELEN(sv), SVs_TEMP));
1624         } else {
1625             dXSTARG;
1626             /* FIXME - can we code this method more efficiently?  */
1627             PUSHi(PTR2IV(sv));
1628         }
1629
1630 #endif
1631
1632 MODULE = B      PACKAGE = B::PV
1633
1634 void
1635 RV(sv)
1636         B::PV   sv
1637     PPCODE:
1638         if (!SvROK(sv))
1639             croak( "argument is not SvROK" );
1640         PUSHs(make_sv_object(aTHX_ SvRV(sv)));
1641
1642 void
1643 PV(sv)
1644         B::PV   sv
1645     ALIAS:
1646         PVX = 1
1647         PVBM = 2
1648         B::BM::TABLE = 3
1649     PREINIT:
1650         const char *p;
1651         STRLEN len = 0;
1652         U32 utf8 = 0;
1653     CODE:
1654         if (ix == 3) {
1655 #ifndef PERL_FBM_TABLE_OFFSET
1656             const MAGIC *const mg = mg_find(sv, PERL_MAGIC_bm);
1657
1658             if (!mg)
1659                 croak("argument to B::BM::TABLE is not a PVBM");
1660             p = mg->mg_ptr;
1661             len = mg->mg_len;
1662 #else
1663             p = SvPV(sv, len);
1664             /* Boyer-Moore table is just after string and its safety-margin \0 */
1665             p += len + PERL_FBM_TABLE_OFFSET;
1666             len = 256;
1667 #endif
1668         } else if (ix == 2) {
1669             /* This used to read 257. I think that that was buggy - should have
1670                been 258. (The "\0", the flags byte, and 256 for the table.)
1671                The only user of this method is B::Bytecode in B::PV::bsave.
1672                I'm guessing that nothing tested the runtime correctness of
1673                output of bytecompiled string constant arguments to index (etc).
1674
1675                Note the start pointer is and has always been SvPVX(sv), not
1676                SvPVX(sv) + SvCUR(sv) PVBM was added in 651aa52ea1faa806, and
1677                first used by the compiler in 651aa52ea1faa806. It's used to
1678                get a "complete" dump of the buffer at SvPVX(), not just the
1679                PVBM table. This permits the generated bytecode to "load"
1680                SvPVX in "one" hit.
1681
1682                5.15 and later store the BM table via MAGIC, so the compiler
1683                should handle this just fine without changes if PVBM now
1684                always returns the SvPVX() buffer.  */
1685             p = SvPVX_const(sv);
1686 #ifdef PERL_FBM_TABLE_OFFSET
1687             len = SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0);
1688 #else
1689             len = SvCUR(sv);
1690 #endif
1691         } else if (ix) {
1692             p = SvPVX(sv);
1693             len = strlen(p);
1694         } else if (SvPOK(sv)) {
1695             len = SvCUR(sv);
1696             p = SvPVX_const(sv);
1697             utf8 = SvUTF8(sv);
1698 #if PERL_VERSION < 10
1699             /* Before 5.10 (well 931b58fb28fa5ca7), PAD_COMPNAME_GEN was stored
1700                in SvCUR(), which meant we had to attempt this special casing
1701                to avoid tripping up over variable names in the pads.  */
1702             if((SvLEN(sv) && len >= SvLEN(sv))) {
1703                 /* It claims to be longer than the space allocated for it -
1704                    presumably it's a variable name in the pad  */
1705                 len = strlen(p);
1706             }
1707 #endif
1708         }
1709         else {
1710             /* XXX for backward compatibility, but should fail */
1711             /* croak( "argument is not SvPOK" ); */
1712             p = NULL;
1713         }
1714         ST(0) = newSVpvn_flags(p, len, SVs_TEMP | utf8);
1715
1716 MODULE = B      PACKAGE = B::PVMG
1717
1718 void
1719 MAGIC(sv)
1720         B::PVMG sv
1721         MAGIC * mg = NO_INIT
1722     PPCODE:
1723         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
1724             XPUSHs(make_mg_object(aTHX_ mg));
1725
1726 MODULE = B      PACKAGE = B::MAGIC
1727
1728 void
1729 MOREMAGIC(mg)
1730         B::MAGIC        mg
1731     ALIAS:
1732         PRIVATE = 1
1733         TYPE = 2
1734         FLAGS = 3
1735         LENGTH = 4
1736         OBJ = 5
1737         PTR = 6
1738         REGEX = 7
1739         precomp = 8
1740     PPCODE:
1741         switch (ix) {
1742         case 0:
1743             XPUSHs(mg->mg_moremagic ? make_mg_object(aTHX_ mg->mg_moremagic)
1744                                     : &PL_sv_undef);
1745             break;
1746         case 1:
1747             mPUSHu(mg->mg_private);
1748             break;
1749         case 2:
1750             PUSHs(newSVpvn_flags(&(mg->mg_type), 1, SVs_TEMP));
1751             break;
1752         case 3:
1753             mPUSHu(mg->mg_flags);
1754             break;
1755         case 4:
1756             mPUSHi(mg->mg_len);
1757             break;
1758         case 5:
1759             PUSHs(make_sv_object(aTHX_ mg->mg_obj));
1760             break;
1761         case 6:
1762             if (mg->mg_ptr) {
1763                 if (mg->mg_len >= 0) {
1764                     PUSHs(newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP));
1765                 } else if (mg->mg_len == HEf_SVKEY) {
1766                     PUSHs(make_sv_object(aTHX_ (SV*)mg->mg_ptr));
1767                 } else
1768                     PUSHs(sv_newmortal());
1769             } else
1770                 PUSHs(sv_newmortal());
1771             break;
1772         case 7:
1773             if(mg->mg_type == PERL_MAGIC_qr) {
1774                 mPUSHi(PTR2IV(mg->mg_obj));
1775             } else {
1776                 croak("REGEX is only meaningful on r-magic");
1777             }
1778             break;
1779         case 8:
1780             if (mg->mg_type == PERL_MAGIC_qr) {
1781                 REGEXP *rx = (REGEXP *)mg->mg_obj;
1782                 PUSHs(newSVpvn_flags(rx ? RX_PRECOMP(rx) : NULL,
1783                                      rx ? RX_PRELEN(rx) : 0, SVs_TEMP));
1784             } else {
1785                 croak( "precomp is only meaningful on r-magic" );
1786             }
1787             break;
1788         }
1789
1790 MODULE = B      PACKAGE = B::GV         PREFIX = Gv
1791
1792 void
1793 GvNAME(gv)
1794         B::GV   gv
1795     ALIAS:
1796         FILE = 1
1797         B::HV::NAME = 2
1798     CODE:
1799 #if PERL_VERSION >= 10
1800         ST(0) = sv_2mortal(newSVhek(!ix ? GvNAME_HEK(gv)
1801                                         : (ix == 1 ? GvFILE_HEK(gv)
1802                                                    : HvNAME_HEK((HV *)gv))));
1803 #else
1804         ST(0) = !ix ? newSVpvn_flags(GvNAME(gv), GvNAMELEN(gv), SVs_TEMP)
1805                     : sv_2mortal(newSVpv(ix == 1 ? GvFILE(gv) : HvNAME((HV *)gv), 0))
1806 #endif
1807
1808 bool
1809 is_empty(gv)
1810         B::GV   gv
1811     ALIAS:
1812         isGV_with_GP = 1
1813     CODE:
1814         if (ix) {
1815 #if PERL_VERSION >= 9
1816             RETVAL = isGV_with_GP(gv) ? TRUE : FALSE;
1817 #else
1818             RETVAL = TRUE; /* In 5.8 and earlier they all are.  */
1819 #endif
1820         } else {
1821             RETVAL = GvGP(gv) == Null(GP*);
1822         }
1823     OUTPUT:
1824         RETVAL
1825
1826 void*
1827 GvGP(gv)
1828         B::GV   gv
1829
1830 #define GP_sv_ix        SVp | offsetof(struct gp, gp_sv)
1831 #define GP_io_ix        SVp | offsetof(struct gp, gp_io)
1832 #define GP_cv_ix        SVp | offsetof(struct gp, gp_cv)
1833 #define GP_cvgen_ix     U32p | offsetof(struct gp, gp_cvgen)
1834 #define GP_refcnt_ix    U32p | offsetof(struct gp, gp_refcnt)
1835 #define GP_hv_ix        SVp | offsetof(struct gp, gp_hv)
1836 #define GP_av_ix        SVp | offsetof(struct gp, gp_av)
1837 #define GP_form_ix      SVp | offsetof(struct gp, gp_form)
1838 #define GP_egv_ix       SVp | offsetof(struct gp, gp_egv)
1839 #define GP_line_ix      line_tp | offsetof(struct gp, gp_line)
1840
1841 void
1842 SV(gv)
1843         B::GV   gv
1844     ALIAS:
1845         SV = GP_sv_ix
1846         IO = GP_io_ix
1847         CV = GP_cv_ix
1848         CVGEN = GP_cvgen_ix
1849         GvREFCNT = GP_refcnt_ix
1850         HV = GP_hv_ix
1851         AV = GP_av_ix
1852         FORM = GP_form_ix
1853         EGV = GP_egv_ix
1854         LINE = GP_line_ix
1855     PREINIT:
1856         GP *gp;
1857         char *ptr;
1858         SV *ret;
1859     PPCODE:
1860         gp = GvGP(gv);
1861         if (!gp) {
1862             const GV *const gv = CvGV(cv);
1863             Perl_croak(aTHX_ "NULL gp in B::GV::%s", gv ? GvNAME(gv) : "???");
1864         }
1865         ptr = (ix & 0xFFFF) + (char *)gp;
1866         switch ((U8)(ix >> 16)) {
1867         case (U8)(SVp >> 16):
1868             ret = make_sv_object(aTHX_ *((SV **)ptr));
1869             break;
1870         case (U8)(U32p >> 16):
1871             ret = sv_2mortal(newSVuv(*((U32*)ptr)));
1872             break;
1873         case (U8)(line_tp >> 16):
1874             ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
1875             break;
1876         default:
1877             croak("Illegal alias 0x%08x for B::*SV", (unsigned)ix);
1878         }
1879         ST(0) = ret;
1880         XSRETURN(1);
1881
1882 void
1883 FILEGV(gv)
1884         B::GV   gv
1885     PPCODE:
1886         PUSHs(make_sv_object(aTHX_ (SV *)GvFILEGV(gv)));
1887
1888 MODULE = B      PACKAGE = B::IO         PREFIX = Io
1889
1890 #if PERL_VERSION <= 8
1891
1892 short
1893 IoSUBPROCESS(io)
1894         B::IO   io
1895
1896 #endif
1897
1898 bool
1899 IsSTD(io,name)
1900         B::IO   io
1901         const char*     name
1902     PREINIT:
1903         PerlIO* handle = 0;
1904     CODE:
1905         if( strEQ( name, "stdin" ) ) {
1906             handle = PerlIO_stdin();
1907         }
1908         else if( strEQ( name, "stdout" ) ) {
1909             handle = PerlIO_stdout();
1910         }
1911         else if( strEQ( name, "stderr" ) ) {
1912             handle = PerlIO_stderr();
1913         }
1914         else {
1915             croak( "Invalid value '%s'", name );
1916         }
1917         RETVAL = handle == IoIFP(io);
1918     OUTPUT:
1919         RETVAL
1920
1921 MODULE = B      PACKAGE = B::AV         PREFIX = Av
1922
1923 SSize_t
1924 AvFILL(av)
1925         B::AV   av
1926
1927 void
1928 AvARRAY(av)
1929         B::AV   av
1930     PPCODE:
1931         if (AvFILL(av) >= 0) {
1932             SV **svp = AvARRAY(av);
1933             I32 i;
1934             for (i = 0; i <= AvFILL(av); i++)
1935                 XPUSHs(make_sv_object(aTHX_ svp[i]));
1936         }
1937
1938 void
1939 AvARRAYelt(av, idx)
1940         B::AV   av
1941         int     idx
1942     PPCODE:
1943         if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
1944             XPUSHs(make_sv_object(aTHX_ (AvARRAY(av)[idx])));
1945         else
1946             XPUSHs(make_sv_object(aTHX_ NULL));
1947
1948 #if PERL_VERSION < 9
1949                                    
1950 #define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1951
1952 IV
1953 AvOFF(av)
1954         B::AV   av
1955
1956 MODULE = B      PACKAGE = B::AV
1957
1958 U8
1959 AvFLAGS(av)
1960         B::AV   av
1961
1962 #endif
1963
1964 MODULE = B      PACKAGE = B::CV         PREFIX = Cv
1965
1966 U32
1967 CvCONST(cv)
1968         B::CV   cv
1969
1970 void
1971 CvSTART(cv)
1972         B::CV   cv
1973     ALIAS:
1974         ROOT = 1
1975     PPCODE:
1976         PUSHs(make_op_object(aTHX_ CvISXSUB(cv) ? NULL
1977                              : ix ? CvROOT(cv) : CvSTART(cv)));
1978
1979 void
1980 CvXSUB(cv)
1981         B::CV   cv
1982     ALIAS:
1983         XSUBANY = 1
1984     CODE:
1985         ST(0) = ix && CvCONST(cv)
1986             ? make_sv_object(aTHX_ (SV *)CvXSUBANY(cv).any_ptr)
1987             : sv_2mortal(newSViv(CvISXSUB(cv)
1988                                  ? (ix ? CvXSUBANY(cv).any_iv
1989                                        : PTR2IV(CvXSUB(cv)))
1990                                  : 0));
1991
1992 void
1993 const_sv(cv)
1994         B::CV   cv
1995     PPCODE:
1996         PUSHs(make_sv_object(aTHX_ (SV *)cv_const_sv(cv)));
1997
1998 MODULE = B      PACKAGE = B::HV         PREFIX = Hv
1999
2000 STRLEN
2001 HvFILL(hv)
2002         B::HV   hv
2003
2004 I32
2005 HvRITER(hv)
2006         B::HV   hv
2007
2008 #if PERL_VERSION < 9
2009
2010 B::PMOP
2011 HvPMROOT(hv)
2012         B::HV   hv
2013     PPCODE:
2014         PUSHs(make_op_object(aTHX_ HvPMROOT(hv)));
2015
2016 #endif
2017
2018 void
2019 HvARRAY(hv)
2020         B::HV   hv
2021     PPCODE:
2022         if (HvUSEDKEYS(hv) > 0) {
2023             SV *sv;
2024             char *key;
2025             I32 len;
2026             (void)hv_iterinit(hv);
2027             EXTEND(sp, HvUSEDKEYS(hv) * 2);
2028             while ((sv = hv_iternextsv(hv, &key, &len))) {
2029                 mPUSHp(key, len);
2030                 PUSHs(make_sv_object(aTHX_ sv));
2031             }
2032         }
2033
2034 MODULE = B      PACKAGE = B::HE         PREFIX = He
2035
2036 void
2037 HeVAL(he)
2038         B::HE he
2039     ALIAS:
2040         SVKEY_force = 1
2041     PPCODE:
2042         PUSHs(make_sv_object(aTHX_ ix ? HeSVKEY_force(he) : HeVAL(he)));
2043
2044 U32
2045 HeHASH(he)
2046         B::HE he
2047
2048 MODULE = B      PACKAGE = B::RHE
2049
2050 #if PERL_VERSION >= 9
2051
2052 SV*
2053 HASH(h)
2054         B::RHE h
2055     CODE:
2056         RETVAL = newRV( (SV*)cophh_2hv(h, 0) );
2057     OUTPUT:
2058         RETVAL
2059
2060 #endif