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"
48 /* start-sanitize-ide */
52 /* end-sanitize-ide */
55 #ifdef ANSI_PROTOTYPES
65 #include <sys/ioctl.h>
66 #include "gdb_string.h"
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
;
82 extern int Tktable_Init
PARAMS ((Tcl_Interp
*interp
));
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));
89 void gdbtk_add_hooks
PARAMS ((void));
90 int gdbtk_test
PARAMS ((char *));
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.
98 extern void gdbtk_fputs
PARAMS ((const char *, FILE *));
100 /* Handle for TCL interpreter */
101 Tcl_Interp
*gdbtk_interp
= NULL
;
103 static int gdbtk_timer_going
= 0;
105 /* This variable is true when the inferior is running. See note in
106 * gdbtk.h for details.
111 /* This variable determines where memory used for disassembly is read from.
112 * See note in gdbtk.h for details.
115 int disassemble_from_exec
= -1;
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. */
120 static char *gdbtk_source_filename
= NULL
;
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. */
132 return xmalloc (size
);
136 Tcl_Realloc (ptr
, size
)
140 return xrealloc (ptr
, size
);
150 #endif /* ! _WIN32 */
154 /* On Windows, if we hold a file open, other programs can't write to
155 * it. In particular, we don't want to hold the executable open,
156 * because it will mean that people have to get out of the debugging
157 * session in order to remake their program. So we close it, although
158 * this will cost us if and when we need to reopen it.
169 bfd_cache_close (o
->obfd
);
172 if (exec_bfd
!= NULL
)
173 bfd_cache_close (exec_bfd
);
179 /* TclDebug (const char *fmt, ...) works just like printf() but
180 * sends the output to the GDB TK debug window.
181 * Not for normal use; just a convenient tool for debugging
185 #ifdef ANSI_PROTOTYPES
186 TclDebug (const char *fmt
, ...)
193 char buf
[512], *v
[2], *merge
;
195 #ifdef ANSI_PROTOTYPES
196 va_start (args
, fmt
);
200 fmt
= va_arg (args
, char *);
206 vsprintf (buf
, fmt
, args
);
209 merge
= Tcl_Merge (2, v
);
210 Tcl_Eval (gdbtk_interp
, merge
);
216 * The rest of this file contains the start-up, and event handling code for gdbtk.
220 * This cleanup function is added to the cleanup list that surrounds the Tk
221 * main in gdbtk_init. It deletes the Tcl interpreter.
225 cleanup_init (ignored
)
228 if (gdbtk_interp
!= NULL
)
229 Tcl_DeleteInterp (gdbtk_interp
);
233 /* Come here during long calculations to check for GUI events. Usually invoked
234 via the QUIT macro. */
239 /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */
246 static int first
= 1;
247 /*TclDebug ("Starting timer....");*/
250 /* first time called, set up all the structs */
252 sigemptyset (&nullsigmask
);
254 act1
.sa_handler
= x_event
;
255 act1
.sa_mask
= nullsigmask
;
258 act2
.sa_handler
= SIG_IGN
;
259 act2
.sa_mask
= nullsigmask
;
262 it_on
.it_interval
.tv_sec
= 0;
263 it_on
.it_interval
.tv_usec
= 250000; /* .25 sec */
264 it_on
.it_value
.tv_sec
= 0;
265 it_on
.it_value
.tv_usec
= 250000;
267 it_off
.it_interval
.tv_sec
= 0;
268 it_off
.it_interval
.tv_usec
= 0;
269 it_off
.it_value
.tv_sec
= 0;
270 it_off
.it_value
.tv_usec
= 0;
273 if (!gdbtk_timer_going
)
275 sigaction (SIGALRM
, &act1
, NULL
);
276 setitimer (ITIMER_REAL
, &it_on
, NULL
);
277 gdbtk_timer_going
= 1;
284 if (gdbtk_timer_going
)
286 gdbtk_timer_going
= 0;
287 /*TclDebug ("Stopping timer.");*/
288 setitimer (ITIMER_REAL
, &it_off
, NULL
);
289 sigaction (SIGALRM
, &act2
, NULL
);
293 /* gdbtk_init installs this function as a final cleanup. */
296 gdbtk_cleanup (dummy
)
299 Tcl_Eval (gdbtk_interp
, "gdbtk_cleanup");
301 struct ide_event_handle
*h
= (struct ide_event_handle
*) dummy
;
302 ide_interface_deregister_all (h
);
307 /* Initialize gdbtk. This involves creating a Tcl interpreter,
308 * defining all the Tcl commands that the GUI will use, pointing
309 * all the gdb "hooks" to the correct functions,
310 * and setting the Tcl auto loading environment so that we can find all
311 * the Tcl based library files.
318 struct cleanup
*old_chain
;
319 char *lib
, *gdbtk_lib
, *gdbtk_lib_tmp
, *gdbtk_file
;
321 Tcl_Obj
*auto_path_elem
, *auto_path_name
;
324 /* start-sanitize-ide */
325 struct ide_event_handle
*h
;
328 /* end-sanitize-ide */
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 (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
);
357 /* For the IDE we register the cleanup later, after we've
358 initialized events. */
359 make_final_cleanup (gdbtk_cleanup
, NULL
);
362 /* Initialize the Paths variable. */
363 if (ide_initialize_paths (gdbtk_interp
, "gdbtcl") != TCL_OK
)
364 error ("ide_initialize_paths failed: %s", gdbtk_interp
->result
);
367 /* start-sanitize-ide */
368 /* Find the directory where we expect to find idemanager. We ignore
369 errors since it doesn't really matter if this fails. */
370 libexecdir
= Tcl_GetVar2 (gdbtk_interp
, "Paths", "libexecdir", TCL_GLOBAL_ONLY
);
374 h
= ide_event_init_from_environment (&errmsg
, libexecdir
);
375 make_final_cleanup (gdbtk_cleanup
, h
);
378 Tcl_AppendResult (gdbtk_interp
, "can't initialize event system: ", errmsg
,
380 fprintf(stderr
, "WARNING: ide_event_init_client failed: %s\n", gdbtk_interp
->result
);
382 Tcl_SetVar (gdbtk_interp
, "IDE_ENABLED", "0", 0);
386 if (ide_create_tclevent_command (gdbtk_interp
, h
) != TCL_OK
)
387 error ("ide_create_tclevent_command failed: %s", gdbtk_interp
->result
);
389 if (ide_create_edit_command (gdbtk_interp
, h
) != TCL_OK
)
390 error ("ide_create_edit_command failed: %s", gdbtk_interp
->result
);
392 if (ide_create_property_command (gdbtk_interp
, h
) != TCL_OK
)
393 error ("ide_create_property_command failed: %s", gdbtk_interp
->result
);
395 if (ide_create_build_command (gdbtk_interp
, h
) != TCL_OK
)
396 error ("ide_create_build_command failed: %s", gdbtk_interp
->result
);
398 if (ide_create_window_register_command (gdbtk_interp
, h
, "gdb-restore")
400 error ("ide_create_window_register_command failed: %s",
401 gdbtk_interp
->result
);
403 if (ide_create_window_command (gdbtk_interp
, h
) != TCL_OK
)
404 error ("ide_create_window_command failed: %s", gdbtk_interp
->result
);
406 if (ide_create_exit_command (gdbtk_interp
, h
) != TCL_OK
)
407 error ("ide_create_exit_command failed: %s", gdbtk_interp
->result
);
409 if (ide_create_help_command (gdbtk_interp
) != TCL_OK
)
410 error ("ide_create_help_command failed: %s", gdbtk_interp
->result
);
413 if (ide_initialize (gdbtk_interp, "gdb") != TCL_OK)
414 error ("ide_initialize failed: %s", gdbtk_interp->result);
417 Tcl_SetVar (gdbtk_interp
, "IDE_ENABLED", "1", 0);
419 /* end-sanitize-ide */
421 Tcl_SetVar (gdbtk_interp
, "IDE_ENABLED", "0", 0);
424 /* We don't want to open the X connection until we've done all the
425 IDE initialization. Otherwise, goofy looking unfinished windows
426 pop up when ILU drops into the TCL event loop. */
428 if (Tk_Init(gdbtk_interp
) != TCL_OK
)
429 error ("Tk_Init failed: %s", gdbtk_interp
->result
);
431 if (Itcl_Init(gdbtk_interp
) == TCL_ERROR
)
432 error ("Itcl_Init failed: %s", gdbtk_interp
->result
);
433 Tcl_StaticPackage(gdbtk_interp
, "Tktable", Tktable_Init
,
434 (Tcl_PackageInitProc
*) NULL
);
436 if (Tix_Init(gdbtk_interp
) != TCL_OK
)
437 error ("Tix_Init failed: %s", gdbtk_interp
->result
);
438 Tcl_StaticPackage(gdbtk_interp
, "Tktable", Tktable_Init
,
439 (Tcl_PackageInitProc
*) NULL
);
441 if (Tktable_Init(gdbtk_interp
) != TCL_OK
)
442 error ("Tktable_Init failed: %s", gdbtk_interp
->result
);
444 Tcl_StaticPackage(gdbtk_interp
, "Tktable", Tktable_Init
,
445 (Tcl_PackageInitProc
*) NULL
);
447 * These are the commands to do some Windows Specific stuff...
451 if (ide_create_messagebox_command (gdbtk_interp
) != TCL_OK
)
452 error ("messagebox command initialization failed");
453 /* On Windows, create a sizebox widget command */
454 if (ide_create_sizebox_command (gdbtk_interp
) != TCL_OK
)
455 error ("sizebox creation failed");
456 if (ide_create_winprint_command (gdbtk_interp
) != TCL_OK
)
457 error ("windows print code initialization failed");
458 /* start-sanitize-ide */
459 /* An interface to ShellExecute. */
460 if (ide_create_shell_execute_command (gdbtk_interp
) != TCL_OK
)
461 error ("shell execute command initialization failed");
462 /* end-sanitize-ide */
463 if (ide_create_win_grab_command (gdbtk_interp
) != TCL_OK
)
464 error ("grab support command initialization failed");
465 /* Path conversion functions. */
466 if (ide_create_cygwin_path_command (gdbtk_interp
) != TCL_OK
)
467 error ("cygwin path command initialization failed");
471 * This adds all the Gdbtk commands.
474 if (Gdbtk_Init(gdbtk_interp
) != TCL_OK
)
476 error("Gdbtk_Init failed: %s", gdbtk_interp
->result
);
479 Tcl_StaticPackage(gdbtk_interp
, "Gdbtk", Gdbtk_Init
, NULL
);
481 /* This adds all the hooks that call up from the bowels of gdb
482 * back into Tcl-land...
487 /* Add a back door to Tk from the gdb console... */
489 add_com ("tk", class_obscure
, tk_command
,
490 "Send a command directly into tk.");
492 Tcl_LinkVar (gdbtk_interp
, "disassemble-from-exec", (char *) &disassemble_from_exec
,
495 /* find the gdb tcl library and source main.tcl */
497 gdbtk_lib
= getenv ("GDBTK_LIBRARY");
500 if (access ("gdbtcl/main.tcl", R_OK
) == 0)
501 gdbtk_lib
= "gdbtcl";
503 gdbtk_lib
= GDBTK_LIBRARY
;
506 gdbtk_lib_tmp
= xstrdup (gdbtk_lib
);
509 /* see if GDBTK_LIBRARY is a path list */
510 lib
= strtok (gdbtk_lib_tmp
, GDBTK_PATH_SEP
);
512 auto_path_name
= Tcl_NewStringObj ("auto_path", -1);
516 auto_path_elem
= Tcl_NewStringObj (lib
, -1);
517 if (Tcl_ObjSetVar2 (gdbtk_interp
, auto_path_name
, NULL
, auto_path_elem
,
518 TCL_GLOBAL_ONLY
| TCL_APPEND_VALUE
| TCL_LIST_ELEMENT
) == NULL
)
520 fputs_unfiltered (Tcl_GetVar (gdbtk_interp
, "errorInfo", 0), gdb_stderr
);
525 gdbtk_file
= concat (lib
, "/main.tcl", (char *) NULL
);
526 if (access (gdbtk_file
, R_OK
) == 0)
529 Tcl_SetVar (gdbtk_interp
, "GDBTK_LIBRARY", lib
, 0);
533 while ((lib
= strtok (NULL
, ":")) != NULL
);
535 free (gdbtk_lib_tmp
);
536 Tcl_DecrRefCount(auto_path_name
);
540 /* Try finding it with the auto path. */
542 static const char script
[] ="\
543 proc gdbtk_find_main {} {\n\
544 global auto_path GDBTK_LIBRARY\n\
545 foreach dir $auto_path {\n\
546 set f [file join $dir main.tcl]\n\
547 if {[file exists $f]} then {\n\
548 set GDBTK_LIBRARY $dir\n\
556 if (Tcl_GlobalEval (gdbtk_interp
, (char *) script
) != TCL_OK
)
558 fputs_unfiltered (Tcl_GetVar (gdbtk_interp
, "errorInfo", 0), gdb_stderr
);
562 if (gdbtk_interp
->result
[0] != '\0')
564 gdbtk_file
= xstrdup (gdbtk_interp
->result
);
571 fputs_unfiltered_hook
= NULL
; /* Force errors to stdout/stderr */
572 if (getenv("GDBTK_LIBRARY"))
574 fprintf_unfiltered (stderr
, "Unable to find main.tcl in %s\n",getenv("GDBTK_LIBRARY"));
575 fprintf_unfiltered (stderr
,
576 "Please set GDBTK_LIBRARY to a path that includes the GDB tcl files.\n");
580 fprintf_unfiltered (stderr
, "Unable to find main.tcl in %s\n", GDBTK_LIBRARY
);
581 fprintf_unfiltered (stderr
, "You might want to set GDBTK_LIBRARY\n");
586 /* Defer setup of fputs_unfiltered_hook to near the end so that error messages
587 prior to this point go to stdout/stderr. */
589 fputs_unfiltered_hook
= gdbtk_fputs
;
591 /* start-sanitize-tclpro */
592 #ifdef TCLPRO_DEBUGGER
594 Tcl_DString source_cmd
;
596 Tcl_DStringInit (&source_cmd
);
597 Tcl_DStringAppend (&source_cmd
,
598 "if {[info exists env(DEBUG_STUB)]} {source $env(DEBUG_STUB); " -1);
599 Tcl_DStringAppend (&source_cmd
, "debugger_init; debugger_eval {source {", -1);
600 Tcl_DStringAppend (&source_cmd
, gdbtk_file
, -1);
601 Tcl_DStringAppend (&source_cmd
, "}}} else {source {", -1);
602 Tcl_DStringAppend (&source_cmd
, gdbtk_file
, -1);
603 Tcl_DStringAppend (&source_cmd
, "}}", -1);
604 if (Tcl_GlobalEval (gdbtk_interp
, Tcl_DStringValue (&source_cmd
)) != TCL_OK
)
606 /* end-sanitize-tclpro */
607 if (Tcl_EvalFile (gdbtk_interp
, gdbtk_file
) != TCL_OK
)
608 /* start-sanitize-tclpro */
610 /* end-sanitize-tclpro */
614 /* Force errorInfo to be set up propertly. */
615 Tcl_AddErrorInfo (gdbtk_interp
, "");
617 msg
= Tcl_GetVar (gdbtk_interp
, "errorInfo", TCL_GLOBAL_ONLY
);
619 fputs_unfiltered_hook
= NULL
; /* Force errors to stdout/stderr */
622 MessageBox (NULL
, msg
, NULL
, MB_OK
| MB_ICONERROR
| MB_TASKMODAL
);
624 fputs_unfiltered (msg
, gdb_stderr
);
629 /* start-sanitize-tclpro */
630 #ifdef TCLPRO_DEBUGGER
631 Tcl_DStringFree(&source_cmd
);
634 /* end-sanitize-tclpro */
637 /* start-sanitize-ide */
638 /* Don't do this until we have initialized. Otherwise, we may get a
639 run command before we are ready for one. */
640 if (ide_run_server_init (gdbtk_interp
, h
) != TCL_OK
)
641 error ("ide_run_server_init failed: %s", gdbtk_interp
->result
);
642 /* end-sanitize-ide */
647 /* Now source in the filename provided by the --tclcommand option.
648 This is mostly used for the gdbtk testsuite... */
650 if (gdbtk_source_filename
!= NULL
)
652 char *s
= "after idle source ";
653 char *script
= concat (s
, gdbtk_source_filename
, (char *) NULL
);
654 Tcl_Eval (gdbtk_interp
, script
);
655 free (gdbtk_source_filename
);
660 discard_cleanups (old_chain
);
663 /* gdbtk_test is used in main.c to validate the -tclcommand option to
664 gdb, which sources in a file of tcl code after idle during the
665 startup procedure. */
668 gdbtk_test (filename
)
671 if (access (filename
, R_OK
) != 0)
674 gdbtk_source_filename
= xstrdup (filename
);
678 /* Come here during initialize_all_files () */
685 /* Tell the rest of the world that Gdbtk is now set up. */
687 init_ui_hook
= gdbtk_init
;
689 (void) FreeConsole ();
695 DWORD ft
= GetFileType (GetStdHandle (STD_INPUT_HANDLE
));
696 void cygwin32_attach_handle_to_fd (char *, int, HANDLE
, int, int);
706 cygwin32_attach_handle_to_fd ("/dev/conin", 0,
707 GetStdHandle (STD_INPUT_HANDLE
),
709 cygwin32_attach_handle_to_fd ("/dev/conout", 1,
710 GetStdHandle (STD_OUTPUT_HANDLE
),
712 cygwin32_attach_handle_to_fd ("/dev/conout", 2,
713 GetStdHandle (STD_ERROR_HANDLE
),
722 tk_command (cmd
, from_tty
)
728 struct cleanup
*old_chain
;
730 /* Catch case of no argument, since this will make the tcl interpreter dump core. */
732 error_no_arg ("tcl command to interpret");
734 retval
= Tcl_Eval (gdbtk_interp
, cmd
);
736 result
= strdup (gdbtk_interp
->result
);
738 old_chain
= make_cleanup (free
, result
);
740 if (retval
!= TCL_OK
)
743 printf_unfiltered ("%s\n", result
);
745 do_cleanups (old_chain
);
This page took 0.044469 seconds and 4 git commands to generate.