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[] = {
66 static const char* const opclassnames[] = {
81 static const size_t opsizes[] = {
96 #define MY_CXT_KEY "B::_guts" XS_VERSION
99 int x_walkoptree_debug; /* Flag for walkoptree debug hook */
100 SV * x_specialsv_list[7];
105 #define walkoptree_debug (MY_CXT.x_walkoptree_debug)
106 #define specialsv_list (MY_CXT.x_specialsv_list)
109 cc_opclass(pTHX_ const OP *o)
115 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
117 if (o->op_type == OP_SASSIGN)
118 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
120 if (o->op_type == OP_AELEMFAST) {
121 if (o->op_flags & OPf_SPECIAL)
132 if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
133 o->op_type == OP_RCATLINE)
137 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
162 case OA_PVOP_OR_SVOP:
164 * Character translations (tr///) are usually a PVOP, keeping a
165 * pointer to a table of shorts used to look up translations.
166 * Under utf8, however, a simple table isn't practical; instead,
167 * the OP is an SVOP, and the SV is a reference to a swash
168 * (i.e., an RV pointing to an HV).
170 return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
171 ? OPc_SVOP : OPc_PVOP;
179 case OA_BASEOP_OR_UNOP:
181 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
182 * whether parens were seen. perly.y uses OPf_SPECIAL to
183 * signal whether a BASEOP had empty parens or none.
184 * Some other UNOPs are created later, though, so the best
185 * test is OPf_KIDS, which is set in newUNOP.
187 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
191 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
192 * the OPf_REF flag to distinguish between OP types instead of the
193 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
194 * return OPc_UNOP so that walkoptree can find our children. If
195 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
196 * (no argument to the operator) it's an OP; with OPf_REF set it's
197 * an SVOP (and op_sv is the GV for the filehandle argument).
199 return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
201 (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
203 (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
207 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
208 * label was omitted (in which case it's a BASEOP) or else a term was
209 * seen. In this last case, all except goto are definitely PVOP but
210 * goto is either a PVOP (with an ordinary constant label), an UNOP
211 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
212 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
215 if (o->op_flags & OPf_STACKED)
217 else if (o->op_flags & OPf_SPECIAL)
222 warn("can't determine class of operator %s, assuming BASEOP\n",
223 PL_op_name[o->op_type]);
228 cc_opclassname(pTHX_ const OP *o)
230 return (char *)opclassnames[cc_opclass(aTHX_ o)];
234 make_sv_object(pTHX_ SV *arg, SV *sv)
236 const char *type = 0;
240 for (iv = 0; iv < sizeof(specialsv_list)/sizeof(SV*); iv++) {
241 if (sv == specialsv_list[iv]) {
247 type = svclassnames[SvTYPE(sv)];
250 sv_setiv(newSVrv(arg, type), iv);
255 make_temp_object(pTHX_ SV *arg, SV *temp)
258 const char *const type = svclassnames[SvTYPE(temp)];
259 const IV iv = PTR2IV(temp);
261 target = newSVrv(arg, type);
262 sv_setiv(target, iv);
264 /* Need to keep our "temp" around as long as the target exists.
265 Simplest way seems to be to hang it from magic, and let that clear
266 it up. No vtable, so won't actually get in the way of anything. */
267 sv_magicext(target, temp, PERL_MAGIC_sv, NULL, NULL, 0);
268 /* magic object has had its reference count increased, so we must drop
275 make_warnings_object(pTHX_ SV *arg, STRLEN *warnings)
277 const char *type = 0;
279 IV iv = sizeof(specialsv_list)/sizeof(SV*);
281 /* Counting down is deliberate. Before the split between make_sv_object
282 and make_warnings_obj there appeared to be a bug - Nullsv and pWARN_STD
283 were both 0, so you could never get a B::SPECIAL for pWARN_STD */
286 if ((SV*)warnings == specialsv_list[iv]) {
292 sv_setiv(newSVrv(arg, type), iv);
295 /* B assumes that warnings are a regular SV. Seems easier to keep it
296 happy by making them into a regular SV. */
297 return make_temp_object(aTHX_ arg,
298 newSVpvn((char *)(warnings + 1), *warnings));
303 make_cop_io_object(pTHX_ SV *arg, COP *cop)
305 SV *const value = newSV(0);
307 Perl_emulate_cop_io(aTHX_ cop, value);
310 return make_temp_object(aTHX_ arg, newSVsv(value));
313 return make_sv_object(aTHX_ arg, NULL);
318 make_mg_object(pTHX_ SV *arg, MAGIC *mg)
320 sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg));
325 cstring(pTHX_ SV *sv, bool perlstyle)
327 SV *sstr = newSVpvn("", 0);
330 sv_setpvn(sstr, "0", 1);
331 else if (perlstyle && SvUTF8(sv)) {
332 SV *tmpsv = sv_newmortal(); /* Temporary SV to feed sv_uni_display */
333 const STRLEN len = SvCUR(sv);
334 const char *s = sv_uni_display(tmpsv, sv, 8*len, UNI_DISPLAY_QQ);
335 sv_setpvn(sstr,"\"",1);
339 sv_catpvn(sstr, "\\\"", 2);
341 sv_catpvn(sstr, "\\$", 2);
343 sv_catpvn(sstr, "\\@", 2);
346 if (strchr("nrftax\\",*(s+1)))
347 sv_catpvn(sstr, s++, 2);
349 sv_catpvn(sstr, "\\\\", 2);
351 else /* should always be printable */
352 sv_catpvn(sstr, s, 1);
355 sv_catpv(sstr, "\"");
362 const char *s = SvPV(sv, len);
363 sv_catpv(sstr, "\"");
364 for (; len; len--, s++)
366 /* At least try a little for readability */
368 sv_catpv(sstr, "\\\"");
370 sv_catpv(sstr, "\\\\");
371 /* trigraphs - bleagh */
372 else if (!perlstyle && *s == '?' && len>=3 && s[1] == '?') {
373 char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
374 sprintf(escbuff, "\\%03o", '?');
375 sv_catpv(sstr, escbuff);
377 else if (perlstyle && *s == '$')
378 sv_catpv(sstr, "\\$");
379 else if (perlstyle && *s == '@')
380 sv_catpv(sstr, "\\@");
382 else if (isPRINT(*s))
384 else if (*s >= ' ' && *s < 127)
386 sv_catpvn(sstr, s, 1);
388 sv_catpv(sstr, "\\n");
390 sv_catpv(sstr, "\\r");
392 sv_catpv(sstr, "\\t");
394 sv_catpv(sstr, "\\a");
396 sv_catpv(sstr, "\\b");
398 sv_catpv(sstr, "\\f");
399 else if (!perlstyle && *s == '\v')
400 sv_catpv(sstr, "\\v");
403 /* Don't want promotion of a signed -1 char in sprintf args */
404 char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
405 const unsigned char c = (unsigned char) *s;
406 sprintf(escbuff, "\\%03o", c);
407 sv_catpv(sstr, escbuff);
409 /* XXX Add line breaks if string is long */
411 sv_catpv(sstr, "\"");
419 SV *sstr = newSVpvn("'", 1);
420 const char *s = SvPV_nolen(sv);
423 sv_catpvn(sstr, "\\'", 2);
425 sv_catpvn(sstr, "\\\\", 2);
427 else if (isPRINT(*s))
429 else if (*s >= ' ' && *s < 127)
431 sv_catpvn(sstr, s, 1);
433 sv_catpvn(sstr, "\\n", 2);
435 sv_catpvn(sstr, "\\r", 2);
437 sv_catpvn(sstr, "\\t", 2);
439 sv_catpvn(sstr, "\\a", 2);
441 sv_catpvn(sstr, "\\b", 2);
443 sv_catpvn(sstr, "\\f", 2);
445 sv_catpvn(sstr, "\\v", 2);
448 /* no trigraph support */
449 char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
450 /* Don't want promotion of a signed -1 char in sprintf args */
451 unsigned char c = (unsigned char) *s;
452 sprintf(escbuff, "\\%03o", c);
453 sv_catpv(sstr, escbuff);
455 sv_catpvn(sstr, "'", 1);
460 walkoptree(pTHX_ SV *opsv, const char *method)
467 croak("opsv is not a reference");
468 opsv = sv_mortalcopy(opsv);
469 o = INT2PTR(OP*,SvIV((SV*)SvRV(opsv)));
470 if (walkoptree_debug) {
474 perl_call_method("walkoptree_debug", G_DISCARD);
479 perl_call_method(method, G_DISCARD);
480 if (o && (o->op_flags & OPf_KIDS)) {
481 for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) {
482 /* Use the same opsv. Rely on methods not to mess it up. */
483 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
484 walkoptree(aTHX_ opsv, method);
487 if (o && (cc_opclass(aTHX_ o) == OPc_PMOP) && o->op_type != OP_PUSHRE
488 && (kid = cPMOPo->op_pmreplroot))
490 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
491 walkoptree(aTHX_ opsv, method);
496 oplist(pTHX_ OP *o, SV **SP)
498 for(; o; o = o->op_next) {
500 #if PERL_VERSION >= 9
509 opsv = sv_newmortal();
510 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ (OP*)o)), PTR2IV(o));
512 switch (o->op_type) {
514 SP = oplist(aTHX_ cPMOPo->op_pmreplstart, SP);
517 if (o->op_flags & OPf_STACKED && o->op_flags & OPf_SPECIAL) {
518 OP *kid = cLISTOPo->op_first->op_sibling; /* pass pushmark */
519 kid = kUNOP->op_first; /* pass rv2gv */
520 kid = kUNOP->op_first; /* pass leave */
521 SP = oplist(aTHX_ kid->op_next, SP);
525 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
527 SP = oplist(aTHX_ cLOGOPo->op_other, SP);
530 SP = oplist(aTHX_ cLOOPo->op_lastop, SP);
531 SP = oplist(aTHX_ cLOOPo->op_nextop, SP);
532 SP = oplist(aTHX_ cLOOPo->op_redoop, SP);
540 typedef UNOP *B__UNOP;
541 typedef BINOP *B__BINOP;
542 typedef LOGOP *B__LOGOP;
543 typedef LISTOP *B__LISTOP;
544 typedef PMOP *B__PMOP;
545 typedef SVOP *B__SVOP;
546 typedef PADOP *B__PADOP;
547 typedef PVOP *B__PVOP;
548 typedef LOOP *B__LOOP;
566 typedef MAGIC *B__MAGIC;
568 typedef struct refcounted_he *B__RHE;
570 MODULE = B PACKAGE = B PREFIX = B_
576 HV *stash = gv_stashpvn("B", 1, GV_ADD);
577 AV *export_ok = perl_get_av("B::EXPORT_OK",TRUE);
579 specialsv_list[0] = Nullsv;
580 specialsv_list[1] = &PL_sv_undef;
581 specialsv_list[2] = &PL_sv_yes;
582 specialsv_list[3] = &PL_sv_no;
583 specialsv_list[4] = (SV *) pWARN_ALL;
584 specialsv_list[5] = (SV *) pWARN_NONE;
585 specialsv_list[6] = (SV *) pWARN_STD;
586 #if PERL_VERSION <= 8
587 # define CVf_ASSERTION 0
588 # define OPpPAD_STATE 0
593 #define B_main_cv() PL_main_cv
594 #define B_init_av() PL_initav
595 #define B_inc_gv() PL_incgv
596 #define B_check_av() PL_checkav_save
598 # define B_unitcheck_av() PL_unitcheckav_save
600 # define B_unitcheck_av() NULL
602 #define B_begin_av() PL_beginav_save
603 #define B_end_av() PL_endav
604 #define B_main_root() PL_main_root
605 #define B_main_start() PL_main_start
606 #define B_amagic_generation() PL_amagic_generation
607 #define B_sub_generation() PL_sub_generation
608 #define B_defstash() PL_defstash
609 #define B_curstash() PL_curstash
610 #define B_dowarn() PL_dowarn
611 #define B_comppadlist() (PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv))
612 #define B_sv_undef() &PL_sv_undef
613 #define B_sv_yes() &PL_sv_yes
614 #define B_sv_no() &PL_sv_no
615 #define B_formfeed() PL_formfeed
617 #define B_regex_padav() PL_regex_padav
655 B_amagic_generation()
687 ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_warnhook);
692 ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_diehook);
694 MODULE = B PACKAGE = B
697 walkoptree(opsv, method)
701 walkoptree(aTHX_ opsv, method);
704 walkoptree_debug(...)
707 RETVAL = walkoptree_debug;
708 if (items > 0 && SvTRUE(ST(1)))
709 walkoptree_debug = 1;
713 #define address(sv) PTR2IV(sv)
724 croak("argument is not a reference");
725 RETVAL = (SV*)SvRV(sv);
736 ST(0) = sv_newmortal();
737 if (strncmp(name,"pp_",3) == 0)
739 for (i = 0; i < PL_maxo; i++)
741 if (strcmp(name, PL_op_name[i]) == 0)
747 sv_setiv(ST(0),result);
754 ST(0) = sv_newmortal();
755 if (opnum >= 0 && opnum < PL_maxo) {
756 sv_setpvn(ST(0), "pp_", 3);
757 sv_catpv(ST(0), PL_op_name[opnum]);
766 char hexhash[19]; /* must fit "0xffffffffffffffff" plus trailing \0 */
767 const char *s = SvPV(sv, len);
768 PERL_HASH(hash, s, len);
769 sprintf(hexhash, "0x%"UVxf, (UV)hash);
770 ST(0) = sv_2mortal(newSVpv(hexhash, 0));
772 #define cast_I32(foo) (I32)foo
791 RETVAL = cstring(aTHX_ sv, 0);
799 RETVAL = cstring(aTHX_ sv, 1);
807 RETVAL = cchar(aTHX_ sv);
814 #if PERL_VERSION <= 8
815 # ifdef USE_5005THREADS
817 const STRLEN len = strlen(PL_threadsv_names);
820 for (i = 0; i < len; i++)
821 PUSHs(sv_2mortal(newSVpvn(&PL_threadsv_names[i], 1)));
825 #define OP_next(o) o->op_next
826 #define OP_sibling(o) o->op_sibling
827 #define OP_desc(o) (char *)PL_op_desc[o->op_type]
828 #define OP_targ(o) o->op_targ
829 #define OP_type(o) o->op_type
830 #if PERL_VERSION >= 9
831 # define OP_opt(o) o->op_opt
832 # define OP_static(o) o->op_static
834 # define OP_seq(o) o->op_seq
836 #define OP_flags(o) o->op_flags
837 #define OP_private(o) o->op_private
838 #define OP_spare(o) o->op_spare
840 MODULE = B PACKAGE = B::OP PREFIX = OP_
846 RETVAL = opsizes[cc_opclass(aTHX_ o)];
862 RETVAL = (char *)PL_op_name[o->op_type];
872 SV *sv = sv_newmortal();
874 sv_setpvn(sv, "PL_ppaddr[OP_", 13);
875 sv_catpv(sv, PL_op_name[o->op_type]);
876 for (i=13; (STRLEN)i < SvCUR(sv); ++i)
877 SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]);
893 #if PERL_VERSION >= 9
919 #if PERL_VERSION >= 9
931 SP = oplist(aTHX_ o, SP);
933 #define UNOP_first(o) o->op_first
935 MODULE = B PACKAGE = B::UNOP PREFIX = UNOP_
941 #define BINOP_last(o) o->op_last
943 MODULE = B PACKAGE = B::BINOP PREFIX = BINOP_
949 #define LOGOP_other(o) o->op_other
951 MODULE = B PACKAGE = B::LOGOP PREFIX = LOGOP_
957 MODULE = B PACKAGE = B::LISTOP PREFIX = LISTOP_
966 for (kid = o->op_first; kid; kid = kid->op_sibling)
972 #define PMOP_pmreplroot(o) o->op_pmreplroot
973 #define PMOP_pmreplstart(o) o->op_pmreplstart
974 #define PMOP_pmnext(o) o->op_pmnext
975 #define PMOP_pmregexp(o) PM_GETRE(o)
977 #define PMOP_pmoffset(o) o->op_pmoffset
978 #define PMOP_pmstashpv(o) o->op_pmstashpv
980 #define PMOP_pmstash(o) o->op_pmstash
982 #define PMOP_pmflags(o) o->op_pmflags
983 #define PMOP_pmpermflags(o) o->op_pmpermflags
984 #define PMOP_pmdynflags(o) o->op_pmdynflags
986 MODULE = B PACKAGE = B::PMOP PREFIX = PMOP_
993 ST(0) = sv_newmortal();
994 root = o->op_pmreplroot;
995 /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */
996 if (o->op_type == OP_PUSHRE) {
998 sv_setiv(ST(0), INT2PTR(PADOFFSET,root) );
1000 sv_setiv(newSVrv(ST(0), root ?
1001 svclassnames[SvTYPE((SV*)root)] : "B::SV"),
1006 sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root));
1050 REGEXP * rx = NO_INIT
1052 ST(0) = sv_newmortal();
1055 sv_setpvn(ST(0), rx->precomp, rx->prelen);
1057 #define SVOP_sv(o) cSVOPo->op_sv
1058 #define SVOP_gv(o) ((GV*)cSVOPo->op_sv)
1060 MODULE = B PACKAGE = B::SVOP PREFIX = SVOP_
1070 #define PADOP_padix(o) o->op_padix
1071 #define PADOP_sv(o) (o->op_padix ? PAD_SVl(o->op_padix) : Nullsv)
1072 #define PADOP_gv(o) ((o->op_padix \
1073 && SvTYPE(PAD_SVl(o->op_padix)) == SVt_PVGV) \
1074 ? (GV*)PAD_SVl(o->op_padix) : Nullgv)
1076 MODULE = B PACKAGE = B::PADOP PREFIX = PADOP_
1090 MODULE = B PACKAGE = B::PVOP PREFIX = PVOP_
1097 * OP_TRANS uses op_pv to point to a table of 256 or >=258 shorts
1098 * whereas other PVOPs point to a null terminated string.
1100 if (o->op_type == OP_TRANS &&
1101 (o->op_private & OPpTRANS_COMPLEMENT) &&
1102 !(o->op_private & OPpTRANS_DELETE))
1104 const short* const tbl = (short*)o->op_pv;
1105 const short entries = 257 + tbl[256];
1106 ST(0) = sv_2mortal(newSVpv(o->op_pv, entries * sizeof(short)));
1108 else if (o->op_type == OP_TRANS) {
1109 ST(0) = sv_2mortal(newSVpv(o->op_pv, 256 * sizeof(short)));
1112 ST(0) = sv_2mortal(newSVpv(o->op_pv, 0));
1114 #define LOOP_redoop(o) o->op_redoop
1115 #define LOOP_nextop(o) o->op_nextop
1116 #define LOOP_lastop(o) o->op_lastop
1118 MODULE = B PACKAGE = B::LOOP PREFIX = LOOP_
1133 #define COP_label(o) o->cop_label
1134 #define COP_stashpv(o) CopSTASHPV(o)
1135 #define COP_stash(o) CopSTASH(o)
1136 #define COP_file(o) CopFILE(o)
1137 #define COP_filegv(o) CopFILEGV(o)
1138 #define COP_cop_seq(o) o->cop_seq
1139 #define COP_arybase(o) CopARYBASE_get(o)
1140 #define COP_line(o) CopLINE(o)
1141 #define COP_hints(o) CopHINTS_get(o)
1143 MODULE = B PACKAGE = B::COP PREFIX = COP_
1182 ST(0) = make_warnings_object(aTHX_ sv_newmortal(), o->cop_warnings);
1189 ST(0) = make_cop_io_object(aTHX_ sv_newmortal(), o);
1200 RETVAL = o->cop_hints_hash;
1204 MODULE = B PACKAGE = B::SV
1210 #define object_2svref(sv) sv
1217 MODULE = B PACKAGE = B::SV PREFIX = Sv
1239 MODULE = B PACKAGE = B::IV PREFIX = Sv
1254 MODULE = B PACKAGE = B::IV
1256 #define needs64bits(sv) ((I32)SvIVX(sv) != SvIVX(sv))
1266 if (sizeof(IV) == 8) {
1268 const IV iv = SvIVX(sv);
1270 * The following way of spelling 32 is to stop compilers on
1271 * 32-bit architectures from moaning about the shift count
1272 * being >= the width of the type. Such architectures don't
1273 * reach this code anyway (unless sizeof(IV) > 8 but then
1274 * everything else breaks too so I'm not fussed at the moment).
1277 wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1279 wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1281 wp[1] = htonl(iv & 0xffffffff);
1282 ST(0) = sv_2mortal(newSVpvn((char *)wp, 8));
1284 U32 w = htonl((U32)SvIVX(sv));
1285 ST(0) = sv_2mortal(newSVpvn((char *)&w, 4));
1288 MODULE = B PACKAGE = B::NV PREFIX = Sv
1299 COP_SEQ_RANGE_LOW(sv)
1303 COP_SEQ_RANGE_HIGH(sv)
1307 PARENT_PAD_INDEX(sv)
1311 PARENT_FAKELEX_FLAGS(sv)
1314 MODULE = B PACKAGE = B::RV PREFIX = Sv
1320 MODULE = B PACKAGE = B::PV PREFIX = Sv
1334 croak( "argument is not SvROK" );
1343 ST(0) = sv_newmortal();
1345 /* FIXME - we need a better way for B to identify PVs that are
1346 in the pads as variable names. */
1347 if((SvLEN(sv) && SvCUR(sv) >= SvLEN(sv))) {
1348 /* It claims to be longer than the space allocated for it -
1349 presuambly it's a variable name in the pad */
1350 sv_setpv(ST(0), SvPV_nolen_const(sv));
1352 sv_setpvn(ST(0), SvPVX_const(sv), SvCUR(sv));
1354 SvFLAGS(ST(0)) |= SvUTF8(sv);
1357 /* XXX for backward compatibility, but should fail */
1358 /* croak( "argument is not SvPOK" ); */
1359 sv_setpvn(ST(0), NULL, 0);
1362 # This used to read 257. I think that that was buggy - should have been 258.
1363 # (The "\0", the flags byte, and 256 for the table. Not that anything
1364 # anywhere calls this method. NWC.
1369 ST(0) = sv_newmortal();
1370 sv_setpvn(ST(0), SvPVX_const(sv),
1371 SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0));
1382 MODULE = B PACKAGE = B::PVMG PREFIX = Sv
1387 MAGIC * mg = NO_INIT
1389 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
1390 XPUSHs(make_mg_object(aTHX_ sv_newmortal(), mg));
1392 MODULE = B PACKAGE = B::PVMG
1398 #define MgMOREMAGIC(mg) mg->mg_moremagic
1399 #define MgPRIVATE(mg) mg->mg_private
1400 #define MgTYPE(mg) mg->mg_type
1401 #define MgFLAGS(mg) mg->mg_flags
1402 #define MgOBJ(mg) mg->mg_obj
1403 #define MgLENGTH(mg) mg->mg_len
1404 #define MgREGEX(mg) PTR2IV(mg->mg_obj)
1406 MODULE = B PACKAGE = B::MAGIC PREFIX = Mg
1412 if( MgMOREMAGIC(mg) ) {
1413 RETVAL = MgMOREMAGIC(mg);
1441 if(mg->mg_type == PERL_MAGIC_qr) {
1442 RETVAL = MgREGEX(mg);
1445 croak( "REGEX is only meaningful on r-magic" );
1454 if (mg->mg_type == PERL_MAGIC_qr) {
1455 REGEXP* rx = (REGEXP*)mg->mg_obj;
1458 RETVAL = newSVpvn( rx->precomp, rx->prelen );
1461 croak( "precomp is only meaningful on r-magic" );
1474 ST(0) = sv_newmortal();
1476 if (mg->mg_len >= 0){
1477 sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len);
1478 } else if (mg->mg_len == HEf_SVKEY) {
1479 ST(0) = make_sv_object(aTHX_
1480 sv_newmortal(), (SV*)mg->mg_ptr);
1484 MODULE = B PACKAGE = B::PVLV PREFIX = Lv
1502 MODULE = B PACKAGE = B::BM PREFIX = Bm
1519 STRLEN len = NO_INIT
1520 char * str = NO_INIT
1522 str = SvPV(sv, len);
1523 /* Boyer-Moore table is just after string and its safety-margin \0 */
1524 ST(0) = sv_2mortal(newSVpvn(str + len + PERL_FBM_TABLE_OFFSET, 256));
1526 MODULE = B PACKAGE = B::GV PREFIX = Gv
1532 ST(0) = sv_2mortal(newSVpvn(GvNAME(gv), GvNAMELEN(gv)));
1538 RETVAL = GvGP(gv) == Null(GP*);
1562 RETVAL = (SV*)GvFORM(gv);
1598 MODULE = B PACKAGE = B::GV
1608 MODULE = B PACKAGE = B::IO PREFIX = Io
1661 if( strEQ( name, "stdin" ) ) {
1662 handle = PerlIO_stdin();
1664 else if( strEQ( name, "stdout" ) ) {
1665 handle = PerlIO_stdout();
1667 else if( strEQ( name, "stderr" ) ) {
1668 handle = PerlIO_stderr();
1671 croak( "Invalid value '%s'", name );
1673 RETVAL = handle == IoIFP(io);
1677 MODULE = B PACKAGE = B::IO
1687 MODULE = B PACKAGE = B::AV PREFIX = Av
1697 #if PERL_VERSION < 9
1700 #define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1712 if (AvFILL(av) >= 0) {
1713 SV **svp = AvARRAY(av);
1715 for (i = 0; i <= AvFILL(av); i++)
1716 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), svp[i]));
1724 if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
1725 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), (AvARRAY(av)[idx])));
1727 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), NULL));
1729 #if PERL_VERSION < 9
1731 MODULE = B PACKAGE = B::AV
1739 MODULE = B PACKAGE = B::FM PREFIX = Fm
1745 MODULE = B PACKAGE = B::CV PREFIX = Cv
1759 RETVAL = CvISXSUB(cv) ? NULL : CvSTART(cv);
1767 RETVAL = CvISXSUB(cv) ? NULL : CvROOT(cv);
1799 ST(0) = sv_2mortal(newSViv(CvISXSUB(cv) ? PTR2IV(CvXSUB(cv)) : 0));
1806 ST(0) = CvCONST(cv) ?
1807 make_sv_object(aTHX_ sv_newmortal(),(SV *)CvXSUBANY(cv).any_ptr) :
1808 sv_2mortal(newSViv(CvISXSUB(cv) ? CvXSUBANY(cv).any_iv : 0));
1810 MODULE = B PACKAGE = B::CV
1816 MODULE = B PACKAGE = B::CV PREFIX = cv_
1823 MODULE = B PACKAGE = B::HV PREFIX = Hv
1845 #if PERL_VERSION < 9
1857 if (HvKEYS(hv) > 0) {
1861 (void)hv_iterinit(hv);
1862 EXTEND(sp, HvKEYS(hv) * 2);
1863 while ((sv = hv_iternextsv(hv, &key, &len))) {
1864 PUSHs(newSVpvn(key, len));
1865 PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv));
1869 MODULE = B PACKAGE = B::HE PREFIX = He
1883 MODULE = B PACKAGE = B::RHE PREFIX = RHE_
1889 RETVAL = newRV( (SV*)Perl_refcounted_he_chain_2hv(aTHX_ h) );