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
 567 MODULE = B      PACKAGE = B     PREFIX = B_
 568
 569 PROTOTYPES: DISABLE
 570
 571 BOOT:
 572 {
 573     HV *stash = gv_stashpvn("B", 1, TRUE);
 574     AV *export_ok = perl_get_av("B::EXPORT_OK",TRUE);
 575     MY_CXT_INIT;
 576     specialsv_list[0] = Nullsv;
 577     specialsv_list[1] = &PL_sv_undef;
 578     specialsv_list[2] = &PL_sv_yes;
 579     specialsv_list[3] = &PL_sv_no;
 580     specialsv_list[4] = (SV *) pWARN_ALL;
 581     specialsv_list[5] = (SV *) pWARN_NONE;
 582     specialsv_list[6] = (SV *) pWARN_STD;
 583 #if PERL_VERSION <= 8
 584 #  define CVf_ASSERTION 0
 585 #endif
 586 #include "defsubs.h"
 587 }
 588
 589 #define B_main_cv()     PL_main_cv
 590 #define B_init_av()     PL_initav
 591 #define B_inc_gv()      PL_incgv
 592 #define B_check_av()    PL_checkav_save
 593 #define B_begin_av()    PL_beginav_save
 594 #define B_end_av()      PL_endav
 595 #define B_main_root()   PL_main_root
 596 #define B_main_start()  PL_main_start
 597 #define B_amagic_generation()   PL_amagic_generation
 598 #define B_sub_generation()      PL_sub_generation
 599 #define B_defstash()    PL_defstash
 600 #define B_curstash()    PL_curstash
 601 #define B_dowarn()      PL_dowarn
 602 #define B_comppadlist() (PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv))
 603 #define B_sv_undef()    &PL_sv_undef
 604 #define B_sv_yes()      &PL_sv_yes
 605 #define B_sv_no()       &PL_sv_no
 606 #define B_formfeed()    PL_formfeed
 607 #ifdef USE_ITHREADS
 608 #define B_regex_padav() PL_regex_padav
 609 #endif
 610
 611 B::AV
 612 B_init_av()
 613
 614 B::AV
 615 B_check_av()
 616
 617 B::AV
 618 B_begin_av()
 619
 620 B::AV
 621 B_end_av()
 622
 623 B::GV
 624 B_inc_gv()
 625
 626 #ifdef USE_ITHREADS
 627
 628 B::AV
 629 B_regex_padav()
 630
 631 #endif
 632
 633 B::CV
 634 B_main_cv()
 635
 636 B::OP
 637 B_main_root()
 638
 639 B::OP
 640 B_main_start()
 641
 642 long
 643 B_amagic_generation()
 644
 645 long
 646 B_sub_generation()
 647
 648 B::AV
 649 B_comppadlist()
 650
 651 B::SV
 652 B_sv_undef()
 653
 654 B::SV
 655 B_sv_yes()
 656
 657 B::SV
 658 B_sv_no()
 659
 660 B::HV
 661 B_curstash()
 662
 663 B::HV
 664 B_defstash()
 665
 666 U8
 667 B_dowarn()
 668
 669 B::SV
 670 B_formfeed()
 671
 672 void
 673 B_warnhook()
 674     CODE:
 675         ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_warnhook);
 676
 677 void
 678 B_diehook()
 679     CODE:
 680         ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_diehook);
 681
 682 MODULE = B      PACKAGE = B
 683
 684 void
 685 walkoptree(opsv, method)
 686         SV *    opsv
 687         const char *    method
 688     CODE:
 689         walkoptree(aTHX_ opsv, method);
 690
 691 int
 692 walkoptree_debug(...)
 693     CODE:
 694         dMY_CXT;
 695         RETVAL = walkoptree_debug;
 696         if (items > 0 && SvTRUE(ST(1)))
 697             walkoptree_debug = 1;
 698     OUTPUT:
 699         RETVAL
 700
 701 #define address(sv) PTR2IV(sv)
 702
 703 IV
 704 address(sv)
 705         SV *    sv
 706
 707 B::SV
 708 svref_2object(sv)
 709         SV *    sv
 710     CODE:
 711         if (!SvROK(sv))
 712             croak("argument is not a reference");
 713         RETVAL = (SV*)SvRV(sv);
 714     OUTPUT:
 715         RETVAL
 716
 717 void
 718 opnumber(name)
 719 const char *    name
 720 CODE:
 721 {
 722  int i;
 723  IV  result = -1;
 724  ST(0) = sv_newmortal();
 725  if (strncmp(name,"pp_",3) == 0)
 726    name += 3;
 727  for (i = 0; i < PL_maxo; i++)
 728   {
 729    if (strcmp(name, PL_op_name[i]) == 0)
 730     {
 731      result = i;
 732      break;
 733     }
 734   }
 735  sv_setiv(ST(0),result);
 736 }
 737
 738 void
 739 ppname(opnum)
 740         int     opnum
 741     CODE:
 742         ST(0) = sv_newmortal();
 743         if (opnum >= 0 && opnum < PL_maxo) {
 744             sv_setpvn(ST(0), "pp_", 3);
 745             sv_catpv(ST(0), PL_op_name[opnum]);
 746         }
 747
 748 void
 749 hash(sv)
 750         SV *    sv
 751     CODE:
 752         STRLEN len;
 753         U32 hash = 0;
 754         char hexhash[19]; /* must fit "0xffffffffffffffff" plus trailing \0 */
 755         const char *s = SvPV(sv, len);
 756         PERL_HASH(hash, s, len);
 757         sprintf(hexhash, "0x%"UVxf, (UV)hash);
 758         ST(0) = sv_2mortal(newSVpv(hexhash, 0));
 759
 760 #define cast_I32(foo) (I32)foo
 761 IV
 762 cast_I32(i)
 763         IV      i
 764
 765 void
 766 minus_c()
 767     CODE:
 768         PL_minus_c = TRUE;
 769
 770 void
 771 save_BEGINs()
 772     CODE:
 773         PL_savebegin = TRUE;
 774
 775 SV *
 776 cstring(sv)
 777         SV *    sv
 778     CODE:
 779         RETVAL = cstring(aTHX_ sv, 0);
 780     OUTPUT:
 781         RETVAL
 782
 783 SV *
 784 perlstring(sv)
 785         SV *    sv
 786     CODE:
 787         RETVAL = cstring(aTHX_ sv, 1);
 788     OUTPUT:
 789         RETVAL
 790
 791 SV *
 792 cchar(sv)
 793         SV *    sv
 794     CODE:
 795         RETVAL = cchar(aTHX_ sv);
 796     OUTPUT:
 797         RETVAL
 798
 799 void
 800 threadsv_names()
 801     PPCODE:
 802 #if PERL_VERSION <= 8
 803 # ifdef USE_5005THREADS
 804         int i;
 805         const STRLEN len = strlen(PL_threadsv_names);
 806
 807         EXTEND(sp, len);
 808         for (i = 0; i < len; i++)
 809             PUSHs(sv_2mortal(newSVpvn(&PL_threadsv_names[i], 1)));
 810 # endif
 811 #endif
 812
 813 #define OP_next(o)      o->op_next
 814 #define OP_sibling(o)   o->op_sibling
 815 #define OP_desc(o)      (char *)PL_op_desc[o->op_type]
 816 #define OP_targ(o)      o->op_targ
 817 #define OP_type(o)      o->op_type
 818 #if PERL_VERSION >= 9
 819 #  define OP_opt(o)     o->op_opt
 820 #  define OP_static(o)  o->op_static
 821 #else
 822 #  define OP_seq(o)     o->op_seq
 823 #endif
 824 #define OP_flags(o)     o->op_flags
 825 #define OP_private(o)   o->op_private
 826 #define OP_spare(o)     o->op_spare
 827
 828 MODULE = B      PACKAGE = B::OP         PREFIX = OP_
 829
 830 size_t
 831 OP_size(o)
 832         B::OP           o
 833     CODE:
 834         RETVAL = opsizes[cc_opclass(aTHX_ o)];
 835     OUTPUT:
 836         RETVAL
 837
 838 B::OP
 839 OP_next(o)
 840         B::OP           o
 841
 842 B::OP
 843 OP_sibling(o)
 844         B::OP           o
 845
 846 char *
 847 OP_name(o)
 848         B::OP           o
 849     CODE:
 850         RETVAL = (char *)PL_op_name[o->op_type];
 851     OUTPUT:
 852         RETVAL
 853
 854
 855 void
 856 OP_ppaddr(o)
 857         B::OP           o
 858     PREINIT:
 859         int i;
 860         SV *sv = sv_newmortal();
 861     CODE:
 862         sv_setpvn(sv, "PL_ppaddr[OP_", 13);
 863         sv_catpv(sv, PL_op_name[o->op_type]);
 864         for (i=13; (STRLEN)i < SvCUR(sv); ++i)
 865             SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]);
 866         sv_catpv(sv, "]");
 867         ST(0) = sv;
 868
 869 char *
 870 OP_desc(o)
 871         B::OP           o
 872
 873 PADOFFSET
 874 OP_targ(o)
 875         B::OP           o
 876
 877 U16
 878 OP_type(o)
 879         B::OP           o
 880
 881 #if PERL_VERSION >= 9
 882
 883 U8
 884 OP_opt(o)
 885         B::OP           o
 886
 887 U8
 888 OP_static(o)
 889         B::OP           o
 890
 891 #else
 892
 893 U16
 894 OP_seq(o)
 895         B::OP           o
 896
 897 #endif
 898
 899 U8
 900 OP_flags(o)
 901         B::OP           o
 902
 903 U8
 904 OP_private(o)
 905         B::OP           o
 906
 907 #if PERL_VERSION >= 9
 908
 909 U8
 910 OP_spare(o)
 911         B::OP           o
 912
 913 #endif
 914
 915 void
 916 OP_oplist(o)
 917         B::OP           o
 918     PPCODE:
 919         SP = oplist(aTHX_ o, SP);
 920
 921 #define UNOP_first(o)   o->op_first
 922
 923 MODULE = B      PACKAGE = B::UNOP               PREFIX = UNOP_
 924
 925 B::OP
 926 UNOP_first(o)
 927         B::UNOP o
 928
 929 #define BINOP_last(o)   o->op_last
 930
 931 MODULE = B      PACKAGE = B::BINOP              PREFIX = BINOP_
 932
 933 B::OP
 934 BINOP_last(o)
 935         B::BINOP        o
 936
 937 #define LOGOP_other(o)  o->op_other
 938
 939 MODULE = B      PACKAGE = B::LOGOP              PREFIX = LOGOP_
 940
 941 B::OP
 942 LOGOP_other(o)
 943         B::LOGOP        o
 944
 945 MODULE = B      PACKAGE = B::LISTOP             PREFIX = LISTOP_
 946
 947 U32
 948 LISTOP_children(o)
 949         B::LISTOP       o
 950         OP *            kid = NO_INIT
 951         int             i = NO_INIT
 952     CODE:
 953         i = 0;
 954         for (kid = o->op_first; kid; kid = kid->op_sibling)
 955             i++;
 956         RETVAL = i;
 957     OUTPUT:
 958         RETVAL
 959
 960 #define PMOP_pmreplroot(o)      o->op_pmreplroot
 961 #define PMOP_pmreplstart(o)     o->op_pmreplstart
 962 #define PMOP_pmnext(o)          o->op_pmnext
 963 #define PMOP_pmregexp(o)        PM_GETRE(o)
 964 #ifdef USE_ITHREADS
 965 #define PMOP_pmoffset(o)        o->op_pmoffset
 966 #define PMOP_pmstashpv(o)       o->op_pmstashpv
 967 #else
 968 #define PMOP_pmstash(o)         o->op_pmstash
 969 #endif
 970 #define PMOP_pmflags(o)         o->op_pmflags
 971 #define PMOP_pmpermflags(o)     o->op_pmpermflags
 972 #define PMOP_pmdynflags(o)      o->op_pmdynflags
 973
 974 MODULE = B      PACKAGE = B::PMOP               PREFIX = PMOP_
 975
 976 void
 977 PMOP_pmreplroot(o)
 978         B::PMOP         o
 979         OP *            root = NO_INIT
 980     CODE:
 981         ST(0) = sv_newmortal();
 982         root = o->op_pmreplroot;
 983         /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */
 984         if (o->op_type == OP_PUSHRE) {
 985 #ifdef USE_ITHREADS
 986             sv_setiv(ST(0), INT2PTR(PADOFFSET,root) );
 987 #else
 988             sv_setiv(newSVrv(ST(0), root ?
 989                              svclassnames[SvTYPE((SV*)root)] : "B::SV"),
 990                      PTR2IV(root));
 991 #endif
 992         }
 993         else {
 994             sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root));
 995         }
 996
 997 B::OP
 998 PMOP_pmreplstart(o)
 999         B::PMOP         o
1000
1001 B::PMOP
1002 PMOP_pmnext(o)
1003         B::PMOP         o
1004
1005 #ifdef USE_ITHREADS
1006
1007 IV
1008 PMOP_pmoffset(o)
1009         B::PMOP         o
1010
1011 char*
1012 PMOP_pmstashpv(o)
1013         B::PMOP         o
1014
1015 #else
1016
1017 B::HV
1018 PMOP_pmstash(o)
1019         B::PMOP         o
1020
1021 #endif
1022
1023 U32
1024 PMOP_pmflags(o)
1025         B::PMOP         o
1026
1027 U32
1028 PMOP_pmpermflags(o)
1029         B::PMOP         o
1030
1031 U8
1032 PMOP_pmdynflags(o)
1033         B::PMOP         o
1034
1035 void
1036 PMOP_precomp(o)
1037         B::PMOP         o
1038         REGEXP *        rx = NO_INIT
1039     CODE:
1040         ST(0) = sv_newmortal();
1041         rx = PM_GETRE(o);
1042         if (rx)
1043             sv_setpvn(ST(0), rx->precomp, rx->prelen);
1044
1045 #define SVOP_sv(o)     cSVOPo->op_sv
1046 #define SVOP_gv(o)     ((GV*)cSVOPo->op_sv)
1047
1048 MODULE = B      PACKAGE = B::SVOP               PREFIX = SVOP_
1049
1050 B::SV
1051 SVOP_sv(o)
1052         B::SVOP o
1053
1054 B::GV
1055 SVOP_gv(o)
1056         B::SVOP o
1057
1058 #define PADOP_padix(o)  o->op_padix
1059 #define PADOP_sv(o)     (o->op_padix ? PAD_SVl(o->op_padix) : Nullsv)
1060 #define PADOP_gv(o)     ((o->op_padix \
1061                           && SvTYPE(PAD_SVl(o->op_padix)) == SVt_PVGV) \
1062                          ? (GV*)PAD_SVl(o->op_padix) : Nullgv)
1063
1064 MODULE = B      PACKAGE = B::PADOP              PREFIX = PADOP_
1065
1066 PADOFFSET
1067 PADOP_padix(o)
1068         B::PADOP o
1069
1070 B::SV
1071 PADOP_sv(o)
1072         B::PADOP o
1073
1074 B::GV
1075 PADOP_gv(o)
1076         B::PADOP o
1077
1078 MODULE = B      PACKAGE = B::PVOP               PREFIX = PVOP_
1079
1080 void
1081 PVOP_pv(o)
1082         B::PVOP o
1083     CODE:
1084         /*
1085          * OP_TRANS uses op_pv to point to a table of 256 or >=258 shorts
1086          * whereas other PVOPs point to a null terminated string.
1087          */
1088         if (o->op_type == OP_TRANS &&
1089                 (o->op_private & OPpTRANS_COMPLEMENT) &&
1090                 !(o->op_private & OPpTRANS_DELETE))
1091         {
1092             const short* const tbl = (short*)o->op_pv;
1093             const short entries = 257 + tbl[256];
1094             ST(0) = sv_2mortal(newSVpv(o->op_pv, entries * sizeof(short)));
1095         }
1096         else if (o->op_type == OP_TRANS) {
1097             ST(0) = sv_2mortal(newSVpv(o->op_pv, 256 * sizeof(short)));
1098         }
1099         else
1100             ST(0) = sv_2mortal(newSVpv(o->op_pv, 0));
1101
1102 #define LOOP_redoop(o)  o->op_redoop
1103 #define LOOP_nextop(o)  o->op_nextop
1104 #define LOOP_lastop(o)  o->op_lastop
1105
1106 MODULE = B      PACKAGE = B::LOOP               PREFIX = LOOP_
1107
1108
1109 B::OP
1110 LOOP_redoop(o)
1111         B::LOOP o
1112
1113 B::OP
1114 LOOP_nextop(o)
1115         B::LOOP o
1116
1117 B::OP
1118 LOOP_lastop(o)
1119         B::LOOP o
1120
1121 #define COP_label(o)    o->cop_label
1122 #define COP_stashpv(o)  CopSTASHPV(o)
1123 #define COP_stash(o)    CopSTASH(o)
1124 #define COP_file(o)     CopFILE(o)
1125 #define COP_filegv(o)   CopFILEGV(o)
1126 #define COP_cop_seq(o)  o->cop_seq
1127 #define COP_arybase(o)  CopARYBASE_get(o)
1128 #define COP_line(o)     CopLINE(o)
1129 #define COP_hints(o)    CopHINTS_get(o)
1130
1131 MODULE = B      PACKAGE = B::COP                PREFIX = COP_
1132
1133 char *
1134 COP_label(o)
1135         B::COP  o
1136
1137 char *
1138 COP_stashpv(o)
1139         B::COP  o
1140
1141 B::HV
1142 COP_stash(o)
1143         B::COP  o
1144
1145 char *
1146 COP_file(o)
1147         B::COP  o
1148
1149 B::GV
1150 COP_filegv(o)
1151        B::COP  o
1152
1153
1154 U32
1155 COP_cop_seq(o)
1156         B::COP  o
1157
1158 I32
1159 COP_arybase(o)
1160         B::COP  o
1161
1162 U32
1163 COP_line(o)
1164         B::COP  o
1165
1166 void
1167 COP_warnings(o)
1168         B::COP  o
1169         PPCODE:
1170         ST(0) = make_warnings_object(aTHX_ sv_newmortal(), o->cop_warnings);
1171         XSRETURN(1);
1172
1173 void
1174 COP_io(o)
1175         B::COP  o
1176         PPCODE:
1177         ST(0) = make_cop_io_object(aTHX_ sv_newmortal(), o);
1178         XSRETURN(1);
1179
1180 U32
1181 COP_hints(o)
1182         B::COP  o
1183
1184 MODULE = B      PACKAGE = B::SV
1185
1186 U32
1187 SvTYPE(sv)
1188         B::SV   sv
1189
1190 #define object_2svref(sv)       sv
1191 #define SVREF SV *
1192
1193 SVREF
1194 object_2svref(sv)
1195         B::SV   sv
1196
1197 MODULE = B      PACKAGE = B::SV         PREFIX = Sv
1198
1199 U32
1200 SvREFCNT(sv)
1201         B::SV   sv
1202
1203 U32
1204 SvFLAGS(sv)
1205         B::SV   sv
1206
1207 U32
1208 SvPOK(sv)
1209         B::SV   sv
1210
1211 U32
1212 SvROK(sv)
1213         B::SV   sv
1214
1215 U32
1216 SvMAGICAL(sv)
1217         B::SV   sv
1218
1219 MODULE = B      PACKAGE = B::IV         PREFIX = Sv
1220
1221 IV
1222 SvIV(sv)
1223         B::IV   sv
1224
1225 IV
1226 SvIVX(sv)
1227         B::IV   sv
1228
1229 UV
1230 SvUVX(sv)
1231         B::IV   sv
1232
1233
1234 MODULE = B      PACKAGE = B::IV
1235
1236 #define needs64bits(sv) ((I32)SvIVX(sv) != SvIVX(sv))
1237
1238 int
1239 needs64bits(sv)
1240         B::IV   sv
1241
1242 void
1243 packiv(sv)
1244         B::IV   sv
1245     CODE:
1246         if (sizeof(IV) == 8) {
1247             U32 wp[2];
1248             const IV iv = SvIVX(sv);
1249             /*
1250              * The following way of spelling 32 is to stop compilers on
1251              * 32-bit architectures from moaning about the shift count
1252              * being >= the width of the type. Such architectures don't
1253              * reach this code anyway (unless sizeof(IV) > 8 but then
1254              * everything else breaks too so I'm not fussed at the moment).
1255              */
1256 #ifdef UV_IS_QUAD
1257             wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1258 #else
1259             wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1260 #endif
1261             wp[1] = htonl(iv & 0xffffffff);
1262             ST(0) = sv_2mortal(newSVpvn((char *)wp, 8));
1263         } else {
1264             U32 w = htonl((U32)SvIVX(sv));
1265             ST(0) = sv_2mortal(newSVpvn((char *)&w, 4));
1266         }
1267
1268 MODULE = B      PACKAGE = B::NV         PREFIX = Sv
1269
1270 NV
1271 SvNV(sv)
1272         B::NV   sv
1273
1274 NV
1275 SvNVX(sv)
1276         B::NV   sv
1277
1278 MODULE = B      PACKAGE = B::RV         PREFIX = Sv
1279
1280 B::SV
1281 SvRV(sv)
1282         B::RV   sv
1283
1284 MODULE = B      PACKAGE = B::PV         PREFIX = Sv
1285
1286 char*
1287 SvPVX(sv)
1288         B::PV   sv
1289
1290 B::SV
1291 SvRV(sv)
1292         B::PV   sv
1293     CODE:
1294         if( SvROK(sv) ) {
1295             RETVAL = SvRV(sv);
1296         }
1297         else {
1298             croak( "argument is not SvROK" );
1299         }
1300     OUTPUT:
1301         RETVAL
1302
1303 void
1304 SvPV(sv)
1305         B::PV   sv
1306     CODE:
1307         ST(0) = sv_newmortal();
1308         if( SvPOK(sv) ) {
1309             /* FIXME - we need a better way for B to identify PVs that are
1310                in the pads as variable names.  */
1311             if((SvLEN(sv) && SvCUR(sv) >= SvLEN(sv))) {
1312                 /* It claims to be longer than the space allocated for it -
1313                    presuambly it's a variable name in the pad  */
1314                 sv_setpv(ST(0), SvPV_nolen_const(sv));
1315             } else {
1316                 sv_setpvn(ST(0), SvPVX_const(sv), SvCUR(sv));
1317             }
1318             SvFLAGS(ST(0)) |= SvUTF8(sv);
1319         }
1320         else {
1321             /* XXX for backward compatibility, but should fail */
1322             /* croak( "argument is not SvPOK" ); */
1323             sv_setpvn(ST(0), NULL, 0);
1324         }
1325
1326 void
1327 SvPVBM(sv)
1328         B::PV   sv
1329     CODE:
1330         ST(0) = sv_newmortal();
1331         sv_setpvn(ST(0), SvPVX_const(sv),
1332             SvCUR(sv) + (SvTYPE(sv) == SVt_PVBM ? 257 : 0));
1333
1334
1335 STRLEN
1336 SvLEN(sv)
1337         B::PV   sv
1338
1339 STRLEN
1340 SvCUR(sv)
1341         B::PV   sv
1342
1343 MODULE = B      PACKAGE = B::PVMG       PREFIX = Sv
1344
1345 void
1346 SvMAGIC(sv)
1347         B::PVMG sv
1348         MAGIC * mg = NO_INIT
1349     PPCODE:
1350         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
1351             XPUSHs(make_mg_object(aTHX_ sv_newmortal(), mg));
1352
1353 MODULE = B      PACKAGE = B::PVMG
1354
1355 B::HV
1356 SvSTASH(sv)
1357         B::PVMG sv
1358
1359 #define MgMOREMAGIC(mg) mg->mg_moremagic
1360 #define MgPRIVATE(mg) mg->mg_private
1361 #define MgTYPE(mg) mg->mg_type
1362 #define MgFLAGS(mg) mg->mg_flags
1363 #define MgOBJ(mg) mg->mg_obj
1364 #define MgLENGTH(mg) mg->mg_len
1365 #define MgREGEX(mg) PTR2IV(mg->mg_obj)
1366
1367 MODULE = B      PACKAGE = B::MAGIC      PREFIX = Mg
1368
1369 B::MAGIC
1370 MgMOREMAGIC(mg)
1371         B::MAGIC        mg
1372      CODE:
1373         if( MgMOREMAGIC(mg) ) {
1374             RETVAL = MgMOREMAGIC(mg);
1375         }
1376         else {
1377             XSRETURN_UNDEF;
1378         }
1379      OUTPUT:
1380         RETVAL
1381
1382 U16
1383 MgPRIVATE(mg)
1384         B::MAGIC        mg
1385
1386 char
1387 MgTYPE(mg)
1388         B::MAGIC        mg
1389
1390 U8
1391 MgFLAGS(mg)
1392         B::MAGIC        mg
1393
1394 B::SV
1395 MgOBJ(mg)
1396         B::MAGIC        mg
1397
1398 IV
1399 MgREGEX(mg)
1400         B::MAGIC        mg
1401     CODE:
1402         if(mg->mg_type == PERL_MAGIC_qr) {
1403             RETVAL = MgREGEX(mg);
1404         }
1405         else {
1406             croak( "REGEX is only meaningful on r-magic" );
1407         }
1408     OUTPUT:
1409         RETVAL
1410
1411 SV*
1412 precomp(mg)
1413         B::MAGIC        mg
1414     CODE:
1415         if (mg->mg_type == PERL_MAGIC_qr) {
1416             REGEXP* rx = (REGEXP*)mg->mg_obj;
1417             RETVAL = Nullsv;
1418             if( rx )
1419                 RETVAL = newSVpvn( rx->precomp, rx->prelen );
1420         }
1421         else {
1422             croak( "precomp is only meaningful on r-magic" );
1423         }
1424     OUTPUT:
1425         RETVAL
1426
1427 I32
1428 MgLENGTH(mg)
1429         B::MAGIC        mg
1430
1431 void
1432 MgPTR(mg)
1433         B::MAGIC        mg
1434     CODE:
1435         ST(0) = sv_newmortal();
1436         if (mg->mg_ptr){
1437                 if (mg->mg_len >= 0){
1438                         sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len);
1439                 } else if (mg->mg_len == HEf_SVKEY) {
1440                         ST(0) = make_sv_object(aTHX_
1441                                     sv_newmortal(), (SV*)mg->mg_ptr);
1442                 }
1443         }
1444
1445 MODULE = B      PACKAGE = B::PVLV       PREFIX = Lv
1446
1447 U32
1448 LvTARGOFF(sv)
1449         B::PVLV sv
1450
1451 U32
1452 LvTARGLEN(sv)
1453         B::PVLV sv
1454
1455 char
1456 LvTYPE(sv)
1457         B::PVLV sv
1458
1459 B::SV
1460 LvTARG(sv)
1461         B::PVLV sv
1462
1463 MODULE = B      PACKAGE = B::BM         PREFIX = Bm
1464
1465 I32
1466 BmUSEFUL(sv)
1467         B::BM   sv
1468
1469 U16
1470 BmPREVIOUS(sv)
1471         B::BM   sv
1472
1473 U8
1474 BmRARE(sv)
1475         B::BM   sv
1476
1477 void
1478 BmTABLE(sv)
1479         B::BM   sv
1480         STRLEN  len = NO_INIT
1481         char *  str = NO_INIT
1482     CODE:
1483         str = SvPV(sv, len);
1484         /* Boyer-Moore table is just after string and its safety-margin \0 */
1485         ST(0) = sv_2mortal(newSVpvn(str + len + 1, 256));
1486
1487 MODULE = B      PACKAGE = B::GV         PREFIX = Gv
1488
1489 void
1490 GvNAME(gv)
1491         B::GV   gv
1492     CODE:
1493         ST(0) = sv_2mortal(newSVpvn(GvNAME(gv), GvNAMELEN(gv)));
1494
1495 bool
1496 is_empty(gv)
1497         B::GV   gv
1498     CODE:
1499         RETVAL = GvGP(gv) == Null(GP*);
1500     OUTPUT:
1501         RETVAL
1502
1503 void*
1504 GvGP(gv)
1505         B::GV   gv
1506
1507 B::HV
1508 GvSTASH(gv)
1509         B::GV   gv
1510
1511 B::SV
1512 GvSV(gv)
1513         B::GV   gv
1514
1515 B::IO
1516 GvIO(gv)
1517         B::GV   gv
1518
1519 B::FM
1520 GvFORM(gv)
1521         B::GV   gv
1522     CODE:
1523         RETVAL = (SV*)GvFORM(gv);
1524     OUTPUT:
1525         RETVAL
1526
1527 B::AV
1528 GvAV(gv)
1529         B::GV   gv
1530
1531 B::HV
1532 GvHV(gv)
1533         B::GV   gv
1534
1535 B::GV
1536 GvEGV(gv)
1537         B::GV   gv
1538
1539 B::CV
1540 GvCV(gv)
1541         B::GV   gv
1542
1543 U32
1544 GvCVGEN(gv)
1545         B::GV   gv
1546
1547 U32
1548 GvLINE(gv)
1549         B::GV   gv
1550
1551 char *
1552 GvFILE(gv)
1553         B::GV   gv
1554
1555 B::GV
1556 GvFILEGV(gv)
1557         B::GV   gv
1558
1559 MODULE = B      PACKAGE = B::GV
1560
1561 U32
1562 GvREFCNT(gv)
1563         B::GV   gv
1564
1565 U8
1566 GvFLAGS(gv)
1567         B::GV   gv
1568
1569 MODULE = B      PACKAGE = B::IO         PREFIX = Io
1570
1571 long
1572 IoLINES(io)
1573         B::IO   io
1574
1575 long
1576 IoPAGE(io)
1577         B::IO   io
1578
1579 long
1580 IoPAGE_LEN(io)
1581         B::IO   io
1582
1583 long
1584 IoLINES_LEFT(io)
1585         B::IO   io
1586
1587 char *
1588 IoTOP_NAME(io)
1589         B::IO   io
1590
1591 B::GV
1592 IoTOP_GV(io)
1593         B::IO   io
1594
1595 char *
1596 IoFMT_NAME(io)
1597         B::IO   io
1598
1599 B::GV
1600 IoFMT_GV(io)
1601         B::IO   io
1602
1603 char *
1604 IoBOTTOM_NAME(io)
1605         B::IO   io
1606
1607 B::GV
1608 IoBOTTOM_GV(io)
1609         B::IO   io
1610
1611 short
1612 IoSUBPROCESS(io)
1613         B::IO   io
1614
1615 bool
1616 IsSTD(io,name)
1617         B::IO   io
1618         const char*     name
1619     PREINIT:
1620         PerlIO* handle = 0;
1621     CODE:
1622         if( strEQ( name, "stdin" ) ) {
1623             handle = PerlIO_stdin();
1624         }
1625         else if( strEQ( name, "stdout" ) ) {
1626             handle = PerlIO_stdout();
1627         }
1628         else if( strEQ( name, "stderr" ) ) {
1629             handle = PerlIO_stderr();
1630         }
1631         else {
1632             croak( "Invalid value '%s'", name );
1633         }
1634         RETVAL = handle == IoIFP(io);
1635     OUTPUT:
1636         RETVAL
1637
1638 MODULE = B      PACKAGE = B::IO
1639
1640 char
1641 IoTYPE(io)
1642         B::IO   io
1643
1644 U8
1645 IoFLAGS(io)
1646         B::IO   io
1647
1648 MODULE = B      PACKAGE = B::AV         PREFIX = Av
1649
1650 SSize_t
1651 AvFILL(av)
1652         B::AV   av
1653
1654 SSize_t
1655 AvMAX(av)
1656         B::AV   av
1657
1658 #if PERL_VERSION < 9
1659
1660
1661 #define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1662
1663 IV
1664 AvOFF(av)
1665         B::AV   av
1666
1667 #endif
1668
1669 void
1670 AvARRAY(av)
1671         B::AV   av
1672     PPCODE:
1673         if (AvFILL(av) >= 0) {
1674             SV **svp = AvARRAY(av);
1675             I32 i;
1676             for (i = 0; i <= AvFILL(av); i++)
1677                 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), svp[i]));
1678         }
1679
1680 void
1681 AvARRAYelt(av, idx)
1682         B::AV   av
1683         int     idx
1684     PPCODE:
1685         if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
1686             XPUSHs(make_sv_object(aTHX_ sv_newmortal(), (AvARRAY(av)[idx])));
1687         else
1688             XPUSHs(make_sv_object(aTHX_ sv_newmortal(), NULL));
1689
1690 #if PERL_VERSION < 9
1691
1692 MODULE = B      PACKAGE = B::AV
1693
1694 U8
1695 AvFLAGS(av)
1696         B::AV   av
1697
1698 #endif
1699
1700 MODULE = B      PACKAGE = B::FM         PREFIX = Fm
1701
1702 IV
1703 FmLINES(form)
1704         B::FM   form
1705
1706 MODULE = B      PACKAGE = B::CV         PREFIX = Cv
1707
1708 U32
1709 CvCONST(cv)
1710         B::CV   cv
1711
1712 B::HV
1713 CvSTASH(cv)
1714         B::CV   cv
1715
1716 B::OP
1717 CvSTART(cv)
1718         B::CV   cv
1719     CODE:
1720         RETVAL = CvISXSUB(cv) ? NULL : CvSTART(cv);
1721     OUTPUT:
1722         RETVAL
1723
1724 B::OP
1725 CvROOT(cv)
1726         B::CV   cv
1727     CODE:
1728         RETVAL = CvISXSUB(cv) ? NULL : CvROOT(cv);
1729     OUTPUT:
1730         RETVAL
1731
1732 B::GV
1733 CvGV(cv)
1734         B::CV   cv
1735
1736 char *
1737 CvFILE(cv)
1738         B::CV   cv
1739
1740 long
1741 CvDEPTH(cv)
1742         B::CV   cv
1743
1744 B::AV
1745 CvPADLIST(cv)
1746         B::CV   cv
1747
1748 B::CV
1749 CvOUTSIDE(cv)
1750         B::CV   cv
1751
1752 U32
1753 CvOUTSIDE_SEQ(cv)
1754         B::CV   cv
1755
1756 void
1757 CvXSUB(cv)
1758         B::CV   cv
1759     CODE:
1760         ST(0) = sv_2mortal(newSViv(CvISXSUB(cv) ? PTR2IV(CvXSUB(cv)) : 0));
1761
1762
1763 void
1764 CvXSUBANY(cv)
1765         B::CV   cv
1766     CODE:
1767         ST(0) = CvCONST(cv) ?
1768             make_sv_object(aTHX_ sv_newmortal(),(SV *)CvXSUBANY(cv).any_ptr) :
1769             sv_2mortal(newSViv(CvISXSUB(cv) ? CvXSUBANY(cv).any_iv : 0));
1770
1771 MODULE = B    PACKAGE = B::CV
1772
1773 U16
1774 CvFLAGS(cv)
1775       B::CV   cv
1776
1777 MODULE = B      PACKAGE = B::CV         PREFIX = cv_
1778
1779 B::SV
1780 cv_const_sv(cv)
1781         B::CV   cv
1782
1783
1784 MODULE = B      PACKAGE = B::HV         PREFIX = Hv
1785
1786 STRLEN
1787 HvFILL(hv)
1788         B::HV   hv
1789
1790 STRLEN
1791 HvMAX(hv)
1792         B::HV   hv
1793
1794 I32
1795 HvKEYS(hv)
1796         B::HV   hv
1797
1798 I32
1799 HvRITER(hv)
1800         B::HV   hv
1801
1802 char *
1803 HvNAME(hv)
1804         B::HV   hv
1805
1806 #if PERL_VERSION < 9
1807
1808 B::PMOP
1809 HvPMROOT(hv)
1810         B::HV   hv
1811
1812 #endif
1813
1814 void
1815 HvARRAY(hv)
1816         B::HV   hv
1817     PPCODE:
1818         if (HvKEYS(hv) > 0) {
1819             SV *sv;
1820             char *key;
1821             I32 len;
1822             (void)hv_iterinit(hv);
1823             EXTEND(sp, HvKEYS(hv) * 2);
1824             while ((sv = hv_iternextsv(hv, &key, &len))) {
1825                 PUSHs(newSVpvn(key, len));
1826                 PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv));
1827             }
1828         }