| # 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 |
| } |
| } |