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 (o->op_flags & OPf_SPECIAL)
 129             return OPc_BASEOP;
 130         else
 131 #ifdef USE_ITHREADS
 132             return OPc_PADOP;
 133 #else
 134             return OPc_SVOP;
 135 #endif
 136     }
 137
 138 #ifdef USE_ITHREADS
 139     if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
 140         o->op_type == OP_RCATLINE)
 141         return OPc_PADOP;
 142 #endif
 143
 144     if (o->op_type == OP_CUSTOM)
 145         custom = 1;
 146
 147     switch (OP_CLASS(o)) {
 148     case OA_BASEOP:
 149         return OPc_BASEOP;
 150
 151     case OA_UNOP:
 152         return OPc_UNOP;
 153
 154     case OA_BINOP:
 155         return OPc_BINOP;
 156
 157     case OA_LOGOP:
 158         return OPc_LOGOP;
 159
 160     case OA_LISTOP:
 161         return OPc_LISTOP;
 162
 163     case OA_PMOP:
 164         return OPc_PMOP;
 165
 166     case OA_SVOP:
 167         return OPc_SVOP;
 168
 169     case OA_PADOP:
 170         return OPc_PADOP;
 171
 172     case OA_PVOP_OR_SVOP:
 173         /*
 174          * Character translations (tr///) are usually a PVOP, keeping a
 175          * pointer to a table of shorts used to look up translations.
 176          * Under utf8, however, a simple table isn't practical; instead,
 177          * the OP is an SVOP (or, under threads, a PADOP),
 178          * and the SV is a reference to a swash
 179          * (i.e., an RV pointing to an HV).
 180          */
 181         return (!custom &&
 182                    (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
 183                )
 184 #if  defined(USE_ITHREADS) \
 185   && (PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION >= 9))
 186                 ? OPc_PADOP : OPc_PVOP;
 187 #else
 188                 ? OPc_SVOP : OPc_PVOP;
 189 #endif
 190
 191     case OA_LOOP:
 192         return OPc_LOOP;
 193
 194     case OA_COP:
 195         return OPc_COP;
 196
 197     case OA_BASEOP_OR_UNOP:
 198         /*
 199          * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
 200          * whether parens were seen. perly.y uses OPf_SPECIAL to
 201          * signal whether a BASEOP had empty parens or none.
 202          * Some other UNOPs are created later, though, so the best
 203          * test is OPf_KIDS, which is set in newUNOP.
 204          */
 205         return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
 206
 207     case OA_FILESTATOP:
 208         /*
 209          * The file stat OPs are created via UNI(OP_foo) in toke.c but use
 210          * the OPf_REF flag to distinguish between OP types instead of the
 211          * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
 212          * return OPc_UNOP so that walkoptree can find our children. If
 213          * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
 214          * (no argument to the operator) it's an OP; with OPf_REF set it's
 215          * an SVOP (and op_sv is the GV for the filehandle argument).
 216          */
 217         return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
 218 #ifdef USE_ITHREADS
 219                 (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
 220 #else
 221                 (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
 222 #endif
 223     case OA_LOOPEXOP:
 224         /*
 225          * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
 226          * label was omitted (in which case it's a BASEOP) or else a term was
 227          * seen. In this last case, all except goto are definitely PVOP but
 228          * goto is either a PVOP (with an ordinary constant label), an UNOP
 229          * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
 230          * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
 231          * get set.
 232          */
 233         if (o->op_flags & OPf_STACKED)
 234             return OPc_UNOP;
 235         else if (o->op_flags & OPf_SPECIAL)
 236             return OPc_BASEOP;
 237         else
 238             return OPc_PVOP;
 239     }
 240     warn("can't determine class of operator %s, assuming BASEOP\n",
 241          OP_NAME(o));
 242     return OPc_BASEOP;
 243 }
 244
 245 static SV *
 246 make_op_object(pTHX_ const OP *o)
 247 {
 248     SV *opsv = sv_newmortal();
 249     sv_setiv(newSVrv(opsv, opclassnames[cc_opclass(aTHX_ o)]), PTR2IV(o));
 250     return opsv;
 251 }
 252
 253 static SV *
 254 make_sv_object(pTHX_ SV *sv)
 255 {
 256     SV *const arg = sv_newmortal();
 257     const char *type = 0;
 258     IV iv;
 259     dMY_CXT;
 260
 261     for (iv = 0; iv < (IV)(sizeof(specialsv_list)/sizeof(SV*)); iv++) {
 262         if (sv == specialsv_list[iv]) {
 263             type = "B::SPECIAL";
 264             break;
 265         }
 266     }
 267     if (!type) {
 268         type = svclassnames[SvTYPE(sv)];
 269         iv = PTR2IV(sv);
 270     }
 271     sv_setiv(newSVrv(arg, type), iv);
 272     return arg;
 273 }
 274
 275 #if PERL_VERSION >= 9
 276 static SV *
 277 make_temp_object(pTHX_ SV *temp)
 278 {
 279     SV *target;
 280     SV *arg = sv_newmortal();
 281     const char *const type = svclassnames[SvTYPE(temp)];
 282     const IV iv = PTR2IV(temp);
 283
 284     target = newSVrv(arg, type);
 285     sv_setiv(target, iv);
 286
 287     /* Need to keep our "temp" around as long as the target exists.
 288        Simplest way seems to be to hang it from magic, and let that clear
 289        it up.  No vtable, so won't actually get in the way of anything.  */
 290     sv_magicext(target, temp, PERL_MAGIC_sv, NULL, NULL, 0);
 291     /* magic object has had its reference count increased, so we must drop
 292        our reference.  */
 293     SvREFCNT_dec(temp);
 294     return arg;
 295 }
 296
 297 static SV *
 298 make_warnings_object(pTHX_ const COP *const cop)
 299 {
 300     const STRLEN *const warnings = cop->cop_warnings;
 301     const char *type = 0;
 302     dMY_CXT;
 303     IV iv = sizeof(specialsv_list)/sizeof(SV*);
 304
 305     /* Counting down is deliberate. Before the split between make_sv_object
 306        and make_warnings_obj there appeared to be a bug - Nullsv and pWARN_STD
 307        were both 0, so you could never get a B::SPECIAL for pWARN_STD  */
 308
 309     while (iv--) {
 310         if ((SV*)warnings == specialsv_list[iv]) {
 311             type = "B::SPECIAL";
 312             break;
 313         }
 314     }
 315     if (type) {
 316         SV *arg = sv_newmortal();
 317         sv_setiv(newSVrv(arg, type), iv);
 318         return arg;
 319     } else {
 320         /* B assumes that warnings are a regular SV. Seems easier to keep it
 321            happy by making them into a regular SV.  */
 322         return make_temp_object(aTHX_ newSVpvn((char *)(warnings + 1), *warnings));
 323     }
 324 }
 325
 326 static SV *
 327 make_cop_io_object(pTHX_ COP *cop)
 328 {
 329     SV *const value = newSV(0);
 330
 331     Perl_emulate_cop_io(aTHX_ cop, value);
 332
 333     if(SvOK(value)) {
 334         return make_sv_object(aTHX_ value);
 335     } else {
 336         SvREFCNT_dec(value);
 337         return make_sv_object(aTHX_ NULL);
 338     }
 339 }
 340 #endif
 341
 342 static SV *
 343 make_mg_object(pTHX_ MAGIC *mg)
 344 {
 345     SV *arg = sv_newmortal();
 346     sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg));
 347     return arg;
 348 }
 349
 350 static SV *
 351 cstring(pTHX_ SV *sv, bool perlstyle)
 352 {
 353     SV *sstr;
 354
 355     if (!SvOK(sv))
 356         return newSVpvs_flags("0", SVs_TEMP);
 357
 358     sstr = newSVpvs_flags("\"", SVs_TEMP);
 359
 360     if (perlstyle && SvUTF8(sv)) {
 361         SV *tmpsv = sv_newmortal(); /* Temporary SV to feed sv_uni_display */
 362         const STRLEN len = SvCUR(sv);
 363         const char *s = sv_uni_display(tmpsv, sv, 8*len, UNI_DISPLAY_QQ);
 364         while (*s)
 365         {
 366             if (*s == '"')
 367                 sv_catpvs(sstr, "\\\"");
 368             else if (*s == '$')
 369                 sv_catpvs(sstr, "\\$");
 370             else if (*s == '@')
 371                 sv_catpvs(sstr, "\\@");
 372             else if (*s == '\\')
 373             {
 374                 if (strchr("nrftax\\",*(s+1)))
 375                     sv_catpvn(sstr, s++, 2);
 376                 else
 377                     sv_catpvs(sstr, "\\\\");
 378             }
 379             else /* should always be printable */
 380                 sv_catpvn(sstr, s, 1);
 381             ++s;
 382         }
 383     }
 384     else
 385     {
 386         /* XXX Optimise? */
 387         STRLEN len;
 388         const char *s = SvPV(sv, len);
 389         for (; len; len--, s++)
 390         {
 391             /* At least try a little for readability */
 392             if (*s == '"')
 393                 sv_catpvs(sstr, "\\\"");
 394             else if (*s == '\\')
 395                 sv_catpvs(sstr, "\\\\");
 396             /* trigraphs - bleagh */
 397             else if (!perlstyle && *s == '?' && len>=3 && s[1] == '?') {
 398                 Perl_sv_catpvf(aTHX_ sstr, "\\%03o", '?');
 399             }
 400             else if (perlstyle && *s == '$')
 401                 sv_catpvs(sstr, "\\$");
 402             else if (perlstyle && *s == '@')
 403                 sv_catpvs(sstr, "\\@");
 404 #ifdef EBCDIC
 405             else if (isPRINT(*s))
 406 #else
 407             else if (*s >= ' ' && *s < 127)
 408 #endif /* EBCDIC */
 409                 sv_catpvn(sstr, s, 1);
 410             else if (*s == '\n')
 411                 sv_catpvs(sstr, "\\n");
 412             else if (*s == '\r')
 413                 sv_catpvs(sstr, "\\r");
 414             else if (*s == '\t')
 415                 sv_catpvs(sstr, "\\t");
 416             else if (*s == '\a')
 417                 sv_catpvs(sstr, "\\a");
 418             else if (*s == '\b')
 419                 sv_catpvs(sstr, "\\b");
 420             else if (*s == '\f')
 421                 sv_catpvs(sstr, "\\f");
 422             else if (!perlstyle && *s == '\v')
 423                 sv_catpvs(sstr, "\\v");
 424             else
 425             {
 426                 /* Don't want promotion of a signed -1 char in sprintf args */
 427                 const unsigned char c = (unsigned char) *s;
 428                 Perl_sv_catpvf(aTHX_ sstr, "\\%03o", c);
 429             }
 430             /* XXX Add line breaks if string is long */
 431         }
 432     }
 433     sv_catpvs(sstr, "\"");
 434     return sstr;
 435 }
 436
 437 static SV *
 438 cchar(pTHX_ SV *sv)
 439 {
 440     SV *sstr = newSVpvs_flags("'", SVs_TEMP);
 441     const char *s = SvPV_nolen(sv);
 442     /* Don't want promotion of a signed -1 char in sprintf args */
 443     const unsigned char c = (unsigned char) *s;
 444
 445     if (c == '\'')
 446         sv_catpvs(sstr, "\\'");
 447     else if (c == '\\')
 448         sv_catpvs(sstr, "\\\\");
 449 #ifdef EBCDIC
 450     else if (isPRINT(c))
 451 #else
 452     else if (c >= ' ' && c < 127)
 453 #endif /* EBCDIC */
 454         sv_catpvn(sstr, s, 1);
 455     else if (c == '\n')
 456         sv_catpvs(sstr, "\\n");
 457     else if (c == '\r')
 458         sv_catpvs(sstr, "\\r");
 459     else if (c == '\t')
 460         sv_catpvs(sstr, "\\t");
 461     else if (c == '\a')
 462         sv_catpvs(sstr, "\\a");
 463     else if (c == '\b')
 464         sv_catpvs(sstr, "\\b");
 465     else if (c == '\f')
 466         sv_catpvs(sstr, "\\f");
 467     else if (c == '\v')
 468         sv_catpvs(sstr, "\\v");
 469     else
 470         Perl_sv_catpvf(aTHX_ sstr, "\\%03o", c);
 471     sv_catpvs(sstr, "'");
 472     return sstr;
 473 }
 474
 475 #if PERL_VERSION >= 9
 476 #  define PMOP_pmreplstart(o)   o->op_pmstashstartu.op_pmreplstart
 477 #  define PMOP_pmreplroot(o)    o->op_pmreplrootu.op_pmreplroot
 478 #else
 479 #  define PMOP_pmreplstart(o)   o->op_pmreplstart
 480 #  define PMOP_pmreplroot(o)    o->op_pmreplroot
 481 #  define PMOP_pmpermflags(o)   o->op_pmpermflags
 482 #  define PMOP_pmdynflags(o)      o->op_pmdynflags
 483 #endif
 484
 485 static SV *
 486 walkoptree(pTHX_ OP *o, const char *method, SV *ref)
 487 {
 488     dSP;
 489     OP *kid;
 490     SV *object;
 491     const char *const classname = opclassnames[cc_opclass(aTHX_ o)];
 492     dMY_CXT;
 493
 494     /* Check that no-one has changed our reference, or is holding a reference
 495        to it.  */
 496     if (SvREFCNT(ref) == 1 && SvROK(ref) && SvTYPE(ref) == SVt_RV
 497         && (object = SvRV(ref)) && SvREFCNT(object) == 1
 498         && SvTYPE(object) == SVt_PVMG && SvIOK_only(object)
 499         && !SvMAGICAL(object) && !SvMAGIC(object) && SvSTASH(object)) {
 500         /* Looks good, so rebless it for the class we need:  */
 501         sv_bless(ref, gv_stashpv(classname, GV_ADD));
 502     } else {
 503         /* Need to make a new one. */
 504         ref = sv_newmortal();
 505         object = newSVrv(ref, classname);
 506     }
 507     sv_setiv(object, PTR2IV(o));
 508
 509     if (walkoptree_debug) {
 510         PUSHMARK(sp);
 511         XPUSHs(ref);
 512         PUTBACK;
 513         perl_call_method("walkoptree_debug", G_DISCARD);
 514     }
 515     PUSHMARK(sp);
 516     XPUSHs(ref);
 517     PUTBACK;
 518     perl_call_method(method, G_DISCARD);
 519     if (o && (o->op_flags & OPf_KIDS)) {
 520         for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) {
 521             ref = walkoptree(aTHX_ kid, method, ref);
 522         }
 523     }
 524     if (o && (cc_opclass(aTHX_ o) == OPc_PMOP) && o->op_type != OP_PUSHRE
 525            && (kid = PMOP_pmreplroot(cPMOPo)))
 526     {
 527         ref = walkoptree(aTHX_ kid, method, ref);
 528     }
 529     return ref;
 530 }
 531
 532 static SV **
 533 oplist(pTHX_ OP *o, SV **SP)
 534 {
 535     for(; o; o = o->op_next) {
 536 #if PERL_VERSION >= 9
 537         if (o->op_opt == 0)
 538             break;
 539         o->op_opt = 0;
 540 #else
 541         if (o->op_seq == 0)
 542             break;
 543         o->op_seq = 0;
 544 #endif
 545         XPUSHs(make_op_object(aTHX_ o));
 546         switch (o->op_type) {
 547         case OP_SUBST:
 548             SP = oplist(aTHX_ PMOP_pmreplstart(cPMOPo), SP);
 549             continue;
 550         case OP_SORT:
 551             if (o->op_flags & OPf_STACKED && o->op_flags & OPf_SPECIAL) {
 552                 OP *kid = cLISTOPo->op_first->op_sibling;   /* pass pushmark */
 553                 kid = kUNOP->op_first;                      /* pass rv2gv */
 554                 kid = kUNOP->op_first;                      /* pass leave */
 555                 SP = oplist(aTHX_ kid->op_next, SP);
 556             }
 557             continue;
 558         }
 559         switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
 560         case OA_LOGOP:
 561             SP = oplist(aTHX_ cLOGOPo->op_other, SP);
 562             break;
 563         case OA_LOOP:
 564             SP = oplist(aTHX_ cLOOPo->op_lastop, SP);
 565             SP = oplist(aTHX_ cLOOPo->op_nextop, SP);
 566             SP = oplist(aTHX_ cLOOPo->op_redoop, SP);
 567             break;
 568         }
 569     }
 570     return SP;
 571 }
 572
 573 typedef OP      *B__OP;
 574 typedef UNOP    *B__UNOP;
 575 typedef BINOP   *B__BINOP;
 576 typedef LOGOP   *B__LOGOP;
 577 typedef LISTOP  *B__LISTOP;
 578 typedef PMOP    *B__PMOP;
 579 typedef SVOP    *B__SVOP;
 580 typedef PADOP   *B__PADOP;
 581 typedef PVOP    *B__PVOP;
 582 typedef LOOP    *B__LOOP;
 583 typedef COP     *B__COP;
 584
 585 typedef SV      *B__SV;
 586 typedef SV      *B__IV;
 587 typedef SV      *B__PV;
 588 typedef SV      *B__NV;
 589 typedef SV      *B__PVMG;
 590 #if PERL_VERSION >= 11
 591 typedef SV      *B__REGEXP;
 592 #endif
 593 typedef SV      *B__PVLV;
 594 typedef SV      *B__BM;
 595 typedef SV      *B__RV;
 596 typedef SV      *B__FM;
 597 typedef AV      *B__AV;
 598 typedef HV      *B__HV;
 599 typedef CV      *B__CV;
 600 typedef GV      *B__GV;
 601 typedef IO      *B__IO;
 602
 603 typedef MAGIC   *B__MAGIC;
 604 typedef HE      *B__HE;
 605 #if PERL_VERSION >= 9
 606 typedef struct refcounted_he    *B__RHE;
 607 #endif
 608
 609 #ifdef MULTIPLICITY
 610 #  define ASSIGN_COMMON_ALIAS(var) \
 611     STMT_START { XSANY.any_i32 = offsetof(struct interpreter, var); } STMT_END
 612 #else
 613 #  define ASSIGN_COMMON_ALIAS(var) \
 614     STMT_START { XSANY.any_ptr = (void *)&PL_##var; } STMT_END
 615 #endif
 616
 617 /* This needs to be ALIASed in a custom way, hence can't easily be defined as
 618    a regular XSUB.  */
 619 static XSPROTO(intrpvar_sv_common); /* prototype to pass -Wmissing-prototypes */
 620 static XSPROTO(intrpvar_sv_common)
 621 {
 622     dVAR;
 623     dXSARGS;
 624     SV *ret;
 625     if (items != 0)
 626        croak_xs_usage(cv,  "");
 627 #ifdef MULTIPLICITY
 628     ret = *(SV **)(XSANY.any_i32 + (char *)my_perl);
 629 #else
 630     ret = *(SV **)(XSANY.any_ptr);
 631 #endif
 632     ST(0) = make_sv_object(aTHX_ ret);
 633     XSRETURN(1);
 634 }
 635
 636 #include "const-c.inc"
 637
 638 MODULE = B      PACKAGE = B
 639
 640 INCLUDE: const-xs.inc
 641
 642 PROTOTYPES: DISABLE
 643
 644 BOOT:
 645 {
 646     CV *cv;
 647     const char *file = __FILE__;
 648     MY_CXT_INIT;
 649     specialsv_list[0] = Nullsv;
 650     specialsv_list[1] = &PL_sv_undef;
 651     specialsv_list[2] = &PL_sv_yes;
 652     specialsv_list[3] = &PL_sv_no;
 653     specialsv_list[4] = (SV *) pWARN_ALL;
 654     specialsv_list[5] = (SV *) pWARN_NONE;
 655     specialsv_list[6] = (SV *) pWARN_STD;
 656
 657     cv = newXS("B::init_av", intrpvar_sv_common, file);
 658     ASSIGN_COMMON_ALIAS(Iinitav);
 659     cv = newXS("B::check_av", intrpvar_sv_common, file);
 660     ASSIGN_COMMON_ALIAS(Icheckav_save);
 661 #if PERL_VERSION >= 9
 662     cv = newXS("B::unitcheck_av", intrpvar_sv_common, file);
 663     ASSIGN_COMMON_ALIAS(Iunitcheckav_save);
 664 #endif
 665     cv = newXS("B::begin_av", intrpvar_sv_common, file);
 666     ASSIGN_COMMON_ALIAS(Ibeginav_save);
 667     cv = newXS("B::end_av", intrpvar_sv_common, file);
 668     ASSIGN_COMMON_ALIAS(Iendav);
 669     cv = newXS("B::main_cv", intrpvar_sv_common, file);
 670     ASSIGN_COMMON_ALIAS(Imain_cv);
 671     cv = newXS("B::inc_gv", intrpvar_sv_common, file);
 672     ASSIGN_COMMON_ALIAS(Iincgv);
 673     cv = newXS("B::defstash", intrpvar_sv_common, file);
 674     ASSIGN_COMMON_ALIAS(Idefstash);
 675     cv = newXS("B::curstash", intrpvar_sv_common, file);
 676     ASSIGN_COMMON_ALIAS(Icurstash);
 677     cv = newXS("B::formfeed", intrpvar_sv_common, file);
 678     ASSIGN_COMMON_ALIAS(Iformfeed);
 679 #ifdef USE_ITHREADS
 680     cv = newXS("B::regex_padav", intrpvar_sv_common, file);
 681     ASSIGN_COMMON_ALIAS(Iregex_padav);
 682 #endif
 683     cv = newXS("B::warnhook", intrpvar_sv_common, file);
 684     ASSIGN_COMMON_ALIAS(Iwarnhook);
 685     cv = newXS("B::diehook", intrpvar_sv_common, file);
 686     ASSIGN_COMMON_ALIAS(Idiehook);
 687 }
 688
 689 long
 690 amagic_generation()
 691     CODE:
 692         RETVAL = PL_amagic_generation;
 693     OUTPUT:
 694         RETVAL
 695
 696 void
 697 comppadlist()
 698     PPCODE:
 699         PUSHs(make_sv_object(aTHX_ (SV *)(PL_main_cv ? CvPADLIST(PL_main_cv)
 700                                                      : CvPADLIST(PL_compcv))));
 701
 702 void
 703 sv_undef()
 704     ALIAS:
 705         sv_no = 1
 706         sv_yes = 2
 707     PPCODE:
 708         PUSHs(make_sv_object(aTHX_ ix > 1 ? &PL_sv_yes
 709                                           : ix < 1 ? &PL_sv_undef
 710                                                    : &PL_sv_no));
 711
 712 void
 713 main_root()
 714     ALIAS:
 715         main_start = 1
 716     PPCODE:
 717         PUSHs(make_op_object(aTHX_ ix ? PL_main_start : PL_main_root));
 718
 719 UV
 720 sub_generation()
 721     ALIAS:
 722         dowarn = 1
 723     CODE:
 724         RETVAL = ix ? PL_dowarn : PL_sub_generation;
 725     OUTPUT:
 726         RETVAL
 727
 728 void
 729 walkoptree(op, method)
 730         B::OP op
 731         const char *    method
 732     CODE:
 733         (void) walkoptree(aTHX_ op, method, &PL_sv_undef);
 734
 735 int
 736 walkoptree_debug(...)
 737     CODE:
 738         dMY_CXT;
 739         RETVAL = walkoptree_debug;
 740         if (items > 0 && SvTRUE(ST(1)))
 741             walkoptree_debug = 1;
 742     OUTPUT:
 743         RETVAL
 744
 745 #define address(sv) PTR2IV(sv)
 746
 747 IV
 748 address(sv)
 749         SV *    sv
 750
 751 void
 752 svref_2object(sv)
 753         SV *    sv
 754     PPCODE:
 755         if (!SvROK(sv))
 756             croak("argument is not a reference");
 757         PUSHs(make_sv_object(aTHX_ SvRV(sv)));
 758
 759 void
 760 opnumber(name)
 761 const char *    name
 762 CODE:
 763 {
 764  int i;
 765  IV  result = -1;
 766  ST(0) = sv_newmortal();
 767  if (strncmp(name,"pp_",3) == 0)
 768    name += 3;
 769  for (i = 0; i < PL_maxo; i++)
 770   {
 771    if (strcmp(name, PL_op_name[i]) == 0)
 772     {
 773      result = i;
 774      break;
 775     }
 776   }
 777  sv_setiv(ST(0),result);
 778 }
 779
 780 void
 781 ppname(opnum)
 782         int     opnum
 783     CODE:
 784         ST(0) = sv_newmortal();
 785         if (opnum >= 0 && opnum < PL_maxo) {
 786             sv_setpvs(ST(0), "pp_");
 787             sv_catpv(ST(0), PL_op_name[opnum]);
 788         }
 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 = newSVpvs_flags("PL_ppaddr[OP_", SVs_TEMP);
 985     CODE:
 986         sv_catpv(sv, PL_op_name[o->op_type]);
 987         for (i=13; (STRLEN)i < SvCUR(sv); ++i)
 988             SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]);
 989         sv_catpvs(sv, "]");
 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 #define COP_arybase(o)  CopARYBASE_get(o)
1231
1232 MODULE = B      PACKAGE = B::COP                PREFIX = COP_
1233
1234 const char *
1235 COP_label(o)
1236         B::COP  o
1237
1238 # Both pairs of accessors are provided for both ithreads and not, but for each,
1239 # one pair is direct structure access, and 1 pair "faked up" with a more complex
1240 # macro. We implement the direct structure access pair using the common code
1241 # above (B::OP::next)
1242
1243 #ifdef USE_ITHREADS
1244
1245 void
1246 COP_stash(o)
1247         B::COP  o
1248     ALIAS:
1249         filegv = 1
1250     PPCODE:
1251         PUSHs(make_sv_object(aTHX_
1252                              ix ? (SV *)CopFILEGV(o) : (SV *)CopSTASH(o)));
1253
1254 #else
1255
1256 char *
1257 COP_stashpv(o)
1258         B::COP  o
1259     ALIAS:
1260         file = 1
1261     CODE:
1262         RETVAL = ix ? CopFILE(o) : CopSTASHPV(o);
1263     OUTPUT:
1264         RETVAL
1265
1266 #endif
1267
1268 I32
1269 COP_arybase(o)
1270         B::COP  o
1271
1272 void
1273 COP_warnings(o)
1274         B::COP  o
1275     ALIAS:
1276         io = 1
1277     PPCODE:
1278 #if PERL_VERSION >= 9
1279         ST(0) = ix ? make_cop_io_object(aTHX_ o) : make_warnings_object(aTHX_ o);
1280 #else
1281         ST(0) = make_sv_object(aTHX_ ix ? o->cop_io : o->cop_warnings);
1282 #endif
1283         XSRETURN(1);
1284
1285 #if PERL_VERSION >= 9
1286
1287 B::RHE
1288 COP_hints_hash(o)
1289         B::COP o
1290     CODE:
1291         RETVAL = CopHINTHASH_get(o);
1292     OUTPUT:
1293         RETVAL
1294
1295 #endif
1296
1297 MODULE = B      PACKAGE = B::SV
1298
1299 #define MAGICAL_FLAG_BITS (SVs_GMG|SVs_SMG|SVs_RMG)
1300
1301 U32
1302 REFCNT(sv)
1303         B::SV   sv
1304     ALIAS:
1305         FLAGS = 0xFFFFFFFF
1306         SvTYPE = SVTYPEMASK
1307         POK = SVf_POK
1308         ROK = SVf_ROK
1309         MAGICAL = MAGICAL_FLAG_BITS
1310     CODE:
1311         RETVAL = ix ? (SvFLAGS(sv) & (U32)ix) : SvREFCNT(sv);
1312     OUTPUT:
1313         RETVAL
1314
1315 void
1316 object_2svref(sv)
1317         B::SV   sv
1318     PPCODE:
1319         ST(0) = sv_2mortal(newRV(sv));
1320         XSRETURN(1);
1321
1322 MODULE = B      PACKAGE = B::IV         PREFIX = Sv
1323
1324 IV
1325 SvIV(sv)
1326         B::IV   sv
1327
1328 MODULE = B      PACKAGE = B::IV
1329
1330 #define sv_SVp          0x00000
1331 #define sv_IVp          0x10000
1332 #define sv_UVp          0x20000
1333 #define sv_STRLENp      0x30000
1334 #define sv_U32p         0x40000
1335 #define sv_U8p          0x50000
1336 #define sv_char_pp      0x60000
1337 #define sv_NVp          0x70000
1338 #define sv_char_p       0x80000
1339 #define sv_SSize_tp     0x90000
1340 #define sv_I32p         0xA0000
1341 #define sv_U16p         0xB0000
1342
1343 #define IV_ivx_ix       sv_IVp | offsetof(struct xpviv, xiv_iv)
1344 #define IV_uvx_ix       sv_UVp | offsetof(struct xpvuv, xuv_uv)
1345 #define NV_nvx_ix       sv_NVp | offsetof(struct xpvnv, xnv_u.xnv_nv)
1346
1347 #if PERL_VERSION >= 10
1348 #define NV_cop_seq_range_low_ix \
1349                         sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
1350 #define NV_cop_seq_range_high_ix \
1351                         sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
1352 #define NV_parent_pad_index_ix \
1353                         sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
1354 #define NV_parent_fakelex_flags_ix \
1355                         sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
1356 #else
1357 #define NV_cop_seq_range_low_ix \
1358                         sv_NVp | offsetof(struct xpvnv, xnv_nv)
1359 #define NV_cop_seq_range_high_ix \
1360                         sv_UVp | offsetof(struct xpvnv, xuv_uv)
1361 #define NV_parent_pad_index_ix \
1362                         sv_NVp | offsetof(struct xpvnv, xnv_nv)
1363 #define NV_parent_fakelex_flags_ix \
1364                         sv_UVp | offsetof(struct xpvnv, xuv_uv)
1365 #endif
1366
1367 #define PV_cur_ix       sv_STRLENp | offsetof(struct xpv, xpv_cur)
1368 #define PV_len_ix       sv_STRLENp | offsetof(struct xpv, xpv_len)
1369
1370 #define PVMG_stash_ix   sv_SVp | offsetof(struct xpvmg, xmg_stash)
1371
1372 #if PERL_VERSION >= 10
1373 #  if PERL_VERSION > 14
1374 #    define PVBM_useful_ix      sv_I32p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_useful)
1375 #    define PVBM_previous_ix    sv_UVp | offsetof(struct xpvuv, xuv_uv)
1376 #  else
1377 #define PVBM_useful_ix  sv_I32p | offsetof(struct xpvgv, xiv_u.xivu_i32)
1378 #define PVBM_previous_ix    sv_U32p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_previous)
1379 #  endif
1380 #define PVBM_rare_ix    sv_U8p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_rare)
1381 #else
1382 #define PVBM_useful_ix  sv_I32p | offsetof(struct xpvbm, xbm_useful)
1383 #define PVBM_previous_ix    sv_U16p | offsetof(struct xpvbm, xbm_previous)
1384 #define PVBM_rare_ix    sv_U8p | offsetof(struct xpvbm, xbm_rare)
1385 #endif
1386
1387 #define PVLV_targoff_ix sv_U32p | offsetof(struct xpvlv, xlv_targoff)
1388 #define PVLV_targlen_ix sv_U32p | offsetof(struct xpvlv, xlv_targlen)
1389 #define PVLV_targ_ix    sv_SVp | offsetof(struct xpvlv, xlv_targ)
1390 #define PVLV_type_ix    sv_char_p | offsetof(struct xpvlv, xlv_type)
1391
1392 #if PERL_VERSION >= 10
1393 #define PVGV_stash_ix   sv_SVp | offsetof(struct xpvgv, xnv_u.xgv_stash)
1394 #define PVGV_flags_ix   sv_STRLENp | offsetof(struct xpvgv, xpv_cur)
1395 #define PVIO_lines_ix   sv_IVp | offsetof(struct xpvio, xiv_iv)
1396 #else
1397 #define PVGV_stash_ix   sv_SVp | offsetof(struct xpvgv, xgv_stash)
1398 #define PVGV_flags_ix   sv_U8p | offsetof(struct xpvgv, xgv_flags)
1399 #define PVIO_lines_ix   sv_IVp | offsetof(struct xpvio, xio_lines)
1400 #endif
1401
1402 #define PVIO_page_ix        sv_IVp | offsetof(struct xpvio, xio_page)
1403 #define PVIO_page_len_ix    sv_IVp | offsetof(struct xpvio, xio_page_len)
1404 #define PVIO_lines_left_ix  sv_IVp | offsetof(struct xpvio, xio_lines_left)
1405 #define PVIO_top_name_ix    sv_char_pp | offsetof(struct xpvio, xio_top_name)
1406 #define PVIO_top_gv_ix      sv_SVp | offsetof(struct xpvio, xio_top_gv)
1407 #define PVIO_fmt_name_ix    sv_char_pp | offsetof(struct xpvio, xio_fmt_name)
1408 #define PVIO_fmt_gv_ix      sv_SVp | offsetof(struct xpvio, xio_fmt_gv)
1409 #define PVIO_bottom_name_ix sv_char_pp | offsetof(struct xpvio, xio_bottom_name)
1410 #define PVIO_bottom_gv_ix   sv_SVp | offsetof(struct xpvio, xio_bottom_gv)
1411 #define PVIO_type_ix        sv_char_p | offsetof(struct xpvio, xio_type)
1412 #define PVIO_flags_ix       sv_U8p | offsetof(struct xpvio, xio_flags)
1413
1414 #define PVAV_max_ix     sv_SSize_tp | offsetof(struct xpvav, xav_max)
1415
1416 #define PVFM_lines_ix   sv_IVp | offsetof(struct xpvfm, xfm_lines)
1417
1418 #define PVCV_stash_ix   sv_SVp | offsetof(struct xpvcv, xcv_stash)
1419 #define PVCV_gv_ix      sv_SVp | offsetof(struct xpvcv, xcv_gv)
1420 #define PVCV_file_ix    sv_char_pp | offsetof(struct xpvcv, xcv_file)
1421 #define PVCV_depth_ix   sv_I32p | offsetof(struct xpvcv, xcv_depth)
1422 #define PVCV_padlist_ix sv_SVp | offsetof(struct xpvcv, xcv_padlist)
1423 #define PVCV_outside_ix sv_SVp | offsetof(struct xpvcv, xcv_outside)
1424 #define PVCV_outside_seq_ix sv_U32p | offsetof(struct xpvcv, xcv_outside_seq)
1425 #define PVCV_flags_ix   sv_U16p | offsetof(struct xpvcv, xcv_flags)
1426
1427 #define PVHV_max_ix     sv_STRLENp | offsetof(struct xpvhv, xhv_max)
1428
1429 #if PERL_VERSION > 12
1430 #define PVHV_keys_ix    sv_STRLENp | offsetof(struct xpvhv, xhv_keys)
1431 #else
1432 #define PVHV_keys_ix    sv_IVp | offsetof(struct xpvhv, xhv_keys)
1433 #endif
1434
1435 # The type checking code in B has always been identical for all SV types,
1436 # irrespective of whether the action is actually defined on that SV.
1437 # We should fix this
1438 void
1439 IVX(sv)
1440         B::SV           sv
1441     ALIAS:
1442         B::IV::IVX = IV_ivx_ix
1443         B::IV::UVX = IV_uvx_ix
1444         B::NV::NVX = NV_nvx_ix
1445         B::NV::COP_SEQ_RANGE_LOW = NV_cop_seq_range_low_ix
1446         B::NV::COP_SEQ_RANGE_HIGH = NV_cop_seq_range_high_ix
1447         B::NV::PARENT_PAD_INDEX = NV_parent_pad_index_ix
1448         B::NV::PARENT_FAKELEX_FLAGS = NV_parent_fakelex_flags_ix
1449         B::PV::CUR = PV_cur_ix
1450         B::PV::LEN = PV_len_ix
1451         B::PVMG::SvSTASH = PVMG_stash_ix
1452         B::PVLV::TARGOFF = PVLV_targoff_ix
1453         B::PVLV::TARGLEN = PVLV_targlen_ix
1454         B::PVLV::TARG = PVLV_targ_ix
1455         B::PVLV::TYPE = PVLV_type_ix
1456         B::GV::STASH = PVGV_stash_ix
1457         B::GV::GvFLAGS = PVGV_flags_ix
1458         B::BM::USEFUL = PVBM_useful_ix
1459         B::BM::PREVIOUS = PVBM_previous_ix
1460         B::BM::RARE = PVBM_rare_ix
1461         B::IO::LINES =  PVIO_lines_ix
1462         B::IO::PAGE = PVIO_page_ix
1463         B::IO::PAGE_LEN = PVIO_page_len_ix
1464         B::IO::LINES_LEFT = PVIO_lines_left_ix
1465         B::IO::TOP_NAME = PVIO_top_name_ix
1466         B::IO::TOP_GV = PVIO_top_gv_ix
1467         B::IO::FMT_NAME = PVIO_fmt_name_ix
1468         B::IO::FMT_GV = PVIO_fmt_gv_ix
1469         B::IO::BOTTOM_NAME = PVIO_bottom_name_ix
1470         B::IO::BOTTOM_GV = PVIO_bottom_gv_ix
1471         B::IO::IoTYPE = PVIO_type_ix
1472         B::IO::IoFLAGS = PVIO_flags_ix
1473         B::AV::MAX = PVAV_max_ix
1474         B::FM::LINES = PVFM_lines_ix
1475         B::CV::STASH = PVCV_stash_ix
1476         B::CV::GV = PVCV_gv_ix
1477         B::CV::FILE = PVCV_file_ix
1478         B::CV::DEPTH = PVCV_depth_ix
1479         B::CV::PADLIST = PVCV_padlist_ix
1480         B::CV::OUTSIDE = PVCV_outside_ix
1481         B::CV::OUTSIDE_SEQ = PVCV_outside_seq_ix
1482         B::CV::CvFLAGS = PVCV_flags_ix
1483         B::HV::MAX = PVHV_max_ix
1484         B::HV::KEYS = PVHV_keys_ix
1485     PREINIT:
1486         char *ptr;
1487         SV *ret;
1488     PPCODE:
1489         ptr = (ix & 0xFFFF) + (char *)SvANY(sv);
1490         switch ((U8)(ix >> 16)) {
1491         case (U8)(sv_SVp >> 16):
1492             ret = make_sv_object(aTHX_ *((SV **)ptr));
1493             break;
1494         case (U8)(sv_IVp >> 16):
1495             ret = sv_2mortal(newSViv(*((IV *)ptr)));
1496             break;
1497         case (U8)(sv_UVp >> 16):
1498             ret = sv_2mortal(newSVuv(*((UV *)ptr)));
1499             break;
1500         case (U8)(sv_STRLENp >> 16):
1501             ret = sv_2mortal(newSVuv(*((STRLEN *)ptr)));
1502             break;
1503         case (U8)(sv_U32p >> 16):
1504             ret = sv_2mortal(newSVuv(*((U32 *)ptr)));
1505             break;
1506         case (U8)(sv_U8p >> 16):
1507             ret = sv_2mortal(newSVuv(*((U8 *)ptr)));
1508             break;
1509         case (U8)(sv_char_pp >> 16):
1510             ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
1511             break;
1512         case (U8)(sv_NVp >> 16):
1513             ret = sv_2mortal(newSVnv(*((NV *)ptr)));
1514             break;
1515         case (U8)(sv_char_p >> 16):
1516             ret = newSVpvn_flags((char *)ptr, 1, SVs_TEMP);
1517             break;
1518         case (U8)(sv_SSize_tp >> 16):
1519             ret = sv_2mortal(newSViv(*((SSize_t *)ptr)));
1520             break;
1521         case (U8)(sv_I32p >> 16):
1522             ret = sv_2mortal(newSVuv(*((I32 *)ptr)));
1523             break;
1524         case (U8)(sv_U16p >> 16):
1525             ret = sv_2mortal(newSVuv(*((U16 *)ptr)));
1526             break;
1527         default:
1528             croak("Illegal alias 0x%08x for B::*IVX", (unsigned)ix);
1529         }
1530         ST(0) = ret;
1531         XSRETURN(1);
1532
1533 void
1534 packiv(sv)
1535         B::IV   sv
1536     ALIAS:
1537         needs64bits = 1
1538     CODE:
1539         if (ix) {
1540             ST(0) = boolSV((I32)SvIVX(sv) != SvIVX(sv));
1541         } else if (sizeof(IV) == 8) {
1542             U32 wp[2];
1543             const IV iv = SvIVX(sv);
1544             /*
1545              * The following way of spelling 32 is to stop compilers on
1546              * 32-bit architectures from moaning about the shift count
1547              * being >= the width of the type. Such architectures don't
1548              * reach this code anyway (unless sizeof(IV) > 8 but then
1549              * everything else breaks too so I'm not fussed at the moment).
1550              */
1551 #ifdef UV_IS_QUAD
1552             wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1553 #else
1554             wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1555 #endif
1556             wp[1] = htonl(iv & 0xffffffff);
1557             ST(0) = newSVpvn_flags((char *)wp, 8, SVs_TEMP);
1558         } else {
1559             U32 w = htonl((U32)SvIVX(sv));
1560             ST(0) = newSVpvn_flags((char *)&w, 4, SVs_TEMP);
1561         }
1562
1563 MODULE = B      PACKAGE = B::NV         PREFIX = Sv
1564
1565 NV
1566 SvNV(sv)
1567         B::NV   sv
1568
1569 #if PERL_VERSION < 11
1570
1571 MODULE = B      PACKAGE = B::RV         PREFIX = Sv
1572
1573 void
1574 SvRV(sv)
1575         B::RV   sv
1576     PPCODE:
1577         PUSHs(make_sv_object(aTHX_ SvRV(sv)));
1578
1579 #else
1580
1581 MODULE = B      PACKAGE = B::REGEXP
1582
1583 void
1584 REGEX(sv)
1585         B::REGEXP       sv
1586     ALIAS:
1587         precomp = 1
1588     PPCODE:
1589         if (ix) {
1590             PUSHs(newSVpvn_flags(RX_PRECOMP(sv), RX_PRELEN(sv), SVs_TEMP));
1591         } else {
1592             dXSTARG;
1593             /* FIXME - can we code this method more efficiently?  */
1594             PUSHi(PTR2IV(sv));
1595         }
1596
1597 #endif
1598
1599 MODULE = B      PACKAGE = B::PV
1600
1601 void
1602 RV(sv)
1603         B::PV   sv
1604     PPCODE:
1605         if (!SvROK(sv))
1606             croak( "argument is not SvROK" );
1607         PUSHs(make_sv_object(aTHX_ SvRV(sv)));
1608
1609 void
1610 PV(sv)
1611         B::PV   sv
1612     ALIAS:
1613         PVX = 1
1614         PVBM = 2
1615         B::BM::TABLE = 3
1616     PREINIT:
1617         const char *p;
1618         STRLEN len = 0;
1619         U32 utf8 = 0;
1620     CODE:
1621         if (ix == 3) {
1622             p = SvPV(sv, len);
1623             /* Boyer-Moore table is just after string and its safety-margin \0 */
1624             p += len + PERL_FBM_TABLE_OFFSET;
1625             len = 256;
1626         } else if (ix == 2) {
1627             /* This used to read 257. I think that that was buggy - should have
1628                been 258. (The "\0", the flags byte, and 256 for the table.)
1629                The only user of this method is B::Bytecode in B::PV::bsave.
1630                I'm guessing that nothing tested the runtime correctness of
1631                output of bytecompiled string constant arguments to index (etc).
1632
1633                Note the start pointer is and has always been SvPVX(sv), not
1634                SvPVX(sv) + SvCUR(sv) PVBM was added in 651aa52ea1faa806, and
1635                first used by the compiler in 651aa52ea1faa806. It's used to
1636                get a "complete" dump of the buffer at SvPVX(), not just the
1637                PVBM table. This permits the generated bytecode to "load"
1638                SvPVX in "one" hit.  */
1639             p = SvPVX_const(sv);
1640             len = SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0);
1641         } else if (ix) {
1642             p = SvPVX(sv);
1643             len = strlen(p);
1644         } else if (SvPOK(sv)) {
1645             len = SvCUR(sv);
1646             p = SvPVX_const(sv);
1647             utf8 = SvUTF8(sv);
1648 #if PERL_VERSION < 10
1649             /* Before 5.10 (well 931b58fb28fa5ca7), PAD_COMPNAME_GEN was stored
1650                in SvCUR(), which meant we had to attempt this special casing
1651                to avoid tripping up over variable names in the pads.  */
1652             if((SvLEN(sv) && len >= SvLEN(sv))) {
1653                 /* It claims to be longer than the space allocated for it -
1654                    presumably it's a variable name in the pad  */
1655                 len = strlen(p);
1656             }
1657 #endif
1658         }
1659         else {
1660             /* XXX for backward compatibility, but should fail */
1661             /* croak( "argument is not SvPOK" ); */
1662             p = NULL;
1663         }
1664         ST(0) = newSVpvn_flags(p, len, SVs_TEMP | utf8);
1665
1666 MODULE = B      PACKAGE = B::PVMG
1667
1668 void
1669 MAGIC(sv)
1670         B::PVMG sv
1671         MAGIC * mg = NO_INIT
1672     PPCODE:
1673         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
1674             XPUSHs(make_mg_object(aTHX_ mg));
1675
1676 MODULE = B      PACKAGE = B::MAGIC
1677
1678 void
1679 MOREMAGIC(mg)
1680         B::MAGIC        mg
1681     ALIAS:
1682         PRIVATE = 1
1683         TYPE = 2
1684         FLAGS = 3
1685         LENGTH = 4
1686         OBJ = 5
1687         PTR = 6
1688         REGEX = 7
1689         precomp = 8
1690     PPCODE:
1691         switch (ix) {
1692         case 0:
1693             XPUSHs(mg->mg_moremagic ? make_mg_object(aTHX_ mg->mg_moremagic)
1694                                     : &PL_sv_undef);
1695             break;
1696         case 1:
1697             mPUSHu(mg->mg_private);
1698             break;
1699         case 2:
1700             PUSHs(newSVpvn_flags(&(mg->mg_type), 1, SVs_TEMP));
1701             break;
1702         case 3:
1703             mPUSHu(mg->mg_flags);
1704             break;
1705         case 4:
1706             mPUSHi(mg->mg_len);
1707             break;
1708         case 5:
1709             PUSHs(make_sv_object(aTHX_ mg->mg_obj));
1710             break;
1711         case 6:
1712             if (mg->mg_ptr) {
1713                 if (mg->mg_len >= 0) {
1714                     PUSHs(newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP));
1715                 } else if (mg->mg_len == HEf_SVKEY) {
1716                     PUSHs(make_sv_object(aTHX_ (SV*)mg->mg_ptr));
1717                 } else
1718                     PUSHs(sv_newmortal());
1719             } else
1720                 PUSHs(sv_newmortal());
1721             break;
1722         case 7:
1723             if(mg->mg_type == PERL_MAGIC_qr) {
1724                 mPUSHi(PTR2IV(mg->mg_obj));
1725             } else {
1726                 croak("REGEX is only meaningful on r-magic");
1727             }
1728             break;
1729         case 8:
1730             if (mg->mg_type == PERL_MAGIC_qr) {
1731                 REGEXP *rx = (REGEXP *)mg->mg_obj;
1732                 PUSHs(newSVpvn_flags(rx ? RX_PRECOMP(rx) : NULL,
1733                                      rx ? RX_PRELEN(rx) : 0, SVs_TEMP));
1734             } else {
1735                 croak( "precomp is only meaningful on r-magic" );
1736             }
1737             break;
1738         }
1739
1740 MODULE = B      PACKAGE = B::GV         PREFIX = Gv
1741
1742 void
1743 GvNAME(gv)
1744         B::GV   gv
1745     ALIAS:
1746         FILE = 1
1747         B::HV::NAME = 2
1748     CODE:
1749 #if PERL_VERSION >= 10
1750         ST(0) = sv_2mortal(newSVhek(!ix ? GvNAME_HEK(gv)
1751                                         : (ix == 1 ? GvFILE_HEK(gv)
1752                                                    : HvNAME_HEK((HV *)gv))));
1753 #else
1754         ST(0) = !ix ? newSVpvn_flags(GvNAME(gv), GvNAMELEN(gv), SVs_TEMP)
1755                     : sv_2mortal(newSVpv(ix == 1 ? GvFILE(gv) : HvNAME((HV *)gv), 0))
1756 #endif
1757
1758 bool
1759 is_empty(gv)
1760         B::GV   gv
1761     ALIAS:
1762         isGV_with_GP = 1
1763     CODE:
1764         if (ix) {
1765 #if PERL_VERSION >= 9
1766             RETVAL = isGV_with_GP(gv) ? TRUE : FALSE;
1767 #else
1768             RETVAL = TRUE; /* In 5.8 and earlier they all are.  */
1769 #endif
1770         } else {
1771             RETVAL = GvGP(gv) == Null(GP*);
1772         }
1773     OUTPUT:
1774         RETVAL
1775
1776 void*
1777 GvGP(gv)
1778         B::GV   gv
1779
1780 #define GP_sv_ix        SVp | offsetof(struct gp, gp_sv)
1781 #define GP_io_ix        SVp | offsetof(struct gp, gp_io)
1782 #define GP_cv_ix        SVp | offsetof(struct gp, gp_cv)
1783 #define GP_cvgen_ix     U32p | offsetof(struct gp, gp_cvgen)
1784 #define GP_refcnt_ix    U32p | offsetof(struct gp, gp_refcnt)
1785 #define GP_hv_ix        SVp | offsetof(struct gp, gp_hv)
1786 #define GP_av_ix        SVp | offsetof(struct gp, gp_av)
1787 #define GP_form_ix      SVp | offsetof(struct gp, gp_form)
1788 #define GP_egv_ix       SVp | offsetof(struct gp, gp_egv)
1789 #define GP_line_ix      line_tp | offsetof(struct gp, gp_line)
1790
1791 void
1792 SV(gv)
1793         B::GV   gv
1794     ALIAS:
1795         SV = GP_sv_ix
1796         IO = GP_io_ix
1797         CV = GP_cv_ix
1798         CVGEN = GP_cvgen_ix
1799         GvREFCNT = GP_refcnt_ix
1800         HV = GP_hv_ix
1801         AV = GP_av_ix
1802         FORM = GP_form_ix
1803         EGV = GP_egv_ix
1804         LINE = GP_line_ix
1805     PREINIT:
1806         GP *gp;
1807         char *ptr;
1808         SV *ret;
1809     PPCODE:
1810         gp = GvGP(gv);
1811         if (!gp) {
1812             const GV *const gv = CvGV(cv);
1813             Perl_croak(aTHX_ "NULL gp in B::GV::%s", gv ? GvNAME(gv) : "???");
1814         }
1815         ptr = (ix & 0xFFFF) + (char *)gp;
1816         switch ((U8)(ix >> 16)) {
1817         case (U8)(SVp >> 16):
1818             ret = make_sv_object(aTHX_ *((SV **)ptr));
1819             break;
1820         case (U8)(U32p >> 16):
1821             ret = sv_2mortal(newSVuv(*((U32*)ptr)));
1822             break;
1823         case (U8)(line_tp >> 16):
1824             ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
1825             break;
1826         default:
1827             croak("Illegal alias 0x%08x for B::*SV", (unsigned)ix);
1828         }
1829         ST(0) = ret;
1830         XSRETURN(1);
1831
1832 void
1833 FILEGV(gv)
1834         B::GV   gv
1835     PPCODE:
1836         PUSHs(make_sv_object(aTHX_ (SV *)GvFILEGV(gv)));
1837
1838 MODULE = B      PACKAGE = B::IO         PREFIX = Io
1839
1840 #if PERL_VERSION <= 8
1841
1842 short
1843 IoSUBPROCESS(io)
1844         B::IO   io
1845
1846 #endif
1847
1848 bool
1849 IsSTD(io,name)
1850         B::IO   io
1851         const char*     name
1852     PREINIT:
1853         PerlIO* handle = 0;
1854     CODE:
1855         if( strEQ( name, "stdin" ) ) {
1856             handle = PerlIO_stdin();
1857         }
1858         else if( strEQ( name, "stdout" ) ) {
1859             handle = PerlIO_stdout();
1860         }
1861         else if( strEQ( name, "stderr" ) ) {
1862             handle = PerlIO_stderr();
1863         }
1864         else {
1865             croak( "Invalid value '%s'", name );
1866         }
1867         RETVAL = handle == IoIFP(io);
1868     OUTPUT:
1869         RETVAL
1870
1871 MODULE = B      PACKAGE = B::AV         PREFIX = Av
1872
1873 SSize_t
1874 AvFILL(av)
1875         B::AV   av
1876
1877 void
1878 AvARRAY(av)
1879         B::AV   av
1880     PPCODE:
1881         if (AvFILL(av) >= 0) {
1882             SV **svp = AvARRAY(av);
1883             I32 i;
1884             for (i = 0; i <= AvFILL(av); i++)
1885                 XPUSHs(make_sv_object(aTHX_ svp[i]));
1886         }
1887
1888 void
1889 AvARRAYelt(av, idx)
1890         B::AV   av
1891         int     idx
1892     PPCODE:
1893         if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
1894             XPUSHs(make_sv_object(aTHX_ (AvARRAY(av)[idx])));
1895         else
1896             XPUSHs(make_sv_object(aTHX_ NULL));
1897
1898 #if PERL_VERSION < 9
1899
1900 #define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1901
1902 IV
1903 AvOFF(av)
1904         B::AV   av
1905
1906 MODULE = B      PACKAGE = B::AV
1907
1908 U8
1909 AvFLAGS(av)
1910         B::AV   av
1911
1912 #endif
1913
1914 MODULE = B      PACKAGE = B::CV         PREFIX = Cv
1915
1916 U32
1917 CvCONST(cv)
1918         B::CV   cv
1919
1920 void
1921 CvSTART(cv)
1922         B::CV   cv
1923     ALIAS:
1924         ROOT = 1
1925     PPCODE:
1926         PUSHs(make_op_object(aTHX_ CvISXSUB(cv) ? NULL
1927                              : ix ? CvROOT(cv) : CvSTART(cv)));
1928
1929 void
1930 CvXSUB(cv)
1931         B::CV   cv
1932     ALIAS:
1933         XSUBANY = 1
1934     CODE:
1935         ST(0) = ix && CvCONST(cv)
1936             ? make_sv_object(aTHX_ (SV *)CvXSUBANY(cv).any_ptr)
1937             : sv_2mortal(newSViv(CvISXSUB(cv)
1938                                  ? (ix ? CvXSUBANY(cv).any_iv
1939                                        : PTR2IV(CvXSUB(cv)))
1940                                  : 0));
1941
1942 void
1943 const_sv(cv)
1944         B::CV   cv
1945     PPCODE:
1946         PUSHs(make_sv_object(aTHX_ (SV *)cv_const_sv(cv)));
1947
1948 MODULE = B      PACKAGE = B::HV         PREFIX = Hv
1949
1950 STRLEN
1951 HvFILL(hv)
1952         B::HV   hv
1953
1954 I32
1955 HvRITER(hv)
1956         B::HV   hv
1957
1958 #if PERL_VERSION < 9
1959
1960 B::PMOP
1961 HvPMROOT(hv)
1962         B::HV   hv
1963     PPCODE:
1964         PUSHs(make_op_object(aTHX_ HvPMROOT(hv)));
1965
1966 #endif
1967
1968 void
1969 HvARRAY(hv)
1970         B::HV   hv
1971     PPCODE:
1972         if (HvUSEDKEYS(hv) > 0) {
1973             SV *sv;
1974             char *key;
1975             I32 len;
1976             (void)hv_iterinit(hv);
1977             EXTEND(sp, HvUSEDKEYS(hv) * 2);
1978             while ((sv = hv_iternextsv(hv, &key, &len))) {
1979                 mPUSHp(key, len);
1980                 PUSHs(make_sv_object(aTHX_ sv));
1981             }
1982         }
1983
1984 MODULE = B      PACKAGE = B::HE         PREFIX = He
1985
1986 void
1987 HeVAL(he)
1988         B::HE he
1989     ALIAS:
1990         SVKEY_force = 1
1991     PPCODE:
1992         PUSHs(make_sv_object(aTHX_ ix ? HeSVKEY_force(he) : HeVAL(he)));
1993
1994 U32
1995 HeHASH(he)
1996         B::HE he
1997
1998 MODULE = B      PACKAGE = B::RHE
1999
2000 #if PERL_VERSION >= 9
2001
2002 SV*
2003 HASH(h)
2004         B::RHE h
2005     CODE:
2006         RETVAL = newRV( (SV*)cophh_2hv(h, 0) );
2007     OUTPUT:
2008         RETVAL
2009
2010 #endif