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