While working on a kind of scheme for a file/directory syncronisation tool, I needed to identify a machine (computer) on the base of a flexible pattern using the MAC- or IP-Address or a hostname pattern.
Because of only needing this scheme on MS Windows I used the network API from TWAPI.
The source below is optimized for tcl 8.5 and needs to get changed for tcl 8.4 usage.
About the package machine interface:
The pattern styles:
AA-BB-CC-DD-EE-FF,
AA:BB:CC:DD:EE:FF,
A?:*:C?:D*:*:*F 192.68.0.2,
192.&255.&255.&255,
192.&92.0.&4,
192.*.*.*,
192.?8.0.? DummyHostname,
D*Host*,
D[au]mmyHost?meIf it makes sense to use patterns on a MAC-address was beyond the scope.
package provide machine 1.0;
package require twapi;
namespace eval ::machine {
variable macAddresses;
variable ipAddresses;
variable hostnames;
variable cache;
# returns the currently known MAC addresses
# belonging to network adapters with such a MAC address
#
proc macaddresses {} {
variable macAddresses;
if {[llength $macAddresses] == 0} {
# loop over the known network interface indices
#
set macAddresses [list];
foreach netifIndex [twapi::get_netif_indices] {
# query the network interface/adapter information
#
set netifInfo [twapi::get_netif_info $netifIndex \
-adapterdescription -physicaladdress -ipaddresses \
];
if {[string length [dict get $netifInfo -physicaladdress]] > 0} {
lappend macAddresses [dict get $netifInfo -physicaladdress];
}
}
}
return $macAddresses;
}
# returns the currently known IP addresses
# belonging to network adapters with such a MAC address
#
proc ipaddresses {} {
variable ipAddresses;
if {[llength $ipAddresses] == 0} {
# loop over the known network interface indices
#
set ipAddresses [list];
foreach netifIndex [twapi::get_netif_indices] {
# query the network interface/adapter information
#
set netifInfo [twapi::get_netif_info $netifIndex \
-adapterdescription -physicaladdress -ipaddresses \
];
if {[string length [dict get $netifInfo -physicaladdress]] > 0} {
lappend ipAddresses [lindex [dict get $netifInfo -ipaddresses] 0 0];
}
}
}
return $ipAddresses;
}
# returns the currently known hostnames retrieved from
# the IP addresses belonging to network adapters with such a MAC address
#
proc hostnames {} {
variable hostnames;
if {[llength $hostnames] == 0} {
# loop over the requestable IP addresses
#
set hostnames [list];
foreach ipAddress [ipaddresses] {
# translate the IP address into a hostname
#
lappend hostnames [twapi::address_to_hostname $ipAddress];
}
}
return $hostnames;
}
proc IsMacAddress {pattern testConditionsVar} {
upvar 1 $testConditionsVar testConditions;
# split the given MAC address pattern into its parts
#
set patternParts [split $pattern "-"];
set testConditions [list];
if {[llength $patternParts] != 6} {
set patternParts [split $pattern ":"];
if {[llength $patternParts] != 6} {
return 0;
}
}
# loop over the parts and test each MAC address part for being a valid
# part pattern to store generated if conditions per part pattern to be
# used in the MatchMacAddress procedure
#
set temp [list];
foreach patternPart $patternParts {
if {[string is xdigit -strict $patternPart] == 0} {
# part could be a glob-style pattern
#
if {([string length $patternPart] < 1) ||
([string length $patternPart] > 2) ||
([regexp -- {^(([[:xdigit:]]|\?){2}|(\*[[:xdigit:]])|([[:xdigit:]]\*)|\*)$} $patternPart] == 0)} {
return 0;
}
lappend temp [format {[string match -nocase {%s} $part] == 0} $patternPart];
} else {
# part could be a 2-Byte hexadecimal value
#
if {0x$patternPart > 0xFF} {
return 0;
}
lappend temp [format {0x$part == 0x%s} $patternPart];
}
}
set testConditions $temp;
return 1;
}
proc IsIpAddress {pattern testConditionsVar} {
upvar 1 $testConditionsVar testConditions;
# split the given IP address pattern into its parts
#
set patternParts [split $pattern "."];
set testConditions [list];
if {[llength $patternParts] != 4} {
return 0;
}
# loop over the parts and test each IP address part for being a valid
# part pattern to store generated if conditions per part pattern to be
# used in the MatchIpAddress procedure
#
set temp [list];
foreach patternPart $patternParts {
if {[string first "&" $patternPart] == -1} {
if {[string is integer -strict $patternPart] == 0} {
# part could be a glob style pattern
#
if {[regexp -- {^((2(\?{2}|\*))|(1?(\?{2}|\*))|(\d?(\?|\*))|(\*?\?{1,2}\*?)|(\?{3}|\*))$} $patternPart] == 0} {
return 0;
}
lappend temp [format \
{[string match -nocase {%s} $part] == 0} \
$patternPart \
];
} else {
# part could be an integer between 0 and 255
#
if {($patternPart < 0) || ($patternPart > 255)} {
return 0;
}
lappend temp [format {$part != %s} $patternPart];
}
} elseif {([string first "&" $patternPart] == 0) &&
([string is integer -strict $patternPart] == 1)} {
# part could be a logical-AND-mask pattern
#
set patternPart [string range $patternPart 1 end];
if {($patternPart < 0) || ($patternPart > 255)} {
return 0;
}
lappend temp [format {(%s & $part) != $part} $patternPart];
} else {
return 0;
}
}
set testConditions $temp;
return 1;
}
proc MatchMacAddress {macAddress testConditions} {
foreach splitChar {"-" ":"} {
set parts [split $macAddress $splitChar];
if {[llength $parts] == 6} {
return [MatchAddress $parts $testConditions];
}
}
return 0;
}
proc MatchIpAddress {ipAddress testConditions} {
set parts [split $ipAddress "."];
if {[llength $parts] != 4} {
return 0;
}
return [MatchAddress $parts $testConditions];
}
proc MatchAddress {address testConditions} {
foreach part $address testCondition $testConditions {
if $testCondition {
return 0;
}
}
return 1;
}
# identifies the machine using one of the following patterns:
#
# 1. MAC address glob-like pattern, like:
# AA-BB-CC-DD-EE-FF,
# AA:BB:CC:DD:EE:FF,
# A?:*:C?:D*:*:*F
#
# 2. IP address glob-like or logical-AND-mask pattern, like:
# 192.68.0.2,
# 192.&255.&255.&255,
# 192.&92.0.&4,
# 192.*.*.*,
# 192.?8.0.?
#
# 3. hostname glob pattern, like:
# DummyHostname,
# D*Host*,
# D[au]mmyHost?me
#
# all calls are cached using the given pattern and its result
#
proc identify {pattern} {
variable cache;
if {[info exists cache($pattern)] == 1} {
return $cache($pattern);
}
set testConditions [list];
if {[IsMacAddress $pattern testConditions] == 1} {
foreach macAddress [macaddresses] {
if {[MatchMacAddress $macAddress $testConditions] == 1} {
return [set cache($pattern) 1];
}
}
} elseif {[IsIpAddress $pattern testConditions] == 1} {
foreach ipAddress [ipaddresses] {
if {[MatchIpAddress $ipAddress $testConditions] == 1} {
return [set cache($pattern) 1];
}
}
} else {
foreach hostname [hostnames] {
if {[string match -nocase $pattern $hostname] == 1} {
return [set cache($pattern) 1];
}
}
}
return [set cache($pattern) 0];
}
# resets the internal cache for identification,
# MAC and IP addresses and hostnames
#
proc reset {} {
variable macAddresses;
variable ipAddresses;
variable hostnames;
variable cache;
set macAddresses [list];
set ipAddresses [list];
set hostnames [list];
array unset cache;
array set cache [list];
return;
}
reset;
namespace export -clear {[a-z]*};
namespace ensemble create ::machine;
};