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