share/insight1.0/globalpref.itb

# Global preference class implementation for Insight.
# Copyright (C) 1997, 1998, 1999, 2002, 2003, 2004, 2008 Red Hat
#
# 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.


# ----------------------------------------------------------------------
# Implements Global preferences dialog
#
# ----------------------------------------------------------------------

# ------------------------------------------------------------------
#  METHOD:  _init - set up the tracing labels info
# ------------------------------------------------------------------
itcl::body GlobalPref::_init {} {
  if {$inited} {
    return
  }
  
  set inited 1
  
  array set tracing_labels {
    0 "Tracing features disabled"
    1 "Tracing features enabled"
    max_len 0
  }
  
  foreach elem [array names tracing_labels] {
    set len [string length $tracing_labels($elem)]
    set tracing_labels(max_len) \
      [expr $len > $tracing_labels(max_len) ? $len : $tracing_labels(max_len) ]
  }
}

# ------------------------------------------------------------------
#  METHOD:  init_var - initialize preference variables
# ------------------------------------------------------------------
itcl::body GlobalPref::_init_var {} {
  set vlist {gdb/ImageDir gdb/console/wrap gdb/mode gdb/use_icons gdb/compat gdb/use_color_schemes}

  foreach var $vlist {
    set _saved($var) [pref get $var]
    set _new($var) $_saved($var)
  }
}

# ------------------------------------------------------------------
#  METHOD:  constructor - create the Global Preferences object
# ------------------------------------------------------------------
itcl::body GlobalPref::constructor {args} {    
  window_name "Global Preferences"
  _init
  _init_var
  _build_win
  eval itk_initialize $args
}

# ------------------------------------------------------------------
#  METHOD:  destructor - destroy the Global Preferences object
# ------------------------------------------------------------------
itcl::body GlobalPref::destructor {} {
  foreach thunk $_fonts {
    font delete test-$thunk-font
  }
}

# ------------------------------------------------------------------
#  METHOD:  _build_win - build the dialog
# ------------------------------------------------------------------
itcl::body GlobalPref::_build_win {} {
  global gdbtk_platform GDBTK_LIBRARY
  debug
  frame $itk_interior.f
  frame $itk_interior.x
  set frame $itk_interior.f
  
  # Icons
  frame $frame.icons
  label $frame.icons.lab -text "Icons "
  combobox::combobox $frame.icons.cb -editable 0 -maxheight 10\
    -command [code $this _change_icons] -bg $::Colors(textbg)
  
  # get list of icon directories
  set curdir [pwd]
  set _icondirlist ""
  cd $GDBTK_LIBRARY
  foreach foo [glob -- *] {
    if {[file isdirectory $foo] && [file exists [file join $foo "icons.txt"]]} {
      lappend _icondirlist $foo
    }
  }

  set width 14
  # load combobox
  foreach dir $_icondirlist {
    if {![string compare $dir $_saved(gdb/ImageDir)]} {
      set cdir 1
    } else {
      set cdir 0
    }
    set foo [file join $dir "icons.txt"]
    if {[catch {::open $foo r} fid]} {
      # failed
      dbug E "couldn't open $foo:$fid"
      if {$cdir} {$frame.icons.cb entryset "unknown icons"}
      $frame.icons.cb list insert end "unknown icons"
    } else {
      if {[gets $fid txt] >= 0} {
	if {$cdir} {$frame.icons.cb entryset $txt}
	if {[string length $txt] > $width} {set width [string length $txt]}
	$frame.icons.cb list insert end $txt
      } else {
	if {$cdir} {$frame.icons.cb entryset "unknown icons"}
	$frame.icons.cb list insert end "unknown icons"
      }
      close $fid
    }
  }
  $frame.icons.cb configure -width $width
  cd $curdir

  # searching for fixed font families take a long time
  # therefore, we cache the font names.  The font cache
  # can be saved in the init file. A way should be provided
  # to rescan the font list, without deleting the entry from the
  # init file.
  set font_cache [pref get gdb/font_cache]

  # get list of fonts, removing some that typically
  # are not useful or cause tk problems
  set fam [lremove [font families] "open look glyph"]
  set fam [lremove $fam "open look cursor"]
  set fam [lremove $fam "song ti"]
  set fam [lremove $fam "clearlyu"]
  set fam [lremove $fam "clearlyu alternate glyphs"]
  set fam [lremove $fam "clearlyu arabic extra"]
  set fam [lremove $fam "clearlyu ligature"]
  set fam [lremove $fam "clearlyu pua"]
  set fam [lremove $fam "fangsong ti"]
  set fam [lremove $fam "newspaper"]
  set fam [lremove $fam "palatino linotype"]
  set fam [lsort $fam]
  
  if {$font_cache == ""} {
    if {$gdbtk_platform(platform) == "unix"} {
      toplevel .c
      wm title .c "Scanning for fonts"
      message .c.m -width 3i -text "Scanning system for fonts\n\nPlease wait..." \
	-relief flat -padx 30 -pady 30 \
	-bg [pref get gdb/global_prefs/message_bg] \
	-fg [pref get gdb/global_prefs/message_fg]
      ::update
      pack .c.m
      focus .c
      ::raise .c
      ::update
    }

    foreach fn $fam {
      if {[font metrics [list $fn] -fixed] == 1} {
	lappend font_cache $fn
      }
    }
    pref set gdb/font_cache $font_cache
    if {[winfo exists .c]} { destroy .c }
  }
  
  Labelledframe $frame.d -text "Fonts"
  set f [$frame.d get_frame]

  _make_font_item $f fixed "Fixed Font:" $font_cache

  if {$gdbtk_platform(platform) != "windows"} {
    # Cannot change the windows menu font ourselves
    _make_font_item $f menu "Menu Font:" $fam
  }

  _make_font_item $f default "Default Font:" $fam
  _make_font_item $f status  "Status Bar Font:" $fam


  iwidgets::Labeledframe $frame.misc -labelpos nw -labeltext "Misc"
  set f [$frame.misc childsite]

  # This is the tracing preference
  set tracing_cb [pref get gdb/mode]
  if { ![info exists tracing_labels($tracing_cb)]} {
    dbug E "Got unknown mode value: $tracing_cb"
    set tracing_labels($tracing_cb) "Unknown gdb mode..."
  }

  checkbutton $f.tracing -variable [scope _new(gdb/mode)] \
    -text $tracing_labels($tracing_cb) \
    -command [code $this _toggle_tracing $f.tracing] \
    -width $tracing_labels(max_len) -anchor w

  # use_icons
  if {$gdbtk_platform(platform) == "unix"} {
    checkbutton $f.use_icons  \
      -text "Use builtin image as icon." -variable [scope _new(gdb/use_icons)]
  }

  # console wrap
  checkbutton $f.consolewrap -text "Wrap text in console window" \
    -variable [scope _new(gdb/console/wrap)]

  # colored backgrounds
  checkbutton $f.use_cs -text "Enable Color Schemes" \
    -variable [scope _new(gdb/use_color_schemes)]

  grid $f.tracing -sticky w -padx 5 -pady 5

  if {$gdbtk_platform(platform) == "unix"} {
    grid $f.use_icons -sticky w -padx 5 -pady 5
  }
  grid $f.consolewrap -sticky w -padx 5 -pady 5
  grid $f.use_cs -sticky w -padx 5 -pady 5

  if {$gdbtk_platform(platform) == "unix"} {
    # Compatibility frame
    iwidgets::Labeledframe $frame.compat -labelpos nw -labeltext "OS Compatibility"
    set fc [$frame.compat childsite]
    radiobutton $fc.0 -text "GNOME" -value "GNOME" -variable [scope _new(gdb/compat)]
    radiobutton $fc.1 -text "KDE" -value "KDE" -variable [scope _new(gdb/compat)]
    radiobutton $fc.2 -text "default" -value "default" -variable [scope _new(gdb/compat)]
    grid $fc.0 -sticky w -padx 5 -pady 5
    grid $fc.1 -sticky w -padx 5 -pady 5
    grid $fc.2 -sticky w -padx 5 -pady 5
    grid [label $fc.warn -text "Restart required for all\nchanges to take effect"] -sticky w
  }

  # pack it all
  pack $frame.icons.lab $frame.icons.cb -side left
  grid $frame.icons x -sticky w -pady 10
  grid $frame.d -columnspan 2 -sticky w
  if {$gdbtk_platform(platform) == "unix"} {
    grid $frame.compat $frame.misc -sticky we
  } else {
    grid $frame.misc x -sticky we
  }

  # make buttons
  button $itk_interior.x.ok -text OK -underline 0 -width 7 -command [code $this _ok]
  button $itk_interior.x.apply -text Apply -width 7 -underline 0 -command [code $this _apply]
  button $itk_interior.x.cancel -text Cancel -width 7 -underline 0 -command [code $this _cancel]
  pack $itk_interior.x.ok $itk_interior.x.apply $itk_interior.x.cancel -side left
  standard_button_box $itk_interior.x

  pack $itk_interior.x -fill x -padx 5 -pady 5 -side bottom
  pack $itk_interior.f -fill both -expand yes -padx 5 -pady 5

  bind $itk_interior.x.ok <Return> \
    "$itk_interior.x.ok flash; $itk_interior.x.ok invoke"
  focus $itk_interior.x.ok

  # We don't want the window flashing around as we change the fonts...

  ::update idletasks

  _resize_font_item_height
  pack propagate $itk_interior.f 0

}
# ------------------------------------------------------------------
#  PRIVATE METHOD:  _make_font_item
# ------------------------------------------------------------------
itcl::body GlobalPref::_make_font_item {f name label font_list} {
  
  # create ComboBox with font name
  lappend _fonts $name
  
  set _original($name,family) [font actual global/$name -family]
  set _original($name,size) [font actual global/$name -size]
  font create test-$name-font -family $_original($name,family) \
    -size $_original($name,size)
  label $f.${name}x -text $label

  combobox::combobox $f.${name}n -editable 0 -value $_original($name,family) \
    -command [code $this _change_font $name] -bg $::Colors(textbg)

  foreach a $font_list {
    $f.${name}n list insert end $a
  }
  
  itk_component add $name-size {
    iwidgets::spinint $f.${name}s -labeltext "Size:" -range {6 18} -step 1 \
      -fixed 2 -width 2 -textvariable [scope _size($name)] -wrap 0 \
      -increment [code $this _change_size up $name] \
      -decrement [code $this _change_size down $name] \
      -textbackground $::Colors(textbg)
  } {}
  label $f.${name}l -text ABCDEFabcdef0123456789 -font test-$name-font
  set _size($name) $_original($name,size)

  grid $f.${name}x $f.${name}n $f.${name}s $f.${name}l -sticky we -padx 5 -pady 5
  grid columnconfigure $f 3 -weight 1
}

# ------------------------------------------------------------------
#  PRIVATE METHOD:  _resize_font_item_height
# ------------------------------------------------------------------
itcl::body GlobalPref::_resize_font_item_height {} {
  foreach font $_fonts {
    set master [$itk_interior.f.d get_frame]
    set row [gridCGet $master.${font}l -row]
    grid rowconfigure $master $row -minsize [lindex [grid bbox $master 0 $row 3 $row ] 3]
  } 
}

# ------------------------------------------------------------------
#  PRIVATE METHOD:  _change_icons
# ------------------------------------------------------------------
itcl::body GlobalPref::_change_icons {w args} {
  set index [$w curselection]
  if {$index != ""} {
    set _new(gdb/ImageDir) [lindex $_icondirlist $index]
  }
}

# ------------------------------------------------------------------
#  NAME:         private method GlobalPref::_change_font
#  DESCRIPTION:  Change the given font's family
#
#  ARGUMENTS:
#                font           - the font whose family is to be
#                                 changed
#                stupid         - the comobox widget which changed
#                implementation - the new value of the combobox
#  RETURNS:      Nothing
#
#  NOTES:        The combobox has a really non-standard callback
#                mechanism: it always adds two args to the callback.
# ------------------------------------------------------------------
itcl::body GlobalPref::_change_font {font stupid implementation} {
  font configure test-$font-font -family $implementation
}

# ------------------------------------------------------------------
#  NAME:         private method GlobalPref::_change_size
#  DESCRIPTION:  Change the given font's size
#
#  ARGUMENTS:
#                direction  - the direction of the change (up/down)
#                font       - the font that is changing
#  RETURNS:      Nothing
#
#  NOTES:        See comments for purpose of "direction". Sigh.
# ------------------------------------------------------------------
itcl::body GlobalPref::_change_size {direction font} {

  # Almost as stupid as the comobox, the iwidgets::spinint class
  # will not treat its -increment and -decrement commands
  # as command callbacks. Instead it OVERRIDES all behavior.
  # Thus, we need to call the stupid spinint's callback.
  $itk_component($font-size) $direction
  font configure test-$font-font -size $_size($font)
}


itcl::body GlobalPref::_toggle_tracing {win} {
  debug
  $win configure -text $tracing_labels($_new(gdb/mode))
}

# ------------------------------------------------------------------
#  METHOD:  _ok - called to accept settings and close dialog
# ------------------------------------------------------------------
itcl::body GlobalPref::_ok {} {
  _apply 1
}

# ------------------------------------------------------------------
#  METHOD:  _apply - apply current settings to the screen
# ------------------------------------------------------------------
itcl::body GlobalPref::_apply {{deleteMe 0}} {
  debug
  set changed_something 0

  # If you are not destroying the window, then make sure to
  # propagate the geometry info from the font frame, so that changing 
  # the fonts IN the window don't cause some of the buttons to 
  # get obscured...

  if {!$deleteMe} {
    pack propagate $itk_interior.f 1
  }

  foreach thunk $_fonts {
    set font [font configure test-$thunk-font]
    if {[pref get global/font/$thunk] != $font} {
      pref set global/font/$thunk $font
    }
  }

  foreach var [array names _new] {
    if {$_new($var) != [pref get $var]} {
      debug "$var = $_new($var)"

      if {$var == "gdb/mode"} { 
	if {!$_new(gdb/mode)} { pref set gdb/B1_behavior 1 }
      } elseif {$var == "gdb/ImageDir"} {
	set ::gdb_ImageDir [file join $::GDBTK_LIBRARY $_new($var)]
      }
      pref set $var $_new($var)
      set changed_something 1
    }
  }

  if {$changed_something} {
    if {$deleteMe} { unpost }
    ManagedWin::restart
    return
  }
  if {$deleteMe} { 
    unpost 
  } else {
    after idle " 
      update idletasks
      [code $this _resize_font_item_height]
      pack propagate $itk_interior.f 0
    "
  }    
}

# ------------------------------------------------------------------
#  METHOD:  _cancel - forget current settings -- reset to original
#                    state and close preferences
# ------------------------------------------------------------------
itcl::body GlobalPref::_cancel {} {
  debug
  set changed_something 0

  # Reset fonts if different
  foreach thunk $_fonts {
    set family [font configure global/$thunk -family]
    set size   [font configure global/$thunk -size]
    if {$_original($thunk,family) != $family || $_original($thunk,size) != $size} {
      pref set global/font/$thunk \
	[list -family $_original($thunk,family) -size $_original($thunk,size)]
      set changed_something 1
    }
  }

  foreach var [array names _saved] {
    if {$_saved($var) != [pref get $var]} {
      debug "$var = $_saved($var)"

      if {$var == "gdb/mode"} { 
	if {!$_saved(gdb/mode)} { pref set gdb/B1_behavior 1 }
      } elseif {$var == "gdb/ImageDir"} {
	set ::gdb_ImageDir [file join $::GDBTK_LIBRARY $_saved($var)]
      }
      pref set $var $_saved($var)
      set changed_something 1
    }
  }

  if {$changed_something} {
    ManagedWin::restart
  }
  unpost
}

# ------------------------------------------------------------------
#  METHOD:  cancel - override modal dialog cancel method.
#                    The cancel method is actually called when
#		     the window is closed. Name needs fixed.
# ------------------------------------------------------------------
itcl::body GlobalPref::cancel {} {
  # when the window is closed, we want the preferences selected to
  # be applied.
  _apply 1
}