453 lines
14 KiB
Tcl
453 lines
14 KiB
Tcl
#==============================================================================
|
|
# Contains common Wcb procedures.
|
|
#
|
|
# Copyright (c) 1999-2005 Csaba Nemethi (E-mail: csaba.nemethi@t-online.de)
|
|
#==============================================================================
|
|
|
|
#
|
|
# Namespace initialization
|
|
# ========================
|
|
#
|
|
|
|
namespace eval wcb {
|
|
#
|
|
# Bind some cleanup operations to the <Destroy> event
|
|
# for all widgets having the binding tag WcbCleanup
|
|
#
|
|
bind WcbCleanup <Destroy> {
|
|
wcb::cleanup %W
|
|
}
|
|
}
|
|
|
|
#
|
|
# Basic procedures
|
|
# ================
|
|
#
|
|
|
|
#------------------------------------------------------------------------------
|
|
# wcb::callback
|
|
#
|
|
# Retrieves, sets, or removes the callbacks for the widget w, the argument
|
|
# when, and the command corresponding to option. when can be "before" or
|
|
# "after", and option can take one of the following values:
|
|
#
|
|
# - "insert", "delete", or "motion", for a Tk entry, tile entry, BWidget
|
|
# Entry, spinbox, tile combobox, text, or
|
|
# ctext widget;
|
|
# - "activate", for a listbox or tablelist widget;
|
|
# - "selset" or "selclear", for a listbox, tablelist, text, or
|
|
# ctext widget;
|
|
# - "activatecell", "cellselset", or
|
|
# "cellselclear", for a tablelist widget.
|
|
#
|
|
# If no arguments after the option parameter are specified, then the procedure
|
|
# just returns the current before- or after-callback list, respectively, for
|
|
# the given widget operation.
|
|
#
|
|
# Otherwise, if at least one of the arguments following the option parameter is
|
|
# a nonempty string, then:
|
|
#
|
|
# - if called for the first time for this widget with at least one nonempty
|
|
# argument following the option parameter, then it replaces the Tcl command
|
|
# w with a new procedure in which the execution of the widget operations
|
|
# associated with the above values of option is preceded by invocations of
|
|
# the corresponding before-callbacks and followed by calls to the
|
|
# corresponding after-callbacks, in the global scope;
|
|
# - it sets the callback list to the one built from these arguments and
|
|
# returns the new list.
|
|
#
|
|
# Otherwise (i.e. if all arguments following the option parameter are empty),
|
|
# then the procedure unregisters all the corresponding callbacks for the given
|
|
# widget and returns an empty string.
|
|
#
|
|
# When a callback is invoked, the name of the original Tcl command for the
|
|
# widget w as well as the command arguments are automatically appended to it as
|
|
# parameters.
|
|
#------------------------------------------------------------------------------
|
|
proc wcb::callback {w when option args} {
|
|
if {![winfo exists $w]} {
|
|
return -code error "bad window path name \"$w\""
|
|
}
|
|
|
|
if {[string first $when "before"] == 0} {
|
|
set when before
|
|
} elseif {[string first $when "after"] == 0} {
|
|
set when after
|
|
} else {
|
|
return -code error "bad argument \"$when\": must be before or after"
|
|
}
|
|
|
|
if {[catch {fullCallbackOpt $w $option} result] != 0} {
|
|
return -code error $result
|
|
}
|
|
set option $result
|
|
|
|
variable data
|
|
if {[llength $args] == 0} {
|
|
if {[info exists data($w-$when-$option)]} {
|
|
return $data($w-$when-$option)
|
|
} else {
|
|
return {}
|
|
}
|
|
} elseif {[areAllEmptyStrings $args]} {
|
|
catch {unset data($w-$when-$option)}
|
|
return ""
|
|
} else {
|
|
switch [winfo class $w] {
|
|
Entry -
|
|
TEntry -
|
|
Spinbox -
|
|
TCombobox {
|
|
set widgetCmd entryWidgetCmd
|
|
}
|
|
Listbox {
|
|
set widgetCmd listboxWidgetCmd
|
|
}
|
|
Tablelist {
|
|
set widgetCmd tablelistWidgetCmd
|
|
}
|
|
Text -
|
|
Ctext {
|
|
set widgetCmd textWidgetCmd
|
|
}
|
|
}
|
|
redefWidgetCmd $w $widgetCmd
|
|
return [set data($w-$when-$option) $args]
|
|
}
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# wcb::cbappend
|
|
#
|
|
# Appends the arguments represented by args to the current before- or after-
|
|
# callback list, respectively, for the given widget operation.
|
|
#------------------------------------------------------------------------------
|
|
proc wcb::cbappend {w when option args} {
|
|
if {[catch {callback $w $when $option} result] != 0} {
|
|
return -code error $result
|
|
}
|
|
|
|
eval lappend result $args
|
|
return [eval [list callback $w $when $option] $result]
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# wcb::cbprepend
|
|
#
|
|
# Prepends the arguments represented by args to the current before- or after-
|
|
# callback list, respectively, for the given widget operation.
|
|
#------------------------------------------------------------------------------
|
|
proc wcb::cbprepend {w when option args} {
|
|
if {[catch {callback $w $when $option} result] != 0} {
|
|
return -code error $result
|
|
}
|
|
|
|
set result [eval [list linsert $result 0] $args]
|
|
return [eval [list callback $w $when $option] $result]
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# wcb::cancel
|
|
#
|
|
# If invoked from a before-callback for a widget command, this procedure
|
|
# cancels the execution of that command and of the remaining callbacks, and
|
|
# calls script in the global scope.
|
|
#------------------------------------------------------------------------------
|
|
proc wcb::cancel {{script bell}} {
|
|
variable data
|
|
set data(canceled-[info level 1]) 1
|
|
|
|
if {[string compare $script ""] != 0} {
|
|
uplevel #0 $script
|
|
}
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# wcb::canceled
|
|
#
|
|
# Returns 1 if the most recent invocation of the widget operation correspondig
|
|
# to w and option has been aborted by some before-callback, and 0 otherwise.
|
|
#------------------------------------------------------------------------------
|
|
proc wcb::canceled {w option} {
|
|
if {![winfo exists $w]} {
|
|
return -code error "bad window path name \"$w\""
|
|
}
|
|
|
|
if {[catch {fullCallbackOpt $w $option} result] != 0} {
|
|
return -code error $result
|
|
}
|
|
set option $result
|
|
|
|
variable data
|
|
if {[info exists data($w-canceled-$option)]} {
|
|
return $data($w-canceled-$option)
|
|
} else {
|
|
return 0
|
|
}
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# wcb::extend
|
|
#
|
|
# If invoked from a before-callback for a widget command, this procedure
|
|
# appends the values given in args to the argument list of that command. The
|
|
# new argument list will be passed to the remaining callbacks for that command,
|
|
# too.
|
|
#------------------------------------------------------------------------------
|
|
proc wcb::extend args {
|
|
variable data
|
|
upvar 0 data(args-[info level 1]) var
|
|
eval lappend var $args
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# wcb::replace
|
|
#
|
|
# If invoked from a before-callback for a widget command, this procedure
|
|
# replaces the arguments having the indices first through last of that command
|
|
# with the values given in args. The new argument list will be passed to the
|
|
# remaining callbacks for that command, too. The arguments are numbered from 0.
|
|
#------------------------------------------------------------------------------
|
|
proc wcb::replace {first last args} {
|
|
variable data
|
|
upvar 0 data(args-[info level 1]) var
|
|
set var [eval [list lreplace $var $first $last] $args]
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# wvb::pathname
|
|
#
|
|
# Returns the path name of the widget corresponding to the Tcl command origCmd
|
|
# (which is supposed to be of the form "::_pathName").
|
|
#------------------------------------------------------------------------------
|
|
proc wcb::pathname origCmd {
|
|
return [string range $origCmd 3 end]
|
|
}
|
|
|
|
#
|
|
# Private procedures
|
|
# ==================
|
|
#
|
|
|
|
#------------------------------------------------------------------------------
|
|
# wcb::cleanup
|
|
#
|
|
# Unregisters all callbacks defined for w and deletes the Tcl command w.
|
|
#------------------------------------------------------------------------------
|
|
proc wcb::cleanup w {
|
|
variable data
|
|
foreach when {before after canceled} {
|
|
foreach option {insert delete motion activate selset selclear} {
|
|
catch {unset data($w-$when-$option)}
|
|
}
|
|
}
|
|
|
|
catch {rename ::$w ""}
|
|
catch {rename ::_$w ""} ;# necessary for tablelist widgets
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# wcb::fullCallbackOpt
|
|
#
|
|
# Returns the full callback option corresponding to the possibly abbreviated
|
|
# option opt.
|
|
#------------------------------------------------------------------------------
|
|
proc wcb::fullCallbackOpt {w opt} {
|
|
set opLen [string length $opt]
|
|
|
|
switch [winfo class $w] {
|
|
Entry -
|
|
TEntry -
|
|
Spinbox -
|
|
TCombobox {
|
|
if {[string first $opt "insert"] == 0} {
|
|
set opt insert
|
|
} elseif {[string first $opt "delete"] == 0} {
|
|
set opt delete
|
|
} elseif {[string first $opt "motion"] == 0} {
|
|
set opt motion
|
|
} else {
|
|
return -code error \
|
|
"bad option \"$opt\": must be insert, delete, or motion"
|
|
}
|
|
}
|
|
|
|
Listbox {
|
|
if {[string first $opt "activate"] == 0} {
|
|
set opt activate
|
|
} elseif {[string first $opt "selset"] == 0 && $opLen >= 4} {
|
|
set opt selset
|
|
} elseif {[string first $opt "selclear"] == 0 && $opLen >= 4} {
|
|
set opt selclear
|
|
} else {
|
|
return -code error \
|
|
"bad option \"$opt\": must be activate, selset, or\
|
|
selclear"
|
|
}
|
|
}
|
|
|
|
Tablelist {
|
|
if {[string compare $opt "activate"] == 0} {
|
|
set opt activate
|
|
} elseif {[string first $opt "selset"] == 0 && $opLen >= 4} {
|
|
set opt selset
|
|
} elseif {[string first $opt "selclear"] == 0 && $opLen >= 4} {
|
|
set opt selclear
|
|
} elseif {[string first $opt "activatecell"] == 0 && $opLen >= 9} {
|
|
set opt activatecell
|
|
} elseif {[string first $opt "cellselset"] == 0 && $opLen >= 8} {
|
|
set opt cellselset
|
|
} elseif {[string first $opt "cellselclear"] == 0 && $opLen >= 8} {
|
|
set opt cellselclear
|
|
} else {
|
|
return -code error \
|
|
"bad option \"$opt\": must be activate, selset,\
|
|
selclear, activatecell, cellselset, or cellselclear"
|
|
}
|
|
}
|
|
|
|
Text -
|
|
Ctext {
|
|
if {[string first $opt "insert"] == 0} {
|
|
set opt insert
|
|
} elseif {[string first $opt "delete"] == 0} {
|
|
set opt delete
|
|
} elseif {[string first $opt "motion"] == 0} {
|
|
set opt motion
|
|
} elseif {[string first $opt "selset"] == 0 && $opLen >= 4} {
|
|
set opt selset
|
|
} elseif {[string first $opt "selclear"] == 0 && $opLen >= 4} {
|
|
set opt selclear
|
|
} else {
|
|
return -code error \
|
|
"bad option \"$opt\": must be insert, delete, motion,\
|
|
selset, or selclear"
|
|
}
|
|
}
|
|
|
|
default {
|
|
return -code error \
|
|
"window \"$w\" is not a Tk entry, tile entry,\
|
|
BWidget Entry, spinbox, tile combobox,\
|
|
listbox, tablelist, text, or ctext widget"
|
|
}
|
|
}
|
|
|
|
return $opt
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# wcb::areAllEmptyStrings
|
|
#
|
|
# Returns 1 if all elements of the list lst are empty strings and 0 otherwise.
|
|
#------------------------------------------------------------------------------
|
|
proc wcb::areAllEmptyStrings lst {
|
|
foreach elem $lst {
|
|
if {[string compare $elem ""] != 0} {
|
|
return 0
|
|
}
|
|
}
|
|
|
|
return 1
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# wcb::redefWidgetCmd
|
|
#
|
|
# Renames the Tcl command w to _w, builds a new widget procedure w that invokes
|
|
# cmd, and appends WcbCleanup to the list of binding tags of the widget w.
|
|
#------------------------------------------------------------------------------
|
|
proc wcb::redefWidgetCmd {w cmd} {
|
|
if {[catch {rename ::$w ::_$w}] != 0} {
|
|
return ""
|
|
}
|
|
|
|
#
|
|
# If the command within the catch below returns an error, we
|
|
# will substitute all occurrences of ::_$w with $w. To this
|
|
# end we need a version of $w in which the characters |, *, +,
|
|
# ?, (, ., ^, $, \, [, {, }, ,, :, =, and ! are escaped, and
|
|
# another version in which the characters & and \ are escaped
|
|
# (to suppress the special processing of &, \0, \1, ..., \9).
|
|
#
|
|
regsub -all {\||\*|\+|\?|\(|\.|\^|\$|\\|\[|\{|\}|\,|\:|\=\!} $w {\\\0} w1
|
|
regsub -all {&|\\} $w {\\\0} w2
|
|
|
|
proc ::$w args [format {
|
|
if {[catch {wcb::%s %s $args} result] == 0} {
|
|
return $result
|
|
} else {
|
|
regsub -all -- %s $result %s result
|
|
return -code error $result
|
|
}
|
|
} $cmd [list $w] [list ::_$w1] [list $w2]]
|
|
|
|
bindtags $w [linsert [bindtags $w] end WcbCleanup]
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# wcb::processCmd
|
|
#
|
|
# Invokes the before-callbacks registered for the widget w and the command
|
|
# corresponding to wcbOp, then executes the script "::_w cmdOp argList", and
|
|
# finally invokes the after-callbacks.
|
|
#------------------------------------------------------------------------------
|
|
proc wcb::processCmd {w wcbOp cmdOp argList} {
|
|
variable data
|
|
set data($w-canceled-$wcbOp) 0
|
|
set orig [list ::_$w]
|
|
|
|
#
|
|
# Invoke the before-callbacks
|
|
#
|
|
if {[info exists data($w-before-$wcbOp)]} {
|
|
foreach cb $data($w-before-$wcbOp) {
|
|
if {[string compare $cb ""] != 0} {
|
|
#
|
|
# Set the two array elements that might be changed
|
|
# by cancel, extend, or replace, invoked (directly
|
|
# or indirectly) from within the callback
|
|
#
|
|
set cb [eval list $cb]
|
|
set cbScript [concat $cb $orig $argList]
|
|
set data(canceled-$cbScript) 0
|
|
set data(args-$cbScript) $argList
|
|
|
|
#
|
|
# Invoke the callback and get the new
|
|
# values of the two array elements
|
|
#
|
|
uplevel #0 $cb $orig $argList
|
|
set data($w-canceled-$wcbOp) $data(canceled-$cbScript)
|
|
set argList $data(args-$cbScript)
|
|
|
|
#
|
|
# Remove the two array elements
|
|
#
|
|
unset data(canceled-$cbScript)
|
|
unset data(args-$cbScript)
|
|
|
|
if {$data($w-canceled-$wcbOp)} {
|
|
return ""
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
#
|
|
# Execute the widget command
|
|
#
|
|
eval $orig $cmdOp $argList
|
|
|
|
#
|
|
# Invoke the after-callbacks
|
|
#
|
|
if {[info exists data($w-after-$wcbOp)]} {
|
|
foreach cb $data($w-after-$wcbOp) {
|
|
if {[string compare $cb ""] != 0} {
|
|
uplevel #0 $cb $orig $argList
|
|
}
|
|
}
|
|
}
|
|
}
|