From: vanandel@rsf.atd.ucar.edu (Joe VanAndel)
Subject: validating the contents of entry fields.
Keywords: entry focus validate
Organization: NCAR/UCAR
Date: Thu, 16 Apr 1992 16:45:55 GMT

I've found an interesting way to validate entry fields.  Rather
than binding "focus" to events (like mouse button 1) that would ordinarily 
set the focus to a new entry widget, I bind my own routine, "new_focus", which
gives the entry widget a chance to validate its own contents, before giving up the focus.  A demo is attached.  Sorry for the length, but I had to pull in various support routines that I use.  It's also a nice demonstration of the power of arrays in TCL, since I use an array to remember the action to invoke when the focus is about to be changed.

#-----------------cut here---------------------------------------------
#!/localbin/wish -f

# demo for entry validation - in particular, examine procedures
# new_focus, and validate_range


#-------------------------------------------------------
# The procedures below provide behavior for widgets like
# entries and menus and menubuttons.  Eventually all of this
# behavior should be built into the widgets, so that this
# code becomes unnecessary.
#-------------------------------------------------------

proc bind_entry args {
    foreach w $args {
	bind $w <Any-KeyPress> {%W insert cursor "%A"}
	bind $w <space> {%W insert cursor " "}
#	bind $w <2> {print "character [%W index @%x]\n"}
	bind $w <Delete> {bs %W}
	bind $w <BackSpace> {bs %W}
	bind $w <Control-h> {bs %W}
	bind $w <1> {%W cursor @%x; new_focus %W; %W select from @%x}
	bind $w <B1-Motion> {%W select to @%x}
	bind $w <Shift-1> {%W select adjust @%x}
	bind $w <Shift-B1-Motion> {%W select to @%x}
	bind $w <3> {%W scan mark %x}
	bind $w <B3-Motion> {%W scan dragto %x}
	bind $w <Control-d> {%W delete sel.first sel.last}
	bind $w <Control-v> {%W insert cursor [selection get]}
	bind $w <Control-u> {%W delete 0 end}
    }
}
proc bind_num_entry args {
    foreach w $args {
	foreach key {+ - 0 1 2 3 4 5 6 7 8 9 } {
	    bind $w $key {%W insert cursor "%A"}
	}
#	bind $w <2> {print "character [%W index @%x]\n"}
	bind $w <Delete> {bs %W}
	bind $w <BackSpace> {bs %W}
	bind $w <Control-h> {bs %W}
	bind $w <1> {%W cursor @%x; new_focus %W; %W select from @%x}
	bind $w <B1-Motion> {%W select to @%x}
	bind $w <Shift-1> {%W select adjust @%x}
	bind $w <Shift-B1-Motion> {%W select to @%x}
	bind $w <3> {%W scan mark %x}
	bind $w <B3-Motion> {%W scan dragto %x}
	bind $w <Control-d> {%W delete sel.first sel.last}
	bind $w <Control-v> {%W insert cursor [selection get]}
	bind $w <Control-u> {%W delete 0 end}
    }
}


proc bs win {
    set x [expr {[$win index cursor] - 1}]
    if {$x != -1} {$win delete $x}
}
#

proc bind_numkey args {
    foreach w $args {
	bind $w <KP_Subtract> {%W insert cursor "-"}
	bind $w <KP_Add> {%W insert cursor "+"}

	bind $w <F27> {%W insert cursor "7"}
	bind $w <Up> {%W insert cursor "8"}
	bind $w <F29> {%W insert cursor "9"}

	bind $w <Left> {%W insert cursor "4"}
	bind $w <F31> {%W insert cursor "5"}
	bind $w <Right> {%W insert cursor "6"}

	bind $w <R13> {%W insert cursor "1"}
	bind $w <Down> {%W insert cursor "2"}
	bind $w <F35> {%W insert cursor "3"}

	bind $w <KP_1> {%W insert cursor "1"}
	bind $w <KP_2> {%W insert cursor "2"}
	bind $w <KP_3> {%W insert cursor "3"}
	bind $w <KP_4> {%W insert cursor "4"}
	bind $w <KP_5> {%W insert cursor "5"}
	bind $w <KP_6> {%W insert cursor "6"}
	bind $w <KP_7> {%W insert cursor "7"}
	bind $w <KP_8> {%W insert cursor "8"}
	bind $w <KP_9> {%W insert cursor "9"}
	bind $w <KP_Decimal> {%W insert cursor "."}
	
    }
}
#
# numeric key pad for Sun type 4 keypads
proc bind_intkey args {
    foreach w $args {

	bind $w <F27> {%W insert cursor "7"}
	bind $w <Up> {%W insert cursor "8"}
	bind $w <F29> {%W insert cursor "9"}

	bind $w <Left> {%W insert cursor "4"}
	bind $w <F31> {%W insert cursor "5"}
	bind $w <Right> {%W insert cursor "6"}

	bind $w <R13> {%W insert cursor "1"}
	bind $w <Down> {%W insert cursor "2"}
	bind $w <F35> {%W insert cursor "3"}

	bind $w <KP_1> {%W insert cursor "1"}
	bind $w <KP_2> {%W insert cursor "2"}
	bind $w <KP_3> {%W insert cursor "3"}
	bind $w <KP_4> {%W insert cursor "4"}
	bind $w <KP_5> {%W insert cursor "5"}
	bind $w <KP_6> {%W insert cursor "6"}
	bind $w <KP_7> {%W insert cursor "7"}
	bind $w <KP_8> {%W insert cursor "8"}
	bind $w <KP_9> {%W insert cursor "9"}
	
    }
}
proc key_show {w key} {
    print "$key pressed in $w\n"
}
proc tab_to {w next} {
#    print "tab from $w to $next\n"
    new_focus $next
}
# procedure called when focus is shifted to a new entry widget

proc new_focus {next_widget} {
    global LostFocusNotify
    set current [focus]
# verify that someone has the focus
    if { $current != "none" } then {
#	puts stderr "focus currently at $current"
# if the widget has registered a notification procedure,
# then invoke it
#
# if the notification procedure returns an error, we don't change the
# focus, since we want the user to correct the input error
#
	set notify_exists [catch {set LostFocusNotify($current)} notify_proc]
	if {$notify_exists == 0} then {
	    set valid [catch {eval $notify_proc $current}]
	    if {$valid != 0} {
# reset the focus, since we may have invoked a dialog
		focus $current	
		return
	    } 
	}
    }
# give up the focus to the new widget
    focus $next_widget
}



# build a window that only accepts integer input
proc mk_tlabel_int {w label next min max value} {
    upvar #0 $value x
    global LostFocusNotify
    frame $w -borderwidth 1

    pack append $w \
    [label $w.lbl -text $label ] {top} \
    [entry $w.e -relief sunken -width 2] {top }
    bind_num_entry $w.e
    bind $w.e <Return> "tab_to %W $next"
    bind $w.e <Tab> "tab_to %W $next"
    bind $w.e <KP_Enter> "tab_to %W $next"
    bind_intkey $w.e
    set LostFocusNotify($w.e) "validate_range $min $max $value"
    entry_set $w.e $x
    return $w

}
# validate that an parameter in an entry window is within the specified range,
# if NOT, restore a previous value
#
# we assume the passed variables are global
#
proc validate_range {theMin theMax theOldValue w} {
#    puts stdout "$theMin $theMax $theOldValue $w"
    upvar #0 $theMin min
    upvar #0 $theMax max
    upvar #0 $theOldValue oldValue
#    puts stdout "$min $max $oldValue $w"
    set new_value [$w get]
    if {$new_value < $min || $new_value >$max } then {
        warnDialog "$new_value invalid, must be in range $min..$max"
        entry_set $w $oldValue
        error "bad spacing value"
    }
    set oldValue [$w get]
}
# helper procedure to set the value of an entry widget
proc entry_set {entry_widget args} {
    $entry_widget delete 0 end
    $entry_widget insert 0 "$args"
}

#------------------------------------------------------------------------
# 	dialog.tk
#-----------------------------------------------------------------------
# Create a dialog box.  Takes three or more arguments.  The first is
# the name of the window to use for the dialog box.  The second is a set
# of arguments for use in creating the message of the dialog box.  The
# third and following arguments consist of two-element lists, each
# describing one button.  The first element gives the text to be displayed
# in the button, the second gives the command to be invoked when the
# button is invoked.
#
# example: 
#    mkDialog .confirm  [list -text "ARE YOU SURE " ]  {"YES"  really_yes } \
#    {NO really_no }
#
# NOTE: you can't just pass the message text itself, you must pass it as
# 	-text "the message text"
#


proc mkDialog {w msgArgs args} {
    catch {destroy $w}
    toplevel $w -class Dialog

    # Create two frames in the main window. The top frame will hold the
    # message and the bottom one will hold the buttons.  Arrange them
    # one above the other, with any extra vertical space split between
    # them.

    frame $w.top -relief raised -border 1
    frame $w.bot -relief raised -border 1
    pack append $w $w.top {top fill expand} $w.bot {top fill expand}
    
    # Create the message widget and arrange for it to be centered in the
    # top frame.
    
    eval message $w.top.msg -justify center \
	    -font -*-times-medium-r-normal--*-180* $msgArgs
    pack append $w.top $w.top.msg {top expand padx 5 pady 5}
    
    # Create as many buttons as needed and arrange them from left to right
    # in the bottom frame.  Embed the left button in an additional sunken
    # frame to indicate that it is the default button, and arrange for that
    # button to be invoked as the default action for clicks and returns in
    # the dialog.

    if {[llength $args] > 0} {
	set arg [lindex $args 0]
	frame $w.bot.0 -relief sunken -border 1
	pack append $w.bot $w.bot.0 {left expand padx 20 pady 20}
	button $w.bot.0.button -text [lindex $arg 0] \
		-command "[lindex $arg 1]; destroy $w"
	pack append $w.bot.0 $w.bot.0.button {expand padx 12 pady 12}
	bind $w.top <Enter> "$w.bot.0.button activate"
	bind $w.top.msg <Enter> "$w.bot.0.button activate"
	bind $w.bot <Enter> "$w.bot.0.button activate"
	bind $w.top <Leave> "$w.bot.0.button deactivate"
	bind $w.top.msg <Leave> "$w.bot.0.button deactivate"
	bind $w.bot <Leave> "$w.bot.0.button deactivate"
	bind $w <1> "$w.bot.0.button config -relief sunken"
	bind $w <ButtonRelease-1> \
		"[lindex $arg 1]; $w.bot.0.button deactivate; destroy $w"
	bind $w <Return> "[lindex $arg 1]; destroy $w"
	focus $w

	set i 1
	foreach arg [lrange $args 1 end] {
	    button $w.bot.$i -text [lindex $arg 0] \
		    -command "[lindex $arg 1]; destroy $w"
	    pack append $w.bot $w.bot.$i {left expand padx 20}
	    set i [expr $i+1]
	}
    }
    dialogPos $w
}
#
#
proc dialogPos {w {width 200} {height 200}} {
# get parent's location
    wm transient $w .
    wm deiconify $w
#    update
    set width [winfo reqwidth $w]
    set height [winfo reqheight $w]
    set swidth [winfo screenwidth $w]
    set sheight [winfo screenheight $w]


#    puts stderr "width=$width height = $height"
    set pw [winfo parent $w]
    set px [winfo rootx $pw]
    set py [winfo rooty $pw]
# get parent's size
    set pwidth [winfo width $pw]
    set pheight [winfo height $pw]
# calculate center of parent
#    set cx [expr {$px + ($pwidth / 2)}]
#    set cy [expr {$py + ($pheight / 2)}]
#    print "parent's center $cx $cy\n"
# calculate our upper left 
#    set x [expr {$cx - ($width  / 2)}]
#    set y [expr {$cy - ($height / 2)}]
    set x [expr "($swidth-$width)/2"]
    set y [expr "($sheight-$height)/2"]

#    print "our upper left $x $y"
    
    wm geometry $w +${x}+${y}
    update
# TWM seems to need this hint
    wm positionfrom $w user
# take the focus for ease of keyboard use
    focus $w
    wm group $w $pw
}
#--------------


# create a simple warning dialog, that the user just
# acknowledges

proc warnDialog {text} {
    mkDialog .warn [list -text $text]  {OK ""} 
}

#-------------------------------------------------------------

set E1Min 4
set E1Max 20
set E2Min 0
set E2Max 2000

set E1Value 5
set E2Value 10

pack append . \
	[label .label -text "entry validation demo" ] {top} \
	[mk_tlabel_int .e1 "Value 1" .e2.e E1Min E1Max E1Value ] {top fillx} \
	[mk_tlabel_int .e2 "Value 2" .e1.e E2Min E2Max E2Value ] {top fillx}

#----------------------------END-----------------------------------------

-- 
	Joe VanAndel  		Internet:vanandel@ncar.ucar.edu
	NCAR - ATD/RSF  			
	P.O Box 3000		Fax:	 303-497-2044
	Boulder, CO 80307-3000	Voice:	 303-497-2071