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 typedef struct refcounted_he *B__RHE;
569 MODULE = B PACKAGE = B PREFIX = B_
575 HV *stash = gv_stashpvn("B", 1, TRUE);
576 AV *export_ok = perl_get_av("B::EXPORT_OK",TRUE);
578 specialsv_list[0] = Nullsv;
579 specialsv_list[1] = &PL_sv_undef;
580 specialsv_list[2] = &PL_sv_yes;
581 specialsv_list[3] = &PL_sv_no;
582 specialsv_list[4] = (SV *) pWARN_ALL;
583 specialsv_list[5] = (SV *) pWARN_NONE;
584 specialsv_list[6] = (SV *) pWARN_STD;
585 #if PERL_VERSION <= 8
586 # define CVf_ASSERTION 0
591 #define B_main_cv() PL_main_cv
592 #define B_init_av() PL_initav
593 #define B_inc_gv() PL_incgv
594 #define B_check_av() PL_checkav_save
595 #define B_unitcheck_av() PL_unitcheckav_save
596 #define B_begin_av() PL_beginav_save
597 #define B_end_av() PL_endav
598 #define B_main_root() PL_main_root
599 #define B_main_start() PL_main_start
600 #define B_amagic_generation() PL_amagic_generation
601 #define B_sub_generation() PL_sub_generation
602 #define B_defstash() PL_defstash
603 #define B_curstash() PL_curstash
604 #define B_dowarn() PL_dowarn
605 #define B_comppadlist() (PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv))
606 #define B_sv_undef() &PL_sv_undef
607 #define B_sv_yes() &PL_sv_yes
608 #define B_sv_no() &PL_sv_no
609 #define B_formfeed() PL_formfeed
611 #define B_regex_padav() PL_regex_padav
649 B_amagic_generation()
681 ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_warnhook);
686 ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_diehook);
688 MODULE = B PACKAGE = B
691 walkoptree(opsv, method)
695 walkoptree(aTHX_ opsv, method);
698 walkoptree_debug(...)
701 RETVAL = walkoptree_debug;
702 if (items > 0 && SvTRUE(ST(1)))
703 walkoptree_debug = 1;
707 #define address(sv) PTR2IV(sv)
718 croak("argument is not a reference");
719 RETVAL = (SV*)SvRV(sv);
730 ST(0) = sv_newmortal();
731 if (strncmp(name,"pp_",3) == 0)
733 for (i = 0; i < PL_maxo; i++)
735 if (strcmp(name, PL_op_name[i]) == 0)
741 sv_setiv(ST(0),result);
748 ST(0) = sv_newmortal();
749 if (opnum >= 0 && opnum < PL_maxo) {
750 sv_setpvn(ST(0), "pp_", 3);
751 sv_catpv(ST(0), PL_op_name[opnum]);
760 char hexhash[19]; /* must fit "0xffffffffffffffff" plus trailing \0 */
761 const char *s = SvPV(sv, len);
762 PERL_HASH(hash, s, len);
763 sprintf(hexhash, "0x%"UVxf, (UV)hash);
764 ST(0) = sv_2mortal(newSVpv(hexhash, 0));
766 #define cast_I32(foo) (I32)foo
785 RETVAL = cstring(aTHX_ sv, 0);
793 RETVAL = cstring(aTHX_ sv, 1);
801 RETVAL = cchar(aTHX_ sv);
808 #if PERL_VERSION <= 8
809 # ifdef USE_5005THREADS
811 const STRLEN len = strlen(PL_threadsv_names);
814 for (i = 0; i < len; i++)
815 PUSHs(sv_2mortal(newSVpvn(&PL_threadsv_names[i], 1)));
819 #define OP_next(o) o->op_next
820 #define OP_sibling(o) o->op_sibling
821 #define OP_desc(o) (char *)PL_op_desc[o->op_type]
822 #define OP_targ(o) o->op_targ
823 #define OP_type(o) o->op_type
824 #if PERL_VERSION >= 9
825 # define OP_opt(o) o->op_opt
826 # define OP_static(o) o->op_static
828 # define OP_seq(o) o->op_seq
830 #define OP_flags(o) o->op_flags
831 #define OP_private(o) o->op_private
832 #define OP_spare(o) o->op_spare
834 MODULE = B PACKAGE = B::OP PREFIX = OP_
840 RETVAL = opsizes[cc_opclass(aTHX_ o)];
856 RETVAL = (char *)PL_op_name[o->op_type];
866 SV *sv = sv_newmortal();
868 sv_setpvn(sv, "PL_ppaddr[OP_", 13);
869 sv_catpv(sv, PL_op_name[o->op_type]);
870 for (i=13; (STRLEN)i < SvCUR(sv); ++i)
871 SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]);
887 #if PERL_VERSION >= 9
913 #if PERL_VERSION >= 9
925 SP = oplist(aTHX_ o, SP);
927 #define UNOP_first(o) o->op_first
929 MODULE = B PACKAGE = B::UNOP PREFIX = UNOP_
935 #define BINOP_last(o) o->op_last
937 MODULE = B PACKAGE = B::BINOP PREFIX = BINOP_
943 #define LOGOP_other(o) o->op_other
945 MODULE = B PACKAGE = B::LOGOP PREFIX = LOGOP_
951 MODULE = B PACKAGE = B::LISTOP PREFIX = LISTOP_
960 for (kid = o->op_first; kid; kid = kid->op_sibling)
966 #define PMOP_pmreplroot(o) o->op_pmreplroot
967 #define PMOP_pmreplstart(o) o->op_pmreplstart
968 #define PMOP_pmnext(o) o->op_pmnext
969 #define PMOP_pmregexp(o) PM_GETRE(o)
971 #define PMOP_pmoffset(o) o->op_pmoffset
972 #define PMOP_pmstashpv(o) o->op_pmstashpv
974 #define PMOP_pmstash(o) o->op_pmstash
976 #define PMOP_pmflags(o) o->op_pmflags
977 #define PMOP_pmpermflags(o) o->op_pmpermflags
978 #define PMOP_pmdynflags(o) o->op_pmdynflags
980 MODULE = B PACKAGE = B::PMOP PREFIX = PMOP_
987 ST(0) = sv_newmortal();
988 root = o->op_pmreplroot;
989 /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */
990 if (o->op_type == OP_PUSHRE) {
992 sv_setiv(ST(0), INT2PTR(PADOFFSET,root) );
994 sv_setiv(newSVrv(ST(0), root ?
995 svclassnames[SvTYPE((SV*)root)] : "B::SV"),
1000 sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root));
1044 REGEXP * rx = NO_INIT
1046 ST(0) = sv_newmortal();
1049 sv_setpvn(ST(0), rx->precomp, rx->prelen);
1051 #define SVOP_sv(o) cSVOPo->op_sv
1052 #define SVOP_gv(o) ((GV*)cSVOPo->op_sv)
1054 MODULE = B PACKAGE = B::SVOP PREFIX = SVOP_
1064 #define PADOP_padix(o) o->op_padix
1065 #define PADOP_sv(o) (o->op_padix ? PAD_SVl(o->op_padix) : Nullsv)
1066 #define PADOP_gv(o) ((o->op_padix \
1067 && SvTYPE(PAD_SVl(o->op_padix)) == SVt_PVGV) \
1068 ? (GV*)PAD_SVl(o->op_padix) : Nullgv)
1070 MODULE = B PACKAGE = B::PADOP PREFIX = PADOP_
1084 MODULE = B PACKAGE = B::PVOP PREFIX = PVOP_
1091 * OP_TRANS uses op_pv to point to a table of 256 or >=258 shorts
1092 * whereas other PVOPs point to a null terminated string.
1094 if (o->op_type == OP_TRANS &&
1095 (o->op_private & OPpTRANS_COMPLEMENT) &&
1096 !(o->op_private & OPpTRANS_DELETE))
1098 const short* const tbl = (short*)o->op_pv;
1099 const short entries = 257 + tbl[256];
1100 ST(0) = sv_2mortal(newSVpv(o->op_pv, entries * sizeof(short)));
1102 else if (o->op_type == OP_TRANS) {
1103 ST(0) = sv_2mortal(newSVpv(o->op_pv, 256 * sizeof(short)));
1106 ST(0) = sv_2mortal(newSVpv(o->op_pv, 0));
1108 #define LOOP_redoop(o) o->op_redoop
1109 #define LOOP_nextop(o) o->op_nextop
1110 #define LOOP_lastop(o) o->op_lastop
1112 MODULE = B PACKAGE = B::LOOP PREFIX = LOOP_
1127 #define COP_label(o) o->cop_label
1128 #define COP_stashpv(o) CopSTASHPV(o)
1129 #define COP_stash(o) CopSTASH(o)
1130 #define COP_file(o) CopFILE(o)
1131 #define COP_filegv(o) CopFILEGV(o)
1132 #define COP_cop_seq(o) o->cop_seq
1133 #define COP_arybase(o) CopARYBASE_get(o)
1134 #define COP_line(o) CopLINE(o)
1135 #define COP_hints(o) CopHINTS_get(o)
1137 MODULE = B PACKAGE = B::COP PREFIX = COP_
1176 ST(0) = make_warnings_object(aTHX_ sv_newmortal(), o->cop_warnings);
1183 ST(0) = make_cop_io_object(aTHX_ sv_newmortal(), o);
1194 RETVAL = o->cop_hints_hash;
1198 MODULE = B PACKAGE = B::SV
1204 #define object_2svref(sv) sv
1211 MODULE = B PACKAGE = B::SV PREFIX = Sv
1233 MODULE = B PACKAGE = B::IV PREFIX = Sv
1248 MODULE = B PACKAGE = B::IV
1250 #define needs64bits(sv) ((I32)SvIVX(sv) != SvIVX(sv))
1260 if (sizeof(IV) == 8) {
1262 const IV iv = SvIVX(sv);
1264 * The following way of spelling 32 is to stop compilers on
1265 * 32-bit architectures from moaning about the shift count
1266 * being >= the width of the type. Such architectures don't
1267 * reach this code anyway (unless sizeof(IV) > 8 but then
1268 * everything else breaks too so I'm not fussed at the moment).
1271 wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1273 wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1275 wp[1] = htonl(iv & 0xffffffff);
1276 ST(0) = sv_2mortal(newSVpvn((char *)wp, 8));
1278 U32 w = htonl((U32)SvIVX(sv));
1279 ST(0) = sv_2mortal(newSVpvn((char *)&w, 4));
1282 MODULE = B PACKAGE = B::NV PREFIX = Sv
1292 MODULE = B PACKAGE = B::RV PREFIX = Sv
1298 MODULE = B PACKAGE = B::PV PREFIX = Sv
1312 croak( "argument is not SvROK" );
1321 ST(0) = sv_newmortal();
1323 /* FIXME - we need a better way for B to identify PVs that are
1324 in the pads as variable names. */
1325 if((SvLEN(sv) && SvCUR(sv) >= SvLEN(sv))) {
1326 /* It claims to be longer than the space allocated for it -
1327 presuambly it's a variable name in the pad */
1328 sv_setpv(ST(0), SvPV_nolen_const(sv));
1330 sv_setpvn(ST(0), SvPVX_const(sv), SvCUR(sv));
1332 SvFLAGS(ST(0)) |= SvUTF8(sv);
1335 /* XXX for backward compatibility, but should fail */
1336 /* croak( "argument is not SvPOK" ); */
1337 sv_setpvn(ST(0), NULL, 0);
1344 ST(0) = sv_newmortal();
1345 sv_setpvn(ST(0), SvPVX_const(sv),
1346 SvCUR(sv) + (SvTYPE(sv) == SVt_PVBM ? 257 : 0));
1357 MODULE = B PACKAGE = B::PVMG PREFIX = Sv
1362 MAGIC * mg = NO_INIT
1364 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
1365 XPUSHs(make_mg_object(aTHX_ sv_newmortal(), mg));
1367 MODULE = B PACKAGE = B::PVMG
1373 #define MgMOREMAGIC(mg) mg->mg_moremagic
1374 #define MgPRIVATE(mg) mg->mg_private
1375 #define MgTYPE(mg) mg->mg_type
1376 #define MgFLAGS(mg) mg->mg_flags
1377 #define MgOBJ(mg) mg->mg_obj
1378 #define MgLENGTH(mg) mg->mg_len
1379 #define MgREGEX(mg) PTR2IV(mg->mg_obj)
1381 MODULE = B PACKAGE = B::MAGIC PREFIX = Mg
1387 if( MgMOREMAGIC(mg) ) {
1388 RETVAL = MgMOREMAGIC(mg);
1416 if(mg->mg_type == PERL_MAGIC_qr) {
1417 RETVAL = MgREGEX(mg);
1420 croak( "REGEX is only meaningful on r-magic" );
1429 if (mg->mg_type == PERL_MAGIC_qr) {
1430 REGEXP* rx = (REGEXP*)mg->mg_obj;
1433 RETVAL = newSVpvn( rx->precomp, rx->prelen );
1436 croak( "precomp is only meaningful on r-magic" );
1449 ST(0) = sv_newmortal();
1451 if (mg->mg_len >= 0){
1452 sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len);
1453 } else if (mg->mg_len == HEf_SVKEY) {
1454 ST(0) = make_sv_object(aTHX_
1455 sv_newmortal(), (SV*)mg->mg_ptr);
1459 MODULE = B PACKAGE = B::PVLV PREFIX = Lv
1477 MODULE = B PACKAGE = B::BM PREFIX = Bm
1494 STRLEN len = NO_INIT
1495 char * str = NO_INIT
1497 str = SvPV(sv, len);
1498 /* Boyer-Moore table is just after string and its safety-margin \0 */
1499 ST(0) = sv_2mortal(newSVpvn(str + len + 1, 256));
1501 MODULE = B PACKAGE = B::GV PREFIX = Gv
1507 ST(0) = sv_2mortal(newSVpvn(GvNAME(gv), GvNAMELEN(gv)));
1513 RETVAL = GvGP(gv) == Null(GP*);
1537 RETVAL = (SV*)GvFORM(gv);
1573 MODULE = B PACKAGE = B::GV
1583 MODULE = B PACKAGE = B::IO PREFIX = Io
1636 if( strEQ( name, "stdin" ) ) {
1637 handle = PerlIO_stdin();
1639 else if( strEQ( name, "stdout" ) ) {
1640 handle = PerlIO_stdout();
1642 else if( strEQ( name, "stderr" ) ) {
1643 handle = PerlIO_stderr();
1646 croak( "Invalid value '%s'", name );
1648 RETVAL = handle == IoIFP(io);
1652 MODULE = B PACKAGE = B::IO
1662 MODULE = B PACKAGE = B::AV PREFIX = Av
1672 #if PERL_VERSION < 9
1675 #define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1687 if (AvFILL(av) >= 0) {
1688 SV **svp = AvARRAY(av);
1690 for (i = 0; i <= AvFILL(av); i++)
1691 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), svp[i]));
1699 if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
1700 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), (AvARRAY(av)[idx])));
1702 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), NULL));
1704 #if PERL_VERSION < 9
1706 MODULE = B PACKAGE = B::AV
1714 MODULE = B PACKAGE = B::FM PREFIX = Fm
1720 MODULE = B PACKAGE = B::CV PREFIX = Cv
1734 RETVAL = CvISXSUB(cv) ? NULL : CvSTART(cv);
1742 RETVAL = CvISXSUB(cv) ? NULL : CvROOT(cv);
1774 ST(0) = sv_2mortal(newSViv(CvISXSUB(cv) ? PTR2IV(CvXSUB(cv)) : 0));
1781 ST(0) = CvCONST(cv) ?
1782 make_sv_object(aTHX_ sv_newmortal(),(SV *)CvXSUBANY(cv).any_ptr) :
1783 sv_2mortal(newSViv(CvISXSUB(cv) ? CvXSUBANY(cv).any_iv : 0));
1785 MODULE = B PACKAGE = B::CV
1791 MODULE = B PACKAGE = B::CV PREFIX = cv_
1798 MODULE = B PACKAGE = B::HV PREFIX = Hv
1820 #if PERL_VERSION < 9
1832 if (HvKEYS(hv) > 0) {
1836 (void)hv_iterinit(hv);
1837 EXTEND(sp, HvKEYS(hv) * 2);
1838 while ((sv = hv_iternextsv(hv, &key, &len))) {
1839 PUSHs(newSVpvn(key, len));
1840 PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv));
1844 MODULE = B PACKAGE = B::HE PREFIX = He
1858 MODULE = B PACKAGE = B::RHE PREFIX = RHE_
1864 RETVAL = newRV( (SV*)Perl_refcounted_he_chain_2hv(h) );