ext/B/B.xs

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