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