Tcl Library Source Code

Check-in [ed69e9893c]
Login
Core Home Blog Docs Downloads Tickets Timeline Branches Tags Wiki
Bounty program for improvements to Tcl and certain Tcl packages.

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

Overview
Comment:New version of nettool which allows for a central text-based pool of tcp ports
Timelines: family | ancestors | descendants | both | hypnotoad
Files: files | file ages | folders
SHA3-256: ed69e9893c22e30bc5cdf951d8b1c7c032bd59d24b488ee824b67f37696e94ce
User & Date: hypnotoad 2020-01-28 19:48:14
Context
2020-01-28
20:09
Nettool: Added an instruction for data to be ignored after a week, and provided a mechanism for a process to release all ports it claimed check-in: 441a5da4ea user: hypnotoad tags: hypnotoad
19:48
New version of nettool which allows for a central text-based pool of tcp ports check-in: ed69e9893c user: hypnotoad tags: hypnotoad
15:58
Added a binary encode to the uuid's random string generator to avoid embedded nulls terminating strings prematurely check-in: 08ccfd657e user: hypnotoad tags: hypnotoad
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to modules/nettool/build/build.tcl. 

1
2
3
4
5
6
7
8
9
10
11

set srcdir [file dirname [file normalize [file join [pwd] [info script]]]]
set moddir [file dirname $srcdir]

set version 0.5.3
set tclversion 8.5
set module [file tail $moddir]

proc ::ladd {varname args} {
  upvar 1 $varname var
  if ![info exists var] {
      set var {}



|








1
2
3
4
5
6
7
8
9
10
11

set srcdir [file dirname [file normalize [file join [pwd] [info script]]]]
set moddir [file dirname $srcdir]

set version 0.5.4
set tclversion 8.5
set module [file tail $moddir]

proc ::ladd {varname args} {
  upvar 1 $varname var
  if ![info exists var] {
      set var {}

Changes to modules/nettool/build/core.tcl. 

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

# @mdgen OWNER: available_ports.tcl
# @mdgen OWNER: locateport.tcl
# @mdgen OWNER: platform_unix_linux.tcl
# @mdgen OWNER: platform_unix_macosx.tcl
# @mdgen OWNER: platform_unix.tcl
# @mdgen OWNER: platform_windows.tcl


package require platform
# Uses the "ip" package from tcllib
package require ip

if {[info commands ::ladd] eq {}} {
  proc ::ladd {varname args} {
    upvar 1 $varname var
    if ![info exists var] {
        set var {}

    }
    foreach item $args {
      if {$item in $var} continue
      lappend var $item

    }
    return $var
  }
}
if {[info commands ::get] eq {}} {
  proc ::get varname {
    upvar 1 $varname var
    if {[info exists var]} {
      return [set var]
    }
    return {}
  }
}
if {[info commands ::cat] eq {}} {
  proc ::cat filename {
    set fin [open $filename r]
    set dat [read $fin]
    close $fin
    return $dat
  }
}


set here [file dirname [file normalize [info script]]]

::namespace eval ::nettool {}

set genus [lindex [split [::platform::generic] -] 0]
dict set ::nettool::platform tcl_os  $::tcl_platform(os)
dict set ::nettool::platform odie_class   $::tcl_platform(platform)
dict set ::nettool::platform odie_genus   $genus
dict set ::nettool::platform odie_target  [::platform::generic]
dict set ::nettool::platform odie_species [::platform::identify]









<




<
<
<
<
<
>
|
<
<
<
>
|
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
|
|
|
<
<
<
<
<
<










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

# @mdgen OWNER: available_ports.tcl
# @mdgen OWNER: locateport.tcl
# @mdgen OWNER: platform_unix_linux.tcl
# @mdgen OWNER: platform_unix_macosx.tcl
# @mdgen OWNER: platform_unix.tcl
# @mdgen OWNER: platform_windows.tcl


package require platform
# Uses the "ip" package from tcllib
package require ip






set here [file dirname [file normalize [info script]]]




::namespace eval ::nettool {}














proc ::nettool::cat filename {
  set fin [open $filename r]
  set dat [read $fin]
  close $fin
  return $dat
}







set genus [lindex [split [::platform::generic] -] 0]
dict set ::nettool::platform tcl_os  $::tcl_platform(os)
dict set ::nettool::platform odie_class   $::tcl_platform(platform)
dict set ::nettool::platform odie_genus   $genus
dict set ::nettool::platform odie_target  [::platform::generic]
dict set ::nettool::platform odie_species [::platform::identify]

Changes to modules/nettool/build/locateport.tcl. 

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





    if { $end <= $startingport } continue
    if { $start > $startingport } {
      set i $start
    } else {
      set i $startingport
    }
    for {} {$i <= $end} {incr i} {
      if {[string is true -strict [get ::nettool::used_ports($i)]]} continue
      if {[catch {socket -server NOOP $i} chan]} continue




      close $chan
      set ::nettool::used_ports($i) 1

      return $i
    }
  }
  error "Could not locate a port"
}

###
# topic: 3286fdbd0a3fdebbb26414475754bcf3dea67b0f
###
proc ::nettool::claim_port {port {protocol tcp}} {

  set ::nettool::used_ports($port) 1



}

###
# topic: 1d1f8a65a9aef8765c9b4f2b0ee0ebaf42e99d46
###
proc ::nettool::find_port startingport {
  foreach {start end} $::nettool::blocks {
................................................................................
    if { $end <= $startingport } continue
    if { $start > $startingport } {
      set i $start
    } else {
      set i $startingport
    }
    for {} {$i <= $end} {incr i} {
      if {[string is true -strict [get ::nettool::used_ports($i)]]} continue
      return $i
    }
  }
  error "Could not locate a port"
}

































###
# topic: ded1c51260e009effb1f77044f8d0dec3d030b91
###
proc ::nettool::port_busy port {



  ###
  # Check our private list of used ports
  ###
  if {[string is true -strict [get ::nettool::used_ports($port)]]} {
    return 1
  }
  foreach {start end} $::nettool::blocks {
    if { $port >= $start && $port <= $end } {
      return 0
    }
  }
................................................................................
  return 1
}

###
# topic: b5407b084aa09f9efa4f58a337af6186418fddf2
###
proc ::nettool::release_port {port {protocol tcp}} {

  set ::nettool::used_ports($port) 0


}












|
|
>
>
>
>

<
>










>
|
>
>
>







 







|





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





>
>
>



|







 







>
|
>
>
|
|
>
>
>
>

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

    if { $end <= $startingport } continue
    if { $start > $startingport } {
      set i $start
    } else {
      set i $startingport
    }
    for {} {$i <= $end} {incr i} {
      if {[port_busy $i]} continue
      if {[catch {socket -server NOOP $i} chan]} {
        dict set ::nettool::used_ports $port mtime [clock seconds]
        dict set ::nettool::used_ports $port pid   1
        continue
      }
      close $chan

      claim_port $i
      return $i
    }
  }
  error "Could not locate a port"
}

###
# topic: 3286fdbd0a3fdebbb26414475754bcf3dea67b0f
###
proc ::nettool::claim_port {port {protocol tcp}} {
  dict set ::nettool::used_ports $port mtime [clock seconds]
  dict set ::nettool::used_ports $port pid   [pid]
  if {[info exists ::nettool::syncfile]} {
    ::nettool::_sync_db $::nettool::syncfile
  }
}

###
# topic: 1d1f8a65a9aef8765c9b4f2b0ee0ebaf42e99d46
###
proc ::nettool::find_port startingport {
  foreach {start end} $::nettool::blocks {
................................................................................
    if { $end <= $startingport } continue
    if { $start > $startingport } {
      set i $start
    } else {
      set i $startingport
    }
    for {} {$i <= $end} {incr i} {
      if {[port_busy $i]} continue
      return $i
    }
  }
  error "Could not locate a port"
}

proc ::nettool::_sync_db {filename} {
  set mypid [pid]
  if {[file exists $filename]} {
    for {set x 0} {$x < 30} {incr x} {
      if {![file exists $filename.lock]} break
      set pid [string trim [cat $filename.lock]]
      if {$pid==$mypid} break
      after 250
    }
    set fout [open $filename.lock w]
    puts $fout $mypid
    close $fout
    set fin [open $filename r]
    while {[gets $fin line]>=0} {
      lassign $line port info
      # Ignore file entries attributed to my process id
      if {[dict exists $info pid] && [dict get $info pid] == $mypid} continue
      # Ignore attempts to update usage on ports I have allocated
      if {[dict exists $::nettool::used_ports $port pid] && [dict get $::nettool::used_ports $port pid] == $mypid} continue
      dict set ::nettool::used_ports $port $info
    }
    close $fin
  }
  set fout [open $filename w]
  set ports [lsort -integer [dict keys $::nettool::used_ports]]
  foreach port $ports {
    puts $fout [list $port [dict get $::nettool::used_ports $port]]
  }
  close $fout
  catch {file delete $filename.lock}
}

###
# topic: ded1c51260e009effb1f77044f8d0dec3d030b91
###
proc ::nettool::port_busy port {
  if {[info exists ::nettool::syncfile] && [file exists $::nettool::syncfile]} {
    ::nettool::_sync_db $::nettool::syncfile
  }
  ###
  # Check our private list of used ports
  ###
  if {[dict exists $::nettool::used_ports $port pid] && [dict get $::nettool::used_ports $port pid] > 0} {
    return 1
  }
  foreach {start end} $::nettool::blocks {
    if { $port >= $start && $port <= $end } {
      return 0
    }
  }
................................................................................
  return 1
}

###
# topic: b5407b084aa09f9efa4f58a337af6186418fddf2
###
proc ::nettool::release_port {port {protocol tcp}} {
  dict set ::nettool::used_ports $port mtime [clock seconds]
  dict set ::nettool::used_ports $port pid   0
  if {[info exists ::nettool::syncfile]} {
    ::nettool::_sync_db $::nettool::syncfile
  }
}

if {![info exists ::nettool::used_ports]} {
  set ::nettool::used_ports {}
}

Changes to modules/nettool/nettool.tcl. 

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
...
959
960
961
962
963
964
965
966
967




968
969

970
971
972
973
974
975
976
977
978
979

980



981
982
983
984
985
986
987
...
988
989
990
991
992
993
994
995
996
997
998
999
1000
































1001
1002
1003
1004
1005



1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
....
1017
1018
1019
1020
1021
1022
1023

1024


1025
1026




1027
1028
1029
1030
1031
1032
1033

###
# Amalgamated package for nettool
# Do not edit directly, tweak the source in src/ and rerun
# build.tcl
###
package require Tcl 8.5
package provide nettool 0.5.3
namespace eval ::nettool {}
set ::nettool::version 0.5.3

###
# START: core.tcl
###
# @mdgen OWNER: generic.tcl
# @mdgen OWNER: available_ports.tcl
# @mdgen OWNER: locateport.tcl
# @mdgen OWNER: platform_unix_linux.tcl
# @mdgen OWNER: platform_unix_macosx.tcl
# @mdgen OWNER: platform_unix.tcl
# @mdgen OWNER: platform_windows.tcl


package require platform
# Uses the "ip" package from tcllib
package require ip

if {[info commands ::ladd] eq {}} {
  proc ::ladd {varname args} {
    upvar 1 $varname var
    if ![info exists var] {
        set var {}

    }
    foreach item $args {
      if {$item in $var} continue
      lappend var $item

    }
    return $var
  }
}
if {[info commands ::get] eq {}} {
  proc ::get varname {
    upvar 1 $varname var
    if {[info exists var]} {
      return [set var]
    }
    return {}
  }
}
if {[info commands ::cat] eq {}} {
  proc ::cat filename {
    set fin [open $filename r]
    set dat [read $fin]
    close $fin
    return $dat
  }
}


set here [file dirname [file normalize [info script]]]

::namespace eval ::nettool {}

set genus [lindex [split [::platform::generic] -] 0]
dict set ::nettool::platform tcl_os  $::tcl_platform(os)
dict set ::nettool::platform odie_class   $::tcl_platform(platform)
dict set ::nettool::platform odie_genus   $genus
dict set ::nettool::platform odie_target  [::platform::generic]
dict set ::nettool::platform odie_species [::platform::identify]
................................................................................
    if { $end <= $startingport } continue
    if { $start > $startingport } {
      set i $start
    } else {
      set i $startingport
    }
    for {} {$i <= $end} {incr i} {
      if {[string is true -strict [get ::nettool::used_ports($i)]]} continue
      if {[catch {socket -server NOOP $i} chan]} continue




      close $chan
      set ::nettool::used_ports($i) 1

      return $i
    }
  }
  error "Could not locate a port"
}

###
# topic: 3286fdbd0a3fdebbb26414475754bcf3dea67b0f
###
proc ::nettool::claim_port {port {protocol tcp}} {

  set ::nettool::used_ports($port) 1



}

###
# topic: 1d1f8a65a9aef8765c9b4f2b0ee0ebaf42e99d46
###
proc ::nettool::find_port startingport {
  foreach {start end} $::nettool::blocks {
................................................................................
    if { $end <= $startingport } continue
    if { $start > $startingport } {
      set i $start
    } else {
      set i $startingport
    }
    for {} {$i <= $end} {incr i} {
      if {[string is true -strict [get ::nettool::used_ports($i)]]} continue
      return $i
    }
  }
  error "Could not locate a port"
}

































###
# topic: ded1c51260e009effb1f77044f8d0dec3d030b91
###
proc ::nettool::port_busy port {



  ###
  # Check our private list of used ports
  ###
  if {[string is true -strict [get ::nettool::used_ports($port)]]} {
    return 1
  }
  foreach {start end} $::nettool::blocks {
    if { $port >= $start && $port <= $end } {
      return 0
    }
  }
................................................................................
  return 1
}

###
# topic: b5407b084aa09f9efa4f58a337af6186418fddf2
###
proc ::nettool::release_port {port {protocol tcp}} {

  set ::nettool::used_ports($port) 0


}






###
# END: locateport.tcl
###
###
# START: platform_unix.tcl
###






|

|












<




<
<
<
<
<
>
|
<
<
<
>
|
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
|
|
|
<
<
<
<
<
<







 







|
|
>
>
>
>

<
>










>
|
>
>
>







 







|





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





>
>
>



|







 







>
|
>
>
|
|
>
>
>
>








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
...
933
934
935
936
937
938
939
940
941
942
943
944
945
946

947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
...
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
....
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057

###
# Amalgamated package for nettool
# Do not edit directly, tweak the source in src/ and rerun
# build.tcl
###
package require Tcl 8.5
package provide nettool 0.5.4
namespace eval ::nettool {}
set ::nettool::version 0.5.4

###
# START: core.tcl
###
# @mdgen OWNER: generic.tcl
# @mdgen OWNER: available_ports.tcl
# @mdgen OWNER: locateport.tcl
# @mdgen OWNER: platform_unix_linux.tcl
# @mdgen OWNER: platform_unix_macosx.tcl
# @mdgen OWNER: platform_unix.tcl
# @mdgen OWNER: platform_windows.tcl


package require platform
# Uses the "ip" package from tcllib
package require ip






set here [file dirname [file normalize [info script]]]




::namespace eval ::nettool {}














proc ::nettool::cat filename {
  set fin [open $filename r]
  set dat [read $fin]
  close $fin
  return $dat
}







set genus [lindex [split [::platform::generic] -] 0]
dict set ::nettool::platform tcl_os  $::tcl_platform(os)
dict set ::nettool::platform odie_class   $::tcl_platform(platform)
dict set ::nettool::platform odie_genus   $genus
dict set ::nettool::platform odie_target  [::platform::generic]
dict set ::nettool::platform odie_species [::platform::identify]
................................................................................
    if { $end <= $startingport } continue
    if { $start > $startingport } {
      set i $start
    } else {
      set i $startingport
    }
    for {} {$i <= $end} {incr i} {
      if {[port_busy $i]} continue
      if {[catch {socket -server NOOP $i} chan]} {
        dict set ::nettool::used_ports $port mtime [clock seconds]
        dict set ::nettool::used_ports $port pid   1
        continue
      }
      close $chan

      claim_port $i
      return $i
    }
  }
  error "Could not locate a port"
}

###
# topic: 3286fdbd0a3fdebbb26414475754bcf3dea67b0f
###
proc ::nettool::claim_port {port {protocol tcp}} {
  dict set ::nettool::used_ports $port mtime [clock seconds]
  dict set ::nettool::used_ports $port pid   [pid]
  if {[info exists ::nettool::syncfile]} {
    ::nettool::_sync_db $::nettool::syncfile
  }
}

###
# topic: 1d1f8a65a9aef8765c9b4f2b0ee0ebaf42e99d46
###
proc ::nettool::find_port startingport {
  foreach {start end} $::nettool::blocks {
................................................................................
    if { $end <= $startingport } continue
    if { $start > $startingport } {
      set i $start
    } else {
      set i $startingport
    }
    for {} {$i <= $end} {incr i} {
      if {[port_busy $i]} continue
      return $i
    }
  }
  error "Could not locate a port"
}

proc ::nettool::_sync_db {filename} {
  set mypid [pid]
  if {[file exists $filename]} {
    for {set x 0} {$x < 30} {incr x} {
      if {![file exists $filename.lock]} break
      set pid [string trim [cat $filename.lock]]
      if {$pid==$mypid} break
      after 250
    }
    set fout [open $filename.lock w]
    puts $fout $mypid
    close $fout
    set fin [open $filename r]
    while {[gets $fin line]>=0} {
      lassign $line port info
      # Ignore file entries attributed to my process id
      if {[dict exists $info pid] && [dict get $info pid] == $mypid} continue
      # Ignore attempts to update usage on ports I have allocated
      if {[dict exists $::nettool::used_ports $port pid] && [dict get $::nettool::used_ports $port pid] == $mypid} continue
      dict set ::nettool::used_ports $port $info
    }
    close $fin
  }
  set fout [open $filename w]
  set ports [lsort -integer [dict keys $::nettool::used_ports]]
  foreach port $ports {
    puts $fout [list $port [dict get $::nettool::used_ports $port]]
  }
  close $fout
  catch {file delete $filename.lock}
}

###
# topic: ded1c51260e009effb1f77044f8d0dec3d030b91
###
proc ::nettool::port_busy port {
  if {[info exists ::nettool::syncfile] && [file exists $::nettool::syncfile]} {
    ::nettool::_sync_db $::nettool::syncfile
  }
  ###
  # Check our private list of used ports
  ###
  if {[dict exists $::nettool::used_ports $port pid] && [dict get $::nettool::used_ports $port pid] > 0} {
    return 1
  }
  foreach {start end} $::nettool::blocks {
    if { $port >= $start && $port <= $end } {
      return 0
    }
  }
................................................................................
  return 1
}

###
# topic: b5407b084aa09f9efa4f58a337af6186418fddf2
###
proc ::nettool::release_port {port {protocol tcp}} {
  dict set ::nettool::used_ports $port mtime [clock seconds]
  dict set ::nettool::used_ports $port pid   0
  if {[info exists ::nettool::syncfile]} {
    ::nettool::_sync_db $::nettool::syncfile
  }
}

if {![info exists ::nettool::used_ports]} {
  set ::nettool::used_ports {}
}

###
# END: locateport.tcl
###
###
# START: platform_unix.tcl
###

Changes to modules/nettool/nettool.test. 

6
7
8
9
10
11
12












13
14
15
16
17
18
19
..
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
..
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

package require tcltest
testsNeedTcl     8.5
testsNeedTcltest 1.0

testing {
    useLocal nettool.tcl    nettool
}













# Test known busy ports
foreach port {
  80
  3020
  21
  7794
................................................................................
  7792 7793 {End of block}
  7793 7795 {Start of new block}
} {
  ::nettool::claim_port $port
  ::tcltest::test port-claim-0001 \
      "Test that port busy returns true after $port is claimed" \
      [list ::nettool::port_busy $port] 1
  
  # Test that claiming a port makes it busy
  ::tcltest::test port-find-0002 \
      "Test that port find returns the next port in unclaimed block starting at $port following claim" \
      [list ::nettool::find_port $port] $nextport

}

................................................................................
::tcltest::test port-claim-0002 \
    "Test that port busy returns true after $port is claimed" \
    [list ::nettool::port_busy $port] 1
::nettool::release_port $port
::tcltest::test port-claim-0003 \
    "Test that port busy returns false after $port is release" \
    [list ::nettool::port_busy $port] 0
  
# Test that claiming a port makes it busy
::tcltest::test port-find-0004 \
    "Test that port find returns the next port in released block starting at $port following claim" \
    [list ::nettool::find_port 7790] 7790

foreach {port nextport comment} {
  7790 7791 {Start of block}
  7791 7792 {...}
  7792 7793 {End of block}
  7793 7795 {Start of new block}
} {
  ::nettool::release_port $port 
}

# Test that claiming a port makes it busy
::tcltest::test port-allocate-0004 \
    "Test allocate port returns the address of an unclaimed spot and claims it" \
    [list ::nettool::allocate_port 7790] 7790

::tcltest::test port-allocate-0005 \
    "Test allocate port returns the next address of an claimed spot and claims it" \
    [list ::nettool::allocate_port 7790] 7791

::tcltest::test port-allocate-0006 \
    "Test allocate port returns the next address of an claimed spot and claims it" \
    [list ::nettool::allocate_port 7790] 7792








testsuiteCleanup
return







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







 







|







 







|











|













|

>
>
>
>
>
>




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
..
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
..
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

package require tcltest
testsNeedTcl     8.5
testsNeedTcltest 1.0

testing {
    useLocal nettool.tcl    nettool
}

set ::nettool::syncfile [file join  [file dirname [file join [pwd] [info script]]] sync.txt]
if {[file exists $::nettool::syncfile]} {
  file delete $::nettool::syncfile
}
# Seed the syncfile with data as if there was a process in paralleld
set fout [open $::nettool::syncfile w]
puts $fout [list 8805 [dict create pid 1 mtime [expr [clock seconds]-1800]]]
puts $fout [list 8806 [dict create pid 1 mtime [expr [clock seconds]-900]]]
puts $fout [list 8807 [dict create pid 1 mtime [expr [clock seconds]-900]]]

close $fout

# Test known busy ports
foreach port {
  80
  3020
  21
  7794
................................................................................
  7792 7793 {End of block}
  7793 7795 {Start of new block}
} {
  ::nettool::claim_port $port
  ::tcltest::test port-claim-0001 \
      "Test that port busy returns true after $port is claimed" \
      [list ::nettool::port_busy $port] 1

  # Test that claiming a port makes it busy
  ::tcltest::test port-find-0002 \
      "Test that port find returns the next port in unclaimed block starting at $port following claim" \
      [list ::nettool::find_port $port] $nextport

}

................................................................................
::tcltest::test port-claim-0002 \
    "Test that port busy returns true after $port is claimed" \
    [list ::nettool::port_busy $port] 1
::nettool::release_port $port
::tcltest::test port-claim-0003 \
    "Test that port busy returns false after $port is release" \
    [list ::nettool::port_busy $port] 0

# Test that claiming a port makes it busy
::tcltest::test port-find-0004 \
    "Test that port find returns the next port in released block starting at $port following claim" \
    [list ::nettool::find_port 7790] 7790

foreach {port nextport comment} {
  7790 7791 {Start of block}
  7791 7792 {...}
  7792 7793 {End of block}
  7793 7795 {Start of new block}
} {
  ::nettool::release_port $port
}

# Test that claiming a port makes it busy
::tcltest::test port-allocate-0004 \
    "Test allocate port returns the address of an unclaimed spot and claims it" \
    [list ::nettool::allocate_port 7790] 7790

::tcltest::test port-allocate-0005 \
    "Test allocate port returns the next address of an claimed spot and claims it" \
    [list ::nettool::allocate_port 7790] 7791

::tcltest::test port-allocate-0006 \
    "Test allocate port returns the next address of an claimed spot and claims it" \
    [list ::nettool::allocate_port 8805] 8808

# This should skip 7993 and 7994 because we seeded those in the txt file
::tcltest::test port-allocate-0007 \
    "Test allocate port returns the next address of an claimed spot and claims it" \
    [list ::nettool::allocate_port 8805] 8809

catch {file delete $::nettool::syncfile}

testsuiteCleanup
return

Changes to modules/nettool/pkgIndex.tcl. 

1
2
3
4
5
6

if {![package vsatisfies [package provide Tcl] 8.5]} {return}
# Backward compatible alias
package ifneeded nettool::available_ports 0.1 {package require nettool ; package provide nettool::available_ports 0.1}
package ifneeded nettool 0.5.3 [list source [file join $dir nettool.tcl]]





|


1
2
3
4
5
6

if {![package vsatisfies [package provide Tcl] 8.5]} {return}
# Backward compatible alias
package ifneeded nettool::available_ports 0.1 {package require nettool ; package provide nettool::available_ports 0.1}
package ifneeded nettool 0.5.4 [list source [file join $dir nettool.tcl]]

This page was generated in about 0.018s by Fossil 2.10 [eb804dc674] 2019-09-19 14:14:14