This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
69c4aaed7b373b9ba421cc835f587b4aab7dd1de
[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 #define PVCV_gv_ix      sv_SVp | offsetof(struct xpvcv, xcv_gv)
1456 #define PVCV_file_ix    sv_char_pp | offsetof(struct xpvcv, xcv_file)
1457 #define PVCV_outside_ix sv_SVp | offsetof(struct xpvcv, xcv_outside)
1458 #define PVCV_outside_seq_ix sv_U32p | offsetof(struct xpvcv, xcv_outside_seq)
1459 #define PVCV_flags_ix   sv_U16p | offsetof(struct xpvcv, xcv_flags)
1460
1461 #define PVHV_max_ix     sv_STRLENp | offsetof(struct xpvhv, xhv_max)
1462
1463 #if PERL_VERSION > 12
1464 #define PVHV_keys_ix    sv_STRLENp | offsetof(struct xpvhv, xhv_keys)
1465 #else
1466 #define PVHV_keys_ix    sv_IVp | offsetof(struct xpvhv, xhv_keys)
1467 #endif
1468
1469 # The type checking code in B has always been identical for all SV types,
1470 # irrespective of whether the action is actually defined on that SV.
1471 # We should fix this
1472 void
1473 IVX(sv)
1474         B::SV           sv
1475     ALIAS:
1476         B::IV::IVX = IV_ivx_ix
1477         B::IV::UVX = IV_uvx_ix
1478         B::NV::NVX = NV_nvx_ix
1479         B::NV::COP_SEQ_RANGE_LOW = NV_cop_seq_range_low_ix
1480         B::NV::COP_SEQ_RANGE_HIGH = NV_cop_seq_range_high_ix
1481         B::NV::PARENT_PAD_INDEX = NV_parent_pad_index_ix
1482         B::NV::PARENT_FAKELEX_FLAGS = NV_parent_fakelex_flags_ix
1483         B::PV::CUR = PV_cur_ix
1484         B::PV::LEN = PV_len_ix
1485         B::PVMG::SvSTASH = PVMG_stash_ix
1486         B::PVLV::TARGOFF = PVLV_targoff_ix
1487         B::PVLV::TARGLEN = PVLV_targlen_ix
1488         B::PVLV::TARG = PVLV_targ_ix
1489         B::PVLV::TYPE = PVLV_type_ix
1490         B::GV::STASH = PVGV_stash_ix
1491         B::GV::GvFLAGS = PVGV_flags_ix
1492         B::BM::USEFUL = PVBM_useful_ix
1493         B::BM::PREVIOUS = PVBM_previous_ix
1494         B::BM::RARE = PVBM_rare_ix
1495         B::IO::LINES =  PVIO_lines_ix
1496         B::IO::PAGE = PVIO_page_ix
1497         B::IO::PAGE_LEN = PVIO_page_len_ix
1498         B::IO::LINES_LEFT = PVIO_lines_left_ix
1499         B::IO::TOP_NAME = PVIO_top_name_ix
1500         B::IO::TOP_GV = PVIO_top_gv_ix
1501         B::IO::FMT_NAME = PVIO_fmt_name_ix
1502         B::IO::FMT_GV = PVIO_fmt_gv_ix
1503         B::IO::BOTTOM_NAME = PVIO_bottom_name_ix
1504         B::IO::BOTTOM_GV = PVIO_bottom_gv_ix
1505         B::IO::IoTYPE = PVIO_type_ix
1506         B::IO::IoFLAGS = PVIO_flags_ix
1507         B::AV::MAX = PVAV_max_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::OUTSIDE = PVCV_outside_ix
1512         B::CV::OUTSIDE_SEQ = PVCV_outside_seq_ix
1513         B::CV::CvFLAGS = PVCV_flags_ix
1514         B::HV::MAX = PVHV_max_ix
1515         B::HV::KEYS = PVHV_keys_ix
1516     PREINIT:
1517         char *ptr;
1518         SV *ret;
1519     PPCODE:
1520         ptr = (ix & 0xFFFF) + (char *)SvANY(sv);
1521         switch ((U8)(ix >> 16)) {
1522         case (U8)(sv_SVp >> 16):
1523             ret = make_sv_object(aTHX_ *((SV **)ptr));
1524             break;
1525         case (U8)(sv_IVp >> 16):
1526             ret = sv_2mortal(newSViv(*((IV *)ptr)));
1527             break;
1528         case (U8)(sv_UVp >> 16):
1529             ret = sv_2mortal(newSVuv(*((UV *)ptr)));
1530             break;
1531         case (U8)(sv_STRLENp >> 16):
1532             ret = sv_2mortal(newSVuv(*((STRLEN *)ptr)));
1533             break;
1534         case (U8)(sv_U32p >> 16):
1535             ret = sv_2mortal(newSVuv(*((U32 *)ptr)));
1536             break;
1537         case (U8)(sv_U8p >> 16):
1538             ret = sv_2mortal(newSVuv(*((U8 *)ptr)));
1539             break;
1540         case (U8)(sv_char_pp >> 16):
1541             ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
1542             break;
1543         case (U8)(sv_NVp >> 16):
1544             ret = sv_2mortal(newSVnv(*((NV *)ptr)));
1545             break;
1546         case (U8)(sv_char_p >> 16):
1547             ret = newSVpvn_flags((char *)ptr, 1, SVs_TEMP);
1548             break;
1549         case (U8)(sv_SSize_tp >> 16):
1550             ret = sv_2mortal(newSViv(*((SSize_t *)ptr)));
1551             break;
1552         case (U8)(sv_I32p >> 16):
1553             ret = sv_2mortal(newSVuv(*((I32 *)ptr)));
1554             break;
1555         case (U8)(sv_U16p >> 16):
1556             ret = sv_2mortal(newSVuv(*((U16 *)ptr)));
1557             break;
1558         default:
1559             croak("Illegal alias 0x%08x for B::*IVX", (unsigned)ix);
1560         }
1561         ST(0) = ret;
1562         XSRETURN(1);
1563
1564 void
1565 packiv(sv)
1566         B::IV   sv
1567     ALIAS:
1568         needs64bits = 1
1569     CODE:
1570         if (ix) {
1571             ST(0) = boolSV((I32)SvIVX(sv) != SvIVX(sv));
1572         } else if (sizeof(IV) == 8) {
1573             U32 wp[2];
1574             const IV iv = SvIVX(sv);
1575             /*
1576              * The following way of spelling 32 is to stop compilers on
1577              * 32-bit architectures from moaning about the shift count
1578              * being >= the width of the type. Such architectures don't
1579              * reach this code anyway (unless sizeof(IV) > 8 but then
1580              * everything else breaks too so I'm not fussed at the moment).
1581              */
1582 #ifdef UV_IS_QUAD
1583             wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1584 #else
1585             wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1586 #endif
1587             wp[1] = htonl(iv & 0xffffffff);
1588             ST(0) = newSVpvn_flags((char *)wp, 8, SVs_TEMP);
1589         } else {
1590             U32 w = htonl((U32)SvIVX(sv));
1591             ST(0) = newSVpvn_flags((char *)&w, 4, SVs_TEMP);
1592         }
1593
1594 MODULE = B      PACKAGE = B::NV         PREFIX = Sv
1595
1596 NV
1597 SvNV(sv)
1598         B::NV   sv
1599
1600 #if PERL_VERSION < 11
1601
1602 MODULE = B      PACKAGE = B::RV         PREFIX = Sv
1603
1604 void
1605 SvRV(sv)
1606         B::RV   sv
1607     PPCODE:
1608         PUSHs(make_sv_object(aTHX_ SvRV(sv)));
1609
1610 #else
1611
1612 MODULE = B      PACKAGE = B::REGEXP
1613
1614 void
1615 REGEX(sv)
1616         B::REGEXP       sv
1617     ALIAS:
1618         precomp = 1
1619     PPCODE:
1620         if (ix) {
1621             PUSHs(newSVpvn_flags(RX_PRECOMP(sv), RX_PRELEN(sv), SVs_TEMP));
1622         } else {
1623             dXSTARG;
1624             /* FIXME - can we code this method more efficiently?  */
1625             PUSHi(PTR2IV(sv));
1626         }
1627
1628 #endif
1629
1630 MODULE = B      PACKAGE = B::PV
1631
1632 void
1633 RV(sv)
1634         B::PV   sv
1635     PPCODE:
1636         if (!SvROK(sv))
1637             croak( "argument is not SvROK" );
1638         PUSHs(make_sv_object(aTHX_ SvRV(sv)));
1639
1640 void
1641 PV(sv)
1642         B::PV   sv
1643     ALIAS:
1644         PVX = 1
1645         PVBM = 2
1646         B::BM::TABLE = 3
1647     PREINIT:
1648         const char *p;
1649         STRLEN len = 0;
1650         U32 utf8 = 0;
1651     CODE:
1652         if (ix == 3) {
1653 #ifndef PERL_FBM_TABLE_OFFSET
1654             const MAGIC *const mg = mg_find(sv, PERL_MAGIC_bm);
1655
1656             if (!mg)
1657                 croak("argument to B::BM::TABLE is not a PVBM");
1658             p = mg->mg_ptr;
1659             len = mg->mg_len;
1660 #else
1661             p = SvPV(sv, len);
1662             /* Boyer-Moore table is just after string and its safety-margin \0 */
1663             p += len + PERL_FBM_TABLE_OFFSET;
1664             len = 256;
1665 #endif
1666         } else if (ix == 2) {
1667             /* This used to read 257. I think that that was buggy - should have
1668                been 258. (The "\0", the flags byte, and 256 for the table.)
1669                The only user of this method is B::Bytecode in B::PV::bsave.
1670                I'm guessing that nothing tested the runtime correctness of
1671                output of bytecompiled string constant arguments to index (etc).
1672
1673                Note the start pointer is and has always been SvPVX(sv), not
1674                SvPVX(sv) + SvCUR(sv) PVBM was added in 651aa52ea1faa806, and
1675                first used by the compiler in 651aa52ea1faa806. It's used to
1676                get a "complete" dump of the buffer at SvPVX(), not just the
1677                PVBM table. This permits the generated bytecode to "load"
1678                SvPVX in "one" hit.
1679
1680                5.15 and later store the BM table via MAGIC, so the compiler
1681                should handle this just fine without changes if PVBM now
1682                always returns the SvPVX() buffer.  */
1683             p = SvPVX_const(sv);
1684 #ifdef PERL_FBM_TABLE_OFFSET
1685             len = SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0);
1686 #else
1687             len = SvCUR(sv);
1688 #endif
1689         } else if (ix) {
1690             p = SvPVX(sv);
1691             len = strlen(p);
1692         } else if (SvPOK(sv)) {
1693             len = SvCUR(sv);
1694             p = SvPVX_const(sv);
1695             utf8 = SvUTF8(sv);
1696 #if PERL_VERSION < 10
1697             /* Before 5.10 (well 931b58fb28fa5ca7), PAD_COMPNAME_GEN was stored
1698                in SvCUR(), which meant we had to attempt this special casing
1699                to avoid tripping up over variable names in the pads.  */
1700             if((SvLEN(sv) && len >= SvLEN(sv))) {
1701                 /* It claims to be longer than the space allocated for it -
1702                    presumably it's a variable name in the pad  */
1703                 len = strlen(p);
1704             }
1705 #endif
1706         }
1707         else {
1708             /* XXX for backward compatibility, but should fail */
1709             /* croak( "argument is not SvPOK" ); */
1710             p = NULL;
1711         }
1712         ST(0) = newSVpvn_flags(p, len, SVs_TEMP | utf8);
1713
1714 MODULE = B      PACKAGE = B::PVMG
1715
1716 void
1717 MAGIC(sv)
1718         B::PVMG sv
1719         MAGIC * mg = NO_INIT
1720     PPCODE:
1721         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
1722             XPUSHs(make_mg_object(aTHX_ mg));
1723
1724 MODULE = B      PACKAGE = B::MAGIC
1725
1726 void
1727 MOREMAGIC(mg)
1728         B::MAGIC        mg
1729     ALIAS:
1730         PRIVATE = 1
1731         TYPE = 2
1732         FLAGS = 3
1733         LENGTH = 4
1734         OBJ = 5
1735         PTR = 6
1736         REGEX = 7
1737         precomp = 8
1738     PPCODE:
1739         switch (ix) {
1740         case 0:
1741             XPUSHs(mg->mg_moremagic ? make_mg_object(aTHX_ mg->mg_moremagic)
1742                                     : &PL_sv_undef);
1743             break;
1744         case 1:
1745             mPUSHu(mg->mg_private);
1746             break;
1747         case 2:
1748             PUSHs(newSVpvn_flags(&(mg->mg_type), 1, SVs_TEMP));
1749             break;
1750         case 3:
1751             mPUSHu(mg->mg_flags);
1752             break;
1753         case 4:
1754             mPUSHi(mg->mg_len);
1755             break;
1756         case 5:
1757             PUSHs(make_sv_object(aTHX_ mg->mg_obj));
1758             break;
1759         case 6:
1760             if (mg->mg_ptr) {
1761                 if (mg->mg_len >= 0) {
1762                     PUSHs(newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP));
1763                 } else if (mg->mg_len == HEf_SVKEY) {
1764                     PUSHs(make_sv_object(aTHX_ (SV*)mg->mg_ptr));
1765                 } else
1766                     PUSHs(sv_newmortal());
1767             } else
1768                 PUSHs(sv_newmortal());
1769             break;
1770         case 7:
1771             if(mg->mg_type == PERL_MAGIC_qr) {
1772                 mPUSHi(PTR2IV(mg->mg_obj));
1773             } else {
1774                 croak("REGEX is only meaningful on r-magic");
1775             }
1776             break;
1777         case 8:
1778             if (mg->mg_type == PERL_MAGIC_qr) {
1779                 REGEXP *rx = (REGEXP *)mg->mg_obj;
1780                 PUSHs(newSVpvn_flags(rx ? RX_PRECOMP(rx) : NULL,
1781                                      rx ? RX_PRELEN(rx) : 0, SVs_TEMP));
1782             } else {
1783                 croak( "precomp is only meaningful on r-magic" );
1784             }
1785             break;
1786         }
1787
1788 MODULE = B      PACKAGE = B::GV         PREFIX = Gv
1789
1790 void
1791 GvNAME(gv)
1792         B::GV   gv
1793     ALIAS:
1794         FILE = 1
1795         B::HV::NAME = 2
1796     CODE:
1797 #if PERL_VERSION >= 10
1798         ST(0) = sv_2mortal(newSVhek(!ix ? GvNAME_HEK(gv)
1799                                         : (ix == 1 ? GvFILE_HEK(gv)
1800                                                    : HvNAME_HEK((HV *)gv))));
1801 #else
1802         ST(0) = !ix ? newSVpvn_flags(GvNAME(gv), GvNAMELEN(gv), SVs_TEMP)
1803                     : sv_2mortal(newSVpv(ix == 1 ? GvFILE(gv) : HvNAME((HV *)gv), 0))
1804 #endif
1805
1806 bool
1807 is_empty(gv)
1808         B::GV   gv
1809     ALIAS:
1810         isGV_with_GP = 1
1811     CODE:
1812         if (ix) {
1813 #if PERL_VERSION >= 9
1814             RETVAL = isGV_with_GP(gv) ? TRUE : FALSE;
1815 #else
1816             RETVAL = TRUE; /* In 5.8 and earlier they all are.  */
1817 #endif
1818         } else {
1819             RETVAL = GvGP(gv) == Null(GP*);
1820         }
1821     OUTPUT:
1822         RETVAL
1823
1824 void*
1825 GvGP(gv)
1826         B::GV   gv
1827
1828 #define GP_sv_ix        SVp | offsetof(struct gp, gp_sv)
1829 #define GP_io_ix        SVp | offsetof(struct gp, gp_io)
1830 #define GP_cv_ix        SVp | offsetof(struct gp, gp_cv)
1831 #define GP_cvgen_ix     U32p | offsetof(struct gp, gp_cvgen)
1832 #define GP_refcnt_ix    U32p | offsetof(struct gp, gp_refcnt)
1833 #define GP_hv_ix        SVp | offsetof(struct gp, gp_hv)
1834 #define GP_av_ix        SVp | offsetof(struct gp, gp_av)
1835 #define GP_form_ix      SVp | offsetof(struct gp, gp_form)
1836 #define GP_egv_ix       SVp | offsetof(struct gp, gp_egv)
1837 #define GP_line_ix      line_tp | offsetof(struct gp, gp_line)
1838
1839 void
1840 SV(gv)
1841         B::GV   gv
1842     ALIAS:
1843         SV = GP_sv_ix
1844         IO = GP_io_ix
1845         CV = GP_cv_ix
1846         CVGEN = GP_cvgen_ix
1847         GvREFCNT = GP_refcnt_ix
1848         HV = GP_hv_ix
1849         AV = GP_av_ix
1850         FORM = GP_form_ix
1851         EGV = GP_egv_ix
1852         LINE = GP_line_ix
1853     PREINIT:
1854         GP *gp;
1855         char *ptr;
1856         SV *ret;
1857     PPCODE:
1858         gp = GvGP(gv);
1859         if (!gp) {
1860             const GV *const gv = CvGV(cv);
1861             Perl_croak(aTHX_ "NULL gp in B::GV::%s", gv ? GvNAME(gv) : "???");
1862         }
1863         ptr = (ix & 0xFFFF) + (char *)gp;
1864         switch ((U8)(ix >> 16)) {
1865         case (U8)(SVp >> 16):
1866             ret = make_sv_object(aTHX_ *((SV **)ptr));
1867             break;
1868         case (U8)(U32p >> 16):
1869             ret = sv_2mortal(newSVuv(*((U32*)ptr)));
1870             break;
1871         case (U8)(line_tp >> 16):
1872             ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
1873             break;
1874         default:
1875             croak("Illegal alias 0x%08x for B::*SV", (unsigned)ix);
1876         }
1877         ST(0) = ret;
1878         XSRETURN(1);
1879
1880 void
1881 FILEGV(gv)
1882         B::GV   gv
1883     PPCODE:
1884         PUSHs(make_sv_object(aTHX_ (SV *)GvFILEGV(gv)));
1885
1886 MODULE = B      PACKAGE = B::IO         PREFIX = Io
1887
1888 #if PERL_VERSION <= 8
1889
1890 short
1891 IoSUBPROCESS(io)
1892         B::IO   io
1893
1894 #endif
1895
1896 bool
1897 IsSTD(io,name)
1898         B::IO   io
1899         const char*     name
1900     PREINIT:
1901         PerlIO* handle = 0;
1902     CODE:
1903         if( strEQ( name, "stdin" ) ) {
1904             handle = PerlIO_stdin();
1905         }
1906         else if( strEQ( name, "stdout" ) ) {
1907             handle = PerlIO_stdout();
1908         }
1909         else if( strEQ( name, "stderr" ) ) {
1910             handle = PerlIO_stderr();
1911         }
1912         else {
1913             croak( "Invalid value '%s'", name );
1914         }
1915         RETVAL = handle == IoIFP(io);
1916     OUTPUT:
1917         RETVAL
1918
1919 MODULE = B      PACKAGE = B::AV         PREFIX = Av
1920
1921 SSize_t
1922 AvFILL(av)
1923         B::AV   av
1924
1925 void
1926 AvARRAY(av)
1927         B::AV   av
1928     PPCODE:
1929         if (AvFILL(av) >= 0) {
1930             SV **svp = AvARRAY(av);
1931             I32 i;
1932             for (i = 0; i <= AvFILL(av); i++)
1933                 XPUSHs(make_sv_object(aTHX_ svp[i]));
1934         }
1935
1936 void
1937 AvARRAYelt(av, idx)
1938         B::AV   av
1939         int     idx
1940     PPCODE:
1941         if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
1942             XPUSHs(make_sv_object(aTHX_ (AvARRAY(av)[idx])));
1943         else
1944             XPUSHs(make_sv_object(aTHX_ NULL));
1945
1946 #if PERL_VERSION < 9
1947                                    
1948 #define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1949
1950 IV
1951 AvOFF(av)
1952         B::AV   av
1953
1954 MODULE = B      PACKAGE = B::AV
1955
1956 U8
1957 AvFLAGS(av)
1958         B::AV   av
1959
1960 #endif
1961
1962 MODULE = B      PACKAGE = B::FM         PREFIX = Fm
1963
1964 #if PERL_VERSION > 7 || (PERL_VERSION == 7 && PERL_SUBVERSION >= 3)
1965 # undef FmLINES
1966 # define FmLINES(sv) 0
1967 #endif
1968
1969 IV
1970 FmLINES(form)
1971         B::FM   form
1972
1973 MODULE = B      PACKAGE = B::CV         PREFIX = Cv
1974
1975 U32
1976 CvCONST(cv)
1977         B::CV   cv
1978
1979 void
1980 CvSTART(cv)
1981         B::CV   cv
1982     ALIAS:
1983         ROOT = 1
1984     PPCODE:
1985         PUSHs(make_op_object(aTHX_ CvISXSUB(cv) ? NULL
1986                              : ix ? CvROOT(cv) : CvSTART(cv)));
1987
1988 I32
1989 CvDEPTH(cv)
1990         B::CV   cv
1991
1992 #ifdef PadlistARRAY
1993
1994 B::PADLIST
1995 CvPADLIST(cv)
1996         B::CV   cv
1997
1998 #else
1999
2000 B::AV
2001 CvPADLIST(cv)
2002         B::CV   cv
2003
2004 #endif
2005
2006 void
2007 CvXSUB(cv)
2008         B::CV   cv
2009     ALIAS:
2010         XSUBANY = 1
2011     CODE:
2012         ST(0) = ix && CvCONST(cv)
2013             ? make_sv_object(aTHX_ (SV *)CvXSUBANY(cv).any_ptr)
2014             : sv_2mortal(newSViv(CvISXSUB(cv)
2015                                  ? (ix ? CvXSUBANY(cv).any_iv
2016                                        : PTR2IV(CvXSUB(cv)))
2017                                  : 0));
2018
2019 void
2020 const_sv(cv)
2021         B::CV   cv
2022     PPCODE:
2023         PUSHs(make_sv_object(aTHX_ (SV *)cv_const_sv(cv)));
2024
2025 MODULE = B      PACKAGE = B::HV         PREFIX = Hv
2026
2027 STRLEN
2028 HvFILL(hv)
2029         B::HV   hv
2030
2031 I32
2032 HvRITER(hv)
2033         B::HV   hv
2034
2035 #if PERL_VERSION < 9
2036
2037 B::PMOP
2038 HvPMROOT(hv)
2039         B::HV   hv
2040     PPCODE:
2041         PUSHs(make_op_object(aTHX_ HvPMROOT(hv)));
2042
2043 #endif
2044
2045 void
2046 HvARRAY(hv)
2047         B::HV   hv
2048     PPCODE:
2049         if (HvUSEDKEYS(hv) > 0) {
2050             SV *sv;
2051             char *key;
2052             I32 len;
2053             (void)hv_iterinit(hv);
2054             EXTEND(sp, HvUSEDKEYS(hv) * 2);
2055             while ((sv = hv_iternextsv(hv, &key, &len))) {
2056                 mPUSHp(key, len);
2057                 PUSHs(make_sv_object(aTHX_ sv));
2058             }
2059         }
2060
2061 MODULE = B      PACKAGE = B::HE         PREFIX = He
2062
2063 void
2064 HeVAL(he)
2065         B::HE he
2066     ALIAS:
2067         SVKEY_force = 1
2068     PPCODE:
2069         PUSHs(make_sv_object(aTHX_ ix ? HeSVKEY_force(he) : HeVAL(he)));
2070
2071 U32
2072 HeHASH(he)
2073         B::HE he
2074
2075 MODULE = B      PACKAGE = B::RHE
2076
2077 #if PERL_VERSION >= 9
2078
2079 SV*
2080 HASH(h)
2081         B::RHE h
2082     CODE:
2083         RETVAL = newRV( (SV*)cophh_2hv(h, 0) );
2084     OUTPUT:
2085         RETVAL
2086
2087 #endif
2088
2089 #ifdef PadlistARRAY
2090
2091 MODULE = B      PACKAGE = B::PADLIST    PREFIX = Padlist
2092
2093 SSize_t
2094 PadlistMAX(padlist)
2095         B::PADLIST      padlist
2096
2097 void
2098 PadlistARRAY(padlist)
2099         B::PADLIST      padlist
2100     PPCODE:
2101         if (PadlistMAX(padlist) >= 0) {
2102             PAD **padp = PadlistARRAY(padlist);
2103             PADOFFSET i;
2104             for (i = 0; i <= PadlistMAX(padlist); i++)
2105                 XPUSHs(make_sv_object(aTHX_ (SV *)padp[i]));
2106         }
2107
2108 void
2109 PadlistARRAYelt(padlist, idx)
2110         B::PADLIST      padlist
2111         PADOFFSET       idx
2112     PPCODE:
2113         if (idx >= 0 && PadlistMAX(padlist) >= 0
2114          && idx <= PadlistMAX(padlist))
2115             XPUSHs(make_sv_object(aTHX_
2116                                   (SV *)PadlistARRAY(padlist)[idx]));
2117         else
2118             XPUSHs(make_sv_object(aTHX_ NULL));
2119
2120 U32
2121 PadlistREFCNT(padlist)
2122         B::PADLIST      padlist
2123     CODE:
2124         RETVAL = PadlistREFCNT(padlist);
2125     OUTPUT:
2126         RETVAL
2127
2128 #endif