You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
336 lines
9.7 KiB
Tcl
336 lines
9.7 KiB
Tcl
# Local preferences functions for Insight.
|
|
# Copyright (C) 2000, 2001, 2002, 2004, 2008 Red Hat, Inc.
|
|
#
|
|
# This program is free software; you can redistribute it and/or modify it
|
|
# under the terms of the GNU General Public License (GPL) as published by
|
|
# the Free Software Foundation; either version 2 of the License, or (at
|
|
# your option) any later version.
|
|
#
|
|
# This program is distributed in the hope that it will be useful,
|
|
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
# GNU General Public License for more details.
|
|
|
|
namespace eval Session {
|
|
namespace export save load notice_file_change delete list_names
|
|
|
|
# An internal function for canonicalizing path names. This probably
|
|
# should use `realpath', but that is more work. So for now we neglect
|
|
# the possibility of symlinks.
|
|
proc _exe_name {path} {
|
|
|
|
# Get real directory.
|
|
if {[string compare $::gdbtk_platform(os) "cygwin"] == 0} {
|
|
set path [ide_cygwin_path to_win32 $path]
|
|
}
|
|
set save [pwd]
|
|
cd [file dirname $path]
|
|
set dir [pwd]
|
|
cd $save
|
|
return [file join $dir [file tail $path]]
|
|
}
|
|
|
|
# An internal function used when saving sessions. Returns a string
|
|
# that can be used to recreate all pertinent breakpoint state.
|
|
proc _serialize_bps {} {
|
|
set result {}
|
|
|
|
# HACK. When debugging gdb with itself in the build
|
|
# directory, there is a ".gdbinit" file that will set
|
|
# breakpoints on internal_error() and info_command().
|
|
# If we then save and set them, they will accumulate.
|
|
# Possible fixes are to modify GDB so we can tell which
|
|
# breakpoints were set from .gdbinit, or modify
|
|
# _recreate_bps to record which breakpoints were
|
|
# set before it was called. For now, we simply detect the
|
|
# most common case and fix it.
|
|
set basename [string tolower [file tail $::gdb_exe_name]]
|
|
if {[string match "gdb*" $basename]
|
|
|| [string match "insight*" $basename]} {
|
|
set debugging_gdb 1
|
|
} else {
|
|
set debugging_gdb 0
|
|
}
|
|
|
|
foreach bp_num [gdb_get_breakpoint_list] {
|
|
lassign [gdb_get_breakpoint_info $bp_num] file function line_number \
|
|
address type enabled disposition ignore_count command_list \
|
|
condition thread hit_count user_specification
|
|
|
|
# These breakpoints are set when debugging GDB with itself.
|
|
# Ignore them so they don't accumulate. They get set again
|
|
# by .gdbinit anyway.
|
|
if {$debugging_gdb} {
|
|
if {$function == "internal_error" || $function == "info_command"} {
|
|
continue
|
|
}
|
|
}
|
|
|
|
switch -glob -- $type {
|
|
"breakpoint" -
|
|
"hw breakpoint" {
|
|
if {$disposition == "delete"} {
|
|
set cmd tbreak
|
|
} else {
|
|
set cmd break
|
|
}
|
|
|
|
append cmd " "
|
|
if {$user_specification != ""} {
|
|
append cmd "$user_specification"
|
|
} elseif {$file != ""} {
|
|
# BpWin::bp_store uses file tail here, but I think that is
|
|
# wrong.
|
|
append cmd "$file:$line_number"
|
|
} else {
|
|
append cmd "*$address"
|
|
}
|
|
}
|
|
"watchpoint" -
|
|
"hw watchpoint" {
|
|
set cmd watch
|
|
if {$user_specification != ""} {
|
|
append cmd " $user_specification"
|
|
} else {
|
|
# There's nothing sensible to do.
|
|
continue
|
|
}
|
|
}
|
|
|
|
"catch*" {
|
|
# FIXME: Don't know what to do.
|
|
continue
|
|
}
|
|
|
|
default {
|
|
# Can't serialize anything other than those listed above.
|
|
continue
|
|
}
|
|
}
|
|
|
|
lappend result [list $cmd $enabled $condition $command_list]
|
|
}
|
|
|
|
return $result
|
|
}
|
|
|
|
# An internal function used when loading sessions. It takes a
|
|
# breakpoint string and recreates all the breakpoints.
|
|
proc _recreate_bps {specs} {
|
|
foreach spec $specs {
|
|
lassign $spec create enabled condition commands
|
|
|
|
# Create the breakpoint
|
|
if {[catch {gdb_cmd $create} txt]} {
|
|
dbug W $txt
|
|
}
|
|
|
|
# Below we use `\$bpnum'. This means we don't have to figure out
|
|
# the number of the breakpoint when doing further manipulations.
|
|
|
|
if {! $enabled} {
|
|
gdb_cmd "disable \$bpnum"
|
|
}
|
|
|
|
if {$condition != ""} {
|
|
gdb_cmd "cond \$bpnum $condition"
|
|
}
|
|
|
|
if {[llength $commands]} {
|
|
lappend commands end
|
|
eval gdb_run_readline_command_no_output [list "commands \$bpnum"] \
|
|
$commands
|
|
}
|
|
}
|
|
}
|
|
|
|
#
|
|
# This procedure decides what makes up a gdb `session'. Roughly a
|
|
# session is whatever the user found useful when debugging a certain
|
|
# executable.
|
|
#
|
|
# Eventually we should expand this procedure to know how to save
|
|
# window placement and contents. That requires more work.
|
|
#
|
|
proc save {} {
|
|
global gdb_exe_name gdb_target_name
|
|
global gdb_current_directory gdb_source_path
|
|
|
|
# gdb sessions are named after the executable.
|
|
set name [_exe_name $gdb_exe_name]
|
|
set key gdb/session/$name
|
|
|
|
# We fill a hash and then use that to set the actual preferences.
|
|
|
|
# Always set the exe. name in case we later decide to change the
|
|
# interpretation of the session key. Use the full path to the
|
|
# executable.
|
|
set values(executable) $name
|
|
|
|
# Some simple state the user wants.
|
|
set values(args) [gdb_get_inferior_args]
|
|
set values(dirs) $gdb_source_path
|
|
set values(pwd) $gdb_current_directory
|
|
set values(target) $gdb_target_name
|
|
set values(hostname) [pref getd gdb/load/$gdb_target_name-hostname]
|
|
set values(port) [pref getd gdb/load/$gdb_target_name-portname]
|
|
set values(target_cmd) $::gdb_target_cmd
|
|
set values(bg) $::gdb_bg_num
|
|
|
|
# these prefs need to be made session-dependent
|
|
set values(run_attach) [pref get gdb/src/run_attach]
|
|
set values(run_load) [pref get gdb/src/run_load]
|
|
set values(run_run) [pref get gdb/src/run_run]
|
|
set values(run_cont) [pref get gdb/src/run_cont]
|
|
|
|
# Breakpoints.
|
|
set values(breakpoints) [_serialize_bps]
|
|
|
|
# Recompute list of recent sessions. Trim to no more than 20 sessions.
|
|
set recent [concat [list $name] \
|
|
[lremove [pref getd gdb/recent-projects] $name]]
|
|
if {[llength $recent] > 20} {
|
|
set recent [lreplace $recent 20 end]
|
|
}
|
|
pref setd gdb/recent-projects $recent
|
|
|
|
foreach k [array names values] {
|
|
pref setd $key/$k $values($k)
|
|
}
|
|
pref setd $key/all-keys [array names values]
|
|
}
|
|
|
|
#
|
|
# Load a session saved with Session::save. NAME is the pretty name of
|
|
# the session, as returned by Session::list_names.
|
|
#
|
|
proc load {name} {
|
|
# gdb sessions are named after the executable.
|
|
set key gdb/session/$name
|
|
|
|
# Fetch all keys for this session into an array.
|
|
foreach k [pref getd $key/all-keys] {
|
|
set values($k) [pref getd $key/$k]
|
|
}
|
|
|
|
if {[info exists values(executable)]} {
|
|
gdb_clear_file
|
|
set_exe_name $values(executable)
|
|
set_exe
|
|
}
|
|
}
|
|
|
|
#
|
|
# This is called from file_changed_hook. It does all the work of
|
|
# loading a session, if one exists with the same name as the current
|
|
# executable.
|
|
#
|
|
proc notice_file_change {} {
|
|
global gdb_exe_name gdb_target_name
|
|
|
|
debug "noticed file change event for $gdb_exe_name"
|
|
|
|
# gdb sessions are named after the executable.
|
|
set name [_exe_name $gdb_exe_name]
|
|
set key gdb/session/$name
|
|
|
|
# Fetch all keys for this session into an array.
|
|
foreach k [pref getd $key/all-keys] {
|
|
set values($k) [pref getd $key/$k]
|
|
}
|
|
|
|
# reset these back to their defaults
|
|
pref set gdb/src/run_attach 0
|
|
pref set gdb/src/run_load 0
|
|
pref set gdb/src/run_run 1
|
|
pref set gdb/src/run_cont 0
|
|
|
|
if {! [info exists values(executable)] || $values(executable) != $name} {
|
|
# No such session.
|
|
return
|
|
}
|
|
|
|
debug "reloading session for $name"
|
|
|
|
if {[info exists values(dirs)]} {
|
|
# FIXME: short-circuit confirmation.
|
|
gdb_cmd "directory"
|
|
gdb_cmd "directory $values(dirs)"
|
|
}
|
|
|
|
if {[info exists values(pwd)]} {
|
|
catch {gdb_cmd "cd $values(pwd)"}
|
|
}
|
|
|
|
if {[info exists values(args)]} {
|
|
gdb_set_inferior_args $values(args)
|
|
}
|
|
|
|
if {[info exists values(breakpoints)]} {
|
|
_recreate_bps $values(breakpoints)
|
|
}
|
|
|
|
if {[info exists values(target)]} {
|
|
#debug "Restoring Target: $values(target)"
|
|
set gdb_target_name $values(target)
|
|
|
|
if {[info exists values(hostname)]} {
|
|
pref setd gdb/load/$gdb_target_name-hostname $values(hostname)
|
|
#debug "Restoring Hostname: $values(hostname)"
|
|
}
|
|
|
|
if {[info exists values(port)]} {
|
|
pref setd gdb/load/$gdb_target_name-portname $values(port)
|
|
#debug "Restoring Port: $values(port)"
|
|
}
|
|
|
|
#debug "Restoring Target_Cmd: $values(target_cmd)"
|
|
set ::gdb_target_cmd $values(target_cmd)
|
|
set_baud
|
|
}
|
|
|
|
if {[info exists values(run_attach)]} {
|
|
pref set gdb/src/run_attach $values(run_attach)
|
|
pref set gdb/src/run_load $values(run_load)
|
|
pref set gdb/src/run_run $values(run_run)
|
|
pref set gdb/src/run_cont $values(run_cont)
|
|
}
|
|
|
|
if {[info exists values(bg)] && [pref get gdb/use_color_schemes]} {
|
|
set_bg_colors $values(bg)
|
|
}
|
|
}
|
|
|
|
#
|
|
# Delete a session. NAME is the internal name of the session.
|
|
#
|
|
proc delete {name} {
|
|
# FIXME: we can't yet fully define this because the libgui
|
|
# preference code doesn't supply a delete method.
|
|
set recent [lremove [pref getd gdb/recent-projects] $name]
|
|
pref setd gdb/recent-projects $recent
|
|
}
|
|
|
|
#
|
|
# Return a list of all known sessions. This returns the `pretty name'
|
|
# of the session -- something suitable for a menu.
|
|
#
|
|
proc list_names {} {
|
|
set newlist {}
|
|
set result {}
|
|
foreach name [pref getd gdb/recent-projects] {
|
|
set exe [pref getd gdb/session/$name/executable]
|
|
# Take this opportunity to prune the list.
|
|
if {[file exists $exe]} then {
|
|
lappend newlist $name
|
|
lappend result $exe
|
|
} else {
|
|
# FIXME: if we could delete keys we would delete all keys
|
|
# associated with NAME now.
|
|
}
|
|
}
|
|
pref setd gdb/recent-projects $newlist
|
|
return $result
|
|
}
|
|
}
|