This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[MERGE] fixup add+use si_cxsubix field
[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             ret = Perl_newSVpvf(aTHX_ "%" IVdf ",%" IVdf, aux[0].iv, aux[1].iv);
1181             if (aux[2].iv)
1182                 Perl_sv_catpvf(aTHX_ ret, ",%c", (char)aux[2].iv);
1183             ret = sv_2mortal(ret);
1184             break;
1185
1186         default:
1187             ret = sv_2mortal(newSVpvn("", 0));
1188         }
1189
1190         ST(0) = ret;
1191         XSRETURN(1);
1192
1193
1194 # Return the contents of the op_aux array as a list of IV/GV/etc objects.
1195 # How to interpret each array element is op-dependent. The op's CV is
1196 # needed as an extra arg to allow GVs and SVs which have been moved into
1197 # the pad to be accessed okay.
1198
1199 void
1200 aux_list(o, cv)
1201         B::OP  o
1202         B::CV  cv
1203     PREINIT:
1204         UNOP_AUX_item *aux;
1205     PPCODE:
1206         PERL_UNUSED_VAR(cv); /* not needed on unthreaded builds */
1207         aux = cUNOP_AUXo->op_aux;
1208         switch (o->op_type) {
1209         default:
1210             XSRETURN(0); /* by default, an empty list */
1211
1212         case OP_ARGELEM:
1213             XPUSHs(sv_2mortal(newSViv(PTR2IV(aux))));
1214             XSRETURN(1);
1215             break;
1216
1217         case OP_ARGCHECK:
1218             EXTEND(SP, 3);
1219             PUSHs(sv_2mortal(newSViv(aux[0].iv)));
1220             PUSHs(sv_2mortal(newSViv(aux[1].iv)));
1221             PUSHs(sv_2mortal(aux[2].iv ? Perl_newSVpvf(aTHX_ "%c",
1222                                 (char)aux[2].iv) : &PL_sv_no));
1223             break;
1224
1225         case OP_MULTICONCAT:
1226             {
1227                 SSize_t nargs;
1228                 char *p;
1229                 STRLEN len;
1230                 U32 utf8 = 0;
1231                 SV *sv;
1232                 UNOP_AUX_item *lens;
1233
1234                 /* return (nargs, const string, segment len 0, 1, 2, ...) */
1235
1236                 /* if this changes, this block of code probably needs fixing */
1237                 assert(PERL_MULTICONCAT_HEADER_SIZE == 5);
1238                 nargs = aux[PERL_MULTICONCAT_IX_NARGS].ssize;
1239                 EXTEND(SP, ((SSize_t)(2 + (nargs+1))));
1240                 PUSHs(sv_2mortal(newSViv((IV)nargs)));
1241
1242                 p   = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1243                 len = aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize;
1244                 if (!p) {
1245                     p   = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1246                     len = aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize;
1247                     utf8 = SVf_UTF8;
1248                 }
1249                 sv = newSVpvn(p, len);
1250                 SvFLAGS(sv) |= utf8;
1251                 PUSHs(sv_2mortal(sv));
1252
1253                 lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
1254                 nargs++; /* loop (nargs+1) times */
1255                 if (utf8) {
1256                     U8 *p = (U8*)SvPVX(sv);
1257                     while (nargs--) {
1258                         SSize_t bytes = lens->ssize;
1259                         SSize_t chars;
1260                         if (bytes <= 0)
1261                             chars = bytes;
1262                         else {
1263                             /* return char lengths rather than byte lengths */
1264                             chars = utf8_length(p, p + bytes);
1265                             p += bytes;
1266                         }
1267                         lens++;
1268                         PUSHs(sv_2mortal(newSViv(chars)));
1269                     }
1270                 }
1271                 else {
1272                     while (nargs--) {
1273                         PUSHs(sv_2mortal(newSViv(lens->ssize)));
1274                         lens++;
1275                     }
1276                 }
1277                 break;
1278             }
1279
1280         case OP_MULTIDEREF:
1281 #ifdef USE_ITHREADS
1282 #  define ITEM_SV(item) *av_fetch(comppad, (item)->pad_offset, FALSE);
1283 #else
1284 #  define ITEM_SV(item) UNOP_AUX_item_sv(item)
1285 #endif
1286             {
1287                 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1288                 UV actions = items->uv;
1289                 UV len = items[-1].uv;
1290                 SV *sv;
1291                 bool last = 0;
1292                 bool is_hash = FALSE;
1293 #ifdef USE_ITHREADS
1294                 PADLIST * const padlist = CvPADLIST(cv);
1295                 PAD *comppad = PadlistARRAY(padlist)[1];
1296 #endif
1297
1298                 /* len should never be big enough to truncate or wrap */
1299                 assert(len <= SSize_t_MAX);
1300                 EXTEND(SP, (SSize_t)len);
1301                 PUSHs(sv_2mortal(newSViv(actions)));
1302
1303                 while (!last) {
1304                     switch (actions & MDEREF_ACTION_MASK) {
1305
1306                     case MDEREF_reload:
1307                         actions = (++items)->uv;
1308                         PUSHs(sv_2mortal(newSVuv(actions)));
1309                         continue;
1310                         NOT_REACHED; /* NOTREACHED */
1311
1312                     case MDEREF_HV_padhv_helem:
1313                         is_hash = TRUE;
1314                         /* FALLTHROUGH */
1315                     case MDEREF_AV_padav_aelem:
1316                         PUSHs(sv_2mortal(newSVuv((++items)->pad_offset)));
1317                         goto do_elem;
1318                         NOT_REACHED; /* NOTREACHED */
1319
1320                     case MDEREF_HV_gvhv_helem:
1321                         is_hash = TRUE;
1322                         /* FALLTHROUGH */
1323                     case MDEREF_AV_gvav_aelem:
1324                         sv = ITEM_SV(++items);
1325                         PUSHs(make_sv_object(aTHX_ sv));
1326                         goto do_elem;
1327                         NOT_REACHED; /* NOTREACHED */
1328
1329                     case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1330                         is_hash = TRUE;
1331                         /* FALLTHROUGH */
1332                     case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1333                         sv = ITEM_SV(++items);
1334                         PUSHs(make_sv_object(aTHX_ sv));
1335                         goto do_vivify_rv2xv_elem;
1336                         NOT_REACHED; /* NOTREACHED */
1337
1338                     case MDEREF_HV_padsv_vivify_rv2hv_helem:
1339                         is_hash = TRUE;
1340                         /* FALLTHROUGH */
1341                     case MDEREF_AV_padsv_vivify_rv2av_aelem:
1342                         PUSHs(sv_2mortal(newSVuv((++items)->pad_offset)));
1343                         goto do_vivify_rv2xv_elem;
1344                         NOT_REACHED; /* NOTREACHED */
1345
1346                     case MDEREF_HV_pop_rv2hv_helem:
1347                     case MDEREF_HV_vivify_rv2hv_helem:
1348                         is_hash = TRUE;
1349                         /* FALLTHROUGH */
1350                     do_vivify_rv2xv_elem:
1351                     case MDEREF_AV_pop_rv2av_aelem:
1352                     case MDEREF_AV_vivify_rv2av_aelem:
1353                     do_elem:
1354                         switch (actions & MDEREF_INDEX_MASK) {
1355                         case MDEREF_INDEX_none:
1356                             last = 1;
1357                             break;
1358                         case MDEREF_INDEX_const:
1359                             if (is_hash) {
1360                                 sv = ITEM_SV(++items);
1361                                 PUSHs(make_sv_object(aTHX_ sv));
1362                             }
1363                             else
1364                                 PUSHs(sv_2mortal(newSViv((++items)->iv)));
1365                             break;
1366                         case MDEREF_INDEX_padsv:
1367                             PUSHs(sv_2mortal(newSVuv((++items)->pad_offset)));
1368                             break;
1369                         case MDEREF_INDEX_gvsv:
1370                             sv = ITEM_SV(++items);
1371                             PUSHs(make_sv_object(aTHX_ sv));
1372                             break;
1373                         }
1374                         if (actions & MDEREF_FLAG_last)
1375                             last = 1;
1376                         is_hash = FALSE;
1377
1378                         break;
1379                     } /* switch */
1380
1381                     actions >>= MDEREF_SHIFT;
1382                 } /* while */
1383                 XSRETURN(len);
1384
1385             } /* OP_MULTIDEREF */
1386         } /* switch */
1387
1388
1389
1390 MODULE = B      PACKAGE = B::SV
1391
1392 #define MAGICAL_FLAG_BITS (SVs_GMG|SVs_SMG|SVs_RMG)
1393
1394 U32
1395 REFCNT(sv)
1396         B::SV   sv
1397     ALIAS:
1398         FLAGS = 0xFFFFFFFF
1399         SvTYPE = SVTYPEMASK
1400         POK = SVf_POK
1401         ROK = SVf_ROK
1402         MAGICAL = MAGICAL_FLAG_BITS
1403     CODE:
1404         RETVAL = ix ? (SvFLAGS(sv) & (U32)ix) : SvREFCNT(sv);
1405     OUTPUT:
1406         RETVAL
1407
1408 void
1409 object_2svref(sv)
1410         B::SV   sv
1411     PPCODE:
1412         ST(0) = sv_2mortal(newRV(sv));
1413         XSRETURN(1);
1414         
1415 MODULE = B      PACKAGE = B::IV         PREFIX = Sv
1416
1417 IV
1418 SvIV(sv)
1419         B::IV   sv
1420
1421 MODULE = B      PACKAGE = B::IV
1422
1423 #define sv_SVp          0x00000
1424 #define sv_IVp          0x10000
1425 #define sv_UVp          0x20000
1426 #define sv_STRLENp      0x30000
1427 #define sv_U32p         0x40000
1428 #define sv_U8p          0x50000
1429 #define sv_char_pp      0x60000
1430 #define sv_NVp          0x70000
1431 #define sv_char_p       0x80000
1432 #define sv_SSize_tp     0x90000
1433 #define sv_I32p         0xA0000
1434 #define sv_U16p         0xB0000
1435
1436 #define IV_ivx_ix       sv_IVp | STRUCT_OFFSET(struct xpviv, xiv_iv)
1437 #define IV_uvx_ix       sv_UVp | STRUCT_OFFSET(struct xpvuv, xuv_uv)
1438 #define NV_nvx_ix       sv_NVp | STRUCT_OFFSET(struct xpvnv, xnv_u.xnv_nv)
1439
1440 #define PV_cur_ix       sv_STRLENp | STRUCT_OFFSET(struct xpv, xpv_cur)
1441 #define PV_len_ix       sv_STRLENp | STRUCT_OFFSET(struct xpv, xpv_len)
1442
1443 #define PVMG_stash_ix   sv_SVp | STRUCT_OFFSET(struct xpvmg, xmg_stash)
1444
1445 #define PVBM_useful_ix  sv_IVp | STRUCT_OFFSET(struct xpviv, xiv_u.xivu_iv)
1446
1447 #define PVLV_targoff_ix sv_U32p | STRUCT_OFFSET(struct xpvlv, xlv_targoff)
1448 #define PVLV_targlen_ix sv_U32p | STRUCT_OFFSET(struct xpvlv, xlv_targlen)
1449 #define PVLV_targ_ix    sv_SVp | STRUCT_OFFSET(struct xpvlv, xlv_targ)
1450 #define PVLV_type_ix    sv_char_p | STRUCT_OFFSET(struct xpvlv, xlv_type)
1451
1452 #define PVGV_stash_ix   sv_SVp | STRUCT_OFFSET(struct xpvgv, xnv_u.xgv_stash)
1453 #define PVGV_flags_ix   sv_STRLENp | STRUCT_OFFSET(struct xpvgv, xpv_cur)
1454 #define PVIO_lines_ix   sv_IVp | STRUCT_OFFSET(struct xpvio, xiv_iv)
1455
1456 #define PVIO_page_ix        sv_IVp | STRUCT_OFFSET(struct xpvio, xio_page)
1457 #define PVIO_page_len_ix    sv_IVp | STRUCT_OFFSET(struct xpvio, xio_page_len)
1458 #define PVIO_lines_left_ix  sv_IVp | STRUCT_OFFSET(struct xpvio, xio_lines_left)
1459 #define PVIO_top_name_ix    sv_char_pp | STRUCT_OFFSET(struct xpvio, xio_top_name)
1460 #define PVIO_top_gv_ix      sv_SVp | STRUCT_OFFSET(struct xpvio, xio_top_gv)
1461 #define PVIO_fmt_name_ix    sv_char_pp | STRUCT_OFFSET(struct xpvio, xio_fmt_name)
1462 #define PVIO_fmt_gv_ix      sv_SVp | STRUCT_OFFSET(struct xpvio, xio_fmt_gv)
1463 #define PVIO_bottom_name_ix sv_char_pp | STRUCT_OFFSET(struct xpvio, xio_bottom_name)
1464 #define PVIO_bottom_gv_ix   sv_SVp | STRUCT_OFFSET(struct xpvio, xio_bottom_gv)
1465 #define PVIO_type_ix        sv_char_p | STRUCT_OFFSET(struct xpvio, xio_type)
1466 #define PVIO_flags_ix       sv_U8p | STRUCT_OFFSET(struct xpvio, xio_flags)
1467
1468 #define PVAV_max_ix     sv_SSize_tp | STRUCT_OFFSET(struct xpvav, xav_max)
1469
1470 #define PVCV_stash_ix   sv_SVp | STRUCT_OFFSET(struct xpvcv, xcv_stash) 
1471 #define PVCV_gv_ix      sv_SVp | STRUCT_OFFSET(struct xpvcv, xcv_gv_u.xcv_gv)
1472 #define PVCV_file_ix    sv_char_pp | STRUCT_OFFSET(struct xpvcv, xcv_file)
1473 #define PVCV_outside_ix sv_SVp | STRUCT_OFFSET(struct xpvcv, xcv_outside)
1474 #define PVCV_outside_seq_ix sv_U32p | STRUCT_OFFSET(struct xpvcv, xcv_outside_seq)
1475 #define PVCV_flags_ix   sv_U32p | STRUCT_OFFSET(struct xpvcv, xcv_flags)
1476
1477 #define PVHV_max_ix     sv_STRLENp | STRUCT_OFFSET(struct xpvhv, xhv_max)
1478 #define PVHV_keys_ix    sv_STRLENp | STRUCT_OFFSET(struct xpvhv, xhv_keys)
1479
1480 # The type checking code in B has always been identical for all SV types,
1481 # irrespective of whether the action is actually defined on that SV.
1482 # We should fix this
1483 void
1484 IVX(sv)
1485         B::SV           sv
1486     ALIAS:
1487         B::IV::IVX = IV_ivx_ix
1488         B::IV::UVX = IV_uvx_ix
1489         B::NV::NVX = NV_nvx_ix
1490         B::PV::CUR = PV_cur_ix
1491         B::PV::LEN = PV_len_ix
1492         B::PVMG::SvSTASH = PVMG_stash_ix
1493         B::PVLV::TARGOFF = PVLV_targoff_ix
1494         B::PVLV::TARGLEN = PVLV_targlen_ix
1495         B::PVLV::TARG = PVLV_targ_ix
1496         B::PVLV::TYPE = PVLV_type_ix
1497         B::GV::STASH = PVGV_stash_ix
1498         B::GV::GvFLAGS = PVGV_flags_ix
1499         B::BM::USEFUL = PVBM_useful_ix
1500         B::IO::LINES =  PVIO_lines_ix
1501         B::IO::PAGE = PVIO_page_ix
1502         B::IO::PAGE_LEN = PVIO_page_len_ix
1503         B::IO::LINES_LEFT = PVIO_lines_left_ix
1504         B::IO::TOP_NAME = PVIO_top_name_ix
1505         B::IO::TOP_GV = PVIO_top_gv_ix
1506         B::IO::FMT_NAME = PVIO_fmt_name_ix
1507         B::IO::FMT_GV = PVIO_fmt_gv_ix
1508         B::IO::BOTTOM_NAME = PVIO_bottom_name_ix
1509         B::IO::BOTTOM_GV = PVIO_bottom_gv_ix
1510         B::IO::IoTYPE = PVIO_type_ix
1511         B::IO::IoFLAGS = PVIO_flags_ix
1512         B::AV::MAX = PVAV_max_ix
1513         B::CV::STASH = PVCV_stash_ix
1514         B::CV::FILE = PVCV_file_ix
1515         B::CV::OUTSIDE = PVCV_outside_ix
1516         B::CV::OUTSIDE_SEQ = PVCV_outside_seq_ix
1517         B::CV::CvFLAGS = PVCV_flags_ix
1518         B::HV::MAX = PVHV_max_ix
1519         B::HV::KEYS = PVHV_keys_ix
1520     PREINIT:
1521         char *ptr;
1522         SV *ret;
1523     PPCODE:
1524         ptr = (ix & 0xFFFF) + (char *)SvANY(sv);
1525         switch ((U8)(ix >> 16)) {
1526         case (U8)(sv_SVp >> 16):
1527             ret = make_sv_object(aTHX_ *((SV **)ptr));
1528             break;
1529         case (U8)(sv_IVp >> 16):
1530             ret = sv_2mortal(newSViv(*((IV *)ptr)));
1531             break;
1532         case (U8)(sv_UVp >> 16):
1533             ret = sv_2mortal(newSVuv(*((UV *)ptr)));
1534             break;
1535         case (U8)(sv_STRLENp >> 16):
1536             ret = sv_2mortal(newSVuv(*((STRLEN *)ptr)));
1537             break;
1538         case (U8)(sv_U32p >> 16):
1539             ret = sv_2mortal(newSVuv(*((U32 *)ptr)));
1540             break;
1541         case (U8)(sv_U8p >> 16):
1542             ret = sv_2mortal(newSVuv(*((U8 *)ptr)));
1543             break;
1544         case (U8)(sv_char_pp >> 16):
1545             ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
1546             break;
1547         case (U8)(sv_NVp >> 16):
1548             ret = sv_2mortal(newSVnv(*((NV *)ptr)));
1549             break;
1550         case (U8)(sv_char_p >> 16):
1551             ret = newSVpvn_flags((char *)ptr, 1, SVs_TEMP);
1552             break;
1553         case (U8)(sv_SSize_tp >> 16):
1554             ret = sv_2mortal(newSViv(*((SSize_t *)ptr)));
1555             break;
1556         case (U8)(sv_I32p >> 16):
1557             ret = sv_2mortal(newSVuv(*((I32 *)ptr)));
1558             break;
1559         case (U8)(sv_U16p >> 16):
1560             ret = sv_2mortal(newSVuv(*((U16 *)ptr)));
1561             break;
1562         default:
1563             croak("Illegal alias 0x%08x for B::*IVX", (unsigned)ix);
1564         }
1565         ST(0) = ret;
1566         XSRETURN(1);
1567
1568 void
1569 packiv(sv)
1570         B::IV   sv
1571     ALIAS:
1572         needs64bits = 1
1573     CODE:
1574         if (ix) {
1575             ST(0) = boolSV((I32)SvIVX(sv) != SvIVX(sv));
1576         } else if (sizeof(IV) == 8) {
1577             U32 wp[2];
1578             const IV iv = SvIVX(sv);
1579             /*
1580              * The following way of spelling 32 is to stop compilers on
1581              * 32-bit architectures from moaning about the shift count
1582              * being >= the width of the type. Such architectures don't
1583              * reach this code anyway (unless sizeof(IV) > 8 but then
1584              * everything else breaks too so I'm not fussed at the moment).
1585              */
1586 #ifdef UV_IS_QUAD
1587             wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1588 #else
1589             wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1590 #endif
1591             wp[1] = htonl(iv & 0xffffffff);
1592             ST(0) = newSVpvn_flags((char *)wp, 8, SVs_TEMP);
1593         } else {
1594             U32 w = htonl((U32)SvIVX(sv));
1595             ST(0) = newSVpvn_flags((char *)&w, 4, SVs_TEMP);
1596         }
1597
1598 MODULE = B      PACKAGE = B::NV         PREFIX = Sv
1599
1600 NV
1601 SvNV(sv)
1602         B::NV   sv
1603
1604 MODULE = B      PACKAGE = B::REGEXP
1605
1606 void
1607 REGEX(sv)
1608         B::REGEXP       sv
1609     ALIAS:
1610         precomp = 1
1611         qr_anoncv = 2
1612         compflags = 3
1613     PPCODE:
1614         if (ix == 1) {
1615             PUSHs(newSVpvn_flags(RX_PRECOMP(sv), RX_PRELEN(sv), SVs_TEMP));
1616         } else if (ix == 2) {
1617             PUSHs(make_sv_object(aTHX_ (SV *)ReANY(sv)->qr_anoncv));
1618         } else {
1619             dXSTARG;
1620             if (ix)
1621                 PUSHu(RX_COMPFLAGS(sv));
1622             else
1623             /* FIXME - can we code this method more efficiently?  */
1624                 PUSHi(PTR2IV(sv));
1625         }
1626
1627 MODULE = B      PACKAGE = B::PV
1628
1629 void
1630 RV(sv)
1631         B::PV   sv
1632     PPCODE:
1633         if (!SvROK(sv))
1634             croak( "argument is not SvROK" );
1635         PUSHs(make_sv_object(aTHX_ SvRV(sv)));
1636
1637 void
1638 PV(sv)
1639         B::PV   sv
1640     ALIAS:
1641         PVX = 1
1642         PVBM = 2
1643         B::BM::TABLE = 3
1644     PREINIT:
1645         const char *p;
1646         STRLEN len = 0;
1647         U32 utf8 = 0;
1648     CODE:
1649         if (ix == 3) {
1650             const MAGIC *const mg = mg_find(sv, PERL_MAGIC_bm);
1651
1652             if (!mg)
1653                 croak("argument to B::BM::TABLE is not a PVBM");
1654             p = mg->mg_ptr;
1655             len = mg->mg_len;
1656         } else if (ix == 2) {
1657             /* This used to read 257. I think that that was buggy - should have
1658                been 258. (The "\0", the flags byte, and 256 for the table.)
1659                The only user of this method is B::Bytecode in B::PV::bsave.
1660                I'm guessing that nothing tested the runtime correctness of
1661                output of bytecompiled string constant arguments to index (etc).
1662
1663                Note the start pointer is and has always been SvPVX(sv), not
1664                SvPVX(sv) + SvCUR(sv) PVBM was added in 651aa52ea1faa806, and
1665                first used by the compiler in 651aa52ea1faa806. It's used to
1666                get a "complete" dump of the buffer at SvPVX(), not just the
1667                PVBM table. This permits the generated bytecode to "load"
1668                SvPVX in "one" hit.
1669
1670                5.15 and later store the BM table via MAGIC, so the compiler
1671                should handle this just fine without changes if PVBM now
1672                always returns the SvPVX() buffer.  */
1673             p = isREGEXP(sv)
1674                  ? RX_WRAPPED_const((REGEXP*)sv)
1675                  : SvPVX_const(sv);
1676             len = SvCUR(sv);
1677         } else if (ix) {
1678             p = isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX(sv);
1679             len = strlen(p);
1680         } else if (SvPOK(sv)) {
1681             len = SvCUR(sv);
1682             p = SvPVX_const(sv);
1683             utf8 = SvUTF8(sv);
1684         } else if (isREGEXP(sv)) {
1685             len = SvCUR(sv);
1686             p = RX_WRAPPED_const((REGEXP*)sv);
1687             utf8 = SvUTF8(sv);
1688         } else {
1689             /* XXX for backward compatibility, but should fail */
1690             /* croak( "argument is not SvPOK" ); */
1691             p = NULL;
1692         }
1693         ST(0) = newSVpvn_flags(p, len, SVs_TEMP | utf8);
1694
1695 MODULE = B      PACKAGE = B::PVMG
1696
1697 void
1698 MAGIC(sv)
1699         B::PVMG sv
1700         MAGIC * mg = NO_INIT
1701     PPCODE:
1702         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
1703             XPUSHs(make_mg_object(aTHX_ mg));
1704
1705 MODULE = B      PACKAGE = B::MAGIC
1706
1707 void
1708 MOREMAGIC(mg)
1709         B::MAGIC        mg
1710     ALIAS:
1711         PRIVATE = 1
1712         TYPE = 2
1713         FLAGS = 3
1714         LENGTH = 4
1715         OBJ = 5
1716         PTR = 6
1717         REGEX = 7
1718         precomp = 8
1719     PPCODE:
1720         switch (ix) {
1721         case 0:
1722             XPUSHs(mg->mg_moremagic ? make_mg_object(aTHX_ mg->mg_moremagic)
1723                                     : &PL_sv_undef);
1724             break;
1725         case 1:
1726             mPUSHu(mg->mg_private);
1727             break;
1728         case 2:
1729             PUSHs(newSVpvn_flags(&(mg->mg_type), 1, SVs_TEMP));
1730             break;
1731         case 3:
1732             mPUSHu(mg->mg_flags);
1733             break;
1734         case 4:
1735             mPUSHi(mg->mg_len);
1736             break;
1737         case 5:
1738             PUSHs(make_sv_object(aTHX_ mg->mg_obj));
1739             break;
1740         case 6:
1741             if (mg->mg_ptr) {
1742                 if (mg->mg_len >= 0) {
1743                     PUSHs(newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP));
1744                 } else if (mg->mg_len == HEf_SVKEY) {
1745                     PUSHs(make_sv_object(aTHX_ (SV*)mg->mg_ptr));
1746                 } else
1747                     PUSHs(sv_newmortal());
1748             } else
1749                 PUSHs(sv_newmortal());
1750             break;
1751         case 7:
1752             if(mg->mg_type == PERL_MAGIC_qr) {
1753                 mPUSHi(PTR2IV(mg->mg_obj));
1754             } else {
1755                 croak("REGEX is only meaningful on r-magic");
1756             }
1757             break;
1758         case 8:
1759             if (mg->mg_type == PERL_MAGIC_qr) {
1760                 REGEXP *rx = (REGEXP *)mg->mg_obj;
1761                 PUSHs(newSVpvn_flags(rx ? RX_PRECOMP(rx) : NULL,
1762                                      rx ? RX_PRELEN(rx) : 0, SVs_TEMP));
1763             } else {
1764                 croak( "precomp is only meaningful on r-magic" );
1765             }
1766             break;
1767         }
1768
1769 MODULE = B      PACKAGE = B::BM         PREFIX = Bm
1770
1771 U32
1772 BmPREVIOUS(sv)
1773         B::BM   sv
1774     CODE:
1775         PERL_UNUSED_VAR(sv);
1776         RETVAL = BmPREVIOUS(sv);
1777     OUTPUT:
1778         RETVAL
1779
1780
1781 U8
1782 BmRARE(sv)
1783         B::BM   sv
1784     CODE:
1785         PERL_UNUSED_VAR(sv);
1786         RETVAL = BmRARE(sv);
1787     OUTPUT:
1788         RETVAL
1789
1790
1791 MODULE = B      PACKAGE = B::GV         PREFIX = Gv
1792
1793 void
1794 GvNAME(gv)
1795         B::GV   gv
1796     ALIAS:
1797         FILE = 1
1798         B::HV::NAME = 2
1799     CODE:
1800         ST(0) = sv_2mortal(newSVhek(!ix ? GvNAME_HEK(gv)
1801                                         : (ix == 1 ? GvFILE_HEK(gv)
1802                                                    : HvNAME_HEK((HV *)gv))));
1803
1804 bool
1805 is_empty(gv)
1806         B::GV   gv
1807     ALIAS:
1808         isGV_with_GP = 1
1809     CODE:
1810         if (ix) {
1811             RETVAL = cBOOL(isGV_with_GP(gv));
1812         } else {
1813             RETVAL = GvGP(gv) == Null(GP*);
1814         }
1815     OUTPUT:
1816         RETVAL
1817
1818 void*
1819 GvGP(gv)
1820         B::GV   gv
1821
1822 #define GP_sv_ix        (SVp << 16) | STRUCT_OFFSET(struct gp, gp_sv)
1823 #define GP_io_ix        (SVp << 16) | STRUCT_OFFSET(struct gp, gp_io)
1824 #define GP_cv_ix        (SVp << 16) | STRUCT_OFFSET(struct gp, gp_cv)
1825 #define GP_cvgen_ix     (U32p << 16) | STRUCT_OFFSET(struct gp, gp_cvgen)
1826 #define GP_refcnt_ix    (U32p << 16) | STRUCT_OFFSET(struct gp, gp_refcnt)
1827 #define GP_hv_ix        (SVp << 16) | STRUCT_OFFSET(struct gp, gp_hv)
1828 #define GP_av_ix        (SVp << 16) | STRUCT_OFFSET(struct gp, gp_av)
1829 #define GP_form_ix      (SVp << 16) | STRUCT_OFFSET(struct gp, gp_form)
1830 #define GP_egv_ix       (SVp << 16) | STRUCT_OFFSET(struct gp, gp_egv)
1831
1832 void
1833 SV(gv)
1834         B::GV   gv
1835     ALIAS:
1836         SV = GP_sv_ix
1837         IO = GP_io_ix
1838         CV = GP_cv_ix
1839         CVGEN = GP_cvgen_ix
1840         GvREFCNT = GP_refcnt_ix
1841         HV = GP_hv_ix
1842         AV = GP_av_ix
1843         FORM = GP_form_ix
1844         EGV = GP_egv_ix
1845     PREINIT:
1846         GP *gp;
1847         char *ptr;
1848         SV *ret;
1849     PPCODE:
1850         gp = GvGP(gv);
1851         if (!gp) {
1852             const GV *const gv = CvGV(cv);
1853             Perl_croak(aTHX_ "NULL gp in B::GV::%s", gv ? GvNAME(gv) : "???");
1854         }
1855         ptr = (ix & 0xFFFF) + (char *)gp;
1856         switch ((U8)(ix >> 16)) {
1857         case SVp:
1858             ret = make_sv_object(aTHX_ *((SV **)ptr));
1859             break;
1860         case U32p:
1861             ret = sv_2mortal(newSVuv(*((U32*)ptr)));
1862             break;
1863         default:
1864             croak("Illegal alias 0x%08x for B::*SV", (unsigned)ix);
1865         }
1866         ST(0) = ret;
1867         XSRETURN(1);
1868
1869 U32
1870 GvLINE(gv)
1871         B::GV   gv
1872
1873 U32
1874 GvGPFLAGS(gv)
1875         B::GV   gv
1876
1877 void
1878 FILEGV(gv)
1879         B::GV   gv
1880     PPCODE:
1881         PUSHs(make_sv_object(aTHX_ (SV *)GvFILEGV(gv)));
1882
1883 MODULE = B      PACKAGE = B::IO         PREFIX = Io
1884
1885
1886 bool
1887 IsSTD(io,name)
1888         B::IO   io
1889         const char*     name
1890     PREINIT:
1891         PerlIO* handle = 0;
1892     CODE:
1893         if( strEQ( name, "stdin" ) ) {
1894             handle = PerlIO_stdin();
1895         }
1896         else if( strEQ( name, "stdout" ) ) {
1897             handle = PerlIO_stdout();
1898         }
1899         else if( strEQ( name, "stderr" ) ) {
1900             handle = PerlIO_stderr();
1901         }
1902         else {
1903             croak( "Invalid value '%s'", name );
1904         }
1905         RETVAL = handle == IoIFP(io);
1906     OUTPUT:
1907         RETVAL
1908
1909 MODULE = B      PACKAGE = B::AV         PREFIX = Av
1910
1911 SSize_t
1912 AvFILL(av)
1913         B::AV   av
1914
1915 void
1916 AvARRAY(av)
1917         B::AV   av
1918     PPCODE:
1919         if (AvFILL(av) >= 0) {
1920             SV **svp = AvARRAY(av);
1921             I32 i;
1922             for (i = 0; i <= AvFILL(av); i++)
1923                 XPUSHs(make_sv_object(aTHX_ svp[i]));
1924         }
1925
1926 void
1927 AvARRAYelt(av, idx)
1928         B::AV   av
1929         int     idx
1930     PPCODE:
1931         if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
1932             XPUSHs(make_sv_object(aTHX_ (AvARRAY(av)[idx])));
1933         else
1934             XPUSHs(make_sv_object(aTHX_ NULL));
1935
1936
1937 MODULE = B      PACKAGE = B::FM         PREFIX = Fm
1938
1939 IV
1940 FmLINES(format)
1941         B::FM   format
1942     CODE:
1943         PERL_UNUSED_VAR(format);
1944        RETVAL = 0;
1945     OUTPUT:
1946         RETVAL
1947
1948
1949 MODULE = B      PACKAGE = B::CV         PREFIX = Cv
1950
1951 U32
1952 CvCONST(cv)
1953         B::CV   cv
1954
1955 void
1956 CvSTART(cv)
1957         B::CV   cv
1958     ALIAS:
1959         ROOT = 1
1960     PPCODE:
1961         PUSHs(make_op_object(aTHX_ CvISXSUB(cv) ? NULL
1962                              : ix ? CvROOT(cv) : CvSTART(cv)));
1963
1964 I32
1965 CvDEPTH(cv)
1966         B::CV   cv
1967
1968 B::PADLIST
1969 CvPADLIST(cv)
1970         B::CV   cv
1971     CODE:
1972         RETVAL = CvISXSUB(cv) ? NULL : CvPADLIST(cv);
1973     OUTPUT:
1974         RETVAL
1975
1976 SV *
1977 CvHSCXT(cv)
1978         B::CV   cv
1979     CODE:
1980         RETVAL = newSVuv(CvISXSUB(cv) ? PTR2UV(CvHSCXT(cv)) : 0);
1981     OUTPUT:
1982         RETVAL
1983
1984 void
1985 CvXSUB(cv)
1986         B::CV   cv
1987     ALIAS:
1988         XSUBANY = 1
1989     CODE:
1990         ST(0) = ix && CvCONST(cv)
1991             ? make_sv_object(aTHX_ (SV *)CvXSUBANY(cv).any_ptr)
1992             : sv_2mortal(newSViv(CvISXSUB(cv)
1993                                  ? (ix ? CvXSUBANY(cv).any_iv
1994                                        : PTR2IV(CvXSUB(cv)))
1995                                  : 0));
1996
1997 void
1998 const_sv(cv)
1999         B::CV   cv
2000     PPCODE:
2001         PUSHs(make_sv_object(aTHX_ (SV *)cv_const_sv(cv)));
2002
2003 void
2004 GV(cv)
2005         B::CV cv
2006     CODE:
2007         ST(0) = make_sv_object(aTHX_ (SV*)CvGV(cv));
2008
2009 SV *
2010 NAME_HEK(cv)
2011         B::CV cv
2012     CODE:
2013         RETVAL = CvNAMED(cv) ? newSVhek(CvNAME_HEK(cv)) : &PL_sv_undef;
2014     OUTPUT:
2015         RETVAL
2016
2017 MODULE = B      PACKAGE = B::HV         PREFIX = Hv
2018
2019 STRLEN
2020 HvFILL(hv)
2021         B::HV   hv
2022
2023 I32
2024 HvRITER(hv)
2025         B::HV   hv
2026
2027 void
2028 HvARRAY(hv)
2029         B::HV   hv
2030     PPCODE:
2031         if (HvUSEDKEYS(hv) > 0) {
2032             HE *he;
2033             SSize_t extend_size;
2034             (void)hv_iterinit(hv);
2035             /* 2*HvUSEDKEYS() should never be big enough to truncate or wrap */
2036             assert(HvUSEDKEYS(hv) <= (SSize_t_MAX >> 1));
2037             extend_size = (SSize_t)HvUSEDKEYS(hv) * 2;
2038             EXTEND(sp, extend_size);
2039             while ((he = hv_iternext(hv))) {
2040                 if (HeSVKEY(he)) {
2041                     mPUSHs(HeSVKEY(he));
2042                 } else if (HeKUTF8(he)) {
2043                     PUSHs(newSVpvn_flags(HeKEY(he), HeKLEN(he), SVf_UTF8|SVs_TEMP));
2044                 } else {
2045                     mPUSHp(HeKEY(he), HeKLEN(he));
2046                 }
2047                 PUSHs(make_sv_object(aTHX_ HeVAL(he)));
2048             }
2049         }
2050
2051 MODULE = B      PACKAGE = B::HE         PREFIX = He
2052
2053 void
2054 HeVAL(he)
2055         B::HE he
2056     ALIAS:
2057         SVKEY_force = 1
2058     PPCODE:
2059         PUSHs(make_sv_object(aTHX_ ix ? HeSVKEY_force(he) : HeVAL(he)));
2060
2061 U32
2062 HeHASH(he)
2063         B::HE he
2064
2065 MODULE = B      PACKAGE = B::RHE
2066
2067 SV*
2068 HASH(h)
2069         B::RHE h
2070     CODE:
2071         RETVAL = newRV_noinc( (SV*)cophh_2hv(h, 0) );
2072     OUTPUT:
2073         RETVAL
2074
2075
2076 MODULE = B      PACKAGE = B::PADLIST    PREFIX = Padlist
2077
2078 SSize_t
2079 PadlistMAX(padlist)
2080         B::PADLIST      padlist
2081     ALIAS: B::PADNAMELIST::MAX = 0
2082     CODE:
2083         PERL_UNUSED_VAR(ix);
2084         RETVAL = PadlistMAX(padlist);
2085     OUTPUT:
2086         RETVAL
2087
2088 B::PADNAMELIST
2089 PadlistNAMES(padlist)
2090         B::PADLIST      padlist
2091
2092 void
2093 PadlistARRAY(padlist)
2094         B::PADLIST      padlist
2095     PPCODE:
2096         if (PadlistMAX(padlist) >= 0) {
2097             dXSTARG;
2098             PAD **padp = PadlistARRAY(padlist);
2099             SSize_t i;
2100             sv_setiv(newSVrv(TARG, PadlistNAMES(padlist)
2101                                     ? "B::PADNAMELIST"
2102                                     : "B::NULL"),
2103                      PTR2IV(PadlistNAMES(padlist)));
2104             XPUSHTARG;
2105             for (i = 1; i <= PadlistMAX(padlist); i++)
2106                 XPUSHs(make_sv_object(aTHX_ (SV *)padp[i]));
2107         }
2108
2109 void
2110 PadlistARRAYelt(padlist, idx)
2111         B::PADLIST      padlist
2112         SSize_t         idx
2113     PPCODE:
2114         if (idx < 0 || idx > PadlistMAX(padlist))
2115             XPUSHs(make_sv_object(aTHX_ NULL));
2116         else if (!idx) {
2117             PL_stack_sp--;
2118             PUSHMARK(PL_stack_sp-1);
2119             XS_B__PADLIST_NAMES(aTHX_ cv);
2120             return;
2121         }
2122         else
2123             XPUSHs(make_sv_object(aTHX_
2124                                   (SV *)PadlistARRAY(padlist)[idx]));
2125
2126 U32
2127 PadlistREFCNT(padlist)
2128         B::PADLIST      padlist
2129     CODE:
2130         PERL_UNUSED_VAR(padlist);
2131         RETVAL = PadlistREFCNT(padlist);
2132     OUTPUT:
2133         RETVAL
2134
2135 MODULE = B      PACKAGE = B::PADNAMELIST        PREFIX = Padnamelist
2136
2137 void
2138 PadnamelistARRAY(pnl)
2139         B::PADNAMELIST  pnl
2140     PPCODE:
2141         if (PadnamelistMAX(pnl) >= 0) {
2142             PADNAME **padp = PadnamelistARRAY(pnl);
2143             SSize_t i = 0;
2144             for (; i <= PadnamelistMAX(pnl); i++)
2145             {
2146                 SV *rv = sv_newmortal();
2147                 sv_setiv(newSVrv(rv,padp[i] ? "B::PADNAME" : "B::SPECIAL"),
2148                          PTR2IV(padp[i]));
2149                 XPUSHs(rv);
2150             }
2151         }
2152
2153 B::PADNAME
2154 PadnamelistARRAYelt(pnl, idx)
2155         B::PADNAMELIST  pnl
2156         SSize_t         idx
2157     CODE:
2158         if (idx < 0 || idx > PadnamelistMAX(pnl))
2159             RETVAL = NULL;
2160         else
2161             RETVAL = PadnamelistARRAY(pnl)[idx];
2162     OUTPUT:
2163         RETVAL
2164
2165 MODULE = B      PACKAGE = B::PADNAME    PREFIX = Padname
2166
2167 #define PN_type_ix \
2168         sv_SVp | STRUCT_OFFSET(struct padname,xpadn_type_u.xpadn_typestash)
2169 #define PN_ourstash_ix \
2170         sv_SVp | STRUCT_OFFSET(struct padname,xpadn_ourstash)
2171 #define PN_len_ix \
2172         sv_U8p | STRUCT_OFFSET(struct padname,xpadn_len)
2173 #define PN_refcnt_ix \
2174         sv_U32p | STRUCT_OFFSET(struct padname, xpadn_refcnt)
2175 #define PN_cop_seq_range_low_ix \
2176         sv_U32p | STRUCT_OFFSET(struct padname, xpadn_low)
2177 #define PN_cop_seq_range_high_ix \
2178         sv_U32p | STRUCT_OFFSET(struct padname, xpadn_high)
2179 #define PNL_refcnt_ix \
2180         sv_U32p | STRUCT_OFFSET(struct padnamelist, xpadnl_refcnt)
2181 #define PL_id_ix \
2182         sv_U32p | STRUCT_OFFSET(struct padlist, xpadl_id)
2183 #define PL_outid_ix \
2184         sv_U32p | STRUCT_OFFSET(struct padlist, xpadl_outid)
2185
2186
2187 void
2188 PadnameTYPE(pn)
2189         B::PADNAME      pn
2190     ALIAS:
2191         B::PADNAME::TYPE        = PN_type_ix
2192         B::PADNAME::OURSTASH    = PN_ourstash_ix
2193         B::PADNAME::LEN         = PN_len_ix
2194         B::PADNAME::REFCNT      = PN_refcnt_ix
2195         B::PADNAME::COP_SEQ_RANGE_LOW    = PN_cop_seq_range_low_ix
2196         B::PADNAME::COP_SEQ_RANGE_HIGH   = PN_cop_seq_range_high_ix
2197         B::PADNAMELIST::REFCNT  = PNL_refcnt_ix
2198         B::PADLIST::id          = PL_id_ix
2199         B::PADLIST::outid       = PL_outid_ix
2200     PREINIT:
2201         char *ptr;
2202         SV *ret;
2203     PPCODE:
2204         ptr = (ix & 0xFFFF) + (char *)pn;
2205         switch ((U8)(ix >> 16)) {
2206         case (U8)(sv_SVp >> 16):
2207             ret = make_sv_object(aTHX_ *((SV **)ptr));
2208             break;
2209         case (U8)(sv_U32p >> 16):
2210             ret = sv_2mortal(newSVuv(*((U32 *)ptr)));
2211             break;
2212         case (U8)(sv_U8p >> 16):
2213             ret = sv_2mortal(newSVuv(*((U8 *)ptr)));
2214             break;
2215         default:
2216             NOT_REACHED;
2217         }
2218         ST(0) = ret;
2219         XSRETURN(1);
2220
2221 SV *
2222 PadnamePV(pn)
2223         B::PADNAME      pn
2224     PREINIT:
2225         dXSTARG;
2226     PPCODE:
2227         PERL_UNUSED_ARG(RETVAL);
2228         sv_setpvn(TARG, PadnamePV(pn), PadnameLEN(pn));
2229         SvUTF8_on(TARG);
2230         XPUSHTARG;
2231
2232 BOOT:
2233 {
2234     /* Uses less memory than an ALIAS.  */
2235     GV *gv = gv_fetchpvs("B::PADNAME::TYPE", 1, SVt_PVGV);
2236     sv_setsv((SV *)gv_fetchpvs("B::PADNAME::SvSTASH",1,SVt_PVGV),(SV *)gv);
2237     sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PROTOCV",1,SVt_PVGV),(SV *)gv);
2238     sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PVX",1,SVt_PVGV),
2239              (SV *)gv_fetchpvs("B::PADNAME::PV" ,1,SVt_PVGV));
2240     sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PARENT_PAD_INDEX" ,1,SVt_PVGV),
2241              (SV *)gv_fetchpvs("B::PADNAME::COP_SEQ_RANGE_LOW",1,
2242                                 SVt_PVGV));
2243     sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PARENT_FAKELEX_FLAGS",1,
2244                                 SVt_PVGV),
2245              (SV *)gv_fetchpvs("B::PADNAME::COP_SEQ_RANGE_HIGH"  ,1,
2246                                 SVt_PVGV));
2247 }
2248
2249 U32
2250 PadnameFLAGS(pn)
2251         B::PADNAME      pn
2252     CODE:
2253         RETVAL = PadnameFLAGS(pn);
2254         /* backward-compatibility hack, which should be removed if the
2255            flags field becomes large enough to hold SVf_FAKE (and
2256            PADNAMEt_OUTER should be renumbered to match SVf_FAKE) */
2257         STATIC_ASSERT_STMT(SVf_FAKE >= 1<<(sizeof(PadnameFLAGS((B__PADNAME)NULL)) * 8));
2258         if (PadnameOUTER(pn))
2259             RETVAL |= SVf_FAKE;
2260     OUTPUT:
2261         RETVAL