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 /* start-sanitize-ide */
53 /* end-sanitize-ide */
55 #ifdef ANSI_PROTOTYPES
65 #include <sys/ioctl.h>
66 #include "gdb_string.h"
75 #include <sys/cygwin.h> /* for cygwin32_attach_handle_to_fd */
78 /* For Cygwin, we use a timer to periodically check for Windows
79 messages. FIXME: It would be better to not poll, but to instead
80 rewrite the target_wait routines to serve as input sources.
81 Unfortunately, that will be a lot of work. */
82 static sigset_t nullsigmask
;
83 static struct sigaction act1
, act2
;
84 static struct itimerval it_on
, it_off
;
87 * These two variables control the interaction with an external editor.
88 * If enable_external_editor is set at startup, BEFORE Gdbtk_Init is run
89 * then the Tcl variable of the same name will be set, and a command will
90 * called external_editor_command will be invoked to call out to the
91 * external editor. We give a dummy version here to warn if it is not set.
93 int enable_external_editor
= 0;
94 char * external_editor_command
= "tk_dialog .warn-external \\\n\
95 \"No command is specified.\nUse --tclcommand <tcl/file> or --external-editor <cmd> to specify a new command\" 0 Ok";
97 extern int Tktable_Init
PARAMS ((Tcl_Interp
*interp
));
99 static void gdbtk_init
PARAMS ((char *));
100 void gdbtk_interactive
PARAMS ((void));
101 static void cleanup_init
PARAMS ((int));
102 static void tk_command
PARAMS ((char *, int));
104 void gdbtk_add_hooks
PARAMS ((void));
105 int gdbtk_test
PARAMS ((char *));
108 * gdbtk_fputs is defined in the gdbtk_hooks.c, but we need it here
109 * because we delay adding this hook till all the setup is done. That
110 * way errors will go to stdout.
113 extern void gdbtk_fputs
PARAMS ((const char *, GDB_FILE
*));
115 /* Handle for TCL interpreter */
116 Tcl_Interp
*gdbtk_interp
= NULL
;
118 static int gdbtk_timer_going
= 0;
120 /* linked variable used to tell tcl what the current thread is */
123 /* This variable is true when the inferior is running. See note in
124 * gdbtk.h for details.
128 /* This variable holds the name of a Tcl file which should be sourced by the
129 interpreter when it goes idle at startup. Used with the testsuite. */
130 static char *gdbtk_source_filename
= NULL
;
134 /* Supply malloc calls for tcl/tk. We do not want to do this on
135 Windows, because Tcl_Alloc is probably in a DLL which will not call
136 the mmalloc routines. */
142 return xmalloc (size
);
146 Tcl_Realloc (ptr
, size
)
150 return xrealloc (ptr
, size
);
160 #endif /* ! _WIN32 */
164 /* On Windows, if we hold a file open, other programs can't write to
165 * it. In particular, we don't want to hold the executable open,
166 * because it will mean that people have to get out of the debugging
167 * session in order to remake their program. So we close it, although
168 * this will cost us if and when we need to reopen it.
179 bfd_cache_close (o
->obfd
);
182 if (exec_bfd
!= NULL
)
183 bfd_cache_close (exec_bfd
);
189 /* TclDebug (const char *fmt, ...) works just like printf() but
190 * sends the output to the GDB TK debug window.
191 * Not for normal use; just a convenient tool for debugging
195 #ifdef ANSI_PROTOTYPES
196 TclDebug (const char *fmt
, ...)
203 char buf
[512], *v
[2], *merge
;
205 #ifdef ANSI_PROTOTYPES
206 va_start (args
, fmt
);
210 fmt
= va_arg (args
, char *);
216 vsprintf (buf
, fmt
, args
);
219 merge
= Tcl_Merge (2, v
);
220 Tcl_Eval (gdbtk_interp
, merge
);
226 * The rest of this file contains the start-up, and event handling code for gdbtk.
230 * This cleanup function is added to the cleanup list that surrounds the Tk
231 * main in gdbtk_init. It deletes the Tcl interpreter.
235 cleanup_init (ignored
)
238 if (gdbtk_interp
!= NULL
)
239 Tcl_DeleteInterp (gdbtk_interp
);
243 /* Come here during long calculations to check for GUI events. Usually invoked
244 via the QUIT macro. */
249 /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */
256 static int first
= 1;
257 /*TclDebug ("Starting timer....");*/
260 /* first time called, set up all the structs */
262 sigemptyset (&nullsigmask
);
264 act1
.sa_handler
= x_event
;
265 act1
.sa_mask
= nullsigmask
;
268 act2
.sa_handler
= SIG_IGN
;
269 act2
.sa_mask
= nullsigmask
;
272 it_on
.it_interval
.tv_sec
= 0;
273 it_on
.it_interval
.tv_usec
= 250000; /* .25 sec */
274 it_on
.it_value
.tv_sec
= 0;
275 it_on
.it_value
.tv_usec
= 250000;
277 it_off
.it_interval
.tv_sec
= 0;
278 it_off
.it_interval
.tv_usec
= 0;
279 it_off
.it_value
.tv_sec
= 0;
280 it_off
.it_value
.tv_usec
= 0;
283 if (!gdbtk_timer_going
)
285 sigaction (SIGALRM
, &act1
, NULL
);
286 setitimer (ITIMER_REAL
, &it_on
, NULL
);
287 gdbtk_timer_going
= 1;
294 if (gdbtk_timer_going
)
296 gdbtk_timer_going
= 0;
297 /*TclDebug ("Stopping timer.");*/
298 setitimer (ITIMER_REAL
, &it_off
, NULL
);
299 sigaction (SIGALRM
, &act2
, NULL
);
303 /* gdbtk_init installs this function as a final cleanup. */
306 gdbtk_cleanup (dummy
)
309 Tcl_Eval (gdbtk_interp
, "gdbtk_cleanup");
312 struct ide_event_handle
*h
= (struct ide_event_handle
*) dummy
;
313 ide_interface_deregister_all (h
);
319 /* Initialize gdbtk. This involves creating a Tcl interpreter,
320 * defining all the Tcl commands that the GUI will use, pointing
321 * all the gdb "hooks" to the correct functions,
322 * and setting the Tcl auto loading environment so that we can find all
323 * the Tcl based library files.
330 struct cleanup
*old_chain
;
333 Tcl_Obj
*auto_path_elem
, *auto_path_name
;
335 /* start-sanitize-ide */
337 struct ide_event_handle
*h
;
341 /* end-sanitize-ide */
343 /* If there is no DISPLAY environment variable, Tk_Init below will fail,
344 causing gdb to abort. If instead we simply return here, gdb will
345 gracefully degrade to using the command line interface. */
348 if (getenv ("DISPLAY") == NULL
)
352 old_chain
= make_cleanup ((make_cleanup_func
) cleanup_init
, 0);
354 /* First init tcl and tk. */
355 Tcl_FindExecutable (argv0
);
356 gdbtk_interp
= Tcl_CreateInterp ();
359 Tcl_InitMemory (gdbtk_interp
);
363 error ("Tcl_CreateInterp failed");
365 if (Tcl_Init(gdbtk_interp
) != TCL_OK
)
366 error ("Tcl_Init failed: %s", gdbtk_interp
->result
);
368 /* Set up some globals used by gdb to pass info to gdbtk
369 for start up options and the like */
370 sprintf (s
, "%d", inhibit_gdbinit
);
371 Tcl_SetVar2 (gdbtk_interp
, "GDBStartup", "inhibit_prefs", s
, TCL_GLOBAL_ONLY
);
373 /* start-sanitize-ide */
375 /* end-sanitize-ide */
376 /* For the IDE we register the cleanup later, after we've
377 initialized events. */
378 make_final_cleanup (gdbtk_cleanup
, NULL
);
379 /* start-sanitize-ide */
381 /* end-sanitize-ide */
383 /* Initialize the Paths variable. */
384 if (ide_initialize_paths (gdbtk_interp
, "") != TCL_OK
)
385 error ("ide_initialize_paths failed: %s", gdbtk_interp
->result
);
387 /* start-sanitize-ide */
389 /* Find the directory where we expect to find idemanager. We ignore
390 errors since it doesn't really matter if this fails. */
391 libexecdir
= Tcl_GetVar2 (gdbtk_interp
, "Paths", "libexecdir", TCL_GLOBAL_ONLY
);
395 h
= ide_event_init_from_environment (&errmsg
, libexecdir
);
396 make_final_cleanup (gdbtk_cleanup
, h
);
399 Tcl_AppendResult (gdbtk_interp
, "can't initialize event system: ", errmsg
,
401 fprintf(stderr
, "WARNING: ide_event_init_client failed: %s\n", gdbtk_interp
->result
);
403 Tcl_SetVar (gdbtk_interp
, "IDE_ENABLED", "0", 0);
407 if (ide_create_tclevent_command (gdbtk_interp
, h
) != TCL_OK
)
408 error ("ide_create_tclevent_command failed: %s", gdbtk_interp
->result
);
410 if (ide_create_edit_command (gdbtk_interp
, h
) != TCL_OK
)
411 error ("ide_create_edit_command failed: %s", gdbtk_interp
->result
);
413 if (ide_create_property_command (gdbtk_interp
, h
) != TCL_OK
)
414 error ("ide_create_property_command failed: %s", gdbtk_interp
->result
);
416 if (ide_create_build_command (gdbtk_interp
, h
) != TCL_OK
)
417 error ("ide_create_build_command failed: %s", gdbtk_interp
->result
);
419 if (ide_create_window_register_command (gdbtk_interp
, h
, "gdb-restore")
421 error ("ide_create_window_register_command failed: %s",
422 gdbtk_interp
->result
);
424 if (ide_create_window_command (gdbtk_interp
, h
) != TCL_OK
)
425 error ("ide_create_window_command failed: %s", gdbtk_interp
->result
);
427 if (ide_create_exit_command (gdbtk_interp
, h
) != TCL_OK
)
428 error ("ide_create_exit_command failed: %s", gdbtk_interp
->result
);
430 if (ide_create_help_command (gdbtk_interp
) != TCL_OK
)
431 error ("ide_create_help_command failed: %s", gdbtk_interp
->result
);
434 if (ide_initialize (gdbtk_interp, "gdb") != TCL_OK)
435 error ("ide_initialize failed: %s", gdbtk_interp->result);
438 Tcl_SetVar (gdbtk_interp
, "IDE_ENABLED", "1", 0);
441 /* end-sanitize-ide */
442 Tcl_SetVar (gdbtk_interp
, "IDE_ENABLED", "0", 0);
443 /* start-sanitize-ide */
445 /* end-sanitize-ide */
447 /* We don't want to open the X connection until we've done all the
448 IDE initialization. Otherwise, goofy looking unfinished windows
449 pop up when ILU drops into the TCL event loop. */
451 if (Tk_Init(gdbtk_interp
) != TCL_OK
)
452 error ("Tk_Init failed: %s", gdbtk_interp
->result
);
454 if (Itcl_Init(gdbtk_interp
) == TCL_ERROR
)
455 error ("Itcl_Init failed: %s", gdbtk_interp
->result
);
456 Tcl_StaticPackage(gdbtk_interp
, "Itcl", Itcl_Init
,
457 (Tcl_PackageInitProc
*) NULL
);
459 if (Itk_Init(gdbtk_interp
) == TCL_ERROR
)
460 error ("Itk_Init failed: %s", gdbtk_interp
->result
);
461 Tcl_StaticPackage(gdbtk_interp
, "Itk", Itk_Init
,
462 (Tcl_PackageInitProc
*) NULL
);
464 if (Tix_Init(gdbtk_interp
) != TCL_OK
)
465 error ("Tix_Init failed: %s", gdbtk_interp
->result
);
466 Tcl_StaticPackage(gdbtk_interp
, "Tix", Tix_Init
,
467 (Tcl_PackageInitProc
*) NULL
);
469 if (Tktable_Init(gdbtk_interp
) != TCL_OK
)
470 error ("Tktable_Init failed: %s", gdbtk_interp
->result
);
472 Tcl_StaticPackage(gdbtk_interp
, "Tktable", Tktable_Init
,
473 (Tcl_PackageInitProc
*) NULL
);
475 * These are the commands to do some Windows Specific stuff...
479 if (ide_create_messagebox_command (gdbtk_interp
) != TCL_OK
)
480 error ("messagebox command initialization failed");
481 /* On Windows, create a sizebox widget command */
482 if (ide_create_sizebox_command (gdbtk_interp
) != TCL_OK
)
483 error ("sizebox creation failed");
484 if (ide_create_winprint_command (gdbtk_interp
) != TCL_OK
)
485 error ("windows print code initialization failed");
486 /* start-sanitize-ide */
487 /* An interface to ShellExecute. */
488 if (ide_create_shell_execute_command (gdbtk_interp
) != TCL_OK
)
489 error ("shell execute command initialization failed");
490 /* end-sanitize-ide */
491 if (ide_create_win_grab_command (gdbtk_interp
) != TCL_OK
)
492 error ("grab support command initialization failed");
493 /* Path conversion functions. */
494 if (ide_create_cygwin_path_command (gdbtk_interp
) != TCL_OK
)
495 error ("cygwin path command initialization failed");
497 /* for now, this testing function is Unix only */
498 if (cyg_create_warp_pointer_command (gdbtk_interp
) != TCL_OK
)
499 error ("warp_pointer command initialization failed");
503 * This adds all the Gdbtk commands.
506 if (Gdbtk_Init(gdbtk_interp
) != TCL_OK
)
508 error("Gdbtk_Init failed: %s", gdbtk_interp
->result
);
511 Tcl_StaticPackage(gdbtk_interp
, "Gdbtk", Gdbtk_Init
, NULL
);
513 /* This adds all the hooks that call up from the bowels of gdb
514 * back into Tcl-land...
519 /* Add a back door to Tk from the gdb console... */
521 add_com ("tk", class_obscure
, tk_command
,
522 "Send a command directly into tk.");
525 * Set the variables for external editor:
528 Tcl_SetVar (gdbtk_interp
, "enable_external_editor", enable_external_editor
? "1" : "0", 0);
529 Tcl_SetVar (gdbtk_interp
, "external_editor_command", external_editor_command
, 0);
531 /* find the gdb tcl library and source main.tcl */
534 #ifdef NO_TCLPRO_DEBUGGER
535 static const char script
[] ="\
536 proc gdbtk_find_main {} {\n\
537 global Paths GDBTK_LIBRARY\n\
538 rename gdbtk_find_main {}\n\
539 tcl_findLibrary gdb 1.0 {} main.tcl GDBTK_LIBRARY GDBTK_LIBRARY gdbtcl2 gdbtcl {}\n\
540 set Paths(appdir) $GDBTK_LIBRARY\n\
544 static const char script
[] ="\
545 proc gdbtk_find_main {} {\n\
546 global Paths GDBTK_LIBRARY env\n\
547 rename gdbtk_find_main {}\n\
548 if {[info exists env(DEBUG_STUB)]} {\n\
549 source $env(DEBUG_STUB)\n\
551 set debug_startup 1\n\
553 set debug_startup 0\n\
555 tcl_findLibrary gdb 1.0 {} main.tcl GDBTK_LIBRARY GDBTK_LIBRARY gdbtcl2 gdbtcl {} $debug_startup\n\
556 set Paths(appdir) $GDBTK_LIBRARY\n\
559 #endif /* NO_TCLPRO_DEBUGGER */
561 fputs_unfiltered_hook
= NULL
; /* Force errors to stdout/stderr */
564 * Set the variables for external editor, do this before eval'ing main.tcl
565 * since the value is used there...
568 Tcl_SetVar (gdbtk_interp
, "enable_external_editor",
569 enable_external_editor
? "1" : "0", 0);
570 Tcl_SetVar (gdbtk_interp
, "external_editor_command",
571 external_editor_command
, 0);
573 if (Tcl_GlobalEval (gdbtk_interp
, (char *) script
) != TCL_OK
)
577 /* Force errorInfo to be set up propertly. */
578 Tcl_AddErrorInfo (gdbtk_interp
, "");
580 msg
= Tcl_GetVar (gdbtk_interp
, "errorInfo", TCL_GLOBAL_ONLY
);
582 fputs_unfiltered_hook
= NULL
; /* Force errors to stdout/stderr */
585 MessageBox (NULL
, msg
, NULL
, MB_OK
| MB_ICONERROR
| MB_TASKMODAL
);
587 fputs_unfiltered (msg
, gdb_stderr
);
595 /* Defer setup of fputs_unfiltered_hook to near the end so that error messages
596 prior to this point go to stdout/stderr. */
598 fputs_unfiltered_hook
= gdbtk_fputs
;
600 /* start-sanitize-ide */
602 /* Don't do this until we have initialized. Otherwise, we may get a
603 run command before we are ready for one. */
604 if (ide_run_server_init (gdbtk_interp
, h
) != TCL_OK
)
605 error ("ide_run_server_init failed: %s", gdbtk_interp
->result
);
607 /* end-sanitize-ide */
609 /* Now source in the filename provided by the --tclcommand option.
610 This is mostly used for the gdbtk testsuite... */
612 if (gdbtk_source_filename
!= NULL
)
614 char *s
= "after idle source ";
615 char *script
= concat (s
, gdbtk_source_filename
, (char *) NULL
);
616 Tcl_Eval (gdbtk_interp
, script
);
617 free (gdbtk_source_filename
);
622 discard_cleanups (old_chain
);
625 /* gdbtk_test is used in main.c to validate the -tclcommand option to
626 gdb, which sources in a file of tcl code after idle during the
627 startup procedure. */
630 gdbtk_test (filename
)
633 if (access (filename
, R_OK
) != 0)
636 gdbtk_source_filename
= xstrdup (filename
);
640 /* Come here during initialize_all_files () */
647 /* Tell the rest of the world that Gdbtk is now set up. */
649 init_ui_hook
= gdbtk_init
;
651 (void) FreeConsole ();
657 DWORD ft
= GetFileType (GetStdHandle (STD_INPUT_HANDLE
));
667 cygwin32_attach_handle_to_fd ("/dev/conin", 0,
668 GetStdHandle (STD_INPUT_HANDLE
),
670 cygwin32_attach_handle_to_fd ("/dev/conout", 1,
671 GetStdHandle (STD_OUTPUT_HANDLE
),
673 cygwin32_attach_handle_to_fd ("/dev/conout", 2,
674 GetStdHandle (STD_ERROR_HANDLE
),
683 tk_command (cmd
, from_tty
)
689 struct cleanup
*old_chain
;
691 /* Catch case of no argument, since this will make the tcl interpreter dump core. */
693 error_no_arg ("tcl command to interpret");
695 retval
= Tcl_Eval (gdbtk_interp
, cmd
);
697 result
= strdup (gdbtk_interp
->result
);
699 old_chain
= make_cleanup (free
, result
);
701 if (retval
!= TCL_OK
)
704 printf_unfiltered ("%s\n", result
);
706 do_cleanups (old_chain
);
709 /* Local variables: */
710 /* change-log-default-name: "ChangeLog-gdbtk" */
This page took 0.043534 seconds and 4 git commands to generate.