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