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