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)    CopLABEL(o)
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 #if PERL_VERSION >= 11
1215
1216 const char *
1217 COP_label(o)
1218         B::COP  o
1219
1220 #else
1221
1222 char *
1223 COP_label(o)
1224         B::COP  o
1225
1226 #endif
1227
1228 char *
1229 COP_stashpv(o)
1230         B::COP  o
1231
1232 B::HV
1233 COP_stash(o)
1234         B::COP  o
1235
1236 char *
1237 COP_file(o)
1238         B::COP  o
1239
1240 B::GV
1241 COP_filegv(o)
1242        B::COP  o
1243
1244
1245 U32
1246 COP_cop_seq(o)
1247         B::COP  o
1248
1249 I32
1250 COP_arybase(o)
1251         B::COP  o
1252
1253 U32
1254 COP_line(o)
1255         B::COP  o
1256
1257 #if PERL_VERSION >= 9
1258
1259 void
1260 COP_warnings(o)
1261         B::COP  o
1262         PPCODE:
1263         ST(0) = make_warnings_object(aTHX_ sv_newmortal(), o->cop_warnings);
1264         XSRETURN(1);
1265
1266 void
1267 COP_io(o)
1268         B::COP  o
1269         PPCODE:
1270         ST(0) = make_cop_io_object(aTHX_ sv_newmortal(), o);
1271         XSRETURN(1);
1272
1273 B::RHE
1274 COP_hints_hash(o)
1275         B::COP o
1276     CODE:
1277         RETVAL = o->cop_hints_hash;
1278     OUTPUT:
1279         RETVAL
1280
1281 #else
1282
1283 B::SV
1284 COP_warnings(o)
1285         B::COP  o
1286
1287 B::SV
1288 COP_io(o)
1289         B::COP  o
1290
1291 #endif
1292
1293 U32
1294 COP_hints(o)
1295         B::COP  o
1296
1297 MODULE = B      PACKAGE = B::SV
1298
1299 U32
1300 SvTYPE(sv)
1301         B::SV   sv
1302
1303 #define object_2svref(sv)       sv
1304 #define SVREF SV *
1305
1306 SVREF
1307 object_2svref(sv)
1308         B::SV   sv
1309
1310 MODULE = B      PACKAGE = B::SV         PREFIX = Sv
1311
1312 U32
1313 SvREFCNT(sv)
1314         B::SV   sv
1315
1316 U32
1317 SvFLAGS(sv)
1318         B::SV   sv
1319
1320 U32
1321 SvPOK(sv)
1322         B::SV   sv
1323
1324 U32
1325 SvROK(sv)
1326         B::SV   sv
1327
1328 U32
1329 SvMAGICAL(sv)
1330         B::SV   sv
1331
1332 MODULE = B      PACKAGE = B::IV         PREFIX = Sv
1333
1334 IV
1335 SvIV(sv)
1336         B::IV   sv
1337
1338 IV
1339 SvIVX(sv)
1340         B::IV   sv
1341
1342 UV
1343 SvUVX(sv)
1344         B::IV   sv
1345
1346
1347 MODULE = B      PACKAGE = B::IV
1348
1349 #define needs64bits(sv) ((I32)SvIVX(sv) != SvIVX(sv))
1350
1351 int
1352 needs64bits(sv)
1353         B::IV   sv
1354
1355 void
1356 packiv(sv)
1357         B::IV   sv
1358     CODE:
1359         if (sizeof(IV) == 8) {
1360             U32 wp[2];
1361             const IV iv = SvIVX(sv);
1362             /*
1363              * The following way of spelling 32 is to stop compilers on
1364              * 32-bit architectures from moaning about the shift count
1365              * being >= the width of the type. Such architectures don't
1366              * reach this code anyway (unless sizeof(IV) > 8 but then
1367              * everything else breaks too so I'm not fussed at the moment).
1368              */
1369 #ifdef UV_IS_QUAD
1370             wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1371 #else
1372             wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1373 #endif
1374             wp[1] = htonl(iv & 0xffffffff);
1375             ST(0) = sv_2mortal(newSVpvn((char *)wp, 8));
1376         } else {
1377             U32 w = htonl((U32)SvIVX(sv));
1378             ST(0) = sv_2mortal(newSVpvn((char *)&w, 4));
1379         }
1380
1381
1382 #if PERL_VERSION >= 11
1383
1384 B::SV
1385 RV(sv)
1386         B::IV   sv
1387     CODE:
1388         if( SvROK(sv) ) {
1389             RETVAL = SvRV(sv);
1390         }
1391         else {
1392             croak( "argument is not SvROK" );
1393         }
1394     OUTPUT:
1395         RETVAL
1396
1397 #endif
1398
1399 MODULE = B      PACKAGE = B::NV         PREFIX = Sv
1400
1401 NV
1402 SvNV(sv)
1403         B::NV   sv
1404
1405 NV
1406 SvNVX(sv)
1407         B::NV   sv
1408
1409 U32
1410 COP_SEQ_RANGE_LOW(sv)
1411         B::NV   sv
1412
1413 U32
1414 COP_SEQ_RANGE_HIGH(sv)
1415         B::NV   sv
1416
1417 U32
1418 PARENT_PAD_INDEX(sv)
1419         B::NV   sv
1420
1421 U32
1422 PARENT_FAKELEX_FLAGS(sv)
1423         B::NV   sv
1424
1425 #if PERL_VERSION < 11
1426
1427 MODULE = B      PACKAGE = B::RV         PREFIX = Sv
1428
1429 B::SV
1430 SvRV(sv)
1431         B::RV   sv
1432
1433 #endif
1434
1435 MODULE = B      PACKAGE = B::PV         PREFIX = Sv
1436
1437 char*
1438 SvPVX(sv)
1439         B::PV   sv
1440
1441 B::SV
1442 SvRV(sv)
1443         B::PV   sv
1444     CODE:
1445         if( SvROK(sv) ) {
1446             RETVAL = SvRV(sv);
1447         }
1448         else {
1449             croak( "argument is not SvROK" );
1450         }
1451     OUTPUT:
1452         RETVAL
1453
1454 void
1455 SvPV(sv)
1456         B::PV   sv
1457     CODE:
1458         ST(0) = sv_newmortal();
1459         if( SvPOK(sv) ) {
1460             /* FIXME - we need a better way for B to identify PVs that are
1461                in the pads as variable names.  */
1462             if((SvLEN(sv) && SvCUR(sv) >= SvLEN(sv))) {
1463                 /* It claims to be longer than the space allocated for it -
1464                    presuambly it's a variable name in the pad  */
1465                 sv_setpv(ST(0), SvPV_nolen_const(sv));
1466             } else {
1467                 sv_setpvn(ST(0), SvPVX_const(sv), SvCUR(sv));
1468             }
1469             SvFLAGS(ST(0)) |= SvUTF8(sv);
1470         }
1471         else {
1472             /* XXX for backward compatibility, but should fail */
1473             /* croak( "argument is not SvPOK" ); */
1474             sv_setpvn(ST(0), NULL, 0);
1475         }
1476
1477 # This used to read 257. I think that that was buggy - should have been 258.
1478 # (The "\0", the flags byte, and 256 for the table.  Not that anything
1479 # anywhere calls this method.  NWC.
1480 void
1481 SvPVBM(sv)
1482         B::PV   sv
1483     CODE:
1484         ST(0) = sv_newmortal();
1485         sv_setpvn(ST(0), SvPVX_const(sv),
1486             SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0));
1487
1488
1489 STRLEN
1490 SvLEN(sv)
1491         B::PV   sv
1492
1493 STRLEN
1494 SvCUR(sv)
1495         B::PV   sv
1496
1497 MODULE = B      PACKAGE = B::PVMG       PREFIX = Sv
1498
1499 void
1500 SvMAGIC(sv)
1501         B::PVMG sv
1502         MAGIC * mg = NO_INIT
1503     PPCODE:
1504         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
1505             XPUSHs(make_mg_object(aTHX_ sv_newmortal(), mg));
1506
1507 MODULE = B      PACKAGE = B::PVMG
1508
1509 B::HV
1510 SvSTASH(sv)
1511         B::PVMG sv
1512
1513 MODULE = B      PACKAGE = B::REGEXP
1514
1515 #if PERL_VERSION >= 11
1516
1517 IV
1518 REGEX(sv)
1519         B::REGEXP       sv
1520     CODE:
1521         /* FIXME - can we code this method more efficiently?  */
1522         RETVAL = PTR2IV(sv);
1523     OUTPUT:
1524         RETVAL
1525
1526 SV*
1527 precomp(sv)
1528         B::REGEXP       sv
1529     CODE:
1530         RETVAL = newSVpvn( RX_PRECOMP(sv), RX_PRELEN(sv) );
1531     OUTPUT:
1532         RETVAL
1533
1534 #endif
1535
1536 #define MgMOREMAGIC(mg) mg->mg_moremagic
1537 #define MgPRIVATE(mg) mg->mg_private
1538 #define MgTYPE(mg) mg->mg_type
1539 #define MgFLAGS(mg) mg->mg_flags
1540 #define MgOBJ(mg) mg->mg_obj
1541 #define MgLENGTH(mg) mg->mg_len
1542 #define MgREGEX(mg) PTR2IV(mg->mg_obj)
1543
1544 MODULE = B      PACKAGE = B::MAGIC      PREFIX = Mg
1545
1546 B::MAGIC
1547 MgMOREMAGIC(mg)
1548         B::MAGIC        mg
1549      CODE:
1550         if( MgMOREMAGIC(mg) ) {
1551             RETVAL = MgMOREMAGIC(mg);
1552         }
1553         else {
1554             XSRETURN_UNDEF;
1555         }
1556      OUTPUT:
1557         RETVAL
1558
1559 U16
1560 MgPRIVATE(mg)
1561         B::MAGIC        mg
1562
1563 char
1564 MgTYPE(mg)
1565         B::MAGIC        mg
1566
1567 U8
1568 MgFLAGS(mg)
1569         B::MAGIC        mg
1570
1571 B::SV
1572 MgOBJ(mg)
1573         B::MAGIC        mg
1574
1575 IV
1576 MgREGEX(mg)
1577         B::MAGIC        mg
1578     CODE:
1579         if(mg->mg_type == PERL_MAGIC_qr) {
1580             RETVAL = MgREGEX(mg);
1581         }
1582         else {
1583             croak( "REGEX is only meaningful on r-magic" );
1584         }
1585     OUTPUT:
1586         RETVAL
1587
1588 SV*
1589 precomp(mg)
1590         B::MAGIC        mg
1591     CODE:
1592         if (mg->mg_type == PERL_MAGIC_qr) {
1593             REGEXP* rx = (REGEXP*)mg->mg_obj;
1594             RETVAL = Nullsv;
1595             if( rx )
1596                 RETVAL = newSVpvn( RX_PRECOMP(rx), RX_PRELEN(rx) );
1597         }
1598         else {
1599             croak( "precomp is only meaningful on r-magic" );
1600         }
1601     OUTPUT:
1602         RETVAL
1603
1604 I32
1605 MgLENGTH(mg)
1606         B::MAGIC        mg
1607
1608 void
1609 MgPTR(mg)
1610         B::MAGIC        mg
1611     CODE:
1612         ST(0) = sv_newmortal();
1613         if (mg->mg_ptr){
1614                 if (mg->mg_len >= 0){
1615                         sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len);
1616                 } else if (mg->mg_len == HEf_SVKEY) {
1617                         ST(0) = make_sv_object(aTHX_
1618                                     sv_newmortal(), (SV*)mg->mg_ptr);
1619                 }
1620         }
1621
1622 MODULE = B      PACKAGE = B::PVLV       PREFIX = Lv
1623
1624 U32
1625 LvTARGOFF(sv)
1626         B::PVLV sv
1627
1628 U32
1629 LvTARGLEN(sv)
1630         B::PVLV sv
1631
1632 char
1633 LvTYPE(sv)
1634         B::PVLV sv
1635
1636 B::SV
1637 LvTARG(sv)
1638         B::PVLV sv
1639
1640 MODULE = B      PACKAGE = B::BM         PREFIX = Bm
1641
1642 I32
1643 BmUSEFUL(sv)
1644         B::BM   sv
1645
1646 U32
1647 BmPREVIOUS(sv)
1648         B::BM   sv
1649
1650 U8
1651 BmRARE(sv)
1652         B::BM   sv
1653
1654 void
1655 BmTABLE(sv)
1656         B::BM   sv
1657         STRLEN  len = NO_INIT
1658         char *  str = NO_INIT
1659     CODE:
1660         str = SvPV(sv, len);
1661         /* Boyer-Moore table is just after string and its safety-margin \0 */
1662         ST(0) = sv_2mortal(newSVpvn(str + len + PERL_FBM_TABLE_OFFSET, 256));
1663
1664 MODULE = B      PACKAGE = B::GV         PREFIX = Gv
1665
1666 void
1667 GvNAME(gv)
1668         B::GV   gv
1669     CODE:
1670         ST(0) = sv_2mortal(newSVpvn(GvNAME(gv), GvNAMELEN(gv)));
1671
1672 bool
1673 is_empty(gv)
1674         B::GV   gv
1675     CODE:
1676         RETVAL = GvGP(gv) == Null(GP*);
1677     OUTPUT:
1678         RETVAL
1679
1680 bool
1681 isGV_with_GP(gv)
1682         B::GV   gv
1683     CODE:
1684 #if PERL_VERSION >= 9
1685         RETVAL = isGV_with_GP(gv) ? TRUE : FALSE;
1686 #else
1687         RETVAL = TRUE; /* In 5.8 and earlier they all are.  */
1688 #endif
1689     OUTPUT:
1690         RETVAL
1691
1692 void*
1693 GvGP(gv)
1694         B::GV   gv
1695
1696 B::HV
1697 GvSTASH(gv)
1698         B::GV   gv
1699
1700 B::SV
1701 GvSV(gv)
1702         B::GV   gv
1703
1704 B::IO
1705 GvIO(gv)
1706         B::GV   gv
1707
1708 B::FM
1709 GvFORM(gv)
1710         B::GV   gv
1711     CODE:
1712         RETVAL = (SV*)GvFORM(gv);
1713     OUTPUT:
1714         RETVAL
1715
1716 B::AV
1717 GvAV(gv)
1718         B::GV   gv
1719
1720 B::HV
1721 GvHV(gv)
1722         B::GV   gv
1723
1724 B::GV
1725 GvEGV(gv)
1726         B::GV   gv
1727
1728 B::CV
1729 GvCV(gv)
1730         B::GV   gv
1731
1732 U32
1733 GvCVGEN(gv)
1734         B::GV   gv
1735
1736 U32
1737 GvLINE(gv)
1738         B::GV   gv
1739
1740 char *
1741 GvFILE(gv)
1742         B::GV   gv
1743
1744 B::GV
1745 GvFILEGV(gv)
1746         B::GV   gv
1747
1748 MODULE = B      PACKAGE = B::GV
1749
1750 U32
1751 GvREFCNT(gv)
1752         B::GV   gv
1753
1754 U8
1755 GvFLAGS(gv)
1756         B::GV   gv
1757
1758 MODULE = B      PACKAGE = B::IO         PREFIX = Io
1759
1760 long
1761 IoLINES(io)
1762         B::IO   io
1763
1764 long
1765 IoPAGE(io)
1766         B::IO   io
1767
1768 long
1769 IoPAGE_LEN(io)
1770         B::IO   io
1771
1772 long
1773 IoLINES_LEFT(io)
1774         B::IO   io
1775
1776 char *
1777 IoTOP_NAME(io)
1778         B::IO   io
1779
1780 B::GV
1781 IoTOP_GV(io)
1782         B::IO   io
1783
1784 char *
1785 IoFMT_NAME(io)
1786         B::IO   io
1787
1788 B::GV
1789 IoFMT_GV(io)
1790         B::IO   io
1791
1792 char *
1793 IoBOTTOM_NAME(io)
1794         B::IO   io
1795
1796 B::GV
1797 IoBOTTOM_GV(io)
1798         B::IO   io
1799
1800 #if PERL_VERSION <= 8
1801
1802 short
1803 IoSUBPROCESS(io)
1804         B::IO   io
1805
1806 #endif
1807
1808 bool
1809 IsSTD(io,name)
1810         B::IO   io
1811         const char*     name
1812     PREINIT:
1813         PerlIO* handle = 0;
1814     CODE:
1815         if( strEQ( name, "stdin" ) ) {
1816             handle = PerlIO_stdin();
1817         }
1818         else if( strEQ( name, "stdout" ) ) {
1819             handle = PerlIO_stdout();
1820         }
1821         else if( strEQ( name, "stderr" ) ) {
1822             handle = PerlIO_stderr();
1823         }
1824         else {
1825             croak( "Invalid value '%s'", name );
1826         }
1827         RETVAL = handle == IoIFP(io);
1828     OUTPUT:
1829         RETVAL
1830
1831 MODULE = B      PACKAGE = B::IO
1832
1833 char
1834 IoTYPE(io)
1835         B::IO   io
1836
1837 U8
1838 IoFLAGS(io)
1839         B::IO   io
1840
1841 MODULE = B      PACKAGE = B::AV         PREFIX = Av
1842
1843 SSize_t
1844 AvFILL(av)
1845         B::AV   av
1846
1847 SSize_t
1848 AvMAX(av)
1849         B::AV   av
1850
1851 #if PERL_VERSION < 9
1852
1853
1854 #define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1855
1856 IV
1857 AvOFF(av)
1858         B::AV   av
1859
1860 #endif
1861
1862 void
1863 AvARRAY(av)
1864         B::AV   av
1865     PPCODE:
1866         if (AvFILL(av) >= 0) {
1867             SV **svp = AvARRAY(av);
1868             I32 i;
1869             for (i = 0; i <= AvFILL(av); i++)
1870                 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), svp[i]));
1871         }
1872
1873 void
1874 AvARRAYelt(av, idx)
1875         B::AV   av
1876         int     idx
1877     PPCODE:
1878         if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
1879             XPUSHs(make_sv_object(aTHX_ sv_newmortal(), (AvARRAY(av)[idx])));
1880         else
1881             XPUSHs(make_sv_object(aTHX_ sv_newmortal(), NULL));
1882
1883 #if PERL_VERSION < 9
1884
1885 MODULE = B      PACKAGE = B::AV
1886
1887 U8
1888 AvFLAGS(av)
1889         B::AV   av
1890
1891 #endif
1892
1893 MODULE = B      PACKAGE = B::FM         PREFIX = Fm
1894
1895 IV
1896 FmLINES(form)
1897         B::FM   form
1898
1899 MODULE = B      PACKAGE = B::CV         PREFIX = Cv
1900
1901 U32
1902 CvCONST(cv)
1903         B::CV   cv
1904
1905 B::HV
1906 CvSTASH(cv)
1907         B::CV   cv
1908
1909 B::OP
1910 CvSTART(cv)
1911         B::CV   cv
1912     CODE:
1913         RETVAL = CvISXSUB(cv) ? NULL : CvSTART(cv);
1914     OUTPUT:
1915         RETVAL
1916
1917 B::OP
1918 CvROOT(cv)
1919         B::CV   cv
1920     CODE:
1921         RETVAL = CvISXSUB(cv) ? NULL : CvROOT(cv);
1922     OUTPUT:
1923         RETVAL
1924
1925 B::GV
1926 CvGV(cv)
1927         B::CV   cv
1928
1929 char *
1930 CvFILE(cv)
1931         B::CV   cv
1932
1933 long
1934 CvDEPTH(cv)
1935         B::CV   cv
1936
1937 B::AV
1938 CvPADLIST(cv)
1939         B::CV   cv
1940
1941 B::CV
1942 CvOUTSIDE(cv)
1943         B::CV   cv
1944
1945 U32
1946 CvOUTSIDE_SEQ(cv)
1947         B::CV   cv
1948
1949 void
1950 CvXSUB(cv)
1951         B::CV   cv
1952     CODE:
1953         ST(0) = sv_2mortal(newSViv(CvISXSUB(cv) ? PTR2IV(CvXSUB(cv)) : 0));
1954
1955
1956 void
1957 CvXSUBANY(cv)
1958         B::CV   cv
1959     CODE:
1960         ST(0) = CvCONST(cv) ?
1961             make_sv_object(aTHX_ sv_newmortal(),(SV *)CvXSUBANY(cv).any_ptr) :
1962             sv_2mortal(newSViv(CvISXSUB(cv) ? CvXSUBANY(cv).any_iv : 0));
1963
1964 MODULE = B    PACKAGE = B::CV
1965
1966 U16
1967 CvFLAGS(cv)
1968       B::CV   cv
1969
1970 MODULE = B      PACKAGE = B::CV         PREFIX = cv_
1971
1972 B::SV
1973 cv_const_sv(cv)
1974         B::CV   cv
1975
1976
1977 MODULE = B      PACKAGE = B::HV         PREFIX = Hv
1978
1979 STRLEN
1980 HvFILL(hv)
1981         B::HV   hv
1982
1983 STRLEN
1984 HvMAX(hv)
1985         B::HV   hv
1986
1987 I32
1988 HvKEYS(hv)
1989         B::HV   hv
1990
1991 I32
1992 HvRITER(hv)
1993         B::HV   hv
1994
1995 char *
1996 HvNAME(hv)
1997         B::HV   hv
1998
1999 #if PERL_VERSION < 9
2000
2001 B::PMOP
2002 HvPMROOT(hv)
2003         B::HV   hv
2004
2005 #endif
2006
2007 void
2008 HvARRAY(hv)
2009         B::HV   hv
2010     PPCODE:
2011         if (HvKEYS(hv) > 0) {
2012             SV *sv;
2013             char *key;
2014             I32 len;
2015             (void)hv_iterinit(hv);
2016             EXTEND(sp, HvKEYS(hv) * 2);
2017             while ((sv = hv_iternextsv(hv, &key, &len))) {
2018                 mPUSHp(key, len);
2019                 PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv));
2020             }
2021         }
2022
2023 MODULE = B      PACKAGE = B::HE         PREFIX = He
2024
2025 B::SV
2026 HeVAL(he)
2027         B::HE he
2028
2029 U32
2030 HeHASH(he)
2031         B::HE he
2032
2033 B::SV
2034 HeSVKEY_force(he)
2035         B::HE he
2036
2037 MODULE = B      PACKAGE = B::RHE        PREFIX = RHE_
2038
2039 #if PERL_VERSION >= 9
2040
2041 SV*
2042 RHE_HASH(h)
2043         B::RHE h
2044     CODE:
2045         RETVAL = newRV( (SV*)Perl_refcounted_he_chain_2hv(aTHX_ h) );
2046     OUTPUT:
2047         RETVAL
2048
2049 #endif