gdb/gdbtk/library/util.tcl

   1 # Utilities for Insight.
   2 # Copyright (C) 1997, 1998, 1999, 2004 Red Hat
   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
  15 # ----------------------------------------------------------------------
  16 # Misc routines
  17 #
  18 #   PROCS:
  19 #
  20 #     keep_raised - keep a window raised
  21 #     sleep - wait a certain number of seconds and return
  22 #     toggle_debug_mode - turn debugging on and off
  23 #     freeze - make a window modal
  24 #     bp_exists - does a breakpoint exist on linespec?
  25 #
  26 # ----------------------------------------------------------------------
  27 #
  28
  29
  30 # A helper procedure to keep a window on top.
  31 proc keep_raised {top} {
  32   if {[winfo exists $top]} {
  33     raise $top
  34     wm deiconify $top
  35     after 1000 [info level 0]
  36   }
  37 }
  38
  39 # sleep - wait a certain number of seconds then return
  40 proc sleep {sec} {
  41   global __sleep_timer
  42   set __sleep_timer 0
  43   after [expr {1000 * $sec}] set __sleep_timer 1
  44   vwait __sleep_timer
  45 }
  46
  47
  48 # ------------------------------------------------------------------
  49 #  PROC:  auto_step - automatically step through a program
  50 # ------------------------------------------------------------------
  51
  52 # FIXME FIXME
  53 proc auto_step {} {
  54   global auto_step_id
  55
  56   set auto_step_id [after 2000 auto_step]
  57   gdb_cmd next
  58 }
  59
  60 # ------------------------------------------------------------------
  61 #  PROC:  auto_step_cancel - cancel auto-stepping
  62 # ------------------------------------------------------------------
  63
  64 proc auto_step_cancel {} {
  65   global auto_step_id
  66
  67   if {[info exists auto_step_id]} {
  68     after cancel $auto_step_id
  69     unset auto_step_id
  70   }
  71 }
  72
  73 # ------------------------------------------------------------------
  74 #  PROC:  tfind_cmd -- to execute a tfind command on the target
  75 # ------------------------------------------------------------------
  76 proc tfind_cmd {command} {
  77   gdbtk_busy
  78   # need to call gdb_cmd because we want to ignore the output
  79   set err [catch {gdb_cmd $command} msg]
  80   if {$err || [regexp "Target failed to find requested trace frame" $msg]} {
  81     tk_messageBox -icon error -title "GDB" -type ok \
  82       -message $msg
  83     gdbtk_idle
  84     return
  85   } else {
  86     gdbtk_update
  87     gdbtk_idle
  88   }
  89 }
  90
  91 # ------------------------------------------------------------------
  92 #  PROC:  save_trace_command -- Saves the current trace settings to a file
  93 # ------------------------------------------------------------------
  94 proc save_trace_commands {} {
  95
  96   set out_file [tk_getSaveFile -title "Enter output file for trace commands"]
  97   debug "Got outfile: $out_file"
  98   if {$out_file != ""} {
  99     gdb_cmd "save-tracepoints $out_file"
 100   }
 101 }
 102
 103 # ------------------------------------------------------------------
 104 #  PROC:  do_test - invoke the test passed in
 105 #           This proc is provided for convenience. For any test
 106 #           that uses the console window (like the console window
 107 #           tests), the file cannot be sourced directly using the
 108 #           'tk' command because it will block the console window
 109 #           until the file is done executing. This proc assures
 110 #           that the console window is free for input by wrapping
 111 #           the source call in an after callback.
 112 #           Users may also pass in the verbose and tests globals
 113 #           used by the testsuite.
 114 # ------------------------------------------------------------------
 115 proc do_test {{file {}} {verbose {}} {tests {}}} {
 116   global _test
 117
 118   if {$file == {}} {
 119     error "wrong \# args: should be: do_test file ?verbose? ?tests ...?"
 120   }
 121
 122   if {$verbose != {}} {
 123     set _test(verbose) $verbose
 124   } elseif {![info exists _test(verbose)]} {
 125     set _test(verbose) 0
 126   }
 127
 128   if {$tests != {}} {
 129     set _test(tests) $tests
 130   }
 131
 132   set _test(interactive) 1
 133   after 500 [list source $file]
 134 }
 135
 136 # ------------------------------------------------------------------
 137 #  PROCEDURE:  gdbtk_read_defs
 138 #        Reads in the defs file for the testsuite. This is usually
 139 #        the first procedure called by a test file. It returns
 140 #        1 if it was successful and 0 if not (if run interactively
 141 #        from the console window) or exits (if running via dejagnu).
 142 # ------------------------------------------------------------------
 143 proc gdbtk_read_defs {} {
 144   global _test env
 145
 146   if {[info exists env(DEFS)]} {
 147     set err [catch {source $env(DEFS)} errTxt]
 148   } else {
 149     set err [catch {source defs} errTxt]
 150   }
 151
 152   if {$err} {
 153     if {$_test(interactive)} {
 154       tk_messageBox -icon error -message "Cannot load defs file:\n$errTxt" -type ok
 155       return 0
 156     } else {
 157       puts stderr "cannot load defs files: $errTxt\ntry setting DEFS"
 158       exit 1
 159     }
 160   }
 161
 162   return 1
 163 }
 164
 165 # ------------------------------------------------------------------
 166 #  PROCEDURE:  bp_exists
 167 #            Returns BPNUM if a breakpoint exists at LINESPEC or
 168 #            -1 if no breakpoint exists there
 169 # ------------------------------------------------------------------
 170 proc bp_exists {linespec} {
 171
 172   lassign $linespec foo function filename line_number addr pc_addr
 173
 174   set bps [gdb_get_breakpoint_list]
 175   foreach bpnum $bps {
 176     set bpinfo [gdb_get_breakpoint_info $bpnum]
 177     lassign $bpinfo file func line pc type enabled disposition \
 178       ignore_count commands cond thread hit_count user_specification
 179     if {$filename == $file && $function == $func && $addr == $pc} {
 180       return $bpnum
 181     }
 182   }
 183
 184   return -1
 185 }
 186
 187
 188 # gridCGet - This provides the missing grid cget
 189 # command.
 190
 191 proc gridCGet {slave option} {
 192   set config_list [grid info $slave]
 193   return [lindex $config_list [expr [lsearch $config_list $option] + 1]]
 194 }
 195
 196 # ------------------------------------------------------------------
 197 #  PROC:  get_disassembly_flavor - gets the current disassembly flavor.
 198 #         The set disassembly-flavor command is assumed to exist.  This
 199 #         will error out if it does not.
 200 # ------------------------------------------------------------------
 201 proc get_disassembly_flavor {} {
 202   if {[catch {gdb_cmd "show disassembly-flavor"} ret]} {
 203     return ""
 204   } else {
 205     regexp {\"([^\"]*)\"\.} $ret dummy gdb_val
 206     return $gdb_val
 207   }
 208 }
 209
 210 # ------------------------------------------------------------------
 211 #  PROC:  list_disassembly_flavors - Lists the current disassembly flavors.
 212 #         Returns an empty list if the set disassembly-flavor is not supported.
 213 # ------------------------------------------------------------------
 214 proc list_disassembly_flavors {} {
 215   catch {gdb_cmd "set disassembly-flavor"} ret_val
 216   if {[regexp {Requires an argument\. Valid arguments are (.*)\.} \
 217          $ret_val dummy list]} {
 218     foreach elem  [split $list ","] {
 219       lappend vals [string trim $elem]
 220     }
 221     return [lsort $vals]
 222   } else {
 223     return {}
 224   }
 225 }
 226
 227 # ------------------------------------------------------------------
 228 #  PROC:  init_disassembly_flavor - Synchs up gdb's internal disassembly
 229 #         flavor with the value in the preferences file.
 230 # ------------------------------------------------------------------
 231 proc init_disassembly_flavor {} {
 232   set gdb_val [get_disassembly_flavor]
 233   if {$gdb_val != ""} {
 234     set def_val [pref get gdb/src/disassembly-flavor]
 235     if {[string compare $def_val ""] != 0} {
 236       if {[catch "gdb_cmd \"set disassembly-flavor $def_val\""]} {
 237         pref set gdb/src/disassembly-flavor $gdb_val
 238       }
 239     } else {
 240       pref set gdb/src/disassembly-flavor $gdb_val
 241     }
 242   }
 243 }
 244
 245 # ------------------------------------------------------------------
 246 #  PROC:  list_element_strcmp - to be used in lsort -command when the
 247 #         elements are themselves lists, and you always want to look at
 248 #         a particular item.
 249 # ------------------------------------------------------------------
 250 proc list_element_strcmp {index first second} {
 251   set theFirst [lindex $first $index]
 252   set theSecond [lindex $second $index]
 253
 254   return [string compare $theFirst $theSecond]
 255 }
 256
 257 # ------------------------------------------------------------------
 258 #  PROC:  gdbtk_endian - returns BIG or LITTLE depending on target
 259 #                        endianess
 260 # ------------------------------------------------------------------
 261
 262 proc gdbtk_endian {} {
 263   if {[catch {gdb_cmd "show endian"} result]} {
 264     return "UNKNOWN"
 265   }
 266   if {[regexp {.*big endian} $result]} {
 267     set result "BIG"
 268   } elseif {[regexp {.*little endian} $result]} {
 269     set result "LITTLE"
 270   } else {
 271     set result "UNKNOWN"
 272   }
 273   return $result
 274 }
 275
 276 # ------------------------------------------------------------------
 277 #  PROC:  set_bg_colors - set background and text background for
 278 #                        all windows.
 279 # ------------------------------------------------------------------
 280 proc set_bg_colors {{num ""}} {
 281   debug $num
 282
 283   if {$num != ""} {
 284     set ::gdb_bg_num $num
 285   }
 286   set ::Colors(textbg) [pref get gdb/bg/$::gdb_bg_num]
 287
 288   # calculate background as 80% of textbg
 289   set ::Colors(bg) [recolor $::Colors(textbg) 80]
 290
 291   # calculate trough and activebackground as 90% of background
 292   set dbg [recolor $::Colors(bg) 90]
 293
 294   r_setcolors . -background $::Colors(bg)
 295   r_setcolors . -highlightbackground $::Colors(bg)
 296   r_setcolors . -textbackground $::Colors(textbg)
 297   r_setcolors . -troughcolor $dbg
 298   r_setcolors . -activebackground $dbg
 299
 300   pref_set_option_db 1
 301   ManagedWin::restart
 302 }
 303
 304 # ------------------------------------------------------------------
 305 #  PROC:  r_setcolors - recursively set background and text background for
 306 #                        all windows.
 307 # ------------------------------------------------------------------
 308 proc r_setcolors {w option color} {
 309   debug "$w $option $color"
 310
 311   # exception(s)
 312   if {![catch {$w isa Balloon} result] && $result == "1"} {
 313     return
 314   }
 315   catch {$w config $option $color}
 316
 317   foreach child [winfo children $w] {
 318     r_setcolors $child $option $color
 319   }
 320 }
 321
 322 # ------------------------------------------------------------------
 323 #  PROC:  recolor - returns a darker or lighter color
 324 # ------------------------------------------------------------------
 325 proc recolor {color percent} {
 326   set c [winfo rgb . $color]
 327   return [format #%02x%02x%02x [expr {($percent * [lindex $c 0]) / 25600}]  \
 328             [expr {($percent * [lindex $c 1]) / 25600}] [expr {($percent * [lindex $c 2]) / 25600}]]
 329 }
 330
 331