Commit | Line | Data |
---|---|---|
920dae64 AT |
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 |