1053 lines
33 KiB
Tcl
1053 lines
33 KiB
Tcl
# -*-mode: tcl; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*-
|
|
#
|
|
#
|
|
# $Id: WmDefault.tcl,v 1.7 2008/03/17 22:47:00 hobbs Exp $
|
|
#
|
|
# Description: Package for making Tk apps use the CDE/KDE/Gnome/Windows scheme
|
|
# Prefix: wm_default::
|
|
# Url: http://tix.sourceforge.net/Tixapps/
|
|
#
|
|
# Usage:
|
|
# It should be sufficient at the beginning of a wish app to simply:
|
|
#
|
|
# package require wm_default
|
|
# wm_default::setup
|
|
# wm_default::addoptions
|
|
#
|
|
# wm_default::setup takes an optional argument - the scheme if already
|
|
# known, one of: windows gnome kde1 kde2 cde kde
|
|
# wm_default::addoptions takes optional arguments - pairs of variables
|
|
# and values to override the kde settings. e.g.
|
|
# wm_default::addoptions -background blue
|
|
#
|
|
# Description:
|
|
# package for making Tk apps look nice under CDE or KDE or Windows
|
|
#
|
|
# The stuff below attempts to use the options database and the
|
|
# various files under ~/.dt, $DTHOME, and /usr/dt to figure out
|
|
# the user's current font and color set. It then uses tk's
|
|
# palette routines to set sensible defaults, and then override
|
|
# some of the options to try to make them look like CDE.
|
|
#
|
|
# There really *must* be an easier way to get text background
|
|
# colors and the radiobutton highlight colors out of the
|
|
# options database or winfo atom... Unfortunately, I can't
|
|
# figure out how...
|
|
|
|
# This package is based on the cde package by D. J. Hagberg, Jr.:
|
|
# dhagberg@glatmos.com
|
|
|
|
########################################################################
|
|
#
|
|
#
|
|
# Copyright 1998 D. J. Hagberg, Jr. and Global Atmospherics, Inc.
|
|
#
|
|
# Permission to use, copy, modify, and distribute this software and its
|
|
# documentation for any purpose and without fee is hereby granted, provided
|
|
# that the above copyright notice appear in all copies.
|
|
# D. J. Hagberg, Jr. and Global Atmospherics, Inc. make no representations
|
|
# about the suitability of this software for any It is provided "as is"
|
|
# without express or implied warranty. By use of this software the user
|
|
# agrees to indemnify and hold harmless D. J. Hagberg, Jr. and Global
|
|
# Atmospherics, Inc. from any claims or liability for loss arising out
|
|
# of such use.
|
|
########################################################################
|
|
|
|
package require Tk
|
|
|
|
proc tixDetermineWM {} {
|
|
# Returns one of cde kde1 kde2 gnome windows or ""
|
|
global tcl_platform env
|
|
|
|
set type ""
|
|
if {$tcl_platform(platform) eq "windows"} {
|
|
set type windows
|
|
} else {
|
|
# The most definitive way is to check the X atoms
|
|
# I'm not sure if we can determine this using regular Tk wm calls
|
|
# I don't want to intern these symbols if they're not there.
|
|
if {![catch {exec xlsatoms} xatoms]} {
|
|
if {[string match *GNOME_SESSION_CORBA_COOKIE* $xatoms]} {
|
|
set type gnome
|
|
} elseif {[string match *KDEChangeStyle* $xatoms]} {
|
|
set type kde1
|
|
} elseif {[string match *KDE_DESKTOP_WINDOW* $xatoms]} {
|
|
set type kde2
|
|
}
|
|
}
|
|
if {$type != ""} {
|
|
# drop through
|
|
} elseif {[info exists env(KDEDIR)] && [file isdir $env(KDEDIR)]} {
|
|
# one or two?
|
|
set type kde2
|
|
} elseif {[info exists env(DTHOME)] && [file isdir $env(DTHOME)]} {
|
|
set type cde
|
|
} else {
|
|
# Maybe look for other Unix window managers?
|
|
# if {[file isfile $env(HOME)/.fwm2rc]} {}
|
|
# if {[file isfile $env(HOME)/.fwmrc]} {}
|
|
# if {[file isfile $env(HOME)/.twmrc]} {}
|
|
# But twm and fwm don't color applications; mwm maybe?
|
|
# Hope someone comes up with the code for openlook :-)
|
|
return ""
|
|
}
|
|
}
|
|
return $type
|
|
}
|
|
|
|
namespace eval ::wm_default {
|
|
global tcl_platform env
|
|
|
|
set _usetix [llength [info commands "tix"]]
|
|
|
|
variable wm ""
|
|
|
|
variable _frame_widgets {*Frame *Toplevel}
|
|
#what about tixGrid?
|
|
if {$_usetix} {
|
|
lappend _frame_widgets *TixLabelFrame *TixButtonBox *TixCObjView \
|
|
*TixListNoteBook *TixPanedWindow *TixStdButtonBox \
|
|
*TixExFileSelectBox
|
|
}
|
|
variable _menu_font_widgets {*Menu *Menubutton}
|
|
if {$_usetix} {lappend _menu_font_widgets *TixMenu}
|
|
variable _button_font_widgets {*Button}
|
|
|
|
variable _system_font_widgets {*Label \
|
|
*Message \
|
|
*Scale *Radiobutton *Checkbutton
|
|
}
|
|
if {$_usetix} {
|
|
lappend _system_font_widgets \
|
|
*TixBalloon*message *TixLabelFrame*Label \
|
|
*TixControl*label *TixControl*Label \
|
|
*TixLabelEntry*label *TixNoteBook.nbframe \
|
|
*TixFileEntry*label *TixComboBox*label \
|
|
*TixOptionMenu*menubutton *TixBitmapButton*label \
|
|
*TixMwmClient*title *TixFileSelectBox*Label
|
|
}
|
|
variable _text_type_widgets {*Canvas *Entry *Listbox *Text}
|
|
if {$_usetix} {
|
|
lappend _text_type_widgets \
|
|
*TixComboBox*Entry *TixControl*entry *TixScrolledHList*hlist \
|
|
*TixDirTree*hlist *TixDirList*hlist *TixTree*hlist \
|
|
*TixMultiList*Listbox *TixScrolledListBox*listbox \
|
|
*TixFileEntry*Entry *TixLabelEntry*Entry \
|
|
*TixFileEntry*entry *TixLabelEntry*entry \
|
|
*TixScrolledTList*tlist *TixScrolledText*text \
|
|
*TixHList *TixCheckList*hlist
|
|
# These arent working yet
|
|
lappend _text_type_widgets \
|
|
*TixDirTree*f1 *TixDirList*f1 \
|
|
*TixFileSelectBox*file*listbox \
|
|
*TixFileSelectBox*directory*listbox \
|
|
*TixExFileSelectBox*filelist*listbox
|
|
}
|
|
|
|
variable _insert_type_widgets {*Entry *Text}
|
|
if {$_usetix} {
|
|
lappend _insert_type_widgets \
|
|
*TixControl*entry *TixComboBox*Entry
|
|
}
|
|
|
|
variable _select_type_widgets {*Checkbutton \
|
|
*Radiobutton \
|
|
*Menu}
|
|
variable _active_borderwidth_widgets {*Button *Radiobutton *Checkbutton}
|
|
|
|
# Other Widgets that are given a borderwidth of $wm_default::borderwidth
|
|
variable _nonzero_borderwidth_widgets {}
|
|
|
|
# Widgets that are given a borderwidth of 0
|
|
# must not be *Entry
|
|
variable _null_borderwidth_widgets {*Menubutton *Label}
|
|
|
|
variable _scrollbar_widgets {}
|
|
variable _scrollbar_widgets {*Scrollbar}
|
|
if {$_usetix} {
|
|
lappend _scrollbar_widgets \
|
|
*TixTree*Scrollbar *TixDirTree*Scrollbar *TixDirList*Scrollbar \
|
|
*TixScrolledTList*Scrollbar *TixScrolledListBox*Scrollbar \
|
|
*TixScrolledHList*Scrollbar *TixMultiView*Scrollbar \
|
|
*TixScrolledText*Scrollbar *TixScrolledWindow*Scrollbar \
|
|
*TixCObjView*Scrollbar
|
|
}
|
|
|
|
proc debug {str} {
|
|
if {[llength [info commands "tix"]] &&
|
|
[string is true -strict [tix cget -debug]]} {
|
|
puts $str
|
|
}
|
|
}
|
|
|
|
# Return the array of what we have deduced
|
|
proc getoptions {} {
|
|
set retval {}
|
|
set len [string length "::wm_default::"]
|
|
foreach variable [lsort [info vars ::wm_default::*]] {
|
|
if {[string match ::wm_default::_* $variable]} {continue}
|
|
set key [string range $variable $len end]
|
|
lappend retval $key [set $variable]
|
|
}
|
|
return $retval
|
|
}
|
|
|
|
# Print out the array of what we have deduced
|
|
proc parray {} {
|
|
set retval ""
|
|
foreach {key val} [::wm_default::getoptions] {
|
|
append retval [join [list $key $val]] "\n"
|
|
}
|
|
debug $retval
|
|
return $retval
|
|
}
|
|
|
|
# Pick a default borderwidth in pixels
|
|
set _bd 2
|
|
# Pick a default font size in pixels
|
|
set _screenheight [winfo screenheight .]
|
|
if {$_screenheight < 500} {
|
|
# for 800x600 or smaller
|
|
set _pixel 10
|
|
set _point 8
|
|
# Pick a default borderwidth which smaller
|
|
set _bd 1
|
|
} elseif {$_screenheight < 800} {
|
|
# for 1024x768
|
|
set _pixel 12
|
|
set _point 8
|
|
} elseif {$_screenheight < 1100} {
|
|
# for 1200x1000
|
|
set _pixel 12
|
|
set _point 8
|
|
} else {
|
|
set _pixel 12
|
|
set _point 10
|
|
}
|
|
|
|
# setup defaults depending on the OS and Window Manager
|
|
# Really should do another version for mono
|
|
if {$tcl_platform(platform) eq "windows"} {
|
|
|
|
if {$tcl_platform(osVersion) < 5} {
|
|
set _prop_default "MS Sans Serif"
|
|
} else {
|
|
set _prop_default "Tahoma"
|
|
}
|
|
|
|
# make sure this font is installed
|
|
set _allowed [string tolow [font families]]
|
|
foreach font [list $_prop_default "MS Sans Serif" Tahoma Arial System] {
|
|
if {[lsearch -exact $_allowed [string tolow $font]] > -1} {
|
|
set _prop_default $font
|
|
break
|
|
}
|
|
}
|
|
|
|
set _fixed_default {Courier New}
|
|
# make sure this font is installed
|
|
foreach font [list $_fixed_default Courier System] {
|
|
if {[lsearch -exact $_allowed [string tolow $font]] > -1} {
|
|
set _fixed_default $font
|
|
break
|
|
}
|
|
}
|
|
|
|
# Windows colors:
|
|
# "3dDarkShadow", COLOR_3DDKSHADOW,
|
|
# "3dLight", COLOR_3DLIGHT,
|
|
# "ActiveBorder", COLOR_ACTIVEBORDER,
|
|
# "ActiveCaption", COLOR_ACTIVECAPTION,
|
|
# "AppWorkspace", COLOR_APPWORKSPACE,
|
|
# "Background", COLOR_BACKGROUND,
|
|
# "ButtonFace", COLOR_BTNFACE,
|
|
# "ButtonHighlight", COLOR_BTNHIGHLIGHT,
|
|
# "ButtonShadow", COLOR_BTNSHADOW,
|
|
# "ButtonText", COLOR_BTNTEXT,
|
|
# "CaptionText", COLOR_CAPTIONTEXT,
|
|
# "DisabledText", COLOR_GRAYTEXT,
|
|
# "GrayText", COLOR_GRAYTEXT,
|
|
# "Highlight", COLOR_HIGHLIGHT,
|
|
# "HighlightText", COLOR_HIGHLIGHTTEXT,
|
|
# "InactiveBorder", COLOR_INACTIVEBORDER,
|
|
# "InactiveCaption", COLOR_INACTIVECAPTION,
|
|
# "InactiveCaptionText", COLOR_INACTIVECAPTIONTEXT,
|
|
# "InfoBackground", COLOR_INFOBK,
|
|
# "InfoText", COLOR_INFOTEXT,
|
|
# "Menu", COLOR_MENU,
|
|
# "MenuText", COLOR_MENUTEXT,
|
|
# "Scrollbar", COLOR_SCROLLBAR,
|
|
# "Window", COLOR_WINDOW,
|
|
# "WindowFrame", COLOR_WINDOWFRAME,
|
|
# "WindowText", COLOR_WINDOWTEXT,
|
|
|
|
variable \
|
|
background "SystemButtonFace" \
|
|
foreground "SystemButtonText" \
|
|
disabledforeground "SystemDisabledText" \
|
|
disabledbackground "SystemButtonShadow" \
|
|
textfamily $_prop_default \
|
|
systemfamily $_prop_default \
|
|
menufamily $_prop_default \
|
|
fixedfamily $_fixed_default \
|
|
fontsize $_point \
|
|
textbackground "SystemWindow" \
|
|
textforeground "SystemWindowText" \
|
|
disabledtextbackground "SystemDisabledText" \
|
|
selectbackground "SystemHighlight" \
|
|
selectforeground "SystemHighlightText" \
|
|
selectcolor "SystemWindow" \
|
|
highlightcolor "SystemWindowFrame" \
|
|
highlightbackground "SystemButtonFace" \
|
|
scrollbars "SystemScrollbar" \
|
|
borderwidth $_bd \
|
|
menubackground "SystemMenu" \
|
|
menuforeground "SystemMenuText"
|
|
|
|
variable highlightthickness 1
|
|
|
|
# Windows does not have an activebackground, but Tk does
|
|
variable activebackground $background
|
|
variable activeforeground $foreground
|
|
} else {
|
|
# intended for Unix
|
|
|
|
# Tk uses the following defaults:
|
|
|
|
#define NORMAL_BG "#d9d9d9"
|
|
#define ACTIVE_BG "#ececec"
|
|
#define SELECT_BG "#c3c3c3"
|
|
#define TROUGH "#c3c3c3"
|
|
#define INDICATOR "#b03060"
|
|
#define DISABLED "#a3a3a3"
|
|
|
|
# We know . exists and it has a background
|
|
# This should be "#d9d9d9" under default Tk
|
|
set _bg [. cget -background]
|
|
|
|
set _prop_default helvetica
|
|
# make sure this font is installed
|
|
set _allowed [string tolow [font families]]
|
|
foreach font [list $_prop_default times fixed] {
|
|
if {[lsearch -exact $_allowed [string tolow $font]] > -1} {
|
|
set _prop_default $font
|
|
break
|
|
}
|
|
}
|
|
set _fixed_default courier
|
|
# make sure this font is installed
|
|
foreach font [list $_fixed_default fixed] {
|
|
if {[lsearch -exact $_allowed [string tolow $font]] > -1} {
|
|
set _fixed_default $font
|
|
break
|
|
}
|
|
}
|
|
|
|
variable \
|
|
background $_bg \
|
|
foreground Black \
|
|
disabledforeground #808080 \
|
|
disabledbackground #a3a3a3 \
|
|
textfamily $_prop_default \
|
|
systemfamily $_prop_default \
|
|
menufamily $_prop_default \
|
|
fixedfamily $_fixed_default \
|
|
fontsize $_pixel \
|
|
textbackground white \
|
|
textforeground Black \
|
|
disabledtextbackground $_bg \
|
|
selectbackground #000080 \
|
|
selectforeground white \
|
|
selectcolor yellow \
|
|
highlightcolor Black \
|
|
highlightbackground $_bg \
|
|
scrollbars "#c3c3c3" \
|
|
borderwidth $_bd \
|
|
menubackground $_bg \
|
|
menuforeground Black
|
|
|
|
variable highlightthickness 1
|
|
|
|
# Windows does not have an activebackground, but Tk does
|
|
variable activebackground "#ececec"
|
|
variable activeforeground $foreground
|
|
}
|
|
|
|
# priority should be userDefault?
|
|
if {$_usetix} {
|
|
variable priority [tix cget -schemepriority]
|
|
} else {
|
|
variable priority 75
|
|
}
|
|
|
|
# variables that will be derived during addoptions - set to null for now
|
|
variable system_font {}
|
|
variable menu_font {}
|
|
variable fixed_font {}
|
|
variable text_font {}
|
|
|
|
# Different desktops have different visible regions
|
|
# This is not working properly yet.
|
|
variable geometry 0+0+[winfo screenwidth .]+$_screenheight
|
|
|
|
# Different desktops have different focusmodels: clicktofocus or
|
|
# followsmouse This is not working properly yet
|
|
variable focusmodel clicktofocus
|
|
|
|
# Some desktops have standardized link colors
|
|
# This is not working properly yet
|
|
variable linkcolor "#0000ff" vlinkcolor "#800000" alinkcolor "#800080"
|
|
|
|
proc default {args} {
|
|
# Override the defaults with any optional arguments
|
|
foreach {var val} $args {
|
|
set $var $val
|
|
}
|
|
}
|
|
|
|
proc setup {{type ""}} {
|
|
# type is one of the recognized window managers
|
|
# one of: cde kde win
|
|
global tcl_platform env
|
|
|
|
if {$type == ""} {
|
|
if {[set type [::tixDetermineWM]] == ""} {
|
|
set ::wm_default::wm ""
|
|
# Generic unix
|
|
return
|
|
}
|
|
}
|
|
setup-$type
|
|
set ::wm_default::wm $type
|
|
# todo - make the menubutton enter and leave events more compatible
|
|
}
|
|
|
|
proc setup-windows {args} {
|
|
# Already done by Tk above.
|
|
# Should find out the useable window region
|
|
}
|
|
|
|
proc setup-gnome {args} {
|
|
# GNOME is still barely supported because of the difficulty
|
|
# of finding and parsing sawfish definition files.
|
|
# First you have to find what window manager, then what theme,
|
|
# then find the files, then parse them according to each Wm's syntax.
|
|
global env
|
|
|
|
set bg $wm_default::background
|
|
set fg $wm_default::foreground
|
|
set txtFont $wm_default::textfamily
|
|
set btnFont $wm_default::systemfamily
|
|
|
|
debug "Setting up Gnome environment"
|
|
|
|
set file ~/.gnome/theme-switcher-capplet
|
|
if {![file exists $file] || \
|
|
[catch {open $file} fd] || $fd == ""} {
|
|
debug "Skipping $file"
|
|
} else {
|
|
debug "Reading $file"
|
|
set contents [read $fd]
|
|
catch {close $fd}
|
|
|
|
if {![regexp -- "use_theme_font=true" $contents]} {
|
|
# not activated
|
|
} elseif {[regexp -- "\nfont=(\[-a-zA-Z0-9,\]+)" $contents \
|
|
foo font]} {
|
|
set_unix_font $font
|
|
}
|
|
}
|
|
|
|
}
|
|
|
|
proc set_unix_font {font} {
|
|
|
|
set list [split $font "-"]
|
|
set font [lindex $list 2]
|
|
set font [string tolow $font]
|
|
if {$font != "" && [lsearch -exact [font families] $font] > -1} {
|
|
set wm_default::textfamily $font
|
|
debug "Setting textfamily to $font"
|
|
set wm_default::systemfamily $font
|
|
set wm_default::menufamily $font
|
|
} else {
|
|
debug "Unable to set font: '$list'"
|
|
}
|
|
|
|
if {[set size [lindex $list 7]] != "" && \
|
|
[string is integer -strict $size]} {
|
|
debug "Setting fontsize to '$size'"
|
|
set wm_default::fontsize $size
|
|
} elseif {[set size [lindex $list 8]] != "" && \
|
|
[string is integer -strict $size]} {
|
|
if {$size > 100} {set size [expr {$size / 10}]}
|
|
debug "Setting fontsize to '$size'"
|
|
set wm_default::fontsize $size
|
|
} else {
|
|
debug "Unable to set fontsize: '$list'"
|
|
}
|
|
}
|
|
|
|
# Common to KDE1 and KDE2
|
|
proc setup-kde {args} {
|
|
global env
|
|
|
|
set file ~/.kderc
|
|
if {![file exists $file] || [catch {open $file} fd] || $fd == ""} {
|
|
debug "Skipping $file"
|
|
} else {
|
|
debug "Reading $file"
|
|
set contents [read $fd]
|
|
catch {close $fd}
|
|
|
|
if {[regexp -- "\nfixedfamily=(\[-a-zA-Z0-9, \]+)" $contents \
|
|
foo font]} {
|
|
set list [split $font ","]
|
|
set font [lindex $list 0]
|
|
set wm_default::fixedfamily $font
|
|
debug "Setting fixedfamily to $font"
|
|
}
|
|
if {[regexp -- "\nfont=(\[-a-zA-Z0-9, \]+)" $contents \
|
|
foo font]} {
|
|
set list [split $font ","]
|
|
set font [lindex $list 0]
|
|
set wm_default::textfamily $font
|
|
debug "Setting textfamily to $font"
|
|
set wm_default::systemfamily $font
|
|
set wm_default::menufamily $font
|
|
}
|
|
}
|
|
|
|
}
|
|
|
|
proc setup-kde1 {args} {
|
|
# Shortcut for the moment
|
|
return [eval setup-kde $args]
|
|
}
|
|
|
|
proc set-kde2-color {str contents var} {
|
|
if {[regexp -- "\n${str}=(\[0-9,\]+)" $contents -> color]} {
|
|
set color [eval [list format "#%02x%02x%02x"] [split $color ","]]
|
|
set ::wm_default::$var $color
|
|
debug "setting $var to $color"
|
|
}
|
|
}
|
|
|
|
proc setup-kde2 {args} {
|
|
global env
|
|
|
|
set bg $wm_default::background
|
|
set fg $wm_default::foreground
|
|
set txtFont $wm_default::textfamily
|
|
set btnFont $wm_default::systemfamily
|
|
|
|
debug "Setting up KDE environment"
|
|
|
|
# Look for system the user settings
|
|
set dirs ~/.kde
|
|
if {[info exists env(KDEDIR)] && [file isdir $env(KDEDIR)]} {
|
|
lappend dirs $env(KDEDIR)
|
|
}
|
|
# read them sequentially and overwrite the previous values
|
|
foreach dir $dirs {
|
|
set file $dir/share/config/kdeglobals
|
|
if {![file exists $file] || [catch {open $file} fd] || $fd == ""} {
|
|
debug "Skipping $file"
|
|
} else {
|
|
debug "Reading $file"
|
|
set contents [read $fd]
|
|
catch {close $fd}
|
|
set-kde2-color background $contents background
|
|
set-kde2-color foreground $contents foreground
|
|
set-kde2-color selectBackground $contents selectbackground
|
|
set-kde2-color selectForeground $contents selectforeground
|
|
set-kde2-color windowBackground $contents textbackground
|
|
set-kde2-color visitedLinkColor $contents vlinkcolor
|
|
set-kde2-color linkColor $contents linkcolor
|
|
if {[regexp -- "\nactiveFont=(\[-a-zA-Z0-9, \]+)" $contents \
|
|
foo font]} {
|
|
set list [split $font ","]
|
|
set font [lindex $list 0]
|
|
set wm_default::textfamily $font
|
|
set size [lindex $list 1]
|
|
if {[string is integer -strict $size]} {
|
|
set wm_default::fontsize $size
|
|
}
|
|
debug "Setting textfamily to $font"
|
|
set wm_default::systemfamily $font
|
|
set wm_default::menufamily $font
|
|
}
|
|
}
|
|
|
|
# should pick up visitedLinkColor
|
|
|
|
set file $dir/share/config/kwmrc
|
|
if {![file exists $file] || [catch {open $file} fd] || $fd == ""} {
|
|
debug "Skipping $file"
|
|
} else {
|
|
debug "Reading $file"
|
|
set contents [read $fd]
|
|
catch {close $fd}
|
|
if {[regexp -- "\nDesktop1Region=(\[0-9+\]+)" $contents \
|
|
foo region]} {
|
|
set wm_default::geometry $region
|
|
debug "Setting geometry to $region"
|
|
}
|
|
|
|
if {[regexp -- "\nFocusPolicy=ClickToFocus" $contents \
|
|
foo region]} {
|
|
set wm_default::focusmodel clicktofocus
|
|
debug "Setting focusmodel to clicktofocus"
|
|
} else {
|
|
# followsmouse
|
|
}
|
|
}
|
|
}
|
|
|
|
return [eval setup-kde $args]
|
|
}
|
|
|
|
proc setup-cde {args} {
|
|
namespace import wm_default::*
|
|
|
|
set bg $wm_default::background
|
|
set fg $wm_default::foreground
|
|
set txtFont $wm_default::textfamily
|
|
set sysFont $wm_default::systemfamily
|
|
|
|
debug "Setting up CDE environment"
|
|
|
|
# if any of these options are missing, we must not be under CDE
|
|
set txtFont [option get . textfamilyList textfamilyList]
|
|
set sysFont [option get . systemfamilyList systemfamilyList]
|
|
if {$txtFont ne "" && $sysFont ne ""} {
|
|
set txtFont [lindex [split $txtFont :] 0]
|
|
set sysFont [lindex [split $sysFont :] 0]
|
|
if {$txtFont ne ""} {set textfamily $txtFont}
|
|
if {$sysFont ne ""} {set systemfamily $sysFont}
|
|
#
|
|
# If we can find the user's dt.resources file, we can find out the
|
|
# palette and text background/foreground colors
|
|
#
|
|
set txtBg $bg
|
|
set txtFg $fg
|
|
set selFg $selectforeground
|
|
set selBg $selectbackground
|
|
set selCol $selectcolor
|
|
set fh ""
|
|
set palf ""
|
|
set cur_rsrc ~/.dt/sessions/current/dt.resources
|
|
set hom_rsrc ~/.dt/sessions/home/dt.resources
|
|
if {[file readable $cur_rsrc] && [file readable $hom_rsrc]} {
|
|
if {[file mtime $cur_rsrc] > [file mtime $hom_rsrc]} {
|
|
if {[catch {open $cur_rsrc r} fh]} {set fh ""}
|
|
} else {
|
|
if {[catch {open $hom_rsrc r} fh]} {set fh ""}
|
|
}
|
|
} elseif {[file readable $cur_rsrc]} {
|
|
if {[catch {open $cur_rsrc r} fh]} {set fh ""}
|
|
} elseif {[file readable $hom_rsrc]} {
|
|
if {[catch {open $hom_rsrc r} fh]} {set fh ""}
|
|
}
|
|
if {[string length $fh] > 0} {
|
|
while {[gets $fh ln] != -1} {
|
|
regexp -- "^\\*0\\*ColorPalette:\[ \t]*(.*)\$" $ln nil palf
|
|
regexp -- "^Window.Color.Background:\[ \t]*(.*)\$" $ln nil txtBg
|
|
regexp -- "^Window.Color.Foreground:\[ \t]*(.*)\$" $ln nil txtFg
|
|
}
|
|
catch {close $fh}
|
|
if {$txtBg ne $bg} {
|
|
set selBg $txtFg
|
|
set selFg $txtBg
|
|
}
|
|
}
|
|
#
|
|
# If the *0*ColorPalette setting was found above, try to find the
|
|
# indicated file in ~/.dt, $DTHOME, or /usr/dt. The 3rd line in the
|
|
# file will be the radiobutton/checkbutton selectColor.
|
|
#
|
|
if {[string length $palf]} {
|
|
set dtdir /usr/dt
|
|
if [info exists env(DTHOME)] {
|
|
set dtdir $env(DTHOME)
|
|
}
|
|
if {[file readable ~/.dt/palettes/$palf]} {
|
|
set palf ~/.dt/palettes/$palf
|
|
} elseif {[file readable $dtdir/palettes/$palf]} {
|
|
set palf $dtdir/palettes/$palf
|
|
} else {
|
|
set palf ""
|
|
}
|
|
if {[string length $palf]} {
|
|
if {![catch {open $palf r} fh]} {
|
|
# selectColor will be the 3rd line in the file --
|
|
set ln ""; catch {gets $fh; gets $fh; gets $fh ln}
|
|
set ln [string trim $ln]
|
|
if {[string length $ln]} {set selCol $ln}
|
|
close $fh
|
|
}
|
|
}
|
|
}
|
|
set wm_default::background $bg
|
|
set wm_default::foreground $fg
|
|
set wm_default::textfamily $txtFont
|
|
set wm_default::systemfamily $sysFont
|
|
set wm_default::menufamily $sysFont
|
|
set wm_default::textbackground $txtBg
|
|
set wm_default::textforeground $txtFg
|
|
set wm_default::selectbackground $selBg
|
|
set wm_default::selectforeground $selFg
|
|
set wm_default::selectcolor $selCol
|
|
}
|
|
}
|
|
|
|
proc derivefonts {} {
|
|
global tcl_platform env
|
|
|
|
# variables that will be derived
|
|
variable system_font
|
|
variable menu_font
|
|
variable fixed_font
|
|
variable text_font
|
|
|
|
#
|
|
# Set default fonts
|
|
#
|
|
|
|
global tcl_platform env
|
|
switch -exact -- $tcl_platform(platform) windows {
|
|
set system_font [list $::wm_default::systemfamily $::wm_default::fontsize]
|
|
set menu_font [list $::wm_default::menufamily $::wm_default::fontsize]
|
|
set text_font [list $::wm_default::textfamily $::wm_default::fontsize]
|
|
set fixed_font [list $::wm_default::fixedfamily $::wm_default::fontsize]
|
|
} default {
|
|
set system_font [list $::wm_default::systemfamily -$::wm_default::fontsize]
|
|
if {[set type $::wm_default::wm] == ""} {
|
|
# Generic unix
|
|
# some Unix Wms seem to make Menu fonts bold - ugly IMHO
|
|
set menu_font [list $::wm_default::menufamily -$::wm_default::fontsize bold]
|
|
} else {
|
|
# gnome kde1 kde2 cde kde don't
|
|
set menu_font [list $::wm_default::menufamily -$::wm_default::fontsize]
|
|
}
|
|
set text_font [list $::wm_default::textfamily -$::wm_default::fontsize]
|
|
set fixed_font [list $::wm_default::fixedfamily -$::wm_default::fontsize]
|
|
}
|
|
}
|
|
|
|
proc addoptions {args} {
|
|
global tcl_platform env tix_version
|
|
|
|
# variables that will be derived
|
|
variable system_font
|
|
variable menu_font
|
|
variable fixed_font
|
|
variable text_font
|
|
|
|
if {[info commands "tix"] != ""} {set _usetix 1} {set _usetix 0}
|
|
|
|
# Override what you have found with any optional arguments
|
|
foreach {var val} $args {
|
|
set var [string trimleft $var "-"]
|
|
set ::wm_default::$var $val
|
|
}
|
|
|
|
set pri $::wm_default::priority
|
|
# If you are running under Tix, set the colorscheme now
|
|
# The options below will then override the Tix settings
|
|
if {$_usetix} {
|
|
# Tix's focus model is very non-standard
|
|
bind TixComboBox <FocusIn> ""
|
|
bind TixComboBox <FocusOut> ""
|
|
|
|
if {$tix_version < "8.2"} {
|
|
# works??
|
|
option add *TixNoteBook.nbframe.inactiveBackground \
|
|
$::wm_default::disabledbackground $pri
|
|
} else {
|
|
# works??
|
|
option add *TixNoteBook.nbframe.inactiveBackground \
|
|
$::wm_default::background $pri
|
|
}
|
|
|
|
# works??
|
|
option add *TixPanedWindow.seperatorBg \
|
|
$::wm_default::disabledbackground $pri
|
|
option add *TixPanedWindow.handleBg \
|
|
$::wm_default::disabledbackground $pri
|
|
|
|
# works??
|
|
option add *TixPanedWindow.separatorActiveBg \
|
|
$::wm_default::activebackground $pri
|
|
option add *TixPanedWindow.handleActiveBg \
|
|
$::wm_default::activebackground $pri
|
|
option add *TixPanedWindow.Background \
|
|
$::wm_default::disabledbackground $pri
|
|
|
|
# works??
|
|
option add *TixResizeHandle*background \
|
|
$::wm_default::disabledbackground $pri
|
|
|
|
}
|
|
foreach pref $wm_default::_frame_widgets {
|
|
option add $pref.background $::wm_default::background $pri
|
|
}
|
|
option add *Background $::wm_default::background $pri
|
|
|
|
derivefonts
|
|
|
|
# Set the global defaults to the system font
|
|
foreach pref [list *Font *font] {
|
|
option add $pref $system_font $pri
|
|
}
|
|
|
|
# Set the "system" type defaults to the system font
|
|
foreach pref $wm_default::_menu_font_widgets {
|
|
option add $pref.font $menu_font $pri
|
|
}
|
|
foreach pref $wm_default::_button_font_widgets {
|
|
option add $pref.font $system_font $pri
|
|
option add $pref.disabledForeground $::wm_default::disabledforeground $pri
|
|
option add $pref.background $::wm_default::background $pri
|
|
option add $pref.foreground $::wm_default::foreground $pri
|
|
option add $pref.highlightBackground $::wm_default::highlightbackground $pri
|
|
}
|
|
foreach pref $wm_default::_system_font_widgets {
|
|
option add $pref.font $system_font $pri
|
|
option add $pref.background $::wm_default::background $pri
|
|
option add $pref.foreground $::wm_default::foreground $pri
|
|
option add $pref.highlightBackground $::wm_default::highlightbackground $pri
|
|
}
|
|
|
|
foreach pref $wm_default::_text_type_widgets {
|
|
option add $pref.font $text_font $pri
|
|
option add $pref.relief sunken $pri
|
|
option add $pref.borderWidth $::wm_default::borderwidth $pri
|
|
|
|
option add $pref.background $::wm_default::textbackground $pri
|
|
option add $pref.foreground $::wm_default::textforeground $pri
|
|
option add $pref.selectBackground $::wm_default::selectbackground $pri
|
|
option add $pref.selectForeground $::wm_default::selectforeground $pri
|
|
option add $pref.highlightThickness $::wm_default::highlightthickness $pri
|
|
option add $pref.disabledBackground $::wm_default::disabledtextbackground $pri
|
|
}
|
|
foreach pref $wm_default::_insert_type_widgets {
|
|
option add $pref.relief sunken $pri
|
|
option add $pref.insertBackground $::wm_default::textforeground $pri
|
|
option add $pref.highlightThickness $::wm_default::highlightthickness $pri
|
|
}
|
|
#
|
|
# Set the Selector color for radiobuttons, checkbuttons, et. al
|
|
#
|
|
foreach pref $wm_default::_select_type_widgets {
|
|
option add $pref.selectColor $::wm_default::selectcolor $pri
|
|
option add $pref.background $::wm_default::background $pri
|
|
option add $pref.foreground $::wm_default::foreground $pri
|
|
|
|
option add $pref.activeBackground $::wm_default::activebackground $pri
|
|
option add $pref.activeForeground $::wm_default::activeforeground $pri
|
|
}
|
|
|
|
# Set the "active" defaults - this could be controversial
|
|
foreach pref $wm_default::_menu_font_widgets {
|
|
option add $pref.activeBackground $::wm_default::activebackground $pri
|
|
option add $pref.activeForeground $::wm_default::activeforeground $pri
|
|
option add $pref.background $::wm_default::background $pri
|
|
option add $pref.foreground $::wm_default::foreground $pri
|
|
option add $pref.disabledForeground $::wm_default::disabledforeground $pri
|
|
option add $pref.highlightThickness $::wm_default::highlightthickness $pri
|
|
}
|
|
|
|
switch -exact -- $tcl_platform(platform) windows {
|
|
# Make sure this is set to foreground - check marks on menus
|
|
set _menu_select_color $::wm_default::foreground
|
|
} default {
|
|
# On unix there are recessed check boxes not check marks
|
|
set _menu_select_color $::wm_default::selectcolor
|
|
}
|
|
option add *Menu.selectColor $_menu_select_color $pri
|
|
if {$_usetix} {
|
|
option add *TixMenu.selectColor $_menu_select_color $pri
|
|
option add *TixBalloon*message.background $::wm_default::textbackground $pri
|
|
}
|
|
|
|
# Windows does not have an activebackground, but Tk does
|
|
foreach pref $wm_default::_button_font_widgets {
|
|
option add $pref.activeBackground $::wm_default::activebackground $pri
|
|
option add $pref.activeForeground $::wm_default::activeforeground $pri
|
|
}
|
|
|
|
#
|
|
# Set the default *button borderwidth
|
|
#
|
|
# option add *.borderWidth $::wm_default::borderwidth $pri
|
|
|
|
foreach pref $wm_default::_active_borderwidth_widgets {
|
|
option add $pref.activeBorderWidth $::wm_default::borderwidth $pri
|
|
option add $pref.borderWidth $::wm_default::borderwidth $pri
|
|
}
|
|
foreach pref $wm_default::_nonzero_borderwidth_widgets {
|
|
option add $pref.borderWidth $::wm_default::borderwidth $pri
|
|
}
|
|
foreach pref $wm_default::_null_borderwidth_widgets {
|
|
option add $pref.borderWidth 0 $pri
|
|
}
|
|
|
|
if {$_usetix} {
|
|
if {$tix_version < "8.2"} {
|
|
option add *TixNoteBook.nbframe.inactiveBackground \
|
|
$::wm_default::disabledbackground $pri
|
|
option add *TixNoteBook*nbframe.inactiveBackground \
|
|
$::wm_default::disabledbackground $pri
|
|
} else {
|
|
option add *TixNoteBook.nbframe.inactiveBackground \
|
|
$::wm_default::background $pri
|
|
option add *TixNoteBook*nbframe.inactiveBackground \
|
|
$::wm_default::background $pri
|
|
}
|
|
}
|
|
|
|
foreach pref $wm_default::_scrollbar_widgets {
|
|
option add $pref.background $::wm_default::background $pri
|
|
option add $pref.foreground $::wm_default::foreground $pri
|
|
# Tix 8.1.1 had these wrong
|
|
option add $pref.troughColor $::wm_default::scrollbars $pri
|
|
option add $pref.borderWidth $::wm_default::borderwidth $pri
|
|
}
|
|
option add *Scale.borderWidth $::wm_default::borderwidth $pri
|
|
option add *Scale.troughColor $::wm_default::scrollbars $pri
|
|
|
|
option add *highlightColor $::wm_default::highlightcolor $pri
|
|
option add *highlightBackground $::wm_default::highlightbackground $pri
|
|
option add *HighlightBackground $::wm_default::highlightbackground $pri
|
|
|
|
# not _system_font_widgets
|
|
set _focus_widgets [concat \
|
|
$::wm_default::_frame_widgets \
|
|
$::wm_default::_menu_font_widgets \
|
|
$::wm_default::_text_type_widgets \
|
|
$::wm_default::_insert_type_widgets \
|
|
$::wm_default::_select_type_widgets \
|
|
$::wm_default::_active_borderwidth_widgets \
|
|
$::wm_default::_nonzero_borderwidth_widgets \
|
|
$::wm_default::_null_borderwidth_widgets ]
|
|
|
|
if {$_usetix} {
|
|
set _tix_hl_widgets [list *TixBitmapButton*label \
|
|
*TixComboBox*Entry \
|
|
*TixControl*entry \
|
|
*TixDirList*hlist \
|
|
*TixDirTree*hlist \
|
|
*TixFileEntry*Entry \
|
|
*TixFileEntry*entry \
|
|
*TixMultiList*Listbox \
|
|
*TixNoteBook.nbframe \
|
|
*TixOptionMenu*menubutton \
|
|
*TixScrolledHList*hlist \
|
|
*TixScrolledListBox*listbox\
|
|
*TixScrolledTList*tlist \
|
|
*TixTree*hlist]
|
|
eval lappend _focus_widgets $_tix_hl_widgets
|
|
}
|
|
|
|
foreach pref [lsort -uniq $_focus_widgets] {
|
|
option add $pref.highlightBackground $::wm_default::highlightbackground $pri
|
|
}
|
|
|
|
# Now for some things to make it look more like the WM
|
|
|
|
# todo - look for and call
|
|
if {$::wm_default::focusmodel eq "followsmouse"} {
|
|
tk_focusFollowsMouse
|
|
}
|
|
|
|
if {$_usetix} {
|
|
tixSetDefaultOptions
|
|
|
|
if {[lsearch -exact {windows kde1 kde2} $::wm_default::wm] > -1} {
|
|
# Fix the way Button boxes are packed
|
|
if {![llength [info procs ::tixButtonBox:add]]} {
|
|
uplevel #0 auto_load tixButtonBox
|
|
}
|
|
proc ::tixButtonBox:add {w name args} {
|
|
upvar #0 $w data
|
|
eval [linsert $args 0 button $w.$name]
|
|
if {![info exists data(-padx)]} {set data(-padx) 5}
|
|
if {![info exists data(-pady)]} {set data(-pady) 10}
|
|
if {$data(-orientation) eq "horizontal"} {
|
|
# Push the Buttons to the right
|
|
if {[info commands $w.pad] == ""} {
|
|
label $w.pad
|
|
pack $w.pad -side left -expand yes -fill both
|
|
}
|
|
pack $w.$name -side left \
|
|
-expand no \
|
|
-padx $data(-padx) -pady $data(-pady)
|
|
} else {
|
|
pack $w.$name -side top \
|
|
-expand no -fill x \
|
|
-padx $data(-padx) -pady $data(-pady)
|
|
}
|
|
lappend data(g:buttons) $name
|
|
set data(w:$name) $w.$name
|
|
return $w.$name
|
|
}
|
|
option add *TixButtonBox.relief flat $::wm_default::priority
|
|
option add *TixButtonBox.borderwidth 2 $::wm_default::priority
|
|
}
|
|
}
|
|
return [getoptions]
|
|
}
|
|
|
|
namespace export setup addoptions getoptions parray
|
|
}
|
|
|
|
package provide wm_default 1.0
|
|
|
|
|
|
proc tixSetDefaultOptions {} {
|
|
# Returns one of cde kde1 kde2 gnome windows or ""
|
|
global tcl_platform env tixOption
|
|
|
|
# There is no overlap between the wm_default variable names and
|
|
# the old style tixOption names. So we can add the wm_default variable
|
|
# names to the array tixOption, and allow people to upgrade in time.
|
|
|
|
foreach variable {
|
|
wm
|
|
linkcolor
|
|
vlinkcolor
|
|
alinkcolor
|
|
background
|
|
foreground
|
|
disabledforeground
|
|
disabledbackground
|
|
textfamily
|
|
systemfamily
|
|
menufamily
|
|
fixedfamily
|
|
fontsize
|
|
textbackground
|
|
textforeground
|
|
disabledtextbackground
|
|
selectbackground
|
|
selectforeground
|
|
selectcolor
|
|
highlightcolor
|
|
highlightbackground
|
|
scrollbars
|
|
borderwidth
|
|
priority
|
|
menubackground
|
|
menuforeground
|
|
activebackground
|
|
activeforeground
|
|
system_font
|
|
menu_font
|
|
fixed_font
|
|
text_font
|
|
} {
|
|
set tixOption($variable) [set ::wm_default::$variable]
|
|
}
|
|
|
|
}
|