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