1 /* Startup code for gdbtk.
2 Copyright 1994, 1995, 1996, 1997, 1998 Free Software Foundation, Inc.
4 Written by Stu Grossman <grossman@cygnus.com> of Cygnus Support.
6 This file is part of GDB.
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.
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.
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. */
31 #include "tracepoint.h"
47 #ifdef ANSI_PROTOTYPES
57 #include <sys/ioctl.h>
58 #include "gdb_string.h"
67 #include <sys/cygwin.h> /* for cygwin32_attach_handle_to_fd */
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;
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.
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";
89 extern int Tktable_Init PARAMS ((Tcl_Interp *interp));
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));
96 void gdbtk_add_hooks PARAMS ((void));
97 int gdbtk_test PARAMS ((char *));
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.
105 extern void gdbtk_fputs PARAMS ((const char *, GDB_FILE *));
107 /* Handle for TCL interpreter */
108 Tcl_Interp *gdbtk_interp = NULL;
110 static int gdbtk_timer_going = 0;
112 /* linked variable used to tell tcl what the current thread is */
115 /* This variable is true when the inferior is running. See note in
116 * gdbtk.h for details.
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;
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. */
132 #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
137 return xmalloc (size);
141 TclpRealloc (ptr, size)
145 return xrealloc (ptr, size);
154 #endif /* TCL_VERSION == 8.0 */
156 #endif /* ! _WIN32 */
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.
175 bfd_cache_close (o->obfd);
178 if (exec_bfd != NULL)
179 bfd_cache_close (exec_bfd);
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
191 TclDebug (char level, const char *fmt, ...)
194 char buf[512], *v[3], *merge, *priority;
211 va_start (args, fmt);
217 vsprintf (buf, fmt, args);
220 merge = Tcl_Merge (3, v);
221 if (Tcl_Eval (gdbtk_interp, merge) != TCL_OK)
222 Tcl_BackgroundError(gdbtk_interp);
228 * The rest of this file contains the start-up, and event handling code for gdbtk.
232 * This cleanup function is added to the cleanup list that surrounds the Tk
233 * main in gdbtk_init. It deletes the Tcl interpreter.
237 cleanup_init (ignored)
240 if (gdbtk_interp != NULL)
241 Tcl_DeleteInterp (gdbtk_interp);
245 /* Come here during long calculations to check for GUI events. Usually invoked
246 via the QUIT macro. */
251 /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */
258 static int first = 1;
259 /*TclDebug ("Starting timer....");*/
262 /* first time called, set up all the structs */
264 sigemptyset (&nullsigmask);
266 act1.sa_handler = x_event;
267 act1.sa_mask = nullsigmask;
270 act2.sa_handler = SIG_IGN;
271 act2.sa_mask = nullsigmask;
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;
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;
285 if (!gdbtk_timer_going)
287 sigaction (SIGALRM, &act1, NULL);
288 setitimer (ITIMER_REAL, &it_on, NULL);
289 gdbtk_timer_going = 1;
296 if (gdbtk_timer_going)
298 gdbtk_timer_going = 0;
299 /*TclDebug ("Stopping timer.");*/
300 setitimer (ITIMER_REAL, &it_off, NULL);
301 sigaction (SIGALRM, &act2, NULL);
305 /* gdbtk_init installs this function as a final cleanup. */
308 gdbtk_cleanup (dummy)
311 Tcl_Eval (gdbtk_interp, "gdbtk_cleanup");
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.
326 struct cleanup *old_chain;
329 Tcl_Obj *auto_path_elem, *auto_path_name;
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. */
336 if (getenv ("DISPLAY") == NULL)
340 old_chain = make_cleanup ((make_cleanup_func) cleanup_init, 0);
342 /* First init tcl and tk. */
343 Tcl_FindExecutable (argv0);
344 gdbtk_interp = Tcl_CreateInterp ();
347 Tcl_InitMemory (gdbtk_interp);
351 error ("Tcl_CreateInterp failed");
353 if (Tcl_Init(gdbtk_interp) != TCL_OK)
354 error ("Tcl_Init failed: %s", gdbtk_interp->result);
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);
361 make_final_cleanup (gdbtk_cleanup, NULL);
363 /* Initialize the Paths variable. */
364 if (ide_initialize_paths (gdbtk_interp, "") != TCL_OK)
365 error ("ide_initialize_paths failed: %s", gdbtk_interp->result);
367 if (Tk_Init(gdbtk_interp) != TCL_OK)
368 error ("Tk_Init failed: %s", gdbtk_interp->result);
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);
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);
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);
385 if (Tktable_Init(gdbtk_interp) != TCL_OK)
386 error ("Tktable_Init failed: %s", gdbtk_interp->result);
388 Tcl_StaticPackage(gdbtk_interp, "Tktable", Tktable_Init,
389 (Tcl_PackageInitProc *) NULL);
391 * These are the commands to do some Windows Specific stuff...
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");
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");
414 * This adds all the Gdbtk commands.
417 if (Gdbtk_Init(gdbtk_interp) != TCL_OK)
419 error("Gdbtk_Init failed: %s", gdbtk_interp->result);
422 Tcl_StaticPackage(gdbtk_interp, "Gdbtk", Gdbtk_Init, NULL);
424 /* This adds all the hooks that call up from the bowels of gdb
425 * back into Tcl-land...
430 /* Add a back door to Tk from the gdb console... */
432 add_com ("tk", class_obscure, tk_command,
433 "Send a command directly into tk.");
436 * Set the variables for external editor:
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);
442 /* find the gdb tcl library and source main.tcl */
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\
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\
462 set debug_startup 1\n\
464 set debug_startup 0\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\
470 #endif /* NO_TCLPRO_DEBUGGER */
472 /* fputs_unfiltered_hook = NULL; */ /* Force errors to stdout/stderr */
475 * Set the variables for external editor, do this before eval'ing main.tcl
476 * since the value is used there...
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);
484 fputs_unfiltered_hook = gdbtk_fputs;
486 if (Tcl_GlobalEval (gdbtk_interp, (char *) script) != TCL_OK)
490 /* Force errorInfo to be set up propertly. */
491 Tcl_AddErrorInfo (gdbtk_interp, "");
493 msg = Tcl_GetVar (gdbtk_interp, "errorInfo", TCL_GLOBAL_ONLY);
495 fputs_unfiltered_hook = NULL; /* Force errors to stdout/stderr */
498 MessageBox (NULL, msg, NULL, MB_OK | MB_ICONERROR | MB_TASKMODAL);
500 fputs_unfiltered (msg, gdb_stderr);
508 /* Now source in the filename provided by the --tclcommand option.
509 This is mostly used for the gdbtk testsuite... */
511 if (gdbtk_source_filename != NULL)
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);
521 discard_cleanups (old_chain);
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. */
529 gdbtk_test (filename)
532 if (access (filename, R_OK) != 0)
535 gdbtk_source_filename = xstrdup (filename);
539 /* Come here during initialize_all_files () */
546 /* Tell the rest of the world that Gdbtk is now set up. */
548 init_ui_hook = gdbtk_init;
550 (void) FreeConsole ();
556 DWORD ft = GetFileType (GetStdHandle (STD_INPUT_HANDLE));
566 cygwin32_attach_handle_to_fd ("/dev/conin", 0,
567 GetStdHandle (STD_INPUT_HANDLE),
569 cygwin32_attach_handle_to_fd ("/dev/conout", 1,
570 GetStdHandle (STD_OUTPUT_HANDLE),
572 cygwin32_attach_handle_to_fd ("/dev/conout", 2,
573 GetStdHandle (STD_ERROR_HANDLE),
582 tk_command (cmd, from_tty)
588 struct cleanup *old_chain;
590 /* Catch case of no argument, since this will make the tcl interpreter dump core. */
592 error_no_arg ("tcl command to interpret");
594 retval = Tcl_Eval (gdbtk_interp, cmd);
596 result = strdup (gdbtk_interp->result);
598 old_chain = make_cleanup (free, result);
600 if (retval != TCL_OK)
603 printf_unfiltered ("%s\n", result);
605 do_cleanups (old_chain);
608 /* Local variables: */
609 /* change-log-default-name: "ChangeLog-gdbtk" */