Tcl Library Source Code

Check-in [8f45d4f200]
Login
Core Home Blog Docs Downloads Tickets Timeline Branches Tags Wiki

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Updated nettool to utilize the latest TWAPI network API Replaced raw "puts" "flush" and "close" commands in udpcluster to utilize the chan ensemble version instead.
Timelines: family | ancestors | descendants | both | odie
Files: files | file ages | folders
SHA1: 8f45d4f20049c7daa926a8ab513cd363cea88130
User & Date: tne 2016-07-19 15:38:08
Context
2016-07-19
15:39
Merging changes from trunk check-in: b83ef84eec user: tne tags: odie
15:38
Updated nettool to utilize the latest TWAPI network API Replaced raw "puts" "flush" and "close" commands in udpcluster to utilize the chan ensemble version instead. check-in: 8f45d4f200 user: tne tags: odie
2016-07-07
13:19
TOOL's pipeline system now utilizes the coro::auto facilities to provide coroutine safe version of after,vwait, etc check-in: de8f0cfec7 user: tne tags: odie
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to modules/nettool/platform_windows.tcl.

︙︙
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

      lappend result [string map {- :} $macid] $ipaddr
    }
  }
  }
  return $result
}

###
# topic: 92ebbfa155883ad41c37d3f843392be4
# title: Return list of broadcast addresses for local networks
###
proc ::nettool::broadcast_list {} {
  set result {}
  lappend result 127.0.0.1
  foreach iface [::twapi::get_netif_indices] {
    set dat [::twapi::GetIpAddrTable $iface]
    foreach element $dat {
      foreach {addr ifindx netmask broadcast reamsize} $element break;
      lappend result [::ip::broadcastAddress $addr/$netmask]
    }
  }
  return [lsort -unique -dictionary $result]
}

###
# topic: 57fdc331bc60c7bf2bd3f3214e9a906f
###
proc ::nettool::hwaddr_to_ipaddr args {
  return [::twapi::hwaddr_to_ipaddr {*}$args]
}

###
# topic: dd2e2c0810cea69909399808f2a68949
# title: Return a list of unique hardware ids
###
proc ::nettool::hwid_list {} {
  # Use the serial number on the hard drive
  catch {exec {*}[auto_execok vol] c:} voldat
  set num [lindex [lindex [split $voldat \n] end] end]
  return 0x[string map {- {}} $num]
}


###
# topic: 4b87d977492bd10802bfc0327cd07ac2
# title: Return list of network interfaces
###
proc ::nettool::if_list {} {
  return [::twapi::get_netif_indices]
}

###
# topic: 417672d3f31b80d749588365af88baf6
# title: Return list of ip addresses for this computer (primary first)
###
set body {}
if {[::twapi::get_ip_addresses] ne {}} {
  set body {
  set result [::twapi::get_ip_addresses]
  ldelete result 127.0.0.1
  return $result
} 
} elseif {[info commands ::twapi::get_system_ipaddrs] ne {}} {
# They changed commands names on me...
  set body {
  set result [::twapi::get_system_ipaddrs]
  ldelete result 127.0.0.1
  return $result
}
}
proc ::nettool::ip_list {} $body
###
# topic: ac9d6815d47f60d45930f0c8c8ae8f16
# title: Return list of mac numbers for this computer (primary first)
###
proc ::nettool::mac_list {} {
  
  set result {}








<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<



















>








<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<








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

      lappend result [string map {- :} $macid] $ipaddr
    }
  }
  }
  return $result
}


















###
# topic: 57fdc331bc60c7bf2bd3f3214e9a906f
###
proc ::nettool::hwaddr_to_ipaddr args {
  return [::twapi::hwaddr_to_ipaddr {*}$args]
}

###
# topic: dd2e2c0810cea69909399808f2a68949
# title: Return a list of unique hardware ids
###
proc ::nettool::hwid_list {} {
  # Use the serial number on the hard drive
  catch {exec {*}[auto_execok vol] c:} voldat
  set num [lindex [lindex [split $voldat \n] end] end]
  return 0x[string map {- {}} $num]
}

if {[info command ::twapi::get_netif_indices] ne {}} {
###
# topic: 4b87d977492bd10802bfc0327cd07ac2
# title: Return list of network interfaces
###
proc ::nettool::if_list {} {
  return [::twapi::get_netif_indices]
}





















###
# topic: ac9d6815d47f60d45930f0c8c8ae8f16
# title: Return list of mac numbers for this computer (primary first)
###
proc ::nettool::mac_list {} {
  
  set result {}
︙︙
110
111
112
113
114
115
116













































































117
118
119
120
121
122
123

      set mask [::ip::maskToInt $netmask]
      set addri [::ip::toInteger $addr]
      lappend result [ip::nativeToPrefix [list [expr {$addri & $mask}] $netmask] -ipv4]    
    }
  }
  return [lsort -unique $result]
}














































































proc ::nettool::status {} {
  set result {}
  #dict set result load [::twapi::]
  set cpus [::twapi::get_processor_count]
  set usage 0
  for {set p 0} {$p < $cpus} {incr p} {








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>








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

      set mask [::ip::maskToInt $netmask]
      set addri [::ip::toInteger $addr]
      lappend result [ip::nativeToPrefix [list [expr {$addri & $mask}] $netmask] -ipv4]    
    }
  }
  return [lsort -unique $result]
}
} else {

if {[info commands ::twapi::get_network_adapters] ne {}} {
proc ::nettool::if_list {} {
  return [::twapi::get_network_adapters]
}
}

if {[info commands ::twapi::get_network_adapter_info] ne {}} {
proc ::nettool::mac_list {} {
  
  set result {}
  foreach iface [if_list] {
    set dat [::twapi::get_network_adapter_info $iface -physicaladdress]
    set addr [string map {- :} [lindex $dat 1]]
    if {[string length $addr] eq 0} continue
    if {[string range $addr 0 5] eq "00:00:"} continue
    lappend result $addr
  }
  return $result
}
  
proc ::nettool::network_list {} {
  set result {}
  foreach iface [if_list] {
    set dat [::twapi::get_network_adapter_info $iface -prefixes]
    foreach kvlist [lindex $dat 1] {
      if {![dict exists $kvlist -address]} continue
      if {![dict exists $kvlist -prefixlength]} continue
      set length [dict get $kvlist -prefixlength]
      if {$length>31} continue
      set address [dict get $kvlist -address]
      if {[string range $address 0 1] eq "ff"} continue
      lappend result $address/$length
    }
  }
  return [lsort -unique $result]
}

}
}


###
# topic: 92ebbfa155883ad41c37d3f843392be4
# title: Return list of broadcast addresses for local networks
###
proc ::nettool::broadcast_list {} {
  set result {}
  lappend result 127.0.0.1
  foreach net [network_list] {
    if {$net in {224.0.0.0/4 127.0.0.0/8}} continue
    lappend result [::ip::broadcastAddress $net]
  }
  return [lsort -unique -dictionary $result]
}
###
# topic: 417672d3f31b80d749588365af88baf6
# title: Return list of ip addresses for this computer (primary first)
###
set body {}
if {[info commands ::twapi::get_ip_addresses] ne {}} {
proc ::nettool::ip_list {} {
  set result [::twapi::get_ip_addresses]
  ldelete result 127.0.0.1
  return $result
}
} elseif {[info commands ::twapi::get_system_ipaddrs] ne {}} {
# They changed commands names on me...
proc ::nettool::ip_list {} {
  set result [::twapi::get_system_ipaddrs -version 4]
  ldelete result 127.0.0.1
  return $result
}
}



proc ::nettool::status {} {
  set result {}
  #dict set result load [::twapi::]
  set cpus [::twapi::get_processor_count]
  set usage 0
  for {set p 0} {$p < $cpus} {incr p} {
︙︙

Changes to modules/udpcluster/udpcluster.tcl.

︙︙
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

proc ::cluster::broadcast {args} {
  if {$::cluster::config(debug)} {
    puts [list $::cluster::local_pid SEND $args]
  }
  variable discovery_port
  listen
  while {[catch {

    foreach net [::nettool::broadcast_list] {
      if {$::cluster::config(debug)} {
        puts [list BROADCAST -> $net $args]
      }
      set s [udp_open]
      udp_conf $s $net $discovery_port
      puts -nonewline $s [list [pid] {*}$args]
      chan flush $s
      chan close $s
    }
    #set sock [listen]
    #puts -nonewline $sock [list [pid] {*}$args]
    #flush $sock
  } error]} {
    set ::cluster::broadcast_sock {}
    if {$::cluster::config(debug)} {
      puts "Broadcast ERR: $error - Reopening Socket"
      ::cluster::sleep 2000
    } else {
      # Double the delay








<






|



<
<
<








29
30
31
32
33
34
35

36
37
38
39
40
41
42
43
44
45



46
47
48
49
50
51
52

proc ::cluster::broadcast {args} {
  if {$::cluster::config(debug)} {
    puts [list $::cluster::local_pid SEND $args]
  }
  variable discovery_port
  listen
  while {[catch {

    foreach net [::nettool::broadcast_list] {
      if {$::cluster::config(debug)} {
        puts [list BROADCAST -> $net $args]
      }
      set s [udp_open]
      udp_conf $s $net $discovery_port
      chan puts -nonewline $s [list [pid] {*}$args]
      chan flush $s
      chan close $s
    }



  } error]} {
    set ::cluster::broadcast_sock {}
    if {$::cluster::config(debug)} {
      puts "Broadcast ERR: $error - Reopening Socket"
      ::cluster::sleep 2000
    } else {
      # Double the delay
︙︙
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122

  if {$directory_sock ne {}} {
    return [Directory {*}$args]
  }
  # We are not acting as the directory, query who is
  variable directory_port
  set sock [socket localhost $directory_port]
  chan configure $sock -translation crlf -buffering line -blocking 1
  puts $sock $args
  flush $sock
  update
  set reply {}
  while {[gets $sock line]>0} {
    append reply \n $line
    if {[::info complete $reply]} break
  }
  catch {close $sock}
  lassign $reply result errdat
  return $result {*}$errdat
}

###
# topic: 3f5f9e197cc9666dd7953d97fef34019
###








|
|


|



|








96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118

  if {$directory_sock ne {}} {
    return [Directory {*}$args]
  }
  # We are not acting as the directory, query who is
  variable directory_port
  set sock [socket localhost $directory_port]
  chan configure $sock -translation crlf -buffering line -blocking 1
  chan puts $sock $args
  chan flush $sock
  update
  set reply {}
  while {[chan gets $sock line]>0} {
    append reply \n $line
    if {[::info complete $reply]} break
  }
  catch {chan close $sock}
  lassign $reply result errdat
  return $result {*}$errdat
}

###
# topic: 3f5f9e197cc9666dd7953d97fef34019
###
︙︙
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193

    }
  }
  return $broadcast_sock
}

proc ::cluster::TCPAccept {sock host port} {
  chan configure $sock -translation {crlf crlf} -buffering line -blocking 1
  set packet [gets $sock]
  if {![string is ascii $packet]} return
  if {![::info complete $packet]} return
  if {[catch {Directory {*}$packet} reply errdat]} {
    puts $sock [list $reply $errdat]   
  } else {
    puts $sock [list $reply {}]
  }
  flush $sock
  close $sock
}
###
# topic: 2a33c825920162b0791e2cdae62e6164
###
proc ::cluster::UDPPacket sock {
  variable ptpdata
  set pid [pid]








|



|

|

|
|








166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189

    }
  }
  return $broadcast_sock
}

proc ::cluster::TCPAccept {sock host port} {
  chan configure $sock -translation {crlf crlf} -buffering line -blocking 1
  set packet [chan gets $sock]
  if {![string is ascii $packet]} return
  if {![::info complete $packet]} return
  if {[catch {Directory {*}$packet} reply errdat]} {
    chan puts $sock [list $reply $errdat]   
  } else {
    chan puts $sock [list $reply {}]
  }
  chan flush $sock
  chan close $sock
}
###
# topic: 2a33c825920162b0791e2cdae62e6164
###
proc ::cluster::UDPPacket sock {
  variable ptpdata
  set pid [pid]
︙︙

This page was generated in about 0.011s by Fossil 2.24 [f4ffefe708] 2024-04-17 14:02:19