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