Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Changes In Branch tcllib-1-19-rc-mix-hypnotoad-f91bd1308c Excluding Merge-Ins
This is equivalent to a diff from 5c8c025dc5 to df153cb3ea
|
2018-02-08
| ||
| 05:19 | Merged "mixing"-branch `tcllib-1-19-rc-mix-hypnotoad-f91bd1308c` into the release. Updated READMEs and generated documentation. check-in: 5addaf1406 user: aku tags: tcllib-1-19-rc | |
|
2018-02-07
| ||
| 19:45 | Merged [hypnotoad] commit [f91bd1308c] with release work and fixed it up (conflict resolution, missing bumps). Placed into a new "mixing"-branch which can be used as starting point for further fixes if necessary, as per results of a testsuite run. Or committed to the release. Closed-Leaf check-in: df153cb3ea user: aku tags: tcllib-1-19-rc-mix-hypnotoad-f91bd1308c | |
|
2018-02-03
| ||
| 05:22 | Reverting to a snapshot of udp cluster from IRM. The version that was checked in was not viable check-in: f91bd1308c user: hypnotoad tags: hypnotoad | |
|
2018-02-02
| ||
| 03:56 | Regenerated docs for accumulated changes. check-in: 5c8c025dc5 user: aku tags: tcllib-1-19-rc | |
| 03:48 | Merge to release RC: GN patches for doctools and markdown. check-in: a43c4df501 user: aku tags: tcllib-1-19-rc | |
Changes to examples/httpd/htdocs/index.md.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 |
* [Class httpd::server](server.md)
* [Class httpd::content](content.md)
* [Content Server](content.server.md)
* [Form handler](content.form.md)
* [File handler](content.file.md)
* [SCGI handler](content.scgi.md)
* [Proxy handler](content.proxy.md)
| > > > > > > > > | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
* [Class httpd::server](server.md)
* [Class httpd::content](content.md)
* [Content Server](content.server.md)
* [Form handler](content.form.md)
* [File handler](content.file.md)
* [SCGI handler](content.scgi.md)
* [Proxy handler](content.proxy.md)
_Upload Test_
<form action=/upload method="POST" enctype="multipart/form-data">
<input name=path />
<input type="file" name=filename />
<input type=submit />
</form>
|
Changes to examples/httpd/httpd.tcl.
1 2 3 4 5 6 7 8 | ### # "Simple" webserver example ### set DIR [file dirname [file normalize [info script]]] set DEMOROOT [file join $DIR htdocs] set tcllibroot [file normalize [file join $DIR .. ..]] set auto_path [linsert $auto_path 0 [file normalize [file join $tcllibroot modules]]] | < | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | ### # "Simple" webserver example ### set DIR [file dirname [file normalize [info script]]] set DEMOROOT [file join $DIR htdocs] set tcllibroot [file normalize [file join $DIR .. ..]] set auto_path [linsert $auto_path 0 [file normalize [file join $tcllibroot modules]]] package require httpd 4.1 ### # This script creates two toplevel domains: # * Hosting the tcllib embedded documentation as static content # * Hosting a local fossil mirror of the tcllib repository ### package require httpd |
| ︙ | ︙ | |||
63 64 65 66 67 68 69 |
#
# --Sean "The Hypnotoad" Woods
###
tool::class create httpd::content::fossil_node_scgi {
superclass httpd::content::scgi
method scgi_info {} {
| | | | | < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
#
# --Sean "The Hypnotoad" Woods
###
tool::class create httpd::content::fossil_node_scgi {
superclass httpd::content::scgi
method scgi_info {} {
set uri [my http_info get REQUEST_URI]
set prefix [my http_info get prefix]
set module [lindex [split $uri /] 2]
file mkdir ~/tmp
if {![info exists ::fossil_process($module)]} {
package require processman
package require nettool
set port [::nettool::allocate_port 40000]
set handle fossil:$port
set dbfiles [::fossil-list]
foreach file [lsort -dictionary $dbfiles] {
dict set result [file rootname [file tail $file]] $file
}
set dbfile [dict get $result $module]
if {![file exists $dbfile]} {
tailcall my error 400 {Not Found}
}
set mport [my <server> port_listening]
set cmd [list [::fossil] server $dbfile --port $port --localhost --scgi 2>~/tmp/$module.err >~/tmp/$module.log]
dict set ::fossil_process($module) port $port
dict set ::fossil_process($module) handle $handle
dict set ::fossil_process($module) cmd $cmd
dict set ::fossil_process($module) SCRIPT_NAME $prefix/$module
}
dict with ::fossil_process($module) {}
if {![::processman::running $handle]} {
set process [::processman::spawn $handle {*}$cmd]
my varname paused
after 500
}
return [list localhost $port $SCRIPT_NAME]
}
}
tool::class create ::docserver::server {
superclass ::httpd::server
method log args {
puts [list {*}$args]
}
}
tool::define ::docserver::dynamic {
method content {} {
my puts "<HTML><HEAD><TITLE>IRM Dispatch Server</TITLE></HEAD><BODY>"
my puts "<TABLE width=100%>"
foreach {f v} [my request dump] {
my puts "<tr><th>$f</th><td>$v</td></tr>"
}
my puts "<tr><td colspan=10><hr></td></tr>"
foreach {f v} [my http_info dump] {
my puts "<tr><th>$f</th><td>$v</td></tr>"
}
my puts "<tr><th>File Size</th><td>[my http_info get CONTENT_LENGTH]</td></tr>"
my puts </TABLE>
my puts </BODY></HTML>
}
}
tool::define ::docserver::upload {
superclass ::docserver::dynamic
method content {} {
my puts "<HTML><HEAD><TITLE>IRM Dispatch Server</TITLE></HEAD><BODY>"
my puts "<TABLE width=100%>"
set FORMDAT [my FormData]
foreach {f v} [my FormData] {
my puts "<tr><th>$f</th><td>$v</td></tr>"
}
my puts "<tr><td colspan=10><hr></td></tr>"
foreach {f v} [my http_info dump] {
my puts "<tr><th>$f</th><td>$v</td></tr>"
}
my puts "<tr><td colspan=10><hr></td></tr>"
foreach part [dict getnull $FORMDAT MIME_PARTS] {
my puts "<tr><td colspan=10><hr></td></tr>"
foreach f [::mime::getheader $part -names] {
my puts "<tr><th>$f</th><td>[mime::getheader $part $f]</td></tr>"
}
my puts "<tr><td colspan=10>[::mime::getbody $part -decode]</td></tr>"
}
my puts "<tr><th>File Size</th><td>[my http_info get CONTENT_LENGTH]</td></tr>"
my puts </TABLE>
my puts </BODY></HTML>
}
}
set opts [::tool::args_to_options {*}$argv]
set serveropts {}
set optinfo [::docserver::server meta getnull option]
foreach {f v} $opts {
if {[dict exists $optinfo $f]} {
dict set serveropts $f $v
}
|
| ︙ | ︙ | |||
232 233 234 235 236 237 238 239 240 |
puts "Fossil Options: $fossilopts"
::docserver::server create appmain doc_root $DEMOROOT {*}$argv
appmain add_uri /tcllib* [list mixin httpd::content::file path [file join $tcllibroot embedded www]]
appmain add_uri /fossil [list mixin httpd::content::fossil_root {*}$fossilopts]
appmain add_uri /fossil/* [list mixin httpd::content::fossil_node_scgi {*}$fossilopts]
puts [list LISTENING]
tool::main
| > > > > | 179 180 181 182 183 184 185 186 187 188 189 190 191 |
puts "Fossil Options: $fossilopts"
::docserver::server create appmain doc_root $DEMOROOT {*}$argv
appmain add_uri /tcllib* [list mixin httpd::content::file path [file join $tcllibroot embedded www]]
appmain add_uri /fossil [list mixin httpd::content::fossil_root {*}$fossilopts]
appmain add_uri /fossil/* [list mixin httpd::content::fossil_node_scgi {*}$fossilopts]
appmain add_uri /upload [list mixin ::docserver::upload]
appmain add_uri /dynamic [list mixin ::docserver::dynamic]
appmain add_uri /listen [list mixin ::docserver::listen]
appmain add_uri /send [list mixin ::docserver::send]
puts [list LISTENING]
tool::main
|
Changes to modules/cron/cron.man.
1 |
[comment {-*- tcl -*- doctools manpage}]
| | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 |
[comment {-*- tcl -*- doctools manpage}]
[vset PACKAGE_VERSION 2.1]
[manpage_begin cron n [vset PACKAGE_VERSION]]
[keywords {cron}]
[keywords {odie}]
[copyright {2016-2018 Sean Woods <[email protected]>}]
[moddesc {cron}]
[titledesc {Tool for automating the period callback of commands}]
[category System]
[require Tcl 8.6]
[require cron [opt [vset PACKAGE_VERSION]]]
[description]
[para]
|
| ︙ | ︙ |
Changes to modules/cron/cron.tcl.
| ︙ | ︙ | |||
28 29 30 31 32 33 34 35 36 37 38 39 40 41 |
}
info {
set process [lindex $args 0]
if {![::info exists ::cron::processTable($process)]} {
error "Process $process does not exist"
}
return $::cron::processTable($process)
}
create -
set {
set process [lindex $args 0]
if {![::info exists ::cron::processTable($process)]} {
set ::cron::processTable($process) [task TEMPLATE]
}
| > > > > > > > > > > > > > > > > > > > > > > | 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 |
}
info {
set process [lindex $args 0]
if {![::info exists ::cron::processTable($process)]} {
error "Process $process does not exist"
}
return $::cron::processTable($process)
}
frequency {
set process [lindex $args 0]
set time [lindex $args 1]
if {![info exists ::cron::processTable($process)]} return
dict with ::cron::processTable($process) {
set now [clock_step [current_time]]
set frequency [expr {0+$time}]
if {$scheduled>($now+$time)} {
dict set ::cron::processTable($process) scheduled [expr {$now+$time}]
}
}
}
sleep {
set process [lindex $args 0]
set time [lindex $args 1]
if {![info exists ::cron::processTable($process)]} return
dict with ::cron::processTable($process) {
set now [clock_step [current_time]]
set frequency 0
set scheduled [expr {$now+$time}]
}
}
create -
set {
set process [lindex $args 0]
if {![::info exists ::cron::processTable($process)]} {
set ::cron::processTable($process) [task TEMPLATE]
}
|
| ︙ | ︙ | |||
76 77 78 79 80 81 82 |
set scheduled [expr {[clock scan $timecode]*1000}]
}
::cron::task set $process \
frequency -1 \
command $command \
scheduled $scheduled \
coroutine {}
| | | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 |
set scheduled [expr {[clock scan $timecode]*1000}]
}
::cron::task set $process \
frequency -1 \
command $command \
scheduled $scheduled \
coroutine {}
if {$::cron::trace > 1} {
puts [list ::cron::task info $process - > [::cron::task info $process]]
}
::cron::wake NEW
return $process
}
|
| ︙ | ︙ | |||
168 169 170 171 172 173 174 |
proc ::cron::object_coroutine {objname coroutine {info {}}} {
if {$::cron::trace > 1} {
puts [list ::cron::object_coroutine $objname $coroutine $info]
}
task set $coroutine \
{*}$info \
object $objname \
| | < | 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 |
proc ::cron::object_coroutine {objname coroutine {info {}}} {
if {$::cron::trace > 1} {
puts [list ::cron::object_coroutine $objname $coroutine $info]
}
task set $coroutine \
{*}$info \
object $objname \
coroutine $coroutine
return $coroutine
}
# Notification that an object has been destroyed, and that
# it should give up any toys associated with events
proc ::cron::object_destroy {objname} {
if {$::cron::trace > 1} {
|
| ︙ | ︙ | |||
230 231 232 233 234 235 236 237 238 239 240 241 |
variable time
for {} {$time < $newtime} {incr time 100} {
uplevel #0 {::cron::do_one_event CLOCK_ADVANCE}
}
set time $newtime
uplevel #0 {::cron::do_one_event CLOCK_ADVANCE}
}
proc ::cron::sleep ms {
if {$::cron::trace > 1} {
puts [list ::cron::sleep $ms [info coroutine]]
}
| > > > > > > > > | > > > > | | | > > | | 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 |
variable time
for {} {$time < $newtime} {incr time 100} {
uplevel #0 {::cron::do_one_event CLOCK_ADVANCE}
}
set time $newtime
uplevel #0 {::cron::do_one_event CLOCK_ADVANCE}
}
proc ::cron::once_in_a_while body {
set script {set _eventid_ $::cron::current_event}
append script $body
# Add a safety to allow this while to only execute once per call
append script {if {$_eventid_==$::cron::current_event} yield}
uplevel 1 [list while 1 $body]
}
proc ::cron::sleep ms {
if {$::cron::trace > 1} {
puts [list ::cron::sleep $ms [info coroutine]]
}
set coro [info coroutine]
# When the clock is being externally
# controlled, advance the clock when
# a sleep is called
variable time
if {$time >= 0 && $coro eq {}} {
::cron::clock_set [expr {$time+$ms}]
return
}
if {$coro ne {}} {
set mnow [current_time]
set start $mnow
set end [expr {$start+$ms}]
set eventid $coro
if {$::cron::trace} {
puts "::cron::sleep $ms $coro"
}
# Mark as running
task set $eventid scheduled $end coroutine $coro running 1
::cron::wake WAKE_IN_CORO
yield 2
while {$end >= $mnow} {
if {$::cron::trace} {
puts "::cron::sleep $ms $coro (loop)"
}
set mnow [current_time]
yield 2
}
# Mark as not running to resume idle computation
task set $eventid running 0
if {$::cron::trace} {
puts "/::cron::sleep $ms $coro"
}
} else {
set eventid [incr ::cron::eventcount]
set var ::cron::event_#$eventid
set $var 0
if {$::cron::trace} {
puts "::cron::sleep $ms $eventid waiting for $var"
::after $ms "set $var 1 ; puts \"::cron::sleep - $eventid - FIRED\""
} else {
|
| ︙ | ︙ | |||
297 298 299 300 301 302 303 | ### variable processTable variable processing variable all_coroutines variable coroutine_object variable coroutine_busy variable nextevent | > | > | 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 |
###
variable processTable
variable processing
variable all_coroutines
variable coroutine_object
variable coroutine_busy
variable nextevent
variable current_event
while 1 {
incr current_event
set lastevent 0
set now [current_time]
# Wake me up in 5 minute intervals, just out of principle
set nextevent [expr {$now-($now % 300000) + 300000}]
set next_idle_event [expr {$now+250}]
if {$::cron::trace > 1} {
puts [list CRON TASK RUNNER nextevent $nextevent]
|
| ︙ | ︙ | |||
350 351 352 353 354 355 356 |
}
set lastevent $now
}
}
}
foreach task $tasks {
dict set processTable($task) lastrun $now
| > | < < < < < < > | | 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 |
}
set lastevent $now
}
}
}
foreach task $tasks {
dict set processTable($task) lastrun $now
if {[dict exists processTable($task) foreground] && [dict set processTable($task) foreground]} continue
if {[dict exists processTable($task) running] && [dict set processTable($task) running]} continue
if {$::cron::trace > 2} {
puts [list RUNNING $task [task info $task]]
}
set coro [dict getnull $processTable($task) coroutine]
dict set processTable($task) running 1
set command [dict getnull $processTable($task) command]
if {$command eq {} && $coro eq {}} {
# Task has nothing to do. Slot it for destruction
lappend cancellist $task
} elseif {$coro ne {}} {
if {[info command $coro] eq {}} {
set object [dict get $processTable($task) object]
# Trigger coroutine again if a command was given
# If this coroutine is associated with an object, ensure
# the object still exists before invoking its method
if {$command eq {} || ($object ne {} && [info command $object] eq {})} {
lappend cancellist $task
dict set processTable($task) running 0
continue
}
if {$::cron::trace} {
puts [list RESTARTING $task - coroutine $coro - with $command]
}
::coroutine $coro {*}$command
}
try $coro on return {} {
|
| ︙ | ︙ | |||
459 460 461 462 463 464 465 |
set delay [expr {$nextevent-$now}]
if {$delay <= 0} {
yield 0
} else {
if {$::cron::trace > 1} {
puts "NEXT EVENT $delay - NEXT TASK $nexttask"
}
| | < < < < < < < < < < < < < | < < | 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 |
set delay [expr {$nextevent-$now}]
if {$delay <= 0} {
yield 0
} else {
if {$::cron::trace > 1} {
puts "NEXT EVENT $delay - NEXT TASK $nexttask"
}
yield $delay
}
}
}
proc ::cron::wake {{who ???}} {
##
# Only triggered by cron jobs kicking off other cron jobs within
# the script body
##
if {$::cron::trace} {
puts "::cron::wake $who"
}
if {$::cron::busy} {
return
}
after cancel $::cron::next_event
set ::cron::next_event [after idle [list ::cron::do_one_event $who]]
}
proc ::cron::do_one_event {{who ???}} {
if {$::cron::trace} {
puts "::cron::do_one_event $who"
}
after cancel $::cron::next_event
set now [current_time]
set ::cron::busy 1
while {$::cron::busy} {
if {[info command ::cron::COROUTINE] eq {}} {
::coroutine ::cron::COROUTINE ::cron::runTasksCoro
}
set cron_delay [::cron::COROUTINE]
if {$cron_delay==0} {
if {[incr loops]>10} {
|
| ︙ | ︙ | |||
572 573 574 575 576 577 578 |
###
namespace eval ::cron {
variable lastcall 0
variable processTable
variable busy 0
variable next_event {}
variable trace 0
| | < | | | | 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 |
###
namespace eval ::cron {
variable lastcall 0
variable processTable
variable busy 0
variable next_event {}
variable trace 0
variable current_event
variable time -1
if {![info exists current_event]} {
set current_event 0
}
if {![info exists ::cron::loops]} {
array set ::cron::loops {
active 0
main 0
idle 0
wake 0
}
}
}
::cron::wake STARTUP
package provide cron 2.1
|
Changes to modules/cron/pkgIndex.tcl.
1 |
if {![package vsatisfies [package provide Tcl] 8.6]} {return}
| | | 1 2 |
if {![package vsatisfies [package provide Tcl] 8.6]} {return}
package ifneeded cron 2.1 [list source [file join $dir cron.tcl]]
|
Added modules/httpd/build.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 69 70 71 72 |
set here [file dirname [file normalize [file join [pwd] [info script]]]]
set version 4.1.0
set tclversion 8.6
set module [file tail $here]
set fout [open [file join $here [file tail $module].tcl] w]
dict set map %module% $module
dict set map %version% $version
dict set map %tclversion% $tclversion
dict set map { } {} ;# strip indentation
dict set map "\t" { } ;# reduce indentation (see cleanup)
puts $fout [string map $map {###
# Amalgamated package for %module%
# Do not edit directly, tweak the source in src/ and rerun
# build.tcl
###
package require Tcl %tclversion%
package provide %module% %version%
namespace eval ::%module% {}
set ::%module%::version %version%
}]
# Track what files we have included so far
set loaded {}
# These files must be loaded in a particular order
foreach file {
core.tcl
reply.tcl
server.tcl
dispatch.tcl
file.tcl
scgi.tcl
proxy.tcl
websocket.tcl
} {
lappend loaded $file
set fin [open [file join $here src $file] r]
puts $fout "###\n# START: [file tail $file]\n###"
puts $fout [read $fin]
close $fin
puts $fout "###\n# END: [file tail $file]\n###"
}
# These files can be loaded in any order
foreach file [glob [file join $here src *.tcl]] {
if {[file tail $file] in $loaded} continue
lappend loaded $file
set fin [open [file join $here src $file] r]
puts $fout "###\n# START: [file tail $file]\n###"
puts $fout [read $fin]
close $fin
puts $fout "###\n# END: [file tail $file]\n###"
}
# Provide some cleanup and our final package provide
puts $fout [string map $map {
namespace eval ::%module% {
namespace export *
}
}]
close $fout
###
# Build our pkgIndex.tcl file
###
set fout [open [file join $here pkgIndex.tcl] w]
puts $fout [string map $map {
if {![package vsatisfies [package provide Tcl] %tclversion%]} {return}
package ifneeded %module% %version% [list source [file join $dir %module%.tcl]]
}]
close $fout
|
Deleted modules/httpd/content.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Added modules/httpd/httpd.man.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
[vset VERSION 4.1.0]
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin tool n [vset VERSION]]
[keywords WWW]
[copyright {2018 Sean Woods <[email protected]>}]
[moddesc {Tcl Web Server}]
[titledesc {A TclOO based update to tclhttpd}]
[category Utility]
[keywords TclOO]
[require Tcl 8.6]
[require httpd [opt [vset VERSION]]]
[require sha1]
[require dicttool]
[require oo::meta]
[require oo::dialect]
[require tool]
[require coroutine]
[require fileutil]
[require fileutil::magic::filetype]
[require websocket]
[require mime]
[require cron]
[require uri]
[description]
[para]
This module implements a web server, suitable for embedding in an
application. The server is object oriented, and contains all of the
fundimentals needed for a full service website.
[para]
[section Class ::httpd::server]
This class is the root object of the webserver. It is responsible
for opening the socket and providing the initial connection negotiation.
[list_begin methods]
[call constructor ?port [opt port]? ?myaddr [opt ipaddr]|all? ?server_string [opt string]? ?server_name [opt string]?]
Build a new server object. [opt port] is the port to listen on
[call method [cmd add_uri] [arg pattern] [arg dict]]
Set the hander for a URI pattern
[call method [cmd connect] [arg sock] [arg ip] [arg port]]
Reply to an open socket.
[call method [cmd Connect] [arg uuid] [arg sock] [arg ip]]
[call method [cmd counter] [arg which]]
Increment an internal counter
[call method [cmd CheckTimeout]]
Check open connections for a time out event.
[call method [cmd dispatch] [arg header_dict]]
Given a key/value list of information, generate a "reply"
object, configure that object, and mix in any data required to
implement a proper reply.
On failure, this method sends either a 404 or 505 reply, depending
on whether a reply could not be mapped at all, or if the object
returns an error.
The contents of [arg header_dict] are the MIME headers and possibly
POST contents of the request.
[call method [cmd log] [arg args]]
Log an event. The input for args is free form. This method is intended
to be replaced by the user, and is a noop for a stock http::server object.
[call method [cmd port_listening]]
Return the actual port that httpd is listening on.
[call method [cmd PrefixNormalize] [arg prefix]]
For the stock version, trim trailing /'s and *'s from a prefix. This
method can be replaced by the end user to perform any other transformations
needed for the application.
[call method [cmd start]]
Open the socket listener.
[call method [cmd stop]]
Shut off the socket listener, and destroy any pending replies.
[call method [cmd template] [arg page]]
Return a template for the string [arg page]
[call method [cmd TemplateSearch] [arg page]]
Perform a search for the template that best matches [arg page]. This
can include local file searches, in-memory structures, or even
database lookups. The stock implementation simply looks for files
with a .tml or .html extension in the [opt doc_root] directory.
[call method [cmd Validate_Connection] [arg sock] [arg ip]]
Given a socket and an ip address, return true if this connection should
be terminated, or false if it should be allowed to continue. The stock
implementation always returns 0. This is intended for applications to
be able to implement black lists and/or provide security based on IP
address.
[list_end]
[section Class ::httpd::reply]
A class which shephards a request through the process of generating a
reply.
[list_begin methods]
[call method [cmd close]]
Terminate the transaction, and close the socket.
[list_end]
[example {
src/reply.tcl: method HttpHeaders {sock {debug {}}} {
src/reply.tcl: method MimeParse mimetext {
src/reply.tcl: method dispatch {newsock datastate} {
src/reply.tcl: method error {code {msg {}} {errorInfo {}}} {
src/reply.tcl: method content {} {
src/reply.tcl: method EncodeStatus {status} {
src/reply.tcl: method output {} {
src/reply.tcl: method DoOutput {} {
src/reply.tcl: method Url_Decode data {
src/reply.tcl: method FormData {} {
src/reply.tcl: method PostData {} {
src/reply.tcl: method TransferComplete args {
src/reply.tcl: method puts line {
src/reply.tcl: method reset {} {
src/reply.tcl: method timeOutCheck {} {
src/reply.tcl: method timestamp {} {
src/file.tcl:::tool::define ::httpd::content::file {
src/file.tcl: method FileName {} {
src/file.tcl: method DirectoryListing {local_file} {
src/file.tcl: method dispatch {newsock datastate} {
src/file.tcl: method content {} {
src/file.tcl: method DoOutput {} {
src/proxy.tcl:::tool::define ::httpd::content::proxy {
src/proxy.tcl: method proxy_info {} {
src/proxy.tcl: method content {} {
src/proxy.tcl: method DoOutput {} {
src/scgi.tcl:::tool::define ::httpd::content::scgi {
src/scgi.tcl: method scgi_info {} {
src/scgi.tcl: method content {} {
src/scgi.tcl: method DoOutput {} {
}]
[section AUTHORS]
Sean Woods
[vset CATEGORY network]
[include ../doctools2base/include/feedback.inc]
[manpage_end]
|
Changes to modules/httpd/httpd.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | ### # Author: Sean Woods, [email protected] ## # Adapted from the "minihttpd.tcl" file distributed with Tclhttpd # # The working elements have been updated to operate as a TclOO object # running with Tcl 8.6+. Global variables and hard coded tables are # now resident with the object, allowing this server to be more easily # embedded another program, as well as be adapted and extended to # support the SCGI module ### package require uri package require cron package require coroutine package require tool | > > > > > > > > > > > > > > | > > > > > > > > > | < > > > > > > | > | | | | 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 |
###
# Amalgamated package for httpd
# Do not edit directly, tweak the source in src/ and rerun
# build.tcl
###
package require Tcl 8.6
package provide httpd 4.1.0
namespace eval ::httpd {}
set ::httpd::version 4.1.0
###
# START: core.tcl
###
###
# Author: Sean Woods, [email protected]
##
# Adapted from the "minihttpd.tcl" file distributed with Tclhttpd
#
# The working elements have been updated to operate as a TclOO object
# running with Tcl 8.6+. Global variables and hard coded tables are
# now resident with the object, allowing this server to be more easily
# embedded another program, as well as be adapted and extended to
# support the SCGI module
###
package require uri
package require cron
package require coroutine
package require tool
package require mime
package require fileutil
package require websocket
###
# Standard library of HTTP/SCGI content
# Each of these classes are intended to be mixed into
# either an HTTPD or SCGI reply
###
package require Markdown
package require fileutil::magic::filetype
namespace eval httpd::content {}
namespace eval ::url {}
namespace eval ::httpd {}
namespace eval ::scgi {}
###
# END: core.tcl
###
###
# START: reply.tcl
###
###
# Define the reply class
###
::tool::define ::httpd::reply {
property reply_headers_default {
Status {200 OK}
Content-Size 0
Content-Type {text/html; charset=ISO-8859-1}
Cache-Control {no-cache}
Connection close
}
array error_codes {
200 {Data follows}
204 {No Content}
302 {Found}
304 {Not Modified}
|
| ︙ | ︙ | |||
85 86 87 88 89 90 91 |
# a flag which will terminate the vwait.
#
# We do this rather than entering blocking mode to prevent the process
# from locking up if it's starved for input. (Or in the case of the test
# suite, when we are opening a blocking channel on the other side of the
# socket back to ourselves.)
###
| | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | > > | | | < < < | | | < < < < | < < < | | | | | | 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 |
# a flag which will terminate the vwait.
#
# We do this rather than entering blocking mode to prevent the process
# from locking up if it's starved for input. (Or in the case of the test
# suite, when we are opening a blocking channel on the other side of the
# socket back to ourselves.)
###
chan configure $sock -translation {auto crlf} -blocking 0 -buffering line
try {
while 1 {
set readCount [::coroutine::util::gets_safety $sock 4096 line]
if {$readCount==0} break
append result $line \n
}
} trap {POSIX EBUSY} {err info} {
# Happens...
} on error {err info} {
puts "ERROR $err"
puts [dict print $info]
tailcall my destroy
}
###
# Return our buffer
###
return $result
}
method dispatch {newsock datastate} {
my http_info replace $datastate
my variable chan rawrequest dipatched_time
set chan $newsock
chan event $chan readable {}
chan configure $chan -translation {auto crlf} -buffering line
set dispatched_time [clock seconds]
try {
# Initialize the reply
my reset
# Process the incoming MIME headers
set rawrequest [my HttpHeaders $chan]
my request parse $rawrequest
# Invoke the URL implementation.
my content
} on error {err info} {
dict print $info
puts stderr $::errorInfo
my error 500 $err [dict get $info -errorinfo]
} finally {
my output
}
}
dictobj http_info http_info {
initialize {
CONTENT_LENGTH 0
}
netstring {
set result {}
foreach {name value} $%VARNAME% {
append result $name \x00 $value \x00
}
return "[string length $result]:$result,"
}
}
method error {code {msg {}} {errorInfo {}}} {
my http_info set HTTP_ERROR $code
my reset
my variable error_codes
set qheaders [my http_info dump]
if {![info exists error_codes($code)]} {
set errorstring "Unknown Error Code"
} else {
set errorstring $error_codes($code)
}
dict with qheaders {}
my reply replace {}
my reply set Status "$code $errorstring"
my reply set Content-Type {text/html; charset=ISO-8859-1}
my puts "
<HTML>
<HEAD>
<TITLE>$code $errorstring</TITLE>
</HEAD>
<BODY>"
if {$msg eq {}} {
|
| ︙ | ︙ | |||
274 275 276 277 278 279 280 281 282 283 284 285 286 287 |
return "HTTP/1.0 $status"
}
method output {} {
my variable chan
chan event $chan writable [namespace code {my DoOutput}]
}
###
# Output the result or error to the channel
# and destroy this object
###
method DoOutput {} {
my variable reply_body chan
chan event $chan writable {}
| > < < < < < < < < < < < < < > | > | | > | > > > > > > > > | > > > > > > > > > > > | | > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | < > > > > > > > > > > > > > > > > > > > > > > > > > | | | | 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 |
return "HTTP/1.0 $status"
}
method output {} {
my variable chan
chan event $chan writable [namespace code {my DoOutput}]
}
###
# Output the result or error to the channel
# and destroy this object
###
method DoOutput {} {
my variable reply_body chan
chan event $chan writable {}
catch {
chan configure $chan -translation {binary binary}
###
# Return dynamic content
###
set length [string length $reply_body]
set result {}
if {${length} > 0} {
my reply set Content-Length [string length $reply_body]
append result [my reply output] \n
append result $reply_body
} else {
append result [my reply output]
}
chan puts -nonewline $chan $result
} err
puts $err
my destroy
}
method Url_Decode data {
regsub -all {\+} $data " " data
regsub -all {([][$\\])} $data {\\\1} data
regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data {[format %c 0x\1]} data
return [subst $data]
}
method FormData {} {
my variable chan formdata rawrequest
# Run this only once
if {[info exists formdata]} {
return $formdata
}
set rawrequest [my HttpHeaders $chan]
my request parse $rawrequest
if {![my request exists Content-Length]} {
set length 0
} else {
set length [my request get Content-Length]
}
set formdata {}
if {[my http_info get REQUEST_METHOD] in {"POST" "PUSH"}} {
set rawtype [my request get Content-Type]
if {[string toupper [string range $rawtype 0 8]] ne "MULTIPART"} {
set type $rawtype
} else {
set type multipart
}
switch $type {
multipart {
###
# Ok, Multipart MIME is troublesome, farm out the parsing to a dedicated tool
###
set body $rawrequest
append body \n [my PostData $length]
set token [::mime::initialize -string $body]
foreach item [::mime::getheader $token -names] {
dict set formdata $item [::mime::getheader $token $item]
}
foreach item {content encoding params parts size} {
dict set formdata MIME_[string toupper $item] [::mime::getproperty $token $item]
}
dict set formdata MIME_TOKEN $token
}
application/x-www-form-urlencoded {
# These foreach loops are structured this way to ensure there are matched
# name/value pairs. Sometimes query data gets garbled.
set body [my PostData $length]
set result {}
foreach pair [split $body "&"] {
foreach {name value} [split $pair "="] {
lappend formdata [my Url_Decode $name] [my Url_Decode $value]
}
}
}
}
} else {
foreach pair [split [my http_info getnull QUERY_STRING] "&"] {
foreach {name value} [split $pair "="] {
lappend formdata [my Url_Decode $name] [my Url_Decode $value]
}
}
}
return $formdata
}
###
# Minimalist MIME Header Parser
###
method MimeParse mimetext {
set data(mimeorder) {}
foreach line [split $mimetext \n] {
# This regexp picks up
# key: value
# MIME headers. MIME headers may be continue with a line
# that starts with spaces or a tab
if {[string length [string trim $line]]==0} break
if {[regexp {^([^ :]+):[ ]*(.*)} $line dummy key value]} {
# The following allows something to
# recreate the headers exactly
lappend data(headerlist) $key $value
# The rest of this makes it easier to pick out
# headers from the data(mime,headername) array
#set key [string tolower $key]
if {[info exists data(mime,$key)]} {
append data(mime,$key) ,$value
} else {
set data(mime,$key) $value
lappend data(mimeorder) $key
}
set data(key) $key
} elseif {[regexp {^[ ]+(.*)} $line dummy value]} {
# Are there really continuation lines in the spec?
if {[info exists data(key)]} {
append data(mime,$data(key)) " " $value
} else {
my error 400 "INVALID HTTP HEADER FORMAT: $line"
tailcall my output
}
} else {
my error 400 "INVALID HTTP HEADER FORMAT: $line"
tailcall my output
}
}
###
# To make life easier for our SCGI implementation rig things
# such that CONTENT_LENGTH is always first
###
set result {}
dict set result Content-Length 0
foreach {key} $data(mimeorder) {
dict set result $key $data(mime,$key)
}
return $result
}
method PostData {length} {
my variable postdata
# Run this only once
if {[info exists postdata]} {
return $postdata
}
set postdata {}
if {[my http_info get REQUEST_METHOD] in {"POST" "PUSH"}} {
my variable chan
chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096
set postdata [::coroutine::util::read $chan $length]
}
return $postdata
}
method TransferComplete args {
foreach c $args {
catch {close $c}
}
my destroy
}
###
# Append to the result buffer
###
method puts line {
my variable reply_body
append reply_body $line \n
}
dictobj request request {
parse {
set request [my MimeParse [lindex $args 0]]
}
}
dictobj reply reply {
output {
set result {}
if {![dict exists $reply Status]} {
set status {200 OK}
} else {
set status [dict get $reply Status]
}
set result "[my EncodeStatus $status]\n"
foreach {f v} $reply {
if {$f in {Status}} continue
append result "[string trimright $f :]: $v\n"
}
#append result \n
return $result
}
}
###
# Reset the result
###
method reset {} {
my variable reply_body
my reply replace [my meta cget reply_headers_default]
my reply set Server [my <server> cget server_string]
my reply set Date [my timestamp]
set reply_body {}
}
###
# Return true of this class as waited too long to respond
###
method timeOutCheck {} {
|
| ︙ | ︙ | |||
414 415 416 417 418 419 420 |
###
method timestamp {} {
return [clock format [clock seconds] -format {%a, %d %b %Y %T %Z}]
}
}
###
| > > > | < < > > > > > > | > > > > > > > > | < < < < > > > > | > | 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 |
###
method timestamp {} {
return [clock format [clock seconds] -format {%a, %d %b %Y %T %Z}]
}
}
###
# END: reply.tcl
###
###
# START: server.tcl
###
###
# An httpd server with a template engine
# and a shim to insert URL domains
###
::tool::define ::httpd::server {
option port {default: auto}
option myaddr {default: 127.0.0.1}
option server_string [list default: [list TclHttpd $::httpd::version]]
option server_name [list default: [list [info hostname]]]
option doc_root {default {}}
property socket buffersize 32768
property socket translation {auto crlf}
property reply_class ::httpd::reply
array template
variable url_patterns {}
constructor {args} {
my configure {*}$args
my start
}
destructor {
my stop
}
method add_uri {pattern info} {
my variable url_patterns
dict set url_patterns $pattern $info
}
method connect {sock ip port} {
###
# If an IP address is blocked
# send a "go to hell" message
###
if {[my Validate_Connection $sock $ip]} {
catch {close $sock}
return
}
set uuid [::tool::uuid_short]
chan configure $sock \
-blocking 0 \
-translation {auto crlf} \
-buffering line
set coro [coroutine [namespace current]::CORO$uuid {*}[namespace code [list my Connect $uuid $sock $ip]]]
chan event $sock readable $coro
}
method Connect {uuid sock ip} {
yield [info coroutine]
chan event $sock readable {}
my counter url_hit
set line {}
try {
set readCount [::coroutine::util::gets_safety $sock 4096 line]
dict set query REMOTE_ADDR $ip
dict set query REQUEST_METHOD [lindex $line 0]
set uriinfo [::uri::split [lindex $line 1]]
dict set query REQUEST_URI [lindex $line 1]
dict set query REQUEST_PATH [dict get $uriinfo path]
dict set query REQUEST_VERSION [lindex [split [lindex $line end] /] end]
if {[dict get $uriinfo host] eq {}} {
if {$ip eq "127.0.0.1"} {
dict set query HTTP_HOST localhost
} else {
dict set query HTTP_HOST [info hostname]
}
} else {
dict set query HTTP_HOST [dict get $uriinfo host]
}
dict set query HTTP_CLIENT_IP $ip
dict set query QUERY_STRING [dict get $uriinfo query]
dict set query REQUEST_RAW $line
} on error {err errdat} {
|
| ︙ | ︙ | |||
555 556 557 558 559 560 561 |
} on error {} {
catch {$obj destroy}
}
}
}
###
| | < < < < > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > | 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 |
} on error {} {
catch {$obj destroy}
}
}
}
###
# Route a request to the appropriate handler
###
method dispatch {data} {
set reply $data
set uri [dict get $data REQUEST_PATH]
# Search from longest pattern to shortest
my variable url_patterns
foreach {pattern info} $url_patterns {
if {[string match ${pattern} /$uri]} {
set reply [dict merge $data $info]
if {![dict exists $reply prefix]} {
dict set reply prefix [my PrefixNormalize $pattern]
}
return $reply
}
}
set doc_root [my cget doc_root]
if {$doc_root ne {}} {
###
# Fall back to doc_root handling
###
dict set reply prefix {}
dict set reply path $doc_root
dict set reply mixin httpd::content::file
return $reply
}
return {}
}
method log args {
# Do nothing for now
}
method port_listening {} {
my variable port_listening
return $port_listening
}
method PrefixNormalize prefix {
set prefix [string trimright $prefix /]
set prefix [string trimright $prefix *]
set prefix [string trimright $prefix /]
return $prefix
}
method start {} {
# Build a namespace to contain replies
namespace eval [namespace current]::reply {}
my variable socklist port_listening
set port [my cget port]
if { $port in {auto {}} } {
|
| ︙ | ︙ | |||
665 666 667 668 669 670 671 |
# The socket will be closed immediately after returning
# This handler is welcome to send a polite error message
###
method Validate_Connection {sock ip} {
return 0
}
}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 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 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 |
# The socket will be closed immediately after returning
# This handler is welcome to send a polite error message
###
method Validate_Connection {sock ip} {
return 0
}
}
###
# Provide a backward compadible alias
###
::tool::define ::httpd::server::dispatch {
superclass ::httpd::server
}
###
# END: server.tcl
###
###
# START: dispatch.tcl
###
###
# END: dispatch.tcl
###
###
# START: file.tcl
###
###
# Class to deliver Static content
# When utilized, this class is fed a local filename
# by the dispatcher
###
::tool::define ::httpd::content::file {
method FileName {} {
set uri [string trimleft [my http_info get REQUEST_URI] /]
set path [my http_info get path]
set prefix [my http_info get prefix]
set fname [string range $uri [string length $prefix] end]
if {$fname in "{} index.html index.md index"} {
return $path
}
if {[file exists [file join $path $fname]]} {
return [file join $path $fname]
}
if {[file exists [file join $path $fname.md]]} {
return [file join $path $fname.md]
}
if {[file exists [file join $path $fname.html]]} {
return [file join $path $fname.html]
}
if {[file exists [file join $path $fname.tml]]} {
return [file join $path $fname.tml]
}
return {}
}
method DirectoryListing {local_file} {
set uri [string trimleft [my http_info get REQUEST_URI] /]
set path [my http_info get path]
set prefix [my http_info get prefix]
set fname [string range $uri [string length $prefix] end]
my puts "<HTML><HEAD><TITLE>Listing of /$fname/</TITLE></HEAD><BODY>"
my puts "Path: $path<br>"
my puts "Prefs: $prefix</br>"
my puts "URI: $uri</br>"
my puts "Listing contents of /$fname/"
my puts "<TABLE>"
if {$prefix ni {/ {}}} {
set updir [file dirname $prefix]
if {$updir ne {}} {
my puts "<TR><TD><a href=\"/$updir\">..</a></TD><TD></TD></TR>"
}
}
foreach file [glob -nocomplain [file join $local_file *]] {
if {[file isdirectory $file]} {
my puts "<TR><TD><a href=\"[file join / $uri [file tail $file]]\">[file tail $file]/</a></TD><TD></TD></TR>"
} else {
my puts "<TR><TD><a href=\"[file join / $uri [file tail $file]]\">[file tail $file]</a></TD><TD>[file size $file]</TD></TR>"
}
}
my puts "</TABLE></BODY></HTML>"
}
method dispatch {newsock datastate} {
# No need to process the rest of the headers
my variable chan dipatched_time
set dispatched_time [clock seconds]
my http_info replace $datastate
set chan $newsock
my content
my output
}
method content {} {
###
# When delivering static content, allow web caches to save
###
my reply set Cache-Control {max-age=3600}
my variable reply_file
set local_file [my FileName]
if {$local_file eq {} || ![file exist $local_file]} {
my <server> log httpNotFound [my http_info get REQUEST_URI]
tailcall my error 404 {Not Found}
}
if {[file isdirectory $local_file]} {
###
# Produce an index page
###
set idxfound 0
foreach name {
index.html
index.tml
index.md
} {
if {[file exists [file join $local_file $name]]} {
set idxfound 1
set local_file [file join $local_file $name]
break
}
}
if {!$idxfound} {
tailcall my DirectoryListing $local_file
}
}
switch [file extension $local_file] {
.md {
package require Markdown
my reply set Content-Type {text/html; charset=ISO-8859-1}
set mdtxt [::fileutil::cat $local_file]
my puts [::Markdown::convert $mdtxt]
}
.tml {
my reply set Content-Type {text/html; charset=ISO-8859-1}
set tmltxt [::fileutil::cat $local_file]
set headers [my http_info dump]
dict with headers {}
my puts [subst $tmltxt]
}
default {
###
# Assume we are returning a binary file
###
my reply set Content-Type [::fileutil::magic::filetype $local_file]
set reply_file $local_file
}
}
}
###
# Output the result or error to the channel
# and destroy this object
###
method DoOutput {} {
my variable chan
chan event $chan writable {}
my variable reply_body reply_file reply_chan chan
chan configure $chan -translation {binary binary}
if {![info exists reply_file]} {
###
# Return dynamic content
###
if {![info exists reply_body]} {
append result [my reply output]
} else {
set reply_body [string trim $reply_body]
my reply set Content-Length [string length $reply_body]
append result [my reply output] \n
append result $reply_body
chan puts -nonewline $chan $result
chan flush $chan
}
my destroy
} else {
###
# Return a stream of data from a file
###
set size [file size $reply_file]
my reply set Content-Length $size
append result [my reply output] \n
chan puts -nonewline $chan $result
set reply_chan [open $reply_file r]
chan configure $reply_chan -translation {binary binary}
chan copy $reply_chan $chan -command [namespace code [list my TransferComplete $reply_chan]]
}
}
}
###
# END: file.tcl
###
###
# START: scgi.tcl
###
###
# Return data from an SCGI process
###
::tool::define ::httpd::content::scgi {
method scgi_info {} {
###
# This method should check if a process is launched
# or launch it if needed, and return a list of
# HOST PORT SCRIPT_NAME
###
# return {localhost 8016 /some/path}
error unimplemented
}
method content {} {
my variable sock chan
set sockinfo [my scgi_info]
if {$sockinfo eq {}} {
my error 404 {Not Found}
return
}
lassign $sockinfo scgihost scgiport scgiscript
set sock [::socket $scgihost $scgiport]
chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096
chan configure $sock -translation binary -blocking 0 -buffering full -buffersize 4096
###
# Convert our query headers into netstring format.
###
if {![my request exists Content-Length]} {
set length 0
} else {
set length [my request get Content-Length]
}
set block {}
append block CONTENT_LENGTH \x00 $length \x00
append block SCGI \x00 1.0 \x00
append block SCRIPT_NAME \x00 $scgiscript \x00
set info {}
foreach {f v} [my http_info dump] {
dict set info $f $v
}
foreach {f v} [my request dump] {
if {[string range $f 0 3] ne "HTTP"} {
set f HTTP_[string toupper $f]
}
dict set info $f $v
}
foreach {f v} $info {
if {$f in {CONTENT_LENGTH HTTP_STATUS}} continue
append block [string toupper $f] \x00 $v \x00
}
chan puts -nonewline $sock "[string length $block]:$block,"
if {$length} {
###
# Send any POST/PUT/etc content
###
chan copy $chan $sock -size $length
}
chan flush $sock
###
# Wake this object up after the SCGI process starts to respond
###
#chan configure $sock -translation {auto crlf} -blocking 0 -buffering line
chan event $sock readable [namespace code {my output}]
}
method output {} {
if {[my http_info getnull HTTP_ERROR] ne {}} {
###
# If something croaked internally, handle this page as a normal reply
###
next
}
my variable sock chan
set replyhead [my HttpHeaders $sock]
set replydat [my MimeParse $replyhead]
if {![dict exists $replydat CONTENT_LENGTH]} {
set length 0
} else {
set length [dict get $replydat CONTENT_LENGTH]
}
###
# Convert the Status: header from the SCGI service to
# a standard service reply line from a web server, but
# otherwise spit out the rest of the headers verbatim
###
set replybuffer "HTTP/1.1 [dict get $replydat HTTP_STATUS]\n"
append replybuffer $replyhead
chan configure $chan -translation {auto crlf} -blocking 0 -buffering full -buffersize 4096
puts $chan $replybuffer
###
# Output the body
###
chan configure $sock -translation binary -blocking 0 -buffering full -buffersize 4096
chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096
if {$length} {
###
# Send any POST/PUT/etc content
###
chan copy $sock $chan -command [namespace code [list my TransferComplete $sock]]
} else {
catch {close $sock}
chan flush $chan
my destroy
}
}
###
# Todo: Shorten this to a http->SCGI header formatter
# And eliminate the duplicate implementation
###
method MimeParse mimetext {
set data(mimeorder) {}
foreach line [split $mimetext \n] {
# This regexp picks up
# key: value
# MIME headers. MIME headers may be continue with a line
# that starts with spaces or a tab
if {[string length [string trim $line]]==0} break
if {[regexp {^([^ :]+):[ ]*(.*)} $line dummy key value]} {
# The following allows something to
# recreate the headers exactly
lappend data(headerlist) $key $value
# The rest of this makes it easier to pick out
# headers from the data(mime,headername) array
#set key [string tolower $key]
if {[info exists data(mime,$key)]} {
append data(mime,$key) ,$value
} else {
set data(mime,$key) $value
lappend data(mimeorder) $key
}
set data(key) $key
} elseif {[regexp {^[ ]+(.*)} $line dummy value]} {
# Are there really continuation lines in the spec?
if {[info exists data(key)]} {
append data(mime,$data(key)) " " $value
} else {
my error 400 "INVALID HTTP HEADER FORMAT: $line"
tailcall my output
}
} else {
my error 400 "INVALID HTTP HEADER FORMAT: $line"
tailcall my output
}
}
###
# To make life easier for our SCGI implementation rig things
# such that CONTENT_LENGTH is always first
###
set result {
CONTENT_LENGTH 0
}
foreach {key} $data(mimeorder) {
switch $key {
Content-Length {
dict set result CONTENT_LENGTH $data(mime,$key)
}
Content-Type {
dict set result CONTENT_TYPE $data(mime,$key)
}
default {
dict set result HTTP_[string map {"-" "_"} [string toupper $key]] $data(mime,$key)
}
}
}
return $result
}
}
###
# END: scgi.tcl
###
###
# START: proxy.tcl
###
# Act as a proxy server
::tool::define ::httpd::content::proxy {
method proxy_info {} {
###
# This method should check if a process is launched
# or launch it if needed, and return a list of
# HOST PORT PROXYURI
###
# return {localhost 8016 /some/path}
error unimplemented
}
method content {} {
my variable chan sock rawrequest
set sockinfo [my proxy_info]
if {$sockinfo eq {}} {
tailcall my error 404 {Not Found}
}
lassign $sockinfo proxyhost proxyport proxyscript
set sock [::socket $proxyhost $proxyport]
chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096
chan configure $sock -translation {auto crlf} -blocking 1 -buffering line
# Pass along our modified METHOD URI PROTO
chan puts $sock "$proxyscript"
# Pass along the headers as we saw them
chan puts $sock $rawrequest
set length [my http_info get CONTENT_LENGTH]
if {$length} {
###
# Send any POST/PUT/etc content
###
chan copy $chan $sock -size $length
}
chan flush $sock
###
# Wake this object up after the proxied process starts to respond
###
chan configure $sock -translation {auto crlf} -blocking 1 -buffering line
chan event $sock readable [namespace code {my output}]
}
method DoOutput {} {
my variable chan sock
chan event $chan writable {}
if {![info exists sock] || [my http_info getnull HTTP_ERROR] ne {}} {
###
# If something croaked internally, handle this page as a normal reply
###
next
return
}
set length 0
chan configure $sock -translation {crlf crlf} -blocking 1
set replystatus [gets $sock]
set replyhead [my HttpHeaders $sock]
set replydat [my MimeParse $replyhead]
###
# Pass along the status line and MIME headers
###
set replybuffer "$replystatus\n"
append replybuffer $replyhead
chan configure $chan -translation {auto crlf} -blocking 0 -buffering full -buffersize 4096
chan puts $chan $replybuffer
###
# Output the body
###
chan configure $sock -translation binary -blocking 0 -buffering full -buffersize 4096
chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096
set length [dict get $replydat CONTENT_LENGTH]
if {$length} {
###
# Send any POST/PUT/etc content
###
chan copy $sock $chan -command [namespace code [list my TransferComplete $sock]]
} else {
my destroy
}
}
}
###
# END: proxy.tcl
###
###
# START: websocket.tcl
###
###
# Upgrade a connection to a websocket
###
::tool::define ::httpd::content::websocket {
}
###
# END: websocket.tcl
###
namespace eval ::httpd {
namespace export *
}
|
Changes to modules/httpd/httpd.test.
| ︙ | ︙ | |||
38 39 40 41 42 43 44 |
namespace eval ::httpd {}
namespace eval ::httpd::test {}
###
# Minimal test harness for the .tests
# Not intended for public consumption
# (But if you find it handy, please steal!)
| | > > > > > > > > > > > | > > > > > | | | | | < < < | < < | < | | > > | < | | | | < > > > > > > > > > | | > | < > | > | | | | | | < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | > | | < > > | < < < < < | > > > > > > | < < < < | < < > | < | < | > > | | < < < < < < < < > | > | < | > > < < | | | < | | > > > > > > | < < < | | > | < < < | | > | < < < | | > | < | | > | | | < | | | < < | | | > > > > > > > | 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 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 |
namespace eval ::httpd {}
namespace eval ::httpd::test {}
###
# Minimal test harness for the .tests
# Not intended for public consumption
# (But if you find it handy, please steal!)
proc ::httpd::test::compare {actual correct} {
set result {}
set cbuf [split $correct \n]
set abuf [split $actual \n]
#puts [list ACTUAL $actual]
#puts [list CORRECT $correct]
for {set i 0} {$i < [llength $cbuf]} {incr i} {
set cline [string trim [lindex $cbuf $i]]
set aline [string trim [lindex $abuf $i]]
if {![string match $cline $aline]} {
if {$cline ne $aline} {
append result "Line $i differs [list $aline] != [list $cline]" \n
}
}
}
return $result
}
proc ::httpd::test::send {port http headers body} {
set sock [socket localhost $port]
variable reply
set reply($sock) {}
chan configure $sock -translation {crlf crlf} -blocking 0 -buffering full -buffersize 4096
chan event $sock readable [list ::httpd::test::get_reply $sock]
puts $sock $http
if {[string length $body]} {
if {![dict exists $headers Content-Type]} {
dict set headers Content_Type text/plain
}
dict set headers Content-Length [string length $body]
}
foreach {f v} $headers {
puts $sock "${f}: $v"
}
if {[string length $body]} {
puts $sock {}
chan configure $sock -translation binary -blocking 0 -buffering full -buffersize 4096
puts -nonewline $sock $body
}
flush $sock
while {$reply($sock) eq {}} {
update
}
#vwait [namespace current]::reply($sock)
return $reply($sock)
}
proc ::httpd::test::get_reply {sock} {
variable buffer
set data [read $sock]
append buffer($sock) $data
if {[eof $sock]} {
chan event $sock readable {}
set [namespace current]::reply($sock) $buffer($sock)
unset buffer($sock)
}
}
###
# Modify the reply class to return plain text
###
tool::define ::httpd::reply {
property reply_headers_default {
Status {200 OK}
Content-Type {text/plain}
Connection close
}
method reset {} {
my variable reply_body
my reply replace [my meta cget reply_headers_default]
set reply_body {}
}
method error {code {msg {}} {errorInfo {}}} {
my http_info set HTTP_ERROR $code
my reset
my variable error_codes
set qheaders [my http_info dump]
if {![info exists error_codes($code)]} {
set errorstring "Unknown Error Code"
} else {
set errorstring $error_codes($code)
}
dict with qheaders {}
my reply replace {}
my reply set Status "$code $errorstring"
my reply set Content-Type text/plain
my puts "$code $errorstring"
}
}
tool::define ::test::content.echo {
method content {} {
my variable reply_body
set reply_body [my PostData [my request get Content-Length]]
#puts [list REPLY BODY WAS $reply_body]
}
}
tool::define ::test::content.file {
superclass ::httpd::content::file
method content {} {
my reset
my variable reply_file
set reply_file [file join $::DEMOROOT pkgIndex.tcl]
}
}
tool::define ::test::content.time {
method content {} {
my variable reply_body
set reply_body [clock seconds]
}
}
tool::define ::test::content.error {
method content {} {
error {The programmer asked me to die this way}
}
}
tool::define ::httpd::test::reply {
superclass ::httpd::reply ::test::content.echo
}
###
# Build the server
###
set DIR [file dirname [file normalize [info script]]]
set ::DEMOROOT $DIR
::httpd::server create TESTAPP port 10001
TESTAPP add_uri / [list mixin ::test::content.echo]
TESTAPP add_uri /echo [list mixin ::test::content.echo]
TESTAPP add_uri /file [list mixin ::test::content.file]
TESTAPP add_uri /time [list mixin ::test::content.time]
TESTAPP add_uri /error [list mixin ::test::content.error]
# Catch all
#TESTAPP add_uri * [list mixin httpd::content.echo]
test httpd-client-0001 {Do an echo request} {
set reply [::httpd::test::send 10001 {POST /echo HTTP/1.0} {} {THIS IS MY CODE}]
::httpd::test::compare $reply {HTTP/1.0 200 OK
Content-Type: text/plain
Connection: close
Content-Length: 15
THIS IS MY CODE}
} {}
test httpd-client-0002 {Do another echo request} {
set reply [::httpd::test::send 10001 {POST /echo HTTP/1.0} {} {THOUGH THERE ARE MANY LIKE IT}]
::httpd::test::compare $reply {HTTP/1.0 200 OK
Content-Type: text/plain
Connection: close
Content-Length: 29
THOUGH THERE ARE MANY LIKE IT}
} {}
test httpd-client-0003 {Do another echo request} {
set reply [::httpd::test::send 10001 {POST /echo HTTP/1.0} {} {THIS ONE ALONE IS MINE}]
::httpd::test::compare $reply {HTTP/1.0 200 OK
Content-Type: text/plain
Connection: close
Content-Length: 22
THIS ONE ALONE IS MINE}
} {}
test httpd-client-0004 {URL Generates Error} {
set reply [::httpd::test::send 10001 {POST /error HTTP/1.0} {} {THIS ONE ALONE IS MINE}]
::httpd::test::compare $reply {HTTP/1.0 500 Server Internal Error
Content-Type: text/plain
Connection: close
Content-Length: 26
500 Server Internal Error}
} {}
set checkreply [subst {HTTP/1.0 200 OK
Content-Type: text/plain
Connection: close
Content-Length: 10
[clock seconds]}]
test httpd-client-0005 {URL Different output with a different request} {
set reply [::httpd::test::send 10001 {POST /time HTTP/1.0} {} {THIS ONE ALONE IS MINE}]
::httpd::test::compare $reply $checkreply
} {}
set fin [open [file join $DEMOROOT pkgIndex.tcl] r]
set replyfile [read $fin]
close $fin
set checkreply "HTTP/1.0 200 OK
Content-Type: text/plain
Connection: close
Content-Length: [string length $replyfile]
$replyfile"
test httpd-client-0006 {Return a file} {
set reply [::httpd::test::send 10001 {GET /file HTTP/1.0} {} {}]
::httpd::test::compare $reply $checkreply
} {}
# -------------------------------------------------------------------------
testsuiteCleanup
# Local variables:
# mode: tcl
# indent-tabs-mode: nil
# End:
|
Changes to modules/httpd/pkgIndex.tcl.
|
| < < < < < < < < < | | | | | 1 2 3 4 |
if {![package vsatisfies [package provide Tcl] 8.6]} {return}
package ifneeded httpd 4.1.0 [list source [file join $dir httpd.tcl]]
|
Deleted modules/httpd/scgi-app.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted modules/httpd/scgi.test.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Added modules/httpd/src/core.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 | ### # Author: Sean Woods, [email protected] ## # Adapted from the "minihttpd.tcl" file distributed with Tclhttpd # # The working elements have been updated to operate as a TclOO object # running with Tcl 8.6+. Global variables and hard coded tables are # now resident with the object, allowing this server to be more easily # embedded another program, as well as be adapted and extended to # support the SCGI module ### package require uri package require cron package require coroutine package require tool package require mime package require fileutil package require websocket ### # Standard library of HTTP/SCGI content # Each of these classes are intended to be mixed into # either an HTTPD or SCGI reply ### package require Markdown package require fileutil::magic::filetype namespace eval httpd::content {} namespace eval ::url {} namespace eval ::httpd {} namespace eval ::scgi {} |
Added modules/httpd/src/dispatch.tcl.
Added modules/httpd/src/file.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 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 |
###
# Class to deliver Static content
# When utilized, this class is fed a local filename
# by the dispatcher
###
::tool::define ::httpd::content::file {
method FileName {} {
set uri [string trimleft [my http_info get REQUEST_URI] /]
set path [my http_info get path]
set prefix [my http_info get prefix]
set fname [string range $uri [string length $prefix] end]
if {$fname in "{} index.html index.md index"} {
return $path
}
if {[file exists [file join $path $fname]]} {
return [file join $path $fname]
}
if {[file exists [file join $path $fname.md]]} {
return [file join $path $fname.md]
}
if {[file exists [file join $path $fname.html]]} {
return [file join $path $fname.html]
}
if {[file exists [file join $path $fname.tml]]} {
return [file join $path $fname.tml]
}
return {}
}
method DirectoryListing {local_file} {
set uri [string trimleft [my http_info get REQUEST_URI] /]
set path [my http_info get path]
set prefix [my http_info get prefix]
set fname [string range $uri [string length $prefix] end]
my puts "<HTML><HEAD><TITLE>Listing of /$fname/</TITLE></HEAD><BODY>"
my puts "Path: $path<br>"
my puts "Prefs: $prefix</br>"
my puts "URI: $uri</br>"
my puts "Listing contents of /$fname/"
my puts "<TABLE>"
if {$prefix ni {/ {}}} {
set updir [file dirname $prefix]
if {$updir ne {}} {
my puts "<TR><TD><a href=\"/$updir\">..</a></TD><TD></TD></TR>"
}
}
foreach file [glob -nocomplain [file join $local_file *]] {
if {[file isdirectory $file]} {
my puts "<TR><TD><a href=\"[file join / $uri [file tail $file]]\">[file tail $file]/</a></TD><TD></TD></TR>"
} else {
my puts "<TR><TD><a href=\"[file join / $uri [file tail $file]]\">[file tail $file]</a></TD><TD>[file size $file]</TD></TR>"
}
}
my puts "</TABLE></BODY></HTML>"
}
method dispatch {newsock datastate} {
# No need to process the rest of the headers
my variable chan dipatched_time
set dispatched_time [clock seconds]
my http_info replace $datastate
set chan $newsock
my content
my output
}
method content {} {
###
# When delivering static content, allow web caches to save
###
my reply set Cache-Control {max-age=3600}
my variable reply_file
set local_file [my FileName]
if {$local_file eq {} || ![file exist $local_file]} {
my <server> log httpNotFound [my http_info get REQUEST_URI]
tailcall my error 404 {Not Found}
}
if {[file isdirectory $local_file]} {
###
# Produce an index page
###
set idxfound 0
foreach name {
index.html
index.tml
index.md
} {
if {[file exists [file join $local_file $name]]} {
set idxfound 1
set local_file [file join $local_file $name]
break
}
}
if {!$idxfound} {
tailcall my DirectoryListing $local_file
}
}
switch [file extension $local_file] {
.md {
package require Markdown
my reply set Content-Type {text/html; charset=ISO-8859-1}
set mdtxt [::fileutil::cat $local_file]
my puts [::Markdown::convert $mdtxt]
}
.tml {
my reply set Content-Type {text/html; charset=ISO-8859-1}
set tmltxt [::fileutil::cat $local_file]
set headers [my http_info dump]
dict with headers {}
my puts [subst $tmltxt]
}
default {
###
# Assume we are returning a binary file
###
my reply set Content-Type [::fileutil::magic::filetype $local_file]
set reply_file $local_file
}
}
}
###
# Output the result or error to the channel
# and destroy this object
###
method DoOutput {} {
my variable chan
chan event $chan writable {}
my variable reply_body reply_file reply_chan chan
chan configure $chan -translation {binary binary}
if {![info exists reply_file]} {
###
# Return dynamic content
###
if {![info exists reply_body]} {
append result [my reply output]
} else {
set reply_body [string trim $reply_body]
my reply set Content-Length [string length $reply_body]
append result [my reply output] \n
append result $reply_body
chan puts -nonewline $chan $result
chan flush $chan
}
my destroy
} else {
###
# Return a stream of data from a file
###
set size [file size $reply_file]
my reply set Content-Length $size
append result [my reply output] \n
chan puts -nonewline $chan $result
set reply_chan [open $reply_file r]
chan configure $reply_chan -translation {binary binary}
chan copy $reply_chan $chan -command [namespace code [list my TransferComplete $reply_chan]]
}
}
}
|
Added modules/httpd/src/proxy.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 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 |
# Act as a proxy server
::tool::define ::httpd::content::proxy {
method proxy_info {} {
###
# This method should check if a process is launched
# or launch it if needed, and return a list of
# HOST PORT PROXYURI
###
# return {localhost 8016 /some/path}
error unimplemented
}
method content {} {
my variable chan sock rawrequest
set sockinfo [my proxy_info]
if {$sockinfo eq {}} {
tailcall my error 404 {Not Found}
}
lassign $sockinfo proxyhost proxyport proxyscript
set sock [::socket $proxyhost $proxyport]
chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096
chan configure $sock -translation {auto crlf} -blocking 1 -buffering line
# Pass along our modified METHOD URI PROTO
chan puts $sock "$proxyscript"
# Pass along the headers as we saw them
chan puts $sock $rawrequest
set length [my http_info get CONTENT_LENGTH]
if {$length} {
###
# Send any POST/PUT/etc content
###
chan copy $chan $sock -size $length
}
chan flush $sock
###
# Wake this object up after the proxied process starts to respond
###
chan configure $sock -translation {auto crlf} -blocking 1 -buffering line
chan event $sock readable [namespace code {my output}]
}
method DoOutput {} {
my variable chan sock
chan event $chan writable {}
if {![info exists sock] || [my http_info getnull HTTP_ERROR] ne {}} {
###
# If something croaked internally, handle this page as a normal reply
###
next
return
}
set length 0
chan configure $sock -translation {crlf crlf} -blocking 1
set replystatus [gets $sock]
set replyhead [my HttpHeaders $sock]
set replydat [my MimeParse $replyhead]
###
# Pass along the status line and MIME headers
###
set replybuffer "$replystatus\n"
append replybuffer $replyhead
chan configure $chan -translation {auto crlf} -blocking 0 -buffering full -buffersize 4096
chan puts $chan $replybuffer
###
# Output the body
###
chan configure $sock -translation binary -blocking 0 -buffering full -buffersize 4096
chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096
set length [dict get $replydat CONTENT_LENGTH]
if {$length} {
###
# Send any POST/PUT/etc content
###
chan copy $sock $chan -command [namespace code [list my TransferComplete $sock]]
} else {
my destroy
}
}
}
|
Added modules/httpd/src/reply.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 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 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 |
###
# Define the reply class
###
::tool::define ::httpd::reply {
property reply_headers_default {
Status {200 OK}
Content-Size 0
Content-Type {text/html; charset=ISO-8859-1}
Cache-Control {no-cache}
Connection close
}
array error_codes {
200 {Data follows}
204 {No Content}
302 {Found}
304 {Not Modified}
400 {Bad Request}
401 {Authorization Required}
403 {Permission denied}
404 {Not Found}
408 {Request Timeout}
411 {Length Required}
419 {Expectation Failed}
500 {Server Internal Error}
501 {Server Busy}
503 {Service Unavailable}
504 {Service Temporarily Unavailable}
505 {Internal Server Error}
}
constructor {ServerObj args} {
my variable chan
oo::objdefine [self] forward <server> $ServerObj
foreach {field value} [::oo::meta::args_to_options {*}$args] {
my meta set config $field: $value
}
}
###
# clean up on exit
###
destructor {
my close
}
method close {} {
my variable chan
if {[info exists chan] && $chan ne {}} {
catch {flush $chan}
catch {close $chan}
}
}
method HttpHeaders {sock {debug {}}} {
set result {}
###
# Set up a channel event to stream the data from the socket line by
# line. When a blank line is read, the HttpHeaderLine method will send
# a flag which will terminate the vwait.
#
# We do this rather than entering blocking mode to prevent the process
# from locking up if it's starved for input. (Or in the case of the test
# suite, when we are opening a blocking channel on the other side of the
# socket back to ourselves.)
###
chan configure $sock -translation {auto crlf} -blocking 0 -buffering line
try {
while 1 {
set readCount [::coroutine::util::gets_safety $sock 4096 line]
if {$readCount==0} break
append result $line \n
}
} trap {POSIX EBUSY} {err info} {
# Happens...
} on error {err info} {
puts "ERROR $err"
puts [dict print $info]
tailcall my destroy
}
###
# Return our buffer
###
return $result
}
method dispatch {newsock datastate} {
my http_info replace $datastate
my variable chan rawrequest dipatched_time
set chan $newsock
chan event $chan readable {}
chan configure $chan -translation {auto crlf} -buffering line
set dispatched_time [clock seconds]
try {
# Initialize the reply
my reset
# Process the incoming MIME headers
set rawrequest [my HttpHeaders $chan]
my request parse $rawrequest
# Invoke the URL implementation.
my content
} on error {err info} {
dict print $info
puts stderr $::errorInfo
my error 500 $err [dict get $info -errorinfo]
} finally {
my output
}
}
dictobj http_info http_info {
initialize {
CONTENT_LENGTH 0
}
netstring {
set result {}
foreach {name value} $%VARNAME% {
append result $name \x00 $value \x00
}
return "[string length $result]:$result,"
}
}
method error {code {msg {}} {errorInfo {}}} {
my http_info set HTTP_ERROR $code
my reset
my variable error_codes
set qheaders [my http_info dump]
if {![info exists error_codes($code)]} {
set errorstring "Unknown Error Code"
} else {
set errorstring $error_codes($code)
}
dict with qheaders {}
my reply replace {}
my reply set Status "$code $errorstring"
my reply set Content-Type {text/html; charset=ISO-8859-1}
my puts "
<HTML>
<HEAD>
<TITLE>$code $errorstring</TITLE>
</HEAD>
<BODY>"
if {$msg eq {}} {
my puts "
Got the error <b>$code $errorstring</b>
<p>
while trying to obtain $REQUEST_URI
"
} else {
my puts "
Guru meditation #[clock seconds]
<p>
The server encountered an internal error:
<p>
<pre>$msg</pre>
<p>
For deeper understanding:
<p>
<pre>$errorInfo</pre>
"
}
my puts "</BODY>
</HTML>"
}
###
# REPLACE ME:
# This method is the "meat" of your application.
# It writes to the result buffer via the "puts" method
# and can tweak the headers via "meta put header_reply"
###
method content {} {
my puts "<HTML>"
my puts "<BODY>"
my puts "<H1>HELLO WORLD!</H1>"
my puts "</BODY>"
my puts "</HTML>"
}
method EncodeStatus {status} {
return "HTTP/1.0 $status"
}
method output {} {
my variable chan
chan event $chan writable [namespace code {my DoOutput}]
}
###
# Output the result or error to the channel
# and destroy this object
###
method DoOutput {} {
my variable reply_body chan
chan event $chan writable {}
catch {
chan configure $chan -translation {binary binary}
###
# Return dynamic content
###
set length [string length $reply_body]
set result {}
if {${length} > 0} {
my reply set Content-Length [string length $reply_body]
append result [my reply output] \n
append result $reply_body
} else {
append result [my reply output]
}
chan puts -nonewline $chan $result
} err
puts $err
my destroy
}
method Url_Decode data {
regsub -all {\+} $data " " data
regsub -all {([][$\\])} $data {\\\1} data
regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data {[format %c 0x\1]} data
return [subst $data]
}
method FormData {} {
my variable chan formdata rawrequest
# Run this only once
if {[info exists formdata]} {
return $formdata
}
set rawrequest [my HttpHeaders $chan]
my request parse $rawrequest
if {![my request exists Content-Length]} {
set length 0
} else {
set length [my request get Content-Length]
}
set formdata {}
if {[my http_info get REQUEST_METHOD] in {"POST" "PUSH"}} {
set rawtype [my request get Content-Type]
if {[string toupper [string range $rawtype 0 8]] ne "MULTIPART"} {
set type $rawtype
} else {
set type multipart
}
switch $type {
multipart {
###
# Ok, Multipart MIME is troublesome, farm out the parsing to a dedicated tool
###
set body $rawrequest
append body \n [my PostData $length]
set token [::mime::initialize -string $body]
foreach item [::mime::getheader $token -names] {
dict set formdata $item [::mime::getheader $token $item]
}
foreach item {content encoding params parts size} {
dict set formdata MIME_[string toupper $item] [::mime::getproperty $token $item]
}
dict set formdata MIME_TOKEN $token
}
application/x-www-form-urlencoded {
# These foreach loops are structured this way to ensure there are matched
# name/value pairs. Sometimes query data gets garbled.
set body [my PostData $length]
set result {}
foreach pair [split $body "&"] {
foreach {name value} [split $pair "="] {
lappend formdata [my Url_Decode $name] [my Url_Decode $value]
}
}
}
}
} else {
foreach pair [split [my http_info getnull QUERY_STRING] "&"] {
foreach {name value} [split $pair "="] {
lappend formdata [my Url_Decode $name] [my Url_Decode $value]
}
}
}
return $formdata
}
###
# Minimalist MIME Header Parser
###
method MimeParse mimetext {
set data(mimeorder) {}
foreach line [split $mimetext \n] {
# This regexp picks up
# key: value
# MIME headers. MIME headers may be continue with a line
# that starts with spaces or a tab
if {[string length [string trim $line]]==0} break
if {[regexp {^([^ :]+):[ ]*(.*)} $line dummy key value]} {
# The following allows something to
# recreate the headers exactly
lappend data(headerlist) $key $value
# The rest of this makes it easier to pick out
# headers from the data(mime,headername) array
#set key [string tolower $key]
if {[info exists data(mime,$key)]} {
append data(mime,$key) ,$value
} else {
set data(mime,$key) $value
lappend data(mimeorder) $key
}
set data(key) $key
} elseif {[regexp {^[ ]+(.*)} $line dummy value]} {
# Are there really continuation lines in the spec?
if {[info exists data(key)]} {
append data(mime,$data(key)) " " $value
} else {
my error 400 "INVALID HTTP HEADER FORMAT: $line"
tailcall my output
}
} else {
my error 400 "INVALID HTTP HEADER FORMAT: $line"
tailcall my output
}
}
###
# To make life easier for our SCGI implementation rig things
# such that CONTENT_LENGTH is always first
###
set result {}
dict set result Content-Length 0
foreach {key} $data(mimeorder) {
dict set result $key $data(mime,$key)
}
return $result
}
method PostData {length} {
my variable postdata
# Run this only once
if {[info exists postdata]} {
return $postdata
}
set postdata {}
if {[my http_info get REQUEST_METHOD] in {"POST" "PUSH"}} {
my variable chan
chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096
set postdata [::coroutine::util::read $chan $length]
}
return $postdata
}
method TransferComplete args {
foreach c $args {
catch {close $c}
}
my destroy
}
###
# Append to the result buffer
###
method puts line {
my variable reply_body
append reply_body $line \n
}
dictobj request request {
parse {
set request [my MimeParse [lindex $args 0]]
}
}
dictobj reply reply {
output {
set result {}
if {![dict exists $reply Status]} {
set status {200 OK}
} else {
set status [dict get $reply Status]
}
set result "[my EncodeStatus $status]\n"
foreach {f v} $reply {
if {$f in {Status}} continue
append result "[string trimright $f :]: $v\n"
}
#append result \n
return $result
}
}
###
# Reset the result
###
method reset {} {
my variable reply_body
my reply replace [my meta cget reply_headers_default]
my reply set Server [my <server> cget server_string]
my reply set Date [my timestamp]
set reply_body {}
}
###
# Return true of this class as waited too long to respond
###
method timeOutCheck {} {
my variable dipatched_time
if {([clock seconds]-$dipatched_time)>30} {
###
# Something has lasted over 2 minutes. Kill this
###
my error 505 {Operation Timed out}
my output
}
}
###
# Return a timestamp
###
method timestamp {} {
return [clock format [clock seconds] -format {%a, %d %b %Y %T %Z}]
}
}
|
Added modules/httpd/src/scgi.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 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 |
###
# Return data from an SCGI process
###
::tool::define ::httpd::content::scgi {
method scgi_info {} {
###
# This method should check if a process is launched
# or launch it if needed, and return a list of
# HOST PORT SCRIPT_NAME
###
# return {localhost 8016 /some/path}
error unimplemented
}
method content {} {
my variable sock chan
set sockinfo [my scgi_info]
if {$sockinfo eq {}} {
my error 404 {Not Found}
return
}
lassign $sockinfo scgihost scgiport scgiscript
set sock [::socket $scgihost $scgiport]
chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096
chan configure $sock -translation binary -blocking 0 -buffering full -buffersize 4096
###
# Convert our query headers into netstring format.
###
if {![my request exists Content-Length]} {
set length 0
} else {
set length [my request get Content-Length]
}
set block {}
append block CONTENT_LENGTH \x00 $length \x00
append block SCGI \x00 1.0 \x00
append block SCRIPT_NAME \x00 $scgiscript \x00
set info {}
foreach {f v} [my http_info dump] {
dict set info $f $v
}
foreach {f v} [my request dump] {
if {[string range $f 0 3] ne "HTTP"} {
set f HTTP_[string toupper $f]
}
dict set info $f $v
}
foreach {f v} $info {
if {$f in {CONTENT_LENGTH HTTP_STATUS}} continue
append block [string toupper $f] \x00 $v \x00
}
chan puts -nonewline $sock "[string length $block]:$block,"
if {$length} {
###
# Send any POST/PUT/etc content
###
chan copy $chan $sock -size $length
}
chan flush $sock
###
# Wake this object up after the SCGI process starts to respond
###
#chan configure $sock -translation {auto crlf} -blocking 0 -buffering line
chan event $sock readable [namespace code {my output}]
}
method output {} {
if {[my http_info getnull HTTP_ERROR] ne {}} {
###
# If something croaked internally, handle this page as a normal reply
###
next
}
my variable sock chan
set replyhead [my HttpHeaders $sock]
set replydat [my MimeParse $replyhead]
if {![dict exists $replydat CONTENT_LENGTH]} {
set length 0
} else {
set length [dict get $replydat CONTENT_LENGTH]
}
###
# Convert the Status: header from the SCGI service to
# a standard service reply line from a web server, but
# otherwise spit out the rest of the headers verbatim
###
set replybuffer "HTTP/1.1 [dict get $replydat HTTP_STATUS]\n"
append replybuffer $replyhead
chan configure $chan -translation {auto crlf} -blocking 0 -buffering full -buffersize 4096
puts $chan $replybuffer
###
# Output the body
###
chan configure $sock -translation binary -blocking 0 -buffering full -buffersize 4096
chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096
if {$length} {
###
# Send any POST/PUT/etc content
###
chan copy $sock $chan -command [namespace code [list my TransferComplete $sock]]
} else {
catch {close $sock}
chan flush $chan
my destroy
}
}
###
# Todo: Shorten this to a http->SCGI header formatter
# And eliminate the duplicate implementation
###
method MimeParse mimetext {
set data(mimeorder) {}
foreach line [split $mimetext \n] {
# This regexp picks up
# key: value
# MIME headers. MIME headers may be continue with a line
# that starts with spaces or a tab
if {[string length [string trim $line]]==0} break
if {[regexp {^([^ :]+):[ ]*(.*)} $line dummy key value]} {
# The following allows something to
# recreate the headers exactly
lappend data(headerlist) $key $value
# The rest of this makes it easier to pick out
# headers from the data(mime,headername) array
#set key [string tolower $key]
if {[info exists data(mime,$key)]} {
append data(mime,$key) ,$value
} else {
set data(mime,$key) $value
lappend data(mimeorder) $key
}
set data(key) $key
} elseif {[regexp {^[ ]+(.*)} $line dummy value]} {
# Are there really continuation lines in the spec?
if {[info exists data(key)]} {
append data(mime,$data(key)) " " $value
} else {
my error 400 "INVALID HTTP HEADER FORMAT: $line"
tailcall my output
}
} else {
my error 400 "INVALID HTTP HEADER FORMAT: $line"
tailcall my output
}
}
###
# To make life easier for our SCGI implementation rig things
# such that CONTENT_LENGTH is always first
###
set result {
CONTENT_LENGTH 0
}
foreach {key} $data(mimeorder) {
switch $key {
Content-Length {
dict set result CONTENT_LENGTH $data(mime,$key)
}
Content-Type {
dict set result CONTENT_TYPE $data(mime,$key)
}
default {
dict set result HTTP_[string map {"-" "_"} [string toupper $key]] $data(mime,$key)
}
}
}
return $result
}
}
|
Added modules/httpd/src/server.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 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 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 |
###
# An httpd server with a template engine
# and a shim to insert URL domains
###
::tool::define ::httpd::server {
option port {default: auto}
option myaddr {default: 127.0.0.1}
option server_string [list default: [list TclHttpd $::httpd::version]]
option server_name [list default: [list [info hostname]]]
option doc_root {default {}}
property socket buffersize 32768
property socket translation {auto crlf}
property reply_class ::httpd::reply
array template
variable url_patterns {}
constructor {args} {
my configure {*}$args
my start
}
destructor {
my stop
}
method add_uri {pattern info} {
my variable url_patterns
dict set url_patterns $pattern $info
}
method connect {sock ip port} {
###
# If an IP address is blocked
# send a "go to hell" message
###
if {[my Validate_Connection $sock $ip]} {
catch {close $sock}
return
}
set uuid [::tool::uuid_short]
chan configure $sock \
-blocking 0 \
-translation {auto crlf} \
-buffering line
set coro [coroutine [namespace current]::CORO$uuid {*}[namespace code [list my Connect $uuid $sock $ip]]]
chan event $sock readable $coro
}
method Connect {uuid sock ip} {
yield [info coroutine]
chan event $sock readable {}
my counter url_hit
set line {}
try {
set readCount [::coroutine::util::gets_safety $sock 4096 line]
dict set query REMOTE_ADDR $ip
dict set query REQUEST_METHOD [lindex $line 0]
set uriinfo [::uri::split [lindex $line 1]]
dict set query REQUEST_URI [lindex $line 1]
dict set query REQUEST_PATH [dict get $uriinfo path]
dict set query REQUEST_VERSION [lindex [split [lindex $line end] /] end]
if {[dict get $uriinfo host] eq {}} {
if {$ip eq "127.0.0.1"} {
dict set query HTTP_HOST localhost
} else {
dict set query HTTP_HOST [info hostname]
}
} else {
dict set query HTTP_HOST [dict get $uriinfo host]
}
dict set query HTTP_CLIENT_IP $ip
dict set query QUERY_STRING [dict get $uriinfo query]
dict set query REQUEST_RAW $line
} on error {err errdat} {
puts stderr $err
my log HttpError $line
catch {close $sock}
return
}
try {
set reply [my dispatch $query]
if {[llength $reply]} {
if {[dict exists $reply class]} {
set class [dict get $reply class]
} else {
set class [my cget reply_class]
}
set pageobj [$class create [namespace current]::reply$uuid [self]]
if {[dict exists $reply mixin]} {
oo::objdefine $pageobj mixin [dict get $reply mixin]
}
$pageobj dispatch $sock $reply
my log HttpAccess $line
} else {
try {
my log HttpMissing $line
chan puts $sock "HTTP/1.0 404 NOT FOUND"
dict with query {}
set body [subst [my template notfound]]
chan puts $sock "Content-length: [string length $body]"
chan puts $sock
chan puts $sock $body
} on error {err errdat} {
puts stderr "FAILED ON 404: $err"
} finally {
catch {chan close $sock}
catch {destroy $pageobj}
}
}
} on error {err errdat} {
try {
puts stderr [dict print $errdat]
chan puts $sock "HTTP/1.0 505 INTERNAL ERROR"
dict with query {}
set body [subst [my template internal_error]]
chan puts $sock "Content-length: [string length $body]"
chan puts $sock
chan puts $sock $body
my log HttpError $line
} on error {err errdat} {
puts stderr "FAILED ON 505: $::errorInfo"
} finally {
catch {chan close $sock}
catch {destroy $pageobj}
}
}
}
method counter which {
my variable counters
incr counters($which)
}
###
# Clean up any process that has gone out for lunch
###
method CheckTimeout {} {
foreach obj [info commands [namespace current]::reply::*] {
try {
$obj timeOutCheck
} on error {} {
catch {$obj destroy}
}
}
}
###
# Route a request to the appropriate handler
###
method dispatch {data} {
set reply $data
set uri [dict get $data REQUEST_PATH]
# Search from longest pattern to shortest
my variable url_patterns
foreach {pattern info} $url_patterns {
if {[string match ${pattern} /$uri]} {
set reply [dict merge $data $info]
if {![dict exists $reply prefix]} {
dict set reply prefix [my PrefixNormalize $pattern]
}
return $reply
}
}
set doc_root [my cget doc_root]
if {$doc_root ne {}} {
###
# Fall back to doc_root handling
###
dict set reply prefix {}
dict set reply path $doc_root
dict set reply mixin httpd::content::file
return $reply
}
return {}
}
method log args {
# Do nothing for now
}
method port_listening {} {
my variable port_listening
return $port_listening
}
method PrefixNormalize prefix {
set prefix [string trimright $prefix /]
set prefix [string trimright $prefix *]
set prefix [string trimright $prefix /]
return $prefix
}
method start {} {
# Build a namespace to contain replies
namespace eval [namespace current]::reply {}
my variable socklist port_listening
set port [my cget port]
if { $port in {auto {}} } {
package require nettool
set port [::nettool::allocate_port 8015]
}
set port_listening $port
set myaddr [my cget myaddr]
puts [list [self] listening on $port $myaddr]
if {$myaddr ni {all any * {}}} {
foreach ip $myaddr {
lappend socklist [socket -server [namespace code [list my connect]] -myaddr $ip $port]
}
} else {
lappend socklist [socket -server [namespace code [list my connect]] $port]
}
::cron::every [self] 120 [namespace code {my CheckTimeout}]
}
method stop {} {
my variable socklist
if {[info exists socklist]} {
foreach sock $socklist {
catch {close $sock}
}
}
set socklist {}
::cron::cancel [self]
}
method template page {
my variable template
if {[info exists template($page)]} {
return $template($page)
}
set template($page) [my TemplateSearch $page]
return $template($page)
}
method TemplateSearch page {
set doc_root [my cget doc_root]
if {$doc_root ne {} && [file exists [file join $doc_root $page.tml]]} {
return [::fileutil::cat [file join $doc_root $page.tml]]
}
if {$doc_root ne {} && [file exists [file join $doc_root $page.html]]} {
return [::fileutil::cat [file join $doc_root $page.html]]
}
switch $page {
internal_error {
return {
<HTML>
<HEAD><TITLE>505: Internal Server Error</TITLE></HEAD>
<BODY>
Error serving <b>${REQUEST_URI}</b>:
<p>
The server encountered an internal server error
<pre><code>
$::errorInfo
</code></pre>
</BODY>
</HTML>
}
}
notfound {
return {
<HTML>
<HEAD><TITLE>404: Page Not Found</TITLE></HEAD>
<BODY>
The page you are looking for: <b>${REQUEST_URI}</b> does not exist.
</BODY>
</HTML>
}
}
}
}
###
# Return true if this IP address is blocked
# The socket will be closed immediately after returning
# This handler is welcome to send a polite error message
###
method Validate_Connection {sock ip} {
return 0
}
}
###
# Provide a backward compadible alias
###
::tool::define ::httpd::server::dispatch {
superclass ::httpd::server
}
|
Added modules/httpd/src/websocket.tcl.
> > > > > > | 1 2 3 4 5 6 |
###
# Upgrade a connection to a websocket
###
::tool::define ::httpd::content::websocket {
}
|
Deleted modules/nettool/available_ports.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Added modules/nettool/build.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 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 |
set here [file dirname [file normalize [file join [pwd] [info script]]]]
set version 0.5.2
set tclversion 8.5
set module [file tail $here]
dict set map %module% $module
dict set map %version% $version
dict set map %tclversion% $tclversion
dict set map { } {}
dict set map "\t" { }
###
# Rebuild the available ports file
###
###
# topic: 65dfea29d424543cdfc0e1cbf9f90295ef6214cb
# description:
# This script digests the raw data from
# http://www.iana.org/assignments/service-names-port-numbers/service-names-port-numbers.csv
# And produces a summary
###
proc ::record {service port type usage} {
if { $port eq {} } return
if {$service eq {} && $type in {tcp udp {}} && $usage != "Reserved"} {
ladd ::available_port($port) {*}$type
return
}
unset -nocomplain ::available_port($port)
lappend ::busy_port($port) $type $usage
#puts [list busy $service $port $type $usage]
}
for {set x 0} {$x < 65536} {incr x} {
set ::available_port($x) {}
}
package require dicttool
package require csv
set fin [open [file join $here src service-names-port-numbers.csv] r]
set headers [gets $fin]
set thisline {}
while {[gets $fin line]>=0} {
append thisline \n$line
if {![csv::iscomplete $line]} continue
set lline [csv::split $line]
if [catch {
set service [lindex $lline 0]
set port [lindex $lline 1]
set type [lindex $lline 2]
set usage [lindex $lline 3]
}] continue
if {![string is integer -strict $port]} {
set startport [lindex [split $port -] 0]
set endport [lindex [split $port -] 1]
if {[string is integer -strict $startport] && [string is integer -strict $endport]} {
for {set i $startport} {$i<=$endport} {incr i} {
record $service $i $type $usage
}
continue
}
}
record $service $port $type $usage
}
close $fin
set fout [open [file join $here available_ports.tcl] w]
puts $fout {
namespace eval ::nettool {
set blocks {}
}
}
set startport 0
set endport 0
foreach port [lsort -integer [array names available_port]] {
set avail $available_port($port)
# Don't bother with ports below 1024
# Most operating systems won't let us access them anyway
if {$port < 1024 } continue
if { $endport == ($port-1) } {
set endport $port
continue
}
if {$startport} {
puts $fout [list lappend ::nettool::blocks $startport $endport]
}
set startport $port
set endport $port
}
if { $startport } {
puts $fout [list lappend ::nettool::blocks $startport $endport]
}
close $fout
set fout [open [file join $here [file tail $module].tcl] w]
puts $fout [string map $map {###
# Amalgamated package for %module%
# Do not edit directly, tweak the source in src/ and rerun
# build.tcl
###
package require Tcl %tclversion%
package provide %module% %version%
namespace eval ::%module% {}
set ::%module%::version %version%
}]
# Track what files we have included so far
set loaded {}
# These files must be loaded in a particular order
foreach file {
core.tcl
generic.tcl
available_ports.tcl
locateport.tcl
platform_unix.tcl
platform_unix_linux.tcl
platform_unix_macosx.tcl
platform_windows.tcl
platform_windows_twapi.tcl
} {
lappend loaded $file
set fin [open [file join $here src $file] r]
puts $fout "###\n# START: [file tail $file]\n###"
puts $fout [read $fin]
close $fin
puts $fout "###\n# END: [file tail $file]\n###"
}
# These files can be loaded in any order
foreach file [glob [file join $here src *.tcl]] {
if {[file tail $file] in $loaded} continue
lappend loaded $file
set fin [open [file join $here src $file] r]
puts $fout "###\n# START: [file tail $file]\n###"
puts $fout [read $fin]
close $fin
puts $fout "###\n# END: [file tail $file]\n###"
}
# Provide some cleanup and our final package provide
puts $fout [string map $map {
namespace eval ::%module% {
namespace export *
}
###
# Perform any one-time discovery we might need
###
::nettool::discover
::nettool::init
}]
close $fout
###
# Build our pkgIndex.tcl file
###
set fout [open [file join $here pkgIndex.tcl] w]
puts $fout [string map $map {
if {![package vsatisfies [package provide Tcl] %tclversion%]} {return}
# Backward compatible alias
package ifneeded nettool::available_ports 0.1 {package require %module% ; package provide nettool::available_ports 0.1}
package ifneeded %module% %version% [list source [file join $dir %module%.tcl]]
}]
close $fout
|
Deleted modules/nettool/generic.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted modules/nettool/locateport.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to modules/nettool/nettool.man.
1 2 3 4 5 |
[comment {-*- tcl -*- doctools manpage}]
[vset PACKAGE_VERSION 0.5.2]
[manpage_begin nettool n [vset PACKAGE_VERSION]]
[keywords {nettool}]
[keywords {odie}]
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 |
[comment {-*- tcl -*- doctools manpage}]
[vset PACKAGE_VERSION 0.5.2]
[manpage_begin nettool n [vset PACKAGE_VERSION]]
[keywords {nettool}]
[keywords {odie}]
[copyright {2015-2018 Sean Woods <[email protected]>}]
[moddesc {nettool}]
[titledesc {Tools for networked applications}]
[category System]
[require Tcl 8.5]
[require nettool [opt [vset PACKAGE_VERSION]]]
[require twapi 3.1]
[require ip 0.1]
|
| ︙ | ︙ |
Changes to modules/nettool/nettool.tcl.
1 2 3 4 5 6 7 | # @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 | > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
###
# 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.2
namespace eval ::nettool {}
set ::nettool::version 0.5.2
###
# 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
|
| ︙ | ︙ | |||
50 51 52 53 54 55 56 | 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] | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | < > | | | < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | 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 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 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 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 |
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]
###
# END: core.tcl
###
###
# START: generic.tcl
###
::namespace eval ::nettool {}
###
# topic: 825cd25953c2cc896a96006b7f454e00
# title: Return pairings of MAC numbers to IP addresses on the local network
###
proc ::nettool::arp_table {} {}
###
# topic: 92ebbfa155883ad41c37d3f843392be4
# title: Return list of broadcast addresses for local networks
###
proc ::nettool::broadcast_list {} {
return 127.0.0.1
}
###
# topic: 15d9bc96ec6ce31d4c8f99a425a9c02c
# description: Return Processor utilization
###
proc ::nettool::busy {} {}
###
# topic: 187cfa1827097c5cdf1c40c656cedfcc
# description: Return time since booted
###
proc ::nettool::cpuinfo {} {}
###
# Clear discovered info
###
proc ::nettool::discover {} {
unset -nocomplain ::nettool::ipinfo ::nettool::macinfo
}
###
# topic: 58295f2544f43827e855d09dc3ee625a
###
proc ::nettool::diskless_client {} {
return 0
}
###
# topic: 57fdc331bc60c7bf2bd3f3214e9a906f
###
proc ::nettool::hwaddr_to_ipaddr {hwaddr args} {}
###
# topic: dd2e2c0810cea69909399808f2a68949
# title: Return a list of unique hardware ids
###
proc ::nettool::hwid_list {} {
set result {}
foreach mac [::nettool::mac_list] {
lappend result 0x[string map {: {}} $mac]
}
if {[llength $result]} {
return $result
}
return 0x010203040506
}
###
# topic: 4b87d977492bd10802bfc0327cd07ac2
# title: Return list of network interfaces
###
proc ::nettool::if_list {} {}
###
# topic: d2932eb0ea8cc9f6a865c1ab7cdd4572
# description:
# Called on package load to build any static
# structures to cache data that would be time
# consuming to call on the fly
###
proc ::nettool::init {} {}
###
# topic: 417672d3f31b80d749588365af88baf6
# title: Return list of ip addresses for this computer (primary first)
###
proc ::nettool::ip_list {} {}
###
# topic: ac9d6815d47f60d45930f0c8c8ae8f16
# title: Return list of mac numbers for this computer (primary first)
###
proc ::nettool::mac_list {} {}
###
# topic: c42343f20e3afd2884a5dd1c219e4415
###
proc ::nettool::platform {} {
variable platform
return $platform
}
proc ::nettool::user_data_root {appname} {
return [file join $::env(HOME) .$appname]
}
###
# END: generic.tcl
###
###
# START: available_ports.tcl
###
###
# topic: 868a79cedf28924191fd86aa85f6dd1d
###
namespace eval ::nettool {
set blocks {}
}
lappend ::nettool::blocks 1028 1028
lappend ::nettool::blocks 1067 1068
lappend ::nettool::blocks 1109 1109
lappend ::nettool::blocks 1138 1138
lappend ::nettool::blocks 1313 1313
lappend ::nettool::blocks 1382 1382
lappend ::nettool::blocks 1385 1385
lappend ::nettool::blocks 1416 1416
lappend ::nettool::blocks 1454 1454
lappend ::nettool::blocks 1461 1461
lappend ::nettool::blocks 1464 1464
lappend ::nettool::blocks 1486 1486
lappend ::nettool::blocks 1491 1491
lappend ::nettool::blocks 1493 1493
lappend ::nettool::blocks 1528 1528
lappend ::nettool::blocks 1556 1556
lappend ::nettool::blocks 1587 1587
lappend ::nettool::blocks 1651 1651
lappend ::nettool::blocks 1783 1783
lappend ::nettool::blocks 1895 1895
lappend ::nettool::blocks 2083 2083
lappend ::nettool::blocks 2194 2196
lappend ::nettool::blocks 2222 2222
lappend ::nettool::blocks 2259 2259
lappend ::nettool::blocks 2340 2340
lappend ::nettool::blocks 2346 2349
lappend ::nettool::blocks 2369 2369
lappend ::nettool::blocks 2377 2378
lappend ::nettool::blocks 2395 2395
lappend ::nettool::blocks 2426 2426
lappend ::nettool::blocks 2446 2446
lappend ::nettool::blocks 2528 2528
lappend ::nettool::blocks 2640 2640
lappend ::nettool::blocks 2654 2654
lappend ::nettool::blocks 2682 2682
lappend ::nettool::blocks 2693 2693
lappend ::nettool::blocks 2794 2794
lappend ::nettool::blocks 2825 2825
lappend ::nettool::blocks 2873 2873
lappend ::nettool::blocks 2916 2917
lappend ::nettool::blocks 2925 2925
lappend ::nettool::blocks 3014 3014
lappend ::nettool::blocks 3016 3019
lappend ::nettool::blocks 3024 3024
lappend ::nettool::blocks 3027 3029
lappend ::nettool::blocks 3050 3050
lappend ::nettool::blocks 3080 3080
lappend ::nettool::blocks 3092 3092
lappend ::nettool::blocks 3126 3126
lappend ::nettool::blocks 3300 3301
lappend ::nettool::blocks 3396 3396
lappend ::nettool::blocks 3403 3404
lappend ::nettool::blocks 3546 3546
lappend ::nettool::blocks 3693 3694
lappend ::nettool::blocks 3876 3876
lappend ::nettool::blocks 3900 3900
lappend ::nettool::blocks 3938 3938
lappend ::nettool::blocks 3970 3970
lappend ::nettool::blocks 3986 3986
lappend ::nettool::blocks 3994 3994
lappend ::nettool::blocks 4000 4000
lappend ::nettool::blocks 4048 4048
lappend ::nettool::blocks 4060 4060
lappend ::nettool::blocks 4065 4065
lappend ::nettool::blocks 4120 4120
lappend ::nettool::blocks 4132 4133
lappend ::nettool::blocks 4140 4140
lappend ::nettool::blocks 4144 4144
lappend ::nettool::blocks 4151 4152
lappend ::nettool::blocks 4184 4184
lappend ::nettool::blocks 4194 4198
lappend ::nettool::blocks 4315 4315
lappend ::nettool::blocks 4317 4319
lappend ::nettool::blocks 4332 4332
lappend ::nettool::blocks 4334 4339
lappend ::nettool::blocks 4363 4367
lappend ::nettool::blocks 4370 4370
lappend ::nettool::blocks 4380 4388
lappend ::nettool::blocks 4397 4399
lappend ::nettool::blocks 4412 4424
lappend ::nettool::blocks 4434 4440
lappend ::nettool::blocks 4459 4483
lappend ::nettool::blocks 4489 4499
lappend ::nettool::blocks 4501 4501
lappend ::nettool::blocks 4503 4533
lappend ::nettool::blocks 4539 4544
lappend ::nettool::blocks 4560 4562
lappend ::nettool::blocks 4564 4565
lappend ::nettool::blocks 4569 4569
lappend ::nettool::blocks 4571 4589
lappend ::nettool::blocks 4606 4657
lappend ::nettool::blocks 4693 4699
lappend ::nettool::blocks 4705 4724
lappend ::nettool::blocks 4734 4736
lappend ::nettool::blocks 4746 4746
lappend ::nettool::blocks 4748 4748
lappend ::nettool::blocks 4754 4783
lappend ::nettool::blocks 4792 4799
lappend ::nettool::blocks 4805 4826
lappend ::nettool::blocks 4828 4836
lappend ::nettool::blocks 4846 4846
lappend ::nettool::blocks 4852 4866
lappend ::nettool::blocks 4872 4875
lappend ::nettool::blocks 4886 4893
lappend ::nettool::blocks 4895 4898
lappend ::nettool::blocks 4903 4911
lappend ::nettool::blocks 4916 4935
lappend ::nettool::blocks 4938 4939
lappend ::nettool::blocks 4943 4948
lappend ::nettool::blocks 4954 4968
lappend ::nettool::blocks 4971 4983
lappend ::nettool::blocks 4992 4998
lappend ::nettool::blocks 5016 5019
lappend ::nettool::blocks 5033 5041
lappend ::nettool::blocks 5076 5077
lappend ::nettool::blocks 5088 5089
lappend ::nettool::blocks 5095 5098
lappend ::nettool::blocks 5107 5110
lappend ::nettool::blocks 5113 5113
lappend ::nettool::blocks 5118 5119
lappend ::nettool::blocks 5121 5132
lappend ::nettool::blocks 5138 5145
lappend ::nettool::blocks 5147 5149
lappend ::nettool::blocks 5151 5151
lappend ::nettool::blocks 5158 5160
lappend ::nettool::blocks 5165 5165
lappend ::nettool::blocks 5169 5171
lappend ::nettool::blocks 5173 5189
lappend ::nettool::blocks 5197 5199
lappend ::nettool::blocks 5204 5208
lappend ::nettool::blocks 5210 5214
lappend ::nettool::blocks 5216 5220
lappend ::nettool::blocks 5238 5244
lappend ::nettool::blocks 5254 5263
lappend ::nettool::blocks 5266 5268
lappend ::nettool::blocks 5273 5279
lappend ::nettool::blocks 5283 5297
lappend ::nettool::blocks 5311 5311
lappend ::nettool::blocks 5316 5316
lappend ::nettool::blocks 5319 5319
lappend ::nettool::blocks 5322 5342
lappend ::nettool::blocks 5345 5348
lappend ::nettool::blocks 5365 5396
lappend ::nettool::blocks 5438 5442
lappend ::nettool::blocks 5444 5444
lappend ::nettool::blocks 5446 5452
lappend ::nettool::blocks 5457 5460
lappend ::nettool::blocks 5466 5499
lappend ::nettool::blocks 5507 5552
lappend ::nettool::blocks 5558 5565
lappend ::nettool::blocks 5570 5572
lappend ::nettool::blocks 5576 5578
lappend ::nettool::blocks 5587 5596
lappend ::nettool::blocks 5606 5617
lappend ::nettool::blocks 5619 5626
lappend ::nettool::blocks 5640 5645
lappend ::nettool::blocks 5647 5669
lappend ::nettool::blocks 5685 5686
lappend ::nettool::blocks 5690 5692
lappend ::nettool::blocks 5694 5695
lappend ::nettool::blocks 5697 5712
lappend ::nettool::blocks 5731 5740
lappend ::nettool::blocks 5749 5749
lappend ::nettool::blocks 5751 5754
lappend ::nettool::blocks 5756 5756
lappend ::nettool::blocks 5758 5765
lappend ::nettool::blocks 5772 5776
lappend ::nettool::blocks 5778 5779
lappend ::nettool::blocks 5788 5792
lappend ::nettool::blocks 5795 5812
lappend ::nettool::blocks 5815 5840
lappend ::nettool::blocks 5843 5858
lappend ::nettool::blocks 5860 5862
lappend ::nettool::blocks 5864 5867
lappend ::nettool::blocks 5869 5882
lappend ::nettool::blocks 5884 5899
lappend ::nettool::blocks 5901 5909
lappend ::nettool::blocks 5914 5962
lappend ::nettool::blocks 5964 5967
lappend ::nettool::blocks 5970 5983
lappend ::nettool::blocks 5993 5998
lappend ::nettool::blocks 6067 6067
lappend ::nettool::blocks 6078 6080
lappend ::nettool::blocks 6089 6098
lappend ::nettool::blocks 6119 6120
lappend ::nettool::blocks 6125 6129
lappend ::nettool::blocks 6131 6132
lappend ::nettool::blocks 6134 6139
lappend ::nettool::blocks 6150 6158
lappend ::nettool::blocks 6164 6199
lappend ::nettool::blocks 6202 6221
lappend ::nettool::blocks 6223 6240
lappend ::nettool::blocks 6245 6250
lappend ::nettool::blocks 6254 6266
lappend ::nettool::blocks 6270 6299
lappend ::nettool::blocks 6301 6305
lappend ::nettool::blocks 6307 6314
lappend ::nettool::blocks 6318 6319
lappend ::nettool::blocks 6323 6323
lappend ::nettool::blocks 6327 6342
lappend ::nettool::blocks 6345 6345
lappend ::nettool::blocks 6348 6349
lappend ::nettool::blocks 6351 6354
lappend ::nettool::blocks 6356 6359
lappend ::nettool::blocks 6361 6362
lappend ::nettool::blocks 6364 6369
lappend ::nettool::blocks 6371 6381
lappend ::nettool::blocks 6383 6388
lappend ::nettool::blocks 6391 6399
lappend ::nettool::blocks 6411 6416
lappend ::nettool::blocks 6422 6431
lappend ::nettool::blocks 6433 6441
lappend ::nettool::blocks 6444 6445
lappend ::nettool::blocks 6447 6454
lappend ::nettool::blocks 6457 6470
lappend ::nettool::blocks 6472 6479
lappend ::nettool::blocks 6490 6499
lappend ::nettool::blocks 6501 6508
lappend ::nettool::blocks 6512 6512
lappend ::nettool::blocks 6516 6542
lappend ::nettool::blocks 6545 6546
lappend ::nettool::blocks 6552 6557
lappend ::nettool::blocks 6559 6565
lappend ::nettool::blocks 6569 6578
lappend ::nettool::blocks 6584 6599
lappend ::nettool::blocks 6603 6618
lappend ::nettool::blocks 6629 6631
lappend ::nettool::blocks 6635 6639
lappend ::nettool::blocks 6641 6652
lappend ::nettool::blocks 6654 6654
lappend ::nettool::blocks 6658 6664
lappend ::nettool::blocks 6672 6677
lappend ::nettool::blocks 6680 6686
lappend ::nettool::blocks 6690 6695
lappend ::nettool::blocks 6698 6700
lappend ::nettool::blocks 6707 6713
lappend ::nettool::blocks 6717 6766
lappend ::nettool::blocks 6772 6776
lappend ::nettool::blocks 6779 6783
lappend ::nettool::blocks 6792 6800
lappend ::nettool::blocks 6802 6816
lappend ::nettool::blocks 6818 6830
lappend ::nettool::blocks 6832 6840
lappend ::nettool::blocks 6843 6849
lappend ::nettool::blocks 6851 6867
lappend ::nettool::blocks 6869 6887
lappend ::nettool::blocks 6889 6900
lappend ::nettool::blocks 6902 6934
lappend ::nettool::blocks 6937 6945
lappend ::nettool::blocks 6947 6950
lappend ::nettool::blocks 6952 6960
lappend ::nettool::blocks 6967 6968
lappend ::nettool::blocks 6971 6996
lappend ::nettool::blocks 7016 7017
lappend ::nettool::blocks 7026 7029
lappend ::nettool::blocks 7032 7039
lappend ::nettool::blocks 7041 7069
lappend ::nettool::blocks 7072 7072
lappend ::nettool::blocks 7074 7079
lappend ::nettool::blocks 7081 7094
lappend ::nettool::blocks 7096 7098
lappend ::nettool::blocks 7102 7106
lappend ::nettool::blocks 7108 7120
lappend ::nettool::blocks 7122 7127
lappend ::nettool::blocks 7130 7160
lappend ::nettool::blocks 7175 7180
lappend ::nettool::blocks 7182 7199
lappend ::nettool::blocks 7202 7226
lappend ::nettool::blocks 7230 7234
lappend ::nettool::blocks 7238 7261
lappend ::nettool::blocks 7263 7271
lappend ::nettool::blocks 7284 7299
lappend ::nettool::blocks 7360 7364
lappend ::nettool::blocks 7366 7390
lappend ::nettool::blocks 7396 7396
lappend ::nettool::blocks 7398 7399
lappend ::nettool::blocks 7403 7409
lappend ::nettool::blocks 7412 7420
lappend ::nettool::blocks 7422 7425
lappend ::nettool::blocks 7432 7436
lappend ::nettool::blocks 7438 7442
lappend ::nettool::blocks 7444 7470
lappend ::nettool::blocks 7472 7472
lappend ::nettool::blocks 7475 7490
lappend ::nettool::blocks 7492 7499
lappend ::nettool::blocks 7502 7507
lappend ::nettool::blocks 7512 7541
lappend ::nettool::blocks 7551 7559
lappend ::nettool::blocks 7561 7562
lappend ::nettool::blocks 7564 7565
lappend ::nettool::blocks 7567 7568
lappend ::nettool::blocks 7571 7573
lappend ::nettool::blocks 7575 7587
lappend ::nettool::blocks 7589 7623
lappend ::nettool::blocks 7625 7625
lappend ::nettool::blocks 7632 7632
lappend ::nettool::blocks 7634 7647
lappend ::nettool::blocks 7649 7671
lappend ::nettool::blocks 7678 7679
lappend ::nettool::blocks 7681 7688
lappend ::nettool::blocks 7690 7696
lappend ::nettool::blocks 7698 7699
lappend ::nettool::blocks 7701 7706
lappend ::nettool::blocks 7709 7719
lappend ::nettool::blocks 7721 7723
lappend ::nettool::blocks 7728 7733
lappend ::nettool::blocks 7735 7737
lappend ::nettool::blocks 7739 7740
lappend ::nettool::blocks 7745 7746
lappend ::nettool::blocks 7748 7776
lappend ::nettool::blocks 7780 7780
lappend ::nettool::blocks 7782 7785
lappend ::nettool::blocks 7788 7788
lappend ::nettool::blocks 7790 7793
lappend ::nettool::blocks 7795 7796
lappend ::nettool::blocks 7803 7809
lappend ::nettool::blocks 7811 7844
lappend ::nettool::blocks 7848 7868
lappend ::nettool::blocks 7873 7877
lappend ::nettool::blocks 7879 7879
lappend ::nettool::blocks 7881 7886
lappend ::nettool::blocks 7888 7899
lappend ::nettool::blocks 7904 7912
lappend ::nettool::blocks 7914 7931
lappend ::nettool::blocks 7934 7961
lappend ::nettool::blocks 7963 7966
lappend ::nettool::blocks 7968 7978
lappend ::nettool::blocks 7983 7996
lappend ::nettool::blocks 8004 8004
lappend ::nettool::blocks 8006 8007
lappend ::nettool::blocks 8009 8018
lappend ::nettool::blocks 8023 8024
lappend ::nettool::blocks 8027 8031
lappend ::nettool::blocks 8035 8039
lappend ::nettool::blocks 8041 8041
lappend ::nettool::blocks 8045 8050
lappend ::nettool::blocks 8061 8065
lappend ::nettool::blocks 8067 8073
lappend ::nettool::blocks 8075 8079
lappend ::nettool::blocks 8084 8085
lappend ::nettool::blocks 8089 8090
lappend ::nettool::blocks 8092 8096
lappend ::nettool::blocks 8098 8099
lappend ::nettool::blocks 8103 8114
lappend ::nettool::blocks 8119 8120
lappend ::nettool::blocks 8123 8127
lappend ::nettool::blocks 8133 8139
lappend ::nettool::blocks 8141 8147
lappend ::nettool::blocks 8150 8152
lappend ::nettool::blocks 8154 8159
lappend ::nettool::blocks 8163 8180
lappend ::nettool::blocks 8185 8190
lappend ::nettool::blocks 8193 8193
lappend ::nettool::blocks 8196 8198
lappend ::nettool::blocks 8203 8203
lappend ::nettool::blocks 8209 8229
lappend ::nettool::blocks 8231 8242
lappend ::nettool::blocks 8244 8275
lappend ::nettool::blocks 8277 8279
lappend ::nettool::blocks 8281 8291
lappend ::nettool::blocks 8295 8299
lappend ::nettool::blocks 8302 8312
lappend ::nettool::blocks 8314 8319
lappend ::nettool::blocks 8322 8350
lappend ::nettool::blocks 8352 8375
lappend ::nettool::blocks 8381 8382
lappend ::nettool::blocks 8384 8399
lappend ::nettool::blocks 8406 8414
lappend ::nettool::blocks 8418 8441
lappend ::nettool::blocks 8446 8449
lappend ::nettool::blocks 8451 8456
lappend ::nettool::blocks 8458 8469
lappend ::nettool::blocks 8475 8499
lappend ::nettool::blocks 8503 8553
lappend ::nettool::blocks 8556 8566
lappend ::nettool::blocks 8568 8599
lappend ::nettool::blocks 8601 8608
lappend ::nettool::blocks 8616 8664
lappend ::nettool::blocks 8667 8674
lappend ::nettool::blocks 8676 8685
lappend ::nettool::blocks 8687 8687
lappend ::nettool::blocks 8689 8698
lappend ::nettool::blocks 8700 8710
lappend ::nettool::blocks 8712 8731
lappend ::nettool::blocks 8734 8749
lappend ::nettool::blocks 8751 8762
lappend ::nettool::blocks 8767 8769
lappend ::nettool::blocks 8771 8777
lappend ::nettool::blocks 8779 8785
lappend ::nettool::blocks 8788 8792
lappend ::nettool::blocks 8794 8799
lappend ::nettool::blocks 8801 8803
lappend ::nettool::blocks 8805 8872
lappend ::nettool::blocks 8874 8879
lappend ::nettool::blocks 8882 8882
lappend ::nettool::blocks 8884 8887
lappend ::nettool::blocks 8895 8898
lappend ::nettool::blocks 8902 8909
lappend ::nettool::blocks 8914 8936
lappend ::nettool::blocks 8938 8952
lappend ::nettool::blocks 8955 8988
lappend ::nettool::blocks 8992 8997
lappend ::nettool::blocks 9003 9006
lappend ::nettool::blocks 9011 9019
lappend ::nettool::blocks 9027 9049
lappend ::nettool::blocks 9052 9079
lappend ::nettool::blocks 9081 9081
lappend ::nettool::blocks 9094 9099
lappend ::nettool::blocks 9108 9118
lappend ::nettool::blocks 9120 9121
lappend ::nettool::blocks 9124 9130
lappend ::nettool::blocks 9132 9159
lappend ::nettool::blocks 9165 9190
lappend ::nettool::blocks 9192 9199
lappend ::nettool::blocks 9218 9221
lappend ::nettool::blocks 9223 9254
lappend ::nettool::blocks 9256 9276
lappend ::nettool::blocks 9288 9291
lappend ::nettool::blocks 9296 9299
lappend ::nettool::blocks 9301 9305
lappend ::nettool::blocks 9307 9311
lappend ::nettool::blocks 9313 9317
lappend ::nettool::blocks 9319 9320
lappend ::nettool::blocks 9322 9342
lappend ::nettool::blocks 9345 9345
lappend ::nettool::blocks 9347 9373
lappend ::nettool::blocks 9375 9379
lappend ::nettool::blocks 9381 9386
lappend ::nettool::blocks 9391 9395
lappend ::nettool::blocks 9398 9399
lappend ::nettool::blocks 9403 9417
lappend ::nettool::blocks 9419 9442
lappend ::nettool::blocks 9446 9449
lappend ::nettool::blocks 9451 9499
lappend ::nettool::blocks 9501 9521
lappend ::nettool::blocks 9523 9534
lappend ::nettool::blocks 9537 9554
lappend ::nettool::blocks 9556 9591
lappend ::nettool::blocks 9601 9611
lappend ::nettool::blocks 9613 9613
lappend ::nettool::blocks 9615 9615
lappend ::nettool::blocks 9619 9627
lappend ::nettool::blocks 9633 9639
lappend ::nettool::blocks 9641 9665
lappend ::nettool::blocks 9669 9693
lappend ::nettool::blocks 9696 9699
lappend ::nettool::blocks 9701 9746
lappend ::nettool::blocks 9748 9749
lappend ::nettool::blocks 9751 9752
lappend ::nettool::blocks 9754 9761
lappend ::nettool::blocks 9763 9799
lappend ::nettool::blocks 9803 9874
lappend ::nettool::blocks 9877 9877
lappend ::nettool::blocks 9879 9887
lappend ::nettool::blocks 9890 9897
lappend ::nettool::blocks 9904 9908
lappend ::nettool::blocks 9910 9910
lappend ::nettool::blocks 9912 9924
lappend ::nettool::blocks 9926 9949
lappend ::nettool::blocks 9957 9965
lappend ::nettool::blocks 9967 9977
lappend ::nettool::blocks 9979 9986
lappend ::nettool::blocks 9989 9989
lappend ::nettool::blocks 10003 10003
lappend ::nettool::blocks 10011 10022
lappend ::nettool::blocks 10024 10049
lappend ::nettool::blocks 10052 10054
lappend ::nettool::blocks 10056 10079
lappend ::nettool::blocks 10082 10099
lappend ::nettool::blocks 10105 10106
lappend ::nettool::blocks 10108 10109
lappend ::nettool::blocks 10112 10112
lappend ::nettool::blocks 10118 10127
lappend ::nettool::blocks 10130 10159
lappend ::nettool::blocks 10163 10199
lappend ::nettool::blocks 10202 10251
lappend ::nettool::blocks 10253 10259
lappend ::nettool::blocks 10261 10287
lappend ::nettool::blocks 10289 10320
lappend ::nettool::blocks 10322 10438
lappend ::nettool::blocks 10440 10499
lappend ::nettool::blocks 10501 10539
lappend ::nettool::blocks 10545 10630
lappend ::nettool::blocks 10632 10799
lappend ::nettool::blocks 10801 10804
lappend ::nettool::blocks 10806 10808
lappend ::nettool::blocks 10811 10859
lappend ::nettool::blocks 10861 10879
lappend ::nettool::blocks 10881 10989
lappend ::nettool::blocks 10991 10999
lappend ::nettool::blocks 11002 11094
lappend ::nettool::blocks 11096 11102
lappend ::nettool::blocks 11107 11107
lappend ::nettool::blocks 11113 11160
lappend ::nettool::blocks 11166 11170
lappend ::nettool::blocks 11176 11200
lappend ::nettool::blocks 11203 11207
lappend ::nettool::blocks 11209 11210
lappend ::nettool::blocks 11212 11318
lappend ::nettool::blocks 11322 11366
lappend ::nettool::blocks 11368 11370
lappend ::nettool::blocks 11372 11429
lappend ::nettool::blocks 11431 11488
lappend ::nettool::blocks 11490 11599
lappend ::nettool::blocks 11601 11622
lappend ::nettool::blocks 11624 11719
lappend ::nettool::blocks 11721 11722
lappend ::nettool::blocks 11724 11750
lappend ::nettool::blocks 11752 11795
lappend ::nettool::blocks 11797 11875
lappend ::nettool::blocks 11878 11966
lappend ::nettool::blocks 11968 11996
lappend ::nettool::blocks 12011 12011
lappend ::nettool::blocks 12014 12108
lappend ::nettool::blocks 12110 12120
lappend ::nettool::blocks 12122 12167
lappend ::nettool::blocks 12169 12171
lappend ::nettool::blocks 12173 12299
lappend ::nettool::blocks 12301 12301
lappend ::nettool::blocks 12303 12320
lappend ::nettool::blocks 12323 12344
lappend ::nettool::blocks 12346 12752
lappend ::nettool::blocks 12754 12864
lappend ::nettool::blocks 12866 13159
lappend ::nettool::blocks 13161 13215
lappend ::nettool::blocks 13219 13222
lappend ::nettool::blocks 13225 13399
lappend ::nettool::blocks 13401 13719
lappend ::nettool::blocks 13723 13723
lappend ::nettool::blocks 13725 13781
lappend ::nettool::blocks 13784 13784
lappend ::nettool::blocks 13787 13817
lappend ::nettool::blocks 13824 13893
lappend ::nettool::blocks 13895 13928
lappend ::nettool::blocks 13931 13999
lappend ::nettool::blocks 14003 14032
lappend ::nettool::blocks 14035 14140
lappend ::nettool::blocks 14143 14144
lappend ::nettool::blocks 14146 14148
lappend ::nettool::blocks 14151 14153
lappend ::nettool::blocks 14155 14249
lappend ::nettool::blocks 14251 14413
lappend ::nettool::blocks 14415 14935
lappend ::nettool::blocks 14938 14999
lappend ::nettool::blocks 15001 15001
lappend ::nettool::blocks 15003 15117
lappend ::nettool::blocks 15119 15344
lappend ::nettool::blocks 15346 15362
lappend ::nettool::blocks 15364 15554
lappend ::nettool::blocks 15556 15659
lappend ::nettool::blocks 15661 15739
lappend ::nettool::blocks 15741 15997
lappend ::nettool::blocks 16004 16019
lappend ::nettool::blocks 16022 16160
lappend ::nettool::blocks 16163 16308
lappend ::nettool::blocks 16312 16359
lappend ::nettool::blocks 16362 16366
lappend ::nettool::blocks 16369 16383
lappend ::nettool::blocks 16385 16618
lappend ::nettool::blocks 16620 16664
lappend ::nettool::blocks 16667 16899
lappend ::nettool::blocks 16901 16949
lappend ::nettool::blocks 16951 16990
lappend ::nettool::blocks 16996 17006
lappend ::nettool::blocks 17008 17183
lappend ::nettool::blocks 17186 17218
lappend ::nettool::blocks 17223 17233
lappend ::nettool::blocks 17236 17499
lappend ::nettool::blocks 17501 17554
lappend ::nettool::blocks 17556 17728
lappend ::nettool::blocks 17730 17753
lappend ::nettool::blocks 17757 17776
lappend ::nettool::blocks 17778 17999
lappend ::nettool::blocks 18001 18103
lappend ::nettool::blocks 18105 18135
lappend ::nettool::blocks 18137 18180
lappend ::nettool::blocks 18188 18240
lappend ::nettool::blocks 18244 18261
lappend ::nettool::blocks 18263 18462
lappend ::nettool::blocks 18464 18633
lappend ::nettool::blocks 18636 18768
lappend ::nettool::blocks 18770 18880
lappend ::nettool::blocks 18882 18887
lappend ::nettool::blocks 18889 18999
lappend ::nettool::blocks 19001 19006
lappend ::nettool::blocks 19008 19019
lappend ::nettool::blocks 19021 19190
lappend ::nettool::blocks 19192 19193
lappend ::nettool::blocks 19195 19282
lappend ::nettool::blocks 19284 19314
lappend ::nettool::blocks 19316 19397
lappend ::nettool::blocks 19399 19409
lappend ::nettool::blocks 19413 19538
lappend ::nettool::blocks 19542 19787
lappend ::nettool::blocks 19789 19997
lappend ::nettool::blocks 20004 20004
lappend ::nettool::blocks 20006 20011
lappend ::nettool::blocks 20015 20045
lappend ::nettool::blocks 20047 20047
lappend ::nettool::blocks 20050 20166
lappend ::nettool::blocks 20168 20201
lappend ::nettool::blocks 20203 20221
lappend ::nettool::blocks 20223 20479
lappend ::nettool::blocks 20481 20669
lappend ::nettool::blocks 20671 20998
lappend ::nettool::blocks 21001 21009
lappend ::nettool::blocks 21011 21552
lappend ::nettool::blocks 21555 21589
lappend ::nettool::blocks 21591 21799
lappend ::nettool::blocks 21801 21844
lappend ::nettool::blocks 21850 21999
lappend ::nettool::blocks 22006 22124
lappend ::nettool::blocks 22126 22127
lappend ::nettool::blocks 22129 22221
lappend ::nettool::blocks 22223 22272
lappend ::nettool::blocks 22274 22304
lappend ::nettool::blocks 22306 22342
lappend ::nettool::blocks 22344 22346
lappend ::nettool::blocks 22348 22349
lappend ::nettool::blocks 22352 22536
lappend ::nettool::blocks 22538 22554
lappend ::nettool::blocks 22556 22762
lappend ::nettool::blocks 22764 22799
lappend ::nettool::blocks 22801 22950
lappend ::nettool::blocks 22952 22999
lappend ::nettool::blocks 23006 23052
lappend ::nettool::blocks 23054 23271
lappend ::nettool::blocks 23273 23332
lappend ::nettool::blocks 23334 23399
lappend ::nettool::blocks 23403 23455
lappend ::nettool::blocks 23458 23545
lappend ::nettool::blocks 23547 23999
lappend ::nettool::blocks 24007 24241
lappend ::nettool::blocks 24243 24248
lappend ::nettool::blocks 24250 24320
lappend ::nettool::blocks 24323 24464
lappend ::nettool::blocks 24466 24553
lappend ::nettool::blocks 24555 24576
lappend ::nettool::blocks 24578 24675
lappend ::nettool::blocks 24679 24679
lappend ::nettool::blocks 24681 24753
lappend ::nettool::blocks 24755 24849
lappend ::nettool::blocks 24851 24921
lappend ::nettool::blocks 24923 24999
lappend ::nettool::blocks 25010 25470
lappend ::nettool::blocks 25472 25575
lappend ::nettool::blocks 25577 25603
lappend ::nettool::blocks 25605 25792
lappend ::nettool::blocks 25794 25899
lappend ::nettool::blocks 25904 25953
lappend ::nettool::blocks 25956 25999
lappend ::nettool::blocks 26001 26132
lappend ::nettool::blocks 26134 26207
lappend ::nettool::blocks 26209 26259
lappend ::nettool::blocks 26264 26485
lappend ::nettool::blocks 26488 26488
lappend ::nettool::blocks 26490 26999
lappend ::nettool::blocks 27010 27344
lappend ::nettool::blocks 27346 27441
lappend ::nettool::blocks 27443 27503
lappend ::nettool::blocks 27505 27781
lappend ::nettool::blocks 27783 27875
lappend ::nettool::blocks 27877 27998
lappend ::nettool::blocks 28002 28118
lappend ::nettool::blocks 28120 28199
lappend ::nettool::blocks 28201 28239
lappend ::nettool::blocks 28241 29117
lappend ::nettool::blocks 29119 29166
lappend ::nettool::blocks 29170 29998
lappend ::nettool::blocks 30005 30259
lappend ::nettool::blocks 30261 30831
lappend ::nettool::blocks 30833 30998
lappend ::nettool::blocks 31000 31019
lappend ::nettool::blocks 31021 31028
lappend ::nettool::blocks 31030 31399
lappend ::nettool::blocks 31401 31415
lappend ::nettool::blocks 31417 31456
lappend ::nettool::blocks 31458 31619
lappend ::nettool::blocks 31621 31684
lappend ::nettool::blocks 31686 31764
lappend ::nettool::blocks 31766 32033
lappend ::nettool::blocks 32035 32248
lappend ::nettool::blocks 32250 32482
lappend ::nettool::blocks 32484 32634
lappend ::nettool::blocks 32637 32766
lappend ::nettool::blocks 32778 32800
lappend ::nettool::blocks 32802 32810
lappend ::nettool::blocks 32812 32895
lappend ::nettool::blocks 32897 33122
lappend ::nettool::blocks 33124 33330
lappend ::nettool::blocks 33332 33332
lappend ::nettool::blocks 33335 33433
lappend ::nettool::blocks 33435 33655
lappend ::nettool::blocks 33657 34248
lappend ::nettool::blocks 34250 34377
lappend ::nettool::blocks 34380 34566
lappend ::nettool::blocks 34568 34961
lappend ::nettool::blocks 34965 34979
lappend ::nettool::blocks 34981 34999
lappend ::nettool::blocks 35007 35353
lappend ::nettool::blocks 35358 36000
lappend ::nettool::blocks 36002 36411
lappend ::nettool::blocks 36413 36421
lappend ::nettool::blocks 36423 36442
lappend ::nettool::blocks 36445 36523
lappend ::nettool::blocks 36525 36601
lappend ::nettool::blocks 36603 36699
lappend ::nettool::blocks 36701 36864
lappend ::nettool::blocks 36866 37474
lappend ::nettool::blocks 37476 37482
lappend ::nettool::blocks 37484 37653
lappend ::nettool::blocks 37655 37999
lappend ::nettool::blocks 38002 38200
lappend ::nettool::blocks 38204 38799
lappend ::nettool::blocks 38801 38864
lappend ::nettool::blocks 38866 39680
lappend ::nettool::blocks 39682 39999
lappend ::nettool::blocks 40001 40403
lappend ::nettool::blocks 40405 40840
lappend ::nettool::blocks 40844 40852
lappend ::nettool::blocks 40854 41110
lappend ::nettool::blocks 41112 41120
lappend ::nettool::blocks 41122 41793
lappend ::nettool::blocks 41798 42507
lappend ::nettool::blocks 42511 42999
lappend ::nettool::blocks 43001 44320
lappend ::nettool::blocks 44323 44443
lappend ::nettool::blocks 44445 44543
lappend ::nettool::blocks 44545 44552
lappend ::nettool::blocks 44554 44599
lappend ::nettool::blocks 44601 44899
lappend ::nettool::blocks 44901 44999
lappend ::nettool::blocks 45002 45044
lappend ::nettool::blocks 45046 45053
lappend ::nettool::blocks 45055 45677
lappend ::nettool::blocks 45679 45823
lappend ::nettool::blocks 45826 45965
lappend ::nettool::blocks 45967 46997
lappend ::nettool::blocks 47002 47099
lappend ::nettool::blocks 47101 47556
lappend ::nettool::blocks 47558 47623
lappend ::nettool::blocks 47625 47805
lappend ::nettool::blocks 47807 47807
lappend ::nettool::blocks 47810 47999
lappend ::nettool::blocks 48006 48048
lappend ::nettool::blocks 48051 48127
lappend ::nettool::blocks 48130 48555
lappend ::nettool::blocks 48557 48618
lappend ::nettool::blocks 48620 48652
lappend ::nettool::blocks 48654 48999
lappend ::nettool::blocks 49001 65535
###
# END: available_ports.tcl
###
###
# START: locateport.tcl
###
::namespace eval ::nettool {}
###
# topic: fc6f8b9587dd5524f143f9df4be4755b63eb6cd5
###
proc ::nettool::allocate_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
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
###
###
# Generic answers that can be answered on most if not all unix platforms
###
if {$::tcl_platform(platform) eq "unix"} {
###
# topic: 825cd25953c2cc896a96006b7f454e00
# title: Return pairings of MAC numbers to IP addresses on the local network
# description: Under unix, we call the arp command for arp table resolution
###
proc ::nettool::arp_table {} {
set result {}
set dat [exec arp -a]
foreach line [split $dat \n] {
set host [lindex $line 0]
set ip [lindex $line 1]
set macid [lindex $line 3]
lappend result $macid [string range $ip 1 end-1]
}
return $result
}
}
###
# END: platform_unix.tcl
###
###
# START: platform_unix_linux.tcl
###
if {$::tcl_platform(platform) eq "unix" && $genus eq "linux"} {
###
# 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 info} [dump] {
if {[dict exists $info ipv4 Bcast:]} {
lappend result [dict get $info ipv4 Bcast:]
}
}
return [lsort -unique -dictionary $result]
}
###
# topic: 187cfa1827097c5cdf1c40c656cedfcc
# description: Return time since booted
###
proc ::nettool::cpuinfo args {
variable cpuinfo
if {![info exists cpuinfo]} {
set cpuinfo {}
set dat [cat /proc/meminfo]
foreach line [split $dat \n] {
switch [lindex $line 0] {
MemTotal: {
# Normalize to MB
dict set cpuinfo memory [lindex $line 1]/1024
}
}
}
set cpus 0
set dat [cat /proc/cpuinfo]
foreach line [split $dat \n] {
set idx [string first : $line]
set field [string trim [string range $line 0 $idx-1]]
set value [string trim [string range $line $idx+1 end]]
switch $field {
processor {
incr cpus
}
{cpu family} {
dict set cpuinfo family $value
}
model {
dict set cpuinfo model $value
}
stepping {
dict set cpuinfo stepping $value
}
vendor_id {
dict set cpuinfo vendor $value
}
{model name} {
dict set cpuinfo brand $value
}
{cpu MHz} {
dict set cpuinfo speed $value
}
flags {
dict set cpuinfo features $value
}
}
}
dict set cpuinfo cpus $cpus
}
if {$args eq "<list>"} {
return [dict keys $cpuinfo]
}
if {[llength $args]==0} {
return $cpuinfo
}
if {[llength $args]==1} {
return [dict get $cpuinfo [lindex $args 0]]
}
set result {}
foreach item $args {
if {[dict exists $cpuinfo $item]} {
dict set result $item [dict get $cpuinfo $item]
} else {
dict set result $item {}
}
}
return $result
}
###
# topic: aa8eda4fb59296a1a34d8d600ca54e28
# description: Dump interfaces
###
proc ::nettool::dump {} {
set data [exec ifconfig]
set iface {}
set result {}
foreach line [split $data \n] {
if {[string index $line 0] in {" " "\t"} } {
# Indented line appends the prior iface
switch [lindex $line 0] {
inet {
foreach tuple [lrange $line 1 end] {
set idx [string first : $tuple]
set field [string trim [string range $tuple 0 $idx]]
set value [string trim [string range $tuple $idx+1 end]]
dict set result $iface ipv4 [string trim $field] [string trim $value]
}
}
inet6 {
dict set result $iface ipv6 addr: [lindex $line 2]
foreach tuple [lrange $line 3 end] {
set idx [string first : $tuple]
set field [string trim [string range $tuple 0 $idx]]
set value [string trim [string range $tuple $idx+1 end]]
dict set result $iface ipv6 [string trim $field] [string trim $value]
}
}
}
} else {
# Non-intended line - new iface
set iface [lindex $line 0]
set idx [lsearch $line HWaddr]
if {$idx >= 0 } {
dict set result $iface ether: [lindex $line $idx+1]
}
}
}
return $result
}
###
# topic: 417672d3f31b80d749588365af88baf6
# title: Return list of ip addresses for this computer (primary first)
###
proc ::nettool::ip_list {} {
set result {}
foreach {iface info} [dump] {
if {[dict exists $info ipv4 addr:]} {
lappend result [dict get $info ipv4 addr:]
}
}
ldelete result 127.0.0.1
return $result
}
###
# topic: ac9d6815d47f60d45930f0c8c8ae8f16
# title: Return list of mac numbers for this computer (primary first)
###
proc ::nettool::mac_list {} {
set result {}
foreach {iface info} [dump] {
if {[dict exists $info ether:]} {
lappend result [dict get $info ether:]
}
}
return $result
}
###
# topic: a43b6f42141820e0ba1094840d0f6fc0
###
proc ::nettool::network_list {} {
foreach {iface info} [dump] {
if {![dict exists $info ipv4 addr:]} continue
if {![dict exists $info ipv4 Mask:]} continue
#set mask [::ip::maskToInt $netmask]
set addr [dict get $info ipv4 addr:]
set mask [dict get $info ipv4 Mask:]
set addri [::ip::toInteger $addr]
lappend result [ip::nativeToPrefix [list [expr {$addri & $mask}] $mask] -ipv4]
}
return $result
}
###
# topic: e7db1ae1b5b98a1bb4384f0a4fe81f42
###
proc ::nettool::status {} {
set result {}
set dat [cat /proc/loadavg]
dict set result load_average [lrange $dat 0 2]
set cpus [cpuinfo cpus].0
dict set result load [expr {[lindex $dat 0]/$cpus}]
set processes [split [lindex $dat 3] /]
dict set result processes_running [lindex $processes 0]
dict set result processes_total [lindex $processes 1]
set dat [cat /proc/meminfo]
foreach line [split $dat \n] {
switch [lindex $line 0] {
MemTotal: {
# Normalize to MB
dict set result memory_total [expr {[lindex $line 1]/1024}]
}
MemFree: {
# Normalize to MB
dict set result memory_free [expr {[lindex $line 1]/1024}]
}
}
}
return $result
}
###
# topic: 59bf977ad7287b4d90346fad639aed34
###
proc ::nettool::uptime_report {} {
set result {}
set dat [split [exec uptime] ,]
puts $dat
dict set result time [lindex [lindex $dat 0] 0]
dict set result uptime [lrange [lindex $dat 0] 1 end]
dict set result users [lindex [lindex $dat 2] 0]
dict set result load_1_minute [lindex [lindex $dat 3] end]
dict set result load_5_minute [lindex [lindex $dat 4] end]
dict set result load_15_minute [lindex [lindex $dat 5] end]
return $result
}
unset -nocomplain ::nettool::cpuinfo
}
###
# END: platform_unix_linux.tcl
###
###
# START: platform_unix_macosx.tcl
###
if {$::tcl_platform(platform) eq "unix" && $genus eq "macosx"} {
###
# topic: 825cd25953c2cc896a96006b7f454e00
# title: Return pairings of MAC numbers to IP addresses on the local network
# description: Under macosx, we call the arp command for arp table resolution
###
proc ::nettool::arp_table {} {
set result {}
set dat [exec arp -a]
foreach line [split $dat \n] {
set host [lindex $line 0]
set ip [lindex $line 1]
set macid [lindex $line 3]
lappend result $macid [string range $ip 1 end-1]
}
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 info} [dump] {
if {[dict exists $info broadcast:]} {
lappend result [dict get $info broadcast:]
}
}
return [lsort -unique -dictionary $result]
}
###
# topic: 187cfa1827097c5cdf1c40c656cedfcc
# description: Return time since booted
###
proc ::nettool::cpuinfo args {
variable cpuinfo
if {![info exists cpuinfo]} {
set cpuinfo {}
dict set cpuinfo machine [exec sysctl -n hw.machine]
dict set cpuinfo cpus [exec sysctl -n hw.ncpu]
# Normalize to MB
dict set cpuinfo memory [expr {[exec sysctl -n hw.memsize] / 1048576}]
dict set cpuinfo vendor [exec sysctl -n machdep.cpu.vendor]
dict set cpuinfo brand [exec sysctl -n machdep.cpu.brand_string]
dict set cpuinfo model [exec sysctl -n machdep.cpu.model]
dict set cpuinfo speed [expr {[exec sysctl -n hw.cpufrequency]/1000000}]
dict set cpuinfo family [exec sysctl -n machdep.cpu.family]
dict set cpuinfo stepping [exec sysctl -n machdep.cpu.stepping]
dict set cpuinfo features [exec sysctl -n machdep.cpu.features]
dict set cpuinfo diskless []
}
if {$args eq "<list>"} {
return [dict keys $cpuinfo]
}
if {[llength $args]==0} {
return $cpuinfo
}
if {[llength $args]==1} {
return [dict get $cpuinfo [lindex $args 0]]
}
set result {}
foreach item $args {
if {[dict exists $cpuinfo $item]} {
dict set result $item [dict get $cpuinfo $item]
} else {
dict set result $item {}
}
}
return $result
}
###
# topic: aa8eda4fb59296a1a34d8d600ca54e28
# description: Dump interfaces
###
proc ::nettool::dump {} {
set data [exec ifconfig]
set iface {}
set result {}
foreach line [split $data \n] {
if {[string index $line 0] in {" " "\t"} } {
# Indented line appends the prior iface
foreach {field value} $line {
dict set result $iface [string trimright $field :]: $value
}
} else {
# Non-intended line - new iface
set iface [lindex $line 0]
}
}
return $result
}
###
# topic: dd2e2c0810cea69909399808f2a68949
# title: Return a list of unique hardware addresses
###
proc ::nettool::hwid_list {} {
variable cached_data
set result {}
if {![info exists cached_data]} {
if {[catch {exec system_profiler SPHardwareDataType} hwlist]} {
set cached_data {}
} else {
set cached_data $hwlist
}
}
set serial {}
set hwuuid {}
set result {}
catch {
foreach line [split $cached_data \n] {
if { [lindex $line 0] == "Serial" && [lindex $line 1] == "Number" } {
set serial [lindex $line end]
}
if { [lindex $line 0] == "Hardware" && [lindex $line 1] == "UUID:" } {
set hwuuid [lindex $line end]
}
}
}
if { $hwuuid != {} } {
lappend result 0x[string map {- {}} $hwuuid]
}
# Blank serial number?
if { $serial != {} } {
set sn [binary scan $serial H* hash]
lappend result 0x$hash
}
if {[llength $result]} {
return $result
}
foreach mac [::nettool::mac_list] {
lappend result 0x[string map {: {}} $mac]
}
if {[llength $result]} {
return $result
}
return 0x010203040506
}
###
# topic: d2932eb0ea8cc9f6a865c1ab7cdd4572
# description:
# Called on package load to build any static
# structures to cache data that would be time
# consuming to call on the fly
###
proc ::nettool::init {} {
unset -nocomplain [namespace current]::cpuinfo
}
###
# topic: 417672d3f31b80d749588365af88baf6
# title: Return list of ip addresses for this computer (primary first)
###
proc ::nettool::ip_list {} {
set result {}
foreach {iface info} [dump] {
if {[dict exists $info inet:]} {
lappend result [dict get $info inet:]
}
}
ldelete result 127.0.0.1
return $result
}
###
# topic: ac9d6815d47f60d45930f0c8c8ae8f16
# title: Return list of mac numbers for this computer (primary first)
###
proc ::nettool::mac_list {} {
set result {}
foreach {iface info} [dump] {
if {[dict exists $info ether:]} {
lappend result [dict get $info ether:]
}
}
return $result
}
###
# topic: a43b6f42141820e0ba1094840d0f6fc0
###
proc ::nettool::network_list {} {
foreach {iface info} [dump] {
if {![dict exists $info inet:]} continue
if {![dict exists $info netmask:]} continue
#set mask [::ip::maskToInt $netmask]
set addr [dict get $info inet:]
set mask [dict get $info netmask:]
set addri [::ip::toInteger $addr]
lappend result [ip::nativeToPrefix [list [expr {$addri & $mask}] $mask] -ipv4]
}
return $result
}
###
# topic: e7db1ae1b5b98a1bb4384f0a4fe81f42
###
proc ::nettool::status {} {
set result {}
set loaddat [lindex [exec sysctl -n vm.loadavg] 0]
set cpus [cpuinfo cpus]
dict set result cpus $cpus
dict set result load [expr {[lindex $loaddat 0]*100.0/$cpus}]
dict set result load_average_1 [lindex $loaddat 0]
dict set result load_average_5 [lindex $loaddat 1]
dict set result load_average_15 [lindex $loaddat 2]
set total [exec sysctl -n hw.memsize]
dict set result memory_total [expr {$total / 1048576}]
set used 0
foreach {amt} [exec sysctl -n machdep.memmap] {
incr used $amt
}
dict set result memory_free [expr {($total - $used) / 1048576}]
return $result
}
proc ::nettool::user_data_root {appname} {
return [file join $::env(HOME) Library {Application Support} $appname]
}
}
###
# END: platform_unix_macosx.tcl
###
###
# START: platform_windows.tcl
###
if {$::tcl_platform(platform) eq "windows"} {
###
# 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: 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]
}
###
# Provide a limited subset using data gleaned from exec
# These calls work in Windows NT 4 and above
###
proc ::nettool::IPINFO {} {
if {![info exists ::nettool::ipinfo]} {
set ::nettool::ipinfo [exec ipconfig /all]
}
return $::nettool::ipinfo
}
proc ::nettool::if_list {} {
return [mac_list]
}
proc ::nettool::ip_list {} {
set result {}
foreach line [split [IPINFO] \n] {
if {![regexp {IPv4 Address} $line]} continue
set line [string range $line [string first ":" $line]+2 end]
if {[scan $line %d.%d.%d.%d A B C D]!=4} continue
lappend result $A.$B.$C.$D
}
return $result
}
proc ::nettool::mac_list {} {
set result {}
foreach line [split [IPINFO] \n] {
if {![regexp {Physical Address} $line]} continue
set line [string range $line [string first ":" $line]+2 end]
if {[scan $line %02x-%02x-%02x-%02x-%02x-%02x A B C D E F] != 6} continue
if {$A==0 && $B==0 && $C==0 && $D==0 && $E==0 && $F==0} continue
lappend result [format %02x:%02x:%02x:%02x:%02x:%02x $A $B $C $D $E $F]
}
return $result
}
proc ::nettool::network_list {} {
set masks {}
foreach line [split [IPINFO] \n] {
if {![regexp {Subnet Mask} $line]} continue
set line [string range $line [string first ":" $line]+2 end]
if {[scan $line %d.%d.%d.%d A B C D]!=4} continue
lappend masks $A.$B.$C.$D
}
set result {}
set idx -1
foreach addr [ip_list] {
set netmask [lindex $masks [incr idx]]
set mask [::ip::maskToInt $netmask]
set addri [::ip::toInteger $addr]
lappend result [ip::nativeToPrefix [list [expr {$addri & $mask}] $netmask] -ipv4]
}
return $result
}
proc ::nettool::status {} {
}
proc ::nettool::user_data_root {appname} {
return [file join $::env(APPDATA) $appname]
}
}
###
# END: platform_windows.tcl
###
###
# START: platform_windows_twapi.tcl
###
if {$::tcl_platform(platform) eq "windows" && ![catch {package require twapi}]} {
# TWAPI Based implementation
::namespace eval ::nettool {}
###
# topic: 825cd25953c2cc896a96006b7f454e00
# title: Return pairings of MAC numbers to IP addresses on the local network
# description: Under macosx, we call the arp command for arp table resolution
###
proc ::nettool::arp_table {} {
set result {}
catch {
foreach element [::twapi::get_arp_table] {
foreach {ifidx macid ipaddr type} {
lappend result [string map {- :} $macid] $ipaddr
}
}
}
return $result
}
###
# topic: 57fdc331bc60c7bf2bd3f3214e9a906f
###
proc ::nettool::hwaddr_to_ipaddr args {
return [::twapi::hwaddr_to_ipaddr {*}$args]
}
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 {}
foreach iface [::twapi::get_netif_indices] {
foreach {field value} [::twapi::get_netif_info $iface -physicaladdress] {
if { $value eq {} } continue
lappend result [string map {- :} $value]
}
}
return $result
}
###
# topic: a43b6f42141820e0ba1094840d0f6fc0
###
proc ::nettool::network_list {} {
set result {}
foreach iface [::twapi::get_netif_indices] {
set dat [::twapi::GetIpAddrTable $iface]
foreach element $dat {
foreach {addr ifindx netmask broadcast reamsize} $element break;
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: 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...
if {[catch {::twapi::get_system_ipaddrs -version 4}]} {
# THEY CHANGED THE API ON ME!
proc ::nettool::ip_list {} {
set result [::twapi::get_system_ipaddrs -ipversion 4]
ldelete result 127.0.0.1
return $result
}
} else {
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} {
if [catch {
set pu [lindex [::twapi::get_processor_info $p -processorutilization] 1]
while {$pu eq {}} {
after 100 {set pause 0}
vwait pause
set pu [lindex [::twapi::get_processor_info $p -processorutilization] 1]
}
set usage [expr {$usage+$pu}]
} err] {
set usage -1
}
}
dict set result cpus $cpus
dict set result load [expr {$usage/$cpus}]
dict set result uptime [::twapi::get_system_uptime]
}
}
###
# END: platform_windows_twapi.tcl
###
namespace eval ::nettool {
namespace export *
}
###
# Perform any one-time discovery we might need
###
::nettool::discover
::nettool::init
|
Changes to modules/nettool/pkgIndex.tcl.
1 2 | package ifneeded nettool 0.5.2 [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.2 [list source [file join $dir nettool.tcl]]
|
Deleted modules/nettool/platform_unix.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < |
Deleted modules/nettool/platform_unix_linux.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted modules/nettool/platform_unix_macosx.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted modules/nettool/platform_windows.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted modules/nettool/scripts/build_services.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted modules/nettool/service-names-port-numbers.csv.
more than 10,000 changes
Added modules/nettool/src/available_ports.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 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 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 |
###
# topic: 868a79cedf28924191fd86aa85f6dd1d
###
namespace eval ::nettool {
set blocks {}
}
lappend ::nettool::blocks 1028 1028
lappend ::nettool::blocks 1067 1068
lappend ::nettool::blocks 1109 1109
lappend ::nettool::blocks 1138 1138
lappend ::nettool::blocks 1313 1313
lappend ::nettool::blocks 1382 1382
lappend ::nettool::blocks 1385 1385
lappend ::nettool::blocks 1416 1416
lappend ::nettool::blocks 1454 1454
lappend ::nettool::blocks 1461 1461
lappend ::nettool::blocks 1464 1464
lappend ::nettool::blocks 1486 1486
lappend ::nettool::blocks 1491 1491
lappend ::nettool::blocks 1493 1493
lappend ::nettool::blocks 1528 1528
lappend ::nettool::blocks 1556 1556
lappend ::nettool::blocks 1587 1587
lappend ::nettool::blocks 1651 1651
lappend ::nettool::blocks 1783 1783
lappend ::nettool::blocks 1895 1895
lappend ::nettool::blocks 2083 2083
lappend ::nettool::blocks 2194 2196
lappend ::nettool::blocks 2222 2222
lappend ::nettool::blocks 2259 2259
lappend ::nettool::blocks 2340 2340
lappend ::nettool::blocks 2346 2349
lappend ::nettool::blocks 2369 2369
lappend ::nettool::blocks 2377 2378
lappend ::nettool::blocks 2395 2395
lappend ::nettool::blocks 2426 2426
lappend ::nettool::blocks 2446 2446
lappend ::nettool::blocks 2528 2528
lappend ::nettool::blocks 2640 2640
lappend ::nettool::blocks 2654 2654
lappend ::nettool::blocks 2682 2682
lappend ::nettool::blocks 2693 2693
lappend ::nettool::blocks 2794 2794
lappend ::nettool::blocks 2825 2825
lappend ::nettool::blocks 2873 2873
lappend ::nettool::blocks 2916 2917
lappend ::nettool::blocks 2925 2925
lappend ::nettool::blocks 3014 3014
lappend ::nettool::blocks 3016 3019
lappend ::nettool::blocks 3024 3024
lappend ::nettool::blocks 3027 3029
lappend ::nettool::blocks 3050 3050
lappend ::nettool::blocks 3080 3080
lappend ::nettool::blocks 3092 3092
lappend ::nettool::blocks 3126 3126
lappend ::nettool::blocks 3300 3301
lappend ::nettool::blocks 3396 3396
lappend ::nettool::blocks 3403 3404
lappend ::nettool::blocks 3546 3546
lappend ::nettool::blocks 3693 3694
lappend ::nettool::blocks 3876 3876
lappend ::nettool::blocks 3900 3900
lappend ::nettool::blocks 3938 3938
lappend ::nettool::blocks 3970 3970
lappend ::nettool::blocks 3986 3986
lappend ::nettool::blocks 3994 3994
lappend ::nettool::blocks 4000 4000
lappend ::nettool::blocks 4048 4048
lappend ::nettool::blocks 4060 4060
lappend ::nettool::blocks 4065 4065
lappend ::nettool::blocks 4120 4120
lappend ::nettool::blocks 4132 4133
lappend ::nettool::blocks 4140 4140
lappend ::nettool::blocks 4144 4144
lappend ::nettool::blocks 4151 4152
lappend ::nettool::blocks 4184 4184
lappend ::nettool::blocks 4194 4198
lappend ::nettool::blocks 4315 4315
lappend ::nettool::blocks 4317 4319
lappend ::nettool::blocks 4332 4332
lappend ::nettool::blocks 4334 4339
lappend ::nettool::blocks 4363 4367
lappend ::nettool::blocks 4370 4370
lappend ::nettool::blocks 4380 4388
lappend ::nettool::blocks 4397 4399
lappend ::nettool::blocks 4412 4424
lappend ::nettool::blocks 4434 4440
lappend ::nettool::blocks 4459 4483
lappend ::nettool::blocks 4489 4499
lappend ::nettool::blocks 4501 4501
lappend ::nettool::blocks 4503 4533
lappend ::nettool::blocks 4539 4544
lappend ::nettool::blocks 4560 4562
lappend ::nettool::blocks 4564 4565
lappend ::nettool::blocks 4569 4569
lappend ::nettool::blocks 4571 4589
lappend ::nettool::blocks 4606 4657
lappend ::nettool::blocks 4693 4699
lappend ::nettool::blocks 4705 4724
lappend ::nettool::blocks 4734 4736
lappend ::nettool::blocks 4746 4746
lappend ::nettool::blocks 4748 4748
lappend ::nettool::blocks 4754 4783
lappend ::nettool::blocks 4792 4799
lappend ::nettool::blocks 4805 4826
lappend ::nettool::blocks 4828 4836
lappend ::nettool::blocks 4846 4846
lappend ::nettool::blocks 4852 4866
lappend ::nettool::blocks 4872 4875
lappend ::nettool::blocks 4886 4893
lappend ::nettool::blocks 4895 4898
lappend ::nettool::blocks 4903 4911
lappend ::nettool::blocks 4916 4935
lappend ::nettool::blocks 4938 4939
lappend ::nettool::blocks 4943 4948
lappend ::nettool::blocks 4954 4968
lappend ::nettool::blocks 4971 4983
lappend ::nettool::blocks 4992 4998
lappend ::nettool::blocks 5016 5019
lappend ::nettool::blocks 5033 5041
lappend ::nettool::blocks 5076 5077
lappend ::nettool::blocks 5088 5089
lappend ::nettool::blocks 5095 5098
lappend ::nettool::blocks 5107 5110
lappend ::nettool::blocks 5113 5113
lappend ::nettool::blocks 5118 5119
lappend ::nettool::blocks 5121 5132
lappend ::nettool::blocks 5138 5145
lappend ::nettool::blocks 5147 5149
lappend ::nettool::blocks 5151 5151
lappend ::nettool::blocks 5158 5160
lappend ::nettool::blocks 5165 5165
lappend ::nettool::blocks 5169 5171
lappend ::nettool::blocks 5173 5189
lappend ::nettool::blocks 5197 5199
lappend ::nettool::blocks 5204 5208
lappend ::nettool::blocks 5210 5214
lappend ::nettool::blocks 5216 5220
lappend ::nettool::blocks 5238 5244
lappend ::nettool::blocks 5254 5263
lappend ::nettool::blocks 5266 5268
lappend ::nettool::blocks 5273 5279
lappend ::nettool::blocks 5283 5297
lappend ::nettool::blocks 5311 5311
lappend ::nettool::blocks 5316 5316
lappend ::nettool::blocks 5319 5319
lappend ::nettool::blocks 5322 5342
lappend ::nettool::blocks 5345 5348
lappend ::nettool::blocks 5365 5396
lappend ::nettool::blocks 5438 5442
lappend ::nettool::blocks 5444 5444
lappend ::nettool::blocks 5446 5452
lappend ::nettool::blocks 5457 5460
lappend ::nettool::blocks 5466 5499
lappend ::nettool::blocks 5507 5552
lappend ::nettool::blocks 5558 5565
lappend ::nettool::blocks 5570 5572
lappend ::nettool::blocks 5576 5578
lappend ::nettool::blocks 5587 5596
lappend ::nettool::blocks 5606 5617
lappend ::nettool::blocks 5619 5626
lappend ::nettool::blocks 5640 5645
lappend ::nettool::blocks 5647 5669
lappend ::nettool::blocks 5685 5686
lappend ::nettool::blocks 5690 5692
lappend ::nettool::blocks 5694 5695
lappend ::nettool::blocks 5697 5712
lappend ::nettool::blocks 5731 5740
lappend ::nettool::blocks 5749 5749
lappend ::nettool::blocks 5751 5754
lappend ::nettool::blocks 5756 5756
lappend ::nettool::blocks 5758 5765
lappend ::nettool::blocks 5772 5776
lappend ::nettool::blocks 5778 5779
lappend ::nettool::blocks 5788 5792
lappend ::nettool::blocks 5795 5812
lappend ::nettool::blocks 5815 5840
lappend ::nettool::blocks 5843 5858
lappend ::nettool::blocks 5860 5862
lappend ::nettool::blocks 5864 5867
lappend ::nettool::blocks 5869 5882
lappend ::nettool::blocks 5884 5899
lappend ::nettool::blocks 5901 5909
lappend ::nettool::blocks 5914 5962
lappend ::nettool::blocks 5964 5967
lappend ::nettool::blocks 5970 5983
lappend ::nettool::blocks 5993 5998
lappend ::nettool::blocks 6067 6067
lappend ::nettool::blocks 6078 6080
lappend ::nettool::blocks 6089 6098
lappend ::nettool::blocks 6119 6120
lappend ::nettool::blocks 6125 6129
lappend ::nettool::blocks 6131 6132
lappend ::nettool::blocks 6134 6139
lappend ::nettool::blocks 6150 6158
lappend ::nettool::blocks 6164 6199
lappend ::nettool::blocks 6202 6221
lappend ::nettool::blocks 6223 6240
lappend ::nettool::blocks 6245 6250
lappend ::nettool::blocks 6254 6266
lappend ::nettool::blocks 6270 6299
lappend ::nettool::blocks 6301 6305
lappend ::nettool::blocks 6307 6314
lappend ::nettool::blocks 6318 6319
lappend ::nettool::blocks 6323 6323
lappend ::nettool::blocks 6327 6342
lappend ::nettool::blocks 6345 6345
lappend ::nettool::blocks 6348 6349
lappend ::nettool::blocks 6351 6354
lappend ::nettool::blocks 6356 6359
lappend ::nettool::blocks 6361 6362
lappend ::nettool::blocks 6364 6369
lappend ::nettool::blocks 6371 6381
lappend ::nettool::blocks 6383 6388
lappend ::nettool::blocks 6391 6399
lappend ::nettool::blocks 6411 6416
lappend ::nettool::blocks 6422 6431
lappend ::nettool::blocks 6433 6441
lappend ::nettool::blocks 6444 6445
lappend ::nettool::blocks 6447 6454
lappend ::nettool::blocks 6457 6470
lappend ::nettool::blocks 6472 6479
lappend ::nettool::blocks 6490 6499
lappend ::nettool::blocks 6501 6508
lappend ::nettool::blocks 6512 6512
lappend ::nettool::blocks 6516 6542
lappend ::nettool::blocks 6545 6546
lappend ::nettool::blocks 6552 6557
lappend ::nettool::blocks 6559 6565
lappend ::nettool::blocks 6569 6578
lappend ::nettool::blocks 6584 6599
lappend ::nettool::blocks 6603 6618
lappend ::nettool::blocks 6629 6631
lappend ::nettool::blocks 6635 6639
lappend ::nettool::blocks 6641 6652
lappend ::nettool::blocks 6654 6654
lappend ::nettool::blocks 6658 6664
lappend ::nettool::blocks 6672 6677
lappend ::nettool::blocks 6680 6686
lappend ::nettool::blocks 6690 6695
lappend ::nettool::blocks 6698 6700
lappend ::nettool::blocks 6707 6713
lappend ::nettool::blocks 6717 6766
lappend ::nettool::blocks 6772 6776
lappend ::nettool::blocks 6779 6783
lappend ::nettool::blocks 6792 6800
lappend ::nettool::blocks 6802 6816
lappend ::nettool::blocks 6818 6830
lappend ::nettool::blocks 6832 6840
lappend ::nettool::blocks 6843 6849
lappend ::nettool::blocks 6851 6867
lappend ::nettool::blocks 6869 6887
lappend ::nettool::blocks 6889 6900
lappend ::nettool::blocks 6902 6934
lappend ::nettool::blocks 6937 6945
lappend ::nettool::blocks 6947 6950
lappend ::nettool::blocks 6952 6960
lappend ::nettool::blocks 6967 6968
lappend ::nettool::blocks 6971 6996
lappend ::nettool::blocks 7016 7017
lappend ::nettool::blocks 7026 7029
lappend ::nettool::blocks 7032 7039
lappend ::nettool::blocks 7041 7069
lappend ::nettool::blocks 7072 7072
lappend ::nettool::blocks 7074 7079
lappend ::nettool::blocks 7081 7094
lappend ::nettool::blocks 7096 7098
lappend ::nettool::blocks 7102 7106
lappend ::nettool::blocks 7108 7120
lappend ::nettool::blocks 7122 7127
lappend ::nettool::blocks 7130 7160
lappend ::nettool::blocks 7175 7180
lappend ::nettool::blocks 7182 7199
lappend ::nettool::blocks 7202 7226
lappend ::nettool::blocks 7230 7234
lappend ::nettool::blocks 7238 7261
lappend ::nettool::blocks 7263 7271
lappend ::nettool::blocks 7284 7299
lappend ::nettool::blocks 7360 7364
lappend ::nettool::blocks 7366 7390
lappend ::nettool::blocks 7396 7396
lappend ::nettool::blocks 7398 7399
lappend ::nettool::blocks 7403 7409
lappend ::nettool::blocks 7412 7420
lappend ::nettool::blocks 7422 7425
lappend ::nettool::blocks 7432 7436
lappend ::nettool::blocks 7438 7442
lappend ::nettool::blocks 7444 7470
lappend ::nettool::blocks 7472 7472
lappend ::nettool::blocks 7475 7490
lappend ::nettool::blocks 7492 7499
lappend ::nettool::blocks 7502 7507
lappend ::nettool::blocks 7512 7541
lappend ::nettool::blocks 7551 7559
lappend ::nettool::blocks 7561 7562
lappend ::nettool::blocks 7564 7565
lappend ::nettool::blocks 7567 7568
lappend ::nettool::blocks 7571 7573
lappend ::nettool::blocks 7575 7587
lappend ::nettool::blocks 7589 7623
lappend ::nettool::blocks 7625 7625
lappend ::nettool::blocks 7632 7632
lappend ::nettool::blocks 7634 7647
lappend ::nettool::blocks 7649 7671
lappend ::nettool::blocks 7678 7679
lappend ::nettool::blocks 7681 7688
lappend ::nettool::blocks 7690 7696
lappend ::nettool::blocks 7698 7699
lappend ::nettool::blocks 7701 7706
lappend ::nettool::blocks 7709 7719
lappend ::nettool::blocks 7721 7723
lappend ::nettool::blocks 7728 7733
lappend ::nettool::blocks 7735 7737
lappend ::nettool::blocks 7739 7740
lappend ::nettool::blocks 7745 7746
lappend ::nettool::blocks 7748 7776
lappend ::nettool::blocks 7780 7780
lappend ::nettool::blocks 7782 7785
lappend ::nettool::blocks 7788 7788
lappend ::nettool::blocks 7790 7793
lappend ::nettool::blocks 7795 7796
lappend ::nettool::blocks 7803 7809
lappend ::nettool::blocks 7811 7844
lappend ::nettool::blocks 7848 7868
lappend ::nettool::blocks 7873 7877
lappend ::nettool::blocks 7879 7879
lappend ::nettool::blocks 7881 7886
lappend ::nettool::blocks 7888 7899
lappend ::nettool::blocks 7904 7912
lappend ::nettool::blocks 7914 7931
lappend ::nettool::blocks 7934 7961
lappend ::nettool::blocks 7963 7966
lappend ::nettool::blocks 7968 7978
lappend ::nettool::blocks 7983 7996
lappend ::nettool::blocks 8004 8004
lappend ::nettool::blocks 8006 8007
lappend ::nettool::blocks 8009 8018
lappend ::nettool::blocks 8023 8024
lappend ::nettool::blocks 8027 8031
lappend ::nettool::blocks 8035 8039
lappend ::nettool::blocks 8041 8041
lappend ::nettool::blocks 8045 8050
lappend ::nettool::blocks 8061 8065
lappend ::nettool::blocks 8067 8073
lappend ::nettool::blocks 8075 8079
lappend ::nettool::blocks 8084 8085
lappend ::nettool::blocks 8089 8090
lappend ::nettool::blocks 8092 8096
lappend ::nettool::blocks 8098 8099
lappend ::nettool::blocks 8103 8114
lappend ::nettool::blocks 8119 8120
lappend ::nettool::blocks 8123 8127
lappend ::nettool::blocks 8133 8139
lappend ::nettool::blocks 8141 8147
lappend ::nettool::blocks 8150 8152
lappend ::nettool::blocks 8154 8159
lappend ::nettool::blocks 8163 8180
lappend ::nettool::blocks 8185 8190
lappend ::nettool::blocks 8193 8193
lappend ::nettool::blocks 8196 8198
lappend ::nettool::blocks 8203 8203
lappend ::nettool::blocks 8209 8229
lappend ::nettool::blocks 8231 8242
lappend ::nettool::blocks 8244 8275
lappend ::nettool::blocks 8277 8279
lappend ::nettool::blocks 8281 8291
lappend ::nettool::blocks 8295 8299
lappend ::nettool::blocks 8302 8312
lappend ::nettool::blocks 8314 8319
lappend ::nettool::blocks 8322 8350
lappend ::nettool::blocks 8352 8375
lappend ::nettool::blocks 8381 8382
lappend ::nettool::blocks 8384 8399
lappend ::nettool::blocks 8406 8414
lappend ::nettool::blocks 8418 8441
lappend ::nettool::blocks 8446 8449
lappend ::nettool::blocks 8451 8456
lappend ::nettool::blocks 8458 8469
lappend ::nettool::blocks 8475 8499
lappend ::nettool::blocks 8503 8553
lappend ::nettool::blocks 8556 8566
lappend ::nettool::blocks 8568 8599
lappend ::nettool::blocks 8601 8608
lappend ::nettool::blocks 8616 8664
lappend ::nettool::blocks 8667 8674
lappend ::nettool::blocks 8676 8685
lappend ::nettool::blocks 8687 8687
lappend ::nettool::blocks 8689 8698
lappend ::nettool::blocks 8700 8710
lappend ::nettool::blocks 8712 8731
lappend ::nettool::blocks 8734 8749
lappend ::nettool::blocks 8751 8762
lappend ::nettool::blocks 8767 8769
lappend ::nettool::blocks 8771 8777
lappend ::nettool::blocks 8779 8785
lappend ::nettool::blocks 8788 8792
lappend ::nettool::blocks 8794 8799
lappend ::nettool::blocks 8801 8803
lappend ::nettool::blocks 8805 8872
lappend ::nettool::blocks 8874 8879
lappend ::nettool::blocks 8882 8882
lappend ::nettool::blocks 8884 8887
lappend ::nettool::blocks 8895 8898
lappend ::nettool::blocks 8902 8909
lappend ::nettool::blocks 8914 8936
lappend ::nettool::blocks 8938 8952
lappend ::nettool::blocks 8955 8988
lappend ::nettool::blocks 8992 8997
lappend ::nettool::blocks 9003 9006
lappend ::nettool::blocks 9011 9019
lappend ::nettool::blocks 9027 9049
lappend ::nettool::blocks 9052 9079
lappend ::nettool::blocks 9081 9081
lappend ::nettool::blocks 9094 9099
lappend ::nettool::blocks 9108 9118
lappend ::nettool::blocks 9120 9121
lappend ::nettool::blocks 9124 9130
lappend ::nettool::blocks 9132 9159
lappend ::nettool::blocks 9165 9190
lappend ::nettool::blocks 9192 9199
lappend ::nettool::blocks 9218 9221
lappend ::nettool::blocks 9223 9254
lappend ::nettool::blocks 9256 9276
lappend ::nettool::blocks 9288 9291
lappend ::nettool::blocks 9296 9299
lappend ::nettool::blocks 9301 9305
lappend ::nettool::blocks 9307 9311
lappend ::nettool::blocks 9313 9317
lappend ::nettool::blocks 9319 9320
lappend ::nettool::blocks 9322 9342
lappend ::nettool::blocks 9345 9345
lappend ::nettool::blocks 9347 9373
lappend ::nettool::blocks 9375 9379
lappend ::nettool::blocks 9381 9386
lappend ::nettool::blocks 9391 9395
lappend ::nettool::blocks 9398 9399
lappend ::nettool::blocks 9403 9417
lappend ::nettool::blocks 9419 9442
lappend ::nettool::blocks 9446 9449
lappend ::nettool::blocks 9451 9499
lappend ::nettool::blocks 9501 9521
lappend ::nettool::blocks 9523 9534
lappend ::nettool::blocks 9537 9554
lappend ::nettool::blocks 9556 9591
lappend ::nettool::blocks 9601 9611
lappend ::nettool::blocks 9613 9613
lappend ::nettool::blocks 9615 9615
lappend ::nettool::blocks 9619 9627
lappend ::nettool::blocks 9633 9639
lappend ::nettool::blocks 9641 9665
lappend ::nettool::blocks 9669 9693
lappend ::nettool::blocks 9696 9699
lappend ::nettool::blocks 9701 9746
lappend ::nettool::blocks 9748 9749
lappend ::nettool::blocks 9751 9752
lappend ::nettool::blocks 9754 9761
lappend ::nettool::blocks 9763 9799
lappend ::nettool::blocks 9803 9874
lappend ::nettool::blocks 9877 9877
lappend ::nettool::blocks 9879 9887
lappend ::nettool::blocks 9890 9897
lappend ::nettool::blocks 9904 9908
lappend ::nettool::blocks 9910 9910
lappend ::nettool::blocks 9912 9924
lappend ::nettool::blocks 9926 9949
lappend ::nettool::blocks 9957 9965
lappend ::nettool::blocks 9967 9977
lappend ::nettool::blocks 9979 9986
lappend ::nettool::blocks 9989 9989
lappend ::nettool::blocks 10003 10003
lappend ::nettool::blocks 10011 10022
lappend ::nettool::blocks 10024 10049
lappend ::nettool::blocks 10052 10054
lappend ::nettool::blocks 10056 10079
lappend ::nettool::blocks 10082 10099
lappend ::nettool::blocks 10105 10106
lappend ::nettool::blocks 10108 10109
lappend ::nettool::blocks 10112 10112
lappend ::nettool::blocks 10118 10127
lappend ::nettool::blocks 10130 10159
lappend ::nettool::blocks 10163 10199
lappend ::nettool::blocks 10202 10251
lappend ::nettool::blocks 10253 10259
lappend ::nettool::blocks 10261 10287
lappend ::nettool::blocks 10289 10320
lappend ::nettool::blocks 10322 10438
lappend ::nettool::blocks 10440 10499
lappend ::nettool::blocks 10501 10539
lappend ::nettool::blocks 10545 10630
lappend ::nettool::blocks 10632 10799
lappend ::nettool::blocks 10801 10804
lappend ::nettool::blocks 10806 10808
lappend ::nettool::blocks 10811 10859
lappend ::nettool::blocks 10861 10879
lappend ::nettool::blocks 10881 10989
lappend ::nettool::blocks 10991 10999
lappend ::nettool::blocks 11002 11094
lappend ::nettool::blocks 11096 11102
lappend ::nettool::blocks 11107 11107
lappend ::nettool::blocks 11113 11160
lappend ::nettool::blocks 11166 11170
lappend ::nettool::blocks 11176 11200
lappend ::nettool::blocks 11203 11207
lappend ::nettool::blocks 11209 11210
lappend ::nettool::blocks 11212 11318
lappend ::nettool::blocks 11322 11366
lappend ::nettool::blocks 11368 11370
lappend ::nettool::blocks 11372 11429
lappend ::nettool::blocks 11431 11488
lappend ::nettool::blocks 11490 11599
lappend ::nettool::blocks 11601 11622
lappend ::nettool::blocks 11624 11719
lappend ::nettool::blocks 11721 11722
lappend ::nettool::blocks 11724 11750
lappend ::nettool::blocks 11752 11795
lappend ::nettool::blocks 11797 11875
lappend ::nettool::blocks 11878 11966
lappend ::nettool::blocks 11968 11996
lappend ::nettool::blocks 12011 12011
lappend ::nettool::blocks 12014 12108
lappend ::nettool::blocks 12110 12120
lappend ::nettool::blocks 12122 12167
lappend ::nettool::blocks 12169 12171
lappend ::nettool::blocks 12173 12299
lappend ::nettool::blocks 12301 12301
lappend ::nettool::blocks 12303 12320
lappend ::nettool::blocks 12323 12344
lappend ::nettool::blocks 12346 12752
lappend ::nettool::blocks 12754 12864
lappend ::nettool::blocks 12866 13159
lappend ::nettool::blocks 13161 13215
lappend ::nettool::blocks 13219 13222
lappend ::nettool::blocks 13225 13399
lappend ::nettool::blocks 13401 13719
lappend ::nettool::blocks 13723 13723
lappend ::nettool::blocks 13725 13781
lappend ::nettool::blocks 13784 13784
lappend ::nettool::blocks 13787 13817
lappend ::nettool::blocks 13824 13893
lappend ::nettool::blocks 13895 13928
lappend ::nettool::blocks 13931 13999
lappend ::nettool::blocks 14003 14032
lappend ::nettool::blocks 14035 14140
lappend ::nettool::blocks 14143 14144
lappend ::nettool::blocks 14146 14148
lappend ::nettool::blocks 14151 14153
lappend ::nettool::blocks 14155 14249
lappend ::nettool::blocks 14251 14413
lappend ::nettool::blocks 14415 14935
lappend ::nettool::blocks 14938 14999
lappend ::nettool::blocks 15001 15001
lappend ::nettool::blocks 15003 15117
lappend ::nettool::blocks 15119 15344
lappend ::nettool::blocks 15346 15362
lappend ::nettool::blocks 15364 15554
lappend ::nettool::blocks 15556 15659
lappend ::nettool::blocks 15661 15739
lappend ::nettool::blocks 15741 15997
lappend ::nettool::blocks 16004 16019
lappend ::nettool::blocks 16022 16160
lappend ::nettool::blocks 16163 16308
lappend ::nettool::blocks 16312 16359
lappend ::nettool::blocks 16362 16366
lappend ::nettool::blocks 16369 16383
lappend ::nettool::blocks 16385 16618
lappend ::nettool::blocks 16620 16664
lappend ::nettool::blocks 16667 16899
lappend ::nettool::blocks 16901 16949
lappend ::nettool::blocks 16951 16990
lappend ::nettool::blocks 16996 17006
lappend ::nettool::blocks 17008 17183
lappend ::nettool::blocks 17186 17218
lappend ::nettool::blocks 17223 17233
lappend ::nettool::blocks 17236 17499
lappend ::nettool::blocks 17501 17554
lappend ::nettool::blocks 17556 17728
lappend ::nettool::blocks 17730 17753
lappend ::nettool::blocks 17757 17776
lappend ::nettool::blocks 17778 17999
lappend ::nettool::blocks 18001 18103
lappend ::nettool::blocks 18105 18135
lappend ::nettool::blocks 18137 18180
lappend ::nettool::blocks 18188 18240
lappend ::nettool::blocks 18244 18261
lappend ::nettool::blocks 18263 18462
lappend ::nettool::blocks 18464 18633
lappend ::nettool::blocks 18636 18768
lappend ::nettool::blocks 18770 18880
lappend ::nettool::blocks 18882 18887
lappend ::nettool::blocks 18889 18999
lappend ::nettool::blocks 19001 19006
lappend ::nettool::blocks 19008 19019
lappend ::nettool::blocks 19021 19190
lappend ::nettool::blocks 19192 19193
lappend ::nettool::blocks 19195 19282
lappend ::nettool::blocks 19284 19314
lappend ::nettool::blocks 19316 19397
lappend ::nettool::blocks 19399 19409
lappend ::nettool::blocks 19413 19538
lappend ::nettool::blocks 19542 19787
lappend ::nettool::blocks 19789 19997
lappend ::nettool::blocks 20004 20004
lappend ::nettool::blocks 20006 20011
lappend ::nettool::blocks 20015 20045
lappend ::nettool::blocks 20047 20047
lappend ::nettool::blocks 20050 20166
lappend ::nettool::blocks 20168 20201
lappend ::nettool::blocks 20203 20221
lappend ::nettool::blocks 20223 20479
lappend ::nettool::blocks 20481 20669
lappend ::nettool::blocks 20671 20998
lappend ::nettool::blocks 21001 21009
lappend ::nettool::blocks 21011 21552
lappend ::nettool::blocks 21555 21589
lappend ::nettool::blocks 21591 21799
lappend ::nettool::blocks 21801 21844
lappend ::nettool::blocks 21850 21999
lappend ::nettool::blocks 22006 22124
lappend ::nettool::blocks 22126 22127
lappend ::nettool::blocks 22129 22221
lappend ::nettool::blocks 22223 22272
lappend ::nettool::blocks 22274 22304
lappend ::nettool::blocks 22306 22342
lappend ::nettool::blocks 22344 22346
lappend ::nettool::blocks 22348 22349
lappend ::nettool::blocks 22352 22536
lappend ::nettool::blocks 22538 22554
lappend ::nettool::blocks 22556 22762
lappend ::nettool::blocks 22764 22799
lappend ::nettool::blocks 22801 22950
lappend ::nettool::blocks 22952 22999
lappend ::nettool::blocks 23006 23052
lappend ::nettool::blocks 23054 23271
lappend ::nettool::blocks 23273 23332
lappend ::nettool::blocks 23334 23399
lappend ::nettool::blocks 23403 23455
lappend ::nettool::blocks 23458 23545
lappend ::nettool::blocks 23547 23999
lappend ::nettool::blocks 24007 24241
lappend ::nettool::blocks 24243 24248
lappend ::nettool::blocks 24250 24320
lappend ::nettool::blocks 24323 24464
lappend ::nettool::blocks 24466 24553
lappend ::nettool::blocks 24555 24576
lappend ::nettool::blocks 24578 24675
lappend ::nettool::blocks 24679 24679
lappend ::nettool::blocks 24681 24753
lappend ::nettool::blocks 24755 24849
lappend ::nettool::blocks 24851 24921
lappend ::nettool::blocks 24923 24999
lappend ::nettool::blocks 25010 25470
lappend ::nettool::blocks 25472 25575
lappend ::nettool::blocks 25577 25603
lappend ::nettool::blocks 25605 25792
lappend ::nettool::blocks 25794 25899
lappend ::nettool::blocks 25904 25953
lappend ::nettool::blocks 25956 25999
lappend ::nettool::blocks 26001 26132
lappend ::nettool::blocks 26134 26207
lappend ::nettool::blocks 26209 26259
lappend ::nettool::blocks 26264 26485
lappend ::nettool::blocks 26488 26488
lappend ::nettool::blocks 26490 26999
lappend ::nettool::blocks 27010 27344
lappend ::nettool::blocks 27346 27441
lappend ::nettool::blocks 27443 27503
lappend ::nettool::blocks 27505 27781
lappend ::nettool::blocks 27783 27875
lappend ::nettool::blocks 27877 27998
lappend ::nettool::blocks 28002 28118
lappend ::nettool::blocks 28120 28199
lappend ::nettool::blocks 28201 28239
lappend ::nettool::blocks 28241 29117
lappend ::nettool::blocks 29119 29166
lappend ::nettool::blocks 29170 29998
lappend ::nettool::blocks 30005 30259
lappend ::nettool::blocks 30261 30831
lappend ::nettool::blocks 30833 30998
lappend ::nettool::blocks 31000 31019
lappend ::nettool::blocks 31021 31028
lappend ::nettool::blocks 31030 31399
lappend ::nettool::blocks 31401 31415
lappend ::nettool::blocks 31417 31456
lappend ::nettool::blocks 31458 31619
lappend ::nettool::blocks 31621 31684
lappend ::nettool::blocks 31686 31764
lappend ::nettool::blocks 31766 32033
lappend ::nettool::blocks 32035 32248
lappend ::nettool::blocks 32250 32482
lappend ::nettool::blocks 32484 32634
lappend ::nettool::blocks 32637 32766
lappend ::nettool::blocks 32778 32800
lappend ::nettool::blocks 32802 32810
lappend ::nettool::blocks 32812 32895
lappend ::nettool::blocks 32897 33122
lappend ::nettool::blocks 33124 33330
lappend ::nettool::blocks 33332 33332
lappend ::nettool::blocks 33335 33433
lappend ::nettool::blocks 33435 33655
lappend ::nettool::blocks 33657 34248
lappend ::nettool::blocks 34250 34377
lappend ::nettool::blocks 34380 34566
lappend ::nettool::blocks 34568 34961
lappend ::nettool::blocks 34965 34979
lappend ::nettool::blocks 34981 34999
lappend ::nettool::blocks 35007 35353
lappend ::nettool::blocks 35358 36000
lappend ::nettool::blocks 36002 36411
lappend ::nettool::blocks 36413 36421
lappend ::nettool::blocks 36423 36442
lappend ::nettool::blocks 36445 36523
lappend ::nettool::blocks 36525 36601
lappend ::nettool::blocks 36603 36699
lappend ::nettool::blocks 36701 36864
lappend ::nettool::blocks 36866 37474
lappend ::nettool::blocks 37476 37482
lappend ::nettool::blocks 37484 37653
lappend ::nettool::blocks 37655 37999
lappend ::nettool::blocks 38002 38200
lappend ::nettool::blocks 38204 38799
lappend ::nettool::blocks 38801 38864
lappend ::nettool::blocks 38866 39680
lappend ::nettool::blocks 39682 39999
lappend ::nettool::blocks 40001 40403
lappend ::nettool::blocks 40405 40840
lappend ::nettool::blocks 40844 40852
lappend ::nettool::blocks 40854 41110
lappend ::nettool::blocks 41112 41120
lappend ::nettool::blocks 41122 41793
lappend ::nettool::blocks 41798 42507
lappend ::nettool::blocks 42511 42999
lappend ::nettool::blocks 43001 44320
lappend ::nettool::blocks 44323 44443
lappend ::nettool::blocks 44445 44543
lappend ::nettool::blocks 44545 44552
lappend ::nettool::blocks 44554 44599
lappend ::nettool::blocks 44601 44899
lappend ::nettool::blocks 44901 44999
lappend ::nettool::blocks 45002 45044
lappend ::nettool::blocks 45046 45053
lappend ::nettool::blocks 45055 45677
lappend ::nettool::blocks 45679 45823
lappend ::nettool::blocks 45826 45965
lappend ::nettool::blocks 45967 46997
lappend ::nettool::blocks 47002 47099
lappend ::nettool::blocks 47101 47556
lappend ::nettool::blocks 47558 47623
lappend ::nettool::blocks 47625 47805
lappend ::nettool::blocks 47807 47807
lappend ::nettool::blocks 47810 47999
lappend ::nettool::blocks 48006 48048
lappend ::nettool::blocks 48051 48127
lappend ::nettool::blocks 48130 48555
lappend ::nettool::blocks 48557 48618
lappend ::nettool::blocks 48620 48652
lappend ::nettool::blocks 48654 48999
lappend ::nettool::blocks 49001 65535
|
Added modules/nettool/src/core.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 |
# @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]
|
Added modules/nettool/src/generic.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 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 |
::namespace eval ::nettool {}
###
# topic: 825cd25953c2cc896a96006b7f454e00
# title: Return pairings of MAC numbers to IP addresses on the local network
###
proc ::nettool::arp_table {} {}
###
# topic: 92ebbfa155883ad41c37d3f843392be4
# title: Return list of broadcast addresses for local networks
###
proc ::nettool::broadcast_list {} {
return 127.0.0.1
}
###
# topic: 15d9bc96ec6ce31d4c8f99a425a9c02c
# description: Return Processor utilization
###
proc ::nettool::busy {} {}
###
# topic: 187cfa1827097c5cdf1c40c656cedfcc
# description: Return time since booted
###
proc ::nettool::cpuinfo {} {}
###
# Clear discovered info
###
proc ::nettool::discover {} {
unset -nocomplain ::nettool::ipinfo ::nettool::macinfo
}
###
# topic: 58295f2544f43827e855d09dc3ee625a
###
proc ::nettool::diskless_client {} {
return 0
}
###
# topic: 57fdc331bc60c7bf2bd3f3214e9a906f
###
proc ::nettool::hwaddr_to_ipaddr {hwaddr args} {}
###
# topic: dd2e2c0810cea69909399808f2a68949
# title: Return a list of unique hardware ids
###
proc ::nettool::hwid_list {} {
set result {}
foreach mac [::nettool::mac_list] {
lappend result 0x[string map {: {}} $mac]
}
if {[llength $result]} {
return $result
}
return 0x010203040506
}
###
# topic: 4b87d977492bd10802bfc0327cd07ac2
# title: Return list of network interfaces
###
proc ::nettool::if_list {} {}
###
# topic: d2932eb0ea8cc9f6a865c1ab7cdd4572
# description:
# Called on package load to build any static
# structures to cache data that would be time
# consuming to call on the fly
###
proc ::nettool::init {} {}
###
# topic: 417672d3f31b80d749588365af88baf6
# title: Return list of ip addresses for this computer (primary first)
###
proc ::nettool::ip_list {} {}
###
# topic: ac9d6815d47f60d45930f0c8c8ae8f16
# title: Return list of mac numbers for this computer (primary first)
###
proc ::nettool::mac_list {} {}
###
# topic: c42343f20e3afd2884a5dd1c219e4415
###
proc ::nettool::platform {} {
variable platform
return $platform
}
proc ::nettool::user_data_root {appname} {
return [file join $::env(HOME) .$appname]
}
|
Added modules/nettool/src/locateport.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 69 70 71 72 73 74 75 |
::namespace eval ::nettool {}
###
# topic: fc6f8b9587dd5524f143f9df4be4755b63eb6cd5
###
proc ::nettool::allocate_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
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
}
|
Added modules/nettool/src/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 |
###
# Generic answers that can be answered on most if not all unix platforms
###
if {$::tcl_platform(platform) eq "unix"} {
###
# topic: 825cd25953c2cc896a96006b7f454e00
# title: Return pairings of MAC numbers to IP addresses on the local network
# description: Under unix, we call the arp command for arp table resolution
###
proc ::nettool::arp_table {} {
set result {}
set dat [exec arp -a]
foreach line [split $dat \n] {
set host [lindex $line 0]
set ip [lindex $line 1]
set macid [lindex $line 3]
lappend result $macid [string range $ip 1 end-1]
}
return $result
}
}
|
Added modules/nettool/src/platform_unix_linux.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 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 213 214 215 216 217 218 219 220 221 222 223 224 |
if {$::tcl_platform(platform) eq "unix" && $genus eq "linux"} {
###
# 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 info} [dump] {
if {[dict exists $info ipv4 Bcast:]} {
lappend result [dict get $info ipv4 Bcast:]
}
}
return [lsort -unique -dictionary $result]
}
###
# topic: 187cfa1827097c5cdf1c40c656cedfcc
# description: Return time since booted
###
proc ::nettool::cpuinfo args {
variable cpuinfo
if {![info exists cpuinfo]} {
set cpuinfo {}
set dat [cat /proc/meminfo]
foreach line [split $dat \n] {
switch [lindex $line 0] {
MemTotal: {
# Normalize to MB
dict set cpuinfo memory [lindex $line 1]/1024
}
}
}
set cpus 0
set dat [cat /proc/cpuinfo]
foreach line [split $dat \n] {
set idx [string first : $line]
set field [string trim [string range $line 0 $idx-1]]
set value [string trim [string range $line $idx+1 end]]
switch $field {
processor {
incr cpus
}
{cpu family} {
dict set cpuinfo family $value
}
model {
dict set cpuinfo model $value
}
stepping {
dict set cpuinfo stepping $value
}
vendor_id {
dict set cpuinfo vendor $value
}
{model name} {
dict set cpuinfo brand $value
}
{cpu MHz} {
dict set cpuinfo speed $value
}
flags {
dict set cpuinfo features $value
}
}
}
dict set cpuinfo cpus $cpus
}
if {$args eq "<list>"} {
return [dict keys $cpuinfo]
}
if {[llength $args]==0} {
return $cpuinfo
}
if {[llength $args]==1} {
return [dict get $cpuinfo [lindex $args 0]]
}
set result {}
foreach item $args {
if {[dict exists $cpuinfo $item]} {
dict set result $item [dict get $cpuinfo $item]
} else {
dict set result $item {}
}
}
return $result
}
###
# topic: aa8eda4fb59296a1a34d8d600ca54e28
# description: Dump interfaces
###
proc ::nettool::dump {} {
set data [exec ifconfig]
set iface {}
set result {}
foreach line [split $data \n] {
if {[string index $line 0] in {" " "\t"} } {
# Indented line appends the prior iface
switch [lindex $line 0] {
inet {
foreach tuple [lrange $line 1 end] {
set idx [string first : $tuple]
set field [string trim [string range $tuple 0 $idx]]
set value [string trim [string range $tuple $idx+1 end]]
dict set result $iface ipv4 [string trim $field] [string trim $value]
}
}
inet6 {
dict set result $iface ipv6 addr: [lindex $line 2]
foreach tuple [lrange $line 3 end] {
set idx [string first : $tuple]
set field [string trim [string range $tuple 0 $idx]]
set value [string trim [string range $tuple $idx+1 end]]
dict set result $iface ipv6 [string trim $field] [string trim $value]
}
}
}
} else {
# Non-intended line - new iface
set iface [lindex $line 0]
set idx [lsearch $line HWaddr]
if {$idx >= 0 } {
dict set result $iface ether: [lindex $line $idx+1]
}
}
}
return $result
}
###
# topic: 417672d3f31b80d749588365af88baf6
# title: Return list of ip addresses for this computer (primary first)
###
proc ::nettool::ip_list {} {
set result {}
foreach {iface info} [dump] {
if {[dict exists $info ipv4 addr:]} {
lappend result [dict get $info ipv4 addr:]
}
}
ldelete result 127.0.0.1
return $result
}
###
# topic: ac9d6815d47f60d45930f0c8c8ae8f16
# title: Return list of mac numbers for this computer (primary first)
###
proc ::nettool::mac_list {} {
set result {}
foreach {iface info} [dump] {
if {[dict exists $info ether:]} {
lappend result [dict get $info ether:]
}
}
return $result
}
###
# topic: a43b6f42141820e0ba1094840d0f6fc0
###
proc ::nettool::network_list {} {
foreach {iface info} [dump] {
if {![dict exists $info ipv4 addr:]} continue
if {![dict exists $info ipv4 Mask:]} continue
#set mask [::ip::maskToInt $netmask]
set addr [dict get $info ipv4 addr:]
set mask [dict get $info ipv4 Mask:]
set addri [::ip::toInteger $addr]
lappend result [ip::nativeToPrefix [list [expr {$addri & $mask}] $mask] -ipv4]
}
return $result
}
###
# topic: e7db1ae1b5b98a1bb4384f0a4fe81f42
###
proc ::nettool::status {} {
set result {}
set dat [cat /proc/loadavg]
dict set result load_average [lrange $dat 0 2]
set cpus [cpuinfo cpus].0
dict set result load [expr {[lindex $dat 0]/$cpus}]
set processes [split [lindex $dat 3] /]
dict set result processes_running [lindex $processes 0]
dict set result processes_total [lindex $processes 1]
set dat [cat /proc/meminfo]
foreach line [split $dat \n] {
switch [lindex $line 0] {
MemTotal: {
# Normalize to MB
dict set result memory_total [expr {[lindex $line 1]/1024}]
}
MemFree: {
# Normalize to MB
dict set result memory_free [expr {[lindex $line 1]/1024}]
}
}
}
return $result
}
###
# topic: 59bf977ad7287b4d90346fad639aed34
###
proc ::nettool::uptime_report {} {
set result {}
set dat [split [exec uptime] ,]
puts $dat
dict set result time [lindex [lindex $dat 0] 0]
dict set result uptime [lrange [lindex $dat 0] 1 end]
dict set result users [lindex [lindex $dat 2] 0]
dict set result load_1_minute [lindex [lindex $dat 3] end]
dict set result load_5_minute [lindex [lindex $dat 4] end]
dict set result load_15_minute [lindex [lindex $dat 5] end]
return $result
}
unset -nocomplain ::nettool::cpuinfo
}
|
Added modules/nettool/src/platform_unix_macosx.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 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 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 |
if {$::tcl_platform(platform) eq "unix" && $genus eq "macosx"} {
###
# topic: 825cd25953c2cc896a96006b7f454e00
# title: Return pairings of MAC numbers to IP addresses on the local network
# description: Under macosx, we call the arp command for arp table resolution
###
proc ::nettool::arp_table {} {
set result {}
set dat [exec arp -a]
foreach line [split $dat \n] {
set host [lindex $line 0]
set ip [lindex $line 1]
set macid [lindex $line 3]
lappend result $macid [string range $ip 1 end-1]
}
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 info} [dump] {
if {[dict exists $info broadcast:]} {
lappend result [dict get $info broadcast:]
}
}
return [lsort -unique -dictionary $result]
}
###
# topic: 187cfa1827097c5cdf1c40c656cedfcc
# description: Return time since booted
###
proc ::nettool::cpuinfo args {
variable cpuinfo
if {![info exists cpuinfo]} {
set cpuinfo {}
dict set cpuinfo machine [exec sysctl -n hw.machine]
dict set cpuinfo cpus [exec sysctl -n hw.ncpu]
# Normalize to MB
dict set cpuinfo memory [expr {[exec sysctl -n hw.memsize] / 1048576}]
dict set cpuinfo vendor [exec sysctl -n machdep.cpu.vendor]
dict set cpuinfo brand [exec sysctl -n machdep.cpu.brand_string]
dict set cpuinfo model [exec sysctl -n machdep.cpu.model]
dict set cpuinfo speed [expr {[exec sysctl -n hw.cpufrequency]/1000000}]
dict set cpuinfo family [exec sysctl -n machdep.cpu.family]
dict set cpuinfo stepping [exec sysctl -n machdep.cpu.stepping]
dict set cpuinfo features [exec sysctl -n machdep.cpu.features]
dict set cpuinfo diskless []
}
if {$args eq "<list>"} {
return [dict keys $cpuinfo]
}
if {[llength $args]==0} {
return $cpuinfo
}
if {[llength $args]==1} {
return [dict get $cpuinfo [lindex $args 0]]
}
set result {}
foreach item $args {
if {[dict exists $cpuinfo $item]} {
dict set result $item [dict get $cpuinfo $item]
} else {
dict set result $item {}
}
}
return $result
}
###
# topic: aa8eda4fb59296a1a34d8d600ca54e28
# description: Dump interfaces
###
proc ::nettool::dump {} {
set data [exec ifconfig]
set iface {}
set result {}
foreach line [split $data \n] {
if {[string index $line 0] in {" " "\t"} } {
# Indented line appends the prior iface
foreach {field value} $line {
dict set result $iface [string trimright $field :]: $value
}
} else {
# Non-intended line - new iface
set iface [lindex $line 0]
}
}
return $result
}
###
# topic: dd2e2c0810cea69909399808f2a68949
# title: Return a list of unique hardware addresses
###
proc ::nettool::hwid_list {} {
variable cached_data
set result {}
if {![info exists cached_data]} {
if {[catch {exec system_profiler SPHardwareDataType} hwlist]} {
set cached_data {}
} else {
set cached_data $hwlist
}
}
set serial {}
set hwuuid {}
set result {}
catch {
foreach line [split $cached_data \n] {
if { [lindex $line 0] == "Serial" && [lindex $line 1] == "Number" } {
set serial [lindex $line end]
}
if { [lindex $line 0] == "Hardware" && [lindex $line 1] == "UUID:" } {
set hwuuid [lindex $line end]
}
}
}
if { $hwuuid != {} } {
lappend result 0x[string map {- {}} $hwuuid]
}
# Blank serial number?
if { $serial != {} } {
set sn [binary scan $serial H* hash]
lappend result 0x$hash
}
if {[llength $result]} {
return $result
}
foreach mac [::nettool::mac_list] {
lappend result 0x[string map {: {}} $mac]
}
if {[llength $result]} {
return $result
}
return 0x010203040506
}
###
# topic: d2932eb0ea8cc9f6a865c1ab7cdd4572
# description:
# Called on package load to build any static
# structures to cache data that would be time
# consuming to call on the fly
###
proc ::nettool::init {} {
unset -nocomplain [namespace current]::cpuinfo
}
###
# topic: 417672d3f31b80d749588365af88baf6
# title: Return list of ip addresses for this computer (primary first)
###
proc ::nettool::ip_list {} {
set result {}
foreach {iface info} [dump] {
if {[dict exists $info inet:]} {
lappend result [dict get $info inet:]
}
}
ldelete result 127.0.0.1
return $result
}
###
# topic: ac9d6815d47f60d45930f0c8c8ae8f16
# title: Return list of mac numbers for this computer (primary first)
###
proc ::nettool::mac_list {} {
set result {}
foreach {iface info} [dump] {
if {[dict exists $info ether:]} {
lappend result [dict get $info ether:]
}
}
return $result
}
###
# topic: a43b6f42141820e0ba1094840d0f6fc0
###
proc ::nettool::network_list {} {
foreach {iface info} [dump] {
if {![dict exists $info inet:]} continue
if {![dict exists $info netmask:]} continue
#set mask [::ip::maskToInt $netmask]
set addr [dict get $info inet:]
set mask [dict get $info netmask:]
set addri [::ip::toInteger $addr]
lappend result [ip::nativeToPrefix [list [expr {$addri & $mask}] $mask] -ipv4]
}
return $result
}
###
# topic: e7db1ae1b5b98a1bb4384f0a4fe81f42
###
proc ::nettool::status {} {
set result {}
set loaddat [lindex [exec sysctl -n vm.loadavg] 0]
set cpus [cpuinfo cpus]
dict set result cpus $cpus
dict set result load [expr {[lindex $loaddat 0]*100.0/$cpus}]
dict set result load_average_1 [lindex $loaddat 0]
dict set result load_average_5 [lindex $loaddat 1]
dict set result load_average_15 [lindex $loaddat 2]
set total [exec sysctl -n hw.memsize]
dict set result memory_total [expr {$total / 1048576}]
set used 0
foreach {amt} [exec sysctl -n machdep.memmap] {
incr used $amt
}
dict set result memory_free [expr {($total - $used) / 1048576}]
return $result
}
proc ::nettool::user_data_root {appname} {
return [file join $::env(HOME) Library {Application Support} $appname]
}
}
|
Added modules/nettool/src/platform_windows.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 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 |
if {$::tcl_platform(platform) eq "windows"} {
###
# 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: 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]
}
###
# Provide a limited subset using data gleaned from exec
# These calls work in Windows NT 4 and above
###
proc ::nettool::IPINFO {} {
if {![info exists ::nettool::ipinfo]} {
set ::nettool::ipinfo [exec ipconfig /all]
}
return $::nettool::ipinfo
}
proc ::nettool::if_list {} {
return [mac_list]
}
proc ::nettool::ip_list {} {
set result {}
foreach line [split [IPINFO] \n] {
if {![regexp {IPv4 Address} $line]} continue
set line [string range $line [string first ":" $line]+2 end]
if {[scan $line %d.%d.%d.%d A B C D]!=4} continue
lappend result $A.$B.$C.$D
}
return $result
}
proc ::nettool::mac_list {} {
set result {}
foreach line [split [IPINFO] \n] {
if {![regexp {Physical Address} $line]} continue
set line [string range $line [string first ":" $line]+2 end]
if {[scan $line %02x-%02x-%02x-%02x-%02x-%02x A B C D E F] != 6} continue
if {$A==0 && $B==0 && $C==0 && $D==0 && $E==0 && $F==0} continue
lappend result [format %02x:%02x:%02x:%02x:%02x:%02x $A $B $C $D $E $F]
}
return $result
}
proc ::nettool::network_list {} {
set masks {}
foreach line [split [IPINFO] \n] {
if {![regexp {Subnet Mask} $line]} continue
set line [string range $line [string first ":" $line]+2 end]
if {[scan $line %d.%d.%d.%d A B C D]!=4} continue
lappend masks $A.$B.$C.$D
}
set result {}
set idx -1
foreach addr [ip_list] {
set netmask [lindex $masks [incr idx]]
set mask [::ip::maskToInt $netmask]
set addri [::ip::toInteger $addr]
lappend result [ip::nativeToPrefix [list [expr {$addri & $mask}] $netmask] -ipv4]
}
return $result
}
proc ::nettool::status {} {
}
proc ::nettool::user_data_root {appname} {
return [file join $::env(APPDATA) $appname]
}
}
|
Added modules/nettool/src/platform_windows_twapi.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 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 |
if {$::tcl_platform(platform) eq "windows" && ![catch {package require twapi}]} {
# TWAPI Based implementation
::namespace eval ::nettool {}
###
# topic: 825cd25953c2cc896a96006b7f454e00
# title: Return pairings of MAC numbers to IP addresses on the local network
# description: Under macosx, we call the arp command for arp table resolution
###
proc ::nettool::arp_table {} {
set result {}
catch {
foreach element [::twapi::get_arp_table] {
foreach {ifidx macid ipaddr type} {
lappend result [string map {- :} $macid] $ipaddr
}
}
}
return $result
}
###
# topic: 57fdc331bc60c7bf2bd3f3214e9a906f
###
proc ::nettool::hwaddr_to_ipaddr args {
return [::twapi::hwaddr_to_ipaddr {*}$args]
}
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 {}
foreach iface [::twapi::get_netif_indices] {
foreach {field value} [::twapi::get_netif_info $iface -physicaladdress] {
if { $value eq {} } continue
lappend result [string map {- :} $value]
}
}
return $result
}
###
# topic: a43b6f42141820e0ba1094840d0f6fc0
###
proc ::nettool::network_list {} {
set result {}
foreach iface [::twapi::get_netif_indices] {
set dat [::twapi::GetIpAddrTable $iface]
foreach element $dat {
foreach {addr ifindx netmask broadcast reamsize} $element break;
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: 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...
if {[catch {::twapi::get_system_ipaddrs -version 4}]} {
# THEY CHANGED THE API ON ME!
proc ::nettool::ip_list {} {
set result [::twapi::get_system_ipaddrs -ipversion 4]
ldelete result 127.0.0.1
return $result
}
} else {
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} {
if [catch {
set pu [lindex [::twapi::get_processor_info $p -processorutilization] 1]
while {$pu eq {}} {
after 100 {set pause 0}
vwait pause
set pu [lindex [::twapi::get_processor_info $p -processorutilization] 1]
}
set usage [expr {$usage+$pu}]
} err] {
set usage -1
}
}
dict set result cpus $cpus
dict set result load [expr {$usage/$cpus}]
dict set result uptime [::twapi::get_system_uptime]
}
}
|
Added modules/nettool/src/service-names-port-numbers.csv.
more than 10,000 changes
Changes to modules/oodialect/oodialect.tcl.
1 2 3 | ### # oodialect.tcl # | > | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | ### # oodialect.tcl # # Copyright (c) 2015-2018 Sean Woods # Copyright (c) 2015 Donald K Fellows # # BSD License ### # @@ Meta Begin # Package oo::dialect 0.3.3 # Meta platform tcl # Meta summary A utility for defining a domain specific language for TclOO systems # Meta description This package allows developers to generate # Meta description domain specific languages to describe TclOO # Meta description classes and objects. # Meta category TclOO # Meta subject oodialect |
| ︙ | ︙ | |||
152 153 154 155 156 157 158 |
proc ::oo::dialect::DefineThunk {target args} {
tailcall ::oo::define [Peek] $target {*}$args
}
proc ::oo::dialect::Canonical {namespace NSpace class} {
namespace upvar $namespace cname cname
| | | < > > > > | | 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 |
proc ::oo::dialect::DefineThunk {target args} {
tailcall ::oo::define [Peek] $target {*}$args
}
proc ::oo::dialect::Canonical {namespace NSpace class} {
namespace upvar $namespace cname cname
#if {[string match ::* $class]} {
# return $class
#}
if {[info exists cname($class)]} {
return $cname($class)
}
if {[info exists ::oo::dialect::cname($class)]} {
return $::oo::dialect::cname($class)
}
if {[info exists ::oo::dialect::cname(${NSpace}::${class})]} {
return $::oo::dialect::cname(${NSpace}::${class})
}
foreach item [list "${NSpace}::$class" "::$class"] {
if {[info commands $item] ne {}} {
return $item
}
}
return ${NSpace}::$class
}
###
|
| ︙ | ︙ | |||
197 198 199 200 201 202 203 |
proc ::oo::dialect::Aliases {namespace args} {
set class [Peek]
namespace upvar $namespace cname cname
set NSpace [join [lrange [split $class ::] 1 end-2] ::]
set cname($class) $class
foreach name $args {
| > | | < > | 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 |
proc ::oo::dialect::Aliases {namespace args} {
set class [Peek]
namespace upvar $namespace cname cname
set NSpace [join [lrange [split $class ::] 1 end-2] ::]
set cname($class) $class
foreach name $args {
set cname($name) $class
#set alias $name
set alias [NSNormalize $NSpace $name]
# Add a local metaclass reference
if {![info exists ::oo::dialect::cname($alias)]} {
lappend ::oo::dialect::aliases($class) $alias
##
# Add a global reference, first come, first served
##
set ::oo::dialect::cname($alias) $class
}
}
}
|
| ︙ | ︙ | |||
246 247 248 249 250 251 252 |
superclass ::oo::class
constructor {define definitionScript} {
$define [self] {
superclass
}
$define [self] $definitionScript
}
| > > > | | > > | | 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 |
superclass ::oo::class
constructor {define definitionScript} {
$define [self] {
superclass
}
$define [self] $definitionScript
}
method aliases {} {
if {[info exists ::oo::dialect::aliases([self])]} {
return $::oo::dialect::aliases([self])
}
}
}
package provide oo::dialect 0.3.3
|
Changes to modules/oodialect/oodialect.test.
| ︙ | ︙ | |||
136 137 138 139 140 141 142 |
namespace eval ::test1 {
::bravo::define f {
superclass A
}
}
} ::test1::f
| > > > > > > | | | > | 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 |
namespace eval ::test1 {
::bravo::define f {
superclass A
}
}
} ::test1::f
test oodialect-aliasing-003 {Testing aliase method on class} {
::test1::a aliases
} {::test1::A}
test oodialect-ancestry-003 {Testing heritage} {
::oo::meta::ancestors ::test1::f
} {::oo::object ::alpha::object ::bravo::object ::test1::a ::test1::f}
test oodialect-ancestry-004 {Testing heritage} {
::oo::meta::ancestors ::alpha::object
} {::oo::object ::alpha::object}
test oodialect-ancestry-005 {Testing heritage} {
::oo::meta::ancestors ::delta::object
} {::oo::object ::alpha::object ::bravo::object ::charlie::object ::delta::object}
# -------------------------------------------------------------------------
testsuiteCleanup
# Local variables:
# mode: tcl
|
| ︙ | ︙ |
Changes to modules/oodialect/pkgIndex.tcl.
|
| < < < < < < < < < < | | 1 | package ifneeded oo::dialect 0.3.3 [list source [file join $dir oodialect.tcl]] |
Changes to modules/practcl/build.tcl.
1 2 | set here [file dirname [file normalize [file join [pwd] [info script]]]] | | > > > > | | | | > | | | 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 |
set here [file dirname [file normalize [file join [pwd] [info script]]]]
set version 0.11
set tclversion 8.5
set module [file tail $here]
set fout [open [file join $here [file tail $module].tcl] w]
fconfigure $fout -translation lf
dict set map %module% $module
dict set map %version% $version
dict set map %tclversion% $tclversion
dict set map { } {}
dict set map "\t" { }
puts $fout [string map $map {###
# Amalgamated package for %module%
# Do not edit directly, tweak the source in src/ and rerun
# build.tcl
###
package require Tcl %tclversion%
package provide %module% %version%
namespace eval ::%module% {}
}]
# Track what files we have included so far
set loaded {}
# These files must be loaded in a particular order
###
|
| ︙ | ︙ | |||
89 90 91 92 93 94 95 | close $fout ### # Build our pkgIndex.tcl file ### set fout [open [file join $here pkgIndex.tcl] w] fconfigure $fout -translation lf | | < < < < < < < < < | | | 94 95 96 97 98 99 100 101 102 103 104 105 |
close $fout
###
# Build our pkgIndex.tcl file
###
set fout [open [file join $here pkgIndex.tcl] w]
fconfigure $fout -translation lf
puts $fout [string map $map {###
if {![package vsatisfies [package provide Tcl] %tclversion%]} {return}
package ifneeded %module% %version% [list source [file join $dir %module%.tcl]]
}]
close $fout
|
Changes to modules/practcl/pkgIndex.tcl.
|
| < < < < < < < < < | | | 1 2 3 4 |
###
if {![package vsatisfies [package provide Tcl] 8.5]} {return}
package ifneeded practcl 0.11 [list source [file join $dir practcl.tcl]]
|
Changes to modules/practcl/practcl.man.
|
| | | | | 1 2 3 4 5 6 7 8 9 10 11 12 |
[comment {-*- practcl -*-}]
[vset VERSION 0.11]
[manpage_begin practcl n [vset VERSION]]
[keywords practcl]
[copyright {2016-2018 Sean Woods <[email protected]>}]
[moddesc {The The Proper Rational API for C to Tool Command Language Module}]
[titledesc {The Practcl Module}]
[category {TclOO}]
[require TclOO 1.0]
[require practcl [vset VERSION]]
[description]
The Practcl module is a tool for integrating large modules for C API
|
| ︙ | ︙ |
Changes to modules/practcl/practcl.tcl.
1 2 3 4 5 | ### # Amalgamated package for practcl # Do not edit directly, tweak the source in src/ and rerun # build.tcl ### | > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
###
# Amalgamated package for practcl
# Do not edit directly, tweak the source in src/ and rerun
# build.tcl
###
package require Tcl 8.5
package provide practcl 0.11
namespace eval ::practcl {}
###
# START: httpwget/wget.tcl
###
###
# Tool to download file from the web
|
| ︙ | ︙ | |||
1122 1123 1124 1125 1126 1127 1128 |
append buffer {
set dir [lindex $::PATHSTACK end]
set ::PATHSTACK [lrange $::PATHSTACK 0 end-1]
}
return $buffer
}
| < < < < < | 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 |
append buffer {
set dir [lindex $::PATHSTACK end]
set ::PATHSTACK [lrange $::PATHSTACK 0 end-1]
}
return $buffer
}
proc ::practcl::installDir {d1 d2} {
puts [format {%*sCreating %s} [expr {4 * [info level]}] {} [file tail $d2]]
file delete -force -- $d2
file mkdir $d2
foreach ftail [glob -directory $d1 -nocomplain -tails *] {
set f [file join $d1 $ftail]
if {[file isdirectory $f] && [string compare CVS $ftail]} {
|
| ︙ | ︙ | |||
1159 1160 1161 1162 1163 1164 1165 |
proc ::practcl::copyDir {d1 d2 {toplevel 1}} {
#if {$toplevel} {
# puts [list ::practcl::copyDir $d1 -> $d2]
#}
#file delete -force -- $d2
file mkdir $d2
| > > > > > > > | > | | | | | | > > > > > > | > | | | | | | < | < < | | < < | | < < < < < < < < < < | 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 |
proc ::practcl::copyDir {d1 d2 {toplevel 1}} {
#if {$toplevel} {
# puts [list ::practcl::copyDir $d1 -> $d2]
#}
#file delete -force -- $d2
file mkdir $d2
if {[file isfile $d1]} {
file copy -force $d1 $d2
set ftail [file tail $d1]
if {$::tcl_platform(platform) eq {unix}} {
file attributes [file join $d2 $ftail] -permissions 0644
} else {
file attributes [file join $d2 $ftail] -readonly 1
}
} else {
foreach ftail [glob -directory $d1 -nocomplain -tails *] {
set f [file join $d1 $ftail]
if {[file isdirectory $f] && [string compare CVS $ftail]} {
copyDir $f [file join $d2 $ftail] 0
} elseif {[file isfile $f]} {
file copy -force $f [file join $d2 $ftail]
if {$::tcl_platform(platform) eq {unix}} {
file attributes [file join $d2 $ftail] -permissions 0644
} else {
file attributes [file join $d2 $ftail] -readonly 1
}
}
}
}
}
###
# END: installutil.tcl
###
###
# START: makeutil.tcl
###
###
# Backward compatible Make facilities
# These were used early in development and are consdiered deprecated
###
proc ::practcl::trigger {args} {
::practcl::LOCAL make trigger {*}$args
foreach {name obj} [::practcl::LOCAL make objects] {
set ::make($name) [$obj do]
}
}
proc ::practcl::depends {args} {
::practcl::LOCAL make depends {*}$args
}
proc ::practcl::target {name info {action {}}} {
set obj [::practcl::LOCAL make task $name $info $action]
set ::make($name) 0
set filename [$obj define get filename]
if {$filename ne {}} {
set ::target($name) $filename
}
}
###
# END: makeutil.tcl
###
###
# START: class metaclass.tcl
###
::oo::class create ::practcl::metaclass {
|
| ︙ | ︙ | |||
1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 |
}
default {
array $submethod define {*}$args
}
}
}
method graft args {
my variable organs
if {[llength $args] == 1} {
error "Need two arguments"
}
set object {}
foreach {stub object} $args {
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 |
}
default {
array $submethod define {*}$args
}
}
}
method meta {submethod args} {
my variable meta
if {![info exists meta]} {
set meta {}
}
switch $submethod {
dump {
return $meta
}
add {
set field [lindex $args 0]
if {![dict exists $meta $field]} {
dict set meta $field {}
}
foreach arg [lrange $args 1 end] {
if {$arg ni [dict get $meta $field]} {
dict lappend meta $field $arg
}
}
return [dict get $meta $field]
}
remove {
set field [lindex $args 0]
if {![dict exists meta $field]} {
return
}
set rlist [lrange $args 1 end]
set olist [dict get $meta $field]
set nlist {}
foreach arg $olist {
if {$arg in $rlist} continue
lappend nlist $arg
}
dict set meta $field $nlist
return $nlist
}
exists {
return [dict exists $meta {*}$args]
}
getnull -
get {
if {[dict exists $meta {*}$args]} {
return [dict get $meta {*}$args]
}
return {}
}
cget {
set field [lindex $args 0]
if {[dict exists $meta $field]} {
return [dict get $meta $field]
}
return [lindex $args 1]
}
set {
if {[llength $args]==1} {
foreach {field value} $args {
dict set meta [string trimright $field :]: $value
}
} else {
set field [lindex $args end-1]
set value [lindex $args end]
dict set meta {*}[lrange $args 0 end-2] [string trimright $field :]: $value
}
}
default {
error "Valid: add cget dump exists get getnull remove set"
}
}
}
method graft args {
my variable organs
if {[llength $args] == 1} {
error "Need two arguments"
}
set object {}
foreach {stub object} $args {
|
| ︙ | ︙ | |||
1482 1483 1484 1485 1486 1487 1488 |
oo::class create ::practcl::toolset {
###
# find or fake a key/value list describing this project
###
method config.sh {} {
return [my read_configuration]
}
| | > > > > > > > > > > > > > > > > > | 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 |
oo::class create ::practcl::toolset {
###
# find or fake a key/value list describing this project
###
method config.sh {} {
return [my read_configuration]
}
method BuildDir {PWD} {
set name [my define get name]
set debug [my define get debug 0]
if {[my <project> define get LOCAL 0]} {
return [my define get builddir [file join $PWD local $name]]
}
if {$debug} {
return [my define get builddir [file join $PWD debug $name]]
} else {
return [my define get builddir [file join $PWD pkg $name]]
}
}
method MakeDir {srcdir} {
return $srcdir
}
method read_configuration {} {
my variable conf_result
if {[info exists conf_result]} {
return $conf_result
}
set result {}
set name [my define get name]
|
| ︙ | ︙ | |||
1591 1592 1593 1594 1595 1596 1597 |
}
set srcdir [my SourceRoot]
set PWD [pwd]
cd $srcdir
::practcl::dotclexec $critcl {*}$args
cd $PWD
}
| | < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 |
}
set srcdir [my SourceRoot]
set PWD [pwd]
cd $srcdir
::practcl::dotclexec $critcl {*}$args
cd $PWD
}
method make-autodetect {} {}
}
oo::objdefine ::practcl::toolset {
method select object {
|
| ︙ | ︙ | |||
1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 |
###
# START: class toolset gcc.tcl
###
::oo::class create ::practcl::toolset.gcc {
superclass ::practcl::toolset
method build-compile-sources {PROJECT COMPILE CPPCOMPILE INCLUDES} {
set objext [my define get OBJEXT o]
set EXTERN_OBJS {}
set OBJECTS {}
set result {}
set builddir [$PROJECT define get builddir]
file mkdir [file join $builddir objs]
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 |
###
# START: class toolset gcc.tcl
###
::oo::class create ::practcl::toolset.gcc {
superclass ::practcl::toolset
method Autoconf {} {
###
# Re-run autoconf for this project
# Not a good idea in practice... but in the right hands it can be useful
###
set pwd [pwd]
set srcdir [file normalize [my define get srcdir]]
cd $srcdir
foreach template {configure.ac configure.in} {
set input [file join $srcdir $template]
if {[file exists $input]} {
puts "autoconf -f $input > [file join $srcdir configure]"
exec autoconf -f $input > [file join $srcdir configure]
}
}
cd $pwd
}
method BuildDir {PWD} {
set name [my define get name]
set debug [my define get debug 0]
if {[my <project> define get LOCAL 0]} {
return [my define get builddir [file join $PWD local $name]]
}
if {$debug} {
return [my define get builddir [file join $PWD debug $name]]
} else {
return [my define get builddir [file join $PWD pkg $name]]
}
}
method ConfigureOpts {} {
set opts {}
set builddir [my define get builddir]
if {[my define get broken_destroot 0]} {
set PREFIX [my <project> define get prefix_broken_destdir]
} else {
set PREFIX [my <project> define get prefix]
}
switch [my define get name] {
tcl {
set opts [::practcl::platform::tcl_core_options [my <project> define get TEACUP_OS]]
}
tk {
set opts [::practcl::platform::tk_core_options [my <project> define get TEACUP_OS]]
}
}
if {[my <project> define get CONFIG_SITE] != {}} {
lappend opts --host=[my <project> define get HOST]
}
set inside_msys [string is true -strict [my <project> define get MSYS_ENV 0]]
lappend opts --with-tclsh=[info nameofexecutable]
if {![my <project> define get LOCAL 0]} {
set obj [my <project> tclcore]
if {$obj ne {}} {
if {$inside_msys} {
lappend opts --with-tcl=[::practcl::file_relative [file normalize $builddir] [$obj define get builddir]]
} else {
lappend opts --with-tcl=[file normalize [$obj define get builddir]]
}
}
if {[my define get tk 0]} {
set obj [my <project> tkcore]
if {$obj ne {}} {
if {$inside_msys} {
lappend opts --with-tk=[::practcl::file_relative [file normalize $builddir] [$obj define get builddir]]
} else {
lappend opts --with-tk=[file normalize [$obj define get builddir]]
}
}
}
} else {
lappend opts --with-tcl=[file join $PREFIX lib]
if {[my define get tk 0]} {
lappend opts --with-tk=[file join $PREFIX lib]
}
}
lappend opts {*}[my define get config_opts]
if {![regexp -- "--prefix" $opts]} {
lappend opts --prefix=$PREFIX --exec-prefix=$PREFIX
}
if {[my define get debug 0]} {
lappend opts --enable-symbols=true
}
#--exec_prefix=$PREFIX
#if {$::tcl_platform(platform) eq "windows"} {
# lappend opts --disable-64bit
#}
if {[my define get static 1]} {
lappend opts --disable-shared
#--disable-stubs
#
} else {
lappend opts --enable-shared
}
return $opts
}
# Detect what directory contains the Makefile template
method MakeDir {srcdir} {
set localsrcdir $srcdir
if {[file exists [file join $srcdir generic]]} {
my define add include_dir [file join $srcdir generic]
}
set os [my <project> define get TEACUP_OS]
switch $os {
windows {
if {[file exists [file join $srcdir win]]} {
my define add include_dir [file join $srcdir win]
}
if {[file exists [file join $srcdir win Makefile.in]]} {
set localsrcdir [file join $srcdir win]
}
}
default {
if {[file exists [file join $srcdir $os]]} {
my define add include_dir [file join $srcdir $os]
}
if {[file exists [file join $srcdir unix]]} {
my define add include_dir [file join $srcdir unix]
}
if {[file exists [file join $srcdir $os Makefile.in]]} {
set localsrcdir [file join $srcdir $os]
} elseif {[file exists [file join $srcdir unix Makefile.in]]} {
set localsrcdir [file join $srcdir unix]
}
}
}
return $localsrcdir
}
method make-autodetect {} {
set srcdir [my define get srcdir]
set localsrcdir [my define get localsrcdir]
if {$srcdir eq $localsrcdir} {
if {![file exists [file join $srcdir tclconfig install-sh]]} {
# ensure we have tclconfig with all of the trimmings
set teapath {}
if {[file exists [file join $srcdir .. tclconfig install-sh]]} {
set teapath [file join $srcdir .. tclconfig]
} else {
set tclConfigObj [::practcl::LOCAL tool tclconfig]
$tclConfigObj load
set teapath [$tclConfigObj define get srcdir]
}
set teapath [file normalize $teapath]
#file mkdir [file join $srcdir tclconfig]
if {[catch {file link -symbolic [file join $srcdir tclconfig] $teapath}]} {
::practcl::copyDir [file join $teapath] [file join $srcdir tclconfig]
}
}
}
set builddir [my define get builddir]
file mkdir $builddir
if {![file exists [file join $localsrcdir configure]]} {
if {[file exists [file join $localsrcdir autogen.sh]]} {
cd $localsrcdir
catch {exec sh autogen.sh >>& [file join $builddir autoconf.log]}
cd $::CWD
}
}
set opts [my ConfigureOpts]
if {[file exists [file join $builddir autoconf.log]]} {
file delete [file join $builddir autoconf.log]
}
::practcl::debug [list PKG [my define get name] CONFIGURE {*}$opts]
::practcl::log [file join $builddir autoconf.log] [list CONFIGURE {*}$opts]
cd $builddir
if {[my <project> define get CONFIG_SITE] ne {}} {
set ::env(CONFIG_SITE) [my <project> define get CONFIG_SITE]
}
catch {exec sh [file join $localsrcdir configure] {*}$opts >>& [file join $builddir autoconf.log]}
cd $::CWD
}
method make-clean {} {
set builddir [file normalize [my define get builddir]]
catch {::practcl::domake $builddir clean}
}
method make-compile {} {
set name [my define get name]
set srcdir [my define get srcdir]
if {[my define get static 1]} {
puts "BUILDING Static $name $srcdir"
} else {
puts "BUILDING Dynamic $name $srcdir"
}
cd $::CWD
set builddir [file normalize [my define get builddir]]
file mkdir $builddir
if {![file exists [file join $builddir Makefile]]} {
my Configure
}
if {[file exists [file join $builddir make.tcl]]} {
if {[my define get debug 0]} {
::practcl::domake.tcl $builddir debug all
} else {
::practcl::domake.tcl $builddir all
}
} else {
::practcl::domake $builddir all
}
}
method make-install DEST {
set PWD [pwd]
set builddir [my define get builddir]
if {[my <project> define get LOCAL 0] || $DEST eq {}} {
if {[file exists [file join $builddir make.tcl]]} {
puts "[self] Local INSTALL (Practcl)"
::practcl::domake.tcl $builddir install
} else {[my define get broken_destroot 0] == 0} {
puts "[self] Local INSTALL (TEA)"
::practcl::domake $builddir install
}
} else {
if {[file exists [file join $builddir make.tcl]]} {
# Practcl builds can inject right to where we need them
puts "[self] VFS INSTALL $DEST (Practcl)"
::practcl::domake.tcl $builddir install-package $DEST
} elseif {[my define get broken_destroot 0] == 0} {
# Most modern TEA projects understand DESTROOT in the makefile
puts "[self] VFS INSTALL $DEST (TEA)"
::practcl::domake $builddir install DESTDIR=[::practcl::file_relative $builddir $DEST]
} else {
# But some require us to do an install into a fictitious filesystem
# and then extract the gooey parts within.
# (*cough*) TkImg
set PREFIX [my <project> define get prefix]
set BROKENROOT [::practcl::msys_to_tclpath [my <project> define get prefix_broken_destdir]]
file delete -force $BROKENROOT
file mkdir $BROKENROOT
::practcl::domake $builddir $install
::practcl::copyDir $BROKENROOT [file join $DEST [string trimleft $PREFIX /]]
file delete -force $BROKENROOT
}
}
cd $PWD
}
method build-compile-sources {PROJECT COMPILE CPPCOMPILE INCLUDES} {
set objext [my define get OBJEXT o]
set EXTERN_OBJS {}
set OBJECTS {}
set result {}
set builddir [$PROJECT define get builddir]
file mkdir [file join $builddir objs]
|
| ︙ | ︙ | |||
2211 2212 2213 2214 2215 2216 2217 |
###
###
# START: class toolset msvc.tcl
###
::oo::class create ::practcl::toolset.msvc {
superclass ::practcl::toolset
| > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > | | | | > > > > > > > | | | | | > | > > > > > > > > > > > > > > > > > > > > > > > | | < | < < | | 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 |
###
###
# START: class toolset msvc.tcl
###
::oo::class create ::practcl::toolset.msvc {
superclass ::practcl::toolset
# MSVC always builds in the source directory
method BuildDir {PWD} {
set srcdir [my define get srcdir]
return $srcdir
}
# Do nothing
method make-autodetect {} {
}
method make-clean {} {
set PWD [pwd]
set srcdir [my define get srcdir]
cd $srcdir
catch {::practcl::doexec nmake -f makefile.vc clean}
cd $PWD
}
method make-compile {} {
set srcdir [my define get srcdir]
if {[my define get static 1]} {
puts "BUILDING Static $name $srcdir"
} else {
puts "BUILDING Dynamic $name $srcdir"
}
cd $srcdir
if {[file exists [file join $srcdir make.tcl]]} {
if {[my define get debug 0]} {
::practcl::domake.tcl $srcdir debug all
} else {
::practcl::domake.tcl $srcdir all
}
} else {
if {[file exists [file join $srcdir makefile.vc]]} {
::practcl::doexec nmake -f makefile.vc INSTALLDIR=[my <project> define get installdir] {*}[my NmakeOpts] release
} elseif {[file exists [file join $srcdir win makefile.vc]]} {
cd [file join $srcdir win]
::practcl::doexec nmake -f makefile.vc INSTALLDIR=[my <project> define get installdir] {*}[my NmakeOpts] release
} else {
error "No make.tcl or makefile.vc found for project $name"
}
}
}
method make-install DEST {
set PWD [pwd]
set srcdir [my define get srcdir]
cd $srcdir
if {$DEST eq {}} {
error "No destination given"
}
if {[my <project> define get LOCAL 0] || $DEST eq {}} {
if {[file exists [file join $srcdir make.tcl]]} {
# Practcl builds can inject right to where we need them
puts "[self] Local Install (Practcl)"
::practcl::domake.tcl $srcdir install
} else {
puts "[self] Local Install (Nmake)"
::practcl::doexec nmake -f makefile.vc {*}[my NmakeOpts] install
}
} else {
if {[file exists [file join $srcdir make.tcl]]} {
# Practcl builds can inject right to where we need them
puts "[self] VFS INSTALL $DEST (Practcl)"
::practcl::domake.tcl $srcdir install-package $DEST
} else {
puts "[self] VFS INSTALL $DEST"
::practcl::doexec nmake -f makefile.vc INSTALLDIR=$DEST {*}[my NmakeOpts] install
}
}
cd $PWD
}
# Detect what directory contains the Makefile template
method MakeDir {srcdir} {
set localsrcdir $srcdir
if {[file exists [file join $srcdir generic]]} {
my define add include_dir [file join $srcdir generic]
}
if {[file exists [file join $srcdir win]]} {
my define add include_dir [file join $srcdir win]
}
if {[file exists [file join $srcdir makefile.vc]]} {
set localsrcdir [file join $srcdir win]
}
return $localsrcdir
}
method NmakeOpts {} {
set opts {}
set builddir [file normalize [my define get builddir]]
if {[my <project> define exists tclsrcdir]} {
###
# On Windows we are probably running under MSYS, which doesn't deal with
# spaces in filename well
###
set TCLSRCDIR [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my <project> define get tclsrcdir] ..]]]
set TCLGENERIC [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my <project> define get tclsrcdir] .. generic]]]
lappend opts TCLDIR=[file normalize $TCLSRCDIR]
#--with-tclinclude=$TCLGENERIC
}
if {[my <project> define exists tksrcdir]} {
set TKSRCDIR [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my <project> define get tksrcdir] ..]]]
set TKGENERIC [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my <project> define get tksrcdir] .. generic]]]
#lappend opts --with-tk=$TKSRCDIR --with-tkinclude=$TKGENERIC
lappend opts TKDIR=[file normalize $TKSRCDIR]
}
return $opts
}
}
###
# END: class toolset msvc.tcl
###
###
# START: class target.tcl
###
::oo::class create ::practcl::make_obj {
superclass ::practcl::metaclass
constructor {module_object name info {action_body {}}} {
my variable define triggered domake
set triggered 0
set domake 0
set define(name) $name
set define(action) {}
array set define $info
my select
my initialize
foreach {stub obj} [$module_object child organs] {
my graft $stub $obj
}
if {$action_body ne {}} {
set define(action) $action_body
}
}
method do {} {
my variable domake
return $domake
}
method check {} {
my variable needs_make domake
if {$domake} {
return 1
}
if {[info exists needs_make]} {
return $needs_make
}
set make_objects [my <module> make objects]
set needs_make 0
foreach item [my define get depends] {
if {![dict exists $make_objects $item]} continue
set depobj [dict get $make_objects $item]
if {$depobj eq [self]} {
puts "WARNING [self] depends on itself"
continue
}
if {[$depobj check]} {
set needs_make 1
}
}
if {!$needs_make} {
foreach filename [my output] {
if {$filename ne {} && ![file exists $filename]} {
set needs_make 1
}
}
}
return $needs_make
}
method output {} {
set result {}
set filename [my define get filename]
if {$filename ne {}} {
lappend result $filename
}
foreach filename [my define get files] {
if {$filename ne {}} {
lappend result $filename
}
}
return $result
}
method reset {} {
my variable triggered domake needs_make
set triggerd 0
set domake 0
set needs_make 0
}
method triggers {} {
my variable triggered domake define
if {$triggered} {
return $domake
}
set triggered 1
set make_objects [my <module> make objects]
foreach item [my define get depends] {
if {![dict exists $make_objects $item]} continue
set depobj [dict get $make_objects $item]
if {$depobj eq [self]} {
puts "WARNING [self] triggers itself"
continue
} else {
set r [$depobj check]
if {$r} {
$depobj triggers
}
}
}
set domake 1
my <module> make trigger {*}[my define get triggers]
}
}
###
# END: class target.tcl
###
###
|
| ︙ | ︙ | |||
3653 3654 3655 3656 3657 3658 3659 |
my variable links
set object [::practcl::object new [self] {*}$args]
foreach linktype [$object linktype] {
lappend links($linktype) $object
}
return $object
}
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 |
my variable links
set object [::practcl::object new [self] {*}$args]
foreach linktype [$object linktype] {
lappend links($linktype) $object
}
return $object
}
method install-headers args {}
###
# Target handling
###
method make {command args} {
my variable make_object
if {![info exists make_object]} {
set make_object {}
}
switch $command {
pkginfo {
###
# Build local variables needed for install
###
package require platform
set result {}
set dat [my define dump]
set PKG_DIR [dict get $dat name][dict get $dat version]
dict set result PKG_DIR $PKG_DIR
dict with dat {}
if {![info exists DESTDIR]} {
set DESTDIR {}
}
dict set result profile [::platform::identify]
dict set result os $::tcl_platform(os)
dict set result platform $::tcl_platform(platform)
foreach {field value} $dat {
switch $field {
includedir -
mandir -
datadir -
libdir -
libfile -
name -
output_tcl -
version -
authors -
license -
requires {
dict set result $field $value
}
TEA_PLATFORM {
dict set result platform $value
}
TEACUP_OS {
dict set result os $value
}
TEACUP_PROFILE {
dict set result profile $value
}
TEACUP_ZIPFILE {
dict set result zipfile $value
}
}
}
if {![dict exists $result zipfile]} {
dict set result zipfile "[dict get $result name]-[dict get $result version]-[dict get $result profile].zip"
}
return $result
}
objects {
return $make_object
}
object {
set name [lindex $args 0]
if {[dict exists $make_object $name]} {
return [dict get $make_object $name]
}
return {}
}
reset {
foreach {name obj} $make_object {
$obj reset
}
}
trigger {
foreach {name obj} $make_object {
if {$name in $args} {
$obj triggers
}
}
}
depends {
foreach {name obj} $make_object {
if {$name in $args} {
$obj check
}
}
}
filename {
set name [lindex $args 0]
if {[dict exists $make_object $name]} {
return [[dict get $make_object $name] define get filename]
}
}
task -
target -
add {
set name [lindex $args 0]
set info [uplevel #0 [list subst [lindex $args 1]]]
set body [lindex $args 2]
set nspace [namespace current]
if {[dict exist $make_object $name]} {
set obj [dict get $$make_object $name]
} else {
set obj [::practcl::make_obj new [self] $name $info $body]
dict set make_object $name $obj
dict set target_make $name 0
dict set target_trigger $name 0
}
if {[dict exists $info aliases]} {
foreach item [dict get $info aliases] {
if {![dict exists $make_object $item]} {
dict set make_object $item $obj
}
}
}
return $obj
}
todo {
foreach {name obj} $make_object {
if {[$obj do]} {
lappend result $name
}
}
}
do {
global CWD SRCDIR project SANDBOX
foreach {name obj} $make_object {
if {[$obj do]} {
eval [$obj define get action]
}
}
}
}
}
method child which {
switch $which {
organs {
return [list project [my define get project] module [self]]
}
}
}
|
| ︙ | ︙ | |||
4342 4343 4344 4345 4346 4347 4348 |
}
# Backward compadible call
method generate-make path {
my build-Makefile $path [self]
}
| < < < < < | 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 |
}
# Backward compadible call
method generate-make path {
my build-Makefile $path [self]
}
method linktype {} {
return library
}
# Create a "package ifneeded"
# Args are a list of aliases for which this package will answer to
method package-ifneeded {args} {
|
| ︙ | ︙ | |||
4511 4512 4513 4514 4515 4516 4517 |
archive=Tcl_GetNameOfExecutable();
}
# We have to initialize the virtual filesystem before calling
# Tcl_Init(). Otherwise, Tcl_Init() will not be able to find
# its startup script files.
if {![$PROJECT define get tip_430 0]} {
# Add declarations of functions that tip430 puts in the stub files
| | | > > > > > > > > > > > > | | 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 |
archive=Tcl_GetNameOfExecutable();
}
# We have to initialize the virtual filesystem before calling
# Tcl_Init(). Otherwise, Tcl_Init() will not be able to find
# its startup script files.
if {![$PROJECT define get tip_430 0]} {
# Add declarations of functions that tip430 puts in the stub files
$PROJECT code public-header {
int TclZipfs_Init(Tcl_Interp *interp);
int TclZipfs_Mount(
Tcl_Interp *interp,
const char *mntpt,
const char *zipname,
const char *passwd
);
int TclZipfs_Mount_Buffer(
Tcl_Interp *interp,
const char *mntpt,
unsigned char *data,
size_t datalen,
int copy
);
}
::practcl::cputs zvfsboot { TclZipfs_Init(NULL);}
}
::practcl::cputs zvfsboot " if(!TclZipfs_Mount(NULL, \"app\", archive, NULL)) \x7B "
::practcl::cputs zvfsboot {
Tcl_Obj *vfsinitscript;
vfsinitscript=Tcl_NewStringObj("%vfs_main%",-1);
Tcl_IncrRefCount(vfsinitscript);
if(Tcl_FSAccess(vfsinitscript,F_OK)==0) {
/* Startup script should be set before calling Tcl_AppInit */
Tcl_SetStartupScript(vfsinitscript,NULL);
|
| ︙ | ︙ | |||
4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 |
###
# Standalone class to manage code distribution
# This class is intended to be mixed into another class
# (Thus the lack of ancestors)
###
oo::class create ::practcl::distribution {
method DistroMixIn {} {
my define set scm none
}
method Sandbox {} {
if {[my define exists sandbox]} {
return [my define get sandbox]
| > > > > > > > > > > | 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 |
###
# Standalone class to manage code distribution
# This class is intended to be mixed into another class
# (Thus the lack of ancestors)
###
oo::class create ::practcl::distribution {
method scm_info {} {
return {
scm None
hash {}
maxdate {}
tags {}
isodate {}
}
}
method DistroMixIn {} {
my define set scm none
}
method Sandbox {} {
if {[my define exists sandbox]} {
return [my define get sandbox]
|
| ︙ | ︙ | |||
4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 |
###
# START: class distro fossil.tcl
###
oo::class create ::practcl::distribution.fossil {
superclass ::practcl::distribution
# Clone the source
method ScmClone {} {
set srcdir [my SrcDir]
if {[file exists [file join $srcdir .fslckout]]} {
return
}
if {[file exists [file join $srcdir _FOSSIL_]]} {
| > > > > > > > > > | 5512 5513 5514 5515 5516 5517 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 |
###
# START: class distro fossil.tcl
###
oo::class create ::practcl::distribution.fossil {
superclass ::practcl::distribution
method scm_info {} {
set info [next]
dict set info scm fossil
foreach {field value} [::practcl::fossil_status [my define get srcdir]] {
dict set info $field $value
}
return $info
}
# Clone the source
method ScmClone {} {
set srcdir [my SrcDir]
if {[file exists [file join $srcdir .fslckout]]} {
return
}
if {[file exists [file join $srcdir _FOSSIL_]]} {
|
| ︙ | ︙ | |||
5182 5183 5184 5185 5186 5187 5188 |
###
oo::class create ::practcl::subproject {
superclass ::practcl::module
method _MorphPatterns {} {
return {{::practcl::subproject.@name@} {::practcl::@name@} {@name@} {::practcl::subproject}}
}
| | > > > > > < | | | 5729 5730 5731 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 |
###
oo::class create ::practcl::subproject {
superclass ::practcl::module
method _MorphPatterns {} {
return {{::practcl::subproject.@name@} {::practcl::@name@} {@name@} {::practcl::subproject}}
}
method BuildDir {PWD} {
return [my define get srcdir]
}
method child which {
switch $which {
organs {
# A library can be a project, it can be a module. Any
# subordinate modules will indicate their existance
return [list project [self] module [self]]
}
}
}
method compile {} {}
method go {} {
::practcl::distribution select [self]
set name [my define get name]
my define set builddir [my BuildDir [my define get masterpath]]
my define set builddir [my BuildDir [my define get masterpath]]
my sources
}
# Install project into the local build system
method install args {}
method linktype {} {
|
| ︙ | ︙ | |||
5474 5475 5476 5477 5478 5479 5480 |
set prefix [my <project> define get prefix [file normalize [file join ~ tcl]]]
set srcdir [my define get srcdir]
lappend options --prefix $prefix --exec-prefix $prefix
my define set config_opts $options
my go
my clean
my compile
| | | 6025 6026 6027 6028 6029 6030 6031 6032 6033 6034 6035 6036 6037 6038 6039 |
set prefix [my <project> define get prefix [file normalize [file join ~ tcl]]]
set srcdir [my define get srcdir]
lappend options --prefix $prefix --exec-prefix $prefix
my define set config_opts $options
my go
my clean
my compile
my make-install {}
}
method project-compile-products {} {}
method ComputeInstall {} {
if {[my define exists install]} {
switch [my define get install] {
|
| ︙ | ︙ | |||
5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 5519 5520 5521 5522 |
}
}
}
}
method go {} {
next
my ComputeInstall
my define set builddir [my BuildDir [my define get masterpath]]
}
method linker-products {configdict} {
if {![my define get static 0]} {
return {}
| > | 6060 6061 6062 6063 6064 6065 6066 6067 6068 6069 6070 6071 6072 6073 6074 |
}
}
}
}
method go {} {
next
::practcl::distribution select [self]
my ComputeInstall
my define set builddir [my BuildDir [my define get masterpath]]
}
method linker-products {configdict} {
if {![my define get static 0]} {
return {}
|
| ︙ | ︙ | |||
5561 5562 5563 5564 5565 5566 5567 |
}
return $result
}
method BuildDir {PWD} {
set name [my define get name]
set debug [my define get debug 0]
| < | < > > < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < | 6113 6114 6115 6116 6117 6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 6132 6133 6134 6135 6136 6137 6138 6139 6140 6141 6142 6143 6144 6145 6146 6147 6148 6149 6150 6151 6152 6153 6154 6155 6156 6157 6158 6159 6160 6161 6162 6163 6164 6165 6166 |
}
return $result
}
method BuildDir {PWD} {
set name [my define get name]
set debug [my define get debug 0]
if {[my <project> define get LOCAL 0]} {
return [my define get builddir [file join $PWD local $name]]
}
if {$debug} {
return [my define get builddir [file join $PWD debug $name]]
} else {
return [my define get builddir [file join $PWD pkg $name]]
}
}
method compile {} {
set name [my define get name]
set PWD $::CWD
cd $PWD
my unpack
set srcdir [file normalize [my SrcDir]]
set localsrcdir [my MakeDir $srcdir]
my define set localsrcdir $localsrcdir
my Collate_Source $PWD
###
# Build a starter VFS for both Tcl and wish
###
set srcdir [my define get srcdir]
if {[my define get static 1]} {
puts "BUILDING Static $name $srcdir"
} else {
puts "BUILDING Dynamic $name $srcdir"
}
my make-compile
cd $PWD
}
method Configure {} {
cd $::CWD
my unpack
::practcl::toolset select [self]
set srcdir [file normalize [my define get srcdir]]
set builddir [file normalize [my define get builddir]]
file mkdir $builddir
my make-autodetect
}
method install DEST {
set PWD [pwd]
set PREFIX [my <project> define get prefix]
###
# Handle teapot installs
|
| ︙ | ︙ | |||
5696 5697 5698 5699 5700 5701 5702 |
set dest [file join $DEST [string trimleft $PREFIX /] lib [file tail $teapath]]
::practcl::copyDir $teapath $dest
return
}
}
}
my compile
| < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < | 6175 6176 6177 6178 6179 6180 6181 6182 6183 6184 6185 6186 6187 6188 6189 6190 6191 |
set dest [file join $DEST [string trimleft $PREFIX /] lib [file tail $teapath]]
::practcl::copyDir $teapath $dest
return
}
}
}
my compile
my make-install $DEST
cd $PWD
}
}
oo::class create ::practcl::subproject.tea {
superclass ::practcl::subproject.binary
}
|
| ︙ | ︙ | |||
5776 5777 5778 5779 5780 5781 5782 |
###
# START: class subproject core.tcl
###
oo::class create ::practcl::subproject.core {
superclass ::practcl::subproject.binary
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < | < < < < < < < < < | < < | < < < < < < < < < < < < < < < < < < < < < | 6210 6211 6212 6213 6214 6215 6216 6217 6218 6219 6220 6221 6222 6223 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 6236 6237 6238 6239 6240 6241 6242 6243 6244 6245 6246 6247 6248 6249 6250 6251 6252 6253 |
###
# START: class subproject core.tcl
###
oo::class create ::practcl::subproject.core {
superclass ::practcl::subproject.binary
method env-bootstrap {} {}
method env-present {} {
set PREFIX [my <project> define get prefix]
set name [my define get name]
set fname [file join $PREFIX lib ${name}Config.sh]
return [file exists $fname]
}
method env-install {} {
my unpack
set os [::practcl::local_os]
set prefix [my <project> define get prefix [file normalize [file join ~ tcl]]]
lappend options --prefix $prefix --exec-prefix $prefix
my define set config_opts $options
puts [list [self] OS [dict get $os TEACUP_OS] options $options]
my go
my compile
my make-install {}
}
method go {} {
my define set core_binary 1
next
}
method linktype {} {
return {subordinate core.library}
}
}
###
# END: class subproject core.tcl
###
###
# START: class tool.tcl
|
| ︙ | ︙ |
Changes to modules/practcl/src/class/distro/baseclass.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 |
###
# Standalone class to manage code distribution
# This class is intended to be mixed into another class
# (Thus the lack of ancestors)
###
oo::class create ::practcl::distribution {
method DistroMixIn {} {
my define set scm none
}
method Sandbox {} {
if {[my define exists sandbox]} {
return [my define get sandbox]
| > > > > > > > > > > | 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 |
###
# Standalone class to manage code distribution
# This class is intended to be mixed into another class
# (Thus the lack of ancestors)
###
oo::class create ::practcl::distribution {
method scm_info {} {
return {
scm None
hash {}
maxdate {}
tags {}
isodate {}
}
}
method DistroMixIn {} {
my define set scm none
}
method Sandbox {} {
if {[my define exists sandbox]} {
return [my define get sandbox]
|
| ︙ | ︙ |
Changes to modules/practcl/src/class/distro/fossil.tcl.
1 2 3 4 5 6 7 8 9 10 11 |
oo::class create ::practcl::distribution.fossil {
superclass ::practcl::distribution
# Clone the source
method ScmClone {} {
set srcdir [my SrcDir]
if {[file exists [file join $srcdir .fslckout]]} {
return
}
if {[file exists [file join $srcdir _FOSSIL_]]} {
| > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
oo::class create ::practcl::distribution.fossil {
superclass ::practcl::distribution
method scm_info {} {
set info [next]
dict set info scm fossil
foreach {field value} [::practcl::fossil_status [my define get srcdir]] {
dict set info $field $value
}
return $info
}
# Clone the source
method ScmClone {} {
set srcdir [my SrcDir]
if {[file exists [file join $srcdir .fslckout]]} {
return
}
if {[file exists [file join $srcdir _FOSSIL_]]} {
|
| ︙ | ︙ |
Changes to modules/practcl/src/class/metaclass.tcl.
| ︙ | ︙ | |||
64 65 66 67 68 69 70 71 72 73 74 75 76 77 |
}
default {
array $submethod define {*}$args
}
}
}
method graft args {
my variable organs
if {[llength $args] == 1} {
error "Need two arguments"
}
set object {}
foreach {stub object} $args {
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
}
default {
array $submethod define {*}$args
}
}
}
method meta {submethod args} {
my variable meta
if {![info exists meta]} {
set meta {}
}
switch $submethod {
dump {
return $meta
}
add {
set field [lindex $args 0]
if {![dict exists $meta $field]} {
dict set meta $field {}
}
foreach arg [lrange $args 1 end] {
if {$arg ni [dict get $meta $field]} {
dict lappend meta $field $arg
}
}
return [dict get $meta $field]
}
remove {
set field [lindex $args 0]
if {![dict exists meta $field]} {
return
}
set rlist [lrange $args 1 end]
set olist [dict get $meta $field]
set nlist {}
foreach arg $olist {
if {$arg in $rlist} continue
lappend nlist $arg
}
dict set meta $field $nlist
return $nlist
}
exists {
return [dict exists $meta {*}$args]
}
getnull -
get {
if {[dict exists $meta {*}$args]} {
return [dict get $meta {*}$args]
}
return {}
}
cget {
set field [lindex $args 0]
if {[dict exists $meta $field]} {
return [dict get $meta $field]
}
return [lindex $args 1]
}
set {
if {[llength $args]==1} {
foreach {field value} $args {
dict set meta [string trimright $field :]: $value
}
} else {
set field [lindex $args end-1]
set value [lindex $args end]
dict set meta {*}[lrange $args 0 end-2] [string trimright $field :]: $value
}
}
default {
error "Valid: add cget dump exists get getnull remove set"
}
}
}
method graft args {
my variable organs
if {[llength $args] == 1} {
error "Need two arguments"
}
set object {}
foreach {stub object} $args {
|
| ︙ | ︙ |
Changes to modules/practcl/src/class/module.tcl.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 |
my variable links
set object [::practcl::object new [self] {*}$args]
foreach linktype [$object linktype] {
lappend links($linktype) $object
}
return $object
}
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
my variable links
set object [::practcl::object new [self] {*}$args]
foreach linktype [$object linktype] {
lappend links($linktype) $object
}
return $object
}
method install-headers args {}
###
# Target handling
###
method make {command args} {
my variable make_object
if {![info exists make_object]} {
set make_object {}
}
switch $command {
pkginfo {
###
# Build local variables needed for install
###
package require platform
set result {}
set dat [my define dump]
set PKG_DIR [dict get $dat name][dict get $dat version]
dict set result PKG_DIR $PKG_DIR
dict with dat {}
if {![info exists DESTDIR]} {
set DESTDIR {}
}
dict set result profile [::platform::identify]
dict set result os $::tcl_platform(os)
dict set result platform $::tcl_platform(platform)
foreach {field value} $dat {
switch $field {
includedir -
mandir -
datadir -
libdir -
libfile -
name -
output_tcl -
version -
authors -
license -
requires {
dict set result $field $value
}
TEA_PLATFORM {
dict set result platform $value
}
TEACUP_OS {
dict set result os $value
}
TEACUP_PROFILE {
dict set result profile $value
}
TEACUP_ZIPFILE {
dict set result zipfile $value
}
}
}
if {![dict exists $result zipfile]} {
dict set result zipfile "[dict get $result name]-[dict get $result version]-[dict get $result profile].zip"
}
return $result
}
objects {
return $make_object
}
object {
set name [lindex $args 0]
if {[dict exists $make_object $name]} {
return [dict get $make_object $name]
}
return {}
}
reset {
foreach {name obj} $make_object {
$obj reset
}
}
trigger {
foreach {name obj} $make_object {
if {$name in $args} {
$obj triggers
}
}
}
depends {
foreach {name obj} $make_object {
if {$name in $args} {
$obj check
}
}
}
filename {
set name [lindex $args 0]
if {[dict exists $make_object $name]} {
return [[dict get $make_object $name] define get filename]
}
}
task -
target -
add {
set name [lindex $args 0]
set info [uplevel #0 [list subst [lindex $args 1]]]
set body [lindex $args 2]
set nspace [namespace current]
if {[dict exist $make_object $name]} {
set obj [dict get $$make_object $name]
} else {
set obj [::practcl::make_obj new [self] $name $info $body]
dict set make_object $name $obj
dict set target_make $name 0
dict set target_trigger $name 0
}
if {[dict exists $info aliases]} {
foreach item [dict get $info aliases] {
if {![dict exists $make_object $item]} {
dict set make_object $item $obj
}
}
}
return $obj
}
todo {
foreach {name obj} $make_object {
if {[$obj do]} {
lappend result $name
}
}
}
do {
global CWD SRCDIR project SANDBOX
foreach {name obj} $make_object {
if {[$obj do]} {
eval [$obj define get action]
}
}
}
}
}
method child which {
switch $which {
organs {
return [list project [my define get project] module [self]]
}
}
}
|
| ︙ | ︙ |
Changes to modules/practcl/src/class/project/library.tcl.
| ︙ | ︙ | |||
254 255 256 257 258 259 260 |
}
# Backward compadible call
method generate-make path {
my build-Makefile $path [self]
}
| < < < < < | 254 255 256 257 258 259 260 261 262 263 264 265 266 267 |
}
# Backward compadible call
method generate-make path {
my build-Makefile $path [self]
}
method linktype {} {
return library
}
# Create a "package ifneeded"
# Args are a list of aliases for which this package will answer to
method package-ifneeded {args} {
|
| ︙ | ︙ |
Changes to modules/practcl/src/class/project/tclkit.tcl.
| ︙ | ︙ | |||
94 95 96 97 98 99 100 |
archive=Tcl_GetNameOfExecutable();
}
# We have to initialize the virtual filesystem before calling
# Tcl_Init(). Otherwise, Tcl_Init() will not be able to find
# its startup script files.
if {![$PROJECT define get tip_430 0]} {
# Add declarations of functions that tip430 puts in the stub files
| | | > > > > > > > > > > > > | | 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 |
archive=Tcl_GetNameOfExecutable();
}
# We have to initialize the virtual filesystem before calling
# Tcl_Init(). Otherwise, Tcl_Init() will not be able to find
# its startup script files.
if {![$PROJECT define get tip_430 0]} {
# Add declarations of functions that tip430 puts in the stub files
$PROJECT code public-header {
int TclZipfs_Init(Tcl_Interp *interp);
int TclZipfs_Mount(
Tcl_Interp *interp,
const char *mntpt,
const char *zipname,
const char *passwd
);
int TclZipfs_Mount_Buffer(
Tcl_Interp *interp,
const char *mntpt,
unsigned char *data,
size_t datalen,
int copy
);
}
::practcl::cputs zvfsboot { TclZipfs_Init(NULL);}
}
::practcl::cputs zvfsboot " if(!TclZipfs_Mount(NULL, \"app\", archive, NULL)) \x7B "
::practcl::cputs zvfsboot {
Tcl_Obj *vfsinitscript;
vfsinitscript=Tcl_NewStringObj("%vfs_main%",-1);
Tcl_IncrRefCount(vfsinitscript);
if(Tcl_FSAccess(vfsinitscript,F_OK)==0) {
/* Startup script should be set before calling Tcl_AppInit */
Tcl_SetStartupScript(vfsinitscript,NULL);
|
| ︙ | ︙ |
Changes to modules/practcl/src/class/subproject/baseclass.tcl.
1 2 3 4 5 6 |
oo::class create ::practcl::subproject {
superclass ::practcl::module
method _MorphPatterns {} {
return {{::practcl::subproject.@name@} {::practcl::@name@} {@name@} {::practcl::subproject}}
}
| | > > > > > < | | | 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 |
oo::class create ::practcl::subproject {
superclass ::practcl::module
method _MorphPatterns {} {
return {{::practcl::subproject.@name@} {::practcl::@name@} {@name@} {::practcl::subproject}}
}
method BuildDir {PWD} {
return [my define get srcdir]
}
method child which {
switch $which {
organs {
# A library can be a project, it can be a module. Any
# subordinate modules will indicate their existance
return [list project [self] module [self]]
}
}
}
method compile {} {}
method go {} {
::practcl::distribution select [self]
set name [my define get name]
my define set builddir [my BuildDir [my define get masterpath]]
my define set builddir [my BuildDir [my define get masterpath]]
my sources
}
# Install project into the local build system
method install args {}
method linktype {} {
|
| ︙ | ︙ |
Changes to modules/practcl/src/class/subproject/binary.tcl.
| ︙ | ︙ | |||
26 27 28 29 30 31 32 |
set prefix [my <project> define get prefix [file normalize [file join ~ tcl]]]
set srcdir [my define get srcdir]
lappend options --prefix $prefix --exec-prefix $prefix
my define set config_opts $options
my go
my clean
my compile
| | | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 |
set prefix [my <project> define get prefix [file normalize [file join ~ tcl]]]
set srcdir [my define get srcdir]
lappend options --prefix $prefix --exec-prefix $prefix
my define set config_opts $options
my go
my clean
my compile
my make-install {}
}
method project-compile-products {} {}
method ComputeInstall {} {
if {[my define exists install]} {
switch [my define get install] {
|
| ︙ | ︙ | |||
61 62 63 64 65 66 67 68 69 70 71 72 73 74 |
}
}
}
}
method go {} {
next
my ComputeInstall
my define set builddir [my BuildDir [my define get masterpath]]
}
method linker-products {configdict} {
if {![my define get static 0]} {
return {}
| > | 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 |
}
}
}
}
method go {} {
next
::practcl::distribution select [self]
my ComputeInstall
my define set builddir [my BuildDir [my define get masterpath]]
}
method linker-products {configdict} {
if {![my define get static 0]} {
return {}
|
| ︙ | ︙ | |||
113 114 115 116 117 118 119 |
}
return $result
}
method BuildDir {PWD} {
set name [my define get name]
set debug [my define get debug 0]
| < | < > > < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < | 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 |
}
return $result
}
method BuildDir {PWD} {
set name [my define get name]
set debug [my define get debug 0]
if {[my <project> define get LOCAL 0]} {
return [my define get builddir [file join $PWD local $name]]
}
if {$debug} {
return [my define get builddir [file join $PWD debug $name]]
} else {
return [my define get builddir [file join $PWD pkg $name]]
}
}
method compile {} {
set name [my define get name]
set PWD $::CWD
cd $PWD
my unpack
set srcdir [file normalize [my SrcDir]]
set localsrcdir [my MakeDir $srcdir]
my define set localsrcdir $localsrcdir
my Collate_Source $PWD
###
# Build a starter VFS for both Tcl and wish
###
set srcdir [my define get srcdir]
if {[my define get static 1]} {
puts "BUILDING Static $name $srcdir"
} else {
puts "BUILDING Dynamic $name $srcdir"
}
my make-compile
cd $PWD
}
method Configure {} {
cd $::CWD
my unpack
::practcl::toolset select [self]
set srcdir [file normalize [my define get srcdir]]
set builddir [file normalize [my define get builddir]]
file mkdir $builddir
my make-autodetect
}
method install DEST {
set PWD [pwd]
set PREFIX [my <project> define get prefix]
###
# Handle teapot installs
|
| ︙ | ︙ | |||
248 249 250 251 252 253 254 |
set dest [file join $DEST [string trimleft $PREFIX /] lib [file tail $teapath]]
::practcl::copyDir $teapath $dest
return
}
}
}
my compile
| < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < | 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 |
set dest [file join $DEST [string trimleft $PREFIX /] lib [file tail $teapath]]
::practcl::copyDir $teapath $dest
return
}
}
}
my compile
my make-install $DEST
cd $PWD
}
}
oo::class create ::practcl::subproject.tea {
superclass ::practcl::subproject.binary
}
|
| ︙ | ︙ |
Changes to modules/practcl/src/class/subproject/core.tcl.
1 2 3 4 |
oo::class create ::practcl::subproject.core {
superclass ::practcl::subproject.binary
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < | < < < < < < < < < | < < | < < < < < < < < < < < < < < < < < < < < < | 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 |
oo::class create ::practcl::subproject.core {
superclass ::practcl::subproject.binary
method env-bootstrap {} {}
method env-present {} {
set PREFIX [my <project> define get prefix]
set name [my define get name]
set fname [file join $PREFIX lib ${name}Config.sh]
return [file exists $fname]
}
method env-install {} {
my unpack
set os [::practcl::local_os]
set prefix [my <project> define get prefix [file normalize [file join ~ tcl]]]
lappend options --prefix $prefix --exec-prefix $prefix
my define set config_opts $options
puts [list [self] OS [dict get $os TEACUP_OS] options $options]
my go
my compile
my make-install {}
}
method go {} {
my define set core_binary 1
next
}
method linktype {} {
return {subordinate core.library}
}
}
|
Changes to modules/practcl/src/class/target.tcl.
1 |
| | | | | > > > > > > > | | | | | > | > > > > > > > > > > > > > > > > > > > > > > > | | < | < < | | 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 |
::oo::class create ::practcl::make_obj {
superclass ::practcl::metaclass
constructor {module_object name info {action_body {}}} {
my variable define triggered domake
set triggered 0
set domake 0
set define(name) $name
set define(action) {}
array set define $info
my select
my initialize
foreach {stub obj} [$module_object child organs] {
my graft $stub $obj
}
if {$action_body ne {}} {
set define(action) $action_body
}
}
method do {} {
my variable domake
return $domake
}
method check {} {
my variable needs_make domake
if {$domake} {
return 1
}
if {[info exists needs_make]} {
return $needs_make
}
set make_objects [my <module> make objects]
set needs_make 0
foreach item [my define get depends] {
if {![dict exists $make_objects $item]} continue
set depobj [dict get $make_objects $item]
if {$depobj eq [self]} {
puts "WARNING [self] depends on itself"
continue
}
if {[$depobj check]} {
set needs_make 1
}
}
if {!$needs_make} {
foreach filename [my output] {
if {$filename ne {} && ![file exists $filename]} {
set needs_make 1
}
}
}
return $needs_make
}
method output {} {
set result {}
set filename [my define get filename]
if {$filename ne {}} {
lappend result $filename
}
foreach filename [my define get files] {
if {$filename ne {}} {
lappend result $filename
}
}
return $result
}
method reset {} {
my variable triggered domake needs_make
set triggerd 0
set domake 0
set needs_make 0
}
method triggers {} {
my variable triggered domake define
if {$triggered} {
return $domake
}
set triggered 1
set make_objects [my <module> make objects]
foreach item [my define get depends] {
if {![dict exists $make_objects $item]} continue
set depobj [dict get $make_objects $item]
if {$depobj eq [self]} {
puts "WARNING [self] triggers itself"
continue
} else {
set r [$depobj check]
if {$r} {
$depobj triggers
}
}
}
set domake 1
my <module> make trigger {*}[my define get triggers]
}
}
|
Changes to modules/practcl/src/class/toolset/baseclass.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 |
###
# Ancestor-less class intended to be a mixin
# which defines a family of build related behaviors
# that are modified when targetting either gcc or msvc
###
oo::class create ::practcl::toolset {
###
# find or fake a key/value list describing this project
###
method config.sh {} {
return [my read_configuration]
}
| | > > > > > > > > > > > > > > > > > | 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 |
###
# Ancestor-less class intended to be a mixin
# which defines a family of build related behaviors
# that are modified when targetting either gcc or msvc
###
oo::class create ::practcl::toolset {
###
# find or fake a key/value list describing this project
###
method config.sh {} {
return [my read_configuration]
}
method BuildDir {PWD} {
set name [my define get name]
set debug [my define get debug 0]
if {[my <project> define get LOCAL 0]} {
return [my define get builddir [file join $PWD local $name]]
}
if {$debug} {
return [my define get builddir [file join $PWD debug $name]]
} else {
return [my define get builddir [file join $PWD pkg $name]]
}
}
method MakeDir {srcdir} {
return $srcdir
}
method read_configuration {} {
my variable conf_result
if {[info exists conf_result]} {
return $conf_result
}
set result {}
set name [my define get name]
|
| ︙ | ︙ | |||
115 116 117 118 119 120 121 |
}
set srcdir [my SourceRoot]
set PWD [pwd]
cd $srcdir
::practcl::dotclexec $critcl {*}$args
cd $PWD
}
| | < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 |
}
set srcdir [my SourceRoot]
set PWD [pwd]
cd $srcdir
::practcl::dotclexec $critcl {*}$args
cd $PWD
}
method make-autodetect {} {}
}
oo::objdefine ::practcl::toolset {
method select object {
|
| ︙ | ︙ |
Changes to modules/practcl/src/class/toolset/gcc.tcl.
1 2 3 4 5 6 7 8 9 10 11 |
::oo::class create ::practcl::toolset.gcc {
superclass ::practcl::toolset
method build-compile-sources {PROJECT COMPILE CPPCOMPILE INCLUDES} {
set objext [my define get OBJEXT o]
set EXTERN_OBJS {}
set OBJECTS {}
set result {}
set builddir [$PROJECT define get builddir]
file mkdir [file join $builddir objs]
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 |
::oo::class create ::practcl::toolset.gcc {
superclass ::practcl::toolset
method Autoconf {} {
###
# Re-run autoconf for this project
# Not a good idea in practice... but in the right hands it can be useful
###
set pwd [pwd]
set srcdir [file normalize [my define get srcdir]]
cd $srcdir
foreach template {configure.ac configure.in} {
set input [file join $srcdir $template]
if {[file exists $input]} {
puts "autoconf -f $input > [file join $srcdir configure]"
exec autoconf -f $input > [file join $srcdir configure]
}
}
cd $pwd
}
method BuildDir {PWD} {
set name [my define get name]
set debug [my define get debug 0]
if {[my <project> define get LOCAL 0]} {
return [my define get builddir [file join $PWD local $name]]
}
if {$debug} {
return [my define get builddir [file join $PWD debug $name]]
} else {
return [my define get builddir [file join $PWD pkg $name]]
}
}
method ConfigureOpts {} {
set opts {}
set builddir [my define get builddir]
if {[my define get broken_destroot 0]} {
set PREFIX [my <project> define get prefix_broken_destdir]
} else {
set PREFIX [my <project> define get prefix]
}
switch [my define get name] {
tcl {
set opts [::practcl::platform::tcl_core_options [my <project> define get TEACUP_OS]]
}
tk {
set opts [::practcl::platform::tk_core_options [my <project> define get TEACUP_OS]]
}
}
if {[my <project> define get CONFIG_SITE] != {}} {
lappend opts --host=[my <project> define get HOST]
}
set inside_msys [string is true -strict [my <project> define get MSYS_ENV 0]]
lappend opts --with-tclsh=[info nameofexecutable]
if {![my <project> define get LOCAL 0]} {
set obj [my <project> tclcore]
if {$obj ne {}} {
if {$inside_msys} {
lappend opts --with-tcl=[::practcl::file_relative [file normalize $builddir] [$obj define get builddir]]
} else {
lappend opts --with-tcl=[file normalize [$obj define get builddir]]
}
}
if {[my define get tk 0]} {
set obj [my <project> tkcore]
if {$obj ne {}} {
if {$inside_msys} {
lappend opts --with-tk=[::practcl::file_relative [file normalize $builddir] [$obj define get builddir]]
} else {
lappend opts --with-tk=[file normalize [$obj define get builddir]]
}
}
}
} else {
lappend opts --with-tcl=[file join $PREFIX lib]
if {[my define get tk 0]} {
lappend opts --with-tk=[file join $PREFIX lib]
}
}
lappend opts {*}[my define get config_opts]
if {![regexp -- "--prefix" $opts]} {
lappend opts --prefix=$PREFIX --exec-prefix=$PREFIX
}
if {[my define get debug 0]} {
lappend opts --enable-symbols=true
}
#--exec_prefix=$PREFIX
#if {$::tcl_platform(platform) eq "windows"} {
# lappend opts --disable-64bit
#}
if {[my define get static 1]} {
lappend opts --disable-shared
#--disable-stubs
#
} else {
lappend opts --enable-shared
}
return $opts
}
# Detect what directory contains the Makefile template
method MakeDir {srcdir} {
set localsrcdir $srcdir
if {[file exists [file join $srcdir generic]]} {
my define add include_dir [file join $srcdir generic]
}
set os [my <project> define get TEACUP_OS]
switch $os {
windows {
if {[file exists [file join $srcdir win]]} {
my define add include_dir [file join $srcdir win]
}
if {[file exists [file join $srcdir win Makefile.in]]} {
set localsrcdir [file join $srcdir win]
}
}
default {
if {[file exists [file join $srcdir $os]]} {
my define add include_dir [file join $srcdir $os]
}
if {[file exists [file join $srcdir unix]]} {
my define add include_dir [file join $srcdir unix]
}
if {[file exists [file join $srcdir $os Makefile.in]]} {
set localsrcdir [file join $srcdir $os]
} elseif {[file exists [file join $srcdir unix Makefile.in]]} {
set localsrcdir [file join $srcdir unix]
}
}
}
return $localsrcdir
}
method make-autodetect {} {
set srcdir [my define get srcdir]
set localsrcdir [my define get localsrcdir]
if {$srcdir eq $localsrcdir} {
if {![file exists [file join $srcdir tclconfig install-sh]]} {
# ensure we have tclconfig with all of the trimmings
set teapath {}
if {[file exists [file join $srcdir .. tclconfig install-sh]]} {
set teapath [file join $srcdir .. tclconfig]
} else {
set tclConfigObj [::practcl::LOCAL tool tclconfig]
$tclConfigObj load
set teapath [$tclConfigObj define get srcdir]
}
set teapath [file normalize $teapath]
#file mkdir [file join $srcdir tclconfig]
if {[catch {file link -symbolic [file join $srcdir tclconfig] $teapath}]} {
::practcl::copyDir [file join $teapath] [file join $srcdir tclconfig]
}
}
}
set builddir [my define get builddir]
file mkdir $builddir
if {![file exists [file join $localsrcdir configure]]} {
if {[file exists [file join $localsrcdir autogen.sh]]} {
cd $localsrcdir
catch {exec sh autogen.sh >>& [file join $builddir autoconf.log]}
cd $::CWD
}
}
set opts [my ConfigureOpts]
if {[file exists [file join $builddir autoconf.log]]} {
file delete [file join $builddir autoconf.log]
}
::practcl::debug [list PKG [my define get name] CONFIGURE {*}$opts]
::practcl::log [file join $builddir autoconf.log] [list CONFIGURE {*}$opts]
cd $builddir
if {[my <project> define get CONFIG_SITE] ne {}} {
set ::env(CONFIG_SITE) [my <project> define get CONFIG_SITE]
}
catch {exec sh [file join $localsrcdir configure] {*}$opts >>& [file join $builddir autoconf.log]}
cd $::CWD
}
method make-clean {} {
set builddir [file normalize [my define get builddir]]
catch {::practcl::domake $builddir clean}
}
method make-compile {} {
set name [my define get name]
set srcdir [my define get srcdir]
if {[my define get static 1]} {
puts "BUILDING Static $name $srcdir"
} else {
puts "BUILDING Dynamic $name $srcdir"
}
cd $::CWD
set builddir [file normalize [my define get builddir]]
file mkdir $builddir
if {![file exists [file join $builddir Makefile]]} {
my Configure
}
if {[file exists [file join $builddir make.tcl]]} {
if {[my define get debug 0]} {
::practcl::domake.tcl $builddir debug all
} else {
::practcl::domake.tcl $builddir all
}
} else {
::practcl::domake $builddir all
}
}
method make-install DEST {
set PWD [pwd]
set builddir [my define get builddir]
if {[my <project> define get LOCAL 0] || $DEST eq {}} {
if {[file exists [file join $builddir make.tcl]]} {
puts "[self] Local INSTALL (Practcl)"
::practcl::domake.tcl $builddir install
} else {[my define get broken_destroot 0] == 0} {
puts "[self] Local INSTALL (TEA)"
::practcl::domake $builddir install
}
} else {
if {[file exists [file join $builddir make.tcl]]} {
# Practcl builds can inject right to where we need them
puts "[self] VFS INSTALL $DEST (Practcl)"
::practcl::domake.tcl $builddir install-package $DEST
} elseif {[my define get broken_destroot 0] == 0} {
# Most modern TEA projects understand DESTROOT in the makefile
puts "[self] VFS INSTALL $DEST (TEA)"
::practcl::domake $builddir install DESTDIR=[::practcl::file_relative $builddir $DEST]
} else {
# But some require us to do an install into a fictitious filesystem
# and then extract the gooey parts within.
# (*cough*) TkImg
set PREFIX [my <project> define get prefix]
set BROKENROOT [::practcl::msys_to_tclpath [my <project> define get prefix_broken_destdir]]
file delete -force $BROKENROOT
file mkdir $BROKENROOT
::practcl::domake $builddir $install
::practcl::copyDir $BROKENROOT [file join $DEST [string trimleft $PREFIX /]]
file delete -force $BROKENROOT
}
}
cd $PWD
}
method build-compile-sources {PROJECT COMPILE CPPCOMPILE INCLUDES} {
set objext [my define get OBJEXT o]
set EXTERN_OBJS {}
set OBJECTS {}
set result {}
set builddir [$PROJECT define get builddir]
file mkdir [file join $builddir objs]
|
| ︙ | ︙ |
Changes to modules/practcl/src/class/toolset/msvc.tcl.
1 2 3 4 |
::oo::class create ::practcl::toolset.msvc {
superclass ::practcl::toolset
}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
::oo::class create ::practcl::toolset.msvc {
superclass ::practcl::toolset
# MSVC always builds in the source directory
method BuildDir {PWD} {
set srcdir [my define get srcdir]
return $srcdir
}
# Do nothing
method make-autodetect {} {
}
method make-clean {} {
set PWD [pwd]
set srcdir [my define get srcdir]
cd $srcdir
catch {::practcl::doexec nmake -f makefile.vc clean}
cd $PWD
}
method make-compile {} {
set srcdir [my define get srcdir]
if {[my define get static 1]} {
puts "BUILDING Static $name $srcdir"
} else {
puts "BUILDING Dynamic $name $srcdir"
}
cd $srcdir
if {[file exists [file join $srcdir make.tcl]]} {
if {[my define get debug 0]} {
::practcl::domake.tcl $srcdir debug all
} else {
::practcl::domake.tcl $srcdir all
}
} else {
if {[file exists [file join $srcdir makefile.vc]]} {
::practcl::doexec nmake -f makefile.vc INSTALLDIR=[my <project> define get installdir] {*}[my NmakeOpts] release
} elseif {[file exists [file join $srcdir win makefile.vc]]} {
cd [file join $srcdir win]
::practcl::doexec nmake -f makefile.vc INSTALLDIR=[my <project> define get installdir] {*}[my NmakeOpts] release
} else {
error "No make.tcl or makefile.vc found for project $name"
}
}
}
method make-install DEST {
set PWD [pwd]
set srcdir [my define get srcdir]
cd $srcdir
if {$DEST eq {}} {
error "No destination given"
}
if {[my <project> define get LOCAL 0] || $DEST eq {}} {
if {[file exists [file join $srcdir make.tcl]]} {
# Practcl builds can inject right to where we need them
puts "[self] Local Install (Practcl)"
::practcl::domake.tcl $srcdir install
} else {
puts "[self] Local Install (Nmake)"
::practcl::doexec nmake -f makefile.vc {*}[my NmakeOpts] install
}
} else {
if {[file exists [file join $srcdir make.tcl]]} {
# Practcl builds can inject right to where we need them
puts "[self] VFS INSTALL $DEST (Practcl)"
::practcl::domake.tcl $srcdir install-package $DEST
} else {
puts "[self] VFS INSTALL $DEST"
::practcl::doexec nmake -f makefile.vc INSTALLDIR=$DEST {*}[my NmakeOpts] install
}
}
cd $PWD
}
# Detect what directory contains the Makefile template
method MakeDir {srcdir} {
set localsrcdir $srcdir
if {[file exists [file join $srcdir generic]]} {
my define add include_dir [file join $srcdir generic]
}
if {[file exists [file join $srcdir win]]} {
my define add include_dir [file join $srcdir win]
}
if {[file exists [file join $srcdir makefile.vc]]} {
set localsrcdir [file join $srcdir win]
}
return $localsrcdir
}
method NmakeOpts {} {
set opts {}
set builddir [file normalize [my define get builddir]]
if {[my <project> define exists tclsrcdir]} {
###
# On Windows we are probably running under MSYS, which doesn't deal with
# spaces in filename well
###
set TCLSRCDIR [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my <project> define get tclsrcdir] ..]]]
set TCLGENERIC [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my <project> define get tclsrcdir] .. generic]]]
lappend opts TCLDIR=[file normalize $TCLSRCDIR]
#--with-tclinclude=$TCLGENERIC
}
if {[my <project> define exists tksrcdir]} {
set TKSRCDIR [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my <project> define get tksrcdir] ..]]]
set TKGENERIC [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my <project> define get tksrcdir] .. generic]]]
#lappend opts --with-tk=$TKSRCDIR --with-tkinclude=$TKGENERIC
lappend opts TKDIR=[file normalize $TKSRCDIR]
}
return $opts
}
}
|
Changes to modules/practcl/src/installutil.tcl.
| ︙ | ︙ | |||
162 163 164 165 166 167 168 |
append buffer {
set dir [lindex $::PATHSTACK end]
set ::PATHSTACK [lrange $::PATHSTACK 0 end-1]
}
return $buffer
}
| < < < < < | 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 |
append buffer {
set dir [lindex $::PATHSTACK end]
set ::PATHSTACK [lrange $::PATHSTACK 0 end-1]
}
return $buffer
}
proc ::practcl::installDir {d1 d2} {
puts [format {%*sCreating %s} [expr {4 * [info level]}] {} [file tail $d2]]
file delete -force -- $d2
file mkdir $d2
foreach ftail [glob -directory $d1 -nocomplain -tails *] {
set f [file join $d1 $ftail]
if {[file isdirectory $f] && [string compare CVS $ftail]} {
|
| ︙ | ︙ | |||
199 200 201 202 203 204 205 |
proc ::practcl::copyDir {d1 d2 {toplevel 1}} {
#if {$toplevel} {
# puts [list ::practcl::copyDir $d1 -> $d2]
#}
#file delete -force -- $d2
file mkdir $d2
| > > > > > > > | > | | | | | | > > > > | | | > > | 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 |
proc ::practcl::copyDir {d1 d2 {toplevel 1}} {
#if {$toplevel} {
# puts [list ::practcl::copyDir $d1 -> $d2]
#}
#file delete -force -- $d2
file mkdir $d2
if {[file isfile $d1]} {
file copy -force $d1 $d2
set ftail [file tail $d1]
if {$::tcl_platform(platform) eq {unix}} {
file attributes [file join $d2 $ftail] -permissions 0644
} else {
file attributes [file join $d2 $ftail] -readonly 1
}
} else {
foreach ftail [glob -directory $d1 -nocomplain -tails *] {
set f [file join $d1 $ftail]
if {[file isdirectory $f] && [string compare CVS $ftail]} {
copyDir $f [file join $d2 $ftail] 0
} elseif {[file isfile $f]} {
file copy -force $f [file join $d2 $ftail]
if {$::tcl_platform(platform) eq {unix}} {
file attributes [file join $d2 $ftail] -permissions 0644
} else {
file attributes [file join $d2 $ftail] -readonly 1
}
}
}
}
}
|
Changes to modules/practcl/src/makeutil.tcl.
1 | ### | | > | | | | | | < | < < | | < < | | < < < < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
###
# Backward compatible Make facilities
# These were used early in development and are consdiered deprecated
###
proc ::practcl::trigger {args} {
::practcl::LOCAL make trigger {*}$args
foreach {name obj} [::practcl::LOCAL make objects] {
set ::make($name) [$obj do]
}
}
proc ::practcl::depends {args} {
::practcl::LOCAL make depends {*}$args
}
proc ::practcl::target {name info {action {}}} {
set obj [::practcl::LOCAL make task $name $info $action]
set ::make($name) 0
set filename [$obj define get filename]
if {$filename ne {}} {
set ::target($name) $filename
}
}
|
Changes to modules/processman/pkgIndex.tcl.
1 2 3 4 5 6 7 8 9 10 | # Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. | | | | 1 2 3 4 5 6 7 8 9 10 11 12 | # Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. package ifneeded odie::processman 0.5 [list source [file join $dir processman.tcl]] package ifneeded processman 0.5 [list source [file join $dir processman.tcl]] |
Changes to modules/processman/processman.tcl.
1 2 3 4 5 6 7 8 |
###
# IRM External Process Manager
###
package require cron 2.0
::namespace eval ::processman {}
| < > | < | > > > > > > > > > > > > > > > > | > > > > > > > > > > | > > | > > > > > > > > > > > > > > > > > > > > > > > > > | > > > | > | | > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > | | | | | > < < | | | 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 |
###
# IRM External Process Manager
###
package require cron 2.0
::namespace eval ::processman {}
###
# Attempt to locate some C - API helpers
###
set ::processman::api tcl
foreach {command package api} {
{::twapi::process_exists} twapi twapi
umask tclx tclx
subprocess_exists tclextra tclextra
{} odielibc tclextra
} {
if {[info commands $command] ne {}} {
set ::processman::api $api
break
}
if {![catch {package require $package}]} {
set ::processman::api $api
break
}
}
switch $api {
tclx {
proc ::processman::kill_subprocess pid {
catch {::kill $pid}
}
}
tclextra {
proc ::processman::kill_subprocess pid {
catch {::kill_subprocess $pid}
}
}
twapi {
proc ::processman::priority {id level} {
foreach pid [PIDLIST $id] {
switch $level {
background {
if {[catch {twapi::set_priority_class $pid 0x00104000} err]} {
puts "BG Mode failed - $err"
twapi::set_priority_class $pid 0x00004000
}
}
low {
twapi::set_priority_class $pid 0x00004000
}
high {
twapi::set_priority_class $pid 0x00000020
}
default {
twapi::set_priority_class $pid 0x00008000
}
}
}
}
proc ::processman::killexe name {
set pids [twapi::get_process_ids -name $name.exe]
foreach pid $pids {
# Catch the error in case process does not exist any more
if {[catch {twapi::end_process $pid} err]} {
puts $err
}
}
#catch {exec taskkill /F /IM $name.exe} err
#puts $err
}
proc ::processman::kill_subprocess pid {
if {[catch {::twapi::end_process $pid} err]} {
puts $err
}
}
proc ::processman::subprocess_exists pid {
return [::twapi::process_exists $pid]
}
proc ::processman::keep_machine_awake {truefalse} {
if {[string is true -strict $truefalse]} {
twapi::SetThreadExecutionState 0x80000040
} else {
twapi::SetThreadExecutionState 0x00000000
}
}
}
default {}
}
###
# Create fallback implementations for functions we don't have a
# C API call for
###
proc ::processman::fallback {name arglist body} {
if {[info commands ::${name}] eq {} && [info commands ::processman::${name}] eq {} } {
::proc ::processman::${name} $arglist $body
}
}
# title: Keep the machine from going to sleep
::processman::fallback keep_machine_awake {truefalse} {
}
::processman::fallback killexe name {
if {[catch {exec killall -9 $name} err]} {
puts $err
}
harvest_zombies
}
###
# title: Detect a running process
# usage: subprocess_exists PID
# description:
# Returns true if PID is running. If PID is an integer
# it is interpreted as Process Id from the operating system.
# Otherwise it is assumed to be a handle previously registered
# with the processman package
###
::processman::fallback subprocess_exists pid {
set dat [exec ps]
foreach line [split $dat \n] {
if {![scan $line "%d %s" thispid rest]} continue
if { $thispid eq $pid} {
return $thispid
}
}
return 0
}
# title: Changes priority of task
::processman::fallback priority {id level} {
if {$::tcl_platform(platform) eq "windows"} {
return
}
foreach pid [PIDLIST $id] {
switch $level {
background {
exec renice -n 20 -p $pid
}
low {
exec renice -n 10 -p $pid
}
high {
exec renice -n -5 -p $pid
}
default {
exec renice -n 0 -p $pid
}
}
}
}
::processman::fallback kill_subprocess pid {
catch {exec kill $pid}
}
::processman::fallback harvest_zombies args {
}
###
# topic: a0cdb7503872cd302756c732956cd5c3
# title: Periodic scan of the state of processes
###
proc ::processman::events {} {
variable process_binding
|
| ︙ | ︙ | |||
67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 |
}
if {![file executable $f]} {
error "Cannot find the $name executable"
return {}
}
return $f
}
###
# topic: ac021b1116f0c1d5e3319d9f333f0c89
# title: Kill a process
###
proc ::processman::kill id {
variable process_list
variable process_binding
global tcl_platform
| > > > > > > > > > > > < < < < | < | < < | < > | | > < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 |
}
if {![file executable $f]} {
error "Cannot find the $name executable"
return {}
}
return $f
}
proc ::processman::PIDLIST id {
variable process_list
if {[string is integer -strict $id]} {
return $id
}
if {[dict exists $process_list $id]} {
return [dict get $process_list $id]
}
return {}
}
###
# topic: ac021b1116f0c1d5e3319d9f333f0c89
# title: Kill a process
###
proc ::processman::kill id {
variable process_list
variable process_binding
global tcl_platform
foreach pid [PIDLIST $id] {
kill_subprocess $pid
}
if {![string is integer $id]} {
dict set process_list $id {}
dict unset process_binding $id
}
harvest_zombies
}
###
# topic: 8987329d60cd1adc766e09a0227f87b6
# title: Kill all processes spawned by this program
###
proc ::processman::kill_all {} {
variable process_list
if {![info exists process_list]} {
return {}
}
foreach {name pidlist} $process_list {
kill $name
}
harvest_zombies
}
###
# topic: 02406b2a7edd05c887554384ad2db41f
# title: Issue a command when process {$id} exits
###
proc ::processman::onexit {id cmd} {
variable process_binding
if {![running $id]} {
catch {eval $cmd}
return
}
dict set process_binding $id $cmd
}
###
# topic: 8bccf62b4fa11949dba4c85e05d116e9
# title: Return a list of processes and their current state
###
proc ::processman::process_list {} {
variable process_list
set result {}
|
| ︙ | ︙ | |||
229 230 231 232 233 234 235 |
return 0
}
set pidlist [dict get $process_list $id]
} else {
set pidlist $id
}
foreach pid $pidlist {
| < < < < < | | < | 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 |
return 0
}
set pidlist [dict get $process_list $id]
} else {
set pidlist $id
}
foreach pid $pidlist {
if {[subprocess_exists $pid]} {
return $pid
}
}
return 0
}
###
# topic: 61694ad97dbac52351431ad0d8c448e3
|
| ︙ | ︙ | |||
281 282 283 284 285 286 287 |
if {![info exists process_binding]} {
set process_binding {}
}
}
::cron::every processman 60 ::processman::events
| | | | 336 337 338 339 340 341 342 343 344 |
if {![info exists process_binding]} {
set process_binding {}
}
}
::cron::every processman 60 ::processman::events
package provide odie::processman 0.5
package provide processman 0.5
|
Changes to modules/tool-ui/build.tcl.
1 2 | set here [file dirname [file normalize [file join [pwd] [info script]]]] | | > > > > | | | | > | | | 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 |
set here [file dirname [file normalize [file join [pwd] [info script]]]]
set version 0.2.1
set tclversion 8.6
set module [file tail $here]
set fout [open [file join $here [file tail $module].tcl] w]
dict set map %module% $module
dict set map %version% $version
dict set map %tclversion% $tclversion
dict set map { } {}
dict set map "\t" { }
puts $fout [string map $map {###
# Amalgamated package for %module%
# Do not edit directly, tweak the source in src/ and rerun
# build.tcl
###
package require Tcl %tclversion%
package provide %module% %version%
namespace eval ::%module% {}
}]
if {$module ne "tool"} {
puts $fout [string map $map {::tool::module push %module%}]
}
# Track what files we have included so far
set loaded {}
|
| ︙ | ︙ | |||
51 52 53 54 55 56 57 | }] close $fout ### # Build our pkgIndex.tcl file ### set fout [open [file join $here pkgIndex.tcl] w] | | < < < < < < < < < | | | 56 57 58 59 60 61 62 63 64 65 66 67 |
}]
close $fout
###
# Build our pkgIndex.tcl file
###
set fout [open [file join $here pkgIndex.tcl] w]
puts $fout [string map $map {###
if {![package vsatisfies [package provide Tcl] %tclversion%]} {return}
package ifneeded %module% %version% [list source [file join $dir %module%.tcl]]
}]
close $fout
|
Changes to modules/tool-ui/pkgIndex.tcl.
|
| < < < < < < < < < | | | 1 2 3 4 |
###
if {![package vsatisfies [package provide Tcl] 8.6]} {return}
package ifneeded tool-ui 0.2.1 [list source [file join $dir tool-ui.tcl]]
|
Changes to modules/tool-ui/src/vector.tcl.
| ︙ | ︙ | |||
35 36 37 38 39 40 41 |
method Value_Get {} {
my variable local_array
return [array get local_array]
}
method Value_Store value {
my variable local_array internalvalue displayvalue
| | | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 |
method Value_Get {} {
my variable local_array
return [array get local_array]
}
method Value_Store value {
my variable local_array internalvalue displayvalue
if {[::tool::is_null $value] || $value eq "0"} {
set internalvalue {}
set displayvalue {}
return
}
array set local_array $value
foreach {field val} [array get local_array] {
dict set internalvalue $field $val
|
| ︙ | ︙ |
Changes to modules/tool-ui/tool-ui.man.
1 |
[comment {-*- tool-ui -*-}]
| > | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
[vset VERSION 0.2.1]
[comment {-*- tool-ui -*-}]
[manpage_begin tool-ui n [vset VERSION]]
[keywords TclOO]
[keywords tao]
[keywords odielib]
[copyright {2014-2018 Sean Woods <[email protected]>}]
[moddesc {Tao User Interface (TaoUI)}]
[titledesc {Abstractions to allow Tao to express Native Tk, HTML5, and Tao-Layout interfaces}]
[category {Object System}]
[require Tcl 8.6]
[require tool-ui [opt [vset VERSION]]]
[description]
[para]
The [package tool-ui] package to allows Tao to express Native Tk, HTML5, and Tao-Layout interfaces.
[para]
Code in this module returns only text and list values. It should not rely on the presence of Tk
|
| ︙ | ︙ |
Changes to modules/tool-ui/tool-ui.tcl.
1 2 3 4 5 | ### # Amalgamated package for tool-ui # Do not edit directly, tweak the source in src/ and rerun # build.tcl ### | > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
###
# Amalgamated package for tool-ui
# Do not edit directly, tweak the source in src/ and rerun
# build.tcl
###
package require Tcl 8.6
package provide tool-ui 0.2.1
namespace eval ::tool-ui {}
::tool::module push tool-ui
###
# START: baseclass.tcl
###
::namespace eval ::tool::ui {}
|
| ︙ | ︙ | |||
920 921 922 923 924 925 926 927 928 929 930 931 932 933 |
}
}
}
###
# END: string.tcl
###
###
# START: form.tcl
###
###
# Basic functions for maintaining a relationship between
# forms and their fields
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 921 922 923 924 925 926 927 928 929 930 931 932 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 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 |
}
}
}
###
# END: string.tcl
###
###
# START: select.tcl
###
::tool::ui::datatype register select {
meta set is claim: {[dict getnull $info values-format] eq "list"}
option values {}
option cache-values {type: boolean default: 1}
option state {
widget select
values {normal readonly disabled}
default readonly
}
method datatype_inferences {options} {
set result {}
if {[dict isnull $options widget]} {
dict set result widget select
}
if {[dict isnull $options state]} {
dict set result state readonly
}
return $result
}
method CalculateValues {} {
set values [my GetConfigValueList]
return $values
}
method CalculateValueWidth values {
set w 0
set n 0
foreach v $values {
incr n
set l [string length $v]
incr bins($l)
if {$l > $w} {
set w $l
}
}
if { $w > 30} {
set w 30
}
return $w
}
method Description {} {
set text [my cget description]
set thisline {}
set values [my CalculateValues]
set format [my cget values-format]
append text \n "Possible Values:"
foreach value [my CalculateValues] {
if {[string length $thisline]>40} {
append text \n [string trim $thisline]
set thisline {}
}
append thisline " $value"
}
append text \n [string trim $thisline]
return $text
}
method GetConfigValueList {} {
my variable config values
if {[info exists values]} {
return $values
}
foreach opt {values-command options_command} {
if {[dict exists $config $opt]} {
set script [string map [list %field% [dict getnull $config field] %config% $config] [dict get $config $opt]]
if {[catch $script cvalues]} {
puts "Warning: Error computing values for $field: $values"
set cvalues {}
} else {
if {[llength $cvalues]} {
return $cvalues
}
}
}
}
if {[dict exists $config options]} {
set values [dict get $config options]
if {[llength $values]} {
return $values
}
}
if {[dict exists $config values]} {
set values [dict get $config values]
}
if {![info exists values]} {
set values {}
}
return $values
}
}
::tool::ui::datatype register select_keyvalue {
superclass select
option accept_number {
datatype boolean
default 1
}
method CalculateValues {} {
set values [my GetConfigValueList]
set result {}
foreach {key value} $values {
lappend result $key
}
return $result
}
method Description {} {
set text [my cget description]
append text \n "Possible Values:"
foreach {key value} [my GetConfigValueList] {
append text \n " * $key - $value"
}
return $text
}
method Value_Export rawvalue {
set values [my GetConfigValueList]
foreach {var val} $values {
if {$rawvalue eq $val} {
return $val
}
if {$rawvalue eq $var} {
return $val
}
}
return $rawvalue
}
method Value_Interpret rawvalue {
set values [my GetConfigValueList]
foreach {var val} $values {
if {$rawvalue eq $val} {
return $var
}
if {$rawvalue eq $var} {
return $var
}
}
if {[my cget accept_number]} {
if {[string is double $rawvalue]} {
return $rawvalue
}
}
error "Invalid Value \"$rawvalue\". Valid: [join [dict keys $values] ,]"
}
}
::tool::ui::datatype register enumerated {
aliases enum
superclass select
meta branchset is {
number: 1
integer: 1
real: 0
}
option enum {
default {}
}
method CalculateValues {} {
set values {}
foreach {id code comment} [my GetConfigValueList] {
lappend values "$id - $code $comment"
}
return $values
}
method Description {} {
set text [my cget description]
append text \n "Possible Values:"
foreach {id code comment} [my GetConfigValueList] {
append text \n " * $id - ($code) $comment"
}
return $text
}
method Value_Interpret value {
set value [lindex $value 0]
foreach {id code comment} [my GetConfigValueList] {
if {$value == $id } {
return $id
}
}
return {}
}
method Value_Display value {
if {[::tool::is_null $value]} {
return {}
}
foreach {id code comment} [my GetConfigValueList] {
if { [lindex $value 0] == $id } {
return "$id - $code"
}
}
return $value
}
}
###
# END: select.tcl
###
###
# START: form.tcl
###
###
# Basic functions for maintaining a relationship between
# forms and their fields
|
| ︙ | ︙ | |||
1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 |
$objname attach [list form [self]] $fconfig
return $objname
}
}
###
# END: form.tcl
###
###
# START: number.tcl
###
::tool::ui::datatype register boolean {
aliases bool u1
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 |
$objname attach [list form [self]] $fconfig
return $objname
}
}
###
# END: form.tcl
###
###
# START: vector.tcl
###
###
# title: Vector
###
::tool::ui::datatype register vector {
superclass ::tool::ui::form
property vector_fields {
x {type real format {%g} width 10}
y {type real format {%g} width 10}
z {type real format {%g} width 10}
}
method datatype_inferences options {
set result {}
if {[dict isnull $options widget]} {
dict set result widget vector
}
return $result
}
method Value_Export newvalue {
set result {}
array set content $newvalue
foreach {vfield info} [my Vector_Fields] {
set format [if_null [dict getnull $info format] %s]
set newvalue [format $format $content($vfield)]
lappend result $newvalue
}
return $result
}
method Vector_Fields {} {
return [my meta cget vector_fields]
}
method Value_Get {} {
my variable local_array
return [array get local_array]
}
method Value_Store value {
my variable local_array internalvalue displayvalue
if {[::tool::is_null $value] || $value eq "0"} {
set internalvalue {}
set displayvalue {}
return
}
array set local_array $value
foreach {field val} [array get local_array] {
dict set internalvalue $field $val
set obj [my formelement object $field]
if {$obj ne {}} {
$obj put $val
}
}
set displayvalue [my Value_Display $internalvalue]
}
method Value_Import inputvalue {
set idx -1
foreach {vfield info} [my Vector_Fields] {
incr idx
set format [if_null [dict getnull $info format] %s]
set value [lindex $inputvalue $idx]
if {[dict exists $info default]} {
if {$value eq {}} {
set value [dict get $info default]
}
}
if {$value eq {}} {
set local_array($vfield) $value
} elseif { $format in {"%d" int integer} } {
if [catch {expr {int($value)}} nvalue] {
puts "Err: $format $vfield. Raw: $value. Err: $nvalue"
dict set result $vfield $value
} else {
dict set result $vfield $nvalue
}
} else {
if [catch {format $format $value} nvalue] {
puts "Err: $vfield. Raw: $value. Err: $nvalue"
dict set result $vfield $value
} else {
dict set result $vfield $nvalue
}
}
}
return $result
}
}
###
# END: vector.tcl
###
###
# START: number.tcl
###
::tool::ui::datatype register boolean {
aliases bool u1
|
| ︙ | ︙ | |||
1606 1607 1608 1609 1610 1611 1612 |
return -options $options -errorinfo "$n is not an integer"
}
}
###
# END: round.tcl
###
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 |
return -options $options -errorinfo "$n is not an integer"
}
}
###
# END: round.tcl
###
namespace eval ::tool-ui {
namespace export *
}
|
Changes to modules/udpcluster/pkgIndex.tcl.
1 2 |
if {![package vsatisfies [package provide Tcl] 8.5]} {return}
# Backward compatible alias
| | | | 1 2 3 4 |
if {![package vsatisfies [package provide Tcl] 8.5]} {return}
# Backward compatible alias
package ifneeded nameserv::cluster 0.2.5 {package require udpcluster ; package provide nameserv::cluster 0.2.5}
package ifneeded udpcluster 0.3.3 [list source [file join $dir udpcluster.tcl]]
|
Changes to modules/udpcluster/udpcluster.man.
|
| > | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 |
[vset VERSION 0.3.3]
[manpage_begin udpcluster n [vset VERSION]]
[keywords {name service}]
[keywords server]
[copyright {2016-2018 Sean Woods <[email protected]>}]
[moddesc {Lightweight UDP based tool for cluster node discovery}]
[titledesc {UDP Peer-to-Peer cluster}]
[category Networking]
[require Tcl 8.5]
[require udpcluster [opt [vset VERSION]]]
[require ip]
[require nettool]
[require comm]
[require interp]
[require dicttool]
[require cron]
[description]
|
| ︙ | ︙ |
Changes to modules/udpcluster/udpcluster.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # -*- tcl -*- # ### ### ### ######### ######### ######### ## Name Service - Cluster # ### ### ### ######### ######### ######### ## Requirements package require Tcl 8.5 package require comm ; # Generic message transport package require interp ; # Interpreter helpers. package require logger ; # Tracing internal activity package require uuid package require cron 2.0 | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# -*- tcl -*-
# ### ### ### ######### ######### #########
## Name Service - Cluster
# ### ### ### ######### ######### #########
## Requirements
package require Tcl 8.5
package require comm ; # Generic message transport
package require interp ; # Interpreter helpers.
package require logger ; # Tracing internal activity
package require uuid
package require cron 2.0
package require nettool 0.5.2
package require udp
package require dicttool
namespace eval ::comm {}
::namespace eval ::cluster {}
###
|
| ︙ | ︙ | |||
137 138 139 140 141 142 143 |
###
proc ::cluster::listen {} {
variable broadcast_sock
if {$broadcast_sock != {}} {
return $broadcast_sock
}
| | | 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 |
###
proc ::cluster::listen {} {
variable broadcast_sock
if {$broadcast_sock != {}} {
return $broadcast_sock
}
variable discovery_port
# Open a local discovery port to catch non-IP traffic
variable discovery_group
set broadcast_sock [udp_open $discovery_port reuse]
fconfigure $broadcast_sock -buffering none -blocking 0 \
-broadcast 1 \
-mcastadd $discovery_group \
-remote [list $discovery_group $discovery_port]
|
| ︙ | ︙ | |||
169 170 171 172 173 174 175 |
}
proc ::cluster::sleep args {
::cron::sleep {*}$args
}
proc ::cluster::TCPAccept {sock host port} {
| < < < < < | < | | | | | | | | < < < | | < < | 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 |
}
proc ::cluster::sleep args {
::cron::sleep {*}$args
}
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]
|
| ︙ | ︙ | |||
230 231 232 233 234 235 236 |
set wmacid [lindex $messageinfo 0]
if { $wmacid eq [::cluster::self] } {
broadcast +WHOIS [::cluster::self]
}
return
}
}
| | | | | 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 |
set wmacid [lindex $messageinfo 0]
if { $wmacid eq [::cluster::self] } {
broadcast +WHOIS [::cluster::self]
}
return
}
}
set now [clock seconds]
set serviceurl [lindex $packet 2]
set serviceinfo [lindex $packet 3]
set ::cluster::ping_recv($serviceurl) $now
UDPPortInfo $serviceurl $messagetype $serviceinfo
if {[dict exists $serviceinfo pid] && [dict get $serviceinfo pid] eq [pid] } {
# Ignore attempts to overwrite locally managed services from the network
return
}
# Always update the IP of the service info
dict set ptpdata($serviceurl) ipaddr $ipaddr
dict set ptpdata($serviceurl) updated $now
dict set serviceinfo ipaddr [lindex $peer 0]
dict set serviceinfo updated $now
set messageinfo [lrange $packet 4 end]
switch -- $messagetype {
-SERVICE {
if {![::info exists ptpdata($serviceurl)]} {
set result $serviceinfo
} else {
set result [dict merge $ptpdata($serviceurl) $serviceinfo]
}
|
| ︙ | ︙ | |||
380 381 382 383 384 385 386 |
set local_data($url) [dict merge $infodict {ipaddr 127.0.0.1}]
broadcast +SERVICE $url $infodict
}
proc ::cluster::heartbeat {} {
variable ptpdata
variable config
| | | 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 |
set local_data($url) [dict merge $infodict {ipaddr 127.0.0.1}]
broadcast +SERVICE $url $infodict
}
proc ::cluster::heartbeat {} {
variable ptpdata
variable config
_Winnow
###
# Broadcast the status of our local services
###
variable local_data
foreach {url info} [array get local_data] {
broadcast ~SERVICE $url $info
|
| ︙ | ︙ | |||
544 545 546 547 548 549 550 |
}
###
# topic: c8475e832c912e962f238c61580b669e
###
proc ::cluster::search pattern {
_Winnow
| | | 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 |
}
###
# topic: c8475e832c912e962f238c61580b669e
###
proc ::cluster::search pattern {
_Winnow
set result {}
variable ptpdata
foreach {service dat} [array get ptpdata $pattern] {
foreach {field value} $dat {
dict set result $service $field $value
}
}
|
| ︙ | ︙ | |||
573 574 575 576 577 578 579 |
if {[array exists local_data [cname $pattern]]} {
return 1
}
return 0
}
proc ::cluster::search_local pattern {
| | | 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 |
if {[array exists local_data [cname $pattern]]} {
return 1
}
return 0
}
proc ::cluster::search_local pattern {
set result {}
variable local_data
foreach {service dat} [array get local_data $pattern] {
foreach {field value} $dat {
dict set result $service $field $value
}
}
return $result
|
| ︙ | ︙ | |||
608 609 610 611 612 613 614 |
# Performed immediately before searches
# and heartbeats
###
proc ::cluster::_Winnow {} {
variable ptpdata
variable config
variable local_data
| | | 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 |
# Performed immediately before searches
# and heartbeats
###
proc ::cluster::_Winnow {} {
variable ptpdata
variable config
variable local_data
set now [clock seconds]
foreach {item info} [array get ptpdata] {
set remove 0
if {[dict exists $info closed] && [dict get $info closed]} {
set remove 1
}
if {[dict exists $info updated] && ($now - [dict get $info updated])>$config(discovery_ttl)} {
|
| ︙ | ︙ | |||
661 662 663 664 665 666 667 |
variable directory_pid {}
# Currently an unassigned group in the
# Local Network Control Block (224.0.0/24)
# See: RFC3692 and http://www.iana.org
variable discovery_group 224.0.0.200
variable local_port {}
| | | | 650 651 652 653 654 655 656 657 658 659 660 661 |
variable directory_pid {}
# Currently an unassigned group in the
# Local Network Control Block (224.0.0/24)
# See: RFC3692 and http://www.iana.org
variable discovery_group 224.0.0.200
variable local_port {}
variable local_macid [lindex [lsort [::nettool::mac_list]] 0]
variable local_pid [::uuid::uuid generate]
}
package provide udpcluster 0.3.3
|