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_warnings_object(pTHX_ SV *arg, STRLEN *warnings)
252 const char *type = 0;
254 IV iv = sizeof(specialsv_list)/sizeof(SV*);
256 /* Counting down is deliberate. Before the split between make_sv_object
257 and make_warnings_obj there appeared to be a bug - Nullsv and pWARN_STD
258 were both 0, so you could never get a B::SPECIAL for pWARN_STD */
261 if ((SV*)warnings == specialsv_list[iv]) {
267 sv_setiv(newSVrv(arg, type), iv);
269 /* B assumes that warnings are a regular SV. Seems easier to keep it
270 happy by making them into a regular SV. */
271 SV *temp = newSVpvn((char *)(warnings + 1), *warnings);
274 type = svclassnames[SvTYPE(temp)];
275 target = newSVrv(arg, type);
277 sv_setiv(target, iv);
279 /* Need to keep our "temp" around as long as the target exists.
280 Simplest way seems to be to hang it from magic, and let that clear
281 it up. No vtable, so won't actually get in the way of anything. */
282 sv_magicext(target, temp, PERL_MAGIC_sv, NULL, NULL, 0);
283 /* magic object has had its reference count increased, so we must drop
291 make_mg_object(pTHX_ SV *arg, MAGIC *mg)
293 sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg));
298 cstring(pTHX_ SV *sv, bool perlstyle)
300 SV *sstr = newSVpvn("", 0);
303 sv_setpvn(sstr, "0", 1);
304 else if (perlstyle && SvUTF8(sv)) {
305 SV *tmpsv = sv_newmortal(); /* Temporary SV to feed sv_uni_display */
306 const STRLEN len = SvCUR(sv);
307 const char *s = sv_uni_display(tmpsv, sv, 8*len, UNI_DISPLAY_QQ);
308 sv_setpvn(sstr,"\"",1);
312 sv_catpvn(sstr, "\\\"", 2);
314 sv_catpvn(sstr, "\\$", 2);
316 sv_catpvn(sstr, "\\@", 2);
319 if (strchr("nrftax\\",*(s+1)))
320 sv_catpvn(sstr, s++, 2);
322 sv_catpvn(sstr, "\\\\", 2);
324 else /* should always be printable */
325 sv_catpvn(sstr, s, 1);
328 sv_catpv(sstr, "\"");
335 const char *s = SvPV(sv, len);
336 sv_catpv(sstr, "\"");
337 for (; len; len--, s++)
339 /* At least try a little for readability */
341 sv_catpv(sstr, "\\\"");
343 sv_catpv(sstr, "\\\\");
344 /* trigraphs - bleagh */
345 else if (!perlstyle && *s == '?' && len>=3 && s[1] == '?') {
346 char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
347 sprintf(escbuff, "\\%03o", '?');
348 sv_catpv(sstr, escbuff);
350 else if (perlstyle && *s == '$')
351 sv_catpv(sstr, "\\$");
352 else if (perlstyle && *s == '@')
353 sv_catpv(sstr, "\\@");
355 else if (isPRINT(*s))
357 else if (*s >= ' ' && *s < 127)
359 sv_catpvn(sstr, s, 1);
361 sv_catpv(sstr, "\\n");
363 sv_catpv(sstr, "\\r");
365 sv_catpv(sstr, "\\t");
367 sv_catpv(sstr, "\\a");
369 sv_catpv(sstr, "\\b");
371 sv_catpv(sstr, "\\f");
372 else if (!perlstyle && *s == '\v')
373 sv_catpv(sstr, "\\v");
376 /* Don't want promotion of a signed -1 char in sprintf args */
377 char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
378 const unsigned char c = (unsigned char) *s;
379 sprintf(escbuff, "\\%03o", c);
380 sv_catpv(sstr, escbuff);
382 /* XXX Add line breaks if string is long */
384 sv_catpv(sstr, "\"");
392 SV *sstr = newSVpvn("'", 1);
393 const char *s = SvPV_nolen(sv);
396 sv_catpvn(sstr, "\\'", 2);
398 sv_catpvn(sstr, "\\\\", 2);
400 else if (isPRINT(*s))
402 else if (*s >= ' ' && *s < 127)
404 sv_catpvn(sstr, s, 1);
406 sv_catpvn(sstr, "\\n", 2);
408 sv_catpvn(sstr, "\\r", 2);
410 sv_catpvn(sstr, "\\t", 2);
412 sv_catpvn(sstr, "\\a", 2);
414 sv_catpvn(sstr, "\\b", 2);
416 sv_catpvn(sstr, "\\f", 2);
418 sv_catpvn(sstr, "\\v", 2);
421 /* no trigraph support */
422 char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
423 /* Don't want promotion of a signed -1 char in sprintf args */
424 unsigned char c = (unsigned char) *s;
425 sprintf(escbuff, "\\%03o", c);
426 sv_catpv(sstr, escbuff);
428 sv_catpvn(sstr, "'", 1);
433 walkoptree(pTHX_ SV *opsv, const char *method)
440 croak("opsv is not a reference");
441 opsv = sv_mortalcopy(opsv);
442 o = INT2PTR(OP*,SvIV((SV*)SvRV(opsv)));
443 if (walkoptree_debug) {
447 perl_call_method("walkoptree_debug", G_DISCARD);
452 perl_call_method(method, G_DISCARD);
453 if (o && (o->op_flags & OPf_KIDS)) {
454 for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) {
455 /* Use the same opsv. Rely on methods not to mess it up. */
456 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
457 walkoptree(aTHX_ opsv, method);
460 if (o && (cc_opclass(aTHX_ o) == OPc_PMOP) && o->op_type != OP_PUSHRE
461 && (kid = cPMOPo->op_pmreplroot))
463 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
464 walkoptree(aTHX_ opsv, method);
469 oplist(pTHX_ OP *o, SV **SP)
471 for(; o; o = o->op_next) {
473 #if PERL_VERSION >= 9
482 opsv = sv_newmortal();
483 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ (OP*)o)), PTR2IV(o));
485 switch (o->op_type) {
487 SP = oplist(aTHX_ cPMOPo->op_pmreplstart, SP);
490 if (o->op_flags & OPf_STACKED && o->op_flags & OPf_SPECIAL) {
491 OP *kid = cLISTOPo->op_first->op_sibling; /* pass pushmark */
492 kid = kUNOP->op_first; /* pass rv2gv */
493 kid = kUNOP->op_first; /* pass leave */
494 SP = oplist(aTHX_ kid->op_next, SP);
498 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
500 SP = oplist(aTHX_ cLOGOPo->op_other, SP);
503 SP = oplist(aTHX_ cLOOPo->op_lastop, SP);
504 SP = oplist(aTHX_ cLOOPo->op_nextop, SP);
505 SP = oplist(aTHX_ cLOOPo->op_redoop, SP);
513 typedef UNOP *B__UNOP;
514 typedef BINOP *B__BINOP;
515 typedef LOGOP *B__LOGOP;
516 typedef LISTOP *B__LISTOP;
517 typedef PMOP *B__PMOP;
518 typedef SVOP *B__SVOP;
519 typedef PADOP *B__PADOP;
520 typedef PVOP *B__PVOP;
521 typedef LOOP *B__LOOP;
539 typedef MAGIC *B__MAGIC;
541 MODULE = B PACKAGE = B PREFIX = B_
547 HV *stash = gv_stashpvn("B", 1, TRUE);
548 AV *export_ok = perl_get_av("B::EXPORT_OK",TRUE);
550 specialsv_list[0] = Nullsv;
551 specialsv_list[1] = &PL_sv_undef;
552 specialsv_list[2] = &PL_sv_yes;
553 specialsv_list[3] = &PL_sv_no;
554 specialsv_list[4] = (SV *) pWARN_ALL;
555 specialsv_list[5] = (SV *) pWARN_NONE;
556 specialsv_list[6] = (SV *) pWARN_STD;
557 #if PERL_VERSION <= 8
558 # define CVf_ASSERTION 0
563 #define B_main_cv() PL_main_cv
564 #define B_init_av() PL_initav
565 #define B_inc_gv() PL_incgv
566 #define B_check_av() PL_checkav_save
567 #define B_begin_av() PL_beginav_save
568 #define B_end_av() PL_endav
569 #define B_main_root() PL_main_root
570 #define B_main_start() PL_main_start
571 #define B_amagic_generation() PL_amagic_generation
572 #define B_sub_generation() PL_sub_generation
573 #define B_defstash() PL_defstash
574 #define B_curstash() PL_curstash
575 #define B_dowarn() PL_dowarn
576 #define B_comppadlist() (PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv))
577 #define B_sv_undef() &PL_sv_undef
578 #define B_sv_yes() &PL_sv_yes
579 #define B_sv_no() &PL_sv_no
580 #define B_formfeed() PL_formfeed
582 #define B_regex_padav() PL_regex_padav
617 B_amagic_generation()
649 ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_warnhook);
654 ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_diehook);
656 MODULE = B PACKAGE = B
659 walkoptree(opsv, method)
663 walkoptree(aTHX_ opsv, method);
666 walkoptree_debug(...)
669 RETVAL = walkoptree_debug;
670 if (items > 0 && SvTRUE(ST(1)))
671 walkoptree_debug = 1;
675 #define address(sv) PTR2IV(sv)
686 croak("argument is not a reference");
687 RETVAL = (SV*)SvRV(sv);
698 ST(0) = sv_newmortal();
699 if (strncmp(name,"pp_",3) == 0)
701 for (i = 0; i < PL_maxo; i++)
703 if (strcmp(name, PL_op_name[i]) == 0)
709 sv_setiv(ST(0),result);
716 ST(0) = sv_newmortal();
717 if (opnum >= 0 && opnum < PL_maxo) {
718 sv_setpvn(ST(0), "pp_", 3);
719 sv_catpv(ST(0), PL_op_name[opnum]);
728 char hexhash[19]; /* must fit "0xffffffffffffffff" plus trailing \0 */
729 const char *s = SvPV(sv, len);
730 PERL_HASH(hash, s, len);
731 sprintf(hexhash, "0x%"UVxf, (UV)hash);
732 ST(0) = sv_2mortal(newSVpv(hexhash, 0));
734 #define cast_I32(foo) (I32)foo
753 RETVAL = cstring(aTHX_ sv, 0);
761 RETVAL = cstring(aTHX_ sv, 1);
769 RETVAL = cchar(aTHX_ sv);
776 #if PERL_VERSION <= 8
777 # ifdef USE_5005THREADS
779 const STRLEN len = strlen(PL_threadsv_names);
782 for (i = 0; i < len; i++)
783 PUSHs(sv_2mortal(newSVpvn(&PL_threadsv_names[i], 1)));
787 #define OP_next(o) o->op_next
788 #define OP_sibling(o) o->op_sibling
789 #define OP_desc(o) (char *)PL_op_desc[o->op_type]
790 #define OP_targ(o) o->op_targ
791 #define OP_type(o) o->op_type
792 #if PERL_VERSION >= 9
793 # define OP_opt(o) o->op_opt
794 # define OP_static(o) o->op_static
796 # define OP_seq(o) o->op_seq
798 #define OP_flags(o) o->op_flags
799 #define OP_private(o) o->op_private
800 #define OP_spare(o) o->op_spare
802 MODULE = B PACKAGE = B::OP PREFIX = OP_
808 RETVAL = opsizes[cc_opclass(aTHX_ o)];
824 RETVAL = (char *)PL_op_name[o->op_type];
834 SV *sv = sv_newmortal();
836 sv_setpvn(sv, "PL_ppaddr[OP_", 13);
837 sv_catpv(sv, PL_op_name[o->op_type]);
838 for (i=13; (STRLEN)i < SvCUR(sv); ++i)
839 SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]);
855 #if PERL_VERSION >= 9
881 #if PERL_VERSION >= 9
893 SP = oplist(aTHX_ o, SP);
895 #define UNOP_first(o) o->op_first
897 MODULE = B PACKAGE = B::UNOP PREFIX = UNOP_
903 #define BINOP_last(o) o->op_last
905 MODULE = B PACKAGE = B::BINOP PREFIX = BINOP_
911 #define LOGOP_other(o) o->op_other
913 MODULE = B PACKAGE = B::LOGOP PREFIX = LOGOP_
919 MODULE = B PACKAGE = B::LISTOP PREFIX = LISTOP_
928 for (kid = o->op_first; kid; kid = kid->op_sibling)
934 #define PMOP_pmreplroot(o) o->op_pmreplroot
935 #define PMOP_pmreplstart(o) o->op_pmreplstart
936 #define PMOP_pmnext(o) o->op_pmnext
937 #define PMOP_pmregexp(o) PM_GETRE(o)
939 #define PMOP_pmoffset(o) o->op_pmoffset
940 #define PMOP_pmstashpv(o) o->op_pmstashpv
942 #define PMOP_pmstash(o) o->op_pmstash
944 #define PMOP_pmflags(o) o->op_pmflags
945 #define PMOP_pmpermflags(o) o->op_pmpermflags
946 #define PMOP_pmdynflags(o) o->op_pmdynflags
948 MODULE = B PACKAGE = B::PMOP PREFIX = PMOP_
955 ST(0) = sv_newmortal();
956 root = o->op_pmreplroot;
957 /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */
958 if (o->op_type == OP_PUSHRE) {
960 sv_setiv(ST(0), INT2PTR(PADOFFSET,root) );
962 sv_setiv(newSVrv(ST(0), root ?
963 svclassnames[SvTYPE((SV*)root)] : "B::SV"),
968 sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root));
1012 REGEXP * rx = NO_INIT
1014 ST(0) = sv_newmortal();
1017 sv_setpvn(ST(0), rx->precomp, rx->prelen);
1019 #define SVOP_sv(o) cSVOPo->op_sv
1020 #define SVOP_gv(o) ((GV*)cSVOPo->op_sv)
1022 MODULE = B PACKAGE = B::SVOP PREFIX = SVOP_
1032 #define PADOP_padix(o) o->op_padix
1033 #define PADOP_sv(o) (o->op_padix ? PAD_SVl(o->op_padix) : Nullsv)
1034 #define PADOP_gv(o) ((o->op_padix \
1035 && SvTYPE(PAD_SVl(o->op_padix)) == SVt_PVGV) \
1036 ? (GV*)PAD_SVl(o->op_padix) : Nullgv)
1038 MODULE = B PACKAGE = B::PADOP PREFIX = PADOP_
1052 MODULE = B PACKAGE = B::PVOP PREFIX = PVOP_
1059 * OP_TRANS uses op_pv to point to a table of 256 or >=258 shorts
1060 * whereas other PVOPs point to a null terminated string.
1062 if (o->op_type == OP_TRANS &&
1063 (o->op_private & OPpTRANS_COMPLEMENT) &&
1064 !(o->op_private & OPpTRANS_DELETE))
1066 const short* const tbl = (short*)o->op_pv;
1067 const short entries = 257 + tbl[256];
1068 ST(0) = sv_2mortal(newSVpv(o->op_pv, entries * sizeof(short)));
1070 else if (o->op_type == OP_TRANS) {
1071 ST(0) = sv_2mortal(newSVpv(o->op_pv, 256 * sizeof(short)));
1074 ST(0) = sv_2mortal(newSVpv(o->op_pv, 0));
1076 #define LOOP_redoop(o) o->op_redoop
1077 #define LOOP_nextop(o) o->op_nextop
1078 #define LOOP_lastop(o) o->op_lastop
1080 MODULE = B PACKAGE = B::LOOP PREFIX = LOOP_
1095 #define COP_label(o) o->cop_label
1096 #define COP_stashpv(o) CopSTASHPV(o)
1097 #define COP_stash(o) CopSTASH(o)
1098 #define COP_file(o) CopFILE(o)
1099 #define COP_filegv(o) CopFILEGV(o)
1100 #define COP_cop_seq(o) o->cop_seq
1101 #define COP_arybase(o) CopARYBASE_get(o)
1102 #define COP_line(o) CopLINE(o)
1103 #define COP_hints(o) CopHINTS_get(o)
1105 MODULE = B PACKAGE = B::COP PREFIX = COP_
1144 ST(0) = make_warnings_object(aTHX_ sv_newmortal(), o->cop_warnings);
1152 make_sv_object(aTHX_ sv_newmortal(),
1153 (CopHINTS_get(o) & HINT_LEXICAL_IO)
1154 ? Perl_refcounted_he_fetch(aTHX_ o->cop_hints_hash,
1163 MODULE = B PACKAGE = B::SV
1169 #define object_2svref(sv) sv
1176 MODULE = B PACKAGE = B::SV PREFIX = Sv
1198 MODULE = B PACKAGE = B::IV PREFIX = Sv
1213 MODULE = B PACKAGE = B::IV
1215 #define needs64bits(sv) ((I32)SvIVX(sv) != SvIVX(sv))
1225 if (sizeof(IV) == 8) {
1227 const IV iv = SvIVX(sv);
1229 * The following way of spelling 32 is to stop compilers on
1230 * 32-bit architectures from moaning about the shift count
1231 * being >= the width of the type. Such architectures don't
1232 * reach this code anyway (unless sizeof(IV) > 8 but then
1233 * everything else breaks too so I'm not fussed at the moment).
1236 wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1238 wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1240 wp[1] = htonl(iv & 0xffffffff);
1241 ST(0) = sv_2mortal(newSVpvn((char *)wp, 8));
1243 U32 w = htonl((U32)SvIVX(sv));
1244 ST(0) = sv_2mortal(newSVpvn((char *)&w, 4));
1247 MODULE = B PACKAGE = B::NV PREFIX = Sv
1257 MODULE = B PACKAGE = B::RV PREFIX = Sv
1263 MODULE = B PACKAGE = B::PV PREFIX = Sv
1277 croak( "argument is not SvROK" );
1286 ST(0) = sv_newmortal();
1288 /* FIXME - we need a better way for B to identify PVs that are
1289 in the pads as variable names. */
1290 if((SvLEN(sv) && SvCUR(sv) >= SvLEN(sv))) {
1291 /* It claims to be longer than the space allocated for it -
1292 presuambly it's a variable name in the pad */
1293 sv_setpv(ST(0), SvPV_nolen_const(sv));
1295 sv_setpvn(ST(0), SvPVX_const(sv), SvCUR(sv));
1297 SvFLAGS(ST(0)) |= SvUTF8(sv);
1300 /* XXX for backward compatibility, but should fail */
1301 /* croak( "argument is not SvPOK" ); */
1302 sv_setpvn(ST(0), NULL, 0);
1309 ST(0) = sv_newmortal();
1310 sv_setpvn(ST(0), SvPVX_const(sv),
1311 SvCUR(sv) + (SvTYPE(sv) == SVt_PVBM ? 257 : 0));
1322 MODULE = B PACKAGE = B::PVMG PREFIX = Sv
1327 MAGIC * mg = NO_INIT
1329 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
1330 XPUSHs(make_mg_object(aTHX_ sv_newmortal(), mg));
1332 MODULE = B PACKAGE = B::PVMG
1338 #define MgMOREMAGIC(mg) mg->mg_moremagic
1339 #define MgPRIVATE(mg) mg->mg_private
1340 #define MgTYPE(mg) mg->mg_type
1341 #define MgFLAGS(mg) mg->mg_flags
1342 #define MgOBJ(mg) mg->mg_obj
1343 #define MgLENGTH(mg) mg->mg_len
1344 #define MgREGEX(mg) PTR2IV(mg->mg_obj)
1346 MODULE = B PACKAGE = B::MAGIC PREFIX = Mg
1352 if( MgMOREMAGIC(mg) ) {
1353 RETVAL = MgMOREMAGIC(mg);
1381 if(mg->mg_type == PERL_MAGIC_qr) {
1382 RETVAL = MgREGEX(mg);
1385 croak( "REGEX is only meaningful on r-magic" );
1394 if (mg->mg_type == PERL_MAGIC_qr) {
1395 REGEXP* rx = (REGEXP*)mg->mg_obj;
1398 RETVAL = newSVpvn( rx->precomp, rx->prelen );
1401 croak( "precomp is only meaningful on r-magic" );
1414 ST(0) = sv_newmortal();
1416 if (mg->mg_len >= 0){
1417 sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len);
1418 } else if (mg->mg_len == HEf_SVKEY) {
1419 ST(0) = make_sv_object(aTHX_
1420 sv_newmortal(), (SV*)mg->mg_ptr);
1424 MODULE = B PACKAGE = B::PVLV PREFIX = Lv
1442 MODULE = B PACKAGE = B::BM PREFIX = Bm
1459 STRLEN len = NO_INIT
1460 char * str = NO_INIT
1462 str = SvPV(sv, len);
1463 /* Boyer-Moore table is just after string and its safety-margin \0 */
1464 ST(0) = sv_2mortal(newSVpvn(str + len + 1, 256));
1466 MODULE = B PACKAGE = B::GV PREFIX = Gv
1472 ST(0) = sv_2mortal(newSVpvn(GvNAME(gv), GvNAMELEN(gv)));
1478 RETVAL = GvGP(gv) == Null(GP*);
1502 RETVAL = (SV*)GvFORM(gv);
1538 MODULE = B PACKAGE = B::GV
1548 MODULE = B PACKAGE = B::IO PREFIX = Io
1601 if( strEQ( name, "stdin" ) ) {
1602 handle = PerlIO_stdin();
1604 else if( strEQ( name, "stdout" ) ) {
1605 handle = PerlIO_stdout();
1607 else if( strEQ( name, "stderr" ) ) {
1608 handle = PerlIO_stderr();
1611 croak( "Invalid value '%s'", name );
1613 RETVAL = handle == IoIFP(io);
1617 MODULE = B PACKAGE = B::IO
1627 MODULE = B PACKAGE = B::AV PREFIX = Av
1637 #if PERL_VERSION < 9
1640 #define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1652 if (AvFILL(av) >= 0) {
1653 SV **svp = AvARRAY(av);
1655 for (i = 0; i <= AvFILL(av); i++)
1656 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), svp[i]));
1664 if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
1665 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), (AvARRAY(av)[idx])));
1667 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), NULL));
1669 #if PERL_VERSION < 9
1671 MODULE = B PACKAGE = B::AV
1679 MODULE = B PACKAGE = B::FM PREFIX = Fm
1685 MODULE = B PACKAGE = B::CV PREFIX = Cv
1699 RETVAL = CvISXSUB(cv) ? NULL : CvSTART(cv);
1707 RETVAL = CvISXSUB(cv) ? NULL : CvROOT(cv);
1739 ST(0) = sv_2mortal(newSViv(CvISXSUB(cv) ? PTR2IV(CvXSUB(cv)) : 0));
1746 ST(0) = CvCONST(cv) ?
1747 make_sv_object(aTHX_ sv_newmortal(),(SV *)CvXSUBANY(cv).any_ptr) :
1748 sv_2mortal(newSViv(CvISXSUB(cv) ? CvXSUBANY(cv).any_iv : 0));
1750 MODULE = B PACKAGE = B::CV
1756 MODULE = B PACKAGE = B::CV PREFIX = cv_
1763 MODULE = B PACKAGE = B::HV PREFIX = Hv
1785 #if PERL_VERSION < 9
1797 if (HvKEYS(hv) > 0) {
1801 (void)hv_iterinit(hv);
1802 EXTEND(sp, HvKEYS(hv) * 2);
1803 while ((sv = hv_iternextsv(hv, &key, &len))) {
1804 PUSHs(newSVpvn(key, len));
1805 PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv));