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