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