1 files changed, 185 insertions, 0 deletions
diff --git a/Master/tlpkg/tltcl/lib/tk8.6/demos/entry3.tcl b/Master/tlpkg/tltcl/lib/tk8.6/demos/entry3.tcl
new file mode 100644
index 00000000000..d4435c6125d
--- /dev/null
+++ b/Master/tlpkg/tltcl/lib/tk8.6/demos/entry3.tcl
@@ -0,0 +1,185 @@
+# entry3.tcl --
+#
+# This demonstration script creates several entry widgets whose
+# permitted input is constrained in some way.  It also shows off a
+# password entry.
+
+if {![info exists widgetDemo]} {
+    error "This script should be run from the \"widget\" demo."
+}
+
+package require Tk
+
+set w .entry3
+catch {destroy $w}
+toplevel $w
+wm title $w "Constrained Entry Demonstration"
+wm iconname $w "entry3"
+positionWindow $w
+
+label $w.msg -font $font -wraplength 5i -justify left -text "Four different\
+	entries are displayed below.  You can add characters by pointing,\
+	clicking and typing, though each is constrained in what it will\
+	accept.  The first only accepts 32-bit integers or the empty string\
+	(checking when focus leaves it) and will flash to indicate any\
+	problem.  The second only accepts strings with fewer than ten\
+	characters and sounds the bell when an attempt to go over the limit\
+	is made.  The third accepts US phone numbers, mapping letters to\
+	their digit equivalent and sounding the bell on encountering an\
+	illegal character or if trying to type over a character that is not\
+	a digit.  The fourth is a password field that accepts up to eight\
+	characters (silently ignoring further ones), and displaying them as\
+	asterisk characters."
+
+## See Code / Dismiss buttons
+set btns [addSeeDismiss $w.buttons $w]
+pack $btns -side bottom -fill x
+
+# focusAndFlash --
+# Error handler for entry widgets that forces the focus onto the
+# widget and makes the widget flash by exchanging the foreground and
+# background colours at intervals of 200ms (i.e. at approximately
+# 2.5Hz).
+#
+# Arguments:
+# W -		Name of entry widget to flash
+# fg -		Initial foreground colour
+# bg -		Initial background colour
+# count -	Counter to control the number of times flashed
+
+proc focusAndFlash {W fg bg {count 9}} {
+    focus -force $W
+    if {$count<1} {
+	$W configure -foreground $fg -background $bg
+    } else {
+	if {$count%2} {
+	    $W configure -foreground $bg -background $fg
+	} else {
+	    $W configure -foreground $fg -background $bg
+	}
+	after 200 [list focusAndFlash $W $fg $bg [expr {$count-1}]]
+    }
+}
+
+labelframe $w.l1 -text "Integer Entry"
+# Alternatively try using {string is digit} for arbitrary length numbers,
+# and not just 32-bit ones.
+entry $w.l1.e -validate focus -vcmd {string is integer %P}
+$w.l1.e configure -invalidcommand \
+	"focusAndFlash %W [$w.l1.e cget -fg] [$w.l1.e cget -bg]"
+pack $w.l1.e -fill x -expand 1 -padx 1m -pady 1m
+
+labelframe $w.l2 -text "Length-Constrained Entry"
+entry $w.l2.e -validate key -invcmd bell -vcmd {expr {[string length %P]<10}}
+pack $w.l2.e -fill x -expand 1 -padx 1m -pady 1m
+
+### PHONE NUMBER ENTRY ###
+# Note that the source to this is quite a bit longer as the behaviour
+# demonstrated is a lot more ambitious than with the others.
+
+# Initial content for the third entry widget
+set entry3content "1-(000)-000-0000"
+# Mapping from alphabetic characters to numbers.  This is probably
+# wrong, but it is the only mapping I have; the UK doesn't really go
+# for associating letters with digits for some reason.
+set phoneNumberMap {}
+foreach {chars digit} {abc 2 def 3 ghi 4 jkl 5 mno 6 pqrs 7 tuv 8 wxyz 9} {
+    foreach char [split $chars ""] {
+	lappend phoneNumberMap $char $digit [string toupper $char] $digit
+    }
+}
+
+# validatePhoneChange --
+# Checks that the replacement (mapped to a digit) of the given
+# character in an entry widget at the given position will leave a
+# valid phone number in the widget.
+#
+# W -	  The entry widget to validate
+# vmode - The widget's validation mode
+# idx -	  The index where replacement is to occur
+# char -  The character (or string, though that will always be
+#	  refused) to be overwritten at that point.
+
+proc validatePhoneChange {W vmode idx char} {
+    global phoneNumberMap entry3content
+    if {$idx == -1} {return 1}
+    after idle [list $W configure -validate $vmode -invcmd bell]
+    if {
+	!($idx<3 || $idx==6 || $idx==7 || $idx==11 || $idx>15) &&
+	[string match {[0-9A-Za-z]} $char]
+    } then {
+	$W delete $idx
+	$W insert $idx [string map $phoneNumberMap $char]
+	after idle [list phoneSkipRight $W -1]
+	return 1
+    }
+    return 0
+}
+
+# phoneSkipLeft --
+# Skip over fixed characters in a phone-number string when moving left.
+#
+# Arguments:
+# W -	The entry widget containing the phone-number.
+
+proc phoneSkipLeft {W} {
+    set idx [$W index insert]
+    if {$idx == 8} {
+	# Skip back two extra characters
+	$W icursor [incr idx -2]
+    } elseif {$idx == 7 || $idx == 12} {
+	# Skip back one extra character
+	$W icursor [incr idx -1]
+    } elseif {$idx <= 3} {
+	# Can't move any further
+	bell
+	return -code break
+    }
+}
+
+# phoneSkipRight --
+# Skip over fixed characters in a phone-number string when moving right.
+#
+# Arguments:
+# W -	The entry widget containing the phone-number.
+# add - Offset to add to index before calculation (used by validation.)
+
+proc phoneSkipRight {W {add 0}} {
+    set idx [$W index insert]
+    if {$idx+$add == 5} {
+	# Skip forward two extra characters
+	$W icursor [incr idx 2]
+    } elseif {$idx+$add == 6 || $idx+$add == 10} {
+	# Skip forward one extra character
+	$W icursor [incr idx]
+    } elseif {$idx+$add == 15 && !$add} {
+	# Can't move any further
+	bell
+	return -code break
+    }
+}
+
+labelframe $w.l3 -text "US Phone-Number Entry"
+entry $w.l3.e -validate key  -invcmd bell  -textvariable entry3content \
+	-vcmd {validatePhoneChange %W %v %i %S}
+# Click to focus goes to the first editable character...
+bind $w.l3.e <FocusIn> {
+    if {"%d" ne "NotifyAncestor"} {
+	%W icursor 3
+	after idle {%W selection clear}
+    }
+}
+bind $w.l3.e <<PrevChar>> {phoneSkipLeft  %W}
+bind $w.l3.e <<NextChar>> {phoneSkipRight %W}
+pack $w.l3.e -fill x -expand 1 -padx 1m -pady 1m
+
+labelframe $w.l4 -text "Password Entry"
+entry $w.l4.e -validate key -show "*" -vcmd {expr {[string length %P]<=8}}
+pack $w.l4.e -fill x -expand 1 -padx 1m -pady 1m
+
+lower [frame $w.mid]
+grid $w.l1 $w.l2 -in $w.mid -padx 3m -pady 1m -sticky ew
+grid $w.l3 $w.l4 -in $w.mid -padx 3m -pady 1m -sticky ew
+grid columnconfigure $w.mid {0 1} -uniform 1
+pack $w.msg -side top
+pack $w.mid -fill both -expand 1