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 Cygwin, 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 gdbtk_init PARAMS ((char *));
  85 void gdbtk_interactive PARAMS ((void));
  86 static void cleanup_init PARAMS ((int));
  87 static void tk_command PARAMS ((char *, int));
  88
  89 void gdbtk_add_hooks PARAMS ((void));
  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 /* linked variable used to tell tcl what the current thread is */
 106 int gdb_context = 0;
 107
 108 /* This variable is true when the inferior is running.  See note in
 109  * gdbtk.h for details.
 110  */
 111 int running_now;
 112
 113 /* This variable holds the name of a Tcl file which should be sourced by the
 114    interpreter when it goes idle at startup. Used with the testsuite. */
 115 static char *gdbtk_source_filename = NULL;
 116 \f
 117 #ifndef _WIN32
 118
 119 /* Supply malloc calls for tcl/tk.  We do not want to do this on
 120    Windows, because Tcl_Alloc is probably in a DLL which will not call
 121    the mmalloc routines.  */
 122
 123 char *
 124 Tcl_Alloc (size)
 125      unsigned int size;
 126 {
 127   return xmalloc (size);
 128 }
 129
 130 char *
 131 Tcl_Realloc (ptr, size)
 132      char *ptr;
 133      unsigned int size;
 134 {
 135   return xrealloc (ptr, size);
 136 }
 137
 138 void
 139 Tcl_Free(ptr)
 140      char *ptr;
 141 {
 142   free (ptr);
 143 }
 144
 145 #endif /* ! _WIN32 */
 146
 147 #ifdef _WIN32
 148
 149 /* On Windows, if we hold a file open, other programs can't write to
 150  * it.  In particular, we don't want to hold the executable open,
 151  * because it will mean that people have to get out of the debugging
 152  * session in order to remake their program.  So we close it, although
 153  * this will cost us if and when we need to reopen it.
 154  */
 155
 156 void
 157 close_bfds ()
 158 {
 159   struct objfile *o;
 160
 161   ALL_OBJFILES (o)
 162     {
 163       if (o->obfd != NULL)
 164         bfd_cache_close (o->obfd);
 165     }
 166
 167   if (exec_bfd != NULL)
 168     bfd_cache_close (exec_bfd);
 169 }
 170
 171 #endif /* _WIN32 */
 172
 173 \f
 174 /* TclDebug (const char *fmt, ...) works just like printf() but
 175  * sends the output to the GDB TK debug window.
 176  * Not for normal use; just a convenient tool for debugging
 177  */
 178
 179 void
 180 #ifdef ANSI_PROTOTYPES
 181 TclDebug (const char *fmt, ...)
 182 #else
 183 TclDebug (va_alist)
 184      va_dcl
 185 #endif
 186 {
 187   va_list args;
 188   char buf[512], *v[2], *merge;
 189
 190 #ifdef ANSI_PROTOTYPES
 191   va_start (args, fmt);
 192 #else
 193   char *fmt;
 194   va_start (args);
 195   fmt = va_arg (args, char *);
 196 #endif
 197
 198   v[0] = "debug";
 199   v[1] = buf;
 200
 201   vsprintf (buf, fmt, args);
 202   va_end (args);
 203
 204   merge = Tcl_Merge (2, v);
 205   Tcl_Eval (gdbtk_interp, merge);
 206   Tcl_Free (merge);
 207 }
 208
 209 \f
 210 /*
 211  * The rest of this file contains the start-up, and event handling code for gdbtk.
 212  */
 213
 214 /*
 215  * This cleanup function is added to the cleanup list that surrounds the Tk
 216  * main in gdbtk_init.  It deletes the Tcl interpreter.
 217  */
 218
 219 static void
 220 cleanup_init (ignored)
 221      int ignored;
 222 {
 223   if (gdbtk_interp != NULL)
 224     Tcl_DeleteInterp (gdbtk_interp);
 225   gdbtk_interp = NULL;
 226 }
 227
 228 /* Come here during long calculations to check for GUI events.  Usually invoked
 229    via the QUIT macro.  */
 230
 231 void
 232 gdbtk_interactive ()
 233 {
 234   /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */
 235 }
 236
 237
 238 void
 239 gdbtk_start_timer ()
 240 {
 241   static int first = 1;
 242   /*TclDebug ("Starting timer....");*/
 243   if (first)
 244     {
 245       /* first time called, set up all the structs */
 246       first = 0;
 247       sigemptyset (&nullsigmask);
 248
 249       act1.sa_handler = x_event;
 250       act1.sa_mask = nullsigmask;
 251       act1.sa_flags = 0;
 252
 253       act2.sa_handler = SIG_IGN;
 254       act2.sa_mask = nullsigmask;
 255       act2.sa_flags = 0;
 256
 257       it_on.it_interval.tv_sec = 0;
 258       it_on.it_interval.tv_usec = 250000; /* .25 sec */
 259       it_on.it_value.tv_sec = 0;
 260       it_on.it_value.tv_usec = 250000;
 261
 262       it_off.it_interval.tv_sec = 0;
 263       it_off.it_interval.tv_usec = 0;
 264       it_off.it_value.tv_sec = 0;
 265       it_off.it_value.tv_usec = 0;
 266     }
 267
 268   if (!gdbtk_timer_going)
 269     {
 270       sigaction (SIGALRM, &act1, NULL);
 271       setitimer (ITIMER_REAL, &it_on, NULL);
 272       gdbtk_timer_going = 1;
 273     }
 274 }
 275
 276 void
 277 gdbtk_stop_timer ()
 278 {
 279   if (gdbtk_timer_going)
 280     {
 281       gdbtk_timer_going = 0;
 282       /*TclDebug ("Stopping timer.");*/
 283       setitimer (ITIMER_REAL, &it_off, NULL);
 284       sigaction (SIGALRM, &act2, NULL);
 285     }
 286 }
 287
 288 /* gdbtk_init installs this function as a final cleanup.  */
 289
 290 static void
 291 gdbtk_cleanup (dummy)
 292      PTR dummy;
 293 {
 294   Tcl_Eval (gdbtk_interp, "gdbtk_cleanup");
 295 #ifdef IDE
 296   {
 297     struct ide_event_handle *h = (struct ide_event_handle *) dummy;
 298     ide_interface_deregister_all (h);
 299   }
 300 #endif
 301   Tcl_Finalize ();
 302 }
 303
 304 /* Initialize gdbtk.  This involves creating a Tcl interpreter,
 305  * defining all the Tcl commands that the GUI will use, pointing
 306  * all the gdb "hooks" to the correct functions,
 307  * and setting the Tcl auto loading environment so that we can find all
 308  * the Tcl based library files.
 309  */
 310
 311 static void
 312 gdbtk_init ( argv0 )
 313      char *argv0;
 314 {
 315   struct cleanup *old_chain;
 316   char *lib, *gdbtk_lib, *gdbtk_lib_tmp, *gdbtk_file;
 317   int found_main;
 318   Tcl_Obj *auto_path_elem, *auto_path_name;
 319
 320 #ifdef IDE
 321   /* start-sanitize-ide */
 322   struct ide_event_handle *h;
 323   const char *errmsg;
 324   char *libexecdir;
 325   /* end-sanitize-ide */
 326 #endif
 327
 328   /* If there is no DISPLAY environment variable, Tk_Init below will fail,
 329      causing gdb to abort.  If instead we simply return here, gdb will
 330      gracefully degrade to using the command line interface. */
 331
 332 #ifndef _WIN32
 333   if (getenv ("DISPLAY") == NULL)
 334     return;
 335 #endif
 336
 337   old_chain = make_cleanup ((make_cleanup_func) cleanup_init, 0);
 338
 339   /* First init tcl and tk. */
 340   Tcl_FindExecutable (argv0);
 341   gdbtk_interp = Tcl_CreateInterp ();
 342
 343 #ifdef TCL_MEM_DEBUG
 344   Tcl_InitMemory (gdbtk_interp);
 345 #endif
 346
 347   if (!gdbtk_interp)
 348     error ("Tcl_CreateInterp failed");
 349
 350   if (Tcl_Init(gdbtk_interp) != TCL_OK)
 351     error ("Tcl_Init failed: %s", gdbtk_interp->result);
 352
 353 #ifndef IDE
 354   /* For the IDE we register the cleanup later, after we've
 355      initialized events.  */
 356   make_final_cleanup (gdbtk_cleanup,  NULL);
 357 #endif
 358
 359   /* Initialize the Paths variable.  */
 360   if (ide_initialize_paths (gdbtk_interp, "gdbtcl") != TCL_OK)
 361     error ("ide_initialize_paths failed: %s", gdbtk_interp->result);
 362
 363 #ifdef IDE
 364   /* start-sanitize-ide */
 365   /* Find the directory where we expect to find idemanager.  We ignore
 366      errors since it doesn't really matter if this fails.  */
 367   libexecdir = Tcl_GetVar2 (gdbtk_interp, "Paths", "libexecdir", TCL_GLOBAL_ONLY);
 368
 369   IluTk_Init ();
 370
 371   h = ide_event_init_from_environment (&errmsg, libexecdir);
 372   make_final_cleanup (gdbtk_cleanup, h);
 373   if (h == NULL)
 374     {
 375       Tcl_AppendResult (gdbtk_interp, "can't initialize event system: ", errmsg,
 376                         (char *) NULL);
 377       fprintf(stderr, "WARNING: ide_event_init_client failed: %s\n", gdbtk_interp->result);
 378
 379       Tcl_SetVar (gdbtk_interp, "IDE_ENABLED", "0", 0);
 380     }
 381   else
 382     {
 383       if (ide_create_tclevent_command (gdbtk_interp, h) != TCL_OK)
 384         error ("ide_create_tclevent_command failed: %s", gdbtk_interp->result);
 385
 386       if (ide_create_edit_command (gdbtk_interp, h) != TCL_OK)
 387         error ("ide_create_edit_command failed: %s", gdbtk_interp->result);
 388
 389       if (ide_create_property_command (gdbtk_interp, h) != TCL_OK)
 390         error ("ide_create_property_command failed: %s", gdbtk_interp->result);
 391
 392       if (ide_create_build_command (gdbtk_interp, h) != TCL_OK)
 393         error ("ide_create_build_command failed: %s", gdbtk_interp->result);
 394
 395       if (ide_create_window_register_command (gdbtk_interp, h, "gdb-restore")
 396           != TCL_OK)
 397         error ("ide_create_window_register_command failed: %s",
 398                gdbtk_interp->result);
 399
 400       if (ide_create_window_command (gdbtk_interp, h) != TCL_OK)
 401         error ("ide_create_window_command failed: %s", gdbtk_interp->result);
 402
 403       if (ide_create_exit_command (gdbtk_interp, h) != TCL_OK)
 404         error ("ide_create_exit_command failed: %s", gdbtk_interp->result);
 405
 406       if (ide_create_help_command (gdbtk_interp) != TCL_OK)
 407         error ("ide_create_help_command failed: %s", gdbtk_interp->result);
 408
 409       /*
 410         if (ide_initialize (gdbtk_interp, "gdb") != TCL_OK)
 411         error ("ide_initialize failed: %s", gdbtk_interp->result);
 412       */
 413
 414       Tcl_SetVar (gdbtk_interp, "IDE_ENABLED", "1", 0);
 415     }
 416   /* end-sanitize-ide */
 417 #else
 418   Tcl_SetVar (gdbtk_interp, "IDE_ENABLED", "0", 0);
 419 #endif /* IDE */
 420
 421   /* We don't want to open the X connection until we've done all the
 422      IDE initialization.  Otherwise, goofy looking unfinished windows
 423      pop up when ILU drops into the TCL event loop.  */
 424
 425   if (Tk_Init(gdbtk_interp) != TCL_OK)
 426     error ("Tk_Init failed: %s", gdbtk_interp->result);
 427
 428   if (Itcl_Init(gdbtk_interp) == TCL_ERROR)
 429     error ("Itcl_Init failed: %s", gdbtk_interp->result);
 430   Tcl_StaticPackage(gdbtk_interp, "Tktable", Tktable_Init,
 431                     (Tcl_PackageInitProc *) NULL);
 432
 433   if (Tix_Init(gdbtk_interp) != TCL_OK)
 434     error ("Tix_Init failed: %s", gdbtk_interp->result);
 435   Tcl_StaticPackage(gdbtk_interp, "Tktable", Tktable_Init,
 436                     (Tcl_PackageInitProc *) NULL);
 437
 438   if (Tktable_Init(gdbtk_interp) != TCL_OK)
 439     error ("Tktable_Init failed: %s", gdbtk_interp->result);
 440
 441   Tcl_StaticPackage(gdbtk_interp, "Tktable", Tktable_Init,
 442                     (Tcl_PackageInitProc *) NULL);
 443   /*
 444    * These are the commands to do some Windows Specific stuff...
 445    */
 446
 447 #ifdef __CYGWIN__
 448   if (ide_create_messagebox_command (gdbtk_interp) != TCL_OK)
 449     error ("messagebox command initialization failed");
 450   /* On Windows, create a sizebox widget command */
 451   if (ide_create_sizebox_command (gdbtk_interp) != TCL_OK)
 452     error ("sizebox creation failed");
 453   if (ide_create_winprint_command (gdbtk_interp) != TCL_OK)
 454     error ("windows print code initialization failed");
 455   /* start-sanitize-ide */
 456   /* An interface to ShellExecute.  */
 457   if (ide_create_shell_execute_command (gdbtk_interp) != TCL_OK)
 458     error ("shell execute command initialization failed");
 459   /* end-sanitize-ide */
 460   if (ide_create_win_grab_command (gdbtk_interp) != TCL_OK)
 461     error ("grab support command initialization failed");
 462   /* Path conversion functions.  */
 463   if (ide_create_cygwin_path_command (gdbtk_interp) != TCL_OK)
 464     error ("cygwin path command initialization failed");
 465 #endif
 466
 467   /*
 468    * This adds all the Gdbtk commands.
 469    */
 470
 471   if (Gdbtk_Init(gdbtk_interp) != TCL_OK)
 472     {
 473        error("Gdbtk_Init failed: %s", gdbtk_interp->result);
 474     }
 475
 476   Tcl_StaticPackage(gdbtk_interp, "Gdbtk", Gdbtk_Init, NULL);
 477
 478   /* This adds all the hooks that call up from the bowels of gdb
 479    *  back into Tcl-land...
 480    */
 481
 482   gdbtk_add_hooks();
 483
 484   /* Add a back door to Tk from the gdb console... */
 485
 486   add_com ("tk", class_obscure, tk_command,
 487            "Send a command directly into tk.");
 488
 489   /* find the gdb tcl library and source main.tcl */
 490
 491   gdbtk_lib = getenv ("GDBTK_LIBRARY");
 492   if (!gdbtk_lib)
 493     {
 494       if (access ("gdbtcl/main.tcl", R_OK) == 0)
 495         gdbtk_lib = "gdbtcl";
 496       else
 497         gdbtk_lib = GDBTK_LIBRARY;
 498     }
 499
 500   gdbtk_lib_tmp = xstrdup (gdbtk_lib);
 501
 502   found_main = 0;
 503   /* see if GDBTK_LIBRARY is a path list */
 504   lib = strtok (gdbtk_lib_tmp, GDBTK_PATH_SEP);
 505
 506   auto_path_name = Tcl_NewStringObj ("auto_path", -1);
 507
 508   do
 509     {
 510       auto_path_elem = Tcl_NewStringObj (lib, -1);
 511       if (Tcl_ObjSetVar2 (gdbtk_interp, auto_path_name, NULL, auto_path_elem,
 512                           TCL_GLOBAL_ONLY | TCL_APPEND_VALUE | TCL_LIST_ELEMENT ) == NULL)
 513         {
 514           fputs_unfiltered (Tcl_GetVar (gdbtk_interp, "errorInfo", 0), gdb_stderr);
 515           error ("");
 516         }
 517       if (!found_main)
 518         {
 519           gdbtk_file = concat (lib, "/main.tcl", (char *) NULL);
 520           if (access (gdbtk_file, R_OK) == 0)
 521             {
 522               found_main++;
 523               Tcl_SetVar (gdbtk_interp, "GDBTK_LIBRARY", lib, 0);
 524             }
 525         }
 526      }
 527   while ((lib = strtok (NULL, ":")) != NULL);
 528
 529   free (gdbtk_lib_tmp);
 530   Tcl_DecrRefCount(auto_path_name);
 531
 532   if (!found_main)
 533     {
 534       /* Try finding it with the auto path.  */
 535
 536       static const char script[] ="\
 537 proc gdbtk_find_main {} {\n\
 538   global auto_path GDBTK_LIBRARY\n\
 539   foreach dir $auto_path {\n\
 540     set f [file join $dir main.tcl]\n\
 541     if {[file exists $f]} then {\n\
 542       set GDBTK_LIBRARY $dir\n\
 543       return $f\n\
 544     }\n\
 545   }\n\
 546   return ""\n\
 547 }\n\
 548 gdbtk_find_main";
 549
 550       if (Tcl_GlobalEval (gdbtk_interp, (char *) script) != TCL_OK)
 551         {
 552           fputs_unfiltered (Tcl_GetVar (gdbtk_interp, "errorInfo", 0), gdb_stderr);
 553           error ("");
 554         }
 555
 556       if (gdbtk_interp->result[0] != '\0')
 557         {
 558           gdbtk_file = xstrdup (gdbtk_interp->result);
 559           found_main++;
 560         }
 561     }
 562
 563   if (!found_main)
 564     {
 565       fputs_unfiltered_hook = NULL; /* Force errors to stdout/stderr */
 566       if (getenv("GDBTK_LIBRARY"))
 567         {
 568           fprintf_unfiltered (stderr, "Unable to find main.tcl in %s\n",getenv("GDBTK_LIBRARY"));
 569           fprintf_unfiltered (stderr,
 570                               "Please set GDBTK_LIBRARY to a path that includes the GDB tcl files.\n");
 571         }
 572       else
 573         {
 574           fprintf_unfiltered (stderr, "Unable to find main.tcl in %s\n", GDBTK_LIBRARY);
 575           fprintf_unfiltered (stderr, "You might want to set GDBTK_LIBRARY\n");
 576         }
 577       error("");
 578     }
 579
 580 /* Defer setup of fputs_unfiltered_hook to near the end so that error messages
 581    prior to this point go to stdout/stderr.  */
 582
 583   fputs_unfiltered_hook = gdbtk_fputs;
 584
 585 /* start-sanitize-tclpro */
 586 #ifdef TCLPRO_DEBUGGER
 587   {
 588     Tcl_DString source_cmd;
 589
 590     Tcl_DStringInit (&source_cmd);
 591     Tcl_DStringAppend (&source_cmd,
 592                       "if {[info exists env(DEBUG_STUB)]} {source $env(DEBUG_STUB); " -1);
 593     Tcl_DStringAppend (&source_cmd, "debugger_init; debugger_eval {source {", -1);
 594     Tcl_DStringAppend (&source_cmd, gdbtk_file, -1);
 595     Tcl_DStringAppend (&source_cmd, "}}} else {source {", -1);
 596     Tcl_DStringAppend (&source_cmd, gdbtk_file, -1);
 597     Tcl_DStringAppend (&source_cmd, "}}", -1);
 598     if (Tcl_GlobalEval (gdbtk_interp, Tcl_DStringValue (&source_cmd)) != TCL_OK)
 599 #else
 600 /* end-sanitize-tclpro */
 601       if (Tcl_EvalFile (gdbtk_interp, gdbtk_file) != TCL_OK)
 602 /* start-sanitize-tclpro */
 603 #endif
 604 /* end-sanitize-tclpro */
 605         {
 606       char *msg;
 607
 608       /* Force errorInfo to be set up propertly.  */
 609       Tcl_AddErrorInfo (gdbtk_interp, "");
 610
 611       msg = Tcl_GetVar (gdbtk_interp, "errorInfo", TCL_GLOBAL_ONLY);
 612
 613       fputs_unfiltered_hook = NULL; /* Force errors to stdout/stderr */
 614
 615 #ifdef _WIN32
 616       MessageBox (NULL, msg, NULL, MB_OK | MB_ICONERROR | MB_TASKMODAL);
 617 #else
 618       fputs_unfiltered (msg, gdb_stderr);
 619 #endif
 620
 621       error ("");
 622     }
 623 /* start-sanitize-tclpro */
 624 #ifdef TCLPRO_DEBUGGER
 625       Tcl_DStringFree(&source_cmd);
 626     }
 627 #endif
 628 /* end-sanitize-tclpro */
 629
 630 #ifdef IDE
 631   /* start-sanitize-ide */
 632   /* Don't do this until we have initialized.  Otherwise, we may get a
 633      run command before we are ready for one.  */
 634   if (ide_run_server_init (gdbtk_interp, h) != TCL_OK)
 635     error ("ide_run_server_init failed: %s", gdbtk_interp->result);
 636   /* end-sanitize-ide */
 637 #endif
 638
 639   free (gdbtk_file);
 640
 641   /* Now source in the filename provided by the --tclcommand option.
 642      This is mostly used for the gdbtk testsuite... */
 643
 644   if (gdbtk_source_filename != NULL)
 645     {
 646       char *s = "after idle source ";
 647       char *script = concat (s, gdbtk_source_filename, (char *) NULL);
 648       Tcl_Eval (gdbtk_interp, script);
 649       free (gdbtk_source_filename);
 650       free (script);
 651     }
 652
 653
 654   discard_cleanups (old_chain);
 655 }
 656
 657 /* gdbtk_test is used in main.c to validate the -tclcommand option to
 658    gdb, which sources in a file of tcl code after idle during the
 659    startup procedure. */
 660
 661 int
 662 gdbtk_test (filename)
 663      char *filename;
 664 {
 665   if (access (filename, R_OK) != 0)
 666     return 0;
 667   else
 668     gdbtk_source_filename = xstrdup (filename);
 669   return 1;
 670 }
 671
 672 /* Come here during initialize_all_files () */
 673
 674 void
 675 _initialize_gdbtk ()
 676 {
 677   if (use_windows)
 678     {
 679       /* Tell the rest of the world that Gdbtk is now set up. */
 680
 681       init_ui_hook = gdbtk_init;
 682 #ifdef __CYGWIN__
 683       (void) FreeConsole ();
 684 #endif
 685     }
 686 #ifdef __CYGWIN__
 687   else
 688     {
 689       DWORD ft = GetFileType (GetStdHandle (STD_INPUT_HANDLE));
 690       void cygwin_attach_handle_to_fd (char *, int, HANDLE, int, int);
 691
 692       switch (ft)
 693         {
 694           case FILE_TYPE_DISK:
 695           case FILE_TYPE_CHAR:
 696           case FILE_TYPE_PIPE:
 697             break;
 698           default:
 699             AllocConsole();
 700             cygwin_attach_handle_to_fd ("/dev/conin", 0,
 701                                         GetStdHandle (STD_INPUT_HANDLE),
 702                                         1, GENERIC_READ);
 703             cygwin_attach_handle_to_fd ("/dev/conout", 1,
 704                                         GetStdHandle (STD_OUTPUT_HANDLE),
 705                                         0, GENERIC_WRITE);
 706             cygwin_attach_handle_to_fd ("/dev/conout", 2,
 707                                         GetStdHandle (STD_ERROR_HANDLE),
 708                                         0, GENERIC_WRITE);
 709             break;
 710         }
 711     }
 712 #endif
 713 }
 714
 715 static void
 716 tk_command (cmd, from_tty)
 717      char *cmd;
 718      int from_tty;
 719 {
 720   int retval;
 721   char *result;
 722   struct cleanup *old_chain;
 723
 724   /* Catch case of no argument, since this will make the tcl interpreter dump core. */
 725   if (cmd == NULL)
 726     error_no_arg ("tcl command to interpret");
 727
 728   retval = Tcl_Eval (gdbtk_interp, cmd);
 729
 730   result = strdup (gdbtk_interp->result);
 731
 732   old_chain = make_cleanup (free, result);
 733
 734   if (retval != TCL_OK)
 735     error (result);
 736
 737   printf_unfiltered ("%s\n", result);
 738
 739   do_cleanups (old_chain);
 740 }
 741