gdb/gdbtk.c

   1 /* Startup code for gdbtk.
   2    Copyright 1994, 1995, 1996, 1997, 1998 Free Software Foundation, Inc.
   3
   4    Written by Stu Grossman <grossman@cygnus.com> of Cygnus Support.
   5
   6 This file is part of GDB.
   7
   8 This program is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 2 of the License, or
  11 (at your option) any later version.
  12
  13 This program is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with this program; if not, write to the Free Software
  20 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.  */
  21
  22 #include "defs.h"
  23 #include "symtab.h"
  24 #include "inferior.h"
  25 #include "command.h"
  26 #include "bfd.h"
  27 #include "symfile.h"
  28 #include "objfiles.h"
  29 #include "target.h"
  30 #include "gdbcore.h"
  31 #include "tracepoint.h"
  32 #include "demangle.h"
  33
  34 #ifdef _WIN32
  35 #include <winuser.h>
  36 #endif
  37
  38 #include <sys/stat.h>
  39
  40 #include <tcl.h>
  41 #include <tk.h>
  42 #include <itcl.h>
  43 #include <tix.h>
  44 #include "guitcl.h"
  45 #include "gdbtk.h"
  46
  47 #ifdef ANSI_PROTOTYPES
  48 #include <stdarg.h>
  49 #else
  50 #include <varargs.h>
  51 #endif
  52 #include <signal.h>
  53 #include <fcntl.h>
  54 #include <unistd.h>
  55 #include <setjmp.h>
  56 #include "top.h"
  57 #include <sys/ioctl.h>
  58 #include "gdb_string.h"
  59 #include "dis-asm.h"
  60 #include <stdio.h>
  61 #include "gdbcmd.h"
  62
  63 #include "annotate.h"
  64 #include <sys/time.h>
  65
  66 #ifdef __CYGWIN32__
  67 #include <sys/cygwin.h> /* for cygwin32_attach_handle_to_fd */
  68 #endif
  69
  70 /* For Cygwin, we use a timer to periodically check for Windows
  71    messages.  FIXME: It would be better to not poll, but to instead
  72    rewrite the target_wait routines to serve as input sources.
  73    Unfortunately, that will be a lot of work.  */
  74 static sigset_t nullsigmask;
  75 static struct sigaction act1, act2;
  76 static struct itimerval it_on, it_off;
  77
  78  /*
  79   * These two variables control the interaction with an external editor.
  80   * If enable_external_editor is set at startup, BEFORE Gdbtk_Init is run
  81   * then the Tcl variable of the same name will be set, and a command will
  82   * called external_editor_command will be invoked to call out to the
  83   * external editor.  We give a dummy version here to warn if it is not set.
  84   */
  85 int enable_external_editor = 0;
  86 char * external_editor_command = "tk_dialog .warn-external \\\n\
  87 \"No command is specified.\nUse --tclcommand <tcl/file> or --external-editor <cmd> to specify a new command\" 0 Ok";
  88
  89 extern int Tktable_Init PARAMS ((Tcl_Interp *interp));
  90
  91 static void gdbtk_init PARAMS ((char *));
  92 void gdbtk_interactive PARAMS ((void));
  93 static void cleanup_init PARAMS ((int));
  94 static void tk_command PARAMS ((char *, int));
  95
  96 void gdbtk_add_hooks PARAMS ((void));
  97 int gdbtk_test PARAMS ((char *));
  98
  99 /*
 100  * gdbtk_fputs is defined in the gdbtk_hooks.c, but we need it here
 101  * because we delay adding this hook till all the setup is done.  That
 102  * way errors will go to stdout.
 103  */
 104
 105 extern void   gdbtk_fputs PARAMS ((const char *, GDB_FILE *));
 106
 107 /* Handle for TCL interpreter */
 108 Tcl_Interp *gdbtk_interp = NULL;
 109
 110 static int gdbtk_timer_going = 0;
 111
 112 /* linked variable used to tell tcl what the current thread is */
 113 int gdb_context = 0;
 114
 115 /* This variable is true when the inferior is running.  See note in
 116  * gdbtk.h for details.
 117  */
 118 int running_now;
 119
 120 /* This variable holds the name of a Tcl file which should be sourced by the
 121    interpreter when it goes idle at startup. Used with the testsuite. */
 122 static char *gdbtk_source_filename = NULL;
 123 \f
 124 #ifndef _WIN32
 125
 126 /* Supply malloc calls for tcl/tk.  We do not want to do this on
 127    Windows, because Tcl_Alloc is probably in a DLL which will not call
 128    the mmalloc routines.
 129    We also don't need to do it for Tcl/Tk8.1, since we locally changed the
 130    allocator to use malloc & free. */
 131
 132 #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
 133 char *
 134 TclpAlloc (size)
 135      unsigned int size;
 136 {
 137   return xmalloc (size);
 138 }
 139
 140 char *
 141 TclpRealloc (ptr, size)
 142      char *ptr;
 143      unsigned int size;
 144 {
 145   return xrealloc (ptr, size);
 146 }
 147
 148 void
 149 TclpFree(ptr)
 150      char *ptr;
 151 {
 152   free (ptr);
 153 }
 154 #endif /* TCL_VERSION == 8.0 */
 155
 156 #endif /* ! _WIN32 */
 157
 158 #ifdef _WIN32
 159
 160 /* On Windows, if we hold a file open, other programs can't write to
 161  * it.  In particular, we don't want to hold the executable open,
 162  * because it will mean that people have to get out of the debugging
 163  * session in order to remake their program.  So we close it, although
 164  * this will cost us if and when we need to reopen it.
 165  */
 166
 167 void
 168 close_bfds ()
 169 {
 170   struct objfile *o;
 171
 172   ALL_OBJFILES (o)
 173     {
 174       if (o->obfd != NULL)
 175         bfd_cache_close (o->obfd);
 176     }
 177
 178   if (exec_bfd != NULL)
 179     bfd_cache_close (exec_bfd);
 180 }
 181
 182 #endif /* _WIN32 */
 183
 184 \f
 185 /* TclDebug (const char *fmt, ...) works just like printf() but
 186  * sends the output to the GDB TK debug window.
 187  * Not for normal use; just a convenient tool for debugging
 188  */
 189
 190 void
 191 TclDebug (char level, const char *fmt, ...)
 192 {
 193   va_list args;
 194   char buf[512], *v[3], *merge, *priority;
 195
 196   switch (level)
 197     {
 198     case 'W':
 199       priority = "W";
 200       break;
 201     case 'E':
 202       priority = "E";
 203       break;
 204     case 'X':
 205       priority = "X";
 206       break;
 207     default:
 208       priority = "I";
 209     }
 210
 211   va_start (args, fmt);
 212
 213   v[0] = "dbug";
 214   v[1] = priority;
 215   v[2] = buf;
 216
 217   vsprintf (buf, fmt, args);
 218   va_end (args);
 219
 220   merge = Tcl_Merge (3, v);
 221   if (Tcl_Eval (gdbtk_interp, merge) != TCL_OK)
 222     Tcl_BackgroundError(gdbtk_interp);
 223   Tcl_Free (merge);
 224 }
 225
 226 \f
 227 /*
 228  * The rest of this file contains the start-up, and event handling code for gdbtk.
 229  */
 230
 231 /*
 232  * This cleanup function is added to the cleanup list that surrounds the Tk
 233  * main in gdbtk_init.  It deletes the Tcl interpreter.
 234  */
 235
 236 static void
 237 cleanup_init (ignored)
 238      int ignored;
 239 {
 240   if (gdbtk_interp != NULL)
 241     Tcl_DeleteInterp (gdbtk_interp);
 242   gdbtk_interp = NULL;
 243 }
 244
 245 /* Come here during long calculations to check for GUI events.  Usually invoked
 246    via the QUIT macro.  */
 247
 248 void
 249 gdbtk_interactive ()
 250 {
 251   /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */
 252 }
 253
 254
 255 void
 256 gdbtk_start_timer ()
 257 {
 258   static int first = 1;
 259   /*TclDebug ("Starting timer....");*/
 260   if (first)
 261     {
 262       /* first time called, set up all the structs */
 263       first = 0;
 264       sigemptyset (&nullsigmask);
 265
 266       act1.sa_handler = x_event;
 267       act1.sa_mask = nullsigmask;
 268       act1.sa_flags = 0;
 269
 270       act2.sa_handler = SIG_IGN;
 271       act2.sa_mask = nullsigmask;
 272       act2.sa_flags = 0;
 273
 274       it_on.it_interval.tv_sec = 0;
 275       it_on.it_interval.tv_usec = 250000; /* .25 sec */
 276       it_on.it_value.tv_sec = 0;
 277       it_on.it_value.tv_usec = 250000;
 278
 279       it_off.it_interval.tv_sec = 0;
 280       it_off.it_interval.tv_usec = 0;
 281       it_off.it_value.tv_sec = 0;
 282       it_off.it_value.tv_usec = 0;
 283     }
 284
 285   if (!gdbtk_timer_going)
 286     {
 287       sigaction (SIGALRM, &act1, NULL);
 288       setitimer (ITIMER_REAL, &it_on, NULL);
 289       gdbtk_timer_going = 1;
 290     }
 291 }
 292
 293 void
 294 gdbtk_stop_timer ()
 295 {
 296   if (gdbtk_timer_going)
 297     {
 298       gdbtk_timer_going = 0;
 299       /*TclDebug ("Stopping timer.");*/
 300       setitimer (ITIMER_REAL, &it_off, NULL);
 301       sigaction (SIGALRM, &act2, NULL);
 302     }
 303 }
 304
 305 /* gdbtk_init installs this function as a final cleanup.  */
 306
 307 static void
 308 gdbtk_cleanup (dummy)
 309      PTR dummy;
 310 {
 311   Tcl_Eval (gdbtk_interp, "gdbtk_cleanup");
 312   Tcl_Finalize ();
 313 }
 314
 315 /* Initialize gdbtk.  This involves creating a Tcl interpreter,
 316  * defining all the Tcl commands that the GUI will use, pointing
 317  * all the gdb "hooks" to the correct functions,
 318  * and setting the Tcl auto loading environment so that we can find all
 319  * the Tcl based library files.
 320  */
 321
 322 static void
 323 gdbtk_init ( argv0 )
 324      char *argv0;
 325 {
 326   struct cleanup *old_chain;
 327   int found_main;
 328   char s[5];
 329   Tcl_Obj *auto_path_elem, *auto_path_name;
 330
 331   /* If there is no DISPLAY environment variable, Tk_Init below will fail,
 332      causing gdb to abort.  If instead we simply return here, gdb will
 333      gracefully degrade to using the command line interface. */
 334
 335 #ifndef _WIN32
 336   if (getenv ("DISPLAY") == NULL)
 337     return;
 338 #endif
 339
 340   old_chain = make_cleanup ((make_cleanup_func) cleanup_init, 0);
 341
 342   /* First init tcl and tk. */
 343   Tcl_FindExecutable (argv0);
 344   gdbtk_interp = Tcl_CreateInterp ();
 345
 346 #ifdef TCL_MEM_DEBUG
 347   Tcl_InitMemory (gdbtk_interp);
 348 #endif
 349
 350   if (!gdbtk_interp)
 351     error ("Tcl_CreateInterp failed");
 352
 353   if (Tcl_Init(gdbtk_interp) != TCL_OK)
 354     error ("Tcl_Init failed: %s", gdbtk_interp->result);
 355
 356   /* Set up some globals used by gdb to pass info to gdbtk
 357      for start up options and the like */
 358   sprintf (s, "%d", inhibit_gdbinit);
 359   Tcl_SetVar2 (gdbtk_interp, "GDBStartup", "inhibit_prefs", s, TCL_GLOBAL_ONLY);
 360
 361   make_final_cleanup (gdbtk_cleanup,  NULL);
 362
 363   /* Initialize the Paths variable.  */
 364   if (ide_initialize_paths (gdbtk_interp, "") != TCL_OK)
 365     error ("ide_initialize_paths failed: %s", gdbtk_interp->result);
 366
 367   if (Tk_Init(gdbtk_interp) != TCL_OK)
 368     error ("Tk_Init failed: %s", gdbtk_interp->result);
 369
 370   if (Itcl_Init(gdbtk_interp) == TCL_ERROR)
 371     error ("Itcl_Init failed: %s", gdbtk_interp->result);
 372   Tcl_StaticPackage(gdbtk_interp, "Itcl", Itcl_Init,
 373                     (Tcl_PackageInitProc *) NULL);
 374
 375   if (Itk_Init(gdbtk_interp) == TCL_ERROR)
 376     error ("Itk_Init failed: %s", gdbtk_interp->result);
 377   Tcl_StaticPackage(gdbtk_interp, "Itk", Itk_Init,
 378                     (Tcl_PackageInitProc *) NULL);
 379
 380   if (Tix_Init(gdbtk_interp) != TCL_OK)
 381     error ("Tix_Init failed: %s", gdbtk_interp->result);
 382   Tcl_StaticPackage(gdbtk_interp, "Tix", Tix_Init,
 383                     (Tcl_PackageInitProc *) NULL);
 384
 385   if (Tktable_Init(gdbtk_interp) != TCL_OK)
 386     error ("Tktable_Init failed: %s", gdbtk_interp->result);
 387
 388   Tcl_StaticPackage(gdbtk_interp, "Tktable", Tktable_Init,
 389                     (Tcl_PackageInitProc *) NULL);
 390   /*
 391    * These are the commands to do some Windows Specific stuff...
 392    */
 393
 394 #ifdef __CYGWIN32__
 395   if (ide_create_messagebox_command (gdbtk_interp) != TCL_OK)
 396     error ("messagebox command initialization failed");
 397   /* On Windows, create a sizebox widget command */
 398   if (ide_create_sizebox_command (gdbtk_interp) != TCL_OK)
 399     error ("sizebox creation failed");
 400   if (ide_create_winprint_command (gdbtk_interp) != TCL_OK)
 401     error ("windows print code initialization failed");
 402   if (ide_create_win_grab_command (gdbtk_interp) != TCL_OK)
 403     error ("grab support command initialization failed");
 404   /* Path conversion functions.  */
 405   if (ide_create_cygwin_path_command (gdbtk_interp) != TCL_OK)
 406     error ("cygwin path command initialization failed");
 407 #else
 408   /* for now, this testing function is Unix only */
 409   if (cyg_create_warp_pointer_command (gdbtk_interp) != TCL_OK)
 410     error ("warp_pointer command initialization failed");
 411 #endif
 412
 413   /*
 414    * This adds all the Gdbtk commands.
 415    */
 416
 417   if (Gdbtk_Init(gdbtk_interp) != TCL_OK)
 418     {
 419        error("Gdbtk_Init failed: %s", gdbtk_interp->result);
 420     }
 421
 422   Tcl_StaticPackage(gdbtk_interp, "Gdbtk", Gdbtk_Init, NULL);
 423
 424   /* This adds all the hooks that call up from the bowels of gdb
 425    *  back into Tcl-land...
 426    */
 427
 428   gdbtk_add_hooks();
 429
 430   /* Add a back door to Tk from the gdb console... */
 431
 432   add_com ("tk", class_obscure, tk_command,
 433            "Send a command directly into tk.");
 434
 435   /*
 436    * Set the variables for external editor:
 437    */
 438
 439   Tcl_SetVar (gdbtk_interp, "enable_external_editor", enable_external_editor ? "1" : "0", 0);
 440   Tcl_SetVar (gdbtk_interp, "external_editor_command", external_editor_command, 0);
 441
 442   /* find the gdb tcl library and source main.tcl */
 443
 444   {
 445 #ifdef NO_TCLPRO_DEBUGGER
 446     static char script[] ="\
 447 proc gdbtk_find_main {} {\n\
 448     global Paths GDBTK_LIBRARY\n\
 449     rename gdbtk_find_main {}\n\
 450     tcl_findLibrary gdb 1.0 {} main.tcl GDBTK_LIBRARY GDBTK_LIBRARY gdbtcl2 gdbtcl {}\n\
 451     set Paths(appdir) $GDBTK_LIBRARY\n\
 452 }\n\
 453 gdbtk_find_main";
 454 #else
 455     static char script[] ="\
 456 proc gdbtk_find_main {} {\n\
 457     global Paths GDBTK_LIBRARY env\n\
 458     rename gdbtk_find_main {}\n\
 459     if {[info exists env(DEBUG_STUB)]} {\n\
 460         source $env(DEBUG_STUB)\n\
 461         debugger_init\n\
 462         set debug_startup 1\n\
 463     } else {\n\
 464         set debug_startup 0\n\
 465     }\n\
 466     tcl_findLibrary gdb 1.0 {} main.tcl GDBTK_LIBRARY GDBTK_LIBRARY gdbtcl2 gdbtcl {} $debug_startup\n\
 467     set Paths(appdir) $GDBTK_LIBRARY\n\
 468 }\n\
 469 gdbtk_find_main";
 470 #endif /* NO_TCLPRO_DEBUGGER */
 471
 472     /* fputs_unfiltered_hook = NULL; */ /* Force errors to stdout/stderr */
 473
 474     /*
 475      * Set the variables for external editor, do this before eval'ing main.tcl
 476      * since the value is used there...
 477      */
 478
 479     Tcl_SetVar (gdbtk_interp, "enable_external_editor",
 480                 enable_external_editor ? "1" : "0", 0);
 481     Tcl_SetVar (gdbtk_interp, "external_editor_command",
 482                 external_editor_command, 0);
 483
 484   fputs_unfiltered_hook = gdbtk_fputs;
 485
 486   if (Tcl_GlobalEval (gdbtk_interp, (char *) script) != TCL_OK)
 487       {
 488         char *msg;
 489
 490         /* Force errorInfo to be set up propertly.  */
 491         Tcl_AddErrorInfo (gdbtk_interp, "");
 492
 493         msg = Tcl_GetVar (gdbtk_interp, "errorInfo", TCL_GLOBAL_ONLY);
 494
 495         fputs_unfiltered_hook = NULL; /* Force errors to stdout/stderr */
 496
 497 #ifdef _WIN32
 498         MessageBox (NULL, msg, NULL, MB_OK | MB_ICONERROR | MB_TASKMODAL);
 499 #else
 500         fputs_unfiltered (msg, gdb_stderr);
 501 #endif
 502
 503         error ("");
 504
 505       }
 506   }
 507
 508   /* Now source in the filename provided by the --tclcommand option.
 509      This is mostly used for the gdbtk testsuite... */
 510
 511   if (gdbtk_source_filename != NULL)
 512     {
 513       char *s = "after idle source ";
 514       char *script = concat (s, gdbtk_source_filename, (char *) NULL);
 515       Tcl_Eval (gdbtk_interp, script);
 516       free (gdbtk_source_filename);
 517       free (script);
 518     }
 519
 520
 521   discard_cleanups (old_chain);
 522 }
 523
 524 /* gdbtk_test is used in main.c to validate the -tclcommand option to
 525    gdb, which sources in a file of tcl code after idle during the
 526    startup procedure. */
 527
 528 int
 529 gdbtk_test (filename)
 530      char *filename;
 531 {
 532   if (access (filename, R_OK) != 0)
 533     return 0;
 534   else
 535     gdbtk_source_filename = xstrdup (filename);
 536   return 1;
 537 }
 538
 539 /* Come here during initialize_all_files () */
 540
 541 void
 542 _initialize_gdbtk ()
 543 {
 544   if (use_windows)
 545     {
 546       /* Tell the rest of the world that Gdbtk is now set up. */
 547
 548       init_ui_hook = gdbtk_init;
 549 #ifdef __CYGWIN32__
 550       (void) FreeConsole ();
 551 #endif
 552     }
 553 #ifdef __CYGWIN32__
 554   else
 555     {
 556       DWORD ft = GetFileType (GetStdHandle (STD_INPUT_HANDLE));
 557
 558       switch (ft)
 559         {
 560           case FILE_TYPE_DISK:
 561           case FILE_TYPE_CHAR:
 562           case FILE_TYPE_PIPE:
 563             break;
 564           default:
 565             AllocConsole();
 566             cygwin32_attach_handle_to_fd ("/dev/conin", 0,
 567                                           GetStdHandle (STD_INPUT_HANDLE),
 568                                           1, GENERIC_READ);
 569             cygwin32_attach_handle_to_fd ("/dev/conout", 1,
 570                                           GetStdHandle (STD_OUTPUT_HANDLE),
 571                                           0, GENERIC_WRITE);
 572             cygwin32_attach_handle_to_fd ("/dev/conout", 2,
 573                                           GetStdHandle (STD_ERROR_HANDLE),
 574                                           0, GENERIC_WRITE);
 575             break;
 576         }
 577     }
 578 #endif
 579 }
 580
 581 static void
 582 tk_command (cmd, from_tty)
 583      char *cmd;
 584      int from_tty;
 585 {
 586   int retval;
 587   char *result;
 588   struct cleanup *old_chain;
 589
 590   /* Catch case of no argument, since this will make the tcl interpreter dump core. */
 591   if (cmd == NULL)
 592     error_no_arg ("tcl command to interpret");
 593
 594   retval = Tcl_Eval (gdbtk_interp, cmd);
 595
 596   result = strdup (gdbtk_interp->result);
 597
 598   old_chain = make_cleanup (free, result);
 599
 600   if (retval != TCL_OK)
 601     error (result);
 602
 603   printf_unfiltered ("%s\n", result);
 604
 605   do_cleanups (old_chain);
 606 }
 607 \f
 608 /* Local variables: */
 609 /* change-log-default-name: "ChangeLog-gdbtk" */
 610 /* End: */
 611