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