dump.c

   1 /*    dump.c
   2  *
   3  *    Copyright (c) 1991-1994, Larry Wall
   4  *
   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.
   7  *
   8  */
   9
  10 /*
  11  * "'You have talked long in your sleep, Frodo,' said Gandalf gently, 'and
  12  * it has not been hard for me to read your mind and memory.'"
  13  */
  14
  15 #include "EXTERN.h"
  16 #include "perl.h"
  17
  18 #ifndef DEBUGGING
  19 void
  20 dump_all()
  21 {
  22 }
  23 #else  /* Rest of file is for DEBUGGING */
  24
  25 #ifdef I_STDARG
  26 static void dump(char *pat, ...);
  27 #else
  28 #  if defined(I_VARARGS)
  29 /*VARARGS0*/
  30 static void
  31 dump(pat, va_alist)
  32     char *pat;
  33     va_dcl
  34 #  else
  35 static void dump();
  36 #  endif
  37 #endif
  38
  39 void
  40 dump_all()
  41 {
  42 #ifdef HAS_SETLINEBUF
  43     setlinebuf(Perl_debug_log);
  44 #else
  45     setvbuf(Perl_debug_log, Nullch, _IOLBF, 0);
  46 #endif
  47     if (main_root)
  48         dump_op(main_root);
  49     dump_packsubs(defstash);
  50 }
  51
  52 void
  53 dump_packsubs(stash)
  54 HV* stash;
  55 {
  56     I32 i;
  57     HE  *entry;
  58
  59     if (!HvARRAY(stash))
  60         return;
  61     for (i = 0; i <= (I32) HvMAX(stash); i++) {
  62         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
  63             GV *gv = (GV*)HeVAL(entry);
  64             HV *hv;
  65             if (GvCV(gv))
  66                 dump_sub(gv);
  67             if (GvFORM(gv))
  68                 dump_form(gv);
  69             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
  70               (hv = GvHV(gv)) && HvNAME(hv) && hv != defstash)
  71                 dump_packsubs(hv);              /* nested package */
  72         }
  73     }
  74 }
  75
  76 void
  77 dump_sub(gv)
  78 GV* gv;
  79 {
  80     SV *sv = sv_newmortal();
  81
  82     gv_fullname(sv,gv);
  83     dump("\nSUB %s = ", SvPVX(sv));
  84     if (CvXSUB(GvCV(gv)))
  85         dump("(xsub 0x%x %d)\n",
  86             (long)CvXSUB(GvCV(gv)),
  87             CvXSUBANY(GvCV(gv)).any_i32);
  88     else if (CvROOT(GvCV(gv)))
  89         dump_op(CvROOT(GvCV(gv)));
  90     else
  91         dump("<undef>\n");
  92 }
  93
  94 void
  95 dump_form(gv)
  96 GV* gv;
  97 {
  98     SV *sv = sv_newmortal();
  99
 100     gv_fullname(sv,gv);
 101     dump("\nFORMAT %s = ", SvPVX(sv));
 102     if (CvROOT(GvFORM(gv)))
 103         dump_op(CvROOT(GvFORM(gv)));
 104     else
 105         dump("<undef>\n");
 106 }
 107
 108 void
 109 dump_eval()
 110 {
 111     dump_op(eval_root);
 112 }
 113
 114 void
 115 dump_op(op)
 116 register OP *op;
 117 {
 118     SV *tmpsv;
 119
 120     dump("{\n");
 121     if (op->op_seq)
 122         fprintf(Perl_debug_log, "%-4d", op->op_seq);
 123     else
 124         fprintf(Perl_debug_log, "    ");
 125     dump("TYPE = %s  ===> ", op_name[op->op_type]);
 126     if (op->op_next) {
 127         if (op->op_seq)
 128             fprintf(Perl_debug_log, "%d\n", op->op_next->op_seq);
 129         else
 130             fprintf(Perl_debug_log, "(%d)\n", op->op_next->op_seq);
 131     }
 132     else
 133         fprintf(Perl_debug_log, "DONE\n");
 134     dumplvl++;
 135     if (op->op_targ) {
 136         if (op->op_type == OP_NULL)
 137             dump("  (was %s)\n", op_name[op->op_targ]);
 138         else
 139             dump("TARG = %d\n", op->op_targ);
 140     }
 141 #ifdef DUMPADDR
 142     dump("ADDR = 0x%lx => 0x%lx\n",op, op->op_next);
 143 #endif
 144     if (op->op_flags) {
 145         *buf = '\0';
 146         if (op->op_flags & OPf_KNOW) {
 147             if (op->op_flags & OPf_LIST)
 148                 (void)strcat(buf,"LIST,");
 149             else
 150                 (void)strcat(buf,"SCALAR,");
 151         }
 152         else
 153             (void)strcat(buf,"UNKNOWN,");
 154         if (op->op_flags & OPf_KIDS)
 155             (void)strcat(buf,"KIDS,");
 156         if (op->op_flags & OPf_PARENS)
 157             (void)strcat(buf,"PARENS,");
 158         if (op->op_flags & OPf_STACKED)
 159             (void)strcat(buf,"STACKED,");
 160         if (op->op_flags & OPf_REF)
 161             (void)strcat(buf,"REF,");
 162         if (op->op_flags & OPf_MOD)
 163             (void)strcat(buf,"MOD,");
 164         if (op->op_flags & OPf_SPECIAL)
 165             (void)strcat(buf,"SPECIAL,");
 166         if (*buf)
 167             buf[strlen(buf)-1] = '\0';
 168         dump("FLAGS = (%s)\n",buf);
 169     }
 170     if (op->op_private) {
 171         *buf = '\0';
 172         if (op->op_type == OP_AASSIGN) {
 173             if (op->op_private & OPpASSIGN_COMMON)
 174                 (void)strcat(buf,"COMMON,");
 175         }
 176         else if (op->op_type == OP_SASSIGN) {
 177             if (op->op_private & OPpASSIGN_BACKWARDS)
 178                 (void)strcat(buf,"BACKWARDS,");
 179         }
 180         else if (op->op_type == OP_TRANS) {
 181             if (op->op_private & OPpTRANS_SQUASH)
 182                 (void)strcat(buf,"SQUASH,");
 183             if (op->op_private & OPpTRANS_DELETE)
 184                 (void)strcat(buf,"DELETE,");
 185             if (op->op_private & OPpTRANS_COMPLEMENT)
 186                 (void)strcat(buf,"COMPLEMENT,");
 187         }
 188         else if (op->op_type == OP_REPEAT) {
 189             if (op->op_private & OPpREPEAT_DOLIST)
 190                 (void)strcat(buf,"DOLIST,");
 191         }
 192         else if (op->op_type == OP_ENTERSUB ||
 193                  op->op_type == OP_RV2SV ||
 194                  op->op_type == OP_RV2AV ||
 195                  op->op_type == OP_RV2HV ||
 196                  op->op_type == OP_RV2GV ||
 197                  op->op_type == OP_AELEM ||
 198                  op->op_type == OP_HELEM )
 199         {
 200             if (op->op_private & OPpENTERSUB_AMPER)
 201                 (void)strcat(buf,"AMPER,");
 202             if (op->op_private & OPpENTERSUB_DB)
 203                 (void)strcat(buf,"DB,");
 204             if (op->op_private & OPpDEREF_AV)
 205                 (void)strcat(buf,"AV,");
 206             if (op->op_private & OPpDEREF_HV)
 207                 (void)strcat(buf,"HV,");
 208             if (op->op_private & HINT_STRICT_REFS)
 209                 (void)strcat(buf,"STRICT_REFS,");
 210         }
 211         else if (op->op_type == OP_CONST) {
 212             if (op->op_private & OPpCONST_BARE)
 213                 (void)strcat(buf,"BARE,");
 214         }
 215         else if (op->op_type == OP_FLIP) {
 216             if (op->op_private & OPpFLIP_LINENUM)
 217                 (void)strcat(buf,"LINENUM,");
 218         }
 219         else if (op->op_type == OP_FLOP) {
 220             if (op->op_private & OPpFLIP_LINENUM)
 221                 (void)strcat(buf,"LINENUM,");
 222         }
 223         if (op->op_flags & OPf_MOD && op->op_private & OPpLVAL_INTRO)
 224             (void)strcat(buf,"INTRO,");
 225         if (*buf) {
 226             buf[strlen(buf)-1] = '\0';
 227             dump("PRIVATE = (%s)\n",buf);
 228         }
 229     }
 230
 231     switch (op->op_type) {
 232     case OP_GVSV:
 233     case OP_GV:
 234         if (cGVOP->op_gv) {
 235             ENTER;
 236             tmpsv = NEWSV(0,0);
 237             SAVEFREESV(tmpsv);
 238             gv_fullname(tmpsv,cGVOP->op_gv);
 239             dump("GV = %s\n", SvPV(tmpsv, na));
 240             LEAVE;
 241         }
 242         else
 243             dump("GV = NULL\n");
 244         break;
 245     case OP_CONST:
 246         dump("SV = %s\n", SvPEEK(cSVOP->op_sv));
 247         break;
 248     case OP_NEXTSTATE:
 249     case OP_DBSTATE:
 250         if (cCOP->cop_line)
 251             dump("LINE = %d\n",cCOP->cop_line);
 252         if (cCOP->cop_label)
 253             dump("LABEL = \"%s\"\n",cCOP->cop_label);
 254         break;
 255     case OP_ENTERLOOP:
 256         dump("REDO ===> ");
 257         if (cLOOP->op_redoop)
 258             fprintf(Perl_debug_log, "%d\n", cLOOP->op_redoop->op_seq);
 259         else
 260             fprintf(Perl_debug_log, "DONE\n");
 261         dump("NEXT ===> ");
 262         if (cLOOP->op_nextop)
 263             fprintf(Perl_debug_log, "%d\n", cLOOP->op_nextop->op_seq);
 264         else
 265             fprintf(Perl_debug_log, "DONE\n");
 266         dump("LAST ===> ");
 267         if (cLOOP->op_lastop)
 268             fprintf(Perl_debug_log, "%d\n", cLOOP->op_lastop->op_seq);
 269         else
 270             fprintf(Perl_debug_log, "DONE\n");
 271         break;
 272     case OP_COND_EXPR:
 273         dump("TRUE ===> ");
 274         if (cCONDOP->op_true)
 275             fprintf(Perl_debug_log, "%d\n", cCONDOP->op_true->op_seq);
 276         else
 277             fprintf(Perl_debug_log, "DONE\n");
 278         dump("FALSE ===> ");
 279         if (cCONDOP->op_false)
 280             fprintf(Perl_debug_log, "%d\n", cCONDOP->op_false->op_seq);
 281         else
 282             fprintf(Perl_debug_log, "DONE\n");
 283         break;
 284     case OP_MAPWHILE:
 285     case OP_GREPWHILE:
 286     case OP_OR:
 287     case OP_AND:
 288         dump("OTHER ===> ");
 289         if (cLOGOP->op_other)
 290             fprintf(Perl_debug_log, "%d\n", cLOGOP->op_other->op_seq);
 291         else
 292             fprintf(Perl_debug_log, "DONE\n");
 293         break;
 294     case OP_PUSHRE:
 295     case OP_MATCH:
 296     case OP_SUBST:
 297         dump_pm((PMOP*)op);
 298         break;
 299     default:
 300         break;
 301     }
 302     if (op->op_flags & OPf_KIDS) {
 303         OP *kid;
 304         for (kid = cUNOP->op_first; kid; kid = kid->op_sibling)
 305             dump_op(kid);
 306     }
 307     dumplvl--;
 308     dump("}\n");
 309 }
 310
 311 void
 312 dump_gv(gv)
 313 register GV *gv;
 314 {
 315     SV *sv;
 316
 317     if (!gv) {
 318         fprintf(Perl_debug_log,"{}\n");
 319         return;
 320     }
 321     sv = sv_newmortal();
 322     dumplvl++;
 323     fprintf(Perl_debug_log,"{\n");
 324     gv_fullname(sv,gv);
 325     dump("GV_NAME = %s", SvPVX(sv));
 326     if (gv != GvEGV(gv)) {
 327         gv_efullname(sv,GvEGV(gv));
 328         dump("-> %s", SvPVX(sv));
 329     }
 330     dump("\n");
 331     dumplvl--;
 332     dump("}\n");
 333 }
 334
 335 void
 336 dump_pm(pm)
 337 register PMOP *pm;
 338 {
 339     char ch;
 340
 341     if (!pm) {
 342         dump("{}\n");
 343         return;
 344     }
 345     dump("{\n");
 346     dumplvl++;
 347     if (pm->op_pmflags & PMf_ONCE)
 348         ch = '?';
 349     else
 350         ch = '/';
 351     if (pm->op_pmregexp)
 352         dump("PMf_PRE %c%s%c\n",ch,pm->op_pmregexp->precomp,ch);
 353     if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) {
 354         dump("PMf_REPL = ");
 355         dump_op(pm->op_pmreplroot);
 356     }
 357     if (pm->op_pmshort) {
 358         dump("PMf_SHORT = %s\n",SvPEEK(pm->op_pmshort));
 359     }
 360     if (pm->op_pmflags) {
 361         *buf = '\0';
 362         if (pm->op_pmflags & PMf_USED)
 363             (void)strcat(buf,"USED,");
 364         if (pm->op_pmflags & PMf_ONCE)
 365             (void)strcat(buf,"ONCE,");
 366         if (pm->op_pmflags & PMf_SCANFIRST)
 367             (void)strcat(buf,"SCANFIRST,");
 368         if (pm->op_pmflags & PMf_ALL)
 369             (void)strcat(buf,"ALL,");
 370         if (pm->op_pmflags & PMf_SKIPWHITE)
 371             (void)strcat(buf,"SKIPWHITE,");
 372         if (pm->op_pmflags & PMf_FOLD)
 373             (void)strcat(buf,"FOLD,");
 374         if (pm->op_pmflags & PMf_CONST)
 375             (void)strcat(buf,"CONST,");
 376         if (pm->op_pmflags & PMf_KEEP)
 377             (void)strcat(buf,"KEEP,");
 378         if (pm->op_pmflags & PMf_GLOBAL)
 379             (void)strcat(buf,"GLOBAL,");
 380         if (pm->op_pmflags & PMf_RUNTIME)
 381             (void)strcat(buf,"RUNTIME,");
 382         if (pm->op_pmflags & PMf_EVAL)
 383             (void)strcat(buf,"EVAL,");
 384         if (*buf)
 385             buf[strlen(buf)-1] = '\0';
 386         dump("PMFLAGS = (%s)\n",buf);
 387     }
 388
 389     dumplvl--;
 390     dump("}\n");
 391 }
 392
 393
 394 #if !defined(I_STDARG) && !defined(I_VARARGS)
 395 /* VARARGS1 */
 396 static void dump(arg1,arg2,arg3,arg4,arg5)
 397 char *arg1;
 398 long arg2, arg3, arg4, arg5;
 399 {
 400     I32 i;
 401
 402     for (i = dumplvl*4; i; i--)
 403         (void)putc(' ',Perl_debug_log);
 404     fprintf(Perl_debug_log,arg1, arg2, arg3, arg4, arg5);
 405 }
 406
 407 #else
 408
 409 #ifdef I_STDARG
 410 static void
 411 dump(char *pat,...)
 412 #else
 413 /*VARARGS0*/
 414 static void
 415 dump(pat,va_alist)
 416     char *pat;
 417     va_dcl
 418 #endif
 419 {
 420     I32 i;
 421     va_list args;
 422 #ifndef HAS_VPRINTF
 423     int vfprintf();
 424 #endif
 425
 426 #ifdef I_STDARG
 427     va_start(args, pat);
 428 #else
 429     va_start(args);
 430 #endif
 431     for (i = dumplvl*4; i; i--)
 432         (void)putc(' ',stderr);
 433     vfprintf(Perl_debug_log,pat,args);
 434     va_end(args);
 435 }
 436 #endif
 437
 438 #endif