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 char *svclassnames[] = {
  23     "B::NULL",
  24     "B::IV",
  25     "B::NV",
  26     "B::RV",
  27     "B::PV",
  28     "B::PVIV",
  29     "B::PVNV",
  30     "B::PVMG",
  31     "B::BM",
  32     "B::PVLV",
  33     "B::AV",
  34     "B::HV",
  35     "B::CV",
  36     "B::GV",
  37     "B::FM",
  38     "B::IO",
  39 };
  40
  41 typedef enum {
  42     OPc_NULL,   /* 0 */
  43     OPc_BASEOP, /* 1 */
  44     OPc_UNOP,   /* 2 */
  45     OPc_BINOP,  /* 3 */
  46     OPc_LOGOP,  /* 4 */
  47     OPc_LISTOP, /* 5 */
  48     OPc_PMOP,   /* 6 */
  49     OPc_SVOP,   /* 7 */
  50     OPc_PADOP,  /* 8 */
  51     OPc_PVOP,   /* 9 */
  52     OPc_CVOP,   /* 10 */
  53     OPc_LOOP,   /* 11 */
  54     OPc_COP     /* 12 */
  55 } opclass;
  56
  57 static char *opclassnames[] = {
  58     "B::NULL",
  59     "B::OP",
  60     "B::UNOP",
  61     "B::BINOP",
  62     "B::LOGOP",
  63     "B::LISTOP",
  64     "B::PMOP",
  65     "B::SVOP",
  66     "B::PADOP",
  67     "B::PVOP",
  68     "B::CVOP",
  69     "B::LOOP",
  70     "B::COP"
  71 };
  72
  73 #define MY_CXT_KEY "B::_guts" XS_VERSION
  74
  75 typedef struct {
  76     int         x_walkoptree_debug;     /* Flag for walkoptree debug hook */
  77     SV *        x_specialsv_list[7];
  78 } my_cxt_t;
  79
  80 START_MY_CXT
  81
  82 #define walkoptree_debug        (MY_CXT.x_walkoptree_debug)
  83 #define specialsv_list          (MY_CXT.x_specialsv_list)
  84
  85 static opclass
  86 cc_opclass(pTHX_ OP *o)
  87 {
  88     if (!o)
  89         return OPc_NULL;
  90
  91     if (o->op_type == 0)
  92         return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
  93
  94     if (o->op_type == OP_SASSIGN)
  95         return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
  96
  97 #ifdef USE_ITHREADS
  98     if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST)
  99         return OPc_PADOP;
 100 #endif
 101
 102     switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
 103     case OA_BASEOP:
 104         return OPc_BASEOP;
 105
 106     case OA_UNOP:
 107         return OPc_UNOP;
 108
 109     case OA_BINOP:
 110         return OPc_BINOP;
 111
 112     case OA_LOGOP:
 113         return OPc_LOGOP;
 114
 115     case OA_LISTOP:
 116         return OPc_LISTOP;
 117
 118     case OA_PMOP:
 119         return OPc_PMOP;
 120
 121     case OA_SVOP:
 122         return OPc_SVOP;
 123
 124     case OA_PADOP:
 125         return OPc_PADOP;
 126
 127     case OA_PVOP_OR_SVOP:
 128         /*
 129          * Character translations (tr///) are usually a PVOP, keeping a
 130          * pointer to a table of shorts used to look up translations.
 131          * Under utf8, however, a simple table isn't practical; instead,
 132          * the OP is an SVOP, and the SV is a reference to a swash
 133          * (i.e., an RV pointing to an HV).
 134          */
 135         return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
 136                 ? OPc_SVOP : OPc_PVOP;
 137
 138     case OA_LOOP:
 139         return OPc_LOOP;
 140
 141     case OA_COP:
 142         return OPc_COP;
 143
 144     case OA_BASEOP_OR_UNOP:
 145         /*
 146          * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
 147          * whether parens were seen. perly.y uses OPf_SPECIAL to
 148          * signal whether a BASEOP had empty parens or none.
 149          * Some other UNOPs are created later, though, so the best
 150          * test is OPf_KIDS, which is set in newUNOP.
 151          */
 152         return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
 153
 154     case OA_FILESTATOP:
 155         /*
 156          * The file stat OPs are created via UNI(OP_foo) in toke.c but use
 157          * the OPf_REF flag to distinguish between OP types instead of the
 158          * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
 159          * return OPc_UNOP so that walkoptree can find our children. If
 160          * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
 161          * (no argument to the operator) it's an OP; with OPf_REF set it's
 162          * an SVOP (and op_sv is the GV for the filehandle argument).
 163          */
 164         return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
 165 #ifdef USE_ITHREADS
 166                 (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
 167 #else
 168                 (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
 169 #endif
 170     case OA_LOOPEXOP:
 171         /*
 172          * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
 173          * label was omitted (in which case it's a BASEOP) or else a term was
 174          * seen. In this last case, all except goto are definitely PVOP but
 175          * goto is either a PVOP (with an ordinary constant label), an UNOP
 176          * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
 177          * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
 178          * get set.
 179          */
 180         if (o->op_flags & OPf_STACKED)
 181             return OPc_UNOP;
 182         else if (o->op_flags & OPf_SPECIAL)
 183             return OPc_BASEOP;
 184         else
 185             return OPc_PVOP;
 186     }
 187     warn("can't determine class of operator %s, assuming BASEOP\n",
 188          PL_op_name[o->op_type]);
 189     return OPc_BASEOP;
 190 }
 191
 192 static char *
 193 cc_opclassname(pTHX_ OP *o)
 194 {
 195     return opclassnames[cc_opclass(aTHX_ o)];
 196 }
 197
 198 static SV *
 199 make_sv_object(pTHX_ SV *arg, SV *sv)
 200 {
 201     char *type = 0;
 202     IV iv;
 203     dMY_CXT;
 204
 205     for (iv = 0; iv < sizeof(specialsv_list)/sizeof(SV*); iv++) {
 206         if (sv == specialsv_list[iv]) {
 207             type = "B::SPECIAL";
 208             break;
 209         }
 210     }
 211     if (!type) {
 212         type = svclassnames[SvTYPE(sv)];
 213         iv = PTR2IV(sv);
 214     }
 215     sv_setiv(newSVrv(arg, type), iv);
 216     return arg;
 217 }
 218
 219 static SV *
 220 make_mg_object(pTHX_ SV *arg, MAGIC *mg)
 221 {
 222     sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg));
 223     return arg;
 224 }
 225
 226 static SV *
 227 cstring(pTHX_ SV *sv)
 228 {
 229     SV *sstr = newSVpvn("", 0);
 230     STRLEN len;
 231     char *s;
 232     char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
 233
 234     if (!SvOK(sv))
 235         sv_setpvn(sstr, "0", 1);
 236     else
 237     {
 238         /* XXX Optimise? */
 239         s = SvPV(sv, len);
 240         sv_catpv(sstr, "\"");
 241         for (; len; len--, s++)
 242         {
 243             /* At least try a little for readability */
 244             if (*s == '"')
 245                 sv_catpv(sstr, "\\\"");
 246             else if (*s == '\\')
 247                 sv_catpv(sstr, "\\\\");
 248             /* trigraphs - bleagh */
 249             else if (*s == '?' && len>=3 && s[1] == '?')
 250             {
 251                 sprintf(escbuff, "\\%03o", '?');
 252                 sv_catpv(sstr, escbuff);
 253             }
 254             else if (*s >= ' ' && *s < 127) /* XXX not portable */
 255                 sv_catpvn(sstr, s, 1);
 256             else if (*s == '\n')
 257                 sv_catpv(sstr, "\\n");
 258             else if (*s == '\r')
 259                 sv_catpv(sstr, "\\r");
 260             else if (*s == '\t')
 261                 sv_catpv(sstr, "\\t");
 262             else if (*s == '\a')
 263                 sv_catpv(sstr, "\\a");
 264             else if (*s == '\b')
 265                 sv_catpv(sstr, "\\b");
 266             else if (*s == '\f')
 267                 sv_catpv(sstr, "\\f");
 268             else if (*s == '\v')
 269                 sv_catpv(sstr, "\\v");
 270             else
 271             {
 272                 /* Don't want promotion of a signed -1 char in sprintf args */
 273                 unsigned char c = (unsigned char) *s;
 274                 sprintf(escbuff, "\\%03o", c);
 275                 sv_catpv(sstr, escbuff);
 276             }
 277             /* XXX Add line breaks if string is long */
 278         }
 279         sv_catpv(sstr, "\"");
 280     }
 281     return sstr;
 282 }
 283
 284 static SV *
 285 cchar(pTHX_ SV *sv)
 286 {
 287     SV *sstr = newSVpvn("'", 1);
 288     STRLEN n_a;
 289     char *s = SvPV(sv, n_a);
 290
 291     if (*s == '\'')
 292         sv_catpv(sstr, "\\'");
 293     else if (*s == '\\')
 294         sv_catpv(sstr, "\\\\");
 295     else if (*s >= ' ' && *s < 127) /* XXX not portable */
 296         sv_catpvn(sstr, s, 1);
 297     else if (*s == '\n')
 298         sv_catpv(sstr, "\\n");
 299     else if (*s == '\r')
 300         sv_catpv(sstr, "\\r");
 301     else if (*s == '\t')
 302         sv_catpv(sstr, "\\t");
 303     else if (*s == '\a')
 304         sv_catpv(sstr, "\\a");
 305     else if (*s == '\b')
 306         sv_catpv(sstr, "\\b");
 307     else if (*s == '\f')
 308         sv_catpv(sstr, "\\f");
 309     else if (*s == '\v')
 310         sv_catpv(sstr, "\\v");
 311     else
 312     {
 313         /* no trigraph support */
 314         char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
 315         /* Don't want promotion of a signed -1 char in sprintf args */
 316         unsigned char c = (unsigned char) *s;
 317         sprintf(escbuff, "\\%03o", c);
 318         sv_catpv(sstr, escbuff);
 319     }
 320     sv_catpv(sstr, "'");
 321     return sstr;
 322 }
 323
 324 void
 325 walkoptree(pTHX_ SV *opsv, char *method)
 326 {
 327     dSP;
 328     OP *o;
 329     dMY_CXT;
 330
 331     if (!SvROK(opsv))
 332         croak("opsv is not a reference");
 333     opsv = sv_mortalcopy(opsv);
 334     o = INT2PTR(OP*,SvIV((SV*)SvRV(opsv)));
 335     if (walkoptree_debug) {
 336         PUSHMARK(sp);
 337         XPUSHs(opsv);
 338         PUTBACK;
 339         perl_call_method("walkoptree_debug", G_DISCARD);
 340     }
 341     PUSHMARK(sp);
 342     XPUSHs(opsv);
 343     PUTBACK;
 344     perl_call_method(method, G_DISCARD);
 345     if (o && (o->op_flags & OPf_KIDS)) {
 346         OP *kid;
 347         for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) {
 348             /* Use the same opsv. Rely on methods not to mess it up. */
 349             sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
 350             walkoptree(aTHX_ opsv, method);
 351         }
 352     }
 353 }
 354
 355 typedef OP      *B__OP;
 356 typedef UNOP    *B__UNOP;
 357 typedef BINOP   *B__BINOP;
 358 typedef LOGOP   *B__LOGOP;
 359 typedef LISTOP  *B__LISTOP;
 360 typedef PMOP    *B__PMOP;
 361 typedef SVOP    *B__SVOP;
 362 typedef PADOP   *B__PADOP;
 363 typedef PVOP    *B__PVOP;
 364 typedef LOOP    *B__LOOP;
 365 typedef COP     *B__COP;
 366
 367 typedef SV      *B__SV;
 368 typedef SV      *B__IV;
 369 typedef SV      *B__PV;
 370 typedef SV      *B__NV;
 371 typedef SV      *B__PVMG;
 372 typedef SV      *B__PVLV;
 373 typedef SV      *B__BM;
 374 typedef SV      *B__RV;
 375 typedef AV      *B__AV;
 376 typedef HV      *B__HV;
 377 typedef CV      *B__CV;
 378 typedef GV      *B__GV;
 379 typedef IO      *B__IO;
 380
 381 typedef MAGIC   *B__MAGIC;
 382
 383 MODULE = B      PACKAGE = B     PREFIX = B_
 384
 385 PROTOTYPES: DISABLE
 386
 387 BOOT:
 388 {
 389     HV *stash = gv_stashpvn("B", 1, TRUE);
 390     AV *export_ok = perl_get_av("B::EXPORT_OK",TRUE);
 391     MY_CXT_INIT;
 392     specialsv_list[0] = Nullsv;
 393     specialsv_list[1] = &PL_sv_undef;
 394     specialsv_list[2] = &PL_sv_yes;
 395     specialsv_list[3] = &PL_sv_no;
 396     specialsv_list[4] = pWARN_ALL;
 397     specialsv_list[5] = pWARN_NONE;
 398     specialsv_list[6] = pWARN_STD;
 399 #include "defsubs.h"
 400 }
 401
 402 #define B_main_cv()     PL_main_cv
 403 #define B_init_av()     PL_initav
 404 #define B_begin_av()    PL_beginav_save
 405 #define B_end_av()      PL_endav
 406 #define B_main_root()   PL_main_root
 407 #define B_main_start()  PL_main_start
 408 #define B_amagic_generation()   PL_amagic_generation
 409 #define B_comppadlist() (PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv))
 410 #define B_sv_undef()    &PL_sv_undef
 411 #define B_sv_yes()      &PL_sv_yes
 412 #define B_sv_no()       &PL_sv_no
 413 #ifdef USE_ITHREADS
 414 #define B_regex_padav() PL_regex_padav
 415 #endif
 416
 417 B::AV
 418 B_init_av()
 419
 420 B::AV
 421 B_begin_av()
 422
 423 B::AV
 424 B_end_av()
 425
 426 #ifdef USE_ITHREADS
 427
 428 B::AV
 429 B_regex_padav()
 430
 431 #endif
 432
 433 B::CV
 434 B_main_cv()
 435
 436 B::OP
 437 B_main_root()
 438
 439 B::OP
 440 B_main_start()
 441
 442 long
 443 B_amagic_generation()
 444
 445 B::AV
 446 B_comppadlist()
 447
 448 B::SV
 449 B_sv_undef()
 450
 451 B::SV
 452 B_sv_yes()
 453
 454 B::SV
 455 B_sv_no()
 456
 457 MODULE = B      PACKAGE = B
 458
 459
 460 void
 461 walkoptree(opsv, method)
 462         SV *    opsv
 463         char *  method
 464     CODE:
 465         walkoptree(aTHX_ opsv, method);
 466
 467 int
 468 walkoptree_debug(...)
 469     CODE:
 470         dMY_CXT;
 471         RETVAL = walkoptree_debug;
 472         if (items > 0 && SvTRUE(ST(1)))
 473             walkoptree_debug = 1;
 474     OUTPUT:
 475         RETVAL
 476
 477 #define address(sv) PTR2IV(sv)
 478
 479 IV
 480 address(sv)
 481         SV *    sv
 482
 483 B::SV
 484 svref_2object(sv)
 485         SV *    sv
 486     CODE:
 487         if (!SvROK(sv))
 488             croak("argument is not a reference");
 489         RETVAL = (SV*)SvRV(sv);
 490     OUTPUT:
 491         RETVAL
 492
 493 void
 494 opnumber(name)
 495 char *  name
 496 CODE:
 497 {
 498  int i;
 499  IV  result = -1;
 500  ST(0) = sv_newmortal();
 501  if (strncmp(name,"pp_",3) == 0)
 502    name += 3;
 503  for (i = 0; i < PL_maxo; i++)
 504   {
 505    if (strcmp(name, PL_op_name[i]) == 0)
 506     {
 507      result = i;
 508      break;
 509     }
 510   }
 511  sv_setiv(ST(0),result);
 512 }
 513
 514 void
 515 ppname(opnum)
 516         int     opnum
 517     CODE:
 518         ST(0) = sv_newmortal();
 519         if (opnum >= 0 && opnum < PL_maxo) {
 520             sv_setpvn(ST(0), "pp_", 3);
 521             sv_catpv(ST(0), PL_op_name[opnum]);
 522         }
 523
 524 void
 525 hash(sv)
 526         SV *    sv
 527     CODE:
 528         char *s;
 529         STRLEN len;
 530         U32 hash = 0;
 531         char hexhash[19]; /* must fit "0xffffffffffffffff" plus trailing \0 */
 532         s = SvPV(sv, len);
 533         PERL_HASH(hash, s, len);
 534         sprintf(hexhash, "0x%"UVxf, (UV)hash);
 535         ST(0) = sv_2mortal(newSVpv(hexhash, 0));
 536
 537 #define cast_I32(foo) (I32)foo
 538 IV
 539 cast_I32(i)
 540         IV      i
 541
 542 void
 543 minus_c()
 544     CODE:
 545         PL_minus_c = TRUE;
 546
 547 void
 548 save_BEGINs()
 549     CODE:
 550         PL_savebegin = TRUE;
 551
 552 SV *
 553 cstring(sv)
 554         SV *    sv
 555     CODE:
 556         RETVAL = cstring(aTHX_ sv);
 557     OUTPUT:
 558         RETVAL
 559
 560 SV *
 561 cchar(sv)
 562         SV *    sv
 563     CODE:
 564         RETVAL = cchar(aTHX_ sv);
 565     OUTPUT:
 566         RETVAL
 567
 568 void
 569 threadsv_names()
 570     PPCODE:
 571 #ifdef USE_5005THREADS
 572         int i;
 573         STRLEN len = strlen(PL_threadsv_names);
 574
 575         EXTEND(sp, len);
 576         for (i = 0; i < len; i++)
 577             PUSHs(sv_2mortal(newSVpvn(&PL_threadsv_names[i], 1)));
 578 #endif
 579
 580
 581 #define OP_next(o)      o->op_next
 582 #define OP_sibling(o)   o->op_sibling
 583 #define OP_desc(o)      PL_op_desc[o->op_type]
 584 #define OP_targ(o)      o->op_targ
 585 #define OP_type(o)      o->op_type
 586 #define OP_seq(o)       o->op_seq
 587 #define OP_flags(o)     o->op_flags
 588 #define OP_private(o)   o->op_private
 589
 590 MODULE = B      PACKAGE = B::OP         PREFIX = OP_
 591
 592 B::OP
 593 OP_next(o)
 594         B::OP           o
 595
 596 B::OP
 597 OP_sibling(o)
 598         B::OP           o
 599
 600 char *
 601 OP_name(o)
 602         B::OP           o
 603     CODE:
 604         RETVAL = PL_op_name[o->op_type];
 605     OUTPUT:
 606         RETVAL
 607
 608
 609 void
 610 OP_ppaddr(o)
 611         B::OP           o
 612     PREINIT:
 613         int i;
 614         SV *sv = sv_newmortal();
 615     CODE:
 616         sv_setpvn(sv, "PL_ppaddr[OP_", 13);
 617         sv_catpv(sv, PL_op_name[o->op_type]);
 618         for (i=13; i<SvCUR(sv); ++i)
 619             SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]);
 620         sv_catpv(sv, "]");
 621         ST(0) = sv;
 622
 623 char *
 624 OP_desc(o)
 625         B::OP           o
 626
 627 PADOFFSET
 628 OP_targ(o)
 629         B::OP           o
 630
 631 U16
 632 OP_type(o)
 633         B::OP           o
 634
 635 U16
 636 OP_seq(o)
 637         B::OP           o
 638
 639 U8
 640 OP_flags(o)
 641         B::OP           o
 642
 643 U8
 644 OP_private(o)
 645         B::OP           o
 646
 647 #define UNOP_first(o)   o->op_first
 648
 649 MODULE = B      PACKAGE = B::UNOP               PREFIX = UNOP_
 650
 651 B::OP
 652 UNOP_first(o)
 653         B::UNOP o
 654
 655 #define BINOP_last(o)   o->op_last
 656
 657 MODULE = B      PACKAGE = B::BINOP              PREFIX = BINOP_
 658
 659 B::OP
 660 BINOP_last(o)
 661         B::BINOP        o
 662
 663 #define LOGOP_other(o)  o->op_other
 664
 665 MODULE = B      PACKAGE = B::LOGOP              PREFIX = LOGOP_
 666
 667 B::OP
 668 LOGOP_other(o)
 669         B::LOGOP        o
 670
 671 MODULE = B      PACKAGE = B::LISTOP             PREFIX = LISTOP_
 672
 673 U32
 674 LISTOP_children(o)
 675         B::LISTOP       o
 676         OP *            kid = NO_INIT
 677         int             i = NO_INIT
 678     CODE:
 679         i = 0;
 680         for (kid = o->op_first; kid; kid = kid->op_sibling)
 681             i++;
 682         RETVAL = i;
 683     OUTPUT:
 684         RETVAL
 685
 686 #define PMOP_pmreplroot(o)      o->op_pmreplroot
 687 #define PMOP_pmreplstart(o)     o->op_pmreplstart
 688 #define PMOP_pmnext(o)          o->op_pmnext
 689 #define PMOP_pmregexp(o)        PM_GETRE(o)
 690 #ifdef USE_ITHREADS
 691 #define PMOP_pmoffset(o)        o->op_pmoffset
 692 #endif
 693 #define PMOP_pmflags(o)         o->op_pmflags
 694 #define PMOP_pmpermflags(o)     o->op_pmpermflags
 695 #define PMOP_pmdynflags(o)      o->op_pmdynflags
 696
 697 MODULE = B      PACKAGE = B::PMOP               PREFIX = PMOP_
 698
 699 void
 700 PMOP_pmreplroot(o)
 701         B::PMOP         o
 702         OP *            root = NO_INIT
 703     CODE:
 704         ST(0) = sv_newmortal();
 705         root = o->op_pmreplroot;
 706         /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */
 707         if (o->op_type == OP_PUSHRE) {
 708 #ifdef USE_ITHREADS
 709             sv_setiv(ST(0), INT2PTR(PADOFFSET,root) );
 710 #else
 711             sv_setiv(newSVrv(ST(0), root ?
 712                              svclassnames[SvTYPE((SV*)root)] : "B::SV"),
 713                      PTR2IV(root));
 714 #endif
 715         }
 716         else {
 717             sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root));
 718         }
 719
 720 B::OP
 721 PMOP_pmreplstart(o)
 722         B::PMOP         o
 723
 724 B::PMOP
 725 PMOP_pmnext(o)
 726         B::PMOP         o
 727
 728 #ifdef USE_ITHREADS
 729
 730 IV
 731 PMOP_pmoffset(o)
 732         B::PMOP         o
 733
 734 #endif
 735
 736 U16
 737 PMOP_pmflags(o)
 738         B::PMOP         o
 739
 740 U16
 741 PMOP_pmpermflags(o)
 742         B::PMOP         o
 743
 744 U8
 745 PMOP_pmdynflags(o)
 746         B::PMOP         o
 747
 748 void
 749 PMOP_precomp(o)
 750         B::PMOP         o
 751         REGEXP *        rx = NO_INIT
 752     CODE:
 753         ST(0) = sv_newmortal();
 754         rx = PM_GETRE(o);
 755         if (rx)
 756             sv_setpvn(ST(0), rx->precomp, rx->prelen);
 757
 758 #define SVOP_sv(o)     cSVOPo->op_sv
 759 #define SVOP_gv(o)     ((GV*)cSVOPo->op_sv)
 760
 761 MODULE = B      PACKAGE = B::SVOP               PREFIX = SVOP_
 762
 763 B::SV
 764 SVOP_sv(o)
 765         B::SVOP o
 766
 767 B::GV
 768 SVOP_gv(o)
 769         B::SVOP o
 770
 771 #define PADOP_padix(o)  o->op_padix
 772 #define PADOP_sv(o)     (o->op_padix ? PL_curpad[o->op_padix] : Nullsv)
 773 #define PADOP_gv(o)     ((o->op_padix \
 774                           && SvTYPE(PL_curpad[o->op_padix]) == SVt_PVGV) \
 775                          ? (GV*)PL_curpad[o->op_padix] : Nullgv)
 776
 777 MODULE = B      PACKAGE = B::PADOP              PREFIX = PADOP_
 778
 779 PADOFFSET
 780 PADOP_padix(o)
 781         B::PADOP o
 782
 783 B::SV
 784 PADOP_sv(o)
 785         B::PADOP o
 786
 787 B::GV
 788 PADOP_gv(o)
 789         B::PADOP o
 790
 791 MODULE = B      PACKAGE = B::PVOP               PREFIX = PVOP_
 792
 793 void
 794 PVOP_pv(o)
 795         B::PVOP o
 796     CODE:
 797         /*
 798          * OP_TRANS uses op_pv to point to a table of 256 or >=258 shorts
 799          * whereas other PVOPs point to a null terminated string.
 800          */
 801         if (o->op_type == OP_TRANS &&
 802                 (o->op_private & OPpTRANS_COMPLEMENT) &&
 803                 !(o->op_private & OPpTRANS_DELETE))
 804         {
 805             short* tbl = (short*)o->op_pv;
 806             short entries = 257 + tbl[256];
 807             ST(0) = sv_2mortal(newSVpv(o->op_pv, entries * sizeof(short)));
 808         }
 809         else if (o->op_type == OP_TRANS) {
 810             ST(0) = sv_2mortal(newSVpv(o->op_pv, 256 * sizeof(short)));
 811         }
 812         else
 813             ST(0) = sv_2mortal(newSVpv(o->op_pv, 0));
 814
 815 #define LOOP_redoop(o)  o->op_redoop
 816 #define LOOP_nextop(o)  o->op_nextop
 817 #define LOOP_lastop(o)  o->op_lastop
 818
 819 MODULE = B      PACKAGE = B::LOOP               PREFIX = LOOP_
 820
 821
 822 B::OP
 823 LOOP_redoop(o)
 824         B::LOOP o
 825
 826 B::OP
 827 LOOP_nextop(o)
 828         B::LOOP o
 829
 830 B::OP
 831 LOOP_lastop(o)
 832         B::LOOP o
 833
 834 #define COP_label(o)    o->cop_label
 835 #define COP_stashpv(o)  CopSTASHPV(o)
 836 #define COP_stash(o)    CopSTASH(o)
 837 #define COP_file(o)     CopFILE(o)
 838 #define COP_cop_seq(o)  o->cop_seq
 839 #define COP_arybase(o)  o->cop_arybase
 840 #define COP_line(o)     CopLINE(o)
 841 #define COP_warnings(o) o->cop_warnings
 842
 843 MODULE = B      PACKAGE = B::COP                PREFIX = COP_
 844
 845 char *
 846 COP_label(o)
 847         B::COP  o
 848
 849 char *
 850 COP_stashpv(o)
 851         B::COP  o
 852
 853 B::HV
 854 COP_stash(o)
 855         B::COP  o
 856
 857 char *
 858 COP_file(o)
 859         B::COP  o
 860
 861 U32
 862 COP_cop_seq(o)
 863         B::COP  o
 864
 865 I32
 866 COP_arybase(o)
 867         B::COP  o
 868
 869 U16
 870 COP_line(o)
 871         B::COP  o
 872
 873 B::SV
 874 COP_warnings(o)
 875         B::COP  o
 876
 877 MODULE = B      PACKAGE = B::SV         PREFIX = Sv
 878
 879 U32
 880 SvREFCNT(sv)
 881         B::SV   sv
 882
 883 U32
 884 SvFLAGS(sv)
 885         B::SV   sv
 886
 887 MODULE = B      PACKAGE = B::IV         PREFIX = Sv
 888
 889 IV
 890 SvIV(sv)
 891         B::IV   sv
 892
 893 IV
 894 SvIVX(sv)
 895         B::IV   sv
 896
 897 UV
 898 SvUVX(sv)
 899         B::IV   sv
 900
 901
 902 MODULE = B      PACKAGE = B::IV
 903
 904 #define needs64bits(sv) ((I32)SvIVX(sv) != SvIVX(sv))
 905
 906 int
 907 needs64bits(sv)
 908         B::IV   sv
 909
 910 void
 911 packiv(sv)
 912         B::IV   sv
 913     CODE:
 914         if (sizeof(IV) == 8) {
 915             U32 wp[2];
 916             IV iv = SvIVX(sv);
 917             /*
 918              * The following way of spelling 32 is to stop compilers on
 919              * 32-bit architectures from moaning about the shift count
 920              * being >= the width of the type. Such architectures don't
 921              * reach this code anyway (unless sizeof(IV) > 8 but then
 922              * everything else breaks too so I'm not fussed at the moment).
 923              */
 924 #ifdef UV_IS_QUAD
 925             wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
 926 #else
 927             wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
 928 #endif
 929             wp[1] = htonl(iv & 0xffffffff);
 930             ST(0) = sv_2mortal(newSVpvn((char *)wp, 8));
 931         } else {
 932             U32 w = htonl((U32)SvIVX(sv));
 933             ST(0) = sv_2mortal(newSVpvn((char *)&w, 4));
 934         }
 935
 936 MODULE = B      PACKAGE = B::NV         PREFIX = Sv
 937
 938 NV
 939 SvNV(sv)
 940         B::NV   sv
 941
 942 NV
 943 SvNVX(sv)
 944         B::NV   sv
 945
 946 MODULE = B      PACKAGE = B::RV         PREFIX = Sv
 947
 948 B::SV
 949 SvRV(sv)
 950         B::RV   sv
 951
 952 MODULE = B      PACKAGE = B::PV         PREFIX = Sv
 953
 954 char*
 955 SvPVX(sv)
 956         B::PV   sv
 957
 958 B::SV
 959 SvRV(sv)
 960         B::PV   sv
 961     CODE:
 962         if( SvROK(sv) ) {
 963             RETVAL = SvRV(sv);
 964         }
 965         else {
 966             croak( "argument is not SvROK" );
 967         }
 968     OUTPUT:
 969         RETVAL
 970
 971 void
 972 SvPV(sv)
 973         B::PV   sv
 974     CODE:
 975         ST(0) = sv_newmortal();
 976         if( SvPOK(sv) ) {
 977             sv_setpvn(ST(0), SvPVX(sv), SvCUR(sv));
 978             SvFLAGS(ST(0)) |= SvUTF8(sv);
 979         }
 980         else {
 981             /* XXX for backward compatibility, but should fail */
 982             /* croak( "argument is not SvPOK" ); */
 983             sv_setpvn(ST(0), NULL, 0);
 984         }
 985
 986 STRLEN
 987 SvLEN(sv)
 988         B::PV   sv
 989
 990 STRLEN
 991 SvCUR(sv)
 992         B::PV   sv
 993
 994 MODULE = B      PACKAGE = B::PVMG       PREFIX = Sv
 995
 996 void
 997 SvMAGIC(sv)
 998         B::PVMG sv
 999         MAGIC * mg = NO_INIT
1000     PPCODE:
1001         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
1002             XPUSHs(make_mg_object(aTHX_ sv_newmortal(), mg));
1003
1004 MODULE = B      PACKAGE = B::PVMG
1005
1006 B::HV
1007 SvSTASH(sv)
1008         B::PVMG sv
1009
1010 #define MgMOREMAGIC(mg) mg->mg_moremagic
1011 #define MgPRIVATE(mg) mg->mg_private
1012 #define MgTYPE(mg) mg->mg_type
1013 #define MgFLAGS(mg) mg->mg_flags
1014 #define MgOBJ(mg) mg->mg_obj
1015 #define MgLENGTH(mg) mg->mg_len
1016 #define MgREGEX(mg) PTR2IV(mg->mg_obj)
1017
1018 MODULE = B      PACKAGE = B::MAGIC      PREFIX = Mg
1019
1020 B::MAGIC
1021 MgMOREMAGIC(mg)
1022         B::MAGIC        mg
1023
1024 U16
1025 MgPRIVATE(mg)
1026         B::MAGIC        mg
1027
1028 char
1029 MgTYPE(mg)
1030         B::MAGIC        mg
1031
1032 U8
1033 MgFLAGS(mg)
1034         B::MAGIC        mg
1035
1036 B::SV
1037 MgOBJ(mg)
1038         B::MAGIC        mg
1039     CODE:
1040         if( mg->mg_type != 'r' ) {
1041             RETVAL = MgOBJ(mg);
1042         }
1043         else {
1044             croak( "OBJ is not meaningful on r-magic" );
1045         }
1046     OUTPUT:
1047         RETVAL
1048
1049 IV
1050 MgREGEX(mg)
1051         B::MAGIC        mg
1052     CODE:
1053         if( mg->mg_type == 'r' ) {
1054             RETVAL = MgREGEX(mg);
1055         }
1056         else {
1057             croak( "REGEX is only meaningful on r-magic" );
1058         }
1059     OUTPUT:
1060         RETVAL
1061
1062 SV*
1063 precomp(mg)
1064         B::MAGIC        mg
1065     CODE:
1066         if (mg->mg_type == 'r') {
1067             REGEXP* rx = (REGEXP*)mg->mg_obj;
1068             if( rx )
1069                 RETVAL = newSVpvn( rx->precomp, rx->prelen );
1070         }
1071         else {
1072             croak( "precomp is only meaningful on r-magic" );
1073         }
1074     OUTPUT:
1075         RETVAL
1076
1077 I32
1078 MgLENGTH(mg)
1079         B::MAGIC        mg
1080
1081 void
1082 MgPTR(mg)
1083         B::MAGIC        mg
1084     CODE:
1085         ST(0) = sv_newmortal();
1086         if (mg->mg_ptr){
1087                 if (mg->mg_len >= 0){
1088                         sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len);
1089                 } else {
1090                         if (mg->mg_len == HEf_SVKEY)
1091                                 sv_setsv(ST(0),newRV((SV*)mg->mg_ptr));
1092                 }
1093         }
1094
1095 MODULE = B      PACKAGE = B::PVLV       PREFIX = Lv
1096
1097 U32
1098 LvTARGOFF(sv)
1099         B::PVLV sv
1100
1101 U32
1102 LvTARGLEN(sv)
1103         B::PVLV sv
1104
1105 char
1106 LvTYPE(sv)
1107         B::PVLV sv
1108
1109 B::SV
1110 LvTARG(sv)
1111         B::PVLV sv
1112
1113 MODULE = B      PACKAGE = B::BM         PREFIX = Bm
1114
1115 I32
1116 BmUSEFUL(sv)
1117         B::BM   sv
1118
1119 U16
1120 BmPREVIOUS(sv)
1121         B::BM   sv
1122
1123 U8
1124 BmRARE(sv)
1125         B::BM   sv
1126
1127 void
1128 BmTABLE(sv)
1129         B::BM   sv
1130         STRLEN  len = NO_INIT
1131         char *  str = NO_INIT
1132     CODE:
1133         str = SvPV(sv, len);
1134         /* Boyer-Moore table is just after string and its safety-margin \0 */
1135         ST(0) = sv_2mortal(newSVpvn(str + len + 1, 256));
1136
1137 MODULE = B      PACKAGE = B::GV         PREFIX = Gv
1138
1139 void
1140 GvNAME(gv)
1141         B::GV   gv
1142     CODE:
1143         ST(0) = sv_2mortal(newSVpvn(GvNAME(gv), GvNAMELEN(gv)));
1144
1145 bool
1146 is_empty(gv)
1147         B::GV   gv
1148     CODE:
1149         RETVAL = GvGP(gv) == Null(GP*);
1150     OUTPUT:
1151         RETVAL
1152
1153 B::HV
1154 GvSTASH(gv)
1155         B::GV   gv
1156
1157 B::SV
1158 GvSV(gv)
1159         B::GV   gv
1160
1161 B::IO
1162 GvIO(gv)
1163         B::GV   gv
1164
1165 B::CV
1166 GvFORM(gv)
1167         B::GV   gv
1168
1169 B::AV
1170 GvAV(gv)
1171         B::GV   gv
1172
1173 B::HV
1174 GvHV(gv)
1175         B::GV   gv
1176
1177 B::GV
1178 GvEGV(gv)
1179         B::GV   gv
1180
1181 B::CV
1182 GvCV(gv)
1183         B::GV   gv
1184
1185 U32
1186 GvCVGEN(gv)
1187         B::GV   gv
1188
1189 U16
1190 GvLINE(gv)
1191         B::GV   gv
1192
1193 char *
1194 GvFILE(gv)
1195         B::GV   gv
1196
1197 B::GV
1198 GvFILEGV(gv)
1199         B::GV   gv
1200
1201 MODULE = B      PACKAGE = B::GV
1202
1203 U32
1204 GvREFCNT(gv)
1205         B::GV   gv
1206
1207 U8
1208 GvFLAGS(gv)
1209         B::GV   gv
1210
1211 MODULE = B      PACKAGE = B::IO         PREFIX = Io
1212
1213 long
1214 IoLINES(io)
1215         B::IO   io
1216
1217 long
1218 IoPAGE(io)
1219         B::IO   io
1220
1221 long
1222 IoPAGE_LEN(io)
1223         B::IO   io
1224
1225 long
1226 IoLINES_LEFT(io)
1227         B::IO   io
1228
1229 char *
1230 IoTOP_NAME(io)
1231         B::IO   io
1232
1233 B::GV
1234 IoTOP_GV(io)
1235         B::IO   io
1236
1237 char *
1238 IoFMT_NAME(io)
1239         B::IO   io
1240
1241 B::GV
1242 IoFMT_GV(io)
1243         B::IO   io
1244
1245 char *
1246 IoBOTTOM_NAME(io)
1247         B::IO   io
1248
1249 B::GV
1250 IoBOTTOM_GV(io)
1251         B::IO   io
1252
1253 short
1254 IoSUBPROCESS(io)
1255         B::IO   io
1256
1257 bool
1258 IsSTD(io,name)
1259         B::IO   io
1260         char*   name
1261     PREINIT:
1262         PerlIO* handle = 0;
1263     CODE:
1264         if( strEQ( name, "stdin" ) ) {
1265             handle = PerlIO_stdin();
1266         }
1267         else if( strEQ( name, "stdout" ) ) {
1268             handle = PerlIO_stdout();
1269         }
1270         else if( strEQ( name, "stderr" ) ) {
1271             handle = PerlIO_stderr();
1272         }
1273         else {
1274             croak( "Invalid value '%s'", name );
1275         }
1276         RETVAL = handle == IoIFP(io);
1277     OUTPUT:
1278         RETVAL
1279
1280 MODULE = B      PACKAGE = B::IO
1281
1282 char
1283 IoTYPE(io)
1284         B::IO   io
1285
1286 U8
1287 IoFLAGS(io)
1288         B::IO   io
1289
1290 MODULE = B      PACKAGE = B::AV         PREFIX = Av
1291
1292 SSize_t
1293 AvFILL(av)
1294         B::AV   av
1295
1296 SSize_t
1297 AvMAX(av)
1298         B::AV   av
1299
1300 #define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1301
1302 IV
1303 AvOFF(av)
1304         B::AV   av
1305
1306 void
1307 AvARRAY(av)
1308         B::AV   av
1309     PPCODE:
1310         if (AvFILL(av) >= 0) {
1311             SV **svp = AvARRAY(av);
1312             I32 i;
1313             for (i = 0; i <= AvFILL(av); i++)
1314                 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), svp[i]));
1315         }
1316
1317 MODULE = B      PACKAGE = B::AV
1318
1319 U8
1320 AvFLAGS(av)
1321         B::AV   av
1322
1323 MODULE = B      PACKAGE = B::CV         PREFIX = Cv
1324
1325 B::HV
1326 CvSTASH(cv)
1327         B::CV   cv
1328
1329 B::OP
1330 CvSTART(cv)
1331         B::CV   cv
1332
1333 B::OP
1334 CvROOT(cv)
1335         B::CV   cv
1336
1337 B::GV
1338 CvGV(cv)
1339         B::CV   cv
1340
1341 char *
1342 CvFILE(cv)
1343         B::CV   cv
1344
1345 long
1346 CvDEPTH(cv)
1347         B::CV   cv
1348
1349 B::AV
1350 CvPADLIST(cv)
1351         B::CV   cv
1352
1353 B::CV
1354 CvOUTSIDE(cv)
1355         B::CV   cv
1356
1357 void
1358 CvXSUB(cv)
1359         B::CV   cv
1360     CODE:
1361         ST(0) = sv_2mortal(newSViv(PTR2IV(CvXSUB(cv))));
1362
1363
1364 void
1365 CvXSUBANY(cv)
1366         B::CV   cv
1367     CODE:
1368         ST(0) = CvCONST(cv) ?
1369                     make_sv_object(aTHX_ sv_newmortal(),CvXSUBANY(cv).any_ptr) :
1370                     sv_2mortal(newSViv(CvXSUBANY(cv).any_iv));
1371
1372 MODULE = B    PACKAGE = B::CV
1373
1374 U16
1375 CvFLAGS(cv)
1376       B::CV   cv
1377
1378 MODULE = B      PACKAGE = B::CV         PREFIX = cv_
1379
1380 B::SV
1381 cv_const_sv(cv)
1382         B::CV   cv
1383
1384
1385 MODULE = B      PACKAGE = B::HV         PREFIX = Hv
1386
1387 STRLEN
1388 HvFILL(hv)
1389         B::HV   hv
1390
1391 STRLEN
1392 HvMAX(hv)
1393         B::HV   hv
1394
1395 I32
1396 HvKEYS(hv)
1397         B::HV   hv
1398
1399 I32
1400 HvRITER(hv)
1401         B::HV   hv
1402
1403 char *
1404 HvNAME(hv)
1405         B::HV   hv
1406
1407 B::PMOP
1408 HvPMROOT(hv)
1409         B::HV   hv
1410
1411 void
1412 HvARRAY(hv)
1413         B::HV   hv
1414     PPCODE:
1415         if (HvKEYS(hv) > 0) {
1416             SV *sv;
1417             char *key;
1418             I32 len;
1419             (void)hv_iterinit(hv);
1420             EXTEND(sp, HvKEYS(hv) * 2);
1421             while ((sv = hv_iternextsv(hv, &key, &len))) {
1422                 PUSHs(newSVpvn(key, len));
1423                 PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv));
1424             }
1425         }