399 lines
9.5 KiB
Tcl
399 lines
9.5 KiB
Tcl
|
# -*- mode: TCL; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*-
|
||
|
|
#
|
||
|
|
# $Id: Tix.tcl,v 1.14 2008/03/17 23:01:10 hobbs Exp $
|
||
|
|
#
|
||
|
|
# Tix.tcl --
|
||
|
|
#
|
||
|
|
# This file implements the Tix application context class
|
||
|
|
#
|
||
|
|
# Copyright (c) 1993-1999 Ioi Kim Lam.
|
||
|
|
# Copyright (c) 2000-2001 Tix Project Group.
|
||
|
|
# Copyright (c) 2004 ActiveState
|
||
|
|
#
|
||
|
|
# See the file "license.terms" for information on usage and redistribution
|
||
|
|
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||
|
|
#
|
||
|
|
|
||
|
|
tixClass tixAppContext {
|
||
|
|
-superclass {}
|
||
|
|
-classname TixAppContext
|
||
|
|
-method {
|
||
|
|
cget configure addbitmapdir filedialog getbitmap getimage
|
||
|
|
option platform resetoptions setbitmap initstyle
|
||
|
|
}
|
||
|
|
-flag {
|
||
|
|
-binding -debug -extracmdargs -filedialog -fontset -grabmode
|
||
|
|
-haspixmap -libdir -scheme -schemepriority -percentsubst
|
||
|
|
}
|
||
|
|
-readonly {
|
||
|
|
-haspixmap
|
||
|
|
}
|
||
|
|
-configspec {
|
||
|
|
{-binding TK}
|
||
|
|
{-debug 0}
|
||
|
|
{-extracmdargs 1}
|
||
|
|
{-filedialog ""}
|
||
|
|
{-fontset WmDefault}
|
||
|
|
{-grabmode global}
|
||
|
|
{-haspixmap 0}
|
||
|
|
{-libdir ""}
|
||
|
|
{-percentsubst 0}
|
||
|
|
{-scheme WmDefault}
|
||
|
|
{-schemepriority 21}
|
||
|
|
}
|
||
|
|
-alias {
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
proc tixAppContext:Constructor {w} {
|
||
|
|
upvar #0 $w data
|
||
|
|
global tix_priv tix_library tixOption
|
||
|
|
|
||
|
|
if {[info exists data(initialized)]} {
|
||
|
|
error "tixAppContext has already be initialized"
|
||
|
|
} else {
|
||
|
|
set data(initialized) 1
|
||
|
|
}
|
||
|
|
|
||
|
|
set data(et) [string equal $tix_library ""]
|
||
|
|
set data(image) 0
|
||
|
|
|
||
|
|
# These options were set when Tix was loaded
|
||
|
|
#
|
||
|
|
set data(-binding) $tix_priv(-binding)
|
||
|
|
set data(-debug) $tix_priv(-debug)
|
||
|
|
set data(-fontset) $tix_priv(-fontset)
|
||
|
|
set data(-scheme) $tix_priv(-scheme)
|
||
|
|
set data(-schemepriority) $tix_priv(-schemepriority)
|
||
|
|
|
||
|
|
if {![info exists tix_priv(isSafe)]} {
|
||
|
|
set data(-libdir) [file normalize $tix_library]
|
||
|
|
}
|
||
|
|
set tixOption(prioLevel) $tix_priv(-schemepriority)
|
||
|
|
|
||
|
|
# Compatibility stuff: the obsolete name courier_font has been changed to
|
||
|
|
# fixed_font
|
||
|
|
set tixOption(fixed_font) Courier
|
||
|
|
set tixOption(courier_font) $tixOption(fixed_font)
|
||
|
|
|
||
|
|
# Enable/Disable Intrinsics debugging
|
||
|
|
#
|
||
|
|
set tix_priv(debug) [string is true -strict $data(-debug)]
|
||
|
|
|
||
|
|
tixAppContext:BitmapInit $w
|
||
|
|
tixAppContext:FileDialogInit $w
|
||
|
|
|
||
|
|
# Clean up any error message generated by the above loop
|
||
|
|
set ::errorInfo ""
|
||
|
|
}
|
||
|
|
|
||
|
|
proc tixAppContext:initstyle {w} {
|
||
|
|
# Do the init stuff here that affects styles
|
||
|
|
|
||
|
|
upvar #0 $w data
|
||
|
|
global tix_priv
|
||
|
|
|
||
|
|
if {![info exists tix_priv(isSafe)]} {
|
||
|
|
tixAppContext:config-fontset $w $data(-fontset)
|
||
|
|
tixAppContext:config-scheme $w $data(-scheme)
|
||
|
|
}
|
||
|
|
|
||
|
|
tixAppContext:BitmapInit $w
|
||
|
|
tixAppContext:FileDialogInit $w
|
||
|
|
|
||
|
|
# Force the "." window to accept the new Tix options
|
||
|
|
#
|
||
|
|
set noconfig [list -class -colormap -container -menu -screen -use -visual]
|
||
|
|
set noconfig [lsort $noconfig]
|
||
|
|
foreach spec [. configure] {
|
||
|
|
set flag [lindex $spec 0]
|
||
|
|
if {[llength $spec] != 5
|
||
|
|
|| [lsearch -exact -sorted $noconfig $flag] != -1} {
|
||
|
|
continue
|
||
|
|
}
|
||
|
|
set name [lindex $spec 1]
|
||
|
|
set class [lindex $spec 2]
|
||
|
|
set value [option get . $name $class]
|
||
|
|
catch {. configure $flag $value}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
#----------------------------------------------------------------------
|
||
|
|
# Configurations
|
||
|
|
#
|
||
|
|
#----------------------------------------------------------------------
|
||
|
|
proc tixAppContext:resetoptions {w scheme fontset {schemePrio ""}} {
|
||
|
|
upvar #0 $w data
|
||
|
|
|
||
|
|
if {! $data(et)} {
|
||
|
|
global tixOption
|
||
|
|
option clear
|
||
|
|
|
||
|
|
if {$schemePrio != ""} {
|
||
|
|
set tixOption(prioLevel) $schemePrio
|
||
|
|
}
|
||
|
|
tixAppContext:config-scheme $w $scheme
|
||
|
|
tixAppContext:config-fontset $w $fontset
|
||
|
|
}
|
||
|
|
}
|
||
|
|
proc tixAppContext:StartupError {args} {
|
||
|
|
bgerror [join $args "\n"]
|
||
|
|
}
|
||
|
|
|
||
|
|
proc tixAppContext:config-fontset {w value} {
|
||
|
|
upvar #0 $w data
|
||
|
|
global tix_priv tixOption
|
||
|
|
|
||
|
|
set data(-fontset) $value
|
||
|
|
|
||
|
|
#-----------------------------------
|
||
|
|
# Initialization of options database
|
||
|
|
#-----------------------------------
|
||
|
|
# Load the fontset
|
||
|
|
#
|
||
|
|
if {!$data(et)} {
|
||
|
|
set prefDir [file join $data(-libdir) pref]
|
||
|
|
set fontSetFile [file join $prefDir $data(-fontset).fsc]
|
||
|
|
if {[file exists $fontSetFile]} {
|
||
|
|
source $fontSetFile
|
||
|
|
tixPref:InitFontSet:$data(-fontset)
|
||
|
|
tixPref:SetFontSet:$data(-fontset)
|
||
|
|
} else {
|
||
|
|
tixAppContext:StartupError \
|
||
|
|
" Error: cannot use fontset \"$data(-fontset)\"" \
|
||
|
|
" Using default fontset "
|
||
|
|
tixSetDefaultFontset
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
if [catch {
|
||
|
|
tixPref:InitFontSet:$data(-fontset)
|
||
|
|
tixPref:SetFontSet:$data(-fontset)
|
||
|
|
}] {
|
||
|
|
# User chose non-existent fontset
|
||
|
|
#
|
||
|
|
tixAppContext:StartupError \
|
||
|
|
" Error: cannot use fontset \"$data(-fontset)\"" \
|
||
|
|
" Using default fontset "
|
||
|
|
tixSetDefaultFontset
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
proc tixAppContext:config-scheme {w value} {
|
||
|
|
upvar #0 $w data
|
||
|
|
global tix_priv
|
||
|
|
|
||
|
|
set data(-scheme) $value
|
||
|
|
|
||
|
|
# Load the color scheme
|
||
|
|
#
|
||
|
|
if {!$data(et)} {
|
||
|
|
set schemeName [file join [file join $data(-libdir) pref] \
|
||
|
|
$data(-scheme).csc]
|
||
|
|
if {[file exists $schemeName]} {
|
||
|
|
source $schemeName
|
||
|
|
tixPref:SetScheme-Color:$data(-scheme)
|
||
|
|
} else {
|
||
|
|
tixAppContext:StartupError \
|
||
|
|
" Error: cannot use color scheme \"$data(-scheme)\"" \
|
||
|
|
" Using default color scheme"
|
||
|
|
tixSetDefaultScheme-Color
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
if [catch {tixPref:SetScheme-Color:$data(-scheme)}] {
|
||
|
|
# User chose non-existent color scheme
|
||
|
|
#
|
||
|
|
tixAppContext:StartupError \
|
||
|
|
" Error: cannot use color scheme \"$data(-scheme)\"" \
|
||
|
|
" Using default color scheme"
|
||
|
|
tixSetDefaultScheme-Color
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
#----------------------------------------------------------------------
|
||
|
|
# Private methods
|
||
|
|
#
|
||
|
|
#----------------------------------------------------------------------
|
||
|
|
proc tixAppContext:BitmapInit {w} {
|
||
|
|
upvar #0 $w data
|
||
|
|
|
||
|
|
# See whether we have pixmap extension
|
||
|
|
#
|
||
|
|
set data(-haspixmap) true
|
||
|
|
|
||
|
|
# Dynamically set the bitmap directory
|
||
|
|
#
|
||
|
|
if {! $data(et)} {
|
||
|
|
set data(bitmapdirs) [list [file join $data(-libdir) bitmaps]]
|
||
|
|
} else {
|
||
|
|
set data(bitmapdirs) ""
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
proc tixAppContext:FileDialogInit {w} {
|
||
|
|
upvar #0 $w data
|
||
|
|
|
||
|
|
if {$data(-filedialog) == ""} {
|
||
|
|
set data(-filedialog) [option get . fileDialog FileDialog]
|
||
|
|
}
|
||
|
|
if {$data(-filedialog) == ""} {
|
||
|
|
set data(-filedialog) tixFileSelectDialog
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
#----------------------------------------------------------------------
|
||
|
|
# Public methods
|
||
|
|
#----------------------------------------------------------------------
|
||
|
|
proc tixAppContext:addbitmapdir {w bmpdir} {
|
||
|
|
upvar #0 $w data
|
||
|
|
|
||
|
|
if {[lsearch $data(bitmapdirs) $bmpdir] == -1} {
|
||
|
|
lappend data(bitmapdirs) $bmpdir
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
proc tixAppContext:getimage {w name} {
|
||
|
|
upvar #0 $w data
|
||
|
|
global tix_priv
|
||
|
|
|
||
|
|
if {[info exists data(img:$name)]} {
|
||
|
|
return $data(img:$name)
|
||
|
|
}
|
||
|
|
|
||
|
|
if {![info exists tix_priv(isSafe)]} {
|
||
|
|
foreach dir $data(bitmapdirs) {
|
||
|
|
foreach {ext type} {
|
||
|
|
.xpm pixmap
|
||
|
|
.gif photo
|
||
|
|
.ppm photo
|
||
|
|
.xbm bitmap
|
||
|
|
"" bitmap
|
||
|
|
} {
|
||
|
|
set file [file join $dir $name$ext]
|
||
|
|
if {[file exists $file]
|
||
|
|
&& ![catch {
|
||
|
|
set img tiximage$data(image)
|
||
|
|
set data(img:$name) \
|
||
|
|
[image create $type $img -file $file]
|
||
|
|
}]} {
|
||
|
|
incr data(image)
|
||
|
|
break
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if {[info exists data(img:$name)]} {
|
||
|
|
return $data(img:$name)
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
if {![info exists data(img:$name)]} {
|
||
|
|
catch {
|
||
|
|
set img tiximage$data(image)
|
||
|
|
# This is for compiled-in images
|
||
|
|
set data(img:$name) [image create pixmap $img -id $name]
|
||
|
|
} err
|
||
|
|
if {[string match internal* $err]} {
|
||
|
|
error $err
|
||
|
|
} else {
|
||
|
|
incr data(image)
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
if {[info exists data(img:$name)]} {
|
||
|
|
return $data(img:$name)
|
||
|
|
} else {
|
||
|
|
error "image file \"$name\" cannot be found"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
proc tixAppContext:getbitmap {w bitmapname} {
|
||
|
|
upvar #0 $w data
|
||
|
|
global tix_priv
|
||
|
|
|
||
|
|
if {[info exists data(bmp:$bitmapname)]} {
|
||
|
|
return $data(bmp:$bitmapname)
|
||
|
|
} else {
|
||
|
|
set ext [file extension $bitmapname]
|
||
|
|
if {$ext == ""} {
|
||
|
|
set ext .xbm
|
||
|
|
}
|
||
|
|
|
||
|
|
# This is the fallback value. If we can't find the bitmap in
|
||
|
|
# the bitmap directories, then use the name of the bitmap
|
||
|
|
# as the default value.
|
||
|
|
#
|
||
|
|
set data(bmp:$bitmapname) $bitmapname
|
||
|
|
|
||
|
|
if {[info exists tix_priv(isSafe)]} {
|
||
|
|
return $data(bmp:$bitmapname)
|
||
|
|
}
|
||
|
|
|
||
|
|
foreach dir $data(bitmapdirs) {
|
||
|
|
if {$ext eq ".xbm" &&
|
||
|
|
[file exists [file join $dir $bitmapname.xbm]]} {
|
||
|
|
set data(bmp:$bitmapname) \
|
||
|
|
@[file join $dir $bitmapname.xbm]
|
||
|
|
break
|
||
|
|
}
|
||
|
|
if {[file exists [file join $dir $bitmapname]]} {
|
||
|
|
set data(bmp:$bitmapname) @[file join $dir $bitmapname]
|
||
|
|
break
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
return $data(bmp:$bitmapname)
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
proc tixAppContext:filedialog {w {type tixFileSelectDialog}} {
|
||
|
|
upvar #0 $w data
|
||
|
|
|
||
|
|
if {$type == ""} {
|
||
|
|
set type $data(-filedialog)
|
||
|
|
}
|
||
|
|
if {![info exists data(filedialog,$type)]} {
|
||
|
|
set data(filedialog,$type) ""
|
||
|
|
}
|
||
|
|
|
||
|
|
if {$data(filedialog,$type) == "" || \
|
||
|
|
![winfo exists $data(filedialog,$type)]} {
|
||
|
|
set data(filedialog,$type) [$type .tixapp_filedialog_$type]
|
||
|
|
}
|
||
|
|
|
||
|
|
return $data(filedialog,$type)
|
||
|
|
}
|
||
|
|
|
||
|
|
proc tixAppContext:option {w action {option ""} {value ""}} {
|
||
|
|
global tixOption
|
||
|
|
|
||
|
|
if {$action eq "get"} {
|
||
|
|
if {$option == ""} {return [lsort [array names tixOption]]}
|
||
|
|
return $tixOption($option)
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
proc tixAppContext:platform {w} {
|
||
|
|
return $::tcl_platform(platform)
|
||
|
|
}
|
||
|
|
|
||
|
|
proc tixDebug {message {level "1"}} {
|
||
|
|
set debug [tix cget -debug]
|
||
|
|
if {![string is true -strict $debug]} { return }
|
||
|
|
|
||
|
|
if {$debug > 0} {
|
||
|
|
# use $level here
|
||
|
|
if {[catch {fconfigure stderr}]} {
|
||
|
|
# This will happen under PYTHONW.EXE or frozen Windows apps
|
||
|
|
proc tixDebug args {}
|
||
|
|
} else {
|
||
|
|
puts stderr $message
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
if {![llength [info commands toplevel]]} {
|
||
|
|
interp alias {} toplevel {} frame
|
||
|
|
}
|