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 #define PVBM_useful_ix  sv_I32p | offsetof(struct xpvgv, xiv_u.xivu_i32)
1374 #define PVBM_previous_ix    sv_U32p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_previous)
1375 #define PVBM_rare_ix    sv_U8p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_rare)
1376 #else
1377 #define PVBM_useful_ix  sv_I32p | offsetof(struct xpvbm, xbm_useful)
1378 #define PVBM_previous_ix    sv_U16p | offsetof(struct xpvbm, xbm_previous)
1379 #define PVBM_rare_ix    sv_U8p | offsetof(struct xpvbm, xbm_rare)
1380 #endif
1381
1382 #define PVLV_targoff_ix sv_U32p | offsetof(struct xpvlv, xlv_targoff)
1383 #define PVLV_targlen_ix sv_U32p | offsetof(struct xpvlv, xlv_targlen)
1384 #define PVLV_targ_ix    sv_SVp | offsetof(struct xpvlv, xlv_targ)
1385 #define PVLV_type_ix    sv_char_p | offsetof(struct xpvlv, xlv_type)
1386
1387 #if PERL_VERSION >= 10
1388 #define PVGV_stash_ix   sv_SVp | offsetof(struct xpvgv, xnv_u.xgv_stash)
1389 #define PVGV_flags_ix   sv_STRLENp | offsetof(struct xpvgv, xpv_cur)
1390 #define PVIO_lines_ix   sv_IVp | offsetof(struct xpvio, xiv_iv)
1391 #else
1392 #define PVGV_stash_ix   sv_SVp | offsetof(struct xpvgv, xgv_stash)
1393 #define PVGV_flags_ix   sv_U8p | offsetof(struct xpvgv, xgv_flags)
1394 #define PVIO_lines_ix   sv_IVp | offsetof(struct xpvio, xio_lines)
1395 #endif
1396
1397 #define PVIO_page_ix        sv_IVp | offsetof(struct xpvio, xio_page)
1398 #define PVIO_page_len_ix    sv_IVp | offsetof(struct xpvio, xio_page_len)
1399 #define PVIO_lines_left_ix  sv_IVp | offsetof(struct xpvio, xio_lines_left)
1400 #define PVIO_top_name_ix    sv_char_pp | offsetof(struct xpvio, xio_top_name)
1401 #define PVIO_top_gv_ix      sv_SVp | offsetof(struct xpvio, xio_top_gv)
1402 #define PVIO_fmt_name_ix    sv_char_pp | offsetof(struct xpvio, xio_fmt_name)
1403 #define PVIO_fmt_gv_ix      sv_SVp | offsetof(struct xpvio, xio_fmt_gv)
1404 #define PVIO_bottom_name_ix sv_char_pp | offsetof(struct xpvio, xio_bottom_name)
1405 #define PVIO_bottom_gv_ix   sv_SVp | offsetof(struct xpvio, xio_bottom_gv)
1406 #define PVIO_type_ix        sv_char_p | offsetof(struct xpvio, xio_type)
1407 #define PVIO_flags_ix       sv_U8p | offsetof(struct xpvio, xio_flags)
1408
1409 #define PVAV_max_ix     sv_SSize_tp | offsetof(struct xpvav, xav_max)
1410
1411 #define PVFM_lines_ix   sv_IVp | offsetof(struct xpvfm, xfm_lines)
1412
1413 #define PVCV_stash_ix   sv_SVp | offsetof(struct xpvcv, xcv_stash)
1414 #define PVCV_gv_ix      sv_SVp | offsetof(struct xpvcv, xcv_gv)
1415 #define PVCV_file_ix    sv_char_pp | offsetof(struct xpvcv, xcv_file)
1416 #define PVCV_depth_ix   sv_I32p | offsetof(struct xpvcv, xcv_depth)
1417 #define PVCV_padlist_ix sv_SVp | offsetof(struct xpvcv, xcv_padlist)
1418 #define PVCV_outside_ix sv_SVp | offsetof(struct xpvcv, xcv_outside)
1419 #define PVCV_outside_seq_ix sv_U32p | offsetof(struct xpvcv, xcv_outside_seq)
1420 #define PVCV_flags_ix   sv_U16p | offsetof(struct xpvcv, xcv_flags)
1421
1422 #define PVHV_max_ix     sv_STRLENp | offsetof(struct xpvhv, xhv_max)
1423
1424 #if PERL_VERSION > 12
1425 #define PVHV_keys_ix    sv_STRLENp | offsetof(struct xpvhv, xhv_keys)
1426 #else
1427 #define PVHV_keys_ix    sv_IVp | offsetof(struct xpvhv, xhv_keys)
1428 #endif
1429
1430 # The type checking code in B has always been identical for all SV types,
1431 # irrespective of whether the action is actually defined on that SV.
1432 # We should fix this
1433 void
1434 IVX(sv)
1435         B::SV           sv
1436     ALIAS:
1437         B::IV::IVX = IV_ivx_ix
1438         B::IV::UVX = IV_uvx_ix
1439         B::NV::NVX = NV_nvx_ix
1440         B::NV::COP_SEQ_RANGE_LOW = NV_cop_seq_range_low_ix
1441         B::NV::COP_SEQ_RANGE_HIGH = NV_cop_seq_range_high_ix
1442         B::NV::PARENT_PAD_INDEX = NV_parent_pad_index_ix
1443         B::NV::PARENT_FAKELEX_FLAGS = NV_parent_fakelex_flags_ix
1444         B::PV::CUR = PV_cur_ix
1445         B::PV::LEN = PV_len_ix
1446         B::PVMG::SvSTASH = PVMG_stash_ix
1447         B::PVLV::TARGOFF = PVLV_targoff_ix
1448         B::PVLV::TARGLEN = PVLV_targlen_ix
1449         B::PVLV::TARG = PVLV_targ_ix
1450         B::PVLV::TYPE = PVLV_type_ix
1451         B::GV::STASH = PVGV_stash_ix
1452         B::GV::GvFLAGS = PVGV_flags_ix
1453         B::BM::USEFUL = PVBM_useful_ix
1454         B::BM::PREVIOUS = PVBM_previous_ix
1455         B::BM::RARE = PVBM_rare_ix
1456         B::IO::LINES =  PVIO_lines_ix
1457         B::IO::PAGE = PVIO_page_ix
1458         B::IO::PAGE_LEN = PVIO_page_len_ix
1459         B::IO::LINES_LEFT = PVIO_lines_left_ix
1460         B::IO::TOP_NAME = PVIO_top_name_ix
1461         B::IO::TOP_GV = PVIO_top_gv_ix
1462         B::IO::FMT_NAME = PVIO_fmt_name_ix
1463         B::IO::FMT_GV = PVIO_fmt_gv_ix
1464         B::IO::BOTTOM_NAME = PVIO_bottom_name_ix
1465         B::IO::BOTTOM_GV = PVIO_bottom_gv_ix
1466         B::IO::IoTYPE = PVIO_type_ix
1467         B::IO::IoFLAGS = PVIO_flags_ix
1468         B::AV::MAX = PVAV_max_ix
1469         B::FM::LINES = PVFM_lines_ix
1470         B::CV::STASH = PVCV_stash_ix
1471         B::CV::GV = PVCV_gv_ix
1472         B::CV::FILE = PVCV_file_ix
1473         B::CV::DEPTH = PVCV_depth_ix
1474         B::CV::PADLIST = PVCV_padlist_ix
1475         B::CV::OUTSIDE = PVCV_outside_ix
1476         B::CV::OUTSIDE_SEQ = PVCV_outside_seq_ix
1477         B::CV::CvFLAGS = PVCV_flags_ix
1478         B::HV::MAX = PVHV_max_ix
1479         B::HV::KEYS = PVHV_keys_ix
1480     PREINIT:
1481         char *ptr;
1482         SV *ret;
1483     PPCODE:
1484         ptr = (ix & 0xFFFF) + (char *)SvANY(sv);
1485         switch ((U8)(ix >> 16)) {
1486         case (U8)(sv_SVp >> 16):
1487             ret = make_sv_object(aTHX_ *((SV **)ptr));
1488             break;
1489         case (U8)(sv_IVp >> 16):
1490             ret = sv_2mortal(newSViv(*((IV *)ptr)));
1491             break;
1492         case (U8)(sv_UVp >> 16):
1493             ret = sv_2mortal(newSVuv(*((UV *)ptr)));
1494             break;
1495         case (U8)(sv_STRLENp >> 16):
1496             ret = sv_2mortal(newSVuv(*((STRLEN *)ptr)));
1497             break;
1498         case (U8)(sv_U32p >> 16):
1499             ret = sv_2mortal(newSVuv(*((U32 *)ptr)));
1500             break;
1501         case (U8)(sv_U8p >> 16):
1502             ret = sv_2mortal(newSVuv(*((U8 *)ptr)));
1503             break;
1504         case (U8)(sv_char_pp >> 16):
1505             ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
1506             break;
1507         case (U8)(sv_NVp >> 16):
1508             ret = sv_2mortal(newSVnv(*((NV *)ptr)));
1509             break;
1510         case (U8)(sv_char_p >> 16):
1511             ret = newSVpvn_flags((char *)ptr, 1, SVs_TEMP);
1512             break;
1513         case (U8)(sv_SSize_tp >> 16):
1514             ret = sv_2mortal(newSViv(*((SSize_t *)ptr)));
1515             break;
1516         case (U8)(sv_I32p >> 16):
1517             ret = sv_2mortal(newSVuv(*((I32 *)ptr)));
1518             break;
1519         case (U8)(sv_U16p >> 16):
1520             ret = sv_2mortal(newSVuv(*((U16 *)ptr)));
1521             break;
1522         default:
1523             croak("Illegal alias 0x%08x for B::*IVX", (unsigned)ix);
1524         }
1525         ST(0) = ret;
1526         XSRETURN(1);
1527
1528 void
1529 packiv(sv)
1530         B::IV   sv
1531     ALIAS:
1532         needs64bits = 1
1533     CODE:
1534         if (ix) {
1535             ST(0) = boolSV((I32)SvIVX(sv) != SvIVX(sv));
1536         } else if (sizeof(IV) == 8) {
1537             U32 wp[2];
1538             const IV iv = SvIVX(sv);
1539             /*
1540              * The following way of spelling 32 is to stop compilers on
1541              * 32-bit architectures from moaning about the shift count
1542              * being >= the width of the type. Such architectures don't
1543              * reach this code anyway (unless sizeof(IV) > 8 but then
1544              * everything else breaks too so I'm not fussed at the moment).
1545              */
1546 #ifdef UV_IS_QUAD
1547             wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1548 #else
1549             wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1550 #endif
1551             wp[1] = htonl(iv & 0xffffffff);
1552             ST(0) = newSVpvn_flags((char *)wp, 8, SVs_TEMP);
1553         } else {
1554             U32 w = htonl((U32)SvIVX(sv));
1555             ST(0) = newSVpvn_flags((char *)&w, 4, SVs_TEMP);
1556         }
1557
1558 MODULE = B      PACKAGE = B::NV         PREFIX = Sv
1559
1560 NV
1561 SvNV(sv)
1562         B::NV   sv
1563
1564 #if PERL_VERSION < 11
1565
1566 MODULE = B      PACKAGE = B::RV         PREFIX = Sv
1567
1568 void
1569 SvRV(sv)
1570         B::RV   sv
1571     PPCODE:
1572         PUSHs(make_sv_object(aTHX_ SvRV(sv)));
1573
1574 #else
1575
1576 MODULE = B      PACKAGE = B::REGEXP
1577
1578 void
1579 REGEX(sv)
1580         B::REGEXP       sv
1581     ALIAS:
1582         precomp = 1
1583     PPCODE:
1584         if (ix) {
1585             PUSHs(newSVpvn_flags(RX_PRECOMP(sv), RX_PRELEN(sv), SVs_TEMP));
1586         } else {
1587             dXSTARG;
1588             /* FIXME - can we code this method more efficiently?  */
1589             PUSHi(PTR2IV(sv));
1590         }
1591
1592 #endif
1593
1594 MODULE = B      PACKAGE = B::PV
1595
1596 void
1597 RV(sv)
1598         B::PV   sv
1599     PPCODE:
1600         if (!SvROK(sv))
1601             croak( "argument is not SvROK" );
1602         PUSHs(make_sv_object(aTHX_ SvRV(sv)));
1603
1604 void
1605 PV(sv)
1606         B::PV   sv
1607     ALIAS:
1608         PVX = 1
1609         PVBM = 2
1610         B::BM::TABLE = 3
1611     PREINIT:
1612         const char *p;
1613         STRLEN len = 0;
1614         U32 utf8 = 0;
1615     CODE:
1616         if (ix == 3) {
1617             p = SvPV(sv, len);
1618             /* Boyer-Moore table is just after string and its safety-margin \0 */
1619             p += len + PERL_FBM_TABLE_OFFSET;
1620             len = 256;
1621         } else if (ix == 2) {
1622             /* This used to read 257. I think that that was buggy - should have
1623                been 258. (The "\0", the flags byte, and 256 for the table.  Not
1624                that anything anywhere calls this method.  NWC.  */
1625             /* Also, the start pointer has always been SvPVX(sv). Surely it
1626                should be SvPVX(sv) + SvCUR(sv)?  The code has faithfully been
1627                refactored with this behaviour, since PVBM was added in
1628                651aa52ea1faa806.  */
1629             p = SvPVX_const(sv);
1630             len = SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0);
1631         } else if (ix) {
1632             p = SvPVX(sv);
1633             len = strlen(p);
1634         } else if (SvPOK(sv)) {
1635             len = SvCUR(sv);
1636             p = SvPVX_const(sv);
1637             utf8 = SvUTF8(sv);
1638 #if PERL_VERSION < 10
1639             /* Before 5.10 (well 931b58fb28fa5ca7), PAD_COMPNAME_GEN was stored
1640                in SvCUR(), which meant we had to attempt this special casing
1641                to avoid tripping up over variable names in the pads.  */
1642             if((SvLEN(sv) && len >= SvLEN(sv))) {
1643                 /* It claims to be longer than the space allocated for it -
1644                    presuambly it's a variable name in the pad  */
1645                 len = strlen(p);
1646             }
1647 #endif
1648         }
1649         else {
1650             /* XXX for backward compatibility, but should fail */
1651             /* croak( "argument is not SvPOK" ); */
1652             p = NULL;
1653         }
1654         ST(0) = newSVpvn_flags(p, len, SVs_TEMP | utf8);
1655
1656 MODULE = B      PACKAGE = B::PVMG
1657
1658 void
1659 MAGIC(sv)
1660         B::PVMG sv
1661         MAGIC * mg = NO_INIT
1662     PPCODE:
1663         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
1664             XPUSHs(make_mg_object(aTHX_ mg));
1665
1666 MODULE = B      PACKAGE = B::MAGIC
1667
1668 void
1669 MOREMAGIC(mg)
1670         B::MAGIC        mg
1671     ALIAS:
1672         PRIVATE = 1
1673         TYPE = 2
1674         FLAGS = 3
1675         LENGTH = 4
1676         OBJ = 5
1677         PTR = 6
1678         REGEX = 7
1679         precomp = 8
1680     PPCODE:
1681         switch (ix) {
1682         case 0:
1683             XPUSHs(mg->mg_moremagic ? make_mg_object(aTHX_ mg->mg_moremagic)
1684                                     : &PL_sv_undef);
1685             break;
1686         case 1:
1687             mPUSHu(mg->mg_private);
1688             break;
1689         case 2:
1690             PUSHs(newSVpvn_flags(&(mg->mg_type), 1, SVs_TEMP));
1691             break;
1692         case 3:
1693             mPUSHu(mg->mg_flags);
1694             break;
1695         case 4:
1696             mPUSHi(mg->mg_len);
1697             break;
1698         case 5:
1699             PUSHs(make_sv_object(aTHX_ mg->mg_obj));
1700             break;
1701         case 6:
1702             if (mg->mg_ptr) {
1703                 if (mg->mg_len >= 0) {
1704                     PUSHs(newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP));
1705                 } else if (mg->mg_len == HEf_SVKEY) {
1706                     PUSHs(make_sv_object(aTHX_ (SV*)mg->mg_ptr));
1707                 } else
1708                     PUSHs(sv_newmortal());
1709             } else
1710                 PUSHs(sv_newmortal());
1711             break;
1712         case 7:
1713             if(mg->mg_type == PERL_MAGIC_qr) {
1714                 mPUSHi(PTR2IV(mg->mg_obj));
1715             } else {
1716                 croak("REGEX is only meaningful on r-magic");
1717             }
1718             break;
1719         case 8:
1720             if (mg->mg_type == PERL_MAGIC_qr) {
1721                 REGEXP *rx = (REGEXP *)mg->mg_obj;
1722                 PUSHs(newSVpvn_flags(rx ? RX_PRECOMP(rx) : NULL,
1723                                      rx ? RX_PRELEN(rx) : 0, SVs_TEMP));
1724             } else {
1725                 croak( "precomp is only meaningful on r-magic" );
1726             }
1727             break;
1728         }
1729
1730 MODULE = B      PACKAGE = B::GV         PREFIX = Gv
1731
1732 void
1733 GvNAME(gv)
1734         B::GV   gv
1735     ALIAS:
1736         FILE = 1
1737         B::HV::NAME = 2
1738     CODE:
1739 #if PERL_VERSION >= 10
1740         ST(0) = sv_2mortal(newSVhek(!ix ? GvNAME_HEK(gv)
1741                                         : (ix == 1 ? GvFILE_HEK(gv)
1742                                                    : HvNAME_HEK((HV *)gv))));
1743 #else
1744         ST(0) = !ix ? newSVpvn_flags(GvNAME(gv), GvNAMELEN(gv), SVs_TEMP)
1745                     : sv_2mortal(newSVpv(ix == 1 ? GvFILE(gv) : HvNAME((HV *)gv), 0))
1746 #endif
1747
1748 bool
1749 is_empty(gv)
1750         B::GV   gv
1751     ALIAS:
1752         isGV_with_GP = 1
1753     CODE:
1754         if (ix) {
1755 #if PERL_VERSION >= 9
1756             RETVAL = isGV_with_GP(gv) ? TRUE : FALSE;
1757 #else
1758             RETVAL = TRUE; /* In 5.8 and earlier they all are.  */
1759 #endif
1760         } else {
1761             RETVAL = GvGP(gv) == Null(GP*);
1762         }
1763     OUTPUT:
1764         RETVAL
1765
1766 void*
1767 GvGP(gv)
1768         B::GV   gv
1769
1770 #define GP_sv_ix        SVp | offsetof(struct gp, gp_sv)
1771 #define GP_io_ix        SVp | offsetof(struct gp, gp_io)
1772 #define GP_cv_ix        SVp | offsetof(struct gp, gp_cv)
1773 #define GP_cvgen_ix     U32p | offsetof(struct gp, gp_cvgen)
1774 #define GP_refcnt_ix    U32p | offsetof(struct gp, gp_refcnt)
1775 #define GP_hv_ix        SVp | offsetof(struct gp, gp_hv)
1776 #define GP_av_ix        SVp | offsetof(struct gp, gp_av)
1777 #define GP_form_ix      SVp | offsetof(struct gp, gp_form)
1778 #define GP_egv_ix       SVp | offsetof(struct gp, gp_egv)
1779 #define GP_line_ix      line_tp | offsetof(struct gp, gp_line)
1780
1781 void
1782 SV(gv)
1783         B::GV   gv
1784     ALIAS:
1785         SV = GP_sv_ix
1786         IO = GP_io_ix
1787         CV = GP_cv_ix
1788         CVGEN = GP_cvgen_ix
1789         GvREFCNT = GP_refcnt_ix
1790         HV = GP_hv_ix
1791         AV = GP_av_ix
1792         FORM = GP_form_ix
1793         EGV = GP_egv_ix
1794         LINE = GP_line_ix
1795     PREINIT:
1796         GP *gp;
1797         char *ptr;
1798         SV *ret;
1799     PPCODE:
1800         gp = GvGP(gv);
1801         if (!gp) {
1802             const GV *const gv = CvGV(cv);
1803             Perl_croak(aTHX_ "NULL gp in B::GV::%s", gv ? GvNAME(gv) : "???");
1804         }
1805         ptr = (ix & 0xFFFF) + (char *)gp;
1806         switch ((U8)(ix >> 16)) {
1807         case (U8)(SVp >> 16):
1808             ret = make_sv_object(aTHX_ *((SV **)ptr));
1809             break;
1810         case (U8)(U32p >> 16):
1811             ret = sv_2mortal(newSVuv(*((U32*)ptr)));
1812             break;
1813         case (U8)(line_tp >> 16):
1814             ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
1815             break;
1816         default:
1817             croak("Illegal alias 0x%08x for B::*SV", (unsigned)ix);
1818         }
1819         ST(0) = ret;
1820         XSRETURN(1);
1821
1822 void
1823 FILEGV(gv)
1824         B::GV   gv
1825     PPCODE:
1826         PUSHs(make_sv_object(aTHX_ (SV *)GvFILEGV(gv)));
1827
1828 MODULE = B      PACKAGE = B::IO         PREFIX = Io
1829
1830 #if PERL_VERSION <= 8
1831
1832 short
1833 IoSUBPROCESS(io)
1834         B::IO   io
1835
1836 #endif
1837
1838 bool
1839 IsSTD(io,name)
1840         B::IO   io
1841         const char*     name
1842     PREINIT:
1843         PerlIO* handle = 0;
1844     CODE:
1845         if( strEQ( name, "stdin" ) ) {
1846             handle = PerlIO_stdin();
1847         }
1848         else if( strEQ( name, "stdout" ) ) {
1849             handle = PerlIO_stdout();
1850         }
1851         else if( strEQ( name, "stderr" ) ) {
1852             handle = PerlIO_stderr();
1853         }
1854         else {
1855             croak( "Invalid value '%s'", name );
1856         }
1857         RETVAL = handle == IoIFP(io);
1858     OUTPUT:
1859         RETVAL
1860
1861 MODULE = B      PACKAGE = B::AV         PREFIX = Av
1862
1863 SSize_t
1864 AvFILL(av)
1865         B::AV   av
1866
1867 void
1868 AvARRAY(av)
1869         B::AV   av
1870     PPCODE:
1871         if (AvFILL(av) >= 0) {
1872             SV **svp = AvARRAY(av);
1873             I32 i;
1874             for (i = 0; i <= AvFILL(av); i++)
1875                 XPUSHs(make_sv_object(aTHX_ svp[i]));
1876         }
1877
1878 void
1879 AvARRAYelt(av, idx)
1880         B::AV   av
1881         int     idx
1882     PPCODE:
1883         if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
1884             XPUSHs(make_sv_object(aTHX_ (AvARRAY(av)[idx])));
1885         else
1886             XPUSHs(make_sv_object(aTHX_ NULL));
1887
1888 #if PERL_VERSION < 9
1889
1890 #define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1891
1892 IV
1893 AvOFF(av)
1894         B::AV   av
1895
1896 MODULE = B      PACKAGE = B::AV
1897
1898 U8
1899 AvFLAGS(av)
1900         B::AV   av
1901
1902 #endif
1903
1904 MODULE = B      PACKAGE = B::CV         PREFIX = Cv
1905
1906 U32
1907 CvCONST(cv)
1908         B::CV   cv
1909
1910 void
1911 CvSTART(cv)
1912         B::CV   cv
1913     ALIAS:
1914         ROOT = 1
1915     PPCODE:
1916         PUSHs(make_op_object(aTHX_ CvISXSUB(cv) ? NULL
1917                              : ix ? CvROOT(cv) : CvSTART(cv)));
1918
1919 void
1920 CvXSUB(cv)
1921         B::CV   cv
1922     ALIAS:
1923         XSUBANY = 1
1924     CODE:
1925         ST(0) = ix && CvCONST(cv)
1926             ? make_sv_object(aTHX_ (SV *)CvXSUBANY(cv).any_ptr)
1927             : sv_2mortal(newSViv(CvISXSUB(cv)
1928                                  ? (ix ? CvXSUBANY(cv).any_iv
1929                                        : PTR2IV(CvXSUB(cv)))
1930                                  : 0));
1931
1932 void
1933 const_sv(cv)
1934         B::CV   cv
1935     PPCODE:
1936         PUSHs(make_sv_object(aTHX_ (SV *)cv_const_sv(cv)));
1937
1938 MODULE = B      PACKAGE = B::HV         PREFIX = Hv
1939
1940 STRLEN
1941 HvFILL(hv)
1942         B::HV   hv
1943
1944 I32
1945 HvRITER(hv)
1946         B::HV   hv
1947
1948 #if PERL_VERSION < 9
1949
1950 B::PMOP
1951 HvPMROOT(hv)
1952         B::HV   hv
1953     PPCODE:
1954         PUSHs(make_op_object(aTHX_ HvPMROOT(hv)));
1955
1956 #endif
1957
1958 void
1959 HvARRAY(hv)
1960         B::HV   hv
1961     PPCODE:
1962         if (HvKEYS(hv) > 0) {
1963             SV *sv;
1964             char *key;
1965             I32 len;
1966             (void)hv_iterinit(hv);
1967             EXTEND(sp, HvKEYS(hv) * 2);
1968             while ((sv = hv_iternextsv(hv, &key, &len))) {
1969                 mPUSHp(key, len);
1970                 PUSHs(make_sv_object(aTHX_ sv));
1971             }
1972         }
1973
1974 MODULE = B      PACKAGE = B::HE         PREFIX = He
1975
1976 void
1977 HeVAL(he)
1978         B::HE he
1979     ALIAS:
1980         SVKEY_force = 1
1981     PPCODE:
1982         PUSHs(make_sv_object(aTHX_ ix ? HeSVKEY_force(he) : HeVAL(he)));
1983
1984 U32
1985 HeHASH(he)
1986         B::HE he
1987
1988 MODULE = B      PACKAGE = B::RHE
1989
1990 #if PERL_VERSION >= 9
1991
1992 SV*
1993 HASH(h)
1994         B::RHE h
1995     CODE:
1996         RETVAL = newRV( (SV*)cophh_2hv(h, 0) );
1997     OUTPUT:
1998         RETVAL
1999
2000 #endif