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