ext/B/B.xs

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