gdb/gdbtk/library/srcpref.itb

   1 # Source preferences dialog for Insight.
   2 # Copyright (C) 1998, 1999, 2002, 2003, 2008 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 #  CONSTRUCTOR - create new source preferences window
  17 # ------------------------------------------------------------------
  18 itcl::body SrcPref::constructor {args} {
  19   window_name "Source Preferences"
  20   _init_var
  21   _build_win
  22 }
  23
  24 # ------------------------------------------------------------------
  25 #  METHOD:  init_var - initialize preference variables
  26 # ------------------------------------------------------------------
  27 itcl::body SrcPref::_init_var {} {
  28   set vlist {gdb/src/PC_TAG gdb/src/STACK_TAG gdb/src/BROWSE_TAG
  29     gdb/src/run_attach gdb/src/run_load gdb/src/run_run
  30     gdb/src/run_cont gdb/src/bp_fg gdb/src/temp_bp_fg
  31     gdb/src/trace_fg gdb/src/thread_fg gdb/src/variableBalloons
  32     gdb/src/source2_fg gdb/src/tab_size gdb/mode gdb/editor
  33     gdb/B1_behavior}
  34
  35   foreach var $vlist {
  36     set _saved($var) [pref get $var]
  37     set _new($var) $_saved($var)
  38   }
  39 }
  40
  41
  42 # ------------------------------------------------------------------
  43 #  METHOD:  build_win - build the dialog
  44 # ------------------------------------------------------------------
  45 itcl::body SrcPref::_build_win {} {
  46   frame $itk_interior.f
  47   frame $itk_interior.f.a
  48   frame $itk_interior.f.b
  49   set f $itk_interior.f.a
  50
  51   # Colors frame
  52   set a [Labelledframe $f.colors]
  53   $a configure -anchor nw -text {Colors}
  54   set w [$f.colors get_frame]
  55
  56   set color [pref get gdb/src/PC_TAG]
  57   label $w.pcl -text {PC}
  58   button $w.pcb -text {     } -activebackground $color -bg $color \
  59     -command [code $this _pick $color $w.pcb PC_TAG]
  60
  61   set color [pref get gdb/src/STACK_TAG]
  62   label $w.stl -text {Stack}
  63   button $w.stb -text {     } -activebackground $color -bg $color \
  64     -command [code $this _pick $color $w.stb STACK_TAG]
  65
  66   set color [pref get gdb/src/BROWSE_TAG]
  67   label $w.brl -text {Browse}
  68   button $w.brb -text {     } -activebackground $color -bg $color\
  69     -command [code $this _pick $color $w.brb BROWSE_TAG]
  70
  71   set color [pref get gdb/src/source2_fg]
  72   label $w.s2l -text {Mixed Source}
  73   button $w.s2b -text {     } -activebackground $color -bg $color \
  74     -command [code $this _pick $color $w.s2b source2_fg]
  75
  76   set color [pref get gdb/src/bp_fg]
  77   label $w.nbpl -text {Normal Breakpoint}
  78   button $w.nbpb -text {     } -activebackground $color -bg $color\
  79     -command [code $this _pick $color $w.nbpb bp_fg]
  80
  81   set color [pref get gdb/src/temp_bp_fg]
  82   label $w.tbpl -text {Temporary Breakpoint}
  83   button $w.tbpb -text {     } -activebackground $color -bg $color \
  84     -command [code $this _pick $color $w.tbpb temp_bp_fg]
  85
  86   set color [pref get gdb/src/thread_fg]
  87   label $w.dbpl -text {Thread Breakpoint}
  88   button $w.dbpb -text {     } -activebackground $color -bg $color \
  89     -command [code $this _pick $color $w.dbpb thread_fg]
  90
  91   set color [pref get gdb/src/trace_fg]
  92   label $w.tpl -text {Tracepoint}
  93   button $w.tpb -text {     } -activebackground $color -bg $color \
  94     -command [code $this _pick $color $w.tpb trace_fg]
  95
  96   grid $w.pcl $w.pcb $w.nbpl $w.nbpb -padx 10 -pady 2 -sticky w
  97   grid $w.stl $w.stb $w.tbpl $w.tbpb -padx 10 -pady 2 -sticky w
  98   grid $w.brl $w.brb $w.dbpl $w.dbpb -padx 10 -pady 2 -sticky w
  99   grid $w.s2l $w.s2b $w.tpl  $w.tpb  -padx 10 -pady 2 -sticky w
 100
 101   frame $f.rmv
 102
 103   # Debug Mode frame
 104   set a [Labelledframe $f.rmv.mode]
 105   $a configure -anchor nw -text "Mouse Button-1 Behavior"
 106   set w [$f.rmv.mode get_frame]
 107
 108   if {[pref get gdb/mode]} {
 109     set state normal
 110   } else {
 111     pref set gdb/B1_behavior 1
 112     set state disabled
 113   }
 114
 115   radiobutton $w.async -text "Set/Clear Tracepoints"  \
 116     -variable [scope _new(gdb/B1_behavior)] -value 0 -state $state
 117   radiobutton $w.sync  -text "Set/Clear Breakpoints" \
 118     -variable [scope _new(gdb/B1_behavior)] -value 1 -state $state
 119
 120   pack $w.async $w.sync -side top
 121
 122   # Variable Balloons
 123   set a [Labelledframe $f.rmv.var]
 124   $a configure -anchor nw -text "Variable Balloons"
 125   set w [$f.rmv.var get_frame]
 126   set var _new(gdb/src/variableBalloons)
 127   radiobutton $w.var_on -text "On " -variable [scope $var] -value 1
 128   radiobutton $w.var_off -text "Off" -variable [scope $var] -value 0
 129   pack $w.var_on $w.var_off -side top
 130   grid $f.rmv.mode -sticky nsew -pady 5 -row 0 -column 0
 131   grid $f.rmv.var -sticky nsew -pady 5 -row 0 -column 2
 132   grid columnconfigure $f.rmv 0 -weight 1
 133   grid columnconfigure $f.rmv 1 -minsize 4
 134   grid columnconfigure $f.rmv 2 -weight 1
 135   grid rowconfigure $f.rmv 0 -weight 1
 136
 137
 138   frame $f.x
 139   # Tab size
 140   itk_component add size {
 141     iwidgets::spinint $f.x.size -labeltext "Tab Size" -range {1 16} \
 142       -step 1 -fixed 2 -width 2 -textvariable [scope _new(gdb/src/tab_size)] \
 143       -wrap 0 -textbackground $::Colors(textbg)
 144   }
 145   $f.x.size delete 0 end
 146   $f.x.size insert end $_saved(gdb/src/tab_size)
 147
 148   # Linenumbers
 149   # commented out because this option isn't really useful
 150 #  checkbutton $f.x.linenum -text "Line Numbers" \
 151 #    -variable [pref varname gdb/src/linenums]
 152 #  pack $f.x.size $f.x.linenum -side left -padx 5 -pady 5
 153   pack $f.x.size -side left -padx 5 -pady 5
 154
 155   # Disassembly flavor - We tell whether this architecture supports
 156   # the flag by checking whether the flag exists.
 157
 158   set have_disassembly_flavor 0
 159   set vals [list_disassembly_flavors]
 160   if {[llength $vals] != 0} {
 161     set have_disassembly_flavor 1
 162     frame $f.dis
 163     label $f.dis.l -text "Disassembly Flavor: "
 164     combobox::combobox $f.dis.combo -maxheight 15 -width 15 \
 165       -font global/fixed -editable 0 -command [code $this _set_flavor] \
 166       -bg $::Colors(textbg)
 167
 168     foreach elem $vals {
 169       $f.dis.combo list insert end $elem
 170     }
 171
 172     set _saved_disassembly_flavor [get_disassembly_flavor]
 173     $f.dis.combo entryset $_saved_disassembly_flavor
 174
 175     pack $f.dis.l -side left
 176     pack $f.dis.combo -side left -padx 4
 177
 178   } else {
 179     set _saved_disassembly_flavor ""
 180   }
 181
 182   # External editor.
 183   frame $f.exted
 184   label $f.exted.l -text "External Editor: "
 185   entry $f.exted.e -width 40 -textvariable [scope _new(gdb/editor)]
 186   pack $f.exted.l -side left
 187   pack $f.exted.e -side left -padx 4
 188
 189   pack $f.colors -fill both -expand 1
 190   pack $f.rmv  -fill both -expand yes
 191   pack $f.x -fill x -expand yes
 192
 193   if {$have_disassembly_flavor} {
 194     pack $f.dis -side top -fill x -padx 4
 195   }
 196
 197   pack $f.exted -side top -fill x -padx 4 -pady 4
 198
 199   button $itk_interior.f.b.ok -text OK -width 7 -underline 0 -command [code $this _save]
 200   button $itk_interior.f.b.apply -text Apply -width 7 -underline 0 -command [code $this _apply]
 201   button $itk_interior.f.b.quit -text Cancel -width 7 -underline 0 -command [code $this _cancel]
 202   standard_button_box $itk_interior.f.b
 203   pack $itk_interior.f.a $itk_interior.f.b $itk_interior.f -expand yes -fill both -padx 5 -pady 5
 204 }
 205
 206 # ------------------------------------------------------------------
 207 #  METHOD:  apply - apply changes
 208 # ------------------------------------------------------------------
 209 itcl::body SrcPref::_apply {} {
 210   foreach var [array names _new] {
 211     if {$_new($var) != [pref get $var]} {
 212       #debug "$var = $_new($var)"
 213       pref set $var $_new($var)
 214     }
 215   }
 216   if {$_new_disassembly_flavor != ""} {
 217     gdb_cmd "set disassembly-flavor $_new_disassembly_flavor"
 218     pref set gdb/src/disassembly-flavor $_new_disassembly_flavor
 219   }
 220   ManagedWin::restart
 221 }
 222
 223 itcl::body SrcPref::cancel {} {
 224   _save
 225 }
 226
 227 # ------------------------------------------------------------------
 228 #  METHOD:  _cancel
 229 # ------------------------------------------------------------------
 230 itcl::body SrcPref::_cancel {} {
 231   set any_changed 0
 232
 233   foreach elem [array names _saved] {
 234     set cur_val [pref get $elem]
 235     if {[string compare $cur_val $_saved($elem)] != 0} {
 236       set any_changed 1
 237       pref set $elem $_saved($elem)
 238     }
 239   }
 240
 241   if {$_new_disassembly_flavor != ""} {
 242     set any_changed 1
 243     gdb_cmd "set disassembly-flavor $_saved_disassembly_flavor"
 244     pref set gdb/src/disassembly-flavor $_saved_disassembly_flavor
 245   }
 246
 247   if {$any_changed} {
 248     ManagedWin::restart
 249   }
 250   unpost
 251 }
 252
 253 # ------------------------------------------------------------------
 254 #  METHOD:  save - apply changes and quit
 255 # ------------------------------------------------------------------
 256 itcl::body SrcPref::_save {} {
 257   _apply
 258   unpost
 259 }
 260
 261 # ------------------------------------------------------------------
 262 #  METHOD:  _set_flavor - sets the disassembly flavor.  The set disassembly-flavor
 263 #           gdb command is already known to exist, so I don't have to check...
 264 # ------------------------------------------------------------------
 265 itcl::body SrcPref::_set_flavor {w new_mode} {
 266   $w entryset $new_mode
 267   set _new_disassembly_flavor $new_mode
 268 }
 269
 270
 271 # ------------------------------------------------------------------
 272 #  METHOD:  pick - pick colors
 273 # ------------------------------------------------------------------
 274 itcl::body SrcPref::_pick {color win tag} {
 275   set new_color [tk_chooseColor -initialcolor $color -title "Choose color"]
 276   if {$new_color != $color && $new_color != {}} {
 277     set _new(gdb/src/$tag) $new_color
 278     $win configure -activebackground $new_color -bg $new_color
 279   }
 280 }
 281