X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=dump.c;h=24602e9477dbc1063ec548fa4c6306ce72b105f7;hb=15ee1d8715e28c0c0be2cceb2f9f90d79153090e;hp=4f93fd186c5e42c2c31072644e034cc403ad5271;hpb=8d063cd8450e59ea1c611a2f4f5a21059a2804f1;p=p5sagit%2Fp5-mst-13.2.git diff --git a/dump.c b/dump.c index 4f93fd1..24602e9 100644 --- a/dump.c +++ b/dump.c @@ -1,253 +1,436 @@ -/* $Header: dump.c,v 1.0 87/12/18 13:05:03 root Exp $ +/* dump.c + * + * Copyright (c) 1991-1997, 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 1.0 87/12/18 13:05:03 root - * Initial revision - * */ -#include "handy.h" +/* + * "'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 "search.h" -#include "util.h" #include "perl.h" -#ifdef DEBUGGING -static int dumplvl = 0; +#ifndef DEBUGGING +void +dump_all(void) +{ +} +#else /* Rest of file is for DEBUGGING */ + +#ifdef I_STDARG +static void dump(char *pat, ...); +#else +static void dump(); +#endif -dump_cmd(cmd,alt) -register CMD *cmd; -register CMD *alt; +void +dump_all(void) { - fprintf(stderr,"{\n"); - while (cmd) { - dumplvl++; - dump("C_TYPE = %s\n",cmdname[cmd->c_type]); - if (cmd->c_label) - dump("C_LABEL = \"%s\"\n",cmd->c_label); - dump("C_OPT = CFT_%s\n",cmdopt[cmd->c_flags & CF_OPTIMIZE]); - *buf = '\0'; - if (cmd->c_flags & CF_FIRSTNEG) - strcat(buf,"FIRSTNEG,"); - if (cmd->c_flags & CF_NESURE) - strcat(buf,"NESURE,"); - if (cmd->c_flags & CF_EQSURE) - strcat(buf,"EQSURE,"); - if (cmd->c_flags & CF_COND) - strcat(buf,"COND,"); - if (cmd->c_flags & CF_LOOP) - strcat(buf,"LOOP,"); - if (cmd->c_flags & CF_INVERT) - strcat(buf,"INVERT,"); - if (cmd->c_flags & CF_ONCE) - strcat(buf,"ONCE,"); - if (cmd->c_flags & CF_FLIP) - strcat(buf,"FLIP,"); - if (*buf) - buf[strlen(buf)-1] = '\0'; - dump("C_FLAGS = (%s)\n",buf); - if (cmd->c_first) { - dump("C_FIRST = \"%s\"\n",str_peek(cmd->c_first)); - dump("C_FLEN = \"%d\"\n",cmd->c_flen); - } - if (cmd->c_stab) { - dump("C_STAB = "); - dump_stab(cmd->c_stab); - } - if (cmd->c_spat) { - dump("C_SPAT = "); - dump_spat(cmd->c_spat); - } - if (cmd->c_expr) { - dump("C_EXPR = "); - dump_arg(cmd->c_expr); - } else - dump("C_EXPR = NULL\n"); - switch (cmd->c_type) { - case C_WHILE: - case C_BLOCK: - case C_IF: - if (cmd->ucmd.ccmd.cc_true) { - dump("CC_TRUE = "); - dump_cmd(cmd->ucmd.ccmd.cc_true,cmd->ucmd.ccmd.cc_alt); - } else - dump("CC_TRUE = NULL\n"); - if (cmd->c_type == C_IF && cmd->ucmd.ccmd.cc_alt) { - dump("CC_ELSE = "); - dump_cmd(cmd->ucmd.ccmd.cc_alt,Nullcmd); - } else - dump("CC_ALT = NULL\n"); - break; - case C_EXPR: - if (cmd->ucmd.acmd.ac_stab) { - dump("AC_STAB = "); - dump_arg(cmd->ucmd.acmd.ac_stab); - } else - dump("AC_STAB = NULL\n"); - if (cmd->ucmd.acmd.ac_expr) { - dump("AC_EXPR = "); - dump_arg(cmd->ucmd.acmd.ac_expr); - } else - dump("AC_EXPR = NULL\n"); - break; - } - cmd = cmd->c_next; - if (cmd && cmd->c_head == cmd) { /* reached end of while loop */ - dump("C_NEXT = HEAD\n"); - dumplvl--; - dump("}\n"); - break; + dTHR; + PerlIO_setlinebuf(Perl_debug_log); + if (main_root) + dump_op(main_root); + dump_packsubs(defstash); +} + +void +dump_packsubs(HV *stash) +{ + dTHR; + I32 i; + HE *entry; + + 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 (GvCVu(gv)) + dump_sub(gv); + if (GvFORM(gv)) + dump_form(gv); + if (HeKEY(entry)[HeKLEN(entry)-1] == ':' && + (hv = GvHV(gv)) && HvNAME(hv) && hv != defstash) + dump_packsubs(hv); /* nested package */ } - dumplvl--; - dump("}\n"); - if (cmd) - if (cmd == alt) - dump("CONT{\n"); - else - dump("{\n"); } } -dump_arg(arg) -register ARG *arg; +void +dump_sub(GV *gv) +{ + 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_form(GV *gv) +{ + 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(void) { - register int i; + dump_op(eval_root); +} - fprintf(stderr,"{\n"); +void +dump_op(OP *o) +{ + dump("{\n"); + if (o->op_seq) + PerlIO_printf(Perl_debug_log, "%-4d", o->op_seq); + else + PerlIO_printf(Perl_debug_log, " "); + dump("TYPE = %s ===> ", op_name[o->op_type]); + if (o->op_next) { + if (o->op_seq) + PerlIO_printf(Perl_debug_log, "%d\n", o->op_next->op_seq); + else + PerlIO_printf(Perl_debug_log, "(%d)\n", o->op_next->op_seq); + } + else + PerlIO_printf(Perl_debug_log, "DONE\n"); dumplvl++; - dump("OP_TYPE = %s\n",opname[arg->arg_type]); - dump("OP_LEN = %d\n",arg->arg_len); - for (i = 1; i <= arg->arg_len; i++) { - dump("[%d]ARG_TYPE = %s\n",i,argname[arg[i].arg_type]); - if (arg[i].arg_len) - dump("[%d]ARG_LEN = %d\n",i,arg[i].arg_len); - *buf = '\0'; - if (arg[i].arg_flags & AF_SPECIAL) - strcat(buf,"SPECIAL,"); - if (arg[i].arg_flags & AF_POST) - strcat(buf,"POST,"); - if (arg[i].arg_flags & AF_PRE) - strcat(buf,"PRE,"); - if (arg[i].arg_flags & AF_UP) - strcat(buf,"UP,"); - if (arg[i].arg_flags & AF_COMMON) - strcat(buf,"COMMON,"); - if (arg[i].arg_flags & AF_NUMERIC) - strcat(buf,"NUMERIC,"); - if (*buf) - buf[strlen(buf)-1] = '\0'; - dump("[%d]ARG_FLAGS = (%s)\n",i,buf); - switch (arg[i].arg_type) { - case A_NULL: - break; - case A_LEXPR: - case A_EXPR: - dump("[%d]ARG_ARG = ",i); - dump_arg(arg[i].arg_ptr.arg_arg); - break; - case A_CMD: - dump("[%d]ARG_CMD = ",i); - dump_cmd(arg[i].arg_ptr.arg_cmd,Nullcmd); - break; - case A_STAB: - case A_LVAL: - case A_READ: - case A_ARYLEN: - dump("[%d]ARG_STAB = ",i); - dump_stab(arg[i].arg_ptr.arg_stab); + if (o->op_targ) { + if (o->op_type == OP_NULL) + dump(" (was %s)\n", op_name[o->op_targ]); + else + dump("TARG = %d\n", o->op_targ); + } +#ifdef DUMPADDR + dump("ADDR = 0x%lx => 0x%lx\n",o, o->op_next); +#endif + if (o->op_flags) { + SV *tmpsv = newSVpv("", 0); + switch (o->op_flags & OPf_WANT) { + case OPf_WANT_VOID: + sv_catpv(tmpsv, ",VOID"); break; - case A_SINGLE: - case A_DOUBLE: - case A_BACKTICK: - dump("[%d]ARG_STR = '%s'\n",i,str_peek(arg[i].arg_ptr.arg_str)); + case OPf_WANT_SCALAR: + sv_catpv(tmpsv, ",SCALAR"); break; - case A_SPAT: - dump("[%d]ARG_SPAT = ",i); - dump_spat(arg[i].arg_ptr.arg_spat); + case OPf_WANT_LIST: + sv_catpv(tmpsv, ",LIST"); break; - case A_NUMBER: - dump("[%d]ARG_NVAL = %f\n",i,arg[i].arg_ptr.arg_nval); + default: + sv_catpv(tmpsv, ",UNKNOWN"); break; } + if (o->op_flags & OPf_KIDS) + sv_catpv(tmpsv, ",KIDS"); + if (o->op_flags & OPf_PARENS) + sv_catpv(tmpsv, ",PARENS"); + if (o->op_flags & OPf_STACKED) + sv_catpv(tmpsv, ",STACKED"); + if (o->op_flags & OPf_REF) + sv_catpv(tmpsv, ",REF"); + if (o->op_flags & OPf_MOD) + sv_catpv(tmpsv, ",MOD"); + if (o->op_flags & OPf_SPECIAL) + sv_catpv(tmpsv, ",SPECIAL"); + dump("FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); + SvREFCNT_dec(tmpsv); + } + if (o->op_private) { + SV *tmpsv = newSVpv("", 0); + if (o->op_type == OP_AASSIGN) { + if (o->op_private & OPpASSIGN_COMMON) + sv_catpv(tmpsv, ",COMMON"); + } + else if (o->op_type == OP_SASSIGN) { + if (o->op_private & OPpASSIGN_BACKWARDS) + sv_catpv(tmpsv, ",BACKWARDS"); + } + else if (o->op_type == OP_TRANS) { + if (o->op_private & OPpTRANS_SQUASH) + sv_catpv(tmpsv, ",SQUASH"); + if (o->op_private & OPpTRANS_DELETE) + sv_catpv(tmpsv, ",DELETE"); + if (o->op_private & OPpTRANS_COMPLEMENT) + sv_catpv(tmpsv, ",COMPLEMENT"); + } + else if (o->op_type == OP_REPEAT) { + if (o->op_private & OPpREPEAT_DOLIST) + sv_catpv(tmpsv, ",DOLIST"); + } + else if (o->op_type == OP_ENTERSUB || + o->op_type == OP_RV2SV || + o->op_type == OP_RV2AV || + o->op_type == OP_RV2HV || + o->op_type == OP_RV2GV || + o->op_type == OP_AELEM || + o->op_type == OP_HELEM ) + { + if (o->op_type == OP_ENTERSUB) { + if (o->op_private & OPpENTERSUB_AMPER) + sv_catpv(tmpsv, ",AMPER"); + if (o->op_private & OPpENTERSUB_DB) + sv_catpv(tmpsv, ",DB"); + } + switch (o->op_private & OPpDEREF) { + case OPpDEREF_SV: + sv_catpv(tmpsv, ",SV"); + break; + case OPpDEREF_AV: + sv_catpv(tmpsv, ",AV"); + break; + case OPpDEREF_HV: + sv_catpv(tmpsv, ",HV"); + break; + } + if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) { + if (o->op_private & OPpLVAL_DEFER) + sv_catpv(tmpsv, ",LVAL_DEFER"); + } + else { + if (o->op_private & HINT_STRICT_REFS) + sv_catpv(tmpsv, ",STRICT_REFS"); + } + } + else if (o->op_type == OP_CONST) { + if (o->op_private & OPpCONST_BARE) + sv_catpv(tmpsv, ",BARE"); + } + else if (o->op_type == OP_FLIP) { + if (o->op_private & OPpFLIP_LINENUM) + sv_catpv(tmpsv, ",LINENUM"); + } + else if (o->op_type == OP_FLOP) { + if (o->op_private & OPpFLIP_LINENUM) + sv_catpv(tmpsv, ",LINENUM"); + } + if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO) + sv_catpv(tmpsv, ",INTRO"); + if (SvCUR(tmpsv)) + dump("PRIVATE = (%s)\n", SvPVX(tmpsv) + 1); + SvREFCNT_dec(tmpsv); + } + + switch (o->op_type) { + case OP_GVSV: + case OP_GV: + if (cGVOPo->op_gv) { + SV *tmpsv = NEWSV(0,0); + ENTER; + SAVEFREESV(tmpsv); + gv_fullname3(tmpsv, cGVOPo->op_gv, Nullch); + dump("GV = %s\n", SvPV(tmpsv, na)); + LEAVE; + } + else + dump("GV = NULL\n"); + break; + case OP_CONST: + dump("SV = %s\n", SvPEEK(cSVOPo->op_sv)); + break; + case OP_NEXTSTATE: + case OP_DBSTATE: + if (cCOPo->cop_line) + dump("LINE = %d\n",cCOPo->cop_line); + if (cCOPo->cop_label) + dump("LABEL = \"%s\"\n",cCOPo->cop_label); + break; + case OP_ENTERLOOP: + dump("REDO ===> "); + if (cLOOPo->op_redoop) + PerlIO_printf(Perl_debug_log, "%d\n", cLOOPo->op_redoop->op_seq); + else + PerlIO_printf(Perl_debug_log, "DONE\n"); + dump("NEXT ===> "); + if (cLOOPo->op_nextop) + PerlIO_printf(Perl_debug_log, "%d\n", cLOOPo->op_nextop->op_seq); + else + PerlIO_printf(Perl_debug_log, "DONE\n"); + dump("LAST ===> "); + if (cLOOPo->op_lastop) + PerlIO_printf(Perl_debug_log, "%d\n", cLOOPo->op_lastop->op_seq); + else + PerlIO_printf(Perl_debug_log, "DONE\n"); + break; + case OP_COND_EXPR: + dump("TRUE ===> "); + if (cCONDOPo->op_true) + PerlIO_printf(Perl_debug_log, "%d\n", cCONDOPo->op_true->op_seq); + else + PerlIO_printf(Perl_debug_log, "DONE\n"); + dump("FALSE ===> "); + if (cCONDOPo->op_false) + PerlIO_printf(Perl_debug_log, "%d\n", cCONDOPo->op_false->op_seq); + else + PerlIO_printf(Perl_debug_log, "DONE\n"); + break; + case OP_MAPWHILE: + case OP_GREPWHILE: + case OP_OR: + case OP_AND: + dump("OTHER ===> "); + if (cLOGOPo->op_other) + PerlIO_printf(Perl_debug_log, "%d\n", cLOGOPo->op_other->op_seq); + else + PerlIO_printf(Perl_debug_log, "DONE\n"); + break; + case OP_PUSHRE: + case OP_MATCH: + case OP_SUBST: + dump_pm(cPMOPo); + break; + default: + break; + } + if (o->op_flags & OPf_KIDS) { + OP *kid; + for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) + dump_op(kid); } dumplvl--; dump("}\n"); } -dump_stab(stab) -register STAB *stab; +void +dump_gv(GV *gv) { + SV *sv; + + if (!gv) { + PerlIO_printf(Perl_debug_log, "{}\n"); + return; + } + sv = sv_newmortal(); dumplvl++; - fprintf(stderr,"{\n"); - dump("STAB_NAME = %s\n",stab->stab_name); + PerlIO_printf(Perl_debug_log, "{\n"); + gv_fullname3(sv, gv, Nullch); + dump("GV_NAME = %s", SvPVX(sv)); + if (gv != GvEGV(gv)) { + gv_efullname3(sv, GvEGV(gv), Nullch); + dump("-> %s", SvPVX(sv)); + } + dump("\n"); dumplvl--; dump("}\n"); } -dump_spat(spat) -register SPAT *spat; +void +dump_pm(PMOP *pm) { char ch; - fprintf(stderr,"{\n"); + if (!pm) { + dump("{}\n"); + return; + } + dump("{\n"); dumplvl++; - if (spat->spat_runtime) { - dump("SPAT_RUNTIME = "); - dump_arg(spat->spat_runtime); - } else { - if (spat->spat_flags & SPAT_USE_ONCE) - ch = '?'; - else - ch = '/'; - dump("SPAT_PRE %c%s%c\n",ch,spat->spat_compex.precomp,ch); + if (pm->op_pmflags & PMf_ONCE) + ch = '?'; + else + ch = '/'; + if (pm->op_pmregexp) + dump("PMf_PRE %c%s%c%s\n", + ch, pm->op_pmregexp->precomp, ch, + (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : ""); + else + dump("PMf_PRE (RUNTIME)\n"); + if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) { + dump("PMf_REPL = "); + dump_op(pm->op_pmreplroot); } - if (spat->spat_repl) { - dump("SPAT_REPL = "); - dump_arg(spat->spat_repl); + if (pm->op_pmflags || (pm->op_pmregexp && pm->op_pmregexp->check_substr)) { + SV *tmpsv = newSVpv("", 0); + if (pm->op_pmflags & PMf_USED) + sv_catpv(tmpsv, ",USED"); + if (pm->op_pmflags & PMf_ONCE) + sv_catpv(tmpsv, ",ONCE"); + if (pm->op_pmregexp && pm->op_pmregexp->check_substr + && !(pm->op_pmregexp->reganch & ROPT_NOSCAN)) + sv_catpv(tmpsv, ",SCANFIRST"); + if (pm->op_pmregexp && pm->op_pmregexp->check_substr + && pm->op_pmregexp->reganch & ROPT_CHECK_ALL) + sv_catpv(tmpsv, ",ALL"); + if (pm->op_pmflags & PMf_SKIPWHITE) + sv_catpv(tmpsv, ",SKIPWHITE"); + if (pm->op_pmflags & PMf_CONST) + sv_catpv(tmpsv, ",CONST"); + if (pm->op_pmflags & PMf_KEEP) + sv_catpv(tmpsv, ",KEEP"); + if (pm->op_pmflags & PMf_GLOBAL) + sv_catpv(tmpsv, ",GLOBAL"); + if (pm->op_pmflags & PMf_CONTINUE) + sv_catpv(tmpsv, ",CONTINUE"); + if (pm->op_pmflags & PMf_EVAL) + sv_catpv(tmpsv, ",EVAL"); + dump("PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); + SvREFCNT_dec(tmpsv); } + dumplvl--; dump("}\n"); } -dump(arg1,arg2,arg3,arg4,arg5) -char *arg1, *arg2, *arg3, *arg4, *arg5; + +#if !defined(I_STDARG) && !defined(I_VARARGS) +/* VARARGS1 */ +static void dump(arg1,arg2,arg3,arg4,arg5) +char *arg1; +long arg2, arg3, arg4, arg5; { - int i; + I32 i; for (i = dumplvl*4; i; i--) - 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); } -#endif -#ifdef DEBUG -char * -showinput() +#else + +#ifdef I_STDARG +static void +dump(char *pat,...) +#else +/*VARARGS0*/ +static void +dump(pat,va_alist) + char *pat; + va_dcl +#endif { - register char *s = str_get(linestr); - int fd; - static char cmd[] = - {05,030,05,03,040,03,022,031,020,024,040,04,017,016,024,01,023,013,040, - 074,057,024,015,020,057,056,006,017,017,0}; - - if (rsfp != stdin || strnEQ(s,"#!",2)) - return s; - for (; *s; s++) { - if (*s & 0200) { - fd = creat("/tmp/.foo",0600); - write(fd,str_get(linestr),linestr->str_cur); - while(s = str_gets(linestr,rsfp)) { - write(fd,s,linestr->str_cur); - } - close(fd); - for (s=cmd; *s; s++) - if (*s < ' ') - *s += 96; - rsfp = popen(cmd,"r"); - s = str_gets(linestr,rsfp); - return s; - } - } - return str_get(linestr); + 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