This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
stop -MO=Concise -e'm?x?' segfaulting
[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::BIND",
25     "B::IV",
26     "B::NV",
27 #if PERL_VERSION <= 10
28     "B::RV",
29 #endif
30     "B::PV",
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 };
722
723 #include "const-c.inc"
724
725 MODULE = B      PACKAGE = B
726
727 INCLUDE: const-xs.inc
728
729 PROTOTYPES: DISABLE
730
731 BOOT:
732 {
733     CV *cv;
734     const char *file = __FILE__;
735     MY_CXT_INIT;
736     specialsv_list[0] = Nullsv;
737     specialsv_list[1] = &PL_sv_undef;
738     specialsv_list[2] = &PL_sv_yes;
739     specialsv_list[3] = &PL_sv_no;
740     specialsv_list[4] = (SV *) pWARN_ALL;
741     specialsv_list[5] = (SV *) pWARN_NONE;
742     specialsv_list[6] = (SV *) pWARN_STD;
743     
744     cv = newXS("B::init_av", intrpvar_sv_common, file);
745     ASSIGN_COMMON_ALIAS(I, initav);
746     cv = newXS("B::check_av", intrpvar_sv_common, file);
747     ASSIGN_COMMON_ALIAS(I, checkav_save);
748     cv = newXS("B::unitcheck_av", intrpvar_sv_common, file);
749     ASSIGN_COMMON_ALIAS(I, unitcheckav_save);
750     cv = newXS("B::begin_av", intrpvar_sv_common, file);
751     ASSIGN_COMMON_ALIAS(I, beginav_save);
752     cv = newXS("B::end_av", intrpvar_sv_common, file);
753     ASSIGN_COMMON_ALIAS(I, endav);
754     cv = newXS("B::main_cv", intrpvar_sv_common, file);
755     ASSIGN_COMMON_ALIAS(I, main_cv);
756     cv = newXS("B::inc_gv", intrpvar_sv_common, file);
757     ASSIGN_COMMON_ALIAS(I, incgv);
758     cv = newXS("B::defstash", intrpvar_sv_common, file);
759     ASSIGN_COMMON_ALIAS(I, defstash);
760     cv = newXS("B::curstash", intrpvar_sv_common, file);
761     ASSIGN_COMMON_ALIAS(I, curstash);
762 #ifdef PL_formfeed
763     cv = newXS("B::formfeed", intrpvar_sv_common, file);
764     ASSIGN_COMMON_ALIAS(I, formfeed);
765 #endif
766 #ifdef USE_ITHREADS
767     cv = newXS("B::regex_padav", intrpvar_sv_common, file);
768     ASSIGN_COMMON_ALIAS(I, regex_padav);
769 #endif
770     cv = newXS("B::warnhook", intrpvar_sv_common, file);
771     ASSIGN_COMMON_ALIAS(I, warnhook);
772     cv = newXS("B::diehook", intrpvar_sv_common, file);
773     ASSIGN_COMMON_ALIAS(I, diehook);
774 }
775
776 #ifndef PL_formfeed
777
778 void
779 formfeed()
780     PPCODE:
781         PUSHs(make_sv_object(aTHX_ GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV))));
782
783 #endif
784
785 long 
786 amagic_generation()
787     CODE:
788         RETVAL = PL_amagic_generation;
789     OUTPUT:
790         RETVAL
791
792 void
793 comppadlist()
794     PREINIT:
795         PADLIST *padlist = CvPADLIST(PL_main_cv ? PL_main_cv : PL_compcv);
796     PPCODE:
797 #ifdef PadlistARRAY
798         {
799             SV * const rv = sv_newmortal();
800             sv_setiv(newSVrv(rv, padlist ? "B::PADLIST" : "B::NULL"),
801                      PTR2IV(padlist));
802             PUSHs(rv);
803         }
804 #else
805         PUSHs(make_sv_object(aTHX_ (SV *)padlist));
806 #endif
807
808 void
809 sv_undef()
810     ALIAS:
811         sv_no = 1
812         sv_yes = 2
813     PPCODE:
814         PUSHs(make_sv_object(aTHX_ ix > 1 ? &PL_sv_yes
815                                           : ix < 1 ? &PL_sv_undef
816                                                    : &PL_sv_no));
817
818 void
819 main_root()
820     ALIAS:
821         main_start = 1
822     PPCODE:
823         PUSHs(make_op_object(aTHX_ ix ? PL_main_start : PL_main_root));
824
825 UV
826 sub_generation()
827     ALIAS:
828         dowarn = 1
829     CODE:
830         RETVAL = ix ? PL_dowarn : PL_sub_generation;
831     OUTPUT:
832         RETVAL
833
834 void
835 walkoptree(op, method)
836         B::OP op
837         const char *    method
838     CODE:
839         (void) walkoptree(aTHX_ op, method, &PL_sv_undef);
840
841 int
842 walkoptree_debug(...)
843     CODE:
844         dMY_CXT;
845         RETVAL = walkoptree_debug;
846         if (items > 0 && SvTRUE(ST(1)))
847             walkoptree_debug = 1;
848     OUTPUT:
849         RETVAL
850
851 #define address(sv) PTR2IV(sv)
852
853 IV
854 address(sv)
855         SV *    sv
856
857 void
858 svref_2object(sv)
859         SV *    sv
860     PPCODE:
861         if (!SvROK(sv))
862             croak("argument is not a reference");
863         PUSHs(make_sv_object(aTHX_ SvRV(sv)));
864
865 void
866 opnumber(name)
867 const char *    name
868 CODE:
869 {
870  int i; 
871  IV  result = -1;
872  ST(0) = sv_newmortal();
873  if (strncmp(name,"pp_",3) == 0)
874    name += 3;
875  for (i = 0; i < PL_maxo; i++)
876   {
877    if (strcmp(name, PL_op_name[i]) == 0)
878     {
879      result = i;
880      break;
881     }
882   }
883  sv_setiv(ST(0),result);
884 }
885
886 void
887 ppname(opnum)
888         int     opnum
889     CODE:
890         ST(0) = sv_newmortal();
891         if (opnum >= 0 && opnum < PL_maxo)
892             Perl_sv_setpvf(aTHX_ ST(0), "pp_%s", PL_op_name[opnum]);
893
894 void
895 hash(sv)
896         SV *    sv
897     CODE:
898         STRLEN len;
899         U32 hash = 0;
900         const char *s = SvPVbyte(sv, len);
901         PERL_HASH(hash, s, len);
902         ST(0) = sv_2mortal(Perl_newSVpvf(aTHX_ "0x%"UVxf, (UV)hash));
903
904 #define cast_I32(foo) (I32)foo
905 IV
906 cast_I32(i)
907         IV      i
908
909 void
910 minus_c()
911     ALIAS:
912         save_BEGINs = 1
913     CODE:
914         if (ix)
915             PL_savebegin = TRUE;
916         else
917             PL_minus_c = TRUE;
918
919 void
920 cstring(sv)
921         SV *    sv
922     ALIAS:
923         perlstring = 1
924         cchar = 2
925     PPCODE:
926         PUSHs(ix == 2 ? cchar(aTHX_ sv) : cstring(aTHX_ sv, (bool)ix));
927
928 void
929 threadsv_names()
930     PPCODE:
931
932
933
934
935 MODULE = B      PACKAGE = B::OP
936
937
938 # The type checking code in B has always been identical for all OP types,
939 # irrespective of whether the action is actually defined on that OP.
940 # We should fix this
941 void
942 next(o)
943         B::OP           o
944     ALIAS:
945         B::OP::next          =  0
946         B::OP::sibling       =  1
947         B::OP::targ          =  2
948         B::OP::flags         =  3
949         B::OP::private       =  4
950         B::UNOP::first       =  5
951         B::BINOP::last       =  6
952         B::LOGOP::other      =  7
953         B::PMOP::pmreplstart =  8
954         B::LOOP::redoop      =  9
955         B::LOOP::nextop      = 10
956         B::LOOP::lastop      = 11
957         B::PMOP::pmflags     = 12
958         B::PMOP::code_list   = 13
959         B::SVOP::sv          = 14
960         B::SVOP::gv          = 15
961         B::PADOP::padix      = 16
962         B::COP::cop_seq      = 17
963         B::COP::line         = 18
964         B::COP::hints        = 19
965         B::PMOP::pmoffset    = 20
966         B::COP::filegv       = 21
967         B::COP::file         = 22
968         B::COP::stash        = 23
969         B::COP::stashpv      = 24
970         B::COP::stashoff     = 25
971         B::OP::size          = 26
972         B::OP::name          = 27
973         B::OP::desc          = 28
974         B::OP::ppaddr        = 29
975         B::OP::type          = 30
976         B::OP::opt           = 31
977         B::OP::spare         = 32
978         B::LISTOP::children  = 33
979         B::PMOP::pmreplroot  = 34
980         B::PMOP::pmstashpv   = 35
981         B::PMOP::pmstash     = 36
982         B::PMOP::precomp     = 37
983         B::PMOP::reflags     = 38
984         B::PADOP::sv         = 39
985         B::PADOP::gv         = 40
986         B::PVOP::pv          = 41
987         B::COP::label        = 42
988         B::COP::arybase      = 43
989         B::COP::warnings     = 44
990         B::COP::io           = 45
991         B::COP::hints_hash   = 46
992     PREINIT:
993         char *ptr;
994         SV *ret;
995         I32 type;
996         I32 offset;
997         STRLEN len;
998     PPCODE:
999         if (ix < 0 || ix > 46)
1000             croak("Illegal alias %d for B::*OP::next", (int)ix);
1001         ret = get_overlay_object(aTHX_ o,
1002                             op_methods[ix].name, op_methods[ix].namelen);
1003         if (ret) {
1004             ST(0) = ret;
1005             XSRETURN(1);
1006         }
1007
1008         /* handle non-direct field access */
1009
1010         offset = op_methods[ix].offset;
1011         if (offset < 0) {
1012             switch (ix) {
1013             case 8: /* pmreplstart */
1014                 ret = make_op_object(aTHX_
1015                                 cPMOPo->op_type == OP_SUBST
1016                                     ?  cPMOPo->op_pmstashstartu.op_pmreplstart
1017                                     : NULL
1018                       );
1019                 break;
1020 #ifdef USE_ITHREADS
1021             case 21: /* filegv */
1022                 ret = make_sv_object(aTHX_ (SV *)CopFILEGV((COP*)o));
1023                 break;
1024 #endif
1025 #ifndef USE_ITHREADS
1026             case 22: /* file */
1027                 ret = sv_2mortal(newSVpv(CopFILE((COP*)o), 0));
1028                 break;
1029 #endif
1030 #ifdef USE_ITHREADS
1031             case 23: /* stash */
1032                 ret = make_sv_object(aTHX_ (SV *)CopSTASH((COP*)o));
1033                 break;
1034 #endif
1035 #if PERL_VERSION >= 17 || !defined USE_ITHREADS
1036             case 24: /* stashpv */
1037 #  if PERL_VERSION >= 17
1038                 ret = sv_2mortal(CopSTASH((COP*)o)
1039                                 && SvTYPE(CopSTASH((COP*)o)) == SVt_PVHV
1040                     ? newSVhek(HvNAME_HEK(CopSTASH((COP*)o)))
1041                     : &PL_sv_undef);
1042 #  else
1043                 ret = sv_2mortal(newSVpv(CopSTASHPV((COP*)o), 0));
1044 #  endif
1045                 break;
1046 #endif
1047             case 26: /* size */
1048                 ret = sv_2mortal(newSVuv((UV)(opsizes[cc_opclass(aTHX_ o)])));
1049                 break;
1050             case 27: /* name */
1051             case 28: /* desc */
1052                 ret = sv_2mortal(newSVpv(
1053                             (char *)(ix == 28 ? OP_DESC(o) : OP_NAME(o)), 0));
1054                 break;
1055             case 29: /* ppaddr */
1056                 {
1057                     int i;
1058                     ret = sv_2mortal(Perl_newSVpvf(aTHX_ "PL_ppaddr[OP_%s]",
1059                                                   PL_op_name[o->op_type]));
1060                     for (i=13; (STRLEN)i < SvCUR(ret); ++i)
1061                         SvPVX(ret)[i] = toUPPER(SvPVX(ret)[i]);
1062                 }
1063                 break;
1064             case 30: /* type  */
1065             case 31: /* opt   */
1066             case 32: /* spare */
1067             /* These 3 are all bitfields, so we can't take their addresses */
1068                 ret = sv_2mortal(newSVuv((UV)(
1069                                       ix == 30 ? o->op_type
1070                                     : ix == 31 ? o->op_opt
1071                                     :            o->op_spare)));
1072                 break;
1073             case 33: /* children */
1074                 {
1075                     OP *kid;
1076                     UV i = 0;
1077                     for (kid = ((LISTOP*)o)->op_first; kid; kid = kid->op_sibling)
1078                         i++;
1079                     ret = sv_2mortal(newSVuv(i));
1080                 }
1081                 break;
1082             case 34: /* pmreplroot */
1083                 if (cPMOPo->op_type == OP_PUSHRE) {
1084 #ifdef USE_ITHREADS
1085                     ret = sv_newmortal();
1086                     sv_setiv(ret, cPMOPo->op_pmreplrootu.op_pmtargetoff);
1087 #else
1088                     GV *const target = cPMOPo->op_pmreplrootu.op_pmtargetgv;
1089                     ret = sv_newmortal();
1090                     sv_setiv(newSVrv(ret, target ?
1091                                      svclassnames[SvTYPE((SV*)target)] : "B::SV"),
1092                              PTR2IV(target));
1093 #endif
1094                 }
1095                 else {
1096                     OP *const root = cPMOPo->op_pmreplrootu.op_pmreplroot;
1097                     ret = make_op_object(aTHX_ root);
1098                 }
1099                 break;
1100 #ifdef USE_ITHREADS
1101             case 35: /* pmstashpv */
1102                 ret = sv_2mortal(newSVpv(PmopSTASHPV(cPMOPo),0));
1103                 break;
1104 #else
1105             case 36: /* pmstash */
1106                 ret = make_sv_object(aTHX_ (SV *) PmopSTASH(cPMOPo));
1107                 break;
1108 #endif
1109             case 37: /* precomp */
1110             case 38: /* reflags */
1111                 {
1112                     REGEXP *rx = PM_GETRE(cPMOPo);
1113                     ret = sv_newmortal();
1114                     if (rx) {
1115                         if (ix==38) {
1116                             sv_setuv(ret, RX_EXTFLAGS(rx));
1117                         }
1118                         else {
1119                             sv_setpvn(ret, RX_PRECOMP(rx), RX_PRELEN(rx));
1120                         }
1121                     }
1122                 }
1123                 break;
1124             case 39: /* sv */
1125             case 40: /* gv */
1126                 /* It happens that the output typemaps for B::SV and B::GV
1127                  * are identical. The "smarts" are in make_sv_object(),
1128                  * which determines which class to use based on SvTYPE(),
1129                  * rather than anything baked in at compile time.  */
1130                 if (cPADOPo->op_padix) {
1131                     ret = PAD_SVl(cPADOPo->op_padix);
1132                     if (ix == 40 && SvTYPE(ret) != SVt_PVGV)
1133                         ret = NULL;
1134                 } else {
1135                     ret = NULL;
1136                 }
1137                 ret = make_sv_object(aTHX_ ret);
1138                 break;
1139             case 41: /* pv */
1140                 /* OP_TRANS uses op_pv to point to a table of 256 or >=258
1141                  * shorts whereas other PVOPs point to a null terminated
1142                  * string.  */
1143                 if (    (cPVOPo->op_type == OP_TRANS
1144                         || cPVOPo->op_type == OP_TRANSR) &&
1145                         (cPVOPo->op_private & OPpTRANS_COMPLEMENT) &&
1146                         !(cPVOPo->op_private & OPpTRANS_DELETE))
1147                 {
1148                     const short* const tbl = (short*)cPVOPo->op_pv;
1149                     const short entries = 257 + tbl[256];
1150                     ret = newSVpvn_flags(cPVOPo->op_pv, entries * sizeof(short), SVs_TEMP);
1151                 }
1152                 else if (cPVOPo->op_type == OP_TRANS || cPVOPo->op_type == OP_TRANSR) {
1153                     ret = newSVpvn_flags(cPVOPo->op_pv, 256 * sizeof(short), SVs_TEMP);
1154                 }
1155                 else
1156                     ret = newSVpvn_flags(cPVOPo->op_pv, strlen(cPVOPo->op_pv), SVs_TEMP);
1157                 break;
1158             case 42: /* label */
1159                 ret = sv_2mortal(newSVpv(CopLABEL(cCOPo),0));
1160                 break;
1161             case 43: /* arybase */
1162                 ret = sv_2mortal(newSVuv(0));
1163                 break;
1164             case 44: /* warnings */
1165                 ret = make_warnings_object(aTHX_ cCOPo);
1166                 break;
1167             case 45: /* io */
1168                 ret = make_cop_io_object(aTHX_ cCOPo);
1169                 break;
1170             case 46: /* hints_hash */
1171                 ret = sv_newmortal();
1172                 sv_setiv(newSVrv(ret, "B::RHE"),
1173                         PTR2IV(CopHINTHASH_get(cCOPo)));
1174                 break;
1175             default:
1176                 croak("method %s not implemented", op_methods[ix].name);
1177             }
1178             ST(0) = ret;
1179             XSRETURN(1);
1180         }
1181
1182         /* do a direct structure offset lookup */
1183
1184         ptr  = (char *)o + offset;
1185         type = op_methods[ix].type;
1186         switch ((U8)(type >> 16)) {
1187         case  (U8)(OPp >> 16):
1188             ret = make_op_object(aTHX_ *((OP **)ptr));
1189             break;
1190         case  (U8)(PADOFFSETp >> 16):
1191             ret = sv_2mortal(newSVuv(*((PADOFFSET*)ptr)));
1192             break;
1193         case (U8)(U8p >> 16):
1194             ret = sv_2mortal(newSVuv(*((U8*)ptr)));
1195             break;
1196         case (U8)(U32p >> 16):
1197             ret = sv_2mortal(newSVuv(*((U32*)ptr)));
1198             break;
1199         case (U8)(SVp >> 16):
1200             ret = make_sv_object(aTHX_ *((SV **)ptr));
1201             break;
1202         case (U8)(line_tp >> 16):
1203             ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
1204             break;
1205         case (U8)(IVp >> 16):
1206             ret = sv_2mortal(newSViv(*((IV*)ptr)));
1207             break;
1208         case (U8)(char_pp >> 16):
1209             ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
1210             break;
1211         default:
1212             croak("Illegal type 0x%08x for B::*OP::%s",
1213                     (unsigned)type, op_methods[ix].name);
1214
1215         }
1216         ST(0) = ret;
1217         XSRETURN(1);
1218
1219
1220 void
1221 oplist(o)
1222         B::OP           o
1223     PPCODE:
1224         SP = oplist(aTHX_ o, SP);
1225
1226
1227 MODULE = B      PACKAGE = B::SV
1228
1229 #define MAGICAL_FLAG_BITS (SVs_GMG|SVs_SMG|SVs_RMG)
1230
1231 U32
1232 REFCNT(sv)
1233         B::SV   sv
1234     ALIAS:
1235         FLAGS = 0xFFFFFFFF
1236         SvTYPE = SVTYPEMASK
1237         POK = SVf_POK
1238         ROK = SVf_ROK
1239         MAGICAL = MAGICAL_FLAG_BITS
1240     CODE:
1241         RETVAL = ix ? (SvFLAGS(sv) & (U32)ix) : SvREFCNT(sv);
1242     OUTPUT:
1243         RETVAL
1244
1245 void
1246 object_2svref(sv)
1247         B::SV   sv
1248     PPCODE:
1249         ST(0) = sv_2mortal(newRV(sv));
1250         XSRETURN(1);
1251         
1252 MODULE = B      PACKAGE = B::IV         PREFIX = Sv
1253
1254 IV
1255 SvIV(sv)
1256         B::IV   sv
1257
1258 MODULE = B      PACKAGE = B::IV
1259
1260 #define sv_SVp          0x00000
1261 #define sv_IVp          0x10000
1262 #define sv_UVp          0x20000
1263 #define sv_STRLENp      0x30000
1264 #define sv_U32p         0x40000
1265 #define sv_U8p          0x50000
1266 #define sv_char_pp      0x60000
1267 #define sv_NVp          0x70000
1268 #define sv_char_p       0x80000
1269 #define sv_SSize_tp     0x90000
1270 #define sv_I32p         0xA0000
1271 #define sv_U16p         0xB0000
1272
1273 #define IV_ivx_ix       sv_IVp | offsetof(struct xpviv, xiv_iv)
1274 #define IV_uvx_ix       sv_UVp | offsetof(struct xpvuv, xuv_uv)
1275 #define NV_nvx_ix       sv_NVp | offsetof(struct xpvnv, xnv_u.xnv_nv)
1276
1277 #define NV_cop_seq_range_low_ix \
1278                         sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
1279 #define NV_cop_seq_range_high_ix \
1280                         sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
1281 #define NV_parent_pad_index_ix \
1282                         sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
1283 #define NV_parent_fakelex_flags_ix \
1284                         sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
1285
1286 #define PV_cur_ix       sv_STRLENp | offsetof(struct xpv, xpv_cur)
1287 #define PV_len_ix       sv_STRLENp | offsetof(struct xpv, xpv_len)
1288
1289 #define PVMG_stash_ix   sv_SVp | offsetof(struct xpvmg, xmg_stash)
1290
1291 #if PERL_VERSION > 14
1292 #    define PVBM_useful_ix      sv_I32p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_useful)
1293 #    define PVBM_previous_ix    sv_UVp | offsetof(struct xpvuv, xuv_uv)
1294 #else
1295 #define PVBM_useful_ix  sv_I32p | offsetof(struct xpvgv, xiv_u.xivu_i32)
1296 #define PVBM_previous_ix    sv_U32p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_previous)
1297 #endif
1298
1299 #define PVBM_rare_ix    sv_U8p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_rare)
1300
1301 #define PVLV_targoff_ix sv_U32p | offsetof(struct xpvlv, xlv_targoff)
1302 #define PVLV_targlen_ix sv_U32p | offsetof(struct xpvlv, xlv_targlen)
1303 #define PVLV_targ_ix    sv_SVp | offsetof(struct xpvlv, xlv_targ)
1304 #define PVLV_type_ix    sv_char_p | offsetof(struct xpvlv, xlv_type)
1305
1306 #define PVGV_stash_ix   sv_SVp | offsetof(struct xpvgv, xnv_u.xgv_stash)
1307 #define PVGV_flags_ix   sv_STRLENp | offsetof(struct xpvgv, xpv_cur)
1308 #define PVIO_lines_ix   sv_IVp | offsetof(struct xpvio, xiv_iv)
1309
1310 #define PVIO_page_ix        sv_IVp | offsetof(struct xpvio, xio_page)
1311 #define PVIO_page_len_ix    sv_IVp | offsetof(struct xpvio, xio_page_len)
1312 #define PVIO_lines_left_ix  sv_IVp | offsetof(struct xpvio, xio_lines_left)
1313 #define PVIO_top_name_ix    sv_char_pp | offsetof(struct xpvio, xio_top_name)
1314 #define PVIO_top_gv_ix      sv_SVp | offsetof(struct xpvio, xio_top_gv)
1315 #define PVIO_fmt_name_ix    sv_char_pp | offsetof(struct xpvio, xio_fmt_name)
1316 #define PVIO_fmt_gv_ix      sv_SVp | offsetof(struct xpvio, xio_fmt_gv)
1317 #define PVIO_bottom_name_ix sv_char_pp | offsetof(struct xpvio, xio_bottom_name)
1318 #define PVIO_bottom_gv_ix   sv_SVp | offsetof(struct xpvio, xio_bottom_gv)
1319 #define PVIO_type_ix        sv_char_p | offsetof(struct xpvio, xio_type)
1320 #define PVIO_flags_ix       sv_U8p | offsetof(struct xpvio, xio_flags)
1321
1322 #define PVAV_max_ix     sv_SSize_tp | offsetof(struct xpvav, xav_max)
1323
1324 #define PVCV_stash_ix   sv_SVp | offsetof(struct xpvcv, xcv_stash) 
1325 #if PERL_VERSION > 17 || (PERL_VERSION == 17 && PERL_SUBVERSION >= 3)
1326 # define PVCV_gv_ix     sv_SVp | offsetof(struct xpvcv, xcv_gv_u.xcv_gv)
1327 #else
1328 # define PVCV_gv_ix     sv_SVp | offsetof(struct xpvcv, xcv_gv)
1329 #endif
1330 #define PVCV_file_ix    sv_char_pp | offsetof(struct xpvcv, xcv_file)
1331 #define PVCV_outside_ix sv_SVp | offsetof(struct xpvcv, xcv_outside)
1332 #define PVCV_outside_seq_ix sv_U32p | offsetof(struct xpvcv, xcv_outside_seq)
1333 #define PVCV_flags_ix   sv_U16p | offsetof(struct xpvcv, xcv_flags)
1334
1335 #define PVHV_max_ix     sv_STRLENp | offsetof(struct xpvhv, xhv_max)
1336
1337 #if PERL_VERSION > 12
1338 #define PVHV_keys_ix    sv_STRLENp | offsetof(struct xpvhv, xhv_keys)
1339 #else
1340 #define PVHV_keys_ix    sv_IVp | offsetof(struct xpvhv, xhv_keys)
1341 #endif
1342
1343 # The type checking code in B has always been identical for all SV types,
1344 # irrespective of whether the action is actually defined on that SV.
1345 # We should fix this
1346 void
1347 IVX(sv)
1348         B::SV           sv
1349     ALIAS:
1350         B::IV::IVX = IV_ivx_ix
1351         B::IV::UVX = IV_uvx_ix
1352         B::NV::NVX = NV_nvx_ix
1353         B::NV::COP_SEQ_RANGE_LOW = NV_cop_seq_range_low_ix
1354         B::NV::COP_SEQ_RANGE_HIGH = NV_cop_seq_range_high_ix
1355         B::NV::PARENT_PAD_INDEX = NV_parent_pad_index_ix
1356         B::NV::PARENT_FAKELEX_FLAGS = NV_parent_fakelex_flags_ix
1357         B::PV::CUR = PV_cur_ix
1358         B::PV::LEN = PV_len_ix
1359         B::PVMG::SvSTASH = PVMG_stash_ix
1360         B::PVLV::TARGOFF = PVLV_targoff_ix
1361         B::PVLV::TARGLEN = PVLV_targlen_ix
1362         B::PVLV::TARG = PVLV_targ_ix
1363         B::PVLV::TYPE = PVLV_type_ix
1364         B::GV::STASH = PVGV_stash_ix
1365         B::GV::GvFLAGS = PVGV_flags_ix
1366         B::BM::USEFUL = PVBM_useful_ix
1367         B::BM::PREVIOUS = PVBM_previous_ix
1368         B::BM::RARE = PVBM_rare_ix
1369         B::IO::LINES =  PVIO_lines_ix
1370         B::IO::PAGE = PVIO_page_ix
1371         B::IO::PAGE_LEN = PVIO_page_len_ix
1372         B::IO::LINES_LEFT = PVIO_lines_left_ix
1373         B::IO::TOP_NAME = PVIO_top_name_ix
1374         B::IO::TOP_GV = PVIO_top_gv_ix
1375         B::IO::FMT_NAME = PVIO_fmt_name_ix
1376         B::IO::FMT_GV = PVIO_fmt_gv_ix
1377         B::IO::BOTTOM_NAME = PVIO_bottom_name_ix
1378         B::IO::BOTTOM_GV = PVIO_bottom_gv_ix
1379         B::IO::IoTYPE = PVIO_type_ix
1380         B::IO::IoFLAGS = PVIO_flags_ix
1381         B::AV::MAX = PVAV_max_ix
1382         B::CV::STASH = PVCV_stash_ix
1383         B::CV::GV = PVCV_gv_ix
1384         B::CV::FILE = PVCV_file_ix
1385         B::CV::OUTSIDE = PVCV_outside_ix
1386         B::CV::OUTSIDE_SEQ = PVCV_outside_seq_ix
1387         B::CV::CvFLAGS = PVCV_flags_ix
1388         B::HV::MAX = PVHV_max_ix
1389         B::HV::KEYS = PVHV_keys_ix
1390     PREINIT:
1391         char *ptr;
1392         SV *ret;
1393     PPCODE:
1394         ptr = (ix & 0xFFFF) + (char *)SvANY(sv);
1395         switch ((U8)(ix >> 16)) {
1396         case (U8)(sv_SVp >> 16):
1397             ret = make_sv_object(aTHX_ *((SV **)ptr));
1398             break;
1399         case (U8)(sv_IVp >> 16):
1400             ret = sv_2mortal(newSViv(*((IV *)ptr)));
1401             break;
1402         case (U8)(sv_UVp >> 16):
1403             ret = sv_2mortal(newSVuv(*((UV *)ptr)));
1404             break;
1405         case (U8)(sv_STRLENp >> 16):
1406             ret = sv_2mortal(newSVuv(*((STRLEN *)ptr)));
1407             break;
1408         case (U8)(sv_U32p >> 16):
1409             ret = sv_2mortal(newSVuv(*((U32 *)ptr)));
1410             break;
1411         case (U8)(sv_U8p >> 16):
1412             ret = sv_2mortal(newSVuv(*((U8 *)ptr)));
1413             break;
1414         case (U8)(sv_char_pp >> 16):
1415             ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
1416             break;
1417         case (U8)(sv_NVp >> 16):
1418             ret = sv_2mortal(newSVnv(*((NV *)ptr)));
1419             break;
1420         case (U8)(sv_char_p >> 16):
1421             ret = newSVpvn_flags((char *)ptr, 1, SVs_TEMP);
1422             break;
1423         case (U8)(sv_SSize_tp >> 16):
1424             ret = sv_2mortal(newSViv(*((SSize_t *)ptr)));
1425             break;
1426         case (U8)(sv_I32p >> 16):
1427             ret = sv_2mortal(newSVuv(*((I32 *)ptr)));
1428             break;
1429         case (U8)(sv_U16p >> 16):
1430             ret = sv_2mortal(newSVuv(*((U16 *)ptr)));
1431             break;
1432         default:
1433             croak("Illegal alias 0x%08x for B::*IVX", (unsigned)ix);
1434         }
1435         ST(0) = ret;
1436         XSRETURN(1);
1437
1438 void
1439 packiv(sv)
1440         B::IV   sv
1441     ALIAS:
1442         needs64bits = 1
1443     CODE:
1444         if (ix) {
1445             ST(0) = boolSV((I32)SvIVX(sv) != SvIVX(sv));
1446         } else if (sizeof(IV) == 8) {
1447             U32 wp[2];
1448             const IV iv = SvIVX(sv);
1449             /*
1450              * The following way of spelling 32 is to stop compilers on
1451              * 32-bit architectures from moaning about the shift count
1452              * being >= the width of the type. Such architectures don't
1453              * reach this code anyway (unless sizeof(IV) > 8 but then
1454              * everything else breaks too so I'm not fussed at the moment).
1455              */
1456 #ifdef UV_IS_QUAD
1457             wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1458 #else
1459             wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1460 #endif
1461             wp[1] = htonl(iv & 0xffffffff);
1462             ST(0) = newSVpvn_flags((char *)wp, 8, SVs_TEMP);
1463         } else {
1464             U32 w = htonl((U32)SvIVX(sv));
1465             ST(0) = newSVpvn_flags((char *)&w, 4, SVs_TEMP);
1466         }
1467
1468 MODULE = B      PACKAGE = B::NV         PREFIX = Sv
1469
1470 NV
1471 SvNV(sv)
1472         B::NV   sv
1473
1474 #if PERL_VERSION < 11
1475
1476 MODULE = B      PACKAGE = B::RV         PREFIX = Sv
1477
1478 void
1479 SvRV(sv)
1480         B::RV   sv
1481     PPCODE:
1482         PUSHs(make_sv_object(aTHX_ SvRV(sv)));
1483
1484 #else
1485
1486 MODULE = B      PACKAGE = B::REGEXP
1487
1488 void
1489 REGEX(sv)
1490         B::REGEXP       sv
1491     ALIAS:
1492         precomp = 1
1493     PPCODE:
1494         if (ix) {
1495             PUSHs(newSVpvn_flags(RX_PRECOMP(sv), RX_PRELEN(sv), SVs_TEMP));
1496         } else {
1497             dXSTARG;
1498             /* FIXME - can we code this method more efficiently?  */
1499             PUSHi(PTR2IV(sv));
1500         }
1501
1502 #endif
1503
1504 MODULE = B      PACKAGE = B::PV
1505
1506 void
1507 RV(sv)
1508         B::PV   sv
1509     PPCODE:
1510         if (!SvROK(sv))
1511             croak( "argument is not SvROK" );
1512         PUSHs(make_sv_object(aTHX_ SvRV(sv)));
1513
1514 void
1515 PV(sv)
1516         B::PV   sv
1517     ALIAS:
1518         PVX = 1
1519         PVBM = 2
1520         B::BM::TABLE = 3
1521     PREINIT:
1522         const char *p;
1523         STRLEN len = 0;
1524         U32 utf8 = 0;
1525     CODE:
1526         if (ix == 3) {
1527 #ifndef PERL_FBM_TABLE_OFFSET
1528             const MAGIC *const mg = mg_find(sv, PERL_MAGIC_bm);
1529
1530             if (!mg)
1531                 croak("argument to B::BM::TABLE is not a PVBM");
1532             p = mg->mg_ptr;
1533             len = mg->mg_len;
1534 #else
1535             p = SvPV(sv, len);
1536             /* Boyer-Moore table is just after string and its safety-margin \0 */
1537             p += len + PERL_FBM_TABLE_OFFSET;
1538             len = 256;
1539 #endif
1540         } else if (ix == 2) {
1541             /* This used to read 257. I think that that was buggy - should have
1542                been 258. (The "\0", the flags byte, and 256 for the table.)
1543                The only user of this method is B::Bytecode in B::PV::bsave.
1544                I'm guessing that nothing tested the runtime correctness of
1545                output of bytecompiled string constant arguments to index (etc).
1546
1547                Note the start pointer is and has always been SvPVX(sv), not
1548                SvPVX(sv) + SvCUR(sv) PVBM was added in 651aa52ea1faa806, and
1549                first used by the compiler in 651aa52ea1faa806. It's used to
1550                get a "complete" dump of the buffer at SvPVX(), not just the
1551                PVBM table. This permits the generated bytecode to "load"
1552                SvPVX in "one" hit.
1553
1554                5.15 and later store the BM table via MAGIC, so the compiler
1555                should handle this just fine without changes if PVBM now
1556                always returns the SvPVX() buffer.  */
1557 #ifdef isREGEXP
1558             p = isREGEXP(sv)
1559                  ? RX_WRAPPED_const((REGEXP*)sv)
1560                  : SvPVX_const(sv);
1561 #else
1562             p = SvPVX_const(sv);
1563 #endif
1564 #ifdef PERL_FBM_TABLE_OFFSET
1565             len = SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0);
1566 #else
1567             len = SvCUR(sv);
1568 #endif
1569         } else if (ix) {
1570 #ifdef isREGEXP
1571             p = isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX(sv);
1572 #else
1573             p = SvPVX(sv);
1574 #endif
1575             len = strlen(p);
1576         } else if (SvPOK(sv)) {
1577             len = SvCUR(sv);
1578             p = SvPVX_const(sv);
1579             utf8 = SvUTF8(sv);
1580         }
1581 #ifdef isREGEXP
1582         else if (isREGEXP(sv)) {
1583             len = SvCUR(sv);
1584             p = RX_WRAPPED_const((REGEXP*)sv);
1585             utf8 = SvUTF8(sv);
1586         }
1587 #endif
1588         else {
1589             /* XXX for backward compatibility, but should fail */
1590             /* croak( "argument is not SvPOK" ); */
1591             p = NULL;
1592         }
1593         ST(0) = newSVpvn_flags(p, len, SVs_TEMP | utf8);
1594
1595 MODULE = B      PACKAGE = B::PVMG
1596
1597 void
1598 MAGIC(sv)
1599         B::PVMG sv
1600         MAGIC * mg = NO_INIT
1601     PPCODE:
1602         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
1603             XPUSHs(make_mg_object(aTHX_ mg));
1604
1605 MODULE = B      PACKAGE = B::MAGIC
1606
1607 void
1608 MOREMAGIC(mg)
1609         B::MAGIC        mg
1610     ALIAS:
1611         PRIVATE = 1
1612         TYPE = 2
1613         FLAGS = 3
1614         LENGTH = 4
1615         OBJ = 5
1616         PTR = 6
1617         REGEX = 7
1618         precomp = 8
1619     PPCODE:
1620         switch (ix) {
1621         case 0:
1622             XPUSHs(mg->mg_moremagic ? make_mg_object(aTHX_ mg->mg_moremagic)
1623                                     : &PL_sv_undef);
1624             break;
1625         case 1:
1626             mPUSHu(mg->mg_private);
1627             break;
1628         case 2:
1629             PUSHs(newSVpvn_flags(&(mg->mg_type), 1, SVs_TEMP));
1630             break;
1631         case 3:
1632             mPUSHu(mg->mg_flags);
1633             break;
1634         case 4:
1635             mPUSHi(mg->mg_len);
1636             break;
1637         case 5:
1638             PUSHs(make_sv_object(aTHX_ mg->mg_obj));
1639             break;
1640         case 6:
1641             if (mg->mg_ptr) {
1642                 if (mg->mg_len >= 0) {
1643                     PUSHs(newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP));
1644                 } else if (mg->mg_len == HEf_SVKEY) {
1645                     PUSHs(make_sv_object(aTHX_ (SV*)mg->mg_ptr));
1646                 } else
1647                     PUSHs(sv_newmortal());
1648             } else
1649                 PUSHs(sv_newmortal());
1650             break;
1651         case 7:
1652             if(mg->mg_type == PERL_MAGIC_qr) {
1653                 mPUSHi(PTR2IV(mg->mg_obj));
1654             } else {
1655                 croak("REGEX is only meaningful on r-magic");
1656             }
1657             break;
1658         case 8:
1659             if (mg->mg_type == PERL_MAGIC_qr) {
1660                 REGEXP *rx = (REGEXP *)mg->mg_obj;
1661                 PUSHs(newSVpvn_flags(rx ? RX_PRECOMP(rx) : NULL,
1662                                      rx ? RX_PRELEN(rx) : 0, SVs_TEMP));
1663             } else {
1664                 croak( "precomp is only meaningful on r-magic" );
1665             }
1666             break;
1667         }
1668
1669 MODULE = B      PACKAGE = B::GV         PREFIX = Gv
1670
1671 void
1672 GvNAME(gv)
1673         B::GV   gv
1674     ALIAS:
1675         FILE = 1
1676         B::HV::NAME = 2
1677     CODE:
1678         ST(0) = sv_2mortal(newSVhek(!ix ? GvNAME_HEK(gv)
1679                                         : (ix == 1 ? GvFILE_HEK(gv)
1680                                                    : HvNAME_HEK((HV *)gv))));
1681
1682 bool
1683 is_empty(gv)
1684         B::GV   gv
1685     ALIAS:
1686         isGV_with_GP = 1
1687     CODE:
1688         if (ix) {
1689             RETVAL = isGV_with_GP(gv) ? TRUE : FALSE;
1690         } else {
1691             RETVAL = GvGP(gv) == Null(GP*);
1692         }
1693     OUTPUT:
1694         RETVAL
1695
1696 void*
1697 GvGP(gv)
1698         B::GV   gv
1699
1700 #define GP_sv_ix        SVp | offsetof(struct gp, gp_sv)
1701 #define GP_io_ix        SVp | offsetof(struct gp, gp_io)
1702 #define GP_cv_ix        SVp | offsetof(struct gp, gp_cv)
1703 #define GP_cvgen_ix     U32p | offsetof(struct gp, gp_cvgen)
1704 #define GP_refcnt_ix    U32p | offsetof(struct gp, gp_refcnt)
1705 #define GP_hv_ix        SVp | offsetof(struct gp, gp_hv)
1706 #define GP_av_ix        SVp | offsetof(struct gp, gp_av)
1707 #define GP_form_ix      SVp | offsetof(struct gp, gp_form)
1708 #define GP_egv_ix       SVp | offsetof(struct gp, gp_egv)
1709 #define GP_line_ix      line_tp | offsetof(struct gp, gp_line)
1710
1711 void
1712 SV(gv)
1713         B::GV   gv
1714     ALIAS:
1715         SV = GP_sv_ix
1716         IO = GP_io_ix
1717         CV = GP_cv_ix
1718         CVGEN = GP_cvgen_ix
1719         GvREFCNT = GP_refcnt_ix
1720         HV = GP_hv_ix
1721         AV = GP_av_ix
1722         FORM = GP_form_ix
1723         EGV = GP_egv_ix
1724         LINE = GP_line_ix
1725     PREINIT:
1726         GP *gp;
1727         char *ptr;
1728         SV *ret;
1729     PPCODE:
1730         gp = GvGP(gv);
1731         if (!gp) {
1732             const GV *const gv = CvGV(cv);
1733             Perl_croak(aTHX_ "NULL gp in B::GV::%s", gv ? GvNAME(gv) : "???");
1734         }
1735         ptr = (ix & 0xFFFF) + (char *)gp;
1736         switch ((U8)(ix >> 16)) {
1737         case (U8)(SVp >> 16):
1738             ret = make_sv_object(aTHX_ *((SV **)ptr));
1739             break;
1740         case (U8)(U32p >> 16):
1741             ret = sv_2mortal(newSVuv(*((U32*)ptr)));
1742             break;
1743         case (U8)(line_tp >> 16):
1744             ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
1745             break;
1746         default:
1747             croak("Illegal alias 0x%08x for B::*SV", (unsigned)ix);
1748         }
1749         ST(0) = ret;
1750         XSRETURN(1);
1751
1752 void
1753 FILEGV(gv)
1754         B::GV   gv
1755     PPCODE:
1756         PUSHs(make_sv_object(aTHX_ (SV *)GvFILEGV(gv)));
1757
1758 MODULE = B      PACKAGE = B::IO         PREFIX = Io
1759
1760
1761 bool
1762 IsSTD(io,name)
1763         B::IO   io
1764         const char*     name
1765     PREINIT:
1766         PerlIO* handle = 0;
1767     CODE:
1768         if( strEQ( name, "stdin" ) ) {
1769             handle = PerlIO_stdin();
1770         }
1771         else if( strEQ( name, "stdout" ) ) {
1772             handle = PerlIO_stdout();
1773         }
1774         else if( strEQ( name, "stderr" ) ) {
1775             handle = PerlIO_stderr();
1776         }
1777         else {
1778             croak( "Invalid value '%s'", name );
1779         }
1780         RETVAL = handle == IoIFP(io);
1781     OUTPUT:
1782         RETVAL
1783
1784 MODULE = B      PACKAGE = B::AV         PREFIX = Av
1785
1786 SSize_t
1787 AvFILL(av)
1788         B::AV   av
1789
1790 void
1791 AvARRAY(av)
1792         B::AV   av
1793     PPCODE:
1794         if (AvFILL(av) >= 0) {
1795             SV **svp = AvARRAY(av);
1796             I32 i;
1797             for (i = 0; i <= AvFILL(av); i++)
1798                 XPUSHs(make_sv_object(aTHX_ svp[i]));
1799         }
1800
1801 void
1802 AvARRAYelt(av, idx)
1803         B::AV   av
1804         int     idx
1805     PPCODE:
1806         if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
1807             XPUSHs(make_sv_object(aTHX_ (AvARRAY(av)[idx])));
1808         else
1809             XPUSHs(make_sv_object(aTHX_ NULL));
1810
1811
1812 MODULE = B      PACKAGE = B::FM         PREFIX = Fm
1813
1814 #undef FmLINES
1815 #define FmLINES(sv) 0
1816
1817 IV
1818 FmLINES(form)
1819         B::FM   form
1820
1821 MODULE = B      PACKAGE = B::CV         PREFIX = Cv
1822
1823 U32
1824 CvCONST(cv)
1825         B::CV   cv
1826
1827 void
1828 CvSTART(cv)
1829         B::CV   cv
1830     ALIAS:
1831         ROOT = 1
1832     PPCODE:
1833         PUSHs(make_op_object(aTHX_ CvISXSUB(cv) ? NULL
1834                              : ix ? CvROOT(cv) : CvSTART(cv)));
1835
1836 I32
1837 CvDEPTH(cv)
1838         B::CV   cv
1839
1840 #ifdef PadlistARRAY
1841
1842 B::PADLIST
1843 CvPADLIST(cv)
1844         B::CV   cv
1845
1846 #else
1847
1848 B::AV
1849 CvPADLIST(cv)
1850         B::CV   cv
1851     PPCODE:
1852         PUSHs(make_sv_object(aTHX_ (SV *)CvPADLIST(cv)));
1853
1854
1855 #endif
1856
1857 void
1858 CvXSUB(cv)
1859         B::CV   cv
1860     ALIAS:
1861         XSUBANY = 1
1862     CODE:
1863         ST(0) = ix && CvCONST(cv)
1864             ? make_sv_object(aTHX_ (SV *)CvXSUBANY(cv).any_ptr)
1865             : sv_2mortal(newSViv(CvISXSUB(cv)
1866                                  ? (ix ? CvXSUBANY(cv).any_iv
1867                                        : PTR2IV(CvXSUB(cv)))
1868                                  : 0));
1869
1870 void
1871 const_sv(cv)
1872         B::CV   cv
1873     PPCODE:
1874         PUSHs(make_sv_object(aTHX_ (SV *)cv_const_sv(cv)));
1875
1876 MODULE = B      PACKAGE = B::HV         PREFIX = Hv
1877
1878 STRLEN
1879 HvFILL(hv)
1880         B::HV   hv
1881
1882 I32
1883 HvRITER(hv)
1884         B::HV   hv
1885
1886 void
1887 HvARRAY(hv)
1888         B::HV   hv
1889     PPCODE:
1890         if (HvUSEDKEYS(hv) > 0) {
1891             SV *sv;
1892             char *key;
1893             I32 len;
1894             (void)hv_iterinit(hv);
1895             EXTEND(sp, HvUSEDKEYS(hv) * 2);
1896             while ((sv = hv_iternextsv(hv, &key, &len))) {
1897                 mPUSHp(key, len);
1898                 PUSHs(make_sv_object(aTHX_ sv));
1899             }
1900         }
1901
1902 MODULE = B      PACKAGE = B::HE         PREFIX = He
1903
1904 void
1905 HeVAL(he)
1906         B::HE he
1907     ALIAS:
1908         SVKEY_force = 1
1909     PPCODE:
1910         PUSHs(make_sv_object(aTHX_ ix ? HeSVKEY_force(he) : HeVAL(he)));
1911
1912 U32
1913 HeHASH(he)
1914         B::HE he
1915
1916 MODULE = B      PACKAGE = B::RHE
1917
1918 SV*
1919 HASH(h)
1920         B::RHE h
1921     CODE:
1922         RETVAL = newRV( (SV*)cophh_2hv(h, 0) );
1923     OUTPUT:
1924         RETVAL
1925
1926
1927 #ifdef PadlistARRAY
1928
1929 MODULE = B      PACKAGE = B::PADLIST    PREFIX = Padlist
1930
1931 SSize_t
1932 PadlistMAX(padlist)
1933         B::PADLIST      padlist
1934
1935 void
1936 PadlistARRAY(padlist)
1937         B::PADLIST      padlist
1938     PPCODE:
1939         if (PadlistMAX(padlist) >= 0) {
1940             PAD **padp = PadlistARRAY(padlist);
1941             PADOFFSET i;
1942             for (i = 0; i <= PadlistMAX(padlist); i++)
1943                 XPUSHs(make_sv_object(aTHX_ (SV *)padp[i]));
1944         }
1945
1946 void
1947 PadlistARRAYelt(padlist, idx)
1948         B::PADLIST      padlist
1949         PADOFFSET       idx
1950     PPCODE:
1951         if (PadlistMAX(padlist) >= 0
1952          && idx <= PadlistMAX(padlist))
1953             XPUSHs(make_sv_object(aTHX_
1954                                   (SV *)PadlistARRAY(padlist)[idx]));
1955         else
1956             XPUSHs(make_sv_object(aTHX_ NULL));
1957
1958 U32
1959 PadlistREFCNT(padlist)
1960         B::PADLIST      padlist
1961     CODE:
1962         RETVAL = PadlistREFCNT(padlist);
1963     OUTPUT:
1964         RETVAL
1965
1966 #endif