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