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