gdb/gdbtk.c

   1 /* TK interface routines.
   2    Copyright 1994 Free Software Foundation, Inc.
   3
   4 This file is part of GDB.
   5
   6 This program is free software; you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation; either version 2 of the License, or
   9 (at your option) any later version.
  10
  11 This program is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with this program; if not, write to the Free Software
  18 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19
  20 #include "defs.h"
  21 #include "symtab.h"
  22 #include "inferior.h"
  23 #include "command.h"
  24 #include "bfd.h"
  25 #include "symfile.h"
  26 #include "objfiles.h"
  27 #include "target.h"
  28 #include <sys/types.h>
  29 #include <sys/time.h>
  30 #include <sys/param.h>
  31 #include <varargs.h>
  32 #include <sys/stat.h>
  33 #include <fcntl.h>
  34 #include <sys/filio.h>
  35 #include <setjmp.h>
  36 #include <signal.h>
  37 #include <sys/errno.h>
  38 #include <termios.h>
  39 #include <string.h>
  40 #include <tcl.h>
  41 #include <tk.h>
  42
  43 /* Non-zero means that we're doing the gdbtk interface. */
  44 int gdbtk = 0;
  45
  46 /* Non-zero means we are reloading breakpoints, etc from the
  47    Gdbtk kernel, and we should suppress various messages */
  48 static int gdbtk_reloading = 0;
  49
  50 /* Handle for TCL interpreter */
  51 static Tcl_Interp *interp = NULL;
  52
  53 /* Handle for TK main window */
  54 static Tk_Window mainWindow = NULL;
  55
  56 static void
  57 null_routine(arg)
  58      int arg;
  59 {
  60 }
  61
  62 \f
  63 /* This routine redirects the output of fputs_unfiltered so that
  64    the user can see what's going on in his debugger window. */
  65
  66 static void
  67 gdbtk_fputs (ptr)
  68      const char *ptr;
  69 {
  70   Tcl_VarEval (interp, "gdbtk_tcl_fputs ", "{", ptr, "}", NULL);
  71 }
  72
  73 static void
  74 gdbtk_flush (stream)
  75      FILE *stream;
  76 {
  77   Tcl_VarEval (interp, "gdbtk_tcl_flush", NULL);
  78 }
  79
  80 static int
  81 gdbtk_query (args)
  82      va_list args;
  83 {
  84   char *query;
  85   char buf[200];
  86   long val;
  87
  88   query = va_arg (args, char *);
  89
  90   vsprintf(buf, query, args);
  91   Tcl_VarEval (interp, "gdbtk_tcl_query ", "{", buf, "}", NULL);
  92
  93   val = atol (interp->result);
  94   return val;
  95 }
  96 \f
  97 static char *
  98 full_filename(symtab)
  99      struct symtab *symtab;
 100 {
 101   int pathlen;
 102   char *filename;
 103
 104   if (!symtab)
 105     return NULL;
 106
 107   if (symtab->fullname)
 108     return savestring(symtab->fullname, strlen(symtab->fullname));
 109
 110   if (symtab->filename[0] == '/')
 111     return savestring(symtab->filename, strlen(symtab->filename));
 112
 113   if (symtab->dirname)
 114     pathlen = strlen(symtab->dirname);
 115   else
 116     pathlen = 0;
 117   if (symtab->filename)
 118     pathlen += strlen(symtab->filename);
 119
 120   filename = xmalloc(pathlen+1);
 121
 122   if (symtab->dirname)
 123     strcpy(filename, symtab->dirname);
 124   else
 125     *filename = '\000';
 126   if (symtab->filename)
 127     strcat(filename, symtab->filename);
 128
 129   return filename;
 130 }
 131 \f
 132 static void
 133 breakpoint_notify(b, action)
 134      struct breakpoint *b;
 135      const char *action;
 136 {
 137   struct symbol *sym;
 138   char bpnum[50], line[50];
 139   struct symtab_and_line sal;
 140   char *filename;
 141   int v;
 142
 143   if (b->type != bp_breakpoint)
 144     return;
 145
 146   sal = find_pc_line (b->address, 0);
 147
 148   filename = full_filename (sal.symtab);
 149
 150   sprintf (bpnum, "%d", b->number);
 151   sprintf (line, "%d", sal.line);
 152
 153   v = Tcl_VarEval (interp,
 154                    "gdbtk_tcl_breakpoint ",
 155                    action,
 156                    " ", bpnum,
 157                    " ", filename,
 158                    " ", line,
 159                    NULL);
 160
 161   if (v != TCL_OK)
 162     {
 163       gdbtk_fputs (interp->result);
 164       gdbtk_fputs ("\n");
 165     }
 166
 167   if (filename)
 168     free (filename);
 169 }
 170
 171 static void
 172 gdbtk_create_breakpoint(b)
 173      struct breakpoint *b;
 174 {
 175   breakpoint_notify(b, "create");
 176 }
 177
 178 static void
 179 gdbtk_delete_breakpoint(b)
 180      struct breakpoint *b;
 181 {
 182   breakpoint_notify(b, "delete");
 183 }
 184
 185 static void
 186 gdbtk_enable_breakpoint(b)
 187      struct breakpoint *b;
 188 {
 189   breakpoint_notify(b, "enable");
 190 }
 191
 192 static void
 193 gdbtk_disable_breakpoint(b)
 194      struct breakpoint *b;
 195 {
 196   breakpoint_notify(b, "disable");
 197 }
 198 \f
 199 /* This implements the TCL command `gdb_loc', which returns a list consisting
 200    of the source and line number associated with the current pc. */
 201
 202 static int
 203 gdb_loc (clientData, interp, argc, argv)
 204      ClientData clientData;
 205      Tcl_Interp *interp;
 206      int argc;
 207      char *argv[];
 208 {
 209   char *filename;
 210   char buf[100];
 211   struct symtab_and_line sal;
 212   char *funcname;
 213
 214   if (argc == 1)
 215     {
 216       struct frame_info *frame;
 217       struct symbol *func;
 218       CORE_ADDR pc;
 219
 220       frame = get_frame_info (selected_frame);
 221       pc = frame ? frame->pc : stop_pc;
 222       func = find_pc_function (pc);
 223       funcname = func ? SYMBOL_NAME (func) : "";
 224       sal = find_pc_line (pc, 0);
 225     }
 226   else if (argc == 2)
 227     {
 228       struct cleanup *old_chain;
 229       struct symtabs_and_lines sals;
 230
 231       sals = decode_line_spec (argv[1], 1);
 232
 233       if (sals.nelts != 1)
 234         {
 235           Tcl_SetResult (interp, "Ambiguous line spec", TCL_STATIC);
 236           free (sals.sals);
 237           return TCL_ERROR;
 238         }
 239
 240       sal = sals.sals[0];
 241       free (sals.sals);
 242       funcname = "*";
 243     }
 244   else
 245     {
 246       Tcl_SetResult (interp, "wrong # args", TCL_STATIC);
 247       return TCL_ERROR;
 248     }
 249
 250   filename = full_filename (sal.symtab);
 251
 252   sprintf (buf, "%d", sal.line);
 253
 254   if (sal.symtab)
 255     Tcl_AppendElement (interp, sal.symtab->filename);
 256   else
 257     Tcl_AppendElement (interp, "");
 258   Tcl_AppendElement (interp, funcname);
 259   Tcl_AppendElement (interp, filename);
 260   Tcl_AppendElement (interp, buf); /* line number */
 261
 262   if (filename)
 263     free(filename);
 264
 265   return TCL_OK;
 266 }
 267 \f
 268 static int
 269 gdb_cmd_stub (cmd)
 270      char *cmd;
 271 {
 272   execute_command (cmd, 1);
 273
 274   return 1;                     /* Indicate success */
 275 }
 276
 277 /* This implements the TCL command `gdb_cmd', which sends it's argument into
 278    the GDB command scanner.  */
 279
 280 static int
 281 gdb_cmd (clientData, interp, argc, argv)
 282      ClientData clientData;
 283      Tcl_Interp *interp;
 284      int argc;
 285      char *argv[];
 286 {
 287   int val;
 288   struct cleanup *old_chain;
 289
 290   if (argc != 2)
 291     {
 292       Tcl_SetResult (interp, "wrong # args", TCL_STATIC);
 293       return TCL_ERROR;
 294     }
 295
 296   old_chain = make_cleanup (null_routine, 0);
 297
 298   val = catch_errors (gdb_cmd_stub, argv[1], "", RETURN_MASK_ERROR);
 299
 300   bpstat_do_actions (&stop_bpstat);
 301   do_cleanups (old_chain);
 302
 303   /* We could base the return value on val, but that would require most users
 304      to use catch.  Since GDB errors are already being handled elsewhere, I
 305      see no reason to pass them up to the caller. */
 306
 307   return TCL_OK;
 308 }
 309
 310 static int
 311 gdb_listfiles (clientData, interp, argc, argv)
 312      ClientData clientData;
 313      Tcl_Interp *interp;
 314      int argc;
 315      char *argv[];
 316 {
 317   int val;
 318   struct objfile *objfile;
 319   struct partial_symtab *psymtab;
 320
 321   ALL_PSYMTABS (objfile, psymtab)
 322     Tcl_AppendElement (interp, psymtab->filename);
 323
 324   return TCL_OK;
 325 }
 326 \f
 327 static void
 328 tk_command (cmd, from_tty)
 329      char *cmd;
 330      int from_tty;
 331 {
 332   Tcl_VarEval (interp, cmd, NULL);
 333
 334   gdbtk_fputs (interp->result);
 335   gdbtk_fputs ("\n");
 336 }
 337
 338 static void
 339 cleanup_init (ignored)
 340      int ignored;
 341 {
 342   if (mainWindow != NULL)
 343     Tk_DestroyWindow (mainWindow);
 344   mainWindow = NULL;
 345
 346   if (interp != NULL)
 347     Tcl_DeleteInterp (interp);
 348   interp = NULL;
 349 }
 350
 351 static void
 352 gdbtk_init ()
 353 {
 354   struct cleanup *old_chain;
 355   char *gdbtk_filename;
 356
 357   old_chain = make_cleanup (cleanup_init, 0);
 358
 359   /* First init tcl and tk. */
 360
 361   interp = Tcl_CreateInterp ();
 362
 363   if (!interp)
 364     error ("Tcl_CreateInterp failed");
 365
 366   mainWindow = Tk_CreateMainWindow (interp, NULL, "gdb", "Gdb");
 367
 368   if (!mainWindow)
 369     return;                     /* DISPLAY probably not set */
 370
 371   if (Tcl_Init(interp) != TCL_OK)
 372     error ("Tcl_Init failed: %s", interp->result);
 373
 374   if (Tk_Init(interp) != TCL_OK)
 375     error ("Tk_Init failed: %s", interp->result);
 376
 377   Tcl_CreateCommand (interp, "gdb_cmd", gdb_cmd, NULL, NULL);
 378   Tcl_CreateCommand (interp, "gdb_loc", gdb_loc, NULL, NULL);
 379   Tcl_CreateCommand (interp, "gdb_listfiles", gdb_listfiles, NULL, NULL);
 380
 381   gdbtk_filename = getenv ("GDBTK_FILENAME");
 382   if (gdbtk_filename)
 383     {
 384       if (Tcl_EvalFile (interp, gdbtk_filename) != TCL_OK)
 385         error ("Failure reading %s: %s", gdbtk_filename, interp->result);
 386     }
 387   else
 388     {
 389       if (Tcl_EvalFile (interp, "gdbtk.tcl") != TCL_OK)
 390         {
 391           Tcl_ResetResult (interp);
 392           if (Tcl_EvalFile (interp, GDBTK_FILENAME) != TCL_OK)
 393             error ("Failure reading %s: %s", GDBTK_FILENAME, interp->result);
 394         }
 395     }
 396
 397   command_loop_hook = Tk_MainLoop;
 398   fputs_unfiltered_hook = gdbtk_fputs;
 399   print_frame_info_listing_hook = null_routine;
 400   query_hook = gdbtk_query;
 401   flush_hook = gdbtk_flush;
 402   create_breakpoint_hook = gdbtk_create_breakpoint;
 403   delete_breakpoint_hook = gdbtk_delete_breakpoint;
 404   enable_breakpoint_hook = gdbtk_enable_breakpoint;
 405   disable_breakpoint_hook = gdbtk_disable_breakpoint;
 406
 407   discard_cleanups (old_chain);
 408
 409   add_com ("tk", class_obscure, tk_command,
 410            "Send a command directly into tk.");
 411 }
 412
 413 /* Come here during initialze_all_files () */
 414
 415 void
 416 _initialize_gdbtk ()
 417 {
 418   if (no_windows)
 419     return;
 420
 421   /* Tell the rest of the world that Gdbtk is now set up. */
 422
 423   init_ui_hook = gdbtk_init;
 424 }