3 * Copyright (c) 1996 Malcolm Beattie
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.
10 #define PERL_NO_GET_CONTEXT
16 typedef PerlIO * InputStream;
18 typedef FILE * InputStream;
22 static const char* const svclassnames[] = {
61 static const char* const opclassnames[] = {
76 static const size_t opsizes[] = {
91 #define MY_CXT_KEY "B::_guts" XS_VERSION
94 int x_walkoptree_debug; /* Flag for walkoptree debug hook */
95 SV * x_specialsv_list[7];
100 #define walkoptree_debug (MY_CXT.x_walkoptree_debug)
101 #define specialsv_list (MY_CXT.x_specialsv_list)
104 cc_opclass(pTHX_ const OP *o)
110 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
112 if (o->op_type == OP_SASSIGN)
113 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
115 if (o->op_type == OP_AELEMFAST) {
116 if (o->op_flags & OPf_SPECIAL)
127 if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
128 o->op_type == OP_RCATLINE)
132 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
157 case OA_PVOP_OR_SVOP:
159 * Character translations (tr///) are usually a PVOP, keeping a
160 * pointer to a table of shorts used to look up translations.
161 * Under utf8, however, a simple table isn't practical; instead,
162 * the OP is an SVOP, and the SV is a reference to a swash
163 * (i.e., an RV pointing to an HV).
165 return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
166 ? OPc_SVOP : OPc_PVOP;
174 case OA_BASEOP_OR_UNOP:
176 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
177 * whether parens were seen. perly.y uses OPf_SPECIAL to
178 * signal whether a BASEOP had empty parens or none.
179 * Some other UNOPs are created later, though, so the best
180 * test is OPf_KIDS, which is set in newUNOP.
182 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
186 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
187 * the OPf_REF flag to distinguish between OP types instead of the
188 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
189 * return OPc_UNOP so that walkoptree can find our children. If
190 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
191 * (no argument to the operator) it's an OP; with OPf_REF set it's
192 * an SVOP (and op_sv is the GV for the filehandle argument).
194 return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
196 (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
198 (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
202 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
203 * label was omitted (in which case it's a BASEOP) or else a term was
204 * seen. In this last case, all except goto are definitely PVOP but
205 * goto is either a PVOP (with an ordinary constant label), an UNOP
206 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
207 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
210 if (o->op_flags & OPf_STACKED)
212 else if (o->op_flags & OPf_SPECIAL)
217 warn("can't determine class of operator %s, assuming BASEOP\n",
218 PL_op_name[o->op_type]);
223 cc_opclassname(pTHX_ const OP *o)
225 return (char *)opclassnames[cc_opclass(aTHX_ o)];
229 make_sv_object(pTHX_ SV *arg, SV *sv)
231 const char *type = 0;
235 for (iv = 0; iv < sizeof(specialsv_list)/sizeof(SV*); iv++) {
236 if (sv == specialsv_list[iv]) {
242 type = svclassnames[SvTYPE(sv)];
245 sv_setiv(newSVrv(arg, type), iv);
250 make_temp_object(pTHX_ SV *arg, SV *temp)
253 const char *const type = svclassnames[SvTYPE(temp)];
254 const IV iv = PTR2IV(temp);
256 target = newSVrv(arg, type);
257 sv_setiv(target, iv);
259 /* Need to keep our "temp" around as long as the target exists.
260 Simplest way seems to be to hang it from magic, and let that clear
261 it up. No vtable, so won't actually get in the way of anything. */
262 sv_magicext(target, temp, PERL_MAGIC_sv, NULL, NULL, 0);
263 /* magic object has had its reference count increased, so we must drop
270 make_warnings_object(pTHX_ SV *arg, STRLEN *warnings)
272 const char *type = 0;
274 IV iv = sizeof(specialsv_list)/sizeof(SV*);
276 /* Counting down is deliberate. Before the split between make_sv_object
277 and make_warnings_obj there appeared to be a bug - Nullsv and pWARN_STD
278 were both 0, so you could never get a B::SPECIAL for pWARN_STD */
281 if ((SV*)warnings == specialsv_list[iv]) {
287 sv_setiv(newSVrv(arg, type), iv);
290 /* B assumes that warnings are a regular SV. Seems easier to keep it
291 happy by making them into a regular SV. */
292 return make_temp_object(aTHX_ arg,
293 newSVpvn((char *)(warnings + 1), *warnings));
298 make_cop_io_object(pTHX_ SV *arg, COP *cop)
300 if (CopHINTS_get(cop) & HINT_LEXICAL_IO) {
301 /* I feel you should be able to simply SvREFCNT_inc the return value
302 from this, but if you do (and restore the line
303 my $ioix = $cop->io->ix;
304 in B::COP::bsave in Bytecode.pm, then you get errors about
305 "attempt to free temp prematurely ... during global destruction.
306 The SV's flags are consistent with the error, but quite how the
307 temp escaped from the save stack is not clear. */
308 SV *value = Perl_refcounted_he_fetch(aTHX_ cop->cop_hints_hash,
310 return make_temp_object(aTHX_ arg, newSVsv(value));
312 return make_sv_object(aTHX_ arg, NULL);
317 make_mg_object(pTHX_ SV *arg, MAGIC *mg)
319 sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg));
324 cstring(pTHX_ SV *sv, bool perlstyle)
326 SV *sstr = newSVpvn("", 0);
329 sv_setpvn(sstr, "0", 1);
330 else if (perlstyle && SvUTF8(sv)) {
331 SV *tmpsv = sv_newmortal(); /* Temporary SV to feed sv_uni_display */
332 const STRLEN len = SvCUR(sv);
333 const char *s = sv_uni_display(tmpsv, sv, 8*len, UNI_DISPLAY_QQ);
334 sv_setpvn(sstr,"\"",1);
338 sv_catpvn(sstr, "\\\"", 2);
340 sv_catpvn(sstr, "\\$", 2);
342 sv_catpvn(sstr, "\\@", 2);
345 if (strchr("nrftax\\",*(s+1)))
346 sv_catpvn(sstr, s++, 2);
348 sv_catpvn(sstr, "\\\\", 2);
350 else /* should always be printable */
351 sv_catpvn(sstr, s, 1);
354 sv_catpv(sstr, "\"");
361 const char *s = SvPV(sv, len);
362 sv_catpv(sstr, "\"");
363 for (; len; len--, s++)
365 /* At least try a little for readability */
367 sv_catpv(sstr, "\\\"");
369 sv_catpv(sstr, "\\\\");
370 /* trigraphs - bleagh */
371 else if (!perlstyle && *s == '?' && len>=3 && s[1] == '?') {
372 char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
373 sprintf(escbuff, "\\%03o", '?');
374 sv_catpv(sstr, escbuff);
376 else if (perlstyle && *s == '$')
377 sv_catpv(sstr, "\\$");
378 else if (perlstyle && *s == '@')
379 sv_catpv(sstr, "\\@");
381 else if (isPRINT(*s))
383 else if (*s >= ' ' && *s < 127)
385 sv_catpvn(sstr, s, 1);
387 sv_catpv(sstr, "\\n");
389 sv_catpv(sstr, "\\r");
391 sv_catpv(sstr, "\\t");
393 sv_catpv(sstr, "\\a");
395 sv_catpv(sstr, "\\b");
397 sv_catpv(sstr, "\\f");
398 else if (!perlstyle && *s == '\v')
399 sv_catpv(sstr, "\\v");
402 /* Don't want promotion of a signed -1 char in sprintf args */
403 char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
404 const unsigned char c = (unsigned char) *s;
405 sprintf(escbuff, "\\%03o", c);
406 sv_catpv(sstr, escbuff);
408 /* XXX Add line breaks if string is long */
410 sv_catpv(sstr, "\"");
418 SV *sstr = newSVpvn("'", 1);
419 const char *s = SvPV_nolen(sv);
422 sv_catpvn(sstr, "\\'", 2);
424 sv_catpvn(sstr, "\\\\", 2);
426 else if (isPRINT(*s))
428 else if (*s >= ' ' && *s < 127)
430 sv_catpvn(sstr, s, 1);
432 sv_catpvn(sstr, "\\n", 2);
434 sv_catpvn(sstr, "\\r", 2);
436 sv_catpvn(sstr, "\\t", 2);
438 sv_catpvn(sstr, "\\a", 2);
440 sv_catpvn(sstr, "\\b", 2);
442 sv_catpvn(sstr, "\\f", 2);
444 sv_catpvn(sstr, "\\v", 2);
447 /* no trigraph support */
448 char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
449 /* Don't want promotion of a signed -1 char in sprintf args */
450 unsigned char c = (unsigned char) *s;
451 sprintf(escbuff, "\\%03o", c);
452 sv_catpv(sstr, escbuff);
454 sv_catpvn(sstr, "'", 1);
459 walkoptree(pTHX_ SV *opsv, const char *method)
466 croak("opsv is not a reference");
467 opsv = sv_mortalcopy(opsv);
468 o = INT2PTR(OP*,SvIV((SV*)SvRV(opsv)));
469 if (walkoptree_debug) {
473 perl_call_method("walkoptree_debug", G_DISCARD);
478 perl_call_method(method, G_DISCARD);
479 if (o && (o->op_flags & OPf_KIDS)) {
480 for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) {
481 /* Use the same opsv. Rely on methods not to mess it up. */
482 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
483 walkoptree(aTHX_ opsv, method);
486 if (o && (cc_opclass(aTHX_ o) == OPc_PMOP) && o->op_type != OP_PUSHRE
487 && (kid = cPMOPo->op_pmreplroot))
489 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
490 walkoptree(aTHX_ opsv, method);
495 oplist(pTHX_ OP *o, SV **SP)
497 for(; o; o = o->op_next) {
499 #if PERL_VERSION >= 9
508 opsv = sv_newmortal();
509 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ (OP*)o)), PTR2IV(o));
511 switch (o->op_type) {
513 SP = oplist(aTHX_ cPMOPo->op_pmreplstart, SP);
516 if (o->op_flags & OPf_STACKED && o->op_flags & OPf_SPECIAL) {
517 OP *kid = cLISTOPo->op_first->op_sibling; /* pass pushmark */
518 kid = kUNOP->op_first; /* pass rv2gv */
519 kid = kUNOP->op_first; /* pass leave */
520 SP = oplist(aTHX_ kid->op_next, SP);
524 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
526 SP = oplist(aTHX_ cLOGOPo->op_other, SP);
529 SP = oplist(aTHX_ cLOOPo->op_lastop, SP);
530 SP = oplist(aTHX_ cLOOPo->op_nextop, SP);
531 SP = oplist(aTHX_ cLOOPo->op_redoop, SP);
539 typedef UNOP *B__UNOP;
540 typedef BINOP *B__BINOP;
541 typedef LOGOP *B__LOGOP;
542 typedef LISTOP *B__LISTOP;
543 typedef PMOP *B__PMOP;
544 typedef SVOP *B__SVOP;
545 typedef PADOP *B__PADOP;
546 typedef PVOP *B__PVOP;
547 typedef LOOP *B__LOOP;
565 typedef MAGIC *B__MAGIC;
567 MODULE = B PACKAGE = B PREFIX = B_
573 HV *stash = gv_stashpvn("B", 1, TRUE);
574 AV *export_ok = perl_get_av("B::EXPORT_OK",TRUE);
576 specialsv_list[0] = Nullsv;
577 specialsv_list[1] = &PL_sv_undef;
578 specialsv_list[2] = &PL_sv_yes;
579 specialsv_list[3] = &PL_sv_no;
580 specialsv_list[4] = (SV *) pWARN_ALL;
581 specialsv_list[5] = (SV *) pWARN_NONE;
582 specialsv_list[6] = (SV *) pWARN_STD;
583 #if PERL_VERSION <= 8
584 # define CVf_ASSERTION 0
589 #define B_main_cv() PL_main_cv
590 #define B_init_av() PL_initav
591 #define B_inc_gv() PL_incgv
592 #define B_check_av() PL_checkav_save
593 #define B_begin_av() PL_beginav_save
594 #define B_end_av() PL_endav
595 #define B_main_root() PL_main_root
596 #define B_main_start() PL_main_start
597 #define B_amagic_generation() PL_amagic_generation
598 #define B_sub_generation() PL_sub_generation
599 #define B_defstash() PL_defstash
600 #define B_curstash() PL_curstash
601 #define B_dowarn() PL_dowarn
602 #define B_comppadlist() (PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv))
603 #define B_sv_undef() &PL_sv_undef
604 #define B_sv_yes() &PL_sv_yes
605 #define B_sv_no() &PL_sv_no
606 #define B_formfeed() PL_formfeed
608 #define B_regex_padav() PL_regex_padav
643 B_amagic_generation()
675 ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_warnhook);
680 ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_diehook);
682 MODULE = B PACKAGE = B
685 walkoptree(opsv, method)
689 walkoptree(aTHX_ opsv, method);
692 walkoptree_debug(...)
695 RETVAL = walkoptree_debug;
696 if (items > 0 && SvTRUE(ST(1)))
697 walkoptree_debug = 1;
701 #define address(sv) PTR2IV(sv)
712 croak("argument is not a reference");
713 RETVAL = (SV*)SvRV(sv);
724 ST(0) = sv_newmortal();
725 if (strncmp(name,"pp_",3) == 0)
727 for (i = 0; i < PL_maxo; i++)
729 if (strcmp(name, PL_op_name[i]) == 0)
735 sv_setiv(ST(0),result);
742 ST(0) = sv_newmortal();
743 if (opnum >= 0 && opnum < PL_maxo) {
744 sv_setpvn(ST(0), "pp_", 3);
745 sv_catpv(ST(0), PL_op_name[opnum]);
754 char hexhash[19]; /* must fit "0xffffffffffffffff" plus trailing \0 */
755 const char *s = SvPV(sv, len);
756 PERL_HASH(hash, s, len);
757 sprintf(hexhash, "0x%"UVxf, (UV)hash);
758 ST(0) = sv_2mortal(newSVpv(hexhash, 0));
760 #define cast_I32(foo) (I32)foo
779 RETVAL = cstring(aTHX_ sv, 0);
787 RETVAL = cstring(aTHX_ sv, 1);
795 RETVAL = cchar(aTHX_ sv);
802 #if PERL_VERSION <= 8
803 # ifdef USE_5005THREADS
805 const STRLEN len = strlen(PL_threadsv_names);
808 for (i = 0; i < len; i++)
809 PUSHs(sv_2mortal(newSVpvn(&PL_threadsv_names[i], 1)));
813 #define OP_next(o) o->op_next
814 #define OP_sibling(o) o->op_sibling
815 #define OP_desc(o) (char *)PL_op_desc[o->op_type]
816 #define OP_targ(o) o->op_targ
817 #define OP_type(o) o->op_type
818 #if PERL_VERSION >= 9
819 # define OP_opt(o) o->op_opt
820 # define OP_static(o) o->op_static
822 # define OP_seq(o) o->op_seq
824 #define OP_flags(o) o->op_flags
825 #define OP_private(o) o->op_private
826 #define OP_spare(o) o->op_spare
828 MODULE = B PACKAGE = B::OP PREFIX = OP_
834 RETVAL = opsizes[cc_opclass(aTHX_ o)];
850 RETVAL = (char *)PL_op_name[o->op_type];
860 SV *sv = sv_newmortal();
862 sv_setpvn(sv, "PL_ppaddr[OP_", 13);
863 sv_catpv(sv, PL_op_name[o->op_type]);
864 for (i=13; (STRLEN)i < SvCUR(sv); ++i)
865 SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]);
881 #if PERL_VERSION >= 9
907 #if PERL_VERSION >= 9
919 SP = oplist(aTHX_ o, SP);
921 #define UNOP_first(o) o->op_first
923 MODULE = B PACKAGE = B::UNOP PREFIX = UNOP_
929 #define BINOP_last(o) o->op_last
931 MODULE = B PACKAGE = B::BINOP PREFIX = BINOP_
937 #define LOGOP_other(o) o->op_other
939 MODULE = B PACKAGE = B::LOGOP PREFIX = LOGOP_
945 MODULE = B PACKAGE = B::LISTOP PREFIX = LISTOP_
954 for (kid = o->op_first; kid; kid = kid->op_sibling)
960 #define PMOP_pmreplroot(o) o->op_pmreplroot
961 #define PMOP_pmreplstart(o) o->op_pmreplstart
962 #define PMOP_pmnext(o) o->op_pmnext
963 #define PMOP_pmregexp(o) PM_GETRE(o)
965 #define PMOP_pmoffset(o) o->op_pmoffset
966 #define PMOP_pmstashpv(o) o->op_pmstashpv
968 #define PMOP_pmstash(o) o->op_pmstash
970 #define PMOP_pmflags(o) o->op_pmflags
971 #define PMOP_pmpermflags(o) o->op_pmpermflags
972 #define PMOP_pmdynflags(o) o->op_pmdynflags
974 MODULE = B PACKAGE = B::PMOP PREFIX = PMOP_
981 ST(0) = sv_newmortal();
982 root = o->op_pmreplroot;
983 /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */
984 if (o->op_type == OP_PUSHRE) {
986 sv_setiv(ST(0), INT2PTR(PADOFFSET,root) );
988 sv_setiv(newSVrv(ST(0), root ?
989 svclassnames[SvTYPE((SV*)root)] : "B::SV"),
994 sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root));
1038 REGEXP * rx = NO_INIT
1040 ST(0) = sv_newmortal();
1043 sv_setpvn(ST(0), rx->precomp, rx->prelen);
1045 #define SVOP_sv(o) cSVOPo->op_sv
1046 #define SVOP_gv(o) ((GV*)cSVOPo->op_sv)
1048 MODULE = B PACKAGE = B::SVOP PREFIX = SVOP_
1058 #define PADOP_padix(o) o->op_padix
1059 #define PADOP_sv(o) (o->op_padix ? PAD_SVl(o->op_padix) : Nullsv)
1060 #define PADOP_gv(o) ((o->op_padix \
1061 && SvTYPE(PAD_SVl(o->op_padix)) == SVt_PVGV) \
1062 ? (GV*)PAD_SVl(o->op_padix) : Nullgv)
1064 MODULE = B PACKAGE = B::PADOP PREFIX = PADOP_
1078 MODULE = B PACKAGE = B::PVOP PREFIX = PVOP_
1085 * OP_TRANS uses op_pv to point to a table of 256 or >=258 shorts
1086 * whereas other PVOPs point to a null terminated string.
1088 if (o->op_type == OP_TRANS &&
1089 (o->op_private & OPpTRANS_COMPLEMENT) &&
1090 !(o->op_private & OPpTRANS_DELETE))
1092 const short* const tbl = (short*)o->op_pv;
1093 const short entries = 257 + tbl[256];
1094 ST(0) = sv_2mortal(newSVpv(o->op_pv, entries * sizeof(short)));
1096 else if (o->op_type == OP_TRANS) {
1097 ST(0) = sv_2mortal(newSVpv(o->op_pv, 256 * sizeof(short)));
1100 ST(0) = sv_2mortal(newSVpv(o->op_pv, 0));
1102 #define LOOP_redoop(o) o->op_redoop
1103 #define LOOP_nextop(o) o->op_nextop
1104 #define LOOP_lastop(o) o->op_lastop
1106 MODULE = B PACKAGE = B::LOOP PREFIX = LOOP_
1121 #define COP_label(o) o->cop_label
1122 #define COP_stashpv(o) CopSTASHPV(o)
1123 #define COP_stash(o) CopSTASH(o)
1124 #define COP_file(o) CopFILE(o)
1125 #define COP_filegv(o) CopFILEGV(o)
1126 #define COP_cop_seq(o) o->cop_seq
1127 #define COP_arybase(o) CopARYBASE_get(o)
1128 #define COP_line(o) CopLINE(o)
1129 #define COP_hints(o) CopHINTS_get(o)
1131 MODULE = B PACKAGE = B::COP PREFIX = COP_
1170 ST(0) = make_warnings_object(aTHX_ sv_newmortal(), o->cop_warnings);
1177 ST(0) = make_cop_io_object(aTHX_ sv_newmortal(), o);
1184 MODULE = B PACKAGE = B::SV
1190 #define object_2svref(sv) sv
1197 MODULE = B PACKAGE = B::SV PREFIX = Sv
1219 MODULE = B PACKAGE = B::IV PREFIX = Sv
1234 MODULE = B PACKAGE = B::IV
1236 #define needs64bits(sv) ((I32)SvIVX(sv) != SvIVX(sv))
1246 if (sizeof(IV) == 8) {
1248 const IV iv = SvIVX(sv);
1250 * The following way of spelling 32 is to stop compilers on
1251 * 32-bit architectures from moaning about the shift count
1252 * being >= the width of the type. Such architectures don't
1253 * reach this code anyway (unless sizeof(IV) > 8 but then
1254 * everything else breaks too so I'm not fussed at the moment).
1257 wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1259 wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1261 wp[1] = htonl(iv & 0xffffffff);
1262 ST(0) = sv_2mortal(newSVpvn((char *)wp, 8));
1264 U32 w = htonl((U32)SvIVX(sv));
1265 ST(0) = sv_2mortal(newSVpvn((char *)&w, 4));
1268 MODULE = B PACKAGE = B::NV PREFIX = Sv
1278 MODULE = B PACKAGE = B::RV PREFIX = Sv
1284 MODULE = B PACKAGE = B::PV PREFIX = Sv
1298 croak( "argument is not SvROK" );
1307 ST(0) = sv_newmortal();
1309 /* FIXME - we need a better way for B to identify PVs that are
1310 in the pads as variable names. */
1311 if((SvLEN(sv) && SvCUR(sv) >= SvLEN(sv))) {
1312 /* It claims to be longer than the space allocated for it -
1313 presuambly it's a variable name in the pad */
1314 sv_setpv(ST(0), SvPV_nolen_const(sv));
1316 sv_setpvn(ST(0), SvPVX_const(sv), SvCUR(sv));
1318 SvFLAGS(ST(0)) |= SvUTF8(sv);
1321 /* XXX for backward compatibility, but should fail */
1322 /* croak( "argument is not SvPOK" ); */
1323 sv_setpvn(ST(0), NULL, 0);
1330 ST(0) = sv_newmortal();
1331 sv_setpvn(ST(0), SvPVX_const(sv),
1332 SvCUR(sv) + (SvTYPE(sv) == SVt_PVBM ? 257 : 0));
1343 MODULE = B PACKAGE = B::PVMG PREFIX = Sv
1348 MAGIC * mg = NO_INIT
1350 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
1351 XPUSHs(make_mg_object(aTHX_ sv_newmortal(), mg));
1353 MODULE = B PACKAGE = B::PVMG
1359 #define MgMOREMAGIC(mg) mg->mg_moremagic
1360 #define MgPRIVATE(mg) mg->mg_private
1361 #define MgTYPE(mg) mg->mg_type
1362 #define MgFLAGS(mg) mg->mg_flags
1363 #define MgOBJ(mg) mg->mg_obj
1364 #define MgLENGTH(mg) mg->mg_len
1365 #define MgREGEX(mg) PTR2IV(mg->mg_obj)
1367 MODULE = B PACKAGE = B::MAGIC PREFIX = Mg
1373 if( MgMOREMAGIC(mg) ) {
1374 RETVAL = MgMOREMAGIC(mg);
1402 if(mg->mg_type == PERL_MAGIC_qr) {
1403 RETVAL = MgREGEX(mg);
1406 croak( "REGEX is only meaningful on r-magic" );
1415 if (mg->mg_type == PERL_MAGIC_qr) {
1416 REGEXP* rx = (REGEXP*)mg->mg_obj;
1419 RETVAL = newSVpvn( rx->precomp, rx->prelen );
1422 croak( "precomp is only meaningful on r-magic" );
1435 ST(0) = sv_newmortal();
1437 if (mg->mg_len >= 0){
1438 sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len);
1439 } else if (mg->mg_len == HEf_SVKEY) {
1440 ST(0) = make_sv_object(aTHX_
1441 sv_newmortal(), (SV*)mg->mg_ptr);
1445 MODULE = B PACKAGE = B::PVLV PREFIX = Lv
1463 MODULE = B PACKAGE = B::BM PREFIX = Bm
1480 STRLEN len = NO_INIT
1481 char * str = NO_INIT
1483 str = SvPV(sv, len);
1484 /* Boyer-Moore table is just after string and its safety-margin \0 */
1485 ST(0) = sv_2mortal(newSVpvn(str + len + 1, 256));
1487 MODULE = B PACKAGE = B::GV PREFIX = Gv
1493 ST(0) = sv_2mortal(newSVpvn(GvNAME(gv), GvNAMELEN(gv)));
1499 RETVAL = GvGP(gv) == Null(GP*);
1523 RETVAL = (SV*)GvFORM(gv);
1559 MODULE = B PACKAGE = B::GV
1569 MODULE = B PACKAGE = B::IO PREFIX = Io
1622 if( strEQ( name, "stdin" ) ) {
1623 handle = PerlIO_stdin();
1625 else if( strEQ( name, "stdout" ) ) {
1626 handle = PerlIO_stdout();
1628 else if( strEQ( name, "stderr" ) ) {
1629 handle = PerlIO_stderr();
1632 croak( "Invalid value '%s'", name );
1634 RETVAL = handle == IoIFP(io);
1638 MODULE = B PACKAGE = B::IO
1648 MODULE = B PACKAGE = B::AV PREFIX = Av
1658 #if PERL_VERSION < 9
1661 #define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1673 if (AvFILL(av) >= 0) {
1674 SV **svp = AvARRAY(av);
1676 for (i = 0; i <= AvFILL(av); i++)
1677 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), svp[i]));
1685 if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
1686 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), (AvARRAY(av)[idx])));
1688 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), NULL));
1690 #if PERL_VERSION < 9
1692 MODULE = B PACKAGE = B::AV
1700 MODULE = B PACKAGE = B::FM PREFIX = Fm
1706 MODULE = B PACKAGE = B::CV PREFIX = Cv
1720 RETVAL = CvISXSUB(cv) ? NULL : CvSTART(cv);
1728 RETVAL = CvISXSUB(cv) ? NULL : CvROOT(cv);
1760 ST(0) = sv_2mortal(newSViv(CvISXSUB(cv) ? PTR2IV(CvXSUB(cv)) : 0));
1767 ST(0) = CvCONST(cv) ?
1768 make_sv_object(aTHX_ sv_newmortal(),(SV *)CvXSUBANY(cv).any_ptr) :
1769 sv_2mortal(newSViv(CvISXSUB(cv) ? CvXSUBANY(cv).any_iv : 0));
1771 MODULE = B PACKAGE = B::CV
1777 MODULE = B PACKAGE = B::CV PREFIX = cv_
1784 MODULE = B PACKAGE = B::HV PREFIX = Hv
1806 #if PERL_VERSION < 9
1818 if (HvKEYS(hv) > 0) {
1822 (void)hv_iterinit(hv);
1823 EXTEND(sp, HvKEYS(hv) * 2);
1824 while ((sv = hv_iternextsv(hv, &key, &len))) {
1825 PUSHs(newSVpvn(key, len));
1826 PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv));