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