added windows installer binary template builder
This commit is contained in:
Stefan Frederik
parent
c22039105f
commit
decb78c6ab
|
|
@ -3,7 +3,7 @@
|
|||
- Windows 10
|
||||
- ActiveState TCL/TK 8.69 x64 (https://www.activestate.com/products/tcl/)
|
||||
- Gawk for Windows (Add directory of awk.exe to PATH)
|
||||
- NGSpice for Windows
|
||||
- NGSpice for Windows (Add directory of NGSpice to PATH, if it's not already done so)
|
||||
|
||||
2. Install Tree
|
||||
C:/Program Files/XSchem/bin - Binaries (executable file).
|
||||
|
|
|
|||
|
|
@ -0,0 +1,648 @@
|
|||
# auto.tcl --
|
||||
#
|
||||
# utility procs formerly in init.tcl dealing with auto execution of commands
|
||||
# and can be auto loaded themselves.
|
||||
#
|
||||
# Copyright (c) 1991-1993 The Regents of the University of California.
|
||||
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution of
|
||||
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
|
||||
# auto_reset --
|
||||
#
|
||||
# Destroy all cached information for auto-loading and auto-execution, so that
|
||||
# the information gets recomputed the next time it's needed. Also delete any
|
||||
# commands that are listed in the auto-load index.
|
||||
#
|
||||
# Arguments:
|
||||
# None.
|
||||
|
||||
proc auto_reset {} {
|
||||
global auto_execs auto_index auto_path
|
||||
if {[array exists auto_index]} {
|
||||
foreach cmdName [array names auto_index] {
|
||||
set fqcn [namespace which $cmdName]
|
||||
if {$fqcn eq ""} {
|
||||
continue
|
||||
}
|
||||
rename $fqcn {}
|
||||
}
|
||||
}
|
||||
unset -nocomplain auto_execs auto_index ::tcl::auto_oldpath
|
||||
if {[catch {llength $auto_path}]} {
|
||||
set auto_path [list [info library]]
|
||||
} elseif {[info library] ni $auto_path} {
|
||||
lappend auto_path [info library]
|
||||
}
|
||||
}
|
||||
|
||||
# tcl_findLibrary --
|
||||
#
|
||||
# This is a utility for extensions that searches for a library directory
|
||||
# using a canonical searching algorithm. A side effect is to source the
|
||||
# initialization script and set a global library variable.
|
||||
#
|
||||
# Arguments:
|
||||
# basename Prefix of the directory name, (e.g., "tk")
|
||||
# version Version number of the package, (e.g., "8.0")
|
||||
# patch Patchlevel of the package, (e.g., "8.0.3")
|
||||
# initScript Initialization script to source (e.g., tk.tcl)
|
||||
# enVarName environment variable to honor (e.g., TK_LIBRARY)
|
||||
# varName Global variable to set when done (e.g., tk_library)
|
||||
|
||||
proc tcl_findLibrary {basename version patch initScript enVarName varName} {
|
||||
upvar #0 $varName the_library
|
||||
global auto_path env tcl_platform
|
||||
|
||||
set dirs {}
|
||||
set errors {}
|
||||
|
||||
# The C application may have hardwired a path, which we honor
|
||||
|
||||
if {[info exists the_library] && $the_library ne ""} {
|
||||
lappend dirs $the_library
|
||||
} else {
|
||||
# Do the canonical search
|
||||
|
||||
# 1. From an environment variable, if it exists. Placing this first
|
||||
# gives the end-user ultimate control to work-around any bugs, or
|
||||
# to customize.
|
||||
|
||||
if {[info exists env($enVarName)]} {
|
||||
lappend dirs $env($enVarName)
|
||||
}
|
||||
|
||||
# 2. In the package script directory registered within the
|
||||
# configuration of the package itself.
|
||||
|
||||
catch {
|
||||
lappend dirs [::${basename}::pkgconfig get scriptdir,runtime]
|
||||
}
|
||||
|
||||
# 3. Relative to auto_path directories. This checks relative to the
|
||||
# Tcl library as well as allowing loading of libraries added to the
|
||||
# auto_path that is not relative to the core library or binary paths.
|
||||
foreach d $auto_path {
|
||||
lappend dirs [file join $d $basename$version]
|
||||
if {$tcl_platform(platform) eq "unix"
|
||||
&& $tcl_platform(os) eq "Darwin"} {
|
||||
# 4. On MacOSX, check the Resources/Scripts subdir too
|
||||
lappend dirs [file join $d $basename$version Resources Scripts]
|
||||
}
|
||||
}
|
||||
|
||||
# 3. Various locations relative to the executable
|
||||
# ../lib/foo1.0 (From bin directory in install hierarchy)
|
||||
# ../../lib/foo1.0 (From bin/arch directory in install hierarchy)
|
||||
# ../library (From unix directory in build hierarchy)
|
||||
#
|
||||
# Remaining locations are out of date (when relevant, they ought to be
|
||||
# covered by the $::auto_path seach above) and disabled.
|
||||
#
|
||||
# ../../library (From unix/arch directory in build hierarchy)
|
||||
# ../../foo1.0.1/library
|
||||
# (From unix directory in parallel build hierarchy)
|
||||
# ../../../foo1.0.1/library
|
||||
# (From unix/arch directory in parallel build hierarchy)
|
||||
|
||||
set parentDir [file dirname [file dirname [info nameofexecutable]]]
|
||||
set grandParentDir [file dirname $parentDir]
|
||||
lappend dirs [file join $parentDir lib $basename$version]
|
||||
lappend dirs [file join $grandParentDir lib $basename$version]
|
||||
lappend dirs [file join $parentDir library]
|
||||
if {0} {
|
||||
lappend dirs [file join $grandParentDir library]
|
||||
lappend dirs [file join $grandParentDir $basename$patch library]
|
||||
lappend dirs [file join [file dirname $grandParentDir] \
|
||||
$basename$patch library]
|
||||
}
|
||||
}
|
||||
# uniquify $dirs in order
|
||||
array set seen {}
|
||||
foreach i $dirs {
|
||||
# Make sure $i is unique under normalization. Avoid repeated [source].
|
||||
if {[interp issafe]} {
|
||||
# Safe interps have no [file normalize].
|
||||
set norm $i
|
||||
} else {
|
||||
set norm [file normalize $i]
|
||||
}
|
||||
if {[info exists seen($norm)]} {
|
||||
continue
|
||||
}
|
||||
set seen($norm) {}
|
||||
|
||||
set the_library $i
|
||||
set file [file join $i $initScript]
|
||||
|
||||
# source everything when in a safe interpreter because we have a
|
||||
# source command, but no file exists command
|
||||
|
||||
if {[interp issafe] || [file exists $file]} {
|
||||
if {![catch {uplevel #0 [list source $file]} msg opts]} {
|
||||
return
|
||||
}
|
||||
append errors "$file: $msg\n"
|
||||
append errors [dict get $opts -errorinfo]\n
|
||||
}
|
||||
}
|
||||
unset -nocomplain the_library
|
||||
set msg "Can't find a usable $initScript in the following directories: \n"
|
||||
append msg " $dirs\n\n"
|
||||
append msg "$errors\n\n"
|
||||
append msg "This probably means that $basename wasn't installed properly.\n"
|
||||
error $msg
|
||||
}
|
||||
|
||||
|
||||
# ----------------------------------------------------------------------
|
||||
# auto_mkindex
|
||||
# ----------------------------------------------------------------------
|
||||
# The following procedures are used to generate the tclIndex file from Tcl
|
||||
# source files. They use a special safe interpreter to parse Tcl source
|
||||
# files, writing out index entries as "proc" commands are encountered. This
|
||||
# implementation won't work in a safe interpreter, since a safe interpreter
|
||||
# can't create the special parser and mess with its commands.
|
||||
|
||||
if {[interp issafe]} {
|
||||
return ;# Stop sourcing the file here
|
||||
}
|
||||
|
||||
# auto_mkindex --
|
||||
# Regenerate a tclIndex file from Tcl source files. Takes as argument the
|
||||
# name of the directory in which the tclIndex file is to be placed, followed
|
||||
# by any number of glob patterns to use in that directory to locate all of the
|
||||
# relevant files.
|
||||
#
|
||||
# Arguments:
|
||||
# dir - Name of the directory in which to create an index.
|
||||
|
||||
# args - Any number of additional arguments giving the names of files
|
||||
# within dir. If no additional are given auto_mkindex will look
|
||||
# for *.tcl.
|
||||
|
||||
proc auto_mkindex {dir args} {
|
||||
if {[interp issafe]} {
|
||||
error "can't generate index within safe interpreter"
|
||||
}
|
||||
|
||||
set oldDir [pwd]
|
||||
cd $dir
|
||||
|
||||
append index "# Tcl autoload index file, version 2.0\n"
|
||||
append index "# This file is generated by the \"auto_mkindex\" command\n"
|
||||
append index "# and sourced to set up indexing information for one or\n"
|
||||
append index "# more commands. Typically each line is a command that\n"
|
||||
append index "# sets an element in the auto_index array, where the\n"
|
||||
append index "# element name is the name of a command and the value is\n"
|
||||
append index "# a script that loads the command.\n\n"
|
||||
if {![llength $args]} {
|
||||
set args *.tcl
|
||||
}
|
||||
|
||||
auto_mkindex_parser::init
|
||||
foreach file [lsort [glob -- {*}$args]] {
|
||||
try {
|
||||
append index [auto_mkindex_parser::mkindex $file]
|
||||
} on error {msg opts} {
|
||||
cd $oldDir
|
||||
return -options $opts $msg
|
||||
}
|
||||
}
|
||||
auto_mkindex_parser::cleanup
|
||||
|
||||
set fid [open "tclIndex" w]
|
||||
puts -nonewline $fid $index
|
||||
close $fid
|
||||
cd $oldDir
|
||||
}
|
||||
|
||||
# Original version of auto_mkindex that just searches the source code for
|
||||
# "proc" at the beginning of the line.
|
||||
|
||||
proc auto_mkindex_old {dir args} {
|
||||
set oldDir [pwd]
|
||||
cd $dir
|
||||
set dir [pwd]
|
||||
append index "# Tcl autoload index file, version 2.0\n"
|
||||
append index "# This file is generated by the \"auto_mkindex\" command\n"
|
||||
append index "# and sourced to set up indexing information for one or\n"
|
||||
append index "# more commands. Typically each line is a command that\n"
|
||||
append index "# sets an element in the auto_index array, where the\n"
|
||||
append index "# element name is the name of a command and the value is\n"
|
||||
append index "# a script that loads the command.\n\n"
|
||||
if {![llength $args]} {
|
||||
set args *.tcl
|
||||
}
|
||||
foreach file [lsort [glob -- {*}$args]] {
|
||||
set f ""
|
||||
set error [catch {
|
||||
set f [open $file]
|
||||
fconfigure $f -eofchar \032
|
||||
while {[gets $f line] >= 0} {
|
||||
if {[regexp {^proc[ ]+([^ ]*)} $line match procName]} {
|
||||
set procName [lindex [auto_qualify $procName "::"] 0]
|
||||
append index "set [list auto_index($procName)]"
|
||||
append index " \[list source \[file join \$dir [list $file]\]\]\n"
|
||||
}
|
||||
}
|
||||
close $f
|
||||
} msg opts]
|
||||
if {$error} {
|
||||
catch {close $f}
|
||||
cd $oldDir
|
||||
return -options $opts $msg
|
||||
}
|
||||
}
|
||||
set f ""
|
||||
set error [catch {
|
||||
set f [open tclIndex w]
|
||||
puts -nonewline $f $index
|
||||
close $f
|
||||
cd $oldDir
|
||||
} msg opts]
|
||||
if {$error} {
|
||||
catch {close $f}
|
||||
cd $oldDir
|
||||
error $msg $info $code
|
||||
return -options $opts $msg
|
||||
}
|
||||
}
|
||||
|
||||
# Create a safe interpreter that can be used to parse Tcl source files
|
||||
# generate a tclIndex file for autoloading. This interp contains commands for
|
||||
# things that need index entries. Each time a command is executed, it writes
|
||||
# an entry out to the index file.
|
||||
|
||||
namespace eval auto_mkindex_parser {
|
||||
variable parser "" ;# parser used to build index
|
||||
variable index "" ;# maintains index as it is built
|
||||
variable scriptFile "" ;# name of file being processed
|
||||
variable contextStack "" ;# stack of namespace scopes
|
||||
variable imports "" ;# keeps track of all imported cmds
|
||||
variable initCommands ;# list of commands that create aliases
|
||||
if {![info exists initCommands]} {
|
||||
set initCommands [list]
|
||||
}
|
||||
|
||||
proc init {} {
|
||||
variable parser
|
||||
variable initCommands
|
||||
|
||||
if {![interp issafe]} {
|
||||
set parser [interp create -safe]
|
||||
$parser hide info
|
||||
$parser hide rename
|
||||
$parser hide proc
|
||||
$parser hide namespace
|
||||
$parser hide eval
|
||||
$parser hide puts
|
||||
foreach ns [$parser invokehidden namespace children ::] {
|
||||
# MUST NOT DELETE "::tcl" OR BAD THINGS HAPPEN!
|
||||
if {$ns eq "::tcl"} continue
|
||||
$parser invokehidden namespace delete $ns
|
||||
}
|
||||
foreach cmd [$parser invokehidden info commands ::*] {
|
||||
$parser invokehidden rename $cmd {}
|
||||
}
|
||||
$parser invokehidden proc unknown {args} {}
|
||||
|
||||
# We'll need access to the "namespace" command within the
|
||||
# interp. Put it back, but move it out of the way.
|
||||
|
||||
$parser expose namespace
|
||||
$parser invokehidden rename namespace _%@namespace
|
||||
$parser expose eval
|
||||
$parser invokehidden rename eval _%@eval
|
||||
|
||||
# Install all the registered psuedo-command implementations
|
||||
|
||||
foreach cmd $initCommands {
|
||||
eval $cmd
|
||||
}
|
||||
}
|
||||
}
|
||||
proc cleanup {} {
|
||||
variable parser
|
||||
interp delete $parser
|
||||
unset parser
|
||||
}
|
||||
}
|
||||
|
||||
# auto_mkindex_parser::mkindex --
|
||||
#
|
||||
# Used by the "auto_mkindex" command to create a "tclIndex" file for the given
|
||||
# Tcl source file. Executes the commands in the file, and handles things like
|
||||
# the "proc" command by adding an entry for the index file. Returns a string
|
||||
# that represents the index file.
|
||||
#
|
||||
# Arguments:
|
||||
# file Name of Tcl source file to be indexed.
|
||||
|
||||
proc auto_mkindex_parser::mkindex {file} {
|
||||
variable parser
|
||||
variable index
|
||||
variable scriptFile
|
||||
variable contextStack
|
||||
variable imports
|
||||
|
||||
set scriptFile $file
|
||||
|
||||
set fid [open $file]
|
||||
fconfigure $fid -eofchar \032
|
||||
set contents [read $fid]
|
||||
close $fid
|
||||
|
||||
# There is one problem with sourcing files into the safe interpreter:
|
||||
# references like "$x" will fail since code is not really being executed
|
||||
# and variables do not really exist. To avoid this, we replace all $ with
|
||||
# \0 (literally, the null char) later, when getting proc names we will
|
||||
# have to reverse this replacement, in case there were any $ in the proc
|
||||
# name. This will cause a problem if somebody actually tries to have a \0
|
||||
# in their proc name. Too bad for them.
|
||||
set contents [string map [list \$ \0] $contents]
|
||||
|
||||
set index ""
|
||||
set contextStack ""
|
||||
set imports ""
|
||||
|
||||
$parser eval $contents
|
||||
|
||||
foreach name $imports {
|
||||
catch {$parser eval [list _%@namespace forget $name]}
|
||||
}
|
||||
return $index
|
||||
}
|
||||
|
||||
# auto_mkindex_parser::hook command
|
||||
#
|
||||
# Registers a Tcl command to evaluate when initializing the child interpreter
|
||||
# used by the mkindex parser. The command is evaluated in the parent
|
||||
# interpreter, and can use the variable auto_mkindex_parser::parser to get to
|
||||
# the child
|
||||
|
||||
proc auto_mkindex_parser::hook {cmd} {
|
||||
variable initCommands
|
||||
|
||||
lappend initCommands $cmd
|
||||
}
|
||||
|
||||
# auto_mkindex_parser::slavehook command
|
||||
#
|
||||
# Registers a Tcl command to evaluate when initializing the child interpreter
|
||||
# used by the mkindex parser. The command is evaluated in the child
|
||||
# interpreter.
|
||||
|
||||
proc auto_mkindex_parser::slavehook {cmd} {
|
||||
variable initCommands
|
||||
|
||||
# The $parser variable is defined to be the name of the child interpreter
|
||||
# when this command is used later.
|
||||
|
||||
lappend initCommands "\$parser eval [list $cmd]"
|
||||
}
|
||||
|
||||
# auto_mkindex_parser::command --
|
||||
#
|
||||
# Registers a new command with the "auto_mkindex_parser" interpreter that
|
||||
# parses Tcl files. These commands are fake versions of things like the
|
||||
# "proc" command. When you execute them, they simply write out an entry to a
|
||||
# "tclIndex" file for auto-loading.
|
||||
#
|
||||
# This procedure allows extensions to register their own commands with the
|
||||
# auto_mkindex facility. For example, a package like [incr Tcl] might
|
||||
# register a "class" command so that class definitions could be added to a
|
||||
# "tclIndex" file for auto-loading.
|
||||
#
|
||||
# Arguments:
|
||||
# name Name of command recognized in Tcl files.
|
||||
# arglist Argument list for command.
|
||||
# body Implementation of command to handle indexing.
|
||||
|
||||
proc auto_mkindex_parser::command {name arglist body} {
|
||||
hook [list auto_mkindex_parser::commandInit $name $arglist $body]
|
||||
}
|
||||
|
||||
# auto_mkindex_parser::commandInit --
|
||||
#
|
||||
# This does the actual work set up by auto_mkindex_parser::command. This is
|
||||
# called when the interpreter used by the parser is created.
|
||||
#
|
||||
# Arguments:
|
||||
# name Name of command recognized in Tcl files.
|
||||
# arglist Argument list for command.
|
||||
# body Implementation of command to handle indexing.
|
||||
|
||||
proc auto_mkindex_parser::commandInit {name arglist body} {
|
||||
variable parser
|
||||
|
||||
set ns [namespace qualifiers $name]
|
||||
set tail [namespace tail $name]
|
||||
if {$ns eq ""} {
|
||||
set fakeName [namespace current]::_%@fake_$tail
|
||||
} else {
|
||||
set fakeName [namespace current]::[string map {:: _} _%@fake_$name]
|
||||
}
|
||||
proc $fakeName $arglist $body
|
||||
|
||||
# YUK! Tcl won't let us alias fully qualified command names, so we can't
|
||||
# handle names like "::itcl::class". Instead, we have to build procs with
|
||||
# the fully qualified names, and have the procs point to the aliases.
|
||||
|
||||
if {[string match *::* $name]} {
|
||||
set exportCmd [list _%@namespace export [namespace tail $name]]
|
||||
$parser eval [list _%@namespace eval $ns $exportCmd]
|
||||
|
||||
# The following proc definition does not work if you want to tolerate
|
||||
# space or something else diabolical in the procedure name, (i.e.,
|
||||
# space in $alias). The following does not work:
|
||||
# "_%@eval {$alias} \$args"
|
||||
# because $alias gets concat'ed to $args. The following does not work
|
||||
# because $cmd is somehow undefined
|
||||
# "set cmd {$alias} \; _%@eval {\$cmd} \$args"
|
||||
# A gold star to someone that can make test autoMkindex-3.3 work
|
||||
# properly
|
||||
|
||||
set alias [namespace tail $fakeName]
|
||||
$parser invokehidden proc $name {args} "_%@eval {$alias} \$args"
|
||||
$parser alias $alias $fakeName
|
||||
} else {
|
||||
$parser alias $name $fakeName
|
||||
}
|
||||
return
|
||||
}
|
||||
|
||||
# auto_mkindex_parser::fullname --
|
||||
#
|
||||
# Used by commands like "proc" within the auto_mkindex parser. Returns the
|
||||
# qualified namespace name for the "name" argument. If the "name" does not
|
||||
# start with "::", elements are added from the current namespace stack to
|
||||
# produce a qualified name. Then, the name is examined to see whether or not
|
||||
# it should really be qualified. If the name has more than the leading "::",
|
||||
# it is returned as a fully qualified name. Otherwise, it is returned as a
|
||||
# simple name. That way, the Tcl autoloader will recognize it properly.
|
||||
#
|
||||
# Arguments:
|
||||
# name - Name that is being added to index.
|
||||
|
||||
proc auto_mkindex_parser::fullname {name} {
|
||||
variable contextStack
|
||||
|
||||
if {![string match ::* $name]} {
|
||||
foreach ns $contextStack {
|
||||
set name "${ns}::$name"
|
||||
if {[string match ::* $name]} {
|
||||
break
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if {[namespace qualifiers $name] eq ""} {
|
||||
set name [namespace tail $name]
|
||||
} elseif {![string match ::* $name]} {
|
||||
set name "::$name"
|
||||
}
|
||||
|
||||
# Earlier, mkindex replaced all $'s with \0. Now, we have to reverse that
|
||||
# replacement.
|
||||
return [string map [list \0 \$] $name]
|
||||
}
|
||||
|
||||
# auto_mkindex_parser::indexEntry --
|
||||
#
|
||||
# Used by commands like "proc" within the auto_mkindex parser to add a
|
||||
# correctly-quoted entry to the index. This is shared code so it is done
|
||||
# *right*, in one place.
|
||||
#
|
||||
# Arguments:
|
||||
# name - Name that is being added to index.
|
||||
|
||||
proc auto_mkindex_parser::indexEntry {name} {
|
||||
variable index
|
||||
variable scriptFile
|
||||
|
||||
# We convert all metacharacters to their backslashed form, and pre-split
|
||||
# the file name that we know about (which will be a proper list, and so
|
||||
# correctly quoted).
|
||||
|
||||
set name [string range [list \}[fullname $name]] 2 end]
|
||||
set filenameParts [file split $scriptFile]
|
||||
|
||||
append index [format \
|
||||
{set auto_index(%s) [list source [file join $dir %s]]%s} \
|
||||
$name $filenameParts \n]
|
||||
return
|
||||
}
|
||||
|
||||
if {[llength $::auto_mkindex_parser::initCommands]} {
|
||||
return
|
||||
}
|
||||
|
||||
# Register all of the procedures for the auto_mkindex parser that will build
|
||||
# the "tclIndex" file.
|
||||
|
||||
# AUTO MKINDEX: proc name arglist body
|
||||
# Adds an entry to the auto index list for the given procedure name.
|
||||
|
||||
auto_mkindex_parser::command proc {name args} {
|
||||
indexEntry $name
|
||||
}
|
||||
|
||||
# Conditionally add support for Tcl byte code files. There are some tricky
|
||||
# details here. First, we need to get the tbcload library initialized in the
|
||||
# current interpreter. We cannot load tbcload into the child until we have
|
||||
# done so because it needs access to the tcl_patchLevel variable. Second,
|
||||
# because the package index file may defer loading the library until we invoke
|
||||
# a command, we need to explicitly invoke auto_load to force it to be loaded.
|
||||
# This should be a noop if the package has already been loaded
|
||||
|
||||
auto_mkindex_parser::hook {
|
||||
try {
|
||||
package require tbcload
|
||||
} on error {} {
|
||||
# OK, don't have it so do nothing
|
||||
} on ok {} {
|
||||
if {[namespace which -command tbcload::bcproc] eq ""} {
|
||||
auto_load tbcload::bcproc
|
||||
}
|
||||
load {} tbcload $auto_mkindex_parser::parser
|
||||
|
||||
# AUTO MKINDEX: tbcload::bcproc name arglist body
|
||||
# Adds an entry to the auto index list for the given pre-compiled
|
||||
# procedure name.
|
||||
|
||||
auto_mkindex_parser::commandInit tbcload::bcproc {name args} {
|
||||
indexEntry $name
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# AUTO MKINDEX: namespace eval name command ?arg arg...?
|
||||
# Adds the namespace name onto the context stack and evaluates the associated
|
||||
# body of commands.
|
||||
#
|
||||
# AUTO MKINDEX: namespace import ?-force? pattern ?pattern...?
|
||||
# Performs the "import" action in the parser interpreter. This is important
|
||||
# for any commands contained in a namespace that affect the index. For
|
||||
# example, a script may say "itcl::class ...", or it may import "itcl::*" and
|
||||
# then say "class ...". This procedure does the import operation, but keeps
|
||||
# track of imported patterns so we can remove the imports later.
|
||||
|
||||
auto_mkindex_parser::command namespace {op args} {
|
||||
switch -- $op {
|
||||
eval {
|
||||
variable parser
|
||||
variable contextStack
|
||||
|
||||
set name [lindex $args 0]
|
||||
set args [lrange $args 1 end]
|
||||
|
||||
set contextStack [linsert $contextStack 0 $name]
|
||||
$parser eval [list _%@namespace eval $name] $args
|
||||
set contextStack [lrange $contextStack 1 end]
|
||||
}
|
||||
import {
|
||||
variable parser
|
||||
variable imports
|
||||
foreach pattern $args {
|
||||
if {$pattern ne "-force"} {
|
||||
lappend imports $pattern
|
||||
}
|
||||
}
|
||||
catch {$parser eval "_%@namespace import $args"}
|
||||
}
|
||||
ensemble {
|
||||
variable parser
|
||||
variable contextStack
|
||||
if {[lindex $args 0] eq "create"} {
|
||||
set name ::[join [lreverse $contextStack] ::]
|
||||
catch {
|
||||
set name [dict get [lrange $args 1 end] -command]
|
||||
if {![string match ::* $name]} {
|
||||
set name ::[join [lreverse $contextStack] ::]$name
|
||||
}
|
||||
regsub -all ::+ $name :: name
|
||||
}
|
||||
# create artifical proc to force an entry in the tclIndex
|
||||
$parser eval [list ::proc $name {} {}]
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# AUTO MKINDEX: oo::class create name ?definition?
|
||||
# Adds an entry to the auto index list for the given class name.
|
||||
auto_mkindex_parser::command oo::class {op name {body ""}} {
|
||||
if {$op eq "create"} {
|
||||
indexEntry $name
|
||||
}
|
||||
}
|
||||
auto_mkindex_parser::command class {op name {body ""}} {
|
||||
if {$op eq "create"} {
|
||||
indexEntry $name
|
||||
}
|
||||
}
|
||||
|
||||
return
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,335 @@
|
|||
# history.tcl --
|
||||
#
|
||||
# Implementation of the history command.
|
||||
#
|
||||
# Copyright (c) 1997 Sun Microsystems, Inc.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution of
|
||||
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
|
||||
# The tcl::history array holds the history list and some additional
|
||||
# bookkeeping variables.
|
||||
#
|
||||
# nextid the index used for the next history list item.
|
||||
# keep the max size of the history list
|
||||
# oldest the index of the oldest item in the history.
|
||||
|
||||
namespace eval ::tcl {
|
||||
variable history
|
||||
if {![info exists history]} {
|
||||
array set history {
|
||||
nextid 0
|
||||
keep 20
|
||||
oldest -20
|
||||
}
|
||||
}
|
||||
|
||||
namespace ensemble create -command ::tcl::history -map {
|
||||
add ::tcl::HistAdd
|
||||
change ::tcl::HistChange
|
||||
clear ::tcl::HistClear
|
||||
event ::tcl::HistEvent
|
||||
info ::tcl::HistInfo
|
||||
keep ::tcl::HistKeep
|
||||
nextid ::tcl::HistNextID
|
||||
redo ::tcl::HistRedo
|
||||
}
|
||||
}
|
||||
|
||||
# history --
|
||||
#
|
||||
# This is the main history command. See the man page for its interface.
|
||||
# This does some argument checking and calls the helper ensemble in the
|
||||
# tcl namespace.
|
||||
|
||||
proc ::history {args} {
|
||||
# If no command given, we're doing 'history info'. Can't be done with an
|
||||
# ensemble unknown handler, as those don't fire when no subcommand is
|
||||
# given at all.
|
||||
|
||||
if {![llength $args]} {
|
||||
set args info
|
||||
}
|
||||
|
||||
# Tricky stuff needed to make stack and errors come out right!
|
||||
tailcall apply {arglist {tailcall history {*}$arglist} ::tcl} $args
|
||||
}
|
||||
|
||||
# (unnamed) --
|
||||
#
|
||||
# Callback when [::history] is destroyed. Destroys the implementation.
|
||||
#
|
||||
# Parameters:
|
||||
# oldName what the command was called.
|
||||
# newName what the command is now called (an empty string).
|
||||
# op the operation (= delete).
|
||||
#
|
||||
# Results:
|
||||
# none
|
||||
#
|
||||
# Side Effects:
|
||||
# The implementation of the [::history] command ceases to exist.
|
||||
|
||||
trace add command ::history delete [list apply {{oldName newName op} {
|
||||
variable history
|
||||
unset -nocomplain history
|
||||
foreach c [info procs ::tcl::Hist*] {
|
||||
rename $c {}
|
||||
}
|
||||
rename ::tcl::history {}
|
||||
} ::tcl}]
|
||||
|
||||
# tcl::HistAdd --
|
||||
#
|
||||
# Add an item to the history, and optionally eval it at the global scope
|
||||
#
|
||||
# Parameters:
|
||||
# event the command to add
|
||||
# exec (optional) a substring of "exec" causes the command to
|
||||
# be evaled.
|
||||
# Results:
|
||||
# If executing, then the results of the command are returned
|
||||
#
|
||||
# Side Effects:
|
||||
# Adds to the history list
|
||||
|
||||
proc ::tcl::HistAdd {event {exec {}}} {
|
||||
variable history
|
||||
|
||||
if {
|
||||
[prefix longest {exec {}} $exec] eq ""
|
||||
&& [llength [info level 0]] == 3
|
||||
} then {
|
||||
return -code error "bad argument \"$exec\": should be \"exec\""
|
||||
}
|
||||
|
||||
# Do not add empty commands to the history
|
||||
if {[string trim $event] eq ""} {
|
||||
return ""
|
||||
}
|
||||
|
||||
# Maintain the history
|
||||
set history([incr history(nextid)]) $event
|
||||
unset -nocomplain history([incr history(oldest)])
|
||||
|
||||
# Only execute if 'exec' (or non-empty prefix of it) given
|
||||
if {$exec eq ""} {
|
||||
return ""
|
||||
}
|
||||
tailcall eval $event
|
||||
}
|
||||
|
||||
# tcl::HistKeep --
|
||||
#
|
||||
# Set or query the limit on the length of the history list
|
||||
#
|
||||
# Parameters:
|
||||
# limit (optional) the length of the history list
|
||||
#
|
||||
# Results:
|
||||
# If no limit is specified, the current limit is returned
|
||||
#
|
||||
# Side Effects:
|
||||
# Updates history(keep) if a limit is specified
|
||||
|
||||
proc ::tcl::HistKeep {{count {}}} {
|
||||
variable history
|
||||
if {[llength [info level 0]] == 1} {
|
||||
return $history(keep)
|
||||
}
|
||||
if {![string is integer -strict $count] || ($count < 0)} {
|
||||
return -code error "illegal keep count \"$count\""
|
||||
}
|
||||
set oldold $history(oldest)
|
||||
set history(oldest) [expr {$history(nextid) - $count}]
|
||||
for {} {$oldold <= $history(oldest)} {incr oldold} {
|
||||
unset -nocomplain history($oldold)
|
||||
}
|
||||
set history(keep) $count
|
||||
}
|
||||
|
||||
# tcl::HistClear --
|
||||
#
|
||||
# Erase the history list
|
||||
#
|
||||
# Parameters:
|
||||
# none
|
||||
#
|
||||
# Results:
|
||||
# none
|
||||
#
|
||||
# Side Effects:
|
||||
# Resets the history array, except for the keep limit
|
||||
|
||||
proc ::tcl::HistClear {} {
|
||||
variable history
|
||||
set keep $history(keep)
|
||||
unset history
|
||||
array set history [list \
|
||||
nextid 0 \
|
||||
keep $keep \
|
||||
oldest -$keep \
|
||||
]
|
||||
}
|
||||
|
||||
# tcl::HistInfo --
|
||||
#
|
||||
# Return a pretty-printed version of the history list
|
||||
#
|
||||
# Parameters:
|
||||
# num (optional) the length of the history list to return
|
||||
#
|
||||
# Results:
|
||||
# A formatted history list
|
||||
|
||||
proc ::tcl::HistInfo {{count {}}} {
|
||||
variable history
|
||||
if {[llength [info level 0]] == 1} {
|
||||
set count [expr {$history(keep) + 1}]
|
||||
} elseif {![string is integer -strict $count]} {
|
||||
return -code error "bad integer \"$count\""
|
||||
}
|
||||
set result {}
|
||||
set newline ""
|
||||
for {set i [expr {$history(nextid) - $count + 1}]} \
|
||||
{$i <= $history(nextid)} {incr i} {
|
||||
if {![info exists history($i)]} {
|
||||
continue
|
||||
}
|
||||
set cmd [string map [list \n \n\t] [string trimright $history($i) \ \n]]
|
||||
append result $newline[format "%6d %s" $i $cmd]
|
||||
set newline \n
|
||||
}
|
||||
return $result
|
||||
}
|
||||
|
||||
# tcl::HistRedo --
|
||||
#
|
||||
# Fetch the previous or specified event, execute it, and then replace
|
||||
# the current history item with that event.
|
||||
#
|
||||
# Parameters:
|
||||
# event (optional) index of history item to redo. Defaults to -1,
|
||||
# which means the previous event.
|
||||
#
|
||||
# Results:
|
||||
# Those of the command being redone.
|
||||
#
|
||||
# Side Effects:
|
||||
# Replaces the current history list item with the one being redone.
|
||||
|
||||
proc ::tcl::HistRedo {{event -1}} {
|
||||
variable history
|
||||
|
||||
set i [HistIndex $event]
|
||||
if {$i == $history(nextid)} {
|
||||
return -code error "cannot redo the current event"
|
||||
}
|
||||
set cmd $history($i)
|
||||
HistChange $cmd 0
|
||||
tailcall eval $cmd
|
||||
}
|
||||
|
||||
# tcl::HistIndex --
|
||||
#
|
||||
# Map from an event specifier to an index in the history list.
|
||||
#
|
||||
# Parameters:
|
||||
# event index of history item to redo.
|
||||
# If this is a positive number, it is used directly.
|
||||
# If it is a negative number, then it counts back to a previous
|
||||
# event, where -1 is the most recent event.
|
||||
# A string can be matched, either by being the prefix of a
|
||||
# command or by matching a command with string match.
|
||||
#
|
||||
# Results:
|
||||
# The index into history, or an error if the index didn't match.
|
||||
|
||||
proc ::tcl::HistIndex {event} {
|
||||
variable history
|
||||
if {![string is integer -strict $event]} {
|
||||
for {set i [expr {$history(nextid)-1}]} {[info exists history($i)]} \
|
||||
{incr i -1} {
|
||||
if {[string match $event* $history($i)]} {
|
||||
return $i
|
||||
}
|
||||
if {[string match $event $history($i)]} {
|
||||
return $i
|
||||
}
|
||||
}
|
||||
return -code error "no event matches \"$event\""
|
||||
} elseif {$event <= 0} {
|
||||
set i [expr {$history(nextid) + $event}]
|
||||
} else {
|
||||
set i $event
|
||||
}
|
||||
if {$i <= $history(oldest)} {
|
||||
return -code error "event \"$event\" is too far in the past"
|
||||
}
|
||||
if {$i > $history(nextid)} {
|
||||
return -code error "event \"$event\" hasn't occured yet"
|
||||
}
|
||||
return $i
|
||||
}
|
||||
|
||||
# tcl::HistEvent --
|
||||
#
|
||||
# Map from an event specifier to the value in the history list.
|
||||
#
|
||||
# Parameters:
|
||||
# event index of history item to redo. See index for a description of
|
||||
# possible event patterns.
|
||||
#
|
||||
# Results:
|
||||
# The value from the history list.
|
||||
|
||||
proc ::tcl::HistEvent {{event -1}} {
|
||||
variable history
|
||||
set i [HistIndex $event]
|
||||
if {![info exists history($i)]} {
|
||||
return ""
|
||||
}
|
||||
return [string trimright $history($i) \ \n]
|
||||
}
|
||||
|
||||
# tcl::HistChange --
|
||||
#
|
||||
# Replace a value in the history list.
|
||||
#
|
||||
# Parameters:
|
||||
# newValue The new value to put into the history list.
|
||||
# event (optional) index of history item to redo. See index for a
|
||||
# description of possible event patterns. This defaults to 0,
|
||||
# which specifies the current event.
|
||||
#
|
||||
# Side Effects:
|
||||
# Changes the history list.
|
||||
|
||||
proc ::tcl::HistChange {newValue {event 0}} {
|
||||
variable history
|
||||
set i [HistIndex $event]
|
||||
set history($i) $newValue
|
||||
}
|
||||
|
||||
# tcl::HistNextID --
|
||||
#
|
||||
# Returns the number of the next history event.
|
||||
#
|
||||
# Parameters:
|
||||
# None.
|
||||
#
|
||||
# Side Effects:
|
||||
# None.
|
||||
|
||||
proc ::tcl::HistNextID {} {
|
||||
variable history
|
||||
return [expr {$history(nextid) + 1}]
|
||||
}
|
||||
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# fill-column: 78
|
||||
# End:
|
||||
|
|
@ -0,0 +1,827 @@
|
|||
# init.tcl --
|
||||
#
|
||||
# Default system startup file for Tcl-based applications. Defines
|
||||
# "unknown" procedure and auto-load facilities.
|
||||
#
|
||||
# Copyright (c) 1991-1993 The Regents of the University of California.
|
||||
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-1999 Scriptics Corporation.
|
||||
# Copyright (c) 2004 Kevin B. Kenny. All rights reserved.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
|
||||
# This test intentionally written in pre-7.5 Tcl
|
||||
if {[info commands package] == ""} {
|
||||
error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
|
||||
}
|
||||
package require -exact Tcl 8.6.11
|
||||
|
||||
# Compute the auto path to use in this interpreter.
|
||||
# The values on the path come from several locations:
|
||||
#
|
||||
# The environment variable TCLLIBPATH
|
||||
#
|
||||
# tcl_library, which is the directory containing this init.tcl script.
|
||||
# [tclInit] (Tcl_Init()) searches around for the directory containing this
|
||||
# init.tcl and defines tcl_library to that location before sourcing it.
|
||||
#
|
||||
# The parent directory of tcl_library. Adding the parent
|
||||
# means that packages in peer directories will be found automatically.
|
||||
#
|
||||
# Also add the directory ../lib relative to the directory where the
|
||||
# executable is located. This is meant to find binary packages for the
|
||||
# same architecture as the current executable.
|
||||
#
|
||||
# tcl_pkgPath, which is set by the platform-specific initialization routines
|
||||
# On UNIX it is compiled in
|
||||
# On Windows, it is not used
|
||||
#
|
||||
# (Ticket 41c9857bdd) In a safe interpreter, this file does not set
|
||||
# ::auto_path (other than to {} if it is undefined). The caller, typically
|
||||
# a Safe Base command, is responsible for setting ::auto_path.
|
||||
|
||||
if {![info exists auto_path]} {
|
||||
if {[info exists env(TCLLIBPATH)] && (![interp issafe])} {
|
||||
set auto_path $env(TCLLIBPATH)
|
||||
} else {
|
||||
set auto_path ""
|
||||
}
|
||||
}
|
||||
namespace eval tcl {
|
||||
if {![interp issafe]} {
|
||||
variable Dir
|
||||
foreach Dir [list $::tcl_library [file dirname $::tcl_library]] {
|
||||
if {$Dir ni $::auto_path} {
|
||||
lappend ::auto_path $Dir
|
||||
}
|
||||
}
|
||||
set Dir [file join [file dirname [file dirname \
|
||||
[info nameofexecutable]]] lib]
|
||||
if {$Dir ni $::auto_path} {
|
||||
lappend ::auto_path $Dir
|
||||
}
|
||||
if {[info exists ::tcl_pkgPath]} { catch {
|
||||
foreach Dir $::tcl_pkgPath {
|
||||
if {$Dir ni $::auto_path} {
|
||||
lappend ::auto_path $Dir
|
||||
}
|
||||
}
|
||||
}}
|
||||
|
||||
variable Path [encoding dirs]
|
||||
set Dir [file join $::tcl_library encoding]
|
||||
if {$Dir ni $Path} {
|
||||
lappend Path $Dir
|
||||
encoding dirs $Path
|
||||
}
|
||||
unset Dir Path
|
||||
}
|
||||
|
||||
# TIP #255 min and max functions
|
||||
namespace eval mathfunc {
|
||||
proc min {args} {
|
||||
if {![llength $args]} {
|
||||
return -code error \
|
||||
"not enough arguments to math function \"min\""
|
||||
}
|
||||
set val Inf
|
||||
foreach arg $args {
|
||||
# This will handle forcing the numeric value without
|
||||
# ruining the internal type of a numeric object
|
||||
if {[catch {expr {double($arg)}} err]} {
|
||||
return -code error $err
|
||||
}
|
||||
if {$arg < $val} {set val $arg}
|
||||
}
|
||||
return $val
|
||||
}
|
||||
proc max {args} {
|
||||
if {![llength $args]} {
|
||||
return -code error \
|
||||
"not enough arguments to math function \"max\""
|
||||
}
|
||||
set val -Inf
|
||||
foreach arg $args {
|
||||
# This will handle forcing the numeric value without
|
||||
# ruining the internal type of a numeric object
|
||||
if {[catch {expr {double($arg)}} err]} {
|
||||
return -code error $err
|
||||
}
|
||||
if {$arg > $val} {set val $arg}
|
||||
}
|
||||
return $val
|
||||
}
|
||||
namespace export min max
|
||||
}
|
||||
}
|
||||
|
||||
# Windows specific end of initialization
|
||||
|
||||
if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} {
|
||||
namespace eval tcl {
|
||||
proc EnvTraceProc {lo n1 n2 op} {
|
||||
global env
|
||||
set x $env($n2)
|
||||
set env($lo) $x
|
||||
set env([string toupper $lo]) $x
|
||||
}
|
||||
proc InitWinEnv {} {
|
||||
global env tcl_platform
|
||||
foreach p [array names env] {
|
||||
set u [string toupper $p]
|
||||
if {$u ne $p} {
|
||||
switch -- $u {
|
||||
COMSPEC -
|
||||
PATH {
|
||||
set temp $env($p)
|
||||
unset env($p)
|
||||
set env($u) $temp
|
||||
trace add variable env($p) write \
|
||||
[namespace code [list EnvTraceProc $p]]
|
||||
trace add variable env($u) write \
|
||||
[namespace code [list EnvTraceProc $p]]
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
if {![info exists env(COMSPEC)]} {
|
||||
set env(COMSPEC) cmd.exe
|
||||
}
|
||||
}
|
||||
InitWinEnv
|
||||
}
|
||||
}
|
||||
|
||||
# Setup the unknown package handler
|
||||
|
||||
|
||||
if {[interp issafe]} {
|
||||
package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown}
|
||||
} else {
|
||||
# Set up search for Tcl Modules (TIP #189).
|
||||
# and setup platform specific unknown package handlers
|
||||
if {$tcl_platform(os) eq "Darwin"
|
||||
&& $tcl_platform(platform) eq "unix"} {
|
||||
package unknown {::tcl::tm::UnknownHandler \
|
||||
{::tcl::MacOSXPkgUnknown ::tclPkgUnknown}}
|
||||
} else {
|
||||
package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown}
|
||||
}
|
||||
|
||||
# Set up the 'clock' ensemble
|
||||
|
||||
namespace eval ::tcl::clock [list variable TclLibDir $::tcl_library]
|
||||
|
||||
proc ::tcl::initClock {} {
|
||||
# Auto-loading stubs for 'clock.tcl'
|
||||
|
||||
foreach cmd {add format scan} {
|
||||
proc ::tcl::clock::$cmd args {
|
||||
variable TclLibDir
|
||||
source -encoding utf-8 [file join $TclLibDir clock.tcl]
|
||||
return [uplevel 1 [info level 0]]
|
||||
}
|
||||
}
|
||||
|
||||
rename ::tcl::initClock {}
|
||||
}
|
||||
::tcl::initClock
|
||||
}
|
||||
|
||||
# Conditionalize for presence of exec.
|
||||
|
||||
if {[namespace which -command exec] eq ""} {
|
||||
|
||||
# Some machines do not have exec. Also, on all
|
||||
# platforms, safe interpreters do not have exec.
|
||||
|
||||
set auto_noexec 1
|
||||
}
|
||||
|
||||
# Define a log command (which can be overwitten to log errors
|
||||
# differently, specially when stderr is not available)
|
||||
|
||||
if {[namespace which -command tclLog] eq ""} {
|
||||
proc tclLog {string} {
|
||||
catch {puts stderr $string}
|
||||
}
|
||||
}
|
||||
|
||||
# unknown --
|
||||
# This procedure is called when a Tcl command is invoked that doesn't
|
||||
# exist in the interpreter. It takes the following steps to make the
|
||||
# command available:
|
||||
#
|
||||
# 1. See if the autoload facility can locate the command in a
|
||||
# Tcl script file. If so, load it and execute it.
|
||||
# 2. If the command was invoked interactively at top-level:
|
||||
# (a) see if the command exists as an executable UNIX program.
|
||||
# If so, "exec" the command.
|
||||
# (b) see if the command requests csh-like history substitution
|
||||
# in one of the common forms !!, !<number>, or ^old^new. If
|
||||
# so, emulate csh's history substitution.
|
||||
# (c) see if the command is a unique abbreviation for another
|
||||
# command. If so, invoke the command.
|
||||
#
|
||||
# Arguments:
|
||||
# args - A list whose elements are the words of the original
|
||||
# command, including the command name.
|
||||
|
||||
proc unknown args {
|
||||
variable ::tcl::UnknownPending
|
||||
global auto_noexec auto_noload env tcl_interactive errorInfo errorCode
|
||||
|
||||
if {[info exists errorInfo]} {
|
||||
set savedErrorInfo $errorInfo
|
||||
}
|
||||
if {[info exists errorCode]} {
|
||||
set savedErrorCode $errorCode
|
||||
}
|
||||
|
||||
set name [lindex $args 0]
|
||||
if {![info exists auto_noload]} {
|
||||
#
|
||||
# Make sure we're not trying to load the same proc twice.
|
||||
#
|
||||
if {[info exists UnknownPending($name)]} {
|
||||
return -code error "self-referential recursion\
|
||||
in \"unknown\" for command \"$name\""
|
||||
}
|
||||
set UnknownPending($name) pending
|
||||
set ret [catch {
|
||||
auto_load $name [uplevel 1 {::namespace current}]
|
||||
} msg opts]
|
||||
unset UnknownPending($name)
|
||||
if {$ret != 0} {
|
||||
dict append opts -errorinfo "\n (autoloading \"$name\")"
|
||||
return -options $opts $msg
|
||||
}
|
||||
if {![array size UnknownPending]} {
|
||||
unset UnknownPending
|
||||
}
|
||||
if {$msg} {
|
||||
if {[info exists savedErrorCode]} {
|
||||
set ::errorCode $savedErrorCode
|
||||
} else {
|
||||
unset -nocomplain ::errorCode
|
||||
}
|
||||
if {[info exists savedErrorInfo]} {
|
||||
set errorInfo $savedErrorInfo
|
||||
} else {
|
||||
unset -nocomplain errorInfo
|
||||
}
|
||||
set code [catch {uplevel 1 $args} msg opts]
|
||||
if {$code == 1} {
|
||||
#
|
||||
# Compute stack trace contribution from the [uplevel].
|
||||
# Note the dependence on how Tcl_AddErrorInfo, etc.
|
||||
# construct the stack trace.
|
||||
#
|
||||
set errInfo [dict get $opts -errorinfo]
|
||||
set errCode [dict get $opts -errorcode]
|
||||
set cinfo $args
|
||||
if {[string bytelength $cinfo] > 150} {
|
||||
set cinfo [string range $cinfo 0 150]
|
||||
while {[string bytelength $cinfo] > 150} {
|
||||
set cinfo [string range $cinfo 0 end-1]
|
||||
}
|
||||
append cinfo ...
|
||||
}
|
||||
set tail "\n (\"uplevel\" body line 1)\n invoked\
|
||||
from within\n\"uplevel 1 \$args\""
|
||||
set expect "$msg\n while executing\n\"$cinfo\"$tail"
|
||||
if {$errInfo eq $expect} {
|
||||
#
|
||||
# The stack has only the eval from the expanded command
|
||||
# Do not generate any stack trace here.
|
||||
#
|
||||
dict unset opts -errorinfo
|
||||
dict incr opts -level
|
||||
return -options $opts $msg
|
||||
}
|
||||
#
|
||||
# Stack trace is nested, trim off just the contribution
|
||||
# from the extra "eval" of $args due to the "catch" above.
|
||||
#
|
||||
set last [string last $tail $errInfo]
|
||||
if {$last + [string length $tail] != [string length $errInfo]} {
|
||||
# Very likely cannot happen
|
||||
return -options $opts $msg
|
||||
}
|
||||
set errInfo [string range $errInfo 0 $last-1]
|
||||
set tail "\"$cinfo\""
|
||||
set last [string last $tail $errInfo]
|
||||
if {$last < 0 || $last + [string length $tail] != [string length $errInfo]} {
|
||||
return -code error -errorcode $errCode \
|
||||
-errorinfo $errInfo $msg
|
||||
}
|
||||
set errInfo [string range $errInfo 0 $last-1]
|
||||
set tail "\n invoked from within\n"
|
||||
set last [string last $tail $errInfo]
|
||||
if {$last + [string length $tail] == [string length $errInfo]} {
|
||||
return -code error -errorcode $errCode \
|
||||
-errorinfo [string range $errInfo 0 $last-1] $msg
|
||||
}
|
||||
set tail "\n while executing\n"
|
||||
set last [string last $tail $errInfo]
|
||||
if {$last + [string length $tail] == [string length $errInfo]} {
|
||||
return -code error -errorcode $errCode \
|
||||
-errorinfo [string range $errInfo 0 $last-1] $msg
|
||||
}
|
||||
return -options $opts $msg
|
||||
} else {
|
||||
dict incr opts -level
|
||||
return -options $opts $msg
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if {([info level] == 1) && ([info script] eq "")
|
||||
&& [info exists tcl_interactive] && $tcl_interactive} {
|
||||
if {![info exists auto_noexec]} {
|
||||
set new [auto_execok $name]
|
||||
if {$new ne ""} {
|
||||
set redir ""
|
||||
if {[namespace which -command console] eq ""} {
|
||||
set redir ">&@stdout <@stdin"
|
||||
}
|
||||
uplevel 1 [list ::catch \
|
||||
[concat exec $redir $new [lrange $args 1 end]] \
|
||||
::tcl::UnknownResult ::tcl::UnknownOptions]
|
||||
dict incr ::tcl::UnknownOptions -level
|
||||
return -options $::tcl::UnknownOptions $::tcl::UnknownResult
|
||||
}
|
||||
}
|
||||
if {$name eq "!!"} {
|
||||
set newcmd [history event]
|
||||
} elseif {[regexp {^!(.+)$} $name -> event]} {
|
||||
set newcmd [history event $event]
|
||||
} elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name -> old new]} {
|
||||
set newcmd [history event -1]
|
||||
catch {regsub -all -- $old $newcmd $new newcmd}
|
||||
}
|
||||
if {[info exists newcmd]} {
|
||||
tclLog $newcmd
|
||||
history change $newcmd 0
|
||||
uplevel 1 [list ::catch $newcmd \
|
||||
::tcl::UnknownResult ::tcl::UnknownOptions]
|
||||
dict incr ::tcl::UnknownOptions -level
|
||||
return -options $::tcl::UnknownOptions $::tcl::UnknownResult
|
||||
}
|
||||
|
||||
set ret [catch {set candidates [info commands $name*]} msg]
|
||||
if {$name eq "::"} {
|
||||
set name ""
|
||||
}
|
||||
if {$ret != 0} {
|
||||
dict append opts -errorinfo \
|
||||
"\n (expanding command prefix \"$name\" in unknown)"
|
||||
return -options $opts $msg
|
||||
}
|
||||
# Filter out bogus matches when $name contained
|
||||
# a glob-special char [Bug 946952]
|
||||
if {$name eq ""} {
|
||||
# Handle empty $name separately due to strangeness
|
||||
# in [string first] (See RFE 1243354)
|
||||
set cmds $candidates
|
||||
} else {
|
||||
set cmds [list]
|
||||
foreach x $candidates {
|
||||
if {[string first $name $x] == 0} {
|
||||
lappend cmds $x
|
||||
}
|
||||
}
|
||||
}
|
||||
if {[llength $cmds] == 1} {
|
||||
uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] \
|
||||
::tcl::UnknownResult ::tcl::UnknownOptions]
|
||||
dict incr ::tcl::UnknownOptions -level
|
||||
return -options $::tcl::UnknownOptions $::tcl::UnknownResult
|
||||
}
|
||||
if {[llength $cmds]} {
|
||||
return -code error "ambiguous command name \"$name\": [lsort $cmds]"
|
||||
}
|
||||
}
|
||||
return -code error -errorcode [list TCL LOOKUP COMMAND $name] \
|
||||
"invalid command name \"$name\""
|
||||
}
|
||||
|
||||
# auto_load --
|
||||
# Checks a collection of library directories to see if a procedure
|
||||
# is defined in one of them. If so, it sources the appropriate
|
||||
# library file to create the procedure. Returns 1 if it successfully
|
||||
# loaded the procedure, 0 otherwise.
|
||||
#
|
||||
# Arguments:
|
||||
# cmd - Name of the command to find and load.
|
||||
# namespace (optional) The namespace where the command is being used - must be
|
||||
# a canonical namespace as returned [namespace current]
|
||||
# for instance. If not given, namespace current is used.
|
||||
|
||||
proc auto_load {cmd {namespace {}}} {
|
||||
global auto_index auto_path
|
||||
|
||||
if {$namespace eq ""} {
|
||||
set namespace [uplevel 1 [list ::namespace current]]
|
||||
}
|
||||
set nameList [auto_qualify $cmd $namespace]
|
||||
# workaround non canonical auto_index entries that might be around
|
||||
# from older auto_mkindex versions
|
||||
lappend nameList $cmd
|
||||
foreach name $nameList {
|
||||
if {[info exists auto_index($name)]} {
|
||||
namespace eval :: $auto_index($name)
|
||||
# There's a couple of ways to look for a command of a given
|
||||
# name. One is to use
|
||||
# info commands $name
|
||||
# Unfortunately, if the name has glob-magic chars in it like *
|
||||
# or [], it may not match. For our purposes here, a better
|
||||
# route is to use
|
||||
# namespace which -command $name
|
||||
if {[namespace which -command $name] ne ""} {
|
||||
return 1
|
||||
}
|
||||
}
|
||||
}
|
||||
if {![info exists auto_path]} {
|
||||
return 0
|
||||
}
|
||||
|
||||
if {![auto_load_index]} {
|
||||
return 0
|
||||
}
|
||||
foreach name $nameList {
|
||||
if {[info exists auto_index($name)]} {
|
||||
namespace eval :: $auto_index($name)
|
||||
if {[namespace which -command $name] ne ""} {
|
||||
return 1
|
||||
}
|
||||
}
|
||||
}
|
||||
return 0
|
||||
}
|
||||
|
||||
# auto_load_index --
|
||||
# Loads the contents of tclIndex files on the auto_path directory
|
||||
# list. This is usually invoked within auto_load to load the index
|
||||
# of available commands. Returns 1 if the index is loaded, and 0 if
|
||||
# the index is already loaded and up to date.
|
||||
#
|
||||
# Arguments:
|
||||
# None.
|
||||
|
||||
proc auto_load_index {} {
|
||||
variable ::tcl::auto_oldpath
|
||||
global auto_index auto_path
|
||||
|
||||
if {[info exists auto_oldpath] && ($auto_oldpath eq $auto_path)} {
|
||||
return 0
|
||||
}
|
||||
set auto_oldpath $auto_path
|
||||
|
||||
# Check if we are a safe interpreter. In that case, we support only
|
||||
# newer format tclIndex files.
|
||||
|
||||
set issafe [interp issafe]
|
||||
for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} {
|
||||
set dir [lindex $auto_path $i]
|
||||
set f ""
|
||||
if {$issafe} {
|
||||
catch {source [file join $dir tclIndex]}
|
||||
} elseif {[catch {set f [open [file join $dir tclIndex]]}]} {
|
||||
continue
|
||||
} else {
|
||||
set error [catch {
|
||||
fconfigure $f -eofchar \032
|
||||
set id [gets $f]
|
||||
if {$id eq "# Tcl autoload index file, version 2.0"} {
|
||||
eval [read $f]
|
||||
} elseif {$id eq "# Tcl autoload index file: each line identifies a Tcl"} {
|
||||
while {[gets $f line] >= 0} {
|
||||
if {([string index $line 0] eq "#") \
|
||||
|| ([llength $line] != 2)} {
|
||||
continue
|
||||
}
|
||||
set name [lindex $line 0]
|
||||
set auto_index($name) \
|
||||
"source [file join $dir [lindex $line 1]]"
|
||||
}
|
||||
} else {
|
||||
error "[file join $dir tclIndex] isn't a proper Tcl index file"
|
||||
}
|
||||
} msg opts]
|
||||
if {$f ne ""} {
|
||||
close $f
|
||||
}
|
||||
if {$error} {
|
||||
return -options $opts $msg
|
||||
}
|
||||
}
|
||||
}
|
||||
return 1
|
||||
}
|
||||
|
||||
# auto_qualify --
|
||||
#
|
||||
# Compute a fully qualified names list for use in the auto_index array.
|
||||
# For historical reasons, commands in the global namespace do not have leading
|
||||
# :: in the index key. The list has two elements when the command name is
|
||||
# relative (no leading ::) and the namespace is not the global one. Otherwise
|
||||
# only one name is returned (and searched in the auto_index).
|
||||
#
|
||||
# Arguments -
|
||||
# cmd The command name. Can be any name accepted for command
|
||||
# invocations (Like "foo::::bar").
|
||||
# namespace The namespace where the command is being used - must be
|
||||
# a canonical namespace as returned by [namespace current]
|
||||
# for instance.
|
||||
|
||||
proc auto_qualify {cmd namespace} {
|
||||
|
||||
# count separators and clean them up
|
||||
# (making sure that foo:::::bar will be treated as foo::bar)
|
||||
set n [regsub -all {::+} $cmd :: cmd]
|
||||
|
||||
# Ignore namespace if the name starts with ::
|
||||
# Handle special case of only leading ::
|
||||
|
||||
# Before each return case we give an example of which category it is
|
||||
# with the following form :
|
||||
# (inputCmd, inputNameSpace) -> output
|
||||
|
||||
if {[string match ::* $cmd]} {
|
||||
if {$n > 1} {
|
||||
# (::foo::bar , *) -> ::foo::bar
|
||||
return [list $cmd]
|
||||
} else {
|
||||
# (::global , *) -> global
|
||||
return [list [string range $cmd 2 end]]
|
||||
}
|
||||
}
|
||||
|
||||
# Potentially returning 2 elements to try :
|
||||
# (if the current namespace is not the global one)
|
||||
|
||||
if {$n == 0} {
|
||||
if {$namespace eq "::"} {
|
||||
# (nocolons , ::) -> nocolons
|
||||
return [list $cmd]
|
||||
} else {
|
||||
# (nocolons , ::sub) -> ::sub::nocolons nocolons
|
||||
return [list ${namespace}::$cmd $cmd]
|
||||
}
|
||||
} elseif {$namespace eq "::"} {
|
||||
# (foo::bar , ::) -> ::foo::bar
|
||||
return [list ::$cmd]
|
||||
} else {
|
||||
# (foo::bar , ::sub) -> ::sub::foo::bar ::foo::bar
|
||||
return [list ${namespace}::$cmd ::$cmd]
|
||||
}
|
||||
}
|
||||
|
||||
# auto_import --
|
||||
#
|
||||
# Invoked during "namespace import" to make see if the imported commands
|
||||
# reside in an autoloaded library. If so, the commands are loaded so
|
||||
# that they will be available for the import links. If not, then this
|
||||
# procedure does nothing.
|
||||
#
|
||||
# Arguments -
|
||||
# pattern The pattern of commands being imported (like "foo::*")
|
||||
# a canonical namespace as returned by [namespace current]
|
||||
|
||||
proc auto_import {pattern} {
|
||||
global auto_index
|
||||
|
||||
# If no namespace is specified, this will be an error case
|
||||
|
||||
if {![string match *::* $pattern]} {
|
||||
return
|
||||
}
|
||||
|
||||
set ns [uplevel 1 [list ::namespace current]]
|
||||
set patternList [auto_qualify $pattern $ns]
|
||||
|
||||
auto_load_index
|
||||
|
||||
foreach pattern $patternList {
|
||||
foreach name [array names auto_index $pattern] {
|
||||
if {([namespace which -command $name] eq "")
|
||||
&& ([namespace qualifiers $pattern] eq [namespace qualifiers $name])} {
|
||||
namespace eval :: $auto_index($name)
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# auto_execok --
|
||||
#
|
||||
# Returns string that indicates name of program to execute if
|
||||
# name corresponds to a shell builtin or an executable in the
|
||||
# Windows search path, or "" otherwise. Builds an associative
|
||||
# array auto_execs that caches information about previous checks,
|
||||
# for speed.
|
||||
#
|
||||
# Arguments:
|
||||
# name - Name of a command.
|
||||
|
||||
if {$tcl_platform(platform) eq "windows"} {
|
||||
# Windows version.
|
||||
#
|
||||
# Note that file executable doesn't work under Windows, so we have to
|
||||
# look for files with .exe, .com, or .bat extensions. Also, the path
|
||||
# may be in the Path or PATH environment variables, and path
|
||||
# components are separated with semicolons, not colons as under Unix.
|
||||
#
|
||||
proc auto_execok name {
|
||||
global auto_execs env tcl_platform
|
||||
|
||||
if {[info exists auto_execs($name)]} {
|
||||
return $auto_execs($name)
|
||||
}
|
||||
set auto_execs($name) ""
|
||||
|
||||
set shellBuiltins [list assoc cls copy date del dir echo erase ftype \
|
||||
md mkdir mklink move rd ren rename rmdir start time type ver vol]
|
||||
if {[info exists env(PATHEXT)]} {
|
||||
# Add an initial ; to have the {} extension check first.
|
||||
set execExtensions [split ";$env(PATHEXT)" ";"]
|
||||
} else {
|
||||
set execExtensions [list {} .com .exe .bat .cmd]
|
||||
}
|
||||
|
||||
if {[string tolower $name] in $shellBuiltins} {
|
||||
# When this is command.com for some reason on Win2K, Tcl won't
|
||||
# exec it unless the case is right, which this corrects. COMSPEC
|
||||
# may not point to a real file, so do the check.
|
||||
set cmd $env(COMSPEC)
|
||||
if {[file exists $cmd]} {
|
||||
set cmd [file attributes $cmd -shortname]
|
||||
}
|
||||
return [set auto_execs($name) [list $cmd /c $name]]
|
||||
}
|
||||
|
||||
if {[llength [file split $name]] != 1} {
|
||||
foreach ext $execExtensions {
|
||||
set file ${name}${ext}
|
||||
if {[file exists $file] && ![file isdirectory $file]} {
|
||||
return [set auto_execs($name) [list $file]]
|
||||
}
|
||||
}
|
||||
return ""
|
||||
}
|
||||
|
||||
set path "[file dirname [info nameof]];.;"
|
||||
if {[info exists env(SystemRoot)]} {
|
||||
set windir $env(SystemRoot)
|
||||
} elseif {[info exists env(WINDIR)]} {
|
||||
set windir $env(WINDIR)
|
||||
}
|
||||
if {[info exists windir]} {
|
||||
if {$tcl_platform(os) eq "Windows NT"} {
|
||||
append path "$windir/system32;"
|
||||
}
|
||||
append path "$windir/system;$windir;"
|
||||
}
|
||||
|
||||
foreach var {PATH Path path} {
|
||||
if {[info exists env($var)]} {
|
||||
append path ";$env($var)"
|
||||
}
|
||||
}
|
||||
|
||||
foreach ext $execExtensions {
|
||||
unset -nocomplain checked
|
||||
foreach dir [split $path {;}] {
|
||||
# Skip already checked directories
|
||||
if {[info exists checked($dir)] || ($dir eq "")} {
|
||||
continue
|
||||
}
|
||||
set checked($dir) {}
|
||||
set file [file join $dir ${name}${ext}]
|
||||
if {[file exists $file] && ![file isdirectory $file]} {
|
||||
return [set auto_execs($name) [list $file]]
|
||||
}
|
||||
}
|
||||
}
|
||||
return ""
|
||||
}
|
||||
|
||||
} else {
|
||||
# Unix version.
|
||||
#
|
||||
proc auto_execok name {
|
||||
global auto_execs env
|
||||
|
||||
if {[info exists auto_execs($name)]} {
|
||||
return $auto_execs($name)
|
||||
}
|
||||
set auto_execs($name) ""
|
||||
if {[llength [file split $name]] != 1} {
|
||||
if {[file executable $name] && ![file isdirectory $name]} {
|
||||
set auto_execs($name) [list $name]
|
||||
}
|
||||
return $auto_execs($name)
|
||||
}
|
||||
foreach dir [split $env(PATH) :] {
|
||||
if {$dir eq ""} {
|
||||
set dir .
|
||||
}
|
||||
set file [file join $dir $name]
|
||||
if {[file executable $file] && ![file isdirectory $file]} {
|
||||
set auto_execs($name) [list $file]
|
||||
return $auto_execs($name)
|
||||
}
|
||||
}
|
||||
return ""
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
# ::tcl::CopyDirectory --
|
||||
#
|
||||
# This procedure is called by Tcl's core when attempts to call the
|
||||
# filesystem's copydirectory function fail. The semantics of the call
|
||||
# are that 'dest' does not yet exist, i.e. dest should become the exact
|
||||
# image of src. If dest does exist, we throw an error.
|
||||
#
|
||||
# Note that making changes to this procedure can change the results
|
||||
# of running Tcl's tests.
|
||||
#
|
||||
# Arguments:
|
||||
# action - "renaming" or "copying"
|
||||
# src - source directory
|
||||
# dest - destination directory
|
||||
proc tcl::CopyDirectory {action src dest} {
|
||||
set nsrc [file normalize $src]
|
||||
set ndest [file normalize $dest]
|
||||
|
||||
if {$action eq "renaming"} {
|
||||
# Can't rename volumes. We could give a more precise
|
||||
# error message here, but that would break the test suite.
|
||||
if {$nsrc in [file volumes]} {
|
||||
return -code error "error $action \"$src\" to\
|
||||
\"$dest\": trying to rename a volume or move a directory\
|
||||
into itself"
|
||||
}
|
||||
}
|
||||
if {[file exists $dest]} {
|
||||
if {$nsrc eq $ndest} {
|
||||
return -code error "error $action \"$src\" to\
|
||||
\"$dest\": trying to rename a volume or move a directory\
|
||||
into itself"
|
||||
}
|
||||
if {$action eq "copying"} {
|
||||
# We used to throw an error here, but, looking more closely
|
||||
# at the core copy code in tclFCmd.c, if the destination
|
||||
# exists, then we should only call this function if -force
|
||||
# is true, which means we just want to over-write. So,
|
||||
# the following code is now commented out.
|
||||
#
|
||||
# return -code error "error $action \"$src\" to\
|
||||
# \"$dest\": file already exists"
|
||||
} else {
|
||||
# Depending on the platform, and on the current
|
||||
# working directory, the directories '.', '..'
|
||||
# can be returned in various combinations. Anyway,
|
||||
# if any other file is returned, we must signal an error.
|
||||
set existing [glob -nocomplain -directory $dest * .*]
|
||||
lappend existing {*}[glob -nocomplain -directory $dest \
|
||||
-type hidden * .*]
|
||||
foreach s $existing {
|
||||
if {[file tail $s] ni {. ..}} {
|
||||
return -code error "error $action \"$src\" to\
|
||||
\"$dest\": file already exists"
|
||||
}
|
||||
}
|
||||
}
|
||||
} else {
|
||||
if {[string first $nsrc $ndest] >= 0} {
|
||||
set srclen [expr {[llength [file split $nsrc]] - 1}]
|
||||
set ndest [lindex [file split $ndest] $srclen]
|
||||
if {$ndest eq [file tail $nsrc]} {
|
||||
return -code error "error $action \"$src\" to\
|
||||
\"$dest\": trying to rename a volume or move a directory\
|
||||
into itself"
|
||||
}
|
||||
}
|
||||
file mkdir $dest
|
||||
}
|
||||
# Have to be careful to capture both visible and hidden files.
|
||||
# We will also be more generous to the file system and not
|
||||
# assume the hidden and non-hidden lists are non-overlapping.
|
||||
#
|
||||
# On Unix 'hidden' files begin with '.'. On other platforms
|
||||
# or filesystems hidden files may have other interpretations.
|
||||
set filelist [concat [glob -nocomplain -directory $src *] \
|
||||
[glob -nocomplain -directory $src -types hidden *]]
|
||||
|
||||
foreach s [lsort -unique $filelist] {
|
||||
if {[file tail $s] ni {. ..}} {
|
||||
file copy -force -- $s [file join $dest [file tail $s]]
|
||||
}
|
||||
}
|
||||
return
|
||||
}
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
This software is copyrighted by the Regents of the University of
|
||||
California, Sun Microsystems, Inc., Scriptics Corporation, ActiveState
|
||||
Corporation and other parties. The following terms apply to all files
|
||||
associated with the software unless explicitly disclaimed in
|
||||
individual files.
|
||||
|
||||
The authors hereby grant permission to use, copy, modify, distribute,
|
||||
and license this software and its documentation for any purpose, provided
|
||||
that existing copyright notices are retained in all copies and that this
|
||||
notice is included verbatim in any distributions. No written agreement,
|
||||
license, or royalty fee is required for any of the authorized uses.
|
||||
Modifications to this software may be copyrighted by their authors
|
||||
and need not follow the licensing terms described here, provided that
|
||||
the new terms are clearly indicated on the first page of each file where
|
||||
they apply.
|
||||
|
||||
IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
|
||||
FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
|
||||
ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
|
||||
DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
|
||||
POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
|
||||
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
|
||||
IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
|
||||
NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
|
||||
MODIFICATIONS.
|
||||
|
||||
GOVERNMENT USE: If you are acquiring this software on behalf of the
|
||||
U.S. government, the Government shall have only "Restricted Rights"
|
||||
in the software and related documentation as defined in the Federal
|
||||
Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
|
||||
are acquiring the software on behalf of the Department of Defense, the
|
||||
software shall be classified as "Commercial Computer Software" and the
|
||||
Government shall have only "Restricted Rights" as defined in Clause
|
||||
252.227-7014 (b) (3) of DFARs. Notwithstanding the foregoing, the
|
||||
authors grant the U.S. Government and others acting in its behalf
|
||||
permission to use and distribute the software in accordance with the
|
||||
terms specified in this license.
|
||||
|
|
@ -0,0 +1,751 @@
|
|||
# package.tcl --
|
||||
#
|
||||
# utility procs formerly in init.tcl which can be loaded on demand
|
||||
# for package management.
|
||||
#
|
||||
# Copyright (c) 1991-1993 The Regents of the University of California.
|
||||
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
|
||||
namespace eval tcl::Pkg {}
|
||||
|
||||
# ::tcl::Pkg::CompareExtension --
|
||||
#
|
||||
# Used internally by pkg_mkIndex to compare the extension of a file to a given
|
||||
# extension. On Windows, it uses a case-insensitive comparison because the
|
||||
# file system can be file insensitive.
|
||||
#
|
||||
# Arguments:
|
||||
# fileName name of a file whose extension is compared
|
||||
# ext (optional) The extension to compare against; you must
|
||||
# provide the starting dot.
|
||||
# Defaults to [info sharedlibextension]
|
||||
#
|
||||
# Results:
|
||||
# Returns 1 if the extension matches, 0 otherwise
|
||||
|
||||
proc tcl::Pkg::CompareExtension {fileName {ext {}}} {
|
||||
global tcl_platform
|
||||
if {$ext eq ""} {set ext [info sharedlibextension]}
|
||||
if {$tcl_platform(platform) eq "windows"} {
|
||||
return [string equal -nocase [file extension $fileName] $ext]
|
||||
} else {
|
||||
# Some unices add trailing numbers after the .so, so
|
||||
# we could have something like '.so.1.2'.
|
||||
set root $fileName
|
||||
while {1} {
|
||||
set currExt [file extension $root]
|
||||
if {$currExt eq $ext} {
|
||||
return 1
|
||||
}
|
||||
|
||||
# The current extension does not match; if it is not a numeric
|
||||
# value, quit, as we are only looking to ignore version number
|
||||
# extensions. Otherwise we might return 1 in this case:
|
||||
# tcl::Pkg::CompareExtension foo.so.bar .so
|
||||
# which should not match.
|
||||
|
||||
if {![string is integer -strict [string range $currExt 1 end]]} {
|
||||
return 0
|
||||
}
|
||||
set root [file rootname $root]
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# pkg_mkIndex --
|
||||
# This procedure creates a package index in a given directory. The package
|
||||
# index consists of a "pkgIndex.tcl" file whose contents are a Tcl script that
|
||||
# sets up package information with "package require" commands. The commands
|
||||
# describe all of the packages defined by the files given as arguments.
|
||||
#
|
||||
# Arguments:
|
||||
# -direct (optional) If this flag is present, the generated
|
||||
# code in pkgMkIndex.tcl will cause the package to be
|
||||
# loaded when "package require" is executed, rather
|
||||
# than lazily when the first reference to an exported
|
||||
# procedure in the package is made.
|
||||
# -verbose (optional) Verbose output; the name of each file that
|
||||
# was successfully rocessed is printed out. Additionally,
|
||||
# if processing of a file failed a message is printed.
|
||||
# -load pat (optional) Preload any packages whose names match
|
||||
# the pattern. Used to handle DLLs that depend on
|
||||
# other packages during their Init procedure.
|
||||
# dir - Name of the directory in which to create the index.
|
||||
# args - Any number of additional arguments, each giving
|
||||
# a glob pattern that matches the names of one or
|
||||
# more shared libraries or Tcl script files in
|
||||
# dir.
|
||||
|
||||
proc pkg_mkIndex {args} {
|
||||
set usage {"pkg_mkIndex ?-direct? ?-lazy? ?-load pattern? ?-verbose? ?--? dir ?pattern ...?"}
|
||||
|
||||
set argCount [llength $args]
|
||||
if {$argCount < 1} {
|
||||
return -code error "wrong # args: should be\n$usage"
|
||||
}
|
||||
|
||||
set more ""
|
||||
set direct 1
|
||||
set doVerbose 0
|
||||
set loadPat ""
|
||||
for {set idx 0} {$idx < $argCount} {incr idx} {
|
||||
set flag [lindex $args $idx]
|
||||
switch -glob -- $flag {
|
||||
-- {
|
||||
# done with the flags
|
||||
incr idx
|
||||
break
|
||||
}
|
||||
-verbose {
|
||||
set doVerbose 1
|
||||
}
|
||||
-lazy {
|
||||
set direct 0
|
||||
append more " -lazy"
|
||||
}
|
||||
-direct {
|
||||
append more " -direct"
|
||||
}
|
||||
-load {
|
||||
incr idx
|
||||
set loadPat [lindex $args $idx]
|
||||
append more " -load $loadPat"
|
||||
}
|
||||
-* {
|
||||
return -code error "unknown flag $flag: should be\n$usage"
|
||||
}
|
||||
default {
|
||||
# done with the flags
|
||||
break
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
set dir [lindex $args $idx]
|
||||
set patternList [lrange $args [expr {$idx + 1}] end]
|
||||
if {![llength $patternList]} {
|
||||
set patternList [list "*.tcl" "*[info sharedlibextension]"]
|
||||
}
|
||||
|
||||
try {
|
||||
set fileList [glob -directory $dir -tails -types {r f} -- \
|
||||
{*}$patternList]
|
||||
} on error {msg opt} {
|
||||
return -options $opt $msg
|
||||
}
|
||||
foreach file $fileList {
|
||||
# For each file, figure out what commands and packages it provides.
|
||||
# To do this, create a child interpreter, load the file into the
|
||||
# interpreter, and get a list of the new commands and packages that
|
||||
# are defined.
|
||||
|
||||
if {$file eq "pkgIndex.tcl"} {
|
||||
continue
|
||||
}
|
||||
|
||||
set c [interp create]
|
||||
|
||||
# Load into the child any packages currently loaded in the parent
|
||||
# interpreter that match the -load pattern.
|
||||
|
||||
if {$loadPat ne ""} {
|
||||
if {$doVerbose} {
|
||||
tclLog "currently loaded packages: '[info loaded]'"
|
||||
tclLog "trying to load all packages matching $loadPat"
|
||||
}
|
||||
if {![llength [info loaded]]} {
|
||||
tclLog "warning: no packages are currently loaded, nothing"
|
||||
tclLog "can possibly match '$loadPat'"
|
||||
}
|
||||
}
|
||||
foreach pkg [info loaded] {
|
||||
if {![string match -nocase $loadPat [lindex $pkg 1]]} {
|
||||
continue
|
||||
}
|
||||
if {$doVerbose} {
|
||||
tclLog "package [lindex $pkg 1] matches '$loadPat'"
|
||||
}
|
||||
try {
|
||||
load [lindex $pkg 0] [lindex $pkg 1] $c
|
||||
} on error err {
|
||||
if {$doVerbose} {
|
||||
tclLog "warning: load [lindex $pkg 0]\
|
||||
[lindex $pkg 1]\nfailed with: $err"
|
||||
}
|
||||
} on ok {} {
|
||||
if {$doVerbose} {
|
||||
tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]"
|
||||
}
|
||||
}
|
||||
if {[lindex $pkg 1] eq "Tk"} {
|
||||
# Withdraw . if Tk was loaded, to avoid showing a window.
|
||||
$c eval [list wm withdraw .]
|
||||
}
|
||||
}
|
||||
|
||||
$c eval {
|
||||
# Stub out the package command so packages can require other
|
||||
# packages.
|
||||
|
||||
rename package __package_orig
|
||||
proc package {what args} {
|
||||
switch -- $what {
|
||||
require {
|
||||
return; # Ignore transitive requires
|
||||
}
|
||||
default {
|
||||
__package_orig $what {*}$args
|
||||
}
|
||||
}
|
||||
}
|
||||
proc tclPkgUnknown args {}
|
||||
package unknown tclPkgUnknown
|
||||
|
||||
# Stub out the unknown command so package can call into each other
|
||||
# during their initialilzation.
|
||||
|
||||
proc unknown {args} {}
|
||||
|
||||
# Stub out the auto_import mechanism
|
||||
|
||||
proc auto_import {args} {}
|
||||
|
||||
# reserve the ::tcl namespace for support procs and temporary
|
||||
# variables. This might make it awkward to generate a
|
||||
# pkgIndex.tcl file for the ::tcl namespace.
|
||||
|
||||
namespace eval ::tcl {
|
||||
variable dir ;# Current directory being processed
|
||||
variable file ;# Current file being processed
|
||||
variable direct ;# -direct flag value
|
||||
variable x ;# Loop variable
|
||||
variable debug ;# For debugging
|
||||
variable type ;# "load" or "source", for -direct
|
||||
variable namespaces ;# Existing namespaces (e.g., ::tcl)
|
||||
variable packages ;# Existing packages (e.g., Tcl)
|
||||
variable origCmds ;# Existing commands
|
||||
variable newCmds ;# Newly created commands
|
||||
variable newPkgs {} ;# Newly created packages
|
||||
}
|
||||
}
|
||||
|
||||
$c eval [list set ::tcl::dir $dir]
|
||||
$c eval [list set ::tcl::file $file]
|
||||
$c eval [list set ::tcl::direct $direct]
|
||||
|
||||
# Download needed procedures into the child because we've just deleted
|
||||
# the unknown procedure. This doesn't handle procedures with default
|
||||
# arguments.
|
||||
|
||||
foreach p {::tcl::Pkg::CompareExtension} {
|
||||
$c eval [list namespace eval [namespace qualifiers $p] {}]
|
||||
$c eval [list proc $p [info args $p] [info body $p]]
|
||||
}
|
||||
|
||||
try {
|
||||
$c eval {
|
||||
set ::tcl::debug "loading or sourcing"
|
||||
|
||||
# we need to track command defined by each package even in the
|
||||
# -direct case, because they are needed internally by the
|
||||
# "partial pkgIndex.tcl" step above.
|
||||
|
||||
proc ::tcl::GetAllNamespaces {{root ::}} {
|
||||
set list $root
|
||||
foreach ns [namespace children $root] {
|
||||
lappend list {*}[::tcl::GetAllNamespaces $ns]
|
||||
}
|
||||
return $list
|
||||
}
|
||||
|
||||
# init the list of existing namespaces, packages, commands
|
||||
|
||||
foreach ::tcl::x [::tcl::GetAllNamespaces] {
|
||||
set ::tcl::namespaces($::tcl::x) 1
|
||||
}
|
||||
foreach ::tcl::x [package names] {
|
||||
if {[package provide $::tcl::x] ne ""} {
|
||||
set ::tcl::packages($::tcl::x) 1
|
||||
}
|
||||
}
|
||||
set ::tcl::origCmds [info commands]
|
||||
|
||||
# Try to load the file if it has the shared library extension,
|
||||
# otherwise source it. It's important not to try to load
|
||||
# files that aren't shared libraries, because on some systems
|
||||
# (like SunOS) the loader will abort the whole application
|
||||
# when it gets an error.
|
||||
|
||||
if {[::tcl::Pkg::CompareExtension $::tcl::file [info sharedlibextension]]} {
|
||||
# The "file join ." command below is necessary. Without
|
||||
# it, if the file name has no \'s and we're on UNIX, the
|
||||
# load command will invoke the LD_LIBRARY_PATH search
|
||||
# mechanism, which could cause the wrong file to be used.
|
||||
|
||||
set ::tcl::debug loading
|
||||
load [file join $::tcl::dir $::tcl::file]
|
||||
set ::tcl::type load
|
||||
} else {
|
||||
set ::tcl::debug sourcing
|
||||
source [file join $::tcl::dir $::tcl::file]
|
||||
set ::tcl::type source
|
||||
}
|
||||
|
||||
# As a performance optimization, if we are creating direct
|
||||
# load packages, don't bother figuring out the set of commands
|
||||
# created by the new packages. We only need that list for
|
||||
# setting up the autoloading used in the non-direct case.
|
||||
if {!$::tcl::direct} {
|
||||
# See what new namespaces appeared, and import commands
|
||||
# from them. Only exported commands go into the index.
|
||||
|
||||
foreach ::tcl::x [::tcl::GetAllNamespaces] {
|
||||
if {![info exists ::tcl::namespaces($::tcl::x)]} {
|
||||
namespace import -force ${::tcl::x}::*
|
||||
}
|
||||
|
||||
# Figure out what commands appeared
|
||||
|
||||
foreach ::tcl::x [info commands] {
|
||||
set ::tcl::newCmds($::tcl::x) 1
|
||||
}
|
||||
foreach ::tcl::x $::tcl::origCmds {
|
||||
unset -nocomplain ::tcl::newCmds($::tcl::x)
|
||||
}
|
||||
foreach ::tcl::x [array names ::tcl::newCmds] {
|
||||
# determine which namespace a command comes from
|
||||
|
||||
set ::tcl::abs [namespace origin $::tcl::x]
|
||||
|
||||
# special case so that global names have no
|
||||
# leading ::, this is required by the unknown
|
||||
# command
|
||||
|
||||
set ::tcl::abs \
|
||||
[lindex [auto_qualify $::tcl::abs ::] 0]
|
||||
|
||||
if {$::tcl::x ne $::tcl::abs} {
|
||||
# Name changed during qualification
|
||||
|
||||
set ::tcl::newCmds($::tcl::abs) 1
|
||||
unset ::tcl::newCmds($::tcl::x)
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Look through the packages that appeared, and if there is a
|
||||
# version provided, then record it
|
||||
|
||||
foreach ::tcl::x [package names] {
|
||||
if {[package provide $::tcl::x] ne ""
|
||||
&& ![info exists ::tcl::packages($::tcl::x)]} {
|
||||
lappend ::tcl::newPkgs \
|
||||
[list $::tcl::x [package provide $::tcl::x]]
|
||||
}
|
||||
}
|
||||
}
|
||||
} on error msg {
|
||||
set what [$c eval set ::tcl::debug]
|
||||
if {$doVerbose} {
|
||||
tclLog "warning: error while $what $file: $msg"
|
||||
}
|
||||
} on ok {} {
|
||||
set what [$c eval set ::tcl::debug]
|
||||
if {$doVerbose} {
|
||||
tclLog "successful $what of $file"
|
||||
}
|
||||
set type [$c eval set ::tcl::type]
|
||||
set cmds [lsort [$c eval array names ::tcl::newCmds]]
|
||||
set pkgs [$c eval set ::tcl::newPkgs]
|
||||
if {$doVerbose} {
|
||||
if {!$direct} {
|
||||
tclLog "commands provided were $cmds"
|
||||
}
|
||||
tclLog "packages provided were $pkgs"
|
||||
}
|
||||
if {[llength $pkgs] > 1} {
|
||||
tclLog "warning: \"$file\" provides more than one package ($pkgs)"
|
||||
}
|
||||
foreach pkg $pkgs {
|
||||
# cmds is empty/not used in the direct case
|
||||
lappend files($pkg) [list $file $type $cmds]
|
||||
}
|
||||
|
||||
if {$doVerbose} {
|
||||
tclLog "processed $file"
|
||||
}
|
||||
}
|
||||
interp delete $c
|
||||
}
|
||||
|
||||
append index "# Tcl package index file, version 1.1\n"
|
||||
append index "# This file is generated by the \"pkg_mkIndex$more\" command\n"
|
||||
append index "# and sourced either when an application starts up or\n"
|
||||
append index "# by a \"package unknown\" script. It invokes the\n"
|
||||
append index "# \"package ifneeded\" command to set up package-related\n"
|
||||
append index "# information so that packages will be loaded automatically\n"
|
||||
append index "# in response to \"package require\" commands. When this\n"
|
||||
append index "# script is sourced, the variable \$dir must contain the\n"
|
||||
append index "# full path name of this file's directory.\n"
|
||||
|
||||
foreach pkg [lsort [array names files]] {
|
||||
set cmd {}
|
||||
lassign $pkg name version
|
||||
lappend cmd ::tcl::Pkg::Create -name $name -version $version
|
||||
foreach spec [lsort -index 0 $files($pkg)] {
|
||||
foreach {file type procs} $spec {
|
||||
if {$direct} {
|
||||
set procs {}
|
||||
}
|
||||
lappend cmd "-$type" [list $file $procs]
|
||||
}
|
||||
}
|
||||
append index "\n[eval $cmd]"
|
||||
}
|
||||
|
||||
set f [open [file join $dir pkgIndex.tcl] w]
|
||||
puts $f $index
|
||||
close $f
|
||||
}
|
||||
|
||||
# tclPkgSetup --
|
||||
# This is a utility procedure use by pkgIndex.tcl files. It is invoked as
|
||||
# part of a "package ifneeded" script. It calls "package provide" to indicate
|
||||
# that a package is available, then sets entries in the auto_index array so
|
||||
# that the package's files will be auto-loaded when the commands are used.
|
||||
#
|
||||
# Arguments:
|
||||
# dir - Directory containing all the files for this package.
|
||||
# pkg - Name of the package (no version number).
|
||||
# version - Version number for the package, such as 2.1.3.
|
||||
# files - List of files that constitute the package. Each
|
||||
# element is a sub-list with three elements. The first
|
||||
# is the name of a file relative to $dir, the second is
|
||||
# "load" or "source", indicating whether the file is a
|
||||
# loadable binary or a script to source, and the third
|
||||
# is a list of commands defined by this file.
|
||||
|
||||
proc tclPkgSetup {dir pkg version files} {
|
||||
global auto_index
|
||||
|
||||
package provide $pkg $version
|
||||
foreach fileInfo $files {
|
||||
set f [lindex $fileInfo 0]
|
||||
set type [lindex $fileInfo 1]
|
||||
foreach cmd [lindex $fileInfo 2] {
|
||||
if {$type eq "load"} {
|
||||
set auto_index($cmd) [list load [file join $dir $f] $pkg]
|
||||
} else {
|
||||
set auto_index($cmd) [list source [file join $dir $f]]
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# tclPkgUnknown --
|
||||
# This procedure provides the default for the "package unknown" function. It
|
||||
# is invoked when a package that's needed can't be found. It scans the
|
||||
# auto_path directories and their immediate children looking for pkgIndex.tcl
|
||||
# files and sources any such files that are found to setup the package
|
||||
# database. As it searches, it will recognize changes to the auto_path and
|
||||
# scan any new directories.
|
||||
#
|
||||
# Arguments:
|
||||
# name - Name of desired package. Not used.
|
||||
# version - Version of desired package. Not used.
|
||||
# exact - Either "-exact" or omitted. Not used.
|
||||
|
||||
proc tclPkgUnknown {name args} {
|
||||
global auto_path env
|
||||
|
||||
if {![info exists auto_path]} {
|
||||
return
|
||||
}
|
||||
# Cache the auto_path, because it may change while we run through the
|
||||
# first set of pkgIndex.tcl files
|
||||
set old_path [set use_path $auto_path]
|
||||
while {[llength $use_path]} {
|
||||
set dir [lindex $use_path end]
|
||||
|
||||
# Make sure we only scan each directory one time.
|
||||
if {[info exists tclSeenPath($dir)]} {
|
||||
set use_path [lrange $use_path 0 end-1]
|
||||
continue
|
||||
}
|
||||
set tclSeenPath($dir) 1
|
||||
|
||||
# Get the pkgIndex.tcl files in subdirectories of auto_path directories.
|
||||
# - Safe Base interpreters have a restricted "glob" command that
|
||||
# works in this case.
|
||||
# - The "catch" was essential when there was no safe glob and every
|
||||
# call in a safe interp failed; it is retained only for corner
|
||||
# cases in which the eventual call to glob returns an error.
|
||||
catch {
|
||||
foreach file [glob -directory $dir -join -nocomplain \
|
||||
* pkgIndex.tcl] {
|
||||
set dir [file dirname $file]
|
||||
if {![info exists procdDirs($dir)]} {
|
||||
try {
|
||||
source $file
|
||||
} trap {POSIX EACCES} {} {
|
||||
# $file was not readable; silently ignore
|
||||
continue
|
||||
} on error msg {
|
||||
tclLog "error reading package index file $file: $msg"
|
||||
} on ok {} {
|
||||
set procdDirs($dir) 1
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
set dir [lindex $use_path end]
|
||||
if {![info exists procdDirs($dir)]} {
|
||||
set file [file join $dir pkgIndex.tcl]
|
||||
# safe interps usually don't have "file exists",
|
||||
if {([interp issafe] || [file exists $file])} {
|
||||
try {
|
||||
source $file
|
||||
} trap {POSIX EACCES} {} {
|
||||
# $file was not readable; silently ignore
|
||||
continue
|
||||
} on error msg {
|
||||
tclLog "error reading package index file $file: $msg"
|
||||
} on ok {} {
|
||||
set procdDirs($dir) 1
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
set use_path [lrange $use_path 0 end-1]
|
||||
|
||||
# Check whether any of the index scripts we [source]d above set a new
|
||||
# value for $::auto_path. If so, then find any new directories on the
|
||||
# $::auto_path, and lappend them to the $use_path we are working from.
|
||||
# This gives index scripts the (arguably unwise) power to expand the
|
||||
# index script search path while the search is in progress.
|
||||
set index 0
|
||||
if {[llength $old_path] == [llength $auto_path]} {
|
||||
foreach dir $auto_path old $old_path {
|
||||
if {$dir ne $old} {
|
||||
# This entry in $::auto_path has changed.
|
||||
break
|
||||
}
|
||||
incr index
|
||||
}
|
||||
}
|
||||
|
||||
# $index now points to the first element of $auto_path that has
|
||||
# changed, or the beginning if $auto_path has changed length Scan the
|
||||
# new elements of $auto_path for directories to add to $use_path.
|
||||
# Don't add directories we've already seen, or ones already on the
|
||||
# $use_path.
|
||||
foreach dir [lrange $auto_path $index end] {
|
||||
if {![info exists tclSeenPath($dir)] && ($dir ni $use_path)} {
|
||||
lappend use_path $dir
|
||||
}
|
||||
}
|
||||
set old_path $auto_path
|
||||
}
|
||||
}
|
||||
|
||||
# tcl::MacOSXPkgUnknown --
|
||||
# This procedure extends the "package unknown" function for MacOSX. It scans
|
||||
# the Resources/Scripts directories of the immediate children of the auto_path
|
||||
# directories for pkgIndex files.
|
||||
#
|
||||
# Arguments:
|
||||
# original - original [package unknown] procedure
|
||||
# name - Name of desired package. Not used.
|
||||
# version - Version of desired package. Not used.
|
||||
# exact - Either "-exact" or omitted. Not used.
|
||||
|
||||
proc tcl::MacOSXPkgUnknown {original name args} {
|
||||
# First do the cross-platform default search
|
||||
uplevel 1 $original [linsert $args 0 $name]
|
||||
|
||||
# Now do MacOSX specific searching
|
||||
global auto_path
|
||||
|
||||
if {![info exists auto_path]} {
|
||||
return
|
||||
}
|
||||
# Cache the auto_path, because it may change while we run through the
|
||||
# first set of pkgIndex.tcl files
|
||||
set old_path [set use_path $auto_path]
|
||||
while {[llength $use_path]} {
|
||||
set dir [lindex $use_path end]
|
||||
|
||||
# Make sure we only scan each directory one time.
|
||||
if {[info exists tclSeenPath($dir)]} {
|
||||
set use_path [lrange $use_path 0 end-1]
|
||||
continue
|
||||
}
|
||||
set tclSeenPath($dir) 1
|
||||
|
||||
# get the pkgIndex files out of the subdirectories
|
||||
# Safe interpreters do not use tcl::MacOSXPkgUnknown - see init.tcl.
|
||||
foreach file [glob -directory $dir -join -nocomplain \
|
||||
* Resources Scripts pkgIndex.tcl] {
|
||||
set dir [file dirname $file]
|
||||
if {![info exists procdDirs($dir)]} {
|
||||
try {
|
||||
source $file
|
||||
} trap {POSIX EACCES} {} {
|
||||
# $file was not readable; silently ignore
|
||||
continue
|
||||
} on error msg {
|
||||
tclLog "error reading package index file $file: $msg"
|
||||
} on ok {} {
|
||||
set procdDirs($dir) 1
|
||||
}
|
||||
}
|
||||
}
|
||||
set use_path [lrange $use_path 0 end-1]
|
||||
|
||||
# Check whether any of the index scripts we [source]d above set a new
|
||||
# value for $::auto_path. If so, then find any new directories on the
|
||||
# $::auto_path, and lappend them to the $use_path we are working from.
|
||||
# This gives index scripts the (arguably unwise) power to expand the
|
||||
# index script search path while the search is in progress.
|
||||
set index 0
|
||||
if {[llength $old_path] == [llength $auto_path]} {
|
||||
foreach dir $auto_path old $old_path {
|
||||
if {$dir ne $old} {
|
||||
# This entry in $::auto_path has changed.
|
||||
break
|
||||
}
|
||||
incr index
|
||||
}
|
||||
}
|
||||
|
||||
# $index now points to the first element of $auto_path that has
|
||||
# changed, or the beginning if $auto_path has changed length Scan the
|
||||
# new elements of $auto_path for directories to add to $use_path.
|
||||
# Don't add directories we've already seen, or ones already on the
|
||||
# $use_path.
|
||||
foreach dir [lrange $auto_path $index end] {
|
||||
if {![info exists tclSeenPath($dir)] && ($dir ni $use_path)} {
|
||||
lappend use_path $dir
|
||||
}
|
||||
}
|
||||
set old_path $auto_path
|
||||
}
|
||||
}
|
||||
|
||||
# ::tcl::Pkg::Create --
|
||||
#
|
||||
# Given a package specification generate a "package ifneeded" statement
|
||||
# for the package, suitable for inclusion in a pkgIndex.tcl file.
|
||||
#
|
||||
# Arguments:
|
||||
# args arguments used by the Create function:
|
||||
# -name packageName
|
||||
# -version packageVersion
|
||||
# -load {filename ?{procs}?}
|
||||
# ...
|
||||
# -source {filename ?{procs}?}
|
||||
# ...
|
||||
#
|
||||
# Any number of -load and -source parameters may be
|
||||
# specified, so long as there is at least one -load or
|
||||
# -source parameter. If the procs component of a module
|
||||
# specifier is left off, that module will be set up for
|
||||
# direct loading; otherwise, it will be set up for lazy
|
||||
# loading. If both -source and -load are specified, the
|
||||
# -load'ed files will be loaded first, followed by the
|
||||
# -source'd files.
|
||||
#
|
||||
# Results:
|
||||
# An appropriate "package ifneeded" statement for the package.
|
||||
|
||||
proc ::tcl::Pkg::Create {args} {
|
||||
append err(usage) "[lindex [info level 0] 0] "
|
||||
append err(usage) "-name packageName -version packageVersion"
|
||||
append err(usage) "?-load {filename ?{procs}?}? ... "
|
||||
append err(usage) "?-source {filename ?{procs}?}? ..."
|
||||
|
||||
set err(wrongNumArgs) "wrong # args: should be \"$err(usage)\""
|
||||
set err(valueMissing) "value for \"%s\" missing: should be \"$err(usage)\""
|
||||
set err(unknownOpt) "unknown option \"%s\": should be \"$err(usage)\""
|
||||
set err(noLoadOrSource) "at least one of -load and -source must be given"
|
||||
|
||||
# process arguments
|
||||
set len [llength $args]
|
||||
if {$len < 6} {
|
||||
error $err(wrongNumArgs)
|
||||
}
|
||||
|
||||
# Initialize parameters
|
||||
array set opts {-name {} -version {} -source {} -load {}}
|
||||
|
||||
# process parameters
|
||||
for {set i 0} {$i < $len} {incr i} {
|
||||
set flag [lindex $args $i]
|
||||
incr i
|
||||
switch -glob -- $flag {
|
||||
"-name" -
|
||||
"-version" {
|
||||
if {$i >= $len} {
|
||||
error [format $err(valueMissing) $flag]
|
||||
}
|
||||
set opts($flag) [lindex $args $i]
|
||||
}
|
||||
"-source" -
|
||||
"-load" {
|
||||
if {$i >= $len} {
|
||||
error [format $err(valueMissing) $flag]
|
||||
}
|
||||
lappend opts($flag) [lindex $args $i]
|
||||
}
|
||||
default {
|
||||
error [format $err(unknownOpt) [lindex $args $i]]
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Validate the parameters
|
||||
if {![llength $opts(-name)]} {
|
||||
error [format $err(valueMissing) "-name"]
|
||||
}
|
||||
if {![llength $opts(-version)]} {
|
||||
error [format $err(valueMissing) "-version"]
|
||||
}
|
||||
|
||||
if {!([llength $opts(-source)] || [llength $opts(-load)])} {
|
||||
error $err(noLoadOrSource)
|
||||
}
|
||||
|
||||
# OK, now everything is good. Generate the package ifneeded statment.
|
||||
set cmdline "package ifneeded $opts(-name) $opts(-version) "
|
||||
|
||||
set cmdList {}
|
||||
set lazyFileList {}
|
||||
|
||||
# Handle -load and -source specs
|
||||
foreach key {load source} {
|
||||
foreach filespec $opts(-$key) {
|
||||
lassign $filespec filename proclist
|
||||
|
||||
if { [llength $proclist] == 0 } {
|
||||
set cmd "\[list $key \[file join \$dir [list $filename]\]\]"
|
||||
lappend cmdList $cmd
|
||||
} else {
|
||||
lappend lazyFileList [list $filename $key $proclist]
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if {[llength $lazyFileList]} {
|
||||
lappend cmdList "\[list tclPkgSetup \$dir $opts(-name)\
|
||||
$opts(-version) [list $lazyFileList]\]"
|
||||
}
|
||||
append cmdline [join $cmdList "\\n"]
|
||||
return $cmdline
|
||||
}
|
||||
|
||||
interp alias {} ::pkg::create {} ::tcl::Pkg::Create
|
||||
|
|
@ -0,0 +1,28 @@
|
|||
# parray:
|
||||
# Print the contents of a global array on stdout.
|
||||
#
|
||||
# Copyright (c) 1991-1993 The Regents of the University of California.
|
||||
# Copyright (c) 1994 Sun Microsystems, Inc.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
|
||||
proc parray {a {pattern *}} {
|
||||
upvar 1 $a array
|
||||
if {![array exists array]} {
|
||||
return -code error "\"$a\" isn't an array"
|
||||
}
|
||||
set maxl 0
|
||||
set names [lsort [array names array $pattern]]
|
||||
foreach name $names {
|
||||
if {[string length $name] > $maxl} {
|
||||
set maxl [string length $name]
|
||||
}
|
||||
}
|
||||
set maxl [expr {$maxl + [string length $a] + 2}]
|
||||
foreach name $names {
|
||||
set nameString [format %s(%s) $a $name]
|
||||
puts stdout [format "%-*s = %s" $maxl $nameString $array($name)]
|
||||
}
|
||||
}
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,78 @@
|
|||
# Tcl autoload index file, version 2.0
|
||||
# -*- tcl -*-
|
||||
# This file is generated by the "auto_mkindex" command
|
||||
# and sourced to set up indexing information for one or
|
||||
# more commands. Typically each line is a command that
|
||||
# sets an element in the auto_index array, where the
|
||||
# element name is the name of a command and the value is
|
||||
# a script that loads the command.
|
||||
|
||||
set auto_index(auto_reset) [list source [file join $dir auto.tcl]]
|
||||
set auto_index(tcl_findLibrary) [list source [file join $dir auto.tcl]]
|
||||
set auto_index(auto_mkindex) [list source [file join $dir auto.tcl]]
|
||||
set auto_index(auto_mkindex_old) [list source [file join $dir auto.tcl]]
|
||||
set auto_index(::auto_mkindex_parser::init) [list source [file join $dir auto.tcl]]
|
||||
set auto_index(::auto_mkindex_parser::cleanup) [list source [file join $dir auto.tcl]]
|
||||
set auto_index(::auto_mkindex_parser::mkindex) [list source [file join $dir auto.tcl]]
|
||||
set auto_index(::auto_mkindex_parser::hook) [list source [file join $dir auto.tcl]]
|
||||
set auto_index(::auto_mkindex_parser::slavehook) [list source [file join $dir auto.tcl]]
|
||||
set auto_index(::auto_mkindex_parser::command) [list source [file join $dir auto.tcl]]
|
||||
set auto_index(::auto_mkindex_parser::commandInit) [list source [file join $dir auto.tcl]]
|
||||
set auto_index(::auto_mkindex_parser::fullname) [list source [file join $dir auto.tcl]]
|
||||
set auto_index(history) [list source [file join $dir history.tcl]]
|
||||
set auto_index(::tcl::HistAdd) [list source [file join $dir history.tcl]]
|
||||
set auto_index(::tcl::HistKeep) [list source [file join $dir history.tcl]]
|
||||
set auto_index(::tcl::HistClear) [list source [file join $dir history.tcl]]
|
||||
set auto_index(::tcl::HistInfo) [list source [file join $dir history.tcl]]
|
||||
set auto_index(::tcl::HistRedo) [list source [file join $dir history.tcl]]
|
||||
set auto_index(::tcl::HistIndex) [list source [file join $dir history.tcl]]
|
||||
set auto_index(::tcl::HistEvent) [list source [file join $dir history.tcl]]
|
||||
set auto_index(::tcl::HistChange) [list source [file join $dir history.tcl]]
|
||||
set auto_index(pkg_mkIndex) [list source [file join $dir package.tcl]]
|
||||
set auto_index(tclPkgSetup) [list source [file join $dir package.tcl]]
|
||||
set auto_index(tclPkgUnknown) [list source [file join $dir package.tcl]]
|
||||
set auto_index(::tcl::MacOSXPkgUnknown) [list source [file join $dir package.tcl]]
|
||||
set auto_index(::pkg::create) [list source [file join $dir package.tcl]]
|
||||
set auto_index(parray) [list source [file join $dir parray.tcl]]
|
||||
set auto_index(::safe::InterpStatics) [list source [file join $dir safe.tcl]]
|
||||
set auto_index(::safe::InterpNested) [list source [file join $dir safe.tcl]]
|
||||
set auto_index(::safe::interpCreate) [list source [file join $dir safe.tcl]]
|
||||
set auto_index(::safe::interpInit) [list source [file join $dir safe.tcl]]
|
||||
set auto_index(::safe::CheckInterp) [list source [file join $dir safe.tcl]]
|
||||
set auto_index(::safe::interpConfigure) [list source [file join $dir safe.tcl]]
|
||||
set auto_index(::safe::InterpCreate) [list source [file join $dir safe.tcl]]
|
||||
set auto_index(::safe::InterpSetConfig) [list source [file join $dir safe.tcl]]
|
||||
set auto_index(::safe::interpFindInAccessPath) [list source [file join $dir safe.tcl]]
|
||||
set auto_index(::safe::interpAddToAccessPath) [list source [file join $dir safe.tcl]]
|
||||
set auto_index(::safe::InterpInit) [list source [file join $dir safe.tcl]]
|
||||
set auto_index(::safe::AddSubDirs) [list source [file join $dir safe.tcl]]
|
||||
set auto_index(::safe::interpDelete) [list source [file join $dir safe.tcl]]
|
||||
set auto_index(::safe::setLogCmd) [list source [file join $dir safe.tcl]]
|
||||
set auto_index(::safe::SyncAccessPath) [list source [file join $dir safe.tcl]]
|
||||
set auto_index(::safe::PathToken) [list source [file join $dir safe.tcl]]
|
||||
set auto_index(::safe::TranslatePath) [list source [file join $dir safe.tcl]]
|
||||
set auto_index(::safe::Log) [list source [file join $dir safe.tcl]]
|
||||
set auto_index(::safe::CheckFileName) [list source [file join $dir safe.tcl]]
|
||||
set auto_index(::safe::AliasGlob) [list source [file join $dir safe.tcl]]
|
||||
set auto_index(::safe::AliasSource) [list source [file join $dir safe.tcl]]
|
||||
set auto_index(::safe::AliasLoad) [list source [file join $dir safe.tcl]]
|
||||
set auto_index(::safe::FileInAccessPath) [list source [file join $dir safe.tcl]]
|
||||
set auto_index(::safe::DirInAccessPath) [list source [file join $dir safe.tcl]]
|
||||
set auto_index(::safe::Subset) [list source [file join $dir safe.tcl]]
|
||||
set auto_index(::safe::AliasSubset) [list source [file join $dir safe.tcl]]
|
||||
set auto_index(::safe::AliasEncoding) [list source [file join $dir safe.tcl]]
|
||||
set auto_index(tcl_wordBreakAfter) [list source [file join $dir word.tcl]]
|
||||
set auto_index(tcl_wordBreakBefore) [list source [file join $dir word.tcl]]
|
||||
set auto_index(tcl_endOfWord) [list source [file join $dir word.tcl]]
|
||||
set auto_index(tcl_startOfNextWord) [list source [file join $dir word.tcl]]
|
||||
set auto_index(tcl_startOfPreviousWord) [list source [file join $dir word.tcl]]
|
||||
set auto_index(::tcl::tm::add) [list source [file join $dir tm.tcl]]
|
||||
set auto_index(::tcl::tm::remove) [list source [file join $dir tm.tcl]]
|
||||
set auto_index(::tcl::tm::list) [list source [file join $dir tm.tcl]]
|
||||
set auto_index(::tcl::tm::Defaults) [list source [file join $dir tm.tcl]]
|
||||
set auto_index(::tcl::tm::UnknownHandler) [list source [file join $dir tm.tcl]]
|
||||
set auto_index(::tcl::tm::roots) [list source [file join $dir tm.tcl]]
|
||||
set auto_index(::tcl::tm::path) [list source [file join $dir tm.tcl]]
|
||||
if {[namespace exists ::tcl::unsupported]} {
|
||||
set auto_index(timerate) {namespace import ::tcl::unsupported::timerate}
|
||||
}
|
||||
|
|
@ -0,0 +1,380 @@
|
|||
# -*- tcl -*-
|
||||
#
|
||||
# Searching for Tcl Modules. Defines a procedure, declares it as the primary
|
||||
# command for finding packages, however also uses the former 'package unknown'
|
||||
# command as a fallback.
|
||||
#
|
||||
# Locates all possible packages in a directory via a less restricted glob. The
|
||||
# targeted directory is derived from the name of the requested package, i.e.
|
||||
# the TM scan will look only at directories which can contain the requested
|
||||
# package. It will register all packages it found in the directory so that
|
||||
# future requests have a higher chance of being fulfilled by the ifneeded
|
||||
# database without having to come to us again.
|
||||
#
|
||||
# We do not remember where we have been and simply rescan targeted directories
|
||||
# when invoked again. The reasoning is this:
|
||||
#
|
||||
# - The only way we get back to the same directory is if someone is trying to
|
||||
# [package require] something that wasn't there on the first scan.
|
||||
#
|
||||
# Either
|
||||
# 1) It is there now: If we rescan, you get it; if not you don't.
|
||||
#
|
||||
# This covers the possibility that the application asked for a package
|
||||
# late, and the package was actually added to the installation after the
|
||||
# application was started. It shoukld still be able to find it.
|
||||
#
|
||||
# 2) It still is not there: Either way, you don't get it, but the rescan
|
||||
# takes time. This is however an error case and we dont't care that much
|
||||
# about it
|
||||
#
|
||||
# 3) It was there the first time; but for some reason a "package forget" has
|
||||
# been run, and "package" doesn't know about it anymore.
|
||||
#
|
||||
# This can be an indication that the application wishes to reload some
|
||||
# functionality. And should work as well.
|
||||
#
|
||||
# Note that this also strikes a balance between doing a glob targeting a
|
||||
# single package, and thus most likely requiring multiple globs of the same
|
||||
# directory when the application is asking for many packages, and trying to
|
||||
# glob for _everything_ in all subdirectories when looking for a package,
|
||||
# which comes with a heavy startup cost.
|
||||
#
|
||||
# We scan for regular packages only if no satisfying module was found.
|
||||
|
||||
namespace eval ::tcl::tm {
|
||||
# Default paths. None yet.
|
||||
|
||||
variable paths {}
|
||||
|
||||
# The regex pattern a file name has to match to make it a Tcl Module.
|
||||
|
||||
set pkgpattern {^([_[:alpha:]][:_[:alnum:]]*)-([[:digit:]].*)[.]tm$}
|
||||
|
||||
# Export the public API
|
||||
|
||||
namespace export path
|
||||
namespace ensemble create -command path -subcommands {add remove list}
|
||||
}
|
||||
|
||||
# ::tcl::tm::path implementations --
|
||||
#
|
||||
# Public API to the module path. See specification.
|
||||
#
|
||||
# Arguments
|
||||
# cmd - The subcommand to execute
|
||||
# args - The paths to add/remove. Must not appear querying the
|
||||
# path with 'list'.
|
||||
#
|
||||
# Results
|
||||
# No result for subcommands 'add' and 'remove'. A list of paths for
|
||||
# 'list'.
|
||||
#
|
||||
# Sideeffects
|
||||
# The subcommands 'add' and 'remove' manipulate the list of paths to
|
||||
# search for Tcl Modules. The subcommand 'list' has no sideeffects.
|
||||
|
||||
proc ::tcl::tm::add {args} {
|
||||
# PART OF THE ::tcl::tm::path ENSEMBLE
|
||||
#
|
||||
# The path is added at the head to the list of module paths.
|
||||
#
|
||||
# The command enforces the restriction that no path may be an ancestor
|
||||
# directory of any other path on the list. If the new path violates this
|
||||
# restriction an error wil be raised.
|
||||
#
|
||||
# If the path is already present as is no error will be raised and no
|
||||
# action will be taken.
|
||||
|
||||
variable paths
|
||||
|
||||
# We use a copy of the path as source during validation, and extend it as
|
||||
# well. Because we not only have to detect if the new paths are bogus with
|
||||
# respect to the existing paths, but also between themselves. Otherwise we
|
||||
# can still add bogus paths, by specifying them in a single call. This
|
||||
# makes the use of the new paths simpler as well, a trivial assignment of
|
||||
# the collected paths to the official state var.
|
||||
|
||||
set newpaths $paths
|
||||
foreach p $args {
|
||||
if {$p in $newpaths} {
|
||||
# Ignore a path already on the list.
|
||||
continue
|
||||
}
|
||||
|
||||
# Search for paths which are subdirectories of the new one. If there
|
||||
# are any then the new path violates the restriction about ancestors.
|
||||
|
||||
set pos [lsearch -glob $newpaths ${p}/*]
|
||||
# Cannot use "in", we need the position for the message.
|
||||
if {$pos >= 0} {
|
||||
return -code error \
|
||||
"$p is ancestor of existing module path [lindex $newpaths $pos]."
|
||||
}
|
||||
|
||||
# Now look for existing paths which are ancestors of the new one. This
|
||||
# reverse question forces us to loop over the existing paths, as each
|
||||
# element is the pattern, not the new path :(
|
||||
|
||||
foreach ep $newpaths {
|
||||
if {[string match ${ep}/* $p]} {
|
||||
return -code error \
|
||||
"$p is subdirectory of existing module path $ep."
|
||||
}
|
||||
}
|
||||
|
||||
set newpaths [linsert $newpaths 0 $p]
|
||||
}
|
||||
|
||||
# The validation of the input is complete and successful, and everything
|
||||
# in newpaths is either an old path, or added. We can now extend the
|
||||
# official list of paths, a simple assignment is sufficient.
|
||||
|
||||
set paths $newpaths
|
||||
return
|
||||
}
|
||||
|
||||
proc ::tcl::tm::remove {args} {
|
||||
# PART OF THE ::tcl::tm::path ENSEMBLE
|
||||
#
|
||||
# Removes the path from the list of module paths. The command is silently
|
||||
# ignored if the path is not on the list.
|
||||
|
||||
variable paths
|
||||
|
||||
foreach p $args {
|
||||
set pos [lsearch -exact $paths $p]
|
||||
if {$pos >= 0} {
|
||||
set paths [lreplace $paths $pos $pos]
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
proc ::tcl::tm::list {} {
|
||||
# PART OF THE ::tcl::tm::path ENSEMBLE
|
||||
|
||||
variable paths
|
||||
return $paths
|
||||
}
|
||||
|
||||
# ::tcl::tm::UnknownHandler --
|
||||
#
|
||||
# Unknown handler for Tcl Modules, i.e. packages in module form.
|
||||
#
|
||||
# Arguments
|
||||
# original - Original [package unknown] procedure.
|
||||
# name - Name of desired package.
|
||||
# version - Version of desired package. Can be the
|
||||
# empty string.
|
||||
# exact - Either -exact or ommitted.
|
||||
#
|
||||
# Name, version, and exact are used to determine satisfaction. The
|
||||
# original is called iff no satisfaction was achieved. The name is also
|
||||
# used to compute the directory to target in the search.
|
||||
#
|
||||
# Results
|
||||
# None.
|
||||
#
|
||||
# Sideeffects
|
||||
# May populate the package ifneeded database with additional provide
|
||||
# scripts.
|
||||
|
||||
proc ::tcl::tm::UnknownHandler {original name args} {
|
||||
# Import the list of paths to search for packages in module form.
|
||||
# Import the pattern used to check package names in detail.
|
||||
|
||||
variable paths
|
||||
variable pkgpattern
|
||||
|
||||
# Without paths to search we can do nothing. (Except falling back to the
|
||||
# regular search).
|
||||
|
||||
if {[llength $paths]} {
|
||||
set pkgpath [string map {:: /} $name]
|
||||
set pkgroot [file dirname $pkgpath]
|
||||
if {$pkgroot eq "."} {
|
||||
set pkgroot ""
|
||||
}
|
||||
|
||||
# We don't remember a copy of the paths while looping. Tcl Modules are
|
||||
# unable to change the list while we are searching for them. This also
|
||||
# simplifies the loop, as we cannot get additional directories while
|
||||
# iterating over the list. A simple foreach is sufficient.
|
||||
|
||||
set satisfied 0
|
||||
foreach path $paths {
|
||||
if {![interp issafe] && ![file exists $path]} {
|
||||
continue
|
||||
}
|
||||
set currentsearchpath [file join $path $pkgroot]
|
||||
if {![interp issafe] && ![file exists $currentsearchpath]} {
|
||||
continue
|
||||
}
|
||||
set strip [llength [file split $path]]
|
||||
|
||||
# Get the module files out of the subdirectories.
|
||||
# - Safe Base interpreters have a restricted "glob" command that
|
||||
# works in this case.
|
||||
# - The "catch" was essential when there was no safe glob and every
|
||||
# call in a safe interp failed; it is retained only for corner
|
||||
# cases in which the eventual call to glob returns an error.
|
||||
|
||||
catch {
|
||||
# We always look for _all_ possible modules in the current
|
||||
# path, to get the max result out of the glob.
|
||||
|
||||
foreach file [glob -nocomplain -directory $currentsearchpath *.tm] {
|
||||
set pkgfilename [join [lrange [file split $file] $strip end] ::]
|
||||
|
||||
if {![regexp -- $pkgpattern $pkgfilename --> pkgname pkgversion]} {
|
||||
# Ignore everything not matching our pattern for
|
||||
# package names.
|
||||
continue
|
||||
}
|
||||
try {
|
||||
package vcompare $pkgversion 0
|
||||
} on error {} {
|
||||
# Ignore everything where the version part is not
|
||||
# acceptable to "package vcompare".
|
||||
continue
|
||||
}
|
||||
|
||||
if {([package ifneeded $pkgname $pkgversion] ne {})
|
||||
&& (![interp issafe])
|
||||
} {
|
||||
# There's already a provide script registered for
|
||||
# this version of this package. Since all units of
|
||||
# code claiming to be the same version of the same
|
||||
# package ought to be identical, just stick with
|
||||
# the one we already have.
|
||||
# This does not apply to Safe Base interpreters because
|
||||
# the token-to-directory mapping may have changed.
|
||||
continue
|
||||
}
|
||||
|
||||
# We have found a candidate, generate a "provide script"
|
||||
# for it, and remember it. Note that we are using ::list
|
||||
# to do this; locally [list] means something else without
|
||||
# the namespace specifier.
|
||||
|
||||
# NOTE. When making changes to the format of the provide
|
||||
# command generated below CHECK that the 'LOCATE'
|
||||
# procedure in core file 'platform/shell.tcl' still
|
||||
# understands it, or, if not, update its implementation
|
||||
# appropriately.
|
||||
#
|
||||
# Right now LOCATE's implementation assumes that the path
|
||||
# of the package file is the last element in the list.
|
||||
|
||||
package ifneeded $pkgname $pkgversion \
|
||||
"[::list package provide $pkgname $pkgversion];[::list source -encoding utf-8 $file]"
|
||||
|
||||
# We abort in this unknown handler only if we got a
|
||||
# satisfying candidate for the requested package.
|
||||
# Otherwise we still have to fallback to the regular
|
||||
# package search to complete the processing.
|
||||
|
||||
if {($pkgname eq $name)
|
||||
&& [package vsatisfies $pkgversion {*}$args]} {
|
||||
set satisfied 1
|
||||
|
||||
# We do not abort the loop, and keep adding provide
|
||||
# scripts for every candidate in the directory, just
|
||||
# remember to not fall back to the regular search
|
||||
# anymore.
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if {$satisfied} {
|
||||
return
|
||||
}
|
||||
}
|
||||
|
||||
# Fallback to previous command, if existing. See comment above about
|
||||
# ::list...
|
||||
|
||||
if {[llength $original]} {
|
||||
uplevel 1 $original [::linsert $args 0 $name]
|
||||
}
|
||||
}
|
||||
|
||||
# ::tcl::tm::Defaults --
|
||||
#
|
||||
# Determines the default search paths.
|
||||
#
|
||||
# Arguments
|
||||
# None
|
||||
#
|
||||
# Results
|
||||
# None.
|
||||
#
|
||||
# Sideeffects
|
||||
# May add paths to the list of defaults.
|
||||
|
||||
proc ::tcl::tm::Defaults {} {
|
||||
global env tcl_platform
|
||||
|
||||
regexp {^(\d+)\.(\d+)} [package provide Tcl] - major minor
|
||||
set exe [file normalize [info nameofexecutable]]
|
||||
|
||||
# Note that we're using [::list], not [list] because [list] means
|
||||
# something other than [::list] in this namespace.
|
||||
roots [::list \
|
||||
[file dirname [info library]] \
|
||||
[file join [file dirname [file dirname $exe]] lib] \
|
||||
]
|
||||
|
||||
if {$tcl_platform(platform) eq "windows"} {
|
||||
set sep ";"
|
||||
} else {
|
||||
set sep ":"
|
||||
}
|
||||
for {set n $minor} {$n >= 0} {incr n -1} {
|
||||
foreach ev [::list \
|
||||
TCL${major}.${n}_TM_PATH \
|
||||
TCL${major}_${n}_TM_PATH \
|
||||
] {
|
||||
if {![info exists env($ev)]} continue
|
||||
foreach p [split $env($ev) $sep] {
|
||||
path add $p
|
||||
}
|
||||
}
|
||||
}
|
||||
return
|
||||
}
|
||||
|
||||
# ::tcl::tm::roots --
|
||||
#
|
||||
# Public API to the module path. See specification.
|
||||
#
|
||||
# Arguments
|
||||
# paths - List of 'root' paths to derive search paths from.
|
||||
#
|
||||
# Results
|
||||
# No result.
|
||||
#
|
||||
# Sideeffects
|
||||
# Calls 'path add' to paths to the list of module search paths.
|
||||
|
||||
proc ::tcl::tm::roots {paths} {
|
||||
regexp {^(\d+)\.(\d+)} [package provide Tcl] - major minor
|
||||
foreach pa $paths {
|
||||
set p [file join $pa tcl$major]
|
||||
for {set n $minor} {$n >= 0} {incr n -1} {
|
||||
set px [file join $p ${major}.${n}]
|
||||
if {![interp issafe]} {set px [file normalize $px]}
|
||||
path add $px
|
||||
}
|
||||
set px [file join $p site-tcl]
|
||||
if {![interp issafe]} {set px [file normalize $px]}
|
||||
path add $px
|
||||
}
|
||||
return
|
||||
}
|
||||
|
||||
# Initialization. Set up the default paths, then insert the new handler into
|
||||
# the chain.
|
||||
|
||||
if {![interp issafe]} {::tcl::tm::Defaults}
|
||||
|
|
@ -0,0 +1,154 @@
|
|||
# word.tcl --
|
||||
#
|
||||
# This file defines various procedures for computing word boundaries in
|
||||
# strings. This file is primarily needed so Tk text and entry widgets behave
|
||||
# properly for different platforms.
|
||||
#
|
||||
# Copyright (c) 1996 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998 Scritpics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
# The following variables are used to determine which characters are
|
||||
# interpreted as white space.
|
||||
|
||||
if {$::tcl_platform(platform) eq "windows"} {
|
||||
# Windows style - any but a unicode space char
|
||||
if {![info exists ::tcl_wordchars]} {
|
||||
set ::tcl_wordchars {\S}
|
||||
}
|
||||
if {![info exists ::tcl_nonwordchars]} {
|
||||
set ::tcl_nonwordchars {\s}
|
||||
}
|
||||
} else {
|
||||
# Motif style - any unicode word char (number, letter, or underscore)
|
||||
if {![info exists ::tcl_wordchars]} {
|
||||
set ::tcl_wordchars {\w}
|
||||
}
|
||||
if {![info exists ::tcl_nonwordchars]} {
|
||||
set ::tcl_nonwordchars {\W}
|
||||
}
|
||||
}
|
||||
|
||||
# Arrange for caches of the real matcher REs to be kept, which enables the REs
|
||||
# themselves to be cached for greater performance (and somewhat greater
|
||||
# clarity too).
|
||||
|
||||
namespace eval ::tcl {
|
||||
variable WordBreakRE
|
||||
array set WordBreakRE {}
|
||||
|
||||
proc UpdateWordBreakREs args {
|
||||
# Ignores the arguments
|
||||
global tcl_wordchars tcl_nonwordchars
|
||||
variable WordBreakRE
|
||||
|
||||
# To keep the RE strings short...
|
||||
set letter $tcl_wordchars
|
||||
set space $tcl_nonwordchars
|
||||
|
||||
set WordBreakRE(after) "$letter$space|$space$letter"
|
||||
set WordBreakRE(before) "^.*($letter$space|$space$letter)"
|
||||
set WordBreakRE(end) "$space*$letter+$space"
|
||||
set WordBreakRE(next) "$letter*$space+$letter"
|
||||
set WordBreakRE(previous) "$space*($letter+)$space*\$"
|
||||
}
|
||||
|
||||
# Initialize the cache
|
||||
UpdateWordBreakREs
|
||||
trace add variable ::tcl_wordchars write ::tcl::UpdateWordBreakREs
|
||||
trace add variable ::tcl_nonwordchars write ::tcl::UpdateWordBreakREs
|
||||
}
|
||||
|
||||
# tcl_wordBreakAfter --
|
||||
#
|
||||
# This procedure returns the index of the first word boundary after the
|
||||
# starting point in the given string, or -1 if there are no more boundaries in
|
||||
# the given string. The index returned refers to the first character of the
|
||||
# pair that comprises a boundary.
|
||||
#
|
||||
# Arguments:
|
||||
# str - String to search.
|
||||
# start - Index into string specifying starting point.
|
||||
|
||||
proc tcl_wordBreakAfter {str start} {
|
||||
variable ::tcl::WordBreakRE
|
||||
set result {-1 -1}
|
||||
regexp -indices -start $start -- $WordBreakRE(after) $str result
|
||||
return [lindex $result 1]
|
||||
}
|
||||
|
||||
# tcl_wordBreakBefore --
|
||||
#
|
||||
# This procedure returns the index of the first word boundary before the
|
||||
# starting point in the given string, or -1 if there are no more boundaries in
|
||||
# the given string. The index returned refers to the second character of the
|
||||
# pair that comprises a boundary.
|
||||
#
|
||||
# Arguments:
|
||||
# str - String to search.
|
||||
# start - Index into string specifying starting point.
|
||||
|
||||
proc tcl_wordBreakBefore {str start} {
|
||||
variable ::tcl::WordBreakRE
|
||||
set result {-1 -1}
|
||||
regexp -indices -- $WordBreakRE(before) [string range $str 0 $start] result
|
||||
return [lindex $result 1]
|
||||
}
|
||||
|
||||
# tcl_endOfWord --
|
||||
#
|
||||
# This procedure returns the index of the first end-of-word location after a
|
||||
# starting index in the given string. An end-of-word location is defined to be
|
||||
# the first whitespace character following the first non-whitespace character
|
||||
# after the starting point. Returns -1 if there are no more words after the
|
||||
# starting point.
|
||||
#
|
||||
# Arguments:
|
||||
# str - String to search.
|
||||
# start - Index into string specifying starting point.
|
||||
|
||||
proc tcl_endOfWord {str start} {
|
||||
variable ::tcl::WordBreakRE
|
||||
set result {-1 -1}
|
||||
regexp -indices -start $start -- $WordBreakRE(end) $str result
|
||||
return [lindex $result 1]
|
||||
}
|
||||
|
||||
# tcl_startOfNextWord --
|
||||
#
|
||||
# This procedure returns the index of the first start-of-word location after a
|
||||
# starting index in the given string. A start-of-word location is defined to
|
||||
# be a non-whitespace character following a whitespace character. Returns -1
|
||||
# if there are no more start-of-word locations after the starting point.
|
||||
#
|
||||
# Arguments:
|
||||
# str - String to search.
|
||||
# start - Index into string specifying starting point.
|
||||
|
||||
proc tcl_startOfNextWord {str start} {
|
||||
variable ::tcl::WordBreakRE
|
||||
set result {-1 -1}
|
||||
regexp -indices -start $start -- $WordBreakRE(next) $str result
|
||||
return [lindex $result 1]
|
||||
}
|
||||
|
||||
# tcl_startOfPreviousWord --
|
||||
#
|
||||
# This procedure returns the index of the first start-of-word location before
|
||||
# a starting index in the given string.
|
||||
#
|
||||
# Arguments:
|
||||
# str - String to search.
|
||||
# start - Index into string specifying starting point.
|
||||
|
||||
proc tcl_startOfPreviousWord {str start} {
|
||||
variable ::tcl::WordBreakRE
|
||||
set word {-1 -1}
|
||||
if {$start > 0} {
|
||||
regexp -indices -- $WordBreakRE(previous) [string range $str 0 $start-1] \
|
||||
result word
|
||||
}
|
||||
return [lindex $word 0]
|
||||
}
|
||||
|
|
@ -0,0 +1,272 @@
|
|||
# bgerror.tcl --
|
||||
#
|
||||
# Implementation of the bgerror procedure. It posts a dialog box with
|
||||
# the error message and gives the user a chance to see a more detailed
|
||||
# stack trace, and possible do something more interesting with that
|
||||
# trace (like save it to a log). This is adapted from work done by
|
||||
# Donal K. Fellows.
|
||||
#
|
||||
# Copyright (c) 1998-2000 by Ajuba Solutions.
|
||||
# Copyright (c) 2007 by ActiveState Software Inc.
|
||||
# Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
|
||||
# Copyright (c) 2009 Pat Thoyts <patthoyts@users.sourceforge.net>
|
||||
|
||||
namespace eval ::tk::dialog::error {
|
||||
namespace import -force ::tk::msgcat::*
|
||||
namespace export bgerror
|
||||
option add *ErrorDialog.function.text [mc "Save To Log"] \
|
||||
widgetDefault
|
||||
option add *ErrorDialog.function.command [namespace code SaveToLog]
|
||||
option add *ErrorDialog*Label.font TkCaptionFont widgetDefault
|
||||
if {[tk windowingsystem] eq "aqua"} {
|
||||
option add *ErrorDialog*background systemAlertBackgroundActive \
|
||||
widgetDefault
|
||||
option add *ErrorDialog*info.text.background \
|
||||
systemTextBackgroundColor widgetDefault
|
||||
option add *ErrorDialog*Button.highlightBackground \
|
||||
systemAlertBackgroundActive widgetDefault
|
||||
}
|
||||
}
|
||||
|
||||
proc ::tk::dialog::error::Return {which code} {
|
||||
variable button
|
||||
|
||||
.bgerrorDialog.$which state {active selected focus}
|
||||
update idletasks
|
||||
after 100
|
||||
set button $code
|
||||
}
|
||||
|
||||
proc ::tk::dialog::error::Details {} {
|
||||
set w .bgerrorDialog
|
||||
set caption [option get $w.function text {}]
|
||||
set command [option get $w.function command {}]
|
||||
if {($caption eq "") || ($command eq "")} {
|
||||
grid forget $w.function
|
||||
}
|
||||
lappend command [$w.top.info.text get 1.0 end-1c]
|
||||
$w.function configure -text $caption -command $command
|
||||
grid $w.top.info - -sticky nsew -padx 3m -pady 3m
|
||||
}
|
||||
|
||||
proc ::tk::dialog::error::SaveToLog {text} {
|
||||
if {$::tcl_platform(platform) eq "windows"} {
|
||||
set allFiles *.*
|
||||
} else {
|
||||
set allFiles *
|
||||
}
|
||||
set types [list \
|
||||
[list [mc "Log Files"] .log] \
|
||||
[list [mc "Text Files"] .txt] \
|
||||
[list [mc "All Files"] $allFiles] \
|
||||
]
|
||||
set filename [tk_getSaveFile -title [mc "Select Log File"] \
|
||||
-filetypes $types -defaultextension .log -parent .bgerrorDialog]
|
||||
if {$filename ne {}} {
|
||||
set f [open $filename w]
|
||||
puts -nonewline $f $text
|
||||
close $f
|
||||
}
|
||||
return
|
||||
}
|
||||
|
||||
proc ::tk::dialog::error::Destroy {w} {
|
||||
if {$w eq ".bgerrorDialog"} {
|
||||
variable button
|
||||
set button -1
|
||||
}
|
||||
}
|
||||
|
||||
proc ::tk::dialog::error::DeleteByProtocol {} {
|
||||
variable button
|
||||
set button 1
|
||||
}
|
||||
|
||||
proc ::tk::dialog::error::ReturnInDetails w {
|
||||
bind $w <Return> {}; # Remove this binding
|
||||
$w invoke
|
||||
return -code break
|
||||
}
|
||||
|
||||
# ::tk::dialog::error::bgerror --
|
||||
#
|
||||
# This is the default version of bgerror.
|
||||
# It tries to execute tkerror, if that fails it posts a dialog box
|
||||
# containing the error message and gives the user a chance to ask
|
||||
# to see a stack trace.
|
||||
#
|
||||
# Arguments:
|
||||
# err - The error message.
|
||||
#
|
||||
proc ::tk::dialog::error::bgerror {err {flag 1}} {
|
||||
global errorInfo
|
||||
variable button
|
||||
|
||||
set info $errorInfo
|
||||
|
||||
set ret [catch {::tkerror $err} msg];
|
||||
if {$ret != 1} {return -code $ret $msg}
|
||||
|
||||
# The application's tkerror either failed or was not found
|
||||
# so we use the default dialog. But on Aqua we cannot display
|
||||
# the dialog if the background error occurs in an idle task
|
||||
# being processed inside of [NSView drawRect]. In that case
|
||||
# we post the dialog as an after task instead.
|
||||
set windowingsystem [tk windowingsystem]
|
||||
if {$windowingsystem eq "aqua"} {
|
||||
if $flag {
|
||||
set errorInfo $info
|
||||
after 500 [list bgerror "$err" 0]
|
||||
return
|
||||
}
|
||||
}
|
||||
|
||||
set ok [mc OK]
|
||||
# Truncate the message if it is too wide (>maxLine characters) or
|
||||
# too tall (>4 lines). Truncation occurs at the first point at
|
||||
# which one of those conditions is met.
|
||||
set displayedErr ""
|
||||
set lines 0
|
||||
set maxLine 45
|
||||
foreach line [split $err \n] {
|
||||
if {[string length $line] > $maxLine} {
|
||||
append displayedErr "[string range $line 0 $maxLine-3]..."
|
||||
break
|
||||
}
|
||||
if {$lines > 4} {
|
||||
append displayedErr "..."
|
||||
break
|
||||
} else {
|
||||
append displayedErr "${line}\n"
|
||||
}
|
||||
incr lines
|
||||
}
|
||||
|
||||
set title [mc "Application Error"]
|
||||
set text [mc "Error: %1\$s" $displayedErr]
|
||||
set buttons [list ok $ok dismiss [mc "Skip Messages"] \
|
||||
function [mc "Details >>"]]
|
||||
|
||||
# 1. Create the top-level window and divide it into top
|
||||
# and bottom parts.
|
||||
|
||||
set dlg .bgerrorDialog
|
||||
set bg [ttk::style lookup . -background]
|
||||
destroy $dlg
|
||||
toplevel $dlg -class ErrorDialog -background $bg
|
||||
wm withdraw $dlg
|
||||
wm title $dlg $title
|
||||
wm iconname $dlg ErrorDialog
|
||||
wm protocol $dlg WM_DELETE_WINDOW [namespace code DeleteByProtocol]
|
||||
|
||||
if {$windowingsystem eq "aqua"} {
|
||||
::tk::unsupported::MacWindowStyle style $dlg moveableAlert {}
|
||||
} elseif {$windowingsystem eq "x11"} {
|
||||
wm attributes $dlg -type dialog
|
||||
}
|
||||
|
||||
ttk::frame $dlg.bot
|
||||
ttk::frame $dlg.top
|
||||
pack $dlg.bot -side bottom -fill both
|
||||
pack $dlg.top -side top -fill both -expand 1
|
||||
|
||||
set W [ttk::frame $dlg.top.info]
|
||||
text $W.text -setgrid true -height 10 -wrap char \
|
||||
-yscrollcommand [list $W.scroll set]
|
||||
if {$windowingsystem ne "aqua"} {
|
||||
$W.text configure -width 40
|
||||
}
|
||||
|
||||
ttk::scrollbar $W.scroll -command [list $W.text yview]
|
||||
pack $W.scroll -side right -fill y
|
||||
pack $W.text -side left -expand yes -fill both
|
||||
$W.text insert 0.0 "$err\n$info"
|
||||
$W.text mark set insert 0.0
|
||||
bind $W.text <Button-1> {focus %W}
|
||||
$W.text configure -state disabled
|
||||
|
||||
# 2. Fill the top part with bitmap and message
|
||||
|
||||
# Max-width of message is the width of the screen...
|
||||
set wrapwidth [winfo screenwidth $dlg]
|
||||
# ...minus the width of the icon, padding and a fudge factor for
|
||||
# the window manager decorations and aesthetics.
|
||||
set wrapwidth [expr {$wrapwidth-60-[winfo pixels $dlg 9m]}]
|
||||
ttk::label $dlg.msg -justify left -text $text -wraplength $wrapwidth
|
||||
ttk::label $dlg.bitmap -image ::tk::icons::error
|
||||
|
||||
grid $dlg.bitmap $dlg.msg -in $dlg.top -row 0 -padx 3m -pady 3m
|
||||
grid configure $dlg.bitmap -sticky ne
|
||||
grid configure $dlg.msg -sticky nsw -padx {0 3m}
|
||||
grid rowconfigure $dlg.top 1 -weight 1
|
||||
grid columnconfigure $dlg.top 1 -weight 1
|
||||
|
||||
# 3. Create a row of buttons at the bottom of the dialog.
|
||||
|
||||
set i 0
|
||||
foreach {name caption} $buttons {
|
||||
ttk::button $dlg.$name -text $caption -default normal \
|
||||
-command [namespace code [list set button $i]]
|
||||
grid $dlg.$name -in $dlg.bot -column $i -row 0 -sticky ew -padx 10
|
||||
grid columnconfigure $dlg.bot $i -weight 1
|
||||
# We boost the size of some Mac buttons for l&f
|
||||
if {$windowingsystem eq "aqua"} {
|
||||
if {($name eq "ok") || ($name eq "dismiss")} {
|
||||
grid columnconfigure $dlg.bot $i -minsize 90
|
||||
}
|
||||
grid configure $dlg.$name -pady 7
|
||||
}
|
||||
incr i
|
||||
}
|
||||
# The "OK" button is the default for this dialog.
|
||||
$dlg.ok configure -default active
|
||||
|
||||
bind $dlg <Return> [namespace code {Return ok 0}]
|
||||
bind $dlg <Escape> [namespace code {Return dismiss 1}]
|
||||
bind $dlg <Destroy> [namespace code {Destroy %W}]
|
||||
bind $dlg.function <Return> [namespace code {ReturnInDetails %W}]
|
||||
$dlg.function configure -command [namespace code Details]
|
||||
|
||||
# 6. Withdraw the window, then update all the geometry information
|
||||
# so we know how big it wants to be, then center the window in the
|
||||
# display (Motif style) and de-iconify it.
|
||||
|
||||
::tk::PlaceWindow $dlg
|
||||
|
||||
# 7. Set a grab and claim the focus too.
|
||||
|
||||
::tk::SetFocusGrab $dlg $dlg.ok
|
||||
|
||||
# 8. Ensure that we are topmost.
|
||||
|
||||
raise $dlg
|
||||
if {[tk windowingsystem] eq "win32"} {
|
||||
# Place it topmost if we aren't at the top of the stacking
|
||||
# order to ensure that it's seen
|
||||
if {[lindex [wm stackorder .] end] ne "$dlg"} {
|
||||
wm attributes $dlg -topmost 1
|
||||
}
|
||||
}
|
||||
|
||||
# 9. Wait for the user to respond, then restore the focus and
|
||||
# return the index of the selected button. Restore the focus
|
||||
# before deleting the window, since otherwise the window manager
|
||||
# may take the focus away so we can't redirect it. Finally,
|
||||
# restore any grab that was in effect.
|
||||
|
||||
vwait [namespace which -variable button]
|
||||
set copy $button; # Save a copy...
|
||||
|
||||
::tk::RestoreFocusGrab $dlg $dlg.ok destroy
|
||||
|
||||
if {$copy == 1} {
|
||||
return -code break
|
||||
}
|
||||
}
|
||||
|
||||
namespace eval :: {
|
||||
# Fool the indexer
|
||||
proc bgerror err {}
|
||||
rename bgerror {}
|
||||
namespace import ::tk::dialog::error::bgerror
|
||||
}
|
||||
|
|
@ -0,0 +1,782 @@
|
|||
# button.tcl --
|
||||
#
|
||||
# This file defines the default bindings for Tk label, button,
|
||||
# checkbutton, and radiobutton widgets and provides procedures
|
||||
# that help in implementing those bindings.
|
||||
#
|
||||
# Copyright (c) 1992-1994 The Regents of the University of California.
|
||||
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
|
||||
# Copyright (c) 2002 ActiveState Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
|
||||
#-------------------------------------------------------------------------
|
||||
# The code below creates the default class bindings for buttons.
|
||||
#-------------------------------------------------------------------------
|
||||
|
||||
if {[tk windowingsystem] eq "aqua"} {
|
||||
|
||||
bind Radiobutton <Enter> {
|
||||
tk::ButtonEnter %W
|
||||
}
|
||||
bind Radiobutton <1> {
|
||||
tk::ButtonDown %W
|
||||
}
|
||||
bind Radiobutton <ButtonRelease-1> {
|
||||
tk::ButtonUp %W
|
||||
}
|
||||
bind Checkbutton <Enter> {
|
||||
tk::ButtonEnter %W
|
||||
}
|
||||
bind Checkbutton <1> {
|
||||
tk::ButtonDown %W
|
||||
}
|
||||
bind Checkbutton <ButtonRelease-1> {
|
||||
tk::ButtonUp %W
|
||||
}
|
||||
bind Checkbutton <Leave> {
|
||||
tk::ButtonLeave %W
|
||||
}
|
||||
}
|
||||
if {"win32" eq [tk windowingsystem]} {
|
||||
bind Checkbutton <equal> {
|
||||
tk::CheckRadioInvoke %W select
|
||||
}
|
||||
bind Checkbutton <plus> {
|
||||
tk::CheckRadioInvoke %W select
|
||||
}
|
||||
bind Checkbutton <minus> {
|
||||
tk::CheckRadioInvoke %W deselect
|
||||
}
|
||||
bind Checkbutton <1> {
|
||||
tk::CheckRadioDown %W
|
||||
}
|
||||
bind Checkbutton <ButtonRelease-1> {
|
||||
tk::ButtonUp %W
|
||||
}
|
||||
bind Checkbutton <Enter> {
|
||||
tk::CheckRadioEnter %W
|
||||
}
|
||||
bind Checkbutton <Leave> {
|
||||
tk::ButtonLeave %W
|
||||
}
|
||||
|
||||
bind Radiobutton <1> {
|
||||
tk::CheckRadioDown %W
|
||||
}
|
||||
bind Radiobutton <ButtonRelease-1> {
|
||||
tk::ButtonUp %W
|
||||
}
|
||||
bind Radiobutton <Enter> {
|
||||
tk::CheckRadioEnter %W
|
||||
}
|
||||
}
|
||||
if {"x11" eq [tk windowingsystem]} {
|
||||
bind Checkbutton <Return> {
|
||||
if {!$tk_strictMotif} {
|
||||
tk::CheckInvoke %W
|
||||
}
|
||||
}
|
||||
bind Radiobutton <Return> {
|
||||
if {!$tk_strictMotif} {
|
||||
tk::CheckRadioInvoke %W
|
||||
}
|
||||
}
|
||||
bind Checkbutton <1> {
|
||||
tk::CheckInvoke %W
|
||||
}
|
||||
bind Radiobutton <1> {
|
||||
tk::CheckRadioInvoke %W
|
||||
}
|
||||
bind Checkbutton <Enter> {
|
||||
tk::CheckEnter %W
|
||||
}
|
||||
bind Radiobutton <Enter> {
|
||||
tk::ButtonEnter %W
|
||||
}
|
||||
bind Checkbutton <Leave> {
|
||||
tk::CheckLeave %W
|
||||
}
|
||||
}
|
||||
|
||||
bind Button <space> {
|
||||
tk::ButtonInvoke %W
|
||||
}
|
||||
bind Checkbutton <space> {
|
||||
tk::CheckRadioInvoke %W
|
||||
}
|
||||
bind Radiobutton <space> {
|
||||
tk::CheckRadioInvoke %W
|
||||
}
|
||||
bind Button <<Invoke>> {
|
||||
tk::ButtonInvoke %W
|
||||
}
|
||||
bind Checkbutton <<Invoke>> {
|
||||
tk::CheckRadioInvoke %W
|
||||
}
|
||||
bind Radiobutton <<Invoke>> {
|
||||
tk::CheckRadioInvoke %W
|
||||
}
|
||||
|
||||
bind Button <FocusIn> {}
|
||||
bind Button <Enter> {
|
||||
tk::ButtonEnter %W
|
||||
}
|
||||
bind Button <Leave> {
|
||||
tk::ButtonLeave %W
|
||||
}
|
||||
bind Button <1> {
|
||||
tk::ButtonDown %W
|
||||
}
|
||||
bind Button <ButtonRelease-1> {
|
||||
tk::ButtonUp %W
|
||||
}
|
||||
|
||||
bind Checkbutton <FocusIn> {}
|
||||
|
||||
bind Radiobutton <FocusIn> {}
|
||||
bind Radiobutton <Leave> {
|
||||
tk::ButtonLeave %W
|
||||
}
|
||||
|
||||
if {"win32" eq [tk windowingsystem]} {
|
||||
|
||||
#########################
|
||||
# Windows implementation
|
||||
#########################
|
||||
|
||||
# ::tk::ButtonEnter --
|
||||
# The procedure below is invoked when the mouse pointer enters a
|
||||
# button widget. It records the button we're in and changes the
|
||||
# state of the button to active unless the button is disabled.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
|
||||
proc ::tk::ButtonEnter w {
|
||||
variable ::tk::Priv
|
||||
if {[$w cget -state] ne "disabled"} {
|
||||
|
||||
# If the mouse button is down, set the relief to sunken on entry.
|
||||
# Overwise, if there's an -overrelief value, set the relief to that.
|
||||
|
||||
set Priv($w,relief) [$w cget -relief]
|
||||
if {$Priv(buttonWindow) eq $w} {
|
||||
$w configure -relief sunken -state active
|
||||
set Priv($w,prelief) sunken
|
||||
} elseif {[set over [$w cget -overrelief]] ne ""} {
|
||||
$w configure -relief $over
|
||||
set Priv($w,prelief) $over
|
||||
}
|
||||
}
|
||||
set Priv(window) $w
|
||||
}
|
||||
|
||||
# ::tk::ButtonLeave --
|
||||
# The procedure below is invoked when the mouse pointer leaves a
|
||||
# button widget. It changes the state of the button back to inactive.
|
||||
# Restore any modified relief too.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
|
||||
proc ::tk::ButtonLeave w {
|
||||
variable ::tk::Priv
|
||||
if {[$w cget -state] ne "disabled"} {
|
||||
$w configure -state normal
|
||||
}
|
||||
|
||||
# Restore the original button relief if it was changed by Tk.
|
||||
# That is signaled by the existence of Priv($w,prelief).
|
||||
|
||||
if {[info exists Priv($w,relief)]} {
|
||||
if {[info exists Priv($w,prelief)] && \
|
||||
$Priv($w,prelief) eq [$w cget -relief]} {
|
||||
$w configure -relief $Priv($w,relief)
|
||||
}
|
||||
unset -nocomplain Priv($w,relief) Priv($w,prelief)
|
||||
}
|
||||
|
||||
set Priv(window) ""
|
||||
}
|
||||
|
||||
# ::tk::ButtonDown --
|
||||
# The procedure below is invoked when the mouse button is pressed in
|
||||
# a button widget. It records the fact that the mouse is in the button,
|
||||
# saves the button's relief so it can be restored later, and changes
|
||||
# the relief to sunken.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
|
||||
proc ::tk::ButtonDown w {
|
||||
variable ::tk::Priv
|
||||
|
||||
# Only save the button's relief if it does not yet exist. If there
|
||||
# is an overrelief setting, Priv($w,relief) will already have been set,
|
||||
# and the current value of the -relief option will be incorrect.
|
||||
|
||||
if {![info exists Priv($w,relief)]} {
|
||||
set Priv($w,relief) [$w cget -relief]
|
||||
}
|
||||
|
||||
if {[$w cget -state] ne "disabled"} {
|
||||
set Priv(buttonWindow) $w
|
||||
$w configure -relief sunken -state active
|
||||
set Priv($w,prelief) sunken
|
||||
|
||||
# If this button has a repeatdelay set up, get it going with an after
|
||||
after cancel $Priv(afterId)
|
||||
set delay [$w cget -repeatdelay]
|
||||
set Priv(repeated) 0
|
||||
if {$delay > 0} {
|
||||
set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]]
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::ButtonUp --
|
||||
# The procedure below is invoked when the mouse button is released
|
||||
# in a button widget. It restores the button's relief and invokes
|
||||
# the command as long as the mouse hasn't left the button.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
|
||||
proc ::tk::ButtonUp w {
|
||||
variable ::tk::Priv
|
||||
if {$Priv(buttonWindow) eq $w} {
|
||||
set Priv(buttonWindow) ""
|
||||
|
||||
# Restore the button's relief if it was cached.
|
||||
|
||||
if {[info exists Priv($w,relief)]} {
|
||||
if {[info exists Priv($w,prelief)] && \
|
||||
$Priv($w,prelief) eq [$w cget -relief]} {
|
||||
$w configure -relief $Priv($w,relief)
|
||||
}
|
||||
unset -nocomplain Priv($w,relief) Priv($w,prelief)
|
||||
}
|
||||
|
||||
# Clean up the after event from the auto-repeater
|
||||
after cancel $Priv(afterId)
|
||||
|
||||
if {$Priv(window) eq $w && [$w cget -state] ne "disabled"} {
|
||||
$w configure -state normal
|
||||
|
||||
# Only invoke the command if it wasn't already invoked by the
|
||||
# auto-repeater functionality
|
||||
if { $Priv(repeated) == 0 } {
|
||||
uplevel #0 [list $w invoke]
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::CheckRadioEnter --
|
||||
# The procedure below is invoked when the mouse pointer enters a
|
||||
# checkbutton or radiobutton widget. It records the button we're in
|
||||
# and changes the state of the button to active unless the button is
|
||||
# disabled.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
|
||||
proc ::tk::CheckRadioEnter w {
|
||||
variable ::tk::Priv
|
||||
if {[$w cget -state] ne "disabled"} {
|
||||
if {$Priv(buttonWindow) eq $w} {
|
||||
$w configure -state active
|
||||
}
|
||||
if {[set over [$w cget -overrelief]] ne ""} {
|
||||
set Priv($w,relief) [$w cget -relief]
|
||||
set Priv($w,prelief) $over
|
||||
$w configure -relief $over
|
||||
}
|
||||
}
|
||||
set Priv(window) $w
|
||||
}
|
||||
|
||||
# ::tk::CheckRadioDown --
|
||||
# The procedure below is invoked when the mouse button is pressed in
|
||||
# a button widget. It records the fact that the mouse is in the button,
|
||||
# saves the button's relief so it can be restored later, and changes
|
||||
# the relief to sunken.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
|
||||
proc ::tk::CheckRadioDown w {
|
||||
variable ::tk::Priv
|
||||
if {![info exists Priv($w,relief)]} {
|
||||
set Priv($w,relief) [$w cget -relief]
|
||||
}
|
||||
if {[$w cget -state] ne "disabled"} {
|
||||
set Priv(buttonWindow) $w
|
||||
set Priv(repeated) 0
|
||||
$w configure -state active
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
if {"x11" eq [tk windowingsystem]} {
|
||||
|
||||
#####################
|
||||
# Unix implementation
|
||||
#####################
|
||||
|
||||
# ::tk::ButtonEnter --
|
||||
# The procedure below is invoked when the mouse pointer enters a
|
||||
# button widget. It records the button we're in and changes the
|
||||
# state of the button to active unless the button is disabled.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
|
||||
proc ::tk::ButtonEnter {w} {
|
||||
variable ::tk::Priv
|
||||
if {[$w cget -state] ne "disabled"} {
|
||||
# On unix the state is active just with mouse-over
|
||||
$w configure -state active
|
||||
|
||||
# If the mouse button is down, set the relief to sunken on entry.
|
||||
# Overwise, if there's an -overrelief value, set the relief to that.
|
||||
|
||||
set Priv($w,relief) [$w cget -relief]
|
||||
if {$Priv(buttonWindow) eq $w} {
|
||||
$w configure -relief sunken
|
||||
set Priv($w,prelief) sunken
|
||||
} elseif {[set over [$w cget -overrelief]] ne ""} {
|
||||
$w configure -relief $over
|
||||
set Priv($w,prelief) $over
|
||||
}
|
||||
}
|
||||
set Priv(window) $w
|
||||
}
|
||||
|
||||
# ::tk::ButtonLeave --
|
||||
# The procedure below is invoked when the mouse pointer leaves a
|
||||
# button widget. It changes the state of the button back to inactive.
|
||||
# Restore any modified relief too.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
|
||||
proc ::tk::ButtonLeave w {
|
||||
variable ::tk::Priv
|
||||
if {[$w cget -state] ne "disabled"} {
|
||||
$w configure -state normal
|
||||
}
|
||||
|
||||
# Restore the original button relief if it was changed by Tk.
|
||||
# That is signaled by the existence of Priv($w,prelief).
|
||||
|
||||
if {[info exists Priv($w,relief)]} {
|
||||
if {[info exists Priv($w,prelief)] && \
|
||||
$Priv($w,prelief) eq [$w cget -relief]} {
|
||||
$w configure -relief $Priv($w,relief)
|
||||
}
|
||||
unset -nocomplain Priv($w,relief) Priv($w,prelief)
|
||||
}
|
||||
|
||||
set Priv(window) ""
|
||||
}
|
||||
|
||||
# ::tk::ButtonDown --
|
||||
# The procedure below is invoked when the mouse button is pressed in
|
||||
# a button widget. It records the fact that the mouse is in the button,
|
||||
# saves the button's relief so it can be restored later, and changes
|
||||
# the relief to sunken.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
|
||||
proc ::tk::ButtonDown w {
|
||||
variable ::tk::Priv
|
||||
|
||||
# Only save the button's relief if it does not yet exist. If there
|
||||
# is an overrelief setting, Priv($w,relief) will already have been set,
|
||||
# and the current value of the -relief option will be incorrect.
|
||||
|
||||
if {![info exists Priv($w,relief)]} {
|
||||
set Priv($w,relief) [$w cget -relief]
|
||||
}
|
||||
|
||||
if {[$w cget -state] ne "disabled"} {
|
||||
set Priv(buttonWindow) $w
|
||||
$w configure -relief sunken
|
||||
set Priv($w,prelief) sunken
|
||||
|
||||
# If this button has a repeatdelay set up, get it going with an after
|
||||
after cancel $Priv(afterId)
|
||||
set delay [$w cget -repeatdelay]
|
||||
set Priv(repeated) 0
|
||||
if {$delay > 0} {
|
||||
set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]]
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::ButtonUp --
|
||||
# The procedure below is invoked when the mouse button is released
|
||||
# in a button widget. It restores the button's relief and invokes
|
||||
# the command as long as the mouse hasn't left the button.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
|
||||
proc ::tk::ButtonUp w {
|
||||
variable ::tk::Priv
|
||||
if {$w eq $Priv(buttonWindow)} {
|
||||
set Priv(buttonWindow) ""
|
||||
|
||||
# Restore the button's relief if it was cached.
|
||||
|
||||
if {[info exists Priv($w,relief)]} {
|
||||
if {[info exists Priv($w,prelief)] && \
|
||||
$Priv($w,prelief) eq [$w cget -relief]} {
|
||||
$w configure -relief $Priv($w,relief)
|
||||
}
|
||||
unset -nocomplain Priv($w,relief) Priv($w,prelief)
|
||||
}
|
||||
|
||||
# Clean up the after event from the auto-repeater
|
||||
after cancel $Priv(afterId)
|
||||
|
||||
if {$Priv(window) eq $w && [$w cget -state] ne "disabled"} {
|
||||
# Only invoke the command if it wasn't already invoked by the
|
||||
# auto-repeater functionality
|
||||
if { $Priv(repeated) == 0 } {
|
||||
uplevel #0 [list $w invoke]
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
if {[tk windowingsystem] eq "aqua"} {
|
||||
|
||||
####################
|
||||
# Mac implementation
|
||||
####################
|
||||
|
||||
# ::tk::ButtonEnter --
|
||||
# The procedure below is invoked when the mouse pointer enters a
|
||||
# button widget. It records the button we're in and changes the
|
||||
# state of the button to active unless the button is disabled.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
|
||||
proc ::tk::ButtonEnter {w} {
|
||||
variable ::tk::Priv
|
||||
if {[$w cget -state] ne "disabled"} {
|
||||
|
||||
# If there's an -overrelief value, set the relief to that.
|
||||
|
||||
if {$Priv(buttonWindow) eq $w} {
|
||||
$w configure -state active
|
||||
} elseif {[set over [$w cget -overrelief]] ne ""} {
|
||||
set Priv($w,relief) [$w cget -relief]
|
||||
set Priv($w,prelief) $over
|
||||
$w configure -relief $over
|
||||
}
|
||||
}
|
||||
set Priv(window) $w
|
||||
}
|
||||
|
||||
# ::tk::ButtonLeave --
|
||||
# The procedure below is invoked when the mouse pointer leaves a
|
||||
# button widget. It changes the state of the button back to
|
||||
# inactive. If we're leaving the button window with a mouse button
|
||||
# pressed (Priv(buttonWindow) == $w), restore the relief of the
|
||||
# button too.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
|
||||
proc ::tk::ButtonLeave w {
|
||||
variable ::tk::Priv
|
||||
if {$w eq $Priv(buttonWindow)} {
|
||||
$w configure -state normal
|
||||
}
|
||||
|
||||
# Restore the original button relief if it was changed by Tk.
|
||||
# That is signaled by the existence of Priv($w,prelief).
|
||||
|
||||
if {[info exists Priv($w,relief)]} {
|
||||
if {[info exists Priv($w,prelief)] && \
|
||||
$Priv($w,prelief) eq [$w cget -relief]} {
|
||||
$w configure -relief $Priv($w,relief)
|
||||
}
|
||||
unset -nocomplain Priv($w,relief) Priv($w,prelief)
|
||||
}
|
||||
|
||||
set Priv(window) ""
|
||||
}
|
||||
|
||||
# ::tk::ButtonDown --
|
||||
# The procedure below is invoked when the mouse button is pressed in
|
||||
# a button widget. It records the fact that the mouse is in the button,
|
||||
# saves the button's relief so it can be restored later, and changes
|
||||
# the relief to sunken.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
|
||||
proc ::tk::ButtonDown w {
|
||||
variable ::tk::Priv
|
||||
|
||||
if {[$w cget -state] ne "disabled"} {
|
||||
set Priv(buttonWindow) $w
|
||||
$w configure -state active
|
||||
|
||||
# If this button has a repeatdelay set up, get it going with an after
|
||||
after cancel $Priv(afterId)
|
||||
set Priv(repeated) 0
|
||||
if { ![catch {$w cget -repeatdelay} delay] } {
|
||||
if {$delay > 0} {
|
||||
set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]]
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::ButtonUp --
|
||||
# The procedure below is invoked when the mouse button is released
|
||||
# in a button widget. It restores the button's relief and invokes
|
||||
# the command as long as the mouse hasn't left the button.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
|
||||
proc ::tk::ButtonUp w {
|
||||
variable ::tk::Priv
|
||||
if {$Priv(buttonWindow) eq $w} {
|
||||
set Priv(buttonWindow) ""
|
||||
$w configure -state normal
|
||||
|
||||
# Restore the button's relief if it was cached.
|
||||
|
||||
if {[info exists Priv($w,relief)]} {
|
||||
if {[info exists Priv($w,prelief)] && \
|
||||
$Priv($w,prelief) eq [$w cget -relief]} {
|
||||
$w configure -relief $Priv($w,relief)
|
||||
}
|
||||
unset -nocomplain Priv($w,relief) Priv($w,prelief)
|
||||
}
|
||||
|
||||
# Clean up the after event from the auto-repeater
|
||||
after cancel $Priv(afterId)
|
||||
|
||||
if {$Priv(window) eq $w && [$w cget -state] ne "disabled"} {
|
||||
# Only invoke the command if it wasn't already invoked by the
|
||||
# auto-repeater functionality
|
||||
if { $Priv(repeated) == 0 } {
|
||||
uplevel #0 [list $w invoke]
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
##################
|
||||
# Shared routines
|
||||
##################
|
||||
|
||||
# ::tk::ButtonInvoke --
|
||||
# The procedure below is called when a button is invoked through
|
||||
# the keyboard. It simulate a press of the button via the mouse.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
|
||||
proc ::tk::ButtonInvoke w {
|
||||
if {[winfo exists $w] && [$w cget -state] ne "disabled"} {
|
||||
set oldRelief [$w cget -relief]
|
||||
set oldState [$w cget -state]
|
||||
$w configure -state active -relief sunken
|
||||
after 100 [list ::tk::ButtonInvokeEnd $w $oldState $oldRelief]
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::ButtonInvokeEnd --
|
||||
# The procedure below is called after a button is invoked through
|
||||
# the keyboard. It simulate a release of the button via the mouse.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
# oldState - Old state to be set back.
|
||||
# oldRelief - Old relief to be set back.
|
||||
|
||||
proc ::tk::ButtonInvokeEnd {w oldState oldRelief} {
|
||||
if {[winfo exists $w]} {
|
||||
$w configure -state $oldState -relief $oldRelief
|
||||
uplevel #0 [list $w invoke]
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::ButtonAutoInvoke --
|
||||
#
|
||||
# Invoke an auto-repeating button, and set it up to continue to repeat.
|
||||
#
|
||||
# Arguments:
|
||||
# w button to invoke.
|
||||
#
|
||||
# Results:
|
||||
# None.
|
||||
#
|
||||
# Side effects:
|
||||
# May create an after event to call ::tk::ButtonAutoInvoke.
|
||||
|
||||
proc ::tk::ButtonAutoInvoke {w} {
|
||||
variable ::tk::Priv
|
||||
after cancel $Priv(afterId)
|
||||
set delay [$w cget -repeatinterval]
|
||||
if {$Priv(window) eq $w} {
|
||||
incr Priv(repeated)
|
||||
uplevel #0 [list $w invoke]
|
||||
}
|
||||
if {$delay > 0} {
|
||||
set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]]
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::CheckRadioInvoke --
|
||||
# The procedure below is invoked when the mouse button is pressed in
|
||||
# a checkbutton or radiobutton widget, or when the widget is invoked
|
||||
# through the keyboard. It invokes the widget if it
|
||||
# isn't disabled.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
# cmd - The subcommand to invoke (one of invoke, select, or deselect).
|
||||
|
||||
proc ::tk::CheckRadioInvoke {w {cmd invoke}} {
|
||||
if {[$w cget -state] ne "disabled"} {
|
||||
uplevel #0 [list $w $cmd]
|
||||
}
|
||||
}
|
||||
|
||||
# Special versions of the handlers for checkbuttons on Unix that do the magic
|
||||
# to make things work right when the checkbutton indicator is hidden;
|
||||
# radiobuttons don't need this complexity.
|
||||
|
||||
# ::tk::CheckInvoke --
|
||||
# The procedure below invokes the checkbutton, like ButtonInvoke, but handles
|
||||
# what to do when the checkbutton indicator is missing. Only used on Unix.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
|
||||
proc ::tk::CheckInvoke {w} {
|
||||
variable ::tk::Priv
|
||||
if {[$w cget -state] ne "disabled"} {
|
||||
# Additional logic to switch the "selected" colors around if necessary
|
||||
# (when we're indicator-less).
|
||||
|
||||
if {![$w cget -indicatoron] && [info exist Priv($w,selectcolor)]} {
|
||||
if {[$w cget -selectcolor] eq $Priv($w,aselectcolor)} {
|
||||
$w configure -selectcolor $Priv($w,selectcolor)
|
||||
} else {
|
||||
$w configure -selectcolor $Priv($w,aselectcolor)
|
||||
}
|
||||
}
|
||||
uplevel #0 [list $w invoke]
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::CheckEnter --
|
||||
# The procedure below enters the checkbutton, like ButtonEnter, but handles
|
||||
# what to do when the checkbutton indicator is missing. Only used on Unix.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
|
||||
proc ::tk::CheckEnter {w} {
|
||||
variable ::tk::Priv
|
||||
if {[$w cget -state] ne "disabled"} {
|
||||
# On unix the state is active just with mouse-over
|
||||
$w configure -state active
|
||||
|
||||
# If the mouse button is down, set the relief to sunken on entry.
|
||||
# Overwise, if there's an -overrelief value, set the relief to that.
|
||||
|
||||
set Priv($w,relief) [$w cget -relief]
|
||||
if {$Priv(buttonWindow) eq $w} {
|
||||
$w configure -relief sunken
|
||||
set Priv($w,prelief) sunken
|
||||
} elseif {[set over [$w cget -overrelief]] ne ""} {
|
||||
$w configure -relief $over
|
||||
set Priv($w,prelief) $over
|
||||
}
|
||||
|
||||
# Compute what the "selected and active" color should be.
|
||||
|
||||
if {![$w cget -indicatoron] && [$w cget -selectcolor] ne ""} {
|
||||
set Priv($w,selectcolor) [$w cget -selectcolor]
|
||||
lassign [winfo rgb $w [$w cget -selectcolor]] r1 g1 b1
|
||||
lassign [winfo rgb $w [$w cget -activebackground]] r2 g2 b2
|
||||
set Priv($w,aselectcolor) \
|
||||
[format "#%04x%04x%04x" [expr {($r1+$r2)/2}] \
|
||||
[expr {($g1+$g2)/2}] [expr {($b1+$b2)/2}]]
|
||||
# use uplevel to work with other var resolvers
|
||||
if {[uplevel #0 [list set [$w cget -variable]]]
|
||||
eq [$w cget -onvalue]} {
|
||||
$w configure -selectcolor $Priv($w,aselectcolor)
|
||||
}
|
||||
}
|
||||
}
|
||||
set Priv(window) $w
|
||||
}
|
||||
|
||||
# ::tk::CheckLeave --
|
||||
# The procedure below leaves the checkbutton, like ButtonLeave, but handles
|
||||
# what to do when the checkbutton indicator is missing. Only used on Unix.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
|
||||
proc ::tk::CheckLeave {w} {
|
||||
variable ::tk::Priv
|
||||
if {[$w cget -state] ne "disabled"} {
|
||||
$w configure -state normal
|
||||
}
|
||||
|
||||
# Restore the original button "selected" color; but only if the user
|
||||
# has not changed it in the meantime.
|
||||
|
||||
if {![$w cget -indicatoron] && [info exist Priv($w,selectcolor)]} {
|
||||
if {[$w cget -selectcolor] eq $Priv($w,selectcolor)
|
||||
|| ([info exist Priv($w,aselectcolor)] &&
|
||||
[$w cget -selectcolor] eq $Priv($w,aselectcolor))} {
|
||||
$w configure -selectcolor $Priv($w,selectcolor)
|
||||
}
|
||||
}
|
||||
unset -nocomplain Priv($w,selectcolor) Priv($w,aselectcolor)
|
||||
|
||||
# Restore the original button relief if it was changed by Tk. That is
|
||||
# signaled by the existence of Priv($w,prelief).
|
||||
|
||||
if {[info exists Priv($w,relief)]} {
|
||||
if {[info exists Priv($w,prelief)] && \
|
||||
$Priv($w,prelief) eq [$w cget -relief]} {
|
||||
$w configure -relief $Priv($w,relief)
|
||||
}
|
||||
unset -nocomplain Priv($w,relief) Priv($w,prelief)
|
||||
}
|
||||
|
||||
set Priv(window) ""
|
||||
}
|
||||
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# fill-column: 78
|
||||
# End:
|
||||
|
|
@ -0,0 +1,308 @@
|
|||
# choosedir.tcl --
|
||||
#
|
||||
# Choose directory dialog implementation for Unix/Mac.
|
||||
#
|
||||
# Copyright (c) 1998-2000 by Scriptics Corporation.
|
||||
# All rights reserved.
|
||||
|
||||
# Make sure the tk::dialog namespace, in which all dialogs should live, exists
|
||||
namespace eval ::tk::dialog {}
|
||||
namespace eval ::tk::dialog::file {}
|
||||
|
||||
# Make the chooseDir namespace inside the dialog namespace
|
||||
namespace eval ::tk::dialog::file::chooseDir {
|
||||
namespace import -force ::tk::msgcat::*
|
||||
}
|
||||
|
||||
# ::tk::dialog::file::chooseDir:: --
|
||||
#
|
||||
# Implements the TK directory selection dialog.
|
||||
#
|
||||
# Arguments:
|
||||
# args Options parsed by the procedure.
|
||||
#
|
||||
proc ::tk::dialog::file::chooseDir:: {args} {
|
||||
variable ::tk::Priv
|
||||
set dataName __tk_choosedir
|
||||
upvar ::tk::dialog::file::$dataName data
|
||||
Config $dataName $args
|
||||
|
||||
if {$data(-parent) eq "."} {
|
||||
set w .$dataName
|
||||
} else {
|
||||
set w $data(-parent).$dataName
|
||||
}
|
||||
|
||||
# (re)create the dialog box if necessary
|
||||
#
|
||||
if {![winfo exists $w]} {
|
||||
::tk::dialog::file::Create $w TkChooseDir
|
||||
} elseif {[winfo class $w] ne "TkChooseDir"} {
|
||||
destroy $w
|
||||
::tk::dialog::file::Create $w TkChooseDir
|
||||
} else {
|
||||
set data(dirMenuBtn) $w.contents.f1.menu
|
||||
set data(dirMenu) $w.contents.f1.menu.menu
|
||||
set data(upBtn) $w.contents.f1.up
|
||||
set data(icons) $w.contents.icons
|
||||
set data(ent) $w.contents.f2.ent
|
||||
set data(okBtn) $w.contents.f2.ok
|
||||
set data(cancelBtn) $w.contents.f2.cancel
|
||||
set data(hiddenBtn) $w.contents.f2.hidden
|
||||
}
|
||||
if {$::tk::dialog::file::showHiddenBtn} {
|
||||
$data(hiddenBtn) configure -state normal
|
||||
grid $data(hiddenBtn)
|
||||
} else {
|
||||
$data(hiddenBtn) configure -state disabled
|
||||
grid remove $data(hiddenBtn)
|
||||
}
|
||||
|
||||
# When using -mustexist, manage the OK button state for validity
|
||||
$data(okBtn) configure -state normal
|
||||
if {$data(-mustexist)} {
|
||||
$data(ent) configure -validate key \
|
||||
-validatecommand [list ::tk::dialog::file::chooseDir::IsOK? $w %P]
|
||||
} else {
|
||||
$data(ent) configure -validate none
|
||||
}
|
||||
|
||||
# Dialog boxes should be transient with respect to their parent,
|
||||
# so that they will always stay on top of their parent window. However,
|
||||
# some window managers will create the window as withdrawn if the parent
|
||||
# window is withdrawn or iconified. Combined with the grab we put on the
|
||||
# window, this can hang the entire application. Therefore we only make
|
||||
# the dialog transient if the parent is viewable.
|
||||
|
||||
if {[winfo viewable [winfo toplevel $data(-parent)]] } {
|
||||
wm transient $w $data(-parent)
|
||||
}
|
||||
|
||||
trace add variable data(selectPath) write \
|
||||
[list ::tk::dialog::file::SetPath $w]
|
||||
$data(dirMenuBtn) configure \
|
||||
-textvariable ::tk::dialog::file::${dataName}(selectPath)
|
||||
|
||||
set data(filter) "*"
|
||||
set data(previousEntryText) ""
|
||||
::tk::dialog::file::UpdateWhenIdle $w
|
||||
|
||||
# Withdraw the window, then update all the geometry information
|
||||
# so we know how big it wants to be, then center the window in the
|
||||
# display (Motif style) and de-iconify it.
|
||||
|
||||
::tk::PlaceWindow $w widget $data(-parent)
|
||||
wm title $w $data(-title)
|
||||
|
||||
# Set a grab and claim the focus too.
|
||||
|
||||
::tk::SetFocusGrab $w $data(ent)
|
||||
$data(ent) delete 0 end
|
||||
$data(ent) insert 0 $data(selectPath)
|
||||
$data(ent) selection range 0 end
|
||||
$data(ent) icursor end
|
||||
|
||||
# Wait for the user to respond, then restore the focus and
|
||||
# return the index of the selected button. Restore the focus
|
||||
# before deleting the window, since otherwise the window manager
|
||||
# may take the focus away so we can't redirect it. Finally,
|
||||
# restore any grab that was in effect.
|
||||
|
||||
vwait ::tk::Priv(selectFilePath)
|
||||
|
||||
::tk::RestoreFocusGrab $w $data(ent) withdraw
|
||||
|
||||
# Cleanup traces on selectPath variable
|
||||
#
|
||||
|
||||
foreach trace [trace info variable data(selectPath)] {
|
||||
trace remove variable data(selectPath) [lindex $trace 0] [lindex $trace 1]
|
||||
}
|
||||
$data(dirMenuBtn) configure -textvariable {}
|
||||
|
||||
# Return value to user
|
||||
#
|
||||
|
||||
return $Priv(selectFilePath)
|
||||
}
|
||||
|
||||
# ::tk::dialog::file::chooseDir::Config --
|
||||
#
|
||||
# Configures the Tk choosedir dialog according to the argument list
|
||||
#
|
||||
proc ::tk::dialog::file::chooseDir::Config {dataName argList} {
|
||||
upvar ::tk::dialog::file::$dataName data
|
||||
|
||||
# 0: Delete all variable that were set on data(selectPath) the
|
||||
# last time the file dialog is used. The traces may cause troubles
|
||||
# if the dialog is now used with a different -parent option.
|
||||
#
|
||||
foreach trace [trace info variable data(selectPath)] {
|
||||
trace remove variable data(selectPath) [lindex $trace 0] [lindex $trace 1]
|
||||
}
|
||||
|
||||
# 1: the configuration specs
|
||||
#
|
||||
set specs {
|
||||
{-mustexist "" "" 0}
|
||||
{-initialdir "" "" ""}
|
||||
{-parent "" "" "."}
|
||||
{-title "" "" ""}
|
||||
}
|
||||
|
||||
# 2: default values depending on the type of the dialog
|
||||
#
|
||||
if {![info exists data(selectPath)]} {
|
||||
# first time the dialog has been popped up
|
||||
set data(selectPath) [pwd]
|
||||
}
|
||||
|
||||
# 3: parse the arguments
|
||||
#
|
||||
tclParseConfigSpec ::tk::dialog::file::$dataName $specs "" $argList
|
||||
|
||||
if {$data(-title) eq ""} {
|
||||
set data(-title) "[mc "Choose Directory"]"
|
||||
}
|
||||
|
||||
# Stub out the -multiple value for the dialog; it doesn't make sense for
|
||||
# choose directory dialogs, but we have to have something there because we
|
||||
# share so much code with the file dialogs.
|
||||
set data(-multiple) 0
|
||||
|
||||
# 4: set the default directory and selection according to the -initial
|
||||
# settings
|
||||
#
|
||||
if {$data(-initialdir) ne ""} {
|
||||
# Ensure that initialdir is an absolute path name.
|
||||
if {[file isdirectory $data(-initialdir)]} {
|
||||
set old [pwd]
|
||||
cd $data(-initialdir)
|
||||
set data(selectPath) [pwd]
|
||||
cd $old
|
||||
} else {
|
||||
set data(selectPath) [pwd]
|
||||
}
|
||||
}
|
||||
|
||||
if {![winfo exists $data(-parent)]} {
|
||||
return -code error -errorcode [list TK LOOKUP WINDOW $data(-parent)] \
|
||||
"bad window path name \"$data(-parent)\""
|
||||
}
|
||||
}
|
||||
|
||||
# Gets called when user presses Return in the "Selection" entry or presses OK.
|
||||
#
|
||||
proc ::tk::dialog::file::chooseDir::OkCmd {w} {
|
||||
upvar ::tk::dialog::file::[winfo name $w] data
|
||||
|
||||
# This is the brains behind selecting non-existant directories. Here's
|
||||
# the flowchart:
|
||||
# 1. If the icon list has a selection, join it with the current dir,
|
||||
# and return that value.
|
||||
# 1a. If the icon list does not have a selection ...
|
||||
# 2. If the entry is empty, do nothing.
|
||||
# 3. If the entry contains an invalid directory, then...
|
||||
# 3a. If the value is the same as last time through here, end dialog.
|
||||
# 3b. If the value is different than last time, save it and return.
|
||||
# 4. If entry contains a valid directory, then...
|
||||
# 4a. If the value is the same as the current directory, end dialog.
|
||||
# 4b. If the value is different from the current directory, change to
|
||||
# that directory.
|
||||
|
||||
set selection [$data(icons) selection get]
|
||||
if {[llength $selection] != 0} {
|
||||
set iconText [$data(icons) get [lindex $selection 0]]
|
||||
set iconText [file join $data(selectPath) $iconText]
|
||||
Done $w $iconText
|
||||
} else {
|
||||
set text [$data(ent) get]
|
||||
if {$text eq ""} {
|
||||
return
|
||||
}
|
||||
set text [file join {*}[file split [string trim $text]]]
|
||||
if {![file exists $text] || ![file isdirectory $text]} {
|
||||
# Entry contains an invalid directory. If it's the same as the
|
||||
# last time they came through here, reset the saved value and end
|
||||
# the dialog. Otherwise, save the value (so we can do this test
|
||||
# next time).
|
||||
if {$text eq $data(previousEntryText)} {
|
||||
set data(previousEntryText) ""
|
||||
Done $w $text
|
||||
} else {
|
||||
set data(previousEntryText) $text
|
||||
}
|
||||
} else {
|
||||
# Entry contains a valid directory. If it is the same as the
|
||||
# current directory, end the dialog. Otherwise, change to that
|
||||
# directory.
|
||||
if {$text eq $data(selectPath)} {
|
||||
Done $w $text
|
||||
} else {
|
||||
set data(selectPath) $text
|
||||
}
|
||||
}
|
||||
}
|
||||
return
|
||||
}
|
||||
|
||||
# Change state of OK button to match -mustexist correctness of entry
|
||||
#
|
||||
proc ::tk::dialog::file::chooseDir::IsOK? {w text} {
|
||||
upvar ::tk::dialog::file::[winfo name $w] data
|
||||
|
||||
set ok [file isdirectory $text]
|
||||
$data(okBtn) configure -state [expr {$ok ? "normal" : "disabled"}]
|
||||
|
||||
# always return 1
|
||||
return 1
|
||||
}
|
||||
|
||||
proc ::tk::dialog::file::chooseDir::DblClick {w} {
|
||||
upvar ::tk::dialog::file::[winfo name $w] data
|
||||
set selection [$data(icons) selection get]
|
||||
if {[llength $selection] != 0} {
|
||||
set filenameFragment [$data(icons) get [lindex $selection 0]]
|
||||
set file $data(selectPath)
|
||||
if {[file isdirectory $file]} {
|
||||
::tk::dialog::file::ListInvoke $w [list $filenameFragment]
|
||||
return
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Gets called when user browses the IconList widget (dragging mouse, arrow
|
||||
# keys, etc)
|
||||
#
|
||||
proc ::tk::dialog::file::chooseDir::ListBrowse {w text} {
|
||||
upvar ::tk::dialog::file::[winfo name $w] data
|
||||
|
||||
if {$text eq ""} {
|
||||
return
|
||||
}
|
||||
|
||||
set file [::tk::dialog::file::JoinFile $data(selectPath) $text]
|
||||
$data(ent) delete 0 end
|
||||
$data(ent) insert 0 $file
|
||||
}
|
||||
|
||||
# ::tk::dialog::file::chooseDir::Done --
|
||||
#
|
||||
# Gets called when user has input a valid filename. Pops up a
|
||||
# dialog box to confirm selection when necessary. Sets the
|
||||
# Priv(selectFilePath) variable, which will break the "vwait"
|
||||
# loop in tk_chooseDirectory and return the selected filename to the
|
||||
# script that calls tk_getOpenFile or tk_getSaveFile
|
||||
#
|
||||
proc ::tk::dialog::file::chooseDir::Done {w {selectFilePath ""}} {
|
||||
upvar ::tk::dialog::file::[winfo name $w] data
|
||||
variable ::tk::Priv
|
||||
|
||||
if {$selectFilePath eq ""} {
|
||||
set selectFilePath $data(selectPath)
|
||||
}
|
||||
if {$data(-mustexist) && ![file isdirectory $selectFilePath]} {
|
||||
return
|
||||
}
|
||||
set Priv(selectFilePath) $selectFilePath
|
||||
}
|
||||
|
|
@ -0,0 +1,695 @@
|
|||
# clrpick.tcl --
|
||||
#
|
||||
# Color selection dialog for platforms that do not support a
|
||||
# standard color selection dialog.
|
||||
#
|
||||
# Copyright (c) 1996 Sun Microsystems, Inc.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
# ToDo:
|
||||
#
|
||||
# (1): Find out how many free colors are left in the colormap and
|
||||
# don't allocate too many colors.
|
||||
# (2): Implement HSV color selection.
|
||||
#
|
||||
|
||||
# Make sure namespaces exist
|
||||
namespace eval ::tk {}
|
||||
namespace eval ::tk::dialog {}
|
||||
namespace eval ::tk::dialog::color {
|
||||
namespace import ::tk::msgcat::*
|
||||
}
|
||||
|
||||
# ::tk::dialog::color:: --
|
||||
#
|
||||
# Create a color dialog and let the user choose a color. This function
|
||||
# should not be called directly. It is called by the tk_chooseColor
|
||||
# function when a native color selector widget does not exist
|
||||
#
|
||||
proc ::tk::dialog::color:: {args} {
|
||||
variable ::tk::Priv
|
||||
set dataName __tk__color
|
||||
upvar ::tk::dialog::color::$dataName data
|
||||
set w .$dataName
|
||||
|
||||
# The lines variables track the start and end indices of the line
|
||||
# elements in the colorbar canvases.
|
||||
set data(lines,red,start) 0
|
||||
set data(lines,red,last) -1
|
||||
set data(lines,green,start) 0
|
||||
set data(lines,green,last) -1
|
||||
set data(lines,blue,start) 0
|
||||
set data(lines,blue,last) -1
|
||||
|
||||
# This is the actual number of lines that are drawn in each color strip.
|
||||
# Note that the bars may be of any width.
|
||||
# However, NUM_COLORBARS must be a number that evenly divides 256.
|
||||
# Such as 256, 128, 64, etc.
|
||||
set data(NUM_COLORBARS) 16
|
||||
|
||||
# BARS_WIDTH is the number of pixels wide the color bar portion of the
|
||||
# canvas is. This number must be a multiple of NUM_COLORBARS
|
||||
set data(BARS_WIDTH) 160
|
||||
|
||||
# PLGN_WIDTH is the number of pixels wide of the triangular selection
|
||||
# polygon. This also results in the definition of the padding on the
|
||||
# left and right sides which is half of PLGN_WIDTH. Make this number even.
|
||||
set data(PLGN_HEIGHT) 10
|
||||
|
||||
# PLGN_HEIGHT is the height of the selection polygon and the height of the
|
||||
# selection rectangle at the bottom of the color bar. No restrictions.
|
||||
set data(PLGN_WIDTH) 10
|
||||
|
||||
Config $dataName $args
|
||||
InitValues $dataName
|
||||
|
||||
set sc [winfo screen $data(-parent)]
|
||||
set winExists [winfo exists $w]
|
||||
if {!$winExists || $sc ne [winfo screen $w]} {
|
||||
if {$winExists} {
|
||||
destroy $w
|
||||
}
|
||||
toplevel $w -class TkColorDialog -screen $sc
|
||||
if {[tk windowingsystem] eq "x11"} {wm attributes $w -type dialog}
|
||||
BuildDialog $w
|
||||
}
|
||||
|
||||
# Dialog boxes should be transient with respect to their parent,
|
||||
# so that they will always stay on top of their parent window. However,
|
||||
# some window managers will create the window as withdrawn if the parent
|
||||
# window is withdrawn or iconified. Combined with the grab we put on the
|
||||
# window, this can hang the entire application. Therefore we only make
|
||||
# the dialog transient if the parent is viewable.
|
||||
|
||||
if {[winfo viewable [winfo toplevel $data(-parent)]] } {
|
||||
wm transient $w $data(-parent)
|
||||
}
|
||||
|
||||
# 5. Withdraw the window, then update all the geometry information
|
||||
# so we know how big it wants to be, then center the window in the
|
||||
# display (Motif style) and de-iconify it.
|
||||
|
||||
::tk::PlaceWindow $w widget $data(-parent)
|
||||
wm title $w $data(-title)
|
||||
|
||||
# 6. Set a grab and claim the focus too.
|
||||
|
||||
::tk::SetFocusGrab $w $data(okBtn)
|
||||
|
||||
# 7. Wait for the user to respond, then restore the focus and
|
||||
# return the index of the selected button. Restore the focus
|
||||
# before deleting the window, since otherwise the window manager
|
||||
# may take the focus away so we can't redirect it. Finally,
|
||||
# restore any grab that was in effect.
|
||||
|
||||
vwait ::tk::Priv(selectColor)
|
||||
set result $Priv(selectColor)
|
||||
::tk::RestoreFocusGrab $w $data(okBtn)
|
||||
unset data
|
||||
|
||||
return $result
|
||||
}
|
||||
|
||||
# ::tk::dialog::color::InitValues --
|
||||
#
|
||||
# Get called during initialization or when user resets NUM_COLORBARS
|
||||
#
|
||||
proc ::tk::dialog::color::InitValues {dataName} {
|
||||
upvar ::tk::dialog::color::$dataName data
|
||||
|
||||
# IntensityIncr is the difference in color intensity between a colorbar
|
||||
# and its neighbors.
|
||||
set data(intensityIncr) [expr {256 / $data(NUM_COLORBARS)}]
|
||||
|
||||
# ColorbarWidth is the width of each colorbar
|
||||
set data(colorbarWidth) [expr {$data(BARS_WIDTH) / $data(NUM_COLORBARS)}]
|
||||
|
||||
# Indent is the width of the space at the left and right side of the
|
||||
# colorbar. It is always half the selector polygon width, because the
|
||||
# polygon extends into the space.
|
||||
set data(indent) [expr {$data(PLGN_WIDTH) / 2}]
|
||||
|
||||
set data(colorPad) 2
|
||||
set data(selPad) [expr {$data(PLGN_WIDTH) / 2}]
|
||||
|
||||
#
|
||||
# minX is the x coordinate of the first colorbar
|
||||
#
|
||||
set data(minX) $data(indent)
|
||||
|
||||
#
|
||||
# maxX is the x coordinate of the last colorbar
|
||||
#
|
||||
set data(maxX) [expr {$data(BARS_WIDTH) + $data(indent)-1}]
|
||||
|
||||
#
|
||||
# canvasWidth is the width of the entire canvas, including the indents
|
||||
#
|
||||
set data(canvasWidth) [expr {$data(BARS_WIDTH) + $data(PLGN_WIDTH)}]
|
||||
|
||||
# Set the initial color, specified by -initialcolor, or the
|
||||
# color chosen by the user the last time.
|
||||
set data(selection) $data(-initialcolor)
|
||||
set data(finalColor) $data(-initialcolor)
|
||||
set rgb [winfo rgb . $data(selection)]
|
||||
|
||||
set data(red,intensity) [expr {[lindex $rgb 0]/0x100}]
|
||||
set data(green,intensity) [expr {[lindex $rgb 1]/0x100}]
|
||||
set data(blue,intensity) [expr {[lindex $rgb 2]/0x100}]
|
||||
}
|
||||
|
||||
# ::tk::dialog::color::Config --
|
||||
#
|
||||
# Parses the command line arguments to tk_chooseColor
|
||||
#
|
||||
proc ::tk::dialog::color::Config {dataName argList} {
|
||||
variable ::tk::Priv
|
||||
upvar ::tk::dialog::color::$dataName data
|
||||
|
||||
# 1: the configuration specs
|
||||
#
|
||||
if {[info exists Priv(selectColor)] && $Priv(selectColor) ne ""} {
|
||||
set defaultColor $Priv(selectColor)
|
||||
} else {
|
||||
set defaultColor [. cget -background]
|
||||
}
|
||||
|
||||
set specs [list \
|
||||
[list -initialcolor "" "" $defaultColor] \
|
||||
[list -parent "" "" "."] \
|
||||
[list -title "" "" [mc "Color"]] \
|
||||
]
|
||||
|
||||
# 2: parse the arguments
|
||||
#
|
||||
tclParseConfigSpec ::tk::dialog::color::$dataName $specs "" $argList
|
||||
|
||||
if {$data(-title) eq ""} {
|
||||
set data(-title) " "
|
||||
}
|
||||
if {[catch {winfo rgb . $data(-initialcolor)} err]} {
|
||||
return -code error -errorcode [list TK LOOKUP COLOR $data(-initialcolor)] \
|
||||
$err
|
||||
}
|
||||
|
||||
if {![winfo exists $data(-parent)]} {
|
||||
return -code error -errorcode [list TK LOOKUP WINDOW $data(-parent)] \
|
||||
"bad window path name \"$data(-parent)\""
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::dialog::color::BuildDialog --
|
||||
#
|
||||
# Build the dialog.
|
||||
#
|
||||
proc ::tk::dialog::color::BuildDialog {w} {
|
||||
upvar ::tk::dialog::color::[winfo name $w] data
|
||||
|
||||
# TopFrame contains the color strips and the color selection
|
||||
#
|
||||
set topFrame [frame $w.top -relief raised -bd 1]
|
||||
|
||||
# StripsFrame contains the colorstrips and the individual RGB entries
|
||||
set stripsFrame [frame $topFrame.colorStrip]
|
||||
|
||||
set maxWidth [::tk::mcmaxamp &Red &Green &Blue]
|
||||
set maxWidth [expr {$maxWidth<6 ? 6 : $maxWidth}]
|
||||
set colorList {
|
||||
red "&Red"
|
||||
green "&Green"
|
||||
blue "&Blue"
|
||||
}
|
||||
foreach {color l} $colorList {
|
||||
# each f frame contains an [R|G|B] entry and the equiv. color strip.
|
||||
set f [frame $stripsFrame.$color]
|
||||
|
||||
# The box frame contains the label and entry widget for an [R|G|B]
|
||||
set box [frame $f.box]
|
||||
|
||||
::tk::AmpWidget label $box.label -text "[mc $l]:" \
|
||||
-width $maxWidth -anchor ne
|
||||
bind $box.label <<AltUnderlined>> [list focus $box.entry]
|
||||
|
||||
entry $box.entry -textvariable \
|
||||
::tk::dialog::color::[winfo name $w]($color,intensity) \
|
||||
-width 4
|
||||
pack $box.label -side left -fill y -padx 2 -pady 3
|
||||
pack $box.entry -side left -anchor n -pady 0
|
||||
pack $box -side left -fill both
|
||||
|
||||
set height [expr {
|
||||
[winfo reqheight $box.entry] -
|
||||
2*([$box.entry cget -highlightthickness] + [$box.entry cget -bd])
|
||||
}]
|
||||
|
||||
canvas $f.color -height $height \
|
||||
-width $data(BARS_WIDTH) -relief sunken -bd 2
|
||||
canvas $f.sel -height $data(PLGN_HEIGHT) \
|
||||
-width $data(canvasWidth) -highlightthickness 0
|
||||
pack $f.color -expand yes -fill both
|
||||
pack $f.sel -expand yes -fill both
|
||||
|
||||
pack $f -side top -fill x -padx 0 -pady 2
|
||||
|
||||
set data($color,entry) $box.entry
|
||||
set data($color,col) $f.color
|
||||
set data($color,sel) $f.sel
|
||||
|
||||
bind $data($color,col) <Configure> \
|
||||
[list tk::dialog::color::DrawColorScale $w $color 1]
|
||||
bind $data($color,col) <Enter> \
|
||||
[list tk::dialog::color::EnterColorBar $w $color]
|
||||
bind $data($color,col) <Leave> \
|
||||
[list tk::dialog::color::LeaveColorBar $w $color]
|
||||
|
||||
bind $data($color,sel) <Enter> \
|
||||
[list tk::dialog::color::EnterColorBar $w $color]
|
||||
bind $data($color,sel) <Leave> \
|
||||
[list tk::dialog::color::LeaveColorBar $w $color]
|
||||
|
||||
bind $box.entry <Return> [list tk::dialog::color::HandleRGBEntry $w]
|
||||
}
|
||||
|
||||
pack $stripsFrame -side left -fill both -padx 4 -pady 10
|
||||
|
||||
# The selFrame contains a frame that demonstrates the currently
|
||||
# selected color
|
||||
#
|
||||
set selFrame [frame $topFrame.sel]
|
||||
set lab [::tk::AmpWidget label $selFrame.lab \
|
||||
-text [mc "&Selection:"] -anchor sw]
|
||||
set ent [entry $selFrame.ent \
|
||||
-textvariable ::tk::dialog::color::[winfo name $w](selection) \
|
||||
-width 16]
|
||||
set f1 [frame $selFrame.f1 -relief sunken -bd 2]
|
||||
set data(finalCanvas) [frame $f1.demo -bd 0 -width 100 -height 70]
|
||||
|
||||
pack $lab $ent -side top -fill x -padx 4 -pady 2
|
||||
pack $f1 -expand yes -anchor nw -fill both -padx 6 -pady 10
|
||||
pack $data(finalCanvas) -expand yes -fill both
|
||||
|
||||
bind $ent <Return> [list tk::dialog::color::HandleSelEntry $w]
|
||||
|
||||
pack $selFrame -side left -fill none -anchor nw
|
||||
pack $topFrame -side top -expand yes -fill both -anchor nw
|
||||
|
||||
# the botFrame frame contains the buttons
|
||||
#
|
||||
set botFrame [frame $w.bot -relief raised -bd 1]
|
||||
|
||||
::tk::AmpWidget button $botFrame.ok -text [mc "&OK"] \
|
||||
-command [list tk::dialog::color::OkCmd $w]
|
||||
::tk::AmpWidget button $botFrame.cancel -text [mc "&Cancel"] \
|
||||
-command [list tk::dialog::color::CancelCmd $w]
|
||||
|
||||
set data(okBtn) $botFrame.ok
|
||||
set data(cancelBtn) $botFrame.cancel
|
||||
|
||||
grid x $botFrame.ok x $botFrame.cancel x -sticky ew
|
||||
grid configure $botFrame.ok $botFrame.cancel -padx 10 -pady 10
|
||||
grid columnconfigure $botFrame {0 4} -weight 1 -uniform space
|
||||
grid columnconfigure $botFrame {1 3} -weight 1 -uniform button
|
||||
grid columnconfigure $botFrame 2 -weight 2 -uniform space
|
||||
pack $botFrame -side bottom -fill x
|
||||
|
||||
# Accelerator bindings
|
||||
bind $lab <<AltUnderlined>> [list focus $ent]
|
||||
bind $w <KeyPress-Escape> [list tk::ButtonInvoke $data(cancelBtn)]
|
||||
bind $w <Alt-Key> [list tk::AltKeyInDialog $w %A]
|
||||
|
||||
wm protocol $w WM_DELETE_WINDOW [list tk::dialog::color::CancelCmd $w]
|
||||
bind $lab <Destroy> [list tk::dialog::color::CancelCmd $w]
|
||||
}
|
||||
|
||||
# ::tk::dialog::color::SetRGBValue --
|
||||
#
|
||||
# Sets the current selection of the dialog box
|
||||
#
|
||||
proc ::tk::dialog::color::SetRGBValue {w color} {
|
||||
upvar ::tk::dialog::color::[winfo name $w] data
|
||||
|
||||
set data(red,intensity) [lindex $color 0]
|
||||
set data(green,intensity) [lindex $color 1]
|
||||
set data(blue,intensity) [lindex $color 2]
|
||||
|
||||
RedrawColorBars $w all
|
||||
|
||||
# Now compute the new x value of each colorbars pointer polygon
|
||||
foreach color {red green blue} {
|
||||
set x [RgbToX $w $data($color,intensity)]
|
||||
MoveSelector $w $data($color,sel) $color $x 0
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::dialog::color::XToRgb --
|
||||
#
|
||||
# Converts a screen coordinate to intensity
|
||||
#
|
||||
proc ::tk::dialog::color::XToRgb {w x} {
|
||||
upvar ::tk::dialog::color::[winfo name $w] data
|
||||
|
||||
set x [expr {($x * $data(intensityIncr))/ $data(colorbarWidth)}]
|
||||
if {$x > 255} {
|
||||
set x 255
|
||||
}
|
||||
return $x
|
||||
}
|
||||
|
||||
# ::tk::dialog::color::RgbToX
|
||||
#
|
||||
# Converts an intensity to screen coordinate.
|
||||
#
|
||||
proc ::tk::dialog::color::RgbToX {w color} {
|
||||
upvar ::tk::dialog::color::[winfo name $w] data
|
||||
|
||||
return [expr {($color * $data(colorbarWidth)/ $data(intensityIncr))}]
|
||||
}
|
||||
|
||||
# ::tk::dialog::color::DrawColorScale --
|
||||
#
|
||||
# Draw color scale is called whenever the size of one of the color
|
||||
# scale canvases is changed.
|
||||
#
|
||||
proc ::tk::dialog::color::DrawColorScale {w c {create 0}} {
|
||||
upvar ::tk::dialog::color::[winfo name $w] data
|
||||
|
||||
# col: color bar canvas
|
||||
# sel: selector canvas
|
||||
set col $data($c,col)
|
||||
set sel $data($c,sel)
|
||||
|
||||
# First handle the case that we are creating everything for the first time.
|
||||
if {$create} {
|
||||
# First remove all the lines that already exist.
|
||||
if { $data(lines,$c,last) > $data(lines,$c,start)} {
|
||||
for {set i $data(lines,$c,start)} \
|
||||
{$i <= $data(lines,$c,last)} {incr i} {
|
||||
$sel delete $i
|
||||
}
|
||||
}
|
||||
# Delete the selector if it exists
|
||||
if {[info exists data($c,index)]} {
|
||||
$sel delete $data($c,index)
|
||||
}
|
||||
|
||||
# Draw the selection polygons
|
||||
CreateSelector $w $sel $c
|
||||
$sel bind $data($c,index) <Button-1> \
|
||||
[list tk::dialog::color::StartMove $w $sel $c %x $data(selPad) 1]
|
||||
$sel bind $data($c,index) <B1-Motion> \
|
||||
[list tk::dialog::color::MoveSelector $w $sel $c %x $data(selPad)]
|
||||
$sel bind $data($c,index) <ButtonRelease-1> \
|
||||
[list tk::dialog::color::ReleaseMouse $w $sel $c %x $data(selPad)]
|
||||
|
||||
set height [winfo height $col]
|
||||
# Create an invisible region under the colorstrip to catch mouse clicks
|
||||
# that aren't on the selector.
|
||||
set data($c,clickRegion) [$sel create rectangle 0 0 \
|
||||
$data(canvasWidth) $height -fill {} -outline {}]
|
||||
|
||||
bind $col <Button-1> \
|
||||
[list tk::dialog::color::StartMove $w $sel $c %x $data(colorPad)]
|
||||
bind $col <B1-Motion> \
|
||||
[list tk::dialog::color::MoveSelector $w $sel $c %x $data(colorPad)]
|
||||
bind $col <ButtonRelease-1> \
|
||||
[list tk::dialog::color::ReleaseMouse $w $sel $c %x $data(colorPad)]
|
||||
|
||||
$sel bind $data($c,clickRegion) <Button-1> \
|
||||
[list tk::dialog::color::StartMove $w $sel $c %x $data(selPad)]
|
||||
$sel bind $data($c,clickRegion) <B1-Motion> \
|
||||
[list tk::dialog::color::MoveSelector $w $sel $c %x $data(selPad)]
|
||||
$sel bind $data($c,clickRegion) <ButtonRelease-1> \
|
||||
[list tk::dialog::color::ReleaseMouse $w $sel $c %x $data(selPad)]
|
||||
} else {
|
||||
# l is the canvas index of the first colorbar.
|
||||
set l $data(lines,$c,start)
|
||||
}
|
||||
|
||||
# Draw the color bars.
|
||||
set highlightW [expr {[$col cget -highlightthickness] + [$col cget -bd]}]
|
||||
for {set i 0} { $i < $data(NUM_COLORBARS)} { incr i} {
|
||||
set intensity [expr {$i * $data(intensityIncr)}]
|
||||
set startx [expr {$i * $data(colorbarWidth) + $highlightW}]
|
||||
if {$c eq "red"} {
|
||||
set color [format "#%02x%02x%02x" \
|
||||
$intensity $data(green,intensity) $data(blue,intensity)]
|
||||
} elseif {$c eq "green"} {
|
||||
set color [format "#%02x%02x%02x" \
|
||||
$data(red,intensity) $intensity $data(blue,intensity)]
|
||||
} else {
|
||||
set color [format "#%02x%02x%02x" \
|
||||
$data(red,intensity) $data(green,intensity) $intensity]
|
||||
}
|
||||
|
||||
if {$create} {
|
||||
set index [$col create rect $startx $highlightW \
|
||||
[expr {$startx +$data(colorbarWidth)}] \
|
||||
[expr {[winfo height $col] + $highlightW}] \
|
||||
-fill $color -outline $color]
|
||||
} else {
|
||||
$col itemconfigure $l -fill $color -outline $color
|
||||
incr l
|
||||
}
|
||||
}
|
||||
$sel raise $data($c,index)
|
||||
|
||||
if {$create} {
|
||||
set data(lines,$c,last) $index
|
||||
set data(lines,$c,start) [expr {$index - $data(NUM_COLORBARS) + 1}]
|
||||
}
|
||||
|
||||
RedrawFinalColor $w
|
||||
}
|
||||
|
||||
# ::tk::dialog::color::CreateSelector --
|
||||
#
|
||||
# Creates and draws the selector polygon at the position
|
||||
# $data($c,intensity).
|
||||
#
|
||||
proc ::tk::dialog::color::CreateSelector {w sel c } {
|
||||
upvar ::tk::dialog::color::[winfo name $w] data
|
||||
set data($c,index) [$sel create polygon \
|
||||
0 $data(PLGN_HEIGHT) \
|
||||
$data(PLGN_WIDTH) $data(PLGN_HEIGHT) \
|
||||
$data(indent) 0]
|
||||
set data($c,x) [RgbToX $w $data($c,intensity)]
|
||||
$sel move $data($c,index) $data($c,x) 0
|
||||
}
|
||||
|
||||
# ::tk::dialog::color::RedrawFinalColor
|
||||
#
|
||||
# Combines the intensities of the three colors into the final color
|
||||
#
|
||||
proc ::tk::dialog::color::RedrawFinalColor {w} {
|
||||
upvar ::tk::dialog::color::[winfo name $w] data
|
||||
|
||||
set color [format "#%02x%02x%02x" $data(red,intensity) \
|
||||
$data(green,intensity) $data(blue,intensity)]
|
||||
|
||||
$data(finalCanvas) configure -bg $color
|
||||
set data(finalColor) $color
|
||||
set data(selection) $color
|
||||
set data(finalRGB) [list \
|
||||
$data(red,intensity) \
|
||||
$data(green,intensity) \
|
||||
$data(blue,intensity)]
|
||||
}
|
||||
|
||||
# ::tk::dialog::color::RedrawColorBars --
|
||||
#
|
||||
# Only redraws the colors on the color strips that were not manipulated.
|
||||
# Params: color of colorstrip that changed. If color is not [red|green|blue]
|
||||
# Then all colorstrips will be updated
|
||||
#
|
||||
proc ::tk::dialog::color::RedrawColorBars {w colorChanged} {
|
||||
upvar ::tk::dialog::color::[winfo name $w] data
|
||||
|
||||
switch $colorChanged {
|
||||
red {
|
||||
DrawColorScale $w green
|
||||
DrawColorScale $w blue
|
||||
}
|
||||
green {
|
||||
DrawColorScale $w red
|
||||
DrawColorScale $w blue
|
||||
}
|
||||
blue {
|
||||
DrawColorScale $w red
|
||||
DrawColorScale $w green
|
||||
}
|
||||
default {
|
||||
DrawColorScale $w red
|
||||
DrawColorScale $w green
|
||||
DrawColorScale $w blue
|
||||
}
|
||||
}
|
||||
RedrawFinalColor $w
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
# Event handlers
|
||||
#----------------------------------------------------------------------
|
||||
|
||||
# ::tk::dialog::color::StartMove --
|
||||
#
|
||||
# Handles a mousedown button event over the selector polygon.
|
||||
# Adds the bindings for moving the mouse while the button is
|
||||
# pressed. Sets the binding for the button-release event.
|
||||
#
|
||||
# Params: sel is the selector canvas window, color is the color of the strip.
|
||||
#
|
||||
proc ::tk::dialog::color::StartMove {w sel color x delta {dontMove 0}} {
|
||||
upvar ::tk::dialog::color::[winfo name $w] data
|
||||
|
||||
if {!$dontMove} {
|
||||
MoveSelector $w $sel $color $x $delta
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::dialog::color::MoveSelector --
|
||||
#
|
||||
# Moves the polygon selector so that its middle point has the same
|
||||
# x value as the specified x. If x is outside the bounds [0,255],
|
||||
# the selector is set to the closest endpoint.
|
||||
#
|
||||
# Params: sel is the selector canvas, c is [red|green|blue]
|
||||
# x is a x-coordinate.
|
||||
#
|
||||
proc ::tk::dialog::color::MoveSelector {w sel color x delta} {
|
||||
upvar ::tk::dialog::color::[winfo name $w] data
|
||||
|
||||
incr x -$delta
|
||||
|
||||
if { $x < 0 } {
|
||||
set x 0
|
||||
} elseif { $x > $data(BARS_WIDTH)} {
|
||||
set x $data(BARS_WIDTH)
|
||||
}
|
||||
set diff [expr {$x - $data($color,x)}]
|
||||
$sel move $data($color,index) $diff 0
|
||||
set data($color,x) [expr {$data($color,x) + $diff}]
|
||||
|
||||
# Return the x value that it was actually set at
|
||||
return $x
|
||||
}
|
||||
|
||||
# ::tk::dialog::color::ReleaseMouse
|
||||
#
|
||||
# Removes mouse tracking bindings, updates the colorbars.
|
||||
#
|
||||
# Params: sel is the selector canvas, color is the color of the strip,
|
||||
# x is the x-coord of the mouse.
|
||||
#
|
||||
proc ::tk::dialog::color::ReleaseMouse {w sel color x delta} {
|
||||
upvar ::tk::dialog::color::[winfo name $w] data
|
||||
|
||||
set x [MoveSelector $w $sel $color $x $delta]
|
||||
|
||||
# Determine exactly what color we are looking at.
|
||||
set data($color,intensity) [XToRgb $w $x]
|
||||
|
||||
RedrawColorBars $w $color
|
||||
}
|
||||
|
||||
# ::tk::dialog::color::ResizeColorbars --
|
||||
#
|
||||
# Completely redraws the colorbars, including resizing the
|
||||
# colorstrips
|
||||
#
|
||||
proc ::tk::dialog::color::ResizeColorBars {w} {
|
||||
upvar ::tk::dialog::color::[winfo name $w] data
|
||||
|
||||
if {
|
||||
($data(BARS_WIDTH) < $data(NUM_COLORBARS)) ||
|
||||
(($data(BARS_WIDTH) % $data(NUM_COLORBARS)) != 0)
|
||||
} then {
|
||||
set data(BARS_WIDTH) $data(NUM_COLORBARS)
|
||||
}
|
||||
InitValues [winfo name $w]
|
||||
foreach color {red green blue} {
|
||||
$data($color,col) configure -width $data(canvasWidth)
|
||||
DrawColorScale $w $color 1
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::dialog::color::HandleSelEntry --
|
||||
#
|
||||
# Handles the return keypress event in the "Selection:" entry
|
||||
#
|
||||
proc ::tk::dialog::color::HandleSelEntry {w} {
|
||||
upvar ::tk::dialog::color::[winfo name $w] data
|
||||
|
||||
set text [string trim $data(selection)]
|
||||
# Check to make sure that the color is valid
|
||||
if {[catch {set color [winfo rgb . $text]} ]} {
|
||||
set data(selection) $data(finalColor)
|
||||
return
|
||||
}
|
||||
|
||||
set R [expr {[lindex $color 0]/0x100}]
|
||||
set G [expr {[lindex $color 1]/0x100}]
|
||||
set B [expr {[lindex $color 2]/0x100}]
|
||||
|
||||
SetRGBValue $w "$R $G $B"
|
||||
set data(selection) $text
|
||||
}
|
||||
|
||||
# ::tk::dialog::color::HandleRGBEntry --
|
||||
#
|
||||
# Handles the return keypress event in the R, G or B entry
|
||||
#
|
||||
proc ::tk::dialog::color::HandleRGBEntry {w} {
|
||||
upvar ::tk::dialog::color::[winfo name $w] data
|
||||
|
||||
foreach c {red green blue} {
|
||||
if {[catch {
|
||||
set data($c,intensity) [expr {int($data($c,intensity))}]
|
||||
}]} {
|
||||
set data($c,intensity) 0
|
||||
}
|
||||
|
||||
if {$data($c,intensity) < 0} {
|
||||
set data($c,intensity) 0
|
||||
}
|
||||
if {$data($c,intensity) > 255} {
|
||||
set data($c,intensity) 255
|
||||
}
|
||||
}
|
||||
|
||||
SetRGBValue $w "$data(red,intensity) \
|
||||
$data(green,intensity) $data(blue,intensity)"
|
||||
}
|
||||
|
||||
# mouse cursor enters a color bar
|
||||
#
|
||||
proc ::tk::dialog::color::EnterColorBar {w color} {
|
||||
upvar ::tk::dialog::color::[winfo name $w] data
|
||||
|
||||
$data($color,sel) itemconfigure $data($color,index) -fill red
|
||||
}
|
||||
|
||||
# mouse leaves enters a color bar
|
||||
#
|
||||
proc ::tk::dialog::color::LeaveColorBar {w color} {
|
||||
upvar ::tk::dialog::color::[winfo name $w] data
|
||||
|
||||
$data($color,sel) itemconfigure $data($color,index) -fill black
|
||||
}
|
||||
|
||||
# user hits OK button
|
||||
#
|
||||
proc ::tk::dialog::color::OkCmd {w} {
|
||||
variable ::tk::Priv
|
||||
upvar ::tk::dialog::color::[winfo name $w] data
|
||||
|
||||
set Priv(selectColor) $data(finalColor)
|
||||
}
|
||||
|
||||
# user hits Cancel button or destroys window
|
||||
#
|
||||
proc ::tk::dialog::color::CancelCmd {w} {
|
||||
variable ::tk::Priv
|
||||
set Priv(selectColor) ""
|
||||
}
|
||||
|
|
@ -0,0 +1,322 @@
|
|||
# comdlg.tcl --
|
||||
#
|
||||
# Some functions needed for the common dialog boxes. Probably need to go
|
||||
# in a different file.
|
||||
#
|
||||
# Copyright (c) 1996 Sun Microsystems, Inc.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
|
||||
# tclParseConfigSpec --
|
||||
#
|
||||
# Parses a list of "-option value" pairs. If all options and
|
||||
# values are legal, the values are stored in
|
||||
# $data($option). Otherwise an error message is returned. When
|
||||
# an error happens, the data() array may have been partially
|
||||
# modified, but all the modified members of the data(0 array are
|
||||
# guaranteed to have valid values. This is different than
|
||||
# Tk_ConfigureWidget() which does not modify the value of a
|
||||
# widget record if any error occurs.
|
||||
#
|
||||
# Arguments:
|
||||
#
|
||||
# w = widget record to modify. Must be the pathname of a widget.
|
||||
#
|
||||
# specs = {
|
||||
# {-commandlineswitch resourceName ResourceClass defaultValue verifier}
|
||||
# {....}
|
||||
# }
|
||||
#
|
||||
# flags = a list of flags. Currently supported flags are:
|
||||
# DONTSETDEFAULTS = skip default values setting
|
||||
#
|
||||
# argList = The list of "-option value" pairs.
|
||||
#
|
||||
proc tclParseConfigSpec {w specs flags argList} {
|
||||
upvar #0 $w data
|
||||
|
||||
# 1: Put the specs in associative arrays for faster access
|
||||
#
|
||||
foreach spec $specs {
|
||||
if {[llength $spec] < 4} {
|
||||
return -code error -errorcode {TK VALUE CONFIG_SPEC} \
|
||||
"\"spec\" should contain 5 or 4 elements"
|
||||
}
|
||||
set cmdsw [lindex $spec 0]
|
||||
set cmd($cmdsw) ""
|
||||
set rname($cmdsw) [lindex $spec 1]
|
||||
set rclass($cmdsw) [lindex $spec 2]
|
||||
set def($cmdsw) [lindex $spec 3]
|
||||
set verproc($cmdsw) [lindex $spec 4]
|
||||
}
|
||||
|
||||
if {[llength $argList] & 1} {
|
||||
set cmdsw [lindex $argList end]
|
||||
if {![info exists cmd($cmdsw)]} {
|
||||
return -code error -errorcode [list TK LOOKUP OPTION $cmdsw] \
|
||||
"bad option \"$cmdsw\": must be [tclListValidFlags cmd]"
|
||||
}
|
||||
return -code error -errorcode {TK VALUE_MISSING} \
|
||||
"value for \"$cmdsw\" missing"
|
||||
}
|
||||
|
||||
# 2: set the default values
|
||||
#
|
||||
if {"DONTSETDEFAULTS" ni $flags} {
|
||||
foreach cmdsw [array names cmd] {
|
||||
set data($cmdsw) $def($cmdsw)
|
||||
}
|
||||
}
|
||||
|
||||
# 3: parse the argument list
|
||||
#
|
||||
foreach {cmdsw value} $argList {
|
||||
if {![info exists cmd($cmdsw)]} {
|
||||
return -code error -errorcode [list TK LOOKUP OPTION $cmdsw] \
|
||||
"bad option \"$cmdsw\": must be [tclListValidFlags cmd]"
|
||||
}
|
||||
set data($cmdsw) $value
|
||||
}
|
||||
|
||||
# Done!
|
||||
}
|
||||
|
||||
proc tclListValidFlags {v} {
|
||||
upvar $v cmd
|
||||
|
||||
set len [llength [array names cmd]]
|
||||
set i 1
|
||||
set separator ""
|
||||
set errormsg ""
|
||||
foreach cmdsw [lsort [array names cmd]] {
|
||||
append errormsg "$separator$cmdsw"
|
||||
incr i
|
||||
if {$i == $len} {
|
||||
set separator ", or "
|
||||
} else {
|
||||
set separator ", "
|
||||
}
|
||||
}
|
||||
return $errormsg
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
#
|
||||
# Focus Group
|
||||
#
|
||||
# Focus groups are used to handle the user's focusing actions inside a
|
||||
# toplevel.
|
||||
#
|
||||
# One example of using focus groups is: when the user focuses on an
|
||||
# entry, the text in the entry is highlighted and the cursor is put to
|
||||
# the end of the text. When the user changes focus to another widget,
|
||||
# the text in the previously focused entry is validated.
|
||||
#
|
||||
#----------------------------------------------------------------------
|
||||
|
||||
|
||||
# ::tk::FocusGroup_Create --
|
||||
#
|
||||
# Create a focus group. All the widgets in a focus group must be
|
||||
# within the same focus toplevel. Each toplevel can have only
|
||||
# one focus group, which is identified by the name of the
|
||||
# toplevel widget.
|
||||
#
|
||||
proc ::tk::FocusGroup_Create {t} {
|
||||
variable ::tk::Priv
|
||||
if {[winfo toplevel $t] ne $t} {
|
||||
return -code error -errorcode [list TK LOOKUP TOPLEVEL $t] \
|
||||
"$t is not a toplevel window"
|
||||
}
|
||||
if {![info exists Priv(fg,$t)]} {
|
||||
set Priv(fg,$t) 1
|
||||
set Priv(focus,$t) ""
|
||||
bind $t <FocusIn> [list tk::FocusGroup_In $t %W %d]
|
||||
bind $t <FocusOut> [list tk::FocusGroup_Out $t %W %d]
|
||||
bind $t <Destroy> [list tk::FocusGroup_Destroy $t %W]
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::FocusGroup_BindIn --
|
||||
#
|
||||
# Add a widget into the "FocusIn" list of the focus group. The $cmd will be
|
||||
# called when the widget is focused on by the user.
|
||||
#
|
||||
proc ::tk::FocusGroup_BindIn {t w cmd} {
|
||||
variable FocusIn
|
||||
variable ::tk::Priv
|
||||
if {![info exists Priv(fg,$t)]} {
|
||||
return -code error -errorcode [list TK LOOKUP FOCUS_GROUP $t] \
|
||||
"focus group \"$t\" doesn't exist"
|
||||
}
|
||||
set FocusIn($t,$w) $cmd
|
||||
}
|
||||
|
||||
|
||||
# ::tk::FocusGroup_BindOut --
|
||||
#
|
||||
# Add a widget into the "FocusOut" list of the focus group. The
|
||||
# $cmd will be called when the widget loses the focus (User
|
||||
# types Tab or click on another widget).
|
||||
#
|
||||
proc ::tk::FocusGroup_BindOut {t w cmd} {
|
||||
variable FocusOut
|
||||
variable ::tk::Priv
|
||||
if {![info exists Priv(fg,$t)]} {
|
||||
return -code error -errorcode [list TK LOOKUP FOCUS_GROUP $t] \
|
||||
"focus group \"$t\" doesn't exist"
|
||||
}
|
||||
set FocusOut($t,$w) $cmd
|
||||
}
|
||||
|
||||
# ::tk::FocusGroup_Destroy --
|
||||
#
|
||||
# Cleans up when members of the focus group is deleted, or when the
|
||||
# toplevel itself gets deleted.
|
||||
#
|
||||
proc ::tk::FocusGroup_Destroy {t w} {
|
||||
variable FocusIn
|
||||
variable FocusOut
|
||||
variable ::tk::Priv
|
||||
|
||||
if {$t eq $w} {
|
||||
unset Priv(fg,$t)
|
||||
unset Priv(focus,$t)
|
||||
|
||||
foreach name [array names FocusIn $t,*] {
|
||||
unset FocusIn($name)
|
||||
}
|
||||
foreach name [array names FocusOut $t,*] {
|
||||
unset FocusOut($name)
|
||||
}
|
||||
} else {
|
||||
if {[info exists Priv(focus,$t)] && ($Priv(focus,$t) eq $w)} {
|
||||
set Priv(focus,$t) ""
|
||||
}
|
||||
unset -nocomplain FocusIn($t,$w) FocusOut($t,$w)
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::FocusGroup_In --
|
||||
#
|
||||
# Handles the <FocusIn> event. Calls the FocusIn command for the newly
|
||||
# focused widget in the focus group.
|
||||
#
|
||||
proc ::tk::FocusGroup_In {t w detail} {
|
||||
variable FocusIn
|
||||
variable ::tk::Priv
|
||||
|
||||
if {$detail ne "NotifyNonlinear" && $detail ne "NotifyNonlinearVirtual"} {
|
||||
# This is caused by mouse moving out&in of the window *or*
|
||||
# ordinary keypresses some window managers (ie: CDE [Bug: 2960]).
|
||||
return
|
||||
}
|
||||
if {![info exists FocusIn($t,$w)]} {
|
||||
set FocusIn($t,$w) ""
|
||||
return
|
||||
}
|
||||
if {![info exists Priv(focus,$t)]} {
|
||||
return
|
||||
}
|
||||
if {$Priv(focus,$t) eq $w} {
|
||||
# This is already in focus
|
||||
#
|
||||
return
|
||||
} else {
|
||||
set Priv(focus,$t) $w
|
||||
eval $FocusIn($t,$w)
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::FocusGroup_Out --
|
||||
#
|
||||
# Handles the <FocusOut> event. Checks if this is really a lose
|
||||
# focus event, not one generated by the mouse moving out of the
|
||||
# toplevel window. Calls the FocusOut command for the widget
|
||||
# who loses its focus.
|
||||
#
|
||||
proc ::tk::FocusGroup_Out {t w detail} {
|
||||
variable FocusOut
|
||||
variable ::tk::Priv
|
||||
|
||||
if {$detail ne "NotifyNonlinear" && $detail ne "NotifyNonlinearVirtual"} {
|
||||
# This is caused by mouse moving out of the window
|
||||
return
|
||||
}
|
||||
if {![info exists Priv(focus,$t)]} {
|
||||
return
|
||||
}
|
||||
if {![info exists FocusOut($t,$w)]} {
|
||||
return
|
||||
} else {
|
||||
eval $FocusOut($t,$w)
|
||||
set Priv(focus,$t) ""
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::FDGetFileTypes --
|
||||
#
|
||||
# Process the string given by the -filetypes option of the file
|
||||
# dialogs. Similar to the C function TkGetFileFilters() on the Mac
|
||||
# and Windows platform.
|
||||
#
|
||||
proc ::tk::FDGetFileTypes {string} {
|
||||
foreach t $string {
|
||||
if {[llength $t] < 2 || [llength $t] > 3} {
|
||||
return -code error -errorcode {TK VALUE FILE_TYPE} \
|
||||
"bad file type \"$t\", should be \"typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?\""
|
||||
}
|
||||
lappend fileTypes([lindex $t 0]) {*}[lindex $t 1]
|
||||
}
|
||||
|
||||
set types {}
|
||||
foreach t $string {
|
||||
set label [lindex $t 0]
|
||||
set exts {}
|
||||
|
||||
if {[info exists hasDoneType($label)]} {
|
||||
continue
|
||||
}
|
||||
|
||||
# Validate each macType. This is to agree with the
|
||||
# behaviour of TkGetFileFilters(). This list may be
|
||||
# empty.
|
||||
foreach macType [lindex $t 2] {
|
||||
if {[string length $macType] != 4} {
|
||||
return -code error -errorcode {TK VALUE MAC_TYPE} \
|
||||
"bad Macintosh file type \"$macType\""
|
||||
}
|
||||
}
|
||||
|
||||
set name "$label \("
|
||||
set sep ""
|
||||
set doAppend 1
|
||||
foreach ext $fileTypes($label) {
|
||||
if {$ext eq ""} {
|
||||
continue
|
||||
}
|
||||
regsub {^[.]} $ext "*." ext
|
||||
if {![info exists hasGotExt($label,$ext)]} {
|
||||
if {$doAppend} {
|
||||
if {[string length $sep] && [string length $name]>40} {
|
||||
set doAppend 0
|
||||
append name $sep...
|
||||
} else {
|
||||
append name $sep$ext
|
||||
}
|
||||
}
|
||||
lappend exts $ext
|
||||
set hasGotExt($label,$ext) 1
|
||||
}
|
||||
set sep ","
|
||||
}
|
||||
append name "\)"
|
||||
lappend types [list $name $exts]
|
||||
|
||||
set hasDoneType($label) 1
|
||||
}
|
||||
|
||||
return $types
|
||||
}
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,175 @@
|
|||
# dialog.tcl --
|
||||
#
|
||||
# This file defines the procedure tk_dialog, which creates a dialog
|
||||
# box containing a bitmap, a message, and one or more buttons.
|
||||
#
|
||||
# Copyright (c) 1992-1993 The Regents of the University of California.
|
||||
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
|
||||
#
|
||||
# ::tk_dialog:
|
||||
#
|
||||
# This procedure displays a dialog box, waits for a button in the dialog
|
||||
# to be invoked, then returns the index of the selected button. If the
|
||||
# dialog somehow gets destroyed, -1 is returned.
|
||||
#
|
||||
# Arguments:
|
||||
# w - Window to use for dialog top-level.
|
||||
# title - Title to display in dialog's decorative frame.
|
||||
# text - Message to display in dialog.
|
||||
# bitmap - Bitmap to display in dialog (empty string means none).
|
||||
# default - Index of button that is to display the default ring
|
||||
# (-1 means none).
|
||||
# args - One or more strings to display in buttons across the
|
||||
# bottom of the dialog box.
|
||||
|
||||
proc ::tk_dialog {w title text bitmap default args} {
|
||||
variable ::tk::Priv
|
||||
|
||||
# Check that $default was properly given
|
||||
if {[string is integer -strict $default]} {
|
||||
if {$default >= [llength $args]} {
|
||||
return -code error -errorcode {TK DIALOG BAD_DEFAULT} \
|
||||
"default button index greater than number of buttons\
|
||||
specified for tk_dialog"
|
||||
}
|
||||
} elseif {"" eq $default} {
|
||||
set default -1
|
||||
} else {
|
||||
set default [lsearch -exact $args $default]
|
||||
}
|
||||
|
||||
set windowingsystem [tk windowingsystem]
|
||||
|
||||
# 1. Create the top-level window and divide it into top
|
||||
# and bottom parts.
|
||||
|
||||
destroy $w
|
||||
toplevel $w -class Dialog
|
||||
wm title $w $title
|
||||
wm iconname $w Dialog
|
||||
wm protocol $w WM_DELETE_WINDOW { }
|
||||
|
||||
# Dialog boxes should be transient with respect to their parent,
|
||||
# so that they will always stay on top of their parent window. However,
|
||||
# some window managers will create the window as withdrawn if the parent
|
||||
# window is withdrawn or iconified. Combined with the grab we put on the
|
||||
# window, this can hang the entire application. Therefore we only make
|
||||
# the dialog transient if the parent is viewable.
|
||||
#
|
||||
if {[winfo viewable [winfo toplevel [winfo parent $w]]] } {
|
||||
wm transient $w [winfo toplevel [winfo parent $w]]
|
||||
}
|
||||
|
||||
if {$windowingsystem eq "aqua"} {
|
||||
::tk::unsupported::MacWindowStyle style $w moveableModal {}
|
||||
} elseif {$windowingsystem eq "x11"} {
|
||||
wm attributes $w -type dialog
|
||||
}
|
||||
|
||||
frame $w.bot
|
||||
frame $w.top
|
||||
if {$windowingsystem eq "x11"} {
|
||||
$w.bot configure -relief raised -bd 1
|
||||
$w.top configure -relief raised -bd 1
|
||||
}
|
||||
pack $w.bot -side bottom -fill both
|
||||
pack $w.top -side top -fill both -expand 1
|
||||
grid anchor $w.bot center
|
||||
|
||||
# 2. Fill the top part with bitmap and message (use the option
|
||||
# database for -wraplength and -font so that they can be
|
||||
# overridden by the caller).
|
||||
|
||||
option add *Dialog.msg.wrapLength 3i widgetDefault
|
||||
option add *Dialog.msg.font TkCaptionFont widgetDefault
|
||||
|
||||
label $w.msg -justify left -text $text
|
||||
pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
|
||||
if {$bitmap ne ""} {
|
||||
if {$windowingsystem eq "aqua" && $bitmap eq "error"} {
|
||||
set bitmap "stop"
|
||||
}
|
||||
label $w.bitmap -bitmap $bitmap
|
||||
pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m
|
||||
}
|
||||
|
||||
# 3. Create a row of buttons at the bottom of the dialog.
|
||||
|
||||
set i 0
|
||||
foreach but $args {
|
||||
button $w.button$i -text $but -command [list set ::tk::Priv(button) $i]
|
||||
if {$i == $default} {
|
||||
$w.button$i configure -default active
|
||||
} else {
|
||||
$w.button$i configure -default normal
|
||||
}
|
||||
grid $w.button$i -in $w.bot -column $i -row 0 -sticky ew \
|
||||
-padx 10 -pady 4
|
||||
grid columnconfigure $w.bot $i
|
||||
# We boost the size of some Mac buttons for l&f
|
||||
if {$windowingsystem eq "aqua"} {
|
||||
set tmp [string tolower $but]
|
||||
if {$tmp eq "ok" || $tmp eq "cancel"} {
|
||||
grid columnconfigure $w.bot $i -minsize 90
|
||||
}
|
||||
grid configure $w.button$i -pady 7
|
||||
}
|
||||
incr i
|
||||
}
|
||||
|
||||
# 4. Create a binding for <Return> on the dialog if there is a
|
||||
# default button.
|
||||
# Convention also dictates that if the keyboard focus moves among the
|
||||
# the buttons that the <Return> binding affects the button with the focus.
|
||||
|
||||
if {$default >= 0} {
|
||||
bind $w <Return> [list $w.button$default invoke]
|
||||
}
|
||||
bind $w <<PrevWindow>> [list bind $w <Return> {[tk_focusPrev %W] invoke}]
|
||||
bind $w <<NextWindow>> [list bind $w <Return> {[tk_focusNext %W] invoke}]
|
||||
|
||||
# 5. Create a <Destroy> binding for the window that sets the
|
||||
# button variable to -1; this is needed in case something happens
|
||||
# that destroys the window, such as its parent window being destroyed.
|
||||
|
||||
bind $w <Destroy> {set ::tk::Priv(button) -1}
|
||||
|
||||
# 6. Withdraw the window, then update all the geometry information
|
||||
# so we know how big it wants to be, then center the window in the
|
||||
# display (Motif style) and de-iconify it.
|
||||
|
||||
::tk::PlaceWindow $w
|
||||
tkwait visibility $w
|
||||
|
||||
# 7. Set a grab and claim the focus too.
|
||||
|
||||
if {$default >= 0} {
|
||||
set focus $w.button$default
|
||||
} else {
|
||||
set focus $w
|
||||
}
|
||||
tk::SetFocusGrab $w $focus
|
||||
|
||||
# 8. Wait for the user to respond, then restore the focus and
|
||||
# return the index of the selected button. Restore the focus
|
||||
# before deleting the window, since otherwise the window manager
|
||||
# may take the focus away so we can't redirect it. Finally,
|
||||
# restore any grab that was in effect.
|
||||
|
||||
vwait ::tk::Priv(button)
|
||||
|
||||
catch {
|
||||
# It's possible that the window has already been destroyed,
|
||||
# hence this "catch". Delete the Destroy handler so that
|
||||
# Priv(button) doesn't get reset by it.
|
||||
|
||||
bind $w <Destroy> {}
|
||||
}
|
||||
tk::RestoreFocusGrab $w $focus
|
||||
return $Priv(button)
|
||||
}
|
||||
|
|
@ -0,0 +1,686 @@
|
|||
# entry.tcl --
|
||||
#
|
||||
# This file defines the default bindings for Tk entry widgets and provides
|
||||
# procedures that help in implementing those bindings.
|
||||
#
|
||||
# Copyright (c) 1992-1994 The Regents of the University of California.
|
||||
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
|
||||
#-------------------------------------------------------------------------
|
||||
# Elements of tk::Priv that are used in this file:
|
||||
#
|
||||
# afterId - If non-null, it means that auto-scanning is underway
|
||||
# and it gives the "after" id for the next auto-scan
|
||||
# command to be executed.
|
||||
# mouseMoved - Non-zero means the mouse has moved a significant
|
||||
# amount since the button went down (so, for example,
|
||||
# start dragging out a selection).
|
||||
# pressX - X-coordinate at which the mouse button was pressed.
|
||||
# selectMode - The style of selection currently underway:
|
||||
# char, word, or line.
|
||||
# x, y - Last known mouse coordinates for scanning
|
||||
# and auto-scanning.
|
||||
# data - Used for Cut and Copy
|
||||
#-------------------------------------------------------------------------
|
||||
|
||||
#-------------------------------------------------------------------------
|
||||
# The code below creates the default class bindings for entries.
|
||||
#-------------------------------------------------------------------------
|
||||
bind Entry <<Cut>> {
|
||||
if {![catch {tk::EntryGetSelection %W} tk::Priv(data)]} {
|
||||
clipboard clear -displayof %W
|
||||
clipboard append -displayof %W $tk::Priv(data)
|
||||
%W delete sel.first sel.last
|
||||
unset tk::Priv(data)
|
||||
}
|
||||
}
|
||||
bind Entry <<Copy>> {
|
||||
if {![catch {tk::EntryGetSelection %W} tk::Priv(data)]} {
|
||||
clipboard clear -displayof %W
|
||||
clipboard append -displayof %W $tk::Priv(data)
|
||||
unset tk::Priv(data)
|
||||
}
|
||||
}
|
||||
bind Entry <<Paste>> {
|
||||
catch {
|
||||
if {[tk windowingsystem] ne "x11"} {
|
||||
catch {
|
||||
%W delete sel.first sel.last
|
||||
}
|
||||
}
|
||||
%W insert insert [::tk::GetSelection %W CLIPBOARD]
|
||||
tk::EntrySeeInsert %W
|
||||
}
|
||||
}
|
||||
bind Entry <<Clear>> {
|
||||
# ignore if there is no selection
|
||||
catch {%W delete sel.first sel.last}
|
||||
}
|
||||
bind Entry <<PasteSelection>> {
|
||||
if {$tk_strictMotif || ![info exists tk::Priv(mouseMoved)]
|
||||
|| !$tk::Priv(mouseMoved)} {
|
||||
tk::EntryPaste %W %x
|
||||
}
|
||||
}
|
||||
|
||||
bind Entry <<TraverseIn>> {
|
||||
%W selection range 0 end
|
||||
%W icursor end
|
||||
}
|
||||
|
||||
# Standard Motif bindings:
|
||||
|
||||
bind Entry <Button-1> {
|
||||
tk::EntryButton1 %W %x
|
||||
%W selection clear
|
||||
}
|
||||
bind Entry <B1-Motion> {
|
||||
set tk::Priv(x) %x
|
||||
tk::EntryMouseSelect %W %x
|
||||
}
|
||||
bind Entry <Double-Button-1> {
|
||||
set tk::Priv(selectMode) word
|
||||
tk::EntryMouseSelect %W %x
|
||||
catch {%W icursor sel.last}
|
||||
}
|
||||
bind Entry <Triple-Button-1> {
|
||||
set tk::Priv(selectMode) line
|
||||
tk::EntryMouseSelect %W %x
|
||||
catch {%W icursor sel.last}
|
||||
}
|
||||
bind Entry <Shift-Button-1> {
|
||||
set tk::Priv(selectMode) char
|
||||
%W selection adjust @%x
|
||||
}
|
||||
bind Entry <Double-Shift-Button-1> {
|
||||
set tk::Priv(selectMode) word
|
||||
tk::EntryMouseSelect %W %x
|
||||
}
|
||||
bind Entry <Triple-Shift-Button-1> {
|
||||
set tk::Priv(selectMode) line
|
||||
tk::EntryMouseSelect %W %x
|
||||
}
|
||||
bind Entry <B1-Leave> {
|
||||
set tk::Priv(x) %x
|
||||
tk::EntryAutoScan %W
|
||||
}
|
||||
bind Entry <B1-Enter> {
|
||||
tk::CancelRepeat
|
||||
}
|
||||
bind Entry <ButtonRelease-1> {
|
||||
tk::CancelRepeat
|
||||
}
|
||||
bind Entry <Control-Button-1> {
|
||||
%W icursor @%x
|
||||
}
|
||||
|
||||
bind Entry <<PrevChar>> {
|
||||
tk::EntrySetCursor %W [expr {[%W index insert]-1}]
|
||||
}
|
||||
bind Entry <<NextChar>> {
|
||||
tk::EntrySetCursor %W [expr {[%W index insert]+1}]
|
||||
}
|
||||
bind Entry <<SelectPrevChar>> {
|
||||
tk::EntryKeySelect %W [expr {[%W index insert]-1}]
|
||||
tk::EntrySeeInsert %W
|
||||
}
|
||||
bind Entry <<SelectNextChar>> {
|
||||
tk::EntryKeySelect %W [expr {[%W index insert]+1}]
|
||||
tk::EntrySeeInsert %W
|
||||
}
|
||||
bind Entry <<PrevWord>> {
|
||||
tk::EntrySetCursor %W [tk::EntryPreviousWord %W insert]
|
||||
}
|
||||
bind Entry <<NextWord>> {
|
||||
tk::EntrySetCursor %W [tk::EntryNextWord %W insert]
|
||||
}
|
||||
bind Entry <<SelectPrevWord>> {
|
||||
tk::EntryKeySelect %W [tk::EntryPreviousWord %W insert]
|
||||
tk::EntrySeeInsert %W
|
||||
}
|
||||
bind Entry <<SelectNextWord>> {
|
||||
tk::EntryKeySelect %W [tk::EntryNextWord %W insert]
|
||||
tk::EntrySeeInsert %W
|
||||
}
|
||||
bind Entry <<LineStart>> {
|
||||
tk::EntrySetCursor %W 0
|
||||
}
|
||||
bind Entry <<SelectLineStart>> {
|
||||
tk::EntryKeySelect %W 0
|
||||
tk::EntrySeeInsert %W
|
||||
}
|
||||
bind Entry <<LineEnd>> {
|
||||
tk::EntrySetCursor %W end
|
||||
}
|
||||
bind Entry <<SelectLineEnd>> {
|
||||
tk::EntryKeySelect %W end
|
||||
tk::EntrySeeInsert %W
|
||||
}
|
||||
|
||||
bind Entry <Delete> {
|
||||
if {[%W selection present]} {
|
||||
%W delete sel.first sel.last
|
||||
} else {
|
||||
%W delete insert
|
||||
}
|
||||
}
|
||||
bind Entry <BackSpace> {
|
||||
tk::EntryBackspace %W
|
||||
}
|
||||
|
||||
bind Entry <Control-space> {
|
||||
%W selection from insert
|
||||
}
|
||||
bind Entry <Select> {
|
||||
%W selection from insert
|
||||
}
|
||||
bind Entry <Control-Shift-space> {
|
||||
%W selection adjust insert
|
||||
}
|
||||
bind Entry <Shift-Select> {
|
||||
%W selection adjust insert
|
||||
}
|
||||
bind Entry <<SelectAll>> {
|
||||
%W selection range 0 end
|
||||
}
|
||||
bind Entry <<SelectNone>> {
|
||||
%W selection clear
|
||||
}
|
||||
bind Entry <Key> {
|
||||
tk::CancelRepeat
|
||||
tk::EntryInsert %W %A
|
||||
}
|
||||
|
||||
# Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
|
||||
# Otherwise, if a widget binding for one of these is defined, the
|
||||
# <Key> class binding will also fire and insert the character,
|
||||
# which is wrong. Ditto for Escape, Return, and Tab.
|
||||
|
||||
bind Entry <Alt-Key> {# nothing}
|
||||
bind Entry <Meta-Key> {# nothing}
|
||||
bind Entry <Control-Key> {# nothing}
|
||||
bind Entry <Escape> {# nothing}
|
||||
bind Entry <Return> {# nothing}
|
||||
bind Entry <KP_Enter> {# nothing}
|
||||
bind Entry <Tab> {# nothing}
|
||||
bind Entry <Prior> {# nothing}
|
||||
bind Entry <Next> {# nothing}
|
||||
if {[tk windowingsystem] eq "aqua"} {
|
||||
bind Entry <Command-Key> {# nothing}
|
||||
}
|
||||
# Tk-on-Cocoa generates characters for these two keys. [Bug 2971663]
|
||||
bind Entry <<NextLine>> {# nothing}
|
||||
bind Entry <<PrevLine>> {# nothing}
|
||||
|
||||
# On Windows, paste is done using Shift-Insert. Shift-Insert already
|
||||
# generates the <<Paste>> event, so we don't need to do anything here.
|
||||
if {[tk windowingsystem] ne "win32"} {
|
||||
bind Entry <Insert> {
|
||||
catch {tk::EntryInsert %W [::tk::GetSelection %W PRIMARY]}
|
||||
}
|
||||
}
|
||||
|
||||
# Additional emacs-like bindings:
|
||||
|
||||
bind Entry <Control-d> {
|
||||
if {!$tk_strictMotif} {
|
||||
%W delete insert
|
||||
}
|
||||
}
|
||||
bind Entry <Control-h> {
|
||||
if {!$tk_strictMotif} {
|
||||
tk::EntryBackspace %W
|
||||
}
|
||||
}
|
||||
bind Entry <Control-k> {
|
||||
if {!$tk_strictMotif} {
|
||||
%W delete insert end
|
||||
}
|
||||
}
|
||||
bind Entry <Control-t> {
|
||||
if {!$tk_strictMotif} {
|
||||
tk::EntryTranspose %W
|
||||
}
|
||||
}
|
||||
bind Entry <Meta-b> {
|
||||
if {!$tk_strictMotif} {
|
||||
tk::EntrySetCursor %W [tk::EntryPreviousWord %W insert]
|
||||
}
|
||||
}
|
||||
bind Entry <Meta-d> {
|
||||
if {!$tk_strictMotif} {
|
||||
%W delete insert [tk::EntryNextWord %W insert]
|
||||
}
|
||||
}
|
||||
bind Entry <Meta-f> {
|
||||
if {!$tk_strictMotif} {
|
||||
tk::EntrySetCursor %W [tk::EntryNextWord %W insert]
|
||||
}
|
||||
}
|
||||
bind Entry <Meta-BackSpace> {
|
||||
if {!$tk_strictMotif} {
|
||||
%W delete [tk::EntryPreviousWord %W insert] insert
|
||||
}
|
||||
}
|
||||
bind Entry <Meta-Delete> {
|
||||
if {!$tk_strictMotif} {
|
||||
%W delete [tk::EntryPreviousWord %W insert] insert
|
||||
}
|
||||
}
|
||||
|
||||
# Bindings for IME text input and accents.
|
||||
|
||||
bind Entry <<TkStartIMEMarkedText>> {
|
||||
dict set ::tk::Priv(IMETextMark) "%W" [%W index insert]
|
||||
}
|
||||
bind Entry <<TkEndIMEMarkedText>> {
|
||||
if {[catch {dict get $::tk::Priv(IMETextMark) "%W"} mark]} {
|
||||
bell
|
||||
} else {
|
||||
%W selection range $mark insert
|
||||
}
|
||||
}
|
||||
bind Entry <<TkClearIMEMarkedText>> {
|
||||
%W delete [dict get $::tk::Priv(IMETextMark) "%W"] [%W index insert]
|
||||
}
|
||||
bind Entry <<TkAccentBackspace>> {
|
||||
tk::EntryBackspace %W
|
||||
}
|
||||
|
||||
# A few additional bindings of my own.
|
||||
|
||||
if {[tk windowingsystem] ne "aqua"} {
|
||||
bind Entry <Button-2> {
|
||||
if {!$tk_strictMotif} {
|
||||
::tk::EntryScanMark %W %x
|
||||
}
|
||||
}
|
||||
bind Entry <B2-Motion> {
|
||||
if {!$tk_strictMotif} {
|
||||
::tk::EntryScanDrag %W %x
|
||||
}
|
||||
}
|
||||
} else {
|
||||
bind Entry <Button-3> {
|
||||
if {!$tk_strictMotif} {
|
||||
::tk::EntryScanMark %W %x
|
||||
}
|
||||
}
|
||||
bind Entry <B3-Motion> {
|
||||
if {!$tk_strictMotif} {
|
||||
::tk::EntryScanDrag %W %x
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::EntryClosestGap --
|
||||
# Given x and y coordinates, this procedure finds the closest boundary
|
||||
# between characters to the given coordinates and returns the index
|
||||
# of the character just after the boundary.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The entry window.
|
||||
# x - X-coordinate within the window.
|
||||
|
||||
proc ::tk::EntryClosestGap {w x} {
|
||||
set pos [$w index @$x]
|
||||
set bbox [$w bbox $pos]
|
||||
if {($x - [lindex $bbox 0]) < ([lindex $bbox 2]/2)} {
|
||||
return $pos
|
||||
}
|
||||
incr pos
|
||||
}
|
||||
|
||||
# ::tk::EntryButton1 --
|
||||
# This procedure is invoked to handle button-1 presses in entry
|
||||
# widgets. It moves the insertion cursor, sets the selection anchor,
|
||||
# and claims the input focus.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The entry window in which the button was pressed.
|
||||
# x - The x-coordinate of the button press.
|
||||
|
||||
proc ::tk::EntryButton1 {w x} {
|
||||
variable ::tk::Priv
|
||||
|
||||
set Priv(selectMode) char
|
||||
set Priv(mouseMoved) 0
|
||||
set Priv(pressX) $x
|
||||
$w icursor [EntryClosestGap $w $x]
|
||||
$w selection from insert
|
||||
if {"disabled" ne [$w cget -state]} {
|
||||
focus $w
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::EntryMouseSelect --
|
||||
# This procedure is invoked when dragging out a selection with
|
||||
# the mouse. Depending on the selection mode (character, word,
|
||||
# line) it selects in different-sized units. This procedure
|
||||
# ignores mouse motions initially until the mouse has moved from
|
||||
# one character to another or until there have been multiple clicks.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The entry window in which the button was pressed.
|
||||
# x - The x-coordinate of the mouse.
|
||||
|
||||
proc ::tk::EntryMouseSelect {w x} {
|
||||
variable ::tk::Priv
|
||||
|
||||
set cur [EntryClosestGap $w $x]
|
||||
set anchor [$w index anchor]
|
||||
if {($cur != $anchor) || (abs($Priv(pressX) - $x) >= 3)} {
|
||||
set Priv(mouseMoved) 1
|
||||
}
|
||||
switch $Priv(selectMode) {
|
||||
char {
|
||||
if {$Priv(mouseMoved)} {
|
||||
if {$cur < $anchor} {
|
||||
$w selection range $cur $anchor
|
||||
} elseif {$cur > $anchor} {
|
||||
$w selection range $anchor $cur
|
||||
} else {
|
||||
$w selection clear
|
||||
}
|
||||
}
|
||||
}
|
||||
word {
|
||||
if {$cur < $anchor} {
|
||||
set before [tcl_wordBreakBefore [$w get] $cur]
|
||||
set after [tcl_wordBreakAfter [$w get] $anchor-1]
|
||||
} elseif {$cur > $anchor} {
|
||||
set before [tcl_wordBreakBefore [$w get] $anchor]
|
||||
set after [tcl_wordBreakAfter [$w get] $cur-1]
|
||||
} else {
|
||||
if {[$w index @$Priv(pressX)] < $anchor} {
|
||||
incr anchor -1
|
||||
}
|
||||
set before [tcl_wordBreakBefore [$w get] $anchor]
|
||||
set after [tcl_wordBreakAfter [$w get] $anchor]
|
||||
}
|
||||
if {$before < 0} {
|
||||
set before 0
|
||||
}
|
||||
if {$after < 0} {
|
||||
set after end
|
||||
}
|
||||
$w selection range $before $after
|
||||
}
|
||||
line {
|
||||
$w selection range 0 end
|
||||
}
|
||||
}
|
||||
if {$Priv(mouseMoved)} {
|
||||
$w icursor $cur
|
||||
}
|
||||
update idletasks
|
||||
}
|
||||
|
||||
# ::tk::EntryPaste --
|
||||
# This procedure sets the insertion cursor to the current mouse position,
|
||||
# pastes the selection there, and sets the focus to the window.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The entry window.
|
||||
# x - X position of the mouse.
|
||||
|
||||
proc ::tk::EntryPaste {w x} {
|
||||
$w icursor [EntryClosestGap $w $x]
|
||||
catch {$w insert insert [::tk::GetSelection $w PRIMARY]}
|
||||
if {"disabled" ne [$w cget -state]} {
|
||||
focus $w
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::EntryAutoScan --
|
||||
# This procedure is invoked when the mouse leaves an entry window
|
||||
# with button 1 down. It scrolls the window left or right,
|
||||
# depending on where the mouse is, and reschedules itself as an
|
||||
# "after" command so that the window continues to scroll until the
|
||||
# mouse moves back into the window or the mouse button is released.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The entry window.
|
||||
|
||||
proc ::tk::EntryAutoScan {w} {
|
||||
variable ::tk::Priv
|
||||
set x $Priv(x)
|
||||
if {![winfo exists $w]} {
|
||||
return
|
||||
}
|
||||
if {$x >= [winfo width $w]} {
|
||||
$w xview scroll 2 units
|
||||
EntryMouseSelect $w $x
|
||||
} elseif {$x < 0} {
|
||||
$w xview scroll -2 units
|
||||
EntryMouseSelect $w $x
|
||||
}
|
||||
set Priv(afterId) [after 50 [list tk::EntryAutoScan $w]]
|
||||
}
|
||||
|
||||
# ::tk::EntryKeySelect --
|
||||
# This procedure is invoked when stroking out selections using the
|
||||
# keyboard. It moves the cursor to a new position, then extends
|
||||
# the selection to that position.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The entry window.
|
||||
# new - A new position for the insertion cursor (the cursor hasn't
|
||||
# actually been moved to this position yet).
|
||||
|
||||
proc ::tk::EntryKeySelect {w new} {
|
||||
if {![$w selection present]} {
|
||||
$w selection from insert
|
||||
$w selection to $new
|
||||
} else {
|
||||
$w selection adjust $new
|
||||
}
|
||||
$w icursor $new
|
||||
}
|
||||
|
||||
# ::tk::EntryInsert --
|
||||
# Insert a string into an entry at the point of the insertion cursor.
|
||||
# If there is a selection in the entry, and it covers the point of the
|
||||
# insertion cursor, then delete the selection before inserting.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The entry window in which to insert the string
|
||||
# s - The string to insert (usually just a single character)
|
||||
|
||||
proc ::tk::EntryInsert {w s} {
|
||||
if {$s eq ""} {
|
||||
return
|
||||
}
|
||||
catch {
|
||||
set insert [$w index insert]
|
||||
if {([$w index sel.first] <= $insert)
|
||||
&& ([$w index sel.last] >= $insert)} {
|
||||
$w delete sel.first sel.last
|
||||
}
|
||||
}
|
||||
$w insert insert $s
|
||||
EntrySeeInsert $w
|
||||
}
|
||||
|
||||
# ::tk::EntryBackspace --
|
||||
# Backspace over the character just before the insertion cursor.
|
||||
# If backspacing would move the cursor off the left edge of the
|
||||
# window, reposition the cursor at about the middle of the window.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The entry window in which to backspace.
|
||||
|
||||
proc ::tk::EntryBackspace w {
|
||||
if {[$w selection present]} {
|
||||
$w delete sel.first sel.last
|
||||
} else {
|
||||
set x [$w index insert]
|
||||
if {$x > 0} {
|
||||
$w delete [expr {$x-1}]
|
||||
}
|
||||
if {[$w index @0] >= [$w index insert]} {
|
||||
set range [$w xview]
|
||||
set left [lindex $range 0]
|
||||
set right [lindex $range 1]
|
||||
$w xview moveto [expr {$left - ($right - $left)/2.0}]
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::EntrySeeInsert --
|
||||
# Make sure that the insertion cursor is visible in the entry window.
|
||||
# If not, adjust the view so that it is.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The entry window.
|
||||
|
||||
proc ::tk::EntrySeeInsert w {
|
||||
set c [$w index insert]
|
||||
if {($c < [$w index @0]) || ($c > [$w index @[winfo width $w]])} {
|
||||
$w xview $c
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::EntrySetCursor -
|
||||
# Move the insertion cursor to a given position in an entry. Also
|
||||
# clears the selection, if there is one in the entry, and makes sure
|
||||
# that the insertion cursor is visible.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The entry window.
|
||||
# pos - The desired new position for the cursor in the window.
|
||||
|
||||
proc ::tk::EntrySetCursor {w pos} {
|
||||
$w icursor $pos
|
||||
$w selection clear
|
||||
EntrySeeInsert $w
|
||||
}
|
||||
|
||||
# ::tk::EntryTranspose -
|
||||
# This procedure implements the "transpose" function for entry widgets.
|
||||
# It tranposes the characters on either side of the insertion cursor,
|
||||
# unless the cursor is at the end of the line. In this case it
|
||||
# transposes the two characters to the left of the cursor. In either
|
||||
# case, the cursor ends up to the right of the transposed characters.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The entry window.
|
||||
|
||||
proc ::tk::EntryTranspose w {
|
||||
set i [$w index insert]
|
||||
if {$i < [$w index end]} {
|
||||
incr i
|
||||
}
|
||||
if {$i < 2} {
|
||||
return
|
||||
}
|
||||
set first [expr {$i-2}]
|
||||
set data [$w get]
|
||||
set new [string index $data $i-1][string index $data $first]
|
||||
$w delete $first $i
|
||||
$w insert insert $new
|
||||
EntrySeeInsert $w
|
||||
}
|
||||
|
||||
# ::tk::EntryNextWord --
|
||||
# Returns the index of the next word position after a given position in the
|
||||
# entry. The next word is platform dependent and may be either the next
|
||||
# end-of-word position or the next start-of-word position after the next
|
||||
# end-of-word position.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The entry window in which the cursor is to move.
|
||||
# start - Position at which to start search.
|
||||
|
||||
if {[tk windowingsystem] eq "win32"} {
|
||||
proc ::tk::EntryNextWord {w start} {
|
||||
set pos [tcl_endOfWord [$w get] [$w index $start]]
|
||||
if {$pos >= 0} {
|
||||
set pos [tcl_startOfNextWord [$w get] $pos]
|
||||
}
|
||||
if {$pos < 0} {
|
||||
return end
|
||||
}
|
||||
return $pos
|
||||
}
|
||||
} else {
|
||||
proc ::tk::EntryNextWord {w start} {
|
||||
set pos [tcl_endOfWord [$w get] [$w index $start]]
|
||||
if {$pos < 0} {
|
||||
return end
|
||||
}
|
||||
return $pos
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::EntryPreviousWord --
|
||||
#
|
||||
# Returns the index of the previous word position before a given
|
||||
# position in the entry.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The entry window in which the cursor is to move.
|
||||
# start - Position at which to start search.
|
||||
|
||||
proc ::tk::EntryPreviousWord {w start} {
|
||||
set pos [tcl_startOfPreviousWord [$w get] [$w index $start]]
|
||||
if {$pos < 0} {
|
||||
return 0
|
||||
}
|
||||
return $pos
|
||||
}
|
||||
|
||||
# ::tk::EntryScanMark --
|
||||
#
|
||||
# Marks the start of a possible scan drag operation
|
||||
#
|
||||
# Arguments:
|
||||
# w - The entry window from which the text to get
|
||||
# x - x location on screen
|
||||
|
||||
proc ::tk::EntryScanMark {w x} {
|
||||
$w scan mark $x
|
||||
set ::tk::Priv(x) $x
|
||||
set ::tk::Priv(y) 0 ; # not used
|
||||
set ::tk::Priv(mouseMoved) 0
|
||||
}
|
||||
|
||||
# ::tk::EntryScanDrag --
|
||||
#
|
||||
# Marks the start of a possible scan drag operation
|
||||
#
|
||||
# Arguments:
|
||||
# w - The entry window from which the text to get
|
||||
# x - x location on screen
|
||||
|
||||
proc ::tk::EntryScanDrag {w x} {
|
||||
# Make sure these exist, as some weird situations can trigger the
|
||||
# motion binding without the initial press. [Bug #220269]
|
||||
if {![info exists ::tk::Priv(x)]} {set ::tk::Priv(x) $x}
|
||||
# allow for a delta
|
||||
if {abs($x-$::tk::Priv(x)) > 2} {
|
||||
set ::tk::Priv(mouseMoved) 1
|
||||
}
|
||||
$w scan dragto $x
|
||||
}
|
||||
|
||||
# ::tk::EntryGetSelection --
|
||||
#
|
||||
# Returns the selected text of the entry with respect to the -show option.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The entry window from which the text to get
|
||||
|
||||
proc ::tk::EntryGetSelection {w} {
|
||||
set entryString [string range [$w get] [$w index sel.first] \
|
||||
[$w index sel.last]-1]
|
||||
if {[$w cget -show] ne ""} {
|
||||
return [string repeat [string index [$w cget -show] 0] \
|
||||
[string length $entryString]]
|
||||
}
|
||||
return $entryString
|
||||
}
|
||||
|
|
@ -0,0 +1,178 @@
|
|||
# focus.tcl --
|
||||
#
|
||||
# This file defines several procedures for managing the input
|
||||
# focus.
|
||||
#
|
||||
# Copyright (c) 1994-1995 Sun Microsystems, Inc.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
|
||||
# ::tk_focusNext --
|
||||
# This procedure returns the name of the next window after "w" in
|
||||
# "focus order" (the window that should receive the focus next if
|
||||
# Tab is typed in w). "Next" is defined by a pre-order search
|
||||
# of a top-level and its non-top-level descendants, with the stacking
|
||||
# order determining the order of siblings. The "-takefocus" options
|
||||
# on windows determine whether or not they should be skipped.
|
||||
#
|
||||
# Arguments:
|
||||
# w - Name of a window.
|
||||
|
||||
proc ::tk_focusNext w {
|
||||
set cur $w
|
||||
while {1} {
|
||||
|
||||
# Descend to just before the first child of the current widget.
|
||||
|
||||
set parent $cur
|
||||
set children [winfo children $cur]
|
||||
set i -1
|
||||
|
||||
# Look for the next sibling that isn't a top-level.
|
||||
|
||||
while {1} {
|
||||
incr i
|
||||
if {$i < [llength $children]} {
|
||||
set cur [lindex $children $i]
|
||||
if {[winfo toplevel $cur] eq $cur} {
|
||||
continue
|
||||
} else {
|
||||
break
|
||||
}
|
||||
}
|
||||
|
||||
# No more siblings, so go to the current widget's parent.
|
||||
# If it's a top-level, break out of the loop, otherwise
|
||||
# look for its next sibling.
|
||||
|
||||
set cur $parent
|
||||
if {[winfo toplevel $cur] eq $cur} {
|
||||
break
|
||||
}
|
||||
set parent [winfo parent $parent]
|
||||
set children [winfo children $parent]
|
||||
set i [lsearch -exact $children $cur]
|
||||
}
|
||||
if {$w eq $cur || [tk::FocusOK $cur]} {
|
||||
return $cur
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk_focusPrev --
|
||||
# This procedure returns the name of the previous window before "w" in
|
||||
# "focus order" (the window that should receive the focus next if
|
||||
# Shift-Tab is typed in w). "Next" is defined by a pre-order search
|
||||
# of a top-level and its non-top-level descendants, with the stacking
|
||||
# order determining the order of siblings. The "-takefocus" options
|
||||
# on windows determine whether or not they should be skipped.
|
||||
#
|
||||
# Arguments:
|
||||
# w - Name of a window.
|
||||
|
||||
proc ::tk_focusPrev w {
|
||||
set cur $w
|
||||
while {1} {
|
||||
|
||||
# Collect information about the current window's position
|
||||
# among its siblings. Also, if the window is a top-level,
|
||||
# then reposition to just after the last child of the window.
|
||||
|
||||
if {[winfo toplevel $cur] eq $cur} {
|
||||
set parent $cur
|
||||
set children [winfo children $cur]
|
||||
set i [llength $children]
|
||||
} else {
|
||||
set parent [winfo parent $cur]
|
||||
set children [winfo children $parent]
|
||||
set i [lsearch -exact $children $cur]
|
||||
}
|
||||
|
||||
# Go to the previous sibling, then descend to its last descendant
|
||||
# (highest in stacking order. While doing this, ignore top-levels
|
||||
# and their descendants. When we run out of descendants, go up
|
||||
# one level to the parent.
|
||||
|
||||
while {$i > 0} {
|
||||
incr i -1
|
||||
set cur [lindex $children $i]
|
||||
if {[winfo toplevel $cur] eq $cur} {
|
||||
continue
|
||||
}
|
||||
set parent $cur
|
||||
set children [winfo children $parent]
|
||||
set i [llength $children]
|
||||
}
|
||||
set cur $parent
|
||||
if {$w eq $cur || [tk::FocusOK $cur]} {
|
||||
return $cur
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::FocusOK --
|
||||
#
|
||||
# This procedure is invoked to decide whether or not to focus on
|
||||
# a given window. It returns 1 if it's OK to focus on the window,
|
||||
# 0 if it's not OK. The code first checks whether the window is
|
||||
# viewable. If not, then it never focuses on the window. Then it
|
||||
# checks the -takefocus option for the window and uses it if it's
|
||||
# set. If there's no -takefocus option, the procedure checks to
|
||||
# see if (a) the widget isn't disabled, and (b) it has some key
|
||||
# bindings. If all of these are true, then 1 is returned.
|
||||
#
|
||||
# Arguments:
|
||||
# w - Name of a window.
|
||||
|
||||
proc ::tk::FocusOK w {
|
||||
set code [catch {$w cget -takefocus} value]
|
||||
if {($code == 0) && ($value ne "")} {
|
||||
if {$value == 0} {
|
||||
return 0
|
||||
} elseif {$value == 1} {
|
||||
return [winfo viewable $w]
|
||||
} else {
|
||||
set value [uplevel #0 $value [list $w]]
|
||||
if {$value ne ""} {
|
||||
return $value
|
||||
}
|
||||
}
|
||||
}
|
||||
if {![winfo viewable $w]} {
|
||||
return 0
|
||||
}
|
||||
set code [catch {$w cget -state} value]
|
||||
if {($code == 0) && $value eq "disabled"} {
|
||||
return 0
|
||||
}
|
||||
regexp Key|Focus "[bind $w] [bind [winfo class $w]]"
|
||||
}
|
||||
|
||||
# ::tk_focusFollowsMouse --
|
||||
#
|
||||
# If this procedure is invoked, Tk will enter "focus-follows-mouse"
|
||||
# mode, where the focus is always on whatever window contains the
|
||||
# mouse. If this procedure isn't invoked, then the user typically
|
||||
# has to click on a window to give it the focus.
|
||||
#
|
||||
# Arguments:
|
||||
# None.
|
||||
|
||||
proc ::tk_focusFollowsMouse {} {
|
||||
set old [bind all <Enter>]
|
||||
set script {
|
||||
if {"%d" eq "NotifyAncestor" || "%d" eq "NotifyNonlinear" \
|
||||
|| "%d" eq "NotifyInferior"} {
|
||||
if {[tk::FocusOK %W]} {
|
||||
focus %W
|
||||
}
|
||||
}
|
||||
}
|
||||
if {$old ne ""} {
|
||||
bind all <Enter> "$old; $script"
|
||||
} else {
|
||||
bind all <Enter> $script
|
||||
}
|
||||
}
|
||||
|
|
@ -0,0 +1,455 @@
|
|||
# fontchooser.tcl -
|
||||
#
|
||||
# A themeable Tk font selection dialog. See TIP #324.
|
||||
#
|
||||
# Copyright (C) 2008 Keith Vetter
|
||||
# Copyright (C) 2008 Pat Thoyts <patthoyts@users.sourceforge.net>
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
namespace eval ::tk::fontchooser {
|
||||
variable S
|
||||
|
||||
set S(W) .__tk__fontchooser
|
||||
set S(fonts) [lsort -dictionary [font families]]
|
||||
set S(styles) [list \
|
||||
[::msgcat::mc "Regular"] \
|
||||
[::msgcat::mc "Italic"] \
|
||||
[::msgcat::mc "Bold"] \
|
||||
[::msgcat::mc "Bold Italic"] \
|
||||
]
|
||||
|
||||
set S(sizes) {8 9 10 11 12 14 16 18 20 22 24 26 28 36 48 72}
|
||||
set S(strike) 0
|
||||
set S(under) 0
|
||||
set S(first) 1
|
||||
set S(sampletext) [::msgcat::mc "AaBbYyZz01"]
|
||||
set S(-parent) .
|
||||
set S(-title) [::msgcat::mc "Font"]
|
||||
set S(-command) ""
|
||||
set S(-font) TkDefaultFont
|
||||
}
|
||||
|
||||
proc ::tk::fontchooser::Setup {} {
|
||||
variable S
|
||||
|
||||
# Canonical versions of font families, styles, etc. for easier searching
|
||||
set S(fonts,lcase) {}
|
||||
foreach font $S(fonts) {lappend S(fonts,lcase) [string tolower $font]}
|
||||
set S(styles,lcase) {}
|
||||
foreach style $S(styles) {lappend S(styles,lcase) [string tolower $style]}
|
||||
set S(sizes,lcase) $S(sizes)
|
||||
|
||||
::ttk::style layout FontchooserFrame {
|
||||
Entry.field -sticky news -border true -children {
|
||||
FontchooserFrame.padding -sticky news
|
||||
}
|
||||
}
|
||||
bind [winfo class .] <<ThemeChanged>> \
|
||||
[list +ttk::style layout FontchooserFrame \
|
||||
[ttk::style layout FontchooserFrame]]
|
||||
|
||||
namespace ensemble create -map {
|
||||
show ::tk::fontchooser::Show
|
||||
hide ::tk::fontchooser::Hide
|
||||
configure ::tk::fontchooser::Configure
|
||||
}
|
||||
}
|
||||
::tk::fontchooser::Setup
|
||||
|
||||
proc ::tk::fontchooser::Show {} {
|
||||
variable S
|
||||
if {![winfo exists $S(W)]} {
|
||||
Create
|
||||
wm transient $S(W) [winfo toplevel $S(-parent)]
|
||||
tk::PlaceWindow $S(W) widget $S(-parent)
|
||||
}
|
||||
set S(fonts) [lsort -dictionary [font families]]
|
||||
set S(fonts,lcase) {}
|
||||
foreach font $S(fonts) { lappend S(fonts,lcase) [string tolower $font]}
|
||||
wm deiconify $S(W)
|
||||
}
|
||||
|
||||
proc ::tk::fontchooser::Hide {} {
|
||||
variable S
|
||||
wm withdraw $S(W)
|
||||
}
|
||||
|
||||
proc ::tk::fontchooser::Configure {args} {
|
||||
variable S
|
||||
|
||||
set specs {
|
||||
{-parent "" "" . }
|
||||
{-title "" "" ""}
|
||||
{-font "" "" ""}
|
||||
{-command "" "" ""}
|
||||
}
|
||||
|
||||
if {[llength $args] == 0} {
|
||||
set result {}
|
||||
foreach spec $specs {
|
||||
foreach {name xx yy default} $spec break
|
||||
lappend result $name \
|
||||
[expr {[info exists S($name)] ? $S($name) : $default}]
|
||||
}
|
||||
lappend result -visible \
|
||||
[expr {[winfo exists $S(W)] && [winfo ismapped $S(W)]}]
|
||||
return $result
|
||||
}
|
||||
if {[llength $args] == 1} {
|
||||
set option [lindex $args 0]
|
||||
if {[string equal $option "-visible"]} {
|
||||
return [expr {[winfo exists $S(W)] && [winfo ismapped $S(W)]}]
|
||||
} elseif {[info exists S($option)]} {
|
||||
return $S($option)
|
||||
}
|
||||
return -code error -errorcode [list TK LOOKUP OPTION $option] \
|
||||
"bad option \"$option\": must be\
|
||||
-command, -font, -parent, -title or -visible"
|
||||
}
|
||||
|
||||
set cache [dict create -parent $S(-parent) -title $S(-title) \
|
||||
-font $S(-font) -command $S(-command)]
|
||||
set r [tclParseConfigSpec [namespace which -variable S] $specs DONTSETDEFAULTS $args]
|
||||
if {![winfo exists $S(-parent)]} {
|
||||
set code [list TK LOOKUP WINDOW $S(-parent)]
|
||||
set err "bad window path name \"$S(-parent)\""
|
||||
array set S $cache
|
||||
return -code error -errorcode $code $err
|
||||
}
|
||||
if {[string trim $S(-title)] eq ""} {
|
||||
set S(-title) [::msgcat::mc "Font"]
|
||||
}
|
||||
if {[winfo exists $S(W)] && ("-font" in $args)} {
|
||||
Init $S(-font)
|
||||
event generate $S(-parent) <<TkFontchooserFontChanged>>
|
||||
}
|
||||
return $r
|
||||
}
|
||||
|
||||
proc ::tk::fontchooser::Create {} {
|
||||
variable S
|
||||
set windowName __tk__fontchooser
|
||||
if {$S(-parent) eq "."} {
|
||||
set S(W) .$windowName
|
||||
} else {
|
||||
set S(W) $S(-parent).$windowName
|
||||
}
|
||||
|
||||
# Now build the dialog
|
||||
if {![winfo exists $S(W)]} {
|
||||
toplevel $S(W) -class TkFontDialog
|
||||
if {[package provide tcltest] ne {}} {set ::tk_dialog $S(W)}
|
||||
wm withdraw $S(W)
|
||||
wm title $S(W) $S(-title)
|
||||
wm transient $S(W) [winfo toplevel $S(-parent)]
|
||||
|
||||
set scaling [tk scaling]
|
||||
set sizeWidth [expr {int([string length [::msgcat::mc "&Size:"]] * $scaling)}]
|
||||
|
||||
set outer [::ttk::frame $S(W).outer -padding {10 10}]
|
||||
::tk::AmpWidget ::ttk::label $S(W).font -text [::msgcat::mc "&Font:"]
|
||||
::tk::AmpWidget ::ttk::label $S(W).style -text [::msgcat::mc "Font st&yle:"]
|
||||
::tk::AmpWidget ::ttk::label $S(W).size -text [::msgcat::mc "&Size:"] -width $sizeWidth
|
||||
ttk::entry $S(W).efont -width 18 \
|
||||
-textvariable [namespace which -variable S](font)
|
||||
ttk::entry $S(W).estyle -width 10 \
|
||||
-textvariable [namespace which -variable S](style)
|
||||
ttk::entry $S(W).esize -textvariable [namespace which -variable S](size) \
|
||||
-width 3 -validate key -validatecommand {string is double %P}
|
||||
|
||||
ttk_slistbox $S(W).lfonts -height 7 -exportselection 0 \
|
||||
-selectmode browse -activestyle none \
|
||||
-listvariable [namespace which -variable S](fonts)
|
||||
ttk_slistbox $S(W).lstyles -width 5 -height 7 -exportselection 0 \
|
||||
-selectmode browse -activestyle none \
|
||||
-listvariable [namespace which -variable S](styles)
|
||||
ttk_slistbox $S(W).lsizes -width 4 -height 7 -exportselection 0 \
|
||||
-selectmode browse -activestyle none \
|
||||
-listvariable [namespace which -variable S](sizes)
|
||||
|
||||
set WE $S(W).effects
|
||||
::ttk::labelframe $WE -text [::msgcat::mc "Effects"]
|
||||
::tk::AmpWidget ::ttk::checkbutton $WE.strike \
|
||||
-variable [namespace which -variable S](strike) \
|
||||
-text [::msgcat::mc "Stri&keout"] \
|
||||
-command [namespace code [list Click strike]]
|
||||
::tk::AmpWidget ::ttk::checkbutton $WE.under \
|
||||
-variable [namespace which -variable S](under) \
|
||||
-text [::msgcat::mc "&Underline"] \
|
||||
-command [namespace code [list Click under]]
|
||||
|
||||
set bbox [::ttk::frame $S(W).bbox]
|
||||
::ttk::button $S(W).ok -text [::msgcat::mc OK] -default active\
|
||||
-command [namespace code [list Done 1]]
|
||||
::ttk::button $S(W).cancel -text [::msgcat::mc Cancel] \
|
||||
-command [namespace code [list Done 0]]
|
||||
::tk::AmpWidget ::ttk::button $S(W).apply -text [::msgcat::mc "&Apply"] \
|
||||
-command [namespace code [list Apply]]
|
||||
wm protocol $S(W) WM_DELETE_WINDOW [namespace code [list Done 0]]
|
||||
|
||||
# Calculate minimum sizes
|
||||
ttk::scrollbar $S(W).tmpvs
|
||||
set scroll_width [winfo reqwidth $S(W).tmpvs]
|
||||
destroy $S(W).tmpvs
|
||||
set minsize(gap) 10
|
||||
set minsize(bbox) [winfo reqwidth $S(W).ok]
|
||||
set minsize(fonts) \
|
||||
[expr {[font measure TkDefaultFont "Helvetica"] + $scroll_width}]
|
||||
set minsize(styles) \
|
||||
[expr {[font measure TkDefaultFont "Bold Italic"] + $scroll_width}]
|
||||
set minsize(sizes) \
|
||||
[expr {[font measure TkDefaultFont "-99"] + $scroll_width}]
|
||||
set min [expr {$minsize(gap) * 4}]
|
||||
foreach {what width} [array get minsize] {incr min $width}
|
||||
wm minsize $S(W) $min 260
|
||||
|
||||
bind $S(W) <Return> [namespace code [list Done 1]]
|
||||
bind $S(W) <Escape> [namespace code [list Done 0]]
|
||||
bind $S(W) <Map> [namespace code [list Visibility %W 1]]
|
||||
bind $S(W) <Unmap> [namespace code [list Visibility %W 0]]
|
||||
bind $S(W) <Destroy> [namespace code [list Visibility %W 0]]
|
||||
bind $S(W).lfonts.list <<ListboxSelect>> [namespace code [list Click font]]
|
||||
bind $S(W).lstyles.list <<ListboxSelect>> [namespace code [list Click style]]
|
||||
bind $S(W).lsizes.list <<ListboxSelect>> [namespace code [list Click size]]
|
||||
bind $S(W) <Alt-Key> [list ::tk::AltKeyInDialog $S(W) %A]
|
||||
bind $S(W).font <<AltUnderlined>> [list ::focus $S(W).efont]
|
||||
bind $S(W).style <<AltUnderlined>> [list ::focus $S(W).estyle]
|
||||
bind $S(W).size <<AltUnderlined>> [list ::focus $S(W).esize]
|
||||
bind $S(W).apply <<AltUnderlined>> [namespace code [list Apply]]
|
||||
bind $WE.strike <<AltUnderlined>> [list $WE.strike invoke]
|
||||
bind $WE.under <<AltUnderlined>> [list $WE.under invoke]
|
||||
|
||||
set WS $S(W).sample
|
||||
::ttk::labelframe $WS -text [::msgcat::mc "Sample"]
|
||||
::ttk::label $WS.sample -relief sunken -anchor center \
|
||||
-textvariable [namespace which -variable S](sampletext)
|
||||
set S(sample) $WS.sample
|
||||
grid $WS.sample -sticky news -padx 6 -pady 4
|
||||
grid rowconfigure $WS 0 -weight 1
|
||||
grid columnconfigure $WS 0 -weight 1
|
||||
grid propagate $WS 0
|
||||
|
||||
grid $S(W).ok -in $bbox -sticky new -pady {0 2}
|
||||
grid $S(W).cancel -in $bbox -sticky new -pady 2
|
||||
if {$S(-command) ne ""} {
|
||||
grid $S(W).apply -in $bbox -sticky new -pady 2
|
||||
}
|
||||
grid columnconfigure $bbox 0 -weight 1
|
||||
|
||||
grid $WE.strike -sticky w -padx 10
|
||||
grid $WE.under -sticky w -padx 10 -pady {0 30}
|
||||
grid columnconfigure $WE 1 -weight 1
|
||||
|
||||
grid $S(W).font x $S(W).style x $S(W).size x -in $outer -sticky w
|
||||
grid $S(W).efont x $S(W).estyle x $S(W).esize x $bbox -in $outer -sticky ew
|
||||
grid $S(W).lfonts x $S(W).lstyles x $S(W).lsizes x ^ -in $outer -sticky news
|
||||
grid $WE x $WS - - x ^ -in $outer -sticky news -pady {15 30}
|
||||
grid configure $bbox -sticky n
|
||||
grid columnconfigure $outer {1 3 5} -minsize $minsize(gap)
|
||||
grid columnconfigure $outer {0 2 4} -weight 1
|
||||
grid columnconfigure $outer 0 -minsize $minsize(fonts)
|
||||
grid columnconfigure $outer 2 -minsize $minsize(styles)
|
||||
grid columnconfigure $outer 4 -minsize $minsize(sizes)
|
||||
grid columnconfigure $outer 6 -minsize $minsize(bbox)
|
||||
|
||||
grid $outer -sticky news
|
||||
grid rowconfigure $S(W) 0 -weight 1
|
||||
grid columnconfigure $S(W) 0 -weight 1
|
||||
|
||||
Init $S(-font)
|
||||
|
||||
trace add variable [namespace which -variable S](size) \
|
||||
write [namespace code [list Tracer]]
|
||||
trace add variable [namespace which -variable S](style) \
|
||||
write [namespace code [list Tracer]]
|
||||
trace add variable [namespace which -variable S](font) \
|
||||
write [namespace code [list Tracer]]
|
||||
} else {
|
||||
Init $S(-font)
|
||||
}
|
||||
|
||||
return
|
||||
}
|
||||
|
||||
# ::tk::fontchooser::Done --
|
||||
#
|
||||
# Handles teardown of the dialog, calling -command if needed
|
||||
#
|
||||
# Arguments:
|
||||
# ok true if user pressed OK
|
||||
#
|
||||
proc ::tk::fontchooser::Done {ok} {
|
||||
variable S
|
||||
|
||||
if {! $ok} {
|
||||
set S(result) ""
|
||||
}
|
||||
trace vdelete S(size) w [namespace code [list Tracer]]
|
||||
trace vdelete S(style) w [namespace code [list Tracer]]
|
||||
trace vdelete S(font) w [namespace code [list Tracer]]
|
||||
destroy $S(W)
|
||||
if {$ok && $S(-command) ne ""} {
|
||||
uplevel #0 $S(-command) [list $S(result)]
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::fontchooser::Apply --
|
||||
#
|
||||
# Call the -command procedure appending the current font
|
||||
# Errors are reported via the background error mechanism
|
||||
#
|
||||
proc ::tk::fontchooser::Apply {} {
|
||||
variable S
|
||||
if {$S(-command) ne ""} {
|
||||
if {[catch {uplevel #0 $S(-command) [list $S(result)]} err]} {
|
||||
::bgerror $err
|
||||
}
|
||||
}
|
||||
event generate $S(-parent) <<TkFontchooserFontChanged>>
|
||||
}
|
||||
|
||||
# ::tk::fontchooser::Init --
|
||||
#
|
||||
# Initializes dialog to a default font
|
||||
#
|
||||
# Arguments:
|
||||
# defaultFont font to use as the default
|
||||
#
|
||||
proc ::tk::fontchooser::Init {{defaultFont ""}} {
|
||||
variable S
|
||||
|
||||
if {$S(first) || $defaultFont ne ""} {
|
||||
if {$defaultFont eq ""} {
|
||||
set defaultFont [[entry .___e] cget -font]
|
||||
destroy .___e
|
||||
}
|
||||
array set F [font actual $defaultFont]
|
||||
set S(font) $F(-family)
|
||||
set S(size) $F(-size)
|
||||
set S(strike) $F(-overstrike)
|
||||
set S(under) $F(-underline)
|
||||
set S(style) [::msgcat::mc "Regular"]
|
||||
if {$F(-weight) eq "bold" && $F(-slant) eq "italic"} {
|
||||
set S(style) [::msgcat::mc "Bold Italic"]
|
||||
} elseif {$F(-weight) eq "bold"} {
|
||||
set S(style) [::msgcat::mc "Bold"]
|
||||
} elseif {$F(-slant) eq "italic"} {
|
||||
set S(style) [::msgcat::mc "Italic"]
|
||||
}
|
||||
|
||||
set S(first) 0
|
||||
}
|
||||
|
||||
Tracer a b c
|
||||
Update
|
||||
}
|
||||
|
||||
# ::tk::fontchooser::Click --
|
||||
#
|
||||
# Handles all button clicks, updating the appropriate widgets
|
||||
#
|
||||
# Arguments:
|
||||
# who which widget got pressed
|
||||
#
|
||||
proc ::tk::fontchooser::Click {who} {
|
||||
variable S
|
||||
|
||||
if {$who eq "font"} {
|
||||
set S(font) [$S(W).lfonts get [$S(W).lfonts curselection]]
|
||||
} elseif {$who eq "style"} {
|
||||
set S(style) [$S(W).lstyles get [$S(W).lstyles curselection]]
|
||||
} elseif {$who eq "size"} {
|
||||
set S(size) [$S(W).lsizes get [$S(W).lsizes curselection]]
|
||||
}
|
||||
Update
|
||||
}
|
||||
|
||||
# ::tk::fontchooser::Tracer --
|
||||
#
|
||||
# Handles traces on key variables, updating the appropriate widgets
|
||||
#
|
||||
# Arguments:
|
||||
# standard trace arguments (not used)
|
||||
#
|
||||
proc ::tk::fontchooser::Tracer {var1 var2 op} {
|
||||
variable S
|
||||
|
||||
set bad 0
|
||||
set nstate normal
|
||||
# Make selection in each listbox
|
||||
foreach var {font style size} {
|
||||
set value [string tolower $S($var)]
|
||||
$S(W).l${var}s selection clear 0 end
|
||||
set n [lsearch -exact $S(${var}s,lcase) $value]
|
||||
$S(W).l${var}s selection set $n
|
||||
if {$n >= 0} {
|
||||
set S($var) [lindex $S(${var}s) $n]
|
||||
$S(W).e$var icursor end
|
||||
$S(W).e$var selection clear
|
||||
} else { ;# No match, try prefix
|
||||
# Size is weird: valid numbers are legal but don't display
|
||||
# unless in the font size list
|
||||
set n [lsearch -glob $S(${var}s,lcase) "$value*"]
|
||||
set bad 1
|
||||
if {$var ne "size" || ! [string is double -strict $value]} {
|
||||
set nstate disabled
|
||||
}
|
||||
}
|
||||
$S(W).l${var}s see $n
|
||||
}
|
||||
if {!$bad} {Update}
|
||||
$S(W).ok configure -state $nstate
|
||||
}
|
||||
|
||||
# ::tk::fontchooser::Update --
|
||||
#
|
||||
# Shows a sample of the currently selected font
|
||||
#
|
||||
proc ::tk::fontchooser::Update {} {
|
||||
variable S
|
||||
|
||||
set S(result) [list $S(font) $S(size)]
|
||||
if {$S(style) eq [::msgcat::mc "Bold"]} {lappend S(result) bold}
|
||||
if {$S(style) eq [::msgcat::mc "Italic"]} {lappend S(result) italic}
|
||||
if {$S(style) eq [::msgcat::mc "Bold Italic"]} {lappend S(result) bold italic}
|
||||
if {$S(strike)} {lappend S(result) overstrike}
|
||||
if {$S(under)} {lappend S(result) underline}
|
||||
|
||||
$S(sample) configure -font $S(result)
|
||||
}
|
||||
|
||||
# ::tk::fontchooser::Visibility --
|
||||
#
|
||||
# Notify the parent when the dialog visibility changes
|
||||
#
|
||||
proc ::tk::fontchooser::Visibility {w visible} {
|
||||
variable S
|
||||
if {$w eq $S(W)} {
|
||||
event generate $S(-parent) <<TkFontchooserVisibility>>
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::fontchooser::ttk_listbox --
|
||||
#
|
||||
# Create a properly themed scrolled listbox.
|
||||
# This is exactly right on XP but may need adjusting on other platforms.
|
||||
#
|
||||
proc ::tk::fontchooser::ttk_slistbox {w args} {
|
||||
set f [ttk::frame $w -style FontchooserFrame -padding 2]
|
||||
if {[catch {
|
||||
listbox $f.list -relief flat -highlightthickness 0 -borderwidth 0 {*}$args
|
||||
ttk::scrollbar $f.vs -command [list $f.list yview]
|
||||
$f.list configure -yscrollcommand [list $f.vs set]
|
||||
grid $f.list $f.vs -sticky news
|
||||
grid rowconfigure $f 0 -weight 1
|
||||
grid columnconfigure $f 0 -weight 1
|
||||
interp hide {} $w
|
||||
interp alias {} $w {} $f.list
|
||||
} err opt]} {
|
||||
destroy $f
|
||||
return -options $opt $err
|
||||
}
|
||||
return $w
|
||||
}
|
||||
|
|
@ -0,0 +1,717 @@
|
|||
# iconlist.tcl
|
||||
#
|
||||
# Implements the icon-list megawidget used in the "Tk" standard file
|
||||
# selection dialog boxes.
|
||||
#
|
||||
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
|
||||
# Copyright (c) 2009 Donal K. Fellows
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution of
|
||||
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
# API Summary:
|
||||
# tk::IconList <path> ?<option> <value>? ...
|
||||
# <path> add <imageName> <itemList>
|
||||
# <path> cget <option>
|
||||
# <path> configure ?<option>? ?<value>? ...
|
||||
# <path> deleteall
|
||||
# <path> destroy
|
||||
# <path> get <itemIndex>
|
||||
# <path> index <index>
|
||||
# <path> invoke
|
||||
# <path> see <index>
|
||||
# <path> selection anchor ?<int>?
|
||||
# <path> selection clear <first> ?<last>?
|
||||
# <path> selection get
|
||||
# <path> selection includes <item>
|
||||
# <path> selection set <first> ?<last>?
|
||||
|
||||
package require Tk
|
||||
|
||||
::tk::Megawidget create ::tk::IconList ::tk::FocusableWidget {
|
||||
variable w canvas sbar accel accelCB fill font index \
|
||||
itemList itemsPerColumn list maxIH maxIW maxTH maxTW noScroll \
|
||||
numItems oldX oldY options rect selected selection textList
|
||||
constructor args {
|
||||
next {*}$args
|
||||
set accelCB {}
|
||||
}
|
||||
destructor {
|
||||
my Reset
|
||||
next
|
||||
}
|
||||
|
||||
method GetSpecs {} {
|
||||
concat [next] {
|
||||
{-command "" "" ""}
|
||||
{-font "" "" "TkIconFont"}
|
||||
{-multiple "" "" "0"}
|
||||
}
|
||||
}
|
||||
|
||||
# ----------------------------------------------------------------------
|
||||
|
||||
method index i {
|
||||
if {![info exist list]} {
|
||||
set list {}
|
||||
}
|
||||
switch -regexp -- $i {
|
||||
"^-?[0-9]+$" {
|
||||
if {$i < 0} {
|
||||
set i 0
|
||||
}
|
||||
if {$i >= [llength $list]} {
|
||||
set i [expr {[llength $list] - 1}]
|
||||
}
|
||||
return $i
|
||||
}
|
||||
"^anchor$" {
|
||||
return $index(anchor)
|
||||
}
|
||||
"^end$" {
|
||||
return [llength $list]
|
||||
}
|
||||
"@-?[0-9]+,-?[0-9]+" {
|
||||
scan $i "@%d,%d" x y
|
||||
set item [$canvas find closest \
|
||||
[$canvas canvasx $x] [$canvas canvasy $y]]
|
||||
return [lindex [$canvas itemcget $item -tags] 1]
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
method selection {op args} {
|
||||
switch -exact -- $op {
|
||||
anchor {
|
||||
if {[llength $args] == 1} {
|
||||
set index(anchor) [$w index [lindex $args 0]]
|
||||
} else {
|
||||
return $index(anchor)
|
||||
}
|
||||
}
|
||||
clear {
|
||||
switch [llength $args] {
|
||||
2 {
|
||||
lassign $args first last
|
||||
}
|
||||
1 {
|
||||
set first [set last [lindex $args 0]]
|
||||
}
|
||||
default {
|
||||
return -code error -errorcode {TCL WRONGARGS} \
|
||||
"wrong # args: should be\
|
||||
\"[lrange [info level 0] 0 1] first ?last?\""
|
||||
}
|
||||
}
|
||||
|
||||
set first [$w index $first]
|
||||
set last [$w index $last]
|
||||
if {$first > $last} {
|
||||
set tmp $first
|
||||
set first $last
|
||||
set last $tmp
|
||||
}
|
||||
set ind 0
|
||||
foreach item $selection {
|
||||
if {$item >= $first} {
|
||||
set first $ind
|
||||
break
|
||||
}
|
||||
incr ind
|
||||
}
|
||||
set ind [expr {[llength $selection] - 1}]
|
||||
for {} {$ind >= 0} {incr ind -1} {
|
||||
set item [lindex $selection $ind]
|
||||
if {$item <= $last} {
|
||||
set last $ind
|
||||
break
|
||||
}
|
||||
}
|
||||
|
||||
if {$first > $last} {
|
||||
return
|
||||
}
|
||||
set selection [lreplace $selection $first $last]
|
||||
event generate $w <<ListboxSelect>>
|
||||
my DrawSelection
|
||||
}
|
||||
get {
|
||||
return $selection
|
||||
}
|
||||
includes {
|
||||
return [expr {[lindex $args 0] in $selection}]
|
||||
}
|
||||
set {
|
||||
switch [llength $args] {
|
||||
2 {
|
||||
lassign $args first last
|
||||
}
|
||||
1 {
|
||||
set first [set last [lindex $args 0]]
|
||||
}
|
||||
default {
|
||||
return -code error -errorcode {TCL WRONGARGS} \
|
||||
"wrong # args: should be\
|
||||
\"[lrange [info level 0] 0 1] first ?last?\""
|
||||
}
|
||||
}
|
||||
|
||||
set first [$w index $first]
|
||||
set last [$w index $last]
|
||||
if {$first > $last} {
|
||||
set tmp $first
|
||||
set first $last
|
||||
set last $tmp
|
||||
}
|
||||
|
||||
for {set i $first} {$i <= $last} {incr i} {
|
||||
lappend selection $i
|
||||
}
|
||||
set selection [lsort -integer -unique $selection]
|
||||
event generate $w <<ListboxSelect>>
|
||||
my DrawSelection
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
method get item {
|
||||
set rTag [lindex $list $item 2]
|
||||
lassign $itemList($rTag) iTag tTag text serial
|
||||
return $text
|
||||
}
|
||||
|
||||
# Deletes all the items inside the canvas subwidget and reset the
|
||||
# iconList's state.
|
||||
#
|
||||
method deleteall {} {
|
||||
$canvas delete all
|
||||
unset -nocomplain selected rect list itemList
|
||||
set maxIW 1
|
||||
set maxIH 1
|
||||
set maxTW 1
|
||||
set maxTH 1
|
||||
set numItems 0
|
||||
set noScroll 1
|
||||
set selection {}
|
||||
set index(anchor) ""
|
||||
$sbar set 0.0 1.0
|
||||
$canvas xview moveto 0
|
||||
}
|
||||
|
||||
# Adds an icon into the IconList with the designated image and text
|
||||
#
|
||||
method add {image items} {
|
||||
foreach text $items {
|
||||
set iID item$numItems
|
||||
set iTag [$canvas create image 0 0 -image $image -anchor nw \
|
||||
-tags [list icon $numItems $iID]]
|
||||
set tTag [$canvas create text 0 0 -text $text -anchor nw \
|
||||
-font $options(-font) -fill $fill \
|
||||
-tags [list text $numItems $iID]]
|
||||
set rTag [$canvas create rect 0 0 0 0 -fill "" -outline "" \
|
||||
-tags [list rect $numItems $iID]]
|
||||
|
||||
lassign [$canvas bbox $iTag] x1 y1 x2 y2
|
||||
set iW [expr {$x2 - $x1}]
|
||||
set iH [expr {$y2 - $y1}]
|
||||
if {$maxIW < $iW} {
|
||||
set maxIW $iW
|
||||
}
|
||||
if {$maxIH < $iH} {
|
||||
set maxIH $iH
|
||||
}
|
||||
|
||||
lassign [$canvas bbox $tTag] x1 y1 x2 y2
|
||||
set tW [expr {$x2 - $x1}]
|
||||
set tH [expr {$y2 - $y1}]
|
||||
if {$maxTW < $tW} {
|
||||
set maxTW $tW
|
||||
}
|
||||
if {$maxTH < $tH} {
|
||||
set maxTH $tH
|
||||
}
|
||||
|
||||
lappend list [list $iTag $tTag $rTag $iW $iH $tW $tH $numItems]
|
||||
set itemList($rTag) [list $iTag $tTag $text $numItems]
|
||||
set textList($numItems) [string tolower $text]
|
||||
incr numItems
|
||||
}
|
||||
my WhenIdle Arrange
|
||||
return
|
||||
}
|
||||
|
||||
# Gets called when the user invokes the IconList (usually by
|
||||
# double-clicking or pressing the Return key).
|
||||
#
|
||||
method invoke {} {
|
||||
if {$options(-command) ne "" && [llength $selection]} {
|
||||
uplevel #0 $options(-command)
|
||||
}
|
||||
}
|
||||
|
||||
# If the item is not (completely) visible, scroll the canvas so that it
|
||||
# becomes visible.
|
||||
#
|
||||
method see rTag {
|
||||
if {$noScroll} {
|
||||
return
|
||||
}
|
||||
set sRegion [$canvas cget -scrollregion]
|
||||
if {$sRegion eq ""} {
|
||||
return
|
||||
}
|
||||
|
||||
if {$rTag < 0 || $rTag >= [llength $list]} {
|
||||
return
|
||||
}
|
||||
|
||||
set bbox [$canvas bbox item$rTag]
|
||||
set pad [expr {[$canvas cget -highlightthickness]+[$canvas cget -bd]}]
|
||||
|
||||
set x1 [lindex $bbox 0]
|
||||
set x2 [lindex $bbox 2]
|
||||
incr x1 [expr {$pad * -2}]
|
||||
incr x2 [expr {$pad * -1}]
|
||||
|
||||
set cW [expr {[winfo width $canvas] - $pad*2}]
|
||||
|
||||
set scrollW [expr {[lindex $sRegion 2]-[lindex $sRegion 0]+1}]
|
||||
set dispX [expr {int([lindex [$canvas xview] 0]*$scrollW)}]
|
||||
set oldDispX $dispX
|
||||
|
||||
# check if out of the right edge
|
||||
#
|
||||
if {($x2 - $dispX) >= $cW} {
|
||||
set dispX [expr {$x2 - $cW}]
|
||||
}
|
||||
# check if out of the left edge
|
||||
#
|
||||
if {($x1 - $dispX) < 0} {
|
||||
set dispX $x1
|
||||
}
|
||||
|
||||
if {$oldDispX ne $dispX} {
|
||||
set fraction [expr {double($dispX) / double($scrollW)}]
|
||||
$canvas xview moveto $fraction
|
||||
}
|
||||
}
|
||||
|
||||
# ----------------------------------------------------------------------
|
||||
|
||||
# Places the icons in a column-major arrangement.
|
||||
#
|
||||
method Arrange {} {
|
||||
if {![info exists list]} {
|
||||
if {[info exists canvas] && [winfo exists $canvas]} {
|
||||
set noScroll 1
|
||||
$sbar configure -command ""
|
||||
}
|
||||
return
|
||||
}
|
||||
|
||||
set W [winfo width $canvas]
|
||||
set H [winfo height $canvas]
|
||||
set pad [expr {[$canvas cget -highlightthickness]+[$canvas cget -bd]}]
|
||||
if {$pad < 2} {
|
||||
set pad 2
|
||||
}
|
||||
|
||||
incr W [expr {$pad*-2}]
|
||||
incr H [expr {$pad*-2}]
|
||||
|
||||
set dx [expr {$maxIW + $maxTW + 8}]
|
||||
if {$maxTH > $maxIH} {
|
||||
set dy $maxTH
|
||||
} else {
|
||||
set dy $maxIH
|
||||
}
|
||||
incr dy 2
|
||||
set shift [expr {$maxIW + 4}]
|
||||
|
||||
set x [expr {$pad * 2}]
|
||||
set y [expr {$pad * 1}] ; # Why * 1 ?
|
||||
set usedColumn 0
|
||||
foreach sublist $list {
|
||||
set usedColumn 1
|
||||
lassign $sublist iTag tTag rTag iW iH tW tH
|
||||
|
||||
set i_dy [expr {($dy - $iH)/2}]
|
||||
set t_dy [expr {($dy - $tH)/2}]
|
||||
|
||||
$canvas coords $iTag $x [expr {$y + $i_dy}]
|
||||
$canvas coords $tTag [expr {$x + $shift}] [expr {$y + $t_dy}]
|
||||
$canvas coords $rTag $x $y [expr {$x+$dx}] [expr {$y+$dy}]
|
||||
|
||||
incr y $dy
|
||||
if {($y + $dy) > $H} {
|
||||
set y [expr {$pad * 1}] ; # *1 ?
|
||||
incr x $dx
|
||||
set usedColumn 0
|
||||
}
|
||||
}
|
||||
|
||||
if {$usedColumn} {
|
||||
set sW [expr {$x + $dx}]
|
||||
} else {
|
||||
set sW $x
|
||||
}
|
||||
|
||||
if {$sW < $W} {
|
||||
$canvas configure -scrollregion [list $pad $pad $sW $H]
|
||||
$sbar configure -command ""
|
||||
$canvas xview moveto 0
|
||||
set noScroll 1
|
||||
} else {
|
||||
$canvas configure -scrollregion [list $pad $pad $sW $H]
|
||||
$sbar configure -command [list $canvas xview]
|
||||
set noScroll 0
|
||||
}
|
||||
|
||||
set itemsPerColumn [expr {($H-$pad) / $dy}]
|
||||
if {$itemsPerColumn < 1} {
|
||||
set itemsPerColumn 1
|
||||
}
|
||||
|
||||
my DrawSelection
|
||||
}
|
||||
|
||||
method DrawSelection {} {
|
||||
$canvas delete selection
|
||||
$canvas itemconfigure selectionText -fill black
|
||||
$canvas dtag selectionText
|
||||
set cbg [ttk::style lookup TEntry -selectbackground focus]
|
||||
set cfg [ttk::style lookup TEntry -selectforeground focus]
|
||||
foreach item $selection {
|
||||
set rTag [lindex $list $item 2]
|
||||
foreach {iTag tTag text serial} $itemList($rTag) {
|
||||
break
|
||||
}
|
||||
|
||||
set bbox [$canvas bbox $tTag]
|
||||
$canvas create rect $bbox -fill $cbg -outline $cbg \
|
||||
-tags selection
|
||||
$canvas itemconfigure $tTag -fill $cfg -tags selectionText
|
||||
}
|
||||
$canvas lower selection
|
||||
return
|
||||
}
|
||||
|
||||
# Creates an IconList widget by assembling a canvas widget and a
|
||||
# scrollbar widget. Sets all the bindings necessary for the IconList's
|
||||
# operations.
|
||||
#
|
||||
method Create {} {
|
||||
variable hull
|
||||
set sbar [ttk::scrollbar $hull.sbar -orient horizontal -takefocus 0]
|
||||
catch {$sbar configure -highlightthickness 0}
|
||||
set canvas [canvas $hull.canvas -highlightthick 0 -takefocus 1 \
|
||||
-width 400 -height 120 -background white]
|
||||
pack $sbar -side bottom -fill x -padx 2 -pady {0 2}
|
||||
pack $canvas -expand yes -fill both -padx 2 -pady {2 0}
|
||||
|
||||
$sbar configure -command [list $canvas xview]
|
||||
$canvas configure -xscrollcommand [list $sbar set]
|
||||
|
||||
# Initializes the max icon/text width and height and other variables
|
||||
#
|
||||
set maxIW 1
|
||||
set maxIH 1
|
||||
set maxTW 1
|
||||
set maxTH 1
|
||||
set numItems 0
|
||||
set noScroll 1
|
||||
set selection {}
|
||||
set index(anchor) ""
|
||||
set fg [option get $canvas foreground Foreground]
|
||||
if {$fg eq ""} {
|
||||
set fill black
|
||||
} else {
|
||||
set fill $fg
|
||||
}
|
||||
|
||||
# Creates the event bindings.
|
||||
#
|
||||
bind $canvas <Configure> [namespace code {my WhenIdle Arrange}]
|
||||
|
||||
bind $canvas <1> [namespace code {my Btn1 %x %y}]
|
||||
bind $canvas <B1-Motion> [namespace code {my Motion1 %x %y}]
|
||||
bind $canvas <B1-Leave> [namespace code {my Leave1 %x %y}]
|
||||
bind $canvas <Control-1> [namespace code {my CtrlBtn1 %x %y}]
|
||||
bind $canvas <Shift-1> [namespace code {my ShiftBtn1 %x %y}]
|
||||
bind $canvas <B1-Enter> [list tk::CancelRepeat]
|
||||
bind $canvas <ButtonRelease-1> [list tk::CancelRepeat]
|
||||
bind $canvas <Double-ButtonRelease-1> \
|
||||
[namespace code {my Double1 %x %y}]
|
||||
|
||||
bind $canvas <Control-B1-Motion> {;}
|
||||
bind $canvas <Shift-B1-Motion> [namespace code {my ShiftMotion1 %x %y}]
|
||||
|
||||
if {[tk windowingsystem] eq "aqua"} {
|
||||
bind $canvas <Shift-MouseWheel> [namespace code {my MouseWheel [expr {40 * (%D)}]}]
|
||||
bind $canvas <Option-Shift-MouseWheel> [namespace code {my MouseWheel [expr {400 * (%D)}]}]
|
||||
} else {
|
||||
bind $canvas <Shift-MouseWheel> [namespace code {my MouseWheel %D}]
|
||||
}
|
||||
if {[tk windowingsystem] eq "x11"} {
|
||||
bind $canvas <Shift-4> [namespace code {my MouseWheel 120}]
|
||||
bind $canvas <Shift-5> [namespace code {my MouseWheel -120}]
|
||||
}
|
||||
|
||||
bind $canvas <<PrevLine>> [namespace code {my UpDown -1}]
|
||||
bind $canvas <<NextLine>> [namespace code {my UpDown 1}]
|
||||
bind $canvas <<PrevChar>> [namespace code {my LeftRight -1}]
|
||||
bind $canvas <<NextChar>> [namespace code {my LeftRight 1}]
|
||||
bind $canvas <Return> [namespace code {my ReturnKey}]
|
||||
bind $canvas <KeyPress> [namespace code {my KeyPress %A}]
|
||||
bind $canvas <Control-KeyPress> ";"
|
||||
bind $canvas <Alt-KeyPress> ";"
|
||||
|
||||
bind $canvas <FocusIn> [namespace code {my FocusIn}]
|
||||
bind $canvas <FocusOut> [namespace code {my FocusOut}]
|
||||
|
||||
return $w
|
||||
}
|
||||
|
||||
# This procedure is invoked when the mouse leaves an entry window with
|
||||
# button 1 down. It scrolls the window up, down, left, or right,
|
||||
# depending on where the mouse left the window, and reschedules itself
|
||||
# as an "after" command so that the window continues to scroll until the
|
||||
# mouse moves back into the window or the mouse button is released.
|
||||
#
|
||||
method AutoScan {} {
|
||||
if {![winfo exists $w]} return
|
||||
set x $oldX
|
||||
set y $oldY
|
||||
if {$noScroll} {
|
||||
return
|
||||
}
|
||||
if {$x >= [winfo width $canvas]} {
|
||||
$canvas xview scroll 1 units
|
||||
} elseif {$x < 0} {
|
||||
$canvas xview scroll -1 units
|
||||
} elseif {$y >= [winfo height $canvas]} {
|
||||
# do nothing
|
||||
} elseif {$y < 0} {
|
||||
# do nothing
|
||||
} else {
|
||||
return
|
||||
}
|
||||
my Motion1 $x $y
|
||||
set ::tk::Priv(afterId) [after 50 [namespace code {my AutoScan}]]
|
||||
}
|
||||
|
||||
# ----------------------------------------------------------------------
|
||||
|
||||
# Event handlers
|
||||
method MouseWheel {amount} {
|
||||
if {$noScroll || $::tk_strictMotif} {
|
||||
return
|
||||
}
|
||||
if {$amount > 0} {
|
||||
$canvas xview scroll [expr {(-119-$amount) / 120}] units
|
||||
} else {
|
||||
$canvas xview scroll [expr {-($amount / 120)}] units
|
||||
}
|
||||
}
|
||||
method Btn1 {x y} {
|
||||
focus $canvas
|
||||
set i [$w index @$x,$y]
|
||||
if {$i eq ""} {
|
||||
return
|
||||
}
|
||||
$w selection clear 0 end
|
||||
$w selection set $i
|
||||
$w selection anchor $i
|
||||
}
|
||||
method CtrlBtn1 {x y} {
|
||||
if {$options(-multiple)} {
|
||||
focus $canvas
|
||||
set i [$w index @$x,$y]
|
||||
if {$i eq ""} {
|
||||
return
|
||||
}
|
||||
if {[$w selection includes $i]} {
|
||||
$w selection clear $i
|
||||
} else {
|
||||
$w selection set $i
|
||||
$w selection anchor $i
|
||||
}
|
||||
}
|
||||
}
|
||||
method ShiftBtn1 {x y} {
|
||||
if {$options(-multiple)} {
|
||||
focus $canvas
|
||||
set i [$w index @$x,$y]
|
||||
if {$i eq ""} {
|
||||
return
|
||||
}
|
||||
if {[$w index anchor] eq ""} {
|
||||
$w selection anchor $i
|
||||
}
|
||||
$w selection clear 0 end
|
||||
$w selection set anchor $i
|
||||
}
|
||||
}
|
||||
|
||||
# Gets called on button-1 motions
|
||||
#
|
||||
method Motion1 {x y} {
|
||||
set oldX $x
|
||||
set oldY $y
|
||||
set i [$w index @$x,$y]
|
||||
if {$i eq ""} {
|
||||
return
|
||||
}
|
||||
$w selection clear 0 end
|
||||
$w selection set $i
|
||||
}
|
||||
method ShiftMotion1 {x y} {
|
||||
set oldX $x
|
||||
set oldY $y
|
||||
set i [$w index @$x,$y]
|
||||
if {$i eq ""} {
|
||||
return
|
||||
}
|
||||
$w selection clear 0 end
|
||||
$w selection set anchor $i
|
||||
}
|
||||
method Double1 {x y} {
|
||||
if {[llength $selection]} {
|
||||
$w invoke
|
||||
}
|
||||
}
|
||||
method ReturnKey {} {
|
||||
$w invoke
|
||||
}
|
||||
method Leave1 {x y} {
|
||||
set oldX $x
|
||||
set oldY $y
|
||||
my AutoScan
|
||||
}
|
||||
method FocusIn {} {
|
||||
$w state focus
|
||||
if {![info exists list]} {
|
||||
return
|
||||
}
|
||||
if {[llength $selection]} {
|
||||
my DrawSelection
|
||||
}
|
||||
}
|
||||
method FocusOut {} {
|
||||
$w state !focus
|
||||
$w selection clear 0 end
|
||||
}
|
||||
|
||||
# Moves the active element up or down by one element
|
||||
#
|
||||
# Arguments:
|
||||
# amount - +1 to move down one item, -1 to move back one item.
|
||||
#
|
||||
method UpDown amount {
|
||||
if {![info exists list]} {
|
||||
return
|
||||
}
|
||||
set curr [$w selection get]
|
||||
if {[llength $curr] == 0} {
|
||||
set i 0
|
||||
} else {
|
||||
set i [$w index anchor]
|
||||
if {$i eq ""} {
|
||||
return
|
||||
}
|
||||
incr i $amount
|
||||
}
|
||||
$w selection clear 0 end
|
||||
$w selection set $i
|
||||
$w selection anchor $i
|
||||
$w see $i
|
||||
}
|
||||
|
||||
# Moves the active element left or right by one column
|
||||
#
|
||||
# Arguments:
|
||||
# amount - +1 to move right one column, -1 to move left one
|
||||
# column
|
||||
#
|
||||
method LeftRight amount {
|
||||
if {![info exists list]} {
|
||||
return
|
||||
}
|
||||
set curr [$w selection get]
|
||||
if {[llength $curr] == 0} {
|
||||
set i 0
|
||||
} else {
|
||||
set i [$w index anchor]
|
||||
if {$i eq ""} {
|
||||
return
|
||||
}
|
||||
incr i [expr {$amount * $itemsPerColumn}]
|
||||
}
|
||||
$w selection clear 0 end
|
||||
$w selection set $i
|
||||
$w selection anchor $i
|
||||
$w see $i
|
||||
}
|
||||
|
||||
# Gets called when user enters an arbitrary key in the listbox.
|
||||
#
|
||||
method KeyPress key {
|
||||
append accel $key
|
||||
my Goto $accel
|
||||
after cancel $accelCB
|
||||
set accelCB [after 500 [namespace code {my Reset}]]
|
||||
}
|
||||
|
||||
method Goto text {
|
||||
if {![info exists list]} {
|
||||
return
|
||||
}
|
||||
if {$text eq "" || $numItems == 0} {
|
||||
return
|
||||
}
|
||||
|
||||
if {[llength [$w selection get]]} {
|
||||
set start [$w index anchor]
|
||||
} else {
|
||||
set start 0
|
||||
}
|
||||
set theIndex -1
|
||||
set less 0
|
||||
set len [string length $text]
|
||||
set len0 [expr {$len - 1}]
|
||||
set i $start
|
||||
|
||||
# Search forward until we find a filename whose prefix is a
|
||||
# case-insensitive match with $text
|
||||
while {1} {
|
||||
if {[string equal -nocase -length $len0 $textList($i) $text]} {
|
||||
set theIndex $i
|
||||
break
|
||||
}
|
||||
incr i
|
||||
if {$i == $numItems} {
|
||||
set i 0
|
||||
}
|
||||
if {$i == $start} {
|
||||
break
|
||||
}
|
||||
}
|
||||
|
||||
if {$theIndex >= 0} {
|
||||
$w selection clear 0 end
|
||||
$w selection set $theIndex
|
||||
$w selection anchor $theIndex
|
||||
$w see $theIndex
|
||||
}
|
||||
}
|
||||
method Reset {} {
|
||||
unset -nocomplain accel
|
||||
}
|
||||
}
|
||||
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# fill-column: 78
|
||||
# End:
|
||||
|
|
@ -0,0 +1,153 @@
|
|||
# icons.tcl --
|
||||
#
|
||||
# A set of stock icons for use in Tk dialogs. The icons used here
|
||||
# were provided by the Tango Desktop project which provides a
|
||||
# unified set of high quality icons licensed under the
|
||||
# Creative Commons Attribution Share-Alike license
|
||||
# (http://creativecommons.org/licenses/by-sa/3.0/)
|
||||
#
|
||||
# See http://tango.freedesktop.org/Tango_Desktop_Project
|
||||
#
|
||||
# Copyright (c) 2009 Pat Thoyts <patthoyts@users.sourceforge.net>
|
||||
|
||||
namespace eval ::tk::icons {}
|
||||
|
||||
image create photo ::tk::icons::warning -data {
|
||||
iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAABHNCSVQICAgIfAhkiAAABSZJREFU
|
||||
WIXll1toVEcYgL+Zc87u2Yu7MYmrWRuTJuvdiMuqiJd4yYKXgMQKVkSjFR80kFIVJfWCWlvpg4h9
|
||||
8sXGWGof8iKNICYSo6JgkCBEJRG8ImYThNrNxmaTeM7pQ5IlJkabi0/9YZhhZv7///4z/8zPgf+7
|
||||
KCNRLgdlJijXwRyuDTlcxV9hbzv8nQmxMjg+XDtiOEplkG9PSfkztGmTgmFQd+FCVzwa3fYN/PHZ
|
||||
AcpBaReicW5xcbb64IEQqko8Lc26d/58cxS+/BY6hmJvyEfQBoUpwWCmW1FErKaGWHU13uRk4QkE
|
||||
UtxQNFR7QwIoB4eiKD9PWbVKbb10CZmaCqmpxCormRYO26QQx85B0mcD+AeK0xYvHqu1tNDx+DH6
|
||||
gQM4jh0j3tCA3tGBLyfHLuD7zwJwAcYqun44sHy51nr5MsqsWWj5+djCYdS5c4ldvUr24sU2qarf
|
||||
lUL6qAN0wqH0vDy7+fAhXZEI+v79CNmt7igpofPVK5SmJvyhkJBwYlQBSiHd7vUWZ86bp8WqqtCW
|
||||
LkVbuBAhBEIItGAQ2+rVxG7cICMY1KTDsekc5IwagIQTmStXis47dzBiMfR9+xCi+wb39s79+zFi
|
||||
MczGRjLmzTMlnBoVgLMwyzF+/Cb/lClq2/Xr2AoKUKdPxzAMWltbiUajmKaJkpGBY8sW3tbW4g8E
|
||||
VNXrXVEKK0YMoMKp7Px8K15Tg2VZOHbvBiASiRAMBgkGg0QiEYQQOIuLsRSFrnv3yJo/HxVOW594
|
||||
7D4KUAa57qysvNSUFOVtbS32rVuRfj9CCFwuV2Kfy+VCCIFMScFVVET7/fukJidLm883rQy+HhaA
|
||||
BUII8cvUNWt4W1WFcLvRd+5MnHl/AOjOB+eOHchx44jX1ZEdCqkSTpaDbcgA5+GrpNmzc9ymKdvr
|
||||
67Hv2oVMSko4cjgcKIqCoijoup64EdLpxLV3Lx1PnuCVUrgmTfK9hV1DAjgKqlSUk1PCYdl25QrS
|
||||
70cvLEw4SWS+04nT6XxvXgiBc8MGtKlTaa+rIysnR1Ok/OF38PxngAzY4VuwYKL99WvR8fQpjj17
|
||||
kLqeiL6393g8eDyeAWBSVfEcOkRXczOOaBRvVpZuDPJEDwD4DVyKrv+UlZurxSorUWfMQC8oGOBc
|
||||
CDHgC/Rdc4TD2BctIl5fT+bkyTahaXvOw8RPApiwd2Ju7hjZ2EhXSwvOkhKQcoADgIqKCioqKgYc
|
||||
QW9LOnIEIxZDbWpiXCCABT9+FKAUxtm83pKMUEiLVVejLVqEtmTJB50LIdi2bRuFPbnRd7232efM
|
||||
wbVuHR2PHjHR77dJXS8sg5mDAihweFJenmrevYvR1oazpGTQ6IQQaJqG7ClI/dd655IOHsSyLMSL
|
||||
F6QFAib9nugEQClk2Xy+orTsbK3t1i3sa9ei5eQMGr0QgvLyci5evDiocyEEtsxMPNu30/nsGRO8
|
||||
XlVzu8NlkNvrV+0T/fHMZcusrtu3MeNx9PXrobUVq8cYQrw3TrRub1h9+v573Bs3Ej1zBvP5c/zp
|
||||
6dbLhoaTwPy+ANKCfF92thq7dg2A6JYt/fNlxGK8eUNSerryHEJHQT8K8V4A5ztojty8OeaLzZul
|
||||
1DSwLCzDANPEMozusWFgmWZ33288YK3/nGlixuM0v3xpWfDX0Z4i1VupXEWwIgRnJfhGPfQ+YsLr
|
||||
+7DzNFwCuvqWyiRg7DSYoIBu9smPkYqEd4AwIN4ITUAL0A4Da7UC6ICdEfy2fUBMoAvo7GnWKNoe
|
||||
mfwLcAuinuFNL7QAAAAASUVORK5CYII=
|
||||
}
|
||||
|
||||
image create photo ::tk::icons::error -data {
|
||||
iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAABHNCSVQICAgIfAhkiAAABiRJREFU
|
||||
WIXFl11sHFcVgL97Z/bX693sbtd2ipOqCU7sQKukFYUigQgv/a+hoZGoqipvfQKpAsEDD0hIvCHE
|
||||
j/pQ3sIDUdOiIqUyqXioEFSUhqit7cRJFJpEruxs1mt77Z3d2Z259/KwM5vZXTtOERJXOrozZ+6e
|
||||
852fuXcW/s9D3O3Cs1Bow1Nx234BKQ9qpYpK6yFLSseScsVoveApdUrAzNOw9j8DOAMTtmX9RsM3
|
||||
SqOjevcXDqUzu8dI5AvEc8O0axu4q6s4yzdZvnCxUSmXLWHMXzxjXpmGq/81wGmIZ6T8NXDi8w8d
|
||||
id//+GPS8j1YWQXHgVYbfA/sGCRiMDQExTzKtvn3zDv6k9m5FsacXNT6+y+D95kAZqCEEO/cMzIy
|
||||
9eBLLybjyodrN6DpDqw1/dfpFNw3TtuSfPz7P7irlZUL2pjHn4GVuwJ4G/JCiLl9U1OjB58/ZnP5
|
||||
Mqxv3NGpMWZAz64cHNzHlTf/5N9YuHzTMeaLx6HW78+K3pwGKynEu/snJycOHPuWzdw81BuDUQZO
|
||||
dfQ+MmvAuC1MdY3i178izUo15VZXj07DyTf6OGX0Jivlz0vFwgMTz3/bNnMXO0ZCo8b0iIk4C0WF
|
||||
zsP1TRc1e4l9x56N5YuFwxkpf9afgW4J/gi7M1IuHH3lezm5uAQbmwOpjc79ujArA2uMgWwGMz7K
|
||||
P377u/WW1pPTUB7IQFrKXx44NJWRbQ9d2+hGqbeRMEoTZEQFJdERfVgmvVFH+D57Jw9k4lL+YqAE
|
||||
pyGnjZm+95knLHVjcVvHA6WIPgtLE+hVH4i6vsS9T3zTVsY8NwPZHoAUPFUs5JVQCt1q9zqORKm3
|
||||
iLKrF6IjkfSHOiUlqu0hhCSXHdYePNYDEBPiu6MT+zOquo6JGNGhESkxUnYNmkCnLQtjWRgpMRG9
|
||||
CtZ3JdD7axsU9+3N2EK8EALYQcNMpvfuQTcaXUMIAa+/Hi0Xgs9weASjefx4p5mFQDdbpD63G/HR
|
||||
hakeAA2l+EgJU652iIMMyO2sRoYxBq1191oIgZQSITqooT0A7fnEirswUAp/LwG0MZlYIY9WqpPa
|
||||
IHU7Da01Sqluo4UQSil830dr3emVsBeMIZbLoI0Z7gGQQtTbjoOOxW/XewcApVQ38jsBNs6fx6tW
|
||||
O70Si+GWKwghNsM1NoCAW81KJTeUjKNbrR2N7uS4B7TRwJ+fR6TTxO4fxzUeAio9AMCl+tVrE0NH
|
||||
DmM2nU4DAu6JE53UGoNfLuNdv45xnO4OF/ZKz+4X2T179I6D5To0NupouNgD4Btzqjx/8WjpS0cy
|
||||
PU1Tr6MqFfylpc4bss1W26/rBwyfybECtcvXNrUxp3oAXJjZ2Kxb7cVP8P61gDGgWy2M624Z5d1E
|
||||
3wNkDDKdwMQkjtuygbMhgAQ4DjUhxFvL/5z15X1jeLUaynW7p1u484WiuL3V9m/NoV6F50Ogjx3Y
|
||||
Q/mDBV8a3piGzR4AAFfrHy4vlesmm0bks7edRQ6aAafcPoZVH2AUXOYzkI5TvbVa9+FHREYX4Bgs
|
||||
I8RrV9/9oJF4eBKTjO8YvdoCJgqujcGkEqQemmDxb7OOFOLV6FHcAwBQ1/onTtOd/fTvH3rJRx/A
|
||||
pBIDqd0q+p5sRaInnWDoywdZem+u7bbaH9W1/il9Y2Brfwt22TBfKOVHxr92JOacv4S/UuttuC06
|
||||
PKoHsEs5hg7vZ/m9eW+zWltuwoNbfRNuebacgXsEnE2lkof2Hn04ZRouzQvXUU5z29cwFGs4TWpy
|
||||
HJGK8+lfP256bnuuDU8+B9WtfG17uL0GsTF4VQrxYn60kBh55JDEbdG6uYq/7qDdFtpTELOQyQRW
|
||||
Lk1sLI+MW9w6d8Wv3Vrz2nDyJPzgDDS287MVgAAywBCQ+Q5MTsOPs/BIMpVQ2bFCKlnMYg+nsYeS
|
||||
eE6TVq1Be3WD9ZtrTc9tWetw7k341dtwBagDTmTeESAdAAxH5z0w9iQ8ehi+moWxBGRsiPvguVBf
|
||||
h8qH8P6f4dxSp9PrdN73cN6k859R3U0J0nS+28JMpIM5FUgCiNP5X2ECox7gAk06KQ8ldLzZ7/xO
|
||||
ANHnscBhCkgGjuOB3gb8CEAbaAWO3UA34DQ6/gPnmhBFs5mqXAAAAABJRU5ErkJggg==
|
||||
}
|
||||
|
||||
image create photo ::tk::icons::information -data {
|
||||
iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAABmJLR0QA/wD/AP+gvaeTAAAACXBI
|
||||
WXMAAAsTAAALEwEAmpwYAAAAB3RJTUUH1gUdFDM4pWaDogAABwNJREFUWMPFlltsVNcVhv+199ln
|
||||
bh7PjAdfMGNDcA04EKMkJlIsBVJVbRqlEVUrqyW0QAtFTVWpjVpFfamUF6K+tCTKQyXn0jaiShOr
|
||||
bRqRoHJpEEoIEBucENuk2OViPB5f5j5zrvuc3YcMFQ8FPBFVj7S0paN91v+tf1/OAv7PD9UzeeCp
|
||||
p0KRCrYyHtymoPrgySYAANdyBBr2Peu1agP+NrR/v3nHAb6/52d7wfivWlet11NdvZG21laEwzo0
|
||||
RvA9F4uLi7h08bxxaWLUVp78xSsv/XrwjgAMDDyjRxPWUGOy5Uu9/VsjEA3I5KvIVQ240gHIh9CA
|
||||
5YkwelIJRATw94NvGpnpK0fL+eDA0NAzzq3ya7cDjCbsoWWr1j+y4f4vB/41Z8JTeaxqE7hndSNi
|
||||
EeELzn3LkapQdfzJTE5JV/GBb28LHz327lcnzp4ZAvB1AOpmAvyWtv/g6R9GW1c+uf6Bx0Kfzpjo
|
||||
TmnYtDaKtkTAj4aEFBqTnJPUOfciIeG3N4XVQtmyzl/JuY8/fH9wOjO/smvVmuy5s+8P1w2wa9dP
|
||||
46SLN3sf2ha7uiixaU0Qna06NA6PMXIZQRJBMiIXRBKABygv3hBQV+bK1dmcoR7d3Bc5c/pk/8YN
|
||||
fYOjo6es/6bDbgbAdLa9uXNj2PYF2pOEloQGAiRIuUTkME42J7IZweYES+NkckZWWNfseEPAKJtO
|
||||
oWxLu69/c5jpbPtNdW7qPwvsbO1cF8pVLKxs0+HD94gpl0AOQTlEsDkjizFmMk4WESyNM4NzMgOC
|
||||
VYI6q17OlIp9992ngek769+EvtfVEI3jWqaKgAgAIAlFLuOwGZHDiTnElGQgF4DvM1LKV7Bdz2NE
|
||||
xaCuhQpVm1Y0p5qhvNV1AyjlRTWhwVM2TMdzgkJzieAQyGGMbMZgfwZBEiBPA3xX+VSouAvBAFeM
|
||||
yDddD7rgpHw/WjcAMa0EZScZk5heqFrxiO4BzCGCzYgsBrI4I5sYcxlBKl/5WdOdd6S0gxoLEZEi
|
||||
Iq4AnzGq1r0HiPhYuZRFU1R3FgqWkS1aZQA2gWzOyGQcJudkaAwVR3qz8yXzvCXlzJoViaagrlWC
|
||||
jJnLm8Jarli2GNMm6wbwPPO31y6Ollc2N3pcI+fyYjW/8a5EKqQTz5WtdLHsTi1W7Im5vDlcMdxx
|
||||
wVk2Ys9/pTI3+WhAaIauM+MLbYnlH46MVKVyX6v7Hhg9e2ps3doN32ld0Rlrb1nmmK4stCdCSCUj
|
||||
Le1NwW6uXJ08m/t2OarBXh0ie0syHu0plKtTFGw8n4o33q1z1XngD7+X3C/uHBkZces7hoAi1946
|
||||
fPSvtpDlYFdLPDI8mR03HC87frXwFpgqLYuFuzrbkg8m49EeDsqDa+cizXcNpppia5ui+sYXnn+O
|
||||
29LbOTg4aHzun9GOPT/pDemhf3xzx25DicjkiqaAIs4zhumMRUJaPhzgJZ0LQ5C7gXjQL1kS0YD+
|
||||
o337nhWlYvHJV178zZ9vlZ/dDuDVl57/2HWt755894hINoYSmZx11TYKCUZKCs4cnQuDmGtfvDiR
|
||||
dD3n04aA6J4YHzeLhfLg7cSXBAAA5NPpufS1WFjwkFSelZ6ZLWfn0kliTDJdue8dO9qenp2d1DVR
|
||||
4cTarlyZJgV5dim5lwTw8sv7c1L6H89cm6FlDcHVhlOJffThsa9d+ud72y5+cnTn2PjJJ1avjOoE
|
||||
SnBiPadOfRDTGT5YSm5tqR2R7Zp7//L6gRPf27NjVaolqS9MCzh28W6mgDXdKxCNRb/oOlV18O3D
|
||||
1xzXGXpx8LnZO94Tbt/x+MFYouexh7dsQU/PWjRGI+BcAyMgm1vAO28fxvj4xOX5jL7u0KEX7Dvq
|
||||
AAC0Nucf2rLZhq8Y3njjT8gulOBKDw0NAQjNQT435eQWL3iHDk3YS81ZF0B6psI/GbuAXbu+gQf7
|
||||
H4ArPeQWC5jLZKCUhQvjWb2QD3bVk5PVM9nz5LML8waOH38fekBHIhFDqqMFXd0pnDhxGmMTU3Bd
|
||||
9/X/GQDntO/eezswMPBjaFwAABxH4sKFq+jt7cX6ni6EQuJbdeWsZ3J3d/PTmqaEYUyhXDZBTEOh
|
||||
WIIQwOi5jzA1eRnZXPFSPO7/bmbGlLfqhus5BVotRH9/x7rGxtBeIQJPACrMOYNSPpRiUIpnlTIO
|
||||
nzmT+eX8fLH8WZMKF4Csje7ncUAHEKhFcHq6ZE5OZoc7O3tlc3N33+7dP9c2bXoE09NlO52uHDhy
|
||||
ZOTVatUWte+otsTXg2pQSwagG6r/jwsAQul0erqjo+OesbGx1tHRUT+fz48dP378j57neQD8mtB1
|
||||
B1TtnV9zo64loJqoXhtFDUQHEGhvb2/2fZ9nMpliTcAFYNdC1sIBYN1sCeq5Ca9bqtWcu9Fe3FDl
|
||||
9Uqvu3HLjfhvTUo85WzjhogAAAAASUVORK5CYII=
|
||||
}
|
||||
|
||||
image create photo ::tk::icons::question -data {
|
||||
iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAABHNCSVQICAgIfAhkiAAACG5JREFU
|
||||
WIXFl3twVdUVxn97n3Nubm7euZcghEdeBBICEQUFIgVECqIo1uJMp3WodqyjMzpjZ7TTh20cK31N
|
||||
/2jL2FYdKXaqRcbnDKGpoBFaAY1BHgHMgyRKQkJy87yv3Nyzd/84594k1RlppzPumTXn3Dl3r/Wd
|
||||
b31rrbPhS17iSv+4bl2t2ZFhrRGI7QKxRkMAyHEfjwgYEOgjNnpfcXjiSENDbeL/AqBoW22uGE/7
|
||||
MYL7yubN4MYVpVkrquaKqwJZ+LPTARgcjdIbHKOx+aI+9EH7WGvnZdA8q9PGf9b5eu3w/wygaPPO
|
||||
h6Uhntxcsyj9/q+vtMrnBa6Is7ZPgzzzyvGJ/YfPRpWWj3fWff93/xWAonW1Xu3z/nVx6cxNTz74
|
||||
1YzK4gIQjuN/nfyEEx9fIjgaYXAkhhAQyE3Hn5PBsvJZrF46l5I5+QB83NnP40+/FT7d1ltPOPrN
|
||||
zoba2BcCWLy91hMOp72/bX1VxU/u3+BJ91i0fhrkuTcaaTzbjTQkhpQIIZBSIBApL1prtNYsryhk
|
||||
xy1XUzonn1g8wVPPvh1/5dDpcz5f7LrmfbXxqfGM6eG1yCw+9uq2G6tW7nxoU5plGrzecJYnnnub
|
||||
SwMhTNPAmmKmYWCaBoYpMQyJaRhIQ3IpGOKt4+1k+dKoLJ7BjStKjb6hcN7JloFrhlsO7oUnPh9A
|
||||
8Rbvo6uuLrr3N4/ckm4Ykt/vPcqe/R9hGAamaWJZbnDL+W2axqRJA8NlxzAkAI3newhF4lxbMZs1
|
||||
y4rNM+19c0PZ++NDLQff+0wKCu/Y6c/UVsubv/12/ryZubxUf5Ln3vgQ0zKnvK1kadkMlpQUUFEU
|
||||
oCDPR25WOuPxBH2DYZpa+qg/3kEoGsdWCttWJGzF3ZuXcuf6Ci5eHmXrw7sHR4mXd7/2w+A0Bvyl
|
||||
N+265/bl19+8eqE8c6GPn+85jGkYWC4Ay3Luf/3AV1g038+MXB8+rwfDkKR5TPKyvCyan8+qqtmc
|
||||
au8nFrcdnQCn2vuoLptJSWEeE7bynDjdXTDUcvBNAAmweF1tpmXKu+65bYWh0Ty97zhSyGkUO0BM
|
||||
hBAI4RAXTyjiCYWUEukKMz/Ly/b1C7EsE49lYlkmhjTYvf8jNHD3lmsM0zTuWryuNhPABIj4vFvW
|
||||
Xl0s87PTOdXWS8snQTwec4ro3DSYBglbcfx8P+8199I7FMEQgg3L53N7TWkKXOV8Px7LJCFtXKx0
|
||||
dA9zrnOAyqIAa68tkQePtm4BXpaO9vWOm65b4EPAkY+6HDEZTt4NN/dJML946QSv/fMCA6PjpHks
|
||||
LI/F2a5BtNYpMUtJirGpLL7f3A3AxpXlPiHFjhQDaJZVlc0EoPWT4DQ1m8ZkKizTJDRuY1mmC04i
|
||||
pWDNksJUD9Bac7E/jGUZrmuN1qCU5sKlIQAqSwrQWi+bBCDwF+RnAk5fl27wqeYAkZM9wLWaxVex
|
||||
qnJmKritFO+e7sMyDdBOc1JKYxiSkdA4CMGM3Aw02j+VAfLcwTIWibuiEpNApJMSw208ydJcu3QW
|
||||
axZPCW7bHGjspmcwimkYTmAlMWzHTyTmDMiczLRU/ctkNxgajboPvUghppuUGFJMY6O6OJ/ViwIo
|
||||
pVBKYds2dR9e4uPuMbc7Tm9MUgqyM70AjITHUy1IAghNsH8oDEAgz4cQOIqWjkkpEC4rSYfXL/Sn
|
||||
giulONYyRFd/1GXKAZxkUrgvkp/tAAgORxAQnAQg5InmC5cBWDgv4NS5EAhAINzyIlVmUgiy040U
|
||||
9Uop2voiKYakEAiRvDp7EYKS2XkAnOvsR0h5IqUBrfWeQ8fb1t2xvtJXs3QuB462TfZokbxMGZxC
|
||||
8If6DtI8Fh6PhcdjojSpBuXin7Kc3csXzQLgrWOtEWWrPSkAvkis7kjTBTU8FqOypIAF8/x09Y6Q
|
||||
FGjyTdHJstLsWDsnNZIBXj7Wj1LKYSS5B412nRTNymHBnHxGQ+O8836r8kVidakUNDfUhhIJtfcv
|
||||
dU22AO69dRlCCNeZU8fJe6U0ylZYBlgGmNKx+ESCiYRNwlYoWzn/UxqtHOB3ra8AAX/7x0nbttXe
|
||||
5oba0GQVAPGE9dju1z4Y7u4fY9F8P9/YWOUEV06O7eTVnXBTBaiUIj4xwcSETSJhk7BtbNtOPdta
|
||||
U0ZpYS59wRB/2ndsOBa3HkvGTU3D0fb6aE7ZBt3RM1yzuabcqiwKEI5N0N495ChaSKcihJPRa0pz
|
||||
sbUmYTugPmgbJmErB4DLxETC5oYlhWxdXUrCVvxgV32krav/qa4Djx76D4kllxalt/7q9e2bqjf9
|
||||
9Lsb0oQQHGrsYO+hc0gp3emW/Bhxm5NbZlqD0g79CTcFt60u4YYlhWhg5/MN4y/WNdW3vfnoNhD6
|
||||
Mww46wlmV9/w6snzA1sHRqKBVUvnGQvm+qkuKyA4GqVvKOJAdrcn8zz14yNh2ywozOVbGyuoKg4w
|
||||
PmHzyxcOx1+sazqTlhbZ3H92vT29Pj5nzVn1SLqVH3ipunzOxqceutlX6n7lXrw8yqn2flq7hxgL
|
||||
TzAWiyOFICfTS44vjbLCXKqK/cwOOHOl49IwP9r192hT84V3e4+9cF90sC0IRL8QAOADsgvXfu9B
|
||||
b3bgkTs3LPN+52srzPlX5V7RUerTy6M8/0Zj4uUDH45Hg13PdB/9425gzLUhQH0RgDQgC8hKLyid
|
||||
7a/c9oCV4d9WVTpLbF5TmX5tRaGYkecjJ8MLAkZD4wyMRGg636PrDjfHzrT26NhYT33w1Kt/Hh/u
|
||||
6XUDh4BBIHwlDIBTohlANpBhWb6s7PKNK30FCzZa6dnVYORoIX2OExVF26Px8NCZSN/5d0bb3mlK
|
||||
JGIhHLpDwLAL4jPnxSs9nBqABXhddrw4XdRygSrABuKuxYBx9/6KDqlf2vo3PYe56vmkuwMAAAAA
|
||||
SUVORK5CYII=
|
||||
}
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
This software is copyrighted by the Regents of the University of
|
||||
California, Sun Microsystems, Inc., Scriptics Corporation, ActiveState
|
||||
Corporation, Apple Inc. and other parties. The following terms apply to
|
||||
all files associated with the software unless explicitly disclaimed in
|
||||
individual files.
|
||||
|
||||
The authors hereby grant permission to use, copy, modify, distribute,
|
||||
and license this software and its documentation for any purpose, provided
|
||||
that existing copyright notices are retained in all copies and that this
|
||||
notice is included verbatim in any distributions. No written agreement,
|
||||
license, or royalty fee is required for any of the authorized uses.
|
||||
Modifications to this software may be copyrighted by their authors
|
||||
and need not follow the licensing terms described here, provided that
|
||||
the new terms are clearly indicated on the first page of each file where
|
||||
they apply.
|
||||
|
||||
IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
|
||||
FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
|
||||
ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
|
||||
DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
|
||||
POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
|
||||
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
|
||||
IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
|
||||
NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
|
||||
MODIFICATIONS.
|
||||
|
||||
GOVERNMENT USE: If you are acquiring this software on behalf of the
|
||||
U.S. government, the Government shall have only "Restricted Rights"
|
||||
in the software and related documentation as defined in the Federal
|
||||
Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
|
||||
are acquiring the software on behalf of the Department of Defense, the
|
||||
software shall be classified as "Commercial Computer Software" and the
|
||||
Government shall have only "Restricted Rights" as defined in Clause
|
||||
252.227-7013 (b) (3) of DFARs. Notwithstanding the foregoing, the
|
||||
authors grant the U.S. Government and others acting in its behalf
|
||||
permission to use and distribute the software in accordance with the
|
||||
terms specified in this license.
|
||||
|
|
@ -0,0 +1,560 @@
|
|||
# listbox.tcl --
|
||||
#
|
||||
# This file defines the default bindings for Tk listbox widgets
|
||||
# and provides procedures that help in implementing those bindings.
|
||||
#
|
||||
# Copyright (c) 1994 The Regents of the University of California.
|
||||
# Copyright (c) 1994-1995 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998 by Scriptics Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
#--------------------------------------------------------------------------
|
||||
# tk::Priv elements used in this file:
|
||||
#
|
||||
# afterId - Token returned by "after" for autoscanning.
|
||||
# listboxPrev - The last element to be selected or deselected
|
||||
# during a selection operation.
|
||||
# listboxSelection - All of the items that were selected before the
|
||||
# current selection operation (such as a mouse
|
||||
# drag) started; used to cancel an operation.
|
||||
#--------------------------------------------------------------------------
|
||||
|
||||
#-------------------------------------------------------------------------
|
||||
# The code below creates the default class bindings for listboxes.
|
||||
#-------------------------------------------------------------------------
|
||||
|
||||
# Note: the check for existence of %W below is because this binding
|
||||
# is sometimes invoked after a window has been deleted (e.g. because
|
||||
# there is a double-click binding on the widget that deletes it). Users
|
||||
# can put "break"s in their bindings to avoid the error, but this check
|
||||
# makes that unnecessary.
|
||||
|
||||
bind Listbox <1> {
|
||||
if {[winfo exists %W]} {
|
||||
tk::ListboxBeginSelect %W [%W index @%x,%y] 1
|
||||
}
|
||||
}
|
||||
|
||||
# Ignore double clicks so that users can define their own behaviors.
|
||||
# Among other things, this prevents errors if the user deletes the
|
||||
# listbox on a double click.
|
||||
|
||||
bind Listbox <Double-1> {
|
||||
# Empty script
|
||||
}
|
||||
|
||||
bind Listbox <B1-Motion> {
|
||||
set tk::Priv(x) %x
|
||||
set tk::Priv(y) %y
|
||||
tk::ListboxMotion %W [%W index @%x,%y]
|
||||
}
|
||||
bind Listbox <ButtonRelease-1> {
|
||||
tk::CancelRepeat
|
||||
%W activate @%x,%y
|
||||
}
|
||||
bind Listbox <Shift-1> {
|
||||
tk::ListboxBeginExtend %W [%W index @%x,%y]
|
||||
}
|
||||
bind Listbox <Control-1> {
|
||||
tk::ListboxBeginToggle %W [%W index @%x,%y]
|
||||
}
|
||||
bind Listbox <B1-Leave> {
|
||||
set tk::Priv(x) %x
|
||||
set tk::Priv(y) %y
|
||||
tk::ListboxAutoScan %W
|
||||
}
|
||||
bind Listbox <B1-Enter> {
|
||||
tk::CancelRepeat
|
||||
}
|
||||
|
||||
bind Listbox <<PrevLine>> {
|
||||
tk::ListboxUpDown %W -1
|
||||
}
|
||||
bind Listbox <<SelectPrevLine>> {
|
||||
tk::ListboxExtendUpDown %W -1
|
||||
}
|
||||
bind Listbox <<NextLine>> {
|
||||
tk::ListboxUpDown %W 1
|
||||
}
|
||||
bind Listbox <<SelectNextLine>> {
|
||||
tk::ListboxExtendUpDown %W 1
|
||||
}
|
||||
bind Listbox <<PrevChar>> {
|
||||
%W xview scroll -1 units
|
||||
}
|
||||
bind Listbox <<PrevWord>> {
|
||||
%W xview scroll -1 pages
|
||||
}
|
||||
bind Listbox <<NextChar>> {
|
||||
%W xview scroll 1 units
|
||||
}
|
||||
bind Listbox <<NextWord>> {
|
||||
%W xview scroll 1 pages
|
||||
}
|
||||
bind Listbox <Prior> {
|
||||
%W yview scroll -1 pages
|
||||
%W activate @0,0
|
||||
}
|
||||
bind Listbox <Next> {
|
||||
%W yview scroll 1 pages
|
||||
%W activate @0,0
|
||||
}
|
||||
bind Listbox <Control-Prior> {
|
||||
%W xview scroll -1 pages
|
||||
}
|
||||
bind Listbox <Control-Next> {
|
||||
%W xview scroll 1 pages
|
||||
}
|
||||
bind Listbox <<LineStart>> {
|
||||
%W xview moveto 0
|
||||
}
|
||||
bind Listbox <<LineEnd>> {
|
||||
%W xview moveto 1
|
||||
}
|
||||
bind Listbox <Control-Home> {
|
||||
%W activate 0
|
||||
%W see 0
|
||||
%W selection clear 0 end
|
||||
%W selection set 0
|
||||
tk::FireListboxSelectEvent %W
|
||||
}
|
||||
bind Listbox <Control-Shift-Home> {
|
||||
tk::ListboxDataExtend %W 0
|
||||
}
|
||||
bind Listbox <Control-End> {
|
||||
%W activate end
|
||||
%W see end
|
||||
%W selection clear 0 end
|
||||
%W selection set end
|
||||
tk::FireListboxSelectEvent %W
|
||||
}
|
||||
bind Listbox <Control-Shift-End> {
|
||||
tk::ListboxDataExtend %W [%W index end]
|
||||
}
|
||||
bind Listbox <<Copy>> {
|
||||
if {[selection own -displayof %W] eq "%W"} {
|
||||
clipboard clear -displayof %W
|
||||
clipboard append -displayof %W [selection get -displayof %W]
|
||||
}
|
||||
}
|
||||
bind Listbox <space> {
|
||||
tk::ListboxBeginSelect %W [%W index active]
|
||||
}
|
||||
bind Listbox <<Invoke>> {
|
||||
tk::ListboxBeginSelect %W [%W index active]
|
||||
}
|
||||
bind Listbox <Select> {
|
||||
tk::ListboxBeginSelect %W [%W index active]
|
||||
}
|
||||
bind Listbox <Control-Shift-space> {
|
||||
tk::ListboxBeginExtend %W [%W index active]
|
||||
}
|
||||
bind Listbox <Shift-Select> {
|
||||
tk::ListboxBeginExtend %W [%W index active]
|
||||
}
|
||||
bind Listbox <Escape> {
|
||||
tk::ListboxCancel %W
|
||||
}
|
||||
bind Listbox <<SelectAll>> {
|
||||
tk::ListboxSelectAll %W
|
||||
}
|
||||
bind Listbox <<SelectNone>> {
|
||||
if {[%W cget -selectmode] ne "browse"} {
|
||||
%W selection clear 0 end
|
||||
tk::FireListboxSelectEvent %W
|
||||
}
|
||||
}
|
||||
|
||||
# Additional Tk bindings that aren't part of the Motif look and feel:
|
||||
|
||||
bind Listbox <2> {
|
||||
%W scan mark %x %y
|
||||
}
|
||||
bind Listbox <B2-Motion> {
|
||||
%W scan dragto %x %y
|
||||
}
|
||||
|
||||
# The MouseWheel will typically only fire on Windows and Mac OS X.
|
||||
# However, someone could use the "event generate" command to produce
|
||||
# one on other platforms.
|
||||
|
||||
if {[tk windowingsystem] eq "aqua"} {
|
||||
bind Listbox <MouseWheel> {
|
||||
%W yview scroll [expr {-(%D)}] units
|
||||
}
|
||||
bind Listbox <Option-MouseWheel> {
|
||||
%W yview scroll [expr {-10 * (%D)}] units
|
||||
}
|
||||
bind Listbox <Shift-MouseWheel> {
|
||||
%W xview scroll [expr {-(%D)}] units
|
||||
}
|
||||
bind Listbox <Shift-Option-MouseWheel> {
|
||||
%W xview scroll [expr {-10 * (%D)}] units
|
||||
}
|
||||
} else {
|
||||
bind Listbox <MouseWheel> {
|
||||
if {%D >= 0} {
|
||||
%W yview scroll [expr {-%D/30}] units
|
||||
} else {
|
||||
%W yview scroll [expr {(29-%D)/30}] units
|
||||
}
|
||||
}
|
||||
bind Listbox <Shift-MouseWheel> {
|
||||
if {%D >= 0} {
|
||||
%W xview scroll [expr {-%D/30}] units
|
||||
} else {
|
||||
%W xview scroll [expr {(29-%D)/30}] units
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if {[tk windowingsystem] eq "x11"} {
|
||||
# Support for mousewheels on Linux/Unix commonly comes through mapping
|
||||
# the wheel to the extended buttons. If you have a mousewheel, find
|
||||
# Linux configuration info at:
|
||||
# http://linuxreviews.org/howtos/xfree/mouse/
|
||||
bind Listbox <4> {
|
||||
if {!$tk_strictMotif} {
|
||||
%W yview scroll -5 units
|
||||
}
|
||||
}
|
||||
bind Listbox <Shift-4> {
|
||||
if {!$tk_strictMotif} {
|
||||
%W xview scroll -5 units
|
||||
}
|
||||
}
|
||||
bind Listbox <5> {
|
||||
if {!$tk_strictMotif} {
|
||||
%W yview scroll 5 units
|
||||
}
|
||||
}
|
||||
bind Listbox <Shift-5> {
|
||||
if {!$tk_strictMotif} {
|
||||
%W xview scroll 5 units
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::ListboxBeginSelect --
|
||||
#
|
||||
# This procedure is typically invoked on button-1 presses. It begins
|
||||
# the process of making a selection in the listbox. Its exact behavior
|
||||
# depends on the selection mode currently in effect for the listbox;
|
||||
# see the Motif documentation for details.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The listbox widget.
|
||||
# el - The element for the selection operation (typically the
|
||||
# one under the pointer). Must be in numerical form.
|
||||
|
||||
proc ::tk::ListboxBeginSelect {w el {focus 1}} {
|
||||
variable ::tk::Priv
|
||||
if {[$w cget -selectmode] eq "multiple"} {
|
||||
if {[$w selection includes $el]} {
|
||||
$w selection clear $el
|
||||
} else {
|
||||
$w selection set $el
|
||||
}
|
||||
} else {
|
||||
$w selection clear 0 end
|
||||
$w selection set $el
|
||||
$w selection anchor $el
|
||||
set Priv(listboxSelection) {}
|
||||
set Priv(listboxPrev) $el
|
||||
}
|
||||
tk::FireListboxSelectEvent $w
|
||||
# check existence as ListboxSelect may destroy us
|
||||
if {$focus && [winfo exists $w] && [$w cget -state] eq "normal"} {
|
||||
focus $w
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::ListboxMotion --
|
||||
#
|
||||
# This procedure is called to process mouse motion events while
|
||||
# button 1 is down. It may move or extend the selection, depending
|
||||
# on the listbox's selection mode.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The listbox widget.
|
||||
# el - The element under the pointer (must be a number).
|
||||
|
||||
proc ::tk::ListboxMotion {w el} {
|
||||
variable ::tk::Priv
|
||||
if {$el == $Priv(listboxPrev)} {
|
||||
return
|
||||
}
|
||||
set anchor [$w index anchor]
|
||||
switch [$w cget -selectmode] {
|
||||
browse {
|
||||
$w selection clear 0 end
|
||||
$w selection set $el
|
||||
set Priv(listboxPrev) $el
|
||||
tk::FireListboxSelectEvent $w
|
||||
}
|
||||
extended {
|
||||
set i $Priv(listboxPrev)
|
||||
if {$i eq ""} {
|
||||
set i $el
|
||||
$w selection set $el
|
||||
}
|
||||
if {[$w selection includes anchor]} {
|
||||
$w selection clear $i $el
|
||||
$w selection set anchor $el
|
||||
} else {
|
||||
$w selection clear $i $el
|
||||
$w selection clear anchor $el
|
||||
}
|
||||
if {![info exists Priv(listboxSelection)]} {
|
||||
set Priv(listboxSelection) [$w curselection]
|
||||
}
|
||||
while {($i < $el) && ($i < $anchor)} {
|
||||
if {$i in $Priv(listboxSelection)} {
|
||||
$w selection set $i
|
||||
}
|
||||
incr i
|
||||
}
|
||||
while {($i > $el) && ($i > $anchor)} {
|
||||
if {$i in $Priv(listboxSelection)} {
|
||||
$w selection set $i
|
||||
}
|
||||
incr i -1
|
||||
}
|
||||
set Priv(listboxPrev) $el
|
||||
tk::FireListboxSelectEvent $w
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::ListboxBeginExtend --
|
||||
#
|
||||
# This procedure is typically invoked on shift-button-1 presses. It
|
||||
# begins the process of extending a selection in the listbox. Its
|
||||
# exact behavior depends on the selection mode currently in effect
|
||||
# for the listbox; see the Motif documentation for details.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The listbox widget.
|
||||
# el - The element for the selection operation (typically the
|
||||
# one under the pointer). Must be in numerical form.
|
||||
|
||||
proc ::tk::ListboxBeginExtend {w el} {
|
||||
if {[$w cget -selectmode] eq "extended"} {
|
||||
if {[$w selection includes anchor]} {
|
||||
ListboxMotion $w $el
|
||||
} else {
|
||||
# No selection yet; simulate the begin-select operation.
|
||||
ListboxBeginSelect $w $el
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::ListboxBeginToggle --
|
||||
#
|
||||
# This procedure is typically invoked on control-button-1 presses. It
|
||||
# begins the process of toggling a selection in the listbox. Its
|
||||
# exact behavior depends on the selection mode currently in effect
|
||||
# for the listbox; see the Motif documentation for details.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The listbox widget.
|
||||
# el - The element for the selection operation (typically the
|
||||
# one under the pointer). Must be in numerical form.
|
||||
|
||||
proc ::tk::ListboxBeginToggle {w el} {
|
||||
variable ::tk::Priv
|
||||
if {[$w cget -selectmode] eq "extended"} {
|
||||
set Priv(listboxSelection) [$w curselection]
|
||||
set Priv(listboxPrev) $el
|
||||
$w selection anchor $el
|
||||
if {[$w selection includes $el]} {
|
||||
$w selection clear $el
|
||||
} else {
|
||||
$w selection set $el
|
||||
}
|
||||
tk::FireListboxSelectEvent $w
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::ListboxAutoScan --
|
||||
# This procedure is invoked when the mouse leaves an entry window
|
||||
# with button 1 down. It scrolls the window up, down, left, or
|
||||
# right, depending on where the mouse left the window, and reschedules
|
||||
# itself as an "after" command so that the window continues to scroll until
|
||||
# the mouse moves back into the window or the mouse button is released.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The entry window.
|
||||
|
||||
proc ::tk::ListboxAutoScan {w} {
|
||||
variable ::tk::Priv
|
||||
if {![winfo exists $w]} return
|
||||
set x $Priv(x)
|
||||
set y $Priv(y)
|
||||
if {$y >= [winfo height $w]} {
|
||||
$w yview scroll 1 units
|
||||
} elseif {$y < 0} {
|
||||
$w yview scroll -1 units
|
||||
} elseif {$x >= [winfo width $w]} {
|
||||
$w xview scroll 2 units
|
||||
} elseif {$x < 0} {
|
||||
$w xview scroll -2 units
|
||||
} else {
|
||||
return
|
||||
}
|
||||
ListboxMotion $w [$w index @$x,$y]
|
||||
set Priv(afterId) [after 50 [list tk::ListboxAutoScan $w]]
|
||||
}
|
||||
|
||||
# ::tk::ListboxUpDown --
|
||||
#
|
||||
# Moves the location cursor (active element) up or down by one element,
|
||||
# and changes the selection if we're in browse or extended selection
|
||||
# mode.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The listbox widget.
|
||||
# amount - +1 to move down one item, -1 to move back one item.
|
||||
|
||||
proc ::tk::ListboxUpDown {w amount} {
|
||||
variable ::tk::Priv
|
||||
$w activate [expr {[$w index active] + $amount}]
|
||||
$w see active
|
||||
switch [$w cget -selectmode] {
|
||||
browse {
|
||||
$w selection clear 0 end
|
||||
$w selection set active
|
||||
tk::FireListboxSelectEvent $w
|
||||
}
|
||||
extended {
|
||||
$w selection clear 0 end
|
||||
$w selection set active
|
||||
$w selection anchor active
|
||||
set Priv(listboxPrev) [$w index active]
|
||||
set Priv(listboxSelection) {}
|
||||
tk::FireListboxSelectEvent $w
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::ListboxExtendUpDown --
|
||||
#
|
||||
# Does nothing unless we're in extended selection mode; in this
|
||||
# case it moves the location cursor (active element) up or down by
|
||||
# one element, and extends the selection to that point.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The listbox widget.
|
||||
# amount - +1 to move down one item, -1 to move back one item.
|
||||
|
||||
proc ::tk::ListboxExtendUpDown {w amount} {
|
||||
variable ::tk::Priv
|
||||
if {[$w cget -selectmode] ne "extended"} {
|
||||
return
|
||||
}
|
||||
set active [$w index active]
|
||||
if {![info exists Priv(listboxSelection)]} {
|
||||
$w selection set $active
|
||||
set Priv(listboxSelection) [$w curselection]
|
||||
}
|
||||
$w activate [expr {$active + $amount}]
|
||||
$w see active
|
||||
ListboxMotion $w [$w index active]
|
||||
}
|
||||
|
||||
# ::tk::ListboxDataExtend
|
||||
#
|
||||
# This procedure is called for key-presses such as Shift-KEndData.
|
||||
# If the selection mode isn't multiple or extend then it does nothing.
|
||||
# Otherwise it moves the active element to el and, if we're in
|
||||
# extended mode, extends the selection to that point.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The listbox widget.
|
||||
# el - An integer element number.
|
||||
|
||||
proc ::tk::ListboxDataExtend {w el} {
|
||||
set mode [$w cget -selectmode]
|
||||
if {$mode eq "extended"} {
|
||||
$w activate $el
|
||||
$w see $el
|
||||
if {[$w selection includes anchor]} {
|
||||
ListboxMotion $w $el
|
||||
}
|
||||
} elseif {$mode eq "multiple"} {
|
||||
$w activate $el
|
||||
$w see $el
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::ListboxCancel
|
||||
#
|
||||
# This procedure is invoked to cancel an extended selection in
|
||||
# progress. If there is an extended selection in progress, it
|
||||
# restores all of the items between the active one and the anchor
|
||||
# to their previous selection state.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The listbox widget.
|
||||
|
||||
proc ::tk::ListboxCancel w {
|
||||
variable ::tk::Priv
|
||||
if {[$w cget -selectmode] ne "extended"} {
|
||||
return
|
||||
}
|
||||
set first [$w index anchor]
|
||||
set last $Priv(listboxPrev)
|
||||
if {$last eq ""} {
|
||||
# Not actually doing any selection right now
|
||||
return
|
||||
}
|
||||
if {$first > $last} {
|
||||
set tmp $first
|
||||
set first $last
|
||||
set last $tmp
|
||||
}
|
||||
$w selection clear $first $last
|
||||
while {$first <= $last} {
|
||||
if {$first in $Priv(listboxSelection)} {
|
||||
$w selection set $first
|
||||
}
|
||||
incr first
|
||||
}
|
||||
tk::FireListboxSelectEvent $w
|
||||
}
|
||||
|
||||
# ::tk::ListboxSelectAll
|
||||
#
|
||||
# This procedure is invoked to handle the "select all" operation.
|
||||
# For single and browse mode, it just selects the active element.
|
||||
# Otherwise it selects everything in the widget.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The listbox widget.
|
||||
|
||||
proc ::tk::ListboxSelectAll w {
|
||||
set mode [$w cget -selectmode]
|
||||
if {$mode eq "single" || $mode eq "browse"} {
|
||||
$w selection clear 0 end
|
||||
$w selection set active
|
||||
} else {
|
||||
$w selection set 0 end
|
||||
}
|
||||
tk::FireListboxSelectEvent $w
|
||||
}
|
||||
|
||||
# ::tk::FireListboxSelectEvent
|
||||
#
|
||||
# Fire the <<ListboxSelect>> event if the listbox is not in disabled
|
||||
# state.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The listbox widget.
|
||||
|
||||
proc ::tk::FireListboxSelectEvent w {
|
||||
if {[$w cget -state] eq "normal"} {
|
||||
event generate $w <<ListboxSelect>>
|
||||
}
|
||||
}
|
||||
|
|
@ -0,0 +1,297 @@
|
|||
# megawidget.tcl
|
||||
#
|
||||
# Basic megawidget support classes. Experimental for any use other than
|
||||
# the ::tk::IconList megawdget, which is itself only designed for use in
|
||||
# the Unix file dialogs.
|
||||
#
|
||||
# Copyright (c) 2009-2010 Donal K. Fellows
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution of
|
||||
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
|
||||
package require Tk
|
||||
|
||||
::oo::class create ::tk::Megawidget {
|
||||
superclass ::oo::class
|
||||
method unknown {w args} {
|
||||
if {[string match .* $w]} {
|
||||
[self] create $w {*}$args
|
||||
return $w
|
||||
}
|
||||
next $w {*}$args
|
||||
}
|
||||
unexport new unknown
|
||||
self method create {name superclasses body} {
|
||||
next $name [list \
|
||||
superclass ::tk::MegawidgetClass {*}$superclasses]\;$body
|
||||
}
|
||||
}
|
||||
|
||||
::oo::class create ::tk::MegawidgetClass {
|
||||
variable w hull options IdleCallbacks
|
||||
constructor args {
|
||||
# Extract the "widget name" from the object name
|
||||
set w [namespace tail [self]]
|
||||
|
||||
# Configure things
|
||||
tclParseConfigSpec [my varname options] [my GetSpecs] "" $args
|
||||
|
||||
# Move the object out of the way of the hull widget
|
||||
rename [self] _tmp
|
||||
|
||||
# Make the hull widget(s)
|
||||
my CreateHull
|
||||
bind $hull <Destroy> [list [namespace which my] destroy]
|
||||
|
||||
# Rename things into their final places
|
||||
rename ::$w theWidget
|
||||
rename [self] ::$w
|
||||
|
||||
# Make the contents
|
||||
my Create
|
||||
}
|
||||
destructor {
|
||||
foreach {name cb} [array get IdleCallbacks] {
|
||||
after cancel $cb
|
||||
unset IdleCallbacks($name)
|
||||
}
|
||||
if {[winfo exists $w]} {
|
||||
bind $hull <Destroy> {}
|
||||
destroy $w
|
||||
}
|
||||
}
|
||||
|
||||
####################################################################
|
||||
#
|
||||
# MegawidgetClass::configure --
|
||||
#
|
||||
# Implementation of 'configure' for megawidgets. Emulates the operation
|
||||
# of the standard Tk configure method fairly closely, which makes things
|
||||
# substantially more complex than they otherwise would be.
|
||||
#
|
||||
# This method assumes that the 'GetSpecs' method returns a description
|
||||
# of all the specifications of the options (i.e., as Tk returns except
|
||||
# with the actual values removed). It also assumes that the 'options'
|
||||
# array in the class holds all options; it is up to subclasses to set
|
||||
# traces on that array if they want to respond to configuration changes.
|
||||
#
|
||||
# TODO: allow unambiguous abbreviations.
|
||||
#
|
||||
method configure args {
|
||||
# Configure behaves differently depending on the number of arguments
|
||||
set argc [llength $args]
|
||||
if {$argc == 0} {
|
||||
return [lmap spec [my GetSpecs] {
|
||||
lappend spec $options([lindex $spec 0])
|
||||
}]
|
||||
} elseif {$argc == 1} {
|
||||
set opt [lindex $args 0]
|
||||
if {[info exists options($opt)]} {
|
||||
set spec [lsearch -inline -index 0 -exact [my GetSpecs] $opt]
|
||||
return [linsert $spec end $options($opt)]
|
||||
}
|
||||
} elseif {$argc == 2} {
|
||||
# Special case for where we're setting a single option. This
|
||||
# avoids some of the costly operations. We still do the [array
|
||||
# get] as this gives a sufficiently-consistent trace.
|
||||
set opt [lindex $args 0]
|
||||
if {[dict exists [array get options] $opt]} {
|
||||
# Actually set the new value of the option. Use a catch to
|
||||
# allow a megawidget user to throw an error from a write trace
|
||||
# on the options array to reject invalid values.
|
||||
try {
|
||||
array set options $args
|
||||
} on error {ret info} {
|
||||
# Rethrow the error to get a clean stack trace
|
||||
return -code error -errorcode [dict get $info -errorcode] $ret
|
||||
}
|
||||
return
|
||||
}
|
||||
} elseif {$argc % 2 == 0} {
|
||||
# Check that all specified options exist. Any unknown option will
|
||||
# cause the merged dictionary to be bigger than the options array
|
||||
set merge [dict merge [array get options] $args]
|
||||
if {[dict size $merge] == [array size options]} {
|
||||
# Actually set the new values of the options. Use a catch to
|
||||
# allow a megawidget user to throw an error from a write trace
|
||||
# on the options array to reject invalid values
|
||||
try {
|
||||
array set options $args
|
||||
} on error {ret info} {
|
||||
# Rethrow the error to get a clean stack trace
|
||||
return -code error -errorcode [dict get $info -errorcode] $ret
|
||||
}
|
||||
return
|
||||
}
|
||||
# Due to the order of the merge, the unknown options will be at
|
||||
# the end of the dict. This makes the first unknown option easy to
|
||||
# find.
|
||||
set opt [lindex [dict keys $merge] [array size options]]
|
||||
} else {
|
||||
set opt [lindex $args end]
|
||||
return -code error -errorcode [list TK VALUE_MISSING] \
|
||||
"value for \"$opt\" missing"
|
||||
}
|
||||
return -code error -errorcode [list TK LOOKUP OPTION $opt] \
|
||||
"bad option \"$opt\": must be [tclListValidFlags options]"
|
||||
}
|
||||
|
||||
####################################################################
|
||||
#
|
||||
# MegawidgetClass::cget --
|
||||
#
|
||||
# Implementation of 'cget' for megawidgets. Emulates the operation of
|
||||
# the standard Tk cget method fairly closely.
|
||||
#
|
||||
# This method assumes that the 'options' array in the class holds all
|
||||
# options; it is up to subclasses to set traces on that array if they
|
||||
# want to respond to configuration reads.
|
||||
#
|
||||
# TODO: allow unambiguous abbreviations.
|
||||
#
|
||||
method cget option {
|
||||
return $options($option)
|
||||
}
|
||||
|
||||
####################################################################
|
||||
#
|
||||
# MegawidgetClass::TraceOption --
|
||||
#
|
||||
# Sets up the tracing of an element of the options variable.
|
||||
#
|
||||
method TraceOption {option method args} {
|
||||
set callback [list my $method {*}$args]
|
||||
trace add variable options($option) write [namespace code $callback]
|
||||
}
|
||||
|
||||
####################################################################
|
||||
#
|
||||
# MegawidgetClass::GetSpecs --
|
||||
#
|
||||
# Return a list of descriptions of options supported by this
|
||||
# megawidget. Each option is described by the 4-tuple list, consisting
|
||||
# of the name of the option, the "option database" name, the "option
|
||||
# database" class-name, and the default value of the option. These are
|
||||
# the same values returned by calling the configure method of a widget,
|
||||
# except without the current values of the options.
|
||||
#
|
||||
method GetSpecs {} {
|
||||
return {
|
||||
{-takefocus takeFocus TakeFocus {}}
|
||||
}
|
||||
}
|
||||
|
||||
####################################################################
|
||||
#
|
||||
# MegawidgetClass::CreateHull --
|
||||
#
|
||||
# Creates the real main widget of the megawidget. This is often a frame
|
||||
# or toplevel widget, but isn't always (lightweight megawidgets might
|
||||
# use a content widget directly).
|
||||
#
|
||||
# The name of the hull widget is given by the 'w' instance variable. The
|
||||
# name should be written into the 'hull' instance variable. The command
|
||||
# created by this method will be renamed.
|
||||
#
|
||||
method CreateHull {} {
|
||||
return -code error -errorcode {TCL OO ABSTRACT_METHOD} \
|
||||
"method must be overridden"
|
||||
}
|
||||
|
||||
####################################################################
|
||||
#
|
||||
# MegawidgetClass::Create --
|
||||
#
|
||||
# Creates the content of the megawidget. The name of the widget to
|
||||
# create the content in will be in the 'hull' instance variable.
|
||||
#
|
||||
method Create {} {
|
||||
return -code error -errorcode {TCL OO ABSTRACT_METHOD} \
|
||||
"method must be overridden"
|
||||
}
|
||||
|
||||
####################################################################
|
||||
#
|
||||
# MegawidgetClass::WhenIdle --
|
||||
#
|
||||
# Arrange for a method to be called on the current instance when Tk is
|
||||
# idle. Only one such method call per method will be queued; subsequent
|
||||
# queuing actions before the callback fires will be silently ignored.
|
||||
# The additional args will be passed to the callback, and the callbacks
|
||||
# will be properly cancelled if the widget is destroyed.
|
||||
#
|
||||
method WhenIdle {method args} {
|
||||
if {![info exists IdleCallbacks($method)]} {
|
||||
set IdleCallbacks($method) [after idle [list \
|
||||
[namespace which my] DoWhenIdle $method $args]]
|
||||
}
|
||||
}
|
||||
method DoWhenIdle {method arguments} {
|
||||
unset IdleCallbacks($method)
|
||||
tailcall my $method {*}$arguments
|
||||
}
|
||||
}
|
||||
|
||||
####################################################################
|
||||
#
|
||||
# tk::SimpleWidget --
|
||||
#
|
||||
# Simple megawidget class that makes it easy create widgets that behave
|
||||
# like a ttk widget. It creates the hull as a ttk::frame and maps the
|
||||
# state manipulation methods of the overall megawidget to the equivalent
|
||||
# operations on the ttk::frame.
|
||||
#
|
||||
::tk::Megawidget create ::tk::SimpleWidget {} {
|
||||
variable w hull options
|
||||
method GetSpecs {} {
|
||||
return {
|
||||
{-cursor cursor Cursor {}}
|
||||
{-takefocus takeFocus TakeFocus {}}
|
||||
}
|
||||
}
|
||||
method CreateHull {} {
|
||||
set hull [::ttk::frame $w -cursor $options(-cursor)]
|
||||
my TraceOption -cursor UpdateCursorOption
|
||||
}
|
||||
method UpdateCursorOption args {
|
||||
$hull configure -cursor $options(-cursor)
|
||||
}
|
||||
# Not fixed names, so can't forward
|
||||
method state args {
|
||||
tailcall $hull state {*}$args
|
||||
}
|
||||
method instate args {
|
||||
tailcall $hull instate {*}$args
|
||||
}
|
||||
}
|
||||
|
||||
####################################################################
|
||||
#
|
||||
# tk::FocusableWidget --
|
||||
#
|
||||
# Simple megawidget class that makes a ttk-like widget that has a focus
|
||||
# ring.
|
||||
#
|
||||
::tk::Megawidget create ::tk::FocusableWidget ::tk::SimpleWidget {
|
||||
variable w hull options
|
||||
method GetSpecs {} {
|
||||
return {
|
||||
{-cursor cursor Cursor {}}
|
||||
{-takefocus takeFocus TakeFocus ::ttk::takefocus}
|
||||
}
|
||||
}
|
||||
method CreateHull {} {
|
||||
ttk::frame $w
|
||||
set hull [ttk::entry $w.cHull -takefocus 0 -cursor $options(-cursor)]
|
||||
pack $hull -expand yes -fill both -ipadx 2 -ipady 2
|
||||
my TraceOption -cursor UpdateCursorOption
|
||||
}
|
||||
}
|
||||
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# fill-column: 78
|
||||
# End:
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,427 @@
|
|||
# msgbox.tcl --
|
||||
#
|
||||
# Implements messageboxes for platforms that do not have native
|
||||
# messagebox support.
|
||||
#
|
||||
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
|
||||
# Ensure existence of ::tk::dialog namespace
|
||||
#
|
||||
namespace eval ::tk::dialog {}
|
||||
|
||||
image create bitmap ::tk::dialog::b1 -foreground black \
|
||||
-data "#define b1_width 32\n#define b1_height 32
|
||||
static unsigned char q1_bits[] = {
|
||||
0x00, 0xf8, 0x1f, 0x00, 0x00, 0x07, 0xe0, 0x00, 0xc0, 0x00, 0x00, 0x03,
|
||||
0x20, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x08, 0x08, 0x00, 0x00, 0x10,
|
||||
0x04, 0x00, 0x00, 0x20, 0x02, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x40,
|
||||
0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,
|
||||
0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,
|
||||
0x01, 0x00, 0x00, 0x80, 0x02, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x40,
|
||||
0x04, 0x00, 0x00, 0x20, 0x08, 0x00, 0x00, 0x10, 0x10, 0x00, 0x00, 0x08,
|
||||
0x60, 0x00, 0x00, 0x04, 0x80, 0x03, 0x80, 0x03, 0x00, 0x0c, 0x78, 0x00,
|
||||
0x00, 0x30, 0x04, 0x00, 0x00, 0x40, 0x04, 0x00, 0x00, 0x40, 0x04, 0x00,
|
||||
0x00, 0x80, 0x04, 0x00, 0x00, 0x00, 0x05, 0x00, 0x00, 0x00, 0x06, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
|
||||
image create bitmap ::tk::dialog::b2 -foreground white \
|
||||
-data "#define b2_width 32\n#define b2_height 32
|
||||
static unsigned char b2_bits[] = {
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0xf8, 0x1f, 0x00, 0x00, 0xff, 0xff, 0x00,
|
||||
0xc0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x07, 0xf0, 0xff, 0xff, 0x0f,
|
||||
0xf8, 0xff, 0xff, 0x1f, 0xfc, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x3f,
|
||||
0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f,
|
||||
0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f,
|
||||
0xfe, 0xff, 0xff, 0x7f, 0xfc, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x3f,
|
||||
0xf8, 0xff, 0xff, 0x1f, 0xf0, 0xff, 0xff, 0x0f, 0xe0, 0xff, 0xff, 0x07,
|
||||
0x80, 0xff, 0xff, 0x03, 0x00, 0xfc, 0x7f, 0x00, 0x00, 0xf0, 0x07, 0x00,
|
||||
0x00, 0xc0, 0x03, 0x00, 0x00, 0x80, 0x03, 0x00, 0x00, 0x80, 0x03, 0x00,
|
||||
0x00, 0x00, 0x03, 0x00, 0x00, 0x00, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
|
||||
image create bitmap ::tk::dialog::q -foreground blue \
|
||||
-data "#define q_width 32\n#define q_height 32
|
||||
static unsigned char q_bits[] = {
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x07, 0x00,
|
||||
0x00, 0x10, 0x0f, 0x00, 0x00, 0x18, 0x1e, 0x00, 0x00, 0x38, 0x1e, 0x00,
|
||||
0x00, 0x38, 0x1e, 0x00, 0x00, 0x10, 0x0f, 0x00, 0x00, 0x80, 0x07, 0x00,
|
||||
0x00, 0xc0, 0x01, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0xc0, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0xe0, 0x01, 0x00,
|
||||
0x00, 0xe0, 0x01, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
|
||||
image create bitmap ::tk::dialog::i -foreground blue \
|
||||
-data "#define i_width 32\n#define i_height 32
|
||||
static unsigned char i_bits[] = {
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0xe0, 0x01, 0x00, 0x00, 0xf0, 0x03, 0x00, 0x00, 0xf0, 0x03, 0x00,
|
||||
0x00, 0xe0, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0xf8, 0x03, 0x00, 0x00, 0xf0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00,
|
||||
0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00,
|
||||
0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00, 0x00, 0xf0, 0x07, 0x00,
|
||||
0x00, 0xf8, 0x0f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
|
||||
image create bitmap ::tk::dialog::w1 -foreground black \
|
||||
-data "#define w1_width 32\n#define w1_height 32
|
||||
static unsigned char w1_bits[] = {
|
||||
0x00, 0x80, 0x01, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x20, 0x04, 0x00,
|
||||
0x00, 0x10, 0x04, 0x00, 0x00, 0x10, 0x08, 0x00, 0x00, 0x08, 0x08, 0x00,
|
||||
0x00, 0x08, 0x10, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x04, 0x20, 0x00,
|
||||
0x00, 0x02, 0x20, 0x00, 0x00, 0x02, 0x40, 0x00, 0x00, 0x01, 0x40, 0x00,
|
||||
0x00, 0x01, 0x80, 0x00, 0x80, 0x00, 0x80, 0x00, 0x80, 0x00, 0x00, 0x01,
|
||||
0x40, 0x00, 0x00, 0x01, 0x40, 0x00, 0x00, 0x02, 0x20, 0x00, 0x00, 0x02,
|
||||
0x20, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x08,
|
||||
0x08, 0x00, 0x00, 0x08, 0x08, 0x00, 0x00, 0x10, 0x04, 0x00, 0x00, 0x10,
|
||||
0x04, 0x00, 0x00, 0x20, 0x02, 0x00, 0x00, 0x20, 0x01, 0x00, 0x00, 0x40,
|
||||
0x01, 0x00, 0x00, 0x40, 0x01, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x20,
|
||||
0xfc, 0xff, 0xff, 0x1f, 0x00, 0x00, 0x00, 0x00};"
|
||||
image create bitmap ::tk::dialog::w2 -foreground yellow \
|
||||
-data "#define w2_width 32\n#define w2_height 32
|
||||
static unsigned char w2_bits[] = {
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0xc0, 0x03, 0x00,
|
||||
0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xf0, 0x07, 0x00,
|
||||
0x00, 0xf0, 0x0f, 0x00, 0x00, 0xf8, 0x0f, 0x00, 0x00, 0xf8, 0x1f, 0x00,
|
||||
0x00, 0xfc, 0x1f, 0x00, 0x00, 0xfc, 0x3f, 0x00, 0x00, 0xfe, 0x3f, 0x00,
|
||||
0x00, 0xfe, 0x7f, 0x00, 0x00, 0xff, 0x7f, 0x00, 0x00, 0xff, 0xff, 0x00,
|
||||
0x80, 0xff, 0xff, 0x00, 0x80, 0xff, 0xff, 0x01, 0xc0, 0xff, 0xff, 0x01,
|
||||
0xc0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x07,
|
||||
0xf0, 0xff, 0xff, 0x07, 0xf0, 0xff, 0xff, 0x0f, 0xf8, 0xff, 0xff, 0x0f,
|
||||
0xf8, 0xff, 0xff, 0x1f, 0xfc, 0xff, 0xff, 0x1f, 0xfe, 0xff, 0xff, 0x3f,
|
||||
0xfe, 0xff, 0xff, 0x3f, 0xfe, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x1f,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
|
||||
image create bitmap ::tk::dialog::w3 -foreground black \
|
||||
-data "#define w3_width 32\n#define w3_height 32
|
||||
static unsigned char w3_bits[] = {
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0xc0, 0x03, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00,
|
||||
0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00,
|
||||
0x00, 0xc0, 0x03, 0x00, 0x00, 0xc0, 0x03, 0x00, 0x00, 0xc0, 0x03, 0x00,
|
||||
0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0xc0, 0x03, 0x00,
|
||||
0x00, 0xc0, 0x03, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
|
||||
|
||||
# ::tk::MessageBox --
|
||||
#
|
||||
# Pops up a messagebox with an application-supplied message with
|
||||
# an icon and a list of buttons. This procedure will be called
|
||||
# by tk_messageBox if the platform does not have native
|
||||
# messagebox support, or if the particular type of messagebox is
|
||||
# not supported natively.
|
||||
#
|
||||
# Color icons are used on Unix displays that have a color
|
||||
# depth of 4 or more and $tk_strictMotif is not on.
|
||||
#
|
||||
# This procedure is a private procedure shouldn't be called
|
||||
# directly. Call tk_messageBox instead.
|
||||
#
|
||||
# See the user documentation for details on what tk_messageBox does.
|
||||
#
|
||||
proc ::tk::MessageBox {args} {
|
||||
global tk_strictMotif
|
||||
variable ::tk::Priv
|
||||
|
||||
set w ::tk::PrivMsgBox
|
||||
upvar $w data
|
||||
|
||||
#
|
||||
# The default value of the title is space (" ") not the empty string
|
||||
# because for some window managers, a
|
||||
# wm title .foo ""
|
||||
# causes the window title to be "foo" instead of the empty string.
|
||||
#
|
||||
set specs {
|
||||
{-default "" "" ""}
|
||||
{-detail "" "" ""}
|
||||
{-icon "" "" "info"}
|
||||
{-message "" "" ""}
|
||||
{-parent "" "" .}
|
||||
{-title "" "" " "}
|
||||
{-type "" "" "ok"}
|
||||
}
|
||||
|
||||
tclParseConfigSpec $w $specs "" $args
|
||||
|
||||
if {$data(-icon) ni {info warning error question}} {
|
||||
return -code error -errorcode [list TK LOOKUP ICON $data(-icon)] \
|
||||
"bad -icon value \"$data(-icon)\": must be error, info, question, or warning"
|
||||
}
|
||||
set windowingsystem [tk windowingsystem]
|
||||
if {$windowingsystem eq "aqua"} {
|
||||
switch -- $data(-icon) {
|
||||
"error" {set data(-icon) "stop"}
|
||||
"warning" {set data(-icon) "caution"}
|
||||
"info" {set data(-icon) "note"}
|
||||
}
|
||||
}
|
||||
|
||||
if {![winfo exists $data(-parent)]} {
|
||||
return -code error -errorcode [list TK LOOKUP WINDOW $data(-parent)] \
|
||||
"bad window path name \"$data(-parent)\""
|
||||
}
|
||||
|
||||
switch -- $data(-type) {
|
||||
abortretryignore {
|
||||
set names [list abort retry ignore]
|
||||
set labels [list &Abort &Retry &Ignore]
|
||||
set cancel abort
|
||||
}
|
||||
ok {
|
||||
set names [list ok]
|
||||
set labels {&OK}
|
||||
set cancel ok
|
||||
}
|
||||
okcancel {
|
||||
set names [list ok cancel]
|
||||
set labels [list &OK &Cancel]
|
||||
set cancel cancel
|
||||
}
|
||||
retrycancel {
|
||||
set names [list retry cancel]
|
||||
set labels [list &Retry &Cancel]
|
||||
set cancel cancel
|
||||
}
|
||||
yesno {
|
||||
set names [list yes no]
|
||||
set labels [list &Yes &No]
|
||||
set cancel no
|
||||
}
|
||||
yesnocancel {
|
||||
set names [list yes no cancel]
|
||||
set labels [list &Yes &No &Cancel]
|
||||
set cancel cancel
|
||||
}
|
||||
default {
|
||||
return -code error -errorcode [list TK LOOKUP DLG_TYPE $data(-type)] \
|
||||
"bad -type value \"$data(-type)\": must be\
|
||||
abortretryignore, ok, okcancel, retrycancel,\
|
||||
yesno, or yesnocancel"
|
||||
}
|
||||
}
|
||||
|
||||
set buttons {}
|
||||
foreach name $names lab $labels {
|
||||
lappend buttons [list $name -text [mc $lab]]
|
||||
}
|
||||
|
||||
# If no default button was specified, the default default is the
|
||||
# first button (Bug: 2218).
|
||||
|
||||
if {$data(-default) eq ""} {
|
||||
set data(-default) [lindex [lindex $buttons 0] 0]
|
||||
}
|
||||
|
||||
set valid 0
|
||||
foreach btn $buttons {
|
||||
if {[lindex $btn 0] eq $data(-default)} {
|
||||
set valid 1
|
||||
break
|
||||
}
|
||||
}
|
||||
if {!$valid} {
|
||||
return -code error -errorcode {TK MSGBOX DEFAULT} \
|
||||
"bad -default value \"$data(-default)\": must be\
|
||||
abort, retry, ignore, ok, cancel, no, or yes"
|
||||
}
|
||||
|
||||
# 2. Set the dialog to be a child window of $parent
|
||||
#
|
||||
#
|
||||
if {$data(-parent) ne "."} {
|
||||
set w $data(-parent).__tk__messagebox
|
||||
} else {
|
||||
set w .__tk__messagebox
|
||||
}
|
||||
|
||||
# There is only one background colour for the whole dialog
|
||||
set bg [ttk::style lookup . -background]
|
||||
|
||||
# 3. Create the top-level window and divide it into top
|
||||
# and bottom parts.
|
||||
|
||||
catch {destroy $w}
|
||||
toplevel $w -class Dialog -bg $bg
|
||||
wm title $w $data(-title)
|
||||
wm iconname $w Dialog
|
||||
wm protocol $w WM_DELETE_WINDOW [list $w.$cancel invoke]
|
||||
|
||||
# Message boxes should be transient with respect to their parent so that
|
||||
# they always stay on top of the parent window. But some window managers
|
||||
# will simply create the child window as withdrawn if the parent is not
|
||||
# viewable (because it is withdrawn or iconified). This is not good for
|
||||
# "grab"bed windows. So only make the message box transient if the parent
|
||||
# is viewable.
|
||||
#
|
||||
if {[winfo viewable [winfo toplevel $data(-parent)]] } {
|
||||
wm transient $w $data(-parent)
|
||||
}
|
||||
|
||||
if {$windowingsystem eq "aqua"} {
|
||||
::tk::unsupported::MacWindowStyle style $w moveableModal {}
|
||||
} elseif {$windowingsystem eq "x11"} {
|
||||
wm attributes $w -type dialog
|
||||
}
|
||||
|
||||
ttk::frame $w.bot
|
||||
grid anchor $w.bot center
|
||||
pack $w.bot -side bottom -fill both
|
||||
ttk::frame $w.top
|
||||
pack $w.top -side top -fill both -expand 1
|
||||
|
||||
# 4. Fill the top part with bitmap, message and detail (use the
|
||||
# option database for -wraplength and -font so that they can be
|
||||
# overridden by the caller).
|
||||
|
||||
option add *Dialog.msg.wrapLength 3i widgetDefault
|
||||
option add *Dialog.dtl.wrapLength 3i widgetDefault
|
||||
option add *Dialog.msg.font TkCaptionFont widgetDefault
|
||||
option add *Dialog.dtl.font TkDefaultFont widgetDefault
|
||||
|
||||
ttk::label $w.msg -anchor nw -justify left -text $data(-message)
|
||||
if {$data(-detail) ne ""} {
|
||||
ttk::label $w.dtl -anchor nw -justify left -text $data(-detail)
|
||||
}
|
||||
if {$data(-icon) ne ""} {
|
||||
if {([winfo depth $w] < 4) || $tk_strictMotif} {
|
||||
# ttk::label has no -bitmap option
|
||||
label $w.bitmap -bitmap $data(-icon) -background $bg
|
||||
} else {
|
||||
switch $data(-icon) {
|
||||
error {
|
||||
ttk::label $w.bitmap -image ::tk::icons::error
|
||||
}
|
||||
info {
|
||||
ttk::label $w.bitmap -image ::tk::icons::information
|
||||
}
|
||||
question {
|
||||
ttk::label $w.bitmap -image ::tk::icons::question
|
||||
}
|
||||
default {
|
||||
ttk::label $w.bitmap -image ::tk::icons::warning
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
grid $w.bitmap $w.msg -in $w.top -sticky news -padx 2m -pady 2m
|
||||
grid configure $w.bitmap -sticky nw
|
||||
grid columnconfigure $w.top 1 -weight 1
|
||||
if {$data(-detail) ne ""} {
|
||||
grid ^ $w.dtl -in $w.top -sticky news -padx 2m -pady {0 2m}
|
||||
grid rowconfigure $w.top 1 -weight 1
|
||||
} else {
|
||||
grid rowconfigure $w.top 0 -weight 1
|
||||
}
|
||||
|
||||
# 5. Create a row of buttons at the bottom of the dialog.
|
||||
|
||||
set i 0
|
||||
foreach but $buttons {
|
||||
set name [lindex $but 0]
|
||||
set opts [lrange $but 1 end]
|
||||
if {![llength $opts]} {
|
||||
# Capitalize the first letter of $name
|
||||
set capName [string toupper $name 0]
|
||||
set opts [list -text $capName]
|
||||
}
|
||||
|
||||
eval [list tk::AmpWidget ttk::button $w.$name] $opts \
|
||||
[list -command [list set tk::Priv(button) $name]]
|
||||
|
||||
if {$name eq $data(-default)} {
|
||||
$w.$name configure -default active
|
||||
} else {
|
||||
$w.$name configure -default normal
|
||||
}
|
||||
grid $w.$name -in $w.bot -row 0 -column $i -padx 3m -pady 2m -sticky ew
|
||||
grid columnconfigure $w.bot $i -uniform buttons
|
||||
# We boost the size of some Mac buttons for l&f
|
||||
if {$windowingsystem eq "aqua"} {
|
||||
set tmp [string tolower $name]
|
||||
if {$tmp eq "ok" || $tmp eq "cancel" || $tmp eq "yes" ||
|
||||
$tmp eq "no" || $tmp eq "abort" || $tmp eq "retry" ||
|
||||
$tmp eq "ignore"} {
|
||||
grid columnconfigure $w.bot $i -minsize 90
|
||||
}
|
||||
grid configure $w.$name -pady 7
|
||||
}
|
||||
incr i
|
||||
|
||||
# create the binding for the key accelerator, based on the underline
|
||||
#
|
||||
# set underIdx [$w.$name cget -under]
|
||||
# if {$underIdx >= 0} {
|
||||
# set key [string index [$w.$name cget -text] $underIdx]
|
||||
# bind $w <Alt-[string tolower $key]> [list $w.$name invoke]
|
||||
# bind $w <Alt-[string toupper $key]> [list $w.$name invoke]
|
||||
# }
|
||||
}
|
||||
bind $w <Alt-Key> [list ::tk::AltKeyInDialog $w %A]
|
||||
|
||||
if {$data(-default) ne ""} {
|
||||
bind $w <FocusIn> {
|
||||
if {[winfo class %W] in "Button TButton"} {
|
||||
%W configure -default active
|
||||
}
|
||||
}
|
||||
bind $w <FocusOut> {
|
||||
if {[winfo class %W] in "Button TButton"} {
|
||||
%W configure -default normal
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# 6. Create bindings for <Return>, <Escape> and <Destroy> on the dialog
|
||||
|
||||
bind $w <Return> {
|
||||
if {[winfo class %W] in "Button TButton"} {
|
||||
%W invoke
|
||||
}
|
||||
}
|
||||
|
||||
# Invoke the designated cancelling operation
|
||||
bind $w <Escape> [list $w.$cancel invoke]
|
||||
|
||||
# At <Destroy> the buttons have vanished, so must do this directly.
|
||||
bind $w.msg <Destroy> [list set tk::Priv(button) $cancel]
|
||||
|
||||
# 7. Withdraw the window, then update all the geometry information
|
||||
# so we know how big it wants to be, then center the window in the
|
||||
# display (Motif style) and de-iconify it.
|
||||
|
||||
::tk::PlaceWindow $w widget $data(-parent)
|
||||
|
||||
# 8. Set a grab and claim the focus too.
|
||||
|
||||
if {$data(-default) ne ""} {
|
||||
set focus $w.$data(-default)
|
||||
} else {
|
||||
set focus $w
|
||||
}
|
||||
::tk::SetFocusGrab $w $focus
|
||||
|
||||
# 9. Wait for the user to respond, then restore the focus and
|
||||
# return the index of the selected button. Restore the focus
|
||||
# before deleting the window, since otherwise the window manager
|
||||
# may take the focus away so we can't redirect it. Finally,
|
||||
# restore any grab that was in effect.
|
||||
|
||||
vwait ::tk::Priv(button)
|
||||
# Copy the result now so any <Destroy> that happens won't cause
|
||||
# trouble
|
||||
set result $Priv(button)
|
||||
|
||||
::tk::RestoreFocusGrab $w $focus
|
||||
|
||||
return $result
|
||||
}
|
||||
|
|
@ -0,0 +1,178 @@
|
|||
# obsolete.tcl --
|
||||
#
|
||||
# This file contains obsolete procedures that people really shouldn't
|
||||
# be using anymore, but which are kept around for backward compatibility.
|
||||
#
|
||||
# Copyright (c) 1994 The Regents of the University of California.
|
||||
# Copyright (c) 1994 Sun Microsystems, Inc.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
|
||||
# The procedures below are here strictly for backward compatibility with
|
||||
# Tk version 3.6 and earlier. The procedures are no longer needed, so
|
||||
# they are no-ops. You should not use these procedures anymore, since
|
||||
# they may be removed in some future release.
|
||||
|
||||
proc tk_menuBar args {}
|
||||
proc tk_bindForTraversal args {}
|
||||
|
||||
# ::tk::classic::restore --
|
||||
#
|
||||
# Restore the pre-8.5 (Tk classic) look as the widget defaults for classic
|
||||
# Tk widgets.
|
||||
#
|
||||
# The value following an 'option add' call is the new 8.5 value.
|
||||
#
|
||||
namespace eval ::tk::classic {
|
||||
# This may need to be adjusted for some window managers that are
|
||||
# more aggressive with their own Xdefaults (like KDE and CDE)
|
||||
variable prio "widgetDefault"
|
||||
}
|
||||
|
||||
proc ::tk::classic::restore {args} {
|
||||
# Restore classic (8.4) look to classic Tk widgets
|
||||
variable prio
|
||||
|
||||
if {[llength $args]} {
|
||||
foreach what $args {
|
||||
::tk::classic::restore_$what
|
||||
}
|
||||
} else {
|
||||
foreach cmd [info procs restore_*] {
|
||||
$cmd
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
proc ::tk::classic::restore_font {args} {
|
||||
# Many widgets were adjusted from hard-coded defaults to using the
|
||||
# TIP#145 fonts defined in fonts.tcl (eg TkDefaultFont, TkFixedFont, ...)
|
||||
# For restoring compatibility, we only correct size and weighting changes,
|
||||
# as the fonts themselves remained mostly the same.
|
||||
if {[tk windowingsystem] eq "x11"} {
|
||||
font configure TkDefaultFont -weight bold ; # normal
|
||||
font configure TkFixedFont -size -12 ; # -10
|
||||
}
|
||||
# Add these with prio 21 to override value in dialog/msgbox.tcl
|
||||
if {[tk windowingsystem] eq "aqua"} {
|
||||
option add *Dialog.msg.font system 21; # TkCaptionFont
|
||||
option add *Dialog.dtl.font system 21; # TkCaptionFont
|
||||
option add *ErrorDialog*Label.font system 21; # TkCaptionFont
|
||||
} else {
|
||||
option add *Dialog.msg.font {Times 12} 21; # TkCaptionFont
|
||||
option add *Dialog.dtl.font {Times 10} 21; # TkCaptionFont
|
||||
option add *ErrorDialog*Label.font {Times -18} 21; # TkCaptionFont
|
||||
}
|
||||
}
|
||||
|
||||
proc ::tk::classic::restore_button {args} {
|
||||
variable prio
|
||||
if {[tk windowingsystem] eq "x11"} {
|
||||
foreach cls {Button Radiobutton Checkbutton} {
|
||||
option add *$cls.borderWidth 2 $prio; # 1
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
proc ::tk::classic::restore_entry {args} {
|
||||
variable prio
|
||||
# Entry and Spinbox share core defaults
|
||||
foreach cls {Entry Spinbox} {
|
||||
if {[tk windowingsystem] ne "aqua"} {
|
||||
option add *$cls.borderWidth 2 $prio; # 1
|
||||
}
|
||||
if {[tk windowingsystem] eq "x11"} {
|
||||
option add *$cls.background "#d9d9d9" $prio; # "white"
|
||||
option add *$cls.selectBorderWidth 1 $prio; # 0
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
proc ::tk::classic::restore_listbox {args} {
|
||||
variable prio
|
||||
if {[tk windowingsystem] ne "win32"} {
|
||||
option add *Listbox.background "#d9d9d9" $prio; # "white"
|
||||
option add *Listbox.activeStyle "underline" $prio; # "dotbox"
|
||||
}
|
||||
if {[tk windowingsystem] ne "aqua"} {
|
||||
option add *Listbox.borderWidth 2 $prio; # 1
|
||||
}
|
||||
if {[tk windowingsystem] eq "x11"} {
|
||||
option add *Listbox.selectBorderWidth 1 $prio; # 0
|
||||
}
|
||||
# Remove focus into Listbox added for 8.5
|
||||
bind Listbox <1> {
|
||||
if {[winfo exists %W]} {
|
||||
tk::ListboxBeginSelect %W [%W index @%x,%y]
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
proc ::tk::classic::restore_menu {args} {
|
||||
variable prio
|
||||
if {[tk windowingsystem] eq "x11"} {
|
||||
option add *Menu.activeBorderWidth 2 $prio; # 1
|
||||
option add *Menu.borderWidth 2 $prio; # 1
|
||||
option add *Menu.clickToFocus true $prio
|
||||
option add *Menu.useMotifHelp true $prio
|
||||
}
|
||||
if {[tk windowingsystem] ne "aqua"} {
|
||||
option add *Menu.font "TkDefaultFont" $prio; # "TkMenuFont"
|
||||
}
|
||||
}
|
||||
|
||||
proc ::tk::classic::restore_menubutton {args} {
|
||||
variable prio
|
||||
option add *Menubutton.borderWidth 2 $prio; # 1
|
||||
}
|
||||
|
||||
proc ::tk::classic::restore_message {args} {
|
||||
variable prio
|
||||
option add *Message.borderWidth 2 $prio; # 1
|
||||
}
|
||||
|
||||
proc ::tk::classic::restore_panedwindow {args} {
|
||||
variable prio
|
||||
option add *Panedwindow.borderWidth 2 $prio; # 1
|
||||
option add *Panedwindow.sashWidth 2 $prio; # 3
|
||||
option add *Panedwindow.sashPad 2 $prio; # 0
|
||||
option add *Panedwindow.sashRelief raised $prio; # flat
|
||||
option add *Panedwindow.opaqueResize 0 $prio; # 1
|
||||
if {[tk windowingsystem] ne "win32"} {
|
||||
option add *Panedwindow.showHandle 1 $prio; # 0
|
||||
}
|
||||
}
|
||||
|
||||
proc ::tk::classic::restore_scale {args} {
|
||||
variable prio
|
||||
option add *Scale.borderWidth 2 $prio; # 1
|
||||
if {[tk windowingsystem] eq "x11"} {
|
||||
option add *Scale.troughColor "#c3c3c3" $prio; # "#b3b3b3"
|
||||
}
|
||||
}
|
||||
|
||||
proc ::tk::classic::restore_scrollbar {args} {
|
||||
variable prio
|
||||
if {[tk windowingsystem] eq "x11"} {
|
||||
option add *Scrollbar.borderWidth 2 $prio; # 1
|
||||
option add *Scrollbar.highlightThickness 1 $prio; # 0
|
||||
option add *Scrollbar.width 15 $prio; # 11
|
||||
option add *Scrollbar.troughColor "#c3c3c3" $prio; # "#b3b3b3"
|
||||
}
|
||||
}
|
||||
|
||||
proc ::tk::classic::restore_text {args} {
|
||||
variable prio
|
||||
if {[tk windowingsystem] ne "aqua"} {
|
||||
option add *Text.borderWidth 2 $prio; # 1
|
||||
}
|
||||
if {[tk windowingsystem] eq "win32"} {
|
||||
option add *Text.font "TkDefaultFont" $prio; # "TkFixedFont"
|
||||
}
|
||||
if {[tk windowingsystem] eq "x11"} {
|
||||
option add *Text.background "#d9d9d9" $prio; # white
|
||||
option add *Text.selectBorderWidth 1 $prio; # 0
|
||||
}
|
||||
}
|
||||
|
|
@ -0,0 +1,43 @@
|
|||
# optMenu.tcl --
|
||||
#
|
||||
# This file defines the procedure tk_optionMenu, which creates
|
||||
# an option button and its associated menu.
|
||||
#
|
||||
# Copyright (c) 1994 The Regents of the University of California.
|
||||
# Copyright (c) 1994 Sun Microsystems, Inc.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
|
||||
# ::tk_optionMenu --
|
||||
# This procedure creates an option button named $w and an associated
|
||||
# menu. Together they provide the functionality of Motif option menus:
|
||||
# they can be used to select one of many values, and the current value
|
||||
# appears in the global variable varName, as well as in the text of
|
||||
# the option menubutton. The name of the menu is returned as the
|
||||
# procedure's result, so that the caller can use it to change configuration
|
||||
# options on the menu or otherwise manipulate it.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name to use for the menubutton.
|
||||
# varName - Global variable to hold the currently selected value.
|
||||
# firstValue - First of legal values for option (must be >= 1).
|
||||
# args - Any number of additional values.
|
||||
|
||||
proc ::tk_optionMenu {w varName firstValue args} {
|
||||
upvar #0 $varName var
|
||||
|
||||
if {![info exists var]} {
|
||||
set var $firstValue
|
||||
}
|
||||
menubutton $w -textvariable $varName -indicatoron 1 -menu $w.menu \
|
||||
-relief raised -highlightthickness 1 -anchor c \
|
||||
-direction flush
|
||||
menu $w.menu -tearoff 0
|
||||
$w.menu add radiobutton -label $firstValue -variable $varName
|
||||
foreach i $args {
|
||||
$w.menu add radiobutton -label $i -variable $varName
|
||||
}
|
||||
return $w.menu
|
||||
}
|
||||
|
|
@ -0,0 +1,244 @@
|
|||
# palette.tcl --
|
||||
#
|
||||
# This file contains procedures that change the color palette used
|
||||
# by Tk.
|
||||
#
|
||||
# Copyright (c) 1995-1997 Sun Microsystems, Inc.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
|
||||
# ::tk_setPalette --
|
||||
# Changes the default color scheme for a Tk application by setting
|
||||
# default colors in the option database and by modifying all of the
|
||||
# color options for existing widgets that have the default value.
|
||||
#
|
||||
# Arguments:
|
||||
# The arguments consist of either a single color name, which
|
||||
# will be used as the new background color (all other colors will
|
||||
# be computed from this) or an even number of values consisting of
|
||||
# option names and values. The name for an option is the one used
|
||||
# for the option database, such as activeForeground, not -activeforeground.
|
||||
|
||||
proc ::tk_setPalette {args} {
|
||||
if {[winfo depth .] == 1} {
|
||||
# Just return on monochrome displays, otherwise errors will occur
|
||||
return
|
||||
}
|
||||
|
||||
# Create an array that has the complete new palette. If some colors
|
||||
# aren't specified, compute them from other colors that are specified.
|
||||
|
||||
if {[llength $args] == 1} {
|
||||
set new(background) [lindex $args 0]
|
||||
} else {
|
||||
array set new $args
|
||||
}
|
||||
if {![info exists new(background)]} {
|
||||
return -code error -errorcode {TK SET_PALETTE BACKGROUND} \
|
||||
"must specify a background color"
|
||||
}
|
||||
set bg [winfo rgb . $new(background)]
|
||||
if {![info exists new(foreground)]} {
|
||||
# Note that the range of each value in the triple returned by
|
||||
# [winfo rgb] is 0-65535, and your eyes are more sensitive to
|
||||
# green than to red, and more to red than to blue.
|
||||
foreach {r g b} $bg {break}
|
||||
if {$r+1.5*$g+0.5*$b > 100000} {
|
||||
set new(foreground) black
|
||||
} else {
|
||||
set new(foreground) white
|
||||
}
|
||||
}
|
||||
lassign [winfo rgb . $new(foreground)] fg_r fg_g fg_b
|
||||
lassign $bg bg_r bg_g bg_b
|
||||
set darkerBg [format #%02x%02x%02x [expr {(9*$bg_r)/2560}] \
|
||||
[expr {(9*$bg_g)/2560}] [expr {(9*$bg_b)/2560}]]
|
||||
|
||||
foreach i {activeForeground insertBackground selectForeground \
|
||||
highlightColor} {
|
||||
if {![info exists new($i)]} {
|
||||
set new($i) $new(foreground)
|
||||
}
|
||||
}
|
||||
if {![info exists new(disabledForeground)]} {
|
||||
set new(disabledForeground) [format #%02x%02x%02x \
|
||||
[expr {(3*$bg_r + $fg_r)/1024}] \
|
||||
[expr {(3*$bg_g + $fg_g)/1024}] \
|
||||
[expr {(3*$bg_b + $fg_b)/1024}]]
|
||||
}
|
||||
if {![info exists new(highlightBackground)]} {
|
||||
set new(highlightBackground) $new(background)
|
||||
}
|
||||
if {![info exists new(activeBackground)]} {
|
||||
# Pick a default active background that islighter than the
|
||||
# normal background. To do this, round each color component
|
||||
# up by 15% or 1/3 of the way to full white, whichever is
|
||||
# greater.
|
||||
|
||||
foreach i {0 1 2} color $bg {
|
||||
set light($i) [expr {$color/256}]
|
||||
set inc1 [expr {($light($i)*15)/100}]
|
||||
set inc2 [expr {(255-$light($i))/3}]
|
||||
if {$inc1 > $inc2} {
|
||||
incr light($i) $inc1
|
||||
} else {
|
||||
incr light($i) $inc2
|
||||
}
|
||||
if {$light($i) > 255} {
|
||||
set light($i) 255
|
||||
}
|
||||
}
|
||||
set new(activeBackground) [format #%02x%02x%02x $light(0) \
|
||||
$light(1) $light(2)]
|
||||
}
|
||||
if {![info exists new(selectBackground)]} {
|
||||
set new(selectBackground) $darkerBg
|
||||
}
|
||||
if {![info exists new(troughColor)]} {
|
||||
set new(troughColor) $darkerBg
|
||||
}
|
||||
|
||||
# let's make one of each of the widgets so we know what the
|
||||
# defaults are currently for this platform.
|
||||
toplevel .___tk_set_palette
|
||||
wm withdraw .___tk_set_palette
|
||||
foreach q {
|
||||
button canvas checkbutton entry frame label labelframe
|
||||
listbox menubutton menu message radiobutton scale scrollbar
|
||||
spinbox text
|
||||
} {
|
||||
$q .___tk_set_palette.$q
|
||||
}
|
||||
|
||||
# Walk the widget hierarchy, recoloring all existing windows.
|
||||
# The option database must be set according to what we do here,
|
||||
# but it breaks things if we set things in the database while
|
||||
# we are changing colors...so, ::tk::RecolorTree now returns the
|
||||
# option database changes that need to be made, and they
|
||||
# need to be evalled here to take effect.
|
||||
# We have to walk the whole widget tree instead of just
|
||||
# relying on the widgets we've created above to do the work
|
||||
# because different extensions may provide other kinds
|
||||
# of widgets that we don't currently know about, so we'll
|
||||
# walk the whole hierarchy just in case.
|
||||
|
||||
eval [tk::RecolorTree . new]
|
||||
|
||||
destroy .___tk_set_palette
|
||||
|
||||
# Change the option database so that future windows will get the
|
||||
# same colors.
|
||||
|
||||
foreach option [array names new] {
|
||||
option add *$option $new($option) widgetDefault
|
||||
}
|
||||
|
||||
# Save the options in the variable ::tk::Palette, for use the
|
||||
# next time we change the options.
|
||||
|
||||
array set ::tk::Palette [array get new]
|
||||
}
|
||||
|
||||
# ::tk::RecolorTree --
|
||||
# This procedure changes the colors in a window and all of its
|
||||
# descendants, according to information provided by the colors
|
||||
# argument. This looks at the defaults provided by the option
|
||||
# database, if it exists, and if not, then it looks at the default
|
||||
# value of the widget itself.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of a window. This window and all its
|
||||
# descendants are recolored.
|
||||
# colors - The name of an array variable in the caller,
|
||||
# which contains color information. Each element
|
||||
# is named after a widget configuration option, and
|
||||
# each value is the value for that option.
|
||||
|
||||
proc ::tk::RecolorTree {w colors} {
|
||||
upvar $colors c
|
||||
set result {}
|
||||
set prototype .___tk_set_palette.[string tolower [winfo class $w]]
|
||||
if {![winfo exists $prototype]} {
|
||||
unset prototype
|
||||
}
|
||||
foreach dbOption [array names c] {
|
||||
set option -[string tolower $dbOption]
|
||||
set class [string replace $dbOption 0 0 [string toupper \
|
||||
[string index $dbOption 0]]]
|
||||
if {![catch {$w configure $option} value]} {
|
||||
# if the option database has a preference for this
|
||||
# dbOption, then use it, otherwise use the defaults
|
||||
# for the widget.
|
||||
set defaultcolor [option get $w $dbOption $class]
|
||||
if {$defaultcolor eq "" || \
|
||||
([info exists prototype] && \
|
||||
[$prototype cget $option] ne "$defaultcolor")} {
|
||||
set defaultcolor [lindex $value 3]
|
||||
}
|
||||
if {$defaultcolor ne ""} {
|
||||
set defaultcolor [winfo rgb . $defaultcolor]
|
||||
}
|
||||
set chosencolor [lindex $value 4]
|
||||
if {$chosencolor ne ""} {
|
||||
set chosencolor [winfo rgb . $chosencolor]
|
||||
}
|
||||
if {[string match $defaultcolor $chosencolor]} {
|
||||
# Change the option database so that future windows will get
|
||||
# the same colors.
|
||||
append result ";\noption add [list \
|
||||
*[winfo class $w].$dbOption $c($dbOption) 60]"
|
||||
$w configure $option $c($dbOption)
|
||||
}
|
||||
}
|
||||
}
|
||||
foreach child [winfo children $w] {
|
||||
append result ";\n[::tk::RecolorTree $child c]"
|
||||
}
|
||||
return $result
|
||||
}
|
||||
|
||||
# ::tk::Darken --
|
||||
# Given a color name, computes a new color value that darkens (or
|
||||
# brightens) the given color by a given percent.
|
||||
#
|
||||
# Arguments:
|
||||
# color - Name of starting color.
|
||||
# percent - Integer telling how much to brighten or darken as a
|
||||
# percent: 50 means darken by 50%, 110 means brighten
|
||||
# by 10%.
|
||||
|
||||
proc ::tk::Darken {color percent} {
|
||||
if {$percent < 0} {
|
||||
return #000000
|
||||
} elseif {$percent > 200} {
|
||||
return #ffffff
|
||||
} elseif {$percent <= 100} {
|
||||
lassign [winfo rgb . $color] r g b
|
||||
set r [expr {($r/256)*$percent/100}]
|
||||
set g [expr {($g/256)*$percent/100}]
|
||||
set b [expr {($b/256)*$percent/100}]
|
||||
} elseif {$percent > 100} {
|
||||
lassign [winfo rgb . $color] r g b
|
||||
set r [expr {255 - ((65535-$r)/256)*(200-$percent)/100}]
|
||||
set g [expr {255 - ((65535-$g)/256)*(200-$percent)/100}]
|
||||
set b [expr {255 - ((65535-$b)/256)*(200-$percent)/100}]
|
||||
}
|
||||
return [format #%02x%02x%02x $r $g $b]
|
||||
}
|
||||
|
||||
# ::tk_bisque --
|
||||
# Reset the Tk color palette to the old "bisque" colors.
|
||||
#
|
||||
# Arguments:
|
||||
# None.
|
||||
|
||||
proc ::tk_bisque {} {
|
||||
tk_setPalette activeBackground #e6ceb1 activeForeground black \
|
||||
background #ffe4c4 disabledForeground #b0b0b0 foreground black \
|
||||
highlightBackground #ffe4c4 highlightColor black \
|
||||
insertBackground black \
|
||||
selectBackground #e6ceb1 selectForeground black \
|
||||
troughColor #cdb79e
|
||||
}
|
||||
|
|
@ -0,0 +1,194 @@
|
|||
# panedwindow.tcl --
|
||||
#
|
||||
# This file defines the default bindings for Tk panedwindow widgets and
|
||||
# provides procedures that help in implementing those bindings.
|
||||
|
||||
bind Panedwindow <Button-1> { ::tk::panedwindow::MarkSash %W %x %y 1 }
|
||||
bind Panedwindow <Button-2> { ::tk::panedwindow::MarkSash %W %x %y 0 }
|
||||
|
||||
bind Panedwindow <B1-Motion> { ::tk::panedwindow::DragSash %W %x %y 1 }
|
||||
bind Panedwindow <B2-Motion> { ::tk::panedwindow::DragSash %W %x %y 0 }
|
||||
|
||||
bind Panedwindow <ButtonRelease-1> {::tk::panedwindow::ReleaseSash %W 1}
|
||||
bind Panedwindow <ButtonRelease-2> {::tk::panedwindow::ReleaseSash %W 0}
|
||||
|
||||
bind Panedwindow <Motion> { ::tk::panedwindow::Motion %W %x %y }
|
||||
|
||||
bind Panedwindow <Leave> { ::tk::panedwindow::Leave %W }
|
||||
|
||||
# Initialize namespace
|
||||
namespace eval ::tk::panedwindow {}
|
||||
|
||||
# ::tk::panedwindow::MarkSash --
|
||||
#
|
||||
# Handle marking the correct sash for possible dragging
|
||||
#
|
||||
# Arguments:
|
||||
# w the widget
|
||||
# x widget local x coord
|
||||
# y widget local y coord
|
||||
# proxy whether this should be a proxy sash
|
||||
# Results:
|
||||
# None
|
||||
#
|
||||
proc ::tk::panedwindow::MarkSash {w x y proxy} {
|
||||
variable ::tk::Priv
|
||||
if {[$w cget -opaqueresize]} {
|
||||
set proxy 0
|
||||
}
|
||||
set what [$w identify $x $y]
|
||||
if { [llength $what] == 2 } {
|
||||
lassign $what index which
|
||||
if {!$::tk_strictMotif || $which eq "handle"} {
|
||||
if {!$proxy} {
|
||||
$w sash mark $index $x $y
|
||||
}
|
||||
set Priv(sash) $index
|
||||
lassign [$w sash coord $index] sx sy
|
||||
set Priv(dx) [expr {$sx-$x}]
|
||||
set Priv(dy) [expr {$sy-$y}]
|
||||
# Do this to init the proxy location
|
||||
DragSash $w $x $y $proxy
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::panedwindow::DragSash --
|
||||
#
|
||||
# Handle dragging of the correct sash
|
||||
#
|
||||
# Arguments:
|
||||
# w the widget
|
||||
# x widget local x coord
|
||||
# y widget local y coord
|
||||
# proxy whether this should be a proxy sash
|
||||
# Results:
|
||||
# Moves sash
|
||||
#
|
||||
proc ::tk::panedwindow::DragSash {w x y proxy} {
|
||||
variable ::tk::Priv
|
||||
if {[$w cget -opaqueresize]} {
|
||||
set proxy 0
|
||||
}
|
||||
if {[info exists Priv(sash)]} {
|
||||
if {$proxy} {
|
||||
$w proxy place [expr {$x+$Priv(dx)}] [expr {$y+$Priv(dy)}]
|
||||
} else {
|
||||
$w sash place $Priv(sash) \
|
||||
[expr {$x+$Priv(dx)}] [expr {$y+$Priv(dy)}]
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::panedwindow::ReleaseSash --
|
||||
#
|
||||
# Handle releasing of the sash
|
||||
#
|
||||
# Arguments:
|
||||
# w the widget
|
||||
# proxy whether this should be a proxy sash
|
||||
# Results:
|
||||
# Returns ...
|
||||
#
|
||||
proc ::tk::panedwindow::ReleaseSash {w proxy} {
|
||||
variable ::tk::Priv
|
||||
if {[$w cget -opaqueresize]} {
|
||||
set proxy 0
|
||||
}
|
||||
if {[info exists Priv(sash)]} {
|
||||
if {$proxy} {
|
||||
lassign [$w proxy coord] x y
|
||||
$w sash place $Priv(sash) $x $y
|
||||
$w proxy forget
|
||||
}
|
||||
unset Priv(sash) Priv(dx) Priv(dy)
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::panedwindow::Motion --
|
||||
#
|
||||
# Handle motion on the widget. This is used to change the cursor
|
||||
# when the user moves over the sash area.
|
||||
#
|
||||
# Arguments:
|
||||
# w the widget
|
||||
# x widget local x coord
|
||||
# y widget local y coord
|
||||
# Results:
|
||||
# May change the cursor. Sets up a timer to verify that we are still
|
||||
# over the widget.
|
||||
#
|
||||
proc ::tk::panedwindow::Motion {w x y} {
|
||||
variable ::tk::Priv
|
||||
set id [$w identify $x $y]
|
||||
if {([llength $id] == 2) && \
|
||||
(!$::tk_strictMotif || [lindex $id 1] eq "handle")} {
|
||||
if {![info exists Priv($w,panecursor)]} {
|
||||
set Priv($w,panecursor) [$w cget -cursor]
|
||||
if {[$w cget -sashcursor] ne ""} {
|
||||
$w configure -cursor [$w cget -sashcursor]
|
||||
} elseif {[$w cget -orient] eq "horizontal"} {
|
||||
$w configure -cursor sb_h_double_arrow
|
||||
} else {
|
||||
$w configure -cursor sb_v_double_arrow
|
||||
}
|
||||
if {[info exists Priv($w,pwAfterId)]} {
|
||||
after cancel $Priv($w,pwAfterId)
|
||||
}
|
||||
set Priv($w,pwAfterId) [after 150 \
|
||||
[list ::tk::panedwindow::Cursor $w]]
|
||||
}
|
||||
return
|
||||
}
|
||||
if {[info exists Priv($w,panecursor)]} {
|
||||
$w configure -cursor $Priv($w,panecursor)
|
||||
unset Priv($w,panecursor)
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::panedwindow::Cursor --
|
||||
#
|
||||
# Handles returning the normal cursor when we are no longer over the
|
||||
# sash area. This needs to be done this way, because the panedwindow
|
||||
# won't see Leave events when the mouse moves from the sash to a
|
||||
# paned child, although the child does receive an Enter event.
|
||||
#
|
||||
# Arguments:
|
||||
# w the widget
|
||||
# Results:
|
||||
# May restore the default cursor, or schedule a timer to do it.
|
||||
#
|
||||
proc ::tk::panedwindow::Cursor {w} {
|
||||
variable ::tk::Priv
|
||||
# Make sure to check window existence in case it is destroyed.
|
||||
if {[info exists Priv($w,panecursor)] && [winfo exists $w]} {
|
||||
if {[winfo containing [winfo pointerx $w] [winfo pointery $w]] eq $w} {
|
||||
set Priv($w,pwAfterId) [after 150 \
|
||||
[list ::tk::panedwindow::Cursor $w]]
|
||||
} else {
|
||||
$w configure -cursor $Priv($w,panecursor)
|
||||
unset Priv($w,panecursor)
|
||||
if {[info exists Priv($w,pwAfterId)]} {
|
||||
after cancel $Priv($w,pwAfterId)
|
||||
unset Priv($w,pwAfterId)
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::panedwindow::Leave --
|
||||
#
|
||||
# Return to default cursor when leaving the pw widget.
|
||||
#
|
||||
# Arguments:
|
||||
# w the widget
|
||||
# Results:
|
||||
# Restores the default cursor
|
||||
#
|
||||
proc ::tk::panedwindow::Leave {w} {
|
||||
variable ::tk::Priv
|
||||
if {[info exists Priv($w,panecursor)]} {
|
||||
$w configure -cursor $Priv($w,panecursor)
|
||||
unset Priv($w,panecursor)
|
||||
}
|
||||
}
|
||||
|
|
@ -0,0 +1,262 @@
|
|||
# safetk.tcl --
|
||||
#
|
||||
# Support procs to use Tk in safe interpreters.
|
||||
#
|
||||
# Copyright (c) 1997 Sun Microsystems, Inc.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
# see safetk.n for documentation
|
||||
|
||||
#
|
||||
#
|
||||
# Note: It is now ok to let untrusted code being executed
|
||||
# between the creation of the interp and the actual loading
|
||||
# of Tk in that interp because the C side Tk_Init will
|
||||
# now look up the parent interp and ask its safe::TkInit
|
||||
# for the actual parameters to use for it's initialization (if allowed),
|
||||
# not relying on the child state.
|
||||
#
|
||||
|
||||
# We use opt (optional arguments parsing)
|
||||
package require opt 0.4.1;
|
||||
|
||||
namespace eval ::safe {
|
||||
|
||||
# counter for safe toplevels
|
||||
variable tkSafeId 0
|
||||
}
|
||||
|
||||
#
|
||||
# tkInterpInit : prepare the child interpreter for tk loading
|
||||
# most of the real job is done by loadTk
|
||||
# returns the child name (tkInterpInit does)
|
||||
#
|
||||
proc ::safe::tkInterpInit {child argv} {
|
||||
global env tk_library
|
||||
|
||||
# We have to make sure that the tk_library variable is normalized.
|
||||
set tk_library [file normalize $tk_library]
|
||||
|
||||
# Clear Tk's access for that interp (path).
|
||||
allowTk $child $argv
|
||||
|
||||
# Ensure tk_library and subdirs (eg, ttk) are on the access path
|
||||
::interp eval $child [list set tk_library [::safe::interpAddToAccessPath $child $tk_library]]
|
||||
foreach subdir [::safe::AddSubDirs [list $tk_library]] {
|
||||
::safe::interpAddToAccessPath $child $subdir
|
||||
}
|
||||
return $child
|
||||
}
|
||||
|
||||
|
||||
# tkInterpLoadTk:
|
||||
# Do additional configuration as needed (calling tkInterpInit)
|
||||
# and actually load Tk into the child.
|
||||
#
|
||||
# Either contained in the specified windowId (-use) or
|
||||
# creating a decorated toplevel for it.
|
||||
|
||||
# empty definition for auto_mkIndex
|
||||
proc ::safe::loadTk {} {}
|
||||
|
||||
::tcl::OptProc ::safe::loadTk {
|
||||
{child -interp "name of the child interpreter"}
|
||||
{-use -windowId {} "window Id to use (new toplevel otherwise)"}
|
||||
{-display -displayName {} "display name to use (current one otherwise)"}
|
||||
} {
|
||||
set displayGiven [::tcl::OptProcArgGiven "-display"]
|
||||
if {!$displayGiven} {
|
||||
# Try to get the current display from "."
|
||||
# (which might not exist if the parent is tk-less)
|
||||
if {[catch {set display [winfo screen .]}]} {
|
||||
if {[info exists ::env(DISPLAY)]} {
|
||||
set display $::env(DISPLAY)
|
||||
} else {
|
||||
Log $child "no winfo screen . nor env(DISPLAY)" WARNING
|
||||
set display ":0.0"
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Get state for access to the cleanupHook.
|
||||
namespace upvar ::safe S$child state
|
||||
|
||||
if {![::tcl::OptProcArgGiven "-use"]} {
|
||||
# create a decorated toplevel
|
||||
lassign [tkTopLevel $child $display] w use
|
||||
|
||||
# set our delete hook (child arg is added by interpDelete)
|
||||
# to clean up both window related code and tkInit(child)
|
||||
set state(cleanupHook) [list tkDelete {} $w]
|
||||
} else {
|
||||
# set our delete hook (child arg is added by interpDelete)
|
||||
# to clean up tkInit(child)
|
||||
set state(cleanupHook) [list disallowTk]
|
||||
|
||||
# Let's be nice and also accept tk window names instead of ids
|
||||
if {[string match ".*" $use]} {
|
||||
set windowName $use
|
||||
set use [winfo id $windowName]
|
||||
set nDisplay [winfo screen $windowName]
|
||||
} else {
|
||||
# Check for a better -display value
|
||||
# (works only for multi screens on single host, but not
|
||||
# cross hosts, for that a tk window name would be better
|
||||
# but embeding is also usefull for non tk names)
|
||||
if {![catch {winfo pathname $use} name]} {
|
||||
set nDisplay [winfo screen $name]
|
||||
} else {
|
||||
# Can't have a better one
|
||||
set nDisplay $display
|
||||
}
|
||||
}
|
||||
if {$nDisplay ne $display} {
|
||||
if {$displayGiven} {
|
||||
return -code error -errorcode {TK DISPLAY SAFE} \
|
||||
"conflicting -display $display and -use $use -> $nDisplay"
|
||||
} else {
|
||||
set display $nDisplay
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Prepares the child for tk with those parameters
|
||||
tkInterpInit $child [list "-use" $use "-display" $display]
|
||||
|
||||
load {} Tk $child
|
||||
|
||||
return $child
|
||||
}
|
||||
|
||||
proc ::safe::TkInit {interpPath} {
|
||||
variable tkInit
|
||||
if {[info exists tkInit($interpPath)]} {
|
||||
set value $tkInit($interpPath)
|
||||
Log $interpPath "TkInit called, returning \"$value\"" NOTICE
|
||||
return $value
|
||||
} else {
|
||||
Log $interpPath "TkInit called for interp with clearance:\
|
||||
preventing Tk init" ERROR
|
||||
return -code error -errorcode {TK SAFE PERMISSION} "not allowed"
|
||||
}
|
||||
}
|
||||
|
||||
# safe::allowTk --
|
||||
#
|
||||
# Set tkInit(interpPath) to allow Tk to be initialized in
|
||||
# safe::TkInit.
|
||||
#
|
||||
# Arguments:
|
||||
# interpPath child interpreter handle
|
||||
# argv arguments passed to safe::TkInterpInit
|
||||
#
|
||||
# Results:
|
||||
# none.
|
||||
|
||||
proc ::safe::allowTk {interpPath argv} {
|
||||
variable tkInit
|
||||
set tkInit($interpPath) $argv
|
||||
return
|
||||
}
|
||||
|
||||
|
||||
# safe::disallowTk --
|
||||
#
|
||||
# Unset tkInit(interpPath) to disallow Tk from getting initialized
|
||||
# in safe::TkInit.
|
||||
#
|
||||
# Arguments:
|
||||
# interpPath child interpreter handle
|
||||
#
|
||||
# Results:
|
||||
# none.
|
||||
|
||||
proc ::safe::disallowTk {interpPath} {
|
||||
variable tkInit
|
||||
# This can already be deleted by the DeleteHook of the interp
|
||||
if {[info exists tkInit($interpPath)]} {
|
||||
unset tkInit($interpPath)
|
||||
}
|
||||
return
|
||||
}
|
||||
|
||||
|
||||
# safe::tkDelete --
|
||||
#
|
||||
# Clean up the window associated with the interp being deleted.
|
||||
#
|
||||
# Arguments:
|
||||
# interpPath child interpreter handle
|
||||
#
|
||||
# Results:
|
||||
# none.
|
||||
|
||||
proc ::safe::tkDelete {W window child} {
|
||||
|
||||
# we are going to be called for each widget... skip untill it's
|
||||
# top level
|
||||
|
||||
Log $child "Called tkDelete $W $window" NOTICE
|
||||
if {[::interp exists $child]} {
|
||||
if {[catch {::safe::interpDelete $child} msg]} {
|
||||
Log $child "Deletion error : $msg"
|
||||
}
|
||||
}
|
||||
if {[winfo exists $window]} {
|
||||
Log $child "Destroy toplevel $window" NOTICE
|
||||
destroy $window
|
||||
}
|
||||
|
||||
# clean up tkInit(child)
|
||||
disallowTk $child
|
||||
return
|
||||
}
|
||||
|
||||
proc ::safe::tkTopLevel {child display} {
|
||||
variable tkSafeId
|
||||
incr tkSafeId
|
||||
set w ".safe$tkSafeId"
|
||||
if {[catch {toplevel $w -screen $display -class SafeTk} msg]} {
|
||||
return -code error -errorcode {TK TOPLEVEL SAFE} \
|
||||
"Unable to create toplevel for \"$child\" ($msg)"
|
||||
}
|
||||
Log $child "New toplevel $w" NOTICE
|
||||
|
||||
set msg "Untrusted Tcl applet ($child)"
|
||||
wm title $w $msg
|
||||
|
||||
# Control frame (we must create a style for it)
|
||||
ttk::style layout TWarningFrame {WarningFrame.border -sticky nswe}
|
||||
ttk::style configure TWarningFrame -background red
|
||||
|
||||
set wc $w.fc
|
||||
ttk::frame $wc -relief ridge -borderwidth 4 -style TWarningFrame
|
||||
|
||||
# We will destroy the interp when the window is destroyed
|
||||
bindtags $wc [concat Safe$wc [bindtags $wc]]
|
||||
bind Safe$wc <Destroy> [list ::safe::tkDelete %W $w $child]
|
||||
|
||||
ttk::label $wc.l -text $msg -anchor w
|
||||
|
||||
# We want the button to be the last visible item
|
||||
# (so be packed first) and at the right and not resizing horizontally
|
||||
|
||||
# frame the button so it does not expand horizontally
|
||||
# but still have the default background instead of red one from the parent
|
||||
ttk::frame $wc.fb -borderwidth 0
|
||||
ttk::button $wc.fb.b -text "Delete" \
|
||||
-command [list ::safe::tkDelete $w $w $child]
|
||||
pack $wc.fb.b -side right -fill both
|
||||
pack $wc.fb -side right -fill both -expand 1
|
||||
pack $wc.l -side left -fill both -expand 1 -ipady 2
|
||||
pack $wc -side bottom -fill x
|
||||
|
||||
# Container frame
|
||||
frame $w.c -container 1
|
||||
pack $w.c -fill both -expand 1
|
||||
|
||||
# return both the toplevel window name and the id to use for embedding
|
||||
list $w [winfo id $w.c]
|
||||
}
|
||||
|
|
@ -0,0 +1,290 @@
|
|||
# scale.tcl --
|
||||
#
|
||||
# This file defines the default bindings for Tk scale widgets and provides
|
||||
# procedures that help in implementing the bindings.
|
||||
#
|
||||
# Copyright (c) 1994 The Regents of the University of California.
|
||||
# Copyright (c) 1994-1995 Sun Microsystems, Inc.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
|
||||
#-------------------------------------------------------------------------
|
||||
# The code below creates the default class bindings for entries.
|
||||
#-------------------------------------------------------------------------
|
||||
|
||||
# Standard Motif bindings:
|
||||
|
||||
bind Scale <Enter> {
|
||||
if {$tk_strictMotif} {
|
||||
set tk::Priv(activeBg) [%W cget -activebackground]
|
||||
%W configure -activebackground [%W cget -background]
|
||||
}
|
||||
tk::ScaleActivate %W %x %y
|
||||
}
|
||||
bind Scale <Motion> {
|
||||
tk::ScaleActivate %W %x %y
|
||||
}
|
||||
bind Scale <Leave> {
|
||||
if {$tk_strictMotif} {
|
||||
%W configure -activebackground $tk::Priv(activeBg)
|
||||
}
|
||||
if {[%W cget -state] eq "active"} {
|
||||
%W configure -state normal
|
||||
}
|
||||
}
|
||||
bind Scale <1> {
|
||||
tk::ScaleButtonDown %W %x %y
|
||||
}
|
||||
bind Scale <B1-Motion> {
|
||||
tk::ScaleDrag %W %x %y
|
||||
}
|
||||
bind Scale <B1-Leave> { }
|
||||
bind Scale <B1-Enter> { }
|
||||
bind Scale <ButtonRelease-1> {
|
||||
tk::CancelRepeat
|
||||
tk::ScaleEndDrag %W
|
||||
tk::ScaleActivate %W %x %y
|
||||
}
|
||||
bind Scale <2> {
|
||||
tk::ScaleButton2Down %W %x %y
|
||||
}
|
||||
bind Scale <B2-Motion> {
|
||||
tk::ScaleDrag %W %x %y
|
||||
}
|
||||
bind Scale <B2-Leave> { }
|
||||
bind Scale <B2-Enter> { }
|
||||
bind Scale <ButtonRelease-2> {
|
||||
tk::CancelRepeat
|
||||
tk::ScaleEndDrag %W
|
||||
tk::ScaleActivate %W %x %y
|
||||
}
|
||||
if {[tk windowingsystem] eq "win32"} {
|
||||
# On Windows do the same with button 3, as that is the right mouse button
|
||||
bind Scale <3> [bind Scale <2>]
|
||||
bind Scale <B3-Motion> [bind Scale <B2-Motion>]
|
||||
bind Scale <B3-Leave> [bind Scale <B2-Leave>]
|
||||
bind Scale <B3-Enter> [bind Scale <B2-Enter>]
|
||||
bind Scale <ButtonRelease-3> [bind Scale <ButtonRelease-2>]
|
||||
}
|
||||
bind Scale <Control-1> {
|
||||
tk::ScaleControlPress %W %x %y
|
||||
}
|
||||
bind Scale <<PrevLine>> {
|
||||
tk::ScaleIncrement %W up little noRepeat
|
||||
}
|
||||
bind Scale <<NextLine>> {
|
||||
tk::ScaleIncrement %W down little noRepeat
|
||||
}
|
||||
bind Scale <<PrevChar>> {
|
||||
tk::ScaleIncrement %W up little noRepeat
|
||||
}
|
||||
bind Scale <<NextChar>> {
|
||||
tk::ScaleIncrement %W down little noRepeat
|
||||
}
|
||||
bind Scale <<PrevPara>> {
|
||||
tk::ScaleIncrement %W up big noRepeat
|
||||
}
|
||||
bind Scale <<NextPara>> {
|
||||
tk::ScaleIncrement %W down big noRepeat
|
||||
}
|
||||
bind Scale <<PrevWord>> {
|
||||
tk::ScaleIncrement %W up big noRepeat
|
||||
}
|
||||
bind Scale <<NextWord>> {
|
||||
tk::ScaleIncrement %W down big noRepeat
|
||||
}
|
||||
bind Scale <<LineStart>> {
|
||||
%W set [%W cget -from]
|
||||
}
|
||||
bind Scale <<LineEnd>> {
|
||||
%W set [%W cget -to]
|
||||
}
|
||||
|
||||
# ::tk::ScaleActivate --
|
||||
# This procedure is invoked to check a given x-y position in the
|
||||
# scale and activate the slider if the x-y position falls within
|
||||
# the slider.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The scale widget.
|
||||
# x, y - Mouse coordinates.
|
||||
|
||||
proc ::tk::ScaleActivate {w x y} {
|
||||
if {[$w cget -state] eq "disabled"} {
|
||||
return
|
||||
}
|
||||
if {[$w identify $x $y] eq "slider"} {
|
||||
set state active
|
||||
} else {
|
||||
set state normal
|
||||
}
|
||||
if {[$w cget -state] ne $state} {
|
||||
$w configure -state $state
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::ScaleButtonDown --
|
||||
# This procedure is invoked when a button is pressed in a scale. It
|
||||
# takes different actions depending on where the button was pressed.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The scale widget.
|
||||
# x, y - Mouse coordinates of button press.
|
||||
|
||||
proc ::tk::ScaleButtonDown {w x y} {
|
||||
variable ::tk::Priv
|
||||
set Priv(dragging) 0
|
||||
set el [$w identify $x $y]
|
||||
|
||||
# save the relief
|
||||
set Priv($w,relief) [$w cget -sliderrelief]
|
||||
|
||||
if {$el eq "trough1"} {
|
||||
ScaleIncrement $w up little initial
|
||||
} elseif {$el eq "trough2"} {
|
||||
ScaleIncrement $w down little initial
|
||||
} elseif {$el eq "slider"} {
|
||||
set Priv(dragging) 1
|
||||
set Priv(initValue) [$w get]
|
||||
set coords [$w coords]
|
||||
set Priv(deltaX) [expr {$x - [lindex $coords 0]}]
|
||||
set Priv(deltaY) [expr {$y - [lindex $coords 1]}]
|
||||
switch -exact -- $Priv($w,relief) {
|
||||
"raised" { $w configure -sliderrelief sunken }
|
||||
"ridge" { $w configure -sliderrelief groove }
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::ScaleDrag --
|
||||
# This procedure is called when the mouse is dragged with
|
||||
# mouse button 1 down. If the drag started inside the slider
|
||||
# (i.e. the scale is active) then the scale's value is adjusted
|
||||
# to reflect the mouse's position.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The scale widget.
|
||||
# x, y - Mouse coordinates.
|
||||
|
||||
proc ::tk::ScaleDrag {w x y} {
|
||||
variable ::tk::Priv
|
||||
if {!$Priv(dragging)} {
|
||||
return
|
||||
}
|
||||
$w set [$w get [expr {$x-$Priv(deltaX)}] [expr {$y-$Priv(deltaY)}]]
|
||||
}
|
||||
|
||||
# ::tk::ScaleEndDrag --
|
||||
# This procedure is called to end an interactive drag of the
|
||||
# slider. It just marks the drag as over.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The scale widget.
|
||||
|
||||
proc ::tk::ScaleEndDrag {w} {
|
||||
variable ::tk::Priv
|
||||
set Priv(dragging) 0
|
||||
if {[info exists Priv($w,relief)]} {
|
||||
$w configure -sliderrelief $Priv($w,relief)
|
||||
unset Priv($w,relief)
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::ScaleIncrement --
|
||||
# This procedure is invoked to increment the value of a scale and
|
||||
# to set up auto-repeating of the action if that is desired. The
|
||||
# way the value is incremented depends on the "dir" and "big"
|
||||
# arguments.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The scale widget.
|
||||
# dir - "up" means move value towards -from, "down" means
|
||||
# move towards -to.
|
||||
# big - Size of increments: "big" or "little".
|
||||
# repeat - Whether and how to auto-repeat the action: "noRepeat"
|
||||
# means don't auto-repeat, "initial" means this is the
|
||||
# first action in an auto-repeat sequence, and "again"
|
||||
# means this is the second repetition or later.
|
||||
|
||||
proc ::tk::ScaleIncrement {w dir big repeat} {
|
||||
variable ::tk::Priv
|
||||
if {![winfo exists $w]} return
|
||||
if {$big eq "big"} {
|
||||
set inc [$w cget -bigincrement]
|
||||
if {$inc == 0} {
|
||||
set inc [expr {abs([$w cget -to] - [$w cget -from])/10.0}]
|
||||
}
|
||||
if {$inc < [$w cget -resolution]} {
|
||||
set inc [$w cget -resolution]
|
||||
}
|
||||
} else {
|
||||
set inc [$w cget -resolution]
|
||||
}
|
||||
if {([$w cget -from] > [$w cget -to]) ^ ($dir eq "up")} {
|
||||
if {$inc > 0} {
|
||||
set inc [expr {-$inc}]
|
||||
}
|
||||
} else {
|
||||
if {$inc < 0} {
|
||||
set inc [expr {-$inc}]
|
||||
}
|
||||
}
|
||||
$w set [expr {[$w get] + $inc}]
|
||||
|
||||
if {$repeat eq "again"} {
|
||||
set Priv(afterId) [after [$w cget -repeatinterval] \
|
||||
[list tk::ScaleIncrement $w $dir $big again]]
|
||||
} elseif {$repeat eq "initial"} {
|
||||
set delay [$w cget -repeatdelay]
|
||||
if {$delay > 0} {
|
||||
set Priv(afterId) [after $delay \
|
||||
[list tk::ScaleIncrement $w $dir $big again]]
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::ScaleControlPress --
|
||||
# This procedure handles button presses that are made with the Control
|
||||
# key down. Depending on the mouse position, it adjusts the scale
|
||||
# value to one end of the range or the other.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The scale widget.
|
||||
# x, y - Mouse coordinates where the button was pressed.
|
||||
|
||||
proc ::tk::ScaleControlPress {w x y} {
|
||||
set el [$w identify $x $y]
|
||||
if {$el eq "trough1"} {
|
||||
$w set [$w cget -from]
|
||||
} elseif {$el eq "trough2"} {
|
||||
$w set [$w cget -to]
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::ScaleButton2Down
|
||||
# This procedure is invoked when button 2 is pressed over a scale.
|
||||
# It sets the value to correspond to the mouse position and starts
|
||||
# a slider drag.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The scrollbar widget.
|
||||
# x, y - Mouse coordinates within the widget.
|
||||
|
||||
proc ::tk::ScaleButton2Down {w x y} {
|
||||
variable ::tk::Priv
|
||||
|
||||
if {[$w cget -state] eq "disabled"} {
|
||||
return
|
||||
}
|
||||
|
||||
$w configure -state active
|
||||
$w set [$w get $x $y]
|
||||
set Priv(dragging) 1
|
||||
set Priv(initValue) [$w get]
|
||||
set Priv($w,relief) [$w cget -sliderrelief]
|
||||
set coords "$x $y"
|
||||
set Priv(deltaX) 0
|
||||
set Priv(deltaY) 0
|
||||
}
|
||||
|
|
@ -0,0 +1,456 @@
|
|||
# scrlbar.tcl --
|
||||
#
|
||||
# This file defines the default bindings for Tk scrollbar widgets.
|
||||
# It also provides procedures that help in implementing the bindings.
|
||||
#
|
||||
# Copyright (c) 1994 The Regents of the University of California.
|
||||
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
|
||||
#-------------------------------------------------------------------------
|
||||
# The code below creates the default class bindings for scrollbars.
|
||||
#-------------------------------------------------------------------------
|
||||
|
||||
# Standard Motif bindings:
|
||||
if {[tk windowingsystem] eq "x11" || [tk windowingsystem] eq "aqua"} {
|
||||
|
||||
bind Scrollbar <Enter> {
|
||||
if {$tk_strictMotif} {
|
||||
set tk::Priv(activeBg) [%W cget -activebackground]
|
||||
%W configure -activebackground [%W cget -background]
|
||||
}
|
||||
%W activate [%W identify %x %y]
|
||||
}
|
||||
bind Scrollbar <Motion> {
|
||||
%W activate [%W identify %x %y]
|
||||
}
|
||||
|
||||
# The "info exists" command in the following binding handles the
|
||||
# situation where a Leave event occurs for a scrollbar without the Enter
|
||||
# event. This seems to happen on some systems (such as Solaris 2.4) for
|
||||
# unknown reasons.
|
||||
|
||||
bind Scrollbar <Leave> {
|
||||
if {$tk_strictMotif && [info exists tk::Priv(activeBg)]} {
|
||||
%W configure -activebackground $tk::Priv(activeBg)
|
||||
}
|
||||
%W activate {}
|
||||
}
|
||||
bind Scrollbar <1> {
|
||||
tk::ScrollButtonDown %W %x %y
|
||||
}
|
||||
bind Scrollbar <B1-Motion> {
|
||||
tk::ScrollDrag %W %x %y
|
||||
}
|
||||
bind Scrollbar <B1-B2-Motion> {
|
||||
tk::ScrollDrag %W %x %y
|
||||
}
|
||||
bind Scrollbar <ButtonRelease-1> {
|
||||
tk::ScrollButtonUp %W %x %y
|
||||
}
|
||||
bind Scrollbar <B1-Leave> {
|
||||
# Prevents <Leave> binding from being invoked.
|
||||
}
|
||||
bind Scrollbar <B1-Enter> {
|
||||
# Prevents <Enter> binding from being invoked.
|
||||
}
|
||||
bind Scrollbar <2> {
|
||||
tk::ScrollButton2Down %W %x %y
|
||||
}
|
||||
bind Scrollbar <B1-2> {
|
||||
# Do nothing, since button 1 is already down.
|
||||
}
|
||||
bind Scrollbar <B2-1> {
|
||||
# Do nothing, since button 2 is already down.
|
||||
}
|
||||
bind Scrollbar <B2-Motion> {
|
||||
tk::ScrollDrag %W %x %y
|
||||
}
|
||||
bind Scrollbar <ButtonRelease-2> {
|
||||
tk::ScrollButtonUp %W %x %y
|
||||
}
|
||||
bind Scrollbar <B1-ButtonRelease-2> {
|
||||
# Do nothing: B1 release will handle it.
|
||||
}
|
||||
bind Scrollbar <B2-ButtonRelease-1> {
|
||||
# Do nothing: B2 release will handle it.
|
||||
}
|
||||
bind Scrollbar <B2-Leave> {
|
||||
# Prevents <Leave> binding from being invoked.
|
||||
}
|
||||
bind Scrollbar <B2-Enter> {
|
||||
# Prevents <Enter> binding from being invoked.
|
||||
}
|
||||
bind Scrollbar <Control-1> {
|
||||
tk::ScrollTopBottom %W %x %y
|
||||
}
|
||||
bind Scrollbar <Control-2> {
|
||||
tk::ScrollTopBottom %W %x %y
|
||||
}
|
||||
|
||||
bind Scrollbar <<PrevLine>> {
|
||||
tk::ScrollByUnits %W v -1
|
||||
}
|
||||
bind Scrollbar <<NextLine>> {
|
||||
tk::ScrollByUnits %W v 1
|
||||
}
|
||||
bind Scrollbar <<PrevPara>> {
|
||||
tk::ScrollByPages %W v -1
|
||||
}
|
||||
bind Scrollbar <<NextPara>> {
|
||||
tk::ScrollByPages %W v 1
|
||||
}
|
||||
bind Scrollbar <<PrevChar>> {
|
||||
tk::ScrollByUnits %W h -1
|
||||
}
|
||||
bind Scrollbar <<NextChar>> {
|
||||
tk::ScrollByUnits %W h 1
|
||||
}
|
||||
bind Scrollbar <<PrevWord>> {
|
||||
tk::ScrollByPages %W h -1
|
||||
}
|
||||
bind Scrollbar <<NextWord>> {
|
||||
tk::ScrollByPages %W h 1
|
||||
}
|
||||
bind Scrollbar <Prior> {
|
||||
tk::ScrollByPages %W hv -1
|
||||
}
|
||||
bind Scrollbar <Next> {
|
||||
tk::ScrollByPages %W hv 1
|
||||
}
|
||||
bind Scrollbar <<LineStart>> {
|
||||
tk::ScrollToPos %W 0
|
||||
}
|
||||
bind Scrollbar <<LineEnd>> {
|
||||
tk::ScrollToPos %W 1
|
||||
}
|
||||
}
|
||||
|
||||
if {[tk windowingsystem] eq "aqua"} {
|
||||
bind Scrollbar <MouseWheel> {
|
||||
tk::ScrollByUnits %W v [expr {-(%D)}]
|
||||
}
|
||||
bind Scrollbar <Option-MouseWheel> {
|
||||
tk::ScrollByUnits %W v [expr {-10 * (%D)}]
|
||||
}
|
||||
bind Scrollbar <Shift-MouseWheel> {
|
||||
tk::ScrollByUnits %W h [expr {-(%D)}]
|
||||
}
|
||||
bind Scrollbar <Shift-Option-MouseWheel> {
|
||||
tk::ScrollByUnits %W h [expr {-10 * (%D)}]
|
||||
}
|
||||
} else {
|
||||
bind Scrollbar <MouseWheel> {
|
||||
if {%D >= 0} {
|
||||
tk::ScrollByUnits %W v [expr {-%D/30}]
|
||||
} else {
|
||||
tk::ScrollByUnits %W v [expr {(29-%D)/30}]
|
||||
}
|
||||
}
|
||||
bind Scrollbar <Shift-MouseWheel> {
|
||||
if {%D >= 0} {
|
||||
tk::ScrollByUnits %W h [expr {-%D/30}]
|
||||
} else {
|
||||
tk::ScrollByUnits %W h [expr {(29-%D)/30}]
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if {[tk windowingsystem] eq "x11"} {
|
||||
bind Scrollbar <4> {tk::ScrollByUnits %W v -5}
|
||||
bind Scrollbar <5> {tk::ScrollByUnits %W v 5}
|
||||
bind Scrollbar <Shift-4> {tk::ScrollByUnits %W h -5}
|
||||
bind Scrollbar <Shift-5> {tk::ScrollByUnits %W h 5}
|
||||
}
|
||||
|
||||
# tk::ScrollButtonDown --
|
||||
# This procedure is invoked when a button is pressed in a scrollbar.
|
||||
# It changes the way the scrollbar is displayed and takes actions
|
||||
# depending on where the mouse is.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The scrollbar widget.
|
||||
# x, y - Mouse coordinates.
|
||||
|
||||
proc tk::ScrollButtonDown {w x y} {
|
||||
variable ::tk::Priv
|
||||
set Priv(relief) [$w cget -activerelief]
|
||||
$w configure -activerelief sunken
|
||||
set element [$w identify $x $y]
|
||||
if {$element eq "slider"} {
|
||||
ScrollStartDrag $w $x $y
|
||||
} else {
|
||||
ScrollSelect $w $element initial
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::ScrollButtonUp --
|
||||
# This procedure is invoked when a button is released in a scrollbar.
|
||||
# It cancels scans and auto-repeats that were in progress, and restores
|
||||
# the way the active element is displayed.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The scrollbar widget.
|
||||
# x, y - Mouse coordinates.
|
||||
|
||||
proc ::tk::ScrollButtonUp {w x y} {
|
||||
variable ::tk::Priv
|
||||
tk::CancelRepeat
|
||||
if {[info exists Priv(relief)]} {
|
||||
# Avoid error due to spurious release events
|
||||
$w configure -activerelief $Priv(relief)
|
||||
ScrollEndDrag $w $x $y
|
||||
$w activate [$w identify $x $y]
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::ScrollSelect --
|
||||
# This procedure is invoked when a button is pressed over the scrollbar.
|
||||
# It invokes one of several scrolling actions depending on where in
|
||||
# the scrollbar the button was pressed.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The scrollbar widget.
|
||||
# element - The element of the scrollbar that was selected, such
|
||||
# as "arrow1" or "trough2". Shouldn't be "slider".
|
||||
# repeat - Whether and how to auto-repeat the action: "noRepeat"
|
||||
# means don't auto-repeat, "initial" means this is the
|
||||
# first action in an auto-repeat sequence, and "again"
|
||||
# means this is the second repetition or later.
|
||||
|
||||
proc ::tk::ScrollSelect {w element repeat} {
|
||||
variable ::tk::Priv
|
||||
if {![winfo exists $w]} return
|
||||
switch -- $element {
|
||||
"arrow1" {ScrollByUnits $w hv -1}
|
||||
"trough1" {ScrollByPages $w hv -1}
|
||||
"trough2" {ScrollByPages $w hv 1}
|
||||
"arrow2" {ScrollByUnits $w hv 1}
|
||||
default {return}
|
||||
}
|
||||
if {$repeat eq "again"} {
|
||||
set Priv(afterId) [after [$w cget -repeatinterval] \
|
||||
[list tk::ScrollSelect $w $element again]]
|
||||
} elseif {$repeat eq "initial"} {
|
||||
set delay [$w cget -repeatdelay]
|
||||
if {$delay > 0} {
|
||||
set Priv(afterId) [after $delay \
|
||||
[list tk::ScrollSelect $w $element again]]
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::ScrollStartDrag --
|
||||
# This procedure is called to initiate a drag of the slider. It just
|
||||
# remembers the starting position of the mouse and slider.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The scrollbar widget.
|
||||
# x, y - The mouse position at the start of the drag operation.
|
||||
|
||||
proc ::tk::ScrollStartDrag {w x y} {
|
||||
variable ::tk::Priv
|
||||
|
||||
if {[$w cget -command] eq ""} {
|
||||
return
|
||||
}
|
||||
set Priv(pressX) $x
|
||||
set Priv(pressY) $y
|
||||
set Priv(initValues) [$w get]
|
||||
set iv0 [lindex $Priv(initValues) 0]
|
||||
if {[llength $Priv(initValues)] == 2} {
|
||||
set Priv(initPos) $iv0
|
||||
} elseif {$iv0 == 0} {
|
||||
set Priv(initPos) 0.0
|
||||
} else {
|
||||
set Priv(initPos) [expr {(double([lindex $Priv(initValues) 2])) \
|
||||
/ [lindex $Priv(initValues) 0]}]
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::ScrollDrag --
|
||||
# This procedure is called for each mouse motion even when the slider
|
||||
# is being dragged. It notifies the associated widget if we're not
|
||||
# jump scrolling, and it just updates the scrollbar if we are jump
|
||||
# scrolling.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The scrollbar widget.
|
||||
# x, y - The current mouse position.
|
||||
|
||||
proc ::tk::ScrollDrag {w x y} {
|
||||
variable ::tk::Priv
|
||||
|
||||
if {$Priv(initPos) eq ""} {
|
||||
return
|
||||
}
|
||||
set delta [$w delta [expr {$x - $Priv(pressX)}] [expr {$y - $Priv(pressY)}]]
|
||||
if {[$w cget -jump]} {
|
||||
if {[llength $Priv(initValues)] == 2} {
|
||||
$w set [expr {[lindex $Priv(initValues) 0] + $delta}] \
|
||||
[expr {[lindex $Priv(initValues) 1] + $delta}]
|
||||
} else {
|
||||
set delta [expr {round($delta * [lindex $Priv(initValues) 0])}]
|
||||
eval [list $w] set [lreplace $Priv(initValues) 2 3 \
|
||||
[expr {[lindex $Priv(initValues) 2] + $delta}] \
|
||||
[expr {[lindex $Priv(initValues) 3] + $delta}]]
|
||||
}
|
||||
} else {
|
||||
ScrollToPos $w [expr {$Priv(initPos) + $delta}]
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::ScrollEndDrag --
|
||||
# This procedure is called to end an interactive drag of the slider.
|
||||
# It scrolls the window if we're in jump mode, otherwise it does nothing.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The scrollbar widget.
|
||||
# x, y - The mouse position at the end of the drag operation.
|
||||
|
||||
proc ::tk::ScrollEndDrag {w x y} {
|
||||
variable ::tk::Priv
|
||||
|
||||
if {$Priv(initPos) eq ""} {
|
||||
return
|
||||
}
|
||||
if {[$w cget -jump]} {
|
||||
set delta [$w delta [expr {$x - $Priv(pressX)}] \
|
||||
[expr {$y - $Priv(pressY)}]]
|
||||
ScrollToPos $w [expr {$Priv(initPos) + $delta}]
|
||||
}
|
||||
set Priv(initPos) ""
|
||||
}
|
||||
|
||||
# ::tk::ScrollByUnits --
|
||||
# This procedure tells the scrollbar's associated widget to scroll up
|
||||
# or down by a given number of units. It notifies the associated widget
|
||||
# in different ways for old and new command syntaxes.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The scrollbar widget.
|
||||
# orient - Which kinds of scrollbars this applies to: "h" for
|
||||
# horizontal, "v" for vertical, "hv" for both.
|
||||
# amount - How many units to scroll: typically 1 or -1.
|
||||
|
||||
proc ::tk::ScrollByUnits {w orient amount} {
|
||||
set cmd [$w cget -command]
|
||||
if {$cmd eq "" || ([string first \
|
||||
[string index [$w cget -orient] 0] $orient] < 0)} {
|
||||
return
|
||||
}
|
||||
set info [$w get]
|
||||
if {[llength $info] == 2} {
|
||||
uplevel #0 $cmd scroll $amount units
|
||||
} else {
|
||||
uplevel #0 $cmd [expr {[lindex $info 2] + $amount}]
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::ScrollByPages --
|
||||
# This procedure tells the scrollbar's associated widget to scroll up
|
||||
# or down by a given number of screenfuls. It notifies the associated
|
||||
# widget in different ways for old and new command syntaxes.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The scrollbar widget.
|
||||
# orient - Which kinds of scrollbars this applies to: "h" for
|
||||
# horizontal, "v" for vertical, "hv" for both.
|
||||
# amount - How many screens to scroll: typically 1 or -1.
|
||||
|
||||
proc ::tk::ScrollByPages {w orient amount} {
|
||||
set cmd [$w cget -command]
|
||||
if {$cmd eq "" || ([string first \
|
||||
[string index [$w cget -orient] 0] $orient] < 0)} {
|
||||
return
|
||||
}
|
||||
set info [$w get]
|
||||
if {[llength $info] == 2} {
|
||||
uplevel #0 $cmd scroll $amount pages
|
||||
} else {
|
||||
uplevel #0 $cmd [expr {[lindex $info 2] + $amount*([lindex $info 1] - 1)}]
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::ScrollToPos --
|
||||
# This procedure tells the scrollbar's associated widget to scroll to
|
||||
# a particular location, given by a fraction between 0 and 1. It notifies
|
||||
# the associated widget in different ways for old and new command syntaxes.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The scrollbar widget.
|
||||
# pos - A fraction between 0 and 1 indicating a desired position
|
||||
# in the document.
|
||||
|
||||
proc ::tk::ScrollToPos {w pos} {
|
||||
set cmd [$w cget -command]
|
||||
if {$cmd eq ""} {
|
||||
return
|
||||
}
|
||||
set info [$w get]
|
||||
if {[llength $info] == 2} {
|
||||
uplevel #0 $cmd moveto $pos
|
||||
} else {
|
||||
uplevel #0 $cmd [expr {round([lindex $info 0]*$pos)}]
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::ScrollTopBottom
|
||||
# Scroll to the top or bottom of the document, depending on the mouse
|
||||
# position.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The scrollbar widget.
|
||||
# x, y - Mouse coordinates within the widget.
|
||||
|
||||
proc ::tk::ScrollTopBottom {w x y} {
|
||||
variable ::tk::Priv
|
||||
set element [$w identify $x $y]
|
||||
if {[string match *1 $element]} {
|
||||
ScrollToPos $w 0
|
||||
} elseif {[string match *2 $element]} {
|
||||
ScrollToPos $w 1
|
||||
}
|
||||
|
||||
# Set Priv(relief), since it's needed by tk::ScrollButtonUp.
|
||||
|
||||
set Priv(relief) [$w cget -activerelief]
|
||||
}
|
||||
|
||||
# ::tk::ScrollButton2Down
|
||||
# This procedure is invoked when button 2 is pressed over a scrollbar.
|
||||
# If the button is over the trough or slider, it sets the scrollbar to
|
||||
# the mouse position and starts a slider drag. Otherwise it just
|
||||
# behaves the same as button 1.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The scrollbar widget.
|
||||
# x, y - Mouse coordinates within the widget.
|
||||
|
||||
proc ::tk::ScrollButton2Down {w x y} {
|
||||
variable ::tk::Priv
|
||||
if {![winfo exists $w]} {
|
||||
return
|
||||
}
|
||||
set element [$w identify $x $y]
|
||||
if {[string match {arrow[12]} $element]} {
|
||||
ScrollButtonDown $w $x $y
|
||||
return
|
||||
}
|
||||
ScrollToPos $w [$w fraction $x $y]
|
||||
set Priv(relief) [$w cget -activerelief]
|
||||
|
||||
# Need the "update idletasks" below so that the widget calls us
|
||||
# back to reset the actual scrollbar position before we start the
|
||||
# slider drag.
|
||||
|
||||
update idletasks
|
||||
if {[winfo exists $w]} {
|
||||
$w configure -activerelief sunken
|
||||
$w activate slider
|
||||
ScrollStartDrag $w $x $y
|
||||
}
|
||||
}
|
||||
|
|
@ -0,0 +1,593 @@
|
|||
# spinbox.tcl --
|
||||
#
|
||||
# This file defines the default bindings for Tk spinbox widgets and provides
|
||||
# procedures that help in implementing those bindings. The spinbox builds
|
||||
# off the entry widget, so it can reuse Entry bindings and procedures.
|
||||
#
|
||||
# Copyright (c) 1992-1994 The Regents of the University of California.
|
||||
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1999-2000 Jeffrey Hobbs
|
||||
# Copyright (c) 2000 Ajuba Solutions
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
|
||||
#-------------------------------------------------------------------------
|
||||
# Elements of tk::Priv that are used in this file:
|
||||
#
|
||||
# afterId - If non-null, it means that auto-scanning is underway
|
||||
# and it gives the "after" id for the next auto-scan
|
||||
# command to be executed.
|
||||
# mouseMoved - Non-zero means the mouse has moved a significant
|
||||
# amount since the button went down (so, for example,
|
||||
# start dragging out a selection).
|
||||
# pressX - X-coordinate at which the mouse button was pressed.
|
||||
# selectMode - The style of selection currently underway:
|
||||
# char, word, or line.
|
||||
# x, y - Last known mouse coordinates for scanning
|
||||
# and auto-scanning.
|
||||
# data - Used for Cut and Copy
|
||||
#-------------------------------------------------------------------------
|
||||
|
||||
# Initialize namespace
|
||||
namespace eval ::tk::spinbox {}
|
||||
|
||||
#-------------------------------------------------------------------------
|
||||
# The code below creates the default class bindings for entries.
|
||||
#-------------------------------------------------------------------------
|
||||
bind Spinbox <<Cut>> {
|
||||
if {![catch {::tk::spinbox::GetSelection %W} tk::Priv(data)]} {
|
||||
clipboard clear -displayof %W
|
||||
clipboard append -displayof %W $tk::Priv(data)
|
||||
%W delete sel.first sel.last
|
||||
unset tk::Priv(data)
|
||||
}
|
||||
}
|
||||
bind Spinbox <<Copy>> {
|
||||
if {![catch {::tk::spinbox::GetSelection %W} tk::Priv(data)]} {
|
||||
clipboard clear -displayof %W
|
||||
clipboard append -displayof %W $tk::Priv(data)
|
||||
unset tk::Priv(data)
|
||||
}
|
||||
}
|
||||
bind Spinbox <<Paste>> {
|
||||
catch {
|
||||
if {[tk windowingsystem] ne "x11"} {
|
||||
catch {
|
||||
%W delete sel.first sel.last
|
||||
}
|
||||
}
|
||||
%W insert insert [::tk::GetSelection %W CLIPBOARD]
|
||||
::tk::EntrySeeInsert %W
|
||||
}
|
||||
}
|
||||
bind Spinbox <<Clear>> {
|
||||
%W delete sel.first sel.last
|
||||
}
|
||||
bind Spinbox <<PasteSelection>> {
|
||||
if {$tk_strictMotif || ![info exists tk::Priv(mouseMoved)]
|
||||
|| !$tk::Priv(mouseMoved)} {
|
||||
::tk::spinbox::Paste %W %x
|
||||
}
|
||||
}
|
||||
|
||||
bind Spinbox <<TraverseIn>> {
|
||||
%W selection range 0 end
|
||||
%W icursor end
|
||||
}
|
||||
|
||||
# Standard Motif bindings:
|
||||
|
||||
bind Spinbox <1> {
|
||||
::tk::spinbox::ButtonDown %W %x %y
|
||||
}
|
||||
bind Spinbox <B1-Motion> {
|
||||
::tk::spinbox::Motion %W %x %y
|
||||
}
|
||||
bind Spinbox <Double-1> {
|
||||
::tk::spinbox::ArrowPress %W %x %y
|
||||
set tk::Priv(selectMode) word
|
||||
::tk::spinbox::MouseSelect %W %x sel.first
|
||||
}
|
||||
bind Spinbox <Triple-1> {
|
||||
::tk::spinbox::ArrowPress %W %x %y
|
||||
set tk::Priv(selectMode) line
|
||||
::tk::spinbox::MouseSelect %W %x 0
|
||||
}
|
||||
bind Spinbox <Shift-1> {
|
||||
set tk::Priv(selectMode) char
|
||||
%W selection adjust @%x
|
||||
}
|
||||
bind Spinbox <Double-Shift-1> {
|
||||
set tk::Priv(selectMode) word
|
||||
::tk::spinbox::MouseSelect %W %x
|
||||
}
|
||||
bind Spinbox <Triple-Shift-1> {
|
||||
set tk::Priv(selectMode) line
|
||||
::tk::spinbox::MouseSelect %W %x
|
||||
}
|
||||
bind Spinbox <B1-Leave> {
|
||||
set tk::Priv(x) %x
|
||||
::tk::spinbox::AutoScan %W
|
||||
}
|
||||
bind Spinbox <B1-Enter> {
|
||||
tk::CancelRepeat
|
||||
}
|
||||
bind Spinbox <ButtonRelease-1> {
|
||||
::tk::spinbox::ButtonUp %W %x %y
|
||||
}
|
||||
bind Spinbox <Control-1> {
|
||||
%W icursor @%x
|
||||
}
|
||||
|
||||
bind Spinbox <<PrevLine>> {
|
||||
%W invoke buttonup
|
||||
}
|
||||
bind Spinbox <<NextLine>> {
|
||||
%W invoke buttondown
|
||||
}
|
||||
|
||||
bind Spinbox <<PrevChar>> {
|
||||
::tk::EntrySetCursor %W [expr {[%W index insert] - 1}]
|
||||
}
|
||||
bind Spinbox <<NextChar>> {
|
||||
::tk::EntrySetCursor %W [expr {[%W index insert] + 1}]
|
||||
}
|
||||
bind Spinbox <<SelectPrevChar>> {
|
||||
::tk::EntryKeySelect %W [expr {[%W index insert] - 1}]
|
||||
::tk::EntrySeeInsert %W
|
||||
}
|
||||
bind Spinbox <<SelectNextChar>> {
|
||||
::tk::EntryKeySelect %W [expr {[%W index insert] + 1}]
|
||||
::tk::EntrySeeInsert %W
|
||||
}
|
||||
bind Spinbox <<PrevWord>> {
|
||||
::tk::EntrySetCursor %W [::tk::EntryPreviousWord %W insert]
|
||||
}
|
||||
bind Spinbox <<NextWord>> {
|
||||
::tk::EntrySetCursor %W [::tk::EntryNextWord %W insert]
|
||||
}
|
||||
bind Spinbox <<SelectPrevWord>> {
|
||||
::tk::EntryKeySelect %W [::tk::EntryPreviousWord %W insert]
|
||||
::tk::EntrySeeInsert %W
|
||||
}
|
||||
bind Spinbox <<SelectNextWord>> {
|
||||
::tk::EntryKeySelect %W [::tk::EntryNextWord %W insert]
|
||||
::tk::EntrySeeInsert %W
|
||||
}
|
||||
bind Spinbox <<LineStart>> {
|
||||
::tk::EntrySetCursor %W 0
|
||||
}
|
||||
bind Spinbox <<SelectLineStart>> {
|
||||
::tk::EntryKeySelect %W 0
|
||||
::tk::EntrySeeInsert %W
|
||||
}
|
||||
bind Spinbox <<LineEnd>> {
|
||||
::tk::EntrySetCursor %W end
|
||||
}
|
||||
bind Spinbox <<SelectLineEnd>> {
|
||||
::tk::EntryKeySelect %W end
|
||||
::tk::EntrySeeInsert %W
|
||||
}
|
||||
|
||||
bind Spinbox <Delete> {
|
||||
if {[%W selection present]} {
|
||||
%W delete sel.first sel.last
|
||||
} else {
|
||||
%W delete insert
|
||||
}
|
||||
}
|
||||
bind Spinbox <BackSpace> {
|
||||
::tk::EntryBackspace %W
|
||||
}
|
||||
|
||||
bind Spinbox <Control-space> {
|
||||
%W selection from insert
|
||||
}
|
||||
bind Spinbox <Select> {
|
||||
%W selection from insert
|
||||
}
|
||||
bind Spinbox <Control-Shift-space> {
|
||||
%W selection adjust insert
|
||||
}
|
||||
bind Spinbox <Shift-Select> {
|
||||
%W selection adjust insert
|
||||
}
|
||||
bind Spinbox <<SelectAll>> {
|
||||
%W selection range 0 end
|
||||
}
|
||||
bind Spinbox <<SelectNone>> {
|
||||
%W selection clear
|
||||
}
|
||||
bind Spinbox <KeyPress> {
|
||||
::tk::EntryInsert %W %A
|
||||
}
|
||||
|
||||
# Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
|
||||
# Otherwise, if a widget binding for one of these is defined, the
|
||||
# <KeyPress> class binding will also fire and insert the character,
|
||||
# which is wrong. Ditto for Escape, Return, and Tab.
|
||||
|
||||
bind Spinbox <Alt-KeyPress> {# nothing}
|
||||
bind Spinbox <Meta-KeyPress> {# nothing}
|
||||
bind Spinbox <Control-KeyPress> {# nothing}
|
||||
bind Spinbox <Escape> {# nothing}
|
||||
bind Spinbox <Return> {# nothing}
|
||||
bind Spinbox <KP_Enter> {# nothing}
|
||||
bind Spinbox <Tab> {# nothing}
|
||||
bind Spinbox <Prior> {# nothing}
|
||||
bind Spinbox <Next> {# nothing}
|
||||
if {[tk windowingsystem] eq "aqua"} {
|
||||
bind Spinbox <Command-KeyPress> {# nothing}
|
||||
}
|
||||
|
||||
# On Windows, paste is done using Shift-Insert. Shift-Insert already
|
||||
# generates the <<Paste>> event, so we don't need to do anything here.
|
||||
if {[tk windowingsystem] ne "win32"} {
|
||||
bind Spinbox <Insert> {
|
||||
catch {::tk::EntryInsert %W [::tk::GetSelection %W PRIMARY]}
|
||||
}
|
||||
}
|
||||
|
||||
# Additional emacs-like bindings:
|
||||
|
||||
bind Spinbox <Control-d> {
|
||||
if {!$tk_strictMotif} {
|
||||
%W delete insert
|
||||
}
|
||||
}
|
||||
bind Spinbox <Control-h> {
|
||||
if {!$tk_strictMotif} {
|
||||
::tk::EntryBackspace %W
|
||||
}
|
||||
}
|
||||
bind Spinbox <Control-k> {
|
||||
if {!$tk_strictMotif} {
|
||||
%W delete insert end
|
||||
}
|
||||
}
|
||||
bind Spinbox <Control-t> {
|
||||
if {!$tk_strictMotif} {
|
||||
::tk::EntryTranspose %W
|
||||
}
|
||||
}
|
||||
bind Spinbox <Meta-b> {
|
||||
if {!$tk_strictMotif} {
|
||||
::tk::EntrySetCursor %W [::tk::EntryPreviousWord %W insert]
|
||||
}
|
||||
}
|
||||
bind Spinbox <Meta-d> {
|
||||
if {!$tk_strictMotif} {
|
||||
%W delete insert [::tk::EntryNextWord %W insert]
|
||||
}
|
||||
}
|
||||
bind Spinbox <Meta-f> {
|
||||
if {!$tk_strictMotif} {
|
||||
::tk::EntrySetCursor %W [::tk::EntryNextWord %W insert]
|
||||
}
|
||||
}
|
||||
bind Spinbox <Meta-BackSpace> {
|
||||
if {!$tk_strictMotif} {
|
||||
%W delete [::tk::EntryPreviousWord %W insert] insert
|
||||
}
|
||||
}
|
||||
bind Spinbox <Meta-Delete> {
|
||||
if {!$tk_strictMotif} {
|
||||
%W delete [::tk::EntryPreviousWord %W insert] insert
|
||||
}
|
||||
}
|
||||
|
||||
# A few additional bindings of my own.
|
||||
|
||||
if {[tk windowingsystem] ne "aqua"} {
|
||||
bind Spinbox <2> {
|
||||
if {!$tk_strictMotif} {
|
||||
::tk::EntryScanMark %W %x
|
||||
}
|
||||
}
|
||||
bind Spinbox <B2-Motion> {
|
||||
if {!$tk_strictMotif} {
|
||||
::tk::EntryScanDrag %W %x
|
||||
}
|
||||
}
|
||||
} else {
|
||||
bind Spinbox <3> {
|
||||
if {!$tk_strictMotif} {
|
||||
::tk::EntryScanMark %W %x
|
||||
}
|
||||
}
|
||||
bind Spinbox <B3-Motion> {
|
||||
if {!$tk_strictMotif} {
|
||||
::tk::EntryScanDrag %W %x
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::spinbox::Invoke --
|
||||
# Invoke an element of the spinbox
|
||||
#
|
||||
# Arguments:
|
||||
# w - The spinbox window.
|
||||
# elem - Element to invoke
|
||||
|
||||
proc ::tk::spinbox::Invoke {w elem} {
|
||||
variable ::tk::Priv
|
||||
|
||||
if {![winfo exists $w]} {
|
||||
return
|
||||
}
|
||||
|
||||
if {![info exists Priv(outsideElement)]} {
|
||||
$w invoke $elem
|
||||
incr Priv(repeated)
|
||||
}
|
||||
set delay [$w cget -repeatinterval]
|
||||
if {$delay > 0} {
|
||||
set Priv(afterId) [after $delay \
|
||||
[list ::tk::spinbox::Invoke $w $elem]]
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::spinbox::ClosestGap --
|
||||
# Given x and y coordinates, this procedure finds the closest boundary
|
||||
# between characters to the given coordinates and returns the index
|
||||
# of the character just after the boundary.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The spinbox window.
|
||||
# x - X-coordinate within the window.
|
||||
|
||||
proc ::tk::spinbox::ClosestGap {w x} {
|
||||
set pos [$w index @$x]
|
||||
set bbox [$w bbox $pos]
|
||||
if {($x - [lindex $bbox 0]) < ([lindex $bbox 2]/2)} {
|
||||
return $pos
|
||||
}
|
||||
incr pos
|
||||
}
|
||||
|
||||
# ::tk::spinbox::ArrowPress --
|
||||
# This procedure is invoked to handle button-1 presses in buttonup
|
||||
# or buttondown elements of spinbox widgets.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The spinbox window in which the button was pressed.
|
||||
# x - The x-coordinate of the button press.
|
||||
# y - The y-coordinate of the button press.
|
||||
|
||||
proc ::tk::spinbox::ArrowPress {w x y} {
|
||||
variable ::tk::Priv
|
||||
|
||||
if {[$w cget -state] ne "disabled" && \
|
||||
[string match "button*" $Priv(element)]} {
|
||||
$w selection element $Priv(element)
|
||||
set Priv(repeated) 0
|
||||
set Priv(relief) [$w cget -$Priv(element)relief]
|
||||
catch {after cancel $Priv(afterId)}
|
||||
set delay [$w cget -repeatdelay]
|
||||
if {$delay > 0} {
|
||||
set Priv(afterId) [after $delay \
|
||||
[list ::tk::spinbox::Invoke $w $Priv(element)]]
|
||||
}
|
||||
if {[info exists Priv(outsideElement)]} {
|
||||
unset Priv(outsideElement)
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::spinbox::ButtonDown --
|
||||
# This procedure is invoked to handle button-1 presses in spinbox
|
||||
# widgets. It moves the insertion cursor, sets the selection anchor,
|
||||
# and claims the input focus.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The spinbox window in which the button was pressed.
|
||||
# x - The x-coordinate of the button press.
|
||||
# y - The y-coordinate of the button press.
|
||||
|
||||
proc ::tk::spinbox::ButtonDown {w x y} {
|
||||
variable ::tk::Priv
|
||||
|
||||
# Get the element that was clicked in. If we are not directly over
|
||||
# the spinbox, default to entry. This is necessary for spinbox grabs.
|
||||
#
|
||||
set Priv(element) [$w identify $x $y]
|
||||
if {$Priv(element) eq ""} {
|
||||
set Priv(element) "entry"
|
||||
}
|
||||
|
||||
switch -exact $Priv(element) {
|
||||
"buttonup" - "buttondown" {
|
||||
::tk::spinbox::ArrowPress $w $x $y
|
||||
}
|
||||
"entry" {
|
||||
set Priv(selectMode) char
|
||||
set Priv(mouseMoved) 0
|
||||
set Priv(pressX) $x
|
||||
$w icursor [::tk::spinbox::ClosestGap $w $x]
|
||||
$w selection from insert
|
||||
if {"disabled" ne [$w cget -state]} {focus $w}
|
||||
$w selection clear
|
||||
}
|
||||
default {
|
||||
return -code error -errorcode {TK SPINBOX UNKNOWN_ELEMENT} \
|
||||
"unknown spinbox element \"$Priv(element)\""
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::spinbox::ButtonUp --
|
||||
# This procedure is invoked to handle button-1 releases in spinbox
|
||||
# widgets.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The spinbox window in which the button was pressed.
|
||||
# x - The x-coordinate of the button press.
|
||||
# y - The y-coordinate of the button press.
|
||||
|
||||
proc ::tk::spinbox::ButtonUp {w x y} {
|
||||
variable ::tk::Priv
|
||||
|
||||
::tk::CancelRepeat
|
||||
|
||||
# Priv(relief) may not exist if the ButtonUp is not paired with
|
||||
# a preceding ButtonDown
|
||||
if {[info exists Priv(element)] && [info exists Priv(relief)] && \
|
||||
[string match "button*" $Priv(element)]} {
|
||||
if {[info exists Priv(repeated)] && !$Priv(repeated)} {
|
||||
$w invoke $Priv(element)
|
||||
}
|
||||
$w configure -$Priv(element)relief $Priv(relief)
|
||||
$w selection element none
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::spinbox::MouseSelect --
|
||||
# This procedure is invoked when dragging out a selection with
|
||||
# the mouse. Depending on the selection mode (character, word,
|
||||
# line) it selects in different-sized units. This procedure
|
||||
# ignores mouse motions initially until the mouse has moved from
|
||||
# one character to another or until there have been multiple clicks.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The spinbox window in which the button was pressed.
|
||||
# x - The x-coordinate of the mouse.
|
||||
# cursor - optional place to set cursor.
|
||||
|
||||
proc ::tk::spinbox::MouseSelect {w x {cursor {}}} {
|
||||
variable ::tk::Priv
|
||||
|
||||
if {$Priv(element) ne "entry"} {
|
||||
# The ButtonUp command triggered by ButtonRelease-1 handles
|
||||
# invoking one of the spinbuttons.
|
||||
return
|
||||
}
|
||||
set cur [::tk::spinbox::ClosestGap $w $x]
|
||||
set anchor [$w index anchor]
|
||||
if {($cur ne $anchor) || (abs($Priv(pressX) - $x) >= 3)} {
|
||||
set Priv(mouseMoved) 1
|
||||
}
|
||||
switch $Priv(selectMode) {
|
||||
char {
|
||||
if {$Priv(mouseMoved)} {
|
||||
if {$cur < $anchor} {
|
||||
$w selection range $cur $anchor
|
||||
} elseif {$cur > $anchor} {
|
||||
$w selection range $anchor $cur
|
||||
} else {
|
||||
$w selection clear
|
||||
}
|
||||
}
|
||||
}
|
||||
word {
|
||||
if {$cur < [$w index anchor]} {
|
||||
set before [tcl_wordBreakBefore [$w get] $cur]
|
||||
set after [tcl_wordBreakAfter [$w get] $anchor-1]
|
||||
} else {
|
||||
set before [tcl_wordBreakBefore [$w get] $anchor]
|
||||
set after [tcl_wordBreakAfter [$w get] $cur-1]
|
||||
}
|
||||
if {$before < 0} {
|
||||
set before 0
|
||||
}
|
||||
if {$after < 0} {
|
||||
set after end
|
||||
}
|
||||
$w selection range $before $after
|
||||
}
|
||||
line {
|
||||
$w selection range 0 end
|
||||
}
|
||||
}
|
||||
if {$cursor ne {} && $cursor ne "ignore"} {
|
||||
catch {$w icursor $cursor}
|
||||
}
|
||||
update idletasks
|
||||
}
|
||||
|
||||
# ::tk::spinbox::Paste --
|
||||
# This procedure sets the insertion cursor to the current mouse position,
|
||||
# pastes the selection there, and sets the focus to the window.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The spinbox window.
|
||||
# x - X position of the mouse.
|
||||
|
||||
proc ::tk::spinbox::Paste {w x} {
|
||||
$w icursor [::tk::spinbox::ClosestGap $w $x]
|
||||
catch {$w insert insert [::tk::GetSelection $w PRIMARY]}
|
||||
if {"disabled" eq [$w cget -state]} {
|
||||
focus $w
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::spinbox::Motion --
|
||||
# This procedure is invoked when the mouse moves in a spinbox window
|
||||
# with button 1 down.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The spinbox window.
|
||||
# x - The x-coordinate of the mouse.
|
||||
# y - The y-coordinate of the mouse.
|
||||
|
||||
proc ::tk::spinbox::Motion {w x y} {
|
||||
variable ::tk::Priv
|
||||
|
||||
if {![info exists Priv(element)]} {
|
||||
set Priv(element) [$w identify $x $y]
|
||||
}
|
||||
|
||||
set Priv(x) $x
|
||||
if {"entry" eq $Priv(element)} {
|
||||
::tk::spinbox::MouseSelect $w $x ignore
|
||||
} elseif {[$w identify $x $y] ne $Priv(element)} {
|
||||
if {![info exists Priv(outsideElement)]} {
|
||||
# We've wandered out of the spin button
|
||||
# setting outside element will cause ::tk::spinbox::Invoke to
|
||||
# loop without doing anything
|
||||
set Priv(outsideElement) ""
|
||||
$w selection element none
|
||||
}
|
||||
} elseif {[info exists Priv(outsideElement)]} {
|
||||
unset Priv(outsideElement)
|
||||
$w selection element $Priv(element)
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::spinbox::AutoScan --
|
||||
# This procedure is invoked when the mouse leaves an spinbox window
|
||||
# with button 1 down. It scrolls the window left or right,
|
||||
# depending on where the mouse is, and reschedules itself as an
|
||||
# "after" command so that the window continues to scroll until the
|
||||
# mouse moves back into the window or the mouse button is released.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The spinbox window.
|
||||
|
||||
proc ::tk::spinbox::AutoScan {w} {
|
||||
variable ::tk::Priv
|
||||
|
||||
set x $Priv(x)
|
||||
if {$x >= [winfo width $w]} {
|
||||
$w xview scroll 2 units
|
||||
::tk::spinbox::MouseSelect $w $x ignore
|
||||
} elseif {$x < 0} {
|
||||
$w xview scroll -2 units
|
||||
::tk::spinbox::MouseSelect $w $x ignore
|
||||
}
|
||||
set Priv(afterId) [after 50 [list ::tk::spinbox::AutoScan $w]]
|
||||
}
|
||||
|
||||
# ::tk::spinbox::GetSelection --
|
||||
#
|
||||
# Returns the selected text of the spinbox. Differs from entry in that
|
||||
# a spinbox has no -show option to obscure contents.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The spinbox window from which the text to get
|
||||
|
||||
proc ::tk::spinbox::GetSelection {w} {
|
||||
return [string range [$w get] [$w index sel.first] \
|
||||
[expr {[$w index sel.last] - 1}]]
|
||||
}
|
||||
|
|
@ -0,0 +1,253 @@
|
|||
# Tcl autoload index file, version 2.0
|
||||
# This file is generated by the "auto_mkindex" command
|
||||
# and sourced to set up indexing information for one or
|
||||
# more commands. Typically each line is a command that
|
||||
# sets an element in the auto_index array, where the
|
||||
# element name is the name of a command and the value is
|
||||
# a script that loads the command.
|
||||
|
||||
set auto_index(::tk::dialog::error::Return) [list source [file join $dir bgerror.tcl]]
|
||||
set auto_index(::tk::dialog::error::Details) [list source [file join $dir bgerror.tcl]]
|
||||
set auto_index(::tk::dialog::error::SaveToLog) [list source [file join $dir bgerror.tcl]]
|
||||
set auto_index(::tk::dialog::error::Destroy) [list source [file join $dir bgerror.tcl]]
|
||||
set auto_index(::tk::dialog::error::bgerror) [list source [file join $dir bgerror.tcl]]
|
||||
set auto_index(bgerror) [list source [file join $dir bgerror.tcl]]
|
||||
set auto_index(::tk::ButtonInvoke) [list source [file join $dir button.tcl]]
|
||||
set auto_index(::tk::ButtonAutoInvoke) [list source [file join $dir button.tcl]]
|
||||
set auto_index(::tk::CheckRadioInvoke) [list source [file join $dir button.tcl]]
|
||||
set auto_index(::tk::dialog::file::chooseDir::) [list source [file join $dir choosedir.tcl]]
|
||||
set auto_index(::tk::dialog::file::chooseDir::Config) [list source [file join $dir choosedir.tcl]]
|
||||
set auto_index(::tk::dialog::file::chooseDir::OkCmd) [list source [file join $dir choosedir.tcl]]
|
||||
set auto_index(::tk::dialog::file::chooseDir::DblClick) [list source [file join $dir choosedir.tcl]]
|
||||
set auto_index(::tk::dialog::file::chooseDir::ListBrowse) [list source [file join $dir choosedir.tcl]]
|
||||
set auto_index(::tk::dialog::file::chooseDir::Done) [list source [file join $dir choosedir.tcl]]
|
||||
set auto_index(::tk::dialog::color::) [list source [file join $dir clrpick.tcl]]
|
||||
set auto_index(::tk::dialog::color::InitValues) [list source [file join $dir clrpick.tcl]]
|
||||
set auto_index(::tk::dialog::color::Config) [list source [file join $dir clrpick.tcl]]
|
||||
set auto_index(::tk::dialog::color::BuildDialog) [list source [file join $dir clrpick.tcl]]
|
||||
set auto_index(::tk::dialog::color::SetRGBValue) [list source [file join $dir clrpick.tcl]]
|
||||
set auto_index(::tk::dialog::color::XToRgb) [list source [file join $dir clrpick.tcl]]
|
||||
set auto_index(::tk::dialog::color::RgbToX) [list source [file join $dir clrpick.tcl]]
|
||||
set auto_index(::tk::dialog::color::DrawColorScale) [list source [file join $dir clrpick.tcl]]
|
||||
set auto_index(::tk::dialog::color::CreateSelector) [list source [file join $dir clrpick.tcl]]
|
||||
set auto_index(::tk::dialog::color::RedrawFinalColor) [list source [file join $dir clrpick.tcl]]
|
||||
set auto_index(::tk::dialog::color::RedrawColorBars) [list source [file join $dir clrpick.tcl]]
|
||||
set auto_index(::tk::dialog::color::StartMove) [list source [file join $dir clrpick.tcl]]
|
||||
set auto_index(::tk::dialog::color::MoveSelector) [list source [file join $dir clrpick.tcl]]
|
||||
set auto_index(::tk::dialog::color::ReleaseMouse) [list source [file join $dir clrpick.tcl]]
|
||||
set auto_index(::tk::dialog::color::ResizeColorBars) [list source [file join $dir clrpick.tcl]]
|
||||
set auto_index(::tk::dialog::color::HandleSelEntry) [list source [file join $dir clrpick.tcl]]
|
||||
set auto_index(::tk::dialog::color::HandleRGBEntry) [list source [file join $dir clrpick.tcl]]
|
||||
set auto_index(::tk::dialog::color::EnterColorBar) [list source [file join $dir clrpick.tcl]]
|
||||
set auto_index(::tk::dialog::color::LeaveColorBar) [list source [file join $dir clrpick.tcl]]
|
||||
set auto_index(::tk::dialog::color::OkCmd) [list source [file join $dir clrpick.tcl]]
|
||||
set auto_index(::tk::dialog::color::CancelCmd) [list source [file join $dir clrpick.tcl]]
|
||||
set auto_index(tclParseConfigSpec) [list source [file join $dir comdlg.tcl]]
|
||||
set auto_index(tclListValidFlags) [list source [file join $dir comdlg.tcl]]
|
||||
set auto_index(::tk::FocusGroup_Create) [list source [file join $dir comdlg.tcl]]
|
||||
set auto_index(::tk::FocusGroup_BindIn) [list source [file join $dir comdlg.tcl]]
|
||||
set auto_index(::tk::FocusGroup_BindOut) [list source [file join $dir comdlg.tcl]]
|
||||
set auto_index(::tk::FocusGroup_Destroy) [list source [file join $dir comdlg.tcl]]
|
||||
set auto_index(::tk::FocusGroup_In) [list source [file join $dir comdlg.tcl]]
|
||||
set auto_index(::tk::FocusGroup_Out) [list source [file join $dir comdlg.tcl]]
|
||||
set auto_index(::tk::FDGetFileTypes) [list source [file join $dir comdlg.tcl]]
|
||||
set auto_index(::tk::ConsoleInit) [list source [file join $dir console.tcl]]
|
||||
set auto_index(::tk::ConsoleSource) [list source [file join $dir console.tcl]]
|
||||
set auto_index(::tk::ConsoleInvoke) [list source [file join $dir console.tcl]]
|
||||
set auto_index(::tk::ConsoleHistory) [list source [file join $dir console.tcl]]
|
||||
set auto_index(::tk::ConsolePrompt) [list source [file join $dir console.tcl]]
|
||||
set auto_index(::tk::ConsoleBind) [list source [file join $dir console.tcl]]
|
||||
set auto_index(::tk::ConsoleInsert) [list source [file join $dir console.tcl]]
|
||||
set auto_index(::tk::ConsoleOutput) [list source [file join $dir console.tcl]]
|
||||
set auto_index(::tk::ConsoleExit) [list source [file join $dir console.tcl]]
|
||||
set auto_index(::tk::ConsoleAbout) [list source [file join $dir console.tcl]]
|
||||
set auto_index(tk_dialog) [list source [file join $dir dialog.tcl]]
|
||||
set auto_index(::tk::EntryClosestGap) [list source [file join $dir entry.tcl]]
|
||||
set auto_index(::tk::EntryButton1) [list source [file join $dir entry.tcl]]
|
||||
set auto_index(::tk::EntryMouseSelect) [list source [file join $dir entry.tcl]]
|
||||
set auto_index(::tk::EntryPaste) [list source [file join $dir entry.tcl]]
|
||||
set auto_index(::tk::EntryAutoScan) [list source [file join $dir entry.tcl]]
|
||||
set auto_index(::tk::EntryKeySelect) [list source [file join $dir entry.tcl]]
|
||||
set auto_index(::tk::EntryInsert) [list source [file join $dir entry.tcl]]
|
||||
set auto_index(::tk::EntryBackspace) [list source [file join $dir entry.tcl]]
|
||||
set auto_index(::tk::EntrySeeInsert) [list source [file join $dir entry.tcl]]
|
||||
set auto_index(::tk::EntrySetCursor) [list source [file join $dir entry.tcl]]
|
||||
set auto_index(::tk::EntryTranspose) [list source [file join $dir entry.tcl]]
|
||||
set auto_index(::tk::EntryPreviousWord) [list source [file join $dir entry.tcl]]
|
||||
set auto_index(::tk::EntryGetSelection) [list source [file join $dir entry.tcl]]
|
||||
set auto_index(tk_focusNext) [list source [file join $dir focus.tcl]]
|
||||
set auto_index(tk_focusPrev) [list source [file join $dir focus.tcl]]
|
||||
set auto_index(::tk::FocusOK) [list source [file join $dir focus.tcl]]
|
||||
set auto_index(tk_focusFollowsMouse) [list source [file join $dir focus.tcl]]
|
||||
set auto_index(::tk::IconList) [list source [file join $dir iconlist.tcl]]
|
||||
set auto_index(::tk::ListboxBeginSelect) [list source [file join $dir listbox.tcl]]
|
||||
set auto_index(::tk::ListboxMotion) [list source [file join $dir listbox.tcl]]
|
||||
set auto_index(::tk::ListboxBeginExtend) [list source [file join $dir listbox.tcl]]
|
||||
set auto_index(::tk::ListboxBeginToggle) [list source [file join $dir listbox.tcl]]
|
||||
set auto_index(::tk::ListboxAutoScan) [list source [file join $dir listbox.tcl]]
|
||||
set auto_index(::tk::ListboxUpDown) [list source [file join $dir listbox.tcl]]
|
||||
set auto_index(::tk::ListboxExtendUpDown) [list source [file join $dir listbox.tcl]]
|
||||
set auto_index(::tk::ListboxDataExtend) [list source [file join $dir listbox.tcl]]
|
||||
set auto_index(::tk::ListboxCancel) [list source [file join $dir listbox.tcl]]
|
||||
set auto_index(::tk::ListboxSelectAll) [list source [file join $dir listbox.tcl]]
|
||||
set auto_index(::tk::Megawidget) [list source [file join $dir megawidget.tcl]]
|
||||
set auto_index(::tk::MbEnter) [list source [file join $dir menu.tcl]]
|
||||
set auto_index(::tk::MbLeave) [list source [file join $dir menu.tcl]]
|
||||
set auto_index(::tk::MbPost) [list source [file join $dir menu.tcl]]
|
||||
set auto_index(::tk::MenuUnpost) [list source [file join $dir menu.tcl]]
|
||||
set auto_index(::tk::MbMotion) [list source [file join $dir menu.tcl]]
|
||||
set auto_index(::tk::MbButtonUp) [list source [file join $dir menu.tcl]]
|
||||
set auto_index(::tk::MenuMotion) [list source [file join $dir menu.tcl]]
|
||||
set auto_index(::tk::MenuButtonDown) [list source [file join $dir menu.tcl]]
|
||||
set auto_index(::tk::MenuLeave) [list source [file join $dir menu.tcl]]
|
||||
set auto_index(::tk::MenuInvoke) [list source [file join $dir menu.tcl]]
|
||||
set auto_index(::tk::MenuEscape) [list source [file join $dir menu.tcl]]
|
||||
set auto_index(::tk::MenuUpArrow) [list source [file join $dir menu.tcl]]
|
||||
set auto_index(::tk::MenuDownArrow) [list source [file join $dir menu.tcl]]
|
||||
set auto_index(::tk::MenuLeftArrow) [list source [file join $dir menu.tcl]]
|
||||
set auto_index(::tk::MenuRightArrow) [list source [file join $dir menu.tcl]]
|
||||
set auto_index(::tk::MenuNextMenu) [list source [file join $dir menu.tcl]]
|
||||
set auto_index(::tk::MenuNextEntry) [list source [file join $dir menu.tcl]]
|
||||
set auto_index(::tk::MenuFind) [list source [file join $dir menu.tcl]]
|
||||
set auto_index(::tk::TraverseToMenu) [list source [file join $dir menu.tcl]]
|
||||
set auto_index(::tk::FirstMenu) [list source [file join $dir menu.tcl]]
|
||||
set auto_index(::tk::TraverseWithinMenu) [list source [file join $dir menu.tcl]]
|
||||
set auto_index(::tk::MenuFirstEntry) [list source [file join $dir menu.tcl]]
|
||||
set auto_index(::tk::MenuFindName) [list source [file join $dir menu.tcl]]
|
||||
set auto_index(::tk::PostOverPoint) [list source [file join $dir menu.tcl]]
|
||||
set auto_index(::tk::SaveGrabInfo) [list source [file join $dir menu.tcl]]
|
||||
set auto_index(::tk::RestoreOldGrab) [list source [file join $dir menu.tcl]]
|
||||
set auto_index(tk_menuSetFocus) [list source [file join $dir menu.tcl]]
|
||||
set auto_index(::tk::GenerateMenuSelect) [list source [file join $dir menu.tcl]]
|
||||
set auto_index(tk_popup) [list source [file join $dir menu.tcl]]
|
||||
set auto_index(::tk::ensure_psenc_is_loaded) [list source [file join $dir mkpsenc.tcl]]
|
||||
set auto_index(::tk::MessageBox) [list source [file join $dir msgbox.tcl]]
|
||||
set auto_index(tk_menuBar) [list source [file join $dir obsolete.tcl]]
|
||||
set auto_index(tk_bindForTraversal) [list source [file join $dir obsolete.tcl]]
|
||||
set auto_index(::tk::classic::restore) [list source [file join $dir obsolete.tcl]]
|
||||
set auto_index(tk_optionMenu) [list source [file join $dir optMenu.tcl]]
|
||||
set auto_index(tk_setPalette) [list source [file join $dir palette.tcl]]
|
||||
set auto_index(::tk::RecolorTree) [list source [file join $dir palette.tcl]]
|
||||
set auto_index(::tk::Darken) [list source [file join $dir palette.tcl]]
|
||||
set auto_index(tk_bisque) [list source [file join $dir palette.tcl]]
|
||||
set auto_index(::safe::tkInterpInit) [list source [file join $dir safetk.tcl]]
|
||||
set auto_index(::safe::loadTk) [list source [file join $dir safetk.tcl]]
|
||||
set auto_index(::safe::TkInit) [list source [file join $dir safetk.tcl]]
|
||||
set auto_index(::safe::allowTk) [list source [file join $dir safetk.tcl]]
|
||||
set auto_index(::safe::disallowTk) [list source [file join $dir safetk.tcl]]
|
||||
set auto_index(::safe::tkDelete) [list source [file join $dir safetk.tcl]]
|
||||
set auto_index(::safe::tkTopLevel) [list source [file join $dir safetk.tcl]]
|
||||
set auto_index(::tk::ScaleActivate) [list source [file join $dir scale.tcl]]
|
||||
set auto_index(::tk::ScaleButtonDown) [list source [file join $dir scale.tcl]]
|
||||
set auto_index(::tk::ScaleDrag) [list source [file join $dir scale.tcl]]
|
||||
set auto_index(::tk::ScaleEndDrag) [list source [file join $dir scale.tcl]]
|
||||
set auto_index(::tk::ScaleIncrement) [list source [file join $dir scale.tcl]]
|
||||
set auto_index(::tk::ScaleControlPress) [list source [file join $dir scale.tcl]]
|
||||
set auto_index(::tk::ScaleButton2Down) [list source [file join $dir scale.tcl]]
|
||||
set auto_index(::tk::ScrollButtonDown) [list source [file join $dir scrlbar.tcl]]
|
||||
set auto_index(::tk::ScrollButtonUp) [list source [file join $dir scrlbar.tcl]]
|
||||
set auto_index(::tk::ScrollSelect) [list source [file join $dir scrlbar.tcl]]
|
||||
set auto_index(::tk::ScrollStartDrag) [list source [file join $dir scrlbar.tcl]]
|
||||
set auto_index(::tk::ScrollDrag) [list source [file join $dir scrlbar.tcl]]
|
||||
set auto_index(::tk::ScrollEndDrag) [list source [file join $dir scrlbar.tcl]]
|
||||
set auto_index(::tk::ScrollByUnits) [list source [file join $dir scrlbar.tcl]]
|
||||
set auto_index(::tk::ScrollByPages) [list source [file join $dir scrlbar.tcl]]
|
||||
set auto_index(::tk::ScrollToPos) [list source [file join $dir scrlbar.tcl]]
|
||||
set auto_index(::tk::ScrollTopBottom) [list source [file join $dir scrlbar.tcl]]
|
||||
set auto_index(::tk::ScrollButton2Down) [list source [file join $dir scrlbar.tcl]]
|
||||
set auto_index(::tk::spinbox::Invoke) [list source [file join $dir spinbox.tcl]]
|
||||
set auto_index(::tk::spinbox::ClosestGap) [list source [file join $dir spinbox.tcl]]
|
||||
set auto_index(::tk::spinbox::ButtonDown) [list source [file join $dir spinbox.tcl]]
|
||||
set auto_index(::tk::spinbox::ButtonUp) [list source [file join $dir spinbox.tcl]]
|
||||
set auto_index(::tk::spinbox::MouseSelect) [list source [file join $dir spinbox.tcl]]
|
||||
set auto_index(::tk::spinbox::Paste) [list source [file join $dir spinbox.tcl]]
|
||||
set auto_index(::tk::spinbox::Motion) [list source [file join $dir spinbox.tcl]]
|
||||
set auto_index(::tk::spinbox::AutoScan) [list source [file join $dir spinbox.tcl]]
|
||||
set auto_index(::tk::spinbox::KeySelect) [list source [file join $dir spinbox.tcl]]
|
||||
set auto_index(::tk::spinbox::Insert) [list source [file join $dir spinbox.tcl]]
|
||||
set auto_index(::tk::spinbox::Backspace) [list source [file join $dir spinbox.tcl]]
|
||||
set auto_index(::tk::spinbox::SeeInsert) [list source [file join $dir spinbox.tcl]]
|
||||
set auto_index(::tk::spinbox::SetCursor) [list source [file join $dir spinbox.tcl]]
|
||||
set auto_index(::tk::spinbox::Transpose) [list source [file join $dir spinbox.tcl]]
|
||||
set auto_index(::tk::spinbox::PreviousWord) [list source [file join $dir spinbox.tcl]]
|
||||
set auto_index(::tk::spinbox::GetSelection) [list source [file join $dir spinbox.tcl]]
|
||||
set auto_index(::tk::TearOffMenu) [list source [file join $dir tearoff.tcl]]
|
||||
set auto_index(::tk::MenuDup) [list source [file join $dir tearoff.tcl]]
|
||||
set auto_index(::tk::TextClosestGap) [list source [file join $dir text.tcl]]
|
||||
set auto_index(::tk::TextButton1) [list source [file join $dir text.tcl]]
|
||||
set auto_index(::tk::TextSelectTo) [list source [file join $dir text.tcl]]
|
||||
set auto_index(::tk::TextKeyExtend) [list source [file join $dir text.tcl]]
|
||||
set auto_index(::tk::TextPaste) [list source [file join $dir text.tcl]]
|
||||
set auto_index(::tk::TextAutoScan) [list source [file join $dir text.tcl]]
|
||||
set auto_index(::tk::TextSetCursor) [list source [file join $dir text.tcl]]
|
||||
set auto_index(::tk::TextKeySelect) [list source [file join $dir text.tcl]]
|
||||
set auto_index(::tk::TextResetAnchor) [list source [file join $dir text.tcl]]
|
||||
set auto_index(::tk::TextInsert) [list source [file join $dir text.tcl]]
|
||||
set auto_index(::tk::TextUpDownLine) [list source [file join $dir text.tcl]]
|
||||
set auto_index(::tk::TextPrevPara) [list source [file join $dir text.tcl]]
|
||||
set auto_index(::tk::TextNextPara) [list source [file join $dir text.tcl]]
|
||||
set auto_index(::tk::TextScrollPages) [list source [file join $dir text.tcl]]
|
||||
set auto_index(::tk::TextTranspose) [list source [file join $dir text.tcl]]
|
||||
set auto_index(tk_textCopy) [list source [file join $dir text.tcl]]
|
||||
set auto_index(tk_textCut) [list source [file join $dir text.tcl]]
|
||||
set auto_index(tk_textPaste) [list source [file join $dir text.tcl]]
|
||||
set auto_index(::tk::TextNextPos) [list source [file join $dir text.tcl]]
|
||||
set auto_index(::tk::TextPrevPos) [list source [file join $dir text.tcl]]
|
||||
set auto_index(::tk::PlaceWindow) [list source [file join $dir tk.tcl]]
|
||||
set auto_index(::tk::SetFocusGrab) [list source [file join $dir tk.tcl]]
|
||||
set auto_index(::tk::RestoreFocusGrab) [list source [file join $dir tk.tcl]]
|
||||
set auto_index(::tk::ScreenChanged) [list source [file join $dir tk.tcl]]
|
||||
set auto_index(::tk::EventMotifBindings) [list source [file join $dir tk.tcl]]
|
||||
set auto_index(::tk::CancelRepeat) [list source [file join $dir tk.tcl]]
|
||||
set auto_index(::tk::TabToWindow) [list source [file join $dir tk.tcl]]
|
||||
set auto_index(::tk::dialog::file::) [list source [file join $dir tkfbox.tcl]]
|
||||
set auto_index(::tk::dialog::file::Config) [list source [file join $dir tkfbox.tcl]]
|
||||
set auto_index(::tk::dialog::file::Create) [list source [file join $dir tkfbox.tcl]]
|
||||
set auto_index(::tk::dialog::file::SetSelectMode) [list source [file join $dir tkfbox.tcl]]
|
||||
set auto_index(::tk::dialog::file::UpdateWhenIdle) [list source [file join $dir tkfbox.tcl]]
|
||||
set auto_index(::tk::dialog::file::Update) [list source [file join $dir tkfbox.tcl]]
|
||||
set auto_index(::tk::dialog::file::SetPathSilently) [list source [file join $dir tkfbox.tcl]]
|
||||
set auto_index(::tk::dialog::file::SetPath) [list source [file join $dir tkfbox.tcl]]
|
||||
set auto_index(::tk::dialog::file::SetFilter) [list source [file join $dir tkfbox.tcl]]
|
||||
set auto_index(::tk::dialog::file::ResolveFile) [list source [file join $dir tkfbox.tcl]]
|
||||
set auto_index(::tk::dialog::file::EntFocusIn) [list source [file join $dir tkfbox.tcl]]
|
||||
set auto_index(::tk::dialog::file::EntFocusOut) [list source [file join $dir tkfbox.tcl]]
|
||||
set auto_index(::tk::dialog::file::ActivateEnt) [list source [file join $dir tkfbox.tcl]]
|
||||
set auto_index(::tk::dialog::file::VerifyFileName) [list source [file join $dir tkfbox.tcl]]
|
||||
set auto_index(::tk::dialog::file::InvokeBtn) [list source [file join $dir tkfbox.tcl]]
|
||||
set auto_index(::tk::dialog::file::UpDirCmd) [list source [file join $dir tkfbox.tcl]]
|
||||
set auto_index(::tk::dialog::file::JoinFile) [list source [file join $dir tkfbox.tcl]]
|
||||
set auto_index(::tk::dialog::file::OkCmd) [list source [file join $dir tkfbox.tcl]]
|
||||
set auto_index(::tk::dialog::file::CancelCmd) [list source [file join $dir tkfbox.tcl]]
|
||||
set auto_index(::tk::dialog::file::ListBrowse) [list source [file join $dir tkfbox.tcl]]
|
||||
set auto_index(::tk::dialog::file::ListInvoke) [list source [file join $dir tkfbox.tcl]]
|
||||
set auto_index(::tk::dialog::file::Done) [list source [file join $dir tkfbox.tcl]]
|
||||
set auto_index(::tk::MotifFDialog) [list source [file join $dir xmfbox.tcl]]
|
||||
set auto_index(::tk::MotifFDialog_Create) [list source [file join $dir xmfbox.tcl]]
|
||||
set auto_index(::tk::MotifFDialog_FileTypes) [list source [file join $dir xmfbox.tcl]]
|
||||
set auto_index(::tk::MotifFDialog_SetFilter) [list source [file join $dir xmfbox.tcl]]
|
||||
set auto_index(::tk::MotifFDialog_Config) [list source [file join $dir xmfbox.tcl]]
|
||||
set auto_index(::tk::MotifFDialog_BuildUI) [list source [file join $dir xmfbox.tcl]]
|
||||
set auto_index(::tk::MotifFDialog_SetListMode) [list source [file join $dir xmfbox.tcl]]
|
||||
set auto_index(::tk::MotifFDialog_MakeSList) [list source [file join $dir xmfbox.tcl]]
|
||||
set auto_index(::tk::MotifFDialog_InterpFilter) [list source [file join $dir xmfbox.tcl]]
|
||||
set auto_index(::tk::MotifFDialog_Update) [list source [file join $dir xmfbox.tcl]]
|
||||
set auto_index(::tk::MotifFDialog_LoadFiles) [list source [file join $dir xmfbox.tcl]]
|
||||
set auto_index(::tk::MotifFDialog_BrowseDList) [list source [file join $dir xmfbox.tcl]]
|
||||
set auto_index(::tk::MotifFDialog_ActivateDList) [list source [file join $dir xmfbox.tcl]]
|
||||
set auto_index(::tk::MotifFDialog_BrowseFList) [list source [file join $dir xmfbox.tcl]]
|
||||
set auto_index(::tk::MotifFDialog_ActivateFList) [list source [file join $dir xmfbox.tcl]]
|
||||
set auto_index(::tk::MotifFDialog_ActivateFEnt) [list source [file join $dir xmfbox.tcl]]
|
||||
set auto_index(::tk::MotifFDialog_ActivateSEnt) [list source [file join $dir xmfbox.tcl]]
|
||||
set auto_index(::tk::MotifFDialog_OkCmd) [list source [file join $dir xmfbox.tcl]]
|
||||
set auto_index(::tk::MotifFDialog_FilterCmd) [list source [file join $dir xmfbox.tcl]]
|
||||
set auto_index(::tk::MotifFDialog_CancelCmd) [list source [file join $dir xmfbox.tcl]]
|
||||
set auto_index(::tk::ListBoxKeyAccel_Set) [list source [file join $dir xmfbox.tcl]]
|
||||
set auto_index(::tk::ListBoxKeyAccel_Unset) [list source [file join $dir xmfbox.tcl]]
|
||||
set auto_index(::tk::ListBoxKeyAccel_Key) [list source [file join $dir xmfbox.tcl]]
|
||||
set auto_index(::tk::ListBoxKeyAccel_Goto) [list source [file join $dir xmfbox.tcl]]
|
||||
set auto_index(::tk::ListBoxKeyAccel_Reset) [list source [file join $dir xmfbox.tcl]]
|
||||
set auto_index(tk_getFileType) [list source [file join $dir xmfbox.tcl]]
|
||||
set auto_index(::tk::unsupported::ExposePrivateCommand) [list source [file join $dir unsupported.tcl]]
|
||||
set auto_index(::tk::unsupported::ExposePrivateVariable) [list source [file join $dir unsupported.tcl]]
|
||||
set auto_index(::tk::fontchooser) [list source [file join $dir fontchooser.tcl]]
|
||||
|
|
@ -0,0 +1,184 @@
|
|||
# tearoff.tcl --
|
||||
#
|
||||
# This file contains procedures that implement tear-off menus.
|
||||
#
|
||||
# Copyright (c) 1994 The Regents of the University of California.
|
||||
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
|
||||
# ::tk::TearoffMenu --
|
||||
# Given the name of a menu, this procedure creates a torn-off menu
|
||||
# that is identical to the given menu (including nested submenus).
|
||||
# The new torn-off menu exists as a toplevel window managed by the
|
||||
# window manager. The return value is the name of the new menu.
|
||||
# The window is created at the point specified by x and y
|
||||
#
|
||||
# Arguments:
|
||||
# w - The menu to be torn-off (duplicated).
|
||||
# x - x coordinate where window is created
|
||||
# y - y coordinate where window is created
|
||||
|
||||
proc ::tk::TearOffMenu {w {x 0} {y 0}} {
|
||||
# Find a unique name to use for the torn-off menu. Find the first
|
||||
# ancestor of w that is a toplevel but not a menu, and use this as
|
||||
# the parent of the new menu. This guarantees that the torn off
|
||||
# menu will be on the same screen as the original menu. By making
|
||||
# it a child of the ancestor, rather than a child of the menu, it
|
||||
# can continue to live even if the menu is deleted; it will go
|
||||
# away when the toplevel goes away.
|
||||
|
||||
if {$x == 0} {
|
||||
set x [winfo rootx $w]
|
||||
}
|
||||
if {$y == 0} {
|
||||
set y [winfo rooty $w]
|
||||
if {[tk windowingsystem] eq "aqua"} {
|
||||
# Shift by height of tearoff entry minus height of window titlebar
|
||||
catch {incr y [expr {[$w yposition 1] - 16}]}
|
||||
# Avoid the native menu bar which sits on top of everything.
|
||||
if {$y < 22} {set y 22}
|
||||
}
|
||||
}
|
||||
|
||||
set parent [winfo parent $w]
|
||||
while {[winfo toplevel $parent] ne $parent \
|
||||
|| [winfo class $parent] eq "Menu"} {
|
||||
set parent [winfo parent $parent]
|
||||
}
|
||||
if {$parent eq "."} {
|
||||
set parent ""
|
||||
}
|
||||
for {set i 1} 1 {incr i} {
|
||||
set menu $parent.tearoff$i
|
||||
if {![winfo exists $menu]} {
|
||||
break
|
||||
}
|
||||
}
|
||||
|
||||
$w clone $menu tearoff
|
||||
|
||||
# Pick a title for the new menu by looking at the parent of the
|
||||
# original: if the parent is a menu, then use the text of the active
|
||||
# entry. If it's a menubutton then use its text.
|
||||
|
||||
set parent [winfo parent $w]
|
||||
if {[$menu cget -title] ne ""} {
|
||||
wm title $menu [$menu cget -title]
|
||||
} else {
|
||||
switch -- [winfo class $parent] {
|
||||
Menubutton {
|
||||
wm title $menu [$parent cget -text]
|
||||
}
|
||||
Menu {
|
||||
wm title $menu [$parent entrycget active -label]
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if {[tk windowingsystem] eq "win32"} {
|
||||
# [Bug 3181181]: Find the toplevel window for the menu
|
||||
set parent [winfo toplevel $parent]
|
||||
while {[winfo class $parent] eq "Menu"} {
|
||||
set parent [winfo toplevel [winfo parent $parent]]
|
||||
}
|
||||
wm transient $menu [winfo toplevel $parent]
|
||||
wm attributes $menu -toolwindow 1
|
||||
}
|
||||
|
||||
$menu post $x $y
|
||||
|
||||
if {[winfo exists $menu] == 0} {
|
||||
return ""
|
||||
}
|
||||
|
||||
# Set tk::Priv(focus) on entry: otherwise the focus will get lost
|
||||
# after keyboard invocation of a sub-menu (it will stay on the
|
||||
# submenu).
|
||||
|
||||
bind $menu <Enter> {
|
||||
set tk::Priv(focus) %W
|
||||
}
|
||||
|
||||
# If there is a -tearoffcommand option for the menu, invoke it
|
||||
# now.
|
||||
|
||||
set cmd [$w cget -tearoffcommand]
|
||||
if {$cmd ne ""} {
|
||||
uplevel #0 $cmd [list $w $menu]
|
||||
}
|
||||
return $menu
|
||||
}
|
||||
|
||||
# ::tk::MenuDup --
|
||||
# Given a menu (hierarchy), create a duplicate menu (hierarchy)
|
||||
# in a given window.
|
||||
#
|
||||
# Arguments:
|
||||
# src - Source window. Must be a menu. It and its
|
||||
# menu descendants will be duplicated at dst.
|
||||
# dst - Name to use for topmost menu in duplicate
|
||||
# hierarchy.
|
||||
|
||||
proc ::tk::MenuDup {src dst type} {
|
||||
set cmd [list menu $dst -type $type]
|
||||
foreach option [$src configure] {
|
||||
if {[llength $option] == 2} {
|
||||
continue
|
||||
}
|
||||
if {[lindex $option 0] eq "-type"} {
|
||||
continue
|
||||
}
|
||||
lappend cmd [lindex $option 0] [lindex $option 4]
|
||||
}
|
||||
eval $cmd
|
||||
set last [$src index last]
|
||||
if {$last eq "none"} {
|
||||
return
|
||||
}
|
||||
for {set i [$src cget -tearoff]} {$i <= $last} {incr i} {
|
||||
set cmd [list $dst add [$src type $i]]
|
||||
foreach option [$src entryconfigure $i] {
|
||||
lappend cmd [lindex $option 0] [lindex $option 4]
|
||||
}
|
||||
eval $cmd
|
||||
}
|
||||
|
||||
# Duplicate the binding tags and bindings from the source menu.
|
||||
|
||||
set tags [bindtags $src]
|
||||
set srcLen [string length $src]
|
||||
|
||||
# Copy tags to x, replacing each substring of src with dst.
|
||||
|
||||
while {[set index [string first $src $tags]] >= 0} {
|
||||
if {$index > 0} {
|
||||
append x [string range $tags 0 $index-1]$dst
|
||||
}
|
||||
set tags [string range $tags $index+$srcLen end]
|
||||
}
|
||||
append x $tags
|
||||
|
||||
bindtags $dst $x
|
||||
|
||||
foreach event [bind $src] {
|
||||
unset x
|
||||
set script [bind $src $event]
|
||||
set eventLen [string length $event]
|
||||
|
||||
# Copy script to x, replacing each substring of event with dst.
|
||||
|
||||
while {[set index [string first $event $script]] >= 0} {
|
||||
if {$index > 0} {
|
||||
append x [string range $script 0 $index-1]
|
||||
}
|
||||
append x $dst
|
||||
set script [string range $script $index+$eventLen end]
|
||||
}
|
||||
append x $script
|
||||
|
||||
bind $dst $event $x
|
||||
}
|
||||
}
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,712 @@
|
|||
# tk.tcl --
|
||||
#
|
||||
# Initialization script normally executed in the interpreter for each Tk-based
|
||||
# application. Arranges class bindings for widgets.
|
||||
#
|
||||
# Copyright (c) 1992-1994 The Regents of the University of California.
|
||||
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-2000 Ajuba Solutions.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution of
|
||||
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
# Verify that we have Tk binary and script components from the same release
|
||||
package require -exact Tk 8.6.11
|
||||
|
||||
# Create a ::tk namespace
|
||||
namespace eval ::tk {
|
||||
# Set up the msgcat commands
|
||||
namespace eval msgcat {
|
||||
namespace export mc mcmax
|
||||
if {[interp issafe] || [catch {package require msgcat}]} {
|
||||
# The msgcat package is not available. Supply our own
|
||||
# minimal replacement.
|
||||
proc mc {src args} {
|
||||
return [format $src {*}$args]
|
||||
}
|
||||
proc mcmax {args} {
|
||||
set max 0
|
||||
foreach string $args {
|
||||
set len [string length $string]
|
||||
if {$len>$max} {
|
||||
set max $len
|
||||
}
|
||||
}
|
||||
return $max
|
||||
}
|
||||
} else {
|
||||
# Get the commands from the msgcat package that Tk uses.
|
||||
namespace import ::msgcat::mc
|
||||
namespace import ::msgcat::mcmax
|
||||
::msgcat::mcload [file join $::tk_library msgs]
|
||||
}
|
||||
}
|
||||
namespace import ::tk::msgcat::*
|
||||
}
|
||||
# and a ::ttk namespace
|
||||
namespace eval ::ttk {
|
||||
if {$::tk_library ne ""} {
|
||||
# avoid file join to work in safe interps, but this is also x-plat ok
|
||||
variable library $::tk_library/ttk
|
||||
}
|
||||
}
|
||||
|
||||
# Add Ttk & Tk's directory to the end of the auto-load search path, if it
|
||||
# isn't already on the path:
|
||||
|
||||
if {[info exists ::auto_path] && ($::tk_library ne "")
|
||||
&& ($::tk_library ni $::auto_path)
|
||||
} then {
|
||||
lappend ::auto_path $::tk_library $::ttk::library
|
||||
}
|
||||
|
||||
# Turn off strict Motif look and feel as a default.
|
||||
|
||||
set ::tk_strictMotif 0
|
||||
|
||||
# Turn on useinputmethods (X Input Methods) by default.
|
||||
# We catch this because safe interpreters may not allow the call.
|
||||
|
||||
catch {tk useinputmethods 1}
|
||||
|
||||
# ::tk::PlaceWindow --
|
||||
# place a toplevel at a particular position
|
||||
# Arguments:
|
||||
# toplevel name of toplevel window
|
||||
# ?placement? pointer ?center? ; places $w centered on the pointer
|
||||
# widget widgetPath ; centers $w over widget_name
|
||||
# defaults to placing toplevel in the middle of the screen
|
||||
# ?anchor? center or widgetPath
|
||||
# Results:
|
||||
# Returns nothing
|
||||
#
|
||||
proc ::tk::PlaceWindow {w {place ""} {anchor ""}} {
|
||||
wm withdraw $w
|
||||
update idletasks
|
||||
set checkBounds 1
|
||||
if {$place eq ""} {
|
||||
set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}]
|
||||
set y [expr {([winfo screenheight $w]-[winfo reqheight $w])/2}]
|
||||
set checkBounds 0
|
||||
} elseif {[string equal -length [string length $place] $place "pointer"]} {
|
||||
## place at POINTER (centered if $anchor == center)
|
||||
if {[string equal -length [string length $anchor] $anchor "center"]} {
|
||||
set x [expr {[winfo pointerx $w]-[winfo reqwidth $w]/2}]
|
||||
set y [expr {[winfo pointery $w]-[winfo reqheight $w]/2}]
|
||||
} else {
|
||||
set x [winfo pointerx $w]
|
||||
set y [winfo pointery $w]
|
||||
}
|
||||
} elseif {[string equal -length [string length $place] $place "widget"] && \
|
||||
[winfo exists $anchor] && [winfo ismapped $anchor]} {
|
||||
## center about WIDGET $anchor, widget must be mapped
|
||||
set x [expr {[winfo rootx $anchor] + \
|
||||
([winfo width $anchor]-[winfo reqwidth $w])/2}]
|
||||
set y [expr {[winfo rooty $anchor] + \
|
||||
([winfo height $anchor]-[winfo reqheight $w])/2}]
|
||||
} else {
|
||||
set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}]
|
||||
set y [expr {([winfo screenheight $w]-[winfo reqheight $w])/2}]
|
||||
set checkBounds 0
|
||||
}
|
||||
if {$checkBounds} {
|
||||
if {$x < [winfo vrootx $w]} {
|
||||
set x [winfo vrootx $w]
|
||||
} elseif {$x > ([winfo vrootx $w]+[winfo vrootwidth $w]-[winfo reqwidth $w])} {
|
||||
set x [expr {[winfo vrootx $w]+[winfo vrootwidth $w]-[winfo reqwidth $w]}]
|
||||
}
|
||||
if {$y < [winfo vrooty $w]} {
|
||||
set y [winfo vrooty $w]
|
||||
} elseif {$y > ([winfo vrooty $w]+[winfo vrootheight $w]-[winfo reqheight $w])} {
|
||||
set y [expr {[winfo vrooty $w]+[winfo vrootheight $w]-[winfo reqheight $w]}]
|
||||
}
|
||||
if {[tk windowingsystem] eq "aqua"} {
|
||||
# Avoid the native menu bar which sits on top of everything.
|
||||
if {$y < 22} {
|
||||
set y 22
|
||||
}
|
||||
}
|
||||
}
|
||||
wm maxsize $w [winfo vrootwidth $w] [winfo vrootheight $w]
|
||||
wm geometry $w +$x+$y
|
||||
wm deiconify $w
|
||||
}
|
||||
|
||||
# ::tk::SetFocusGrab --
|
||||
# swap out current focus and grab temporarily (for dialogs)
|
||||
# Arguments:
|
||||
# grab new window to grab
|
||||
# focus window to give focus to
|
||||
# Results:
|
||||
# Returns nothing
|
||||
#
|
||||
proc ::tk::SetFocusGrab {grab {focus {}}} {
|
||||
set index "$grab,$focus"
|
||||
upvar ::tk::FocusGrab($index) data
|
||||
|
||||
lappend data [focus]
|
||||
set oldGrab [grab current $grab]
|
||||
lappend data $oldGrab
|
||||
if {[winfo exists $oldGrab]} {
|
||||
lappend data [grab status $oldGrab]
|
||||
}
|
||||
# The "grab" command will fail if another application
|
||||
# already holds the grab. So catch it.
|
||||
catch {grab $grab}
|
||||
if {[winfo exists $focus]} {
|
||||
focus $focus
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::RestoreFocusGrab --
|
||||
# restore old focus and grab (for dialogs)
|
||||
# Arguments:
|
||||
# grab window that had taken grab
|
||||
# focus window that had taken focus
|
||||
# destroy destroy|withdraw - how to handle the old grabbed window
|
||||
# Results:
|
||||
# Returns nothing
|
||||
#
|
||||
proc ::tk::RestoreFocusGrab {grab focus {destroy destroy}} {
|
||||
set index "$grab,$focus"
|
||||
if {[info exists ::tk::FocusGrab($index)]} {
|
||||
foreach {oldFocus oldGrab oldStatus} $::tk::FocusGrab($index) { break }
|
||||
unset ::tk::FocusGrab($index)
|
||||
} else {
|
||||
set oldGrab ""
|
||||
}
|
||||
|
||||
catch {focus $oldFocus}
|
||||
grab release $grab
|
||||
if {$destroy eq "withdraw"} {
|
||||
wm withdraw $grab
|
||||
} else {
|
||||
destroy $grab
|
||||
}
|
||||
if {[winfo exists $oldGrab] && [winfo ismapped $oldGrab]} {
|
||||
if {$oldStatus eq "global"} {
|
||||
grab -global $oldGrab
|
||||
} else {
|
||||
grab $oldGrab
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::GetSelection --
|
||||
# This tries to obtain the default selection. On Unix, we first try
|
||||
# and get a UTF8_STRING, a type supported by modern Unix apps for
|
||||
# passing Unicode data safely. We fall back on the default STRING
|
||||
# type otherwise. On Windows, only the STRING type is necessary.
|
||||
# Arguments:
|
||||
# w The widget for which the selection will be retrieved.
|
||||
# Important for the -displayof property.
|
||||
# sel The source of the selection (PRIMARY or CLIPBOARD)
|
||||
# Results:
|
||||
# Returns the selection, or an error if none could be found
|
||||
#
|
||||
if {[tk windowingsystem] ne "win32"} {
|
||||
proc ::tk::GetSelection {w {sel PRIMARY}} {
|
||||
if {[catch {
|
||||
selection get -displayof $w -selection $sel -type UTF8_STRING
|
||||
} txt] && [catch {
|
||||
selection get -displayof $w -selection $sel
|
||||
} txt]} then {
|
||||
return -code error -errorcode {TK SELECTION NONE} \
|
||||
"could not find default selection"
|
||||
} else {
|
||||
return $txt
|
||||
}
|
||||
}
|
||||
} else {
|
||||
proc ::tk::GetSelection {w {sel PRIMARY}} {
|
||||
if {[catch {
|
||||
selection get -displayof $w -selection $sel
|
||||
} txt]} then {
|
||||
return -code error -errorcode {TK SELECTION NONE} \
|
||||
"could not find default selection"
|
||||
} else {
|
||||
return $txt
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::ScreenChanged --
|
||||
# This procedure is invoked by the binding mechanism whenever the
|
||||
# "current" screen is changing. The procedure does two things.
|
||||
# First, it uses "upvar" to make variable "::tk::Priv" point at an
|
||||
# array variable that holds state for the current display. Second,
|
||||
# it initializes the array if it didn't already exist.
|
||||
#
|
||||
# Arguments:
|
||||
# screen - The name of the new screen.
|
||||
|
||||
proc ::tk::ScreenChanged screen {
|
||||
# Extract the display name.
|
||||
set disp [string range $screen 0 [string last . $screen]-1]
|
||||
|
||||
# Ensure that namespace separators never occur in the display name (as
|
||||
# they cause problems in variable names). Double-colons exist in some VNC
|
||||
# display names. [Bug 2912473]
|
||||
set disp [string map {:: _doublecolon_} $disp]
|
||||
|
||||
uplevel #0 [list upvar #0 ::tk::Priv.$disp ::tk::Priv]
|
||||
variable ::tk::Priv
|
||||
|
||||
if {[info exists Priv]} {
|
||||
set Priv(screen) $screen
|
||||
return
|
||||
}
|
||||
array set Priv {
|
||||
activeMenu {}
|
||||
activeItem {}
|
||||
afterId {}
|
||||
buttons 0
|
||||
buttonWindow {}
|
||||
dragging 0
|
||||
focus {}
|
||||
grab {}
|
||||
initPos {}
|
||||
inMenubutton {}
|
||||
listboxPrev {}
|
||||
menuBar {}
|
||||
mouseMoved 0
|
||||
oldGrab {}
|
||||
popup {}
|
||||
postedMb {}
|
||||
pressX 0
|
||||
pressY 0
|
||||
prevPos 0
|
||||
selectMode char
|
||||
}
|
||||
set Priv(screen) $screen
|
||||
set Priv(tearoff) [string equal [tk windowingsystem] "x11"]
|
||||
set Priv(window) {}
|
||||
}
|
||||
|
||||
# Do initial setup for Priv, so that it is always bound to something
|
||||
# (otherwise, if someone references it, it may get set to a non-upvar-ed
|
||||
# value, which will cause trouble later).
|
||||
|
||||
tk::ScreenChanged [winfo screen .]
|
||||
|
||||
# ::tk::EventMotifBindings --
|
||||
# This procedure is invoked as a trace whenever ::tk_strictMotif is
|
||||
# changed. It is used to turn on or turn off the motif virtual
|
||||
# bindings.
|
||||
#
|
||||
# Arguments:
|
||||
# n1 - the name of the variable being changed ("::tk_strictMotif").
|
||||
|
||||
proc ::tk::EventMotifBindings {n1 dummy dummy} {
|
||||
upvar $n1 name
|
||||
|
||||
if {$name} {
|
||||
set op delete
|
||||
} else {
|
||||
set op add
|
||||
}
|
||||
|
||||
event $op <<Cut>> <Control-Key-w> <Control-Lock-Key-W> <Shift-Key-Delete>
|
||||
event $op <<Copy>> <Meta-Key-w> <Meta-Lock-Key-W> <Control-Key-Insert>
|
||||
event $op <<Paste>> <Control-Key-y> <Control-Lock-Key-Y> <Shift-Key-Insert>
|
||||
event $op <<PrevChar>> <Control-Key-b> <Control-Lock-Key-B>
|
||||
event $op <<NextChar>> <Control-Key-f> <Control-Lock-Key-F>
|
||||
event $op <<PrevLine>> <Control-Key-p> <Control-Lock-Key-P>
|
||||
event $op <<NextLine>> <Control-Key-n> <Control-Lock-Key-N>
|
||||
event $op <<LineStart>> <Control-Key-a> <Control-Lock-Key-A>
|
||||
event $op <<LineEnd>> <Control-Key-e> <Control-Lock-Key-E>
|
||||
event $op <<SelectPrevChar>> <Control-Key-B> <Control-Lock-Key-b>
|
||||
event $op <<SelectNextChar>> <Control-Key-F> <Control-Lock-Key-f>
|
||||
event $op <<SelectPrevLine>> <Control-Key-P> <Control-Lock-Key-p>
|
||||
event $op <<SelectNextLine>> <Control-Key-N> <Control-Lock-Key-n>
|
||||
event $op <<SelectLineStart>> <Control-Key-A> <Control-Lock-Key-a>
|
||||
event $op <<SelectLineEnd>> <Control-Key-E> <Control-Lock-Key-e>
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
# Define common dialogs on platforms where they are not implemented
|
||||
# using compiled code.
|
||||
#----------------------------------------------------------------------
|
||||
|
||||
if {![llength [info commands tk_chooseColor]]} {
|
||||
proc ::tk_chooseColor {args} {
|
||||
return [::tk::dialog::color:: {*}$args]
|
||||
}
|
||||
}
|
||||
if {![llength [info commands tk_getOpenFile]]} {
|
||||
proc ::tk_getOpenFile {args} {
|
||||
if {$::tk_strictMotif} {
|
||||
return [::tk::MotifFDialog open {*}$args]
|
||||
} else {
|
||||
return [::tk::dialog::file:: open {*}$args]
|
||||
}
|
||||
}
|
||||
}
|
||||
if {![llength [info commands tk_getSaveFile]]} {
|
||||
proc ::tk_getSaveFile {args} {
|
||||
if {$::tk_strictMotif} {
|
||||
return [::tk::MotifFDialog save {*}$args]
|
||||
} else {
|
||||
return [::tk::dialog::file:: save {*}$args]
|
||||
}
|
||||
}
|
||||
}
|
||||
if {![llength [info commands tk_messageBox]]} {
|
||||
proc ::tk_messageBox {args} {
|
||||
return [::tk::MessageBox {*}$args]
|
||||
}
|
||||
}
|
||||
if {![llength [info command tk_chooseDirectory]]} {
|
||||
proc ::tk_chooseDirectory {args} {
|
||||
return [::tk::dialog::file::chooseDir:: {*}$args]
|
||||
}
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
# Define the set of common virtual events.
|
||||
#----------------------------------------------------------------------
|
||||
|
||||
switch -exact -- [tk windowingsystem] {
|
||||
"x11" {
|
||||
event add <<Cut>> <Control-Key-x> <Key-F20> <Control-Lock-Key-X>
|
||||
event add <<Copy>> <Control-Key-c> <Key-F16> <Control-Lock-Key-C>
|
||||
event add <<Paste>> <Control-Key-v> <Key-F18> <Control-Lock-Key-V>
|
||||
event add <<PasteSelection>> <ButtonRelease-2>
|
||||
event add <<Undo>> <Control-Key-z> <Control-Lock-Key-Z>
|
||||
event add <<Redo>> <Control-Key-Z> <Control-Lock-Key-z>
|
||||
event add <<ContextMenu>> <Button-3>
|
||||
# On Darwin/Aqua, buttons from left to right are 1,3,2. On Darwin/X11 with recent
|
||||
# XQuartz as the X server, they are 1,2,3; other X servers may differ.
|
||||
|
||||
event add <<SelectAll>> <Control-Key-slash>
|
||||
event add <<SelectNone>> <Control-Key-backslash>
|
||||
event add <<NextChar>> <Right>
|
||||
event add <<SelectNextChar>> <Shift-Right>
|
||||
event add <<PrevChar>> <Left>
|
||||
event add <<SelectPrevChar>> <Shift-Left>
|
||||
event add <<NextWord>> <Control-Right>
|
||||
event add <<SelectNextWord>> <Control-Shift-Right>
|
||||
event add <<PrevWord>> <Control-Left>
|
||||
event add <<SelectPrevWord>> <Control-Shift-Left>
|
||||
event add <<LineStart>> <Home>
|
||||
event add <<SelectLineStart>> <Shift-Home>
|
||||
event add <<LineEnd>> <End>
|
||||
event add <<SelectLineEnd>> <Shift-End>
|
||||
event add <<PrevLine>> <Up>
|
||||
event add <<NextLine>> <Down>
|
||||
event add <<SelectPrevLine>> <Shift-Up>
|
||||
event add <<SelectNextLine>> <Shift-Down>
|
||||
event add <<PrevPara>> <Control-Up>
|
||||
event add <<NextPara>> <Control-Down>
|
||||
event add <<SelectPrevPara>> <Control-Shift-Up>
|
||||
event add <<SelectNextPara>> <Control-Shift-Down>
|
||||
event add <<ToggleSelection>> <Control-Button-1>
|
||||
|
||||
# Some OS's define a goofy (as in, not <Shift-Tab>) keysym that is
|
||||
# returned when the user presses <Shift-Tab>. In order for tab
|
||||
# traversal to work, we have to add these keysyms to the PrevWindow
|
||||
# event. We use catch just in case the keysym isn't recognized.
|
||||
|
||||
# This is needed for XFree86 systems
|
||||
catch { event add <<PrevWindow>> <ISO_Left_Tab> }
|
||||
# This seems to be correct on *some* HP systems.
|
||||
catch { event add <<PrevWindow>> <hpBackTab> }
|
||||
|
||||
trace add variable ::tk_strictMotif write ::tk::EventMotifBindings
|
||||
set ::tk_strictMotif $::tk_strictMotif
|
||||
# On unix, we want to always display entry/text selection,
|
||||
# regardless of which window has focus
|
||||
set ::tk::AlwaysShowSelection 1
|
||||
}
|
||||
"win32" {
|
||||
event add <<Cut>> <Control-Key-x> <Shift-Key-Delete> <Control-Lock-Key-X>
|
||||
event add <<Copy>> <Control-Key-c> <Control-Key-Insert> <Control-Lock-Key-C>
|
||||
event add <<Paste>> <Control-Key-v> <Shift-Key-Insert> <Control-Lock-Key-V>
|
||||
event add <<PasteSelection>> <ButtonRelease-2>
|
||||
event add <<Undo>> <Control-Key-z> <Control-Lock-Key-Z>
|
||||
event add <<Redo>> <Control-Key-y> <Control-Lock-Key-Y>
|
||||
event add <<ContextMenu>> <Button-3>
|
||||
|
||||
event add <<SelectAll>> <Control-Key-slash> <Control-Key-a> <Control-Lock-Key-A>
|
||||
event add <<SelectNone>> <Control-Key-backslash>
|
||||
event add <<NextChar>> <Right>
|
||||
event add <<SelectNextChar>> <Shift-Right>
|
||||
event add <<PrevChar>> <Left>
|
||||
event add <<SelectPrevChar>> <Shift-Left>
|
||||
event add <<NextWord>> <Control-Right>
|
||||
event add <<SelectNextWord>> <Control-Shift-Right>
|
||||
event add <<PrevWord>> <Control-Left>
|
||||
event add <<SelectPrevWord>> <Control-Shift-Left>
|
||||
event add <<LineStart>> <Home>
|
||||
event add <<SelectLineStart>> <Shift-Home>
|
||||
event add <<LineEnd>> <End>
|
||||
event add <<SelectLineEnd>> <Shift-End>
|
||||
event add <<PrevLine>> <Up>
|
||||
event add <<NextLine>> <Down>
|
||||
event add <<SelectPrevLine>> <Shift-Up>
|
||||
event add <<SelectNextLine>> <Shift-Down>
|
||||
event add <<PrevPara>> <Control-Up>
|
||||
event add <<NextPara>> <Control-Down>
|
||||
event add <<SelectPrevPara>> <Control-Shift-Up>
|
||||
event add <<SelectNextPara>> <Control-Shift-Down>
|
||||
event add <<ToggleSelection>> <Control-Button-1>
|
||||
}
|
||||
"aqua" {
|
||||
event add <<Cut>> <Command-Key-x> <Key-F2> <Command-Lock-Key-X>
|
||||
event add <<Copy>> <Command-Key-c> <Key-F3> <Command-Lock-Key-C>
|
||||
event add <<Paste>> <Command-Key-v> <Key-F4> <Command-Lock-Key-V>
|
||||
event add <<PasteSelection>> <ButtonRelease-3>
|
||||
event add <<Clear>> <Clear>
|
||||
event add <<ContextMenu>> <Button-2>
|
||||
|
||||
# Official bindings
|
||||
# See http://support.apple.com/kb/HT1343
|
||||
event add <<SelectAll>> <Command-Key-a>
|
||||
event add <<Undo>> <Command-Key-z> <Command-Lock-Key-Z>
|
||||
event add <<Redo>> <Shift-Command-Key-z> <Shift-Command-Lock-Key-z>
|
||||
event add <<NextChar>> <Right> <Control-Key-f> <Control-Lock-Key-F>
|
||||
event add <<SelectNextChar>> <Shift-Right> <Shift-Control-Key-F> <Shift-Control-Lock-Key-F>
|
||||
event add <<PrevChar>> <Left> <Control-Key-b> <Control-Lock-Key-B>
|
||||
event add <<SelectPrevChar>> <Shift-Left> <Shift-Control-Key-B> <Shift-Control-Lock-Key-B>
|
||||
event add <<NextWord>> <Option-Right>
|
||||
event add <<SelectNextWord>> <Shift-Option-Right>
|
||||
event add <<PrevWord>> <Option-Left>
|
||||
event add <<SelectPrevWord>> <Shift-Option-Left>
|
||||
event add <<LineStart>> <Home> <Command-Left> <Control-Key-a> <Control-Lock-Key-A>
|
||||
event add <<SelectLineStart>> <Shift-Home> <Shift-Command-Left> <Shift-Control-Key-A> <Shift-Control-Lock-Key-A>
|
||||
event add <<LineEnd>> <End> <Command-Right> <Control-Key-e> <Control-Lock-Key-E>
|
||||
event add <<SelectLineEnd>> <Shift-End> <Shift-Command-Right> <Shift-Control-Key-E> <Shift-Control-Lock-Key-E>
|
||||
event add <<PrevLine>> <Up> <Control-Key-p> <Control-Lock-Key-P>
|
||||
event add <<SelectPrevLine>> <Shift-Up> <Shift-Control-Key-P> <Shift-Control-Lock-Key-P>
|
||||
event add <<NextLine>> <Down> <Control-Key-n> <Control-Lock-Key-N>
|
||||
event add <<SelectNextLine>> <Shift-Down> <Shift-Control-Key-N> <Shift-Control-Lock-Key-N>
|
||||
# Not official, but logical extensions of above. Also derived from
|
||||
# bindings present in MS Word on OSX.
|
||||
event add <<PrevPara>> <Option-Up>
|
||||
event add <<NextPara>> <Option-Down>
|
||||
event add <<SelectPrevPara>> <Shift-Option-Up>
|
||||
event add <<SelectNextPara>> <Shift-Option-Down>
|
||||
event add <<ToggleSelection>> <Command-Button-1>
|
||||
}
|
||||
}
|
||||
|
||||
# ----------------------------------------------------------------------
|
||||
# Read in files that define all of the class bindings.
|
||||
# ----------------------------------------------------------------------
|
||||
|
||||
if {$::tk_library ne ""} {
|
||||
proc ::tk::SourceLibFile {file} {
|
||||
namespace eval :: [list source -encoding utf-8 [file join $::tk_library $file.tcl]]
|
||||
}
|
||||
namespace eval ::tk {
|
||||
SourceLibFile icons
|
||||
SourceLibFile button
|
||||
SourceLibFile entry
|
||||
SourceLibFile listbox
|
||||
SourceLibFile menu
|
||||
SourceLibFile panedwindow
|
||||
SourceLibFile scale
|
||||
SourceLibFile scrlbar
|
||||
SourceLibFile spinbox
|
||||
SourceLibFile text
|
||||
}
|
||||
}
|
||||
|
||||
# ----------------------------------------------------------------------
|
||||
# Default bindings for keyboard traversal.
|
||||
# ----------------------------------------------------------------------
|
||||
|
||||
event add <<PrevWindow>> <Shift-Tab>
|
||||
event add <<NextWindow>> <Tab>
|
||||
bind all <<NextWindow>> {tk::TabToWindow [tk_focusNext %W]}
|
||||
bind all <<PrevWindow>> {tk::TabToWindow [tk_focusPrev %W]}
|
||||
|
||||
# ::tk::CancelRepeat --
|
||||
# This procedure is invoked to cancel an auto-repeat action described
|
||||
# by ::tk::Priv(afterId). It's used by several widgets to auto-scroll
|
||||
# the widget when the mouse is dragged out of the widget with a
|
||||
# button pressed.
|
||||
#
|
||||
# Arguments:
|
||||
# None.
|
||||
|
||||
proc ::tk::CancelRepeat {} {
|
||||
variable ::tk::Priv
|
||||
after cancel $Priv(afterId)
|
||||
set Priv(afterId) {}
|
||||
}
|
||||
|
||||
# ::tk::TabToWindow --
|
||||
# This procedure moves the focus to the given widget.
|
||||
# It sends a <<TraverseOut>> virtual event to the previous focus window,
|
||||
# if any, before changing the focus, and a <<TraverseIn>> event
|
||||
# to the new focus window afterwards.
|
||||
#
|
||||
# Arguments:
|
||||
# w - Window to which focus should be set.
|
||||
|
||||
proc ::tk::TabToWindow {w} {
|
||||
set focus [focus]
|
||||
if {$focus ne ""} {
|
||||
event generate $focus <<TraverseOut>>
|
||||
}
|
||||
focus $w
|
||||
event generate $w <<TraverseIn>>
|
||||
}
|
||||
|
||||
# ::tk::UnderlineAmpersand --
|
||||
# This procedure takes some text with ampersand and returns text w/o
|
||||
# ampersand and position of the ampersand. Double ampersands are
|
||||
# converted to single ones. Position returned is -1 when there is no
|
||||
# ampersand.
|
||||
#
|
||||
proc ::tk::UnderlineAmpersand {text} {
|
||||
set s [string map {&& & & \ufeff} $text]
|
||||
set idx [string first \ufeff $s]
|
||||
return [list [string map {\ufeff {}} $s] $idx]
|
||||
}
|
||||
|
||||
# ::tk::SetAmpText --
|
||||
# Given widget path and text with "magic ampersands", sets -text and
|
||||
# -underline options for the widget
|
||||
#
|
||||
proc ::tk::SetAmpText {widget text} {
|
||||
lassign [UnderlineAmpersand $text] newtext under
|
||||
$widget configure -text $newtext -underline $under
|
||||
}
|
||||
|
||||
# ::tk::AmpWidget --
|
||||
# Creates new widget, turning -text option into -text and -underline
|
||||
# options, returned by ::tk::UnderlineAmpersand.
|
||||
#
|
||||
proc ::tk::AmpWidget {class path args} {
|
||||
set options {}
|
||||
foreach {opt val} $args {
|
||||
if {$opt eq "-text"} {
|
||||
lassign [UnderlineAmpersand $val] newtext under
|
||||
lappend options -text $newtext -underline $under
|
||||
} else {
|
||||
lappend options $opt $val
|
||||
}
|
||||
}
|
||||
set result [$class $path {*}$options]
|
||||
if {[string match "*button" $class]} {
|
||||
bind $path <<AltUnderlined>> [list $path invoke]
|
||||
}
|
||||
return $result
|
||||
}
|
||||
|
||||
# ::tk::AmpMenuArgs --
|
||||
# Processes arguments for a menu entry, turning -label option into
|
||||
# -label and -underline options, returned by ::tk::UnderlineAmpersand.
|
||||
# The cmd argument is supposed to be either "add" or "entryconfigure"
|
||||
#
|
||||
proc ::tk::AmpMenuArgs {widget cmd type args} {
|
||||
set options {}
|
||||
foreach {opt val} $args {
|
||||
if {$opt eq "-label"} {
|
||||
lassign [UnderlineAmpersand $val] newlabel under
|
||||
lappend options -label $newlabel -underline $under
|
||||
} else {
|
||||
lappend options $opt $val
|
||||
}
|
||||
}
|
||||
$widget $cmd $type {*}$options
|
||||
}
|
||||
|
||||
# ::tk::FindAltKeyTarget --
|
||||
# Search recursively through the hierarchy of visible widgets to find
|
||||
# button or label which has $char as underlined character.
|
||||
#
|
||||
proc ::tk::FindAltKeyTarget {path char} {
|
||||
set class [winfo class $path]
|
||||
if {$class in {
|
||||
Button Checkbutton Label Radiobutton
|
||||
TButton TCheckbutton TLabel TRadiobutton
|
||||
} && [string equal -nocase $char \
|
||||
[string index [$path cget -text] [$path cget -underline]]]} {
|
||||
return $path
|
||||
}
|
||||
set subwins [concat [grid slaves $path] [pack slaves $path] \
|
||||
[place slaves $path]]
|
||||
if {$class eq "Canvas"} {
|
||||
foreach item [$path find all] {
|
||||
if {[$path type $item] eq "window"} {
|
||||
set w [$path itemcget $item -window]
|
||||
if {$w ne ""} {lappend subwins $w}
|
||||
}
|
||||
}
|
||||
} elseif {$class eq "Text"} {
|
||||
lappend subwins {*}[$path window names]
|
||||
}
|
||||
foreach child $subwins {
|
||||
set target [FindAltKeyTarget $child $char]
|
||||
if {$target ne ""} {
|
||||
return $target
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::AltKeyInDialog --
|
||||
# <Alt-Key> event handler for standard dialogs. Sends <<AltUnderlined>>
|
||||
# to button or label which has appropriate underlined character.
|
||||
#
|
||||
proc ::tk::AltKeyInDialog {path key} {
|
||||
set target [FindAltKeyTarget $path $key]
|
||||
if {$target ne ""} {
|
||||
event generate $target <<AltUnderlined>>
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::mcmaxamp --
|
||||
# Replacement for mcmax, used for texts with "magic ampersand" in it.
|
||||
#
|
||||
|
||||
proc ::tk::mcmaxamp {args} {
|
||||
set maxlen 0
|
||||
foreach arg $args {
|
||||
# Should we run [mc] in caller's namespace?
|
||||
lassign [UnderlineAmpersand [mc $arg]] msg
|
||||
set length [string length $msg]
|
||||
if {$length > $maxlen} {
|
||||
set maxlen $length
|
||||
}
|
||||
}
|
||||
return $maxlen
|
||||
}
|
||||
|
||||
# For now, turn off the custom mdef proc for the Mac:
|
||||
|
||||
if {[tk windowingsystem] eq "aqua"} {
|
||||
namespace eval ::tk::mac {
|
||||
set useCustomMDEF 0
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
if {[tk windowingsystem] eq "aqua"} {
|
||||
#stub procedures to respond to "do script" Apple Events
|
||||
proc ::tk::mac::DoScriptFile {file} {
|
||||
uplevel #0 $file
|
||||
source -encoding utf-8 $file
|
||||
}
|
||||
proc ::tk::mac::DoScriptText {script} {
|
||||
uplevel #0 $script
|
||||
eval $script
|
||||
}
|
||||
}
|
||||
|
||||
# Create a dictionary to store the starting index of the IME marked
|
||||
# text in an Entry or Text widget.
|
||||
|
||||
set ::tk::Priv(IMETextMark) [dict create]
|
||||
|
||||
# Run the Ttk themed widget set initialization
|
||||
if {$::ttk::library ne ""} {
|
||||
uplevel \#0 [list source -encoding utf-8 $::ttk::library/ttk.tcl]
|
||||
}
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# fill-column: 78
|
||||
# End:
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,269 @@
|
|||
# unsupported.tcl --
|
||||
#
|
||||
# Commands provided by Tk without official support. Use them at your
|
||||
# own risk. They may change or go away without notice.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
# ----------------------------------------------------------------------
|
||||
# Unsupported compatibility interface for folks accessing Tk's private
|
||||
# commands and variable against recommended usage.
|
||||
# ----------------------------------------------------------------------
|
||||
|
||||
namespace eval ::tk::unsupported {
|
||||
|
||||
# Map from the old global names of Tk private commands to their
|
||||
# new namespace-encapsulated names.
|
||||
|
||||
variable PrivateCommands
|
||||
array set PrivateCommands {
|
||||
tkButtonAutoInvoke ::tk::ButtonAutoInvoke
|
||||
tkButtonDown ::tk::ButtonDown
|
||||
tkButtonEnter ::tk::ButtonEnter
|
||||
tkButtonInvoke ::tk::ButtonInvoke
|
||||
tkButtonLeave ::tk::ButtonLeave
|
||||
tkButtonUp ::tk::ButtonUp
|
||||
tkCancelRepeat ::tk::CancelRepeat
|
||||
tkCheckRadioDown ::tk::CheckRadioDown
|
||||
tkCheckRadioEnter ::tk::CheckRadioEnter
|
||||
tkCheckRadioInvoke ::tk::CheckRadioInvoke
|
||||
tkColorDialog ::tk::dialog::color::
|
||||
tkColorDialog_BuildDialog ::tk::dialog::color::BuildDialog
|
||||
tkColorDialog_CancelCmd ::tk::dialog::color::CancelCmd
|
||||
tkColorDialog_Config ::tk::dialog::color::Config
|
||||
tkColorDialog_CreateSelector ::tk::dialog::color::CreateSelector
|
||||
tkColorDialog_DrawColorScale ::tk::dialog::color::DrawColorScale
|
||||
tkColorDialog_EnterColorBar ::tk::dialog::color::EnterColorBar
|
||||
tkColorDialog_InitValues ::tk::dialog::color::InitValues
|
||||
tkColorDialog_HandleRGBEntry ::tk::dialog::color::HandleRGBEntry
|
||||
tkColorDialog_HandleSelEntry ::tk::dialog::color::HandleSelEntry
|
||||
tkColorDialog_LeaveColorBar ::tk::dialog::color::LeaveColorBar
|
||||
tkColorDialog_MoveSelector ::tk::dialog::color::MoveSelector
|
||||
tkColorDialog_OkCmd ::tk::dialog::color::OkCmd
|
||||
tkColorDialog_RedrawColorBars ::tk::dialog::color::RedrawColorBars
|
||||
tkColorDialog_RedrawFinalColor ::tk::dialog::color::RedrawFinalColor
|
||||
tkColorDialog_ReleaseMouse ::tk::dialog::color::ReleaseMouse
|
||||
tkColorDialog_ResizeColorBars ::tk::dialog::color::ResizeColorBars
|
||||
tkColorDialog_RgbToX ::tk::dialog::color::RgbToX
|
||||
tkColorDialog_SetRGBValue ::tk::dialog::color::SetRGBValue
|
||||
tkColorDialog_StartMove ::tk::dialog::color::StartMove
|
||||
tkColorDialog_XToRgb ::tk::dialog::color::XToRGB
|
||||
tkConsoleAbout ::tk::ConsoleAbout
|
||||
tkConsoleBind ::tk::ConsoleBind
|
||||
tkConsoleExit ::tk::ConsoleExit
|
||||
tkConsoleHistory ::tk::ConsoleHistory
|
||||
tkConsoleInit ::tk::ConsoleInit
|
||||
tkConsoleInsert ::tk::ConsoleInsert
|
||||
tkConsoleInvoke ::tk::ConsoleInvoke
|
||||
tkConsoleOutput ::tk::ConsoleOutput
|
||||
tkConsolePrompt ::tk::ConsolePrompt
|
||||
tkConsoleSource ::tk::ConsoleSource
|
||||
tkDarken ::tk::Darken
|
||||
tkEntryAutoScan ::tk::EntryAutoScan
|
||||
tkEntryBackspace ::tk::EntryBackspace
|
||||
tkEntryButton1 ::tk::EntryButton1
|
||||
tkEntryClosestGap ::tk::EntryClosestGap
|
||||
tkEntryGetSelection ::tk::EntryGetSelection
|
||||
tkEntryInsert ::tk::EntryInsert
|
||||
tkEntryKeySelect ::tk::EntryKeySelect
|
||||
tkEntryMouseSelect ::tk::EntryMouseSelect
|
||||
tkEntryNextWord ::tk::EntryNextWord
|
||||
tkEntryPaste ::tk::EntryPaste
|
||||
tkEntryPreviousWord ::tk::EntryPreviousWord
|
||||
tkEntrySeeInsert ::tk::EntrySeeInsert
|
||||
tkEntrySetCursor ::tk::EntrySetCursor
|
||||
tkEntryTranspose ::tk::EntryTranspose
|
||||
tkEventMotifBindings ::tk::EventMotifBindings
|
||||
tkFDGetFileTypes ::tk::FDGetFileTypes
|
||||
tkFirstMenu ::tk::FirstMenu
|
||||
tkFocusGroup_BindIn ::tk::FocusGroup_BindIn
|
||||
tkFocusGroup_BindOut ::tk::FocusGroup_BindOut
|
||||
tkFocusGroup_Create ::tk::FocusGroup_Create
|
||||
tkFocusGroup_Destroy ::tk::FocusGroup_Destroy
|
||||
tkFocusGroup_In ::tk::FocusGroup_In
|
||||
tkFocusGroup_Out ::tk::FocusGroup_Out
|
||||
tkFocusOK ::tk::FocusOK
|
||||
tkGenerateMenuSelect ::tk::GenerateMenuSelect
|
||||
tkIconList ::tk::IconList
|
||||
tkListbox ::tk::Listbox
|
||||
tkListboxAutoScan ::tk::ListboxAutoScan
|
||||
tkListboxBeginExtend ::tk::ListboxBeginExtend
|
||||
tkListboxBeginSelect ::tk::ListboxBeginSelect
|
||||
tkListboxBeginToggle ::tk::ListboxBeginToggle
|
||||
tkListboxCancel ::tk::ListboxCancel
|
||||
tkListboxDataExtend ::tk::ListboxDataExtend
|
||||
tkListboxExtendUpDown ::tk::ListboxExtendUpDown
|
||||
tkListboxKeyAccel_Goto ::tk::ListboxKeyAccel_Goto
|
||||
tkListboxKeyAccel_Key ::tk::ListboxKeyAccel_Key
|
||||
tkListboxKeyAccel_Reset ::tk::ListboxKeyAccel_Reset
|
||||
tkListboxKeyAccel_Set ::tk::ListboxKeyAccel_Set
|
||||
tkListboxKeyAccel_Unset ::tk::ListboxKeyAccel_Unxet
|
||||
tkListboxMotion ::tk::ListboxMotion
|
||||
tkListboxSelectAll ::tk::ListboxSelectAll
|
||||
tkListboxUpDown ::tk::ListboxUpDown
|
||||
tkListboxBeginToggle ::tk::ListboxBeginToggle
|
||||
tkMbButtonUp ::tk::MbButtonUp
|
||||
tkMbEnter ::tk::MbEnter
|
||||
tkMbLeave ::tk::MbLeave
|
||||
tkMbMotion ::tk::MbMotion
|
||||
tkMbPost ::tk::MbPost
|
||||
tkMenuButtonDown ::tk::MenuButtonDown
|
||||
tkMenuDownArrow ::tk::MenuDownArrow
|
||||
tkMenuDup ::tk::MenuDup
|
||||
tkMenuEscape ::tk::MenuEscape
|
||||
tkMenuFind ::tk::MenuFind
|
||||
tkMenuFindName ::tk::MenuFindName
|
||||
tkMenuFirstEntry ::tk::MenuFirstEntry
|
||||
tkMenuInvoke ::tk::MenuInvoke
|
||||
tkMenuLeave ::tk::MenuLeave
|
||||
tkMenuLeftArrow ::tk::MenuLeftArrow
|
||||
tkMenuMotion ::tk::MenuMotion
|
||||
tkMenuNextEntry ::tk::MenuNextEntry
|
||||
tkMenuNextMenu ::tk::MenuNextMenu
|
||||
tkMenuRightArrow ::tk::MenuRightArrow
|
||||
tkMenuUnpost ::tk::MenuUnpost
|
||||
tkMenuUpArrow ::tk::MenuUpArrow
|
||||
tkMessageBox ::tk::MessageBox
|
||||
tkMotifFDialog ::tk::MotifFDialog
|
||||
tkMotifFDialog_ActivateDList ::tk::MotifFDialog_ActivateDList
|
||||
tkMotifFDialog_ActivateFList ::tk::MotifFDialog_ActivateFList
|
||||
tkMotifFDialog_ActivateFEnt ::tk::MotifFDialog_ActivateFEnt
|
||||
tkMotifFDialog_ActivateSEnt ::tk::MotifFDialog_ActivateSEnt
|
||||
tkMotifFDialog ::tk::MotifFDialog
|
||||
tkMotifFDialog_BrowseDList ::tk::MotifFDialog_BrowseDList
|
||||
tkMotifFDialog_BrowseFList ::tk::MotifFDialog_BrowseFList
|
||||
tkMotifFDialog_BuildUI ::tk::MotifFDialog_BuildUI
|
||||
tkMotifFDialog_CancelCmd ::tk::MotifFDialog_CancelCmd
|
||||
tkMotifFDialog_Config ::tk::MotifFDialog_Config
|
||||
tkMotifFDialog_Create ::tk::MotifFDialog_Create
|
||||
tkMotifFDialog_FileTypes ::tk::MotifFDialog_FileTypes
|
||||
tkMotifFDialog_FilterCmd ::tk::MotifFDialog_FilterCmd
|
||||
tkMotifFDialog_InterpFilter ::tk::MotifFDialog_InterpFilter
|
||||
tkMotifFDialog_LoadFiles ::tk::MotifFDialog_LoadFiles
|
||||
tkMotifFDialog_MakeSList ::tk::MotifFDialog_MakeSList
|
||||
tkMotifFDialog_OkCmd ::tk::MotifFDialog_OkCmd
|
||||
tkMotifFDialog_SetFilter ::tk::MotifFDialog_SetFilter
|
||||
tkMotifFDialog_SetListMode ::tk::MotifFDialog_SetListMode
|
||||
tkMotifFDialog_Update ::tk::MotifFDialog_Update
|
||||
tkPostOverPoint ::tk::PostOverPoint
|
||||
tkRecolorTree ::tk::RecolorTree
|
||||
tkRestoreOldGrab ::tk::RestoreOldGrab
|
||||
tkSaveGrabInfo ::tk::SaveGrabInfo
|
||||
tkScaleActivate ::tk::ScaleActivate
|
||||
tkScaleButtonDown ::tk::ScaleButtonDown
|
||||
tkScaleButton2Down ::tk::ScaleButton2Down
|
||||
tkScaleControlPress ::tk::ScaleControlPress
|
||||
tkScaleDrag ::tk::ScaleDrag
|
||||
tkScaleEndDrag ::tk::ScaleEndDrag
|
||||
tkScaleIncrement ::tk::ScaleIncrement
|
||||
tkScreenChanged ::tk::ScreenChanged
|
||||
tkScrollButtonDown ::tk::ScrollButtonDown
|
||||
tkScrollButton2Down ::tk::ScrollButton2Down
|
||||
tkScrollButtonDrag ::tk::ScrollButtonDrag
|
||||
tkScrollButtonUp ::tk::ScrollButtonUp
|
||||
tkScrollByPages ::tk::ScrollByPages
|
||||
tkScrollByUnits ::tk::ScrollByUnits
|
||||
tkScrollEndDrag ::tk::ScrollEndDrag
|
||||
tkScrollSelect ::tk::ScrollSelect
|
||||
tkScrollStartDrag ::tk::ScrollStartDrag
|
||||
tkScrollTopBottom ::tk::ScrollTopBottom
|
||||
tkScrollToPos ::tk::ScrollToPos
|
||||
tkTabToWindow ::tk::TabToWindow
|
||||
tkTearOffMenu ::tk::TearOffMenu
|
||||
tkTextAutoScan ::tk::TextAutoScan
|
||||
tkTextButton1 ::tk::TextButton1
|
||||
tkTextClosestGap ::tk::TextClosestGap
|
||||
tkTextInsert ::tk::TextInsert
|
||||
tkTextKeyExtend ::tk::TextKeyExtend
|
||||
tkTextKeySelect ::tk::TextKeySelect
|
||||
tkTextNextPara ::tk::TextNextPara
|
||||
tkTextNextPos ::tk::TextNextPos
|
||||
tkTextNextWord ::tk::TextNextWord
|
||||
tkTextPaste ::tk::TextPaste
|
||||
tkTextPrevPara ::tk::TextPrevPara
|
||||
tkTextPrevPos ::tk::TextPrevPos
|
||||
tkTextPrevWord ::tk::TextPrevWord
|
||||
tkTextResetAnchor ::tk::TextResetAnchor
|
||||
tkTextScrollPages ::tk::TextScrollPages
|
||||
tkTextSelectTo ::tk::TextSelectTo
|
||||
tkTextSetCursor ::tk::TextSetCursor
|
||||
tkTextTranspose ::tk::TextTranspose
|
||||
tkTextUpDownLine ::tk::TextUpDownLine
|
||||
tkTraverseToMenu ::tk::TraverseToMenu
|
||||
tkTraverseWithinMenu ::tk::TraverseWithinMenu
|
||||
unsupported1 ::tk::unsupported::MacWindowStyle
|
||||
}
|
||||
|
||||
# Map from the old global names of Tk private variable to their
|
||||
# new namespace-encapsulated names.
|
||||
|
||||
variable PrivateVariables
|
||||
array set PrivateVariables {
|
||||
droped_to_start ::tk::mac::Droped_to_start
|
||||
histNum ::tk::HistNum
|
||||
stub_location ::tk::mac::Stub_location
|
||||
tkFocusIn ::tk::FocusIn
|
||||
tkFocusOut ::tk::FocusOut
|
||||
tkPalette ::tk::Palette
|
||||
tkPriv ::tk::Priv
|
||||
tkPrivMsgBox ::tk::PrivMsgBox
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::unsupported::ExposePrivateCommand --
|
||||
#
|
||||
# Expose one of Tk's private commands to be visible under its
|
||||
# old global name
|
||||
#
|
||||
# Arguments:
|
||||
# cmd Global name by which the command was once known,
|
||||
# or a glob-style pattern.
|
||||
#
|
||||
# Results:
|
||||
# None.
|
||||
#
|
||||
# Side effects:
|
||||
# The old command name in the global namespace is aliased to the
|
||||
# new private name.
|
||||
|
||||
proc ::tk::unsupported::ExposePrivateCommand {cmd} {
|
||||
variable PrivateCommands
|
||||
set cmds [array get PrivateCommands $cmd]
|
||||
if {[llength $cmds] == 0} {
|
||||
return -code error -errorcode {TK EXPOSE_PRIVATE_COMMAND} \
|
||||
"No compatibility support for \[$cmd]"
|
||||
}
|
||||
foreach {old new} $cmds {
|
||||
namespace eval :: [list interp alias {} $old {}] $new
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::unsupported::ExposePrivateVariable --
|
||||
#
|
||||
# Expose one of Tk's private variables to be visible under its
|
||||
# old global name
|
||||
#
|
||||
# Arguments:
|
||||
# var Global name by which the variable was once known,
|
||||
# or a glob-style pattern.
|
||||
#
|
||||
# Results:
|
||||
# None.
|
||||
#
|
||||
# Side effects:
|
||||
# The old variable name in the global namespace is aliased to the
|
||||
# new private name.
|
||||
|
||||
proc ::tk::unsupported::ExposePrivateVariable {var} {
|
||||
variable PrivateVariables
|
||||
set vars [array get PrivateVariables $var]
|
||||
if {[llength $vars] == 0} {
|
||||
return -code error -errorcode {TK EXPOSE_PRIVATE_VARIABLE} \
|
||||
"No compatibility support for \$$var"
|
||||
}
|
||||
namespace eval ::tk::mac {}
|
||||
foreach {old new} $vars {
|
||||
namespace eval :: [list upvar "#0" $new $old]
|
||||
}
|
||||
}
|
||||
|
|
@ -0,0 +1,989 @@
|
|||
# xmfbox.tcl --
|
||||
#
|
||||
# Implements the "Motif" style file selection dialog for the
|
||||
# Unix platform. This implementation is used only if the
|
||||
# "::tk_strictMotif" flag is set.
|
||||
#
|
||||
# Copyright (c) 1996 Sun Microsystems, Inc.
|
||||
# Copyright (c) 1998-2000 Scriptics Corporation
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
namespace eval ::tk::dialog {}
|
||||
namespace eval ::tk::dialog::file {}
|
||||
|
||||
|
||||
# ::tk::MotifFDialog --
|
||||
#
|
||||
# Implements a file dialog similar to the standard Motif file
|
||||
# selection box.
|
||||
#
|
||||
# Arguments:
|
||||
# type "open" or "save"
|
||||
# args Options parsed by the procedure.
|
||||
#
|
||||
# Results:
|
||||
# When -multiple is set to 0, this returns the absolute pathname
|
||||
# of the selected file. (NOTE: This is not the same as a single
|
||||
# element list.)
|
||||
#
|
||||
# When -multiple is set to > 0, this returns a Tcl list of absolute
|
||||
# pathnames. The argument for -multiple is ignored, but for consistency
|
||||
# with Windows it defines the maximum amount of memory to allocate for
|
||||
# the returned filenames.
|
||||
|
||||
proc ::tk::MotifFDialog {type args} {
|
||||
variable ::tk::Priv
|
||||
set dataName __tk_filedialog
|
||||
upvar ::tk::dialog::file::$dataName data
|
||||
|
||||
set w [MotifFDialog_Create $dataName $type $args]
|
||||
|
||||
# Set a grab and claim the focus too.
|
||||
|
||||
::tk::SetFocusGrab $w $data(sEnt)
|
||||
$data(sEnt) selection range 0 end
|
||||
|
||||
# Wait for the user to respond, then restore the focus and
|
||||
# return the index of the selected button. Restore the focus
|
||||
# before deleting the window, since otherwise the window manager
|
||||
# may take the focus away so we can't redirect it. Finally,
|
||||
# restore any grab that was in effect.
|
||||
|
||||
vwait ::tk::Priv(selectFilePath)
|
||||
set result $Priv(selectFilePath)
|
||||
::tk::RestoreFocusGrab $w $data(sEnt) withdraw
|
||||
|
||||
return $result
|
||||
}
|
||||
|
||||
# ::tk::MotifFDialog_Create --
|
||||
#
|
||||
# Creates the Motif file dialog (if it doesn't exist yet) and
|
||||
# initialize the internal data structure associated with the
|
||||
# dialog.
|
||||
#
|
||||
# This procedure is used by ::tk::MotifFDialog to create the
|
||||
# dialog. It's also used by the test suite to test the Motif
|
||||
# file dialog implementation. User code shouldn't call this
|
||||
# procedure directly.
|
||||
#
|
||||
# Arguments:
|
||||
# dataName Name of the global "data" array for the file dialog.
|
||||
# type "Save" or "Open"
|
||||
# argList Options parsed by the procedure.
|
||||
#
|
||||
# Results:
|
||||
# Pathname of the file dialog.
|
||||
|
||||
proc ::tk::MotifFDialog_Create {dataName type argList} {
|
||||
upvar ::tk::dialog::file::$dataName data
|
||||
|
||||
MotifFDialog_Config $dataName $type $argList
|
||||
|
||||
if {$data(-parent) eq "."} {
|
||||
set w .$dataName
|
||||
} else {
|
||||
set w $data(-parent).$dataName
|
||||
}
|
||||
|
||||
# (re)create the dialog box if necessary
|
||||
#
|
||||
if {![winfo exists $w]} {
|
||||
MotifFDialog_BuildUI $w
|
||||
} elseif {[winfo class $w] ne "TkMotifFDialog"} {
|
||||
destroy $w
|
||||
MotifFDialog_BuildUI $w
|
||||
} else {
|
||||
set data(fEnt) $w.top.f1.ent
|
||||
set data(dList) $w.top.f2.a.l
|
||||
set data(fList) $w.top.f2.b.l
|
||||
set data(sEnt) $w.top.f3.ent
|
||||
set data(okBtn) $w.bot.ok
|
||||
set data(filterBtn) $w.bot.filter
|
||||
set data(cancelBtn) $w.bot.cancel
|
||||
}
|
||||
MotifFDialog_SetListMode $w
|
||||
|
||||
# Dialog boxes should be transient with respect to their parent,
|
||||
# so that they will always stay on top of their parent window. However,
|
||||
# some window managers will create the window as withdrawn if the parent
|
||||
# window is withdrawn or iconified. Combined with the grab we put on the
|
||||
# window, this can hang the entire application. Therefore we only make
|
||||
# the dialog transient if the parent is viewable.
|
||||
|
||||
if {[winfo viewable [winfo toplevel $data(-parent)]] } {
|
||||
wm transient $w $data(-parent)
|
||||
}
|
||||
|
||||
MotifFDialog_FileTypes $w
|
||||
MotifFDialog_Update $w
|
||||
|
||||
# Withdraw the window, then update all the geometry information
|
||||
# so we know how big it wants to be, then center the window in the
|
||||
# display (Motif style) and de-iconify it.
|
||||
|
||||
::tk::PlaceWindow $w
|
||||
wm title $w $data(-title)
|
||||
|
||||
return $w
|
||||
}
|
||||
|
||||
# ::tk::MotifFDialog_FileTypes --
|
||||
#
|
||||
# Checks the -filetypes option. If present this adds a list of radio-
|
||||
# buttons to pick the file types from.
|
||||
#
|
||||
# Arguments:
|
||||
# w Pathname of the tk_get*File dialogue.
|
||||
#
|
||||
# Results:
|
||||
# none
|
||||
|
||||
proc ::tk::MotifFDialog_FileTypes {w} {
|
||||
upvar ::tk::dialog::file::[winfo name $w] data
|
||||
|
||||
set f $w.top.f3.types
|
||||
destroy $f
|
||||
|
||||
# No file types: use "*" as the filter and display no radio-buttons
|
||||
if {$data(-filetypes) eq ""} {
|
||||
set data(filter) *
|
||||
return
|
||||
}
|
||||
|
||||
# The filetypes radiobuttons
|
||||
# set data(fileType) $data(-defaulttype)
|
||||
# Default type to first entry
|
||||
set initialTypeName [lindex $data(origfiletypes) 0 0]
|
||||
if {$data(-typevariable) ne ""} {
|
||||
upvar #0 $data(-typevariable) typeVariable
|
||||
if {[info exists typeVariable]} {
|
||||
set initialTypeName $typeVariable
|
||||
}
|
||||
}
|
||||
set ix 0
|
||||
set data(fileType) 0
|
||||
foreach fltr $data(origfiletypes) {
|
||||
set fname [lindex $fltr 0]
|
||||
if {[string first $initialTypeName $fname] == 0} {
|
||||
set data(fileType) $ix
|
||||
break
|
||||
}
|
||||
incr ix
|
||||
}
|
||||
|
||||
MotifFDialog_SetFilter $w [lindex $data(-filetypes) $data(fileType)]
|
||||
|
||||
#don't produce radiobuttons for only one filetype
|
||||
if {[llength $data(-filetypes)] == 1} {
|
||||
return
|
||||
}
|
||||
|
||||
frame $f
|
||||
set cnt 0
|
||||
if {$data(-filetypes) ne {}} {
|
||||
foreach type $data(-filetypes) {
|
||||
set title [lindex $type 0]
|
||||
set filter [lindex $type 1]
|
||||
radiobutton $f.b$cnt \
|
||||
-text $title \
|
||||
-variable ::tk::dialog::file::[winfo name $w](fileType) \
|
||||
-value $cnt \
|
||||
-command [list tk::MotifFDialog_SetFilter $w $type]
|
||||
pack $f.b$cnt -side left
|
||||
incr cnt
|
||||
}
|
||||
}
|
||||
$f.b$data(fileType) invoke
|
||||
|
||||
pack $f -side bottom -fill both
|
||||
|
||||
return
|
||||
}
|
||||
|
||||
# This proc gets called whenever data(filter) is set
|
||||
#
|
||||
proc ::tk::MotifFDialog_SetFilter {w type} {
|
||||
upvar ::tk::dialog::file::[winfo name $w] data
|
||||
variable ::tk::Priv
|
||||
|
||||
set data(filter) [lindex $type 1]
|
||||
set Priv(selectFileType) [lindex [lindex $type 0] 0]
|
||||
|
||||
MotifFDialog_Update $w
|
||||
}
|
||||
|
||||
# ::tk::MotifFDialog_Config --
|
||||
#
|
||||
# Iterates over the optional arguments to determine the option
|
||||
# values for the Motif file dialog; gives default values to
|
||||
# unspecified options.
|
||||
#
|
||||
# Arguments:
|
||||
# dataName The name of the global variable in which
|
||||
# data for the file dialog is stored.
|
||||
# type "Save" or "Open"
|
||||
# argList Options parsed by the procedure.
|
||||
|
||||
proc ::tk::MotifFDialog_Config {dataName type argList} {
|
||||
upvar ::tk::dialog::file::$dataName data
|
||||
|
||||
set data(type) $type
|
||||
|
||||
# 1: the configuration specs
|
||||
#
|
||||
set specs {
|
||||
{-defaultextension "" "" ""}
|
||||
{-filetypes "" "" ""}
|
||||
{-initialdir "" "" ""}
|
||||
{-initialfile "" "" ""}
|
||||
{-parent "" "" "."}
|
||||
{-title "" "" ""}
|
||||
{-typevariable "" "" ""}
|
||||
}
|
||||
if {$type eq "open"} {
|
||||
lappend specs {-multiple "" "" "0"}
|
||||
}
|
||||
if {$type eq "save"} {
|
||||
lappend specs {-confirmoverwrite "" "" "1"}
|
||||
}
|
||||
|
||||
set data(-multiple) 0
|
||||
set data(-confirmoverwrite) 1
|
||||
# 2: default values depending on the type of the dialog
|
||||
#
|
||||
if {![info exists data(selectPath)]} {
|
||||
# first time the dialog has been popped up
|
||||
set data(selectPath) [pwd]
|
||||
set data(selectFile) ""
|
||||
}
|
||||
|
||||
# 3: parse the arguments
|
||||
#
|
||||
tclParseConfigSpec ::tk::dialog::file::$dataName $specs "" $argList
|
||||
|
||||
if {$data(-title) eq ""} {
|
||||
if {$type eq "open"} {
|
||||
if {$data(-multiple) != 0} {
|
||||
set data(-title) "[mc {Open Multiple Files}]"
|
||||
} else {
|
||||
set data(-title) [mc "Open"]
|
||||
}
|
||||
} else {
|
||||
set data(-title) [mc "Save As"]
|
||||
}
|
||||
}
|
||||
|
||||
# 4: set the default directory and selection according to the -initial
|
||||
# settings
|
||||
#
|
||||
if {$data(-initialdir) ne ""} {
|
||||
if {[file isdirectory $data(-initialdir)]} {
|
||||
set data(selectPath) [lindex [glob $data(-initialdir)] 0]
|
||||
} else {
|
||||
set data(selectPath) [pwd]
|
||||
}
|
||||
|
||||
# Convert the initialdir to an absolute path name.
|
||||
|
||||
set old [pwd]
|
||||
cd $data(selectPath)
|
||||
set data(selectPath) [pwd]
|
||||
cd $old
|
||||
}
|
||||
set data(selectFile) $data(-initialfile)
|
||||
|
||||
# 5. Parse the -filetypes option. It is not used by the motif
|
||||
# file dialog, but we check for validity of the value to make sure
|
||||
# the application code also runs fine with the TK file dialog.
|
||||
#
|
||||
set data(origfiletypes) $data(-filetypes)
|
||||
set data(-filetypes) [::tk::FDGetFileTypes $data(-filetypes)]
|
||||
|
||||
if {![info exists data(filter)]} {
|
||||
set data(filter) *
|
||||
}
|
||||
if {![winfo exists $data(-parent)]} {
|
||||
return -code error -errorcode [list TK LOOKUP WINDOW $data(-parent)] \
|
||||
"bad window path name \"$data(-parent)\""
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::MotifFDialog_BuildUI --
|
||||
#
|
||||
# Builds the UI components of the Motif file dialog.
|
||||
#
|
||||
# Arguments:
|
||||
# w Pathname of the dialog to build.
|
||||
#
|
||||
# Results:
|
||||
# None.
|
||||
|
||||
proc ::tk::MotifFDialog_BuildUI {w} {
|
||||
set dataName [lindex [split $w .] end]
|
||||
upvar ::tk::dialog::file::$dataName data
|
||||
|
||||
# Create the dialog toplevel and internal frames.
|
||||
#
|
||||
toplevel $w -class TkMotifFDialog
|
||||
set top [frame $w.top -relief raised -bd 1]
|
||||
set bot [frame $w.bot -relief raised -bd 1]
|
||||
|
||||
pack $w.bot -side bottom -fill x
|
||||
pack $w.top -side top -expand yes -fill both
|
||||
|
||||
set f1 [frame $top.f1]
|
||||
set f2 [frame $top.f2]
|
||||
set f3 [frame $top.f3]
|
||||
|
||||
pack $f1 -side top -fill x
|
||||
pack $f3 -side bottom -fill x
|
||||
pack $f2 -expand yes -fill both
|
||||
|
||||
set f2a [frame $f2.a]
|
||||
set f2b [frame $f2.b]
|
||||
|
||||
grid $f2a -row 0 -column 0 -rowspan 1 -columnspan 1 -padx 4 -pady 4 \
|
||||
-sticky news
|
||||
grid $f2b -row 0 -column 1 -rowspan 1 -columnspan 1 -padx 4 -pady 4 \
|
||||
-sticky news
|
||||
grid rowconfigure $f2 0 -minsize 0 -weight 1
|
||||
grid columnconfigure $f2 0 -minsize 0 -weight 1
|
||||
grid columnconfigure $f2 1 -minsize 150 -weight 2
|
||||
|
||||
# The Filter box
|
||||
#
|
||||
bind [::tk::AmpWidget label $f1.lab -text [mc "Fil&ter:"] -anchor w] \
|
||||
<<AltUnderlined>> [list focus $f1.ent]
|
||||
entry $f1.ent
|
||||
pack $f1.lab -side top -fill x -padx 6 -pady 4
|
||||
pack $f1.ent -side top -fill x -padx 4 -pady 0
|
||||
set data(fEnt) $f1.ent
|
||||
|
||||
# The file and directory lists
|
||||
#
|
||||
set data(dList) [MotifFDialog_MakeSList $w $f2a \
|
||||
[mc "&Directory:"] DList]
|
||||
set data(fList) [MotifFDialog_MakeSList $w $f2b \
|
||||
[mc "Fi&les:"] FList]
|
||||
|
||||
# The Selection box
|
||||
#
|
||||
bind [::tk::AmpWidget label $f3.lab -text [mc "&Selection:"] -anchor w] \
|
||||
<<AltUnderlined>> [list focus $f3.ent]
|
||||
entry $f3.ent
|
||||
pack $f3.lab -side top -fill x -padx 6 -pady 0
|
||||
pack $f3.ent -side top -fill x -padx 4 -pady 4
|
||||
set data(sEnt) $f3.ent
|
||||
|
||||
# The buttons
|
||||
#
|
||||
set maxWidth [::tk::mcmaxamp &OK &Filter &Cancel]
|
||||
set maxWidth [expr {$maxWidth<6?6:$maxWidth}]
|
||||
set data(okBtn) [::tk::AmpWidget button $bot.ok -text [mc "&OK"] \
|
||||
-width $maxWidth \
|
||||
-command [list tk::MotifFDialog_OkCmd $w]]
|
||||
set data(filterBtn) [::tk::AmpWidget button $bot.filter -text [mc "&Filter"] \
|
||||
-width $maxWidth \
|
||||
-command [list tk::MotifFDialog_FilterCmd $w]]
|
||||
set data(cancelBtn) [::tk::AmpWidget button $bot.cancel -text [mc "&Cancel"] \
|
||||
-width $maxWidth \
|
||||
-command [list tk::MotifFDialog_CancelCmd $w]]
|
||||
|
||||
pack $bot.ok $bot.filter $bot.cancel -padx 10 -pady 10 -expand yes \
|
||||
-side left
|
||||
|
||||
# Create the bindings:
|
||||
#
|
||||
bind $w <Alt-Key> [list ::tk::AltKeyInDialog $w %A]
|
||||
|
||||
bind $data(fEnt) <Return> [list tk::MotifFDialog_ActivateFEnt $w]
|
||||
bind $data(sEnt) <Return> [list tk::MotifFDialog_ActivateSEnt $w]
|
||||
bind $w <Escape> [list tk::MotifFDialog_CancelCmd $w]
|
||||
bind $w.bot <Destroy> {set ::tk::Priv(selectFilePath) {}}
|
||||
|
||||
wm protocol $w WM_DELETE_WINDOW [list tk::MotifFDialog_CancelCmd $w]
|
||||
}
|
||||
|
||||
proc ::tk::MotifFDialog_SetListMode {w} {
|
||||
upvar ::tk::dialog::file::[winfo name $w] data
|
||||
|
||||
if {$data(-multiple) != 0} {
|
||||
set selectmode extended
|
||||
} else {
|
||||
set selectmode browse
|
||||
}
|
||||
set f $w.top.f2.b
|
||||
$f.l configure -selectmode $selectmode
|
||||
}
|
||||
|
||||
# ::tk::MotifFDialog_MakeSList --
|
||||
#
|
||||
# Create a scrolled-listbox and set the keyboard accelerator
|
||||
# bindings so that the list selection follows what the user
|
||||
# types.
|
||||
#
|
||||
# Arguments:
|
||||
# w Pathname of the dialog box.
|
||||
# f Frame widget inside which to create the scrolled
|
||||
# listbox. This frame widget already exists.
|
||||
# label The string to display on top of the listbox.
|
||||
# under Sets the -under option of the label.
|
||||
# cmdPrefix Specifies procedures to call when the listbox is
|
||||
# browsed or activated.
|
||||
|
||||
proc ::tk::MotifFDialog_MakeSList {w f label cmdPrefix} {
|
||||
bind [::tk::AmpWidget label $f.lab -text $label -anchor w] \
|
||||
<<AltUnderlined>> [list focus $f.l]
|
||||
listbox $f.l -width 12 -height 5 -exportselection 0\
|
||||
-xscrollcommand [list $f.h set] -yscrollcommand [list $f.v set]
|
||||
scrollbar $f.v -orient vertical -takefocus 0 -command [list $f.l yview]
|
||||
scrollbar $f.h -orient horizontal -takefocus 0 -command [list $f.l xview]
|
||||
grid $f.lab -row 0 -column 0 -sticky news -rowspan 1 -columnspan 2 \
|
||||
-padx 2 -pady 2
|
||||
grid $f.l -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news
|
||||
grid $f.v -row 1 -column 1 -rowspan 1 -columnspan 1 -sticky news
|
||||
grid $f.h -row 2 -column 0 -rowspan 1 -columnspan 1 -sticky news
|
||||
|
||||
grid rowconfigure $f 0 -weight 0 -minsize 0
|
||||
grid rowconfigure $f 1 -weight 1 -minsize 0
|
||||
grid columnconfigure $f 0 -weight 1 -minsize 0
|
||||
|
||||
# bindings for the listboxes
|
||||
#
|
||||
set list $f.l
|
||||
bind $list <<ListboxSelect>> [list tk::MotifFDialog_Browse$cmdPrefix $w]
|
||||
bind $list <Double-ButtonRelease-1> \
|
||||
[list tk::MotifFDialog_Activate$cmdPrefix $w]
|
||||
bind $list <Return> "tk::MotifFDialog_Browse$cmdPrefix [list $w]; \
|
||||
tk::MotifFDialog_Activate$cmdPrefix [list $w]"
|
||||
|
||||
bindtags $list [list Listbox $list [winfo toplevel $list] all]
|
||||
ListBoxKeyAccel_Set $list
|
||||
|
||||
return $f.l
|
||||
}
|
||||
|
||||
# ::tk::MotifFDialog_InterpFilter --
|
||||
#
|
||||
# Interpret the string in the filter entry into two components:
|
||||
# the directory and the pattern. If the string is a relative
|
||||
# pathname, give a warning to the user and restore the pattern
|
||||
# to original.
|
||||
#
|
||||
# Arguments:
|
||||
# w pathname of the dialog box.
|
||||
#
|
||||
# Results:
|
||||
# A list of two elements. The first element is the directory
|
||||
# specified # by the filter. The second element is the filter
|
||||
# pattern itself.
|
||||
|
||||
proc ::tk::MotifFDialog_InterpFilter {w} {
|
||||
upvar ::tk::dialog::file::[winfo name $w] data
|
||||
|
||||
set text [string trim [$data(fEnt) get]]
|
||||
|
||||
# Perform tilde substitution
|
||||
#
|
||||
set badTilde 0
|
||||
if {[string index $text 0] eq "~"} {
|
||||
set list [file split $text]
|
||||
set tilde [lindex $list 0]
|
||||
if {[catch {set tilde [glob $tilde]}]} {
|
||||
set badTilde 1
|
||||
} else {
|
||||
set text [eval file join [concat $tilde [lrange $list 1 end]]]
|
||||
}
|
||||
}
|
||||
|
||||
# If the string is a relative pathname, combine it
|
||||
# with the current selectPath.
|
||||
|
||||
set relative 0
|
||||
if {[file pathtype $text] eq "relative"} {
|
||||
set relative 1
|
||||
} elseif {$badTilde} {
|
||||
set relative 1
|
||||
}
|
||||
|
||||
if {$relative} {
|
||||
tk_messageBox -icon warning -type ok \
|
||||
-message "\"$text\" must be an absolute pathname"
|
||||
|
||||
$data(fEnt) delete 0 end
|
||||
$data(fEnt) insert 0 [::tk::dialog::file::JoinFile $data(selectPath) \
|
||||
$data(filter)]
|
||||
|
||||
return [list $data(selectPath) $data(filter)]
|
||||
}
|
||||
|
||||
set resolved [::tk::dialog::file::JoinFile [file dirname $text] [file tail $text]]
|
||||
|
||||
if {[file isdirectory $resolved]} {
|
||||
set dir $resolved
|
||||
set fil $data(filter)
|
||||
} else {
|
||||
set dir [file dirname $resolved]
|
||||
set fil [file tail $resolved]
|
||||
}
|
||||
|
||||
return [list $dir $fil]
|
||||
}
|
||||
|
||||
# ::tk::MotifFDialog_Update
|
||||
#
|
||||
# Load the files and synchronize the "filter" and "selection" fields
|
||||
# boxes.
|
||||
#
|
||||
# Arguments:
|
||||
# w pathname of the dialog box.
|
||||
#
|
||||
# Results:
|
||||
# None.
|
||||
|
||||
proc ::tk::MotifFDialog_Update {w} {
|
||||
upvar ::tk::dialog::file::[winfo name $w] data
|
||||
|
||||
$data(fEnt) delete 0 end
|
||||
$data(fEnt) insert 0 \
|
||||
[::tk::dialog::file::JoinFile $data(selectPath) $data(filter)]
|
||||
$data(sEnt) delete 0 end
|
||||
$data(sEnt) insert 0 [::tk::dialog::file::JoinFile $data(selectPath) \
|
||||
$data(selectFile)]
|
||||
|
||||
MotifFDialog_LoadFiles $w
|
||||
}
|
||||
|
||||
# ::tk::MotifFDialog_LoadFiles --
|
||||
#
|
||||
# Loads the files and directories into the two listboxes according
|
||||
# to the filter setting.
|
||||
#
|
||||
# Arguments:
|
||||
# w pathname of the dialog box.
|
||||
#
|
||||
# Results:
|
||||
# None.
|
||||
|
||||
proc ::tk::MotifFDialog_LoadFiles {w} {
|
||||
upvar ::tk::dialog::file::[winfo name $w] data
|
||||
|
||||
$data(dList) delete 0 end
|
||||
$data(fList) delete 0 end
|
||||
|
||||
set appPWD [pwd]
|
||||
if {[catch {cd $data(selectPath)}]} {
|
||||
cd $appPWD
|
||||
|
||||
$data(dList) insert end ".."
|
||||
return
|
||||
}
|
||||
|
||||
# Make the dir and file lists
|
||||
#
|
||||
# For speed we only have one glob, which reduces the file system
|
||||
# calls (good for slow NFS networks).
|
||||
#
|
||||
# We also do two smaller sorts (files + dirs) instead of one large sort,
|
||||
# which gives a small speed increase.
|
||||
#
|
||||
set top 0
|
||||
set dlist ""
|
||||
set flist ""
|
||||
foreach f [glob -nocomplain .* *] {
|
||||
if {[file isdir ./$f]} {
|
||||
lappend dlist $f
|
||||
} else {
|
||||
foreach pat $data(filter) {
|
||||
if {[string match $pat $f]} {
|
||||
if {[string match .* $f]} {
|
||||
incr top
|
||||
}
|
||||
lappend flist $f
|
||||
break
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
eval [list $data(dList) insert end] [lsort -dictionary $dlist]
|
||||
eval [list $data(fList) insert end] [lsort -dictionary $flist]
|
||||
|
||||
# The user probably doesn't want to see the . files. We adjust the view
|
||||
# so that the listbox displays all the non-dot files
|
||||
$data(fList) yview $top
|
||||
|
||||
cd $appPWD
|
||||
}
|
||||
|
||||
# ::tk::MotifFDialog_BrowseDList --
|
||||
#
|
||||
# This procedure is called when the directory list is browsed
|
||||
# (clicked-over) by the user.
|
||||
#
|
||||
# Arguments:
|
||||
# w The pathname of the dialog box.
|
||||
#
|
||||
# Results:
|
||||
# None.
|
||||
|
||||
proc ::tk::MotifFDialog_BrowseDList {w} {
|
||||
upvar ::tk::dialog::file::[winfo name $w] data
|
||||
|
||||
focus $data(dList)
|
||||
if {[$data(dList) curselection] eq ""} {
|
||||
return
|
||||
}
|
||||
set subdir [$data(dList) get [$data(dList) curselection]]
|
||||
if {$subdir eq ""} {
|
||||
return
|
||||
}
|
||||
|
||||
$data(fList) selection clear 0 end
|
||||
|
||||
set list [MotifFDialog_InterpFilter $w]
|
||||
set data(filter) [lindex $list 1]
|
||||
|
||||
switch -- $subdir {
|
||||
. {
|
||||
set newSpec [::tk::dialog::file::JoinFile $data(selectPath) $data(filter)]
|
||||
}
|
||||
.. {
|
||||
set newSpec [::tk::dialog::file::JoinFile [file dirname $data(selectPath)] \
|
||||
$data(filter)]
|
||||
}
|
||||
default {
|
||||
set newSpec [::tk::dialog::file::JoinFile [::tk::dialog::file::JoinFile \
|
||||
$data(selectPath) $subdir] $data(filter)]
|
||||
}
|
||||
}
|
||||
|
||||
$data(fEnt) delete 0 end
|
||||
$data(fEnt) insert 0 $newSpec
|
||||
}
|
||||
|
||||
# ::tk::MotifFDialog_ActivateDList --
|
||||
#
|
||||
# This procedure is called when the directory list is activated
|
||||
# (double-clicked) by the user.
|
||||
#
|
||||
# Arguments:
|
||||
# w The pathname of the dialog box.
|
||||
#
|
||||
# Results:
|
||||
# None.
|
||||
|
||||
proc ::tk::MotifFDialog_ActivateDList {w} {
|
||||
upvar ::tk::dialog::file::[winfo name $w] data
|
||||
|
||||
if {[$data(dList) curselection] eq ""} {
|
||||
return
|
||||
}
|
||||
set subdir [$data(dList) get [$data(dList) curselection]]
|
||||
if {$subdir eq ""} {
|
||||
return
|
||||
}
|
||||
|
||||
$data(fList) selection clear 0 end
|
||||
|
||||
switch -- $subdir {
|
||||
. {
|
||||
set newDir $data(selectPath)
|
||||
}
|
||||
.. {
|
||||
set newDir [file dirname $data(selectPath)]
|
||||
}
|
||||
default {
|
||||
set newDir [::tk::dialog::file::JoinFile $data(selectPath) $subdir]
|
||||
}
|
||||
}
|
||||
|
||||
set data(selectPath) $newDir
|
||||
MotifFDialog_Update $w
|
||||
|
||||
if {$subdir ne ".."} {
|
||||
$data(dList) selection set 0
|
||||
$data(dList) activate 0
|
||||
} else {
|
||||
$data(dList) selection set 1
|
||||
$data(dList) activate 1
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::MotifFDialog_BrowseFList --
|
||||
#
|
||||
# This procedure is called when the file list is browsed
|
||||
# (clicked-over) by the user.
|
||||
#
|
||||
# Arguments:
|
||||
# w The pathname of the dialog box.
|
||||
#
|
||||
# Results:
|
||||
# None.
|
||||
|
||||
proc ::tk::MotifFDialog_BrowseFList {w} {
|
||||
upvar ::tk::dialog::file::[winfo name $w] data
|
||||
|
||||
focus $data(fList)
|
||||
set data(selectFile) ""
|
||||
foreach item [$data(fList) curselection] {
|
||||
lappend data(selectFile) [$data(fList) get $item]
|
||||
}
|
||||
if {[llength $data(selectFile)] == 0} {
|
||||
return
|
||||
}
|
||||
|
||||
$data(dList) selection clear 0 end
|
||||
|
||||
$data(fEnt) delete 0 end
|
||||
$data(fEnt) insert 0 [::tk::dialog::file::JoinFile $data(selectPath) \
|
||||
$data(filter)]
|
||||
$data(fEnt) xview end
|
||||
|
||||
# if it's a multiple selection box, just put in the filenames
|
||||
# otherwise put in the full path as usual
|
||||
$data(sEnt) delete 0 end
|
||||
if {$data(-multiple) != 0} {
|
||||
$data(sEnt) insert 0 $data(selectFile)
|
||||
} else {
|
||||
$data(sEnt) insert 0 [::tk::dialog::file::JoinFile $data(selectPath) \
|
||||
[lindex $data(selectFile) 0]]
|
||||
}
|
||||
$data(sEnt) xview end
|
||||
}
|
||||
|
||||
# ::tk::MotifFDialog_ActivateFList --
|
||||
#
|
||||
# This procedure is called when the file list is activated
|
||||
# (double-clicked) by the user.
|
||||
#
|
||||
# Arguments:
|
||||
# w The pathname of the dialog box.
|
||||
#
|
||||
# Results:
|
||||
# None.
|
||||
|
||||
proc ::tk::MotifFDialog_ActivateFList {w} {
|
||||
upvar ::tk::dialog::file::[winfo name $w] data
|
||||
|
||||
if {[$data(fList) curselection] eq ""} {
|
||||
return
|
||||
}
|
||||
set data(selectFile) [$data(fList) get [$data(fList) curselection]]
|
||||
if {$data(selectFile) eq ""} {
|
||||
return
|
||||
} else {
|
||||
MotifFDialog_ActivateSEnt $w
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::MotifFDialog_ActivateFEnt --
|
||||
#
|
||||
# This procedure is called when the user presses Return inside
|
||||
# the "filter" entry. It updates the dialog according to the
|
||||
# text inside the filter entry.
|
||||
#
|
||||
# Arguments:
|
||||
# w The pathname of the dialog box.
|
||||
#
|
||||
# Results:
|
||||
# None.
|
||||
|
||||
proc ::tk::MotifFDialog_ActivateFEnt {w} {
|
||||
upvar ::tk::dialog::file::[winfo name $w] data
|
||||
|
||||
set list [MotifFDialog_InterpFilter $w]
|
||||
set data(selectPath) [lindex $list 0]
|
||||
set data(filter) [lindex $list 1]
|
||||
|
||||
MotifFDialog_Update $w
|
||||
}
|
||||
|
||||
# ::tk::MotifFDialog_ActivateSEnt --
|
||||
#
|
||||
# This procedure is called when the user presses Return inside
|
||||
# the "selection" entry. It sets the ::tk::Priv(selectFilePath)
|
||||
# variable so that the vwait loop in tk::MotifFDialog will be
|
||||
# terminated.
|
||||
#
|
||||
# Arguments:
|
||||
# w The pathname of the dialog box.
|
||||
#
|
||||
# Results:
|
||||
# None.
|
||||
|
||||
proc ::tk::MotifFDialog_ActivateSEnt {w} {
|
||||
variable ::tk::Priv
|
||||
upvar ::tk::dialog::file::[winfo name $w] data
|
||||
|
||||
set selectFilePath [string trim [$data(sEnt) get]]
|
||||
|
||||
if {$selectFilePath eq ""} {
|
||||
MotifFDialog_FilterCmd $w
|
||||
return
|
||||
}
|
||||
|
||||
if {$data(-multiple) == 0} {
|
||||
set selectFilePath [list $selectFilePath]
|
||||
}
|
||||
|
||||
if {[file isdirectory [lindex $selectFilePath 0]]} {
|
||||
set data(selectPath) [lindex [glob $selectFilePath] 0]
|
||||
set data(selectFile) ""
|
||||
MotifFDialog_Update $w
|
||||
return
|
||||
}
|
||||
|
||||
set newFileList ""
|
||||
foreach item $selectFilePath {
|
||||
if {[file pathtype $item] ne "absolute"} {
|
||||
set item [file join $data(selectPath) $item]
|
||||
} elseif {![file exists [file dirname $item]]} {
|
||||
tk_messageBox -icon warning -type ok \
|
||||
-message [mc {Directory "%1$s" does not exist.} \
|
||||
[file dirname $item]]
|
||||
return
|
||||
}
|
||||
|
||||
if {![file exists $item]} {
|
||||
if {$data(type) eq "open"} {
|
||||
tk_messageBox -icon warning -type ok \
|
||||
-message [mc {File "%1$s" does not exist.} $item]
|
||||
return
|
||||
}
|
||||
} elseif {$data(type) eq "save" && $data(-confirmoverwrite)} {
|
||||
set message [format %s%s \
|
||||
[mc "File \"%1\$s\" already exists.\n\n" $selectFilePath] \
|
||||
[mc {Replace existing file?}]]
|
||||
set answer [tk_messageBox -icon warning -type yesno \
|
||||
-message $message]
|
||||
if {$answer eq "no"} {
|
||||
return
|
||||
}
|
||||
}
|
||||
|
||||
lappend newFileList $item
|
||||
}
|
||||
|
||||
# Return selected filter
|
||||
if {[info exists data(-typevariable)] && $data(-typevariable) ne ""
|
||||
&& [info exists data(-filetypes)] && $data(-filetypes) ne ""} {
|
||||
upvar #0 $data(-typevariable) typeVariable
|
||||
set typeVariable [lindex $data(origfiletypes) $data(fileType) 0]
|
||||
}
|
||||
|
||||
if {$data(-multiple) != 0} {
|
||||
set Priv(selectFilePath) $newFileList
|
||||
} else {
|
||||
set Priv(selectFilePath) [lindex $newFileList 0]
|
||||
}
|
||||
|
||||
# Set selectFile and selectPath to first item in list
|
||||
set Priv(selectFile) [file tail [lindex $newFileList 0]]
|
||||
set Priv(selectPath) [file dirname [lindex $newFileList 0]]
|
||||
}
|
||||
|
||||
|
||||
proc ::tk::MotifFDialog_OkCmd {w} {
|
||||
upvar ::tk::dialog::file::[winfo name $w] data
|
||||
|
||||
MotifFDialog_ActivateSEnt $w
|
||||
}
|
||||
|
||||
proc ::tk::MotifFDialog_FilterCmd {w} {
|
||||
upvar ::tk::dialog::file::[winfo name $w] data
|
||||
|
||||
MotifFDialog_ActivateFEnt $w
|
||||
}
|
||||
|
||||
proc ::tk::MotifFDialog_CancelCmd {w} {
|
||||
variable ::tk::Priv
|
||||
|
||||
set Priv(selectFilePath) ""
|
||||
set Priv(selectFile) ""
|
||||
set Priv(selectPath) ""
|
||||
}
|
||||
|
||||
proc ::tk::ListBoxKeyAccel_Set {w} {
|
||||
bind Listbox <Any-KeyPress> ""
|
||||
bind $w <Destroy> [list tk::ListBoxKeyAccel_Unset $w]
|
||||
bind $w <Any-KeyPress> [list tk::ListBoxKeyAccel_Key $w %A]
|
||||
}
|
||||
|
||||
proc ::tk::ListBoxKeyAccel_Unset {w} {
|
||||
variable ::tk::Priv
|
||||
|
||||
catch {after cancel $Priv(lbAccel,$w,afterId)}
|
||||
unset -nocomplain Priv(lbAccel,$w) Priv(lbAccel,$w,afterId)
|
||||
}
|
||||
|
||||
# ::tk::ListBoxKeyAccel_Key--
|
||||
#
|
||||
# This procedure maintains a list of recently entered keystrokes
|
||||
# over a listbox widget. It arranges an idle event to move the
|
||||
# selection of the listbox to the entry that begins with the
|
||||
# keystrokes.
|
||||
#
|
||||
# Arguments:
|
||||
# w The pathname of the listbox.
|
||||
# key The key which the user just pressed.
|
||||
#
|
||||
# Results:
|
||||
# None.
|
||||
|
||||
proc ::tk::ListBoxKeyAccel_Key {w key} {
|
||||
variable ::tk::Priv
|
||||
|
||||
if { $key eq "" } {
|
||||
return
|
||||
}
|
||||
append Priv(lbAccel,$w) $key
|
||||
ListBoxKeyAccel_Goto $w $Priv(lbAccel,$w)
|
||||
catch {
|
||||
after cancel $Priv(lbAccel,$w,afterId)
|
||||
}
|
||||
set Priv(lbAccel,$w,afterId) [after 500 \
|
||||
[list tk::ListBoxKeyAccel_Reset $w]]
|
||||
}
|
||||
|
||||
proc ::tk::ListBoxKeyAccel_Goto {w string} {
|
||||
variable ::tk::Priv
|
||||
|
||||
set string [string tolower $string]
|
||||
set end [$w index end]
|
||||
set theIndex -1
|
||||
|
||||
for {set i 0} {$i < $end} {incr i} {
|
||||
set item [string tolower [$w get $i]]
|
||||
if {[string compare $string $item] >= 0} {
|
||||
set theIndex $i
|
||||
}
|
||||
if {[string compare $string $item] <= 0} {
|
||||
set theIndex $i
|
||||
break
|
||||
}
|
||||
}
|
||||
|
||||
if {$theIndex >= 0} {
|
||||
$w selection clear 0 end
|
||||
$w selection set $theIndex $theIndex
|
||||
$w activate $theIndex
|
||||
$w see $theIndex
|
||||
event generate $w <<ListboxSelect>>
|
||||
}
|
||||
}
|
||||
|
||||
proc ::tk::ListBoxKeyAccel_Reset {w} {
|
||||
variable ::tk::Priv
|
||||
|
||||
unset -nocomplain Priv(lbAccel,$w)
|
||||
}
|
||||
|
||||
proc ::tk_getFileType {} {
|
||||
variable ::tk::Priv
|
||||
|
||||
return $Priv(selectFileType)
|
||||
}
|
||||
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
This software is copyrighted by the Regents of the University of
|
||||
California, Sun Microsystems, Inc., Scriptics Corporation, ActiveState
|
||||
Corporation and other parties. The following terms apply to all files
|
||||
associated with the software unless explicitly disclaimed in
|
||||
individual files.
|
||||
|
||||
The authors hereby grant permission to use, copy, modify, distribute,
|
||||
and license this software and its documentation for any purpose, provided
|
||||
that existing copyright notices are retained in all copies and that this
|
||||
notice is included verbatim in any distributions. No written agreement,
|
||||
license, or royalty fee is required for any of the authorized uses.
|
||||
Modifications to this software may be copyrighted by their authors
|
||||
and need not follow the licensing terms described here, provided that
|
||||
the new terms are clearly indicated on the first page of each file where
|
||||
they apply.
|
||||
|
||||
IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
|
||||
FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
|
||||
ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
|
||||
DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
|
||||
POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
|
||||
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
|
||||
IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
|
||||
NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
|
||||
MODIFICATIONS.
|
||||
|
||||
GOVERNMENT USE: If you are acquiring this software on behalf of the
|
||||
U.S. government, the Government shall have only "Restricted Rights"
|
||||
in the software and related documentation as defined in the Federal
|
||||
Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
|
||||
are acquiring the software on behalf of the Department of Defense, the
|
||||
software shall be classified as "Commercial Computer Software" and the
|
||||
Government shall have only "Restricted Rights" as defined in Clause
|
||||
252.227-7014 (b) (3) of DFARs. Notwithstanding the foregoing, the
|
||||
authors grant the U.S. Government and others acting in its behalf
|
||||
permission to use and distribute the software in accordance with the
|
||||
terms specified in this license.
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
This software is copyrighted by the Regents of the University of
|
||||
California, Sun Microsystems, Inc., Scriptics Corporation, ActiveState
|
||||
Corporation, Apple Inc. and other parties. The following terms apply to
|
||||
all files associated with the software unless explicitly disclaimed in
|
||||
individual files.
|
||||
|
||||
The authors hereby grant permission to use, copy, modify, distribute,
|
||||
and license this software and its documentation for any purpose, provided
|
||||
that existing copyright notices are retained in all copies and that this
|
||||
notice is included verbatim in any distributions. No written agreement,
|
||||
license, or royalty fee is required for any of the authorized uses.
|
||||
Modifications to this software may be copyrighted by their authors
|
||||
and need not follow the licensing terms described here, provided that
|
||||
the new terms are clearly indicated on the first page of each file where
|
||||
they apply.
|
||||
|
||||
IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
|
||||
FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
|
||||
ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
|
||||
DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
|
||||
POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
|
||||
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
|
||||
IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
|
||||
NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
|
||||
MODIFICATIONS.
|
||||
|
||||
GOVERNMENT USE: If you are acquiring this software on behalf of the
|
||||
U.S. government, the Government shall have only "Restricted Rights"
|
||||
in the software and related documentation as defined in the Federal
|
||||
Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
|
||||
are acquiring the software on behalf of the Department of Defense, the
|
||||
software shall be classified as "Commercial Computer Software" and the
|
||||
Government shall have only "Restricted Rights" as defined in Clause
|
||||
252.227-7013 (b) (3) of DFARs. Notwithstanding the foregoing, the
|
||||
authors grant the U.S. Government and others acting in its behalf
|
||||
permission to use and distribute the software in accordance with the
|
||||
terms specified in this license.
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
This software is copyrighted by the Regents of the University of
|
||||
California, Sun Microsystems, Inc., Scriptics Corporation, ActiveState
|
||||
Corporation, Apple Inc. and other parties. The following terms apply to
|
||||
all files associated with the software unless explicitly disclaimed in
|
||||
individual files.
|
||||
|
||||
The authors hereby grant permission to use, copy, modify, distribute,
|
||||
and license this software and its documentation for any purpose, provided
|
||||
that existing copyright notices are retained in all copies and that this
|
||||
notice is included verbatim in any distributions. No written agreement,
|
||||
license, or royalty fee is required for any of the authorized uses.
|
||||
Modifications to this software may be copyrighted by their authors
|
||||
and need not follow the licensing terms described here, provided that
|
||||
the new terms are clearly indicated on the first page of each file where
|
||||
they apply.
|
||||
|
||||
IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
|
||||
FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
|
||||
ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
|
||||
DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
|
||||
POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
|
||||
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
|
||||
IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
|
||||
NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
|
||||
MODIFICATIONS.
|
||||
|
||||
GOVERNMENT USE: If you are acquiring this software on behalf of the
|
||||
U.S. government, the Government shall have only "Restricted Rights"
|
||||
in the software and related documentation as defined in the Federal
|
||||
Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
|
||||
are acquiring the software on behalf of the Department of Defense, the
|
||||
software shall be classified as "Commercial Computer Software" and the
|
||||
Government shall have only "Restricted Rights" as defined in Clause
|
||||
252.227-7013 (b) (3) of DFARs. Notwithstanding the foregoing, the
|
||||
authors grant the U.S. Government and others acting in its behalf
|
||||
permission to use and distribute the software in accordance with the
|
||||
terms specified in this license.
|
||||
|
|
@ -0,0 +1,21 @@
|
|||
xcopy binary_template xschem-%1-win64 /E/H/C/I
|
||||
cd xschem-%1-win64
|
||||
copy "C:\Program Files\Xschem\bin\Xschem.exe" bin
|
||||
copy "D:\Projects\XSchem\LICENSE" licenses
|
||||
mkdir doc
|
||||
cd doc
|
||||
xcopy "C:\Program Files\Xschem\doc" . /E/H/C/I
|
||||
cd ..
|
||||
mkdir share
|
||||
cd share
|
||||
xcopy "C:\Program Files\Xschem\share" . /E/H/C/I
|
||||
cd ..
|
||||
mkdir xschem_library
|
||||
cd xschem_library
|
||||
xcopy "C:\Program Files\Xschem\xschem_library" . /E/H/C/I
|
||||
cd ..
|
||||
cd ..
|
||||
tar.exe -a -c -f xschem-%1-win64.zip xschem-%1-win64
|
||||
rmdir /s /q xschem-%1-win64
|
||||
copy ..\XSchemWix\bin\Release\XSchem.msi .
|
||||
rename XSchem.msi XSchem-%1-64bit.msi
|
||||
|
|
@ -41,6 +41,7 @@ INSTRUCTIONS TO ADD XSCHEM TO VISUAL STUDIO 2019
|
|||
Optional:
|
||||
- Windows Ghostscript (to print)
|
||||
Update xschemrc to set variable to_pdf and to_png
|
||||
Add directory of gswin64.exe to PATH if installer didn't do it
|
||||
|
||||
2. Create new XSchemWin project on Visual Studio 2019
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<Wix xmlns="http://schemas.microsoft.com/wix/2006/wi">
|
||||
<Product Id="*" Name="Xschem" Language="1033" Version="2.9.9.6" Manufacturer="Xschem" UpgradeCode="0deb9c17-cbbd-491c-be3e-24446b27ccd5">
|
||||
<Product Id="*" Name="Xschem" Language="1033" Version="2.9.9.7" Manufacturer="Xschem" UpgradeCode="0deb9c17-cbbd-491c-be3e-24446b27ccd5">
|
||||
<Package InstallerVersion="200" Compressed="yes" InstallScope="perMachine" />
|
||||
<WixVariable Id="WixUILicenseRtf"
|
||||
Value="License.rtf" />
|
||||
|
|
|
|||
Loading…
Reference in New Issue