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
 606
 607 #define SVp            0x00000
 608 #define U32p           0x10000
 609 #define line_tp        0x20000
 610 #define OPp            0x30000
 611 #define PADOFFSETp     0x40000
 612 #define U8p            0x50000
 613 #define IVp            0x60000
 614 #define char_pp        0x70000
 615
 616 /* table that drives most of the B::*OP methods */
 617
 618 struct OP_methods {
 619     const char *name;
 620     STRLEN namelen;
 621     I32    type;
 622     size_t offset; /* if -1, access is handled on a case-by-case basis */
 623 } op_methods[] = {
 624     STR_WITH_LEN("next"),    OPp,    offsetof(struct op, op_next),       /* 0*/
 625     STR_WITH_LEN("sibling"), OPp,    offsetof(struct op, op_sibling),    /* 1*/
 626     STR_WITH_LEN("targ"),    PADOFFSETp, offsetof(struct op, op_targ),   /* 2*/
 627     STR_WITH_LEN("flags"),   U8p,    offsetof(struct op, op_flags),      /* 3*/
 628     STR_WITH_LEN("private"), U8p,    offsetof(struct op, op_private),    /* 4*/
 629     STR_WITH_LEN("first"),   OPp,    offsetof(struct unop, op_first),     /* 5*/
 630     STR_WITH_LEN("last"),    OPp,    offsetof(struct binop, op_last),    /* 6*/
 631     STR_WITH_LEN("other"),   OPp,    offsetof(struct logop, op_other),   /* 7*/
 632     STR_WITH_LEN("pmreplstart"), OPp,
 633              offsetof(struct pmop,   op_pmstashstartu.op_pmreplstart),   /* 8*/
 634     STR_WITH_LEN("redoop"),  OPp,    offsetof(struct loop, op_redoop),   /* 9*/
 635     STR_WITH_LEN("nextop"),  OPp,    offsetof(struct loop, op_nextop),   /*10*/
 636     STR_WITH_LEN("lastop"),  OPp,    offsetof(struct loop, op_lastop),   /*11*/
 637     STR_WITH_LEN("pmflags"), U32p,   offsetof(struct pmop, op_pmflags),  /*12*/
 638 #if PERL_VERSION >= 17
 639     STR_WITH_LEN("code_list"),OPp,   offsetof(struct pmop, op_code_list),/*13*/
 640 #else
 641     STR_WITH_LEN("code_list"),0,     -1,
 642 #endif
 643     STR_WITH_LEN("sv"),      SVp,     offsetof(struct svop, op_sv),      /*14*/
 644     STR_WITH_LEN("gv"),      SVp,     offsetof(struct svop, op_sv),      /*15*/
 645     STR_WITH_LEN("padix"),   PADOFFSETp,offsetof(struct padop, op_padix),/*16*/
 646     STR_WITH_LEN("cop_seq"), U32p,    offsetof(struct cop, cop_seq),     /*17*/
 647     STR_WITH_LEN("line"),    line_tp, offsetof(struct cop, cop_line),    /*18*/
 648     STR_WITH_LEN("hints"),   U32p,    offsetof(struct cop, cop_hints),   /*19*/
 649 #ifdef USE_ITHREADS
 650     STR_WITH_LEN("pmoffset"),IVp,     offsetof(struct pmop, op_pmoffset),/*20*/
 651     STR_WITH_LEN("filegv"),  0,       -1,                                /*21*/
 652     STR_WITH_LEN("file"),    char_pp, offsetof(struct cop, cop_file),    /*22*/
 653     STR_WITH_LEN("stash"),   0,       -1,                                /*23*/
 654 #  if PERL_VERSION < 17
 655     STR_WITH_LEN("stashpv"), char_pp, offsetof(struct cop, cop_stashpv), /*24*/
 656     STR_WITH_LEN("stashoff"),0,       -1,                                /*25*/
 657 #  else
 658     STR_WITH_LEN("stashpv"), 0,       -1,                                /*24*/
 659     STR_WITH_LEN("stashoff"),PADOFFSETp,offsetof(struct cop, cop_stashoff),/*25*/
 660 #  endif
 661 #else
 662     STR_WITH_LEN("pmoffset"),0,       -1,                                /*20*/
 663     STR_WITH_LEN("filegv"),  SVp,     offsetof(struct cop, cop_filegv),  /*21*/
 664     STR_WITH_LEN("file"),    0,       -1,                                /*22*/
 665     STR_WITH_LEN("stash"),   SVp,     offsetof(struct cop, cop_stash),   /*23*/
 666     STR_WITH_LEN("stashpv"), 0,       -1,                                /*24*/
 667     STR_WITH_LEN("stashoff"),0,       -1,                                /*25*/
 668 #endif
 669     STR_WITH_LEN("size"),    0,       -1,                                /*26*/
 670     STR_WITH_LEN("name"),    0,       -1,                                /*27*/
 671     STR_WITH_LEN("desc"),    0,       -1,                                /*28*/
 672     STR_WITH_LEN("ppaddr"),  0,       -1,                                /*29*/
 673     STR_WITH_LEN("type"),    0,       -1,                                /*30*/
 674     STR_WITH_LEN("opt"),     0,       -1,                                /*31*/
 675     STR_WITH_LEN("spare"),   0,       -1,                                /*32*/
 676     STR_WITH_LEN("children"),0,       -1,                                /*33*/
 677     STR_WITH_LEN("pmreplroot"), 0,    -1,                                /*34*/
 678     STR_WITH_LEN("pmstashpv"), 0,     -1,                                /*35*/
 679     STR_WITH_LEN("pmstash"), 0,       -1,                                /*36*/
 680     STR_WITH_LEN("precomp"), 0,       -1,                                /*37*/
 681     STR_WITH_LEN("reflags"), 0,       -1,                                /*38*/
 682     STR_WITH_LEN("sv"),      0,       -1,                                /*39*/
 683     STR_WITH_LEN("gv"),      0,       -1,                                /*40*/
 684     STR_WITH_LEN("pv"),      0,       -1,                                /*41*/
 685     STR_WITH_LEN("label"),   0,       -1,                                /*42*/
 686     STR_WITH_LEN("arybase"), 0,       -1,                                /*43*/
 687     STR_WITH_LEN("warnings"),0,       -1,                                /*44*/
 688     STR_WITH_LEN("io"),      0,       -1,                                /*45*/
 689     STR_WITH_LEN("hints_hash"),0,     -1,                                /*46*/
 690 };
 691
 692 #include "const-c.inc"
 693
 694 MODULE = B      PACKAGE = B
 695
 696 INCLUDE: const-xs.inc
 697
 698 PROTOTYPES: DISABLE
 699
 700 BOOT:
 701 {
 702     CV *cv;
 703     const char *file = __FILE__;
 704     MY_CXT_INIT;
 705     specialsv_list[0] = Nullsv;
 706     specialsv_list[1] = &PL_sv_undef;
 707     specialsv_list[2] = &PL_sv_yes;
 708     specialsv_list[3] = &PL_sv_no;
 709     specialsv_list[4] = (SV *) pWARN_ALL;
 710     specialsv_list[5] = (SV *) pWARN_NONE;
 711     specialsv_list[6] = (SV *) pWARN_STD;
 712
 713     cv = newXS("B::init_av", intrpvar_sv_common, file);
 714     ASSIGN_COMMON_ALIAS(I, initav);
 715     cv = newXS("B::check_av", intrpvar_sv_common, file);
 716     ASSIGN_COMMON_ALIAS(I, checkav_save);
 717     cv = newXS("B::unitcheck_av", intrpvar_sv_common, file);
 718     ASSIGN_COMMON_ALIAS(I, unitcheckav_save);
 719     cv = newXS("B::begin_av", intrpvar_sv_common, file);
 720     ASSIGN_COMMON_ALIAS(I, beginav_save);
 721     cv = newXS("B::end_av", intrpvar_sv_common, file);
 722     ASSIGN_COMMON_ALIAS(I, endav);
 723     cv = newXS("B::main_cv", intrpvar_sv_common, file);
 724     ASSIGN_COMMON_ALIAS(I, main_cv);
 725     cv = newXS("B::inc_gv", intrpvar_sv_common, file);
 726     ASSIGN_COMMON_ALIAS(I, incgv);
 727     cv = newXS("B::defstash", intrpvar_sv_common, file);
 728     ASSIGN_COMMON_ALIAS(I, defstash);
 729     cv = newXS("B::curstash", intrpvar_sv_common, file);
 730     ASSIGN_COMMON_ALIAS(I, curstash);
 731 #ifdef PL_formfeed
 732     cv = newXS("B::formfeed", intrpvar_sv_common, file);
 733     ASSIGN_COMMON_ALIAS(I, formfeed);
 734 #endif
 735 #ifdef USE_ITHREADS
 736     cv = newXS("B::regex_padav", intrpvar_sv_common, file);
 737     ASSIGN_COMMON_ALIAS(I, regex_padav);
 738 #endif
 739     cv = newXS("B::warnhook", intrpvar_sv_common, file);
 740     ASSIGN_COMMON_ALIAS(I, warnhook);
 741     cv = newXS("B::diehook", intrpvar_sv_common, file);
 742     ASSIGN_COMMON_ALIAS(I, diehook);
 743 }
 744
 745 #ifndef PL_formfeed
 746
 747 void
 748 formfeed()
 749     PPCODE:
 750         PUSHs(make_sv_object(aTHX_ GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV))));
 751
 752 #endif
 753
 754 long
 755 amagic_generation()
 756     CODE:
 757         RETVAL = PL_amagic_generation;
 758     OUTPUT:
 759         RETVAL
 760
 761 void
 762 comppadlist()
 763     PREINIT:
 764         PADLIST *padlist = CvPADLIST(PL_main_cv ? PL_main_cv : PL_compcv);
 765     PPCODE:
 766 #ifdef PadlistARRAY
 767         {
 768             SV * const rv = sv_newmortal();
 769             sv_setiv(newSVrv(rv, padlist ? "B::PADLIST" : "B::NULL"),
 770                      PTR2IV(padlist));
 771             PUSHs(rv);
 772         }
 773 #else
 774         PUSHs(make_sv_object(aTHX_ (SV *)padlist));
 775 #endif
 776
 777 void
 778 sv_undef()
 779     ALIAS:
 780         sv_no = 1
 781         sv_yes = 2
 782     PPCODE:
 783         PUSHs(make_sv_object(aTHX_ ix > 1 ? &PL_sv_yes
 784                                           : ix < 1 ? &PL_sv_undef
 785                                                    : &PL_sv_no));
 786
 787 void
 788 main_root()
 789     ALIAS:
 790         main_start = 1
 791     PPCODE:
 792         PUSHs(make_op_object(aTHX_ ix ? PL_main_start : PL_main_root));
 793
 794 UV
 795 sub_generation()
 796     ALIAS:
 797         dowarn = 1
 798     CODE:
 799         RETVAL = ix ? PL_dowarn : PL_sub_generation;
 800     OUTPUT:
 801         RETVAL
 802
 803 void
 804 walkoptree(op, method)
 805         B::OP op
 806         const char *    method
 807     CODE:
 808         (void) walkoptree(aTHX_ op, method, &PL_sv_undef);
 809
 810 int
 811 walkoptree_debug(...)
 812     CODE:
 813         dMY_CXT;
 814         RETVAL = walkoptree_debug;
 815         if (items > 0 && SvTRUE(ST(1)))
 816             walkoptree_debug = 1;
 817     OUTPUT:
 818         RETVAL
 819
 820 #define address(sv) PTR2IV(sv)
 821
 822 IV
 823 address(sv)
 824         SV *    sv
 825
 826 void
 827 svref_2object(sv)
 828         SV *    sv
 829     PPCODE:
 830         if (!SvROK(sv))
 831             croak("argument is not a reference");
 832         PUSHs(make_sv_object(aTHX_ SvRV(sv)));
 833
 834 void
 835 opnumber(name)
 836 const char *    name
 837 CODE:
 838 {
 839  int i;
 840  IV  result = -1;
 841  ST(0) = sv_newmortal();
 842  if (strncmp(name,"pp_",3) == 0)
 843    name += 3;
 844  for (i = 0; i < PL_maxo; i++)
 845   {
 846    if (strcmp(name, PL_op_name[i]) == 0)
 847     {
 848      result = i;
 849      break;
 850     }
 851   }
 852  sv_setiv(ST(0),result);
 853 }
 854
 855 void
 856 ppname(opnum)
 857         int     opnum
 858     CODE:
 859         ST(0) = sv_newmortal();
 860         if (opnum >= 0 && opnum < PL_maxo)
 861             Perl_sv_setpvf(aTHX_ ST(0), "pp_%s", PL_op_name[opnum]);
 862
 863 void
 864 hash(sv)
 865         SV *    sv
 866     CODE:
 867         STRLEN len;
 868         U32 hash = 0;
 869         const char *s = SvPVbyte(sv, len);
 870         PERL_HASH(hash, s, len);
 871         ST(0) = sv_2mortal(Perl_newSVpvf(aTHX_ "0x%"UVxf, (UV)hash));
 872
 873 #define cast_I32(foo) (I32)foo
 874 IV
 875 cast_I32(i)
 876         IV      i
 877
 878 void
 879 minus_c()
 880     ALIAS:
 881         save_BEGINs = 1
 882     CODE:
 883         if (ix)
 884             PL_savebegin = TRUE;
 885         else
 886             PL_minus_c = TRUE;
 887
 888 void
 889 cstring(sv)
 890         SV *    sv
 891     ALIAS:
 892         perlstring = 1
 893         cchar = 2
 894     PPCODE:
 895         PUSHs(ix == 2 ? cchar(aTHX_ sv) : cstring(aTHX_ sv, (bool)ix));
 896
 897 void
 898 threadsv_names()
 899     PPCODE:
 900
 901
 902
 903
 904 MODULE = B      PACKAGE = B::OP
 905
 906
 907 # The type checking code in B has always been identical for all OP types,
 908 # irrespective of whether the action is actually defined on that OP.
 909 # We should fix this
 910 void
 911 next(o)
 912         B::OP           o
 913     ALIAS:
 914         B::OP::next          =  0
 915         B::OP::sibling       =  1
 916         B::OP::targ          =  2
 917         B::OP::flags         =  3
 918         B::OP::private       =  4
 919         B::UNOP::first       =  5
 920         B::BINOP::last       =  6
 921         B::LOGOP::other      =  7
 922         B::PMOP::pmreplstart =  8
 923         B::LOOP::redoop      =  9
 924         B::LOOP::nextop      = 10
 925         B::LOOP::lastop      = 11
 926         B::PMOP::pmflags     = 12
 927         B::PMOP::code_list   = 13
 928         B::SVOP::sv          = 14
 929         B::SVOP::gv          = 15
 930         B::PADOP::padix      = 16
 931         B::COP::cop_seq      = 17
 932         B::COP::line         = 18
 933         B::COP::hints        = 19
 934         B::PMOP::pmoffset    = 20
 935         B::COP::filegv       = 21
 936         B::COP::file         = 22
 937         B::COP::stash        = 23
 938         B::COP::stashpv      = 24
 939         B::COP::stashoff     = 25
 940         B::OP::size          = 26
 941         B::OP::name          = 27
 942         B::OP::desc          = 28
 943         B::OP::ppaddr        = 29
 944         B::OP::type          = 30
 945         B::OP::opt           = 31
 946         B::OP::spare         = 32
 947         B::LISTOP::children  = 33
 948         B::PMOP::pmreplroot  = 34
 949         B::PMOP::pmstashpv   = 35
 950         B::PMOP::pmstash     = 36
 951         B::PMOP::precomp     = 37
 952         B::PMOP::reflags     = 38
 953         B::PADOP::sv         = 39
 954         B::PADOP::gv         = 40
 955         B::PVOP::pv          = 41
 956         B::COP::label        = 42
 957         B::COP::arybase      = 43
 958         B::COP::warnings     = 44
 959         B::COP::io           = 45
 960         B::COP::hints_hash   = 46
 961     PREINIT:
 962         char *ptr;
 963         SV *ret;
 964         I32 type;
 965         I32 offset;
 966         STRLEN len;
 967     PPCODE:
 968         if (ix < 0 || ix > 46)
 969             croak("Illegal alias %d for B::*OP::next", (int)ix);
 970         offset = op_methods[ix].offset;
 971
 972         /* handle non-direct field access */
 973
 974         if (offset < 0) {
 975             switch (ix) {
 976 #ifdef USE_ITHREADS
 977             case 21: /* filegv */
 978                 ret = make_sv_object(aTHX_ (SV *)CopFILEGV((COP*)o));
 979                 break;
 980 #endif
 981 #ifndef USE_ITHREADS
 982             case 22: /* file */
 983                 ret = sv_2mortal(newSVpv(CopFILE((COP*)o), 0));
 984                 break;
 985 #endif
 986 #ifdef USE_ITHREADS
 987             case 23: /* stash */
 988                 ret = make_sv_object(aTHX_ (SV *)CopSTASH((COP*)o));
 989                 break;
 990 #endif
 991 #if PERL_VERSION >= 17 || !defined USE_ITHREADS
 992             case 24: /* stashpv */
 993 #  if PERL_VERSION >= 17
 994                 ret = sv_2mortal(CopSTASH((COP*)o)
 995                                 && SvTYPE(CopSTASH((COP*)o)) == SVt_PVHV
 996                     ? newSVhek(HvNAME_HEK(CopSTASH((COP*)o)))
 997                     : &PL_sv_undef);
 998 #  else
 999                 ret = sv_2mortal(newSVpv(CopSTASHPV((COP*)o), 0));
1000 #  endif
1001                 break;
1002 #endif
1003             case 26: /* size */
1004                 ret = sv_2mortal(newSVuv((UV)(opsizes[cc_opclass(aTHX_ o)])));
1005                 break;
1006             case 27: /* name */
1007             case 28: /* desc */
1008                 ret = sv_2mortal(newSVpv(
1009                             (char *)(ix == 28 ? OP_DESC(o) : OP_NAME(o)), 0));
1010                 break;
1011             case 29: /* ppaddr */
1012                 {
1013                     int i;
1014                     ret = sv_2mortal(Perl_newSVpvf(aTHX_ "PL_ppaddr[OP_%s]",
1015                                                   PL_op_name[o->op_type]));
1016                     for (i=13; (STRLEN)i < SvCUR(ret); ++i)
1017                         SvPVX(ret)[i] = toUPPER(SvPVX(ret)[i]);
1018                 }
1019                 break;
1020             case 30: /* type  */
1021             case 31: /* opt   */
1022             case 32: /* spare */
1023             /* These 3 are all bitfields, so we can't take their addresses */
1024                 ret = sv_2mortal(newSVuv((UV)(
1025                                       ix == 30 ? o->op_type
1026                                     : ix == 31 ? o->op_opt
1027                                     :            o->op_spare)));
1028                 break;
1029             case 33: /* children */
1030                 {
1031                     OP *kid;
1032                     UV i = 0;
1033                     for (kid = ((LISTOP*)o)->op_first; kid; kid = kid->op_sibling)
1034                         i++;
1035                     ret = sv_2mortal(newSVuv(i));
1036                 }
1037                 break;
1038             case 34: /* pmreplroot */
1039                 if (cPMOPo->op_type == OP_PUSHRE) {
1040 #ifdef USE_ITHREADS
1041                     ret = sv_newmortal();
1042                     sv_setiv(ret, cPMOPo->op_pmreplrootu.op_pmtargetoff);
1043 #else
1044                     GV *const target = cPMOPo->op_pmreplrootu.op_pmtargetgv;
1045                     ret = sv_newmortal();
1046                     sv_setiv(newSVrv(ret, target ?
1047                                      svclassnames[SvTYPE((SV*)target)] : "B::SV"),
1048                              PTR2IV(target));
1049 #endif
1050                 }
1051                 else {
1052                     OP *const root = cPMOPo->op_pmreplrootu.op_pmreplroot;
1053                     ret = make_op_object(aTHX_ root);
1054                 }
1055                 break;
1056 #ifdef USE_ITHREADS
1057             case 35: /* pmstashpv */
1058                 ret = sv_2mortal(newSVpv(PmopSTASHPV(cPMOPo),0));
1059                 break;
1060 #else
1061             case 36: /* pmstash */
1062                 ret = make_sv_object(aTHX_ (SV *) PmopSTASH(cPMOPo));
1063                 break;
1064 #endif
1065             case 37: /* precomp */
1066             case 38: /* reflags */
1067                 {
1068                     REGEXP *rx = PM_GETRE(cPMOPo);
1069                     ret = sv_newmortal();
1070                     if (rx) {
1071                         if (ix==38) {
1072                             sv_setuv(ret, RX_EXTFLAGS(rx));
1073                         }
1074                         else {
1075                             sv_setpvn(ret, RX_PRECOMP(rx), RX_PRELEN(rx));
1076                         }
1077                     }
1078                 }
1079                 break;
1080             case 39: /* sv */
1081             case 40: /* gv */
1082                 /* It happens that the output typemaps for B::SV and B::GV
1083                  * are identical. The "smarts" are in make_sv_object(),
1084                  * which determines which class to use based on SvTYPE(),
1085                  * rather than anything baked in at compile time.  */
1086                 if (cPADOPo->op_padix) {
1087                     ret = PAD_SVl(cPADOPo->op_padix);
1088                     if (ix == 40 && SvTYPE(ret) != SVt_PVGV)
1089                         ret = NULL;
1090                 } else {
1091                     ret = NULL;
1092                 }
1093                 ret = make_sv_object(aTHX_ ret);
1094                 break;
1095             case 41: /* pv */
1096                 /* OP_TRANS uses op_pv to point to a table of 256 or >=258
1097                  * shorts whereas other PVOPs point to a null terminated
1098                  * string.  */
1099                 if (    (cPVOPo->op_type == OP_TRANS
1100                         || cPVOPo->op_type == OP_TRANSR) &&
1101                         (cPVOPo->op_private & OPpTRANS_COMPLEMENT) &&
1102                         !(cPVOPo->op_private & OPpTRANS_DELETE))
1103                 {
1104                     const short* const tbl = (short*)cPVOPo->op_pv;
1105                     const short entries = 257 + tbl[256];
1106                     ret = newSVpvn_flags(cPVOPo->op_pv, entries * sizeof(short), SVs_TEMP);
1107                 }
1108                 else if (cPVOPo->op_type == OP_TRANS || cPVOPo->op_type == OP_TRANSR) {
1109                     ret = newSVpvn_flags(cPVOPo->op_pv, 256 * sizeof(short), SVs_TEMP);
1110                 }
1111                 else
1112                     ret = newSVpvn_flags(cPVOPo->op_pv, strlen(cPVOPo->op_pv), SVs_TEMP);
1113                 break;
1114             case 42: /* label */
1115                 ret = sv_2mortal(newSVpv(CopLABEL(cCOPo),0));
1116                 break;
1117             case 43: /* arybase */
1118                 ret = sv_2mortal(newSVuv(0));
1119                 break;
1120             case 44: /* warnings */
1121                 ret = make_warnings_object(aTHX_ cCOPo);
1122                 break;
1123             case 45: /* io */
1124                 ret = make_cop_io_object(aTHX_ cCOPo);
1125                 break;
1126             case 46: /* hints_hash */
1127                 ret = sv_newmortal();
1128                 sv_setiv(newSVrv(ret, "B::RHE"),
1129                         PTR2IV(CopHINTHASH_get(cCOPo)));
1130                 break;
1131             default:
1132                 croak("method %s not implemented", op_methods[ix].name);
1133             }
1134             ST(0) = ret;
1135             XSRETURN(1);
1136         }
1137
1138         /* do a direct structure offset lookup */
1139
1140         ptr  = (char *)o + offset;
1141         type = op_methods[ix].type;
1142         switch ((U8)(type >> 16)) {
1143         case  (U8)(OPp >> 16):
1144             ret = make_op_object(aTHX_ *((OP **)ptr));
1145             break;
1146         case  (U8)(PADOFFSETp >> 16):
1147             ret = sv_2mortal(newSVuv(*((PADOFFSET*)ptr)));
1148             break;
1149         case (U8)(U8p >> 16):
1150             ret = sv_2mortal(newSVuv(*((U8*)ptr)));
1151             break;
1152         case (U8)(U32p >> 16):
1153             ret = sv_2mortal(newSVuv(*((U32*)ptr)));
1154             break;
1155         case (U8)(SVp >> 16):
1156             ret = make_sv_object(aTHX_ *((SV **)ptr));
1157             break;
1158         case (U8)(line_tp >> 16):
1159             ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
1160             break;
1161         case (U8)(IVp >> 16):
1162             ret = sv_2mortal(newSViv(*((IV*)ptr)));
1163             break;
1164         case (U8)(char_pp >> 16):
1165             ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
1166             break;
1167         default:
1168             croak("Illegal type 0x%08x for B::*OP::%s",
1169                     (unsigned)type, op_methods[ix].name);
1170
1171         }
1172         ST(0) = ret;
1173         XSRETURN(1);
1174
1175
1176 void
1177 oplist(o)
1178         B::OP           o
1179     PPCODE:
1180         SP = oplist(aTHX_ o, SP);
1181
1182
1183 MODULE = B      PACKAGE = B::SV
1184
1185 #define MAGICAL_FLAG_BITS (SVs_GMG|SVs_SMG|SVs_RMG)
1186
1187 U32
1188 REFCNT(sv)
1189         B::SV   sv
1190     ALIAS:
1191         FLAGS = 0xFFFFFFFF
1192         SvTYPE = SVTYPEMASK
1193         POK = SVf_POK
1194         ROK = SVf_ROK
1195         MAGICAL = MAGICAL_FLAG_BITS
1196     CODE:
1197         RETVAL = ix ? (SvFLAGS(sv) & (U32)ix) : SvREFCNT(sv);
1198     OUTPUT:
1199         RETVAL
1200
1201 void
1202 object_2svref(sv)
1203         B::SV   sv
1204     PPCODE:
1205         ST(0) = sv_2mortal(newRV(sv));
1206         XSRETURN(1);
1207
1208 MODULE = B      PACKAGE = B::IV         PREFIX = Sv
1209
1210 IV
1211 SvIV(sv)
1212         B::IV   sv
1213
1214 MODULE = B      PACKAGE = B::IV
1215
1216 #define sv_SVp          0x00000
1217 #define sv_IVp          0x10000
1218 #define sv_UVp          0x20000
1219 #define sv_STRLENp      0x30000
1220 #define sv_U32p         0x40000
1221 #define sv_U8p          0x50000
1222 #define sv_char_pp      0x60000
1223 #define sv_NVp          0x70000
1224 #define sv_char_p       0x80000
1225 #define sv_SSize_tp     0x90000
1226 #define sv_I32p         0xA0000
1227 #define sv_U16p         0xB0000
1228
1229 #define IV_ivx_ix       sv_IVp | offsetof(struct xpviv, xiv_iv)
1230 #define IV_uvx_ix       sv_UVp | offsetof(struct xpvuv, xuv_uv)
1231 #define NV_nvx_ix       sv_NVp | offsetof(struct xpvnv, xnv_u.xnv_nv)
1232
1233 #define NV_cop_seq_range_low_ix \
1234                         sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
1235 #define NV_cop_seq_range_high_ix \
1236                         sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
1237 #define NV_parent_pad_index_ix \
1238                         sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
1239 #define NV_parent_fakelex_flags_ix \
1240                         sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
1241
1242 #define PV_cur_ix       sv_STRLENp | offsetof(struct xpv, xpv_cur)
1243 #define PV_len_ix       sv_STRLENp | offsetof(struct xpv, xpv_len)
1244
1245 #define PVMG_stash_ix   sv_SVp | offsetof(struct xpvmg, xmg_stash)
1246
1247 #if PERL_VERSION > 14
1248 #    define PVBM_useful_ix      sv_I32p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_useful)
1249 #    define PVBM_previous_ix    sv_UVp | offsetof(struct xpvuv, xuv_uv)
1250 #else
1251 #define PVBM_useful_ix  sv_I32p | offsetof(struct xpvgv, xiv_u.xivu_i32)
1252 #define PVBM_previous_ix    sv_U32p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_previous)
1253 #endif
1254
1255 #define PVBM_rare_ix    sv_U8p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_rare)
1256
1257 #define PVLV_targoff_ix sv_U32p | offsetof(struct xpvlv, xlv_targoff)
1258 #define PVLV_targlen_ix sv_U32p | offsetof(struct xpvlv, xlv_targlen)
1259 #define PVLV_targ_ix    sv_SVp | offsetof(struct xpvlv, xlv_targ)
1260 #define PVLV_type_ix    sv_char_p | offsetof(struct xpvlv, xlv_type)
1261
1262 #define PVGV_stash_ix   sv_SVp | offsetof(struct xpvgv, xnv_u.xgv_stash)
1263 #define PVGV_flags_ix   sv_STRLENp | offsetof(struct xpvgv, xpv_cur)
1264 #define PVIO_lines_ix   sv_IVp | offsetof(struct xpvio, xiv_iv)
1265
1266 #define PVIO_page_ix        sv_IVp | offsetof(struct xpvio, xio_page)
1267 #define PVIO_page_len_ix    sv_IVp | offsetof(struct xpvio, xio_page_len)
1268 #define PVIO_lines_left_ix  sv_IVp | offsetof(struct xpvio, xio_lines_left)
1269 #define PVIO_top_name_ix    sv_char_pp | offsetof(struct xpvio, xio_top_name)
1270 #define PVIO_top_gv_ix      sv_SVp | offsetof(struct xpvio, xio_top_gv)
1271 #define PVIO_fmt_name_ix    sv_char_pp | offsetof(struct xpvio, xio_fmt_name)
1272 #define PVIO_fmt_gv_ix      sv_SVp | offsetof(struct xpvio, xio_fmt_gv)
1273 #define PVIO_bottom_name_ix sv_char_pp | offsetof(struct xpvio, xio_bottom_name)
1274 #define PVIO_bottom_gv_ix   sv_SVp | offsetof(struct xpvio, xio_bottom_gv)
1275 #define PVIO_type_ix        sv_char_p | offsetof(struct xpvio, xio_type)
1276 #define PVIO_flags_ix       sv_U8p | offsetof(struct xpvio, xio_flags)
1277
1278 #define PVAV_max_ix     sv_SSize_tp | offsetof(struct xpvav, xav_max)
1279
1280 #define PVCV_stash_ix   sv_SVp | offsetof(struct xpvcv, xcv_stash)
1281 #if PERL_VERSION > 17 || (PERL_VERSION == 17 && PERL_SUBVERSION >= 3)
1282 # define PVCV_gv_ix     sv_SVp | offsetof(struct xpvcv, xcv_gv_u.xcv_gv)
1283 #else
1284 # define PVCV_gv_ix     sv_SVp | offsetof(struct xpvcv, xcv_gv)
1285 #endif
1286 #define PVCV_file_ix    sv_char_pp | offsetof(struct xpvcv, xcv_file)
1287 #define PVCV_outside_ix sv_SVp | offsetof(struct xpvcv, xcv_outside)
1288 #define PVCV_outside_seq_ix sv_U32p | offsetof(struct xpvcv, xcv_outside_seq)
1289 #define PVCV_flags_ix   sv_U16p | offsetof(struct xpvcv, xcv_flags)
1290
1291 #define PVHV_max_ix     sv_STRLENp | offsetof(struct xpvhv, xhv_max)
1292
1293 #if PERL_VERSION > 12
1294 #define PVHV_keys_ix    sv_STRLENp | offsetof(struct xpvhv, xhv_keys)
1295 #else
1296 #define PVHV_keys_ix    sv_IVp | offsetof(struct xpvhv, xhv_keys)
1297 #endif
1298
1299 # The type checking code in B has always been identical for all SV types,
1300 # irrespective of whether the action is actually defined on that SV.
1301 # We should fix this
1302 void
1303 IVX(sv)
1304         B::SV           sv
1305     ALIAS:
1306         B::IV::IVX = IV_ivx_ix
1307         B::IV::UVX = IV_uvx_ix
1308         B::NV::NVX = NV_nvx_ix
1309         B::NV::COP_SEQ_RANGE_LOW = NV_cop_seq_range_low_ix
1310         B::NV::COP_SEQ_RANGE_HIGH = NV_cop_seq_range_high_ix
1311         B::NV::PARENT_PAD_INDEX = NV_parent_pad_index_ix
1312         B::NV::PARENT_FAKELEX_FLAGS = NV_parent_fakelex_flags_ix
1313         B::PV::CUR = PV_cur_ix
1314         B::PV::LEN = PV_len_ix
1315         B::PVMG::SvSTASH = PVMG_stash_ix
1316         B::PVLV::TARGOFF = PVLV_targoff_ix
1317         B::PVLV::TARGLEN = PVLV_targlen_ix
1318         B::PVLV::TARG = PVLV_targ_ix
1319         B::PVLV::TYPE = PVLV_type_ix
1320         B::GV::STASH = PVGV_stash_ix
1321         B::GV::GvFLAGS = PVGV_flags_ix
1322         B::BM::USEFUL = PVBM_useful_ix
1323         B::BM::PREVIOUS = PVBM_previous_ix
1324         B::BM::RARE = PVBM_rare_ix
1325         B::IO::LINES =  PVIO_lines_ix
1326         B::IO::PAGE = PVIO_page_ix
1327         B::IO::PAGE_LEN = PVIO_page_len_ix
1328         B::IO::LINES_LEFT = PVIO_lines_left_ix
1329         B::IO::TOP_NAME = PVIO_top_name_ix
1330         B::IO::TOP_GV = PVIO_top_gv_ix
1331         B::IO::FMT_NAME = PVIO_fmt_name_ix
1332         B::IO::FMT_GV = PVIO_fmt_gv_ix
1333         B::IO::BOTTOM_NAME = PVIO_bottom_name_ix
1334         B::IO::BOTTOM_GV = PVIO_bottom_gv_ix
1335         B::IO::IoTYPE = PVIO_type_ix
1336         B::IO::IoFLAGS = PVIO_flags_ix
1337         B::AV::MAX = PVAV_max_ix
1338         B::CV::STASH = PVCV_stash_ix
1339         B::CV::GV = PVCV_gv_ix
1340         B::CV::FILE = PVCV_file_ix
1341         B::CV::OUTSIDE = PVCV_outside_ix
1342         B::CV::OUTSIDE_SEQ = PVCV_outside_seq_ix
1343         B::CV::CvFLAGS = PVCV_flags_ix
1344         B::HV::MAX = PVHV_max_ix
1345         B::HV::KEYS = PVHV_keys_ix
1346     PREINIT:
1347         char *ptr;
1348         SV *ret;
1349     PPCODE:
1350         ptr = (ix & 0xFFFF) + (char *)SvANY(sv);
1351         switch ((U8)(ix >> 16)) {
1352         case (U8)(sv_SVp >> 16):
1353             ret = make_sv_object(aTHX_ *((SV **)ptr));
1354             break;
1355         case (U8)(sv_IVp >> 16):
1356             ret = sv_2mortal(newSViv(*((IV *)ptr)));
1357             break;
1358         case (U8)(sv_UVp >> 16):
1359             ret = sv_2mortal(newSVuv(*((UV *)ptr)));
1360             break;
1361         case (U8)(sv_STRLENp >> 16):
1362             ret = sv_2mortal(newSVuv(*((STRLEN *)ptr)));
1363             break;
1364         case (U8)(sv_U32p >> 16):
1365             ret = sv_2mortal(newSVuv(*((U32 *)ptr)));
1366             break;
1367         case (U8)(sv_U8p >> 16):
1368             ret = sv_2mortal(newSVuv(*((U8 *)ptr)));
1369             break;
1370         case (U8)(sv_char_pp >> 16):
1371             ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
1372             break;
1373         case (U8)(sv_NVp >> 16):
1374             ret = sv_2mortal(newSVnv(*((NV *)ptr)));
1375             break;
1376         case (U8)(sv_char_p >> 16):
1377             ret = newSVpvn_flags((char *)ptr, 1, SVs_TEMP);
1378             break;
1379         case (U8)(sv_SSize_tp >> 16):
1380             ret = sv_2mortal(newSViv(*((SSize_t *)ptr)));
1381             break;
1382         case (U8)(sv_I32p >> 16):
1383             ret = sv_2mortal(newSVuv(*((I32 *)ptr)));
1384             break;
1385         case (U8)(sv_U16p >> 16):
1386             ret = sv_2mortal(newSVuv(*((U16 *)ptr)));
1387             break;
1388         default:
1389             croak("Illegal alias 0x%08x for B::*IVX", (unsigned)ix);
1390         }
1391         ST(0) = ret;
1392         XSRETURN(1);
1393
1394 void
1395 packiv(sv)
1396         B::IV   sv
1397     ALIAS:
1398         needs64bits = 1
1399     CODE:
1400         if (ix) {
1401             ST(0) = boolSV((I32)SvIVX(sv) != SvIVX(sv));
1402         } else if (sizeof(IV) == 8) {
1403             U32 wp[2];
1404             const IV iv = SvIVX(sv);
1405             /*
1406              * The following way of spelling 32 is to stop compilers on
1407              * 32-bit architectures from moaning about the shift count
1408              * being >= the width of the type. Such architectures don't
1409              * reach this code anyway (unless sizeof(IV) > 8 but then
1410              * everything else breaks too so I'm not fussed at the moment).
1411              */
1412 #ifdef UV_IS_QUAD
1413             wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1414 #else
1415             wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1416 #endif
1417             wp[1] = htonl(iv & 0xffffffff);
1418             ST(0) = newSVpvn_flags((char *)wp, 8, SVs_TEMP);
1419         } else {
1420             U32 w = htonl((U32)SvIVX(sv));
1421             ST(0) = newSVpvn_flags((char *)&w, 4, SVs_TEMP);
1422         }
1423
1424 MODULE = B      PACKAGE = B::NV         PREFIX = Sv
1425
1426 NV
1427 SvNV(sv)
1428         B::NV   sv
1429
1430 #if PERL_VERSION < 11
1431
1432 MODULE = B      PACKAGE = B::RV         PREFIX = Sv
1433
1434 void
1435 SvRV(sv)
1436         B::RV   sv
1437     PPCODE:
1438         PUSHs(make_sv_object(aTHX_ SvRV(sv)));
1439
1440 #else
1441
1442 MODULE = B      PACKAGE = B::REGEXP
1443
1444 void
1445 REGEX(sv)
1446         B::REGEXP       sv
1447     ALIAS:
1448         precomp = 1
1449     PPCODE:
1450         if (ix) {
1451             PUSHs(newSVpvn_flags(RX_PRECOMP(sv), RX_PRELEN(sv), SVs_TEMP));
1452         } else {
1453             dXSTARG;
1454             /* FIXME - can we code this method more efficiently?  */
1455             PUSHi(PTR2IV(sv));
1456         }
1457
1458 #endif
1459
1460 MODULE = B      PACKAGE = B::PV
1461
1462 void
1463 RV(sv)
1464         B::PV   sv
1465     PPCODE:
1466         if (!SvROK(sv))
1467             croak( "argument is not SvROK" );
1468         PUSHs(make_sv_object(aTHX_ SvRV(sv)));
1469
1470 void
1471 PV(sv)
1472         B::PV   sv
1473     ALIAS:
1474         PVX = 1
1475         PVBM = 2
1476         B::BM::TABLE = 3
1477     PREINIT:
1478         const char *p;
1479         STRLEN len = 0;
1480         U32 utf8 = 0;
1481     CODE:
1482         if (ix == 3) {
1483 #ifndef PERL_FBM_TABLE_OFFSET
1484             const MAGIC *const mg = mg_find(sv, PERL_MAGIC_bm);
1485
1486             if (!mg)
1487                 croak("argument to B::BM::TABLE is not a PVBM");
1488             p = mg->mg_ptr;
1489             len = mg->mg_len;
1490 #else
1491             p = SvPV(sv, len);
1492             /* Boyer-Moore table is just after string and its safety-margin \0 */
1493             p += len + PERL_FBM_TABLE_OFFSET;
1494             len = 256;
1495 #endif
1496         } else if (ix == 2) {
1497             /* This used to read 257. I think that that was buggy - should have
1498                been 258. (The "\0", the flags byte, and 256 for the table.)
1499                The only user of this method is B::Bytecode in B::PV::bsave.
1500                I'm guessing that nothing tested the runtime correctness of
1501                output of bytecompiled string constant arguments to index (etc).
1502
1503                Note the start pointer is and has always been SvPVX(sv), not
1504                SvPVX(sv) + SvCUR(sv) PVBM was added in 651aa52ea1faa806, and
1505                first used by the compiler in 651aa52ea1faa806. It's used to
1506                get a "complete" dump of the buffer at SvPVX(), not just the
1507                PVBM table. This permits the generated bytecode to "load"
1508                SvPVX in "one" hit.
1509
1510                5.15 and later store the BM table via MAGIC, so the compiler
1511                should handle this just fine without changes if PVBM now
1512                always returns the SvPVX() buffer.  */
1513 #ifdef isREGEXP
1514             p = isREGEXP(sv)
1515                  ? RX_WRAPPED_const((REGEXP*)sv)
1516                  : SvPVX_const(sv);
1517 #else
1518             p = SvPVX_const(sv);
1519 #endif
1520 #ifdef PERL_FBM_TABLE_OFFSET
1521             len = SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0);
1522 #else
1523             len = SvCUR(sv);
1524 #endif
1525         } else if (ix) {
1526 #ifdef isREGEXP
1527             p = isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX(sv);
1528 #else
1529             p = SvPVX(sv);
1530 #endif
1531             len = strlen(p);
1532         } else if (SvPOK(sv)) {
1533             len = SvCUR(sv);
1534             p = SvPVX_const(sv);
1535             utf8 = SvUTF8(sv);
1536         }
1537 #ifdef isREGEXP
1538         else if (isREGEXP(sv)) {
1539             len = SvCUR(sv);
1540             p = RX_WRAPPED_const((REGEXP*)sv);
1541             utf8 = SvUTF8(sv);
1542         }
1543 #endif
1544         else {
1545             /* XXX for backward compatibility, but should fail */
1546             /* croak( "argument is not SvPOK" ); */
1547             p = NULL;
1548         }
1549         ST(0) = newSVpvn_flags(p, len, SVs_TEMP | utf8);
1550
1551 MODULE = B      PACKAGE = B::PVMG
1552
1553 void
1554 MAGIC(sv)
1555         B::PVMG sv
1556         MAGIC * mg = NO_INIT
1557     PPCODE:
1558         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
1559             XPUSHs(make_mg_object(aTHX_ mg));
1560
1561 MODULE = B      PACKAGE = B::MAGIC
1562
1563 void
1564 MOREMAGIC(mg)
1565         B::MAGIC        mg
1566     ALIAS:
1567         PRIVATE = 1
1568         TYPE = 2
1569         FLAGS = 3
1570         LENGTH = 4
1571         OBJ = 5
1572         PTR = 6
1573         REGEX = 7
1574         precomp = 8
1575     PPCODE:
1576         switch (ix) {
1577         case 0:
1578             XPUSHs(mg->mg_moremagic ? make_mg_object(aTHX_ mg->mg_moremagic)
1579                                     : &PL_sv_undef);
1580             break;
1581         case 1:
1582             mPUSHu(mg->mg_private);
1583             break;
1584         case 2:
1585             PUSHs(newSVpvn_flags(&(mg->mg_type), 1, SVs_TEMP));
1586             break;
1587         case 3:
1588             mPUSHu(mg->mg_flags);
1589             break;
1590         case 4:
1591             mPUSHi(mg->mg_len);
1592             break;
1593         case 5:
1594             PUSHs(make_sv_object(aTHX_ mg->mg_obj));
1595             break;
1596         case 6:
1597             if (mg->mg_ptr) {
1598                 if (mg->mg_len >= 0) {
1599                     PUSHs(newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP));
1600                 } else if (mg->mg_len == HEf_SVKEY) {
1601                     PUSHs(make_sv_object(aTHX_ (SV*)mg->mg_ptr));
1602                 } else
1603                     PUSHs(sv_newmortal());
1604             } else
1605                 PUSHs(sv_newmortal());
1606             break;
1607         case 7:
1608             if(mg->mg_type == PERL_MAGIC_qr) {
1609                 mPUSHi(PTR2IV(mg->mg_obj));
1610             } else {
1611                 croak("REGEX is only meaningful on r-magic");
1612             }
1613             break;
1614         case 8:
1615             if (mg->mg_type == PERL_MAGIC_qr) {
1616                 REGEXP *rx = (REGEXP *)mg->mg_obj;
1617                 PUSHs(newSVpvn_flags(rx ? RX_PRECOMP(rx) : NULL,
1618                                      rx ? RX_PRELEN(rx) : 0, SVs_TEMP));
1619             } else {
1620                 croak( "precomp is only meaningful on r-magic" );
1621             }
1622             break;
1623         }
1624
1625 MODULE = B      PACKAGE = B::GV         PREFIX = Gv
1626
1627 void
1628 GvNAME(gv)
1629         B::GV   gv
1630     ALIAS:
1631         FILE = 1
1632         B::HV::NAME = 2
1633     CODE:
1634         ST(0) = sv_2mortal(newSVhek(!ix ? GvNAME_HEK(gv)
1635                                         : (ix == 1 ? GvFILE_HEK(gv)
1636                                                    : HvNAME_HEK((HV *)gv))));
1637
1638 bool
1639 is_empty(gv)
1640         B::GV   gv
1641     ALIAS:
1642         isGV_with_GP = 1
1643     CODE:
1644         if (ix) {
1645             RETVAL = isGV_with_GP(gv) ? TRUE : FALSE;
1646         } else {
1647             RETVAL = GvGP(gv) == Null(GP*);
1648         }
1649     OUTPUT:
1650         RETVAL
1651
1652 void*
1653 GvGP(gv)
1654         B::GV   gv
1655
1656 #define GP_sv_ix        SVp | offsetof(struct gp, gp_sv)
1657 #define GP_io_ix        SVp | offsetof(struct gp, gp_io)
1658 #define GP_cv_ix        SVp | offsetof(struct gp, gp_cv)
1659 #define GP_cvgen_ix     U32p | offsetof(struct gp, gp_cvgen)
1660 #define GP_refcnt_ix    U32p | offsetof(struct gp, gp_refcnt)
1661 #define GP_hv_ix        SVp | offsetof(struct gp, gp_hv)
1662 #define GP_av_ix        SVp | offsetof(struct gp, gp_av)
1663 #define GP_form_ix      SVp | offsetof(struct gp, gp_form)
1664 #define GP_egv_ix       SVp | offsetof(struct gp, gp_egv)
1665 #define GP_line_ix      line_tp | offsetof(struct gp, gp_line)
1666
1667 void
1668 SV(gv)
1669         B::GV   gv
1670     ALIAS:
1671         SV = GP_sv_ix
1672         IO = GP_io_ix
1673         CV = GP_cv_ix
1674         CVGEN = GP_cvgen_ix
1675         GvREFCNT = GP_refcnt_ix
1676         HV = GP_hv_ix
1677         AV = GP_av_ix
1678         FORM = GP_form_ix
1679         EGV = GP_egv_ix
1680         LINE = GP_line_ix
1681     PREINIT:
1682         GP *gp;
1683         char *ptr;
1684         SV *ret;
1685     PPCODE:
1686         gp = GvGP(gv);
1687         if (!gp) {
1688             const GV *const gv = CvGV(cv);
1689             Perl_croak(aTHX_ "NULL gp in B::GV::%s", gv ? GvNAME(gv) : "???");
1690         }
1691         ptr = (ix & 0xFFFF) + (char *)gp;
1692         switch ((U8)(ix >> 16)) {
1693         case (U8)(SVp >> 16):
1694             ret = make_sv_object(aTHX_ *((SV **)ptr));
1695             break;
1696         case (U8)(U32p >> 16):
1697             ret = sv_2mortal(newSVuv(*((U32*)ptr)));
1698             break;
1699         case (U8)(line_tp >> 16):
1700             ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
1701             break;
1702         default:
1703             croak("Illegal alias 0x%08x for B::*SV", (unsigned)ix);
1704         }
1705         ST(0) = ret;
1706         XSRETURN(1);
1707
1708 void
1709 FILEGV(gv)
1710         B::GV   gv
1711     PPCODE:
1712         PUSHs(make_sv_object(aTHX_ (SV *)GvFILEGV(gv)));
1713
1714 MODULE = B      PACKAGE = B::IO         PREFIX = Io
1715
1716
1717 bool
1718 IsSTD(io,name)
1719         B::IO   io
1720         const char*     name
1721     PREINIT:
1722         PerlIO* handle = 0;
1723     CODE:
1724         if( strEQ( name, "stdin" ) ) {
1725             handle = PerlIO_stdin();
1726         }
1727         else if( strEQ( name, "stdout" ) ) {
1728             handle = PerlIO_stdout();
1729         }
1730         else if( strEQ( name, "stderr" ) ) {
1731             handle = PerlIO_stderr();
1732         }
1733         else {
1734             croak( "Invalid value '%s'", name );
1735         }
1736         RETVAL = handle == IoIFP(io);
1737     OUTPUT:
1738         RETVAL
1739
1740 MODULE = B      PACKAGE = B::AV         PREFIX = Av
1741
1742 SSize_t
1743 AvFILL(av)
1744         B::AV   av
1745
1746 void
1747 AvARRAY(av)
1748         B::AV   av
1749     PPCODE:
1750         if (AvFILL(av) >= 0) {
1751             SV **svp = AvARRAY(av);
1752             I32 i;
1753             for (i = 0; i <= AvFILL(av); i++)
1754                 XPUSHs(make_sv_object(aTHX_ svp[i]));
1755         }
1756
1757 void
1758 AvARRAYelt(av, idx)
1759         B::AV   av
1760         int     idx
1761     PPCODE:
1762         if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
1763             XPUSHs(make_sv_object(aTHX_ (AvARRAY(av)[idx])));
1764         else
1765             XPUSHs(make_sv_object(aTHX_ NULL));
1766
1767
1768 MODULE = B      PACKAGE = B::FM         PREFIX = Fm
1769
1770 #undef FmLINES
1771 #define FmLINES(sv) 0
1772
1773 IV
1774 FmLINES(form)
1775         B::FM   form
1776
1777 MODULE = B      PACKAGE = B::CV         PREFIX = Cv
1778
1779 U32
1780 CvCONST(cv)
1781         B::CV   cv
1782
1783 void
1784 CvSTART(cv)
1785         B::CV   cv
1786     ALIAS:
1787         ROOT = 1
1788     PPCODE:
1789         PUSHs(make_op_object(aTHX_ CvISXSUB(cv) ? NULL
1790                              : ix ? CvROOT(cv) : CvSTART(cv)));
1791
1792 I32
1793 CvDEPTH(cv)
1794         B::CV   cv
1795
1796 #ifdef PadlistARRAY
1797
1798 B::PADLIST
1799 CvPADLIST(cv)
1800         B::CV   cv
1801
1802 #else
1803
1804 B::AV
1805 CvPADLIST(cv)
1806         B::CV   cv
1807     PPCODE:
1808         PUSHs(make_sv_object(aTHX_ (SV *)CvPADLIST(cv)));
1809
1810
1811 #endif
1812
1813 void
1814 CvXSUB(cv)
1815         B::CV   cv
1816     ALIAS:
1817         XSUBANY = 1
1818     CODE:
1819         ST(0) = ix && CvCONST(cv)
1820             ? make_sv_object(aTHX_ (SV *)CvXSUBANY(cv).any_ptr)
1821             : sv_2mortal(newSViv(CvISXSUB(cv)
1822                                  ? (ix ? CvXSUBANY(cv).any_iv
1823                                        : PTR2IV(CvXSUB(cv)))
1824                                  : 0));
1825
1826 void
1827 const_sv(cv)
1828         B::CV   cv
1829     PPCODE:
1830         PUSHs(make_sv_object(aTHX_ (SV *)cv_const_sv(cv)));
1831
1832 MODULE = B      PACKAGE = B::HV         PREFIX = Hv
1833
1834 STRLEN
1835 HvFILL(hv)
1836         B::HV   hv
1837
1838 I32
1839 HvRITER(hv)
1840         B::HV   hv
1841
1842 void
1843 HvARRAY(hv)
1844         B::HV   hv
1845     PPCODE:
1846         if (HvUSEDKEYS(hv) > 0) {
1847             SV *sv;
1848             char *key;
1849             I32 len;
1850             (void)hv_iterinit(hv);
1851             EXTEND(sp, HvUSEDKEYS(hv) * 2);
1852             while ((sv = hv_iternextsv(hv, &key, &len))) {
1853                 mPUSHp(key, len);
1854                 PUSHs(make_sv_object(aTHX_ sv));
1855             }
1856         }
1857
1858 MODULE = B      PACKAGE = B::HE         PREFIX = He
1859
1860 void
1861 HeVAL(he)
1862         B::HE he
1863     ALIAS:
1864         SVKEY_force = 1
1865     PPCODE:
1866         PUSHs(make_sv_object(aTHX_ ix ? HeSVKEY_force(he) : HeVAL(he)));
1867
1868 U32
1869 HeHASH(he)
1870         B::HE he
1871
1872 MODULE = B      PACKAGE = B::RHE
1873
1874 SV*
1875 HASH(h)
1876         B::RHE h
1877     CODE:
1878         RETVAL = newRV( (SV*)cophh_2hv(h, 0) );
1879     OUTPUT:
1880         RETVAL
1881
1882
1883 #ifdef PadlistARRAY
1884
1885 MODULE = B      PACKAGE = B::PADLIST    PREFIX = Padlist
1886
1887 SSize_t
1888 PadlistMAX(padlist)
1889         B::PADLIST      padlist
1890
1891 void
1892 PadlistARRAY(padlist)
1893         B::PADLIST      padlist
1894     PPCODE:
1895         if (PadlistMAX(padlist) >= 0) {
1896             PAD **padp = PadlistARRAY(padlist);
1897             PADOFFSET i;
1898             for (i = 0; i <= PadlistMAX(padlist); i++)
1899                 XPUSHs(make_sv_object(aTHX_ (SV *)padp[i]));
1900         }
1901
1902 void
1903 PadlistARRAYelt(padlist, idx)
1904         B::PADLIST      padlist
1905         PADOFFSET       idx
1906     PPCODE:
1907         if (idx >= 0 && PadlistMAX(padlist) >= 0
1908          && idx <= PadlistMAX(padlist))
1909             XPUSHs(make_sv_object(aTHX_
1910                                   (SV *)PadlistARRAY(padlist)[idx]));
1911         else
1912             XPUSHs(make_sv_object(aTHX_ NULL));
1913
1914 U32
1915 PadlistREFCNT(padlist)
1916         B::PADLIST      padlist
1917     CODE:
1918         RETVAL = PadlistREFCNT(padlist);
1919     OUTPUT:
1920         RETVAL
1921
1922 #endif