This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Merge B::AV::MAX and B::FM::LINES into the common accessor.
[perl5.git] / 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 /* FIXME - figure out how to get the typemap to assign this to ST(0), rather
239    than creating a new mortal for ST(0) then passing it in as the first
240    argument.  */
241 static SV *
242 make_sv_object(pTHX_ SV *arg, SV *sv)
243 {
244     const char *type = 0;
245     IV iv;
246     dMY_CXT;
247
248     if (!arg)
249         arg = sv_newmortal();
250
251     for (iv = 0; iv < sizeof(specialsv_list)/sizeof(SV*); iv++) {
252         if (sv == specialsv_list[iv]) {
253             type = "B::SPECIAL";
254             break;
255         }
256     }
257     if (!type) {
258         type = svclassnames[SvTYPE(sv)];
259         iv = PTR2IV(sv);
260     }
261     sv_setiv(newSVrv(arg, type), iv);
262     return arg;
263 }
264
265 #if PERL_VERSION >= 9
266 static SV *
267 make_temp_object(pTHX_ SV *temp)
268 {
269     SV *target;
270     SV *arg = sv_newmortal();
271     const char *const type = svclassnames[SvTYPE(temp)];
272     const IV iv = PTR2IV(temp);
273
274     target = newSVrv(arg, type);
275     sv_setiv(target, iv);
276
277     /* Need to keep our "temp" around as long as the target exists.
278        Simplest way seems to be to hang it from magic, and let that clear
279        it up.  No vtable, so won't actually get in the way of anything.  */
280     sv_magicext(target, temp, PERL_MAGIC_sv, NULL, NULL, 0);
281     /* magic object has had its reference count increased, so we must drop
282        our reference.  */
283     SvREFCNT_dec(temp);
284     return arg;
285 }
286
287 static SV *
288 make_warnings_object(pTHX_ STRLEN *warnings)
289 {
290     const char *type = 0;
291     dMY_CXT;
292     IV iv = sizeof(specialsv_list)/sizeof(SV*);
293
294     /* Counting down is deliberate. Before the split between make_sv_object
295        and make_warnings_obj there appeared to be a bug - Nullsv and pWARN_STD
296        were both 0, so you could never get a B::SPECIAL for pWARN_STD  */
297
298     while (iv--) {
299         if ((SV*)warnings == specialsv_list[iv]) {
300             type = "B::SPECIAL";
301             break;
302         }
303     }
304     if (type) {
305         SV *arg = sv_newmortal();
306         sv_setiv(newSVrv(arg, type), iv);
307         return arg;
308     } else {
309         /* B assumes that warnings are a regular SV. Seems easier to keep it
310            happy by making them into a regular SV.  */
311         return make_temp_object(aTHX_ newSVpvn((char *)(warnings + 1), *warnings));
312     }
313 }
314
315 static SV *
316 make_cop_io_object(pTHX_ COP *cop)
317 {
318     SV *const value = newSV(0);
319
320     Perl_emulate_cop_io(aTHX_ cop, value);
321
322     if(SvOK(value)) {
323         return make_sv_object(aTHX_ NULL, value);
324     } else {
325         SvREFCNT_dec(value);
326         return make_sv_object(aTHX_ NULL, NULL);
327     }
328 }
329 #endif
330
331 static SV *
332 make_mg_object(pTHX_ MAGIC *mg)
333 {
334     SV *arg = sv_newmortal();
335     sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg));
336     return arg;
337 }
338
339 static SV *
340 cstring(pTHX_ SV *sv, bool perlstyle)
341 {
342     SV *sstr;
343
344     if (!SvOK(sv))
345         return newSVpvs_flags("0", SVs_TEMP);
346
347     sstr = newSVpvs_flags("\"", SVs_TEMP);
348
349     if (perlstyle && SvUTF8(sv)) {
350         SV *tmpsv = sv_newmortal(); /* Temporary SV to feed sv_uni_display */
351         const STRLEN len = SvCUR(sv);
352         const char *s = sv_uni_display(tmpsv, sv, 8*len, UNI_DISPLAY_QQ);
353         while (*s)
354         {
355             if (*s == '"')
356                 sv_catpvs(sstr, "\\\"");
357             else if (*s == '$')
358                 sv_catpvs(sstr, "\\$");
359             else if (*s == '@')
360                 sv_catpvs(sstr, "\\@");
361             else if (*s == '\\')
362             {
363                 if (strchr("nrftax\\",*(s+1)))
364                     sv_catpvn(sstr, s++, 2);
365                 else
366                     sv_catpvs(sstr, "\\\\");
367             }
368             else /* should always be printable */
369                 sv_catpvn(sstr, s, 1);
370             ++s;
371         }
372     }
373     else
374     {
375         /* XXX Optimise? */
376         STRLEN len;
377         const char *s = SvPV(sv, len);
378         for (; len; len--, s++)
379         {
380             /* At least try a little for readability */
381             if (*s == '"')
382                 sv_catpvs(sstr, "\\\"");
383             else if (*s == '\\')
384                 sv_catpvs(sstr, "\\\\");
385             /* trigraphs - bleagh */
386             else if (!perlstyle && *s == '?' && len>=3 && s[1] == '?') {
387                 Perl_sv_catpvf(aTHX_ sstr, "\\%03o", '?');
388             }
389             else if (perlstyle && *s == '$')
390                 sv_catpvs(sstr, "\\$");
391             else if (perlstyle && *s == '@')
392                 sv_catpvs(sstr, "\\@");
393 #ifdef EBCDIC
394             else if (isPRINT(*s))
395 #else
396             else if (*s >= ' ' && *s < 127)
397 #endif /* EBCDIC */
398                 sv_catpvn(sstr, s, 1);
399             else if (*s == '\n')
400                 sv_catpvs(sstr, "\\n");
401             else if (*s == '\r')
402                 sv_catpvs(sstr, "\\r");
403             else if (*s == '\t')
404                 sv_catpvs(sstr, "\\t");
405             else if (*s == '\a')
406                 sv_catpvs(sstr, "\\a");
407             else if (*s == '\b')
408                 sv_catpvs(sstr, "\\b");
409             else if (*s == '\f')
410                 sv_catpvs(sstr, "\\f");
411             else if (!perlstyle && *s == '\v')
412                 sv_catpvs(sstr, "\\v");
413             else
414             {
415                 /* Don't want promotion of a signed -1 char in sprintf args */
416                 const unsigned char c = (unsigned char) *s;
417                 Perl_sv_catpvf(aTHX_ sstr, "\\%03o", c);
418             }
419             /* XXX Add line breaks if string is long */
420         }
421     }
422     sv_catpvs(sstr, "\"");
423     return sstr;
424 }
425
426 static SV *
427 cchar(pTHX_ SV *sv)
428 {
429     SV *sstr = newSVpvs_flags("'", SVs_TEMP);
430     const char *s = SvPV_nolen(sv);
431     /* Don't want promotion of a signed -1 char in sprintf args */
432     const unsigned char c = (unsigned char) *s;
433
434     if (c == '\'')
435         sv_catpvs(sstr, "\\'");
436     else if (c == '\\')
437         sv_catpvs(sstr, "\\\\");
438 #ifdef EBCDIC
439     else if (isPRINT(c))
440 #else
441     else if (c >= ' ' && c < 127)
442 #endif /* EBCDIC */
443         sv_catpvn(sstr, s, 1);
444     else if (c == '\n')
445         sv_catpvs(sstr, "\\n");
446     else if (c == '\r')
447         sv_catpvs(sstr, "\\r");
448     else if (c == '\t')
449         sv_catpvs(sstr, "\\t");
450     else if (c == '\a')
451         sv_catpvs(sstr, "\\a");
452     else if (c == '\b')
453         sv_catpvs(sstr, "\\b");
454     else if (c == '\f')
455         sv_catpvs(sstr, "\\f");
456     else if (c == '\v')
457         sv_catpvs(sstr, "\\v");
458     else
459         Perl_sv_catpvf(aTHX_ sstr, "\\%03o", c);
460     sv_catpvs(sstr, "'");
461     return sstr;
462 }
463
464 #if PERL_VERSION >= 9
465 #  define PMOP_pmreplstart(o)   o->op_pmstashstartu.op_pmreplstart
466 #  define PMOP_pmreplroot(o)    o->op_pmreplrootu.op_pmreplroot
467 #else
468 #  define PMOP_pmreplstart(o)   o->op_pmreplstart
469 #  define PMOP_pmreplroot(o)    o->op_pmreplroot
470 #  define PMOP_pmpermflags(o)   o->op_pmpermflags
471 #  define PMOP_pmdynflags(o)      o->op_pmdynflags
472 #endif
473
474 static void
475 walkoptree(pTHX_ SV *opsv, const char *method)
476 {
477     dSP;
478     OP *o, *kid;
479     dMY_CXT;
480
481     if (!SvROK(opsv))
482         croak("opsv is not a reference");
483     opsv = sv_mortalcopy(opsv);
484     o = INT2PTR(OP*,SvIV((SV*)SvRV(opsv)));
485     if (walkoptree_debug) {
486         PUSHMARK(sp);
487         XPUSHs(opsv);
488         PUTBACK;
489         perl_call_method("walkoptree_debug", G_DISCARD);
490     }
491     PUSHMARK(sp);
492     XPUSHs(opsv);
493     PUTBACK;
494     perl_call_method(method, G_DISCARD);
495     if (o && (o->op_flags & OPf_KIDS)) {
496         for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) {
497             /* Use the same opsv. Rely on methods not to mess it up. */
498             sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
499             walkoptree(aTHX_ opsv, method);
500         }
501     }
502     if (o && (cc_opclass(aTHX_ o) == OPc_PMOP) && o->op_type != OP_PUSHRE
503            && (kid = PMOP_pmreplroot(cPMOPo)))
504     {
505         sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
506         walkoptree(aTHX_ opsv, method);
507     }
508 }
509
510 static SV **
511 oplist(pTHX_ OP *o, SV **SP)
512 {
513     for(; o; o = o->op_next) {
514         SV *opsv;
515 #if PERL_VERSION >= 9
516         if (o->op_opt == 0)
517             break;
518         o->op_opt = 0;
519 #else
520         if (o->op_seq == 0)
521             break;
522         o->op_seq = 0;
523 #endif
524         opsv = sv_newmortal();
525         sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ (OP*)o)), PTR2IV(o));
526         XPUSHs(opsv);
527         switch (o->op_type) {
528         case OP_SUBST:
529             SP = oplist(aTHX_ PMOP_pmreplstart(cPMOPo), SP);
530             continue;
531         case OP_SORT:
532             if (o->op_flags & OPf_STACKED && o->op_flags & OPf_SPECIAL) {
533                 OP *kid = cLISTOPo->op_first->op_sibling;   /* pass pushmark */
534                 kid = kUNOP->op_first;                      /* pass rv2gv */
535                 kid = kUNOP->op_first;                      /* pass leave */
536                 SP = oplist(aTHX_ kid->op_next, SP);
537             }
538             continue;
539         }
540         switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
541         case OA_LOGOP:
542             SP = oplist(aTHX_ cLOGOPo->op_other, SP);
543             break;
544         case OA_LOOP:
545             SP = oplist(aTHX_ cLOOPo->op_lastop, SP);
546             SP = oplist(aTHX_ cLOOPo->op_nextop, SP);
547             SP = oplist(aTHX_ cLOOPo->op_redoop, SP);
548             break;
549         }
550     }
551     return SP;
552 }
553
554 typedef OP      *B__OP;
555 typedef UNOP    *B__UNOP;
556 typedef BINOP   *B__BINOP;
557 typedef LOGOP   *B__LOGOP;
558 typedef LISTOP  *B__LISTOP;
559 typedef PMOP    *B__PMOP;
560 typedef SVOP    *B__SVOP;
561 typedef PADOP   *B__PADOP;
562 typedef PVOP    *B__PVOP;
563 typedef LOOP    *B__LOOP;
564 typedef COP     *B__COP;
565
566 typedef SV      *B__SV;
567 typedef SV      *B__IV;
568 typedef SV      *B__PV;
569 typedef SV      *B__NV;
570 typedef SV      *B__PVMG;
571 #if PERL_VERSION >= 11
572 typedef SV      *B__REGEXP;
573 #endif
574 typedef SV      *B__PVLV;
575 typedef SV      *B__BM;
576 typedef SV      *B__RV;
577 typedef SV      *B__FM;
578 typedef AV      *B__AV;
579 typedef HV      *B__HV;
580 typedef CV      *B__CV;
581 typedef GV      *B__GV;
582 typedef IO      *B__IO;
583
584 typedef MAGIC   *B__MAGIC;
585 typedef HE      *B__HE;
586 #if PERL_VERSION >= 9
587 typedef struct refcounted_he    *B__RHE;
588 #endif
589
590 #include "const-c.inc"
591
592 MODULE = B      PACKAGE = B     PREFIX = B_
593
594 INCLUDE: const-xs.inc
595
596 PROTOTYPES: DISABLE
597
598 BOOT:
599 {
600     HV *stash = gv_stashpvs("B", GV_ADD);
601     AV *export_ok = perl_get_av("B::EXPORT_OK", GV_ADD);
602     MY_CXT_INIT;
603     specialsv_list[0] = Nullsv;
604     specialsv_list[1] = &PL_sv_undef;
605     specialsv_list[2] = &PL_sv_yes;
606     specialsv_list[3] = &PL_sv_no;
607     specialsv_list[4] = (SV *) pWARN_ALL;
608     specialsv_list[5] = (SV *) pWARN_NONE;
609     specialsv_list[6] = (SV *) pWARN_STD;
610 #if PERL_VERSION <= 8
611 #  define OPpPAD_STATE 0
612 #endif
613 }
614
615 #define B_main_cv()     PL_main_cv
616 #define B_init_av()     PL_initav
617 #define B_inc_gv()      PL_incgv
618 #define B_check_av()    PL_checkav_save
619 #if PERL_VERSION > 8
620 #  define B_unitcheck_av()      PL_unitcheckav_save
621 #else
622 #  define B_unitcheck_av()      NULL
623 #endif
624 #define B_begin_av()    PL_beginav_save
625 #define B_end_av()      PL_endav
626 #define B_main_root()   PL_main_root
627 #define B_main_start()  PL_main_start
628 #define B_amagic_generation()   PL_amagic_generation
629 #define B_sub_generation()      PL_sub_generation
630 #define B_defstash()    PL_defstash
631 #define B_curstash()    PL_curstash
632 #define B_dowarn()      PL_dowarn
633 #define B_comppadlist() (PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv))
634 #define B_sv_undef()    &PL_sv_undef
635 #define B_sv_yes()      &PL_sv_yes
636 #define B_sv_no()       &PL_sv_no
637 #define B_formfeed()    PL_formfeed
638 #ifdef USE_ITHREADS
639 #define B_regex_padav() PL_regex_padav
640 #endif
641
642 B::AV
643 B_init_av()
644
645 B::AV
646 B_check_av()
647
648 #if PERL_VERSION >= 9
649
650 B::AV
651 B_unitcheck_av()
652
653 #endif
654
655 B::AV
656 B_begin_av()
657
658 B::AV
659 B_end_av()
660
661 B::GV
662 B_inc_gv()
663
664 #ifdef USE_ITHREADS
665
666 B::AV
667 B_regex_padav()
668
669 #endif
670
671 B::CV
672 B_main_cv()
673
674 B::OP
675 B_main_root()
676
677 B::OP
678 B_main_start()
679
680 long 
681 B_amagic_generation()
682
683 long
684 B_sub_generation()
685
686 B::AV
687 B_comppadlist()
688
689 B::SV
690 B_sv_undef()
691
692 B::SV
693 B_sv_yes()
694
695 B::SV
696 B_sv_no()
697
698 B::HV
699 B_curstash()
700
701 B::HV
702 B_defstash()
703
704 U8
705 B_dowarn()
706
707 B::SV
708 B_formfeed()
709
710 void
711 B_warnhook()
712     CODE:
713         ST(0) = make_sv_object(aTHX_ NULL, PL_warnhook);
714
715 void
716 B_diehook()
717     CODE:
718         ST(0) = make_sv_object(aTHX_ NULL, PL_diehook);
719
720 MODULE = B      PACKAGE = B
721
722 void
723 walkoptree(opsv, method)
724         SV *    opsv
725         const char *    method
726     CODE:
727         walkoptree(aTHX_ opsv, method);
728
729 int
730 walkoptree_debug(...)
731     CODE:
732         dMY_CXT;
733         RETVAL = walkoptree_debug;
734         if (items > 0 && SvTRUE(ST(1)))
735             walkoptree_debug = 1;
736     OUTPUT:
737         RETVAL
738
739 #define address(sv) PTR2IV(sv)
740
741 IV
742 address(sv)
743         SV *    sv
744
745 B::SV
746 svref_2object(sv)
747         SV *    sv
748     CODE:
749         if (!SvROK(sv))
750             croak("argument is not a reference");
751         RETVAL = (SV*)SvRV(sv);
752     OUTPUT:
753         RETVAL              
754
755 void
756 opnumber(name)
757 const char *    name
758 CODE:
759 {
760  int i; 
761  IV  result = -1;
762  ST(0) = sv_newmortal();
763  if (strncmp(name,"pp_",3) == 0)
764    name += 3;
765  for (i = 0; i < PL_maxo; i++)
766   {
767    if (strcmp(name, PL_op_name[i]) == 0)
768     {
769      result = i;
770      break;
771     }
772   }
773  sv_setiv(ST(0),result);
774 }
775
776 void
777 ppname(opnum)
778         int     opnum
779     CODE:
780         ST(0) = sv_newmortal();
781         if (opnum >= 0 && opnum < PL_maxo) {
782             sv_setpvs(ST(0), "pp_");
783             sv_catpv(ST(0), PL_op_name[opnum]);
784         }
785
786 void
787 hash(sv)
788         SV *    sv
789     CODE:
790         STRLEN len;
791         U32 hash = 0;
792         const char *s = SvPVbyte(sv, len);
793         PERL_HASH(hash, s, len);
794         ST(0) = sv_2mortal(Perl_newSVpvf(aTHX_ "0x%"UVxf, (UV)hash));
795
796 #define cast_I32(foo) (I32)foo
797 IV
798 cast_I32(i)
799         IV      i
800
801 void
802 minus_c()
803     CODE:
804         PL_minus_c = TRUE;
805
806 void
807 save_BEGINs()
808     CODE:
809         PL_savebegin = TRUE;
810
811 SV *
812 cstring(sv)
813         SV *    sv
814     ALIAS:
815         perlstring = 1
816         cchar = 2
817     PPCODE:
818         PUSHs(ix == 2 ? cchar(aTHX_ sv) : cstring(aTHX_ sv, ix));
819
820 void
821 threadsv_names()
822     PPCODE:
823 #if PERL_VERSION <= 8
824 # ifdef USE_5005THREADS
825         int i;
826         const STRLEN len = strlen(PL_threadsv_names);
827
828         EXTEND(sp, len);
829         for (i = 0; i < len; i++)
830             PUSHs(newSVpvn_flags(&PL_threadsv_names[i], 1, SVs_TEMP));
831 # endif
832 #endif
833
834 #define SVp             0x00000
835 #define U32p            0x10000
836 #define line_tp         0x20000
837 #define OPp             0x30000
838 #define PADOFFSETp      0x40000
839 #define U8p             0x50000
840 #define IVp             0x60000
841 #define char_pp         0x70000
842
843 #define OP_next_ix              OPp | offsetof(struct op, op_next)
844 #define OP_sibling_ix           OPp | offsetof(struct op, op_sibling)
845 #define UNOP_first_ix           OPp | offsetof(struct unop, op_first)
846 #define BINOP_last_ix           OPp | offsetof(struct binop, op_last)
847 #define LOGOP_other_ix          OPp | offsetof(struct logop, op_other)
848 #if PERL_VERSION >= 9
849 #  define PMOP_pmreplstart_ix \
850                 OPp | offsetof(struct pmop, op_pmstashstartu.op_pmreplstart)
851 #else
852 #  define PMOP_pmreplstart_ix   OPp | offsetof(struct pmop, op_pmreplstart)
853 #endif
854 #define LOOP_redoop_ix          OPp | offsetof(struct loop, op_redoop)
855 #define LOOP_nextop_ix          OPp | offsetof(struct loop, op_nextop)
856 #define LOOP_lastop_ix          OPp | offsetof(struct loop, op_lastop)
857
858 #define OP_targ_ix              PADOFFSETp | offsetof(struct op, op_targ)
859 #define OP_flags_ix             U8p | offsetof(struct op, op_flags)
860 #define OP_private_ix           U8p | offsetof(struct op, op_private)
861
862 #define PMOP_pmflags_ix         U32p | offsetof(struct pmop, op_pmflags)
863
864 #ifdef USE_ITHREADS
865 #define PMOP_pmoffset_ix        IVp | offsetof(struct pmop, op_pmoffset)
866 #endif
867
868 #  Yes, B::SV::sv and B::SV::gv really do end up generating identical code.
869 #define SVOP_sv_ix              SVp | offsetof(struct svop, op_sv)
870 #define SVOP_gv_ix              SVp | offsetof(struct svop, op_sv)
871
872 #define PADOP_padix_ix          PADOFFSETp | offsetof(struct padop, op_padix)
873
874 #define COP_seq_ix              U32p | offsetof(struct cop, cop_seq)
875 #define COP_line_ix             line_tp | offsetof(struct cop, cop_line)
876 #if PERL_VERSION >= 9
877 #define COP_hints_ix            U32p | offsetof(struct cop, cop_hints)
878 #else
879 #define COP_hints_ix            U8p | offsetof(struct cop, op_private)
880 #endif
881
882 #ifdef USE_ITHREADS
883 #define COP_stashpv_ix          char_pp | offsetof(struct cop, cop_stashpv)
884 #define COP_file_ix             char_pp | offsetof(struct cop, cop_file)
885 #else
886 #define COP_stash_ix            SVp | offsetof(struct cop, cop_stash)
887 #define COP_filegv_ix           SVp | offsetof(struct cop, cop_filegv)
888 #endif
889
890 MODULE = B      PACKAGE = B::OP         PREFIX = OP_
891
892 size_t
893 OP_size(o)
894         B::OP           o
895     CODE:
896         RETVAL = opsizes[cc_opclass(aTHX_ o)];
897     OUTPUT:
898         RETVAL
899
900 # The type checking code in B has always been identical for all OP types,
901 # irrespective of whether the action is actually defined on that OP.
902 # We should fix this
903 void
904 next(o)
905         B::OP           o
906     ALIAS:
907         B::OP::next = OP_next_ix
908         B::OP::sibling = OP_sibling_ix
909         B::OP::targ = OP_targ_ix
910         B::OP::flags = OP_flags_ix
911         B::OP::private = OP_private_ix
912         B::UNOP::first = UNOP_first_ix
913         B::BINOP::last = BINOP_last_ix
914         B::LOGOP::other = LOGOP_other_ix
915         B::PMOP::pmreplstart = PMOP_pmreplstart_ix
916         B::LOOP::redoop = LOOP_redoop_ix
917         B::LOOP::nextop = LOOP_nextop_ix
918         B::LOOP::lastop = LOOP_lastop_ix
919         B::PMOP::pmflags = PMOP_pmflags_ix
920         B::SVOP::sv = SVOP_sv_ix
921         B::SVOP::gv = SVOP_gv_ix
922         B::PADOP::padix = PADOP_padix_ix
923         B::COP::cop_seq = COP_seq_ix
924         B::COP::line = COP_line_ix
925         B::COP::hints = COP_hints_ix
926     PREINIT:
927         char *ptr;
928         SV *ret;
929     PPCODE:
930         ptr = (ix & 0xFFFF) + (char *)o;
931         switch ((U8)(ix >> 16)) {
932         case (U8)(OPp >> 16):
933             {
934                 OP *const o2 = *((OP **)ptr);
935                 ret = sv_newmortal();
936                 sv_setiv(newSVrv(ret, cc_opclassname(aTHX_ o2)), PTR2IV(o2));
937                 break;
938             }
939         case (U8)(PADOFFSETp >> 16):
940             ret = sv_2mortal(newSVuv(*((PADOFFSET*)ptr)));
941             break;
942         case (U8)(U8p >> 16):
943             ret = sv_2mortal(newSVuv(*((U8*)ptr)));
944             break;
945         case (U8)(U32p >> 16):
946             ret = sv_2mortal(newSVuv(*((U32*)ptr)));
947             break;
948         case (U8)(SVp >> 16):
949             ret = make_sv_object(aTHX_ NULL, *((SV **)ptr));
950             break;
951         case (U8)(line_tp >> 16):
952             ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
953             break;
954 #ifdef USE_ITHREADS
955         case (U8)(IVp >> 16):
956             ret = sv_2mortal(newSViv(*((IV*)ptr)));
957             break;
958         case (U8)(char_pp >> 16):
959             ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
960             break;
961 #endif
962         }
963         ST(0) = ret;
964         XSRETURN(1);
965
966 char *
967 OP_name(o)
968         B::OP           o
969     ALIAS:
970         desc = 1
971     CODE:
972         RETVAL = (char *)(ix ? PL_op_desc : PL_op_name)[o->op_type];
973     OUTPUT:
974         RETVAL
975
976 void
977 OP_ppaddr(o)
978         B::OP           o
979     PREINIT:
980         int i;
981         SV *sv = newSVpvs_flags("PL_ppaddr[OP_", SVs_TEMP);
982     CODE:
983         sv_catpv(sv, PL_op_name[o->op_type]);
984         for (i=13; (STRLEN)i < SvCUR(sv); ++i)
985             SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]);
986         sv_catpvs(sv, "]");
987         ST(0) = sv;
988
989 #if PERL_VERSION >= 9
990 #  These 3 are all bitfields, so we can't take their addresses.
991 UV
992 OP_type(o)
993         B::OP           o
994     ALIAS:
995         opt = 1
996         spare = 2
997     CODE:
998         switch(ix) {
999           case 1:
1000             RETVAL = o->op_opt;
1001             break;
1002           case 2:
1003             RETVAL = o->op_spare;
1004             break;
1005           default:
1006             RETVAL = o->op_type;
1007         }
1008     OUTPUT:
1009         RETVAL
1010
1011 #else
1012
1013 UV
1014 OP_type(o)
1015         B::OP           o
1016     ALIAS:
1017         seq = 1
1018     CODE:
1019         switch(ix) {
1020           case 1:
1021             RETVAL = o->op_seq;
1022             break;
1023           default:
1024             RETVAL = o->op_type;
1025         }
1026     OUTPUT:
1027         RETVAL
1028
1029 #endif
1030
1031 void
1032 OP_oplist(o)
1033         B::OP           o
1034     PPCODE:
1035         SP = oplist(aTHX_ o, SP);
1036
1037 MODULE = B      PACKAGE = B::LISTOP             PREFIX = LISTOP_
1038
1039 U32
1040 LISTOP_children(o)
1041         B::LISTOP       o
1042         OP *            kid = NO_INIT
1043         int             i = NO_INIT
1044     CODE:
1045         i = 0;
1046         for (kid = o->op_first; kid; kid = kid->op_sibling)
1047             i++;
1048         RETVAL = i;
1049     OUTPUT:
1050         RETVAL
1051
1052 MODULE = B      PACKAGE = B::PMOP               PREFIX = PMOP_
1053
1054 #if PERL_VERSION <= 8
1055
1056 void
1057 PMOP_pmreplroot(o)
1058         B::PMOP         o
1059         OP *            root = NO_INIT
1060     CODE:
1061         ST(0) = sv_newmortal();
1062         root = o->op_pmreplroot;
1063         /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */
1064         if (o->op_type == OP_PUSHRE) {
1065 #  ifdef USE_ITHREADS
1066             sv_setiv(ST(0), INT2PTR(PADOFFSET,root) );
1067 #  else
1068             sv_setiv(newSVrv(ST(0), root ?
1069                              svclassnames[SvTYPE((SV*)root)] : "B::SV"),
1070                      PTR2IV(root));
1071 #  endif
1072         }
1073         else {
1074             sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root));
1075         }
1076
1077 #else
1078
1079 void
1080 PMOP_pmreplroot(o)
1081         B::PMOP         o
1082     CODE:
1083         ST(0) = sv_newmortal();
1084         if (o->op_type == OP_PUSHRE) {
1085 #  ifdef USE_ITHREADS
1086             sv_setiv(ST(0), o->op_pmreplrootu.op_pmtargetoff);
1087 #  else
1088             GV *const target = o->op_pmreplrootu.op_pmtargetgv;
1089             sv_setiv(newSVrv(ST(0), target ?
1090                              svclassnames[SvTYPE((SV*)target)] : "B::SV"),
1091                      PTR2IV(target));
1092 #  endif
1093         }
1094         else {
1095             OP *const root = o->op_pmreplrootu.op_pmreplroot; 
1096             sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)),
1097                      PTR2IV(root));
1098         }
1099
1100 #endif
1101
1102 #ifdef USE_ITHREADS
1103 #define PMOP_pmstashpv(o)       PmopSTASHPV(o);
1104
1105 char*
1106 PMOP_pmstashpv(o)
1107         B::PMOP         o
1108
1109 #else
1110 #define PMOP_pmstash(o)         PmopSTASH(o);
1111
1112 B::HV
1113 PMOP_pmstash(o)
1114         B::PMOP         o
1115
1116 #endif
1117
1118 #if PERL_VERSION < 9
1119 #define PMOP_pmnext(o)          o->op_pmnext
1120
1121 B::PMOP
1122 PMOP_pmnext(o)
1123         B::PMOP         o
1124
1125 U32
1126 PMOP_pmpermflags(o)
1127         B::PMOP         o
1128
1129 U8
1130 PMOP_pmdynflags(o)
1131         B::PMOP         o
1132
1133 #endif
1134
1135 void
1136 PMOP_precomp(o)
1137         B::PMOP         o
1138     PREINIT:
1139         dXSI32;
1140         REGEXP *rx;
1141     CODE:
1142         rx = PM_GETRE(o);
1143         ST(0) = sv_newmortal();
1144         if (rx) {
1145 #if PERL_VERSION >= 9
1146             if (ix) {
1147                 sv_setuv(ST(0), RX_EXTFLAGS(rx));
1148             } else
1149 #endif
1150             {
1151                 sv_setpvn(ST(0), RX_PRECOMP(rx), RX_PRELEN(rx));
1152             }
1153         }
1154
1155 BOOT:
1156 {
1157         CV *cv;
1158 #ifdef USE_ITHREADS
1159         cv = newXS("B::PMOP::pmoffset", XS_B__OP_next, __FILE__);
1160         XSANY.any_i32 = PMOP_pmoffset_ix;
1161         cv = newXS("B::COP::stashpv", XS_B__OP_next, __FILE__);
1162         XSANY.any_i32 = COP_stashpv_ix;
1163         cv = newXS("B::COP::file", XS_B__OP_next, __FILE__);
1164         XSANY.any_i32 = COP_file_ix;
1165 #else
1166         cv = newXS("B::COP::stash", XS_B__OP_next, __FILE__);
1167         XSANY.any_i32 = COP_stash_ix;
1168         cv = newXS("B::COP::filegv", XS_B__OP_next, __FILE__);
1169         XSANY.any_i32 = COP_filegv_ix;
1170 #endif
1171 #if PERL_VERSION >= 9
1172         cv = newXS("B::PMOP::reflags", XS_B__PMOP_precomp, __FILE__);
1173         XSANY.any_i32 = 1;
1174 #endif
1175 }
1176
1177 MODULE = B      PACKAGE = B::PADOP
1178
1179 B::SV
1180 sv(o)
1181         B::PADOP o
1182     ALIAS:
1183         gv = 1
1184     CODE:
1185         /* It happens that the output typemaps for B::SV and B::GV are
1186            identical. The "smarts" are in make_sv_object(), which determines
1187            which class to use based on SvTYPE(), rather than anything baked in
1188            at compile time.  */    
1189         if (o->op_padix) {
1190             RETVAL = PAD_SVl(o->op_padix);
1191             if (ix && SvTYPE(RETVAL) != SVt_PVGV)
1192                 RETVAL = NULL;
1193         } else {
1194             RETVAL = NULL;
1195         }
1196     OUTPUT:
1197         RETVAL
1198
1199 MODULE = B      PACKAGE = B::PVOP               PREFIX = PVOP_
1200
1201 void
1202 PVOP_pv(o)
1203         B::PVOP o
1204     CODE:
1205         /*
1206          * OP_TRANS uses op_pv to point to a table of 256 or >=258 shorts
1207          * whereas other PVOPs point to a null terminated string.
1208          */
1209         if (o->op_type == OP_TRANS &&
1210                 (o->op_private & OPpTRANS_COMPLEMENT) &&
1211                 !(o->op_private & OPpTRANS_DELETE))
1212         {
1213             const short* const tbl = (short*)o->op_pv;
1214             const short entries = 257 + tbl[256];
1215             ST(0) = newSVpvn_flags(o->op_pv, entries * sizeof(short), SVs_TEMP);
1216         }
1217         else if (o->op_type == OP_TRANS) {
1218             ST(0) = newSVpvn_flags(o->op_pv, 256 * sizeof(short), SVs_TEMP);
1219         }
1220         else
1221             ST(0) = newSVpvn_flags(o->op_pv, strlen(o->op_pv), SVs_TEMP);
1222
1223 #define COP_label(o)    CopLABEL(o)
1224 #define COP_arybase(o)  CopARYBASE_get(o)
1225
1226 MODULE = B      PACKAGE = B::COP                PREFIX = COP_
1227
1228 const char *
1229 COP_label(o)
1230         B::COP  o
1231
1232 # Both pairs of accessors are provided for both ithreads and not, but for each,
1233 # one pair is direct structure access, and 1 pair "faked up" with a more complex
1234 # macro. We implement the direct structure access pair using the common code
1235 # above (B::OP::next)
1236  
1237 #ifdef USE_ITHREADS
1238 #define COP_stash(o)    CopSTASH(o)
1239 #define COP_filegv(o)   CopFILEGV(o)
1240
1241 B::HV
1242 COP_stash(o)
1243         B::COP  o
1244
1245 B::GV
1246 COP_filegv(o)
1247        B::COP  o
1248
1249 #else
1250 #define COP_stashpv(o)  CopSTASHPV(o)
1251 #define COP_file(o)     CopFILE(o)
1252
1253 char *
1254 COP_stashpv(o)
1255         B::COP  o
1256
1257 char *
1258 COP_file(o)
1259         B::COP  o
1260
1261 #endif
1262
1263 I32
1264 COP_arybase(o)
1265         B::COP  o
1266
1267 void
1268 COP_warnings(o)
1269         B::COP  o
1270         PPCODE:
1271 #if PERL_VERSION >= 9
1272         ST(0) = make_warnings_object(aTHX_ o->cop_warnings);
1273 #else
1274         ST(0) = make_sv_object(aTHX_ NULL, o->cop_warnings);
1275 #endif
1276         XSRETURN(1);
1277
1278 void
1279 COP_io(o)
1280         B::COP  o
1281         PPCODE:
1282 #if PERL_VERSION >= 9
1283         ST(0) = make_cop_io_object(aTHX_ o);
1284 #else
1285         ST(0) = make_sv_object(aTHX_ NULL, o->cop_io);
1286 #endif
1287         XSRETURN(1);
1288
1289 #if PERL_VERSION >= 9
1290
1291 B::RHE
1292 COP_hints_hash(o)
1293         B::COP o
1294     CODE:
1295         RETVAL = CopHINTHASH_get(o);
1296     OUTPUT:
1297         RETVAL
1298
1299 #endif
1300
1301 MODULE = B      PACKAGE = B::SV
1302
1303 #define MAGICAL_FLAG_BITS (SVs_GMG|SVs_SMG|SVs_RMG)
1304
1305 U32
1306 REFCNT(sv)
1307         B::SV   sv
1308     ALIAS:
1309         FLAGS = 0xFFFFFFFF
1310         SvTYPE = SVTYPEMASK
1311         POK = SVf_POK
1312         ROK = SVf_ROK
1313         MAGICAL = MAGICAL_FLAG_BITS
1314     CODE:
1315         RETVAL = ix ? (SvFLAGS(sv) & (U32)ix) : SvREFCNT(sv);
1316     OUTPUT:
1317         RETVAL
1318
1319 void
1320 object_2svref(sv)
1321         B::SV   sv
1322     PPCODE:
1323         ST(0) = sv_2mortal(newRV(sv));
1324         XSRETURN(1);
1325         
1326 MODULE = B      PACKAGE = B::IV         PREFIX = Sv
1327
1328 IV
1329 SvIV(sv)
1330         B::IV   sv
1331
1332 MODULE = B      PACKAGE = B::IV
1333
1334 #define sv_SVp          0x00000
1335 #define sv_IVp          0x10000
1336 #define sv_UVp          0x20000
1337 #define sv_STRLENp      0x30000
1338 #define sv_U32p         0x40000
1339 #define sv_U8p          0x50000
1340 #define sv_char_pp      0x60000
1341 #define sv_NVp          0x70000
1342 #define sv_char_p       0x80000
1343 #define sv_SSize_tp     0x90000
1344
1345 #define IV_ivx_ix       sv_IVp | offsetof(struct xpviv, xiv_iv)
1346 #define IV_uvx_ix       sv_UVp | offsetof(struct xpvuv, xuv_uv)
1347 #define NV_nvx_ix       sv_NVp | offsetof(struct xpvnv, xnv_u.xnv_nv)
1348
1349 #if PERL_VERSION >= 10
1350 #define NV_cop_seq_range_low_ix \
1351                         sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
1352 #define NV_cop_seq_range_high_ix \
1353                         sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
1354 #define NV_parent_pad_index_ix \
1355                         sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow)
1356 #define NV_parent_fakelex_flags_ix \
1357                         sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xhigh)
1358 #else
1359 #define NV_cop_seq_range_low_ix \
1360                         sv_NVp | offsetof(struct xpvnv, xnv_nv)
1361 #define NV_cop_seq_range_high_ix \
1362                         sv_UVp | offsetof(struct xpvnv, xuv_uv)
1363 #define NV_parent_pad_index_ix \
1364                         sv_NVp | offsetof(struct xpvnv, xnv_nv)
1365 #define NV_parent_fakelex_flags_ix \
1366                         sv_UVp | offsetof(struct xpvnv, xuv_uv)
1367 #endif
1368
1369 #define PV_cur_ix       sv_STRLENp | offsetof(struct xpv, xpv_cur)
1370 #define PV_len_ix       sv_STRLENp | offsetof(struct xpv, xpv_len)
1371
1372 #define PVMG_stash_ix   sv_SVp | offsetof(struct xpvmg, xmg_stash)
1373
1374 #define PVLV_targoff_ix sv_U32p | offsetof(struct xpvlv, xlv_targoff)
1375 #define PVLV_targlen_ix sv_U32p | offsetof(struct xpvlv, xlv_targlen)
1376 #define PVLV_targ_ix    sv_SVp | offsetof(struct xpvlv, xlv_targ)
1377 #define PVLV_type_ix    sv_char_p | offsetof(struct xpvlv, xlv_type)
1378
1379 #if PERL_VERSION >= 10
1380 #define PVGV_stash_ix   sv_SVp | offsetof(struct xpvgv, xnv_u.xgv_stash)
1381 #define PVGV_flags_ix   sv_STRLENp | offsetof(struct xpvgv, xpv_cur)
1382 #define PVIO_lines_ix   sv_IVp | offsetof(struct xpvio, xiv_iv)
1383 #else
1384 #define PVGV_stash_ix   sv_SVp | offsetof(struct xpvgv, xgv_stash)
1385 #define PVGV_flags_ix   sv_U8p | offsetof(struct xpvgv, xgv_flags)
1386 #define PVIO_lines_ix   sv_IVp | offsetof(struct xpvio, xio_lines)
1387 #endif
1388
1389 #define PVIO_page_ix        sv_IVp | offsetof(struct xpvio, xio_page)
1390 #define PVIO_page_len_ix    sv_IVp | offsetof(struct xpvio, xio_page_len)
1391 #define PVIO_lines_left_ix  sv_IVp | offsetof(struct xpvio, xio_lines_left)
1392 #define PVIO_top_name_ix    sv_char_pp | offsetof(struct xpvio, xio_top_name)
1393 #define PVIO_top_gv_ix      sv_SVp | offsetof(struct xpvio, xio_top_gv)
1394 #define PVIO_fmt_name_ix    sv_char_pp | offsetof(struct xpvio, xio_fmt_name)
1395 #define PVIO_fmt_gv_ix      sv_SVp | offsetof(struct xpvio, xio_fmt_gv)
1396 #define PVIO_bottom_name_ix sv_char_pp | offsetof(struct xpvio, xio_bottom_name)
1397 #define PVIO_bottom_gv_ix   sv_SVp | offsetof(struct xpvio, xio_bottom_gv)
1398 #define PVIO_type_ix        sv_char_p | offsetof(struct xpvio, xio_type)
1399 #define PVIO_flags_ix       sv_U8p | offsetof(struct xpvio, xio_flags)
1400
1401 #define PVAV_max_ix     sv_SSize_tp | offsetof(struct xpvav, xav_max)
1402
1403 #define PVFM_lines_ix   sv_IVp | offsetof(struct xpvfm, xfm_lines)
1404
1405 # The type checking code in B has always been identical for all SV types,
1406 # irrespective of whether the action is actually defined on that SV.
1407 # We should fix this
1408 void
1409 IVX(sv)
1410         B::SV           sv
1411     ALIAS:
1412         B::IV::IVX = IV_ivx_ix
1413         B::IV::UVX = IV_uvx_ix
1414         B::NV::NVX = NV_nvx_ix
1415         B::NV::COP_SEQ_RANGE_LOW = NV_cop_seq_range_low_ix
1416         B::NV::COP_SEQ_RANGE_HIGH = NV_cop_seq_range_high_ix
1417         B::NV::PARENT_PAD_INDEX = NV_parent_pad_index_ix
1418         B::NV::PARENT_FAKELEX_FLAGS = NV_parent_fakelex_flags_ix
1419         B::PV::CUR = PV_cur_ix
1420         B::PV::LEN = PV_len_ix
1421         B::PVMG::SvSTASH = PVMG_stash_ix
1422         B::PVLV::TARGOFF = PVLV_targoff_ix
1423         B::PVLV::TARGLEN = PVLV_targlen_ix
1424         B::PVLV::TARG = PVLV_targ_ix
1425         B::PVLV::TYPE = PVLV_type_ix
1426         B::GV::STASH = PVGV_stash_ix
1427         B::GV::GvFLAGS = PVGV_flags_ix
1428         B::IO::LINES =  PVIO_lines_ix
1429         B::IO::PAGE = PVIO_page_ix
1430         B::IO::PAGE_LEN = PVIO_page_len_ix
1431         B::IO::LINES_LEFT = PVIO_lines_left_ix
1432         B::IO::TOP_NAME = PVIO_top_name_ix
1433         B::IO::TOP_GV = PVIO_top_gv_ix
1434         B::IO::FMT_NAME = PVIO_fmt_name_ix
1435         B::IO::FMT_GV = PVIO_fmt_gv_ix
1436         B::IO::BOTTOM_NAME = PVIO_bottom_name_ix
1437         B::IO::BOTTOM_GV = PVIO_bottom_gv_ix
1438         B::IO::IoTYPE = PVIO_type_ix
1439         B::IO::IoFLAGS = PVIO_flags_ix
1440         B::AV::MAX = PVAV_max_ix
1441         B::FM::LINES = PVFM_lines_ix
1442     PREINIT:
1443         char *ptr;
1444         SV *ret;
1445     PPCODE:
1446         ptr = (ix & 0xFFFF) + (char *)SvANY(sv);
1447         switch ((U8)(ix >> 16)) {
1448         case (U8)(sv_SVp >> 16):
1449             ret = make_sv_object(aTHX_ NULL, *((SV **)ptr));
1450             break;
1451         case (U8)(sv_IVp >> 16):
1452             ret = sv_2mortal(newSViv(*((IV *)ptr)));
1453             break;
1454         case (U8)(sv_UVp >> 16):
1455             ret = sv_2mortal(newSVuv(*((UV *)ptr)));
1456             break;
1457         case (U8)(sv_STRLENp >> 16):
1458             ret = sv_2mortal(newSVuv(*((STRLEN *)ptr)));
1459             break;
1460         case (U8)(sv_U32p >> 16):
1461             ret = sv_2mortal(newSVuv(*((U32 *)ptr)));
1462             break;
1463         case (U8)(sv_U8p >> 16):
1464             ret = sv_2mortal(newSVuv(*((U8 *)ptr)));
1465             break;
1466         case (U8)(sv_char_pp >> 16):
1467             ret = sv_2mortal(newSVpv(*((char **)ptr), 0));
1468             break;
1469         case (U8)(sv_NVp >> 16):
1470             ret = sv_2mortal(newSVnv(*((NV *)ptr)));
1471             break;
1472         case (U8)(sv_char_p >> 16):
1473             ret = newSVpvn_flags((char *)ptr, 1, SVs_TEMP);
1474             break;
1475         case (U8)(sv_SSize_tp >> 16):
1476             ret = sv_2mortal(newSViv(*((SSize_t *)ptr)));
1477             break;
1478         }
1479         ST(0) = ret;
1480         XSRETURN(1);
1481
1482 void
1483 packiv(sv)
1484         B::IV   sv
1485     ALIAS:
1486         needs64bits = 1
1487     CODE:
1488         if (ix) {
1489             ST(0) = boolSV((I32)SvIVX(sv) != SvIVX(sv));
1490         } else if (sizeof(IV) == 8) {
1491             U32 wp[2];
1492             const IV iv = SvIVX(sv);
1493             /*
1494              * The following way of spelling 32 is to stop compilers on
1495              * 32-bit architectures from moaning about the shift count
1496              * being >= the width of the type. Such architectures don't
1497              * reach this code anyway (unless sizeof(IV) > 8 but then
1498              * everything else breaks too so I'm not fussed at the moment).
1499              */
1500 #ifdef UV_IS_QUAD
1501             wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1502 #else
1503             wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1504 #endif
1505             wp[1] = htonl(iv & 0xffffffff);
1506             ST(0) = newSVpvn_flags((char *)wp, 8, SVs_TEMP);
1507         } else {
1508             U32 w = htonl((U32)SvIVX(sv));
1509             ST(0) = newSVpvn_flags((char *)&w, 4, SVs_TEMP);
1510         }
1511
1512 #if PERL_VERSION >= 11
1513 #  The input typemap checking makes no distinction between different SV types,
1514 #  so the XS body will generate the same C code, despite the different XS
1515 #  "types". So there is no change in behaviour from doing newXS like this,
1516 #  compared with the old approach of having a (near) duplicate XS body.
1517 #  We should fix the typemap checking.
1518
1519 BOOT:
1520         newXS("B::IV::RV", XS_B__PV_RV, __FILE__);
1521
1522 #endif
1523
1524 MODULE = B      PACKAGE = B::NV         PREFIX = Sv
1525
1526 NV
1527 SvNV(sv)
1528         B::NV   sv
1529
1530 #if PERL_VERSION < 11
1531
1532 MODULE = B      PACKAGE = B::RV         PREFIX = Sv
1533
1534 B::SV
1535 SvRV(sv)
1536         B::RV   sv
1537
1538 #endif
1539
1540 MODULE = B      PACKAGE = B::PV         PREFIX = Sv
1541
1542 char*
1543 SvPVX(sv)
1544         B::PV   sv
1545
1546 B::SV
1547 SvRV(sv)
1548         B::PV   sv
1549     CODE:
1550         if( SvROK(sv) ) {
1551             RETVAL = SvRV(sv);
1552         }
1553         else {
1554             croak( "argument is not SvROK" );
1555         }
1556     OUTPUT:
1557         RETVAL
1558
1559 void
1560 SvPV(sv)
1561         B::PV   sv
1562     CODE:
1563         if( SvPOK(sv) ) {
1564             STRLEN len = SvCUR(sv);
1565             const char *p = SvPVX_const(sv);
1566 #if PERL_VERSION < 10
1567             /* Before 5.10 (well 931b58fb28fa5ca7), PAD_COMPNAME_GEN was stored
1568                in SvCUR(), which meant we had to attempt this special casing
1569                to avoid tripping up over variable names in the pads.  */
1570             if((SvLEN(sv) && len >= SvLEN(sv))) {
1571                 /* It claims to be longer than the space allocated for it -
1572                    presuambly it's a variable name in the pad  */
1573                 len = strlen(p);
1574             }
1575 #endif
1576             ST(0) = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
1577         }
1578         else {
1579             /* XXX for backward compatibility, but should fail */
1580             /* croak( "argument is not SvPOK" ); */
1581             ST(0) = sv_newmortal();
1582         }
1583
1584 # This used to read 257. I think that that was buggy - should have been 258.
1585 # (The "\0", the flags byte, and 256 for the table.  Not that anything
1586 # anywhere calls this method.  NWC.
1587 void
1588 SvPVBM(sv)
1589         B::PV   sv
1590     CODE:
1591         ST(0) = newSVpvn_flags(SvPVX_const(sv),
1592             SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0),
1593             SVs_TEMP);
1594
1595 MODULE = B      PACKAGE = B::PVMG       PREFIX = Sv
1596
1597 void
1598 SvMAGIC(sv)
1599         B::PVMG sv
1600         MAGIC * mg = NO_INIT
1601     PPCODE:
1602         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
1603             XPUSHs(make_mg_object(aTHX_ mg));
1604
1605 MODULE = B      PACKAGE = B::REGEXP
1606
1607 #if PERL_VERSION >= 11
1608
1609 IV
1610 REGEX(sv)
1611         B::REGEXP       sv
1612     CODE:
1613         /* FIXME - can we code this method more efficiently?  */
1614         RETVAL = PTR2IV(sv);
1615     OUTPUT:
1616         RETVAL
1617
1618 SV*
1619 precomp(sv)
1620         B::REGEXP       sv
1621     CODE:
1622         RETVAL = newSVpvn( RX_PRECOMP(sv), RX_PRELEN(sv) );
1623     OUTPUT:
1624         RETVAL
1625
1626 #endif
1627
1628 #define MgMOREMAGIC(mg) mg->mg_moremagic
1629 #define MgPRIVATE(mg) mg->mg_private
1630 #define MgTYPE(mg) mg->mg_type
1631 #define MgFLAGS(mg) mg->mg_flags
1632 #define MgOBJ(mg) mg->mg_obj
1633 #define MgLENGTH(mg) mg->mg_len
1634 #define MgREGEX(mg) PTR2IV(mg->mg_obj)
1635
1636 MODULE = B      PACKAGE = B::MAGIC      PREFIX = Mg     
1637
1638 B::MAGIC
1639 MgMOREMAGIC(mg)
1640         B::MAGIC        mg
1641      CODE:
1642         if( MgMOREMAGIC(mg) ) {
1643             RETVAL = MgMOREMAGIC(mg);
1644         }
1645         else {
1646             XSRETURN_UNDEF;
1647         }
1648      OUTPUT:
1649         RETVAL
1650
1651 U16
1652 MgPRIVATE(mg)
1653         B::MAGIC        mg
1654
1655 char
1656 MgTYPE(mg)
1657         B::MAGIC        mg
1658
1659 U8
1660 MgFLAGS(mg)
1661         B::MAGIC        mg
1662
1663 B::SV
1664 MgOBJ(mg)
1665         B::MAGIC        mg
1666
1667 IV
1668 MgREGEX(mg)
1669         B::MAGIC        mg
1670     CODE:
1671         if(mg->mg_type == PERL_MAGIC_qr) {
1672             RETVAL = MgREGEX(mg);
1673         }
1674         else {
1675             croak( "REGEX is only meaningful on r-magic" );
1676         }
1677     OUTPUT:
1678         RETVAL
1679
1680 SV*
1681 precomp(mg)
1682         B::MAGIC        mg
1683     CODE:
1684         if (mg->mg_type == PERL_MAGIC_qr) {
1685             REGEXP* rx = (REGEXP*)mg->mg_obj;
1686             RETVAL = Nullsv;
1687             if( rx )
1688                 RETVAL = newSVpvn( RX_PRECOMP(rx), RX_PRELEN(rx) );
1689         }
1690         else {
1691             croak( "precomp is only meaningful on r-magic" );
1692         }
1693     OUTPUT:
1694         RETVAL
1695
1696 I32 
1697 MgLENGTH(mg)
1698         B::MAGIC        mg
1699  
1700 void
1701 MgPTR(mg)
1702         B::MAGIC        mg
1703     CODE:
1704         if (mg->mg_ptr){
1705                 if (mg->mg_len >= 0){
1706                         ST(0) = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
1707                 } else if (mg->mg_len == HEf_SVKEY) {
1708                         ST(0) = make_sv_object(aTHX_ NULL, (SV*)mg->mg_ptr);
1709                 } else
1710                     ST(0) = sv_newmortal();
1711         } else
1712             ST(0) = sv_newmortal();
1713
1714 MODULE = B      PACKAGE = B::BM         PREFIX = Bm
1715
1716 I32
1717 BmUSEFUL(sv)
1718         B::BM   sv
1719
1720 U32
1721 BmPREVIOUS(sv)
1722         B::BM   sv
1723
1724 U8
1725 BmRARE(sv)
1726         B::BM   sv
1727
1728 void
1729 BmTABLE(sv)
1730         B::BM   sv
1731         STRLEN  len = NO_INIT
1732         char *  str = NO_INIT
1733     CODE:
1734         str = SvPV(sv, len);
1735         /* Boyer-Moore table is just after string and its safety-margin \0 */
1736         ST(0) = newSVpvn_flags(str + len + PERL_FBM_TABLE_OFFSET, 256, SVs_TEMP);
1737
1738 MODULE = B      PACKAGE = B::GV         PREFIX = Gv
1739
1740 void
1741 GvNAME(gv)
1742         B::GV   gv
1743     ALIAS:
1744         FILE = 1
1745     CODE:
1746 #if PERL_VERSION >= 10
1747         ST(0) = sv_2mortal(newSVhek(ix ? GvFILE_HEK(gv) : GvNAME_HEK(gv)));
1748 #else
1749         ST(0) = ix ? sv_2mortal(newSVpv(GvFILE(gv), 0))
1750             : newSVpvn_flags(GvNAME(gv), GvNAMELEN(gv), SVs_TEMP);
1751 #endif
1752
1753 bool
1754 is_empty(gv)
1755         B::GV   gv
1756     ALIAS:
1757         isGV_with_GP = 1
1758     CODE:
1759         if (ix) {
1760 #if PERL_VERSION >= 9
1761             RETVAL = isGV_with_GP(gv) ? TRUE : FALSE;
1762 #else
1763             RETVAL = TRUE; /* In 5.8 and earlier they all are.  */
1764 #endif
1765         } else {
1766             RETVAL = GvGP(gv) == Null(GP*);
1767         }
1768     OUTPUT:
1769         RETVAL
1770
1771 void*
1772 GvGP(gv)
1773         B::GV   gv
1774
1775 #define GP_sv_ix        SVp | offsetof(struct gp, gp_sv)
1776 #define GP_io_ix        SVp | offsetof(struct gp, gp_io)
1777 #define GP_cv_ix        SVp | offsetof(struct gp, gp_cv)
1778 #define GP_cvgen_ix     U32p | offsetof(struct gp, gp_cvgen)
1779 #define GP_refcnt_ix    U32p | offsetof(struct gp, gp_refcnt)
1780 #define GP_hv_ix        SVp | offsetof(struct gp, gp_hv)
1781 #define GP_av_ix        SVp | offsetof(struct gp, gp_av)
1782 #define GP_form_ix      SVp | offsetof(struct gp, gp_form)
1783 #define GP_egv_ix       SVp | offsetof(struct gp, gp_egv)
1784 #define GP_line_ix      line_tp | offsetof(struct gp, gp_line)
1785
1786 void
1787 SV(gv)
1788         B::GV   gv
1789     ALIAS:
1790         SV = GP_sv_ix
1791         IO = GP_io_ix
1792         CV = GP_cv_ix
1793         CVGEN = GP_cvgen_ix
1794         GvREFCNT = GP_refcnt_ix
1795         HV = GP_hv_ix
1796         AV = GP_av_ix
1797         FORM = GP_form_ix
1798         EGV = GP_egv_ix
1799         LINE = GP_line_ix
1800     PREINIT:
1801         GP *gp;
1802         char *ptr;
1803         SV *ret;
1804     PPCODE:
1805         gp = GvGP(gv);
1806         if (!gp) {
1807             const GV *const gv = CvGV(cv);
1808             Perl_croak(aTHX_ "NULL gp in B::GV::%s", gv ? GvNAME(gv) : "???");
1809         }
1810         ptr = (ix & 0xFFFF) + (char *)gp;
1811         switch ((U8)(ix >> 16)) {
1812         case (U8)(SVp >> 16):
1813             ret = make_sv_object(aTHX_ NULL, *((SV **)ptr));
1814             break;
1815         case (U8)(U32p >> 16):
1816             ret = sv_2mortal(newSVuv(*((U32*)ptr)));
1817             break;
1818         case (U8)(line_tp >> 16):
1819             ret = sv_2mortal(newSVuv(*((line_t *)ptr)));
1820             break;
1821         }
1822         ST(0) = ret;
1823         XSRETURN(1);
1824
1825 B::GV
1826 GvFILEGV(gv)
1827         B::GV   gv
1828
1829 MODULE = B      PACKAGE = B::IO         PREFIX = Io
1830
1831 #if PERL_VERSION <= 8
1832
1833 short
1834 IoSUBPROCESS(io)
1835         B::IO   io
1836
1837 #endif
1838
1839 bool
1840 IsSTD(io,name)
1841         B::IO   io
1842         const char*     name
1843     PREINIT:
1844         PerlIO* handle = 0;
1845     CODE:
1846         if( strEQ( name, "stdin" ) ) {
1847             handle = PerlIO_stdin();
1848         }
1849         else if( strEQ( name, "stdout" ) ) {
1850             handle = PerlIO_stdout();
1851         }
1852         else if( strEQ( name, "stderr" ) ) {
1853             handle = PerlIO_stderr();
1854         }
1855         else {
1856             croak( "Invalid value '%s'", name );
1857         }
1858         RETVAL = handle == IoIFP(io);
1859     OUTPUT:
1860         RETVAL
1861
1862 MODULE = B      PACKAGE = B::AV         PREFIX = Av
1863
1864 SSize_t
1865 AvFILL(av)
1866         B::AV   av
1867
1868 void
1869 AvARRAY(av)
1870         B::AV   av
1871     PPCODE:
1872         if (AvFILL(av) >= 0) {
1873             SV **svp = AvARRAY(av);
1874             I32 i;
1875             for (i = 0; i <= AvFILL(av); i++)
1876                 XPUSHs(make_sv_object(aTHX_ NULL, svp[i]));
1877         }
1878
1879 void
1880 AvARRAYelt(av, idx)
1881         B::AV   av
1882         int     idx
1883     PPCODE:
1884         if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
1885             XPUSHs(make_sv_object(aTHX_ NULL, (AvARRAY(av)[idx])));
1886         else
1887             XPUSHs(make_sv_object(aTHX_ NULL, NULL));
1888
1889 #if PERL_VERSION < 9
1890                                    
1891 #define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1892
1893 IV
1894 AvOFF(av)
1895         B::AV   av
1896
1897 MODULE = B      PACKAGE = B::AV
1898
1899 U8
1900 AvFLAGS(av)
1901         B::AV   av
1902
1903 #endif
1904
1905 MODULE = B      PACKAGE = B::CV         PREFIX = Cv
1906
1907 U32
1908 CvCONST(cv)
1909         B::CV   cv
1910
1911 B::HV
1912 CvSTASH(cv)
1913         B::CV   cv
1914
1915 B::OP
1916 CvSTART(cv)
1917         B::CV   cv
1918     ALIAS:
1919         ROOT = 1
1920     CODE:
1921         RETVAL = CvISXSUB(cv) ? NULL : ix ? CvROOT(cv) : CvSTART(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_ NULL, (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_ NULL, 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*)cophh_2hv(h, 0) );
2046     OUTPUT:
2047         RETVAL
2048
2049 #endif