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 # This used to read 257. I think that that was buggy - should have been 258.
1341 # (The "\0", the flags byte, and 256 for the table.  Not that anything
1342 # anywhere calls this method.  NWC.
1343 void
1344 SvPVBM(sv)
1345         B::PV   sv
1346     CODE:
1347         ST(0) = sv_newmortal();
1348         sv_setpvn(ST(0), SvPVX_const(sv),
1349             SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0));
1350
1351
1352 STRLEN
1353 SvLEN(sv)
1354         B::PV   sv
1355
1356 STRLEN
1357 SvCUR(sv)
1358         B::PV   sv
1359
1360 MODULE = B      PACKAGE = B::PVMG       PREFIX = Sv
1361
1362 void
1363 SvMAGIC(sv)
1364         B::PVMG sv
1365         MAGIC * mg = NO_INIT
1366     PPCODE:
1367         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
1368             XPUSHs(make_mg_object(aTHX_ sv_newmortal(), mg));
1369
1370 MODULE = B      PACKAGE = B::PVMG
1371
1372 B::HV
1373 SvSTASH(sv)
1374         B::PVMG sv
1375
1376 #define MgMOREMAGIC(mg) mg->mg_moremagic
1377 #define MgPRIVATE(mg) mg->mg_private
1378 #define MgTYPE(mg) mg->mg_type
1379 #define MgFLAGS(mg) mg->mg_flags
1380 #define MgOBJ(mg) mg->mg_obj
1381 #define MgLENGTH(mg) mg->mg_len
1382 #define MgREGEX(mg) PTR2IV(mg->mg_obj)
1383
1384 MODULE = B      PACKAGE = B::MAGIC      PREFIX = Mg
1385
1386 B::MAGIC
1387 MgMOREMAGIC(mg)
1388         B::MAGIC        mg
1389      CODE:
1390         if( MgMOREMAGIC(mg) ) {
1391             RETVAL = MgMOREMAGIC(mg);
1392         }
1393         else {
1394             XSRETURN_UNDEF;
1395         }
1396      OUTPUT:
1397         RETVAL
1398
1399 U16
1400 MgPRIVATE(mg)
1401         B::MAGIC        mg
1402
1403 char
1404 MgTYPE(mg)
1405         B::MAGIC        mg
1406
1407 U8
1408 MgFLAGS(mg)
1409         B::MAGIC        mg
1410
1411 B::SV
1412 MgOBJ(mg)
1413         B::MAGIC        mg
1414
1415 IV
1416 MgREGEX(mg)
1417         B::MAGIC        mg
1418     CODE:
1419         if(mg->mg_type == PERL_MAGIC_qr) {
1420             RETVAL = MgREGEX(mg);
1421         }
1422         else {
1423             croak( "REGEX is only meaningful on r-magic" );
1424         }
1425     OUTPUT:
1426         RETVAL
1427
1428 SV*
1429 precomp(mg)
1430         B::MAGIC        mg
1431     CODE:
1432         if (mg->mg_type == PERL_MAGIC_qr) {
1433             REGEXP* rx = (REGEXP*)mg->mg_obj;
1434             RETVAL = Nullsv;
1435             if( rx )
1436                 RETVAL = newSVpvn( rx->precomp, rx->prelen );
1437         }
1438         else {
1439             croak( "precomp is only meaningful on r-magic" );
1440         }
1441     OUTPUT:
1442         RETVAL
1443
1444 I32
1445 MgLENGTH(mg)
1446         B::MAGIC        mg
1447
1448 void
1449 MgPTR(mg)
1450         B::MAGIC        mg
1451     CODE:
1452         ST(0) = sv_newmortal();
1453         if (mg->mg_ptr){
1454                 if (mg->mg_len >= 0){
1455                         sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len);
1456                 } else if (mg->mg_len == HEf_SVKEY) {
1457                         ST(0) = make_sv_object(aTHX_
1458                                     sv_newmortal(), (SV*)mg->mg_ptr);
1459                 }
1460         }
1461
1462 MODULE = B      PACKAGE = B::PVLV       PREFIX = Lv
1463
1464 U32
1465 LvTARGOFF(sv)
1466         B::PVLV sv
1467
1468 U32
1469 LvTARGLEN(sv)
1470         B::PVLV sv
1471
1472 char
1473 LvTYPE(sv)
1474         B::PVLV sv
1475
1476 B::SV
1477 LvTARG(sv)
1478         B::PVLV sv
1479
1480 MODULE = B      PACKAGE = B::BM         PREFIX = Bm
1481
1482 I32
1483 BmUSEFUL(sv)
1484         B::BM   sv
1485
1486 U16
1487 BmPREVIOUS(sv)
1488         B::BM   sv
1489
1490 U8
1491 BmRARE(sv)
1492         B::BM   sv
1493
1494 void
1495 BmTABLE(sv)
1496         B::BM   sv
1497         STRLEN  len = NO_INIT
1498         char *  str = NO_INIT
1499     CODE:
1500         str = SvPV(sv, len);
1501         /* Boyer-Moore table is just after string and its safety-margin \0 */
1502         ST(0) = sv_2mortal(newSVpvn(str + len + PERL_FBM_TABLE_OFFSET, 256));
1503
1504 MODULE = B      PACKAGE = B::GV         PREFIX = Gv
1505
1506 void
1507 GvNAME(gv)
1508         B::GV   gv
1509     CODE:
1510         ST(0) = sv_2mortal(newSVpvn(GvNAME(gv), GvNAMELEN(gv)));
1511
1512 bool
1513 is_empty(gv)
1514         B::GV   gv
1515     CODE:
1516         RETVAL = GvGP(gv) == Null(GP*);
1517     OUTPUT:
1518         RETVAL
1519
1520 void*
1521 GvGP(gv)
1522         B::GV   gv
1523
1524 B::HV
1525 GvSTASH(gv)
1526         B::GV   gv
1527
1528 B::SV
1529 GvSV(gv)
1530         B::GV   gv
1531
1532 B::IO
1533 GvIO(gv)
1534         B::GV   gv
1535
1536 B::FM
1537 GvFORM(gv)
1538         B::GV   gv
1539     CODE:
1540         RETVAL = (SV*)GvFORM(gv);
1541     OUTPUT:
1542         RETVAL
1543
1544 B::AV
1545 GvAV(gv)
1546         B::GV   gv
1547
1548 B::HV
1549 GvHV(gv)
1550         B::GV   gv
1551
1552 B::GV
1553 GvEGV(gv)
1554         B::GV   gv
1555
1556 B::CV
1557 GvCV(gv)
1558         B::GV   gv
1559
1560 U32
1561 GvCVGEN(gv)
1562         B::GV   gv
1563
1564 U32
1565 GvLINE(gv)
1566         B::GV   gv
1567
1568 char *
1569 GvFILE(gv)
1570         B::GV   gv
1571
1572 B::GV
1573 GvFILEGV(gv)
1574         B::GV   gv
1575
1576 MODULE = B      PACKAGE = B::GV
1577
1578 U32
1579 GvREFCNT(gv)
1580         B::GV   gv
1581
1582 U8
1583 GvFLAGS(gv)
1584         B::GV   gv
1585
1586 MODULE = B      PACKAGE = B::IO         PREFIX = Io
1587
1588 long
1589 IoLINES(io)
1590         B::IO   io
1591
1592 long
1593 IoPAGE(io)
1594         B::IO   io
1595
1596 long
1597 IoPAGE_LEN(io)
1598         B::IO   io
1599
1600 long
1601 IoLINES_LEFT(io)
1602         B::IO   io
1603
1604 char *
1605 IoTOP_NAME(io)
1606         B::IO   io
1607
1608 B::GV
1609 IoTOP_GV(io)
1610         B::IO   io
1611
1612 char *
1613 IoFMT_NAME(io)
1614         B::IO   io
1615
1616 B::GV
1617 IoFMT_GV(io)
1618         B::IO   io
1619
1620 char *
1621 IoBOTTOM_NAME(io)
1622         B::IO   io
1623
1624 B::GV
1625 IoBOTTOM_GV(io)
1626         B::IO   io
1627
1628 short
1629 IoSUBPROCESS(io)
1630         B::IO   io
1631
1632 bool
1633 IsSTD(io,name)
1634         B::IO   io
1635         const char*     name
1636     PREINIT:
1637         PerlIO* handle = 0;
1638     CODE:
1639         if( strEQ( name, "stdin" ) ) {
1640             handle = PerlIO_stdin();
1641         }
1642         else if( strEQ( name, "stdout" ) ) {
1643             handle = PerlIO_stdout();
1644         }
1645         else if( strEQ( name, "stderr" ) ) {
1646             handle = PerlIO_stderr();
1647         }
1648         else {
1649             croak( "Invalid value '%s'", name );
1650         }
1651         RETVAL = handle == IoIFP(io);
1652     OUTPUT:
1653         RETVAL
1654
1655 MODULE = B      PACKAGE = B::IO
1656
1657 char
1658 IoTYPE(io)
1659         B::IO   io
1660
1661 U8
1662 IoFLAGS(io)
1663         B::IO   io
1664
1665 MODULE = B      PACKAGE = B::AV         PREFIX = Av
1666
1667 SSize_t
1668 AvFILL(av)
1669         B::AV   av
1670
1671 SSize_t
1672 AvMAX(av)
1673         B::AV   av
1674
1675 #if PERL_VERSION < 9
1676
1677
1678 #define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1679
1680 IV
1681 AvOFF(av)
1682         B::AV   av
1683
1684 #endif
1685
1686 void
1687 AvARRAY(av)
1688         B::AV   av
1689     PPCODE:
1690         if (AvFILL(av) >= 0) {
1691             SV **svp = AvARRAY(av);
1692             I32 i;
1693             for (i = 0; i <= AvFILL(av); i++)
1694                 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), svp[i]));
1695         }
1696
1697 void
1698 AvARRAYelt(av, idx)
1699         B::AV   av
1700         int     idx
1701     PPCODE:
1702         if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
1703             XPUSHs(make_sv_object(aTHX_ sv_newmortal(), (AvARRAY(av)[idx])));
1704         else
1705             XPUSHs(make_sv_object(aTHX_ sv_newmortal(), NULL));
1706
1707 #if PERL_VERSION < 9
1708
1709 MODULE = B      PACKAGE = B::AV
1710
1711 U8
1712 AvFLAGS(av)
1713         B::AV   av
1714
1715 #endif
1716
1717 MODULE = B      PACKAGE = B::FM         PREFIX = Fm
1718
1719 IV
1720 FmLINES(form)
1721         B::FM   form
1722
1723 MODULE = B      PACKAGE = B::CV         PREFIX = Cv
1724
1725 U32
1726 CvCONST(cv)
1727         B::CV   cv
1728
1729 B::HV
1730 CvSTASH(cv)
1731         B::CV   cv
1732
1733 B::OP
1734 CvSTART(cv)
1735         B::CV   cv
1736     CODE:
1737         RETVAL = CvISXSUB(cv) ? NULL : CvSTART(cv);
1738     OUTPUT:
1739         RETVAL
1740
1741 B::OP
1742 CvROOT(cv)
1743         B::CV   cv
1744     CODE:
1745         RETVAL = CvISXSUB(cv) ? NULL : CvROOT(cv);
1746     OUTPUT:
1747         RETVAL
1748
1749 B::GV
1750 CvGV(cv)
1751         B::CV   cv
1752
1753 char *
1754 CvFILE(cv)
1755         B::CV   cv
1756
1757 long
1758 CvDEPTH(cv)
1759         B::CV   cv
1760
1761 B::AV
1762 CvPADLIST(cv)
1763         B::CV   cv
1764
1765 B::CV
1766 CvOUTSIDE(cv)
1767         B::CV   cv
1768
1769 U32
1770 CvOUTSIDE_SEQ(cv)
1771         B::CV   cv
1772
1773 void
1774 CvXSUB(cv)
1775         B::CV   cv
1776     CODE:
1777         ST(0) = sv_2mortal(newSViv(CvISXSUB(cv) ? PTR2IV(CvXSUB(cv)) : 0));
1778
1779
1780 void
1781 CvXSUBANY(cv)
1782         B::CV   cv
1783     CODE:
1784         ST(0) = CvCONST(cv) ?
1785             make_sv_object(aTHX_ sv_newmortal(),(SV *)CvXSUBANY(cv).any_ptr) :
1786             sv_2mortal(newSViv(CvISXSUB(cv) ? CvXSUBANY(cv).any_iv : 0));
1787
1788 MODULE = B    PACKAGE = B::CV
1789
1790 U16
1791 CvFLAGS(cv)
1792       B::CV   cv
1793
1794 MODULE = B      PACKAGE = B::CV         PREFIX = cv_
1795
1796 B::SV
1797 cv_const_sv(cv)
1798         B::CV   cv
1799
1800
1801 MODULE = B      PACKAGE = B::HV         PREFIX = Hv
1802
1803 STRLEN
1804 HvFILL(hv)
1805         B::HV   hv
1806
1807 STRLEN
1808 HvMAX(hv)
1809         B::HV   hv
1810
1811 I32
1812 HvKEYS(hv)
1813         B::HV   hv
1814
1815 I32
1816 HvRITER(hv)
1817         B::HV   hv
1818
1819 char *
1820 HvNAME(hv)
1821         B::HV   hv
1822
1823 #if PERL_VERSION < 9
1824
1825 B::PMOP
1826 HvPMROOT(hv)
1827         B::HV   hv
1828
1829 #endif
1830
1831 void
1832 HvARRAY(hv)
1833         B::HV   hv
1834     PPCODE:
1835         if (HvKEYS(hv) > 0) {
1836             SV *sv;
1837             char *key;
1838             I32 len;
1839             (void)hv_iterinit(hv);
1840             EXTEND(sp, HvKEYS(hv) * 2);
1841             while ((sv = hv_iternextsv(hv, &key, &len))) {
1842                 PUSHs(newSVpvn(key, len));
1843                 PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv));
1844             }
1845         }
1846
1847 MODULE = B      PACKAGE = B::HE         PREFIX = He
1848
1849 B::SV
1850 HeVAL(he)
1851         B::HE he
1852
1853 U32
1854 HeHASH(he)
1855         B::HE he
1856
1857 B::SV
1858 HeSVKEY_force(he)
1859         B::HE he
1860
1861 MODULE = B      PACKAGE = B::RHE        PREFIX = RHE_
1862
1863 SV*
1864 RHE_HASH(h)
1865         B::RHE h
1866     CODE:
1867         RETVAL = newRV( (SV*)Perl_refcounted_he_chain_2hv(aTHX_ h) );
1868     OUTPUT:
1869         RETVAL