#==============================================================================
# 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
}