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