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