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 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));
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 */
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 #ifdef ANSI_PROTOTYPES
192 TclDebug (const char *fmt
, ...)
199 char buf
[512], *v
[2], *merge
;
201 #ifdef ANSI_PROTOTYPES
202 va_start (args
, fmt
);
206 fmt
= va_arg (args
, char *);
212 vsprintf (buf
, fmt
, args
);
215 merge
= Tcl_Merge (2, v
);
216 Tcl_Eval (gdbtk_interp
, merge
);
222 * The rest of this file contains the start-up, and event handling code for gdbtk.
226 * This cleanup function is added to the cleanup list that surrounds the Tk
227 * main in gdbtk_init. It deletes the Tcl interpreter.
231 cleanup_init (ignored
)
234 if (gdbtk_interp
!= NULL
)
235 Tcl_DeleteInterp (gdbtk_interp
);
239 /* Come here during long calculations to check for GUI events. Usually invoked
240 via the QUIT macro. */
245 /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */
252 static int first
= 1;
253 /*TclDebug ("Starting timer....");*/
256 /* first time called, set up all the structs */
258 sigemptyset (&nullsigmask
);
260 act1
.sa_handler
= x_event
;
261 act1
.sa_mask
= nullsigmask
;
264 act2
.sa_handler
= SIG_IGN
;
265 act2
.sa_mask
= nullsigmask
;
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;
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;
279 if (!gdbtk_timer_going
)
281 sigaction (SIGALRM
, &act1
, NULL
);
282 setitimer (ITIMER_REAL
, &it_on
, NULL
);
283 gdbtk_timer_going
= 1;
290 if (gdbtk_timer_going
)
292 gdbtk_timer_going
= 0;
293 /*TclDebug ("Stopping timer.");*/
294 setitimer (ITIMER_REAL
, &it_off
, NULL
);
295 sigaction (SIGALRM
, &act2
, NULL
);
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.
306 gdbtk_call_command (cmdblk
, arg
, from_tty
)
307 struct cmd_list_element
*cmdblk
;
312 if (cmdblk
->class == class_run
|| cmdblk
->class == class_trace
)
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.*/
322 if (!strcmp(cmdblk
->name
, "tstart") && !No_Update
)
324 Tcl_Eval (gdbtk_interp
, "gdbtk_tcl_tstart");
325 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
327 else if (!strcmp(cmdblk
->name
, "tstop") && !No_Update
)
329 Tcl_Eval (gdbtk_interp
, "gdbtk_tcl_tstop");
330 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
337 Tcl_Eval (gdbtk_interp
, "gdbtk_tcl_busy");
338 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
341 Tcl_Eval (gdbtk_interp
, "gdbtk_tcl_idle");
345 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
348 /* gdbtk_init installs this function as a final cleanup. */
351 gdbtk_cleanup (dummy
)
354 Tcl_Eval (gdbtk_interp
, "gdbtk_cleanup");
356 struct ide_event_handle
*h
= (struct ide_event_handle
*) dummy
;
357 ide_interface_deregister_all (h
);
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.
373 struct cleanup
*old_chain
;
374 char *lib
, *gdbtk_lib
, *gdbtk_lib_tmp
, *gdbtk_file
;
376 Tcl_Obj
*auto_path_elem
, *auto_path_name
;
378 struct sigaction action
;
379 static sigset_t nullsigmask
= {0};
382 /* start-sanitize-ide */
383 struct ide_event_handle
*h
;
386 /* end-sanitize-ide */
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. */
394 if (getenv ("DISPLAY") == NULL
)
398 old_chain
= make_cleanup (cleanup_init
, 0);
400 /* First init tcl and tk. */
401 Tcl_FindExecutable (argv0
);
402 gdbtk_interp
= Tcl_CreateInterp ();
405 Tcl_InitMemory (gdbtk_interp
);
409 error ("Tcl_CreateInterp failed");
411 if (Tcl_Init(gdbtk_interp
) != TCL_OK
)
412 error ("Tcl_Init failed: %s", gdbtk_interp
->result
);
415 /* For the IDE we register the cleanup later, after we've
416 initialized events. */
417 make_final_cleanup (gdbtk_cleanup
, NULL
);
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
);
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
);
432 h
= ide_event_init_from_environment (&errmsg
, libexecdir
);
433 make_final_cleanup (gdbtk_cleanup
, h
);
436 Tcl_AppendResult (gdbtk_interp
, "can't initialize event system: ", errmsg
,
438 fprintf(stderr
, "WARNING: ide_event_init_client failed: %s\n", gdbtk_interp
->result
);
440 Tcl_SetVar (gdbtk_interp
, "IDE_ENABLED", "0", 0);
444 if (ide_create_tclevent_command (gdbtk_interp
, h
) != TCL_OK
)
445 error ("ide_create_tclevent_command failed: %s", gdbtk_interp
->result
);
447 if (ide_create_edit_command (gdbtk_interp
, h
) != TCL_OK
)
448 error ("ide_create_edit_command failed: %s", gdbtk_interp
->result
);
450 if (ide_create_property_command (gdbtk_interp
, h
) != TCL_OK
)
451 error ("ide_create_property_command failed: %s", gdbtk_interp
->result
);
453 if (ide_create_build_command (gdbtk_interp
, h
) != TCL_OK
)
454 error ("ide_create_build_command failed: %s", gdbtk_interp
->result
);
456 if (ide_create_window_register_command (gdbtk_interp
, h
, "gdb-restore")
458 error ("ide_create_window_register_command failed: %s",
459 gdbtk_interp
->result
);
461 if (ide_create_window_command (gdbtk_interp
, h
) != TCL_OK
)
462 error ("ide_create_window_command failed: %s", gdbtk_interp
->result
);
464 if (ide_create_exit_command (gdbtk_interp
, h
) != TCL_OK
)
465 error ("ide_create_exit_command failed: %s", gdbtk_interp
->result
);
467 if (ide_create_help_command (gdbtk_interp
) != TCL_OK
)
468 error ("ide_create_help_command failed: %s", gdbtk_interp
->result
);
471 if (ide_initialize (gdbtk_interp, "gdb") != TCL_OK)
472 error ("ide_initialize failed: %s", gdbtk_interp->result);
475 Tcl_SetVar (gdbtk_interp
, "IDE_ENABLED", "1", 0);
477 /* end-sanitize-ide */
479 Tcl_SetVar (gdbtk_interp
, "IDE_ENABLED", "0", 0);
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. */
486 if (Tk_Init(gdbtk_interp
) != TCL_OK
)
487 error ("Tk_Init failed: %s", gdbtk_interp
->result
);
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
);
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
);
499 if (Tktable_Init(gdbtk_interp
) != TCL_OK
)
500 error ("Tktable_Init failed: %s", gdbtk_interp
->result
);
502 Tcl_StaticPackage(gdbtk_interp
, "Tktable", Tktable_Init
,
503 (Tcl_PackageInitProc
*) NULL
);
505 * These are the commands to do some Windows Specific stuff...
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");
529 * This adds all the Gdbtk commands.
532 if (Gdbtk_Init(gdbtk_interp
) != TCL_OK
)
534 error("Gdbtk_Init failed: %s", gdbtk_interp
->result
);
537 Tcl_StaticPackage(gdbtk_interp
, "Gdbtk", Gdbtk_Init
, NULL
);
539 /* This adds all the hooks that call up from the bowels of gdb
540 * back into Tcl-land...
545 /* Add a back door to Tk from the gdb console... */
547 add_com ("tk", class_obscure
, tk_command
,
548 "Send a command directly into tk.");
550 Tcl_LinkVar (gdbtk_interp
, "disassemble-from-exec", (char *) &disassemble_from_exec
,
553 /* find the gdb tcl library and source main.tcl */
555 gdbtk_lib
= getenv ("GDBTK_LIBRARY");
557 if (access ("gdbtcl/main.tcl", R_OK
) == 0)
558 gdbtk_lib
= "gdbtcl";
560 gdbtk_lib
= GDBTK_LIBRARY
;
562 gdbtk_lib_tmp
= xstrdup (gdbtk_lib
);
565 /* see if GDBTK_LIBRARY is a path list */
566 lib
= strtok (gdbtk_lib_tmp
, GDBTK_PATH_SEP
);
568 auto_path_name
= Tcl_NewStringObj ("auto_path", -1);
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
)
576 fputs_unfiltered (Tcl_GetVar (gdbtk_interp
, "errorInfo", 0), gdb_stderr
);
581 gdbtk_file
= concat (lib
, "/main.tcl", (char *) NULL
);
582 if (access (gdbtk_file
, R_OK
) == 0)
585 Tcl_SetVar (gdbtk_interp
, "GDBTK_LIBRARY", lib
, 0);
589 while ((lib
= strtok (NULL
, ":")) != NULL
);
591 free (gdbtk_lib_tmp
);
592 Tcl_DecrRefCount(auto_path_name
);
596 /* Try finding it with the auto path. */
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\
612 if (Tcl_GlobalEval (gdbtk_interp
, (char *) script
) != TCL_OK
)
614 fputs_unfiltered (Tcl_GetVar (gdbtk_interp
, "errorInfo", 0), gdb_stderr
);
618 if (gdbtk_interp
->result
[0] != '\0')
620 gdbtk_file
= xstrdup (gdbtk_interp
->result
);
627 fputs_unfiltered_hook
= NULL
; /* Force errors to stdout/stderr */
628 if (getenv("GDBTK_LIBRARY"))
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");
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");
642 /* Defer setup of fputs_unfiltered_hook to near the end so that error messages
643 prior to this point go to stdout/stderr. */
645 fputs_unfiltered_hook
= gdbtk_fputs
;
647 /* start-sanitize-tclpro */
648 #ifdef TCLPRO_DEBUGGER
650 Tcl_DString source_cmd
;
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
)
662 /* end-sanitize-tclpro */
663 if (Tcl_EvalFile (gdbtk_interp
, gdbtk_file
) != TCL_OK
)
664 /* start-sanitize-tclpro */
666 /* end-sanitize-tclpro */
670 /* Force errorInfo to be set up propertly. */
671 Tcl_AddErrorInfo (gdbtk_interp
, "");
673 msg
= Tcl_GetVar (gdbtk_interp
, "errorInfo", TCL_GLOBAL_ONLY
);
675 fputs_unfiltered_hook
= NULL
; /* Force errors to stdout/stderr */
678 MessageBox (NULL
, msg
, NULL
, MB_OK
| MB_ICONERROR
| MB_TASKMODAL
);
680 fputs_unfiltered (msg
, gdb_stderr
);
685 /* start-sanitize-tclpro */
686 #ifdef TCLPRO_DEBUGGER
687 Tcl_DStringFree(&source_cmd
);
690 /* end-sanitize-tclpro */
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 */
703 /* Now source in the filename provided by the --tclcommand option.
704 This is mostly used for the gdbtk testsuite... */
706 if (gdbtk_source_filename
!= NULL
)
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
);
716 discard_cleanups (old_chain
);
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. */
724 gdbtk_test (filename
)
727 if (access (filename
, R_OK
) != 0)
730 gdbtk_source_filename
= xstrdup (filename
);
734 /* Come here during initialize_all_files () */
741 /* Tell the rest of the world that Gdbtk is now set up. */
743 init_ui_hook
= gdbtk_init
;
745 (void) FreeConsole ();
751 DWORD ft
= GetFileType (GetStdHandle (STD_INPUT_HANDLE
));
752 void cygwin32_attach_handle_to_fd (char *, int, HANDLE
, int, int);
762 cygwin32_attach_handle_to_fd ("/dev/conin", 0,
763 GetStdHandle (STD_INPUT_HANDLE
),
765 cygwin32_attach_handle_to_fd ("/dev/conout", 1,
766 GetStdHandle (STD_OUTPUT_HANDLE
),
768 cygwin32_attach_handle_to_fd ("/dev/conout", 2,
769 GetStdHandle (STD_ERROR_HANDLE
),
778 tk_command (cmd
, from_tty
)
784 struct cleanup
*old_chain
;
786 /* Catch case of no argument, since this will make the tcl interpreter dump core. */
788 error_no_arg ("tcl command to interpret");
790 retval
= Tcl_Eval (gdbtk_interp
, cmd
);
792 result
= strdup (gdbtk_interp
->result
);
794 old_chain
= make_cleanup (free
, result
);
796 if (retval
!= TCL_OK
)
799 printf_unfiltered ("%s\n", result
);
801 do_cleanups (old_chain
);
This page took 0.045034 seconds and 4 git commands to generate.