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(rx));
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::REGEXP       sv
1516     CODE:
1517         /* FIXME - can we code this method more efficiently?  */
1518         RETVAL = PTR2IV(sv);
1519     OUTPUT:
1520         RETVAL
1521
1522 SV*
1523 precomp(sv)
1524         B::REGEXP       sv
1525     CODE:
1526         RETVAL = newSVpvn( RX_PRECOMP(sv), RX_PRELEN(sv) );
1527     OUTPUT:
1528         RETVAL
1529
1530 #endif
1531
1532 #define MgMOREMAGIC(mg) mg->mg_moremagic
1533 #define MgPRIVATE(mg) mg->mg_private
1534 #define MgTYPE(mg) mg->mg_type
1535 #define MgFLAGS(mg) mg->mg_flags
1536 #define MgOBJ(mg) mg->mg_obj
1537 #define MgLENGTH(mg) mg->mg_len
1538 #define MgREGEX(mg) PTR2IV(mg->mg_obj)
1539
1540 MODULE = B      PACKAGE = B::MAGIC      PREFIX = Mg
1541
1542 B::MAGIC
1543 MgMOREMAGIC(mg)
1544         B::MAGIC        mg
1545      CODE:
1546         if( MgMOREMAGIC(mg) ) {
1547             RETVAL = MgMOREMAGIC(mg);
1548         }
1549         else {
1550             XSRETURN_UNDEF;
1551         }
1552      OUTPUT:
1553         RETVAL
1554
1555 U16
1556 MgPRIVATE(mg)
1557         B::MAGIC        mg
1558
1559 char
1560 MgTYPE(mg)
1561         B::MAGIC        mg
1562
1563 U8
1564 MgFLAGS(mg)
1565         B::MAGIC        mg
1566
1567 B::SV
1568 MgOBJ(mg)
1569         B::MAGIC        mg
1570
1571 IV
1572 MgREGEX(mg)
1573         B::MAGIC        mg
1574     CODE:
1575         if(mg->mg_type == PERL_MAGIC_qr) {
1576             RETVAL = MgREGEX(mg);
1577         }
1578         else {
1579             croak( "REGEX is only meaningful on r-magic" );
1580         }
1581     OUTPUT:
1582         RETVAL
1583
1584 SV*
1585 precomp(mg)
1586         B::MAGIC        mg
1587     CODE:
1588         if (mg->mg_type == PERL_MAGIC_qr) {
1589             REGEXP* rx = (REGEXP*)mg->mg_obj;
1590             RETVAL = Nullsv;
1591             if( rx )
1592                 RETVAL = newSVpvn( RX_PRECOMP(rx), RX_PRELEN(rx) );
1593         }
1594         else {
1595             croak( "precomp is only meaningful on r-magic" );
1596         }
1597     OUTPUT:
1598         RETVAL
1599
1600 I32
1601 MgLENGTH(mg)
1602         B::MAGIC        mg
1603
1604 void
1605 MgPTR(mg)
1606         B::MAGIC        mg
1607     CODE:
1608         ST(0) = sv_newmortal();
1609         if (mg->mg_ptr){
1610                 if (mg->mg_len >= 0){
1611                         sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len);
1612                 } else if (mg->mg_len == HEf_SVKEY) {
1613                         ST(0) = make_sv_object(aTHX_
1614                                     sv_newmortal(), (SV*)mg->mg_ptr);
1615                 }
1616         }
1617
1618 MODULE = B      PACKAGE = B::PVLV       PREFIX = Lv
1619
1620 U32
1621 LvTARGOFF(sv)
1622         B::PVLV sv
1623
1624 U32
1625 LvTARGLEN(sv)
1626         B::PVLV sv
1627
1628 char
1629 LvTYPE(sv)
1630         B::PVLV sv
1631
1632 B::SV
1633 LvTARG(sv)
1634         B::PVLV sv
1635
1636 MODULE = B      PACKAGE = B::BM         PREFIX = Bm
1637
1638 I32
1639 BmUSEFUL(sv)
1640         B::BM   sv
1641
1642 U32
1643 BmPREVIOUS(sv)
1644         B::BM   sv
1645
1646 U8
1647 BmRARE(sv)
1648         B::BM   sv
1649
1650 void
1651 BmTABLE(sv)
1652         B::BM   sv
1653         STRLEN  len = NO_INIT
1654         char *  str = NO_INIT
1655     CODE:
1656         str = SvPV(sv, len);
1657         /* Boyer-Moore table is just after string and its safety-margin \0 */
1658         ST(0) = sv_2mortal(newSVpvn(str + len + PERL_FBM_TABLE_OFFSET, 256));
1659
1660 MODULE = B      PACKAGE = B::GV         PREFIX = Gv
1661
1662 void
1663 GvNAME(gv)
1664         B::GV   gv
1665     CODE:
1666         ST(0) = sv_2mortal(newSVpvn(GvNAME(gv), GvNAMELEN(gv)));
1667
1668 bool
1669 is_empty(gv)
1670         B::GV   gv
1671     CODE:
1672         RETVAL = GvGP(gv) == Null(GP*);
1673     OUTPUT:
1674         RETVAL
1675
1676 bool
1677 isGV_with_GP(gv)
1678         B::GV   gv
1679     CODE:
1680 #if PERL_VERSION >= 9
1681         RETVAL = isGV_with_GP(gv) ? TRUE : FALSE;
1682 #else
1683         RETVAL = TRUE; /* In 5.8 and earlier they all are.  */
1684 #endif
1685     OUTPUT:
1686         RETVAL
1687
1688 void*
1689 GvGP(gv)
1690         B::GV   gv
1691
1692 B::HV
1693 GvSTASH(gv)
1694         B::GV   gv
1695
1696 B::SV
1697 GvSV(gv)
1698         B::GV   gv
1699
1700 B::IO
1701 GvIO(gv)
1702         B::GV   gv
1703
1704 B::FM
1705 GvFORM(gv)
1706         B::GV   gv
1707     CODE:
1708         RETVAL = (SV*)GvFORM(gv);
1709     OUTPUT:
1710         RETVAL
1711
1712 B::AV
1713 GvAV(gv)
1714         B::GV   gv
1715
1716 B::HV
1717 GvHV(gv)
1718         B::GV   gv
1719
1720 B::GV
1721 GvEGV(gv)
1722         B::GV   gv
1723
1724 B::CV
1725 GvCV(gv)
1726         B::GV   gv
1727
1728 U32
1729 GvCVGEN(gv)
1730         B::GV   gv
1731
1732 U32
1733 GvLINE(gv)
1734         B::GV   gv
1735
1736 char *
1737 GvFILE(gv)
1738         B::GV   gv
1739
1740 B::GV
1741 GvFILEGV(gv)
1742         B::GV   gv
1743
1744 MODULE = B      PACKAGE = B::GV
1745
1746 U32
1747 GvREFCNT(gv)
1748         B::GV   gv
1749
1750 U8
1751 GvFLAGS(gv)
1752         B::GV   gv
1753
1754 MODULE = B      PACKAGE = B::IO         PREFIX = Io
1755
1756 long
1757 IoLINES(io)
1758         B::IO   io
1759
1760 long
1761 IoPAGE(io)
1762         B::IO   io
1763
1764 long
1765 IoPAGE_LEN(io)
1766         B::IO   io
1767
1768 long
1769 IoLINES_LEFT(io)
1770         B::IO   io
1771
1772 char *
1773 IoTOP_NAME(io)
1774         B::IO   io
1775
1776 B::GV
1777 IoTOP_GV(io)
1778         B::IO   io
1779
1780 char *
1781 IoFMT_NAME(io)
1782         B::IO   io
1783
1784 B::GV
1785 IoFMT_GV(io)
1786         B::IO   io
1787
1788 char *
1789 IoBOTTOM_NAME(io)
1790         B::IO   io
1791
1792 B::GV
1793 IoBOTTOM_GV(io)
1794         B::IO   io
1795
1796 #if PERL_VERSION <= 8
1797
1798 short
1799 IoSUBPROCESS(io)
1800         B::IO   io
1801
1802 #endif
1803
1804 bool
1805 IsSTD(io,name)
1806         B::IO   io
1807         const char*     name
1808     PREINIT:
1809         PerlIO* handle = 0;
1810     CODE:
1811         if( strEQ( name, "stdin" ) ) {
1812             handle = PerlIO_stdin();
1813         }
1814         else if( strEQ( name, "stdout" ) ) {
1815             handle = PerlIO_stdout();
1816         }
1817         else if( strEQ( name, "stderr" ) ) {
1818             handle = PerlIO_stderr();
1819         }
1820         else {
1821             croak( "Invalid value '%s'", name );
1822         }
1823         RETVAL = handle == IoIFP(io);
1824     OUTPUT:
1825         RETVAL
1826
1827 MODULE = B      PACKAGE = B::IO
1828
1829 char
1830 IoTYPE(io)
1831         B::IO   io
1832
1833 U8
1834 IoFLAGS(io)
1835         B::IO   io
1836
1837 MODULE = B      PACKAGE = B::AV         PREFIX = Av
1838
1839 SSize_t
1840 AvFILL(av)
1841         B::AV   av
1842
1843 SSize_t
1844 AvMAX(av)
1845         B::AV   av
1846
1847 #if PERL_VERSION < 9
1848
1849
1850 #define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1851
1852 IV
1853 AvOFF(av)
1854         B::AV   av
1855
1856 #endif
1857
1858 void
1859 AvARRAY(av)
1860         B::AV   av
1861     PPCODE:
1862         if (AvFILL(av) >= 0) {
1863             SV **svp = AvARRAY(av);
1864             I32 i;
1865             for (i = 0; i <= AvFILL(av); i++)
1866                 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), svp[i]));
1867         }
1868
1869 void
1870 AvARRAYelt(av, idx)
1871         B::AV   av
1872         int     idx
1873     PPCODE:
1874         if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
1875             XPUSHs(make_sv_object(aTHX_ sv_newmortal(), (AvARRAY(av)[idx])));
1876         else
1877             XPUSHs(make_sv_object(aTHX_ sv_newmortal(), NULL));
1878
1879 #if PERL_VERSION < 9
1880
1881 MODULE = B      PACKAGE = B::AV
1882
1883 U8
1884 AvFLAGS(av)
1885         B::AV   av
1886
1887 #endif
1888
1889 MODULE = B      PACKAGE = B::FM         PREFIX = Fm
1890
1891 IV
1892 FmLINES(form)
1893         B::FM   form
1894
1895 MODULE = B      PACKAGE = B::CV         PREFIX = Cv
1896
1897 U32
1898 CvCONST(cv)
1899         B::CV   cv
1900
1901 B::HV
1902 CvSTASH(cv)
1903         B::CV   cv
1904
1905 B::OP
1906 CvSTART(cv)
1907         B::CV   cv
1908     CODE:
1909         RETVAL = CvISXSUB(cv) ? NULL : CvSTART(cv);
1910     OUTPUT:
1911         RETVAL
1912
1913 B::OP
1914 CvROOT(cv)
1915         B::CV   cv
1916     CODE:
1917         RETVAL = CvISXSUB(cv) ? NULL : CvROOT(cv);
1918     OUTPUT:
1919         RETVAL
1920
1921 B::GV
1922 CvGV(cv)
1923         B::CV   cv
1924
1925 char *
1926 CvFILE(cv)
1927         B::CV   cv
1928
1929 long
1930 CvDEPTH(cv)
1931         B::CV   cv
1932
1933 B::AV
1934 CvPADLIST(cv)
1935         B::CV   cv
1936
1937 B::CV
1938 CvOUTSIDE(cv)
1939         B::CV   cv
1940
1941 U32
1942 CvOUTSIDE_SEQ(cv)
1943         B::CV   cv
1944
1945 void
1946 CvXSUB(cv)
1947         B::CV   cv
1948     CODE:
1949         ST(0) = sv_2mortal(newSViv(CvISXSUB(cv) ? PTR2IV(CvXSUB(cv)) : 0));
1950
1951
1952 void
1953 CvXSUBANY(cv)
1954         B::CV   cv
1955     CODE:
1956         ST(0) = CvCONST(cv) ?
1957             make_sv_object(aTHX_ sv_newmortal(),(SV *)CvXSUBANY(cv).any_ptr) :
1958             sv_2mortal(newSViv(CvISXSUB(cv) ? CvXSUBANY(cv).any_iv : 0));
1959
1960 MODULE = B    PACKAGE = B::CV
1961
1962 U16
1963 CvFLAGS(cv)
1964       B::CV   cv
1965
1966 MODULE = B      PACKAGE = B::CV         PREFIX = cv_
1967
1968 B::SV
1969 cv_const_sv(cv)
1970         B::CV   cv
1971
1972
1973 MODULE = B      PACKAGE = B::HV         PREFIX = Hv
1974
1975 STRLEN
1976 HvFILL(hv)
1977         B::HV   hv
1978
1979 STRLEN
1980 HvMAX(hv)
1981         B::HV   hv
1982
1983 I32
1984 HvKEYS(hv)
1985         B::HV   hv
1986
1987 I32
1988 HvRITER(hv)
1989         B::HV   hv
1990
1991 char *
1992 HvNAME(hv)
1993         B::HV   hv
1994
1995 #if PERL_VERSION < 9
1996
1997 B::PMOP
1998 HvPMROOT(hv)
1999         B::HV   hv
2000
2001 #endif
2002
2003 void
2004 HvARRAY(hv)
2005         B::HV   hv
2006     PPCODE:
2007         if (HvKEYS(hv) > 0) {
2008             SV *sv;
2009             char *key;
2010             I32 len;
2011             (void)hv_iterinit(hv);
2012             EXTEND(sp, HvKEYS(hv) * 2);
2013             while ((sv = hv_iternextsv(hv, &key, &len))) {
2014                 mPUSHp(key, len);
2015                 PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv));
2016             }
2017         }
2018
2019 MODULE = B      PACKAGE = B::HE         PREFIX = He
2020
2021 B::SV
2022 HeVAL(he)
2023         B::HE he
2024
2025 U32
2026 HeHASH(he)
2027         B::HE he
2028
2029 B::SV
2030 HeSVKEY_force(he)
2031         B::HE he
2032
2033 MODULE = B      PACKAGE = B::RHE        PREFIX = RHE_
2034
2035 #if PERL_VERSION >= 9
2036
2037 SV*
2038 RHE_HASH(h)
2039         B::RHE h
2040     CODE:
2041         RETVAL = newRV( (SV*)Perl_refcounted_he_chain_2hv(aTHX_ h) );
2042     OUTPUT:
2043         RETVAL
2044
2045 #endif