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