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