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