X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=dump.c;h=7aed230c70771375bad8138b08be0597ebdf3050;hb=8227f81cbd3d53a745747c4247824562383badae;hp=7839ed7828b1e0d79b4ab9e99eeaa709f998e40f;hpb=ed6116ce9b9d13712ea252ee248b0400653db7f9;p=p5sagit%2Fp5-mst-13.2.git diff --git a/dump.c b/dump.c index 7839ed7..7aed230 100644 --- a/dump.c +++ b/dump.c @@ -1,37 +1,37 @@ -/* $RCSfile: dump.c,v $$Revision: 4.1 $$Date: 92/08/07 17:20:03 $ +/* dump.c * - * Copyright (c) 1991, Larry Wall + * Copyright (c) 1991-1994, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * $Log: dump.c,v $ - * Revision 4.1 92/08/07 17:20:03 lwall - * Stage 6 Snapshot - * - * Revision 4.0.1.2 92/06/08 13:14:22 lwall - * patch20: removed implicit int declarations on funcions - * patch20: fixed confusion between a *var's real name and its effective name - * - * Revision 4.0.1.1 91/06/07 10:58:44 lwall - * patch4: new copyright notice - * - * Revision 4.0 91/03/20 01:08:25 lwall - * 4.0 baseline. - * + */ + +/* + * "'You have talked long in your sleep, Frodo,' said Gandalf gently, 'and + * it has not been hard for me to read your mind and memory.'" */ #include "EXTERN.h" #include "perl.h" -#ifdef DEBUGGING +#ifndef DEBUGGING +void +dump_all() +{ +} +#else /* Rest of file is for DEBUGGING */ +#ifdef I_STDARG +static void dump(char *pat, ...); +#else static void dump(); +#endif void dump_all() { - setlinebuf(stderr); + PerlIO_setlinebuf(Perl_debug_log); if (main_root) dump_op(main_root); dump_packsubs(defstash); @@ -41,17 +41,21 @@ void dump_packsubs(stash) HV* stash; { - U32 i; + I32 i; HE *entry; - for (i = 0; i <= HvMAX(stash); i++) { - for (entry = HvARRAY(stash)[i]; entry; entry = entry->hent_next) { - GV *gv = (GV*)entry->hent_val; + if (!HvARRAY(stash)) + return; + for (i = 0; i <= (I32) HvMAX(stash); i++) { + for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { + GV *gv = (GV*)HeVAL(entry); HV *hv; - if (GvCV(gv)) + if (GvCVu(gv)) dump_sub(gv); - if (*entry->hent_key == '_' && (hv = GvHV(gv)) && HvNAME(hv) && - hv != defstash) + if (GvFORM(gv)) + dump_form(gv); + if (HeKEY(entry)[HeKLEN(entry)-1] == ':' && + (hv = GvHV(gv)) && HvNAME(hv) && hv != defstash) dump_packsubs(hv); /* nested package */ } } @@ -61,28 +65,37 @@ void dump_sub(gv) GV* gv; { - SV *sv = sv_mortalcopy(&sv_undef); - if (GvCV(gv)) { - gv_fullname(sv,gv); - dump("\nSUB %s = ", SvPVX(sv)); - if (CvUSERSUB(GvCV(gv))) - dump("(xsub 0x%x %d)\n", - (long)CvUSERSUB(GvCV(gv)), - CvUSERINDEX(GvCV(gv))); - else if (CvROOT(GvCV(gv))) - dump_op(CvROOT(GvCV(gv))); - else - dump("\n"); - } + SV *sv = sv_newmortal(); + + gv_fullname3(sv, gv, Nullch); + dump("\nSUB %s = ", SvPVX(sv)); + if (CvXSUB(GvCV(gv))) + dump("(xsub 0x%x %d)\n", + (long)CvXSUB(GvCV(gv)), + CvXSUBANY(GvCV(gv)).any_i32); + else if (CvROOT(GvCV(gv))) + dump_op(CvROOT(GvCV(gv))); + else + dump("\n"); } void -dump_eval() +dump_form(gv) +GV* gv; { - register I32 i; - register GV *gv; - register HE *entry; + SV *sv = sv_newmortal(); + gv_fullname3(sv, gv, Nullch); + dump("\nFORMAT %s = ", SvPVX(sv)); + if (CvROOT(GvFORM(gv))) + dump_op(CvROOT(GvFORM(gv))); + else + dump("\n"); +} + +void +dump_eval() +{ dump_op(eval_root); } @@ -94,22 +107,26 @@ register OP *op; dump("{\n"); if (op->op_seq) - fprintf(stderr, "%-4d", op->op_seq); + PerlIO_printf(Perl_debug_log, "%-4d", op->op_seq); else - fprintf(stderr, " "); + PerlIO_printf(Perl_debug_log, " "); dump("TYPE = %s ===> ", op_name[op->op_type]); if (op->op_next) { if (op->op_seq) - fprintf(stderr, "%d\n", op->op_next->op_seq); + PerlIO_printf(Perl_debug_log, "%d\n", op->op_next->op_seq); else - fprintf(stderr, "(%d)\n", op->op_next->op_seq); + PerlIO_printf(Perl_debug_log, "(%d)\n", op->op_next->op_seq); } else - fprintf(stderr, "DONE\n"); + PerlIO_printf(Perl_debug_log, "DONE\n"); dumplvl++; - if (op->op_targ) - dump("TARG = %d\n", op->op_targ); -#ifdef NOTDEF + if (op->op_targ) { + if (op->op_type == OP_NULL) + dump(" (was %s)\n", op_name[op->op_targ]); + else + dump("TARG = %d\n", op->op_targ); + } +#ifdef DUMPADDR dump("ADDR = 0x%lx => 0x%lx\n",op, op->op_next); #endif if (op->op_flags) { @@ -128,10 +145,10 @@ register OP *op; (void)strcat(buf,"PARENS,"); if (op->op_flags & OPf_STACKED) (void)strcat(buf,"STACKED,"); - if (op->op_flags & OPf_LVAL) - (void)strcat(buf,"LVAL,"); - if (op->op_flags & OPf_INTRO) - (void)strcat(buf,"INTRO,"); + if (op->op_flags & OPf_REF) + (void)strcat(buf,"REF,"); + if (op->op_flags & OPf_MOD) + (void)strcat(buf,"MOD,"); if (op->op_flags & OPf_SPECIAL) (void)strcat(buf,"SPECIAL,"); if (*buf) @@ -144,6 +161,10 @@ register OP *op; if (op->op_private & OPpASSIGN_COMMON) (void)strcat(buf,"COMMON,"); } + else if (op->op_type == OP_SASSIGN) { + if (op->op_private & OPpASSIGN_BACKWARDS) + (void)strcat(buf,"BACKWARDS,"); + } else if (op->op_type == OP_TRANS) { if (op->op_private & OPpTRANS_SQUASH) (void)strcat(buf,"SQUASH,"); @@ -156,9 +177,31 @@ register OP *op; if (op->op_private & OPpREPEAT_DOLIST) (void)strcat(buf,"DOLIST,"); } - else if (op->op_type == OP_ENTERSUBR) { - if (op->op_private & OPpSUBR_DB) + else if (op->op_type == OP_ENTERSUB || + op->op_type == OP_RV2SV || + op->op_type == OP_RV2AV || + op->op_type == OP_RV2HV || + op->op_type == OP_RV2GV || + op->op_type == OP_AELEM || + op->op_type == OP_HELEM ) + { + if (op->op_private & OPpENTERSUB_AMPER) + (void)strcat(buf,"AMPER,"); + if (op->op_private & OPpENTERSUB_DB) (void)strcat(buf,"DB,"); + switch (op->op_private & OPpDEREF) { + case OPpDEREF_SV: + (void)strcat(buf, "SV,"); + break; + case OPpDEREF_AV: + (void)strcat(buf, "AV,"); + break; + case OPpDEREF_HV: + (void)strcat(buf, "HV,"); + break; + } + if (op->op_private & HINT_STRICT_REFS) + (void)strcat(buf,"STRICT_REFS,"); } else if (op->op_type == OP_CONST) { if (op->op_private & OPpCONST_BARE) @@ -172,6 +215,8 @@ register OP *op; if (op->op_private & OPpFLIP_LINENUM) (void)strcat(buf,"LINENUM,"); } + if (op->op_flags & OPf_MOD && op->op_private & OPpLVAL_INTRO) + (void)strcat(buf,"INTRO,"); if (*buf) { buf[strlen(buf)-1] = '\0'; dump("PRIVATE = (%s)\n",buf); @@ -182,10 +227,12 @@ register OP *op; case OP_GVSV: case OP_GV: if (cGVOP->op_gv) { + ENTER; tmpsv = NEWSV(0,0); - gv_fullname(tmpsv,cGVOP->op_gv); + SAVEFREESV(tmpsv); + gv_fullname3(tmpsv, cGVOP->op_gv, Nullch); dump("GV = %s\n", SvPV(tmpsv, na)); - sv_free(tmpsv); + LEAVE; } else dump("GV = NULL\n"); @@ -203,47 +250,49 @@ register OP *op; case OP_ENTERLOOP: dump("REDO ===> "); if (cLOOP->op_redoop) - fprintf(stderr, "%d\n", cLOOP->op_redoop->op_seq); + PerlIO_printf(Perl_debug_log, "%d\n", cLOOP->op_redoop->op_seq); else - fprintf(stderr, "DONE\n"); + PerlIO_printf(Perl_debug_log, "DONE\n"); dump("NEXT ===> "); if (cLOOP->op_nextop) - fprintf(stderr, "%d\n", cLOOP->op_nextop->op_seq); + PerlIO_printf(Perl_debug_log, "%d\n", cLOOP->op_nextop->op_seq); else - fprintf(stderr, "DONE\n"); + PerlIO_printf(Perl_debug_log, "DONE\n"); dump("LAST ===> "); if (cLOOP->op_lastop) - fprintf(stderr, "%d\n", cLOOP->op_lastop->op_seq); + PerlIO_printf(Perl_debug_log, "%d\n", cLOOP->op_lastop->op_seq); else - fprintf(stderr, "DONE\n"); + PerlIO_printf(Perl_debug_log, "DONE\n"); break; case OP_COND_EXPR: dump("TRUE ===> "); if (cCONDOP->op_true) - fprintf(stderr, "%d\n", cCONDOP->op_true->op_seq); + PerlIO_printf(Perl_debug_log, "%d\n", cCONDOP->op_true->op_seq); else - fprintf(stderr, "DONE\n"); + PerlIO_printf(Perl_debug_log, "DONE\n"); dump("FALSE ===> "); if (cCONDOP->op_false) - fprintf(stderr, "%d\n", cCONDOP->op_false->op_seq); + PerlIO_printf(Perl_debug_log, "%d\n", cCONDOP->op_false->op_seq); else - fprintf(stderr, "DONE\n"); + PerlIO_printf(Perl_debug_log, "DONE\n"); break; + case OP_MAPWHILE: case OP_GREPWHILE: case OP_OR: case OP_AND: - case OP_METHOD: dump("OTHER ===> "); if (cLOGOP->op_other) - fprintf(stderr, "%d\n", cLOGOP->op_other->op_seq); + PerlIO_printf(Perl_debug_log, "%d\n", cLOGOP->op_other->op_seq); else - fprintf(stderr, "DONE\n"); + PerlIO_printf(Perl_debug_log, "DONE\n"); break; case OP_PUSHRE: case OP_MATCH: case OP_SUBST: dump_pm((PMOP*)op); break; + default: + break; } if (op->op_flags & OPf_KIDS) { OP *kid; @@ -261,16 +310,16 @@ register GV *gv; SV *sv; if (!gv) { - fprintf(stderr,"{}\n"); + PerlIO_printf(Perl_debug_log, "{}\n"); return; } - sv = sv_mortalcopy(&sv_undef); + sv = sv_newmortal(); dumplvl++; - fprintf(stderr,"{\n"); - gv_fullname(sv,gv); + PerlIO_printf(Perl_debug_log, "{\n"); + gv_fullname3(sv, gv, Nullch); dump("GV_NAME = %s", SvPVX(sv)); if (gv != GvEGV(gv)) { - gv_efullname(sv,GvEGV(gv)); + gv_efullname3(sv, GvEGV(gv), Nullch); dump("-> %s", SvPVX(sv)); } dump("\n"); @@ -315,8 +364,6 @@ register PMOP *pm; (void)strcat(buf,"ALL,"); if (pm->op_pmflags & PMf_SKIPWHITE) (void)strcat(buf,"SKIPWHITE,"); - if (pm->op_pmflags & PMf_FOLD) - (void)strcat(buf,"FOLD,"); if (pm->op_pmflags & PMf_CONST) (void)strcat(buf,"CONST,"); if (pm->op_pmflags & PMf_KEEP) @@ -336,6 +383,8 @@ register PMOP *pm; dump("}\n"); } + +#if !defined(I_STDARG) && !defined(I_VARARGS) /* VARARGS1 */ static void dump(arg1,arg2,arg3,arg4,arg5) char *arg1; @@ -344,7 +393,36 @@ long arg2, arg3, arg4, arg5; I32 i; for (i = dumplvl*4; i; i--) - (void)putc(' ',stderr); - fprintf(stderr,arg1, arg2, arg3, arg4, arg5); + (void)PerlIO_putc(Perl_debug_log,' '); + PerlIO_printf(Perl_debug_log, arg1, arg2, arg3, arg4, arg5); } + +#else + +#ifdef I_STDARG +static void +dump(char *pat,...) +#else +/*VARARGS0*/ +static void +dump(pat,va_alist) + char *pat; + va_dcl +#endif +{ + I32 i; + va_list args; + +#ifdef I_STDARG + va_start(args, pat); +#else + va_start(args); +#endif + for (i = dumplvl*4; i; i--) + (void)PerlIO_putc(Perl_debug_log,' '); + PerlIO_vprintf(Perl_debug_log,pat,args); + va_end(args); +} +#endif + #endif