97 changed files with 26487 additions and 3697 deletions
@ -1,3 +1 @@ |
|||||||
|
package ifneeded app-punk 1.0 [list source [file join $dir repl.tcl]] |
||||||
package ifneeded app-punk 1.0 [list source [file join $dir repl.tcl]] |
|
||||||
|
|
||||||
@ -0,0 +1,2 @@ |
|||||||
|
package ifneeded app-punkshell 1.0 [list source [file join $dir punkshell.tcl]] |
||||||
|
|
||||||
@ -0,0 +1,296 @@ |
|||||||
|
package provide app-punkshell 1.0 |
||||||
|
|
||||||
|
package require Thread |
||||||
|
package require punk::args |
||||||
|
package require shellfilter |
||||||
|
package require punk::ansi |
||||||
|
package require punk::packagepreference |
||||||
|
punk::packagepreference::install |
||||||
|
|
||||||
|
namespace eval punkshell { |
||||||
|
variable chanstack_stderr_redir |
||||||
|
variable chanstack_stdout_redir |
||||||
|
proc clock_sec {} { |
||||||
|
return [expr {[clock millis]/1000.0}] |
||||||
|
} |
||||||
|
set do_log 0 |
||||||
|
if {$do_log} { |
||||||
|
set debug_syslog_server 127.0.0.1:514 |
||||||
|
#set debug_syslog_server 172.16.6.42:51500 |
||||||
|
set error_syslog_server 127.0.0.1:514 |
||||||
|
set data_syslog_server 127.0.0.1:514 |
||||||
|
} else { |
||||||
|
set debug_syslog_server "" |
||||||
|
set error_syslog_server "" |
||||||
|
set data_syslog_server "" |
||||||
|
} |
||||||
|
#------------------------------------------------------------------------- |
||||||
|
##don't write to stdout/stderr before you've redirected them to a log using shellfilter functions |
||||||
|
## puts to stdout/stderr will comingle with command's output if performed before the channel stacks are configured. |
||||||
|
|
||||||
|
#chan configure stdin -buffering line |
||||||
|
#chan configure stdout -buffering none |
||||||
|
#chan configure stderr -buffering none |
||||||
|
|
||||||
|
#redir on the shellfilter stack with no log or syslog specified acts to suppress output of stdout & stderr. |
||||||
|
#todo - fix shellfilter code to make this noop more efficient (avoid creating corresponding logging thread and filter?) |
||||||
|
#JMN |
||||||
|
#set redirconfig {-settings {-syslog 127.0.0.1:514 -file ""}} |
||||||
|
set redirconfig {} |
||||||
|
#lassign [shellfilter::redir_output_to_log "SUPPRESS" {*}$redirconfig] chanstack_stdout_redir chanstack_stderr_redir |
||||||
|
#shellfilter::log::write $punkshell_status_log "shellfilter::redir_output_to_log SUPPRESS DONE [clock_sec]" |
||||||
|
|
||||||
|
set stdout_log "" |
||||||
|
set stderr_log "" |
||||||
|
#set stdout_log [file normalize ~]/punkshell-stdout.txt |
||||||
|
#set stderr_log [file normalize ~]/punkshell-stderr.txt |
||||||
|
set stdout_log "[pwd]/punkshell_out.log" |
||||||
|
set stderr_log "[pwd]/punkshell_err.log" |
||||||
|
|
||||||
|
set errdeviceinfo [shellfilter::stack::new punkshellerr -settings [list -tag "punkshellerr" -buffering none -raw 1 -syslog $data_syslog_server -file $stderr_log]] |
||||||
|
set outdeviceinfo [shellfilter::stack::new punkshellout -settings [list -tag "punkshellout" -buffering none -raw 1 -syslog $data_syslog_server -file $stdout_log]] |
||||||
|
#set commandlog [dict get $outdeviceinfo localchan] |
||||||
|
#puts $commandlog "HELLO $commandlog" |
||||||
|
#flush $commandlog |
||||||
|
|
||||||
|
proc do_script {scriptname args} { |
||||||
|
#ideally we don't want to launch an external process to run the script |
||||||
|
#variable punkshell_status_log |
||||||
|
#shellfilter::log::write $punkshell_status_log "do_script got scriptname:'$scriptname' replwhen:$replwhen args:'$args'" |
||||||
|
set exepath [file dirname [file join [info nameofexecutable] __dummy__]] |
||||||
|
set exedir [file dirname $exepath] |
||||||
|
set scriptpath [file normalize $scriptname] |
||||||
|
if {![file exists $scriptpath]} { |
||||||
|
puts stderr "Failed to find script: '$scriptpath'" |
||||||
|
error "bad scriptpath '$scriptpath'" |
||||||
|
} |
||||||
|
|
||||||
|
set script [string map [list %a% $args %s% $scriptpath] { |
||||||
|
set normscript %s% |
||||||
|
#save values |
||||||
|
set prevscript [info script] |
||||||
|
set prevglobal [dict create] |
||||||
|
foreach g [list ::argv ::argc ::argv0] { |
||||||
|
if {[info exists $g]} { |
||||||
|
dict set prevglobal $g [set $g] |
||||||
|
} |
||||||
|
} |
||||||
|
#setup and run |
||||||
|
set ::argv [list %a%] |
||||||
|
set ::argc [llength $::argv] |
||||||
|
set ::argv0 $normscript |
||||||
|
info script $normscript |
||||||
|
source $normscript |
||||||
|
#restore values |
||||||
|
info script $prevscript |
||||||
|
dict with prevglobal {} |
||||||
|
}] |
||||||
|
|
||||||
|
dict set params -tclscript 1 ;#don't give callback a chance to omit/break this |
||||||
|
dict set params -teehandle punkshell |
||||||
|
#dict set params -teehandle punksh |
||||||
|
dict set params -inbuffering none |
||||||
|
dict set params -outbuffering none |
||||||
|
dict set params -readprocesstranslation crlf |
||||||
|
dict set params -outtranslation lf |
||||||
|
|
||||||
|
set id_err [shellfilter::stack::add stderr ansiwrap -action sink-locked -settings {-colour {red bold}}] |
||||||
|
|
||||||
|
set exitinfo [shellfilter::run $script {*}$params] |
||||||
|
|
||||||
|
shellfilter::stack::remove stderr $id_err |
||||||
|
|
||||||
|
if {[dict exists $exitinfo errorInfo]} { |
||||||
|
#strip out the irrelevant info from the errorInfo - we don't want info beyond 'invoked from within' as this is just plumbing related to the script sourcing |
||||||
|
set stacktrace [string map [list \r\n \n] [dict get $exitinfo errorInfo]] |
||||||
|
set output "" |
||||||
|
set tracelines [split $stacktrace \n] |
||||||
|
foreach ln $tracelines { |
||||||
|
if {[string match "*invoked from within*" $ln]} { |
||||||
|
break |
||||||
|
} |
||||||
|
append output $ln \n |
||||||
|
} |
||||||
|
set output [string trimright $output \n] |
||||||
|
dict set exitinfo errorInfo $output |
||||||
|
} |
||||||
|
return $exitinfo |
||||||
|
} |
||||||
|
|
||||||
|
proc do_tclkit {kitname replwhen args} { |
||||||
|
|
||||||
|
set script [string map [list %a% $args %k% $kitname] { |
||||||
|
#::tcl::tm::add %m% |
||||||
|
set kit %k% |
||||||
|
set kitpath [file normalize $kit] |
||||||
|
set kitmount $kitpath.0 |
||||||
|
|
||||||
|
#save values |
||||||
|
set prevscript [info script] |
||||||
|
set prevglobal [dict create] |
||||||
|
foreach g [list ::argv ::argc ::argv0] { |
||||||
|
if {[info exists $g]} { |
||||||
|
dict set prevglobal $g [set $g] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#setup and run |
||||||
|
set ::argv [list %a%] |
||||||
|
set ::argc [llength $::argv] |
||||||
|
|
||||||
|
set ::argv0 $kitmount |
||||||
|
#puts stderr "setting 'info script' $kitmount/main.tcl" |
||||||
|
info script $kitmount/main.tcl |
||||||
|
#info script dir must match argv0 for kit main.tcl to return 'starkit' from 'starkit::startup' |
||||||
|
|
||||||
|
if {![catch { |
||||||
|
package require vfs |
||||||
|
package require vfs::mk4 |
||||||
|
} errMsg]} { |
||||||
|
|
||||||
|
vfs::mk4::Mount $kitpath $kitmount |
||||||
|
lappend ::auto_path $kitmount/lib |
||||||
|
if {[file exists "$kitmount/modules"]} { |
||||||
|
tcl::tm::add "$kitmount/modules" |
||||||
|
} |
||||||
|
|
||||||
|
#puts stderr "sourcing $kitmount/main.tcl" |
||||||
|
#puts stderr "$kitmount/main.tcl exists: [file exists $kitmount/main.tcl]" |
||||||
|
#puts stderr "argv : $::argv" |
||||||
|
#puts stderr "argv0: $::argv0" |
||||||
|
#puts stderr "autopath: $::auto_path" |
||||||
|
#puts stdout "starkit::startup [starkit::startup]" |
||||||
|
|
||||||
|
#usually main.tcl will just be something like: package require app-XXX |
||||||
|
#it will usually do nothing if starkit::startup returned 'sourced' |
||||||
|
|
||||||
|
source $kitmount/main.tcl |
||||||
|
|
||||||
|
} else { |
||||||
|
puts stderr "Unable to load vfs::mk4 for tclkit mounting" |
||||||
|
} |
||||||
|
#restore values |
||||||
|
info script $prevscript |
||||||
|
dict with prevglobal {} |
||||||
|
}] |
||||||
|
|
||||||
|
set repl_lines "" |
||||||
|
append repl_lines {package require punk::repl} \n |
||||||
|
append repl_lines {repl::init -safe 0} \n |
||||||
|
append repl_lines {repl::start stdin} \n |
||||||
|
|
||||||
|
#test |
||||||
|
#set replwhen "repl_last" |
||||||
|
|
||||||
|
if {$replwhen eq "repl_first"} { |
||||||
|
#we need to cooperate with the repl to get the script to run on exit |
||||||
|
namespace eval ::repl {} |
||||||
|
set ::repl::post_script $script |
||||||
|
set script "$repl_lines" |
||||||
|
} elseif {$replwhen eq "repl_last"} { |
||||||
|
append script $repl_lines |
||||||
|
} else { |
||||||
|
#just the script |
||||||
|
} |
||||||
|
|
||||||
|
dict set params -tclscript 1 ;#don't give callback a chance to omit/break this |
||||||
|
dict set params -teehandle punkshell |
||||||
|
dict set params -inbuffering none |
||||||
|
dict set params -outbuffering none |
||||||
|
dict set params -readprocesstranslation crlf |
||||||
|
dict set params -outtranslation lf |
||||||
|
|
||||||
|
set id_err [shellfilter::stack::add stderr ansiwrap -action sink-locked -settings {-colour {red bold}}] |
||||||
|
|
||||||
|
set exitinfo [shellfilter::run $script {*}$params] |
||||||
|
|
||||||
|
shellfilter::stack::remove stderr $id_err |
||||||
|
|
||||||
|
if {[dict exists $exitinfo errorInfo]} { |
||||||
|
#strip out the irrelevant info from the errorInfo - we don't want info beyond 'invoked from within' as this is just plumbing related to the script sourcing |
||||||
|
set stacktrace [string map [list \r\n \n] [dict get $exitinfo errorInfo]] |
||||||
|
set output "" |
||||||
|
set tracelines [split $stacktrace \n] |
||||||
|
foreach ln $tracelines { |
||||||
|
if {[string match "*invoked from within*" $ln]} { |
||||||
|
break |
||||||
|
} |
||||||
|
append output $ln \n |
||||||
|
} |
||||||
|
set output [string trimright $output \n] |
||||||
|
dict set exitinfo errorInfo $output |
||||||
|
} |
||||||
|
return $exitinfo |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
punk::args::define { |
||||||
|
@id -id ::punkshell |
||||||
|
@cmd -name punkshell |
||||||
|
@leaders -min 0 -max 0 |
||||||
|
@opts |
||||||
|
-debug -type none |
||||||
|
@values -min 1 -max -1 |
||||||
|
script_or_kit -type string |
||||||
|
arg -type any -optional 1 -multiple 1 |
||||||
|
} |
||||||
|
set argd [punk::args::parse $::argv withid ::punkshell] |
||||||
|
lassign [dict values $argd] leaders opts values received |
||||||
|
|
||||||
|
set script_or_kit [dict get $values script_or_kit] |
||||||
|
if {[dict exists $received arg]} { |
||||||
|
set arglist [dict get $values arg] |
||||||
|
} else { |
||||||
|
set arglist [list] |
||||||
|
} |
||||||
|
|
||||||
|
set exitinfo [dict create] |
||||||
|
switch -glob -nocase -- $script_or_kit { |
||||||
|
lib:* { |
||||||
|
#scriptlib |
||||||
|
puts stderr "lib:* todo" |
||||||
|
} |
||||||
|
*.tcl { |
||||||
|
set exitinfo [punkshell::do_script $script_or_kit {*}$arglist] |
||||||
|
} |
||||||
|
*.kit { |
||||||
|
set exitinfo [punkshell::do_tclkit $script_or_kit "no_repl" {*}$arglist] |
||||||
|
} |
||||||
|
default { |
||||||
|
puts stderr "unrecognised script extension" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
catch { |
||||||
|
shellfilter::stack::remove stderr $chanstack_stderr_redir |
||||||
|
shellfilter::stack::remove stdout $chanstack_stdout_redir |
||||||
|
} |
||||||
|
shellfilter::stack::delete punkshellout |
||||||
|
shellfilter::stack::delete punkshellerr |
||||||
|
set free_info [shellthread::manager::shutdown_free_threads] |
||||||
|
foreach tid [thread::names] { |
||||||
|
thread::release $tid |
||||||
|
} |
||||||
|
|
||||||
|
if {[dict size $exitinfo] == 0} { |
||||||
|
puts stderr "No result" |
||||||
|
exit 2 |
||||||
|
} |
||||||
|
|
||||||
|
if {[dict exists $exitinfo errorInfo]} { |
||||||
|
set einf [dict get $exitinfo errorInfo] |
||||||
|
puts stderr "errorCode: [dict get $exitinfo errorCode]" |
||||||
|
if {[catch { |
||||||
|
punk::ansi::ansiwrap yellow bold $einf |
||||||
|
} msg]} { |
||||||
|
set msg $einf |
||||||
|
} |
||||||
|
puts stderr $msg |
||||||
|
flush stderr |
||||||
|
exit 1 |
||||||
|
} else { |
||||||
|
puts -nonewline stdout [dict get $exitinfo result] |
||||||
|
exit 0 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
@ -1,3 +1,2 @@ |
|||||||
|
package ifneeded app-shellspy 1.0 [list source [file join $dir shellspy.tcl]] |
||||||
package ifneeded app-shellspy 1.0 [list source [file join $dir shellspy.tcl]] |
|
||||||
|
|
||||||
|
|||||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,3 @@ |
|||||||
|
0.3.1 |
||||||
|
#First line must be a tm version number |
||||||
|
#all other lines are ignored. |
||||||
@ -0,0 +1,131 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application zzzload 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license BSD |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
##e.g package require frobz |
||||||
|
|
||||||
|
package require Thread |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval zzzload { |
||||||
|
variable loader_tid "" ;#thread id |
||||||
|
proc stacktrace {} { |
||||||
|
set stack "Stack trace:\n" |
||||||
|
for {set i 1} {$i < [info level]} {incr i} { |
||||||
|
set lvl [info level -$i] |
||||||
|
set pname [lindex $lvl 0] |
||||||
|
append stack [string repeat " " $i]$pname |
||||||
|
|
||||||
|
if {![catch {info args $pname} pargs]} { |
||||||
|
foreach value [lrange $lvl 1 end] arg $pargs { |
||||||
|
|
||||||
|
if {$value eq ""} { |
||||||
|
if {$arg != 0} { |
||||||
|
info default $pname $arg value |
||||||
|
} |
||||||
|
} |
||||||
|
append stack " $arg='$value'" |
||||||
|
} |
||||||
|
} else { |
||||||
|
append stack " !unknown vars for $pname" |
||||||
|
} |
||||||
|
|
||||||
|
append stack \n |
||||||
|
} |
||||||
|
return $stack |
||||||
|
} |
||||||
|
proc pkg_require {pkgname args} { |
||||||
|
variable loader_tid |
||||||
|
if {[set ver [package provide twapi]] ne ""} { |
||||||
|
#skip the whole shebazzle if it's already loaded |
||||||
|
return $ver |
||||||
|
} |
||||||
|
if {$loader_tid eq ""} { |
||||||
|
set loader_tid [thread::create -joinable -preserved] |
||||||
|
} |
||||||
|
if {![tsv::exists zzzload_pkg $pkgname]} { |
||||||
|
#puts stderr "zzzload pkg_require $pkgname" |
||||||
|
#puts [stacktrace] |
||||||
|
tsv::set zzzload_pkg $pkgname "loading" |
||||||
|
tsv::set zzzload_pkg_mutex $pkgname [thread::mutex create] |
||||||
|
set cond [thread::cond create] |
||||||
|
tsv::set zzzload_pkg_cond $pkgname $cond |
||||||
|
thread::send -async $loader_tid [string map [list <pkg> $pkgname <cond> $cond] { |
||||||
|
if {![catch {package require <pkg>} returnver]} { |
||||||
|
tsv::set zzzload_pkg <pkg> $returnver |
||||||
|
} else { |
||||||
|
tsv::set zzzload_pkg <pkg> "failed" |
||||||
|
} |
||||||
|
thread::cond notify <cond> |
||||||
|
}] |
||||||
|
return "loading" |
||||||
|
} else { |
||||||
|
return [tsv::get zzzload_pkg $pkgname] |
||||||
|
} |
||||||
|
} |
||||||
|
proc pkg_wait {pkgname} { |
||||||
|
if {[set ver [package provide twapi]] ne ""} { |
||||||
|
return $ver |
||||||
|
} |
||||||
|
|
||||||
|
set pkgstate [tsv::get zzzload_pkg $pkgname] |
||||||
|
if {$pkgstate eq "loading"} { |
||||||
|
set mutex [tsv::get zzzload_pkg_mutex $pkgname] |
||||||
|
thread::mutex lock $mutex |
||||||
|
set cond [tsv::get zzzload_pkg_cond $pkgname] |
||||||
|
while {[tsv::get zzzload_pkg $pkgname] eq "loading"} { |
||||||
|
thread::cond wait $cond $mutex 3000 |
||||||
|
} |
||||||
|
set result [tsv::get zzzload_pkg $pkgname] |
||||||
|
thread::mutex unlock $mutex |
||||||
|
return $result |
||||||
|
} else { |
||||||
|
return $pkgstate |
||||||
|
} |
||||||
|
} |
||||||
|
proc shutdown {} { |
||||||
|
variable loader_tid |
||||||
|
if {[thread::exists $loader_tid]} { |
||||||
|
thread::release $loader_tid |
||||||
|
thread::join $loader_tid |
||||||
|
set loader_tid "" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide zzzload [namespace eval zzzload { |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
@ -0,0 +1,131 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application zzzload 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license BSD |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
##e.g package require frobz |
||||||
|
|
||||||
|
package require Thread |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval zzzload { |
||||||
|
variable loader_tid "" ;#thread id |
||||||
|
proc stacktrace {} { |
||||||
|
set stack "Stack trace:\n" |
||||||
|
for {set i 1} {$i < [info level]} {incr i} { |
||||||
|
set lvl [info level -$i] |
||||||
|
set pname [lindex $lvl 0] |
||||||
|
append stack [string repeat " " $i]$pname |
||||||
|
|
||||||
|
if {![catch {info args $pname} pargs]} { |
||||||
|
foreach value [lrange $lvl 1 end] arg $pargs { |
||||||
|
|
||||||
|
if {$value eq ""} { |
||||||
|
if {$arg != 0} { |
||||||
|
info default $pname $arg value |
||||||
|
} |
||||||
|
} |
||||||
|
append stack " $arg='$value'" |
||||||
|
} |
||||||
|
} else { |
||||||
|
append stack " !unknown vars for $pname" |
||||||
|
} |
||||||
|
|
||||||
|
append stack \n |
||||||
|
} |
||||||
|
return $stack |
||||||
|
} |
||||||
|
proc pkg_require {pkgname args} { |
||||||
|
variable loader_tid |
||||||
|
if {[set ver [package provide twapi]] ne ""} { |
||||||
|
#skip the whole shebazzle if it's already loaded |
||||||
|
return $ver |
||||||
|
} |
||||||
|
if {$loader_tid eq ""} { |
||||||
|
set loader_tid [thread::create -joinable -preserved] |
||||||
|
} |
||||||
|
if {![tsv::exists zzzload_pkg $pkgname]} { |
||||||
|
#puts stderr "zzzload pkg_require $pkgname" |
||||||
|
#puts [stacktrace] |
||||||
|
tsv::set zzzload_pkg $pkgname "loading" |
||||||
|
tsv::set zzzload_pkg_mutex $pkgname [thread::mutex create] |
||||||
|
set cond [thread::cond create] |
||||||
|
tsv::set zzzload_pkg_cond $pkgname $cond |
||||||
|
thread::send -async $loader_tid [string map [list <pkg> $pkgname <cond> $cond] { |
||||||
|
if {![catch {package require <pkg>} returnver]} { |
||||||
|
tsv::set zzzload_pkg <pkg> $returnver |
||||||
|
} else { |
||||||
|
tsv::set zzzload_pkg <pkg> "failed" |
||||||
|
} |
||||||
|
thread::cond notify <cond> |
||||||
|
}] |
||||||
|
return "loading" |
||||||
|
} else { |
||||||
|
return [tsv::get zzzload_pkg $pkgname] |
||||||
|
} |
||||||
|
} |
||||||
|
proc pkg_wait {pkgname} { |
||||||
|
if {[set ver [package provide twapi]] ne ""} { |
||||||
|
return $ver |
||||||
|
} |
||||||
|
|
||||||
|
set pkgstate [tsv::get zzzload_pkg $pkgname] |
||||||
|
if {$pkgstate eq "loading"} { |
||||||
|
set mutex [tsv::get zzzload_pkg_mutex $pkgname] |
||||||
|
thread::mutex lock $mutex |
||||||
|
set cond [tsv::get zzzload_pkg_cond $pkgname] |
||||||
|
while {[tsv::get zzzload_pkg $pkgname] eq "loading"} { |
||||||
|
thread::cond wait $cond $mutex 3000 |
||||||
|
} |
||||||
|
set result [tsv::get zzzload_pkg $pkgname] |
||||||
|
thread::mutex unlock $mutex |
||||||
|
return $result |
||||||
|
} else { |
||||||
|
return $pkgstate |
||||||
|
} |
||||||
|
} |
||||||
|
proc shutdown {} { |
||||||
|
variable loader_tid |
||||||
|
if {[thread::exists $loader_tid]} { |
||||||
|
thread::release $loader_tid |
||||||
|
thread::join $loader_tid |
||||||
|
set loader_tid "" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide zzzload [namespace eval zzzload { |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
@ -0,0 +1,18 @@ |
|||||||
|
|
||||||
|
#!/bin/sh |
||||||
|
echo `# <#` |
||||||
|
mkdir -p ./zig |
||||||
|
wget https://ziglang.org/download/0.10.1/zig-linux-x86_64-0.10.1.tar.xz -O ./zig/zig-linux-x86_64-0.10.1.tar.xz |
||||||
|
tar -xf ./zig/zig-linux-x86_64-0.10.1.tar.xz -C ./zig --strip-components=1 |
||||||
|
rm ./zig/zig-linux-x86_64-0.10.1.tar.xz |
||||||
|
echo "Zig installed." |
||||||
|
./zig/zig version |
||||||
|
exit |
||||||
|
#> > $null |
||||||
|
|
||||||
|
Invoke-WebRequest -Uri "https://ziglang.org/download/0.10.1/zig-windows-x86_64-0.10.1.zip" -OutFile ".\zig-windows-x86_64-0.10.1.zip" |
||||||
|
Expand-Archive -Path ".\zig-windows-x86_64-0.10.1.zip" -DestinationPath ".\" -Force |
||||||
|
Remove-Item -Path " .\zig-windows-x86_64-0.10.1.zip" |
||||||
|
Rename-Item -Path ".\zig-windows-x86_64-0.10.1" -NewName ".\zig" |
||||||
|
Write-Host "Zig installed." |
||||||
|
./zig/zig.exe version |
||||||
@ -0,0 +1,9 @@ |
|||||||
|
puts stdout "::argc" |
||||||
|
puts stdout $::argc |
||||||
|
puts stdout "::argv" |
||||||
|
puts stdout "$::argv" |
||||||
|
puts stdout ----------------------- |
||||||
|
foreach a $::argv { |
||||||
|
puts stdout $a |
||||||
|
} |
||||||
|
puts stdout -done- |
||||||
@ -0,0 +1,15 @@ |
|||||||
|
[application] |
||||||
|
template="punk.multishell.cmd" |
||||||
|
as_admin=false |
||||||
|
|
||||||
|
scripts=[ |
||||||
|
"tclargs.tcl", |
||||||
|
] |
||||||
|
|
||||||
|
default_outputfile="tclargs.cmd" |
||||||
|
default_nextshellpath="tclsh" |
||||||
|
default_nextshelltype="tcl" |
||||||
|
|
||||||
|
win32.nextshellpath="tclsh" |
||||||
|
win32.nextshelltype="tcl" |
||||||
|
win32.outputfile="tclargs.cmd" |
||||||
@ -0,0 +1,83 @@ |
|||||||
|
namespace eval www::digest { |
||||||
|
variable noncecount |
||||||
|
} |
||||||
|
|
||||||
|
# HTTP/1.1 401 Unauthorized |
||||||
|
# WWW-Authenticate: Digest |
||||||
|
# realm="testrealm@host.com", |
||||||
|
# qop="auth,auth-int", |
||||||
|
# nonce="dcd98b7102dd2f0e8b11d0f600bfb0c093", |
||||||
|
# opaque="5ccc069c403ebaf9f0171e9517f40e41" |
||||||
|
|
||||||
|
proc www::digest::md5 {str} { |
||||||
|
package require md5 |
||||||
|
return [string tolower [::md5::md5 -hex $str]] |
||||||
|
} |
||||||
|
|
||||||
|
proc www::digest::sha256 {str} { |
||||||
|
package require sha256 |
||||||
|
return [::sha2::sha256 -hex $str] |
||||||
|
} |
||||||
|
|
||||||
|
proc www::digest::digest {challenge username password method uri {body ""}} { |
||||||
|
variable noncecount |
||||||
|
if {[dict exists $challenge algorithm]} { |
||||||
|
set algorithm [dict get $challenge algorithm] |
||||||
|
} else { |
||||||
|
set algorithm MD5 |
||||||
|
} |
||||||
|
switch $algorithm { |
||||||
|
MD5 - MD5-sess {set hash md5} |
||||||
|
SHA-256 - SHA-256-sess {set hash sha256} |
||||||
|
default { |
||||||
|
error "unsupported algorithm: $algorithm" |
||||||
|
} |
||||||
|
} |
||||||
|
set interlude [dict get $challenge nonce] |
||||||
|
set keys {username realm nonce uri response} |
||||||
|
if {[dict exists $challenge qop]} { |
||||||
|
set qops [split [dict get $challenge qop] ,] |
||||||
|
if {"auth" in $qops} { |
||||||
|
set qop auth |
||||||
|
} elseif {"auth-int" in $qops} { |
||||||
|
set qop auth-int |
||||||
|
} else { |
||||||
|
error "unsupported qop: [join $qops {, }]" |
||||||
|
} |
||||||
|
set nonce [dict get $challenge nonce] |
||||||
|
# Generate a random cnonce |
||||||
|
set cnonce [format %08x [expr {int(rand() * 0x100000000)}]] |
||||||
|
set nc [format %08X [incr noncecount($nonce)]] |
||||||
|
append interlude : $nc : $cnonce : $qop |
||||||
|
lappend keys qop nc cnonce |
||||||
|
if {[dict exists $challenge algorithm]} {lappend keys algorithm} |
||||||
|
if {[dict exists $challenge opaque]} {lappend keys opaque} |
||||||
|
} else { |
||||||
|
set qop auth |
||||||
|
} |
||||||
|
foreach n $keys { |
||||||
|
dict set rc $n \ |
||||||
|
[if {[dict exists $challenge $n]} {dict get $challenge $n}] |
||||||
|
} |
||||||
|
dict set rc username $username |
||||||
|
dict set rc uri $uri |
||||||
|
if {[dict exists $rc qop]} { |
||||||
|
dict set rc qop $qop |
||||||
|
dict set rc cnonce $cnonce |
||||||
|
dict set rc nc $nc |
||||||
|
} |
||||||
|
set A1 [$hash $username:[dict get $challenge realm]:$password] |
||||||
|
if {[string match {*-sess} $algorithm]} {append A1 : $nonce : $cnonce} |
||||||
|
set A2 [$hash $method:$uri] |
||||||
|
if {$qop eq "auth-int"} {append A2 : $body} |
||||||
|
dict set rc response [$hash $A1:$interlude:$A2] |
||||||
|
set authlist {} |
||||||
|
dict for {key val} $rc { |
||||||
|
if {$key ni {qop nc}} { |
||||||
|
lappend authlist [format {%s="%s"} $key $val] |
||||||
|
} else { |
||||||
|
lappend authlist $key=$val |
||||||
|
} |
||||||
|
} |
||||||
|
return "Digest [join $authlist ,]" |
||||||
|
} |
||||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,13 @@ |
|||||||
|
Copyright (c) 2021, Schelte Bron |
||||||
|
|
||||||
|
Permission to use, copy, modify, and/or distribute this software for any |
||||||
|
purpose with or without fee is hereby granted, provided that the above |
||||||
|
copyright notice and this permission notice appear in all copies. |
||||||
|
|
||||||
|
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES |
||||||
|
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF |
||||||
|
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR |
||||||
|
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES |
||||||
|
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN |
||||||
|
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF |
||||||
|
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. |
||||||
@ -0,0 +1,826 @@ |
|||||||
|
#!/usr/bin/tclsh |
||||||
|
|
||||||
|
# This library can be used together with www 2.0+ to use a proxy based on a |
||||||
|
# Proxy Auto Configure (pac) file: |
||||||
|
# package require proxypac |
||||||
|
# www configure -proxyfilter {proxypac <pacurl>} |
||||||
|
# Example: http://pac.webdefence.global.blackspider.com:8082/proxy.pac |
||||||
|
|
||||||
|
package require www |
||||||
|
|
||||||
|
namespace eval www::proxypac { |
||||||
|
variable oldpac {} |
||||||
|
namespace export proxypac |
||||||
|
|
||||||
|
proc proxypac {pacurl url host} { |
||||||
|
variable oldpac |
||||||
|
if {[string equal -length [string length $url] $pacurl $url]} { |
||||||
|
# The pac url itself must be reachable directly |
||||||
|
return DIRECT |
||||||
|
} |
||||||
|
try { |
||||||
|
if {$pacurl ne $oldpac} { |
||||||
|
set data [www get $pacurl] |
||||||
|
set oldpac $pacurl |
||||||
|
parse $data |
||||||
|
} |
||||||
|
set proxies [execute FindProxyForURL $url $host] |
||||||
|
return [lmap proxy [split $proxies {;}] { |
||||||
|
if {[string is space $proxy]} continue |
||||||
|
string trim $proxy |
||||||
|
}] |
||||||
|
} on error {err opts} { |
||||||
|
www::log "Failed to auto-configure proxy: $err" |
||||||
|
# In case of any error, use a direct connection |
||||||
|
return [list DIRECT] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc validip {ipchars} { |
||||||
|
set valid [lmap n [split $ipchars .] { |
||||||
|
expr {[string is digit -strict $n] && $n < 256} |
||||||
|
}] |
||||||
|
return [expr {[join $valid ""] eq "1111"}] |
||||||
|
} |
||||||
|
|
||||||
|
proc resolve {host} { |
||||||
|
if {[catch {package require dns}]} return |
||||||
|
set tok [dns::resolve $host] |
||||||
|
dns::wait $tok |
||||||
|
set result [lindex [dns::address $tok] 0] |
||||||
|
dns::cleanup $tok |
||||||
|
return $result |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {[catch {package require duktape::oo 0.11}]} { |
||||||
|
proc www::proxypac::parse {data} { |
||||||
|
set code [convert [string map [list \r\n \n] $data]] |
||||||
|
proxypacrun eval $code |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::execute {args} { |
||||||
|
proxypacrun eval $args |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::convert {data} { |
||||||
|
variable tokenlist |
||||||
|
set p 0 |
||||||
|
set re {/[/=*]?|[*]/|[+][+=]?|[*][*]?=?|-=?|<[<=]?|>>>|>[>=]?|%=?|&&?|[|][|]?|!=?=?|={1,3}|[][(),.{}"';\n?~^]|[ \t]+} |
||||||
|
|
||||||
|
set tokenlist [lmap n [regexp -all -indices -inline $re $data] { |
||||||
|
lassign $n x1 x2 |
||||||
|
set str [string range $data $p [expr {$x1 - 1}]] |
||||||
|
set sep [string range $data $x1 $x2] |
||||||
|
set p [expr {$x2 + 1}] |
||||||
|
list $str $sep |
||||||
|
}] |
||||||
|
|
||||||
|
set code [lmap line [block] { |
||||||
|
set tabs [string length [lindex [regexp -inline ^\t* $line] 0]] |
||||||
|
set indent [string repeat \t [expr {$tabs / 2}]] |
||||||
|
append indent [string repeat " " [expr {$tabs % 2}]] |
||||||
|
regsub ^\t* $line $indent |
||||||
|
}] |
||||||
|
return [join $code \n] |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::peek {{trim 1}} { |
||||||
|
variable tokenlist |
||||||
|
variable count |
||||||
|
if {[incr count] > 20} { |
||||||
|
fail "endless loop" |
||||||
|
} |
||||||
|
if {[llength $tokenlist] == 0} return |
||||||
|
lassign [lindex $tokenlist 0] str tag |
||||||
|
if {![string is space $tag] || !$trim} { |
||||||
|
return [lindex $tokenlist 0] |
||||||
|
} elseif {$str ne ""} { |
||||||
|
if {[lindex $tokenlist 1 0] ne ""} { |
||||||
|
return [lindex $tokenlist 0] |
||||||
|
} |
||||||
|
lset tokenlist 1 0 $str |
||||||
|
} |
||||||
|
set tokenlist [lrange $tokenlist 1 end] |
||||||
|
tailcall peek |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::poke {str tag} { |
||||||
|
variable tokenlist |
||||||
|
lset tokenlist 0 [list $str $tag] |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::next {{trim 1}} { |
||||||
|
variable tokenlist |
||||||
|
variable count 0 |
||||||
|
set tokenlist [lrange $tokenlist 1 end] |
||||||
|
tailcall peek $trim |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::end {} { |
||||||
|
variable tokenlist |
||||||
|
return [expr {[llength $tokenlist] == 0}] |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::code {} { |
||||||
|
lassign [peek] str tag |
||||||
|
if {$str eq "" && $tag eq "\{"} { |
||||||
|
next |
||||||
|
lappend rc {*}[block] |
||||||
|
lassign [peek] str tag |
||||||
|
if {$tag ne "\}"} { |
||||||
|
fail "expected \}" |
||||||
|
} |
||||||
|
next |
||||||
|
} else { |
||||||
|
lappend rc {*}[statement] |
||||||
|
} |
||||||
|
return $rc |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::block {} { |
||||||
|
while {![end]} { |
||||||
|
lassign [peek] str tag |
||||||
|
switch $str { |
||||||
|
{} { |
||||||
|
if {$tag in {// /*}} { |
||||||
|
comment |
||||||
|
} |
||||||
|
} |
||||||
|
default { |
||||||
|
set block [statement] |
||||||
|
lappend rc {*}$block |
||||||
|
} |
||||||
|
} |
||||||
|
lassign [peek] str tag |
||||||
|
if {$tag eq "\}"} { |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
return $rc |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::comment {} { |
||||||
|
variable tokenlist |
||||||
|
variable count 0 |
||||||
|
lassign [peek] str tag |
||||||
|
if {$tag eq "//"} { |
||||||
|
set end \n |
||||||
|
} else { |
||||||
|
set end "*/" |
||||||
|
} |
||||||
|
set nl [lsearch -exact -index 1 $tokenlist $end] |
||||||
|
if {$nl < 0} {set nl end} |
||||||
|
set tokenlist [lreplace $tokenlist 0 $nl] |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::statement {} { |
||||||
|
lassign [peek] str tag |
||||||
|
switch $str { |
||||||
|
function { |
||||||
|
if {![string is space $tag]} { |
||||||
|
fail "expected white space" |
||||||
|
} |
||||||
|
set rc [function] |
||||||
|
} |
||||||
|
if { |
||||||
|
set rc [ifelse] |
||||||
|
} |
||||||
|
return { |
||||||
|
set rc [jsreturn] |
||||||
|
} |
||||||
|
var { |
||||||
|
if {![string is space $tag]} { |
||||||
|
fail "expected white space" |
||||||
|
} |
||||||
|
set rc [var] |
||||||
|
} |
||||||
|
for { |
||||||
|
if {$tag ne "("} { |
||||||
|
fail "expected (" |
||||||
|
} |
||||||
|
set rc [forloop] |
||||||
|
} |
||||||
|
default { |
||||||
|
if {![regexp {^[\w$]+$} $str]} { |
||||||
|
fail "unsupported JavaScript command: $str" |
||||||
|
} elseif {$tag eq "="} { |
||||||
|
set rc [assignment $str] |
||||||
|
} elseif {$tag eq "("} { |
||||||
|
set rc [list [funccall $str]] |
||||||
|
} else { |
||||||
|
fail "unsupported JavaScript command: $str (tag = $tag)" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
lassign [peek] str tag |
||||||
|
if {$tag eq ";"} { |
||||||
|
lassign [next] str tag |
||||||
|
} |
||||||
|
return $rc |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::jsreturn {} { |
||||||
|
lassign [peek] str tag |
||||||
|
if {$str eq "" && $tag in {; \n}} { |
||||||
|
return [list return] |
||||||
|
} else { |
||||||
|
poke "" $tag |
||||||
|
return [list "return [expression]"] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::expression {{top 1}} { |
||||||
|
lassign [peek] str tag |
||||||
|
set rc {} |
||||||
|
set unary {} |
||||||
|
set strcat 0 |
||||||
|
while 1 { |
||||||
|
if {$str eq "" && $tag in {+ - ! ~}} { |
||||||
|
append unary $tag |
||||||
|
lassign [next] str tag |
||||||
|
continue |
||||||
|
} |
||||||
|
switch -regexp $str { |
||||||
|
{^$} { |
||||||
|
set op [lindex $rc end] |
||||||
|
if {$op eq "=="} { |
||||||
|
lset rc end eq |
||||||
|
} elseif {$op eq "!="} { |
||||||
|
lset rc end ne |
||||||
|
} |
||||||
|
if {$tag in {\" '}} { |
||||||
|
set quote $tag |
||||||
|
set strvar "" |
||||||
|
while 1 { |
||||||
|
lassign [next 0] str tag |
||||||
|
if {$tag eq $quote} { |
||||||
|
append strvar $str |
||||||
|
break |
||||||
|
} else { |
||||||
|
append strvar $str $tag |
||||||
|
} |
||||||
|
} |
||||||
|
lappend rc [format {{%s}} $strvar] |
||||||
|
lassign [next] str tag |
||||||
|
if {$str ne ""} { |
||||||
|
fail "invalid expression" |
||||||
|
} |
||||||
|
set strcat 1 |
||||||
|
} elseif {$tag in "("} { |
||||||
|
next |
||||||
|
lappend rc [format (%s) [expression 0]] |
||||||
|
lassign [peek] str tag |
||||||
|
if {$tag ne ")"} { |
||||||
|
fail "expected )" |
||||||
|
} |
||||||
|
next |
||||||
|
} |
||||||
|
} |
||||||
|
{^[\w$]+$} { |
||||||
|
if {$tag eq "("} { |
||||||
|
lappend rc [format {[%s]} [funccall $str]] |
||||||
|
} elseif {$tag eq "\["} { |
||||||
|
lappend rc [arrayelem $str] |
||||||
|
} elseif {[string is double $str]} { |
||||||
|
lappend rc $str |
||||||
|
} elseif {[string tolower $str] in {true false}} { |
||||||
|
lappend rc $str |
||||||
|
} else { |
||||||
|
lappend rc [format {$%s} $str] |
||||||
|
} |
||||||
|
} |
||||||
|
default { |
||||||
|
fail "expected expression" |
||||||
|
} |
||||||
|
} |
||||||
|
lassign [peek] str tag |
||||||
|
while {$tag eq "."} { |
||||||
|
lset rc end [method [lindex $rc end]] |
||||||
|
lassign [peek] str tag |
||||||
|
} |
||||||
|
if {$unary ne ""} { |
||||||
|
lset rc end $unary[lindex $rc end] |
||||||
|
set unary {} |
||||||
|
} |
||||||
|
switch $tag { |
||||||
|
+ - - - * - ** - / - % - |
||||||
|
== - != - > - < - >= - <= - ? - : - |
||||||
|
& - | - ^ - << - >> - && - || { |
||||||
|
lappend rc $tag |
||||||
|
} |
||||||
|
=== { |
||||||
|
lappend rc == |
||||||
|
} |
||||||
|
!== { |
||||||
|
lappend rc != |
||||||
|
} |
||||||
|
>>> { |
||||||
|
lappend rc >> |
||||||
|
} |
||||||
|
default { |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
lassign [next] str tag |
||||||
|
} |
||||||
|
if {!$top} { |
||||||
|
return [join $rc " "] |
||||||
|
} elseif {[llength $rc] == 1} { |
||||||
|
set rc [lindex $rc 0] |
||||||
|
if {[string match {{*}} $rc]} { |
||||||
|
return [list [string range $rc 1 end-1]] |
||||||
|
} else { |
||||||
|
return $rc |
||||||
|
} |
||||||
|
} elseif {!$strcat} { |
||||||
|
return [format {[expr {%s}]} [join $rc " "]] |
||||||
|
} |
||||||
|
set cat {} |
||||||
|
set expr {} |
||||||
|
set rest [lassign $rc arg] |
||||||
|
set strcat [string match {{*}} $arg] |
||||||
|
if {$strcat} { |
||||||
|
lappend cat $arg |
||||||
|
} else { |
||||||
|
lappend expr $arg |
||||||
|
} |
||||||
|
foreach {op arg} $rest { |
||||||
|
if {$op ne "+" || !$strcat && ![string match {{*}} $arg]} { |
||||||
|
lappend expr $op $arg |
||||||
|
} else { |
||||||
|
if {[llength $expr]} { |
||||||
|
if {[llength $expr] > 1} { |
||||||
|
lappend cat [format {[expr {%s}]} [join $expr]] |
||||||
|
} else { |
||||||
|
lappend cat [lindex $expr 0] |
||||||
|
} |
||||||
|
} |
||||||
|
set expr {} |
||||||
|
if {[string match {{*}} $arg]} { |
||||||
|
set strcat 1 |
||||||
|
lappend cat $arg |
||||||
|
} else { |
||||||
|
lappend expr $arg |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
if {[llength $expr]} { |
||||||
|
if {[llength $expr] > 1} { |
||||||
|
lappend cat [format {[expr {%s}]} [join $expr]] |
||||||
|
} else { |
||||||
|
lappend cat [lindex $expr 0] |
||||||
|
} |
||||||
|
} |
||||||
|
return [format {[string cat %s]} [join $cat]] |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::function {} { |
||||||
|
lassign [next] name tag |
||||||
|
if {$tag ne "("} { |
||||||
|
fail "expected open parenthesis" |
||||||
|
} |
||||||
|
set arglist {} |
||||||
|
lassign [next] str tag |
||||||
|
if {$str ne ""} { |
||||||
|
while 1 { |
||||||
|
lappend arglist $str |
||||||
|
if {$tag eq ")"} break |
||||||
|
if {$tag ne ","} { |
||||||
|
fail "expected , or )" |
||||||
|
} |
||||||
|
lassign [next] str tag |
||||||
|
} |
||||||
|
} elseif {$tag ne ")"} { |
||||||
|
fail "expected )" |
||||||
|
} |
||||||
|
lappend rc "proc $name [list $arglist] \{" |
||||||
|
lassign [next] str tag |
||||||
|
lappend rc {*}[indent [code]] |
||||||
|
lappend rc "\}" |
||||||
|
return $rc |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::funccall {name} { |
||||||
|
set cmd $name |
||||||
|
lassign [next] str tag |
||||||
|
if {$str ne "" || $tag ne ")"} { |
||||||
|
while 1 { |
||||||
|
append cmd " " [expression] |
||||||
|
lassign [peek] str tag |
||||||
|
if {$tag eq ")"} break |
||||||
|
if {$tag ne ","} { |
||||||
|
fail "expected , or )" |
||||||
|
} |
||||||
|
next |
||||||
|
} |
||||||
|
} |
||||||
|
next |
||||||
|
return $cmd |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::ifelse {} { |
||||||
|
lassign [peek] str tag |
||||||
|
if {$tag ne "("} { |
||||||
|
fail "expected (" |
||||||
|
} |
||||||
|
next |
||||||
|
lappend rc [format "if {%s} \{" [expression 0]] |
||||||
|
lassign [next] str tag |
||||||
|
lappend rc {*}[indent [code]] |
||||||
|
lassign [peek] str tag |
||||||
|
if {$str eq "else"} { |
||||||
|
lappend rc {\} else \{} |
||||||
|
lassign [next] str tag |
||||||
|
lappend rc {*}[indent [code]] |
||||||
|
} |
||||||
|
lappend rc "\}" |
||||||
|
return $rc |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::forloop {} { |
||||||
|
lassign [peek] str tag |
||||||
|
if {$tag ne "("} { |
||||||
|
fail "expected (" |
||||||
|
} |
||||||
|
lassign [next] name tag |
||||||
|
if {$name eq "var" && [string is space $tag]} { |
||||||
|
lassign [next] name tag |
||||||
|
} |
||||||
|
if {![regexp {^[\w$]+$} $name]} { |
||||||
|
fail "expected identifier" |
||||||
|
} |
||||||
|
if {$tag eq "="} { |
||||||
|
} elseif {[string is space $tag]} { |
||||||
|
lassign [next] str tag |
||||||
|
if {$str ni {in of} || ![string is space $tag]} { |
||||||
|
fail "expected 'in' or 'of'" |
||||||
|
} |
||||||
|
if {$str eq "in"} { |
||||||
|
set op keys |
||||||
|
} else { |
||||||
|
set op values |
||||||
|
} |
||||||
|
lassign [next] str tag |
||||||
|
lappend rc [format "foreach %s \[dict %s $%s\] \{" $name $op $str] |
||||||
|
if {$tag ne ")"} { |
||||||
|
fail "expected )" |
||||||
|
} |
||||||
|
next |
||||||
|
lappend rc {*}[indent [code]] |
||||||
|
lappend rc "\}" |
||||||
|
} |
||||||
|
return $rc |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::method {obj} { |
||||||
|
lassign [next] method tag |
||||||
|
set cmd [format {%s %s} $method $obj] |
||||||
|
if {$tag eq "("} { |
||||||
|
lassign [next] str tag |
||||||
|
if {$str ne "" || $tag ne ")"} { |
||||||
|
while 1 { |
||||||
|
append cmd " " [expression] |
||||||
|
lassign [peek] str tag |
||||||
|
if {$tag eq ")"} break |
||||||
|
if {$tag ne ","} { |
||||||
|
fail "expected , or )" |
||||||
|
} |
||||||
|
next |
||||||
|
} |
||||||
|
} |
||||||
|
next |
||||||
|
} |
||||||
|
return [format {[%s]} $cmd] |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::assignment {name} { |
||||||
|
lassign [next] str tag |
||||||
|
switch $str { |
||||||
|
new { |
||||||
|
if {![string is space $tag]} { |
||||||
|
fail "expected white space" |
||||||
|
} |
||||||
|
lassign [next] str tag |
||||||
|
switch $str { |
||||||
|
Array { |
||||||
|
if {$tag ne "("} { |
||||||
|
fail "expected (" |
||||||
|
} |
||||||
|
set cmd "dict create" |
||||||
|
lassign [next] str tag |
||||||
|
set index 0 |
||||||
|
if {$str ne "" || $tag ne ")"} { |
||||||
|
while 1 { |
||||||
|
append cmd " " $index " " [expression] |
||||||
|
incr index |
||||||
|
lassign [peek] str tag |
||||||
|
next |
||||||
|
if {$tag eq ","} continue |
||||||
|
if {$tag eq ")"} break |
||||||
|
fail "expected , or )" |
||||||
|
} |
||||||
|
} else { |
||||||
|
next |
||||||
|
} |
||||||
|
return [list [format {set %s [%s]} $name $cmd]] |
||||||
|
} |
||||||
|
default { |
||||||
|
fail "$str objects are not supported" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
{} { |
||||||
|
if {$tag eq "\["} { |
||||||
|
set cmd list |
||||||
|
lassign [next] str tag |
||||||
|
if {$str ne "" || $tag ne "]"} { |
||||||
|
while 1 { |
||||||
|
append cmd " " [expression] |
||||||
|
lassign [peek] str tag |
||||||
|
next |
||||||
|
if {$tag eq ","} continue |
||||||
|
if {$tag eq "\]"} break |
||||||
|
fail "expected , or \]" |
||||||
|
} |
||||||
|
} |
||||||
|
return [list [format {set %s [%s]} $name $cmd]] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return [list [format {set %s %s} $name [expression]]] |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::var {} { |
||||||
|
lassign [next] str tag |
||||||
|
if {![regexp {^[\w$]+$} $str]} { |
||||||
|
fail "expected identifier" |
||||||
|
} |
||||||
|
if {$tag in {; \n}} return |
||||||
|
return [assignment $str] |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::arrayelem {name} { |
||||||
|
next |
||||||
|
set sub [expression] |
||||||
|
lassign [peek] str tag |
||||||
|
if {$tag ne "\]"} { |
||||||
|
fail "expected \]" |
||||||
|
} |
||||||
|
next |
||||||
|
return [format {[dict get $%s %s]} $name $sub] |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::indent {list} { |
||||||
|
return [lmap line $list {format \t%s $line}] |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::fail {str} { |
||||||
|
error $str |
||||||
|
} |
||||||
|
|
||||||
|
namespace eval www::proxypac { |
||||||
|
interp create [namespace current]::proxypacrun |
||||||
|
proxypacrun alias resolve [namespace which resolve] |
||||||
|
proxypacrun alias validip [namespace which validip] |
||||||
|
|
||||||
|
proxypacrun eval { |
||||||
|
proc substring {str start {end 0}} { |
||||||
|
if {[llength [info level 0]] < 4} { |
||||||
|
set end [string length $str] |
||||||
|
} |
||||||
|
if {$start < $end} { |
||||||
|
return [string range $str $start [expr {$end - 1}]] |
||||||
|
} else { |
||||||
|
return [string range $str $end [expr {$start - 1}]] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc toLowerCase {str} { |
||||||
|
return [string tolower $str] |
||||||
|
} |
||||||
|
|
||||||
|
rename split tclsplit |
||||||
|
proc split {str {separator ""} {limit 2147483647}} { |
||||||
|
if {[llength [info level 0]] == 1} { |
||||||
|
set list [list $str] |
||||||
|
} elseif {$separator eq ""} { |
||||||
|
set list [tclsplit $str ""] |
||||||
|
} else { |
||||||
|
set list {} |
||||||
|
set p 0 |
||||||
|
while {[set x [string first $separator $str $p]] >= 0} { |
||||||
|
lappend list [string range $str $p [expr {$x - 1}]] |
||||||
|
set p [expr {$x + [string length $separator]}] |
||||||
|
} |
||||||
|
lappend list [string range $str $p end] |
||||||
|
} |
||||||
|
set rc {} |
||||||
|
set num 0 |
||||||
|
foreach n $list { |
||||||
|
if {$num >= $limit} break |
||||||
|
dict set rc $num $n |
||||||
|
incr num |
||||||
|
} |
||||||
|
return $rc |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc jsfunction {name type args body} { |
||||||
|
proxypacrun alias $name \ |
||||||
|
apply [list $args $body [namespace current]] |
||||||
|
# proxypacrun eval [list proc $name $args $body] |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
namespace eval www::proxypac { |
||||||
|
duktape::oo::Duktape create js |
||||||
|
|
||||||
|
proc parse {data} { |
||||||
|
js eval $data |
||||||
|
} |
||||||
|
|
||||||
|
proc execute {args} { |
||||||
|
js call {*}$args |
||||||
|
} |
||||||
|
|
||||||
|
proc jsfunction {name type args body} { |
||||||
|
js tcl-function $name $type $args $body |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
namespace eval www::proxypac { |
||||||
|
variable ipaddress "" |
||||||
|
|
||||||
|
jsfunction isPlainHostName boolean {host} { |
||||||
|
return [expr {[string first . $host] < 0}] |
||||||
|
} |
||||||
|
|
||||||
|
jsfunction dnsDomainIs boolean {host domain} { |
||||||
|
set x [string first . $host] |
||||||
|
return [expr {$x >= 0 && [string range $host $x end] eq $domain}] |
||||||
|
} |
||||||
|
|
||||||
|
jsfunction localHostOrDomainIs boolean {host hostdom} { |
||||||
|
return \ |
||||||
|
[expr {$host eq $hostdom || $host eq [lindex [split $host .] 0]}] |
||||||
|
} |
||||||
|
|
||||||
|
jsfunction isValidIpAddress boolean {ipchars} { |
||||||
|
return [validip $ipchars] |
||||||
|
} |
||||||
|
|
||||||
|
jsfunction isResolvable boolean {host} { |
||||||
|
return [expr {[resolve $host] ne ""}] |
||||||
|
} |
||||||
|
|
||||||
|
jsfunction isInNet boolean {host pattern mask} { |
||||||
|
if {![validip $host]} { |
||||||
|
set host [resolve $host] |
||||||
|
if {$host eq ""} {return 0} |
||||||
|
} |
||||||
|
foreach ip1 [split $host .] ip2 [split $pattern .] m [split $mask .] { |
||||||
|
if {($ip1 & $m) != ($ip2 & $m)} {return 0} |
||||||
|
} |
||||||
|
return 1 |
||||||
|
} |
||||||
|
|
||||||
|
jsfunction dnsResolve string {host} { |
||||||
|
return [resolve $host] |
||||||
|
} |
||||||
|
|
||||||
|
jsfunction convert_addr integer {ipaddr} { |
||||||
|
binary scan [binary format c4 [split $ipaddr .]] Iu addr |
||||||
|
return $addr |
||||||
|
} |
||||||
|
|
||||||
|
jsfunction myIpAddress string {} { |
||||||
|
variable ipaddress |
||||||
|
if {$ipaddress eq ""} { |
||||||
|
try { |
||||||
|
set fd "" |
||||||
|
set fd [socket -server dummy -myaddr [info hostname] 0] |
||||||
|
set ipaddress [lindex [fconfigure $fd -sockname] 0] |
||||||
|
} on error {} { |
||||||
|
set ipaddress 127.0.0.1 |
||||||
|
} finally { |
||||||
|
if {$fd ne ""} {close $fd} |
||||||
|
} |
||||||
|
} |
||||||
|
return $ipaddress |
||||||
|
} |
||||||
|
|
||||||
|
jsfunction dnsDomainLevels integer {host} { |
||||||
|
return [regexp {[.]} $host] |
||||||
|
} |
||||||
|
|
||||||
|
jsfunction shExpMatch boolean {str shexp} { |
||||||
|
return [string match $shexp $str] |
||||||
|
} |
||||||
|
|
||||||
|
jsfunction weekdayRange boolean {wd1 {wd2 ""} {gmt ""}} { |
||||||
|
set weekdays {SUN MON TUE WED THU FRI SAT} |
||||||
|
if {$wd2 eq "GMT"} { |
||||||
|
set gmt 1 |
||||||
|
set match [list $wd1] |
||||||
|
} else { |
||||||
|
set gmt [expr {$gmt eq "GMT"}] |
||||||
|
set d1 [lsearch -exact $weekdays $wd1] |
||||||
|
set d2 [lsearch -exact $weekdays $wd2] |
||||||
|
if {$d1 < $d2} { |
||||||
|
set match [lrange $weekdays $d1 $d2] |
||||||
|
} else { |
||||||
|
set match [list $wd1 $wd2] |
||||||
|
} |
||||||
|
} |
||||||
|
set wd0 [clock format [clock seconds] -gmt $gmt -format %a] |
||||||
|
return [expr {[string toupper $wd0] in $match}] |
||||||
|
} |
||||||
|
|
||||||
|
jsfunction dateRange boolean {args} { |
||||||
|
set gmt [expr {[lindex $args end] eq "GMT"}] |
||||||
|
set len [expr {[llength $args] - $gmt}] |
||||||
|
if {$len < 1} {return 0} |
||||||
|
set now [clock seconds] |
||||||
|
if {$len == 1} { |
||||||
|
set arg [lindex $args 0] |
||||||
|
if {![string is integer -strict $arg]} { |
||||||
|
set mon [clock format $now -format %b -gmt $gmt] |
||||||
|
return [expr {$arg eq [string toupper $mon]}] |
||||||
|
} elseif {$arg < 32} { |
||||||
|
set day [clock format $now -format %e -gmt $gmt] |
||||||
|
return [expr {$arg == $day}] |
||||||
|
} else { |
||||||
|
set year [clock format $now -format %Y -gmt $gmt] |
||||||
|
return [expr {$arg == $year}] |
||||||
|
} |
||||||
|
} |
||||||
|
lassign [clock format $now -format {%Y %b} -gmt $gmt] year month |
||||||
|
set d1 [list $year JAN 1 0 0 0] |
||||||
|
set d2 [list $year DEC 31 23 59 59] |
||||||
|
set middle [expr {$len / 2}] |
||||||
|
for {set i 0} {$i < $middle} {incr i} { |
||||||
|
set arg [lindex $args $i] |
||||||
|
if {![string is integer -strict $arg]} { |
||||||
|
lset d1 1 $arg |
||||||
|
} elseif {$arg < 32} { |
||||||
|
lset d1 2 $arg |
||||||
|
if {$len <= 2} { |
||||||
|
lset d1 1 $month |
||||||
|
lset d2 1 $month |
||||||
|
} |
||||||
|
} else { |
||||||
|
lset d1 0 $arg |
||||||
|
} |
||||||
|
} |
||||||
|
for {set i $middle} {$i < $len} {incr i} { |
||||||
|
set arg [lindex $args $i] |
||||||
|
if {![string is integer -strict $arg]} { |
||||||
|
lset d2 1 $arg |
||||||
|
} elseif {$arg < 32} { |
||||||
|
lset d2 2 $arg |
||||||
|
} else { |
||||||
|
lset d2 0 $arg |
||||||
|
} |
||||||
|
} |
||||||
|
set time1 [clock scan [join $d1 :] -format %Y:%b:%d:%T -gmt $gmt] |
||||||
|
set time2 [clock scan [join $d2 :] -format %Y:%b:%d:%T -gmt $gmt] |
||||||
|
if {$time1 < $time2} { |
||||||
|
return [expr {$now >= $time1 && $now <= $time2}] |
||||||
|
} else { |
||||||
|
return [expr {$now >= $time2 && $now <= $time1}] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
jsfunction timeRange boolean {args} { |
||||||
|
set gmt [expr {[lindex $args end] eq "GMT"}] |
||||||
|
set len [expr {[llength $args] - $gmt}] |
||||||
|
if {$len < 1} { |
||||||
|
return 0 |
||||||
|
} elseif {$len > 6 || $len == 3 || $len == 5} { |
||||||
|
return -code error "timeRange: bad number of arguments" |
||||||
|
} |
||||||
|
set t1 {0 0 0} |
||||||
|
set t2 {23 59 59} |
||||||
|
set n [expr {($len + 1) / 2}] |
||||||
|
for {set i1 0; set i2 [expr {$len / 2}]} {$i1 < $n} {incr i1; incr i2} { |
||||||
|
lset t1 $i1 [lindex $args $i1] |
||||||
|
if {$i2 < $len} { |
||||||
|
lset t2 $i1 [lindex $args $i2] |
||||||
|
} |
||||||
|
} |
||||||
|
set time1 [clock scan [join $t1 :] -format %T -gmt $gmt] |
||||||
|
set time2 [clock scan [join $t2 :] -format %T -gmt $gmt] |
||||||
|
set now [clock seconds] |
||||||
|
if {$time1 < $time2} { |
||||||
|
return [expr {$now >= $time1 && $now <= $time2}] |
||||||
|
} else { |
||||||
|
return [expr {$now >= $time2 && $now <= $time1}] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
jsfunction alert undefined {} {} |
||||||
|
} |
||||||
|
|
||||||
|
namespace import www::proxypac::* |
||||||
@ -0,0 +1,156 @@ |
|||||||
|
# SOCKS V4a: http://ftp.icm.edu.pl/packages/socks/socks4/SOCKS4.protocol |
||||||
|
# SOCKS V5: RFC 1928 |
||||||
|
|
||||||
|
namespace eval www::socks { |
||||||
|
variable username guest password guest |
||||||
|
namespace ensemble create -map {socks4 {init socks4} socks5 {init socks5}} |
||||||
|
} |
||||||
|
|
||||||
|
proc www::socks::command {sock data {count 2} {timeout 2000}} { |
||||||
|
if {$data ne ""} { |
||||||
|
puts -nonewline $sock $data |
||||||
|
flush $sock |
||||||
|
} |
||||||
|
set coro [info coroutine] |
||||||
|
if {[llength $coro]} { |
||||||
|
set id [after $timeout [list $coro timeout]] |
||||||
|
fileevent $sock readable [list $coro data] |
||||||
|
} else { |
||||||
|
fconfigure $sock -blocking 1 |
||||||
|
set id {} |
||||||
|
} |
||||||
|
set resp {} |
||||||
|
set len 0 |
||||||
|
while {![eof $sock]} { |
||||||
|
append resp [read $sock [expr {$count - $len}]] |
||||||
|
set len [string length $resp] |
||||||
|
if {$len >= $count} { |
||||||
|
after cancel $id |
||||||
|
return $resp |
||||||
|
} |
||||||
|
if {[llength $coro] == 0} continue |
||||||
|
set event [yield] |
||||||
|
if {$event eq "data"} continue |
||||||
|
if {$event eq "timeout"} break |
||||||
|
} |
||||||
|
throw {SOCKS PROTOCOL ERROR} "did not get expected response from proxy" |
||||||
|
} |
||||||
|
|
||||||
|
proc www::socks::init {version sock host port} { |
||||||
|
# Make sure this is running in a coroutine |
||||||
|
if {[llength [info coroutine]] == 0} { |
||||||
|
return [coroutine $sock init $version $sock $host $port] |
||||||
|
} |
||||||
|
dict set cfg -translation [fconfigure $sock -translation] |
||||||
|
dict set cfg -blocking [fconfigure $sock -blocking] |
||||||
|
dict set event readable [fileevent $sock readable] |
||||||
|
dict set event writable [fileevent $sock writable] |
||||||
|
fileevent $sock writable {} |
||||||
|
fconfigure $sock -translation binary -blocking 0 |
||||||
|
if {[catch {$version $sock $host $port} result opts]} { |
||||||
|
variable lasterror $result |
||||||
|
} |
||||||
|
fconfigure $sock {*}$cfg |
||||||
|
dict for {ev cmd} $event { |
||||||
|
fileevent $sock $ev $cmd |
||||||
|
} |
||||||
|
return -options [dict incr opts -level] $result |
||||||
|
} |
||||||
|
|
||||||
|
proc www::socks::socks4 {sock host port} { |
||||||
|
variable username |
||||||
|
set ip4 [split $host .] |
||||||
|
if {[llength $ip4] == 4 && [string is digit -strict [lindex $ip4 end]]} { |
||||||
|
set data [binary format ccSc4a*x 4 1 $port $ip4 $username] |
||||||
|
} else { |
||||||
|
# SOCKS4a |
||||||
|
set data [binary format ccSx3ca*xa*x 4 1 $port 1 $username $host] |
||||||
|
} |
||||||
|
binary scan [command $sock $data 8] cucuSc4 vn cd dstport dstip |
||||||
|
if {$vn != 0} { |
||||||
|
throw {SOCKS CONNECT VERSION} \ |
||||||
|
"unsupported socks connection version: $vn" |
||||||
|
} |
||||||
|
if {$cd != 90} { |
||||||
|
throw [list SOCKS CONNECT [format ERROR%02X $cd]] \ |
||||||
|
"socks connection failed with error code $cd" |
||||||
|
} |
||||||
|
return [join $dstip .]:$dstport |
||||||
|
} |
||||||
|
|
||||||
|
proc www::socks::socks5 {sock host port} { |
||||||
|
fconfigure $sock -translation binary -blocking 0 |
||||||
|
# Authenticate |
||||||
|
set methods [list 0 2] |
||||||
|
set data [binary format ccc* 5 [llength $methods] $methods] |
||||||
|
binary scan [command $sock $data 2] cucu version method |
||||||
|
|
||||||
|
if {$method == 0} { |
||||||
|
# No authentication required |
||||||
|
} elseif {$method == 1} { |
||||||
|
# GSS-API RFC 1961 |
||||||
|
# Not implemented |
||||||
|
throw {SOCKS AUTH UNKNOWN} "unsupported authentication method: $method" |
||||||
|
} elseif {$method == 2} { |
||||||
|
# Username/password RFC 1929 |
||||||
|
authenticate $sock |
||||||
|
} else { |
||||||
|
throw {SOCKS AUTH NOTACCEPTED} "no acceptable authentication methods" |
||||||
|
} |
||||||
|
|
||||||
|
# Connect |
||||||
|
set data [binary format ccc 5 1 0] |
||||||
|
set ip4 [split $host .] |
||||||
|
if {[llength $ip4] == 1 && [llength [set ip6 [split $host :]]] >= 3} { |
||||||
|
# IPv6 address |
||||||
|
set x [lsearch -exact $ip6 {}] |
||||||
|
if {$x >= 0} { |
||||||
|
set ip6 [lsearch -inline -exact -all -not $ip6 {}] |
||||||
|
set insert [lrepeat [expr {8 - [llength $ip6]}] 0] |
||||||
|
set ip6 [linsert $ip6 $x {*}$insert] |
||||||
|
} |
||||||
|
append data [binary format cS8S 4 $ip6 $port] |
||||||
|
} elseif {[llength $ip4] == 4 && [string is digit -strict [lindex $ip4 end]]} { |
||||||
|
# IPv4 address |
||||||
|
append data [binary format cc4S 1 $ip4 $port] |
||||||
|
} else { |
||||||
|
# hostname |
||||||
|
append data [binary format cca*S 3 [string length $host] $host $port] |
||||||
|
} |
||||||
|
binary scan [command $sock $data 4 10000] ccxc version reply atyp |
||||||
|
if {$reply != 0} { |
||||||
|
throw [list SOCKS CONNECT [format ERROR%02X $reply]] \ |
||||||
|
"socks connection failed with error code $reply" |
||||||
|
} |
||||||
|
switch $atyp { |
||||||
|
1 { |
||||||
|
binary scan [command $sock {} 6] c4S dstip dstport |
||||||
|
return [join $dstip .]:$dstport |
||||||
|
} |
||||||
|
3 { |
||||||
|
binary scan [command $sock {} 1] c len |
||||||
|
binary scan [command $sock {} [expr {$len + 2}]] a${len}S dsthost dstport |
||||||
|
return $dsthost:$dstport |
||||||
|
} |
||||||
|
4 { |
||||||
|
binary scan [command $sock {} 18] S8S dstip dstport |
||||||
|
return format {[%s]:$d} [join $dstip :] $dstport |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc www::socks::authenticate {sock} { |
||||||
|
variable username |
||||||
|
variable password |
||||||
|
set data [binary format cca*ca* 1 \ |
||||||
|
[string length $username] $username [string length $password] $password] |
||||||
|
binary scan [command $sock 2] cucu version status |
||||||
|
if {$version != 1} { |
||||||
|
throw {SOCKS AUTH RFC1929 VERSION} \ |
||||||
|
"unsupported username/password authentication version: $version" |
||||||
|
} |
||||||
|
if {$status != 0} { |
||||||
|
throw {SOCKS AUTH RFC1929 STATUS} \ |
||||||
|
"username/password authentication failed: $status" |
||||||
|
} |
||||||
|
} |
||||||
@ -0,0 +1,306 @@ |
|||||||
|
# Helper library for adding websocket support to www |
||||||
|
|
||||||
|
package require www 2.7 |
||||||
|
|
||||||
|
proc www::websocket {args} { |
||||||
|
set opts {-upgrade {WebSocket www::WebSocket}} |
||||||
|
set args [getopt arg $args { |
||||||
|
-timeout:milliseconds {dict set opts -timeout $arg} |
||||||
|
-auth:data {dict set opts -auth $arg} |
||||||
|
-digest:cred {dict set opts -digest $arg} |
||||||
|
-maxredir:cnt {dict set opts -maxredir $arg} |
||||||
|
}] |
||||||
|
if {[llength $args] < 1 || [llength $args] > 3} { |
||||||
|
throw {WWW WEBSOCKET ARGS} {wrong # args:\ |
||||||
|
should be "www::websocket url ?protocols? ?extensions?"} |
||||||
|
} |
||||||
|
lassign $args url protocols extensions |
||||||
|
try { |
||||||
|
set hdrs [WebSocket headers] |
||||||
|
if {[llength $protocols]} { |
||||||
|
lappend hdrs Sec-WebSocket-Protocol [join $protocols {, }] |
||||||
|
} |
||||||
|
if {[dict size $extensions]} { |
||||||
|
set ext [join [lmap name [dict keys $extensions] { |
||||||
|
set list [list $name] |
||||||
|
if {[dict exists $extensions $name parameters]} { |
||||||
|
lappend $list [dict get $extensions $name parameters] |
||||||
|
} |
||||||
|
join $list {; } |
||||||
|
}] {, }] |
||||||
|
lappend hdrs Sec-WebSocket-Extensions $ext |
||||||
|
} |
||||||
|
www get {*}$opts -headers $hdrs $url |
||||||
|
} on ok {result info} { |
||||||
|
if {[dict get $info status code] != 101} { |
||||||
|
# The only correct response for a successful websocket connection |
||||||
|
# is 101 Switching Protocols. Even 200 OK is not good. |
||||||
|
set code [dict get $info status code] |
||||||
|
set codegrp [string replace $code 1 2 XX] |
||||||
|
set reason [dict get $info status reason] |
||||||
|
dict set info -code 1 |
||||||
|
dict set info -errorcode [list WWW CODE $codegrp $code $reason] |
||||||
|
return -options [dict incr info -level] $result |
||||||
|
} |
||||||
|
set websock [dict get $info websocket] |
||||||
|
set hdrs [dict get $info headers] |
||||||
|
set protocol [if {[dict exists $hdrs sec-websocket-protocol]} { |
||||||
|
dict get $hdrs sec-websocket-protocol |
||||||
|
}] |
||||||
|
if {[dict exists $hdrs sec-websocket-extensions]} { |
||||||
|
set ext [header [$hdrs sec-websocket-extensions] *] |
||||||
|
set mixins [lmap value [lreverse $ext] { |
||||||
|
set list [lmap n [split $value {;}] {string trim $n}] |
||||||
|
set params [lassign $list name] |
||||||
|
dict set parameters $name $params |
||||||
|
dict get $extensions $name implementation |
||||||
|
}] |
||||||
|
oo::objdefine $websock \ |
||||||
|
mixin www::WSExtension {*}$mixins www::WebSocket |
||||||
|
# Inform the extensions of their parameters, if any |
||||||
|
$websock parameters $parameters |
||||||
|
} |
||||||
|
# Return the websocket object command (and the negotiated protocol) |
||||||
|
return protocol $protocol [dict get $info websocket] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
namespace ensemble configure www \ |
||||||
|
-subcommands [linsert [namespace ensemble configure www -subcommands] end websocket] |
||||||
|
|
||||||
|
oo::class create www::WebSocket { |
||||||
|
method Startup {headers} { |
||||||
|
my variable fd |
||||||
|
variable callback {} |
||||||
|
# This socket cannot be used for future connections |
||||||
|
release [self] |
||||||
|
fconfigure $fd -translation binary -buffering none -blocking 0 |
||||||
|
# Return the websocket object to the caller |
||||||
|
my Result websocket [self] |
||||||
|
my Return [my PopRequest] |
||||||
|
} |
||||||
|
|
||||||
|
method Read {} { |
||||||
|
my variable fd |
||||||
|
return [read $fd] |
||||||
|
} |
||||||
|
|
||||||
|
method Write {data} { |
||||||
|
my variable fd |
||||||
|
puts -nonewline $fd $data |
||||||
|
} |
||||||
|
|
||||||
|
method Handler {} { |
||||||
|
my variable fd callback |
||||||
|
fileevent $fd readable [list [info coroutine] data] |
||||||
|
set data "" |
||||||
|
set payload "" |
||||||
|
while {![eof $fd]} { |
||||||
|
yield |
||||||
|
append data [my Read] |
||||||
|
if {[binary scan $data B4Xcucu flags code len] != 3} continue |
||||||
|
if {$len < 126} { |
||||||
|
set pos 2 |
||||||
|
} elseif {$len == 126} { |
||||||
|
if {[binary scan $data x2Su len] != 1} continue |
||||||
|
set pos 4 |
||||||
|
} elseif {$len == 127} { |
||||||
|
if {[binary scan $data x2Wu len] != 1} continue |
||||||
|
set pos 10 |
||||||
|
} else { |
||||||
|
# Error: Messages from server to client should not be masked |
||||||
|
my close 1002 |
||||||
|
} |
||||||
|
if {[string length $data] < $pos + $len} continue |
||||||
|
set code [expr {$code & 0xf}] |
||||||
|
set payload [string range $data $pos [expr {$pos + $len - 1}]] |
||||||
|
set data [string range $data [expr {$pos + $len}] end] |
||||||
|
if {$code == 0} { |
||||||
|
append message $payload |
||||||
|
} else { |
||||||
|
set opcode $code |
||||||
|
# Control frames MAY be injected in the middle of a |
||||||
|
# fragmented message. (RFC6455 5.4) |
||||||
|
# Control frames are identified by opcodes where the most |
||||||
|
# significant bit of the opcode is 1. (RFC6455 5.5) |
||||||
|
if {$code < 8} {set message $payload} |
||||||
|
} |
||||||
|
if {![string index $flags 0]} continue |
||||||
|
if {$opcode < 8} { |
||||||
|
my Receive $opcode $message $flags |
||||||
|
} else { |
||||||
|
my Receive $opcode $payload $flags |
||||||
|
} |
||||||
|
} |
||||||
|
if {[dict exists $callback close]} { |
||||||
|
# 1006 is designated for use in applications expecting a status |
||||||
|
# code to indicate that the connection was closed abnormally, |
||||||
|
# e.g., without sending or receiving a Close control frame. |
||||||
|
{*}[dict get $callback close] close 1006 "eof on connection" |
||||||
|
} |
||||||
|
my destroy |
||||||
|
} |
||||||
|
|
||||||
|
# Methods that can be overridden by extensions |
||||||
|
|
||||||
|
method Read {} { |
||||||
|
my variable fd |
||||||
|
return [read $fd] |
||||||
|
} |
||||||
|
|
||||||
|
method Write {data} { |
||||||
|
my variable fd |
||||||
|
puts -nonewline $fd $data |
||||||
|
} |
||||||
|
|
||||||
|
method Receive {opcode data flags} { |
||||||
|
my variable callback |
||||||
|
switch $opcode { |
||||||
|
1 { |
||||||
|
if {[dict exists $callback text]} { |
||||||
|
set str [encoding convertfrom utf-8 $data] |
||||||
|
{*}[dict get $callback text] text $str |
||||||
|
} else { |
||||||
|
my close 1003 |
||||||
|
} |
||||||
|
} |
||||||
|
2 { |
||||||
|
if {[dict exists $callback binary]} { |
||||||
|
{*}[dict get $callback binary] binary $data |
||||||
|
} else { |
||||||
|
my close 1003 |
||||||
|
} |
||||||
|
} |
||||||
|
8 { |
||||||
|
if {[dict exists $callback close]} { |
||||||
|
if {[binary scan $data Sua* code reason] != 2} { |
||||||
|
set code 1005 |
||||||
|
set reason "" |
||||||
|
} |
||||||
|
{*}[dict get $callback close] close $code $reason |
||||||
|
set callback {} |
||||||
|
} |
||||||
|
} |
||||||
|
9 { |
||||||
|
if {[dict exists $callback ping]} { |
||||||
|
{*}[dict get $callback ping] ping $data |
||||||
|
} else { |
||||||
|
my pong $data |
||||||
|
} |
||||||
|
} |
||||||
|
10 { |
||||||
|
if {[dict exists $callback pong]} { |
||||||
|
{*}[dict get $callback pong] pong $data |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
method Transmit {opcode data {flags 1}} { |
||||||
|
binary scan $data cu* bytes |
||||||
|
# The requirement to use a strong source of entropy makes no sense |
||||||
|
# So we'll just use Tcl's simple linear congruential generator |
||||||
|
set key [expr {int(rand() * 0x100000000)}] |
||||||
|
binary scan [binary format I $key] cu* mask |
||||||
|
set length [llength $bytes] |
||||||
|
# Apply the mask |
||||||
|
set i 0 |
||||||
|
set bytes [lmap n $bytes { |
||||||
|
set m [lindex $mask [expr {$i & 3}]] |
||||||
|
incr i |
||||||
|
expr {$n ^ $m} |
||||||
|
}] |
||||||
|
set type \ |
||||||
|
[expr {$opcode | "0b[string reverse [format %04s $flags]]0000"}] |
||||||
|
set data [binary format c $type] |
||||||
|
if {$length < 126} { |
||||||
|
append data [binary format c [expr {$length | 0x80}]] |
||||||
|
} elseif {$length < 65536} { |
||||||
|
append data [binary format cS [expr {126 | 0x80}] $length] |
||||||
|
} else { |
||||||
|
append data [binary format cW [expr {127 | 0x80}] $length] |
||||||
|
} |
||||||
|
append data [binary format c*c* $mask $bytes] |
||||||
|
my Write $data |
||||||
|
} |
||||||
|
|
||||||
|
# Public methods |
||||||
|
|
||||||
|
method callback {types prefix} { |
||||||
|
variable callback |
||||||
|
set running [dict size $callback] |
||||||
|
if {$prefix ne ""} { |
||||||
|
foreach type $types { |
||||||
|
dict set callback $type $prefix |
||||||
|
} |
||||||
|
} elseif {[llength $types]} { |
||||||
|
set callback [dict remove $callback {*}$types] |
||||||
|
} else { |
||||||
|
set callback {} |
||||||
|
} |
||||||
|
if {[dict size $callback]} { |
||||||
|
if {!$running} {coroutine websockcoro my Handler} |
||||||
|
} else { |
||||||
|
if {$running} {rename websockcoro ""} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
method text {str} { |
||||||
|
my Transmit 1 [encoding convertto utf-8 $str] |
||||||
|
} |
||||||
|
|
||||||
|
method binary {data} { |
||||||
|
my Transmit 2 $data |
||||||
|
} |
||||||
|
|
||||||
|
method close {{code 1005} {reason ""}} { |
||||||
|
# 1005 is designated for use in applications expecting a status code |
||||||
|
# to indicate that no status code was actually present. |
||||||
|
set payload [if {$code != 1005} { |
||||||
|
binary format Sa* $code [encoding convertto utf-8 $reason] |
||||||
|
}] |
||||||
|
my Transmit 8 $payload |
||||||
|
# The client SHOULD wait for the server to close the connection but |
||||||
|
# MAY close the connection at any time after sending and receiving |
||||||
|
# a Close message, e.g., if it has not received a TCP Close from |
||||||
|
# the server in a reasonable time period. |
||||||
|
# my destroy |
||||||
|
} |
||||||
|
|
||||||
|
method ping {{data ""}} { |
||||||
|
my Transmit 9 $data |
||||||
|
} |
||||||
|
|
||||||
|
method pong {{data ""}} { |
||||||
|
my Transmit 10 $data |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
oo::class create www::WSExtension { |
||||||
|
method parameters {parameters} { |
||||||
|
dict for {mixin params} $parameters { |
||||||
|
nextto $mixin $params |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
oo::objdefine www::WebSocket { |
||||||
|
method key {} { |
||||||
|
# Generate a websocket key containing base64-encoded random bytes |
||||||
|
# This key is only intended to prevent a caching proxy from |
||||||
|
# re-sending a previous WebSocket conversation, and does not |
||||||
|
# provide any authentication, privacy or integrity. |
||||||
|
# It is therefor not necessary to check the returned hash. |
||||||
|
for {set i 0} {$i < 12} {incr i} { |
||||||
|
lappend bytes [expr {int(rand() * 256)}] |
||||||
|
} |
||||||
|
return [binary encode base64 [binary format c* $bytes]] |
||||||
|
} |
||||||
|
|
||||||
|
method headers {} { |
||||||
|
return [list Sec-WebSocket-Key [my key] Sec-WebSocket-Version 13] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
www register ws 80 |
||||||
|
www register wss 443 www::encrypt 1 |
||||||
@ -1,3 +1 @@ |
|||||||
|
package ifneeded app-punk 1.0 [list source [file join $dir repl.tcl]] |
||||||
package ifneeded app-punk 1.0 [list source [file join $dir repl.tcl]] |
|
||||||
|
|
||||||
@ -0,0 +1,2 @@ |
|||||||
|
package ifneeded app-punkshell 1.0 [list source [file join $dir punkshell.tcl]] |
||||||
|
|
||||||
@ -0,0 +1,296 @@ |
|||||||
|
package provide app-punkshell 1.0 |
||||||
|
|
||||||
|
package require Thread |
||||||
|
package require punk::args |
||||||
|
package require shellfilter |
||||||
|
package require punk::ansi |
||||||
|
package require punk::packagepreference |
||||||
|
punk::packagepreference::install |
||||||
|
|
||||||
|
namespace eval punkshell { |
||||||
|
variable chanstack_stderr_redir |
||||||
|
variable chanstack_stdout_redir |
||||||
|
proc clock_sec {} { |
||||||
|
return [expr {[clock millis]/1000.0}] |
||||||
|
} |
||||||
|
set do_log 0 |
||||||
|
if {$do_log} { |
||||||
|
set debug_syslog_server 127.0.0.1:514 |
||||||
|
#set debug_syslog_server 172.16.6.42:51500 |
||||||
|
set error_syslog_server 127.0.0.1:514 |
||||||
|
set data_syslog_server 127.0.0.1:514 |
||||||
|
} else { |
||||||
|
set debug_syslog_server "" |
||||||
|
set error_syslog_server "" |
||||||
|
set data_syslog_server "" |
||||||
|
} |
||||||
|
#------------------------------------------------------------------------- |
||||||
|
##don't write to stdout/stderr before you've redirected them to a log using shellfilter functions |
||||||
|
## puts to stdout/stderr will comingle with command's output if performed before the channel stacks are configured. |
||||||
|
|
||||||
|
#chan configure stdin -buffering line |
||||||
|
#chan configure stdout -buffering none |
||||||
|
#chan configure stderr -buffering none |
||||||
|
|
||||||
|
#redir on the shellfilter stack with no log or syslog specified acts to suppress output of stdout & stderr. |
||||||
|
#todo - fix shellfilter code to make this noop more efficient (avoid creating corresponding logging thread and filter?) |
||||||
|
#JMN |
||||||
|
#set redirconfig {-settings {-syslog 127.0.0.1:514 -file ""}} |
||||||
|
set redirconfig {} |
||||||
|
#lassign [shellfilter::redir_output_to_log "SUPPRESS" {*}$redirconfig] chanstack_stdout_redir chanstack_stderr_redir |
||||||
|
#shellfilter::log::write $punkshell_status_log "shellfilter::redir_output_to_log SUPPRESS DONE [clock_sec]" |
||||||
|
|
||||||
|
set stdout_log "" |
||||||
|
set stderr_log "" |
||||||
|
#set stdout_log [file normalize ~]/punkshell-stdout.txt |
||||||
|
#set stderr_log [file normalize ~]/punkshell-stderr.txt |
||||||
|
set stdout_log "[pwd]/punkshell_out.log" |
||||||
|
set stderr_log "[pwd]/punkshell_err.log" |
||||||
|
|
||||||
|
set errdeviceinfo [shellfilter::stack::new punkshellerr -settings [list -tag "punkshellerr" -buffering none -raw 1 -syslog $data_syslog_server -file $stderr_log]] |
||||||
|
set outdeviceinfo [shellfilter::stack::new punkshellout -settings [list -tag "punkshellout" -buffering none -raw 1 -syslog $data_syslog_server -file $stdout_log]] |
||||||
|
#set commandlog [dict get $outdeviceinfo localchan] |
||||||
|
#puts $commandlog "HELLO $commandlog" |
||||||
|
#flush $commandlog |
||||||
|
|
||||||
|
proc do_script {scriptname args} { |
||||||
|
#ideally we don't want to launch an external process to run the script |
||||||
|
#variable punkshell_status_log |
||||||
|
#shellfilter::log::write $punkshell_status_log "do_script got scriptname:'$scriptname' replwhen:$replwhen args:'$args'" |
||||||
|
set exepath [file dirname [file join [info nameofexecutable] __dummy__]] |
||||||
|
set exedir [file dirname $exepath] |
||||||
|
set scriptpath [file normalize $scriptname] |
||||||
|
if {![file exists $scriptpath]} { |
||||||
|
puts stderr "Failed to find script: '$scriptpath'" |
||||||
|
error "bad scriptpath '$scriptpath'" |
||||||
|
} |
||||||
|
|
||||||
|
set script [string map [list %a% $args %s% $scriptpath] { |
||||||
|
set normscript %s% |
||||||
|
#save values |
||||||
|
set prevscript [info script] |
||||||
|
set prevglobal [dict create] |
||||||
|
foreach g [list ::argv ::argc ::argv0] { |
||||||
|
if {[info exists $g]} { |
||||||
|
dict set prevglobal $g [set $g] |
||||||
|
} |
||||||
|
} |
||||||
|
#setup and run |
||||||
|
set ::argv [list %a%] |
||||||
|
set ::argc [llength $::argv] |
||||||
|
set ::argv0 $normscript |
||||||
|
info script $normscript |
||||||
|
source $normscript |
||||||
|
#restore values |
||||||
|
info script $prevscript |
||||||
|
dict with prevglobal {} |
||||||
|
}] |
||||||
|
|
||||||
|
dict set params -tclscript 1 ;#don't give callback a chance to omit/break this |
||||||
|
dict set params -teehandle punkshell |
||||||
|
#dict set params -teehandle punksh |
||||||
|
dict set params -inbuffering none |
||||||
|
dict set params -outbuffering none |
||||||
|
dict set params -readprocesstranslation crlf |
||||||
|
dict set params -outtranslation lf |
||||||
|
|
||||||
|
set id_err [shellfilter::stack::add stderr ansiwrap -action sink-locked -settings {-colour {red bold}}] |
||||||
|
|
||||||
|
set exitinfo [shellfilter::run $script {*}$params] |
||||||
|
|
||||||
|
shellfilter::stack::remove stderr $id_err |
||||||
|
|
||||||
|
if {[dict exists $exitinfo errorInfo]} { |
||||||
|
#strip out the irrelevant info from the errorInfo - we don't want info beyond 'invoked from within' as this is just plumbing related to the script sourcing |
||||||
|
set stacktrace [string map [list \r\n \n] [dict get $exitinfo errorInfo]] |
||||||
|
set output "" |
||||||
|
set tracelines [split $stacktrace \n] |
||||||
|
foreach ln $tracelines { |
||||||
|
if {[string match "*invoked from within*" $ln]} { |
||||||
|
break |
||||||
|
} |
||||||
|
append output $ln \n |
||||||
|
} |
||||||
|
set output [string trimright $output \n] |
||||||
|
dict set exitinfo errorInfo $output |
||||||
|
} |
||||||
|
return $exitinfo |
||||||
|
} |
||||||
|
|
||||||
|
proc do_tclkit {kitname replwhen args} { |
||||||
|
|
||||||
|
set script [string map [list %a% $args %k% $kitname] { |
||||||
|
#::tcl::tm::add %m% |
||||||
|
set kit %k% |
||||||
|
set kitpath [file normalize $kit] |
||||||
|
set kitmount $kitpath.0 |
||||||
|
|
||||||
|
#save values |
||||||
|
set prevscript [info script] |
||||||
|
set prevglobal [dict create] |
||||||
|
foreach g [list ::argv ::argc ::argv0] { |
||||||
|
if {[info exists $g]} { |
||||||
|
dict set prevglobal $g [set $g] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#setup and run |
||||||
|
set ::argv [list %a%] |
||||||
|
set ::argc [llength $::argv] |
||||||
|
|
||||||
|
set ::argv0 $kitmount |
||||||
|
#puts stderr "setting 'info script' $kitmount/main.tcl" |
||||||
|
info script $kitmount/main.tcl |
||||||
|
#info script dir must match argv0 for kit main.tcl to return 'starkit' from 'starkit::startup' |
||||||
|
|
||||||
|
if {![catch { |
||||||
|
package require vfs |
||||||
|
package require vfs::mk4 |
||||||
|
} errMsg]} { |
||||||
|
|
||||||
|
vfs::mk4::Mount $kitpath $kitmount |
||||||
|
lappend ::auto_path $kitmount/lib |
||||||
|
if {[file exists "$kitmount/modules"]} { |
||||||
|
tcl::tm::add "$kitmount/modules" |
||||||
|
} |
||||||
|
|
||||||
|
#puts stderr "sourcing $kitmount/main.tcl" |
||||||
|
#puts stderr "$kitmount/main.tcl exists: [file exists $kitmount/main.tcl]" |
||||||
|
#puts stderr "argv : $::argv" |
||||||
|
#puts stderr "argv0: $::argv0" |
||||||
|
#puts stderr "autopath: $::auto_path" |
||||||
|
#puts stdout "starkit::startup [starkit::startup]" |
||||||
|
|
||||||
|
#usually main.tcl will just be something like: package require app-XXX |
||||||
|
#it will usually do nothing if starkit::startup returned 'sourced' |
||||||
|
|
||||||
|
source $kitmount/main.tcl |
||||||
|
|
||||||
|
} else { |
||||||
|
puts stderr "Unable to load vfs::mk4 for tclkit mounting" |
||||||
|
} |
||||||
|
#restore values |
||||||
|
info script $prevscript |
||||||
|
dict with prevglobal {} |
||||||
|
}] |
||||||
|
|
||||||
|
set repl_lines "" |
||||||
|
append repl_lines {package require punk::repl} \n |
||||||
|
append repl_lines {repl::init -safe 0} \n |
||||||
|
append repl_lines {repl::start stdin} \n |
||||||
|
|
||||||
|
#test |
||||||
|
#set replwhen "repl_last" |
||||||
|
|
||||||
|
if {$replwhen eq "repl_first"} { |
||||||
|
#we need to cooperate with the repl to get the script to run on exit |
||||||
|
namespace eval ::repl {} |
||||||
|
set ::repl::post_script $script |
||||||
|
set script "$repl_lines" |
||||||
|
} elseif {$replwhen eq "repl_last"} { |
||||||
|
append script $repl_lines |
||||||
|
} else { |
||||||
|
#just the script |
||||||
|
} |
||||||
|
|
||||||
|
dict set params -tclscript 1 ;#don't give callback a chance to omit/break this |
||||||
|
dict set params -teehandle punkshell |
||||||
|
dict set params -inbuffering none |
||||||
|
dict set params -outbuffering none |
||||||
|
dict set params -readprocesstranslation crlf |
||||||
|
dict set params -outtranslation lf |
||||||
|
|
||||||
|
set id_err [shellfilter::stack::add stderr ansiwrap -action sink-locked -settings {-colour {red bold}}] |
||||||
|
|
||||||
|
set exitinfo [shellfilter::run $script {*}$params] |
||||||
|
|
||||||
|
shellfilter::stack::remove stderr $id_err |
||||||
|
|
||||||
|
if {[dict exists $exitinfo errorInfo]} { |
||||||
|
#strip out the irrelevant info from the errorInfo - we don't want info beyond 'invoked from within' as this is just plumbing related to the script sourcing |
||||||
|
set stacktrace [string map [list \r\n \n] [dict get $exitinfo errorInfo]] |
||||||
|
set output "" |
||||||
|
set tracelines [split $stacktrace \n] |
||||||
|
foreach ln $tracelines { |
||||||
|
if {[string match "*invoked from within*" $ln]} { |
||||||
|
break |
||||||
|
} |
||||||
|
append output $ln \n |
||||||
|
} |
||||||
|
set output [string trimright $output \n] |
||||||
|
dict set exitinfo errorInfo $output |
||||||
|
} |
||||||
|
return $exitinfo |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
punk::args::define { |
||||||
|
@id -id ::punkshell |
||||||
|
@cmd -name punkshell |
||||||
|
@leaders -min 0 -max 0 |
||||||
|
@opts |
||||||
|
-debug -type none |
||||||
|
@values -min 1 -max -1 |
||||||
|
script_or_kit -type string |
||||||
|
arg -type any -optional 1 -multiple 1 |
||||||
|
} |
||||||
|
set argd [punk::args::parse $::argv withid ::punkshell] |
||||||
|
lassign [dict values $argd] leaders opts values received |
||||||
|
|
||||||
|
set script_or_kit [dict get $values script_or_kit] |
||||||
|
if {[dict exists $received arg]} { |
||||||
|
set arglist [dict get $values arg] |
||||||
|
} else { |
||||||
|
set arglist [list] |
||||||
|
} |
||||||
|
|
||||||
|
set exitinfo [dict create] |
||||||
|
switch -glob -nocase -- $script_or_kit { |
||||||
|
lib:* { |
||||||
|
#scriptlib |
||||||
|
puts stderr "lib:* todo" |
||||||
|
} |
||||||
|
*.tcl { |
||||||
|
set exitinfo [punkshell::do_script $script_or_kit {*}$arglist] |
||||||
|
} |
||||||
|
*.kit { |
||||||
|
set exitinfo [punkshell::do_tclkit $script_or_kit "no_repl" {*}$arglist] |
||||||
|
} |
||||||
|
default { |
||||||
|
puts stderr "unrecognised script extension" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
catch { |
||||||
|
shellfilter::stack::remove stderr $chanstack_stderr_redir |
||||||
|
shellfilter::stack::remove stdout $chanstack_stdout_redir |
||||||
|
} |
||||||
|
shellfilter::stack::delete punkshellout |
||||||
|
shellfilter::stack::delete punkshellerr |
||||||
|
set free_info [shellthread::manager::shutdown_free_threads] |
||||||
|
foreach tid [thread::names] { |
||||||
|
thread::release $tid |
||||||
|
} |
||||||
|
|
||||||
|
if {[dict size $exitinfo] == 0} { |
||||||
|
puts stderr "No result" |
||||||
|
exit 2 |
||||||
|
} |
||||||
|
|
||||||
|
if {[dict exists $exitinfo errorInfo]} { |
||||||
|
set einf [dict get $exitinfo errorInfo] |
||||||
|
puts stderr "errorCode: [dict get $exitinfo errorCode]" |
||||||
|
if {[catch { |
||||||
|
punk::ansi::ansiwrap yellow bold $einf |
||||||
|
} msg]} { |
||||||
|
set msg $einf |
||||||
|
} |
||||||
|
puts stderr $msg |
||||||
|
flush stderr |
||||||
|
exit 1 |
||||||
|
} else { |
||||||
|
puts -nonewline stdout [dict get $exitinfo result] |
||||||
|
exit 0 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
@ -1,3 +1,2 @@ |
|||||||
|
package ifneeded app-shellspy 1.0 [list source [file join $dir shellspy.tcl]] |
||||||
package ifneeded app-shellspy 1.0 [list source [file join $dir shellspy.tcl]] |
|
||||||
|
|
||||||
|
|||||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,83 @@ |
|||||||
|
namespace eval www::digest { |
||||||
|
variable noncecount |
||||||
|
} |
||||||
|
|
||||||
|
# HTTP/1.1 401 Unauthorized |
||||||
|
# WWW-Authenticate: Digest |
||||||
|
# realm="testrealm@host.com", |
||||||
|
# qop="auth,auth-int", |
||||||
|
# nonce="dcd98b7102dd2f0e8b11d0f600bfb0c093", |
||||||
|
# opaque="5ccc069c403ebaf9f0171e9517f40e41" |
||||||
|
|
||||||
|
proc www::digest::md5 {str} { |
||||||
|
package require md5 |
||||||
|
return [string tolower [::md5::md5 -hex $str]] |
||||||
|
} |
||||||
|
|
||||||
|
proc www::digest::sha256 {str} { |
||||||
|
package require sha256 |
||||||
|
return [::sha2::sha256 -hex $str] |
||||||
|
} |
||||||
|
|
||||||
|
proc www::digest::digest {challenge username password method uri {body ""}} { |
||||||
|
variable noncecount |
||||||
|
if {[dict exists $challenge algorithm]} { |
||||||
|
set algorithm [dict get $challenge algorithm] |
||||||
|
} else { |
||||||
|
set algorithm MD5 |
||||||
|
} |
||||||
|
switch $algorithm { |
||||||
|
MD5 - MD5-sess {set hash md5} |
||||||
|
SHA-256 - SHA-256-sess {set hash sha256} |
||||||
|
default { |
||||||
|
error "unsupported algorithm: $algorithm" |
||||||
|
} |
||||||
|
} |
||||||
|
set interlude [dict get $challenge nonce] |
||||||
|
set keys {username realm nonce uri response} |
||||||
|
if {[dict exists $challenge qop]} { |
||||||
|
set qops [split [dict get $challenge qop] ,] |
||||||
|
if {"auth" in $qops} { |
||||||
|
set qop auth |
||||||
|
} elseif {"auth-int" in $qops} { |
||||||
|
set qop auth-int |
||||||
|
} else { |
||||||
|
error "unsupported qop: [join $qops {, }]" |
||||||
|
} |
||||||
|
set nonce [dict get $challenge nonce] |
||||||
|
# Generate a random cnonce |
||||||
|
set cnonce [format %08x [expr {int(rand() * 0x100000000)}]] |
||||||
|
set nc [format %08X [incr noncecount($nonce)]] |
||||||
|
append interlude : $nc : $cnonce : $qop |
||||||
|
lappend keys qop nc cnonce |
||||||
|
if {[dict exists $challenge algorithm]} {lappend keys algorithm} |
||||||
|
if {[dict exists $challenge opaque]} {lappend keys opaque} |
||||||
|
} else { |
||||||
|
set qop auth |
||||||
|
} |
||||||
|
foreach n $keys { |
||||||
|
dict set rc $n \ |
||||||
|
[if {[dict exists $challenge $n]} {dict get $challenge $n}] |
||||||
|
} |
||||||
|
dict set rc username $username |
||||||
|
dict set rc uri $uri |
||||||
|
if {[dict exists $rc qop]} { |
||||||
|
dict set rc qop $qop |
||||||
|
dict set rc cnonce $cnonce |
||||||
|
dict set rc nc $nc |
||||||
|
} |
||||||
|
set A1 [$hash $username:[dict get $challenge realm]:$password] |
||||||
|
if {[string match {*-sess} $algorithm]} {append A1 : $nonce : $cnonce} |
||||||
|
set A2 [$hash $method:$uri] |
||||||
|
if {$qop eq "auth-int"} {append A2 : $body} |
||||||
|
dict set rc response [$hash $A1:$interlude:$A2] |
||||||
|
set authlist {} |
||||||
|
dict for {key val} $rc { |
||||||
|
if {$key ni {qop nc}} { |
||||||
|
lappend authlist [format {%s="%s"} $key $val] |
||||||
|
} else { |
||||||
|
lappend authlist $key=$val |
||||||
|
} |
||||||
|
} |
||||||
|
return "Digest [join $authlist ,]" |
||||||
|
} |
||||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,13 @@ |
|||||||
|
Copyright (c) 2021, Schelte Bron |
||||||
|
|
||||||
|
Permission to use, copy, modify, and/or distribute this software for any |
||||||
|
purpose with or without fee is hereby granted, provided that the above |
||||||
|
copyright notice and this permission notice appear in all copies. |
||||||
|
|
||||||
|
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES |
||||||
|
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF |
||||||
|
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR |
||||||
|
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES |
||||||
|
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN |
||||||
|
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF |
||||||
|
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. |
||||||
@ -0,0 +1,826 @@ |
|||||||
|
#!/usr/bin/tclsh |
||||||
|
|
||||||
|
# This library can be used together with www 2.0+ to use a proxy based on a |
||||||
|
# Proxy Auto Configure (pac) file: |
||||||
|
# package require proxypac |
||||||
|
# www configure -proxyfilter {proxypac <pacurl>} |
||||||
|
# Example: http://pac.webdefence.global.blackspider.com:8082/proxy.pac |
||||||
|
|
||||||
|
package require www |
||||||
|
|
||||||
|
namespace eval www::proxypac { |
||||||
|
variable oldpac {} |
||||||
|
namespace export proxypac |
||||||
|
|
||||||
|
proc proxypac {pacurl url host} { |
||||||
|
variable oldpac |
||||||
|
if {[string equal -length [string length $url] $pacurl $url]} { |
||||||
|
# The pac url itself must be reachable directly |
||||||
|
return DIRECT |
||||||
|
} |
||||||
|
try { |
||||||
|
if {$pacurl ne $oldpac} { |
||||||
|
set data [www get $pacurl] |
||||||
|
set oldpac $pacurl |
||||||
|
parse $data |
||||||
|
} |
||||||
|
set proxies [execute FindProxyForURL $url $host] |
||||||
|
return [lmap proxy [split $proxies {;}] { |
||||||
|
if {[string is space $proxy]} continue |
||||||
|
string trim $proxy |
||||||
|
}] |
||||||
|
} on error {err opts} { |
||||||
|
www::log "Failed to auto-configure proxy: $err" |
||||||
|
# In case of any error, use a direct connection |
||||||
|
return [list DIRECT] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc validip {ipchars} { |
||||||
|
set valid [lmap n [split $ipchars .] { |
||||||
|
expr {[string is digit -strict $n] && $n < 256} |
||||||
|
}] |
||||||
|
return [expr {[join $valid ""] eq "1111"}] |
||||||
|
} |
||||||
|
|
||||||
|
proc resolve {host} { |
||||||
|
if {[catch {package require dns}]} return |
||||||
|
set tok [dns::resolve $host] |
||||||
|
dns::wait $tok |
||||||
|
set result [lindex [dns::address $tok] 0] |
||||||
|
dns::cleanup $tok |
||||||
|
return $result |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {[catch {package require duktape::oo 0.11}]} { |
||||||
|
proc www::proxypac::parse {data} { |
||||||
|
set code [convert [string map [list \r\n \n] $data]] |
||||||
|
proxypacrun eval $code |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::execute {args} { |
||||||
|
proxypacrun eval $args |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::convert {data} { |
||||||
|
variable tokenlist |
||||||
|
set p 0 |
||||||
|
set re {/[/=*]?|[*]/|[+][+=]?|[*][*]?=?|-=?|<[<=]?|>>>|>[>=]?|%=?|&&?|[|][|]?|!=?=?|={1,3}|[][(),.{}"';\n?~^]|[ \t]+} |
||||||
|
|
||||||
|
set tokenlist [lmap n [regexp -all -indices -inline $re $data] { |
||||||
|
lassign $n x1 x2 |
||||||
|
set str [string range $data $p [expr {$x1 - 1}]] |
||||||
|
set sep [string range $data $x1 $x2] |
||||||
|
set p [expr {$x2 + 1}] |
||||||
|
list $str $sep |
||||||
|
}] |
||||||
|
|
||||||
|
set code [lmap line [block] { |
||||||
|
set tabs [string length [lindex [regexp -inline ^\t* $line] 0]] |
||||||
|
set indent [string repeat \t [expr {$tabs / 2}]] |
||||||
|
append indent [string repeat " " [expr {$tabs % 2}]] |
||||||
|
regsub ^\t* $line $indent |
||||||
|
}] |
||||||
|
return [join $code \n] |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::peek {{trim 1}} { |
||||||
|
variable tokenlist |
||||||
|
variable count |
||||||
|
if {[incr count] > 20} { |
||||||
|
fail "endless loop" |
||||||
|
} |
||||||
|
if {[llength $tokenlist] == 0} return |
||||||
|
lassign [lindex $tokenlist 0] str tag |
||||||
|
if {![string is space $tag] || !$trim} { |
||||||
|
return [lindex $tokenlist 0] |
||||||
|
} elseif {$str ne ""} { |
||||||
|
if {[lindex $tokenlist 1 0] ne ""} { |
||||||
|
return [lindex $tokenlist 0] |
||||||
|
} |
||||||
|
lset tokenlist 1 0 $str |
||||||
|
} |
||||||
|
set tokenlist [lrange $tokenlist 1 end] |
||||||
|
tailcall peek |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::poke {str tag} { |
||||||
|
variable tokenlist |
||||||
|
lset tokenlist 0 [list $str $tag] |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::next {{trim 1}} { |
||||||
|
variable tokenlist |
||||||
|
variable count 0 |
||||||
|
set tokenlist [lrange $tokenlist 1 end] |
||||||
|
tailcall peek $trim |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::end {} { |
||||||
|
variable tokenlist |
||||||
|
return [expr {[llength $tokenlist] == 0}] |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::code {} { |
||||||
|
lassign [peek] str tag |
||||||
|
if {$str eq "" && $tag eq "\{"} { |
||||||
|
next |
||||||
|
lappend rc {*}[block] |
||||||
|
lassign [peek] str tag |
||||||
|
if {$tag ne "\}"} { |
||||||
|
fail "expected \}" |
||||||
|
} |
||||||
|
next |
||||||
|
} else { |
||||||
|
lappend rc {*}[statement] |
||||||
|
} |
||||||
|
return $rc |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::block {} { |
||||||
|
while {![end]} { |
||||||
|
lassign [peek] str tag |
||||||
|
switch $str { |
||||||
|
{} { |
||||||
|
if {$tag in {// /*}} { |
||||||
|
comment |
||||||
|
} |
||||||
|
} |
||||||
|
default { |
||||||
|
set block [statement] |
||||||
|
lappend rc {*}$block |
||||||
|
} |
||||||
|
} |
||||||
|
lassign [peek] str tag |
||||||
|
if {$tag eq "\}"} { |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
return $rc |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::comment {} { |
||||||
|
variable tokenlist |
||||||
|
variable count 0 |
||||||
|
lassign [peek] str tag |
||||||
|
if {$tag eq "//"} { |
||||||
|
set end \n |
||||||
|
} else { |
||||||
|
set end "*/" |
||||||
|
} |
||||||
|
set nl [lsearch -exact -index 1 $tokenlist $end] |
||||||
|
if {$nl < 0} {set nl end} |
||||||
|
set tokenlist [lreplace $tokenlist 0 $nl] |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::statement {} { |
||||||
|
lassign [peek] str tag |
||||||
|
switch $str { |
||||||
|
function { |
||||||
|
if {![string is space $tag]} { |
||||||
|
fail "expected white space" |
||||||
|
} |
||||||
|
set rc [function] |
||||||
|
} |
||||||
|
if { |
||||||
|
set rc [ifelse] |
||||||
|
} |
||||||
|
return { |
||||||
|
set rc [jsreturn] |
||||||
|
} |
||||||
|
var { |
||||||
|
if {![string is space $tag]} { |
||||||
|
fail "expected white space" |
||||||
|
} |
||||||
|
set rc [var] |
||||||
|
} |
||||||
|
for { |
||||||
|
if {$tag ne "("} { |
||||||
|
fail "expected (" |
||||||
|
} |
||||||
|
set rc [forloop] |
||||||
|
} |
||||||
|
default { |
||||||
|
if {![regexp {^[\w$]+$} $str]} { |
||||||
|
fail "unsupported JavaScript command: $str" |
||||||
|
} elseif {$tag eq "="} { |
||||||
|
set rc [assignment $str] |
||||||
|
} elseif {$tag eq "("} { |
||||||
|
set rc [list [funccall $str]] |
||||||
|
} else { |
||||||
|
fail "unsupported JavaScript command: $str (tag = $tag)" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
lassign [peek] str tag |
||||||
|
if {$tag eq ";"} { |
||||||
|
lassign [next] str tag |
||||||
|
} |
||||||
|
return $rc |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::jsreturn {} { |
||||||
|
lassign [peek] str tag |
||||||
|
if {$str eq "" && $tag in {; \n}} { |
||||||
|
return [list return] |
||||||
|
} else { |
||||||
|
poke "" $tag |
||||||
|
return [list "return [expression]"] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::expression {{top 1}} { |
||||||
|
lassign [peek] str tag |
||||||
|
set rc {} |
||||||
|
set unary {} |
||||||
|
set strcat 0 |
||||||
|
while 1 { |
||||||
|
if {$str eq "" && $tag in {+ - ! ~}} { |
||||||
|
append unary $tag |
||||||
|
lassign [next] str tag |
||||||
|
continue |
||||||
|
} |
||||||
|
switch -regexp $str { |
||||||
|
{^$} { |
||||||
|
set op [lindex $rc end] |
||||||
|
if {$op eq "=="} { |
||||||
|
lset rc end eq |
||||||
|
} elseif {$op eq "!="} { |
||||||
|
lset rc end ne |
||||||
|
} |
||||||
|
if {$tag in {\" '}} { |
||||||
|
set quote $tag |
||||||
|
set strvar "" |
||||||
|
while 1 { |
||||||
|
lassign [next 0] str tag |
||||||
|
if {$tag eq $quote} { |
||||||
|
append strvar $str |
||||||
|
break |
||||||
|
} else { |
||||||
|
append strvar $str $tag |
||||||
|
} |
||||||
|
} |
||||||
|
lappend rc [format {{%s}} $strvar] |
||||||
|
lassign [next] str tag |
||||||
|
if {$str ne ""} { |
||||||
|
fail "invalid expression" |
||||||
|
} |
||||||
|
set strcat 1 |
||||||
|
} elseif {$tag in "("} { |
||||||
|
next |
||||||
|
lappend rc [format (%s) [expression 0]] |
||||||
|
lassign [peek] str tag |
||||||
|
if {$tag ne ")"} { |
||||||
|
fail "expected )" |
||||||
|
} |
||||||
|
next |
||||||
|
} |
||||||
|
} |
||||||
|
{^[\w$]+$} { |
||||||
|
if {$tag eq "("} { |
||||||
|
lappend rc [format {[%s]} [funccall $str]] |
||||||
|
} elseif {$tag eq "\["} { |
||||||
|
lappend rc [arrayelem $str] |
||||||
|
} elseif {[string is double $str]} { |
||||||
|
lappend rc $str |
||||||
|
} elseif {[string tolower $str] in {true false}} { |
||||||
|
lappend rc $str |
||||||
|
} else { |
||||||
|
lappend rc [format {$%s} $str] |
||||||
|
} |
||||||
|
} |
||||||
|
default { |
||||||
|
fail "expected expression" |
||||||
|
} |
||||||
|
} |
||||||
|
lassign [peek] str tag |
||||||
|
while {$tag eq "."} { |
||||||
|
lset rc end [method [lindex $rc end]] |
||||||
|
lassign [peek] str tag |
||||||
|
} |
||||||
|
if {$unary ne ""} { |
||||||
|
lset rc end $unary[lindex $rc end] |
||||||
|
set unary {} |
||||||
|
} |
||||||
|
switch $tag { |
||||||
|
+ - - - * - ** - / - % - |
||||||
|
== - != - > - < - >= - <= - ? - : - |
||||||
|
& - | - ^ - << - >> - && - || { |
||||||
|
lappend rc $tag |
||||||
|
} |
||||||
|
=== { |
||||||
|
lappend rc == |
||||||
|
} |
||||||
|
!== { |
||||||
|
lappend rc != |
||||||
|
} |
||||||
|
>>> { |
||||||
|
lappend rc >> |
||||||
|
} |
||||||
|
default { |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
lassign [next] str tag |
||||||
|
} |
||||||
|
if {!$top} { |
||||||
|
return [join $rc " "] |
||||||
|
} elseif {[llength $rc] == 1} { |
||||||
|
set rc [lindex $rc 0] |
||||||
|
if {[string match {{*}} $rc]} { |
||||||
|
return [list [string range $rc 1 end-1]] |
||||||
|
} else { |
||||||
|
return $rc |
||||||
|
} |
||||||
|
} elseif {!$strcat} { |
||||||
|
return [format {[expr {%s}]} [join $rc " "]] |
||||||
|
} |
||||||
|
set cat {} |
||||||
|
set expr {} |
||||||
|
set rest [lassign $rc arg] |
||||||
|
set strcat [string match {{*}} $arg] |
||||||
|
if {$strcat} { |
||||||
|
lappend cat $arg |
||||||
|
} else { |
||||||
|
lappend expr $arg |
||||||
|
} |
||||||
|
foreach {op arg} $rest { |
||||||
|
if {$op ne "+" || !$strcat && ![string match {{*}} $arg]} { |
||||||
|
lappend expr $op $arg |
||||||
|
} else { |
||||||
|
if {[llength $expr]} { |
||||||
|
if {[llength $expr] > 1} { |
||||||
|
lappend cat [format {[expr {%s}]} [join $expr]] |
||||||
|
} else { |
||||||
|
lappend cat [lindex $expr 0] |
||||||
|
} |
||||||
|
} |
||||||
|
set expr {} |
||||||
|
if {[string match {{*}} $arg]} { |
||||||
|
set strcat 1 |
||||||
|
lappend cat $arg |
||||||
|
} else { |
||||||
|
lappend expr $arg |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
if {[llength $expr]} { |
||||||
|
if {[llength $expr] > 1} { |
||||||
|
lappend cat [format {[expr {%s}]} [join $expr]] |
||||||
|
} else { |
||||||
|
lappend cat [lindex $expr 0] |
||||||
|
} |
||||||
|
} |
||||||
|
return [format {[string cat %s]} [join $cat]] |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::function {} { |
||||||
|
lassign [next] name tag |
||||||
|
if {$tag ne "("} { |
||||||
|
fail "expected open parenthesis" |
||||||
|
} |
||||||
|
set arglist {} |
||||||
|
lassign [next] str tag |
||||||
|
if {$str ne ""} { |
||||||
|
while 1 { |
||||||
|
lappend arglist $str |
||||||
|
if {$tag eq ")"} break |
||||||
|
if {$tag ne ","} { |
||||||
|
fail "expected , or )" |
||||||
|
} |
||||||
|
lassign [next] str tag |
||||||
|
} |
||||||
|
} elseif {$tag ne ")"} { |
||||||
|
fail "expected )" |
||||||
|
} |
||||||
|
lappend rc "proc $name [list $arglist] \{" |
||||||
|
lassign [next] str tag |
||||||
|
lappend rc {*}[indent [code]] |
||||||
|
lappend rc "\}" |
||||||
|
return $rc |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::funccall {name} { |
||||||
|
set cmd $name |
||||||
|
lassign [next] str tag |
||||||
|
if {$str ne "" || $tag ne ")"} { |
||||||
|
while 1 { |
||||||
|
append cmd " " [expression] |
||||||
|
lassign [peek] str tag |
||||||
|
if {$tag eq ")"} break |
||||||
|
if {$tag ne ","} { |
||||||
|
fail "expected , or )" |
||||||
|
} |
||||||
|
next |
||||||
|
} |
||||||
|
} |
||||||
|
next |
||||||
|
return $cmd |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::ifelse {} { |
||||||
|
lassign [peek] str tag |
||||||
|
if {$tag ne "("} { |
||||||
|
fail "expected (" |
||||||
|
} |
||||||
|
next |
||||||
|
lappend rc [format "if {%s} \{" [expression 0]] |
||||||
|
lassign [next] str tag |
||||||
|
lappend rc {*}[indent [code]] |
||||||
|
lassign [peek] str tag |
||||||
|
if {$str eq "else"} { |
||||||
|
lappend rc {\} else \{} |
||||||
|
lassign [next] str tag |
||||||
|
lappend rc {*}[indent [code]] |
||||||
|
} |
||||||
|
lappend rc "\}" |
||||||
|
return $rc |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::forloop {} { |
||||||
|
lassign [peek] str tag |
||||||
|
if {$tag ne "("} { |
||||||
|
fail "expected (" |
||||||
|
} |
||||||
|
lassign [next] name tag |
||||||
|
if {$name eq "var" && [string is space $tag]} { |
||||||
|
lassign [next] name tag |
||||||
|
} |
||||||
|
if {![regexp {^[\w$]+$} $name]} { |
||||||
|
fail "expected identifier" |
||||||
|
} |
||||||
|
if {$tag eq "="} { |
||||||
|
} elseif {[string is space $tag]} { |
||||||
|
lassign [next] str tag |
||||||
|
if {$str ni {in of} || ![string is space $tag]} { |
||||||
|
fail "expected 'in' or 'of'" |
||||||
|
} |
||||||
|
if {$str eq "in"} { |
||||||
|
set op keys |
||||||
|
} else { |
||||||
|
set op values |
||||||
|
} |
||||||
|
lassign [next] str tag |
||||||
|
lappend rc [format "foreach %s \[dict %s $%s\] \{" $name $op $str] |
||||||
|
if {$tag ne ")"} { |
||||||
|
fail "expected )" |
||||||
|
} |
||||||
|
next |
||||||
|
lappend rc {*}[indent [code]] |
||||||
|
lappend rc "\}" |
||||||
|
} |
||||||
|
return $rc |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::method {obj} { |
||||||
|
lassign [next] method tag |
||||||
|
set cmd [format {%s %s} $method $obj] |
||||||
|
if {$tag eq "("} { |
||||||
|
lassign [next] str tag |
||||||
|
if {$str ne "" || $tag ne ")"} { |
||||||
|
while 1 { |
||||||
|
append cmd " " [expression] |
||||||
|
lassign [peek] str tag |
||||||
|
if {$tag eq ")"} break |
||||||
|
if {$tag ne ","} { |
||||||
|
fail "expected , or )" |
||||||
|
} |
||||||
|
next |
||||||
|
} |
||||||
|
} |
||||||
|
next |
||||||
|
} |
||||||
|
return [format {[%s]} $cmd] |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::assignment {name} { |
||||||
|
lassign [next] str tag |
||||||
|
switch $str { |
||||||
|
new { |
||||||
|
if {![string is space $tag]} { |
||||||
|
fail "expected white space" |
||||||
|
} |
||||||
|
lassign [next] str tag |
||||||
|
switch $str { |
||||||
|
Array { |
||||||
|
if {$tag ne "("} { |
||||||
|
fail "expected (" |
||||||
|
} |
||||||
|
set cmd "dict create" |
||||||
|
lassign [next] str tag |
||||||
|
set index 0 |
||||||
|
if {$str ne "" || $tag ne ")"} { |
||||||
|
while 1 { |
||||||
|
append cmd " " $index " " [expression] |
||||||
|
incr index |
||||||
|
lassign [peek] str tag |
||||||
|
next |
||||||
|
if {$tag eq ","} continue |
||||||
|
if {$tag eq ")"} break |
||||||
|
fail "expected , or )" |
||||||
|
} |
||||||
|
} else { |
||||||
|
next |
||||||
|
} |
||||||
|
return [list [format {set %s [%s]} $name $cmd]] |
||||||
|
} |
||||||
|
default { |
||||||
|
fail "$str objects are not supported" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
{} { |
||||||
|
if {$tag eq "\["} { |
||||||
|
set cmd list |
||||||
|
lassign [next] str tag |
||||||
|
if {$str ne "" || $tag ne "]"} { |
||||||
|
while 1 { |
||||||
|
append cmd " " [expression] |
||||||
|
lassign [peek] str tag |
||||||
|
next |
||||||
|
if {$tag eq ","} continue |
||||||
|
if {$tag eq "\]"} break |
||||||
|
fail "expected , or \]" |
||||||
|
} |
||||||
|
} |
||||||
|
return [list [format {set %s [%s]} $name $cmd]] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return [list [format {set %s %s} $name [expression]]] |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::var {} { |
||||||
|
lassign [next] str tag |
||||||
|
if {![regexp {^[\w$]+$} $str]} { |
||||||
|
fail "expected identifier" |
||||||
|
} |
||||||
|
if {$tag in {; \n}} return |
||||||
|
return [assignment $str] |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::arrayelem {name} { |
||||||
|
next |
||||||
|
set sub [expression] |
||||||
|
lassign [peek] str tag |
||||||
|
if {$tag ne "\]"} { |
||||||
|
fail "expected \]" |
||||||
|
} |
||||||
|
next |
||||||
|
return [format {[dict get $%s %s]} $name $sub] |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::indent {list} { |
||||||
|
return [lmap line $list {format \t%s $line}] |
||||||
|
} |
||||||
|
|
||||||
|
proc www::proxypac::fail {str} { |
||||||
|
error $str |
||||||
|
} |
||||||
|
|
||||||
|
namespace eval www::proxypac { |
||||||
|
interp create [namespace current]::proxypacrun |
||||||
|
proxypacrun alias resolve [namespace which resolve] |
||||||
|
proxypacrun alias validip [namespace which validip] |
||||||
|
|
||||||
|
proxypacrun eval { |
||||||
|
proc substring {str start {end 0}} { |
||||||
|
if {[llength [info level 0]] < 4} { |
||||||
|
set end [string length $str] |
||||||
|
} |
||||||
|
if {$start < $end} { |
||||||
|
return [string range $str $start [expr {$end - 1}]] |
||||||
|
} else { |
||||||
|
return [string range $str $end [expr {$start - 1}]] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc toLowerCase {str} { |
||||||
|
return [string tolower $str] |
||||||
|
} |
||||||
|
|
||||||
|
rename split tclsplit |
||||||
|
proc split {str {separator ""} {limit 2147483647}} { |
||||||
|
if {[llength [info level 0]] == 1} { |
||||||
|
set list [list $str] |
||||||
|
} elseif {$separator eq ""} { |
||||||
|
set list [tclsplit $str ""] |
||||||
|
} else { |
||||||
|
set list {} |
||||||
|
set p 0 |
||||||
|
while {[set x [string first $separator $str $p]] >= 0} { |
||||||
|
lappend list [string range $str $p [expr {$x - 1}]] |
||||||
|
set p [expr {$x + [string length $separator]}] |
||||||
|
} |
||||||
|
lappend list [string range $str $p end] |
||||||
|
} |
||||||
|
set rc {} |
||||||
|
set num 0 |
||||||
|
foreach n $list { |
||||||
|
if {$num >= $limit} break |
||||||
|
dict set rc $num $n |
||||||
|
incr num |
||||||
|
} |
||||||
|
return $rc |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc jsfunction {name type args body} { |
||||||
|
proxypacrun alias $name \ |
||||||
|
apply [list $args $body [namespace current]] |
||||||
|
# proxypacrun eval [list proc $name $args $body] |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
namespace eval www::proxypac { |
||||||
|
duktape::oo::Duktape create js |
||||||
|
|
||||||
|
proc parse {data} { |
||||||
|
js eval $data |
||||||
|
} |
||||||
|
|
||||||
|
proc execute {args} { |
||||||
|
js call {*}$args |
||||||
|
} |
||||||
|
|
||||||
|
proc jsfunction {name type args body} { |
||||||
|
js tcl-function $name $type $args $body |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
namespace eval www::proxypac { |
||||||
|
variable ipaddress "" |
||||||
|
|
||||||
|
jsfunction isPlainHostName boolean {host} { |
||||||
|
return [expr {[string first . $host] < 0}] |
||||||
|
} |
||||||
|
|
||||||
|
jsfunction dnsDomainIs boolean {host domain} { |
||||||
|
set x [string first . $host] |
||||||
|
return [expr {$x >= 0 && [string range $host $x end] eq $domain}] |
||||||
|
} |
||||||
|
|
||||||
|
jsfunction localHostOrDomainIs boolean {host hostdom} { |
||||||
|
return \ |
||||||
|
[expr {$host eq $hostdom || $host eq [lindex [split $host .] 0]}] |
||||||
|
} |
||||||
|
|
||||||
|
jsfunction isValidIpAddress boolean {ipchars} { |
||||||
|
return [validip $ipchars] |
||||||
|
} |
||||||
|
|
||||||
|
jsfunction isResolvable boolean {host} { |
||||||
|
return [expr {[resolve $host] ne ""}] |
||||||
|
} |
||||||
|
|
||||||
|
jsfunction isInNet boolean {host pattern mask} { |
||||||
|
if {![validip $host]} { |
||||||
|
set host [resolve $host] |
||||||
|
if {$host eq ""} {return 0} |
||||||
|
} |
||||||
|
foreach ip1 [split $host .] ip2 [split $pattern .] m [split $mask .] { |
||||||
|
if {($ip1 & $m) != ($ip2 & $m)} {return 0} |
||||||
|
} |
||||||
|
return 1 |
||||||
|
} |
||||||
|
|
||||||
|
jsfunction dnsResolve string {host} { |
||||||
|
return [resolve $host] |
||||||
|
} |
||||||
|
|
||||||
|
jsfunction convert_addr integer {ipaddr} { |
||||||
|
binary scan [binary format c4 [split $ipaddr .]] Iu addr |
||||||
|
return $addr |
||||||
|
} |
||||||
|
|
||||||
|
jsfunction myIpAddress string {} { |
||||||
|
variable ipaddress |
||||||
|
if {$ipaddress eq ""} { |
||||||
|
try { |
||||||
|
set fd "" |
||||||
|
set fd [socket -server dummy -myaddr [info hostname] 0] |
||||||
|
set ipaddress [lindex [fconfigure $fd -sockname] 0] |
||||||
|
} on error {} { |
||||||
|
set ipaddress 127.0.0.1 |
||||||
|
} finally { |
||||||
|
if {$fd ne ""} {close $fd} |
||||||
|
} |
||||||
|
} |
||||||
|
return $ipaddress |
||||||
|
} |
||||||
|
|
||||||
|
jsfunction dnsDomainLevels integer {host} { |
||||||
|
return [regexp {[.]} $host] |
||||||
|
} |
||||||
|
|
||||||
|
jsfunction shExpMatch boolean {str shexp} { |
||||||
|
return [string match $shexp $str] |
||||||
|
} |
||||||
|
|
||||||
|
jsfunction weekdayRange boolean {wd1 {wd2 ""} {gmt ""}} { |
||||||
|
set weekdays {SUN MON TUE WED THU FRI SAT} |
||||||
|
if {$wd2 eq "GMT"} { |
||||||
|
set gmt 1 |
||||||
|
set match [list $wd1] |
||||||
|
} else { |
||||||
|
set gmt [expr {$gmt eq "GMT"}] |
||||||
|
set d1 [lsearch -exact $weekdays $wd1] |
||||||
|
set d2 [lsearch -exact $weekdays $wd2] |
||||||
|
if {$d1 < $d2} { |
||||||
|
set match [lrange $weekdays $d1 $d2] |
||||||
|
} else { |
||||||
|
set match [list $wd1 $wd2] |
||||||
|
} |
||||||
|
} |
||||||
|
set wd0 [clock format [clock seconds] -gmt $gmt -format %a] |
||||||
|
return [expr {[string toupper $wd0] in $match}] |
||||||
|
} |
||||||
|
|
||||||
|
jsfunction dateRange boolean {args} { |
||||||
|
set gmt [expr {[lindex $args end] eq "GMT"}] |
||||||
|
set len [expr {[llength $args] - $gmt}] |
||||||
|
if {$len < 1} {return 0} |
||||||
|
set now [clock seconds] |
||||||
|
if {$len == 1} { |
||||||
|
set arg [lindex $args 0] |
||||||
|
if {![string is integer -strict $arg]} { |
||||||
|
set mon [clock format $now -format %b -gmt $gmt] |
||||||
|
return [expr {$arg eq [string toupper $mon]}] |
||||||
|
} elseif {$arg < 32} { |
||||||
|
set day [clock format $now -format %e -gmt $gmt] |
||||||
|
return [expr {$arg == $day}] |
||||||
|
} else { |
||||||
|
set year [clock format $now -format %Y -gmt $gmt] |
||||||
|
return [expr {$arg == $year}] |
||||||
|
} |
||||||
|
} |
||||||
|
lassign [clock format $now -format {%Y %b} -gmt $gmt] year month |
||||||
|
set d1 [list $year JAN 1 0 0 0] |
||||||
|
set d2 [list $year DEC 31 23 59 59] |
||||||
|
set middle [expr {$len / 2}] |
||||||
|
for {set i 0} {$i < $middle} {incr i} { |
||||||
|
set arg [lindex $args $i] |
||||||
|
if {![string is integer -strict $arg]} { |
||||||
|
lset d1 1 $arg |
||||||
|
} elseif {$arg < 32} { |
||||||
|
lset d1 2 $arg |
||||||
|
if {$len <= 2} { |
||||||
|
lset d1 1 $month |
||||||
|
lset d2 1 $month |
||||||
|
} |
||||||
|
} else { |
||||||
|
lset d1 0 $arg |
||||||
|
} |
||||||
|
} |
||||||
|
for {set i $middle} {$i < $len} {incr i} { |
||||||
|
set arg [lindex $args $i] |
||||||
|
if {![string is integer -strict $arg]} { |
||||||
|
lset d2 1 $arg |
||||||
|
} elseif {$arg < 32} { |
||||||
|
lset d2 2 $arg |
||||||
|
} else { |
||||||
|
lset d2 0 $arg |
||||||
|
} |
||||||
|
} |
||||||
|
set time1 [clock scan [join $d1 :] -format %Y:%b:%d:%T -gmt $gmt] |
||||||
|
set time2 [clock scan [join $d2 :] -format %Y:%b:%d:%T -gmt $gmt] |
||||||
|
if {$time1 < $time2} { |
||||||
|
return [expr {$now >= $time1 && $now <= $time2}] |
||||||
|
} else { |
||||||
|
return [expr {$now >= $time2 && $now <= $time1}] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
jsfunction timeRange boolean {args} { |
||||||
|
set gmt [expr {[lindex $args end] eq "GMT"}] |
||||||
|
set len [expr {[llength $args] - $gmt}] |
||||||
|
if {$len < 1} { |
||||||
|
return 0 |
||||||
|
} elseif {$len > 6 || $len == 3 || $len == 5} { |
||||||
|
return -code error "timeRange: bad number of arguments" |
||||||
|
} |
||||||
|
set t1 {0 0 0} |
||||||
|
set t2 {23 59 59} |
||||||
|
set n [expr {($len + 1) / 2}] |
||||||
|
for {set i1 0; set i2 [expr {$len / 2}]} {$i1 < $n} {incr i1; incr i2} { |
||||||
|
lset t1 $i1 [lindex $args $i1] |
||||||
|
if {$i2 < $len} { |
||||||
|
lset t2 $i1 [lindex $args $i2] |
||||||
|
} |
||||||
|
} |
||||||
|
set time1 [clock scan [join $t1 :] -format %T -gmt $gmt] |
||||||
|
set time2 [clock scan [join $t2 :] -format %T -gmt $gmt] |
||||||
|
set now [clock seconds] |
||||||
|
if {$time1 < $time2} { |
||||||
|
return [expr {$now >= $time1 && $now <= $time2}] |
||||||
|
} else { |
||||||
|
return [expr {$now >= $time2 && $now <= $time1}] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
jsfunction alert undefined {} {} |
||||||
|
} |
||||||
|
|
||||||
|
namespace import www::proxypac::* |
||||||
@ -0,0 +1,156 @@ |
|||||||
|
# SOCKS V4a: http://ftp.icm.edu.pl/packages/socks/socks4/SOCKS4.protocol |
||||||
|
# SOCKS V5: RFC 1928 |
||||||
|
|
||||||
|
namespace eval www::socks { |
||||||
|
variable username guest password guest |
||||||
|
namespace ensemble create -map {socks4 {init socks4} socks5 {init socks5}} |
||||||
|
} |
||||||
|
|
||||||
|
proc www::socks::command {sock data {count 2} {timeout 2000}} { |
||||||
|
if {$data ne ""} { |
||||||
|
puts -nonewline $sock $data |
||||||
|
flush $sock |
||||||
|
} |
||||||
|
set coro [info coroutine] |
||||||
|
if {[llength $coro]} { |
||||||
|
set id [after $timeout [list $coro timeout]] |
||||||
|
fileevent $sock readable [list $coro data] |
||||||
|
} else { |
||||||
|
fconfigure $sock -blocking 1 |
||||||
|
set id {} |
||||||
|
} |
||||||
|
set resp {} |
||||||
|
set len 0 |
||||||
|
while {![eof $sock]} { |
||||||
|
append resp [read $sock [expr {$count - $len}]] |
||||||
|
set len [string length $resp] |
||||||
|
if {$len >= $count} { |
||||||
|
after cancel $id |
||||||
|
return $resp |
||||||
|
} |
||||||
|
if {[llength $coro] == 0} continue |
||||||
|
set event [yield] |
||||||
|
if {$event eq "data"} continue |
||||||
|
if {$event eq "timeout"} break |
||||||
|
} |
||||||
|
throw {SOCKS PROTOCOL ERROR} "did not get expected response from proxy" |
||||||
|
} |
||||||
|
|
||||||
|
proc www::socks::init {version sock host port} { |
||||||
|
# Make sure this is running in a coroutine |
||||||
|
if {[llength [info coroutine]] == 0} { |
||||||
|
return [coroutine $sock init $version $sock $host $port] |
||||||
|
} |
||||||
|
dict set cfg -translation [fconfigure $sock -translation] |
||||||
|
dict set cfg -blocking [fconfigure $sock -blocking] |
||||||
|
dict set event readable [fileevent $sock readable] |
||||||
|
dict set event writable [fileevent $sock writable] |
||||||
|
fileevent $sock writable {} |
||||||
|
fconfigure $sock -translation binary -blocking 0 |
||||||
|
if {[catch {$version $sock $host $port} result opts]} { |
||||||
|
variable lasterror $result |
||||||
|
} |
||||||
|
fconfigure $sock {*}$cfg |
||||||
|
dict for {ev cmd} $event { |
||||||
|
fileevent $sock $ev $cmd |
||||||
|
} |
||||||
|
return -options [dict incr opts -level] $result |
||||||
|
} |
||||||
|
|
||||||
|
proc www::socks::socks4 {sock host port} { |
||||||
|
variable username |
||||||
|
set ip4 [split $host .] |
||||||
|
if {[llength $ip4] == 4 && [string is digit -strict [lindex $ip4 end]]} { |
||||||
|
set data [binary format ccSc4a*x 4 1 $port $ip4 $username] |
||||||
|
} else { |
||||||
|
# SOCKS4a |
||||||
|
set data [binary format ccSx3ca*xa*x 4 1 $port 1 $username $host] |
||||||
|
} |
||||||
|
binary scan [command $sock $data 8] cucuSc4 vn cd dstport dstip |
||||||
|
if {$vn != 0} { |
||||||
|
throw {SOCKS CONNECT VERSION} \ |
||||||
|
"unsupported socks connection version: $vn" |
||||||
|
} |
||||||
|
if {$cd != 90} { |
||||||
|
throw [list SOCKS CONNECT [format ERROR%02X $cd]] \ |
||||||
|
"socks connection failed with error code $cd" |
||||||
|
} |
||||||
|
return [join $dstip .]:$dstport |
||||||
|
} |
||||||
|
|
||||||
|
proc www::socks::socks5 {sock host port} { |
||||||
|
fconfigure $sock -translation binary -blocking 0 |
||||||
|
# Authenticate |
||||||
|
set methods [list 0 2] |
||||||
|
set data [binary format ccc* 5 [llength $methods] $methods] |
||||||
|
binary scan [command $sock $data 2] cucu version method |
||||||
|
|
||||||
|
if {$method == 0} { |
||||||
|
# No authentication required |
||||||
|
} elseif {$method == 1} { |
||||||
|
# GSS-API RFC 1961 |
||||||
|
# Not implemented |
||||||
|
throw {SOCKS AUTH UNKNOWN} "unsupported authentication method: $method" |
||||||
|
} elseif {$method == 2} { |
||||||
|
# Username/password RFC 1929 |
||||||
|
authenticate $sock |
||||||
|
} else { |
||||||
|
throw {SOCKS AUTH NOTACCEPTED} "no acceptable authentication methods" |
||||||
|
} |
||||||
|
|
||||||
|
# Connect |
||||||
|
set data [binary format ccc 5 1 0] |
||||||
|
set ip4 [split $host .] |
||||||
|
if {[llength $ip4] == 1 && [llength [set ip6 [split $host :]]] >= 3} { |
||||||
|
# IPv6 address |
||||||
|
set x [lsearch -exact $ip6 {}] |
||||||
|
if {$x >= 0} { |
||||||
|
set ip6 [lsearch -inline -exact -all -not $ip6 {}] |
||||||
|
set insert [lrepeat [expr {8 - [llength $ip6]}] 0] |
||||||
|
set ip6 [linsert $ip6 $x {*}$insert] |
||||||
|
} |
||||||
|
append data [binary format cS8S 4 $ip6 $port] |
||||||
|
} elseif {[llength $ip4] == 4 && [string is digit -strict [lindex $ip4 end]]} { |
||||||
|
# IPv4 address |
||||||
|
append data [binary format cc4S 1 $ip4 $port] |
||||||
|
} else { |
||||||
|
# hostname |
||||||
|
append data [binary format cca*S 3 [string length $host] $host $port] |
||||||
|
} |
||||||
|
binary scan [command $sock $data 4 10000] ccxc version reply atyp |
||||||
|
if {$reply != 0} { |
||||||
|
throw [list SOCKS CONNECT [format ERROR%02X $reply]] \ |
||||||
|
"socks connection failed with error code $reply" |
||||||
|
} |
||||||
|
switch $atyp { |
||||||
|
1 { |
||||||
|
binary scan [command $sock {} 6] c4S dstip dstport |
||||||
|
return [join $dstip .]:$dstport |
||||||
|
} |
||||||
|
3 { |
||||||
|
binary scan [command $sock {} 1] c len |
||||||
|
binary scan [command $sock {} [expr {$len + 2}]] a${len}S dsthost dstport |
||||||
|
return $dsthost:$dstport |
||||||
|
} |
||||||
|
4 { |
||||||
|
binary scan [command $sock {} 18] S8S dstip dstport |
||||||
|
return format {[%s]:$d} [join $dstip :] $dstport |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc www::socks::authenticate {sock} { |
||||||
|
variable username |
||||||
|
variable password |
||||||
|
set data [binary format cca*ca* 1 \ |
||||||
|
[string length $username] $username [string length $password] $password] |
||||||
|
binary scan [command $sock 2] cucu version status |
||||||
|
if {$version != 1} { |
||||||
|
throw {SOCKS AUTH RFC1929 VERSION} \ |
||||||
|
"unsupported username/password authentication version: $version" |
||||||
|
} |
||||||
|
if {$status != 0} { |
||||||
|
throw {SOCKS AUTH RFC1929 STATUS} \ |
||||||
|
"username/password authentication failed: $status" |
||||||
|
} |
||||||
|
} |
||||||
@ -0,0 +1,306 @@ |
|||||||
|
# Helper library for adding websocket support to www |
||||||
|
|
||||||
|
package require www 2.7 |
||||||
|
|
||||||
|
proc www::websocket {args} { |
||||||
|
set opts {-upgrade {WebSocket www::WebSocket}} |
||||||
|
set args [getopt arg $args { |
||||||
|
-timeout:milliseconds {dict set opts -timeout $arg} |
||||||
|
-auth:data {dict set opts -auth $arg} |
||||||
|
-digest:cred {dict set opts -digest $arg} |
||||||
|
-maxredir:cnt {dict set opts -maxredir $arg} |
||||||
|
}] |
||||||
|
if {[llength $args] < 1 || [llength $args] > 3} { |
||||||
|
throw {WWW WEBSOCKET ARGS} {wrong # args:\ |
||||||
|
should be "www::websocket url ?protocols? ?extensions?"} |
||||||
|
} |
||||||
|
lassign $args url protocols extensions |
||||||
|
try { |
||||||
|
set hdrs [WebSocket headers] |
||||||
|
if {[llength $protocols]} { |
||||||
|
lappend hdrs Sec-WebSocket-Protocol [join $protocols {, }] |
||||||
|
} |
||||||
|
if {[dict size $extensions]} { |
||||||
|
set ext [join [lmap name [dict keys $extensions] { |
||||||
|
set list [list $name] |
||||||
|
if {[dict exists $extensions $name parameters]} { |
||||||
|
lappend $list [dict get $extensions $name parameters] |
||||||
|
} |
||||||
|
join $list {; } |
||||||
|
}] {, }] |
||||||
|
lappend hdrs Sec-WebSocket-Extensions $ext |
||||||
|
} |
||||||
|
www get {*}$opts -headers $hdrs $url |
||||||
|
} on ok {result info} { |
||||||
|
if {[dict get $info status code] != 101} { |
||||||
|
# The only correct response for a successful websocket connection |
||||||
|
# is 101 Switching Protocols. Even 200 OK is not good. |
||||||
|
set code [dict get $info status code] |
||||||
|
set codegrp [string replace $code 1 2 XX] |
||||||
|
set reason [dict get $info status reason] |
||||||
|
dict set info -code 1 |
||||||
|
dict set info -errorcode [list WWW CODE $codegrp $code $reason] |
||||||
|
return -options [dict incr info -level] $result |
||||||
|
} |
||||||
|
set websock [dict get $info websocket] |
||||||
|
set hdrs [dict get $info headers] |
||||||
|
set protocol [if {[dict exists $hdrs sec-websocket-protocol]} { |
||||||
|
dict get $hdrs sec-websocket-protocol |
||||||
|
}] |
||||||
|
if {[dict exists $hdrs sec-websocket-extensions]} { |
||||||
|
set ext [header [$hdrs sec-websocket-extensions] *] |
||||||
|
set mixins [lmap value [lreverse $ext] { |
||||||
|
set list [lmap n [split $value {;}] {string trim $n}] |
||||||
|
set params [lassign $list name] |
||||||
|
dict set parameters $name $params |
||||||
|
dict get $extensions $name implementation |
||||||
|
}] |
||||||
|
oo::objdefine $websock \ |
||||||
|
mixin www::WSExtension {*}$mixins www::WebSocket |
||||||
|
# Inform the extensions of their parameters, if any |
||||||
|
$websock parameters $parameters |
||||||
|
} |
||||||
|
# Return the websocket object command (and the negotiated protocol) |
||||||
|
return protocol $protocol [dict get $info websocket] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
namespace ensemble configure www \ |
||||||
|
-subcommands [linsert [namespace ensemble configure www -subcommands] end websocket] |
||||||
|
|
||||||
|
oo::class create www::WebSocket { |
||||||
|
method Startup {headers} { |
||||||
|
my variable fd |
||||||
|
variable callback {} |
||||||
|
# This socket cannot be used for future connections |
||||||
|
release [self] |
||||||
|
fconfigure $fd -translation binary -buffering none -blocking 0 |
||||||
|
# Return the websocket object to the caller |
||||||
|
my Result websocket [self] |
||||||
|
my Return [my PopRequest] |
||||||
|
} |
||||||
|
|
||||||
|
method Read {} { |
||||||
|
my variable fd |
||||||
|
return [read $fd] |
||||||
|
} |
||||||
|
|
||||||
|
method Write {data} { |
||||||
|
my variable fd |
||||||
|
puts -nonewline $fd $data |
||||||
|
} |
||||||
|
|
||||||
|
method Handler {} { |
||||||
|
my variable fd callback |
||||||
|
fileevent $fd readable [list [info coroutine] data] |
||||||
|
set data "" |
||||||
|
set payload "" |
||||||
|
while {![eof $fd]} { |
||||||
|
yield |
||||||
|
append data [my Read] |
||||||
|
if {[binary scan $data B4Xcucu flags code len] != 3} continue |
||||||
|
if {$len < 126} { |
||||||
|
set pos 2 |
||||||
|
} elseif {$len == 126} { |
||||||
|
if {[binary scan $data x2Su len] != 1} continue |
||||||
|
set pos 4 |
||||||
|
} elseif {$len == 127} { |
||||||
|
if {[binary scan $data x2Wu len] != 1} continue |
||||||
|
set pos 10 |
||||||
|
} else { |
||||||
|
# Error: Messages from server to client should not be masked |
||||||
|
my close 1002 |
||||||
|
} |
||||||
|
if {[string length $data] < $pos + $len} continue |
||||||
|
set code [expr {$code & 0xf}] |
||||||
|
set payload [string range $data $pos [expr {$pos + $len - 1}]] |
||||||
|
set data [string range $data [expr {$pos + $len}] end] |
||||||
|
if {$code == 0} { |
||||||
|
append message $payload |
||||||
|
} else { |
||||||
|
set opcode $code |
||||||
|
# Control frames MAY be injected in the middle of a |
||||||
|
# fragmented message. (RFC6455 5.4) |
||||||
|
# Control frames are identified by opcodes where the most |
||||||
|
# significant bit of the opcode is 1. (RFC6455 5.5) |
||||||
|
if {$code < 8} {set message $payload} |
||||||
|
} |
||||||
|
if {![string index $flags 0]} continue |
||||||
|
if {$opcode < 8} { |
||||||
|
my Receive $opcode $message $flags |
||||||
|
} else { |
||||||
|
my Receive $opcode $payload $flags |
||||||
|
} |
||||||
|
} |
||||||
|
if {[dict exists $callback close]} { |
||||||
|
# 1006 is designated for use in applications expecting a status |
||||||
|
# code to indicate that the connection was closed abnormally, |
||||||
|
# e.g., without sending or receiving a Close control frame. |
||||||
|
{*}[dict get $callback close] close 1006 "eof on connection" |
||||||
|
} |
||||||
|
my destroy |
||||||
|
} |
||||||
|
|
||||||
|
# Methods that can be overridden by extensions |
||||||
|
|
||||||
|
method Read {} { |
||||||
|
my variable fd |
||||||
|
return [read $fd] |
||||||
|
} |
||||||
|
|
||||||
|
method Write {data} { |
||||||
|
my variable fd |
||||||
|
puts -nonewline $fd $data |
||||||
|
} |
||||||
|
|
||||||
|
method Receive {opcode data flags} { |
||||||
|
my variable callback |
||||||
|
switch $opcode { |
||||||
|
1 { |
||||||
|
if {[dict exists $callback text]} { |
||||||
|
set str [encoding convertfrom utf-8 $data] |
||||||
|
{*}[dict get $callback text] text $str |
||||||
|
} else { |
||||||
|
my close 1003 |
||||||
|
} |
||||||
|
} |
||||||
|
2 { |
||||||
|
if {[dict exists $callback binary]} { |
||||||
|
{*}[dict get $callback binary] binary $data |
||||||
|
} else { |
||||||
|
my close 1003 |
||||||
|
} |
||||||
|
} |
||||||
|
8 { |
||||||
|
if {[dict exists $callback close]} { |
||||||
|
if {[binary scan $data Sua* code reason] != 2} { |
||||||
|
set code 1005 |
||||||
|
set reason "" |
||||||
|
} |
||||||
|
{*}[dict get $callback close] close $code $reason |
||||||
|
set callback {} |
||||||
|
} |
||||||
|
} |
||||||
|
9 { |
||||||
|
if {[dict exists $callback ping]} { |
||||||
|
{*}[dict get $callback ping] ping $data |
||||||
|
} else { |
||||||
|
my pong $data |
||||||
|
} |
||||||
|
} |
||||||
|
10 { |
||||||
|
if {[dict exists $callback pong]} { |
||||||
|
{*}[dict get $callback pong] pong $data |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
method Transmit {opcode data {flags 1}} { |
||||||
|
binary scan $data cu* bytes |
||||||
|
# The requirement to use a strong source of entropy makes no sense |
||||||
|
# So we'll just use Tcl's simple linear congruential generator |
||||||
|
set key [expr {int(rand() * 0x100000000)}] |
||||||
|
binary scan [binary format I $key] cu* mask |
||||||
|
set length [llength $bytes] |
||||||
|
# Apply the mask |
||||||
|
set i 0 |
||||||
|
set bytes [lmap n $bytes { |
||||||
|
set m [lindex $mask [expr {$i & 3}]] |
||||||
|
incr i |
||||||
|
expr {$n ^ $m} |
||||||
|
}] |
||||||
|
set type \ |
||||||
|
[expr {$opcode | "0b[string reverse [format %04s $flags]]0000"}] |
||||||
|
set data [binary format c $type] |
||||||
|
if {$length < 126} { |
||||||
|
append data [binary format c [expr {$length | 0x80}]] |
||||||
|
} elseif {$length < 65536} { |
||||||
|
append data [binary format cS [expr {126 | 0x80}] $length] |
||||||
|
} else { |
||||||
|
append data [binary format cW [expr {127 | 0x80}] $length] |
||||||
|
} |
||||||
|
append data [binary format c*c* $mask $bytes] |
||||||
|
my Write $data |
||||||
|
} |
||||||
|
|
||||||
|
# Public methods |
||||||
|
|
||||||
|
method callback {types prefix} { |
||||||
|
variable callback |
||||||
|
set running [dict size $callback] |
||||||
|
if {$prefix ne ""} { |
||||||
|
foreach type $types { |
||||||
|
dict set callback $type $prefix |
||||||
|
} |
||||||
|
} elseif {[llength $types]} { |
||||||
|
set callback [dict remove $callback {*}$types] |
||||||
|
} else { |
||||||
|
set callback {} |
||||||
|
} |
||||||
|
if {[dict size $callback]} { |
||||||
|
if {!$running} {coroutine websockcoro my Handler} |
||||||
|
} else { |
||||||
|
if {$running} {rename websockcoro ""} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
method text {str} { |
||||||
|
my Transmit 1 [encoding convertto utf-8 $str] |
||||||
|
} |
||||||
|
|
||||||
|
method binary {data} { |
||||||
|
my Transmit 2 $data |
||||||
|
} |
||||||
|
|
||||||
|
method close {{code 1005} {reason ""}} { |
||||||
|
# 1005 is designated for use in applications expecting a status code |
||||||
|
# to indicate that no status code was actually present. |
||||||
|
set payload [if {$code != 1005} { |
||||||
|
binary format Sa* $code [encoding convertto utf-8 $reason] |
||||||
|
}] |
||||||
|
my Transmit 8 $payload |
||||||
|
# The client SHOULD wait for the server to close the connection but |
||||||
|
# MAY close the connection at any time after sending and receiving |
||||||
|
# a Close message, e.g., if it has not received a TCP Close from |
||||||
|
# the server in a reasonable time period. |
||||||
|
# my destroy |
||||||
|
} |
||||||
|
|
||||||
|
method ping {{data ""}} { |
||||||
|
my Transmit 9 $data |
||||||
|
} |
||||||
|
|
||||||
|
method pong {{data ""}} { |
||||||
|
my Transmit 10 $data |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
oo::class create www::WSExtension { |
||||||
|
method parameters {parameters} { |
||||||
|
dict for {mixin params} $parameters { |
||||||
|
nextto $mixin $params |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
oo::objdefine www::WebSocket { |
||||||
|
method key {} { |
||||||
|
# Generate a websocket key containing base64-encoded random bytes |
||||||
|
# This key is only intended to prevent a caching proxy from |
||||||
|
# re-sending a previous WebSocket conversation, and does not |
||||||
|
# provide any authentication, privacy or integrity. |
||||||
|
# It is therefor not necessary to check the returned hash. |
||||||
|
for {set i 0} {$i < 12} {incr i} { |
||||||
|
lappend bytes [expr {int(rand() * 256)}] |
||||||
|
} |
||||||
|
return [binary encode base64 [binary format c* $bytes]] |
||||||
|
} |
||||||
|
|
||||||
|
method headers {} { |
||||||
|
return [list Sec-WebSocket-Key [my key] Sec-WebSocket-Version 13] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
www register ws 80 |
||||||
|
www register wss 443 www::encrypt 1 |
||||||
@ -0,0 +1,381 @@ |
|||||||
|
# |
||||||
|
# Critcl - build C extensions on-the-fly |
||||||
|
# |
||||||
|
# Copyright (c) 2001-2007 Jean-Claude Wippler |
||||||
|
# Copyright (c) 2002-2007 Steve Landers |
||||||
|
# |
||||||
|
# See http://wiki.tcl.tk/critcl |
||||||
|
# |
||||||
|
# This is the Critcl runtime that loads the appropriate |
||||||
|
# shared library when a package is requested |
||||||
|
# |
||||||
|
|
||||||
|
namespace eval ::critcl::runtime {} |
||||||
|
|
||||||
|
proc ::critcl::runtime::loadlib {dir package version libname initfun tsrc mapping args} { |
||||||
|
# XXX At least parts of this can be done by the package generator, |
||||||
|
# XXX like listing the Tcl files to source. The glob here allows |
||||||
|
# XXX code-injection after-the-fact, by simply adding a .tcl in |
||||||
|
# XXX the proper place. |
||||||
|
set path [file join $dir [MapPlatform $mapping]] |
||||||
|
set ext [info sharedlibextension] |
||||||
|
set lib [file join $path $libname$ext] |
||||||
|
set provide [list] |
||||||
|
|
||||||
|
# Now the runtime equivalent of a series of 'preFetch' commands. |
||||||
|
if {[llength $args]} { |
||||||
|
set preload [file join $path preload$ext] |
||||||
|
foreach p $args { |
||||||
|
set prelib [file join $path $p$ext] |
||||||
|
if {[file readable $preload] && [file readable $prelib]} { |
||||||
|
lappend provide [list load $preload];# XXX Move this out of the loop, do only once. |
||||||
|
lappend provide [list ::critcl::runtime::preload $prelib] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
lappend provide [list load $lib $initfun] |
||||||
|
foreach t $tsrc { |
||||||
|
lappend loadcmd "::critcl::runtime::Fetch \$dir [list $t]" |
||||||
|
} |
||||||
|
lappend provide "package provide $package $version" |
||||||
|
package ifneeded $package $version [join $provide "\n"] |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc ::critcl::runtime::preFetch {path ext dll} { |
||||||
|
set preload [file join $path preload$ext] |
||||||
|
if {![file readable $preload]} return |
||||||
|
|
||||||
|
set prelib [file join $path $dll$ext] |
||||||
|
if {![file readable $prelib]} return |
||||||
|
|
||||||
|
load $preload ; # Defines next command. |
||||||
|
::critcl::runtime::preload $prelib |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc ::critcl::runtime::Fetch {dir t} { |
||||||
|
# The 'Ignore' disables compile & run functionality. |
||||||
|
|
||||||
|
# Background: If the regular critcl package is already loaded, and |
||||||
|
# this prebuilt package uses its defining .tcl file also as a |
||||||
|
# 'tsources' then critcl might try to collect data and build it |
||||||
|
# because of the calls to its API, despite the necessary binaries |
||||||
|
# already being present, just not in the critcl cache. That is |
||||||
|
# redundant in the best case, and fails in the worst case (no |
||||||
|
# compiler), preventing the use o a perfectly fine package. The |
||||||
|
# 'ignore' call now tells critcl that it should ignore any calls |
||||||
|
# made to it by the sourced files, and thus avoids that trouble. |
||||||
|
|
||||||
|
# The other case, the regular critcl package getting loaded after |
||||||
|
# this prebuilt package is irrelevant. At that point the tsources |
||||||
|
# were already run, and used the dummy procedures defined in the |
||||||
|
# critcl-rt.tcl, which ignore the calls by definition. |
||||||
|
|
||||||
|
set t [file join $dir tcl $t] |
||||||
|
::critcl::Ignore $t |
||||||
|
uplevel #0 [list source $t] |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc ::critcl::runtime::precopy {dll} { |
||||||
|
# This command is only used on Windows when preloading out of a |
||||||
|
# VFS that doesn't support direct loading (usually, a Starkit) |
||||||
|
# - we preserve the dll name so that dependencies are satisfied |
||||||
|
# - The critcl::runtime::preload command is defined in the supporting |
||||||
|
# "preload" package, implemented in "critcl/lib/critcl/critcl_c/preload.c" |
||||||
|
|
||||||
|
global env |
||||||
|
if {[info exists env(TEMP)]} { |
||||||
|
set dir $env(TEMP) |
||||||
|
} elseif {[info exists env(TMP)]} { |
||||||
|
set dir $env(TMP) |
||||||
|
} elseif {[file exists $env(HOME)]} { |
||||||
|
set dir $env(HOME) |
||||||
|
} else { |
||||||
|
set dir . |
||||||
|
} |
||||||
|
set dir [file join $dir TCL[pid]] |
||||||
|
set i 0 |
||||||
|
while {[file exists $dir]} { |
||||||
|
append dir [incr i] |
||||||
|
} |
||||||
|
set new [file join $dir [file tail $dll]] |
||||||
|
file mkdir $dir |
||||||
|
file copy $dll $new |
||||||
|
return $new |
||||||
|
} |
||||||
|
|
||||||
|
proc ::critcl::runtime::MapPlatform {{mapping {}}} { |
||||||
|
# A sibling of critcl::platform that applies the platform mapping |
||||||
|
|
||||||
|
set platform [::platform::generic] |
||||||
|
set version $::tcl_platform(osVersion) |
||||||
|
if {[string match "macosx-*" $platform]} { |
||||||
|
# "normalize" the osVersion to match OSX release numbers |
||||||
|
set v [split $version .] |
||||||
|
set v1 [lindex $v 0] |
||||||
|
set v2 [lindex $v 1] |
||||||
|
incr v1 -4 |
||||||
|
set version 10.$v1.$v2 |
||||||
|
} else { |
||||||
|
# Strip trailing non-version info |
||||||
|
regsub -- {-.*$} $version {} version |
||||||
|
} |
||||||
|
foreach {config map} $mapping { |
||||||
|
if {![string match $config $platform]} continue |
||||||
|
set minver [lindex $map 1] |
||||||
|
if {[package vcompare $version $minver] < 0} continue |
||||||
|
set platform [lindex $map 0] |
||||||
|
break |
||||||
|
} |
||||||
|
return $platform |
||||||
|
} |
||||||
|
|
||||||
|
# Dummy implementation of the critcl package, if not present |
||||||
|
if {![llength [info commands ::critcl::Ignore]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::Ignore {args} { |
||||||
|
namespace eval ::critcl::v {} |
||||||
|
set ::critcl::v::ignore([file normalize [lindex $args 0]]) . |
||||||
|
} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::api]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::api {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::at]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::at {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::cache]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::cache {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::ccode]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::ccode {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::ccommand]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::ccommand {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::cdata]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::cdata {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::cdefines]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::cdefines {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::cflags]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::cflags {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::cheaders]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::cheaders {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::check]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::check {args} {return 0} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::cinit]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::cinit {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::clibraries]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::clibraries {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::compiled]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::compiled {args} {return 1} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::compiling]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::compiling {args} {return 0} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::config]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::config {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::cproc]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::cproc {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::csources]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::csources {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::debug]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::debug {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::done]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::done {args} {return 1} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::failed]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::failed {args} {return 0} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::framework]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::framework {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::include]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::include {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::ldflags]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::ldflags {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::license]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::license {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::load]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::load {args} {return 1} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::make]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::make {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::meta]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::meta {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::platform]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::platform {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::preload]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::preload {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::source]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::source {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::tcl]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::tcl {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::tk]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::tk {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::tsources]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::tsources {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::userconfig]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::userconfig {args} {} |
||||||
|
} |
||||||
|
|
||||||
|
# Define a clone of platform::generic, if needed |
||||||
|
if {![llength [info commands ::platform::generic]]} { |
||||||
|
namespace eval ::platform {} |
||||||
|
proc ::platform::generic {} { |
||||||
|
global tcl_platform |
||||||
|
|
||||||
|
set plat [string tolower [lindex $tcl_platform(os) 0]] |
||||||
|
set cpu $tcl_platform(machine) |
||||||
|
|
||||||
|
switch -glob -- $cpu { |
||||||
|
sun4* { |
||||||
|
set cpu sparc |
||||||
|
} |
||||||
|
intel - |
||||||
|
ia32* - |
||||||
|
i*86* { |
||||||
|
set cpu ix86 |
||||||
|
} |
||||||
|
x86_64 { |
||||||
|
if {$tcl_platform(wordSize) == 4} { |
||||||
|
# See Example <1> at the top of this file. |
||||||
|
set cpu ix86 |
||||||
|
} |
||||||
|
} |
||||||
|
ppc - |
||||||
|
"Power*" { |
||||||
|
set cpu powerpc |
||||||
|
} |
||||||
|
"arm*" { |
||||||
|
set cpu arm |
||||||
|
} |
||||||
|
ia64 { |
||||||
|
if {$tcl_platform(wordSize) == 4} { |
||||||
|
append cpu _32 |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
switch -glob -- $plat { |
||||||
|
windows { |
||||||
|
if {$tcl_platform(platform) == "unix"} { |
||||||
|
set plat cygwin |
||||||
|
} else { |
||||||
|
set plat win32 |
||||||
|
} |
||||||
|
if {$cpu eq "amd64"} { |
||||||
|
# Do not check wordSize, win32-x64 is an IL32P64 platform. |
||||||
|
set cpu x86_64 |
||||||
|
} |
||||||
|
} |
||||||
|
sunos { |
||||||
|
set plat solaris |
||||||
|
if {[string match "ix86" $cpu]} { |
||||||
|
if {$tcl_platform(wordSize) == 8} { |
||||||
|
set cpu x86_64 |
||||||
|
} |
||||||
|
} elseif {![string match "ia64*" $cpu]} { |
||||||
|
# sparc |
||||||
|
if {$tcl_platform(wordSize) == 8} { |
||||||
|
append cpu 64 |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
darwin { |
||||||
|
set plat macosx |
||||||
|
# Correctly identify the cpu when running as a 64bit |
||||||
|
# process on a machine with a 32bit kernel |
||||||
|
if {$cpu eq "ix86"} { |
||||||
|
if {$tcl_platform(wordSize) == 8} { |
||||||
|
set cpu x86_64 |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
aix { |
||||||
|
set cpu powerpc |
||||||
|
if {$tcl_platform(wordSize) == 8} { |
||||||
|
append cpu 64 |
||||||
|
} |
||||||
|
} |
||||||
|
hp-ux { |
||||||
|
set plat hpux |
||||||
|
if {![string match "ia64*" $cpu]} { |
||||||
|
set cpu parisc |
||||||
|
if {$tcl_platform(wordSize) == 8} { |
||||||
|
append cpu 64 |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
osf1 { |
||||||
|
set plat tru64 |
||||||
|
} |
||||||
|
default { |
||||||
|
set plat [lindex [split $plat _-] 0] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
return "${plat}-${cpu}" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
@ -0,0 +1 @@ |
|||||||
|
<<Undefined>> |
||||||
Binary file not shown.
@ -0,0 +1,2 @@ |
|||||||
|
if {![package vsatisfies [package provide Tcl] 9.0]} {return} |
||||||
|
package ifneeded tcllibc 2.0 "[list proc __critcl_load__ {dir} { ; source [file join $dir critcl-rt.tcl] ; set path [file join $dir [::critcl::runtime::MapPlatform]] ; set ext [info sharedlibextension] ; set lib [file join $path "tcllibc$ext"] ; load $lib Tcllibc ; package provide tcllibc 2.0 ; catch {rename __critcl_load__ {}}}] ; [list __critcl_load__ $dir]" |
||||||
@ -0,0 +1,21 @@ |
|||||||
|
Package tcllibc 2.0 |
||||||
|
Meta platform linux-glibc2.22-x86_64 |
||||||
|
Meta build::date 2025-08-20 |
||||||
|
Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier |
||||||
|
Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier |
||||||
|
Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier |
||||||
|
Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier |
||||||
|
Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier |
||||||
|
Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier |
||||||
|
Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier |
||||||
|
Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier |
||||||
|
Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier |
||||||
|
Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier |
||||||
|
Meta generated::date critcl |
||||||
|
Meta license BSD licensed. |
||||||
|
Meta author {Andreas Kupries} |
||||||
|
Meta require {Tcl 8.5 9} {Tcl 8.5 9} {Tcl 8.5 9} {Tcl 8.5 9} {Tcl 8.5 9} |
||||||
|
Meta require {Tcl 8.5 9} {Tcl 8.5 9} {Tcl 8.5 9} {Tcl 8.5 9} {Tcl 8.5 9} |
||||||
|
Meta require {Tcl 8.5 9} {Tcl 8.5 9} |
||||||
|
Meta entrytclcommand {eval "[list proc __critcl_load__ {dir} { ; source [file join $dir critcl-rt.tcl] ; set path [file join $dir [::critcl::runtime::MapPlatform]] ; set ext [info sharedlibextension] ; set lib [file join $path "tcllibc$ext"] ; load $lib Tcllibc ; package provide tcllibc 2.0 ; catch {rename __critcl_load__ {}}}] ; [list __critcl_load__ $dir]"} |
||||||
|
Meta included critcl-rt.tcl linux-x86_64/tcllibc.so |
||||||
@ -0,0 +1,381 @@ |
|||||||
|
# |
||||||
|
# Critcl - build C extensions on-the-fly |
||||||
|
# |
||||||
|
# Copyright (c) 2001-2007 Jean-Claude Wippler |
||||||
|
# Copyright (c) 2002-2007 Steve Landers |
||||||
|
# |
||||||
|
# See http://wiki.tcl.tk/critcl |
||||||
|
# |
||||||
|
# This is the Critcl runtime that loads the appropriate |
||||||
|
# shared library when a package is requested |
||||||
|
# |
||||||
|
|
||||||
|
namespace eval ::critcl::runtime {} |
||||||
|
|
||||||
|
proc ::critcl::runtime::loadlib {dir package version libname initfun tsrc mapping args} { |
||||||
|
# XXX At least parts of this can be done by the package generator, |
||||||
|
# XXX like listing the Tcl files to source. The glob here allows |
||||||
|
# XXX code-injection after-the-fact, by simply adding a .tcl in |
||||||
|
# XXX the proper place. |
||||||
|
set path [file join $dir [MapPlatform $mapping]] |
||||||
|
set ext [info sharedlibextension] |
||||||
|
set lib [file join $path $libname$ext] |
||||||
|
set provide [list] |
||||||
|
|
||||||
|
# Now the runtime equivalent of a series of 'preFetch' commands. |
||||||
|
if {[llength $args]} { |
||||||
|
set preload [file join $path preload$ext] |
||||||
|
foreach p $args { |
||||||
|
set prelib [file join $path $p$ext] |
||||||
|
if {[file readable $preload] && [file readable $prelib]} { |
||||||
|
lappend provide [list load $preload];# XXX Move this out of the loop, do only once. |
||||||
|
lappend provide [list ::critcl::runtime::preload $prelib] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
lappend provide [list load $lib $initfun] |
||||||
|
foreach t $tsrc { |
||||||
|
lappend loadcmd "::critcl::runtime::Fetch \$dir [list $t]" |
||||||
|
} |
||||||
|
lappend provide "package provide $package $version" |
||||||
|
package ifneeded $package $version [join $provide "\n"] |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc ::critcl::runtime::preFetch {path ext dll} { |
||||||
|
set preload [file join $path preload$ext] |
||||||
|
if {![file readable $preload]} return |
||||||
|
|
||||||
|
set prelib [file join $path $dll$ext] |
||||||
|
if {![file readable $prelib]} return |
||||||
|
|
||||||
|
load $preload ; # Defines next command. |
||||||
|
::critcl::runtime::preload $prelib |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc ::critcl::runtime::Fetch {dir t} { |
||||||
|
# The 'Ignore' disables compile & run functionality. |
||||||
|
|
||||||
|
# Background: If the regular critcl package is already loaded, and |
||||||
|
# this prebuilt package uses its defining .tcl file also as a |
||||||
|
# 'tsources' then critcl might try to collect data and build it |
||||||
|
# because of the calls to its API, despite the necessary binaries |
||||||
|
# already being present, just not in the critcl cache. That is |
||||||
|
# redundant in the best case, and fails in the worst case (no |
||||||
|
# compiler), preventing the use o a perfectly fine package. The |
||||||
|
# 'ignore' call now tells critcl that it should ignore any calls |
||||||
|
# made to it by the sourced files, and thus avoids that trouble. |
||||||
|
|
||||||
|
# The other case, the regular critcl package getting loaded after |
||||||
|
# this prebuilt package is irrelevant. At that point the tsources |
||||||
|
# were already run, and used the dummy procedures defined in the |
||||||
|
# critcl-rt.tcl, which ignore the calls by definition. |
||||||
|
|
||||||
|
set t [file join $dir tcl $t] |
||||||
|
::critcl::Ignore $t |
||||||
|
uplevel #0 [list source $t] |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc ::critcl::runtime::precopy {dll} { |
||||||
|
# This command is only used on Windows when preloading out of a |
||||||
|
# VFS that doesn't support direct loading (usually, a Starkit) |
||||||
|
# - we preserve the dll name so that dependencies are satisfied |
||||||
|
# - The critcl::runtime::preload command is defined in the supporting |
||||||
|
# "preload" package, implemented in "critcl/lib/critcl/critcl_c/preload.c" |
||||||
|
|
||||||
|
global env |
||||||
|
if {[info exists env(TEMP)]} { |
||||||
|
set dir $env(TEMP) |
||||||
|
} elseif {[info exists env(TMP)]} { |
||||||
|
set dir $env(TMP) |
||||||
|
} elseif {[file exists $env(HOME)]} { |
||||||
|
set dir $env(HOME) |
||||||
|
} else { |
||||||
|
set dir . |
||||||
|
} |
||||||
|
set dir [file join $dir TCL[pid]] |
||||||
|
set i 0 |
||||||
|
while {[file exists $dir]} { |
||||||
|
append dir [incr i] |
||||||
|
} |
||||||
|
set new [file join $dir [file tail $dll]] |
||||||
|
file mkdir $dir |
||||||
|
file copy $dll $new |
||||||
|
return $new |
||||||
|
} |
||||||
|
|
||||||
|
proc ::critcl::runtime::MapPlatform {{mapping {}}} { |
||||||
|
# A sibling of critcl::platform that applies the platform mapping |
||||||
|
|
||||||
|
set platform [::platform::generic] |
||||||
|
set version $::tcl_platform(osVersion) |
||||||
|
if {[string match "macosx-*" $platform]} { |
||||||
|
# "normalize" the osVersion to match OSX release numbers |
||||||
|
set v [split $version .] |
||||||
|
set v1 [lindex $v 0] |
||||||
|
set v2 [lindex $v 1] |
||||||
|
incr v1 -4 |
||||||
|
set version 10.$v1.$v2 |
||||||
|
} else { |
||||||
|
# Strip trailing non-version info |
||||||
|
regsub -- {-.*$} $version {} version |
||||||
|
} |
||||||
|
foreach {config map} $mapping { |
||||||
|
if {![string match $config $platform]} continue |
||||||
|
set minver [lindex $map 1] |
||||||
|
if {[package vcompare $version $minver] < 0} continue |
||||||
|
set platform [lindex $map 0] |
||||||
|
break |
||||||
|
} |
||||||
|
return $platform |
||||||
|
} |
||||||
|
|
||||||
|
# Dummy implementation of the critcl package, if not present |
||||||
|
if {![llength [info commands ::critcl::Ignore]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::Ignore {args} { |
||||||
|
namespace eval ::critcl::v {} |
||||||
|
set ::critcl::v::ignore([file normalize [lindex $args 0]]) . |
||||||
|
} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::api]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::api {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::at]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::at {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::cache]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::cache {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::ccode]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::ccode {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::ccommand]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::ccommand {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::cdata]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::cdata {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::cdefines]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::cdefines {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::cflags]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::cflags {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::cheaders]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::cheaders {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::check]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::check {args} {return 0} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::cinit]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::cinit {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::clibraries]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::clibraries {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::compiled]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::compiled {args} {return 1} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::compiling]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::compiling {args} {return 0} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::config]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::config {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::cproc]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::cproc {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::csources]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::csources {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::debug]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::debug {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::done]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::done {args} {return 1} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::failed]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::failed {args} {return 0} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::framework]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::framework {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::include]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::include {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::ldflags]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::ldflags {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::license]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::license {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::load]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::load {args} {return 1} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::make]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::make {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::meta]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::meta {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::platform]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::platform {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::preload]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::preload {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::source]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::source {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::tcl]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::tcl {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::tk]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::tk {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::tsources]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::tsources {args} {} |
||||||
|
} |
||||||
|
if {![llength [info commands ::critcl::userconfig]]} { |
||||||
|
namespace eval ::critcl {} |
||||||
|
proc ::critcl::userconfig {args} {} |
||||||
|
} |
||||||
|
|
||||||
|
# Define a clone of platform::generic, if needed |
||||||
|
if {![llength [info commands ::platform::generic]]} { |
||||||
|
namespace eval ::platform {} |
||||||
|
proc ::platform::generic {} { |
||||||
|
global tcl_platform |
||||||
|
|
||||||
|
set plat [string tolower [lindex $tcl_platform(os) 0]] |
||||||
|
set cpu $tcl_platform(machine) |
||||||
|
|
||||||
|
switch -glob -- $cpu { |
||||||
|
sun4* { |
||||||
|
set cpu sparc |
||||||
|
} |
||||||
|
intel - |
||||||
|
ia32* - |
||||||
|
i*86* { |
||||||
|
set cpu ix86 |
||||||
|
} |
||||||
|
x86_64 { |
||||||
|
if {$tcl_platform(wordSize) == 4} { |
||||||
|
# See Example <1> at the top of this file. |
||||||
|
set cpu ix86 |
||||||
|
} |
||||||
|
} |
||||||
|
ppc - |
||||||
|
"Power*" { |
||||||
|
set cpu powerpc |
||||||
|
} |
||||||
|
"arm*" { |
||||||
|
set cpu arm |
||||||
|
} |
||||||
|
ia64 { |
||||||
|
if {$tcl_platform(wordSize) == 4} { |
||||||
|
append cpu _32 |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
switch -glob -- $plat { |
||||||
|
windows { |
||||||
|
if {$tcl_platform(platform) == "unix"} { |
||||||
|
set plat cygwin |
||||||
|
} else { |
||||||
|
set plat win32 |
||||||
|
} |
||||||
|
if {$cpu eq "amd64"} { |
||||||
|
# Do not check wordSize, win32-x64 is an IL32P64 platform. |
||||||
|
set cpu x86_64 |
||||||
|
} |
||||||
|
} |
||||||
|
sunos { |
||||||
|
set plat solaris |
||||||
|
if {[string match "ix86" $cpu]} { |
||||||
|
if {$tcl_platform(wordSize) == 8} { |
||||||
|
set cpu x86_64 |
||||||
|
} |
||||||
|
} elseif {![string match "ia64*" $cpu]} { |
||||||
|
# sparc |
||||||
|
if {$tcl_platform(wordSize) == 8} { |
||||||
|
append cpu 64 |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
darwin { |
||||||
|
set plat macosx |
||||||
|
# Correctly identify the cpu when running as a 64bit |
||||||
|
# process on a machine with a 32bit kernel |
||||||
|
if {$cpu eq "ix86"} { |
||||||
|
if {$tcl_platform(wordSize) == 8} { |
||||||
|
set cpu x86_64 |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
aix { |
||||||
|
set cpu powerpc |
||||||
|
if {$tcl_platform(wordSize) == 8} { |
||||||
|
append cpu 64 |
||||||
|
} |
||||||
|
} |
||||||
|
hp-ux { |
||||||
|
set plat hpux |
||||||
|
if {![string match "ia64*" $cpu]} { |
||||||
|
set cpu parisc |
||||||
|
if {$tcl_platform(wordSize) == 8} { |
||||||
|
append cpu 64 |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
osf1 { |
||||||
|
set plat tru64 |
||||||
|
} |
||||||
|
default { |
||||||
|
set plat [lindex [split $plat _-] 0] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
return "${plat}-${cpu}" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
@ -0,0 +1 @@ |
|||||||
|
<<Undefined>> |
||||||
Binary file not shown.
@ -0,0 +1,2 @@ |
|||||||
|
if {![package vsatisfies [package provide Tcl] 9.0]} {return} |
||||||
|
package ifneeded tcllibc 2.0 "[list proc __critcl_load__ {dir} { ; source [file join $dir critcl-rt.tcl] ; set path [file join $dir [::critcl::runtime::MapPlatform]] ; set ext [info sharedlibextension] ; set lib [file join $path "tcllibc$ext"] ; load $lib Tcllibc ; package provide tcllibc 2.0 ; catch {rename __critcl_load__ {}}}] ; [list __critcl_load__ $dir]" |
||||||
@ -0,0 +1,21 @@ |
|||||||
|
Package tcllibc 2.0 |
||||||
|
Meta platform linux-glibc2.22-x86_64 |
||||||
|
Meta build::date 2025-08-20 |
||||||
|
Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier |
||||||
|
Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier |
||||||
|
Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier |
||||||
|
Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier |
||||||
|
Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier |
||||||
|
Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier |
||||||
|
Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier |
||||||
|
Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier |
||||||
|
Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier |
||||||
|
Meta generated::by {critcl 3.3} obermeier {critcl 3.3} obermeier |
||||||
|
Meta generated::date critcl |
||||||
|
Meta license BSD licensed. |
||||||
|
Meta author {Andreas Kupries} |
||||||
|
Meta require {Tcl 8.5 9} {Tcl 8.5 9} {Tcl 8.5 9} {Tcl 8.5 9} {Tcl 8.5 9} |
||||||
|
Meta require {Tcl 8.5 9} {Tcl 8.5 9} {Tcl 8.5 9} {Tcl 8.5 9} {Tcl 8.5 9} |
||||||
|
Meta require {Tcl 8.5 9} {Tcl 8.5 9} |
||||||
|
Meta entrytclcommand {eval "[list proc __critcl_load__ {dir} { ; source [file join $dir critcl-rt.tcl] ; set path [file join $dir [::critcl::runtime::MapPlatform]] ; set ext [info sharedlibextension] ; set lib [file join $path "tcllibc$ext"] ; load $lib Tcllibc ; package provide tcllibc 2.0 ; catch {rename __critcl_load__ {}}}] ; [list __critcl_load__ $dir]"} |
||||||
|
Meta included critcl-rt.tcl linux-x86_64/tcllibc.so |
||||||
@ -0,0 +1,16 @@ |
|||||||
|
if {[package vsatisfies [package present Tcl] 8.5-]} { |
||||||
|
package ifneeded tls 1.7.23 [list apply {{dir} { |
||||||
|
if {{shared} eq "static"} { |
||||||
|
load {} Tls |
||||||
|
} else { |
||||||
|
load [file join $dir tcltls.so] Tls |
||||||
|
} |
||||||
|
|
||||||
|
set tlsTclInitScript [file join $dir tls.tcl] |
||||||
|
if {[file exists $tlsTclInitScript]} { |
||||||
|
source $tlsTclInitScript |
||||||
|
} |
||||||
|
}} $dir] |
||||||
|
} elseif {[package vsatisfies [package present Tcl] 8.4]} { |
||||||
|
package ifneeded tls 1.7.23 [list load [file join $dir tcltls.so] Tls] |
||||||
|
} |
||||||
Binary file not shown.
@ -0,0 +1,398 @@ |
|||||||
|
# |
||||||
|
# Copyright (C) 1997-2000 Matt Newman <matt@novadigm.com> |
||||||
|
# |
||||||
|
namespace eval tls { |
||||||
|
variable logcmd tclLog |
||||||
|
variable debug 0 |
||||||
|
|
||||||
|
# Default flags passed to tls::import |
||||||
|
variable defaults {} |
||||||
|
|
||||||
|
# Maps UID to Server Socket |
||||||
|
variable srvmap |
||||||
|
variable srvuid 0 |
||||||
|
|
||||||
|
# Over-ride this if you are using a different socket command |
||||||
|
variable socketCmd |
||||||
|
if {![info exists socketCmd]} { |
||||||
|
set socketCmd [info command ::socket] |
||||||
|
} |
||||||
|
|
||||||
|
# This is the possible arguments to tls::socket and tls::init |
||||||
|
# The format of this is a list of lists |
||||||
|
## Each inner list contains the following elements |
||||||
|
### Server (matched against "string match" for 0/1) |
||||||
|
### Option name |
||||||
|
### Variable to add the option to: |
||||||
|
#### sopts: [socket] option |
||||||
|
#### iopts: [tls::import] option |
||||||
|
### How many arguments the following the option to consume |
||||||
|
variable socketOptionRules { |
||||||
|
{0 -async sopts 0} |
||||||
|
{* -myaddr sopts 1} |
||||||
|
{0 -myport sopts 1} |
||||||
|
{* -type sopts 1} |
||||||
|
{* -cadir iopts 1} |
||||||
|
{* -cafile iopts 1} |
||||||
|
{* -cert iopts 1} |
||||||
|
{* -certfile iopts 1} |
||||||
|
{* -cipher iopts 1} |
||||||
|
{* -command iopts 1} |
||||||
|
{* -dhparams iopts 1} |
||||||
|
{* -key iopts 1} |
||||||
|
{* -keyfile iopts 1} |
||||||
|
{* -password iopts 1} |
||||||
|
{* -request iopts 1} |
||||||
|
{* -require iopts 1} |
||||||
|
{* -autoservername discardOpts 1} |
||||||
|
{* -servername iopts 1} |
||||||
|
{* -ssl2 iopts 1} |
||||||
|
{* -ssl3 iopts 1} |
||||||
|
{* -tls1 iopts 1} |
||||||
|
{* -tls1.1 iopts 1} |
||||||
|
{* -tls1.2 iopts 1} |
||||||
|
{* -tls1.3 iopts 1} |
||||||
|
} |
||||||
|
|
||||||
|
# tls::socket and tls::init options as a humane readable string |
||||||
|
variable socketOptionsNoServer |
||||||
|
variable socketOptionsServer |
||||||
|
|
||||||
|
# Internal [switch] body to validate options |
||||||
|
variable socketOptionsSwitchBody |
||||||
|
} |
||||||
|
|
||||||
|
proc tls::_initsocketoptions {} { |
||||||
|
variable socketOptionRules |
||||||
|
variable socketOptionsNoServer |
||||||
|
variable socketOptionsServer |
||||||
|
variable socketOptionsSwitchBody |
||||||
|
|
||||||
|
# Do not re-run if we have already been initialized |
||||||
|
if {[info exists socketOptionsSwitchBody]} { |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# Create several structures from our list of options |
||||||
|
## 1. options: a text representation of the valid options for the current |
||||||
|
## server type |
||||||
|
## 2. argSwitchBody: Switch body for processing arguments |
||||||
|
set options(0) [list] |
||||||
|
set options(1) [list] |
||||||
|
set argSwitchBody [list] |
||||||
|
foreach optionRule $socketOptionRules { |
||||||
|
set ruleServer [lindex $optionRule 0] |
||||||
|
set ruleOption [lindex $optionRule 1] |
||||||
|
set ruleVarToUpdate [lindex $optionRule 2] |
||||||
|
set ruleVarArgsToConsume [lindex $optionRule 3] |
||||||
|
|
||||||
|
foreach server [list 0 1] { |
||||||
|
if {![string match $ruleServer $server]} { |
||||||
|
continue |
||||||
|
} |
||||||
|
|
||||||
|
lappend options($server) $ruleOption |
||||||
|
} |
||||||
|
|
||||||
|
switch -- $ruleVarArgsToConsume { |
||||||
|
0 { |
||||||
|
set argToExecute { |
||||||
|
lappend @VAR@ $arg |
||||||
|
set argsArray($arg) true |
||||||
|
} |
||||||
|
} |
||||||
|
1 { |
||||||
|
set argToExecute { |
||||||
|
incr idx |
||||||
|
if {$idx >= [llength $args]} { |
||||||
|
return -code error "\"$arg\" option must be followed by value" |
||||||
|
} |
||||||
|
set argValue [lindex $args $idx] |
||||||
|
lappend @VAR@ $arg $argValue |
||||||
|
set argsArray($arg) $argValue |
||||||
|
} |
||||||
|
} |
||||||
|
default { |
||||||
|
return -code error "Internal argument construction error" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
lappend argSwitchBody $ruleServer,$ruleOption [string map [list @VAR@ $ruleVarToUpdate] $argToExecute] |
||||||
|
} |
||||||
|
|
||||||
|
# Add in the final options |
||||||
|
lappend argSwitchBody {*,-*} {return -code error "bad option \"$arg\": must be one of $options"} |
||||||
|
lappend argSwitchBody default break |
||||||
|
|
||||||
|
# Set the final variables |
||||||
|
set socketOptionsNoServer [join $options(0) {, }] |
||||||
|
set socketOptionsServer [join $options(1) {, }] |
||||||
|
set socketOptionsSwitchBody $argSwitchBody |
||||||
|
} |
||||||
|
|
||||||
|
proc tls::initlib {dir dll} { |
||||||
|
# Package index cd's into the package directory for loading. |
||||||
|
# Irrelevant to unixoids, but for Windows this enables the OS to find |
||||||
|
# the dependent DLL's in the CWD, where they may be. |
||||||
|
set cwd [pwd] |
||||||
|
catch {cd $dir} |
||||||
|
if {[string equal $::tcl_platform(platform) "windows"] && |
||||||
|
![string equal [lindex [file system $dir] 0] "native"]} { |
||||||
|
# If it is a wrapped executable running on windows, the openssl |
||||||
|
# dlls must be copied out of the virtual filesystem to the disk |
||||||
|
# where Windows will find them when resolving the dependency in |
||||||
|
# the tls dll. We choose to make them siblings of the executable. |
||||||
|
package require starkit |
||||||
|
set dst [file nativename [file dirname $starkit::topdir]] |
||||||
|
foreach sdll [glob -nocomplain -directory $dir -tails *eay32.dll] { |
||||||
|
catch {file delete -force $dst/$sdll} |
||||||
|
catch {file copy -force $dir/$sdll $dst/$sdll} |
||||||
|
} |
||||||
|
} |
||||||
|
set res [catch {uplevel #0 [list load [file join [pwd] $dll]]} err] |
||||||
|
catch {cd $cwd} |
||||||
|
if {$res} { |
||||||
|
namespace eval [namespace parent] {namespace delete tls} |
||||||
|
return -code $res $err |
||||||
|
} |
||||||
|
rename tls::initlib {} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# |
||||||
|
# Backwards compatibility, also used to set the default |
||||||
|
# context options |
||||||
|
# |
||||||
|
proc tls::init {args} { |
||||||
|
variable defaults |
||||||
|
variable socketOptionsNoServer |
||||||
|
variable socketOptionsServer |
||||||
|
variable socketOptionsSwitchBody |
||||||
|
|
||||||
|
tls::_initsocketoptions |
||||||
|
|
||||||
|
# Technically a third option should be used here: Options that are valid |
||||||
|
# only a both servers and non-servers |
||||||
|
set server -1 |
||||||
|
set options $socketOptionsServer |
||||||
|
|
||||||
|
# Validate arguments passed |
||||||
|
set initialArgs $args |
||||||
|
set argc [llength $args] |
||||||
|
|
||||||
|
array set argsArray [list] |
||||||
|
for {set idx 0} {$idx < $argc} {incr idx} { |
||||||
|
set arg [lindex $args $idx] |
||||||
|
switch -glob -- $server,$arg $socketOptionsSwitchBody |
||||||
|
} |
||||||
|
|
||||||
|
set defaults $initialArgs |
||||||
|
} |
||||||
|
# |
||||||
|
# Helper function - behaves exactly as the native socket command. |
||||||
|
# |
||||||
|
proc tls::socket {args} { |
||||||
|
variable socketCmd |
||||||
|
variable defaults |
||||||
|
variable socketOptionsNoServer |
||||||
|
variable socketOptionsServer |
||||||
|
variable socketOptionsSwitchBody |
||||||
|
|
||||||
|
tls::_initsocketoptions |
||||||
|
|
||||||
|
set idx [lsearch $args -server] |
||||||
|
if {$idx != -1} { |
||||||
|
set server 1 |
||||||
|
set callback [lindex $args [expr {$idx+1}]] |
||||||
|
set args [lreplace $args $idx [expr {$idx+1}]] |
||||||
|
|
||||||
|
set usage "wrong # args: should be \"tls::socket -server command ?options? port\"" |
||||||
|
set options $socketOptionsServer |
||||||
|
} else { |
||||||
|
set server 0 |
||||||
|
|
||||||
|
set usage "wrong # args: should be \"tls::socket ?options? host port\"" |
||||||
|
set options $socketOptionsNoServer |
||||||
|
} |
||||||
|
|
||||||
|
# Combine defaults with current options |
||||||
|
set args [concat $defaults $args] |
||||||
|
|
||||||
|
set argc [llength $args] |
||||||
|
set sopts {} |
||||||
|
set iopts [list -server $server] |
||||||
|
|
||||||
|
array set argsArray [list] |
||||||
|
for {set idx 0} {$idx < $argc} {incr idx} { |
||||||
|
set arg [lindex $args $idx] |
||||||
|
switch -glob -- $server,$arg $socketOptionsSwitchBody |
||||||
|
} |
||||||
|
|
||||||
|
if {$server} { |
||||||
|
if {($idx + 1) != $argc} { |
||||||
|
return -code error $usage |
||||||
|
} |
||||||
|
set uid [incr ::tls::srvuid] |
||||||
|
|
||||||
|
set port [lindex $args [expr {$argc-1}]] |
||||||
|
lappend sopts $port |
||||||
|
#set sopts [linsert $sopts 0 -server $callback] |
||||||
|
set sopts [linsert $sopts 0 -server [list tls::_accept $iopts $callback]] |
||||||
|
#set sopts [linsert $sopts 0 -server [list tls::_accept $uid $callback]] |
||||||
|
} else { |
||||||
|
if {($idx + 2) != $argc} { |
||||||
|
return -code error $usage |
||||||
|
} |
||||||
|
|
||||||
|
set host [lindex $args [expr {$argc-2}]] |
||||||
|
set port [lindex $args [expr {$argc-1}]] |
||||||
|
|
||||||
|
# If an "-autoservername" option is found, honor it |
||||||
|
if {[info exists argsArray(-autoservername)] && $argsArray(-autoservername)} { |
||||||
|
if {![info exists argsArray(-servername)]} { |
||||||
|
set argsArray(-servername) $host |
||||||
|
lappend iopts -servername $host |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
lappend sopts $host $port |
||||||
|
} |
||||||
|
# |
||||||
|
# Create TCP/IP socket |
||||||
|
# |
||||||
|
set chan [eval $socketCmd $sopts] |
||||||
|
if {!$server && [catch { |
||||||
|
# |
||||||
|
# Push SSL layer onto socket |
||||||
|
# |
||||||
|
eval [list tls::import] $chan $iopts |
||||||
|
} err]} { |
||||||
|
set info ${::errorInfo} |
||||||
|
catch {close $chan} |
||||||
|
return -code error -errorinfo $info $err |
||||||
|
} |
||||||
|
return $chan |
||||||
|
} |
||||||
|
|
||||||
|
# tls::_accept -- |
||||||
|
# |
||||||
|
# This is the actual accept that TLS sockets use, which then calls |
||||||
|
# the callback registered by tls::socket. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# iopts tls::import opts |
||||||
|
# callback server callback to invoke |
||||||
|
# chan socket channel to accept/deny |
||||||
|
# ipaddr calling IP address |
||||||
|
# port calling port |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# Returns an error if the callback throws one. |
||||||
|
# |
||||||
|
proc tls::_accept { iopts callback chan ipaddr port } { |
||||||
|
log 2 [list tls::_accept $iopts $callback $chan $ipaddr $port] |
||||||
|
|
||||||
|
set chan [eval [list tls::import $chan] $iopts] |
||||||
|
|
||||||
|
lappend callback $chan $ipaddr $port |
||||||
|
if {[catch { |
||||||
|
uplevel #0 $callback |
||||||
|
} err]} { |
||||||
|
log 1 "tls::_accept error: ${::errorInfo}" |
||||||
|
close $chan |
||||||
|
error $err $::errorInfo $::errorCode |
||||||
|
} else { |
||||||
|
log 2 "tls::_accept - called \"$callback\" succeeded" |
||||||
|
} |
||||||
|
} |
||||||
|
# |
||||||
|
# Sample callback for hooking: - |
||||||
|
# |
||||||
|
# error |
||||||
|
# verify |
||||||
|
# info |
||||||
|
# |
||||||
|
proc tls::callback {option args} { |
||||||
|
variable debug |
||||||
|
|
||||||
|
#log 2 [concat $option $args] |
||||||
|
|
||||||
|
switch -- $option { |
||||||
|
"error" { |
||||||
|
foreach {chan msg} $args break |
||||||
|
|
||||||
|
log 0 "TLS/$chan: error: $msg" |
||||||
|
} |
||||||
|
"verify" { |
||||||
|
# poor man's lassign |
||||||
|
foreach {chan depth cert rc err} $args break |
||||||
|
|
||||||
|
array set c $cert |
||||||
|
|
||||||
|
if {$rc != "1"} { |
||||||
|
log 1 "TLS/$chan: verify/$depth: Bad Cert: $err (rc = $rc)" |
||||||
|
} else { |
||||||
|
log 2 "TLS/$chan: verify/$depth: $c(subject)" |
||||||
|
} |
||||||
|
if {$debug > 0} { |
||||||
|
return 1; # FORCE OK |
||||||
|
} else { |
||||||
|
return $rc |
||||||
|
} |
||||||
|
} |
||||||
|
"info" { |
||||||
|
# poor man's lassign |
||||||
|
foreach {chan major minor state msg} $args break |
||||||
|
|
||||||
|
if {$msg != ""} { |
||||||
|
append state ": $msg" |
||||||
|
} |
||||||
|
# For tracing |
||||||
|
upvar #0 tls::$chan cb |
||||||
|
set cb($major) $minor |
||||||
|
|
||||||
|
log 2 "TLS/$chan: $major/$minor: $state" |
||||||
|
} |
||||||
|
default { |
||||||
|
return -code error "bad option \"$option\":\ |
||||||
|
must be one of error, info, or verify" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc tls::xhandshake {chan} { |
||||||
|
upvar #0 tls::$chan cb |
||||||
|
|
||||||
|
if {[info exists cb(handshake)] && \ |
||||||
|
$cb(handshake) == "done"} { |
||||||
|
return 1 |
||||||
|
} |
||||||
|
while {1} { |
||||||
|
vwait tls::${chan}(handshake) |
||||||
|
if {![info exists cb(handshake)]} { |
||||||
|
return 0 |
||||||
|
} |
||||||
|
if {$cb(handshake) == "done"} { |
||||||
|
return 1 |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc tls::password {} { |
||||||
|
log 0 "TLS/Password: did you forget to set your passwd!" |
||||||
|
# Return the worlds best kept secret password. |
||||||
|
return "secret" |
||||||
|
} |
||||||
|
|
||||||
|
proc tls::log {level msg} { |
||||||
|
variable debug |
||||||
|
variable logcmd |
||||||
|
|
||||||
|
if {$level > $debug || $logcmd == ""} { |
||||||
|
return |
||||||
|
} |
||||||
|
set cmd $logcmd |
||||||
|
lappend cmd $msg |
||||||
|
uplevel #0 $cmd |
||||||
|
} |
||||||
|
|
||||||
Binary file not shown.
Binary file not shown.
@ -0,0 +1,12 @@ |
|||||||
|
# |
||||||
|
# Tcl package index file |
||||||
|
# |
||||||
|
if {[package vsatisfies [package provide Tcl] 9.0-]} { |
||||||
|
package ifneeded tdom 0.9.6 \ |
||||||
|
"[list load [file join $dir libtcl9tdom0.9.6.so]]; |
||||||
|
[list source [file join $dir tdom.tcl]]" |
||||||
|
} else { |
||||||
|
package ifneeded tdom 0.9.6 \ |
||||||
|
"[list load [file join $dir libtdom0.9.6.so]]; |
||||||
|
[list source [file join $dir tdom.tcl]]" |
||||||
|
} |
||||||
File diff suppressed because it is too large
Load Diff
Binary file not shown.
@ -0,0 +1,55 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Tcl package index file, version 1.1 |
||||||
|
# |
||||||
|
|
||||||
|
# Tcl 8.7 interps are only supported on 32-bit platforms. |
||||||
|
# Lower than that is never supported. Bye! |
||||||
|
if {![package vsatisfies [package provide Tcl] 9.0] |
||||||
|
&& ((![package vsatisfies [package provide Tcl] 8.7]) |
||||||
|
|| ($::tcl_platform(pointerSize)!=4))} { |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# All Tcl 8.7+ interps can [load] thread 3.0.2 |
||||||
|
# |
||||||
|
# For interps that are not thread-enabled, we still call [package ifneeded]. |
||||||
|
# This is contrary to the usual convention, but is a good idea because we |
||||||
|
# cannot imagine any other version of thread that might succeed in a |
||||||
|
# thread-disabled interp. There's nothing to gain by yielding to other |
||||||
|
# competing callers of [package ifneeded Thread]. On the other hand, |
||||||
|
# deferring the error has the advantage that a script calling |
||||||
|
# [package require Thread] in a thread-disabled interp gets an error message |
||||||
|
# about a thread-disabled interp, instead of the message |
||||||
|
# "can't find package thread". |
||||||
|
|
||||||
|
package ifneeded [string tolower thread] 3.0.2 \ |
||||||
|
[list load [file join $dir libtcl9thread3.0.2.so] [string totitle thread]] |
||||||
|
package ifneeded [string totitle thread] 3.0.2 \ |
||||||
|
[list package require -exact [string tolower thread] 3.0.2] |
||||||
|
|
||||||
|
# package ttrace uses some support machinery. |
||||||
|
|
||||||
|
# In Tcl 8.7+ interps; use [::apply] |
||||||
|
|
||||||
|
package ifneeded ttrace 3.0.2 [list ::apply {{dir} { |
||||||
|
if {[info exists ::env(TCL_THREAD_LIBRARY)] && |
||||||
|
[file readable $::env(TCL_THREAD_LIBRARY)/ttrace.tcl]} { |
||||||
|
source $::env(TCL_THREAD_LIBRARY)/ttrace.tcl |
||||||
|
} elseif {[file readable [file join $dir .. lib ttrace.tcl]]} { |
||||||
|
source [file join $dir .. lib ttrace.tcl] |
||||||
|
} elseif {[file readable [file join $dir ttrace.tcl]]} { |
||||||
|
source [file join $dir ttrace.tcl] |
||||||
|
} elseif {[file exists //zipfs:/lib/thread/ttrace.tcl] || |
||||||
|
![catch {zipfs mount [file join $dir libtcl9thread3.0.2.so] //zipfs:/lib/thread}]} { |
||||||
|
source //zipfs:/lib/thread/ttrace.tcl |
||||||
|
} |
||||||
|
if {[namespace which ::ttrace::update] ne ""} { |
||||||
|
::ttrace::update |
||||||
|
} |
||||||
|
}} $dir] |
||||||
|
package ifneeded Ttrace 3.0.2 \ |
||||||
|
[list package require -exact ttrace 3.0.2] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
Binary file not shown.
@ -0,0 +1,55 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Tcl package index file, version 1.1 |
||||||
|
# |
||||||
|
|
||||||
|
# Tcl 8.7 interps are only supported on 32-bit platforms. |
||||||
|
# Lower than that is never supported. Bye! |
||||||
|
if {![package vsatisfies [package provide Tcl] 9.0] |
||||||
|
&& ((![package vsatisfies [package provide Tcl] 8.7]) |
||||||
|
|| ($::tcl_platform(pointerSize)!=4))} { |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# All Tcl 8.7+ interps can [load] thread 3.0.2 |
||||||
|
# |
||||||
|
# For interps that are not thread-enabled, we still call [package ifneeded]. |
||||||
|
# This is contrary to the usual convention, but is a good idea because we |
||||||
|
# cannot imagine any other version of thread that might succeed in a |
||||||
|
# thread-disabled interp. There's nothing to gain by yielding to other |
||||||
|
# competing callers of [package ifneeded Thread]. On the other hand, |
||||||
|
# deferring the error has the advantage that a script calling |
||||||
|
# [package require Thread] in a thread-disabled interp gets an error message |
||||||
|
# about a thread-disabled interp, instead of the message |
||||||
|
# "can't find package thread". |
||||||
|
|
||||||
|
package ifneeded [string tolower thread] 3.0.2 \ |
||||||
|
[list load [file join $dir libtcl9thread3.0.2.so] [string totitle thread]] |
||||||
|
package ifneeded [string totitle thread] 3.0.2 \ |
||||||
|
[list package require -exact [string tolower thread] 3.0.2] |
||||||
|
|
||||||
|
# package ttrace uses some support machinery. |
||||||
|
|
||||||
|
# In Tcl 8.7+ interps; use [::apply] |
||||||
|
|
||||||
|
package ifneeded ttrace 3.0.2 [list ::apply {{dir} { |
||||||
|
if {[info exists ::env(TCL_THREAD_LIBRARY)] && |
||||||
|
[file readable $::env(TCL_THREAD_LIBRARY)/ttrace.tcl]} { |
||||||
|
source $::env(TCL_THREAD_LIBRARY)/ttrace.tcl |
||||||
|
} elseif {[file readable [file join $dir .. lib ttrace.tcl]]} { |
||||||
|
source [file join $dir .. lib ttrace.tcl] |
||||||
|
} elseif {[file readable [file join $dir ttrace.tcl]]} { |
||||||
|
source [file join $dir ttrace.tcl] |
||||||
|
} elseif {[file exists //zipfs:/lib/thread/ttrace.tcl] || |
||||||
|
![catch {zipfs mount [file join $dir libtcl9thread3.0.2.so] //zipfs:/lib/thread}]} { |
||||||
|
source //zipfs:/lib/thread/ttrace.tcl |
||||||
|
} |
||||||
|
if {[namespace which ::ttrace::update] ne ""} { |
||||||
|
::ttrace::update |
||||||
|
} |
||||||
|
}} $dir] |
||||||
|
package ifneeded Ttrace 3.0.2 \ |
||||||
|
[list package require -exact ttrace 3.0.2] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
Binary file not shown.
Binary file not shown.
@ -0,0 +1,16 @@ |
|||||||
|
if {[package vsatisfies [package present Tcl] 8.5-]} { |
||||||
|
package ifneeded tls 1.7.23 [list apply {{dir} { |
||||||
|
if {{shared} eq "static"} { |
||||||
|
load {} Tls |
||||||
|
} else { |
||||||
|
load [file join $dir tcltls.dll] Tls |
||||||
|
} |
||||||
|
|
||||||
|
set tlsTclInitScript [file join $dir tls.tcl] |
||||||
|
if {[file exists $tlsTclInitScript]} { |
||||||
|
source $tlsTclInitScript |
||||||
|
} |
||||||
|
}} $dir] |
||||||
|
} elseif {[package vsatisfies [package present Tcl] 8.4]} { |
||||||
|
package ifneeded tls 1.7.23 [list load [file join $dir tcltls.dll] Tls] |
||||||
|
} |
||||||
Binary file not shown.
@ -0,0 +1,398 @@ |
|||||||
|
# |
||||||
|
# Copyright (C) 1997-2000 Matt Newman <matt@novadigm.com> |
||||||
|
# |
||||||
|
namespace eval tls { |
||||||
|
variable logcmd tclLog |
||||||
|
variable debug 0 |
||||||
|
|
||||||
|
# Default flags passed to tls::import |
||||||
|
variable defaults {} |
||||||
|
|
||||||
|
# Maps UID to Server Socket |
||||||
|
variable srvmap |
||||||
|
variable srvuid 0 |
||||||
|
|
||||||
|
# Over-ride this if you are using a different socket command |
||||||
|
variable socketCmd |
||||||
|
if {![info exists socketCmd]} { |
||||||
|
set socketCmd [info command ::socket] |
||||||
|
} |
||||||
|
|
||||||
|
# This is the possible arguments to tls::socket and tls::init |
||||||
|
# The format of this is a list of lists |
||||||
|
## Each inner list contains the following elements |
||||||
|
### Server (matched against "string match" for 0/1) |
||||||
|
### Option name |
||||||
|
### Variable to add the option to: |
||||||
|
#### sopts: [socket] option |
||||||
|
#### iopts: [tls::import] option |
||||||
|
### How many arguments the following the option to consume |
||||||
|
variable socketOptionRules { |
||||||
|
{0 -async sopts 0} |
||||||
|
{* -myaddr sopts 1} |
||||||
|
{0 -myport sopts 1} |
||||||
|
{* -type sopts 1} |
||||||
|
{* -cadir iopts 1} |
||||||
|
{* -cafile iopts 1} |
||||||
|
{* -cert iopts 1} |
||||||
|
{* -certfile iopts 1} |
||||||
|
{* -cipher iopts 1} |
||||||
|
{* -command iopts 1} |
||||||
|
{* -dhparams iopts 1} |
||||||
|
{* -key iopts 1} |
||||||
|
{* -keyfile iopts 1} |
||||||
|
{* -password iopts 1} |
||||||
|
{* -request iopts 1} |
||||||
|
{* -require iopts 1} |
||||||
|
{* -autoservername discardOpts 1} |
||||||
|
{* -servername iopts 1} |
||||||
|
{* -ssl2 iopts 1} |
||||||
|
{* -ssl3 iopts 1} |
||||||
|
{* -tls1 iopts 1} |
||||||
|
{* -tls1.1 iopts 1} |
||||||
|
{* -tls1.2 iopts 1} |
||||||
|
{* -tls1.3 iopts 1} |
||||||
|
} |
||||||
|
|
||||||
|
# tls::socket and tls::init options as a humane readable string |
||||||
|
variable socketOptionsNoServer |
||||||
|
variable socketOptionsServer |
||||||
|
|
||||||
|
# Internal [switch] body to validate options |
||||||
|
variable socketOptionsSwitchBody |
||||||
|
} |
||||||
|
|
||||||
|
proc tls::_initsocketoptions {} { |
||||||
|
variable socketOptionRules |
||||||
|
variable socketOptionsNoServer |
||||||
|
variable socketOptionsServer |
||||||
|
variable socketOptionsSwitchBody |
||||||
|
|
||||||
|
# Do not re-run if we have already been initialized |
||||||
|
if {[info exists socketOptionsSwitchBody]} { |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# Create several structures from our list of options |
||||||
|
## 1. options: a text representation of the valid options for the current |
||||||
|
## server type |
||||||
|
## 2. argSwitchBody: Switch body for processing arguments |
||||||
|
set options(0) [list] |
||||||
|
set options(1) [list] |
||||||
|
set argSwitchBody [list] |
||||||
|
foreach optionRule $socketOptionRules { |
||||||
|
set ruleServer [lindex $optionRule 0] |
||||||
|
set ruleOption [lindex $optionRule 1] |
||||||
|
set ruleVarToUpdate [lindex $optionRule 2] |
||||||
|
set ruleVarArgsToConsume [lindex $optionRule 3] |
||||||
|
|
||||||
|
foreach server [list 0 1] { |
||||||
|
if {![string match $ruleServer $server]} { |
||||||
|
continue |
||||||
|
} |
||||||
|
|
||||||
|
lappend options($server) $ruleOption |
||||||
|
} |
||||||
|
|
||||||
|
switch -- $ruleVarArgsToConsume { |
||||||
|
0 { |
||||||
|
set argToExecute { |
||||||
|
lappend @VAR@ $arg |
||||||
|
set argsArray($arg) true |
||||||
|
} |
||||||
|
} |
||||||
|
1 { |
||||||
|
set argToExecute { |
||||||
|
incr idx |
||||||
|
if {$idx >= [llength $args]} { |
||||||
|
return -code error "\"$arg\" option must be followed by value" |
||||||
|
} |
||||||
|
set argValue [lindex $args $idx] |
||||||
|
lappend @VAR@ $arg $argValue |
||||||
|
set argsArray($arg) $argValue |
||||||
|
} |
||||||
|
} |
||||||
|
default { |
||||||
|
return -code error "Internal argument construction error" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
lappend argSwitchBody $ruleServer,$ruleOption [string map [list @VAR@ $ruleVarToUpdate] $argToExecute] |
||||||
|
} |
||||||
|
|
||||||
|
# Add in the final options |
||||||
|
lappend argSwitchBody {*,-*} {return -code error "bad option \"$arg\": must be one of $options"} |
||||||
|
lappend argSwitchBody default break |
||||||
|
|
||||||
|
# Set the final variables |
||||||
|
set socketOptionsNoServer [join $options(0) {, }] |
||||||
|
set socketOptionsServer [join $options(1) {, }] |
||||||
|
set socketOptionsSwitchBody $argSwitchBody |
||||||
|
} |
||||||
|
|
||||||
|
proc tls::initlib {dir dll} { |
||||||
|
# Package index cd's into the package directory for loading. |
||||||
|
# Irrelevant to unixoids, but for Windows this enables the OS to find |
||||||
|
# the dependent DLL's in the CWD, where they may be. |
||||||
|
set cwd [pwd] |
||||||
|
catch {cd $dir} |
||||||
|
if {[string equal $::tcl_platform(platform) "windows"] && |
||||||
|
![string equal [lindex [file system $dir] 0] "native"]} { |
||||||
|
# If it is a wrapped executable running on windows, the openssl |
||||||
|
# dlls must be copied out of the virtual filesystem to the disk |
||||||
|
# where Windows will find them when resolving the dependency in |
||||||
|
# the tls dll. We choose to make them siblings of the executable. |
||||||
|
package require starkit |
||||||
|
set dst [file nativename [file dirname $starkit::topdir]] |
||||||
|
foreach sdll [glob -nocomplain -directory $dir -tails *eay32.dll] { |
||||||
|
catch {file delete -force $dst/$sdll} |
||||||
|
catch {file copy -force $dir/$sdll $dst/$sdll} |
||||||
|
} |
||||||
|
} |
||||||
|
set res [catch {uplevel #0 [list load [file join [pwd] $dll]]} err] |
||||||
|
catch {cd $cwd} |
||||||
|
if {$res} { |
||||||
|
namespace eval [namespace parent] {namespace delete tls} |
||||||
|
return -code $res $err |
||||||
|
} |
||||||
|
rename tls::initlib {} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# |
||||||
|
# Backwards compatibility, also used to set the default |
||||||
|
# context options |
||||||
|
# |
||||||
|
proc tls::init {args} { |
||||||
|
variable defaults |
||||||
|
variable socketOptionsNoServer |
||||||
|
variable socketOptionsServer |
||||||
|
variable socketOptionsSwitchBody |
||||||
|
|
||||||
|
tls::_initsocketoptions |
||||||
|
|
||||||
|
# Technically a third option should be used here: Options that are valid |
||||||
|
# only a both servers and non-servers |
||||||
|
set server -1 |
||||||
|
set options $socketOptionsServer |
||||||
|
|
||||||
|
# Validate arguments passed |
||||||
|
set initialArgs $args |
||||||
|
set argc [llength $args] |
||||||
|
|
||||||
|
array set argsArray [list] |
||||||
|
for {set idx 0} {$idx < $argc} {incr idx} { |
||||||
|
set arg [lindex $args $idx] |
||||||
|
switch -glob -- $server,$arg $socketOptionsSwitchBody |
||||||
|
} |
||||||
|
|
||||||
|
set defaults $initialArgs |
||||||
|
} |
||||||
|
# |
||||||
|
# Helper function - behaves exactly as the native socket command. |
||||||
|
# |
||||||
|
proc tls::socket {args} { |
||||||
|
variable socketCmd |
||||||
|
variable defaults |
||||||
|
variable socketOptionsNoServer |
||||||
|
variable socketOptionsServer |
||||||
|
variable socketOptionsSwitchBody |
||||||
|
|
||||||
|
tls::_initsocketoptions |
||||||
|
|
||||||
|
set idx [lsearch $args -server] |
||||||
|
if {$idx != -1} { |
||||||
|
set server 1 |
||||||
|
set callback [lindex $args [expr {$idx+1}]] |
||||||
|
set args [lreplace $args $idx [expr {$idx+1}]] |
||||||
|
|
||||||
|
set usage "wrong # args: should be \"tls::socket -server command ?options? port\"" |
||||||
|
set options $socketOptionsServer |
||||||
|
} else { |
||||||
|
set server 0 |
||||||
|
|
||||||
|
set usage "wrong # args: should be \"tls::socket ?options? host port\"" |
||||||
|
set options $socketOptionsNoServer |
||||||
|
} |
||||||
|
|
||||||
|
# Combine defaults with current options |
||||||
|
set args [concat $defaults $args] |
||||||
|
|
||||||
|
set argc [llength $args] |
||||||
|
set sopts {} |
||||||
|
set iopts [list -server $server] |
||||||
|
|
||||||
|
array set argsArray [list] |
||||||
|
for {set idx 0} {$idx < $argc} {incr idx} { |
||||||
|
set arg [lindex $args $idx] |
||||||
|
switch -glob -- $server,$arg $socketOptionsSwitchBody |
||||||
|
} |
||||||
|
|
||||||
|
if {$server} { |
||||||
|
if {($idx + 1) != $argc} { |
||||||
|
return -code error $usage |
||||||
|
} |
||||||
|
set uid [incr ::tls::srvuid] |
||||||
|
|
||||||
|
set port [lindex $args [expr {$argc-1}]] |
||||||
|
lappend sopts $port |
||||||
|
#set sopts [linsert $sopts 0 -server $callback] |
||||||
|
set sopts [linsert $sopts 0 -server [list tls::_accept $iopts $callback]] |
||||||
|
#set sopts [linsert $sopts 0 -server [list tls::_accept $uid $callback]] |
||||||
|
} else { |
||||||
|
if {($idx + 2) != $argc} { |
||||||
|
return -code error $usage |
||||||
|
} |
||||||
|
|
||||||
|
set host [lindex $args [expr {$argc-2}]] |
||||||
|
set port [lindex $args [expr {$argc-1}]] |
||||||
|
|
||||||
|
# If an "-autoservername" option is found, honor it |
||||||
|
if {[info exists argsArray(-autoservername)] && $argsArray(-autoservername)} { |
||||||
|
if {![info exists argsArray(-servername)]} { |
||||||
|
set argsArray(-servername) $host |
||||||
|
lappend iopts -servername $host |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
lappend sopts $host $port |
||||||
|
} |
||||||
|
# |
||||||
|
# Create TCP/IP socket |
||||||
|
# |
||||||
|
set chan [eval $socketCmd $sopts] |
||||||
|
if {!$server && [catch { |
||||||
|
# |
||||||
|
# Push SSL layer onto socket |
||||||
|
# |
||||||
|
eval [list tls::import] $chan $iopts |
||||||
|
} err]} { |
||||||
|
set info ${::errorInfo} |
||||||
|
catch {close $chan} |
||||||
|
return -code error -errorinfo $info $err |
||||||
|
} |
||||||
|
return $chan |
||||||
|
} |
||||||
|
|
||||||
|
# tls::_accept -- |
||||||
|
# |
||||||
|
# This is the actual accept that TLS sockets use, which then calls |
||||||
|
# the callback registered by tls::socket. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# iopts tls::import opts |
||||||
|
# callback server callback to invoke |
||||||
|
# chan socket channel to accept/deny |
||||||
|
# ipaddr calling IP address |
||||||
|
# port calling port |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# Returns an error if the callback throws one. |
||||||
|
# |
||||||
|
proc tls::_accept { iopts callback chan ipaddr port } { |
||||||
|
log 2 [list tls::_accept $iopts $callback $chan $ipaddr $port] |
||||||
|
|
||||||
|
set chan [eval [list tls::import $chan] $iopts] |
||||||
|
|
||||||
|
lappend callback $chan $ipaddr $port |
||||||
|
if {[catch { |
||||||
|
uplevel #0 $callback |
||||||
|
} err]} { |
||||||
|
log 1 "tls::_accept error: ${::errorInfo}" |
||||||
|
close $chan |
||||||
|
error $err $::errorInfo $::errorCode |
||||||
|
} else { |
||||||
|
log 2 "tls::_accept - called \"$callback\" succeeded" |
||||||
|
} |
||||||
|
} |
||||||
|
# |
||||||
|
# Sample callback for hooking: - |
||||||
|
# |
||||||
|
# error |
||||||
|
# verify |
||||||
|
# info |
||||||
|
# |
||||||
|
proc tls::callback {option args} { |
||||||
|
variable debug |
||||||
|
|
||||||
|
#log 2 [concat $option $args] |
||||||
|
|
||||||
|
switch -- $option { |
||||||
|
"error" { |
||||||
|
foreach {chan msg} $args break |
||||||
|
|
||||||
|
log 0 "TLS/$chan: error: $msg" |
||||||
|
} |
||||||
|
"verify" { |
||||||
|
# poor man's lassign |
||||||
|
foreach {chan depth cert rc err} $args break |
||||||
|
|
||||||
|
array set c $cert |
||||||
|
|
||||||
|
if {$rc != "1"} { |
||||||
|
log 1 "TLS/$chan: verify/$depth: Bad Cert: $err (rc = $rc)" |
||||||
|
} else { |
||||||
|
log 2 "TLS/$chan: verify/$depth: $c(subject)" |
||||||
|
} |
||||||
|
if {$debug > 0} { |
||||||
|
return 1; # FORCE OK |
||||||
|
} else { |
||||||
|
return $rc |
||||||
|
} |
||||||
|
} |
||||||
|
"info" { |
||||||
|
# poor man's lassign |
||||||
|
foreach {chan major minor state msg} $args break |
||||||
|
|
||||||
|
if {$msg != ""} { |
||||||
|
append state ": $msg" |
||||||
|
} |
||||||
|
# For tracing |
||||||
|
upvar #0 tls::$chan cb |
||||||
|
set cb($major) $minor |
||||||
|
|
||||||
|
log 2 "TLS/$chan: $major/$minor: $state" |
||||||
|
} |
||||||
|
default { |
||||||
|
return -code error "bad option \"$option\":\ |
||||||
|
must be one of error, info, or verify" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc tls::xhandshake {chan} { |
||||||
|
upvar #0 tls::$chan cb |
||||||
|
|
||||||
|
if {[info exists cb(handshake)] && \ |
||||||
|
$cb(handshake) == "done"} { |
||||||
|
return 1 |
||||||
|
} |
||||||
|
while {1} { |
||||||
|
vwait tls::${chan}(handshake) |
||||||
|
if {![info exists cb(handshake)]} { |
||||||
|
return 0 |
||||||
|
} |
||||||
|
if {$cb(handshake) == "done"} { |
||||||
|
return 1 |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc tls::password {} { |
||||||
|
log 0 "TLS/Password: did you forget to set your passwd!" |
||||||
|
# Return the worlds best kept secret password. |
||||||
|
return "secret" |
||||||
|
} |
||||||
|
|
||||||
|
proc tls::log {level msg} { |
||||||
|
variable debug |
||||||
|
variable logcmd |
||||||
|
|
||||||
|
if {$level > $debug || $logcmd == ""} { |
||||||
|
return |
||||||
|
} |
||||||
|
set cmd $logcmd |
||||||
|
lappend cmd $msg |
||||||
|
uplevel #0 $cmd |
||||||
|
} |
||||||
|
|
||||||
Loading…
Reference in new issue