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