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