gdb/gdbtk/library/session.tcl

   1 # Local preferences functions for Insight.
   2 # Copyright (C) 2000, 2001, 2002, 2004, 2008 Red Hat, Inc.
   3 #
   4 # This program is free software; you can redistribute it and/or modify it
   5 # under the terms of the GNU General Public License (GPL) as published by
   6 # the Free Software Foundation; either version 2 of the License, or (at
   7 # your option) any later version.
   8 #
   9 # This program is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 # GNU General Public License for more details.
  13
  14 namespace eval Session {
  15   namespace export save load notice_file_change delete list_names
  16
  17   # An internal function for canonicalizing path names.  This probably
  18   # should use `realpath', but that is more work.  So for now we neglect
  19   # the possibility of symlinks.
  20   proc _exe_name {path} {
  21
  22     # Get real directory.
  23     if {[string compare $::gdbtk_platform(os) "cygwin"] == 0} {
  24       set path [ide_cygwin_path to_win32 $path]
  25     }
  26     set save [pwd]
  27     cd [file dirname $path]
  28     set dir [pwd]
  29     cd $save
  30     return [file join $dir [file tail $path]]
  31   }
  32
  33   # An internal function used when saving sessions.  Returns a string
  34   # that can be used to recreate all pertinent breakpoint state.
  35   proc _serialize_bps {} {
  36     set result {}
  37
  38     # HACK.  When debugging gdb with itself in the build
  39     # directory, there is a ".gdbinit" file that will set
  40     # breakpoints on internal_error() and info_command().
  41     # If we then save and set them, they will accumulate.
  42     # Possible fixes are to modify GDB so we can tell which
  43     # breakpoints were set from .gdbinit, or modify
  44     # _recreate_bps to record which breakpoints were
  45     # set before it was called.  For now, we simply detect the
  46     # most common case and fix it.
  47     set basename [string tolower [file tail $::gdb_exe_name]]
  48     if {[string match "gdb*" $basename]
  49         || [string match "insight*" $basename]} {
  50       set debugging_gdb 1
  51     } else {
  52       set debugging_gdb 0
  53     }
  54
  55     foreach bp_num [gdb_get_breakpoint_list] {
  56       lassign [gdb_get_breakpoint_info $bp_num] file function line_number \
  57         address type enabled disposition ignore_count command_list \
  58         condition thread hit_count user_specification
  59
  60       # These breakpoints are set when debugging GDB with itself.
  61       # Ignore them so they don't accumulate. They get set again
  62       # by .gdbinit anyway.
  63       if {$debugging_gdb} {
  64         if {$function == "internal_error" || $function == "info_command"} {
  65           continue
  66         }
  67       }
  68
  69       switch -glob -- $type {
  70         "breakpoint" -
  71         "hw breakpoint" {
  72           if {$disposition == "delete"} {
  73             set cmd tbreak
  74           } else {
  75             set cmd break
  76           }
  77
  78           append cmd " "
  79           if {$user_specification != ""} {
  80             append cmd "$user_specification"
  81           } elseif {$file != ""} {
  82             # BpWin::bp_store uses file tail here, but I think that is
  83             # wrong.
  84             append cmd "$file:$line_number"
  85           } else {
  86             append cmd "*$address"
  87           }
  88         }
  89         "watchpoint" -
  90         "hw watchpoint" {
  91           set cmd watch
  92           if {$user_specification != ""} {
  93             append cmd " $user_specification"
  94           } else {
  95             # There's nothing sensible to do.
  96             continue
  97           }
  98         }
  99
 100         "catch*" {
 101           # FIXME: Don't know what to do.
 102           continue
 103         }
 104
 105         default {
 106           # Can't serialize anything other than those listed above.
 107           continue
 108         }
 109       }
 110
 111       lappend result [list $cmd $enabled $condition $command_list]
 112     }
 113
 114     return $result
 115   }
 116
 117   # An internal function used when loading sessions.  It takes a
 118   # breakpoint string and recreates all the breakpoints.
 119   proc _recreate_bps {specs} {
 120     foreach spec $specs {
 121       lassign $spec create enabled condition commands
 122
 123       # Create the breakpoint
 124       if {[catch {gdb_cmd $create} txt]} {
 125         dbug W $txt
 126       }
 127
 128       # Below we use `\$bpnum'.  This means we don't have to figure out
 129       # the number of the breakpoint when doing further manipulations.
 130
 131       if {! $enabled} {
 132         gdb_cmd "disable \$bpnum"
 133       }
 134
 135       if {$condition != ""} {
 136         gdb_cmd "cond \$bpnum $condition"
 137       }
 138
 139       if {[llength $commands]} {
 140         lappend commands end
 141         eval gdb_run_readline_command_no_output [list "commands \$bpnum"] \
 142           $commands
 143       }
 144     }
 145   }
 146
 147   #
 148   # This procedure decides what makes up a gdb `session'.  Roughly a
 149   # session is whatever the user found useful when debugging a certain
 150   # executable.
 151   #
 152   # Eventually we should expand this procedure to know how to save
 153   # window placement and contents.  That requires more work.
 154   #
 155   proc save {} {
 156     global gdb_exe_name gdb_target_name
 157     global gdb_current_directory gdb_source_path
 158
 159     # gdb sessions are named after the executable.
 160     set name [_exe_name $gdb_exe_name]
 161     set key gdb/session/$name
 162
 163     # We fill a hash and then use that to set the actual preferences.
 164
 165     # Always set the exe. name in case we later decide to change the
 166     # interpretation of the session key.  Use the full path to the
 167     # executable.
 168     set values(executable) $name
 169
 170     # Some simple state the user wants.
 171     set values(args) [gdb_get_inferior_args]
 172     set values(dirs) $gdb_source_path
 173     set values(pwd) $gdb_current_directory
 174     set values(target) $gdb_target_name
 175     set values(hostname) [pref getd gdb/load/$gdb_target_name-hostname]
 176     set values(port) [pref getd gdb/load/$gdb_target_name-portname]
 177     set values(target_cmd) $::gdb_target_cmd
 178     set values(bg) $::gdb_bg_num
 179
 180     # these prefs need to be made session-dependent
 181     set values(run_attach) [pref get gdb/src/run_attach]
 182     set values(run_load) [pref get gdb/src/run_load]
 183     set values(run_run) [pref get gdb/src/run_run]
 184     set values(run_cont) [pref get gdb/src/run_cont]
 185
 186     # Breakpoints.
 187     set values(breakpoints) [_serialize_bps]
 188
 189     # Recompute list of recent sessions.  Trim to no more than 20 sessions.
 190     set recent [concat [list $name] \
 191                   [lremove [pref getd gdb/recent-projects] $name]]
 192     if {[llength $recent] > 20} {
 193       set recent [lreplace $recent 20 end]
 194     }
 195     pref setd gdb/recent-projects $recent
 196
 197     foreach k [array names values] {
 198       pref setd $key/$k $values($k)
 199     }
 200     pref setd $key/all-keys [array names values]
 201   }
 202
 203   #
 204   # Load a session saved with Session::save.  NAME is the pretty name of
 205   # the session, as returned by Session::list_names.
 206   #
 207   proc load {name} {
 208     # gdb sessions are named after the executable.
 209     set key gdb/session/$name
 210
 211     # Fetch all keys for this session into an array.
 212     foreach k [pref getd $key/all-keys] {
 213       set values($k) [pref getd $key/$k]
 214     }
 215
 216     if {[info exists values(executable)]} {
 217       gdb_clear_file
 218       set_exe_name $values(executable)
 219       set_exe
 220     }
 221   }
 222
 223   #
 224   # This is called from file_changed_hook.  It does all the work of
 225   # loading a session, if one exists with the same name as the current
 226   # executable.
 227   #
 228   proc notice_file_change {} {
 229     global gdb_exe_name gdb_target_name
 230
 231     debug "noticed file change event for $gdb_exe_name"
 232
 233     # gdb sessions are named after the executable.
 234     set name [_exe_name $gdb_exe_name]
 235     set key gdb/session/$name
 236
 237     # Fetch all keys for this session into an array.
 238     foreach k [pref getd $key/all-keys] {
 239       set values($k) [pref getd $key/$k]
 240     }
 241
 242     # reset these back to their defaults
 243     pref set gdb/src/run_attach          0
 244     pref set gdb/src/run_load            0
 245     pref set gdb/src/run_run             1
 246     pref set gdb/src/run_cont            0
 247
 248     if {! [info exists values(executable)] || $values(executable) != $name} {
 249       # No such session.
 250       return
 251     }
 252
 253     debug "reloading session for $name"
 254
 255     if {[info exists values(dirs)]} {
 256       # FIXME: short-circuit confirmation.
 257       gdb_cmd "directory"
 258       gdb_cmd "directory $values(dirs)"
 259     }
 260
 261     if {[info exists values(pwd)]} {
 262       catch {gdb_cmd "cd $values(pwd)"}
 263     }
 264
 265     if {[info exists values(args)]} {
 266       gdb_set_inferior_args $values(args)
 267     }
 268
 269     if {[info exists values(breakpoints)]} {
 270       _recreate_bps $values(breakpoints)
 271     }
 272
 273     if {[info exists values(target)]} {
 274       #debug "Restoring Target: $values(target)"
 275       set gdb_target_name $values(target)
 276
 277       if {[info exists values(hostname)]} {
 278         pref setd gdb/load/$gdb_target_name-hostname $values(hostname)
 279         #debug "Restoring Hostname: $values(hostname)"
 280       }
 281
 282       if {[info exists values(port)]} {
 283         pref setd gdb/load/$gdb_target_name-portname $values(port)
 284         #debug "Restoring Port: $values(port)"
 285       }
 286
 287       #debug "Restoring Target_Cmd: $values(target_cmd)"
 288       set ::gdb_target_cmd $values(target_cmd)
 289       set_baud
 290     }
 291
 292     if {[info exists values(run_attach)]} {
 293       pref set gdb/src/run_attach $values(run_attach)
 294       pref set gdb/src/run_load $values(run_load)
 295       pref set gdb/src/run_run $values(run_run)
 296       pref set gdb/src/run_cont $values(run_cont)
 297     }
 298
 299     if {[info exists values(bg)] && [pref get gdb/use_color_schemes]} {
 300       set_bg_colors $values(bg)
 301     }
 302   }
 303
 304   #
 305   # Delete a session.  NAME is the internal name of the session.
 306   #
 307   proc delete {name} {
 308     # FIXME: we can't yet fully define this because the libgui
 309     # preference code doesn't supply a delete method.
 310     set recent [lremove [pref getd gdb/recent-projects] $name]
 311     pref setd gdb/recent-projects $recent
 312   }
 313
 314   #
 315   # Return a list of all known sessions.  This returns the `pretty name'
 316   # of the session -- something suitable for a menu.
 317   #
 318   proc list_names {} {
 319     set newlist {}
 320     set result {}
 321     foreach name [pref getd gdb/recent-projects] {
 322       set exe [pref getd gdb/session/$name/executable]
 323       # Take this opportunity to prune the list.
 324       if {[file exists $exe]} then {
 325         lappend newlist $name
 326         lappend result $exe
 327       } else {
 328         # FIXME: if we could delete keys we would delete all keys
 329         # associated with NAME now.
 330       }
 331     }
 332     pref setd gdb/recent-projects $newlist
 333     return $result
 334   }
 335 }