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