commit
b1af07bd5a
1928 changed files with 663075 additions and 0 deletions
@ -0,0 +1,356 @@
|
||||
namespace eval shellspy::callbacks { |
||||
package require shellfilter |
||||
|
||||
|
||||
#each member of args - ist not itself a list - and cannot be treated as one. |
||||
#things like [concat {*}args] will generall break things further down the line |
||||
proc cmdshellb {args} { |
||||
shellfilter::log::open callback_cmdb {-syslog 127.0.0.1:514} |
||||
shellfilter::log::write callback_cmdb "cmdshellb got [llength $args] arguments" |
||||
shellfilter::log::write callback_cmdb "cmdshellb got '$args'" |
||||
|
||||
if {[lindex $args 0] eq "cmdb"} { |
||||
set curlyparts [lrange $args 1 end] |
||||
shellfilter::log::write callback_cmdb "cmdshellb curlyparts '$curlyparts'" |
||||
#we lose grouping info by joining like this.. |
||||
#set tail [string trim [join $curlyparts " "]] |
||||
set tailinfo [shellfilter::list_element_info $curlyparts] |
||||
|
||||
shellfilter::log::write callback_cmdb "cmdshellb tailinfo '$tailinfo'" |
||||
#e.g |
||||
#% set y {{"c:/test/etc"} true {'blah1'} {'blah 2'}} |
||||
#% lappend y \\\\\\ |
||||
#{"c:/test/etc"} true {'blah1'} {'blah 2'} \\\\\\ |
||||
#% foreach i [shellfilter::list_element_info $y] {puts $i} |
||||
# 0 |
||||
# wouldbrace 1 wouldescape 0 has_braces 0 has_inner_braces 0 apparentwrap doublequotes head_tail_chars {{"} {"}} head_tail_names {dq dq} len 13 difflen 2 |
||||
# 1 |
||||
# wouldbrace 0 wouldescape 0 has_braces 0 has_inner_braces 0 apparentwrap not-determined head_tail_chars {t e} head_tail_names {t e} len 4 difflen 0 |
||||
# 2 |
||||
# wouldbrace 0 wouldescape 0 has_braces 0 has_inner_braces 0 apparentwrap singlequotes head_tail_chars {' '} head_tail_names {sqote sqote} len 7 difflen 0 |
||||
# 3 |
||||
# wouldbrace 1 wouldescape 0 has_braces 0 has_inner_braces 0 apparentwrap singlequotes head_tail_chars {' '} head_tail_names {sqote sqote} len 8 difflen 2 |
||||
# 4 |
||||
# wouldbrace 0 wouldescape 1 has_braces 0 has_inner_braces 0 apparentwrap not-determined head_tail_chars {\\ \\} head_tail_names {\\ \\} len 3 difflen 3 |
||||
|
||||
|
||||
#sample arglist - 7 items |
||||
#((c:\lua\luajit.exe |
||||
#C:\Users\sleek\vimfiles\plugged\vim-flog/lua/flog/graph_bin.lua |
||||
#__START |
||||
#true |
||||
#git -C C:/repo/3p/ansi-to-html --literal-pathspecs log --parents --topo-order --no-color --pretty=format:__START\%n\%h\%n\%p\%n\%D\%n\%ad\ \[\%h\]\ \{\%an\}\%d\ \%s --date=iso --no-merges --max-count=2000 -- ) |
||||
#> |
||||
#C:\Users\sleek\AppData\Local\Temp\VRR6A67.tmp) |
||||
|
||||
|
||||
#complex method.. lists at levels.. |
||||
set taillist [list] |
||||
set level 0 ;#bracket depth.. incr each opening bracket "(" |
||||
set leveldict [dict create] |
||||
dict set leveldict 0 [list] |
||||
|
||||
#simpler method.. string |
||||
set output "" |
||||
dict for {idx info} $tailinfo { |
||||
set item [lindex $curlyparts $idx] |
||||
set itemlen [string length $item] |
||||
if {[dict get $info apparentwrap] eq "brackets"} { |
||||
set chars [split $item ""] |
||||
set opening [lsearch -all $chars "("] |
||||
set closing [lsearch -all $chars ")"] |
||||
if {[llength $opening] == [llength $closing]} { |
||||
#dict lappend leveldict 0 $item ;#element individually wrapped in brackets and balanced, pass through |
||||
append output "$item " |
||||
} else { |
||||
#robustness warning: we examine outer brackets only, and are ignoring that things like {((a)(b)} {((a)(b} |
||||
# are composed of multiple elements for now .. as there should have been a space between the (a) & (b) elements anyway, |
||||
# in which case we would only see things like {((a)} or {(a} |
||||
set ltrimmed [string trimleft $item "("] |
||||
set countleft [expr {$itemlen - [string length $ltrimmed]}] |
||||
|
||||
set rtrimmed [string trimright $item ")"] |
||||
set countright [expr {$itemlen - [string length $rtrimmed]}] |
||||
|
||||
#simpler method.. |
||||
append output "$item " |
||||
|
||||
} |
||||
} else { |
||||
set lcharname [lindex [dict get $info head_tail_names] 0] |
||||
set rcharname [lindex [dict get $info head_tail_names] 1] |
||||
|
||||
if {$lcharname eq "lbracket"} { |
||||
set ltrimmed [string trimleft $item "("] |
||||
set countleft [expr {$itemlen - [string length $ltrimmed]}] |
||||
set braces [string repeat "(" $countleft] |
||||
|
||||
set testlist [list] |
||||
lappend testlist $ltrimmed |
||||
set testinfo [shellfilter::list_element_info $testlist] |
||||
set testelement [dict get $testinfo 0] |
||||
if {[dict get $testelement wouldbrace]} { |
||||
#append output "${braces}\"$ltrimmed\" " |
||||
append output "${braces} $ltrimmed " |
||||
} else { |
||||
append output "${braces} $ltrimmed " |
||||
} |
||||
|
||||
} elseif {$rcharname eq "rbracket"} { |
||||
set rtrimmed [string trimright $item ")" ] |
||||
set countright [expr {$itemlen - [string length $rtrimmed]}] |
||||
set braces [string repeat ")" $countright] |
||||
set testlist [list] |
||||
lappend testlist $rtrimmed |
||||
set testinfo [shellfilter::list_element_info $testlist] |
||||
set testelement [dict get $testinfo 0] |
||||
if {[dict get $testelement wouldbrace]} { |
||||
#append output "\"$rtrimmed\"${braces} " |
||||
if {[string first " " $rtrimmed] > 0} { |
||||
append output "\"$rtrimmed\" ${braces} " |
||||
} else { |
||||
append output "$rtrimmed ${braces} " |
||||
} |
||||
} else { |
||||
append output "${rtrimmed} ${braces} " |
||||
} |
||||
|
||||
|
||||
} else { |
||||
set testlist [list] |
||||
lappend testlist $item |
||||
set testinfo [shellfilter::list_element_info $testlist] |
||||
set testelement [dict get $testinfo 0] |
||||
if {[dict get $testelement wouldbrace]} { |
||||
#append output "\"$item\" " |
||||
if {[string first " " $item] > 0} { |
||||
append output "\"$item\" " |
||||
} else { |
||||
append output "$item " |
||||
} |
||||
} else { |
||||
append output "$item " |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
} |
||||
shellfilter::log::write callback_cmdb "cmdshellb about to parse_cmd_brackets '$output'" |
||||
#$output now has quoted all items that 'wouldbrace' |
||||
set curly_list [shellfilter::parse_cmd_brackets $output] |
||||
if {[llength $curly_list] == 1} { |
||||
#we expect the whole set of arguments was wrapped in a set of brackets |
||||
set curly_items [lindex $curly_list 0] |
||||
} else { |
||||
#unexpected.. root level of string had multiple bracketed sections |
||||
#try using the curly_list directly warn? |
||||
set curly_items $curly_list |
||||
} |
||||
#e.g |
||||
# ((c:\lua\luajit.exe -v) > C:\Users\sleek\AppData\Local\Temp\V7NCBF.tmp) |
||||
#=> |
||||
# {{{c:\lua\luajit.exe} -v} > {C:\Users\sleek\AppData\Local\Temp\V7NCBF.tmp}} |
||||
|
||||
#what is the proper way to flatten? |
||||
|
||||
set comspec [lindex $curly_items 0] |
||||
if {[llength $comspec] >1} { |
||||
set commandlist [concat $comspec [lrange $curly_items 1 end]] |
||||
} else { |
||||
set commandlist $curly_items |
||||
} |
||||
|
||||
set commandlist [floghack_singlearg callback_cmdb {*}$commandlist] |
||||
return $commandlist |
||||
} else { |
||||
shellfilter::log::write callback_cmdb "first arg: [lindex $args 0] vs 'cmdb'" |
||||
error "first arg: [lindex $args 0] vs 'cmdb'" |
||||
#return $args |
||||
} |
||||
} |
||||
proc cmdshell {args} { |
||||
if {[catch { |
||||
set args [floghack_singlearg callback_cmdshell {*}$args] |
||||
} errMsg]} { |
||||
error "FLOGHACK callback_cmdshell error $errMsg" |
||||
} |
||||
|
||||
|
||||
#set args [concat [lindex $args 0] [lrange $args 1 end]] |
||||
return $args |
||||
} |
||||
proc cmdshelluc {args} { |
||||
if {[catch { |
||||
set args [floghack_singlearg callback_cmdshelluc {*}$args] |
||||
} errMsg]} { |
||||
error "FLOGHACK callback_cmdshelluc error $errMsg" |
||||
} |
||||
|
||||
#set args [concat [lindex $args 0] [lrange $args 1 end]] |
||||
return $args |
||||
} |
||||
|
||||
proc powershell {args} { |
||||
if {[catch { |
||||
set args [floghack "callback_powershell" {*}$args] |
||||
} errMsg]} { |
||||
error "FLOGHACK callback_powershell error $errMsg" |
||||
} |
||||
return $args |
||||
|
||||
} |
||||
proc raw {args} { |
||||
if {[catch { |
||||
set args [floghack_singlearg "callback_raw" {*}$args] |
||||
} errMsg]} { |
||||
error "FLOGHACK callback_raw error $errMsg" |
||||
} |
||||
#set args [concat [split [lindex $args 0]] [lrange $args 1 end]] ;#definitely bad! |
||||
|
||||
|
||||
return $args |
||||
} |
||||
|
||||
#hack for c: drive - extend as necessary |
||||
#todo - customize! |
||||
# various hacks may be necessary for home dirs temp files etc! |
||||
proc sh {args} { |
||||
if {[catch { |
||||
set args [floghack callback_sh {*}$args] |
||||
} errMsg]} { |
||||
error "FLOGHACK callback_sh error $errMsg" |
||||
} |
||||
|
||||
|
||||
|
||||
set final [list] |
||||
foreach a $args { |
||||
if {[string match -nocase {*c:/*} $a]} { |
||||
set a [string map [list {c:/} {/c/}] $a] |
||||
lappend final $a |
||||
} elseif {[string match -nocase {*c:\\*} $a]} { |
||||
set a [string map [list \\ / ] $a] |
||||
set a [string map [list {c:/} {/c/} {C:/} {/C/}] $a] |
||||
lappend final $a |
||||
} else { |
||||
lappend final $a |
||||
} |
||||
} |
||||
return $final |
||||
} |
||||
proc wsl {args} { |
||||
set args [floghack_singlearg callback_wsl {*}$args] |
||||
#wsl bash-style /mnt/c paths to be convertd |
||||
set args [convert_mnt_win {*}$args] |
||||
|
||||
#review - seems bad |
||||
#flatten first element which arrives wrapped |
||||
#set args [concat [lindex $args 0] [lrange $args 1 end]] |
||||
|
||||
|
||||
return $args |
||||
} |
||||
proc bash {args} { |
||||
set args [floghack callback_bash {*}$args] |
||||
return [convert_mnt_win {*}$args] |
||||
} |
||||
|
||||
|
||||
|
||||
#helper functions |
||||
proc convert_mnt_win {args} { |
||||
set final [list] |
||||
foreach a $args { |
||||
if {[string match -nocase {*c:\\*} $a]} { |
||||
set a [string map [list \\ / ] $a] |
||||
} |
||||
#bash seems to be strict about lowercase /mnt/c |
||||
if {[string match -nocase {*c:/*} $a]} { |
||||
set a [string map [list {c:/} {/mnt/c/} {C:/} {/mnt/c/}] $a] |
||||
} |
||||
lappend final $a |
||||
} |
||||
shellfilter::log::write callback_convert_mnt_win "convert_mnt_win commandlist '$final'" |
||||
return $final |
||||
} |
||||
|
||||
#when we get the git command and args together as one element in the commandlist |
||||
proc floghack_singlearg {logtag args} { |
||||
#return $args |
||||
shellfilter::log::write $logtag "floghack_singlearg got $logtag '$args'" |
||||
set newargs [list] |
||||
foreach a $args { |
||||
if {[string match "*pretty=format:__START*" $a]} { |
||||
set a [string map [list "pretty=format:__" "pretty=format:\"__"] $a] |
||||
set a [string map [list " --date=" "\" --date="] $a] |
||||
set a [string map [list \\ ""] $a] ;# a bad idea? |
||||
lappend newargs $a |
||||
} else { |
||||
lappend newargs $a |
||||
} |
||||
} |
||||
shellfilter::log::write $logtag "floghack_singlearg hacked commandlist '$newargs'" |
||||
return $newargs |
||||
} |
||||
|
||||
|
||||
proc floghack {logtag args} { |
||||
|
||||
#return $args |
||||
shellfilter::log::write $logtag "floghack got [llength $args] args: '$args'" |
||||
set indent " " |
||||
set i 0 |
||||
foreach a $args { |
||||
shellfilter::log::write $logtag "floghack ${indent}$i $a" |
||||
incr i |
||||
} |
||||
|
||||
#Flog/luajit hack |
||||
#wrong way |
||||
#if {[string first "pretty=format:__START" $args] > 0} { |
||||
# set args [string map [list "pretty=format:" "pretty=format:'" " --date=" "' --date=" ] $args] |
||||
#} |
||||
set newargs [list] |
||||
|
||||
set pretty "" |
||||
set pstart [lsearch $args "--pretty=format:__START*"] |
||||
set pafter [lsearch $args "--date=*"] |
||||
if {$pstart > 0} { |
||||
set newargs [lrange $args 0 $pstart-1] |
||||
set parts [lrange $args $pstart $pafter-1] |
||||
set i 1 |
||||
foreach p $parts { |
||||
if {$i == 1} { |
||||
set pretty [string map [list "format:__" "format:\"__"] $p] |
||||
#set pretty $p |
||||
} else { |
||||
append pretty " $p" |
||||
} |
||||
if {$i == [llength $parts]} { |
||||
append pretty "\"" |
||||
} |
||||
incr i |
||||
} |
||||
set pretty [string map [list \\ ""] $pretty] |
||||
lappend newargs $pretty |
||||
#lappend newargs "--pretty=format:%h" |
||||
set newargs [concat $newargs [lrange $args $pafter end]] ;#concat of 2 lists.. should be ok |
||||
} else { |
||||
set newargs $args |
||||
} |
||||
|
||||
|
||||
shellfilter::log::write $logtag "floghack hacked commandlist '$newargs'" |
||||
|
||||
|
||||
return $newargs |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
} |
||||
@ -0,0 +1,51 @@
|
||||
namespace eval shellspy::parameters { |
||||
proc cmdshellb {paramdict} { |
||||
return [commonset params_cmdshellb $paramdict] |
||||
} |
||||
|
||||
|
||||
proc cmdshell {paramdict} { |
||||
return [commonset params_cmdshell $paramdict] |
||||
} |
||||
|
||||
proc powershell {paramdict} { |
||||
return [commonset params_powershell $paramdict] |
||||
} |
||||
|
||||
proc raw {paramdict} { |
||||
return [commonset params_raw $paramdict] |
||||
} |
||||
|
||||
proc wsl {paramdict} { |
||||
return [commonset params_wsl $paramdict] |
||||
} |
||||
proc bash {paramdict} { |
||||
return [commonset params_bash $paramdict] |
||||
} |
||||
|
||||
proc sh {paramdict} { |
||||
return [commonset params_sh $paramdict] |
||||
} |
||||
|
||||
proc commonset {logtag paramdict} { |
||||
#timeout for launched process |
||||
dict set paramdict -timeout 60000 |
||||
#prefix for each stdout line - for debugging if this output being mixed with some other |
||||
dict set paramdict -outprefix "" |
||||
#prefix for each stderr line - also usually best left blank |
||||
dict set paramdict -errprefix "" |
||||
#put extra info to the log outputs (by default goes to syslog 127.0.0.1 514) |
||||
dict set paramdict -debug 0 |
||||
dict set paramdict -outbuffering none |
||||
dict set paramdict -inbuffering none |
||||
#if at tail end of commandline there is a > or >> redirection to a file that contains 'temp' |
||||
# make a '_copy' version e.g for something/temp/blah.tmp |
||||
# create something/temp/blah_copy.tmp |
||||
# this is for pipelines where some other process deletes the original temp file but you want a copy |
||||
# to review/debug. |
||||
dict set paramdict -copytempfile 1 |
||||
|
||||
shellfilter::log::write $logtag "base parameters: $paramdict" |
||||
return $paramdict |
||||
} |
||||
} |
||||
@ -0,0 +1,54 @@
|
||||
|
||||
if {$::argc == 1} { |
||||
set persec $::argv |
||||
} else { |
||||
set persec 1 |
||||
} |
||||
if {$persec > 1000} { |
||||
puts stderr "WARNING: (>1000) sub millisecond scheduling not available - will go full speed" |
||||
flush stderr |
||||
after 500 |
||||
} |
||||
#--- confg --- |
||||
set newline_every_x_seconds 5 |
||||
#--- |
||||
chan configure stdout -blocking 1 -buffering none |
||||
set counter 0 |
||||
set ms [expr {1000 / $persec}] |
||||
set nl_every [expr {$persec * $newline_every_x_seconds}] |
||||
|
||||
proc schedule {} { |
||||
after idle [list after 0 ::emit] |
||||
tailcall after $::ms ::schedule |
||||
} |
||||
|
||||
proc emit {} { |
||||
upvar ::counter c |
||||
puts -nonewline "\x1b\[1000D$c" |
||||
|
||||
#if {($c > 1) && (($c % $::nl_every) == 0)} { |
||||
# puts stdout $c |
||||
# flush stdout |
||||
#} else { |
||||
# puts -nonewline "\x1b\[1000D$c" |
||||
#} |
||||
#flush stdout |
||||
incr c |
||||
} |
||||
chan configure stdin -blocking 0 -buffering none |
||||
chan event stdin readable [list apply {{chan} { |
||||
set chunk [chan read $chan] |
||||
if {[string length $chunk]} { |
||||
if {[string match "q*" [string tolower $chunk]]} { |
||||
set ::forever 0 |
||||
} |
||||
} |
||||
if {[chan eof $chan]} { |
||||
chan event $chan readable {} |
||||
} |
||||
}} stdin] |
||||
|
||||
schedule |
||||
vwait ::forever |
||||
|
||||
puts "-done-" |
||||
@ -0,0 +1,32 @@
|
||||
puts -nonewline stdout "info script\r\n" |
||||
puts stdout "[info script]" |
||||
puts stdout "::argc" |
||||
puts stdout $::argc |
||||
puts stdout "::argv" |
||||
puts stdout "$::argv" |
||||
puts stdout "NS" |
||||
puts stdout "[namespace current]" |
||||
|
||||
if {[info exists ::test]} { |
||||
puts stdout "::test has existing value" |
||||
puts stdout "$::test" |
||||
} |
||||
|
||||
puts stdout "setting ::test to showargs-ran" |
||||
set ::test "showargs-ran" |
||||
puts stdout "doing basic check of stdin for data" |
||||
chan configure stdin -blocking 0 |
||||
set indata "" |
||||
if {![chan eof stdin]} { |
||||
#set indata [read stdin] |
||||
} |
||||
if {[string length $indata]} { |
||||
puts stdout "read from stdin:" |
||||
puts stdout $indata |
||||
} else { |
||||
puts stdout "-no stdin data read-" |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
@ -0,0 +1,77 @@
|
||||
|
||||
if {$::argc >= 1} { |
||||
set persec [lindex $::argv 0] |
||||
} else { |
||||
set persec 1 |
||||
} |
||||
if {$::argc == 2} { |
||||
set what [lindex $::argv 1] |
||||
} else { |
||||
set what "." |
||||
} |
||||
|
||||
if {$persec > 1000} { |
||||
puts stderr "WARNING: (>1000) sub millisecond scheduling not available - will go full speed" |
||||
flush stderr |
||||
after 500 |
||||
} |
||||
#--- confg --- |
||||
set newline_every_x_seconds 5 |
||||
#--- |
||||
chan configure stdout -blocking 1 -buffering none |
||||
set counter 0 |
||||
set ms [expr {1000 / $persec}] |
||||
set nl_every [expr {$persec * $newline_every_x_seconds}] |
||||
|
||||
proc schedule {} { |
||||
if {$::forever_stdout_per_second} { |
||||
after idle [list after 0 ::emit] |
||||
tailcall after $::ms ::schedule |
||||
} else { |
||||
after idle [list ::the_end] |
||||
} |
||||
} |
||||
|
||||
set ::forever_stdout_per_second 1 |
||||
|
||||
proc the_end {} { |
||||
puts "-done-" |
||||
flush stdout |
||||
set ::done_stdout_per_second 1 |
||||
} |
||||
|
||||
proc emit {} { |
||||
upvar ::counter c |
||||
if {($c > 1) && (($c % $::nl_every) == 0)} { |
||||
puts -nonewline stdout " " |
||||
flush stdout |
||||
puts stderr $c |
||||
flush stderr |
||||
} else { |
||||
puts -nonewline stdout $::what |
||||
} |
||||
#flush stdout |
||||
incr c |
||||
} |
||||
chan configure stdin -blocking 0 -buffering none |
||||
chan event stdin readable [list apply {{chan} { |
||||
set chunk [chan read $chan] |
||||
if {[string length $chunk]} { |
||||
if {[string match "*q*" [string tolower $chunk]]} { |
||||
set ::forever_stdout_per_second 0 |
||||
chan event $chan readable {} |
||||
puts stdout "cancelling" |
||||
} |
||||
} |
||||
if {[chan eof $chan]} { |
||||
chan event $chan readable {} |
||||
} |
||||
}} stdin] |
||||
|
||||
schedule |
||||
vwait ::forever_stdout_per_second |
||||
|
||||
vwait ::done_stdout_per_second |
||||
|
||||
|
||||
|
||||
@ -0,0 +1,118 @@
|
||||
|
||||
|
||||
if {[lsearch $::argv -k] >= 0} { |
||||
set forcekill 1 |
||||
} else { |
||||
set forcekill 0 |
||||
} |
||||
puts stdout "::argv $::argv" |
||||
|
||||
set dirname [file normalize [file dirname [info script]]] |
||||
|
||||
if {![file exists $dirname/punk86.vfs]} { |
||||
puts stderr "missing $dirname/punk86.vfs" |
||||
exit 1 |
||||
} |
||||
if {[file exists $dirname/punk86]} { |
||||
puts stderr "deleting existing $dirname/punk86" |
||||
file delete $dirname/punk86 |
||||
} |
||||
|
||||
puts stdout "building with sdx.." |
||||
if {[catch { |
||||
exec sdx wrap punk86 -runtime tclkit86bi.exe -verbose |
||||
} result]} { |
||||
puts stderr "sdx wrap punk86 -runtime tclkit86bi.exe -verbose failed with msg: $result" |
||||
} else { |
||||
puts stdout "ok - finished sdx" |
||||
set separator [string repeat = 40] |
||||
puts stdout $separator |
||||
puts stdout $result |
||||
puts stdout $separator |
||||
} |
||||
|
||||
if {![file exists $dirname/punk86]} { |
||||
puts stderr "|err> build didn't seem to produce output at $dirname/punk86" |
||||
exit 2 |
||||
} |
||||
|
||||
if {![catch { |
||||
exec tasklist | grep punk86 |
||||
} still_running]} { |
||||
puts stdout "found punk86 instances still running\n" |
||||
set count_killed 0 |
||||
foreach ln [split $still_running \n] { |
||||
puts stdout " $ln" |
||||
set pid [lindex $ln 1] |
||||
if {$forcekill} { |
||||
set killcmd [list taskkill /F /PID $pid] |
||||
} else { |
||||
set killcmd [list taskkill /PID $pid] |
||||
} |
||||
|
||||
puts stdout " pid: $pid (attempting to kill now using '$killcmd')" |
||||
|
||||
if {[catch { |
||||
exec {*}$killcmd |
||||
} errMsg]} { |
||||
puts stderr "taskkill /PID $pid returned an error:" |
||||
puts stderr $errMsg |
||||
puts stderr "(try '[info script] -k' option to force kill)" |
||||
exit 4 |
||||
} else { |
||||
puts stderr "taskkill /PID $pid ran without error" |
||||
incr count_killed |
||||
} |
||||
} |
||||
if {$count_killed > 0} { |
||||
puts stderr "\nKilled $count_killed processes. Waiting a short time before attempting to delete executable" |
||||
after 2000 |
||||
} |
||||
} else { |
||||
puts stderr "Ok.. no running punk processes found" |
||||
} |
||||
|
||||
|
||||
|
||||
if {[file exists $dirname/punk86.exe]} { |
||||
puts stderr "deleting existing $dirname/punk86.exe" |
||||
if {[catch { |
||||
file delete $dirname/punk86.exe |
||||
} msg]} { |
||||
puts stderr "Failed to delete $dirname/punk86.exe" |
||||
exit 3 |
||||
} |
||||
} |
||||
|
||||
#is this test necessary? |
||||
if {[file exists $dirname/punk86.exe]} { |
||||
puts stderr "deletion of $dirname/punk86.exe failed - locked?" |
||||
exit 3 |
||||
} |
||||
|
||||
file rename $dirname/punk86 $dirname/punk86.exe |
||||
after 500 |
||||
set deployment_folder [file dirname $dirname] |
||||
|
||||
if {[file exists $deployment_folder/punk86.exe]} { |
||||
puts stderr "deleting existing deployed at $deployment_folder/punk86.exe" |
||||
if {[catch { |
||||
file delete $deployment_folder/punk86.exe |
||||
} errMsg]} { |
||||
puts stderr "deletion of deployed version at $deployment_folder/punk86.exe failed: $errMsg" |
||||
exit 4 |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
puts stdout "copying.." |
||||
puts stdout "$dirname/punk86.exe" |
||||
puts stdout "to:" |
||||
puts stdout "$deployment_folder/punk86.exe" |
||||
after 500 |
||||
file copy $dirname/punk86.exe $deployment_folder/punk86.exe |
||||
|
||||
puts stdout "done" |
||||
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,19 @@
|
||||
2010-03-05 |
||||
- allow #tarjar-loadscript.tcl (no package name or version number) |
||||
|
||||
2008-03-15 (tarpack) |
||||
- version 1.1.3 |
||||
- modified for use in environments where ::env(HOME) is not available (certain operations such as 'file normalize ~' etc depend on it) |
||||
|
||||
2006-08-08 (tarpack) |
||||
- bump version to 1.1.2 |
||||
- fix tarpack::wrap so that the 'scriptTidy' string doesn't force the wrapped package to be dependent on tarpack. |
||||
i.e call to 'tarpack::disconnect' now wrapped in test for 'tarpack'. |
||||
This allows a tcl-only script to be wrapped with tarpack, but not require tarpack on deployment. |
||||
|
||||
2006-08-15 |
||||
- tarjar 1.0 created as a fork of tarpack 1.1.2 (which is to be abandoned as it's too close in name to 'starpack'). |
||||
|
||||
2008-06-06 |
||||
- tarjar 1.1 |
||||
|
||||
@ -0,0 +1,3 @@
|
||||
Identifier: tarjar |
||||
Version: 2.3 |
||||
Rights: BSD |
||||
@ -0,0 +1,11 @@
|
||||
A tarjar is a standard tar (ustar or gnu format) archive which is also directly loadable as a Tcl module without requiring the tarball to be unarchived. |
||||
|
||||
When the tarjar is placed on the Tcl module-path it can be loaded with: |
||||
package require <PackageName> |
||||
Where the <PackageName> is the segment of the tarjar filename before the dash and version number. |
||||
|
||||
!NOTE! The tarjar can be unpacked in the same folder as the .tm file, in which case, the unpacked files will take precedence over the wrapped version. |
||||
The wrapped (.tm) version however needs to remain in place to 'redirect' to the unwrapped version. |
||||
|
||||
|
||||
|
||||
@ -0,0 +1,47 @@
|
||||
apply {code { |
||||
set scriptpath [file normalize [info script]] |
||||
if {[string match "#tarjar-loadscript*.tcl" [file tail $scriptpath]]} { |
||||
#jump up an extra dir level if we are within a #tarjar-loadscript file. |
||||
set mypath [file dirname [file dirname $scriptpath]] |
||||
set modver [string range [file tail [file dirname $scriptpath]] 8 end] ;# the containing folder is named #tarjar-<module>-<ver> |
||||
} else { |
||||
set mypath [file dirname $scriptpath] |
||||
set modver [file root [file tail [info script]]] |
||||
} |
||||
set mysegs [file split $mypath] |
||||
set overhang [list] |
||||
foreach libpath [tcl::tm::list] { |
||||
set libsegs [file split $libpath] ;#split and rejoin with '/' because sometimes module paths may have mixed \ & / |
||||
if {[file join $mysegs /] eq [file join [lrange $libsegs 0 [llength $mysegs]] /]} { |
||||
#mypath is below libpath |
||||
set overhang [lrange $mysegs [llength $libsegs]+1 end] |
||||
break |
||||
} |
||||
} |
||||
lassign [split $modver -] moduletail version |
||||
set ns [join [concat $overhang $moduletail] ::] |
||||
if {![catch {package require tarjar}]} { |
||||
::tarjar::disconnect [info script] |
||||
} |
||||
package provide $ns $version |
||||
namespace eval $ns $code |
||||
} ::} { |
||||
# |
||||
# Module procs here, where current namespace is that of the module. |
||||
# Package version can, if needed, be accessed as [uplevel 1 {set version}] |
||||
# Last element of module name: [uplevel 1 {set moduletail}] |
||||
# Full module name: [uplevel 1 {set ns}] |
||||
|
||||
#<modulecode> |
||||
# |
||||
#</modulecode> |
||||
|
||||
#<sourcefiles> |
||||
# |
||||
#</sourcefiles> |
||||
|
||||
#<loadfiles> |
||||
# |
||||
#</loadfiles> |
||||
|
||||
} |
||||
@ -0,0 +1,78 @@
|
||||
apply {code { |
||||
set scriptpath [file normalize [info script]] |
||||
if {[string match "#tarjar-loadscript*.tcl" [file tail $scriptpath]]} { |
||||
#jump up an extra dir level if we are within a #tarjar-loadscript file. |
||||
set mypath [file dirname [file dirname $scriptpath]] |
||||
set modver [string range [file tail [file dirname $scriptpath]] 8 end] ;# the containing folder is named #tarjar-<module>-<ver> |
||||
} else { |
||||
set mypath [file dirname $scriptpath] |
||||
set modver [file root [file tail [info script]]] |
||||
} |
||||
set mysegs [file split $mypath] |
||||
set mysegs_rejoined [file join $mysegs /] |
||||
set mysegs_count [llength $mysegs] |
||||
set overhang [list] |
||||
foreach libpath [tcl::tm::list] { |
||||
set libsegs [file split $libpath] ;#split and rejoin with '/' because sometimes module paths may have mixed \ & / |
||||
if {$mysegs_rejoined eq [file join [lrange $libsegs 0 $mysegs_count] /]} { |
||||
#mypath is below libpath |
||||
set overhang [lrange $mysegs [llength $libsegs]+1 end] |
||||
break |
||||
} |
||||
} |
||||
lassign [split $modver -] moduletail version |
||||
set ns [join [concat $overhang $moduletail] ::] |
||||
if {![catch {package require tarjar}]} { |
||||
lassign [::tarjar::glob ${moduletail}/load/[::tarjar::platform::generic] *] _ok libs ;#assume all files are loadable.. |
||||
if {[llength $libs] > 0} { |
||||
foreach lname $libs { |
||||
tarjar::load ${moduletail}/load/[::tarjar::platform::generic]/$lname -from [info script] |
||||
} |
||||
} else { |
||||
lassign [::tarjar::glob ${moduletail}/load *] _ok binfolders |
||||
set some_bin_exists false ;#keep track of whether there is at least one binary in the archive for some architecture. |
||||
set architectures_supported [list] |
||||
foreach fldr $binfolders { |
||||
lassign [::tarjar::glob ${moduletail}/load/$fldr *] _ok binfile |
||||
if {[llength $binfile] > 0} { |
||||
set some_bin_exists true |
||||
lappend architectures_supported $fldr |
||||
} |
||||
} |
||||
if {[llength $architectures_supported] > 0} { |
||||
puts stderr "platform [tarjar::platform::generic] not supported by the tarjar load-script. (archive contains binaries for:[join $architectures_supported ,])" |
||||
} |
||||
} |
||||
#load all other .tcl files in the *tarjar base* folder - ie those not explicitly wrapped in the {modulename} folder |
||||
#!todo - use a manifest to determine load order? |
||||
set basefolder [file dirname $moduletail] |
||||
lassign [::tarjar::glob $basefolder *.tcl] _ok sourcefiles |
||||
foreach f $sourcefiles { |
||||
if {![string match "#*" $f]} { |
||||
namespace eval $ns [list tarjar::source $basefolder/$f] |
||||
} |
||||
} |
||||
::tarjar::disconnect [info script] |
||||
} |
||||
package provide $ns $version |
||||
namespace eval $ns $code |
||||
} ::} { |
||||
# |
||||
# Module procs here, where current namespace is that of the module. |
||||
# Package version can, if needed, be accessed as [uplevel 1 {set version}] |
||||
# Last element of module name: [uplevel 1 {set moduletail}] |
||||
# Full module name: [uplevel 1 {set ns}] |
||||
|
||||
#<modulecode> |
||||
# |
||||
#</modulecode> |
||||
|
||||
#<sourcefiles> |
||||
# |
||||
#</sourcefiles> |
||||
|
||||
#<loadfiles> |
||||
# |
||||
#</loadfiles> |
||||
|
||||
} |
||||
@ -0,0 +1,11 @@
|
||||
A tarjar is a standard tar (ustar or gnu format) archive which is also directly loadable as a Tcl module without requiring the tarball to be unarchived. |
||||
|
||||
When the tarjar is placed on the Tcl module-path it can be loaded with: |
||||
package require <PackageName> |
||||
Where the <PackageName> is the segment of the tarjar filename before the dash and version number. |
||||
|
||||
!NOTE! The tarjar can be unpacked in the same folder as the .tm file, in which case, the unpacked files will take precedence over the wrapped version. |
||||
The wrapped version however needs to remain in place to 'redirect' to the unwrapped version. |
||||
|
||||
|
||||
|
||||
@ -0,0 +1,3 @@
|
||||
split tarjar read functionality into separate file/namespace. |
||||
Work out how to make tarjar self-hosting. ie wrap next version of tarjar using current one. |
||||
(use a 'rollup' of the read-code in the generated loadscript?) |
||||
@ -0,0 +1,259 @@
|
||||
|
||||
# Tcl parser for optional arguments in function calls and |
||||
# commandline arguments |
||||
# |
||||
# (c) 2001 Bastien Chevreux |
||||
|
||||
# Index of exported commands |
||||
# - argp::registerArgs |
||||
# - argp::setArgDefaults |
||||
# - argp::setArgsNeeded |
||||
# - argp::parseArgs |
||||
|
||||
# Internal commands |
||||
# - argp::CheckValues |
||||
|
||||
# See end of file for an example on how to use |
||||
|
||||
package provide argp 0.2 |
||||
|
||||
namespace eval argp { |
||||
variable Optstore |
||||
variable Opttypes { |
||||
boolean integer double string |
||||
} |
||||
|
||||
namespace export {[a-z]*} |
||||
} |
||||
|
||||
|
||||
proc argp::registerArgs { func arglist } { |
||||
variable Opttypes |
||||
variable Optstore |
||||
|
||||
set parentns [string range [uplevel 1 [list namespace current]] 2 end] |
||||
if { $parentns != "" } { |
||||
append caller $parentns :: $func |
||||
} else { |
||||
set caller $func |
||||
} |
||||
set cmangled [string map {:: _} $caller] |
||||
|
||||
#puts $parentns |
||||
#puts $caller |
||||
#puts $cmangled |
||||
|
||||
set Optstore(keys,$cmangled) {} |
||||
set Optstore(deflist,$cmangled) {} |
||||
set Optstore(argneeded,$cmangled) {} |
||||
|
||||
foreach arg $arglist { |
||||
foreach {opt type default allowed} $arg { |
||||
set optindex [lsearch -glob $Opttypes $type*] |
||||
if { $optindex < 0} { |
||||
return -code error "$caller, unknown type $type while registering arguments.\nAllowed types: [string trim $Opttypes]" |
||||
} |
||||
set type [lindex $Opttypes $optindex] |
||||
|
||||
lappend Optstore(keys,$cmangled) $opt |
||||
set Optstore(type,$opt,$cmangled) $type |
||||
set Optstore(default,$opt,$cmangled) $default |
||||
set Optstore(allowed,$opt,$cmangled) $allowed |
||||
lappend Optstore(deflist,$cmangled) $opt $default |
||||
} |
||||
} |
||||
|
||||
if { [catch {CheckValues $caller $cmangled $Optstore(deflist,$cmangled)} res]} { |
||||
return -code error "Error in declaration of optional arguments.\n$res" |
||||
} |
||||
} |
||||
|
||||
proc argp::setArgDefaults { func arglist } { |
||||
variable Optstore |
||||
|
||||
set parentns [string range [uplevel 1 [list namespace current]] 2 end] |
||||
if { $parentns != "" } { |
||||
append caller $parentns :: $func |
||||
} else { |
||||
set caller $func |
||||
} |
||||
set cmangled [string map {:: _} $caller] |
||||
|
||||
if {![info exists Optstore(deflist,$cmangled)]} { |
||||
return -code error "Arguments for $caller not registered yet." |
||||
} |
||||
set Optstore(deflist,$cmangled) {} |
||||
foreach {opt default} $arglist { |
||||
if {![info exists Optstore(default,$opt,$cmangled)]} { |
||||
return -code error "$caller, unknown option $opt, must be one of: $Optstore(keys,$cmangled)" |
||||
} |
||||
set Optstore(default,$opt,$cmangled) $default |
||||
} |
||||
|
||||
# set the new defaultlist |
||||
foreach opt $Optstore(keys,$cmangled) { |
||||
lappend Optstore(deflist,$cmangled) $opt $Optstore(default,$opt,$cmangled) |
||||
} |
||||
} |
||||
|
||||
proc argp::setArgsNeeded { func arglist } { |
||||
variable Optstore |
||||
|
||||
set parentns [string range [uplevel 1 [list namespace current]] 2 end] |
||||
if { $parentns != "" } { |
||||
append caller $parentns :: $func |
||||
} else { |
||||
set caller $func |
||||
} |
||||
set cmangled [string map {:: _} $caller] |
||||
|
||||
#append caller $parentns :: $func |
||||
#set cmangled ${parentns}_$func |
||||
|
||||
if {![info exists Optstore(deflist,$cmangled)]} { |
||||
return -code error "Arguments for $caller not registered yet." |
||||
} |
||||
|
||||
set Optstore(argneeded,$cmangled) {} |
||||
foreach opt $arglist { |
||||
if {![info exists Optstore(default,$opt,$cmangled)]} { |
||||
return -code error "$caller, unknown option $opt, must be one of: $Optstore(keys,$cmangled)" |
||||
} |
||||
lappend Optstore(argneeded,$cmangled) $opt |
||||
} |
||||
} |
||||
|
||||
|
||||
proc argp::parseArgs { args } { |
||||
variable Optstore |
||||
|
||||
if {[llength $args] == 0} { |
||||
upvar args a opts o |
||||
} else { |
||||
upvar args a [lindex $args 0] o |
||||
} |
||||
|
||||
if { [ catch { set caller [lindex [info level -1] 0]}]} { |
||||
set caller "main program" |
||||
set cmangled "" |
||||
} else { |
||||
set cmangled [string map {:: _} $caller] |
||||
} |
||||
|
||||
if {![info exists Optstore(deflist,$cmangled)]} { |
||||
return -code error "Arguments for $caller not registered yet." |
||||
} |
||||
|
||||
# set the defaults |
||||
array set o $Optstore(deflist,$cmangled) |
||||
|
||||
# but unset the needed arguments |
||||
foreach key $Optstore(argneeded,$cmangled) { |
||||
catch { unset o($key) } |
||||
} |
||||
|
||||
foreach {key val} $a { |
||||
if {![info exists Optstore(type,$key,$cmangled)]} { |
||||
return -code error "$caller, unknown option $key, must be one of: $Optstore(keys,$cmangled)" |
||||
} |
||||
switch -exact -- $Optstore(type,$key,$cmangled) { |
||||
boolean - |
||||
integer { |
||||
if { $val == "" } { |
||||
return -code error "$caller, $key empty string is not $Optstore(type,$key,$cmangled) value." |
||||
} |
||||
if { ![string is $Optstore(type,$key,$cmangled) $val]} { |
||||
return -code error "$caller, $key $val is not $Optstore(type,$key,$cmangled) value." |
||||
} |
||||
} |
||||
double { |
||||
if { $val == "" } { |
||||
return -code error "$caller, $key empty string is not double value." |
||||
} |
||||
if { ![string is double $val]} { |
||||
return -code error "$caller, $key $val is not double value." |
||||
} |
||||
if { [string is integer $val]} { |
||||
set val [expr {$val + .0}] |
||||
} |
||||
} |
||||
default { |
||||
} |
||||
} |
||||
set o($key) $val |
||||
} |
||||
|
||||
foreach key $Optstore(argneeded,$cmangled) { |
||||
if {![info exists o($key)]} { |
||||
return -code error "$caller, needed argument $key was not given." |
||||
} |
||||
} |
||||
|
||||
if { [catch { CheckValues $caller $cmangled [array get o]} err]} { |
||||
return -code error $err |
||||
} |
||||
|
||||
return |
||||
} |
||||
|
||||
|
||||
proc argp::CheckValues { caller cmangled checklist } { |
||||
variable Optstore |
||||
|
||||
#puts "Checking $checklist" |
||||
|
||||
foreach {key val} $checklist { |
||||
if { [llength $Optstore(allowed,$key,$cmangled)] > 0 } { |
||||
switch -exact -- $Optstore(type,$key,$cmangled) { |
||||
string { |
||||
if { [lsearch $Optstore(allowed,$key,$cmangled) $val] < 0} { |
||||
return -code error "$caller, $key $val is not in allowed values: $Optstore(allowed,$key,$cmangled)" |
||||
} |
||||
} |
||||
double - |
||||
integer { |
||||
set found 0 |
||||
foreach range $Optstore(allowed,$key,$cmangled) { |
||||
if {[llength $range] == 1} { |
||||
if { $val == [lindex $range 0] } { |
||||
set found 1 |
||||
break |
||||
} |
||||
} elseif {[llength $range] == 2} { |
||||
set low [lindex $range 0] |
||||
set high [lindex $range 1] |
||||
|
||||
if { ![string is integer $low] \ |
||||
&& [string compare "-" $low] != 0} { |
||||
return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has a lower value range that is not integer and not ´-´: $range" |
||||
} |
||||
if { ![string is integer $high] \ |
||||
&& [string compare "+" $high] != 0} { |
||||
return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has a upper value range that is not integer and not ´+´: $range" |
||||
} |
||||
if {[string compare "-" $low] == 0} { |
||||
if { [string compare "+" $high] == 0 \ |
||||
|| $val <= $high } { |
||||
set found 1 |
||||
break |
||||
} |
||||
} |
||||
if { $val >= $low } { |
||||
if {[string compare "+" $high] == 0 \ |
||||
|| $val <= $high } { |
||||
set found 1 |
||||
break |
||||
} |
||||
} |
||||
} else { |
||||
return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has an allowed value range containing more than 2 elements: $range" |
||||
} |
||||
} |
||||
if { $found == 0 } { |
||||
return -code error "$caller, $key $val is not covered by allowed ranges: $Optstore(allowed,$key,$cmangled)" |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
@ -0,0 +1,157 @@
|
||||
|
||||
package provide [lassign {overtype 1.3} pkg ver]$pkg [namespace eval $pkg[set pkg {}] {list [variable version $ver[set ver {}]]$version}] |
||||
|
||||
#Julian Noble <julian@precisium.com.au> - 2003 |
||||
#Released under standard 'BSD license' conditions. |
||||
# |
||||
#todo - ellipsis truncation indicator for center,right |
||||
|
||||
|
||||
namespace eval overtype { |
||||
namespace export * |
||||
} |
||||
proc overtype::about {} { |
||||
return "Simple text formatting. Author JMN. BSD-License" |
||||
} |
||||
|
||||
|
||||
proc overtype::left {args} { |
||||
# @c overtype starting at left (overstrike) |
||||
# @c can/should we use something like this?: 'format "%-*s" $len $overtext |
||||
|
||||
if {[llength $args] < 2} { |
||||
error {usage: ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} |
||||
} |
||||
foreach {undertext overtext} [lrange $args end-1 end] break |
||||
|
||||
set opt(-ellipsis) 0 |
||||
set opt(-ellipsistext) {...} |
||||
set opt(-overflow) 0 |
||||
array set opt [lrange $args 0 end-2] |
||||
|
||||
|
||||
set len [string length $undertext] |
||||
set overlen [string length $overtext] |
||||
set diff [expr {$overlen - $len}] |
||||
if {$diff > 0} { |
||||
if {$opt(-overflow)} { |
||||
return $overtext |
||||
} else { |
||||
if {$opt(-ellipsis)} { |
||||
return [overtype::right [string range $overtext 0 [expr {$len -1}]] $opt(-ellipsistext)] |
||||
} else { |
||||
return [string range $overtext 0 [expr {$len -1}]] |
||||
} |
||||
} |
||||
} else { |
||||
|
||||
return "$overtext[string range $undertext $overlen end]" |
||||
} |
||||
} |
||||
|
||||
# test - use more tcl8.5 features. |
||||
proc overtype::left2 {args} { |
||||
# @c overtype starting at left (overstrike) |
||||
# @c can/should we use something like this?: 'format "%-*s" $len $overtext |
||||
|
||||
if {[llength $args] < 2} { |
||||
error {usage: ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} |
||||
} |
||||
foreach {undertext overtext} [lrange $args end-1 end] break |
||||
|
||||
set opt(-ellipsis) 0 |
||||
set opt(-ellipsistext) {...} |
||||
set opt(-overflow) 0 |
||||
array set opt [lrange $args 0 end-2] |
||||
|
||||
|
||||
set len [string length $undertext] |
||||
set overlen [string length $overtext] |
||||
set diff [expr {$overlen - $len}] |
||||
if {$diff > 0} { |
||||
if {$opt(-overflow)} { |
||||
return $overtext |
||||
} else { |
||||
if {$opt(-ellipsis)} { |
||||
return [overtype::right [string range $overtext 0 $len-1] $opt(-ellipsistext)] |
||||
} else { |
||||
return [string range $overtext 0 $len-1 ] |
||||
} |
||||
} |
||||
} else { |
||||
#return "$overtext[string range $undertext $overlen end]" |
||||
return [string replace $undertext 0 $overlen-1 $overtext] |
||||
} |
||||
} |
||||
proc overtype::centre {args} { |
||||
if {[llength $args] < 2} { |
||||
error {usage: ?-bias [left|right]? ?-overflow [1|0]? undertext overtext} |
||||
} |
||||
foreach {undertext overtext} [lrange $args end-1 end] break |
||||
|
||||
set opt(-bias) left |
||||
set opt(-overflow) 0 |
||||
array set opt [lrange $args 0 end-2] |
||||
|
||||
|
||||
set olen [string length $overtext] |
||||
set ulen [string length $undertext] |
||||
set diff [expr {$ulen - $olen}] |
||||
if {$diff > 0} { |
||||
set half [expr {round(int($diff / 2))}] |
||||
if {[string match right $opt(-bias)]} { |
||||
if {[expr {2 * $half}] < $diff} { |
||||
incr half |
||||
} |
||||
} |
||||
|
||||
set rhs [expr {$diff - $half - 1}] |
||||
set lhs [expr {$half - 1}] |
||||
|
||||
set a [string range $undertext 0 $lhs] |
||||
set b $overtext |
||||
set c [string range $undertext end-$rhs end] |
||||
return $a$b$c |
||||
} else { |
||||
if {$diff < 0} { |
||||
if {$opt(-overflow)} { |
||||
return $overtext |
||||
} else { |
||||
return [string range $overtext 0 [expr {$ulen - 1}]] |
||||
} |
||||
} else { |
||||
return $overtext |
||||
} |
||||
} |
||||
} |
||||
|
||||
proc overtype::right {args} { |
||||
# @d !todo - implement overflow, length checks etc |
||||
|
||||
if {[llength $args] < 2} { |
||||
error {usage: ?-overflow [1|0]? undertext overtext} |
||||
} |
||||
foreach {undertext overtext} [lrange $args end-1 end] break |
||||
|
||||
set opt(-overflow) 0 |
||||
array set opt [lrange $args 0 end-2] |
||||
|
||||
|
||||
set olen [string length $overtext] |
||||
set ulen [string length $undertext] |
||||
|
||||
if {$opt(-overflow)} { |
||||
return [string range $undertext 0 end-$olen]$overtext |
||||
} else { |
||||
if {$olen > $ulen} { |
||||
set diff [expr {$olen - $ulen}] |
||||
return [string range $undertext 0 end-$olen][string range $overtext 0 end-$diff] |
||||
} else { |
||||
return [string range $undertext 0 end-$olen]$overtext |
||||
} |
||||
} |
||||
} |
||||
|
||||
namespace eval overtype { |
||||
interp alias {} ::overtype::center {} ::overtype::centre |
||||
} |
||||
@ -0,0 +1,428 @@
|
||||
# -*- tcl -*- |
||||
# ### ### ### ######### ######### ######### |
||||
## Overview |
||||
|
||||
# Heuristics to assemble a platform identifier from publicly available |
||||
# information. The identifier describes the platform of the currently |
||||
# running tcl shell. This is a mixture of the runtime environment and |
||||
# of build-time properties of the executable itself. |
||||
# |
||||
# Examples: |
||||
# <1> A tcl shell executing on a x86_64 processor, but having a |
||||
# wordsize of 4 was compiled for the x86 environment, i.e. 32 |
||||
# bit, and loaded packages have to match that, and not the |
||||
# actual cpu. |
||||
# |
||||
# <2> The hp/solaris 32/64 bit builds of the core cannot be |
||||
# distinguished by looking at tcl_platform. As packages have to |
||||
# match the 32/64 information we have to look in more places. In |
||||
# this case we inspect the executable itself (magic numbers, |
||||
# i.e. fileutil::magic::filetype). |
||||
# |
||||
# The basic information used comes out of the 'os' and 'machine' |
||||
# entries of the 'tcl_platform' array. A number of general and |
||||
# os/machine specific transformation are applied to get a canonical |
||||
# result. |
||||
# |
||||
# General |
||||
# Only the first element of 'os' is used - we don't care whether we |
||||
# are on "Windows NT" or "Windows XP" or whatever. |
||||
# |
||||
# Machine specific |
||||
# % amd64 -> x86_64 |
||||
# % arm* -> arm |
||||
# % sun4* -> sparc |
||||
# % ia32* -> ix86 |
||||
# % intel -> ix86 |
||||
# % i*86* -> ix86 |
||||
# % Power* -> powerpc |
||||
# % x86_64 + wordSize 4 => x86 code |
||||
# |
||||
# OS specific |
||||
# % AIX are always powerpc machines |
||||
# % HP-UX 9000/800 etc means parisc |
||||
# % linux has to take glibc version into account |
||||
# % sunos -> solaris, and keep version number |
||||
# |
||||
# NOTE: A platform like linux glibc 2.3, which can use glibc 2.2 stuff |
||||
# has to provide all possible allowed platform identifiers when |
||||
# searching search. Ditto a solaris 2.8 platform can use solaris 2.6 |
||||
# packages. Etc. This is handled by the other procedure, see below. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requirements |
||||
|
||||
namespace eval ::platform {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Implementation |
||||
|
||||
# -- platform::generic |
||||
# |
||||
# Assembles an identifier for the generic platform. It leaves out |
||||
# details like kernel version, libc version, etc. |
||||
|
||||
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}" |
||||
} |
||||
|
||||
# -- platform::identify |
||||
# |
||||
# Assembles an identifier for the exact platform, by extending the |
||||
# generic identifier. I.e. it adds in details like kernel version, |
||||
# libc version, etc., if they are relevant for the loading of |
||||
# packages on the platform. |
||||
|
||||
proc ::platform::identify {} { |
||||
global tcl_platform |
||||
|
||||
set id [generic] |
||||
regexp {^([^-]+)-([^-]+)$} $id -> plat cpu |
||||
|
||||
switch -- $plat { |
||||
solaris { |
||||
regsub {^5} $tcl_platform(osVersion) 2 text |
||||
append plat $text |
||||
return "${plat}-${cpu}" |
||||
} |
||||
macosx { |
||||
set major [lindex [split $tcl_platform(osVersion) .] 0] |
||||
if {$major > 19} { |
||||
set minor [lindex [split $tcl_platform(osVersion) .] 1] |
||||
incr major -9 |
||||
append plat $major.[expr {$minor - 1}] |
||||
} else { |
||||
incr major -4 |
||||
append plat 10.$major |
||||
return "${plat}-${cpu}" |
||||
} |
||||
return "${plat}-${cpu}" |
||||
} |
||||
linux { |
||||
# Look for the libc*.so and determine its version |
||||
# (libc5/6, libc6 further glibc 2.X) |
||||
|
||||
set v unknown |
||||
|
||||
# Determine in which directory to look. /lib, or /lib64. |
||||
# For that we use the tcl_platform(wordSize). |
||||
# |
||||
# We could use the 'cpu' info, per the equivalence below, |
||||
# that however would be restricted to intel. And this may |
||||
# be a arm, mips, etc. system. The wordsize is more |
||||
# fundamental. |
||||
# |
||||
# ix86 <=> (wordSize == 4) <=> 32 bit ==> /lib |
||||
# x86_64 <=> (wordSize == 8) <=> 64 bit ==> /lib64 |
||||
# |
||||
# Do not look into /lib64 even if present, if the cpu |
||||
# doesn't fit. |
||||
|
||||
# TODO: Determine the prefixes (i386, x86_64, ...) for |
||||
# other cpus. The path after the generic one is utterly |
||||
# specific to intel right now. Ok, on Ubuntu, possibly |
||||
# other Debian systems we may apparently be able to query |
||||
# the necessary CPU code. If we can't we simply use the |
||||
# hardwired fallback. |
||||
|
||||
switch -exact -- $tcl_platform(wordSize) { |
||||
4 { |
||||
lappend bases /lib |
||||
if {[catch { |
||||
exec dpkg-architecture -qDEB_HOST_MULTIARCH |
||||
} res]} { |
||||
lappend bases /lib/i386-linux-gnu |
||||
} else { |
||||
# dpkg-arch returns the full tripled, not just cpu. |
||||
lappend bases /lib/$res |
||||
} |
||||
} |
||||
8 { |
||||
lappend bases /lib64 |
||||
if {[catch { |
||||
exec dpkg-architecture -qDEB_HOST_MULTIARCH |
||||
} res]} { |
||||
lappend bases /lib/x86_64-linux-gnu |
||||
} else { |
||||
# dpkg-arch returns the full tripled, not just cpu. |
||||
lappend bases /lib/$res |
||||
} |
||||
} |
||||
default { |
||||
return -code error "Bad wordSize $tcl_platform(wordSize), expected 4 or 8" |
||||
} |
||||
} |
||||
|
||||
foreach base $bases { |
||||
if {[LibcVersion $base -> v]} break |
||||
} |
||||
|
||||
append plat -$v |
||||
return "${plat}-${cpu}" |
||||
} |
||||
} |
||||
|
||||
return $id |
||||
} |
||||
|
||||
proc ::platform::LibcVersion {base _->_ vv} { |
||||
upvar 1 $vv v |
||||
set libclist [lsort [glob -nocomplain -directory $base libc*]] |
||||
|
||||
if {![llength $libclist]} { return 0 } |
||||
|
||||
set libc [lindex $libclist 0] |
||||
|
||||
# Try executing the library first. This should suceed |
||||
# for a glibc library, and return the version |
||||
# information. |
||||
|
||||
if {![catch { |
||||
set vdata [lindex [split [exec $libc] \n] 0] |
||||
}]} { |
||||
regexp {version ([0-9]+(\.[0-9]+)*)} $vdata -> v |
||||
foreach {major minor} [split $v .] break |
||||
set v glibc${major}.${minor} |
||||
return 1 |
||||
} else { |
||||
# We had trouble executing the library. We are now |
||||
# inspecting its name to determine the version |
||||
# number. This code by Larry McVoy. |
||||
|
||||
if {[regexp -- {libc-([0-9]+)\.([0-9]+)} $libc -> major minor]} { |
||||
set v glibc${major}.${minor} |
||||
return 1 |
||||
} |
||||
} |
||||
return 0 |
||||
} |
||||
|
||||
# -- platform::patterns |
||||
# |
||||
# Given an exact platform identifier, i.e. _not_ the generic |
||||
# identifier it assembles a list of exact platform identifier |
||||
# describing platform which should be compatible with the |
||||
# input. |
||||
# |
||||
# I.e. packages for all platforms in the result list should be |
||||
# loadable on the specified platform. |
||||
|
||||
# << Should we add the generic identifier to the list as well ? In |
||||
# general it is not compatible I believe. So better not. In many |
||||
# cases the exact identifier is identical to the generic one |
||||
# anyway. |
||||
# >> |
||||
|
||||
proc ::platform::patterns {id} { |
||||
set res [list $id] |
||||
if {$id eq "tcl"} {return $res} |
||||
|
||||
switch -glob -- $id { |
||||
solaris*-* { |
||||
if {[regexp {solaris([^-]*)-(.*)} $id -> v cpu]} { |
||||
if {$v eq ""} {return $id} |
||||
foreach {major minor} [split $v .] break |
||||
incr minor -1 |
||||
for {set j $minor} {$j >= 6} {incr j -1} { |
||||
lappend res solaris${major}.${j}-${cpu} |
||||
} |
||||
} |
||||
} |
||||
linux*-* { |
||||
if {[regexp {linux-glibc([^-]*)-(.*)} $id -> v cpu]} { |
||||
foreach {major minor} [split $v .] break |
||||
incr minor -1 |
||||
for {set j $minor} {$j >= 0} {incr j -1} { |
||||
lappend res linux-glibc${major}.${j}-${cpu} |
||||
} |
||||
} |
||||
} |
||||
macosx-powerpc { |
||||
lappend res macosx-universal |
||||
} |
||||
macosx-x86_64 { |
||||
lappend res macosx-i386-x86_64 |
||||
} |
||||
macosx-ix86 { |
||||
lappend res macosx-universal macosx-i386-x86_64 |
||||
} |
||||
macosx*-* { |
||||
# 10.5+,11.0+ |
||||
if {[regexp {macosx([^-]*)-(.*)} $id -> v cpu]} { |
||||
|
||||
switch -exact -- $cpu { |
||||
ix86 { |
||||
lappend alt i386-x86_64 |
||||
lappend alt universal |
||||
} |
||||
x86_64 { |
||||
if {[lindex [split $::tcl_platform(osVersion) .] 0] < 19} { |
||||
set alt i386-x86_64 |
||||
} else { |
||||
set alt {} |
||||
} |
||||
} |
||||
arm { |
||||
lappend alt x86_64 |
||||
} |
||||
default { set alt {} } |
||||
} |
||||
|
||||
if {$v ne ""} { |
||||
foreach {major minor} [split $v .] break |
||||
|
||||
set res {} |
||||
if {$major eq 11} { |
||||
# Add 11.0 to 11.minor to patterns. |
||||
for {set j $minor} {$j >= 0} {incr j -1} { |
||||
lappend res macosx${major}.${j}-${cpu} |
||||
foreach a $alt { |
||||
lappend res macosx${major}.${j}-$a |
||||
} |
||||
} |
||||
set major 10 |
||||
set minor 15 |
||||
} |
||||
# Add 10.5 to 10.minor to patterns. |
||||
for {set j $minor} {$j >= 5} {incr j -1} { |
||||
if {$cpu ne "arm"} { |
||||
lappend res macosx${major}.${j}-${cpu} |
||||
} |
||||
foreach a $alt { |
||||
lappend res macosx${major}.${j}-$a |
||||
} |
||||
} |
||||
|
||||
# Add unversioned patterns for 10.3/10.4 builds. |
||||
lappend res macosx-${cpu} |
||||
foreach a $alt { |
||||
lappend res macosx-$a |
||||
} |
||||
} else { |
||||
# No version, just do unversioned patterns. |
||||
foreach a $alt { |
||||
lappend res macosx-$a |
||||
} |
||||
} |
||||
} else { |
||||
# no v, no cpu ... nothing |
||||
} |
||||
} |
||||
} |
||||
lappend res tcl ; # Pure tcl packages are always compatible. |
||||
return $res |
||||
} |
||||
|
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide platform 1.0.17 |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Demo application |
||||
|
||||
if {[info exists argv0] && ($argv0 eq [info script])} { |
||||
puts ==================================== |
||||
parray tcl_platform |
||||
puts ==================================== |
||||
puts Generic\ identification:\ [::platform::generic] |
||||
puts Exact\ identification:\ \ \ [::platform::identify] |
||||
puts ==================================== |
||||
puts Search\ patterns: |
||||
puts *\ [join [::platform::patterns [::platform::identify]] \n*\ ] |
||||
puts ==================================== |
||||
exit 0 |
||||
} |
||||
@ -0,0 +1,241 @@
|
||||
|
||||
# -*- tcl -*- |
||||
# ### ### ### ######### ######### ######### |
||||
## Overview |
||||
|
||||
# Higher-level commands which invoke the functionality of this package |
||||
# for an arbitrary tcl shell (tclsh, wish, ...). This is required by a |
||||
# repository as while the tcl shell executing packages uses the same |
||||
# platform in general as a repository application there can be |
||||
# differences in detail (i.e. 32/64 bit builds). |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requirements |
||||
|
||||
package require platform |
||||
namespace eval ::platform::shell {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Implementation |
||||
|
||||
# -- platform::shell::generic |
||||
|
||||
proc ::platform::shell::generic {shell} { |
||||
# Argument is the path to a tcl shell. |
||||
|
||||
CHECK $shell |
||||
LOCATE base out |
||||
|
||||
set code {} |
||||
# Forget any pre-existing platform package, it might be in |
||||
# conflict with this one. |
||||
lappend code {package forget platform} |
||||
# Inject our platform package |
||||
lappend code [list source $base] |
||||
# Query and print the architecture |
||||
lappend code {puts [platform::generic]} |
||||
# And done |
||||
lappend code {exit 0} |
||||
|
||||
set arch [RUN $shell [join $code \n]] |
||||
|
||||
if {$out} {file delete -force $base} |
||||
return $arch |
||||
} |
||||
|
||||
# -- platform::shell::identify |
||||
|
||||
proc ::platform::shell::identify {shell} { |
||||
# Argument is the path to a tcl shell. |
||||
|
||||
CHECK $shell |
||||
LOCATE base out |
||||
|
||||
set code {} |
||||
# Forget any pre-existing platform package, it might be in |
||||
# conflict with this one. |
||||
lappend code {package forget platform} |
||||
# Inject our platform package |
||||
lappend code [list source $base] |
||||
# Query and print the architecture |
||||
lappend code {puts [platform::identify]} |
||||
# And done |
||||
lappend code {exit 0} |
||||
|
||||
set arch [RUN $shell [join $code \n]] |
||||
|
||||
if {$out} {file delete -force $base} |
||||
return $arch |
||||
} |
||||
|
||||
# -- platform::shell::platform |
||||
|
||||
proc ::platform::shell::platform {shell} { |
||||
# Argument is the path to a tcl shell. |
||||
|
||||
CHECK $shell |
||||
|
||||
set code {} |
||||
lappend code {puts $tcl_platform(platform)} |
||||
lappend code {exit 0} |
||||
|
||||
return [RUN $shell [join $code \n]] |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Internal helper commands. |
||||
|
||||
proc ::platform::shell::CHECK {shell} { |
||||
if {![file exists $shell]} { |
||||
return -code error "Shell \"$shell\" does not exist" |
||||
} |
||||
if {![file executable $shell]} { |
||||
return -code error "Shell \"$shell\" is not executable (permissions)" |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc ::platform::shell::LOCATE {bv ov} { |
||||
upvar 1 $bv base $ov out |
||||
|
||||
# Locate the platform package for injection into the specified |
||||
# shell. We are using package management to find it, whereever it |
||||
# is, instead of using hardwired relative paths. This allows us to |
||||
# install the two packages as TMs without breaking the code |
||||
# here. If the found package is wrapped we copy the code somewhere |
||||
# where the spawned shell will be able to read it. |
||||
|
||||
# This code is brittle, it needs has to adapt to whatever changes |
||||
# are made to the TM code, i.e. the provide statement generated by |
||||
# tm.tcl |
||||
|
||||
set pl [package ifneeded platform [package require platform]] |
||||
set base [lindex $pl end] |
||||
|
||||
set out 0 |
||||
if {[lindex [file system $base]] ne "native"} { |
||||
set temp [TEMP] |
||||
file copy -force $base $temp |
||||
set base $temp |
||||
set out 1 |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc ::platform::shell::RUN {shell code} { |
||||
set c [TEMP] |
||||
set cc [open $c w] |
||||
puts $cc $code |
||||
close $cc |
||||
|
||||
set e [TEMP] |
||||
|
||||
set code [catch { |
||||
exec $shell $c 2> $e |
||||
} res] |
||||
|
||||
file delete $c |
||||
|
||||
if {$code} { |
||||
append res \n[read [set chan [open $e r]]][close $chan] |
||||
file delete $e |
||||
return -code error "Shell \"$shell\" is not executable ($res)" |
||||
} |
||||
|
||||
file delete $e |
||||
return $res |
||||
} |
||||
|
||||
proc ::platform::shell::TEMP {} { |
||||
set prefix platform |
||||
|
||||
# This code is copied out of Tcllib's fileutil package. |
||||
# (TempFile/tempfile) |
||||
|
||||
set tmpdir [DIR] |
||||
|
||||
set chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" |
||||
set nrand_chars 10 |
||||
set maxtries 10 |
||||
set access [list RDWR CREAT EXCL TRUNC] |
||||
set permission 0600 |
||||
set channel "" |
||||
set checked_dir_writable 0 |
||||
set mypid [pid] |
||||
for {set i 0} {$i < $maxtries} {incr i} { |
||||
set newname $prefix |
||||
for {set j 0} {$j < $nrand_chars} {incr j} { |
||||
append newname [string index $chars \ |
||||
[expr {int(rand()*62)}]] |
||||
} |
||||
set newname [file join $tmpdir $newname] |
||||
if {[file exists $newname]} { |
||||
after 1 |
||||
} else { |
||||
if {[catch {open $newname $access $permission} channel]} { |
||||
if {!$checked_dir_writable} { |
||||
set dirname [file dirname $newname] |
||||
if {![file writable $dirname]} { |
||||
return -code error "Directory $dirname is not writable" |
||||
} |
||||
set checked_dir_writable 1 |
||||
} |
||||
} else { |
||||
# Success |
||||
close $channel |
||||
return [file normalize $newname] |
||||
} |
||||
} |
||||
} |
||||
if {$channel ne ""} { |
||||
return -code error "Failed to open a temporary file: $channel" |
||||
} else { |
||||
return -code error "Failed to find an unused temporary file name" |
||||
} |
||||
} |
||||
|
||||
proc ::platform::shell::DIR {} { |
||||
# This code is copied out of Tcllib's fileutil package. |
||||
# (TempDir/tempdir) |
||||
|
||||
global tcl_platform env |
||||
|
||||
set attempdirs [list] |
||||
|
||||
foreach tmp {TMPDIR TEMP TMP} { |
||||
if { [info exists env($tmp)] } { |
||||
lappend attempdirs $env($tmp) |
||||
} |
||||
} |
||||
|
||||
switch $tcl_platform(platform) { |
||||
windows { |
||||
lappend attempdirs "C:\\TEMP" "C:\\TMP" "\\TEMP" "\\TMP" |
||||
} |
||||
macintosh { |
||||
set tmpdir $env(TRASH_FOLDER) ;# a better place? |
||||
} |
||||
default { |
||||
lappend attempdirs \ |
||||
[file join / tmp] \ |
||||
[file join / var tmp] \ |
||||
[file join / usr tmp] |
||||
} |
||||
} |
||||
|
||||
lappend attempdirs [pwd] |
||||
|
||||
foreach tmp $attempdirs { |
||||
if { [file isdirectory $tmp] && [file writable $tmp] } { |
||||
return [file normalize $tmp] |
||||
} |
||||
} |
||||
|
||||
# Fail if nothing worked. |
||||
return -code error "Unable to determine a proper directory for temporary files" |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide platform::shell 1.1.4 |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,595 @@
|
||||
#package require logger |
||||
|
||||
package provide shellthread [namespace eval shellthread { |
||||
variable version |
||||
set version 1.6 |
||||
}] |
||||
|
||||
|
||||
package require Thread |
||||
|
||||
namespace eval shellthread { |
||||
|
||||
proc iso8601 {{tsmicros ""}} { |
||||
if {$tsmicros eq ""} { |
||||
set tsmicros [clock micros] |
||||
} else { |
||||
set microsnow [clock micros] |
||||
if {[string length $tsmicros] != [string length $microsnow]} { |
||||
error "iso8601 requires 'clock micros' or empty string to create timestamp" |
||||
} |
||||
} |
||||
set seconds [expr {$tsmicros / 1000000}] |
||||
return [clock format $seconds -format "%Y-%m-%d_%H-%M-%S"] |
||||
} |
||||
} |
||||
|
||||
namespace eval shellthread::worker { |
||||
variable settings |
||||
variable sysloghost_port |
||||
variable sock |
||||
variable logfile "" |
||||
variable fd |
||||
variable client_ids [list] |
||||
variable ts_start_micros |
||||
variable errorlist [list] |
||||
variable inpipe "" |
||||
|
||||
proc bgerror {args} { |
||||
variable errorlist |
||||
lappend errorlist $args |
||||
} |
||||
proc send_errors_now {tidcli} { |
||||
variable errorlist |
||||
thread::send -async $tidcli [list shellthread::manager::report_worker_errors [list worker_tid [thread::id] errors $errorlist]] |
||||
} |
||||
proc add_client_tid {tidcli} { |
||||
variable client_ids |
||||
if {$tidcli ni $client_ids} { |
||||
lappend client_ids $tidcli |
||||
} |
||||
} |
||||
proc init {tidclient start_m settingsdict} { |
||||
variable sysloghost_port |
||||
variable logfile |
||||
variable settings |
||||
interp bgerror {} shellthread::worker::bgerror |
||||
package require overtype |
||||
variable client_ids |
||||
variable ts_start_micros |
||||
lappend client_ids $tidclient |
||||
set ts_start_micros $start_m |
||||
|
||||
set defaults [list -raw 0 -file "" -syslog "" -direction out] |
||||
set settings [dict merge $defaults $settingsdict] |
||||
|
||||
set syslog [dict get $settings -syslog] |
||||
if {[string length $syslog]} { |
||||
lassign [split $syslog :] s_host s_port |
||||
set sysloghost_port [list $s_host $s_port] |
||||
} else { |
||||
set sysloghost_port "" |
||||
} |
||||
if {[catch {package require udp} errm]} { |
||||
#disable rather than bomb and interfere with any -file being written |
||||
set sysloghost_port "" |
||||
} |
||||
|
||||
set logfile [dict get $settings -file] |
||||
} |
||||
|
||||
proc start_pipe_read {source readchan args} { |
||||
#assume 1 inpipe for now |
||||
variable inpipe |
||||
variable sysloghost_port |
||||
variable logfile |
||||
set defaults [dict create -buffering \uFFFF ] |
||||
set opts [dict merge $defaults $args] |
||||
if {[dict exists $opts -readbuffering]} { |
||||
set readbuffering [dict get $opts -readbuffering] |
||||
} else { |
||||
if {[dict get $opts -buffering] eq "\uFFFF"} { |
||||
#get buffering setting from the channel as it was set prior to thread::transfer |
||||
set readbuffering [chan configure $readchan -buffering] |
||||
} else { |
||||
set readbuffering [dict get $opts -buffering] |
||||
chan configure $readchan -buffering $readbuffering |
||||
} |
||||
} |
||||
if {[dict exists $opts -writebuffering]} { |
||||
set writebuffering [dict get $opts -writebuffering] |
||||
} else { |
||||
if {[dict get $opts -buffering] eq "\uFFFF"} { |
||||
set writebuffering line |
||||
#set writebuffering [chan configure $writechan -buffering] |
||||
} else { |
||||
set writebuffering [dict get $opts -buffering] |
||||
#can configure $writechan -buffering $writebuffering |
||||
} |
||||
} |
||||
|
||||
chan configure $readchan -translation lf |
||||
|
||||
if {$readchan ni [chan names]} { |
||||
error "shellthread::worker::start_pipe_read - inpipe not configured. Use shellthread::manager::set_pipe_read_from_client to thread::transfer the pipe end" |
||||
} |
||||
set inpipe $readchan |
||||
#::shellthread::worker::log $inpipe 0 - $source - info "START PIPE READ HELLO\n" line |
||||
chan configure $readchan -blocking 0 |
||||
#::shellthread::worker::log $inpipe 0 - $source - info "START PIPE READ HELLO2 readbuffering: $readbuffering syslog $sysloghost_port filename $logfile" line |
||||
|
||||
set waitvar ::shellthread::worker::wait($inpipe,[clock micros]) |
||||
chan event $readchan readable [list apply {{chan source waitfor readbuffering writebuffering} { |
||||
if {$readbuffering eq "line"} { |
||||
set chunksize [chan gets $chan chunk] |
||||
if {$chunksize >= 0} { |
||||
if {![chan eof $chan]} { |
||||
::shellthread::worker::log pipe 0 - $source - info $chunk\n $writebuffering |
||||
} else { |
||||
::shellthread::worker::log pipe 0 - $source - info $chunk $writebuffering |
||||
} |
||||
} |
||||
} else { |
||||
set chunk [chan read $chan] |
||||
::shellthread::worker::log pipe 0 - $source - info $chunk $writebuffering |
||||
} |
||||
if {[chan eof $chan]} { |
||||
chan event $chan readable {} |
||||
set $waitfor "pipe" |
||||
chan close $chan |
||||
} |
||||
}} $readchan $source $waitvar $readbuffering $writebuffering] |
||||
#::shellthread::worker::log $inpipe 0 - $source - info "START PIPE READ HELLO3 vwaiting on $waitvar\n" line |
||||
vwait $waitvar |
||||
} |
||||
|
||||
proc start_pipe_write {source writechan args} { |
||||
variable outpipe |
||||
set defaults [dict create -buffering \uFFFF ] |
||||
set opts [dict merge $defaults $args] |
||||
|
||||
#todo! |
||||
set readchan stdin |
||||
|
||||
if {[dict exists $opts -readbuffering]} { |
||||
set readbuffering [dict get $opts -readbuffering] |
||||
} else { |
||||
if {[dict get $opts -buffering] eq "\uFFFF"} { |
||||
set readbuffering [chan configure $readchan -buffering] |
||||
} else { |
||||
set readbuffering [dict get $opts -buffering] |
||||
chan configure $readchan -buffering $readbuffering |
||||
} |
||||
} |
||||
if {[dict exists $opts -writebuffering]} { |
||||
set writebuffering [dict get $opts -writebuffering] |
||||
} else { |
||||
if {[dict get $opts -buffering] eq "\uFFFF"} { |
||||
#nothing explicitly set - take from transferred channel |
||||
set writebuffering [chan configure $writechan -buffering] |
||||
} else { |
||||
set writebuffering [dict get $opts -buffering] |
||||
can configure $writechan -buffering $writebuffering |
||||
} |
||||
} |
||||
|
||||
if {$writechan ni [chan names]} { |
||||
error "shellthread::worker::start_pipe_write - outpipe not configured. Use shellthread::manager::set_pipe_write_to_client to thread::transfer the pipe end" |
||||
} |
||||
set outpipe $writechan |
||||
chan configure $readchan -blocking 0 |
||||
chan configure $writechan -blocking 0 |
||||
set waitvar ::shellthread::worker::wait($outpipe,[clock micros]) |
||||
|
||||
chan event $readchan readable [list apply {{chan writechan source waitfor readbuffering} { |
||||
if {$readbuffering eq "line"} { |
||||
set chunksize [chan gets $chan chunk] |
||||
if {$chunksize >= 0} { |
||||
if {![chan eof $chan]} { |
||||
puts $writechan $chunk |
||||
} else { |
||||
puts -nonewline $writechan $chunk |
||||
} |
||||
} |
||||
} else { |
||||
set chunk [chan read $chan] |
||||
puts -nonewline $writechan $chunk |
||||
} |
||||
if {[chan eof $chan]} { |
||||
chan event $chan readable {} |
||||
set $waitfor "pipe" |
||||
chan close $writechan |
||||
if {$chan ne "stdin"} { |
||||
chan close $chan |
||||
} |
||||
} |
||||
}} $readchan $writechan $source $waitvar $readbuffering] |
||||
|
||||
vwait $waitvar |
||||
} |
||||
|
||||
|
||||
proc _initsock {} { |
||||
variable sysloghost_port |
||||
variable sock |
||||
if {[string length $sysloghost_port]} { |
||||
if {[catch {fconfigure $sock} state]} { |
||||
set sock [udp_open] |
||||
fconfigure $sock -buffering none -translation binary |
||||
fconfigure $sock -remote $sysloghost_port |
||||
} |
||||
} |
||||
} |
||||
proc _reconnect {} { |
||||
variable sock |
||||
catch {close $sock} |
||||
_initsock |
||||
return [fconfigure $sock] |
||||
} |
||||
|
||||
proc send_info {client_tid ts_sent source msg} { |
||||
set ts_received [clock micros] |
||||
set lag_micros [expr {$ts_received - $ts_sent}] |
||||
set lag [expr {$lag_micros / 1000000.0}] ;#lag as x.xxxxxx seconds |
||||
|
||||
log $client_tid $ts_sent $lag $source - info $msg line 1 |
||||
} |
||||
proc log {client_tid ts_sent lag source service level msg writebuffering {islog 0}} { |
||||
variable sock |
||||
variable fd |
||||
variable sysloghost_port |
||||
variable logfile |
||||
variable settings |
||||
|
||||
set logchunk $msg |
||||
|
||||
if {![dict get $settings -raw]} { |
||||
set tail_crlf 0 |
||||
set tail_lf 0 |
||||
set tail_cr 0 |
||||
#for cooked - always remove the trailing newline before splitting.. |
||||
# |
||||
#note that if we got our data from reading a non-line-buffered binary channel - then this naive line splitting will not split neatly for mixed line-endings. |
||||
# |
||||
#Possibly not critical as cooked is for logging and we are still preserving all \r and \n chars - but review and consider implementing a better split |
||||
#but add it back exactly as it was afterwards |
||||
#we can always split on \n - and any adjacent \r will be preserved in the rejoin |
||||
set lastchar [string range $logchunk end end] |
||||
if {[string range $logchunk end-1 end] eq "\r\n"} { |
||||
set tail_crlf 1 |
||||
set logchunk [string range $logchunk 0 end-2] |
||||
} else { |
||||
if {$lastchar eq "\n"} { |
||||
set tail_lf 1 |
||||
set logchunk [string range $logchunk 0 end-1] |
||||
} elseif {$lastchar eq "\r"} { |
||||
#\r line-endings are obsolete..and unlikely... and ugly as they can hide characters on the console. but we'll pass through anyway. |
||||
set tail_cr 1 |
||||
set logchunk [string range $logchunk 0 end-1] |
||||
} else { |
||||
#possibly a single line with no linefeed.. or has linefeeds only in the middle |
||||
} |
||||
} |
||||
|
||||
if {$ts_sent != 0} { |
||||
set micros [lindex [split [expr {$ts_sent / 1000000.0}] .] end] |
||||
set time_info [::shellthread::iso8601 $ts_sent].$micros |
||||
#set time_info "${time_info}+$lag" |
||||
set lagfp "+[format %f $lag]" |
||||
} else { |
||||
#from pipe - no ts_sent/lag info available |
||||
set time_info "" |
||||
set lagfp "" |
||||
} |
||||
|
||||
set idtail [string range $client_tid end-8 end] ;#enough for display purposes id - mostly zeros anyway |
||||
set col0 [string repeat " " 9] |
||||
set col1 [string repeat " " 27] |
||||
set col2 [string repeat " " 11] |
||||
set col3 [string repeat " " 20] |
||||
#do not columnize the final data column or append to tail - or we could muck up the crlf integrity |
||||
|
||||
lassign [list [overtype::left $col0 $idtail] [overtype::left $col1 $time_info] [overtype::left $col2 $lagfp] [overtype::left $col3 $source]] c0 c1 c2 c3 |
||||
|
||||
#split on \n no matter the actual line-ending in use |
||||
#shouldn't matter as long as we don't add anything at the end of the line other than the raw data |
||||
#ie - don't quote or add spaces |
||||
set lines [split $logchunk \n] |
||||
|
||||
set i 1 |
||||
set outlines [list] |
||||
foreach ln $lines { |
||||
if {$i == 1} { |
||||
lappend outlines "$c0 $c1 $c2 $c3 $ln" |
||||
} else { |
||||
lappend outlines "$c0 $c1 $col2 $c3 $ln" |
||||
} |
||||
incr i |
||||
} |
||||
if {$tail_lf} { |
||||
set logchunk "[join $outlines \n]\n" |
||||
} elseif {$tail_crlf} { |
||||
set logchunk "[join $outlines \r\n]\r\n" |
||||
} elseif {$tail_cr} { |
||||
set logchunk "[join $outlines \r]\r" |
||||
} else { |
||||
#no trailing linefeed |
||||
set logchunk [join $outlines \n] |
||||
|
||||
} |
||||
|
||||
#set logchunk "[overtype::left $col0 $idtail] [overtype::left $col1 $time_info] [overtype::left $col2 "+$lagfp"] [overtype::left $col3 $source] $msg" |
||||
} |
||||
|
||||
if {[string length $sysloghost_port]} { |
||||
_initsock |
||||
catch {puts -nonewline $sock $logchunk} |
||||
} |
||||
#todo - sockets etc? |
||||
if {[string length $logfile]} { |
||||
#todo - setting to maintain open filehandle and reduce io. |
||||
# possible settings for buffersize - and maybe logrotation, although this could be left to client |
||||
#for now - default to safe option of open/close each write despite the overhead. |
||||
set fd [open $logfile a] |
||||
chan configure $fd -translation auto -buffering $writebuffering |
||||
#whether line buffered or not - by now our logchunk includes newlines |
||||
puts -nonewline $fd $logchunk |
||||
close $fd |
||||
} |
||||
} |
||||
|
||||
# - withdraw just this client |
||||
proc finish {tidclient} { |
||||
variable client_ids |
||||
if {($tidclient in $clientids) && ([llength $clientids] == 1)} { |
||||
terminate $tidclient |
||||
} else { |
||||
set posn [lsearch $client_ids $tidclient] |
||||
set client_ids [lreplace $clientids $posn $posn] |
||||
} |
||||
} |
||||
|
||||
#allow any client to terminate |
||||
proc terminate {tidclient} { |
||||
variable sock |
||||
variable client_ids |
||||
if {$tidclient in $client_ids} { |
||||
catch {close $sock} |
||||
set client_ids [list] |
||||
return 1 |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
namespace eval shellthread::manager { |
||||
variable workers [dict create] |
||||
variable worker_errors [list] |
||||
|
||||
variable log_threads |
||||
|
||||
#new datastructure regarding workers and sourcetags required. |
||||
#one worker can service multiple sourcetags - but each sourcetag may be used by multiple threads too. |
||||
#generally each thread will use a specific sourcetag - but we may have pools doing similar things which log to same destination. |
||||
# |
||||
#As a convention we may use a sourcetag for the thread which started the worker that isn't actually used for logging - but as a common target for joins |
||||
#If the thread which started the thread calls leave_worker with that 'primary' sourcetag it means others won't be able to use that target - which seems reasonable. |
||||
#If another thread want's to maintain joinability beyond the span provided by the starting client, |
||||
#it can join with both the primary tag and a tag it will actually use for logging. |
||||
#A thread can join the logger with any existingtag - not just the 'primary' |
||||
#(which is arbitrary anyway. It will usually be the first in the list - but may be unsubscribed by clients and disappear) |
||||
proc join_worker {client_tid existingtag sourcetaglist} { |
||||
#todo - allow a source to piggyback on existing worker by referencing one of the sourcetags already using the worker |
||||
} |
||||
proc leave_worker {client_tid sourcetaglist} { |
||||
#todo |
||||
#unsub this client_tid from the sourcetags in the sourcetaglist. if no more client_tids exist for sourcetag, remove sourcetag, |
||||
#if no more sourcetags - close worker |
||||
} |
||||
#it is up to caller to use a unique sourcetag (e.g by prefixing with own thread::id etc) |
||||
# This allows multiple threads to more easily write to the same named sourcetag if necessary |
||||
# todo - change sourcetag for a list of tags which will be handled by the same thread. e.g for multiple threads logging to same file |
||||
# |
||||
# todo - some protection mechanism for case where target is a file to stop creation of multiple worker threads writing to same file. |
||||
# Even if we use open fd,close fd wrapped around writes.. it is probably undesirable to have multiple threads with same target |
||||
# On the other hand socket targets such as UDP can happily be written to by multiple threads. |
||||
# For now the mechanism is that a call to new_worker (rename to open_worker?) will join the same thread if a sourcetag matches.. |
||||
# but, as sourcetags can get removed(unsubbed via leave_worker) this doesn't guarantee two threads with same -file settings won't fight. |
||||
# Also.. the settingsdict is ignored when joining with a tag that exists.. this is problematic.. e.g logrotation where previous file still being written by existing worker |
||||
# todo - rename 'sourcetag' concept to 'targettag' ?? the concept is a mixture of both.. it is somewhat analagous to a syslog 'facility' |
||||
# probably new_worker should disallow auto-joining and we allow different workers to handle same tags simultaneously to support overlap during logrotation etc. |
||||
proc new_worker {sourcetaglist {settingsdict {}}} { |
||||
variable workers |
||||
set ts_start [clock micros] |
||||
set tidclient [thread::id] |
||||
set sourcetag [lindex $sourcetaglist 0] ;#todo - use all |
||||
|
||||
if {[dict exists $workers $sourcetag]} { |
||||
set winfo [dict get $workers $sourcetag] |
||||
if {[thread::exists [dict get $winfo tid]]} { |
||||
#add our client-info to existing worker thread |
||||
dict lappend winfo list_client_tids $tidclient |
||||
dict set workers $sourcetag $winfo ;#writeback |
||||
return [dict get $winfo tid] |
||||
} |
||||
} |
||||
#set ts_start [::shellthread::iso8601] |
||||
set tidworker [thread::create -preserved] |
||||
set init_script [string map [list %ts_start% $ts_start %mp% [tcl::tm::list] %ap% $::auto_path %tidcli% $tidclient %sd% $settingsdict] { |
||||
#set tclbase [file dirname [file dirname [info nameofexecutable]]] |
||||
#set tcllib $tclbase/lib |
||||
#if {$tcllib ni $::auto_path} { |
||||
# lappend ::auto_path $tcllib |
||||
#} |
||||
|
||||
set ::settingsinfo [dict create %sd%] |
||||
#if the executable running things is something like a tclkit, |
||||
# then it's likely we will need to use the caller's auto_path and tcl::tm::list to find things |
||||
#The caller can tune the thread's package search by providing a settingsdict |
||||
if {![dict exists $::settingsinfo tcl_tm_list]} { |
||||
tcl::tm::add %mp% |
||||
} else { |
||||
tcl::tm::remove {*}[tcl::tm::list] |
||||
tcl::tm::add {*}[dict get $::settingsinfo tcl_tm_list] |
||||
} |
||||
if {![dict exists $::settingsinfo auto_path]} { |
||||
set ::auto_path [list %ap%] |
||||
} else { |
||||
set ::auto_path [dict get $::settingsinfo auto_path] |
||||
} |
||||
|
||||
package require Thread |
||||
package require shellthread |
||||
if {![catch {::shellthread::worker::init %tidcli% %ts_start% $::settingsinfo} errmsg]} { |
||||
unset ::settingsinfo |
||||
set ::shellthread_init "ok" |
||||
} else { |
||||
unset ::settingsinfo |
||||
set ::shellthread_init "err $errmsg" |
||||
} |
||||
}] |
||||
|
||||
thread::send -async $tidworker $init_script |
||||
#thread::send $tidworker $init_script |
||||
set winfo [dict create tid $tidworker list_client_tids [list $tidclient] ts_start $ts_start ts_end_list [list]] |
||||
dict set workers $sourcetag $winfo |
||||
return $tidworker |
||||
} |
||||
|
||||
proc set_pipe_read_from_client {tag_pipename worker_tid rchan args} { |
||||
variable workers |
||||
if {![dict exists $workers $tag_pipename]} { |
||||
error "workerthread::manager::set_pipe_read_from_client source/pipename $tag_pipename not found" |
||||
} |
||||
set match_worker_tid [dict get $workers $tag_pipename tid] |
||||
if {$worker_tid ne $match_worker_tid} { |
||||
error "workerthread::manager::set_pipe_read_from_client source/pipename $tag_pipename workert_tid mismatch '$worker_tid' vs existing:'$match_worker_tid'" |
||||
} |
||||
#buffering set during channel creation will be preserved on thread::transfer |
||||
thread::transfer $worker_tid $rchan |
||||
#start_pipe_read will vwait - so we have to send async |
||||
thread::send -async $worker_tid [list ::shellthread::worker::start_pipe_read $tag_pipename $rchan] |
||||
#client may start writing immediately - but presumably it will buffer in fifo2 |
||||
} |
||||
|
||||
proc set_pipe_write_to_client {tag_pipename worker_tid wchan args} { |
||||
variable workers |
||||
if {![dict exists $workers $tag_pipename]} { |
||||
error "workerthread::manager::set_pipe_write_to_client pipename $tag_pipename not found" |
||||
} |
||||
set match_worker_tid [dict get $workers $tag_pipename tid] |
||||
if {$worker_tid ne $match_worker_tid} { |
||||
error "workerthread::manager::set_pipe_write_to_client pipename $tag_pipename workert_tid mismatch '$worker_tid' vs existing:'$match_worker_tid'" |
||||
} |
||||
#buffering set during channel creation will be preserved on thread::transfer |
||||
thread::transfer $worker_tid $wchan |
||||
thread::send -async $worker_tid [list ::shellthread::worker::start_pipe_write $tag_pipename $wchan] |
||||
} |
||||
|
||||
proc write_log {source msg args} { |
||||
variable workers |
||||
set ts_micros_sent [clock micros] |
||||
set defaults [list -async 1 -level info] |
||||
set opts [dict merge $defaults $args] |
||||
|
||||
if {[dict exists $workers $source]} { |
||||
set tidworker [dict get $workers $source tid] |
||||
if {![thread::exists $tidworker]} { |
||||
set tidworker [new_worker $source] |
||||
} |
||||
} else { |
||||
#auto create with no requirement to call new_worker.. warn? |
||||
set tidworker [new_worker $source] |
||||
} |
||||
set client_tid [thread::id] |
||||
if {[dict get $opts -async]} { |
||||
thread::send -async $tidworker [list ::shellthread::worker::send_info $client_tid $ts_micros_sent $source $msg] |
||||
} else { |
||||
thread::send $tidworker [list ::shellthread::worker::send_info $client_tid $ts_micros_sent $source $msg] |
||||
} |
||||
} |
||||
proc report_worker_errors {errdict} { |
||||
variable workers |
||||
set reporting_tid [dict get $errdict worker_tid] |
||||
dict for {src srcinfo} $workers { |
||||
if {[dict get $srcinfo tid] eq $reporting_tid} { |
||||
dict set srcinfo errors [dict get $errdict errors] |
||||
dict set workers $src $srcinfo ;#writeback updated |
||||
break |
||||
} |
||||
} |
||||
} |
||||
proc close_worker {source {timeout 2500}} { |
||||
variable workers |
||||
variable worker_errors |
||||
set ts_now [clock micros] |
||||
#puts stderr "close_worker $source" |
||||
if {[dict exists $workers $source]} { |
||||
set tidworker [dict get $workers $source tid] |
||||
set ts_end_list [dict get $workers $source ts_end_list] |
||||
if {[llength $ts_end_list]} { |
||||
set last_end_ts [lindex $ts_end_list end] |
||||
if {[expr {(($tsnow - $last_end_ts) / 1000) >= $timeout}]} { |
||||
lappend ts_end_list $ts_now |
||||
dict set workers $source ts_end_list $ts_end_list |
||||
} else { |
||||
#existing close in progress.. assume it will work |
||||
return |
||||
} |
||||
} |
||||
|
||||
if {[thread::exists $tidworker]} { |
||||
#puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source still running.. terminating" |
||||
set timeoutarr($source) 0 |
||||
after $timeout [list set timeoutarr($source) 2] |
||||
|
||||
thread::send -async $tidworker [list shellthread::worker::send_errors_now [thread::id]] |
||||
thread::send -async $tidworker [list shellthread::worker::terminate [thread::id]] timeoutarr($source) |
||||
|
||||
#thread::send -async $tidworker [string map [list %tidclient% [thread::id]] { |
||||
# shellthread::worker::terminate %tidclient% |
||||
#}] timeoutarr($source) |
||||
|
||||
vwait timeoutarr($source) |
||||
#puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source DONE1" |
||||
|
||||
thread::release $tidworker |
||||
#puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source DONE2" |
||||
if {[dict exists $workers $source errors]} { |
||||
set errlist [dict get $workers $source errors] |
||||
if {[llength $errlist]} { |
||||
lappend worker_errors [list $source [dict get $workers $source]] |
||||
} |
||||
} |
||||
dict unset workers $source |
||||
} |
||||
} |
||||
#puts stdout "close_worker $source - end" |
||||
} |
||||
|
||||
#worker errors only available for a source after close_worker called on that source |
||||
#It is possible for there to be multiple entries for a source because new_worker can be called multiple times with same sourcetag, |
||||
# e.g if a thread |
||||
proc get_and_clear_errors {source} { |
||||
variable worker_errors |
||||
set source_errors [lsearch -all -inline -index 0 $worker_errors $source] |
||||
set worker_errors [lsearch -all -inline -index 0 -not $worker_errors $source] |
||||
return $source_errors |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
Binary file not shown.
@ -0,0 +1,3 @@
|
||||
|
||||
package ifneeded app-punk 1.0 [list source [file join $dir repl.tcl]] |
||||
|
||||
@ -0,0 +1,820 @@
|
||||
#temp |
||||
package provide app-punk 1.0 |
||||
|
||||
set stdin_info [chan configure stdin] |
||||
if {[dict exists $stdin_info -inputmode]} { |
||||
#this is the only way I currently know to detect console on windows.. doesn't work on Alma linux. |
||||
# tcl_interactive used by repl to determine if stderr output prompt to be printed. |
||||
# (that way, piping commands into stdin should not produce prompts for each command) |
||||
set tcl_interactive 1 |
||||
} |
||||
#however, the -mode option only seems to appear on linux when a terminal exists.. |
||||
if {[dict exists $stdin_info -mode]} { |
||||
set tcl_interactive 1 |
||||
} |
||||
|
||||
#give up for now |
||||
set tcl_interactive 1 |
||||
|
||||
proc todo {} { |
||||
puts "tcl History" |
||||
|
||||
|
||||
} |
||||
tcl::tm::add [pwd]/modules |
||||
|
||||
package require shellfilter |
||||
package require Thread |
||||
set outdevice [shellfilter::stack::new punkout -settings {-tag "punkout" -buffering none -raw 1 -syslog 127.0.0.1:514 -file "c:/repo/jn/shellspy/logs/repl-exec-stdout.txt"}] |
||||
set out [dict get $outdevice localchan] |
||||
set errdevice [shellfilter::stack::new punkerr -settings {-tag "punkerr" -buffering none -raw 1 -syslog 127.0.0.1:514 -file "c:/repo/jn/shellspy/logs/repl-exec-stderr.txt"}] |
||||
set err [dict get $errdevice localchan] |
||||
# |
||||
#set indevice [shellfilter::stack::new commandin -settings {-tag "commandin" -readbuffering line -writebuffering none -raw 1 -direction in}] |
||||
#set program_read_stdin_pipe [dict get $indevice localchan] |
||||
|
||||
|
||||
|
||||
# unknown -- |
||||
# This procedure is called when a Tcl command is invoked that doesn't |
||||
# exist in the interpreter. It takes the following steps to make the |
||||
# command available: |
||||
# |
||||
# 1. See if the autoload facility can locate the command in a |
||||
# Tcl script file. If so, load it and execute it. |
||||
# 2. If the command was invoked interactively at top-level: |
||||
# (a) see if the command exists as an executable UNIX program. |
||||
# If so, "exec" the command. |
||||
# (b) see if the command requests csh-like history substitution |
||||
# in one of the common forms !!, !<number>, or ^old^new. If |
||||
# so, emulate csh's history substitution. |
||||
# (c) see if the command is a unique abbreviation for another |
||||
# command. If so, invoke the command. |
||||
# |
||||
# Arguments: |
||||
# args - A list whose elements are the words of the original |
||||
# command, including the command name. |
||||
|
||||
proc unknown args { |
||||
variable ::tcl::UnknownPending |
||||
global auto_noexec auto_noload env tcl_interactive errorInfo errorCode |
||||
|
||||
if {[info exists errorInfo]} { |
||||
set savedErrorInfo $errorInfo |
||||
} |
||||
if {[info exists errorCode]} { |
||||
set savedErrorCode $errorCode |
||||
} |
||||
|
||||
set name [lindex $args 0] |
||||
if {![info exists auto_noload]} { |
||||
# |
||||
# Make sure we're not trying to load the same proc twice. |
||||
# |
||||
if {[info exists UnknownPending($name)]} { |
||||
return -code error "self-referential recursion\ |
||||
in \"unknown\" for command \"$name\"" |
||||
} |
||||
set UnknownPending($name) pending |
||||
set ret [catch { |
||||
auto_load $name [uplevel 1 {::namespace current}] |
||||
} msg opts] |
||||
unset UnknownPending($name) |
||||
if {$ret != 0} { |
||||
dict append opts -errorinfo "\n (autoloading \"$name\")" |
||||
return -options $opts $msg |
||||
} |
||||
if {![array size UnknownPending]} { |
||||
unset UnknownPending |
||||
} |
||||
if {$msg} { |
||||
if {[info exists savedErrorCode]} { |
||||
set ::errorCode $savedErrorCode |
||||
} else { |
||||
unset -nocomplain ::errorCode |
||||
} |
||||
if {[info exists savedErrorInfo]} { |
||||
set errorInfo $savedErrorInfo |
||||
} else { |
||||
unset -nocomplain errorInfo |
||||
} |
||||
set code [catch {uplevel 1 $args} msg opts] |
||||
if {$code == 1} { |
||||
# |
||||
# Compute stack trace contribution from the [uplevel]. |
||||
# Note the dependence on how Tcl_AddErrorInfo, etc. |
||||
# construct the stack trace. |
||||
# |
||||
set errInfo [dict get $opts -errorinfo] |
||||
set errCode [dict get $opts -errorcode] |
||||
set cinfo $args |
||||
if {[string length [encoding convertto utf-8 $cinfo]] > 150} { |
||||
set cinfo [string range $cinfo 0 150] |
||||
while {[string length [encoding convertto utf-8 $cinfo]] > 150} { |
||||
set cinfo [string range $cinfo 0 end-1] |
||||
} |
||||
append cinfo ... |
||||
} |
||||
set tail "\n (\"uplevel\" body line 1)\n invoked\ |
||||
from within\n\"uplevel 1 \$args\"" |
||||
set expect "$msg\n while executing\n\"$cinfo\"$tail" |
||||
if {$errInfo eq $expect} { |
||||
# |
||||
# The stack has only the eval from the expanded command |
||||
# Do not generate any stack trace here. |
||||
# |
||||
dict unset opts -errorinfo |
||||
dict incr opts -level |
||||
return -options $opts $msg |
||||
} |
||||
# |
||||
# Stack trace is nested, trim off just the contribution |
||||
# from the extra "eval" of $args due to the "catch" above. |
||||
# |
||||
set last [string last $tail $errInfo] |
||||
if {$last + [string length $tail] != [string length $errInfo]} { |
||||
# Very likely cannot happen |
||||
return -options $opts $msg |
||||
} |
||||
set errInfo [string range $errInfo 0 $last-1] |
||||
set tail "\"$cinfo\"" |
||||
set last [string last $tail $errInfo] |
||||
if {$last < 0 || $last + [string length $tail] != [string length $errInfo]} { |
||||
return -code error -errorcode $errCode \ |
||||
-errorinfo $errInfo $msg |
||||
} |
||||
set errInfo [string range $errInfo 0 $last-1] |
||||
set tail "\n invoked from within\n" |
||||
set last [string last $tail $errInfo] |
||||
if {$last + [string length $tail] == [string length $errInfo]} { |
||||
return -code error -errorcode $errCode \ |
||||
-errorinfo [string range $errInfo 0 $last-1] $msg |
||||
} |
||||
set tail "\n while executing\n" |
||||
set last [string last $tail $errInfo] |
||||
if {$last + [string length $tail] == [string length $errInfo]} { |
||||
return -code error -errorcode $errCode \ |
||||
-errorinfo [string range $errInfo 0 $last-1] $msg |
||||
} |
||||
return -options $opts $msg |
||||
} else { |
||||
dict incr opts -level |
||||
return -options $opts $msg |
||||
} |
||||
} |
||||
} |
||||
#set isrepl [expr {[file tail [file rootname [info script]]] eq "repl"}] |
||||
set isrepl $::repl::running ;#may not be reading though |
||||
if {$isrepl} { |
||||
#set ::tcl_interactive 1 |
||||
} |
||||
if {$isrepl || (([info level] == 1) && (([info script] eq "" ) ) |
||||
&& ([info exists tcl_interactive] && $tcl_interactive))} { |
||||
if {![info exists auto_noexec]} { |
||||
set new [auto_execok $name] |
||||
if {$new ne ""} { |
||||
set redir "" |
||||
if {[namespace which -command console] eq ""} { |
||||
set redir ">&@stdout <@stdin" |
||||
} |
||||
|
||||
|
||||
#experiment todo - use twapi and named pipes |
||||
#twapi::namedpipe_server {\\.\pipe\something} |
||||
#Then override tcl 'exec' and replace all stdout/stderr/stdin with our fake ones |
||||
#These can be stacked with shellfilter and operate as OS handles - which we can't do with fifo2 etc |
||||
# |
||||
|
||||
|
||||
# 'script' command to fake a tty |
||||
# note that we lose the exit code from the underlying command by using 'script' if we call shellfilter::run without -e option to script |
||||
set scr [auto_execok script] |
||||
if {$scr ne ""} { |
||||
if {[string first " " $new] > 0} { |
||||
set c1 $name |
||||
} else { |
||||
set c1 $new |
||||
} |
||||
#set scriptrun "( $c1 [lrange $args 1 end] )" |
||||
|
||||
set scriptrun_commandlist [shellfilter::get_scriptrun_from_cmdlist_dquote_if_not $args] |
||||
|
||||
if 0 { |
||||
set scriptrun "( $c1 " |
||||
foreach a [lrange $args 1 end] { |
||||
if {[string first " " $a] > 0} { |
||||
#append scriptrun "\"$a\"" |
||||
append scriptrun $a |
||||
} else { |
||||
append scriptrun $a |
||||
} |
||||
append scriptrun " " |
||||
} |
||||
append scriptrun " )" |
||||
} |
||||
#------------------------------------- |
||||
if 0 { |
||||
package require string::token::shell |
||||
set shellparts [string token shell -indices $args] |
||||
|
||||
set scriptrun "( $c1 " |
||||
foreach info [lrange $shellparts 1 end] { |
||||
set type [lindex $info 0] |
||||
if {$type eq "D:QUOTED"} { |
||||
append scriptrun "\"" |
||||
append scriptrun [lindex $info 3] |
||||
append scriptrun "\"" |
||||
} elseif {$type eq "S:QUOTED"} { |
||||
append scriptrun "'" |
||||
append scriptrun [lindex $info 3] |
||||
append scriptrun "'" |
||||
} elseif {$type eq "PLAIN"} { |
||||
append scriptrun [lindex $info 3] |
||||
} else { |
||||
error "Can't interpret '$args' with sh-like syntax" |
||||
} |
||||
append scriptrun " " |
||||
} |
||||
append scriptrun " )" |
||||
} |
||||
|
||||
#------------------------------------- |
||||
#puts stderr ">>>scriptrun_commandlist: $scriptrun_commandlist" |
||||
|
||||
#uplevel 1 [list ::catch \ |
||||
[list ::shellfilter::run [list $scr -q -e -c $scriptrun /dev/null] -teehandle punk -inbuffering line -outbuffering none ] \ |
||||
::tcl::UnknownResult ::tcl::UnknownOptions] |
||||
|
||||
uplevel 1 [list ::catch \ |
||||
[list ::shellfilter::run $scriptrun_commandlist -teehandle punk -inbuffering line -outbuffering none ] \ |
||||
::tcl::UnknownResult ::tcl::UnknownOptions] |
||||
|
||||
|
||||
|
||||
#puts stderr "script result $::tcl::UnknownOptions $::tcl::UnknownResult" |
||||
} else { |
||||
uplevel 1 [list ::catch \ |
||||
[list ::shellfilter::run [concat $new [lrange $args 1 end]] -teehandle punk -inbuffering line -outbuffering none ] \ |
||||
::tcl::UnknownResult ::tcl::UnknownOptions] |
||||
} |
||||
if {[string trim $::tcl::UnknownResult] ne "exitcode 0"} { |
||||
dict set ::tcl::UnknownOptions -code error |
||||
set ::tcl::UnknownResult "Non-zero exit code from command '$c1 [lrange $args 1 end]' $::tcl::UnknownResult" |
||||
} else { |
||||
#no point returning "exitcode 0" if that's the only non-error return. |
||||
#It is misleading. Better to return empty string. |
||||
set ::tcl::UnknownResult "" |
||||
} |
||||
|
||||
|
||||
#uplevel 1 [list ::catch \ |
||||
# [concat exec $redir $new [lrange $args 1 end]] \ |
||||
# ::tcl::UnknownResult ::tcl::UnknownOptions] |
||||
|
||||
#puts "===exec with redir:$redir $::tcl::UnknownResult ==" |
||||
dict incr ::tcl::UnknownOptions -level |
||||
return -options $::tcl::UnknownOptions $::tcl::UnknownResult |
||||
} |
||||
} |
||||
if {$name eq "!!"} { |
||||
set newcmd [history event] |
||||
} elseif {[regexp {^!(.+)$} $name -> event]} { |
||||
set newcmd [history event $event] |
||||
} elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name -> old new]} { |
||||
set newcmd [history event -1] |
||||
catch {regsub -all -- $old $newcmd $new newcmd} |
||||
} |
||||
if {[info exists newcmd]} { |
||||
tclLog $newcmd |
||||
history change $newcmd 0 |
||||
uplevel 1 [list ::catch $newcmd \ |
||||
::tcl::UnknownResult ::tcl::UnknownOptions] |
||||
dict incr ::tcl::UnknownOptions -level |
||||
return -options $::tcl::UnknownOptions $::tcl::UnknownResult |
||||
} |
||||
|
||||
set ret [catch {set candidates [info commands $name*]} msg] |
||||
if {$name eq "::"} { |
||||
set name "" |
||||
} |
||||
if {$ret != 0} { |
||||
dict append opts -errorinfo \ |
||||
"\n (expanding command prefix \"$name\" in unknown)" |
||||
return -options $opts $msg |
||||
} |
||||
# Filter out bogus matches when $name contained |
||||
# a glob-special char [Bug 946952] |
||||
if {$name eq ""} { |
||||
# Handle empty $name separately due to strangeness |
||||
# in [string first] (See RFE 1243354) |
||||
set cmds $candidates |
||||
} else { |
||||
set cmds [list] |
||||
foreach x $candidates { |
||||
if {[string first $name $x] == 0} { |
||||
lappend cmds $x |
||||
} |
||||
} |
||||
} |
||||
if {[llength $cmds] == 1} { |
||||
uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] \ |
||||
::tcl::UnknownResult ::tcl::UnknownOptions] |
||||
dict incr ::tcl::UnknownOptions -level |
||||
return -options $::tcl::UnknownOptions $::tcl::UnknownResult |
||||
} |
||||
if {[llength $cmds]} { |
||||
return -code error "ambiguous command name \"$name\": [lsort $cmds]" |
||||
} |
||||
} |
||||
return -code error -errorcode [list TCL LOOKUP COMMAND $name] \ |
||||
"invalid command name \"$name\"" |
||||
} |
||||
|
||||
|
||||
proc know {cond body} { |
||||
proc unknown {args} [string map [list @c@ $cond @b@ $body] { |
||||
if {![catch {expr {@c@}} res] && $res} { |
||||
return [eval {@b@}] |
||||
#tailcall @b@ |
||||
} |
||||
}][info body unknown] |
||||
} |
||||
proc know? {} { |
||||
puts [string range [info body unknown] 0 511] |
||||
} |
||||
if 1 { |
||||
know {[expr $args] || 1} {expr $args} |
||||
know {[regexp {^([0-9]+)\.\.([0-9]+)$} [lindex $args 0] -> from to]} { |
||||
set res {} |
||||
while {$from<=$to} {lappend res $from; incr from} |
||||
set res |
||||
} |
||||
|
||||
|
||||
#run as raw string instead of tcl-list - no variable subst etc |
||||
proc do_runraw {commandline} { |
||||
#return [shellfilter::run [lrange $args 1 end] -teehandle punk -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] |
||||
puts stdout ">>runraw got: $commandline" |
||||
|
||||
#run always echoes anyway.. as we aren't diverting stdout/stderr off for capturing |
||||
#for consistency with other runxxx commands - we'll just consume it. (review) |
||||
#set wordparts [regexp -inline -all {\S+} $commandline] |
||||
package require string::token::shell |
||||
set parts [string token shell -indices $commandline] |
||||
puts stdout ">>shellparts: $parts" |
||||
|
||||
set runwords [list] |
||||
foreach p $parts { |
||||
set ptype [lindex $p 0] |
||||
set pval [lindex $p 3] |
||||
if {$ptype eq "PLAIN"} { |
||||
lappend runwords [lindex $p 3] |
||||
} elseif {$ptype eq "D:QUOTED"} { |
||||
set v {"} |
||||
append v $pval |
||||
append v {"} |
||||
lappend runwords $v |
||||
} elseif {$ptype eq "S:QUOTED"} { |
||||
set v {'} |
||||
append v $pval |
||||
append v {'} |
||||
lappend runwords $v |
||||
} |
||||
} |
||||
puts stdout ">>runraw runwords: $runwords" |
||||
set runwords [lrange $runwords 1 end] |
||||
|
||||
puts stdout ">>runraw runwords: $runwords" |
||||
#set args [lrange $args 1 end] |
||||
#set runwords [lrange $wordparts 1 end] |
||||
|
||||
set known_runopts [list "-echo" "-e" "-terminal" "-t"] |
||||
set aliases [list "-e" "-echo" "-echo" "-echo" "-t" "-terminal" "-terminal" "-terminal"] ;#include map to self |
||||
set runopts [list] |
||||
set cmdwords [list] |
||||
set idx_first_cmdarg [lsearch -not $runwords "-*"] |
||||
set runopts [lrange $runwords 0 $idx_first_cmdarg-1] |
||||
set cmdwords [lrange $runwords $idx_first_cmdarg end] |
||||
|
||||
foreach o $runopts { |
||||
if {$o ni $known_runopts} { |
||||
error "runout: Unknown runoption $o" |
||||
} |
||||
} |
||||
set runopts [lmap o $runopts {dict get $aliases $o}] |
||||
|
||||
set cmd_as_string [join $cmdwords " "] |
||||
puts stdout ">>cmd_as_string: $cmd_as_string" |
||||
|
||||
if {"-terminal" in $runopts} { |
||||
set tcmd [shellfilter::get_scriptrun_from_cmdlist_dquote_if_not $cmdwords] |
||||
puts stdout ">>tcmd: $tcmd" |
||||
#set exitinfo [shellfilter::run $tcmd -teehandle punk -inbuffering line -outbuffering none ] |
||||
set exitinfo "not-implemented" |
||||
} else { |
||||
set exitinfo [shellfilter::run $cmdwords -teehandle punk -inbuffering line -outbuffering none ] |
||||
} |
||||
|
||||
if {[dict exists $exitinfo error]} { |
||||
#todo - check errorInfo makes sense.. return -code? tailcall? |
||||
error [dict get $exitinfo error] |
||||
} |
||||
return $exitinfo |
||||
} |
||||
|
||||
#NOTE: the run,runout,runerr,runx commands only produce an error if the command didn't run. |
||||
# - If it did run, but there was a non-zero exitcode it is up to the application to check that. |
||||
#This is deliberate, but means 'catch' doesn't catch errors within the command itself - the exitcode has to be checked. |
||||
#The user can always use exec for different process error semantics (they don't get exitcode with exec) |
||||
know {[lindex $args 0] eq "runraw"} { |
||||
return [do_run $args] |
||||
} |
||||
know {[lindex $args 0] eq "run"} { |
||||
set args [lrange $args 1 end] |
||||
set known_runopts [list "-echo" "-e"] |
||||
set aliases [list "-e" "-echo" "-echo" "-echo"] ;#include map to self |
||||
set runopts [list] |
||||
set cmdargs [list] |
||||
set idx_first_cmdarg [lsearch -not $args "-*"] |
||||
set runopts [lrange $args 0 $idx_first_cmdarg-1] |
||||
set cmdargs [lrange $args $idx_first_cmdarg end] |
||||
foreach o $runopts { |
||||
if {$o ni $known_runopts} { |
||||
error "run: Unknown runoption $o" |
||||
} |
||||
} |
||||
set runopts [lmap o $runopts {dict get $aliases $o}] |
||||
|
||||
set exitinfo [shellfilter::run $cmdargs -teehandle punk -inbuffering none -outbuffering none ] |
||||
} |
||||
|
||||
know {[lindex $args 0] eq "runout"} { |
||||
set ::runout "" |
||||
|
||||
set args [lrange $args 1 end] |
||||
set known_runopts [list "-echo" "-e"] |
||||
set aliases [list "-e" "-echo" "-echo" "-echo"] ;#include map to self |
||||
set runopts [list] |
||||
set cmdargs [list] |
||||
set idx_first_cmdarg [lsearch -not $args "-*"] |
||||
set runopts [lrange $args 0 $idx_first_cmdarg-1] |
||||
set cmdargs [lrange $args $idx_first_cmdarg end] |
||||
foreach o $runopts { |
||||
if {$o ni $known_runopts} { |
||||
error "runout: Unknown runoption $o" |
||||
} |
||||
} |
||||
set runopts [lmap o $runopts {dict get $aliases $o}] |
||||
|
||||
#puts stdout "RUNOUT cmdargs: $cmdargs" |
||||
|
||||
#set outvar_stackid [shellfilter::stack::add commandout tee_to_var -action float -settings {-varname ::runout}] |
||||
if {"-echo" in $runopts} { |
||||
set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action sink-locked -settings {-varname ::runout}] |
||||
} else { |
||||
set stdout_stackid [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::runout}] |
||||
} |
||||
|
||||
#shellfilter::run [lrange $args 1 end] -teehandle punk -outchan stdout -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler |
||||
set exitinfo [shellfilter::run $cmdargs -teehandle punk -inbuffering none -outbuffering none ] |
||||
|
||||
shellfilter::stack::remove stdout $stdout_stackid |
||||
#shellfilter::stack::remove commandout $outvar_stackid |
||||
if {[dict exists $exitinfo error]} { |
||||
#we must raise an error. |
||||
#todo - check errorInfo makes sense.. return -code? tailcall? |
||||
error [dict get $exitinfo error] |
||||
} |
||||
puts stderr $exitinfo |
||||
return $::runout |
||||
} |
||||
know {[lindex $args 0] eq "runerr"} { |
||||
set ::runerr "" |
||||
|
||||
set args [lrange $args 1 end] |
||||
set known_runopts [list "-echo" "-e"] |
||||
set aliases [list "-e" "-echo" "-echo" "-echo"] ;#include map to self |
||||
set runopts [list] |
||||
set cmdargs [list] |
||||
set idx_first_cmdarg [lsearch -not $args "-*"] |
||||
set runopts [lrange $args 0 $idx_first_cmdarg-1] |
||||
set cmdargs [lrange $args $idx_first_cmdarg end] |
||||
foreach o $runopts { |
||||
if {$o ni $known_runopts} { |
||||
error "runout: Unknown runoption $o" |
||||
} |
||||
} |
||||
set runopts [lmap o $runopts {dict get $aliases $o}] |
||||
|
||||
if {"-echo" in $runopts} { |
||||
set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action sink-locked -settings {-varname ::runerr}] |
||||
} else { |
||||
set stderr_stackid [shellfilter::stack::add stderr var -action sink-locked -settings {-varname ::runerr}] |
||||
} |
||||
set exitinfo [shellfilter::run $cmdargs -teehandle punk -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] |
||||
shellfilter::stack::remove stderr $stderr_stackid |
||||
|
||||
|
||||
#we raise an error because an error during calling is different to collecting stderr from a command, and the caller should be able to wrap in a catch |
||||
# to determine something other than just a nonzero exit code or output on stderr. |
||||
if {[dict exists $exitinfo error]} { |
||||
#todo - check errorInfo makes sense.. return -code? tailcall? |
||||
error [dict get $exitinfo error] |
||||
} |
||||
|
||||
|
||||
puts stderr \n$exitinfo |
||||
return $::runerr |
||||
} |
||||
know {[lindex $args 0] eq "runx"} { |
||||
set ::runerr "" |
||||
set ::runout "" |
||||
|
||||
set args [lrange $args 1 end] |
||||
set known_runopts [list "-echo" "-e"] |
||||
set aliases [list "-e" "-echo" "-echo" "-echo"] ;#include map to self |
||||
set runopts [list] |
||||
set cmdargs [list] |
||||
set idx_first_cmdarg [lsearch -not $args "-*"] |
||||
set runopts [lrange $args 0 $idx_first_cmdarg-1] |
||||
set cmdargs [lrange $args $idx_first_cmdarg end] |
||||
foreach o $runopts { |
||||
if {$o ni $known_runopts} { |
||||
error "runout: Unknown runoption $o" |
||||
} |
||||
} |
||||
set runopts [lmap o $runopts {dict get $aliases $o}] |
||||
|
||||
|
||||
|
||||
#shellfilter::stack::remove stdout $::repl::id_outstack |
||||
|
||||
if {"-echo" in $runopts} { |
||||
set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action sink-locked -settings {-varname ::runerr}] |
||||
set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action sink-locked -settings {-varname ::runout}] |
||||
} else { |
||||
set stderr_stackid [shellfilter::stack::add stderr var -action sink-locked -settings {-varname ::runerr}] |
||||
set stdout_stackid [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::runout}] |
||||
} |
||||
|
||||
set exitinfo [shellfilter::run $cmdargs -teehandle punk -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] |
||||
|
||||
shellfilter::stack::remove stdout $stdout_stackid |
||||
shellfilter::stack::remove stderr $stderr_stackid |
||||
|
||||
set ::repl::output "" |
||||
|
||||
|
||||
#set x [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::repl::runxoutput}] |
||||
set pretty "" |
||||
append pretty "stdout\n" |
||||
if {[string length $::runout]} { |
||||
append pretty "$::runout\n" |
||||
} |
||||
append pretty "stderr\n" |
||||
if {[string length $::runerr]} { |
||||
append pretty "$::runerr\n" |
||||
} |
||||
append pretty "$exitinfo" |
||||
#set ::repl::result_print 0 |
||||
#return [lindex [list [list stdout $::runout stderr $::runerr {*}$exitinfo] [shellfilter::stack::remove stdout $x][puts -nonewline stdout $pretty][set ::repl::output ""]] 0] |
||||
|
||||
set ::repl::result_pretty $pretty |
||||
|
||||
if {[dict exists $exitinfo error]} { |
||||
#todo - check errorInfo makes sense.. return -code? tailcall? |
||||
error [dict get $exitinfo error] |
||||
} |
||||
|
||||
|
||||
return [list stdout $::runout stderr $::runerr {*}$exitinfo] |
||||
|
||||
|
||||
#return [string map [list %o% [list $::runout] %e% [list $::runerr] %x% $exitinfo] {stdout\ |
||||
# %o%\ |
||||
# stderr\ |
||||
# %e%\ |
||||
# %x%\ |
||||
#}] |
||||
} |
||||
} |
||||
namespace eval repl { |
||||
variable output "" |
||||
#important not to initialize - as it can be preset by cooperating package before app-punk has been package required |
||||
variable post_script |
||||
} |
||||
|
||||
|
||||
proc repl::doprompt {prompt} { |
||||
#prompt to stderr. |
||||
#We can pipe commands into repl's stdin without the prompt interfering with the output. |
||||
#Although all command output for each line goes to stdout - not just what is emmited with puts |
||||
if {$::tcl_interactive} { |
||||
puts -nonewline stderr $prompt |
||||
flush stderr |
||||
} |
||||
} |
||||
|
||||
proc repl::start {inchan} { |
||||
variable command |
||||
variable running |
||||
variable reading |
||||
variable done |
||||
set running 1 |
||||
set command "" |
||||
doprompt "P% " |
||||
fileevent $inchan readable [list [namespace current]::repl_handler $inchan] |
||||
set reading 1 |
||||
vwait [namespace current]::done |
||||
#todo - override exit? |
||||
after 0 ::repl::post_operations |
||||
vwait repl::post_operations_done |
||||
return 0 |
||||
} |
||||
proc repl::post_operations {} { |
||||
if {[info exists ::repl::post_script] && [string length $::repl::post_script]} { |
||||
#put aside post_script so the script has the option to add another post_script and restart the repl |
||||
set ::repl::running_script $::repl::post_script |
||||
set ::repl::post_script "" |
||||
uplevel #0 {eval $::repl::running_script} |
||||
} |
||||
|
||||
#todo - tidyup so repl could be restarted |
||||
|
||||
|
||||
set repl::post_operations_done 0 |
||||
} |
||||
|
||||
|
||||
proc repl::reopen_stdin {} { |
||||
if {$::tcl_platform(platform) eq "windows"} { |
||||
puts stderr "|repl> Attempting reconnection of console to stdin by opening 'CON'" |
||||
} else { |
||||
puts stderr "|repl> Attempting reconnection of console to stdin by opening '/dev/tty'" |
||||
} |
||||
#puts stderr "channels:[chan names]" |
||||
#flush stderr |
||||
chan close stdin |
||||
if {$::tcl_platform(platform) eq "windows"} { |
||||
set s [open "CON" r] |
||||
} else { |
||||
#/dev/tty - reference to the controlling terminal for a process |
||||
#review/test |
||||
set s [open "/dev/tty" r] |
||||
} |
||||
|
||||
repl::start stdin |
||||
} |
||||
proc quit {} { |
||||
set ::repl::done "quit" |
||||
} |
||||
#just a failed experiment.. tried various things |
||||
proc repl::reopen_stdinX {} { |
||||
#windows - todo unix |
||||
package require twapi |
||||
|
||||
if 0 { |
||||
if {[catch {package require Memchan} errM]} { |
||||
#package require tcl::chan::fifo2 |
||||
#lassign [tcl::chan::fifo2] a b |
||||
package require tcl::chan::fifo |
||||
set x [tcl::chan::fifo] |
||||
} else { |
||||
#lassign [fifo2] a b |
||||
set x [fifo] |
||||
} |
||||
#first channel opened after stdin closed becomes stdin |
||||
#use a fifo or fifo2 because [chan pipe] assigns the wrong end first! |
||||
#a will be stdin |
||||
} |
||||
#these can't replace proper stdin (filehandle 0) because they're not 'file backed' or 'os level' |
||||
#try opening a named pipe server to become stdin |
||||
set pipename {\\.\pipe\stdin_%id%} |
||||
set pipename [string map [list %id% [pid]] $pipename] |
||||
|
||||
|
||||
|
||||
package require tcl::chan::fifo |
||||
|
||||
chan close stdin |
||||
lassign [tcl::chan::fifo] a |
||||
|
||||
|
||||
puts stderr "newchan: $a" |
||||
puts stderr "|test> $a [chan conf $a]" |
||||
|
||||
#set server [twapi::namedpipe_server $pipename] |
||||
#set client [twapi::namedpipe_client $pipename] ;#open a client and connect to the server we just made |
||||
|
||||
puts stderr "chan names: [chan names]" |
||||
|
||||
#by now $server not valid? |
||||
#set server stdin |
||||
|
||||
#chan configure $server -buffering line -encoding unicode |
||||
#chan configure $client -buffering line -encoding unicode |
||||
|
||||
#puts stderr "|test>ns-server $server [chan conf $server]" |
||||
#puts stderr "|test>ns-client $client [chan conf $client]" |
||||
|
||||
set conin [twapi::get_console_handle stdin] |
||||
twapi::set_standard_handle stdin $conin |
||||
|
||||
set h_in [twapi::get_standard_handle stdin] |
||||
|
||||
puts stderr "|test> $a [chan conf $a]" |
||||
|
||||
#chan configure $client -blocking 0 |
||||
after 10 repl::start $a |
||||
|
||||
} |
||||
proc repl::repl_handler {chan} { |
||||
variable command |
||||
variable running |
||||
variable reading |
||||
variable post_script |
||||
variable id_outstack |
||||
variable result_print |
||||
variable result_pretty |
||||
set chunksize [gets $chan line] |
||||
if {$chunksize < 0} { |
||||
if {[chan eof $chan]} { |
||||
fileevent $chan readable {} |
||||
set reading 0 |
||||
set running 0 |
||||
if {$::tcl_interactive} { |
||||
puts stderr "\n|repl> EOF on $chan." |
||||
} |
||||
set [namespace current]::done 1 |
||||
#test |
||||
repl::reopen_stdin |
||||
return |
||||
} |
||||
} |
||||
append command $line |
||||
if {[info complete $command]} { |
||||
set ::repl::output "" |
||||
set id_outstack [shellfilter::stack::add stdout tee_to_var -settings {-varname ::repl::output}] |
||||
#chan configure stdout -buffering none |
||||
fileevent $chan readable {} |
||||
set reading 0 |
||||
set result_print 1 |
||||
set result_pretty "" |
||||
#don't let unknown use 'args' to convert command to list |
||||
|
||||
if {[string equal -length [string length "runraw "] "runraw " $command]} { |
||||
set status [catch {uplevel #0 [list do_runraw $command]} result] |
||||
} else { |
||||
set status [catch {uplevel #0 $command} result] |
||||
} |
||||
set lastoutchar [string range $::repl::output end-1 end] |
||||
#puts stderr "<output>'$::repl::output' lastoutchar:'$lastoutchar' result:'$result'" |
||||
shellfilter::stack::remove stdout $id_outstack |
||||
if {!$result_print} { |
||||
set result "" |
||||
set lastoutchar "" |
||||
} |
||||
#$command is an unevaluated script at this point |
||||
# so may not be a well formed list e.g 'set x [list a "b"]' |
||||
#- lindex will fail |
||||
#if {[lindex $command 0] eq "runx"} {} |
||||
|
||||
set test [string trim $command] |
||||
if {[string equal -length [string length "runx "] "runx " $command]} { |
||||
if {[string length $result_pretty]} { |
||||
set result $result_pretty |
||||
} |
||||
} |
||||
fileevent $chan readable [list [namespace current]::repl_handler $chan] |
||||
set reading 1 |
||||
if {$result ne ""} { |
||||
if {$status == 0} { |
||||
if {[string length $lastoutchar]} { |
||||
puts \n$result |
||||
} else { |
||||
puts $result |
||||
} |
||||
doprompt "P% " |
||||
} else { |
||||
puts stderr $result |
||||
doprompt "p% " |
||||
} |
||||
} else { |
||||
if {[string length $lastoutchar]} { |
||||
doprompt "\nP% " |
||||
} else { |
||||
doprompt "P% " |
||||
} |
||||
} |
||||
set command "" |
||||
} else { |
||||
append command \n |
||||
doprompt "> " |
||||
} |
||||
} |
||||
repl::start stdin |
||||
|
||||
exit 0 |
||||
|
||||
#repl::start $program_read_stdin_pipe |
||||
|
||||
@ -0,0 +1,3 @@
|
||||
|
||||
package ifneeded app-shellspy 1.0 [list source [file join $dir shellspy.tcl]] |
||||
|
||||
@ -0,0 +1,717 @@
|
||||
#! /usr/bin/env tclsh |
||||
# |
||||
#copyright 2023 Julian Marcel Noble |
||||
#license: BSD (revised 3-clause) |
||||
# |
||||
#see notes at beginning of shellspy namespace re stdout/stderr |
||||
# |
||||
#SHELLSPY - provides commandline flag information and stdout/stderr logging/mirroring without output/pipeline interference, |
||||
# or modified output if modifying filters explicitly configured. |
||||
# |
||||
#shellspy uses the shellfilter and flagfilter libraries to run a commandline with tee-diversions of stdout/stderr to configured syslog/file logs |
||||
#Because it is a tee, the command's stdout/stderr are still available as direct output from this script. |
||||
#Various filters/modifiers/redirections can be placed on the channel stacks for stdin/stderr using the shellfilter::stack api |
||||
# and other shellfilter:: helpers such as shellfilter::redir_output_to_log |
||||
# Redirecting stderr/stdout in this way prior to the actual command run will not interfere with the command/pipeline output due to the way |
||||
# shellfilter temporarily inserts it's own tee into the stack at the point of the highest existing redirection it encounters. |
||||
# |
||||
#A note on input/output convention regarding channels/pipes |
||||
# we write to an output, read from an input. |
||||
# e.g when creating a pipe with 'lassign [chan pipe] in out' we write to out and read from in. |
||||
# This is potentially confusing from an OO-like perspective thinking of a pipe object as a sort of object. |
||||
# Don't think of it from the perspective of the pipe - but from the program using it. |
||||
# This is not a convention invented here for shellspy - but it seems to match documentation and common use e.g for 'chan pending input|output chanid' |
||||
# This matches the way we write to stdout read from stdin. |
||||
# Possibly using read/write related naming for pipe ends is clearer. eg 'lassign [chan pipe] rd_pipe1 wr_pipe1' |
||||
# |
||||
package provide app-shellspy 1.0 |
||||
|
||||
|
||||
#a test for windows |
||||
#fconfigure stdin -encoding utf-16le |
||||
#fconfigure stdout -encoding utf-16le |
||||
|
||||
#tcl::tm::remove {*}[tcl::tm::list] |
||||
|
||||
#add dir outside of tclkit/exe so we can override with higher versions if necessary without rebuilding |
||||
set m_dir [file normalize [file join [file dirname [info nameofexecutable]] modules]] |
||||
tcl::tm::add $m_dir |
||||
set m_dir [file normalize [file join [file dirname [info script]] ../../../modules]] |
||||
tcl::tm::add $m_dir |
||||
|
||||
|
||||
#experiment - todo make a flag for it if it's useful |
||||
#Middle cap for direct dispatch without flagcheck arg processing or redirections or REPL. |
||||
set arg1 [lindex $::argv 0] |
||||
if {[file extension $arg1] in [list .tCl]} { |
||||
set ::argv [lrange $::argv 1 end] |
||||
set ::argc [llength $::argv] |
||||
set scriptfile [file normalize $arg1] |
||||
if {![file exists $scriptfile]} { |
||||
#try the lowercase version (extension lowercased only) so that file doesn't have to be renamed to use alternate dispatch |
||||
set scriptfile [file rootname $scriptfile][string tolower [file extension $scriptfile]] |
||||
} |
||||
source [file normalize $arg1] |
||||
|
||||
#package require app-punk |
||||
|
||||
} else { |
||||
|
||||
|
||||
|
||||
#set m_dir [file join $starkit::topdir modules] |
||||
|
||||
#lappend auto_path c:/tcl/lib/tcllib1.20 |
||||
package require flagfilter |
||||
package require shellfilter |
||||
package require Thread |
||||
|
||||
#package require packageTrace |
||||
|
||||
set ::testconfig 5 |
||||
|
||||
namespace eval shellspy { |
||||
variable shellspy_status_log "shellspy-[clock micros]" |
||||
#shellfilter::log::open $shellspy_status_log [list -tag $shellspy_status_log -syslog 172.16.6.42:51500 -file ""] |
||||
shellfilter::log::open $shellspy_status_log [list -tag $shellspy_status_log -syslog 127.0.0.1:514 -file ""] |
||||
shellfilter::log::write $shellspy_status_log "shellspy launch with args '$::argv'" |
||||
shellfilter::log::write $shellspy_status_log "stdout/stderr encoding: [chan configure stdout -encoding]/[chan configure stderr -encoding]" |
||||
|
||||
#------------------------------------------------------------------------- |
||||
##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 |
||||
|
||||
#set id_ansistrip [shellfilter::stack::add stderr ansistrip -settings {}] |
||||
#set id_ansistrip [shellfilter::stack::add stdout ansistrip -settings {}] |
||||
|
||||
lassign [shellfilter::redir_output_to_log "SPY"] id_stdout_redir id_stderr_redir |
||||
|
||||
|
||||
### |
||||
#we can now safely write to stderr/stdout and it will not interfere with stderr/stdout from the dispatched command. |
||||
#This is because when shellfilter::run is called it temporarily adds it's own filter in place of the redirection we just added. |
||||
# shellfilter::run installs tee_to_pipe on stdout & stderr with -action sink-aside. |
||||
# sink-aside means to sink down the filter stack to the topmost filter that is diversionary, and replace it. |
||||
# when the command finishes running, the redirecting filter that it displaced is reinstalled in the stack. |
||||
### |
||||
|
||||
### |
||||
#Note that futher filters installed here will sit 'above' any of the redirecting filters |
||||
# so apply to both the shellfilter::run commandline, |
||||
# as well as writes to stderr/stdout from here or other libraries operating in this process. |
||||
# To bypass the the filter-stack and still emit to syslog etc - |
||||
# you can use shellfilter::log::open and shellfilter::log::write e.g |
||||
# shellfilter::log::open "mystatuslog" [list -tag "mystatuslog" -syslog 172.16.6.42:51500 -file ""] |
||||
# shellfilter::log::write "mystatuslog" "shellspy launch" |
||||
# |
||||
#### |
||||
#set id_ansistrip [shellfilter::stack::add stderr ansistrip -action float -settings {}] |
||||
#set id_ansistrip [shellfilter::stack::add stdout ansistrip -action float -settings {}] |
||||
|
||||
|
||||
##stdin stack operates in reverse compared to stdout/stderr in that first added to stack is first to see the data |
||||
##for stdin: first added to stack is 'upstream' as it will always encounter the data before later ones added to the stack. |
||||
##for stdout: first added to stack is 'downstream' as it will alays encounter the data after others on the stack |
||||
#shellfilter::stack::add stdin ansistrip -action {} -settings {} |
||||
#shellfilter::stack::add stdin tee_to_log -settings {-tag "input" -raw 1 -syslog 172.16.6.42:51500 -file ""} |
||||
|
||||
#------------------------------------------------------------------------- |
||||
##note - to use shellfilter::stack::new - the fifo2 end at the local side requires the event loop to be running |
||||
## for interactive testing a relatively simple repl.tcl can be used. |
||||
|
||||
#todo - default to no logging.. add special flag in checkflags to indicate end of options for matched command only e.g --- ? |
||||
# then prioritize these results from checkflags to configure pre-dispatch behaviour by running a predispatch script(?) |
||||
# |
||||
# we can log flag-processing info coming from checkflags.. but we don't want to do two opt scans and emit it twice. |
||||
# configuration of the logging for flag/opt parsing should come from a config file and default to none. |
||||
set stdout_log [file normalize ~]/shellspy-stdout.txt |
||||
set stderr_log [file normalize ~]/shellspy-stderr.txt |
||||
|
||||
set outdeviceinfo [shellfilter::stack::new shellspyout -settings [list -tag "shellspyout" -buffering none -raw 1 -syslog 127.0.0.1:514 -file $stdout_log]] |
||||
set commandlog [dict get $outdeviceinfo localchan] |
||||
#puts $commandlog "HELLO $commandlog" |
||||
#flush $commandlog |
||||
set errdeviceinfo [shellfilter::stack::new shellspyerr -settings [list -tag "shellspyerr" -buffering none -raw 1 -syslog 127.0.0.1:514 -file $stderr_log]] |
||||
|
||||
#note that this filter is inline with the data teed off to the shellspyout log. |
||||
#To filter the main stdout an addition to the stdout stack can be made. specify -action float to have it affect both stdout and the tee'd off data. |
||||
set id_ansistrip [shellfilter::stack::add shellspyout ansistrip -settings {}] |
||||
|
||||
|
||||
#set id_out [shellfilter::stack::add stdout rebuffer -settings {}] |
||||
|
||||
#an example filter to capture some output to a var for later use - this one is for ansible-playbook |
||||
#set ::recap "" |
||||
#set id_tee_grep [shellfilter::stack::add shellspyout tee_grep_to_var -settings {-grep ".*PLAY RECAP.*|.*fatal:.*|.*changed:.*" -varname ::recap -pre 1 -post 3}] |
||||
|
||||
namespace import ::flagfilter::check_flags |
||||
|
||||
namespace eval shellspy::callbacks {} |
||||
namespace eval shellspy::parameters {} |
||||
|
||||
|
||||
proc do_callback {func args} { |
||||
variable shellspy_status_log |
||||
set exedir [file dirname [info nameofexecutable]] |
||||
set dispatchtcl [file join $exedir callbacks dispatch.tcl] |
||||
if {[file exists $dispatchtcl]} { |
||||
source $dispatchtcl |
||||
if {[llength [info commands shellspy::callbacks::$func]]} { |
||||
shellfilter::log::write $shellspy_status_log "found shellspy::callbacks::$func - calling" |
||||
if {[catch { |
||||
set args [shellspy::callbacks::$func {*}$args] |
||||
} errmsg]} { |
||||
shellfilter::log::write $shellspy_status_log "ERROR in shellspy::callbacks::$func\n errormsg:$errmsg" |
||||
error $errmsg |
||||
} |
||||
} |
||||
} |
||||
return $args |
||||
} |
||||
proc do_callback_parameters {func args} { |
||||
variable shellspy_status_log |
||||
set exedir [file dirname [info nameofexecutable]] |
||||
set paramtcl [file join $exedir callbacks parameters.tcl] |
||||
set params $args |
||||
if {[file exists $paramtcl]} { |
||||
source $paramtcl |
||||
if {[llength [info commands shellspy::parameters::$func]]} { |
||||
shellfilter::log::write $shellspy_status_log "found shellspy::parameters::$func - calling" |
||||
if {[catch { |
||||
set params [shellspy::parameters::$func $params] |
||||
} errmsg]} { |
||||
shellfilter::log::write $shellspy_status_log "ERROR in shellspy::parameters::$func\n errormsg:$errmsg" |
||||
} |
||||
} |
||||
} |
||||
return $params |
||||
} |
||||
|
||||
#some tested configs |
||||
proc get_channel_config {config} { |
||||
#note tcl script being called from wrong place.. configs don't affect: todo - move it. |
||||
set params [dict create] |
||||
if {$config == 0} { |
||||
#bad for: everything. extra cr |
||||
dict set params -inbuffering line |
||||
dict set params -outbuffering line |
||||
dict set params -readprocesstranslation auto ;#default |
||||
dict set params -outtranslation auto |
||||
} |
||||
|
||||
if {$config == 1} { |
||||
#ok for: cmd, cmd/u/c,raw,pwsh, sh,raw, tcl script process |
||||
#not ok for: bash,wsl, tcl script |
||||
dict set params -inbuffering line |
||||
dict set params -outbuffering line |
||||
dict set params -readprocesstranslation auto ;#default |
||||
dict set params -outtranslation lf |
||||
} |
||||
if {$config == 2} { |
||||
#ok for: cmd, cmd/uc,pwsh,sh , tcl script process |
||||
#not ok for: tcl script, bash, wsl |
||||
dict set params -inbuffering none ;#default |
||||
dict set params -outbuffering none ;#default |
||||
dict set params -readprocesstranslation auto ;#default |
||||
dict set params -outtranslation lf ;#default |
||||
} |
||||
if {$config == 3} { |
||||
#ok for: cmd |
||||
dict set params -inbuffering line |
||||
dict set params -outbuffering line |
||||
dict set params -readprocesstranslation lf |
||||
dict set params -outtranslation lf |
||||
} |
||||
if {$config == 4} { |
||||
#ok for: cmd,cmd/uc,raw,sh |
||||
#not ok for pwsh,bash,wsl, tcl script, tcl script process |
||||
dict set params -inbuffering none |
||||
dict set params -outbuffering none |
||||
dict set params -readprocesstranslation lf |
||||
dict set params -outtranslation lf |
||||
} |
||||
|
||||
if {$config == 5} { |
||||
#ok for: pwsh,cmd,cmd/u/c,raw,sh, tcl script process |
||||
#not ok for bash,wsl |
||||
#ok for vim cmd/u/c but only with to_unix filter on stdout (works in gvim and console) |
||||
dict set params -inbuffering none |
||||
dict set params -outbuffering none |
||||
dict set params -readprocesstranslation crlf |
||||
dict set params -outtranslation lf |
||||
} |
||||
if {$config == 6} { |
||||
#ok for: cmd,cmd/u/c,pwsh,raw,sh,bash |
||||
#not ok for: vim with cmd /u/c (?) |
||||
dict set params -inbuffering line |
||||
dict set params -outbuffering line |
||||
dict set params -readprocesstranslation crlf |
||||
dict set params -outtranslation lf |
||||
} |
||||
if {$config == 7} { |
||||
#ok for: sh,bash |
||||
#not ok for: wsl (display ok but extra cr), cmd,cmd/u/c,pwsh, tcl script, tcl script process, raw |
||||
dict set params -inbuffering none |
||||
dict set params -outbuffering none |
||||
dict set params -readprocesstranslation crlf |
||||
dict set params -outtranslation crlf |
||||
} |
||||
if {$config == 8} { |
||||
#not ok for anything..all have extra cr |
||||
dict set params -inbuffering none |
||||
dict set params -outbuffering none |
||||
dict set params -readprocesstranslation lf |
||||
dict set params -outtranslation crlf |
||||
} |
||||
return $params |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
proc do_in_powershell {args} { |
||||
variable shellspy_status_log |
||||
shellfilter::log::write $shellspy_status_log "do_in_powershell got '$args'" |
||||
set args [do_callback powershell {*}$args] |
||||
set params [do_callback_parameters powershell] |
||||
dict set params -teehandle shellspy |
||||
|
||||
|
||||
#readprocesstranslation lf - doesn't work for buffering line or none |
||||
#readprocesstranslation crlf works for buffering line and none with outchantranslation lf |
||||
|
||||
set params [dict merge $params [get_channel_config $::testconfig]] ;#working: 5 unbuffered, 6 linebuffered |
||||
|
||||
|
||||
|
||||
#set exitinfo [shellfilter::run [list pwsh -nologo -noprofile -c {*}$args] -debug 1] |
||||
|
||||
|
||||
set exitinfo [shellfilter::run [list pwsh -nologo -noprofile -c {*}$args] {*}$params] |
||||
#Passing args in as a single element will tend to make powershell treat the args as a 'script block' |
||||
# (powershell sees items in curly brackets {} as a scriptblock - when called from non-powershell, this tends to just echo back the contents) |
||||
#set exitinfo [shellfilter::run [list pwsh -nologo -noprofile -c $args] {*}$params] |
||||
if {[lindex $exitinfo 0] eq "exitcode"} { |
||||
shellfilter::log::write $shellspy_status_log "do_in_powershell returning $exitinfo" |
||||
#exit [lindex $exitinfo 1] |
||||
} |
||||
} |
||||
proc do_in_powershell_terminal {args} { |
||||
variable shellspy_status_log |
||||
shellfilter::log::write $shellspy_status_log "do_in_powershell_terminal got '$args'" |
||||
dict set params -teehandle shellspy |
||||
set params [dict merge $params [get_channel_config $::testconfig]] ;#working: 5 unbuffered, 6 linebuffered |
||||
|
||||
set cmdlist [list pwsh -nologo -noprofile -c {*}$args] |
||||
set cmdlist [shellfilter::get_scriptrun $cmdlist] |
||||
shellfilter::log::write $shellspy_status_log "do_in_powershell_terminal as script: '$cmdlist'" |
||||
|
||||
set exitinfo [shellfilter::run $cmdlist {*}$params] |
||||
if {[lindex $exitinfo 0] eq "exitcode"} { |
||||
shellfilter::log::write $shellspy_status_log "do_in_powershell_terminal returning $exitinfo" |
||||
} |
||||
} |
||||
|
||||
|
||||
proc do_in_cmdshell {args} { |
||||
variable shellspy_status_log |
||||
shellfilter::log::write $shellspy_status_log "do_in_cmdshell got '$args'" |
||||
set args [do_callback cmdshell {*}$args] |
||||
set params [do_callback_parameters cmdshell] |
||||
|
||||
|
||||
dict set params -teehandle shellspy |
||||
dict set params -copytempfile 1 |
||||
|
||||
set params [dict merge $params [get_channel_config $::testconfig]] |
||||
|
||||
#set id_out [shellfilter::stack::add stdout tounix -action sink-locked -settings {}] |
||||
|
||||
#set exitinfo [shellfilter::run "cmd /c $args" -debug 1] |
||||
set exitinfo [shellfilter::run [list cmd /c {*}$args] {*}$params] |
||||
#set exitinfo [shellfilter::run [list cmd /c {*}$args] -debug 1] |
||||
|
||||
#shellfilter::stack::remove stdout $id_out |
||||
|
||||
|
||||
|
||||
if {[lindex $exitinfo 0] eq "exitcode"} { |
||||
#exit [lindex $exitinfo 1] |
||||
shellfilter::log::write $shellspy_status_log "do_in_cmdshell returning $exitinfo" |
||||
#puts stderr "do_in_cmdshell returning $exitinfo" |
||||
} |
||||
} |
||||
proc do_in_cmdshellb {args} { |
||||
|
||||
variable shellspy_status_log |
||||
shellfilter::log::write $shellspy_status_log "do_in_cmdshellb got '$args'" |
||||
|
||||
set args [do_callback cmdshellb {*}$args] |
||||
|
||||
|
||||
shellfilter::log::write $shellspy_status_log "do_in_cmdshellb post_callback args '$args'" |
||||
|
||||
set params [do_callback_parameters cmdshellb] |
||||
dict set params -teehandle shellspy |
||||
dict set params -copytempfile 1 |
||||
dict set params -debug 0 |
||||
|
||||
#----------------------------- |
||||
#channel config 6 and towindows sink-aside-locked {-junction 1} works with vim-flog |
||||
#----------------------------- |
||||
set params [dict merge $params [get_channel_config 6]] |
||||
#set id_out [shellfilter::stack::add stdout tounix -action sink-aside-locked -settings {-junction 1}] |
||||
|
||||
|
||||
set exitinfo [shellfilter::run [list cmd /u/c {*}$args] {*}$params] |
||||
|
||||
#shellfilter::stack::remove stdout $id_out |
||||
|
||||
if {[lindex $exitinfo 0] eq "exitcode"} { |
||||
shellfilter::log::write $shellspy_status_log "do_in_cmdshellb returning with exitcode $exitinfo" |
||||
} else { |
||||
shellfilter::log::write $shellspy_status_log "do_in_cmdshellb returning WITHOUT exitcode $exitinfo" |
||||
} |
||||
} |
||||
proc do_in_cmdshelluc {args} { |
||||
variable shellspy_status_log |
||||
shellfilter::log::write $shellspy_status_log "do_in_cmdshelluc got '$args'" |
||||
set args [do_callback cmdshelluc {*}$args] |
||||
set params [do_callback_parameters cmdshell] |
||||
#set exitinfo [shellfilter::run "cmd /c $args" -debug 1] |
||||
dict set params -teehandle shellspy |
||||
dict set params -copytempfile 1 |
||||
dict set params -debug 0 |
||||
|
||||
#set params [dict merge $params [get_channel_config $::testconfig]] |
||||
|
||||
set params [dict merge $params [get_channel_config 1]] |
||||
#set id_out [shellfilter::stack::add stdout tounix -action sink-locked -settings {}] |
||||
|
||||
set id_out [shellfilter::stack::add stdout tounix -action sink-locked -settings {}] |
||||
|
||||
set exitinfo [shellfilter::run [list cmd /u/c {*}$args] {*}$params] |
||||
shellfilter::stack::remove stdout $id_out |
||||
#chan configure stdout -translation crlf |
||||
|
||||
if {[lindex $exitinfo 0] eq "exitcode"} { |
||||
#exit [lindex $exitinfo 1] |
||||
shellfilter::log::write $shellspy_status_log "do_in_cmdshelluc returning $exitinfo" |
||||
#puts stderr "do_in_cmdshell returning $exitinfo" |
||||
} |
||||
} |
||||
proc do_raw {args} { |
||||
variable shellspy_status_log |
||||
shellfilter::log::write $shellspy_status_log "do_raw got '$args'" |
||||
set args [do_callback raw {*}$args] |
||||
set params [do_callback_parameters raw] |
||||
#set params {} |
||||
dict set params -debug 0 |
||||
#dict set params -outprefix "_test_" |
||||
dict set params -teehandle shellspy |
||||
|
||||
|
||||
set params [dict merge $params [get_channel_config $::testconfig]] |
||||
|
||||
|
||||
if {[llength $params]} { |
||||
set exitinfo [shellfilter::run $args {*}$params] |
||||
} else { |
||||
set exitinfo [shellfilter::run $args -debug 1 -outprefix "j"] |
||||
} |
||||
if {[lindex $exitinfo 0] eq "exitcode"} { |
||||
shellfilter::log::write $shellspy_status_log "do_raw returning $exitinfo" |
||||
} |
||||
} |
||||
|
||||
proc do_script_process {scriptname args} { |
||||
variable shellspy_status_log |
||||
shellfilter::log::write $shellspy_status_log "do_script_process got scriptname:'$scriptname' args:'$args'" |
||||
set args [do_callback script_process {*}$args] |
||||
set params [do_callback_parameters script_process] |
||||
dict set params -teehandle shellspy |
||||
|
||||
set params [dict merge $params [get_channel_config $::testconfig]] |
||||
|
||||
#todo - use glob to check capitalisation of file tail (.TCL vs .tcl .Tcl etc) |
||||
set exitinfo [shellfilter::run [concat [auto_execok tclsh] $scriptname $args] {*}$params] |
||||
if {[lindex $exitinfo 0] eq "exitcode"} { |
||||
shellfilter::log::write $shellspy_status_log "do_script_process returning $exitinfo" |
||||
} |
||||
} |
||||
proc do_script {scriptname replwhen args} { |
||||
#ideally we don't want to launch an external process to run the script |
||||
variable shellspy_status_log |
||||
shellfilter::log::write $shellspy_status_log "do_script got scriptname:'$scriptname' replwhen:$replwhen args:'$args'" |
||||
|
||||
set script [string map [list %a% $args %s% $scriptname] { |
||||
set scriptname %s% |
||||
set ::argv [list %a%] |
||||
set ::argc [llength $::argv] |
||||
source [file normalize $scriptname] |
||||
|
||||
}] |
||||
|
||||
set repl_line "package require app-punk\n" |
||||
|
||||
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_line" |
||||
} elseif {$replwhen eq "repl_last"} { |
||||
append script $repl_line |
||||
} else { |
||||
#just the script |
||||
} |
||||
|
||||
|
||||
set args [do_callback script {*}$args] |
||||
set params [do_callback_parameters script] |
||||
dict set params -tclscript 1 ;#don't give callback a chance to omit/break this |
||||
dict set params -teehandle shellspy |
||||
|
||||
set params [dict merge $params [get_channel_config $::testconfig]] |
||||
|
||||
|
||||
set exitinfo [shellfilter::run $script {*}$params] |
||||
if {[lindex $exitinfo 0] eq "exitcode"} { |
||||
shellfilter::log::write $shellspy_status_log "do_script returning $exitinfo" |
||||
} |
||||
} |
||||
|
||||
proc shellescape {arglist} { |
||||
set out [list] |
||||
foreach a $arglist { |
||||
set a [string map [list \\ \\\\ ] $a] |
||||
lappend out $a |
||||
} |
||||
return $out |
||||
} |
||||
proc do_shell {shell args} { |
||||
variable shellspy_status_log |
||||
shellfilter::log::write $shellspy_status_log "do_shell $shell got '$args' [llength $args]" |
||||
set args [do_callback $shell {*}$args] |
||||
shellfilter::log::write $shellspy_status_log "do_shell $shell xgot '$args'" |
||||
set params [do_callback_parameters $shell] |
||||
dict set params -teehandle shellspy |
||||
|
||||
|
||||
set params [dict merge $params [get_channel_config $::testconfig]] |
||||
|
||||
set id_out [shellfilter::stack::add stdout towindows -action sink-aside-locked -settings {-junction 1}] |
||||
|
||||
#shells that take -c and need all args passed together as a string |
||||
|
||||
set exitinfo [shellfilter::run [concat $shell -c [shellescape $args]] {*}$params] |
||||
|
||||
shellfilter::stack::remove stdout $id_out |
||||
|
||||
|
||||
if {[lindex $exitinfo 0] eq "exitcode"} { |
||||
shellfilter::log::write $shellspy_status_log "do_shell $shell returning $exitinfo" |
||||
} |
||||
} |
||||
proc do_wsl {dist args} { |
||||
variable shellspy_status_log |
||||
shellfilter::log::write $shellspy_status_log "do_wsl $dist got '$args' [llength $args]" |
||||
set args [do_callback wsl {*}$args] ;#use dist? |
||||
shellfilter::log::write $shellspy_status_log "do_wsl $dist xgot '$args'" |
||||
set params [do_callback_parameters wsl] |
||||
|
||||
dict set params -debug 0 |
||||
|
||||
|
||||
set params [dict merge $params [get_channel_config $::testconfig]] |
||||
|
||||
|
||||
set id_out [shellfilter::stack::add stdout towindows -action sink-aside-locked -settings {-junction 1}] |
||||
|
||||
|
||||
dict set params -teehandle shellspy ;#shellspyout shellspyerr must exist |
||||
set exitinfo [shellfilter::run [concat wsl -d $dist -e [shellescape $args]] {*}$params] |
||||
|
||||
|
||||
shellfilter::stack::remove stdout $id_out |
||||
|
||||
|
||||
if {[lindex $exitinfo 0] eq "exitcode"} { |
||||
shellfilter::log::write $shellspy_status_log "do_wsl $dist returning $exitinfo" |
||||
} |
||||
} |
||||
|
||||
#todo - load these from a callback |
||||
set commands [list] |
||||
|
||||
#shout extension to force use of tclsh as a separate process |
||||
#todo - detect various extensions - and use all script-preceding unmatched args as interpreter+options |
||||
#e.g perl,php,python etc. |
||||
#For tcl will make it easy to test different interpreter output from tclkitsh, tclsh8.6, tclsh8.7 etc |
||||
#for now we have a hardcoded default interpreter for tcl as 'tclsh' - todo: get default interps from config |
||||
#(or just attempt launch in case there is shebang line in script) |
||||
#we may get ambiguity with existing shell match-specs such as -c /c -r. todo - only match those in first slot? |
||||
lappend commands [list tclscriptprocess [list match [list .*\.TCL$ .*\.TM$ .*\.TK$] dispatch [list shellspy::do_script_process %matched%] dispatchtype tcl dispatchglobal 1 singleopts {any}]] |
||||
for {set i 0} {$i < 25} {incr i} { |
||||
lappend commands [list tclscriptprocess [list sub word$i singleopts {any}]] |
||||
} |
||||
|
||||
#camelcase convention .Tcl script before repl |
||||
lappend commands [list tclscriptbeforerepl [list match [list .*\.Tcl$ .*\.Tm$ .*\.Tk$ ] dispatch [list shellspy::do_script %matched% "repl_last"] dispatchtype tcl dispatchglobal 1 singleopts {any}]] |
||||
for {set i 0} {$i < 25} {incr i} { |
||||
lappend commands [list tclscriptbeforerepl [list sub word$i singleopts {any}]] |
||||
} |
||||
|
||||
|
||||
#Backwards Camelcase convention .tcL - means repl first, script last |
||||
lappend commands [list tclscriptafterrepl [list match [list .*\.tcL$ .*\.tM$ .*\.tK$ ] dispatch [list shellspy::do_script %matched% "repl_first"] dispatchtype tcl dispatchglobal 1 singleopts {any}]] |
||||
for {set i 0} {$i < 25} {incr i} { |
||||
lappend commands [list tclscriptafterrepl [list sub word$i singleopts {any}]] |
||||
} |
||||
|
||||
|
||||
#we've already handled .Tcl .tcL, .tCl, .TCL - handle any other capitalisations as a script in this process |
||||
lappend commands [list tclscript [list match [list .*\.tcl$ .*\.tCL$ .*\.TCl$ .*\.tm$ .*\.tk$ ] dispatch [list shellspy::do_script %matched% "no_repl"] dispatchtype tcl dispatchglobal 1 singleopts {any}]] |
||||
for {set i 0} {$i < 25} {incr i} { |
||||
lappend commands [list tclscript [list sub word$i singleopts {any}]] |
||||
} |
||||
|
||||
|
||||
|
||||
lappend commands [list bashraw [list match ^bash$ dispatch [list shellspy::do_shell bash] dispatchtype raw dispatchglobal 1 singleopts {any}]] |
||||
for {set i 0} {$i < 25} {incr i} { |
||||
lappend commands [list bashraw [list sub word$i singleopts {any}]] |
||||
} |
||||
lappend commands {shraw {match ^sh$ dispatch {shellspy::do_shell sh} dispatchtype raw dispatchglobal 1 singleopts {any}}} |
||||
for {set i 0} {$i < 25} {incr i} { |
||||
lappend commands [list shraw [list sub word$i singleopts {any}]] |
||||
} |
||||
|
||||
lappend commands [list runbash [list match ^b$ dispatch [list shellspy::do_shell bash] dispatchtype shell dispatchglobal 1 singleopts {any}]] |
||||
for {set i 0} {$i < 25} {incr i} { |
||||
lappend commands [list runbash [list sub word$i singleopts {any}]] |
||||
} |
||||
lappend commands {runsh {match ^s$ dispatch {shellspy::do_shell sh} dispatchtype shell dispatchglobal 1 singleopts {any}}} |
||||
for {set i 0} {$i < 25} {incr i} { |
||||
lappend commands [list runsh [list sub word$i singleopts {any}]] |
||||
} |
||||
|
||||
lappend commands {runraw {match ^-r$ dispatch shellspy::do_raw dispatchtype raw dispatchglobal 1 singleopts {any}}} |
||||
for {set i 0} {$i < 25} {incr i} { |
||||
lappend commands [list runraw [list sub word$i singleopts {any}]] |
||||
} |
||||
lappend commands {runpwsh {match ^-c$ dispatch shellspy::do_in_powershell dispatchtype raw dispatchglobal 1 singleopts {any}}} |
||||
for {set i 0} {$i < 25} {incr i} { |
||||
lappend commands [list runpwsh [list sub word$i singleopts {any}]] |
||||
} |
||||
lappend commands {runpwsht {match ^pwsh$ dispatch shellspy::do_in_powershell_terminal dispatchtype raw dispatchglobal 1 singleopts {any}}} |
||||
for {set i 0} {$i < 25} {incr i} { |
||||
lappend commands [list runpwsht [list sub word$i singleopts {any}]] |
||||
} |
||||
|
||||
|
||||
lappend commands {runcmd {match ^/c$ dispatch shellspy::do_in_cmdshell dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}}} |
||||
for {set i 0} {$i < 25} {incr i} { |
||||
lappend commands [list runcmd [list sub word$i singleopts {any}]] |
||||
} |
||||
lappend commands {runcmduc {match ^/u/c$ dispatch shellspy::do_in_cmdshelluc dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}}} |
||||
for {set i 0} {$i < 25} {incr i} { |
||||
lappend commands [list runcmduc [list sub word$i singleopts {any}]] |
||||
} |
||||
#cmd with bracked args () e.g with vim shellxquote set to "(" |
||||
lappend commands [list runcmdb [list match ^cmdb$ dispatch [list shellspy::do_in_cmdshellb %matched%] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any} pairopts {any}]] |
||||
for {set i 0} {$i < 25} {incr i} { |
||||
lappend commands [list runcmdb [list sub word$i singleopts {any} longopts {any} pairopts {any}]] |
||||
} |
||||
|
||||
lappend commands [list wslraw [list match ^wsl$ dispatch [list shellspy::do_wsl AlmaLinux9] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] |
||||
for {set i 0} {$i < 25} {incr i} { |
||||
lappend commands [list wslraw [list sub word$i singleopts {any}]] |
||||
} |
||||
|
||||
|
||||
############################################################################################ |
||||
|
||||
#echo raw args to diverted stderr before running the argument analysis |
||||
puts -nonewline stderr "rawargs: $::argv\n" |
||||
set i 1 |
||||
foreach a $::argv { |
||||
puts -nonewline stderr "arg$i: '$a'\n" |
||||
incr i |
||||
} |
||||
|
||||
|
||||
puts stderr $::shellfilter::ansi::test |
||||
flush stderr |
||||
|
||||
set argdefinitions [list \ |
||||
-caller shellspy_dispatcher \ |
||||
-debugargs 0 \ |
||||
-debugargsonerror 2 \ |
||||
-return all \ |
||||
-soloflags {} \ |
||||
-defaults [list] \ |
||||
-required {none} \ |
||||
-extras {all} \ |
||||
-commandprocessors $commands \ |
||||
-values $::argv ] |
||||
|
||||
|
||||
|
||||
if {[catch { |
||||
set arglist [check_flags {*}$argdefinitions] |
||||
} errMsg]} { |
||||
puts -nonewline stderr "|shellspy-stderr> ERROR during command dispatch\n" |
||||
puts -nonewline stderr "|shellspy-stderr> $errMsg\n" |
||||
puts -nonewline stderr "|shellspy-stderr> [set ::errorInfo]\n" |
||||
|
||||
} else { |
||||
puts stdout "shellspy final-arglist $arglist" |
||||
} |
||||
|
||||
shellfilter::log::write $shellspy_status_log "check_flags dispatch -done-" |
||||
|
||||
#puts stdout "sp2. $::argv" |
||||
|
||||
if {[catch { |
||||
set tidyinfo [shellfilter::logtidyup] |
||||
} errMsg]} { |
||||
|
||||
shellfilter::log::open shellspy-error {-tag shellspy-error -syslog 127.0.0.1:514} |
||||
shellfilter::log::write shellspy-error "logtidyup error $errMsg\n [set ::errorInfo]" |
||||
after 500 |
||||
} |
||||
#don't open more logs.. |
||||
#puts stdout ">$tidyinfo" |
||||
|
||||
|
||||
#shellfilter::log::write $shellspy_status_log "logtidyup -done- $tidyinfo" |
||||
|
||||
|
||||
|
||||
set errorlist [dict get $tidyinfo errors] |
||||
if {[llength $errorlist]} { |
||||
foreach err $errorlist { |
||||
puts -nonewline stderr "|shellspy-final> worker-error-set $err\n" |
||||
} |
||||
} |
||||
puts stdout "shellspy -done-" |
||||
#shellfilter::log::write $shellspy_status_log "shellspy -done-" |
||||
flush stdout |
||||
|
||||
if {[catch { |
||||
shellfilter::logtidyup $shellspy_status_log |
||||
} errMsg]} { |
||||
shellfilter::log::open shellspy-final {-tag shellspy-final -syslog 127.0.0.1:514} |
||||
shellfilter::log::write shellspy-final "FINAL logtidyup error $errMsg\n [set ::errorInfo]" |
||||
after 500 |
||||
|
||||
} |
||||
|
||||
exit 0 |
||||
} |
||||
|
||||
} |
||||
@ -0,0 +1,29 @@
|
||||
Copyright (c) 2003-2012, Ashok P. Nadkarni |
||||
All rights reserved. |
||||
|
||||
Redistribution and use in source and binary forms, with or without |
||||
modification, are permitted provided that the following conditions are |
||||
met: |
||||
|
||||
- Redistributions of source code must retain the above copyright notice, |
||||
this list of conditions and the following disclaimer. |
||||
|
||||
- Redistributions in binary form must reproduce the above copyright |
||||
notice, this list of conditions and the following disclaimer in the |
||||
documentation and/or other materials provided with the distribution. |
||||
|
||||
- The name of the copyright holder and any other contributors may not |
||||
be used to endorse or promote products derived from this software |
||||
without specific prior written permission. |
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS |
||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT |
||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR |
||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT |
||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, |
||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT |
||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, |
||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY |
||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT |
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE |
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,28 @@
|
||||
# |
||||
# Copyright (c) 2010-2012, Ashok P. Nadkarni |
||||
# All rights reserved. |
||||
# |
||||
# See the file LICENSE for license |
||||
|
||||
# ADSI routines |
||||
|
||||
# TBD - document |
||||
proc twapi::adsi_translate_name {name to {from 0}} { |
||||
set map { |
||||
unknown 0 fqdn 1 samcompatible 2 display 3 uniqueid 6 |
||||
canonical 7 userprincipal 8 canonicalex 9 serviceprincipal 10 |
||||
dnsdomain 12 |
||||
} |
||||
if {! [string is integer -strict $to]} { |
||||
set to [dict get $map $to] |
||||
if {$to == 0} { |
||||
error "'unknown' is not a valid target format." |
||||
} |
||||
} |
||||
|
||||
if {! [string is integer -strict $from]} { |
||||
set from [dict get $map $from] |
||||
} |
||||
|
||||
return [TranslateName $name $from $to] |
||||
} |
||||
@ -0,0 +1,114 @@
|
||||
# |
||||
# Copyright (c) 2003-2012, Ashok P. Nadkarni |
||||
# All rights reserved. |
||||
# |
||||
# See the file LICENSE for license |
||||
|
||||
namespace eval twapi {} |
||||
|
||||
# Get the command line |
||||
proc twapi::get_command_line {} { |
||||
return [GetCommandLineW] |
||||
} |
||||
|
||||
# Parse the command line |
||||
proc twapi::get_command_line_args {cmdline} { |
||||
# Special check for empty line. CommandLinetoArgv returns process |
||||
# exe name in this case. |
||||
if {[string length $cmdline] == 0} { |
||||
return [list ] |
||||
} |
||||
return [CommandLineToArgv $cmdline] |
||||
} |
||||
|
||||
# Read an ini file int |
||||
proc twapi::read_inifile_key {section key args} { |
||||
array set opts [parseargs args { |
||||
{default.arg ""} |
||||
inifile.arg |
||||
} -maxleftover 0] |
||||
|
||||
if {[info exists opts(inifile)]} { |
||||
set values [read_inifile_section $section -inifile $opts(inifile)] |
||||
} else { |
||||
set values [read_inifile_section $section] |
||||
} |
||||
|
||||
# Cannot use kl_get or arrays here because we want case insensitive compare |
||||
foreach {k val} $values { |
||||
if {[string equal -nocase $key $k]} { |
||||
return $val |
||||
} |
||||
} |
||||
return $opts(default) |
||||
} |
||||
|
||||
# Write an ini file string |
||||
proc twapi::write_inifile_key {section key value args} { |
||||
array set opts [parseargs args { |
||||
inifile.arg |
||||
} -maxleftover 0] |
||||
|
||||
if {[info exists opts(inifile)]} { |
||||
WritePrivateProfileString $section $key $value $opts(inifile) |
||||
} else { |
||||
WriteProfileString $section $key $value |
||||
} |
||||
} |
||||
|
||||
# Delete an ini file string |
||||
proc twapi::delete_inifile_key {section key args} { |
||||
array set opts [parseargs args { |
||||
inifile.arg |
||||
} -maxleftover 0] |
||||
|
||||
if {[info exists opts(inifile)]} { |
||||
WritePrivateProfileString $section $key $twapi::nullptr $opts(inifile) |
||||
} else { |
||||
WriteProfileString $section $key $twapi::nullptr |
||||
} |
||||
} |
||||
|
||||
# Get names of the sections in an inifile |
||||
proc twapi::read_inifile_section_names {args} { |
||||
array set opts [parseargs args { |
||||
inifile.arg |
||||
} -nulldefault -maxleftover 0] |
||||
|
||||
return [GetPrivateProfileSectionNames $opts(inifile)] |
||||
} |
||||
|
||||
# Get keys and values in a section in an inifile |
||||
proc twapi::read_inifile_section {section args} { |
||||
array set opts [parseargs args { |
||||
inifile.arg |
||||
} -nulldefault -maxleftover 0] |
||||
|
||||
set result [list ] |
||||
foreach line [GetPrivateProfileSection $section $opts(inifile)] { |
||||
set pos [string first "=" $line] |
||||
if {$pos >= 0} { |
||||
lappend result [string range $line 0 [expr {$pos-1}]] [string range $line [incr pos] end] |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
|
||||
# Delete an ini file section |
||||
proc twapi::delete_inifile_section {section args} { |
||||
variable nullptr |
||||
|
||||
array set opts [parseargs args { |
||||
inifile.arg |
||||
}] |
||||
|
||||
if {[info exists opts(inifile)]} { |
||||
WritePrivateProfileString $section $nullptr $nullptr $opts(inifile) |
||||
} else { |
||||
WriteProfileString $section $nullptr $nullptr |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,254 @@
|
||||
# |
||||
# Copyright (c) 2004, 2008 Ashok P. Nadkarni |
||||
# All rights reserved. |
||||
# |
||||
# See the file LICENSE for license |
||||
|
||||
# Clipboard related commands |
||||
|
||||
namespace eval twapi {} |
||||
|
||||
# Open the clipboard |
||||
# TBD - why no mechanism to pass window handle to OpenClipboard? |
||||
proc twapi::open_clipboard {} { |
||||
OpenClipboard 0 |
||||
} |
||||
|
||||
# Close the clipboard |
||||
proc twapi::close_clipboard {} { |
||||
catch {CloseClipboard} |
||||
return |
||||
} |
||||
|
||||
# Empty the clipboard |
||||
proc twapi::empty_clipboard {} { |
||||
EmptyClipboard |
||||
} |
||||
|
||||
proc twapi::_read_clipboard {fmt} { |
||||
# Always catch errors and close clipboard before passing exception on |
||||
# Also ensure memory unlocked |
||||
trap { |
||||
set h [GetClipboardData $fmt] |
||||
set p [GlobalLock $h] |
||||
set data [Twapi_ReadMemory 1 $p 0 [GlobalSize $h]] |
||||
} onerror {} { |
||||
catch {close_clipboard} |
||||
rethrow |
||||
} finally { |
||||
# If p exists, then we must have locked the handle |
||||
if {[info exists p]} { |
||||
GlobalUnlock $h |
||||
} |
||||
} |
||||
return $data |
||||
} |
||||
|
||||
proc twapi::read_clipboard {fmt} { |
||||
trap { |
||||
set data [_read_clipboard $fmt] |
||||
} onerror {TWAPI_WIN32 1418} { |
||||
# Caller did not have clipboard open. Do it on its behalf |
||||
open_clipboard |
||||
trap { |
||||
set data [_read_clipboard $fmt] |
||||
} finally { |
||||
catch {close_clipboard} |
||||
} |
||||
} |
||||
return $data |
||||
} |
||||
|
||||
# Read text data from the clipboard |
||||
proc twapi::read_clipboard_text {args} { |
||||
array set opts [parseargs args { |
||||
{raw.bool 0} |
||||
}] |
||||
|
||||
set bin [read_clipboard 13]; # 13 -> Unicode |
||||
# Decode Unicode and discard trailing nulls |
||||
set data [string trimright [encoding convertfrom unicode $bin] \0] |
||||
if {! $opts(raw)} { |
||||
set data [string map {"\r\n" "\n"} $data] |
||||
} |
||||
|
||||
return $data |
||||
} |
||||
|
||||
proc twapi::_write_clipboard {fmt data} { |
||||
# Always catch errors and close |
||||
# clipboard before passing exception on |
||||
trap { |
||||
# For byte arrays, string length does return correct size |
||||
# (DO NOT USE string bytelength - see Tcl docs!) |
||||
set len [string length $data] |
||||
|
||||
# Allocate global memory |
||||
set mem_h [GlobalAlloc 2 $len] |
||||
set mem_p [GlobalLock $mem_h] |
||||
|
||||
Twapi_WriteMemory 1 $mem_p 0 $len $data |
||||
|
||||
# The rest of this code just to ensure we do not free |
||||
# memory beyond this point irrespective of error/success |
||||
set h $mem_h |
||||
unset mem_p mem_h |
||||
GlobalUnlock $h |
||||
SetClipboardData $fmt $h |
||||
} onerror {} { |
||||
catch close_clipboard |
||||
rethrow |
||||
} finally { |
||||
if {[info exists mem_p]} { |
||||
GlobalUnlock $mem_h |
||||
} |
||||
if {[info exists mem_h]} { |
||||
GlobalFree $mem_h |
||||
} |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc twapi::write_clipboard {fmt data} { |
||||
trap { |
||||
_write_clipboard $fmt $data |
||||
} onerror {TWAPI_WIN32 1418} { |
||||
# Caller did not have clipboard open. Do it on its behalf |
||||
open_clipboard |
||||
empty_clipboard |
||||
trap { |
||||
_write_clipboard $fmt $data |
||||
} finally { |
||||
catch close_clipboard |
||||
} |
||||
} |
||||
return |
||||
} |
||||
|
||||
# Write text to the clipboard |
||||
proc twapi::write_clipboard_text {data args} { |
||||
array set opts [parseargs args { |
||||
{raw.bool 0} |
||||
}] |
||||
|
||||
# Convert \n to \r\n leaving existing \r\n alone |
||||
if {! $opts(raw)} { |
||||
set data [regsub -all {(^|[^\r])\n} $data[set data ""] \\1\r\n] |
||||
} |
||||
append data \0 |
||||
write_clipboard 13 [encoding convertto unicode $data]; # 13 -> Unicode |
||||
return |
||||
} |
||||
|
||||
# Get current clipboard formats |
||||
proc twapi::get_clipboard_formats {} { |
||||
return [Twapi_EnumClipboardFormats] |
||||
} |
||||
|
||||
# Get registered clipboard format name. Clipboard does not have to be open |
||||
proc twapi::get_registered_clipboard_format_name {fmt} { |
||||
return [GetClipboardFormatName $fmt] |
||||
} |
||||
|
||||
# Register a clipboard format |
||||
proc twapi::register_clipboard_format {fmt_name} { |
||||
RegisterClipboardFormat $fmt_name |
||||
} |
||||
|
||||
# Returns 1/0 depending on whether a format is on the clipboard. Clipboard |
||||
# does not have to be open |
||||
proc twapi::clipboard_format_available {fmt} { |
||||
return [IsClipboardFormatAvailable $fmt] |
||||
} |
||||
|
||||
proc twapi::read_clipboard_paths {} { |
||||
set bin [read_clipboard 15] |
||||
# Extract the DROPFILES header |
||||
if {[binary scan $bin iiiii offset - - - unicode] != 5} { |
||||
error "Invalid or unsupported clipboard CF_DROP data." |
||||
} |
||||
# Sanity check |
||||
if {$offset >= [string length $bin]} { |
||||
error "Truncated clipboard data." |
||||
} |
||||
if {$unicode} { |
||||
set paths [encoding convertfrom unicode [string range $bin $offset end]] |
||||
} else { |
||||
set paths [encoding convertfrom ascii [string range $bin $offset end]] |
||||
} |
||||
set ret {} |
||||
foreach path [split $paths \0] { |
||||
if {[string length $path] == 0} break; # Empty string -> end of list |
||||
lappend ret [file join $path] |
||||
} |
||||
return $ret |
||||
} |
||||
|
||||
proc twapi::write_clipboard_paths {paths} { |
||||
# The header for a DROPFILES path list in hex |
||||
set fheader "1400000000000000000000000000000001000000" |
||||
set bin [binary format H* $fheader] |
||||
foreach path $paths { |
||||
# Note explicit \0 so the encoded binary includes the null terminator |
||||
append bin [encoding convertto unicode "[file nativename [file normalize $path]]\0"] |
||||
} |
||||
# A Unicode null char to terminate the list of paths |
||||
append bin [encoding convertto unicode \0] |
||||
write_clipboard 15 $bin |
||||
} |
||||
|
||||
# Start monitoring of the clipboard |
||||
proc twapi::_clipboard_handler {} { |
||||
variable _clipboard_monitors |
||||
|
||||
if {![info exists _clipboard_monitors] || |
||||
[llength $_clipboard_monitors] == 0} { |
||||
return; # Not an error, could have deleted while already queued |
||||
} |
||||
|
||||
foreach {id script} $_clipboard_monitors { |
||||
set code [catch {uplevel #0 $script} msg] |
||||
if {$code == 1} { |
||||
# Error - put in background but we do not abort |
||||
after 0 [list error $msg $::errorInfo $::errorCode] |
||||
} |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc twapi::start_clipboard_monitor {script} { |
||||
variable _clipboard_monitors |
||||
|
||||
set id "clip#[TwapiId]" |
||||
if {![info exists _clipboard_monitors] || |
||||
[llength $_clipboard_monitors] == 0} { |
||||
# No clipboard monitoring in progress. Start it |
||||
Twapi_ClipboardMonitorStart |
||||
} |
||||
|
||||
lappend _clipboard_monitors $id $script |
||||
return $id |
||||
} |
||||
|
||||
|
||||
|
||||
# Stop monitoring of the clipboard |
||||
proc twapi::stop_clipboard_monitor {clipid} { |
||||
variable _clipboard_monitors |
||||
|
||||
if {![info exists _clipboard_monitors]} { |
||||
return; # Should we raise an error instead? |
||||
} |
||||
|
||||
set new_monitors {} |
||||
foreach {id script} $_clipboard_monitors { |
||||
if {$id ne $clipid} { |
||||
lappend new_monitors $id $script |
||||
} |
||||
} |
||||
|
||||
set _clipboard_monitors $new_monitors |
||||
if {[llength $_clipboard_monitors] == 0} { |
||||
Twapi_ClipboardMonitorStop |
||||
} |
||||
} |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,736 @@
|
||||
# |
||||
# Copyright (c) 2004-2014, Ashok P. Nadkarni |
||||
# All rights reserved. |
||||
# |
||||
# See the file LICENSE for license |
||||
|
||||
namespace eval twapi { |
||||
} |
||||
|
||||
# Allocate a new console |
||||
proc twapi::allocate_console {} { |
||||
AllocConsole |
||||
} |
||||
|
||||
# Free a console |
||||
proc twapi::free_console {} { |
||||
FreeConsole |
||||
} |
||||
|
||||
# Get a console handle |
||||
proc twapi::get_console_handle {type} { |
||||
switch -exact -- $type { |
||||
0 - |
||||
stdin { set fn "CONIN\$" } |
||||
1 - |
||||
stdout - |
||||
2 - |
||||
stderr { set fn "CONOUT\$" } |
||||
default { |
||||
error "Unknown console handle type '$type'" |
||||
} |
||||
} |
||||
|
||||
# 0xC0000000 -> GENERIC_READ | GENERIC_WRITE |
||||
# 3 -> FILE_SHARE_READ | FILE_SHARE_WRITE |
||||
# 3 -> OPEN_EXISTING |
||||
return [CreateFile $fn \ |
||||
0xC0000000 \ |
||||
3 \ |
||||
{{} 1} \ |
||||
3 \ |
||||
0 \ |
||||
NULL] |
||||
} |
||||
|
||||
proc twapi::_standard_handle_type {type} { |
||||
if {[string is integer -strict $type]} { |
||||
set type [format %d $type] ; # Convert hex etc. |
||||
} |
||||
switch -exact -- $type { |
||||
0 - |
||||
-10 - |
||||
stdin { set type -10 } |
||||
1 - |
||||
-11 - |
||||
stdout { set type -11 } |
||||
2 - |
||||
-12 - |
||||
stderr { set type -12 } |
||||
default { |
||||
error "Unknown console handle type '$type'" |
||||
} |
||||
} |
||||
return $type |
||||
} |
||||
|
||||
# Get a console handle |
||||
proc twapi::get_standard_handle {type} { |
||||
return [GetStdHandle [_standard_handle_type $type]] |
||||
} |
||||
|
||||
# Set a console handle |
||||
proc twapi::set_standard_handle {type handle} { |
||||
return [SetStdHandle [_standard_handle_type $type] $handle] |
||||
} |
||||
|
||||
proc twapi::_console_output_attr_to_flags {attrs} { |
||||
set flags 0 |
||||
foreach {attr bool} $attrs { |
||||
if {$bool} { |
||||
set flags [expr {$flags | [_console_output_attr $attr]}] |
||||
} |
||||
} |
||||
return $flags |
||||
} |
||||
|
||||
proc twapi::_flags_to_console_output_attr {flags} { |
||||
# Check for multiple bit attributes first, in order |
||||
set attrs {} |
||||
foreach attr { |
||||
-fgwhite -bgwhite -fggray -bggray |
||||
-fgturquoise -bgturquoise -fgpurple -bgpurple -fgyellow -bgyellow |
||||
-fgred -bgred -fggreen -bggreen -fgblue -bgblue |
||||
-fgbright -bgbright |
||||
} { |
||||
if {($flags & [_console_output_attr $attr]) == [_console_output_attr $attr]} { |
||||
lappend attrs $attr 1 |
||||
set flags [expr {$flags & ~ [_console_output_attr $attr]}] |
||||
if {$flags == 0} { |
||||
break |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $attrs |
||||
} |
||||
|
||||
|
||||
# Get the current mode settings for the console |
||||
proc twapi::_get_console_input_mode {conh} { |
||||
set mode [GetConsoleMode $conh] |
||||
return [_bitmask_to_switches $mode [_console_input_mode_syms]] |
||||
} |
||||
interp alias {} twapi::get_console_input_mode {} twapi::_do_console_proc twapi::_get_console_input_mode stdin |
||||
|
||||
# Get the current mode settings for the console |
||||
proc twapi::_get_console_output_mode {conh} { |
||||
set mode [GetConsoleMode $conh] |
||||
return [_bitmask_to_switches $mode [_console_output_mode_syms]] |
||||
} |
||||
interp alias {} twapi::get_console_output_mode {} twapi::_do_console_proc twapi::_get_console_output_mode stdout |
||||
|
||||
# Set console input mode |
||||
proc twapi::_set_console_input_mode {conh args} { |
||||
set mode [_switches_to_bitmask $args [_console_input_mode_syms]] |
||||
# If insertmode or quickedit mode are set, make sure to set extended bit |
||||
if {$mode & 0x60} { |
||||
setbits mode 0x80; # ENABLE_EXTENDED_FLAGS |
||||
} |
||||
|
||||
SetConsoleMode $conh $mode |
||||
} |
||||
interp alias {} twapi::set_console_input_mode {} twapi::_do_console_proc twapi::_set_console_input_mode stdin |
||||
|
||||
# Modify console input mode |
||||
proc twapi::_modify_console_input_mode {conh args} { |
||||
set prev [GetConsoleMode $conh] |
||||
set mode [_switches_to_bitmask $args [_console_input_mode_syms] $prev] |
||||
# If insertmode or quickedit mode are set, make sure to set extended bit |
||||
if {$mode & 0x60} { |
||||
setbits mode 0x80; # ENABLE_EXTENDED_FLAGS |
||||
} |
||||
|
||||
SetConsoleMode $conh $mode |
||||
# Returns the old modes |
||||
return [_bitmask_to_switches $prev [_console_input_mode_syms]] |
||||
} |
||||
interp alias {} twapi::modify_console_input_mode {} twapi::_do_console_proc twapi::_modify_console_input_mode stdin |
||||
|
||||
# |
||||
# Set console output mode |
||||
proc twapi::_set_console_output_mode {conh args} { |
||||
set mode [_switches_to_bitmask $args [_console_output_mode_syms]] |
||||
|
||||
SetConsoleMode $conh $mode |
||||
|
||||
} |
||||
interp alias {} twapi::set_console_output_mode {} twapi::_do_console_proc twapi::_set_console_output_mode stdout |
||||
|
||||
# Set console output mode |
||||
proc twapi::_modify_console_output_mode {conh args} { |
||||
set prev [GetConsoleMode $conh] |
||||
set mode [_switches_to_bitmask $args [_console_output_mode_syms] $prev] |
||||
|
||||
SetConsoleMode $conh $mode |
||||
# Returns the old modes |
||||
return [_bitmask_to_switches $prev [_console_output_mode_syms]] |
||||
} |
||||
interp alias {} twapi::modify_console_output_mode {} twapi::_do_console_proc twapi::_modify_console_output_mode stdout |
||||
|
||||
|
||||
# Create and return a handle to a screen buffer |
||||
proc twapi::create_console_screen_buffer {args} { |
||||
array set opts [parseargs args { |
||||
{inherit.bool 0} |
||||
{mode.arg readwrite {read write readwrite}} |
||||
{secd.arg ""} |
||||
{share.arg readwrite {none read write readwrite}} |
||||
} -maxleftover 0] |
||||
|
||||
switch -exact -- $opts(mode) { |
||||
read { set mode [_access_rights_to_mask generic_read] } |
||||
write { set mode [_access_rights_to_mask generic_write] } |
||||
readwrite { |
||||
set mode [_access_rights_to_mask {generic_read generic_write}] |
||||
} |
||||
} |
||||
switch -exact -- $opts(share) { |
||||
none { |
||||
set share 0 |
||||
} |
||||
read { |
||||
set share 1 ;# FILE_SHARE_READ |
||||
} |
||||
write { |
||||
set share 2 ;# FILE_SHARE_WRITE |
||||
} |
||||
readwrite { |
||||
set share 3 |
||||
} |
||||
} |
||||
|
||||
return [CreateConsoleScreenBuffer \ |
||||
$mode \ |
||||
$share \ |
||||
[_make_secattr $opts(secd) $opts(inherit)] \ |
||||
1] |
||||
} |
||||
|
||||
# Retrieve information about a console screen buffer |
||||
proc twapi::_get_console_screen_buffer_info {conh args} { |
||||
array set opts [parseargs args { |
||||
all |
||||
textattr |
||||
cursorpos |
||||
maxwindowsize |
||||
size |
||||
windowlocation |
||||
windowpos |
||||
windowsize |
||||
} -maxleftover 0] |
||||
|
||||
lassign [GetConsoleScreenBufferInfo $conh] size cursorpos textattr windowlocation maxwindowsize |
||||
|
||||
set result [list ] |
||||
foreach opt {size cursorpos maxwindowsize windowlocation} { |
||||
if {$opts($opt) || $opts(all)} { |
||||
lappend result -$opt [set $opt] |
||||
} |
||||
} |
||||
|
||||
if {$opts(windowpos) || $opts(all)} { |
||||
lappend result -windowpos [lrange $windowlocation 0 1] |
||||
} |
||||
|
||||
if {$opts(windowsize) || $opts(all)} { |
||||
lassign $windowlocation left top right bot |
||||
lappend result -windowsize [list [expr {$right-$left+1}] [expr {$bot-$top+1}]] |
||||
} |
||||
|
||||
if {$opts(textattr) || $opts(all)} { |
||||
lappend result -textattr [_flags_to_console_output_attr $textattr] |
||||
} |
||||
|
||||
return $result |
||||
} |
||||
interp alias {} twapi::get_console_screen_buffer_info {} twapi::_do_console_proc twapi::_get_console_screen_buffer_info stdout |
||||
|
||||
# Set the cursor position |
||||
proc twapi::_set_console_cursor_position {conh pos} { |
||||
SetConsoleCursorPosition $conh $pos |
||||
} |
||||
interp alias {} twapi::set_console_cursor_position {} twapi::_do_console_proc twapi::_set_console_cursor_position stdout |
||||
|
||||
# Get the cursor position |
||||
proc twapi::get_console_cursor_position {conh} { |
||||
return [lindex [get_console_screen_buffer_info $conh -cursorpos] 1] |
||||
} |
||||
|
||||
# Write the specified string to the console |
||||
proc twapi::_console_write {conh s args} { |
||||
# Note writes are always in raw mode, |
||||
# TBD - support for scrolling |
||||
# TBD - support for attributes |
||||
|
||||
array set opts [parseargs args { |
||||
position.arg |
||||
{newlinemode.arg column {line column}} |
||||
{restoreposition.bool 0} |
||||
} -maxleftover 0] |
||||
|
||||
# Get screen buffer info including cursor position |
||||
array set csbi [get_console_screen_buffer_info $conh -cursorpos -size] |
||||
|
||||
# Get current console mode for later restoration |
||||
# If console is in processed mode, set it to raw mode |
||||
set oldmode [get_console_output_mode $conh] |
||||
set processed_index [lsearch -exact $oldmode "processed"] |
||||
if {$processed_index >= 0} { |
||||
# Console was in processed mode. Set it to raw mode |
||||
set newmode [lreplace $oldmode $processed_index $processed_index] |
||||
set_console_output_mode $conh $newmode |
||||
} |
||||
|
||||
trap { |
||||
# x,y are starting position to write |
||||
if {[info exists opts(position)]} { |
||||
lassign [_parse_integer_pair $opts(position)] x y |
||||
} else { |
||||
# No position specified, get current cursor position |
||||
lassign $csbi(-cursorpos) x y |
||||
} |
||||
|
||||
set startx [expr {$opts(newlinemode) == "column" ? $x : 0}] |
||||
|
||||
# Get screen buffer limits |
||||
lassign $csbi(-size) width height |
||||
|
||||
# Ensure line terminations are just \n |
||||
set s [string map [list \r\n \n] $s] |
||||
|
||||
# Write out each line at ($x,$y) |
||||
# Either \r or \n is considered a newline |
||||
foreach line [split $s \r\n] { |
||||
if {$y >= $height} break |
||||
set_console_cursor_position $conh [list $x $y] |
||||
if {$x < $width} { |
||||
# Write the characters - do not write more than buffer width |
||||
set num_chars [expr {$width-$x}] |
||||
if {[string length $line] < $num_chars} { |
||||
set num_chars [string length $line] |
||||
} |
||||
WriteConsole $conh $line $num_chars |
||||
} |
||||
|
||||
|
||||
# Calculate starting position of next line |
||||
incr y |
||||
set x $startx |
||||
} |
||||
|
||||
} finally { |
||||
# Restore cursor if requested |
||||
if {$opts(restoreposition)} { |
||||
set_console_cursor_position $conh $csbi(-cursorpos) |
||||
} |
||||
# Restore output mode if changed |
||||
if {[info exists newmode]} { |
||||
set_console_output_mode $conh $oldmode |
||||
} |
||||
} |
||||
|
||||
return |
||||
} |
||||
interp alias {} twapi::write_console {} twapi::_do_console_proc twapi::_console_write stdout |
||||
interp alias {} twapi::console_write {} twapi::_do_console_proc twapi::_console_write stdout |
||||
|
||||
# Fill an area of the console with the specified attribute |
||||
proc twapi::_fill_console {conh args} { |
||||
array set opts [parseargs args { |
||||
position.arg |
||||
numlines.int |
||||
numcols.int |
||||
{mode.arg column {line column}} |
||||
window.bool |
||||
fillchar.arg |
||||
} -ignoreunknown] |
||||
|
||||
# args will now contain attribute switches if any |
||||
set attr [_console_output_attr_to_flags $args] |
||||
|
||||
# Get screen buffer info for window and size of buffer |
||||
array set csbi [get_console_screen_buffer_info $conh -windowpos -windowsize -size] |
||||
# Height and width of the console |
||||
lassign $csbi(-size) conx cony |
||||
|
||||
# Figure out what area we want to fill |
||||
# startx,starty are starting position to write |
||||
# sizex, sizey are the number of rows/lines |
||||
if {[info exists opts(window)]} { |
||||
if {[info exists opts(numlines)] || [info exists opts(numcols)] |
||||
|| [info exists opts(position)]} { |
||||
error "Option -window cannot be used togther with options -position, -numlines or -numcols" |
||||
} |
||||
lassign [_parse_integer_pair $csbi(-windowpos)] startx starty |
||||
lassign [_parse_integer_pair $csbi(-windowsize)] sizex sizey |
||||
} else { |
||||
if {[info exists opts(position)]} { |
||||
lassign [_parse_integer_pair $opts(position)] startx starty |
||||
} else { |
||||
set startx 0 |
||||
set starty 0 |
||||
} |
||||
if {[info exists opts(numlines)]} { |
||||
set sizey $opts(numlines) |
||||
} else { |
||||
set sizey $cony |
||||
} |
||||
if {[info exists opts(numcols)]} { |
||||
set sizex $opts(numcols) |
||||
} else { |
||||
set sizex [expr {$conx - $startx}] |
||||
} |
||||
} |
||||
|
||||
set firstcol [expr {$opts(mode) == "column" ? $startx : 0}] |
||||
|
||||
# Fill attribute at ($x,$y) |
||||
set x $startx |
||||
set y $starty |
||||
while {$y < $cony && $y < ($starty + $sizey)} { |
||||
if {$x < $conx} { |
||||
# Write the characters - do not write more than buffer width |
||||
set max [expr {$conx-$x}] |
||||
if {[info exists attr]} { |
||||
FillConsoleOutputAttribute $conh $attr [expr {$sizex > $max ? $max : $sizex}] [list $x $y] |
||||
} |
||||
if {[info exists opts(fillchar)]} { |
||||
FillConsoleOutputCharacter $conh $opts(fillchar) [expr {$sizex > $max ? $max : $sizex}] [list $x $y] |
||||
} |
||||
} |
||||
|
||||
# Calculate starting position of next line |
||||
incr y |
||||
set x $firstcol |
||||
} |
||||
|
||||
return |
||||
} |
||||
interp alias {} twapi::fill_console {} twapi::_do_console_proc twapi::_fill_console stdout |
||||
|
||||
# Clear the console |
||||
proc twapi::_clear_console {conh args} { |
||||
# I support we could just call fill_console but this code was already |
||||
# written and is faster |
||||
array set opts [parseargs args { |
||||
{fillchar.arg " "} |
||||
{windowonly.bool 0} |
||||
} -maxleftover 0] |
||||
|
||||
array set cinfo [get_console_screen_buffer_info $conh -size -windowpos -windowsize] |
||||
lassign $cinfo(-size) width height |
||||
if {$opts(windowonly)} { |
||||
# Only clear portion visible in the window. We have to do this |
||||
# line by line since we do not want to erase text scrolled off |
||||
# the window either in the vertical or horizontal direction |
||||
lassign $cinfo(-windowpos) x y |
||||
lassign $cinfo(-windowsize) w h |
||||
for {set i 0} {$i < $h} {incr i} { |
||||
FillConsoleOutputCharacter \ |
||||
$conh \ |
||||
$opts(fillchar) \ |
||||
$w \ |
||||
[list $x [expr {$y+$i}]] |
||||
} |
||||
} else { |
||||
FillConsoleOutputCharacter \ |
||||
$conh \ |
||||
$opts(fillchar) \ |
||||
[expr {($width*$height) }] \ |
||||
[list 0 0] |
||||
} |
||||
return |
||||
} |
||||
interp alias {} twapi::clear_console {} twapi::_do_console_proc twapi::_clear_console stdout |
||||
# |
||||
# Flush console input |
||||
proc twapi::_flush_console_input {conh} { |
||||
FlushConsoleInputBuffer $conh |
||||
} |
||||
interp alias {} twapi::flush_console_input {} twapi::_do_console_proc twapi::_flush_console_input stdin |
||||
|
||||
# Return number of pending console input events |
||||
proc twapi::_get_console_pending_input_count {conh} { |
||||
return [GetNumberOfConsoleInputEvents $conh] |
||||
} |
||||
interp alias {} twapi::get_console_pending_input_count {} twapi::_do_console_proc twapi::_get_console_pending_input_count stdin |
||||
|
||||
# Generate a console control event |
||||
proc twapi::generate_console_control_event {event {procgrp 0}} { |
||||
switch -exact -- $event { |
||||
ctrl-c {set event 0} |
||||
ctrl-break {set event 1} |
||||
default {error "Invalid event definition '$event'"} |
||||
} |
||||
GenerateConsoleCtrlEvent $event $procgrp |
||||
} |
||||
|
||||
# Get number of mouse buttons |
||||
proc twapi::num_console_mouse_buttons {} { |
||||
return [GetNumberOfConsoleMouseButtons] |
||||
} |
||||
|
||||
# Get console title text |
||||
proc twapi::get_console_title {} { |
||||
return [GetConsoleTitle] |
||||
} |
||||
|
||||
# Set console title text |
||||
proc twapi::set_console_title {title} { |
||||
return [SetConsoleTitle $title] |
||||
} |
||||
|
||||
# Get the handle to the console window |
||||
proc twapi::get_console_window {} { |
||||
return [GetConsoleWindow] |
||||
} |
||||
|
||||
# Get the largest console window size |
||||
proc twapi::_get_console_window_maxsize {conh} { |
||||
return [GetLargestConsoleWindowSize $conh] |
||||
} |
||||
interp alias {} twapi::get_console_window_maxsize {} twapi::_do_console_proc twapi::_get_console_window_maxsize stdout |
||||
|
||||
proc twapi::_set_console_active_screen_buffer {conh} { |
||||
SetConsoleActiveScreenBuffer $conh |
||||
} |
||||
interp alias {} twapi::set_console_active_screen_buffer {} twapi::_do_console_proc twapi::_set_console_active_screen_buffer stdout |
||||
|
||||
# Set the size of the console screen buffer |
||||
proc twapi::_set_console_screen_buffer_size {conh size} { |
||||
SetConsoleScreenBufferSize $conh [_parse_integer_pair $size] |
||||
} |
||||
interp alias {} twapi::set_console_screen_buffer_size {} twapi::_do_console_proc twapi::_set_console_screen_buffer_size stdout |
||||
|
||||
# Set the default text attribute |
||||
proc twapi::_set_console_default_attr {conh args} { |
||||
SetConsoleTextAttribute $conh [_console_output_attr_to_flags $args] |
||||
} |
||||
interp alias {} twapi::set_console_default_attr {} twapi::_do_console_proc twapi::_set_console_default_attr stdout |
||||
|
||||
# Set the console window position |
||||
proc twapi::_set_console_window_location {conh rect args} { |
||||
array set opts [parseargs args { |
||||
{absolute.bool true} |
||||
} -maxleftover 0] |
||||
|
||||
SetConsoleWindowInfo $conh $opts(absolute) $rect |
||||
} |
||||
interp alias {} twapi::set_console_window_location {} twapi::_do_console_proc twapi::_set_console_window_location stdout |
||||
|
||||
proc twapi::get_console_window_location {conh} { |
||||
return [lindex [get_console_screen_buffer_info $conh -windowlocation] 1] |
||||
} |
||||
|
||||
# Get the console code page |
||||
proc twapi::get_console_output_codepage {} { |
||||
return [GetConsoleOutputCP] |
||||
} |
||||
|
||||
# Set the console code page |
||||
proc twapi::set_console_output_codepage {cp} { |
||||
SetConsoleOutputCP $cp |
||||
} |
||||
|
||||
# Get the console input code page |
||||
proc twapi::get_console_input_codepage {} { |
||||
return [GetConsoleCP] |
||||
} |
||||
|
||||
# Set the console input code page |
||||
proc twapi::set_console_input_codepage {cp} { |
||||
SetConsoleCP $cp |
||||
} |
||||
|
||||
# Read a line of input |
||||
proc twapi::_console_read {conh args} { |
||||
if {[llength $args]} { |
||||
set oldmode [modify_console_input_mode $conh {*}$args] |
||||
} |
||||
trap { |
||||
return [ReadConsole $conh 1024] |
||||
} finally { |
||||
if {[info exists oldmode]} { |
||||
set_console_input_mode $conh {*}$oldmode |
||||
} |
||||
} |
||||
} |
||||
interp alias {} twapi::console_read {} twapi::_do_console_proc twapi::_console_read stdin |
||||
|
||||
proc twapi::_map_console_controlkeys {control} { |
||||
return [_make_symbolic_bitmask $control { |
||||
capslock 0x80 |
||||
enhanced 0x100 |
||||
leftalt 0x2 |
||||
leftctrl 0x8 |
||||
numlock 0x20 |
||||
rightalt 0x1 |
||||
rightctrl 4 |
||||
scrolllock 0x40 |
||||
shift 0x10 |
||||
} 0] |
||||
} |
||||
|
||||
proc twapi::_console_read_input_records {conh args} { |
||||
parseargs args { |
||||
{count.int 1} |
||||
peek |
||||
} -setvars -maxleftover 0 |
||||
set recs {} |
||||
if {$peek} { |
||||
set input [PeekConsoleInput $conh $count] |
||||
} else { |
||||
set input [ReadConsoleInput $conh $count] |
||||
} |
||||
foreach rec $input { |
||||
switch [format %d [lindex $rec 0]] { |
||||
1 { |
||||
lassign [lindex $rec 1] keydown repeat keycode scancode char controlstate |
||||
lappend recs \ |
||||
[list key [list \ |
||||
keystate [expr {$keydown ? "down" : "up"}] \ |
||||
repeat $repeat keycode $keycode \ |
||||
scancode $scancode char $char \ |
||||
controls [_map_console_controlkeys $controlstate]]] |
||||
} |
||||
2 { |
||||
lassign [lindex $rec 1] position buttonstate controlstate flags |
||||
set buttons {} |
||||
if {[expr {$buttonstate & 0x1}]} {lappend buttons left} |
||||
if {[expr {$buttonstate & 0x2}]} {lappend buttons right} |
||||
if {[expr {$buttonstate & 0x4}]} {lappend buttons left2} |
||||
if {[expr {$buttonstate & 0x8}]} {lappend buttons left3} |
||||
if {[expr {$buttonstate & 0x10}]} {lappend buttons left4} |
||||
if {$flags & 0x8} { |
||||
set horizontalwheel [expr {$buttonstate >> 16}] |
||||
} else { |
||||
set horizontalwheel 0 |
||||
} |
||||
if {$flags & 0x4} { |
||||
set verticalwheel [expr {$buttonstate >> 16}] |
||||
} else { |
||||
set verticalwheel 0 |
||||
} |
||||
lappend recs \ |
||||
[list mouse [list \ |
||||
position $position \ |
||||
buttons $buttons \ |
||||
controls [_map_console_controlkeys $controlstate] \ |
||||
doubleclick [expr {$flags & 0x2}] \ |
||||
horizontalwheel $horizontalwheel \ |
||||
moved [expr {$flags & 0x1}] \ |
||||
verticalwheel $verticalwheel]] |
||||
} |
||||
default { |
||||
lappend recs [list \ |
||||
[dict* {4 buffersize 8 menu 16 focus} [lindex $rec 0]] \ |
||||
[lindex $rec 1]] |
||||
} |
||||
} |
||||
} |
||||
return $recs |
||||
} |
||||
interp alias {} twapi::console_read_input_records {} twapi::_do_console_proc twapi::_console_read_input_records stdin |
||||
|
||||
# Set up a console handler |
||||
proc twapi::_console_ctrl_handler {ctrl} { |
||||
variable _console_control_script |
||||
if {[info exists _console_control_script]} { |
||||
return [uplevel #0 [linsert $_console_control_script end $ctrl]] |
||||
} |
||||
return 0; # Not handled |
||||
} |
||||
proc twapi::set_console_control_handler {script} { |
||||
variable _console_control_script |
||||
if {[string length $script]} { |
||||
if {![info exists _console_control_script]} { |
||||
Twapi_ConsoleEventNotifier 1 |
||||
} |
||||
set _console_control_script $script |
||||
} else { |
||||
if {[info exists _console_control_script]} { |
||||
Twapi_ConsoleEventNotifier 0 |
||||
unset _console_control_script |
||||
} |
||||
} |
||||
} |
||||
|
||||
# |
||||
# Utilities |
||||
# |
||||
|
||||
# Helper to call a proc after doing a stdin/stdout/stderr -> handle |
||||
# mapping. The handle is closed after calling the proc. The first |
||||
# arg in $args must be the console handle if $args is not an empty list |
||||
proc twapi::_do_console_proc {proc default args} { |
||||
if {[llength $args] == 0} { |
||||
set args [list $default] |
||||
} |
||||
set conh [lindex $args 0] |
||||
switch -exact -- [string tolower $conh] { |
||||
stdin - |
||||
stdout - |
||||
stderr { |
||||
set real_handle [get_console_handle $conh] |
||||
trap { |
||||
lset args 0 $real_handle |
||||
return [uplevel 1 [list $proc] $args] |
||||
} finally { |
||||
CloseHandle $real_handle |
||||
} |
||||
} |
||||
} |
||||
|
||||
return [uplevel 1 [list $proc] $args] |
||||
} |
||||
|
||||
proc twapi::_console_input_mode_syms {} { |
||||
return { |
||||
-processedinput 0x0001 |
||||
-lineinput 0x0002 |
||||
-echoinput 0x0004 |
||||
-windowinput 0x0008 |
||||
-mouseinput 0x0010 |
||||
-insertmode 0x0020 |
||||
-quickeditmode 0x0040 |
||||
-extendedmode 0x0080 |
||||
-autoposition 0x0100 |
||||
} |
||||
} |
||||
|
||||
proc twapi::_console_output_mode_syms {} { |
||||
return { -processedoutput 1 -wrapoutput 2 } |
||||
} |
||||
|
||||
twapi::proc* twapi::_console_output_attr {sym} { |
||||
variable _console_output_attr_syms |
||||
array set _console_output_attr_syms { |
||||
-fgblue 1 |
||||
-fggreen 2 |
||||
-fgturquoise 3 |
||||
-fgred 4 |
||||
-fgpurple 5 |
||||
-fgyellow 6 |
||||
-fggray 7 |
||||
-fgbright 8 |
||||
-fgwhite 15 |
||||
-bgblue 16 |
||||
-bggreen 32 |
||||
-bgturquoise 48 |
||||
-bgred 64 |
||||
-bgpurple 80 |
||||
-bgyellow 96 |
||||
-bggray 112 |
||||
-bgbright 128 |
||||
-bgwhite 240 |
||||
} |
||||
} { |
||||
variable _console_output_attr_syms |
||||
if {[info exists _console_output_attr_syms($sym)]} { |
||||
return $_console_output_attr_syms($sym) |
||||
} |
||||
|
||||
badargs! "Invalid console output attribute '$sym'" 3 |
||||
} |
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,624 @@
|
||||
# |
||||
# Copyright (c) 2008-2014 Ashok P. Nadkarni |
||||
# All rights reserved. |
||||
# |
||||
# See the file LICENSE for license |
||||
|
||||
namespace eval twapi { |
||||
struct _PREVENT_MEDIA_REMOVAL { |
||||
BOOLEAN PreventMediaRemoval; |
||||
} |
||||
record device_element { class_guid device_instance reserved } |
||||
} |
||||
|
||||
interp alias {} close_devinfoset {} devinfoset_close |
||||
|
||||
proc twapi::rescan_devices {} { |
||||
CM_Reenumerate_DevNode_Ex [CM_Locate_DevNode_Ex "" 0] 0 |
||||
} |
||||
|
||||
|
||||
# Callback invoked for device changes. |
||||
# Does some processing of passed data and then invokes the |
||||
# real callback script |
||||
proc twapi::_device_notification_handler {id args} { |
||||
variable _device_notifiers |
||||
set idstr "devnotifier#$id" |
||||
if {![info exists _device_notifiers($idstr)]} { |
||||
# Notifications that expect a response default to "true" |
||||
return 1 |
||||
} |
||||
set script [lindex $_device_notifiers($idstr) 1] |
||||
|
||||
# For volume notifications, change drive bitmask to |
||||
# list of drives before passing back to script |
||||
set event [lindex $args 0] |
||||
if {[lindex $args 1] eq "volume" && |
||||
($event eq "deviceremovecomplete" || $event eq "devicearrival")} { |
||||
lset args 2 [_drivemask_to_drivelist [lindex $args 2]] |
||||
|
||||
# Also indicate whether network volume and whether change is a media |
||||
# change or physical change |
||||
set attrs [list ] |
||||
set flags [lindex $args 3] |
||||
if {$flags & 1} { |
||||
lappend attrs mediachange |
||||
} |
||||
if {$flags & 2} { |
||||
lappend attrs networkvolume |
||||
} |
||||
lset args 3 $attrs |
||||
} |
||||
|
||||
return [uplevel #0 [linsert $script end $idstr {*}$args]] |
||||
} |
||||
|
||||
proc twapi::start_device_notifier {script args} { |
||||
variable _device_notifiers |
||||
|
||||
set script [lrange $script 0 end]; # Verify syntactically a list |
||||
|
||||
array set opts [parseargs args { |
||||
deviceinterface.arg |
||||
handle.arg |
||||
} -maxleftover 0] |
||||
|
||||
# For reference - some common device interface classes |
||||
# NOTE: NOT ALL HAVE BEEN VERIFIED! |
||||
# Network Card {ad498944-762f-11d0-8dcb-00c04fc3358c} |
||||
# Human Interface Device (HID) {4d1e55b2-f16f-11cf-88cb-001111000030} |
||||
# GUID_DEVINTERFACE_DISK - {53f56307-b6bf-11d0-94f2-00a0c91efb8b} |
||||
# GUID_DEVINTERFACE_CDROM - {53f56308-b6bf-11d0-94f2-00a0c91efb8b} |
||||
# GUID_DEVINTERFACE_PARTITION - {53f5630a-b6bf-11d0-94f2-00a0c91efb8b} |
||||
# GUID_DEVINTERFACE_TAPE - {53f5630b-b6bf-11d0-94f2-00a0c91efb8b} |
||||
# GUID_DEVINTERFACE_WRITEONCEDISK - {53f5630c-b6bf-11d0-94f2-00a0c91efb8b} |
||||
# GUID_DEVINTERFACE_VOLUME - {53f5630d-b6bf-11d0-94f2-00a0c91efb8b} |
||||
# GUID_DEVINTERFACE_MEDIUMCHANGER - {53f56310-b6bf-11d0-94f2-00a0c91efb8b} |
||||
# GUID_DEVINTERFACE_FLOPPY - {53f56311-b6bf-11d0-94f2-00a0c91efb8b} |
||||
# GUID_DEVINTERFACE_CDCHANGER - {53f56312-b6bf-11d0-94f2-00a0c91efb8b} |
||||
# GUID_DEVINTERFACE_STORAGEPORT - {2accfe60-c130-11d2-b082-00a0c91efb8b} |
||||
# GUID_DEVINTERFACE_KEYBOARD - {884b96c3-56ef-11d1-bc8c-00a0c91405dd} |
||||
# GUID_DEVINTERFACE_MOUSE - {378de44c-56ef-11d1-bc8c-00a0c91405dd} |
||||
# GUID_DEVINTERFACE_PARALLEL - {97F76EF0-F883-11D0-AF1F-0000F800845C} |
||||
# GUID_DEVINTERFACE_COMPORT - {86e0d1e0-8089-11d0-9ce4-08003e301f73} |
||||
# GUID_DEVINTERFACE_DISPLAY_ADAPTER - {5b45201d-f2f2-4f3b-85bb-30ff1f953599} |
||||
# GUID_DEVINTERFACE_USB_HUB - {f18a0e88-c30c-11d0-8815-00a0c906bed8} |
||||
# GUID_DEVINTERFACE_USB_DEVICE - {A5DCBF10-6530-11D2-901F-00C04FB951ED} |
||||
# GUID_DEVINTERFACE_USB_HOST_CONTROLLER - {3abf6f2d-71c4-462a-8a92-1e6861e6af27} |
||||
|
||||
|
||||
if {[info exists opts(deviceinterface)] && [info exists opts(handle)]} { |
||||
error "Options -deviceinterface and -handle are mutually exclusive." |
||||
} |
||||
|
||||
if {![info exists opts(deviceinterface)]} { |
||||
set opts(deviceinterface) "" |
||||
} |
||||
if {[info exists opts(handle)]} { |
||||
set type 6 |
||||
} else { |
||||
set opts(handle) NULL |
||||
switch -exact -- $opts(deviceinterface) { |
||||
port { set type 3 ; set opts(deviceinterface) "" } |
||||
volume { set type 2 ; set opts(deviceinterface) "" } |
||||
default { |
||||
# device interface class guid or empty string (for all device interfaces) |
||||
set type 5 |
||||
} |
||||
} |
||||
} |
||||
|
||||
set id [Twapi_RegisterDeviceNotification $type $opts(deviceinterface) $opts(handle)] |
||||
set idstr "devnotifier#$id" |
||||
|
||||
set _device_notifiers($idstr) [list $id $script] |
||||
return $idstr |
||||
} |
||||
|
||||
proc twapi::stop_device_notifier {idstr} { |
||||
variable _device_notifiers |
||||
|
||||
if {![info exists _device_notifiers($idstr)]} { |
||||
return; |
||||
} |
||||
|
||||
Twapi_UnregisterDeviceNotification [lindex $_device_notifiers($idstr) 0] |
||||
unset _device_notifiers($idstr) |
||||
} |
||||
|
||||
proc twapi::devinfoset {args} { |
||||
array set opts [parseargs args { |
||||
{guid.arg ""} |
||||
{classtype.arg setup {interface setup}} |
||||
{presentonly.bool false 0x2} |
||||
{currentprofileonly.bool false 0x8} |
||||
{deviceinfoset.arg NULL} |
||||
{hwin.int 0} |
||||
{system.arg ""} |
||||
{pnpenumerator.arg ""} |
||||
} -maxleftover 0] |
||||
|
||||
# DIGCF_ALLCLASSES is bitmask 4 |
||||
set flags [expr {$opts(guid) eq "" ? 0x4 : 0}] |
||||
if {$opts(classtype) eq "interface"} { |
||||
if {$opts(pnpenumerator) ne ""} { |
||||
error "The -pnpenumerator option cannot be used when -classtype interface is specified." |
||||
} |
||||
# DIGCF_DEVICEINTERFACE |
||||
set flags [expr {$flags | 0x10}] |
||||
} |
||||
|
||||
# DIGCF_PRESENT |
||||
set flags [expr {$flags | $opts(presentonly)}] |
||||
|
||||
# DIGCF_PRESENT |
||||
set flags [expr {$flags | $opts(currentprofileonly)}] |
||||
|
||||
return [SetupDiGetClassDevsEx \ |
||||
$opts(guid) \ |
||||
$opts(pnpenumerator) \ |
||||
$opts(hwin) \ |
||||
$flags \ |
||||
$opts(deviceinfoset) \ |
||||
$opts(system)] |
||||
} |
||||
|
||||
|
||||
# Given a device information set, returns the device elements within it |
||||
proc twapi::devinfoset_elements {hdevinfo} { |
||||
set result [list ] |
||||
set i 0 |
||||
trap { |
||||
while {true} { |
||||
lappend result [SetupDiEnumDeviceInfo $hdevinfo $i] |
||||
incr i |
||||
} |
||||
} onerror {TWAPI_WIN32 0x103} { |
||||
# Fine, Just means no more items |
||||
} onerror {TWAPI_WIN32 0x80070103} { |
||||
# Fine, Just means no more items (HRESULT version of above code) |
||||
} |
||||
|
||||
return $result |
||||
} |
||||
|
||||
# Given a device information set, returns the device elements within it |
||||
proc twapi::devinfoset_instance_ids {hdevinfo} { |
||||
set result [list ] |
||||
set i 0 |
||||
trap { |
||||
while {true} { |
||||
lappend result [device_element_instance_id $hdevinfo [SetupDiEnumDeviceInfo $hdevinfo $i]] |
||||
incr i |
||||
} |
||||
} onerror {TWAPI_WIN32 0x103} { |
||||
# Fine, Just means no more items |
||||
} onerror {TWAPI_WIN32 0x80070103} { |
||||
# Fine, Just means no more items (HRESULT version of above code) |
||||
} |
||||
|
||||
return $result |
||||
} |
||||
|
||||
# Returns a device instance element from a devinfoset |
||||
proc twapi::devinfoset_element {hdevinfo instance_id} { |
||||
return [SetupDiOpenDeviceInfo $hdevinfo $instance_id 0 0] |
||||
} |
||||
|
||||
# Get the registry property for a devinfoset element |
||||
proc twapi::devinfoset_element_registry_property {hdevinfo develem prop} { |
||||
Twapi_SetupDiGetDeviceRegistryProperty $hdevinfo $develem [_device_registry_sym_to_code $prop] |
||||
} |
||||
|
||||
# Given a device information set, returns a list of specified registry |
||||
# properties for all elements of the set |
||||
# args is list of properties to retrieve |
||||
proc twapi::devinfoset_registry_properties {hdevinfo args} { |
||||
set result [list ] |
||||
trap { |
||||
# Keep looping until there is an error saying no more items |
||||
set i 0 |
||||
while {true} { |
||||
|
||||
# First element is the DEVINFO_DATA element |
||||
set devinfo_data [SetupDiEnumDeviceInfo $hdevinfo $i] |
||||
set item [list -deviceelement $devinfo_data ] |
||||
|
||||
# Get all specified property values |
||||
foreach prop $args { |
||||
set intprop [_device_registry_sym_to_code $prop] |
||||
trap { |
||||
lappend item $prop \ |
||||
[list success \ |
||||
[Twapi_SetupDiGetDeviceRegistryProperty \ |
||||
$hdevinfo $devinfo_data $intprop]] |
||||
} onerror {} { |
||||
lappend item $prop [list fail [list [trapresult] $::errorCode]] |
||||
} |
||||
} |
||||
lappend result $item |
||||
|
||||
incr i |
||||
} |
||||
} onerror {TWAPI_WIN32 0x103} { |
||||
# Fine, Just means no more items |
||||
} onerror {TWAPI_WIN32 0x80070103} { |
||||
# Fine, Just means no more items (HRESULT version of above code) |
||||
} |
||||
|
||||
return $result |
||||
} |
||||
|
||||
|
||||
# Given a device information set, returns specified device interface |
||||
# properties |
||||
# TBD - document ? |
||||
proc twapi::devinfoset_interface_details {hdevinfo guid args} { |
||||
set result [list ] |
||||
|
||||
array set opts [parseargs args { |
||||
{matchdeviceelement.arg {}} |
||||
interfaceclass |
||||
flags |
||||
devicepath |
||||
deviceelement |
||||
ignoreerrors |
||||
} -maxleftover 0] |
||||
|
||||
trap { |
||||
# Keep looping until there is an error saying no more items |
||||
set i 0 |
||||
while {true} { |
||||
set interface_data [SetupDiEnumDeviceInterfaces $hdevinfo \ |
||||
$opts(matchdeviceelement) $guid $i] |
||||
set item [list ] |
||||
if {$opts(interfaceclass)} { |
||||
lappend item -interfaceclass [lindex $interface_data 0] |
||||
} |
||||
if {$opts(flags)} { |
||||
set flags [lindex $interface_data 1] |
||||
set symflags [_make_symbolic_bitmask $flags {active 1 default 2 removed 4} false] |
||||
lappend item -flags [linsert $symflags 0 $flags] |
||||
} |
||||
|
||||
if {$opts(devicepath) || $opts(deviceelement)} { |
||||
# Need to get device interface detail. |
||||
trap { |
||||
foreach {devicepath deviceelement} \ |
||||
[SetupDiGetDeviceInterfaceDetail \ |
||||
$hdevinfo \ |
||||
$interface_data \ |
||||
$opts(matchdeviceelement)] \ |
||||
break |
||||
|
||||
if {$opts(deviceelement)} { |
||||
lappend item -deviceelement $deviceelement |
||||
} |
||||
if {$opts(devicepath)} { |
||||
lappend item -devicepath $devicepath |
||||
} |
||||
} onerror {} { |
||||
if {! $opts(ignoreerrors)} { |
||||
rethrow |
||||
} |
||||
} |
||||
} |
||||
lappend result $item |
||||
|
||||
incr i |
||||
} |
||||
} onerror {TWAPI_WIN32 0x103} { |
||||
# Fine, Just means no more items |
||||
} onerror {TWAPI_WIN32 0x80070103} { |
||||
# Fine, Just means no more items (HRESULT version of above code) |
||||
} |
||||
|
||||
return $result |
||||
} |
||||
|
||||
|
||||
# Return the guids associated with a device class set name. Note |
||||
# the latter is not unique so multiple guids may be associated. |
||||
proc twapi::device_setup_class_name_to_guids {name args} { |
||||
array set opts [parseargs args { |
||||
system.arg |
||||
} -maxleftover 0 -nulldefault] |
||||
|
||||
return [twapi::SetupDiClassGuidsFromNameEx $name $opts(system)] |
||||
} |
||||
|
||||
# Utility functions |
||||
|
||||
proc twapi::_init_device_registry_code_maps {} { |
||||
variable _device_registry_syms |
||||
variable _device_registry_codes |
||||
|
||||
# Note this list is ordered based on the corresponding integer codes |
||||
set _device_registry_code_syms { |
||||
devicedesc hardwareid compatibleids unused0 service unused1 |
||||
unused2 class classguid driver configflags mfg friendlyname |
||||
location_information physical_device_object_name capabilities |
||||
ui_number upperfilters lowerfilters |
||||
bustypeguid legacybustype busnumber enumerator_name security |
||||
security_sds devtype exclusive characteristics address |
||||
ui_number_desc_format device_power_data |
||||
removal_policy removal_policy_hw_default removal_policy_override |
||||
install_state location_paths base_containerid |
||||
} |
||||
|
||||
set i 0 |
||||
foreach sym $_device_registry_code_syms { |
||||
set _device_registry_codes($sym) $i |
||||
incr i |
||||
} |
||||
} |
||||
|
||||
# Map a device registry property to a symbol |
||||
proc twapi::_device_registry_code_to_sym {code} { |
||||
_init_device_registry_code_maps |
||||
|
||||
# Once we have initialized, redefine ourselves so we do not do so |
||||
# every time. Note define at global ::twapi scope! |
||||
proc ::twapi::_device_registry_code_to_sym {code} { |
||||
variable _device_registry_code_syms |
||||
if {$code >= [llength $_device_registry_code_syms]} { |
||||
return $code |
||||
} else { |
||||
return [lindex $_device_registry_code_syms $code] |
||||
} |
||||
} |
||||
# Call the redefined proc |
||||
return [_device_registry_code_to_sym $code] |
||||
} |
||||
|
||||
# Map a device registry property symbol to a numeric code |
||||
proc twapi::_device_registry_sym_to_code {sym} { |
||||
_init_device_registry_code_maps |
||||
|
||||
# Once we have initialized, redefine ourselves so we do not do so |
||||
# every time. Note define at global ::twapi scope! |
||||
proc ::twapi::_device_registry_sym_to_code {sym} { |
||||
variable _device_registry_codes |
||||
# Return the value. If non-existent, an error will be raised |
||||
if {[info exists _device_registry_codes($sym)]} { |
||||
return $_device_registry_codes($sym) |
||||
} elseif {[string is integer -strict $sym]} { |
||||
return $sym |
||||
} else { |
||||
error "Unknown or unsupported device registry property symbol '$sym'" |
||||
} |
||||
} |
||||
# Call the redefined proc |
||||
return [_device_registry_sym_to_code $sym] |
||||
} |
||||
|
||||
# Do a device ioctl, returning result as a binary |
||||
# TBD - document that caller has to handle errors 122 (ERROR_INSUFFICIENT_BUFFER) and (ERROR_MORE_DATA) |
||||
proc twapi::device_ioctl {h code args} { |
||||
array set opts [parseargs args { |
||||
{input.arg {}} |
||||
{outputcount.int 0} |
||||
} -maxleftover 0] |
||||
|
||||
return [DeviceIoControl $h $code $opts(input) $opts(outputcount)] |
||||
} |
||||
|
||||
|
||||
# Return a list of physical disks. Note CD-ROMs and floppies not included |
||||
proc twapi::find_physical_disks {} { |
||||
# Disk interface class guid |
||||
set guid {{53F56307-B6BF-11D0-94F2-00A0C91EFB8B}} |
||||
set hdevinfo [devinfoset \ |
||||
-guid $guid \ |
||||
-presentonly true \ |
||||
-classtype interface] |
||||
trap { |
||||
return [kl_flatten [devinfoset_interface_details $hdevinfo $guid -devicepath] -devicepath] |
||||
} finally { |
||||
devinfoset_close $hdevinfo |
||||
} |
||||
} |
||||
|
||||
# Return information about a physical disk |
||||
proc twapi::get_physical_disk_info {disk args} { |
||||
set result [list ] |
||||
|
||||
array set opts [parseargs args { |
||||
geometry |
||||
layout |
||||
all |
||||
} -maxleftover 0] |
||||
|
||||
if {$opts(all) || $opts(geometry) || $opts(layout)} { |
||||
set h [create_file $disk -createdisposition open_existing] |
||||
} |
||||
|
||||
trap { |
||||
if {$opts(all) || $opts(geometry)} { |
||||
# IOCTL_DISK_GET_DRIVE_GEOMETRY - 0x70000 |
||||
if {[binary scan [device_ioctl $h 0x70000 -outputcount 24] "wiiii" geom(-cylinders) geom(-mediatype) geom(-trackspercylinder) geom(-sectorspertrack) geom(-bytespersector)] != 5} { |
||||
error "DeviceIoControl 0x70000 on disk '$disk' returned insufficient data." |
||||
} |
||||
lappend result -geometry [array get geom] |
||||
} |
||||
|
||||
if {$opts(all) || $opts(layout)} { |
||||
# XP and later - IOCTL_DISK_GET_DRIVE_LAYOUT_EX |
||||
set data [device_ioctl $h 0x70050 -outputcount 624] |
||||
if {[binary scan $data "i i" partstyle layout(-partitioncount)] != 2} { |
||||
error "DeviceIoControl 0x70050 on disk '$disk' returned insufficient data." |
||||
} |
||||
set layout(-partitionstyle) [_partition_style_sym $partstyle] |
||||
switch -exact -- $layout(-partitionstyle) { |
||||
mbr { |
||||
if {[binary scan $data "@8 i" layout(-signature)] != 1} { |
||||
error "DeviceIoControl 0x70050 on disk '$disk' returned insufficient data." |
||||
} |
||||
} |
||||
gpt { |
||||
set pi(-diskid) [_binary_to_guid $data 32] |
||||
if {[binary scan $data "@8 w w i" layout(-startingusableoffset) layout(-usablelength) layout(-maxpartitioncount)] != 3} { |
||||
error "DeviceIoControl 0x70050 on disk '$disk' returned insufficient data." |
||||
} |
||||
} |
||||
raw - |
||||
unknown { |
||||
# No fields to add |
||||
} |
||||
} |
||||
|
||||
set layout(-partitions) [list ] |
||||
for {set i 0} {$i < $layout(-partitioncount)} {incr i} { |
||||
# Decode each partition in turn. Sizeof of PARTITION_INFORMATION_EX is 144 |
||||
lappend layout(-partitions) [_decode_PARTITION_INFORMATION_EX_binary $data [expr {48 + (144*$i)}]] |
||||
} |
||||
lappend result -layout [array get layout] |
||||
} |
||||
|
||||
} finally { |
||||
if {[info exists h]} { |
||||
CloseHandle $h |
||||
} |
||||
} |
||||
|
||||
return $result |
||||
} |
||||
|
||||
# Given a Tcl binary and offset, decode the PARTITION_INFORMATION_EX record |
||||
proc twapi::_decode_PARTITION_INFORMATION_EX_binary {bin off} { |
||||
if {[binary scan $bin "@$off i x4 w w i c" \ |
||||
pi(-partitionstyle) \ |
||||
pi(-startingoffset) \ |
||||
pi(-partitionlength) \ |
||||
pi(-partitionnumber) \ |
||||
pi(-rewritepartition)] != 5} { |
||||
error "Truncated partition structure." |
||||
} |
||||
|
||||
set pi(-partitionstyle) [_partition_style_sym $pi(-partitionstyle)] |
||||
|
||||
# MBR/GPT are at offset 32 in the structure |
||||
switch -exact -- $pi(-partitionstyle) { |
||||
mbr { |
||||
if {[binary scan $bin "@$off x32 c c c x i" pi(-partitiontype) pi(-bootindicator) pi(-recognizedpartition) pi(-hiddensectors)] != 4} { |
||||
error "Truncated partition structure." |
||||
} |
||||
# Show partition type in hex, not negative number |
||||
set pi(-partitiontype) [format 0x%2.2x [expr {0xff & $pi(-partitiontype)}]] |
||||
} |
||||
gpt { |
||||
set pi(-partitiontype) [_binary_to_guid $bin [expr {$off+32}]] |
||||
set pi(-partitionif) [_binary_to_guid $bin [expr {$off+48}]] |
||||
if {[binary scan $bin "@$off x64 w" pi(-attributes)] != 1} { |
||||
error "Truncated partition structure." |
||||
} |
||||
set pi(-name) [_ucs16_binary_to_string [string range $bin [expr {$off+72}] end]] |
||||
} |
||||
raw - |
||||
unknown { |
||||
# No fields to add |
||||
} |
||||
|
||||
} |
||||
|
||||
return [array get pi] |
||||
} |
||||
|
||||
# IOCTL_STORAGE_EJECT_MEDIA |
||||
interp alias {} twapi::eject {} twapi::eject_media |
||||
proc twapi::eject_media device { |
||||
# http://support.microsoft.com/default.aspx?scid=KB;EN-US;Q165721& |
||||
set h [_open_disk_device $device] |
||||
trap { |
||||
device_ioctl $h 0x90018; # FSCTL_LOCK_VOLUME |
||||
device_ioctl $h 0x90020; # FSCTL_DISMOUNT_VOLUME |
||||
# IOCTL_STORAGE_MEDIA_REMOVAL (0) |
||||
device_ioctl $h 0x2d4804 -input [_PREVENT_MEDIA_REMOVAL 0] |
||||
device_ioctl $h 0x2d4808; # IOCTL_STORAGE_EJECT_MEDIA |
||||
} finally { |
||||
close_handle $h |
||||
} |
||||
} |
||||
|
||||
# IOCTL_DISK_LOAD_MEDIA |
||||
# TBD - should we use IOCTL_DISK_LOAD_MEDIA2 instead (0x2d080c) see |
||||
# SDK, faster if read / write access not necessary. We are closing |
||||
# the handle right away anyway but would that stop other apps from |
||||
# acessing the file system on the CD ? Need to try (note device |
||||
# has to be opened with FILE_READ_ATTRIBUTES only in that case) |
||||
|
||||
interp alias {} twapi::load_media {} twapi::_issue_disk_ioctl 0x2d480c |
||||
|
||||
# FSCTL_LOCK_VOLUME |
||||
# TBD - interp alias {} twapi::lock_volume {} twapi::_issue_disk_ioctl 0x90018 |
||||
# FSCTL_LOCK_VOLUME |
||||
# TBD - interp alias {} twapi::unlock_volume {} twapi::_issue_disk_ioctl 0x9001c |
||||
|
||||
proc twapi::_lock_media {lock device} { |
||||
# IOCTL_STORAGE_MEDIA_REMOVAL |
||||
_issue_disk_ioctl 0x2d4804 $device -input [_PREVENT_MEDIA_REMOVAL $lock] |
||||
} |
||||
interp alias {} twapi::lock_media {} twapi::_lock_media 1 |
||||
interp alias {} twapi::unlock_media {} twapi::_lock_media 0 |
||||
|
||||
proc twapi::_issue_disk_ioctl {ioctl device args} { |
||||
set h [_open_disk_device $device] |
||||
trap { |
||||
device_ioctl $h $ioctl {*}$args |
||||
} finally { |
||||
close_handle $h |
||||
} |
||||
} |
||||
|
||||
twapi::proc* twapi::_open_disk_device {device} { |
||||
package require twapi_storage |
||||
} { |
||||
# device must be "cdrom", X:, X:\\, X:/, a volume or a physical disk as |
||||
# returned from find_physical_disks |
||||
switch -regexp -nocase -- $device { |
||||
{^cdrom$} { |
||||
foreach drive [find_logical_drives] { |
||||
if {![catch {get_drive_type $drive} drive_type]} { |
||||
if {$drive_type eq "cdrom"} { |
||||
set device "\\\\.\\$drive" |
||||
break |
||||
} |
||||
} |
||||
} |
||||
if {$device eq "cdrom"} { |
||||
error "Could not find a CD-ROM device." |
||||
} |
||||
} |
||||
{^[[:alpha:]]:(/|\\)?$} { |
||||
set device "\\\\.\\[string range $device 0 1]" |
||||
} |
||||
{^\\\\\?\\.*#\{[[:xdigit:]]{8}-[[:xdigit:]]{4}-[[:xdigit:]]{4}-[[:xdigit:]]{4}-[[:xdigit:]]{12}\}$} { |
||||
# Device name ok |
||||
} |
||||
{^\\\\\?\\Volume\{[[:xdigit:]]{8}-[[:xdigit:]]{4}-[[:xdigit:]]{4}-[[:xdigit:]]{4}-[[:xdigit:]]{12}\}\\?$} { |
||||
# Volume name ok. But make sure we trim off any trailing |
||||
# \ since create_file will open the root dir instead of the device |
||||
set device [string trimright $device \\] |
||||
} |
||||
default { |
||||
# Just to prevent us from opening some file instead |
||||
error "Invalid device name '$device'" |
||||
} |
||||
} |
||||
|
||||
# http://support.microsoft.com/default.aspx?scid=KB;EN-US;Q165721& |
||||
return [create_file $device -access {generic_read generic_write} \ |
||||
-createdisposition open_existing \ |
||||
-share {read write}] |
||||
} |
||||
|
||||
|
||||
# Map a partition style code to a symbol |
||||
proc twapi::_partition_style_sym {partstyle} { |
||||
set partstyle [lindex {mbr gpt raw} $partstyle] |
||||
if {$partstyle ne ""} { |
||||
return $partstyle |
||||
} |
||||
return "unknown" |
||||
} |
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,391 @@
|
||||
# |
||||
# Copyright (c) 2004-2012, Ashok P. Nadkarni |
||||
# All rights reserved. |
||||
# |
||||
# See the file LICENSE for license |
||||
|
||||
package require registry |
||||
|
||||
namespace eval twapi { |
||||
# We maintain caches so we do not do lookups all the time |
||||
# TBD - have a means of clearing this out |
||||
variable _eventlog_message_cache |
||||
set _eventlog_message_cache {} |
||||
} |
||||
|
||||
|
||||
# Read the event log |
||||
proc twapi::eventlog_read {hevl args} { |
||||
_eventlog_valid_handle $hevl read raise |
||||
|
||||
array set opts [parseargs args { |
||||
seek.int |
||||
{direction.arg forward} |
||||
}] |
||||
|
||||
if {[info exists opts(seek)]} { |
||||
set flags 2; # Seek |
||||
set offset $opts(seek) |
||||
} else { |
||||
set flags 1; # Sequential read |
||||
set offset 0 |
||||
} |
||||
|
||||
switch -glob -- $opts(direction) { |
||||
"" - |
||||
forw* { |
||||
setbits flags 4 |
||||
} |
||||
back* { |
||||
setbits flags 8 |
||||
} |
||||
default { |
||||
error "Invalid value '$opts(direction)' for -direction option" |
||||
} |
||||
} |
||||
|
||||
set results [list ] |
||||
|
||||
trap { |
||||
set recs [ReadEventLog $hevl $flags $offset] |
||||
} onerror {TWAPI_WIN32 38} { |
||||
# EOF - no more |
||||
set recs [list ] |
||||
} |
||||
foreach event $recs { |
||||
dict set event -type [string map {0 success 1 error 2 warning 4 information 8 auditsuccess 16 auditfailure} [dict get $event -level]] |
||||
lappend results $event |
||||
} |
||||
|
||||
return $results |
||||
} |
||||
|
||||
|
||||
# Get the oldest event log record index. $hevl must be read handle |
||||
proc twapi::eventlog_oldest {hevl} { |
||||
_eventlog_valid_handle $hevl read raise |
||||
return [GetOldestEventLogRecord $hevl] |
||||
} |
||||
|
||||
# Get the event log record count. $hevl must be read handle |
||||
proc twapi::eventlog_count {hevl} { |
||||
_eventlog_valid_handle $hevl read raise |
||||
return [GetNumberOfEventLogRecords $hevl] |
||||
} |
||||
|
||||
# Check if the event log is full. $hevl may be either read or write handle |
||||
# (only win2k plus) |
||||
proc twapi::eventlog_is_full {hevl} { |
||||
# Does not matter if $hevl is read or write, but verify it is a handle |
||||
_eventlog_valid_handle $hevl read |
||||
return [Twapi_IsEventLogFull $hevl] |
||||
} |
||||
|
||||
# Backup the event log |
||||
proc twapi::eventlog_backup {hevl file} { |
||||
_eventlog_valid_handle $hevl read raise |
||||
BackupEventLog $hevl $file |
||||
} |
||||
|
||||
# Clear the event log |
||||
proc twapi::eventlog_clear {hevl args} { |
||||
_eventlog_valid_handle $hevl read raise |
||||
array set opts [parseargs args {backup.arg} -nulldefault] |
||||
ClearEventLog $hevl $opts(backup) |
||||
} |
||||
|
||||
|
||||
# Formats the given event log record message |
||||
# |
||||
proc twapi::eventlog_format_message {rec args} { |
||||
variable _eventlog_message_cache |
||||
|
||||
array set opts [parseargs args { |
||||
width.int |
||||
langid.int |
||||
} -nulldefault] |
||||
|
||||
set source [dict get $rec -source] |
||||
set eventid [dict get $rec -eventid] |
||||
|
||||
if {[dict exists $_eventlog_message_cache $source fmtstring $opts(langid) $eventid]} { |
||||
set fmtstring [dict get $_eventlog_message_cache $source fmtstring $opts(langid) $eventid] |
||||
dict incr _eventlog_message_cache __fmtstring_hits |
||||
} else { |
||||
dict incr _eventlog_message_cache __fmtstring_misses |
||||
|
||||
# Find the registry key if we do not have it already |
||||
if {[dict exists $_eventlog_message_cache $source regkey]} { |
||||
dict incr _eventlog_message_cache __regkey_hits |
||||
set regkey [dict get $_eventlog_message_cache $source regkey] |
||||
} else { |
||||
set regkey [_find_eventlog_regkey $source] |
||||
dict set _eventlog_message_cache $source regkey $regkey |
||||
dict incr _eventlog_message_cache __regkey_misses |
||||
} |
||||
|
||||
# Get the message file, if there is one |
||||
if {! [catch {registry get $regkey "EventMessageFile"} path]} { |
||||
# Try each file listed in turn |
||||
foreach dll [split $path \;] { |
||||
set dll [expand_environment_strings $dll] |
||||
if {! [catch { |
||||
set fmtstring [format_message -module $dll -messageid $eventid -width $opts(width) -langid $opts(langid)] |
||||
} msg]} { |
||||
dict set _eventlog_message_cache $source fmtstring $opts(langid) $eventid $fmtstring |
||||
break |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {! [info exists fmtstring]} { |
||||
dict incr _eventlog_message_cache __notfound |
||||
|
||||
set fmt "The message file or event definition for event id [dict get $rec -eventid] from source [dict get $rec -source] was not found. The following information was part of the event: " |
||||
set flds [list ] |
||||
for {set i 1} {$i <= [llength [dict get $rec -params]]} {incr i} { |
||||
lappend flds %$i |
||||
} |
||||
append fmt [join $flds ", "] |
||||
return [format_message -fmtstring $fmt \ |
||||
-params [dict get $rec -params] -width $opts(width)] |
||||
} |
||||
|
||||
set msg [format_message -fmtstring $fmtstring -params [dict get $rec -params]] |
||||
|
||||
# We'd found a message from the message file and replaced the string |
||||
# parameters. Now fill in the parameter file values if any. Note these are |
||||
# separate from the string parameters passed in through rec(-params) |
||||
|
||||
# First check if the formatted string itself still has placeholders |
||||
# Place holder for the parameters file are supposed to start |
||||
# with two % chars. Unfortunately, not all apps, even Microsoft's own |
||||
# DCOM obey this. So check for both % and %% |
||||
set placeholder_indices [regexp -indices -all -inline {%?%\d+} $msg] |
||||
if {[llength $placeholder_indices] == 0} { |
||||
# No placeholders. |
||||
return $msg |
||||
} |
||||
|
||||
# Loop through to replace placeholders. |
||||
set msg2 ""; # Holds result after param replacement |
||||
set prev_end 0 |
||||
foreach placeholder $placeholder_indices { |
||||
lassign $placeholder start end |
||||
# Append the stuff between previous placeholder and this one |
||||
append msg2 [string range $msg $prev_end [expr {$start-1}]] |
||||
set repl [string range $msg $start $end]; # Default if not found |
||||
set paramid [string trimleft $repl %]; # Skip "%" |
||||
if {[dict exists $_eventlog_message_cache $source paramstring $opts(langid) $paramid]} { |
||||
dict incr _eventlog_message_cache __paramstring_hits |
||||
set repl [format_message -fmtstring [dict get $_eventlog_message_cache $source paramstring $opts(langid) $paramid] -params [dict get $rec -params]] |
||||
} else { |
||||
dict incr _eventlog_message_cache __paramstring_misses |
||||
# Not in cache, need to look up |
||||
if {![info exists paramfiles]} { |
||||
# Construct list of parameter string files |
||||
|
||||
# TBD - cache registry key results? |
||||
# Find the registry key if we do not have it already |
||||
if {![info exists regkey]} { |
||||
if {[dict exists $_eventlog_message_cache $source regkey]} { |
||||
dict incr _eventlog_message_cache __regkey_hits |
||||
set regkey [dict get $_eventlog_message_cache $source regkey] |
||||
} else { |
||||
dict incr _eventlog_message_cache __regkey_misses |
||||
set regkey [_find_eventlog_regkey $source] |
||||
dict set _eventlog_message_cache $source regkey $regkey |
||||
} |
||||
} |
||||
set paramfiles {} |
||||
if {! [catch {registry get $regkey "ParameterMessageFile"} path]} { |
||||
# Loop through every placeholder, look for the entry in the |
||||
# parameters file and replace it if found |
||||
foreach paramfile [split $path \;] { |
||||
lappend paramfiles [expand_environment_strings $paramfile] |
||||
} |
||||
} |
||||
} |
||||
# Try each file listed in turn |
||||
foreach paramfile $paramfiles { |
||||
if {! [catch { |
||||
set paramstring [string trimright [format_message -module $paramfile -messageid $paramid -langid $opts(langid)] \r\n] |
||||
} ]} { |
||||
# Found the replacement |
||||
dict set _eventlog_message_cache $source paramstring $opts(langid) $paramid $paramstring |
||||
set repl [format_message -fmtstring $paramstring -params [dict get $rec -params]] |
||||
break |
||||
} |
||||
} |
||||
} |
||||
append msg2 $repl |
||||
set prev_end [incr end] |
||||
} |
||||
|
||||
# Tack on tail after last placeholder |
||||
append msg2 [string range $msg $prev_end end] |
||||
return $msg2 |
||||
} |
||||
|
||||
# Format the category |
||||
proc twapi::eventlog_format_category {rec args} { |
||||
|
||||
array set opts [parseargs args { |
||||
width.int |
||||
langid.int |
||||
} -nulldefault] |
||||
|
||||
set category [dict get $rec -category] |
||||
if {$category == 0} { |
||||
return "" |
||||
} |
||||
|
||||
variable _eventlog_message_cache |
||||
|
||||
set source [dict get $rec -source] |
||||
|
||||
# Get the category string from cache, if there is one |
||||
if {[dict exists $_eventlog_message_cache $source category $opts(langid) $category]} { |
||||
dict incr _eventlog_message_cache __category_hits |
||||
set fmtstring [dict get $_eventlog_message_cache $source category $opts(langid) $category] |
||||
} else { |
||||
dict incr _eventlog_message_cache __category_misses |
||||
|
||||
# Find the registry key if we do not have it already |
||||
if {[dict exists $_eventlog_message_cache $source regkey]} { |
||||
dict incr _eventlog_message_cache __regkey_hits |
||||
set regkey [dict get $_eventlog_message_cache $source regkey] |
||||
} else { |
||||
set regkey [_find_eventlog_regkey $source] |
||||
dict set _eventlog_message_cache $source regkey $regkey |
||||
dict incr _eventlog_message_cache __regkey_misses |
||||
} |
||||
|
||||
if {! [catch {registry get $regkey "CategoryMessageFile"} path]} { |
||||
# Try each file listed in turn |
||||
foreach dll [split $path \;] { |
||||
set dll [expand_environment_strings $dll] |
||||
if {! [catch { |
||||
set fmtstring [format_message -module $dll -messageid $category -width $opts(width) -langid $opts(langid)] |
||||
} msg]} { |
||||
dict set _eventlog_message_cache $source category $opts(langid) $category $fmtstring |
||||
break |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {![info exists fmtstring]} { |
||||
set fmtstring "Category $category" |
||||
dict set _eventlog_message_cache $source category $opts(langid) $category $fmtstring |
||||
} |
||||
|
||||
return [format_message -fmtstring $fmtstring -params [dict get $rec -params]] |
||||
} |
||||
|
||||
proc twapi::eventlog_monitor_start {hevl script} { |
||||
variable _eventlog_notification_scripts |
||||
|
||||
set hevent [lindex [CreateEvent [_make_secattr {} 0] 0 0 ""] 0] |
||||
if {[catch {NotifyChangeEventLog $hevl $hevent} msg]} { |
||||
CloseHandle $hevent |
||||
error $msg $::errorInfo $::errorCode |
||||
} |
||||
|
||||
wait_on_handle $hevent -async twapi::_eventlog_notification_handler |
||||
set _eventlog_notification_scripts($hevent) $script |
||||
|
||||
# We do not want the application mistakenly closing the event |
||||
# while being waited on by the thread pool. That would be a big NO-NO |
||||
# so change the handle type so it cannot be passed to close_handle. |
||||
return [list evl $hevent] |
||||
} |
||||
|
||||
# Stop any notifications. Note these will stop even if the event log |
||||
# handle is closed but leave the event dangling. |
||||
proc twapi::eventlog_monitor_stop {hevent} { |
||||
variable _eventlog_notification_scripts |
||||
set hevent [lindex $hevent 1] |
||||
if {[info exists _eventlog_notification_scripts($hevent)]} { |
||||
unset _eventlog_notification_scripts($hevent) |
||||
cancel_wait_on_handle $hevent |
||||
CloseHandle $hevent |
||||
} |
||||
} |
||||
|
||||
proc twapi::_eventlog_notification_handler {hevent event} { |
||||
variable _eventlog_notification_scripts |
||||
if {[info exists _eventlog_notification_scripts($hevent)] && |
||||
$event eq "signalled"} { |
||||
uplevel #0 $_eventlog_notification_scripts($hevent) [list [list evl $hevent]] |
||||
} |
||||
} |
||||
|
||||
# TBD - document |
||||
proc twapi::eventlog_subscribe {source} { |
||||
set hevl [eventlog_open -source $source] |
||||
set hevent [lindex [CreateEvent [_make_secattr {} 0] 0 0 ""] 0] |
||||
if {[catch {NotifyChangeEventLog $hevl $hevent} msg]} { |
||||
set erinfo $::errorInfo |
||||
set ercode $::errorCode |
||||
CloseHandle $hevent |
||||
error $hsubscribe $erinfo $ercode |
||||
} |
||||
|
||||
return [list $hevl $hevent] |
||||
} |
||||
|
||||
# Utility procs |
||||
|
||||
# Find the registry key corresponding the given event log source |
||||
proc twapi::_find_eventlog_regkey {source} { |
||||
set topkey {HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\Eventlog} |
||||
|
||||
# Set a default list of children to work around an issue in |
||||
# the Tcl [registry keys] command where a ERROR_MORE_DATA is returned |
||||
# instead of a retry with a larger buffer. |
||||
set keys {Application Security System} |
||||
catch {set keys [registry keys $topkey]} |
||||
# Get all keys under this key and look for a source under that |
||||
foreach key $keys { |
||||
# See above Tcl issue |
||||
set srckeys {} |
||||
catch {set srckeys [registry keys "${topkey}\\$key"]} |
||||
foreach srckey $srckeys { |
||||
if {[string equal -nocase $srckey $source]} { |
||||
return "${topkey}\\${key}\\$srckey" |
||||
} |
||||
} |
||||
} |
||||
|
||||
# Default to Application - TBD |
||||
return "${topkey}\\Application" |
||||
} |
||||
|
||||
proc twapi::_eventlog_dump {source chan} { |
||||
set hevl [eventlog_open -source $source] |
||||
while {[llength [set events [eventlog_read $hevl]]]} { |
||||
# print out each record |
||||
foreach eventrec $events { |
||||
array set event $eventrec |
||||
set timestamp [clock format $event(-timewritten) -format "%x %X"] |
||||
set source $event(-source) |
||||
set category [twapi::eventlog_format_category $eventrec -width -1] |
||||
set message [twapi::eventlog_format_message $eventrec -width -1] |
||||
puts $chan "$timestamp $source $category $message" |
||||
} |
||||
} |
||||
eventlog_close $hevl |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
# If we are not being sourced from a executable resource, need to |
||||
# source the remaining support files. In the former case, they are |
||||
# automatically combined into one so the sourcing is not needed. |
||||
if {![info exists twapi::twapi_eventlog_rc_sourced]} { |
||||
source [file join [file dirname [info script]] evt.tcl] |
||||
source [file join [file dirname [info script]] winlog.tcl] |
||||
} |
||||
@ -0,0 +1,718 @@
|
||||
# |
||||
# Copyright (c) 2012-2014, Ashok P. Nadkarni |
||||
# All rights reserved. |
||||
# |
||||
# See the file LICENSE for license |
||||
|
||||
# Event log handling for Vista and later |
||||
|
||||
namespace eval twapi { |
||||
variable _evt; # See _evt_init |
||||
|
||||
# System event fields in order returned by _evt_decode_event_system_fields |
||||
twapi::record evt_system_fields { |
||||
-providername -providerguid -eventid -qualifiers -level -task |
||||
-opcode -keywordmask -timecreated -eventrecordid -activityid |
||||
-relatedactivityid -pid -tid -channel |
||||
-computer -sid -version |
||||
} |
||||
|
||||
proc _evt_init {} { |
||||
variable _evt |
||||
|
||||
# Various structures that we maintain / cache for efficiency as they |
||||
# are commonly used are kept in the _evt array with the following keys: |
||||
|
||||
# system_render_context_handle - is the handle to a rendering |
||||
# context for the system portion of an event |
||||
set _evt(system_render_context_handle) [evt_render_context_system] |
||||
|
||||
# user_render_context_handle - is the handle to a rendering |
||||
# context for the user data portion of an event |
||||
set _evt(user_render_context_handle) [evt_render_context_user] |
||||
|
||||
# render_buffer - is NULL or holds a pointer to the buffer used to |
||||
# retrieve values so does not have to be reallocated every time. |
||||
set _evt(render_buffer) NULL |
||||
|
||||
# publisher_handles - caches publisher names to their meta information. |
||||
# This is a dictionary indexed with nested keys - |
||||
# publisher, session, lcid. TBD - need a mechanism to clear ? |
||||
set _evt(publisher_handles) [dict create] |
||||
|
||||
# -levelname - dict of publisher name / level number to level names |
||||
set _evt(-levelname) {} |
||||
|
||||
# -taskname - dict of publisher name / task number to task name |
||||
set _evt(-taskname) {} |
||||
|
||||
# -opcodename - dict of publisher name / opcode number to opcode name |
||||
set _evt(-opcodename) {} |
||||
|
||||
# No-op the proc once init is done |
||||
proc _evt_init {} {} |
||||
} |
||||
} |
||||
|
||||
# TBD - document |
||||
proc twapi::evt_local_session {} { |
||||
return NULL |
||||
} |
||||
|
||||
# TBD - document |
||||
proc twapi::evt_local_session? {hsess} { |
||||
return [pointer_null? $hsess] |
||||
} |
||||
|
||||
# TBD - document |
||||
proc twapi::evt_open_session {server args} { |
||||
array set opts [parseargs args { |
||||
user.arg |
||||
domain.arg |
||||
password.arg |
||||
{authtype.arg 0} |
||||
} -nulldefault -maxleftover 0] |
||||
|
||||
if {![string is integer -strict $opts(authtype)]} { |
||||
set opts(authtype) [dict get {default 0 negotiate 1 kerberos 2 ntlm 3} [string tolower $opts(authtype)]] |
||||
} |
||||
|
||||
return [EvtOpenSession 1 [list $server $opts(user) $opts(domain) $opts(password) $opts(authtype)] 0 0] |
||||
} |
||||
|
||||
# TBD - document |
||||
proc twapi::evt_close_session {hsess} { |
||||
if {![evt_local_session? $hsess]} { |
||||
evt_close $hsess |
||||
} |
||||
} |
||||
|
||||
proc twapi::evt_channels {{hevtsess NULL}} { |
||||
# TBD - document hevtsess |
||||
set chnames {} |
||||
set hevt [EvtOpenChannelEnum $hevtsess 0] |
||||
trap { |
||||
while {[set chname [EvtNextChannelPath $hevt]] ne ""} { |
||||
lappend chnames $chname |
||||
} |
||||
} finally { |
||||
evt_close $hevt |
||||
} |
||||
|
||||
return $chnames |
||||
} |
||||
|
||||
proc twapi::evt_clear_log {chanpath args} { |
||||
# TBD - document -session |
||||
array set opts [parseargs args { |
||||
{session.arg NULL} |
||||
{backup.arg ""} |
||||
} -maxleftover 0] |
||||
|
||||
return [EvtClearLog $opts(session) $chanpath [_evt_normalize_path $opts(backup)] 0] |
||||
} |
||||
|
||||
# TBD - document |
||||
proc twapi::evt_archive_exported_log {logpath args} { |
||||
array set opts [parseargs args { |
||||
{session.arg NULL} |
||||
{lcid.int 0} |
||||
} -maxleftover 0] |
||||
|
||||
return [EvtArchiveExportedLog $opts(session) [_evt_normalize_path $logpath] $opts(lcid) 0] |
||||
} |
||||
|
||||
proc twapi::evt_export_log {outfile args} { |
||||
# TBD - document -session |
||||
array set opts [parseargs args { |
||||
{session.arg NULL} |
||||
file.arg |
||||
channel.arg |
||||
{query.arg *} |
||||
{ignorequeryerrors 0 0x1000} |
||||
} -maxleftover 0] |
||||
|
||||
if {([info exists opts(file)] && [info exists opts(channel)]) || |
||||
! ([info exists opts(file)] || [info exists opts(channel)])} { |
||||
error "Exactly one of -file or -channel must be specified." |
||||
} |
||||
|
||||
if {[info exists opts(file)]} { |
||||
set path [_evt_normalize_path $opts(file)] |
||||
incr opts(ignorequeryerrors) 2 |
||||
} else { |
||||
set path $opts(channel) |
||||
incr opts(ignorequeryerrors) 1 |
||||
} |
||||
|
||||
return [EvtExportLog $opts(session) $path $opts(query) [_evt_normalize_path $outfile] $opts(ignorequeryerrors)] |
||||
} |
||||
|
||||
# TBD - document |
||||
proc twapi::evt_create_bookmark {{mark ""}} { |
||||
return [EvtCreateBookmark $mark] |
||||
} |
||||
|
||||
# TBD - document |
||||
proc twapi::evt_render_context_xpaths {xpaths} { |
||||
return [EvtCreateRenderContext $xpaths 0] |
||||
} |
||||
|
||||
# TBD - document |
||||
proc twapi::evt_render_context_system {} { |
||||
return [EvtCreateRenderContext {} 1] |
||||
} |
||||
|
||||
# TBD - document |
||||
proc twapi::evt_render_context_user {} { |
||||
return [EvtCreateRenderContext {} 2] |
||||
} |
||||
|
||||
# TBD - document |
||||
proc twapi::evt_open_channel_config {chanpath args} { |
||||
array set opts [parseargs args { |
||||
{session.arg NULL} |
||||
} -maxleftover 0] |
||||
|
||||
return [EvtOpenChannelConfig $opts(session) $chanpath 0] |
||||
} |
||||
|
||||
# TBD - document |
||||
proc twapi::evt_get_channel_config {hevt args} { |
||||
set result {} |
||||
foreach opt $args { |
||||
lappend result $opt \ |
||||
[EvtGetChannelConfigProperty $hevt \ |
||||
[_evt_map_channel_config_property $hevt $propid]] |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
# TBD - document |
||||
proc twapi::evt_set_channel_config {hevt propid val} { |
||||
return [EvtSetChannelConfigProperty $hevt [_evt_map_channel_config_property $propid 0 $val]] |
||||
} |
||||
|
||||
|
||||
# TBD - document |
||||
proc twapi::_evt_map_channel_config_property {propid} { |
||||
if {[string is integer -strict $propid]} { |
||||
return $propid |
||||
} |
||||
|
||||
# Note: values are from winevt.h, Win7 SDK has typos for last few |
||||
return [dict get { |
||||
-enabled 0 |
||||
-isolation 1 |
||||
-type 2 |
||||
-owningpublisher 3 |
||||
-classiceventlog 4 |
||||
-access 5 |
||||
-loggingretention 6 |
||||
-loggingautobackup 7 |
||||
-loggingmaxsize 8 |
||||
-logginglogfilepath 9 |
||||
-publishinglevel 10 |
||||
-publishingkeywords 11 |
||||
-publishingcontrolguid 12 |
||||
-publishingbuffersize 13 |
||||
-publishingminbuffers 14 |
||||
-publishingmaxbuffers 15 |
||||
-publishinglatency 16 |
||||
-publishingclocktype 17 |
||||
-publishingsidtype 18 |
||||
-publisherlist 19 |
||||
-publishingfilemax 20 |
||||
} $propid] |
||||
} |
||||
|
||||
# TBD - document |
||||
proc twapi::evt_event_info {hevt args} { |
||||
set result {} |
||||
foreach opt $args { |
||||
lappend result $opt [EvtGetEventInfo $hevt \ |
||||
[dict get {-queryids 0 -path 1} $opt]] |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
|
||||
# TBD - document |
||||
proc twapi::evt_event_metadata_property {hevt args} { |
||||
set result {} |
||||
foreach opt $args { |
||||
lappend result $opt \ |
||||
[EvtGetEventMetadataProperty $hevt \ |
||||
[dict get { |
||||
-id 0 -version 1 -channel 2 -level 3 |
||||
-opcode 4 -task 5 -keyword 6 -messageid 7 -template 8 |
||||
} $opt]] |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
|
||||
# TBD - document |
||||
proc twapi::evt_open_log_info {args} { |
||||
array set opts [parseargs args { |
||||
{session.arg NULL} |
||||
file.arg |
||||
channel.arg |
||||
} -maxleftover 0] |
||||
|
||||
if {([info exists opts(file)] && [info exists opts(channel)]) || |
||||
! ([info exists opts(file)] || [info exists opts(channel)])} { |
||||
error "Exactly one of -file or -channel must be specified." |
||||
} |
||||
|
||||
if {[info exists opts(file)]} { |
||||
set path [_evt_normalize_path $opts(file)] |
||||
set flags 0x2 |
||||
} else { |
||||
set path $opts(channel) |
||||
set flags 0x1 |
||||
} |
||||
|
||||
return [EvtOpenLog $opts(session) $path $flags] |
||||
} |
||||
|
||||
# TBD - document |
||||
proc twapi::evt_log_info {hevt args} { |
||||
set result {} |
||||
foreach opt $args { |
||||
lappend result $opt [EvtGetLogInfo $hevt [dict get { |
||||
-creationtime 0 -lastaccesstime 1 -lastwritetime 2 |
||||
-filesize 3 -attributes 4 -numberoflogrecords 5 |
||||
-oldestrecordnumber 6 -full 7 |
||||
} $opt]] |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
# TBD - document |
||||
proc twapi::evt_publisher_metadata_property {hpub args} { |
||||
set result {} |
||||
foreach opt $args { |
||||
set val [EvtGetPublisherMetadataProperty $hpub [dict get { |
||||
-publisherguid 0 -resourcefilepath 1 -parameterfilepath 2 |
||||
-messagefilepath 3 -helplink 4 -publishermessageid 5 |
||||
-channelreferences 6 -levels 12 -tasks 16 |
||||
-opcodes 21 -keywords 25 |
||||
} $opt] 0] |
||||
if {$opt ni {-channelreferences -levels -tasks -opcodes -keywords}} { |
||||
lappend result $opt $val |
||||
continue |
||||
} |
||||
set n [EvtGetObjectArraySize $val] |
||||
set val2 {} |
||||
for {set i 0} {$i < $n} {incr i} { |
||||
set rec {} |
||||
foreach {opt2 iopt} [dict get { |
||||
-channelreferences { -channelreferencepath 7 |
||||
-channelreferenceindex 8 -channelreferenceid 9 |
||||
-channelreferenceflags 10 -channelreferencemessageid 11} |
||||
-levels { -levelname 13 -levelvalue 14 -levelmessageid 15 } |
||||
-tasks { -taskname 17 -taskeventguid 18 -taskvalue 19 |
||||
-taskmessageid 20} |
||||
-opcodes {-opcodename 22 -opcodevalue 23 -opcodemessageid 24} |
||||
-keywords {-keywordname 26 -keywordvalue 27 |
||||
-keywordmessageid 28} |
||||
} $opt] { |
||||
lappend rec $opt2 [EvtGetObjectArrayProperty $val $iopt $i] |
||||
} |
||||
lappend val2 $rec |
||||
} |
||||
|
||||
evt_close $val |
||||
lappend result $opt $val2 |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
# TBD - document |
||||
proc twapi::evt_query_info {hq args} { |
||||
set result {} |
||||
foreach opt $args { |
||||
lappend result $opt [EvtGetQueryInfo $hq [dict get { |
||||
-names 1 statuses 2 |
||||
} $opt]] |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
# TBD - document |
||||
proc twapi::evt_object_array_size {hevt} { |
||||
return [EvtGetObjectArraySize $hevt] |
||||
} |
||||
|
||||
# TBD - document |
||||
proc twapi::evt_object_array_property {hevt index args} { |
||||
set result {} |
||||
|
||||
foreach opt $args { |
||||
lappend result $opt \ |
||||
[EvtGetObjectArrayProperty $hevt [dict get { |
||||
-channelreferencepath 7 |
||||
-channelreferenceindex 8 -channelreferenceid 9 |
||||
-channelreferenceflags 10 -channelreferencemessageid 11 |
||||
-levelname 13 -levelvalue 14 -levelmessageid 15 |
||||
-taskname 17 -taskeventguid 18 -taskvalue 19 |
||||
-taskmessageid 20 -opcodename 22 |
||||
-opcodevalue 23 -opcodemessageid 24 |
||||
-keywordname 26 -keywordvalue 27 -keywordmessageid 28 |
||||
}] $index] |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
proc twapi::evt_publishers {{hsess NULL}} { |
||||
set pubs {} |
||||
set hevt [EvtOpenPublisherEnum $hsess 0] |
||||
trap { |
||||
while {[set pub [EvtNextPublisherId $hevt]] ne ""} { |
||||
lappend pubs $pub |
||||
} |
||||
} finally { |
||||
evt_close $hevt |
||||
} |
||||
|
||||
return $pubs |
||||
} |
||||
|
||||
# TBD - document |
||||
proc twapi::evt_open_publisher_metadata {pub args} { |
||||
array set opts [parseargs args { |
||||
{session.arg NULL} |
||||
logfile.arg |
||||
lcid.int |
||||
} -nulldefault -maxleftover 0] |
||||
|
||||
return [EvtOpenPublisherMetadata $opts(session) $pub $opts(logfile) $opts(lcid) 0] |
||||
} |
||||
|
||||
# TBD - document |
||||
proc twapi::evt_publisher_events_metadata {hpub args} { |
||||
set henum [EvtOpenEventMetadataEnum $hpub] |
||||
|
||||
# It is faster to build a list and then have Tcl shimmer to a dict when |
||||
# required |
||||
set meta {} |
||||
trap { |
||||
while {[set hmeta [EvtNextEventMetadata $henum 0]] ne ""} { |
||||
lappend meta [evt_event_metadata_property $hmeta {*}$args] |
||||
evt_close $hmeta |
||||
} |
||||
} finally { |
||||
evt_close $henum |
||||
} |
||||
|
||||
return $meta |
||||
} |
||||
|
||||
proc twapi::evt_query {args} { |
||||
array set opts [parseargs args { |
||||
{session.arg NULL} |
||||
file.arg |
||||
channel.arg |
||||
{query.arg *} |
||||
{ignorequeryerrors 0 0x1000} |
||||
{direction.sym forward {forward 0x100 reverse 0x200 backward 0x200}} |
||||
} -maxleftover 0] |
||||
|
||||
if {([info exists opts(file)] && [info exists opts(channel)]) || |
||||
! ([info exists opts(file)] || [info exists opts(channel)])} { |
||||
error "Exactly one of -file or -channel must be specified." |
||||
} |
||||
|
||||
set flags $opts(ignorequeryerrors) |
||||
incr flags $opts(direction) |
||||
|
||||
if {[info exists opts(file)]} { |
||||
set path [_evt_normalize_path $opts(file)] |
||||
incr flags 0x2 |
||||
} else { |
||||
set path $opts(channel) |
||||
incr flags 0x1 |
||||
} |
||||
|
||||
return [EvtQuery $opts(session) $path $opts(query) $flags] |
||||
} |
||||
|
||||
proc twapi::evt_next {hresultset args} { |
||||
array set opts [parseargs args { |
||||
{timeout.int -1} |
||||
{count.int 1} |
||||
{status.arg} |
||||
} -maxleftover 0] |
||||
|
||||
if {[info exists opts(status)]} { |
||||
upvar 1 $opts(status) status |
||||
return [EvtNext $hresultset $opts(count) $opts(timeout) 0 status] |
||||
} else { |
||||
return [EvtNext $hresultset $opts(count) $opts(timeout) 0] |
||||
} |
||||
} |
||||
|
||||
twapi::proc* twapi::_evt_decode_event_system_fields {hevt} { |
||||
_evt_init |
||||
} { |
||||
variable _evt |
||||
set _evt(render_buffer) [Twapi_EvtRenderValues $_evt(system_render_context_handle) $hevt $_evt(render_buffer)] |
||||
set rec [Twapi_ExtractEVT_RENDER_VALUES $_evt(render_buffer)] |
||||
return [evt_system_fields set $rec \ |
||||
-providername [atomize [evt_system_fields -providername $rec]] \ |
||||
-providerguid [atomize [evt_system_fields -providerguid $rec]] \ |
||||
-channel [atomize [evt_system_fields -channel $rec]] \ |
||||
-computer [atomize [evt_system_fields -computer $rec]]] |
||||
} |
||||
|
||||
# TBD - document. Returns a list of user data values |
||||
twapi::proc* twapi::evt_decode_event_userdata {hevt} { |
||||
_evt_init |
||||
} { |
||||
variable _evt |
||||
set _evt(render_buffer) [Twapi_EvtRenderValues $_evt(user_render_context_handle) $hevt $_evt(render_buffer)] |
||||
return [Twapi_ExtractEVT_RENDER_VALUES $_evt(render_buffer)] |
||||
} |
||||
|
||||
twapi::proc* twapi::evt_decode_events {hevts args} { |
||||
_evt_init |
||||
} { |
||||
variable _evt |
||||
|
||||
array set opts [parseargs args { |
||||
{values.arg NULL} |
||||
{session.arg NULL} |
||||
{logfile.arg ""} |
||||
{lcid.int 0} |
||||
ignorestring.arg |
||||
message |
||||
levelname |
||||
taskname |
||||
opcodename |
||||
keywords |
||||
xml |
||||
} -ignoreunknown -hyphenated] |
||||
|
||||
# SAME ORDER AS _evt_decode_event_system_fields |
||||
set decoded_fields [evt_system_fields] |
||||
set decoded_events {} |
||||
|
||||
# ORDER MUST BE SAME AS order in which values are appended below |
||||
foreach opt {-levelname -taskname -opcodename -keywords -xml -message} { |
||||
if {$opts($opt)} { |
||||
lappend decoded_fields $opt |
||||
} |
||||
} |
||||
|
||||
foreach hevt $hevts { |
||||
set decoded [_evt_decode_event_system_fields $hevt] |
||||
# Get publisher from hevt |
||||
set publisher [evt_system_fields -providername $decoded] |
||||
|
||||
if {! [dict exists $_evt(publisher_handles) $publisher $opts(-session) $opts(-lcid)]} { |
||||
if {[catch { |
||||
dict set _evt(publisher_handles) $publisher $opts(-session) $opts(-lcid) [EvtOpenPublisherMetadata $opts(-session) $publisher $opts(-logfile) $opts(-lcid) 0] |
||||
}]} { |
||||
# TBD - debug log |
||||
dict set _evt(publisher_handles) $publisher $opts(-session) $opts(-lcid) NULL |
||||
} |
||||
} |
||||
set hpub [dict get $_evt(publisher_handles) $publisher $opts(-session) $opts(-lcid)] |
||||
|
||||
# See if cached values are present for -levelname -taskname |
||||
# and -opcodename. TBD - can -keywords be added to this ? |
||||
foreach {intopt opt callflag} {-level -levelname 2 -task -taskname 3 -opcode -opcodename 4} { |
||||
if {$opts($opt)} { |
||||
set ival [evt_system_fields $intopt $decoded] |
||||
if {[dict exists $_evt($opt) $publisher $ival]} { |
||||
lappend decoded [dict get $_evt($opt) $publisher $ival] |
||||
} else { |
||||
# Not cached. Look it up. Value of 0 -> null so |
||||
# just use ignorestring if specified. |
||||
if {$ival == 0 && [info exists opts(-ignorestring)]} { |
||||
set optval $opts(-ignorestring) |
||||
} else { |
||||
if {[info exists opts(-ignorestring)]} { |
||||
if {[EvtFormatMessage $hpub $hevt 0 $opts(-values) $callflag optval]} { |
||||
dict set _evt($opt) $publisher $ival $optval |
||||
} else { |
||||
# Note result not cached if not found since |
||||
# ignorestring may be different on every call |
||||
set optval $opts(-ignorestring) |
||||
} |
||||
} else { |
||||
# -ignorestring not specified so |
||||
# will raise error if not found |
||||
set optval [EvtFormatMessage $hpub $hevt 0 $opts(-values) $callflag] |
||||
dict set _evt($opt) $publisher $ival [atomize $optval] |
||||
} |
||||
} |
||||
lappend decoded $optval |
||||
} |
||||
} |
||||
} |
||||
|
||||
# Non-cached fields |
||||
# ORDER MUST BE SAME AS decoded_fields ABOVE |
||||
foreach {opt callflag} { |
||||
-keywords 5 |
||||
-xml 9 |
||||
} { |
||||
if {$opts($opt)} { |
||||
if {[info exists opts(-ignorestring)]} { |
||||
if {! [EvtFormatMessage $hpub $hevt 0 $opts(-values) $callflag optval]} { |
||||
set optval $opts(-ignorestring) |
||||
} |
||||
} else { |
||||
set optval [EvtFormatMessage $hpub $hevt 0 $opts(-values) $callflag] |
||||
} |
||||
lappend decoded $optval |
||||
} |
||||
} |
||||
|
||||
# We treat -message differently because on failure we want |
||||
# to extract the user data. -ignorestring is not used for this |
||||
# unless user data extraction also fails |
||||
if {$opts(-message)} { |
||||
if {[EvtFormatMessage $hpub $hevt 0 $opts(-values) 1 message]} { |
||||
lappend decoded $message |
||||
} else { |
||||
# TBD - make sure we have a test for this case. |
||||
# TBD - log |
||||
if {[catch { |
||||
lappend decoded "Message for event could not be found. Event contained user data: [join [evt_decode_event_userdata $hevt] ,]" |
||||
} message]} { |
||||
if {[info exists opts(-ignorestring)]} { |
||||
lappend decoded $opts(-ignorestring) |
||||
} else { |
||||
error $message |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
lappend decoded_events $decoded |
||||
} |
||||
|
||||
return [list $decoded_fields $decoded_events] |
||||
} |
||||
|
||||
proc twapi::evt_decode_event {hevt args} { |
||||
return [recordarray index [evt_decode_events [list $hevt] {*}$args] 0 -format dict] |
||||
} |
||||
|
||||
# TBD - document |
||||
proc twapi::evt_format_publisher_message {hpub msgid args} { |
||||
|
||||
array set opts [parseargs args { |
||||
{values.arg NULL} |
||||
} -maxleftover 0] |
||||
|
||||
return [EvtFormatMessage $hpub NULL $msgid $opts(values) 8] |
||||
} |
||||
|
||||
# TBD - document |
||||
# Where is this used? |
||||
proc twapi::evt_free_EVT_VARIANT_ARRAY {p} { |
||||
evt_free $p |
||||
} |
||||
|
||||
# TBD - document |
||||
# Where is this used? |
||||
proc twapi::evt_free_EVT_RENDER_VALUES {p} { |
||||
evt_free $p |
||||
} |
||||
|
||||
# TBD - document |
||||
proc twapi::evt_seek {hresults pos args} { |
||||
array set opts [parseargs args { |
||||
{origin.arg first {first last current}} |
||||
bookmark.arg |
||||
{strict 0 0x10000} |
||||
} -maxleftover 0] |
||||
|
||||
if {[info exists opts(bookmark)]} { |
||||
set flags 4 |
||||
} else { |
||||
set flags [lsearch -exact {first last current} $opts(origin)] |
||||
incr flags; # 1 -> first, 2 -> last, 3 -> current |
||||
set opts(bookmark) NULL |
||||
} |
||||
|
||||
incr flags $opts(strict) |
||||
|
||||
EvtSeek $hresults $pos $opts(bookmark) 0 $flags |
||||
} |
||||
|
||||
proc twapi::evt_subscribe {path args} { |
||||
# TBD - document -session and -bookmark and -strict |
||||
array set opts [parseargs args { |
||||
{session.arg NULL} |
||||
{query.arg *} |
||||
bookmark.arg |
||||
includeexisting |
||||
{ignorequeryerrors 0 0x1000} |
||||
{strict 0 0x10000} |
||||
} -maxleftover 0] |
||||
|
||||
set flags [expr {$opts(ignorequeryerrors) | $opts(strict)}] |
||||
if {[info exists opts(bookmark)]} { |
||||
set flags [expr {$flags | 3}] |
||||
set bookmark $opts(origin) |
||||
} else { |
||||
set bookmark NULL |
||||
if {$opts(includeexisting)} { |
||||
set flags [expr {$flags | 2}] |
||||
} else { |
||||
set flags [expr {$flags | 1}] |
||||
} |
||||
} |
||||
|
||||
set hevent [lindex [CreateEvent [_make_secattr {} 0] 0 0 ""] 0] |
||||
if {[catch { |
||||
EvtSubscribe $opts(session) $hevent $path $opts(query) $bookmark $flags |
||||
} hsubscribe]} { |
||||
set erinfo $::errorInfo |
||||
set ercode $::errorCode |
||||
CloseHandle $hevent |
||||
error $hsubscribe $erinfo $ercode |
||||
} |
||||
|
||||
return [list $hsubscribe $hevent] |
||||
} |
||||
|
||||
proc twapi::_evt_normalize_path {path} { |
||||
# Do not want to rely on [file normalize] returning "" for "" |
||||
if {$path eq ""} { |
||||
return "" |
||||
} else { |
||||
return [file nativename [file normalize $path]] |
||||
} |
||||
} |
||||
|
||||
proc twapi::_evt_dump {args} { |
||||
array set opts [parseargs args { |
||||
{outfd.arg stdout} |
||||
count.int |
||||
} -ignoreunknown] |
||||
|
||||
set hq [evt_query {*}$args] |
||||
trap { |
||||
while {[llength [set hevts [evt_next $hq]]]} { |
||||
trap { |
||||
foreach ev [recordarray getlist [evt_decode_events $hevts -message -ignorestring None.] -format dict] { |
||||
if {[info exists opts(count)] && |
||||
[incr opts(count) -1] < 0} { |
||||
return |
||||
} |
||||
puts $opts(outfd) "[dict get $ev -timecreated] [dict get $ev -eventrecordid] [dict get $ev -providername]: [dict get $ev -eventrecordid] [dict get $ev -message]" |
||||
} |
||||
} finally { |
||||
evt_close {*}$hevts |
||||
} |
||||
} |
||||
} finally { |
||||
evt_close $hq |
||||
} |
||||
} |
||||
@ -0,0 +1,236 @@
|
||||
# |
||||
# Copyright (c) 2010, Ashok P. Nadkarni |
||||
# All rights reserved. |
||||
# |
||||
# See the file LICENSE for license |
||||
|
||||
namespace eval twapi { |
||||
# Array maps handles we are waiting on to the ids of the registered waits |
||||
variable _wait_handle_ids |
||||
# Array maps id of registered wait to the corresponding callback scripts |
||||
variable _wait_handle_scripts |
||||
|
||||
} |
||||
|
||||
proc twapi::cast_handle {h type} { |
||||
# TBD - should this use pointer_from_address: |
||||
# return [pointer_from_address [address_from_pointer $h] $type] |
||||
return [list [lindex $h 0] $type] |
||||
} |
||||
|
||||
proc twapi::close_handle {h} { |
||||
|
||||
# Cancel waits on the handle, if any |
||||
cancel_wait_on_handle $h |
||||
|
||||
# Then close it |
||||
CloseHandle $h |
||||
} |
||||
|
||||
# Close multiple handles. In case of errors, collects them but keeps |
||||
# closing remaining handles and only raises the error at the end. |
||||
proc twapi::close_handles {args} { |
||||
# The original definition for this was broken in that it would |
||||
# gracefully accept non list parameters as a list of one. In 3.0 |
||||
# the handle format has changed so this does not happen |
||||
# naturally. We have to try and decipher whether it is a list |
||||
# of handles or a single handle. |
||||
|
||||
foreach arg $args { |
||||
if {[pointer? $arg]} { |
||||
# Looks like a single handle |
||||
if {[catch {close_handle $arg} msg]} { |
||||
set erinfo $::errorInfo |
||||
set ercode $::errorCode |
||||
set ermsg $msg |
||||
} |
||||
} else { |
||||
# Assume a list of handles |
||||
foreach h $arg { |
||||
if {[catch {close_handle $h} msg]} { |
||||
set erinfo $::errorInfo |
||||
set ercode $::errorCode |
||||
set ermsg $msg |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {[info exists erinfo]} { |
||||
error $msg $erinfo $ercode |
||||
} |
||||
} |
||||
|
||||
# |
||||
# Wait on a handle |
||||
proc twapi::wait_on_handle {hwait args} { |
||||
variable _wait_handle_ids |
||||
variable _wait_handle_scripts |
||||
|
||||
# When we are invoked from callback, handle is always typed as HANDLE |
||||
# so convert it so lookups succeed |
||||
set h [cast_handle $hwait HANDLE] |
||||
|
||||
# 0x00000008 -> # WT_EXECUTEONCEONLY |
||||
array set opts [parseargs args { |
||||
{wait.int -1} |
||||
async.arg |
||||
{executeonce.bool false 0x00000008} |
||||
}] |
||||
|
||||
if {![info exists opts(async)]} { |
||||
if {[info exists _wait_handle_ids($h)]} { |
||||
error "Attempt to synchronously wait on handle that is registered for an asynchronous wait." |
||||
} |
||||
|
||||
set ret [WaitForSingleObject $h $opts(wait)] |
||||
if {$ret == 0x80} { |
||||
return abandoned |
||||
} elseif {$ret == 0} { |
||||
return signalled |
||||
} elseif {$ret == 0x102} { |
||||
return timeout |
||||
} else { |
||||
error "Unexpected value $ret returned from WaitForSingleObject" |
||||
} |
||||
} |
||||
|
||||
# async option specified |
||||
|
||||
# Do not wait on manual reset events as cpu will spin continuously |
||||
# queueing events |
||||
if {[pointer? $hwait HANDLE_MANUALRESETEVENT] && |
||||
! $opts(executeonce) |
||||
} { |
||||
error "A handle to a manual reset event cannot be waited on asynchronously unless -executeonce is specified." |
||||
} |
||||
|
||||
# If handle already registered, cancel previous registration. |
||||
if {[info exists _wait_handle_ids($h)]} { |
||||
cancel_wait_on_handle $h |
||||
} |
||||
|
||||
|
||||
set id [Twapi_RegisterWaitOnHandle $h $opts(wait) $opts(executeonce)] |
||||
|
||||
# Set now that successfully registered |
||||
set _wait_handle_scripts($id) $opts(async) |
||||
set _wait_handle_ids($h) $id |
||||
|
||||
return |
||||
} |
||||
|
||||
# |
||||
# Cancel an async wait on a handle |
||||
proc twapi::cancel_wait_on_handle {h} { |
||||
variable _wait_handle_ids |
||||
variable _wait_handle_scripts |
||||
|
||||
if {[info exists _wait_handle_ids($h)]} { |
||||
Twapi_UnregisterWaitOnHandle $_wait_handle_ids($h) |
||||
unset _wait_handle_scripts($_wait_handle_ids($h)) |
||||
unset _wait_handle_ids($h) |
||||
} |
||||
} |
||||
|
||||
# |
||||
# Called from C when a handle is signalled or times out |
||||
proc twapi::_wait_handler {id h event} { |
||||
variable _wait_handle_ids |
||||
variable _wait_handle_scripts |
||||
|
||||
# We ignore the following stale event cases - |
||||
# - _wait_handle_ids($h) does not exist : the wait was canceled while |
||||
# and event was queued |
||||
# - _wait_handle_ids($h) exists but is different from $id - same |
||||
# as prior case, except that a new wait has since been initiated |
||||
# on the same handle value (which might have be for a different |
||||
# resource |
||||
|
||||
if {[info exists _wait_handle_ids($h)] && |
||||
$_wait_handle_ids($h) == $id} { |
||||
uplevel #0 [linsert $_wait_handle_scripts($id) end $h $event] |
||||
} |
||||
|
||||
return |
||||
} |
||||
|
||||
# Get the handle for a Tcl channel |
||||
proc twapi::get_tcl_channel_handle {chan direction} { |
||||
set direction [expr {[string equal $direction "write"] ? 1 : 0}] |
||||
return [Tcl_GetChannelHandle $chan $direction] |
||||
} |
||||
|
||||
# Duplicate a OS handle |
||||
proc twapi::duplicate_handle {h args} { |
||||
variable my_process_handle |
||||
|
||||
array set opts [parseargs args { |
||||
sourcepid.int |
||||
targetpid.int |
||||
access.arg |
||||
inherit |
||||
closesource |
||||
} -maxleftover 0] |
||||
|
||||
# Assume source and target processes are us |
||||
set source_ph $my_process_handle |
||||
set target_ph $my_process_handle |
||||
|
||||
if {[string is wideinteger $h]} { |
||||
set h [pointer_from_address $h HANDLE] |
||||
} |
||||
|
||||
trap { |
||||
set me [pid] |
||||
# If source pid specified and is not us, get a handle to the process |
||||
if {[info exists opts(sourcepid)] && $opts(sourcepid) != $me} { |
||||
set source_ph [get_process_handle $opts(sourcepid) -access process_dup_handle] |
||||
} |
||||
|
||||
# Ditto for target process... |
||||
if {[info exists opts(targetpid)] && $opts(targetpid) != $me} { |
||||
set target_ph [get_process_handle $opts(targetpid) -access process_dup_handle] |
||||
} |
||||
|
||||
# Do we want to close the original handle (DUPLICATE_CLOSE_SOURCE) |
||||
set flags [expr {$opts(closesource) ? 0x1: 0}] |
||||
|
||||
if {[info exists opts(access)]} { |
||||
set access [_access_rights_to_mask $opts(access)] |
||||
} else { |
||||
# If no desired access is indicated, we want the same access as |
||||
# the original handle |
||||
set access 0 |
||||
set flags [expr {$flags | 0x2}]; # DUPLICATE_SAME_ACCESS |
||||
} |
||||
|
||||
|
||||
set dup [DuplicateHandle $source_ph $h $target_ph $access $opts(inherit) $flags] |
||||
|
||||
# IF targetpid specified, return handle else literal |
||||
# (even if targetpid is us) |
||||
if {[info exists opts(targetpid)]} { |
||||
set dup [pointer_to_address $dup] |
||||
} |
||||
} finally { |
||||
if {$source_ph != $my_process_handle} { |
||||
CloseHandle $source_ph |
||||
} |
||||
if {$target_ph != $my_process_handle} { |
||||
CloseHandle $source_ph |
||||
} |
||||
} |
||||
|
||||
return $dup |
||||
} |
||||
|
||||
proc twapi::set_handle_inheritance {h inherit} { |
||||
# 1 -> HANDLE_FLAG_INHERIT |
||||
SetHandleInformation $h 0x1 [expr {$inherit ? 1 : 0}] |
||||
} |
||||
|
||||
proc twapi::get_handle_inheritance {h} { |
||||
# 1 -> HANDLE_FLAG_INHERIT |
||||
return [expr {[GetHandleInformation $h] & 1}] |
||||
} |
||||
@ -0,0 +1,623 @@
|
||||
# |
||||
# Copyright (c) 2012 Ashok P. Nadkarni |
||||
# All rights reserved. |
||||
# |
||||
# See the file LICENSE for license |
||||
|
||||
package require twapi_ui; # SetCursorPos etc. |
||||
|
||||
# Enable window input |
||||
proc twapi::enable_window_input {hwin} { |
||||
return [expr {[EnableWindow $hwin 1] != 0}] |
||||
} |
||||
|
||||
# Disable window input |
||||
proc twapi::disable_window_input {hwin} { |
||||
return [expr {[EnableWindow $hwin 0] != 0}] |
||||
} |
||||
|
||||
# CHeck if window input is enabled |
||||
proc twapi::window_input_enabled {hwin} { |
||||
return [IsWindowEnabled $hwin] |
||||
} |
||||
|
||||
# Simulate user input |
||||
proc twapi::send_input {inputlist} { |
||||
array set input_defs { |
||||
MOUSEEVENTF_MOVE 0x0001 |
||||
MOUSEEVENTF_LEFTDOWN 0x0002 |
||||
MOUSEEVENTF_LEFTUP 0x0004 |
||||
MOUSEEVENTF_RIGHTDOWN 0x0008 |
||||
MOUSEEVENTF_RIGHTUP 0x0010 |
||||
MOUSEEVENTF_MIDDLEDOWN 0x0020 |
||||
MOUSEEVENTF_MIDDLEUP 0x0040 |
||||
MOUSEEVENTF_XDOWN 0x0080 |
||||
MOUSEEVENTF_XUP 0x0100 |
||||
MOUSEEVENTF_WHEEL 0x0800 |
||||
MOUSEEVENTF_VIRTUALDESK 0x4000 |
||||
MOUSEEVENTF_ABSOLUTE 0x8000 |
||||
|
||||
KEYEVENTF_EXTENDEDKEY 0x0001 |
||||
KEYEVENTF_KEYUP 0x0002 |
||||
KEYEVENTF_UNICODE 0x0004 |
||||
KEYEVENTF_SCANCODE 0x0008 |
||||
|
||||
XBUTTON1 0x0001 |
||||
XBUTTON2 0x0002 |
||||
} |
||||
|
||||
set inputs [list ] |
||||
foreach input $inputlist { |
||||
if {[string equal [lindex $input 0] "mouse"]} { |
||||
lassign $input mouse xpos ypos |
||||
set mouseopts [lrange $input 3 end] |
||||
array unset opts |
||||
array set opts [parseargs mouseopts { |
||||
relative moved |
||||
ldown lup rdown rup mdown mup x1down x1up x2down x2up |
||||
wheel.int |
||||
}] |
||||
set flags 0 |
||||
if {! $opts(relative)} { |
||||
set flags $input_defs(MOUSEEVENTF_ABSOLUTE) |
||||
} |
||||
|
||||
if {[info exists opts(wheel)]} { |
||||
if {($opts(x1down) || $opts(x1up) || $opts(x2down) || $opts(x2up))} { |
||||
error "The -wheel input event attribute may not be specified with -x1up, -x1down, -x2up or -x2down events" |
||||
} |
||||
set mousedata $opts(wheel) |
||||
set flags $input_defs(MOUSEEVENTF_WHEEL) |
||||
} else { |
||||
if {$opts(x1down) || $opts(x1up)} { |
||||
if {$opts(x2down) || $opts(x2up)} { |
||||
error "The -x1down, -x1up mouse input attributes are mutually exclusive with -x2down, -x2up attributes" |
||||
} |
||||
set mousedata $input_defs(XBUTTON1) |
||||
} else { |
||||
if {$opts(x2down) || $opts(x2up)} { |
||||
set mousedata $input_defs(XBUTTON2) |
||||
} else { |
||||
set mousedata 0 |
||||
} |
||||
} |
||||
} |
||||
foreach {opt flag} { |
||||
moved MOVE |
||||
ldown LEFTDOWN |
||||
lup LEFTUP |
||||
rdown RIGHTDOWN |
||||
rup RIGHTUP |
||||
mdown MIDDLEDOWN |
||||
mup MIDDLEUP |
||||
x1down XDOWN |
||||
x1up XUP |
||||
x2down XDOWN |
||||
x2up XUP |
||||
} { |
||||
if {$opts($opt)} { |
||||
set flags [expr {$flags | $input_defs(MOUSEEVENTF_$flag)}] |
||||
} |
||||
} |
||||
|
||||
lappend inputs [list mouse $xpos $ypos $mousedata $flags] |
||||
|
||||
} else { |
||||
lassign $input inputtype vk scan keyopts |
||||
if {"-extended" ni $keyopts} { |
||||
set extended 0 |
||||
} else { |
||||
set extended $input_defs(KEYEVENTF_EXTENDEDKEY) |
||||
} |
||||
if {"-usescan" ni $keyopts} { |
||||
set usescan 0 |
||||
} else { |
||||
set usescan $input_defs(KEYEVENTF_SCANCODE) |
||||
} |
||||
switch -exact -- $inputtype { |
||||
keydown { |
||||
lappend inputs [list key $vk $scan [expr {$extended|$usescan}]] |
||||
} |
||||
keyup { |
||||
lappend inputs [list key $vk $scan \ |
||||
[expr {$extended |
||||
| $usescan |
||||
| $input_defs(KEYEVENTF_KEYUP) |
||||
}]] |
||||
} |
||||
key { |
||||
lappend inputs [list key $vk $scan [expr {$extended|$usescan}]] |
||||
lappend inputs [list key $vk $scan \ |
||||
[expr {$extended |
||||
| $usescan |
||||
| $input_defs(KEYEVENTF_KEYUP) |
||||
}]] |
||||
} |
||||
unicode { |
||||
lappend inputs [list key 0 $scan $input_defs(KEYEVENTF_UNICODE)] |
||||
lappend inputs [list key 0 $scan \ |
||||
[expr {$input_defs(KEYEVENTF_UNICODE) |
||||
| $input_defs(KEYEVENTF_KEYUP) |
||||
}]] |
||||
} |
||||
default { |
||||
error "Unknown input type '$inputtype'" |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
SendInput $inputs |
||||
} |
||||
|
||||
# Block the input |
||||
proc twapi::block_input {} { |
||||
return [BlockInput 1] |
||||
} |
||||
|
||||
# Unblock the input |
||||
proc twapi::unblock_input {} { |
||||
return [BlockInput 0] |
||||
} |
||||
|
||||
# Send the given set of characters to the input queue |
||||
proc twapi::send_input_text {s} { |
||||
return [Twapi_SendUnicode $s] |
||||
} |
||||
|
||||
# send_keys - uses same syntax as VB SendKeys function |
||||
proc twapi::send_keys {keys} { |
||||
set inputs [_parse_send_keys $keys] |
||||
send_input $inputs |
||||
} |
||||
|
||||
|
||||
# Handles a hotkey notification |
||||
proc twapi::_hotkey_handler {msg atom key msgpos ticks} { |
||||
variable _hotkeys |
||||
|
||||
# Note it is not an error if a hotkey does not exist since it could |
||||
# have been deregistered in the time between hotkey input and receiving it. |
||||
set code 0 |
||||
if {[info exists _hotkeys($atom)]} { |
||||
foreach handler $_hotkeys($atom) { |
||||
set code [catch {uplevel #0 $handler} msg] |
||||
switch -exact -- $code { |
||||
0 { |
||||
# Normal, keep going |
||||
} |
||||
1 { |
||||
# Error - put in background and abort |
||||
after 0 [list error $msg $::errorInfo $::errorCode] |
||||
break |
||||
} |
||||
3 { |
||||
break; # Ignore remaining handlers |
||||
} |
||||
default { |
||||
# Keep going |
||||
} |
||||
} |
||||
} |
||||
} |
||||
return -code $code "" |
||||
} |
||||
|
||||
proc twapi::register_hotkey {hotkey script args} { |
||||
variable _hotkeys |
||||
|
||||
# 0x312 -> WM_HOTKEY |
||||
_register_script_wm_handler 0x312 [list [namespace current]::_hotkey_handler] 1 |
||||
|
||||
array set opts [parseargs args { |
||||
append |
||||
} -maxleftover 0] |
||||
|
||||
# set script [lrange $script 0 end]; # Ensure a valid list |
||||
|
||||
lassign [_hotkeysyms_to_vk $hotkey] modifiers vk |
||||
set hkid "twapi_hk_${vk}_$modifiers" |
||||
set atom [GlobalAddAtom $hkid] |
||||
if {[info exists _hotkeys($atom)]} { |
||||
GlobalDeleteAtom $atom; # Undo above AddAtom since already there |
||||
if {$opts(append)} { |
||||
lappend _hotkeys($atom) $script |
||||
} else { |
||||
set _hotkeys($atom) [list $script]; # Replace previous script |
||||
} |
||||
return $atom |
||||
} |
||||
trap { |
||||
RegisterHotKey $atom $modifiers $vk |
||||
} onerror {} { |
||||
GlobalDeleteAtom $atom; # Undo above AddAtom |
||||
rethrow |
||||
} |
||||
set _hotkeys($atom) [list $script]; # Replace previous script |
||||
return $atom |
||||
} |
||||
|
||||
proc twapi::unregister_hotkey {atom} { |
||||
variable _hotkeys |
||||
if {[info exists _hotkeys($atom)]} { |
||||
UnregisterHotKey $atom |
||||
GlobalDeleteAtom $atom |
||||
unset _hotkeys($atom) |
||||
} |
||||
} |
||||
|
||||
|
||||
# Simulate clicking a mouse button |
||||
proc twapi::click_mouse_button {button} { |
||||
switch -exact -- $button { |
||||
1 - |
||||
left { set down -ldown ; set up -lup} |
||||
2 - |
||||
right { set down -rdown ; set up -rup} |
||||
3 - |
||||
middle { set down -mdown ; set up -mup} |
||||
x1 { set down -x1down ; set up -x1up} |
||||
x2 { set down -x2down ; set up -x2up} |
||||
default {error "Invalid mouse button '$button' specified"} |
||||
} |
||||
|
||||
send_input [list \ |
||||
[list mouse 0 0 $down] \ |
||||
[list mouse 0 0 $up]] |
||||
return |
||||
} |
||||
|
||||
# Simulate mouse movement |
||||
proc twapi::move_mouse {xpos ypos {mode ""}} { |
||||
# If mouse trails are enabled, it leaves traces when the mouse is |
||||
# moved and does not clear them until mouse is moved again. So |
||||
# we temporarily disable mouse trails if we can |
||||
|
||||
if {[llength [info commands ::twapi::get_system_parameters_info]] != 0} { |
||||
set trail [get_system_parameters_info SPI_GETMOUSETRAILS] |
||||
set_system_parameters_info SPI_SETMOUSETRAILS 0 |
||||
} |
||||
switch -exact -- $mode { |
||||
-relative { |
||||
lappend cmd -relative |
||||
lassign [GetCursorPos] curx cury |
||||
incr xpos $curx |
||||
incr ypos $cury |
||||
} |
||||
-absolute - |
||||
"" { } |
||||
default { error "Invalid mouse movement mode '$mode'" } |
||||
} |
||||
|
||||
SetCursorPos $xpos $ypos |
||||
|
||||
# Restore trail setting if we had disabled it and it was originally enabled |
||||
if {[info exists trail] && $trail} { |
||||
set_system_parameters_info SPI_SETMOUSETRAILS $trail |
||||
} |
||||
} |
||||
|
||||
# Simulate turning of the mouse wheel |
||||
proc twapi::turn_mouse_wheel {wheelunits} { |
||||
send_input [list [list mouse 0 0 -relative -wheel $wheelunits]] |
||||
return |
||||
} |
||||
|
||||
# Get the mouse/cursor position |
||||
proc twapi::get_mouse_location {} { |
||||
return [GetCursorPos] |
||||
} |
||||
|
||||
proc twapi::get_input_idle_time {} { |
||||
# The formats are to convert wrapped 32bit signed to unsigned |
||||
set last_event [format 0x%x [GetLastInputInfo]] |
||||
set now [format 0x%x [GetTickCount]] |
||||
|
||||
# Deal with wrap around |
||||
if {$now >= $last_event} { |
||||
return [expr {$now - $last_event}] |
||||
} else { |
||||
return [expr {$now + (0xffffffff - $last_event) + 1}] |
||||
} |
||||
} |
||||
|
||||
# Initialize the virtual key table |
||||
proc twapi::_init_vk_map {} { |
||||
variable vk_map |
||||
|
||||
if {![info exists vk_map]} { |
||||
# Map tokens to VK_* key codes |
||||
array set vk_map { |
||||
BACK {0x08 0} |
||||
BACKSPACE {0x08 0} BS {0x08 0} BKSP {0x08 0} TAB {0x09 0} |
||||
CLEAR {0x0C 0} RETURN {0x0D 0} ENTER {0x0D 0} SHIFT {0x10 0} |
||||
CONTROL {0x11 0} MENU {0x12 0} ALT {0x12 0} PAUSE {0x13 0} |
||||
BREAK {0x13 0} CAPITAL {0x14 0} CAPSLOCK {0x14 0} |
||||
KANA {0x15 0} HANGEUL {0x15 0} HANGUL {0x15 0} JUNJA {0x17 0} |
||||
FINAL {0x18 0} HANJA {0x19 0} KANJI {0x19 0} ESCAPE {0x1B 0} |
||||
ESC {0x1B 0} CONVERT {0x1C 0} NONCONVERT {0x1D 0} |
||||
ACCEPT {0x1E 0} MODECHANGE {0x1F 0} SPACE {0x20 0} |
||||
PRIOR {0x21 0} PGUP {0x21 0} NEXT {0x22 0} PGDN {0x22 0} |
||||
END {0x23 0} HOME {0x24 0} LEFT {0x25 0} UP {0x26 0} |
||||
RIGHT {0x27 0} DOWN {0x28 0} SELECT {0x29 0} |
||||
PRINT {0x2A 0} PRTSC {0x2C 0} EXECUTE {0x2B 0} |
||||
SNAPSHOT {0x2C 0} INSERT {0x2D 0} INS {0x2D 0} |
||||
DELETE {0x2E 0} DEL {0x2E 0} HELP {0x2F 0} LWIN {0x5B 0} |
||||
RWIN {0x5C 0} APPS {0x5D 0} SLEEP {0x5F 0} NUMPAD0 {0x60 0} |
||||
NUMPAD1 {0x61 0} NUMPAD2 {0x62 0} NUMPAD3 {0x63 0} |
||||
NUMPAD4 {0x64 0} NUMPAD5 {0x65 0} NUMPAD6 {0x66 0} |
||||
NUMPAD7 {0x67 0} NUMPAD8 {0x68 0} NUMPAD9 {0x69 0} |
||||
MULTIPLY {0x6A 0} ADD {0x6B 0} SEPARATOR {0x6C 0} |
||||
SUBTRACT {0x6D 0} DECIMAL {0x6E 0} DIVIDE {0x6F 0} |
||||
F1 {0x70 0} F2 {0x71 0} F3 {0x72 0} F4 {0x73 0} |
||||
F5 {0x74 0} F6 {0x75 0} F7 {0x76 0} F8 {0x77 0} |
||||
F9 {0x78 0} F10 {0x79 0} F11 {0x7A 0} F12 {0x7B 0} |
||||
F13 {0x7C 0} F14 {0x7D 0} F15 {0x7E 0} F16 {0x7F 0} |
||||
F17 {0x80 0} F18 {0x81 0} F19 {0x82 0} F20 {0x83 0} |
||||
F21 {0x84 0} F22 {0x85 0} F23 {0x86 0} F24 {0x87 0} |
||||
NUMLOCK {0x90 0} SCROLL {0x91 0} SCROLLLOCK {0x91 0} |
||||
LSHIFT {0xA0 0} RSHIFT {0xA1 0 -extended} LCONTROL {0xA2 0} |
||||
RCONTROL {0xA3 0 -extended} LMENU {0xA4 0} LALT {0xA4 0} |
||||
RMENU {0xA5 0 -extended} RALT {0xA5 0 -extended} |
||||
BROWSER_BACK {0xA6 0} BROWSER_FORWARD {0xA7 0} |
||||
BROWSER_REFRESH {0xA8 0} BROWSER_STOP {0xA9 0} |
||||
BROWSER_SEARCH {0xAA 0} BROWSER_FAVORITES {0xAB 0} |
||||
BROWSER_HOME {0xAC 0} VOLUME_MUTE {0xAD 0} |
||||
VOLUME_DOWN {0xAE 0} VOLUME_UP {0xAF 0} |
||||
MEDIA_NEXT_TRACK {0xB0 0} MEDIA_PREV_TRACK {0xB1 0} |
||||
MEDIA_STOP {0xB2 0} MEDIA_PLAY_PAUSE {0xB3 0} |
||||
LAUNCH_MAIL {0xB4 0} LAUNCH_MEDIA_SELECT {0xB5 0} |
||||
LAUNCH_APP1 {0xB6 0} LAUNCH_APP2 {0xB7 0} |
||||
} |
||||
} |
||||
} |
||||
|
||||
# Find the next token from a send_keys argument |
||||
# Returns pair token,position after token |
||||
proc twapi::_parse_send_key_token {keys start} { |
||||
set char [string index $keys $start] |
||||
if {$char ne "\{"} { |
||||
return [list $char [incr start]] |
||||
} |
||||
# Need to find the matching end brace. Note special case of |
||||
# start/end brace enclosed within braces |
||||
set n [string length $keys] |
||||
# Jump past brace and succeeding character (which may be end brace) |
||||
set terminator [string first "\}" $keys $start+2] |
||||
if {$terminator < 0} { |
||||
error "Unterminated or empty braced key token." |
||||
} |
||||
return [list [string range $keys $start $terminator] [incr terminator]] |
||||
} |
||||
|
||||
# Appends to inputs the trailer in reverse order. trailer is reset |
||||
proc twapi::_flush_send_keys_trailer {vinputs vtrailer} { |
||||
upvar 1 $vinputs inputs |
||||
upvar 1 $vtrailer trailer |
||||
|
||||
lappend inputs {*}[lreverse $trailer] |
||||
set trailer {} |
||||
} |
||||
|
||||
# Constructs a list of input events by parsing a string in the format |
||||
# used by Visual Basic's SendKeys function. See that documentation |
||||
# for syntax. |
||||
proc twapi::_parse_send_keys {keys} { |
||||
variable vk_map |
||||
|
||||
_init_vk_map |
||||
array set modifier_vk {+ 0x10 ^ 0x11 % 0x12} |
||||
|
||||
# Array state holds state of the parse. An atom refers to a single |
||||
# character or a () group. |
||||
# modifiers - list of current modifiers in order they were added including |
||||
# those coming from containing groups. |
||||
# group_modifiers - stack of modifiers state when parsing groups. |
||||
# When a group begins, state(modifiers) is pushed on this stack. |
||||
# The top of the stack is used to initialize state(modifiers) |
||||
# for every atom within the group. When the group ends, |
||||
# the top of the stack is popped and discarded and state(modifiers) |
||||
# is reinitialized to new top of stack. |
||||
# trailer - list of trailing input records to add after next atom. Note |
||||
# these are stored in order of occurence but need to be reversed |
||||
# when emitted |
||||
# group_trailers - stack of trailers to add after group ends. Each |
||||
# element is a trailer which is a list of input records. |
||||
# cleanup_trailer - to be emitted right at the end if we have to |
||||
# reset CAPSLOCK/NUMLOCK/SCROLL |
||||
set state(modifiers) {} |
||||
set state(group_modifiers) [list $state(modifiers)]; # "Global" group |
||||
set state(trailer) {} |
||||
set state(group_trailers) {} |
||||
set state(cleanup_trailer) {} |
||||
|
||||
set inputs {} |
||||
|
||||
# If {CAPS,NUM,SCROLL}LOCK are set, need to reset them and then |
||||
# set them back |
||||
foreach vk {20 144 145} { |
||||
if {[GetKeyState $vk]} { |
||||
lappend inputs [list key $vk 0] |
||||
lappend state(cleanup_trailer) [list key $vk 0] |
||||
} |
||||
} |
||||
|
||||
set keyslen [string length $keys] |
||||
set pos 0; # Current parse position |
||||
while {$pos < $keyslen} { |
||||
lassign [_parse_send_key_token $keys $pos] token pos |
||||
switch -exact -- $token { |
||||
+ - |
||||
^ - |
||||
% { |
||||
if {$token in $state(modifiers)} { |
||||
# Following VB SendKeys |
||||
error "Modifier state for $token already set." |
||||
} |
||||
lappend state(modifiers) $token |
||||
lappend inputs [list keydown $modifier_vk($token) 0] |
||||
lappend state(trailer) [list keyup $modifier_vk($token) 0] |
||||
} |
||||
"(" { |
||||
# Start a group |
||||
lappend state(group_modifiers) $state(modifiers) |
||||
lappend state(group_trailers) $state(trailer) |
||||
set state(trailer) {} |
||||
} |
||||
")" { |
||||
# Terminates group. Illegal if no group collection in progress |
||||
if {[llength $state(group_trailers)] == 0} { |
||||
error "Unmatched \")\" in send_keys string." |
||||
} |
||||
# If there is a live trailer inside group, emit it e.g. +(ab^) |
||||
_flush_send_keys_trailer inputs state(trailer) |
||||
# Now emit the group trailer |
||||
set trailer [lpop state(group_trailers)] |
||||
_flush_send_keys_trailer inputs trailer |
||||
# Discard the initial modifier state for this group |
||||
lpop state(group_modifiers) |
||||
# Set the current modifiers to outer group state |
||||
set state(modifiers) [lindex $state(group_modifiers) end] |
||||
} |
||||
default { |
||||
if {$token eq "~"} { |
||||
set token "{ENTER}" |
||||
} |
||||
# May be a single character to send, a braced virtual key |
||||
# or a braced single char with count |
||||
if {[string length $token] == 1} { |
||||
# Single character. |
||||
set key $token |
||||
set nch 1 |
||||
} elseif {[string index $token 0] eq "\{"} { |
||||
# NOTE: a ~ inside a brace is treated as a literal ~ |
||||
# and not the ENTER key |
||||
# Look for space skipping the starting brace and following |
||||
# character which may be itself a space (to be repeated) |
||||
set space_pos [string first " " $token 2] |
||||
if {$space_pos < 0} { |
||||
# No space found |
||||
set nch 1 |
||||
set key [string range $token 1 end-1] |
||||
} else { |
||||
# A key followed by a count |
||||
# Note space_pos >= 2 |
||||
set key [string range $token 1 $space_pos-1] |
||||
set nch [string trim [string range $token $space_pos+1 end-1]] |
||||
if {![string is integer -strict $nch] || $nch < 0} { |
||||
error "Invalid count \"$nch\" in send_keys." |
||||
} |
||||
} |
||||
} else { |
||||
# Problem in token parsing. Would be a bug. |
||||
error "Internal error: invalid token \"$token\" parsing send_keys string." |
||||
} |
||||
|
||||
set vk_leader {} |
||||
set vk_trailer {} |
||||
if {[string length $key] == 1} { |
||||
# Single character |
||||
lassign [VkKeyScan $key] modifiers vk |
||||
if {$modifiers == -1 || $vk == -1} { |
||||
scan $key %c code_point |
||||
set vk_rec [list unicode 0 $code_point] |
||||
} else { |
||||
# Generates input records for modifiers that are set |
||||
# unless they are already set. NOTE: Do NOT set the |
||||
# state(modifier) state since they will be in effect |
||||
# only for the current character. This is for correctly |
||||
# showing A-Z with shift and Ctrl-A etc. with control. |
||||
if {($modifiers & 0x1) && ("+" ni $state(modifiers))} { |
||||
lappend vk_leader [list keydown 0x10 0] |
||||
lappend vk_trailer [list keyup 0x10 0] |
||||
} |
||||
if {($modifiers & 0x2) && ("^" ni $state(modifiers))} { |
||||
lappend vk_leader [list keydown 0x11 0] |
||||
lappend vk_trailer [list keyup 0x11 0] |
||||
} |
||||
|
||||
if {($modifiers & 0x4) && ("%" ni $state(modifiers))} { |
||||
lappend vk_leader [list keydown 0x12 0] |
||||
lappend vk_trailer [list keyup 0x12 0] |
||||
} |
||||
set vk_rec [list key $vk 0] |
||||
} |
||||
} else { |
||||
# Virtual key string. Note modifiers ignored here |
||||
# as for VB SendKeys |
||||
if {[info exists vk_map($key)]} { |
||||
# Virtual key |
||||
set vk_rec [list key {*}$vk_map($key)] |
||||
} else { |
||||
error "Unknown braced virtual key \"$token\"." |
||||
} |
||||
} |
||||
lappend inputs {*}$vk_leader |
||||
lappend inputs {*}[lrepeat $nch $vk_rec] |
||||
# vk_trailer arises from the character itself, e.g. A |
||||
# has shift set, Ctrl-A has control set. |
||||
_flush_send_keys_trailer inputs vk_trailer |
||||
# state(trailer) arises from preceding +,^,% This is also |
||||
# emitted and reset as it applied only to this character |
||||
_flush_send_keys_trailer inputs state(trailer) |
||||
set state(modifiers) [lindex $state(group_modifiers) end] |
||||
} |
||||
} |
||||
} |
||||
# Emit left over trailer |
||||
_flush_send_keys_trailer inputs state(trailer) |
||||
|
||||
# Restore capslock/numlock |
||||
_flush_send_keys_trailer inputs state(cleanup_trailer) |
||||
|
||||
return $inputs |
||||
} |
||||
|
||||
# utility procedure to map symbolic hotkey to {modifiers virtualkey} |
||||
# We allow modifier map to be passed in because different api's use |
||||
# different bits for key modifiers |
||||
proc twapi::_hotkeysyms_to_vk {hotkey {modifier_map {ctrl 2 control 2 alt 1 menu 1 shift 4 win 8}}} { |
||||
variable vk_map |
||||
|
||||
_init_vk_map |
||||
|
||||
set keyseq [split [string tolower $hotkey] -] |
||||
set key [lindex $keyseq end] |
||||
|
||||
# Convert modifiers to bitmask |
||||
set modifiers 0 |
||||
foreach modifier [lrange $keyseq 0 end-1] { |
||||
setbits modifiers [dict! $modifier_map [string tolower $modifier]] |
||||
} |
||||
# Map the key to a virtual key code |
||||
if {[string length $key] == 1} { |
||||
# Single character |
||||
scan $key %c unicode |
||||
|
||||
# Only allow alphanumeric keys and a few punctuation symbols |
||||
# since keyboard layouts are not standard |
||||
if {$unicode >= 0x61 && $unicode <= 0x7A} { |
||||
# Lowercase letters - change to upper case virtual keys |
||||
set vk [expr {$unicode-32}] |
||||
} elseif {($unicode >= 0x30 && $unicode <= 0x39) |
||||
|| ($unicode >= 0x41 && $unicode <= 0x5A)} { |
||||
# Digits or upper case |
||||
set vk $unicode |
||||
} else { |
||||
error "Only alphanumeric characters may be specified for the key. For non-alphanumeric characters, specify the virtual key code" |
||||
} |
||||
} elseif {[info exists vk_map($key)]} { |
||||
# It is a virtual key name |
||||
set vk [lindex $vk_map($key) 0] |
||||
} elseif {[info exists vk_map([string toupper $key])]} { |
||||
# It is a virtual key name |
||||
set vk [lindex $vk_map([string toupper $key]) 0] |
||||
} elseif {[string is integer -strict $key]} { |
||||
# Actual virtual key specification |
||||
set vk $key |
||||
} else { |
||||
error "Unknown or invalid key specifier '$key'" |
||||
} |
||||
|
||||
return [list $modifiers $vk] |
||||
} |
||||
@ -0,0 +1,605 @@
|
||||
# MeTOO stands for "MeTOO Emulates TclOO" (at a superficial syntactic level) |
||||
# |
||||
# Implements a *tiny*, but useful, subset of TclOO, primarily for use |
||||
# with Tcl 8.4. Intent is that if you write code using MeToo, it should work |
||||
# unmodified with TclOO in 8.5/8.6. Obviously, don't try going the other way! |
||||
# |
||||
# Emulation is superficial, don't try to be too clever in usage. |
||||
# Doing funky, or even non-funky, things with object namespaces will |
||||
# not work as you would expect. |
||||
# |
||||
# See the metoo::demo proc for sample usage. Calling this proc |
||||
# with parameter "oo" will use the TclOO commands. Else the metoo:: |
||||
# commands. Note the demo code remains the same for both. |
||||
# |
||||
# The following fragment uses MeToo only if TclOO is not available: |
||||
# if {[llength [info commands oo::*]]} { |
||||
# namespace import oo::* |
||||
# } else { |
||||
# source metoo.tcl |
||||
# namespace import metoo::class |
||||
# } |
||||
# class create C {...} |
||||
# |
||||
# Summary of the TclOO subset implemented - see TclOO docs for detail : |
||||
# |
||||
# Creating a new class: |
||||
# metoo::class create CLASSNAME CLASSDEFINITION |
||||
# |
||||
# Destroying a class: |
||||
# CLASSNAME destroy |
||||
# - this also destroys objects of that class and recursively destroys |
||||
# child classes. NOTE: deleting the class namespace or renaming |
||||
# the CLASSNAME command to "" will NOT call object destructors. |
||||
# |
||||
# CLASSDEFINITION: Following may appear in CLASSDEFINTION |
||||
# method METHODNAME params METHODBODY |
||||
# - same as TclOO |
||||
# constructor params METHODBODY |
||||
# - same syntax as TclOO |
||||
# destructor METHODBODY |
||||
# - same syntax as TclOO |
||||
# unknown METHODNAME ARGS |
||||
# - if defined, called when an undefined method is invoked |
||||
# superclass SUPER |
||||
# - inherits from SUPER. Unlike TclOO, only single inheritance. Also |
||||
# no checks for inheritance loops. You'll find out quickly enough! |
||||
# All other commands within a CLASSDEFINITION will either raise error or |
||||
# work differently from TclOO. Actually you can use pretty much any |
||||
# Tcl command inside CLASSDEFINITION but the results may not be what you |
||||
# expect. Best to avoid this. |
||||
# |
||||
# METHODBODY: The following method-internal TclOO commands are available: |
||||
# my METHODNAME ARGS |
||||
# - to call another method METHODNAME |
||||
# my variable VAR1 ?VAR2...? |
||||
# - brings object-specific variables into scope |
||||
# next ?ARGS? |
||||
# - calls the superclass method of the same name |
||||
# self |
||||
# self object |
||||
# - returns the object name (usable as a command) |
||||
# self class |
||||
# - returns class of this object |
||||
# self namespace |
||||
# - returns namespace of this object |
||||
# |
||||
# Creating objects: |
||||
# CLASSNAME create OBJNAME ?ARGS? |
||||
# - creates object OBJNAME of class CLASSNAME, passing ARGS to constructor |
||||
# Returns the fully qualified object name that can be used as a command. |
||||
# CLASSNAME new ?ARGS? |
||||
# - creates a new object with an auto-generated name |
||||
# |
||||
# Destroying objects |
||||
# OBJNAME destroy |
||||
# - destroys the object calling destructors |
||||
# rename OBJNAME "" |
||||
# - same as above |
||||
# |
||||
# Renaming an object |
||||
# rename OBJNAME NEWNAME |
||||
# - the object can now be invoked using the new name. Note this is unlike |
||||
# classes which should not be renamed. |
||||
# |
||||
# |
||||
# Introspection (though different from TclOO) |
||||
# metoo::introspect object isa OBJECT ?CLASSNAME? |
||||
# - returns 1 if OBJECT is a metoo object and is of the specified class |
||||
# if CLASSNAME is specified. Returns 0 otherwise. |
||||
# metoo::introspect object list |
||||
# - returns list of all objects |
||||
# metoo::introspect class ancestors CLASSNAME |
||||
# - returns list of ancestors for a class |
||||
# |
||||
# Differences and missing features from TclOO: Everything not listed above |
||||
# is missing. Some notable differences: |
||||
# - MeTOO is class-based, not object based like TclOO, thus class instances |
||||
# (objects) cannot be modified by adding instance-specific methods etc.. |
||||
# Also a class is not itself an object. |
||||
# - Renaming classes does not work and will fail in mysterious ways |
||||
# - does not support class refinement/definition |
||||
# - no variable command at class level for automatically bringing variables |
||||
# into scope |
||||
# - no filters, forwarding, multiple-inheritance |
||||
# - no private methods (all methods are exported). |
||||
|
||||
# NOTE: file must be sourced at global level since metoo namespace is expected |
||||
# to be top level namespace |
||||
|
||||
# DO NOT DO THIS. ELSE TESTS FAIL BECAUSE they define tests in the |
||||
# metoo namespace which then get deleted by the line below when |
||||
# the package is lazy auto-loaded |
||||
# catch {namespace delete metoo} |
||||
|
||||
# TBD - variable ("my variable" is done, "variable" in method or |
||||
# class definition is not) |
||||
# TBD - default constructor and destructor to "next" (or maybe that |
||||
# is already taken care of by the inheritance code |
||||
|
||||
namespace eval metoo { |
||||
variable next_id 0 |
||||
|
||||
variable _objects; # Maps objects to its namespace |
||||
array set _objects {} |
||||
|
||||
} |
||||
|
||||
# Namespace in which commands in a class definition block are called |
||||
namespace eval metoo::define { |
||||
proc method {class_ns name params body} { |
||||
# Methods are defined in the methods subspace of the class namespace. |
||||
# We prefix with _m_ to prevent them from being directly called |
||||
# as procs, for example if the method is a Tcl command like "set" |
||||
# The first parameter to a method is always the object namespace |
||||
# denoted as the paramter "_this" |
||||
namespace eval ${class_ns}::methods [list proc _m_$name [concat [list _this] $params] $body] |
||||
|
||||
} |
||||
proc superclass {class_ns superclass} { |
||||
if {[info exists ${class_ns}::super]} { |
||||
error "Only one superclass allowed for a class" |
||||
} |
||||
set sup [uplevel 3 "namespace eval $superclass {namespace current}"] |
||||
set ${class_ns}::super $sup |
||||
# We store the subclass in the super so it can be destroyed |
||||
# if the super is destroyed. |
||||
set ${sup}::subclasses($class_ns) 1 |
||||
} |
||||
proc constructor {class_ns params body} { |
||||
method $class_ns constructor $params $body |
||||
} |
||||
proc destructor {class_ns body} { |
||||
method $class_ns destructor {} $body |
||||
} |
||||
proc export {args} { |
||||
# Nothing to do, all methods are exported anyways |
||||
# Command is here for compatibility only |
||||
} |
||||
} |
||||
|
||||
# Namespace in which commands used in objects methods are defined |
||||
# (self, my etc.) |
||||
namespace eval metoo::object { |
||||
proc next {args} { |
||||
upvar 1 _this this; # object namespace |
||||
|
||||
# Figure out what class context this is executing in. Note |
||||
# we cannot use _this in caller since that is the object namespace |
||||
# which is not necessarily related to the current class namespace. |
||||
set class_ns [namespace parent [uplevel 1 {namespace current}]] |
||||
|
||||
# Figure out the current method being called |
||||
set methodname [namespace tail [lindex [uplevel 1 {info level 0}] 0]] |
||||
|
||||
# Find the next method in the class hierarchy and call it |
||||
while {[info exists ${class_ns}::super]} { |
||||
set class_ns [set ${class_ns}::super] |
||||
if {[llength [info commands ${class_ns}::methods::$methodname]]} { |
||||
return [uplevel 1 [list ${class_ns}::methods::$methodname $this] $args] |
||||
} |
||||
} |
||||
|
||||
error "'next' command has no receiver in the hierarchy for method $methodname" |
||||
} |
||||
|
||||
proc self {{what object}} { |
||||
upvar 1 _this this |
||||
switch -exact -- $what { |
||||
class { return [namespace parent $this] } |
||||
namespace { return $this } |
||||
object { return [set ${this}::_(name)] } |
||||
default { |
||||
error "Argument '$what' not understood by self method" |
||||
} |
||||
} |
||||
} |
||||
|
||||
proc my {methodname args} { |
||||
# We insert the object namespace as the first parameter to the command. |
||||
# This is passed as the first parameter "_this" to methods. Since |
||||
# "my" can be only called from methods, we can retrieve it fro |
||||
# our caller. |
||||
upvar 1 _this this; # object namespace |
||||
|
||||
set class_ns [namespace parent $this] |
||||
|
||||
set meth [::metoo::_locate_method $class_ns $methodname] |
||||
if {$meth ne ""} { |
||||
# We need to invoke in the caller's context so upvar etc. will |
||||
# not be affected by this intermediate method dispatcher |
||||
return [uplevel 1 [list $meth $this] $args] |
||||
} |
||||
|
||||
# It is ok for constructor or destructor to be undefined. For |
||||
# the others, invoke "unknown" if it exists |
||||
if {$methodname eq "constructor" || $methodname eq "destructor"} { |
||||
return |
||||
} |
||||
|
||||
set meth [::metoo::_locate_method $class_ns "unknown"] |
||||
if {$meth ne ""} { |
||||
# We need to invoke in the caller's context so upvar etc. will |
||||
# not be affected by this intermediate method dispatcher |
||||
return [uplevel 1 [list $meth $this $methodname] $args] |
||||
} |
||||
|
||||
error "Unknown method $methodname" |
||||
} |
||||
} |
||||
|
||||
# Given a method name, locate it in the class hierarchy. Returns |
||||
# fully qualified method if found, else an empty string |
||||
proc metoo::_locate_method {class_ns methodname} { |
||||
# See if there is a method defined in this class. |
||||
# Breakage if method names with wildcard chars. Too bad |
||||
if {[llength [info commands ${class_ns}::methods::_m_$methodname]]} { |
||||
# We need to invoke in the caller's context so upvar etc. will |
||||
# not be affected by this intermediate method dispatcher |
||||
return ${class_ns}::methods::_m_$methodname |
||||
} |
||||
|
||||
# No method here, check for super class. |
||||
while {[info exists ${class_ns}::super]} { |
||||
set class_ns [set ${class_ns}::super] |
||||
if {[llength [info commands ${class_ns}::methods::_m_$methodname]]} { |
||||
return ${class_ns}::methods::_m_$methodname |
||||
} |
||||
} |
||||
|
||||
return ""; # Not found |
||||
} |
||||
|
||||
proc metoo::_new {class_ns cmd args} { |
||||
# class_ns expected to be fully qualified |
||||
variable next_id |
||||
|
||||
# IMPORTANT: |
||||
# object namespace *must* be child of class namespace. |
||||
# Saves a bit of bookkeeping. Putting it somewhere else will require |
||||
# changes to many other places in the code. |
||||
set objns ${class_ns}::o#[incr next_id] |
||||
|
||||
switch -exact -- $cmd { |
||||
create { |
||||
if {[llength $args] < 1} { |
||||
error "Insufficient args, should be: class create CLASSNAME ?args?" |
||||
} |
||||
# TBD - check if command already exists |
||||
# Note objname must always be fully qualified. Note cannot |
||||
# use namespace which here because the commmand does not |
||||
# yet exist. |
||||
set args [lassign $args objname] |
||||
if {[string compare :: [string range $objname 0 1]]} { |
||||
# Not fully qualified. Qualify based on caller namespace |
||||
set objname [uplevel 1 "namespace current"]::$objname |
||||
} |
||||
# Trip excess ":" - can happen in both above cases |
||||
set objname ::[string trimleft $objname :] |
||||
} |
||||
new { |
||||
set objname $objns |
||||
} |
||||
default { |
||||
error "Unknown command '$cmd'. Should be create or new." |
||||
} |
||||
} |
||||
|
||||
# Create the namespace. The array _ is used to hold private information |
||||
namespace eval $objns { |
||||
variable _ |
||||
} |
||||
set ${objns}::_(name) $objname |
||||
|
||||
# When invoked by its name, call the dispatcher. |
||||
interp alias {} $objname {} ${class_ns}::_call $objns |
||||
|
||||
# Register the object. We do this BEFORE running the constructor |
||||
variable _objects |
||||
set _objects($objname) $objns |
||||
|
||||
# Invoke the constructor |
||||
if {[catch { |
||||
$objname constructor {*}$args |
||||
} msg]} { |
||||
# Undo what we did |
||||
set erinfo $::errorInfo |
||||
set ercode $::errorCode |
||||
rename $objname "" |
||||
namespace delete $objns |
||||
error $msg $erinfo $ercode |
||||
} |
||||
|
||||
# TBD - does tracing cause a slowdown ? |
||||
# Set up trace to track when the object is renamed/destroyed |
||||
trace add command $objname {rename delete} [list [namespace current]::_trace_object_renames $objns] |
||||
|
||||
return $objname |
||||
} |
||||
|
||||
proc metoo::_trace_object_renames {objns oldname newname op} { |
||||
# Note the trace command fully qualifies oldname and newname |
||||
if {$op eq "rename"} { |
||||
variable _objects |
||||
set _objects($newname) $_objects($oldname) |
||||
unset _objects($oldname) |
||||
set ${objns}::_(name) $newname |
||||
} else { |
||||
$oldname destroy |
||||
} |
||||
} |
||||
|
||||
proc metoo::_class_cmd {class_ns cmd args} { |
||||
switch -exact -- $cmd { |
||||
create - |
||||
new { |
||||
return [uplevel 1 [list [namespace current]::_new $class_ns $cmd] $args] |
||||
} |
||||
destroy { |
||||
# Destroy all objects belonging to this class |
||||
foreach objns [namespace children ${class_ns} o#*] { |
||||
[set ${objns}::_(name)] destroy |
||||
} |
||||
# Destroy all classes that inherit from this |
||||
foreach child_ns [array names ${class_ns}::subclasses] { |
||||
# Child namespace is also subclass command |
||||
$child_ns destroy |
||||
} |
||||
trace remove command $class_ns {rename delete} [list ::metoo::_trace_class_renames] |
||||
namespace delete ${class_ns} |
||||
rename ${class_ns} "" |
||||
} |
||||
default { |
||||
error "Unknown command '$cmd'. Should be create, new or destroy." |
||||
} |
||||
} |
||||
} |
||||
|
||||
proc metoo::class {cmd cname definition} { |
||||
variable next_id |
||||
|
||||
if {$cmd ne "create"} { |
||||
error "Syntax: class create CLASSNAME DEFINITION" |
||||
} |
||||
|
||||
if {[uplevel 1 "namespace exists $cname"]} { |
||||
error "can't create class '$cname': namespace already exists with that name." |
||||
} |
||||
|
||||
# Resolve cname into a namespace in the caller's context |
||||
set class_ns [uplevel 1 "namespace eval $cname {namespace current}"] |
||||
|
||||
if {[llength [info commands $class_ns]]} { |
||||
# Delete the namespace we just created |
||||
namespace delete $class_ns |
||||
error "can't create class '$cname': command already exists with that name." |
||||
} |
||||
|
||||
# Define the commands/aliases that are used inside a class definition |
||||
foreach procname [info commands [namespace current]::define::*] { |
||||
interp alias {} ${class_ns}::[namespace tail $procname] {} $procname $class_ns |
||||
} |
||||
|
||||
# Define the built in commands callable within class instance methods |
||||
foreach procname [info commands [namespace current]::object::*] { |
||||
interp alias {} ${class_ns}::methods::[namespace tail $procname] {} $procname |
||||
} |
||||
|
||||
# Define the destroy method for the class object instances |
||||
namespace eval $class_ns { |
||||
method destroy {} { |
||||
set retval [my destructor] |
||||
# Remove trace on command rename/deletion. |
||||
# ${_this}::_(name) contains the object's current name on |
||||
# which the trace is set. |
||||
set me [set ${_this}::_(name)] |
||||
trace remove command $me {rename delete} [list ::metoo::_trace_object_renames $_this] |
||||
rename $me "" |
||||
unset -nocomplain ::metoo::_objects($me) |
||||
namespace delete $_this |
||||
return $retval |
||||
} |
||||
method variable {args} { |
||||
if {[llength $args]} { |
||||
set cmd [list upvar 0] |
||||
foreach varname $args { |
||||
lappend cmd ${_this}::$varname $varname |
||||
} |
||||
uplevel 1 $cmd |
||||
} |
||||
} |
||||
} |
||||
|
||||
# Define the class. Note we do this *after* the standard |
||||
# definitions (destroy etc.) above so that they can |
||||
# be overridden by the class definition. |
||||
if {[catch { |
||||
namespace eval $class_ns $definition |
||||
} msg ]} { |
||||
namespace delete $class_ns |
||||
error $msg $::errorInfo $::errorCode |
||||
} |
||||
|
||||
# Also define the call dispatcher within the class. |
||||
# TBD - not sure this is actually necessary any more |
||||
namespace eval ${class_ns} { |
||||
proc _call {objns methodname args} { |
||||
# Note this duplicates the "my" code but cannot call that as |
||||
# it adds another frame level which interferes with uplevel etc. |
||||
|
||||
set class_ns [namespace parent $objns] |
||||
|
||||
# We insert the object namespace as the first param to the command. |
||||
# This is passed as the first parameter "_this" to methods. |
||||
|
||||
set meth [::metoo::_locate_method $class_ns $methodname] |
||||
if {$meth ne ""} { |
||||
# We need to invoke in the caller's context so upvar etc. will |
||||
# not be affected by this intermediate method dispatcher |
||||
return [uplevel 1 [list $meth $objns] $args] |
||||
} |
||||
|
||||
# It is ok for constructor or destructor to be undefined. For |
||||
# the others, invoke "unknown" if it exists |
||||
|
||||
if {$methodname eq "constructor" || $methodname eq "destructor"} { |
||||
return |
||||
} |
||||
|
||||
set meth [::metoo::_locate_method $class_ns "unknown"] |
||||
if {$meth ne ""} { |
||||
# We need to invoke in the caller's context so upvar etc. will |
||||
# not be affected by this intermediate method dispatcher |
||||
return [uplevel 1 [list $meth $objns $methodname] $args] |
||||
} |
||||
|
||||
error "Unknown method $methodname" |
||||
} |
||||
} |
||||
|
||||
# The namespace is also a command used to create class instances |
||||
# TBD - check if command of that name already exists |
||||
interp alias {} $class_ns {} [namespace current]::_class_cmd $class_ns |
||||
# Set up trace to track when the class command is renamed/destroyed |
||||
trace add command $class_ns [list rename delete] ::metoo::_trace_class_renames |
||||
|
||||
return $class_ns |
||||
} |
||||
|
||||
proc metoo::_trace_class_renames {oldname newname op} { |
||||
if {$op eq "rename"} { |
||||
# TBD - this does not actually work. The rename succeeds anyways |
||||
error "MetOO classes may not be renamed" |
||||
} else { |
||||
$oldname destroy |
||||
} |
||||
} |
||||
|
||||
proc metoo::introspect {type info args} { |
||||
switch -exact -- $type { |
||||
"object" { |
||||
variable _objects |
||||
switch -exact -- $info { |
||||
"isa" { |
||||
if {[llength $args] == 0 || [llength $args] > 2} { |
||||
error "wrong # args: should be \"metoo::introspect $type $info OBJNAME ?CLASS?\"" |
||||
} |
||||
set objname [uplevel 1 [list namespace which -command [lindex $args 0]]] |
||||
if {![info exists _objects($objname)]} { |
||||
return 0 |
||||
} |
||||
if {[llength $args] == 1} { |
||||
# No class specified |
||||
return 1 |
||||
} |
||||
# passed classname assumed to be fully qualified |
||||
set objclass [namespace parent $_objects($objname)] |
||||
if {[string equal $objclass [lindex $args 1]]} { |
||||
# Direct hit |
||||
return 1 |
||||
} |
||||
|
||||
# No direct hit, check ancestors |
||||
if {[lindex $args 1] in [ancestors $objclass]} { |
||||
return 1 |
||||
} |
||||
|
||||
return 0 |
||||
} |
||||
|
||||
"list" { |
||||
if {[llength $args] > 1} { |
||||
error "wrong # args: should be \"metoo::introspect $type $info ?CLASS?" |
||||
} |
||||
variable _objects |
||||
if {[llength $args] == 0} { |
||||
return [array names _objects] |
||||
} |
||||
set objs {} |
||||
foreach obj [array names _objects] { |
||||
if {[introspect object isa $obj [lindex $args 0]]} { |
||||
lappend objs $obj |
||||
} |
||||
} |
||||
return $objs |
||||
} |
||||
default { |
||||
error "$info subcommand not supported for $type introspection" |
||||
} |
||||
} |
||||
} |
||||
|
||||
"class" { |
||||
switch -exact -- $info { |
||||
"ancestors" { |
||||
if {[llength $args] != 1} { |
||||
error "wrong # args: should be \"metoo::introspect $type $info CLASSNAME" |
||||
} |
||||
return [ancestors [lindex $args 0]] |
||||
} |
||||
default { |
||||
error "$info subcommand not supported for $type introspection" |
||||
} |
||||
} |
||||
} |
||||
default { |
||||
error "$type introspection not supported" |
||||
} |
||||
} |
||||
} |
||||
|
||||
proc metoo::ancestors {class_ns} { |
||||
# Returns ancestors of a class |
||||
|
||||
set ancestors [list ] |
||||
while {[info exists ${class_ns}::super]} { |
||||
lappend ancestors [set class_ns [set ${class_ns}::super]] |
||||
} |
||||
|
||||
return $ancestors |
||||
} |
||||
|
||||
namespace eval metoo { namespace export class } |
||||
|
||||
# Simple sample class showing all capabilities. Anything not shown here will |
||||
# probably not work. Call as "demo" to use metoo, or "demo oo" to use TclOO. |
||||
# Output should be same in both cases. |
||||
proc ::metoo::demo {{ns metoo}} { |
||||
${ns}::class create Base { |
||||
constructor {x y} { puts "Base constructor ([self object]): $x, $y" |
||||
} |
||||
method m {} { puts "Base::m called" } |
||||
method n {args} { puts "Base::n called: [join $args {, }]"; my m } |
||||
method unknown {methodname args} { puts "Base::unknown called for $methodname [join $args {, }]"} |
||||
destructor { puts "Base::destructor ([self object])" } |
||||
} |
||||
|
||||
${ns}::class create Derived { |
||||
superclass Base |
||||
constructor {x y} { puts "Derived constructor ([self object]): $x, $y" ; next $x $y } |
||||
destructor { puts "Derived::destructor called ([self object])" ; next } |
||||
method n {args} { puts "Derived::n ([self object]): [join $args {, }]"; next {*}$args} |
||||
method put {val} {my variable var ; set var $val} |
||||
method get {varname} {my variable var ; upvar 1 $varname retvar; set retvar $var} |
||||
} |
||||
|
||||
Base create b dum dee; # Create named object |
||||
Derived create d fee fi; # Create derived object |
||||
set o [Derived new fo fum]; # Create autonamed object |
||||
$o put 10; # Use of instance variable |
||||
$o get v; # Verify correct frame level ... |
||||
puts "v:$v"; # ...when calling methods |
||||
b m; # Direct method |
||||
b n; # Use of my to call another method |
||||
$o m; # Inherited method |
||||
$o n; # Overridden method chained to inherited |
||||
$o nosuchmethod arg1 arg2; # Invoke unknown |
||||
$o destroy; # Explicit destroy |
||||
rename b ""; # Destroy through rename |
||||
Base destroy; # Should destroy object d, Derived, Base |
||||
} |
||||
|
||||
# Hack to work with the various build configuration. |
||||
if {[info commands ::twapi::get_version] ne ""} { |
||||
package provide metoo [::twapi::get_version -patchlevel] |
||||
} |
||||
@ -0,0 +1,403 @@
|
||||
# |
||||
# Copyright (c) 2003-2018, Ashok P. Nadkarni |
||||
# All rights reserved. |
||||
# |
||||
# See the file LICENSE for license |
||||
|
||||
# Hack to work with the various build configuration. |
||||
if {[info commands ::twapi::get_version] ne ""} { |
||||
package provide twapi_msi [::twapi::get_version -patchlevel] |
||||
} |
||||
|
||||
# Rest of this file auto-generated |
||||
|
||||
|
||||
# Automatically generated type library interface |
||||
# File: msi.dll |
||||
# Name: WindowsInstaller |
||||
# GUID: {000C1092-0000-0000-C000-000000000046} |
||||
# Version: 1.0 |
||||
# LCID: 1033 |
||||
package require twapi_com |
||||
|
||||
namespace eval windowsinstaller { |
||||
|
||||
# Array mapping coclass names to their guids |
||||
variable _coclass_guids |
||||
|
||||
# Array mapping dispatch interface names to their guids |
||||
variable _dispatch_guids |
||||
|
||||
# Returns the GUID for a coclass or empty string if not found |
||||
proc coclass_guid {coclass_name} { |
||||
variable _coclass_guids |
||||
if {[info exists _coclass_guids($coclass_name)]} { |
||||
return $_coclass_guids($coclass_name) |
||||
} |
||||
return "" |
||||
} |
||||
# Returns the GUID for a dispatch name or empty string if not found |
||||
proc dispatch_guid {dispatch_name} { |
||||
variable _dispatch_guids |
||||
if {[info exists _dispatch_guids($dispatch_name)]} { |
||||
return $_dispatch_guids($dispatch_name) |
||||
} |
||||
return "" |
||||
} |
||||
# Marks the specified object to be of a specific dispatch/coclass type |
||||
proc declare {typename comobj} { |
||||
# First check if it is the name of a dispatch interface |
||||
set guid [dispatch_guid $typename] |
||||
if {$guid ne ""} { |
||||
$comobj -interfaceguid $guid |
||||
return |
||||
} |
||||
|
||||
# If not, check if it is the name of a coclass with a dispatch interface |
||||
set guid [coclass_guid $typename] |
||||
if {$guid ne ""} { |
||||
if {[info exists ::twapi::_coclass_idispatch_guids($guid)]} { |
||||
$comobj -interfaceguid $::twapi::_coclass_idispatch_guids($guid) |
||||
return |
||||
} |
||||
} |
||||
|
||||
error "Could not resolve interface for $coclass_name." |
||||
} |
||||
|
||||
# Enum MsiUILevel |
||||
array set MsiUILevel {msiUILevelNoChange 0 msiUILevelDefault 1 msiUILevelNone 2 msiUILevelBasic 3 msiUILevelReduced 4 msiUILevelFull 5 msiUILevelHideCancel 32 msiUILevelProgressOnly 64 msiUILevelEndDialog 128 msiUILevelSourceResOnly 256} |
||||
|
||||
# Enum MsiReadStream |
||||
array set MsiReadStream {msiReadStreamInteger 0 msiReadStreamBytes 1 msiReadStreamAnsi 2 msiReadStreamDirect 3} |
||||
|
||||
# Enum MsiRunMode |
||||
array set MsiRunMode {msiRunModeAdmin 0 msiRunModeAdvertise 1 msiRunModeMaintenance 2 msiRunModeRollbackEnabled 3 msiRunModeLogEnabled 4 msiRunModeOperations 5 msiRunModeRebootAtEnd 6 msiRunModeRebootNow 7 msiRunModeCabinet 8 msiRunModeSourceShortNames 9 msiRunModeTargetShortNames 10 msiRunModeWindows9x 12 msiRunModeZawEnabled 13 msiRunModeScheduled 16 msiRunModeRollback 17 msiRunModeCommit 18} |
||||
|
||||
# Enum MsiDatabaseState |
||||
array set MsiDatabaseState {msiDatabaseStateRead 0 msiDatabaseStateWrite 1} |
||||
|
||||
# Enum MsiViewModify |
||||
array set MsiViewModify {msiViewModifySeek -1 msiViewModifyRefresh 0 msiViewModifyInsert 1 msiViewModifyUpdate 2 msiViewModifyAssign 3 msiViewModifyReplace 4 msiViewModifyMerge 5 msiViewModifyDelete 6 msiViewModifyInsertTemporary 7 msiViewModifyValidate 8 msiViewModifyValidateNew 9 msiViewModifyValidateField 10 msiViewModifyValidateDelete 11} |
||||
|
||||
# Enum MsiColumnInfo |
||||
array set MsiColumnInfo {msiColumnInfoNames 0 msiColumnInfoTypes 1} |
||||
|
||||
# Enum MsiTransformError |
||||
array set MsiTransformError {msiTransformErrorNone 0 msiTransformErrorAddExistingRow 1 msiTransformErrorDeleteNonExistingRow 2 msiTransformErrorAddExistingTable 4 msiTransformErrorDeleteNonExistingTable 8 msiTransformErrorUpdateNonExistingRow 16 msiTransformErrorChangeCodePage 32 msiTransformErrorViewTransform 256} |
||||
|
||||
# Enum MsiEvaluateCondition |
||||
array set MsiEvaluateCondition {msiEvaluateConditionFalse 0 msiEvaluateConditionTrue 1 msiEvaluateConditionNone 2 msiEvaluateConditionError 3} |
||||
|
||||
# Enum MsiTransformValidation |
||||
array set MsiTransformValidation {msiTransformValidationNone 0 msiTransformValidationLanguage 1 msiTransformValidationProduct 2 msiTransformValidationPlatform 4 msiTransformValidationMajorVer 8 msiTransformValidationMinorVer 16 msiTransformValidationUpdateVer 32 msiTransformValidationLess 64 msiTransformValidationLessOrEqual 128 msiTransformValidationEqual 256 msiTransformValidationGreaterOrEqual 512 msiTransformValidationGreater 1024 msiTransformValidationUpgradeCode 2048} |
||||
|
||||
# Enum MsiDoActionStatus |
||||
array set MsiDoActionStatus {msiDoActionStatusNoAction 0 msiDoActionStatusSuccess 1 msiDoActionStatusUserExit 2 msiDoActionStatusFailure 3 msiDoActionStatusSuspend 4 msiDoActionStatusFinished 5 msiDoActionStatusWrongState 6 msiDoActionStatusBadActionData 7} |
||||
|
||||
# Enum MsiMessageStatus |
||||
array set MsiMessageStatus {msiMessageStatusError -1 msiMessageStatusNone 0 msiMessageStatusOk 1 msiMessageStatusCancel 2 msiMessageStatusAbort 3 msiMessageStatusRetry 4 msiMessageStatusIgnore 5 msiMessageStatusYes 6 msiMessageStatusNo 7} |
||||
|
||||
# Enum MsiMessageType |
||||
array set MsiMessageType {msiMessageTypeFatalExit 0 msiMessageTypeError 16777216 msiMessageTypeWarning 33554432 msiMessageTypeUser 50331648 msiMessageTypeInfo 67108864 msiMessageTypeFilesInUse 83886080 msiMessageTypeResolveSource 100663296 msiMessageTypeOutOfDiskSpace 117440512 msiMessageTypeActionStart 134217728 msiMessageTypeActionData 150994944 msiMessageTypeProgress 167772160 msiMessageTypeCommonData 184549376 msiMessageTypeOk 0 msiMessageTypeOkCancel 1 msiMessageTypeAbortRetryIgnore 2 msiMessageTypeYesNoCancel 3 msiMessageTypeYesNo 4 msiMessageTypeRetryCancel 5 msiMessageTypeDefault1 0 msiMessageTypeDefault2 256 msiMessageTypeDefault3 512} |
||||
|
||||
# Enum MsiInstallState |
||||
array set MsiInstallState {msiInstallStateNotUsed -7 msiInstallStateBadConfig -6 msiInstallStateIncomplete -5 msiInstallStateSourceAbsent -4 msiInstallStateInvalidArg -2 msiInstallStateUnknown -1 msiInstallStateBroken 0 msiInstallStateAdvertised 1 msiInstallStateRemoved 1 msiInstallStateAbsent 2 msiInstallStateLocal 3 msiInstallStateSource 4 msiInstallStateDefault 5} |
||||
|
||||
# Enum MsiCostTree |
||||
array set MsiCostTree {msiCostTreeSelfOnly 0 msiCostTreeChildren 1 msiCostTreeParents 2} |
||||
|
||||
# Enum MsiReinstallMode |
||||
array set MsiReinstallMode {msiReinstallModeFileMissing 2 msiReinstallModeFileOlderVersion 4 msiReinstallModeFileEqualVersion 8 msiReinstallModeFileExact 16 msiReinstallModeFileVerify 32 msiReinstallModeFileReplace 64 msiReinstallModeMachineData 128 msiReinstallModeUserData 256 msiReinstallModeShortcut 512 msiReinstallModePackage 1024} |
||||
|
||||
# Enum MsiInstallType |
||||
array set MsiInstallType {msiInstallTypeDefault 0 msiInstallTypeNetworkImage 1 msiInstallTypeSingleInstance 2} |
||||
|
||||
# Enum MsiInstallMode |
||||
array set MsiInstallMode {msiInstallModeNoSourceResolution -3 msiInstallModeNoDetection -2 msiInstallModeExisting -1 msiInstallModeDefault 0} |
||||
|
||||
# Enum MsiSignatureInfo |
||||
array set MsiSignatureInfo {msiSignatureInfoCertificate 0 msiSignatureInfoHash 1} |
||||
|
||||
# Enum MsiInstallContext |
||||
array set MsiInstallContext {msiInstallContextFirstVisible 0 msiInstallContextUserManaged 1 msiInstallContextUser 2 msiInstallContextMachine 4 msiInstallContextAllUserManaged 8} |
||||
|
||||
# Enum MsiInstallSourceType |
||||
array set MsiInstallSourceType {msiInstallSourceTypeUnknown 0 msiInstallSourceTypeNetwork 1 msiInstallSourceTypeURL 2 msiInstallSourceTypeMedia 4} |
||||
|
||||
# Enum MsiAssemblyType |
||||
array set MsiAssemblyType {msiProvideAssemblyNet 0 msiProvideAssemblyWin32 1} |
||||
|
||||
# Enum MsiProductScriptInfo |
||||
array set MsiProductScriptInfo {msiProductScriptInfoProductCode 0 msiProductScriptInfoProductLanguage 1 msiProductScriptInfoProductVersion 2 msiProductScriptInfoProductName 3 msiProductScriptInfoPackageName 4} |
||||
|
||||
# Enum MsiAdvertiseProductContext |
||||
array set MsiAdvertiseProductContext {msiAdvertiseProductMachine 0 msiAdvertiseProductUser 1} |
||||
|
||||
# Enum Constants |
||||
array set Constants {msiDatabaseNullInteger -2147483648} |
||||
|
||||
# Enum MsiOpenDatabaseMode |
||||
array set MsiOpenDatabaseMode {msiOpenDatabaseModeReadOnly 0 msiOpenDatabaseModeTransact 1 msiOpenDatabaseModeDirect 2 msiOpenDatabaseModeCreate 3 msiOpenDatabaseModeCreateDirect 4 msiOpenDatabaseModePatchFile 32} |
||||
|
||||
# Enum MsiSignatureOption |
||||
array set MsiSignatureOption {msiSignatureOptionInvalidHashFatal 1} |
||||
|
||||
# Enum MsiAdvertiseProductPlatform |
||||
array set MsiAdvertiseProductPlatform {msiAdvertiseCurrentPlatform 0 msiAdvertiseX86Platform 1 msiAdvertiseIA64Platform 2 msiAdvertiseX64Platform 4} |
||||
|
||||
# Enum MsiAdvertiseProductOptions |
||||
array set MsiAdvertiseProductOptions {msiAdvertiseDefault 0 msiAdvertiseSingleInstance 1} |
||||
|
||||
# Enum MsiAdvertiseScriptFlags |
||||
array set MsiAdvertiseScriptFlags {msiAdvertiseScriptCacheInfo 1 msiAdvertiseScriptShortcuts 4 msiAdvertiseScriptMachineAssign 8 msiAdvertiseScriptConfigurationRegistration 32 msiAdvertiseScriptValidateTransformsList 64 msiAdvertiseScriptClassInfoRegistration 128 msiAdvertiseScriptExtensionInfoRegistration 256 msiAdvertiseScriptAppInfo 384 msiAdvertiseScriptRegData 416} |
||||
} |
||||
|
||||
# Dispatch Interface Installer |
||||
set windowsinstaller::_dispatch_guids(Installer) "{000C1090-0000-0000-C000-000000000046}" |
||||
# Installer Methods |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} CreateRecord 1033 1 {1 1033 1 {26 {29 256}} {{3 1}} Count} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} OpenPackage 1033 1 {2 1033 1 {26 {29 512}} {{12 1} {3 {49 {3 0}}}} {PackagePath Options}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} OpenProduct 1033 1 {3 1033 1 {26 {29 512}} {{8 1}} ProductCode} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} OpenDatabase 1033 1 {4 1033 1 {26 {29 768}} {{8 1} {12 1}} {DatabasePath OpenMode}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} SummaryInformation 1033 2 {5 1033 2 {26 {29 1024}} {{8 1} {3 {49 {3 0}}}} {PackagePath UpdateCount}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} EnableLog 1033 1 {7 1033 1 24 {{8 1} {8 1}} {LogMode LogFile}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} InstallProduct 1033 1 {8 1033 1 24 {{8 1} {8 {49 {8 0}}}} {PackagePath PropertyValues}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} Version 1033 2 {9 1033 2 8 {} {}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} LastErrorRecord 1033 1 {10 1033 1 {26 {29 256}} {} {}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} RegistryValue 1033 1 {11 1033 1 8 {{12 1} {8 1} {12 17}} {Root Key Value}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} FileAttributes 1033 1 {13 1033 1 3 {{8 1}} FilePath} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} FileSize 1033 1 {15 1033 1 3 {{8 1}} FilePath} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} FileVersion 1033 1 {16 1033 1 8 {{8 1} {12 17}} {FilePath Language}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} Environment 1033 2 {12 1033 2 8 {{8 1}} Variable} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} Environment 1033 4 {12 1033 4 24 {{8 1} {8 1}} Variable} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ProductState 1033 2 {17 1033 2 {29 2432} {{8 1}} Product} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ProductInfo 1033 2 {18 1033 2 8 {{8 1} {8 1}} {Product Attribute}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ConfigureProduct 1033 1 {19 1033 1 24 {{8 1} {3 1} {3 1}} {Product InstallLevel InstallState}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ReinstallProduct 1033 1 {20 1033 1 24 {{8 1} {3 1}} {Product ReinstallMode}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} CollectUserInfo 1033 1 {21 1033 1 24 {{8 1}} Product} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ApplyPatch 1033 1 {22 1033 1 24 {{8 1} {8 1} {3 1} {8 1}} {PatchPackage InstallPackage InstallType CommandLine}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} FeatureParent 1033 2 {23 1033 2 8 {{8 1} {8 1}} {Product Feature}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} FeatureState 1033 2 {24 1033 2 {29 2432} {{8 1} {8 1}} {Product Feature}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} UseFeature 1033 1 {25 1033 1 24 {{8 1} {8 1} {3 1}} {Product Feature InstallMode}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} FeatureUsageCount 1033 2 {26 1033 2 3 {{8 1} {8 1}} {Product Feature}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} FeatureUsageDate 1033 2 {27 1033 2 7 {{8 1} {8 1}} {Product Feature}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ConfigureFeature 1033 1 {28 1033 1 24 {{8 1} {8 1} {3 1}} {Product Feature InstallState}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ReinstallFeature 1033 1 {29 1033 1 24 {{8 1} {8 1} {3 1}} {Product Feature ReinstallMode}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ProvideComponent 1033 1 {30 1033 1 8 {{8 1} {8 1} {8 1} {3 1}} {Product Feature Component InstallMode}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ComponentPath 1033 2 {31 1033 2 8 {{8 1} {8 1}} {Product Component}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ProvideQualifiedComponent 1033 1 {32 1033 1 8 {{8 1} {8 1} {3 1}} {Category Qualifier InstallMode}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} QualifierDescription 1033 2 {33 1033 2 8 {{8 1} {8 1}} {Category Qualifier}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ComponentQualifiers 1033 2 {34 1033 2 {26 {29 3328}} {{8 1}} Category} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} Products 1033 2 {35 1033 2 {26 {29 3328}} {} {}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} Features 1033 2 {36 1033 2 {26 {29 3328}} {{8 1}} Product} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} Components 1033 2 {37 1033 2 {26 {29 3328}} {} {}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ComponentClients 1033 2 {38 1033 2 {26 {29 3328}} {{8 1}} Component} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} Patches 1033 2 {39 1033 2 {26 {29 3328}} {{8 1}} Product} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} RelatedProducts 1033 2 {40 1033 2 {26 {29 3328}} {{8 1}} UpgradeCode} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} PatchInfo 1033 2 {41 1033 2 8 {{8 1} {8 1}} {Patch Attribute}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} PatchTransforms 1033 2 {42 1033 2 8 {{8 1} {8 1}} {Product Patch}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} AddSource 1033 1 {43 1033 1 24 {{8 1} {8 1} {8 1}} {Product User Source}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ClearSourceList 1033 1 {44 1033 1 24 {{8 1} {8 1}} {Product User}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ForceSourceListResolution 1033 1 {45 1033 1 24 {{8 1} {8 1}} {Product User}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} GetShortcutTarget 1033 2 {46 1033 2 {26 {29 256}} {{8 1}} ShortcutPath} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} FileHash 1033 1 {47 1033 1 {26 {29 256}} {{8 1} {3 1}} {FilePath Options}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} FileSignatureInfo 1033 1 {48 1033 1 {27 17} {{8 1} {3 1} {3 1}} {FilePath Options Format}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} RemovePatches 1033 1 {49 1033 1 24 {{8 1} {8 1} {3 1} {8 {49 {8 0}}}} {PatchList Product UninstallType PropertyList}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ApplyMultiplePatches 1033 1 {51 1033 1 24 {{8 1} {8 1} {8 1}} {PatchPackage Product PropertiesList}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} Product 1033 2 {53 1033 2 25 {{8 1} {8 1} {3 1} {{26 9} 10}} {Product UserSid iContext retval}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} Patch 1033 2 {56 1033 2 25 {{8 1} {8 1} {8 1} {3 1} {{26 9} 10}} {PatchCode ProductCode UserSid iContext retval}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ProductsEx 1033 2 {52 1033 2 {26 {29 2816}} {{8 1} {8 1} {3 1}} {Product UserSid Contexts}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} PatchesEx 1033 2 {55 1033 2 {26 {29 2816}} {{8 1} {8 1} {3 1} {3 1}} {Product UserSid Contexts filter}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ExtractPatchXMLData 1033 1 {57 1033 1 8 {{8 1}} PatchPath} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ProductCode 1033 2 {58 1033 2 8 {{8 1}} Component} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ProductElevated 1033 2 {59 1033 2 11 {{8 1}} Product} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ProvideAssembly 1033 1 {60 1033 1 8 {{8 1} {8 1} {3 1} {3 1}} {Assembly Context InstallMode AssemblyInfo}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ProductInfoFromScript 1033 2 {61 1033 2 12 {{8 1} {3 1}} {ScriptFile ProductInfo}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} AdvertiseProduct 1033 1 {62 1033 1 24 {{8 1} {3 1} {8 {49 {8 0}}} {3 {49 {3 0}}} {3 {49 {3 0}}}} {PackagePath iContext Transforms Language Options}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} CreateAdvertiseScript 1033 1 {63 1033 1 24 {{8 1} {8 1} {8 {49 {8 0}}} {3 {49 {3 0}}} {3 {49 {3 0}}} {3 {49 {3 0}}}} {PackagePath ScriptFilePath Transforms Language Platform Options}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} AdvertiseScript 1033 1 {64 1033 1 24 {{8 1} {3 1} {11 1}} {ScriptPath ScriptFlags RemoveItems}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} PatchFiles 1033 2 {65 1033 2 {26 {29 3328}} {{8 1} {8 1}} {Product PatchPackages}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ComponentsEx 1033 2 {66 1033 2 {26 {29 2816}} {{8 1} {3 1}} {UserSid Context}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ComponentClientsEx 1033 2 {67 1033 2 {26 {29 2816}} {{8 1} {8 1} {3 1}} {ComponentCode UserSid Context}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ComponentPathEx 1033 2 {9068 1033 2 {26 {29 4480}} {{8 1} {8 1} {8 1} {3 1}} {ProductCode ComponentCode UserSid Context}} |
||||
# Installer Properties |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} UILevel 1033 2 {6 1033 2 {29 128} {} {}} |
||||
::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} UILevel 1033 4 {6 1033 4 24 {{{29 128} 1}} {}} |
||||
|
||||
# Dispatch Interface Record |
||||
set windowsinstaller::_dispatch_guids(Record) "{000C1093-0000-0000-C000-000000000046}" |
||||
# Record Methods |
||||
::twapi::dispatch_prototype_set {{000C1093-0000-0000-C000-000000000046}} StringData 1033 2 {1 1033 2 8 {{3 1}} Field} |
||||
::twapi::dispatch_prototype_set {{000C1093-0000-0000-C000-000000000046}} StringData 1033 4 {1 1033 4 24 {{3 1} {8 1}} Field} |
||||
::twapi::dispatch_prototype_set {{000C1093-0000-0000-C000-000000000046}} IntegerData 1033 2 {2 1033 2 3 {{3 1}} Field} |
||||
::twapi::dispatch_prototype_set {{000C1093-0000-0000-C000-000000000046}} IntegerData 1033 4 {2 1033 4 24 {{3 1} {3 1}} Field} |
||||
::twapi::dispatch_prototype_set {{000C1093-0000-0000-C000-000000000046}} SetStream 1033 1 {3 1033 1 24 {{3 1} {8 1}} {Field FilePath}} |
||||
::twapi::dispatch_prototype_set {{000C1093-0000-0000-C000-000000000046}} ReadStream 1033 1 {4 1033 1 8 {{3 1} {3 1} {3 1}} {Field Length Format}} |
||||
::twapi::dispatch_prototype_set {{000C1093-0000-0000-C000-000000000046}} FieldCount 1033 2 {0 1033 2 3 {} {}} |
||||
::twapi::dispatch_prototype_set {{000C1093-0000-0000-C000-000000000046}} IsNull 1033 2 {6 1033 2 11 {{3 1}} Field} |
||||
::twapi::dispatch_prototype_set {{000C1093-0000-0000-C000-000000000046}} DataSize 1033 2 {5 1033 2 3 {{3 1}} Field} |
||||
::twapi::dispatch_prototype_set {{000C1093-0000-0000-C000-000000000046}} ClearData 1033 1 {7 1033 1 24 {} {}} |
||||
::twapi::dispatch_prototype_set {{000C1093-0000-0000-C000-000000000046}} FormatText 1033 1 {8 1033 1 8 {} {}} |
||||
|
||||
# Dispatch Interface Session |
||||
set windowsinstaller::_dispatch_guids(Session) "{000C109E-0000-0000-C000-000000000046}" |
||||
# Session Methods |
||||
::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} Installer 1033 2 {1 1033 2 {26 {29 0}} {} {}} |
||||
::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} Property 1033 2 {2 1033 2 8 {{8 1}} Name} |
||||
::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} Property 1033 4 {2 1033 4 24 {{8 1} {8 1}} Name} |
||||
::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} Language 1033 2 {3 1033 2 3 {} {}} |
||||
::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} Mode 1033 2 {4 1033 2 11 {{3 1}} Flag} |
||||
::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} Mode 1033 4 {4 1033 4 24 {{3 1} {11 1}} Flag} |
||||
::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} Database 1033 2 {5 1033 2 {26 {29 768}} {} {}} |
||||
::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} SourcePath 1033 2 {6 1033 2 8 {{8 1}} Folder} |
||||
::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} TargetPath 1033 2 {7 1033 2 8 {{8 1}} Folder} |
||||
::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} TargetPath 1033 4 {7 1033 4 24 {{8 1} {8 1}} Folder} |
||||
::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} DoAction 1033 1 {8 1033 1 {29 2048} {{8 1}} Action} |
||||
::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} Sequence 1033 1 {9 1033 1 {29 2048} {{8 1} {12 17}} {Table Mode}} |
||||
::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} EvaluateCondition 1033 1 {10 1033 1 {29 1792} {{8 1}} Expression} |
||||
::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} FormatRecord 1033 1 {11 1033 1 8 {{9 1}} Record} |
||||
::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} Message 1033 1 {12 1033 1 {29 2176} {{3 1} {9 1}} {Kind Record}} |
||||
::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} FeatureCurrentState 1033 2 {13 1033 2 {29 2432} {{8 1}} Feature} |
||||
::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} FeatureRequestState 1033 2 {14 1033 2 {29 2432} {{8 1}} Feature} |
||||
::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} FeatureRequestState 1033 4 {14 1033 4 24 {{8 1} {3 1}} Feature} |
||||
::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} FeatureValidStates 1033 2 {15 1033 2 3 {{8 1}} Feature} |
||||
::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} FeatureCost 1033 2 {16 1033 2 3 {{8 1} {3 1} {3 1}} {Feature CostTree State}} |
||||
::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} ComponentCurrentState 1033 2 {17 1033 2 {29 2432} {{8 1}} Component} |
||||
::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} ComponentRequestState 1033 2 {18 1033 2 {29 2432} {{8 1}} Component} |
||||
::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} ComponentRequestState 1033 4 {18 1033 4 24 {{8 1} {3 1}} Component} |
||||
::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} SetInstallLevel 1033 1 {19 1033 1 24 {{3 1}} Level} |
||||
::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} VerifyDiskSpace 1033 2 {20 1033 2 11 {} {}} |
||||
::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} ProductProperty 1033 2 {21 1033 2 8 {{8 1}} Property} |
||||
::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} FeatureInfo 1033 2 {22 1033 2 {26 {29 2688}} {{8 1}} Feature} |
||||
::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} ComponentCosts 1033 2 {23 1033 2 {26 {29 2816}} {{8 1} {3 1}} {Component State}} |
||||
|
||||
# Dispatch Interface Database |
||||
set windowsinstaller::_dispatch_guids(Database) "{000C109D-0000-0000-C000-000000000046}" |
||||
# Database Methods |
||||
::twapi::dispatch_prototype_set {{000C109D-0000-0000-C000-000000000046}} DatabaseState 1033 2 {1 1033 2 {29 896} {} {}} |
||||
::twapi::dispatch_prototype_set {{000C109D-0000-0000-C000-000000000046}} SummaryInformation 1033 2 {2 1033 2 {26 {29 1024}} {{3 {49 {3 0}}}} UpdateCount} |
||||
::twapi::dispatch_prototype_set {{000C109D-0000-0000-C000-000000000046}} OpenView 1033 1 {3 1033 1 {26 {29 1152}} {{8 1}} Sql} |
||||
::twapi::dispatch_prototype_set {{000C109D-0000-0000-C000-000000000046}} Commit 1033 1 {4 1033 1 24 {} {}} |
||||
::twapi::dispatch_prototype_set {{000C109D-0000-0000-C000-000000000046}} PrimaryKeys 1033 2 {5 1033 2 {26 {29 256}} {{8 1}} Table} |
||||
::twapi::dispatch_prototype_set {{000C109D-0000-0000-C000-000000000046}} Import 1033 1 {6 1033 1 24 {{8 1} {8 1}} {Folder File}} |
||||
::twapi::dispatch_prototype_set {{000C109D-0000-0000-C000-000000000046}} Export 1033 1 {7 1033 1 24 {{8 1} {8 1} {8 1}} {Table Folder File}} |
||||
::twapi::dispatch_prototype_set {{000C109D-0000-0000-C000-000000000046}} Merge 1033 1 {8 1033 1 11 {{9 1} {8 {49 {8 0}}}} {Database ErrorTable}} |
||||
::twapi::dispatch_prototype_set {{000C109D-0000-0000-C000-000000000046}} GenerateTransform 1033 1 {9 1033 1 11 {{9 1} {8 {49 {8 0}}}} {ReferenceDatabase TransformFile}} |
||||
::twapi::dispatch_prototype_set {{000C109D-0000-0000-C000-000000000046}} ApplyTransform 1033 1 {10 1033 1 24 {{8 1} {3 1}} {TransformFile ErrorConditions}} |
||||
::twapi::dispatch_prototype_set {{000C109D-0000-0000-C000-000000000046}} EnableUIPreview 1033 1 {11 1033 1 {26 {29 1664}} {} {}} |
||||
::twapi::dispatch_prototype_set {{000C109D-0000-0000-C000-000000000046}} TablePersistent 1033 2 {12 1033 2 {29 1792} {{8 1}} Table} |
||||
::twapi::dispatch_prototype_set {{000C109D-0000-0000-C000-000000000046}} CreateTransformSummaryInfo 1033 1 {13 1033 1 24 {{9 1} {8 1} {3 1} {3 1}} {ReferenceDatabase TransformFile ErrorConditions Validation}} |
||||
|
||||
# Dispatch Interface SummaryInfo |
||||
set windowsinstaller::_dispatch_guids(SummaryInfo) "{000C109B-0000-0000-C000-000000000046}" |
||||
# SummaryInfo Methods |
||||
::twapi::dispatch_prototype_set {{000C109B-0000-0000-C000-000000000046}} Property 1033 2 {1 1033 2 12 {{3 1}} Pid} |
||||
::twapi::dispatch_prototype_set {{000C109B-0000-0000-C000-000000000046}} Property 1033 4 {1 1033 4 24 {{3 1} {12 1}} Pid} |
||||
::twapi::dispatch_prototype_set {{000C109B-0000-0000-C000-000000000046}} PropertyCount 1033 2 {2 1033 2 3 {} {}} |
||||
::twapi::dispatch_prototype_set {{000C109B-0000-0000-C000-000000000046}} Persist 1033 1 {3 1033 1 24 {} {}} |
||||
|
||||
# Dispatch Interface View |
||||
set windowsinstaller::_dispatch_guids(View) "{000C109C-0000-0000-C000-000000000046}" |
||||
# View Methods |
||||
::twapi::dispatch_prototype_set {{000C109C-0000-0000-C000-000000000046}} Execute 1033 1 {1 1033 1 24 {{9 {49 {3 0}}}} Params} |
||||
::twapi::dispatch_prototype_set {{000C109C-0000-0000-C000-000000000046}} Fetch 1033 1 {2 1033 1 {26 {29 256}} {} {}} |
||||
::twapi::dispatch_prototype_set {{000C109C-0000-0000-C000-000000000046}} Modify 1033 1 {3 1033 1 24 {{3 1} {9 0}} {Mode Record}} |
||||
::twapi::dispatch_prototype_set {{000C109C-0000-0000-C000-000000000046}} ColumnInfo 1033 2 {5 1033 2 {26 {29 256}} {{3 1}} Info} |
||||
::twapi::dispatch_prototype_set {{000C109C-0000-0000-C000-000000000046}} Close 1033 1 {4 1033 1 24 {} {}} |
||||
::twapi::dispatch_prototype_set {{000C109C-0000-0000-C000-000000000046}} GetError 1033 1 {6 1033 1 8 {} {}} |
||||
|
||||
# Dispatch Interface UIPreview |
||||
set windowsinstaller::_dispatch_guids(UIPreview) "{000C109A-0000-0000-C000-000000000046}" |
||||
# UIPreview Methods |
||||
::twapi::dispatch_prototype_set {{000C109A-0000-0000-C000-000000000046}} Property 1033 2 {1 1033 2 8 {{8 1}} Name} |
||||
::twapi::dispatch_prototype_set {{000C109A-0000-0000-C000-000000000046}} Property 1033 4 {1 1033 4 24 {{8 1} {8 1}} Name} |
||||
::twapi::dispatch_prototype_set {{000C109A-0000-0000-C000-000000000046}} ViewDialog 1033 1 {2 1033 1 24 {{8 1}} Dialog} |
||||
::twapi::dispatch_prototype_set {{000C109A-0000-0000-C000-000000000046}} ViewBillboard 1033 1 {3 1033 1 24 {{8 1} {8 1}} {Control Billboard}} |
||||
|
||||
# Dispatch Interface FeatureInfo |
||||
set windowsinstaller::_dispatch_guids(FeatureInfo) "{000C109F-0000-0000-C000-000000000046}" |
||||
# FeatureInfo Methods |
||||
::twapi::dispatch_prototype_set {{000C109F-0000-0000-C000-000000000046}} Title 1033 2 {1 1033 2 8 {} {}} |
||||
::twapi::dispatch_prototype_set {{000C109F-0000-0000-C000-000000000046}} Description 1033 2 {2 1033 2 8 {} {}} |
||||
# FeatureInfo Properties |
||||
::twapi::dispatch_prototype_set {{000C109F-0000-0000-C000-000000000046}} Attributes 1033 2 {3 1033 2 3 {} {}} |
||||
::twapi::dispatch_prototype_set {{000C109F-0000-0000-C000-000000000046}} Attributes 1033 4 {3 1033 4 24 {{3 1}} {}} |
||||
|
||||
# Dispatch Interface RecordList |
||||
set windowsinstaller::_dispatch_guids(RecordList) "{000C1096-0000-0000-C000-000000000046}" |
||||
# RecordList Methods |
||||
::twapi::dispatch_prototype_set {{000C1096-0000-0000-C000-000000000046}} _NewEnum 1033 1 {-4 1033 1 13 {} {}} |
||||
::twapi::dispatch_prototype_set {{000C1096-0000-0000-C000-000000000046}} Item 1033 2 {0 1033 2 {26 {29 256}} {{3 0}} Index} |
||||
::twapi::dispatch_prototype_set {{000C1096-0000-0000-C000-000000000046}} Count 1033 2 {1 1033 2 3 {} {}} |
||||
|
||||
# Dispatch Interface StringList |
||||
set windowsinstaller::_dispatch_guids(StringList) "{000C1095-0000-0000-C000-000000000046}" |
||||
# StringList Methods |
||||
::twapi::dispatch_prototype_set {{000C1095-0000-0000-C000-000000000046}} _NewEnum 1033 1 {-4 1033 1 13 {} {}} |
||||
::twapi::dispatch_prototype_set {{000C1095-0000-0000-C000-000000000046}} Item 1033 2 {0 1033 2 8 {{3 0}} Index} |
||||
::twapi::dispatch_prototype_set {{000C1095-0000-0000-C000-000000000046}} Count 1033 2 {1 1033 2 3 {} {}} |
||||
|
||||
# Dispatch Interface Product |
||||
set windowsinstaller::_dispatch_guids(Product) "{000C10A0-0000-0000-C000-000000000046}" |
||||
# Product Methods |
||||
::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} ProductCode 1033 2 {1 1033 2 25 {{{26 8} 10}} retval} |
||||
::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} UserSid 1033 2 {2 1033 2 25 {{{26 8} 10}} retval} |
||||
::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} Context 1033 2 {3 1033 2 25 {{{26 3} 10}} retval} |
||||
::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} State 1033 2 {4 1033 2 25 {{{26 3} 10}} retval} |
||||
::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} InstallProperty 1033 2 {5 1033 2 25 {{8 1} {{26 8} 10}} {Name retval}} |
||||
::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} ComponentState 1033 2 {6 1033 2 25 {{8 1} {{26 3} 10}} {Component retval}} |
||||
::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} FeatureState 1033 2 {7 1033 2 25 {{8 1} {{26 3} 10}} {Feature retval}} |
||||
::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} Sources 1033 2 {14 1033 2 25 {{3 1} {{26 9} 10}} {SourceType retval}} |
||||
::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} MediaDisks 1033 2 {15 1033 2 25 {{{26 9} 10}} retval} |
||||
::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} SourceListAddSource 1033 1 {8 1033 1 25 {{3 1} {8 1} {3 1}} {iSourceType Source dwIndex}} |
||||
::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} SourceListAddMediaDisk 1033 1 {9 1033 1 25 {{3 1} {8 1} {8 1}} {dwDiskId VolumeLabel DiskPrompt}} |
||||
::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} SourceListClearSource 1033 1 {10 1033 1 25 {{3 1} {8 1}} {iSourceType Source}} |
||||
::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} SourceListClearMediaDisk 1033 1 {11 1033 1 25 {{3 1}} iDiskId} |
||||
::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} SourceListClearAll 1033 1 {12 1033 1 25 {{3 1}} iSourceType} |
||||
::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} SourceListForceResolution 1033 1 {13 1033 1 25 {} {}} |
||||
::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} SourceListInfo 1033 2 {16 1033 2 25 {{8 1} {{26 8} 10}} {Property retval}} |
||||
::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} SourceListInfo 1033 4 {16 1033 4 25 {{8 1} {8 1}} {Property retval}} |
||||
|
||||
# Dispatch Interface Patch |
||||
set windowsinstaller::_dispatch_guids(Patch) "{000C10A1-0000-0000-C000-000000000046}" |
||||
# Patch Methods |
||||
::twapi::dispatch_prototype_set {{000C10A1-0000-0000-C000-000000000046}} PatchCode 1033 2 {1 1033 2 25 {{{26 8} 10}} retval} |
||||
::twapi::dispatch_prototype_set {{000C10A1-0000-0000-C000-000000000046}} ProductCode 1033 2 {2 1033 2 25 {{{26 8} 10}} retval} |
||||
::twapi::dispatch_prototype_set {{000C10A1-0000-0000-C000-000000000046}} UserSid 1033 2 {3 1033 2 25 {{{26 8} 10}} retval} |
||||
::twapi::dispatch_prototype_set {{000C10A1-0000-0000-C000-000000000046}} Context 1033 2 {4 1033 2 25 {{{26 3} 10}} retval} |
||||
::twapi::dispatch_prototype_set {{000C10A1-0000-0000-C000-000000000046}} State 1033 2 {5 1033 2 25 {{{26 3} 10}} retval} |
||||
::twapi::dispatch_prototype_set {{000C10A1-0000-0000-C000-000000000046}} Sources 1033 2 {12 1033 2 25 {{3 1} {{26 9} 10}} {SourceType retval}} |
||||
::twapi::dispatch_prototype_set {{000C10A1-0000-0000-C000-000000000046}} MediaDisks 1033 2 {13 1033 2 25 {{{26 9} 10}} retval} |
||||
::twapi::dispatch_prototype_set {{000C10A1-0000-0000-C000-000000000046}} SourceListAddSource 1033 1 {6 1033 1 25 {{3 1} {8 1} {3 1}} {iSourceType Source dwIndex}} |
||||
::twapi::dispatch_prototype_set {{000C10A1-0000-0000-C000-000000000046}} SourceListAddMediaDisk 1033 1 {7 1033 1 25 {{3 1} {8 1} {8 1}} {dwDiskId VolumeLabel DiskPrompt}} |
||||
::twapi::dispatch_prototype_set {{000C10A1-0000-0000-C000-000000000046}} SourceListClearSource 1033 1 {8 1033 1 25 {{3 1} {8 1}} {iSourceType Source}} |
||||
::twapi::dispatch_prototype_set {{000C10A1-0000-0000-C000-000000000046}} SourceListClearMediaDisk 1033 1 {9 1033 1 25 {{3 1}} iDiskId} |
||||
::twapi::dispatch_prototype_set {{000C10A1-0000-0000-C000-000000000046}} SourceListClearAll 1033 1 {10 1033 1 25 {{3 1}} iSourceType} |
||||
::twapi::dispatch_prototype_set {{000C10A1-0000-0000-C000-000000000046}} SourceListForceResolution 1033 1 {11 1033 1 25 {} {}} |
||||
::twapi::dispatch_prototype_set {{000C10A1-0000-0000-C000-000000000046}} SourceListInfo 1033 2 {14 1033 2 25 {{8 1} {{26 8} 10}} {Property retval}} |
||||
::twapi::dispatch_prototype_set {{000C10A1-0000-0000-C000-000000000046}} SourceListInfo 1033 4 {14 1033 4 25 {{8 1} {8 1}} {Property retval}} |
||||
::twapi::dispatch_prototype_set {{000C10A1-0000-0000-C000-000000000046}} PatchProperty 1033 2 {15 1033 2 25 {{8 1} {{26 8} 10}} {Property Value}} |
||||
|
||||
# Dispatch Interface ComponentPath |
||||
set windowsinstaller::_dispatch_guids(ComponentPath) "{000C1099-0000-0000-C000-000000000046}" |
||||
# ComponentPath Methods |
||||
::twapi::dispatch_prototype_set {{000C1099-0000-0000-C000-000000000046}} ComponentCode 1033 2 {1 1033 2 25 {{{26 8} 10}} retval} |
||||
::twapi::dispatch_prototype_set {{000C1099-0000-0000-C000-000000000046}} Path 1033 2 {2 1033 2 25 {{{26 8} 10}} retval} |
||||
::twapi::dispatch_prototype_set {{000C1099-0000-0000-C000-000000000046}} State 1033 2 {3 1033 2 25 {{{26 3} 10}} retval} |
||||
|
||||
# Dispatch Interface Component |
||||
set windowsinstaller::_dispatch_guids(Component) "{000C1097-0000-0000-C000-000000000046}" |
||||
# Component Methods |
||||
::twapi::dispatch_prototype_set {{000C1097-0000-0000-C000-000000000046}} ComponentCode 1033 2 {1 1033 2 25 {{{26 8} 10}} retval} |
||||
::twapi::dispatch_prototype_set {{000C1097-0000-0000-C000-000000000046}} UserSid 1033 2 {2 1033 2 25 {{{26 8} 10}} retval} |
||||
::twapi::dispatch_prototype_set {{000C1097-0000-0000-C000-000000000046}} Context 1033 2 {3 1033 2 25 {{{26 3} 10}} retval} |
||||
|
||||
# Dispatch Interface ComponentClient |
||||
set windowsinstaller::_dispatch_guids(ComponentClient) "{000C1098-0000-0000-C000-000000000046}" |
||||
# ComponentClient Methods |
||||
::twapi::dispatch_prototype_set {{000C1098-0000-0000-C000-000000000046}} ProductCode 1033 2 {2 1033 2 25 {{{26 8} 10}} retval} |
||||
::twapi::dispatch_prototype_set {{000C1098-0000-0000-C000-000000000046}} ComponentCode 1033 2 {1 1033 2 25 {{{26 8} 10}} retval} |
||||
::twapi::dispatch_prototype_set {{000C1098-0000-0000-C000-000000000046}} UserSid 1033 2 {3 1033 2 25 {{{26 8} 10}} retval} |
||||
::twapi::dispatch_prototype_set {{000C1098-0000-0000-C000-000000000046}} Context 1033 2 {4 1033 2 25 {{{26 3} 10}} retval} |
||||
|
||||
@ -0,0 +1,745 @@
|
||||
# |
||||
# Copyright (c) 2006-2013 Ashok P. Nadkarni |
||||
# All rights reserved. |
||||
# |
||||
# See the file LICENSE for license |
||||
|
||||
# Task scheduler API |
||||
|
||||
package require twapi_com |
||||
|
||||
namespace eval twapi { |
||||
variable CLSID_ITaskScheduler {{148BD52A-A2AB-11CE-B11F-00AA00530503}} |
||||
variable CLSID_ITask {{148BD520-A2AB-11CE-B11F-00AA00530503}} |
||||
} |
||||
|
||||
# Return an instance of the task scheduler |
||||
proc twapi::itaskscheduler_new {args} { |
||||
array set opts [parseargs args { |
||||
system.arg |
||||
} -maxleftover 0] |
||||
|
||||
# Get ITaskScheduler interface |
||||
set its [com_create_instance $::twapi::CLSID_ITaskScheduler -model inprocserver -interface ITaskScheduler -raw] |
||||
if {![info exists opts(system)]} { |
||||
return $its |
||||
} |
||||
trap { |
||||
itaskscheduler_set_target_system $its $opts(system) |
||||
} onerror {} { |
||||
IUnknown_Release $its |
||||
rethrow |
||||
} |
||||
return $its |
||||
} |
||||
|
||||
interp alias {} ::twapi::itaskscheduler_release {} ::twapi::IUnknown_Release |
||||
|
||||
# Return a new task interface |
||||
proc twapi::itaskscheduler_new_itask {its taskname} { |
||||
set iid_itask [name_to_iid ITask] |
||||
set iunk [ITaskScheduler_NewWorkItem $its $taskname $::twapi::CLSID_ITask $iid_itask] |
||||
trap { |
||||
set itask [Twapi_IUnknown_QueryInterface $iunk $iid_itask ITask] |
||||
} finally { |
||||
IUnknown_Release $iunk |
||||
} |
||||
return $itask |
||||
} |
||||
|
||||
# Get an existing task |
||||
proc twapi::itaskscheduler_get_itask {its taskname} { |
||||
set iid_itask [name_to_iid ITask] |
||||
set iunk [ITaskScheduler_Activate $its $taskname $iid_itask] |
||||
trap { |
||||
set itask [Twapi_IUnknown_QueryInterface $iunk $iid_itask ITask] |
||||
} finally { |
||||
IUnknown_Release $iunk |
||||
} |
||||
return $itask |
||||
} |
||||
|
||||
# Check if an itask exists |
||||
proc twapi::itaskscheduler_task_exists {its taskname} { |
||||
return [expr {[ITaskScheduler_IsOfType $its $taskname [name_to_iid ITask]] == 0 ? true : false}] |
||||
} |
||||
|
||||
# Return list of tasks |
||||
proc twapi::itaskscheduler_get_tasks {its} { |
||||
set ienum [ITaskScheduler_Enum $its] |
||||
trap { |
||||
set result [list ] |
||||
set more 1 |
||||
while {$more} { |
||||
lassign [IEnumWorkItems_Next $ienum 20] more items |
||||
set result [concat $result $items] |
||||
} |
||||
} finally { |
||||
IUnknown_Release $ienum |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
# Sets the specified properties of the ITask |
||||
proc twapi::itask_configure {itask args} { |
||||
|
||||
array set opts [parseargs args { |
||||
application.arg |
||||
maxruntime.int |
||||
params.arg |
||||
priority.arg |
||||
workingdir.arg |
||||
account.arg |
||||
password.arg |
||||
comment.arg |
||||
creator.arg |
||||
data.arg |
||||
idlewait.int |
||||
idlewaitdeadline.int |
||||
interactive.bool |
||||
deletewhendone.bool |
||||
disabled.bool |
||||
hidden.bool |
||||
runonlyifloggedon.bool |
||||
startonlyifidle.bool |
||||
resumesystem.bool |
||||
killonidleend.bool |
||||
restartonidleresume.bool |
||||
dontstartonbatteries.bool |
||||
killifonbatteries.bool |
||||
} -maxleftover 0] |
||||
|
||||
if {[info exists opts(priority)]} { |
||||
switch -exact -- $opts(priority) { |
||||
normal {set opts(priority) 0x00000020} |
||||
abovenormal {set opts(priority) 0x00008000} |
||||
belownormal {set opts(priority) 0x00004000} |
||||
high {set opts(priority) 0x00000080} |
||||
realtime {set opts(priority) 0x00000100} |
||||
idle {set opts(priority) 0x00000040} |
||||
default {error "Unknown priority '$opts(priority)'. Must be one of 'normal', 'high', 'idle' or 'realtime'"} |
||||
} |
||||
} |
||||
|
||||
foreach {opt fn} { |
||||
application ITask_SetApplicationName |
||||
maxruntime ITask_SetMaxRunTime |
||||
params ITask_SetParameters |
||||
workingdir ITask_SetWorkingDirectory |
||||
priority ITask_SetPriority |
||||
comment IScheduledWorkItem_SetComment |
||||
creator IScheduledWorkItem_SetCreator |
||||
data IScheduledWorkItem_SetWorkItemData |
||||
errorretrycount IScheduledWorkItem_SetErrorRetryCount |
||||
errorretryinterval IScheduledWorkItem_SetErrorRetryInterval |
||||
} { |
||||
if {[info exists opts($opt)]} { |
||||
$fn $itask $opts($opt) |
||||
} |
||||
} |
||||
|
||||
if {[info exists opts(account)]} { |
||||
if {$opts(account) ne ""} { |
||||
if {![info exists opts(password)]} { |
||||
error "Option -password must be specified if -account is specified" |
||||
} |
||||
} else { |
||||
# System account. Set password to NULL pointer indicated |
||||
# by magic null pointer |
||||
set opts(password) $::twapi::nullptr |
||||
} |
||||
IScheduledWorkItem_SetAccountInformation $itask $opts(account) $opts(password) |
||||
} |
||||
|
||||
if {[info exists opts(idlewait)] || [info exists opts(idlewaitdeadline)]} { |
||||
# If either one is not specified, get the current settings |
||||
if {! ([info exists opts(idlewait)] && |
||||
[info exists opts(idlewaitdeadline)]) } { |
||||
lassign [IScheduledWorkItem_GetIdleWait $itask] idle dead |
||||
if {![info exists opts(idlewait)]} { |
||||
set opts(idlewait) $idle |
||||
} |
||||
if {![info exists opts(idlewaitdeadline)]} { |
||||
set opts(idlewaitdeadline) $dead |
||||
} |
||||
} |
||||
IScheduledWorkItem_SetIdleWait $itask $opts(idlewait) $opts(idlewaitdeadline) |
||||
} |
||||
|
||||
# Finally figure out and set the flags if needed |
||||
if {[info exists opts(interactive)] || |
||||
[info exists opts(deletewhendone)] || |
||||
[info exists opts(disabled)] || |
||||
[info exists opts(hidden)] || |
||||
[info exists opts(runonlyifloggedon)] || |
||||
[info exists opts(startonlyifidle)] || |
||||
[info exists opts(resumesystem)] || |
||||
[info exists opts(killonidleend)] || |
||||
[info exists opts(restartonidleresume)] || |
||||
[info exists opts(dontstartonbatteries)] || |
||||
[info exists opts(killifonbatteries)]} { |
||||
|
||||
# First, get the current flags |
||||
set flags [IScheduledWorkItem_GetFlags $itask] |
||||
foreach {opt val} { |
||||
interactive 0x1 |
||||
deletewhendone 0x2 |
||||
disabled 0x4 |
||||
startonlyifidle 0x10 |
||||
hidden 0x200 |
||||
runonlyifloggedon 0x2000 |
||||
resumesystem 0x1000 |
||||
killonidleend 0x20 |
||||
restartonidleresume 0x800 |
||||
dontstartonbatteries 0x40 |
||||
killifonbatteries 0x80 |
||||
} { |
||||
# Set / reset the bit if specified |
||||
if {[info exists opts($opt)]} { |
||||
if {$opts($opt)} { |
||||
setbits flags $val |
||||
} else { |
||||
resetbits flags $val |
||||
} |
||||
} |
||||
} |
||||
|
||||
# Now set the new value of flags |
||||
IScheduledWorkItem_SetFlags $itask $flags |
||||
} |
||||
|
||||
|
||||
return |
||||
} |
||||
|
||||
proc twapi::itask_get_info {itask args} { |
||||
# Note options errorretrycount and errorretryinterval are not implemented |
||||
# by the OS so left out |
||||
array set opts [parseargs args { |
||||
all |
||||
application |
||||
maxruntime |
||||
params |
||||
priority |
||||
workingdir |
||||
account |
||||
comment |
||||
creator |
||||
data |
||||
idlewait |
||||
idlewaitdeadline |
||||
interactive |
||||
deletewhendone |
||||
disabled |
||||
hidden |
||||
runonlyifloggedon |
||||
startonlyifidle |
||||
resumesystem |
||||
killonidleend |
||||
restartonidleresume |
||||
dontstartonbatteries |
||||
killifonbatteries |
||||
lastruntime |
||||
nextruntime |
||||
status |
||||
} -maxleftover 0] |
||||
|
||||
set result [list ] |
||||
if {$opts(all) || $opts(priority)} { |
||||
switch -exact -- [twapi::ITask_GetPriority $itask] { |
||||
32 { set priority normal } |
||||
64 { set priority idle } |
||||
128 { set priority high } |
||||
256 { set priority realtime } |
||||
16384 { set priority belownormal } |
||||
32768 { set priority abovenormal } |
||||
default { set priority unknown } |
||||
} |
||||
lappend result -priority $priority |
||||
} |
||||
|
||||
foreach {opt fn} { |
||||
application ITask_GetApplicationName |
||||
maxruntime ITask_GetMaxRunTime |
||||
params ITask_GetParameters |
||||
workingdir ITask_GetWorkingDirectory |
||||
account IScheduledWorkItem_GetAccountInformation |
||||
comment IScheduledWorkItem_GetComment |
||||
creator IScheduledWorkItem_GetCreator |
||||
data IScheduledWorkItem_GetWorkItemData |
||||
} { |
||||
if {$opts(all) || $opts($opt)} { |
||||
trap { |
||||
lappend result -$opt [$fn $itask] |
||||
} onerror {TWAPI_WIN32 -2147216625} { |
||||
# THe information is empty in the scheduler database |
||||
lappend result -$opt {} |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {$opts(all) || $opts(lastruntime)} { |
||||
trap { |
||||
lappend result -lastruntime [_timelist_to_timestring [IScheduledWorkItem_GetMostRecentRunTime $itask]] |
||||
} onerror {TWAPI_WIN32 267011} { |
||||
# Not run yet at all |
||||
lappend result -lastruntime {} |
||||
} |
||||
} |
||||
|
||||
if {$opts(all) || $opts(nextruntime)} { |
||||
trap { |
||||
lappend result -nextruntime [_timelist_to_timestring [IScheduledWorkItem_GetNextRunTime $itask]] |
||||
} onerror {TWAPI_WIN32 267010} { |
||||
# Task is disabled |
||||
lappend result -nextruntime disabled |
||||
} onerror {TWAPI_WIN32 267015} { |
||||
# No triggers set |
||||
lappend result -nextruntime notriggers |
||||
} onerror {TWAPI_WIN32 267016} { |
||||
# No triggers set |
||||
lappend result -nextruntime oneventonly |
||||
} |
||||
} |
||||
|
||||
if {$opts(all) || $opts(status)} { |
||||
set status [IScheduledWorkItem_GetStatus $itask] |
||||
if {$status == 0x41300} { |
||||
set status ready |
||||
} elseif {$status == 0x41301} { |
||||
set status running |
||||
} elseif {$status == 0x41302} { |
||||
set status disabled |
||||
} elseif {$status == 0x41305} { |
||||
set status partiallydefined |
||||
} else { |
||||
set status unknown |
||||
} |
||||
lappend result -status $status |
||||
} |
||||
|
||||
|
||||
if {$opts(all) || $opts(idlewait) || $opts(idlewaitdeadline)} { |
||||
lassign [IScheduledWorkItem_GetIdleWait $itask] idle dead |
||||
if {$opts(all) || $opts(idlewait)} { |
||||
lappend result -idlewait $idle |
||||
} |
||||
if {$opts(all) || $opts(idlewaitdeadline)} { |
||||
lappend result -idlewaitdeadline $dead |
||||
} |
||||
} |
||||
|
||||
# Finally figure out and set the flags if needed |
||||
if {$opts(all) || |
||||
$opts(interactive) || |
||||
$opts(deletewhendone) || |
||||
$opts(disabled) || |
||||
$opts(hidden) || |
||||
$opts(runonlyifloggedon) || |
||||
$opts(startonlyifidle) || |
||||
$opts(resumesystem) || |
||||
$opts(killonidleend) || |
||||
$opts(restartonidleresume) || |
||||
$opts(dontstartonbatteries) || |
||||
$opts(killifonbatteries)} { |
||||
|
||||
# First, get the current flags |
||||
set flags [IScheduledWorkItem_GetFlags $itask] |
||||
foreach {opt val} { |
||||
interactive 0x1 |
||||
deletewhendone 0x2 |
||||
disabled 0x4 |
||||
startonlyifidle 0x10 |
||||
hidden 0x200 |
||||
runonlyifloggedon 0x2000 |
||||
resumesystem 0x1000 |
||||
killonidleend 0x20 |
||||
restartonidleresume 0x800 |
||||
dontstartonbatteries 0x40 |
||||
killifonbatteries 0x80 |
||||
} { |
||||
if {$opts(all) || $opts($opt)} { |
||||
lappend result -$opt [expr {($flags & $val) ? true : false}] |
||||
} |
||||
} |
||||
} |
||||
|
||||
|
||||
return $result |
||||
} |
||||
|
||||
# Get the runtimes for a task within an interval |
||||
proc twapi::itask_get_runtimes_within_interval {itask args} { |
||||
array set opts [parseargs args { |
||||
start.arg |
||||
end.arg |
||||
{count.int 1} |
||||
statusvar.arg |
||||
} -maxleftover 0] |
||||
|
||||
if {[info exists opts(start)]} { |
||||
set start [_timestring_to_timelist $opts(start)] |
||||
} else { |
||||
set start [_seconds_to_timelist [clock seconds]] |
||||
} |
||||
if {[info exists opts(end)]} { |
||||
set end [_timestring_to_timelist $opts(end)] |
||||
} else { |
||||
set end {2038 1 1 0 0 0 0} |
||||
} |
||||
|
||||
set result [list ] |
||||
if {[info exists opts(statusvar)]} { |
||||
upvar $opts(statusvar) status |
||||
} |
||||
lassign [IScheduledWorkItem_GetRunTimes $itask $start $end $opts(count)] status timelist |
||||
|
||||
foreach time $timelist { |
||||
lappend result [_timelist_to_timestring $time] |
||||
} |
||||
|
||||
|
||||
return $result |
||||
} |
||||
|
||||
# Saves the specified ITask |
||||
proc twapi::itask_save {itask} { |
||||
set ipersist [Twapi_IUnknown_QueryInterface $itask [name_to_iid IPersistFile] IPersistFile] |
||||
trap { |
||||
IPersistFile_Save $ipersist "" 1 |
||||
} finally { |
||||
IUnknown_Release $ipersist |
||||
} |
||||
return |
||||
} |
||||
|
||||
# Show property editor for a task |
||||
proc twapi::itask_edit_dialog {itask args} { |
||||
array set opts [parseargs args { |
||||
{hwin.arg 0} |
||||
} -maxleftover 0] |
||||
|
||||
return [twapi::IScheduledWorkItem_EditWorkItem $itask $opts(hwin) 0] |
||||
} |
||||
|
||||
|
||||
interp alias {} ::twapi::itask_release {} ::twapi::IUnknown_Release |
||||
|
||||
# Get information about a trigger |
||||
proc twapi::itasktrigger_get_info {itt} { |
||||
array set data [ITaskTrigger_GetTrigger $itt] |
||||
|
||||
set result(-begindate) [format %04d-%02d-%02d $data(wBeginYear) $data(wBeginMonth) $data(wBeginDay)] |
||||
|
||||
set result(-starttime) [format %02d:%02d $data(wStartHour) $data(wStartMinute)] |
||||
|
||||
if {$data(rgFlags) & 1} { |
||||
set result(-enddate) [format %04d-%02d-%02d $data(wEndYear) $data(wEndMonth) $data(wEndDay)] |
||||
} else { |
||||
set result(-enddate) "" |
||||
} |
||||
|
||||
set result(-duration) $data(MinutesDuration) |
||||
set result(-interval) $data(MinutesInterval) |
||||
if {$data(rgFlags) & 2} { |
||||
set result(-killatdurationend) true |
||||
} else { |
||||
set result(-killatdurationend) false |
||||
} |
||||
|
||||
if {$data(rgFlags) & 4} { |
||||
set result(-disabled) true |
||||
} else { |
||||
set result(-disabled) false |
||||
} |
||||
|
||||
switch -exact -- [lindex $data(type) 0] { |
||||
0 { |
||||
set result(-type) once |
||||
} |
||||
1 { |
||||
set result(-type) daily |
||||
set result(-period) [lindex $data(type) 1] |
||||
} |
||||
2 { |
||||
set result(-type) weekly |
||||
set result(-period) [lindex $data(type) 1] |
||||
set result(-weekdays) [format 0x%x [lindex $data(type) 2]] |
||||
} |
||||
3 { |
||||
set result(-type) monthlydate |
||||
set result(-daysofmonth) [format 0x%x [lindex $data(type) 1]] |
||||
set result(-months) [format 0x%x [lindex $data(type) 2]] |
||||
} |
||||
4 { |
||||
set result(-type) monthlydow |
||||
set result(-weekofmonth) [lindex {first second third fourth last} [lindex $data(type) 2]] |
||||
set result(-weekdays) [format 0x%x [lindex $data(type) 2]] |
||||
set result(-months) [format 0x%x [lindex $data(type) 3]] |
||||
} |
||||
5 { |
||||
set result(-type) onidle |
||||
} |
||||
6 { |
||||
set result(-type) atsystemstart |
||||
} |
||||
7 { |
||||
set result(-type) atlogon |
||||
} |
||||
} |
||||
return [array get result] |
||||
} |
||||
|
||||
|
||||
# Configure a task trigger |
||||
proc twapi::itasktrigger_configure {itt args} { |
||||
array set opts [parseargs args { |
||||
begindate.arg |
||||
enddate.arg |
||||
starttime.arg |
||||
interval.int |
||||
duration.int |
||||
killatdurationend.bool |
||||
disabled.bool |
||||
type.arg |
||||
weekofmonth.int |
||||
{period.int 1} |
||||
{weekdays.int 0x7f} |
||||
{daysofmonth.int 0x7fffffff} |
||||
{months.int 0xfff} |
||||
} -maxleftover 0] |
||||
|
||||
|
||||
array set data [ITaskTrigger_GetTrigger $itt] |
||||
|
||||
if {[info exists opts(begindate)]} { |
||||
lassign [split $opts(begindate) -] year month day |
||||
# Note we trim leading zeroes else Tcl thinks its octal |
||||
set data(wBeginYear) [scan $year %d] |
||||
set data(wBeginMonth) [scan $month %d] |
||||
set data(wBeginDay) [scan $day %d] |
||||
} |
||||
|
||||
if {[info exists opts(starttime)]} { |
||||
lassign [split $opts(starttime) :] hour minute |
||||
# Note we trim leading zeroes else Tcl thinks its octal |
||||
set data(wStartHour) [scan $hour %d] |
||||
set data(wStartMinute) [scan $minute %d] |
||||
} |
||||
|
||||
if {[info exists opts(enddate)]} { |
||||
if {$opts(enddate) ne ""} { |
||||
setbits data(rgFlags) 1; # Indicate end date is present |
||||
lassign [split $opts(enddate) -] year month day |
||||
# Note we trim leading zeroes else Tcl thinks its octal |
||||
set data(wEndYear) [scan $year %d] |
||||
set data(wEndMonth) [scan $month %d] |
||||
set data(wEndDay) [scan $day %d] |
||||
} else { |
||||
resetbits data(rgFlags) 1; # Indicate no end date |
||||
} |
||||
} |
||||
|
||||
|
||||
if {[info exists opts(duration)]} { |
||||
set data(MinutesDuration) $opts(duration) |
||||
} |
||||
|
||||
if {[info exists opts(interval)]} { |
||||
set data(MinutesInterval) $opts(interval) |
||||
} |
||||
|
||||
if {[info exists opts(killatdurationend)]} { |
||||
if {$opts(killatdurationend)} { |
||||
setbits data(rgFlags) 2 |
||||
} else { |
||||
resetbits data(rgFlags) 2 |
||||
} |
||||
} |
||||
|
||||
if {[info exists opts(disabled)]} { |
||||
if {$opts(disabled)} { |
||||
setbits data(rgFlags) 4 |
||||
} else { |
||||
resetbits data(rgFlags) 4 |
||||
} |
||||
} |
||||
|
||||
# Note the type specific options are only used if -type is specified |
||||
if {[info exists opts(type)]} { |
||||
switch -exact -- $opts(type) { |
||||
once { |
||||
set data(type) [list 0] |
||||
} |
||||
daily { |
||||
set data(type) [list 1 $opts(period)] |
||||
} |
||||
weekly { |
||||
set data(type) [list 2 $opts(period) $opts(weekdays)] |
||||
} |
||||
monthlydate { |
||||
set data(type) [list 3 $opts(daysofmonth) $opts(months)] |
||||
} |
||||
monthlydow { |
||||
set data(type) [list 4 $opts(weekofmonth) $opts(weekdays) $opts(months)] |
||||
} |
||||
onidle { |
||||
set data(type) [list 5] |
||||
} |
||||
atsystemstart { |
||||
set data(type) [list 6] |
||||
} |
||||
atlogon { |
||||
set data(type) [list 7] |
||||
} |
||||
} |
||||
} |
||||
|
||||
ITaskTrigger_SetTrigger $itt [array get data] |
||||
return |
||||
} |
||||
|
||||
interp alias {} ::twapi::itasktrigger_release {} ::twapi::IUnknown_Release |
||||
|
||||
# Create a new task from scratch. Basically a wrapper around the |
||||
# corresponding itaskscheduler, itask and itasktrigger calls |
||||
proc twapi::mstask_create {taskname args} { |
||||
|
||||
# The options are a combination of itask_configure and |
||||
# itasktrigger_configure. |
||||
# Note the disabled option default to false explicitly. This is because |
||||
# the task trigger will default to disabled unless specifically set. |
||||
array set opts [parseargs args { |
||||
system.arg |
||||
application.arg |
||||
maxruntime.int |
||||
params.arg |
||||
priority.arg |
||||
workingdir.arg |
||||
account.arg |
||||
password.arg |
||||
comment.arg |
||||
creator.arg |
||||
data.arg |
||||
idlewait.int |
||||
idlewaitdeadline.int |
||||
interactive.bool |
||||
deletewhendone.bool |
||||
{disabled.bool false} |
||||
hidden.bool |
||||
runonlyifloggedon.bool |
||||
startonlyifidle.bool |
||||
resumesystem.bool |
||||
killonidleend.bool |
||||
restartonidleresume.bool |
||||
dontstartonbatteries.bool |
||||
killifonbatteries.bool |
||||
begindate.arg |
||||
enddate.arg |
||||
starttime.arg |
||||
interval.int |
||||
duration.int |
||||
killatdurationend.bool |
||||
type.arg |
||||
period.int |
||||
weekdays.int |
||||
daysofmonth.int |
||||
months.int |
||||
} -maxleftover 0] |
||||
|
||||
set its [itaskscheduler_new] |
||||
trap { |
||||
if {[info exists opts(system)]} { |
||||
itaskscheduler_set_target_system $opts(system) |
||||
} |
||||
|
||||
set itask [itaskscheduler_new_itask $its $taskname] |
||||
# Construct the command line for configuring the task |
||||
set cmd [list itask_configure $itask] |
||||
foreach opt { |
||||
application |
||||
maxruntime |
||||
params |
||||
priority |
||||
workingdir |
||||
account |
||||
password |
||||
comment |
||||
creator |
||||
data |
||||
idlewait |
||||
idlewaitdeadline |
||||
interactive |
||||
deletewhendone |
||||
disabled |
||||
hidden |
||||
runonlyifloggedon |
||||
startonlyifidle |
||||
resumesystem |
||||
killonidleend |
||||
restartonidleresume |
||||
dontstartonbatteries |
||||
killifonbatteries |
||||
} { |
||||
if {[info exists opts($opt)]} { |
||||
lappend cmd -$opt $opts($opt) |
||||
} |
||||
} |
||||
eval $cmd |
||||
|
||||
# Now get a trigger and configure it |
||||
set itt [lindex [itask_new_itasktrigger $itask] 1] |
||||
set cmd [list itasktrigger_configure $itt] |
||||
foreach opt { |
||||
begindate |
||||
enddate |
||||
interval |
||||
starttime |
||||
duration |
||||
killatdurationend |
||||
type |
||||
period |
||||
weekdays |
||||
daysofmonth |
||||
months |
||||
disabled |
||||
} { |
||||
if {[info exists opts($opt)]} { |
||||
lappend cmd -$opt $opts($opt) |
||||
} |
||||
} |
||||
eval $cmd |
||||
|
||||
# Save the task |
||||
itask_save $itask |
||||
|
||||
} finally { |
||||
IUnknown_Release $its |
||||
if {[info exists itask]} { |
||||
IUnknown_Release $itask |
||||
} |
||||
if {[info exists itt]} { |
||||
IUnknown_Release $itt |
||||
} |
||||
} |
||||
return |
||||
} |
||||
|
||||
# Delete a task |
||||
proc twapi::mstask_delete {taskname args} { |
||||
# The options are a combination of itask_configure and |
||||
# itasktrigger_configure |
||||
array set opts [parseargs args { |
||||
system.arg |
||||
} -maxleftover 0] |
||||
set its [itaskscheduler_new] |
||||
trap { |
||||
if {[info exists opts(system)]} { |
||||
itaskscheduler_set_target_system $opts(system) |
||||
} |
||||
itaskscheduler_delete_task $its $taskname |
||||
} finally { |
||||
IUnknown_Release $its |
||||
} |
||||
return |
||||
} |
||||
@ -0,0 +1,75 @@
|
||||
# |
||||
# Copyright (c) 2012 Ashok P. Nadkarni |
||||
# All rights reserved. |
||||
# |
||||
# See the file LICENSE for license |
||||
|
||||
# Generate sound for the specified duration |
||||
proc twapi::beep {args} { |
||||
array set opts [parseargs args { |
||||
{frequency.int 1000} |
||||
{duration.int 100} |
||||
{type.arg} |
||||
}] |
||||
|
||||
if {[info exists opts(type)]} { |
||||
switch -exact -- $opts(type) { |
||||
ok {MessageBeep 0} |
||||
hand {MessageBeep 0x10} |
||||
question {MessageBeep 0x20} |
||||
exclaimation {MessageBeep 0x30} |
||||
exclamation {MessageBeep 0x30} |
||||
asterisk {MessageBeep 0x40} |
||||
default {error "Unknown sound type '$opts(type)'"} |
||||
} |
||||
return |
||||
} |
||||
Beep $opts(frequency) $opts(duration) |
||||
return |
||||
} |
||||
|
||||
# Play the specified sound |
||||
proc twapi::play_sound {name args} { |
||||
array set opts [parseargs args { |
||||
alias |
||||
async |
||||
loop |
||||
nodefault |
||||
wait |
||||
nostop |
||||
}] |
||||
|
||||
if {$opts(alias)} { |
||||
set flags 0x00010000; #SND_ALIAS |
||||
} else { |
||||
set flags 0x00020000; #SND_FILENAME |
||||
} |
||||
if {$opts(loop)} { |
||||
# Note LOOP requires ASYNC |
||||
setbits flags 0x9; #SND_LOOP | SND_ASYNC |
||||
} else { |
||||
if {$opts(async)} { |
||||
setbits flags 0x0001; #SND_ASYNC |
||||
} else { |
||||
setbits flags 0x0000; #SND_SYNC |
||||
} |
||||
} |
||||
|
||||
if {$opts(nodefault)} { |
||||
setbits flags 0x0002; #SND_NODEFAULT |
||||
} |
||||
|
||||
if {! $opts(wait)} { |
||||
setbits flags 0x00002000; #SND_NOWAIT |
||||
} |
||||
|
||||
if {$opts(nostop)} { |
||||
setbits flags 0x0010; #SND_NOSTOP |
||||
} |
||||
|
||||
return [PlaySound $name 0 $flags] |
||||
} |
||||
|
||||
proc twapi::stop_sound {} { |
||||
PlaySound "" 0 0x0040; #SND_PURGE |
||||
} |
||||
@ -0,0 +1,103 @@
|
||||
# |
||||
# Copyright (c) 2010-2011, Ashok P. Nadkarni |
||||
# All rights reserved. |
||||
# |
||||
# See the file LICENSE for license |
||||
|
||||
# Implementation of named pipes |
||||
|
||||
proc twapi::namedpipe_server {name args} { |
||||
set name [file nativename $name] |
||||
|
||||
# Only byte mode currently supported. Message mode does |
||||
# not mesh well with Tcl channel infrastructure. |
||||
# readmode.arg |
||||
# writemode.arg |
||||
|
||||
array set opts [twapi::parseargs args { |
||||
{access.arg {read write}} |
||||
{writedacl 0 0x00040000} |
||||
{writeowner 0 0x00080000} |
||||
{writesacl 0 0x01000000} |
||||
{writethrough 0 0x80000000} |
||||
denyremote |
||||
{timeout.int 50} |
||||
{maxinstances.int 255} |
||||
{secd.arg {}} |
||||
{inherit.bool 0} |
||||
} -maxleftover 0] |
||||
|
||||
# 0x40000000 -> OVERLAPPED I/O |
||||
set open_mode [expr { |
||||
[twapi::_parse_symbolic_bitmask $opts(access) {read 1 write 2}] | |
||||
$opts(writedacl) | $opts(writeowner) | |
||||
$opts(writesacl) | $opts(writethrough) | |
||||
0x40000000 |
||||
}] |
||||
|
||||
set pipe_mode 0 |
||||
if {$opts(denyremote)} { |
||||
if {! [twapi::min_os_version 6]} { |
||||
error "Option -denyremote not supported on this operating system." |
||||
} |
||||
set pipe_mode [expr {$pipe_mode | 8}] |
||||
} |
||||
|
||||
return [twapi::Twapi_NPipeServer $name $open_mode $pipe_mode \ |
||||
$opts(maxinstances) 4000 4000 $opts(timeout) \ |
||||
[_make_secattr $opts(secd) $opts(inherit)]] |
||||
} |
||||
|
||||
proc twapi::namedpipe_client {name args} { |
||||
set name [file nativename $name] |
||||
|
||||
# Only byte mode currently supported. Message mode does |
||||
# not mesh well with Tcl channel infrastructure. |
||||
# readmode.arg |
||||
# writemode.arg |
||||
|
||||
array set opts [twapi::parseargs args { |
||||
{access.arg {read write}} |
||||
impersonationlevel.arg |
||||
{impersonateeffectiveonly.bool false 0x00080000} |
||||
{impersonatecontexttracking.bool false 0x00040000} |
||||
} -maxleftover 0] |
||||
|
||||
# FILE_READ_DATA 0x00000001 |
||||
# FILE_WRITE_DATA 0x00000002 |
||||
# Note - use _parse_symbolic_bitmask because we allow user to specify |
||||
# numeric masks as well |
||||
set desired_access [twapi::_parse_symbolic_bitmask $opts(access) { |
||||
read 1 |
||||
write 2 |
||||
}] |
||||
|
||||
set flags 0 |
||||
if {[info exists opts(impersonationlevel)]} { |
||||
switch -exact -- $opts(impersonationlevel) { |
||||
anonymous { set flags 0x00100000 } |
||||
identification { set flags 0x00110000 } |
||||
impersonation { set flags 0x00120000 } |
||||
delegation { set flags 0x00130000 } |
||||
default { |
||||
# ERROR_BAD_IMPERSONATION_LEVEL |
||||
win32_error 1346 "Invalid impersonation level '$opts(impersonationlevel)'." |
||||
} |
||||
} |
||||
set flags [expr {$flags | $opts(impersonateeffectiveonly) | |
||||
$opts(impersonatecontexttracking)}] |
||||
} |
||||
|
||||
set share_mode 0; # Share none |
||||
set secattr {}; # At some point use this for "inherit" flag |
||||
set create_disposition 3; # OPEN_EXISTING |
||||
return [twapi::Twapi_NPipeClient $name $desired_access $share_mode \ |
||||
$secattr $create_disposition $flags] |
||||
} |
||||
|
||||
# Impersonate a named pipe client |
||||
proc twapi::impersonate_namedpipe_client {chan} { |
||||
set h [get_tcl_channel_handle $chan read] |
||||
ImpersonateNamedPipeClient $h |
||||
} |
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,467 @@
|
||||
# |
||||
# Copyright (c) 2003-2013, Ashok P. Nadkarni |
||||
# All rights reserved. |
||||
# |
||||
# See the file LICENSE for license |
||||
|
||||
namespace eval twapi {} |
||||
|
||||
# Compatibility alias |
||||
interp alias {} twapi::get_user_default_langid {} twapi::get_user_langid |
||||
interp alias {} twapi::get_system_default_langid {} twapi::get_system_langid |
||||
|
||||
# |
||||
# Format a number |
||||
proc twapi::format_number {number lcid args} { |
||||
|
||||
set number [_verify_number_format $number] |
||||
|
||||
set lcid [_map_default_lcid_token $lcid] |
||||
|
||||
# If no options specified, format according to the passed locale |
||||
if {[llength $args] == 0} { |
||||
return [GetNumberFormat 1 $lcid 0 $number 0 0 0 . "" 0] |
||||
} |
||||
|
||||
array set opts [parseargs args { |
||||
idigits.int |
||||
ilzero.bool |
||||
sgrouping.int |
||||
sdecimal.arg |
||||
sthousand.arg |
||||
inegnumber.int |
||||
}] |
||||
|
||||
# Check the locale for unspecified options |
||||
foreach opt {idigits ilzero sgrouping sdecimal sthousand inegnumber} { |
||||
if {![info exists opts($opt)]} { |
||||
set opts($opt) [lindex [get_locale_info $lcid -$opt] 1] |
||||
} |
||||
} |
||||
|
||||
# If number of decimals is -1, see how many decimal places |
||||
# in passed string |
||||
if {$opts(idigits) == -1} { |
||||
lassign [split $number .] whole frac |
||||
set opts(idigits) [string length $frac] |
||||
} |
||||
|
||||
# Convert Locale format for grouping to integer calue |
||||
if {![string is integer $opts(sgrouping)]} { |
||||
# Format assumed to be of the form "N;M;....;0" |
||||
set grouping 0 |
||||
foreach n [split $opts(sgrouping) {;}] { |
||||
if {$n == 0} break |
||||
set grouping [expr {$n + 10*$grouping}] |
||||
} |
||||
set opts(sgrouping) $grouping |
||||
} |
||||
|
||||
set flags 0 |
||||
if {[info exists opts(nouseroverride)] && $opts(nouseroverride)} { |
||||
setbits flags 0x80000000 |
||||
} |
||||
return [GetNumberFormat 0 $lcid $flags $number $opts(idigits) \ |
||||
$opts(ilzero) $opts(sgrouping) $opts(sdecimal) \ |
||||
$opts(sthousand) $opts(inegnumber)] |
||||
} |
||||
|
||||
|
||||
# |
||||
# Format currency |
||||
proc twapi::format_currency {number lcid args} { |
||||
|
||||
set number [_verify_number_format $number] |
||||
|
||||
# Get semi-canonical form (get rid of preceding "+" etc.) |
||||
# Also verifies number syntax |
||||
set number [expr {$number+0}]; |
||||
|
||||
set lcid [_map_default_lcid_token $lcid] |
||||
|
||||
# If no options specified, format according to the passed locale |
||||
if {[llength $args] == 0} { |
||||
return [GetCurrencyFormat 1 $lcid 0 $number 0 0 0 . "" 0 0 ""] |
||||
} |
||||
|
||||
array set opts [parseargs args { |
||||
idigits.int |
||||
ilzero.bool |
||||
sgrouping.int |
||||
sdecimal.arg |
||||
sthousand.arg |
||||
inegcurr.int |
||||
icurrency.int |
||||
scurrency.arg |
||||
}] |
||||
|
||||
# Check the locale for unspecified options |
||||
foreach opt {idigits ilzero sgrouping sdecimal sthousand inegcurr icurrency scurrency} { |
||||
if {![info exists opts($opt)]} { |
||||
set opts($opt) [lindex [get_locale_info $lcid -$opt] 1] |
||||
} |
||||
} |
||||
|
||||
# If number of decimals is -1, see how many decimal places |
||||
# in passed string |
||||
if {$opts(idigits) == -1} { |
||||
lassign [split $number .] whole frac |
||||
set opts(idigits) [string length $frac] |
||||
} |
||||
|
||||
# Convert Locale format for grouping to integer calue |
||||
if {![string is integer $opts(sgrouping)]} { |
||||
# Format assumed to be of the form "N;M;....;0" |
||||
set grouping 0 |
||||
foreach n [split $opts(sgrouping) {;}] { |
||||
if {$n == 0} break |
||||
set grouping [expr {$n + 10*$grouping}] |
||||
} |
||||
set opts(sgrouping) $grouping |
||||
} |
||||
|
||||
set flags 0 |
||||
if {[info exists opts(nouseroverride)] && $opts(nouseroverride)} { |
||||
setbits flags 0x80000000 |
||||
} |
||||
|
||||
return [GetCurrencyFormat 0 $lcid $flags $number $opts(idigits) \ |
||||
$opts(ilzero) $opts(sgrouping) $opts(sdecimal) \ |
||||
$opts(sthousand) $opts(inegcurr) \ |
||||
$opts(icurrency) $opts(scurrency)] |
||||
} |
||||
|
||||
|
||||
# |
||||
# Get various info about a locale |
||||
proc twapi::get_locale_info {lcid args} { |
||||
|
||||
set lcid [_map_default_lcid_token $lcid] |
||||
|
||||
variable locale_info_class_map |
||||
if {![info exists locale_info_class_map]} { |
||||
# TBD - ilanguage not recommended for Vista. Remove it? |
||||
array set locale_info_class_map { |
||||
ilanguage 0x00000001 |
||||
slanguage 0x00000002 |
||||
senglanguage 0x00001001 |
||||
sabbrevlangname 0x00000003 |
||||
snativelangname 0x00000004 |
||||
icountry 0x00000005 |
||||
scountry 0x00000006 |
||||
sengcountry 0x00001002 |
||||
sabbrevctryname 0x00000007 |
||||
snativectryname 0x00000008 |
||||
idefaultlanguage 0x00000009 |
||||
idefaultcountry 0x0000000A |
||||
idefaultcodepage 0x0000000B |
||||
idefaultansicodepage 0x00001004 |
||||
idefaultmaccodepage 0x00001011 |
||||
slist 0x0000000C |
||||
imeasure 0x0000000D |
||||
sdecimal 0x0000000E |
||||
sthousand 0x0000000F |
||||
sgrouping 0x00000010 |
||||
idigits 0x00000011 |
||||
ilzero 0x00000012 |
||||
inegnumber 0x00001010 |
||||
snativedigits 0x00000013 |
||||
scurrency 0x00000014 |
||||
sintlsymbol 0x00000015 |
||||
smondecimalsep 0x00000016 |
||||
smonthousandsep 0x00000017 |
||||
smongrouping 0x00000018 |
||||
icurrdigits 0x00000019 |
||||
iintlcurrdigits 0x0000001A |
||||
icurrency 0x0000001B |
||||
inegcurr 0x0000001C |
||||
sdate 0x0000001D |
||||
stime 0x0000001E |
||||
sshortdate 0x0000001F |
||||
slongdate 0x00000020 |
||||
stimeformat 0x00001003 |
||||
idate 0x00000021 |
||||
ildate 0x00000022 |
||||
itime 0x00000023 |
||||
itimemarkposn 0x00001005 |
||||
icentury 0x00000024 |
||||
itlzero 0x00000025 |
||||
idaylzero 0x00000026 |
||||
imonlzero 0x00000027 |
||||
s1159 0x00000028 |
||||
s2359 0x00000029 |
||||
icalendartype 0x00001009 |
||||
ioptionalcalendar 0x0000100B |
||||
ifirstdayofweek 0x0000100C |
||||
ifirstweekofyear 0x0000100D |
||||
sdayname1 0x0000002A |
||||
sdayname2 0x0000002B |
||||
sdayname3 0x0000002C |
||||
sdayname4 0x0000002D |
||||
sdayname5 0x0000002E |
||||
sdayname6 0x0000002F |
||||
sdayname7 0x00000030 |
||||
sabbrevdayname1 0x00000031 |
||||
sabbrevdayname2 0x00000032 |
||||
sabbrevdayname3 0x00000033 |
||||
sabbrevdayname4 0x00000034 |
||||
sabbrevdayname5 0x00000035 |
||||
sabbrevdayname6 0x00000036 |
||||
sabbrevdayname7 0x00000037 |
||||
smonthname1 0x00000038 |
||||
smonthname2 0x00000039 |
||||
smonthname3 0x0000003A |
||||
smonthname4 0x0000003B |
||||
smonthname5 0x0000003C |
||||
smonthname6 0x0000003D |
||||
smonthname7 0x0000003E |
||||
smonthname8 0x0000003F |
||||
smonthname9 0x00000040 |
||||
smonthname10 0x00000041 |
||||
smonthname11 0x00000042 |
||||
smonthname12 0x00000043 |
||||
smonthname13 0x0000100E |
||||
sabbrevmonthname1 0x00000044 |
||||
sabbrevmonthname2 0x00000045 |
||||
sabbrevmonthname3 0x00000046 |
||||
sabbrevmonthname4 0x00000047 |
||||
sabbrevmonthname5 0x00000048 |
||||
sabbrevmonthname6 0x00000049 |
||||
sabbrevmonthname7 0x0000004A |
||||
sabbrevmonthname8 0x0000004B |
||||
sabbrevmonthname9 0x0000004C |
||||
sabbrevmonthname10 0x0000004D |
||||
sabbrevmonthname11 0x0000004E |
||||
sabbrevmonthname12 0x0000004F |
||||
sabbrevmonthname13 0x0000100F |
||||
spositivesign 0x00000050 |
||||
snegativesign 0x00000051 |
||||
ipossignposn 0x00000052 |
||||
inegsignposn 0x00000053 |
||||
ipossymprecedes 0x00000054 |
||||
ipossepbyspace 0x00000055 |
||||
inegsymprecedes 0x00000056 |
||||
inegsepbyspace 0x00000057 |
||||
fontsignature 0x00000058 |
||||
siso639langname 0x00000059 |
||||
siso3166ctryname 0x0000005A |
||||
idefaultebcdiccodepage 0x00001012 |
||||
ipapersize 0x0000100A |
||||
sengcurrname 0x00001007 |
||||
snativecurrname 0x00001008 |
||||
syearmonth 0x00001006 |
||||
ssortname 0x00001013 |
||||
idigitsubstitution 0x00001014 |
||||
} |
||||
} |
||||
|
||||
# array set opts [parseargs args [array names locale_info_class_map]] |
||||
|
||||
set result [list ] |
||||
foreach opt $args { |
||||
lappend result $opt [GetLocaleInfo $lcid $locale_info_class_map([string range $opt 1 end])] |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
|
||||
proc twapi::map_code_page_to_name {cp} { |
||||
set code_page_names { |
||||
0 "System ANSI default" |
||||
1 "System OEM default" |
||||
37 "IBM EBCDIC - U.S./Canada" |
||||
437 "OEM - United States" |
||||
500 "IBM EBCDIC - International" |
||||
708 "Arabic - ASMO 708" |
||||
709 "Arabic - ASMO 449+, BCON V4" |
||||
710 "Arabic - Transparent Arabic" |
||||
720 "Arabic - Transparent ASMO" |
||||
737 "OEM - Greek (formerly 437G)" |
||||
775 "OEM - Baltic" |
||||
850 "OEM - Multilingual Latin I" |
||||
852 "OEM - Latin II" |
||||
855 "OEM - Cyrillic (primarily Russian)" |
||||
857 "OEM - Turkish" |
||||
858 "OEM - Multlingual Latin I + Euro symbol" |
||||
860 "OEM - Portuguese" |
||||
861 "OEM - Icelandic" |
||||
862 "OEM - Hebrew" |
||||
863 "OEM - Canadian-French" |
||||
864 "OEM - Arabic" |
||||
865 "OEM - Nordic" |
||||
866 "OEM - Russian" |
||||
869 "OEM - Modern Greek" |
||||
870 "IBM EBCDIC - Multilingual/ROECE (Latin-2)" |
||||
874 "ANSI/OEM - Thai (same as 28605, ISO 8859-15)" |
||||
875 "IBM EBCDIC - Modern Greek" |
||||
932 "ANSI/OEM - Japanese, Shift-JIS" |
||||
936 "ANSI/OEM - Simplified Chinese (PRC, Singapore)" |
||||
949 "ANSI/OEM - Korean (Unified Hangeul Code)" |
||||
950 "ANSI/OEM - Traditional Chinese (Taiwan; Hong Kong SAR, PRC)" |
||||
1026 "IBM EBCDIC - Turkish (Latin-5)" |
||||
1047 "IBM EBCDIC - Latin 1/Open System" |
||||
1140 "IBM EBCDIC - U.S./Canada (037 + Euro symbol)" |
||||
1141 "IBM EBCDIC - Germany (20273 + Euro symbol)" |
||||
1142 "IBM EBCDIC - Denmark/Norway (20277 + Euro symbol)" |
||||
1143 "IBM EBCDIC - Finland/Sweden (20278 + Euro symbol)" |
||||
1144 "IBM EBCDIC - Italy (20280 + Euro symbol)" |
||||
1145 "IBM EBCDIC - Latin America/Spain (20284 + Euro symbol)" |
||||
1146 "IBM EBCDIC - United Kingdom (20285 + Euro symbol)" |
||||
1147 "IBM EBCDIC - France (20297 + Euro symbol)" |
||||
1148 "IBM EBCDIC - International (500 + Euro symbol)" |
||||
1149 "IBM EBCDIC - Icelandic (20871 + Euro symbol)" |
||||
1200 "Unicode UCS-2 Little-Endian (BMP of ISO 10646)" |
||||
1201 "Unicode UCS-2 Big-Endian" |
||||
1250 "ANSI - Central European" |
||||
1251 "ANSI - Cyrillic" |
||||
1252 "ANSI - Latin I" |
||||
1253 "ANSI - Greek" |
||||
1254 "ANSI - Turkish" |
||||
1255 "ANSI - Hebrew" |
||||
1256 "ANSI - Arabic" |
||||
1257 "ANSI - Baltic" |
||||
1258 "ANSI/OEM - Vietnamese" |
||||
1361 "Korean (Johab)" |
||||
10000 "MAC - Roman" |
||||
10001 "MAC - Japanese" |
||||
10002 "MAC - Traditional Chinese (Big5)" |
||||
10003 "MAC - Korean" |
||||
10004 "MAC - Arabic" |
||||
10005 "MAC - Hebrew" |
||||
10006 "MAC - Greek I" |
||||
10007 "MAC - Cyrillic" |
||||
10008 "MAC - Simplified Chinese (GB 2312)" |
||||
10010 "MAC - Romania" |
||||
10017 "MAC - Ukraine" |
||||
10021 "MAC - Thai" |
||||
10029 "MAC - Latin II" |
||||
10079 "MAC - Icelandic" |
||||
10081 "MAC - Turkish" |
||||
10082 "MAC - Croatia" |
||||
12000 "Unicode UCS-4 Little-Endian" |
||||
12001 "Unicode UCS-4 Big-Endian" |
||||
20000 "CNS - Taiwan" |
||||
20001 "TCA - Taiwan" |
||||
20002 "Eten - Taiwan" |
||||
20003 "IBM5550 - Taiwan" |
||||
20004 "TeleText - Taiwan" |
||||
20005 "Wang - Taiwan" |
||||
20105 "IA5 IRV International Alphabet No. 5 (7-bit)" |
||||
20106 "IA5 German (7-bit)" |
||||
20107 "IA5 Swedish (7-bit)" |
||||
20108 "IA5 Norwegian (7-bit)" |
||||
20127 "US-ASCII (7-bit)" |
||||
20261 "T.61" |
||||
20269 "ISO 6937 Non-Spacing Accent" |
||||
20273 "IBM EBCDIC - Germany" |
||||
20277 "IBM EBCDIC - Denmark/Norway" |
||||
20278 "IBM EBCDIC - Finland/Sweden" |
||||
20280 "IBM EBCDIC - Italy" |
||||
20284 "IBM EBCDIC - Latin America/Spain" |
||||
20285 "IBM EBCDIC - United Kingdom" |
||||
20290 "IBM EBCDIC - Japanese Katakana Extended" |
||||
20297 "IBM EBCDIC - France" |
||||
20420 "IBM EBCDIC - Arabic" |
||||
20423 "IBM EBCDIC - Greek" |
||||
20424 "IBM EBCDIC - Hebrew" |
||||
20833 "IBM EBCDIC - Korean Extended" |
||||
20838 "IBM EBCDIC - Thai" |
||||
20866 "Russian - KOI8-R" |
||||
20871 "IBM EBCDIC - Icelandic" |
||||
20880 "IBM EBCDIC - Cyrillic (Russian)" |
||||
20905 "IBM EBCDIC - Turkish" |
||||
20924 "IBM EBCDIC - Latin-1/Open System (1047 + Euro symbol)" |
||||
20932 "JIS X 0208-1990 & 0121-1990" |
||||
20936 "Simplified Chinese (GB2312)" |
||||
21025 "IBM EBCDIC - Cyrillic (Serbian, Bulgarian)" |
||||
21027 "Extended Alpha Lowercase" |
||||
21866 "Ukrainian (KOI8-U)" |
||||
28591 "ISO 8859-1 Latin I" |
||||
28592 "ISO 8859-2 Central Europe" |
||||
28593 "ISO 8859-3 Latin 3" |
||||
28594 "ISO 8859-4 Baltic" |
||||
28595 "ISO 8859-5 Cyrillic" |
||||
28596 "ISO 8859-6 Arabic" |
||||
28597 "ISO 8859-7 Greek" |
||||
28598 "ISO 8859-8 Hebrew" |
||||
28599 "ISO 8859-9 Latin 5" |
||||
28605 "ISO 8859-15 Latin 9" |
||||
29001 "Europa 3" |
||||
38598 "ISO 8859-8 Hebrew" |
||||
50220 "ISO 2022 Japanese with no halfwidth Katakana" |
||||
50221 "ISO 2022 Japanese with halfwidth Katakana" |
||||
50222 "ISO 2022 Japanese JIS X 0201-1989" |
||||
50225 "ISO 2022 Korean" |
||||
50227 "ISO 2022 Simplified Chinese" |
||||
50229 "ISO 2022 Traditional Chinese" |
||||
50930 "Japanese (Katakana) Extended" |
||||
50931 "US/Canada and Japanese" |
||||
50933 "Korean Extended and Korean" |
||||
50935 "Simplified Chinese Extended and Simplified Chinese" |
||||
50936 "Simplified Chinese" |
||||
50937 "US/Canada and Traditional Chinese" |
||||
50939 "Japanese (Latin) Extended and Japanese" |
||||
51932 "EUC - Japanese" |
||||
51936 "EUC - Simplified Chinese" |
||||
51949 "EUC - Korean" |
||||
51950 "EUC - Traditional Chinese" |
||||
52936 "HZ-GB2312 Simplified Chinese" |
||||
54936 "Windows XP: GB18030 Simplified Chinese (4 Byte)" |
||||
57002 "ISCII Devanagari" |
||||
57003 "ISCII Bengali" |
||||
57004 "ISCII Tamil" |
||||
57005 "ISCII Telugu" |
||||
57006 "ISCII Assamese" |
||||
57007 "ISCII Oriya" |
||||
57008 "ISCII Kannada" |
||||
57009 "ISCII Malayalam" |
||||
57010 "ISCII Gujarati" |
||||
57011 "ISCII Punjabi" |
||||
65000 "Unicode UTF-7" |
||||
65001 "Unicode UTF-8" |
||||
} |
||||
|
||||
# TBD - isn't there a Win32 function to do this ? |
||||
set cp [expr {0+$cp}] |
||||
if {[dict exists $code_page_names $cp]} { |
||||
return [dict get $code_page_names $cp] |
||||
} else { |
||||
return "Code page $cp" |
||||
} |
||||
} |
||||
|
||||
# |
||||
# Get the name of a language |
||||
interp alias {} twapi::map_langid_to_name {} twapi::VerLanguageName |
||||
|
||||
# |
||||
# Extract language and sublanguage values |
||||
proc twapi::extract_primary_langid {langid} { |
||||
return [expr {$langid & 0x3ff}] |
||||
} |
||||
proc twapi::extract_sublanguage_langid {langid} { |
||||
return [expr {($langid >> 10) & 0x3f}] |
||||
} |
||||
|
||||
# |
||||
# Utility functions |
||||
|
||||
proc twapi::_map_default_lcid_token {lcid} { |
||||
if {$lcid == "systemdefault"} { |
||||
return 2048 |
||||
} elseif {$lcid == "userdefault"} { |
||||
return 1024 |
||||
} |
||||
return $lcid |
||||
} |
||||
|
||||
proc twapi::_verify_number_format {n} { |
||||
set n [string trimleft $n 0] |
||||
if {[regexp {^[+-]?[[:digit:]]*(\.)?[[:digit:]]*$} $n]} { |
||||
return $n |
||||
} else { |
||||
error "Invalid numeric format. Must be of a sequence of digits with an optional decimal point and leading plus/minus sign" |
||||
} |
||||
} |
||||
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,984 @@
|
||||
# |
||||
# Copyright (c) 2003-2014, Ashok P. Nadkarni |
||||
# All rights reserved. |
||||
# |
||||
# See the file LICENSE for license |
||||
|
||||
namespace eval twapi { |
||||
} |
||||
|
||||
# |
||||
# Return list of toplevel performance objects |
||||
proc twapi::pdh_enumerate_objects {args} { |
||||
|
||||
array set opts [parseargs args { |
||||
datasource.arg |
||||
machine.arg |
||||
{detail.arg wizard} |
||||
refresh |
||||
} -nulldefault] |
||||
|
||||
# TBD - PdhEnumObjects enables the SeDebugPrivilege the first time it |
||||
# is called. Should we reset it if it was not already enabled? |
||||
# This seems to only happen on the first call |
||||
|
||||
return [PdhEnumObjects $opts(datasource) $opts(machine) \ |
||||
[_perf_detail_sym_to_val $opts(detail)] \ |
||||
$opts(refresh)] |
||||
} |
||||
|
||||
proc twapi::_pdh_enumerate_object_items_helper {selector objname args} { |
||||
array set opts [parseargs args { |
||||
datasource.arg |
||||
machine.arg |
||||
{detail.arg wizard} |
||||
refresh |
||||
} -nulldefault] |
||||
|
||||
if {$opts(refresh)} { |
||||
_refresh_perf_objects $opts(machine) $opts(datasource) |
||||
} |
||||
|
||||
return [PdhEnumObjectItems $opts(datasource) $opts(machine) \ |
||||
$objname \ |
||||
[_perf_detail_sym_to_val $opts(detail)] \ |
||||
$selector] |
||||
} |
||||
|
||||
interp alias {} twapi::pdh_enumerate_object_items {} twapi::_pdh_enumerate_object_items_helper 0 |
||||
interp alias {} twapi::pdh_enumerate_object_counters {} twapi::_pdh_enumerate_object_items_helper 1 |
||||
interp alias {} twapi::pdh_enumerate_object_instances {} twapi::_pdh_enumerate_object_items_helper 2 |
||||
|
||||
|
||||
# |
||||
# Construct a counter path |
||||
proc twapi::pdh_counter_path {object counter args} { |
||||
array set opts [parseargs args { |
||||
machine.arg |
||||
instance.arg |
||||
parent.arg |
||||
{instanceindex.int -1} |
||||
{localized.bool false} |
||||
} -nulldefault] |
||||
|
||||
if {$opts(instanceindex) == 0} { |
||||
# For XP. For first instance (index 0), the path should not contain |
||||
# "#0" but on XP it does. Reset it to -1 for Vista+ consistency |
||||
set opts(instanceindex) -1 |
||||
} |
||||
|
||||
|
||||
if {! $opts(localized)} { |
||||
# Need to localize the counter names |
||||
set object [_pdh_localize $object] |
||||
set counter [_pdh_localize $counter] |
||||
# TBD - not sure we need to localize parent |
||||
set opts(parent) [_pdh_localize $opts(parent)] |
||||
} |
||||
|
||||
# TBD - add options PDH_PATH_WBEM as documented in PdhMakeCounterPath |
||||
return [PdhMakeCounterPath $opts(machine) $object $opts(instance) \ |
||||
$opts(parent) $opts(instanceindex) $counter 0] |
||||
|
||||
} |
||||
|
||||
# |
||||
# Parse a counter path and return the individual elements |
||||
proc twapi::pdh_parse_counter_path {counter_path} { |
||||
return [twine {machine object instance parent instanceindex counter} [PdhParseCounterPath $counter_path 0]] |
||||
} |
||||
|
||||
|
||||
interp alias {} twapi::pdh_get_scalar {} twapi::_pdh_get 1 |
||||
interp alias {} twapi::pdh_get_array {} twapi::_pdh_get 0 |
||||
|
||||
proc twapi::_pdh_get {scalar hcounter args} { |
||||
|
||||
array set opts [parseargs args { |
||||
{format.arg large {long large double}} |
||||
{scale.arg {} {{} none x1000 nocap100}} |
||||
var.arg |
||||
} -ignoreunknown -nulldefault] |
||||
|
||||
set flags [_pdh_fmt_sym_to_val $opts(format)] |
||||
|
||||
if {$opts(scale) ne ""} { |
||||
set flags [expr {$flags | [_pdh_fmt_sym_to_val $opts(scale)]}] |
||||
} |
||||
|
||||
set status 1 |
||||
set result "" |
||||
trap { |
||||
if {$scalar} { |
||||
set result [PdhGetFormattedCounterValue $hcounter $flags] |
||||
} else { |
||||
set result [PdhGetFormattedCounterArray $hcounter $flags] |
||||
} |
||||
} onerror {TWAPI_WIN32 0x800007d1} { |
||||
# Error is that no such instance exists. |
||||
# If result is being returned in a variable, then |
||||
# we will not generate an error but pass back a return value |
||||
# of 0 |
||||
if {[string length $opts(var)] == 0} { |
||||
rethrow |
||||
} |
||||
set status 0 |
||||
} |
||||
|
||||
if {[string length $opts(var)]} { |
||||
uplevel [list set $opts(var) $result] |
||||
return $status |
||||
} else { |
||||
return $result |
||||
} |
||||
} |
||||
|
||||
# |
||||
# Get the value of a counter identified by the path. |
||||
# Should not be used to collect |
||||
# rate based options. |
||||
# TBD - document |
||||
proc twapi::pdh_counter_path_value {counter_path args} { |
||||
|
||||
array set opts [parseargs args { |
||||
{format.arg long} |
||||
scale.arg |
||||
datasource.arg |
||||
var.arg |
||||
full.bool |
||||
} -nulldefault] |
||||
|
||||
# Open the query |
||||
set hquery [pdh_query_open -datasource $opts(datasource)] |
||||
trap { |
||||
set hcounter [pdh_add_counter $hquery $counter_path] |
||||
pdh_query_refresh $hquery |
||||
if {[string length $opts(var)]} { |
||||
# Need to pass up value in a variable if so requested |
||||
upvar $opts(var) myvar |
||||
set opts(var) myvar |
||||
} |
||||
set value [pdh_get_scalar $hcounter -format $opts(format) \ |
||||
-scale $opts(scale) -full $opts(full) \ |
||||
-var $opts(var)] |
||||
} finally { |
||||
pdh_query_close $hquery |
||||
} |
||||
|
||||
return $value |
||||
} |
||||
|
||||
|
||||
# |
||||
# Constructs one or more counter paths for getting process information. |
||||
# Returned as a list of sublists. Each sublist corresponds to a counter path |
||||
# and has the form {counteroptionname datatype counterpath rate} |
||||
# datatype is the recommended format when retrieving counter value (eg. double) |
||||
# rate is 0 or 1 depending on whether the counter is a rate based counter or |
||||
# not (requires at least two readings when getting the value) |
||||
proc twapi::get_perf_process_counter_paths {pids args} { |
||||
variable _process_counter_opt_map |
||||
|
||||
if {![info exists _counter_opt_map]} { |
||||
# "descriptive string" format rate |
||||
array set _process_counter_opt_map { |
||||
privilegedutilization {"% Privileged Time" double 1} |
||||
processorutilization {"% Processor Time" double 1} |
||||
userutilization {"% User Time" double 1} |
||||
parent {"Creating Process ID" long 0} |
||||
elapsedtime {"Elapsed Time" large 0} |
||||
handlecount {"Handle Count" long 0} |
||||
pid {"ID Process" long 0} |
||||
iodatabytesrate {"IO Data Bytes/sec" large 1} |
||||
iodataopsrate {"IO Data Operations/sec" large 1} |
||||
iootherbytesrate {"IO Other Bytes/sec" large 1} |
||||
iootheropsrate {"IO Other Operations/sec" large 1} |
||||
ioreadbytesrate {"IO Read Bytes/sec" large 1} |
||||
ioreadopsrate {"IO Read Operations/sec" large 1} |
||||
iowritebytesrate {"IO Write Bytes/sec" large 1} |
||||
iowriteopsrate {"IO Write Operations/sec" large 1} |
||||
pagefaultrate {"Page Faults/sec" large 1} |
||||
pagefilebytes {"Page File Bytes" large 0} |
||||
pagefilebytespeak {"Page File Bytes Peak" large 0} |
||||
poolnonpagedbytes {"Pool Nonpaged Bytes" large 0} |
||||
poolpagedbytes {"Pool Paged Bytes" large 1} |
||||
basepriority {"Priority Base" large 1} |
||||
privatebytes {"Private Bytes" large 1} |
||||
threadcount {"Thread Count" large 1} |
||||
virtualbytes {"Virtual Bytes" large 1} |
||||
virtualbytespeak {"Virtual Bytes Peak" large 1} |
||||
workingset {"Working Set" large 1} |
||||
workingsetpeak {"Working Set Peak" large 1} |
||||
} |
||||
} |
||||
|
||||
set optdefs { |
||||
machine.arg |
||||
datasource.arg |
||||
all |
||||
refresh |
||||
} |
||||
|
||||
# Add counter names to option list |
||||
foreach cntr [array names _process_counter_opt_map] { |
||||
lappend optdefs $cntr |
||||
} |
||||
|
||||
# Parse options |
||||
array set opts [parseargs args $optdefs -nulldefault] |
||||
|
||||
# Force a refresh of object items |
||||
if {$opts(refresh)} { |
||||
# Silently ignore. The above counters are predefined and refreshing |
||||
# is just a time-consuming no-op. Keep the option for backward |
||||
# compatibility |
||||
if {0} { |
||||
_refresh_perf_objects $opts(machine) $opts(datasource) |
||||
} |
||||
} |
||||
|
||||
# TBD - could we not use get_perf_instance_counter_paths instead of rest of this code |
||||
|
||||
# Get the path to the process. |
||||
set pid_paths [get_perf_counter_paths \ |
||||
[_pdh_localize "Process"] \ |
||||
[list [_pdh_localize "ID Process"]] \ |
||||
$pids \ |
||||
-machine $opts(machine) -datasource $opts(datasource) \ |
||||
-all] |
||||
|
||||
if {[llength $pid_paths] == 0} { |
||||
# No thread |
||||
return [list ] |
||||
} |
||||
|
||||
# Construct the requested counter paths |
||||
set counter_paths [list ] |
||||
foreach {pid pid_path} $pid_paths { |
||||
|
||||
# We have to filter out an entry for _Total which might be present |
||||
# if pid includes "0" |
||||
# TBD - does _Total need to be localized? |
||||
if {$pid == 0 && [string match -nocase *_Total\#0* $pid_path]} { |
||||
continue |
||||
} |
||||
|
||||
# Break it down into components and store in array |
||||
array set path_components [pdh_parse_counter_path $pid_path] |
||||
|
||||
# Construct counter paths for this pid |
||||
foreach {opt counter_info} [array get _process_counter_opt_map] { |
||||
if {$opts(all) || $opts($opt)} { |
||||
lappend counter_paths \ |
||||
[list -$opt $pid [lindex $counter_info 1] \ |
||||
[pdh_counter_path $path_components(object) \ |
||||
[_pdh_localize [lindex $counter_info 0]] \ |
||||
-localized true \ |
||||
-machine $path_components(machine) \ |
||||
-parent $path_components(parent) \ |
||||
-instance $path_components(instance) \ |
||||
-instanceindex $path_components(instanceindex)] \ |
||||
[lindex $counter_info 2] \ |
||||
] |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $counter_paths |
||||
} |
||||
|
||||
|
||||
# Returns the counter path for the process with the given pid. This includes |
||||
# the pid counter path element |
||||
proc twapi::get_perf_process_id_path {pid args} { |
||||
return [get_unique_counter_path \ |
||||
[_pdh_localize "Process"] \ |
||||
[_pdh_localize "ID Process"] $pid] |
||||
} |
||||
|
||||
|
||||
# |
||||
# Constructs one or more counter paths for getting thread information. |
||||
# Returned as a list of sublists. Each sublist corresponds to a counter path |
||||
# and has the form {counteroptionname datatype counterpath rate} |
||||
# datatype is the recommended format when retrieving counter value (eg. double) |
||||
# rate is 0 or 1 depending on whether the counter is a rate based counter or |
||||
# not (requires at least two readings when getting the value) |
||||
proc twapi::get_perf_thread_counter_paths {tids args} { |
||||
variable _thread_counter_opt_map |
||||
|
||||
if {![info exists _thread_counter_opt_map]} { |
||||
array set _thread_counter_opt_map { |
||||
privilegedutilization {"% Privileged Time" double 1} |
||||
processorutilization {"% Processor Time" double 1} |
||||
userutilization {"% User Time" double 1} |
||||
contextswitchrate {"Context Switches/sec" long 1} |
||||
elapsedtime {"Elapsed Time" large 0} |
||||
pid {"ID Process" long 0} |
||||
tid {"ID Thread" long 0} |
||||
basepriority {"Priority Base" long 0} |
||||
priority {"Priority Current" long 0} |
||||
startaddress {"Start Address" large 0} |
||||
state {"Thread State" long 0} |
||||
waitreason {"Thread Wait Reason" long 0} |
||||
} |
||||
} |
||||
|
||||
set optdefs { |
||||
machine.arg |
||||
datasource.arg |
||||
all |
||||
refresh |
||||
} |
||||
|
||||
# Add counter names to option list |
||||
foreach cntr [array names _thread_counter_opt_map] { |
||||
lappend optdefs $cntr |
||||
} |
||||
|
||||
# Parse options |
||||
array set opts [parseargs args $optdefs -nulldefault] |
||||
|
||||
# Force a refresh of object items |
||||
if {$opts(refresh)} { |
||||
# Silently ignore. The above counters are predefined and refreshing |
||||
# is just a time-consuming no-op. Keep the option for backward |
||||
# compatibility |
||||
if {0} { |
||||
_refresh_perf_objects $opts(machine) $opts(datasource) |
||||
} |
||||
} |
||||
|
||||
# TBD - could we not use get_perf_instance_counter_paths instead of rest of this code |
||||
|
||||
# Get the path to the thread |
||||
set tid_paths [get_perf_counter_paths \ |
||||
[_pdh_localize "Thread"] \ |
||||
[list [_pdh_localize "ID Thread"]] \ |
||||
$tids \ |
||||
-machine $opts(machine) -datasource $opts(datasource) \ |
||||
-all] |
||||
|
||||
if {[llength $tid_paths] == 0} { |
||||
# No thread |
||||
return [list ] |
||||
} |
||||
|
||||
# Now construct the requested counter paths |
||||
set counter_paths [list ] |
||||
foreach {tid tid_path} $tid_paths { |
||||
# Break it down into components and store in array |
||||
array set path_components [pdh_parse_counter_path $tid_path] |
||||
foreach {opt counter_info} [array get _thread_counter_opt_map] { |
||||
if {$opts(all) || $opts($opt)} { |
||||
lappend counter_paths \ |
||||
[list -$opt $tid [lindex $counter_info 1] \ |
||||
[pdh_counter_path $path_components(object) \ |
||||
[_pdh_localize [lindex $counter_info 0]] \ |
||||
-localized true \ |
||||
-machine $path_components(machine) \ |
||||
-parent $path_components(parent) \ |
||||
-instance $path_components(instance) \ |
||||
-instanceindex $path_components(instanceindex)] \ |
||||
[lindex $counter_info 2] |
||||
] |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $counter_paths |
||||
} |
||||
|
||||
|
||||
# Returns the counter path for the thread with the given tid. This includes |
||||
# the tid counter path element |
||||
proc twapi::get_perf_thread_id_path {tid args} { |
||||
|
||||
return [get_unique_counter_path [_pdh_localize"Thread"] [_pdh_localize "ID Thread"] $tid] |
||||
} |
||||
|
||||
|
||||
# |
||||
# Constructs one or more counter paths for getting processor information. |
||||
# Returned as a list of sublists. Each sublist corresponds to a counter path |
||||
# and has the form {counteroptionname datatype counterpath rate} |
||||
# datatype is the recommended format when retrieving counter value (eg. double) |
||||
# rate is 0 or 1 depending on whether the counter is a rate based counter or |
||||
# not (requires at least two readings when getting the value) |
||||
# $processor should be the processor number or "" to get total |
||||
proc twapi::get_perf_processor_counter_paths {processor args} { |
||||
variable _processor_counter_opt_map |
||||
|
||||
if {![string is integer -strict $processor]} { |
||||
if {[string length $processor]} { |
||||
error "Processor id must be an integer or null to retrieve information for all processors" |
||||
} |
||||
set processor "_Total" |
||||
} |
||||
|
||||
if {![info exists _processor_counter_opt_map]} { |
||||
array set _processor_counter_opt_map { |
||||
dpcutilization {"% DPC Time" double 1} |
||||
interruptutilization {"% Interrupt Time" double 1} |
||||
privilegedutilization {"% Privileged Time" double 1} |
||||
processorutilization {"% Processor Time" double 1} |
||||
userutilization {"% User Time" double 1} |
||||
dpcrate {"DPC Rate" double 1} |
||||
dpcqueuerate {"DPCs Queued/sec" double 1} |
||||
interruptrate {"Interrupts/sec" double 1} |
||||
} |
||||
} |
||||
|
||||
set optdefs { |
||||
machine.arg |
||||
datasource.arg |
||||
all |
||||
refresh |
||||
} |
||||
|
||||
# Add counter names to option list |
||||
foreach cntr [array names _processor_counter_opt_map] { |
||||
lappend optdefs $cntr |
||||
} |
||||
|
||||
# Parse options |
||||
array set opts [parseargs args $optdefs -nulldefault -maxleftover 0] |
||||
|
||||
# Force a refresh of object items |
||||
if {$opts(refresh)} { |
||||
# Silently ignore. The above counters are predefined and refreshing |
||||
# is just a time-consuming no-op. Keep the option for backward |
||||
# compatibility |
||||
if {0} { |
||||
_refresh_perf_objects $opts(machine) $opts(datasource) |
||||
} |
||||
} |
||||
|
||||
# Now construct the requested counter paths |
||||
set counter_paths [list ] |
||||
foreach {opt counter_info} [array get _processor_counter_opt_map] { |
||||
if {$opts(all) || $opts($opt)} { |
||||
lappend counter_paths \ |
||||
[list $opt $processor [lindex $counter_info 1] \ |
||||
[pdh_counter_path \ |
||||
[_pdh_localize "Processor"] \ |
||||
[_pdh_localize [lindex $counter_info 0]] \ |
||||
-localized true \ |
||||
-machine $opts(machine) \ |
||||
-instance $processor] \ |
||||
[lindex $counter_info 2] \ |
||||
] |
||||
} |
||||
} |
||||
|
||||
return $counter_paths |
||||
} |
||||
|
||||
|
||||
|
||||
# |
||||
# Returns a list comprising of the counter paths for counters with |
||||
# names in the list $counters from those instance(s) whose counter |
||||
# $key_counter matches the specified $key_counter_value |
||||
proc twapi::get_perf_instance_counter_paths {object counters |
||||
key_counter key_counter_values |
||||
args} { |
||||
# Parse options |
||||
array set opts [parseargs args { |
||||
machine.arg |
||||
datasource.arg |
||||
{matchop.arg "exact"} |
||||
skiptotal.bool |
||||
refresh |
||||
} -nulldefault] |
||||
|
||||
# Force a refresh of object items |
||||
if {$opts(refresh)} { |
||||
_refresh_perf_objects $opts(machine) $opts(datasource) |
||||
} |
||||
|
||||
# Get the list of instances that have the specified value for the |
||||
# key counter |
||||
set instance_paths [get_perf_counter_paths $object \ |
||||
[list $key_counter] $key_counter_values \ |
||||
-machine $opts(machine) \ |
||||
-datasource $opts(datasource) \ |
||||
-matchop $opts(matchop) \ |
||||
-skiptotal $opts(skiptotal) \ |
||||
-all] |
||||
|
||||
# Loop through all instance paths, and all counters to generate |
||||
# We store in an array to get rid of duplicates |
||||
array set counter_paths {} |
||||
foreach {key_counter_value instance_path} $instance_paths { |
||||
# Break it down into components and store in array |
||||
array set path_components [pdh_parse_counter_path $instance_path] |
||||
|
||||
# Now construct the requested counter paths |
||||
# TBD - what should -localized be here ? |
||||
foreach counter $counters { |
||||
set counter_path \ |
||||
[pdh_counter_path $path_components(object) \ |
||||
$counter \ |
||||
-localized true \ |
||||
-machine $path_components(machine) \ |
||||
-parent $path_components(parent) \ |
||||
-instance $path_components(instance) \ |
||||
-instanceindex $path_components(instanceindex)] |
||||
set counter_paths($counter_path) "" |
||||
} |
||||
} |
||||
|
||||
return [array names counter_paths] |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
# |
||||
# Returns a list comprising of the counter paths for all counters |
||||
# whose values match the specified criteria |
||||
proc twapi::get_perf_counter_paths {object counters counter_values args} { |
||||
array set opts [parseargs args { |
||||
machine.arg |
||||
datasource.arg |
||||
{matchop.arg "exact"} |
||||
skiptotal.bool |
||||
all |
||||
refresh |
||||
} -nulldefault] |
||||
|
||||
if {$opts(refresh)} { |
||||
_refresh_perf_objects $opts(machine) $opts(datasource) |
||||
} |
||||
|
||||
set items [pdh_enum_object_items $object \ |
||||
-machine $opts(machine) \ |
||||
-datasource $opts(datasource)] |
||||
lassign $items object_counters object_instances |
||||
|
||||
if {[llength $counters]} { |
||||
set object_counters $counters |
||||
} |
||||
set paths [_make_counter_path_list \ |
||||
$object $object_instances $object_counters \ |
||||
-skiptotal $opts(skiptotal) -machine $opts(machine)] |
||||
set result_paths [list ] |
||||
trap { |
||||
# Set up the query with the process id for all processes |
||||
set hquery [pdh_query_open -datasource $opts(datasource)] |
||||
foreach path $paths { |
||||
set hcounter [pdh_add_counter $hquery $path] |
||||
set lookup($hcounter) $path |
||||
} |
||||
|
||||
# Now collect the info |
||||
pdh_query_refresh $hquery |
||||
|
||||
# Now lookup each counter value to find a matching one |
||||
foreach hcounter [array names lookup] { |
||||
if {! [pdh_get_scalar $hcounter -var value]} { |
||||
# Counter or instance no longer exists |
||||
continue |
||||
} |
||||
|
||||
set match_pos [lsearch -$opts(matchop) $counter_values $value] |
||||
if {$match_pos >= 0} { |
||||
lappend result_paths \ |
||||
[lindex $counter_values $match_pos] $lookup($hcounter) |
||||
if {! $opts(all)} { |
||||
break |
||||
} |
||||
} |
||||
} |
||||
} finally { |
||||
# TBD - should we have a catch to throw errors? |
||||
pdh_query_close $hquery |
||||
} |
||||
|
||||
return $result_paths |
||||
} |
||||
|
||||
|
||||
# |
||||
# Returns the counter path for counter $counter with a value $value |
||||
# for object $object. Returns "" on no matches but exception if more than one |
||||
proc twapi::get_unique_counter_path {object counter value args} { |
||||
set matches [get_perf_counter_paths $object [list $counter ] [list $value] {*}$args -all] |
||||
if {[llength $matches] > 1} { |
||||
error "Multiple counter paths found matching criteria object='$object' counter='$counter' value='$value" |
||||
} |
||||
return [lindex $matches 0] |
||||
} |
||||
|
||||
|
||||
|
||||
# |
||||
# Utilities |
||||
# |
||||
proc twapi::_refresh_perf_objects {machine datasource} { |
||||
pdh_enumerate_objects -refresh |
||||
return |
||||
} |
||||
|
||||
|
||||
# |
||||
# Return the localized form of a counter name |
||||
# TBD - assumes machine is local machine! |
||||
proc twapi::_pdh_localize {name} { |
||||
variable _perf_counter_ids |
||||
variable _localized_perf_counter_names |
||||
|
||||
set name_index [string tolower $name] |
||||
|
||||
# If we already have a translation, return it |
||||
if {[info exists _localized_perf_counter_names($name_index)]} { |
||||
return $_localized_perf_counter_names($name_index) |
||||
} |
||||
|
||||
# Didn't already have it. Go generate the mappings |
||||
|
||||
# Get the list of counter names in English if we don't already have it |
||||
if {![info exists _perf_counter_ids]} { |
||||
foreach {id label} [registry get {HKEY_PERFORMANCE_DATA} {Counter 009}] { |
||||
set _perf_counter_ids([string tolower $label]) $id |
||||
} |
||||
} |
||||
|
||||
# If we have do not have id for the given name, we will just use |
||||
# the passed name as the localized version |
||||
if {! [info exists _perf_counter_ids($name_index)]} { |
||||
# Does not seem to exist. Just set localized name to itself |
||||
return [set _localized_perf_counter_names($name_index) $name] |
||||
} |
||||
|
||||
# We do have an id. THen try to get a translated name |
||||
if {[catch {PdhLookupPerfNameByIndex "" $_perf_counter_ids($name_index)} xname]} { |
||||
set _localized_perf_counter_names($name_index) $name |
||||
} else { |
||||
set _localized_perf_counter_names($name_index) $xname |
||||
} |
||||
|
||||
return $_localized_perf_counter_names($name_index) |
||||
} |
||||
|
||||
|
||||
# Given a list of instances and counters, return a cross product of the |
||||
# corresponding counter paths. |
||||
# The list is expected to be already localized |
||||
# Example: _make_counter_path_list "Process" (instance list) {{ID Process} {...}} |
||||
# TBD - bug - does not handle -parent in counter path |
||||
proc twapi::_make_counter_path_list {object instance_list counter_list args} { |
||||
array set opts [parseargs args { |
||||
machine.arg |
||||
skiptotal.bool |
||||
} -nulldefault] |
||||
|
||||
array set instances {} |
||||
foreach instance $instance_list { |
||||
if {![info exists instances($instance)]} { |
||||
set instances($instance) 1 |
||||
} else { |
||||
incr instances($instance) |
||||
} |
||||
} |
||||
|
||||
if {$opts(skiptotal)} { |
||||
catch {array unset instances "*_Total"} |
||||
} |
||||
|
||||
set counter_paths [list ] |
||||
foreach {instance count} [array get instances] { |
||||
while {$count} { |
||||
incr count -1 |
||||
foreach counter $counter_list { |
||||
lappend counter_paths [pdh_counter_path \ |
||||
$object $counter \ |
||||
-localized true \ |
||||
-machine $opts(machine) \ |
||||
-instance $instance \ |
||||
-instanceindex $count] |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $counter_paths |
||||
} |
||||
|
||||
|
||||
# |
||||
# Given a set of counter paths in the format returned by |
||||
# get_perf_thread_counter_paths, get_perf_processor_counter_paths etc. |
||||
# return the counter information as a flat list of field value pairs |
||||
proc twapi::get_perf_values_from_metacounter_info {metacounters args} { |
||||
array set opts [parseargs args {{interval.int 100}}] |
||||
|
||||
set result [list ] |
||||
set counters [list ] |
||||
if {[llength $metacounters]} { |
||||
set hquery [pdh_query_open] |
||||
trap { |
||||
set counter_info [list ] |
||||
set need_wait 0 |
||||
foreach counter_elem $metacounters { |
||||
lassign $counter_elem pdh_opt key data_type counter_path wait |
||||
incr need_wait $wait |
||||
set hcounter [pdh_add_counter $hquery $counter_path] |
||||
lappend counters $hcounter |
||||
lappend counter_info $pdh_opt $key $counter_path $data_type $hcounter |
||||
} |
||||
|
||||
pdh_query_refresh $hquery |
||||
if {$need_wait} { |
||||
after $opts(interval) |
||||
pdh_query_refresh $hquery |
||||
} |
||||
|
||||
foreach {pdh_opt key counter_path data_type hcounter} $counter_info { |
||||
if {[pdh_get_scalar $hcounter -format $data_type -var value]} { |
||||
lappend result $pdh_opt $key $value |
||||
} |
||||
} |
||||
} onerror {} { |
||||
#puts "Error: $msg" |
||||
} finally { |
||||
pdh_query_close $hquery |
||||
} |
||||
} |
||||
|
||||
return $result |
||||
|
||||
} |
||||
|
||||
proc twapi::pdh_query_open {args} { |
||||
variable _pdh_queries |
||||
|
||||
array set opts [parseargs args { |
||||
datasource.arg |
||||
cookie.int |
||||
} -nulldefault] |
||||
|
||||
set qh [PdhOpenQuery $opts(datasource) $opts(cookie)] |
||||
set id pdh[TwapiId] |
||||
dict set _pdh_queries($id) Qh $qh |
||||
dict set _pdh_queries($id) Counters {} |
||||
dict set _pdh_queries($id) Meta {} |
||||
return $id |
||||
} |
||||
|
||||
proc twapi::pdh_query_refresh {qid args} { |
||||
variable _pdh_queries |
||||
_pdh_query_check $qid |
||||
PdhCollectQueryData [dict get $_pdh_queries($qid) Qh] |
||||
return |
||||
} |
||||
|
||||
proc twapi::pdh_query_close {qid} { |
||||
variable _pdh_queries |
||||
_pdh_query_check $qid |
||||
|
||||
dict for {ctrh -} [dict get $_pdh_queries($qid) Counters] { |
||||
PdhRemoveCounter $ctrh |
||||
} |
||||
|
||||
PdhCloseQuery [dict get $_pdh_queries($qid) Qh] |
||||
unset _pdh_queries($qid) |
||||
} |
||||
|
||||
proc twapi::pdh_add_counter {qid ctr_path args} { |
||||
variable _pdh_queries |
||||
|
||||
_pdh_query_check $qid |
||||
|
||||
parseargs args { |
||||
{format.arg large {long large double}} |
||||
{scale.arg {} {{} none x1000 nocap100}} |
||||
name.arg |
||||
cookie.int |
||||
array.bool |
||||
} -nulldefault -maxleftover 0 -setvars |
||||
|
||||
if {$name eq ""} { |
||||
set name $ctr_path |
||||
} |
||||
|
||||
if {[dict exists $_pdh_queries($qid) Meta $name]} { |
||||
error "A counter with name \"$name\" already present in the query." |
||||
} |
||||
|
||||
set flags [_pdh_fmt_sym_to_val $format] |
||||
|
||||
if {$scale ne ""} { |
||||
set flags [expr {$flags | [_pdh_fmt_sym_to_val $scale]}] |
||||
} |
||||
|
||||
set hctr [PdhAddCounter [dict get $_pdh_queries($qid) Qh] $ctr_path $flags] |
||||
dict set _pdh_queries($qid) Counters $hctr 1 |
||||
dict set _pdh_queries($qid) Meta $name [list Counter $hctr FmtFlags $flags Array $array] |
||||
|
||||
return $hctr |
||||
} |
||||
|
||||
proc twapi::pdh_remove_counter {qid ctrname} { |
||||
variable _pdh_queries |
||||
_pdh_query_check $qid |
||||
if {![dict exists $_pdh_queries($qid) Meta $ctrname]} { |
||||
badargs! "Counter \"$ctrname\" not present in query." |
||||
} |
||||
set hctr [dict get $_pdh_queries($qid) Meta $ctrname Counter] |
||||
dict unset _pdh_queries($qid) Counters $hctr |
||||
dict unset _pdh_queries($qid) Meta $ctrname |
||||
PdhRemoveCounter $hctr |
||||
return |
||||
} |
||||
|
||||
proc twapi::pdh_query_get {qid args} { |
||||
variable _pdh_queries |
||||
|
||||
_pdh_query_check $qid |
||||
|
||||
# Refresh the data |
||||
PdhCollectQueryData [dict get $_pdh_queries($qid) Qh] |
||||
|
||||
set meta [dict get $_pdh_queries($qid) Meta] |
||||
|
||||
if {[llength $args] != 0} { |
||||
set names $args |
||||
} else { |
||||
set names [dict keys $meta] |
||||
} |
||||
|
||||
set result {} |
||||
foreach name $names { |
||||
if {[dict get $meta $name Array]} { |
||||
lappend result $name [PdhGetFormattedCounterArray [dict get $meta $name Counter] [dict get $meta $name FmtFlags]] |
||||
} else { |
||||
lappend result $name [PdhGetFormattedCounterValue [dict get $meta $name Counter] [dict get $meta $name FmtFlags]] |
||||
} |
||||
} |
||||
|
||||
return $result |
||||
} |
||||
|
||||
twapi::proc* twapi::pdh_system_performance_query args { |
||||
variable _sysperf_defs |
||||
|
||||
set _sysperf_defs { |
||||
event_count { {Objects Events} {} } |
||||
mutex_count { {Objects Mutexes} {} } |
||||
process_count { {Objects Processes} {} } |
||||
section_count { {Objects Sections} {} } |
||||
semaphore_count { {Objects Semaphores} {} } |
||||
thread_count { {Objects Threads} {} } |
||||
handle_count { {Process "Handle Count" -instance _Total} {-format long} } |
||||
commit_limit { {Memory "Commit Limit"} {} } |
||||
committed_bytes { {Memory "Committed Bytes"} {} } |
||||
committed_percent { {Memory "% Committed Bytes In Use"} {-format double} } |
||||
memory_free_mb { {Memory "Available MBytes"} {} } |
||||
memory_free_kb { {Memory "Available KBytes"} {} } |
||||
page_fault_rate { {Memory "Page Faults/sec"} {} } |
||||
page_input_rate { {Memory "Pages Input/sec"} {} } |
||||
page_output_rate { {Memory "Pages Output/sec"} {} } |
||||
|
||||
disk_bytes_rate { {PhysicalDisk "Disk Bytes/sec" -instance _Total} {} } |
||||
disk_readbytes_rate { {PhysicalDisk "Disk Read Bytes/sec" -instance _Total} {} } |
||||
disk_writebytes_rate { {PhysicalDisk "Disk Write Bytes/sec" -instance _Total} {} } |
||||
disk_transfer_rate { {PhysicalDisk "Disk Transfers/sec" -instance _Total} {} } |
||||
disk_read_rate { {PhysicalDisk "Disk Reads/sec" -instance _Total} {} } |
||||
disk_write_rate { {PhysicalDisk "Disk Writes/sec" -instance _Total} {} } |
||||
disk_idle_percent { {PhysicalDisk "% Idle Time" -instance _Total} {-format double} } |
||||
} |
||||
|
||||
# Per-processor counters are based on above but the object name depends |
||||
# on the system in order to support > 64 processors |
||||
set obj_name [expr {[min_os_version 6 1] ? "Processor Information" : "Processor"}] |
||||
dict for {key ctr_name} { |
||||
interrupt_utilization "% Interrupt Time" |
||||
privileged_utilization "% Privileged Time" |
||||
processor_utilization "% Processor Time" |
||||
user_utilization "% User Time" |
||||
idle_utilization "% Idle Time" |
||||
} { |
||||
lappend _sysperf_defs $key \ |
||||
[list \ |
||||
[list $obj_name $ctr_name -instance _Total] \ |
||||
[list -format double]] |
||||
|
||||
lappend _sysperf_defs ${key}_per_cpu \ |
||||
[list \ |
||||
[list $obj_name $ctr_name -instance *] \ |
||||
[list -format double -array 1]] |
||||
} |
||||
} { |
||||
variable _sysperf_defs |
||||
|
||||
if {[llength $args] == 0} { |
||||
return [lsort -dictionary [dict keys $_sysperf_defs]] |
||||
} |
||||
|
||||
set qid [pdh_query_open] |
||||
trap { |
||||
foreach arg $args { |
||||
set def [dict! $_sysperf_defs $arg] |
||||
set ctr_path [pdh_counter_path {*}[lindex $def 0]] |
||||
pdh_add_counter $qid $ctr_path -name $arg {*}[lindex $def 1] |
||||
} |
||||
pdh_query_refresh $qid |
||||
} onerror {} { |
||||
pdh_query_close $qid |
||||
rethrow |
||||
} |
||||
|
||||
return $qid |
||||
} |
||||
|
||||
# |
||||
# Internal utility procedures |
||||
proc twapi::_pdh_query_check {qid} { |
||||
variable _pdh_queries |
||||
|
||||
if {![info exists _pdh_queries($qid)]} { |
||||
error "Invalid query id $qid" |
||||
} |
||||
} |
||||
|
||||
proc twapi::_perf_detail_sym_to_val {sym} { |
||||
# PERF_DETAIL_NOVICE 100 |
||||
# PERF_DETAIL_ADVANCED 200 |
||||
# PERF_DETAIL_EXPERT 300 |
||||
# PERF_DETAIL_WIZARD 400 |
||||
# PERF_DETAIL_COSTLY 0x00010000 |
||||
# PERF_DETAIL_STANDARD 0x0000FFFF |
||||
|
||||
return [dict get {novice 100 advanced 200 expert 300 wizard 400 costly 0x00010000 standard 0x0000ffff } $sym] |
||||
} |
||||
|
||||
|
||||
proc twapi::_pdh_fmt_sym_to_val {sym} { |
||||
# PDH_FMT_RAW 0x00000010 |
||||
# PDH_FMT_ANSI 0x00000020 |
||||
# PDH_FMT_UNICODE 0x00000040 |
||||
# PDH_FMT_LONG 0x00000100 |
||||
# PDH_FMT_DOUBLE 0x00000200 |
||||
# PDH_FMT_LARGE 0x00000400 |
||||
# PDH_FMT_NOSCALE 0x00001000 |
||||
# PDH_FMT_1000 0x00002000 |
||||
# PDH_FMT_NODATA 0x00004000 |
||||
# PDH_FMT_NOCAP100 0x00008000 |
||||
|
||||
return [dict get { |
||||
raw 0x00000010 |
||||
ansi 0x00000020 |
||||
unicode 0x00000040 |
||||
long 0x00000100 |
||||
double 0x00000200 |
||||
large 0x00000400 |
||||
noscale 0x00001000 |
||||
none 0x00001000 |
||||
1000 0x00002000 |
||||
x1000 0x00002000 |
||||
nodata 0x00004000 |
||||
nocap100 0x00008000 |
||||
nocap 0x00008000 |
||||
} $sym] |
||||
} |
||||
@ -0,0 +1,119 @@
|
||||
# |
||||
# Tcl package index file |
||||
# |
||||
|
||||
namespace eval twapi { |
||||
variable scriptdir |
||||
proc set_scriptdir dir {variable scriptdir ; set scriptdir $dir} |
||||
} |
||||
|
||||
package ifneeded twapi_base 4.7.2 \ |
||||
[list load [file join $dir twapi472.dll] twapi_base] |
||||
package ifneeded twapi_com 4.7.2 \ |
||||
{load {} twapi_com} |
||||
package ifneeded metoo 4.7.2 \ |
||||
[list source [file join $dir metoo.tcl]] |
||||
package ifneeded twapi_com 4.7.2 \ |
||||
{load {} twapi_com} |
||||
package ifneeded twapi_msi 4.7.2 \ |
||||
[list source [file join $dir msi.tcl]] |
||||
package ifneeded twapi_power 4.7.2 \ |
||||
[list source [file join $dir power.tcl]] |
||||
package ifneeded twapi_printer 4.7.2 \ |
||||
[list source [file join $dir printer.tcl]] |
||||
package ifneeded twapi_synch 4.7.2 \ |
||||
[list source [file join $dir synch.tcl]] |
||||
package ifneeded twapi_security 4.7.2 \ |
||||
{load {} twapi_security} |
||||
package ifneeded twapi_account 4.7.2 \ |
||||
{load {} twapi_account} |
||||
package ifneeded twapi_apputil 4.7.2 \ |
||||
{load {} twapi_apputil} |
||||
package ifneeded twapi_clipboard 4.7.2 \ |
||||
{load {} twapi_clipboard} |
||||
package ifneeded twapi_console 4.7.2 \ |
||||
{load {} twapi_console} |
||||
package ifneeded twapi_crypto 4.7.2 \ |
||||
{load {} twapi_crypto} |
||||
package ifneeded twapi_device 4.7.2 \ |
||||
{load {} twapi_device} |
||||
package ifneeded twapi_etw 4.7.2 \ |
||||
{load {} twapi_etw} |
||||
package ifneeded twapi_eventlog 4.7.2 \ |
||||
{load {} twapi_eventlog} |
||||
package ifneeded twapi_mstask 4.7.2 \ |
||||
{load {} twapi_mstask} |
||||
package ifneeded twapi_multimedia 4.7.2 \ |
||||
{load {} twapi_multimedia} |
||||
package ifneeded twapi_namedpipe 4.7.2 \ |
||||
{load {} twapi_namedpipe} |
||||
package ifneeded twapi_network 4.7.2 \ |
||||
{load {} twapi_network} |
||||
package ifneeded twapi_nls 4.7.2 \ |
||||
{load {} twapi_nls} |
||||
package ifneeded twapi_os 4.7.2 \ |
||||
{load {} twapi_os} |
||||
package ifneeded twapi_pdh 4.7.2 \ |
||||
{load {} twapi_pdh} |
||||
package ifneeded twapi_process 4.7.2 \ |
||||
{load {} twapi_process} |
||||
package ifneeded twapi_rds 4.7.2 \ |
||||
{load {} twapi_rds} |
||||
package ifneeded twapi_resource 4.7.2 \ |
||||
{load {} twapi_resource} |
||||
package ifneeded twapi_service 4.7.2 \ |
||||
{load {} twapi_service} |
||||
package ifneeded twapi_share 4.7.2 \ |
||||
{load {} twapi_share} |
||||
package ifneeded twapi_shell 4.7.2 \ |
||||
{load {} twapi_shell} |
||||
package ifneeded twapi_storage 4.7.2 \ |
||||
{load {} twapi_storage} |
||||
package ifneeded twapi_ui 4.7.2 \ |
||||
{load {} twapi_ui} |
||||
package ifneeded twapi_input 4.7.2 \ |
||||
{load {} twapi_input} |
||||
package ifneeded twapi_winsta 4.7.2 \ |
||||
{load {} twapi_winsta} |
||||
package ifneeded twapi_wmi 4.7.2 \ |
||||
{load {} twapi_wmi} |
||||
|
||||
package ifneeded twapi 4.7.2 [subst { |
||||
twapi::set_scriptdir [list $dir] |
||||
package require twapi_base 4.7.2 |
||||
source [list [file join $dir twapi_entry.tcl]] |
||||
package require metoo 4.7.2 |
||||
package require twapi_com 4.7.2 |
||||
package require twapi_msi 4.7.2 |
||||
package require twapi_power 4.7.2 |
||||
package require twapi_printer 4.7.2 |
||||
package require twapi_synch 4.7.2 |
||||
package require twapi_security 4.7.2 |
||||
package require twapi_account 4.7.2 |
||||
package require twapi_apputil 4.7.2 |
||||
package require twapi_clipboard 4.7.2 |
||||
package require twapi_console 4.7.2 |
||||
package require twapi_crypto 4.7.2 |
||||
package require twapi_device 4.7.2 |
||||
package require twapi_etw 4.7.2 |
||||
package require twapi_eventlog 4.7.2 |
||||
package require twapi_mstask 4.7.2 |
||||
package require twapi_multimedia 4.7.2 |
||||
package require twapi_namedpipe 4.7.2 |
||||
package require twapi_network 4.7.2 |
||||
package require twapi_nls 4.7.2 |
||||
package require twapi_os 4.7.2 |
||||
package require twapi_pdh 4.7.2 |
||||
package require twapi_process 4.7.2 |
||||
package require twapi_rds 4.7.2 |
||||
package require twapi_resource 4.7.2 |
||||
package require twapi_service 4.7.2 |
||||
package require twapi_share 4.7.2 |
||||
package require twapi_shell 4.7.2 |
||||
package require twapi_storage 4.7.2 |
||||
package require twapi_ui 4.7.2 |
||||
package require twapi_input 4.7.2 |
||||
package require twapi_winsta 4.7.2 |
||||
package require twapi_wmi 4.7.2 |
||||
package provide twapi 4.7.2 |
||||
}] |
||||
@ -0,0 +1,136 @@
|
||||
# |
||||
# Copyright (c) 2003-2012 Ashok P. Nadkarni |
||||
# All rights reserved. |
||||
# |
||||
# See the file LICENSE for license |
||||
|
||||
namespace eval twapi { |
||||
variable _power_monitors |
||||
set _power_monitors [dict create] |
||||
} |
||||
|
||||
# Get the power status of the system |
||||
proc twapi::get_power_status {} { |
||||
lassign [GetSystemPowerStatus] ac battery lifepercent reserved lifetime fulllifetime |
||||
|
||||
set acstatus unknown |
||||
if {$ac == 0} { |
||||
set acstatus off |
||||
} elseif {$ac == 1} { |
||||
# Note only value 1 is "on", not just any non-0 value |
||||
set acstatus on |
||||
} |
||||
|
||||
set batterycharging unknown |
||||
if {$battery == -1} { |
||||
set batterystate unknown |
||||
} elseif {$battery & 128} { |
||||
set batterystate notpresent; # No battery |
||||
} else { |
||||
if {$battery & 8} { |
||||
set batterycharging true |
||||
} else { |
||||
set batterycharging false |
||||
} |
||||
if {$battery & 4} { |
||||
set batterystate critical |
||||
} elseif {$battery & 2} { |
||||
set batterystate low |
||||
} else { |
||||
set batterystate high |
||||
} |
||||
} |
||||
|
||||
set batterylifepercent unknown |
||||
if {$lifepercent >= 0 && $lifepercent <= 100} { |
||||
set batterylifepercent $lifepercent |
||||
} |
||||
|
||||
set batterylifetime $lifetime |
||||
if {$lifetime == -1} { |
||||
set batterylifetime unknown |
||||
} |
||||
|
||||
set batteryfulllifetime $fulllifetime |
||||
if {$fulllifetime == -1} { |
||||
set batteryfulllifetime unknown |
||||
} |
||||
|
||||
return [kl_create2 { |
||||
-acstatus |
||||
-batterystate |
||||
-batterycharging |
||||
-batterylifepercent |
||||
-batterylifetime |
||||
-batteryfulllifetime |
||||
} [list $acstatus $batterystate $batterycharging $batterylifepercent $batterylifetime $batteryfulllifetime]] |
||||
} |
||||
|
||||
|
||||
# Power notification callback |
||||
proc twapi::_power_handler {msg power_event lparam msgpos ticks} { |
||||
variable _power_monitors |
||||
|
||||
if {[dict size $_power_monitors] == 0} { |
||||
return; # Not an error, could have deleted while already queued |
||||
} |
||||
|
||||
if {![kl_vget { |
||||
0 apmquerysuspend |
||||
2 apmquerysuspendfailed |
||||
4 apmsuspend |
||||
6 apmresumecritical |
||||
7 apmresumesuspend |
||||
9 apmbatterylow |
||||
10 apmpowerstatuschange |
||||
11 apmoemevent |
||||
18 apmresumeautomatic |
||||
} $power_event power_event]} { |
||||
return; # Do not support this event |
||||
} |
||||
|
||||
dict for {id script} $_power_monitors { |
||||
set code [catch {uplevel #0 [linsert $script end $power_event $lparam]} msg] |
||||
if {$code == 1} { |
||||
# Error - put in background but we do not abort |
||||
after 0 [list error $msg $::errorInfo $::errorCode] |
||||
} |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc twapi::start_power_monitor {script} { |
||||
variable _power_monitors |
||||
|
||||
set script [lrange $script 0 end]; # Verify syntactically a list |
||||
|
||||
set id "power#[TwapiId]" |
||||
if {[dict size $_power_monitors] == 0} { |
||||
# No power monitoring in progress. Start it |
||||
# 0x218 -> WM_POWERBROADCAST |
||||
_register_script_wm_handler 0x218 [list [namespace current]::_power_handler] 1 |
||||
} |
||||
|
||||
dict set _power_monitors $id $script |
||||
return $id |
||||
} |
||||
|
||||
|
||||
# Stop monitoring of the power |
||||
proc twapi::stop_power_monitor {id} { |
||||
variable _power_monitors |
||||
|
||||
if {![dict exists $_power_monitors $id]} { |
||||
return |
||||
} |
||||
|
||||
dict unset _power_monitors $id |
||||
if {[dict size $_power_monitors] == 0} { |
||||
_unregister_script_wm_handler 0x218 [list [namespace current]::_power_handler] |
||||
} |
||||
} |
||||
|
||||
# Hack to work with the various build configuration. |
||||
if {[info commands ::twapi::get_version] ne ""} { |
||||
package provide twapi_power [::twapi::get_version -patchlevel] |
||||
} |
||||
@ -0,0 +1,58 @@
|
||||
# |
||||
# Copyright (c) 2004-2006 Ashok P. Nadkarni |
||||
# All rights reserved. |
||||
# |
||||
# See the file LICENSE for license |
||||
|
||||
namespace eval twapi {} |
||||
|
||||
proc twapi::enumerate_printers {args} { |
||||
array set opts [parseargs args { |
||||
{proximity.arg all {local remote all any}} |
||||
} -maxleftover 0] |
||||
|
||||
set result [list ] |
||||
foreach elem [Twapi_EnumPrinters_Level4 \ |
||||
[string map {all 6 any 6 local 2 remote 4} $opts(proximity)] \ |
||||
] { |
||||
lappend result [list [lindex $elem 0] [lindex $elem 1] \ |
||||
[_symbolize_printer_attributes [lindex $elem 2]]] |
||||
} |
||||
return [list {-name -server -attrs} $result] |
||||
} |
||||
|
||||
|
||||
# Utilities |
||||
# |
||||
proc twapi::_symbolize_printer_attributes {attr} { |
||||
return [_make_symbolic_bitmask $attr { |
||||
queued 0x00000001 |
||||
direct 0x00000002 |
||||
default 0x00000004 |
||||
shared 0x00000008 |
||||
network 0x00000010 |
||||
hidden 0x00000020 |
||||
local 0x00000040 |
||||
enabledevq 0x00000080 |
||||
keepprintedjobs 0x00000100 |
||||
docompletefirst 0x00000200 |
||||
workoffline 0x00000400 |
||||
enablebidi 0x00000800 |
||||
rawonly 0x00001000 |
||||
published 0x00002000 |
||||
fax 0x00004000 |
||||
ts 0x00008000 |
||||
pusheduser 0x00020000 |
||||
pushedmachine 0x00040000 |
||||
machine 0x00080000 |
||||
friendlyname 0x00100000 |
||||
tsgenericdriver 0x00200000 |
||||
peruser 0x00400000 |
||||
enterprisecloud 0x00800000 |
||||
}] |
||||
} |
||||
|
||||
# Hack to work with the various build configuration. |
||||
if {[info commands ::twapi::get_version] ne ""} { |
||||
package provide twapi_printer [::twapi::get_version -patchlevel] |
||||
} |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,191 @@
|
||||
# |
||||
# Copyright (c) 2010, Ashok P. Nadkarni |
||||
# All rights reserved. |
||||
# |
||||
# See the file LICENSE for license |
||||
|
||||
# Remote Desktop Services - TBD - document and test |
||||
|
||||
namespace eval twapi {} |
||||
|
||||
proc twapi::rds_enumerate_sessions {args} { |
||||
array set opts [parseargs args { |
||||
{hserver.arg 0} |
||||
state.arg |
||||
} -maxleftover 0] |
||||
|
||||
set states {active connected connectquery shadow disconnected idle listen reset down init} |
||||
if {[info exists opts(state)]} { |
||||
if {[string is integer -strict $opts(state)]} { |
||||
set state $opts(state) |
||||
} else { |
||||
set state [lsearch -exact $states $opts(state)] |
||||
if {$state < 0} { |
||||
error "Invalid value '$opts(state)' specified for -state option." |
||||
} |
||||
} |
||||
} |
||||
|
||||
set sessions [WTSEnumerateSessions $opts(hserver)] |
||||
|
||||
if {[info exists state]} { |
||||
set sessions [recordarray get $sessions -filter [list [list State == $state]]] |
||||
} |
||||
|
||||
set result {} |
||||
foreach {sess rec} [recordarray getdict $sessions -key SessionId -format dict] { |
||||
set state [lindex $states [kl_get $rec State]] |
||||
if {$state eq ""} { |
||||
set state [kl_get $rec State] |
||||
} |
||||
lappend result $sess [list -tssession [kl_get $rec SessionId] \ |
||||
-winstaname [kl_get $rec pWinStationName] \ |
||||
-state $state] |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
proc twapi::rds_disconnect_session args { |
||||
array set opts [parseargs args { |
||||
{hserver.arg 0} |
||||
{tssession.int -1} |
||||
{async.bool false} |
||||
} -maxleftover 0] |
||||
|
||||
WTSDisconnectSession $opts(hserver) $opts(tssession) [expr {! $opts(async)}] |
||||
|
||||
} |
||||
|
||||
proc twapi::rds_logoff_session args { |
||||
array set opts [parseargs args { |
||||
{hserver.arg 0} |
||||
{tssession.int -1} |
||||
{async.bool false} |
||||
} -maxleftover 0] |
||||
|
||||
WTSLogoffSession $opts(hserver) $opts(tssession) [expr {! $opts(async)}] |
||||
} |
||||
|
||||
proc twapi::rds_query_session_information {infoclass args} { |
||||
array set opts [parseargs args { |
||||
{hserver.arg 0} |
||||
{tssession.int -1} |
||||
} -maxleftover 0] |
||||
|
||||
return [WTSQuerySessionInformation $opts(hserver) $opts(tssession) $infoclass] |
||||
} |
||||
|
||||
interp alias {} twapi::rds_get_session_appname {} twapi::rds_query_session_information 1 |
||||
interp alias {} twapi::rds_get_session_clientdir {} twapi::rds_query_session_information 11 |
||||
interp alias {} twapi::rds_get_session_clientname {} twapi::rds_query_session_information 10 |
||||
interp alias {} twapi::rds_get_session_userdomain {} twapi::rds_query_session_information 7 |
||||
interp alias {} twapi::rds_get_session_initialprogram {} twapi::rds_query_session_information 0 |
||||
interp alias {} twapi::rds_get_session_oemid {} twapi::rds_query_session_information 3 |
||||
interp alias {} twapi::rds_get_session_user {} twapi::rds_query_session_information 5 |
||||
interp alias {} twapi::rds_get_session_winsta {} twapi::rds_query_session_information 6 |
||||
interp alias {} twapi::rds_get_session_intialdir {} twapi::rds_query_session_information 2 |
||||
interp alias {} twapi::rds_get_session_clientbuild {} twapi::rds_query_session_information 9 |
||||
interp alias {} twapi::rds_get_session_clienthwid {} twapi::rds_query_session_information 13 |
||||
interp alias {} twapi::rds_get_session_state {} twapi::rds_query_session_information 8 |
||||
interp alias {} twapi::rds_get_session_id {} twapi::rds_query_session_information 4 |
||||
interp alias {} twapi::rds_get_session_productid {} twapi::rds_query_session_information 12 |
||||
interp alias {} twapi::rds_get_session_protocol {} twapi::rds_query_session_information 16 |
||||
|
||||
|
||||
proc twapi::rds_send_message {args} { |
||||
|
||||
array set opts [parseargs args { |
||||
{hserver.arg 0} |
||||
tssession.int |
||||
title.arg |
||||
message.arg |
||||
{buttons.arg ok} |
||||
{icon.arg information} |
||||
defaultbutton.arg |
||||
{modality.arg task {task appl application system}} |
||||
{justify.arg left {left right}} |
||||
rtl.bool |
||||
foreground.bool |
||||
topmost.bool |
||||
showhelp.bool |
||||
service.bool |
||||
timeout.int |
||||
async.bool |
||||
} -maxleftover 0 -nulldefault] |
||||
|
||||
if {![kl_vget { |
||||
ok {0 {ok}} |
||||
okcancel {1 {ok cancel}} |
||||
abortretryignore {2 {abort retry ignore}} |
||||
yesnocancel {3 {yes no cancel}} |
||||
yesno {4 {yes no}} |
||||
retrycancel {5 {retry cancel}} |
||||
canceltrycontinue {6 {cancel try continue}} |
||||
} $opts(buttons) buttons]} { |
||||
error "Invalid value '$opts(buttons)' specified for option -buttons." |
||||
} |
||||
|
||||
set style [lindex $buttons 0] |
||||
switch -exact -- $opts(icon) { |
||||
warning - |
||||
exclamation {setbits style 0x30} |
||||
asterisk - |
||||
information {setbits style 0x40} |
||||
question {setbits style 0x20} |
||||
error - |
||||
hand - |
||||
stop {setbits style 0x10} |
||||
default { |
||||
error "Invalid value '$opts(icon)' specified for option -icon." |
||||
} |
||||
} |
||||
|
||||
# Map the default button |
||||
switch -exact -- [lsearch -exact [lindex $buttons 1] $opts(defaultbutton)] { |
||||
1 {setbits style 0x100 } |
||||
2 {setbits style 0x200 } |
||||
3 {setbits style 0x300 } |
||||
default { |
||||
# First button, |
||||
# setbits style 0x000 |
||||
} |
||||
} |
||||
|
||||
switch -exact -- $opts(modality) { |
||||
system { setbits style 0x1000 } |
||||
task { setbits style 0x2000 } |
||||
appl - |
||||
application - |
||||
default { |
||||
# setbits style 0x0000 |
||||
} |
||||
} |
||||
|
||||
if {$opts(showhelp)} { setbits style 0x00004000 } |
||||
if {$opts(rtl)} { setbits style 0x00100000 } |
||||
if {$opts(justify) eq "right"} { setbits style 0x00080000 } |
||||
if {$opts(topmost)} { setbits style 0x00040000 } |
||||
if {$opts(foreground)} { setbits style 0x00010000 } |
||||
if {$opts(service)} { setbits style 0x00200000 } |
||||
|
||||
set response [WTSSendMessage $opts(hserver) $opts(tssession) $opts(title) \ |
||||
$opts(message) $style $opts(timeout) \ |
||||
[expr {!$opts(async)}]] |
||||
|
||||
switch -exact -- $response { |
||||
1 { return ok } |
||||
2 { return cancel } |
||||
3 { return abort } |
||||
4 { return retry } |
||||
5 { return ignore } |
||||
6 { return yes } |
||||
7 { return no } |
||||
8 { return close } |
||||
9 { return help } |
||||
10 { return tryagain } |
||||
11 { return continue } |
||||
32000 { return timeout } |
||||
32001 { return async } |
||||
default { return $response } |
||||
} |
||||
} |
||||
@ -0,0 +1,490 @@
|
||||
# |
||||
# Copyright (c) 2020 Ashok P. Nadkarni |
||||
# All rights reserved. |
||||
# |
||||
# See the file LICENSE for license |
||||
|
||||
namespace eval twapi {} |
||||
|
||||
# |
||||
# TBD -32bit and -64bit options are not documented |
||||
# pending test cases |
||||
|
||||
proc twapi::reg_key_copy {hkey to_hkey args} { |
||||
parseargs args { |
||||
subkey.arg |
||||
copysecd.bool |
||||
} -setvars -maxleftover 0 -nulldefault |
||||
|
||||
if {$copysecd} { |
||||
RegCopyTree $hkey $subkey $to_hkey |
||||
} else { |
||||
SHCopyKey $hkey $subkey $to_hkey |
||||
} |
||||
} |
||||
|
||||
proc twapi::reg_key_create {hkey subkey args} { |
||||
# TBD - document -link |
||||
# [opt_def [cmd -link] [arg BOOL]] If [const true], [arg SUBKEY] is stored as the |
||||
# value of the [const SymbolicLinkValue] value under [arg HKEY]. Default is |
||||
# [const false]. |
||||
parseargs args { |
||||
{access.arg generic_read} |
||||
{inherit.bool 0} |
||||
{secd.arg ""} |
||||
{volatile.bool 0 0x1} |
||||
{link.bool 0 0x2} |
||||
{backup.bool 0 0x4} |
||||
32bit |
||||
64bit |
||||
disposition.arg |
||||
} -maxleftover 0 -setvars |
||||
|
||||
set access [_access_rights_to_mask $access] |
||||
# Note: Following might be set via -access as well. The -32bit and -64bit |
||||
# options just make it a little more convenient for caller |
||||
if {$32bit} { |
||||
set access [expr {$access | 0x200}] |
||||
} |
||||
if {$64bit} { |
||||
set access [expr {$access | 0x100}] |
||||
} |
||||
lassign [RegCreateKeyEx \ |
||||
$hkey \ |
||||
$subkey \ |
||||
0 \ |
||||
"" \ |
||||
[expr {$volatile | $backup}] \ |
||||
$access \ |
||||
[_make_secattr $secd $inherit] \ |
||||
] hkey disposition_value |
||||
if {[info exists disposition]} { |
||||
upvar 1 $disposition created_or_existed |
||||
if {$disposition_value == 1} { |
||||
set created_or_existed created |
||||
} else { |
||||
# disposition_value == 2 |
||||
set created_or_existed existed |
||||
} |
||||
} |
||||
return $hkey |
||||
} |
||||
|
||||
proc twapi::reg_key_delete {hkey subkey args} { |
||||
parseargs args { |
||||
32bit |
||||
64bit |
||||
} -maxleftover 0 -setvars |
||||
|
||||
# TBD - document options after adding tests |
||||
set access 0 |
||||
if {$32bit} { |
||||
set access [expr {$access | 0x200}] |
||||
} |
||||
if {$64bit} { |
||||
set access [expr {$access | 0x100}] |
||||
} |
||||
|
||||
RegDeleteKeyEx $hkey $subkey $access |
||||
} |
||||
|
||||
proc twapi::reg_keys {hkey {subkey {}}} { |
||||
if {$subkey ne ""} { |
||||
set hkey [reg_key_open $hkey $subkey] |
||||
} |
||||
try { |
||||
return [RegEnumKeyEx $hkey 0] |
||||
} finally { |
||||
if {$subkey ne ""} { |
||||
reg_key_close $hkey |
||||
} |
||||
} |
||||
} |
||||
|
||||
proc twapi::reg_key_open {hkey subkey args} { |
||||
# Not documented: -link, -32bit, -64bit |
||||
# [opt_def [cmd -link] [arg BOOL]] If [const true], specifies the key is a |
||||
# symbolic link. Defaults to [const false]. |
||||
parseargs args { |
||||
{link.bool 0} |
||||
{access.arg generic_read} |
||||
32bit |
||||
64bit |
||||
} -maxleftover 0 -setvars |
||||
|
||||
set access [_access_rights_to_mask $access] |
||||
# Note: Following might be set via -access as well. The -32bit and -64bit |
||||
# options just make it a little more convenient for caller |
||||
if {$32bit} { |
||||
set access [expr {$access | 0x200}] |
||||
} |
||||
if {$64bit} { |
||||
set access [expr {$access | 0x100}] |
||||
} |
||||
return [RegOpenKeyEx $hkey $subkey $link $access] |
||||
} |
||||
|
||||
proc twapi::reg_value_delete {hkey args} { |
||||
if {[llength $args] == 1} { |
||||
RegDeleteValue $hkey [lindex $args 0] |
||||
} elseif {[llength $args] == 2} { |
||||
RegDeleteKeyValue $hkey {*}$args |
||||
} else { |
||||
error "Wrong # args: should be \"reg_value_delete ?SUBKEY? VALUENAME\"" |
||||
} |
||||
} |
||||
|
||||
proc twapi::reg_key_current_user {args} { |
||||
parseargs args { |
||||
{access.arg generic_read} |
||||
32bit |
||||
64bit |
||||
} -maxleftover 0 -setvars |
||||
|
||||
set access [_access_rights_to_mask $access] |
||||
# Note: Following might be set via -access as well. The -32bit and -64bit |
||||
# options just make it a little more convenient for caller |
||||
if {$32bit} { |
||||
set access [expr {$access | 0x200}] |
||||
} |
||||
if {$64bit} { |
||||
set access [expr {$access | 0x100}] |
||||
} |
||||
return [RegOpenCurrentUser $access] |
||||
} |
||||
|
||||
proc twapi::reg_key_user_classes_root {usertoken args} { |
||||
parseargs args { |
||||
{access.arg generic_read} |
||||
32bit |
||||
64bit |
||||
} -maxleftover 0 -setvars |
||||
|
||||
set access [_access_rights_to_mask $access] |
||||
# Note: Following might be set via -access as well. The -32bit and -64bit |
||||
# options just make it a little more convenient for caller |
||||
if {$32bit} { |
||||
set access [expr {$access | 0x200}] |
||||
} |
||||
if {$64bit} { |
||||
set access [expr {$access | 0x100}] |
||||
} |
||||
return [RegOpenUserClassesRoot $usertoken 0 $access] |
||||
} |
||||
|
||||
proc twapi::reg_key_export {hkey filepath args} { |
||||
parseargs args { |
||||
{secd.arg {}} |
||||
{format.arg xp {win2k xp}} |
||||
{compress.bool 1} |
||||
} -setvars |
||||
|
||||
set format [dict get {win2k 1 xp 2} $format] |
||||
if {! $compress} { |
||||
set format [expr {$format | 4}] |
||||
} |
||||
twapi::eval_with_privileges { |
||||
RegSaveKeyEx $hkey $filepath [_make_secattr $secd 0] $format |
||||
} SeBackupPrivilege |
||||
} |
||||
|
||||
proc twapi::reg_key_import {hkey filepath args} { |
||||
parseargs args { |
||||
{volatile.bool 0 0x1} |
||||
{force.bool 0 0x8} |
||||
} -setvars |
||||
twapi::eval_with_privileges { |
||||
RegRestoreKey $hkey $filepath [expr {$force | $volatile}] |
||||
} {SeBackupPrivilege SeRestorePrivilege} |
||||
} |
||||
|
||||
proc twapi::reg_key_load {hkey hivename filepath} { |
||||
twapi::eval_with_privileges { |
||||
RegLoadKey $hkey $subkey $filepath |
||||
} {SeBackupPrivilege SeRestorePrivilege} |
||||
} |
||||
|
||||
proc twapi::reg_key_unload {hkey hivename} { |
||||
twapi::eval_with_privileges { |
||||
RegUnLoadKey $hkey $subkey |
||||
} {SeBackupPrivilege SeRestorePrivilege} |
||||
} |
||||
|
||||
proc twapi::reg_key_monitor {hkey hevent args} { |
||||
parseargs args { |
||||
{keys.bool 0 0x1} |
||||
{attr.bool 0 0x2} |
||||
{values.bool 0 0x4} |
||||
{secd.bool 0 0x8} |
||||
{subtree.bool 0} |
||||
} -setvars |
||||
|
||||
set filter [expr {$keys | $attr | $values | $secd}] |
||||
if {$filter == 0} { |
||||
set filter 0xf |
||||
} |
||||
|
||||
RegNotifyChangeKeyValue $hkey $subtree $filter $hevent 1 |
||||
} |
||||
|
||||
proc twapi::reg_value_names {hkey {subkey {}}} { |
||||
if {$subkey eq ""} { |
||||
# 0 - value names only |
||||
return [RegEnumValue $hkey 0] |
||||
} |
||||
set hkey [reg_key_open $hkey $subkey] |
||||
try { |
||||
# 0 - value names only |
||||
return [RegEnumValue $hkey 0] |
||||
} finally { |
||||
reg_key_close $hkey |
||||
} |
||||
} |
||||
|
||||
proc twapi::reg_values {hkey {subkey {}}} { |
||||
if {$subkey eq ""} { |
||||
# 3 -> 0x1 - return data values, 0x2 - cooked data |
||||
return [RegEnumValue $hkey 3] |
||||
} |
||||
set hkey [reg_key_open $hkey $subkey] |
||||
try { |
||||
# 3 -> 0x1 - return data values, 0x2 - cooked data |
||||
return [RegEnumValue $hkey 3] |
||||
} finally { |
||||
reg_key_close $hkey |
||||
} |
||||
} |
||||
|
||||
proc twapi::reg_values_raw {hkey {subkey {}}} { |
||||
if {$subkey eq ""} { |
||||
# 0x1 - return data values |
||||
return [RegEnumValue $hkey 1] |
||||
} |
||||
set hkey [reg_key_open $hkey $subkey] |
||||
try { |
||||
return [RegEnumValue $hkey 1] |
||||
} finally { |
||||
reg_key_close $hkey |
||||
} |
||||
} |
||||
|
||||
proc twapi::reg_value_raw {hkey args} { |
||||
if {[llength $args] == 1} { |
||||
return [RegQueryValueEx $hkey [lindex $args 0] false] |
||||
} elseif {[llength $args] == 2} { |
||||
return [RegGetValue $hkey {*}$args 0x1000ffff false] |
||||
} else { |
||||
error "wrong # args: should be \"reg_value_get HKEY ?SUBKEY? VALUENAME\"" |
||||
} |
||||
} |
||||
|
||||
proc twapi::reg_value {hkey args} { |
||||
if {[llength $args] == 1} { |
||||
return [RegQueryValueEx $hkey [lindex $args 0] true] |
||||
} elseif {[llength $args] == 2} { |
||||
return [RegGetValue $hkey {*}$args 0x1000ffff true] |
||||
} else { |
||||
error "wrong # args: should be \"reg_value_get HKEY ?SUBKEY? VALUENAME\"" |
||||
} |
||||
} |
||||
|
||||
if {[twapi::min_os_version 6]} { |
||||
proc twapi::reg_value_set {hkey args} { |
||||
if {[llength $args] == 3} { |
||||
return [RegSetValueEx $hkey {*}$args] |
||||
} elseif {[llength $args] == 4} { |
||||
return [RegSetKeyValue $hkey {*}$args] |
||||
} else { |
||||
error "wrong # args: should be \"reg_value_set HKEY ?SUBKEY? VALUENAME TYPE VALUE\"" |
||||
} |
||||
} |
||||
} else { |
||||
proc twapi::reg_value_set {hkey args} { |
||||
if {[llength $args] == 3} { |
||||
lassign $args value_name value_type value |
||||
} elseif {[llength $args] == 4} { |
||||
lassign $args subkey value_name value_type value |
||||
set hkey [reg_key_open $hkey $subkey -access key_set_value] |
||||
} else { |
||||
error "wrong # args: should be \"reg_value_set HKEY ?SUBKEY? VALUENAME TYPE VALUE\"" |
||||
} |
||||
try { |
||||
RegSetValueEx $hkey $value_name $value_type $value |
||||
} finally { |
||||
if {[info exists subkey]} { |
||||
# We opened hkey |
||||
reg_close_key $hkey |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
proc twapi::reg_key_override_undo {hkey} { |
||||
RegOverridePredefKey $hkey 0 |
||||
} |
||||
|
||||
proc twapi::_reg_walker {hkey path callback cbdata} { |
||||
# Callback for the key |
||||
set code [catch { |
||||
{*}$callback $cbdata $hkey $path |
||||
} cbdata ropts] |
||||
if {$code != 0} { |
||||
if {$code == 4} { |
||||
# Continue - skip children, continue with siblings |
||||
return $cbdata |
||||
} elseif {$code == 3} { |
||||
# Skip siblings as well |
||||
return -code break $cbdata |
||||
} elseif {$code == 2} { |
||||
# Stop complete iteration |
||||
return -code return $cbdata |
||||
} else { |
||||
return -options $ropts $cbdata |
||||
} |
||||
} |
||||
|
||||
# Iterate over child keys |
||||
foreach child_key [reg_keys $hkey] { |
||||
set child_hkey [reg_key_open $hkey $child_key] |
||||
try { |
||||
# Recurse to call into children |
||||
set code [catch { |
||||
_reg_walker $child_hkey [linsert $path end $child_key] $callback $cbdata |
||||
} cbdata ropts] |
||||
if {$code != 0 && $code != 4} { |
||||
if {$code == 3} { |
||||
# break - skip remaining child keys |
||||
return $cbdata |
||||
} elseif {$code == 2} { |
||||
# return - stop all iteration all up the tree |
||||
return -code return $cbdata |
||||
} else { |
||||
return -options $ropts $cbdata |
||||
} |
||||
} |
||||
} finally { |
||||
reg_key_close $child_hkey |
||||
} |
||||
} |
||||
|
||||
return $cbdata |
||||
} |
||||
|
||||
proc twapi::reg_walk {hkey args} { |
||||
parseargs args { |
||||
{subkey.arg {}} |
||||
callback.arg |
||||
{cbdata.arg ""} |
||||
} -maxleftover 0 -setvars |
||||
|
||||
|
||||
if {$subkey ne ""} { |
||||
set hkey [reg_key_open $hkey $subkey] |
||||
set path [list $subkey] |
||||
} else { |
||||
set path [list ] |
||||
} |
||||
|
||||
if {![info exists callback]} { |
||||
set callback [lambda {cbdata hkey path} {puts [join $path \\]}] |
||||
} |
||||
try { |
||||
set code [catch {_reg_walker $hkey $path $callback $cbdata } result ropts] |
||||
# Codes 2 (return), 3 (break) and 4 (continue) are just early terminations |
||||
if {$code == 1} { |
||||
return -options $ropts $result |
||||
} |
||||
} finally { |
||||
if {$subkey ne ""} { |
||||
reg_key_close $hkey |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
proc twapi::_reg_iterator_callback {cbdata hkey path args} { |
||||
set cmd [yield [list $hkey $path {*}$args]] |
||||
# Loop until valid argument |
||||
while {1} { |
||||
switch -exact -- $cmd { |
||||
"" - |
||||
next { return $cbdata } |
||||
stop { return -code return $cbdata } |
||||
parentsibling { return -code break $cbdata } |
||||
sibling { return -code continue $cbdata } |
||||
default { |
||||
set ret [yieldto return -level 0 -code error "Invalid argument \"$cmd\"."] |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
proc twapi::_reg_iterator_coro {hkey subkey} { |
||||
set cmd [yield [info coroutine]] |
||||
switch -exact -- $cmd { |
||||
"" - |
||||
next { |
||||
# Drop into reg_walk |
||||
} |
||||
stop - |
||||
parentsibling - |
||||
sibling { |
||||
return {} |
||||
} |
||||
default { |
||||
error "Invalid argument \"$cmd\"." |
||||
} |
||||
} |
||||
if {$subkey ne ""} { |
||||
set hkey [reg_key_open $hkey $subkey] |
||||
} |
||||
try { |
||||
reg_walk $hkey -callback [namespace current]::_reg_iterator_callback |
||||
} finally { |
||||
if {$subkey ne ""} { |
||||
reg_key_close $hkey |
||||
} |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc twapi::reg_iterator {hkey {subkey {}}} { |
||||
variable reg_walk_counter |
||||
|
||||
return [coroutine "regwalk#[incr reg_walk_counter]" _reg_iterator_coro $hkey $subkey] |
||||
} |
||||
|
||||
proc twapi::reg_tree {hkey {subkey {}}} { |
||||
|
||||
set iter [reg_iterator $hkey $subkey] |
||||
|
||||
set paths {} |
||||
while {[llength [set item [$iter next]]]} { |
||||
lappend paths [join [lindex $item 1] \\] |
||||
} |
||||
return $paths |
||||
} |
||||
|
||||
proc twapi::reg_tree_values {hkey {subkey {}}} { |
||||
|
||||
set iter [reg_iterator $hkey $subkey] |
||||
|
||||
set tree {} |
||||
# Note here we cannot ignore the first empty node corresponding |
||||
# to the root because we have to return any values it contains. |
||||
while {[llength [set item [$iter next]]]} { |
||||
dict set tree [join [lindex $item 1] \\] [reg_values [lindex $item 0]] |
||||
} |
||||
return $tree |
||||
} |
||||
|
||||
proc twapi::reg_tree_values_raw {hkey {subkey {}}} { |
||||
set iter [reg_iterator $hkey $subkey] |
||||
|
||||
set tree {} |
||||
while {[llength [set item [$iter next]]]} { |
||||
dict set tree [join [lindex $item 1] \\] [reg_values_raw [lindex $item 0]] |
||||
} |
||||
return $tree |
||||
} |
||||
|
||||
@ -0,0 +1,458 @@
|
||||
# Commands related to resource manipulation |
||||
# |
||||
# Copyright (c) 2003-2012 Ashok P. Nadkarni |
||||
# All rights reserved. |
||||
# |
||||
# See the file LICENSE for license |
||||
|
||||
package require twapi_nls |
||||
|
||||
# Retrieve version info for a file |
||||
proc twapi::get_file_version_resource {path args} { |
||||
array set opts [parseargs args { |
||||
all |
||||
datetime |
||||
signature |
||||
structversion |
||||
fileversion |
||||
productversion |
||||
flags |
||||
fileos |
||||
filetype |
||||
foundlangid |
||||
foundcodepage |
||||
langid.arg |
||||
codepage.arg |
||||
}] |
||||
|
||||
|
||||
set ver [Twapi_GetFileVersionInfo $path] |
||||
|
||||
trap { |
||||
array set verinfo [Twapi_VerQueryValue_FIXEDFILEINFO $ver] |
||||
|
||||
set result [list ] |
||||
if {$opts(all) || $opts(signature)} { |
||||
lappend result -signature [format 0x%x $verinfo(dwSignature)] |
||||
} |
||||
|
||||
if {$opts(all) || $opts(structversion)} { |
||||
lappend result -structversion "[expr {0xffff & ($verinfo(dwStrucVersion) >> 16)}].[expr {0xffff & $verinfo(dwStrucVersion)}]" |
||||
} |
||||
|
||||
if {$opts(all) || $opts(fileversion)} { |
||||
lappend result -fileversion "[expr {0xffff & ($verinfo(dwFileVersionMS) >> 16)}].[expr {0xffff & $verinfo(dwFileVersionMS)}].[expr {0xffff & ($verinfo(dwFileVersionLS) >> 16)}].[expr {0xffff & $verinfo(dwFileVersionLS)}]" |
||||
} |
||||
|
||||
if {$opts(all) || $opts(productversion)} { |
||||
lappend result -productversion "[expr {0xffff & ($verinfo(dwProductVersionMS) >> 16)}].[expr {0xffff & $verinfo(dwProductVersionMS)}].[expr {0xffff & ($verinfo(dwProductVersionLS) >> 16)}].[expr {0xffff & $verinfo(dwProductVersionLS)}]" |
||||
} |
||||
|
||||
if {$opts(all) || $opts(flags)} { |
||||
set flags [expr {$verinfo(dwFileFlags) & $verinfo(dwFileFlagsMask)}] |
||||
lappend result -flags \ |
||||
[_make_symbolic_bitmask \ |
||||
[expr {$verinfo(dwFileFlags) & $verinfo(dwFileFlagsMask)}] \ |
||||
{ |
||||
debug 1 |
||||
prerelease 2 |
||||
patched 4 |
||||
privatebuild 8 |
||||
infoinferred 16 |
||||
specialbuild 32 |
||||
} \ |
||||
] |
||||
} |
||||
|
||||
if {$opts(all) || $opts(fileos)} { |
||||
switch -exact -- [format %08x $verinfo(dwFileOS)] { |
||||
00010000 {set os dos} |
||||
00020000 {set os os216} |
||||
00030000 {set os os232} |
||||
00040000 {set os nt} |
||||
00050000 {set os wince} |
||||
00000001 {set os windows16} |
||||
00000002 {set os pm16} |
||||
00000003 {set os pm32} |
||||
00000004 {set os windows32} |
||||
00010001 {set os dos_windows16} |
||||
00010004 {set os dos_windows32} |
||||
00020002 {set os os216_pm16} |
||||
00030003 {set os os232_pm32} |
||||
00040004 {set os nt_windows32} |
||||
default {set os $verinfo(dwFileOS)} |
||||
} |
||||
lappend result -fileos $os |
||||
} |
||||
|
||||
if {$opts(all) || $opts(filetype)} { |
||||
switch -exact -- [expr {0+$verinfo(dwFileType)}] { |
||||
1 {set type application} |
||||
2 {set type dll} |
||||
3 { |
||||
set type "driver." |
||||
switch -exact -- [expr {0+$verinfo(dwFileSubtype)}] { |
||||
1 {append type printer} |
||||
2 {append type keyboard} |
||||
3 {append type language} |
||||
4 {append type display} |
||||
5 {append type mouse} |
||||
6 {append type network} |
||||
7 {append type system} |
||||
8 {append type installable} |
||||
9 {append type sound} |
||||
10 {append type comm} |
||||
11 {append type inputmethod} |
||||
12 {append type versionedprinter} |
||||
default {append type $verinfo(dwFileSubtype)} |
||||
} |
||||
} |
||||
4 { |
||||
set type "font." |
||||
switch -exact -- [expr {0+$verinfo(dwFileSubtype)}] { |
||||
1 {append type raster} |
||||
2 {append type vector} |
||||
3 {append type truetype} |
||||
default {append type $verinfo(dwFileSubtype)} |
||||
} |
||||
} |
||||
5 { set type "vxd.$verinfo(dwFileSubtype)" } |
||||
7 {set type staticlib} |
||||
default { |
||||
set type "$verinfo(dwFileType).$verinfo(dwFileSubtype)" |
||||
} |
||||
} |
||||
lappend result -filetype $type |
||||
} |
||||
|
||||
if {$opts(all) || $opts(datetime)} { |
||||
lappend result -datetime [expr {($verinfo(dwFileDateMS) << 32) + $verinfo(dwFileDateLS)}] |
||||
} |
||||
|
||||
# Any remaining arguments are treated as string names |
||||
|
||||
if {[llength $args] || $opts(foundlangid) || $opts(foundcodepage) || $opts(all)} { |
||||
# Find list of langid's and codepages and do closest match |
||||
set langid [expr {[info exists opts(langid)] ? $opts(langid) : [get_user_ui_langid]}] |
||||
set primary_langid [extract_primary_langid $langid] |
||||
set sub_langid [extract_sublanguage_langid $langid] |
||||
set cp [expr {[info exists opts(codepage)] ? $opts(codepage) : 0}] |
||||
|
||||
# Find a match in the following order: |
||||
# 0 Exact match for both langid and codepage |
||||
# 1 Exact match for langid |
||||
# 2 Primary langid matches (sublang does not) and exact codepage |
||||
# 3 Primary langid matches (sublang does not) |
||||
# 4 Language neutral |
||||
# 5 English |
||||
# 6 First langcp in list or "00000000" |
||||
set match(7) "00000000"; # In case list is empty |
||||
foreach langcp [Twapi_VerQueryValue_TRANSLATIONS $ver] { |
||||
set verlangid 0x[string range $langcp 0 3] |
||||
set vercp 0x[string range $langcp 4 7] |
||||
if {$verlangid == $langid && $vercp == $cp} { |
||||
set match(0) $langcp |
||||
break; # No need to look further |
||||
} |
||||
if {[info exists match(1)]} continue |
||||
if {$verlangid == $langid} { |
||||
set match(1) $langcp |
||||
continue; # Continue to look for match(0) |
||||
} |
||||
if {[info exists match(2)]} continue |
||||
set verprimary [extract_primary_langid $verlangid] |
||||
if {$verprimary == $primary_langid && $vercp == $cp} { |
||||
set match(2) $langcp |
||||
continue; # Continue to look for match(1) or better |
||||
} |
||||
if {[info exists match(3)]} continue |
||||
if {$verprimary == $primary_langid} { |
||||
set match(3) $langcp |
||||
continue; # Continue to look for match(2) or better |
||||
} |
||||
if {[info exists match(4)]} continue |
||||
if {$verprimary == 0} { |
||||
set match(4) $langcp; # LANG_NEUTRAL |
||||
continue; # Continue to look for match(3) or better |
||||
} |
||||
if {[info exists match(5)]} continue |
||||
if {$verprimary == 9} { |
||||
set match(5) $langcp; # English |
||||
continue; # Continue to look for match(4) or better |
||||
} |
||||
if {![info exists match(6)]} { |
||||
set match(6) $langcp |
||||
} |
||||
} |
||||
|
||||
# Figure out what is the best match we have |
||||
for {set i 0} {$i <= 7} {incr i} { |
||||
if {[info exists match($i)]} { |
||||
break |
||||
} |
||||
} |
||||
|
||||
if {$opts(foundlangid) || $opts(all)} { |
||||
set langid 0x[string range $match($i) 0 3] |
||||
lappend result -foundlangid [list $langid [VerLanguageName $langid]] |
||||
} |
||||
|
||||
if {$opts(foundcodepage) || $opts(all)} { |
||||
lappend result -foundcodepage 0x[string range $match($i) 4 7] |
||||
} |
||||
|
||||
foreach sname $args { |
||||
lappend result $sname [Twapi_VerQueryValue_STRING $ver $match($i) $sname] |
||||
} |
||||
|
||||
} |
||||
|
||||
} finally { |
||||
Twapi_FreeFileVersionInfo $ver |
||||
} |
||||
|
||||
return $result |
||||
} |
||||
|
||||
proc twapi::begin_resource_update {path args} { |
||||
array set opts [parseargs args { |
||||
deleteall |
||||
} -maxleftover 0] |
||||
|
||||
return [BeginUpdateResource $path $opts(deleteall)] |
||||
} |
||||
|
||||
# Note this is not an alias because we want to control arguments |
||||
# to UpdateResource (which can take more args that specified here) |
||||
proc twapi::delete_resource {hmod restype resname langid} { |
||||
UpdateResource $hmod $restype $resname $langid |
||||
} |
||||
|
||||
|
||||
# Note this is not an alias because we want to make sure $bindata is specified |
||||
# as an argument else it will have the effect of deleting a resource |
||||
proc twapi::update_resource {hmod restype resname langid bindata} { |
||||
UpdateResource $hmod $restype $resname $langid $bindata |
||||
} |
||||
|
||||
proc twapi::end_resource_update {hmod args} { |
||||
array set opts [parseargs args { |
||||
discard |
||||
} -maxleftover 0] |
||||
|
||||
return [EndUpdateResource $hmod $opts(discard)] |
||||
} |
||||
|
||||
proc twapi::read_resource {hmod restype resname langid} { |
||||
return [Twapi_LoadResource $hmod [FindResourceEx $hmod $restype $resname $langid]] |
||||
} |
||||
|
||||
proc twapi::read_resource_string {hmod resname langid} { |
||||
# As an aside, note that we do not use a LoadString call |
||||
# because it does not allow for specification of a langid |
||||
|
||||
# For a reference to how strings are stored, see |
||||
# http://blogs.msdn.com/b/oldnewthing/archive/2004/01/30/65013.aspx |
||||
# or http://support.microsoft.com/kb/196774 |
||||
|
||||
if {![string is integer -strict $resname]} { |
||||
error "String resources must have an integer id" |
||||
} |
||||
|
||||
lassign [resource_stringid_to_stringblockid $resname] block_id index_within_block |
||||
|
||||
return [lindex \ |
||||
[resource_stringblock_to_strings \ |
||||
[read_resource $hmod 6 $block_id $langid] ] \ |
||||
$index_within_block] |
||||
} |
||||
|
||||
# Give a list of strings, formats it as a string block. Number of strings |
||||
# must not be greater than 16. If less than 16 strings, remaining are |
||||
# treated as empty. |
||||
proc twapi::strings_to_resource_stringblock {strings} { |
||||
if {[llength $strings] > 16} { |
||||
error "Cannot have more than 16 strings in a resource string block." |
||||
} |
||||
|
||||
for {set i 0} {$i < 16} {incr i} { |
||||
set s [lindex $strings $i] |
||||
set n [string length $s] |
||||
append bin [binary format sa* $n [encoding convertto unicode $s]] |
||||
} |
||||
|
||||
return $bin |
||||
} |
||||
|
||||
proc twapi::resource_stringid_to_stringblockid {id} { |
||||
# Strings are stored in blocks of 16, with block id's beginning at 1, not 0 |
||||
return [list [expr {($id / 16) + 1}] [expr {$id & 15}]] |
||||
} |
||||
|
||||
proc twapi::extract_resources {hmod {withdata 0}} { |
||||
set result [dict create] |
||||
foreach type [enumerate_resource_types $hmod] { |
||||
set typedict [dict create] |
||||
foreach name [enumerate_resource_names $hmod $type] { |
||||
set namedict [dict create] |
||||
foreach lang [enumerate_resource_languages $hmod $type $name] { |
||||
if {$withdata} { |
||||
dict set namedict $lang [read_resource $hmod $type $name $lang] |
||||
} else { |
||||
dict set namedict $lang {} |
||||
} |
||||
} |
||||
dict set typedict $name $namedict |
||||
} |
||||
dict set result $type $typedict |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
# TBD - test |
||||
proc twapi::write_bmp_file {filename bmp} { |
||||
# Assumes $bmp is clipboard content in format 8 (CF_DIB) |
||||
|
||||
# First parse the bitmap data to collect header information |
||||
binary scan $bmp "iiissiiiiii" size width height planes bitcount compression sizeimage xpelspermeter ypelspermeter clrused clrimportant |
||||
|
||||
# We only handle BITMAPINFOHEADER right now (size must be 40) |
||||
if {$size != 40} { |
||||
error "Unsupported bitmap format. Header size=$size" |
||||
} |
||||
|
||||
# We need to figure out the offset to the actual bitmap data |
||||
# from the start of the file header. For this we need to know the |
||||
# size of the color table which directly follows the BITMAPINFOHEADER |
||||
if {$bitcount == 0} { |
||||
error "Unsupported format: implicit JPEG or PNG" |
||||
} elseif {$bitcount == 1} { |
||||
set color_table_size 2 |
||||
} elseif {$bitcount == 4} { |
||||
# TBD - Not sure if this is the size or the max size |
||||
set color_table_size 16 |
||||
} elseif {$bitcount == 8} { |
||||
# TBD - Not sure if this is the size or the max size |
||||
set color_table_size 256 |
||||
} elseif {$bitcount == 16 || $bitcount == 32} { |
||||
if {$compression == 0} { |
||||
# BI_RGB |
||||
set color_table_size $clrused |
||||
} elseif {$compression == 3} { |
||||
# BI_BITFIELDS |
||||
set color_table_size 3 |
||||
} else { |
||||
error "Unsupported compression type '$compression' for bitcount value $bitcount" |
||||
} |
||||
} elseif {$bitcount == 24} { |
||||
set color_table_size $clrused |
||||
} else { |
||||
error "Unsupported value '$bitcount' in bitmap bitcount field" |
||||
} |
||||
|
||||
set filehdr_size 14; # sizeof(BITMAPFILEHEADER) |
||||
set bitmap_file_offset [expr {$filehdr_size+$size+($color_table_size*4)}] |
||||
set filehdr [binary format "a2 i x2 x2 i" "BM" [expr {$filehdr_size + [string length $bmp]}] $bitmap_file_offset] |
||||
|
||||
set fd [open $filename w] |
||||
fconfigure $fd -translation binary |
||||
|
||||
puts -nonewline $fd $filehdr |
||||
puts -nonewline $fd $bmp |
||||
|
||||
close $fd |
||||
} |
||||
|
||||
proc twapi::_load_image {flags type hmod path args} { |
||||
# The flags arg is generally 0x10 (load from file), or 0 (module) |
||||
# or'ed with 0x8000 (shared). The latter can be overridden by |
||||
# the -shared option but should not be except when loading from module. |
||||
array set opts [parseargs args { |
||||
{createdibsection.bool 0 0x2000} |
||||
{defaultsize.bool 0 0x40} |
||||
height.int |
||||
{loadtransparent.bool 0 0x20} |
||||
{monochrome.bool 0 0x1} |
||||
{shared.bool 0 0x8000} |
||||
{vgacolor.bool 0 0x80} |
||||
width.int |
||||
} -maxleftover 0 -nulldefault] |
||||
|
||||
set flags [expr {$flags | $opts(defaultsize) | $opts(loadtransparent) | $opts(monochrome) | $opts(shared) | $opts(vgacolor)}] |
||||
|
||||
set h [LoadImage $hmod $path $type $opts(width) $opts(height) $flags] |
||||
# Cast as _SHARED if required to offer some protection against |
||||
# being freed using DestroyIcon etc. |
||||
set type [lindex {HGDIOBJ HICON HCURSOR} $type] |
||||
if {$flags & 0x8000} { |
||||
append type _SHARED |
||||
} |
||||
return [cast_handle $h $type] |
||||
} |
||||
|
||||
|
||||
proc twapi::_load_image_from_system {type id args} { |
||||
variable _oem_image_syms |
||||
|
||||
if {![string is integer -strict $id]} { |
||||
if {![info exists _oem_image_syms]} { |
||||
# Bitmap symbols (type 0) |
||||
dict set _oem_image_syms 0 { |
||||
CLOSE 32754 UPARROW 32753 |
||||
DNARROW 32752 RGARROW 32751 |
||||
LFARROW 32750 REDUCE 32749 |
||||
ZOOM 32748 RESTORE 32747 |
||||
REDUCED 32746 ZOOMD 32745 |
||||
RESTORED 32744 UPARROWD 32743 |
||||
DNARROWD 32742 RGARROWD 32741 |
||||
LFARROWD 32740 MNARROW 32739 |
||||
COMBO 32738 UPARROWI 32737 |
||||
DNARROWI 32736 RGARROWI 32735 |
||||
LFARROWI 32734 SIZE 32766 |
||||
BTSIZE 32761 CHECK 32760 |
||||
CHECKBOXES 32759 BTNCORNERS 32758 |
||||
} |
||||
# Icon symbols (type 1) |
||||
dict set _oem_image_syms 1 { |
||||
SAMPLE 32512 HAND 32513 |
||||
QUES 32514 BANG 32515 |
||||
NOTE 32516 WINLOGO 32517 |
||||
WARNING 32515 ERROR 32513 |
||||
INFORMATION 32516 SHIELD 32518 |
||||
} |
||||
# Cursor symbols (type 2) |
||||
dict set _oem_image_syms 2 { |
||||
NORMAL 32512 IBEAM 32513 |
||||
WAIT 32514 CROSS 32515 |
||||
UP 32516 SIZENWSE 32642 |
||||
SIZENESW 32643 SIZEWE 32644 |
||||
SIZENS 32645 SIZEALL 32646 |
||||
NO 32648 HAND 32649 |
||||
APPSTARTING 32650 |
||||
} |
||||
|
||||
} |
||||
} |
||||
|
||||
set id [dict get $_oem_image_syms $type [string toupper $id]] |
||||
# Built-in system images must always be loaded shared (0x8000) |
||||
return [_load_image 0x8000 $type NULL $id {*}$args] |
||||
} |
||||
|
||||
|
||||
# 0x10 -> LR_LOADFROMFILE. Also 0x8000 not set (meaning unshared) |
||||
interp alias {} twapi::load_bitmap_from_file {} twapi::_load_image 0x10 0 NULL |
||||
interp alias {} twapi::load_icon_from_file {} twapi::_load_image 0x10 1 NULL |
||||
interp alias {} twapi::load_cursor_from_file {} twapi::_load_image 0x10 2 NULL |
||||
|
||||
interp alias {} twapi::load_bitmap_from_module {} twapi::_load_image 0 0 |
||||
interp alias {} twapi::load_icon_from_module {} twapi::_load_image 0 1 |
||||
interp alias {} twapi::load_cursor_from_module {} twapi::_load_image 0 2 |
||||
|
||||
interp alias {} twapi::load_bitmap_from_system {} twapi::_load_image_from_system 0 |
||||
interp alias {} twapi::load_icon_from_system {} twapi::_load_image_from_system 1 |
||||
interp alias {} twapi::load_cursor_from_system {} twapi::_load_image_from_system 2 |
||||
|
||||
interp alias {} twapi::free_icon {} twapi::DestroyIcon |
||||
interp alias {} twapi::free_bitmap {} twapi::DeleteObject |
||||
interp alias {} twapi::free_cursor {} twapi::DestroyCursor |
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,966 @@
|
||||
# |
||||
# Copyright (c) 2003-2014, Ashok P. Nadkarni |
||||
# All rights reserved. |
||||
# |
||||
# See the file LICENSE for license |
||||
|
||||
namespace eval twapi { |
||||
# Win SDK based structure definitions |
||||
|
||||
record SHARE_INFO_0 {-name} |
||||
record SHARE_INFO_1 {-name -type -comment} |
||||
record SHARE_INFO_2 {-name -type -comment -permissions -max_conn -current_conn -path -passwd} |
||||
record SHARE_INFO_502 {-name -type -comment -permissions -max_conn -current_conn -path -passwd -reserved -secd} |
||||
|
||||
record USE_INFO_0 {-localdevice -remoteshare} |
||||
record USE_INFO_1 {-localdevice -remoteshare -password -status -type -opencount -usecount} |
||||
record USE_INFO_2 {-localdevice -remoteshare -password -status -type -opencount -usecount -user -domain} |
||||
|
||||
record SESSION_INFO_0 {-clientname} |
||||
record SESSION_INFO_1 {-clientname -user -opencount -activeseconds -idleseconds -attrs} |
||||
record SESSION_INFO_2 {-clientname -user -opencount -activeseconds -idleseconds -attrs -clienttype} |
||||
record SESSION_INFO_502 {-clientname -user -opencount -activeseconds -idleseconds -attrs -clienttype -transport} |
||||
record SESSION_INFO_10 {-clientname -user -activeseconds -idleseconds} |
||||
|
||||
record FILE_INFO_2 {-id} |
||||
record FILE_INFO_3 {-id -permissions -lockcount -path -user} |
||||
|
||||
record CONNECTION_INFO_0 {-id} |
||||
record CONNECTION_INFO_1 {-id -type -opencount -usercount -activeseconds -user -netname} |
||||
|
||||
struct NETRESOURCE { |
||||
DWORD dwScope; |
||||
DWORD dwType; |
||||
DWORD dwDisplayType; |
||||
DWORD dwUsage; |
||||
LPCWSTR lpLocalName; |
||||
LPCWSTR lpRemoteName; |
||||
LPCWSTR lpComment; |
||||
LPCWSTR lpProvider; |
||||
}; |
||||
|
||||
struct NETINFOSTRUCT { |
||||
DWORD cbStructure; |
||||
DWORD dwProviderVersion; |
||||
DWORD dwStatus; |
||||
DWORD dwCharacteristics; |
||||
HANDLE dwHandle; |
||||
WORD wNetType; |
||||
DWORD dwPrinters; |
||||
DWORD dwDrives; |
||||
} |
||||
} |
||||
|
||||
# TBD - is there a Tcl wrapper around NetShareCheck? |
||||
|
||||
# Create a network share |
||||
proc twapi::new_share {sharename path args} { |
||||
array set opts [parseargs args { |
||||
{system.arg ""} |
||||
{type.arg "file"} |
||||
{comment.arg ""} |
||||
{max_conn.int -1} |
||||
secd.arg |
||||
} -maxleftover 0] |
||||
|
||||
# If no security descriptor specified, default to "Everyone, |
||||
# read permission". Levaing it empty will give everyone all permissions |
||||
# which is probably not a good idea! |
||||
if {![info exists opts(secd)]} { |
||||
set opts(secd) [new_security_descriptor -dacl [new_acl [list [new_ace allow S-1-1-0 1179817]]]] |
||||
} |
||||
|
||||
NetShareAdd $opts(system) \ |
||||
$sharename \ |
||||
[_share_type_symbols_to_code $opts(type)] \ |
||||
$opts(comment) \ |
||||
$opts(max_conn) \ |
||||
[file nativename $path] \ |
||||
$opts(secd) |
||||
} |
||||
|
||||
# Delete a network share |
||||
proc twapi::delete_share {sharename args} { |
||||
array set opts [parseargs args {system.arg} -nulldefault] |
||||
NetShareDel $opts(system) $sharename 0 |
||||
} |
||||
|
||||
# Enumerate network shares |
||||
proc twapi::get_shares {args} { |
||||
|
||||
array set opts [parseargs args { |
||||
{system.arg ""} |
||||
{type.arg ""} |
||||
excludespecial |
||||
level.int |
||||
} -maxleftover 0] |
||||
|
||||
if {$opts(type) != ""} { |
||||
set type_filter [_share_type_symbols_to_code $opts(type) 1] |
||||
} |
||||
|
||||
if {[info exists opts(level)] && $opts(level) > 0} { |
||||
set level $opts(level) |
||||
} else { |
||||
# Either -level not specified or specified as 0 |
||||
# We need at least level 1 to filter on type |
||||
set level 1 |
||||
} |
||||
|
||||
set record_proc SHARE_INFO_$level |
||||
set raw_data [_net_enum_helper NetShareEnum -system $opts(system) -level $level -fields [$record_proc]] |
||||
set recs [list ] |
||||
foreach rec [recordarray getlist $raw_data] { |
||||
# 0xC0000000 -> 0x80000000 (STYPE_SPECIAL), 0x40000000 (STYPE_TEMPORARY) |
||||
set special [expr {[$record_proc -type $rec] & 0xC0000000}] |
||||
if {$special && $opts(excludespecial)} { |
||||
continue |
||||
} |
||||
# We need the special cast to int because else operands get promoted |
||||
# to 64 bits as the hex is treated as an unsigned value |
||||
set share_type [$record_proc -type $rec] |
||||
if {[info exists type_filter] && [expr {int($share_type & ~ $special)}] != $type_filter} { |
||||
continue |
||||
} |
||||
set rec [$record_proc set $rec -type [_share_type_code_to_symbols $share_type]] |
||||
if {[info exists opts(level)]} { |
||||
lappend recs $rec |
||||
} else { |
||||
lappend recs [$record_proc -name $rec] |
||||
} |
||||
} |
||||
|
||||
if {[info exists opts(level)]} { |
||||
set ra [list [$record_proc] $recs] |
||||
if {$opts(level) == 0} { |
||||
# We actually need only a level 0 subset |
||||
return [recordarray get $ra -slice [SHARE_INFO_0]] |
||||
} |
||||
return $ra |
||||
} else { |
||||
return $recs |
||||
} |
||||
} |
||||
|
||||
|
||||
# Get details about a share |
||||
proc twapi::get_share_info {sharename args} { |
||||
array set opts [parseargs args { |
||||
system.arg |
||||
all |
||||
name |
||||
type |
||||
path |
||||
comment |
||||
max_conn |
||||
current_conn |
||||
secd |
||||
} -nulldefault -hyphenated] |
||||
|
||||
set level 0 |
||||
|
||||
if {$opts(-all) || $opts(-name) || $opts(-type) || $opts(-comment)} { |
||||
set level 1 |
||||
set record_proc SHARE_INFO_1 |
||||
} |
||||
|
||||
if {$opts(-all) || $opts(-max_conn) || $opts(-current_conn) || $opts(-path)} { |
||||
set level 2 |
||||
set record_proc SHARE_INFO_2 |
||||
} |
||||
|
||||
if {$opts(-all) || $opts(-secd)} { |
||||
set level 502 |
||||
set record_proc SHARE_INFO_502 |
||||
} |
||||
|
||||
if {! $level} { |
||||
return |
||||
} |
||||
|
||||
set rec [NetShareGetInfo $opts(-system) $sharename $level] |
||||
set result [list ] |
||||
foreach opt {-name -comment -max_conn -current_conn -path -secd} { |
||||
if {$opts(-all) || $opts($opt)} { |
||||
lappend result $opt [$record_proc $opt $rec] |
||||
} |
||||
} |
||||
if {$opts(-all) || $opts(-type)} { |
||||
lappend result -type [_share_type_code_to_symbols [$record_proc -type $rec]] |
||||
} |
||||
|
||||
return $result |
||||
} |
||||
|
||||
|
||||
# Set a share configuration |
||||
proc twapi::set_share_info {sharename args} { |
||||
array set opts [parseargs args { |
||||
{system.arg ""} |
||||
comment.arg |
||||
max_conn.int |
||||
secd.arg |
||||
}] |
||||
|
||||
# First get the current config so we can change specified fields |
||||
# and write back |
||||
array set shareinfo [get_share_info $sharename -system $opts(system) \ |
||||
-comment -max_conn -secd] |
||||
foreach field {comment max_conn secd} { |
||||
if {[info exists opts($field)]} { |
||||
set shareinfo(-$field) $opts($field) |
||||
} |
||||
} |
||||
|
||||
NetShareSetInfo $opts(system) $sharename $shareinfo(-comment) \ |
||||
$shareinfo(-max_conn) $shareinfo(-secd) |
||||
} |
||||
|
||||
|
||||
# Get list of remote shares |
||||
proc twapi::get_client_shares {args} { |
||||
array set opts [parseargs args { |
||||
{system.arg ""} |
||||
level.int |
||||
} -maxleftover 0] |
||||
|
||||
if {[info exists opts(level)]} { |
||||
set rec_proc USE_INFO_$opts(level) |
||||
set ra [_net_enum_helper NetUseEnum -system $opts(system) -level $opts(level) -fields [$rec_proc]] |
||||
set fields [$rec_proc] |
||||
set have_status [expr {"-status" in $fields}] |
||||
set have_type [expr {"-type" in $fields}] |
||||
if {! ($have_status || $have_type)} { |
||||
return $ra |
||||
} |
||||
set recs {} |
||||
foreach rec [recordarray getlist $ra] { |
||||
if {$have_status} { |
||||
set rec [$rec_proc set $rec -status [_map_useinfo_status [$rec_proc -status $rec]]] |
||||
} |
||||
if {$have_type} { |
||||
set rec [$rec_proc set $rec -type [_map_useinfo_type [$rec_proc -type $rec]]] |
||||
} |
||||
lappend recs $rec |
||||
} |
||||
return [list $fields $recs] |
||||
} |
||||
|
||||
# -level not specified. Just return a list of the remote share names |
||||
return [recordarray column [_net_enum_helper NetUseEnum -system $opts(system) -level 0 -fields [USE_INFO_0]] -remoteshare] |
||||
} |
||||
|
||||
|
||||
# Connect to a share |
||||
proc twapi::connect_share {remoteshare args} { |
||||
array set opts [parseargs args { |
||||
{type.arg "disk"} |
||||
localdevice.arg |
||||
provider.arg |
||||
password.arg |
||||
nopassword |
||||
defaultpassword |
||||
user.arg |
||||
{window.arg 0} |
||||
{interactive {} 0x8} |
||||
{prompt {} 0x10} |
||||
{updateprofile {} 0x1} |
||||
{commandline {} 0x800} |
||||
} -nulldefault] |
||||
|
||||
set flags 0 |
||||
|
||||
switch -exact -- $opts(type) { |
||||
"any" {set type 0} |
||||
"disk" - |
||||
"file" {set type 1} |
||||
"printer" {set type 2} |
||||
default { |
||||
error "Invalid network share type '$opts(type)'" |
||||
} |
||||
} |
||||
|
||||
# localdevice - "" means no local device, * means pick any, otherwise |
||||
# it's a local device to be mapped |
||||
if {$opts(localdevice) == "*"} { |
||||
set opts(localdevice) "" |
||||
setbits flags 0x80; # CONNECT_REDIRECT |
||||
} |
||||
|
||||
if {$opts(defaultpassword) && $opts(nopassword)} { |
||||
error "Options -defaultpassword and -nopassword may not be used together" |
||||
} |
||||
if {$opts(nopassword)} { |
||||
set opts(password) "" |
||||
set ignore_password 1 |
||||
} else { |
||||
set ignore_password 0 |
||||
if {$opts(defaultpassword)} { |
||||
set opts(password) "" |
||||
} |
||||
} |
||||
|
||||
set flags [expr {$flags | $opts(interactive) | $opts(prompt) | |
||||
$opts(updateprofile) | $opts(commandline)}] |
||||
|
||||
return [Twapi_WNetUseConnection $opts(window) $type $opts(localdevice) \ |
||||
$remoteshare $opts(provider) $opts(user) $ignore_password \ |
||||
$opts(password) $flags] |
||||
} |
||||
|
||||
# Disconnects an existing share |
||||
proc twapi::disconnect_share {sharename args} { |
||||
array set opts [parseargs args {updateprofile force}] |
||||
|
||||
set flags [expr {$opts(updateprofile) ? 0x1 : 0}] |
||||
WNetCancelConnection2 $sharename $flags $opts(force) |
||||
} |
||||
|
||||
|
||||
# Get information about a connected share |
||||
proc twapi::get_client_share_info {sharename args} { |
||||
if {$sharename eq ""} { |
||||
error "A share name cannot be the empty string" |
||||
} |
||||
|
||||
# We have to use a combination of NetUseGetInfo and |
||||
# WNetGetResourceInformation as neither gives us the full information |
||||
# THe former takes the local device name if there is one and will |
||||
# only accept a UNC if there is an entry for the UNC with |
||||
# no local device mapped. The latter |
||||
# always wants the UNC. So we need to figure out exactly if there |
||||
# is a local device mapped to the sharename or not |
||||
# TBD _ see if this is really the case. Also, NetUse only works with |
||||
# LANMAN, not WebDAV. So see if there is a way to only use WNet* |
||||
# variants |
||||
|
||||
# There may be multiple entries for the same UNC |
||||
# If there is an entry for the UNC with no device mapped, select |
||||
# that else select any of the local devices mapped to it |
||||
# TBD - any better way of finding out a mapping than calling |
||||
# get_client_shares? |
||||
# TBD - use wnet_connected_resources |
||||
foreach {elem_device elem_unc} [recordarray getlist [get_client_shares -level 0] -format flat] { |
||||
if {[string equal -nocase $sharename $elem_unc]} { |
||||
if {$elem_device eq ""} { |
||||
# Found an entry without a local device. Use it |
||||
set unc $elem_unc |
||||
unset -nocomplain local; # In case we found a match earlier |
||||
break |
||||
} else { |
||||
# Found a matching device |
||||
set local $elem_device |
||||
set unc $elem_unc |
||||
# Keep looping in case we find an entry with no local device |
||||
# (which we will prefer) |
||||
} |
||||
} else { |
||||
# See if the sharename is actually a local device name |
||||
if {[string equal -nocase [string trimright $elem_device :] [string trimright $sharename :]]} { |
||||
# Device name matches. Use it |
||||
set local $elem_device |
||||
set unc $elem_unc |
||||
break |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {![info exists unc]} { |
||||
win32_error 2250 "Share '$sharename' not found." |
||||
} |
||||
|
||||
# At this point $unc is the UNC form of the share and |
||||
# $local is either undefined or the local mapped device if there is one |
||||
|
||||
array set opts [parseargs args { |
||||
user |
||||
localdevice |
||||
remoteshare |
||||
status |
||||
type |
||||
opencount |
||||
usecount |
||||
domain |
||||
provider |
||||
comment |
||||
all |
||||
} -maxleftover 0 -hyphenated] |
||||
|
||||
|
||||
# Call Twapi_NetGetInfo always to get status. If we are not connected, |
||||
# we will not call WNetGetResourceInformation as that will time out |
||||
if {[info exists local]} { |
||||
set share [NetUseGetInfo "" $local 2] |
||||
} else { |
||||
set share [NetUseGetInfo "" $unc 2] |
||||
} |
||||
array set shareinfo [USE_INFO_2 $share] |
||||
unset shareinfo(-password) |
||||
if {[info exists shareinfo(-status)]} { |
||||
set shareinfo(-status) [_map_useinfo_status $shareinfo(-status)] |
||||
} |
||||
if {[info exists shareinfo(-type)]} { |
||||
set shareinfo(-type) [_map_useinfo_type $shareinfo(-type)] |
||||
} |
||||
|
||||
if {$opts(-all) || $opts(-comment) || $opts(-provider)} { |
||||
# Only get this information if we are connected |
||||
if {$shareinfo(-status) eq "connected"} { |
||||
set wnetinfo [lindex [Twapi_WNetGetResourceInformation $unc "" 0] 0] |
||||
set shareinfo(-comment) [lindex $wnetinfo 6] |
||||
set shareinfo(-provider) [lindex $wnetinfo 7] |
||||
} else { |
||||
set shareinfo(-comment) "" |
||||
set shareinfo(-provider) "" |
||||
} |
||||
} |
||||
|
||||
if {$opts(-all)} { |
||||
return [array get shareinfo] |
||||
} |
||||
|
||||
# Get rid of unwanted fields |
||||
foreach opt { |
||||
-user |
||||
-localdevice |
||||
-remoteshare |
||||
-status |
||||
-type |
||||
-opencount |
||||
-usecount |
||||
-domain |
||||
-provider |
||||
-comment |
||||
} { |
||||
if {! $opts($opt)} { |
||||
unset -nocomplain shareinfo($opt) |
||||
} |
||||
} |
||||
|
||||
return [array get shareinfo] |
||||
} |
||||
|
||||
|
||||
# Enumerate sessions |
||||
proc twapi::find_lm_sessions args { |
||||
array set opts [parseargs args { |
||||
all |
||||
{matchclient.arg ""} |
||||
{system.arg ""} |
||||
{matchuser.arg ""} |
||||
transport |
||||
clientname |
||||
user |
||||
clienttype |
||||
opencount |
||||
idleseconds |
||||
activeseconds |
||||
attrs |
||||
} -maxleftover 0] |
||||
|
||||
set level [_calc_minimum_session_info_level opts] |
||||
|
||||
# On all platforms, client must be in UNC format |
||||
set opts(matchclient) [_make_unc_computername $opts(matchclient)] |
||||
|
||||
trap { |
||||
set sessions [_net_enum_helper NetSessionEnum -system $opts(system) -preargs [list $opts(matchclient) $opts(matchuser)] -level $level -fields [SESSION_INFO_$level]] |
||||
} onerror {TWAPI_WIN32 2312} { |
||||
# No session matching the specified client |
||||
set sessions {} |
||||
} onerror {TWAPI_WIN32 2221} { |
||||
# No session matching the user |
||||
set sessions {} |
||||
} |
||||
|
||||
return [_format_lm_sessions $sessions opts] |
||||
} |
||||
|
||||
|
||||
# Get information about a session |
||||
proc twapi::get_lm_session_info {client user args} { |
||||
array set opts [parseargs args { |
||||
all |
||||
{system.arg ""} |
||||
transport |
||||
clientname |
||||
user |
||||
clienttype |
||||
opencount |
||||
idleseconds |
||||
activeseconds |
||||
attrs |
||||
} -maxleftover 0] |
||||
|
||||
set level [_calc_minimum_session_info_level opts] |
||||
if {$level == -1} { |
||||
# No data requested so return empty list |
||||
return [list ] |
||||
} |
||||
|
||||
if {![min_os_version 5]} { |
||||
# System name is specified. If NT, make sure it is UNC form |
||||
set opts(system) [_make_unc_computername $opts(system)] |
||||
} |
||||
|
||||
# On all platforms, client must be in UNC format |
||||
set client [_make_unc_computername $client] |
||||
|
||||
# Note an error is generated if no matching session exists |
||||
set sess [NetSessionGetInfo $opts(system) $client $user $level] |
||||
|
||||
return [recordarray index [_format_lm_sessions [list [SESSION_INFO_$level] [list $sess]] opts] 0 -format dict] |
||||
} |
||||
|
||||
# Delete sessions |
||||
proc twapi::end_lm_sessions args { |
||||
array set opts [parseargs args { |
||||
{client.arg ""} |
||||
{system.arg ""} |
||||
{user.arg ""} |
||||
} -maxleftover 0] |
||||
|
||||
if {![min_os_version 5]} { |
||||
# System name is specified. If NT, make sure it is UNC form |
||||
set opts(system) [_make_unc_computername $opts(system)] |
||||
} |
||||
|
||||
if {$opts(client) eq "" && $opts(user) eq ""} { |
||||
win32_error 87 "At least one of -client and -user must be specified." |
||||
} |
||||
|
||||
# On all platforms, client must be in UNC format |
||||
set opts(client) [_make_unc_computername $opts(client)] |
||||
|
||||
trap { |
||||
NetSessionDel $opts(system) $opts(client) $opts(user) |
||||
} onerror {TWAPI_WIN32 2312} { |
||||
# No session matching the specified client - ignore error |
||||
} onerror {TWAPI_WIN32 2221} { |
||||
# No session matching the user - ignore error |
||||
} |
||||
return |
||||
} |
||||
|
||||
# Enumerate open files |
||||
proc twapi::find_lm_open_files args { |
||||
array set opts [parseargs args { |
||||
{basepath.arg ""} |
||||
{system.arg ""} |
||||
{matchuser.arg ""} |
||||
all |
||||
permissions |
||||
id |
||||
lockcount |
||||
path |
||||
user |
||||
} -maxleftover 0] |
||||
|
||||
set level 3 |
||||
if {! ($opts(all) || $opts(permissions) || $opts(lockcount) || |
||||
$opts(path) || $opts(user))} { |
||||
# Only id's required |
||||
set level 2 |
||||
} |
||||
|
||||
# TBD - change to use -resume option to _net_enum_helper as there |
||||
# might be a lot of files |
||||
trap { |
||||
set files [_net_enum_helper NetFileEnum -system $opts(system) -preargs [list [file nativename $opts(basepath)] $opts(matchuser)] -level $level -fields [FILE_INFO_$level]] |
||||
} onerror {TWAPI_WIN32 2221} { |
||||
# No files matching the user |
||||
set files [list [FILE_INFO_$level] {}] |
||||
} |
||||
|
||||
return [_format_lm_open_files $files opts] |
||||
} |
||||
|
||||
# Get information about an open LM file |
||||
proc twapi::get_lm_open_file_info {fid args} { |
||||
array set opts [parseargs args { |
||||
{system.arg ""} |
||||
all |
||||
permissions |
||||
id |
||||
lockcount |
||||
path |
||||
user |
||||
} -maxleftover 0] |
||||
|
||||
# System name is specified. If NT, make sure it is UNC form |
||||
if {![min_os_version 5]} { |
||||
set opts(system) [_make_unc_computername $opts(system)] |
||||
} |
||||
|
||||
set level 3 |
||||
if {! ($opts(all) || $opts(permissions) || $opts(lockcount) || |
||||
$opts(path) || $opts(user))} { |
||||
# Only id's required. We actually already have this but don't |
||||
# return it since we want to go ahead and make the call in case |
||||
# the id does not exist |
||||
set level 2 |
||||
} |
||||
|
||||
return [recordarray index [_format_lm_open_files [list [FILE_INFO_$level] [list [NetFileGetInfo $opts(system) $fid $level]]] opts] 0 -format dict] |
||||
} |
||||
|
||||
# Close an open LM file |
||||
proc twapi::close_lm_open_file {fid args} { |
||||
array set opts [parseargs args { |
||||
{system.arg ""} |
||||
} -maxleftover 0] |
||||
trap { |
||||
NetFileClose $opts(system) $fid |
||||
} onerror {TWAPI_WIN32 2314} { |
||||
# No such fid. Ignore, perhaps it was closed in the meanwhile |
||||
} |
||||
} |
||||
|
||||
|
||||
# Enumerate open connections |
||||
proc twapi::find_lm_connections args { |
||||
array set opts [parseargs args { |
||||
client.arg |
||||
{system.arg ""} |
||||
share.arg |
||||
all |
||||
id |
||||
type |
||||
opencount |
||||
usercount |
||||
activeseconds |
||||
user |
||||
clientname |
||||
sharename |
||||
} -maxleftover 0] |
||||
|
||||
if {! ([info exists opts(client)] || [info exists opts(share)])} { |
||||
win32_error 87 "Must specify either -client or -share option." |
||||
} |
||||
|
||||
if {[info exists opts(client)] && [info exists opts(share)]} { |
||||
win32_error 87 "Must not specify both -client and -share options." |
||||
} |
||||
|
||||
if {[info exists opts(client)]} { |
||||
set qualifier [_make_unc_computername $opts(client)] |
||||
} else { |
||||
set qualifier $opts(share) |
||||
} |
||||
|
||||
set level 0 |
||||
if {$opts(all) || $opts(type) || $opts(opencount) || |
||||
$opts(usercount) || $opts(user) || |
||||
$opts(activeseconds) || $opts(clientname) || $opts(sharename)} { |
||||
set level 1 |
||||
} |
||||
|
||||
# TBD - change to use -resume option to _net_enum_helper since |
||||
# there might be a log of connections |
||||
set conns [_net_enum_helper NetConnectionEnum -system $opts(system) -preargs [list $qualifier] -level $level -fields [CONNECTION_INFO_$level]] |
||||
|
||||
# NOTE fields MUST BE IN SAME ORDER AS VALUES BELOW |
||||
if {! $opts(all)} { |
||||
set fields {} |
||||
foreach opt {id opencount usercount activeseconds user type} { |
||||
if {$opts(all) || $opts($opt)} { |
||||
lappend fields -$opt |
||||
} |
||||
} |
||||
if {$opts(all) || $opts(clientname) || $opts(sharename)} { |
||||
lappend fields -netname |
||||
} |
||||
set conns [recordarray get $conns -slice $fields] |
||||
} |
||||
set fields [recordarray fields $conns] |
||||
if {"-type" in $fields} { |
||||
set type_enum [enum $fields -type] |
||||
} |
||||
if {"-netname" in $fields} { |
||||
set netname_enum [enum $fields -netname] |
||||
} |
||||
|
||||
if {! ([info exists type_enum] || [info exists netname_enum])} { |
||||
# No need to massage any data |
||||
return $conns |
||||
} |
||||
|
||||
set recs {} |
||||
foreach rec [recordarray getlist $conns] { |
||||
if {[info exists type_enum]} { |
||||
lset rec $type_enum [_share_type_code_to_symbols [lindex $rec $type_enum]] |
||||
} |
||||
if {[info exists netname_enum]} { |
||||
# What's returned in the netname field depends on what we |
||||
# passed as the qualifier |
||||
if {[info exists opts(client)]} { |
||||
set sharename [lindex $rec $netname_enum] |
||||
set clientname [_make_unc_computername $opts(client)] |
||||
} else { |
||||
set sharename $opts(share) |
||||
set clientname [_make_unc_computername [lindex $rec $netname_enum]] |
||||
} |
||||
if {$opts(all) || $opts(clientname)} { |
||||
lappend rec $clientname |
||||
} |
||||
if {$opts(all) || $opts(sharename)} { |
||||
lappend rec $sharename |
||||
} |
||||
} |
||||
lappend recs $rec |
||||
} |
||||
if {$opts(all) || $opts(clientname)} { |
||||
lappend fields -clientname |
||||
} |
||||
if {$opts(all) || $opts(sharename)} { |
||||
lappend fields -sharename |
||||
} |
||||
|
||||
return [list $fields $recs] |
||||
} |
||||
|
||||
proc twapi::wnet_connected_resources {args} { |
||||
# Accept both file/disk and print/printer for historical reasons |
||||
# file and printer are official to match get_client_share_info |
||||
parseargs args { |
||||
{type.sym any {any 0 file 1 disk 1 print 2 printer 2}} |
||||
} -maxleftover 0 -setvars |
||||
set h [WNetOpenEnum 1 $type 0 ""] |
||||
trap { |
||||
set resources {} |
||||
set structdef [twapi::NETRESOURCE] |
||||
while {[llength [set rs [WNetEnumResource $h 100 $structdef]]]} { |
||||
foreach r $rs { |
||||
lappend resources [lrange $r 4 5] |
||||
} |
||||
} |
||||
} finally { |
||||
WNetCloseEnum $h |
||||
} |
||||
return $resources |
||||
} |
||||
|
||||
################################################################ |
||||
# Utility functions |
||||
|
||||
# Common code to figure out what SESSION_INFO level is required |
||||
# for the specified set of requested fields. v_opts is name |
||||
# of array indicating which fields are required |
||||
proc twapi::_calc_minimum_session_info_level {v_opts} { |
||||
upvar $v_opts opts |
||||
|
||||
# Set the information level requested based on options specified. |
||||
# We set the level to the one that requires the lowest possible |
||||
# privilege level and still includes the data requested. |
||||
if {$opts(all) || $opts(transport)} { |
||||
return 502 |
||||
} elseif {$opts(clienttype)} { |
||||
return 2 |
||||
} elseif {$opts(opencount) || $opts(attrs)} { |
||||
return 1 |
||||
} elseif {$opts(clientname) || $opts(user) || |
||||
$opts(idleseconds) || $opts(activeseconds)} { |
||||
return 10 |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
|
||||
# Common code to format a session record. v_opts is name of array |
||||
# that controls which fields are returned |
||||
# sessions is a record array |
||||
proc twapi::_format_lm_sessions {sessions v_opts} { |
||||
upvar $v_opts opts |
||||
|
||||
if {! $opts(all)} { |
||||
set fields {} |
||||
foreach opt { |
||||
transport user opencount idleseconds activeseconds |
||||
clienttype clientname attrs |
||||
} { |
||||
if {$opts(all) || $opts($opt)} { |
||||
lappend fields -$opt |
||||
} |
||||
} |
||||
set sessions [recordarray get $sessions -slice $fields] |
||||
} |
||||
|
||||
set fields [recordarray fields $sessions] |
||||
if {"-clientname" in $fields} { |
||||
set client_enum [enum $fields -clientname] |
||||
} |
||||
if {"-attrs" in $fields} { |
||||
set attrs_enum [enum $fields -attrs] |
||||
} |
||||
|
||||
if {! ([info exists client_enum] || [info exists attrs_enum])} { |
||||
return $sessions |
||||
} |
||||
|
||||
# Need to map client name and attrs fields |
||||
set recs {} |
||||
foreach rec [recordarray getlist $sessions] { |
||||
if {[info exists client_enum]} { |
||||
lset rec $client_enum [_make_unc_computername [lindex $rec $client_enum]] |
||||
} |
||||
if {[info exists attrs_enum]} { |
||||
set attrs {} |
||||
set flags [lindex $rec $attrs_enum] |
||||
if {$flags & 1} { |
||||
lappend attrs guest |
||||
} |
||||
if {$flags & 2} { |
||||
lappend attrs noencryption |
||||
} |
||||
lset rec $attrs_enum $attrs |
||||
} |
||||
lappend recs $rec |
||||
} |
||||
return [list $fields $recs] |
||||
} |
||||
|
||||
# Common code to format a lm open file record. v_opts is name of array |
||||
# that controls which fields are returned |
||||
proc twapi::_format_lm_open_files {files v_opts} { |
||||
upvar $v_opts opts |
||||
|
||||
if {! $opts(all)} { |
||||
set fields {} |
||||
foreach opt { |
||||
id lockcount path user permissions |
||||
} { |
||||
if {$opts(all) || $opts($opt)} { |
||||
lappend fields -$opt |
||||
} |
||||
} |
||||
set files [recordarray get $files -slice $fields] |
||||
} |
||||
|
||||
set fields [recordarray fields $files] |
||||
|
||||
if {"-permissions" ni $fields} { |
||||
return $files |
||||
} |
||||
|
||||
# Need to massage permissions |
||||
set enum [enum $fields -permissions] |
||||
|
||||
set recs {} |
||||
foreach rec [recordarray getlist $files] { |
||||
set permissions [list ] |
||||
set perms [lindex $rec $enum] |
||||
foreach {flag perm} {1 read 2 write 4 create} { |
||||
if {$perms & $flag} { |
||||
lappend permissions $perm |
||||
} |
||||
} |
||||
lset rec $enum $permissions |
||||
lappend recs $rec |
||||
} |
||||
|
||||
return [list $fields $recs] |
||||
} |
||||
|
||||
# NOTE: THIS ONLY MAPS FOR THE Net* functions, NOT THE WNet* |
||||
proc twapi::_share_type_symbols_to_code {typesyms {basetypeonly 0}} { |
||||
|
||||
# STYPE_DISKTREE 0 |
||||
# STYPE_PRINTQ 1 |
||||
# STYPE_DEVICE 2 |
||||
# STYPE_IPC 3 |
||||
switch -exact -- [lindex $typesyms 0] { |
||||
file { set code 0 } |
||||
printer { set code 1 } |
||||
device { set code 2 } |
||||
ipc { set code 3 } |
||||
default { |
||||
error "Unknown type network share type symbol [lindex $typesyms 0]" |
||||
} |
||||
} |
||||
|
||||
if {$basetypeonly} { |
||||
return $code |
||||
} |
||||
|
||||
# STYPE_TEMPORARY 0x40000000 |
||||
# STYPE_SPECIAL 0x80000000 |
||||
set special 0 |
||||
foreach sym [lrange $typesyms 1 end] { |
||||
switch -exact -- $sym { |
||||
special { setbits special 0x80000000 } |
||||
temporary { setbits special 0x40000000 } |
||||
file - |
||||
printer - |
||||
device - |
||||
ipc { |
||||
error "Base share type symbol '$sym' cannot be used as a share attribute type" |
||||
} |
||||
default { |
||||
error "Unknown type network share type symbol '$sym'" |
||||
} |
||||
} |
||||
} |
||||
|
||||
return [expr {$code | $special}] |
||||
} |
||||
|
||||
|
||||
# First element is always the base type of the share |
||||
# NOTE: THIS ONLY MAPS FOR THE Net* functions, NOT THE WNet* |
||||
proc twapi::_share_type_code_to_symbols {type} { |
||||
|
||||
# STYPE_DISKTREE 0 |
||||
# STYPE_PRINTQ 1 |
||||
# STYPE_DEVICE 2 |
||||
# STYPE_IPC 3 |
||||
# STYPE_TEMPORARY 0x40000000 |
||||
# STYPE_SPECIAL 0x80000000 |
||||
|
||||
set special [expr {$type & 0xC0000000}] |
||||
|
||||
# We need the special cast to int because else operands get promoted |
||||
# to 64 bits as the hex is treated as an unsigned value |
||||
switch -exact -- [expr {int($type & ~ $special)}] { |
||||
0 {set sym "file"} |
||||
1 {set sym "printer"} |
||||
2 {set sym "device"} |
||||
3 {set sym "ipc"} |
||||
default {set sym $type} |
||||
} |
||||
|
||||
set typesyms [list $sym] |
||||
|
||||
if {$special & 0x80000000} { |
||||
lappend typesyms special |
||||
} |
||||
|
||||
if {$special & 0x40000000} { |
||||
lappend typesyms temporary |
||||
} |
||||
|
||||
return $typesyms |
||||
} |
||||
|
||||
# Make sure a computer name is in unc format unless it is an empty |
||||
# string (local computer) |
||||
proc twapi::_make_unc_computername {name} { |
||||
if {$name eq ""} { |
||||
return "" |
||||
} else { |
||||
return "\\\\[string trimleft $name \\]" |
||||
} |
||||
} |
||||
|
||||
proc twapi::_map_useinfo_status {status} { |
||||
set sym [lindex {connected paused lostsession disconnected networkerror connecting reconnecting} $status] |
||||
if {$sym ne ""} { |
||||
return $sym |
||||
} else { |
||||
return $status |
||||
} |
||||
} |
||||
|
||||
proc twapi::_map_useinfo_type {type} { |
||||
# Note share type and use info types are different |
||||
return [_share_type_code_to_symbols [expr {$type & 0x3fffffff}]] |
||||
} |
||||
@ -0,0 +1,627 @@
|
||||
# |
||||
# Copyright (c) 2004-2011 Ashok P. Nadkarni |
||||
# All rights reserved. |
||||
# |
||||
# See the file LICENSE for license |
||||
|
||||
namespace eval twapi {} |
||||
|
||||
|
||||
# Get the specified shell folder |
||||
proc twapi::get_shell_folder {csidl args} { |
||||
variable csidl_lookup |
||||
|
||||
array set opts [parseargs args {create} -maxleftover 0] |
||||
|
||||
# Following are left out because they refer to virtual folders |
||||
# and will return error if used here |
||||
# CSIDL_BITBUCKET - 0xa |
||||
if {![info exists csidl_lookup]} { |
||||
array set csidl_lookup { |
||||
CSIDL_ADMINTOOLS 0x30 |
||||
CSIDL_COMMON_ADMINTOOLS 0x2f |
||||
CSIDL_APPDATA 0x1a |
||||
CSIDL_COMMON_APPDATA 0x23 |
||||
CSIDL_COMMON_DESKTOPDIRECTORY 0x19 |
||||
CSIDL_COMMON_DOCUMENTS 0x2e |
||||
CSIDL_COMMON_FAVORITES 0x1f |
||||
CSIDL_COMMON_MUSIC 0x35 |
||||
CSIDL_COMMON_PICTURES 0x36 |
||||
CSIDL_COMMON_PROGRAMS 0x17 |
||||
CSIDL_COMMON_STARTMENU 0x16 |
||||
CSIDL_COMMON_STARTUP 0x18 |
||||
CSIDL_COMMON_TEMPLATES 0x2d |
||||
CSIDL_COMMON_VIDEO 0x37 |
||||
CSIDL_COOKIES 0x21 |
||||
CSIDL_DESKTOPDIRECTORY 0x10 |
||||
CSIDL_FAVORITES 0x6 |
||||
CSIDL_HISTORY 0x22 |
||||
CSIDL_INTERNET_CACHE 0x20 |
||||
CSIDL_LOCAL_APPDATA 0x1c |
||||
CSIDL_MYMUSIC 0xd |
||||
CSIDL_MYPICTURES 0x27 |
||||
CSIDL_MYVIDEO 0xe |
||||
CSIDL_NETHOOD 0x13 |
||||
CSIDL_PERSONAL 0x5 |
||||
CSIDL_PRINTHOOD 0x1b |
||||
CSIDL_PROFILE 0x28 |
||||
CSIDL_PROFILES 0x3e |
||||
CSIDL_PROGRAMS 0x2 |
||||
CSIDL_PROGRAM_FILES 0x26 |
||||
CSIDL_PROGRAM_FILES_COMMON 0x2b |
||||
CSIDL_RECENT 0x8 |
||||
CSIDL_SENDTO 0x9 |
||||
CSIDL_STARTMENU 0xb |
||||
CSIDL_STARTUP 0x7 |
||||
CSIDL_SYSTEM 0x25 |
||||
CSIDL_TEMPLATES 0x15 |
||||
CSIDL_WINDOWS 0x24 |
||||
CSIDL_CDBURN_AREA 0x3b |
||||
} |
||||
} |
||||
|
||||
if {![string is integer $csidl]} { |
||||
set csidl_key [string toupper $csidl] |
||||
if {![info exists csidl_lookup($csidl_key)]} { |
||||
# Try by adding a CSIDL prefix |
||||
set csidl_key "CSIDL_$csidl_key" |
||||
if {![info exists csidl_lookup($csidl_key)]} { |
||||
error "Invalid CSIDL value '$csidl'" |
||||
} |
||||
} |
||||
set csidl $csidl_lookup($csidl_key) |
||||
} |
||||
|
||||
trap { |
||||
set path [SHGetSpecialFolderPath 0 $csidl $opts(create)] |
||||
} onerror {} { |
||||
# Try some other way to get the information |
||||
switch -exact -- [format %x $csidl] { |
||||
1a { catch {set path $::env(APPDATA)} } |
||||
2b { catch {set path $::env(CommonProgramFiles)} } |
||||
26 { catch {set path $::env(ProgramFiles)} } |
||||
24 { catch {set path $::env(windir)} } |
||||
25 { catch {set path [file join $::env(systemroot) system32]} } |
||||
} |
||||
if {![info exists path]} { |
||||
return "" |
||||
} |
||||
} |
||||
|
||||
return $path |
||||
} |
||||
|
||||
# Displays a shell property dialog for the given object |
||||
proc twapi::shell_object_properties_dialog {path args} { |
||||
array set opts [parseargs args { |
||||
{type.arg file {file printer volume}} |
||||
{hwin.int 0} |
||||
{page.arg ""} |
||||
} -maxleftover 0] |
||||
|
||||
|
||||
if {$opts(type) eq "file"} { |
||||
set path [file nativename [file normalize $path]] |
||||
} |
||||
|
||||
SHObjectProperties $opts(hwin) \ |
||||
[string map {printer 1 file 2 volume 4} $opts(type)] \ |
||||
$path \ |
||||
$opts(page) |
||||
} |
||||
|
||||
# Writes a shell shortcut |
||||
proc twapi::write_shortcut {link args} { |
||||
|
||||
array set opts [parseargs args { |
||||
path.arg |
||||
idl.arg |
||||
args.arg |
||||
desc.arg |
||||
hotkey.arg |
||||
iconpath.arg |
||||
iconindex.int |
||||
{showcmd.arg normal} |
||||
workdir.arg |
||||
relativepath.arg |
||||
runas.bool |
||||
} -nulldefault -maxleftover 0] |
||||
|
||||
# Map hot key to integer if needed |
||||
if {![string is integer -strict $opts(hotkey)]} { |
||||
if {$opts(hotkey) eq ""} { |
||||
set opts(hotkey) 0 |
||||
} else { |
||||
# Try treating it as symbolic |
||||
lassign [_hotkeysyms_to_vk $opts(hotkey)] modifiers vk |
||||
set opts(hotkey) $vk |
||||
if {$modifiers & 1} { |
||||
set opts(hotkey) [expr {$opts(hotkey) | (4<<8)}] |
||||
} |
||||
if {$modifiers & 2} { |
||||
set opts(hotkey) [expr {$opts(hotkey) | (2<<8)}] |
||||
} |
||||
if {$modifiers & 4} { |
||||
set opts(hotkey) [expr {$opts(hotkey) | (1<<8)}] |
||||
} |
||||
if {$modifiers & 8} { |
||||
set opts(hotkey) [expr {$opts(hotkey) | (8<<8)}] |
||||
} |
||||
} |
||||
} |
||||
|
||||
# IF a known symbol translate it. Note caller can pass integer |
||||
# values as well which will be kept as they are. Bogus valuse and |
||||
# symbols will generate an error on the actual call so we don't |
||||
# check here. |
||||
switch -exact -- $opts(showcmd) { |
||||
minimized { set opts(showcmd) 7 } |
||||
maximized { set opts(showcmd) 3 } |
||||
normal { set opts(showcmd) 1 } |
||||
} |
||||
|
||||
Twapi_WriteShortcut $link $opts(path) $opts(idl) $opts(args) \ |
||||
$opts(desc) $opts(hotkey) $opts(iconpath) $opts(iconindex) \ |
||||
$opts(relativepath) $opts(showcmd) $opts(workdir) $opts(runas) |
||||
} |
||||
|
||||
|
||||
# Read a shortcut |
||||
proc twapi::read_shortcut {link args} { |
||||
array set opts [parseargs args { |
||||
timeout.int |
||||
{hwin.int 0} |
||||
|
||||
{_comment {Path format flags}} |
||||
{shortnames {} 1} |
||||
{uncpath {} 2} |
||||
{rawpath {} 4} |
||||
|
||||
{_comment {Resolve flags}} |
||||
{install {} 128} |
||||
{nolinkinfo {} 64} |
||||
{notrack {} 32} |
||||
{nosearch {} 16} |
||||
{anymatch {} 2} |
||||
{noui {} 1} |
||||
} -maxleftover 0] |
||||
|
||||
set pathfmt [expr {$opts(shortnames) | $opts(uncpath) | $opts(rawpath)}] |
||||
|
||||
# 4 -> SLR_UPDATE |
||||
set resolve_flags [expr {4 | $opts(install) | $opts(nolinkinfo) | |
||||
$opts(notrack) | $opts(nosearch) | |
||||
$opts(anymatch) | $opts(noui)}] |
||||
|
||||
array set shortcut [twapi::Twapi_ReadShortcut $link $pathfmt $opts(hwin) $resolve_flags] |
||||
|
||||
switch -exact -- $shortcut(-showcmd) { |
||||
1 { set shortcut(-showcmd) normal } |
||||
3 { set shortcut(-showcmd) maximized } |
||||
7 { set shortcut(-showcmd) minimized } |
||||
} |
||||
|
||||
return [array get shortcut] |
||||
} |
||||
|
||||
|
||||
|
||||
# Writes a url shortcut |
||||
proc twapi::write_url_shortcut {link url args} { |
||||
|
||||
array set opts [parseargs args { |
||||
{missingprotocol.arg 0} |
||||
} -nulldefault -maxleftover 0] |
||||
|
||||
switch -exact -- $opts(missingprotocol) { |
||||
guess { |
||||
set opts(missingprotocol) 1; # IURL_SETURL_FL_GUESS_PROTOCOL |
||||
} |
||||
usedefault { |
||||
# 3 -> IURL_SETURL_FL_GUESS_PROTOCOL | IURL_SETURL_FL_USE_DEFAULT_PROTOCOL |
||||
# The former must also be specified (based on experimentation) |
||||
set opts(missingprotocol) 3 |
||||
} |
||||
default { |
||||
if {![string is integer -strict $opts(missingprotocol)]} { |
||||
error "Invalid value '$opts(missingprotocol)' for -missingprotocol option." |
||||
} |
||||
} |
||||
} |
||||
|
||||
Twapi_WriteUrlShortcut $link $url $opts(missingprotocol) |
||||
} |
||||
|
||||
# Read a url shortcut |
||||
proc twapi::read_url_shortcut {link} { |
||||
return [Twapi_ReadUrlShortcut $link] |
||||
} |
||||
|
||||
# Invoke a url shortcut |
||||
proc twapi::invoke_url_shortcut {link args} { |
||||
|
||||
array set opts [parseargs args { |
||||
verb.arg |
||||
{hwin.int 0} |
||||
allowui |
||||
} -maxleftover 0] |
||||
|
||||
set flags 0 |
||||
if {$opts(allowui)} {setbits flags 1} |
||||
if {! [info exists opts(verb)]} { |
||||
setbits flags 2 |
||||
set opts(verb) "" |
||||
} |
||||
|
||||
Twapi_InvokeUrlShortcut $link $opts(verb) $flags $opts(hwin) |
||||
} |
||||
|
||||
# Send a file to the recycle bin |
||||
proc twapi::recycle_file {fn args} { |
||||
return [recycle_files [list $fn] {*}$args] |
||||
} |
||||
|
||||
# Send multiple files to the recycle bin - from Alexandru |
||||
# This is much faster than "recycle_file"! |
||||
proc twapi::recycle_files {fns args} { |
||||
array set opts [parseargs args { |
||||
confirm.bool |
||||
showerror.bool |
||||
} -maxleftover 0 -nulldefault] |
||||
|
||||
if {$opts(confirm)} { |
||||
set flags 0x40; # FOF_ALLOWUNDO |
||||
} else { |
||||
set flags 0x50; # FOF_ALLOWUNDO | FOF_NOCONFIRMATION |
||||
} |
||||
|
||||
if {! $opts(showerror)} { |
||||
set flags [expr {$flags | 0x0400}]; # FOF_NOERRORUI |
||||
} |
||||
|
||||
set fns [lmap fn $fns { |
||||
file nativename [file normalize $fn] |
||||
}] |
||||
|
||||
return [expr {[lindex [Twapi_SHFileOperation 0 3 $fns __null__ $flags ""] 0] ? false : true}] |
||||
} |
||||
|
||||
proc twapi::shell_execute args { |
||||
# TBD - Document following shell_execute options after testing. |
||||
# [opt_def [cmd -connect] [arg BOOLEAN]] |
||||
# [opt_def [cmd -hicon] [arg HANDLE]] |
||||
# [opt_def [cmd -hkeyclass] [arg BOOLEAN]] |
||||
# [opt_def [cmd -hotkey] [arg HOTKEY]] |
||||
# [opt_def [cmd -nozonechecks] [arg BOOLEAN]] |
||||
|
||||
array set opts [parseargs args { |
||||
class.arg |
||||
dir.arg |
||||
{hicon.arg NULL} |
||||
{hkeyclass.arg NULL} |
||||
{hmonitor.arg NULL} |
||||
hotkey.arg |
||||
hwin.int |
||||
idl.arg |
||||
params.arg |
||||
path.arg |
||||
{show.arg 1} |
||||
verb.arg |
||||
|
||||
{getprocesshandle.bool 0 0x00000040} |
||||
{connect.bool 0 0x00000080} |
||||
{wait.bool 0x00000100 0x00000100} |
||||
{substenv.bool 0 0x00000200} |
||||
{noui.bool 0 0x00000400} |
||||
{unicode.bool 0 0x00004000} |
||||
{noconsole.bool 0 0x00008000} |
||||
{asyncok.bool 0 0x00100000} |
||||
{nozonechecks.bool 0 0x00800000} |
||||
{waitforinputidle.bool 0 0x02000000} |
||||
{logusage.bool 0 0x04000000} |
||||
{invokeidlist.bool 0 0x0000000C} |
||||
} -maxleftover 0 -nulldefault] |
||||
|
||||
set fmask 0 |
||||
|
||||
foreach {opt mask} { |
||||
class 1 |
||||
idl 4 |
||||
} { |
||||
if {$opts($opt) ne ""} { |
||||
setbits fmask $mask |
||||
} |
||||
} |
||||
|
||||
if {$opts(hkeyclass) ne "NULL"} { |
||||
setbits fmask 3 |
||||
} |
||||
|
||||
set fmask [expr {$fmask | |
||||
$opts(getprocesshandle) | $opts(connect) | $opts(wait) | |
||||
$opts(substenv) | $opts(noui) | $opts(unicode) | |
||||
$opts(noconsole) | $opts(asyncok) | $opts(nozonechecks) | |
||||
$opts(waitforinputidle) | $opts(logusage) | |
||||
$opts(invokeidlist)}] |
||||
|
||||
if {$opts(hicon) ne "NULL" && $opts(hmonitor) ne "NULL"} { |
||||
error "Cannot specify -hicon and -hmonitor options together." |
||||
} |
||||
|
||||
set hiconormonitor NULL |
||||
if {$opts(hicon) ne "NULL"} { |
||||
set hiconormonitor $opts(hicon) |
||||
set flags [expr {$flags | 0x00000010}] |
||||
} elseif {$opts(hmonitor) ne "NULL"} { |
||||
set hiconormonitor $opts(hmonitor) |
||||
set flags [expr {$flags | 0x00200000}] |
||||
} |
||||
|
||||
if {![string is integer -strict $opts(show)]} { |
||||
set opts(show) [dict get { |
||||
hide 0 |
||||
shownormal 1 |
||||
normal 1 |
||||
showminimized 2 |
||||
showmaximized 3 |
||||
maximize 3 |
||||
shownoactivate 4 |
||||
show 5 |
||||
minimize 6 |
||||
showminnoactive 7 |
||||
showna 8 |
||||
restore 9 |
||||
showdefault 10 |
||||
forceminimize 11 |
||||
} $opts(show)] |
||||
} |
||||
|
||||
if {$opts(hotkey) eq ""} { |
||||
set hotkey 0 |
||||
} else { |
||||
lassign [_hotkeysyms_to_vk $opts(hotkey) { |
||||
shift 1 |
||||
ctrl 2 |
||||
control 2 |
||||
alt 4 |
||||
menu 4 |
||||
ext 8 |
||||
}] modifiers vk |
||||
set hotkey [expr {($modifiers << 16) | $vk}] |
||||
} |
||||
if {$hotkey != 0} { |
||||
setbits fmask 0x00000020 |
||||
} |
||||
return [Twapi_ShellExecuteEx \ |
||||
$fmask \ |
||||
$opts(hwin) \ |
||||
$opts(verb) \ |
||||
$opts(path) \ |
||||
$opts(params) \ |
||||
$opts(dir) \ |
||||
$opts(show) \ |
||||
$opts(idl) \ |
||||
$opts(class) \ |
||||
$opts(hkeyclass) \ |
||||
$hotkey \ |
||||
$hiconormonitor] |
||||
} |
||||
|
||||
|
||||
namespace eval twapi::systemtray { |
||||
|
||||
namespace path [namespace parent] |
||||
|
||||
# Dictionary mapping id->handler, hicon |
||||
variable _icondata |
||||
set _icondata [dict create] |
||||
|
||||
variable _icon_id_ctr |
||||
|
||||
variable _message_map |
||||
array set _message_map { |
||||
123 contextmenu |
||||
512 mousemove |
||||
513 lbuttondown |
||||
514 lbuttonup |
||||
515 lbuttondblclk |
||||
516 rbuttondown |
||||
517 rbuttonup |
||||
518 rbuttondblclk |
||||
519 mbuttondown |
||||
520 mbuttonup |
||||
521 mbuttondblclk |
||||
522 mousewheel |
||||
523 xbuttondown |
||||
524 xbuttonup |
||||
525 xbuttondblclk |
||||
1024 select |
||||
1025 keyselect |
||||
1026 balloonshow |
||||
1027 balloonhide |
||||
1028 balloontimeout |
||||
1029 balloonuserclick |
||||
} |
||||
|
||||
proc _make_NOTIFYICONW {id args} { |
||||
# TBD - implement -hiddenicon and -sharedicon using |
||||
# dwState and dwStateMask |
||||
set state 0 |
||||
set statemask 0 |
||||
array set opts [parseargs args { |
||||
hicon.arg |
||||
tip.arg |
||||
balloon.arg |
||||
timeout.int |
||||
version.int |
||||
balloontitle.arg |
||||
{balloonicon.arg none {info warning error user none}} |
||||
{silent.bool 0} |
||||
} -maxleftover 0] |
||||
|
||||
set timeout_or_version 0 |
||||
if {[info exists opts(version)]} { |
||||
if {[info exists opts(timeout)]} { |
||||
error "Cannot simultaneously specify -timeout and -version." |
||||
} |
||||
set timeout_or_version $opts(version) |
||||
} else { |
||||
if {[info exists opts(timeout)]} { |
||||
set timeout_or_version $opts(timeout) |
||||
} |
||||
} |
||||
|
||||
set flags 0x1; # uCallbackMessage member is valid |
||||
if {[info exists opts(hicon)]} { |
||||
incr flags 0x2; # hIcon member is valid |
||||
} else { |
||||
set opts(hicon) NULL |
||||
} |
||||
|
||||
if {[info exists opts(tip)]} { |
||||
incr flags 0x4 |
||||
# Truncate if necessary to 127 chars |
||||
set opts(tip) [string range $opts(tip) 0 127] |
||||
} else { |
||||
set opts(tip) "" |
||||
} |
||||
|
||||
if {[info exists opts(balloon)] || [info exists opts(balloontitle)]} { |
||||
incr flags 0x10 |
||||
} |
||||
|
||||
if {[info exists opts(balloon)]} { |
||||
set opts(balloon) [string range $opts(balloon) 0 255] |
||||
} else { |
||||
set opts(balloon) "" |
||||
} |
||||
|
||||
if {[info exists opts(balloontitle)]} { |
||||
set opts(balloontitle) [string range $opts(balloontitle) 0 63] |
||||
} else { |
||||
set opts(balloontitle) "" |
||||
} |
||||
|
||||
# Calculate padding for text fields (in bytes so 2*num padchars) |
||||
set tip_padcount [expr {2*(128 - [string length $opts(tip)])}] |
||||
set balloon_padcount [expr {2*(256 - [string length $opts(balloon)])}] |
||||
set balloontitle_padcount [expr {2 * (64 - [string length $opts(balloontitle)])}] |
||||
if {$opts(balloonicon) eq "user"} { |
||||
if {![min_os_version 5 1 2]} { |
||||
# 'user' not supported before XP SP2 |
||||
set opts(balloonicon) none |
||||
} |
||||
} |
||||
|
||||
set balloonflags [dict get { |
||||
none 0 |
||||
info 1 |
||||
warning 2 |
||||
error 3 |
||||
user 4 |
||||
} $opts(balloonicon)] |
||||
|
||||
if {$balloonflags == 4} { |
||||
if {![info exists opts(hicon)]} { |
||||
error "Option -hicon must be specified if value of -balloonicon option is 'user'" |
||||
} |
||||
} |
||||
|
||||
if {$opts(silent)} { |
||||
incr balloonflags 0x10 |
||||
} |
||||
|
||||
if {$::tcl_platform(pointerSize) == 8} { |
||||
set addrfmt m |
||||
set alignment x4 |
||||
} else { |
||||
set addrfmt n |
||||
set alignment x0 |
||||
} |
||||
|
||||
set hwnd [pointer_to_address [Twapi_GetNotificationWindow]] |
||||
set opts(hicon) [pointer_to_address $opts(hicon)] |
||||
|
||||
set bin [binary format "${alignment}${addrfmt}nnn" $hwnd $id $flags [_get_script_wm NOTIFY_ICON_CALLBACK]] |
||||
append bin \ |
||||
[binary format ${alignment}${addrfmt} $opts(hicon)] \ |
||||
[encoding convertto unicode $opts(tip)] \ |
||||
[binary format "x${tip_padcount}nn" $state $statemask] \ |
||||
[encoding convertto unicode $opts(balloon)] \ |
||||
[binary format "x${balloon_padcount}n" $timeout_or_version] \ |
||||
[encoding convertto unicode $opts(balloontitle)] \ |
||||
[binary format "x${balloontitle_padcount}nx16" $balloonflags] |
||||
return "[binary format n [expr {4+[string length $bin]}]]$bin" |
||||
} |
||||
|
||||
proc addicon {hicon {cmdprefix ""}} { |
||||
variable _icon_id_ctr |
||||
variable _icondata |
||||
|
||||
_register_script_wm_handler [_get_script_wm NOTIFY_ICON_CALLBACK] [list [namespace current]::_icon_handler] 1 |
||||
_register_script_wm_handler [_get_script_wm TASKBAR_RESTART] [list [namespace current]::_taskbar_restart_handler] 1 |
||||
|
||||
set id [incr _icon_id_ctr] |
||||
|
||||
# 0 -> Add |
||||
Shell_NotifyIcon 0 [_make_NOTIFYICONW $id -hicon $hicon] |
||||
|
||||
# 4 -> set version (controls notification behaviour) to 3 (Win2K+) |
||||
if {[catch { |
||||
Shell_NotifyIcon 4 [_make_NOTIFYICONW $id -version 3] |
||||
} ermsg]} { |
||||
set ercode $::errorCode |
||||
set erinfo $::errorInfo |
||||
removeicon $id |
||||
error $ermsg $erinfo $ercode |
||||
} |
||||
|
||||
if {[llength $cmdprefix]} { |
||||
dict set _icondata $id handler $cmdprefix |
||||
} |
||||
dict set _icondata $id hicon $hicon |
||||
|
||||
return $id |
||||
} |
||||
|
||||
proc removeicon {id} { |
||||
variable _icondata |
||||
|
||||
# Ignore errors in case dup call |
||||
catch {Shell_NotifyIcon 2 [_make_NOTIFYICONW $id]} |
||||
dict unset _icondata $id |
||||
} |
||||
|
||||
proc modifyicon {id args} { |
||||
# TBD - do we need to [dict set _icondata hicon ...] ? |
||||
Shell_NotifyIcon 1 [_make_NOTIFYICONW $id {*}$args] |
||||
} |
||||
|
||||
proc _icon_handler {msg id notification msgpos ticks} { |
||||
variable _icondata |
||||
variable _message_map |
||||
|
||||
if {![dict exists $_icondata $id handler]} { |
||||
return; # Stale or no handler specified |
||||
} |
||||
|
||||
# Translate the notification into text |
||||
if {[info exists _message_map($notification)]} { |
||||
set notification $_message_map($notification) |
||||
} |
||||
|
||||
uplevel #0 [linsert [dict get $_icondata $id handler] end $id $notification $msgpos $ticks] |
||||
} |
||||
|
||||
proc _taskbar_restart_handler {args} { |
||||
variable _icondata |
||||
# Need to add icons back into taskbar |
||||
dict for {id icodata} $_icondata { |
||||
# 0 -> Add |
||||
Shell_NotifyIcon 0 [_make_NOTIFYICONW $id -hicon [dict get $icodata hicon]] |
||||
} |
||||
} |
||||
|
||||
namespace export addicon modifyicon removeicon |
||||
namespace ensemble create |
||||
} |
||||
@ -0,0 +1,801 @@
|
||||
# |
||||
# Copyright (c) 2007-2013, Ashok P. Nadkarni |
||||
# All rights reserved. |
||||
# |
||||
# See the file LICENSE for license |
||||
|
||||
namespace eval twapi { |
||||
|
||||
|
||||
# Holds SSPI security contexts indexed by a handle |
||||
# Each element is a dict with the following keys: |
||||
# State - state of the security context - see sspi_step |
||||
# Handle - the Win32 SecHandle for the context |
||||
# Input - Pending input from remote end to be passed in to |
||||
# SSPI provider (only valid for streams) |
||||
# Output - list of SecBuffers that contain data to be sent |
||||
# to remote end during a SSPI negotiation |
||||
# Inattr - requested context attributes |
||||
# Outattr - context attributes returned from service provider |
||||
# (currently not used) |
||||
# Expiration - time when context will expire |
||||
# Ctxtype - client, server |
||||
# Target - |
||||
# Datarep - data representation format |
||||
# Credentials - handle for credentials to pass to sspi provider |
||||
variable _sspi_state |
||||
array set _sspi_state {} |
||||
|
||||
proc* _init_security_context_syms {} { |
||||
variable _server_security_context_syms |
||||
variable _client_security_context_syms |
||||
variable _secpkg_capability_syms |
||||
|
||||
|
||||
# Symbols used for mapping server security context flags |
||||
array set _server_security_context_syms { |
||||
confidentiality 0x10 |
||||
connection 0x800 |
||||
delegate 0x1 |
||||
extendederror 0x8000 |
||||
identify 0x80000 |
||||
integrity 0x20000 |
||||
mutualauth 0x2 |
||||
replaydetect 0x4 |
||||
sequencedetect 0x8 |
||||
stream 0x10000 |
||||
} |
||||
|
||||
# Symbols used for mapping client security context flags |
||||
array set _client_security_context_syms { |
||||
confidentiality 0x10 |
||||
connection 0x800 |
||||
delegate 0x1 |
||||
extendederror 0x4000 |
||||
identify 0x20000 |
||||
integrity 0x10000 |
||||
manualvalidation 0x80000 |
||||
mutualauth 0x2 |
||||
replaydetect 0x4 |
||||
sequencedetect 0x8 |
||||
stream 0x8000 |
||||
usesessionkey 0x20 |
||||
usesuppliedcreds 0x80 |
||||
} |
||||
|
||||
# Symbols used for mapping security package capabilities |
||||
array set _secpkg_capability_syms { |
||||
integrity 0x00000001 |
||||
privacy 0x00000002 |
||||
tokenonly 0x00000004 |
||||
datagram 0x00000008 |
||||
connection 0x00000010 |
||||
multirequired 0x00000020 |
||||
clientonly 0x00000040 |
||||
extendederror 0x00000080 |
||||
impersonation 0x00000100 |
||||
acceptwin32name 0x00000200 |
||||
stream 0x00000400 |
||||
negotiable 0x00000800 |
||||
gsscompatible 0x00001000 |
||||
logon 0x00002000 |
||||
asciibuffers 0x00004000 |
||||
fragment 0x00008000 |
||||
mutualauth 0x00010000 |
||||
delegation 0x00020000 |
||||
readonlywithchecksum 0x00040000 |
||||
restrictedtokens 0x00080000 |
||||
negoextender 0x00100000 |
||||
negotiable2 0x00200000 |
||||
appcontainerpassthrough 0x00400000 |
||||
appcontainerchecks 0x00800000 |
||||
} |
||||
} {} |
||||
} |
||||
|
||||
# Return list of security packages |
||||
proc twapi::sspi_enumerate_packages {args} { |
||||
set pkgs [EnumerateSecurityPackages] |
||||
if {[llength $args] == 0} { |
||||
set names [list ] |
||||
foreach pkg $pkgs { |
||||
lappend names [kl_get $pkg Name] |
||||
} |
||||
return $names |
||||
} |
||||
|
||||
# TBD - why is this hyphenated ? |
||||
array set opts [parseargs args { |
||||
all capabilities version rpcid maxtokensize name comment |
||||
} -maxleftover 0 -hyphenated] |
||||
|
||||
_init_security_context_syms |
||||
variable _secpkg_capability_syms |
||||
set retdata {} |
||||
foreach pkg $pkgs { |
||||
set rec {} |
||||
if {$opts(-all) || $opts(-capabilities)} { |
||||
lappend rec -capabilities [_make_symbolic_bitmask [kl_get $pkg fCapabilities] _secpkg_capability_syms] |
||||
} |
||||
foreach {opt field} {-version wVersion -rpcid wRPCID -maxtokensize cbMaxToken -name Name -comment Comment} { |
||||
if {$opts(-all) || $opts($opt)} { |
||||
lappend rec $opt [kl_get $pkg $field] |
||||
} |
||||
} |
||||
dict set recdata [kl_get $pkg Name] $rec |
||||
} |
||||
return $recdata |
||||
} |
||||
|
||||
proc twapi::sspi_schannel_credentials args { |
||||
# TBD - do all these options work ? Check before documenting |
||||
# since they seem to be duplicated in InitializeSecurityContext |
||||
parseargs args { |
||||
certificates.arg |
||||
{rootstore.arg NULL} |
||||
sessionlifespan.int |
||||
usedefaultclientcert.bool |
||||
{disablereconnects.bool 0 0x80} |
||||
{revocationcheck.arg none {full endonly excluderoot none}} |
||||
{ignoreerrorrevocationoffline.bool 0 0x1000} |
||||
{ignoreerrornorevocationcheck.bool 0 0x800} |
||||
{validateservercert.bool 1} |
||||
cipherstrength.arg |
||||
protocols.arg |
||||
} -setvars -nulldefault -maxleftover 0 |
||||
|
||||
set flags [expr {$disablereconnects | $ignoreerrornorevocationcheck | $ignoreerrorrevocationoffline}] |
||||
incr flags [dict get { |
||||
none 0 full 0x200 excluderoot 0x400 endonly 0x100 |
||||
} $revocationcheck] |
||||
|
||||
if {$validateservercert} { |
||||
incr flags 0x20; # SCH_CRED_AUTO_CRED_VALIDATION |
||||
} else { |
||||
incr flags 0x8; # SCH_CRED_MANUAL_CRED_VALIDATION |
||||
} |
||||
if {$usedefaultclientcert} { |
||||
incr flags 0x40; # SCH_CRED_USE_DEFAULT_CREDS |
||||
} else { |
||||
incr flags 0x10; # SCH_CRED_NO_DEFAULT_CREDS |
||||
} |
||||
|
||||
set protbits 0 |
||||
foreach prot $protocols { |
||||
set protbits [expr { |
||||
$protbits | [dict! { |
||||
ssl2 0xc ssl3 0x30 tls1 0xc0 tls1.1 0x300 tls1.2 0xc00 |
||||
} $prot] |
||||
}] |
||||
} |
||||
|
||||
switch [llength $cipherstrength] { |
||||
0 { set minbits 0 ; set maxbits 0 } |
||||
1 { set minbits [lindex $cipherstrength 0] ; set maxbits $minbits } |
||||
2 { |
||||
set minbits [lindex $cipherstrength 0] |
||||
set maxbits [lindex $cipherstrength 1] |
||||
} |
||||
default { |
||||
error "Invalid value '$cipherstrength' for option -cipherstrength" |
||||
} |
||||
} |
||||
|
||||
# 4 -> SCHANNEL_CRED_VERSION |
||||
return [list 4 $certificates $rootstore {} {} $protbits $minbits $maxbits $sessionlifespan $flags 0] |
||||
} |
||||
|
||||
proc twapi::sspi_winnt_identity_credentials {user domain password} { |
||||
return [list $user $domain $password] |
||||
} |
||||
|
||||
proc twapi::sspi_acquire_credentials {args} { |
||||
parseargs args { |
||||
{credentials.arg {}} |
||||
principal.arg |
||||
{package.arg NTLM} |
||||
{role.arg both {client server inbound outbound both}} |
||||
getexpiration |
||||
} -maxleftover 0 -setvars -nulldefault |
||||
|
||||
set creds [AcquireCredentialsHandle $principal \ |
||||
[dict* { |
||||
unisp {Microsoft Unified Security Protocol Provider} |
||||
ssl {Microsoft Unified Security Protocol Provider} |
||||
tls {Microsoft Unified Security Protocol Provider} |
||||
} $package] \ |
||||
[kl_get {inbound 1 server 1 outbound 2 client 2 both 3} $role] \ |
||||
"" $credentials] |
||||
|
||||
if {$getexpiration} { |
||||
return [kl_create2 {-handle -expiration} $creds] |
||||
} else { |
||||
return [lindex $creds 0] |
||||
} |
||||
} |
||||
|
||||
# Frees credentials |
||||
proc twapi::sspi_free_credentials {cred} { |
||||
FreeCredentialsHandle $cred |
||||
} |
||||
|
||||
# Return a client context |
||||
proc twapi::sspi_client_context {cred args} { |
||||
_init_security_context_syms |
||||
variable _client_security_context_syms |
||||
|
||||
parseargs args { |
||||
target.arg |
||||
{datarep.arg network {native network}} |
||||
confidentiality.bool |
||||
connection.bool |
||||
delegate.bool |
||||
extendederror.bool |
||||
identify.bool |
||||
integrity.bool |
||||
manualvalidation.bool |
||||
mutualauth.bool |
||||
replaydetect.bool |
||||
sequencedetect.bool |
||||
stream.bool |
||||
usesessionkey.bool |
||||
usesuppliedcreds.bool |
||||
} -maxleftover 0 -nulldefault -setvars |
||||
|
||||
set context_flags 0 |
||||
foreach {opt flag} [array get _client_security_context_syms] { |
||||
if {[set $opt]} { |
||||
set context_flags [expr {$context_flags | $flag}] |
||||
} |
||||
} |
||||
|
||||
set drep [kl_get {native 0x10 network 0} $datarep] |
||||
return [_construct_sspi_security_context \ |
||||
sspiclient#[TwapiId] \ |
||||
[InitializeSecurityContext \ |
||||
$cred \ |
||||
"" \ |
||||
$target \ |
||||
$context_flags \ |
||||
0 \ |
||||
$drep \ |
||||
[list ] \ |
||||
0] \ |
||||
client \ |
||||
$context_flags \ |
||||
$target \ |
||||
$cred \ |
||||
$drep \ |
||||
] |
||||
} |
||||
|
||||
# Delete a security context |
||||
proc twapi::sspi_delete_context {ctx} { |
||||
variable _sspi_state |
||||
set h [_sspi_context_handle $ctx] |
||||
if {[llength $h]} { |
||||
DeleteSecurityContext $h |
||||
} |
||||
unset _sspi_state($ctx) |
||||
} |
||||
|
||||
# Shuts down a security context in orderly fashion |
||||
# Caller should start sspi_step |
||||
proc twapi::sspi_shutdown_context {ctx} { |
||||
variable _sspi_state |
||||
|
||||
_sspi_context_handle $ctx; # Verify handle |
||||
dict with _sspi_state($ctx) { |
||||
switch -nocase -- [lindex [QueryContextAttributes $Handle 10] 4] { |
||||
schannel - |
||||
"Microsoft Unified Security Protocol Provider" {} |
||||
default { return } |
||||
} |
||||
|
||||
# Signal to security provider we want to shutdown |
||||
Twapi_ApplyControlToken_SCHANNEL_SHUTDOWN $Handle |
||||
|
||||
if {$Ctxtype eq "client"} { |
||||
set rawctx [InitializeSecurityContext \ |
||||
$Credentials \ |
||||
$Handle \ |
||||
$Target \ |
||||
$Inattr \ |
||||
0 \ |
||||
$Datarep \ |
||||
[list ] \ |
||||
0] |
||||
} else { |
||||
set rawctx [AcceptSecurityContext \ |
||||
$Credentials \ |
||||
$Handle \ |
||||
[list ] \ |
||||
$Inattr \ |
||||
$Datarep] |
||||
} |
||||
lassign $rawctx State Handle out Outattr Expiration extra |
||||
if {$State in {ok expired}} { |
||||
return [list done [_gather_secbuf_data $out]] |
||||
} else { |
||||
return [list continue [_gather_secbuf_data $out]] |
||||
} |
||||
} |
||||
} |
||||
|
||||
# Take the next step in an SSPI negotiation |
||||
# Returns |
||||
# {done data extradata} |
||||
# {continue data} |
||||
# {expired data} |
||||
proc twapi::sspi_step {ctx {received ""}} { |
||||
variable _sspi_state |
||||
variable _client_security_context_syms |
||||
|
||||
_sspi_validate_handle $ctx |
||||
|
||||
dict with _sspi_state($ctx) { |
||||
# Note the dictionary content variables are |
||||
# State, Handle, Output, Outattr, Expiration, |
||||
# Ctxtype, Inattr, Target, Datarep, Credentials |
||||
|
||||
# Append new input to existing input |
||||
append Input $received |
||||
switch -exact -- $State { |
||||
ok { |
||||
set data [_gather_secbuf_data $Output] |
||||
set Output {} |
||||
|
||||
# $Input at this point contains left over input that is |
||||
# actually application data (streaming case). |
||||
# Application should pass this to decrypt commands |
||||
return [list done $data $Input[set Input ""]] |
||||
} |
||||
continue { |
||||
# Continue with the negotiation |
||||
if {[string length $Input] != 0} { |
||||
# Pass in received data to SSPI. |
||||
# Most providers take only the first buffer |
||||
# but SChannel/UNISP need the second. Since |
||||
# others don't seem to mind the second buffer |
||||
# we always always include it |
||||
# 2 -> SECBUFFER_TOKEN, 0 -> SECBUFFER_EMPTY |
||||
set inbuflist [list [list 2 $Input] [list 0]] |
||||
if {$Ctxtype eq "client"} { |
||||
set rawctx [InitializeSecurityContext \ |
||||
$Credentials \ |
||||
$Handle \ |
||||
$Target \ |
||||
$Inattr \ |
||||
0 \ |
||||
$Datarep \ |
||||
$inbuflist \ |
||||
0] |
||||
} else { |
||||
set rawctx [AcceptSecurityContext \ |
||||
$Credentials \ |
||||
$Handle \ |
||||
$inbuflist \ |
||||
$Inattr \ |
||||
$Datarep] |
||||
} |
||||
lassign $rawctx State Handle out Outattr Expiration extra |
||||
lappend Output {*}$out |
||||
# When the error is incomplete_credentials, we will retry |
||||
# with the SEC_I_INCOMPLETE_CREDENTIALS flag set. For |
||||
# this the Input should remain the same. Otherwise set it |
||||
# to whatever remains to be processed in the buffer. |
||||
if {$State ne "incomplete_credentials"} { |
||||
set Input $extra |
||||
} |
||||
# Will recurse at proc end |
||||
} else { |
||||
# There was no received data. Return any data |
||||
# to be sent to remote end |
||||
set data [_gather_secbuf_data $Output] |
||||
set Output {} |
||||
return [list continue $data ""] |
||||
} |
||||
} |
||||
incomplete_message { |
||||
# Caller has to get more data from remote end |
||||
set State continue |
||||
return [list continue "" ""] |
||||
} |
||||
expired { |
||||
# Remote end closed in middle of negotiation |
||||
return [list disconnected "" ""] |
||||
} |
||||
incomplete_credentials { |
||||
# In this state, the remote has asked for an client certificate. |
||||
# In this case, we ask Schannel to limit itself to whatever |
||||
# the user supplied and retry. Servers that ask for a cert |
||||
# but do not mandate it will then proceed. However, we only |
||||
# do this if we have not already tried this route. If we have, |
||||
# then generate an error. The real solution would be to attempt |
||||
# to look up new credentials by retrieving a certificate |
||||
# from the certificate store (possibly by asking the user) but |
||||
# this is not implemented. |
||||
# TBD - get client cert from user. See |
||||
# https://github.com/david-maw/StreamSSL and |
||||
# https://www.codeproject.com/Articles/1094525/Configuring-SSL-and-Client-Certificate-Validation |
||||
if {$Inattr & $_client_security_context_syms(usesuppliedcreds)} { |
||||
# Already tried with this. Give up. |
||||
set ermsg "Handling of incomplete credentials not implemented. If using TLS, specify the -credentials option to tls_socket to provide credentials." |
||||
error $ermsg "" [list TWAPI SSPI UNSUPPORTED $ermsg] |
||||
} |
||||
set Inattr [expr {$Inattr | $_client_security_context_syms(usesuppliedcreds)}] |
||||
set State continue |
||||
# Fall to bottom to recurse one more time |
||||
} |
||||
complete - |
||||
complete_and_continue { |
||||
# Should not actually occur as sspi.c no longer returns |
||||
# these codes |
||||
error "State $State handling not implemented." |
||||
} |
||||
} |
||||
} |
||||
|
||||
# Recurse to return next state. |
||||
# This has to be OUTSIDE the [dict with] above else it will not |
||||
# see the updated values |
||||
return [sspi_step $ctx] |
||||
} |
||||
|
||||
# Return a server context |
||||
proc twapi::sspi_server_context {cred clientdata args} { |
||||
_init_security_context_syms |
||||
variable _server_security_context_syms |
||||
|
||||
parseargs args { |
||||
{datarep.arg network {native network}} |
||||
confidentiality.bool |
||||
connection.bool |
||||
delegate.bool |
||||
extendederror.bool |
||||
identify.bool |
||||
integrity.bool |
||||
mutualauth.bool |
||||
replaydetect.bool |
||||
sequencedetect.bool |
||||
stream.bool |
||||
} -maxleftover 0 -nulldefault -setvars |
||||
|
||||
set context_flags 0 |
||||
foreach {opt flag} [array get _server_security_context_syms] { |
||||
if {[set $opt]} { |
||||
set context_flags [expr {$context_flags | $flag}] |
||||
} |
||||
} |
||||
|
||||
set drep [kl_get {native 0x10 network 0} $datarep] |
||||
return [_construct_sspi_security_context \ |
||||
sspiserver#[TwapiId] \ |
||||
[AcceptSecurityContext \ |
||||
$cred \ |
||||
"" \ |
||||
[list [list 2 $clientdata]] \ |
||||
$context_flags \ |
||||
$drep] \ |
||||
server \ |
||||
$context_flags \ |
||||
"" \ |
||||
$cred \ |
||||
$drep \ |
||||
] |
||||
} |
||||
|
||||
|
||||
# Get the security context flags after completion of request |
||||
proc ::twapi::sspi_context_features {ctx} { |
||||
variable _sspi_state |
||||
|
||||
set ctxh [_sspi_context_handle $ctx] |
||||
|
||||
_init_security_context_syms |
||||
|
||||
# We could directly look in the context itself but intead we make |
||||
# an explicit call, just in case they change after initial setup |
||||
set flags [QueryContextAttributes $ctxh 14] |
||||
|
||||
# Mapping of symbols depends on whether it is a client or server |
||||
# context |
||||
if {[dict get $_sspi_state($ctx) Ctxtype] eq "client"} { |
||||
upvar 0 [namespace current]::_client_security_context_syms syms |
||||
} else { |
||||
upvar 0 [namespace current]::_server_security_context_syms syms |
||||
} |
||||
|
||||
set result [list -raw $flags] |
||||
foreach {sym flag} [array get syms] { |
||||
lappend result -$sym [expr {($flag & $flags) != 0}] |
||||
} |
||||
|
||||
return $result |
||||
} |
||||
|
||||
# Get the user name for a security context |
||||
proc twapi::sspi_context_username {ctx} { |
||||
return [QueryContextAttributes [_sspi_context_handle $ctx] 1] |
||||
} |
||||
|
||||
# Get the field size information for a security context |
||||
# TBD - update for SSL |
||||
proc twapi::sspi_context_sizes {ctx} { |
||||
set sizes [QueryContextAttributes [_sspi_context_handle $ctx] 0] |
||||
return [twine {-maxtoken -maxsig -blocksize -trailersize} $sizes] |
||||
} |
||||
|
||||
proc twapi::sspi_remote_cert {ctx} { |
||||
return [QueryContextAttributes [_sspi_context_handle $ctx] 0x53] |
||||
} |
||||
|
||||
proc twapi::sspi_local_cert {ctx} { |
||||
return [QueryContextAttributes [_sspi_context_handle $ctx] 0x54] |
||||
} |
||||
|
||||
proc twapi::sspi_issuers_accepted_by_peer {ctx} { |
||||
return [QueryContextAttributes [_sspi_context_handle $ctx] 0x59] |
||||
} |
||||
|
||||
# Returns a signature |
||||
proc twapi::sspi_sign {ctx data args} { |
||||
parseargs args { |
||||
{seqnum.int 0} |
||||
{qop.int 0} |
||||
} -maxleftover 0 -setvars |
||||
|
||||
return [MakeSignature \ |
||||
[_sspi_context_handle $ctx] \ |
||||
$qop \ |
||||
$data \ |
||||
$seqnum] |
||||
} |
||||
|
||||
# Verify signature |
||||
proc twapi::sspi_verify_signature {ctx sig data args} { |
||||
parseargs args { |
||||
{seqnum.int 0} |
||||
} -maxleftover 0 -setvars |
||||
|
||||
# Buffer type 2 - Token, 1- Data |
||||
return [VerifySignature \ |
||||
[_sspi_context_handle $ctx] \ |
||||
[list [list 2 $sig] [list 1 $data]] \ |
||||
$seqnum] |
||||
} |
||||
|
||||
# Encrypts a data as per a context |
||||
# Returns {securitytrailer encrypteddata padding} |
||||
proc twapi::sspi_encrypt {ctx data args} { |
||||
parseargs args { |
||||
{seqnum.int 0} |
||||
{qop.int 0} |
||||
} -maxleftover 0 -setvars |
||||
|
||||
return [EncryptMessage \ |
||||
[_sspi_context_handle $ctx] \ |
||||
$qop \ |
||||
$data \ |
||||
$seqnum] |
||||
} |
||||
|
||||
proc twapi::sspi_encrypt_stream {ctx data args} { |
||||
variable _sspi_state |
||||
|
||||
set h [_sspi_context_handle $ctx] |
||||
|
||||
# TBD - docment options |
||||
parseargs args { |
||||
{qop.int 0} |
||||
} -maxleftover 0 -setvars |
||||
|
||||
set enc "" |
||||
while {[string length $data]} { |
||||
lassign [EncryptStream $h $qop $data] fragment data |
||||
lappend enc $fragment |
||||
} |
||||
|
||||
return [join $enc ""] |
||||
} |
||||
|
||||
# chan must be in binary mode |
||||
proc twapi::sspi_encrypt_and_write {ctx data chan args} { |
||||
variable _sspi_state |
||||
|
||||
set h [_sspi_context_handle $ctx] |
||||
|
||||
parseargs args { |
||||
{qop.int 0} |
||||
{flush.bool 1} |
||||
} -maxleftover 0 -setvars |
||||
|
||||
while {[string length $data]} { |
||||
lassign [EncryptStream $h $qop $data] fragment data |
||||
puts -nonewline $chan $fragment |
||||
} |
||||
|
||||
if {$flush} { |
||||
chan flush $chan |
||||
} |
||||
} |
||||
|
||||
|
||||
# Decrypts a message |
||||
# TBD - why does this not return a status like sspi_decrypt_stream ? |
||||
proc twapi::sspi_decrypt {ctx sig data padding args} { |
||||
variable _sspi_state |
||||
_sspi_validate_handle $ctx |
||||
|
||||
parseargs args { |
||||
{seqnum.int 0} |
||||
} -maxleftover 0 -setvars |
||||
|
||||
# Buffer type 2 - Token, 1- Data, 9 - padding |
||||
set decrypted [DecryptMessage \ |
||||
[dict get $_sspi_state($ctx) Handle] \ |
||||
[list [list 2 $sig] [list 1 $data] [list 9 $padding]] \ |
||||
$seqnum] |
||||
set plaintext {} |
||||
# Pick out only the data buffers, ignoring pad buffers and signature |
||||
# Optimize copies by keeping as a list so in the common case of a |
||||
# single buffer can return it as is. Multiple buffers are expensive |
||||
# because Tcl will shimmer each byte array into a list and then |
||||
# incur additional copies during joining |
||||
foreach buf $decrypted { |
||||
# SECBUFFER_DATA -> 1 |
||||
if {[lindex $buf 0] == 1} { |
||||
lappend plaintext [lindex $buf 1] |
||||
} |
||||
} |
||||
|
||||
if {[llength $plaintext] < 2} { |
||||
return [lindex $plaintext 0] |
||||
} else { |
||||
return [join $plaintext ""] |
||||
} |
||||
} |
||||
|
||||
# Decrypts a stream |
||||
proc twapi::sspi_decrypt_stream {ctx data} { |
||||
variable _sspi_state |
||||
set hctx [_sspi_context_handle $ctx] |
||||
|
||||
# SSL decryption is done in max size chunks. |
||||
# We will loop collecting as much data as possible. Collecting |
||||
# as a list and joining at end minimizes internal byte copies |
||||
set plaintext {} |
||||
lassign [DecryptStream $hctx [dict get $_sspi_state($ctx) Input] $data] status decrypted extra |
||||
lappend plaintext $decrypted |
||||
|
||||
# TBD - handle renegotiate status |
||||
while {$status eq "ok" && [string length $extra]} { |
||||
# See if additional data and loop again |
||||
lassign [DecryptStream $hctx $extra] status decrypted extra |
||||
lappend plaintext $decrypted |
||||
} |
||||
|
||||
dict set _sspi_state($ctx) Input $extra |
||||
if {$status eq "incomplete_message"} { |
||||
set status ok |
||||
} |
||||
return [list $status [join $plaintext ""]] |
||||
} |
||||
|
||||
|
||||
################################################################ |
||||
# Utility procs |
||||
|
||||
|
||||
# Construct a high level SSPI security context structure |
||||
# rawctx is context as returned from C level code |
||||
proc twapi::_construct_sspi_security_context {id rawctx ctxtype inattr target credentials datarep} { |
||||
variable _sspi_state |
||||
|
||||
set _sspi_state($id) [dict merge [dict create Ctxtype $ctxtype \ |
||||
Inattr $inattr \ |
||||
Target $target \ |
||||
Datarep $datarep \ |
||||
Credentials $credentials] \ |
||||
[twine \ |
||||
{State Handle Output Outattr Expiration Input} \ |
||||
$rawctx]] |
||||
|
||||
return $id |
||||
} |
||||
|
||||
proc twapi::_sspi_validate_handle {ctx} { |
||||
variable _sspi_state |
||||
|
||||
if {![info exists _sspi_state($ctx)]} { |
||||
badargs! "Invalid SSPI security context handle $ctx" 3 |
||||
} |
||||
} |
||||
|
||||
proc twapi::_sspi_context_handle {ctx} { |
||||
variable _sspi_state |
||||
|
||||
if {![info exists _sspi_state($ctx)]} { |
||||
badargs! "Invalid SSPI security context handle $ctx" 3 |
||||
} |
||||
|
||||
return [dict get $_sspi_state($ctx) Handle] |
||||
} |
||||
|
||||
proc twapi::_gather_secbuf_data {bufs} { |
||||
if {[llength $bufs] == 1} { |
||||
return [lindex [lindex $bufs 0] 1] |
||||
} else { |
||||
set data {} |
||||
foreach buf $bufs { |
||||
# First element is buffer type, which we do not care |
||||
# Second element is actual data |
||||
lappend data [lindex $buf 1] |
||||
} |
||||
return [join $data {}] |
||||
} |
||||
} |
||||
|
||||
if {0} { |
||||
TBD - delete |
||||
set cred [sspi_acquire_credentials -package ssl -role client] |
||||
set client [sspi_client_context $cred -stream 1 -manualvalidation 1] |
||||
set out [sspi_step $client] |
||||
set so [socket 192.168.1.127 443] |
||||
fconfigure $so -blocking 0 -buffering none -translation binary |
||||
puts -nonewline $so [lindex $out 1] |
||||
|
||||
set data [read $so] |
||||
set out [sspi_step $client $data] |
||||
puts -nonewline $so [lindex $out 1] |
||||
|
||||
set data [read $so] |
||||
set out [sspi_step $client $data] |
||||
|
||||
set out [sspi_encrypt_stream $client "GET / HTTP/1.0\r\n\r\n"] |
||||
puts -nonewline $so $out |
||||
set data [read $so] |
||||
set d [sspi_decrypt_stream $client $data] |
||||
sspi_shutdown_context $client |
||||
close $so ; sspi_free_credentials $cred ; sspi_free_context $client |
||||
sspi_context_free $client |
||||
sspi_shutdown_context $client |
||||
|
||||
# INTERNAL client-server |
||||
proc 'sslsetup {} { |
||||
uplevel #0 { |
||||
twapi |
||||
source ../tests/testutil.tcl |
||||
set ca [make_test_certs] |
||||
set cacert [cert_store_find_certificate $ca subject_substring twapitestca] |
||||
set scert [cert_store_find_certificate $ca subject_substring twapitestserver] |
||||
set scred [sspi_acquire_credentials -package ssl -role server -credentials [sspi_schannel_credentials -certificates [list $scert]]] |
||||
set ccert [cert_store_find_certificate $ca subject_substring twapitestclient] |
||||
set ccred [sspi_acquire_credentials -package ssl -role client -credentials [sspi_schannel_credentials]] |
||||
set cctx [sspi_client_context $ccred -stream 1 -manualvalidation 1] |
||||
set cstep [sspi_step $cctx] |
||||
|
||||
set sctx [sspi_server_context $scred [lindex $cstep 1] -stream 1] |
||||
set sstep [sspi_step $sctx] |
||||
set cstep [sspi_step $cctx [lindex $sstep 1]] |
||||
set sstep [sspi_step $sctx [lindex $cstep 1]] |
||||
set cstep [sspi_step $cctx [lindex $sstep 1]] |
||||
} |
||||
} |
||||
set out [sspi_encrypt_stream $cctx "This is a test"] |
||||
|
||||
sspi_decrypt_stream $sctx $out |
||||
sspi_decrypt_stream $sctx "" |
||||
set out [sspi_encrypt_stream $sctx "This is a testx"] |
||||
sspi_decrypt_stream $cctx $out |
||||
|
||||
proc 'ccred {} { |
||||
set store [cert_system_store_open twapitest user] |
||||
set ccert [cert_store_find_certificate $store subject_substring twapitestclient] |
||||
set ccred [sspi_acquire_credentials -package ssl -role client -credentials [sspi_schannel_credentials -certificates [list $ccert]]] |
||||
cert_store_release $store |
||||
cert_release $ccert |
||||
return $ccred |
||||
} |
||||
|
||||
} |
||||
@ -0,0 +1,616 @@
|
||||
# |
||||
# Copyright (c) 2003, 2008 Ashok P. Nadkarni |
||||
# All rights reserved. |
||||
# |
||||
# See the file LICENSE for license |
||||
|
||||
# TBD - convert file spec to drive root path |
||||
|
||||
# Get info associated with a drive |
||||
proc twapi::get_volume_info {drive args} { |
||||
|
||||
set drive [_drive_rootpath $drive] |
||||
|
||||
array set opts [parseargs args { |
||||
all size freespace used useravail type serialnum label maxcomponentlen fstype attr device extents |
||||
} -maxleftover 0] |
||||
|
||||
if {$opts(all)} { |
||||
# -all option does not cover -type, -extents and -device |
||||
foreach opt { |
||||
all size freespace used useravail serialnum label maxcomponentlen fstype attr |
||||
} { |
||||
set opts($opt) 1 |
||||
} |
||||
} |
||||
|
||||
set result [list ] |
||||
if {$opts(size) || $opts(freespace) || $opts(used) || $opts(useravail)} { |
||||
lassign [GetDiskFreeSpaceEx $drive] useravail size freespace |
||||
foreach opt {size freespace useravail} { |
||||
if {$opts($opt)} { |
||||
lappend result -$opt [set $opt] |
||||
} |
||||
} |
||||
if {$opts(used)} { |
||||
lappend result -used [expr {$size - $freespace}] |
||||
} |
||||
} |
||||
|
||||
if {$opts(type)} { |
||||
set drive_type [get_drive_type $drive] |
||||
lappend result -type $drive_type |
||||
} |
||||
if {$opts(device)} { |
||||
if {[_is_unc $drive]} { |
||||
# UNC paths cannot be used with QueryDosDevice |
||||
lappend result -device "" |
||||
} else { |
||||
lappend result -device [QueryDosDevice [string range $drive 0 1]] |
||||
} |
||||
} |
||||
|
||||
if {$opts(extents)} { |
||||
set extents {} |
||||
if {! [_is_unc $drive]} { |
||||
trap { |
||||
set device_handle [create_file "\\\\.\\[string range $drive 0 1]" -createdisposition open_existing] |
||||
set bin [device_ioctl $device_handle 0x560000 -outputcount 32] |
||||
if {[binary scan $bin i nextents] != 1} { |
||||
error "Truncated information returned from ioctl 0x560000" |
||||
} |
||||
set off 8 |
||||
for {set i 0} {$i < $nextents} {incr i} { |
||||
if {[binary scan $bin "@$off i x4 w w" extent(-disknumber) extent(-startingoffset) extent(-extentlength)] != 3} { |
||||
error "Truncated information returned from ioctl 0x560000" |
||||
} |
||||
lappend extents [array get extent] |
||||
incr off 24; # Size of one extent element |
||||
} |
||||
} onerror {} { |
||||
# Do nothing, device does not support extents or access denied |
||||
# Empty list is returned |
||||
} finally { |
||||
if {[info exists device_handle]} { |
||||
CloseHandle $device_handle |
||||
} |
||||
} |
||||
} |
||||
|
||||
lappend result -extents $extents |
||||
} |
||||
|
||||
if {$opts(serialnum) || $opts(label) || $opts(maxcomponentlen) |
||||
|| $opts(fstype) || $opts(attr)} { |
||||
foreach {label serialnum maxcomponentlen attr fstype} \ |
||||
[GetVolumeInformation $drive] { break } |
||||
foreach opt {label maxcomponentlen fstype} { |
||||
if {$opts($opt)} { |
||||
lappend result -$opt [set $opt] |
||||
} |
||||
} |
||||
if {$opts(serialnum)} { |
||||
set low [expr {$serialnum & 0x0000ffff}] |
||||
set high [expr {($serialnum >> 16) & 0x0000ffff}] |
||||
lappend result -serialnum [format "%.4X-%.4X" $high $low] |
||||
} |
||||
if {$opts(attr)} { |
||||
set attrs [list ] |
||||
foreach {sym val} { |
||||
case_preserved_names 2 |
||||
unicode_on_disk 4 |
||||
persistent_acls 8 |
||||
file_compression 16 |
||||
volume_quotas 32 |
||||
supports_sparse_files 64 |
||||
supports_reparse_points 128 |
||||
supports_remote_storage 256 |
||||
volume_is_compressed 0x8000 |
||||
supports_object_ids 0x10000 |
||||
supports_encryption 0x20000 |
||||
named_streams 0x40000 |
||||
read_only_volume 0x80000 |
||||
sequential_write_once 0x00100000 |
||||
supports_transactions 0x00200000 |
||||
supports_hard_links 0x00400000 |
||||
supports_extended_attributes 0x00800000 |
||||
supports_open_by_file_id 0x01000000 |
||||
supports_usn_journal 0x02000000 |
||||
} { |
||||
if {$attr & $val} { |
||||
lappend attrs $sym |
||||
} |
||||
} |
||||
lappend result -attr $attrs |
||||
} |
||||
} |
||||
|
||||
return $result |
||||
} |
||||
interp alias {} twapi::get_drive_info {} twapi::get_volume_info |
||||
|
||||
|
||||
# Check if disk has at least n bytes available for the user (NOT total free) |
||||
proc twapi::user_drive_space_available {drv space} { |
||||
return [expr {$space <= [lindex [get_drive_info $drv -useravail] 1]}] |
||||
} |
||||
|
||||
# Get the drive type |
||||
proc twapi::get_drive_type {drive} { |
||||
# set type [GetDriveType "[string trimright $drive :/\\]:\\"] |
||||
set type [GetDriveType [_drive_rootpath $drive]] |
||||
switch -exact -- $type { |
||||
0 { return unknown} |
||||
1 { return invalid} |
||||
2 { return removable} |
||||
3 { return fixed} |
||||
4 { return remote} |
||||
5 { return cdrom} |
||||
6 { return ramdisk} |
||||
} |
||||
} |
||||
|
||||
# Get list of drives |
||||
proc twapi::find_logical_drives {args} { |
||||
array set opts [parseargs args {type.arg}] |
||||
|
||||
set drives [list ] |
||||
foreach drive [_drivemask_to_drivelist [GetLogicalDrives]] { |
||||
if {(![info exists opts(type)]) || |
||||
[lsearch -exact $opts(type) [get_drive_type $drive]] >= 0} { |
||||
lappend drives $drive |
||||
} |
||||
} |
||||
return $drives |
||||
} |
||||
|
||||
twapi::proc* twapi::drive_ready {drive} { |
||||
uplevel #0 package require twapi_device |
||||
} { |
||||
set drive [string trimright $drive "/\\"] |
||||
if {[string length $drive] != 2 || [string index $drive 1] ne ":"} { |
||||
error "Invalid drive specification" |
||||
} |
||||
set drive "\\\\.\\$drive" |
||||
|
||||
# Do our best to avoid the Windows "Drive not ready" dialog |
||||
# 1 -> SEM_FAILCRITICALERRORS |
||||
if {[min_os_version 6]} { |
||||
set old_mode [SetErrorMode 1] |
||||
} |
||||
trap { |
||||
|
||||
# We will first try using IOCTL_STORAGE_CHECK_VERIFY2 as that is |
||||
# much faster and only needs FILE_READ_ATTRIBUTES access. |
||||
set error [catch { |
||||
set h [create_file $drive -access file_read_attributes \ |
||||
-createdisposition open_existing -share {read write}] |
||||
device_ioctl $h 0x2d0800; # IOCTL_STORAGE_CHECK_VERIFY2 |
||||
}] |
||||
if {[info exists h]} { |
||||
close_handle $h |
||||
} |
||||
if {! $error} { |
||||
return 1; # Device is ready |
||||
} |
||||
|
||||
# On error, try the older slower method. Note we now need |
||||
# GENERIC_READ access. (NOTE: FILE_READ_DATA will not work with some |
||||
# volume types) |
||||
unset -nocomplain h |
||||
set error [catch { |
||||
set h [create_file $drive -access generic_read \ |
||||
-createdisposition open_existing -share {read write}] |
||||
device_ioctl $h 0x2d4800; # IOCTL_STORAGE_CHECK_VERIFY |
||||
}] |
||||
if {[info exists h]} { |
||||
close_handle $h |
||||
} |
||||
if {! $error} { |
||||
return 1; # Device is ready |
||||
} |
||||
|
||||
# Remote shares sometimes return access denied with the above |
||||
# even when actually available. Try with good old file exists |
||||
# on root directory |
||||
return [file exists "[string range $drive end-1 end]\\"] |
||||
} finally { |
||||
if {[min_os_version 6]} { |
||||
SetErrorMode $old_mode |
||||
} |
||||
} |
||||
} |
||||
|
||||
|
||||
# Set the drive label |
||||
proc twapi::set_drive_label {drive label} { |
||||
SetVolumeLabel [_drive_rootpath $drive] $label |
||||
} |
||||
|
||||
# Maps a drive letter to the given path |
||||
proc twapi::map_drive_local {drive path args} { |
||||
array set opts [parseargs args {raw}] |
||||
|
||||
set drive [string range [_drive_rootpath $drive] 0 1] |
||||
DefineDosDevice $opts(raw) $drive [file nativename $path] |
||||
} |
||||
|
||||
|
||||
# Unmaps a drive letter |
||||
proc twapi::unmap_drive_local {drive args} { |
||||
array set opts [parseargs args { |
||||
path.arg |
||||
raw |
||||
} -nulldefault] |
||||
|
||||
set drive [string range [_drive_rootpath $drive] 0 1] |
||||
|
||||
set flags $opts(raw) |
||||
setbits flags 0x2; # DDD_REMOVE_DEFINITION |
||||
if {$opts(path) ne ""} { |
||||
setbits flags 0x4; # DDD_EXACT_MATCH_ON_REMOVE |
||||
} |
||||
DefineDosDevice $flags $drive [file nativename $opts(path)] |
||||
} |
||||
|
||||
|
||||
# Callback from C code |
||||
proc twapi::_filesystem_monitor_handler {id changes} { |
||||
variable _filesystem_monitor_scripts |
||||
if {[info exists _filesystem_monitor_scripts($id)]} { |
||||
return [uplevel #0 [linsert $_filesystem_monitor_scripts($id) end $id $changes]] |
||||
} else { |
||||
# Callback queued after close. Ignore |
||||
} |
||||
} |
||||
|
||||
# Monitor file changes |
||||
proc twapi::begin_filesystem_monitor {path script args} { |
||||
variable _filesystem_monitor_scripts |
||||
|
||||
array set opts [parseargs args { |
||||
{subtree.bool 0} |
||||
{filename.bool 0 0x1} |
||||
{dirname.bool 0 0x2} |
||||
{attr.bool 0 0x4} |
||||
{size.bool 0 0x8} |
||||
{write.bool 0 0x10} |
||||
{access.bool 0 0x20} |
||||
{create.bool 0 0x40} |
||||
{secd.bool 0 0x100} |
||||
{pattern.arg ""} |
||||
{patterns.arg ""} |
||||
} -maxleftover 0] |
||||
|
||||
if {[string length $opts(pattern)] && |
||||
[llength $opts(patterns)]} { |
||||
error "Options -pattern and -patterns are mutually exclusive. Note option -pattern is deprecated." |
||||
} |
||||
|
||||
if {[string length $opts(pattern)]} { |
||||
# Old style single pattern. Convert to new -patterns |
||||
set opts(patterns) [list "+$opts(pattern)"] |
||||
} |
||||
|
||||
# Change to use \ style path separator as that is what the file monitoring functions return |
||||
if {[llength $opts(patterns)]} { |
||||
foreach pat $opts(patterns) { |
||||
# Note / is replaced by \\ within the pattern |
||||
# since \ needs to be escaped with another \ within |
||||
# string match patterns |
||||
lappend pats [string map [list / \\\\] $pat] |
||||
} |
||||
set opts(patterns) $pats |
||||
} |
||||
|
||||
set flags [expr { $opts(filename) | $opts(dirname) | $opts(attr) | |
||||
$opts(size) | $opts(write) | $opts(access) | |
||||
$opts(create) | $opts(secd)}] |
||||
|
||||
if {! $flags} { |
||||
# If no options specified, default to all |
||||
set flags 0x17f |
||||
} |
||||
|
||||
set id [Twapi_RegisterDirectoryMonitor $path $opts(subtree) $flags $opts(patterns)] |
||||
set _filesystem_monitor_scripts($id) $script |
||||
return $id |
||||
} |
||||
|
||||
# Stop monitoring of files |
||||
proc twapi::cancel_filesystem_monitor {id} { |
||||
variable _filesystem_monitor_scripts |
||||
if {[info exists _filesystem_monitor_scripts($id)]} { |
||||
Twapi_UnregisterDirectoryMonitor $id |
||||
unset _filesystem_monitor_scripts($id) |
||||
} |
||||
} |
||||
|
||||
|
||||
# Get list of volumes |
||||
proc twapi::find_volumes {} { |
||||
set vols [list ] |
||||
set found 1 |
||||
# Assumes there has to be at least one volume |
||||
lassign [FindFirstVolume] handle vol |
||||
while {$found} { |
||||
lappend vols $vol |
||||
lassign [FindNextVolume $handle] found vol |
||||
} |
||||
FindVolumeClose $handle |
||||
return $vols |
||||
} |
||||
|
||||
# Get list of volume mount points |
||||
proc twapi::find_volume_mount_points {vol} { |
||||
set mntpts [list ] |
||||
set found 1 |
||||
trap { |
||||
lassign [FindFirstVolumeMountPoint $vol] handle mntpt |
||||
} onerror {TWAPI_WIN32 18} { |
||||
# ERROR_NO_MORE_FILES |
||||
# No volume mount points |
||||
return [list ] |
||||
} onerror {TWAPI_WIN32 3} { |
||||
# Volume does not support them |
||||
return [list ] |
||||
} |
||||
|
||||
# At least one volume found |
||||
while {$found} { |
||||
lappend mntpts $mntpt |
||||
lassign [FindNextVolumeMountPoint $handle] found mntpt |
||||
} |
||||
FindVolumeMountPointClose $handle |
||||
return $mntpts |
||||
} |
||||
|
||||
# Set volume mount point |
||||
proc twapi::mount_volume {volpt volname} { |
||||
# Note we don't use _drive_rootpath for trimming since may not be root path |
||||
SetVolumeMountPoint "[string trimright $volpt /\\]\\" "[string trimright $volname /\\]\\" |
||||
} |
||||
|
||||
# Delete volume mount point |
||||
proc twapi::unmount_volume {volpt} { |
||||
# Note we don't use _drive_rootpath for trimming since may not be root path |
||||
DeleteVolumeMountPoint "[string trimright $volpt /\\]\\" |
||||
} |
||||
|
||||
# Get the volume mounted at a volume mount point |
||||
proc twapi::get_mounted_volume_name {volpt} { |
||||
# Note we don't use _drive_rootpath for trimming since may not be root path |
||||
return [GetVolumeNameForVolumeMountPoint "[string trimright $volpt /\\]\\"] |
||||
} |
||||
|
||||
# Get the mount point corresponding to a given path |
||||
proc twapi::get_volume_mount_point_for_path {path} { |
||||
return [GetVolumePathName [file nativename $path]] |
||||
} |
||||
|
||||
|
||||
# Return the times associated with a file |
||||
proc twapi::get_file_times {fd args} { |
||||
array set opts [parseargs args { |
||||
all |
||||
mtime |
||||
ctime |
||||
atime |
||||
} -maxleftover 0] |
||||
|
||||
# Figure out if fd is a file path, Tcl channel or a handle |
||||
set close_handle false |
||||
if {[file exists $fd]} { |
||||
# It's a file name |
||||
# 0x02000000 -> FILE_FLAG_BACKUP_SEMANTICS, always required in case |
||||
# opening a directory (even if SeBackupPrivilege is not held |
||||
set h [create_file $fd -createdisposition open_existing -flags 0x02000000] |
||||
set close_handle true |
||||
} elseif {[catch {fconfigure $fd}]} { |
||||
# Not a Tcl channel, See if handle |
||||
if {[pointer? $fd]} { |
||||
set h $fd |
||||
} else { |
||||
error "$fd is not an existing file, handle or Tcl channel." |
||||
} |
||||
} else { |
||||
# Tcl channel |
||||
set h [get_tcl_channel_handle $fd read] |
||||
} |
||||
|
||||
set result [list ] |
||||
|
||||
foreach opt {ctime atime mtime} time [GetFileTime $h] { |
||||
if {$opts(all) || $opts($opt)} { |
||||
lappend result -$opt $time |
||||
} |
||||
} |
||||
|
||||
if {$close_handle} { |
||||
CloseHandle $h |
||||
} |
||||
|
||||
return $result |
||||
} |
||||
|
||||
|
||||
# Set the times associated with a file |
||||
proc twapi::set_file_times {fd args} { |
||||
|
||||
array set opts [parseargs args { |
||||
mtime.arg |
||||
ctime.arg |
||||
atime.arg |
||||
preserveatime |
||||
} -maxleftover 0 -nulldefault] |
||||
|
||||
if {$opts(atime) ne "" && $opts(preserveatime)} { |
||||
win32_error 87 "Cannot specify -atime and -preserveatime at the same time." |
||||
} |
||||
if {$opts(preserveatime)} { |
||||
set opts(atime) -1; # Meaning preserve access to original |
||||
} |
||||
|
||||
# Figure out if fd is a file path, Tcl channel or a handle |
||||
set close_handle false |
||||
if {[file exists $fd]} { |
||||
if {$opts(preserveatime)} { |
||||
win32_error 87 "Cannot specify -preserveatime unless file is specified as a Tcl channel or a Win32 handle." |
||||
} |
||||
|
||||
# It's a file name |
||||
# 0x02000000 -> FILE_FLAG_BACKUP_SEMANTICS, always required in case |
||||
# opening a directory (even if SeBackupPrivilege is not held |
||||
set h [create_file $fd -access {generic_write} -createdisposition open_existing -flags 0x02000000] |
||||
set close_handle true |
||||
} elseif {[catch {fconfigure $fd}]} { |
||||
# Not a Tcl channel, assume a handle |
||||
set h $fd |
||||
} else { |
||||
# Tcl channel |
||||
set h [get_tcl_channel_handle $fd read] |
||||
} |
||||
|
||||
SetFileTime $h $opts(ctime) $opts(atime) $opts(mtime) |
||||
|
||||
if {$close_handle} { |
||||
CloseHandle $h |
||||
} |
||||
|
||||
return |
||||
} |
||||
|
||||
# Convert a device based path to a normalized Win32 path with drive letters |
||||
proc twapi::normalize_device_rooted_path {path args} { |
||||
# TBD - keep a cache ? |
||||
# For example, we need to map \Device\HarddiskVolume1 to C: |
||||
# Can only do that by enumerating logical drives |
||||
set npath [file nativename $path] |
||||
if {![string match -nocase {\\Device\\*} $npath]} { |
||||
error "$path is not a valid device based path." |
||||
} |
||||
array set device_map {} |
||||
foreach drive [find_logical_drives] { |
||||
set device_path [lindex [lindex [get_volume_info $drive -device] 1] 0] |
||||
if {$device_path ne ""} { |
||||
set len [string length $device_path] |
||||
if {[string equal -nocase -length $len $path $device_path]} { |
||||
# Prefix matches, must be terminated by end or path separator |
||||
set ch [string index $npath $len] |
||||
if {$ch eq "" || $ch eq "\\"} { |
||||
set path ${drive}[string range $npath $len end] |
||||
if {[llength $args]} { |
||||
upvar [lindex $args 0] retvar |
||||
set retvar $path |
||||
return 1 |
||||
} else { |
||||
return $path |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {[llength $args]} { |
||||
return 0 |
||||
} else { |
||||
error "Could not map device based path '$path'" |
||||
} |
||||
} |
||||
|
||||
proc twapi::flush_channel {chan} { |
||||
flush $chan |
||||
FlushFileBuffers [get_tcl_channel_handle $chan write] |
||||
} |
||||
|
||||
proc twapi::find_file_open {path args} { |
||||
variable _find_tokens |
||||
variable _find_counter |
||||
parseargs args { |
||||
{detail.arg basic {basic full}} |
||||
} -setvars -maxleftover 0 |
||||
|
||||
set detail_level [expr {$detail eq "basic" ? 1 : 0}] |
||||
if {[min_os_version 6 1]} { |
||||
set flags 2; # FIND_FIRST_EX_LARGE_FETCH - Win 7 |
||||
} else { |
||||
set flags 0 |
||||
} |
||||
# 0 -> search op. Could be specified as 1 to limit search to |
||||
# directories but that is only advisory and does not seem to work |
||||
# in many cases. So don't bother making it an option. |
||||
lassign [FindFirstFileEx $path $detail_level 0 "" $flags] handle entry |
||||
set token ff#[incr _find_counter] |
||||
set _find_tokens($token) [list Handle $handle Entry $entry] |
||||
return $token |
||||
} |
||||
|
||||
proc twapi::find_file_close {token} { |
||||
variable _find_tokens |
||||
if {[info exists _find_tokens($token)]} { |
||||
FindClose [dict get $_find_tokens($token) Handle] |
||||
unset _find_tokens($token) |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc twapi::decode_file_attributes {attrs} { |
||||
return [_make_symbolic_bitmask $attrs { |
||||
archive 0x20 |
||||
compressed 0x800 |
||||
device 0x40 |
||||
directory 0x10 |
||||
encrypted 0x4000 |
||||
hidden 0x2 |
||||
integrity_stream 0x8000 |
||||
normal 0x80 |
||||
not_content_indexed 0x2000 |
||||
no_scrub_data 0x20000 |
||||
offline 0x1000 |
||||
readonly 0x1 |
||||
recall_on_data_access 0x400000 |
||||
recall_on_open 0x40000 |
||||
reparse_point 0x400 |
||||
sparse_file 0x200 |
||||
system 0x4 |
||||
temporary 0x100 |
||||
virtual 0x10000 |
||||
}] |
||||
} |
||||
|
||||
proc twapi::find_file_next {token varname} { |
||||
variable _find_tokens |
||||
if {![info exists _find_tokens($token)]} { |
||||
return false |
||||
} |
||||
if {[dict exists $_find_tokens($token) Entry]} { |
||||
set entry [dict get $_find_tokens($token) Entry] |
||||
dict unset _find_tokens($token) Entry |
||||
} else { |
||||
set entry [FindNextFile [dict get $_find_tokens($token) Handle]] |
||||
} |
||||
if {[llength $entry]} { |
||||
upvar 1 $varname result |
||||
set result [twine {attrs ctime atime mtime size reserve0 reserve1 name altname} $entry] |
||||
return true |
||||
} else { |
||||
return false |
||||
} |
||||
} |
||||
|
||||
# Utility functions |
||||
|
||||
proc twapi::_drive_rootpath {drive} { |
||||
if {[_is_unc $drive]} { |
||||
# UNC |
||||
return "[string trimright $drive ]\\" |
||||
} else { |
||||
return "[string trimright $drive :/\\]:\\" |
||||
} |
||||
} |
||||
|
||||
proc twapi::_is_unc {path} { |
||||
return [expr {[string match {\\\\*} $path] || [string match //* $path]}] |
||||
} |
||||
|
||||
|
||||
@ -0,0 +1,94 @@
|
||||
# |
||||
# Copyright (c) 2004, Ashok P. Nadkarni |
||||
# All rights reserved. |
||||
# |
||||
# See the file LICENSE for license |
||||
# |
||||
# TBD - tcl wrappers for semaphores |
||||
|
||||
namespace eval twapi { |
||||
} |
||||
|
||||
# |
||||
# Create and return a handle to a mutex |
||||
proc twapi::create_mutex {args} { |
||||
array set opts [parseargs args { |
||||
name.arg |
||||
secd.arg |
||||
inherit.bool |
||||
lock.bool |
||||
} -nulldefault -maxleftover 0] |
||||
|
||||
if {$opts(name) ne "" && $opts(lock)} { |
||||
# TBD - remove this mutex limitation |
||||
# This is not a Win32 limitation but ours. Would need to change the C |
||||
# implementation and our return format |
||||
error "Option -lock must not be specified as true if mutex is named" |
||||
} |
||||
|
||||
return [CreateMutex [_make_secattr $opts(secd) $opts(inherit)] $opts(lock) $opts(name)] |
||||
} |
||||
|
||||
# Get handle to an existing mutex |
||||
proc twapi::open_mutex {name args} { |
||||
array set opts [parseargs args { |
||||
{inherit.bool 0} |
||||
{access.arg {mutex_all_access}} |
||||
} -maxleftover 0] |
||||
|
||||
return [OpenMutex [_access_rights_to_mask $opts(access)] $opts(inherit) $name] |
||||
} |
||||
|
||||
# Lock the mutex |
||||
proc twapi::lock_mutex {h args} { |
||||
array set opts [parseargs args { |
||||
{wait.int -1} |
||||
}] |
||||
|
||||
return [wait_on_handle $h -wait $opts(wait)] |
||||
} |
||||
|
||||
|
||||
# Unlock the mutex |
||||
proc twapi::unlock_mutex {h} { |
||||
ReleaseMutex $h |
||||
} |
||||
|
||||
# |
||||
# Create and return a handle to a event |
||||
proc twapi::create_event {args} { |
||||
array set opts [parseargs args { |
||||
name.arg |
||||
secd.arg |
||||
inherit.bool |
||||
signalled.bool |
||||
manualreset.bool |
||||
existvar.arg |
||||
} -nulldefault -maxleftover 0] |
||||
|
||||
if {$opts(name) ne "" && $opts(signalled)} { |
||||
# Not clear whether event will be signalled state if it already |
||||
# existed but was not signalled |
||||
error "Option -signalled must not be specified as true if event is named." |
||||
} |
||||
|
||||
lassign [CreateEvent [_make_secattr $opts(secd) $opts(inherit)] $opts(manualreset) $opts(signalled) $opts(name)] h preexisted |
||||
if {$opts(manualreset)} { |
||||
# We want to catch attempts to wait on manual reset handles |
||||
set h [cast_handle $h HANDLE_MANUALRESETEVENT] |
||||
} |
||||
if {$opts(existvar) ne ""} { |
||||
upvar 1 $opts(existvar) existvar |
||||
set existvar $preexisted |
||||
} |
||||
|
||||
return $h |
||||
} |
||||
|
||||
interp alias {} twapi::set_event {} twapi::SetEvent |
||||
interp alias {} twapi::reset_event {} twapi::ResetEvent |
||||
|
||||
# Hack to work with the various build configuration. |
||||
if {[info commands ::twapi::get_version] ne ""} { |
||||
package provide twapi_synch [::twapi::get_version -patchlevel] |
||||
} |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,858 @@
|
||||
# |
||||
# Copyright (c) 2003-2018, Ashok P. Nadkarni |
||||
# All rights reserved. |
||||
# |
||||
# See the file LICENSE for license |
||||
|
||||
# General definitions and procs used by all TWAPI modules |
||||
|
||||
package require Tcl 8.5 |
||||
package require registry |
||||
|
||||
namespace eval twapi { |
||||
# Get rid of this ugliness - TBD |
||||
# Note this is different from NULL or {0 VOID} etc. It is more like |
||||
# a null token passed to functions that expect ptr to strings and |
||||
# allow the ptr to be NULL. |
||||
variable nullptr "__null__" |
||||
|
||||
variable scriptdir [file dirname [info script]] |
||||
|
||||
# Name of the var holding log messages in reflected in the C |
||||
# code, don't change it! |
||||
variable log_messages {} |
||||
|
||||
################################################################ |
||||
# Following procs are used early in init process so defined here |
||||
|
||||
# Throws a bad argument error that appears to come from caller's invocation |
||||
# (if default level is 2) |
||||
proc badargs! {msg {level 2}} { |
||||
return -level $level -code error -errorcode [list TWAPI BADARGS $msg] $msg |
||||
} |
||||
|
||||
proc lambda {arglist body {ns {}}} { |
||||
return [list ::apply [list $arglist $body $ns]] |
||||
} |
||||
|
||||
# Similar to lambda but takes additional parameters to be passed |
||||
# to the anonymous functin |
||||
proc lambda* {arglist body {ns {}} args} { |
||||
return [list ::apply [list $arglist $body $ns] {*}$args] |
||||
} |
||||
|
||||
# Rethrow original exception from inside a trap |
||||
proc rethrow {} { |
||||
return -code error -level 0 -options [twapi::trapoptions] [twapi::trapresult] |
||||
} |
||||
|
||||
# Dict lookup, returns default (from args) if not in dict and |
||||
# key itself if no defaults specified |
||||
proc dict* {d key args} { |
||||
if {[dict exists $d $key]} { |
||||
return [dict get $d $key] |
||||
} elseif {[llength $args]} { |
||||
return [lindex $args 0] |
||||
} else { |
||||
return $key |
||||
} |
||||
} |
||||
|
||||
proc dict! {d key {frame 0}} { |
||||
if {[dict exists $d $key]} { |
||||
return [dict get $d $key] |
||||
} else { |
||||
# frame is how must above the caller errorInfo must appear |
||||
return [badargs! "Bad value \"$key\". Must be one of [join [dict keys $d] {, }]" [incr frame 2]] |
||||
} |
||||
} |
||||
|
||||
|
||||
# Defines a proc with some initialization code |
||||
proc proc* {procname arglist initcode body} { |
||||
if {![string match ::* $procname]} { |
||||
set ns [uplevel 1 {namespace current}] |
||||
set procname ${ns}::$procname |
||||
} |
||||
set proc_def [format {proc %s {%s} {%s ; proc %s {%s} {%s} ; uplevel 1 [list %s] [lrange [info level 0] 1 end]}} $procname $arglist $initcode $procname $arglist $body $procname] |
||||
uplevel 1 $proc_def |
||||
} |
||||
|
||||
# Swap keys and values |
||||
proc swapl {l} { |
||||
set swapped {} |
||||
foreach {a b} $l { |
||||
lappend swapped $b $a |
||||
} |
||||
return $swapped |
||||
} |
||||
|
||||
# TBD - see if C would make faster |
||||
# Returns a list consisting of n'th index within each sublist element |
||||
# Should we allow n to be a nested index ? C impl may be harder |
||||
proc lpick {l {n 0}} { |
||||
set result {} |
||||
foreach e $l { |
||||
lappend result [lindex $e $n] |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
# Simple helper to treat lists as a stack |
||||
proc lpop {vl} { |
||||
upvar 1 $vl l |
||||
set top [lindex $l end] |
||||
# K combinator trick to reset l to allow lreplace to work in place |
||||
set l [lreplace $l [set l end] end] |
||||
return $top |
||||
} |
||||
|
||||
# twine list of n items |
||||
proc ntwine {fields l} { |
||||
set ntwine {} |
||||
foreach e $l { |
||||
lappend ntwine [twine $fields $e] |
||||
} |
||||
return $ntwine |
||||
} |
||||
|
||||
# Qualifies a name in context of caller's caller |
||||
proc callerns {name} { |
||||
if {[string match "::*" $name]} { |
||||
return $name |
||||
} |
||||
if {[info level] > 2} { |
||||
return [uplevel 2 namespace current]::$name |
||||
} else { |
||||
return ::$name |
||||
} |
||||
} |
||||
} |
||||
|
||||
# Make twapi versions the same as the base module versions |
||||
set twapi::version(twapi) $::twapi::version(twapi_base) |
||||
|
||||
# |
||||
# log for tracing / debug messages. |
||||
proc twapi::debuglog_clear {} { |
||||
variable log_messages |
||||
set log_messages {} |
||||
} |
||||
|
||||
proc twapi::debuglog_enable {} { |
||||
catch {rename [namespace current]::debuglog {}} |
||||
interp alias {} [namespace current]::debuglog {} [namespace current]::Twapi_AppendLog |
||||
} |
||||
|
||||
proc twapi::debuglog_disable {} { |
||||
proc [namespace current]::debuglog {args} {} |
||||
} |
||||
|
||||
proc twapi::debuglog_get {} { |
||||
variable log_messages |
||||
return $log_messages |
||||
} |
||||
|
||||
# Logging disabled by default |
||||
twapi::debuglog_disable |
||||
|
||||
proc twapi::get_build_config {{key ""}} { |
||||
variable build_ids |
||||
array set config [GetTwapiBuildInfo] |
||||
|
||||
# This is actually a runtime config and might not have been initialized |
||||
if {[info exists ::twapi::use_tcloo_for_com]} { |
||||
if {$::twapi::use_tcloo_for_com} { |
||||
set config(comobj_ootype) tcloo |
||||
} else { |
||||
set config(comobj_ootype) metoo |
||||
} |
||||
} else { |
||||
set config(comobj_ootype) uninitialized |
||||
} |
||||
|
||||
if {$key eq ""} { |
||||
return [array get config] |
||||
} else { |
||||
if {![info exists config($key)]} { |
||||
error "key not known"; # Matches tcl::pkgconfig error message |
||||
} |
||||
return $config($key) |
||||
} |
||||
} |
||||
|
||||
# This matches the pkgconfig command as defined by Tcl_RegisterConfig |
||||
# TBD - Doc and test |
||||
proc twapi::pkgconfig {subcommand {arg {}}} { |
||||
if {$subcommand eq "list"} { |
||||
if {$arg ne ""} { |
||||
error {wrong # args: should be "twapi::pkgconfig list"} |
||||
} |
||||
return [dict keys [get_build_config]] |
||||
} elseif {$subcommand eq "get"} { |
||||
if {$arg eq ""} { |
||||
error {wrong # args: should be "twapi::pkgconfig get key"} |
||||
} |
||||
return [get_build_config $arg] |
||||
} else { |
||||
error {wrong # args: should be "tcl::pkgconfig subcommand ?arg?"} |
||||
} |
||||
} |
||||
|
||||
# TBD - document |
||||
proc twapi::support_report {} { |
||||
set report "Operating system: [get_os_description]\n" |
||||
append report "Processors: [get_processor_count]\n" |
||||
append report "WOW64: [wow64_process]\n" |
||||
append report "Virtualized: [virtualized_process]\n" |
||||
append report "System locale: [get_system_default_lcid], [get_system_default_langid]\n" |
||||
append report "User locale: [get_user_default_lcid], [get_user_default_langid]\n" |
||||
append report "Tcl version: [info patchlevel]\n" |
||||
append report "tcl_platform:\n" |
||||
foreach k [lsort -dictionary [array names ::tcl_platform]] { |
||||
append report " $k = $::tcl_platform($k)\n" |
||||
} |
||||
append report "TWAPI version: [get_version -patchlevel]\n" |
||||
array set a [get_build_config] |
||||
append report "TWAPI config:\n" |
||||
foreach k [lsort -dictionary [array names a]] { |
||||
append report " $k = $a($k)\n" |
||||
} |
||||
append report "\nDebug log:\n[join [debuglog_get] \n]\n" |
||||
} |
||||
|
||||
|
||||
# Returns a list of raw Windows API functions supported |
||||
proc twapi::list_raw_api {} { |
||||
set rawapi [list ] |
||||
foreach fn [info commands ::twapi::*] { |
||||
if {[regexp {^::twapi::([A-Z][^_]*)$} $fn ignore fn]} { |
||||
lappend rawapi $fn |
||||
} |
||||
} |
||||
return $rawapi |
||||
} |
||||
|
||||
|
||||
# Wait for $wait_ms milliseconds or until $script returns $guard. $gap_ms is |
||||
# time between retries to call $script |
||||
# TBD - write a version that will allow other events to be processed |
||||
proc twapi::wait {script guard wait_ms {gap_ms 10}} { |
||||
if {$gap_ms == 0} { |
||||
set gap_ms 10 |
||||
} |
||||
set end_ms [expr {[clock clicks -milliseconds] + $wait_ms}] |
||||
while {[clock clicks -milliseconds] < $end_ms} { |
||||
set script_result [uplevel $script] |
||||
if {[string equal $script_result $guard]} { |
||||
return 1 |
||||
} |
||||
after $gap_ms |
||||
} |
||||
# Reached limit, one last try |
||||
return [string equal [uplevel $script] $guard] |
||||
} |
||||
|
||||
# Get twapi version |
||||
proc twapi::get_version {args} { |
||||
variable version |
||||
array set opts [parseargs args {patchlevel}] |
||||
if {$opts(patchlevel)} { |
||||
return $version(twapi) |
||||
} else { |
||||
# Only return major, minor |
||||
set ver $version(twapi) |
||||
regexp {^([[:digit:]]+\.[[:digit:]]+)[.ab]} $version(twapi) - ver |
||||
return $ver |
||||
} |
||||
} |
||||
|
||||
# Set all elements of the array to specified value |
||||
proc twapi::_array_set_all {v_arr val} { |
||||
upvar $v_arr arr |
||||
foreach e [array names arr] { |
||||
set arr($e) $val |
||||
} |
||||
} |
||||
|
||||
# Check if any of the specified array elements are non-0 |
||||
proc twapi::_array_non_zero_entry {v_arr indices} { |
||||
upvar $v_arr arr |
||||
foreach i $indices { |
||||
if {$arr($i)} { |
||||
return 1 |
||||
} |
||||
} |
||||
return 0 |
||||
} |
||||
|
||||
# Check if any of the specified array elements are non-0 |
||||
# and return them as a list of options (preceded with -) |
||||
proc twapi::_array_non_zero_switches {v_arr indices all} { |
||||
upvar $v_arr arr |
||||
set result [list ] |
||||
foreach i $indices { |
||||
if {$all || ([info exists arr($i)] && $arr($i))} { |
||||
lappend result -$i |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
|
||||
# Bitmask operations on 32bit values |
||||
# The int() casts are to deal with hex-decimal sign extension issues |
||||
proc twapi::setbits {v_bits mask} { |
||||
upvar $v_bits bits |
||||
set bits [expr {int($bits) | int($mask)}] |
||||
return $bits |
||||
} |
||||
proc twapi::resetbits {v_bits mask} { |
||||
upvar $v_bits bits |
||||
set bits [expr {int($bits) & int(~ $mask)}] |
||||
return $bits |
||||
} |
||||
|
||||
# Return a bitmask corresponding to a list of symbolic and integer values |
||||
# If symvals is a single item, it is an array else a list of sym bitmask pairs |
||||
proc twapi::_parse_symbolic_bitmask {syms symvals} { |
||||
if {[llength $symvals] == 1} { |
||||
upvar $symvals lookup |
||||
} else { |
||||
array set lookup $symvals |
||||
} |
||||
set bits 0 |
||||
foreach sym $syms { |
||||
if {[info exists lookup($sym)]} { |
||||
set bits [expr {$bits | $lookup($sym)}] |
||||
} else { |
||||
set bits [expr {$bits | $sym}] |
||||
} |
||||
} |
||||
return $bits |
||||
} |
||||
|
||||
# Return a list of symbols corresponding to a bitmask |
||||
proc twapi::_make_symbolic_bitmask {bits symvals {append_unknown 1}} { |
||||
if {[llength $symvals] == 1} { |
||||
upvar $symvals lookup |
||||
set map [array get lookup] |
||||
} else { |
||||
set map $symvals |
||||
} |
||||
set symbits 0 |
||||
set symmask [list ] |
||||
foreach {sym val} $map { |
||||
if {$bits & $val} { |
||||
set symbits [expr {$symbits | $val}] |
||||
lappend symmask $sym |
||||
} |
||||
} |
||||
|
||||
# Get rid of bits that mapped to symbols |
||||
set bits [expr {$bits & ~$symbits}] |
||||
# If any left over, add them |
||||
if {$bits && $append_unknown} { |
||||
lappend symmask $bits |
||||
} |
||||
return $symmask |
||||
} |
||||
|
||||
# Return a bitmask corresponding to a list of symbolic and integer values |
||||
# If symvals is a single item, it is an array else a list of sym bitmask pairs |
||||
# Ditto for switches - an array or flat list of switch boolean pairs |
||||
proc twapi::_switches_to_bitmask {switches symvals {bits 0}} { |
||||
if {[llength $symvals] == 1} { |
||||
upvar $symvals lookup |
||||
} else { |
||||
array set lookup $symvals |
||||
} |
||||
if {[llength $switches] == 1} { |
||||
upvar $switches swtable |
||||
} else { |
||||
array set swtable $switches |
||||
} |
||||
|
||||
foreach {switch bool} [array get swtable] { |
||||
if {$bool} { |
||||
set bits [expr {$bits | $lookup($switch)}] |
||||
} else { |
||||
set bits [expr {$bits & ~ $lookup($switch)}] |
||||
} |
||||
} |
||||
return $bits |
||||
} |
||||
|
||||
# Return a list of switche bool pairs corresponding to a bitmask |
||||
proc twapi::_bitmask_to_switches {bits symvals} { |
||||
if {[llength $symvals] == 1} { |
||||
upvar $symvals lookup |
||||
set map [array get lookup] |
||||
} else { |
||||
set map $symvals |
||||
} |
||||
set symbits 0 |
||||
set symmask [list ] |
||||
foreach {sym val} $map { |
||||
if {$bits & $val} { |
||||
set symbits [expr {$symbits | $val}] |
||||
lappend symmask $sym 1 |
||||
} else { |
||||
lappend symmask $sym 0 |
||||
} |
||||
} |
||||
|
||||
return $symmask |
||||
} |
||||
|
||||
# Make and return a keyed list |
||||
proc twapi::kl_create {args} { |
||||
if {[llength $args] & 1} { |
||||
error "No value specified for keyed list field [lindex $args end]. A keyed list must have an even number of elements." |
||||
} |
||||
return $args |
||||
} |
||||
|
||||
# Make a keyed list given fields and values |
||||
interp alias {} twapi::kl_create2 {} twapi::twine |
||||
|
||||
# Set a key value |
||||
proc twapi::kl_set {kl field newval} { |
||||
set i 0 |
||||
foreach {fld val} $kl { |
||||
if {[string equal $fld $field]} { |
||||
incr i |
||||
return [lreplace $kl $i $i $newval] |
||||
} |
||||
incr i 2 |
||||
} |
||||
lappend kl $field $newval |
||||
return $kl |
||||
} |
||||
|
||||
# Check if a field exists in the keyed list |
||||
proc twapi::kl_vget {kl field varname} { |
||||
upvar $varname var |
||||
return [expr {! [catch {set var [kl_get $kl $field]}]}] |
||||
} |
||||
|
||||
# Remote/unset a key value |
||||
proc twapi::kl_unset {kl field} { |
||||
array set arr $kl |
||||
unset -nocomplain arr($field) |
||||
return [array get arr] |
||||
} |
||||
|
||||
# Compare two keyed lists |
||||
proc twapi::kl_equal {kl_a kl_b} { |
||||
array set a $kl_a |
||||
foreach {kb valb} $kl_b { |
||||
if {[info exists a($kb)] && ($a($kb) == $valb)} { |
||||
unset a($kb) |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
if {[array size a]} { |
||||
return 0 |
||||
} else { |
||||
return 1 |
||||
} |
||||
} |
||||
|
||||
# Return the field names in a keyed list in the same order that they |
||||
# occured |
||||
proc twapi::kl_fields {kl} { |
||||
set fields [list ] |
||||
foreach {fld val} $kl { |
||||
lappend fields $fld |
||||
} |
||||
return $fields |
||||
} |
||||
|
||||
# Returns a flat list of the $field fields from a list |
||||
# of keyed lists |
||||
proc twapi::kl_flatten {list_of_kl args} { |
||||
set result {} |
||||
foreach kl $list_of_kl { |
||||
foreach field $args { |
||||
lappend result [kl_get $kl $field] |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
|
||||
# Return an array as a list of -index value pairs |
||||
proc twapi::_get_array_as_options {v_arr} { |
||||
upvar $v_arr arr |
||||
set result [list ] |
||||
foreach {index value} [array get arr] { |
||||
lappend result -$index $value |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
# Parse a list of two integers or a x,y pair and return a list of two integers |
||||
# Generate exception on format error using msg |
||||
proc twapi::_parse_integer_pair {pair {msg "Invalid integer pair"}} { |
||||
if {[llength $pair] == 2} { |
||||
lassign $pair first second |
||||
if {[string is integer -strict $first] && |
||||
[string is integer -strict $second]} { |
||||
return [list $first $second] |
||||
} |
||||
} elseif {[regexp {^([[:digit:]]+),([[:digit:]]+)$} $pair dummy first second]} { |
||||
return [list $first $second] |
||||
} |
||||
|
||||
error "$msg: '$pair'. Should be a list of two integers or in the form 'x,y'" |
||||
} |
||||
|
||||
|
||||
# Convert file names by substituting \SystemRoot and \??\ sequences |
||||
proc twapi::_normalize_path {path} { |
||||
# Get rid of \??\ prefixes |
||||
regsub {^[\\/]\?\?[\\/](.*)} $path {\1} path |
||||
|
||||
# Replace leading \SystemRoot with real system root |
||||
if {[string match -nocase {[\\/]Systemroot*} $path] && |
||||
([string index $path 11] in [list "" / \\])} { |
||||
return [file join [twapi::GetSystemWindowsDirectory] [string range $path 12 end]] |
||||
} else { |
||||
return [file normalize $path] |
||||
} |
||||
} |
||||
|
||||
|
||||
# Convert seconds to a list {Year Month Day Hour Min Sec Ms} |
||||
# (Ms will always be zero). |
||||
proc twapi::_seconds_to_timelist {secs {gmt 0}} { |
||||
# For each field, we need to trim the leading zeroes |
||||
set result [list ] |
||||
foreach x [clock format $secs -format "%Y %m %e %k %M %S 0" -gmt $gmt] { |
||||
lappend result [scan $x %d] |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
# Convert local time list {Year Month Day Hour Min Sec Ms} to seconds |
||||
# (Ms field is ignored) |
||||
# TBD - fix this gmt issue - not clear whether caller expects gmt time |
||||
proc twapi::_timelist_to_seconds {timelist} { |
||||
return [clock scan [_timelist_to_timestring $timelist] -gmt false] |
||||
} |
||||
|
||||
# Convert local time list {Year Month Day Hour Min Sec Ms} to a time string |
||||
# (Ms field is ignored) |
||||
proc twapi::_timelist_to_timestring {timelist} { |
||||
if {[llength $timelist] < 6} { |
||||
error "Invalid time list format" |
||||
} |
||||
|
||||
return "[lindex $timelist 0]-[lindex $timelist 1]-[lindex $timelist 2] [lindex $timelist 3]:[lindex $timelist 4]:[lindex $timelist 5]" |
||||
} |
||||
|
||||
# Convert a time string to a time list |
||||
proc twapi::_timestring_to_timelist {timestring} { |
||||
return [_seconds_to_timelist [clock scan $timestring -gmt false]] |
||||
} |
||||
|
||||
# Parse raw memory like binary scan command |
||||
proc twapi::mem_binary_scan {mem off mem_sz args} { |
||||
uplevel [list binary scan [Twapi_ReadMemory 1 $mem $off $mem_sz]] $args |
||||
} |
||||
|
||||
|
||||
# Validate guid syntax |
||||
proc twapi::_validate_guid {guid} { |
||||
if {![Twapi_IsValidGUID $guid]} { |
||||
error "Invalid GUID syntax: '$guid'" |
||||
} |
||||
} |
||||
|
||||
# Validate uuid syntax |
||||
proc twapi::_validate_uuid {uuid} { |
||||
if {![regexp {^[[:xdigit:]]{8}-[[:xdigit:]]{4}-[[:xdigit:]]{4}-[[:xdigit:]]{4}-[[:xdigit:]]{12}$} $uuid]} { |
||||
error "Invalid UUID syntax: '$uuid'" |
||||
} |
||||
} |
||||
|
||||
# Extract a UCS-16 string from a binary. Cannot directly use |
||||
# encoding convertfrom because that will not stop at the terminating |
||||
# null. The UCS-16 assumed to be little endian. |
||||
proc twapi::_ucs16_binary_to_string {bin {off 0}} { |
||||
set bin [string range $bin $off end] |
||||
|
||||
# Find the terminating null. |
||||
set off [string first \0\0 $bin] |
||||
while {$off > 0 && ($off & 1)} { |
||||
# Offset off is odd and so crosses a char boundary, so not the |
||||
# terminating null. Step to the char boundary and start search again |
||||
incr off |
||||
set off [string first \0\0 $bin $off] |
||||
} |
||||
# off is offset of terminating UCS-16 null, or -1 if not found |
||||
if {$off < 0} { |
||||
# No terminator |
||||
return [encoding convertfrom unicode $bin] |
||||
} else { |
||||
return [encoding convertfrom unicode [string range $bin 0 $off-1]] |
||||
} |
||||
} |
||||
|
||||
# Extract a string from a binary. Cannot directly use |
||||
# encoding convertfrom because that will not stop at the terminating |
||||
# null. |
||||
proc twapi::_ascii_binary_to_string {bin {off 0}} { |
||||
set bin [string range $bin $off end] |
||||
|
||||
# Find the terminating null. |
||||
set off [string first \0 $bin] |
||||
|
||||
# off is offset of terminating null, or -1 if not found |
||||
if {$off < 0} { |
||||
# No terminator |
||||
return [encoding convertfrom ascii $bin] |
||||
} else { |
||||
return [encoding convertfrom ascii [string range $bin 0 $off-1]] |
||||
} |
||||
} |
||||
|
||||
|
||||
# Given a binary, return a GUID. The formatting is done as per the |
||||
# Windows StringFromGUID2 convention used by COM |
||||
proc twapi::_binary_to_guid {bin {off 0}} { |
||||
if {[binary scan $bin "@$off i s s H4 H12" g1 g2 g3 g4 g5] != 5} { |
||||
error "Invalid GUID binary" |
||||
} |
||||
|
||||
return [format "{%8.8X-%2.2hX-%2.2hX-%s}" $g1 $g2 $g3 [string toupper "$g4-$g5"]] |
||||
} |
||||
|
||||
# Given a guid string, return a GUID in binary form |
||||
proc twapi::_guid_to_binary {guid} { |
||||
_validate_guid $guid |
||||
lassign [split [string range $guid 1 end-1] -] g1 g2 g3 g4 g5 |
||||
return [binary format "i s s H4 H12" 0x$g1 0x$g2 0x$g3 $g4 $g5] |
||||
} |
||||
|
||||
# Return a guid from raw memory |
||||
proc twapi::_decode_mem_guid {mem {off 0}} { |
||||
return [_binary_to_guid [Twapi_ReadMemory 1 $mem $off 16]] |
||||
} |
||||
|
||||
# Convert a Windows registry value to Tcl form. mem is a raw |
||||
# memory object. off is the offset into the memory object to read. |
||||
# $type is a integer corresponding |
||||
# to the registry types |
||||
proc twapi::_decode_mem_registry_value {type mem len {off 0}} { |
||||
set type [expr {$type}]; # Convert hex etc. to decimal form |
||||
switch -exact -- $type { |
||||
1 - |
||||
2 { |
||||
return [list [expr {$type == 2 ? "expand_sz" : "sz"}] \ |
||||
[Twapi_ReadMemory 3 $mem $off $len 1]] |
||||
} |
||||
7 { |
||||
# Collect strings until we come across an empty string |
||||
# Note two nulls right at the start will result in |
||||
# an empty list. Should it result in a list with |
||||
# one empty string element? Most code on the web treats |
||||
# it as the former so we do too. |
||||
set multi [list ] |
||||
while {1} { |
||||
set str [Twapi_ReadMemory 3 $mem $off -1] |
||||
set n [string length $str] |
||||
# Check for out of bounds. Cannot check for this before |
||||
# actually reading the string since we do not know size |
||||
# of the string. |
||||
if {($len != -1) && ($off+$n+1) > $len} { |
||||
error "Possible memory corruption: read memory beyond specified memory size." |
||||
} |
||||
if {$n == 0} { |
||||
return [list multi_sz $multi] |
||||
} |
||||
lappend multi $str |
||||
# Move offset by length of the string and terminating null |
||||
# (times 2 since unicode and we want byte offset) |
||||
incr off [expr {2*($n+1)}] |
||||
} |
||||
} |
||||
4 { |
||||
if {$len < 4} { |
||||
error "Insufficient number of bytes to convert to integer." |
||||
} |
||||
return [list dword [Twapi_ReadMemory 0 $mem $off]] |
||||
} |
||||
5 { |
||||
if {$len < 4} { |
||||
error "Insufficient number of bytes to convert to big-endian integer." |
||||
} |
||||
set type "dword_big_endian" |
||||
set scanfmt "I" |
||||
set len 4 |
||||
} |
||||
11 { |
||||
if {$len < 8} { |
||||
error "Insufficient number of bytes to convert to wide integer." |
||||
} |
||||
set type "qword" |
||||
set scanfmt "w" |
||||
set len 8 |
||||
} |
||||
0 { set type "none" } |
||||
6 { set type "link" } |
||||
8 { set type "resource_list" } |
||||
3 { set type "binary" } |
||||
default { |
||||
error "Unsupported registry value type '$type'" |
||||
} |
||||
} |
||||
|
||||
set val [Twapi_ReadMemory 1 $mem $off $len] |
||||
if {[info exists scanfmt]} { |
||||
if {[binary scan $val $scanfmt val] != 1} { |
||||
error "Could not convert from binary value using scan format $scanfmt" |
||||
} |
||||
} |
||||
|
||||
return [list $type $val] |
||||
} |
||||
|
||||
|
||||
proc twapi::_log_timestamp {} { |
||||
return [clock format [clock seconds] -format "%a %T"] |
||||
} |
||||
|
||||
|
||||
# Helper for Net*Enum type functions taking a common set of arguments |
||||
proc twapi::_net_enum_helper {function args} { |
||||
if {[llength $args] == 1} { |
||||
set args [lindex $args 0] |
||||
} |
||||
|
||||
# -namelevel is used internally to indicate what level is to be used |
||||
# to retrieve names. -preargs and -postargs are used internally to |
||||
# add additional arguments at specific positions in the generic call. |
||||
array set opts [parseargs args { |
||||
{system.arg ""} |
||||
level.int |
||||
resume.int |
||||
filter.int |
||||
{namelevel.int 0} |
||||
{preargs.arg {}} |
||||
{postargs.arg {}} |
||||
{namefield.int 0} |
||||
fields.arg |
||||
} -maxleftover 0] |
||||
|
||||
if {[info exists opts(level)]} { |
||||
set level $opts(level) |
||||
if {! [info exists opts(fields)]} { |
||||
badargs! "Option -fields must be specified if -level is specified" |
||||
} |
||||
} else { |
||||
set level $opts(namelevel) |
||||
} |
||||
|
||||
# Note later we need to know if opts(resume) was specified so |
||||
# don't change this to just default -resume to 0 above |
||||
if {[info exists opts(resume)]} { |
||||
set resumehandle $opts(resume) |
||||
} else { |
||||
set resumehandle 0 |
||||
} |
||||
|
||||
set moredata 1 |
||||
set result {} |
||||
while {$moredata} { |
||||
if {[info exists opts(filter)]} { |
||||
lassign [$function $opts(system) {*}$opts(preargs) $level $opts(filter) {*}$opts(postargs) $resumehandle] moredata resumehandle totalentries entries |
||||
} else { |
||||
lassign [$function $opts(system) {*}$opts(preargs) $level {*}$opts(postargs) $resumehandle] moredata resumehandle totalentries entries |
||||
} |
||||
# If caller does not want all data in one lump stop here |
||||
if {[info exists opts(resume)]} { |
||||
if {[info exists opts(level)]} { |
||||
return [list $moredata $resumehandle $totalentries [list $opts(fields) $entries]] |
||||
} else { |
||||
# Return flat list of names |
||||
return [list $moredata $resumehandle $totalentries [lpick $entries $opts(namefield)]] |
||||
} |
||||
} |
||||
|
||||
lappend result {*}$entries |
||||
} |
||||
|
||||
# Return what we have. Format depend on caller options. |
||||
if {[info exists opts(level)]} { |
||||
return [list $opts(fields) $result] |
||||
} else { |
||||
return [lpick $result $opts(namefield)] |
||||
} |
||||
} |
||||
|
||||
# If we are not being sourced from a executable resource, need to |
||||
# source the remaining support files. In the former case, they are |
||||
# automatically combined into one so the sourcing is not needed. |
||||
if {![info exists twapi::twapi_base_rc_sourced]} { |
||||
apply {{filelist} { |
||||
set dir [file dirname [info script]] |
||||
foreach f $filelist { |
||||
uplevel #0 [list source [file join $dir $f]] |
||||
} |
||||
}} {base.tcl handle.tcl win.tcl adsi.tcl} |
||||
} |
||||
|
||||
# Used in various matcher callbacks to signify always include etc. |
||||
# TBD - document |
||||
proc twapi::true {args} { |
||||
return true |
||||
} |
||||
|
||||
|
||||
namespace eval twapi { |
||||
# Get a handle to ourselves. This handle never need be closed |
||||
variable my_process_handle [GetCurrentProcess] |
||||
} |
||||
|
||||
# Only used internally for test validation. |
||||
# NOT the same as export_public_commands |
||||
proc twapi::_get_public_commands {} { |
||||
variable exports; # Populated via pkgIndex.tcl |
||||
if {[info exists exports]} { |
||||
return [concat {*}[dict values $exports]] |
||||
} else { |
||||
set cmds {} |
||||
foreach cmd [lsearch -regexp -inline -all [info commands [namespace current]::*] {::twapi::[a-z].*}] { |
||||
lappend cmds [namespace tail $cmd] |
||||
} |
||||
return $cmds |
||||
} |
||||
} |
||||
|
||||
proc twapi::export_public_commands {} { |
||||
variable exports; # Populated via pkgIndex.tcl |
||||
if {[info exists exports]} { |
||||
# Only export commands under twapi (e.g. not metoo) |
||||
dict for {ns cmds} $exports { |
||||
if {[regexp {^::twapi($|::)} $ns]} { |
||||
uplevel #0 [list namespace eval $ns [list namespace export {*}$cmds] |
||||
] |
||||
} |
||||
} |
||||
} else { |
||||
set cmds {} |
||||
foreach cmd [lsearch -regexp -inline -all [info commands [namespace current]::*] {::twapi::[a-z].*}] { |
||||
lappend cmds [namespace tail $cmd] |
||||
} |
||||
namespace eval [namespace current] "namespace export {*}$cmds" |
||||
} |
||||
} |
||||
|
||||
proc twapi::import_commands {} { |
||||
export_public_commands |
||||
uplevel namespace import twapi::* |
||||
} |
||||
|
||||
Binary file not shown.
@ -0,0 +1,11 @@
|
||||
# -*- tcl -*- |
||||
namespace eval twapi { |
||||
variable version |
||||
set version(twapi) 4.7.2 |
||||
variable patchlevel 4.7.2 |
||||
variable package_name twapi |
||||
variable dll_base_name twapi[string map {. {}} 4.7.2] |
||||
variable scriptdir [file dirname [info script]] |
||||
} |
||||
|
||||
source [file join $twapi::scriptdir twapi.tcl] |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,131 @@
|
||||
# |
||||
# Copyright (c) 2012 Ashok P. Nadkarni |
||||
# All rights reserved. |
||||
# |
||||
# See the file LICENSE for license |
||||
|
||||
# Contains common windowing and notification infrastructure |
||||
|
||||
namespace eval twapi { |
||||
variable null_hwin "" |
||||
|
||||
# Windows messages that are directly accessible from script. These |
||||
# are handled by the default notifications window and passed to |
||||
# the twapi::_script_wm_handler. These messages must be in the |
||||
# range (1056 = 1024+32) - (1024+32+31) (see twapi_wm.h) |
||||
variable _wm_script_msgs |
||||
array set _wm_script_msgs { |
||||
TASKBAR_RESTART 1031 |
||||
NOTIFY_ICON_CALLBACK 1056 |
||||
} |
||||
proc _get_script_wm {tok} { |
||||
variable _wm_script_msgs |
||||
return $_wm_script_msgs($tok) |
||||
} |
||||
} |
||||
|
||||
# Backward compatibility aliases |
||||
interp alias {} twapi::GetWindowLong {} twapi::GetWindowLongPtr |
||||
interp alias {} twapi::SetWindowLong {} twapi::SetWindowLongPtr |
||||
|
||||
# Return the long value at the given index |
||||
# This is a raw function, and should generally be used only to get |
||||
# non-system defined indices |
||||
proc twapi::get_window_long {hwin index} { |
||||
return [GetWindowLongPtr $hwin $index] |
||||
} |
||||
|
||||
# Set the long value at the given index and return the previous value |
||||
# This is a raw function, and should generally be used only to get |
||||
# non-system defined indices |
||||
proc twapi::set_window_long {hwin index val} { |
||||
set oldval [SetWindowLongPtr $hwin $index $val] |
||||
} |
||||
|
||||
# Set the user data associated with a window. Returns the previous value |
||||
proc twapi::set_window_userdata {hwin val} { |
||||
# GWL_USERDATA -> -21 |
||||
return [SetWindowLongPtr $hwin -21 $val] |
||||
} |
||||
|
||||
# Attaches to the thread queue of the thread owning $hwin and executes |
||||
# script in the caller's scope |
||||
proc twapi::_attach_hwin_and_eval {hwin script} { |
||||
set me [GetCurrentThreadId] |
||||
set hwin_tid [lindex [GetWindowThreadProcessId $hwin] 0] |
||||
if {$hwin_tid == 0} { |
||||
error "Window $hwin does not exist or could not get its thread owner" |
||||
} |
||||
|
||||
# Cannot (and no need to) attach to oneself so just exec script directly |
||||
if {$me == $hwin_tid} { |
||||
return [uplevel 1 $script] |
||||
} |
||||
|
||||
trap { |
||||
if {![AttachThreadInput $me $hwin_tid 1]} { |
||||
error "Could not attach to thread input for window $hwin" |
||||
} |
||||
set result [uplevel 1 $script] |
||||
} finally { |
||||
AttachThreadInput $me $hwin_tid 0 |
||||
} |
||||
|
||||
return $result |
||||
} |
||||
|
||||
proc twapi::_register_script_wm_handler {msg cmdprefix {overwrite 0}} { |
||||
variable _wm_registrations |
||||
|
||||
# Ensure notification window exists |
||||
twapi::Twapi_GetNotificationWindow |
||||
|
||||
# The incr ensures decimal format |
||||
# The lrange ensure proper list format |
||||
if {$overwrite} { |
||||
set _wm_registrations([incr msg 0]) [list [lrange $cmdprefix 0 end]] |
||||
} else { |
||||
lappend _wm_registrations([incr msg 0]) [lrange $cmdprefix 0 end] |
||||
} |
||||
} |
||||
|
||||
proc twapi::_unregister_script_wm_handler {msg cmdprefix} { |
||||
variable _wm_registrations |
||||
|
||||
# The incr ensures decimal format |
||||
incr msg 0 |
||||
# The lrange ensure proper list format |
||||
if {[info exists _wm_registrations($msg)]} { |
||||
set _wm_registrations($msg) [lsearch -exact -inline -not -all $_wm_registrations($msg) [lrange $cmdprefix 0 end]] |
||||
} |
||||
} |
||||
|
||||
# Handles notifications from the common window for script level windows |
||||
# messages (see win.c) |
||||
proc twapi::_script_wm_handler {msg wparam lparam msgpos ticks} { |
||||
variable _wm_registrations |
||||
|
||||
set code 0 |
||||
if {[info exists _wm_registrations($msg)]} { |
||||
foreach handler $_wm_registrations($msg) { |
||||
set code [catch {uplevel #0 [linsert $handler end $msg $wparam $lparam $msgpos $ticks]} msg] |
||||
switch -exact -- $code { |
||||
1 { |
||||
# TBD - should remaining handlers be called even on error ? |
||||
after 0 [list error $msg $::errorInfo $::errorCode] |
||||
break |
||||
} |
||||
3 { |
||||
break; # Ignore remaining handlers |
||||
} |
||||
default { |
||||
# Keep going |
||||
} |
||||
} |
||||
} |
||||
} else { |
||||
# TBD - debuglog - no handler for $msg |
||||
} |
||||
|
||||
return |
||||
} |
||||
@ -0,0 +1,304 @@
|
||||
# |
||||
# Copyright (c) 2012, Ashok P. Nadkarni |
||||
# All rights reserved. |
||||
# |
||||
# See the file LICENSE for license |
||||
|
||||
# Routines to unify old and new Windows event log APIs |
||||
|
||||
namespace eval twapi { |
||||
# Dictionary to map eventlog consumer handles to various related info |
||||
# The primary key is the read handle to the event channel/source. |
||||
# Nested keys depend on OS version |
||||
variable _winlog_handles |
||||
} |
||||
|
||||
proc twapi::winlog_open {args} { |
||||
variable _winlog_handles |
||||
|
||||
# TBD - document -authtype |
||||
array set opts [parseargs args { |
||||
{system.arg ""} |
||||
channel.arg |
||||
file.arg |
||||
{authtype.arg 0} |
||||
{direction.arg forward {forward backward}} |
||||
} -maxleftover 0] |
||||
|
||||
if {[info exists opts(file)] && |
||||
($opts(system) ne "" || [info exists opts(channel)])} { |
||||
error "Option '-file' cannot be used with '-channel' or '-system'" |
||||
} else { |
||||
if {![info exists opts(channel)]} { |
||||
set opts(channel) "Application" |
||||
} |
||||
} |
||||
|
||||
if {[min_os_version 6]} { |
||||
# Use new Vista APIs |
||||
if {[info exists opts(file)]} { |
||||
set hsess NULL |
||||
set hq [evt_query -file $opts(file) -ignorequeryerrors] |
||||
} else { |
||||
if {$opts(system) eq ""} { |
||||
set hsess [twapi::evt_local_session] |
||||
} else { |
||||
set hsess [evt_open_session $opts(system) -authtype $opts(authtype)] |
||||
} |
||||
# evt_query will not read new events from a channel once |
||||
# eof is reached. So if reading in forward direction, we use |
||||
# evt_subscribe. Backward it does not matter. |
||||
if {$opts(direction) eq "forward"} { |
||||
lassign [evt_subscribe $opts(channel) -session $hsess -ignorequeryerrors -includeexisting] hq signal |
||||
dict set _winlog_handles $hq signal $signal |
||||
} else { |
||||
set hq [evt_query -session $hsess -channel $opts(channel) -ignorequeryerrors -direction $opts(direction)] |
||||
} |
||||
} |
||||
|
||||
dict set _winlog_handles $hq session $hsess |
||||
} else { |
||||
if {[info exists opts(file)]} { |
||||
set hq [eventlog_open -file $opts(file)] |
||||
dict set _winlog_handles $hq channel $opts(file) |
||||
} else { |
||||
set hq [eventlog_open -system $opts(system) -source $opts(channel)] |
||||
dict set _winlog_handles $hq channel $opts(channel) |
||||
} |
||||
dict set _winlog_handles $hq direction $opts(direction) |
||||
} |
||||
return $hq |
||||
} |
||||
|
||||
proc twapi::winlog_close {hq} { |
||||
variable _winlog_handles |
||||
|
||||
if {! [dict exists $_winlog_handles $hq]} { |
||||
error "Invalid event consumer handler '$hq'" |
||||
} |
||||
|
||||
if {[dict exists $_winlog_handles $hq signal]} { |
||||
# Catch in case app has closed event directly, for |
||||
# example when returned through winlog_subscribe |
||||
catch {close_handle [dict get $_winlog_handles $hq signal]} |
||||
} |
||||
if {[min_os_version 6]} { |
||||
set hsess [dict get $_winlog_handles $hq session] |
||||
evt_close $hq |
||||
evt_close_session $hsess |
||||
} else { |
||||
eventlog_close $hq |
||||
} |
||||
|
||||
dict unset _winlog_handles $hq |
||||
return |
||||
} |
||||
|
||||
proc twapi::winlog_event_count {args} { |
||||
# TBD - document and -authtype |
||||
array set opts [parseargs args { |
||||
{system.arg ""} |
||||
channel.arg |
||||
file.arg |
||||
{authtype.arg 0} |
||||
} -maxleftover 0] |
||||
|
||||
if {[info exists opts(file)] && |
||||
($opts(system) ne "" || [info exists opts(channel)])} { |
||||
error "Option '-file' cannot be used with '-channel' or '-system'" |
||||
} else { |
||||
if {![info exists opts(channel)]} { |
||||
set opts(channel) "Application" |
||||
} |
||||
} |
||||
|
||||
if {[min_os_version 6]} { |
||||
# Use new Vista APIs |
||||
trap { |
||||
if {[info exists opts(file)]} { |
||||
set hsess NULL |
||||
set hevl [evt_open_log_info -file $opts(file)] |
||||
} else { |
||||
if {$opts(system) eq ""} { |
||||
set hsess [twapi::evt_local_session] |
||||
} else { |
||||
set hsess [evt_open_session $opts(system) -authtype $opts(authtype)] |
||||
} |
||||
set hevl [evt_open_log_info -session $hsess -channel $opts(channel)] |
||||
} |
||||
return [lindex [evt_log_info $hevl -numberoflogrecords] 1] |
||||
} finally { |
||||
if {[info exists hsess]} { |
||||
evt_close_session $hsess |
||||
} |
||||
if {[info exists hevl]} { |
||||
evt_close $hevl |
||||
} |
||||
} |
||||
} else { |
||||
if {[info exists opts(file)]} { |
||||
set hevl [eventlog_open -file $opts(file)] |
||||
} else { |
||||
set hevl [eventlog_open -system $opts(system) -source $opts(channel)] |
||||
} |
||||
|
||||
trap { |
||||
return [eventlog_count $hevl] |
||||
} finally { |
||||
eventlog_close $hevl |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {[twapi::min_os_version 6]} { |
||||
|
||||
proc twapi::winlog_read {hq args} { |
||||
parseargs args { |
||||
{lcid.int 0} |
||||
} -setvars -maxleftover 0 |
||||
|
||||
# TBD - is 10 an appropriate number of events to read? |
||||
set events [evt_next $hq -timeout 0 -count 10 -status status] |
||||
if {[llength $events]} { |
||||
trap { |
||||
set result [evt_decode_events $events -lcid $lcid -ignorestring "" -message -levelname -taskname] |
||||
} finally { |
||||
evt_close {*}$events |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
# No events were returned. Check status whether it is fatal error |
||||
# or not. SUCCESS, NO_MORE_ITEMS, TIMEOUT, INVALID_OPERATION |
||||
# are acceptable. This last happens when another EvtNext is done |
||||
# after an NO_MORE_ITEMS is already returned. |
||||
if {$status == 0 || $status == 259 || $status == 1460 || $status == 4317} { |
||||
# Even though $events is empty, still pass it in so it returns |
||||
# an empty record array in the correct format. |
||||
return [evt_decode_events $events -lcid $lcid -ignorestring "" -message -levelname -taskname] |
||||
} else { |
||||
win32_error $status |
||||
} |
||||
} |
||||
|
||||
proc twapi::winlog_subscribe {channelpath} { |
||||
variable _winlog_handles |
||||
lassign [evt_subscribe $channelpath -ignorequeryerrors] hq signal |
||||
dict set _winlog_handles $hq signal $signal |
||||
dict set _winlog_handles $hq session NULL; # local session |
||||
return [list $hq $signal] |
||||
} |
||||
|
||||
interp alias {} twapi::winlog_clear {} twapi::evt_clear_log |
||||
|
||||
proc twapi::winlog_backup {channel outpath} { |
||||
evt_export_log $outpath -channel $channel |
||||
return |
||||
} |
||||
|
||||
} else { |
||||
|
||||
proc twapi::winlog_read {hq args} { |
||||
parseargs args { |
||||
{lcid.int 0} |
||||
} -setvars -maxleftover 0 |
||||
|
||||
variable _winlog_handles |
||||
set fields {-channel -taskname -message -providername -eventid -level -levelname -eventrecordid -computer -sid -timecreated} |
||||
set values {} |
||||
set channel [dict get $_winlog_handles $hq channel] |
||||
foreach evl [eventlog_read $hq -direction [dict get $_winlog_handles $hq direction]] { |
||||
# Note order must be same as fields above |
||||
lappend values \ |
||||
[list \ |
||||
$channel \ |
||||
[eventlog_format_category $evl -langid $lcid] \ |
||||
[eventlog_format_message $evl -langid $lcid -width -1] \ |
||||
[dict get $evl -source] \ |
||||
[dict get $evl -eventid] \ |
||||
[dict get $evl -level] \ |
||||
[dict get $evl -type] \ |
||||
[dict get $evl -recordnum] \ |
||||
[dict get $evl -system] \ |
||||
[dict get $evl -sid] \ |
||||
[secs_since_1970_to_large_system_time [dict get $evl -timewritten]]] |
||||
} |
||||
return [list $fields $values] |
||||
} |
||||
|
||||
proc twapi::winlog_subscribe {source} { |
||||
variable _winlog_handles |
||||
lassign [eventlog_subscribe $source] hq hevent |
||||
dict set _winlog_handles $hq channel $source |
||||
dict set _winlog_handles $hq direction forward |
||||
dict set _winlog_handles $hq signal $hevent |
||||
return [list $hq $hevent] |
||||
} |
||||
|
||||
proc twapi::winlog_clear {source args} { |
||||
set hevl [eventlog_open -source $source] |
||||
trap { |
||||
eventlog_clear $hevl {*}$args |
||||
} finally { |
||||
eventlog_close $hevl |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc twapi::winlog_backup {source outpath} { |
||||
set hevl [eventlog_open -source $source] |
||||
trap { |
||||
eventlog_backup $hevl $outpath |
||||
} finally { |
||||
eventlog_close $hevl |
||||
} |
||||
return |
||||
} |
||||
|
||||
} |
||||
|
||||
|
||||
proc twapi::_winlog_dump_list {{channels {Application System Security}} {atomize 0}} { |
||||
set evlist {} |
||||
foreach channel $channels { |
||||
set hevl [winlog_open -channel $channel] |
||||
trap { |
||||
while {[llength [set events [winlog_read $hevl]]]} { |
||||
foreach e [recordarray getlist $events -format dict] { |
||||
if {$atomize} { |
||||
dict set ev -message [atomize [dict get $e -message]] |
||||
dict set ev -levelname [atomize [dict get $e -levelname]] |
||||
dict set ev -channel [atomize [dict get $e -channel]] |
||||
dict set ev -providername [atomize [dict get $e -providername]] |
||||
dict set ev -taskname [atomize [dict get $e -taskname]] |
||||
dict set ev -eventid [atomize [dict get $e -eventid]] |
||||
dict set ev -account [atomize [dict get $e -userid]] |
||||
} else { |
||||
dict set ev -message [dict get $e -message] |
||||
dict set ev -levelname [dict get $e -levelname] |
||||
dict set ev -channel [dict get $e -channel] |
||||
dict set ev -providername [dict get $e -providername] |
||||
dict set ev -taskname [dict get $e -taskname] |
||||
dict set ev -eventid [dict get $e -eventid] |
||||
dict set ev -account [dict get $e -userid] |
||||
} |
||||
lappend evlist $ev |
||||
} |
||||
} |
||||
} finally { |
||||
winlog_close $hevl |
||||
} |
||||
} |
||||
return $evlist |
||||
} |
||||
|
||||
proc twapi::_winlog_dump {{channel Application} {fd stdout}} { |
||||
set hevl [winlog_open -channel $channel] |
||||
while {[llength [set events [winlog_read $hevl]]]} { |
||||
# print out each record |
||||
foreach ev [recordarray getlist $events -format dict] { |
||||
puts $fd "[dict get $ev -timecreated] [dict get $ev -providername]: [dict get $ev -message]" |
||||
} |
||||
} |
||||
winlog_close $hevl |
||||
} |
||||
@ -0,0 +1,113 @@
|
||||
# |
||||
# Copyright (c) 2004-2012, Ashok P. Nadkarni |
||||
# All rights reserved. |
||||
# |
||||
# See the file LICENSE for license |
||||
|
||||
|
||||
# TBD - document and test |
||||
proc twapi::get_active_console_tssession {} { |
||||
return [WTSGetActiveConsoleSessionId] |
||||
} |
||||
|
||||
proc twapi::get_current_window_station_handle {} { |
||||
return [GetProcessWindowStation] |
||||
} |
||||
|
||||
# Get the handle to a window station |
||||
proc twapi::get_window_station_handle {winsta args} { |
||||
array set opts [parseargs args { |
||||
inherit.bool |
||||
{access.arg generic_read} |
||||
} -nulldefault] |
||||
|
||||
set access_rights [_access_rights_to_mask $opts(access)] |
||||
|
||||
return [OpenWindowStation $winsta $opts(inherit) $access_rights] |
||||
} |
||||
|
||||
|
||||
# Close a window station handle |
||||
proc twapi::close_window_station_handle {hwinsta} { |
||||
# Trying to close our window station handle will generate an error |
||||
if {$hwinsta != [get_current_window_station_handle]} { |
||||
CloseWindowStation $hwinsta |
||||
} |
||||
return |
||||
} |
||||
|
||||
# List all window stations |
||||
proc twapi::find_window_stations {} { |
||||
return [EnumWindowStations] |
||||
} |
||||
|
||||
|
||||
# Enumerate desktops in a window station |
||||
proc twapi::find_desktops {args} { |
||||
array set opts [parseargs args {winsta.arg}] |
||||
|
||||
if {[info exists opts(winsta)]} { |
||||
set hwinsta [get_window_station_handle $opts(winsta)] |
||||
} else { |
||||
set hwinsta [get_current_window_station_handle] |
||||
} |
||||
|
||||
trap { |
||||
return [EnumDesktops $hwinsta] |
||||
} finally { |
||||
# Note close_window_station_handle protects against |
||||
# hwinsta being the current window station handle so |
||||
# we do not need to do that check here |
||||
close_window_station_handle $hwinsta |
||||
} |
||||
} |
||||
|
||||
|
||||
# Get the handle to a desktop |
||||
proc twapi::get_desktop_handle {desk args} { |
||||
array set opts [parseargs args { |
||||
inherit.bool |
||||
allowhooks.bool |
||||
{access.arg generic_read} |
||||
} -nulldefault] |
||||
|
||||
set access_mask [_access_rights_to_mask $opts(access)] |
||||
|
||||
# If certain access rights are specified, we must add certain other |
||||
# access rights. See OpenDesktop SDK docs |
||||
set access_rights [_access_mask_to_rights $access_mask] |
||||
if {"read_control" in $access_rights || |
||||
"write_dacl" in $access_rights || |
||||
"write_owner" in $access_rights} { |
||||
lappend access_rights desktop_readobject desktop_writeobjects |
||||
set access_mask [_access_rights_to_mask $opts(access)] |
||||
} |
||||
|
||||
return [OpenDesktop $desk $opts(allowhooks) $opts(inherit) $access_mask] |
||||
} |
||||
|
||||
# Close the desktop handle |
||||
proc twapi::close_desktop_handle {hdesk} { |
||||
CloseDesktop $hdesk |
||||
} |
||||
|
||||
# Set the process window station |
||||
proc twapi::set_process_window_station {hwinsta} { |
||||
SetProcessWindowStation $hwinsta |
||||
} |
||||
|
||||
proc twapi::get_desktop_user_sid {hdesk} { |
||||
return [GetUserObjectInformation $hdesk 4] |
||||
} |
||||
|
||||
proc twapi::get_window_station_user_sid {hwinsta} { |
||||
return [GetUserObjectInformation $hwinsta 4] |
||||
} |
||||
|
||||
proc twapi::get_desktop_name {hdesk} { |
||||
return [GetUserObjectInformation $hdesk 2] |
||||
} |
||||
|
||||
proc twapi::get_window_station_name {hwinsta} { |
||||
return [GetUserObjectInformation $hwinsta 2] |
||||
} |
||||
@ -0,0 +1,223 @@
|
||||
# |
||||
# Copyright (c) 2012 Ashok P. Nadkarni |
||||
# All rights reserved. |
||||
# |
||||
# See the file LICENSE for license |
||||
|
||||
package require twapi_com |
||||
|
||||
# TBD - document? |
||||
|
||||
twapi::class create ::twapi::IMofCompilerProxy { |
||||
superclass ::twapi::IUnknownProxy |
||||
|
||||
constructor {args} { |
||||
if {[llength $args] == 0} { |
||||
set args [list [::twapi::com_create_instance "{6daf9757-2e37-11d2-aec9-00c04fb68820}" -interface IMofCompiler -raw]] |
||||
} |
||||
next {*}$args |
||||
} |
||||
|
||||
method CompileBuffer args { |
||||
my variable _ifc |
||||
return [::twapi::IMofCompiler_CompileBuffer $_ifc {*}$args] |
||||
} |
||||
|
||||
method CompileFile args { |
||||
my variable _ifc |
||||
return [::twapi::IMofCompiler_CompileFile $_ifc {*}$args] |
||||
} |
||||
|
||||
method CreateBMOF args { |
||||
my variable _ifc |
||||
return [::twapi::IMofCompiler_CreateBMOF $_ifc {*}$args] |
||||
} |
||||
|
||||
twapi_exportall |
||||
} |
||||
|
||||
|
||||
# |
||||
# Get WMI service - TBD document |
||||
proc twapi::wmi_root {args} { |
||||
array set opts [parseargs args { |
||||
{root.arg cimv2} |
||||
{impersonationlevel.arg impersonate {default anonymous identify delegate impersonate} } |
||||
} -maxleftover 0] |
||||
|
||||
# TBD - any injection attacks possible ? Need to quote ? |
||||
return [comobj_object "winmgmts:{impersonationLevel=$opts(impersonationlevel)}!//./root/$opts(root)"] |
||||
} |
||||
# Backwards compat |
||||
proc twapi::_wmi {{top cimv2}} { |
||||
return [wmi_root -root $top] |
||||
} |
||||
|
||||
# TBD - see if using ExecQuery would be faster if it supports all the options |
||||
proc twapi::wmi_collect_classes {swbemservices args} { |
||||
array set opts [parseargs args { |
||||
{ancestor.arg {}} |
||||
shallow |
||||
first |
||||
matchproperties.arg |
||||
matchsystemproperties.arg |
||||
matchqualifiers.arg |
||||
{collector.arg {lindex}} |
||||
} -maxleftover 0] |
||||
|
||||
|
||||
# Create a forward only enumerator for efficiency |
||||
# wbemFlagUseAmendedQualifiers | wbemFlagReturnImmediately | wbemFlagForwardOnly |
||||
set flags 0x20030 |
||||
if {$opts(shallow)} { |
||||
incr flags 1; # 0x1 -> wbemQueryFlagShallow |
||||
} |
||||
|
||||
set classes [$swbemservices SubclassesOf $opts(ancestor) $flags] |
||||
set matches {} |
||||
set delete_on_error {} |
||||
twapi::trap { |
||||
$classes -iterate class { |
||||
set matched 1 |
||||
foreach {opt fn} { |
||||
matchproperties Properties_ |
||||
matchsystemproperties SystemProperties_ |
||||
matchqualifiers Qualifiers_ |
||||
} { |
||||
if {[info exists opts($opt)]} { |
||||
foreach {name matcher} $opts($opt) { |
||||
if {[catch { |
||||
if {! [{*}$matcher [$class -with [list [list -get $fn] [list Item $name]] Value]]} { |
||||
set matched 0 |
||||
break; # Value does not match |
||||
} |
||||
} msg ]} { |
||||
# TBD - log debug error if not property found |
||||
# No such property or no access |
||||
set matched 0 |
||||
break |
||||
} |
||||
} |
||||
} |
||||
if {! $matched} { |
||||
# Already failed to match, no point continuing looping |
||||
break |
||||
} |
||||
} |
||||
|
||||
if {$matched} { |
||||
# Note collector code is responsible for disposing |
||||
# of $class as appropriate. But we take care of deleting |
||||
# when an error occurs after some accumulation has |
||||
# already occurred. |
||||
lappend delete_on_error $class |
||||
if {$opts(first)} { |
||||
return [{*}$opts(collector) $class] |
||||
} else { |
||||
lappend matches [{*}$opts(collector) $class] |
||||
} |
||||
} else { |
||||
$class destroy |
||||
} |
||||
} |
||||
} onerror {} { |
||||
foreach class $delete_on_error { |
||||
if {[comobj? $class]} { |
||||
$class destroy |
||||
} |
||||
} |
||||
rethrow |
||||
} finally { |
||||
$classes destroy |
||||
} |
||||
|
||||
return $matches |
||||
} |
||||
|
||||
proc twapi::wmi_extract_qualifier {qual} { |
||||
foreach prop {name value isamended propagatestoinstance propagatestosubclass isoverridable} { |
||||
dict set result $prop [$qual -get $prop] |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
proc twapi::wmi_extract_property {propobj} { |
||||
foreach prop {name value cimtype isarray islocal origin} { |
||||
dict set result $prop [$propobj -get $prop] |
||||
} |
||||
|
||||
$propobj -with Qualifiers_ -iterate -cleanup qual { |
||||
set rec [wmi_extract_qualifier $qual] |
||||
dict set result qualifiers [string tolower [dict get $rec name]] $rec |
||||
} |
||||
|
||||
return $result |
||||
} |
||||
|
||||
proc twapi::wmi_extract_systemproperty {propobj} { |
||||
# Separate from wmi_extract_property because system properties do not |
||||
# have Qualifiers_ |
||||
foreach prop {name value cimtype isarray islocal origin} { |
||||
dict set result $prop [$propobj -get $prop] |
||||
} |
||||
|
||||
return $result |
||||
} |
||||
|
||||
|
||||
proc twapi::wmi_extract_method {mobj} { |
||||
foreach prop {name origin} { |
||||
dict set result $prop [$mobj -get $prop] |
||||
} |
||||
|
||||
# The InParameters and OutParameters properties are SWBEMObjects |
||||
# the properties of which describe the parameters. |
||||
foreach inout {inparameters outparameters} { |
||||
set paramsobj [$mobj -get $inout] |
||||
if {[$paramsobj -isnull]} { |
||||
dict set result $inout {} |
||||
} else { |
||||
$paramsobj -with Properties_ -iterate -cleanup pobj { |
||||
set rec [wmi_extract_property $pobj] |
||||
dict set result $inout [string tolower [dict get $rec name]] $rec |
||||
} |
||||
} |
||||
} |
||||
|
||||
$mobj -with Qualifiers_ -iterate qual { |
||||
set rec [wmi_extract_qualifier $qual] |
||||
dict set result qualifiers [string tolower [dict get $rec name]] $rec |
||||
$qual destroy |
||||
} |
||||
|
||||
return $result |
||||
} |
||||
|
||||
|
||||
proc twapi::wmi_extract_class {obj} { |
||||
|
||||
set result [dict create] |
||||
|
||||
# Class qualifiers |
||||
$obj -with Qualifiers_ -iterate -cleanup qualobj { |
||||
set rec [wmi_extract_qualifier $qualobj] |
||||
dict set result qualifiers [string tolower [dict get $rec name]] $rec |
||||
} |
||||
|
||||
$obj -with Properties_ -iterate -cleanup propobj { |
||||
set rec [wmi_extract_property $propobj] |
||||
dict set result properties [string tolower [dict get $rec name]] $rec |
||||
} |
||||
|
||||
$obj -with SystemProperties_ -iterate -cleanup propobj { |
||||
set rec [wmi_extract_systemproperty $propobj] |
||||
dict set result systemproperties [string tolower [dict get $rec name]] $rec |
||||
} |
||||
|
||||
$obj -with Methods_ -iterate -cleanup mobj { |
||||
set rec [wmi_extract_method $mobj] |
||||
dict set result methods [string tolower [dict get $rec name]] $rec |
||||
} |
||||
|
||||
return $result |
||||
} |
||||
@ -0,0 +1,9 @@
|
||||
|
||||
package require starkit |
||||
starkit::startup |
||||
if {[llength $::argv]} { |
||||
package require app-shellspy |
||||
} else { |
||||
package require app-punk |
||||
} |
||||
|
||||
Binary file not shown.
@ -0,0 +1,127 @@
|
||||
proc tclInit {} { |
||||
rename tclInit {} |
||||
|
||||
global auto_path tcl_library tcl_libPath tcl_version tclkit_system_encoding |
||||
|
||||
# find the file to mount. |
||||
set noe $::tcl::kitpath |
||||
# resolve symlinks |
||||
set noe [file dirname [file normalize [file join $noe __dummy__]]] |
||||
set tcl_library [file join $noe lib tcl$tcl_version] |
||||
set tcl_libPath [list $tcl_library [file join $noe lib]] |
||||
|
||||
# get rid of a build residue |
||||
unset -nocomplain ::tclDefaultLibrary |
||||
|
||||
# The following code only gets executed if we don't have our exe |
||||
# already mounted. This should only happen once per thread. |
||||
# We could use [vfs::filesystem info], but that would require |
||||
# loading vfs into every interp. |
||||
if {![file isdirectory $noe]} { |
||||
load {} vfs |
||||
|
||||
# lookup and emulate "source" of lib/vfs1*/{vfs*.tcl,mk4vfs.tcl} |
||||
if {[llength [info command mk::file]]} { |
||||
set driver mk4 |
||||
|
||||
# must use raw Metakit calls because VFS is not yet in place |
||||
set d [mk::select exe.dirs parent 0 name lib] |
||||
set d [mk::select exe.dirs parent $d -glob name vfs1*] |
||||
|
||||
foreach x {vfsUtils vfslib mk4vfs} { |
||||
set n [mk::select exe.dirs!$d.files name $x.tcl] |
||||
if {[llength $n] != 1} { error "$x: cannot find startup script"} |
||||
|
||||
set s [mk::get exe.dirs!$d.files!$n contents] |
||||
catch {set s [zlib decompress $s]} |
||||
uplevel #0 $s |
||||
} |
||||
|
||||
# use on-the-fly decompression, if mk4vfs understands that |
||||
# Note: 8.6 core zlib does not support this for mk4vfs |
||||
if {![package vsatisfies [package require Tcl] 8.6]} { |
||||
set mk4vfs::zstreamed 1 |
||||
} |
||||
} else { |
||||
set driver mkcl |
||||
|
||||
# use raw Vlerq calls if Mk4tcl is not available |
||||
# $::vlerq::starkit_root is set in the init script in kitInit.c |
||||
set rootv [vlerq get $::vlerq::starkit_root 0 dirs] |
||||
set dname [vlerq get $rootv * name] |
||||
set prows [vlerq get $rootv * parent] |
||||
foreach r [lsearch -int -all $prows 0] { |
||||
if {[lindex $dname $r] eq "lib"} break |
||||
} |
||||
|
||||
# glob for a subdir in "lib", then source the specified file inside it |
||||
foreach {d f} { |
||||
vfs1* vfsUtils.tcl vfs1* vfslib.tcl vqtcl4* mkclvfs.tcl |
||||
} { |
||||
foreach z [lsearch -int -all $prows $r] { |
||||
if {[string match $d [lindex $dname $z]]} break |
||||
} |
||||
|
||||
set files [vlerq get $rootv $z files] |
||||
set names [vlerq get $files * name] |
||||
|
||||
set n [lsearch $names $f] |
||||
if {$n < 0} { error "$d/$f: cannot find startup script"} |
||||
|
||||
set s [vlerq get $files $n contents] |
||||
catch {set s [zlib decompress $s]} |
||||
uplevel #0 $s |
||||
} |
||||
|
||||
# hack the mkcl info so it will know this mount point as "exe" |
||||
set vfs::mkcl::v::rootv(exe) $rootv |
||||
set vfs::mkcl::v::dname(exe) $dname |
||||
set vfs::mkcl::v::prows(exe) $prows |
||||
} |
||||
|
||||
# mount the executable, i.e. make all runtime files available |
||||
vfs::filesystem mount $noe [list ::vfs::${driver}::handler exe] |
||||
|
||||
# alter path to find encodings |
||||
if {[info tclversion] eq "8.4"} { |
||||
load {} pwb |
||||
librarypath [info library] |
||||
} else { |
||||
encoding dirs [list [file join [info library] encoding]] ;# TIP 258 |
||||
} |
||||
# if the C code passed us a system encoding, apply it here. |
||||
if {[info exists tclkit_system_encoding]} { |
||||
# It is possible the chosen encoding is unavailable in which case |
||||
# we will be left with 'identity' to be handled below. |
||||
catch {encoding system $tclkit_system_encoding} |
||||
unset tclkit_system_encoding |
||||
} |
||||
# fix system encoding, if it wasn't properly set up (200207.004 bug) |
||||
if {[encoding system] eq "identity"} { |
||||
switch $::tcl_platform(platform) { |
||||
windows { encoding system cp1252 } |
||||
macintosh { encoding system macRoman } |
||||
default { encoding system iso8859-1 } |
||||
} |
||||
} |
||||
|
||||
# now remount the executable with the correct encoding |
||||
vfs::filesystem unmount $noe |
||||
set noe $::tcl::kitpath |
||||
# resolve symlinks |
||||
set noe [file dirname [file normalize [file join $noe __dummy__]]] |
||||
|
||||
set tcl_library [file join $noe lib tcl$tcl_version] |
||||
set tcl_libPath [list $tcl_library [file join $noe lib]] |
||||
vfs::filesystem mount $noe [list ::vfs::${driver}::handler exe] |
||||
} |
||||
|
||||
# load config settings file if present |
||||
namespace eval ::vfs { variable tclkit_version 1 } |
||||
catch { uplevel #0 [list source [file join $noe config.tcl]] } |
||||
|
||||
uplevel #0 [list source [file join $tcl_library init.tcl]] |
||||
|
||||
# reset auto_path, so that init.tcl's search outside of tclkit is cancelled |
||||
set auto_path $tcl_libPath |
||||
} |
||||
Binary file not shown.
@ -0,0 +1,333 @@
|
||||
# |
||||
# Ffidl interface to Tcl8.2 |
||||
# |
||||
# Run time support for Ffidl. |
||||
# |
||||
# NOTE: Remember to update FFIDLRT_VERSION in configure.ac when changing this |
||||
# version number. |
||||
package provide Ffidlrt 0.4 |
||||
package require Ffidl |
||||
|
||||
namespace eval ::ffidl:: {} |
||||
|
||||
proc ::ffidl::find-pkg-lib {pkg} { |
||||
package require $pkg |
||||
foreach i [::info loaded {}] { |
||||
foreach {l p} $i {} |
||||
if {$p eq "$pkg"} { |
||||
return $l |
||||
} |
||||
} |
||||
# ignore errors when running under pkg_mkIndex: |
||||
if {![llength [info commands __package_orig]] } { |
||||
return -code error "Library for package $pkg not found" |
||||
} |
||||
} |
||||
|
||||
namespace eval ::ffidl:: { |
||||
set ffidl_lib [find-pkg-lib Ffidl] |
||||
array set libs [list ffidl [list $ffidl_lib] ffidl_test [list $ffidl_lib]] |
||||
unset ffidl_lib |
||||
|
||||
# 'libs' array is used by the ::ffidl::find-lib |
||||
# abstraction to store the resolved lib paths |
||||
# |
||||
# 'types' and 'typedefs' arrays are used by the ::ffidl::find-type |
||||
# abstraction to store resolved system types |
||||
# and whether they have already been defined |
||||
# with ::ffidl::typedef |
||||
array set typedefs {} |
||||
switch -exact $tcl_platform(platform) { |
||||
unix { |
||||
switch -glob $tcl_platform(os) { |
||||
Darwin { |
||||
array set libs { |
||||
c System.framework/System |
||||
m System.framework/System |
||||
gdbm {} |
||||
gmp {} |
||||
mathswig libmathswig0.5.dylib |
||||
} |
||||
array set types { |
||||
size_t {{unsigned long}} |
||||
clock_t {{unsigned long}} |
||||
time_t long |
||||
timeval {uint32 uint32} |
||||
} |
||||
} |
||||
Linux { |
||||
if {$tcl_platform(wordSize) == 8} { |
||||
if {$tcl_platform(machine) eq "alpha"} { |
||||
array set libs { |
||||
c /lib/libc.so.6.1 |
||||
m /lib/libm.so.6.1 |
||||
gdbm /usr/lib/libgdbm.so |
||||
gmp {/usr/local/lib/libgmp.so /usr/lib/libgmp.so.2} |
||||
mathswig libmathswig0.5.so |
||||
} |
||||
array set types { |
||||
size_t long |
||||
clock_t long |
||||
time_t long |
||||
timeval {time_t time_t} |
||||
} |
||||
} else { |
||||
array set libs { |
||||
c { |
||||
/lib64/libc.so.6 |
||||
/lib/x86_64-linux-gnu/libc.so.6 |
||||
} |
||||
m { |
||||
/lib64/libm.so.6 |
||||
/lib/x86_64-linux-gnu/libm.so.6 |
||||
} |
||||
gdbm { |
||||
/usr/lib64/libgdbm.so |
||||
/usr/lib/x86_64-linux-gnu/libgdbm.so |
||||
} |
||||
gmp { |
||||
/usr/lib/x86_64-linux-gnu/libgmp.so |
||||
/usr/local/lib64/libgmp.so |
||||
/usr/lib64/libgmp.so.2 |
||||
} |
||||
mathswig libmathswig0.5.so |
||||
} |
||||
array set types { |
||||
size_t long |
||||
clock_t long |
||||
time_t long |
||||
timeval {time_t time_t} |
||||
} |
||||
} |
||||
} else { |
||||
array set libs { |
||||
c { |
||||
/lib/libc.so.6 |
||||
/lib/i386-linux-gnu/libc.so.6 |
||||
} |
||||
m { |
||||
/lib/libm.so.6 |
||||
/lib/i386-linux-gnu/libm.so.6 |
||||
} |
||||
gdbm { |
||||
/usr/lib/libgdbm.so |
||||
/usr/lib/i386-linux-gnu/libgdbm.so.3 |
||||
} |
||||
gmp { |
||||
/usr/lib/i386-linux-gnu/libgmp.so.2 |
||||
/usr/local/lib/libgmp.so |
||||
/usr/lib/libgmp.so.2 |
||||
} |
||||
mathswig libmathswig0.5.so |
||||
} |
||||
array set types { |
||||
size_t int |
||||
clock_t long |
||||
time_t long |
||||
timeval {time_t time_t} |
||||
} |
||||
} |
||||
} |
||||
*BSD { |
||||
array set libs { |
||||
c {/usr/lib/libc.so /usr/lib/libc.so.30.1} |
||||
m {/usr/lib/libm.so /usr/lib/libm.so.1.0} |
||||
gdbm libgdbm.so |
||||
gmp libgmp.so |
||||
mathswig libmathswig0.5.so |
||||
} |
||||
array set types { |
||||
size_t int |
||||
clock_t long |
||||
time_t long |
||||
timeval {time_t time_t} |
||||
} |
||||
} |
||||
default { |
||||
array set libs { |
||||
c /lib/libc.so |
||||
m /lib/libm.so |
||||
gdbm libgdbm.so |
||||
gmp libgmp.so |
||||
mathswig libmathswig0.5.so |
||||
} |
||||
array set types { |
||||
size_t int |
||||
clock_t long |
||||
time_t long |
||||
timeval {time_t time_t} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
windows { |
||||
# |
||||
# found libraries |
||||
# this array is used by the ::ffidl::find-lib |
||||
# abstraction to store the resolved lib paths |
||||
# |
||||
# CHANGE - put your resolved lib paths here |
||||
# |
||||
array set libs { |
||||
c msvcrt.dll |
||||
m msvcrt.dll |
||||
gdbm {} |
||||
gmp gmp202.dll |
||||
mathswig mathswig05.dll |
||||
} |
||||
# |
||||
# found types |
||||
# these arrays are used by the ::ffidl::find-type |
||||
# abstraction to store resolved system types |
||||
# and whether they have already been defined |
||||
# with ::ffidl::typedef |
||||
# |
||||
# CHANGE - put your resolved system types here |
||||
# |
||||
array set types { |
||||
size_t int |
||||
clock_t long |
||||
time_t long |
||||
timeval {time_t time_t} |
||||
} |
||||
array set typedefs { |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
# |
||||
# find a shared library given a root name |
||||
# this is an abstraction in search of a |
||||
# solution. |
||||
# |
||||
# currently wired for my linux box |
||||
# |
||||
proc ::ffidl::find-lib {root} { |
||||
upvar \#0 ::ffidl::libs libs |
||||
if { ! [::info exists libs($root)] || [llength libs($root)] == 0} { |
||||
error "::ffidl::find-lib $root - no mapping defined for $root" |
||||
} |
||||
if {[llength $libs($root)] > 1} { |
||||
foreach l $libs($root) { |
||||
if {[file exists $l]} { |
||||
set libs($root) $l |
||||
break |
||||
} |
||||
} |
||||
} |
||||
lindex $libs($root) 0 |
||||
} |
||||
|
||||
# |
||||
# find a typedef for a standard type |
||||
# and define it with ::ffidl::typedef |
||||
# if not already done |
||||
# |
||||
# currently wired for my linux box |
||||
# |
||||
proc ::ffidl::find-type {type} { |
||||
upvar \#0 ::ffidl::types types |
||||
upvar \#0 ::ffidl::typedefs typedefs |
||||
if { ! [::info exists types($type)]} { |
||||
error "::ffidl::find-type $type - no mapping defined for $type" |
||||
} |
||||
if { ! [::info exists typedefs($type)]} { |
||||
eval ::ffidl::typedef $type $types($type) |
||||
set typedefs($type) 1 |
||||
} |
||||
} |
||||
|
||||
# |
||||
# get the address of the string rep of a Tcl_Obj |
||||
# get the address of the unicode rep of a Tcl_Obj |
||||
# get the address of the bytearray rep of a Tcl_Obj |
||||
# |
||||
# CAUTION - anything which alters the Tcl_Obj may |
||||
# invalidate the results of this function. Use |
||||
# only in circumstances where the Tcl_Obj will not |
||||
# be modified in any way. |
||||
# |
||||
# CAUTION - the memory pointed to by the addresses |
||||
# returned by ::ffidl::get-string and ::ffidl::get-unicode |
||||
# is managed by Tcl, the contents should never be |
||||
# modified. |
||||
# |
||||
# The memory pointed to by ::ffidl::get-bytearray may |
||||
# be modified if care is taken to respect its size, |
||||
# and if shared references to the bytearray object |
||||
# are known to be compatible with the modification. |
||||
# |
||||
|
||||
::ffidl::callout ::ffidl::get-string {pointer-obj} pointer [::ffidl::stubsymbol tcl stubs 340]; #Tcl_GetString |
||||
::ffidl::callout ::ffidl::get-unicode {pointer-obj} pointer [::ffidl::stubsymbol tcl stubs 382]; #Tcl_GetUnicode |
||||
::ffidl::callout ::ffidl::get-bytearray-from-obj {pointer-obj pointer-var} pointer [::ffidl::stubsymbol tcl stubs 33]; #Tcl_GetByteArrayFromObj |
||||
|
||||
proc ::ffidl::get-bytearray {obj} { |
||||
set len [binary format [::ffidl::info format int] 0] |
||||
::ffidl::get-bytearray-from-obj $obj len |
||||
} |
||||
|
||||
# |
||||
# create a new string Tcl_Obj |
||||
# create a new unicode Tcl_Obj |
||||
# create a new bytearray Tcl_Obj |
||||
# |
||||
# I'm not sure if these are actually useful |
||||
# |
||||
|
||||
::ffidl::callout ::ffidl::new-string {pointer int} pointer-obj [::ffidl::stubsymbol tcl stubs 56]; #Tcl_NewStringObj |
||||
::ffidl::callout ::ffidl::new-unicode {pointer int} pointer-obj [::ffidl::stubsymbol tcl stubs 378]; #Tcl_NewUnicodeObj |
||||
::ffidl::callout ::ffidl::new-bytearray {pointer int} pointer-obj [::ffidl::stubsymbol tcl stubs 50]; #Tcl_NewByteArrayObj |
||||
|
||||
::ffidl::find-type size_t |
||||
if {1} { |
||||
# Tcl's allocator: malloc, free, realloc. |
||||
::ffidl::callout ::ffidl::malloc {unsigned} pointer [::ffidl::stubsymbol tcl stubs 3]; #Tcl_Alloc |
||||
::ffidl::callout ::ffidl::realloc {pointer unsigned} pointer [::ffidl::stubsymbol tcl stubs 5]; #Tcl_Realloc |
||||
::ffidl::callout ::ffidl::free {pointer} void [::ffidl::stubsymbol tcl stubs 4]; #Tcl_Free |
||||
} else { |
||||
# access the standard allocator: malloc, free, realloc. |
||||
::ffidl::callout ::ffidl::malloc {size_t} pointer [::ffidl::symbol [::ffidl::find-lib c] malloc] |
||||
::ffidl::callout ::ffidl::realloc {pointer size_t} pointer [::ffidl::symbol [::ffidl::find-lib c] realloc] |
||||
::ffidl::callout ::ffidl::free {pointer} void [::ffidl::symbol [::ffidl::find-lib c] free] |
||||
} |
||||
|
||||
# |
||||
# Copy some memory at some location into a Tcl bytearray. |
||||
# |
||||
# Needless to say, this can be very hazardous to your |
||||
# program's health if things aren't sized correctly. |
||||
# |
||||
::ffidl::callout ::ffidl::memcpy {pointer-var pointer size_t} pointer [::ffidl::symbol [::ffidl::find-lib ffidl] ffidl_copy_bytes]; |
||||
|
||||
# |
||||
# Regular memcpy working on pointers. ::ffidl::memcpy kept as is for compatibilitiy. |
||||
# |
||||
::ffidl::callout ::ffidl::memcpy2 {pointer pointer size_t} pointer [::ffidl::symbol [::ffidl::find-lib ffidl] ffidl_copy_bytes]; |
||||
|
||||
# |
||||
# Create a Tcl bytearray with a copy of the contents some memory location. |
||||
# |
||||
proc ::ffidl::peek {address nbytes} { |
||||
set dst [binary format x$nbytes] |
||||
::ffidl::memcpy dst $address $nbytes |
||||
set dst |
||||
} |
||||
|
||||
# |
||||
# Copy the contents of a Tcl bytearray to some memory location. |
||||
# |
||||
proc ::ffidl::poke {dst src} { |
||||
set n [string length $bytes]; |
||||
set src [::ffidl::get-bytearray $bytes]; |
||||
::ffidl::memcpy2 $dst $src $n; |
||||
} |
||||
|
||||
# |
||||
# convert raw pointers, as integers, into Tcl_Obj's |
||||
# |
||||
::ffidl::callout ::ffidl::pointer-into-string {pointer} pointer-utf8 [::ffidl::symbol [::ffidl::find-lib ffidl] ffidl_pointer_pun] |
||||
::ffidl::callout ::ffidl::pointer-into-unicode {pointer} pointer-utf16 [::ffidl::symbol [::ffidl::find-lib ffidl] ffidl_pointer_pun] |
||||
# ::ffidl::pointer-into-bytearray is deprecated. Use ::ffidl::peek instead. |
||||
interp alias {} ::ffidl::pointer-into-bytearray {} ::ffidl::peek; |
||||
@ -0,0 +1,12 @@
|
||||
# Tcl package index file, version 1.1 |
||||
# This file is generated by the "pkg_mkIndex" command |
||||
# and sourced either when an application starts up or |
||||
# by a "package unknown" script. It invokes the |
||||
# "package ifneeded" command to set up package-related |
||||
# information so that packages will be loaded automatically |
||||
# in response to "package require" commands. When this |
||||
# script is sourced, the variable $dir must contain the |
||||
# full path name of this file's directory. |
||||
|
||||
package ifneeded Ffidl 0.9.0 [list load [file join $dir Ffidl090.dll]] |
||||
package ifneeded Ffidlrt 0.4 [list source [file join $dir ffidlrt.tcl]] |
||||
Binary file not shown.
Binary file not shown.
@ -0,0 +1,2 @@
|
||||
package ifneeded Memchan 2.3 \ |
||||
[list load [file join $dir Memchan23.dll]] |
||||
Binary file not shown.
Binary file not shown.
@ -0,0 +1,2 @@
|
||||
package ifneeded Trf 2.1.4 \ |
||||
[list load [file join $dir Trf214.dll]] |
||||
@ -0,0 +1,29 @@
|
||||
# |
||||
# Tcl package index file - generated from pkgIndex.tcl.in |
||||
# |
||||
|
||||
package ifneeded cffi 1.2.0 \ |
||||
[list apply [list {dir} { |
||||
set dllname "tclcffi120.dll" |
||||
set package "cffi" |
||||
set package_ns ::$package |
||||
|
||||
# First try to load from current directory. If that fails, try from |
||||
# arch-specific subdirectories |
||||
set path [file join $dir $dllname] |
||||
if {[catch {uplevel #0 [list load $path $package]}]} { |
||||
package require platform |
||||
foreach platform [platform::patterns [platform::identify]] { |
||||
if {$platform eq "tcl"} continue |
||||
set path [file join $dir $platform $dllname] |
||||
if {![catch {uplevel #0 [list load $path $package]}]} { |
||||
break |
||||
} |
||||
} |
||||
} |
||||
if {[namespace exists $package_ns]} { |
||||
# Load was successful |
||||
set ${package_ns}::dll_path $path |
||||
set ${package_ns}::package_dir $dir |
||||
} |
||||
}] $dir] |
||||
Binary file not shown.
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,2 @@
|
||||
if {![package vsatisfies [package provide Tcl] 8.6]} {return} |
||||
package ifneeded critcl::app 3.2 [list source [file join $dir critcl.tcl]] |
||||
@ -0,0 +1,134 @@
|
||||
# |
||||
# 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 {[info exists ~]} { |
||||
set dir ~ |
||||
} 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 |
||||
} |
||||
@ -0,0 +1,188 @@
|
||||
## -*- tcl -*- Critcl configuration file |
||||
# # ## ### ##### ######## ############# ##################### |
||||
## For |
||||
# @@PNAME@@ @@PMAJORV@@.@@PMINORV@@ |
||||
# |
||||
# Copyright (c) @@YEAR@@ @@PORG@@ |
||||
# |
||||
# Generated by @@CRITCL@@ |
||||
# At @@NOW@@ |
||||
|
||||
# This specific file gets filled by the TEA configure(.in) with the |
||||
# compiler information it found when run, and the accompanying |
||||
# Makefile(.in) uses it to overide critcl's default configuration |
||||
# settings. In this way we manage to get a proper TEA setup of flags |
||||
# and such, bypassing all of critcl's own selection logic. critcl is |
||||
# essentially 'just' used as a custom compiler driver, whereas a |
||||
# standard TEA Makefile would have all the relevant commands listed |
||||
# explicitly in its rules. |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## First, keep the GCC specific defaults. |
||||
|
||||
compile gcc -c -fPIC |
||||
version gcc -v |
||||
link gcc -shared |
||||
include -I |
||||
preproc_define gcc -E -dM |
||||
preproc_enum gcc -E |
||||
tclstubs -DUSE_TCL_STUBS |
||||
tkstubs -DUSE_TK_STUBS |
||||
debug_memory -DTCL_MEM_DEBUG |
||||
debug_symbols -g |
||||
object .o |
||||
output -o [list $outfile] |
||||
ldoutput |
||||
link_debug |
||||
link_release |
||||
link_preload --unresolved-symbols=ignore-in-shared-libs |
||||
strip -Wl,-s |
||||
optimize -O2 |
||||
noassert -DNDEBUG |
||||
threadflags -DUSE_THREAD_ALLOC=1 -D_REENTRANT=1 -D_THREAD_SAFE=1 \ |
||||
-DHAVE_PTHREAD_ATTR_SETSTACKSIZE=1 -DHAVE_READDIR_R=1 \ |
||||
-DTCL_THREADS=1 |
||||
|
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Second, define settings based on the system information found by |
||||
## configure(.in), converted into something usable by critcl. See the |
||||
## section below for the raw settings. |
||||
|
||||
TEA platform @CRITCL_PLATFORM@ |
||||
TEA compile @CRITCL_CC@ |
||||
TEA version @CRITCL_VERSION@ |
||||
TEA link @CRITCL_LINK@ |
||||
TEA preproc_define @CRITCL_CPP_DEFINE@ |
||||
TEA preproc_enum @CRITCL_CPP_ENUM@ |
||||
TEA debug_symbols @CFLAGS_DEBUG@ |
||||
TEA object .@OBJEXT@ |
||||
TEA output @CRITCL_CC_OUTPUT@ |
||||
TEA ldoutput @CRITCL_LD_OUTPUT@ |
||||
TEA link_debug @CRITCL_LD_DBG@ |
||||
TEA link_release @CRITCL_LD_REL@ |
||||
TEA link_preload --unresolved-symbols=ignore-in-shared-libs |
||||
TEA strip |
||||
TEA optimize @CFLAGS_OPTIMIZE@ |
||||
|
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Third, the exact raw settings generated by configure(.in), |
||||
## as found in build_dir/config.status. To help debugging the |
||||
## munging, when its wrong. |
||||
## |
||||
## The lines marked with ** are those which are of especially high |
||||
## interest. |
||||
|
||||
#** CC = (@CC@) |
||||
#** CFLAGS = (@CFLAGS@) |
||||
#** CFLAGS_DEBUG = (@CFLAGS_DEBUG@) |
||||
#** CFLAGS_OPTIMIZE = (@CFLAGS_OPTIMIZE@) |
||||
#** CFLAGS_WARNING = (@CFLAGS_WARNING@) |
||||
#** CPP = (@CPP@) |
||||
#** CPPFLAGS = (@CPPFLAGS@) |
||||
#** DEFS = (@DEFS@) |
||||
#** LDFLAGS = (@LDFLAGS@) |
||||
#** LDFLAGS_DEFAULT = (@LDFLAGS_DEFAULT@) |
||||
#** LIBS = (@LIBS@) |
||||
#** MAKE_LIB = (@MAKE_LIB@) |
||||
#** MAKE_SHARED_LIB = (@MAKE_SHARED_LIB@) |
||||
#** MAKE_STATIC_LIB = (@MAKE_STATIC_LIB@) |
||||
#** MAKE_STUB_LIB = (@MAKE_STUB_LIB@) |
||||
#** MATH_LIBS = (@MATH_LIBS@) |
||||
#** OBJEXT = (@OBJEXT@) |
||||
#** SHLIB_CFLAGS = (@SHLIB_CFLAGS@) |
||||
#** SHLIB_LD = (@SHLIB_LD@) |
||||
#** SHLIB_LD_LIBS = (@SHLIB_LD_LIBS@) |
||||
#** SHLIB_SUFFIX = (@SHLIB_SUFFIX@) |
||||
#** STLIB_LD = (@STLIB_LD@) |
||||
#** TCL_EXTRA_CFLAGS = (@TCL_EXTRA_CFLAGS@) |
||||
#** TCL_INCLUDES = (@TCL_INCLUDES@) |
||||
#** TCL_LD_FLAGS = (@TCL_LD_FLAGS@) |
||||
#** TCL_LIBS = (@TCL_LIBS@) |
||||
#** TCL_SHLIB_LD_LIBS = (@TCL_SHLIB_LD_LIBS@) |
||||
#** TCL_THREADS = (@TCL_THREADS@) |
||||
|
||||
# AR = (@AR@) |
||||
# CELIB_DIR = (@CELIB_DIR@) |
||||
# CFLAGS_DEFAULT = (@CFLAGS_DEFAULT@) |
||||
# CLEANFILES = (@CLEANFILES@) |
||||
# CYGPATH = (@CYGPATH@) |
||||
# ECHO_C = (@ECHO_C@) |
||||
# ECHO_N = (@ECHO_N@) |
||||
# ECHO_T = (@ECHO_T@) |
||||
# EGREP = (@EGREP@) |
||||
# EXEEXT = (@EXEEXT@) |
||||
# GREP = (@GREP@) |
||||
# INSTALL_DATA = (@INSTALL_DATA@) |
||||
# INSTALL_PROGRAM = (@INSTALL_PROGRAM@) |
||||
# INSTALL_SCRIPT = (@INSTALL_SCRIPT@) |
||||
# LD_LIBRARY_PATH_VAR = (@LD_LIBRARY_PATH_VAR@) |
||||
# LIBOBJS = (@LIBOBJS@) |
||||
# LTLIBOBJS = (@LTLIBOBJS@) |
||||
# PACKAGE_BUGREPORT = (@PACKAGE_BUGREPORT@) |
||||
# PACKAGE_NAME = (@PACKAGE_NAME@) |
||||
# PACKAGE_STRING = (@PACKAGE_STRING@) |
||||
# PACKAGE_TARNAME = (@PACKAGE_TARNAME@) |
||||
# PACKAGE_VERSION = (@PACKAGE_VERSION@) |
||||
# PATH_SEPARATOR = (@PATH_SEPARATOR@) |
||||
# PKG_CFLAGS = (@PKG_CFLAGS@) |
||||
# PKG_HEADERS = (@PKG_HEADERS@) |
||||
# PKG_INCLUDES = (@PKG_INCLUDES@) |
||||
# PKG_LIBS = (@PKG_LIBS@) |
||||
# PKG_LIB_FILE = (@PKG_LIB_FILE@) |
||||
# PKG_OBJECTS = (@PKG_OBJECTS@) |
||||
# PKG_SOURCES = (@PKG_SOURCES@) |
||||
# PKG_STUB_LIB_FILE = (@PKG_STUB_LIB_FILE@) |
||||
# PKG_STUB_OBJECTS = (@PKG_STUB_OBJECTS@) |
||||
# PKG_STUB_SOURCES = (@PKG_STUB_SOURCES@) |
||||
# PKG_TCL_SOURCES = (@PKG_TCL_SOURCES@) |
||||
# RANLIB = (@RANLIB@) |
||||
# RANLIB_STUB = (@RANLIB_STUB@) |
||||
# SET_MAKE = (@SET_MAKE@) |
||||
# SHARED_BUILD = (@SHARED_BUILD@) |
||||
# SHELL = (@SHELL@) |
||||
# TCLSH_PROG = (@TCLSH_PROG@) |
||||
# TCL_BIN_DIR = (@TCL_BIN_DIR@) |
||||
# TCL_DBGX = (@TCL_DBGX@) |
||||
# TCL_DEFS = (@TCL_DEFS@) |
||||
# TCL_LIB_FILE = (@TCL_LIB_FILE@) |
||||
# TCL_LIB_FLAG = (@TCL_LIB_FLAG@) |
||||
# TCL_LIB_SPEC = (@TCL_LIB_SPEC@) |
||||
# TCL_PATCH_LEVEL = (@TCL_PATCH_LEVEL@) |
||||
# TCL_SRC_DIR = (@TCL_SRC_DIR@) |
||||
# TCL_STUB_LIB_FILE = (@TCL_STUB_LIB_FILE@) |
||||
# TCL_STUB_LIB_FLAG = (@TCL_STUB_LIB_FLAG@) |
||||
# TCL_STUB_LIB_SPEC = (@TCL_STUB_LIB_SPEC@) |
||||
# TCL_VERSION = (@TCL_VERSION@) |
||||
# VC_MANIFEST_EMBED_DLL = (@VC_MANIFEST_EMBED_DLL@) |
||||
# VC_MANIFEST_EMBED_EXE = (@VC_MANIFEST_EMBED_EXE@) |
||||
|
||||
# ac_ct_CC = (@ac_ct_CC@) |
||||
# bindir = (@bindir@) |
||||
# build_alias = (@build_alias@) |
||||
# datadir = (@datadir@) |
||||
# datarootdir = (@datarootdir@) |
||||
# docdir = (@docdir@) |
||||
# dvidir = (@dvidir@) |
||||
# exec_prefix = (@exec_prefix@) |
||||
# host_alias = (@host_alias@) |
||||
# htmldir = (@htmldir@) |
||||
# includedir = (@includedir@) |
||||
# infodir = (@infodir@) |
||||
# libdir = (@libdir@) |
||||
# libexecdir = (@libexecdir@) |
||||
# localedir = (@localedir@) |
||||
# localstatedir = (@localstatedir@) |
||||
# mandir = (@mandir@) |
||||
# oldincludedir = (@oldincludedir@) |
||||
# pdfdir = (@pdfdir@) |
||||
# prefix = (@prefix@) |
||||
# program_transform_name = (@program_transform_name@) |
||||
# psdir = (@psdir@) |
||||
# sbindir = (@sbindir@) |
||||
# sharedstatedir = (@sharedstatedir@) |
||||
# sysconfdir = (@sysconfdir@) |
||||
# target_alias = (@target_alias@) |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
@ -0,0 +1,145 @@
|
||||
# Makefile.in --
|
||||
#
|
||||
# This file is a Makefile for "@@PNAME@@ @@PMAJORV@@.@@PMINORV@@". If this
|
||||
# is "Makefile.in" then it is a template for a Makefile; to generate
|
||||
# the actual Makefile, run "./configure", which is a configuration script
|
||||
# generated by the "autoconf" program (constructs like "@foo@" will get
|
||||
# replaced in the actual Makefile.
|
||||
#
|
||||
# Copyright (c) @@YEAR@@ @@PORG@@
|
||||
#
|
||||
# Generated by @@CRITCL@@
|
||||
# At @@NOW@@
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
#========================================================================
|
||||
# Nothing of the variables below this line need to be changed. Please
|
||||
# check the TARGETS section below to make sure the make targets are
|
||||
# correct.
|
||||
#========================================================================
|
||||
|
||||
SHELL = @SHELL@
|
||||
|
||||
srcdir = @srcdir@
|
||||
top_srcdir = @top_srcdir@
|
||||
prefix = @prefix@
|
||||
exec_prefix = @exec_prefix@
|
||||
libdir = @libdir@
|
||||
mandir = @mandir@
|
||||
bindir = @bindir@
|
||||
|
||||
sbindir = @sbindir@
|
||||
libexecdir = @libexecdir@
|
||||
datarootdir = @datarootdir@
|
||||
datadir = @datadir@
|
||||
sysconfdir = @sysconfdir@
|
||||
sharedir = @sharedstatedir@
|
||||
statedir = @localstatedir@
|
||||
includedir = @includedir@
|
||||
oldincludedir = @oldincludedir@
|
||||
|
||||
DESTDIR =
|
||||
pkglibdir = $(libdir)/@PACKAGE_NAME@@PACKAGE_VERSION@
|
||||
top_builddir = .
|
||||
|
||||
PACKAGE = @PACKAGE_NAME@
|
||||
VERSION = @PACKAGE_VERSION@
|
||||
CYGPATH = @CYGPATH@
|
||||
|
||||
TCLSH_PROG = @TCLSH_PROG@
|
||||
CRITCL = `$(CYGPATH) $(srcdir)/critcl/main.tcl`
|
||||
|
||||
CONFIG_CLEAN_FILES =
|
||||
@@API@@ |
||||
@@UCONFIG@@ |
||||
#========================================================================
|
||||
# PKG_TCL_SOURCES identifies Tcl runtime files that are associated with
|
||||
# this package that need to be installed, if any.
|
||||
#========================================================================
|
||||
|
||||
PKG_TCL_SOURCES = @@PFILES@@
|
||||
|
||||
#========================================================================
|
||||
# Start of user-definable TARGETS section
|
||||
#========================================================================
|
||||
|
||||
all: |
||||
@echo %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
@echo Please run '"make install"' to build and install the package.
|
||||
@echo Critcl has no separate build-step.
|
||||
|
||||
doc: |
||||
@echo No documentation to build.
|
||||
|
||||
install: |
||||
@echo %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ; \
|
||||
cat $(top_builddir)/Config | grep -v '^#' ; \
|
||||
echo %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ; \
|
||||
rm -rf $(top_builddir)/results-tea ; \
|
||||
$(TCLSH_PROG) $(CRITCL) \
|
||||
-I $(prefix)/include \
|
||||
-I $(exec_prefix)/include \
|
||||
-I $(includedir)@@APIUSE@@ \
|
||||
@@UCONFIGUSE@@ \
|
||||
-keep -cache $(top_builddir)/results-tea \
|
||||
-target TEA -config $(top_builddir)/Config \
|
||||
-libdir $(DESTDIR)$(libdir) \
|
||||
-includedir $(DESTDIR)$(includedir) \
|
||||
-pkg $(PACKAGE)$(VERSION) \
|
||||
$(PKG_TCL_SOURCES) ; \
|
||||
echo %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ; \
|
||||
cat $(top_builddir)/results-tea/*.log
|
||||
echo %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ; \
|
||||
|
||||
install-auto: show-auto |
||||
@rm -rf $(top_builddir)/results-auto ; \
|
||||
$(TCLSH_PROG) $(CRITCL) \
|
||||
-I $(prefix)/include \
|
||||
-I $(exec_prefix)/include \
|
||||
-I $(includedir)@@APIUSE@@ \
|
||||
@@UCONFIGUSE@@ \
|
||||
-keep -cache $(top_builddir)/results-auto \
|
||||
-libdir $(DESTDIR)$(libdir) \
|
||||
-includedir $(DESTDIR)$(includedir) \
|
||||
-pkg $(PACKAGE)$(VERSION) \
|
||||
$(PKG_TCL_SOURCES) ; \
|
||||
echo %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ; \
|
||||
cat $(top_builddir)/results-auto/*.log
|
||||
echo %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ; \
|
||||
|
||||
install-doc: |
||||
@echo No documentation to install.
|
||||
|
||||
show: |
||||
@$(TCLSH_PROG) $(CRITCL) \
|
||||
-keep -cache $(top_builddir)/results-tea \
|
||||
-target TEA -config $(top_builddir)/Config \
|
||||
-libdir $(DESTDIR)$(libdir) \
|
||||
-pkg -show
|
||||
|
||||
show-auto: |
||||
@$(TCLSH_PROG) $(CRITCL) \
|
||||
-keep -cache $(top_builddir)/results-auto \
|
||||
-libdir $(DESTDIR)$(libdir) \
|
||||
-pkg -show
|
||||
|
||||
clean: |
||||
rm -rf doc *-doc
|
||||
|
||||
distclean: clean |
||||
-rm -f Makefile $(CONFIG_CLEAN_FILES)
|
||||
-rm -f config.cache config.log stamp-h stamp-h[0-9]*
|
||||
-rm -f config.status
|
||||
|
||||
Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status |
||||
cd $(top_builddir) \
|
||||
&& CONFIG_FILES=$@ CONFIG_HEADERS= $(SHELL) ./config.status
|
||||
|
||||
|
||||
.PHONY: all binaries clean depend distclean doc install installdirs libraries test |
||||
|
||||
# Tell versions [3.59,3.63) of GNU make to not export all variables.
|
||||
# Otherwise a system limit (for SysV at least) may be exceeded.
|
||||
.NOEXPORT: |
||||
@ -0,0 +1,180 @@
|
||||
# |
||||
# Include the TEA standard macro set |
||||
# |
||||
|
||||
builtin(include,tclconfig/tcl.m4) |
||||
|
||||
# |
||||
# Add here whatever m4 macros you want to define for your package |
||||
# |
||||
|
||||
#------------------------------------------------------------------------ |
||||
# CRITCL_TEA_PUBLIC_PACKAGE_HEADERS -- |
||||
# |
||||
# Locate the installed public FOO header files |
||||
# |
||||
# Arguments: |
||||
# Name of the package to search headers for. |
||||
# |
||||
# Requires: |
||||
# CYGPATH must be set |
||||
# |
||||
# Results: |
||||
# |
||||
# Adds a --with-[$1]-include switch to configure. |
||||
# Result is cached. |
||||
# |
||||
# Substs the following vars: |
||||
# CRITCL_API_$1_INCLUDE |
||||
#------------------------------------------------------------------------ |
||||
|
||||
AC_DEFUN([CRITCL_TEA_PUBLIC_PACKAGE_HEADERS],[ |
||||
# CRITCL_TEA_PUBLIC_PACKAGE_HEADERS: $1 |
||||
AC_MSG_CHECKING([for $1 public headers]) |
||||
AC_ARG_WITH([$1-include], [ --with-$1-include directory containing the public $1 header files], [with_$1_include=${withval}]) |
||||
AC_CACHE_VAL(ac_cv_c_$1_header, [ |
||||
# Use the value from --with-$1-include, if it was given |
||||
|
||||
if test x"[$]{with_$1_include}" != x ; then |
||||
if test -f "[$]{with_$1_include}/$1Decls.h" ; then |
||||
ac_cv_c_$1_header=[$]{with_$1_include} |
||||
else |
||||
AC_MSG_ERROR([[$]{with_$1_include} directory does not contain $1Decls.h]) |
||||
fi |
||||
else |
||||
list="" |
||||
if test "`uname -s`" = "Darwin"; then |
||||
# If $1 was built as a framework, attempt to use |
||||
# the framework's Headers directory |
||||
case [$]{$1_DEFS} in |
||||
*$1_FRAMEWORK*) |
||||
list="`ls -d [$]{$1_BIN_DIR}/Headers 2>/dev/null`" |
||||
;; |
||||
esac |
||||
fi |
||||
|
||||
# Check order: pkg --prefix location, Tcl's --prefix location, |
||||
# relative to directory of $1Config.sh. |
||||
|
||||
eval "temp_includedir=[$]{includedir}" |
||||
list="[$]list \ |
||||
`ls -d [$]{temp_includedir} 2>/dev/null` \ |
||||
`ls -d [$]{$1_PREFIX}/include 2>/dev/null` \ |
||||
`ls -d [$]{$1_BIN_DIR}/../include 2>/dev/null` \ |
||||
`ls -d ${TCL_PREFIX}/include 2>/dev/null` \ |
||||
`ls -d ${TCL_BIN_DIR}/../include 2>/dev/null`" |
||||
|
||||
if test "[$]{TEA_PLATFORM}" != "windows" -o "[$]GCC" = "yes"; then |
||||
list="[$]list /usr/local/include /usr/include" |
||||
if test x"[$]{$1_INCLUDE_SPEC}" != x ; then |
||||
d=`echo "[$]{$1_INCLUDE_SPEC}" | sed -e 's/^-I//'` |
||||
list="[$]list `ls -d ${d} 2>/dev/null`" |
||||
fi |
||||
fi |
||||
for i in [$]list ; do |
||||
if test -f "[$]i/$1/$1Decls.h" ; then |
||||
ac_cv_c_$1_header=[$]i |
||||
break |
||||
fi |
||||
done |
||||
fi |
||||
]) |
||||
|
||||
# Print a message based on how we determined the include path |
||||
if test x"[$]{ac_cv_c_$1_header}" = x ; then |
||||
AC_MSG_ERROR([$1Decls.h not found. Please specify its location with --with-$1-include]) |
||||
else |
||||
AC_MSG_RESULT([[$]{ac_cv_c_$1_header}]) |
||||
fi |
||||
|
||||
# Convert to a native path and substitute into the transfer variable. |
||||
# NOTE: Anything going into actual TEA would have to use A TEA_xx |
||||
# transfer variable, instead of critcl. |
||||
INCLUDE_DIR_NATIVE=`[$]{CYGPATH} [$]{ac_cv_c_$1_header}` |
||||
CRITCL_API_$1_INCLUDE="\"[$]{INCLUDE_DIR_NATIVE}\"" |
||||
AC_SUBST([CRITCL_API_$1_INCLUDE]) |
||||
]) |
||||
|
||||
#------------------------------------------------------------------------ |
||||
# CRITCL_TEA_WITH_CONFIG -- |
||||
# |
||||
# Declare a --with-FOO option, with default and legal values. |
||||
# |
||||
# Arguments: |
||||
# Name of the option. |
||||
# List of legal values. |
||||
# Default value. |
||||
# Option description. |
||||
# |
||||
# Requires: |
||||
# Results: |
||||
# Adds a --with-[$1] switch to configure. |
||||
# |
||||
# Substs the following vars: |
||||
# CRITCL_UCONFIG_$1 |
||||
#------------------------------------------------------------------------ |
||||
|
||||
AC_DEFUN([CRITCL_TEA_WITH_CONFIG],[ |
||||
# CRITCL_TEA_WITH_CONFIG: $1 |
||||
AC_ARG_WITH([$1], |
||||
AC_HELP_STRING([--with-$1], |
||||
[$4]), |
||||
[with_uc_$1=${withval}]) |
||||
|
||||
# Use default if user did not specify anything. |
||||
if test x"[$]{with_uc_$1}" = x ; then |
||||
with_uc_$1="$3" |
||||
fi |
||||
|
||||
AC_MSG_CHECKING([Validating $1]) |
||||
tcl_ok=no |
||||
for x in $2 |
||||
do |
||||
if test "[$]x" = "[$]with_uc_$1" ; then |
||||
tcl_ok=yes |
||||
break |
||||
fi |
||||
done |
||||
if test "[$]tcl_ok" = "no" ; then |
||||
AC_MSG_ERROR([Illegal value [$]with_uc_$1, expected one of: $2]) |
||||
else |
||||
AC_MSG_RESULT([[$]with_uc_$1]) |
||||
fi |
||||
|
||||
CRITCL_UCONFIG_$1="-with-$1 \"[$]with_uc_$1\"" |
||||
AC_SUBST([CRITCL_UCONFIG_$1]) |
||||
]) |
||||
|
||||
#------------------------------------------------------------------------ |
||||
# CRITCL_TEA_BOOL_CONFIG -- |
||||
# |
||||
# Declare a --disable/enable-FOO option, with default. |
||||
# |
||||
# Arguments: |
||||
# Name of the option. |
||||
# Default value. |
||||
# Option description. |
||||
# |
||||
# Requires: |
||||
# Results: |
||||
# Adds a --enable-[$1] switch to configure. |
||||
# |
||||
# Substs the following vars: |
||||
# CRITCL_UCONFIG_$1 |
||||
#------------------------------------------------------------------------ |
||||
|
||||
AC_DEFUN([CRITCL_TEA_BOOL_CONFIG],[ |
||||
# CRITCL_TEA_BOOL_CONFIG: $1 |
||||
AC_ARG_ENABLE([$1], |
||||
AC_HELP_STRING([--enable-$1],[$3]), |
||||
[bool_uc_$1=${enableval}] |
||||
[bool_uc_$1="$2"]) |
||||
|
||||
if test "bool_uc_$1" = "yes" ; then |
||||
CRITCL_UCONFIG_$1="-enable $1" |
||||
else |
||||
CRITCL_UCONFIG_$1="-disable $1" |
||||
fi |
||||
|
||||
AC_SUBST([CRITCL_UCONFIG_$1]) |
||||
]) |
||||
@ -0,0 +1,151 @@
|
||||
# Configure for |
||||
# @@PNAME@@ @@PMAJORV@@.@@PMINORV@@ |
||||
# |
||||
# Copyright (c) @@YEAR@@ @@PORG@@ |
||||
# |
||||
# Generated by @@CRITCL@@ |
||||
# At @@NOW@@ |
||||
|
||||
AC_INIT([@@PNAME@@],[@@PMAJORV@@.@@PMINORV@@]) |
||||
|
||||
TEA_INIT([3.9]) |
||||
|
||||
AC_CONFIG_AUX_DIR(tclconfig) |
||||
|
||||
#-------------------------------------------------------------------- |
||||
# Configure script for package '@@PNAME@@'. |
||||
# TEA compliant. |
||||
#-------------------------------------------------------------------- |
||||
|
||||
#-------------------------------------------------------------------- |
||||
# Load the tclConfig.sh file |
||||
#-------------------------------------------------------------------- |
||||
|
||||
TEA_PATH_TCLCONFIG |
||||
TEA_LOAD_TCLCONFIG |
||||
|
||||
#----------------------------------------------------------------------- |
||||
## Std TEA setup |
||||
|
||||
TEA_PREFIX |
||||
TEA_SETUP_COMPILER |
||||
TEA_PUBLIC_TCL_HEADERS |
||||
#TEA_PRIVATE_TCL_HEADERS |
||||
TEA_ENABLE_THREADS |
||||
TEA_ENABLE_SHARED |
||||
TEA_CONFIG_CFLAGS |
||||
TEA_ENABLE_SYMBOLS |
||||
AC_DEFINE(USE_TCL_STUBS) |
||||
TEA_MAKE_LIB |
||||
TEA_PROG_TCLSH |
||||
@@API@@ |
||||
@@UCONFIG@@ |
||||
#----------------------------------------------------------------------- |
||||
## Convert the TEA settings determined by the macros in the last |
||||
## section into something critcl can use throughts configuration. |
||||
|
||||
AC_MSG_RESULT([critcl config: derived from core TEA]) |
||||
|
||||
#AC_MSG_RESULT([critcl config: CC............. ${CC}]) |
||||
#AC_MSG_RESULT([critcl config: CFLAGS......... ${CFLAGS}]) |
||||
#AC_MSG_RESULT([critcl config: SHLIB_LD....... ${SHLIB_LD}]) |
||||
#AC_MSG_RESULT([critcl config: LIBS........... ${LIBS}| |
||||
#AC_MSG_RESULT([critcl config: MATH_LIBS...... ${MATH_LIBS}]) |
||||
#AC_MSG_RESULT([critcl config: CFLAGS_DEFAULT. ${CFLAGS_DEFAULT}]) |
||||
#AC_MSG_RESULT([critcl config: CFLAGS_WARNING. ${CFLAGS_WARNING}]) |
||||
#AC_MSG_RESULT([critcl config: SHLIB_CFLAGS... ${SHLIB_CFLAGS}]) |
||||
#AC_MSG_RESULT([critcl config: LDFLAGS_DEFAULT ${LDFLAGS_DEFAULT}]) |
||||
|
||||
#----------------------------------------------------------------------- |
||||
## 1. Basic/foundational translation. |
||||
|
||||
CRITCL_CC="$(eval echo ${CC} -c ${CFLAGS})" |
||||
CRITCL_VERSION="${CC} -v" |
||||
CRITCL_LINK="$(eval echo $(eval echo ${SHLIB_LD} ${LIBS} ${MATH_LIBS}))" |
||||
CRITCL_PLATFORM="$(${TCLSH_PROG} ${srcdir}/critcl/main.tcl -showtarget)" |
||||
CRITCL_LD_DBG="" |
||||
CRITCL_LD_REL="" |
||||
CRITCL_CC_OUTPUT="-o [[list \$outfile]]" |
||||
CRITCL_LD_OUTPUT="" |
||||
|
||||
if test "${GCC}" = "yes" |
||||
then |
||||
CRITCL_CPP_DEFINE="${CPP} -dM" |
||||
else |
||||
CRITCL_CPP_DEFINE="${CPP}" |
||||
|
||||
if test "${TEA_PLATFORM}" = "windows" |
||||
then |
||||
# windows, no gcc => msvc |
||||
CRITCL_CC_OUTPUT="[[list -Fo\$outfile]]" |
||||
CRITCL_LD_OUTPUT="-dll [[list -out:\$outfile]]" |
||||
CRITCL_LD_DBG="-debug:full -debugtype:cv -verbose:lib" |
||||
CRITCL_LD_REL="-release -opt:ref -opt:icf,3 -ws:aggressive -verbose:lib" |
||||
if test "$do64bit" = "no" ; then |
||||
# 32bit |
||||
CRITCL_LD_DBG="$CRITCL_LD_DBG -nodefaultlib:libc" |
||||
fi |
||||
fi |
||||
fi |
||||
CRITCL_CPP_ENUM="${CPP}" |
||||
|
||||
#----------------------------------------------------------------------- |
||||
## 2. Fine tuning the commands, this now is platform specific. |
||||
|
||||
case $(uname -s) in |
||||
Darwin*) |
||||
AC_MSG_RESULT([critcl config: darwin specific tune-up]) |
||||
|
||||
# - Critcl, due to essentially generating its private |
||||
# lib{tcl,tk}stub.a does generate common symbols for the |
||||
# stubs tables. Use of -fno-common then prevents linking the |
||||
# object files. |
||||
# |
||||
# - A version 0.0 as pulled from TEA package version is not |
||||
# liked by the Darwin gcc either (Example: crimp). |
||||
|
||||
CRITCL_CC="$(echo "$CRITCL_CC" |sed -e 's,-fno-common,,g')" |
||||
CRITCL_LINK="$(echo "$CRITCL_LINK"|sed -e 's,-fno-common,,g')" |
||||
CRITCL_LINK="$(echo "$CRITCL_LINK"|sed -e 's,-current_version 0\.0,,g')" |
||||
CRITCL_LINK="$(echo "$CRITCL_LINK"|sed -e 's,-compatibility_version 0\.0,,g')" |
||||
;; |
||||
*) |
||||
;; |
||||
esac |
||||
|
||||
#----------------------------------------------------------------------- |
||||
## Conversion results |
||||
|
||||
AC_MSG_RESULT([critcl config: platform.......... $CRITCL_PLATFORM]) |
||||
AC_MSG_RESULT([critcl config: compile........... $CRITCL_CC]) |
||||
AC_MSG_RESULT([critcl config: link.............. $CRITCL_LINK]) |
||||
AC_MSG_RESULT([critcl config: cpp define........ $CRITCL_CPP_DEFINE]) |
||||
AC_MSG_RESULT([critcl config: cpp enum.......... $CRITCL_CPP_ENUM]) |
||||
AC_MSG_RESULT([critcl config: version inquiry... $CRITCL_VERSION]) |
||||
AC_MSG_RESULT([critcl config: cc output......... $CRITCL_CC_OUTPUT]) |
||||
AC_MSG_RESULT([critcl config: ld output......... $CRITCL_LD_OUTPUT]) |
||||
AC_MSG_RESULT([critcl config: ld debug.......... $CRITCL_LD_DBG]) |
||||
AC_MSG_RESULT([critcl config: ld release........ $CRITCL_LD_REL]) |
||||
|
||||
#----------------------------------------------------------------------- |
||||
|
||||
AC_SUBST(CRITCL_CC) |
||||
AC_SUBST(CRITCL_VERSION) |
||||
AC_SUBST(CRITCL_LINK) |
||||
AC_SUBST(CRITCL_PLATFORM) |
||||
AC_SUBST(CRITCL_CPP_DEFINE) |
||||
AC_SUBST(CRITCL_CPP_ENUM) |
||||
AC_SUBST(CRITCL_CC_OUTPUT) |
||||
AC_SUBST(CRITCL_LD_OUTPUT) |
||||
AC_SUBST(CRITCL_LD_DBG) |
||||
AC_SUBST(CRITCL_LD_REL) |
||||
#AC_SUBST(CRITCL_) |
||||
#AC_SUBST() |
||||
|
||||
#-------------------------------------------------------------------- |
||||
# Finally, substitute all of the various values into the Makefile. |
||||
# You may alternatively have a special pkgIndex.tcl.in or other files |
||||
# which require substituting th AC variables in. Include these here. |
||||
#-------------------------------------------------------------------- |
||||
|
||||
AC_OUTPUT([Makefile Config]) |
||||
@ -0,0 +1,26 @@
|
||||
These files comprise the basic building blocks for a Tcl Extension |
||||
Architecture (TEA) extension. For more information on TEA see: |
||||
|
||||
http://www.tcl.tk/doc/tea/ |
||||
|
||||
This package is part of the Tcl project at SourceForge, and latest |
||||
sources should be available there: |
||||
|
||||
http://tcl.sourceforge.net/ |
||||
|
||||
This package is a freely available open source package. You can do |
||||
virtually anything you like with it, such as modifying it, redistributing |
||||
it, and selling it either in whole or in part. |
||||
|
||||
CONTENTS |
||||
======== |
||||
The following is a short description of the files you will find in |
||||
the sample extension. |
||||
|
||||
README.txt This file |
||||
|
||||
install-sh Program used for copying binaries and script files |
||||
to their install locations. |
||||
|
||||
tcl.m4 Collection of Tcl autoconf macros. Included by a package's |
||||
aclocal.m4 to define TEA_* macros. |
||||
@ -0,0 +1,119 @@
|
||||
#!/bin/sh |
||||
|
||||
# |
||||
# install - install a program, script, or datafile |
||||
# This comes from X11R5; it is not part of GNU. |
||||
# |
||||
# $XConsortium: install.sh,v 1.2 89/12/18 14:47:22 jim Exp $ |
||||
# |
||||
# This script is compatible with the BSD install script, but was written |
||||
# from scratch. |
||||
# |
||||
|
||||
|
||||
# set DOITPROG to echo to test this script |
||||
|
||||
# Don't use :- since 4.3BSD and earlier shells don't like it. |
||||
doit="${DOITPROG-}" |
||||
|
||||
|
||||
# put in absolute paths if you don't have them in your path; or use env. vars. |
||||
|
||||
mvprog="${MVPROG-mv}" |
||||
cpprog="${CPPROG-cp}" |
||||
chmodprog="${CHMODPROG-chmod}" |
||||
chownprog="${CHOWNPROG-chown}" |
||||
chgrpprog="${CHGRPPROG-chgrp}" |
||||
stripprog="${STRIPPROG-strip}" |
||||
rmprog="${RMPROG-rm}" |
||||
|
||||
instcmd="$mvprog" |
||||
chmodcmd="" |
||||
chowncmd="" |
||||
chgrpcmd="" |
||||
stripcmd="" |
||||
rmcmd="$rmprog -f" |
||||
mvcmd="$mvprog" |
||||
src="" |
||||
dst="" |
||||
|
||||
while [ x"$1" != x ]; do |
||||
case $1 in |
||||
-c) instcmd="$cpprog" |
||||
shift |
||||
continue;; |
||||
|
||||
-m) chmodcmd="$chmodprog $2" |
||||
shift |
||||
shift |
||||
continue;; |
||||
|
||||
-o) chowncmd="$chownprog $2" |
||||
shift |
||||
shift |
||||
continue;; |
||||
|
||||
-g) chgrpcmd="$chgrpprog $2" |
||||
shift |
||||
shift |
||||
continue;; |
||||
|
||||
-s) stripcmd="$stripprog" |
||||
shift |
||||
continue;; |
||||
|
||||
*) if [ x"$src" = x ] |
||||
then |
||||
src=$1 |
||||
else |
||||
dst=$1 |
||||
fi |
||||
shift |
||||
continue;; |
||||
esac |
||||
done |
||||
|
||||
if [ x"$src" = x ] |
||||
then |
||||
echo "install: no input file specified" |
||||
exit 1 |
||||
fi |
||||
|
||||
if [ x"$dst" = x ] |
||||
then |
||||
echo "install: no destination specified" |
||||
exit 1 |
||||
fi |
||||
|
||||
|
||||
# If destination is a directory, append the input filename; if your system |
||||
# does not like double slashes in filenames, you may need to add some logic |
||||
|
||||
if [ -d $dst ] |
||||
then |
||||
dst="$dst"/`basename $src` |
||||
fi |
||||
|
||||
# Make a temp file name in the proper directory. |
||||
|
||||
dstdir=`dirname $dst` |
||||
dsttmp=$dstdir/#inst.$$# |
||||
|
||||
# Move or copy the file name to the temp name |
||||
|
||||
$doit $instcmd $src $dsttmp |
||||
|
||||
# and set any options; do chmod last to preserve setuid bits |
||||
|
||||
if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; fi |
||||
if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; fi |
||||
if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; fi |
||||
if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; fi |
||||
|
||||
# Now rename the file to the real destination. |
||||
|
||||
$doit $rmcmd $dst |
||||
$doit $mvcmd $dsttmp $dst |
||||
|
||||
|
||||
exit 0 |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,227 @@
|
||||
## -*- tcl -*- |
||||
# # ## ### ##### ######## ############# ##################### |
||||
# Pragmas for MetaData Scanner. |
||||
# n/a |
||||
|
||||
# CriTcl Utility Package for bitmap en- and decoder. |
||||
# Based on i-assoc. |
||||
|
||||
package provide critcl::bitmap 1.1 |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Requirements. |
||||
|
||||
package require Tcl 8.6 ; # Min supported version. |
||||
package require critcl 3.2 |
||||
package require critcl::iassoc |
||||
|
||||
namespace eval ::critcl::bitmap {} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Implementation -- API: Embed C Code |
||||
|
||||
proc critcl::bitmap::def {name dict {exclusions {}}} { |
||||
# dict: Tcl symbolic name -> (C bit-mask (1)) |
||||
# |
||||
# (Ad 1) Can be numeric, or symbolic, as long as it is a C int |
||||
# expression in the end. |
||||
# |
||||
# (Ad exclusions) |
||||
# Excluded bit-masks cannot be converted back to Tcl |
||||
# symbols. These are usually masks with multiple bits |
||||
# set. Conversion back delivers the individual elements |
||||
# instead of the combined mask. |
||||
# |
||||
# If no exclusions are specified the generated code is |
||||
# simpler, i.e. not containing anything for dealing with |
||||
# exclusions at runtime. |
||||
|
||||
# For the C level opt array we want the elements sorted alphabetically. |
||||
set symbols [lsort -dict [dict keys $dict]] |
||||
set i 0 |
||||
foreach s $symbols { |
||||
set id($s) $i |
||||
incr i |
||||
} |
||||
set last $i |
||||
|
||||
set hasexcl [llength $exclusions] |
||||
set excl {} |
||||
foreach e $exclusions { |
||||
dict set excl $e . |
||||
} |
||||
|
||||
dict for {sym mask} $dict { |
||||
set receivable [expr {![dict exists $excl $mask]}] |
||||
|
||||
set map [list @ID@ $id($sym) @SYM@ $sym @MASK@ $mask @RECV@ $receivable] |
||||
|
||||
if {$hasexcl} { |
||||
append init \n[critcl::at::here!][string map $map { |
||||
data->c [@ID@] = "@SYM@"; |
||||
data->mask [@ID@] = @MASK@; |
||||
data->recv [@ID@] = @RECV@; |
||||
data->tcl [@ID@] = Tcl_NewStringObj ("@SYM@", -1); |
||||
Tcl_IncrRefCount (data->tcl [@ID@]); |
||||
}] |
||||
} else { |
||||
append init \n[critcl::at::here!][string map $map { |
||||
data->c [@ID@] = "@SYM@"; |
||||
data->mask [@ID@] = @MASK@; |
||||
data->tcl [@ID@] = Tcl_NewStringObj ("@SYM@", -1); |
||||
Tcl_IncrRefCount (data->tcl [@ID@]); |
||||
}] |
||||
} |
||||
|
||||
append final \n[critcl::at::here!][string map $map { |
||||
Tcl_DecrRefCount (data->tcl [@ID@]); |
||||
}] |
||||
} |
||||
append init \n " data->c \[$last\] = NULL;" |
||||
|
||||
lappend map @NAME@ $name |
||||
lappend map @UNAME@ [string toupper $name] |
||||
lappend map @LAST@ $last |
||||
|
||||
# I. Generate a header file for inclusion by other parts of the |
||||
# package, i.e. csources. Include the header here as well, for |
||||
# the following blocks of code. |
||||
# |
||||
# Declaration of the en- and decoder functions. |
||||
|
||||
critcl::include [critcl::make ${name}.h \n[critcl::at::here!][string map $map { |
||||
#ifndef @NAME@_HEADER |
||||
#define @NAME@_HEADER |
||||
|
||||
/* Encode a flag list into the corresponding bitset */ |
||||
extern int |
||||
@NAME@_encode (Tcl_Interp* interp, |
||||
Tcl_Obj* flags, |
||||
int* result); |
||||
|
||||
/* Decode a bitset into the corresponding flag list */ |
||||
extern Tcl_Obj* |
||||
@NAME@_decode (Tcl_Interp* interp, |
||||
int mask); |
||||
|
||||
#endif |
||||
}]] |
||||
|
||||
# II: Generate the interp association holding the various |
||||
# conversion maps. |
||||
|
||||
if {$hasexcl} { |
||||
critcl::iassoc def ${name}_iassoc {} \n[critcl::at::here!][string map $map { |
||||
const char* c [@LAST@+1]; /* Bit name, C string */ |
||||
Tcl_Obj* tcl [@LAST@]; /* Bit name, Tcl_Obj*, sharable */ |
||||
int mask [@LAST@]; /* Bit mask */ |
||||
int recv [@LAST@]; /* Flag, true for receivable event */ |
||||
}] $init $final |
||||
} else { |
||||
critcl::iassoc def ${name}_iassoc {} \n[critcl::at::here!][string map $map { |
||||
const char* c [@LAST@+1]; /* Bit name, C string */ |
||||
Tcl_Obj* tcl [@LAST@]; /* Bit name, Tcl_Obj*, sharable */ |
||||
int mask [@LAST@]; /* Bit mask */ |
||||
}] $init $final |
||||
} |
||||
|
||||
# III: Generate encoder function: Conversion of list of flag names |
||||
# into corresponding bitset. |
||||
|
||||
critcl::ccode \n[critcl::at::here!][string map $map { |
||||
int |
||||
@NAME@_encode (Tcl_Interp* interp, |
||||
Tcl_Obj* flags, |
||||
int* result) |
||||
{ |
||||
@NAME@_iassoc_data context = @NAME@_iassoc (interp); |
||||
int mask, lc, i, id; |
||||
Tcl_Obj** lv; |
||||
|
||||
if (Tcl_ListObjGetElements (interp, flags, &lc, &lv) != TCL_OK) { |
||||
return TCL_ERROR; |
||||
} |
||||
|
||||
mask = 0; |
||||
for (i = 0; i < lc; i++) { |
||||
if (Tcl_GetIndexFromObj (interp, lv[i], context->c, "@NAME@", 0, |
||||
&id) != TCL_OK) { |
||||
Tcl_SetErrorCode (interp, "@UNAME@", "FLAG", NULL); |
||||
return TCL_ERROR; |
||||
} |
||||
mask |= context->mask [id]; |
||||
} |
||||
|
||||
*result = mask; |
||||
return TCL_OK; |
||||
} |
||||
}] |
||||
|
||||
# IV: Generate decoder function: Convert bitset into the |
||||
# corresponding list of flag names. |
||||
|
||||
if {$hasexcl} { |
||||
critcl::ccode \n[critcl::at::here!][string map $map { |
||||
Tcl_Obj* |
||||
@NAME@_decode (Tcl_Interp* interp, int mask) |
||||
{ |
||||
int i; |
||||
@NAME@_iassoc_data context = @NAME@_iassoc (interp); |
||||
Tcl_Obj* res = Tcl_NewListObj (0, NULL); |
||||
|
||||
for (i = 0; i < @LAST@; i++) { |
||||
if (!context->recv[i]) continue; |
||||
if (!(mask & context->mask[i])) continue; |
||||
(void) Tcl_ListObjAppendElement (interp, res, context->tcl [i]); |
||||
} |
||||
return res; |
||||
} |
||||
}] |
||||
} else { |
||||
critcl::ccode \n[critcl::at::here!][string map $map { |
||||
Tcl_Obj* |
||||
@NAME@_decode (Tcl_Interp* interp, int mask) |
||||
{ |
||||
int i; |
||||
@NAME@_iassoc_data context = @NAME@_iassoc (interp); |
||||
Tcl_Obj* res = Tcl_NewListObj (0, NULL); |
||||
|
||||
for (i = 0; i < @LAST@; i++) { |
||||
if (!(mask & context->mask[i])) continue; |
||||
(void) Tcl_ListObjAppendElement (interp, res, context->tcl [i]); |
||||
} |
||||
return res; |
||||
} |
||||
}] |
||||
} |
||||
|
||||
# V. Define convenient argument- and result-type definitions |
||||
# wrapping the de- and encoder functions for use by cprocs. |
||||
|
||||
critcl::argtype $name \n[critcl::at::here!][string map $map { |
||||
if (@NAME@_encode (interp, @@, &@A) != TCL_OK) return TCL_ERROR; |
||||
}] int int |
||||
|
||||
critcl::resulttype $name \n[critcl::at::here!][string map $map { |
||||
/* @NAME@_decode result is 0-refcount */ |
||||
Tcl_SetObjResult (interp, @NAME@_decode (interp, rv)); |
||||
return TCL_OK; |
||||
}] int |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Export API |
||||
|
||||
namespace eval ::critcl::bitmap { |
||||
namespace export def |
||||
catch { namespace ensemble create } |
||||
} |
||||
|
||||
namespace eval ::critcl { |
||||
namespace export bitmap |
||||
catch { namespace ensemble create } |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Ready |
||||
return |
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in new issue