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 IDE
  48 /* start-sanitize-ide */
  49 #include "event.h"
  50 #include "idetcl.h"
  51 #include "ilutk.h"
  52 /* end-sanitize-ide */
  53 #endif
  54
  55 #ifdef ANSI_PROTOTYPES
  56 #include <stdarg.h>
  57 #else
  58 #include <varargs.h>
  59 #endif
  60 #include <signal.h>
  61 #include <fcntl.h>
  62 #include <unistd.h>
  63 #include <setjmp.h>
  64 #include "top.h"
  65 #include <sys/ioctl.h>
  66 #include "gdb_string.h"
  67 #include "dis-asm.h"
  68 #include <stdio.h>
  69 #include "gdbcmd.h"
  70
  71 #include "annotate.h"
  72 #include <sys/time.h>
  73
  74 /* For Cygwin32, we use a timer to periodically check for Windows
  75    messages.  FIXME: It would be better to not poll, but to instead
  76    rewrite the target_wait routines to serve as input sources.
  77    Unfortunately, that will be a lot of work.  */
  78 static sigset_t nullsigmask;
  79 static struct sigaction act1, act2;
  80 static struct itimerval it_on, it_off;
  81
  82 extern int Tktable_Init PARAMS ((Tcl_Interp *interp));
  83
  84 static void null_routine PARAMS ((int));
  85 static void gdbtk_init PARAMS ((char *));
  86 void gdbtk_interactive PARAMS ((void));
  87 static void cleanup_init PARAMS ((int));
  88 static void tk_command PARAMS ((char *, int));
  89
  90 int gdbtk_test PARAMS ((char *));
  91
  92 /*
  93  * gdbtk_fputs is defined in the gdbtk_hooks.c, but we need it here
  94  * because we delay adding this hook till all the setup is done.  That
  95  * way errors will go to stdout.
  96  */
  97
  98 extern void   gdbtk_fputs PARAMS ((const char *, FILE *));
  99
 100 /* Handle for TCL interpreter */
 101 Tcl_Interp *gdbtk_interp = NULL;
 102
 103 static int gdbtk_timer_going = 0;
 104
 105 /* This variable is true when the inferior is running.  See note in
 106  * gdbtk.h for details.
 107  */
 108
 109 int running_now;
 110
 111 /* This variable determines where memory used for disassembly is read from.
 112  * See note in gdbtk.h for details.
 113  */
 114
 115 int disassemble_from_exec = -1;
 116
 117 /* This variable holds the name of a Tcl file which should be sourced by the
 118    interpreter when it goes idle at startup. Used with the testsuite. */
 119
 120 static char *gdbtk_source_filename = NULL;
 121 \f
 122 #ifndef _WIN32
 123
 124 /* Supply malloc calls for tcl/tk.  We do not want to do this on
 125    Windows, because Tcl_Alloc is probably in a DLL which will not call
 126    the mmalloc routines.  */
 127
 128 char *
 129 Tcl_Alloc (size)
 130      unsigned int size;
 131 {
 132   return xmalloc (size);
 133 }
 134
 135 char *
 136 Tcl_Realloc (ptr, size)
 137      char *ptr;
 138      unsigned int size;
 139 {
 140   return xrealloc (ptr, size);
 141 }
 142
 143 void
 144 Tcl_Free(ptr)
 145      char *ptr;
 146 {
 147   free (ptr);
 148 }
 149
 150 #endif /* ! _WIN32 */
 151
 152 static void
 153 null_routine(arg)
 154      int arg;
 155 {
 156 }
 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 #ifdef ANSI_PROTOTYPES
 192 TclDebug (const char *fmt, ...)
 193 #else
 194 TclDebug (va_alist)
 195      va_dcl
 196 #endif
 197 {
 198   va_list args;
 199   char buf[512], *v[2], *merge;
 200
 201 #ifdef ANSI_PROTOTYPES
 202   va_start (args, fmt);
 203 #else
 204   char *fmt;
 205   va_start (args);
 206   fmt = va_arg (args, char *);
 207 #endif
 208
 209   v[0] = "debug";
 210   v[1] = buf;
 211
 212   vsprintf (buf, fmt, args);
 213   va_end (args);
 214
 215   merge = Tcl_Merge (2, v);
 216   Tcl_Eval (gdbtk_interp, merge);
 217   Tcl_Free (merge);
 218 }
 219
 220 \f
 221 /*
 222  * The rest of this file contains the start-up, and event handling code for gdbtk.
 223  */
 224
 225 /*
 226  * This cleanup function is added to the cleanup list that surrounds the Tk
 227  * main in gdbtk_init.  It deletes the Tcl interpreter.
 228  */
 229
 230 static void
 231 cleanup_init (ignored)
 232      int ignored;
 233 {
 234   if (gdbtk_interp != NULL)
 235     Tcl_DeleteInterp (gdbtk_interp);
 236   gdbtk_interp = NULL;
 237 }
 238
 239 /* Come here during long calculations to check for GUI events.  Usually invoked
 240    via the QUIT macro.  */
 241
 242 void
 243 gdbtk_interactive ()
 244 {
 245   /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */
 246 }
 247
 248
 249 void
 250 gdbtk_start_timer ()
 251 {
 252   static int first = 1;
 253   /*TclDebug ("Starting timer....");*/
 254   if (first)
 255     {
 256       /* first time called, set up all the structs */
 257       first = 0;
 258       sigemptyset (&nullsigmask);
 259
 260       act1.sa_handler = x_event;
 261       act1.sa_mask = nullsigmask;
 262       act1.sa_flags = 0;
 263
 264       act2.sa_handler = SIG_IGN;
 265       act2.sa_mask = nullsigmask;
 266       act2.sa_flags = 0;
 267
 268       it_on.it_interval.tv_sec = 0;
 269       it_on.it_interval.tv_usec = 250000; /* .25 sec */
 270       it_on.it_value.tv_sec = 0;
 271       it_on.it_value.tv_usec = 250000;
 272
 273       it_off.it_interval.tv_sec = 0;
 274       it_off.it_interval.tv_usec = 0;
 275       it_off.it_value.tv_sec = 0;
 276       it_off.it_value.tv_usec = 0;
 277     }
 278
 279   if (!gdbtk_timer_going)
 280     {
 281       sigaction (SIGALRM, &act1, NULL);
 282       setitimer (ITIMER_REAL, &it_on, NULL);
 283       gdbtk_timer_going = 1;
 284     }
 285 }
 286
 287 void
 288 gdbtk_stop_timer ()
 289 {
 290   if (gdbtk_timer_going)
 291     {
 292       gdbtk_timer_going = 0;
 293       /*TclDebug ("Stopping timer.");*/
 294       setitimer (ITIMER_REAL, &it_off, NULL);
 295       sigaction (SIGALRM, &act2, NULL);
 296     }
 297 }
 298
 299 /* This is called from execute_command, and provides a wrapper around
 300    various command routines in a place where both protocol messages and
 301    user input both flow through.  Mostly this is used for indicating whether
 302    the target process is running or not.
 303 */
 304
 305 static void
 306 gdbtk_call_command (cmdblk, arg, from_tty)
 307      struct cmd_list_element *cmdblk;
 308      char *arg;
 309      int from_tty;
 310 {
 311   running_now = 0;
 312   if (cmdblk->class == class_run || cmdblk->class == class_trace)
 313     {
 314
 315 /* HACK! HACK! This is to get the gui to update the tstart/tstop
 316    button only incase of tstart/tstop commands issued from the console
 317    We don't want to update the src window, so we need to have specific
 318    procedures to do tstart and tstop
 319    Unfortunately this will not display errors from tstart or tstop in the
 320    console window itself, but as dialogs.*/
 321
 322       if (!strcmp(cmdblk->name, "tstart") && !No_Update)
 323         {
 324               Tcl_Eval (gdbtk_interp, "gdbtk_tcl_tstart");
 325               (*cmdblk->function.cfunc)(arg, from_tty);
 326         }
 327       else if (!strcmp(cmdblk->name, "tstop") && !No_Update)
 328              {
 329               Tcl_Eval (gdbtk_interp, "gdbtk_tcl_tstop");
 330               (*cmdblk->function.cfunc)(arg, from_tty);
 331              }
 332 /* end of hack */
 333            else
 334              {
 335                  running_now = 1;
 336                  if (!No_Update)
 337                    Tcl_Eval (gdbtk_interp, "gdbtk_tcl_busy");
 338                  (*cmdblk->function.cfunc)(arg, from_tty);
 339                  running_now = 0;
 340                  if (!No_Update)
 341                    Tcl_Eval (gdbtk_interp, "gdbtk_tcl_idle");
 342              }
 343     }
 344   else
 345     (*cmdblk->function.cfunc)(arg, from_tty);
 346 }
 347
 348 /* gdbtk_init installs this function as a final cleanup.  */
 349
 350 static void
 351 gdbtk_cleanup (dummy)
 352      PTR dummy;
 353 {
 354   Tcl_Eval (gdbtk_interp, "gdbtk_cleanup");
 355 #ifdef IDE
 356   struct ide_event_handle *h = (struct ide_event_handle *) dummy;
 357   ide_interface_deregister_all (h);
 358 #endif
 359   Tcl_Finalize ();
 360 }
 361
 362 /* Initialize gdbtk.  This involves creating a Tcl interpreter,
 363  * defining all the Tcl commands that the GUI will use, pointing
 364  * all the gdb "hooks" to the correct functions,
 365  * and setting the Tcl auto loading environment so that we can find all
 366  * the Tcl based library files.
 367  */
 368
 369 static void
 370 gdbtk_init ( argv0 )
 371      char *argv0;
 372 {
 373   struct cleanup *old_chain;
 374   char *lib, *gdbtk_lib, *gdbtk_lib_tmp, *gdbtk_file;
 375   int i, found_main;
 376   Tcl_Obj *auto_path_elem, *auto_path_name;
 377 #ifndef WINNT
 378   struct sigaction action;
 379   static sigset_t nullsigmask = {0};
 380 #endif
 381 #ifdef IDE
 382   /* start-sanitize-ide */
 383   struct ide_event_handle *h;
 384   const char *errmsg;
 385   char *libexecdir;
 386   /* end-sanitize-ide */
 387 #endif
 388
 389   /* If there is no DISPLAY environment variable, Tk_Init below will fail,
 390      causing gdb to abort.  If instead we simply return here, gdb will
 391      gracefully degrade to using the command line interface. */
 392
 393 #ifndef WINNT
 394   if (getenv ("DISPLAY") == NULL)
 395     return;
 396 #endif
 397
 398   old_chain = make_cleanup (cleanup_init, 0);
 399
 400   /* First init tcl and tk. */
 401   Tcl_FindExecutable (argv0);
 402   gdbtk_interp = Tcl_CreateInterp ();
 403
 404 #ifdef TCL_MEM_DEBUG
 405   Tcl_InitMemory (gdbtk_interp);
 406 #endif
 407
 408   if (!gdbtk_interp)
 409     error ("Tcl_CreateInterp failed");
 410
 411   if (Tcl_Init(gdbtk_interp) != TCL_OK)
 412     error ("Tcl_Init failed: %s", gdbtk_interp->result);
 413
 414 #ifndef IDE
 415   /* For the IDE we register the cleanup later, after we've
 416      initialized events.  */
 417   make_final_cleanup (gdbtk_cleanup,  NULL);
 418 #endif
 419
 420   /* Initialize the Paths variable.  */
 421   if (ide_initialize_paths (gdbtk_interp, "gdbtcl") != TCL_OK)
 422     error ("ide_initialize_paths failed: %s", gdbtk_interp->result);
 423
 424 #ifdef IDE
 425   /* start-sanitize-ide */
 426   /* Find the directory where we expect to find idemanager.  We ignore
 427      errors since it doesn't really matter if this fails.  */
 428   libexecdir = Tcl_GetVar2 (gdbtk_interp, "Paths", "libexecdir", TCL_GLOBAL_ONLY);
 429
 430   IluTk_Init ();
 431
 432   h = ide_event_init_from_environment (&errmsg, libexecdir);
 433   make_final_cleanup (gdbtk_cleanup, h);
 434   if (h == NULL)
 435     {
 436       Tcl_AppendResult (gdbtk_interp, "can't initialize event system: ", errmsg,
 437                         (char *) NULL);
 438       fprintf(stderr, "WARNING: ide_event_init_client failed: %s\n", gdbtk_interp->result);
 439
 440       Tcl_SetVar (gdbtk_interp, "IDE_ENABLED", "0", 0);
 441     }
 442   else
 443     {
 444       if (ide_create_tclevent_command (gdbtk_interp, h) != TCL_OK)
 445         error ("ide_create_tclevent_command failed: %s", gdbtk_interp->result);
 446
 447       if (ide_create_edit_command (gdbtk_interp, h) != TCL_OK)
 448         error ("ide_create_edit_command failed: %s", gdbtk_interp->result);
 449
 450       if (ide_create_property_command (gdbtk_interp, h) != TCL_OK)
 451         error ("ide_create_property_command failed: %s", gdbtk_interp->result);
 452
 453       if (ide_create_build_command (gdbtk_interp, h) != TCL_OK)
 454         error ("ide_create_build_command failed: %s", gdbtk_interp->result);
 455
 456       if (ide_create_window_register_command (gdbtk_interp, h, "gdb-restore")
 457           != TCL_OK)
 458         error ("ide_create_window_register_command failed: %s",
 459                gdbtk_interp->result);
 460
 461       if (ide_create_window_command (gdbtk_interp, h) != TCL_OK)
 462         error ("ide_create_window_command failed: %s", gdbtk_interp->result);
 463
 464       if (ide_create_exit_command (gdbtk_interp, h) != TCL_OK)
 465         error ("ide_create_exit_command failed: %s", gdbtk_interp->result);
 466
 467       if (ide_create_help_command (gdbtk_interp) != TCL_OK)
 468         error ("ide_create_help_command failed: %s", gdbtk_interp->result);
 469
 470       /*
 471         if (ide_initialize (gdbtk_interp, "gdb") != TCL_OK)
 472         error ("ide_initialize failed: %s", gdbtk_interp->result);
 473       */
 474
 475       Tcl_SetVar (gdbtk_interp, "IDE_ENABLED", "1", 0);
 476     }
 477   /* end-sanitize-ide */
 478 #else
 479   Tcl_SetVar (gdbtk_interp, "IDE_ENABLED", "0", 0);
 480 #endif /* IDE */
 481
 482   /* We don't want to open the X connection until we've done all the
 483      IDE initialization.  Otherwise, goofy looking unfinished windows
 484      pop up when ILU drops into the TCL event loop.  */
 485
 486   if (Tk_Init(gdbtk_interp) != TCL_OK)
 487     error ("Tk_Init failed: %s", gdbtk_interp->result);
 488
 489   if (Itcl_Init(gdbtk_interp) == TCL_ERROR)
 490     error ("Itcl_Init failed: %s", gdbtk_interp->result);
 491   Tcl_StaticPackage(gdbtk_interp, "Tktable", Tktable_Init,
 492                     (Tcl_PackageInitProc *) NULL);
 493
 494   if (Tix_Init(gdbtk_interp) != TCL_OK)
 495     error ("Tix_Init failed: %s", gdbtk_interp->result);
 496   Tcl_StaticPackage(gdbtk_interp, "Tktable", Tktable_Init,
 497                     (Tcl_PackageInitProc *) NULL);
 498
 499   if (Tktable_Init(gdbtk_interp) != TCL_OK)
 500     error ("Tktable_Init failed: %s", gdbtk_interp->result);
 501
 502   Tcl_StaticPackage(gdbtk_interp, "Tktable", Tktable_Init,
 503                     (Tcl_PackageInitProc *) NULL);
 504   /*
 505    * These are the commands to do some Windows Specific stuff...
 506    */
 507
 508 #ifdef __CYGWIN32__
 509   if (ide_create_messagebox_command (gdbtk_interp) != TCL_OK)
 510     error ("messagebox command initialization failed");
 511   /* On Windows, create a sizebox widget command */
 512   if (ide_create_sizebox_command (gdbtk_interp) != TCL_OK)
 513     error ("sizebox creation failed");
 514   if (ide_create_winprint_command (gdbtk_interp) != TCL_OK)
 515     error ("windows print code initialization failed");
 516   /* start-sanitize-ide */
 517   /* An interface to ShellExecute.  */
 518   if (ide_create_shell_execute_command (gdbtk_interp) != TCL_OK)
 519     error ("shell execute command initialization failed");
 520   /* end-sanitize-ide */
 521   if (ide_create_win_grab_command (gdbtk_interp) != TCL_OK)
 522     error ("grab support command initialization failed");
 523   /* Path conversion functions.  */
 524   if (ide_create_cygwin_path_command (gdbtk_interp) != TCL_OK)
 525     error ("cygwin path command initialization failed");
 526 #endif
 527
 528   /*
 529    * This adds all the Gdbtk commands.
 530    */
 531
 532   if (Gdbtk_Init(gdbtk_interp) != TCL_OK)
 533     {
 534        error("Gdbtk_Init failed: %s", gdbtk_interp->result);
 535     }
 536
 537   Tcl_StaticPackage(gdbtk_interp, "Gdbtk", Gdbtk_Init, NULL);
 538
 539   /* This adds all the hooks that call up from the bowels of gdb
 540    *  back into Tcl-land...
 541    */
 542
 543   gdbtk_add_hooks();
 544
 545   /* Add a back door to Tk from the gdb console... */
 546
 547   add_com ("tk", class_obscure, tk_command,
 548            "Send a command directly into tk.");
 549
 550   Tcl_LinkVar (gdbtk_interp, "disassemble-from-exec", (char *) &disassemble_from_exec,
 551                TCL_LINK_INT);
 552
 553   /* find the gdb tcl library and source main.tcl */
 554
 555   gdbtk_lib = getenv ("GDBTK_LIBRARY");
 556   if (!gdbtk_lib)
 557     if (access ("gdbtcl/main.tcl", R_OK) == 0)
 558       gdbtk_lib = "gdbtcl";
 559     else
 560       gdbtk_lib = GDBTK_LIBRARY;
 561
 562   gdbtk_lib_tmp = xstrdup (gdbtk_lib);
 563
 564   found_main = 0;
 565   /* see if GDBTK_LIBRARY is a path list */
 566   lib = strtok (gdbtk_lib_tmp, GDBTK_PATH_SEP);
 567
 568   auto_path_name = Tcl_NewStringObj ("auto_path", -1);
 569
 570   do
 571     {
 572       auto_path_elem = Tcl_NewStringObj (lib, -1);
 573       if (Tcl_ObjSetVar2 (gdbtk_interp, auto_path_name, NULL, auto_path_elem,
 574                           TCL_GLOBAL_ONLY | TCL_APPEND_VALUE | TCL_LIST_ELEMENT ) == NULL)
 575         {
 576           fputs_unfiltered (Tcl_GetVar (gdbtk_interp, "errorInfo", 0), gdb_stderr);
 577           error ("");
 578         }
 579       if (!found_main)
 580         {
 581           gdbtk_file = concat (lib, "/main.tcl", (char *) NULL);
 582           if (access (gdbtk_file, R_OK) == 0)
 583             {
 584               found_main++;
 585               Tcl_SetVar (gdbtk_interp, "GDBTK_LIBRARY", lib, 0);
 586             }
 587         }
 588      }
 589   while ((lib = strtok (NULL, ":")) != NULL);
 590
 591   free (gdbtk_lib_tmp);
 592   Tcl_DecrRefCount(auto_path_name);
 593
 594   if (!found_main)
 595     {
 596       /* Try finding it with the auto path.  */
 597
 598       static const char script[] ="\
 599 proc gdbtk_find_main {} {\n\
 600   global auto_path GDBTK_LIBRARY\n\
 601   foreach dir $auto_path {\n\
 602     set f [file join $dir main.tcl]\n\
 603     if {[file exists $f]} then {\n\
 604       set GDBTK_LIBRARY $dir\n\
 605       return $f\n\
 606     }\n\
 607   }\n\
 608   return ""\n\
 609 }\n\
 610 gdbtk_find_main";
 611
 612       if (Tcl_GlobalEval (gdbtk_interp, (char *) script) != TCL_OK)
 613         {
 614           fputs_unfiltered (Tcl_GetVar (gdbtk_interp, "errorInfo", 0), gdb_stderr);
 615           error ("");
 616         }
 617
 618       if (gdbtk_interp->result[0] != '\0')
 619         {
 620           gdbtk_file = xstrdup (gdbtk_interp->result);
 621           found_main++;
 622         }
 623     }
 624
 625   if (!found_main)
 626     {
 627       fputs_unfiltered_hook = NULL; /* Force errors to stdout/stderr */
 628       if (getenv("GDBTK_LIBRARY"))
 629         {
 630           fprintf_unfiltered (stderr, "Unable to find main.tcl in %s\n",getenv("GDBTK_LIBRARY"));
 631           fprintf_unfiltered (stderr,
 632                               "Please set GDBTK_LIBRARY to a path that includes the GDB tcl files.\n");
 633         }
 634       else
 635         {
 636           fprintf_unfiltered (stderr, "Unable to find main.tcl in %s\n", GDBTK_LIBRARY);
 637           fprintf_unfiltered (stderr, "You might want to set GDBTK_LIBRARY\n");
 638         }
 639       error("");
 640     }
 641
 642 /* Defer setup of fputs_unfiltered_hook to near the end so that error messages
 643    prior to this point go to stdout/stderr.  */
 644
 645   fputs_unfiltered_hook = gdbtk_fputs;
 646
 647 /* start-sanitize-tclpro */
 648 #ifdef TCLPRO_DEBUGGER
 649   {
 650     Tcl_DString source_cmd;
 651
 652     Tcl_DStringInit (&source_cmd);
 653     Tcl_DStringAppend (&source_cmd,
 654                       "if {[info exists env(DEBUG_STUB)]} {source $env(DEBUG_STUB); " -1);
 655     Tcl_DStringAppend (&source_cmd, "debugger_init; debugger_eval {source {", -1);
 656     Tcl_DStringAppend (&source_cmd, gdbtk_file, -1);
 657     Tcl_DStringAppend (&source_cmd, "}}} else {source {", -1);
 658     Tcl_DStringAppend (&source_cmd, gdbtk_file, -1);
 659     Tcl_DStringAppend (&source_cmd, "}}", -1);
 660     if (Tcl_GlobalEval (gdbtk_interp, Tcl_DStringValue (&source_cmd)) != TCL_OK)
 661 #else
 662 /* end-sanitize-tclpro */
 663       if (Tcl_EvalFile (gdbtk_interp, gdbtk_file) != TCL_OK)
 664 /* start-sanitize-tclpro */
 665 #endif
 666 /* end-sanitize-tclpro */
 667         {
 668       char *msg;
 669
 670       /* Force errorInfo to be set up propertly.  */
 671       Tcl_AddErrorInfo (gdbtk_interp, "");
 672
 673       msg = Tcl_GetVar (gdbtk_interp, "errorInfo", TCL_GLOBAL_ONLY);
 674
 675       fputs_unfiltered_hook = NULL; /* Force errors to stdout/stderr */
 676
 677 #ifdef _WIN32
 678       MessageBox (NULL, msg, NULL, MB_OK | MB_ICONERROR | MB_TASKMODAL);
 679 #else
 680       fputs_unfiltered (msg, gdb_stderr);
 681 #endif
 682
 683       error ("");
 684     }
 685 /* start-sanitize-tclpro */
 686 #ifdef TCLPRO_DEBUGGER
 687       Tcl_DStringFree(&source_cmd);
 688     }
 689 #endif
 690 /* end-sanitize-tclpro */
 691
 692 #ifdef IDE
 693   /* start-sanitize-ide */
 694   /* Don't do this until we have initialized.  Otherwise, we may get a
 695      run command before we are ready for one.  */
 696   if (ide_run_server_init (gdbtk_interp, h) != TCL_OK)
 697     error ("ide_run_server_init failed: %s", gdbtk_interp->result);
 698   /* end-sanitize-ide */
 699 #endif
 700
 701   free (gdbtk_file);
 702
 703   /* Now source in the filename provided by the --tclcommand option.
 704      This is mostly used for the gdbtk testsuite... */
 705
 706   if (gdbtk_source_filename != NULL)
 707     {
 708       char *s = "after idle source ";
 709       char *script = concat (s, gdbtk_source_filename, (char *) NULL);
 710       Tcl_Eval (gdbtk_interp, script);
 711       free (gdbtk_source_filename);
 712       free (script);
 713     }
 714
 715
 716   discard_cleanups (old_chain);
 717 }
 718
 719 /* gdbtk_test is used in main.c to validate the -tclcommand option to
 720    gdb, which sources in a file of tcl code after idle during the
 721    startup procedure. */
 722
 723 int
 724 gdbtk_test (filename)
 725      char *filename;
 726 {
 727   if (access (filename, R_OK) != 0)
 728     return 0;
 729   else
 730     gdbtk_source_filename = xstrdup (filename);
 731   return 1;
 732 }
 733
 734 /* Come here during initialize_all_files () */
 735
 736 void
 737 _initialize_gdbtk ()
 738 {
 739   if (use_windows)
 740     {
 741       /* Tell the rest of the world that Gdbtk is now set up. */
 742
 743       init_ui_hook = gdbtk_init;
 744 #ifdef __CYGWIN32__
 745       (void) FreeConsole ();
 746 #endif
 747     }
 748 #ifdef __CYGWIN32__
 749   else
 750     {
 751       DWORD ft = GetFileType (GetStdHandle (STD_INPUT_HANDLE));
 752       void cygwin32_attach_handle_to_fd (char *, int, HANDLE, int, int);
 753
 754       switch (ft)
 755         {
 756           case FILE_TYPE_DISK:
 757           case FILE_TYPE_CHAR:
 758           case FILE_TYPE_PIPE:
 759             break;
 760           default:
 761             AllocConsole();
 762             cygwin32_attach_handle_to_fd ("/dev/conin", 0,
 763                                           GetStdHandle (STD_INPUT_HANDLE),
 764                                           1, GENERIC_READ);
 765             cygwin32_attach_handle_to_fd ("/dev/conout", 1,
 766                                           GetStdHandle (STD_OUTPUT_HANDLE),
 767                                           0, GENERIC_WRITE);
 768             cygwin32_attach_handle_to_fd ("/dev/conout", 2,
 769                                           GetStdHandle (STD_ERROR_HANDLE),
 770                                           0, GENERIC_WRITE);
 771             break;
 772         }
 773     }
 774 #endif
 775 }
 776
 777 static void
 778 tk_command (cmd, from_tty)
 779      char *cmd;
 780      int from_tty;
 781 {
 782   int retval;
 783   char *result;
 784   struct cleanup *old_chain;
 785
 786   /* Catch case of no argument, since this will make the tcl interpreter dump core. */
 787   if (cmd == NULL)
 788     error_no_arg ("tcl command to interpret");
 789
 790   retval = Tcl_Eval (gdbtk_interp, cmd);
 791
 792   result = strdup (gdbtk_interp->result);
 793
 794   old_chain = make_cleanup (free, result);
 795
 796   if (retval != TCL_OK)
 797     error (result);
 798
 799   printf_unfiltered ("%s\n", result);
 800
 801   do_cleanups (old_chain);
 802 }
 803