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