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