gdb/gdbtk/library/targetselection.itb

   1 # Target selection dialog for Insight.
   2 # Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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
  15 # ----------------------------------------------------------------------
  16 # Implements GDB TargetSelection dialog
  17 # ----------------------------------------------------------------------
  18
  19 # ------------------------------------------------------------------
  20 #  CONSTRUCTOR - create new target selection window
  21 # ------------------------------------------------------------------
  22 itcl::body TargetSelection::constructor {args} {
  23   eval itk_initialize $args
  24   _init
  25   build_win
  26 }
  27
  28 itcl::body TargetSelection::getname {target name} {
  29
  30   # Init target database if we haven't already done so
  31   init_target_db
  32
  33   if {[info exists gdb_target($target,$name)]} {
  34     return $gdb_target($target,$name)
  35   } else {
  36     return ""
  37   }
  38 }
  39
  40 itcl::body TargetSelection::init_target_db {} {
  41   # check to see if we already initialized this database
  42   if {$db_inited} {
  43     return
  44   }
  45   set db_inited 1
  46
  47   # We really need to have the preferences defined, too,
  48   # otherwise set_target and company won't work properly
  49   # unless the user has first opened a TargetSelection dialog.
  50   _init_prefs
  51
  52   # Target Database
  53   # Set the following members:
  54   # TARGET,pretty-name: Name to display to user
  55   # TARGET,debaud: Default baudrate
  56   # TARGET,baud-rates: Permissible baudrates
  57   # TARGET,cmd: Abstracted command to run for this target (tcpX and com1 are
  58   #          replaced with the real port and host/port in set_target)
  59   # TARGET,runlist: List of preferences for the target: {attach download run cont}
  60   # TARGET,after_attaching: a command to run after attaching to the target
  61
  62   # Default target
  63   set gdb_target(default,pretty-name) "Default"
  64   set gdb_target(default,defbaud) ""
  65   set gdb_target(default,baud-rates) {}
  66   set gdb_target(default,cmd) ""
  67   set gdb_target(default,runlist) {0 0 1 0}
  68   set gdb_target(default,options) ""
  69   set gdb_target(default,after_attaching) {}
  70
  71   # Exec target
  72   set gdb_target(exec,pretty-name) "Exec"
  73   set gdb_target(exec,defbaud) ""
  74   set gdb_target(exec,baud-rates) {}
  75   set gdb_target(exec,cmd) ""
  76   set gdb_target(exec,runlist) {0 0 1 0}
  77   set gdb_target(exec,options) ""
  78   set gdb_target(exec,after_attaching) {}
  79
  80   # ADS board w/SDS protocol
  81   set gdb_target(sds,pretty-name) "SDS"
  82   set gdb_target(sds,defbaud) "38400"
  83   set gdb_target(sds,baud-rates) {9600 38400}
  84   set gdb_target(sds,cmd) "sds com1"
  85   set gdb_target(sds,runlist) {1 1 0 1}
  86   set gdb_target(sds,after_attaching) {}
  87
  88   # Simulator
  89   set gdb_target(sim,pretty-name) "Simulator"
  90   set gdb_target(sim,defbaud) ""
  91   set gdb_target(sim,baud-rates) {}
  92   set gdb_target(sim,cmd) "sim"
  93   set gdb_target(sim,runlist) {1 1 1 0}
  94   set gdb_target(sim,options) ""
  95   set gdb_target(sim,after_attaching) {}
  96
  97   # Remote
  98   set gdb_target(remote,pretty-name) "Remote/Serial"
  99   set gdb_target(remote,defbaud) "9600"
 100   set gdb_target(remote,baud-rates) {9600 19200 38400 57600 115200}
 101   set gdb_target(remote,cmd) "remote com1"
 102   set gdb_target(remote,runlist) {1 1 0 1}
 103   set gdb_target(remote,after_attaching) {}
 104   set gdb_target(remotetcp,pretty-name) "Remote/TCP"
 105   set gdb_target(remotetcp,defbaud) "TCP"
 106   set gdb_target(remotetcp,baud-rates) {}
 107   set gdb_target(remotetcp,cmd) "remote tcpX"
 108   set gdb_target(remotetcp,runlist) {1 1 0 1}
 109   set gdb_target(remotetcp,after_attaching) {}
 110
 111   # ARM Angel
 112   set gdb_target(rdi,pretty-name) "ARM Angel/Serial"
 113   set gdb_target(rdi,defbaud) "9600"
 114   set gdb_target(rdi,baud-rates) {9600 19200 38400 57600 115200}
 115   set gdb_target(rdi,cmd) "rdi com1"
 116   set gdb_target(rdi,runlist) {1 1 0 1}
 117   set gdb_target(rdi,after_attaching) {}
 118
 119   # ARM Angel/Ethernet
 120   set gdb_target(rditcp,pretty-name) "ARM Angel/Ethernet"
 121   set gdb_target(rditcp,defbaud) "ETH"
 122   set gdb_target(rditcp,baud-rates) {}
 123   set gdb_target(rditcp,cmd) "rdi ethX"
 124   set gdb_target(rditcp,runlist) {1 1 0 1}
 125   set gdb_target(rditcp,after_attaching) {}
 126
 127   # ARM Remote
 128   set gdb_target(rdp,pretty-name) "ARM Remote/Serial"
 129   set gdb_target(rdp,defbaud) "9600"
 130   set gdb_target(rdp,baud-rates) {9600}
 131   set gdb_target(rdp,cmd) "rdp com1"
 132   set gdb_target(rdp,runlist) {1 1 0 1}
 133   set gdb_target(rdp,after_attaching) {}
 134   set gdb_target(rdptcp,pretty-name) "ARM Remote/TCP"
 135   set gdb_target(rdptcp,defbaud) "TCP"
 136   set gdb_target(rdptcp,baud-rates) {}
 137   set gdb_target(rdptcp,cmd) "rdp tcpX"
 138   set gdb_target(rdptcp,runlist) {1 1 0 1}
 139   set gdb_target(rdptcp,after_attaching) {}
 140
 141   # m32r rev C
 142   set gdb_target(m32r,pretty-name) "M32R/Serial"
 143   set gdb_target(m32r,defbaud) "9600"
 144   set gdb_target(m32r,baud-rates) {9600}
 145   set gdb_target(m32r,cmd) "m32r com1"
 146   set gdb_target(m32r,runlist) {1 1 0 1}
 147   set gdb_target(m32r,after_attaching) {}
 148   set gdb_target(m32rtcp,pretty-name) "M32R/TCP"
 149   set gdb_target(m32rtcp,defbaud) "TCP"
 150   set gdb_target(m32rtcp,baud-rates) {}
 151   set gdb_target(m32rtcp,cmd) "m32r tcpX"
 152   set gdb_target(m32rtcp,runlist) {1 1 0 1}
 153   set gdb_target(m32rtcp,after_attaching) {}
 154
 155   # m32r msa2000
 156   set gdb_target(mon2000,pretty-name) "MON2000/Serial"
 157   set gdb_target(mon2000,defbaud) "9600"
 158   set gdb_target(mon2000,baud-rates) {9600}
 159   set gdb_target(mon2000,cmd) "mon2000 com1"
 160   set gdb_target(mon2000,runlist) {1 1 0 1}
 161   set gdb_target(mon2000,after_attaching) {}
 162   set gdb_target(mon2000tcp,pretty-name) "MON2000/TCP"
 163   set gdb_target(mon2000tcp,defbaud) "TCP"
 164   set gdb_target(mon2000tcp,baud-rates) {}
 165   set gdb_target(mon2000tcp,cmd) "mon2000 tcpX"
 166   set gdb_target(mon2000tcp,runlist) {1 1 0 1}
 167   set gdb_target(mon2000tcp,after_attaching) {}
 168
 169   # sparclite
 170   set gdb_target(sparclite,pretty-name) "SPARClite/Serial"
 171   set gdb_target(sparclite,defbaud) "9600"
 172   set gdb_target(sparclite,baud-rates) {9600}
 173   set gdb_target(sparclite,cmd) "sparclite com1"
 174   set gdb_target(sparclite,runlist) {1 1 0 1}
 175   set gdb_target(sparclite,after_attaching) {}
 176   set gdb_target(sparclitetcp,pretty-name) "SPARClite/TCP"
 177   set gdb_target(sparclitetcp,defbaud) "TCP"
 178   set gdb_target(sparclitetcp,baud-rates) {}
 179   set gdb_target(sparclitetcp,cmd) "sparclite tcpX"
 180   set gdb_target(sparclitetcp,runlist) {1 1 0 1}
 181   set gdb_target(sparclitetcp,after_attaching) {}
 182
 183   # V850 ICE
 184   set gdb_target(ice,pretty-name) "V850 ICE"
 185   set gdb_target(ice,defbaud) ""
 186   set gdb_target(ice,baud-rates) {}
 187   set gdb_target(ice,cmd) "ice"
 188   set gdb_target(ice,runlist) {1 1 0 1}
 189   set gdb_target(ice,after_attaching) {}
 190
 191   # MIPS
 192   set gdb_target(mips,pretty-name) "MIPS/Serial"
 193   set gdb_target(mips,defbaud) "9600"
 194   set gdb_target(mips,baud-rates) {9600}
 195   set gdb_target(mips,cmd) "mips com1"
 196   set gdb_target(mips,runlist) {1 1 0 1}
 197   set gdb_target(mips,after_attaching) {}
 198   set gdb_target(mipstcp,pretty-name) "MIPS/TCP"
 199   set gdb_target(mipstcp,defbaud) "TCP"
 200   set gdb_target(mipstcp,baud-rates) {}
 201   set gdb_target(mipstcp,cmd) "mips tcpX"
 202   set gdb_target(mipstcp,runlist) {1 1 0 1}
 203   set gdb_target(mipstcp,after_attaching) {}
 204
 205   # PMON
 206   set gdb_target(pmon,pretty-name) "PMON/Serial"
 207   set gdb_target(pmon,defbaud) "9600"
 208   set gdb_target(pmon,baud-rates) {9600 19200 38400}
 209   set gdb_target(pmon,cmd) "pmon com1"
 210   set gdb_target(pmon,runlist) {1 1 0 1}
 211   set gdb_target(pmon,after_attaching) {}
 212   set gdb_target(pmontcp,pretty-name) "PMON/TCP"
 213   set gdb_target(pmontcp,defbaud) "TCP"
 214   set gdb_target(pmontcp,baud-rates) {}
 215   set gdb_target(pmontcp,cmd) "pmon tcpX"
 216   set gdb_target(pmontcp,runlist) {1 1 0 1}
 217   set gdb_target(pmontcp,after_attaching) {}
 218
 219   # DDB
 220   set gdb_target(ddb,pretty-name) "DDB/Serial"
 221   set gdb_target(ddb,defbaud) "19200"
 222   set gdb_target(ddb,baud-rates) {9600 19200 38400}
 223   set gdb_target(ddb,cmd) "ddb com1"
 224   set gdb_target(ddb,runlist) {1 1 0 1}
 225   set gdb_target(ddb,after_attaching) {}
 226   set gdb_target(ddbtcp,pretty-name) "DDB/TCP"
 227   set gdb_target(ddbtcp,defbaud) "TCP"
 228   set gdb_target(ddbtcp,baud-rates) {}
 229   set gdb_target(ddbtcp,cmd) "ddb tcpX"
 230   set gdb_target(ddbtcp,runlist) {1 1 0 1}
 231   set gdb_target(ddbtcp,after_attaching) {}
 232
 233   # Picobug
 234   set gdb_target(picobug,pretty-name) "Picobug/Serial"
 235   set gdb_target(picobug,defbaud) "19200"
 236   set gdb_target(picobug,baud-rates) {19200}
 237   set gdb_target(picobug,cmd) "picobug com1"
 238   set gdb_target(picobug,runlist) {1 1 0 1}
 239   set gdb_target(picobug,after_attaching) {}
 240   set gdb_target(picobugtcp,pretty-name) "Picobug/TCP"
 241   set gdb_target(picobugtcp,defbaud) "TCP"
 242   set gdb_target(picobugtcp,baud-rates) {}
 243   set gdb_target(picobugtcp,cmd) "picobug tcpX"
 244   set gdb_target(picobugtcp,runlist) {1 1 0 1}
 245   set gdb_target(picobugtcp,after_attaching) {}
 246
 247   # Cisco.
 248   set gdb_target(cisco,pretty-name) "Cisco/Serial"
 249   set gdb_target(cisco,defbaud) "38400"
 250   set gdb_target(cisco,baud-rates) {9600 19200 38400 56000}
 251   set gdb_target(cisco,cmd) "cisco com1"
 252   set gdb_target(cisco,runlist) {1 0 0 0}
 253   set gdb_target(cisco,after_attaching) "set os cisco"
 254   set gdb_target(ciscotcp,pretty-name) "Cisco/TCP"
 255   set gdb_target(ciscotcp,defbaud) "TCP"
 256   set gdb_target(ciscotcp,baud-rates) {}
 257   set gdb_target(ciscotcp,cmd) "cisco tcpX"
 258   set gdb_target(ciscotcp,runlist) {1 0 0 0}
 259   set gdb_target(ciscotcp,after_attaching) "set os cisco"
 260
 261   # VxWorks
 262   set gdb_target(vxworks,pretty-name) "VxWorks RDB"
 263   set gdb_target(vxworks,defbaud) "ETH"
 264   set gdb_target(vxworks,baud-rates) {}
 265   set gdb_target(vxworks,cmd) "vxworks ethX"
 266   set gdb_target(vxworks,runlist) { 1 0 1 1}
 267   set gdb_target(vxworks,after_attaching) { sym vxWorks.st }
 268
 269   # GDBServer, libremote, rda, etc
 270   set gdb_target(gdbserver,pretty-name) "GDBserver"
 271   set gdb_target(gdbserver,pretty-name) "GDBserver/Serial"
 272   set gdb_target(gdbserver,defbaud) "9600"
 273   set gdb_target(gdbserver,baud-rates) {9600 19200 38400 57600 115200}
 274   set gdb_target(gdbserver,cmd) "remote com1"
 275   set gdb_target(gdbserver,runlist) {1 0 0 1}
 276   set gdb_target(gdbserver,after_attaching) {}
 277   set gdb_target(gdbservertcp,pretty-name) "GDBserver/TCP"
 278   set gdb_target(gdbservertcp,defbaud) "TCP"
 279   set gdb_target(gdbservertcp,baud-rates) {}
 280   set gdb_target(gdbservertcp,cmd) "remote tcpX"
 281   set gdb_target(gdbservertcp,runlist) {1 0 0 1}
 282   set gdb_target(gdbservertcp,after_attaching) {}
 283 }
 284
 285 itcl::body TargetSelection::default_port {} {
 286   global gdbtk_platform
 287   switch -regexp $gdbtk_platform(os) {
 288     cygwin  { set port /dev/com1 }
 289     mingw   { set port COM1 }
 290     Linux   { set port /dev/ttyS0 }
 291     SunOS   { set port /dev/ttya }
 292     AIX     { set port /dev/foo1 }
 293     ULTRIX  { set port /dev/foo1 }
 294     IRIX    { set port /dev/foo1 }
 295     OSF1    { set port /dev/foo1 }
 296     NetBSD  { set port /dev/foo1 }
 297     HP-UX   {
 298       # Special case...
 299       switch -regexp $gdbtk_platform(osVersion) {
 300         A.09 { set port /dev/tty00 }
 301         B.10 -
 302         B.11 { set port /dev/tty0p0 }
 303       }
 304     }
 305     default { set port /dev/ttya }
 306   }
 307
 308   return $port
 309 }
 310
 311
 312 itcl::body TargetSelection::_init_prefs {} {
 313
 314   if {$prefs_inited} {
 315     return
 316   }
 317   set prefs_inited 1
 318
 319   # these are not target-specific
 320
 321   pref define gdb/load/main 1
 322   pref define gdb/load/exit 1
 323   pref define gdb/load/check 0
 324
 325   # these are target-specific
 326   # set up the defaults
 327   pref define gdb/load/default-verbose 0
 328   pref define gdb/load/default-port [default_port]
 329   pref define gdb/load/default-hostname ""
 330   pref define gdb/load/default-after_attaching {}
 331   pref define gdb/load/default-portname 32767
 332 }
 333
 334 itcl::body TargetSelection::_init_target {} {
 335   global gdb_target_name
 336   set target_list [get_target_list]
 337   set target $gdb_target_name
 338
 339   # target = CANCEL should never come into here.  If the target was
 340   # returned as CANCEL, it should be fixed by the caller...  But it
 341   # should not be harmful if it gets in here.
 342
 343   if {$target == "" || [string compare $target CANCEL] == 0} {
 344     set target default
 345   }
 346
 347   set defbaud $gdb_target($target,defbaud)
 348   pref define gdb/load/$target-baud $defbaud
 349   pref define gdb/load/$target-port [pref get gdb/load/default-port]
 350   pref define gdb/load/$target-verbose [pref get gdb/load/default-verbose]
 351   pref define gdb/load/$target-portname 1000
 352   pref define gdb/load/$target-hostname [pref get gdb/load/default-hostname]
 353
 354   set err [catch {pref get gdb/load/$target-runlist} run_list]
 355   if {$err} {
 356     set run_list $gdb_target($target,runlist)
 357     pref setd gdb/load/$target-runlist $run_list
 358   }
 359   pref set gdb/src/run_attach [lindex $run_list 0]
 360   pref set gdb/src/run_load   [lindex $run_list 1]
 361   pref set gdb/src/run_run    [lindex $run_list 2]
 362   pref set gdb/src/run_cont   [lindex $run_list 3]
 363
 364   set err [catch {pref get gdb/load/$target-after_attaching} aa]
 365   if {$err} {
 366     set aa $gdb_target($target,after_attaching)
 367     pref setd gdb/load/$target-after_attaching $aa
 368   }
 369 }
 370
 371 itcl::body TargetSelection::_init {} {
 372
 373   if {!$trace_inited} {
 374     # Trace all gdb_loaded changes based on target
 375     trace variable gdb_loaded w [code TargetSelection::target_trace]
 376   }
 377   set trace_inited 1
 378
 379   init_target_db        ;# initialize database
 380   _init_target  ;# initialize target prefs
 381   set_saved
 382
 383   # This tells us that the target system is inited.  Some of these
 384   # init functions need to be called every time the target dialog is
 385   # posted, some only once.  The latter functions can check inited to
 386   # see what they should do.
 387
 388 }
 389
 390 # ------------------------------------------------------------------
 391 #  METHOD:  build_win - build the dialog
 392 # ------------------------------------------------------------------
 393 itcl::body TargetSelection::build_win {} {
 394   global gdbtk_platform PREFS_state gdb_ImageDir gdb_target_name
 395
 396   set f [frame $itk_interior.f]
 397   set opts [frame $itk_interior.moreoptions]
 398   frame $itk_interior.moreoptionsframe
 399   set btns [frame $itk_interior.buttons]
 400
 401   #labelled frame "Connection"
 402   iwidgets::Labeledframe $f.lab -labelpos nw -labeltext [gettext "Connection"]
 403   set fr [$f.lab childsite]
 404
 405   # target name
 406   label $fr.tarl -text [gettext "Target:"]
 407   combobox::combobox $fr.tar -editable 0 -command [code $this change_target] \
 408     -width $Width -maxheight 10 -bg $::Colors(textbg)
 409
 410   # baud rate combobox
 411   label $fr.cbl -text [gettext "Baud Rate:"]
 412   combobox::combobox $fr.cb -editable 0 -command [code $this change_baud] \
 413     -textvariable [pref varname gdb/load/$target-baud] -width $Width \
 414     -maxheight 10 -bg $::Colors(textbg)
 415
 416   if {[catch {gdb_cmd "show remotebaud"} res]} {
 417     set baud [pref get gdb/load/$target-baud]
 418   } else {
 419     set baud [lindex $res end]
 420     set baud [string trimright $baud "."]
 421     # When uninitialized, GDB returns a baud rate of 2^32
 422     # Detect this and ignore it.
 423     if {$baud > 4000000000} {
 424       set baud [pref get gdb/load/$target-baud]
 425     } else {
 426       pref setd gdb/load/$target-baud $baud
 427     }
 428   }
 429
 430   # host entry widget
 431   entry $fr.host -textvariable [pref varname gdb/load/$target-hostname] \
 432     -width $Width
 433
 434   # port combobox
 435   if {$gdbtk_platform(platform) == "windows"} {
 436     set editable 0
 437   } else {
 438     set editable 1
 439   }
 440
 441   label $fr.portl -text [gettext "Port:"]
 442   combobox::combobox $fr.port -editable $editable \
 443     -textvariable [pref varname gdb/load/$target-port] \
 444     -width $Width -maxheight 10 -bg $::Colors(textbg)
 445
 446   # load baud rates into combobox
 447   fill_rates
 448
 449   # load port combobox
 450   if {$gdbtk_platform(platform) == "windows"} {
 451     foreach val [port_list] {
 452       $fr.port list insert end $val
 453     }
 454   } else {
 455     # fixme:  how do I find valid values for these????
 456     switch $gdbtk_platform(os) {
 457       Linux { set ports [list /dev/cua0 /dev/ttyS0 /dev/ttyS1 /dev/ttyS2 /dev/ttyS3]}
 458       SunOS { set ports [list /dev/ttya /dev/ttyb] }
 459       AIX   { set ports [list /dev/foo1 /dev/foo2] }
 460       ULTRIX { set ports [list /dev/foo1 /dev/foo2] }
 461       IRIX   { set ports [list /dev/foo1 /dev/foo2] }
 462       OSF1   { set ports [list /dev/foo1 /dev/foo2] }
 463       NetBSD { set ports [list /dev/foo1 /dev/foo2] }
 464       HP-UX  {
 465         # Special case...
 466         switch -regexp $gdbtk_platform(osVersion) {
 467           A.09 { set ports [list /dev/tty00 /dev/tty01] }
 468           B.10 -
 469           B.11 { set ports [list /dev/tty0p0 /dev/tty1p0] }
 470         }
 471       }
 472       default { set ports [list UNKNOWN UNKNOWN] }
 473     }
 474     foreach val $ports {
 475       $fr.port list insert end $val
 476     }
 477   }
 478
 479   # Port entry widget
 480   entry $fr.porte -textvariable [pref varname gdb/load/$target-port] -width $Width
 481
 482   frame $f.fr
 483   checkbutton $f.fr.main -text [gettext "Set breakpoint at 'main'"] \
 484     -variable [pref varname gdb/load/main]
 485   checkbutton $f.fr.exit -text [gettext "Set breakpoint at 'exit'"] \
 486     -variable [pref varname gdb/load/exit]
 487   frame $f.fr.bp
 488   checkbutton $f.fr.bp.at_func -text [gettext "Set breakpoint at"] \
 489     -variable [pref varname gdb/load/bp_at_func]
 490   entry $f.fr.bp.func -textvariable [pref varname gdb/load/bp_func] -width 20
 491   checkbutton $f.fr.verb -text [gettext "Display Download Dialog"] \
 492     -variable [pref varname gdb/load/$target-verbose]
 493
 494   if {$gdbtk_platform(platform) == "unix"} {
 495     checkbutton $f.fr.xterm -text [gettext "Use xterm as inferior's tty"] \
 496         -variable [pref varname gdb/process/xtermtty] \
 497         -onvalue yes -offvalue no
 498   }
 499
 500   if {![pref get gdb/control_target]} {
 501     $f.fr.main configure -state disabled
 502     $f.fr.exit configure -state disabled
 503     $f.fr.verb configure -state disabled
 504     $f.fr.bp.at_func configure -state disabled
 505     $f.fr.bp.func configure -state disabled
 506     checkbutton $f.fr.check -text [gettext "Compare to remote executable"] \
 507       -variable [pref varname gdb/load/check]
 508     if { $gdb_target_name == "exec" } {
 509       $f.fr.check configure -state disabled
 510     }
 511   }
 512
 513   grid $fr.tarl $fr.tar -sticky w -padx 5 -pady 5
 514   grid $fr.cbl $fr.cb -sticky w -padx 5 -pady 5
 515   grid $fr.portl $fr.port -sticky w -padx 5 -pady 5
 516   set mapped1 $fr.cb
 517   set mapped2 $fr.port
 518
 519   grid $f.fr.main -sticky w -padx 5 -pady 5
 520   grid $f.fr.exit -sticky w -padx 5 -pady 5
 521   pack $f.fr.bp.at_func $f.fr.bp.func -side left
 522   grid $f.fr.bp -sticky w -padx 5 -pady 5
 523   grid $f.fr.verb -sticky w -padx 5 -pady 5
 524   if {$gdbtk_platform(platform) == "unix"} {
 525     grid $f.fr.xterm -sticky w -padx 5 -pady 5
 526   }
 527   if {![pref get gdb/control_target]} {
 528     grid $f.fr.check -sticky w -padx 5 -pady 5
 529   }
 530
 531   grid $f.lab $f.fr -sticky w -padx 5 -pady 5
 532
 533   # Create the "More Options" thingy
 534   if {[lsearch [image names] _MORE_] == -1} {
 535     image create photo _MORE_ -file [file join $gdb_ImageDir more.gif]
 536     image create photo _LESS_ -file [file join $gdb_ImageDir less.gif]
 537   }
 538
 539   set MoreButton [button $opts.button -image _MORE_ \
 540                     -relief flat -command [code $this toggle_more_options]]
 541   set MoreLabel [label $opts.lbl -text {More Options}]
 542   frame $opts.frame -relief raised -bd 1
 543   pack $opts.button $opts.lbl -side left
 544   place $opts.frame -relx 1 -x -10 -rely 0.5 -relwidth 0.73 -height 2 -anchor e
 545
 546   # Create the (hidden) more options frame
 547   set MoreFrame [iwidgets::Labeledframe $itk_interior.moreoptionsframe.frame \
 548                    -labelpos nw -labeltext {Run Options}]
 549   set frame [$MoreFrame childsite]
 550
 551   set var [pref varname gdb/src/run_attach]
 552   checkbutton $frame.attach -text {Attach to Target} -variable $var
 553
 554   set var [pref varname gdb/src/run_load]
 555   checkbutton $frame.load -text {Download Program} -variable $var
 556
 557   set rm_frame [iwidgets::labeledframe $frame.run_method -labelpos nw -labeltext "Run Method" ]
 558   set RunMethod [ $rm_frame childsite ]
 559
 560   set var [pref varname gdb/src/run_cont]
 561   radiobutton $RunMethod.cont -text {Continue from Last Stop} -value 1 -variable $var \
 562     -command [code $this set_run run]
 563
 564   set var [pref varname gdb/src/run_run]
 565   radiobutton $RunMethod.run -text {Run Program} -value 1 -variable $var \
 566     -command [code $this set_run cont]
 567
 568   # The after attaching command entry
 569   set _after_entry [entry $frame.aftere]
 570   label $frame.afterl -text {Command to issue after attaching:}
 571
 572   grid $frame.attach -column 0 -row 1 -padx 10 -sticky w
 573   grid $frame.load -column 0 -row 2 -padx 10 -sticky w
 574
 575   grid $RunMethod.run -column 0 -row 1 -sticky w -ipady 2
 576   grid $RunMethod.cont -column 0 -row 2 -sticky w -ipady 2
 577
 578   grid $rm_frame -column 1 -row 1 -rowspan 2 -sticky nsew -ipady 2
 579
 580   grid $frame.afterl -row 4 -sticky we -columnspan 2 -ipady 2
 581   grid $frame.aftere -sticky we -columnspan 2 -ipady 2
 582   grid columnconfigure $frame 0 -weight 1
 583   grid columnconfigure $frame 1 -weight 1
 584
 585   # Map everything onto the screen
 586   # This looks like a possible packing bug -- our topmost frame
 587   # will not resize itself. So, instead, use the topmost frame.
 588   #pack $f $opts $itk_interior.moreoptionsframe -side top -fill x
 589   pack $MoreFrame -fill x -expand yes
 590   pack $f $opts -side top -fill x
 591
 592   change_target $gdb_target($target,pretty-name)
 593
 594   button $btns.ok -text [gettext OK] -width 7 -command [code $this save] \
 595     -default active
 596   button $btns.cancel -text [gettext Cancel] -width 7 \
 597     -command [code $this cancel]
 598   button $btns.help -text [gettext Help] -width 7 -command [code $this help]
 599
 600   standard_button_box $btns
 601   bind $btns.ok <Return> "$btns.ok flash; $btns.ok invoke"
 602   bind $btns.cancel <Return> "$btns.cancel flash; $btns.cancel invoke"
 603   bind $btns.help <Return> "$btns.help flash; $btns.help invoke"
 604
 605   pack $btns -side bottom -anchor e
 606   focus $btns.ok
 607
 608   # set up balloon help
 609   balloon register $f.fr.bp.at_func "Set User-Speficied Breakpoints at Run Time"
 610   balloon register $f.fr.bp.func "Enter a List of Functions for Breakpoints"
 611
 612   window_name "Target Selection"
 613
 614   if {[valid_target $target]} {
 615     $fr.tar configure -value $gdb_target($target,pretty-name)
 616   }
 617   fill_targets
 618
 619
 620 }
 621
 622 # ------------------------------------------------------------------
 623 #  METHOD:  set_saved - set saved values
 624 # ------------------------------------------------------------------
 625 itcl::body TargetSelection::set_saved {} {
 626   set saved_baud [pref get gdb/load/$target-baud]
 627   set saved_port [pref get gdb/load/$target-port]
 628   set saved_main [pref get gdb/load/main]
 629   set saved_exit [pref get gdb/load/exit]
 630   set saved_check [pref get gdb/load/check]
 631   set saved_verb [pref get gdb/load/$target-verbose]
 632   set saved_portname [pref get gdb/load/$target-portname]
 633   set saved_hostname [pref get gdb/load/$target-hostname]
 634   set saved_attach [pref get gdb/src/run_attach]
 635   set saved_load   [pref get gdb/src/run_load]
 636   set saved_run    [pref get gdb/src/run_run]
 637   set saved_cont   [pref get gdb/src/run_cont]
 638   if {[info exists gdb_target($target,options)]} {
 639     if {[catch {pref get gdb/load/$target-opts} saved_options]} {
 640       set saved_options ""
 641     }
 642   }
 643 }
 644
 645 # ------------------------------------------------------------------
 646 #  METHOD:  write_saved - write saved values to preferences
 647 # ------------------------------------------------------------------
 648 itcl::body TargetSelection::write_saved {} {
 649   pref setd gdb/load/$target-baud $saved_baud
 650   pref setd gdb/load/$target-port $saved_port
 651   pref setd gdb/load/main $saved_main
 652   pref setd gdb/load/exit $saved_exit
 653   pref setd gdb/load/check $saved_check
 654   pref setd gdb/load/$target-verbose $saved_verb
 655   pref setd gdb/load/$target-portname $saved_portname
 656   pref setd gdb/load/$target-hostname $saved_hostname
 657   pref setd gdb/load/$target-runlist [list $saved_attach $saved_load $saved_run $saved_cont]
 658   if {[info exists gdb_target($target,options)]} {
 659     pref setd gdb/load/$target-opts $saved_options
 660   }
 661   if {[catch {$_after_entry get} saved_after_attaching]} {
 662     set saved_after_attaching ""
 663   }
 664   pref setd gdb/load/$target-after_attaching $saved_after_attaching
 665 }
 666
 667 # ------------------------------------------------------------------
 668 #  METHOD:  fill_rates - fill baud rate combobox
 669 # ------------------------------------------------------------------
 670 itcl::body TargetSelection::fill_rates {} {
 671   $fr.cb list delete 0 end
 672
 673   if {$gdb_target($target,baud-rates) != ""} {
 674     foreach val $gdb_target($target,baud-rates) {
 675       $fr.cb list insert end $val
 676     }
 677   }
 678 }
 679
 680 # ------------------------------------------------------------------
 681 #  METHOD:  fill_targets - fill target combobox
 682 # ------------------------------------------------------------------
 683 itcl::body TargetSelection::fill_targets {} {
 684   #[$fr.tar subwidget listbox] delete 0 end
 685   $fr.tar list delete 0 end
 686
 687   foreach val $target_list {
 688     if {[info exists gdb_target($val,pretty-name)]} {
 689       $fr.tar list insert end $gdb_target($val,pretty-name)
 690
 691       # Insert TCP target, if it exists
 692       if {[info exists gdb_target(${val}tcp,pretty-name)]} {
 693         $fr.tar list insert end $gdb_target(${val}tcp,pretty-name)
 694       }
 695     }
 696   }
 697 }
 698
 699 # ------------------------------------------------------------------
 700 #  METHOD:  config_dialog - Convenience method to map/unmap/rename
 701 #            components onto the screen based on target T.
 702 # ------------------------------------------------------------------
 703 itcl::body TargetSelection::config_dialog {t} {
 704   pref define gdb/load/$t-verbose [pref get gdb/load/verbose]
 705   $f.fr.verb config -variable [pref varname gdb/load/$t-verbose]
 706   # Map the correct entries and comboboxes onto the screen
 707   if {$gdb_target($t,defbaud) == "TCP"} {
 708     # we have a tcp target
 709     # map host and porte
 710     if {$mapped1 != "$fr.host"} {
 711       grid forget $mapped1
 712       set mapped1 $fr.host
 713       grid $mapped1 -row 1 -column 1 -sticky w -padx 5 -pady 5
 714     }
 715     $fr.cbl configure -text "Hostname:"
 716     $fr.host config -textvariable [pref varname gdb/load/$t-hostname]
 717
 718     if {$mapped2 != "$fr.porte"} {
 719       grid forget $mapped2
 720       set mapped2 $fr.porte
 721       grid $mapped2 -row 2 -column 1 -sticky w -padx 5 -pady 5
 722     }
 723     $fr.portl configure -text {Port:}
 724     $fr.porte config -textvariable [pref varname gdb/load/$t-portname] -fg black
 725
 726     $mapped1 configure -state normal
 727     $mapped2 configure -state normal
 728   } elseif {$gdb_target($t,defbaud) == "ETH"} {
 729     # we have a udp target
 730     # map host and porte
 731     if {$mapped1 != "$fr.host"} {
 732       grid forget $mapped1
 733       set mapped1 $fr.host
 734       grid $mapped1 -row 1 -column 1 -sticky w -padx 5 -pady 5
 735     }
 736     $fr.cbl configure -text "Hostname:"
 737     $fr.host config -textvariable [pref varname gdb/load/$t-hostname]
 738
 739     if {$mapped2 != "$fr.porte"} {
 740       grid forget $mapped2
 741     }
 742     $fr.portl configure -text {Port: N/A (fixed)}
 743
 744     $mapped1 configure -state normal
 745     $mapped2 configure -state disabled
 746   } elseif {$gdb_target($t,defbaud) != ""} {
 747     # we have a serial target
 748     # map port and cb
 749     if {$mapped1 != "$fr.cb"} {
 750       grid forget $mapped1
 751       set mapped1 $fr.cb
 752       grid $mapped1 -row 1 -column 1 -sticky w -padx 5 -pady 5
 753     }
 754     $fr.cbl configure -text "Baud Rate:"
 755     $fr.cb configure -textvariable [pref varname gdb/load/$t-baud]
 756
 757     if {$mapped2 != "$fr.port"} {
 758       grid forget $mapped2
 759       set mapped2 $fr.port
 760       grid $mapped2 -row 2 -column 1 -sticky w -padx 5 -pady 5
 761     }
 762     $fr.portl configure -text {Port:}
 763     $fr.port configure -textvariable [pref varname gdb/load/$t-port]
 764
 765     $mapped1 configure -state normal
 766     $mapped2 configure -state normal
 767   } else {
 768     # we have a non-remote(-like) target
 769     # disable all (except tar) and check for
 770     # options
 771     $mapped1 configure -state disabled
 772     $mapped2 configure -state disabled
 773     $fr.porte configure -fg gray
 774
 775     if {[info exists gdb_target($t,options)]} {
 776       if {$mapped1 != "$fr.host"} {
 777         grid forget $mapped1
 778         set mapped1 $fr.host
 779         grid $mapped1 -row 1 -column 1 -sticky w -padx 5 -pady 5
 780       }
 781       $mapped1 configure -state normal
 782       $fr.host config -textvariable [pref varname gdb/load/$t-opts]
 783
 784       # We call options "arguments" for the exec target
 785       # FIXME: this is really overloaded!!
 786       if {$t == "exec"} {
 787         set text "Arguments:"
 788       } else {
 789         set text "Options:"
 790       }
 791       $fr.cbl configure -text $text
 792     }
 793   }
 794 }
 795
 796 # ------------------------------------------------------------------
 797 #  METHOD:  change_target - callback for target combobox
 798 # ------------------------------------------------------------------
 799 itcl::body TargetSelection::change_target {w {name ""}} {
 800   if {$name == ""} {return}
 801   set target [get_target $name]
 802
 803   if { "$target" == "exec" } {
 804     $RunMethod.run configure -state disabled -value 1
 805     $RunMethod.cont configure -state disabled
 806   } else {
 807     $RunMethod.run configure -state normal
 808     $RunMethod.cont configure -state normal
 809   }
 810
 811   debug "$target"
 812   set defbaud $gdb_target($target,defbaud)
 813   pref define gdb/load/$target-baud $defbaud
 814   pref define gdb/load/$target-portname 1000
 815   pref define gdb/load/$target-hostname [pref get gdb/load/default-hostname]
 816   if {$defbaud == ""} {
 817     pref define gdb/load/$target-port ""
 818   } else {
 819     pref define gdb/load/$target-port [pref get gdb/load/default-port]
 820   }
 821
 822   config_dialog $target
 823   fill_rates
 824
 825   # Configure the default run options for this target
 826   set err [catch {pref get gdb/load/$target-runlist} run_list]
 827   if {$err} {
 828     set run_list $gdb_target($target,runlist)
 829     pref setd gdb/load/$target-runlist $run_list
 830   }
 831
 832   pref set gdb/src/run_attach [lindex $run_list 0]
 833   pref set gdb/src/run_load   [lindex $run_list 1]
 834   pref set gdb/src/run_run    [lindex $run_list 2]
 835   pref set gdb/src/run_cont   [lindex $run_list 3]
 836   set_check_button $name
 837
 838   set err [catch {pref get gdb/load/$target-after_attaching} aa]
 839   if {$err} {
 840     set aa $gdb_target($target,after_attaching)
 841     pref setd gdb/load/$target-after_attaching $aa
 842   }
 843
 844   $_after_entry delete 0 end
 845   $_after_entry insert 0 $aa
 846
 847   set_saved
 848
 849   set changes 0
 850 }
 851
 852 # ------------------------------------------------------------------
 853 #  PRIVATE METHOD:  change_baud - called when the baud rate is changed.
 854 #  If GDB is running, set baud rate in GDB and read it back.
 855 # ------------------------------------------------------------------
 856 itcl::body TargetSelection::change_baud {w {baud ""}} {
 857   if {$baud != ""} {
 858     if {([string compare $baud "TCP"] != 0)
 859         && ([string compare $baud "ETH"] != 0)} {
 860       gdb_cmd "set remotebaud $baud"
 861       if {[catch {gdb_cmd "show remotebaud"} res]} {
 862         set newbaud 0
 863       } else {
 864         set newbaud [lindex $res end]
 865         set newbaud [string trimright $newbaud "."]
 866         if {$newbaud > 4000000} {
 867           set newbaud 0
 868         }
 869       }
 870       if {$newbaud != $baud} {
 871         pref set gdb/load/$target-baud $newbaud
 872       }
 873     }
 874   }
 875 }
 876
 877
 878 # ------------------------------------------------------------------
 879 #  METHOD:  port_list - return a list of valid ports for Windows
 880 # ------------------------------------------------------------------
 881 itcl::body TargetSelection::port_list {} {
 882   global gdbtk_platform
 883   if {[string compare $gdbtk_platform(os) "cygwin"] == 0} {
 884     set device "/dev/com"
 885   } else {
 886     set device "COM"
 887   }
 888   set plist ""
 889   # Scan com1 - com8 trying to open each one.
 890   # If permission is denied that means it is in use,
 891   # which is OK because we may be using it or the user
 892   # may be setting up the remote target manually with
 893   # a terminal program.
 894   set quit 0
 895   for {set i 1} {!$quit} {incr i} {
 896     if {[catch { set fd [::open COM$i: RDWR] } msg]} {
 897       # Failed.  Find out why.
 898       if {[string first "permission denied" $msg] != -1} {
 899         # Port is there, but busy right now. That's OK.
 900         lappend plist $device$i
 901       } elseif {$i > 4} {
 902         # if we've scanned the first 4 ports, then quit when we find no more
 903         set quit 1
 904       }
 905     } else {
 906       # We got it.  Now close it and add to list.
 907       close $fd
 908       lappend plist $device$i
 909     }
 910   }
 911   return $plist
 912 }
 913
 914 # ------------------------------------------------------------------
 915 #  METHOD:  get_target_list - return a list of targets supported
 916 #  by this GDB.  Parses the output of "help target"
 917 # ------------------------------------------------------------------
 918 itcl::body TargetSelection::get_target_list {} {
 919   set native [native_debugging]
 920   set names ""
 921   set res [gdb_cmd "help target"]; # this just screams MI...
 922
 923   # targets are listed with lines like "target NAME -- DESCRIPTION"
 924   foreach line [split $res \n] {
 925     if {[scan $line "target %s --" name] == 1} {
 926       # For cross debuggers, do not allow the target "exec"
 927       if {$name == "exec" && !$native} {
 928         continue
 929       }
 930
 931       lappend names $name
 932     }
 933   }
 934
 935   lappend names gdbserver
 936   return [lsort $names]
 937 }
 938
 939 # ------------------------------------------------------------------
 940 #  METHOD:  save - save values
 941 # ------------------------------------------------------------------
 942 itcl::body TargetSelection::save {} {
 943   global gdb_target_name
 944   set err [catch {
 945     set_saved
 946     write_saved
 947     set gdb_target_name $target
 948     pref setd gdb/load/target $target
 949   } errtxt]
 950   if {$err} {debug "target: $errtxt"}
 951   if {[valid_target $gdb_target_name]} {
 952     # Dismiss the dialog box
 953     unpost
 954   } else {
 955     tk_messageBox -message "The current target is not valid."
 956   }
 957
 958 }
 959
 960
 961 # ------------------------------------------------------------------
 962 #  METHOD:  cancel - restore previous values
 963 # ------------------------------------------------------------------
 964 itcl::body TargetSelection::cancel {} {
 965   global gdb_target_name
 966   catch {gdb_cmd "set remotebaud $saved_baud"}
 967
 968   $fr.cb configure -value $saved_baud
 969   write_saved
 970   if {$exportcancel} {
 971     set gdb_target_name CANCEL
 972   }
 973
 974   # Now dismiss the dialog
 975   unpost
 976 }
 977
 978 # ------------------------------------------------------------------
 979 #  METHOD: set_check_button - enable/disable compare-section command
 980 # ------------------------------------------------------------------
 981 itcl::body TargetSelection::set_check_button {name} {
 982   if {[winfo exists  $itk_interior.f.fr.check]} {
 983     if { $name == "exec" } {
 984       $itk_interior.f.fr.check configure -state disabled
 985     } else {
 986       $itk_interior.f.fr.check configure -state normal
 987     }
 988   }
 989 }
 990
 991 # ------------------------------------------------------------------
 992 #  METHOD:  help - launches context sensitive help.
 993 # ------------------------------------------------------------------
 994 itcl::body TargetSelection::help {} {
 995   open_help target.html
 996 }
 997
 998 # ------------------------------------------------------------------
 999 #  METHOD:  reconfig - used when preferences change
1000 # ------------------------------------------------------------------
1001 itcl::body TargetSelection::reconfig {} {
1002   # for now, just delete and recreate
1003   destroy $itk_interior.f
1004   build_win
1005 }
1006
1007 # ------------------------------------------------------------------
1008 #  METHOD:  get_target - get the internal name of a target from the
1009 #              pretty-name
1010 # ------------------------------------------------------------------
1011 itcl::body TargetSelection::get_target {name} {
1012   set t {}
1013   set list [array get gdb_target *,pretty-name]
1014   set i [lsearch -exact $list $name]
1015   if {$i != -1} {
1016     incr i -1
1017     set t [lindex [split [lindex $list $i] ,] 0]
1018   } else {
1019     debug "unknown pretty-name \"$name\""
1020   }
1021   return $t
1022 }
1023
1024 # ------------------------------------------------------------------
1025 #  METHOD: toggle_more_options -- toggle displaying the  More/Fewer
1026 #                Options pane
1027 # ------------------------------------------------------------------
1028 itcl::body TargetSelection::toggle_more_options {} {
1029   if {[$MoreLabel cget -text] == "More Options"} {
1030     $MoreLabel configure -text "Fewer Options"
1031     $MoreButton configure -image _LESS_
1032     # Bug in Tk? The top-most frame does not shrink...
1033     #pack $MoreFrame
1034     pack $itk_interior.moreoptionsframe -after $itk_interior.moreoptions -fill both -padx 5 -pady 5
1035   } else {
1036     $MoreLabel configure -text "More Options"
1037     $MoreButton configure -image _MORE_
1038     #pack forget $MoreFrame
1039     pack forget $itk_interior.moreoptionsframe
1040   }
1041 }
1042
1043 # ------------------------------------------------------------------
1044 #  METHOD:  set_run - set the run button. Make sure not both run and
1045 #                     continue are selected.
1046 # ------------------------------------------------------------------
1047 itcl::body TargetSelection::set_run {check_which} {
1048   global PREFS_state
1049   set var [pref varname gdb/src/run_$check_which]
1050   global $var
1051   if {[set $var]} {
1052     set $var 0
1053   }
1054 }
1055
1056 # ------------------------------------------------------------------
1057 #   PROCEDURE: target_trace
1058 #          This procedure is used to configure gdb_loaded
1059 #          and possible more) whenever the value of gdb_loaded
1060 #          is changed based on the current target.
1061 # ------------------------------------------------------------------
1062 itcl::body TargetSelection::target_trace {variable index op} {
1063   global gdb_target_name gdb_loaded
1064
1065   switch $gdb_target_name {
1066
1067     exec {
1068       # The exec target is always loaded.
1069       set gdb_loaded 1
1070     }
1071   }
1072 }
1073
1074 # Returns 1 if TARGET is a _runnable_ target for this gdb.
1075 itcl::body TargetSelection::valid_target {target} {
1076
1077   # always allow gdbserver
1078   if {$target == "gdbserver"} {return 1}
1079
1080   set err [catch {gdb_cmd "help target $target"}]
1081   if {$target == "exec" && ![native_debugging]} {
1082     set err 1
1083   }
1084
1085   if {[regexp "tcp$" $target]} {
1086     # Special case (of course)
1087     regsub tcp$ $target {} foo
1088     return [valid_target $foo]
1089   }
1090
1091   return [expr {$err == 0}]
1092 }
1093
1094 # Returns 1 if this is not a cross debugger.
1095 itcl::body TargetSelection::native_debugging {} {
1096   global GDBStartup
1097
1098   set r [string compare $GDBStartup(host_name) $GDBStartup(target_name)]
1099   return [expr {!$r}]
1100 }