1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
|
#! /usr/bin/env tclsh
#==============================================================================
# Demonstrates how to implement a multi-entry widget for Ethernet addresses.
#
# Copyright (c) 1999-2023 Csaba Nemethi (E-mail: csaba.nemethi@t-online.de)
#==============================================================================
package require Tk
package require mentry_tile
set title "Ethernet Address"
wm title . $title
#
# Add some entries to the Tk option database
#
source [file join [file dirname [info script]] option_tile.tcl]
#------------------------------------------------------------------------------
# ethernetAddrMentry
#
# Creates a new mentry widget win that allows to display and edit Ethernet
# addresses. Sets the type attribute of the widget to EthernetAddr and returns
# the name of the newly created widget.
#------------------------------------------------------------------------------
proc ethernetAddrMentry {win args} {
#
# Create a mentry widget consisting of 6 entries of width
# 2, separated by colons, and set its type to EthernetAddr
#
eval [list mentry::mentry $win] $args
$win configure -body {2 : 2 : 2 : 2 : 2 : 2}
$win attrib type EthernetAddr
#
# Install automatic uppercase conversion and allow only hexadecimal
# digits in all entry components; use wcb::cbappend (or wcb::cbprepend)
# instead of wcb::callback in order to keep the wcb::checkEntryLen
# callback, registered by mentry::mentry for all entry components
#
for {set n 0} {$n < 6} {incr n} {
set w [$win entrypath $n]
wcb::cbappend $w before insert wcb::convStrToUpper \
{wcb::checkStrForRegExp {^[0-9A-F]*$}}
$win adjustentry $n "0123456789ABCDEF"
bindtags $w [linsert [bindtags $w] 1 MentryEthernetAddr]
}
return $win
}
#------------------------------------------------------------------------------
# putEthernetAddr
#
# Outputs the Ethernet address addr to the mentry widget win of type
# EthernetAddr. The address must be a string of the form XX:XX:XX:XX:XX:XX,
# where each XX must be a hexadecimal string in the range 0 - 255. Leading
# zeros are allowed (but not required), hence the components may have more (but
# also less) than two characters; the procedure displays them with exactly two
# digits.
#------------------------------------------------------------------------------
proc putEthernetAddr {addr win} {
set errorMsg "expected an Ethernet address but got \"$addr\""
#
# Check the syntax of addr
#
set lst [split $addr :]
if {[llength $lst] != 6} {
return -code error $errorMsg
}
#
# Try to convert the 6 components of addr to hexadecimal
# strings and check whether they are in the range 0 - 255
#
for {set n 0} {$n < 6} {incr n} {
set val 0x[lindex $lst $n]
if {[catch {format "%02X" $val} str$n] != 0 || $val < 0 || $val > 255} {
return -code error $errorMsg
}
}
#
# Check the widget and display the properly formatted Ethernet address
#
checkIfEthernetAddrMentry $win
$win put 0 $str0 $str1 $str2 $str3 $str4 $str5
}
#------------------------------------------------------------------------------
# getEthernetAddr
#
# Returns the Ethernet address contained in the mentry widget win of type
# EthernetAddr.
#------------------------------------------------------------------------------
proc getEthernetAddr win {
#
# Check the widget
#
checkIfEthernetAddrMentry $win
#
# Generate an error if any entry component is empty
#
for {set n 0} {$n < 6} {incr n} {
if {[$win isempty $n]} {
focus [$win entrypath $n]
return -code error EMPTY
}
}
#
# Return the properly formatted Ethernet address built
# from the values contained in the entry components
#
$win getarray strs
return [format "%02X:%02X:%02X:%02X:%02X:%02X" \
0x$strs(0) 0x$strs(1) 0x$strs(2) 0x$strs(3) 0x$strs(4) 0x$strs(5)]
}
#------------------------------------------------------------------------------
# checkIfEthernetAddrMentry
#
# Generates an error if win is not a mentry widget of type EthernetAddr.
#------------------------------------------------------------------------------
proc checkIfEthernetAddrMentry win {
if {![winfo exists $win]} {
return -code error "bad window path name \"$win\""
}
if {[winfo class $win] ne "Mentry" ||
[$win attrib type] ne "EthernetAddr"} {
return -code error \
"window \"$win\" is not a mentry widget for Ethernet addresses"
}
}
bind MentryEthernetAddr <<Paste>> { pasteEthernetAddr %W }
#------------------------------------------------------------------------------
# pasteEthernetAddr
#
# Handles <<Paste>> events in the entry component w of a mentry widget for
# Ethernet addresses by pasting the current contents of the clipboard into the
# mentry if it is a valid Ethernet address.
#------------------------------------------------------------------------------
proc pasteEthernetAddr w {
set res [catch {::tk::GetSelection $w CLIPBOARD} addr]
if {$res == 0} {
set win [winfo parent [winfo parent $w]]
catch { putEthernetAddr $addr $win }
}
return -code break ""
}
#------------------------------------------------------------------------------
#
# Improve the window's appearance by using a tile
# frame as a container for the other widgets
#
ttk::frame .base
#
# Frame .base.f with a mentry displaying an Ethernet address
#
ttk::frame .base.f
ttk::label .base.f.l -text "A mentry widget for Ethernet addresses,\nwith\
automatic uppercase conversion:"
ethernetAddrMentry .base.f.me -justify center
pack .base.f.l .base.f.me
#
# Button .base.get invoking the procedure getEthernetAddr
#
ttk::button .base.get -text "Get from mentry" -command {
if {[catch {
set addr ""
set addr [getEthernetAddr .base.f.me]
}] != 0} {
bell
tk_messageBox -icon error -message "Field value missing" \
-title $title -type ok
}
}
#
# Label .base.addr displaying the result of getEthernetAddr
#
ttk::label .base.addr -textvariable addr
#
# Separator .sep and button .close
#
ttk::separator .base.sep -orient horizontal
ttk::button .base.close -text Close -command exit
#
# Manage the widgets
#
pack .base.close -side bottom -pady 7p
pack .base.sep -side bottom -fill x
pack .base.f -padx 7p -pady 7p
pack .base.get -padx 7p
pack .base.addr -padx 7p -pady 7p
pack .base -expand yes -fill both
putEthernetAddr 0:40:5:E4:99:26 .base.f.me
focus [.base.f.me entrypath 0]
|
