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