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