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