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 < 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 SV *
 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, 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         }
 963         ST(0) = ret;
 964         XSRETURN(1);
 965
 966 char *
 967 name(o)
 968         B::OP           o
 969     ALIAS:
 970         desc = 1
 971     CODE:
 972         RETVAL = (char *)(ix ? OP_DESC(o) : OP_NAME(o));
 973     OUTPUT:
 974         RETVAL
 975
 976 void
 977 ppaddr(o)
 978         B::OP           o
 979     PREINIT:
 980         int i;
 981         SV *sv = newSVpvs_flags("PL_ppaddr[OP_", SVs_TEMP);
 982     CODE:
 983         sv_catpv(sv, PL_op_name[o->op_type]);
 984         for (i=13; (STRLEN)i < SvCUR(sv); ++i)
 985             SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]);
 986         sv_catpvs(sv, "]");
 987         ST(0) = sv;
 988
 989 #if PERL_VERSION >= 9
 990 #  These 3 are all bitfields, so we can't take their addresses.
 991 UV
 992 type(o)
 993         B::OP           o
 994     ALIAS:
 995         opt = 1
 996         spare = 2
 997     CODE:
 998         switch(ix) {
 999           case 1:
1000             RETVAL = o->op_opt;
1001             break;
1002           case 2:
1003             RETVAL = o->op_spare;
1004             break;
1005           default:
1006             RETVAL = o->op_type;
1007         }
1008     OUTPUT:
1009         RETVAL
1010
1011 #else
1012
1013 UV
1014 type(o)
1015         B::OP           o
1016     ALIAS:
1017         seq = 1
1018     CODE:
1019         switch(ix) {
1020           case 1:
1021             RETVAL = o->op_seq;
1022             break;
1023           default:
1024             RETVAL = o->op_type;
1025         }
1026     OUTPUT:
1027         RETVAL
1028
1029 #endif
1030
1031 void
1032 oplist(o)
1033         B::OP           o
1034     PPCODE:
1035         SP = oplist(aTHX_ o, SP);
1036
1037 MODULE = B      PACKAGE = B::LISTOP
1038
1039 U32
1040 children(o)
1041         B::LISTOP       o
1042         OP *            kid = NO_INIT
1043         int             i = NO_INIT
1044     CODE:
1045         i = 0;
1046         for (kid = o->op_first; kid; kid = kid->op_sibling)
1047             i++;
1048         RETVAL = i;
1049     OUTPUT:
1050         RETVAL
1051
1052 MODULE = B      PACKAGE = B::PMOP               PREFIX = PMOP_
1053
1054 #if PERL_VERSION <= 8
1055
1056 void
1057 PMOP_pmreplroot(o)
1058         B::PMOP         o
1059         OP *            root = NO_INIT
1060     CODE:
1061         root = o->op_pmreplroot;
1062         /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */
1063         if (o->op_type == OP_PUSHRE) {
1064             ST(0) = sv_newmortal();
1065 #  ifdef USE_ITHREADS
1066             sv_setiv(ST(0), INT2PTR(PADOFFSET,root) );
1067 #  else
1068             sv_setiv(newSVrv(ST(0), root ?
1069                              svclassnames[SvTYPE((SV*)root)] : "B::SV"),
1070                      PTR2IV(root));
1071 #  endif
1072         }
1073         else {
1074             ST(0) = make_op_object(aTHX_ root);
1075         }
1076
1077 #else
1078
1079 void
1080 PMOP_pmreplroot(o)
1081         B::PMOP         o
1082     CODE:
1083         if (o->op_type == OP_PUSHRE) {
1084 #  ifdef USE_ITHREADS
1085             ST(0) = sv_newmortal();
1086             sv_setiv(ST(0), o->op_pmreplrootu.op_pmtargetoff);
1087 #  else
1088             GV *const target = o->op_pmreplrootu.op_pmtargetgv;
1089             ST(0) = sv_newmortal();
1090             sv_setiv(newSVrv(ST(0), target ?
1091                              svclassnames[SvTYPE((SV*)target)] : "B::SV"),
1092                      PTR2IV(target));
1093 #  endif
1094         }
1095         else {
1096             OP *const root = o->op_pmreplrootu.op_pmreplroot;
1097             ST(0) = make_op_object(aTHX_ root);
1098         }
1099
1100 #endif
1101
1102 #ifdef USE_ITHREADS
1103 #define PMOP_pmstashpv(o)       PmopSTASHPV(o);
1104
1105 char*
1106 PMOP_pmstashpv(o)
1107         B::PMOP         o
1108
1109 #else
1110
1111 void
1112 PMOP_pmstash(o)
1113         B::PMOP         o
1114     PPCODE:
1115         PUSHs(make_sv_object(aTHX_ (SV *) PmopSTASH(o)));
1116
1117 #endif
1118
1119 #if PERL_VERSION < 9
1120
1121 void
1122 PMOP_pmnext(o)
1123         B::PMOP         o
1124     PPCODE:
1125         PUSHs(make_op_object(aTHX_ o->op_pmnext));
1126
1127 U32
1128 PMOP_pmpermflags(o)
1129         B::PMOP         o
1130
1131 U8
1132 PMOP_pmdynflags(o)
1133         B::PMOP         o
1134
1135 #endif
1136
1137 void
1138 PMOP_precomp(o)
1139         B::PMOP         o
1140     PREINIT:
1141         dXSI32;
1142         REGEXP *rx;
1143     CODE:
1144         rx = PM_GETRE(o);
1145         ST(0) = sv_newmortal();
1146         if (rx) {
1147 #if PERL_VERSION >= 9
1148             if (ix) {
1149                 sv_setuv(ST(0), RX_EXTFLAGS(rx));
1150             } else
1151 #endif
1152             {
1153                 sv_setpvn(ST(0), RX_PRECOMP(rx), RX_PRELEN(rx));
1154             }
1155         }
1156
1157 BOOT:
1158 {
1159         CV *cv;
1160 #ifdef USE_ITHREADS
1161         cv = newXS("B::PMOP::pmoffset", XS_B__OP_next, __FILE__);
1162         XSANY.any_i32 = PMOP_pmoffset_ix;
1163         cv = newXS("B::COP::stashpv", XS_B__OP_next, __FILE__);
1164         XSANY.any_i32 = COP_stashpv_ix;
1165         cv = newXS("B::COP::file", XS_B__OP_next, __FILE__);
1166         XSANY.any_i32 = COP_file_ix;
1167 #else
1168         cv = newXS("B::COP::stash", XS_B__OP_next, __FILE__);
1169         XSANY.any_i32 = COP_stash_ix;
1170         cv = newXS("B::COP::filegv", XS_B__OP_next, __FILE__);
1171         XSANY.any_i32 = COP_filegv_ix;
1172 #endif
1173 #if PERL_VERSION >= 9
1174         cv = newXS("B::PMOP::reflags", XS_B__PMOP_precomp, __FILE__);
1175         XSANY.any_i32 = 1;
1176 #endif
1177 }
1178
1179 MODULE = B      PACKAGE = B::PADOP
1180
1181 void
1182 sv(o)
1183         B::PADOP o
1184     PREINIT:
1185         SV *ret;
1186     ALIAS:
1187         gv = 1
1188     PPCODE:
1189         /* It happens that the output typemaps for B::SV and B::GV are
1190            identical. The "smarts" are in make_sv_object(), which determines
1191            which class to use based on SvTYPE(), rather than anything baked in
1192            at compile time.  */
1193         if (o->op_padix) {
1194             ret = PAD_SVl(o->op_padix);
1195             if (ix && SvTYPE(ret) != SVt_PVGV)
1196                 ret = NULL;
1197         } else {
1198             ret = NULL;
1199         }
1200         PUSHs(make_sv_object(aTHX_ ret));
1201
1202 MODULE = B      PACKAGE = B::PVOP
1203
1204 void
1205 pv(o)
1206         B::PVOP o
1207     CODE:
1208         /*
1209          * OP_TRANS uses op_pv to point to a table of 256 or >=258 shorts
1210          * whereas other PVOPs point to a null terminated string.
1211          */
1212         if ((o->op_type == OP_TRANS || o->op_type == OP_TRANSR) &&
1213                 (o->op_private & OPpTRANS_COMPLEMENT) &&
1214                 !(o->op_private & OPpTRANS_DELETE))
1215         {
1216             const short* const tbl = (short*)o->op_pv;
1217             const short entries = 257 + tbl[256];
1218             ST(0) = newSVpvn_flags(o->op_pv, entries * sizeof(short), SVs_TEMP);
1219         }
1220         else if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
1221             ST(0) = newSVpvn_flags(o->op_pv, 256 * sizeof(short), SVs_TEMP);
1222         }
1223         else
1224             ST(0) = newSVpvn_flags(o->op_pv, strlen(o->op_pv), SVs_TEMP);
1225
1226 #define COP_label(o)    CopLABEL(o)
1227 #define COP_arybase(o)  CopARYBASE_get(o)
1228
1229 MODULE = B      PACKAGE = B::COP                PREFIX = COP_
1230
1231 const char *
1232 COP_label(o)
1233         B::COP  o
1234
1235 # Both pairs of accessors are provided for both ithreads and not, but for each,
1236 # one pair is direct structure access, and 1 pair "faked up" with a more complex
1237 # macro. We implement the direct structure access pair using the common code
1238 # above (B::OP::next)
1239
1240 #ifdef USE_ITHREADS
1241
1242 void
1243 COP_stash(o)
1244         B::COP  o
1245     ALIAS:
1246         filegv = 1
1247     PPCODE:
1248         PUSHs(make_sv_object(aTHX_
1249                              ix ? (SV *)CopFILEGV(o) : (SV *)CopSTASH(o)));
1250
1251 #else
1252
1253 char *
1254 COP_stashpv(o)
1255         B::COP  o
1256     ALIAS:
1257         file = 1
1258     CODE:
1259         RETVAL = ix ? CopFILE(o) : CopSTASHPV(o);
1260     OUTPUT:
1261         RETVAL
1262
1263 #endif
1264
1265 I32
1266 COP_arybase(o)
1267         B::COP  o
1268
1269 void
1270 COP_warnings(o)
1271         B::COP  o
1272     ALIAS:
1273         io = 1
1274     PPCODE:
1275 #if PERL_VERSION >= 9
1276         ST(0) = ix ? make_cop_io_object(aTHX_ o) : make_warnings_object(aTHX_ o);
1277 #else
1278         ST(0) = make_sv_object(aTHX_ ix ? o->cop_io : o->cop_warnings);
1279 #endif
1280         XSRETURN(1);
1281
1282 #if PERL_VERSION >= 9
1283
1284 B::RHE
1285 COP_hints_hash(o)
1286         B::COP o
1287     CODE:
1288         RETVAL = CopHINTHASH_get(o);
1289     OUTPUT:
1290         RETVAL
1291
1292 #endif
1293
1294 MODULE = B      PACKAGE = B::SV
1295
1296 #define MAGICAL_FLAG_BITS (SVs_GMG|SVs_SMG|SVs_RMG)
1297
1298 U32
1299 REFCNT(sv)
1300         B::SV   sv
1301     ALIAS:
1302         FLAGS = 0xFFFFFFFF
1303         SvTYPE = SVTYPEMASK
1304         POK = SVf_POK
1305         ROK = SVf_ROK
1306         MAGICAL = MAGICAL_FLAG_BITS
1307     CODE:
1308         RETVAL = ix ? (SvFLAGS(sv) & (U32)ix) : SvREFCNT(sv);
1309     OUTPUT:
1310         RETVAL
1311
1312 void
1313 object_2svref(sv)
1314         B::SV   sv
1315     PPCODE:
1316         ST(0) = sv_2mortal(newRV(sv));
1317         XSRETURN(1);
1318
1319 MODULE = B      PACKAGE = B::IV         PREFIX = Sv
1320
1321 IV
1322 SvIV(sv)
1323         B::IV   sv
1324
1325 MODULE = B      PACKAGE = B::IV
1326
1327 #define sv_SVp          0x00000
1328 #define sv_IVp          0x10000
1329 #define sv_UVp          0x20000
1330 #define sv_STRLENp      0x30000
1331 #define sv_U32p         0x40000
1332 #define sv_U8p          0x50000
1333 #define sv_char_pp      0x60000
1334 #define sv_NVp          0x70000
1335 #define sv_char_p       0x80000
1336 #define sv_SSize_tp     0x90000
1337 #define sv_I32p         0xA0000
1338 #define sv_U16p         0xB0000
1339
1340 #define IV_ivx_ix       sv_IVp | offsetof(struct xpviv, xiv_iv)
1341 #define IV_uvx_ix       sv_UVp | offsetof(struct xpvuv, xuv_uv)
1342 #define NV_nvx_ix       sv_NVp | offsetof(struct xpvnv, xnv_u.xnv_nv)
1343
1344 #if PERL_VERSION >= 10
1345 #define NV_cop_seq_range_low_ix \
1346                         sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
1347 #define NV_cop_seq_range_high_ix \
1348                         sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
1349 #define NV_parent_pad_index_ix \
1350                         sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
1351 #define NV_parent_fakelex_flags_ix \
1352                         sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
1353 #else
1354 #define NV_cop_seq_range_low_ix \
1355                         sv_NVp | offsetof(struct xpvnv, xnv_nv)
1356 #define NV_cop_seq_range_high_ix \
1357                         sv_UVp | offsetof(struct xpvnv, xuv_uv)
1358 #define NV_parent_pad_index_ix \
1359                         sv_NVp | offsetof(struct xpvnv, xnv_nv)
1360 #define NV_parent_fakelex_flags_ix \
1361                         sv_UVp | offsetof(struct xpvnv, xuv_uv)
1362 #endif
1363
1364 #define PV_cur_ix       sv_STRLENp | offsetof(struct xpv, xpv_cur)
1365 #define PV_len_ix       sv_STRLENp | offsetof(struct xpv, xpv_len)
1366
1367 #define PVMG_stash_ix   sv_SVp | offsetof(struct xpvmg, xmg_stash)
1368
1369 #if PERL_VERSION >= 10
1370 #define PVBM_useful_ix  sv_I32p | offsetof(struct xpvgv, xiv_u.xivu_i32)
1371 #define PVBM_previous_ix    sv_U32p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_previous)
1372 #define PVBM_rare_ix    sv_U8p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_rare)
1373 #else
1374 #define PVBM_useful_ix  sv_I32p | offsetof(struct xpvbm, xbm_useful)
1375 #define PVBM_previous_ix    sv_U16p | offsetof(struct xpvbm, xbm_previous)
1376 #define PVBM_rare_ix    sv_U8p | offsetof(struct xpvbm, xbm_rare)
1377 #endif
1378
1379 #define PVLV_targoff_ix sv_U32p | offsetof(struct xpvlv, xlv_targoff)
1380 #define PVLV_targlen_ix sv_U32p | offsetof(struct xpvlv, xlv_targlen)
1381 #define PVLV_targ_ix    sv_SVp | offsetof(struct xpvlv, xlv_targ)
1382 #define PVLV_type_ix    sv_char_p | offsetof(struct xpvlv, xlv_type)
1383
1384 #if PERL_VERSION >= 10
1385 #define PVGV_stash_ix   sv_SVp | offsetof(struct xpvgv, xnv_u.xgv_stash)
1386 #define PVGV_flags_ix   sv_STRLENp | offsetof(struct xpvgv, xpv_cur)
1387 #define PVIO_lines_ix   sv_IVp | offsetof(struct xpvio, xiv_iv)
1388 #else
1389 #define PVGV_stash_ix   sv_SVp | offsetof(struct xpvgv, xgv_stash)
1390 #define PVGV_flags_ix   sv_U8p | offsetof(struct xpvgv, xgv_flags)
1391 #define PVIO_lines_ix   sv_IVp | offsetof(struct xpvio, xio_lines)
1392 #endif
1393
1394 #define PVIO_page_ix        sv_IVp | offsetof(struct xpvio, xio_page)
1395 #define PVIO_page_len_ix    sv_IVp | offsetof(struct xpvio, xio_page_len)
1396 #define PVIO_lines_left_ix  sv_IVp | offsetof(struct xpvio, xio_lines_left)
1397 #define PVIO_top_name_ix    sv_char_pp | offsetof(struct xpvio, xio_top_name)
1398 #define PVIO_top_gv_ix      sv_SVp | offsetof(struct xpvio, xio_top_gv)
1399 #define PVIO_fmt_name_ix    sv_char_pp | offsetof(struct xpvio, xio_fmt_name)
1400 #define PVIO_fmt_gv_ix      sv_SVp | offsetof(struct xpvio, xio_fmt_gv)
1401 #define PVIO_bottom_name_ix sv_char_pp | offsetof(struct xpvio, xio_bottom_name)
1402 #define PVIO_bottom_gv_ix   sv_SVp | offsetof(struct xpvio, xio_bottom_gv)
1403 #define PVIO_type_ix        sv_char_p | offsetof(struct xpvio, xio_type)
1404 #define PVIO_flags_ix       sv_U8p | offsetof(struct xpvio, xio_flags)
1405
1406 #define PVAV_max_ix     sv_SSize_tp | offsetof(struct xpvav, xav_max)
1407
1408 #define PVFM_lines_ix   sv_IVp | offsetof(struct xpvfm, xfm_lines)
1409
1410 #define PVCV_stash_ix   sv_SVp | offsetof(struct xpvcv, xcv_stash)
1411 #define PVCV_gv_ix      sv_SVp | offsetof(struct xpvcv, xcv_gv)
1412 #define PVCV_file_ix    sv_char_pp | offsetof(struct xpvcv, xcv_file)
1413 #define PVCV_depth_ix   sv_I32p | offsetof(struct xpvcv, xcv_depth)
1414 #define PVCV_padlist_ix sv_SVp | offsetof(struct xpvcv, xcv_padlist)
1415 #define PVCV_outside_ix sv_SVp | offsetof(struct xpvcv, xcv_outside)
1416 #define PVCV_outside_seq_ix sv_U32p | offsetof(struct xpvcv, xcv_outside_seq)
1417 #define PVCV_flags_ix   sv_U16p | offsetof(struct xpvcv, xcv_flags)
1418
1419 #define PVHV_max_ix     sv_STRLENp | offsetof(struct xpvhv, xhv_max)
1420
1421 #if PERL_VERSION > 12
1422 #define PVHV_keys_ix    sv_STRLENp | offsetof(struct xpvhv, xhv_keys)
1423 #else
1424 #define PVHV_keys_ix    sv_IVp | offsetof(struct xpvhv, xhv_keys)
1425 #endif
1426
1427 # The type checking code in B has always been identical for all SV types,
1428 # irrespective of whether the action is actually defined on that SV.
1429 # We should fix this
1430 void
1431 IVX(sv)
1432         B::SV           sv
1433     ALIAS:
1434         B::IV::IVX = IV_ivx_ix
1435         B::IV::UVX = IV_uvx_ix
1436         B::NV::NVX = NV_nvx_ix
1437         B::NV::COP_SEQ_RANGE_LOW = NV_cop_seq_range_low_ix
1438         B::NV::COP_SEQ_RANGE_HIGH = NV_cop_seq_range_high_ix
1439         B::NV::PARENT_PAD_INDEX = NV_parent_pad_index_ix
1440         B::NV::PARENT_FAKELEX_FLAGS = NV_parent_fakelex_flags_ix
1441         B::PV::CUR = PV_cur_ix
1442         B::PV::LEN = PV_len_ix
1443         B::PVMG::SvSTASH = PVMG_stash_ix
1444         B::PVLV::TARGOFF = PVLV_targoff_ix
1445         B::PVLV::TARGLEN = PVLV_targlen_ix
1446         B::PVLV::TARG = PVLV_targ_ix
1447         B::PVLV::TYPE = PVLV_type_ix
1448         B::GV::STASH = PVGV_stash_ix
1449         B::GV::GvFLAGS = PVGV_flags_ix
1450         B::BM::USEFUL = PVBM_useful_ix
1451         B::BM::PREVIOUS = PVBM_previous_ix
1452         B::BM::RARE = PVBM_rare_ix
1453         B::IO::LINES =  PVIO_lines_ix
1454         B::IO::PAGE = PVIO_page_ix
1455         B::IO::PAGE_LEN = PVIO_page_len_ix
1456         B::IO::LINES_LEFT = PVIO_lines_left_ix
1457         B::IO::TOP_NAME = PVIO_top_name_ix
1458         B::IO::TOP_GV = PVIO_top_gv_ix
1459         B::IO::FMT_NAME = PVIO_fmt_name_ix
1460         B::IO::FMT_GV = PVIO_fmt_gv_ix
1461         B::IO::BOTTOM_NAME = PVIO_bottom_name_ix
1462         B::IO::BOTTOM_GV = PVIO_bottom_gv_ix
1463         B::IO::IoTYPE = PVIO_type_ix
1464         B::IO::IoFLAGS = PVIO_flags_ix
1465         B::AV::MAX = PVAV_max_ix
1466         B::FM::LINES = PVFM_lines_ix
1467         B::CV::STASH = PVCV_stash_ix
1468         B::CV::GV = PVCV_gv_ix
1469         B::CV::FILE = PVCV_file_ix
1470         B::CV::DEPTH = PVCV_depth_ix
1471         B::CV::PADLIST = PVCV_padlist_ix
1472         B::CV::OUTSIDE = PVCV_outside_ix
1473         B::CV::OUTSIDE_SEQ = PVCV_outside_seq_ix
1474         B::CV::CvFLAGS = PVCV_flags_ix
1475         B::HV::MAX = PVHV_max_ix
1476         B::HV::KEYS = PVHV_keys_ix
1477     PREINIT:
1478         char *ptr;
1479         SV *ret;
1480     PPCODE:
1481         ptr = (ix & 0xFFFF) + (char *)SvANY(sv);
1482         switch ((U8)(ix >> 16)) {
1483         case (U8)(sv_SVp >> 16):
1484             ret = make_sv_object(aTHX_ *((SV **)ptr));
1485             break;
1486         case (U8)(sv_IVp >> 16):
1487             ret = sv_2mortal(newSViv(*((IV *)ptr)));
1488             break;
1489         case (U8)(sv_UVp >> 16):
1490             ret = sv_2mortal(newSVuv(*((UV *)ptr)));
1491             break;
1492         case (U8)(sv_STRLENp >> 16):
1493             ret = sv_2mortal(newSVuv(*((STRLEN *)ptr)));
1494             break;
1495         case (U8)(sv_U32p >> 16):
1496             ret = sv_2mortal(newSVuv(*((U32 *)ptr)));
1497             break;
1498         case (U8)(sv_U8p >> 16):
1499             ret = sv_2mortal(newSVuv(*((U8 *)ptr)));
1500             break;
1501         case (U8)(sv_char_pp >> 16):
1502             ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
1503             break;
1504         case (U8)(sv_NVp >> 16):
1505             ret = sv_2mortal(newSVnv(*((NV *)ptr)));
1506             break;
1507         case (U8)(sv_char_p >> 16):
1508             ret = newSVpvn_flags((char *)ptr, 1, SVs_TEMP);
1509             break;
1510         case (U8)(sv_SSize_tp >> 16):
1511             ret = sv_2mortal(newSViv(*((SSize_t *)ptr)));
1512             break;
1513         case (U8)(sv_I32p >> 16):
1514             ret = sv_2mortal(newSVuv(*((I32 *)ptr)));
1515             break;
1516         case (U8)(sv_U16p >> 16):
1517             ret = sv_2mortal(newSVuv(*((U16 *)ptr)));
1518             break;
1519         }
1520         ST(0) = ret;
1521         XSRETURN(1);
1522
1523 void
1524 packiv(sv)
1525         B::IV   sv
1526     ALIAS:
1527         needs64bits = 1
1528     CODE:
1529         if (ix) {
1530             ST(0) = boolSV((I32)SvIVX(sv) != SvIVX(sv));
1531         } else if (sizeof(IV) == 8) {
1532             U32 wp[2];
1533             const IV iv = SvIVX(sv);
1534             /*
1535              * The following way of spelling 32 is to stop compilers on
1536              * 32-bit architectures from moaning about the shift count
1537              * being >= the width of the type. Such architectures don't
1538              * reach this code anyway (unless sizeof(IV) > 8 but then
1539              * everything else breaks too so I'm not fussed at the moment).
1540              */
1541 #ifdef UV_IS_QUAD
1542             wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1543 #else
1544             wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1545 #endif
1546             wp[1] = htonl(iv & 0xffffffff);
1547             ST(0) = newSVpvn_flags((char *)wp, 8, SVs_TEMP);
1548         } else {
1549             U32 w = htonl((U32)SvIVX(sv));
1550             ST(0) = newSVpvn_flags((char *)&w, 4, SVs_TEMP);
1551         }
1552
1553 MODULE = B      PACKAGE = B::NV         PREFIX = Sv
1554
1555 NV
1556 SvNV(sv)
1557         B::NV   sv
1558
1559 #if PERL_VERSION < 11
1560
1561 MODULE = B      PACKAGE = B::RV         PREFIX = Sv
1562
1563 void
1564 SvRV(sv)
1565         B::RV   sv
1566     PPCODE:
1567         PUSHs(make_sv_object(aTHX_ SvRV(sv)));
1568
1569 #else
1570
1571 MODULE = B      PACKAGE = B::REGEXP
1572
1573 void
1574 REGEX(sv)
1575         B::REGEXP       sv
1576     ALIAS:
1577         precomp = 1
1578     PPCODE:
1579         if (ix) {
1580             PUSHs(newSVpvn_flags(RX_PRECOMP(sv), RX_PRELEN(sv), SVs_TEMP));
1581         } else {
1582             dXSTARG;
1583             /* FIXME - can we code this method more efficiently?  */
1584             PUSHi(PTR2IV(sv));
1585         }
1586
1587 #endif
1588
1589 MODULE = B      PACKAGE = B::PV
1590
1591 void
1592 RV(sv)
1593         B::PV   sv
1594     PPCODE:
1595         if (!SvROK(sv))
1596             croak( "argument is not SvROK" );
1597         PUSHs(make_sv_object(aTHX_ SvRV(sv)));
1598
1599 void
1600 PV(sv)
1601         B::PV   sv
1602     ALIAS:
1603         PVX = 1
1604         PVBM = 2
1605         B::BM::TABLE = 3
1606     PREINIT:
1607         const char *p;
1608         STRLEN len = 0;
1609         U32 utf8 = 0;
1610     CODE:
1611         if (ix == 3) {
1612             p = SvPV(sv, len);
1613             /* Boyer-Moore table is just after string and its safety-margin \0 */
1614             p += len + PERL_FBM_TABLE_OFFSET;
1615             len = 256;
1616         } else if (ix == 2) {
1617             /* This used to read 257. I think that that was buggy - should have
1618                been 258. (The "\0", the flags byte, and 256 for the table.  Not
1619                that anything anywhere calls this method.  NWC.  */
1620             /* Also, the start pointer has always been SvPVX(sv). Surely it
1621                should be SvPVX(sv) + SvCUR(sv)?  The code has faithfully been
1622                refactored with this behaviour, since PVBM was added in
1623                651aa52ea1faa806.  */
1624             p = SvPVX_const(sv);
1625             len = SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0);
1626         } else if (ix) {
1627             p = SvPVX(sv);
1628             len = strlen(p);
1629         } else if (SvPOK(sv)) {
1630             len = SvCUR(sv);
1631             p = SvPVX_const(sv);
1632             utf8 = SvUTF8(sv);
1633 #if PERL_VERSION < 10
1634             /* Before 5.10 (well 931b58fb28fa5ca7), PAD_COMPNAME_GEN was stored
1635                in SvCUR(), which meant we had to attempt this special casing
1636                to avoid tripping up over variable names in the pads.  */
1637             if((SvLEN(sv) && len >= SvLEN(sv))) {
1638                 /* It claims to be longer than the space allocated for it -
1639                    presuambly it's a variable name in the pad  */
1640                 len = strlen(p);
1641             }
1642 #endif
1643         }
1644         else {
1645             /* XXX for backward compatibility, but should fail */
1646             /* croak( "argument is not SvPOK" ); */
1647             p = NULL;
1648         }
1649         ST(0) = newSVpvn_flags(p, len, SVs_TEMP | utf8);
1650
1651 MODULE = B      PACKAGE = B::PVMG
1652
1653 void
1654 MAGIC(sv)
1655         B::PVMG sv
1656         MAGIC * mg = NO_INIT
1657     PPCODE:
1658         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
1659             XPUSHs(make_mg_object(aTHX_ mg));
1660
1661 MODULE = B      PACKAGE = B::MAGIC
1662
1663 void
1664 MOREMAGIC(mg)
1665         B::MAGIC        mg
1666     ALIAS:
1667         PRIVATE = 1
1668         TYPE = 2
1669         FLAGS = 3
1670         LENGTH = 4
1671         OBJ = 5
1672         PTR = 6
1673         REGEX = 7
1674         precomp = 8
1675     PPCODE:
1676         switch (ix) {
1677         case 0:
1678             XPUSHs(mg->mg_moremagic ? make_mg_object(aTHX_ mg->mg_moremagic)
1679                                     : &PL_sv_undef);
1680             break;
1681         case 1:
1682             mPUSHu(mg->mg_private);
1683             break;
1684         case 2:
1685             PUSHs(newSVpvn_flags(&(mg->mg_type), 1, SVs_TEMP));
1686             break;
1687         case 3:
1688             mPUSHu(mg->mg_flags);
1689             break;
1690         case 4:
1691             mPUSHi(mg->mg_len);
1692             break;
1693         case 5:
1694             PUSHs(make_sv_object(aTHX_ mg->mg_obj));
1695             break;
1696         case 6:
1697             if (mg->mg_ptr) {
1698                 if (mg->mg_len >= 0) {
1699                     PUSHs(newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP));
1700                 } else if (mg->mg_len == HEf_SVKEY) {
1701                     PUSHs(make_sv_object(aTHX_ (SV*)mg->mg_ptr));
1702                 } else
1703                     PUSHs(sv_newmortal());
1704             } else
1705                 PUSHs(sv_newmortal());
1706             break;
1707         case 7:
1708             if(mg->mg_type == PERL_MAGIC_qr) {
1709                 mPUSHi(PTR2IV(mg->mg_obj));
1710             } else {
1711                 croak("REGEX is only meaningful on r-magic");
1712             }
1713             break;
1714         case 8:
1715             if (mg->mg_type == PERL_MAGIC_qr) {
1716                 REGEXP *rx = (REGEXP *)mg->mg_obj;
1717                 PUSHs(newSVpvn_flags(rx ? RX_PRECOMP(rx) : NULL,
1718                                      rx ? RX_PRELEN(rx) : 0, SVs_TEMP));
1719             } else {
1720                 croak( "precomp is only meaningful on r-magic" );
1721             }
1722             break;
1723         }
1724
1725 MODULE = B      PACKAGE = B::GV         PREFIX = Gv
1726
1727 void
1728 GvNAME(gv)
1729         B::GV   gv
1730     ALIAS:
1731         FILE = 1
1732         B::HV::NAME = 2
1733     CODE:
1734 #if PERL_VERSION >= 10
1735         ST(0) = sv_2mortal(newSVhek(!ix ? GvNAME_HEK(gv)
1736                                         : (ix == 1 ? GvFILE_HEK(gv)
1737                                                    : HvNAME_HEK((HV *)gv))));
1738 #else
1739         ST(0) = !ix ? newSVpvn_flags(GvNAME(gv), GvNAMELEN(gv), SVs_TEMP)
1740                     : sv_2mortal(newSVpv(ix == 1 ? GvFILE(gv) : HvNAME((HV *)gv), 0))
1741 #endif
1742
1743 bool
1744 is_empty(gv)
1745         B::GV   gv
1746     ALIAS:
1747         isGV_with_GP = 1
1748     CODE:
1749         if (ix) {
1750 #if PERL_VERSION >= 9
1751             RETVAL = isGV_with_GP(gv) ? TRUE : FALSE;
1752 #else
1753             RETVAL = TRUE; /* In 5.8 and earlier they all are.  */
1754 #endif
1755         } else {
1756             RETVAL = GvGP(gv) == Null(GP*);
1757         }
1758     OUTPUT:
1759         RETVAL
1760
1761 void*
1762 GvGP(gv)
1763         B::GV   gv
1764
1765 #define GP_sv_ix        SVp | offsetof(struct gp, gp_sv)
1766 #define GP_io_ix        SVp | offsetof(struct gp, gp_io)
1767 #define GP_cv_ix        SVp | offsetof(struct gp, gp_cv)
1768 #define GP_cvgen_ix     U32p | offsetof(struct gp, gp_cvgen)
1769 #define GP_refcnt_ix    U32p | offsetof(struct gp, gp_refcnt)
1770 #define GP_hv_ix        SVp | offsetof(struct gp, gp_hv)
1771 #define GP_av_ix        SVp | offsetof(struct gp, gp_av)
1772 #define GP_form_ix      SVp | offsetof(struct gp, gp_form)
1773 #define GP_egv_ix       SVp | offsetof(struct gp, gp_egv)
1774 #define GP_line_ix      line_tp | offsetof(struct gp, gp_line)
1775
1776 void
1777 SV(gv)
1778         B::GV   gv
1779     ALIAS:
1780         SV = GP_sv_ix
1781         IO = GP_io_ix
1782         CV = GP_cv_ix
1783         CVGEN = GP_cvgen_ix
1784         GvREFCNT = GP_refcnt_ix
1785         HV = GP_hv_ix
1786         AV = GP_av_ix
1787         FORM = GP_form_ix
1788         EGV = GP_egv_ix
1789         LINE = GP_line_ix
1790     PREINIT:
1791         GP *gp;
1792         char *ptr;
1793         SV *ret;
1794     PPCODE:
1795         gp = GvGP(gv);
1796         if (!gp) {
1797             const GV *const gv = CvGV(cv);
1798             Perl_croak(aTHX_ "NULL gp in B::GV::%s", gv ? GvNAME(gv) : "???");
1799         }
1800         ptr = (ix & 0xFFFF) + (char *)gp;
1801         switch ((U8)(ix >> 16)) {
1802         case (U8)(SVp >> 16):
1803             ret = make_sv_object(aTHX_ *((SV **)ptr));
1804             break;
1805         case (U8)(U32p >> 16):
1806             ret = sv_2mortal(newSVuv(*((U32*)ptr)));
1807             break;
1808         case (U8)(line_tp >> 16):
1809             ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
1810             break;
1811         }
1812         ST(0) = ret;
1813         XSRETURN(1);
1814
1815 void
1816 FILEGV(gv)
1817         B::GV   gv
1818     PPCODE:
1819         PUSHs(make_sv_object(aTHX_ (SV *)GvFILEGV(gv)));
1820
1821 MODULE = B      PACKAGE = B::IO         PREFIX = Io
1822
1823 #if PERL_VERSION <= 8
1824
1825 short
1826 IoSUBPROCESS(io)
1827         B::IO   io
1828
1829 #endif
1830
1831 bool
1832 IsSTD(io,name)
1833         B::IO   io
1834         const char*     name
1835     PREINIT:
1836         PerlIO* handle = 0;
1837     CODE:
1838         if( strEQ( name, "stdin" ) ) {
1839             handle = PerlIO_stdin();
1840         }
1841         else if( strEQ( name, "stdout" ) ) {
1842             handle = PerlIO_stdout();
1843         }
1844         else if( strEQ( name, "stderr" ) ) {
1845             handle = PerlIO_stderr();
1846         }
1847         else {
1848             croak( "Invalid value '%s'", name );
1849         }
1850         RETVAL = handle == IoIFP(io);
1851     OUTPUT:
1852         RETVAL
1853
1854 MODULE = B      PACKAGE = B::AV         PREFIX = Av
1855
1856 SSize_t
1857 AvFILL(av)
1858         B::AV   av
1859
1860 void
1861 AvARRAY(av)
1862         B::AV   av
1863     PPCODE:
1864         if (AvFILL(av) >= 0) {
1865             SV **svp = AvARRAY(av);
1866             I32 i;
1867             for (i = 0; i <= AvFILL(av); i++)
1868                 XPUSHs(make_sv_object(aTHX_ svp[i]));
1869         }
1870
1871 void
1872 AvARRAYelt(av, idx)
1873         B::AV   av
1874         int     idx
1875     PPCODE:
1876         if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
1877             XPUSHs(make_sv_object(aTHX_ (AvARRAY(av)[idx])));
1878         else
1879             XPUSHs(make_sv_object(aTHX_ NULL));
1880
1881 #if PERL_VERSION < 9
1882
1883 #define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1884
1885 IV
1886 AvOFF(av)
1887         B::AV   av
1888
1889 MODULE = B      PACKAGE = B::AV
1890
1891 U8
1892 AvFLAGS(av)
1893         B::AV   av
1894
1895 #endif
1896
1897 MODULE = B      PACKAGE = B::CV         PREFIX = Cv
1898
1899 U32
1900 CvCONST(cv)
1901         B::CV   cv
1902
1903 void
1904 CvSTART(cv)
1905         B::CV   cv
1906     ALIAS:
1907         ROOT = 1
1908     PPCODE:
1909         PUSHs(make_op_object(aTHX_ CvISXSUB(cv) ? NULL
1910                              : ix ? CvROOT(cv) : CvSTART(cv)));
1911
1912 void
1913 CvXSUB(cv)
1914         B::CV   cv
1915     ALIAS:
1916         XSUBANY = 1
1917     CODE:
1918         ST(0) = ix && CvCONST(cv)
1919             ? make_sv_object(aTHX_ (SV *)CvXSUBANY(cv).any_ptr)
1920             : sv_2mortal(newSViv(CvISXSUB(cv)
1921                                  ? (ix ? CvXSUBANY(cv).any_iv
1922                                        : PTR2IV(CvXSUB(cv)))
1923                                  : 0));
1924
1925 void
1926 const_sv(cv)
1927         B::CV   cv
1928     PPCODE:
1929         PUSHs(make_sv_object(aTHX_ (SV *)cv_const_sv(cv)));
1930
1931 MODULE = B      PACKAGE = B::HV         PREFIX = Hv
1932
1933 STRLEN
1934 HvFILL(hv)
1935         B::HV   hv
1936
1937 I32
1938 HvRITER(hv)
1939         B::HV   hv
1940
1941 #if PERL_VERSION < 9
1942
1943 B::PMOP
1944 HvPMROOT(hv)
1945         B::HV   hv
1946     PPCODE:
1947         PUSHs(make_op_object(aTHX_ HvPMROOT(hv)));
1948
1949 #endif
1950
1951 void
1952 HvARRAY(hv)
1953         B::HV   hv
1954     PPCODE:
1955         if (HvKEYS(hv) > 0) {
1956             SV *sv;
1957             char *key;
1958             I32 len;
1959             (void)hv_iterinit(hv);
1960             EXTEND(sp, HvKEYS(hv) * 2);
1961             while ((sv = hv_iternextsv(hv, &key, &len))) {
1962                 mPUSHp(key, len);
1963                 PUSHs(make_sv_object(aTHX_ sv));
1964             }
1965         }
1966
1967 MODULE = B      PACKAGE = B::HE         PREFIX = He
1968
1969 void
1970 HeVAL(he)
1971         B::HE he
1972     ALIAS:
1973         SVKEY_force = 1
1974     PPCODE:
1975         PUSHs(make_sv_object(aTHX_ ix ? HeSVKEY_force(he) : HeVAL(he)));
1976
1977 U32
1978 HeHASH(he)
1979         B::HE he
1980
1981 MODULE = B      PACKAGE = B::RHE
1982
1983 #if PERL_VERSION >= 9
1984
1985 SV*
1986 HASH(h)
1987         B::RHE h
1988     CODE:
1989         RETVAL = newRV( (SV*)cophh_2hv(h, 0) );
1990     OUTPUT:
1991         RETVAL
1992
1993 #endif