1 | # entry2.tcl -- |
---|
2 | # |
---|
3 | # This demonstration script creates several entry widgets whose |
---|
4 | # permitted input is constrained in some way. It also shows off a |
---|
5 | # password entry. |
---|
6 | # |
---|
7 | # RCS: @(#) $Id: entry3.tcl,v 1.1 2001/11/19 14:02:29 dkf Exp $ |
---|
8 | |
---|
9 | if {![info exists widgetDemo]} { |
---|
10 | error "This script should be run from the \"widget\" demo." |
---|
11 | } |
---|
12 | |
---|
13 | set w .entry3 |
---|
14 | catch {destroy $w} |
---|
15 | toplevel $w |
---|
16 | wm title $w "Constrained Entry Demonstration" |
---|
17 | wm iconname $w "entry3" |
---|
18 | positionWindow $w |
---|
19 | |
---|
20 | |
---|
21 | label $w.msg -font $font -wraplength 5i -justify left -text "Four different\ |
---|
22 | entries are displayed below. You can add characters by pointing,\ |
---|
23 | clicking and typing, though each is constrained in what it will\ |
---|
24 | accept. The first only accepts integers or the empty string\ |
---|
25 | (checking when focus leaves it) and will flash to indicate any\ |
---|
26 | problem. The second only accepts strings with fewer than ten\ |
---|
27 | characters and sounds the bell when an attempt to go over the limit\ |
---|
28 | is made. The third accepts US phone numbers, mapping letters to\ |
---|
29 | their digit equivalent and sounding the bell on encountering an\ |
---|
30 | illegal character or if trying to type over a character that is not\ |
---|
31 | a digit. The fourth is a password field that accepts up to eight\ |
---|
32 | characters (silently ignoring further ones), and displaying them as\ |
---|
33 | asterisk characters." |
---|
34 | |
---|
35 | frame $w.buttons |
---|
36 | button $w.buttons.dismiss -text Dismiss -command "destroy $w" |
---|
37 | button $w.buttons.code -text "See Code" -command "showCode $w" |
---|
38 | pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 |
---|
39 | |
---|
40 | |
---|
41 | # focusAndFlash -- |
---|
42 | # Error handler for entry widgets that forces the focus onto the |
---|
43 | # widget and makes the widget flash by exchanging the foreground and |
---|
44 | # background colours at intervals of 200ms (i.e. at approximately |
---|
45 | # 2.5Hz). |
---|
46 | # |
---|
47 | # Arguments: |
---|
48 | # W - Name of entry widget to flash |
---|
49 | # fg - Initial foreground colour |
---|
50 | # bg - Initial background colour |
---|
51 | # count - Counter to control the number of times flashed |
---|
52 | |
---|
53 | proc focusAndFlash {W fg bg {count 9}} { |
---|
54 | focus -force $W |
---|
55 | if {$count<1} { |
---|
56 | $W configure -foreground $fg -background $bg |
---|
57 | } else { |
---|
58 | if {$count%2} { |
---|
59 | $W configure -foreground $bg -background $fg |
---|
60 | } else { |
---|
61 | $W configure -foreground $fg -background $bg |
---|
62 | } |
---|
63 | after 200 [list focusAndFlash $W $fg $bg [expr {$count-1}]] |
---|
64 | } |
---|
65 | } |
---|
66 | |
---|
67 | labelframe $w.l1 -text "Integer Entry" |
---|
68 | entry $w.l1.e -validate focus -vcmd {string is integer %P} |
---|
69 | $w.l1.e configure -invalidcommand \ |
---|
70 | "focusAndFlash %W [$w.l1.e cget -fg] [$w.l1.e cget -bg]" |
---|
71 | pack $w.l1.e -fill x -expand 1 -padx 1m -pady 1m |
---|
72 | |
---|
73 | labelframe $w.l2 -text "Length-Constrained Entry" |
---|
74 | entry $w.l2.e -validate key -invcmd bell -vcmd {expr {[string length %P]<10}} |
---|
75 | pack $w.l2.e -fill x -expand 1 -padx 1m -pady 1m |
---|
76 | |
---|
77 | ### PHONE NUMBER ENTRY ### |
---|
78 | # Note that the source to this is quite a bit longer as the behaviour |
---|
79 | # demonstrated is a lot more ambitious than with the others. |
---|
80 | |
---|
81 | # Initial content for the third entry widget |
---|
82 | set entry3content "1-(000)-000-0000" |
---|
83 | # Mapping from alphabetic characters to numbers. This is probably |
---|
84 | # wrong, but it is the only mapping I have; the UK doesn't really go |
---|
85 | # for associating letters with digits for some reason. |
---|
86 | set phoneNumberMap {} |
---|
87 | foreach {chars digit} {abc 2 def 3 ghi 4 jkl 5 mno 6 pqrs 7 tuv 8 wxyz 9} { |
---|
88 | foreach char [split $chars ""] { |
---|
89 | lappend phoneNumberMap $char $digit [string toupper $char] $digit |
---|
90 | } |
---|
91 | } |
---|
92 | |
---|
93 | # validatePhoneChange -- |
---|
94 | # Checks that the replacement (mapped to a digit) of the given |
---|
95 | # character in an entry widget at the given position will leave a |
---|
96 | # valid phone number in the widget. |
---|
97 | # |
---|
98 | # W - The entry widget to validate |
---|
99 | # vmode - The widget's validation mode |
---|
100 | # idx - The index where replacement is to occur |
---|
101 | # char - The character (or string, though that will always be |
---|
102 | # refused) to be overwritten at that point. |
---|
103 | |
---|
104 | proc validatePhoneChange {W vmode idx char} { |
---|
105 | global phoneNumberMap entry3content |
---|
106 | if {$idx == -1} {return 1} |
---|
107 | after idle [list $W configure -validate $vmode -invcmd bell] |
---|
108 | if { |
---|
109 | !($idx<3 || $idx==6 || $idx==7 || $idx==11 || $idx>15) && |
---|
110 | [string match {[0-9A-Za-z]} $char] |
---|
111 | } then { |
---|
112 | $W delete $idx |
---|
113 | $W insert $idx [string map $phoneNumberMap $char] |
---|
114 | after idle [list phoneSkipRight $W -1] |
---|
115 | return 1 |
---|
116 | } |
---|
117 | return 0 |
---|
118 | } |
---|
119 | |
---|
120 | # phoneSkipLeft -- |
---|
121 | # Skip over fixed characters in a phone-number string when moving left. |
---|
122 | # |
---|
123 | # Arguments: |
---|
124 | # W - The entry widget containing the phone-number. |
---|
125 | |
---|
126 | proc phoneSkipLeft {W} { |
---|
127 | set idx [$W index insert] |
---|
128 | if {$idx == 8} { |
---|
129 | # Skip back two extra characters |
---|
130 | $W icursor [incr idx -2] |
---|
131 | } elseif {$idx == 7 || $idx == 12} { |
---|
132 | # Skip back one extra character |
---|
133 | $W icursor [incr idx -1] |
---|
134 | } elseif {$idx <= 3} { |
---|
135 | # Can't move any further |
---|
136 | bell |
---|
137 | return -code break |
---|
138 | } |
---|
139 | } |
---|
140 | |
---|
141 | # phoneSkipRight -- |
---|
142 | # Skip over fixed characters in a phone-number string when moving right. |
---|
143 | # |
---|
144 | # Arguments: |
---|
145 | # W - The entry widget containing the phone-number. |
---|
146 | # add - Offset to add to index before calculation (used by validation.) |
---|
147 | |
---|
148 | proc phoneSkipRight {W {add 0}} { |
---|
149 | set idx [$W index insert] |
---|
150 | if {$idx+$add == 5} { |
---|
151 | # Skip forward two extra characters |
---|
152 | $W icursor [incr idx 2] |
---|
153 | } elseif {$idx+$add == 6 || $idx+$add == 10} { |
---|
154 | # Skip forward one extra character |
---|
155 | $W icursor [incr idx] |
---|
156 | } elseif {$idx+$add == 15 && !$add} { |
---|
157 | # Can't move any further |
---|
158 | bell |
---|
159 | return -code break |
---|
160 | } |
---|
161 | } |
---|
162 | |
---|
163 | labelframe $w.l3 -text "US Phone-Number Entry" |
---|
164 | entry $w.l3.e -validate key -invcmd bell -textvariable entry3content \ |
---|
165 | -vcmd {validatePhoneChange %W %v %i %S} |
---|
166 | # Click to focus goes to the first editable character... |
---|
167 | bind $w.l3.e <FocusIn> { |
---|
168 | if {"%d" ne "NotifyAncestor"} { |
---|
169 | %W icursor 3 |
---|
170 | after idle {%W selection clear} |
---|
171 | } |
---|
172 | } |
---|
173 | bind $w.l3.e <Left> {phoneSkipLeft %W} |
---|
174 | bind $w.l3.e <Right> {phoneSkipRight %W} |
---|
175 | pack $w.l3.e -fill x -expand 1 -padx 1m -pady 1m |
---|
176 | |
---|
177 | labelframe $w.l4 -text "Password Entry" |
---|
178 | entry $w.l4.e -validate key -show "*" -vcmd {expr {[string length %P]<=8}} |
---|
179 | pack $w.l4.e -fill x -expand 1 -padx 1m -pady 1m |
---|
180 | |
---|
181 | lower [frame $w.mid] |
---|
182 | grid $w.l1 $w.l2 -in $w.mid -padx 3m -pady 1m -sticky ew |
---|
183 | grid $w.l3 $w.l4 -in $w.mid -padx 3m -pady 1m -sticky ew |
---|
184 | grid columnconfigure $w.mid {0 1} -uniform 1 |
---|
185 | pack $w.msg -side top |
---|
186 | pack $w.buttons -side bottom -fill x -pady 2m |
---|
187 | pack $w.mid -fill both -expand 1 |
---|