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[] = {
29 #if PERL_VERSION <= 10
39 #if PERL_VERSION >= 11
71 static const char* const opclassnames[] = {
86 static const size_t opsizes[] = {
101 #define MY_CXT_KEY "B::_guts" XS_VERSION
104 int x_walkoptree_debug; /* Flag for walkoptree debug hook */
105 SV * x_specialsv_list[7];
110 #define walkoptree_debug (MY_CXT.x_walkoptree_debug)
111 #define specialsv_list (MY_CXT.x_specialsv_list)
114 cc_opclass(pTHX_ const OP *o)
120 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
122 if (o->op_type == OP_SASSIGN)
123 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
125 if (o->op_type == OP_AELEMFAST) {
126 if (o->op_flags & OPf_SPECIAL)
137 if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
138 o->op_type == OP_RCATLINE)
142 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
167 case OA_PVOP_OR_SVOP:
169 * Character translations (tr///) are usually a PVOP, keeping a
170 * pointer to a table of shorts used to look up translations.
171 * Under utf8, however, a simple table isn't practical; instead,
172 * the OP is an SVOP, and the SV is a reference to a swash
173 * (i.e., an RV pointing to an HV).
175 return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
176 ? OPc_SVOP : OPc_PVOP;
184 case OA_BASEOP_OR_UNOP:
186 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
187 * whether parens were seen. perly.y uses OPf_SPECIAL to
188 * signal whether a BASEOP had empty parens or none.
189 * Some other UNOPs are created later, though, so the best
190 * test is OPf_KIDS, which is set in newUNOP.
192 return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
196 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
197 * the OPf_REF flag to distinguish between OP types instead of the
198 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
199 * return OPc_UNOP so that walkoptree can find our children. If
200 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
201 * (no argument to the operator) it's an OP; with OPf_REF set it's
202 * an SVOP (and op_sv is the GV for the filehandle argument).
204 return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
206 (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
208 (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
212 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
213 * label was omitted (in which case it's a BASEOP) or else a term was
214 * seen. In this last case, all except goto are definitely PVOP but
215 * goto is either a PVOP (with an ordinary constant label), an UNOP
216 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
217 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
220 if (o->op_flags & OPf_STACKED)
222 else if (o->op_flags & OPf_SPECIAL)
227 warn("can't determine class of operator %s, assuming BASEOP\n",
228 PL_op_name[o->op_type]);
233 cc_opclassname(pTHX_ const OP *o)
235 return (char *)opclassnames[cc_opclass(aTHX_ o)];
239 make_sv_object(pTHX_ SV *arg, SV *sv)
241 const char *type = 0;
245 for (iv = 0; iv < sizeof(specialsv_list)/sizeof(SV*); iv++) {
246 if (sv == specialsv_list[iv]) {
252 type = svclassnames[SvTYPE(sv)];
255 sv_setiv(newSVrv(arg, type), iv);
259 #if PERL_VERSION >= 9
261 make_temp_object(pTHX_ SV *arg, SV *temp)
264 const char *const type = svclassnames[SvTYPE(temp)];
265 const IV iv = PTR2IV(temp);
267 target = newSVrv(arg, type);
268 sv_setiv(target, iv);
270 /* Need to keep our "temp" around as long as the target exists.
271 Simplest way seems to be to hang it from magic, and let that clear
272 it up. No vtable, so won't actually get in the way of anything. */
273 sv_magicext(target, temp, PERL_MAGIC_sv, NULL, NULL, 0);
274 /* magic object has had its reference count increased, so we must drop
281 make_warnings_object(pTHX_ SV *arg, STRLEN *warnings)
283 const char *type = 0;
285 IV iv = sizeof(specialsv_list)/sizeof(SV*);
287 /* Counting down is deliberate. Before the split between make_sv_object
288 and make_warnings_obj there appeared to be a bug - Nullsv and pWARN_STD
289 were both 0, so you could never get a B::SPECIAL for pWARN_STD */
292 if ((SV*)warnings == specialsv_list[iv]) {
298 sv_setiv(newSVrv(arg, type), iv);
301 /* B assumes that warnings are a regular SV. Seems easier to keep it
302 happy by making them into a regular SV. */
303 return make_temp_object(aTHX_ arg,
304 newSVpvn((char *)(warnings + 1), *warnings));
309 make_cop_io_object(pTHX_ SV *arg, COP *cop)
311 SV *const value = newSV(0);
313 Perl_emulate_cop_io(aTHX_ cop, value);
316 return make_temp_object(aTHX_ arg, newSVsv(value));
319 return make_sv_object(aTHX_ arg, NULL);
325 make_mg_object(pTHX_ SV *arg, MAGIC *mg)
327 sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg));
332 cstring(pTHX_ SV *sv, bool perlstyle)
334 SV *sstr = newSVpvn("", 0);
337 sv_setpvn(sstr, "0", 1);
338 else if (perlstyle && SvUTF8(sv)) {
339 SV *tmpsv = sv_newmortal(); /* Temporary SV to feed sv_uni_display */
340 const STRLEN len = SvCUR(sv);
341 const char *s = sv_uni_display(tmpsv, sv, 8*len, UNI_DISPLAY_QQ);
342 sv_setpvn(sstr,"\"",1);
346 sv_catpvn(sstr, "\\\"", 2);
348 sv_catpvn(sstr, "\\$", 2);
350 sv_catpvn(sstr, "\\@", 2);
353 if (strchr("nrftax\\",*(s+1)))
354 sv_catpvn(sstr, s++, 2);
356 sv_catpvn(sstr, "\\\\", 2);
358 else /* should always be printable */
359 sv_catpvn(sstr, s, 1);
362 sv_catpv(sstr, "\"");
369 const char *s = SvPV(sv, len);
370 sv_catpv(sstr, "\"");
371 for (; len; len--, s++)
373 /* At least try a little for readability */
375 sv_catpv(sstr, "\\\"");
377 sv_catpv(sstr, "\\\\");
378 /* trigraphs - bleagh */
379 else if (!perlstyle && *s == '?' && len>=3 && s[1] == '?') {
380 char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
381 sprintf(escbuff, "\\%03o", '?');
382 sv_catpv(sstr, escbuff);
384 else if (perlstyle && *s == '$')
385 sv_catpv(sstr, "\\$");
386 else if (perlstyle && *s == '@')
387 sv_catpv(sstr, "\\@");
389 else if (isPRINT(*s))
391 else if (*s >= ' ' && *s < 127)
393 sv_catpvn(sstr, s, 1);
395 sv_catpv(sstr, "\\n");
397 sv_catpv(sstr, "\\r");
399 sv_catpv(sstr, "\\t");
401 sv_catpv(sstr, "\\a");
403 sv_catpv(sstr, "\\b");
405 sv_catpv(sstr, "\\f");
406 else if (!perlstyle && *s == '\v')
407 sv_catpv(sstr, "\\v");
410 /* Don't want promotion of a signed -1 char in sprintf args */
411 char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
412 const unsigned char c = (unsigned char) *s;
413 sprintf(escbuff, "\\%03o", c);
414 sv_catpv(sstr, escbuff);
416 /* XXX Add line breaks if string is long */
418 sv_catpv(sstr, "\"");
426 SV *sstr = newSVpvn("'", 1);
427 const char *s = SvPV_nolen(sv);
430 sv_catpvn(sstr, "\\'", 2);
432 sv_catpvn(sstr, "\\\\", 2);
434 else if (isPRINT(*s))
436 else if (*s >= ' ' && *s < 127)
438 sv_catpvn(sstr, s, 1);
440 sv_catpvn(sstr, "\\n", 2);
442 sv_catpvn(sstr, "\\r", 2);
444 sv_catpvn(sstr, "\\t", 2);
446 sv_catpvn(sstr, "\\a", 2);
448 sv_catpvn(sstr, "\\b", 2);
450 sv_catpvn(sstr, "\\f", 2);
452 sv_catpvn(sstr, "\\v", 2);
455 /* no trigraph support */
456 char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
457 /* Don't want promotion of a signed -1 char in sprintf args */
458 unsigned char c = (unsigned char) *s;
459 sprintf(escbuff, "\\%03o", c);
460 sv_catpv(sstr, escbuff);
462 sv_catpvn(sstr, "'", 1);
467 walkoptree(pTHX_ SV *opsv, const char *method)
474 croak("opsv is not a reference");
475 opsv = sv_mortalcopy(opsv);
476 o = INT2PTR(OP*,SvIV((SV*)SvRV(opsv)));
477 if (walkoptree_debug) {
481 perl_call_method("walkoptree_debug", G_DISCARD);
486 perl_call_method(method, G_DISCARD);
487 if (o && (o->op_flags & OPf_KIDS)) {
488 for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) {
489 /* Use the same opsv. Rely on methods not to mess it up. */
490 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
491 walkoptree(aTHX_ opsv, method);
494 if (o && (cc_opclass(aTHX_ o) == OPc_PMOP) && o->op_type != OP_PUSHRE
495 #if PERL_VERSION >= 9
496 && (kid = cPMOPo->op_pmreplrootu.op_pmreplroot)
498 && (kid = cPMOPo->op_pmreplroot)
502 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
503 walkoptree(aTHX_ opsv, method);
508 oplist(pTHX_ OP *o, SV **SP)
510 for(; o; o = o->op_next) {
512 #if PERL_VERSION >= 9
521 opsv = sv_newmortal();
522 sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ (OP*)o)), PTR2IV(o));
524 switch (o->op_type) {
526 #if PERL_VERSION >= 9
527 SP = oplist(aTHX_ cPMOPo->op_pmstashstartu.op_pmreplstart, SP);
529 SP = oplist(aTHX_ cPMOPo->op_pmreplstart, SP);
533 if (o->op_flags & OPf_STACKED && o->op_flags & OPf_SPECIAL) {
534 OP *kid = cLISTOPo->op_first->op_sibling; /* pass pushmark */
535 kid = kUNOP->op_first; /* pass rv2gv */
536 kid = kUNOP->op_first; /* pass leave */
537 SP = oplist(aTHX_ kid->op_next, SP);
541 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
543 SP = oplist(aTHX_ cLOGOPo->op_other, SP);
546 SP = oplist(aTHX_ cLOOPo->op_lastop, SP);
547 SP = oplist(aTHX_ cLOOPo->op_nextop, SP);
548 SP = oplist(aTHX_ cLOOPo->op_redoop, SP);
556 typedef UNOP *B__UNOP;
557 typedef BINOP *B__BINOP;
558 typedef LOGOP *B__LOGOP;
559 typedef LISTOP *B__LISTOP;
560 typedef PMOP *B__PMOP;
561 typedef SVOP *B__SVOP;
562 typedef PADOP *B__PADOP;
563 typedef PVOP *B__PVOP;
564 typedef LOOP *B__LOOP;
572 #if PERL_VERSION >= 11
573 typedef SV *B__REGEXP;
585 typedef MAGIC *B__MAGIC;
587 #if PERL_VERSION >= 9
588 typedef struct refcounted_he *B__RHE;
591 MODULE = B PACKAGE = B PREFIX = B_
597 HV *stash = gv_stashpvn("B", 1, GV_ADD);
598 AV *export_ok = perl_get_av("B::EXPORT_OK",TRUE);
600 specialsv_list[0] = Nullsv;
601 specialsv_list[1] = &PL_sv_undef;
602 specialsv_list[2] = &PL_sv_yes;
603 specialsv_list[3] = &PL_sv_no;
604 specialsv_list[4] = (SV *) pWARN_ALL;
605 specialsv_list[5] = (SV *) pWARN_NONE;
606 specialsv_list[6] = (SV *) pWARN_STD;
607 #if PERL_VERSION <= 8
608 # define OPpPAD_STATE 0
613 #define B_main_cv() PL_main_cv
614 #define B_init_av() PL_initav
615 #define B_inc_gv() PL_incgv
616 #define B_check_av() PL_checkav_save
618 # define B_unitcheck_av() PL_unitcheckav_save
620 # define B_unitcheck_av() NULL
622 #define B_begin_av() PL_beginav_save
623 #define B_end_av() PL_endav
624 #define B_main_root() PL_main_root
625 #define B_main_start() PL_main_start
626 #define B_amagic_generation() PL_amagic_generation
627 #define B_sub_generation() PL_sub_generation
628 #define B_defstash() PL_defstash
629 #define B_curstash() PL_curstash
630 #define B_dowarn() PL_dowarn
631 #define B_comppadlist() (PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv))
632 #define B_sv_undef() &PL_sv_undef
633 #define B_sv_yes() &PL_sv_yes
634 #define B_sv_no() &PL_sv_no
635 #define B_formfeed() PL_formfeed
637 #define B_regex_padav() PL_regex_padav
646 #if PERL_VERSION >= 9
679 B_amagic_generation()
711 ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_warnhook);
716 ST(0) = make_sv_object(aTHX_ sv_newmortal(), PL_diehook);
718 MODULE = B PACKAGE = B
721 walkoptree(opsv, method)
725 walkoptree(aTHX_ opsv, method);
728 walkoptree_debug(...)
731 RETVAL = walkoptree_debug;
732 if (items > 0 && SvTRUE(ST(1)))
733 walkoptree_debug = 1;
737 #define address(sv) PTR2IV(sv)
748 croak("argument is not a reference");
749 RETVAL = (SV*)SvRV(sv);
760 ST(0) = sv_newmortal();
761 if (strncmp(name,"pp_",3) == 0)
763 for (i = 0; i < PL_maxo; i++)
765 if (strcmp(name, PL_op_name[i]) == 0)
771 sv_setiv(ST(0),result);
778 ST(0) = sv_newmortal();
779 if (opnum >= 0 && opnum < PL_maxo) {
780 sv_setpvn(ST(0), "pp_", 3);
781 sv_catpv(ST(0), PL_op_name[opnum]);
790 char hexhash[19]; /* must fit "0xffffffffffffffff" plus trailing \0 */
791 const char *s = SvPV(sv, len);
792 PERL_HASH(hash, s, len);
793 sprintf(hexhash, "0x%"UVxf, (UV)hash);
794 ST(0) = sv_2mortal(newSVpv(hexhash, 0));
796 #define cast_I32(foo) (I32)foo
815 RETVAL = cstring(aTHX_ sv, 0);
823 RETVAL = cstring(aTHX_ sv, 1);
831 RETVAL = cchar(aTHX_ sv);
838 #if PERL_VERSION <= 8
839 # ifdef USE_5005THREADS
841 const STRLEN len = strlen(PL_threadsv_names);
844 for (i = 0; i < len; i++)
845 PUSHs(sv_2mortal(newSVpvn(&PL_threadsv_names[i], 1)));
849 #define OP_next(o) o->op_next
850 #define OP_sibling(o) o->op_sibling
851 #define OP_desc(o) (char *)PL_op_desc[o->op_type]
852 #define OP_targ(o) o->op_targ
853 #define OP_type(o) o->op_type
854 #if PERL_VERSION >= 9
855 # define OP_opt(o) o->op_opt
857 # define OP_seq(o) o->op_seq
859 #define OP_flags(o) o->op_flags
860 #define OP_private(o) o->op_private
861 #define OP_spare(o) o->op_spare
863 MODULE = B PACKAGE = B::OP PREFIX = OP_
869 RETVAL = opsizes[cc_opclass(aTHX_ o)];
885 RETVAL = (char *)PL_op_name[o->op_type];
895 SV *sv = sv_newmortal();
897 sv_setpvn(sv, "PL_ppaddr[OP_", 13);
898 sv_catpv(sv, PL_op_name[o->op_type]);
899 for (i=13; (STRLEN)i < SvCUR(sv); ++i)
900 SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]);
916 #if PERL_VERSION >= 9
938 #if PERL_VERSION >= 9
950 SP = oplist(aTHX_ o, SP);
952 #define UNOP_first(o) o->op_first
954 MODULE = B PACKAGE = B::UNOP PREFIX = UNOP_
960 #define BINOP_last(o) o->op_last
962 MODULE = B PACKAGE = B::BINOP PREFIX = BINOP_
968 #define LOGOP_other(o) o->op_other
970 MODULE = B PACKAGE = B::LOGOP PREFIX = LOGOP_
976 MODULE = B PACKAGE = B::LISTOP PREFIX = LISTOP_
985 for (kid = o->op_first; kid; kid = kid->op_sibling)
991 #if PERL_VERSION >= 9
992 # define PMOP_pmreplstart(o) o->op_pmstashstartu.op_pmreplstart
994 # define PMOP_pmreplstart(o) o->op_pmreplstart
995 # define PMOP_pmpermflags(o) o->op_pmpermflags
996 # define PMOP_pmdynflags(o) o->op_pmdynflags
998 #define PMOP_pmnext(o) o->op_pmnext
999 #define PMOP_pmregexp(o) PM_GETRE(o)
1001 #define PMOP_pmoffset(o) o->op_pmoffset
1002 #define PMOP_pmstashpv(o) PmopSTASHPV(o);
1004 #define PMOP_pmstash(o) PmopSTASH(o);
1006 #define PMOP_pmflags(o) o->op_pmflags
1008 MODULE = B PACKAGE = B::PMOP PREFIX = PMOP_
1010 #if PERL_VERSION <= 8
1017 ST(0) = sv_newmortal();
1018 root = o->op_pmreplroot;
1019 /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */
1020 if (o->op_type == OP_PUSHRE) {
1021 # ifdef USE_ITHREADS
1022 sv_setiv(ST(0), INT2PTR(PADOFFSET,root) );
1024 sv_setiv(newSVrv(ST(0), root ?
1025 svclassnames[SvTYPE((SV*)root)] : "B::SV"),
1030 sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root));
1039 ST(0) = sv_newmortal();
1040 if (o->op_type == OP_PUSHRE) {
1041 # ifdef USE_ITHREADS
1042 sv_setiv(ST(0), o->op_pmreplrootu.op_pmtargetoff);
1044 GV *const target = o->op_pmreplrootu.op_pmtargetgv;
1045 sv_setiv(newSVrv(ST(0), target ?
1046 svclassnames[SvTYPE((SV*)target)] : "B::SV"),
1051 OP *const root = o->op_pmreplrootu.op_pmreplroot;
1052 sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)),
1062 #if PERL_VERSION < 9
1092 #if PERL_VERSION < 9
1107 REGEXP * rx = NO_INIT
1109 ST(0) = sv_newmortal();
1112 sv_setpvn(ST(0), RX_PRECOMP(rx), RX_PRELEN(rx));
1114 #if PERL_VERSION >= 9
1119 REGEXP * rx = NO_INIT
1121 ST(0) = sv_newmortal();
1124 sv_setuv(ST(0), rx->extflags);
1128 #define SVOP_sv(o) cSVOPo->op_sv
1129 #define SVOP_gv(o) ((GV*)cSVOPo->op_sv)
1131 MODULE = B PACKAGE = B::SVOP PREFIX = SVOP_
1141 #define PADOP_padix(o) o->op_padix
1142 #define PADOP_sv(o) (o->op_padix ? PAD_SVl(o->op_padix) : Nullsv)
1143 #define PADOP_gv(o) ((o->op_padix \
1144 && SvTYPE(PAD_SVl(o->op_padix)) == SVt_PVGV) \
1145 ? (GV*)PAD_SVl(o->op_padix) : Nullgv)
1147 MODULE = B PACKAGE = B::PADOP PREFIX = PADOP_
1161 MODULE = B PACKAGE = B::PVOP PREFIX = PVOP_
1168 * OP_TRANS uses op_pv to point to a table of 256 or >=258 shorts
1169 * whereas other PVOPs point to a null terminated string.
1171 if (o->op_type == OP_TRANS &&
1172 (o->op_private & OPpTRANS_COMPLEMENT) &&
1173 !(o->op_private & OPpTRANS_DELETE))
1175 const short* const tbl = (short*)o->op_pv;
1176 const short entries = 257 + tbl[256];
1177 ST(0) = sv_2mortal(newSVpv(o->op_pv, entries * sizeof(short)));
1179 else if (o->op_type == OP_TRANS) {
1180 ST(0) = sv_2mortal(newSVpv(o->op_pv, 256 * sizeof(short)));
1183 ST(0) = sv_2mortal(newSVpv(o->op_pv, 0));
1185 #define LOOP_redoop(o) o->op_redoop
1186 #define LOOP_nextop(o) o->op_nextop
1187 #define LOOP_lastop(o) o->op_lastop
1189 MODULE = B PACKAGE = B::LOOP PREFIX = LOOP_
1204 #define COP_label(o) o->cop_label
1205 #define COP_stashpv(o) CopSTASHPV(o)
1206 #define COP_stash(o) CopSTASH(o)
1207 #define COP_file(o) CopFILE(o)
1208 #define COP_filegv(o) CopFILEGV(o)
1209 #define COP_cop_seq(o) o->cop_seq
1210 #define COP_arybase(o) CopARYBASE_get(o)
1211 #define COP_line(o) CopLINE(o)
1212 #define COP_hints(o) CopHINTS_get(o)
1213 #if PERL_VERSION < 9
1214 # define COP_warnings(o) o->cop_warnings
1215 # define COP_io(o) o->cop_io
1218 MODULE = B PACKAGE = B::COP PREFIX = COP_
1253 #if PERL_VERSION >= 9
1259 ST(0) = make_warnings_object(aTHX_ sv_newmortal(), o->cop_warnings);
1266 ST(0) = make_cop_io_object(aTHX_ sv_newmortal(), o);
1273 RETVAL = o->cop_hints_hash;
1293 MODULE = B PACKAGE = B::SV
1299 #define object_2svref(sv) sv
1306 MODULE = B PACKAGE = B::SV PREFIX = Sv
1328 MODULE = B PACKAGE = B::IV PREFIX = Sv
1343 MODULE = B PACKAGE = B::IV
1345 #define needs64bits(sv) ((I32)SvIVX(sv) != SvIVX(sv))
1355 if (sizeof(IV) == 8) {
1357 const IV iv = SvIVX(sv);
1359 * The following way of spelling 32 is to stop compilers on
1360 * 32-bit architectures from moaning about the shift count
1361 * being >= the width of the type. Such architectures don't
1362 * reach this code anyway (unless sizeof(IV) > 8 but then
1363 * everything else breaks too so I'm not fussed at the moment).
1366 wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4));
1368 wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4));
1370 wp[1] = htonl(iv & 0xffffffff);
1371 ST(0) = sv_2mortal(newSVpvn((char *)wp, 8));
1373 U32 w = htonl((U32)SvIVX(sv));
1374 ST(0) = sv_2mortal(newSVpvn((char *)&w, 4));
1378 #if PERL_VERSION >= 11
1388 croak( "argument is not SvROK" );
1395 MODULE = B PACKAGE = B::NV PREFIX = Sv
1406 COP_SEQ_RANGE_LOW(sv)
1410 COP_SEQ_RANGE_HIGH(sv)
1414 PARENT_PAD_INDEX(sv)
1418 PARENT_FAKELEX_FLAGS(sv)
1421 #if PERL_VERSION < 11
1423 MODULE = B PACKAGE = B::RV PREFIX = Sv
1431 MODULE = B PACKAGE = B::PV PREFIX = Sv
1445 croak( "argument is not SvROK" );
1454 ST(0) = sv_newmortal();
1456 /* FIXME - we need a better way for B to identify PVs that are
1457 in the pads as variable names. */
1458 if((SvLEN(sv) && SvCUR(sv) >= SvLEN(sv))) {
1459 /* It claims to be longer than the space allocated for it -
1460 presuambly it's a variable name in the pad */
1461 sv_setpv(ST(0), SvPV_nolen_const(sv));
1463 sv_setpvn(ST(0), SvPVX_const(sv), SvCUR(sv));
1465 SvFLAGS(ST(0)) |= SvUTF8(sv);
1468 /* XXX for backward compatibility, but should fail */
1469 /* croak( "argument is not SvPOK" ); */
1470 sv_setpvn(ST(0), NULL, 0);
1473 # This used to read 257. I think that that was buggy - should have been 258.
1474 # (The "\0", the flags byte, and 256 for the table. Not that anything
1475 # anywhere calls this method. NWC.
1480 ST(0) = sv_newmortal();
1481 sv_setpvn(ST(0), SvPVX_const(sv),
1482 SvCUR(sv) + (SvVALID(sv) ? 256 + PERL_FBM_TABLE_OFFSET : 0));
1493 MODULE = B PACKAGE = B::PVMG PREFIX = Sv
1498 MAGIC * mg = NO_INIT
1500 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
1501 XPUSHs(make_mg_object(aTHX_ sv_newmortal(), mg));
1503 MODULE = B PACKAGE = B::PVMG
1509 MODULE = B PACKAGE = B::REGEXP
1511 #if PERL_VERSION >= 11
1517 RETVAL = PTR2IV(((struct xregexp *)SvANY(sv))->xrx_regexp);
1524 REGEXP* rx = NO_INIT
1526 rx = ((struct xregexp *)SvANY(sv))->xrx_regexp;
1527 /* FIXME - UTF-8? And the equivalent precomp methods? */
1528 RETVAL = newSVpvn( RX_PRECOMP(rx), RX_PRELEN(rx) );
1534 #define MgMOREMAGIC(mg) mg->mg_moremagic
1535 #define MgPRIVATE(mg) mg->mg_private
1536 #define MgTYPE(mg) mg->mg_type
1537 #define MgFLAGS(mg) mg->mg_flags
1538 #define MgOBJ(mg) mg->mg_obj
1539 #define MgLENGTH(mg) mg->mg_len
1540 #define MgREGEX(mg) PTR2IV(mg->mg_obj)
1542 MODULE = B PACKAGE = B::MAGIC PREFIX = Mg
1548 if( MgMOREMAGIC(mg) ) {
1549 RETVAL = MgMOREMAGIC(mg);
1577 if(mg->mg_type == PERL_MAGIC_qr) {
1578 RETVAL = MgREGEX(mg);
1581 croak( "REGEX is only meaningful on r-magic" );
1590 if (mg->mg_type == PERL_MAGIC_qr) {
1591 REGEXP* rx = (REGEXP*)mg->mg_obj;
1594 RETVAL = newSVpvn( RX_PRECOMP(rx), RX_PRELEN(rx) );
1597 croak( "precomp is only meaningful on r-magic" );
1610 ST(0) = sv_newmortal();
1612 if (mg->mg_len >= 0){
1613 sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len);
1614 } else if (mg->mg_len == HEf_SVKEY) {
1615 ST(0) = make_sv_object(aTHX_
1616 sv_newmortal(), (SV*)mg->mg_ptr);
1620 MODULE = B PACKAGE = B::PVLV PREFIX = Lv
1638 MODULE = B PACKAGE = B::BM PREFIX = Bm
1655 STRLEN len = NO_INIT
1656 char * str = NO_INIT
1658 str = SvPV(sv, len);
1659 /* Boyer-Moore table is just after string and its safety-margin \0 */
1660 ST(0) = sv_2mortal(newSVpvn(str + len + PERL_FBM_TABLE_OFFSET, 256));
1662 MODULE = B PACKAGE = B::GV PREFIX = Gv
1668 ST(0) = sv_2mortal(newSVpvn(GvNAME(gv), GvNAMELEN(gv)));
1674 RETVAL = GvGP(gv) == Null(GP*);
1682 #if PERL_VERSION >= 9
1683 RETVAL = isGV_with_GP(gv) ? TRUE : FALSE;
1685 RETVAL = TRUE; /* In 5.8 and earlier they all are. */
1710 RETVAL = (SV*)GvFORM(gv);
1746 MODULE = B PACKAGE = B::GV
1756 MODULE = B PACKAGE = B::IO PREFIX = Io
1798 #if PERL_VERSION <= 8
1813 if( strEQ( name, "stdin" ) ) {
1814 handle = PerlIO_stdin();
1816 else if( strEQ( name, "stdout" ) ) {
1817 handle = PerlIO_stdout();
1819 else if( strEQ( name, "stderr" ) ) {
1820 handle = PerlIO_stderr();
1823 croak( "Invalid value '%s'", name );
1825 RETVAL = handle == IoIFP(io);
1829 MODULE = B PACKAGE = B::IO
1839 MODULE = B PACKAGE = B::AV PREFIX = Av
1849 #if PERL_VERSION < 9
1852 #define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
1864 if (AvFILL(av) >= 0) {
1865 SV **svp = AvARRAY(av);
1867 for (i = 0; i <= AvFILL(av); i++)
1868 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), svp[i]));
1876 if (idx >= 0 && AvFILL(av) >= 0 && idx <= AvFILL(av))
1877 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), (AvARRAY(av)[idx])));
1879 XPUSHs(make_sv_object(aTHX_ sv_newmortal(), NULL));
1881 #if PERL_VERSION < 9
1883 MODULE = B PACKAGE = B::AV
1891 MODULE = B PACKAGE = B::FM PREFIX = Fm
1897 MODULE = B PACKAGE = B::CV PREFIX = Cv
1911 RETVAL = CvISXSUB(cv) ? NULL : CvSTART(cv);
1919 RETVAL = CvISXSUB(cv) ? NULL : CvROOT(cv);
1951 ST(0) = sv_2mortal(newSViv(CvISXSUB(cv) ? PTR2IV(CvXSUB(cv)) : 0));
1958 ST(0) = CvCONST(cv) ?
1959 make_sv_object(aTHX_ sv_newmortal(),(SV *)CvXSUBANY(cv).any_ptr) :
1960 sv_2mortal(newSViv(CvISXSUB(cv) ? CvXSUBANY(cv).any_iv : 0));
1962 MODULE = B PACKAGE = B::CV
1968 MODULE = B PACKAGE = B::CV PREFIX = cv_
1975 MODULE = B PACKAGE = B::HV PREFIX = Hv
1997 #if PERL_VERSION < 9
2009 if (HvKEYS(hv) > 0) {
2013 (void)hv_iterinit(hv);
2014 EXTEND(sp, HvKEYS(hv) * 2);
2015 while ((sv = hv_iternextsv(hv, &key, &len))) {
2016 PUSHs(newSVpvn(key, len));
2017 PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv));
2021 MODULE = B PACKAGE = B::HE PREFIX = He
2035 MODULE = B PACKAGE = B::RHE PREFIX = RHE_
2037 #if PERL_VERSION >= 9
2043 RETVAL = newRV( (SV*)Perl_refcounted_he_chain_2hv(aTHX_ h) );