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