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