1408 lines
40 KiB
Tcl
1408 lines
40 KiB
Tcl
#==============================================================================
|
|
# Contains the implementation of the multi-entry widget.
|
|
#
|
|
# Structure of the module:
|
|
# - Namespace initialization
|
|
# - Public procedure
|
|
# - Private configuration procedures
|
|
# - Private procedures implementing the mentry widget command
|
|
# - Private callback procedures
|
|
# - Private procedures used in bindings
|
|
# - Private utility procedures
|
|
#
|
|
# Copyright (c) 1999-2004 Csaba Nemethi (E-mail: csaba.nemethi@t-online.de)
|
|
#==============================================================================
|
|
|
|
#
|
|
# Namespace initialization
|
|
# ========================
|
|
#
|
|
|
|
namespace eval mentry {
|
|
#
|
|
# The array configSpecs is used to handle configuration options. The
|
|
# names of its elements are the configuration options for the Mentry widget
|
|
# class. The value of an array element is either an alias name or a list
|
|
# containing the database name and class as well as an indicator specifying
|
|
# the widgets to which the option applies: c stands for all children
|
|
# (entries and labels), e for the entries only, f for the frame, and w for
|
|
# the widget itself.
|
|
#
|
|
# Command-Line Name {Database Name Database Class W}
|
|
# -----------------------------------------------------------------------
|
|
#
|
|
variable configSpecs
|
|
array set configSpecs {
|
|
-background {background Background e}
|
|
-bg -background
|
|
-body {body Body w}
|
|
-borderwidth {borderWidth BorderWidth f}
|
|
-bd -borderwidth
|
|
-cursor {cursor Cursor c}
|
|
-disabledbackground {disabledBackground DisabledBackground e}
|
|
-disabledforeground {disabledForeground DisabledForeground c}
|
|
-exportselection {exportSelection ExportSelection e}
|
|
-font {font Font c}
|
|
-foreground {foreground Foreground c}
|
|
-fg -foreground
|
|
-highlightbackground {highlightBackground HighlightBackground f}
|
|
-highlightcolor {highlightColor HighlightColor f}
|
|
-highlightthickness {highlightThickness HighlightThickness f}
|
|
-insertbackground {insertBackground Foreground e}
|
|
-insertborderwidth {insertBorderWidth BorderWidth e}
|
|
-insertofftime {insertOffTime OffTime e}
|
|
-insertontime {insertOnTime OnTime e}
|
|
-insertwidth {insertWidth InsertWidth e}
|
|
-invalidcommand {invalidCommand InvalidCommand e}
|
|
-invcmd -invalidcommand
|
|
-justify {justify Justify e}
|
|
-readonlybackground {readonlyBackground ReadonlyBackground e}
|
|
-relief {relief Relief f}
|
|
-selectbackground {selectBackground Foreground e}
|
|
-selectborderwidth {selectBorderWidth BorderWidth e}
|
|
-selectforeground {selectForeground Background e}
|
|
-show {show Show e}
|
|
-state {state State e}
|
|
-takefocus {takeFocus TakeFocus f}
|
|
-textvariable {textVariable Variable e}
|
|
-validate {validate Validate e}
|
|
-validatecommand {validateCommand ValidateCommand e}
|
|
-vcmd -validatecommand
|
|
}
|
|
|
|
#
|
|
# Extend the elements of the array configSpecs
|
|
#
|
|
proc extendConfigSpecs {} {
|
|
variable helpEntry
|
|
variable configSpecs
|
|
if {$::tk_version < 8.3} {
|
|
foreach opt {-invalidcommand -invcmd -validate
|
|
-validatecommand -vcmd} {
|
|
unset configSpecs($opt)
|
|
}
|
|
}
|
|
if {$::tk_version < 8.4} {
|
|
foreach opt {-disabledbackground -disabledforeground
|
|
-readonlybackground} {
|
|
unset configSpecs($opt)
|
|
}
|
|
}
|
|
|
|
#
|
|
# Append the default values of the configuration options
|
|
# of an invisible entry widget to the values of the
|
|
# corresponding elements of the array configSpecs
|
|
#
|
|
set helpEntry .__helpEntry
|
|
for {set n 0} {[winfo exists $helpEntry]} {incr n} {
|
|
set helpEntry .__helpEntry$n
|
|
}
|
|
entry $helpEntry
|
|
foreach configSet [$helpEntry configure] {
|
|
if {[llength $configSet] != 2} {
|
|
set opt [lindex $configSet 0]
|
|
if {[info exists configSpecs($opt)]} {
|
|
lappend configSpecs($opt) [lindex $configSet 3]
|
|
} elseif {[string compare $opt "-width"] == 0} {
|
|
lappend configSpecs(-body) [lindex $configSet 3]
|
|
}
|
|
}
|
|
}
|
|
}
|
|
extendConfigSpecs
|
|
|
|
variable configOpts [lsort [array names configSpecs]]
|
|
|
|
#
|
|
# Use a list to facilitate the handling of the command options
|
|
#
|
|
variable cmdOpts [list \
|
|
attrib cget clear configure entries entrycount \
|
|
entrylimit entrypath getarray getlist getstring \
|
|
isempty isfull labelcount labelpath labels put]
|
|
|
|
#
|
|
# Define some Mentry class bindings
|
|
#
|
|
bind Mentry <KeyPress> continue
|
|
bind Mentry <FocusIn> {
|
|
if {[string compare [focus -lastfor %W] %W] == 0} {
|
|
catch {mentry::tabToEntry [mentry::firstNormal %W]}
|
|
}
|
|
}
|
|
bind Mentry <Destroy> {
|
|
namespace delete mentry::ns%W
|
|
catch {rename ::%W ""}
|
|
}
|
|
|
|
#
|
|
# Define the binding tag MentryKeyNav
|
|
#
|
|
mwutil::defineKeyNav Mentry
|
|
|
|
#
|
|
# Define some bindings for the binding tag MentryEntry
|
|
#
|
|
bind MentryEntry <Control-Left> { mentry::tabToPrev %W }
|
|
bind MentryEntry <Control-Right> { mentry::tabToNext %W }
|
|
bind MentryEntry <Home> { mentry::goToHome %W }
|
|
bind MentryEntry <End> { mentry::goToEnd %W }
|
|
bind MentryEntry <Shift-Home> { mentry::selectToHome %W }
|
|
bind MentryEntry <Shift-End> { mentry::selectToEnd %W }
|
|
bind MentryEntry <BackSpace> { mentry::backSpace %W }
|
|
bind MentryEntry <KeyPress> { mentry::procLabelChars %W %A }
|
|
|
|
#
|
|
# Define some emacs-like key bindings for the binding tag MentryEntry
|
|
#
|
|
bind MentryEntry <Meta-b> {
|
|
if {!$tk_strictMotif} {
|
|
mentry::tabToPrev %W
|
|
}
|
|
}
|
|
bind MentryEntry <Meta-f> {
|
|
if {!$tk_strictMotif} {
|
|
mentry::tabToNext %W
|
|
}
|
|
}
|
|
bind MentryEntry <Control-a> {
|
|
if {!$tk_strictMotif} {
|
|
mentry::goToHome %W
|
|
}
|
|
}
|
|
bind MentryEntry <Control-e> {
|
|
if {!$tk_strictMotif} {
|
|
mentry::goToEnd %W
|
|
}
|
|
}
|
|
bind MentryEntry <Control-h> {
|
|
if {!$tk_strictMotif} {
|
|
mentry::backSpace %W
|
|
}
|
|
}
|
|
bind MentryEntry <Meta-d> {
|
|
if {!$tk_strictMotif} {
|
|
%W delete insert end
|
|
break
|
|
}
|
|
}
|
|
bind MentryEntry <Meta-BackSpace> {
|
|
if {!$tk_strictMotif} {
|
|
mentry::delToLeft %W
|
|
}
|
|
}
|
|
bind MentryEntry <Meta-Delete> {
|
|
if {!$tk_strictMotif} {
|
|
mentry::delToLeft %W
|
|
}
|
|
}
|
|
|
|
#
|
|
# Define some bindings for the binding tag MentryLabel
|
|
#
|
|
bind MentryLabel <Button-1> { mentry::labelButton1 %W }
|
|
}
|
|
|
|
#
|
|
# Public procedure
|
|
# ================
|
|
#
|
|
|
|
#------------------------------------------------------------------------------
|
|
# mentry::mentry
|
|
#
|
|
# Creates a new multi-entry widget whose name is specified as the first command-
|
|
# line argument, and configures it according to the options and their values
|
|
# given on the command line. Returns the name of the newly created widget.
|
|
#------------------------------------------------------------------------------
|
|
proc mentry::mentry args {
|
|
variable configSpecs
|
|
variable configOpts
|
|
|
|
if {[llength $args] == 0} {
|
|
mwutil::wrongNumArgs "mentry pathName ?options?"
|
|
}
|
|
|
|
#
|
|
# Create a frame of the class Mentry
|
|
#
|
|
set win [lindex $args 0]
|
|
if {[catch {
|
|
frame $win -class Mentry -container 0 -height 0 -width 0
|
|
} result] != 0} {
|
|
return -code error $result
|
|
}
|
|
|
|
#
|
|
# Create a namespace within the current one to hold the data of the widget
|
|
#
|
|
namespace eval ns$win {
|
|
#
|
|
# The folowing array holds various data for this widget
|
|
#
|
|
variable data
|
|
array set data {
|
|
entryCount 0
|
|
labelCount 0
|
|
maxEntryIdx -1
|
|
maxLabelIdx -1
|
|
}
|
|
|
|
#
|
|
# The following array is used to hold arbitrary
|
|
# attributes and their values for this widget
|
|
#
|
|
variable attribVals
|
|
}
|
|
|
|
#
|
|
# Initialize some further components of data
|
|
#
|
|
upvar ::mentry::ns${win}::data data
|
|
foreach opt $configOpts {
|
|
set data($opt) [lindex $configSpecs($opt) 3]
|
|
}
|
|
|
|
#
|
|
# Configure the widget according to the command-line
|
|
# arguments and to the available database options
|
|
#
|
|
if {[catch {
|
|
mwutil::configure $win configSpecs data mentry::doConfig \
|
|
[lrange $args 1 end] 1
|
|
} result] != 0} {
|
|
destroy $win
|
|
return -code error $result
|
|
}
|
|
|
|
#
|
|
# Move the original widget command into the current namespace
|
|
# and build a new widget procedure in the global one
|
|
#
|
|
rename ::$win $win
|
|
proc ::$win args [format {
|
|
if {[catch {mentry::mentryWidgetCmd %s $args} result] == 0} {
|
|
return $result
|
|
} else {
|
|
return -code error $result
|
|
}
|
|
} [list $win]]
|
|
|
|
return $win
|
|
}
|
|
|
|
#
|
|
# Private configuration procedures
|
|
# ================================
|
|
#
|
|
|
|
#------------------------------------------------------------------------------
|
|
# mentry::doConfig
|
|
#
|
|
# Applies the value val of the configuration option opt to the mentry widget
|
|
# win.
|
|
#------------------------------------------------------------------------------
|
|
proc mentry::doConfig {win opt val} {
|
|
variable helpEntry
|
|
variable configSpecs
|
|
upvar ::mentry::ns${win}::data data
|
|
|
|
#
|
|
# Apply the value to the widget(s) corresponding to the given option
|
|
#
|
|
switch [lindex $configSpecs($opt) 2] {
|
|
c {
|
|
#
|
|
# Apply the value to all children and save the
|
|
# properly formatted value of val in data($opt)
|
|
#
|
|
foreach w [winfo children $win] {
|
|
if {[regexp {^(Entry|Label)$} [winfo class $w]]} {
|
|
if {$opt == "-background"} {
|
|
$w configure $opt white
|
|
} else {
|
|
$w configure $opt $val
|
|
}
|
|
}
|
|
}
|
|
# danilo comentou as duas linhas abaixo, para não dar erro no cobol ao ser chamado duas vezes
|
|
# $helpEntry configure $opt $val
|
|
# set data($opt) [$helpEntry cget $opt]
|
|
}
|
|
|
|
e {
|
|
if {[string compare $opt "-textvariable"] == 0 &&
|
|
[string compare $val ""] != 0} {
|
|
#
|
|
# The text variable must be an array
|
|
#
|
|
global $val
|
|
if {[info exists $val] && ![array exists $val]} {
|
|
return -code error "variable \"$val\" isn't array"
|
|
}
|
|
|
|
#
|
|
# For each entry child, set the -textvariable configuration
|
|
# option of the entry to the corresponding array element
|
|
#
|
|
for {set n 0} {$n < $data(entryCount)} {incr n} {
|
|
[entryPath $win $n] configure $opt ${val}($n)
|
|
}
|
|
set data($opt) $val
|
|
} else {
|
|
#
|
|
# Apply the value to all entry children and save
|
|
# the properly formatted value of val in data($opt)
|
|
#
|
|
foreach w [entries $win] {
|
|
if {$opt == "-background"} {
|
|
$w configure $opt white
|
|
} else {
|
|
$w configure $opt $val
|
|
}
|
|
}
|
|
# danilo comentou as duas linhas abaixo, para nao dar erro no cobol ao ser chamado duas vezes
|
|
# a linha abaixo, não permite que seja alterada a cor do fundo do mentry
|
|
#$helpEntry configure $opt $val
|
|
#set data($opt) [$helpEntry cget $opt]
|
|
|
|
#
|
|
# Some options need special handling
|
|
#
|
|
if {[string compare $opt "-background"] == 0} {
|
|
if {$::tk_version < 8.4} {
|
|
set labelBg $val
|
|
} else {
|
|
switch $data(-state) {
|
|
normal {
|
|
set labelBg white
|
|
}
|
|
disabled {
|
|
set labelBg $data(-disabledbackground)
|
|
}
|
|
readonly {
|
|
set labelBg $data(-readonlybackground)
|
|
}
|
|
}
|
|
if {[string compare $labelBg ""] == 0} {
|
|
set labelBg $val
|
|
}
|
|
}
|
|
foreach w [labels $win] {
|
|
$w configure $opt white
|
|
}
|
|
|
|
#
|
|
# Set also the frame's background, because
|
|
# of the shadow colors of its 3-D border
|
|
#
|
|
$win configure $opt white
|
|
} elseif {[regexp \
|
|
{^-(disabledbackground|readonlybackground|state)$} \
|
|
$opt] && $::tk_version >= 8.4} {
|
|
switch $data(-state) {
|
|
normal {
|
|
set labelBg white
|
|
set labelState normal
|
|
}
|
|
disabled {
|
|
set labelBg $data(-disabledbackground)
|
|
set labelState disabled
|
|
}
|
|
readonly {
|
|
set labelBg $data(-readonlybackground)
|
|
set labelState normal
|
|
}
|
|
}
|
|
if {[string compare $labelBg ""] == 0} {
|
|
set labelBg white
|
|
}
|
|
foreach w [labels $win] {
|
|
#$w configure -background $labelBg -state $labelState
|
|
$w configure -background white -state $labelState
|
|
}
|
|
|
|
#
|
|
# Set also the frame's background, because
|
|
# of the shadow colors of its 3-D border
|
|
#
|
|
$win configure -background white
|
|
# $win configure -background $labelBg
|
|
}
|
|
}
|
|
}
|
|
|
|
f {
|
|
#
|
|
# Apply the value to the frame and save the
|
|
# properly formatted value of val in data($opt)
|
|
#
|
|
if {$opt == "-background"} {
|
|
$win configure $opt white
|
|
} else {
|
|
$win configure $opt $val
|
|
}
|
|
set data($opt) [$win cget $opt]
|
|
}
|
|
|
|
w {
|
|
if {[string compare $opt "-body"] == 0} {
|
|
createChildren $win $val
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# mentry::createChildren
|
|
#
|
|
# For each <width, text> pair given in the list body, the procedure creates an
|
|
# entry of the given width and a label displaying the given text, and defines
|
|
# some callbacks as well as bindings for the entry just created. All entries
|
|
# and labels are created as children of the frame win.
|
|
#------------------------------------------------------------------------------
|
|
proc mentry::createChildren {win body} {
|
|
variable configSpecs
|
|
variable configOpts
|
|
upvar ::mentry::ns${win}::data data
|
|
|
|
#
|
|
# Check the syntax of body before performing any changes
|
|
#
|
|
set argCount [llength $body]
|
|
if {$argCount == 0} {
|
|
return -code error "expected at least one entry child width"
|
|
}
|
|
foreach {width text} $body {
|
|
if {[catch {format "%d" $width}] != 0 || $width <= 0} {
|
|
return -code error "expected positive integer but got \"$width\""
|
|
}
|
|
}
|
|
|
|
#
|
|
# Destroy any existing children of the frame
|
|
#
|
|
foreach w [winfo children $win] {
|
|
if {[regexp {^(Entry|Label)$} [winfo class $w]]} {
|
|
destroy $w
|
|
}
|
|
}
|
|
|
|
set data(entryCount) [expr {($argCount + 1) / 2}]
|
|
set data(labelCount) [expr {$argCount / 2}]
|
|
set data(maxEntryIdx) [expr {$data(entryCount) - 1}]
|
|
set data(maxLabelIdx) [expr {$data(labelCount) - 1}]
|
|
|
|
set data(-body) {}
|
|
set n 0
|
|
foreach {width text} $body {
|
|
#
|
|
# Append the properly formatted value
|
|
# of width to the list data(-body)
|
|
#
|
|
lappend data(-body) [format "%d" $width]
|
|
|
|
#
|
|
# Create an entry of the given width within the frame win
|
|
#
|
|
set w [entryPath $win $n]
|
|
entry $w -borderwidth 0 -highlightthickness 0 \
|
|
-takefocus 0 -textvariable "" -width $width
|
|
pack $w -side left -expand 1 -fill both
|
|
|
|
#
|
|
# Apply to it the current configuration options
|
|
#
|
|
foreach opt $configOpts {
|
|
if {[string compare $opt "-textvariable"] == 0 &&
|
|
[string compare $data($opt) ""] != 0} {
|
|
upvar data($opt) val
|
|
if {$opt == "-background"} {
|
|
$w configure $opt white
|
|
} else {
|
|
$w configure $opt ${val}($n)
|
|
}
|
|
} elseif {[regexp {[ec]} [lindex $configSpecs($opt) 2]]} {
|
|
if {$opt == "-background"} {
|
|
$w configure $opt white
|
|
} else {
|
|
$w configure $opt $data($opt)
|
|
}
|
|
}
|
|
}
|
|
|
|
#
|
|
# Define some callbacks for the entry just created
|
|
#
|
|
wcb::callback $w before insert [list wcb::checkEntryLen $width]
|
|
wcb::callback $w after insert \
|
|
[list mentry::condTabToNext $width $win $n]
|
|
wcb::callback $w after motion \
|
|
[list mentry::condGoToNeighbor $win $n]
|
|
|
|
#
|
|
# Modify the list of binding tags of the entry
|
|
#
|
|
bindtags $w [list $w MentryEntry Entry [winfo toplevel $w] \
|
|
MentryKeyNav all]
|
|
|
|
if {$n == $data(labelCount)} {
|
|
break
|
|
}
|
|
|
|
#
|
|
# Append the value of text to the list data(-body)
|
|
#
|
|
lappend data(-body) $text
|
|
|
|
#
|
|
# Create a label displaying the given text within the frame win
|
|
#
|
|
set w [labelPath $win $n]
|
|
label $w -bitmap "" -borderwidth 0 -height 0 -highlightthickness 0 \
|
|
-image "" -padx 0 -pady 0 -takefocus 0 -text $text \
|
|
-textvariable "" -underline -1 -width 0 -wraplength 0
|
|
pack $w -side left -fill y
|
|
|
|
#
|
|
# Apply to it the current configuration options
|
|
#
|
|
foreach opt $configOpts {
|
|
if {[string compare [lindex $configSpecs($opt) 2] "c"] == 0 &&
|
|
[info exists data($opt)]} {
|
|
$w configure $opt $data($opt)
|
|
}
|
|
}
|
|
if {$::tk_version < 8.4} {
|
|
#$w configure -background $data(-background)
|
|
$w configure -background white
|
|
} else {
|
|
switch $data(-state) {
|
|
normal {
|
|
set labelBg white
|
|
set labelState normal
|
|
}
|
|
disabled {
|
|
set labelBg $data(-disabledbackground)
|
|
set labelState disabled
|
|
}
|
|
readonly {
|
|
set labelBg $data(-readonlybackground)
|
|
set labelState normal
|
|
}
|
|
}
|
|
if {[string compare $labelBg ""] == 0} {
|
|
set labelBg $data(-background)
|
|
}
|
|
|
|
$w configure -background white -state $labelState
|
|
# $w configure -background $labelBg -state $labelState
|
|
}
|
|
|
|
#
|
|
# Replace the binding tag Label with MentryLabel
|
|
# in the list of binding tags of the label
|
|
#
|
|
bindtags $w [lreplace [bindtags $w] 1 1 MentryLabel]
|
|
|
|
incr n
|
|
}
|
|
}
|
|
|
|
#
|
|
# Private procedures implementing the mentry widget command
|
|
# =========================================================
|
|
#
|
|
|
|
#------------------------------------------------------------------------------
|
|
# mentry::mentryWidgetCmd
|
|
#
|
|
# This procedure is invoked to process the Tcl command corresponding to a
|
|
# multi-entry widget.
|
|
#------------------------------------------------------------------------------
|
|
proc mentry::mentryWidgetCmd {win argList} {
|
|
variable cmdOpts
|
|
upvar ::mentry::ns${win}::data data
|
|
|
|
set argCount [llength $argList]
|
|
if {$argCount == 0} {
|
|
mwutil::wrongNumArgs "$win option ?arg arg ...?"
|
|
}
|
|
|
|
set cmd [mwutil::fullOpt "option" [lindex $argList 0] $cmdOpts]
|
|
switch $cmd {
|
|
attrib {
|
|
return [mwutil::attribSubCmd $win [lrange $argList 1 end]]
|
|
}
|
|
|
|
cget {
|
|
if {$argCount != 2} {
|
|
mwutil::wrongNumArgs "$win $cmd option"
|
|
}
|
|
|
|
#
|
|
# Return the value of the specified configuration option
|
|
#
|
|
variable configSpecs
|
|
set opt [mwutil::fullConfigOpt [lindex $argList 1] configSpecs]
|
|
return $data($opt)
|
|
}
|
|
|
|
clear {
|
|
if {$argCount < 2 || $argCount > 3} {
|
|
mwutil::wrongNumArgs "$win $cmd firstIndex ?lastIndex?"
|
|
}
|
|
|
|
set firstIdx [childIndex [lindex $argList 1] $data(maxEntryIdx)]
|
|
if {$argCount == 3} {
|
|
set lastIdx [childIndex [lindex $argList 2] $data(maxEntryIdx)]
|
|
} else {
|
|
set lastIdx $firstIdx
|
|
}
|
|
|
|
for {set n $firstIdx} {$n <= $lastIdx} {incr n} {
|
|
_[entryPath $win $n] delete 0 end
|
|
}
|
|
return ""
|
|
}
|
|
|
|
configure {
|
|
variable configSpecs
|
|
return [mwutil::configSubCmd $win configSpecs data \
|
|
mentry::doConfig [lrange $argList 1 end]]
|
|
}
|
|
|
|
entries {
|
|
if {$argCount != 1} {
|
|
mwutil::wrongNumArgs "$win $cmd"
|
|
}
|
|
|
|
return [entries $win]
|
|
}
|
|
|
|
entrycount {
|
|
if {$argCount != 1} {
|
|
mwutil::wrongNumArgs "$win $cmd"
|
|
}
|
|
|
|
return $data(entryCount)
|
|
}
|
|
|
|
entrylimit {
|
|
if {$argCount != 2} {
|
|
mwutil::wrongNumArgs "$win $cmd index"
|
|
}
|
|
|
|
set n [childIndex [lindex $argList 1] $data(maxEntryIdx)]
|
|
return [lindex $data(-body) [expr {$n * 2}]]
|
|
}
|
|
|
|
entrypath {
|
|
if {$argCount != 2} {
|
|
mwutil::wrongNumArgs "$win $cmd index"
|
|
}
|
|
|
|
set n [childIndex [lindex $argList 1] $data(maxEntryIdx)]
|
|
return [entryPath $win $n]
|
|
}
|
|
|
|
getarray {
|
|
if {$argCount != 2} {
|
|
mwutil::wrongNumArgs "$win $cmd array"
|
|
}
|
|
|
|
#
|
|
# The last argument must be an array
|
|
#
|
|
set varName [lindex $argList 1]
|
|
set _varName [list $varName]
|
|
if {[uplevel 2 info exists $_varName] &&
|
|
![uplevel 2 array exists $_varName]} {
|
|
return -code error "variable \"$varName\" isn't array"
|
|
}
|
|
|
|
upvar 2 $varName arr
|
|
for {set n 0} {$n < $data(entryCount)} {incr n} {
|
|
set arr($n) [[entryPath $win $n] get]
|
|
}
|
|
return ""
|
|
}
|
|
|
|
getlist {
|
|
if {$argCount != 1} {
|
|
mwutil::wrongNumArgs "$win $cmd"
|
|
}
|
|
|
|
set result {}
|
|
foreach w [entries $win] {
|
|
lappend result [$w get]
|
|
}
|
|
return $result
|
|
}
|
|
|
|
getstring {
|
|
if {$argCount != 1} {
|
|
mwutil::wrongNumArgs "$win $cmd"
|
|
}
|
|
|
|
set result ""
|
|
foreach w [winfo children $win] {
|
|
switch [winfo class $w] {
|
|
Entry { append result [$w get] }
|
|
Label { append result [$w cget -text] }
|
|
}
|
|
}
|
|
return $result
|
|
}
|
|
|
|
isempty {
|
|
switch $argCount {
|
|
1 {
|
|
foreach w [entries $win] {
|
|
if {[string compare [$w get] ""] != 0} {
|
|
return 0
|
|
}
|
|
}
|
|
return 1
|
|
}
|
|
2 {
|
|
set n [childIndex [lindex $argList 1] $data(maxEntryIdx)]
|
|
set w [entryPath $win $n]
|
|
return [expr {[string compare [$w get] ""] == 0}]
|
|
}
|
|
default {
|
|
mwutil::wrongNumArgs "$win $cmd ?index?"
|
|
}
|
|
}
|
|
}
|
|
|
|
isfull {
|
|
switch $argCount {
|
|
1 {
|
|
for {set n 0} {$n < $data(entryCount)} {incr n} {
|
|
set w [entryPath $win $n]
|
|
set limit [lindex $data(-body) [expr {$n * 2}]]
|
|
if {[string length [$w get]] != $limit} {
|
|
return 0
|
|
}
|
|
}
|
|
return 1
|
|
}
|
|
2 {
|
|
set n [childIndex [lindex $argList 1] $data(maxEntryIdx)]
|
|
set w [entryPath $win $n]
|
|
set limit [lindex $data(-body) [expr {$n * 2}]]
|
|
return [expr {[string length [$w get]] == $limit}]
|
|
}
|
|
default {
|
|
mwutil::wrongNumArgs "$win $cmd ?index?"
|
|
}
|
|
}
|
|
}
|
|
|
|
labelcount {
|
|
if {$argCount != 1} {
|
|
mwutil::wrongNumArgs "$win $cmd"
|
|
}
|
|
|
|
return $data(labelCount)
|
|
}
|
|
|
|
labelpath {
|
|
if {$argCount != 2} {
|
|
mwutil::wrongNumArgs "$win $cmd index"
|
|
}
|
|
|
|
set n [childIndex [lindex $argList 1] $data(maxLabelIdx)]
|
|
return [labelPath $win $n]
|
|
}
|
|
|
|
labels {
|
|
if {$argCount != 1} {
|
|
mwutil::wrongNumArgs "$win $cmd"
|
|
}
|
|
|
|
return [labels $win]
|
|
}
|
|
|
|
put {
|
|
if {$argCount < 2} {
|
|
mwutil::wrongNumArgs "$win $cmd startIndex\
|
|
?string string ...?"
|
|
}
|
|
|
|
set startIdx [childIndex [lindex $argList 1] $data(maxEntryIdx)]
|
|
return [putSubCmd $win $startIdx [lrange $argList 2 end]]
|
|
}
|
|
|
|
}
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# mentry::putSubCmd
|
|
#
|
|
# This procedure is invoked to process the mentry put subcommand.
|
|
#------------------------------------------------------------------------------
|
|
proc mentry::putSubCmd {win startIdx strList} {
|
|
upvar ::mentry::ns${win}::data data
|
|
|
|
#
|
|
# If the focus is currently on one of win's children then set it
|
|
# temporarily to the top-level window containing win, to make sure
|
|
# that the after-insert callback condTabToNext will not change it
|
|
#
|
|
set focus [focus -displayof $win]
|
|
if {[string compare $focus ""] != 0 &&
|
|
[string compare [winfo parent $focus] $win] == 0} {
|
|
focus [winfo toplevel $win]
|
|
set focusChanged 1
|
|
} else {
|
|
set focusChanged 0
|
|
}
|
|
|
|
#
|
|
# Attempt to replace the texts of the entry children whose indices are
|
|
# >= startIdx with the given strings, until either the entries or the
|
|
# strings are consumed, by using the delete and insert operations; abort
|
|
# the loop if one of these subcommands is canceled by some before-callback
|
|
#
|
|
set undo 0
|
|
set n $startIdx
|
|
set oldStrings {}
|
|
set oldPositions {}
|
|
foreach str $strList {
|
|
if {$n == $data(entryCount)} {
|
|
break
|
|
}
|
|
|
|
set w [entryPath $win $n]
|
|
lappend oldStrings [$w get]
|
|
lappend oldPositions [$w index insert]
|
|
|
|
$w delete 0 end
|
|
if {[wcb::canceled $w delete]} {
|
|
set undo 1
|
|
break
|
|
}
|
|
|
|
$w insert 0 $str
|
|
if {[wcb::canceled $w insert]} {
|
|
set undo 1
|
|
break
|
|
}
|
|
|
|
incr n
|
|
}
|
|
|
|
#
|
|
# Restore the original contents of the entry children if necessary, and
|
|
# in any case restore the position of the insertion cursor in each entry
|
|
#
|
|
set n $startIdx
|
|
foreach oldStr $oldStrings oldPos $oldPositions {
|
|
set w [entryPath $win $n]
|
|
if {$undo} {
|
|
$w delete 0 end
|
|
$w insert 0 $oldStr
|
|
}
|
|
$w icursor $oldPos
|
|
|
|
incr n
|
|
}
|
|
|
|
#
|
|
# Reset the focus if needed and return the negation of $undo
|
|
#
|
|
if {$focusChanged} {
|
|
focus $focus
|
|
}
|
|
return [expr {!$undo}]
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# mentry::childIndex
|
|
#
|
|
# Checks the index n, rounds it to the nearest value between 0 and max, and
|
|
# returns either the rounded value or an error.
|
|
#------------------------------------------------------------------------------
|
|
proc mentry::childIndex {n max} {
|
|
if {[string first $n "end"] == 0} {
|
|
return $max
|
|
} elseif {[catch {format "%d" $n} index] != 0} {
|
|
return -code error \
|
|
"bad index \"$n\": must be end or a number"
|
|
} elseif {$index < 0} {
|
|
return 0
|
|
} elseif {$index > $max} {
|
|
return $max
|
|
} else {
|
|
return $index
|
|
}
|
|
}
|
|
|
|
#
|
|
# Private callback procedures
|
|
# ===========================
|
|
#
|
|
|
|
#------------------------------------------------------------------------------
|
|
# mentry::condTabToNext
|
|
#
|
|
# This after-insert callback checks whether the insertion cursor in the n'th
|
|
# entry child of the mentry widget win is just behind the character having the
|
|
# index width; if this is the case, it moves the focus to the next enabled
|
|
# entry child, selects the content of that widget, and sets the insertion
|
|
# cursor to its end.
|
|
#------------------------------------------------------------------------------
|
|
proc mentry::condTabToNext {width win n w idx str} {
|
|
if {[$w index insert] == $width &&
|
|
[string compare [focus -displayof $win] [entryPath $win $n]] == 0 &&
|
|
[string compare [set next [nextNormal $win $n]] ""] != 0} {
|
|
tabToEntry $next
|
|
}
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# mentry::condGoToNeighbor
|
|
#
|
|
# This after-motion callback examines the index idx passed to the last icursor
|
|
# command in the n'th entry child of the mentry widget win. If it was
|
|
# negative, the procedure clears the selection in the current entry widget,
|
|
# moves the focus to the previous enabled entry child, and sets the insertion
|
|
# cursor to the end of that widget; if it was greater than the index of the
|
|
# last character, the procedure clears the selection in the current entry
|
|
# widget, moves the focus to the next enabled entry child, and sets the
|
|
# insertion cursor to the beginning of that widget.
|
|
#------------------------------------------------------------------------------
|
|
proc mentry::condGoToNeighbor {win n w idx} {
|
|
if {![regexp {^[0-9-]+$} $idx] ||
|
|
[string compare [focus -displayof $win] [entryPath $win $n]] != 0} {
|
|
return ""
|
|
}
|
|
|
|
if {$idx < 0 &&
|
|
[string compare [set prev [prevNormal $win $n]] ""] != 0} {
|
|
$w selection clear
|
|
focus $prev
|
|
entrySetCursor $prev end
|
|
} elseif {$idx > [$w index end] &&
|
|
[string compare [set next [nextNormal $win $n]] ""] != 0} {
|
|
$w selection clear
|
|
focus $next
|
|
entrySetCursor $next 0
|
|
}
|
|
}
|
|
|
|
#
|
|
# Private procedures used in bindings
|
|
# ===================================
|
|
#
|
|
|
|
#------------------------------------------------------------------------------
|
|
# mentry::tabToPrev
|
|
#
|
|
# This procedure handles <Control-Left> events in the entry child w of a mentry
|
|
# widget. If possible, it moves the focus to the previous enabled entry child,
|
|
# selects the content of that widget, and sets the insertion cursor to its end;
|
|
# otherwise, it moves the insertion cursor to the beginning of the current
|
|
# entry and clears the selection in that widget.
|
|
#------------------------------------------------------------------------------
|
|
proc mentry::tabToPrev w {
|
|
parseChildPath $w win n
|
|
set prev [prevNormal $win $n]
|
|
if {[string compare $prev ""] != 0} {
|
|
tabToEntry $prev
|
|
} else {
|
|
entrySetCursor $w 0
|
|
}
|
|
return -code break ""
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# mentry::tabToNext
|
|
#
|
|
# This procedure handles <Control-Right> events in the entry child w of a
|
|
# mentry widget. If possible, it moves the focus to the next enabled entry
|
|
# child, selects the content of that widget, and sets the insertion cursor to
|
|
# its end; otherwise, it moves the insertion cursor to the end of the current
|
|
# entry and clears the selection in that widget.
|
|
#------------------------------------------------------------------------------
|
|
proc mentry::tabToNext w {
|
|
parseChildPath $w win n
|
|
set next [nextNormal $win $n]
|
|
if {[string compare $next ""] != 0} {
|
|
tabToEntry $next
|
|
} else {
|
|
entrySetCursor $w end
|
|
}
|
|
return -code break ""
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# mentry::goToHome
|
|
#
|
|
# This procedure handles <Home> events in the entry child w of a mentry widget.
|
|
# It clears the selection in the current entry, moves the focus to the first
|
|
# enabled entry child, and sets the insertion cursor to the beginning of that
|
|
# widget.
|
|
#------------------------------------------------------------------------------
|
|
proc mentry::goToHome w {
|
|
parseChildPath $w win n
|
|
set first [firstNormal $win]
|
|
$w selection clear
|
|
focus $first
|
|
catch {entrySetCursor $first 0}
|
|
return -code break ""
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# mentry::goToEnd
|
|
#
|
|
# This procedure handles <End> events in the entry child w of a mentry widget.
|
|
# It clears the selection in the current entry, moves the focus to the last
|
|
# enabled entry child, and sets the insertion cursor to the end of that widget.
|
|
#------------------------------------------------------------------------------
|
|
proc mentry::goToEnd w {
|
|
parseChildPath $w win n
|
|
set last [lastNormal $win]
|
|
$w selection clear
|
|
focus $last
|
|
catch {entrySetCursor $last end}
|
|
return -code break ""
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# mentry::selectToHome
|
|
#
|
|
# This procedure handles <Shift-Home> events in the entry child w of a mentry
|
|
# widget. It moves the focus to the first enabled entry child, sets the
|
|
# insertion cursor to the beginning of that widget, and either extends the
|
|
# selection to that position. or clears the selection in w and selects the
|
|
# contents of the new widget, depending upon whether the first enabled entry
|
|
# child equals w.
|
|
#------------------------------------------------------------------------------
|
|
proc mentry::selectToHome w {
|
|
parseChildPath $w win n
|
|
set first [firstNormal $win]
|
|
if {[string compare $first $w] != 0} {
|
|
$w selection clear
|
|
focus $first
|
|
catch {$first icursor end}
|
|
}
|
|
catch {
|
|
entryKeySelect $first 0
|
|
entryViewCursor $first
|
|
}
|
|
return -code break ""
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# mentry::selectToEnd
|
|
#
|
|
# This procedure handles <Shift-End> events in the entry child w of a mentry
|
|
# widget. It moves the focus to the last enabled entry child, sets the
|
|
# insertion cursor to the end of that widget, and either extends the
|
|
# selection to that position. or clears the selection in w and selects the
|
|
# contents of the new widget, depending upon whether the last enabled entry
|
|
# child equals w.
|
|
#------------------------------------------------------------------------------
|
|
proc mentry::selectToEnd w {
|
|
parseChildPath $w win n
|
|
set last [lastNormal $win]
|
|
if {[string compare $last $w] != 0} {
|
|
$w selection clear
|
|
focus $last
|
|
catch {$last icursor 0}
|
|
}
|
|
catch {
|
|
entryKeySelect $last end
|
|
entryViewCursor $last
|
|
}
|
|
return -code break ""
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# mentry::backSpace
|
|
#
|
|
# This procedure handles <BackSpace> events in the entry child w of a mentry
|
|
# widget. It deletes the selection if there is one in the entry. Otherwise,
|
|
# it deletes either the character to the left of the insertion cursor in the
|
|
# current entry, or the last character of the previous enabled entry child,
|
|
# depending upon the position of the insertion cursor. In the second case, it
|
|
# also moves the focus to the previous enabled entry child and sets the
|
|
# insertion cursor to its end.
|
|
#------------------------------------------------------------------------------
|
|
proc mentry::backSpace w {
|
|
parseChildPath $w win n
|
|
if {[$w selection present]} {
|
|
$w delete sel.first sel.last
|
|
} else {
|
|
if {[$w index insert] == 0 &&
|
|
[string compare [set prev [prevNormal $win $n]] ""] != 0} {
|
|
focus $prev
|
|
entrySetCursor $prev end
|
|
set w $prev
|
|
}
|
|
|
|
set x [expr {[$w index insert] - 1}]
|
|
if {$x >= 0} {
|
|
$w delete $x
|
|
}
|
|
if {[$w index insert] <= [$w index @0]} {
|
|
set range [$w xview]
|
|
set left [lindex $range 0]
|
|
set right [lindex $range 1]
|
|
$w xview moveto [expr {$left - ($right - $left)/2.0}]
|
|
}
|
|
}
|
|
return -code break ""
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# mentry::delToLeft
|
|
#
|
|
# This procedure handles <Meta-BackSpace> and <Meta-Delete> events in the entry
|
|
# child w of a mentry widget. It deletes either all characters to the left of
|
|
# the insertion cursor in the current entry, or the contents of the previous
|
|
# enabled entry child, depending upon the position of the insertion cursor. In
|
|
# the second case, it also clears the selection in the current entry widget and
|
|
# moves the focus to the previous enabled entry child.
|
|
#------------------------------------------------------------------------------
|
|
proc mentry::delToLeft w {
|
|
parseChildPath $w win n
|
|
if {[$w index insert] == 0 &&
|
|
[string compare [set prev [prevNormal $win $n]] ""] != 0} {
|
|
$w selection clear
|
|
focus $prev
|
|
$prev delete 0 end
|
|
} else {
|
|
$w delete 0 insert
|
|
}
|
|
return -code break ""
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# mentry::procLabelChars
|
|
#
|
|
# This procedure handles <KeyPress> events in the entry child w of a mentry
|
|
# widget. If this entry is non-empty and the character char corresponding to
|
|
# the event is contained in the text displayed in the label child following the
|
|
# entry (if any) then the procedure moves the focus to the next enabled entry
|
|
# child, selects the content of that widget, and sets the insertion cursor to
|
|
# its end.
|
|
#------------------------------------------------------------------------------
|
|
proc mentry::procLabelChars {w char} {
|
|
parseChildPath $w win n
|
|
set label [labelPath $win $n]
|
|
if {![winfo exists $label] ||
|
|
[string first $char [$label cget -text]] < 0} {
|
|
return ""
|
|
}
|
|
|
|
if {[string compare [$w get] ""] == 0} {
|
|
return -code break ""
|
|
}
|
|
|
|
set next [nextNormal $win $n]
|
|
if {[string compare $next ""] != 0} {
|
|
tabToEntry $next
|
|
}
|
|
return -code break ""
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# mentry::labelButton1
|
|
#
|
|
# This procedure handles <Button-1> events in the label child w of a mentry
|
|
# widget. It generates a <Button-1> event in the previous enabled entry child,
|
|
# after its last character.
|
|
#------------------------------------------------------------------------------
|
|
proc mentry::labelButton1 w {
|
|
parseChildPath $w win n
|
|
incr n
|
|
set entry [prevNormal $win $n]
|
|
if {[string compare $entry ""] != 0} {
|
|
set bbox [$entry bbox end]
|
|
set x [expr {[lindex $bbox 0] + [lindex $bbox 2]}]
|
|
event generate $entry <Button-1> -x $x
|
|
}
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# mentry::parseChildPath
|
|
#
|
|
# Extracts the path name of the mentry widget as well as the child's index from
|
|
# the path name w of a child of a mentry widget.
|
|
#------------------------------------------------------------------------------
|
|
proc mentry::parseChildPath {w winName indexName} {
|
|
upvar $winName win $indexName index
|
|
|
|
regexp {^(.+)\.[el]([0-9]+)$} $w dummy win index
|
|
}
|
|
|
|
#
|
|
# Private utility procedures
|
|
# ==========================
|
|
#
|
|
|
|
#------------------------------------------------------------------------------
|
|
# mentry::entryPath
|
|
#
|
|
# Returns the path name of the n'th entry child of the mentry widget win.
|
|
#------------------------------------------------------------------------------
|
|
proc mentry::entryPath {win n} {
|
|
return $win.e$n
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# mentry::labelPath
|
|
#
|
|
# Returns the path name of the n'th label child of the mentry widget win.
|
|
#------------------------------------------------------------------------------
|
|
proc mentry::labelPath {win n} {
|
|
return $win.l$n
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# mentry::entries
|
|
#
|
|
# Returns a list containing the path names of the entry children of the widget
|
|
# win.
|
|
#------------------------------------------------------------------------------
|
|
proc mentry::entries win {
|
|
set lst {}
|
|
foreach w [winfo children $win] {
|
|
if {[string compare [winfo class $w] "Entry"] == 0} {
|
|
lappend lst $w
|
|
}
|
|
}
|
|
return $lst
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# mentry::labels
|
|
#
|
|
# Returns a list containing the path names of the label children of the widget
|
|
# win.
|
|
#------------------------------------------------------------------------------
|
|
proc mentry::labels win {
|
|
set lst {}
|
|
foreach w [winfo children $win] {
|
|
if {[string compare [winfo class $w] "Label"] == 0} {
|
|
lappend lst $w
|
|
}
|
|
}
|
|
return $lst
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# mentry::prevNormal
|
|
#
|
|
# Returns the path name of the rightmost enabled entry child to the left of the
|
|
# n'th entry of the mentry widget win.
|
|
#------------------------------------------------------------------------------
|
|
proc mentry::prevNormal {win n} {
|
|
for {incr n -1} {$n >= 0} {incr n -1} {
|
|
set w [entryPath $win $n]
|
|
if {[string compare [$w cget -state] "normal"] == 0} {
|
|
return $w
|
|
}
|
|
}
|
|
return ""
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# mentry::nextNormal
|
|
#
|
|
# Returns the path name of the leftmost enabled entry child to the right of the
|
|
# n'th entry of the mentry widget win.
|
|
#------------------------------------------------------------------------------
|
|
proc mentry::nextNormal {win n} {
|
|
upvar ::mentry::ns${win}::data data
|
|
|
|
for {incr n} {$n < $data(entryCount)} {incr n} {
|
|
set w [entryPath $win $n]
|
|
if {[string compare [$w cget -state] "normal"] == 0} {
|
|
return $w
|
|
}
|
|
}
|
|
return ""
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# mentry::firstNormal
|
|
#
|
|
# Returns the path name of the first enabled entry child of the mentry widget
|
|
# win.
|
|
#------------------------------------------------------------------------------
|
|
proc mentry::firstNormal win {
|
|
return [nextNormal $win -1]
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# mentry::lastNormal
|
|
#
|
|
# Returns the path name of the last enabled entry child of the mentry widget
|
|
# win.
|
|
#------------------------------------------------------------------------------
|
|
proc mentry::lastNormal win {
|
|
upvar ::mentry::ns${win}::data data
|
|
return [prevNormal $win $data(entryCount)]
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# mentry::tabToEntry
|
|
#
|
|
# Moves the focus to the specified entry widget, selects its contents, and sets
|
|
# the insertion cursor to its end.
|
|
#------------------------------------------------------------------------------
|
|
proc mentry::tabToEntry w {
|
|
focus $w
|
|
$w selection range 0 end
|
|
$w icursor end
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# mentry::entrySetCursor
|
|
#
|
|
# Moves the insertion cursor to the specified position in the given entry
|
|
# widget, clears the selection, and makes sure that the insertion cursor is
|
|
# visible.
|
|
#------------------------------------------------------------------------------
|
|
proc mentry::entrySetCursor {w pos} {
|
|
$w icursor $pos
|
|
$w selection clear
|
|
entryViewCursor $w
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# mentry::entryViewCursor
|
|
#
|
|
# Makes sure that the insertion cursor in the specified entry is visible by
|
|
# adjusting the view if necessary.
|
|
#------------------------------------------------------------------------------
|
|
proc mentry::entryViewCursor w {
|
|
set c [$w index insert]
|
|
if {$c < [$w index @0] || $c > [$w index @[winfo width $w]]} {
|
|
$w xview $c
|
|
}
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# mentry::entryKeySelect
|
|
#
|
|
# Extends the selection to the specified position in the given entry widget and
|
|
# moves the insertion cursor to that position.
|
|
#------------------------------------------------------------------------------
|
|
proc mentry::entryKeySelect {w pos} {
|
|
if {[$w selection present]} {
|
|
$w selection adjust $pos
|
|
} else {
|
|
$w selection from insert
|
|
$w selection to $pos
|
|
}
|
|
|
|
$w icursor $pos
|
|
}
|