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