lib/gui_script/config.tcl

   1 #--- configure for default fonts
   2
   3 foreach type {normal italic bold fixed large} {
   4   set Font($type) ""
   5 }
   6
   7 #----- init fonts and colors
   8
   9 proc do_config {args} {
  10   global argc argv bgColor tkPalette tk_strictMotif UseNativeDialogs
  11   set config ""
  12   set proc ""
  13   set fg ""
  14   set bg ""
  15   set native 0
  16   set fonts 0
  17   set motif 0
  18   set focus 0
  19   if {$argc} {
  20     eval lappend args $argv
  21   }
  22   set len [llength $args]
  23   if {$len} {
  24     for {set n 0} {$n < $len} {incr n} {
  25       set arg [string tolower [lindex $args $n]]
  26       if [string match "-con*" $arg] {
  27         incr n
  28         if {$n < $len} {
  29           set config [lindex $args $n]
  30         }
  31       } elseif [string match "-win*" $arg] {
  32         set proc setup_windows
  33         set config ""
  34       } elseif [string match "-def*" $arg] {
  35         set proc config_init
  36         set config ""
  37       } elseif [string match "-fon*" $arg] {
  38         set fonts 1
  39       } elseif [string match "-nat*" $arg] {
  40         set native 1
  41       } elseif [string match "-fgc*" $arg] {
  42         incr n
  43         if {$n < $len} {
  44           set fg [lindex $args $n]
  45         }
  46       } elseif [string match "-bgc*" $arg] {
  47         incr n
  48         if {$n < $len} {
  49           set bg [lindex $args $n]
  50         }
  51       } elseif [string match "-mot*" $arg] {
  52         set motif 1
  53       } elseif [string match "-foc*" $arg] {
  54         set focus 1
  55       }
  56     }
  57   }
  58
  59   if {$config != "" && ![catch {option readfile $config}]} {
  60     set UseNativeDialogs 0
  61     config_init
  62     if {$fonts} setup_fonts
  63     . configure -background $bgColor(normal)
  64     if {[option get . keyboardFocusPolicy TakeFocus] == "pointer"} {
  65       set focus 1
  66     }
  67   } elseif {$proc != ""} {
  68     $proc
  69   } else {
  70     if {$bg != ""} {
  71       if {$fg == ""} {
  72         catch {tk_setPalette $bg}
  73       } else {
  74         catch {tk_setPalette background $bg foreground $fg}
  75       }
  76       option add *background $tkPalette(background)
  77       option add *foreground $tkPalette(foreground)
  78       . configure -background $tkPalette(background)
  79     }
  80     if {$fonts} setup_fonts
  81     config_init
  82   }
  83   if {$native} {set UseNativeDialogs 1}
  84   if {$motif} {
  85     set tk_strictMotif 1
  86     set focus 0
  87   }
  88   if {$focus} {
  89     if {[info commands tk_focusFollowsMouse] != ""} {
  90       tk_focusFollowsMouse
  91     } else {
  92       bind all <Enter> {+focus %W}
  93     }
  94   }
  95 }
  96
  97 proc setup_fonts {} {
  98   global Font tcl_platform
  99   if {$tcl_platform(platform) == "windows"} {
 100     set Font(normal) "Helvetica 8"
 101     set Font(italic) "Helvetica 8 italic"
 102     set Font(bold)   "Helvetica 8 bold"
 103     set Font(fixed)  "Courier 8"
 104     set Font(large)  "Helvetica 10"
 105   } else {
 106     set Font(normal) "Helvetica -12"
 107     set Font(italic) "Helvetica -12 italic"
 108     set Font(bold)   "Helvetica -12 bold"
 109     set Font(fixed)  "Courier -12"
 110     set Font(large)  "Helvetica -16"
 111   }
 112   option add *font $Font(normal)
 113   option add *Entry.font $Font(fixed)
 114   option add *Listbox.font $Font(fixed)
 115   option add *Text.font $Font(fixed)
 116 }
 117
 118 #--- setup colors for windows
 119
 120 proc setup_windows {} {
 121   global UseNativeDialogs tcl_platform
 122   if {$tcl_platform(platform) == "windows"} {
 123     set UseNativeDialogs 1
 124     option add *Listbox.background SystemWindow
 125     option add *Listbox.foreground SystemWindowText
 126 #    option add *Canvas.background SystemWindow
 127     option add *Button.padY 0
 128   } else {
 129     set UseNativeDialogs 0
 130     tk_setPalette #C0C0C0
 131     option add *selectBackground #00007F
 132     option add *selectForeground white
 133     option add *Text.background white
 134     option add *Entry.background white
 135     option add *Listbox.background white
 136 #    option add *Canvas.background white
 137   }
 138   setup_fonts
 139   config_init
 140 }
 141
 142 #--- get colors and fonts into globals
 143
 144 proc config_init {} {
 145   global Font bgColor fgColor tcl_platform UseNativeDialogs
 146
 147   checkbutton .configbutton
 148   text .configtext
 149   label .configlabel
 150
 151   #--- background colors
 152
 153   set bgColor(normal)    [.configlabel cget -background]
 154   set bgColor(button)    [.configbutton cget -background]
 155   set bgColor(text)      [.configtext cget -background]
 156   set bgColor(active)    [.configbutton cget -activebackground]
 157   set bgColor(highlight) [.configbutton cget -highlightbackground]
 158   set bgColor(disabled)  $bgColor(normal)
 159   set bgColor(select)    [.configtext cget -selectbackground]
 160   set bgColor(indicator) [.configbutton cget -selectcolor]
 161   if {![info exists bgColor(canvas)]} {
 162     canvas .configcanvas
 163     set bgColor(canvas) [.configcanvas cget -background]
 164     destroy .configcanvas
 165   }
 166
 167   #--- foreground colors
 168
 169   set fgColor(normal)    [.configlabel cget -foreground]
 170   set fgColor(button)    [.configbutton cget -foreground]
 171   set fgColor(text)      [.configtext cget -foreground]
 172   set fgColor(active)    [.configbutton cget -activeforeground]
 173   set fgColor(highlight) [.configbutton cget -highlightcolor]
 174   set fgColor(disabled)  [.configbutton cget -disabledforeground]
 175   set fgColor(select)    [.configtext cget -selectforeground]
 176   set fgColor(indicator) $bgColor(indicator)
 177   if {![info exists fgColor(canvas)]} {
 178     set mx [lindex [winfo rgb . white] 0]
 179     set bg [winfo rgb . $bgColor(canvas)]
 180     if [expr (0.3 * [lindex $bg 0] + 0.59 * [lindex $bg 1] + \
 181         0.11 * [lindex $bg 2]) >= (0.5 * $mx)] {
 182       set fgColor(canvas) black
 183     } else {
 184       set fgColor(canvas) white
 185     }
 186   }
 187
 188   #--- fonts
 189
 190   foreach type {normal fixed italic bold large} {
 191     if {$Font($type) == ""} {
 192       set font [option get . $type\Font Font]
 193       if {$font != ""} {
 194         if ![catch {button .fntbutton -font $font}] {
 195           set Font($type) $font
 196         }
 197         catch {destroy .fntbutton}
 198       }
 199     }
 200   }
 201
 202   set font [.configlabel cget -font]
 203   set family [lindex $font 0]
 204   set size [lindex $font 1]
 205   if {$Font(normal) == ""} {
 206     set Font(normal) [list $family $size]
 207   }
 208   if {$Font(fixed) == ""} {
 209     set Font(fixed) [list Courier $size]
 210   }
 211   if {$Font(bold) == ""} {
 212     set Font(bold) [list $family $size bold]
 213   }
 214   if {$Font(italic) == ""} {
 215     set Font(italic) [list $family $size italic]
 216   }
 217   if {$Font(large) == ""} {
 218     if {$size < 0} {
 219       incr size -2
 220     } else {
 221       incr size 2
 222     }
 223     set Font(large) [list $family $size]
 224   }
 225
 226   destroy .configbutton
 227   destroy .configtext
 228   destroy .configlabel
 229
 230   if {![info exists UseNativeDialogs] || $UseNativeDialogs == ""} {
 231     if {$tcl_platform(platform) == "windows"} {
 232       set UseNativeDialogs 1
 233     } else {
 234       set UseNativeDialogs 0
 235     }
 236   }
 237 }