diff --git a/src/vfs/punk86old.vfs/lib/app-punk/pkgIndex.tcl b/src/vfs/punk86old.vfs/lib/app-punk/pkgIndex.tcl deleted file mode 100644 index 6ace9792..00000000 --- a/src/vfs/punk86old.vfs/lib/app-punk/pkgIndex.tcl +++ /dev/null @@ -1,3 +0,0 @@ - - package ifneeded app-punk 1.0 [list source [file join $dir repl.tcl]] - diff --git a/src/vfs/punk86old.vfs/lib/app-punk/repl.tcl b/src/vfs/punk86old.vfs/lib/app-punk/repl.tcl deleted file mode 100644 index fd658367..00000000 --- a/src/vfs/punk86old.vfs/lib/app-punk/repl.tcl +++ /dev/null @@ -1,188 +0,0 @@ -package provide app-punk 1.0 - -#punk linerepl launcher - -#By the time we get here, we don't expect other packages to have been loaded - but the lib/module paths have already been scanned to populate 'package names' - - -#Note regarding the use of package forget and binary packages -#If the package has loaded a binary component - then a package forget and a subsequent package require can result in both binaries being present, as seen in 'info loaded' result - potentially resulting in anomalous behaviour -#In general package forget after a package has already been required may need special handling and should be avoided where possible. -#Only a limited set of package support unloading a binary component -#We limit the use of 'package forget' here to packages that have not been loaded (whether pure-tcl or not) -#ie in this context it is used only for manipulating preferences of which packages are loaded in the first place - -#Unintuitive preferencing can occur if the same package version is for example present in a tclkit and in a module or lib folder external to the kit. -#It may be desired for performance or testing reasons to preference the library outside of the kit - and raising the version number may not always be possible/practical. - -#If the executable is a kit - we don't know what packages it contains or whether it allows loading from env based external paths. -#For app-punk projects - the lib/module paths based on the project being run should take preference, even if the version number is the same. -#(these are the 'info nameofexecutable' or 'info script' or 'pwd' relative paths that are added here) -#Some kits will remove lib/module paths (from auto_path & tcl::tm::list) that have been added via TCLLIBPATH / TCLX_Y_TM_PATH environment variables -#Some kits will remove those env-provided lib paths but fail to remove the env-provided module paths -#(differences in boot.tcl in the kits) - -#------------------------------------------------------------------------------ -#Module loading -#------------------------------------------------------------------------------ -#If the current directory contains .tm files when the punk repl starts - then it will attempt to preference them -# - but first add our other known relative modules paths - as it won't make sense to use current directory as a modulepath if it's an ancestor of one of these.. - -set original_tm_list [tcl::tm::list] -tcl::tm::remove {*}$original_tm_list - -set module_folders [list] - -#tm list first added end up later in the list - and then override earlier ones if version the same - so add pwd-relative 1st to give higher priority -#(only if Tcl has scanned all paths - see below bogus package load) -#1 -if {[file isdirectory [pwd]/modules]} { - catch {tcl::tm::add [pwd]/modules} -} - -set tclmajorv [lindex [split [info tclversion] .] 0] - -#2) -if {[string match "*.vfs/*" [file normalize [info script]]]} { - #src/xxx.vfs/lib/app-punk/repl.tcl - # assume if calling directly into .vfs that the user would prefer to preference the /modules - so go up 4 levels - set basefolder [file dirname [file dirname [file dirname [file dirname [file normalize [info script]]]]]] - lappend module_folders [file join [file dirname $basefolder] modules] ;#modules folder at same level as src folder - lappend module_folders [file join [file dirname $basefolder] modules_tcl$tclmajorv] -} else { - # .../bin/punkXX.exe look for ../modules (i.e modules folder at same level as bin folder) - lappend module_folders [file dirname [file dirname [info nameofexecutable]]]/modules - lappend module_folders [file dirname [file dirname [info nameofexecutable]]]/modules_tcl$tclmajorv -} -foreach modulefolder $module_folders { - if {[file isdirectory $modulefolder]} { - tcl::tm::add $modulefolder - } else { - puts stderr "Warning unable to find module folder at: $modulefolder" - } -} - - - -#add lib and lib_tcl8 lib_tcl9 etc based on tclmajorv -#libs are appended to end - so add higher priority libraries last (opposite to modules) -#auto_path - add exe-relative after exe-relative path -if {"windows" eq $::tcl_platform(platform)} { - #case differences dont matter - but can stop us finding path in auto_path - foreach libsub [list lib_tcl$tclmajorv lib] { - set libfolder [file dirname [file dirname [info nameofexecutable]]]/$libsub - if {[string tolower $libfolder] ni [string tolower $::auto_path]} { - if {[file isdirectory $libfolder]} { - lappend ::auto_path $libfolder - } - } - set libfolder [pwd]/$libsub - if {[string tolower $libfolder] ni [string tolower $::auto_path]} { - if {[file isdirectory $libfolder]} { - lappend ::auto_path $libfolder - } - } - } -} else { - #on other platforms, case differences could represent different paths - foreach libsub [list lib_tcl$tclmajorv lib] { - set libfolder [file dirname [file dirname [info nameofexecutable]]]/$libsub - if {$libfolder ni $::auto_path} { - if {[file isdirectory $libfolder]} { - lappend ::auto_path $libfolder - } - } - set libfolder [pwd]/$libsub - if {$libfolder ni $::auto_path} { - if {[file isdirectory $libfolder]} { - lappend ::auto_path $libfolder - } - } - } -} - - -#2) -#now add current dir (if no conflict with above) -set currentdir_modules [glob -nocomplain -dir [pwd] -type f -tail *.tm] -set tcl_core_packages [list tcl::zlib zlib tcl::oo TclOO tcl::tommath tcl::zipfs Tcl Tk] -if {[llength $currentdir_modules]} { - #only forget all *unloaded* package names if we are started in a .tm containing folder - foreach pkg [package names] { - if {$pkg in $tcl_core_packages} { - continue - } - if {![llength [package versions $pkg]]} { - #puts stderr "Got no versions for pkg $pkg" - continue - } - if {![string length [package provide $pkg]]} { - puts stderr "--->package forget $pkg<---" - package forget $pkg - } - } - catch {tcl::tm::add [pwd]} -} - -#These are strong dependencies -# - the repl requires Threading and shellfilter to call and display properly. -# tm list already indexed - 'package forget' to find modules based on current tcl::tm::list -#set required [list\ -# shellfilter\ -# shellrun\ -# punk\ -# ] - -#punk & shellrun should be in codethreads - but not required in the parent repl threads - -set required [list\ - shellfilter\ - ] - -catch { - foreach pkg $required { - package forget $pkg - package require $pkg - } -} - - -#restore module paths -set tm_list_now [tcl::tm::list] -foreach p $original_tm_list { - if {$p ni $tm_list_now} { - #the prior tm paths go to the head of the list. - #They are processed first.. but an item of same version later in the list will override one at the head. (depending on when list was scanned) - tcl::tm::add $p - } -} -#------------------------------------------------------------------------------ -#now we need to package require a bogus package to ensure Tcl scans the whole auto_path/tm list - otherwise a lower-versioned module earlier in the path may be loaded -#This seems to take not insignificant time depending on size of auto_path and tcl::tm::list (e.g 2023 i9 100ms) - but seems unavoidable for now -catch {package require flobrudder666_nonexistant} -#------------------------------------------------------------------------------ - -#puts stdout "$::auto_path" -#puts stderr "-----------" -#puts stderr "tcl::tm::list" -#puts stderr "-----------" -#puts stderr "[join [tcl::tm::list] \n]" -#puts stderr "-----------" -#puts stderr "auto_path" -#puts stderr "-----------" -#puts stderr "[join $::auto_path \n]" -#puts stderr "-----------" -#puts stderr "thread? [package provide Thread]" -set thread_version [package require Thread] -#puts stderr "repl.tcl thread version:$thread_version" -catch {package require tcllibc} -foreach pkg $required { - package require $pkg -} - -package require punk::repl -repl::init -safe 0 -repl::start stdin -title app-punk - - - diff --git a/src/vfs/punk86old.vfs/lib/app-shellspy/pkgIndex.tcl b/src/vfs/punk86old.vfs/lib/app-shellspy/pkgIndex.tcl deleted file mode 100644 index 4e20e141..00000000 --- a/src/vfs/punk86old.vfs/lib/app-shellspy/pkgIndex.tcl +++ /dev/null @@ -1,3 +0,0 @@ - - package ifneeded app-shellspy 1.0 [list source [file join $dir shellspy.tcl]] - diff --git a/src/vfs/punk86old.vfs/lib/app-shellspy/shellspy.tcl b/src/vfs/punk86old.vfs/lib/app-shellspy/shellspy.tcl deleted file mode 100644 index c3550570..00000000 --- a/src/vfs/punk86old.vfs/lib/app-shellspy/shellspy.tcl +++ /dev/null @@ -1,1168 +0,0 @@ -#! /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 - -if 0 { - rename ::package ::package_orig - proc package {args} { - if {[lindex $args 0] eq "require"} { - if {[lindex $args 1] eq "twapi"} { - puts stderr "-------------------- loading twapi -------------" - } else { - #puts stderr "-- loading [lindex $args 1] --" - } - - } - tailcall ::package_orig {*}$args - } -} - - -#a test for windows -#fconfigure stdin -encoding utf-16le -#fconfigure stdout -encoding utf-16le - -set original_tm_list [tcl::tm::list] -tcl::tm::remove {*}$original_tm_list -set minimal_tm_list [list] ;#used initially to ensure core modules are loaded from a reduced set of paths to preference current project - -if {[info exists ::starkit::topdir]} { - lappend minimal_tm_list [file join $::starkit::topdir modules] -} -if {[string match "*.vfs/*" [info script]]} { - #src/xxx.vfs/lib/app-punk/repl.tcl - #we assume if calling directly into .vfs that the user would prefer to use the project's built modules - so go up 4 levels - lappend minimal_tm_list [file dirname [file dirname [file dirname [file dirname [info script]]]]]/modules -} else { - #add dir outside of tclkit/exe so we can override with higher versions if necessary without rebuilding - # .../bin/punkXX.exe look for ../modules (i.e modules folder at same level as bin folder) - lappend minimal_tm_list [file normalize [file join [file dirname [file dirname [info nameofexecutable]]] modules]] -} -tcl::tm::add {*}$::minimal_tm_list - -#set m_dir [file normalize [file join [file dirname [info script]] ../../../modules]] -#tcl::tm::add $m_dir - -set libfolder [file dirname [file dirname [info nameofexecutable]]]/lib -if {[file exists $libfolder]} { - lappend ::auto_path $libfolder -} -#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 exedir [file dirname [info nameofexecutable]] - set libroot [file join $exedir scriptlib] - set scriptname $arg1 - if {[string match lib::* $scriptname]} { - set scriptname [string map [list "lib::" "" "::" "/"] $scriptname] - set scriptpath $libroot/$scriptname - } else { - set scriptpath [file normalize $scriptname] - } - - if {![file exists $scriptpath]} { - #try the lowercase version (extension lowercased only) so that file doesn't have to be renamed to use alternate dispatch - set scriptpath [file rootname $scriptpath][string tolower [file extension $scriptpath]] - } - source $scriptpath - - #package require app-punk - -} else { - - - -#set m_dir [file join $starkit::topdir modules] - -#lappend auto_path c:/tcl/lib/tcllib1.20 - -catch {package require tcllibc} -package require Thread - -#NOTE: tm package index will probably already have been created so we must use 'package forget' to restrict to current tcl::tm::list path -#Review - effect on load time of wasting a previously created index? better way? -#require core modules only from punk distribution (REVIEW - override option?) -package forget flagfilter -package require flagfilter -package forget shellfilter -package require shellfilter -package forget punk::ansi -package require punk::ansi -#package forget punk -#package require punk - -#restore module paths -set tm_list_now [tcl::tm::list] -foreach p $original_tm_list { - if {$p ni $tm_list_now} { - tcl::tm::add $p - } -} - - -#package require packageTrace - -set ::testconfig 5 - -namespace eval shellspy { - variable chanstack_stderr_redir - variable chanstack_stdout_redir - - variable commands - proc clock_sec {} { - return [expr {[clock millis]/1000.0}] - } - variable shellspy_status_log "shellspy-[clock micros]" - set debug_syslog_server 127.0.0.1:514 - #set debug_syslog_server 172.16.6.42:51500 - #set debug_syslog_server "" - set error_syslog_server 127.0.0.1:514 - set data_syslog_server 127.0.0.1:514 - - shellfilter::log::open $shellspy_status_log [list -tag $shellspy_status_log -syslog $debug_syslog_server -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 {}] - - #redir on the shellfilter stack with no log or syslog specified acts to suppress output of stdout & stderr. - #todo - fix shellfilter code to make this noop more efficient (avoid creating corresponding logging thread and filter?) - #JMN - #set redirconfig {-settings {-syslog 127.0.0.1:514 -file ""}} - set redirconfig {} - lassign [shellfilter::redir_output_to_log "SUPPRESS" {*}$redirconfig] chanstack_stdout_redir chanstack_stderr_redir - shellfilter::log::write $shellspy_status_log "shellfilter::redir_output_to_log SUPPRESS DONE [clock_sec]" - - - ### - #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 stdout_log "" - set stderr_log "" - - shellfilter::log::write $shellspy_status_log "shellfilter::stack::new shellspyerr ABOUTTO [clock_sec]" - set errdeviceinfo [shellfilter::stack::new shellspyerr -settings [list -tag "shellspyerr" -buffering none -raw 1 -syslog $data_syslog_server -file $stderr_log]] - shellfilter::log::write $shellspy_status_log "shellfilter::stack::new shellspyerr DONE [clock_sec]" - - - shellfilter::log::write $shellspy_status_log "shellfilter::stack::new shellspyout ABOUTTO [clock_sec]" - set outdeviceinfo [shellfilter::stack::new shellspyout -settings [list -tag "shellspyout" -buffering none -raw 1 -syslog $data_syslog_server -file $stdout_log]] - set commandlog [dict get $outdeviceinfo localchan] - #puts $commandlog "HELLO $commandlog" - #flush $commandlog - shellfilter::log::write $shellspy_status_log "shellfilter::stack::new shellspyout DONE [clock_sec]" - - - - #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 {}] - shellfilter::log::write $shellspy_status_log "shellfilter::stack::add shellspyout ansistrip DONE [clock_sec]" - - - #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_help {args} { - #return [dict create result $::shellspy::commands] - set result "" - foreach cmd $::shellspy::commands { - lassign $cmd tag cmdinfo - if {[lindex $cmdinfo 0] eq "sub"} { - continue - } - if {[dict exists $cmdinfo match]} { - append result "$tag [dict get $cmdinfo match]" \n - } - } - return [dict create result $result] - } - - - #punk86 -tk example: - # punk86 -tk eval "button .tk.b -text doit -command {set ::punkapp::result(shell) guiresult;punkapp::close_window .tk}; pack .tk.b;return somedefaultvalue" - proc do_tclline {flavour args} { - variable chanstack_stderr_redir - variable chanstack_stdout_redir - - if {$flavour in [list "punk" "punkshell"]} { - namespace eval :: {package require punk;package require shellrun} - } elseif {$flavour in [list "tk" "tkshell"]} { - namespace eval :: { - package require Tk - package require punkapp - punkapp::hide_dot_window - toplevel .tk - if {[wm protocol . WM_DELETE_WINDOW] eq ""} { - wm protocol . WM_DELETE_WINDOW [list punkapp::close_window .] - } - wm protocol .tk WM_DELETE_WINDOW [list punkapp::close_window .tk] - } - } - #remove SUPPRESS redirection if it was in place so that shell output is visible - catch { - shellfilter::stack::remove stderr $chanstack_stderr_redir - shellfilter::stack::remove stdout $chanstack_stdout_redir - } - set result_is_error 0 - if {[catch {apply [list {arglist} {namespace eval :: $arglist} ::] $args} result]} { - set result_is_error 1 - } - if {$flavour in [list "punkshell" "tkshell"]} { - set result [namespace eval :: [string map [list %e% $chanstack_stderr_redir %o% $chanstack_stdout_redir %r% $result] { - package require punk - package require shellrun - package require punk::repl - puts stdout "quit to exit" - repl::init -safe 0 - repl::start stdin -defaultresult %r% - }]] - } - - #todo - better exit? - if {$result_is_error} { - if {$flavour eq "tk"} { - return [dict create error [namespace eval :: [list punkapp::wait -defaultresult $result]]] - #todo - better return value e.g from dialog? - } - return [dict create error $result] - } else { - if {$flavour eq "tk"} { - return [dict create result [namespace eval :: [list punkapp::wait -defaultresult $result]]] - #todo - better return value e.g from dialog? - } - return [dict create result $result] - } - } - proc set_punkd {args} { - variable shellspy_status_log - shellfilter::log::write $shellspy_status_log "set_punkd got '$args'" - - set punkd_status_log "set_punkd_log" - shellfilter::log::open $punkd_status_log [list -tag $punkd_status_log -syslog 127.0.0.1:514 -file ""] - shellfilter::log::write $punkd_status_log "set_punkd got '$args'" - return [dict create result ok] - } - - 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 - - - dict set params -debug 1 - dict set params -timeout 1000 - - #set exitinfo [shellfilter::run [list pwsh -nologo -noprofile -c {*}$args] -debug 1] - - - set id_err [shellfilter::stack::add stderr ansiwrap -action sink -settings {-colour {red bold}}] - set exitinfo [shellfilter::run [list pwsh -nologo -noprofile -c {*}$args] {*}$params] - shellfilter::stack::remove stderr $id_err - - #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] - } - return $exitinfo - } - proc do_in_powershell_terminal {args} { - variable shellspy_status_log - shellfilter::log::write $shellspy_status_log "do_in_powershell_terminal got '$args'" - set args [do_callback powershell {*}$args] - set params [do_callback_parameters powershell] - 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 [list pwsh -nologo -c {*}$args] - #the big problem with using the 'script' command is that we get stderr/stdout mashed together. - - #set cmdlist [shellfilter::get_scriptrun_from_cmdlist_dquote_if_not $cmdlist] - shellfilter::log::write $shellspy_status_log "do_in_powershell_terminal as script: '$cmdlist'" - - set id_err [shellfilter::stack::add stderr ansiwrap -action sink -settings {-colour {red bold}}] - set exitinfo [shellfilter::run $cmdlist {*}$params] - shellfilter::stack::remove stderr $id_err - - if {[lindex $exitinfo 0] eq "exitcode"} { - shellfilter::log::write $shellspy_status_log "do_in_powershell_terminal returning $exitinfo" - } - return $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 id_err [shellfilter::stack::add stderr ansiwrap -action sink-locked -settings {-colour {red bold}}] - - #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 stderr $id_err - - #shellfilter::stack::remove stdout $id_out - - shellfilter::log::write $shellspy_status_log "do_in_cmdshell raw exitinfo: $exitinfo" - - - 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" - } - return $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 -junction 1 -settings {}] - - - 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" - } - return $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" - } - return $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" - } - return $exitinfo - } - - proc do_script_process {scriptbin 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]] - - set exedir [file dirname [info nameofexecutable]] - if {[file tail $exedir] eq "bin"} { - set basedir [file dirname $exedir] - } else { - set basedir $exedir - } - set libroot [file join $basedir scriptlib] - if {[string match lib::* $scriptname]} { - set scriptname [string map [list "lib::" "" "::" "/"] $scriptname] - set scriptpath $libroot/$scriptname - } else { - set scriptpath $scriptname - } - if {![file exists $scriptpath]} { - set scriptpath [file rootname $scriptpath][string tolower [file extension $scriptpath]] - if {![file exists $scriptpath]} { - puts stderr "Failed to find script: '$scriptpath'" - error "bad scriptpath '$scriptpath' arguments: $scriptbin $scriptname $args" - } - } - - - - #set id_err [shellfilter::stack::add stderr ansiwrap -action sink-locked -settings {-colour {red bold}}] - - - - #todo - use glob to check capitalisation of file tail (.TCL vs .tcl .Tcl etc) - set exitinfo [shellfilter::run [concat [auto_execok $scriptbin] $scriptpath $args] {*}$params] - shellfilter::log::write $shellspy_status_log "do_script_process exitinfo: $exitinfo" - - #shellfilter::stack::remove stderr $id_err - - #if {[lindex $exitinfo 0] eq "exitcode"} { - # shellfilter::log::write $shellspy_status_log "do_script_process returning $exitinfo" - #} - #if {[dict exists $exitinfo errorCode]} { - # exit [dict get $exitinfo $errorCode] - #} - return $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 exedir [file dirname [info nameofexecutable]] - if {[file tail $exedir] eq "bin"} { - set basedir [file dirname $exedir] - } else { - set basedir $exedir - } - set libroot [file join $basedir scriptlib] - if {[string match lib::* $scriptname]} { - set scriptname [string map [list "lib::" "" "::" "/"] $scriptname] - set scriptpath $libroot/$scriptname - if {[file extension $scriptpath] eq ""} { - if {![file exists $scriptpath]} { - set scriptpath ${scriptpath}.tcl - } - } - } else { - set scriptpath $scriptname - } - if {![file exists $scriptpath]} { - set scriptpath [file rootname $scriptpath][string tolower [file extension $scriptpath]] - if {![file exists $scriptpath]} { - puts stderr "Failed to find script: '$scriptpath'" - error "bad scriptpath '$scriptpath'" - } - } - set modulesdir $basedir/modules - - set script [string map [list %a% $args %s% $scriptpath %m% $modulesdir] { -::tcl::tm::add %m% -set scriptname %s% -set ::argv [list %a%] -set ::argc [llength $::argv] -source [file normalize $scriptname] - - }] - - set repl_lines "" - #append repl_lines {puts stderr "starting repl [chan names]"} \n - #append repl_lines {puts stderr "stdin [chan configure stdin]"} \n - append repl_lines {package require punk::repl} \n - append repl_lines {repl::init -safe 0} \n - append repl_lines {repl::start stdin} \n - - #append repl_lines {puts stdout "shutdown message"} \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_lines" - } elseif {$replwhen eq "repl_last"} { - append script $repl_lines - } 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 - #dict set params -teehandle punksh - - - set params [dict merge $params [get_channel_config $::testconfig]] - - set id_err [shellfilter::stack::add stderr ansiwrap -action sink-locked -settings {-colour {red bold}}] - - set exitinfo [shellfilter::run $script {*}$params] - - shellfilter::stack::remove stderr $id_err - - #if {[lindex $exitinfo 0] eq "exitcode"} { - # shellfilter::log::write $shellspy_status_log "do_script returning $exitinfo" - #} - - shellfilter::log::write $shellspy_status_log "do_script raw exitinfo: $exitinfo" - if {[dict exists $exitinfo errorInfo]} { - #strip out the irrelevant info from the errorInfo - we don't want info beyond 'invoked from within' as this is just plumbing related to the script sourcing - set stacktrace [string map [list \r\n \n] [dict get $exitinfo errorInfo]] - set output "" - set tracelines [split $stacktrace \n] - foreach ln $tracelines { - if {[string match "*invoked from within*" $ln]} { - break - } - append output $ln \n - } - set output [string trimright $output \n] - dict set exitinfo errorInfo $output - shellfilter::log::write $shellspy_status_log "do_script simplified exitinfo: $exitinfo" - } - return $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 -junction 1 -settings {}] - - #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" - } - return $exitinfo - } - proc do_wsl {distdefault args} { - variable shellspy_status_log - shellfilter::log::write $shellspy_status_log "do_wsl $distdefault got '$args' [llength $args]" - set args [do_callback wsl {*}$args] ;#use dist? - shellfilter::log::write $shellspy_status_log "do_wsl $distdefault 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 -junction 1 -settings {}] - - dict set params -teehandle shellspy ;#shellspyout shellspyerr must exist - set exitinfo [shellfilter::run [concat wsl -d $distdefault -e [shellescape $args]] {*}$params] - - - shellfilter::stack::remove stdout $id_out - - - if {[lindex $exitinfo 0] eq "exitcode"} { - shellfilter::log::write $shellspy_status_log "do_wsl $distdefault returning $exitinfo" - } - return $exitinfo - } - - #todo - load these from a callback - set commands [list] - lappend commands [list punkd [list match [list punkd] dispatch [list shellspy::set_punkd] dispatchtype raw dispatchglobal 1 singleopts {any}]] - lappend commands [list punkd [list sub punkdict singleopts {any}]] - - - #'shout' extension (all uppercase) 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 tclsh %matched%] dispatchtype raw 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 raw 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 raw 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 raw dispatchglobal 1 singleopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list tclscript [list sub word$i singleopts {any}]] - } - #%argN% and %argtakeN% can be used as well as %matched% - %argtakeN% will remove from raw and arguments elements of dispatchrecord - lappend commands [list withinterp [list match {^withinterp$} dispatch [list shellspy::do_script_process %argtake0%] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any} pairopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list withinterp [list sub word$i singleopts {any} longopts {any} pairopts {any}]] - } - - lappend commands [list runcmdfile [list match [list {.*\.cmd$} {.*\.bat$} ] dispatch [list shellspy::do_in_cmdshell %matched%] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list runcmdfile [list sub word$i singleopts {any}]] - } - - lappend commands [list libscript [list match [list {lib::.*$} ] dispatch [list shellspy::do_script %matched% "no_repl"] dispatchtype raw dispatchglobal 1 singleopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list libscript [list sub word$i singleopts {any}]] - } - - lappend commands [list luascriptprocess [list match [list {.*\.lua|Lua|LUA$}] dispatch [list shellspy::do_script_process lua %matched% "no_repl"] dispatchtype raw dispatchglobal 1 singleopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list luascriptprocess [list sub word$i singleopts {any}]] - } - - lappend commands [list phpscriptprocess [list match [list {.*\.php|Php|PHP$}] dispatch [list shellspy::do_script_process php %matched% "no_repl"] dispatchtype raw dispatchglobal 1 singleopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list phpscriptprocess [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 [list runbash [list match {^shellbash$} 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 {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 {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 bracketed args () e.g with vim shellxquote set to "(" - lappend commands [list runcmdb [list match {^cmdb$} dispatch [list shellspy::do_in_cmdshellb] 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}]] - } - - #e.g - # punk -tcl info patch - # punk -tcl eval "package require punk::char;punk::char::charset_page dingbats" - - lappend commands [list tclline [list match [list {^-tcl$}] dispatch [list shellspy::do_tclline tcl] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list tclline [list sub word$i singleopts {any}]] - } - lappend commands [list punkline [list match {^-punk$} dispatch [list shellspy::do_tclline punk] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list punkline [list sub word$i singleopts {any}]] - } - lappend commands [list tkline [list match {^-tk$} dispatch [list shellspy::do_tclline tk] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list tkline [list sub word$i singleopts {any}]] - } - lappend commands [list tkshellline [list match {^-tkshell$} dispatch [list shellspy::do_tclline tkshell] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list tkshellline [list sub word$i singleopts {any}]] - } - lappend commands [list punkshellline [list match {^-punkshell$} dispatch [list shellspy::do_tclline punkshell] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list punkshellline [list sub word$i singleopts {any}]] - } - - - lappend commands [list help [list match [list {^-help$} {^--help$} {^help$} {^/\?}] dispatch [list shellspy::do_help] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]] - for {set i 0} {$i < 25} {incr i} { - lappend commands [list help [list sub word$i singleopts {any}]] - } - ############################################################################################ - - #todo -noexit flag - - - #echo raw args to diverted stderr before running the argument analysis - puts -nonewline stderr "exe:[info nameofexecutable] script:[info script] shellspy-rawargs: $::argv\n" - set i 1 - foreach a $::argv { - puts -nonewline stderr "arg$i: '$a'\n" - incr i - } - - - set argdefinitions [list \ - -caller punkshell_dispatcher \ - -debugargs 0 \ - -debugargsonerror 2 \ - -return all \ - -soloflags {} \ - -defaults [list] \ - -required {none} \ - -extras {all} \ - -commandprocessors $commands \ - -values $::argv ] - - - set is_call_error 0 - set arglist [list] ;#processed args result - contains dispatch info etc. - if {[catch { - set arglist [check_flags {*}$argdefinitions] - } callError]} { - puts -nonewline stderr "|shellspy-stderr> ERROR during command dispatch\n" - puts -nonewline stderr "|shellspy-stderr> $callError\n" - puts -nonewline stderr "|shellspy-stderr> [set ::errorInfo]\n" - - shellfilter::log::write $shellspy_status_log "check_flags error: $callError" - set is_call_error 1 - } else { - shellfilter::log::write $shellspy_status_log "check_flags result: $arglist" - } - - shellfilter::log::write $shellspy_status_log "check_flags dispatch -done- [clock_sec]" - - #puts stdout "sp2. $::argv" - - if {[catch { - set tidyinfo [shellfilter::logtidyup] - } errMsg]} { - - shellfilter::log::open shellspy-error {-tag shellspy-error -syslog $error_syslog_server} - shellfilter::log::write shellspy-error "logtidyup error $errMsg\n [set ::errorInfo]" - after 200 - } - #don't open more logs.. - #puts stdout ">$tidyinfo" - - #lassign [shellfilter::redir_output_to_log "SUPPRESS"] id_stdout_redir id_stderr_redir - catch { - shellfilter::stack::remove stderr $chanstack_stderr_redir - shellfilter::stack::remove stdout $chanstack_stdout_redir - } - - #shellfilter::log::write $shellspy_status_log "logtidyup -done- $tidyinfo" - - catch { - 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 -done1-" - #flush stdout - - #shellfilter::log::write $shellspy_status_log "shellspy -done-" - - if {[catch { - shellfilter::logtidyup $shellspy_status_log - #puts stdout "shellspy logtidyup done" - #flush stdout - } errMsg]} { - puts stdout "shellspy logtidyup error $errMsg" - flush stdout - shellfilter::log::open shellspy-final {-tag shellspy-final -syslog $error_syslog_server} - shellfilter::log::write shellspy-final "FINAL logtidyup error $errMsg\n [set ::errorInfo]" - after 100 - } - #puts [shellfilter::stack::status shellspyout] - #puts [shellfilter::stack::status shellspyerr] - - #sample dispatch member of $arglist - #dispatch { - # tclscript { - # command {shellspy::do_script %matched% no_repl} - # matched stdout.tcl arguments {} raw {} dispatchtype raw - # asdispatched {shellspy::do_script stdout.tcl no_repl} - # result {result {}} - # error {} - # } - #} - # or - #dispatch { - # tclscript { - # command xxx - # matched error.tcl arguments {} raw {} dispatchtype raw - # asdispatched {shellspy::do_script error.tcl no_repl} - # result { - # error {This is the error} - # errorCode NONE - # errorInfo This\ is\ the\ error\n\ etc - # } - # error {} - # } - #} - - - shellfilter::stack::delete shellspyout - shellfilter::stack::delete shellspyerr - set free_info [shellthread::manager::shutdown_free_threads] - #puts stdout $free_info - #flush stdout - if {[package provide zzzload] ne ""} { - #if zzzload used and not shutdown - we can get deadlock - #puts "zzzload::loader_tid [set ::zzzload::loader_tid]" - #zzzload::shutdown - } - #puts stdout "threads: [thread::names]" - #flush stdout - #puts stdout "calling release on remaining threads" - foreach tid [thread::names] { - thread::release $tid - } - #puts stdout "threads: [thread::names]" - #flush stdout - - - set colour ""; set reset "" - if {$is_call_error} { - catch { - set colour [punk::ansi::a+ yellow bold underline]; set reset [punk::ansi::a] - } - puts stderr $colour$callError$reset - flush stderr - exit 1 - } else { - if {[dict exists $arglist dispatch tclscript result errorInfo]} { - catch { - set colour [punk::ansi::a+ yellow bold]; set reset [punk::ansi::a] - } - set err [dict get $arglist dispatch tclscript result errorInfo] - if {$err ne ""} { - puts stderr $colour$err$reset - flush stderr - exit 1 - } - } - - foreach tclscript_flavour [list tclline punkline punkshellline tkline tkshellline libscript help] { - if {[dict exists $arglist dispatch $tclscript_flavour result error]} { - catch { - set colour [punk::ansi::a+ yellow bold]; set reset [punk::ansi::a] - } - set err [dict get $arglist dispatch $tclscript_flavour result error] - if {$err ne ""} { - puts stderr $colour$err$reset - flush stderr - exit 1 - } - } - } - } - - - if {[dict exists $arglist errorCode]} { - exit [dict get $arglist errorCode] - } - foreach tclscript_flavour [list tclline punkline punkshellline tkline tkshellline libscript help] { - if {[dict exists $arglist dispatch $tclscript_flavour result result]} { - puts -nonewline stdout [dict get $arglist dispatch $tclscript_flavour result result] - exit 0 - } - } - - #if we call exit - package require Tk script files will exit prematurely - #review - #exit 0 -} - -} diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/LICENSE b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/LICENSE deleted file mode 100644 index fcfc79f8..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/LICENSE +++ /dev/null @@ -1,29 +0,0 @@ -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. diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/account.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/account.tcl deleted file mode 100644 index 2b87b35d..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/account.tcl +++ /dev/null @@ -1,1160 +0,0 @@ -# -# Copyright (c) 2009-2015, Ashok P. Nadkarni -# All rights reserved. -# -# See the file LICENSE for license - -package require twapi_security - -namespace eval twapi { - record USER_INFO_0 {-name} - record USER_INFO_1 [concat [USER_INFO_0] { - -password -password_age -priv -home_dir -comment -flags -script_path - }] - record USER_INFO_2 [concat [USER_INFO_1] { - -auth_flags -full_name -usr_comment -parms - -workstations -last_logon -last_logoff -acct_expires -max_storage - -units_per_week -logon_hours -bad_pw_count -num_logons - -logon_server -country_code -code_page - }] - record USER_INFO_3 [concat [USER_INFO_2] { - -user_id -primary_group_id -profile -home_dir_drive -password_expired - }] - record USER_INFO_4 [concat [USER_INFO_2] { - -sid -primary_group_id -profile -home_dir_drive -password_expired - }] - - record GROUP_INFO_0 {-name} - record GROUP_INFO_1 {-name -comment} - record GROUP_INFO_2 {-name -comment -group_id -attributes} - record GROUP_INFO_3 {-name -comment -sid -attributes} - - record NetEnumResult {moredata hresume totalentries entries} - -} - -# Add a new user account -proc twapi::new_user {username args} { - array set opts [parseargs args [list \ - system.arg \ - password.arg \ - comment.arg \ - [list priv.arg "user" [array names twapi::priv_level_map]] \ - home_dir.arg \ - script_path.arg \ - ] \ - -nulldefault] - - if {$opts(priv) ne "user"} { - error "Option -priv is deprecated and values other than 'user' are not allowed" - } - - # 1 -> priv level 'user'. NetUserAdd mandates this as only allowed value - NetUserAdd $opts(system) $username $opts(password) 1 \ - $opts(home_dir) $opts(comment) 0 $opts(script_path) - - - # Backward compatibility - add to 'Users' local group - # but only if -system is local - if {$opts(system) eq "" || - ([info exists ::env(COMPUTERNAME)] && - [string equal -nocase $opts(system) $::env(COMPUTERNAME)])} { - trap { - _set_user_priv_level $username $opts(priv) -system $opts(system) - } onerror {} { - # Remove the previously created user account - catch {delete_user $username -system $opts(system)} - rethrow - } - } -} - - -# Delete a user account -proc twapi::delete_user {username args} { - array set opts [parseargs args {system.arg} -nulldefault] - - # Remove the user from the LSA rights database. - _delete_rights $username $opts(system) - - NetUserDel $opts(system) $username -} - - -# Define various functions to set various user account fields -foreach twapi::_field_ { - {name 0} - {password 1003} - {home_dir 1006} - {comment 1007} - {script_path 1009} - {full_name 1011} - {country_code 1024} - {profile 1052} - {home_dir_drive 1053} -} { - proc twapi::set_user_[lindex $::twapi::_field_ 0] {username fieldval args} " - array set opts \[parseargs args { - system.arg - } -nulldefault \] - Twapi_NetUserSetInfo [lindex $::twapi::_field_ 1] \$opts(system) \$username \$fieldval" -} -unset twapi::_field_ - -# Set account expiry time -proc twapi::set_user_expiration {username time args} { - array set opts [parseargs args {system.arg} -nulldefault] - - if {![string is integer -strict $time]} { - if {[string equal $time "never"]} { - set time -1 - } else { - set time [clock scan $time] - } - } - Twapi_NetUserSetInfo 1017 $opts(system) $username $time -} - -# Unlock a user account -proc twapi::unlock_user {username args} { - # UF_LOCKOUT -> 0x10 - _change_user_info_flags $username 0x10 0 {*}$args -} - -# Enable a user account -proc twapi::enable_user {username args} { - # UF_ACCOUNTDISABLE -> 0x2 - _change_user_info_flags $username 0x2 0 {*}$args -} - -# Disable a user account -proc twapi::disable_user {username args} { - # UF_ACCOUNTDISABLE -> 0x2 - _change_user_info_flags $username 0x2 0x2 {*}$args -} - - -# Return the specified fields for a user account -proc twapi::get_user_account_info {account args} { - # Define each option, the corresponding field, and the - # information level at which it is returned - array set fields { - comment 1 - password_expired 4 - full_name 2 - parms 2 - units_per_week 2 - primary_group_id 4 - flags 1 - logon_server 2 - country_code 2 - home_dir 1 - password_age 1 - home_dir_drive 4 - num_logons 2 - acct_expires 2 - last_logon 2 - usr_comment 2 - bad_pw_count 2 - code_page 2 - logon_hours 2 - workstations 2 - last_logoff 2 - name 0 - script_path 1 - profile 4 - max_storage 2 - } - # Left out - auth_flags 2 - # Left out (always returned as NULL) - password {usri3_password 1} - # Note sid is available at level 4 as well but don't want to set - # level 4 just for that since we can get it by other means. Hence - # not listed above - - array set opts [parseargs args \ - [concat [array names fields] sid \ - internet_identity \ - status type password_attrs \ - [list local_groups global_groups system.arg all]] \ - -nulldefault] - - if {$opts(all)} { - set level 4 - set opts(local_groups) 1 - set opts(global_groups) 1 - } else { - # Based on specified fields, figure out what level info to ask for - set level -1 - foreach {opt optval} [array get opts] { - if {[info exists fields($opt)] && - $optval && - $fields($opt) > $level - } { - set level $fields($opt) - } - } - if {$opts(status) || $opts(type) || $opts(password_attrs)} { - # These fields are based on the flags field - if {$level < 1} { - set level 1 - } - } - } - - array set result [list ] - - if {$level > -1} { - set rawdata [NetUserGetInfo $opts(system) $account $level] - array set data [USER_INFO_$level $rawdata] - - # Extract the requested data - foreach opt [array names fields] { - if {$opts(all) || $opts($opt)} { - set result(-$opt) $data(-$opt) - } - } - if {$level == 4 && ($opts(all) || $opts(sid))} { - set result(-sid) $data(-sid) - } - - # Map internal values to more friendly formats - if {$opts(all) || $opts(status) || $opts(type) || $opts(password_attrs)} { - array set result [_map_userinfo_flags $data(-flags)] - if {! $opts(all)} { - if {! $opts(status)} {unset result(-status)} - if {! $opts(type)} {unset result(-type)} - if {! $opts(password_attrs)} {unset result(-password_attrs)} - } - } - - if {[info exists result(-logon_hours)]} { - binary scan $result(-logon_hours) b* result(-logon_hours) - } - - foreach time_field {-acct_expires -last_logon -last_logoff} { - if {[info exists result($time_field)]} { - if {$result($time_field) == -1 || $result($time_field) == 4294967295} { - set result($time_field) "never" - } elseif {$result($time_field) == 0} { - set result($time_field) "unknown" - } - } - } - } - - if {$opts(all) || $opts(internet_identity)} { - set result(-internet_identity) {} - if {[min_os_version 6 2]} { - set inet_ident [NetUserGetInfo $opts(system) $account 24] - if {[llength $inet_ident]} { - set result(-internet_identity) [twine { - internet_provider_name internet_principal_name sid - } [lrange $inet_ident 1 end]] - } - } - } - - # The Net* calls always return structures as lists even when the struct - # contains only one field so we need to lpick to extract the field - - if {$opts(local_groups)} { - set result(-local_groups) [lpick [NetEnumResult entries [NetUserGetLocalGroups $opts(system) $account 0 0]] 0] - } - - if {$opts(global_groups)} { - set result(-global_groups) [lpick [NetEnumResult entries [NetUserGetGroups $opts(system) $account 0]] 0] - } - - if {$opts(sid) && ! [info exists result(-sid)]} { - set result(-sid) [lookup_account_name $account -system $opts(system)] - } - - return [array get result] -} - -proc twapi::get_user_global_groups {account args} { - parseargs args { - system.arg - denyonly - all - } -nulldefault -maxleftover 0 -setvars - - set groups {} - foreach elem [NetEnumResult entries [NetUserGetGroups $system [map_account_to_name $account -system $system] 1]] { - # 0x10 -> SE_GROUP_USE_FOR_DENY_ONLY - set marked_denyonly [expr {[lindex $elem 1] & 0x10}] - if {$all || ($denyonly && $marked_denyonly) || !($denyonly || $marked_denyonly)} { - lappend groups [lindex $elem 0] - } - } - return $groups -} - -proc twapi::get_user_local_groups {account args} { - parseargs args { - system.arg - {recurse.bool 0} - } -nulldefault -maxleftover 0 -setvars - - # The Net* calls always return structures as lists even when the struct - # contains only one field so we need to lpick to extract the field - return [lpick [NetEnumResult entries [NetUserGetLocalGroups $system [map_account_to_name $account -system $system] 0 $recurse]] 0] -} - -proc twapi::get_user_local_groups_recursive {account args} { - return [get_user_local_groups $account {*}$args -recurse 1] -} - - -# Set the specified fields for a user account -proc twapi::set_user_account_info {account args} { - - # Define each option, the corresponding field, and the - # information level at which it is returned - array set opts [parseargs args { - {system.arg ""} - comment.arg - full_name.arg - country_code.arg - home_dir.arg - home_dir.arg - acct_expires.arg - name.arg - script_path.arg - profile.arg - }] - - # TBD - rewrite this to be atomic - - if {[info exists opts(comment)]} { - set_user_comment $account $opts(comment) -system $opts(system) - } - - if {[info exists opts(full_name)]} { - set_user_full_name $account $opts(full_name) -system $opts(system) - } - - if {[info exists opts(country_code)]} { - set_user_country_code $account $opts(country_code) -system $opts(system) - } - - if {[info exists opts(home_dir)]} { - set_user_home_dir $account $opts(home_dir) -system $opts(system) - } - - if {[info exists opts(home_dir_drive)]} { - set_user_home_dir_drive $account $opts(home_dir_drive) -system $opts(system) - } - - if {[info exists opts(acct_expires)]} { - set_user_expiration $account $opts(acct_expires) -system $opts(system) - } - - if {[info exists opts(name)]} { - set_user_name $account $opts(name) -system $opts(system) - } - - if {[info exists opts(script_path)]} { - set_user_script_path $account $opts(script_path) -system $opts(system) - } - - if {[info exists opts(profile)]} { - set_user_profile $account $opts(profile) -system $opts(system) - } -} - - -proc twapi::get_global_group_info {grpname args} { - array set opts [parseargs args { - {system.arg ""} - comment - name - members - sid - attributes - all - } -maxleftover 0] - - set result {} - if {[expr {$opts(comment) || $opts(name) || $opts(sid) || $opts(attributes) || $opts(all)}]} { - # 3 -> GROUP_INFO level 3 - lassign [NetGroupGetInfo $opts(system) $grpname 3] name comment sid attributes - if {$opts(all) || $opts(sid)} { - lappend result -sid $sid - } - if {$opts(all) || $opts(name)} { - lappend result -name $name - } - if {$opts(all) || $opts(comment)} { - lappend result -comment $comment - } - if {$opts(all) || $opts(attributes)} { - lappend result -attributes [map_token_group_attr $attributes] - } - } - - if {$opts(all) || $opts(members)} { - lappend result -members [get_global_group_members $grpname -system $opts(system)] - } - - return $result -} - -# Get info about a local or global group -proc twapi::get_local_group_info {name args} { - array set opts [parseargs args { - {system.arg ""} - comment - name - members - sid - all - } -maxleftover 0] - - set result [list ] - if {$opts(all) || $opts(sid)} { - lappend result -sid [lookup_account_name $name -system $opts(system)] - } - if {$opts(all) || $opts(comment) || $opts(name)} { - lassign [NetLocalGroupGetInfo $opts(system) $name 1] name comment - if {$opts(all) || $opts(name)} { - lappend result -name $name - } - if {$opts(all) || $opts(comment)} { - lappend result -comment $comment - } - } - if {$opts(all) || $opts(members)} { - lappend result -members [get_local_group_members $name -system $opts(system)] - } - return $result -} - -# Get list of users on a system -proc twapi::get_users {args} { - parseargs args { - level.int - } -setvars -ignoreunknown - - # TBD -allow user to specify filter - lappend args -filter 0 - if {[info exists level]} { - lappend args -level $level -fields [USER_INFO_$level] - } - return [_net_enum_helper NetUserEnum $args] -} - -proc twapi::get_global_groups {args} { - parseargs args { - level.int - } -setvars -ignoreunknown - - # TBD - level 3 returns an ERROR_INVALID_LEVEL even though - # MSDN says its valid for NetGroupEnum - - if {[info exists level]} { - lappend args -level $level -fields [GROUP_INFO_$level] - } - return [_net_enum_helper NetGroupEnum $args] -} - -proc twapi::get_local_groups {args} { - parseargs args { - level.int - } -setvars -ignoreunknown - - if {[info exists level]} { - lappend args -level $level -fields [dict get {0 {-name} 1 {-name -comment}} $level] - } - return [_net_enum_helper NetLocalGroupEnum $args] -} - -# Create a new global group -proc twapi::new_global_group {grpname args} { - array set opts [parseargs args { - system.arg - comment.arg - } -nulldefault] - - NetGroupAdd $opts(system) $grpname $opts(comment) -} - -# Create a new local group -proc twapi::new_local_group {grpname args} { - array set opts [parseargs args { - system.arg - comment.arg - } -nulldefault] - - NetLocalGroupAdd $opts(system) $grpname $opts(comment) -} - - -# Delete a global group -proc twapi::delete_global_group {grpname args} { - array set opts [parseargs args {system.arg} -nulldefault] - - # Remove the group from the LSA rights database. - _delete_rights $grpname $opts(system) - - NetGroupDel $opts(system) $grpname -} - -# Delete a local group -proc twapi::delete_local_group {grpname args} { - array set opts [parseargs args {system.arg} -nulldefault] - - # Remove the group from the LSA rights database. - _delete_rights $grpname $opts(system) - - NetLocalGroupDel $opts(system) $grpname -} - - -# Enumerate members of a global group -proc twapi::get_global_group_members {grpname args} { - parseargs args { - level.int - } -setvars -ignoreunknown - - if {[info exists level]} { - lappend args -level $level -fields [dict! {0 {-name} 1 {-name -attributes}} $level] - } - - lappend args -preargs [list $grpname] -namelevel 1 - return [_net_enum_helper NetGroupGetUsers $args] -} - -# Enumerate members of a local group -proc twapi::get_local_group_members {grpname args} { - parseargs args { - level.int - } -setvars -ignoreunknown - - if {[info exists level]} { - lappend args -level $level -fields [dict! {0 {-sid} 1 {-sid -sidusage -name} 2 {-sid -sidusage -domainandname} 3 {-domainandname}} $level] - } - - lappend args -preargs [list $grpname] -namelevel 1 -namefield 2 - return [_net_enum_helper NetLocalGroupGetMembers $args] -} - -# Add a user to a global group -proc twapi::add_user_to_global_group {grpname username args} { - array set opts [parseargs args {system.arg} -nulldefault] - - # No error if already member of the group - trap { - NetGroupAddUser $opts(system) $grpname $username - } onerror {TWAPI_WIN32 1320} { - # Ignore - } -} - - -# Remove a user from a global group -proc twapi::remove_user_from_global_group {grpname username args} { - array set opts [parseargs args {system.arg} -nulldefault] - - trap { - NetGroupDelUser $opts(system) $grpname $username - } onerror {TWAPI_WIN32 1321} { - # Was not in group - ignore - } -} - - -# Add a user to a local group -proc twapi::add_member_to_local_group {grpname username args} { - array set opts [parseargs args { - system.arg - {type.arg name} - } -nulldefault] - - # No error if already member of the group - trap { - Twapi_NetLocalGroupMembers 0 $opts(system) $grpname [expr {$opts(type) eq "sid" ? 0 : 3}] [list $username] - } onerror {TWAPI_WIN32 1378} { - # Ignore - } -} - -proc twapi::add_members_to_local_group {grpname accts args} { - array set opts [parseargs args { - system.arg - {type.arg name} - } -nulldefault] - - Twapi_NetLocalGroupMembers 0 $opts(system) $grpname [expr {$opts(type) eq "sid" ? 0 : 3}] $accts -} - - -# Remove a user from a local group -proc twapi::remove_member_from_local_group {grpname username args} { - array set opts [parseargs args { - system.arg - {type.arg name} - } -nulldefault] - - trap { - Twapi_NetLocalGroupMembers 1 $opts(system) $grpname [expr {$opts(type) eq "sid" ? 0 : 3}] [list $username] - } onerror {TWAPI_WIN32 1377} { - # Was not in group - ignore - } -} - -proc twapi::remove_members_from_local_group {grpname accts args} { - array set opts [parseargs args { - system.arg - {type.arg name} - } -nulldefault] - - Twapi_NetLocalGroupMembers 1 $opts(system) $grpname [expr {$opts(type) eq "sid" ? 0 : 3}] $accts -} - - -# Get rights for an account -proc twapi::get_account_rights {account args} { - array set opts [parseargs args { - {system.arg ""} - } -maxleftover 0] - - set sid [map_account_to_sid $account -system $opts(system)] - - trap { - set lsah [get_lsa_policy_handle -system $opts(system) -access policy_lookup_names] - return [Twapi_LsaEnumerateAccountRights $lsah $sid] - } onerror {TWAPI_WIN32 2} { - # No specific rights for this account - return [list ] - } finally { - if {[info exists lsah]} { - close_lsa_policy_handle $lsah - } - } -} - -# Get accounts having a specific right -proc twapi::find_accounts_with_right {right args} { - array set opts [parseargs args { - {system.arg ""} - name - } -maxleftover 0] - - trap { - set lsah [get_lsa_policy_handle \ - -system $opts(system) \ - -access { - policy_lookup_names - policy_view_local_information - }] - set accounts [list ] - foreach sid [Twapi_LsaEnumerateAccountsWithUserRight $lsah $right] { - if {$opts(name)} { - if {[catch {lappend accounts [lookup_account_sid $sid -system $opts(system)]}]} { - # No mapping for SID - can happen if account has been - # deleted but LSA policy not updated accordingly - lappend accounts $sid - } - } else { - lappend accounts $sid - } - } - return $accounts - } onerror {TWAPI_WIN32 259} { - # No accounts have this right - return [list ] - } finally { - if {[info exists lsah]} { - close_lsa_policy_handle $lsah - } - } - -} - -# Add/remove rights to an account -proc twapi::_modify_account_rights {operation account rights args} { - set switches { - system.arg - handle.arg - } - - switch -exact -- $operation { - add { - # Nothing to do - } - remove { - lappend switches all - } - default { - error "Invalid operation '$operation' specified" - } - } - - array set opts [parseargs args $switches -maxleftover 0] - - if {[info exists opts(system)] && [info exists opts(handle)]} { - error "Options -system and -handle may not be specified together" - } - - if {[info exists opts(handle)]} { - set lsah $opts(handle) - set sid $account - } else { - if {![info exists opts(system)]} { - set opts(system) "" - } - - set sid [map_account_to_sid $account -system $opts(system)] - # We need to open a policy handle ourselves. First try to open - # with max privileges in case the account needs to be created - # and then retry with lower privileges if that fails - catch { - set lsah [get_lsa_policy_handle \ - -system $opts(system) \ - -access { - policy_lookup_names - policy_create_account - }] - } - if {![info exists lsah]} { - set lsah [get_lsa_policy_handle \ - -system $opts(system) \ - -access policy_lookup_names] - } - } - - trap { - if {$operation == "add"} { - LsaAddAccountRights $lsah $sid $rights - } else { - LsaRemoveAccountRights $lsah $sid $opts(all) $rights - } - } finally { - # Close the handle if we opened it - if {! [info exists opts(handle)]} { - close_lsa_policy_handle $lsah - } - } -} - -interp alias {} twapi::add_account_rights {} twapi::_modify_account_rights add -interp alias {} twapi::remove_account_rights {} twapi::_modify_account_rights remove - -# Return list of logon sesionss -proc twapi::find_logon_sessions {args} { - array set opts [parseargs args { - user.arg - type.arg - tssession.arg - } -maxleftover 0] - - set luids [LsaEnumerateLogonSessions] - if {! ([info exists opts(user)] || [info exists opts(type)] || - [info exists opts(tssession)])} { - return $luids - } - - - # Need to get the data for each session to see if it matches - set result [list ] - if {[info exists opts(user)]} { - set sid [map_account_to_sid $opts(user)] - } - if {[info exists opts(type)]} { - set logontypes [list ] - foreach logontype $opts(type) { - lappend logontypes [_logon_session_type_code $logontype] - } - } - - foreach luid $luids { - trap { - unset -nocomplain session - array set session [LsaGetLogonSessionData $luid] - - # For the local system account, no data is returned on some - # platforms - if {[array size session] == 0} { - set session(Sid) S-1-5-18; # SYSTEM - set session(Session) 0 - set session(LogonType) 0 - } - if {[info exists opts(user)] && $session(Sid) ne $sid} { - continue; # User id does not match - } - - if {[info exists opts(type)] && [lsearch -exact $logontypes $session(LogonType)] < 0} { - continue; # Type does not match - } - - if {[info exists opts(tssession)] && $session(Session) != $opts(tssession)} { - continue; # Term server session does not match - } - - lappend result $luid - - } onerror {TWAPI_WIN32 1312} { - # Session no longer exists. Just skip - continue - } - } - - return $result -} - - -# Return data for a logon session -proc twapi::get_logon_session_info {luid args} { - array set opts [parseargs args { - all - authpackage - dnsdomain - logondomain - logonid - logonserver - logontime - type - usersid - user - tssession - userprincipal - } -maxleftover 0] - - array set session [LsaGetLogonSessionData $luid] - - # Some fields may be missing on Win2K - foreach fld {LogonServer DnsDomainName Upn} { - if {![info exists session($fld)]} { - set session($fld) "" - } - } - - array set result [list ] - foreach {opt index} { - authpackage AuthenticationPackage - dnsdomain DnsDomainName - logondomain LogonDomain - logonid LogonId - logonserver LogonServer - logontime LogonTime - type LogonType - usersid Sid - user UserName - tssession Session - userprincipal Upn - } { - if {$opts(all) || $opts($opt)} { - set result(-$opt) $session($index) - } - } - - if {[info exists result(-type)]} { - set result(-type) [_logon_session_type_symbol $result(-type)] - } - - return [array get result] -} - - - - -# Set/reset the given bits in the usri3_flags field for a user account -# mask indicates the mask of bits to set. values indicates the values -# of those bits -proc twapi::_change_user_info_flags {username mask values args} { - array set opts [parseargs args { - system.arg - } -nulldefault -maxleftover 0] - - # Get current flags - set flags [USER_INFO_1 -flags [NetUserGetInfo $opts(system) $username 1]] - - # Turn off mask bits and write flags back - set flags [expr {$flags & (~ $mask)}] - # Set the specified bits - set flags [expr {$flags | ($values & $mask)}] - - # Write new flags back - Twapi_NetUserSetInfo 1008 $opts(system) $username $flags -} - -# Returns the logon session type value for a symbol -twapi::proc* twapi::_logon_session_type_code {type} { - variable _logon_session_type_map - # Variable that maps logon session type codes to integer values - # Position of each symbol gives its corresponding type value - # See ntsecapi.h for definitions - set _logon_session_type_map { - 0 - 1 - interactive - network - batch - service - proxy - unlockworkstation - networkclear - newcredentials - remoteinteractive - cachedinteractive - cachedremoteinteractive - cachedunlockworkstation - } -} { - variable _logon_session_type_map - - # Type may be an integer or a token - set code [lsearch -exact $_logon_session_type_map $type] - if {$code >= 0} { - return $code - } - - if {![string is integer -strict $type]} { - badargs! "Invalid logon session type '$type' specified" 3 - } - return $type -} - -# Returns the logon session type symbol for an integer value -proc twapi::_logon_session_type_symbol {code} { - variable _logon_session_type_map - _logon_session_type_code interactive; # Just to init _logon_session_type_map - set symbol [lindex $_logon_session_type_map $code] - if {$symbol eq ""} { - return $code - } else { - return $symbol - } -} - -proc twapi::_set_user_priv_level {username priv_level args} { - - array set opts [parseargs args {system.arg} -nulldefault] - - if {0} { - # FOr some reason NetUserSetInfo cannot change priv level - # Tried it separately with a simple C program. So this code - # is commented out and we use group membership to achieve - # the desired result - # Note: - latest MSDN confirms above - if {![info exists twapi::priv_level_map($priv_level)]} { - error "Invalid privilege level value '$priv_level' specified. Must be one of [join [array names twapi::priv_level_map] ,]" - } - set priv $twapi::priv_level_map($priv_level) - - Twapi_NetUserSetInfo_priv $opts(system) $username $priv - } else { - # Don't hardcode group names - reverse map SID's instead for - # non-English systems. Also note that since - # we might be lowering privilege level, we have to also - # remove from higher privileged groups - - switch -exact -- $priv_level { - guest { - # administrators users - set outgroups {S-1-5-32-544 S-1-5-32-545} - # guests - set ingroup S-1-5-32-546 - } - user { - # administrators - set outgroups {S-1-5-32-544} - # users - set ingroup S-1-5-32-545 - } - admin { - set outgroups {} - set ingroup S-1-5-32-544 - } - default {error "Invalid privilege level '$priv_level'. Must be one of 'guest', 'user' or 'admin'"} - } - # Remove from higher priv groups - foreach outgroup $outgroups { - # Get the potentially localized name of the group - set group [lookup_account_sid $outgroup -system $opts(system)] - # Catch since may not be member of that group - catch {remove_member_from_local_group $group $username -system $opts(system)} - } - - # Get the potentially localized name of the group to be added - set group [lookup_account_sid $ingroup -system $opts(system)] - add_member_to_local_group $group $username -system $opts(system) - } -} - -proc twapi::_map_userinfo_flags {flags} { - # UF_LOCKOUT -> 0x10, UF_ACCOUNTDISABLE -> 0x2 - if {$flags & 0x2} { - set status disabled - } elseif {$flags & 0x10} { - set status locked - } else { - set status enabled - } - - #define UF_TEMP_DUPLICATE_ACCOUNT 0x0100 - #define UF_NORMAL_ACCOUNT 0x0200 - #define UF_INTERDOMAIN_TRUST_ACCOUNT 0x0800 - #define UF_WORKSTATION_TRUST_ACCOUNT 0x1000 - #define UF_SERVER_TRUST_ACCOUNT 0x2000 - if {$flags & 0x0200} { - set type normal - } elseif {$flags & 0x0100} { - set type duplicate - } elseif {$flags & 0x0800} { - set type interdomain_trust - } elseif {$flags & 0x1000} { - set type workstation_trust - } elseif {$flags & 0x2000} { - set type server_trust - } else { - set type unknown - } - - set pw {} - #define UF_PASSWD_NOTREQD 0x0020 - if {$flags & 0x0020} { - lappend pw not_required - } - #define UF_PASSWD_CANT_CHANGE 0x0040 - if {$flags & 0x0040} { - lappend pw cannot_change - } - #define UF_ENCRYPTED_TEXT_PASSWORD_ALLOWED 0x0080 - if {$flags & 0x0080} { - lappend pw encrypted_text_allowed - } - #define UF_DONT_EXPIRE_PASSWD 0x10000 - if {$flags & 0x10000} { - lappend pw no_expiry - } - #define UF_SMARTCARD_REQUIRED 0x40000 - if {$flags & 0x40000} { - lappend pw smartcard_required - } - #define UF_PASSWORD_EXPIRED 0x800000 - if {$flags & 0x800000} { - lappend pw expired - } - - return [list -status $status -type $type -password_attrs $pw] -} - -twapi::proc* twapi::_define_user_modals {} { - struct _USER_MODALS_INFO_0 { - DWORD min_passwd_len; - DWORD max_passwd_age; - DWORD min_passwd_age; - DWORD force_logoff; - DWORD password_hist_len; - } - struct _USER_MODALS_INFO_1 { - DWORD role; - LPWSTR primary; - } - struct _USER_MODALS_INFO_2 { - LPWSTR domain_name; - PSID domain_id; - } - struct _USER_MODALS_INFO_3 { - DWORD lockout_duration; - DWORD lockout_observation_window; - DWORD lockout_threshold; - } - struct _USER_MODALS_INFO_1001 { - DWORD min_passwd_len; - } - struct _USER_MODALS_INFO_1002 { - DWORD max_passwd_age; - } - struct _USER_MODALS_INFO_1003 { - DWORD min_passwd_age; - } - struct _USER_MODALS_INFO_1004 { - DWORD force_logoff; - } - struct _USER_MODALS_INFO_1005 { - DWORD password_hist_len; - } - struct _USER_MODALS_INFO_1006 { - DWORD role; - } - struct _USER_MODALS_INFO_1007 { - LPWSTR primary; - } -} { -} - -twapi::proc* twapi::get_password_policy {{server_name ""}} { - _define_user_modals -} { - set result [NetUserModalsGet $server_name 0 [_USER_MODALS_INFO_0]] - dict with result { - if {$force_logoff == 4294967295 || $force_logoff == -1} { - set force_logoff never - } - if {$max_passwd_age == 4294967295 || $max_passwd_age == -1} { - set max_passwd_age none - } - } - return $result -} - -# TBD - doc & test -twapi::proc* twapi::get_system_role {{server_name ""}} { - _define_user_modals -} { - set result [NetUserModalsGet $server_name 1 [_USER_MODALS_INFO_1]] - dict set result role [dict* { - 0 standalone 1 member 2 backup 3 primary - } [dict get $result role]] - return $result -} - -# TBD - doc & test -twapi::proc* twapi::get_system_domain {{server_name ""}} { - _define_user_modals -} { - return [NetUserModalsGet $server_name 2 [_USER_MODALS_INFO_2]] -} - -twapi::proc* twapi::get_lockout_policy {{server_name ""}} { - _define_user_modals -} { - return [NetUserModalsGet $server_name 3 [_USER_MODALS_INFO_3]] -} - -twapi::proc* twapi::set_password_policy {name val {server_name ""}} { - _define_user_modals -} { - switch -exact $name { - min_passwd_len { - NetUserModalsSet $server_name 1001 [_USER_MODALS_INFO_1001 $val] - } - max_passwd_age { - if {$val eq "none"} { - set val 4294967295 - } - NetUserModalsSet $server_name 1002 [_USER_MODALS_INFO_1002 $val] - } - min_passwd_age { - NetUserModalsSet $server_name 1003 [_USER_MODALS_INFO_1003 $val] - } - force_logoff { - if {$val eq "never"} { - set val 4294967295 - } - NetUserModalsSet $server_name 1004 [_USER_MODALS_INFO_1004 $val] - } - password_hist_len { - NetUserModalsSet $server_name 1005 [_USER_MODALS_INFO_1005 $val] - } - } -} - -twapi::proc* twapi::set_lockout_policy {duration observe_window threshold {server_name ""}} { - _define_user_modals -} { - NetUserModalsSet $server_name 3 [_USER_MODALS_INFO_3 $duration $observe_window $threshold] -} diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/adsi.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/adsi.tcl deleted file mode 100644 index 77dd5122..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/adsi.tcl +++ /dev/null @@ -1,28 +0,0 @@ -# -# 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] -} \ No newline at end of file diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/apputil.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/apputil.tcl deleted file mode 100644 index db008b66..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/apputil.tcl +++ /dev/null @@ -1,114 +0,0 @@ -# -# 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 - } -} - - - diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/base.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/base.tcl deleted file mode 100644 index b227d2c0..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/base.tcl +++ /dev/null @@ -1,1873 +0,0 @@ -# -# Copyright (c) 2012-2014, Ashok P. Nadkarni -# All rights reserved. -# -# See the file LICENSE for license - -# Commands in twapi_base module - -namespace eval twapi { - # Map of Sid integer type to Sid type name - array set sid_type_names { - 1 user - 2 group - 3 domain - 4 alias - 5 wellknowngroup - 6 deletedaccount - 7 invalid - 8 unknown - 9 computer - 10 label - 11 logonsession - } - - # Cache mapping account names to SIDs. Dict keyed by system and name - variable _name_to_sid_cache {} - - # Cache mapping SIDs to account names. Dict keyed by system and SID - variable _sid_to_name_cache {} - - # Dictionary of FFI libraries to handles and back - variable _ffi_paths {} - variable _ffi_handles {} -} - - - -# Return major minor servicepack as a quad list -proc twapi::get_os_version {} { - array set verinfo [GetVersionEx] - return [list $verinfo(dwMajorVersion) $verinfo(dwMinorVersion) \ - $verinfo(wServicePackMajor) $verinfo(wServicePackMinor)] -} - -# Returns true if the OS version is at least $major.$minor.$sp -proc twapi::min_os_version {major {minor 0} {spmajor 0} {spminor 0}} { - lassign [twapi::get_os_version] osmajor osminor osspmajor osspminor - - if {$osmajor > $major} {return 1} - if {$osmajor < $major} {return 0} - if {$osminor > $minor} {return 1} - if {$osminor < $minor} {return 0} - if {$osspmajor > $spmajor} {return 1} - if {$osspmajor < $spmajor} {return 0} - if {$osspminor > $spminor} {return 1} - if {$osspminor < $spminor} {return 0} - - # Same version, ok - return 1 -} - -# Convert a LARGE_INTEGER time value (100ns since 1601) to a formatted date -# time -interp alias {} twapi::large_system_time_to_secs {} twapi::large_system_time_to_secs_since_1970 -proc twapi::large_system_time_to_secs_since_1970 {ns100 {fraction false}} { - # No. 100ns units between 1601 to 1970 = 116444736000000000 - set ns100_since_1970 [expr {$ns100-116444736000000000}] - - set secs_since_1970 [expr {$ns100_since_1970/10000000}] - if {$fraction} { - append secs_since_1970 .[string range $ns100 end-6 end] - } - return $secs_since_1970 -} - -proc twapi::secs_since_1970_to_large_system_time {secs} { - # No. 100ns units between 1601 to 1970 = 116444736000000000 - return [expr {($secs * 10000000) + 116444736000000000}] -} - -# Map a Windows error code to a string -proc twapi::map_windows_error {code} { - # Trim trailing CR/LF - return [string trimright [twapi::Twapi_MapWindowsErrorToString $code] "\r\n"] -} - -# Load given library -proc twapi::load_library {path args} { - array set opts [parseargs args { - dontresolverefs - datafile - alteredpath - }] - - set flags 0 - if {$opts(dontresolverefs)} { - setbits flags 1; # DONT_RESOLVE_DLL_REFERENCES - } - if {$opts(datafile)} { - setbits flags 2; # LOAD_LIBRARY_AS_DATAFILE - } - if {$opts(alteredpath)} { - setbits flags 8; # LOAD_WITH_ALTERED_SEARCH_PATH - } - - # LoadLibrary always wants backslashes - set path [file nativename $path] - return [LoadLibraryEx $path $flags] -} - -# Free library opened with load_library -proc twapi::free_library {libh} { - FreeLibrary $libh -} - -# Format message string - will raise exception if insufficient number -# of arguments -proc twapi::_unsafe_format_message {args} { - array set opts [parseargs args { - module.arg - fmtstring.arg - messageid.arg - langid.arg - params.arg - includesystem - ignoreinserts - width.int - } -nulldefault -maxleftover 0] - - set flags 0 - - if {$opts(module) == ""} { - if {$opts(fmtstring) == ""} { - # If neither -module nor -fmtstring specified, message is formatted - # from the system - set opts(module) NULL - setbits flags 0x1000; # FORMAT_MESSAGE_FROM_SYSTEM - } else { - setbits flags 0x400; # FORMAT_MESSAGE_FROM_STRING - if {$opts(includesystem) || $opts(messageid) != "" || $opts(langid) != ""} { - error "Options -includesystem, -messageid and -langid cannot be used with -fmtstring" - } - } - } else { - if {$opts(fmtstring) != ""} { - error "Options -fmtstring and -module cannot be used together" - } - setbits flags 0x800; # FORMAT_MESSAGE_FROM_HMODULE - if {$opts(includesystem)} { - # Also include system in search - setbits flags 0x1000; # FORMAT_MESSAGE_FROM_SYSTEM - } - } - - if {$opts(ignoreinserts)} { - setbits flags 0x200; # FORMAT_MESSAGE_IGNORE_INSERTS - } - - if {$opts(width) > 254} { - error "Invalid value for option -width. Must be -1, 0, or a positive integer less than 255" - } - if {$opts(width) < 0} { - # Negative width means no width restrictions - set opts(width) 255; # 255 -> no restrictions - } - incr flags $opts(width); # Width goes in low byte of flags - - if {$opts(fmtstring) != ""} { - return [FormatMessageFromString $flags $opts(fmtstring) $opts(params)] - } else { - if {![string is integer -strict $opts(messageid)]} { - error "Unspecified or invalid value for -messageid option. Must be an integer value" - } - if {$opts(langid) == ""} { set opts(langid) 0 } - if {![string is integer -strict $opts(langid)]} { - error "Unspecfied or invalid value for -langid option. Must be an integer value" - } - - # Check if $opts(module) is a file or module handle (pointer) - if {[pointer? $opts(module)]} { - return [FormatMessageFromModule $flags $opts(module) \ - $opts(messageid) $opts(langid) $opts(params)] - } else { - set hmod [load_library $opts(module) -datafile] - trap { - set message [FormatMessageFromModule $flags $hmod \ - $opts(messageid) $opts(langid) $opts(params)] - } finally { - free_library $hmod - } - return $message - } - } -} - -# Format message string -proc twapi::format_message {args} { - array set opts [parseargs args { - params.arg - fmtstring.arg - width.int - ignoreinserts - } -ignoreunknown] - - # TBD - document - if no params specified, different from params = {} - - # If a format string is specified, other options do not matter - # except for -width. In that case, we do not call FormatMessage - # at all - if {[info exists opts(fmtstring)]} { - # If -width specifed, call FormatMessage - if {[info exists opts(width)] && $opts(width)} { - set msg [_unsafe_format_message -ignoreinserts -fmtstring $opts(fmtstring) -width $opts(width) {*}$args] - } else { - set msg $opts(fmtstring) - } - } else { - # Not -fmtstring, retrieve from message file - if {[info exists opts(width)]} { - set msg [_unsafe_format_message -ignoreinserts -width $opts(width) {*}$args] - } else { - set msg [_unsafe_format_message -ignoreinserts {*}$args] - } - } - - # If we are told to ignore inserts, all done. Else replace them except - # that if no param list, do not replace placeholder. This is NOT - # the same as empty param list - if {$opts(ignoreinserts) || ![info exists opts(params)]} { - return $msg - } - - # TBD - cache fmtstring -> indices for performance - set placeholder_indices [regexp -indices -all -inline {%(?:.|(?:[1-9][0-9]?(?:![^!]+!)?))} $msg] - - if {[llength $placeholder_indices] == 0} { - # No placeholders. - return $msg - } - - # Use of * in format specifiers will change where the actual parameters - # are positioned - set num_asterisks 0 - set msg2 "" - 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 spec [string range $msg $start+1 $end] - switch -exact -- [string index $spec 0] { - % { append msg2 % } - r { append msg2 \r } - n { append msg2 \n } - t { append msg2 \t } - 0 { - # No-op - %0 means to not add trailing newline - } - default { - if {! [string is integer -strict [string index $spec 0]]} { - # Not a insert parameter. Just append the character - append msg2 $spec - } else { - # Insert parameter - set fmt "" - scan $spec %d%s param_index fmt - # Note params are numbered starting with 1 - incr param_index -1 - # Format spec, if present, is enclosed in !. Get rid of them - set fmt [string trim $fmt "!"] - if {$fmt eq ""} { - # No fmt spec - } else { - # Since everything is a string in Tcl, we happily - # do not have to worry about type. However, the - # format spec could have * specifiers which will - # change the parameter indexing for subsequent - # arguments - incr num_asterisks [expr {[llength [split $fmt *]]-1}] - incr param_index $num_asterisks - } - # TBD - we ignore the actual format type - append msg2 [lindex $opts(params) $param_index] - } - } - } - set prev_end [incr end] - } - append msg2 [string range $msg $prev_end end] - return $msg2 -} - -# Revert to process token. In base package because used across many modules -proc twapi::revert_to_self {{opt ""}} { - RevertToSelf -} - -# For backward compatibility -interp alias {} twapi::expand_environment_strings {} twapi::expand_environment_vars - -proc twapi::_init_security_defs {} { - variable security_defs - - # NOTE : the access definitions for those types that are included here - # have been updated as of Windows 8. - array set security_defs { - - TOKEN_ASSIGN_PRIMARY 0x00000001 - TOKEN_DUPLICATE 0x00000002 - TOKEN_IMPERSONATE 0x00000004 - TOKEN_QUERY 0x00000008 - TOKEN_QUERY_SOURCE 0x00000010 - TOKEN_ADJUST_PRIVILEGES 0x00000020 - TOKEN_ADJUST_GROUPS 0x00000040 - TOKEN_ADJUST_DEFAULT 0x00000080 - TOKEN_ADJUST_SESSIONID 0x00000100 - - TOKEN_ALL_ACCESS_WINNT 0x000F00FF - TOKEN_ALL_ACCESS_WIN2K 0x000F01FF - TOKEN_ALL_ACCESS 0x000F01FF - TOKEN_READ 0x00020008 - TOKEN_WRITE 0x000200E0 - TOKEN_EXECUTE 0x00020000 - - SYSTEM_MANDATORY_LABEL_NO_WRITE_UP 0x1 - SYSTEM_MANDATORY_LABEL_NO_READ_UP 0x2 - SYSTEM_MANDATORY_LABEL_NO_EXECUTE_UP 0x4 - - ACL_REVISION 2 - ACL_REVISION_DS 4 - - ACCESS_MAX_MS_V2_ACE_TYPE 0x3 - ACCESS_MAX_MS_V3_ACE_TYPE 0x4 - ACCESS_MAX_MS_V4_ACE_TYPE 0x8 - ACCESS_MAX_MS_V5_ACE_TYPE 0x11 - - STANDARD_RIGHTS_REQUIRED 0x000F0000 - STANDARD_RIGHTS_READ 0x00020000 - STANDARD_RIGHTS_WRITE 0x00020000 - STANDARD_RIGHTS_EXECUTE 0x00020000 - STANDARD_RIGHTS_ALL 0x001F0000 - SPECIFIC_RIGHTS_ALL 0x0000FFFF - - GENERIC_READ 0x80000000 - GENERIC_WRITE 0x40000000 - GENERIC_EXECUTE 0x20000000 - GENERIC_ALL 0x10000000 - - SERVICE_QUERY_CONFIG 0x00000001 - SERVICE_CHANGE_CONFIG 0x00000002 - SERVICE_QUERY_STATUS 0x00000004 - SERVICE_ENUMERATE_DEPENDENTS 0x00000008 - SERVICE_START 0x00000010 - SERVICE_STOP 0x00000020 - SERVICE_PAUSE_CONTINUE 0x00000040 - SERVICE_INTERROGATE 0x00000080 - SERVICE_USER_DEFINED_CONTROL 0x00000100 - SERVICE_ALL_ACCESS 0x000F01FF - - SC_MANAGER_CONNECT 0x00000001 - SC_MANAGER_CREATE_SERVICE 0x00000002 - SC_MANAGER_ENUMERATE_SERVICE 0x00000004 - SC_MANAGER_LOCK 0x00000008 - SC_MANAGER_QUERY_LOCK_STATUS 0x00000010 - SC_MANAGER_MODIFY_BOOT_CONFIG 0x00000020 - SC_MANAGER_ALL_ACCESS 0x000F003F - - KEY_QUERY_VALUE 0x00000001 - KEY_SET_VALUE 0x00000002 - KEY_CREATE_SUB_KEY 0x00000004 - KEY_ENUMERATE_SUB_KEYS 0x00000008 - KEY_NOTIFY 0x00000010 - KEY_CREATE_LINK 0x00000020 - KEY_WOW64_32KEY 0x00000200 - KEY_WOW64_64KEY 0x00000100 - KEY_WOW64_RES 0x00000300 - KEY_READ 0x00020019 - KEY_WRITE 0x00020006 - KEY_EXECUTE 0x00020019 - KEY_ALL_ACCESS 0x000F003F - - POLICY_VIEW_LOCAL_INFORMATION 0x00000001 - POLICY_VIEW_AUDIT_INFORMATION 0x00000002 - POLICY_GET_PRIVATE_INFORMATION 0x00000004 - POLICY_TRUST_ADMIN 0x00000008 - POLICY_CREATE_ACCOUNT 0x00000010 - POLICY_CREATE_SECRET 0x00000020 - POLICY_CREATE_PRIVILEGE 0x00000040 - POLICY_SET_DEFAULT_QUOTA_LIMITS 0x00000080 - POLICY_SET_AUDIT_REQUIREMENTS 0x00000100 - POLICY_AUDIT_LOG_ADMIN 0x00000200 - POLICY_SERVER_ADMIN 0x00000400 - POLICY_LOOKUP_NAMES 0x00000800 - POLICY_NOTIFICATION 0x00001000 - POLICY_READ 0X00020006 - POLICY_WRITE 0X000207F8 - POLICY_EXECUTE 0X00020801 - POLICY_ALL_ACCESS 0X000F0FFF - - DESKTOP_READOBJECTS 0x0001 - DESKTOP_CREATEWINDOW 0x0002 - DESKTOP_CREATEMENU 0x0004 - DESKTOP_HOOKCONTROL 0x0008 - DESKTOP_JOURNALRECORD 0x0010 - DESKTOP_JOURNALPLAYBACK 0x0020 - DESKTOP_ENUMERATE 0x0040 - DESKTOP_WRITEOBJECTS 0x0080 - DESKTOP_SWITCHDESKTOP 0x0100 - - WINSTA_ENUMDESKTOPS 0x0001 - WINSTA_READATTRIBUTES 0x0002 - WINSTA_ACCESSCLIPBOARD 0x0004 - WINSTA_CREATEDESKTOP 0x0008 - WINSTA_WRITEATTRIBUTES 0x0010 - WINSTA_ACCESSGLOBALATOMS 0x0020 - WINSTA_EXITWINDOWS 0x0040 - WINSTA_ENUMERATE 0x0100 - WINSTA_READSCREEN 0x0200 - WINSTA_ALL_ACCESS 0x37f - - PROCESS_TERMINATE 0x0001 - PROCESS_CREATE_THREAD 0x0002 - PROCESS_SET_SESSIONID 0x0004 - PROCESS_VM_OPERATION 0x0008 - PROCESS_VM_READ 0x0010 - PROCESS_VM_WRITE 0x0020 - PROCESS_DUP_HANDLE 0x0040 - PROCESS_CREATE_PROCESS 0x0080 - PROCESS_SET_QUOTA 0x0100 - PROCESS_SET_INFORMATION 0x0200 - PROCESS_QUERY_INFORMATION 0x0400 - PROCESS_SUSPEND_RESUME 0x0800 - - THREAD_TERMINATE 0x00000001 - THREAD_SUSPEND_RESUME 0x00000002 - THREAD_GET_CONTEXT 0x00000008 - THREAD_SET_CONTEXT 0x00000010 - THREAD_SET_INFORMATION 0x00000020 - THREAD_QUERY_INFORMATION 0x00000040 - THREAD_SET_THREAD_TOKEN 0x00000080 - THREAD_IMPERSONATE 0x00000100 - THREAD_DIRECT_IMPERSONATION 0x00000200 - THREAD_SET_LIMITED_INFORMATION 0x00000400 - THREAD_QUERY_LIMITED_INFORMATION 0x00000800 - - EVENT_MODIFY_STATE 0x00000002 - EVENT_ALL_ACCESS 0x001F0003 - - SEMAPHORE_MODIFY_STATE 0x00000002 - SEMAPHORE_ALL_ACCESS 0x001F0003 - - MUTANT_QUERY_STATE 0x00000001 - MUTANT_ALL_ACCESS 0x001F0001 - - MUTEX_MODIFY_STATE 0x00000001 - MUTEX_ALL_ACCESS 0x001F0001 - - TIMER_QUERY_STATE 0x00000001 - TIMER_MODIFY_STATE 0x00000002 - TIMER_ALL_ACCESS 0x001F0003 - - FILE_READ_DATA 0x00000001 - FILE_LIST_DIRECTORY 0x00000001 - FILE_WRITE_DATA 0x00000002 - FILE_ADD_FILE 0x00000002 - FILE_APPEND_DATA 0x00000004 - FILE_ADD_SUBDIRECTORY 0x00000004 - FILE_CREATE_PIPE_INSTANCE 0x00000004 - FILE_READ_EA 0x00000008 - FILE_WRITE_EA 0x00000010 - FILE_EXECUTE 0x00000020 - FILE_TRAVERSE 0x00000020 - FILE_DELETE_CHILD 0x00000040 - FILE_READ_ATTRIBUTES 0x00000080 - FILE_WRITE_ATTRIBUTES 0x00000100 - - FILE_ALL_ACCESS 0x001F01FF - FILE_GENERIC_READ 0x00120089 - FILE_GENERIC_WRITE 0x00120116 - FILE_GENERIC_EXECUTE 0x001200A0 - - DELETE 0x00010000 - READ_CONTROL 0x00020000 - WRITE_DAC 0x00040000 - WRITE_OWNER 0x00080000 - SYNCHRONIZE 0x00100000 - - MAXIMUM_ALLOWED 0x02000000 - - COM_RIGHTS_EXECUTE 1 - COM_RIGHTS_EXECUTE_LOCAL 2 - COM_RIGHTS_EXECUTE_REMOTE 4 - COM_RIGHTS_ACTIVATE_LOCAL 8 - COM_RIGHTS_ACTIVATE_REMOTE 16 - } - - if {[min_os_version 6]} { - array set security_defs { - PROCESS_QUERY_LIMITED_INFORMATION 0x00001000 - PROCESS_ALL_ACCESS 0x001fffff - THREAD_ALL_ACCESS 0x001fffff - } - } else { - array set security_defs { - PROCESS_ALL_ACCESS 0x001f0fff - THREAD_ALL_ACCESS 0x001f03ff - } - } - - # Make next call a no-op - proc _init_security_defs {} {} -} - -# Map a set of access right symbols to a flag. Concatenates -# all the arguments, and then OR's the individual elements. Each -# element may either be a integer or one of the access rights -proc twapi::_access_rights_to_mask {args} { - _init_security_defs - - proc _access_rights_to_mask args { - variable security_defs - set rights 0 - foreach right [concat {*}$args] { - # The mandatory label access rights are not in security_defs - # because we do not want them to mess up the int->name mapping - # for DACL's - set right [dict* { - no_write_up 1 - system_mandatory_label_no_write_up 1 - no_read_up 2 - system_mandatory_label_no_read_up 2 - no_execute_up 4 - system_mandatory_label_no_execute_up 4 - } $right] - if {![string is integer $right]} { - if {[catch {set right $security_defs([string toupper $right])}]} { - error "Invalid access right symbol '$right'" - } - } - set rights [expr {$rights | $right}] - } - return $rights - } - return [_access_rights_to_mask {*}$args] -} - - -# Map an access mask to a set of rights -proc twapi::_access_mask_to_rights {access_mask {type ""}} { - _init_security_defs - - proc _access_mask_to_rights {access_mask {type ""}} { - variable security_defs - - set rights [list ] - - if {$type eq "mandatory_label"} { - if {$access_mask & 1} { - lappend rights system_mandatory_label_no_write_up - } - if {$access_mask & 2} { - lappend rights system_mandatory_label_no_read_up - } - if {$access_mask & 4} { - lappend rights system_mandatory_label_no_execute_up - } - return $rights - } - - # The returned list will include rights that map to multiple bits - # as well as the individual bits. We first add the multiple bits - # and then the individual bits (since we clear individual bits - # after adding) - - # - # Check standard multiple bit masks - # - foreach x {STANDARD_RIGHTS_REQUIRED STANDARD_RIGHTS_READ STANDARD_RIGHTS_WRITE STANDARD_RIGHTS_EXECUTE STANDARD_RIGHTS_ALL SPECIFIC_RIGHTS_ALL} { - if {($security_defs($x) & $access_mask) == $security_defs($x)} { - lappend rights [string tolower $x] - } - } - - # - # Check type specific multiple bit masks. - # - - set type_mask_map { - file {FILE_ALL_ACCESS FILE_GENERIC_READ FILE_GENERIC_WRITE FILE_GENERIC_EXECUTE} - process {PROCESS_ALL_ACCESS} - pipe {FILE_ALL_ACCESS} - policy {POLICY_READ POLICY_WRITE POLICY_EXECUTE POLICY_ALL_ACCESS} - registry {KEY_READ KEY_WRITE KEY_EXECUTE KEY_ALL_ACCESS} - service {SERVICE_ALL_ACCESS} - thread {THREAD_ALL_ACCESS} - token {TOKEN_READ TOKEN_WRITE TOKEN_EXECUTE TOKEN_ALL_ACCESS} - desktop {} - winsta {WINSTA_ALL_ACCESS} - } - if {[dict exists $type_mask_map $type]} { - foreach x [dict get $type_mask_map $type] { - if {($security_defs($x) & $access_mask) == $security_defs($x)} { - lappend rights [string tolower $x] - } - } - } - - # - # OK, now map individual bits - - # First map the common bits - foreach x {DELETE READ_CONTROL WRITE_DAC WRITE_OWNER SYNCHRONIZE} { - if {$security_defs($x) & $access_mask} { - lappend rights [string tolower $x] - resetbits access_mask $security_defs($x) - } - } - - # Then the generic bits - foreach x {GENERIC_READ GENERIC_WRITE GENERIC_EXECUTE GENERIC_ALL} { - if {$security_defs($x) & $access_mask} { - lappend rights [string tolower $x] - resetbits access_mask $security_defs($x) - } - } - - # Then the type specific - set type_mask_map { - file { FILE_READ_DATA FILE_WRITE_DATA FILE_APPEND_DATA - FILE_READ_EA FILE_WRITE_EA FILE_EXECUTE - FILE_DELETE_CHILD FILE_READ_ATTRIBUTES - FILE_WRITE_ATTRIBUTES } - pipe { FILE_READ_DATA FILE_WRITE_DATA FILE_CREATE_PIPE_INSTANCE - FILE_READ_ATTRIBUTES FILE_WRITE_ATTRIBUTES } - service { SERVICE_QUERY_CONFIG SERVICE_CHANGE_CONFIG - SERVICE_QUERY_STATUS SERVICE_ENUMERATE_DEPENDENTS - SERVICE_START SERVICE_STOP SERVICE_PAUSE_CONTINUE - SERVICE_INTERROGATE SERVICE_USER_DEFINED_CONTROL } - registry { KEY_QUERY_VALUE KEY_SET_VALUE KEY_CREATE_SUB_KEY - KEY_ENUMERATE_SUB_KEYS KEY_NOTIFY KEY_CREATE_LINK - KEY_WOW64_32KEY KEY_WOW64_64KEY KEY_WOW64_RES } - policy { POLICY_VIEW_LOCAL_INFORMATION POLICY_VIEW_AUDIT_INFORMATION - POLICY_GET_PRIVATE_INFORMATION POLICY_TRUST_ADMIN - POLICY_CREATE_ACCOUNT POLICY_CREATE_SECRET - POLICY_CREATE_PRIVILEGE POLICY_SET_DEFAULT_QUOTA_LIMITS - POLICY_SET_AUDIT_REQUIREMENTS POLICY_AUDIT_LOG_ADMIN - POLICY_SERVER_ADMIN POLICY_LOOKUP_NAMES } - process { PROCESS_TERMINATE PROCESS_CREATE_THREAD - PROCESS_SET_SESSIONID PROCESS_VM_OPERATION - PROCESS_VM_READ PROCESS_VM_WRITE PROCESS_DUP_HANDLE - PROCESS_CREATE_PROCESS PROCESS_SET_QUOTA - PROCESS_SET_INFORMATION PROCESS_QUERY_INFORMATION - PROCESS_SUSPEND_RESUME} - thread { THREAD_TERMINATE THREAD_SUSPEND_RESUME - THREAD_GET_CONTEXT THREAD_SET_CONTEXT - THREAD_SET_INFORMATION THREAD_QUERY_INFORMATION - THREAD_SET_THREAD_TOKEN THREAD_IMPERSONATE - THREAD_DIRECT_IMPERSONATION - THREAD_SET_LIMITED_INFORMATION - THREAD_QUERY_LIMITED_INFORMATION } - token { TOKEN_ASSIGN_PRIMARY TOKEN_DUPLICATE TOKEN_IMPERSONATE - TOKEN_QUERY TOKEN_QUERY_SOURCE TOKEN_ADJUST_PRIVILEGES - TOKEN_ADJUST_GROUPS TOKEN_ADJUST_DEFAULT TOKEN_ADJUST_SESSIONID } - desktop { DESKTOP_READOBJECTS DESKTOP_CREATEWINDOW - DESKTOP_CREATEMENU DESKTOP_HOOKCONTROL - DESKTOP_JOURNALRECORD DESKTOP_JOURNALPLAYBACK - DESKTOP_ENUMERATE DESKTOP_WRITEOBJECTS DESKTOP_SWITCHDESKTOP } - windowstation { WINSTA_ENUMDESKTOPS WINSTA_READATTRIBUTES - WINSTA_ACCESSCLIPBOARD WINSTA_CREATEDESKTOP - WINSTA_WRITEATTRIBUTES WINSTA_ACCESSGLOBALATOMS - WINSTA_EXITWINDOWS WINSTA_ENUMERATE WINSTA_READSCREEN } - winsta { WINSTA_ENUMDESKTOPS WINSTA_READATTRIBUTES - WINSTA_ACCESSCLIPBOARD WINSTA_CREATEDESKTOP - WINSTA_WRITEATTRIBUTES WINSTA_ACCESSGLOBALATOMS - WINSTA_EXITWINDOWS WINSTA_ENUMERATE WINSTA_READSCREEN } - com { COM_RIGHTS_EXECUTE COM_RIGHTS_EXECUTE_LOCAL - COM_RIGHTS_EXECUTE_REMOTE COM_RIGHTS_ACTIVATE_LOCAL - COM_RIGHTS_ACTIVATE_REMOTE - } - } - - if {[min_os_version 6]} { - dict lappend type_mask_map process PROCESS_QUERY_LIMITED_INFORMATION - } - - if {[dict exists $type_mask_map $type]} { - foreach x [dict get $type_mask_map $type] { - if {$security_defs($x) & $access_mask} { - lappend rights [string tolower $x] - # Reset the bit so is it not included in unknown bits below - resetbits access_mask $security_defs($x) - } - } - } - - # Finally add left over bits if any - for {set i 0} {$i < 32} {incr i} { - set x [expr {1 << $i}] - if {$access_mask & $x} { - lappend rights [hex32 $x] - } - } - - return $rights - } - - return [_access_mask_to_rights $access_mask $type] -} - -# Map the symbolic CreateDisposition parameter of CreateFile to integer values -proc twapi::_create_disposition_to_code {sym} { - if {[string is integer -strict $sym]} { - return $sym - } - # CREATE_NEW 1 - # CREATE_ALWAYS 2 - # OPEN_EXISTING 3 - # OPEN_ALWAYS 4 - # TRUNCATE_EXISTING 5 - return [dict get { - create_new 1 - create_always 2 - open_existing 3 - open_always 4 - truncate_existing 5} $sym] -} - -# Wrapper around CreateFile -proc twapi::create_file {path args} { - array set opts [parseargs args { - {access.arg {generic_read}} - {share.arg {read write delete}} - {inherit.bool 0} - {secd.arg ""} - {createdisposition.arg open_always} - {flags.int 0} - {templatefile.arg NULL} - } -maxleftover 0] - - set access_mode [_access_rights_to_mask $opts(access)] - set share_mode [_share_mode_to_mask $opts(share)] - set create_disposition [_create_disposition_to_code $opts(createdisposition)] - return [CreateFile $path \ - $access_mode \ - $share_mode \ - [_make_secattr $opts(secd) $opts(inherit)] \ - $create_disposition \ - $opts(flags) \ - $opts(templatefile)] -} - -# Map a set of share mode symbols to a flag. Concatenates -# all the arguments, and then OR's the individual elements. Each -# element may either be a integer or one of the share modes -proc twapi::_share_mode_to_mask {modelist} { - # Values correspond to FILE_SHARE_* defines - return [_parse_symbolic_bitmask $modelist {read 1 write 2 delete 4}] -} - -# Construct a security attributes structure out of a security descriptor -# and inheritance. The command is here because we do not want to -# have to load the twapi_security package for the common case of -# null security attributes. -proc twapi::_make_secattr {secd inherit} { - if {$inherit} { - set sec_attr [list $secd 1] - } else { - if {[llength $secd] == 0} { - # If a security descriptor not specified, keep - # all security attributes as an empty list (ie. NULL) - set sec_attr [list ] - } else { - set sec_attr [list $secd 0] - } - } - return $sec_attr -} - -# Returns the sid, domain and type for an account -proc twapi::lookup_account_name {name args} { - variable _name_to_sid_cache - - # Fast path - no options specified and cached - if {[llength $args] == 0 && [dict exists $_name_to_sid_cache "" $name]} { - return [lindex [dict get $_name_to_sid_cache "" $name] 0] - } - - array set opts [parseargs args \ - [list all \ - sid \ - domain \ - type \ - [list system.arg ""]\ - ]] - - if {! [dict exists $_name_to_sid_cache $opts(system) $name]} { - dict set _name_to_sid_cache $opts(system) $name [LookupAccountName $opts(system) $name] - } - lassign [dict get $_name_to_sid_cache $opts(system) $name] sid domain type - - set result [list ] - if {$opts(all) || $opts(domain)} { - lappend result -domain $domain - } - if {$opts(all) || $opts(type)} { - if {[info exists twapi::sid_type_names($type)]} { - lappend result -type $twapi::sid_type_names($type) - } else { - # Could be the "logonid" dummy type we added above - lappend result -type $type - } - } - - if {$opts(all) || $opts(sid)} { - lappend result -sid $sid - } - - # If no options specified, only return the sid/name - if {[llength $result] == 0} { - return $sid - } - - return $result -} - - -# Returns the name, domain and type for an account -proc twapi::lookup_account_sid {sid args} { - variable _sid_to_name_cache - - # Fast path - no options specified and cached - if {[llength $args] == 0 && [dict exists $_sid_to_name_cache "" $sid]} { - return [lindex [dict get $_sid_to_name_cache "" $sid] 0] - } - - array set opts [parseargs args \ - [list all \ - name \ - domain \ - type \ - [list system.arg ""]\ - ]] - - if {[dict exists $_sid_to_name_cache $opts(system) $sid]} { - lassign [dict get $_sid_to_name_cache $opts(system) $sid] name domain type - } else { - # Not in cache. Need to look up - - trap { - set data [LookupAccountSid $opts(system) $sid] - lassign $data name domain type - } onerror {TWAPI_WIN32 1332} { - # Win10 resolves this, Win7 does not. Emulate Win10 - if {![string match -nocase "S-1-5-5-*" $sid]} { - rethrow - } - # Name is formed similar to how Win10 does it - set name "LogonSessionId_[string map {- _} [string range $sid 8 end]]" - set domain "NT AUTHORITY" - set type 11 - set data [list $name $domain $type] - } - dict set _sid_to_name_cache $opts(system) $sid $data - } - - - set result [list ] - if {$opts(all) || $opts(domain)} { - lappend result -domain $domain - } - if {$opts(all) || $opts(type)} { - if {[info exists twapi::sid_type_names($type)]} { - lappend result -type $twapi::sid_type_names($type) - } else { - lappend result -type $type - } - } - - if {$opts(all) || $opts(name)} { - lappend result -name $name - } - - # If no options specified, only return the sid/name - if {[llength $result] == 0} { - return $name - } - - return $result -} - -# Returns the sid for a account - may be given as a SID or name -proc twapi::map_account_to_sid {account args} { - array set opts [parseargs args {system.arg} -nulldefault] - - # Treat empty account as null SID (self) - if {[string length $account] == ""} { - return "" - } - - if {[is_valid_sid_syntax $account]} { - return $account - } else { - return [lookup_account_name $account -system $opts(system)] - } -} - - -# Returns the name for a account - may be given as a SID or name -proc twapi::map_account_to_name {account args} { - array set opts [parseargs args {system.arg} -nulldefault] - - if {[is_valid_sid_syntax $account]} { - return [lookup_account_sid $account -system $opts(system)] - } else { - # Verify whether a valid account by mapping to an sid - if {[catch {map_account_to_sid $account -system $opts(system)}]} { - # As a special case, change LocalSystem to SYSTEM. Some Windows - # API's (such as services) return LocalSystem which cannot be - # resolved by the security functions. This name is really the - # same a the built-in SYSTEM - if {$account == "LocalSystem"} { - return "SYSTEM" - } - error "Unknown account '$account'" - } - return $account - } -} - -# Return the user account for the current process -proc twapi::get_current_user {{format -samcompatible}} { - - set return_sid false - switch -exact -- $format { - -fullyqualifieddn {set format 1} - -samcompatible {set format 2} - -display {set format 3} - -uniqueid {set format 6} - -canonical {set format 7} - -userprincipal {set format 8} - -canonicalex {set format 9} - -serviceprincipal {set format 10} - -dnsdomain {set format 12} - -sid {set format 2 ; set return_sid true} - default { - error "Unknown user name format '$format'" - } - } - - set user [GetUserNameEx $format] - - if {$return_sid} { - return [map_account_to_sid $user] - } else { - return $user - } -} - -# Get a new uuid -proc twapi::new_uuid {{opt ""}} { - if {[string length $opt]} { - if {[string equal $opt "-localok"]} { - set local_ok 1 - } else { - error "Invalid or unknown argument '$opt'" - } - } else { - set local_ok 0 - } - return [UuidCreate $local_ok] -} -proc twapi::nil_uuid {} { - return [UuidCreateNil] -} - -proc twapi::new_guid {} { - return [canonicalize_guid [new_uuid]] -} - -# Get a handle to a LSA policy. TBD - document -proc twapi::get_lsa_policy_handle {args} { - array set opts [parseargs args { - {system.arg ""} - {access.arg policy_read} - } -maxleftover 0] - - set access [_access_rights_to_mask $opts(access)] - return [Twapi_LsaOpenPolicy $opts(system) $access] -} - -# Close a LSA policy handle. TBD - document -proc twapi::close_lsa_policy_handle {h} { - LsaClose $h - return -} - -# Eventlog stuff in the base package - -namespace eval twapi { - # Keep track of event log handles - values are "r" or "w" - variable eventlog_handles - array set eventlog_handles {} -} - -# Open an eventlog for reading or writing -proc twapi::eventlog_open {args} { - variable eventlog_handles - - array set opts [parseargs args { - system.arg - source.arg - file.arg - write - } -nulldefault -maxleftover 0] - if {$opts(source) == ""} { - # Source not specified - if {$opts(file) == ""} { - # No source or file specified, default to current event log - # using executable name as source - set opts(source) [file rootname [file tail [info nameofexecutable]]] - } else { - if {$opts(write)} { - error "Option -file may not be used with -write" - } - } - } else { - # Source explicitly specified - if {$opts(file) != ""} { - error "Option -file may not be used with -source" - } - } - - if {$opts(write)} { - set handle [RegisterEventSource $opts(system) $opts(source)] - set mode write - } else { - if {$opts(source) != ""} { - set handle [OpenEventLog $opts(system) $opts(source)] - } else { - set handle [OpenBackupEventLog $opts(system) $opts(file)] - } - set mode read - } - - set eventlog_handles($handle) $mode - return $handle -} - -# Close an event log opened for writing -proc twapi::eventlog_close {hevl} { - variable eventlog_handles - - if {[_eventlog_valid_handle $hevl read]} { - CloseEventLog $hevl - } else { - DeregisterEventSource $hevl - } - - unset eventlog_handles($hevl) -} - - -# Log an event -proc twapi::eventlog_write {hevl id args} { - _eventlog_valid_handle $hevl write raise - - array set opts [parseargs args { - {type.arg information {success error warning information auditsuccess auditfailure}} - {category.int 1} - loguser - params.arg - data.arg - } -nulldefault] - - - switch -exact -- $opts(type) { - success {set opts(type) 0} - error {set opts(type) 1} - warning {set opts(type) 2} - information {set opts(type) 4} - auditsuccess {set opts(type) 8} - auditfailure {set opts(type) 16} - default {error "Invalid value '$opts(type)' for option -type"} - } - - if {$opts(loguser)} { - set user [get_current_user -sid] - } else { - set user "" - } - - ReportEvent $hevl $opts(type) $opts(category) $id \ - $user $opts(params) $opts(data) -} - - -# Log a message -proc twapi::eventlog_log {message args} { - array set opts [parseargs args { - system.arg - source.arg - {type.arg information} - {category.int 0} - } -nulldefault] - - set hevl [eventlog_open -write -source $opts(source) -system $opts(system)] - - trap { - eventlog_write $hevl 1 -params [list $message] -type $opts(type) -category $opts(category) - } finally { - eventlog_close $hevl - } - return -} - -proc twapi::make_logon_identity {username password domain} { - if {[concealed? $password]} { - return [list $username $domain $password] - } else { - return [list $username $domain [conceal $password]] - } -} - -proc twapi::read_credentials {args} { - # DEPRECATED - array set opts [parseargs args { - target.arg - winerror.int - username.arg - password.arg - persist.bool - {type.sym generic {domain 0 generic 0x40000 runas 0x80000}} - {forceui.bool 0 0x80} - {showsaveoption.bool true} - {expectconfirmation.bool 0 0x20000} - } -maxleftover 0 -nulldefault] - - if {$opts(persist) && ! $opts(expectconfirmation)} { - badargs! "Option -expectconfirmation must be specified as true if -persist is true" - } - - # 0x8 -> CREDUI_FLAGS_EXCLUDE_CERTIFICATES (needed for console) - set flags [expr {0x8 | $opts(forceui) | $opts(expectconfirmation)}] - - if {$opts(persist)} { - if {! $opts(showsaveoption)} { - incr flags 0x1000; # CREDUI_FLAGS_PERSIST - } - } else { - incr flags 0x2; # CREDUI_FLAGS_DO_NOT_PERSIST - if {$opts(showsaveoption)} { - incr flags 0x40; # CREDUI_FLAGS_SHOW_SAVE_CHECK_BOX - } - } - - incr flags $opts(type) - - return [CredUICmdLinePromptForCredentials $opts(target) NULL $opts(winerror) $opts(username) $opts(password) $opts(persist) $flags] -} - -proc twapi::credentials_dialog {args} { - # DEPRECATED - array set opts [parseargs args { - target.arg - winerror.int - username.arg - password.arg - persist.bool - {type.sym generic {domain 0 generic 0x40000 runas 0x80000}} - {forceui.bool 0 0x80} - {showsaveoption.bool true} - {expectconfirmation.bool 0 0x20000} - {fillusername.bool 0 0x800} - {filllocaladmins.bool 0 0x4} - {notifyfail.bool 0 0x1} - {passwordonly.bool 0 0x200} - {requirecertificate.bool 0 0x10} - {requiresmartcard.bool 0 0x100} - {validateusername.bool 0 0x400} - {parent.arg NULL} - message.arg - caption.arg - {bitmap.arg NULL} - } -maxleftover 0 -nulldefault] - - if {$opts(persist) && ! $opts(expectconfirmation)} { - badargs! "Option -willconfirm must be specified as true if -persist is true" - } - - set flags [expr { 0x8 | $opts(forceui) | $opts(notifyfail) | $opts(expectconfirmation) | $opts(fillusername) | $opts(filllocaladmins)}] - - if {$opts(persist)} { - if {! $opts(showsaveoption)} { - incr flags 0x1000; # CREDUI_FLAGS_PERSIST - } - } else { - incr flags 0x2; # CREDUI_FLAGS_DO_NOT_PERSIST - if {$opts(showsaveoption)} { - incr flags 0x40; # CREDUI_FLAGS_SHOW_SAVE_CHECK_BOX - } - } - - incr flags $opts(type) - - return [CredUIPromptForCredentials [list $opts(parent) $opts(message) $opts(caption) $opts(bitmap)] $opts(target) NULL $opts(winerror) $opts(username) $opts(password) $opts(persist) $flags] -} - -proc twapi::confirm_credentials {target valid} { - # DEPRECATED - return [CredUIConfirmCredentials $target $valid] -} - - -proc twapi::_make_cred_persist_flags {persist showsave} { - # Use cases - - # (1) credentials to be persisted WITHOUT showing save option to user - # (2) credentials to be persisted AFTER showing save option to user - # (3) credentials NOT to be persisted, user not shown save option - # (4) credentials NOT to be persisted, but user shown save option - # In case (4), caller has to decide what to do with the credentials if - # user selects to save (e.g. save elsewhere) - # If credentials are to be persisted, caller MUST call cred_confirm later - - if {$persist} { - # Note CREDUI_FLAGS_EXPECT_CONFIRMATION (0x20000) must be specified - # whenever CREDUI_FLAGS_DO_NOT_PERSIST is not specified - if {$showsave} { - # (2) CREDUI_FLAGS_EXPECT_CONFIRMATION - return 0x20000 - } else { - # (1) CREDUI_FLAGS_PERSIST | CREDUI_FLAGS_EXPECT_CONFIRMATION - return 0x21000 - } - } else { - if {$showsave} { - # (4) CREDUI_FLAGS_DO_NOT_PERSIST | CREDUI_FLAGS_SHOW_SAVE_CHECK_BOX - return 0x42 - } else { - # (3) CREDUI_FLAGS_DO_NOT_PERSIST - return 0x02 - } - } -} - -proc twapi::cred_prompt_console {target args} { - # Not documented because Windows seems to ignore on Win10 at least - - # -password, -winerror - array set opts [parseargs args { - {forceui.bool 0 0x80} - password.arg - persist.bool - {showsaveoption.bool 0} - {type.sym generic {domain 0 generic 0x40000 runas 0x80000}} - username.arg - winerror.int - } -maxleftover 0 -nulldefault] - - if {$target eq ""} { - error "Target must not be an empty string." - } - - if {$opts(forceui) && $opts(type) != 0x40000} { - error "The -forceui option can only be set if -type is \"generic\"." - } - - if {$opts(type) == 0x80000 && $opts(username) eq ""} { - # CredUIPromptForCredentials crashes - error "The -username option must not be an empty string if -type is \"runas\"." - } - - set flags [_make_cred_persist_flags $opts(persist) $opts(showsaveoption)] - - # 0x8 -> CREDUI_FLAGS_EXCLUDE_CERTIFICATES (needed for console) - set flags [expr {0x8 | $flags | $opts(type) | $opts(forceui)}] - - return [CredUICmdLinePromptForCredentials $target NULL $opts(winerror) $opts(username) $opts(password) $opts(persist) $flags] -} - -proc twapi::cred_prompt_gui {target args} { - # Not documented because Windows seems to ignore on Win10 at least - - # -passwordonly, -notifyfail, -winerror - array set opts [parseargs args { - {bitmap.arg NULL} - caption.arg - {excludecertificates.bool 0 0x8} - {filllocaladmins.bool 0 0x4} - {completeusername.bool 0 0x800} - {forceui.bool 0 0x80} - {keepusername.bool 0 0x100000} - message.arg - {notifyfail.bool 0 0x1} - {parent.arg NULL} - password.arg - {passwordonly.bool 0 0x200} - persist.bool - {requirecertificate.bool 0 0x10} - {requiresmartcard.bool 0 0x100} - {showsaveoption.bool 0} - {type.sym generic {domain 0 generic 0x40000 runas 0x80000}} - username.arg - {validateusername.bool 0 0x400} - winerror.int - } -maxleftover 0 -nulldefault] - - if {$target eq ""} { - error "Target must not be an empty string." - } - - if {$opts(forceui) && $opts(type) != 0x40000} { - error "The -forceui option can only be set if -type is \"generic\"." - } - - if {$opts(type) == 0x80000 && $opts(username) eq ""} { - # CredUIPromptForCredentials crashes - error "The -username option must not be an empty string if -type is \"runas\"." - } - - set flags [_make_cred_persist_flags $opts(persist) $opts(showsaveoption)] - set flags [expr { - $flags | - $opts(excludecertificates) | - $opts(filllocaladmins) | - $opts(completeusername) | - $opts(forceui) | - $opts(keepusername) | - $opts(notifyfail) | - $opts(passwordonly) | - $opts(requirecertificate) | - $opts(requiresmartcard) | - $opts(type) | - $opts(validateusername) - }] - - return [CredUIPromptForCredentials [list $opts(parent) $opts(message) $opts(caption) $opts(bitmap)] $target NULL $opts(winerror) $opts(username) $opts(password) $opts(persist) $flags] -} - -proc twapi::cred_confirm {target valid} { - return [CredUIConfirmCredentials $target $valid] -} - -# Validate a handle for a mode. Always raises error if handle is invalid -# If handle valid but not for that mode, will raise error iff $raise_error -# is non-empty. Returns 1 if valid, 0 otherwise -proc twapi::_eventlog_valid_handle {hevl mode {raise_error ""}} { - variable eventlog_handles - if {![info exists eventlog_handles($hevl)]} { - error "Invalid event log handle '$hevl'" - } - - if {[string compare $eventlog_handles($hevl) $mode]} { - if {$raise_error != ""} { - error "Eventlog handle '$hevl' not valid for $mode" - } - return 0 - } else { - return 1 - } -} - -### Common disk related - -# Map bit mask to list of drive letters -proc twapi::_drivemask_to_drivelist {drivebits} { - set drives [list ] - set i 0 - foreach drive {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} { - if {$drivebits == 0} break - set drivemask [expr {1 << $i}] - if {[expr {$drivebits & $drivemask}]} { - lappend drives $drive: - set drivebits [expr {$drivebits & ~ $drivemask}] - } - incr i - } - return $drives -} - -### Type casts -proc twapi::tclcast {type val} { - # Only permit these because wideInt, for example, cannot be reliably - # converted -> it can return an int instead. - set types {"" empty null bstr int boolean double string list dict} - if {$type ni $types} { - badargs! "Bad cast to \"$type\". Must be one of: $types" - } - return [Twapi_InternalCast $type $val] -} - -if {[info commands ::lmap] eq "::lmap"} { - proc twapi::safearray {type l} { - set type [dict! { - variant "" - boolean boolean - bool boolean - int int - i4 int - double double - r8 double - string string - bstr string - } $type] - return [lmap val $l {tclcast $type $val}] - } -} else { - proc twapi::safearray {type l} { - set type [dict! { - variant "" - boolean boolean - bool boolean - int int - i4 int - double double - r8 double - string string - bstr string - } $type] - set l2 {} - foreach val $l { - lappend l2 [tclcast $type $val] - } - return $l2 - } -} - -namespace eval twapi::recordarray {} - -proc twapi::recordarray::size {ra} { - return [llength [lindex $ra 1]] -} - -proc twapi::recordarray::fields {ra} { - return [lindex $ra 0] -} - -proc twapi::recordarray::index {ra row args} { - set r [lindex $ra 1 $row] - if {[llength $r] == 0} { - return $r - } - ::twapi::parseargs args { - {format.arg list {list dict}} - slice.arg - } -setvars -maxleftover 0 - - set fields [lindex $ra 0] - if {[info exists slice]} { - set new_fields {} - set new_r {} - foreach field $slice { - set i [twapi::enum $fields $field] - lappend new_r [lindex $r $i] - lappend new_fields [lindex $fields $i] - } - set r $new_r - set fields $new_fields - } - - if {$format eq "list"} { - return $r - } else { - return [::twapi::twine $fields $r] - } -} - -proc twapi::recordarray::range {ra low high} { - return [list [lindex $ra 0] [lrange [lindex $ra 1] $low $high]] -} - -proc twapi::recordarray::column {ra field args} { - # TBD - time to see if a script loop would be faster - ::twapi::parseargs args { - filter.arg - } -nulldefault -maxleftover 0 -setvars - _recordarray -slice [list $field] -filter $filter -format flat $ra -} - -proc twapi::recordarray::cell {ra row field} { - return [lindex [lindex $ra 1 $row] [twapi::enum [lindex $ra 0] $field]] -} - -proc twapi::recordarray::get {ra args} { - ::twapi::parseargs args { - {format.arg list {list dict flat}} - key.arg - } -ignoreunknown -setvars - - # format & key are options just to stop them flowing down to _recordarray - # We do not pass it in - - return [_recordarray {*}$args $ra] -} - -proc twapi::recordarray::getlist {ra args} { - # key is an option just to stop in flowing down to _recordarray - # We do not pass it in - - if {[llength $args] == 0} { - return [lindex $ra 1] - } - - ::twapi::parseargs args { - {format.arg list {list dict flat}} - key.arg - } -ignoreunknown -setvars - - - return [_recordarray {*}$args -format $format $ra] -} - -proc twapi::recordarray::getdict {ra args} { - ::twapi::parseargs args { - {format.arg list {list dict}} - key.arg - } -ignoreunknown -setvars - - if {![info exists key]} { - set key [lindex $ra 0 0] - } - - # Note _recordarray has different (putting it politely) semantics - # of how -format and -key option are handled so the below might - # look a bit strange in that we pass -format as list and get - # back a dict - return [_recordarray {*}$args -format $format -key $key $ra] -} - -proc twapi::recordarray::iterate {arrayvarname ra args} { - - if {[llength $args] == 0} { - badargs! "No script supplied" - } - - set body [lindex $args end] - set args [lrange $args 0 end-1] - - upvar 1 $arrayvarname var - - # TBD - Can this be optimized by prepending a ::foreach to body - # and executing that in uplevel 1 ? - - foreach rec [getlist $ra {*}$args -format dict] { - array set var $rec - set code [catch {uplevel 1 $body} result] - switch -exact -- $code { - 0 {} - 1 { - return -errorinfo $::errorInfo -errorcode $::errorCode -code error $result - } - 3 { - return; # break - } - 4 { - # continue - } - default { - return -code $code $result - } - } - } - return -} - -proc twapi::recordarray::rename {ra renames} { - set new_fields {} - foreach field [lindex $ra 0] { - if {[dict exists $renames $field]} { - lappend new_fields [dict get $renames $field] - } else { - lappend new_fields $field - } - } - return [list $new_fields [lindex $ra 1]] -} - -proc twapi::recordarray::concat {args} { - if {[llength $args] == 0} { - return {} - } - set args [lassign $args ra] - set fields [lindex $ra 0] - set values [list [lindex $ra 1]] - set width [llength $fields] - foreach ra $args { - foreach fld1 $fields fld2 [lindex $ra 0] { - if {$fld1 ne $fld2} { - twapi::badargs! "Attempt to concat record arrays with different fields ([join $fields ,] versus [join [lindex $ra 0] ,])" - } - } - lappend values [lindex $ra 1] - } - - return [list $fields [::twapi::lconcat {*}$values]] -} - -namespace eval twapi::recordarray { - namespace export cell column concat fields get getdict getlist index iterate range rename size - namespace ensemble create -} - -proc twapi::_parse_ctype {def parse_mode} { - variable _struct_defs - - # parse_mode is "struct", "param" or "function" - - if {![regexp -expanded { - ^ - \s* - (.+[^[:alnum:]_]) # type - ([[:alnum:]_]+) # name - \s* - (\[.+\])? # array size - \s*$ - } $def -> type name array]} { - error "Invalid C type definition $def" - } - - set child {} - switch -regexp -matchvar matchvar -- [string trim $type] { - {^void$} { - if {$parse_mode ne "function"} { - error "Type void cannot be used for structs and parameters." - } - set type void - } - {^char$} {set type i1} - {^BYTE$} - - {^unsigned char$} {set type ui1} - {^short$} {set type i2} - {^WORD$} - - {^unsigned\s+short$} {set type ui2} - {^BOOLEAN$} {set type bool} - {^LONG$} - - {^int$} {set type i4} - {^UINT$} - - {^ULONG$} - - {^DWORD$} - - {^unsigned\s+int$} {set type ui4} - {^__int64$} {set type i8} - {^unsigned\s+__int64$} {set type ui8} - {^double$} {set type r8} - {^float$} {set type r4} - {^LPCSTR$} - - {^LPSTR$} - - {^char\s*\*$} {set type lpstr} - {^LPCWSTR$} - - {^LPWSTR$} - - {^WCHAR\s*\*$} {set type lpwstr} - {^HANDLE$} {set type handle} - {^PSID$} {set type psid} - {^struct\s+([[:alnum:]_]+)$} { - if {$parse_mode ne "struct"} { - error "Structure types not allowed for parameters and return values." - } - # Embedded struct. It should be defined already. Calling - # it with no args returns its definition but doing that - # to retrieve the definition could be a security hole - # (could be passed any Tcl command!) if unwary apps - # pass in input from unknown sources. So we explicitly - # remember definitions instead. - set child_name [lindex $matchvar 1] - if {![info exists _struct_defs($child_name)]} { - error "Unknown struct $child_name" - } - set child $_struct_defs($child_name) - set type struct - } - default {error "Unknown type $type"} - } - set count 0 - if {$array ne ""} { - set count [string trim [string range $array 1 end-1]] - if {![string is integer -strict $count]} { - error "Non-integer array size" - } - if {$parse_mode ne "struct"} { - error "Arrays not allowed for parameters and return values." - } - } - - if {[string equal -nocase $name "cbSize"] && - $type in {i4 ui4} && $count == 0} { - set type cbsize - } - - return [list $name $type $count $child] -} - -proc twapi::_parse_cproto {s} { - variable _struct_defs - - # Get rid of comments - regsub -all {(/\*.* \*/){1,1}?} $s {} s - regsub -line -all {//.*$} $s { } s - - if {![regexp -expanded { - ^ - \s* - (?:(_cdecl|_stdcall)\s+)? - ([[:alnum:]_][[:space:][:alnum:]_]*) # Function type and name - \s* - \( # Beginning of parameters - ([^\)]*) # Parameter definition string - \) # End of parameters - \s*$ # End of prototype - } $s -> callconv fntypeandname paramstr]} { - error "Invalid C prototype \"$s\"" - } - - regsub -all {\s+} $fntypeandname " " - set fntype [_parse_ctype $fntypeandname function] - set params {} - foreach def [split $paramstr ","] { - lappend params [_parse_ctype $def param] - } - - return [list $callconv $fntype [lindex $fntype 0] $params] -} - -# Return a suitable cstruct definition based on a C definition -proc twapi::struct {struct_name s} { - variable _struct_defs - - if {0} { - TBD - Commented out because nested structs do not currently - handle namespaces. However this means structs are effectively - global even if the corresponding command is not. - set struct_name [callerns $struct_name] - } - - regsub -all {(/\*.* \*/){1,1}?} $s {} s - regsub -line -all {//.*$} $s { } s - set l {} - foreach def [split $s ";"] { - set def [string trim $def] - if {$def eq ""} continue - lappend l [_parse_ctype $def struct] - } - - set proc_body [format { - set def %s - if {[llength $args] == 0} { - return $def - } else { - return [list $def $args] - } - } [list $l]] - uplevel 1 [list proc $struct_name args $proc_body] - set _struct_defs($struct_name) $l - return -} - - -proc twapi::ffi_load {path} { - variable _ffi_paths - variable _ffi_handles - - # Note we do NOT normalize path as we leave it to the OS to do so. - # We also do not canonicalize it (e.g. all lower case). - # This means there may be multiple handles for a single shared lib - # but that's ok. - - if {[dict exists $_ffi_paths $path]} { - set h [dict get $_ffi_paths $path] - if {![dict exists $_ffi_handles $h]} { - error "Internal error: Handle $h not found in FFI table." - } - dict with _ffi_handles $h { - if {$Path ne $path} { - error "Internal error: Handle $h not assigned to $path" - } - incr NRefs - } - } else { - set h [load_library $path] - dict set _ffi_paths $path $h - dict set _ffi_handles $h Path $path - dict set _ffi_handles $h NRefs 1 - } - return $h -} - -proc twapi::ffi_unload {h} { - variable _ffi_handles - variable _ffi_paths - - if {![dict exists $_ffi_handles $h]} { - error "FFI handle $h does not exist." - } - - dict with _ffi_handles $h { - if {[incr NRefs -1] <= 0} { - dict unset _ffi_paths $Path - dict unset _ffi_handles $h - } - } - - return -} - -proc twapi::ffi_cfuncs {dllh cprotos {ns ::}} { - variable _ffi_handles - - if {![dict exists $_ffi_handles $dllh]} { - # error "Unknown FFI handle \"$dllh\"." - } - - set l {} - foreach cproto [split $cprotos ";"] { - set cproto [string trim $cproto] - if {$cproto eq ""} continue - lappend l [_parse_cproto $cproto] - } - set cprotos $l - - set def { - proc %NAME% {%PARAMNAMES%} { - if {![dict exists $%TWAPINS%::_ffi_handles %DLLH%]} { - error "Attempt to call function in unloaded library." - } - %TWAPINS%::%CALL% %FNADDR% %FNTYPE% %PARAMS% [list %PARAMREFS%] - } - } - - if {$::tcl_platform(pointerSize) == 8} { - # Win64 has single calling convention - set callmap {"" ffi_call _cdecl ffi_call _stdcall ffi_call} - } else { - set callmap {"" ffi_call _cdecl ffi_call _stdcall ffi_stdcall} - } - - foreach cproto $cprotos { - lassign $cproto callconv fntype fnname params - set call [dict get $callmap $callconv] - - set fnaddr [GetProcAddress $dllh $fnname] - if {[pointer_null? $fnaddr]} { - error "Entry point $fnname not found in shared library." - } - set paramnames {} - set paramrefs {} - foreach arg $params { - set name [lindex $arg 0] - lappend paramnames $name - lappend paramrefs \$$name - } - - # Note that fntype is doubly listified because the C ffi expects - # it in same format as params, ie. a list of type definitions - # _parse_cproto however returns it as a single type definition - append defs [string map [list \ - %CALL% $call \ - %DLLH% [list $dllh] \ - %NAME% ${ns}::$fnname \ - %PARAMNAMES% [join $paramnames { }] \ - %PARAMREFS% [join $paramrefs { }] \ - %TWAPINS% [namespace current] \ - %FNADDR% [list $fnaddr] \ - %FNTYPE% [list [list $fntype]] \ - %PARAMS% [list $params]] \ - $def] \n - } - - uplevel 1 $defs -} - - -if {[twapi::min_os_version 6]} { - twapi::ffi_cfuncs [twapi::ffi_load kernel32.dll] { - UINT GetErrorMode(); - UINT SetErrorMode(UINT mode); - } ::twapi -} - diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/clipboard.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/clipboard.tcl deleted file mode 100644 index 9fee98f8..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/clipboard.tcl +++ /dev/null @@ -1,254 +0,0 @@ -# -# 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 - } -} diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/com.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/com.tcl deleted file mode 100644 index 128a3458..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/com.tcl +++ /dev/null @@ -1,4238 +0,0 @@ -# -# Copyright (c) 2006-2018 Ashok P. Nadkarni -# All rights reserved. -# -# See the file LICENSE for license - -# TBD - tests comobj? works with derived classes of Automation - -# TBD - object identity comparison -# - see http://blogs.msdn.com/ericlippert/archive/2005/04/26/412199.aspx -# TBD - we seem to resolve UDT's every time a COM method is actually invoked. -# Optimize by doing it when prototype is stored or only the first time it -# is called. -# TBD - optimize by caching UDT's within a type library when the library -# is read. - -# TBD - optimize comobj unknown by caching previously resolved names -# - - -namespace eval twapi { - # Maps TYPEKIND data values to symbols - variable _typekind_map - array set _typekind_map { - 0 enum - 1 record - 2 module - 3 interface - 4 dispatch - 5 coclass - 6 alias - 7 union - } - - # Cache of Interface names - IID mappings - variable _name_to_iid_cache - array set _name_to_iid_cache { - iunknown {{00000000-0000-0000-C000-000000000046}} - idispatch {{00020400-0000-0000-C000-000000000046}} - idispatchex {{A6EF9860-C720-11D0-9337-00A0C90DCAA9}} - itypeinfo {{00020401-0000-0000-C000-000000000046}} - itypecomp {{00020403-0000-0000-C000-000000000046}} - ienumvariant {{00020404-0000-0000-C000-000000000046}} - iprovideclassinfo {{B196B283-BAB4-101A-B69C-00AA00341D07}} - - ipersist {{0000010c-0000-0000-C000-000000000046}} - ipersistfile {{0000010b-0000-0000-C000-000000000046}} - - iprovidetaskpage {{4086658a-cbbb-11cf-b604-00c04fd8d565}} - itasktrigger {{148BD52B-A2AB-11CE-B11F-00AA00530503}} - ischeduleworkitem {{a6b952f0-a4b1-11d0-997d-00aa006887ec}} - itask {{148BD524-A2AB-11CE-B11F-00AA00530503}} - ienumworkitems {{148BD528-A2AB-11CE-B11F-00AA00530503}} - itaskscheduler {{148BD527-A2AB-11CE-B11F-00AA00530503}} - imofcompiler {{6daf974e-2e37-11d2-aec9-00c04fb68820}} - } -} - -proc twapi::IUnknown_QueryInterface {ifc iid} { - set iidname void - catch {set iidname [registry get HKEY_CLASSES_ROOT\\Interface\\$iid ""]} - return [Twapi_IUnknown_QueryInterface $ifc $iid $iidname] -} - -proc twapi::CoGetObject {name bindopts iid} { - set iidname void - catch {set iidname [registry get HKEY_CLASSES_ROOT\\Interface\\$iid ""]} - return [Twapi_CoGetObject $name $bindopts $iid $iidname] -} - -proc twapi::progid_to_clsid {progid} { return [CLSIDFromProgID $progid] } -proc twapi::clsid_to_progid {progid} { return [ProgIDFromCLSID $progid] } - -proc twapi::com_security_blanket {args} { - # mutualauth.bool - docs for EOLE_AUTHENTICATION_CAPABILITIES. Learning - # DCOM says it is only for CoInitializeSecurity. Either way, - # that option is not applicable here - parseargs args { - {authenticationservice.arg default} - serverprincipal.arg - {authenticationlevel.arg default} - {impersonationlevel.arg default} - credentials.arg - cloaking.arg - } -maxleftover 0 -setvars - - set authenticationservice [_com_name_to_authsvc $authenticationservice] - set authenticationlevel [_com_name_to_authlevel $authenticationlevel] - set impersonationlevel [_com_name_to_impersonation $impersonationlevel] - - if {![info exists cloaking]} { - set eoac 0x800; # EOAC_DEFAULT - } else { - set eoac [dict! {none 0 static 0x20 dynamic 0x40} $cloaking] - } - - if {[info exists credentials]} { - # Credentials specified. Empty list -> NULL, ie use thread token - set creds_tag 1 - } else { - # Credentials not to be changed - set creds_tag 0 - set credentials {}; # Ignored - } - - if {[info exists serverprincipal]} { - if {$serverprincipal eq ""} { - set serverprincipaltag 0; # Default based on com_initialize_security - } else { - set serverprincipaltag 2 - } - } else { - set serverprincipaltag 1; # Unchanged server principal - set serverprincipal "" - } - - return [list $authenticationservice 0 $serverprincipaltag $serverprincipal $authenticationlevel $impersonationlevel $creds_tag $credentials $eoac] -} - -proc twapi::com_query_client_blanket {} { - lassign [CoQueryClientBlanket] authn authz server authlevel implevel client capabilities - if {$capabilities & 0x20} { - # EOAC_STATIC_CLOAKING - set cloaking static - } elseif {$capabilities & 0x40} { - set cloaking dynamic - } else { - set cloaking none - } - - # Note there is no implevel set as CoQueryClientBlanket does - # not return that information and implevel is a dummy value - return [list \ - -authenticationservice [_com_authsvc_to_name $authn] \ - -authorizationservice [dict* {0 none 1 name 2 dce} $authz] \ - -serverprincipal $server \ - -authenticationlevel [_com_authlevel_to_name $authlevel] \ - -clientprincipal $client \ - -cloaking $cloaking \ - ] -} - -# TBD - document -proc twapi::com_query_proxy_blanket {ifc} { - lassign [CoQueryProxyBlanket [lindex $args 0]] authn authz server authlevel implevel client capabilities - if {$capabilities & 0x20} { - # EOAC_STATIC_CLOAKING - set cloaking static - } elseif {$capabilities & 0x40} { - set cloaking dynamic - } else { - set cloaking none - } - - return [list \ - -authenticationservice [_com_authsvc_to_name $authn] \ - -authorizationservice [dict* {0 none 1 name 2 dce} $authz] \ - -serverprincipal $server \ - -authenticationlevel [_com_authlevel_to_name $authlevel] \ - -impersonationlevel [_com_impersonation_to_name $implevel] \ - -clientprincipal $client \ - -cloaking $cloaking \ - ] - -} - -proc twapi::com_initialize_security {args} { - # TBD - mutualauth? - # TBD - securerefs? - parseargs args { - {authenticationlevel.arg default} - {impersonationlevel.arg impersonate} - {cloaking.sym none {none 0 static 0x20 dynamic 0x40}} - secd.arg - appid.arg - authenticationservices.arg - } -maxleftover 0 -setvars - - if {[info exists secd] && [info exists appid]} { - badargs! "Only one of -secd and -appid can be specified." - } - - set impersonationlevel [_com_name_to_impersonation $impersonationlevel] - set authenticationlevel [_com_name_to_authlevel $authenticationlevel] - - set eoac $cloaking - if {[info exists appid]} { - incr eoac 8; # 8 -> EOAC_APPID - set secarg $appid - } else { - if {[info exists secd]} { - set secarg $secd - } else { - set secarg {} - } - } - - set authlist {} - if {[info exists authenticationservices]} { - foreach authsvc $authenticationservices { - lappend authlist [list [_com_name_to_authsvc [lindex $authsvc 0]] 0 [lindex $authsvc 1]] - } - } - - CoInitializeSecurity $secarg "" "" $authenticationlevel $impersonationlevel $authlist $eoac "" -} - -interp alias {} twapi::com_make_credentials {} twapi::make_logon_identity - -# TBD - document -proc twapi::com_create_instance {clsid args} { - array set opts [parseargs args { - {model.arg any} - download.bool - {disablelog.bool false} - enableaaa.bool - {nocustommarshal.bool false 0x1000} - {interface.arg IUnknown} - {authenticationservice.arg none} - {impersonationlevel.arg impersonate} - {credentials.arg {}} - {serverprincipal.arg {}} - {authenticationlevel.arg default} - {mutualauth.bool 0 0x1} - securityblanket.arg - system.arg - raw - } -maxleftover 0] - - set opts(authenticationservice) [_com_name_to_authsvc $opts(authenticationservice)] - set opts(authenticationlevel) [_com_name_to_authlevel $opts(authenticationlevel)] - set opts(impersonationlevel) [_com_name_to_impersonation $opts(impersonationlevel)] - - # CLSCTX_NO_CUSTOM_MARSHAL ? - set flags $opts(nocustommarshal) - - set model 0 - if {[info exists opts(model)]} { - foreach m $opts(model) { - switch -exact -- $m { - any {setbits model 23} - inprocserver {setbits model 1} - inprochandler {setbits model 2} - localserver {setbits model 4} - remoteserver {setbits model 16} - } - } - } - - setbits flags $model - - if {[info exists opts(download)]} { - if {$opts(download)} { - setbits flags 0x2000; # CLSCTX_ENABLE_CODE_DOWNLOAD - } else { - setbits flags 0x400; # CLSCTX_NO_CODE_DOWNLOAD - } - } - - if {$opts(disablelog)} { - setbits flags 0x4000; # CLSCTX_NO_FAILURE_LOG - } - - if {[info exists opts(enableaaa)]} { - if {$opts(enableaaa)} { - setbits flags 0x10000; # CLSCTX_ENABLE_AAA - } else { - setbits flags 0x8000; # CLSCTX_DISABLE_AAA - } - } - - if {[info exists opts(system)]} { - set coserverinfo [list 0 $opts(system) \ - [list $opts(authenticationservice) \ - 0 \ - $opts(serverprincipal) \ - $opts(authenticationlevel) \ - $opts(impersonationlevel) \ - $opts(credentials) \ - $opts(mutualauth) \ - ] \ - 0] - set activation_blanket \ - [com_security_blanket \ - -authenticationservice $opts(authenticationservice) \ - -serverprincipal $opts(serverprincipal) \ - -authenticationlevel $opts(authenticationlevel) \ - -impersonationlevel $opts(impersonationlevel) \ - -credentials $opts(credentials)] - } else { - set coserverinfo {} - } - - # If remote, set the specified security blanket on the proxy. Note - # that the blanket settings passed to CoCreateInstanceEx are used - # only for activation and do NOT get passed down to method calls - # If a remote component is activated with specific identity, we - # assume method calls require the same security settings. - - if {([info exists activation_blanket] || [llength $opts(credentials)]) && - ![info exists opts(securityblanket)]} { - if {[info exists activation_blanket]} { - set opts(securityblanket) $activation_blanket - } else { - set opts(securityblanket) [com_security_blanket -credentials $opts(credentials)] - } - } - - lassign [_resolve_iid $opts(interface)] iid iid_name - - # TBD - is all this OleRun still necessary or is there a check we can make - # before going down that path ? - # Microsoft Office (and maybe others) have some, uhhm, quirks. - # If they are loaded as inproc, all calls to retrieve an interface other - # than IUnknown fails. We have to get the IUnknown interface, - # call OleRun and then retrieve the desired interface. - # This does not happen if the localserver model was requested. - # We could check for a specific error code but no guarantee that - # the error is same in all versions so we catch and retry on all errors. - # 3rd element of each sublist is status. Non-0 -> Failure code - if {[catch {set ifcs [CoCreateInstanceEx $clsid NULL $flags $coserverinfo [list $iid]]}] || [lindex $ifcs 0 2] != 0} { - # Try through IUnknown - set ifcs [CoCreateInstanceEx $clsid NULL $flags $coserverinfo [list [_iid_iunknown]]] - - if {[lindex $ifcs 0 2] != 0} { - win32_error [lindex $ifcs 0 2] - } - set iunk [lindex $ifcs 0 1] - - # Need to set security blanket if specified before invoking any method - # else will get access denied - if {[info exists opts(securityblanket)]} { - trap { - CoSetProxyBlanket $iunk {*}$opts(securityblanket) - } onerror {} { - IUnknown_Release $iunk - rethrow - } - } - - trap { - # Wait for it to run, then get desired interface from it - twapi::OleRun $iunk - set ifc [Twapi_IUnknown_QueryInterface $iunk $iid $iid_name] - } finally { - IUnknown_Release $iunk - } - } else { - set ifc [lindex $ifcs 0 1] - } - - # All interfaces are returned typed as IUnknown by the C level - # even though they are actually the requested type. - set ifc [cast_handle $ifc $iid_name] - - if {[info exists activation_blanket]} { - # In order for servers to release objects properly, the IUnknown - # interface must have the same security settings as were used in - # the object creation - _com_set_iunknown_proxy $ifc $activation_blanket - } - - if {$opts(raw)} { - if {[info exists opts(securityblanket)]} { - trap { - CoSetProxyBlanket $ifc {*}$opts(securityblanket) - } onerror {} { - IUnknown_Release $ifc - rethrow - } - } - return $ifc - } else { - set proxy [make_interface_proxy $ifc] - if {[info exists opts(securityblanket)]} { - trap { - $proxy @SetSecurityBlanket $opts(securityblanket) - } onerror {} { - catch {$proxy Release} - rethrow - } - } - return $proxy - } -} - - -proc twapi::comobj_idispatch {ifc {addref 0} {objclsid ""} {lcid 0}} { - if {[pointer_null? $ifc]} { - return ::twapi::comobj_null - } - - if {[pointer? $ifc IDispatch]} { - if {$addref} { IUnknown_AddRef $ifc } - set proxyobj [IDispatchProxy new $ifc $objclsid] - } elseif {[pointer? $ifc IDispatchEx]} { - if {$addref} { IUnknown_AddRef $ifc } - set proxyobj [IDispatchExProxy new $ifc $objclsid] - } else { - error "'$ifc' does not reference an IDispatch interface" - } - - return [Automation new $proxyobj $lcid] -} - -# -# Create an object command for a COM object from a name -proc twapi::comobj_object {path args} { - array set opts [parseargs args { - progid.arg - {interface.arg IDispatch {IDispatch IDispatchEx}} - {lcid.int 0} - } -maxleftover 0] - - set clsid "" - if {[info exists opts(progid)]} { - # TBD - document once we have a test case for this - # Specify which app to use to open the file. - # See "Mapping Visual Basic to Automation" in SDK help - set clsid [_convert_to_clsid $opts(progid)] - set ipersistfile [com_create_instance $clsid -interface IPersistFile] - trap { - IPersistFile_Load $ipersistfile $path 0 - set idisp [Twapi_IUnknown_QueryInterface $ipersistfile [_iid_idispatch] IDispatch] - } finally { - IUnknown_Release $ipersistfile - } - } else { - # TBD - can we get the CLSID for this case - set idisp [::twapi::Twapi_CoGetObject $path {} [name_to_iid $opts(interface)] $opts(interface)] - } - - return [comobj_idispatch $idisp 0 $clsid $opts(lcid)] -} - -# -# Create a object command for a COM object IDispatch interface -# comid is either a CLSID or a PROGID -proc twapi::comobj {comid args} { - array set opts [parseargs args { - {interface.arg IDispatch {IDispatch IDispatchEx}} - active - {lcid.int 0} - } -ignoreunknown] - set clsid [_convert_to_clsid $comid] - if {$opts(active)} { - set iunk [GetActiveObject $clsid] - twapi::trap { - # TBD - do we need to deal with security blanket here? How do - # know what blanket is to be used on an already active object? - # Get the IDispatch interface - set idisp [IUnknown_QueryInterface $iunk {{00020400-0000-0000-C000-000000000046}}] - return [comobj_idispatch $idisp 0 $clsid $opts(lcid)] - } finally { - IUnknown_Release $iunk - } - } else { - set proxy [com_create_instance $clsid -interface $opts(interface) {*}$args] - $proxy @SetCLSID $clsid - return [Automation new $proxy $opts(lcid)] - } -} - -proc twapi::comobj_destroy args { - foreach arg $args { - catch {$arg -destroy} - } -} - -# Return an interface to a typelib -proc twapi::ITypeLibProxy_from_path {path args} { - array set opts [parseargs args { - {registration.arg none {none register default}} - } -maxleftover 0] - - return [make_interface_proxy [LoadTypeLibEx $path [kl_get {default 0 register 1 none 2} $opts(registration) $opts(registration)]]] -} - -# -# Return an interface to a typelib from the registry -proc twapi::ITypeLibProxy_from_guid {uuid major minor args} { - array set opts [parseargs args { - lcid.int - } -maxleftover 0 -nulldefault] - - return [make_interface_proxy [LoadRegTypeLib $uuid $major $minor $opts(lcid)]] -} - -# -# Unregister a typelib -proc twapi::unregister_typelib {uuid major minor args} { - array set opts [parseargs args { - lcid.int - } -maxleftover 0 -nulldefault] - - UnRegisterTypeLib $uuid $major $minor $opts(lcid) 1 -} - -# -# Returns the path to the typelib based on a guid -proc twapi::get_typelib_path_from_guid {guid major minor args} { - array set opts [parseargs args { - lcid.int - } -maxleftover 0 -nulldefault] - - - set path [variant_value [QueryPathOfRegTypeLib $guid $major $minor $opts(lcid)] 0 0 $opts(lcid)] - # At least some versions have a bug in that there is an extra \0 - # at the end. - if {[string equal [string index $path end] \0]} { - set path [string range $path 0 end-1] - } - return $path -} - -# -# Map interface name to IID -proc twapi::name_to_iid {iname} { - set iname [string tolower $iname] - - if {[info exists ::twapi::_name_to_iid_cache($iname)]} { - return $::twapi::_name_to_iid_cache($iname) - } - - # Look up the registry - set iids {} - foreach iid [registry keys HKEY_CLASSES_ROOT\\Interface] { - if {![catch { - set val [registry get HKEY_CLASSES_ROOT\\Interface\\$iid ""] - }]} { - if {[string equal -nocase $iname $val]} { - lappend iids $iid - } - } - } - - if {[llength $iids] == 1} { - return [set ::twapi::_name_to_iid_cache($iname) [lindex $iids 0]] - } elseif {[llength $iids]} { - error "Multiple interfaces found matching name $iname: [join $iids ,]" - } else { - return [set ::twapi::_name_to_iid_cache($iname) ""] - } -} - - -# -# Map interface IID to name -proc twapi::iid_to_name {iid} { - set iname "" - catch {set iname [registry get HKEY_CLASSES_ROOT\\Interface\\$iid ""]} - return $iname -} - -# -# Convert a variant time to a time list -proc twapi::variant_time_to_timelist {double} { - return [VariantTimeToSystemTime $double] -} - -# -# Convert a time list time to a variant time -proc twapi::timelist_to_variant_time {timelist} { - return [SystemTimeToVariantTime $timelist] -} - - -proc twapi::typelib_print {path args} { - array set opts [parseargs args { - type.arg - name.arg - output.arg - } -maxleftover 0 -nulldefault] - - - if {$opts(output) ne ""} { - if {[file exists $opts(output)]} { - error "File $opts(output) already exists." - } - set outfd [open $opts(output) a] - } else { - set outfd stdout - } - - trap { - set tl [ITypeLibProxy_from_path $path -registration none] - puts $outfd [$tl @Text -type $opts(type) -name $opts(name)] - } finally { - if {[info exists tl]} { - $tl Release - } - if {$outfd ne "stdout"} { - close $outfd - } - } - - return -} - -proc twapi::generate_code_from_typelib {path args} { - array set opts [parseargs args { - output.arg - } -ignoreunknown] - - if {[info exists opts(output)]} { - if {$opts(output) ne "stdout"} { - if {[file exists $opts(output)]} { - error "File $opts(output) already exists." - } - set outfd [open $opts(output) a] - } else { - set outfd stdout - } - } - - trap { - set tl [ITypeLibProxy_from_path $path -registration none] - set code [$tl @GenerateCode {*}$args] - if {[info exists outfd]} { - set libattr [$tl @GetLibAttr -all] - puts $outfd "# Automatically generated type library interface" - puts $outfd "# File: [file tail $path]" - puts $outfd "# Name: [$tl @GetName]" - puts $outfd "# GUID: [dict get $libattr -guid]" - puts $outfd "# Version: [dict get $libattr -majorversion].[dict get $libattr -minorversion]" - puts $outfd "# LCID: [dict get $libattr -lcid]" - - puts $outfd "\npackage require twapi_com" - puts $outfd $code - return - } else { - return $code - } - } finally { - if {[info exists tl]} { - $tl Release - } - if {[info exists outfd] && $outfd ne "stdout"} { - close $outfd - } - } -} - - - - -proc twapi::_interface_text {ti} { - # ti must be TypeInfo for an interface or module (or enum?) - TBD - set desc "" - array set attrs [$ti @GetTypeAttr -all] - set desc "Functions:\n" - for {set j 0} {$j < $attrs(-fncount)} {incr j} { - array set funcdata [$ti @GetFuncDesc $j -all] - if {$funcdata(-funckind) eq "dispatch"} { - set funckind "(dispid $funcdata(-memid))" - } else { - set funckind "(vtable $funcdata(-vtbloffset))" - } - append desc "\t$funckind [::twapi::_resolve_com_type_text $ti $funcdata(-datatype)] $funcdata(-name) $funcdata(-invkind) [::twapi::_resolve_com_params_text $ti $funcdata(-params) $funcdata(-paramnames)]\n" - } - append desc "Variables:\n" - for {set j 0} {$j < $attrs(-varcount)} {incr j} { - array set vardata [$ti @GetVarDesc $j -all] - set vardesc "($vardata(-memid)) $vardata(-varkind) [::twapi::_flatten_com_type [::twapi::_resolve_com_type_text $ti $vardata(-datatype)]] $vardata(-name)" - if {$attrs(-typekind) eq "enum" || $vardata(-varkind) eq "const"} { - append vardesc " = $vardata(-value)" - } else { - append vardesc " (offset $vardata(-value))" - } - append desc "\t$vardesc\n" - } - return $desc -} - -# -# Print methods in an interface, including inherited names -proc twapi::dispatch_print {di args} { - array set opts [parseargs args { - output.arg - } -maxleftover 0 -nulldefault] - - if {$opts(output) ne ""} { - if {[file exists $opts(output)]} { - error "File $opts(output) already exists." - } - set outfd [open $opts(output) a] - } else { - set outfd stdout - } - - trap { - set ti [$di @GetTypeInfo] - twapi::_dispatch_print_helper $ti $outfd - } finally { - if {[info exists ti]} { - $ti Release - } - if {$outfd ne "stdout"} { - close $outfd - } - } - - return -} - -proc twapi::_dispatch_print_helper {ti outfd {names_already_done ""}} { - set name [$ti @GetName] - if {$name in $names_already_done} { - # Already printed this - return $names_already_done - } - lappend names_already_done $name - - # Check for dual interfaces - we want to print both vtable and disp versions - set tilist [list $ti] - if {![catch {set ti2 [$ti @GetRefTypeInfoFromIndex $ti -1]}]} { - lappend tilist $ti2 - } - - trap { - foreach tifc $tilist { - puts $outfd $name - puts $outfd [_interface_text $tifc] - } - } finally { - if {[info exists ti2]} { - $ti2 Release - } - } - - # Now get any referenced typeinfos and print them - array set tiattrs [$ti GetTypeAttr] - for {set j 0} {$j < $tiattrs(cImplTypes)} {incr j} { - set ti2 [$ti @GetRefTypeInfoFromIndex $j] - trap { - set names_already_done [_dispatch_print_helper $ti2 $outfd $names_already_done] - } finally { - $ti2 Release - } - } - - return $names_already_done -} - - - -# -# Resolves references to parameter definition -proc twapi::_resolve_com_params_text {ti params paramnames} { - set result [list ] - foreach param $params paramname $paramnames { - set paramdesc [_flatten_com_type [_resolve_com_type_text $ti [lindex $param 0]]] - if {[llength $param] > 1 && [llength [lindex $param 1]] > 0} { - set paramdesc "\[[lindex $param 1]\] $paramdesc" - } - if {[llength $param] > 2} { - append paramdesc " [lrange $param 2 end]" - } - append paramdesc " $paramname" - lappend result $paramdesc - } - return "([join $result {, }])" -} - -# Flattens the output of _resolve_com_type_text -proc twapi::_flatten_com_type {com_type_desc} { - if {[llength $com_type_desc] < 2} { - return $com_type_desc - } - - if {[lindex $com_type_desc 0] eq "ptr"} { - return "[_flatten_com_type [lindex $com_type_desc 1]]*" - } else { - return "([lindex $com_type_desc 0] [_flatten_com_type [lindex $com_type_desc 1]])" - } -} - -# -# Resolves typedefs -proc twapi::_resolve_com_type_text {ti typedesc} { - - switch -exact -- [lindex $typedesc 0] { - 26 - - ptr { - # Recurse to resolve any inner types - set typedesc [list ptr [_resolve_com_type_text $ti [lindex $typedesc 1]]] - } - 29 - - userdefined { - set hreftype [lindex $typedesc 1] - set ti2 [$ti @GetRefTypeInfo $hreftype] - set typedesc "[$ti2 @GetName]" - $ti2 Release - } - default { - set typedesc [_vttype_to_string $typedesc] - } - } - - return $typedesc -} - - -# -# Given a COM type descriptor, resolved all user defined types (UDT) in it -# The descriptor must be in raw form as returned by the C code -proc twapi::_resolve_comtype {ti typedesc} { - - if {[lindex $typedesc 0] == 26} { - # VT_PTR - {26 INNER_TYPEDESC} - # If pointing to a UDT, convert to appropriate base type if possible - set inner [_resolve_comtype $ti [lindex $typedesc 1]] - set inner_type [lindex $inner 0] - if {$inner_type == 29} { - # When the referenced type is a UDT (29) which is actually - # a dispatch or other interface, replace the - # "pointer to UDT" with VT_DISPATCH/VT_INTERFACE - switch -exact -- [lindex $inner 1] { - dispatch {set typedesc [list 9]} - interface {set typedesc [list 13]} - coclass { - # Replace pointers to a user defined type that is - # a coclass having a default dispatch interface with - # the type for a dispatch interface - set idispatch_guid [coclass_idispatch_guid [lindex $inner 2]] - if {$idispatch_guid eq ""} { - # Coclass has no default dispatch interface - set typedesc [list 26 $inner] - } else { - # TBD - can we store idispatch_guid in param def so - # for return values we automatically convert to correct - # comobj type? - set typedesc [list 9]; # VT_DISPATCH - } - } - default { - # TBD - need to decode all the other types (record etc.) - set typedesc [list 26 $inner] - } - } - } else { - set typedesc [list 26 $inner] - } - } elseif {[lindex $typedesc 0] == 29} { - # VT_USERDEFINED - {29 HREFTYPE} - set ti2 [$ti @GetRefTypeInfo [lindex $typedesc 1]] - array set tattr [$ti2 @GetTypeAttr -guid -typekind] - switch -exact -- $tattr(-typekind) { - enum { - set typedesc [list 3]; # 3 -> i4 - } - alias { - set typedesc [_resolve_comtype $ti2 [kl_get [$ti2 GetTypeAttr] tdescAlias]] - } - default { - set typedesc [list 29 $tattr(-typekind) $tattr(-guid)] - } - } - $ti2 Release - } - - return $typedesc -} - -proc twapi::_resolve_params_for_prototype {ti paramdescs} { - set params {} - foreach paramdesc $paramdescs { - lappend params \ - [lreplace $paramdesc 0 0 [::twapi::_resolve_comtype $ti [lindex $paramdesc 0]]] - } - return $params -} - -proc twapi::_variant_values_from_safearray {sa ndims {raw false} {addref false} {lcid 0}} { - set result {} - if {[incr ndims -1] > 0} { - foreach elem $sa { - lappend result [_variant_values_from_safearray $elem $ndims $raw $addref $lcid] - } - } else { - foreach elem $sa { - lappend result [twapi::variant_value $elem $raw $addref $lcid] - } - } - return $result -} - -proc twapi::outvar {varname} { return [Twapi_InternalCast outvar $varname] } - -proc twapi::variant_value {variant raw addref {lcid 0}} { - # TBD - format appropriately depending on variant type for dates and - # currency - if {[llength $variant] == 0} { - return "" - } - set vt [lindex $variant 0] - - if {$vt & 0x2000} { - # VT_ARRAY - second element is {dimensions value} - if {[llength $variant] < 2} { - return [list ] - } - lassign [lindex $variant 1] dimensions values - set vt [expr {$vt & ~ 0x2000}] - if {$vt == 12} { - # Array of variants. Recursively convert values - return [_variant_values_from_safearray \ - $values \ - [expr {[llength $dimensions] / 2}] \ - $raw $addref $lcid] - } else { - return $values - } - } else { - if {$vt == 9} { - set idisp [lindex $variant 1]; # May be NULL! - if {$addref && ! [pointer_null? $idisp]} { - IUnknown_AddRef $idisp - } - if {$raw} { - return $idisp - } else { - # Note comobj_idispatch takes care of NULL - return [comobj_idispatch $idisp 0 "" $lcid] - } - } elseif {$vt == 13} { - set iunk [lindex $variant 1]; # May be NULL! - if {$addref && ! [pointer_null? $iunk]} { - IUnknown_AddRef $iunk - } - if {$raw} { - return $iunk - } else { - return [make_interface_proxy $iunk] - } - } - } - return [lindex $variant 1] -} - -proc twapi::variant_type {variant} { - return [lindex $variant 0] -} - -proc twapi::vt_null {} { - return [tclcast null ""] -} - -proc twapi::vt_empty {} { - return [tclcast empty ""] -} - -# -# General dispatcher for callbacks from event sinks. Invokes the actual -# registered script after mapping dispid's -proc twapi::_eventsink_callback {comobj script callee args} { - # Check if the comobj is still active - if {[llength [info commands $comobj]] == 0} { - if {$::twapi::log_config(twapi_com)} { - debuglog "COM event received for inactive object" - } - return; # Object has gone away, ignore - } - - set retcode [catch { - # We are invoked with cooked values so no need to call variant_value - uplevel #0 $script [list $callee] $args - } result] - - if {$::twapi::log_config(twapi_com) && $retcode} { - debuglog "Event sink callback error ($retcode): $result\n$::errorInfo" - } - - # $retcode is returned as HRESULT by the Invoke - return -code $retcode $result -} - -# -# Return clsid from a string. If $clsid is a valid CLSID - returns as is -# else tries to convert it from progid. An error is generated if neither -# works -proc twapi::_convert_to_clsid {comid} { - if {! [Twapi_IsValidGUID $comid]} { - return [progid_to_clsid $comid] - } - return $comid -} - -# -# Format a prototype definition for human consumption -# Proto is in the form {DISPID LCID INVOKEFLAGS RETTYPE PARAMTYPES PARAMNAMES} -proc twapi::_format_prototype {name proto} { - set dispid_lcid [lindex $proto 0]/[lindex $proto 1] - set ret_type [_vttype_to_string [lindex $proto 3]] - set invkind [_invkind_to_string [lindex $proto 2]] - # Distinguish between no parameters and parameters not known - set paramstr "" - if {[llength $proto] > 4} { - set params {} - foreach param [lindex $proto 4] paramname [lindex $proto 5] { - if {[string length $paramname]} { - set paramname " $paramname" - } - lassign $param type paramdesc - set type [_vttype_to_string $type] - set parammods [_paramflags_to_tokens [lindex $paramdesc 0]] - if {[llength [lindex $paramdesc 1]]} { - # Default specified - lappend parammods "default:[lindex [lindex $paramdesc 1] 1]" - } - lappend params "\[$parammods\] $type$paramname" - } - set paramstr " ([join $params {, }])" - } - return "$dispid_lcid $invkind $ret_type ${name}${paramstr}" -} - -# Convert parameter modifiers to string tokens. -# modifiers is list of integer flags or tokens. -proc twapi::_paramflags_to_tokens {modifiers} { - array set tokens {} - foreach mod $modifiers { - if {! [string is integer -strict $mod]} { - # mod is a token itself - set tokens($mod) "" - } else { - foreach tok [_make_symbolic_bitmask $mod { - in 1 - out 2 - lcid 4 - retval 8 - optional 16 - hasdefault 32 - hascustom 64 - }] { - set tokens($tok) "" - } - } - } - - # For cosmetic reasons, in/out should be first and remaining sorted - # Also (in,out) -> inout - if {[info exists tokens(in)]} { - if {[info exists tokens(out)]} { - set inout [list inout] - unset tokens(in) - unset tokens(out) - } else { - set inout [list in] - unset tokens(in) - } - } else { - if {[info exists tokens(out)]} { - set inout [list out] - unset tokens(out) - } - } - - if {[info exists inout]} { - return [linsert [lsort [array names tokens]] 0 $inout] - } else { - return [lsort [array names tokens]] - } -} - -# -# Map method invocation code to string -# Return code itself if no match -proc twapi::_invkind_to_string {code} { - return [kl_get { - 1 func - 2 propget - 4 propput - 8 propputref - } $code $code] -} - -# -# Map string method invocation symbol to code -# Error if no match and not an integer -proc twapi::_string_to_invkind {s} { - if {[string is integer $s]} { return $s } - return [kl_get { - func 1 - propget 2 - propput 4 - propputref 8 - } $s] -} - - -# -# Convert a VT typedef to a string -# vttype may be nested -proc twapi::_vttype_to_string {vttype} { - set vts [_vtcode_to_string [lindex $vttype 0]] - if {[llength $vttype] < 2} { - return $vts - } - - return [list $vts [_vttype_to_string [lindex $vttype 1]]] -} - -# -# Convert VT codes to strings -proc twapi::_vtcode_to_string {vt} { - return [kl_get { - 2 i2 - 3 i4 - 4 r4 - 5 r8 - 6 cy - 7 date - 8 bstr - 9 idispatch - 10 error - 11 bool - 12 variant - 13 iunknown - 14 decimal - 16 i1 - 17 ui1 - 18 ui2 - 19 ui4 - 20 i8 - 21 ui8 - 22 int - 23 uint - 24 void - 25 hresult - 26 ptr - 27 safearray - 28 carray - 29 userdefined - 30 lpstr - 31 lpwstr - 36 record - } $vt $vt] -} - -proc twapi::_string_to_base_vt {tok} { - # Only maps base VT tokens to numeric value - # TBD - record and userdefined? - return [dict get { - i2 2 - i4 3 - r4 4 - r8 5 - cy 6 - date 7 - bstr 8 - idispatch 9 - error 10 - bool 11 - iunknown 13 - decimal 14 - i1 16 - ui1 17 - ui2 18 - ui4 19 - i8 20 - ui8 21 - int 22 - uint 23 - hresult 25 - userdefined 29 - record 36 - } [string tolower $tok]] - -} - -# -# Get ADSI provider service -proc twapi::_adsi {{prov WinNT} {path {//.}}} { - return [comobj_object "${prov}:$path"] -} - -# Get cached IDispatch and IUNknown IID's -proc twapi::_iid_iunknown {} { - return $::twapi::_name_to_iid_cache(iunknown) -} -proc twapi::_iid_idispatch {} { - return $::twapi::_name_to_iid_cache(idispatch) -} - -# -# Return IID and name given a IID or name -proc twapi::_resolve_iid {name_or_iid} { - - # IID -> name mapping is more efficient so first assume it is - # an IID else we will unnecessarily trundle through the whole - # registry area looking for an IID when we already have it - # Assume it is a name - set other [iid_to_name $name_or_iid] - if {$other ne ""} { - # It was indeed the IID. Return the pair - return [list $name_or_iid $other] - } - - # Else resolve as a name - set other [name_to_iid $name_or_iid] - if {$other ne ""} { - # Yep - return [list $other $name_or_iid] - } - - win32_error 0x80004002 "Could not find IID $name_or_iid" -} - - -namespace eval twapi { - # Enable use of TclOO for new Tcl versions. To override setting - # applications should define and set before sourcing this file. - variable use_tcloo_for_com - if {![info exists use_tcloo_for_com]} { - set use_tcloo_for_com [package vsatisfies [package require Tcl] 8.6b2] - } - if {$use_tcloo_for_com} { - interp alias {} ::twapi::class {} ::oo::class - proc ::oo::define::twapi_exportall {} { - uplevel 1 export [info class methods [lindex [info level -1] 1] -private] - } - proc comobj? {cobj} { - # We do not want change the internal type so - # do not check for some types that - # could not be a comobj. In particular, - # if a list type, we do not even check - # because it cannot be a comobj and even checking - # will result in nested list types being - # destroyed which affects safearray type detection - # TBD - would it be faster to keep explicit track through - # a dictionary ? - if {[twapi::tcltype $cobj] in {bstr empty null bytecode TwapiOpaque list int double bytearray dict wideInt booleanString}} { - return 0 - } - set cobj [uplevel 1 [list namespace which -command $cobj]] - if {[info object isa object $cobj] && - [info object isa typeof $cobj ::twapi::Automation]} { - return 1 - } else { - return 0 - } - } - proc comobj_instances {} { - set comobj_classes [list ::twapi::Automation] - set objs {} - while {[llength $comobj_classes]} { - set comobj_classes [lassign $comobj_classes class] - lappend objs {*}[info class instances $class] - lappend comobj_classes {*}[info class subclasses $class] - } - # Get rid of dups which may occur if subclasses use - # multiple (diamond type) inheritance - return [lsort -unique $objs] - } - } else { - package require metoo - interp alias {} ::twapi::class {} ::metoo::class - namespace eval ::metoo::define { - proc twapi_exportall {args} { - # args is dummy to match metoo's class definition signature - # Nothing to do, all methods are metoo are public - } - } - proc comobj? {cobj} { - set cobj [uplevel 1 [list namespace which -command $cobj]] - return [metoo::introspect object isa $cobj ::twapi::Automation] - } - proc comobj_instances {} { - return [metoo::introspect object list ::twapi::Automation] - } - } - - # The prototype cache is indexed a composite key consisting of - # - the GUID of the interface, - # - the name of the function - # - the LCID - # - the invocation kind (as an integer) - # Each value contains the full prototype in a form - # that can be passed to IDispatch_Invoke. This is a list with the - # elements {DISPID LCID INVOKEFLAGS RETTYPE PARAMTYPES PARAMNAMES} - # Here PARAMTYPES is a list each element of which describes a - # parameter in the following format: - # {TYPE {FLAGS DEFAULT} NAMEDARGVALUE} where DEFAULT is optional - # and NAMEDARGVALUE only appears (optionally) when the prototype is - # passed to Invoke, not in the cached prototype itself. - # PARAMNAMES is list of parameter names in order and is - # only present if PARAMTYPES is also present. - - variable _dispatch_prototype_cache - array set _dispatch_prototype_cache {} -} - - -interp alias {} twapi::_dispatch_prototype_get {} twapi::dispatch_prototype_get -proc twapi::dispatch_prototype_get {guid name lcid invkind vproto} { - variable _dispatch_prototype_cache - set invkind [::twapi::_string_to_invkind $invkind] - if {[info exists _dispatch_prototype_cache($guid,$name,$lcid,$invkind)]} { - # Note this may be null if that name does not exist in the interface - upvar 1 $vproto proto - set proto $_dispatch_prototype_cache($guid,$name,$lcid,$invkind) - return 1 - } - return 0 -} - -# Update a prototype in cache. Note lcid and invkind cannot be -# picked up from prototype since it might be empty. -interp alias {} twapi::_dispatch_prototype_set {} twapi::dispatch_prototype_set -proc twapi::dispatch_prototype_set {guid name lcid invkind proto} { - # If the prototype does not contain the 5th element (params) - # it is a constructed prototype and we do NOT cache it as the - # disp id can change. Note empty prototypes are cached so - # we don't keep looking up something that does not exist - # Bug 130 - - if {[llength $proto] == 4} { - return - } - - variable _dispatch_prototype_cache - set invkind [_string_to_invkind $invkind] - set _dispatch_prototype_cache($guid,$name,$lcid,$invkind) $proto - return -} - -# Explicitly set prototypes for a guid -# protolist is a list of alternating name and prototype pairs. -# Each prototype must contain the LCID and invkind fields -proc twapi::_dispatch_prototype_load {guid protolist} { - foreach {name proto} $protolist { - dispatch_prototype_set $guid $name [lindex $proto 1] [lindex $proto 2] $proto - } -} - -proc twapi::coclass_idispatch_guid {coclass_guid} { - variable _coclass_idispatch_guids - if {[info exists _coclass_idispatch_guids($coclass_guid)]} { - return $_coclass_idispatch_guids($coclass_guid) - } - return "" -} - -proc twapi::_parse_dispatch_paramdef {paramdef} { - set errormsg "Invalid parameter or return type declaration '$paramdef'" - - set paramregex {^(\[[^\]]*\])?\s*(\w+)\s*(\[\s*\])?\s*([*]?)\s*(\w+)?$} - if {![regexp $paramregex [string trim $paramdef] def attrs paramtype safearray ptr paramname]} { - error $errormsg - } - - if {[string length $paramname]} { - lappend paramnames $paramname - } - # attrs can be in, out, opt separated by spaces - set paramflags 0 - foreach attr [string range $attrs 1 end-1] { - switch -exact -- $attr { - in {set paramflags [expr {$paramflags | 1}]} - out {set paramflags [expr {$paramflags | 2}]} - inout {set paramflags [expr {$paramflags | 3}]} - opt - - optional {set paramflags [expr {$paramflags | 16}]} - default {error "Unknown parameter attribute $attr"} - } - } - if {($paramflags & 3) == 0} { - set paramflags [expr {$paramflags | 1}]; # in param if unspecified - } - # Resolve parameter type. It can be - # - a safearray of base types or "variant"s (not pointers) - # - a pointer to a base type - # - a pointer to a safearray - # - a base type or "variant" - switch -exact -- $paramtype { - variant { set paramtype 12 } - void { set paramtype 24 } - default { set paramtype [_string_to_base_vt $paramtype] } - } - if {[string length $safearray]} { - if {$paramtype == 24} { - # Safearray of type void is an invalid type decl - error $errormsg - } - set paramtype [list 27 $paramtype] - } - if {[string length $ptr]} { - if {$paramtype == 24} { - # Pointer to type void is an invalid type - error $errormsg - } - set paramtype [list 26 $paramtype] - } - - return [list $paramflags $paramtype $paramname] -} - -proc twapi::define_dispatch_prototypes {guid protos args} { - array set opts [parseargs args { - {lcid.int 0} - } -maxleftover 0] - - set guid [canonicalize_guid $guid] - - set defregx {^\s*(\w+)\s+(\d+)\s+(\w[^\(]*)\(([^\)]*)\)(.*)$} - set parsed_protos {} - # Loop picking out one prototype in each interation - while {[regexp $defregx $protos -> membertype memid rettype paramstring protos]} { - set params {} - set paramnames {} - foreach paramdef [split $paramstring ,] { - lassign [_parse_dispatch_paramdef $paramdef] paramflags paramtype paramname - if {[string length $paramname]} { - lappend paramnames $paramname - } - lappend params [list $paramtype [list $paramflags]] - } - if {[llength $paramnames] && - [llength $params] != [llength $paramnames]} { - error "Missing parameter name in '$paramstring'. All parameter names must be specified or none at all." - } - - lassign [_parse_dispatch_paramdef $rettype] _ rettype name - set invkind [_string_to_invkind $membertype] - set proto [list $memid $opts(lcid) $invkind $rettype $params $paramnames] - lappend parsed_protos $name $proto - } - - set protos [string trim $protos] - if {[string length $protos]} { - error "Invalid dispatch prototype: '$protos'" - } - - _dispatch_prototype_load $guid $parsed_protos -} - -# Used to track when interface proxies are renamed/deleted -proc twapi::_interface_proxy_tracer {ifc oldname newname op} { - variable _interface_proxies - if {$op eq "rename"} { - if {$oldname eq $newname} return - set _interface_proxies($ifc) $newname - } else { - unset _interface_proxies($ifc) - } -} - - -# Return a COM interface proxy object for the specified interface. -# If such an object already exists, it is returned. Otherwise a new one -# is created. $ifc must be a valid COM Interface pointer for which -# the caller is holding a reference. Caller relinquishes ownership -# of the interface and must solely invoke operations through the -# returned proxy object. When done with the object, call the Release -# method on it, NOT destroy. -# TBD - how does this interact with security blankets ? -proc twapi::make_interface_proxy {ifc} { - variable _interface_proxies - - if {[info exists _interface_proxies($ifc)]} { - set proxy $_interface_proxies($ifc) - $proxy AddRef - if {! [pointer_null? $ifc]} { - # Release the caller's ref to the interface since we are holding - # one in the proxy object - ::twapi::IUnknown_Release $ifc - } - } else { - if {[pointer_null? $ifc]} { - set proxy [INullProxy new $ifc] - } else { - set ifcname [pointer_type $ifc] - set proxy [${ifcname}Proxy new $ifc] - } - set _interface_proxies($ifc) $proxy - trace add command $proxy {rename delete} [list ::twapi::_interface_proxy_tracer $ifc] - } - return $proxy -} - -# "Null" object - clones IUnknownProxy but will raise error on method calls -# We could have inherited but IUnknownProxy assumes non-null ifc so it -# and its inherited classes do not have to check for null in every method. -twapi::class create ::twapi::INullProxy { - constructor {ifc} { - my variable _ifc - # We keep the interface pointer because it encodes type information - if {! [::twapi::pointer_null? $ifc]} { - error "Attempt to create a INullProxy with non-NULL interface" - } - - set _ifc $ifc - - my variable _nrefs; # Internal ref count (held by app) - set _nrefs 1 - } - - method @Null? {} { return 1 } - method @Type {} { - my variable _ifc - return [::twapi::pointer_type $_ifc] - } - method @Type? {type} { - my variable _ifc - return [::twapi::pointer? $_ifc $type] - } - method AddRef {} { - my variable _nrefs - # We maintain our own ref counts. _ifc is null so do not - # call the COM AddRef ! - incr _nrefs - } - - method Release {} { - my variable _nrefs - if {[incr _nrefs -1] == 0} { - my destroy - } - } - - method DebugRefCounts {} { - my variable _nrefs - - # Return out internal ref as well as the COM ones - # Note latter is always 0 since _ifc is always NULL. - return [list $_nrefs 0] - } - - method QueryInterface {name_or_iid} { - error "Attempt to call QueryInterface called on NULL pointer" - } - - method @QueryInterface {name_or_iid} { - error "Attempt to call QueryInterface called on NULL pointer" - } - - # Parameter is for compatibility with IUnknownProxy - method @Interface {{addref 1}} { - my variable _ifc - return $_ifc - } - - twapi_exportall -} - -twapi::class create ::twapi::IUnknownProxy { - # Note caller must hold ref on the ifc. This ref is passed to - # the proxy object and caller must not make use of that ref - # unless it does an AddRef on it. - constructor {ifc {objclsid ""}} { - if {[::twapi::pointer_null? $ifc]} { - error "Attempt to register a NULL interface" - } - - my variable _ifc - set _ifc $ifc - - my variable _clsid - set _clsid $objclsid - - my variable _blanket; # Security blanket - set _blanket [list ] - - # We keep an internal reference count instead of explicitly - # calling out to the object's AddRef/Release every time. - # When the internal ref count goes to 0, we will invoke the - # object's "native" Release. - # - # Note the primary purpose of maintaining our internal reference counts - # is not efficiency by shortcutting the "native" AddRefs. It is to - # prevent crashes by bad application code; we can just generate an - # error instead by having the command go away. - my variable _nrefs; # Internal ref count (held by app) - - set _nrefs 1 - } - - destructor { - my variable _ifc - ::twapi::IUnknown_Release $_ifc - } - - method AddRef {} { - my variable _nrefs - # We maintain our own ref counts. Not pass it on to the actual object - incr _nrefs - } - - method Release {} { - my variable _nrefs - if {[incr _nrefs -1] == 0} { - my destroy - } - } - - method DebugRefCounts {} { - my variable _nrefs - my variable _ifc - - # Return out internal ref as well as the COM ones - # Note latter are unstable and only to be used for - # debugging - twapi::IUnknown_AddRef $_ifc - return [list $_nrefs [twapi::IUnknown_Release $_ifc]] - } - - method QueryInterface {name_or_iid} { - my variable _ifc - lassign [::twapi::_resolve_iid $name_or_iid] iid name - return [::twapi::Twapi_IUnknown_QueryInterface $_ifc $iid $name] - } - - # Same as QueryInterface except return "" instead of exception - # if interface not found and returns proxy object instead of interface - method @QueryInterface {name_or_iid {set_blanket 0}} { - my variable _blanket - ::twapi::trap { - set proxy [::twapi::make_interface_proxy [my QueryInterface $name_or_iid]] - if {$set_blanket && [llength $_blanket]} { - $proxy @SetSecurityBlanket $_blanket - } - return $proxy - } onerror {TWAPI_WIN32 0x80004002} { - # No such interface, return "", don't generate error - return "" - } onerror {} { - if {[info exists proxy]} { - catch {$proxy Release} - } - rethrow - } - } - - method @Type {} { - my variable _ifc - return [::twapi::pointer_type $_ifc] - } - - method @Type? {type} { - my variable _ifc - return [::twapi::pointer? $_ifc $type] - } - - method @Null? {} { - my variable _ifc - return [::twapi::pointer_null? $_ifc] - } - - # Returns raw interface. Caller must call IUnknown_Release on it - # iff addref is passed as true (default) - method @Interface {{addref 1}} { - my variable _ifc - if {$addref} { - ::twapi::IUnknown_AddRef $_ifc - } - return $_ifc - } - - # Returns out class id - old deprecated - use GetCLSID - method @Clsid {} { - my variable _clsid - return $_clsid - } - - method @GetCLSID {} { - my variable _clsid - return $_clsid - } - - method @SetCLSID {clsid} { - my variable _clsid - set _clsid $clsid - return - } - - method @SetSecurityBlanket blanket { - my variable _ifc _blanket - # In-proc components will not support IClientSecurity interface - # and will raise an error. That's the for the caller to be careful - # about. - twapi::CoSetProxyBlanket $_ifc {*}$blanket - set _blanket $blanket - return - } - - method @GetSecurityBlanket {} { - my variable _blanket - return $_blanket - } - - - twapi_exportall -} - -twapi::class create ::twapi::IDispatchProxy { - superclass ::twapi::IUnknownProxy - - destructor { - my variable _typecomp - if {[info exists _typecomp] && $_typecomp ne ""} { - $_typecomp Release - } - next - } - - method GetTypeInfoCount {} { - my variable _ifc - return [::twapi::IDispatch_GetTypeInfoCount $_ifc] - } - - # names is list - method name followed by parameter names - # Returns list of name dispid pairs - method GetIDsOfNames {names {lcid 0}} { - my variable _ifc - return [::twapi::IDispatch_GetIDsOfNames $_ifc $names $lcid] - } - - # Get dispid of a method (without parameter names) - method @GetIDOfOneName {name {lcid 0}} { - return [lindex [my GetIDsOfNames [list $name] $lcid] 1] - } - - method GetTypeInfo {{infotype 0} {lcid 0}} { - my variable _ifc - if {$infotype != 0} {error "Parameter infotype must be 0"} - return [::twapi::IDispatch_GetTypeInfo $_ifc $infotype $lcid] - } - - method @GetTypeInfo {{lcid 0}} { - return [::twapi::make_interface_proxy [my GetTypeInfo 0 $lcid]] - } - - method Invoke {prototype args} { - my variable _ifc - if {[llength $prototype] == 0 && [llength $args] == 0} { - # Treat as a property get DISPID_VALUE (default value) - # {dispid=0, lcid=0 cmd=propget(2) ret type=bstr(8) {} (no params)} - set prototype {0 0 2 8 {}} - } else { - # TBD - optimize by precomputing if a prototype needs this processing - # If any arguments are comobjs, may need to replace with the - # IDispatch interface. - # Moreover, we have to manage the reference counts for both - # IUnknown and IDispatch - - # - If the parameter is an IN parameter, ref counts do not need - # to change. - # - If the parameter is an OUT parameter, we are not passing - # an interface in, so nothing to do - # - If the parameter is an INOUT, we need to AddRef it since - # the COM method will Release it when storing a replacement - # HERE WE ONLY DO THE CHECK FOR COMOBJ. The AddRef checks are - # DONE IN THE C CODE (if necessary) - - set iarg -1 - set args2 {} - foreach arg $args { - incr iarg - # TBD - optimize this loop - set argtype [lindex $prototype 4 $iarg 0] - set argflags 0 - if {[llength [lindex $prototype 4 $iarg 1]]} { - set argflags [lindex $prototype 4 $iarg 1 0] - } - if {$argflags & 1} { - # IN param - if {$argflags & 2} { - # IN/OUT - # We currently do NOT handle a In/Out - skip for now TBD - # In the future we will have to check contents of - # the passed arg as a variable in the CALLER's context - } else { - # Pure IN param. Check if it is VT_DISPATCH or - # VT_VARIANT. Else nothing - # to do - if {[lindex $argtype 0] == 26} { - # Pointer, get base type - set argtype [lindex $argtype 1] - } - if {[lindex $argtype 0] == 9 || [lindex $argtype 0] == 12} { - # If a comobj was passed, need to extract the - # dispatch pointer. - if {[twapi::comobj? $arg]} { - # Note we do not addref when getting the interface - # (last param 0) because not necessary for IN - # params, AND it is the C code's responsibility - # anyways - set arg [$arg -interface 0] - } - } - } - - } else { - # Not an IN param. Nothing to be done - } - - lappend args2 $arg - } - set args $args2 - } - - # The uplevel is so that if some parameters are output, the varnames - # are resolved in caller - uplevel 1 [list ::twapi::IDispatch_Invoke $_ifc $prototype] $args - } - - # Methods are tried in the order specified by invkinds. - method @Invoke {name invkinds lcid params {namedargs {}}} { - if {$name eq ""} { - # Default method - return [uplevel 1 [list [self] Invoke {}] $params] - } - set nparams [llength $params] - - # We will try for each invkind to match. matches can be of - # different degrees, in descending priority - - # 1. prototype has parameter info and num params match exactly - # 2. prototype has parameter info and num params is greater - # than supplied arguments (assumes others have defaults) - # 3. prototype has no parameter information - # Within these classes, the order of invkinds determines - # priority - - if {$name eq "_NewEnum"} { - # Special case property to retrieve iterator. Some objects - # call it _NewEnum, others NewEnum. The disp id must always - # be -4 so we hard code that instead - # DISPID=-4 LCID=0 INVOKE=2(propget) RETTYPE=13(IUnknown) no parameters - set class1 [list {-4 0 2 13 {} {}}] - } else { - foreach invkind $invkinds { - set proto [my @Prototype $name $invkind $lcid] - if {[llength $proto]} { - if {[llength $proto] < 5} { - # No parameter information - lappend class3 $proto - } else { - if {[llength [lindex $proto 4]] == $nparams} { - lappend class1 $proto - break; # Class 1 match, no need to try others - } elseif {[llength [lindex $proto 4]] > $nparams} { - lappend class2 $proto - } else { - # Ignore - proto has fewer than supplied params - # Could not be a match - } - } - } - } - } - # For exact match (class1), we do not need the named - # arguments as positional arguments take priority. When - # number of passed parameters is fewer than those in - # prototype, check named arguments and use those - # values. If no parameter information, we can't use named - # arguments anyways. - - if {[info exists class1]} { - set matched_proto [lindex $class1 0] - } elseif {[info exists class2]} { - set matched_proto [lindex $class2 0] - # If we are passed named arguments AND the prototype also - # has parameter name information, replace the default values - # in the parameter definitions with the named arg value if - # it exists. - if {[llength $namedargs] && - [llength [set paramnames [lindex $matched_proto 5]]]} { - foreach {paramname paramval} $namedargs { - set paramindex [lsearch -nocase $paramnames $paramname] - if {$paramindex < 0} { - twapi::win32_error 0x80020004 "No parameter with name '$paramname' found for method '$name'" - } - - # Set the default value field of the - # appropriate parameter to the named arg value - set paramtype [lindex $matched_proto 4 $paramindex 0] - - # If parameter is VT_DISPATCH or VT_VARIANT, - # convert from comobj if necessary. - if {$paramtype == 9 || $paramtype == 12} { - if {[::twapi::comobj? $paramval]} { - # Note no AddRef when getting the interface - # (last param 0) because it is the C code's - # responsibility based on in/out direction - set paramval [$paramval -interface 0] - } - } - - # Replace the default value field for that param def - lset matched_proto 4 $paramindex [linsert [lrange [lindex $matched_proto 4 $paramindex] 0 1] 2 $paramval] - } - } - } elseif {[info exists class3]} { - set matched_proto [lindex $class3 0] - } - - if {[info exists matched_proto]} { - # Need uplevel so by-ref param vars are resolved correctly - return [uplevel 1 [list [self] Invoke $matched_proto] $params] - } - - # No prototype via typecomp / typeinfo available. - # No lcid worked. - # We have to use the last resort of GetIDsOfNames - set dispid [my @GetIDOfOneName [list $name] 0] - # TBD - should we cache result ? Probably not. - if {$dispid eq ""} { - twapi::win32_error 0x80020003 "No property or method found with name '$name'." - } - - # Try all invocation types except last in turn. If error is "Member not - # found" try the next prototype. - foreach invkind [lrange $invkinds 0 end-1] { - # Note params field (last) is missing signifying we do not - # know prototypes - set matched_proto [list $dispid 0 $invkind 8] - if {![catch { - uplevel 1 [list [self] Invoke $matched_proto] $params - } result ropts]} { - return $result - } - # If member not found error, keep going. Other errors, throw - lassign [dict get $ropts -errorcode] fac winerror - if {$fac ne "TWAPI_WIN32" && $winerror != -2147352573} { - # Some other error. - return -options $ropts $result - } - } - # Try the last one and hope for the best - set matched_proto [list $dispid 0 [lindex $invkinds end] 8] - return [uplevel 1 [list [self] Invoke $matched_proto] $params] - } - - # Get prototype that match the specified name - method @Prototype {name invkind lcid} { - my variable _ifc _guid _typecomp - - # Always need the GUID so get it we have not done so already - if {![info exists _guid]} { - my @InitTypeCompAndGuid - } - # Note above call may still have failed to init _guid - - # If we have been through here before and have our guid, - # check if a prototype exists and return it. - if {[info exists _guid] && $_guid ne "" && - [::twapi::_dispatch_prototype_get $_guid $name $lcid $invkind proto]} { - return $proto - } - - # Not in cache, have to look for it - # Use the ITypeComp for this interface if we do not - # already have it. We trap any errors because we will retry with - # different LCID's below. - set proto {} - if {![info exists _typecomp]} { - my @InitTypeCompAndGuid - } - if {$_typecomp ne ""} { - ::twapi::trap { - - set invkind [::twapi::_string_to_invkind $invkind] - set lhash [::twapi::LHashValOfName $lcid $name] - - if {![catch {$_typecomp Bind $name $lhash $invkind} binddata] && - [llength $binddata]} { - lassign $binddata type data ifc - if {$type eq "funcdesc" || - ($type eq "vardesc" && [::twapi::kl_get $data varkind] == 3)} { - set params {} - set bindti [::twapi::make_interface_proxy $ifc] - ::twapi::trap { - set params [::twapi::_resolve_params_for_prototype $bindti [::twapi::kl_get $data lprgelemdescParam]] - # Param names are needed for named arguments. Index 0 is method name so skip it - if {[catch {lrange [$bindti GetNames [twapi::kl_get $data memid]] 1 end} paramnames]} { - set paramnames {} - } - } finally { - $bindti Release - } - set proto [list [::twapi::kl_get $data memid] \ - $lcid \ - $invkind \ - [::twapi::kl_get $data elemdescFunc.tdesc] \ - $params $paramnames] - } else { - ::twapi::IUnknown_Release $ifc; # Don't need ifc but must release - twapi::debuglog "IDispatchProxy::@Prototype: Unexpected Bind type: $type, data: $data" - } - } - } onerror {} { - # Ignore and retry with other LCID's below - } - } - - - # If we do not have a guid return because even if we do not - # have a proto yet, falling through to try another lcid will not - # help and in fact will cause infinite recursion. - - if {$_guid eq ""} { - return $proto - } - - # We do have a guid, store the proto in cache (even if negative) - ::twapi::dispatch_prototype_set $_guid $name $lcid $invkind $proto - - # If we have the proto return it - if {[llength $proto]} { - return $proto - } - - # Could not find a matching prototype from the typeinfo/typecomp. - # We are not done yet. We will try and fall back to other lcid's - # Note we do this AFTER setting the prototype in the cache. That - # way we prevent (infinite) mutual recursion between lcid fallbacks. - # The fallback sequence is $lcid -> 0 -> 1033 - # (1033 is US English). Note lcid could itself be 1033 - # default and land up being checked twice times but that's - # ok since that's a one-time thing, and not very expensive either - # since the second go-around will hit the cache (negative). - # Note the time this is really useful is when the cache has - # been populated explicitly from a type library since in that - # case many interfaces land up with a US ENglish lcid (MSI being - # just one example) - - if {$lcid == 0} { - # Note this call may further recurse and return either a - # proto or empty (fail) - set proto [my @Prototype $name $invkind 1033] - } else { - set proto [my @Prototype $name $invkind 0] - } - - # Store it as *original* lcid. - ::twapi::dispatch_prototype_set $_guid $name $lcid $invkind $proto - - return $proto - } - - - # Initialize _typecomp and _guid. Not in constructor because may - # not always be required. Raises error if not available - method @InitTypeCompAndGuid {} { - my variable _guid _typecomp - - if {[info exists _typecomp]} { - # Based on code below, if _typecomp exists - # _guid also exists so no need to check for that - return - } - - ::twapi::trap { - set ti [my @GetTypeInfo 0] - } onerror {} { - # We do not raise an error because - # even without the _typecomp we can try invoking - # methods via IDispatch::GetIDsOfNames - twapi::debuglog "Could not ITypeInfo: [twapi::trapresult]" - if {![info exists _guid]} { - # Do not overwrite if already set thru @SetGuid or constructor - # Set to empty otherwise so we know we tried and failed - set _guid "" - } - set _typecomp "" - return - } - - ::twapi::trap { - # In case of dual interfaces, we need the typeinfo for the - # dispatch. Again, errors handled in try handlers - set attr [$ti GetTypeAttr] - switch -exact -- [::twapi::kl_get $attr typekind] { - 4 { - # Dispatch type, fine, just what we want - } - 3 { - # Interface type, Get the dispatch interface. If that fails, - # don't raise an error for the same reason as above - # if the interface itself is marked dispatchable - if {[catch { - $ti @GetRefTypeInfo [$ti GetRefTypeOfImplType -1] - } ti2 eropts]} { - # 4096 -> TYPEFLAG_FDISPATCHABLE - if {[::twapi::kl_get $attr wTypeFlags] & 4096} { - if {![info exists _guid]} { - # Do not overwrite if already set thru @SetGuid or constructor - # Set to empty otherwise so we know we tried and failed - # TBD - should we set _guid to [kl_get $attr guid] ? - set _guid "" - } - set _typecomp "" - return; # Note the finally clause will release $ti - } else { - # TBD - should we ignore errors even if dispatchable flag is not set? - return -options $eropts $ti2 - } - } - $ti Release - set ti $ti2 - } - default { - error "Interface is not a dispatch interface" - } - } - if {![info exists _guid]} { - # _guid might have already been valid, do not overwrite - set _guid [::twapi::kl_get [$ti GetTypeAttr] guid] - } - set _typecomp [$ti @GetTypeComp]; # ITypeComp - } finally { - $ti Release - } - } - - # Some COM objects like MSI do not have TypeInfo interfaces from - # where the GUID and TypeComp can be extracted. So we allow caller - # to explicitly set the GUID so we can look up methods in the - # dispatch prototype cache if it was populated directly by the - # application. If guid is not a valid GUID, an attempt is made - # to look it up as an IID name. - method @SetGuid {guid} { - my variable _guid - if {$guid eq ""} { - if {![info exists _guid]} { - my @InitTypeCompAndGuid - } - } else { - if {![::twapi::Twapi_IsValidGUID $guid]} { - set resolved_guid [::twapi::name_to_iid $guid] - if {$resolved_guid eq ""} { - error "Could not resolve $guid to a Interface GUID." - } - set guid $resolved_guid - } - - if {[info exists _guid] && $_guid ne ""} { - if {[string compare -nocase $guid $_guid]} { - error "Attempt to set the GUID to $guid when the dispatch proxy has already been initialized to $_guid" - } - } else { - set _guid $guid - } - } - - return $_guid - } - - method @GetCoClassTypeInfo {} { - my variable _ifc - - # We can get the typeinfo for the coclass in one of two ways: - # If the object supports IProvideClassInfo, we use it. Else - # we try the following: - # - from the idispatch, we get its typeinfo - # - from the typeinfo, we get the containing typelib - # - then we search the typelib for the coclass clsid - - ::twapi::trap { - set pci_ifc [my QueryInterface IProvideClassInfo] - set ti_ifc [::twapi::IProvideClassInfo_GetClassInfo $pci_ifc] - return [::twapi::make_interface_proxy $ti_ifc] - } onerror {} { - # Ignore - try the longer route if we were given the coclass clsid - } finally { - if {[info exists pci_ifc]} { - ::twapi::IUnknown_Release $pci_ifc - } - # Note - do not do anything with ti_ifc here, EVEN on error - } - - set co_clsid [my @Clsid] - if {$co_clsid eq ""} { - # E_FAIL - twapi::win32_error 0x80004005 "Could not get ITypeInfo for coclass: object does not support IProvideClassInfo and clsid not specified." - } - - set ti [my @GetTypeInfo] - ::twapi::trap { - set tl [lindex [$ti @GetContainingTypeLib] 0] - if {0} { - $tl @Foreach -guid $co_clsid -type coclass coti { - break - } - if {[info exists coti]} { - return $coti - } - } else { - return [$tl @GetTypeInfoOfGuid $co_clsid] - } - twapi::win32_error 0x80004005 "Could not find coclass."; # E_FAIL - } finally { - if {[info exists ti]} { - $ti Release - } - if {[info exists tl]} { - $tl Release - } - } - } - - twapi_exportall -} - - -twapi::class create ::twapi::IDispatchExProxy { - superclass ::twapi::IDispatchProxy - - method DeleteMemberByDispID {dispid} { - my variable _ifc - return [::twapi::IDispatchEx_DeleteMemberByDispID $_ifc $dispid] - } - - method DeleteMemberByName {name {lcid 0}} { - my variable _ifc - return [::twapi::IDispatchEx_DeleteMemberByName $_ifc $name $lcid] - } - - method GetDispID {name flags} { - my variable _ifc - return [::twapi::IDispatchEx_GetDispID $_ifc $name $flags] - } - - method GetMemberName {dispid} { - my variable _ifc - return [::twapi::IDispatchEx_GetMemberName $_ifc $dispid] - } - - method GetMemberProperties {dispid flags} { - my variable _ifc - return [::twapi::IDispatchEx_GetMemberProperties $_ifc $dispid $flags] - } - - # For some reason, order of args is different for this call! - method GetNextDispID {flags dispid} { - my variable _ifc - return [::twapi::IDispatchEx_GetNextDispID $_ifc $flags $dispid] - } - - method GetNameSpaceParent {} { - my variable _ifc - return [::twapi::IDispatchEx_GetNameSpaceParent $_ifc] - } - - method @GetNameSpaceParent {} { - return [::twapi::make_interface_proxy [my GetNameSpaceParent]] - } - - method @Prototype {name invkind {lcid 0}} { - set invkind [::twapi::_string_to_invkind $invkind] - - # First try IDispatch - ::twapi::trap { - set proto [next $name $invkind $lcid] - if {[llength $proto]} { - return $proto - } - # Note negative results ignored, as new members may be added/deleted - # to an IDispatchEx at any time. We will try below another way. - - } onerror {} { - # Ignore the error - we will try below using another method - } - - # Not a simple dispatch interface method. Could be expando - # type which is dynamically created. NOTE: The member is NOT - # created until the GetDispID call is made. - - # 10 -> case insensitive, create if required - set dispid [my GetDispID $name 10] - - # IMPORTANT : prototype retrieval results MUST NOT be cached since - # underlying object may add/delete members at any time. - - # No type information is available for dynamic members. - # TBD - is that really true? - - # Invoke kind - 1 (method), 2 (propget), 4 (propput) - if {$invkind == 1} { - # method - set flags 0x100 - } elseif {$invkind == 2} { - # propget - set flags 0x1 - } elseif {$invkind == 4} { - # propput - set flags 0x4 - } elseif {$invkind == 8 } { - # propputref - set flags 0x10 - } else { - error "Internal error: Invalid invkind value $invkind" - } - - # Try at least getting the invocation type but even that is not - # supported by all objects in which case we assume it can be invoked. - # TBD - in that case, why even bother doing GetMemberProperties? - if {! [catch { - set flags [expr {[my GetMemberProperties 0x115] & $flags}] - }]} { - if {! $flags} { - return {}; # EMpty proto -> no valid name for this invkind - } - } - - # Valid invkind or object does not support GetMemberProperties - # Return type is 8 (BSTR) but does not really matter as - # actual type will be set based on what is returned. - return [list $dispid $lcid $invkind 8] - } - - twapi_exportall -} - - -# ITypeInfo -#----------- - -twapi::class create ::twapi::ITypeInfoProxy { - superclass ::twapi::IUnknownProxy - - method GetRefTypeOfImplType {index} { - my variable _ifc - return [::twapi::ITypeInfo_GetRefTypeOfImplType $_ifc $index] - } - - method GetDocumentation {memid} { - my variable _ifc - return [::twapi::ITypeInfo_GetDocumentation $_ifc $memid] - } - - method GetImplTypeFlags {index} { - my variable _ifc - return [::twapi::ITypeInfo_GetImplTypeFlags $_ifc $index] - } - - method GetNames {index} { - my variable _ifc - return [::twapi::ITypeInfo_GetNames $_ifc $index] - } - - method GetTypeAttr {} { - my variable _ifc - return [::twapi::ITypeInfo_GetTypeAttr $_ifc] - } - - method GetFuncDesc {index} { - my variable _ifc - return [::twapi::ITypeInfo_GetFuncDesc $_ifc $index] - } - - method GetVarDesc {index} { - my variable _ifc - return [::twapi::ITypeInfo_GetVarDesc $_ifc $index] - } - - method GetIDsOfNames {names} { - my variable _ifc - return [::twapi::ITypeInfo_GetIDsOfNames $_ifc $names] - } - - method GetRefTypeInfo {hreftype} { - my variable _ifc - return [::twapi::ITypeInfo_GetRefTypeInfo $_ifc $hreftype] - } - - method @GetRefTypeInfo {hreftype} { - return [::twapi::make_interface_proxy [my GetRefTypeInfo $hreftype]] - } - - method GetTypeComp {} { - my variable _ifc - return [::twapi::ITypeInfo_GetTypeComp $_ifc] - } - - method @GetTypeComp {} { - return [::twapi::make_interface_proxy [my GetTypeComp]] - } - - method GetContainingTypeLib {} { - my variable _ifc - return [::twapi::ITypeInfo_GetContainingTypeLib $_ifc] - } - - method @GetContainingTypeLib {} { - lassign [my GetContainingTypeLib] itypelib index - return [list [::twapi::make_interface_proxy $itypelib] $index] - } - - method @GetRefTypeInfoFromIndex {index} { - return [my @GetRefTypeInfo [my GetRefTypeOfImplType $index]] - } - - # Friendlier version of GetTypeAttr - method @GetTypeAttr {args} { - - array set opts [::twapi::parseargs args { - all - guid - lcid - constructorid - destructorid - schema - instancesize - typekind - fncount - varcount - interfacecount - vtblsize - alignment - majorversion - minorversion - aliasdesc - flags - idldesc - memidmap - } -maxleftover 0] - - array set data [my GetTypeAttr] - set result [list ] - foreach {opt key} { - guid guid - lcid lcid - constructorid memidConstructor - destructorid memidDestructor - schema lpstrSchema - instancesize cbSizeInstance - fncount cFuncs - varcount cVars - interfacecount cImplTypes - vtblsize cbSizeVft - alignment cbAlignment - majorversion wMajorVerNum - minorversion wMinorVerNum - aliasdesc tdescAlias - } { - if {$opts(all) || $opts($opt)} { - lappend result -$opt $data($key) - } - } - - if {$opts(all) || $opts(typekind)} { - set typekind $data(typekind) - if {[info exists ::twapi::_typekind_map($typekind)]} { - set typekind $::twapi::_typekind_map($typekind) - } - lappend result -typekind $typekind - } - - if {$opts(all) || $opts(flags)} { - lappend result -flags [::twapi::_make_symbolic_bitmask $data(wTypeFlags) { - appobject 1 - cancreate 2 - licensed 4 - predeclid 8 - hidden 16 - control 32 - dual 64 - nonextensible 128 - oleautomation 256 - restricted 512 - aggregatable 1024 - replaceable 2048 - dispatchable 4096 - reversebind 8192 - proxy 16384 - }] - } - - if {$opts(all) || $opts(idldesc)} { - lappend result -idldesc [::twapi::_make_symbolic_bitmask $data(idldescType) { - in 1 - out 2 - lcid 4 - retval 8 - }] - } - - if {$opts(all) || $opts(memidmap)} { - set memidmap [list ] - for {set i 0} {$i < $data(cFuncs)} {incr i} { - array set fninfo [my @GetFuncDesc $i -memid -name] - lappend memidmap $fninfo(-memid) $fninfo(-name) - } - lappend result -memidmap $memidmap - } - - return $result - } - - # - # Get a variable description associated with a type - method @GetVarDesc {index args} { - # TBD - add support for retrieving elemdescVar.paramdesc fields - - array set opts [::twapi::parseargs args { - all - name - memid - schema - datatype - value - valuetype - varkind - flags - } -maxleftover 0] - - array set data [my GetVarDesc $index] - - set result [list ] - foreach {opt key} { - memid memid - schema lpstrSchema - datatype elemdescVar.tdesc - } { - if {$opts(all) || $opts($opt)} { - lappend result -$opt $data($key) - } - } - - - if {$opts(all) || $opts(value)} { - if {[info exists data(lpvarValue)]} { - # Const value - lappend result -value [lindex $data(lpvarValue) 1] - } else { - lappend result -value $data(oInst) - } - } - - if {$opts(all) || $opts(valuetype)} { - if {[info exists data(lpvarValue)]} { - lappend result -valuetype [lindex $data(lpvarValue) 0] - } else { - lappend result -valuetype int - } - } - - if {$opts(all) || $opts(varkind)} { - lappend result -varkind [::twapi::kl_get { - 0 perinstance - 1 static - 2 const - 3 dispatch - } $data(varkind) $data(varkind)] - } - - if {$opts(all) || $opts(flags)} { - lappend result -flags [::twapi::_make_symbolic_bitmask $data(wVarFlags) { - readonly 1 - source 2 - bindable 4 - requestedit 8 - displaybind 16 - defaultbind 32 - hidden 64 - restricted 128 - defaultcollelem 256 - uidefault 512 - nonbrowsable 1024 - replaceable 2048 - immediatebind 4096 - }] - } - - if {$opts(all) || $opts(name)} { - set result [concat $result [my @GetDocumentation $data(memid) -name]] - } - - return $result - } - - method @GetFuncDesc {index args} { - array set opts [::twapi::parseargs args { - all - name - memid - funckind - invkind - callconv - params - paramnames - flags - datatype - resultcodes - vtbloffset - } -maxleftover 0] - - array set data [my GetFuncDesc $index] - set result [list ] - - if {$opts(all) || $opts(paramnames)} { - lappend result -paramnames [lrange [my GetNames $data(memid)] 1 end] - } - foreach {opt key} { - memid memid - vtbloffset oVft - datatype elemdescFunc.tdesc - resultcodes lprgscode - } { - if {$opts(all) || $opts($opt)} { - lappend result -$opt $data($key) - } - } - - if {$opts(all) || $opts(funckind)} { - lappend result -funckind [::twapi::kl_get { - 0 virtual - 1 purevirtual - 2 nonvirtual - 3 static - 4 dispatch - } $data(funckind) $data(funckind)] - } - - if {$opts(all) || $opts(invkind)} { - lappend result -invkind [::twapi::_string_to_invkind $data(invkind)] - } - - if {$opts(all) || $opts(callconv)} { - lappend result -callconv [::twapi::kl_get { - 0 fastcall - 1 cdecl - 2 pascal - 3 macpascal - 4 stdcall - 5 fpfastcall - 6 syscall - 7 mpwcdecl - 8 mpwpascal - } $data(callconv) $data(callconv)] - } - - if {$opts(all) || $opts(flags)} { - lappend result -flags [::twapi::_make_symbolic_bitmask $data(wFuncFlags) { - restricted 1 - source 2 - bindable 4 - requestedit 8 - displaybind 16 - defaultbind 32 - hidden 64 - usesgetlasterror 128 - defaultcollelem 256 - uidefault 512 - nonbrowsable 1024 - replaceable 2048 - immediatebind 4096 - }] - } - - if {$opts(all) || $opts(params)} { - set params [list ] - foreach param $data(lprgelemdescParam) { - lassign $param paramtype paramdesc - set paramflags [::twapi::_paramflags_to_tokens [lindex $paramdesc 0]] - if {[llength $paramdesc] > 1} { - # There is a default value associated with the parameter - lappend params [list $paramtype $paramflags [lindex $paramdesc 1]] - } else { - lappend params [list $paramtype $paramflags] - } - } - lappend result -params $params - } - - if {$opts(all) || $opts(name)} { - set result [concat $result [my @GetDocumentation $data(memid) -name]] - } - - return $result - } - - # - # Get documentation for a element of a type - method @GetDocumentation {memid args} { - array set opts [::twapi::parseargs args { - all - name - docstring - helpctx - helpfile - } -maxleftover 0] - - lassign [my GetDocumentation $memid] name docstring helpctx helpfile - - set result [list ] - foreach opt {name docstring helpctx helpfile} { - if {$opts(all) || $opts($opt)} { - lappend result -$opt [set $opt] - } - } - return $result - } - - method @GetName {{memid -1}} { - return [lindex [my @GetDocumentation $memid -name] 1] - } - - method @GetImplTypeFlags {index} { - return [::twapi::_make_symbolic_bitmask \ - [my GetImplTypeFlags $index] \ - { - default 1 - source 2 - restricted 4 - defaultvtable 8 - }] - } - - # - # Get the typeinfo for the default source interface of a coclass - # This object must be the typeinfo of the coclass - method @GetDefaultSourceTypeInfo {} { - set count [lindex [my @GetTypeAttr -interfacecount] 1] - for {set i 0} {$i < $count} {incr i} { - set flags [my GetImplTypeFlags $i] - # default 0x1, source 0x2 - if {($flags & 3) == 3} { - # Our source interface implementation can only handle IDispatch - # so check if the source interface is that else keep looking. - # We even ignore dual interfaces because we cannot then - # assume caller will use the dispatch version - set ti [my @GetRefTypeInfoFromIndex $i] - array set typeinfo [$ti GetTypeAttr] - # typekind == 4 -> IDispatch, - # flags - 0x1000 -> dispatchable, 0x40 -> dual - if {$typeinfo(typekind) == 4 && - ($typeinfo(wTypeFlags) & 0x1000) && - !($typeinfo(wTypeFlags) & 0x40)} { - return $ti - } - $ti destroy - } - } - return "" - } - - twapi_exportall -} - - -# ITypeLib -#---------- - -twapi::class create ::twapi::ITypeLibProxy { - superclass ::twapi::IUnknownProxy - - method GetDocumentation {index} { - my variable _ifc - return [::twapi::ITypeLib_GetDocumentation $_ifc $index] - } - method GetTypeInfoCount {} { - my variable _ifc - return [::twapi::ITypeLib_GetTypeInfoCount $_ifc] - } - method GetTypeInfoType {index} { - my variable _ifc - return [::twapi::ITypeLib_GetTypeInfoType $_ifc $index] - } - method GetLibAttr {} { - my variable _ifc - return [::twapi::ITypeLib_GetLibAttr $_ifc] - } - method GetTypeInfo {index} { - my variable _ifc - return [::twapi::ITypeLib_GetTypeInfo $_ifc $index] - } - method @GetTypeInfo {index} { - return [::twapi::make_interface_proxy [my GetTypeInfo $index]] - } - method GetTypeInfoOfGuid {guid} { - my variable _ifc - return [::twapi::ITypeLib_GetTypeInfoOfGuid $_ifc $guid] - } - method @GetTypeInfoOfGuid {guid} { - return [::twapi::make_interface_proxy [my GetTypeInfoOfGuid $guid]] - } - method @GetTypeInfoType {index} { - set typekind [my GetTypeInfoType $index] - if {[info exists ::twapi::_typekind_map($typekind)]} { - set typekind $::twapi::_typekind_map($typekind) - } - return $typekind - } - - method @GetDocumentation {id args} { - array set opts [::twapi::parseargs args { - all - name - docstring - helpctx - helpfile - } -maxleftover 0] - - lassign [my GetDocumentation $id] name docstring helpctx helpfile - set result [list ] - foreach opt {name docstring helpctx helpfile} { - if {$opts(all) || $opts($opt)} { - lappend result -$opt [set $opt] - } - } - return $result - } - - method @GetName {} { - return [lindex [my GetDocumentation -1] 0] - } - - method @GetLibAttr {args} { - array set opts [::twapi::parseargs args { - all - guid - lcid - syskind - majorversion - minorversion - flags - } -maxleftover 0] - - array set data [my GetLibAttr] - set result [list ] - foreach {opt key} { - guid guid - lcid lcid - majorversion wMajorVerNum - minorversion wMinorVerNum - } { - if {$opts(all) || $opts($opt)} { - lappend result -$opt $data($key) - } - } - - if {$opts(all) || $opts(flags)} { - lappend result -flags [::twapi::_make_symbolic_bitmask $data(wLibFlags) { - restricted 1 - control 2 - hidden 4 - hasdiskimage 8 - }] - } - - if {$opts(all) || $opts(syskind)} { - lappend result -syskind [::twapi::kl_get { - 0 win16 - 1 win32 - 2 mac - } $data(syskind) $data(syskind)] - } - - return $result - } - - # - # Iterate through a typelib. Caller is responsible for releasing - # each ITypeInfo passed to it - # - method @Foreach {args} { - - array set opts [::twapi::parseargs args { - type.arg - name.arg - guid.arg - } -maxleftover 2 -nulldefault] - - if {[llength $args] != 2} { - error "Syntax error: Should be '[self] @Foreach ?options? VARNAME SCRIPT'" - } - - lassign $args varname script - upvar $varname varti - - set count [my GetTypeInfoCount] - for {set i 0} {$i < $count} {incr i} { - if {$opts(type) ne "" && $opts(type) ne [my @GetTypeInfoType $i]} { - continue; # Type does not match - } - if {$opts(name) ne "" && - [string compare -nocase $opts(name) [lindex [my @GetDocumentation $i -name] 1]]} { - continue; # Name does not match - } - set ti [my @GetTypeInfo $i] - if {$opts(guid) ne ""} { - if {[string compare -nocase [lindex [$ti @GetTypeAttr -guid] 1] $opts(guid)]} { - $ti Release - continue - } - } - set varti $ti - set ret [catch {uplevel 1 $script} result] - switch -exact -- $ret { - 1 { - error $result $::errorInfo $::errorCode - } - 2 { - return -code return $result; # TCL_RETURN - } - 3 { - set i $count; # TCL_BREAK - } - } - } - return - } - - method @Register {path {helppath ""}} { - my variable _ifc - ::twapi::RegisterTypeLib $_ifc $path $helppath - } - - method @LoadDispatchPrototypes {} { - set data [my @Read -type dispatch] - if {![dict exists $data dispatch]} { - return - } - - dict for {guid guiddata} [dict get $data dispatch] { - foreach type {methods properties} { - if {[dict exists $guiddata -$type]} { - dict for {name namedata} [dict get $guiddata -$type] { - dict for {lcid lciddata} $namedata { - dict for {invkind proto} $lciddata { - ::twapi::dispatch_prototype_set \ - $guid $name $lcid $invkind $proto - } - } - } - } - } - } - } - - method @Text {args} { - array set opts [::twapi::parseargs args { - type.arg - name.arg - } -maxleftover 0 -nulldefault] - - set text {} - my @Foreach -type $opts(type) -name $opts(name) ti { - ::twapi::trap { - array set attrs [$ti @GetTypeAttr -all] - set docs [$ti @GetDocumentation -1 -name -docstring] - set desc "[string totitle $attrs(-typekind)] [::twapi::kl_get $docs -name] $attrs(-guid) - [::twapi::kl_get $docs -docstring]\n" - switch -exact -- $attrs(-typekind) { - record - - union - - enum { - for {set j 0} {$j < $attrs(-varcount)} {incr j} { - array set vardata [$ti @GetVarDesc $j -all] - set vardesc "$vardata(-varkind) [::twapi::_resolve_com_type_text $ti $vardata(-datatype)] $vardata(-name)" - if {$attrs(-typekind) eq "enum"} { - append vardesc " = $vardata(-value) ([::twapi::_resolve_com_type_text $ti $vardata(-valuetype)])" - } else { - append vardesc " (offset $vardata(-value))" - } - append desc "\t$vardesc\n" - } - } - alias { - append desc "\ttypedef $attrs(-aliasdesc)\n" - } - module - - dispatch - - interface { - append desc [::twapi::_interface_text $ti] - } - coclass { - for {set j 0} {$j < $attrs(-interfacecount)} {incr j} { - set ti2 [$ti @GetRefTypeInfoFromIndex $j] - set idesc [$ti2 @GetName] - set iflags [$ti @GetImplTypeFlags $j] - if {[llength $iflags]} { - append idesc " ([join $iflags ,])" - } - append desc \t$idesc - $ti2 Release - unset ti2 - } - } - default { - append desc "Unknown typekind: $attrs(-typekind)\n" - } - } - append text \n$desc - } finally { - $ti Release - if {[info exists ti2]} { - $ti2 Release - } - } - } - return $text - } - - method @GenerateCode {args} { - array set opts [twapi::parseargs args { - namespace.arg - } -ignoreunknown] - - if {![info exists opts(namespace)]} { - set opts(namespace) [string tolower [my @GetName]] - } - - set data [my @Read {*}$args] - - set code {} - - # If namespace specfied as empty string (as opposed to unspecified) - # do not output a namespace - if {$opts(namespace) ne "" && - ([dict exists $data enum] || - [dict exists $data module] || - [dict exists $data coclass]) - } { - append code "\nnamespace eval $opts(namespace) \{\n" - append code "\n # Array mapping coclass names to their guids\n" - append code " variable _coclass_guids\n" - append code "\n # Array mapping dispatch interface names to their guids\n" - append code " variable _dispatch_guids\n" - append code { - # 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 $typename." - } - } - }; # append code... - - if {[dict exists $data module]} { - dict for {guid guiddata} [dict get $data module] { - # Some modules may not have constants (-values). - # We currently only output constants from modules, not functions - if {[dict exists $guiddata -values]} { - set module_name [dict get $guiddata -name] - append code "\n # Module $module_name ($guid)\n" - append code " [list array set $module_name [dict get $guiddata -values]]" - append code \n - } - } - } - - if {[dict exists $data enum]} { - dict for {name def} [dict get $data enum] { - append code "\n # Enum $name\n" - append code " [list array set $name [dict get $def -values]]" - append code \n - } - } - - if {[dict exists $data coclass]} { - dict for {guid def} [dict get $data coclass] { - append code "\n # Coclass [dict get $def -name]" - # Look for the default interface so we can remember its GUID. - # This is necessary for the cases where the Dispatch interface - # GUID is not available via a TypeInfo interface (e.g. - # a 64-bit COM component not registered with the 32-bit - # COM registry) - if {[dict exists $def -defaultdispatch]} { - set default_dispatch_guid [dict get $def -defaultdispatch] - append code "\n set ::twapi::_coclass_idispatch_guids($guid) \"$default_dispatch_guid\"\n" - } else { - set default_dispatch_guid "" - } - - # We assume here that coclass has a default interface - # which is dispatchable. Else an error will be generated - # at runtime. - append code [format { - set _coclass_guids(%1$s) "%2$s" - twapi::class create %1$s { - superclass ::twapi::Automation - constructor {args} { - set ifc [twapi::com_create_instance "%2$s" -interface IDispatch -raw {*}$args] - next [twapi::IDispatchProxy new $ifc "%2$s"] - if {[string length "%3$s"]} { - my -interfaceguid "%3$s" - } - } - }} [dict get $def -name] $guid $default_dispatch_guid] - append code \n - } - } - - if {$opts(namespace) ne "" && - ([dict exists $data enum] || - [dict exists $data module] || - [dict exists $data coclass]) - } { - append code "\}" - append code \n - } - - if {[dict exists $data dispatch]} { - dict for {guid guiddata} [dict get $data dispatch] { - set dispatch_name [dict get $guiddata -name] - append code "\n# Dispatch Interface $dispatch_name\n" - append code "set [set opts(namespace)]::_dispatch_guids($dispatch_name) \"$guid\"\n" - foreach type {methods properties} { - if {[dict exists $guiddata -$type]} { - append code "# $dispatch_name [string totitle $type]\n" - dict for {name namedata} [dict get $guiddata -$type] { - dict for {lcid lciddata} $namedata { - dict for {invkind proto} $lciddata { - append code [list ::twapi::dispatch_prototype_set \ - $guid $name $lcid $invkind $proto] - append code \n - } - } - } - } - } - } - } - - return $code - } - - method @Read {args} { - array set opts [::twapi::parseargs args { - type.arg - name.arg - } -maxleftover 0 -nulldefault] - - # Dictionary to contain result - set data [dict create] - - # Entries for coclasses and dispatch interfaces have a mutual - # dependency. Generation of dispatch interface method - # prototypes need to (potentially) resolve coclass names - # that map to dispatch interfaces. - # Conversely, that resolution requires a list of dispatch - # interface guids so gather that first. - - # List of dispatch guids - array set dispatch_guids {} - if {$opts(type) in {{} coclass dispatch}} { - # Collect dispatch guids. Note we do not collect other - # dispatch details since prototypes will need the coclass - # information which we do not have yet - my @Foreach -type dispatch ti { - ::twapi::trap { - set dispatch_guids([dict get [$ti GetTypeAttr] guid]) "" - } finally { - $ti Release - } - } - # Now that we have dispatch guids, collect coclass information - my @Foreach -type coclass ti { - ::twapi::trap { - array set attrs [$ti @GetTypeAttr -guid -lcid -varcount -fncount -interfacecount -typekind] - set name [lindex [$ti @GetDocumentation -1 -name] 1] - dict set data "coclass" $attrs(-guid) -name $name - for {set j 0} {$j < $attrs(-interfacecount)} {incr j} { - set ti2 [$ti @GetRefTypeInfoFromIndex $j] - set iflags [$ti GetImplTypeFlags $j] - set iguid [twapi::kl_get [$ti2 GetTypeAttr] guid] - set iname [$ti2 @GetName] - $ti2 Release - unset ti2; # So finally clause does not release again on error - - dict set data "coclass" $attrs(-guid) -interfaces $iguid -name $iname - dict set data "coclass" $attrs(-guid) -interfaces $iguid -flags $iflags - - # If this is a dispatch interface and the default interface - # for the coclass, add it to coclass default dispatch database. - # This will be used to resolve dispatch prototypes - if {$iflags == 1 && [info exists dispatch_guids($iguid)]} { - # This is used by the parameter resolution code in - # _resolve_comtype while building prototypes - set ::twapi::_coclass_idispatch_guids($attrs(-guid)) $iguid - dict set data "coclass" $attrs(-guid) -defaultdispatch $iguid - } - } - } finally { - if {[info exists ti2]} { - $i2 Release - } - $ti Release - } - } - } - - # If we were only looking for coclass information, we already have it - if {$opts(type) eq "coclass"} { - return $data - } - - my @Foreach -type $opts(type) -name $opts(name) ti { - ::twapi::trap { - array set attrs [$ti @GetTypeAttr -guid -lcid -varcount -fncount -interfacecount -typekind] - set name [lindex [$ti @GetDocumentation -1 -name] 1] - # dict set data $attrs(-typekind) $name {} - switch -exact -- $attrs(-typekind) { - record - - union - - enum { - # For consistency with the coclass and dispatch dict structure - # we have a separate key for 'name' even though it is the same - # as the dict key - dict set data $attrs(-typekind) $name -name $name - for {set j 0} {$j < $attrs(-varcount)} {incr j} { - array set vardata [$ti @GetVarDesc $j -name -value] - dict set data $attrs(-typekind) $name -values $vardata(-name) $vardata(-value) - } - } - alias { - # TBD - anything worth importing ? - } - dispatch { - # Load up the functions - dict set data $attrs(-typekind) $attrs(-guid) -name $name - for {set j 0} {$j < $attrs(-fncount)} {incr j} { - array set funcdata [$ti GetFuncDesc $j] - if {$funcdata(funckind) != 4} { - # Not a dispatch function (4), ignore - # TBD - what else could it be if already filtering - # typeinfo on dispatch - # Vtable set funckind "(vtable $funcdata(-oVft))" - ::twapi::debuglog "Unexpected funckind value '$funcdata(funckind)' ignored. funcdata: [array get funcdata]" - continue; - } - - set proto [list $funcdata(memid) \ - $attrs(-lcid) \ - $funcdata(invkind) \ - $funcdata(elemdescFunc.tdesc) \ - [::twapi::_resolve_params_for_prototype $ti $funcdata(lprgelemdescParam)]] - # Param names are needed for named arguments. Index 0 is method name so skip it - if {[catch {lappend proto [lrange [$ti GetNames $funcdata(memid)] 1 end]}]} { - # Could not get param names - lappend proto {} - } - - dict set data "$attrs(-typekind)" \ - $attrs(-guid) \ - -methods \ - [$ti @GetName $funcdata(memid)] \ - $attrs(-lcid) \ - $funcdata(invkind) \ - $proto - } - # Load up the properties - for {set j 0} {$j < $attrs(-varcount)} {incr j} { - array set vardata [$ti GetVarDesc $j] - # We will add both propput and propget. - # propget: - dict set data "$attrs(-typekind)" \ - $attrs(-guid) \ - -properties \ - [$ti @GetName $vardata(memid)] \ - $attrs(-lcid) \ - 2 \ - [list $vardata(memid) $attrs(-lcid) 2 $vardata(elemdescVar.tdesc) {} {}] - - # TBD - mock up the parameters for the property set - # Single parameter corresponding to return type of - # property. Param list is of the form - # {PARAM1 PARAM2} where PARAM is {TYPE {FLAGS ?DEFAULT}} - # So param list with one param is - # {{TYPE {FLAGS ?DEFAULT?}}} - # propput: - if {! ($vardata(wVarFlags) & 1)} { - # Not read-only - dict set data "$attrs(-typekind)" \ - $attrs(-guid) \ - -properties \ - [$ti @GetName $vardata(memid)] \ - $attrs(-lcid) \ - 4 \ - [list $vardata(memid) $attrs(-lcid) 4 24 [list [list $vardata(elemdescVar.tdesc) [list 1]]] {}] - } - } - } - - module { - dict set data $attrs(-typekind) $attrs(-guid) -name $name - # TBD - Load up the functions - - # Now load up the variables - for {set j 0} {$j < $attrs(-varcount)} {incr j} { - array set vardata [$ti @GetVarDesc $j -name -value] - dict set data $attrs(-typekind) $attrs(-guid) -values $vardata(-name) $vardata(-value) - } - } - - interface { - # TBD - } - - coclass { - # We have already collected this information before this loop - continue - } - default { - # TBD - } - } - } finally { - $ti Release - if {[info exists ti2]} { - $ti2 Release - } - } - } - - # Unless we are collecting coclass info, remove any related info - # that we might have gathered for dispatch prototypes - if {$opts(type) ni {{} coclass}} { - dict unset data "coclass" - } - return $data - } - - twapi_exportall -} - -# ITypeComp -#---------- -twapi::class create ::twapi::ITypeCompProxy { - superclass ::twapi::IUnknownProxy - - method Bind {name lhash flags} { - my variable _ifc - return [::twapi::ITypeComp_Bind $_ifc $name $lhash $flags] - } - - # Returns empty list if bind not found - method @Bind {name flags {lcid 0}} { - ::twapi::trap { - set binding [my Bind $name [::twapi::LHashValOfName $lcid $name] $flags] - } onerror {TWAPI_WIN32 0x80028ca0} { - # Found but type mismatch (flags not correct) - return {} - } - - lassign $binding type data tifc - return [list $type $data [::twapi::make_interface_proxy $tifc]] - } - - twapi_exportall -} - -# IEnumVARIANT -#------------- - -twapi::class create ::twapi::IEnumVARIANTProxy { - superclass ::twapi::IUnknownProxy - - method Next {count {value_only 0}} { - my variable _ifc - return [::twapi::IEnumVARIANT_Next $_ifc $count $value_only] - } - method Clone {} { - my variable _ifc - return [::twapi::IEnumVARIANT_Clone $_ifc] - } - method @Clone {} { - return [::twapi::make_interface_proxy [my Clone]] - } - method Reset {} { - my variable _ifc - return [::twapi::IEnumVARIANT_Reset $_ifc] - } - method Skip {count} { - my variable _ifc - return [::twapi::IEnumVARIANT_Skip $_ifc $count] - } - - twapi_exportall -} - -# Automation -#----------- -twapi::class create ::twapi::Automation { - - # Caller gives up ownership of proxy in all cases, even errors. - # $proxy will eventually be Release'ed. If caller wants to keep - # a reference to it, it must do an *additional* AddRef on it to - # keep it from going away when the Automation object releases it. - constructor {proxy {lcid 0}} { - my variable _proxy _lcid _sinks _connection_pts - - set type [$proxy @Type] - if {$type ne "IDispatch" && $type ne "IDispatchEx"} { - $proxy Release; # Even on error, responsible for releasing - error "Automation objects do not support interfaces of type '$type'" - } - if {$type eq "IDispatchEx"} { - my variable _have_dispex - # If _have_dispex variable - # - does not exist, have not tried to get IDispatchEx yet - # - is 0, have tried but failed - # - is 1, already have IDispatchEx - set _have_dispex 1 - } - - set _proxy $proxy - set _lcid $lcid - array set _sinks {} - array set _connection_pts {} - } - - destructor { - my variable _proxy _sinks - - # Release sinks, connection points - foreach sinkid [array names _sinks] { - my -unbind $sinkid - } - - if {[info exists _proxy]} { - $_proxy Release - } - return - } - - # Intended to be called only from another method. Not directly. - # Does an uplevel 2 to get to application context. - # On failures, retries with IDispatchEx interface - # TBD - get rid of this uplevel business by having internal - # callers to equivalent of "uplevel 1 my _invoke ... - method _invoke {name invkinds params args} { - my variable _proxy _lcid - - if {[$_proxy @Null?]} { - error "Attempt to invoke method $name on NULL COM object" - } - - array set opts [twapi::parseargs args { - raw.bool - namedargs.arg - } -nulldefault -maxleftover 0] - - ::twapi::trap { - set vtval [uplevel 2 [list $_proxy @Invoke $name $invkinds $_lcid $params $opts(namedargs)]] - if {$opts(raw)} { - return $vtval - } else { - return [::twapi::variant_value $vtval 0 0 $_lcid] - } - } onerror {} { - # TBD - should we only drop down below to check for IDispatchEx - # for specific error codes. Right now we do it for all. - set erinfo $::errorInfo - set ercode $::errorCode - set ermsg [::twapi::trapresult] - } - - # We plan on trying to get a IDispatchEx interface in case - # the method/property is the "expando" type - my variable _have_dispex - if {[info exists _have_dispex]} { - # We have already tried for IDispatchEx, either successfully - # or not. Either way, no need to try again - error $ermsg $erinfo $ercode - } - - # Try getting a IDispatchEx interface - if {[catch {$_proxy @QueryInterface IDispatchEx 1} proxy_ex] || - $proxy_ex eq ""} { - set _have_dispex 0 - error $ermsg $erinfo $ercode - } - - set _have_dispex 1 - $_proxy Release - set _proxy $proxy_ex - - # Retry with the IDispatchEx interface - set vtval [uplevel 2 [list $_proxy @Invoke $name $invkinds $_lcid $params $opts(namedargs)]] - if {$opts(raw)} { - return $vtval - } else { - return [::twapi::variant_value $vtval 0 0 $_lcid] - } - } - - method -get {name args} { - return [my _invoke $name [list 2] $args] - } - - method -put {name args} { - return [my _invoke $name [list 4] $args] - } - forward -set my -put - - method -putref {name args} { - return [my _invoke $name [list 8] $args] - } - - method -call {name args} { - return [my _invoke $name [list 1] $args] - } - - method -callnamedargs {name args} { - return [my _invoke $name [list 1] {} -namedargs $args] - } - - # Need a wrapper around _invoke in order for latter's uplevel 2 - # to work correctly - # TBD - document, test - method -invoke {name invkinds params args} { - return [my _invoke $name $invkinds $params {*}$args] - } - - method -destroy {} { - my destroy - } - - method -isnull {} { - my variable _proxy - return [$_proxy @Null?] - } - - method -default {} { - my variable _proxy _lcid - return [::twapi::variant_value [$_proxy Invoke ""] 0 0 $_lcid] - } - - # Caller must call release on the proxy - method -proxy {} { - my variable _proxy - $_proxy AddRef - return $_proxy - } - - # Only for debugging - method -proxyrefcounts {} { - my variable _proxy - return [$_proxy DebugRefCounts] - } - - # Returns the raw interface. Caller must call IUnknownRelease on it - # iff addref is passed as true (default) - method -interface {{addref 1}} { - my variable _proxy - return [$_proxy @Interface $addref] - } - - # Validates internal structures - method -validate {} { - twapi::ValidateIUnknown [my -interface 0] - } - - # Set/return the GUID for the interface - method -interfaceguid {{guid ""}} { - my variable _proxy - return [$_proxy @SetGuid $guid] - } - - # Sets the idispatch or coclass of the object - method -instanceof {coclass} { - # The coclass may be a GUID or the Tcl name - if {[::twapi::Twapi_IsValidGUID $coclass]} { - if {[info exists ::twapi::_coclass_idispatch_guids($coclass)]} { - $comobj -interfaceguid $::twapi::_coclass_idispatch_guids($coclass) - } - error "Could not resolve interface for coclass GUID $coclass." - } - # Check for corresponding Tcl class name generated from a type - # library - set ns [namespace qualifiers $coclass] - if {$ns eq ""} { - error "Coclass name must be qualified with name of containing namespace." - } - uplevel 1 [list ${ns}::declare [namespace tail $coclass] [self]] - } - - # Return the disp id for a method/property - method -dispid {name} { - my variable _proxy - return [$_proxy @GetIDOfOneName $name] - } - - # Prints methods in an interface - method -print {} { - my variable _proxy - ::twapi::dispatch_print $_proxy - } - - method -with {subobjlist args} { - # $obj -with SUBOBJECTPATHLIST arguments - # where SUBOBJECTPATHLIST is list each element of which is - # either a property or a method of the previous element in - # the list. The element may itself be a list in which case - # the first element is the property/method and remaining - # are passed to it - # - # Note that 'arguments' may themselves be comobj subcommands! - set next [self] - set releaselist [list ] - ::twapi::trap { - while {[llength $subobjlist]} { - set nextargs [lindex $subobjlist 0] - set subobjlist [lrange $subobjlist 1 end] - set next [uplevel 1 [list $next] $nextargs] - lappend releaselist $next - } - # We use uplevel here because again we want to run in caller - # context - return [uplevel 1 [list $next] $args] - } finally { - foreach next $releaselist { - $next -destroy - } - } - } - - method -iterate {args} { - my variable _lcid - - array set opts [::twapi::parseargs args { - cleanup - }] - - if {[llength $args] < 2} { - error "Syntax: COMOBJ -iterate ?options? VARNAME SCRIPT" - } - upvar 1 [lindex $args 0] var - set script [lindex $args 1] - - # First get IEnumVariant iterator using the _NewEnum method - # TBD - As per MS OLE Automation spec, it appears _NewEnum - # MUST have dispid -4. Can we use this information when - # this object does not have an associated interface guid or - # when no prototype is available ? - set enumerator [my -get _NewEnum] - # This gives us an IUnknown. - ::twapi::trap { - # Convert the IUnknown to IEnumVARIANT - set iter [$enumerator @QueryInterface IEnumVARIANT] - if {! [$iter @Null?]} { - set more 1 - while {$more} { - # Get the next item from iterator - set next [$iter Next 1] - lassign $next more values - if {[llength $values]} { - set var [::twapi::variant_value [lindex $values 0] 0 0 $_lcid] - set ret [catch {uplevel 1 $script} msg options] - switch -exact -- $ret { - 0 - - 4 { - # Body executed successfully, or invoked continue - if {$opts(cleanup)} { - $var destroy - } - } - 3 { - if {$opts(cleanup)} { - $var destroy - } - set more 0; # TCL_BREAK - } - 1 - - 2 - - default { - if {$opts(cleanup)} { - $var destroy - } - dict incr options -level - return -options $options $msg - } - - } - } - } - } - } finally { - $enumerator Release - if {[info exists iter] && ![$iter @Null?]} { - $iter Release - } - } - return - } - - method -bind {script} { - my variable _proxy _sinks _connection_pts - - # Get the coclass typeinfo and locate the source interface - # within it and retrieve disp id mappings - ::twapi::trap { - set coti [$_proxy @GetCoClassTypeInfo] - - # $coti is the coclass information. Get dispids for the default - # source interface for events and its guid - set srcti [$coti @GetDefaultSourceTypeInfo] - array set srcinfo [$srcti @GetTypeAttr -memidmap -guid] - - # TBD - implement IConnectionPointContainerProxy - # Now we need to get the actual connection point itself - set container [$_proxy QueryInterface IConnectionPointContainer] - set connpt_ifc [::twapi::IConnectionPointContainer_FindConnectionPoint $container $srcinfo(-guid)] - - # Finally, create our sink object - # TBD - need to make sure Automation object is not deleted or - # should the callback itself check? - # TBD - what guid should we be passing? CLSID or IID ? - set sink_ifc [::twapi::Twapi_ComServer $srcinfo(-guid) $srcinfo(-memidmap) [list ::twapi::_eventsink_callback [self] $script]] - - # OK, we finally have everything we need. Tell the event source - set sinkid [::twapi::IConnectionPoint_Advise $connpt_ifc $sink_ifc] - - set _sinks($sinkid) $sink_ifc - set _connection_pts($sinkid) $connpt_ifc - return $sinkid - } onerror {} { - # These are released only on error as otherwise they have - # to be kept until unbind time - foreach ifc {connpt_ifc sink_ifc} { - if {[info exists $ifc] && [set $ifc] ne ""} { - ::twapi::IUnknown_Release [set $ifc] - } - } - twapi::rethrow - } finally { - # In all cases, release any interfaces we created - # Note connpt_ifc and sink_ifc are released at unbind time except - # on error - foreach obj {coti srcti} { - if {[info exists $obj]} { - [set $obj] Release - } - } - if {[info exists container]} { - ::twapi::IUnknown_Release $container - } - } - } - - method -unbind {sinkid} { - my variable _proxy _sinks _connection_pts - - if {[info exists _connection_pts($sinkid)]} { - ::twapi::IConnectionPoint_Unadvise $_connection_pts($sinkid) $sinkid - unset _connection_pts($sinkid) - } - - if {[info exists _sinks($sinkid)]} { - ::twapi::IUnknown_Release $_sinks($sinkid) - unset _sinks($sinkid) - } - return - } - - method -securityblanket {args} { - my variable _proxy - if {[llength $args]} { - $_proxy @SetSecurityBlanket [lindex $args 0] - return - } else { - return [$_proxy @GetSecurityBlanket] - } - } - - method -lcid {{lcid ""}} { - my variable _lcid - if {$lcid ne ""} { - if {![string is integer -strict $lcid]} { - error "Invalid LCID $lcid" - } - set _lcid $lcid - } - return $_lcid - } - - method unknown {name args} { - # We have to figure out if it is a property get, property put - # or a method. We make a guess based on number of parameters. - # We specify an order to try based on this. The invoke will try - # all invocations in that order. - set nargs [llength $args] - if {$nargs == 0} { - # No arguments, cannot be propput*. Try propget and method - set invkinds [list 2 1] - } elseif {$nargs == 1} { - # One argument, likely propput, method, propget, propputref - # propputref is last as least likely - set invkinds [list 4 1 2 8] - } else { - # Multiple arguments, likely method, propput, propget, propputref - # propputref is last as least likely - set invkinds [list 1 4 2 8] - } - - return [my _invoke $name $invkinds $args] - } - - twapi_exportall -} - -# -# Singleton NULL comobj object. We want to override default destroy methods -# to prevent object from being destroyed. This is a backward compatibility -# hack and not fool proof since the command could just be renamed away. -twapi::class create twapi::NullAutomation { - superclass twapi::Automation - constructor {} { - next [twapi::make_interface_proxy {0 IDispatch}] - } - method -destroy {} { - # Silently ignore - } - method destroy {} { - # Silently ignore - } - twapi_exportall -} - -twapi::NullAutomation create twapi::comobj_null -# twapi::Automation create twapi::comobj_null [twapi::make_interface_proxy {0 IDispatch}] - -proc twapi::_comobj_cleanup {} { - foreach obj [comobj_instances] { - $obj destroy - } -} - -# In order for servers to release objects properly, the IUnknown interface -# must have the same security settings as were used in the object creation -# call. This is a helper for that. -proc twapi::_com_set_iunknown_proxy {ifc blanket} { - set iunk [Twapi_IUnknown_QueryInterface $ifc [_iid_iunknown] IUnknown] - trap { - CoSetProxyBlanket $iunk {*}$blanket - } finally { - IUnknown_Release $iunk - } -} - - -twapi::proc* twapi::_init_authnames {} { - variable _com_authsvc_to_name - variable _com_name_to_authsvc - variable _com_impersonation_to_name - variable _com_name_to_impersonation - variable _com_authlevel_to_name - variable _com_name_to_authlevel - - set _com_authsvc_to_name {0 none 9 negotiate 10 ntlm 14 schannel 16 kerberos 0xffffffff default} - set _com_name_to_authsvc [swapl $_com_authsvc_to_name] - set _com_name_to_impersonation {default 0 anonymous 1 identify 2 impersonate 3 delegate 4} - set _com_impersonation_to_name [swapl $_com_name_to_impersonation] - set _com_name_to_authlevel {default 0 none 1 connect 2 call 3 packet 4 packetintegrity 5 privacy 6} - set _com_authlevel_to_name [swapl $_com_name_to_authlevel] -} { -} - -twapi::proc* twapi::_com_authsvc_to_name {authsvc} { - _init_authnames -} { - variable _com_authsvc_to_name - return [dict* $_com_authsvc_to_name $authsvc] -} - -twapi::proc* twapi::_com_name_to_authsvc {name} { - _init_authnames -} { - variable _com_name_to_authsvc - if {[string is integer -strict $name]} { - return $name - } - return [dict! $_com_name_to_authsvc $name] -} - -twapi::proc* twapi::_com_authlevel_to_name {authlevel} { - _init_authnames -} { - variable _com_authlevel_to_name - return [dict* $_com_authlevel_to_name $authlevel] -} - -twapi::proc* twapi::_com_name_to_authlevel {name} { - _init_authnames -} { - variable _com_name_to_authlevel - if {[string is integer -strict $name]} { - return $name - } - return [dict! $_com_name_to_authlevel $name] -} - - -twapi::proc* twapi::_com_impersonation_to_name {imp} { - _init_authnames -} { - variable _com_impersonation_to_name - return [dict* $_com_impersonation_to_name $imp] -} - -twapi::proc* twapi::_com_name_to_impersonation {name} { - _init_authnames -} { - variable _com_name_to_impersonation - if {[string is integer -strict $name]} { - return $name - } - return [dict! $_com_name_to_impersonation $name] -} - -################################################################# -# COM server implementation -# WARNING: do not use any fancy TclOO features because it has to -# run under 8.5/metoo as well -# TBD - test scripts? - -twapi::class create twapi::ComFactory { - constructor {clsid member_map create_command_prefix} { - my variable _clsid _create_command_prefix _member_map _ifc - - set _clsid $clsid - set _member_map $member_map - set _create_command_prefix $create_command_prefix - - set _ifc [twapi::Twapi_ClassFactory $_clsid [list [self] _create_instance]] - } - - destructor { - # TBD - what happens if factory is destroyed while objects still - # exist ? - # App MUST explicitly destroy objects before exiting - my variable _class_registration_id - if {[info exists _class_registration_id]} { - twapi::CoRevokeClassObject $_class_registration_id - } - } - - # Called from Twapi_ClassFactory_CreateInstance to create a new object - # Should not be called from elsewhere - method _create_instance {iid} { - my variable _create_command_prefix _member_map - # Note [list {*}$foo] != $foo - consider when foo contains a ";" - set obj_prefix [uplevel #0 [list {*}$_create_command_prefix]] - twapi::trap { - # Since we are not holding on to this interface ourselves, - # we can pass it on without AddRef'ing it - return [twapi::Twapi_ComServer $iid $_member_map $obj_prefix] - } onerror {} { - $obj_prefix destroy - twapi::rethrow - } - } - - method register {args} { - my variable _clsid _create_command_prefix _member_map _ifc _class_registration_id - twapi::parseargs args { - {model.arg any} - } -setvars -maxleftover 0 - set model_flags 0 - foreach m $model { - switch -exact -- $m { - any {twapi::setbits model_flags 20} - localserver {twapi::setbits model_flags 4} - remoteserver {twapi::setbits model_flags 16} - default {twapi::badargs! "Invalid COM class model '$m'"} - } - } - - # 0x6 -> REGCLS_MULTI_SEPARATE | REGCLS_SUSPENDED - set _class_registration_id [twapi::CoRegisterClassObject $_clsid $_ifc $model_flags 0x6] - return - } - - export _create_instance -} - -proc twapi::comserver_factory {clsid member_map command_prefix {name {}}} { - if {$name ne ""} { - uplevel 1 [list [namespace current]::ComFactory create $name $clsid $member_map $command_prefix] - } else { - uplevel 1 [list [namespace current]::ComFactory new $clsid $member_map $command_prefix] - } -} - -proc twapi::start_factories {{cmd {}}} { - # TBD - what if no class objects ? - CoResumeClassObjects - - if {[llength $cmd]} { - # TBD - normalize $cmd so to run in right namespace etc. - trace add variable [namspace current]::com_shutdown_signal write $cmd - return - } - - # This is set from the C code when we are not serving up any - # COM objects (either event callbacks or com servers) - vwait [namespace current]::com_shutdown_signal -} - -proc twapi::suspend_factories {} { - CoSuspendClassObjects -} - -proc twapi::resume_factories {} { - CoResumeClassObjects -} - -proc twapi::install_coclass_script {progid clsid version script_path args} { - # Need to extract params so we can prefix script name - set saved_args $args - array set opts [parseargs args { - params.arg - } -ignoreunknown] - - set script_path [file normalize $script_path] - - # Try to locate the wish executable to run the component - if {[info commands wm] eq ""} { - set dir [file dirname [info nameofexecutable]] - set wishes [glob -nocomplain -directory $dir wish*.exe] - if {[llength $wishes] == 0} { - error "Could not locate wish program." - } - set wish [lindex $wishes 0] - } else { - # We are running wish already - set wish [info nameofexecutable] - } - - set exe_path [file nativename [file attributes $wish -shortname]] - - set params "\"$script_path\"" - if {[info exists opts(params)]} { - append params " $params" - } - return [install_coclass $progid $clsid $version $exe_path {*}$args -outproc -params $params] -} - -proc twapi::install_coclass {progid clsid version path args} { - array set opts [twapi::parseargs args { - {scope.arg user {user system}} - appid.arg - appname.arg - inproc - outproc - service - params.arg - name.arg - } -maxleftover 0] - - switch [tcl::mathop::+ $opts(inproc) $opts(outproc) $opts(service)] { - 0 { - # Need to figure out the type - switch [file extension $path] { - .exe { set opts(outproc) 1 } - .ocx - - .dll { set opts(inproc) 1 } - default { set opts(service) 1 } - } - } - 1 {} - default { - badargs! "Only one of -inproc, -outproc or -service may be specified" - } - } - - if {(! [string is integer -strict $version]) || $version <= 0} { - twapi::badargs! "Invalid version '$version'. Must be a positive integer" - } - if {![regexp {^[[:alpha:]][[:alnum:]]*\.[[:alpha:]][[:alnum:]]*$} $progid]} { - badargs! "Invalid PROGID syntax '$progid'" - } - set clsid [canonicalize_guid $clsid] - if {![info exists opts(appid)]} { - # This is what dcomcnfg and oleview do - default to the CLSID - set opts(appid) $clsid - } else { - set opts(appid) [canonicalize_guid $opts(appid)] - } - - if {$opts(scope) eq "user"} { - if {$opts(service)} { - twapi::badargs! "Option -service cannot be specified if -scope is \"user\"" - } - set regtop HKEY_CURRENT_USER - } else { - set regtop HKEY_LOCAL_MACHINE - } - - set progid_path "$regtop\\Software\\Classes\\$progid" - set clsid_path "$regtop\\Software\\Classes\\CLSID\\$clsid" - set appid_path "$regtop\\Software\\Classes\\AppID\\$opts(appid)" - - if {$opts(service)} { - # TBD - badargs! "Option -service is not implemented" - } elseif {$opts(outproc)} { - if {[info exists opts(params)]} { - registry set "$clsid_path\\LocalServer32" "" "\"[file nativename [file normalize $path]]\" $opts(params)" - } else { - registry set "$clsid_path\\LocalServer32" "" "\"[file nativename [file normalize $path]]\"" - } - # TBD - We do not quote path for ServerExecutable, should we ? - registry set "$clsid_path\\LocalServer32" "ServerExecutable" [file nativename [file normalize $path]] - } else { - # TBD - We do not quote path here either, should we ? - registry set "$clsid_path\\InprocServer32" "" [file nativename [file normalize $path]] - } - - registry set "$clsid_path\\ProgID" "" "$progid.$version" - registry set "$clsid_path\\VersionIndependentProgID" "" $progid - - # Set the registry under the progid and progid.version - registry set "$progid_path\\CLSID" "" $clsid - registry set "$progid_path\\CurVer" "" "$progid.$version" - if {[info exists opts(name)]} { - registry set $progid_path "" $opts(name) - } - - append progid_path ".$version" - registry set "$progid_path\\CLSID" "" $clsid - if {[info exists opts(name)]} { - registry set $progid_path "" $opts(name) - } - - registry set $clsid_path "AppID" $opts(appid) - registry set $appid_path; # Always create the key even if nothing below - if {[info exists opts(appname)]} { - registry set $appid_path "" $opts(appname) - } - - if {$opts(service)} { - registry set $appid_path "LocalService" $path - if {[info exists opts(params)]} { - registry set $appid_path "ServiceParameters" $opts(params) - } - } - - return -} - -proc twapi::uninstall_coclass {progid args} { - # Note "CLSID" itself is a valid ProgID (it has a CLSID key below it) - # Also we want to protect against horrible errors that blow away - # entire branches if progid is empty, wrong value, etc. - # So only work with keys of the form X.X - if {![regexp {^[[:alpha:]][[:alnum:]]*\.[[:alpha:]][[:alnum:]]*$} $progid]} { - badargs! "Invalid PROGID syntax '$progid'" - } - - # Do NOT want to delete the CLSID key by mistake. Note below checks - # will not protect against this since they will return a valid value - # if progid is "CLSID" since that has a CLSID key below it as well. - if {[string equal -nocase $progid CLSID]} { - badargs! "Attempt to delete protected key 'CLSID'" - } - - array set opts [twapi::parseargs args { - {scope.arg user {user system}} - keepappid - } -maxleftover 0] - - switch -exact -- $opts(scope) { - user { set regtop HKEY_CURRENT_USER } - system { set regtop HKEY_LOCAL_MACHINE } - default { - badargs! "Invalid class registration scope '$opts(scope)'. Must be 'user' or 'system'" - } - } - - if {0} { - # Do NOT use this. If running under elevated, it will ignore - # HKEY_CURRENT_USER. - set clsid [progid_to_clsid $progid]; # Also protects against bogus progids - } else { - set clsid [registry get "$regtop\\Software\\Classes\\$progid\\CLSID" ""] - } - - # Should not be empty at this point but do not want to delete the - # whole Classes tree in case progid or clsid are empty strings - # because of some bug! That would be an epic disaster so try and - # protect. - if {$clsid eq ""} { - badargs! "CLSID corresponding to PROGID '$progid' is empty" - } - - # See if we need to delete the linked current version - if {! [catch { - registry get "$regtop\\Software\\Classes\\$progid\\CurVer" "" - } curver]} { - if {[string match -nocase ${progid}.* $curver]} { - registry delete "$regtop\\Software\\Classes\\$curver" - } - } - - # See if we need to delete the APPID - if {! $opts(keepappid)} { - if {! [catch { - registry get "$regtop\\Software\\Classes\\CLSID\\$clsid" "AppID" - } appid]} { - # Validate it is a real GUID - if {![catch {canonicalize_guid $appid}]} { - registry delete "$regtop\\Software\\Classes\\AppID\\$appid" - } - } - } - - # Finally delete the keys and hope we have not trashed the system - registry delete "$regtop\\Software\\Classes\\CLSID\\$clsid" - registry delete "$regtop\\Software\\Classes\\$progid" - - return -} - - diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/console.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/console.tcl deleted file mode 100644 index 3f503040..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/console.tcl +++ /dev/null @@ -1,736 +0,0 @@ -# -# 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 -} - diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/crypto.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/crypto.tcl deleted file mode 100644 index b7cc9c32..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/crypto.tcl +++ /dev/null @@ -1,3457 +0,0 @@ -# -# Copyright (c) 2007-2021, Ashok P. Nadkarni -# All rights reserved. -# -# See the file LICENSE for license - -namespace eval twapi { - variable wintrust_guids - # Array key names match those in softpub.h in SDK - array set wintrust_guids { - action_generic_verify_v2 00AAC56B-CD44-11d0-8CC2-00C04FC295EE - action_trust_provider_test 573E31F8-DDBA-11d0-8CCB-00C04FC295EE - action_generic_cert_verify 189A3842-3041-11d1-85E1-00C04FC295EE - action_generic_chain_verify fc451c16-ac75-11d1-b4b8-00c04fb66ea0 - httpsprov_action 573E31F8-AABA-11d0-8CCB-00C04FC295EE - driver_action_verify F750E6C3-38EE-11d1-85E5-00C04FC295EE - } - - # Dictionaries used by capi_encrypt|decrypt_bytes to store partial blocks of data - # First level key is Crypto key handle - # Second level keys are Blocklen (block size in bytes) and Data (data bytes left over) - variable _capi_encrypt_partials - variable _capi_decrypt_partials - set _capi_encrypt_partials {} - set _capi_decrypt_partials {} -} - -### Hash functions - -proc twapi::capi_hash_create {hcrypt algid {hkey NULL}} { - return [CryptCreateHash $hcrypt [capi_algid $algid] $hkey] -} - -proc twapi::capi_hash_string {hhash s {enc utf-8}} { - return [capi_hash_bytes $hhash [encoding convertto $enc $s] 0] -} - -proc twapi::capi_hash_value {hhash} { - return [CryptGetHashParam $hhash 2]; # HP_HASHVAL -} - -proc twapi::capi_hash_sign {hhash keyspec args} { - # -pad not documented because new Windows version do not support X.931 - # and there are some openssl incompatibilities I cannot figure out - parseargs args { - {nohashoid.bool 0 1} - {pad.arg pkcs1 {pkcs1 x931}} - } -maxleftover 0 -setvars - set flags [expr {[dict get {pkcs1 0 x931 4} $pad] | $nohashoid}] - return [CryptSignHash $hhash [_crypt_keyspec $keyspec] "" $flags] -} - -proc twapi::capi_hash_verify {hhash sig hkey args} { - # -pad not documented because new Windows version do not support X.931 - # and there are some openssl incompatibilities I cannot figure out - parseargs args { - {nohashoid.bool 0 1} - {pad.arg pkcs1 {pkcs1 x931}} - } -maxleftover 0 -setvars - set flags [expr {[dict get {pkcs1 0 x931 4} $pad] | $nohashoid}] - return [CryptVerifySignature $hhash $sig $hkey "" $flags] -} - -proc twapi::_do_hash {csptype alg s {enc ""}} { - if {$enc ne ""} { - set s [encoding convertto $enc $s] - } - set hcrypt [crypt_acquire -csptype $csptype] - trap { - set hhash [capi_hash_create $hcrypt $alg] - capi_hash_bytes $hhash $s - return [capi_hash_value $hhash] - } finally { - if {[info exists hhash]} { - capi_hash_free $hhash - } - crypt_free $hcrypt - } -} - -interp alias {} twapi::md5 {} twapi::_do_hash prov_rsa_full md5 -interp alias {} twapi::sha1 {} twapi::_do_hash prov_rsa_full sha1 -interp alias {} twapi::sha256 {} twapi::_do_hash prov_rsa_aes sha_256 -interp alias {} twapi::sha384 {} twapi::_do_hash prov_rsa_aes sha_384 -interp alias {} twapi::sha512 {} twapi::_do_hash prov_rsa_aes sha_512 - -proc twapi::hmac {data key {prf sha1} {charset {}}} { - if {$charset ne ""} { - set data [encoding convertto $charset $data] - } - - # Choose prov_rsa_aes because older CSP's do not support sha256 - set hcrypt [crypt_acquire -csptype prov_rsa_aes] - try { - # The algorithm specified for importing the key actually is not - # executed at all. It's only used for importing the key. - # However it has to be something that will accept any key size. - # On Windows 8 at least, RC4 seems to require at least 5 byte keys. - # RC2 on the other hand, if the -ipsechmac flag is specifie - # will accept any number. TBD - the pbkdf2 source code implies - # on Win8.1 single byte keys will not be accepted by rc2 and - # keys need to be padded with 0's. Need to check that. - set hkey [crypt_import_key $hcrypt [capi_keyblob_concealed rc2 $key] -ipsechmac 1] - set hhash [capi_hash_create $hcrypt hmac $hkey] - # 5 -> HP_HMAC_INFO - CryptSetHashParam $hhash 5 [list [capi_algid $prf] "" ""] - capi_hash_bytes $hhash $data - return [capi_hash_value $hhash] - } finally { - if {[info exists hhash]} { - capi_hash_free $hhash - } - if {[info exists hkey]} { - capi_key_free $hkey - } - crypt_free $hcrypt - } -} - - -### Data protection - -proc twapi::protect_data {data args} { - - # Not used because doesn't seem to have any effect - # {promptonunprotect.bool 0 0x1} - parseargs args { - {description.arg ""} - {localmachine.bool 0 0x4} - {noui.bool 0 0x1} - {audit.bool 0 0x10} - {hwnd.arg NULL} - prompt.arg - } -setvars -maxleftover 0 - - if {[info exists prompt]} { - # 2 -> PROMPTONPROTECT - set prompt [list 2 $hwnd $prompt] - } else { - set prompt {} - } - - return [CryptProtectData $data $description "" "" $prompt [expr {$localmachine | $noui | $audit}]] -} - -proc twapi::unprotect_data {data args} { - # Do not seem to have any effect - # {promptonunprotect.bool 0 0x1} - # {promptonprotect.bool 0 0x2} - parseargs args { - {withdescription.bool 0} - {noui.bool 0 0x1} - {hwnd.arg NULL} - prompt.arg - } -setvars -maxleftover 0 - - if {[info exists prompt]} { - # 2 -> PROMPTONPROTECT - set prompt [list 2 $hwnd $prompt] - } else { - set prompt {} - } - - set data [CryptUnprotectData $data "" "" $prompt $noui] - if {$withdescription} { - return $data - } else { - return [lindex $data 0] - } -} - - - -################################################################ -# Certificate Stores - -# Close a certificate store -proc twapi::cert_store_release {hstore} { - CertCloseStore $hstore 0 - return -} - -proc twapi::cert_temporary_store {args} { - # TBD - add support for PKCS12_NO_PERSIST_KEY post-XP. If not - # specified and on XP document a means of getting rid of the key - # containers. See https://msdn.microsoft.com/en-us/library/ms867088.aspx#pk_topic6 - # Also CryptAcquireCertificatePrivateKey and GetCryptProvFromCert - # might be useful in this regard - parseargs args { - {encoding.arg {} {der pem {}}} - serialized.arg - pkcs7.arg - {password.arg ""} - pfx.arg - pkcs12.arg - {exportableprivatekeys.bool 0 1} - {userprotected.bool 0 2} - keysettype.arg - } -setvars -maxleftover 0 - - set nformats 0 - foreach format {serialized pkcs7 pfx pkcs12} { - if {[info exists $format]} { - set data [set $format] - incr nformats - } - } - if {$nformats > 1} { - badargs! "At most one of -pfx, -pkcs12, -pkcs7 or -serialized may be specified." - } - if {$nformats == 0} { - # 2 -> CERT_STORE_PROV_MEMORY - return [CertOpenStore 2 0 NULL 0 ""] - } - - # 0x10001 -> PKCS_7_ASN_ENCODING|X509_ASN_ENCODING - - if {[info exists serialized]} { - # 6 -> CERT_STORE_PROV_SERIALIZED - return [CertOpenStore 6 0x10001 NULL 0 $data] - } - - if {[info exists pkcs7]} { - # 5 -> CERT_STORE_PROV_PKCS7 - return [CertOpenStore 5 0x10001 NULL 0 [_pem_decode $data $encoding]] - } - - # PFX/PKCS12 - if {[string length $password] == 0} { - set password [conceal ""] - } - set flags 0 - if {[info exists keysettype]} { - set flags [dict! {user 0x1000 machine 0x20} $keysettype] - } - - set flags [tcl::mathop::| $flags $exportableprivatekeys $userprotected] - return [PFXImportCertStore $data $password $flags] -} - -proc twapi::cert_file_store_open {path args} { - set flags [_parse_store_open_opts $args] - - if {! ($flags & 0x00008000)} { - # If not readonly, set commitenable - set flags [expr {$flags | 0x00010000}] - } - - # 0x10001 -> PKCS_7_ASN_ENCODING|X509_ASN_ENCODING - # 8 -> CERT_STORE_PROV_FILENAME_W - return [CertOpenStore 8 0x10001 NULL $flags [file nativename [file normalize $path]]] -} - -proc twapi::cert_serialized_store_open {data args} { - set flags [_parse_store_open_opts $args] - - # 0x10001 -> PKCS_7_ASN_ENCODING|X509_ASN_ENCODING - # 6 -> CERT_STORE_PROV_SERIALIZED - return [CertOpenStore 6 0x10001 NULL $flags $data] -} - -proc twapi::cert_physical_store_open {name location args} { - variable _system_stores - - set flags [_parse_store_open_opts $args] - incr flags [_system_store_id $location] - # 14 -> CERT_STORE_PROV_PHYSICAL_W - return [CertOpenStore 14 0 NULL $flags $name] -} - -proc twapi::cert_physical_store_delete {name location} { - set flags 0x10; # CERT_STORE_DELETE_FLAG - incr flags [_system_store_id $location] - - # 14 -> CERT_STORE_PROV_PHYSICAL_W - return [CertOpenStore 14 0 NULL $flags $name] -} - -# TBD - document and figure out what format to return data in -proc twapi::cert_physical_stores {system_store_name location} { - return [CertEnumPhysicalStore $system_store_name [_system_store_id $location]] -} - -proc twapi::cert_system_store_open {name args} { - variable _system_stores - - if {[llength $args] == 0} { - return [CertOpenSystemStore $name] - } - - set flags [_parse_store_open_opts [lassign $args location]] - incr flags [_system_store_id $location] - return [CertOpenStore 10 0 NULL $flags $name] -} - -proc twapi::cert_system_store_delete {name location} { - set flags 0x10; # CERT_STORE_DELETE_FLAG - incr flags [_system_store_id $location] - return [CertOpenStore 10 0 NULL $flags $name] -} - -proc twapi::cert_system_store_locations {} { - set l {} - foreach e [CertEnumSystemStoreLocation 0] { - lappend l [lindex $e 0] - } - return $l -} - -proc twapi::cert_system_stores {location} { - set l {} - foreach e [CertEnumSystemStore [_system_store_id $location] ""] { - lappend l [lindex $e 0] - } - return $l -} - -proc twapi::cert_store_iterate {hstore varname script {type any} {term {}}} { - upvar 1 $varname cert - set cert NULL - while {1} { - set cert [cert_store_find_certificate $hstore $type $term $cert] - if {$cert eq ""} break - switch [catch {uplevel 1 $script} result options] { - 0 - - 4 { - # Normal execution or continue. Keep $cert to get next cert - # from store - } - 3 { - # break - get out of loop so free the last cert - cert_release $cert - set cert "" - return - } - 1 - - default { - cert_release $cert - set cert "" - return -options $options $result - } - } - } - return -} - -proc twapi::cert_store_find_certificate {hstore {type any} {term {}} {hcert NULL}} { - - # TBD subject_cert 11<<16 - # TBD key_spec 9<<16 - - set term_types { - any 0 - existing 13<<16 - key_identifier 15<<16 - md5_hash 4<<16 - subject_public_key_md5_hash 18<<16 - sha1_hash 1<<16 - signature_hash 14<<16 - issuer_name (2<<16)|4 - subject_name (2<<16)|7 - issuer_substring (8<<16)|4 - subject_substring (8<<16)|7 - property 5<<16 - public_key 6<<16 - } - - if {$type eq "property"} { - set term [_cert_prop_id $term] - } - set type [expr [dict! $term_types $type 1]] - - # 0x10001 -> PKCS_7_ASN_ENCODING|X509_ASN_ENCODING - return [CertFindCertificateInStore $hstore 0x10001 0 $type $term $hcert] -} - -proc twapi::cert_store_enum_contents {hstore {hcert NULL}} { - return [CertEnumCertificatesInStore $hstore $hcert] -} - -proc twapi::cert_store_add_certificate {hstore hcert args} { - array set opts [_cert_add_parseargs args] - return [CertAddCertificateContextToStore $hstore $hcert $opts(disposition)] -} - -proc twapi::cert_store_add_encoded_certificate {hstore enccert args} { - parseargs args { - {encoding.arg {} {der pem {}}} - } -ignoreunknown -setvars - array set opts [_cert_add_parseargs args] - return [CertAddEncodedCertificateToStore $hstore 0x10001 [_pem_decode $enccert $encoding] $opts(disposition)] -} - -proc twapi::cert_store_export_pem {hstore} { - set pem {} - cert_store_iterate $hstore c {append pem [cert_export $c]\n} - return $pem -} - -proc twapi::cert_store_export_pfx {hstore password args} { - parseargs args { - {exportprivatekeys.bool 0 0x4} - {failonmissingkey.bool 0 0x1} - {failonunexportablekey.bool 0 0x2} - } -maxleftover 0 -setvars - - if {[string length $password] == 0} { - set password [conceal ""] - } - - # NOTE: the -fail* flags only take effect iff the certificate in the store - # claims to have a private key but does not actually have one. It will - # not fail if the cert does not actually claim to have a private key - - set flags [tcl::mathop::| $exportprivatekeys $failonunexportablekey $failonmissingkey] - - return [PFXExportCertStoreEx $hstore $password {} $flags] -} -interp alias {} twapi::cert_store_export_pkcs12 {} twapi::cert_store_export_pfx - -proc twapi::cert_store_commit {hstore args} { - array set opts [parseargs args { - {force.bool 0} - } -maxleftover 0] - - return [Twapi_CertStoreCommit $hstore $opts(force)] -} - -proc twapi::cert_store_serialize {hstore} { - return [Twapi_CertStoreSerialize $hstore 1] -} - -proc twapi::cert_store_export_pkcs7 {hstore args} { - parseargs args { - {encoding.arg pem {der pem}} - } -setvars -maxleftover 0 - - return [_as_pem_or_der [Twapi_CertStoreSerialize $hstore 2] "PKCS7" $encoding] -} - -################################################################ -# Certificates - -interp alias {} twapi::cert_subject_name {} twapi::_cert_get_name subject -interp alias {} twapi::cert_issuer_name {} twapi::_cert_get_name issuer -proc twapi::_cert_get_name {field hcert args} { - - switch $field { - subject { set field 0 } - issuer { set field 1 } - default { badargs! "Invalid name type '$field': must be \"subject\" or \"issuer\"." - } - } - array set opts [parseargs args { - {name.arg oid_common_name} - {separator.arg comma {comma semicolon newline}} - {reverse.bool 0 0x02000000} - {noquote.bool 0 0x10000000} - {noplus.bool 0 0x20000000} - {format.arg x500 {x500 oid simple}} - } -maxleftover 0] - - set arg "" - switch $opts(name) { - email { set what 1 } - simpledisplay { set what 4 } - friendlydisplay {set what 5 } - dns { set what 6 } - url { set what 7 } - upn { set what 8 } - rdn { - set what 2 - switch $opts(format) { - simple {set arg 1} - oid {set arg 2} - x500 - - default {set arg 3} - } - set arg [expr {$arg | $opts(reverse) | $opts(noquote) | $opts(noplus)}] - switch $opts(separator) { - semicolon { set arg [expr {$arg | 0x40000000}] } - newline { set arg [expr {$arg | 0x08000000}] } - } - } - default { - set what 3; # Assume OID - set arg [oid $opts(name)] - } - } - - return [CertGetNameString $hcert $what $field $arg] - -} - -proc twapi::cert_blob_to_name {blob args} { - array set opts [parseargs args { - {format.arg x500 {x500 oid simple}} - {separator.arg comma {comma semi newline}} - {reverse.bool 0 0x02000000} - {noquote.bool 0 0x10000000} - {noplus.bool 0 0x20000000} - } -maxleftover 0] - - switch $opts(format) { - x500 {set arg 3} - simple {set arg 1} - oid {set arg 2} - } - - set arg [expr {$arg | $opts(reverse) | $opts(noquote) | $opts(noplus)}] - switch $opts(separator) { - semi { set arg [expr {$arg | 0x40000000}] } - newline { set arg [expr {$arg | 0x08000000}] } - } - - return [CertNameToStr $blob $arg] -} - -proc twapi::cert_name_to_blob {name args} { - array set opts [parseargs args { - {format.arg x500 {x500 oid simple}} - {separator.arg any {any comma semicolon newline}} - {reverse.bool 0 0x02000000} - {noquote.bool 0 0x10000000} - {noplus.bool 0 0x20000000} - } -maxleftover 0] - - switch $opts(format) { - x500 {set arg 3} - simple {set arg 1} - oid {set arg 2} - } - - set arg [expr {$arg | $opts(reverse) | $opts(noquote) | $opts(noplus)}] - switch $opts(separator) { - comma { set arg [expr {$arg | 0x04000000}] } - semicolon { set arg [expr {$arg | 0x40000000}] } - newline { set arg [expr {$arg | 0x08000000}] } - } - - return [CertStrToName $name $arg] -} - -proc twapi::cert_enum_properties {hcert args} { - parseargs args { - names - } -setvars -maxleftover 0 - - set id 0 - set ids {} - while {[set id [CertEnumCertificateContextProperties $hcert $id]]} { - if {$names} { - lappend ids [_cert_prop_name $id] - } else { - lappend ids $id - } - } - return $ids -} - -proc twapi::cert_property {hcert prop} { - # TBD - need to cook some properties - enhkey_usage - - if {[string is integer -strict $prop]} { - return [CertGetCertificateContextProperty $hcert $prop] - } else { - return [CertGetCertificateContextProperty $hcert [_cert_prop_id $prop] 1] - } -} - -proc twapi::cert_property_set {hcert prop propval} { - switch $prop { - pvk_file - - friendly_name - - description { - set val [encoding convertto unicode "${propval}\0"] - } - enhkey_usage { - set val [::twapi::CryptEncodeObjectEx 2.5.29.37 [_get_enhkey_usage_oids $propval]] - } - default { - badargs! "Invalid or unsupported property name \"$prop\". Must be one of [join $unicode_props {, }]." - } - } - - CertSetCertificateContextProperty $hcert [_cert_prop_id $prop] 0 $val -} - -proc twapi::cert_property_delete {hcert prop} { - CertSetCertificateContextProperty $hcert [_cert_prop_id $prop] 0 -} - -# TBD - Also add cert_set_key_prov_from_crypt_context -proc twapi::cert_set_key_prov {hcert keycontainer keyspec args} { - parseargs args { - csp.arg - {csptype.arg prov_rsa_full} - {keysettype.arg user {user machine}} - {silent.bool 0 0x40} - } -maxleftover 0 -nulldefault -setvars - - set flags $silent - if {$keysettype eq "machine"} { - incr flags 0x20; # CRYPT_KEYSET_MACHINE - } - - # 2 -> CERT_KEY_PROV_INFO_PROP_ID - # TBD - the provider param is hardcoded as {}. Should that be an option ? - CertSetCertificateContextProperty $hcert 2 0 \ - [list $keycontainer $csp [_csp_type_name_to_id $csptype] $flags {} [_crypt_keyspec $keyspec]] - return -} - -proc twapi::cert_export {hcert args} { - parseargs args { - {encoding.arg pem {der pem}} - } -maxleftover 0 -setvars - - return [_as_pem_or_der [lindex [Twapi_CertGetEncoded $hcert] 1] CERTIFICATE $encoding] -} - -proc twapi::cert_import {enccert args} { - parseargs args { - {encoding.arg {} {der pem {}}} - } -maxleftover 0 -setvars - return [CertCreateCertificateContext 0x10001 [_pem_decode $enccert $encoding]] -} - -proc twapi::cert_enhkey_usage {hcert {loc both}} { - return [_cert_decode_enhkey [CertGetEnhancedKeyUsage $hcert [dict! {property 4 extension 2 both 0} $loc 1]]] -} - -proc twapi::cert_key_usage {hcert} { - # 0x10001 -> PKCS_7_ASN_ENCODING|X509_ASN_ENCODING - return [_cert_decode_keyusage [Twapi_CertGetIntendedKeyUsage 0x10001 $hcert]] -} - -proc twapi::cert_thumbprint {hcert} { - binary scan [cert_property $hcert sha1_hash] H* hash - return $hash -} - -proc twapi::cert_info {hcert} { - # TBD - add option to cook extensions using _cert_decode_extension - # instead of returning the raw form - set info [twine { - -version -serialnumber -signaturealgorithm -issuer - -start -end -subject -publickey -issuerid -subjectid -extensions} \ - [Twapi_CertGetInfo $hcert]] - dict set info -start \ - [clock format \ - [large_system_time_to_secs_since_1970 [dict get $info -start]] \ - -timezone :UTC \ - -format "%Y-%m-%d %H:%M:%S"] - dict set info -end \ - [clock format \ - [large_system_time_to_secs_since_1970 [dict get $info -end]] \ - -timezone :UTC \ - -format "%Y-%m-%d %H:%M:%S"] - - return $info -} - -proc twapi::cert_extension {hcert oid} { - set ext [CertFindExtension $hcert [oid $oid]] - if {[llength $ext] == 0} { - return $ext - } - lassign $ext oid critical val - return [list $critical [_cert_decode_extension $oid $val]] -} - -proc twapi::cert_create_self_signed {subject keycontainer keyspec args} { - set args [_cert_create_parse_options $args opts] - - array set opts [parseargs args { - {keysettype.arg user {machine user}} - {silent.bool 0 0x40} - {csp.arg {}} - {csptype.arg {prov_rsa_full}} - {signaturealgorithm.arg {}} - } -maxleftover 0 -ignoreunknown] - - set name_blob [cert_name_to_blob $subject] - - set kiflags $opts(silent) - if {$opts(keysettype) eq "machine"} { - incr kiflags 0x20; # CRYPT_MACHINE_KEYSET - } - set keyinfo [list \ - $keycontainer \ - $opts(csp) \ - [_csp_type_name_to_id $opts(csptype)] \ - $kiflags \ - {} \ - [_crypt_keyspec $keyspec]] - - set flags 0; # Always 0 for now - return [CertCreateSelfSignCertificate NULL $name_blob $flags $keyinfo \ - [_make_algorithm_identifier $opts(signaturealgorithm)] \ - $opts(start) $opts(end) $opts(extensions)] -} - -proc twapi::cert_create_self_signed_from_crypt_context {subject hprov args} { - set args [_cert_create_parse_options $args opts] - - array set opts [parseargs args { - {signaturealgorithm.arg {}} - } -maxleftover 0] - - set name_blob [cert_name_to_blob $subject] - - set flags 0; # Always 0 for now - return [CertCreateSelfSignCertificate $hprov $name_blob $flags {} \ - [_make_algorithm_identifier $opts(signaturealgorithm)] \ - $opts(start) $opts(end) $opts(extensions)] -} - -proc twapi::cert_create {subject pubkey cissuer args} { - set args [_cert_create_parse_options $args opts] - - parseargs args { - {encoding.arg pem {der pem}} - } -maxleftover 0 -setvars - - # TBD - check that issuer is a CA - but then what about self-signed? - - set issuer_info [cert_info $cissuer] - set issuer_blob [cert_name_to_blob [dict get $issuer_info -subject] -format x500] - set sigalgo [dict get $issuer_info -signaturealgorithm] - - # If issuer cert has altnames, use they as issuer altnames for new cert - set issuer_altnames [lindex [cert_extension $cissuer 2.5.29.17] 1] - if {[llength $issuer_altnames]} { - lappend opts(extensions) [_make_altnames_ext $issuer_altnames 0 1] - } - - # The subject key id in issuer's cert will become the - # authority key id in the new cert - # TBD - if fail, get the CERT_KEY_IDENTIFIER_PROP_ID - # 2.5.29.14 -> oid_subject_key_identifier - set issuer_subject_key_id [cert_extension $cissuer 2.5.29.14] - if {[string length [lindex $issuer_subject_key_id 1]] } { - # 2.5.29.35 -> oid_authority_key_identifier - lappend opts(extensions) [list 2.5.29.35 0 [list [lindex $issuer_subject_key_id 1] {} {}]] - } - - # Generate a subject key identifier for this cert based on a hash - # of the public key - set subject_key_id [Twapi_HashPublicKeyInfo $pubkey] - lappend opts(extensions) [list 2.5.29.14 0 $subject_key_id] - - set start [timelist_to_large_system_time $opts(start)] - set end [timelist_to_large_system_time $opts(end)] - - # 2 -> CERT_V3 - # issuer_id and subject_id for the certificate are left empty - # as recommended by gutman's X.509 paper - set cert_info [list 2 $opts(serialnumber) $sigalgo $issuer_blob \ - $start $end \ - [cert_name_to_blob $subject] \ - $pubkey {} {} \ - $opts(extensions)] - - # We need to get the crypt provider for the issuer cert since - # that is what will sign the new cert - lassign [cert_property $cissuer key_prov_info] issuer_container issuer_provname issuer_provtype issuer_flags dontcare issuer_keyspec - set hissuerprov [crypt_acquire $issuer_container -csp $issuer_provname -csptype $issuer_provtype -keysettype [expr {$issuer_flags & 0x20 ? "machine" : "user"}]] - trap { - # 0x10001 -> X509_ASN_ENCODING, 2 -> X509_CERT_TO_BE_SIGNED - return [_as_pem_or_der [CryptSignAndEncodeCertificate $hissuerprov \ - $issuer_keyspec \ - 0x10001 2 $cert_info $sigalgo] \ - CERTIFICATE $encoding] - } finally { - # TBD - test to make sure ok to close this if caller had - # it open - crypt_free $hissuerprov - } -} - -# TBD - test -proc twapi::cert_chain_build {hcert args} { - # -timestamp not documented because not clear exactly how it behaves - # -disablepass1*, -returnlower* not documented because not clear how - # useful. - # TBD - what about CERT_CHAIN_REVOCATION_ACCUMULATIVE_TIMEOUT - parseargs args { - {cacheendcert.bool 0 0x1} - {disableauthrootautoupdate.bool 0 0x100} - {disablepass1qualityfiltering.bool 0 0x40} - {engine.arg user {user machine}} - {hstore.arg NULL} - {returnlowerqualitycontexts.bool 0 0x80} - {revocationcheck.arg all {none all leaf excluderoot}} - {revocationcheckcacheonly.bool 0 0x80000000} - {timestamp.arg ""} - {urlretrievalcacheonly.bool 0 0x4} - usageall.arg - usageany.arg - } -setvars -maxleftover 0 - - set flags [dict! {none 0 all 0x20000000 leaf 0x10000000 excluderoot 0x40000000} $revocationcheck] - set flags [tcl::mathop::| $flags $cacheendcert $revocationcheckcacheonly $urlretrievalcacheonly $disablepass1qualityfiltering $returnlowerqualitycontexts $disableauthrootautoupdate] - - set usage_op 1; # USAGE_MATCH_TYPE_OR - if {[info exists usageall]} { - if {[info exists usageany]} { - error "Only one of -usageall and -usageany may be specified" - } - set usage_op 0; # USAGE_MATCH_TYPE_AND - set usage [_get_enhkey_usage_oids $usageall] - } elseif {[info exists usageany]} { - set usage [_get_enhkey_usage_oids $usageany] - } else { - set usage {} - } - - return [CertGetCertificateChain \ - [dict* {user NULL machine {1 HCERTCHAINENGINE}} $engine] \ - $hcert $timestamp $hstore \ - [list [list $usage_op $usage]] $flags] -} - -proc twapi::cert_ancestors {hcert args} { - # Note - does not care if certs are valid or not - set certs {} - set hchain [cert_chain_build $hcert {*}$args] - trap { - set simple_chain [twapi::Twapi_CertChainSimpleChain $hchain 0] - } finally { - cert_chain_release $hchain - } - foreach elem [dict get $simple_chain chain] { - lappend certs [dict get $elem hcert] - } - return $certs -} - -proc twapi::cert_chain_simple_chain {hchain index} { - set simple_chain [twapi::Twapi_CertChainSimpleChain $hchain $index] - set errors [_map_trust_error [dict get $simple_chain trust_errors]] - dict set simple_chain trust_errors $errors - if {[llength $errors]} { - dict set simple_chain status fail - } else { - dict set simple_chain status ok - } - dict set simple_chain trust_info [_map_trust_info [dict get $simple_chain trust_info]] - set chain_elements {} - foreach elem [dict get $simple_chain chain] { - set errors [_map_trust_error [dict get $elem trust_errors]] - dict set elem trust_errors $errors - if {[llength $errors]} { - dict set elem status fail - } else { - dict set elem status ok - } - dict set elem trust_info [_map_trust_info [dict get $elem trust_info]] - if {[dict exists $elem revocation]} { - set revocation [dict get $elem revocation] - if {$revocation == 0} { - dict unset elem revocation - } else { - dict set elem revocation [_map_cert_verify_error $revocation] - } - } - if {[dict exists $elem application_usage]} { - dict set elem application_usage [_cert_decode_enhkey [dict get $elem application_usage]] - } - lappend chain_elements $elem - } - dict set simple_chain chain $chain_elements - return $simple_chain -} - -# TBD - test -proc twapi::cert_chain_trust_info {hchain} { - return [_map_trust_info [Twapi_CertChainInfo $hchain]] -} - -proc twapi::_map_trust_info {info} { - return [_make_symbolic_bitmask $info { - hasexactmatchissuer 0x00000001 - haskeymatchissuer 0x00000002 - hasnamematchissuer 0x00000004 - isselfsigned 0x00000008 - haspreferredissuer 0x00000100 - hasissuancechainpolicy 0x00000200 - hasvalidnameconstraints 0x00000400 - ispeertrusted 0x00000800 - hascrlvalidityextended 0x00001000 - isfromexclusivetruststore 0x00002000 - iscomplexchain 0x00010000 - }] -} - -# TBD - test -proc twapi::cert_chain_trust_errors {hchain} { - return [_map_trust_error [Twapi_CertChainError $hchain]] -} - -proc twapi::_map_trust_error {errbits} { - return [_make_symbolic_bitmask $errbits { - time 1 - revoked 4 - signature 8 - wrongusage 0x10 - untrustedroot 0x20 - revocationunknown 0x40 - trustcycle 0x80 - extension 0x100 - policy 0x200 - basiconstraints 0x400 - nameconstraints 0x800 - unsupportednameconstraint 0x1000 - undefinednameconstraint 0x2000 - unpermittednameconstraint 0x4000 - excludednameconstraint 0x8000 - revocationoffline 0x01000000 - noissuancechainpolicy 0x02000000 - distrust 0x04000000 - criticalextension 0x08000000 - weaksignature 0x00100000 - partialchain 0x00010000 - ctltime 0x00020000 - ctlsignature 0x00040000 - ctlusage 0x00080000 - }] -} - -proc twapi::cert_verify {hcert policy args} { - # TBD - should we explicitly look for nulls in the subject name? - # The Chrome source at - # https://src.chromium.org/svn/branches/455/src/net/base/x509_certificate_win.cc - # does this though it also uses the same calls as below. See - # CertSubjectCommonNameHasNull in that code. - set policy_id [dict! { - authenticode 2 authenticodets 3 base 1 basicconstraints 5 - extendedvalidation 8 microsoftroot 7 ntauth 6 - ssl 4 tls 4 - } $policy] - - # Construct policy specific options - set optdefs { - {ignoreerrors.arg {}} - policyparams.arg - {trustedroots.arg} - } - switch -exact -- $policy_id { - 4 { - # SSL/TLS - lappend optdefs server.arg - } - 5 { - # basicconstraints - lappend optdefs isa.arg - } - 6 { - # ntauth also accepts -isa as it includes basic constraints checks - lappend optdefs isa.arg - } - 7 { - # microsoftroot - lappend optdefs enabletestroot.bool - } - } - - array set opts [parseargs args $optdefs -ignoreunknown -setvars] - - if {![dict exists $args -usageall] && ![dict exists $args -usageany]} { - switch -exact -- $policy { - authenticodets - - authenticode { - dict lappend args -usageany code_signing - } - ssl - - tls { - if {[info exists server]} { - dict lappend args -usageany server_auth - } else { - dict lappend args -usageany client_auth - } - } - } - } - - set verify_flags 0 - if {[info exists isa]} { - switch -exact -- $isa { - ca { set verify_flags [expr {$verify_flags | 0x80000000}] } - endentity { set verify_flags [expr {$verify_flags | 0x40000000}] } - default { - error "Invalid value \"$isa\" specified for option -isa." - } - } - } - if {[info exists enabletestroot]} { - set verify_flags [expr {$verify_flags | 0x00010000}] - } - - if {$policy eq "basicconstraints"} { - # TBD - peertrust 0x1000, see below - set ignore_options {} - } else { - # Any other policy - # TBD - the meaning of these is not clear. Are they ignore - # error flags or options? - # peertrust 0x1000 - # trusttestroot 0x4000 - # allowtestroot 0x8000 - set ignore_options { - time 0x07 - basicconstraints 0x08 - unknownca 0x10 - usage 0x20 - name 0x40 - policy 0x80 - revocation 0xf00 - criticalextensions 0x2000 - } - } - - foreach ignore $ignoreerrors { - if {![dict exists $ignore_options $ignore]} { - error "Value $ignore for option -ignoreerrors cannot be used with policy $policy." - } - set verify_flags [expr {$verify_flags | [dict get $ignore_options $ignore]}] - } - - if {![info exists policyparams]} { - switch -exact -- $policy_id { - 4 { - # ssl/tls - if {[info exists server]} { - set policyparams [cert_policy_params_tls -ignoreerrors $ignoreerrors -server $server] - } else { - set policyparams [cert_policy_params_tls -ignoreerrors $ignoreerrors] - } - } - default { - set policyparams {} - } - } - } - - if {[info exists ignoreerrors] && "revocation" in $ignoreerrors} { - lappend args -revocationcheck none - } - set chainh [cert_chain_build $hcert {*}$args] - - trap { - # Actually verification is a bit tricky because the caller might - # have asked for certain errors to be ignored. - # Note that CertVerifyChainPolicy below does NOT check for revocation - # of certificates in the certificate chain as per Microsoft docs. - # We therefore check for revocation errors here and abort if present. - set chain_errors [cert_chain_trust_errors $chainh] - if {[llength $chain_errors]} { - if {"revoked" in $chain_errors} { - return revoked - } - if {"revocationoffline" in $chain_errors} { - return revocationoffline - } - if {"revocationunknown" in $chain_errors} { - return revocationunknown - } - - if {0} { - # For other kind of errors, caller might have indicated - # some types are to be ignored. In that case we will proceed - # to use CertVerifyTrustPolicy since that will allow - # control of which errors are to be ignored. As a - # special case, if caller has specified additional trusted - # roots, we will proceed to call CertVerifyTrustPolicy - # even when caller is not ignoring errors but only if - # there are no errors indicated. - if {[llength $chain_errors] > 1 || - [lindex $chain_errors 0] ne "untrustedroot" || - ![info exists trustedroots]} { - return $chain_errors - } - } - } - - set status [Twapi_CertVerifyChainPolicy $policy_id $chainh [list $verify_flags $policyparams]] - - # If caller had provided additional trusted roots that are not - # in the Windows trusted store, and the error is that the root is - # untrusted, see if the root cert is one of the passed trusted ones - # We will only deal when there is a single possible chain else - # the recheck becomes very complicated as we are not sure if - # the recheck will employ the same chain or not. - if {$status == 0x800B0109 && - [info exists trustedroots] && [llength $trustedroots] && - [cert_chain_simple_chain_count $chainh] == 1} { - set simple_chain [cert_chain_simple_chain $chainh 0] - # Double check no errors listed for this chain - set trust_errors [dict get $simple_chain trust_errors] - if {[llength $trust_errors] == 1 && - [lindex $trust_errors 0] eq "untrustedroot"} { - set certs_in_chain [dict get $simple_chain chain] - set root_cert [dict get [lindex $certs_in_chain end] hcert] - set thumbprint [cert_thumbprint $root_cert] - # Match against each trusted root - set trusted 0 - foreach trusted_cert $trustedroots { - if {$thumbprint eq [cert_thumbprint $trusted_cert]} { - set trusted 1 - break - } - } - if {$trusted} { - # Yes, the root is trusted. It is not enough to - # say validation is ok because even if root - # is trusted, other errors might show up - # once untrusted roots are ignored. So we have - # to call the verification again. - # 0x10 -> CERT_CHAIN_POLICY_ALLOW_UNKNOWN_CA_FLAG - set verify_flags [expr {$verify_flags | 0x10}] - if {0} { - TBD - need to redo the policy params? - # 0x100 -> SECURITY_FLAG_IGNORE_UNKNOWN_CA - set checks [expr {$checks | 0x100}] - } - # Retry the call ignoring root errors - set status [Twapi_CertVerifyChainPolicy $policy_id $chainh [list $verify_flags $policyparams]] - } - } - } - - return [_map_cert_verify_error $status] - } finally { - if {[info exists simple_chain]} { - foreach cert [dict get $simple_chain chain] { - cert_release [dict get $cert hcert] - } - } - cert_chain_release $chainh - } - - return $status -} - -proc twapi::_map_cert_verify_error {err} { - if {![string is integer -strict $err]} { - return $err - } - return [dict* { - 0x00000000 ok - 0x80096004 signature - 0x80092010 revoked - 0x800b0109 untrustedroot - 0x800b010d untrustedtestroot - 0x800b010a partialchain - 0x800b0110 wrongusage - 0x800b0101 time - 0x800b0114 name - 0x800b0113 policy - 0x80096019 basicconstraints - 0x800b0105 criticalextension - 0x800b0102 validityperiodnesting - 0x80092011 norevocationdll - 0x80092012 norevocationcheck - 0x80092013 revocationoffline - 0x800b010f cnmatch - 0x800b0106 purpose - 0x800b010e revocationunknown - 0x800b0103 carole - } [format 0x%8.8x $err]] -} - -# TBD - document -proc twapi::cert_policy_params_tls {args} { - - parseargs args { - ignoreerrors.arg - server.arg - } -maxleftover 0 -setvars -ignoreunknown - - if {[info exists server]} { - set role 2; # AUTHTYPE_SERVER - } else { - set role 1; # AUTHTYPE_CLIENT - set server "" - } - - set ignore_options { - time 0x2000 - unknownca 0x100 - usage 0x200 - name 0x1000 - revocation 0x80 - } - set checks 0 - foreach ignore $ignoreerrors { - # Note we use dict*, not dict! so we can skip any ignore tokens - # that we don't know - set checks [expr {$checks | [dict* $ignore_options $ignore 0]}] - } - return [list $role $checks $server] -} - -proc twapi::cert_tls_verify {hcert args} { - return [cert_verify $hcert tls {*}$args] -} - -# TBD - provide a -peersubject option -proc twapi::cert_fetch {addr {port 443}} { - set so [tls_socket $addr $port] - trap { - set sspi_ctx [chan configure $so -context] - return [sspi_remote_cert $sspi_ctx] - } finally { - close $so - } -} - -proc twapi::cert_locate_private_key {hcert args} { - parseargs args { - {keysettype.arg any {any user machine}} - {silent 0 0x40} - } -maxleftover 0 -setvars - - return [CryptFindCertificateKeyProvInfo $hcert \ - [expr {$silent | [dict get {any 0 user 1 machine 2} $keysettype]}]] -} - -proc twapi::cert_request_parse {req args} { - parseargs args { - {encoding.arg {} {der pem {}}} - } -setvars -maxleftover 0 - - # 3 -> CRYPT_STRING_BASE64REQUESTHEADER - # 4 -> X509_CERT_REQUEST_TO_BE_SIGNED - lassign [::twapi::CryptDecodeObjectEx 4 [_pem_decode $req $encoding 3]] ver subject pubkey attrs - lappend reqdict version $ver pubkey $pubkey attributes $attrs - lappend reqdict subject [cert_blob_to_name $subject] - foreach attr $attrs { - lassign $attr oid values - if {$oid eq "1.2.840.113549.1.9.14"} { - # ...1.9.14 -> oid_rsa_certextensions - set extensions {} - foreach ext [lindex $values 0] { - lassign $ext oid critical value - set value [_cert_decode_extension $oid $value] - lappend extensions $oid [list $value $critical] - # Also add "option keyed" values - switch -exact -- $oid { - 2.5.29.15 { - lappend extensions -keyusage [list $value $critical] - } - 2.5.29.17 { - lappend extensions -altnames [list $value $critical] - } - 2.5.29.19 { - lappend extensions -basicconstraints [list $value $critical] - } - 2.5.29.37 { - lappend extensions -enhkeyusage [list $value $critical] - } - } - } - lappend reqdict extensions $extensions - } - } - - return $reqdict -} - - -proc twapi::cert_request_create {subject hprov keyspec args} { - set args [_cert_create_parse_options $args opts] - # TBD - barf if any elements other than extensions is set - # TBD - document signaturealgorithmid - parseargs args { - {signaturealgorithmid.arg oid_rsa_sha1rsa} - {encoding.arg pem {der pem}} - } -setvars -maxleftover 0 - - set sigoid [oid $signaturealgorithmid] - if {$sigoid ni [list [oid oid_rsa_sha1rsa] [oid oid_rsa_md5rsa] [oid oid_x957_sha1dsa]]} { - badargs! "Invalid signature algorithm '$sigalg'" - } - set keyspec [twapi::_crypt_keyspec $keyspec] - # 0x10001 -> PKCS_7_ASN_ENCODING|X509_ASN_ENCODING - # Pass oid_rsa_rsa as that seems to be what OPENSSL understands in - # a CSR - set pubkeyinfo [crypt_public_key $hprov $keyspec oid_rsa_rsa] - set attrs [list 0 [cert_name_to_blob $subject] $pubkeyinfo] - if {[llength $opts(extensions)]} { - lappend attrs [list [list [oid oid_rsa_certextensions] [list $opts(extensions)]]] - } else { - lappend attrs {} - } - return [_as_pem_or_der [CryptSignAndEncodeCertificate $hprov $keyspec 0x10001 4 $attrs $sigoid] "NEW CERTIFICATE REQUEST" $encoding] -} - - -################################################################ -# Cryptographic context commands - -proc twapi::crypt_acquire {args} { - # Backward compatibility - keycontainer can be specified as first arg - if {[llength $args] & 1} { - set args [lassign $args keycontainer] - } else { - set keycontainer "" - } - - parseargs args { - {csp.arg {}} - {csptype.arg prov_rsa_full} - keycontainer.arg - {keysettype.arg user {user machine}} - {create.bool 0 0x8} - {silent.bool 0 0x40} - verifycontext.bool - } -maxleftover 0 -setvars - - # The defaults for verifycontext are a little confusing. For a named - # key container, at least the MS CSP's require -verifycontext to be 0. - # For the frequent case where private keys are not required, MS recommends - # using the null key container with -verifycontext 1. So accordingly, - # if the keycontainer is empty (or unspecified), then it - # defaults to 1, else defaults to 0. - if {![info exists verifycontext]} { - if {$keycontainer eq ""} { - set verifycontext 1 - } else { - set verifycontext 0 - } - } - - if {$verifycontext} { - set verifycontext 0xf0000000 - } - - set flags [expr {$silent | $verifycontext}] - if {$keysettype eq "machine"} { - incr flags 0x20; # CRYPT_KEYSET_MACHINE - } - - trap { - return [CryptAcquireContext $keycontainer $csp [_csp_type_name_to_id $csptype] $flags] - } onerror {TWAPI_WIN32 0x80090016} { - # NTE_BAD_KEYSET - does not exist. Try to create it. - if {$create} { - set flags [expr {$flags | $create}] - return [CryptAcquireContext $keycontainer $csp [_csp_type_name_to_id $csptype] $flags] - } else { - rethrow - } - } -} - -proc twapi::crypt_free {hcrypt} { - twapi::CryptReleaseContext $hcrypt -} - -proc twapi::crypt_key_container_delete {keycontainer args} { - parseargs args { - csp.arg - {csptype.arg prov_rsa_full} - {keysettype.arg user {machine user}} - force - } -maxleftover 0 -nulldefault -setvars - - if {$keycontainer eq "" && ! $force} { - error "Default container cannot be deleted unless the -force option is specified" - } - - set flags 0x10; # CRYPT_DELETEKEYSET - if {$keysettype eq "machine"} { - incr flags 0x20; # CRYPT_MACHINE_KEYSET - } - - return [CryptAcquireContext $keycontainer $csp [_csp_type_name_to_id $csptype] $flags] -} - -proc twapi::crypt_generate_key {hprov algid args} { - - array set opts [parseargs args { - {archivable.bool 0 0x4000} - {salt.bool 0 4} - {exportable.bool 0 1} - {pregen.bool 0x40} - {userprotected.bool 0 2} - {nosalt40.bool 0 0x10} - {size.int 0} - } -maxleftover 0] - - set algid [capi_algid $algid] - - if {$opts(size) < 0 || $opts(size) > 65535} { - badargs! "Bad key size value '$size': must be positive integer less than 65536" - } - - return [CryptGenKey $hprov $algid [expr {($opts(size) << 16) | $opts(archivable) | $opts(salt) | $opts(exportable) | $opts(pregen) | $opts(userprotected) | $opts(nosalt40)}]] -} - -proc twapi::crypt_keypair {hprov keyspec} { - return [CryptGetUserKey $hprov [dict! {keyexchange 1 signature 2} $keyspec]] -} - -proc twapi::crypt_public_key_import {hprov key args} { - parseargs args { - {algid.arg 0} - {encoding.arg {} {native pem der {}}} - } -setvars - - if {$encoding eq "native"} { - set pub $key - } elseif {$encoding eq "der"} { - set pub [CryptDecodeObjectEx 8 $key] - } elseif {$encoding eq "pem" || - ($encoding eq "" && [string match -nocase "-----BEGIN*" $key])} { - set pub [CryptDecodeObjectEx 8 [CryptStringToBinary $key 0]] - } else { - # encoding is unspecified and is either der or native - if {[catch {set pub [CryptDecodeObjectEx 8 $key]}]} { - # Not DER, assume native - set pub $key - } - } - - return [CryptImportPublicKeyInfoEx $hprov 0x10001 $pub [capi_algid $algid]] -} - -proc twapi::crypt_public_key_export {hprov keyspec args} { - parseargs args { - algoid.arg - {encoding.arg pem {pem der native}} - } -setvars -nulldefault - - if {$algoid ne ""} { - set algoid [oid $algoid] - } - set pubkey [CryptExportPublicKeyInfoEx $hprov \ - [_crypt_keyspec $keyspec] \ - 0x10001 \ - $algoid \ - 0] - if {$encoding eq "native"} { - return $pubkey - } - # Generate SubjectPublicKeyInfo - set der [CryptEncodeObjectEx 8 $pubkey] - if {$encoding eq "der"} { - return $der - } - # 0x80000001 -> No CR (only LF) and headers - return "-----BEGIN PUBLIC KEY-----\n[CryptBinaryToString $der 0x80000001]-----END PUBLIC KEY-----\n" -} - -# For back compat - undocumented -proc twapi::crypt_public_key {hcrypt algid oid} { - return [crypt_public_key_export $hcrypt $algid -encoding native -algoid $oid] -} - -proc twapi::crypt_get_security_descriptor {hprov} { - return [CryptGetProvParam $hprov 8 7] -} - -proc twapi::crypt_set_security_descriptor {hprov secd} { - CryptSetProvParam $hprov 8 $secd -} - -proc twapi::crypt_key_container_name {hprov} { - return [CryptGetProvParam $hprov 6 0] -} - -proc twapi::crypt_key_container_unique_name {hprov} { - return [CryptGetProvParam $hprov 36 0] -} - -proc twapi::crypt_csp {hprov} { - return [CryptGetProvParam $hprov 4 0] -} - -proc twapi::csps {} { - set i 0 - set result {} - while {[llength [set csp [::twapi::CryptEnumProviders $i]]]} { - lappend result [lreplace $csp 0 0 [_csp_type_id_to_name [lindex $csp 0]]] - incr i - } - return $result -} -interp alias {} twapi::crypt_csps {} twapi::csps - -proc twapi::crypt_csp_type {hprov} { - return [_csp_type_id_to_name [CryptGetProvParam $hprov 16 0]] -} - -proc twapi::csp_types {} { - set i 0 - set result {} - while {[llength [set csptype [::twapi::CryptEnumProviderTypes $i]]]} { - lappend result [lreplace $csptype 0 0 [_csp_type_id_to_name [lindex $csptype 0]]] - incr i - } - return $result -} -interp alias {} twapi::crypt_csptypes {} twapi::csp_types - -proc twapi::crypt_key_container_names {hcrypt} { - return [CryptGetProvParam $hcrypt 2 0] -} - -proc twapi::crypt_session_key_size {hcrypt} { - return [CryptGetProvParam $hcrypt 20 0] -} - -proc twapi::crypt_keyx_keysize_increment {hcrypt} { - return [CryptGetProvParam $hcrypt 35 0] -} - -proc twapi::crypt_sig_keysize_increment {hcrypt} { - return [CryptGetProvParam $hcrypt 34 0] -} - -# TBD - Doc and test -proc twapi::crypt_admin_pin {hcrypt} { - return [CryptGetProvParam $hcrypt 31 0] -} - -# TBD - Doc and test -proc twapi::crypt_keyx_pin {hcrypt} { - return [CryptGetProvParam $hcrypt 32 0] -} - -# TBD - Doc and test -proc twapi::crypt_sig_pin {hcrypt} { - return [CryptGetProvParam $hcrypt 33 0] -} - -proc twapi::crypt_csp_version {hcrypt} { - set ver [CryptGetProvParam $hcrypt 5 0] - return [format %d.%d [expr {($ver & 0xff00)>>8}] [expr {$ver & 0xff}]] -} - -proc twapi::crypt_keyset_type {hcrypt} { - return [expr {[CryptGetProvParam $hcrypt 27 0] & 0x20 ? "machine" : "user"}] -} - -proc twapi::crypt_key_specifiers {hcrypt} { - set keyspec [CryptGetProvParam $hcrypt 39 0] - set keyspecs {} - if {$keyspec & 1} { - lappend keyspecs keyexchange - } - if {$keyspec & 2} { - lappend keyspecs signature - } - return $keyspecs -} - -proc twapi::crypt_symmetric_key_size {hcrypt} { - return [CryptGetProvParam $hcrypt 19 0] -} - -proc twapi::capi_key_export {hkey blob_type args} { - parseargs args { - {wrapper.arg NULL} - {v3.bool 0 0x80} - {oeap.bool 0 0x40} - {destroy.bool 0 0x04} - } -setvars -maxleftover 0 - - return [CryptExportKey $hkey $wrapper [_capi_keyblob_type_id $blob_type] [expr {$v3|$oeap}]] -} -interp alias {} twapi::crypt_export_key {} twapi::capi_key_export - - -proc twapi::crypt_import_key {hcrypt keyblob args} { - parseargs args { - {wrapper.arg NULL} - {exportable.bool 1 0x01} - {oaep.bool 0 0x40} - {userprotected.bool 0 0x02} - {ipsechmac.bool 0 0x100} - } -setvars -maxleftover 0 - return [CryptImportKey $hcrypt $keyblob $wrapper \ - [expr {$exportable|$oaep|$userprotected|$ipsechmac}]] -} -interp alias {} twapi::capi_key_import {} twapi::crypt_import_key - -proc twapi::crypt_derive_key {hcrypt algid passphrase args} { - parseargs args { - {size.int 0} - {exportable.bool 1 0x01} - {prf.arg sha1} - {method.arg pbkdf2} - {iterations.int 100000} - {salt.arg ""} - } -maxleftover 0 -setvars - - if {$method eq "pbkdf2"} { - set algnum [capi_algid $algid] - if {$size == 0} { - # Need to figure out the default key size for the algorithm - # The loop below does not work for des/3des/3des_112 because - # it will get the actual key size whereas CryptImportKey - # wants key size with pad/parity bits. So hardcode these - if {$algnum == 0x6601} { - set size 64; # - } elseif {$algnum == 0x6603} { - set size 192; # 3des - } elseif {$algnum == 0x6609} { - set size 128; # 3des_112 - } else { - foreach alg [crypt_algorithms $hcrypt] { - if {[dict get $alg algid] == $algnum} { - set size [dict get $alg defkeylen] - break - } - } - } - if {$size == 0} { - error "Could not figure out default key size for algorithm $algid. Please use the -size option." - } - } - set pbkdf2 [PBKDF2 $passphrase $size [capi_algid $prf] $salt $iterations] - set keyblob [list 0 2 0 $algnum $pbkdf2] - return [crypt_import_key $hcrypt $keyblob -exportable $exportable] - } else { - if {$size < 0 || $size > 65535} { - # Key size of 0 is default. Else it must be within 1-65535 - badargs! "Option -size value \"$size\" is not between 0 and 65535." - } - set hhash [capi_hash_create $hcrypt [capi_algid $method]] - twapi::trap { - capi_hash_password $hhash $passphrase - return [CryptDeriveKey $hcrypt [capi_algid $algid] $hhash \ - [expr {($size << 16) | $exportable}]] - } finally { - capi_hash_free $hhash - } - } -} - -proc twapi::pbkdf2 {pass nbits alg_id salt niters} { - return [PBKDF2 $pass $nbits [capi_algid $alg_id] $salt $niters] -} - - -proc twapi::capi_encrypt_bytes {bytes hkey args} { - variable _capi_encrypt_partials - parseargs args { - {hhash.arg NULL} - {final.bool 1} - {pad.arg oaep {oaep pkcs1}} - } -setvars -maxleftover 0 - - if {[dict exists $_capi_encrypt_partials $hkey Data]} { - append plaintext \ - [dict get $_capi_encrypt_partials $hkey Data] \ - $bytes - } else { - set plaintext $bytes - } - - if {$final} { - dict unset _capi_encrypt_partials $hkey - return [CryptEncrypt $hkey $hhash $final [dict! {pkcs1 0 oaep 0x40} $pad] $plaintext] - } - - # If not the final segment, we have to split it up into the block size multiple. - if {[dict exists $_capi_encrypt_partials $hkey Blocklen]} { - set blocklen [dict get $_capi_encrypt_partials $hkey Blocklen] - } else { - set blocklen [expr {[capi_key_blocklen $hkey] / 8}]; # Bits -> bytes - } - - # len is largest multiple of block size less than data length - set len [expr {([string length $plaintext] / $blocklen) * $blocklen}] - set enc [CryptEncrypt $hkey $hhash $final [dict! {pkcs1 0 oaep 0x40} $pad] [string range $plaintext 0 $len-1]] - # Note following will not happen if CryptEncrypt throws an error. As desired - set remain [string range $plaintext $len end] - if {[string length $remain]} { - # Remember additional data - dict set _capi_encrypt_partials $hkey Data $remain - dict set _capi_encrypt_partials $hkey Blocklen $blocklen - } else { - dict unset _capi_encrypt_partials $hkey - } - - return $enc -} - -proc twapi::capi_encrypt_string {s hkey args} { - # Explicitly parse args, not just pass on because this command - # does not support -final for symmetry with capi_decrypt_string - parseargs args { - {hhash.arg NULL} - {pad.arg oaep {oaep pkcs1}} - } -setvars -maxleftover 0 - return [capi_encrypt_bytes [encoding convertto utf-8 $s] $hkey -hhash $hhash -pad $pad] -} - -proc twapi::capi_decrypt_bytes {bytes hkey args} { - variable _capi_decrypt_partials - parseargs args { - {pad.arg oaep {oaep pkcs1 nopadcheck}} - {final.bool 1} - {hhash.arg NULL} - } -setvars -maxleftover 0 - - if {[dict exists $_capi_decrypt_partials $hkey Data]} { - append enc \ - [dict get $_capi_decrypt_partials $hkey Data] \ - $bytes - } else { - set enc $bytes - } - - if {$final} { - dict unset _capi_decrypt_partials $hkey - return [CryptDecrypt $hkey $hhash $final [dict! {pkcs1 0 oaep 0x40 nopadcheck 0x20} $pad] $enc] - } - - # If not the final segment, we have to split it up into the block size multiple. - if {[dict exists $_capi_decrypt_partials $hkey Blocklen]} { - set blocklen [dict get $_capi_decrypt_partials $hkey Blocklen] - } else { - set blocklen [expr {[capi_key_blocklen $hkey] / 8}]; # Bits -> bytes - } - - # len is largest multiple of block size less than data length - set len [expr {([string length $enc] / $blocklen) * $blocklen}] - set plaintext [CryptDecrypt $hkey $hhash $final [dict! {pkcs1 0 oaep 0x40} $pad] [string range $enc 0 $len-1]] - # Note following will not happen if CryptDecrypt throws an error. As desired - set remain [string range $enc $len end] - if {[string length $remain]} { - # Remember additional data - dict set _capi_decrypt_partials $hkey Data $remain - dict set _capi_decrypt_partials $hkey Blocklen $blocklen - } else { - dict unset _capi_decrypt_partials $hkey - } - - return $plaintext -} - -proc twapi::capi_decrypt_string {s hkey args} { - # Explicitly parse args, not just pass on because this command - # does not support -final for symmetry with capi_decrypt_string - parseargs args { - {hhash.arg NULL} - {pad.arg oaep {oaep pkcs1}} - } -setvars -maxleftover 0 - return [encoding convertfrom utf-8 [capi_decrypt_bytes $s $hkey -hhash $hhash -pad $pad]] -} - -# Returns the most capable CSP -proc twapi::_crypt_acquire_default {} { - if {[catch {crypt_acquire -csptype prov_rsa_aes} hcrypt] && - [catch {crypt_acquire -csptype prov_rsa_full -csp {Microsoft Enhanced Cryptographic Provider v1.0}} hcrypt]} { - set hcrypt [crypt_acquire] - } - set cspname [crypt_csp $hcrypt] - set csptype [crypt_csp_type $hcrypt] - # Redefine ourselves for next call - proc [namespace current]::_crypt_acquire_default {} "crypt_acquire -csp {$cspname} -csptype $csptype" - return $hcrypt -} - -proc twapi::_block_cipher {algo direction bytes keybytes args} { - - # Note: padding mode is not documented since MS providers only support - # one mode anyway - parseargs args { - mode.arg - iv.arg - padding.arg - } -setvars -maxleftover 0 - - set hcrypt [_crypt_acquire_default] - try { - set hkey [crypt_import_key $hcrypt [capi_keyblob_concealed $algo $keybytes]] - if {[info exists mode]} { - capi_key_mode $hkey $mode - } - if {[info exists iv]} { - capi_key_iv $hkey $iv - } - if {$direction eq "encrypt"} { - if {[info exists padding]} { - capi_key_padding $hkey $padding - } - set ciphertext [capi_encrypt_bytes $bytes $hkey] - } else { - set ciphertext [capi_decrypt_bytes $bytes $hkey] - } - } finally { - if {[info exists hkey]} { - capi_key_free $hkey - } - crypt_free $hcrypt - } - return $ciphertext -} - -# apply to avoid global variable pollution -apply {{} { - foreach {algo blocklen} {des 8 3des 8 aes_128 16 aes_192 16 aes_256 16} { - namespace eval twapi::$algo {} - interp alias {} twapi::${algo}::encrypt {} twapi::_block_cipher $algo encrypt - interp alias {} twapi::${algo}::decrypt {} twapi::_block_cipher $algo decrypt - interp alias {} twapi::${algo}::iv {} twapi::random_bytes $blocklen - namespace eval twapi::$algo { - namespace export encrypt decrypt iv - namespace ensemble create - } - } -}} - -### -# PKCS7 commands - -proc twapi::pkcs7_encrypt {bytes recipients encalg args} { - parseargs args { - {encoding.arg pem {pem der}} - {innertype.arg 0} - } -setvars -maxleftover 0 - - # TBD - add support for the following - set flags 0 - set encauxinfo {} - - set params [list \ - 0x10001 \ - NULL \ - [_make_algorithm_identifier $encalg] \ - $encauxinfo \ - $flags \ - $innertype] - return [_as_pem_or_der [CryptEncryptMessage $params $recipients $bytes] PKCS7 $encoding] -} - -proc twapi::pkcs7_decrypt {bytes stores args} { - parseargs args { - {encoding.arg {} {der pem {}}} - {silent.bool 0 0x40} - {certvar.arg ""} - } -maxleftover 0 -setvars - - set params [list \ - 0x10001 \ - $stores \ - $silent] - if {$certvar ne ""} { - upvar 1 $certvar hcert - set certvar hcert - } - - return [CryptDecryptMessage $params [_pem_decode $bytes $encoding] $certvar] -} - -proc twapi::pkcs7_sign {bytes hcert hashalg args} { - # TBD - document crls? - parseargs args { - {detached.bool 0} - {encoding.arg pem {pem der}} - {includecerts.arg all {none leaf all}} - {silent.bool 0 0x40} - {usesignerkeyid.bool 0 0x4} - {crls.arg {}} - {innercontenttype.arg 0} - } -setvars -maxleftover 0 - - set flags [expr {$usesignerkeyid | $silent}] - - switch -exact -- $includecerts { - leaf { set certs [list [cert_duplicate $hcert]] } - none { set certs {} } - all { set certs [cert_ancestors $hcert] } - } - # TBD - add support for the following - set hashaux {} - set authattrs {} - set unauthattrs {} - set encalg "" - set hashencaux "" - # 0x10001 -> PKCS_7_ASN_ENCODING|X509_ASN_ENCODING - set params [list \ - 0x10001 \ - $hcert \ - [_make_algorithm_identifier $hashalg] \ - $hashaux \ - $certs \ - $crls \ - $authattrs \ - $unauthattrs \ - $flags \ - $innercontenttype \ - $encalg \ - $hashencaux] - trap { - return [_as_pem_or_der [CryptSignMessage $params $detached [list $bytes]] PKCS7 $encoding] - } finally { - foreach c $certs { - cert_release $c - } - } -} - -proc twapi::pkcs7_verify {bytes args} { - parseargs args { - {encoding.arg {} {der pem {}}} - {contentvar.arg ""} - {certvar.arg ""} - } -maxleftover 0 -setvars -ignoreunknown - - if {$contentvar ne ""} { - upvar 1 $contentvar content - set contentvar content - } - set status [CryptVerifyMessageSignature [list 0x10001 NULL] 0 [_pem_decode $bytes $encoding] $contentvar hcert] - if {$status == 0} { - trap { - set status [cert_verify $hcert base {*}$args] - if {$status eq "ok"} { - if {$certvar ne ""} { - upvar 1 $certvar cert - set cert $hcert - unset hcert; # So we do not release it below - } - if {$contentvar ne ""} { - upvar 1 $contentvar con - set con content - } - } - } finally { - if {[info exists hcert]} { - cert_release $hcert - } - } - } else { - # Note these codes are different from those in _map_cert_verify_error - if {$status == 0x80090006} { - set status "signature" - } elseif {$status == 0x80090008} { - set status "invalidalgorithm" - } - } - - return $status -} - - -# For backwards compat - deprecated -interp alias {} twapi::crypt_key_free {} twapi::capi_key_free - -proc twapi::crypt_algorithms {hcrypt} { - set algs {} - foreach alg [CryptGetProvParam $hcrypt 22 0] { - lassign $alg algid defaultlen minlen maxlen protos name description - set protos [_make_symbolic_bitmask $protos { - ipsec 0x10 pct1 0x01 signing 0x20 ssl2 0x02 ssl3 0x04 tls1 0x08 - }] - lappend algs [list algid $algid defkeylen $defaultlen minkeylen $minlen maxkeylen $maxlen protocols $protos name $name description $description] - } - return $algs -} - -proc twapi::crypt_implementation_type {hcrypt} { - return [dict* {1 hardware 2 software 3 mixed 4 unknown 8 removable} [CryptGetProvParam $hcrypt 3 0]] -} - -proc twapi::capi_algid {s} { - if {[string is integer -strict $s]} { - return [expr {$s}]; # Return in decimal form - } - set algid [dict* { - 3des 0x00006603 - 3des_112 0x00006609 - aes 0x00006611 - aes_128 0x0000660e - aes_192 0x0000660f - aes_256 0x00006610 - agreedkey_any 0x0000aa03 - keyexchange 1 - signature 2 - cylink_mek 0x0000660c - des 0x00006601 - desx 0x00006604 - dh_ephem 0x0000aa02 - dh_sf 0x0000aa01 - dss_sign 0x00002200 - ecdh 0x0000aa05 - ecdsa 0x00002203 - ecmqv 0x0000a001 - hash_replace_owf 0x0000800b - hughes_md5 0x0000a003 - hmac 0x00008009 - kea_keyx 0x0000aa04 - mac 0x00008005 - md2 0x00008001 - md4 0x00008002 - md5 0x00008003 - no_sign 0x00002000 - pct1_master 0x00004c04 - rc2 0x00006602 - rc4 0x00006801 - rc5 0x0000660d - rsa_keyx 0x0000a400 - rsa_sign 0x00002400 - schannel_enc_key 0x00004c07 - schannel_mac_key 0x00004c03 - schannel_master_hash 0x00004c02 - sha 0x00008004 - sha1 0x00008004 - sha_256 0x0000800c - sha_384 0x0000800d - sha_512 0x0000800e - ssl2_master 0x00004c05 - ssl3_master 0x00004c01 - ssl3_shamd5 0x00008008 - tls1_master 0x00004c06 - tls1prf 0x0000800a - } $s ""] - - if {$algid eq ""} { - set oid [oid $s] - set algid [CertOIDToAlgId $oid] - if {$algid == 0} { - error "Could not map \"$s\" to algorithm id" - } - } - # Return the decimal form - return [expr {$algid}] -} - -# TBD - document -proc twapi::crypt_find_oid_info {key args} { - array set opts [parseargs args { - {restrict.arg any {sign encrypt any}} - keylen.int - {searchds.bool 0} - {oidgroup.arg 0} - } -maxleftover 0] - - # We will try key to be an OID, Alg Id, sign id or a simple - # name in turn - if {[catch { - set key [oid $key] - set keytype 1; # OID - }]} { - if {[catch { - set key [capi_algid $key] - set keytype 3; # Alg Id - }]} { - if {[catch { - # Sign - list of two alg id's - if {[llength $key] == 2} { - set key [list [capi_algid [lindex $key 0]] [capi_algid [lindex $key 1]]] - set keytype 4 - } else { - set keytype 2 ;# Name - } - }]} { - set keytype 2 ;# Name - } - } - } - - set oidgroup [oidgroup $opts(oidgroup)] - if {$opts(restrict) ne "any"} { - if {$oidgroup != 0 && $oidgroup != 3} { - error "The -restrict option can only be used with the oidgroup_pubkey_alg OID group" - } - if {$opts(restrict) eq "sign"} { - set keytype [expr {$keytype | 0x80000000}] - } else { - set keytype [expr {$keytype | 0x40000000}] - } - } - - if {[info exists opts(keylen)]} { - set oidgroup [expr {$oidgroup | ($opts(keylen) << 16)}] - } - - # Because search of active dir can be slow, turn it off unless - # caller explicitly requests it - if {! $opts(searchds)} { - set oidgroup [expr {$oidgroup | 0x80000000}] - } - - return [CryptFindOIDInfo $keytype $key $oidgroup] -} - -# TBD - document -proc twapi::crypt_enumerate_oid_info {{oidgroup 0}} { - # TBD - parse extra based on OID group - set ret {} - foreach info [CryptEnumOIDInfo [oidgroup $oidgroup]] { - lappend ret [twine {oid name oidgroup value extra} $info] - } - return $ret -} - -# TBD - test -proc twapi::_capi_parse {type arg args} { - parseargs args { - {contenttype.arg any} - {formattype.arg any} - {typesonly.bool 0} - } -setvars -maxleftover 0 - - # First try the formats not supported by CryptQueryObject - if {$contenttype in {any rsapublickey subjectpublickeyinfo}} { - if {$formattype eq "binary"} { - set encoding der - } elseif {$formattype eq "base64"} { - set encoding pem - } else { - set encoding "" - } - if {$type == 1} { - # arg is a file - set fd [open $arg] - trap { - fconfigure $fd -translation binary - set content [_pem_decode [read $fd] $encoding] - set is_pem [_is_pem $content] - } finally { - close $fd - } - } - if {$contenttype in {any subjectpublickeyinfo}} { - trap { - set data [CryptDecodeObjectEx 8 $content] - dict set ret contenttype subjectpublickeyinfo - dict set ret formattype [lindex {binary base64} $is_pem] - if {! $typesonly} { - dict set ret subjectpublickeyinfo $data - } - return $ret - } onerror {} { - if {$contenttype eq "subjectpublickeyinfo"} { - rethrow - } - # Go on to try other types - } - } - if {$contenttype in {any rsapublickey}} { - trap { - set data [CryptDecodeObjectEx 19 $content] - dict set ret contenttype rsapublickey - dict set ret formattype [lindex {binary base64} $is_pem] - if {! $typesonly} { - dict set ret rsapublickey $data - } - return $ret - } onerror {} { - if {$contenttype eq "rsapublickey"} { - rethrow - } - # Go on to try other types - } - } - } - - # No joy. Go on to try CryptQueryObject - - # Note - CERT_QUERY_CONTENT_FLAG_PFX_AND_LOAD not supported - # on XP/2k3 hence not included in expected_content_type - set contenttype [dict! { - cert 2 - ctl 4 - crl 8 - serializedstore 16 - serializedcert 32 - serializedctl 64 - serializedcrl 128 - pkcs7signed 256 - pkcs7unsigned 512 - pkcs7signedembed 1024 - pkcs10 2048 - pfx 4096 - certpair 8192 - any 0x3FFE - } $contenttype] - - set formattype [dict! { - binary 2 - base64 4 - asn1hex 8 - any 14 - } $formattype] - - set ret [CryptQueryObject $type $arg \ - $contenttype $formattype 0 $typesonly] - # We don't mention PKCS7_ASN v/s X509_ASN anywhere and use encoding - # to refer to PEM/DER so leave it off for now - dict unset ret encoding - dict set ret formattype [dict* { - 1 binary - 2 base64 - 3 asn1hex - } [dict get $ret formattype]] - dict set ret contenttype [dict* { - 1 cert - 2 ctl - 3 crl - 4 serializedstore - 5 serializedcert - 6 serializedctl - 7 serializedcrl - 8 pkcs7signed - 9 pkcs7unsigned - 10 pkcs7signedembed - 11 pkcs10 - 12 pfx - 13 certpair - } [dict get $ret contenttype]] - - return $ret -} -interp alias {} twapi::capi_parse_file {} twapi::_capi_parse 1 -interp alias {} twapi::capi_parse {} twapi::_capi_parse 2 - -### -# ASN.1 procs - -# TBD - document -proc twapi::asn1_decode_string {bin} { - # 24 -> X509_UNICODE_ANY_STRING - return [lindex [twapi::CryptDecodeObjectEx 24 $bin] 1] -} - -# TBD - document -proc twapi::asn1_encode_string {s {encformat utf8}} { - # 24 -> X509_UNICODE_ANY_STRING - return [twapi::CryptEncodeObjectEx 24 [list [dict! { - numeric 3 printable 4 teletex 5 t61 5 videotex 6 ia5 7 graphic 8 - visible 9 iso646 9 general 10 universal 11 int4 11 - bmp 12 unicode 12 utf8 13 - } $encformat] $s]] -} - -### -# Key procs - -proc twapi::_capi_key_param {param_id hkey args} { - if {[llength $args] == 0} { - return [CryptGetKeyParam $hkey $param_id] - } - if {[llength $args] == 1} { - return [CryptSetKeyParam $hkey $param_id [lindex $args 0]] - } - badargs! "Invalid syntax. Should be [lindex [info level -1] 0] HKEY ?VALUE?" 3 -} - -proc twapi::capi_key_iv {args} {return [_capi_key_param 1 {*}$args]} -proc twapi::capi_key_mode_bits {args} {return [_capi_key_param 5 {*}$args]} -proc twapi::capi_key_dss_p {args} {return [_capi_key_param 11 {*}$args]} -proc twapi::capi_key_dss_q {args} {return [_capi_key_param 13 {*}$args]} -proc twapi::capi_key_dss_g {args} {return [_capi_key_param 12 {*}$args]} -proc twapi::capi_key_effective_keylen {args} {return [_capi_key_param 19 {*}$args]} - -proc twapi::capi_key_blocklen {hkey} {return [CryptGetKeyParam $hkey 8]} -proc twapi::capi_key_certificate {hkey} {return [CryptGetKeyParam $hkey 26]} -proc twapi::capi_key_keylen {hkey} {return [CryptGetKeyParam $hkey 9]} - -proc twapi::capi_key_algid {hkey args} { - if {[llength $args] == 0} { - return [CryptGetKeyParam $hkey 7] - } - set args [lassign $args algid] - set algid [capi_algid $algid] - array set opts [parseargs args { - {archivable.bool 0 0x4000} - {salt.bool 0 4} - {exportable.bool 0 1} - {pregen.bool 0x40} - {userprotected.bool 0 2} - {nosalt40.bool 0 0x10} - {size.int 0} - } -maxleftover 0] - if {$opts(size) < 0 || $opts(size) > 65535} { - badargs! "Bad key size value '$size': must be positive integer less than 65536" - } - set flags [expr {($opts(size) << 16) | $opts(archivable) | $opts(salt) | $opts(exportable) | $opts(pregen) | $opts(userprotected) | $opts(nosalt40)}] - return [CryptSetKeyParam $hkey 7 $algid $flags] -} - -proc twapi::capi_key_mode {hkey args} { - if {[llength $args] == 0} { - return [dict* {1 cbc 2 ecb 3 ofb 4 cfb 5 cts} [CryptGetKeyParam $hkey 4]] - } - if {[llength $args] == 1} { - set val [dict* {cbc 1 ecb 2 ofb 3 cfb 4 cts 5} [lindex $args 0]] - return [CryptSetKeyParam $hkey 4 $val] - } - badargs! "Invalid syntax. Should be [lindex [info level 0] 0] HKEY ?VALUE?" -} - -proc twapi::capi_key_padding {hkey args} { - if {[llength $args] == 0} { - return [dict* {1 pkcs5 2 random 3 zeroes} [CryptGetKeyParam $hkey 3]] - } - if {[llength $args] == 1} { - set val [dict* {pkcs5 1 random 2 zeroes 3} [lindex $args 0]] - return [CryptSetKeyParam $hkey 3 $val] - } - badargs! "Invalid syntax. Should be [lindex [info level 0] 0] HKEY ?VALUE?" -} - -proc twapi::capi_key_permissions {hkey args} { - set bitmasks { - encrypt 0x01 decrypt 0x02 export 0x04 read 0x08 write 0x10 - mac 0x20 export_key 0x40 import_key 0x80 archive 0x100 - } - if {[llength $args] == 0} { - return [_make_symbolic_bitmask [CryptGetKeyParam $hkey 6] $bitmasks] - } - if {[llength $args] == 1} { - set val [_parse_symbolic_bitmask [lindex $args 0] $bitmasks] - return [CryptSetKeyParam $hkey 6 $val] - } - badargs! "Invalid syntax. Should be [lindex [info level 0] 0] HKEY ?VALUE?" -} - -proc twapi::capi_key_salt {hkey args} { - if {[llength $args] == 0} { - # 2 -> KP_SALT - return [CryptGetKeyParam $hkey 2] - } - if {[llength $args] == 1} { - # 10 -> KP_SALT_EX - return [CryptSetKeyParam $hkey 10 [lindex $args 0]] - } - badargs! "Invalid syntax. Should be [lindex [info level 0] 0] HKEY ?VALUE?" -} - -proc twapi::capi_keyblob_create {ver algid blob_type key} { - # 0 -> reserved field - return [list [_capi_keyblob_type_id $blob_type] $ver 0 [capi_algid $algid] $key] -} - -proc twapi::capi_keyblob_concealed {algid concealed_key} { - # 2 -> bVersion - # 0 -> concealed plaintextkeyblob - # Note: for our own home grown concealed type there is no - # BLOBHEADER - return [capi_keyblob_create 2 $algid concealed $concealed_key] -} - -proc twapi::capi_keyblob_plaintext {algid binkey} { - # typedef struct _PUBLICKEYSTRUC { - # BYTE bType; - # BYTE bVersion; - # WORD reserved; - # ALG_ID aiKeyAlg; - # } BLOBHEADER; - # 2 -> bVersion - set algnum [capi_algid $algid] - set blob_type [_capi_keyblob_type_id plaintext] - set len [string length $binkey] - set blob "[binary format ccsii $blob_type 2 0 $algnum $len]$binkey" - return [capi_keyblob_create 2 $algid plaintext $blob] -} - -proc twapi::capi_keyblob_version {kblob} { - return [lindex $kblob 1] -} - -proc twapi::capi_keyblob_algid {kblob} { - return [lindex $kblob 3] -} - -proc twapi::capi_keyblob_type {kblob} { - return [_capi_keyblob_type_name [lindex $kblob 0]] -} - -proc twapi::capi_keyblob_blob {kblob} { - return [lindex $kblob 4] -} - -proc twapi::_capi_keyblob_type_id {name} { - set blob_type [dict* { - concealed 0 - keystate 12 - opaque 9 - plaintext 8 - privatekey 7 - publickey 6 - publickeyex 10 - rfc3217 11 - simple 1 - } $name] -} - -proc twapi::_capi_keyblob_type_name {id} { - set blob_type [dict* { - 0 concealed - 1 simple - 6 publickey - 7 privatekey - 8 plaintext - 9 opaque - 10 publickeyex - 11 rfc3217 - 12 keystate - } [incr id 0]]; # incr to convert hex etc. to decimal - -} - -### -# Utility procs - -proc twapi::_make_algorithm_identifier {oid {param {}}} { - if {[string length $oid] == 0} { - return "" - } - if {0} { - # TBD - what modes to default to ? - switch -exact -- $oid { -#define szOID_NIST_AES128_CBC "2.16.840.1.101.3.4.1.2" -#define szOID_NIST_AES192_CBC "2.16.840.1.101.3.4.1.22" -#define szOID_NIST_AES256_CBC "2.16.840.1.101.3.4.1.42" - -#// For the above Algorithms, the AlgorithmIdentifier parameters must be -#// present and the parameters field MUST contain an AES-IV: -#// -#// AES-IV ::= OCTET STRING (SIZE(16)) - -#// NIST AES WRAP Algorithms -#define szOID_NIST_AES128_WRAP "2.16.840.1.101.3.4.1.5" -#define szOID_NIST_AES192_WRAP "2.16.840.1.101.3.4.1.25" -#define szOID_NIST_AES256_WRAP "2.16.840.1.101.3.4.1.45" - des { set oid "oid_rsa_des_ede3_cbc" } - des { set oid "oid_oiwsec_descbc" } - aes128 { TBD } - aes192 { TBD } - aes256 { TBD } - rc2 { set oid "oid_rsa_rc2cbc" } - rc4 { set oid "oid_rsa_rc4" } - } - } - set oid [oid $oid] - if {[string length $param]} { - return [list $oid $param] - } else { - return [list $oid] - } -} - -twapi::proc* twapi::_cert_prop_id {prop} { - # Certificate property menomics - variable _cert_prop_name_id_map - array set _cert_prop_name_id_map { - key_prov_handle 1 - key_prov_info 2 - sha1_hash 3 - hash 3 - md5_hash 4 - key_context 5 - key_spec 6 - ie30_reserved 7 - pubkey_hash_reserved 8 - enhkey_usage 9 - ctl_usage 9 - next_update_location 10 - friendly_name 11 - pvk_file 12 - description 13 - access_state 14 - signature_hash 15 - smart_card_data 16 - efs 17 - fortezza_data 18 - archived 19 - key_identifier 20 - auto_enroll 21 - pubkey_alg_para 22 - cross_cert_dist_points 23 - issuer_public_key_md5_hash 24 - subject_public_key_md5_hash 25 - id 26 - date_stamp 27 - issuer_serial_number_md5_hash 28 - subject_name_md5_hash 29 - extended_error_info 30 - - renewal 64 - archived_key_hash 65 - auto_enroll_retry 66 - aia_url_retrieved 67 - authority_info_access 68 - backed_up 69 - ocsp_response 70 - request_originator 71 - source_location 72 - source_url 73 - new_key 74 - ocsp_cache_prefix 75 - smart_card_root_info 76 - no_auto_expire_check 77 - ncrypt_key_handle 78 - hcryptprov_or_ncrypt_key_handle 79 - - subject_info_access 80 - ca_ocsp_authority_info_access 81 - ca_disable_crl 82 - root_program_cert_policies 83 - root_program_name_constraints 84 - subject_ocsp_authority_info_access 85 - subject_disable_crl 86 - cep 87 - - sign_hash_cng_alg 89 - - scard_pin_id 90 - scard_pin_info 91 - } -} { - variable _cert_prop_name_id_map - - if {[string is integer -strict $prop]} { - return $prop - } - if {![info exists _cert_prop_name_id_map($prop)]} { - badargs! "Unknown certificate property id '$prop'" 3 - } - - return $_cert_prop_name_id_map($prop) -} - -twapi::proc* twapi::_cert_prop_name {id} { - variable _cert_prop_name_id_map - variable _cert_prop_id_name_map - - _cert_prop_id key_prov_handle; # Just to init _cert_prop_name_id_map - array set _cert_prop_id_name_map [swapl [array get _cert_prop_name_id_map]] -} { - variable _cert_prop_id_name_map - if {[info exists _cert_prop_id_name_map($id)]} { - return $_cert_prop_id_name_map($id) - } - if {[string is integer -strict $id]} { - return $id - } - badargs! "Unknown certificate property id '$id'" 3 -} - -twapi::proc* twapi::_system_store_id {name} { - variable _system_store_locations - - set _system_store_locations { - service 0x40000 - "" 0x10000 - user 0x10000 - usergrouppolicy 0x70000 - localmachine 0x20000 - localmachineenterprise 0x90000 - localmachinegrouppolicy 0x80000 - services 0x50000 - users 0x60000 - } - - foreach loc [CertEnumSystemStoreLocation 0] { - dict set _system_store_locations {*}$loc - } -} { - variable _system_store_locations - - if {[string is integer -strict $name]} { - if {$name < 65536} { - badargs! "Invalid system store name $name" 3 - } - return $name - } - - return [dict! $_system_store_locations $name 2] -} - -twapi::proc* twapi::_csp_type_name_to_id prov { - variable _csp_type_name_id_map - - array set _csp_type_name_id_map { - prov_rsa_full 1 - prov_rsa_sig 2 - prov_dss 3 - prov_fortezza 4 - prov_ms_exchange 5 - prov_ssl 6 - prov_rsa_schannel 12 - prov_dss_dh 13 - prov_ec_ecdsa_sig 14 - prov_ec_ecnra_sig 15 - prov_ec_ecdsa_full 16 - prov_ec_ecnra_full 17 - prov_dh_schannel 18 - prov_spyrus_lynks 20 - prov_rng 21 - prov_intel_sec 22 - prov_replace_owf 23 - prov_rsa_aes 24 - } -} { - variable _csp_type_name_id_map - - set key [string tolower $prov] - - if {[info exists _csp_type_name_id_map($key)]} { - return $_csp_type_name_id_map($key) - } - - if {[string is integer -strict $prov]} { - return $prov - } - - badargs! "Invalid or unknown provider type '$prov'" 3 -} - -twapi::proc* twapi::_csp_type_id_to_name prov { - variable _csp_type_name_id_map - variable _csp_id_type_name_map - - _csp_type_name_to_id prov_rsa_full; # Just to ensure _csp_type_name_id_map exists - array set _csp_id_type_name_map [swapl [array get _csp_type_name_id_map]] -} { - variable _csp_id_type_name_map - if {[info exists _csp_id_type_name_map($prov)]} { - return $_csp_id_type_name_map($prov) - } - - if {[string is integer -strict $prov]} { - return $prov - } - - badargs! "Invalid or unknown CSP type id '$prov'" 3 -} - -twapi::proc* twapi::oid {name} { - variable _name_oid_map - if {![info exists _name_oid_map]} { - oids; # To init the map - } -} { - variable _name_oid_map - - if {[regexp {^\d+\.\d+(\.\d+)*$} $name]} { - return $name; # OID literal n.n... - } - if {[info exists _name_oid_map($name)]} { - return $_name_oid_map($name) - } - # Try by adding oid_ - if {[info exists _name_oid_map(oid_$name)]} { - return $_name_oid_map(oid_$name) - } - - badargs! "Invalid OID '$name'" - -} - -twapi::proc* twapi::oidname {oid} { - variable _oid_name_map - if {![info exists _oid_name_map]} { - oids; # To init the map - } -} { - variable _oid_name_map - - if {[info exists _oid_name_map($oid)]} { - return $_oid_name_map($oid) - } - if {[regexp {^\d([\d\.]*\d)?$} $oid]} { - return $oid - } else { - badargs! "Invalid OID '$oid'" - } -} - -# TBD - change OID mnemonics to those in RFC (see pki.tcl in tcllib) -twapi::proc* twapi::oids {{pattern *}} { - variable _oid_name_map - variable _name_oid_map - - # TBD - clean up table for rarely used OIDs - array set _name_oid_map { - oid_common_name "2.5.4.3" - oid_sur_name "2.5.4.4" - oid_device_serial_number "2.5.4.5" - oid_country_name "2.5.4.6" - oid_locality_name "2.5.4.7" - oid_state_or_province_name "2.5.4.8" - oid_street_address "2.5.4.9" - oid_organization_name "2.5.4.10" - oid_organizational_unit_name "2.5.4.11" - oid_title "2.5.4.12" - oid_description "2.5.4.13" - oid_search_guide "2.5.4.14" - oid_business_category "2.5.4.15" - oid_postal_address "2.5.4.16" - oid_postal_code "2.5.4.17" - oid_post_office_box "2.5.4.18" - oid_physical_delivery_office_name "2.5.4.19" - oid_telephone_number "2.5.4.20" - oid_telex_number "2.5.4.21" - oid_teletext_terminal_identifier "2.5.4.22" - oid_facsimile_telephone_number "2.5.4.23" - oid_x21_address "2.5.4.24" - oid_international_isdn_number "2.5.4.25" - oid_registered_address "2.5.4.26" - oid_destination_indicator "2.5.4.27" - oid_user_password "2.5.4.35" - oid_user_certificate "2.5.4.36" - oid_ca_certificate "2.5.4.37" - oid_authority_revocation_list "2.5.4.38" - oid_certificate_revocation_list "2.5.4.39" - oid_cross_certificate_pair "2.5.4.40" - - oid_rsa "1.2.840.113549" - oid_pkcs "1.2.840.113549.1" - oid_rsa_hash "1.2.840.113549.2" - oid_rsa_encrypt "1.2.840.113549.3" - - oid_pkcs_1 "1.2.840.113549.1.1" - oid_pkcs_2 "1.2.840.113549.1.2" - oid_pkcs_3 "1.2.840.113549.1.3" - oid_pkcs_4 "1.2.840.113549.1.4" - oid_pkcs_5 "1.2.840.113549.1.5" - oid_pkcs_6 "1.2.840.113549.1.6" - oid_pkcs_7 "1.2.840.113549.1.7" - oid_pkcs_8 "1.2.840.113549.1.8" - oid_pkcs_9 "1.2.840.113549.1.9" - oid_pkcs_10 "1.2.840.113549.1.10" - oid_pkcs_12 "1.2.840.113549.1.12" - - oid_rsa_rsa "1.2.840.113549.1.1.1" - oid_rsa_md2rsa "1.2.840.113549.1.1.2" - oid_rsa_md4rsa "1.2.840.113549.1.1.3" - oid_rsa_md5rsa "1.2.840.113549.1.1.4" - oid_rsa_sha1rsa "1.2.840.113549.1.1.5" - oid_rsa_setoaep_rsa "1.2.840.113549.1.1.6" - - oid_rsa_dh "1.2.840.113549.1.3.1" - - oid_rsa_data "1.2.840.113549.1.7.1" - oid_rsa_signeddata "1.2.840.113549.1.7.2" - oid_rsa_envelopeddata "1.2.840.113549.1.7.3" - oid_rsa_signenvdata "1.2.840.113549.1.7.4" - oid_rsa_digesteddata "1.2.840.113549.1.7.5" - oid_rsa_hasheddata "1.2.840.113549.1.7.5" - oid_rsa_encrypteddata "1.2.840.113549.1.7.6" - - oid_rsa_emailaddr "1.2.840.113549.1.9.1" - oid_rsa_unstructname "1.2.840.113549.1.9.2" - oid_rsa_contenttype "1.2.840.113549.1.9.3" - oid_rsa_messagedigest "1.2.840.113549.1.9.4" - oid_rsa_signingtime "1.2.840.113549.1.9.5" - oid_rsa_countersign "1.2.840.113549.1.9.6" - oid_rsa_challengepwd "1.2.840.113549.1.9.7" - oid_rsa_unstructaddr "1.2.840.113549.1.9.8" - oid_rsa_extcertattrs "1.2.840.113549.1.9.9" - oid_rsa_certextensions "1.2.840.113549.1.9.14" - oid_rsa_smimecapabilities "1.2.840.113549.1.9.15" - oid_rsa_prefersigneddata "1.2.840.113549.1.9.15.1" - - oid_rsa_smimealg "1.2.840.113549.1.9.16.3" - oid_rsa_smimealgesdh "1.2.840.113549.1.9.16.3.5" - oid_rsa_smimealgcms3deswrap "1.2.840.113549.1.9.16.3.6" - oid_rsa_smimealgcmsrc2wrap "1.2.840.113549.1.9.16.3.7" - - oid_rsa_md2 "1.2.840.113549.2.2" - oid_rsa_md4 "1.2.840.113549.2.4" - oid_rsa_md5 "1.2.840.113549.2.5" - - oid_rsa_rc2cbc "1.2.840.113549.3.2" - oid_rsa_rc4 "1.2.840.113549.3.4" - oid_rsa_des_ede3_cbc "1.2.840.113549.3.7" - oid_rsa_rc5_cbcpad "1.2.840.113549.3.9" - - - oid_ansi_x942 "1.2.840.10046" - oid_ansi_x942_dh "1.2.840.10046.2.1" - - oid_x957 "1.2.840.10040" - oid_x957_dsa "1.2.840.10040.4.1" - oid_x957_sha1dsa "1.2.840.10040.4.3" - - oid_ds "2.5" - oid_dsalg "2.5.8" - oid_dsalg_crpt "2.5.8.1" - oid_dsalg_hash "2.5.8.2" - oid_dsalg_sign "2.5.8.3" - oid_dsalg_rsa "2.5.8.1.1" - - oid_pkix_kp_server_auth "1.3.6.1.5.5.7.3.1" - oid_pkix_kp_client_auth "1.3.6.1.5.5.7.3.2" - oid_pkix_kp_code_signing "1.3.6.1.5.5.7.3.3" - oid_pkix_kp_email_protection "1.3.6.1.5.5.7.3.4" - oid_pkix_kp_ipsec_end_system "1.3.6.1.5.5.7.3.5" - oid_pkix_kp_ipsec_tunnel "1.3.6.1.5.5.7.3.6" - oid_pkix_kp_ipsec_user "1.3.6.1.5.5.7.3.7" - oid_pkix_kp_timestamp_signing "1.3.6.1.5.5.7.3.8" - oid_pkix_kp_ocsp_signing "1.3.6.1.5.5.7.3.9" - - oid_oiw "1.3.14" - - oid_oiwsec "1.3.14.3.2" - oid_oiwsec_md4rsa "1.3.14.3.2.2" - oid_oiwsec_md5rsa "1.3.14.3.2.3" - oid_oiwsec_md4rsa2 "1.3.14.3.2.4" - oid_oiwsec_desecb "1.3.14.3.2.6" - oid_oiwsec_descbc "1.3.14.3.2.7" - oid_oiwsec_desofb "1.3.14.3.2.8" - oid_oiwsec_descfb "1.3.14.3.2.9" - oid_oiwsec_desmac "1.3.14.3.2.10" - oid_oiwsec_rsasign "1.3.14.3.2.11" - oid_oiwsec_dsa "1.3.14.3.2.12" - oid_oiwsec_shadsa "1.3.14.3.2.13" - oid_oiwsec_mdc2rsa "1.3.14.3.2.14" - oid_oiwsec_sharsa "1.3.14.3.2.15" - oid_oiwsec_dhcommmod "1.3.14.3.2.16" - oid_oiwsec_desede "1.3.14.3.2.17" - oid_oiwsec_sha "1.3.14.3.2.18" - oid_oiwsec_mdc2 "1.3.14.3.2.19" - oid_oiwsec_dsacomm "1.3.14.3.2.20" - oid_oiwsec_dsacommsha "1.3.14.3.2.21" - oid_oiwsec_rsaxchg "1.3.14.3.2.22" - oid_oiwsec_keyhashseal "1.3.14.3.2.23" - oid_oiwsec_md2rsasign "1.3.14.3.2.24" - oid_oiwsec_md5rsasign "1.3.14.3.2.25" - oid_oiwsec_sha1 "1.3.14.3.2.26" - oid_oiwsec_dsasha1 "1.3.14.3.2.27" - oid_oiwsec_dsacommsha1 "1.3.14.3.2.28" - oid_oiwsec_sha1rsasign "1.3.14.3.2.29" - - oid_oiwdir "1.3.14.7.2" - oid_oiwdir_crpt "1.3.14.7.2.1" - oid_oiwdir_hash "1.3.14.7.2.2" - oid_oiwdir_sign "1.3.14.7.2.3" - oid_oiwdir_md2 "1.3.14.7.2.2.1" - oid_oiwdir_md2rsa "1.3.14.7.2.3.1" - - oid_infosec "2.16.840.1.101.2.1" - oid_infosec_sdnssignature "2.16.840.1.101.2.1.1.1" - oid_infosec_mosaicsignature "2.16.840.1.101.2.1.1.2" - oid_infosec_sdnsconfidentiality "2.16.840.1.101.2.1.1.3" - oid_infosec_mosaicconfidentiality "2.16.840.1.101.2.1.1.4" - oid_infosec_sdnsintegrity "2.16.840.1.101.2.1.1.5" - oid_infosec_mosaicintegrity "2.16.840.1.101.2.1.1.6" - oid_infosec_sdnstokenprotection "2.16.840.1.101.2.1.1.7" - oid_infosec_mosaictokenprotection "2.16.840.1.101.2.1.1.8" - oid_infosec_sdnskeymanagement "2.16.840.1.101.2.1.1.9" - oid_infosec_mosaickeymanagement "2.16.840.1.101.2.1.1.10" - oid_infosec_sdnskmandsig "2.16.840.1.101.2.1.1.11" - oid_infosec_mosaickmandsig "2.16.840.1.101.2.1.1.12" - oid_infosec_suiteasignature "2.16.840.1.101.2.1.1.13" - oid_infosec_suiteaconfidentiality "2.16.840.1.101.2.1.1.14" - oid_infosec_suiteaintegrity "2.16.840.1.101.2.1.1.15" - oid_infosec_suiteatokenprotection "2.16.840.1.101.2.1.1.16" - oid_infosec_suiteakeymanagement "2.16.840.1.101.2.1.1.17" - oid_infosec_suiteakmandsig "2.16.840.1.101.2.1.1.18" - oid_infosec_mosaicupdatedsig "2.16.840.1.101.2.1.1.19" - oid_infosec_mosaickmandupdsig "2.16.840.1.101.2.1.1.20" - oid_infosec_mosaicupdatedinteg "2.16.840.1.101.2.1.1.21" - } - - # OIDs for certificate extensions - array set _name_oid_map { - oid_authority_key_identifier_old "2.5.29.1" - oid_key_attributes "2.5.29.2" - oid_cert_policies_95 "2.5.29.3" - oid_key_usage_restriction "2.5.29.4" - oid_subject_alt_name_old "2.5.29.7" - oid_issuer_alt_name_old "2.5.29.8" - oid_basic_constraints_old "2.5.29.10" - oid_key_usage "2.5.29.15" - oid_privatekey_usage_period "2.5.29.16" - oid_basic_constraints "2.5.29.19" - - oid_cert_policies "2.5.29.32" - oid_any_cert_policy "2.5.29.32.0" - oid_inhibit_any_policy "2.5.29.54" - - oid_authority_key_identifier "2.5.29.35" - oid_subject_key_identifier "2.5.29.14" - oid_subject_alt_name2 "2.5.29.17" - oid_issuer_alt_name "2.5.29.18" - oid_crl_reason_code "2.5.29.21" - oid_reason_code_hold "2.5.29.23" - oid_crl_dist_points "2.5.29.31" - oid_enhanced_key_usage "2.5.29.37" - - oid_any_enhanced_key_usage "2.5.29.37.0" - - oid_crl_number "2.5.29.20" - oid_delta_crl_indicator "2.5.29.27" - oid_issuing_dist_point "2.5.29.28" - oid_freshest_crl "2.5.29.46" - oid_name_constraints "2.5.29.30" - - oid_policy_mappings "2.5.29.33" - oid_legacy_policy_mappings "2.5.29.5" - oid_policy_constraints "2.5.29.36" - } - - array set _oid_name_map [swapl [array get _name_oid_map]] -} { - variable _name_oid_map - return [array get _name_oid_map $pattern] -} - -# TBD - document -proc twapi::oidgroup {oidgroup} { - if {[string is integer -strict $oidgroup]} { - return $oidgroup - } - return [dict! { - oidgroup_hash_alg 1 - oidgroup_encrypt_alg 2 - oidgroup_pubkey_alg 3 - oidgroup_sign_alg 4 - oidgroup_rdn_attr 5 - oidgroup_ext_or_attr 6 - oidgroup_enhkey_usage 7 - oidgroup_policy 8 - oidgroup_template 9 - } $oidgroup] -} - -# TBD - document -proc twapi::oidgroup_token {oidgroup} { - return [lindex { - {} - oidgroup_hash_alg - oidgroup_encrypt_alg - oidgroup_pubkey_alg - oidgroup_sign_alg - oidgroup_rdn_attr - oidgroup_ext_or_attr - oidgroup_enhkey_usage - oidgroup_policy - oidgroup_template - } $oidgroup] -} - -proc twapi::_make_altnames_ext {altnames {critical 0} {issuer 0}} { - set names {} - foreach pair $altnames { - lassign $pair alttype altname - lappend names [list \ - [dict get { - other 1 - email 2 - dns 3 - directory 5 - url 7 - ip 8 - registered 9 - } $alttype] $altname] - } - - return [list [expr {$issuer ? "2.5.29.18" : "2.5.29.17"}] $critical $names] -} - -proc twapi::_get_enhkey_usage_oids {names} { - array set map [oids oid_pkix_kp_*] - - # We use an array to remove duplicates - array set oids {} - foreach name $names { - if {[info exists map($name)]} { - set oids($map($name)) 1 - } elseif {[info exists map(oid_pkix_kp_$name)]} { - set oids($map(oid_pkix_kp_$name)) 1 - } elseif {[regexp {^\d([\d\.]*\d)?$} $name]} { - # Any OID will do - set oids($name) 1 - } else { - error "Invalid Enhanced Key Usage OID \"$name\"" - } - } - return [array names oids] -} - -proc twapi::_make_enhkeyusage_ext {enhkeyusage {critical 0}} { - return [list "2.5.29.37" $critical [_get_enhkey_usage_oids $enhkeyusage]] -} - -twapi::proc* twapi::_init_keyusage_names {} { - variable _keyusage_byte1 - variable _keyusage_byte2 - set _keyusage_byte1 { - digital_signature 0x80 - non_repudiation 0x40 - key_encipherment 0x20 - data_encipherment 0x10 - key_agreement 0x08 - key_cert_sign 0x04 - crl_sign 0x02 - encipher_only 0x01 - } - set _keyusage_byte2 { - decipher_only 0x80 - } -} {} - -proc twapi::_make_basic_constraints_ext {basicconstraints {critical 1}} { - lassign $basicconstraints isca capathlenvalid capathlen - if {[string is boolean $isca] && [string is boolean $capathlenvalid] && - [string is integer -strict $capathlen] && $capathlen >= 0} { - return [list "2.5.29.19" $critical [list $isca $capathlenvalid $capathlen]] - } - error "Invalid basicconstraints value" -} - -proc twapi::_make_keyusage_ext {keyusage {critical 0}} { - variable _keyusage_byte1 - variable _keyusage_byte2 - - _init_keyusage_names - set byte1 0 - set byte2 0 - foreach usage $keyusage { - if {[dict exists $_keyusage_byte1 $usage]} { - set byte1 [expr {$byte1 | [dict get $_keyusage_byte1 $usage]}] - } elseif {[dict exists $_keyusage_byte2 $usage]} { - set byte2 [expr {$byte2 | [dict get $_keyusage_byte2 $usage]}] - } else { - error "Invalid key usage value \"$keyusage\"" - } - } - - set bin [binary format cc $byte1 $byte2] - # 7 -> # unused bits in last byte - return [list "2.5.29.15" $critical [list $bin 7]] -} - -# Given a byte array, decode to key usage flags -proc twapi::_cert_decode_keyusage {bin} { - variable _keyusage_byte1 - variable _keyusage_byte2 - - _init_keyusage_names - - binary scan $bin c* bytes - - if {[llength $bytes] == 0} { - return *; # Field not present, TBD - } - - set usages {} - set byte [lindex $bytes 0] - dict for {key val} $_keyusage_byte1 { - if {$byte & $val} { - lappend usages $key - } - } - - set byte [lindex $bytes 1] - dict for {key val} $_keyusage_byte2 { - if {$byte & $val} { - lappend usages $key - set byte [expr {$byte & ~$val}] - } - } - - if {0} { - # Commented out because some certificates seem to contain - # bits not defined by RF5280. Do not barf on these - - # For the second byte, not all bits are defined. Error if any - # that we do not understand - if {$byte} { - error "Key usage sequence $bytes includes unsupported bits" - } - - # If there are more bytes, they should all be 0 as well - foreach byte [lrange $bytes 2 end] { - if {$byte} { - error "Key usage sequence $bytes includes unsupported bits" - } - } - } - - return $usages -} - -proc twapi::_cert_decode_enhkey {vals} { - set result {} - set symmap [swapl [oids oid_pkix_kp_*]] - foreach val $vals { - if {[dict exists $symmap $val]} { - lappend result [string range [dict get $symmap $val] 12 end] - } else { - lappend result $val - } - } - return $result -} - -proc twapi::_cert_decode_extension {oid val} { - # TBD - see what other types need to be decoded - # 2.5.29.19 - basic constraints - # - switch $oid { - 2.5.29.15 { return [_cert_decode_keyusage $val] } - 2.5.29.37 { return [_cert_decode_enhkey $val] } - 2.5.29.17 - - 2.5.29.18 { - # TBD - replace with lmap for 8.6 - set names {} - foreach elem $val { - lappend names [list [dict* { - 1 other 2 email 3 dns 5 directory 7 url 8 ip 9 registered - } [lindex $elem 0]] [lindex $elem 1]] - } - return $names - } - } - return $val -} - -proc twapi::_crypt_keyspec {keyspec} { - return [dict* {keyexchange 1 signature 2} $keyspec] -} - -proc twapi::_cert_create_parse_options {optvals optsvar} { - upvar 1 $optsvar opts - - # TBD - add -issueraltnames - parseargs optvals { - start.arg - end.arg - serialnumber.arg - altnames.arg - enhkeyusage.arg - keyusage.arg - basicconstraints.arg - {purpose.arg {}} - {capathlen.int -1} - } -ignoreunknown -setvars - - set ca [expr {"ca" in $purpose}] - if {$ca} { - if {[info exists basicconstraints]} { - badargs! "Option -basicconstraints cannot be specified if \"ca\" is included in the -purpose option" - } - if {$capathlen < 0} { - set basicconstraints {{1 0 0} 1}; # No path length constraint - } else { - set basicconstraints [list [list 1 1 $capathlen] 1] - } - } else { - if {![info exists basicconstraints]} { - set basicconstraints {{0 0 0} 1} - } - } - set sslserver [expr {"server" in $purpose}] - set sslclient [expr {"client" in $purpose}] - - if {[info exists serialnumber]} { - if {$serialnumber <= 0 || $serialnumber > 0x7fffffffffffffff} { - badargs! "Serial number must be specified as a positive wide integer." - } - # Format as little endian - set opts(serialnumber) [binary format w $serialnumber] - } else { - # Generate 15 byte random and add high byte (little endian) - # to 0x01 to ensure it is treated as positive - set opts(serialnumber) "[random_bytes 15]\x01" - } - - # Validity period - if {[info exists start]} { - set opts(start) $start - } else { - set opts(start) [_seconds_to_timelist [clock seconds] 1] - } - if {[info exists end]} { - set opts(end) $end - } else { - set opts(end) $opts(start) - lset opts(end) 0 [expr {[lindex $opts(end) 0] + 1}] - # Ensure valid date (Feb 29 leap year -> non-leap year for example) - set opts(end) [clock format [clock scan [lrange $opts(end) 0 2] -format "%Y %N %e"] -format "%Y %N %e"] - lappend opts(end) 23 59 59 0 - } - - # Generate the extensions list - set exts {} - lappend exts [_make_basic_constraints_ext {*}$basicconstraints ] - if {$ca} { - lappend extra_keyusage key_cert_sign crl_sign - } - if {$sslserver || $sslclient} { - # TBD - not clear key_agreement is needed for SSL certs for - # either client or server. See - # https://access.redhat.com/documentation/en-us/red_hat_certificate_system/10/html/administration_guide/standard_x.509_v3_certificate_extensions - lappend extra_keyusage digital_signature key_encipherment key_agreement - if {$sslserver} { - lappend extra_enhkeyusage oid_pkix_kp_server_auth - } - if {$sslclient} { - lappend extra_enhkeyusage oid_pkix_kp_client_auth - } - } - - if {[info exists extra_keyusage]} { - if {[info exists keyusage]} { - # TBD - should it be marked critical or not ? - lset keyusage 0 [concat [lindex $keyusage 0] $extra_keyusage] - } else { - # TBD - should it be marked critical or not ? - set keyusage [list $extra_keyusage 1] - } - } - - if {[info exists keyusage]} { - lappend exts [_make_keyusage_ext {*}$keyusage] - } - - if {[info exists extra_enhkeyusage]} { - if {[info exists enhkeyusage]} { - # TBD - should it be marked critical or not ? - lset enhkeyusage 0 [concat [lindex $enhkeyusage 0] $extra_enhkeyusage] - } else { - # TBD - should it be marked critical or not ? - set enhkeyusage [list $extra_enhkeyusage 1] - } - } - if {[info exists enhkeyusage]} { - lappend exts [_make_enhkeyusage_ext {*}$enhkeyusage] - } - - if {[info exists altnames]} { - lappend exts [_make_altnames_ext {*}$altnames] - } - - set opts(extensions) $exts - - return $optvals -} - -proc twapi::_cert_add_parseargs {vargs} { - upvar 1 $vargs optvals - parseargs optvals { - {disposition.arg preserve {overwrite duplicate update preserve}} - } -maxleftover 0 -setvars - - # 4 -> CERT_STORE_ADD_ALWAYS - # 3 -> CERT_STORE_ADD_REPLACE_EXISTING - # 6 -> CERT_STORE_ADD_NEWER - # 1 -> CERT_STORE_ADD_NEW - - return [list disposition \ - [dict get { - duplicate 4 - overwrite 3 - update 6 - preserve 1 - } $disposition]] -} - -proc twapi::_parse_store_open_opts {optvals} { - array set opts [parseargs optvals { - {commitenable.bool 0 0x00010000} - {readonly.bool 0 0x00008000} - {existing.bool 0 0x00004000} - {create.bool 0 0x00002000} - {includearchived.bool 0 0x00000200} - {maxpermissions.bool 0 0x00001000} - {deferclose.bool 0 0x00000004} - {backupprivilege.bool 0 0x00000800} - } -maxleftover 0 -nulldefault] - - set flags 0 - foreach {opt val} [array get opts] { - incr flags $val - } - return $flags -} - -# Helper to return as der/pem based on encoding option -proc twapi::_as_pem_or_der {bin tag encoding} { - if {$encoding eq "pem"} { - # 1 -> CRYPT_STRING_BASE64 - # 0x80000000 -> LF-only, not CRLF - return "-----BEGIN $tag-----\n[CryptBinaryToString $bin 0x80000001]-----END $tag-----\n" - } else { - return $bin - } -} - -# Helper for converting input parameters if they are in PEM format -# pem_or_der is the data -# enc specifies the type of pem_or_der. If empty, we guess. -# pemtype should generally be -# 0 -> CRYPT_STRING_BASE64HEADER for certificates -# 1 -> CRYPT_STRING_BASE64 (no header) -# 3 -> CRYPT_STRING_BASE64REQUESTHEADER -# 6 -> CRYPT_STRING_BASE64_ANY (actually same as 0 or 1) -proc twapi::_pem_decode {pem_or_der enc {pemtype 6}} { - if {$enc eq "der"} { - return $pem_or_der - } - if {$enc eq "pem" || - [regexp -nocase {^\s*-----\s*BEGIN\s+} $pem_or_der]} { - return [CryptStringToBinary $pem_or_der $pemtype] - } - return $pem_or_der -} - -proc twapi::_is_pem {pem_or_der} { - return [regexp -nocase {^\s*-----\s*BEGIN\s+} $pem_or_der] -} - -# Utility proc to generate certs in a memory store - -# one self signed which is used to sign a client and a server cert -proc twapi::make_test_certs {{hstore {}} args} { - crypt_test_container_cleanup - - parseargs args { - {csp.arg {Microsoft Strong Cryptographic Provider}} - {csptype.arg prov_rsa_full} - unique - {duration.int 5} - } -maxleftover 0 -setvars - - set enddate [clock format [clock seconds] -format "%Y %N %e"] - lset enddate 0 [expr {[lindex $enddate 0]+$duration}] - # Ensure valid date e.g. Feb 29 non-leap year - set enddate [clock format [clock scan $enddate -format "%Y %N %e"] -format "%Y %N %e"] - - if {$unique} { - set uuid [twapi::new_uuid] - } else { - set uuid "" - } - - # Create the self signed CA cert - set container twapitestca$uuid - set crypt [twapi::crypt_acquire $container -csp $csp -csptype $csptype -create 1] - twapi::crypt_key_free [twapi::crypt_generate_key $crypt signature -exportable 1] - set ca_altnames [list [list [list email ${container}@twapitest.com] [list dns ${container}.twapitest.com] [list url http://${container}.twapitest.com] [list directory [cert_name_to_blob "CN=${container}altname"]] [list ip [binary format c4 {127 0 0 2}]]]] - set cert [twapi::cert_create_self_signed_from_crypt_context "CN=$container, C=IN, O=Tcl, OU=twapi" $crypt -purpose {ca} -altnames $ca_altnames -end $enddate] - if {[llength $hstore] == 0} { - set hstore [twapi::cert_temporary_store] - } - set ca_certificate [twapi::cert_store_add_certificate $hstore $cert] - twapi::cert_release $cert - twapi::cert_set_key_prov $ca_certificate $container signature -csp $csp -csptype $csptype - crypt_free $crypt - - # Create the client and server certs - foreach cert_type {intermediate server client altserver full min} { - set container twapitest${cert_type}$uuid - set subject $container - set crypt [twapi::crypt_acquire $container -csp $csp -csptype $csptype -create 1] - twapi::crypt_key_free [twapi::crypt_generate_key $crypt keyexchange -exportable 1] - switch $cert_type { - intermediate { - set req [cert_request_create "CN=$container, C=IN, O=Tcl, OU=twapi" $crypt keyexchange -purpose ca] - set signing_cert $ca_certificate - } - altserver { - # No COMMON name. Used for testing use of DNS altname - set altnames [list [list [list dns ${cert_type}.twapitest.com] [list dns ${cert_type}2.twapitest.com]]] - set req [cert_request_create "C=IN, O=Tcl, OU=twapi, OU=$container" $crypt keyexchange -purpose $cert_type -altnames $altnames] - set signing_cert $ca_certificate - } - client - - server { - set req [cert_request_create "CN=$container, C=IN, O=Tcl, OU=twapi" $crypt keyexchange -purpose $cert_type] - set signing_cert $intermediate_certificate - } - full { - set altnames [list [list [list email ${container}@twapitest.com] [list dns ${cert_type}.twapitest.com] [list url http://${container}.twapitest.com] [list directory [cert_name_to_blob "CN=${container}altname"]] [list ip [binary format c4 {127 0 0 1}]]]] - set req [cert_request_create \ - "CN=$container, C=IN, O=Tcl, OU=twapi" \ - $crypt keyexchange \ - -keyusage [list {crl_sign data_encipherment digital_signature key_agreement key_cert_sign key_encipherment non_repudiation} 1]\ - -enhkeyusage [list {client_auth code_signing email_protection ipsec_end_system ipsec_tunnel ipsec_user server_auth timestamp_signing ocsp_signing} 1] \ - -altnames $altnames] - set signing_cert $ca_certificate - } - min { - set req [cert_request_create "CN=$container" $crypt keyexchange] - set signing_cert $ca_certificate - } - } - crypt_free $crypt - set parsed_req [cert_request_parse $req] - set subject [dict get $parsed_req subject] - set pubkey [dict get $parsed_req pubkey] - set opts {} - foreach optname {-basicconstraints -keyusage -enhkeyusage -altnames} { - if {[dict exists $parsed_req extensions $optname]} { - lappend opts $optname [dict get $parsed_req extensions $optname] - } - } - set encoded_cert [cert_create $subject $pubkey $signing_cert {*}$opts -end $enddate] - set certificate [twapi::cert_store_add_encoded_certificate $hstore $encoded_cert] - twapi::cert_set_key_prov $certificate $container keyexchange -csp $csp -csptype $csptype - if {$cert_type eq "intermediate"} { - set intermediate_certificate $certificate - } else { - cert_release $certificate - } - } - - cert_release $ca_certificate - cert_release $intermediate_certificate - return $hstore -} - -proc twapi::dump_test_certs {hstore dir {pfxfile twapitest.pfx}} { - set fd [open [file join $dir $pfxfile] wb] - puts -nonewline $fd [cert_store_export_pfx $hstore "" -exportprivatekeys 1] - close $fd - cert_store_iterate $hstore c { - set fd [open [file join $dir [cert_subject_name $c -name simpledisplay].cer] wb] - puts -nonewline $fd [cert_export $c] - close $fd - } -} - -proc twapi::crypt_test_containers {} { - set crypt [crypt_acquire "" -verifycontext 1] - twapi::trap { - set names {} - foreach name [crypt_key_container_names $crypt] { - if {[string match -nocase twapitest* $name]} { - lappend names $name - } - } - } finally { - crypt_free $crypt - } - return $names -} - -proc twapi::crypt_test_container_cleanup {} { - foreach c [crypt_test_containers] { - crypt_key_container_delete $c - } -} - - -# 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_crypto_rc_sourced]} { - source [file join [file dirname [info script]] sspi.tcl] - source [file join [file dirname [info script]] tls.tcl] -} - diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/device.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/device.tcl deleted file mode 100644 index 3daf681e..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/device.tcl +++ /dev/null @@ -1,624 +0,0 @@ -# -# 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" -} - diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/etw.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/etw.tcl deleted file mode 100644 index df8d60a0..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/etw.tcl +++ /dev/null @@ -1,1390 +0,0 @@ -# -# Copyright (c) 2012-2014 Ashok P. Nadkarni -# All rights reserved. -# -# See the file LICENSE for license - -namespace eval twapi { - # GUID's and event types for ETW. - variable _etw_mof - array set _etw_mof { - provider_name "TwapiETWProvider" - provider_guid "{B358E9D9-4D82-4A82-A129-BAC098C54746}" - eventclass_name "TwapiETWEventClass" - eventclass_guid "{D5B52E95-8447-40C1-B316-539894449B36}" - } - - # So we don't pollute namespace with temp vars - apply [list defs { - foreach {key val} $defs { - proc etw_twapi_$key {} "return $val" - } - } [namespace current]] [array get _etw_mof] - - # Cache of event definitions for parsing MOF events. Nested dictionary - # with the following structure (uppercase keys are variables, - # lower case are constant/tokens, "->" is nested dict, "-" is scalar): - # EVENTCLASSGUID -> - # classname - name of the class - # definitions -> - # VERSION -> - # EVENTTYPE -> - # eventtype - same as EVENTTYPE - # eventtypename - name / description for the event type - # fieldtypes - ordered list of field types for that event - # fields -> - # FIELDINDEX -> - # type - the field type in string format - # fieldtype - the corresponding field type numeric value - # extension - the MoF extension qualifier for the field - # - # The cache assumes that MOF event definitions are globally identical - # (ie. same on local and remote systems) - variable _etw_event_defs - set _etw_event_defs [dict create] - - # Keeps track of open trace handles for reading - variable _etw_trace_consumers - array set _etw_trace_consumers {} - - # Keep track of trace controller handles. Note we do not always - # need a handle for controller actions. We can also control based - # on name, for example if some other process has started the trace - variable _etw_trace_controllers - array set _etw_trace_controllers {} - - # - # These record definitions match the lists constructed in the ETW C code - # Note these are purposely formatted on single line so the record fieldnames - # print better. - - # Buffer header (EVENT_TRACE_LOGFILE) - record etw_event_trace_logfile {logfile logger_name current_time buffers_read trace_logfile_header buffer_size filled kernel_trace} - - # TRACE_LOGFILE_HEADER - record etw_trace_logfile_header {buffer_size version_major version_minor version_submajor version_subminor provider_version processor_count end_time timer_resolution max_file_size logfile_mode buffers_written pointer_size events_lost cpu_mhz time_zone boot_time perf_frequency start_time reserved_flags buffers_lost } - - # TDH based event definitions - - record tdh_event { header buffer_context extended_data data } - - record tdh_event_header { flags event_property tid pid timestamp - kernel_time user_time processor_time activity_id descriptor provider_guid} - record tdh_event_buffer_context { processor logger_id } - record tdh_event_data {provider_guid event_guid decoder provider_name level_name channel_name keyword_names task_name opcode_name message localized_provider_name activity_id related_activity_id properties flags} - - record tdh_event_data_descriptor {id version channel level opcode task keywords} - - # Definitions for EVENT_TRACE_LOGFILE - record tdh_buffer { logfile logger current_time buffers_read header buffer_size filled kernel_trace } - - record tdh_logfile_header { size major_version minor_version sub_version subminor_version provider_version processor_count end_time resolution max_file_size logfile_mode buffers_written pointer_size events_lost cpu_mhz timezone boot_time perf_frequency start_time reserved_flags buffers_lost } - - # MOF based event definitions - record mof_event {header instance_id parent_instance_id parent_guid data} - record mof_event_header {type level version tid pid timestamp guid kernel_time user_time processor_time} - - # Standard app visible event definitions. These are made - # compatible with the evt_* routines - record etw_event {-eventid -version -channel -level -opcode -task -keywordmask -timecreated -tid -pid -providerguid -usertime -kerneltime -providername -eventguid -channelname -levelname -opcodename -taskname -keywords -properties -message -sid} - - # Record for EVENT_TRACE_PROPERTIES - # TBD - document - record etw_trace_properties {logfile trace_name trace_guid buffer_size min_buffers max_buffers max_file_size logfile_mode flush_timer enable_flags clock_resolution age_limit buffer_count free_buffers events_lost buffers_written log_buffers_lost real_time_buffers_lost logger_tid} -} - - -proc twapi::etw_get_traces {args} { - parseargs args {detail} -setvars -maxleftover 0 - set sessions {} - foreach sess [QueryAllTraces] { - set name [etw_trace_properties trace_name $sess] - if {$detail} { - lappend sessions [etw_trace_properties $sess] - } else { - lappend sessions $name - } - } - return $sessions -} - -if {[twapi::min_os_version 6]} { - proc twapi::etw_get_provider_guid {name} { - return [lindex [Twapi_TdhEnumerateProviders $name] 0] - } - proc twapi::etw_get_providers {args} { - parseargs args { - detail - {types.arg {mof xml}} - } -setvars -maxleftover 0 - set providers {} - foreach rec [Twapi_TdhEnumerateProviders] { - lassign $rec guid type name - set type [dict* {0 xml 1 mof} $type] - if {$type in $types} { - if {$detail} { - lappend providers [list guid $guid type $type name $name] - } else { - lappend providers $name - } - } - } - return $providers - } -} else { - twapi::proc* twapi::etw_get_provider_guid {lookup_name} { - package require twapi_wmi - } { - set wmi [wmi_root -root wmi] - set oclasses {} - set providers {} - # TBD - check if ExecQuery would be faster - trap { - # All providers are direct subclasses of the EventTrace class - set oclasses [wmi_collect_classes $wmi -ancestor EventTrace -shallow] - foreach ocls $oclasses { - set quals [$ocls Qualifiers_] - trap { - set name [$quals -with {{Item Description}} -invoke Value 2 {}] - if {[string equal -nocase $name $lookup_name]} { - return [$quals -with {{Item Guid}} -invoke Value 2 {}] - } - } finally { - $quals -destroy - } - } - } finally { - foreach ocls $oclasses {$ocls -destroy} - $wmi -destroy - } - return "" - } - - twapi::proc* twapi::etw_get_providers {args} { - package require twapi_wmi - } { - parseargs args { detail {types.arg {mof xml}} } -setvars -maxleftover 0 - if {"mof" ni $types} { - return {}; # Older systems do not have xml based providers - } - set wmi [wmi_root -root wmi] - set oclasses {} - set providers {} - # TBD - check if ExecQuery would be faster - trap { - # All providers are direct subclasses of the EventTrace class - set oclasses [wmi_collect_classes $wmi -ancestor EventTrace -shallow] - foreach ocls $oclasses { - set quals [$ocls Qualifiers_] - trap { - set name [$quals -with {{Item Description}} -invoke Value 2 {}] - set guid [$quals -with {{Item Guid}} -invoke Value 2 {}] - if {$detail} { - lappend providers [list guid $guid type mof name $name] - } else { - lappend providers $name - } - } finally { - $quals -destroy - } - } - } finally { - foreach ocls $oclasses {$ocls -destroy} - $wmi -destroy - } - return $providers - } -} - -twapi::proc* twapi::etw_install_twapi_mof {} { - package require twapi_wmi -} { - variable _etw_mof - - # MOF definition for our ETW trace event. This is loaded into - # the system WMI registry so event readers can decode our events - # - # Note all strings are NullTerminated and not Counted so embedded nulls - # will not be handled correctly. The problem with using Counted strings - # is that the MSDN docs are inconsistent as to whether the count - # is number of *bytes* or number of *characters* and the existing tools - # are similarly confused. We avoid this by choosing null terminated - # strings despite the embedded nulls drawback. - # TBD - revisit this and see if counted can always be treated as - # bytes and not characters. - - # We do not want the pure binary builds think #pragma is a comment - # and remove the line! Bug 170 - #createtmfile-disable-compaction - set mof_template { - #pragma namespace("\\\\.\\root\\wmi") - - // Keep Description same as provider_name as that is how - // TDH library identifies it. Else there will be a mismatch - // between TdhEnumerateProviders and how we internally assume is - // the provider name - [dynamic: ToInstance, Description("@provider_name"), - Guid("@provider_guid")] - class @provider_name : EventTrace - { - }; - - [dynamic: ToInstance, Description("TWAPI ETW event class"): Amended, - Guid("@eventclass_guid")] - class @eventclass_name : @provider_name - { - }; - - // NOTE: The EventTypeName is REQUIRED else the MS LogParser app - // crashes (even though it should not) - - [dynamic: ToInstance, Description("TWAPI log message"): Amended, - EventType(1), EventTypeName("Message")] - class @eventclass_name_Message : @eventclass_name - { - [WmiDataId(1), Description("Log message"): Amended, read, StringTermination("NullTerminated"), Format("w")] string Message; - }; - - [dynamic: ToInstance, Description("TWAPI variable trace"): Amended, - EventType(2), EventTypeName("VariableTrace")] - class @eventclass_name_VariableTrace : @eventclass_name - { - [WmiDataId(1), Description("Operation"): Amended, read, StringTermination("NullTerminated"), Format("w")] string Operation; - [WmiDataId(2), Description("Variable name"): Amended, read, StringTermination("NullTerminated"), Format("w")] string Name; - [WmiDataId(3), Description("Array index"): Amended, read, StringTermination("NullTerminated"), Format("w")] string Index; - [WmiDataId(4), Description("Value"): Amended, read, StringTermination("NullTerminated"), Format("w")] string Value; - [WmiDataId(5), Description("Context"): Amended, read, StringTermination("NullTerminated"), Format("w")] string Context; - }; - - [dynamic: ToInstance, Description("TWAPI execution trace"): Amended, - EventType(3), EventTypeName("ExecutionTrace")] - class @eventclass_name_ExecutionTrace : @eventclass_name - { - [WmiDataId(1), Description("Operation"): Amended, read, StringTermination("NullTerminated"), Format("w")] string Operation; - [WmiDataId(2), Description("Executed command"): Amended, read, StringTermination("NullTerminated"), Format("w")] string Command; - [WmiDataId(3), Description("Status code"): Amended, read, StringTermination("NullTerminated"), Format("w")] string Code; - [WmiDataId(4), Description("Result"): Amended, read, StringTermination("NullTerminated"), Format("w")] string Result; - [WmiDataId(5), Description("Context"): Amended, read, StringTermination("NullTerminated"), Format("w")] string Context; - }; - - [dynamic: ToInstance, Description("TWAPI command trace"): Amended, - EventType(4), EventTypeName("CommandTrace")] - class @eventclass_name_CommandTrace : @eventclass_name - { - [WmiDataId(1), Description("Operation"): Amended, read, StringTermination("NullTerminated"), Format("w")] string Operation; - [WmiDataId(2), Description("Old command name"): Amended, read, StringTermination("NullTerminated"), Format("w")] string OldName; - [WmiDataId(3), Description("New command name"): Amended, read, StringTermination("NullTerminated"), Format("w")] string NewName; - [WmiDataId(4), Description("Context"): Amended, read, StringTermination("NullTerminated"), Format("w")] string Context; - }; - } - - #createtmfile-enable-compaction - - set mof [string map \ - [list @provider_name $_etw_mof(provider_name) \ - @provider_guid $_etw_mof(provider_guid) \ - @eventclass_name $_etw_mof(eventclass_name) \ - @eventclass_guid $_etw_mof(eventclass_guid) \ - ] $mof_template] - - set mofc [twapi::IMofCompilerProxy new] - twapi::trap { - $mofc CompileBuffer $mof - } finally { - $mofc Release - } -} - -proc twapi::etw_uninstall_twapi_mof {} { - variable _etw_mof - - set wmi [twapi::_wmi wmi] - trap { - set omof [$wmi Get $_etw_mof(provider_name)] - $omof Delete_ - } finally { - if {[info exists omof]} { - $omof destroy - } - $wmi destroy - } -} - -proc twapi::etw_twapi_provider_register {} { - variable _etw_mof - return [twapi::RegisterTraceGuids $_etw_mof(provider_guid) $_etw_mof(eventclass_guid)] -} - -proc twapi::etw_log_message {htrace message {level 4}} { - set level [_etw_level_to_int $level] - if {[etw_provider_enable_level] >= $level} { - # Must match Message event type in MoF definition - # 1 -> event type for Message - TraceEvent $htrace 1 $level [encoding convertto unicode "$message\0"] - } -} - -proc twapi::etw_variable_tracker {htrace name1 name2 op} { - switch -exact -- $op { - array - - unset { set var "" } - default { - if {$name2 eq ""} { - upvar 1 $name1 var - } else { - upvar 1 $name1($name2) var - } - } - } - - if {[info level] > 1} { - set context [info level -1] - } else { - set context "" - } - - # Must match VariableTrace event type in MoF definition - TraceEvent $htrace 2 0 \ - [encoding convertto unicode "$op\0$name1\0$name2\0$var\0"] \ - [_etw_encode_limited_unicode $context] -} - - -proc twapi::etw_execution_tracker {htrace command args} { - set op [lindex $args end] - - switch -exact -- $op { - enter - - enterstep { - set code "" - set result "" - } - leave - - leavestep { - lassign $args code result - } - } - - if {[info level] > 1} { - set context [info level -1] - } else { - set context "" - } - - # Must match Execution event type in MoF definition - TraceEvent $htrace 3 0 \ - [encoding convertto unicode "$op\0"] \ - [_etw_encode_limited_unicode $command] \ - [encoding convertto unicode "$code\0"] \ - [_etw_encode_limited_unicode $result] \ - [_etw_encode_limited_unicode $context] -} - - -proc twapi::etw_command_tracker {htrace oldname newname op} { - if {[info level] > 1} { - set context [info level -1] - } else { - set context "" - } - # Must match CommandTrace event type in MoF definition - TraceEvent $htrace 4 0 \ - [encoding convertto unicode "$op\0$oldname\0$newname\0"] \ - [_etw_encode_limited_unicode $context] -} - -proc twapi::etw_parse_mof_event_class {ocls} { - # Returns a dict - # First level key - event type (integer) - # See description of _etw_event_defs for rest of the structure - - set result [dict create] - - # Iterate over the subclasses, collecting the event metadata - # Create a forward only enumerator for efficiency - # wbemFlagUseAmendedQualifiers|wbemFlagReturnImmediately|wbemFlagForwardOnly - # wbemQueryFlagsShallow - # -> 0x20031 - $ocls -with {{SubClasses_ 0x20031}} -iterate -cleanup osub { - # The subclass must have the eventtype property - # We fetch as a raw value so we can tell the - # original type - if {![catch { - $osub -with { - Qualifiers_ - {Item EventType} - } -invoke Value 2 {} -raw 1 - } event_types]} { - - # event_types is a raw value with a type descriptor as elem 0 - if {[variant_type $event_types] & 0x2000} { - # It is VT_ARRAY so value is already a list - set event_types [variant_value $event_types 0 0 0] - } else { - set event_types [list [variant_value $event_types 0 0 0]] - } - - set event_type_names {} - catch { - set event_type_names [$osub -with { - Qualifiers_ - {Item EventTypeName} - } -invoke Value 2 {} -raw 1] - # event_type_names is a raw value with a type descriptor as elem 0 - # It is IMPORTANT to check this else we cannot distinguish - # between a array (list) and a string with spaces - if {[variant_type $event_type_names] & 0x2000} { - # It is VT_ARRAY so value is already a list - set event_type_names [variant_value $event_type_names 0 0 0] - } else { - # Scalar value. Make into a list - set event_type_names [list [variant_value $event_type_names 0 0 0]] - } - } - - # The subclass has a EventType property. Pick up the - # field definitions. - set fields [dict create] - $osub -with Properties_ -iterate -cleanup oprop { - set quals [$oprop Qualifiers_] - # Event fields will have a WmiDataId qualifier - if {![catch {$quals -with {{Item WmiDataId}} Value} wmidataid]} { - # Yep this is a field, figure out its type - set type [_etw_decipher_mof_event_field_type $oprop $quals] - dict set type -fieldname [$oprop -get Name] - dict set fields $wmidataid $type - } - $quals destroy - } - - # Process the records to put the fields in order based on - # their wmidataid. If any info is missing or inconsistent - # we will mark the whole event type class has undecodable. - # Ids begin from 1. - set fieldtypes {} - for {set id 1} {$id <= [dict size $fields]} {incr id} { - if {![dict exists $fields $id]} { - # Discard all type info - missing type info - debuglog "Missing id $id for event type(s) $event_types for EventTrace Mof Class [$ocls -with {{SystemProperties_} {Item __CLASS}} Value]" - set fieldtypes {} - break; - } - lappend fieldtypes [dict get $fields $id -fieldname] [dict get $fields $id -fieldtype] - } - - foreach event_type $event_types event_type_name $event_type_names { - dict set result -definitions $event_type [dict create -eventtype $event_type -eventtypename $event_type_name -fields $fields -fieldtypes $fieldtypes] - } - } - } - - if {[dict size $result] == 0} { - return {} - } else { - dict set result -classname [$ocls -with {SystemProperties_ {Item __CLASS}} Value] - return $result - } -} - -# Deciphers an event field type - -proc twapi::_etw_decipher_mof_event_field_type {oprop oquals} { - # Maps event field type strings to enums to pass to the C code - # 0 should be unmapped. Note some are duplicates because they - # are the same format. Some are legacy formats not explicitly documented - # in MSDN but found in the sample code. - # Reference - Event Tracing MOF Qualifiers http://msdn.microsoft.com/en-us/library/windows/desktop/aa363800(v=vs.85).aspx - set etw_fieldtypes { - string 1 - stringnullterminated 1 - wstring 2 - wstringnullterminated 2 - stringcounted 3 - stringreversecounted 4 - wstringcounted 5 - wstringreversecounted 6 - boolean 7 - sint8 8 - uint8 9 - csint8 10 - cuint8 11 - sint16 12 - uint16 13 - uint32 14 - sint32 15 - sint64 16 - uint64 17 - xsint16 18 - xuint16 19 - xsint32 20 - xuint32 21 - xsint64 22 - xuint64 23 - real32 24 - real64 25 - object 26 - char16 27 - uint8guid 28 - objectguid 29 - objectipaddrv4 30 - uint32ipaddr 30 - objectipaddr 30 - objectipaddrv6 31 - objectvariant 32 - objectsid 33 - uint64wmitime 34 - objectwmitime 35 - uint16port 38 - objectport 39 - datetime 40 - stringnotcounted 41 - wstringnotcounted 42 - pointer 43 - sizet 43 - } - - # On any errors, we will set type to unknown or unsupported - set type unknown - set quals(extension) ""; # Hint for formatting for display - - if {![catch { - $oquals -with {{Item Pointer}} Value - }]} { - # Actual value does not matter - # If the Pointer qualifier exists, ignore everything else - set type pointer - } elseif {![catch { - $oquals -with {{Item PointerType}} Value - }]} { - # Actual value does not matter - # Some apps mistakenly use PointerType instead of Pointer - set type pointer - } else { - catch { - set type [string tolower [$oquals -with {{Item CIMTYPE}} Value]] - - # The following qualifiers may or may not exist - # TBD - not all may be required to be retrieved - # NOTE: MSDN says some qualifiers are case sensitive! - foreach qual {BitMap BitValues Extension Format Pointer StringTermination ValueMap Values ValueType XMLFragment} { - # catch in case it does not exist - set lqual [string tolower $qual] - set quals($lqual) "" - catch { - set quals($lqual) [$oquals -with [list [list Item $qual]] Value] - } - } - set type [string tolower "$quals(format)${type}$quals(stringtermination)"] - set quals(extension) [string tolower $quals(extension)] - # Not all extensions affect how the event field is extracted - # e.g. the noprint value - if {$quals(extension) in {ipaddr ipaddrv4 ipaddrv6 port variant wmitime guid sid}} { - append type $quals(extension) - } elseif {$quals(extension) eq "sizet"} { - set type sizet - } - } - } - - # Cannot handle arrays yet - TBD - if {[$oprop -get IsArray]} { - set type "arrayof$type" - } - - if {![dict exists $etw_fieldtypes $type]} { - set fieldtype 0 - } else { - set fieldtype [dict get $etw_fieldtypes $type] - } - - return [dict create -type $type -fieldtype $fieldtype -extension $quals(extension)] -} - -proc twapi::etw_find_mof_event_classes {oswbemservices args} { - # Return all classes where a GUID or name matches - - # To avoid iterating the tree multiple times, separate out the guids - # and the names and use separator comparators - - set guids {} - set names {} - - foreach arg $args { - if {[Twapi_IsValidGUID $arg]} { - # GUID's can be multiple format, canonicalize for lsearch - lappend guids [canonicalize_guid $arg] - } else { - lappend names $arg - } - } - - # Note there can be multiple versions sharing a single guid so - # we cannot use the wmi_collect_classes "-first" option to stop the - # search when one is found. - - set name_matcher [lambda* {names val} { - ::tcl::mathop::>= [lsearch -exact -nocase $names $val] 0 - } :: $names] - set guid_matcher [lambda* {guids val} { - ::tcl::mathop::>= [lsearch -exact -nocase $guids $val] 0 - } :: $guids] - - set named_classes {} - if {[llength $names]} { - foreach name $names { - catch {lappend named_classes [$oswbemservices Get $name]} - } - } - - if {[llength $guids]} { - set guid_classes [wmi_collect_classes $oswbemservices -ancestor EventTrace -matchqualifiers [list Guid $guid_matcher]] - } else { - set guid_classes {} - } - - return [concat $guid_classes $named_classes] -} - -proc twapi::etw_get_all_mof_event_classes {oswbemservices} { - return [twapi::wmi_collect_classes $oswbemservices -ancestor EventTrace -matchqualifiers [list Guid ::twapi::true]] -} - -proc twapi::etw_load_mof_event_class_obj {oswbemservices ocls} { - variable _etw_event_defs - set quals [$ocls Qualifiers_] - trap { - set guid [$quals -with {{Item Guid}} Value] - set vers "" - catch {set vers [$quals -with {{Item EventVersion}} Value]} - set def [etw_parse_mof_event_class $ocls] - # Class may be a provider, not a event class in which case - # def will be empty - if {[dict size $def]} { - dict set _etw_event_defs [canonicalize_guid $guid] $vers $def - } - } finally { - $quals destroy - } -} - -proc twapi::etw_load_mof_event_classes {oswbemservices args} { - if {[llength $args] == 0} { - set oclasses [etw_get_all_mof_event_classes $oswbemservices] - } else { - set oclasses [etw_find_mof_event_classes $oswbemservices {*}$args] - } - - foreach ocls $oclasses { - trap { - etw_load_mof_event_class_obj $oswbemservices $ocls - } finally { - $ocls destroy - } - } -} - -proc twapi::etw_open_file {path} { -# TBD - PROCESS_TRACE_MODE_RAW_TIMESTAMP - variable _etw_trace_consumers - - set path [file normalize $path] - - set htrace [OpenTrace $path 0] - set _etw_trace_consumers($htrace) $path - return $htrace -} - -proc twapi::etw_open_session {sessionname} { -# TBD - PROCESS_TRACE_MODE_RAW_TIMESTAMP - variable _etw_trace_consumers - - set htrace [OpenTrace $sessionname 1] - set _etw_trace_consumers($htrace) $sessionname - return $htrace -} - -proc twapi::etw_close_session {htrace} { - variable _etw_trace_consumers - - if {! [info exists _etw_trace_consumers($htrace)]} { - badargs! "Cannot find trace session with handle $htrace" - } - - CloseTrace $htrace - unset _etw_trace_consumers($htrace) - return -} - - -proc twapi::etw_process_events {args} { - array set opts [parseargs args { - callback.arg - start.arg - end.arg - } -nulldefault] - - if {[llength $args] == 0} { - error "At least one trace handle must be specified." - } - - return [ProcessTrace $args $opts(callback) $opts(start) $opts(end)] -} - -proc twapi::etw_open_formatter {} { - variable _etw_formatters - - if {[etw_force_mof] || ![twapi::min_os_version 6 0]} { - uplevel #0 package require twapi_wmi - # Need WMI MOF definitions - set id mof[TwapiId] - dict set _etw_formatters $id OSWBemServices [wmi_root -root wmi] - } else { - # Just a dummy if using a TDH based api - set id tdh[TwapiId] - # Nothing to set as yet but for consistency with MOF implementation - dict set _etw_formatters $id {} - } - return $id -} - -proc twapi::etw_close_formatter {formatter} { - variable _etw_formatters - if {[dict exists $_etw_formatters $formatter OSWBemServices]} { - [dict get $_etw_formatters $formatter OSWBemServices] -destroy - } - - dict unset _etw_formatters $formatter - if {[dict size $_etw_formatters] == 0} { - variable _etw_event_defs - # No more formatters - # Clear out event defs cache which can be quite large - # Really only needed for mof but doesn't matter - set _etw_event_defs {} - } - - return -} - -proc twapi::etw_format_events {formatter args} { - variable _etw_formatters - - if {![dict exists $_etw_formatters $formatter]} { - # We could actually just init ourselves but we want to force - # consistency and caller to release wmi COM object - badargs! "Invalid ETW formatter id \"$formatter\"" - } - - set events {} - if {[dict exists $_etw_formatters $formatter OSWBemServices]} { - set oswbemservices [dict get $_etw_formatters $formatter OSWBemServices] - foreach {bufd rawevents} $args { - lappend events [_etw_format_mof_events $oswbemservices $bufd $rawevents] - } - } else { - foreach {bufd rawevents} $args { - lappend events [_etw_format_tdh_events $bufd $rawevents] - } - } - - # Return as a recordarray - return [list [etw_event] [lconcat {*}$events]] -} - -proc twapi::_etw_format_tdh_events {bufdesc events} { - - set bufhdr [etw_event_trace_logfile trace_logfile_header $bufdesc] - set timer_resolution [etw_trace_logfile_header timer_resolution $bufhdr] - set private_session [expr {0x800 & [etw_trace_logfile_header logfile_mode $bufhdr]}] - set pointer_size [etw_trace_logfile_header pointer_size $bufhdr] - - set formatted_events {} - foreach event $events { - array set fields [tdh_event $event] - set formatted_event [tdh_event_header descriptor $fields(header)] - # Do not select provider_guid from header as for TDH it needs to come - # from the provider_guid in the data portion. - lappend formatted_event {*}[tdh_event_header select $fields(header) {timestamp tid pid}] - lappend formatted_event {*}[tdh_event_data select $fields(data) provider_guid] - if {$private_session} { - lappend formatted_event [expr {[tdh_event_header processor_time $fields(header)] * $timer_resolution}] 0 - } else { - lappend formatted_event [expr {[tdh_event_header user_time $fields(header)] * $timer_resolution}] [expr {[tdh_event_header kernel_time $fields(header)] * $timer_resolution}] - } - lappend formatted_event {*}[tdh_event_data select $fields(data) {provider_name event_guid channel_name level_name opcode_name task_name keyword_names properties message}] [dict* $fields(extended_data) sid ""] - - lappend formatted_events $formatted_event - } - return $formatted_events -} - -proc twapi::_etw_format_mof_events {oswbemservices bufdesc events} { - variable _etw_event_defs - - # TBD - it may be faster to special case NT kernel events as per - # the structures defined in http://msdn.microsoft.com/en-us/library/windows/desktop/aa364083(v=vs.85).aspx - # However, the MSDN warns that structures should not be created from - # MOF classes as alignment restrictions might be different - array set missing {} - foreach event $events { - set guid [mof_event_header guid [mof_event header $event]] - if {! [dict exists $_etw_event_defs $guid]} { - set missing($guid) "" - } - } - - if {[array size missing]} { - etw_load_mof_event_classes $oswbemservices {*}[array names missing] - } - - set bufhdr [etw_event_trace_logfile trace_logfile_header $bufdesc] - set timer_resolution [etw_trace_logfile_header timer_resolution $bufhdr] - set private_session [expr {0x800 & [etw_trace_logfile_header logfile_mode $bufhdr]}] - set pointer_size [etw_trace_logfile_header pointer_size $bufhdr] - - # TBD - what should provider_guid be for each event? - set provider_guid "" - - set formatted_events {} - foreach event $events { - array set hdr [mof_event_header [mof_event header $event]] - - # Formatted event must match field sequence in etw_event record - set formatted_event [list 0 $hdr(version) 0 $hdr(level) $hdr(type) 0 0 \ - $hdr(timestamp) $hdr(tid) $hdr(pid) $provider_guid] - - if {$private_session} { - lappend formatted_event [expr {$hdr(processor_time) * $timer_resolution}] 0 - } else { - lappend formatted_event [expr {$hdr(user_time) * $timer_resolution}] [expr {$hdr(kernel_time) * $timer_resolution}] - } - - if {[dict exists $_etw_event_defs $hdr(guid) $hdr(version) -definitions $hdr(type)]} { - set eventclass [dict get $_etw_event_defs $hdr(guid) $hdr(version) -classname] - set mof [dict get $_etw_event_defs $hdr(guid) $hdr(version) -definitions $hdr(type)] - set eventtypename [dict get $mof -eventtypename] - set properties [Twapi_ParseEventMofData \ - [mof_event data $event] \ - [dict get $mof -fieldtypes] \ - $pointer_size] - } elseif {[dict exists $_etw_event_defs $hdr(guid) "" -definitions $hdr(type)]} { - # If exact version not present, use one without - # a version - set eventclass [dict get $_etw_event_defs $hdr(guid) "" -classname] - set mof [dict get $_etw_event_defs $hdr(guid) "" -definitions $hdr(type)] - set eventtypename [dict get $mof -eventtypename] - set properties [Twapi_ParseEventMofData \ - [mof_event data $event] \ - [dict get $mof -fieldtypes] \ - $pointer_size] - } else { - # No definition. Create an entry so we know we already tried - # looking this up and don't keep retrying later - dict set _etw_event_defs $hdr(guid) {} - - # Nothing we can add to the event. Pass on with defaults - set eventtypename $hdr(type) - # Try to get at least the class name - if {[dict exists $_etw_event_defs $hdr(guid) $hdr(version) -classname]} { - set eventclass [dict get $_etw_event_defs $hdr(guid) $hdr(version) -classname] - } elseif {[dict exists $_etw_event_defs $hdr(guid) "" -classname]} { - set eventclass [dict get $_etw_event_defs $hdr(guid) "" -classname] - } else { - set eventclass "" - } - set properties [list _mofdata [mof_event data $event]] - } - - # eventclass -> provider_name - # TBD - should we get the Provider qualifier from Mof as provider_name? (Does it even exist?) - # mofformatteddata -> properties - # level name is not localized. Oh well, too bad - set level_name [dict* {0 {Log Always} 1 Critical 2 Error 3 Warning 4 Informational 5 Debug} $hdr(level)] - lappend formatted_event $eventclass $hdr(guid) "" $level_name $eventtypename "" "" $properties "" "" - - lappend formatted_events $formatted_event - } - - return $formatted_events -} - -proc twapi::etw_format_event_message {message properties} { - if {$message ne ""} { - set params {} - foreach {propname propval} $properties { - # Properties are always a list, even when scalars because - # there is no way of distinguishing between a scalar and - # an array of size 1 in the return values from TDH - lappend params [join $propval {, }] - } - catch {set message [format_message -fmtstring $message -params $params]} - } - return $message -} - - -proc twapi::etw_dump_to_file {args} { - array set opts [parseargs args { - {output.arg stdout} - {limit.int -1} - {format.arg csv {csv list}} - {separator.arg ,} - {fields.arg {-timecreated -levelname -providername -pid -taskname -opcodename -message}} - {filter.arg {}} - }] - - if {$opts(format) eq "csv"} { - package require csv - } - if {$opts(output) in [chan names]} { - # Writing to a channel - set outfd $opts(output) - set do_close 0 - } else { - if {[file exists $opts(output)]} { - error "File $opts(output) already exists." - } - set outfd [open $opts(output) a] - set do_close 1 - } - - set formatter [etw_open_formatter] - trap { - set varname ::twapi::_etw_dump_ctr[TwapiId] - set $varname 0; # Yes, set $varname, not set varname - set htraces {} - foreach arg $args { - if {[file exists $arg]} { - lappend htraces [etw_open_file $arg] - } else { - lappend htraces [etw_open_session $arg] - } - } - - if {$opts(format) eq "csv"} { - puts $outfd [csv::join $opts(fields) $opts(separator)] - } - if {[llength $htraces] == 0} { - return - } - # This is written using a callback to basically test the callback path - set callback [list apply { - {options outfd counter_varname max formatter bufd events} - { - array set opts $options - set events [etw_format_events $formatter $bufd $events] - foreach event [recordarray getlist $events -format dict -filter $opts(filter)] { - if {$max >= 0 && [set $counter_varname] >= $max} { - return -code break - } - array set fields $event - if {"-message" in $opts(fields)} { - if {$fields(-message) ne ""} { - set fields(-message) [etw_format_event_message $fields(-message) $fields(-properties)] - } else { - set fields(-message) "Properties: $fields(-properties)" - } - } - if {"-properties" in $opts(fields)} { - set fmtdata $fields(-properties) - if {[dict exists $fmtdata mofdata]} { - # Only show 32 bytes - binary scan [string range [dict get $fmtdata mofdata] 0 31] H* hex - dict set fmtdata mofdata [regsub -all (..) $hex {\1 }] - } - set fields(-properties) $fmtdata - } - set fmtlist {} - foreach field $opts(fields) { - lappend fmtlist $fields($field) - } - if {$opts(format) eq "csv"} { - puts $outfd [csv::join $fmtlist $opts(separator)] - } else { - puts $outfd $fmtlist - } - incr $counter_varname - } - } - } [array get opts] $outfd $varname $opts(limit) $formatter] - - # Process the events using the callback - etw_process_events -callback $callback {*}$htraces - - } finally { - unset -nocomplain $varname - foreach htrace $htraces { - etw_close_session $htrace - } - if {$do_close} { - close $outfd - } else { - flush $outfd - } - etw_close_formatter $formatter - } -} - -proc twapi::etw_dump_to_list {args} { - set htraces {} - set formatter [etw_open_formatter] - trap { - foreach arg $args { - if {[file exists $arg]} { - lappend htraces [etw_open_file $arg] - } else { - lappend htraces [etw_open_session $arg] - } - } - return [recordarray getlist [etw_format_events $formatter {*}[etw_process_events {*}$htraces]]] - } finally { - foreach htrace $htraces { - etw_close_session $htrace - } - etw_close_formatter $formatter - } -} - -proc twapi::etw_dump {args} { - set htraces {} - set formatter [etw_open_formatter] - trap { - foreach arg $args { - if {[file exists $arg]} { - lappend htraces [etw_open_file $arg] - } else { - lappend htraces [etw_open_session $arg] - } - } - return [recordarray get [etw_format_events $formatter {*}[etw_process_events {*}$htraces]]] - } finally { - foreach htrace $htraces { - etw_close_session $htrace - } - etw_close_formatter $formatter - } -} - - -proc twapi::etw_start_trace {session_name args} { - variable _etw_trace_controllers - - # Specialized for kernel debugging - {bufferingmode {} 0x400} - # Not supported until Win7 {noperprocessorbuffering {} 0x10000000} - # Not clear what conditions it can be used {usekbytesforsize {} 0x2000} - array set opts [parseargs args { - traceguid.arg - logfile.arg - buffersize.int - minbuffers.int - maxbuffers.int - maxfilesize.int - flushtimer.int - enableflags.int - {filemode.arg circular {sequential append rotate circular}} - {clockresolution.sym system {qpc 1 system 2 cpucycle 3}} - {private.bool 0 0x800} - {realtime.bool 0 0x100} - {secure.bool 0 0x80} - {privateinproc.bool 0 0x20800} - {sequence.sym none {none 0 local 0x8000 global 0x4000}} - {paged.bool 0 0x01000000} - {preallocate.bool 0 0x20} - } -maxleftover 0] - - if {!$opts(realtime) && (![info exists opts(logfile)] || $opts(logfile) eq "")} { - badargs! "Log file name must be specified if real time mode is not in effect" - } - - if {[string equal -nocase $session_name "NT Kernel Logger"] && - $opts(filemode) eq "rotate"} { - error "Option -filemode cannot have value \"rotate\" for NT Kernel Logger" - } - - set logfilemode 0 - switch -exact $opts(filemode) { - sequential { - if {[info exists opts(maxfilesize)]} { - # 1 -> EVENT_TRACE_FILE_MODE_SEQUENTIAL - set logfilemode [expr {$logfilemode | 1}] - } else { - # 0 -> EVENT_TRACE_FILE_MODE_NONE - # set logfilemode [expr {$logfilemode | 0}] - } - } - circular { - # 2 -> EVENT_TRACE_FILE_MODE_CIRCULAR - set logfilemode [expr {$logfilemode | 2}] - if {![info exists opts(maxfilesize)]} { - set opts(maxfilesize) 1; # 1MB default - } - } - rotate { - if {$opts(private) || $opts(privateinproc)} { - if {![min_os_version 6 2]} { - badargs! "Option -filemode must not be \"rotate\" for private traces" - } - } - - # 8 -> EVENT_TRACE_FILE_MODE_NEWFILE - set logfilemode [expr {$logfilemode | 8}] - if {![info exists opts(maxfilesize)]} { - set opts(maxfilesize) 1; # 1MB default - } - } - append { - if {$opts(private) || $opts(privateinproc) || $opts(realtime)} { - badargs! "Option -filemode must not be \"append\" for private or realtime traces" - } - # 4 -> EVENT_TRACE_FILE_MODE_APPEND - # Not clear what to do about maxfilesize. Keep as is for now - set logfilemode [expr {$logfilemode | 4}] - } - } - - if {![info exists opts(maxfilesize)]} { - set opts(maxfilesize) 0 - } - - if {$opts(realtime) && ($opts(private) || $opts(privateinproc))} { - badargs! "Option -realtime is incompatible with options -private and -privateinproc" - } - - foreach opt {traceguid logfile buffersize minbuffers maxbuffers flushtimer enableflags maxfilesize} { - if {[info exists opts($opt)]} { - lappend params -$opt $opts($opt) - } - } - - set logfilemode [expr {$logfilemode | $opts(sequence)}] - - set logfilemode [tcl::mathop::| $logfilemode $opts(realtime) $opts(private) $opts(privateinproc) $opts(secure) $opts(paged) $opts(preallocate)] - - lappend params -logfilemode $logfilemode - - if {$opts(filemode) eq "append" && $opts(clockresolution) != 2} { - error "Option -clockresolution must be set to 'system' if -filemode is append" - } - - if {($opts(filemode) eq "rotate" || $opts(preallocate)) && - $opts(maxfilesize) == 0} { - error "Option -maxfilesize must also be specified with -preallocate or -filemodenewfile." - } - - lappend params -clockresolution $opts(clockresolution) - - trap { - set h [StartTrace $session_name $params] - set _etw_trace_controllers($h) $session_name - return $h - } onerror {TWAPI_WIN32 5} { - return -options [trapoptions] "Access denied. This may be because the process does not have permission to create the specified logfile or because it is not running under an account permitted to control ETW traces." - } -} - -proc twapi::etw_start_kernel_trace {events args} { - - set enableflags 0 - - # Note sysconfig is a dummy event. It is always logged. - set eventmap { - process 0x00000001 - thread 0x00000002 - imageload 0x00000004 - diskio 0x00000100 - diskfileio 0x00000200 - pagefault 0x00001000 - hardfault 0x00002000 - tcpip 0x00010000 - registry 0x00020000 - dbgprint 0x00040000 - sysconfig 0x00000000 - } - - if {"diskfileio" in $events} { - lappend events diskio; # Required by diskfileio - } - - if {[min_os_version 6]} { - lappend eventmap {*}{ - processcounter 0x00000008 - contextswitch 0x00000010 - dpc 0x00000020 - interrupt 0x00000040 - systemcall 0x00000080 - diskioinit 0x00000400 - alpc 0x00100000 - splitio 0x00200000 - driver 0x00800000 - profile 0x01000000 - fileio 0x02000000 - fileioinit 0x04000000 - } - - if {"diskio" in $events} { - lappend events diskioinit - } - } - - if {[min_os_version 6 1]} { - lappend eventmap {*}{ - dispatcher 0x00000800 - virtualalloc 0x00004000 - } - } - - if {[min_os_version 6 2]} { - lappend eventmap {*}{ - vamap 0x00008000 - } - if {"sysconfig" ni $events} { - # EVENT_TRACE_FLAG_NO_SYSCONFIG - set enableflags [expr {$enableflags | 0x10000000}] - } - } - - foreach event $events { - set enableflags [expr {$enableflags | [dict! $eventmap $event]}] - } - - # Name "NT Kernel Logger" is hardcoded in Windows - # GUID is 9e814aad-3204-11d2-9a82-006008a86939 but does not need to be - # specified. Note kernel logger cannot use paged memory so - # -paged 0 is required - return [etw_start_trace "NT Kernel Logger" -enableflags $enableflags {*}$args -paged 0] -} - -proc twapi::etw_enable_provider {htrace guid enableflags level} { - set guid [_etw_provider_guid $guid] - return [EnableTrace 1 $enableflags [_etw_level_to_int $level] $guid $htrace] -} - -proc twapi::etw_disable_provider {htrace guid} { - set guid [_etw_provider_guid $guid] - return [EnableTrace 0 -1 5 $guid $htrace] -} - -proc twapi::etw_control_trace {action session args} { - variable _etw_trace_controllers - - if {[info exists _etw_trace_controllers($session)]} { - set sessionhandle $session - } else { - set sessionhandle 0 - set sessionname $session - } - - set action [dict get { - query 0 - stop 1 - update 2 - flush 3 - } $action] - - array set opts [parseargs args { - traceguid.arg - logfile.arg - maxbuffers.int - flushtimer.int - enableflags.int - realtime.bool - } -maxleftover 0] - - set params {} - - if {[info exists opts(realtime)]} { - if {$opts(realtime)} { - lappend params -logfilemode 0x100; # EVENT_TRACE_REAL_TIME_MODE - } else { - lappend params -logfilemode 0 - } - } - - if {[info exists opts(traceguid)]} { - append params -traceguid $opts(traceguid) - } - - if {[info exists sessionname]} { - lappend params -sessionname $sessionname - } - - if {$action == 2} { - # update - foreach opt {logfile flushtimer enableflags maxbuffers} { - if {[info exists opts($opt)]} { - lappend params -$opt $opts($opt) - } - } - } - - return [etw_trace_properties [ControlTrace $action $sessionhandle $params]] -} - -interp alias {} twapi::etw_update_trace {} twapi::etw_control_trace update - -proc twapi::etw_stop_trace {trace} { - variable _etw_trace_controllers - set stats [etw_control_trace stop $trace] - unset -nocomplain _etw_trace_controllers($trace) - return $stats -} - -proc twapi::etw_flush_trace {trace} { - return [etw_control_trace flush $trace] -} - -proc twapi::etw_query_trace {trace} { - set d [etw_control_trace query $trace] - set cres [lindex {{} qpc system cpucycle} [dict get $d clock_resolution]] - if {$cres ne ""} { - dict set d clock_resolution $cres - } - - #TBD - check whether -maxfilesize needs to be massaged - - return $d -} - - - -# -# Helper functions -# - - -# Return binary unicode with truncation if necessary -proc twapi::_etw_encode_limited_unicode {s {max 80}} { - if {[string length $s] > $max} { - set s "[string range $s 0 $max-3]..." - } - return [encoding convertto unicode "$s\0"] -} - -# Used for development/debug to see what all types are in use -proc twapi::_etw_get_types {} { - dict for {g gval} $::twapi::_etw_event_defs { - dict for {ver verval} $gval { - dict for {eventtype eval} [dict get $verval -definitions] { - dict for {id idval} [dict get $eval -fields] { - dict set types [dict get $idval -type] [dict get $verval -classname] $eventtype $id - } - } - } - } - return $types -} - -proc twapi::_etw_level_to_int {level} { - return [dict* {verbose 5 information 4 info 4 informational 4 warning 3 error 2 fatal 1 critical 1} [string tolower $level]] -} - -# Map provider guid/name to guid -proc twapi::_etw_provider_guid {lookup} { - if {[Twapi_IsValidGUID $lookup]} { - return $lookup - } - set guid [etw_get_provider_guid $lookup] - if {$guid eq ""} { - badargs! "Provider \"$lookup\" not found." - } - return $guid -} diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/eventlog.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/eventlog.tcl deleted file mode 100644 index 205784fd..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/eventlog.tcl +++ /dev/null @@ -1,391 +0,0 @@ -# -# 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] -} diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/evt.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/evt.tcl deleted file mode 100644 index 61d19bc1..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/evt.tcl +++ /dev/null @@ -1,718 +0,0 @@ -# -# 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 - } -} diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/handle.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/handle.tcl deleted file mode 100644 index 223608ac..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/handle.tcl +++ /dev/null @@ -1,236 +0,0 @@ -# -# 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}] -} diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/input.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/input.tcl deleted file mode 100644 index cdae8cea..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/input.tcl +++ /dev/null @@ -1,623 +0,0 @@ -# -# 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] -} diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/metoo.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/metoo.tcl deleted file mode 100644 index 91a32e5a..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/metoo.tcl +++ /dev/null @@ -1,605 +0,0 @@ -# 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] -} diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/msi.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/msi.tcl deleted file mode 100644 index f50cea2e..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/msi.tcl +++ /dev/null @@ -1,403 +0,0 @@ -# -# 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} - diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/mstask.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/mstask.tcl deleted file mode 100644 index d1e37686..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/mstask.tcl +++ /dev/null @@ -1,745 +0,0 @@ -# -# 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 -} diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/multimedia.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/multimedia.tcl deleted file mode 100644 index 57665197..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/multimedia.tcl +++ /dev/null @@ -1,75 +0,0 @@ -# -# 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 -} diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/namedpipe.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/namedpipe.tcl deleted file mode 100644 index 7e222f13..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/namedpipe.tcl +++ /dev/null @@ -1,103 +0,0 @@ -# -# 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 -} - diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/network.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/network.tcl deleted file mode 100644 index 4cdbba87..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/network.tcl +++ /dev/null @@ -1,1124 +0,0 @@ -# -# Copyright (c) 2004-2014, Ashok P. Nadkarni -# All rights reserved. -# -# See the file LICENSE for license - -namespace eval twapi { - record IP_ADAPTER_ADDRESSES_XP { - -ipv4ifindex -adaptername -unicastaddresses -anycastaddresses - -multicastaddresses -dnsservers -dnssuffix -description - -friendlyname -physicaladdress -flags -mtu -type -operstatus - -ipv6ifindex -zoneindices -prefixes - } - - if {[min_os_version 6]} { - record IP_ADAPTER_ADDRESSES [list {*}[IP_ADAPTER_ADDRESSES_XP] -transmitspeed -receivespeed -winsaddresses -gatewayaddresses -ipv4metric -ipv6metric -luid -dhcpv4server -compartmentid -networkguid -connectiontype -tunneltype -dhcpv6server -dhcpv6clientduid -dhcpv6iaid -dnssuffixes] - } else { - record IP_ADAPTER_ADDRESSES [IP_ADAPTER_ADDRESSES_XP] - } - - record IP_ADAPTER_UNICAST_ADDRESS { - -flags -address -prefixorigin -suffixorigin -dadstate -validlifetime -preferredlifetime -leaselifetime - } - - record IP_ADAPTER_ANYCAST_ADDRESS {-flags -address} - record IP_ADAPTER_MULTICAST_ADDRESS [IP_ADAPTER_ANYCAST_ADDRESS] - record IP_ADAPTER_DNS_SERVER_ADDRESS [IP_ADAPTER_ANYCAST_ADDRESS] -} - -proc twapi::get_network_adapters {} { - # 0x20 -> SKIP_FRIENDLYNAME - # 0x0f -> SKIP_DNS_SERVER, SKIP_UNICAST/MULTICAST/ANYCAST - return [lpick [GetAdaptersAddresses 0 0x2f] [enum [IP_ADAPTER_ADDRESSES] -adaptername]] -} - -proc twapi::get_network_adapters_detail {} { - set recs {} - # We only return fields common to all platforms - set fields [IP_ADAPTER_ADDRESSES_XP] - foreach rec [GetAdaptersAddresses 0 0] { - set rec [IP_ADAPTER_ADDRESSES set $rec \ - -physicaladdress [_hwaddr_binary_to_string [IP_ADAPTER_ADDRESSES -physicaladdress $rec]] \ - -unicastaddresses [ntwine [IP_ADAPTER_UNICAST_ADDRESS] [IP_ADAPTER_ADDRESSES -unicastaddresses $rec]] \ - -multicastaddresses [ntwine [IP_ADAPTER_MULTICAST_ADDRESS] [IP_ADAPTER_ADDRESSES -multicastaddresses $rec]] \ - -anycastaddresses [ntwine [IP_ADAPTER_ANYCAST_ADDRESS] [IP_ADAPTER_ADDRESSES -anycastaddresses $rec]] \ - -dnsservers [ntwine [IP_ADAPTER_DNS_SERVER_ADDRESS] [IP_ADAPTER_ADDRESSES -dnsservers $rec]]] - - lappend recs [IP_ADAPTER_ADDRESSES select $rec $fields] - } - return [list $fields $recs] -} - -# Get the list of local IP addresses -proc twapi::get_system_ipaddrs {args} { - array set opts [parseargs args { - {ipversion.arg 0} - {types.arg unicast} - adaptername.arg - } -maxleftover 0] - - # 0x20 -> SKIP_FRIENDLYNAME - # 0x08 -> SKIP_DNS_SERVER - set flags 0x2f - if {"all" in $opts(types)} { - set flags 0x20 - } else { - if {"unicast" in $opts(types)} {incr flags -1} - if {"anycast" in $opts(types)} {incr flags -2} - if {"multicast" in $opts(types)} {incr flags -4} - } - - set addrs {} - trap { - set entries [GetAdaptersAddresses [_ipversion_to_af $opts(ipversion)] $flags] - } onerror {TWAPI_WIN32 232} { - # Not installed, so no addresses - return {} - } - - foreach entry $entries { - if {[info exists opts(adaptername)] && - [string compare -nocase [IP_ADAPTER_ADDRESSES -adaptername $entry] $opts(adaptername)]} { - continue - } - - foreach rec [IP_ADAPTER_ADDRESSES -unicastaddresses $entry] { - lappend addrs [IP_ADAPTER_UNICAST_ADDRESS -address $rec] - } - foreach rec [IP_ADAPTER_ADDRESSES -anycastaddresses $entry] { - lappend addrs [IP_ADAPTER_ANYCAST_ADDRESS -address $rec] - } - foreach rec [IP_ADAPTER_ADDRESSES -multicastaddresses $entry] { - lappend addrs [IP_ADAPTER_MULTICAST_ADDRESS -address $rec] - } - } - - return [lsort -unique $addrs] -} - -# Get network related information -proc twapi::get_network_info {args} { - # Map options into the positions in result of GetNetworkParams - array set getnetworkparams_opts { - hostname 0 - domain 1 - dnsservers 2 - dhcpscopeid 4 - routingenabled 5 - arpproxyenabled 6 - dnsenabled 7 - } - - array set opts [parseargs args \ - [concat [list all] \ - [array names getnetworkparams_opts]]] - set result [list ] - foreach opt [array names getnetworkparams_opts] { - if {!$opts(all) && !$opts($opt)} continue - if {![info exists netparams]} { - set netparams [GetNetworkParams] - } - lappend result -$opt [lindex $netparams $getnetworkparams_opts($opt)] - } - - return $result -} - - -proc twapi::get_network_adapter_info {interface args} { - array set opts [parseargs args { - all - adaptername - anycastaddresses - description - dhcpenabled - dnsservers - dnssuffix - friendlyname - ipv4ifindex - ipv6ifindex - multicastaddresses - mtu - operstatus - physicaladdress - prefixes - type - unicastaddresses - zoneindices - - {ipversion.arg 0} - } -maxleftover 0 -hyphenated] - - set ipversion [_ipversion_to_af $opts(-ipversion)] - - set flags 0 - if {! $opts(-all)} { - # If not asked for some fields, don't bother getting them - if {! $opts(-unicastaddresses)} { incr flags 0x1 } - if {! $opts(-anycastaddresses)} { incr flags 0x2 } - if {! $opts(-multicastaddresses)} { incr flags 0x4 } - if {! $opts(-dnsservers)} { incr flags 0x8 } - if {! $opts(-friendlyname)} { incr flags 0x20 } - - if {$opts(-prefixes)} { incr flags 0x10 } - } else { - incr flags 0x10; # Want prefixes also - } - - set entries [GetAdaptersAddresses $ipversion $flags] - set nameindex [enum [IP_ADAPTER_ADDRESSES] -adaptername] - set entry [lsearch -nocase -exact -inline -index $nameindex $entries $interface] - if {[llength $entry] == 0} { - error "No interface matching '$interface'." - } - - array set result [IP_ADAPTER_ADDRESSES $entry] - if {$opts(-all) || $opts(-dhcpenabled)} { - set result(-dhcpenabled) [expr {($result(-flags) & 0x4) != 0}] - } - # Note even if -all is specified, we still loop through because - # the fields of IP_ADAPTER_ADDRESSES are a superset of options - foreach opt [IP_ADAPTER_ADDRESSES] { - # Select only those fields that have an option defined - # and that option is selected - if {!([info exists opts($opt)] && ($opts(-all) || $opts($opt)))} { - unset result($opt) - } - } - if {[info exists result(-physicaladdress)]} { - set result(-physicaladdress) [_hwaddr_binary_to_string $result(-physicaladdress)] - } - if {[info exists result(-unicastaddresses)]} { - set result(-unicastaddresses) [ntwine [IP_ADAPTER_UNICAST_ADDRESS] $result(-unicastaddresses)] - } - if {[info exists result(-multicastaddresses)]} { - set result(-multicastaddresses) [ntwine [IP_ADAPTER_MULTICAST_ADDRESS] $result(-multicastaddresses)] - } - if {[info exists result(-anycastaddresses)]} { - set result(-anycastaddresses) [ntwine [IP_ADAPTER_ANYCAST_ADDRESS] $result(-anycastaddresses)] - } - if {[info exists result(-dnsservers)]} { - set result(-dnsservers) [ntwine [IP_ADAPTER_DNS_SERVER_ADDRESS] $result(-dnsservers)] - } - - return [array get result] -} - -# Get the address->h/w address table -proc twapi::get_arp_table {args} { - array set opts [parseargs args { - sort - }] - - set arps [list ] - - foreach arp [GetIpNetTable $opts(sort)] { - lassign $arp ifindex hwaddr ipaddr type - # Token for enry 0 1 2 3 4 - set type [lindex {other other invalid dynamic static} $type] - if {$type == ""} { - set type other - } - lappend arps [list $ifindex [_hwaddr_binary_to_string $hwaddr] $ipaddr $type] - } - return [list [list ifindex hwaddr ipaddr type] $arps] -} - -# Return IP address for a hw address -proc twapi::ipaddr_to_hwaddr {ipaddr {varname ""}} { - if {![Twapi_IPAddressFamily $ipaddr]} { - error "$ipaddr is not a valid IP V4 address" - } - - foreach arp [GetIpNetTable 0] { - if {[lindex $arp 3] == 2} continue; # Invalid entry type - if {[string equal $ipaddr [lindex $arp 2]]} { - set result [_hwaddr_binary_to_string [lindex $arp 1]] - break - } - } - - # If could not get from ARP table, see if it is one of our own - # Ignore errors - if {![info exists result]} { - foreach ifc [get_network_adapters] { - catch { - array set netifinfo [get_network_adapter_info $ifc -unicastaddresses -physicaladdress] - if {$netifinfo(-physicaladdress) eq ""} continue - foreach elem $netifinfo(-unicastaddresses) { - if {[dict get $elem -address] eq $ipaddr} { - set result $netifinfo(-physicaladdress) - break - } - } - } - if {[info exists result]} { - break - } - } - } - - if {[info exists result]} { - if {$varname == ""} { - return $result - } - upvar $varname var - set var $result - return 1 - } else { - if {$varname == ""} { - error "Could not map IP address $ipaddr to a hardware address" - } - return 0 - } -} - -# Return hw address for a IP address -proc twapi::hwaddr_to_ipaddr {hwaddr {varname ""}} { - set hwaddr [string map {- "" : ""} $hwaddr] - foreach arp [GetIpNetTable 0] { - if {[lindex $arp 3] == 2} continue; # Invalid entry type - if {[string equal $hwaddr [_hwaddr_binary_to_string [lindex $arp 1] ""]]} { - set result [lindex $arp 2] - break - } - } - - # If could not get from ARP table, see if it is one of our own - # Ignore errors - if {![info exists result]} { - foreach ifc [get_network_adapters] { - catch { - array set netifinfo [get_network_adapter_info $ifc -unicastaddresses -physicaladdress] - if {$netifinfo(-physicaladdress) eq ""} continue - set ifhwaddr [string map {- ""} $netifinfo(-physicaladdress)] - if {[string equal -nocase $hwaddr $ifhwaddr]} { - foreach elem $netifinfo(-unicastaddresses) { - if {[dict get $elem -address] ne ""} { - set result [dict get $elem -address] - break - } - } - } - } - if {[info exists result]} { - break - } - } - } - - if {[info exists result]} { - if {$varname == ""} { - return $result - } - upvar $varname var - set var $result - return 1 - } else { - if {$varname == ""} { - error "Could not map hardware address $hwaddr to an IP address" - } - return 0 - } -} - -# Flush the arp table for a given interface -proc twapi::flush_arp_tables {args} { - if {[llength $args] == 0} { - set args [get_network_adapters] - } - foreach arg $args { - array set ifc [get_network_adapter_info $arg -type -ipv4ifindex] - if {$ifc(-type) != 24} { - trap { - FlushIpNetTable $ifc(-ipv4ifindex) - } onerror {} { - # Ignore - flush not supported for that interface type - } - } - } -} - -# Return the list of TCP connections -twapi::proc* twapi::get_tcp_connections {args} { - variable tcp_statenames - variable tcp_statevalues - - array set tcp_statevalues { - closed 1 - listen 2 - syn_sent 3 - syn_rcvd 4 - estab 5 - fin_wait1 6 - fin_wait2 7 - close_wait 8 - closing 9 - last_ack 10 - time_wait 11 - delete_tcb 12 - } - foreach {name val} [array get tcp_statevalues] { - set tcp_statenames($val) $name - } -} { - variable tcp_statenames - variable tcp_statevalues - - array set opts [parseargs args { - state - {ipversion.arg 0} - localaddr - remoteaddr - localport - remoteport - pid - modulename - modulepath - bindtime - all - matchstate.arg - matchlocaladdr.arg - matchremoteaddr.arg - matchlocalport.int - matchremoteport.int - matchpid.int - } -maxleftover 0] - - set opts(ipversion) [_ipversion_to_af $opts(ipversion)] - - if {! ($opts(state) || $opts(localaddr) || $opts(remoteaddr) || $opts(localport) || $opts(remoteport) || $opts(pid) || $opts(modulename) || $opts(modulepath) || $opts(bindtime))} { - set opts(all) 1 - } - - # Convert state to appropriate symbol if necessary - if {[info exists opts(matchstate)]} { - set matchstates [list ] - foreach stateval $opts(matchstate) { - if {[info exists tcp_statevalues($stateval)]} { - lappend matchstates $stateval - continue - } - if {[info exists tcp_statenames($stateval)]} { - lappend matchstates $tcp_statenames($stateval) - continue - } - error "Unrecognized connection state '$stateval' specified for option -matchstate" - } - } - - foreach opt {matchlocaladdr matchremoteaddr} { - if {[info exists opts($opt)]} { - # Note this also normalizes the address format - set $opt [_hosts_to_ip_addrs $opts($opt)] - if {[llength [set $opt]] == 0} { - return [list ]; # No addresses, so no connections will match - } - } - } - - # Get the complete list of connections - if {$opts(modulename) || $opts(modulepath) || $opts(bindtime) || $opts(all)} { - set level 8 - } else { - set level 5 - } - - # See if any matching needs to be done - if {[info exists opts(matchlocaladdr)] || [info exists opts(matchlocalport)] || - [info exist opts(matchremoteaddr)] || [info exists opts(matchremoteport)] || - [info exists opts(matchpid)] || [info exists opts(matchstate)]} { - set need_matching 1 - } else { - set need_matching 0 - } - - - set conns [list ] - foreach entry [_get_all_tcp 0 $level $opts(ipversion)] { - lassign $entry state localaddr localport remoteaddr remoteport pid bindtime modulename modulepath - - if {[string equal $remoteaddr 0.0.0.0]} { - # Socket not connected. WIndows passes some random value - # for remote port in this case. Set it to 0 - set remoteport 0 - } - - if {[info exists tcp_statenames($state)]} { - set state $tcp_statenames($state) - } - if {$need_matching} { - if {[info exists opts(matchpid)]} { - # See if this platform even returns the PID - if {$pid == ""} { - error "Connection process id not available on this system." - } - if {$pid != $opts(matchpid)} { - continue - } - } - if {[info exists matchlocaladdr] && - [lsearch -exact $matchlocaladdr $localaddr] < 0} { - # Not in match list - continue - } - if {[info exists matchremoteaddr] && - [lsearch -exact $matchremoteaddr $remoteaddr] < 0} { - # Not in match list - continue - } - if {[info exists opts(matchlocalport)] && - $opts(matchlocalport) != $localport} { - continue - } - if {[info exists opts(matchremoteport)] && - $opts(matchremoteport) != $remoteport} { - continue - } - if {[info exists matchstates] && [lsearch -exact $matchstates $state] < 0} { - continue - } - } - - # OK, now we have matched. Include specified fields in the result - set conn [list ] - foreach opt {localaddr localport remoteaddr remoteport state pid bindtime modulename modulepath} { - if {$opts(all) || $opts($opt)} { - lappend conn [set $opt] - } - } - lappend conns $conn - } - - # ORDER MUST MATCH ORDER ABOVE - set fields [list ] - foreach opt {localaddr localport remoteaddr remoteport state pid bindtime modulename modulepath} { - if {$opts(all) || $opts($opt)} { - lappend fields -$opt - } - } - - return [list $fields $conns] -} - - -# Return the list of UDP connections -proc twapi::get_udp_connections {args} { - array set opts [parseargs args { - {ipversion.arg 0} - localaddr - localport - pid - modulename - modulepath - bindtime - all - matchlocaladdr.arg - matchlocalport.int - matchpid.int - } -maxleftover 0] - - set opts(ipversion) [_ipversion_to_af $opts(ipversion)] - - if {! ($opts(localaddr) || $opts(localport) || $opts(pid) || $opts(modulename) || $opts(modulepath) || $opts(bindtime))} { - set opts(all) 1 - } - - if {[info exists opts(matchlocaladdr)]} { - # Note this also normalizes the address format - set matchlocaladdr [_hosts_to_ip_addrs $opts(matchlocaladdr)] - if {[llength $matchlocaladdr] == 0} { - return [list ]; # No addresses, so no connections will match - } - } - - # Get the complete list of connections - # Get the complete list of connections - if {$opts(modulename) || $opts(modulepath) || $opts(bindtime) || $opts(all)} { - set level 2 - } else { - set level 1 - } - set conns [list ] - foreach entry [_get_all_udp 0 $level $opts(ipversion)] { - foreach {localaddr localport pid bindtime modulename modulepath} $entry { - break - } - if {[info exists opts(matchpid)]} { - # See if this platform even returns the PID - if {$pid == ""} { - error "Connection process id not available on this system." - } - if {$pid != $opts(matchpid)} { - continue - } - } - if {[info exists matchlocaladdr] && - [lsearch -exact $matchlocaladdr $localaddr] < 0} { - continue - } - if {[info exists opts(matchlocalport)] && - $opts(matchlocalport) != $localport} { - continue - } - - # OK, now we have matched. Include specified fields in the result - set conn [list ] - foreach opt {localaddr localport pid bindtime modulename modulepath} { - if {$opts(all) || $opts($opt)} { - lappend conn [set $opt] - } - } - lappend conns $conn - } - - # ORDER MUST MATCH THAT ABOVE - set fields [list ] - foreach opt {localaddr localport pid bindtime modulename modulepath} { - if {$opts(all) || $opts($opt)} { - lappend fields -$opt - } - } - - return [list $fields $conns] -} - -# Terminates a TCP connection. Does not generate an error if connection -# does not exist -proc twapi::terminate_tcp_connections {args} { - array set opts [parseargs args { - matchstate.arg - matchlocaladdr.arg - matchremoteaddr.arg - matchlocalport.int - matchremoteport.int - matchpid.int - } -maxleftover 0] - - # TBD - ignore 'no such connection' errors - - # If local and remote endpoints fully specified, just directly call - # SetTcpEntry. Note pid must NOT be specified since we must then - # fall through and check for that pid - if {[info exists opts(matchlocaladdr)] && [info exists opts(matchlocalport)] && - [info exists opts(matchremoteaddr)] && [info exists opts(matchremoteport)] && - ! [info exists opts(matchpid)]} { - # 12 is "delete" code - catch { - SetTcpEntry [list 12 $opts(matchlocaladdr) $opts(matchlocalport) $opts(matchremoteaddr) $opts(matchremoteport)] - } - return - } - - # Get connection list and go through matching on each - # TBD - optimize by precalculating if *ANY* matching is to be done - # and if not, skip the whole matching sequence - foreach conn [twapi::recordarray getlist [get_tcp_connections {*}[_get_array_as_options opts]] -format dict] { - array set aconn $conn - # TBD - should we handle integer values of opts(state) ? - if {[info exists opts(matchstate)] && - $opts(matchstate) != $aconn(-state)} { - continue - } - if {[info exists opts(matchlocaladdr)] && - $opts(matchlocaladdr) != $aconn(-localaddr)} { - continue - } - if {[info exists opts(matchlocalport)] && - $opts(matchlocalport) != $aconn(-localport)} { - continue - } - if {[info exists opts(matchremoteaddr)] && - $opts(matchremoteaddr) != $aconn(-remoteaddr)} { - continue - } - if {[info exists opts(remoteport)] && - $opts(matchremoteport) != $aconn(-remoteport)} { - continue - } - if {[info exists opts(matchpid)] && - $opts(matchpid) != $aconn(-pid)} { - continue - } - # Matching conditions fulfilled - # 12 is "delete" code - catch { - SetTcpEntry [list 12 $aconn(-localaddr) $aconn(-localport) $aconn(-remoteaddr) $aconn(-remoteport)] - } - } - return -} - -# Flush cache of host names and ports. -# Backward compatibility - no op since we no longer have a cache -proc twapi::flush_network_name_cache {} {} - -# IP addr -> hostname -proc twapi::resolve_address {addr args} { - - # flushcache is ignored (for backward compatibility only) - array set opts [parseargs args { - flushcache - async.arg - } -maxleftover 0] - - # Note as a special case, we treat 0.0.0.0 explicitly since - # win32 getnameinfo translates this to the local host name which - # is completely bogus. - if {$addr eq "0.0.0.0"} { - if {[info exists opts(async)]} { - after idle [list after 0 $opts(async) [list $addr success $addr]] - return "" - } else { - return $addr - } - } - - # If async option, we will call back our internal function which - # will update the cache and then invoke the caller's script - if {[info exists opts(async)]} { - variable _address_handler_scripts - set id [Twapi_ResolveAddressAsync $addr] - set _address_handler_scripts($id) [list $addr $opts(async)] - return "" - } - - # Synchronous - set name [lindex [twapi::getnameinfo [list $addr] 8] 0] - if {$name eq $addr} { - # Could not resolve. - set name "" - } - - return $name -} - -# host name -> IP addresses -proc twapi::resolve_hostname {name args} { - set name [string tolower $name] - - # -flushcache option ignored (for backward compat only) - array set opts [parseargs args { - flushcache - async.arg - {ipversion.arg 0} - } -maxleftover 0] - - # NOTE: we do not pass the IP version to getaddrinfo but always - # give it 0 and then filter the results based on IP version ourselves - # if necessary. This is because of some confusion over behaviour - # with various combination of flags. - - set opts(ipversion) [_ipversion_to_af $opts(ipversion)] - set flags 0 - if {[min_os_version 6]} { - # 0x100 -> AI_ALL. By default, Windows enables the AI_ADDRCONFIG - # flat which will hide IPv6 addresses if the local system does - # not have an *global* IPv6 addr configured. We don't want that - # so set AI_ALL to override it and get back all addresses. - set flags 0x100; # AI_ALL - } - - # If async option, we will call back our internal function which - # will update the cache and then invoke the caller's script - if {[info exists opts(async)]} { - variable _hostname_handler_scripts - set id [Twapi_ResolveHostnameAsync $name 0 $flags] - set _hostname_handler_scripts($id) [list $opts(ipversion) $name $opts(async)] - return "" - } - - # Resolve address synchronously - set addrs [list ] - trap { - foreach endpt [twapi::getaddrinfo $name 0 0 0 0 $flags] { - # endpt is {family address port} - if {$opts(ipversion) == 0 || $opts(ipversion) == [lindex $endpt 0]} { - lappend addrs [lindex $endpt 1] - } - } - } onerror {TWAPI_WIN32 11001} { - # Ignore - 11001 -> no such host, so just return empty list - } onerror {TWAPI_WIN32 11002} { - # Ignore - 11002 -> no such host, non-authoritative - } onerror {TWAPI_WIN32 11003} { - # Ignore - 11001 -> no such host, non recoverable - } onerror {TWAPI_WIN32 11004} { - # Ignore - 11004 -> no such host, though valid syntax - } - - return $addrs -} - -# Look up a port name -proc twapi::port_to_service {port} { - set name "" - trap { - set name [lindex [twapi::getnameinfo [list 0.0.0.0 $port] 2] 1] - if {[string is integer $name] && $name == $port} { - # Some platforms return the port itself if no name exists - set name "" - } - } onerror {TWAPI_WIN32 11001} { - # Ignore - 11001 -> no such host, so just return empty list - } onerror {TWAPI_WIN32 11002} { - # Ignore - 11002 -> no such host, non-authoritative - } onerror {TWAPI_WIN32 11003} { - # Ignore - 11001 -> no such host, non recoverable - } onerror {TWAPI_WIN32 11004} { - # Ignore - 11004 -> no such host, though valid syntax - } - - # If we did not get a name back, check for some well known names - # that windows does not translate. Note some of these are names - # that windows does translate in the reverse direction! - if {$name eq ""} { - foreach {p n} { - 123 ntp - 137 netbios-ns - 138 netbios-dgm - 500 isakmp - 1900 ssdp - 4500 ipsec-nat-t - } { - if {$port == $p} { - set name $n - break - } - } - } - - return $name -} - - -# Port name -> number -proc twapi::service_to_port {name} { - - # TBD - add option for specifying protocol - set protocol 0 - - if {[string is integer $name]} { - return $name - } - - if {[catch { - # Return the first port - set port [lindex [lindex [twapi::getaddrinfo "" $name $protocol] 0] 2] - }]} { - set port "" - } - return $port -} - -# Get the routing table -proc twapi::get_routing_table {args} { - array set opts [parseargs args { - sort - } -maxleftover 0] - - set routes [list ] - foreach route [twapi::GetIpForwardTable $opts(sort)] { - lappend routes [_format_route $route] - } - - return $routes -} - -# Get the best route for given destination -proc twapi::get_route {args} { - array set opts [parseargs args { - {dest.arg 0.0.0.0} - {source.arg 0.0.0.0} - } -maxleftover 0] - return [_format_route [GetBestRoute $opts(dest) $opts(source)]] -} - -# Get the interface for a destination -proc twapi::get_outgoing_interface {{dest 0.0.0.0}} { - return [GetBestInterfaceEx $dest] -} - -proc twapi::get_ipaddr_version {addr} { - set af [Twapi_IPAddressFamily $addr] - if {$af == 2} { - return 4 - } elseif {$af == 23} { - return 6 - } else { - return 0 - } -} - -################################################################ -# Utility procs - -# Convert a route as returned by C code to Tcl format route -proc twapi::_format_route {route} { - foreach fld { - addr - mask - policy - nexthop - ifindex - type - protocol - age - nexthopas - metric1 - metric2 - metric3 - metric4 - metric5 - } val $route { - set r(-$fld) $val - } - - switch -exact -- $r(-type) { - 2 { set r(-type) invalid } - 3 { set r(-type) local } - 4 { set r(-type) remote } - 1 - - default { set r(-type) other } - } - - switch -exact -- $r(-protocol) { - 2 { set r(-protocol) local } - 3 { set r(-protocol) netmgmt } - 4 { set r(-protocol) icmp } - 5 { set r(-protocol) egp } - 6 { set r(-protocol) ggp } - 7 { set r(-protocol) hello } - 8 { set r(-protocol) rip } - 9 { set r(-protocol) is_is } - 10 { set r(-protocol) es_is } - 11 { set r(-protocol) cisco } - 12 { set r(-protocol) bbn } - 13 { set r(-protocol) ospf } - 14 { set r(-protocol) bgp } - 1 - - default { set r(-protocol) other } - } - - return [array get r] -} - - -# Convert binary hardware address to string format -proc twapi::_hwaddr_binary_to_string {b {joiner -}} { - if {[binary scan $b H* str]} { - set s "" - foreach {x y} [split $str ""] { - lappend s $x$y - } - return [join $s $joiner] - } else { - error "Could not convert binary hardware address" - } -} - -# Callback for address resolution -proc twapi::_address_resolve_handler {id status hostname} { - variable _address_handler_scripts - - if {![info exists _address_handler_scripts($id)]} { - # Queue a background error - after 0 [list error "Error: No entry found for id $id in address request table"] - return - } - lassign $_address_handler_scripts($id) addr script - unset _address_handler_scripts($id) - - # Before invoking the callback, store result if available - uplevel #0 [linsert $script end $addr $status $hostname] - return -} - -# Callback for hostname resolution -proc twapi::_hostname_resolve_handler {id status addrandports} { - variable _hostname_handler_scripts - - if {![info exists _hostname_handler_scripts($id)]} { - # Queue a background error - after 0 [list error "Error: No entry found for id $id in hostname request table"] - return - } - lassign $_hostname_handler_scripts($id) ipver name script - unset _hostname_handler_scripts($id) - - set addrs {} - if {$status eq "success"} { - foreach addr $addrandports { - lassign $addr ver addr - if {$ipver == 0 || $ipver == $ver} { - lappend addrs $addr - } - } - } elseif {$addrandports == 11001 || $addrandports == 11004} { - # For compatibility with the sync version and address resolution, - # We return an success if empty list if in fact the failure was - # that no name->address mapping exists - set status success - } - - uplevel #0 [linsert $script end $name $status $addrs] - return -} - -# Return list of all TCP connections -# Uses GetExtendedTcpTable if available, else AllocateAndGetTcpExTableFromStack -# $level is passed to GetExtendedTcpTable and dtermines format of returned -# data. Level 5 (default) matches what AllocateAndGetTcpExTableFromStack -# returns. Note level 6 and higher is two orders of magnitude more expensive -# to get for IPv4 and crashes in Windows for IPv6 (silently downgraded to -# level 5 for IPv6) -twapi::proc* twapi::_get_all_tcp {sort level address_family} { - variable _tcp_buf - set _tcp_buf(ptr) NULL - set _tcp_buf(size) 0 -} { - variable _tcp_buf - - if {$address_family == 0} { - return [concat [_get_all_tcp $sort $level 2] [_get_all_tcp $sort $level 23]] - } - - if {$address_family == 23 && $level > 5} { - set level 5; # IPv6 crashes for levels > 5 - Windows bug - } - - # Get required size of buffer. This also verifies that the - # GetExtendedTcpTable API exists on this system - # TBD - modify to do this check only once and not on every call - - if {[catch {twapi::GetExtendedTcpTable $_tcp_buf(ptr) $_tcp_buf(size) $sort $address_family $level} bufsz]} { - # No workee, try AllocateAndGetTcpExTableFromStack - # Note if GetExtendedTcpTable is not present, ipv6 is not - # available - if {$address_family == 2} { - return [AllocateAndGetTcpExTableFromStack $sort 0] - } else { - return {} - } - } - - # The required buffer size might change as connections - # are added or deleted. So we sit in a loop. - # Non-0 value indicates buffer was not large enough - # For safety, we only retry 10 times - set i 0 - while {$bufsz && [incr i] <= 10} { - if {! [pointer_null? $_tcp_buf(ptr)]} { - free $_tcp_buf(ptr) - set _tcp_buf(ptr) NULL - set _tcp_buf(size) 0 - } - - set _tcp_buf(ptr) [malloc $bufsz] - set _tcp_buf(size) $bufsz - - set bufsz [GetExtendedTcpTable $_tcp_buf(ptr) $_tcp_buf(size) $sort $address_family $level] - } - - if ($bufsz) { - # Repeated attempts failed - win32_error 122 - } - - return [Twapi_FormatExtendedTcpTable $_tcp_buf(ptr) $address_family $level] -} - -# See comments for _get_all_tcp above except this is for _get_all_udp -twapi::proc* twapi::_get_all_udp {sort level address_family} { - variable _udp_buf - set _udp_buf(ptr) NULL - set _udp_buf(size) 0 -} { - variable _udp_buf - - if {$address_family == 0} { - return [concat [_get_all_udp $sort $level 2] [_get_all_udp $sort $level 23]] - } - - if {$address_family == 23 && $level > 5} { - set level 5; # IPv6 crashes for levels > 5 - Windows bug - } - - # Get required size of buffer. This also verifies that the - # GetExtendedTcpTable API exists on this system - if {[catch {twapi::GetExtendedUdpTable $_udp_buf(ptr) $_udp_buf(size) $sort $address_family $level} bufsz]} { - # No workee, try AllocateAndGetUdpExTableFromStack - if {$address_family == 2} { - return [AllocateAndGetUdpExTableFromStack $sort 0] - } else { - return {} - } - } - - # The required buffer size might change as connections - # are added or deleted. So we sit in a loop. - # Non-0 value indicates buffer was not large enough - # For safety, we only retry 10 times - set i 0 - while {$bufsz && [incr i] <= 10} { - if {! [pointer_null? $_udp_buf(ptr)]} { - free $_udp_buf(ptr) - set _udp_buf(ptr) NULL - set _udp_buf(size) 0 - } - - set _udp_buf(ptr) [malloc $bufsz] - set _udp_buf(size) $bufsz - - set bufsz [GetExtendedUdpTable $_udp_buf(ptr) $_udp_buf(size) $sort $address_family $level] - } - - if ($bufsz) { - # Repeated attempts failed - win32_error 122 - } - - return [Twapi_FormatExtendedUdpTable $_udp_buf(ptr) $address_family $level] -} - - -# valid IP address -proc twapi::_valid_ipaddr_format {ipaddr} { - return [expr {[Twapi_IPAddressFamily $ipaddr] != 0}] -} - -# Given lists of IP addresses and DNS names, returns -# a list purely of IP addresses in normalized form -proc twapi::_hosts_to_ip_addrs hosts { - set addrs [list ] - foreach host $hosts { - if {[_valid_ipaddr_format $host]} { - lappend addrs [Twapi_NormalizeIPAddress $host] - } else { - # Not IP address. Try to resolve, ignoring errors - if {![catch {resolve_hostname $host} hostaddrs]} { - foreach addr $hostaddrs { - lappend addrs [Twapi_NormalizeIPAddress $addr] - } - } - } - } - return $addrs -} - -proc twapi::_ipversion_to_af {opt} { - if {[string is integer -strict $opt]} { - incr opt 0; # Normalize ints for switch - } - switch -exact -- [string tolower $opt] { - 4 - - inet { return 2 } - 6 - - inet6 { return 23 } - 0 - - any - - all { return 0 } - } - error "Invalid IP version '$opt'" -} diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/nls.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/nls.tcl deleted file mode 100644 index 66b51db9..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/nls.tcl +++ /dev/null @@ -1,467 +0,0 @@ -# -# 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" - } -} - - diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/os.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/os.tcl deleted file mode 100644 index 87939756..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/os.tcl +++ /dev/null @@ -1,1213 +0,0 @@ -# -# Copyright (c) 2003-2012, Ashok P. Nadkarni -# All rights reserved. -# -# See the file LICENSE for license - -namespace eval twapi {} - -# Returns an keyed list with the following elements: -# os_major_version -# os_minor_version -# os_build_number -# platform - currently always NT -# sp_major_version -# sp_minor_version -# suites - one or more from backoffice, blade, datacenter, enterprise, -# smallbusiness, smallbusiness_restricted, terminal, personal -# system_type - workstation, server -proc twapi::get_os_info {} { - variable _osinfo - - if {[info exists _osinfo]} { - return [array get _osinfo] - } - - array set verinfo [GetVersionEx] - set _osinfo(os_major_version) $verinfo(dwMajorVersion) - set _osinfo(os_minor_version) $verinfo(dwMinorVersion) - set _osinfo(os_build_number) $verinfo(dwBuildNumber) - set _osinfo(platform) "NT" - - set _osinfo(sp_major_version) $verinfo(wServicePackMajor) - set _osinfo(sp_minor_version) $verinfo(wServicePackMinor) - - set _osinfo(suites) [list ] - set suites $verinfo(wSuiteMask) - foreach {suite def} { - backoffice 0x4 blade 0x400 communications 0x8 compute_server 0x4000 - datacenter 0x80 embeddednt 0x40 embedded_restricted 0x800 - enterprise 0x2 personal 0x200 security_appliance 0x1000 - singleuserts 0x100 smallbusiness 0x1 - smallbusiness_restricted 0x20 storage_server 0x2000 - terminal 0x10 wh_server 0x8000 - } { - if {$suites & $def} { - lappend _osinfo(suites) $suite - } - } - - set system_type $verinfo(wProductType) - if {$system_type == 1} { - set _osinfo(system_type) "workstation"; # VER_NT_WORKSTATION - } elseif {$system_type == 3} { - set _osinfo(system_type) "server"; # VER_NT_SERVER - } elseif {$system_type == 2} { - set _osinfo(system_type) "domain_controller"; # VER_NT_DOMAIN_CONTROLLER - } else { - set _osinfo(system_type) "unknown" - } - - return [array get _osinfo] -} - -# Return a text string describing the OS version and options -# If specified, osinfo should be a keyed list containing -# data returned by get_os_info -proc twapi::get_os_description {} { - - array set osinfo [get_os_info] - - # Assume not terminal server - set tserver "" - - # Version - set osversion "$osinfo(os_major_version).$osinfo(os_minor_version)" - - set systype "" - - # Base OS name - switch -exact -- $osversion { - "5.0" { - set osname "Windows 2000" - if {[string equal $osinfo(system_type) "workstation"]} { - set systype "Professional" - } else { - if {"datacenter" in $osinfo(suites)} { - set systype "Datacenter Server" - } elseif {"enterprise" in $osinfo(suites)} { - set systype "Advanced Server" - } else { - set systype "Server" - } - } - } - "5.1" { - set osname "Windows XP" - if {"personal" in $osinfo(suites)} { - set systype "Home Edition" - } else { - set systype "Professional" - } - } - "5.2" { - set osname "Windows Server 2003" - if {[GetSystemMetrics 89]} { - append osname " R2" - } - if {"datacenter" in $osinfo(suites)} { - set systype "Datacenter Edition" - } elseif {"enterprise" in $osinfo(suites)} { - set systype "Enterprise Edition" - } elseif {"blade" in $osinfo(suites)} { - set systype "Web Edition" - } else { - set systype "Standard Edition" - } - } - "6.0" { - set prodtype [GetProductInfo] - if {$osinfo(system_type) eq "workstation"} { - set osname "Windows Vista" - } else { - set osname "Windows Server 2008" - } - } - "6.1" { - set prodtype [GetProductInfo] - if {$osinfo(system_type) eq "workstation"} { - set osname "Windows 7" - } else { - set osname "Windows Server 2008 R2" - } - } - "6.2" { - if {$osinfo(system_type) eq "workstation"} { - # Win8 does not follow the systype table below - switch -exact -- [format %x [GetProductInfo]] { - 3 {set systype ""} - 6 {set systype Pro} - default {set systype Enterprise} - } - set osname "Windows 8" - } else { - set prodtype [GetProductInfo] - - set osname "Windows Server 2012" - } - - } - "6.3" { - if {$osinfo(system_type) eq "workstation"} { - # Win8.1 probably (TBD) does not follow the systype table below - switch -exact -- [format %x [GetProductInfo]] { - 3 {set systype ""} - 6 {set systype Pro} - default {set systype Enterprise} - } - set osname "Windows 8.1" - } else { - set prodtype [GetProductInfo] - set osname "Windows Server 2012 R2" - } - } - default { - # Future release - can't really name, just make something up - catch {set prodtype [GetProductInfo]} - set osname "Windows" - } - } - - if {[info exists prodtype] && $prodtype} { - catch { - set systype [dict get { - 1 "Ultimate" - 2 "Home Basic" - 3 "Home Premium" - 4 "Enterprise" - 5 "Home Basic N" - 6 "Business" - 7 "Standard" - 8 "Datacenter" - 9 "Small Business Server" - a "Enterprise Server" - b "Starter" - c "Datacenter Server Core" - d "Standard Server Core" - e "Enterprise Server Core" - f "Enterprise Server Ia64" - 10 "Business N" - 11 "Web Server" - 12 "HPC Edition" - 13 "Home Server" - 14 "Storage Server Express" - 15 "Storage Server Standard" - 16 "Storage Server Workgroup" - 17 "Storage Server Enterprise" - 18 "Essential Server Solutions" - 19 "Small Business Server Premium" - 1a "Home Premium N" - 1b "Enterprise N" - 1c "Ultimate N" - 1d "Web Server Core" - 1e "Essential Business Server Management Server" - 1f "Essential Business Server Security Server" - 20 "Essential Business Server Messaging Server" - 21 "Server Foundation" - 22 "Home Premium Server" - 23 "Essential Server Solutions without Hyper-V" - 24 "Standard without Hyper-V" - 25 "Datacenter without Hyper-V" - 26 "Enterprise without Hyper-V" - 26 "Enterprise Server V" - 27 "Datacenter Server Core without Hyper-V" - 28 "Standard Core without Hyper-V" - 29 "Enterprise Server Core without Hyper-V" - 2a "Hyper-V Server" - 2b "Storage Express Server Core" - 2c "Storage Standard Server Core" - 2d "Storage Workgroup Server Core" - 2e "Storage Enterprise Server Core" - 2f "Starter N" - 30 "Professional" - 31 "Professional N" - 32 "Small Business Server 2011 Essentials" - 33 "Server For SB Solutions" - 34 "Standard Server Solutions" - 35 "Standard Server Solutions Core" - 36 "Server For SB Solutions EM" - 37 "Server For SB Solutions EM" - 38 "Windows MultiPoint Server" - 39 "Solution Embeddedserver Core" - 3a "Professional Embedded" - 3b "Windows Essential Server Solution Management" - 3c "Windows Essential Server Solution Additional" - 3d "Windows Essential Server Solution SVC" - 3e "Windows Essential Server Solution Additional SVC" - 3f "Small Business Premium Server Core" - 40 "Hyper Core V" - 41 "Embedded" - 42 "Starter E" - 43 "Home Basic E" - 44 "Home Premium E" - 45 "Professional E" - 46 "Enterprise E" - 47 "Ultimate E" - 48 "Enterprise Evaluation" - 4c "Multipoint Standard Server" - 4d "Multipoint Premium Server" - 4f "Standard Evaluation Server" - 50 "Datacenter Evaluation" - 54 "Enterprise N Evaluation" - 55 "Embedded Automotive" - 56 "Embedded Industry A" - 57 "Thin PC" - 58 "Embedded A" - 59 "Embedded Industry" - 5a "Embedded E" - 5b "Embedded Industry E" - 5c "Embedded Industry A E" - 5f "Storage Workgroup Evaluation Server" - 60 "Storage Standard Evaluation Server" - 61 "Core Arm" - 62 "N" - 63 "China" - 64 "Single Language" - 65 "" - 67 "Professional Wmc" - 68 "Mobile Core" - 69 "Embedded Industry Eval" - 6a "Embedded Industry E Eval" - 6b "Embedded Eval" - 6c "Embedded E Eval" - 6d "Core Server" - 6e "Cloud Storage Server" - abcdabcd "unlicensed" - } [format %x $prodtype]] - } - } - - if {"terminal" in $osinfo(suites)} { - set tserver " with Terminal Services" - } - - # Service pack - if {$osinfo(sp_major_version) != 0} { - set spver " Service Pack $osinfo(sp_major_version)" - } else { - set spver "" - } - - if {$systype ne ""} { - return "$osname $systype ${osversion} (Build $osinfo(os_build_number))${spver}${tserver}" - } else { - return "$osname ${osversion} (Build $osinfo(os_build_number))${spver}${tserver}" - } -} - -proc twapi::get_processor_group_config {} { - trap { - set info [GetLogicalProcessorInformationEx 4] - if {[llength $info]} { - set maxgroupcount [lindex $info 0 1 0] - set groups {} - set num -1 - foreach group [lindex $info 0 1 1] { - lappend groups [incr num] [twine {-maxprocessorcount -activeprocessorcount -processormask} $group] - } - } - return [list -maxgroupcount $maxgroupcount -activegroups $groups] - } onerror {TWAPI_WIN32 127} { - # Just try older APIs - set processor_count [lindex [GetSystemInfo] 5] - return [list -maxgroupcount 1 -activegroups [list 0 [list -maxprocessorcount $processor_count -activeprocessorcount $processor_count -processormask [expr {(1 << $processor_count) - 1}]]]] - } - -} - -proc twapi::get_numa_config {} { - trap { - set result {} - foreach rec [GetLogicalProcessorInformationEx 1] { - lappend result [lindex $rec 1 0] [twine {-processormask -group} [lindex $rec 1 1]] - } - return $result - } onerror {TWAPI_WIN32 127} { - # Use older APIs below - } - - # If GetLogicalProcessorInformation is available, records of type "1" - # indicate NUMA information. Use it. - trap { - set result {} - foreach rec [GetLogicalProcessorInformation] { - if {[lindex $rec 1] == 1} { - lappend result [lindex $rec 2] [list -processormask [lindex $rec 0] -group 0] - } - } - return $result - } onerror {TWAPI_WIN32 127} { - # API not present, fake it - } - - return $result -} - -# Returns proc information -# $processor should be processor number or "" for "total" -proc twapi::get_processor_info {processor args} { - - if {![string is integer $processor]} { - error "Invalid processor number \"$processor\". Should be a processor identifier or the empty string to signify all processors" - } - - if {![info exists ::twapi::get_processor_info_base_opts]} { - array set ::twapi::get_processor_info_base_opts { - idletime IdleTime - privilegedtime KernelTime - usertime UserTime - dpctime DpcTime - interrupttime InterruptTime - interrupts InterruptCount - } - } - - set sysinfo_opts { - arch - processorlevel - processorrev - processorname - processormodel - processorspeed - } - - array set opts [parseargs args \ - [concat all \ - [array names ::twapi::get_processor_info_base_opts] \ - $sysinfo_opts] -maxleftover 0] - - # Registry lookup for processor description - # If no processor specified, use 0 under the assumption all processors - # are the same - set reg_hwkey "HKEY_LOCAL_MACHINE\\HARDWARE\\DESCRIPTION\\System\\CentralProcessor\\[expr {$processor == "" ? 0 : $processor}]" - - set results [list ] - - set processordata [Twapi_SystemProcessorTimes] - if {$processor ne ""} { - if {[llength $processordata] <= $processor} { - error "Invalid processor number '$processor'" - } - array set times [lindex $processordata $processor] - foreach {opt field} [array get ::twapi::get_processor_info_base_opts] { - if {$opts(all) || $opts($opt)} { - lappend results -$opt $times($field) - } - } - } else { - # Need information across all processors - foreach instancedata $processordata { - foreach {opt field} [array get ::twapi::get_processor_info_base_opts] { - incr times($field) [kl_get $instancedata $field] - } - foreach {opt field} [array get ::twapi::get_processor_info_base_opts] { - if {$opts(all) || $opts($opt)} { - lappend results -$opt $times($field) - } - } - } - } - - if {$opts(all) || $opts(arch) || $opts(processorlevel) || $opts(processorrev)} { - set sysinfo [GetSystemInfo] - if {$opts(all) || $opts(arch)} { - lappend results -arch [dict* { - 0 intel - 5 arm - 6 ia64 - 9 amd64 - 10 ia32_win64 - 65535 unknown - } [lindex $sysinfo 0]] - } - - if {$opts(all) || $opts(processorlevel)} { - lappend results -processorlevel [lindex $sysinfo 8] - } - - if {$opts(all) || $opts(processorrev)} { - lappend results -processorrev [format %x [lindex $sysinfo 9]] - } - } - - if {$opts(all) || $opts(processorname)} { - if {[catch {registry get $reg_hwkey "ProcessorNameString"} val]} { - set val "unknown" - } - lappend results -processorname $val - } - - if {$opts(all) || $opts(processormodel)} { - if {[catch {registry get $reg_hwkey "Identifier"} val]} { - set val "unknown" - } - lappend results -processormodel $val - } - - if {$opts(all) || $opts(processorspeed)} { - if {[catch {registry get $reg_hwkey "~MHz"} val]} { - set val "unknown" - } - lappend results -processorspeed $val - } - - return $results -} - -# Get mask of active processors -# TBD - handle processor groups -proc twapi::get_active_processor_mask {} { - return [format 0x%x [lindex [GetSystemInfo] 4]] -} - - -# Get number of active processors -proc twapi::get_processor_count {} { - trap { - set info [GetLogicalProcessorInformationEx 4] - if {[llength $info]} { - set count 0 - foreach group [lindex $info 0 1 1] { - incr count [lindex $group 1] - } - } - return $count - } onerror {TWAPI_WIN32 127} { - # GetLogicalProcessorInformationEx call does not exist - # so system does not support processor groups - return [lindex [GetSystemInfo] 5] - } -} - -# Get system memory information -proc twapi::get_memory_info {args} { - array set opts [parseargs args { - all - allocationgranularity - availcommit - availphysical - kernelpaged - kernelnonpaged - minappaddr - maxappaddr - pagesize - peakcommit - physicalmemoryload - processavailcommit - processcommitlimit - processtotalvirtual - processavailvirtual - swapfiles - swapfiledetail - systemcache - totalcommit - totalphysical - usedcommit - } -maxleftover 0] - - - set results [list ] - set mem [GlobalMemoryStatus] - foreach {opt fld} { - physicalmemoryload dwMemoryLoad - totalphysical ullTotalPhys - availphysical ullAvailPhys - processcommitlimit ullTotalPageFile - processavailcommit ullAvailPageFile - processtotalvirtual ullTotalVirtual - processavailvirtual ullAvailVirtual - } { - if {$opts(all) || $opts($opt)} { - lappend results -$opt [kl_get $mem $fld] - } - } - - if {$opts(all) || $opts(swapfiles) || $opts(swapfiledetail)} { - set swapfiles [list ] - set swapdetail [list ] - - foreach item [Twapi_SystemPagefileInformation] { - lassign $item current_size total_used peak_used path - set path [_normalize_path $path] - lappend swapfiles $path - lappend swapdetail $path [list $current_size $total_used $peak_used] - } - if {$opts(all) || $opts(swapfiles)} { - lappend results -swapfiles $swapfiles - } - if {$opts(all) || $opts(swapfiledetail)} { - lappend results -swapfiledetail $swapdetail - } - } - - if {$opts(all) || $opts(allocationgranularity) || - $opts(minappaddr) || $opts(maxappaddr) || $opts(pagesize)} { - set sysinfo [twapi::GetSystemInfo] - foreach {opt fmt index} { - pagesize %u 1 minappaddr 0x%lx 2 maxappaddr 0x%lx 3 allocationgranularity %u 7} { - if {$opts(all) || $opts($opt)} { - lappend results -$opt [format $fmt [lindex $sysinfo $index]] - } - } - } - - # This call is slightly expensive so check if it is really needed - if {$opts(all) || $opts(totalcommit) || $opts(usedcommit) || - $opts(availcommit) || - $opts(kernelpaged) || $opts(kernelnonpaged) - } { - set mem [GetPerformanceInformation] - set page_size [kl_get $mem PageSize] - foreach {opt fld} { - totalcommit CommitLimit - usedcommit CommitTotal - peakcommit CommitPeak - systemcache SystemCache - kernelpaged KernelPaged - kernelnonpaged KernelNonpaged - } { - if {$opts(all) || $opts($opt)} { - lappend results -$opt [expr {[kl_get $mem $fld] * $page_size}] - } - } - if {$opts(all) || $opts(availcommit)} { - lappend results -availcommit [expr {$page_size * ([kl_get $mem CommitLimit]-[kl_get $mem CommitTotal])}] - } - } - - return $results -} - -# Get the netbios name -proc twapi::get_computer_netbios_name {} { - return [GetComputerName] -} - -# Get the computer name -proc twapi::get_computer_name {{typename netbios}} { - if {[string is integer $typename]} { - set type $typename - } else { - set type [lsearch -exact {netbios dnshostname dnsdomain dnsfullyqualified physicalnetbios physicaldnshostname physicaldnsdomain physicaldnsfullyqualified} $typename] - if {$type < 0} { - error "Unknown computer name type '$typename' specified" - } - } - return [GetComputerNameEx $type] -} - -# Suspend system -proc twapi::suspend_system {args} { - array set opts [parseargs args { - {state.arg standby {standby hibernate}} - force.bool - disablewakeevents.bool - } -maxleftover 0 -nulldefault] - - eval_with_privileges { - SetSuspendState [expr {$opts(state) eq "hibernate"}] $opts(force) $opts(disablewakeevents) - } SeShutdownPrivilege -} - -# Shut down the system -proc twapi::shutdown_system {args} { - array set opts [parseargs args { - system.arg - {message.arg "System shutdown has been initiated"} - {timeout.int 60} - force - restart - } -nulldefault] - - eval_with_privileges { - InitiateSystemShutdown $opts(system) $opts(message) \ - $opts(timeout) $opts(force) $opts(restart) - } SeShutdownPrivilege -} - -# Abort a system shutdown -proc twapi::abort_system_shutdown {args} { - array set opts [parseargs args {system.arg} -nulldefault] - eval_with_privileges { - AbortSystemShutdown $opts(system) - } SeShutdownPrivilege -} - -twapi::proc* twapi::get_system_uptime {} { - package require twapi_pdh - variable _system_start_time - set ctr_path [pdh_counter_path System "System Up Time"] - set uptime [pdh_counter_path_value $ctr_path -format double] - set now [clock seconds] - set _system_start_time [expr {$now - round($uptime+0.5)}] -} { - variable _system_start_time - return [expr {[clock seconds] - $_system_start_time}] -} - -proc twapi::get_system_sid {} { - set lsah [get_lsa_policy_handle -access policy_view_local_information] - trap { - return [lindex [LsaQueryInformationPolicy $lsah 5] 1] - } finally { - close_lsa_policy_handle $lsah - } -} - -# Get the primary domain controller -proc twapi::get_primary_domain_controller {args} { - array set opts [parseargs args {system.arg domain.arg} -nulldefault -maxleftover 0] - return [NetGetDCName $opts(system) $opts(domain)] -} - -# Get a domain controller for a domain -proc twapi::find_domain_controller {args} { - array set opts [parseargs args { - system.arg - avoidself.bool - domain.arg - domainguid.arg - site.arg - rediscover.bool - allowstale.bool - require.arg - prefer.arg - justldap.bool - {inputnameformat.arg any {dns flat netbios any}} - {outputnameformat.arg any {dns flat netbios any}} - {outputaddrformat.arg any {ip netbios any}} - getdetails - } -maxleftover 0 -nulldefault] - - - set flags 0 - - if {$opts(outputaddrformat) eq "ip"} { - setbits flags 0x200 - } - - # Set required bits. - foreach req $opts(require) { - if {[string is integer $req]} { - setbits flags $req - } else { - switch -exact -- $req { - directoryservice { setbits flags 0x10 } - globalcatalog { setbits flags 0x40 } - pdc { setbits flags 0x80 } - kdc { setbits flags 0x400 } - timeserver { setbits flags 0x800 } - writable { setbits flags 0x1000 } - default { - error "Invalid token '$req' specified in value for option '-require'" - } - } - } - } - - # Set preferred bits. - foreach req $opts(prefer) { - if {[string is integer $req]} { - setbits flags $req - } else { - switch -exact -- $req { - directoryservice { - # If required flag is already set, don't set this - if {! ($flags & 0x10)} { - setbits flags 0x20 - } - } - timeserver { - # If required flag is already set, don't set this - if {! ($flags & 0x800)} { - setbits flags 0x2000 - } - } - default { - error "Invalid token '$req' specified in value for option '-prefer'" - } - } - } - } - - if {$opts(rediscover)} { - setbits flags 0x1 - } else { - # Only look at this option if rediscover is not set - if {$opts(allowstale)} { - setbits flags 0x100 - } - } - - if {$opts(avoidself)} { - setbits flags 0x4000 - } - - if {$opts(justldap)} { - setbits flags 0x8000 - } - - switch -exact -- $opts(inputnameformat) { - any { } - netbios - - flat { setbits flags 0x10000 } - dns { setbits flags 0x20000 } - default { - error "Invalid value '$opts(inputnameformat)' for option '-inputnameformat'" - } - } - - switch -exact -- $opts(outputnameformat) { - any { } - netbios - - flat { setbits flags 0x80000000 } - dns { setbits flags 0x40000000 } - default { - error "Invalid value '$opts(outputnameformat)' for option '-outputnameformat'" - } - } - - array set dcinfo [DsGetDcName $opts(system) $opts(domain) $opts(domainguid) $opts(site) $flags] - - if {! $opts(getdetails)} { - return $dcinfo(DomainControllerName) - } - - set result [list \ - -dcname $dcinfo(DomainControllerName) \ - -dcaddr [string trimleft $dcinfo(DomainControllerAddress) \\] \ - -domainguid $dcinfo(DomainGuid) \ - -domain $dcinfo(DomainName) \ - -dnsforest $dcinfo(DnsForestName) \ - -dcsite $dcinfo(DcSiteName) \ - -clientsite $dcinfo(ClientSiteName) \ - ] - - - if {$dcinfo(DomainControllerAddressType) == 1} { - lappend result -dcaddrformat ip - } else { - lappend result -dcaddrformat netbios - } - - if {$dcinfo(Flags) & 0x20000000} { - lappend result -dcnameformat dns - } else { - lappend result -dcnameformat netbios - } - - if {$dcinfo(Flags) & 0x40000000} { - lappend result -domainformat dns - } else { - lappend result -domainformat netbios - } - - if {$dcinfo(Flags) & 0x80000000} { - lappend result -dnsforestformat dns - } else { - lappend result -dnsforestformat netbios - } - - set features [list ] - foreach {flag feature} { - 0x1 pdc - 0x4 globalcatalog - 0x8 ldap - 0x10 directoryservice - 0x20 kdc - 0x40 timeserver - 0x80 closest - 0x100 writable - 0x200 goodtimeserver - } { - if {$dcinfo(Flags) & $flag} { - lappend features $feature - } - } - - lappend result -features $features - - return $result -} - -# Get the primary domain info -proc twapi::get_primary_domain_info {args} { - array set opts [parseargs args { - all - name - dnsdomainname - dnsforestname - domainguid - sid - type - } -maxleftover 0] - - set result [list ] - set lsah [get_lsa_policy_handle -access policy_view_local_information] - trap { - lassign [LsaQueryInformationPolicy $lsah 12] name dnsdomainname dnsforestname domainguid sid - if {[string length $sid] == 0} { - set type workgroup - set domainguid "" - } else { - set type domain - } - foreach opt {name dnsdomainname dnsforestname domainguid sid type} { - if {$opts(all) || $opts($opt)} { - lappend result -$opt [set $opt] - } - } - } finally { - close_lsa_policy_handle $lsah - } - - return $result -} - -# Get a element from SystemParametersInfo -proc twapi::get_system_parameters_info {uiaction} { - variable SystemParametersInfo_uiactions_get - # Format of an element is - # uiaction_indexvalue uiparam binaryscanstring malloc_size modifiers - # uiparam may be an int or "sz" in which case the malloc size - # is substituted for it. - # If modifiers contains "cbsize" the first dword is initialized - # with malloc_size - if {![info exists SystemParametersInfo_uiactions_get]} { - array set SystemParametersInfo_uiactions_get { - SPI_GETDESKWALLPAPER {0x0073 2048 unicode 4096} - SPI_GETBEEP {0x0001 0 i 4} - SPI_GETMOUSE {0x0003 0 i3 12} - SPI_GETBORDER {0x0005 0 i 4} - SPI_GETKEYBOARDSPEED {0x000A 0 i 4} - SPI_ICONHORIZONTALSPACING {0x000D 0 i 4} - SPI_GETSCREENSAVETIMEOUT {0x000E 0 i 4} - SPI_GETSCREENSAVEACTIVE {0x0010 0 i 4} - SPI_GETKEYBOARDDELAY {0x0016 0 i 4} - SPI_ICONVERTICALSPACING {0x0018 0 i 4} - SPI_GETICONTITLEWRAP {0x0019 0 i 4} - SPI_GETMENUDROPALIGNMENT {0x001B 0 i 4} - SPI_GETDRAGFULLWINDOWS {0x0026 0 i 4} - SPI_GETNONCLIENTMETRICS {0x0029 sz {i6 i5 cu8 A64 i2 i5 cu8 A64 i2 i5 cu8 A64 i5 cu8 A64 i5 cu8 A64} 500 cbsize} - SPI_GETMINIMIZEDMETRICS {0x002B sz i5 20 cbsize} - SPI_GETWORKAREA {0x0030 0 i4 16} - SPI_GETKEYBOARDPREF {0x0044 0 i 4 } - SPI_GETSCREENREADER {0x0046 0 i 4} - SPI_GETANIMATION {0x0048 sz i2 8 cbsize} - SPI_GETFONTSMOOTHING {0x004A 0 i 4} - SPI_GETLOWPOWERTIMEOUT {0x004F 0 i 4} - SPI_GETPOWEROFFTIMEOUT {0x0050 0 i 4} - SPI_GETLOWPOWERACTIVE {0x0053 0 i 4} - SPI_GETPOWEROFFACTIVE {0x0054 0 i 4} - SPI_GETMOUSETRAILS {0x005E 0 i 4} - SPI_GETSCREENSAVERRUNNING {0x0072 0 i 4} - SPI_GETFILTERKEYS {0x0032 sz i6 24 cbsize} - SPI_GETTOGGLEKEYS {0x0034 sz i2 8 cbsize} - SPI_GETMOUSEKEYS {0x0036 sz i7 28 cbsize} - SPI_GETSHOWSOUNDS {0x0038 0 i 4} - SPI_GETSTICKYKEYS {0x003A sz i2 8 cbsize} - SPI_GETACCESSTIMEOUT {0x003C 12 i3 12 cbsize} - SPI_GETSNAPTODEFBUTTON {0x005F 0 i 4} - SPI_GETMOUSEHOVERWIDTH {0x0062 0 i 4} - SPI_GETMOUSEHOVERHEIGHT {0x0064 0 i 4 } - SPI_GETMOUSEHOVERTIME {0x0066 0 i 4} - SPI_GETWHEELSCROLLLINES {0x0068 0 i 4} - SPI_GETMENUSHOWDELAY {0x006A 0 i 4} - SPI_GETSHOWIMEUI {0x006E 0 i 4} - SPI_GETMOUSESPEED {0x0070 0 i 4} - SPI_GETACTIVEWINDOWTRACKING {0x1000 0 i 4} - SPI_GETMENUANIMATION {0x1002 0 i 4} - SPI_GETCOMBOBOXANIMATION {0x1004 0 i 4} - SPI_GETLISTBOXSMOOTHSCROLLING {0x1006 0 i 4} - SPI_GETGRADIENTCAPTIONS {0x1008 0 i 4} - SPI_GETKEYBOARDCUES {0x100A 0 i 4} - SPI_GETMENUUNDERLINES {0x100A 0 i 4} - SPI_GETACTIVEWNDTRKZORDER {0x100C 0 i 4} - SPI_GETHOTTRACKING {0x100E 0 i 4} - SPI_GETMENUFADE {0x1012 0 i 4} - SPI_GETSELECTIONFADE {0x1014 0 i 4} - SPI_GETTOOLTIPANIMATION {0x1016 0 i 4} - SPI_GETTOOLTIPFADE {0x1018 0 i 4} - SPI_GETCURSORSHADOW {0x101A 0 i 4} - SPI_GETMOUSESONAR {0x101C 0 i 4 } - SPI_GETMOUSECLICKLOCK {0x101E 0 i 4} - SPI_GETMOUSEVANISH {0x1020 0 i 4} - SPI_GETFLATMENU {0x1022 0 i 4} - SPI_GETDROPSHADOW {0x1024 0 i 4} - SPI_GETBLOCKSENDINPUTRESETS {0x1026 0 i 4} - SPI_GETUIEFFECTS {0x103E 0 i 4} - SPI_GETFOREGROUNDLOCKTIMEOUT {0x2000 0 i 4} - SPI_GETACTIVEWNDTRKTIMEOUT {0x2002 0 i 4} - SPI_GETFOREGROUNDFLASHCOUNT {0x2004 0 i 4} - SPI_GETCARETWIDTH {0x2006 0 i 4} - SPI_GETMOUSECLICKLOCKTIME {0x2008 0 i 4} - SPI_GETFONTSMOOTHINGTYPE {0x200A 0 i 4} - SPI_GETFONTSMOOTHINGCONTRAST {0x200C 0 i 4} - SPI_GETFOCUSBORDERWIDTH {0x200E 0 i 4} - SPI_GETFOCUSBORDERHEIGHT {0x2010 0 i 4} - } - if {$::tcl_platform(pointerSize) == 4} { - set hc_struct_size 12 - set bfmt i3 - } else { - set hc_struct_size 16 - set bfmt i4 - } - set SystemParametersInfo_uiactions_get(SPI_GETHIGHCONTRAST) [list 0x0042 sz $bfmt $hc_struct_size cbsize] - } - - set key [string toupper $uiaction] - - # TBD - - # SPI_GETSOUNDSENTRY {0x0040 } - # SPI_GETICONMETRICS {0x002D } - # SPI_GETICONTITLELOGFONT {0x001F } - # SPI_GETDEFAULTINPUTLANG {0x0059 } - # SPI_GETFONTSMOOTHINGORIENTATION {0x2012} - - if {![info exists SystemParametersInfo_uiactions_get($key)]} { - set key SPI_$key - if {![info exists SystemParametersInfo_uiactions_get($key)]} { - error "Unknown SystemParametersInfo index symbol '$uiaction'" - } - } - - lassign $SystemParametersInfo_uiactions_get($key) index uiparam fmt sz modifiers - if {$uiparam eq "sz"} { - set uiparam $sz - } - set mem [malloc $sz] - trap { - if {[lsearch -exact $modifiers cbsize] >= 0} { - # A structure that needs first field set to its size - Twapi_WriteMemory 1 $mem 0 $sz [binary format i $sz] - } - SystemParametersInfo $index $uiparam $mem 0 - if {$fmt eq "unicode"} { - return [Twapi_ReadMemory 3 $mem 0 $sz 1] - } else { - set n [binary scan [Twapi_ReadMemory 1 $mem 0 $sz] $fmt {*}[lrange {val0 val1 val2 val3 val4 val5 val6 val7 val8 val9 val10 val11 val12 val13 val14 val15 val16 val17 val17} 0 [llength $fmt]-1]] - if {$n == 1} { - return $val0 - } else { - set result {} - for {set i 0} {$i < $n} {incr i} { - lappend result {*}[set val$i] - } - return $result - } - } - } finally { - free $mem - } -} - -proc twapi::set_system_parameters_info {uiaction val args} { - variable SystemParametersInfo_uiactions_set - - # Format of an element is - # uiaction_indexvalue uiparam binaryscanstring malloc_size modifiers - # uiparam may be an int or "sz" in which case the malloc size - # is substribnuted for it. - # If modifiers contains "cbsize" the first dword is initialized - # with malloc_size - if {![info exists SystemParametersInfo_uiactions_set]} { - array set SystemParametersInfo_uiactions_set { - SPI_SETBEEP {0x0002 bool} - SPI_SETMOUSE {0x0004 unsupported} - SPI_SETBORDER {0x0006 int} - SPI_SETKEYBOARDSPEED {0x000B int} - SPI_ICONHORIZONTALSPACING {0x000D int} - SPI_SETSCREENSAVETIMEOUT {0x000F int} - SPI_SETSCREENSAVEACTIVE {0x0011 bool} - SPI_SETDESKWALLPAPER {0x0014 unsupported} - SPI_SETDESKPATTERN {0x0015 int} - SPI_SETKEYBOARDDELAY {0x0017 int} - SPI_ICONVERTICALSPACING {0x0018 int} - SPI_SETICONTITLEWRAP {0x001A bool} - SPI_SETMENUDROPALIGNMENT {0x001C bool} - SPI_SETDOUBLECLKWIDTH {0x001D int} - SPI_SETDOUBLECLKHEIGHT {0x001E int} - SPI_SETDOUBLECLICKTIME {0x0020 int} - SPI_SETMOUSEBUTTONSWAP {0x0021 bool} - SPI_SETICONTITLELOGFONT {0x0022 LOGFONT} - SPI_SETDRAGFULLWINDOWS {0x0025 bool} - SPI_SETNONCLIENTMETRICS {0x002A NONCLIENTMETRICS} - SPI_SETMINIMIZEDMETRICS {0x002C MINIMIZEDMETRICS} - SPI_SETICONMETRICS {0x002E ICONMETRICS} - SPI_SETWORKAREA {0x002F RECT} - SPI_SETPENWINDOWS {0x0031} - SPI_SETHIGHCONTRAST {0x0043 HIGHCONTRAST} - SPI_SETKEYBOARDPREF {0x0045 bool} - SPI_SETSCREENREADER {0x0047 bool} - SPI_SETANIMATION {0x0049 ANIMATIONINFO} - SPI_SETFONTSMOOTHING {0x004B bool} - SPI_SETDRAGWIDTH {0x004C int} - SPI_SETDRAGHEIGHT {0x004D int} - SPI_SETHANDHELD {0x004E} - SPI_SETLOWPOWERTIMEOUT {0x0051 int} - SPI_SETPOWEROFFTIMEOUT {0x0052 int} - SPI_SETLOWPOWERACTIVE {0x0055 bool} - SPI_SETPOWEROFFACTIVE {0x0056 bool} - SPI_SETCURSORS {0x0057 int} - SPI_SETICONS {0x0058 int} - SPI_SETDEFAULTINPUTLANG {0x005A HKL} - SPI_SETLANGTOGGLE {0x005B int} - SPI_SETMOUSETRAILS {0x005D int} - SPI_SETFILTERKEYS {0x0033 FILTERKEYS} - SPI_SETTOGGLEKEYS {0x0035 TOGGLEKEYS} - SPI_SETMOUSEKEYS {0x0037 MOUSEKEYS} - SPI_SETSHOWSOUNDS {0x0039 bool} - SPI_SETSTICKYKEYS {0x003B STICKYKEYS} - SPI_SETACCESSTIMEOUT {0x003D ACCESSTIMEOUT} - SPI_SETSERIALKEYS {0x003F SERIALKEYS} - SPI_SETSOUNDSENTRY {0x0041 SOUNDSENTRY} - SPI_SETSNAPTODEFBUTTON {0x0060 bool} - SPI_SETMOUSEHOVERWIDTH {0x0063 int} - SPI_SETMOUSEHOVERHEIGHT {0x0065 int} - SPI_SETMOUSEHOVERTIME {0x0067 int} - SPI_SETWHEELSCROLLLINES {0x0069 int} - SPI_SETMENUSHOWDELAY {0x006B int} - SPI_SETSHOWIMEUI {0x006F bool} - SPI_SETMOUSESPEED {0x0071 castint} - SPI_SETACTIVEWINDOWTRACKING {0x1001 castbool} - SPI_SETMENUANIMATION {0x1003 castbool} - SPI_SETCOMBOBOXANIMATION {0x1005 castbool} - SPI_SETLISTBOXSMOOTHSCROLLING {0x1007 castbool} - SPI_SETGRADIENTCAPTIONS {0x1009 castbool} - SPI_SETKEYBOARDCUES {0x100B castbool} - SPI_SETMENUUNDERLINES {0x100B castbool} - SPI_SETACTIVEWNDTRKZORDER {0x100D castbool} - SPI_SETHOTTRACKING {0x100F castbool} - SPI_SETMENUFADE {0x1013 castbool} - SPI_SETSELECTIONFADE {0x1015 castbool} - SPI_SETTOOLTIPANIMATION {0x1017 castbool} - SPI_SETTOOLTIPFADE {0x1019 castbool} - SPI_SETCURSORSHADOW {0x101B castbool} - SPI_SETMOUSESONAR {0x101D castbool} - SPI_SETMOUSECLICKLOCK {0x101F bool} - SPI_SETMOUSEVANISH {0x1021 castbool} - SPI_SETFLATMENU {0x1023 castbool} - SPI_SETDROPSHADOW {0x1025 castbool} - SPI_SETBLOCKSENDINPUTRESETS {0x1027 bool} - SPI_SETUIEFFECTS {0x103F castbool} - SPI_SETFOREGROUNDLOCKTIMEOUT {0x2001 castint} - SPI_SETACTIVEWNDTRKTIMEOUT {0x2003 castint} - SPI_SETFOREGROUNDFLASHCOUNT {0x2005 castint} - SPI_SETCARETWIDTH {0x2007 castint} - SPI_SETMOUSECLICKLOCKTIME {0x2009 int} - SPI_SETFONTSMOOTHINGTYPE {0x200B castint} - SPI_SETFONTSMOOTHINGCONTRAST {0x200D unsupported} - SPI_SETFOCUSBORDERWIDTH {0x200F castint} - SPI_SETFOCUSBORDERHEIGHT {0x2011 castint} - } - } - - - array set opts [parseargs args { - persist - notify - } -nulldefault] - - set flags 0 - if {$opts(persist)} { - setbits flags 1 - } - - if {$opts(notify)} { - # Note that actually the notify flag has no effect if persist - # is not set. - setbits flags 2 - } - - set key [string toupper $uiaction] - - if {![info exists SystemParametersInfo_uiactions_set($key)]} { - set key SPI_$key - if {![info exists SystemParametersInfo_uiactions_set($key)]} { - error "Unknown SystemParametersInfo index symbol '$uiaction'" - } - } - - lassign $SystemParametersInfo_uiactions_set($key) index fmt - - switch -exact -- $fmt { - int { SystemParametersInfo $index $val NULL $flags } - bool { - set val [expr {$val ? 1 : 0}] - SystemParametersInfo $index $val NULL $flags - } - castint { - # We have to pass the value as a cast pointer - SystemParametersInfo $index 0 [Twapi_AddressToPointer $val] $flags - } - castbool { - # We have to pass the value as a cast pointer - set val [expr {$val ? 1 : 0}] - SystemParametersInfo $index 0 [Twapi_AddressToPointer $val] $flags - } - default { - error "The data format for $uiaction is not currently supported" - } - } - - return -} - -namespace eval twapi { - variable _wts_session_monitors - set _wts_session_monitors [dict create] -} - -proc twapi::start_wts_session_monitor {script args} { - variable _wts_session_monitors - - parseargs args { - all - } -maxleftover 0 -setvars - set script [lrange $script 0 end]; # Verify syntactically a list - - set id "wts#[TwapiId]" - if {[dict size $_wts_session_monitors] == 0} { - # No monitoring in progress. Start it - # 0x2B1 -> WM_WTSSESSION_CHANGE - Twapi_WTSRegisterSessionNotification $all - _register_script_wm_handler 0x2B1 [list [namespace current]::_wts_session_change_handler] 0 - } - - dict set _wts_session_monitors $id $script - return $id -} - - -proc twapi::stop_wts_session_monitor {id} { - variable _wts_session_monitors - - if {![dict exists $_wts_session_monitors $id]} { - return - } - - dict unset _wts_session_monitors $id - if {[dict size $_wts_session_monitors] == 0} { - # 0x2B1 -> WM_WTSSESSION_CHANGE - _unregister_script_wm_handler 0x2B1 [list [namespace current]::_wts_session_handler] - Twapi_WTSUnRegisterSessionNotification - } -} - -proc twapi::_wts_session_change_handler {msg change session_id msgpos ticks} { - variable _wts_session_monitors - - if {[dict size $_wts_session_monitors] == 0} { - return; # Not an error, could have deleted while already queued - } - - dict for {id script} $_wts_session_monitors { - set code [catch {uplevel #0 [linsert $script end $change $session_id]} msg] - if {$code == 1} { - # Error - put in background but we do not abort - after 0 [list error $msg $::errorInfo $::errorCode] - } - } - return -} diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/pdh.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/pdh.tcl deleted file mode 100644 index fadf8817..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/pdh.tcl +++ /dev/null @@ -1,984 +0,0 @@ -# -# 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] -} diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/pkgIndex.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/pkgIndex.tcl deleted file mode 100644 index 1fc7471d..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/pkgIndex.tcl +++ /dev/null @@ -1,119 +0,0 @@ -# -# 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 -}] diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/power.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/power.tcl deleted file mode 100644 index f8a793c1..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/power.tcl +++ /dev/null @@ -1,136 +0,0 @@ -# -# 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] -} diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/printer.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/printer.tcl deleted file mode 100644 index d73af00d..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/printer.tcl +++ /dev/null @@ -1,58 +0,0 @@ -# -# 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] -} diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/process.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/process.tcl deleted file mode 100644 index 5f37800b..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/process.tcl +++ /dev/null @@ -1,2028 +0,0 @@ -# -# Copyright (c) 2003-2020, Ashok P. Nadkarni -# All rights reserved. -# -# See the file LICENSE for license - -namespace eval twapi {} - - -# Create a process -# TBD Use https://blogs.msdn.microsoft.com/twistylittlepassagesallalike/2011/04/23/everyone-quotes-command-line-arguments-the-wrong-way/ -# to construct -cmdline value -proc twapi::create_process {path args} { - array set opts [parseargs args { - {debugchildtree.bool 0 0x1} - {debugchild.bool 0 0x2} - {createsuspended.bool 0 0x4} - {detached.bool 0 0x8} - {newconsole.bool 0 0x10} - {newprocessgroup.bool 0 0x200} - {separatevdm.bool 0 0x800} - {sharedvdm.bool 0 0x1000} - {inheriterrormode.bool 1 0x04000000} - {noconsole.bool 0 0x08000000} - {priority.arg normal {normal abovenormal belownormal high realtime idle}} - - {feedbackcursoron.bool 0 0x40} - {feedbackcursoroff.bool 0 0x80} - {fullscreen.bool 0 0x20} - - {cmdline.arg ""} - {inheritablechildprocess.bool 0} - {inheritablechildthread.bool 0} - {childprocesssecd.arg ""} - {childthreadsecd.arg ""} - {inherithandles.bool 0} - {env.arg ""} - {startdir.arg ""} - {desktop.arg __null__} - {title.arg ""} - windowpos.arg - windowsize.arg - screenbuffersize.arg - background.arg - foreground.arg - {showwindow.arg ""} - {stdhandles.arg ""} - {stdchannels.arg ""} - {returnhandles.bool 0} - - token.arg - } -maxleftover 0] - - set process_sec_attr [_make_secattr $opts(childprocesssecd) $opts(inheritablechildprocess)] - set thread_sec_attr [_make_secattr $opts(childthreadsecd) $opts(inheritablechildthread)] - - # Check incompatible options - if {$opts(newconsole) && $opts(detached)} { - error "Options -newconsole and -detached cannot be specified together" - } - if {$opts(sharedvdm) && $opts(separatevdm)} { - error "Options -sharedvdm and -separatevdm cannot be specified together" - } - - # Create the start up info structure - set si_flags 0 - if {[info exists opts(windowpos)]} { - lassign [_parse_integer_pair $opts(windowpos)] xpos ypos - setbits si_flags 0x4 - } else { - set xpos 0 - set ypos 0 - } - if {[info exists opts(windowsize)]} { - lassign [_parse_integer_pair $opts(windowsize)] xsize ysize - setbits si_flags 0x2 - } else { - set xsize 0 - set ysize 0 - } - if {[info exists opts(screenbuffersize)]} { - lassign [_parse_integer_pair $opts(screenbuffersize)] xscreen yscreen - setbits si_flags 0x8 - } else { - set xscreen 0 - set yscreen 0 - } - - set fg 7; # Default to white - set bg 0; # Default to black - if {[info exists opts(foreground)]} { - set fg [_map_console_color $opts(foreground) 0] - setbits si_flags 0x10 - } - if {[info exists opts(background)]} { - set bg [_map_console_color $opts(background) 1] - setbits si_flags 0x10 - } - - set si_flags [expr {$si_flags | - $opts(feedbackcursoron) | $opts(feedbackcursoroff) | - $opts(fullscreen)}] - - switch -exact -- $opts(showwindow) { - "" {set opts(showwindow) 1 } - hidden {set opts(showwindow) 0} - normal {set opts(showwindow) 1} - minimized {set opts(showwindow) 2} - maximized {set opts(showwindow) 3} - default {error "Invalid value '$opts(showwindow)' for -showwindow option"} - } - if {[string length $opts(showwindow)]} { - setbits si_flags 0x1 - } - - if {[llength $opts(stdhandles)] && [llength $opts(stdchannels)]} { - error "Options -stdhandles and -stdchannels cannot be used together" - } - - if {[llength $opts(stdhandles)]} { - if {! $opts(inherithandles)} { - error "Cannot specify -stdhandles option if option -inherithandles is specified as 0" - } - - setbits si_flags 0x100 - } - - # Figure out process creation flags - # 0x400 -> CREATE_UNICODE_ENVIRONMENT - set flags [expr {0x00000400 | - $opts(createsuspended) | $opts(debugchildtree) | - $opts(debugchild) | $opts(detached) | $opts(newconsole) | - $opts(newprocessgroup) | $opts(separatevdm) | - $opts(sharedvdm) | $opts(inheriterrormode) | - $opts(noconsole) }] - - switch -exact -- $opts(priority) { - normal {set priority 0x00000020} - abovenormal {set priority 0x00008000} - belownormal {set priority 0x00004000} - "" {set priority 0} - high {set priority 0x00000080} - realtime {set priority 0x00000100} - idle {set priority 0x00000040} - default {error "Unknown priority '$priority'"} - } - set flags [expr {$flags | $priority}] - - # Create the environment strings - if {[llength $opts(env)]} { - set child_env [list ] - foreach {envvar envval} $opts(env) { - lappend child_env "$envvar=$envval" - } - } else { - set child_env "__null__" - } - - trap { - # This is inside the trap because duplicated handles have - # to be closed. - if {[llength $opts(stdchannels)]} { - if {! $opts(inherithandles)} { - error "Cannot specify -stdhandles option if option -inherithandles is specified as 0" - } - if {[llength $opts(stdchannels)] != 3} { - error "Must specify 3 channels for -stdchannels option corresponding stdin, stdout and stderr" - } - - setbits si_flags 0x100 - - # Convert the channels to handles - lappend opts(stdhandles) [duplicate_handle [get_tcl_channel_handle [lindex $opts(stdchannels) 0] read] -inherit] - lappend opts(stdhandles) [duplicate_handle [get_tcl_channel_handle [lindex $opts(stdchannels) 1] write] -inherit] - lappend opts(stdhandles) [duplicate_handle [get_tcl_channel_handle [lindex $opts(stdchannels) 2] write] -inherit] - } - - set startup [list $opts(desktop) $opts(title) $xpos $ypos \ - $xsize $ysize $xscreen $yscreen \ - [expr {$fg|$bg}] $si_flags $opts(showwindow) \ - $opts(stdhandles)] - - if {[info exists opts(token)]} { - lassign [CreateProcessAsUser $opts(token) [file nativename $path] \ - $opts(cmdline) \ - $process_sec_attr $thread_sec_attr \ - $opts(inherithandles) $flags $child_env \ - [file normalize $opts(startdir)] $startup \ - ] ph th pid tid - - } else { - lassign [CreateProcess [file nativename $path] \ - $opts(cmdline) \ - $process_sec_attr $thread_sec_attr \ - $opts(inherithandles) $flags $child_env \ - [file normalize $opts(startdir)] $startup \ - ] ph th pid tid - } - } finally { - # If opts(stdchannels) is not an empty list, we duplicated the handles - # into opts(stdhandles) ourselves so free them - if {[llength $opts(stdchannels)]} { - # Free corresponding handles in opts(stdhandles) - close_handles $opts(stdhandles) - } - } - - # From the Tcl source code - (tclWinPipe.c) - # /* - # * "When an application spawns a process repeatedly, a new thread - # * instance will be created for each process but the previous - # * instances may not be cleaned up. This results in a significant - # * virtual memory loss each time the process is spawned. If there - # * is a WaitForInputIdle() call between CreateProcess() and - # * CloseHandle(), the problem does not occur." PSS ID Number: Q124121 - # */ - # WaitForInputIdle $ph 5000 -- Apparently this is only needed for NT 3.5 - - - if {$opts(returnhandles)} { - return [list $pid $tid $ph $th] - } else { - CloseHandle $th - CloseHandle $ph - return [list $pid $tid] - } -} - -# Wait until the process is ready -proc twapi::process_waiting_for_input {pid args} { - array set opts [parseargs args { - {wait.int 0} - } -maxleftover 0] - - if {$pid == [pid]} { - variable my_process_handle - return [WaitForInputIdle $my_process_handle $opts(wait)] - } - - set hpid [get_process_handle $pid] - trap { - return [WaitForInputIdle $hpid $opts(wait)] - } finally { - CloseHandle $hpid - } -} - - - -# Get a handle to a process -proc twapi::get_process_handle {pid args} { - # OpenProcess masks off the bottom two bits thereby converting - # an invalid pid to a real one. - if {(![string is integer -strict $pid]) || ($pid & 3)} { - win32_error 87 "Invalid PID '$pid'."; # "The parameter is incorrect" - } - array set opts [parseargs args { - {access.arg process_query_information} - {inherit.bool 0} - } -maxleftover 0] - return [OpenProcess [_access_rights_to_mask $opts(access)] $opts(inherit) $pid] -} - -# Return true if passed pid is system -proc twapi::is_system_pid {pid} { - # Note Windows 2000 System PID was 8 but we no longer support it. - return [expr {$pid == 4}] -} - -# Return true if passed pid is of idle process -proc twapi::is_idle_pid {pid} { - return [expr {$pid == 0}] -} - -# Get my process id -proc twapi::get_current_process_id {} { - return [::pid] -} - -# Get my thread id -proc twapi::get_current_thread_id {} { - return [GetCurrentThreadId] -} - -# Get the exit code for a process. Returns "" if still running. -proc twapi::get_process_exit_code {hpid} { - set code [GetExitCodeProcess $hpid] - return [expr {$code == 259 ? "" : $code}] -} - -# Return list of process ids -# Note if -path or -name is specified, then processes for which this -# information cannot be obtained are skipped -proc twapi::get_process_ids {args} { - - set save_args $args; # Need to pass to process_exists - array set opts [parseargs args { - user.arg - path.arg - name.arg - logonsession.arg - glob} -maxleftover 0] - - if {[info exists opts(path)] && [info exists opts(name)]} { - error "Options -path and -name are mutually exclusive" - } - - if {$opts(glob)} { - set match_op ~ - } else { - set match_op eq - } - - # If we do not care about user or path, Twapi_GetProcessList - # is faster than EnumProcesses or the WTS functions - if {[info exists opts(user)] == 0 && - [info exists opts(logonsession)] == 0 && - [info exists opts(path)] == 0} { - if {[info exists opts(name)] == 0} { - return [Twapi_GetProcessList -1 0] - } - # We need to match against the name - return [recordarray column [Twapi_GetProcessList -1 2] -pid \ - -filter [list [list "-name" $match_op $opts(name) -nocase]]] - } - - # Only want pids with a specific user or path or logon session - - # If is the name we are looking for, try using the faster WTS - # API's first. If they are not available, we try a slower method - # If we need to match paths or logon sessions, we don't try this - # at all as the wts api's don't provide that info - if {[info exists opts(path)] == 0 && - [info exists opts(logonsession)] == 0} { - if {![info exists opts(user)]} { - # How did we get here? - error "Internal error - option -user not specified where expected" - } - if {[catch {map_account_to_sid $opts(user)} sid]} { - # No such user. Return empty list (no processes) - return [list ] - } - - if {[info exists opts(name)]} { - set filter_expr [list [list pUserSid eq $sid -nocase] [list pProcessName $match_op $opts(name) -nocase]] - } else { - set filter_expr [list [list pUserSid eq $sid -nocase]] - } - - # Catch failures so we can try other means - if {! [catch {recordarray column [WTSEnumerateProcesses NULL] \ - ProcessId -filter $filter_expr} wtslist]} { - return $wtslist - } - } - - set process_pids [list ] - - - # Either we are matching on path/logonsession, or the WTS call failed - # Try yet another way. - - # Note that in the code below, we use "file join" with a single arg - # to convert \ to /. Do not use file normalize as that will also - # land up converting relative paths to full paths - if {[info exists opts(path)]} { - set opts(path) [file join $opts(path)] - } - - set process_pids [list ] - if {[info exists opts(name)]} { - # Note we may reach here if the WTS call above failed - set all_pids [recordarray column [Twapi_GetProcessList -1 2] ProcessId -filter [list [list ProcessName $match_op $opts(name) -nocase]]] - } else { - set all_pids [Twapi_GetProcessList -1 0] - } - - set filter_expr {} - set popts [list ] - if {[info exists opts(path)]} { - lappend popts -path - lappend filter_expr [list -path $match_op $opts(path) -nocase] - } - - if {[info exists opts(user)]} { - lappend popts -user - lappend filter_expr [list -user eq $opts(user) -nocase] - } - if {[info exists opts(logonsession)]} { - lappend popts -logonsession - lappend filter_expr [list -logonsession eq $opts(logonsession) -nocase] - } - - - set matches [recordarray get [get_multiple_process_info -matchpids $all_pids {*}$popts] -filter $filter_expr] - return [recordarray column $matches -pid] -} - -proc twapi::get_process_memory_info {{pid {}}} { - variable my_process_handle - - if {$pid eq "" || $pid == [pid]} { - set hpid $my_process_handle - } else { - set hpid [get_process_handle $pid -access {process_query_information process_vm_read}] - } - - try { - # Note: -pagefileusage and -privateusage are same according to SDK. - # However for Win7 and earlier, -pagefileusage is always set to 0. - # We return what was given and not try to fix it up. - return [twine { - -pagefaults -workingsetpeak -workingset - -poolpagedbytespeak -poolpagedbytes - -poolnonpagedbytespeak -poolnonpagedbytes - -pagefilebytes -pagefilebytespeak -privatebytes - } [GetProcessMemoryInfo $hpid]] - } finally { - if {$hpid != $my_process_handle} { - CloseHandle $hpid - } - } -} - -# Return list of modules handles for a process -proc twapi::get_process_modules {pid args} { - variable my_process_handle - - array set opts [parseargs args {handle name path base size entry all}] - - if {$opts(all)} { - foreach opt {handle name path base size entry} { - set opts($opt) 1 - } - } - set noopts [expr {($opts(name) || $opts(path) || $opts(base) || $opts(size) || $opts(entry) || $opts(handle)) == 0}] - - if {! $noopts} { - # Returning a record array - set fields {} - # ORDER MUST be same a value order below - foreach opt {handle name path base size entry} { - if {$opts($opt)} { - lappend fields -$opt - } - } - - } - - if {$pid == [pid]} { - set hpid $my_process_handle - } else { - set hpid [get_process_handle $pid -access {process_query_information process_vm_read}] - } - - set results [list ] - trap { - foreach module [EnumProcessModules $hpid] { - if {$noopts} { - lappend results $module - continue - } - set rec {} - if {$opts(handle)} { - lappend rec $module - } - if {$opts(name)} { - if {[catch {GetModuleBaseName $hpid $module} name]} { - set name "" - } - lappend rec $name - } - if {$opts(path)} { - if {[catch {GetModuleFileNameEx $hpid $module} path]} { - set path "" - } - lappend rec [_normalize_path $path] - } - if {$opts(base) || $opts(size) || $opts(entry)} { - if {[catch {GetModuleInformation $hpid $module} imagedata]} { - set base "" - set size "" - set entry "" - } else { - lassign $imagedata base size entry - } - foreach opt {base size entry} { - if {$opts($opt)} { - lappend rec [set $opt] - } - } - } - lappend results $rec - } - } finally { - if {$hpid != $my_process_handle} { - CloseHandle $hpid - } - } - - if {$noopts} { - return $results - } else { - return [list $fields $results] - } -} - - -# Kill a process -# Returns 1 if process was ended, 0 if not ended within timeout -proc twapi::end_process {pid args} { - - if {$pid == [pid]} { - error "The passed PID is the PID of the current process. end_process cannot be used to commit suicide." - } - - array set opts [parseargs args { - {exitcode.int 1} - force - {wait.int 0} - }] - - # In order to verify the process is really gone, we open the process - # if possible and then wait on its handle. If access restrictions prevent - # us from doing so, we ignore the issue and will simply check for the - # the PID later (which is not a sure check since PID's can be reused - # immediately) - catch {set hproc [get_process_handle $pid -access synchronize]} - - # First try to close nicely. We need to send messages to toplevels - # as well as message-only windows. We could make use of get_toplevel_windows - # and find_windows but those would require pulling in the whole - # twapi_ui package so do it ourselves. - set toplevels {} - foreach toplevel [EnumWindows] { - # Check if it belongs to pid. Errors are ignored, we simply - # will not send a message to that window - catch { - if {[lindex [GetWindowThreadProcessId $toplevel] 1] == $pid} { - lappend toplevels $toplevel - } - } - } - # Repeat for message only windows as EnumWindows skips them - set prev 0 - while {1} { - # Again, errors are ignored - # -3 -> HWND_MESSAGE windows - if {[catch { - set toplevel [FindWindowEx [list -3 HWND] $prev "" ""] - }]} { - break - } - if {[pointer_null? $toplevel]} break - catch { - if {[lindex [GetWindowThreadProcessId $toplevel] 1] == $pid} { - lappend toplevels $toplevel - } - } - set prev $toplevel - } - - if {[llength $toplevels]} { - # Try and close by sending them a message. WM_CLOSE is 0x10 - foreach toplevel $toplevels { - # Send a message but come back right away - # See Bug #139 as to why PostMessage instead of SendNotifyMessage - catch {PostMessage $toplevel 0x10 0 0} - } - - # Wait for the specified time to verify process has gone away - if {[info exists hproc]} { - set status [WaitForSingleObject $hproc $opts(wait)] - CloseHandle $hproc - set gone [expr {! $status}] - } else { - # We could not get a process handle to wait on, just check if - # PID still exists. This COULD be a false positive... - set gone [twapi::wait {process_exists $pid} 0 $opts(wait)] - } - if {$gone || ! $opts(force)} { - # Succeeded or do not want to force a kill - return $gone - } - - # Only wait 10 ms since we have already waited above - if {$opts(wait)} { - set opts(wait) 10 - } - } - - # Open the process for terminate access. IF access denied (5), retry after - # getting the required privilege - trap { - set hproc [get_process_handle $pid -access {synchronize process_terminate}] - } onerror {TWAPI_WIN32 5} { - # Retry - if still fail, then just throw the error - eval_with_privileges { - set hproc [get_process_handle $pid -access {synchronize process_terminate}] - } SeDebugPrivilege - } onerror {TWAPI_WIN32 87} { - # Process does not exist, we must have succeeded above but just - # took a bit longer for it to exit - return 1 - } - - trap { - TerminateProcess $hproc $opts(exitcode) - set status [WaitForSingleObject $hproc $opts(wait)] - if {$status == 0} { - return 1 - } - } finally { - CloseHandle $hproc - } - - return 0 -} - -# Get the path of a process -proc twapi::get_process_path {pid args} { - return [twapi::_get_process_name_path_helper $pid path {*}$args] -} - -# Get the path of a process -proc twapi::get_process_name {pid args} { - return [twapi::_get_process_name_path_helper $pid name {*}$args] -} - - -# Return list of device drivers -proc twapi::get_device_drivers {args} { - array set opts [parseargs args {name path base all}] - - set fields {} - # Order MUST be same as order of values below - foreach opt {base name path} { - if {$opts($opt) || $opts(all)} { - lappend fields -$opt - } - } - - set results [list ] - foreach module [EnumDeviceDrivers] { - unset -nocomplain rec - if {$opts(base) || $opts(all)} { - lappend rec $module - } - if {$opts(name) || $opts(all)} { - if {[catch {GetDeviceDriverBaseName $module} name]} { - set name "" - } - lappend rec $name - } - if {$opts(path) || $opts(all)} { - if {[catch {GetDeviceDriverFileName $module} path]} { - set path "" - } - lappend rec [_normalize_path $path] - } - if {[info exists rec]} { - lappend results $rec - } - } - - return [list $fields $results] -} - -# Check if the given process exists -# 0 - does not exist or exists but paths/names do not match, -# 1 - exists and matches path (or no -path or -name specified) -# -1 - exists but do not know path and cannot compare -proc twapi::process_exists {pid args} { - array set opts [parseargs args { path.arg name.arg glob}] - - # Simplest case - don't care about name or path - if {! ([info exists opts(path)] || [info exists opts(name)])} { - if {$pid == [pid]} { - return 1 - } - # TBD - would it be faster to do OpenProcess ? If success or - # access denied, process exists. - - if {[llength [Twapi_GetProcessList $pid 0]] == 0} { - return 0 - } else { - return 1 - } - } - - # Can't specify both name and path - if {[info exists opts(path)] && [info exists opts(name)]} { - error "Options -path and -name are mutually exclusive" - } - - if {$opts(glob)} { - set string_cmd match - } else { - set string_cmd equal - } - - if {[info exists opts(name)]} { - # Name is specified - set pidlist [Twapi_GetProcessList $pid 2] - if {[llength $pidlist] == 0} { - return 0 - } - return [string $string_cmd -nocase $opts(name) [lindex $pidlist 1 0 1]] - } - - # Need to match on the path - set process_path [get_process_path $pid -noexist "" -noaccess "(unknown)"] - if {[string length $process_path] == 0} { - # No such process - return 0 - } - - # Process with this pid exists - # Path still has to match - if {[string equal $process_path "(unknown)"]} { - # Exists but cannot check path/name - return -1 - } - - # Note we do not use file normalize here since that will tack on - # absolute paths which we do not want for glob matching - - # We use [file join ] to convert \ to / to avoid special - # interpretation of \ in string match command - return [string $string_cmd -nocase [file join $opts(path)] [file join $process_path]] -} - -# Get the parent process of a thread. Return "" if no such thread -proc twapi::get_thread_parent_process_id {tid} { - set status [catch { - set th [get_thread_handle $tid] - trap { - set pid [lindex [lindex [Twapi_NtQueryInformationThreadBasicInformation $th] 2] 0] - } finally { - CloseHandle $th - } - }] - - if {$status == 0} { - return $pid - } - - - # Could not use undocumented function. Try slooooow perf counter method - set pid_paths [get_perf_thread_counter_paths $tid -pid] - if {[llength $pid_paths] == 0} { - return "" - } - - if {[pdh_counter_path_value [lindex [lindex $pid_paths 0] 3] -var pid]} { - return $pid - } else { - return "" - } -} - -# Get the thread ids belonging to a process -proc twapi::get_process_thread_ids {pid} { - return [recordarray cell [get_multiple_process_info -matchpids [list $pid] -tids] 0 -tids] -} - - -# Get process information -proc twapi::get_process_info {pid args} { - # To avert a common mistake where pid is unspecified, use current pid - # so [get_process_info -name] becomes [get_process_info [pid] -name] - # TBD - should this be documented ? - - if {![string is integer -strict $pid]} { - set args [linsert $args 0 $pid] - set pid [pid] - } - - set rec [recordarray index [get_multiple_process_info {*}$args -matchpids [list $pid]] 0 -format dict] - if {"-pid" ni $args && "-all" ni $args} { - dict unset rec -pid - } - return $rec -} - - -# Get multiple process information -# TBD - document and write tests -proc twapi::get_multiple_process_info {args} { - - # Options that are directly available from Twapi_GetProcessList - # Dict value is the flags to pass to Twapi_GetProcessList - set base_opts { - basepriority 1 - parent 1 tssession 1 - name 2 - createtime 4 usertime 4 - privilegedtime 4 handlecount 4 - threadcount 4 - pagefaults 8 pagefilebytes 8 - pagefilebytespeak 8 poolnonpagedbytes 8 - poolnonpagedbytespeak 8 poolpagedbytes 8 - poolpagedbytespeak 8 virtualbytes 8 - virtualbytespeak 8 workingset 8 - workingsetpeak 8 - ioreadops 16 iowriteops 16 - iootherops 16 ioreadbytes 16 - iowritebytes 16 iootherbytes 16 - } - # Options that also dependent on Twapi_GetProcessList but not - # directly available - set base_calc_opts { elapsedtime 4 tids 32 } - - # Note -user is also a potential token opt but not listed below - # because it can be gotten by other means - set token_opts { - disabledprivileges elevation enabledprivileges groupattrs groups groupsids - integrity integritylabel logonsession primarygroup primarygroupsid - privileges restrictedgroupattrs restrictedgroups virtualized - } - - set optdefs [lconcat {all pid user path commandline priorityclass {noexist.arg {(no such process)}} {noaccess.arg {(unknown)}} matchpids.arg} \ - [dict keys $base_opts] \ - [dict keys $base_calc_opts] \ - $token_opts] - array set opts [parseargs args $optdefs -maxleftover 0] - set opts(pid) 1; # Always return pid, -pid option is for backward compat - - if {[info exists opts(matchpids)]} { - set pids $opts(matchpids) - } else { - set pids [Twapi_GetProcessList -1 0] - } - - set now [get_system_time] - - # We will return a record array. $records tracks a dict of record - # values keyed by pid, $fields tracks the names in the list elements - # [llength $fields] == [llength [lindex $records *]] - set records {} - set fields {} - - # If user is requested, try getting it through terminal services - # if possible since the token method fails on some newer platforms - if {$opts(all) || $opts(user)} { - _get_wts_pids wtssids wtsnames - } - - # See if any Twapi_GetProcessList options are requested and if - # so, calculate the appropriate flags - set baseflags 0 - set basenoexistvals {} - dict for {opt flag} $base_opts { - if {$opts($opt) || $opts(all)} { - set baseflags [expr {$baseflags | $flag}] - lappend basefields -$opt - lappend basenoexistvals $opts(noexist) - } - } - dict for {opt flag} $base_calc_opts { - if {$opts($opt) || $opts(all)} { - set baseflags [expr {$baseflags | $flag}] - } - } - - # See if we need to retrieve any base options - if {$baseflags} { - set pidarg [expr {[llength $pids] == 1 ? [lindex $pids 0] : -1}] - set data [twapi::Twapi_GetProcessList $pidarg [expr {$baseflags|1}]] - if {$opts(all) || $opts(elapsedtime) || $opts(tids)} { - array set baserawdata [recordarray getdict $data -key "-pid" -format dict] - } - if {[info exists basefields]} { - set fields $basefields - set records [recordarray getdict $data -slice $basefields -key "-pid"] - } - } - if {$opts(pid)} { - lappend fields -pid - } - foreach pid $pids { - # If base values were requested, but this pid does not exist - # use the "noexist" values - if {![dict exists $records $pid]} { - dict set records $pid $basenoexistvals - } - if {$opts(pid)} { - dict lappend records $pid $pid - } - } - - # If all we need are baseline options, and no massaging is required - # (as for elapsedtime, for example), we can return what we have - # without looping through below. Saves significant time. - set done 1 - foreach opt [list all user elapsedtime tids path commandline priorityclass \ - {*}$token_opts] { - if {$opts($opt)} { - set done 0 - break - } - } - - if {$done} { - set return_data {} - foreach pid $pids { - lappend return_data [dict get $records $pid] - } - return [list $fields $return_data] - } - - set requested_token_opts {} - foreach opt $token_opts { - if {$opts(all) || $opts($opt)} { - lappend requested_token_opts -$opt - } - } - - if {$opts(elapsedtime) || $opts(all)} { - lappend fields -elapsedtime - foreach pid $pids { - if {[info exists baserawdata($pid)]} { - set elapsed [twapi::kl_get $baserawdata($pid) -createtime] - if {$elapsed} { - # 100ns -> seconds - dict lappend records $pid [expr {($now-$elapsed)/10000000}] - } else { - # For some processes like, System and Idle, kernel - # returns start time of 0. Just use system uptime - if {![info exists system_uptime]} { - # Store locally so no refetch on each iteration - set system_uptime [get_system_uptime] - } - dict lappend records $pid $system_uptime - } - } else { - dict lappend records $pid $opts(noexist) - } - } - } - - if {$opts(tids) || $opts(all)} { - lappend fields -tids - foreach pid $pids { - if {[info exists baserawdata($pid)]} { - dict lappend records $pid [recordarray column [kl_get $baserawdata($pid) Threads] -tid] - } else { - dict lappend records $pid $opts(noexist) - } - } - } - - if {$opts(all) || $opts(path)} { - lappend fields -path - foreach pid $pids { - dict lappend records $pid [get_process_path $pid -noexist $opts(noexist) -noaccess $opts(noaccess)] - } - } - - if {$opts(all) || $opts(priorityclass)} { - lappend fields -priorityclass - foreach pid $pids { - trap { - set prioclass [get_priority_class $pid] - } onerror {TWAPI_WIN32 5} { - set prioclass $opts(noaccess) - } onerror {TWAPI_WIN32 87} { - set prioclass $opts(noexist) - } - dict lappend records $pid $prioclass - } - } - - if {$opts(all) || $opts(commandline)} { - lappend fields -commandline - foreach pid $pids { - dict lappend records $pid [get_process_commandline $pid -noexist $opts(noexist) -noaccess $opts(noaccess)] - } - } - - - if {$opts(all) || $opts(user) || [llength $requested_token_opts]} { - foreach pid $pids { - # Now get token related info, if any requested - # For returning as a record array, we have to be careful that - # each field is added in a specific order for every pid - # keeping in mind a different method might be used for different - # pids. So we collect the data in dictionary token_records and add - # at the end in a fixed order - set token_records {} - set requested_opts $requested_token_opts - unset -nocomplain user - if {$opts(all) || $opts(user)} { - # See if we already have the user. Note sid of system idle - # will be empty string - if {[info exists wtssids($pid)]} { - if {$wtssids($pid) == ""} { - # Put user as System - set user SYSTEM - } else { - # We speed up account lookup by caching sids - if {[info exists sidcache($wtssids($pid))]} { - set user $sidcache($wtssids($pid)) - } else { - set user [lookup_account_sid $wtssids($pid)] - set sidcache($wtssids($pid)) $user - } - } - } else { - lappend requested_opts -user - } - } - - if {[llength $requested_opts]} { - trap { - dict set token_records $pid [_token_info_helper -pid $pid {*}$requested_opts] - } onerror {TWAPI_WIN32 5} { - foreach opt $requested_opts { - dict set token_records $pid $opt $opts(noaccess) - } - # The NETWORK SERVICE and LOCAL SERVICE processes cannot - # be accessed. If we are looking for the logon session for - # these, try getting it from the witssid if we have it - # since the logon session is hardcoded for these accounts - if {"-logonsession" in $requested_opts} { - if {![info exists wtssids]} { - _get_wts_pids wtssids wtsnames - } - if {[info exists wtssids($pid)]} { - # Map user SID to logon session - switch -exact -- $wtssids($pid) { - S-1-5-18 { - # SYSTEM - dict set token_records $pid -logonsession 00000000-000003e7 - } - S-1-5-19 { - # LOCAL SERVICE - dict set token_records $pid -logonsession 00000000-000003e5 - } - S-1-5-20 { - # LOCAL SERVICE - dict set token_records $pid -logonsession 00000000-000003e4 - } - } - } - } - - # Similarly, if we are looking for user account, special case - # system and system idle processes - if {"-user" in $requested_opts} { - if {[is_idle_pid $pid] || [is_system_pid $pid]} { - set user SYSTEM - } else { - set user $opts(noaccess) - } - } - - } onerror {TWAPI_WIN32 87} { - foreach opt $requested_opts { - if {$opt eq "-user"} { - if {[is_idle_pid $pid] || [is_system_pid $pid]} { - set user SYSTEM - } else { - set user $opts(noexist) - } - } else { - dict set token_records $pid $opt $opts(noexist) - } - } - } - } - # Now add token values in a specific order - MUST MATCH fields BELOW - if {$opts(all) || $opts(user)} { - # TBD - BUG - user is supposed to be set to *something* by this - # point but WiTS throws error every blue moon on this line that - # user is not defined. Workaround. - if {![info exists user]} { - set user $opts(noaccess) - } - dict lappend records $pid $user - } - foreach opt $requested_token_opts { - if {[dict exists $token_records $pid $opt]} { - dict lappend records $pid [dict get $token_records $pid $opt] - } - } - } - # Now add token field names in a specific order - MUST MATCH ABOVE - if {$opts(all) || $opts(user)} { - lappend fields -user - } - foreach opt $requested_token_opts { - if {[dict exists $token_records $pid $opt]} { - lappend fields $opt - } - } - } - - set return_data {} - foreach pid $pids { - lappend return_data [dict get $records $pid] - } - return [list $fields $return_data] -} - - - -# Get thread information -# TBD - add info from GetGUIThreadInfo -proc twapi::get_thread_info {tid args} { - # TBD - modify so tid is optional like for get_process_info - - # Options that are directly available from Twapi_GetProcessList - if {![info exists ::twapi::get_thread_info_base_opts]} { - # Array value is the flags to pass to Twapi_GetProcessList - array set ::twapi::get_thread_info_base_opts { - pid 32 - elapsedtime 96 - waittime 96 - usertime 96 - createtime 96 - privilegedtime 96 - contextswitches 96 - basepriority 160 - priority 160 - startaddress 160 - state 160 - waitreason 160 - } - } - - set token_opts { - user - primarygroup - primarygroupsid - groups - groupsids - restrictedgroups - groupattrs - restrictedgroupattrs - privileges - enabledprivileges - disabledprivileges - } - - array set opts [parseargs args \ - [concat [list all \ - relativepriority \ - tid \ - [list noexist.arg "(no such thread)"] \ - [list noaccess.arg "(unknown)"]] \ - [array names ::twapi::get_thread_info_base_opts] \ - $token_opts ]] - - set requested_opts [_array_non_zero_switches opts $token_opts $opts(all)] - # Now get token info, if any - if {[llength $requested_opts]} { - trap { - trap { - set results [_token_info_helper -tid $tid {*}$requested_opts] - } onerror {TWAPI_WIN32 1008} { - # Thread does not have its own token. Use it's parent process - set results [_token_info_helper -pid [get_thread_parent_process_id $tid] {*}$requested_opts] - } - } onerror {TWAPI_WIN32 5} { - # No access - foreach opt $requested_opts { - lappend results $opt $opts(noaccess) - } - } onerror {TWAPI_WIN32 87} { - # Thread does not exist - foreach opt $requested_opts { - lappend results $opt $opts(noexist) - } - } - - } else { - set results [list ] - } - - # Now get the base options - set flags 0 - foreach opt [array names ::twapi::get_thread_info_base_opts] { - if {$opts($opt) || $opts(all)} { - set flags [expr {$flags | $::twapi::get_thread_info_base_opts($opt)}] - } - } - - if {$flags} { - # We need at least one of the base options - foreach tdata [recordarray column [twapi::Twapi_GetProcessList -1 $flags] Threads] { - set tdict [recordarray getdict $tdata -key "-tid" -format dict] - if {[dict exists $tdict $tid]} { - array set threadinfo [dict get $tdict $tid] - break - } - } - # It is possible that we looped through all the processes without - # a thread match. Hence we check again that we have threadinfo for - # each option value - foreach opt { - pid - waittime - usertime - createtime - privilegedtime - basepriority - priority - startaddress - state - waitreason - contextswitches - } { - if {$opts($opt) || $opts(all)} { - if {[info exists threadinfo]} { - lappend results -$opt $threadinfo(-$opt) - } else { - lappend results -$opt $opts(noexist) - } - } - } - - if {$opts(elapsedtime) || $opts(all)} { - if {[info exists threadinfo(-createtime)]} { - lappend results -elapsedtime [expr {[clock seconds]-[large_system_time_to_secs $threadinfo(-createtime)]}] - } else { - lappend results -elapsedtime $opts(noexist) - } - } - } - - - if {$opts(all) || $opts(relativepriority)} { - trap { - lappend results -relativepriority [get_thread_relative_priority $tid] - } onerror {TWAPI_WIN32 5} { - lappend results -relativepriority $opts(noaccess) - } onerror {TWAPI_WIN32 87} { - lappend results -relativepriority $opts(noexist) - } - } - - if {$opts(all) || $opts(tid)} { - lappend results -tid $tid - } - - return $results -} - -# Get a handle to a thread -proc twapi::get_thread_handle {tid args} { - # OpenThread masks off the bottom two bits thereby converting - # an invalid tid to a real one. We do not want this. - if {$tid & 3} { - win32_error 87; # "The parameter is incorrect" - } - - array set opts [parseargs args { - {access.arg thread_query_information} - {inherit.bool 0} - }] - return [OpenThread [_access_rights_to_mask $opts(access)] $opts(inherit) $tid] -} - -# Suspend a thread -proc twapi::suspend_thread {tid} { - set htid [get_thread_handle $tid -access thread_suspend_resume] - trap { - set status [SuspendThread $htid] - } finally { - CloseHandle $htid - } - return $status -} - -# Resume a thread -proc twapi::resume_thread {tid} { - set htid [get_thread_handle $tid -access thread_suspend_resume] - trap { - set status [ResumeThread $htid] - } finally { - CloseHandle $htid - } - return $status -} - -# Get the command line for a process -proc twapi::get_process_commandline {pid args} { - - if {[is_system_pid $pid] || [is_idle_pid $pid]} { - return "" - } - - array set opts [parseargs args { - {noexist.arg "(no such process)"} - {noaccess.arg "(unknown)"} - }] - - trap { - # Assume max command line len is 1024 chars (2048 bytes) - trap { - set hpid [get_process_handle $pid -access {process_query_information process_vm_read}] - } onerror {TWAPI_WIN32 87} { - # Process does not exist - return $opts(noexist) - } - - # Get the address where the PEB is stored - see Nebbett - set peb_addr [lindex [Twapi_NtQueryInformationProcessBasicInformation $hpid] 1] - - # Read the PEB as binary - # The pointer to the process parameter block is the 5th pointer field. - # The struct looks like: - # 32 bit - - # typedef struct _PEB { - # BYTE Reserved1[2]; - # BYTE BeingDebugged; - # BYTE Reserved2[1]; - # PVOID Reserved3[2]; - # PPEB_LDR_DATA Ldr; - # PRTL_USER_PROCESS_PARAMETERS ProcessParameters; - # BYTE Reserved4[104]; - # PVOID Reserved5[52]; - # PPS_POST_PROCESS_INIT_ROUTINE PostProcessInitRoutine; - # BYTE Reserved6[128]; - # PVOID Reserved7[1]; - # ULONG SessionId; - # } PEB, *PPEB; - # 64 bit - - # typedef struct _PEB { - # BYTE Reserved1[2]; - # BYTE BeingDebugged; - # BYTE Reserved2[21]; - # PPEB_LDR_DATA LoaderData; - # PRTL_USER_PROCESS_PARAMETERS ProcessParameters; - # BYTE Reserved3[520]; - # PPS_POST_PROCESS_INIT_ROUTINE PostProcessInitRoutine; - # BYTE Reserved4[136]; - # ULONG SessionId; - # } PEB; - # So in both cases the pointer is 4 pointers from the start - - if {[info exists ::tcl_platform(pointerSize)]} { - set pointer_size $::tcl_platform(pointerSize) - } else { - set pointer_size 4 - } - if {$pointer_size == 4} { - set pointer_scanner n - } else { - set pointer_scanner m - } - set mem [ReadProcessMemory $hpid [expr {$peb_addr+(4*$pointer_size)}] $pointer_size] - if {![binary scan $mem $pointer_scanner proc_param_addr]} { - error "Could not read PEB of process $pid" - } - - # Now proc_param_addr contains the address of the Process parameter - # structure which looks like: - # typedef struct _RTL_USER_PROCESS_PARAMETERS { - # Offsets: x86 x64 - # BYTE Reserved1[16]; 0 0 - # PVOID Reserved2[10]; 16 16 - # UNICODE_STRING ImagePathName; 56 96 - # UNICODE_STRING CommandLine; 64 112 - # } RTL_USER_PROCESS_PARAMETERS, *PRTL_USER_PROCESS_PARAMETERS; - # UNICODE_STRING is defined as - # typedef struct _UNICODE_STRING { - # USHORT Length; - # USHORT MaximumLength; - # PWSTR Buffer; - # } UNICODE_STRING; - - # Note - among twapi supported builds, tcl_platform(pointerSize) - # not existing implies 32-bits - if {[info exists ::tcl_platform(pointerSize)] && - $::tcl_platform(pointerSize) == 8} { - # Read the CommandLine field - set mem [ReadProcessMemory $hpid [expr {$proc_param_addr + 112}] 16] - if {![binary scan $mem tutunum cmdline_bytelen cmdline_bufsize unused cmdline_addr]} { - error "Could not get address of command line" - } - } else { - # Read the CommandLine field - set mem [ReadProcessMemory $hpid [expr {$proc_param_addr + 64}] 8] - if {![binary scan $mem tutunu cmdline_bytelen cmdline_bufsize cmdline_addr]} { - error "Could not get address of command line" - } - } - - if {1} { - if {$cmdline_bytelen == 0} { - set cmdline "" - } else { - trap { - set mem [ReadProcessMemory $hpid $cmdline_addr $cmdline_bytelen] - } onerror {TWAPI_WIN32 299} { - # ERROR_PARTIAL_COPY - # Rumour has it this can be a transient error if the - # process is initializing, so try once more - Sleep 0; # Relinquish control to OS to run other process - # Retry - set mem [ReadProcessMemory $hpid $cmdline_addr $cmdline_bytelen] - } - } - } else { - THIS CODE NEEDS TO BE MODIFIED IF REINSTATED. THE ReadProcessMemory - parameters have changed - # Old pre-2.3 code - # Now read the command line itself. We do not know the length - # so assume MAX_PATH (1024) chars (2048 bytes). However, this may - # fail if the memory beyond the command line is not allocated in the - # target process. So we have to check for this error and retry with - # smaller read sizes - set max_len 2048 - while {$max_len > 128} { - trap { - ReadProcessMemory $hpid $cmdline_addr $pgbl $max_len - break - } onerror {TWAPI_WIN32 299} { - # Reduce read size - set max_len [expr {$max_len / 2}] - } - } - # OK, got something. It's in Unicode format, may not be null terminated - # or may have multiple null terminated strings. THe command line - # is the first string. - } - set cmdline [encoding convertfrom unicode $mem] - set null_offset [string first "\0" $cmdline] - if {$null_offset >= 0} { - set cmdline [string range $cmdline 0 [expr {$null_offset-1}]] - } - - } onerror {TWAPI_WIN32 5} { - # Access denied - set cmdline $opts(noaccess) - } onerror {TWAPI_WIN32 299} { - # Only part of the Read* could be completed - # Access denied - set cmdline $opts(noaccess) - } onerror {TWAPI_WIN32 87} { - # The parameter is incorrect - # Access denied (or should it be noexist?) - set cmdline $opts(noaccess) - } finally { - if {[info exists hpid]} { - CloseHandle $hpid - } - } - - return $cmdline -} - - -# Get process parent - can return "" -proc twapi::get_process_parent {pid args} { - array set opts [parseargs args { - {noexist.arg "(no such process)"} - {noaccess.arg "(unknown)"} - }] - - if {[is_system_pid $pid] || [is_idle_pid $pid]} { - return "" - } - - trap { - set parent [recordarray cell [twapi::Twapi_GetProcessList $pid 1] 0 InheritedFromProcessId] - if {$parent ne ""} { - return $parent - } - } onerror {} { - # Just try the other methods below - } - - trap { - set hpid [get_process_handle $pid] - return [lindex [Twapi_NtQueryInformationProcessBasicInformation $hpid] 5] - - } onerror {TWAPI_WIN32 5} { - set error noaccess - } onerror {TWAPI_WIN32 87} { - set error noexist - } finally { - if {[info exists hpid]} { - CloseHandle $hpid - } - } - - return $opts($error) -} - -# Get the base priority class of a process -proc twapi::get_priority_class {pid} { - set ph [get_process_handle $pid] - trap { - return [GetPriorityClass $ph] - } finally { - CloseHandle $ph - } -} - -# Get the base priority class of a process -proc twapi::set_priority_class {pid priority} { - if {$pid == [pid]} { - variable my_process_handle - SetPriorityClass $my_process_handle $priority - return - } - - set ph [get_process_handle $pid -access process_set_information] - trap { - SetPriorityClass $ph $priority - } finally { - CloseHandle $ph - } -} - -# Get the priority of a thread -proc twapi::get_thread_relative_priority {tid} { - set h [get_thread_handle $tid] - trap { - return [GetThreadPriority $h] - } finally { - CloseHandle $h - } -} - -# Set the priority of a thread -proc twapi::set_thread_relative_priority {tid priority} { - switch -exact -- $priority { - abovenormal { set priority 1 } - belownormal { set priority -1 } - highest { set priority 2 } - idle { set priority -15 } - lowest { set priority -2 } - normal { set priority 0 } - timecritical { set priority 15 } - default { - if {![string is integer -strict $priority]} { - error "Invalid priority value '$priority'." - } - } - } - - set h [get_thread_handle $tid -access thread_set_information] - trap { - SetThreadPriority $h $priority - } finally { - CloseHandle $h - } -} - -# Return type of process elevation -proc twapi::get_process_elevation {args} { - lappend args -elevation - return [lindex [_token_info_helper $args] 1] -} - -# Return integrity level of process -proc twapi::get_process_integrity {args} { - lappend args -integrity - return [lindex [_token_info_helper $args] 1] -} - -# Return whether a process is running under WoW64 -proc twapi::wow64_process {args} { - array set opts [parseargs args { - pid.arg - hprocess.arg - } -maxleftover 0] - - if {[info exists opts(hprocess)]} { - if {[info exists opts(pid)]} { - error "Options -pid and -hprocess cannot be used together." - } - return [IsWow64Process $opts(hprocess)] - } - - if {[info exists opts(pid)] && $opts(pid) != [pid]} { - trap { - set hprocess [get_process_handle $opts(pid)] - return [IsWow64Process $hprocess] - } finally { - if {[info exists hprocess]} { - CloseHandle $hprocess - } - } - } - - # Common case - checking about ourselves - variable my_process_handle - return [IsWow64Process $my_process_handle] -} - -# Check whether a process is virtualized -proc twapi::virtualized_process {args} { - lappend args -virtualized - return [lindex [_token_info_helper $args] 1] -} - -proc twapi::set_process_integrity {level args} { - lappend args -integrity $level - _token_set_helper $args -} - -proc twapi::set_process_virtualization {enable args} { - lappend args -virtualized $enable - _token_set_helper $args -} - -# Map a process handle to its pid -proc twapi::get_pid_from_handle {hprocess} { - return [lindex [Twapi_NtQueryInformationProcessBasicInformation $hprocess] 4] -} - -# Check if current process is an administrative process or not -proc twapi::process_in_administrators {} { - - # Administrators group SID - S-1-5-32-544 - - if {[get_process_elevation] ne "limited"} { - return [CheckTokenMembership NULL S-1-5-32-544] - } - - # When running as with a limited token under UAC, we cannot check - # if the process is in administrators group or not since the group - # will be disabled in the token. Rather, we need to get the linked - # token (which is unfiltered) and check that. - set tok [lindex [_token_info_helper -linkedtoken] 1] - trap { - return [CheckTokenMembership $tok S-1-5-32-544] - } finally { - close_token $tok - } -} - -# Get a module handle -proc twapi::get_module_handle {args} { - array set opts [parseargs args { - path.arg - pin.bool - } -nulldefault -maxleftover 0] - - return [GetModuleHandleEx $opts(pin) [file nativename $opts(path)]] -} - -# Get a module handle from an address -proc twapi::get_module_handle_from_address {addr args} { - array set opts [parseargs args { - pin.bool - } -nulldefault -maxleftover 0] - - return [GetModuleHandleEx [expr {$opts(pin) ? 5 : 4}] $addr] -} - - -proc twapi::load_user_profile {token args} { - # PI_NOUI -> 0x1 - parseargs args { - username.arg - {noui.bool 0 0x1} - defaultuserpath.arg - servername.arg - roamingprofilepath.arg - } -maxleftover 0 -setvars -nulldefault - - if {$username eq ""} { - set username [get_token_user $token -name] - } - - return [eval_with_privileges { - LoadUserProfile [list $token $noui $username $roamingprofilepath $defaultuserpath $servername] - } {SeRestorePrivilege SeBackupPrivilege}] -} - -# TBD - document -proc twapi::get_profile_type {} { - return [dict* {0 local 1 temporary 2 roaming 4 mandatory} [GetProfileType]] -} - - -proc twapi::_env_block_to_dict {block normalize} { - set env_dict {} - foreach env_str $block { - set pos [string first = $env_str] - set key [string range $env_str 0 $pos-1] - if {$normalize} { - set key [string toupper $key] - } - lappend env_dict $key [string range $env_str $pos+1 end] - } - return $env_dict -} - -proc twapi::get_system_environment_vars {args} { - parseargs args {normalize.bool} -nulldefault -setvars -maxleftover 0 - return [_env_block_to_dict [CreateEnvironmentBlock 0 0] $normalize] -} - -proc twapi::get_user_environment_vars {token args} { - parseargs args {inherit.bool normalize.bool} -nulldefault -setvars -maxleftover 0 - return [_env_block_to_dict [CreateEnvironmentBlock $token $inherit] $normalize] -} - -proc twapi::expand_system_environment_vars {s} { - return [ExpandEnvironmentStringsForUser 0 $s] -} - -proc twapi::expand_user_environment_vars {tok s} { - return [ExpandEnvironmentStringsForUser $tok $s] -} - -# -# Utility procedures - -# Get the path of a process -proc twapi::_get_process_name_path_helper {pid {type name} args} { - - if {$pid == [pid]} { - # It is our process! - set exe [info nameofexecutable] - if {$type eq "name"} { - return [file tail $exe] - } else { - return $exe - } - } - - array set opts [parseargs args { - {noexist.arg "(no such process)"} - {noaccess.arg "(unknown)"} - } -maxleftover 0] - - if {![string is integer $pid]} { - error "Invalid non-numeric pid $pid" - } - if {[is_system_pid $pid]} { - return "System" - } - if {[is_idle_pid $pid]} { - return "System Idle Process" - } - - # Try the quicker way if looking for a name - if {$type eq "name" && - ![catch { - Twapi_GetProcessList $pid 2 - } plist]} { - set name [lindex $plist 1 0 1] - if {$name ne ""} { - return $name - } - } - - # We first try using GetProcessImageFileName as that does not require - # the PROCESS_VM_READ privilege - if {[min_os_version 6 0]} { - set privs [list process_query_limited_information] - } else { - set privs [list process_query_information] - } - - trap { - set hprocess [get_process_handle $pid -access $privs] - set path [GetProcessImageFileName $hprocess] - if {$type eq "name"} { - return [file tail $path] - } - # Returned path is in native format, convert to win32 - return [normalize_device_rooted_path $path] - } onerror {TWAPI_WIN32 87} { - return $opts(noexist) - } onerror {} { - # Other errors, continue on to other methods - } finally { - if {[info exists hprocess]} { - twapi::close_handle $hprocess - } - } - - trap { - set hprocess [get_process_handle $pid -access {process_query_information process_vm_read}] - } onerror {TWAPI_WIN32 87} { - return $opts(noexist) - } onerror {TWAPI_WIN32 5} { - # Access denied - # If it is the name we want, first try WTS and if that - # fails try getting it from PDH (slowest) - - if {[string equal $type "name"]} { - if {! [catch {WTSEnumerateProcesses NULL} precords]} { - - return [lindex [recordarray column $precords pProcessName -filter [list [list ProcessId == $pid]]] 0] - } - - # That failed as well, try PDH. TBD - get rid of PDH - set pdh_path [lindex [lindex [twapi::get_perf_process_counter_paths [list $pid] -pid] 0] 3] - array set pdhinfo [pdh_parse_counter_path $pdh_path] - return $pdhinfo(instance) - } - return $opts(noaccess) - } - - trap { - set module [lindex [EnumProcessModules $hprocess] 0] - if {[string equal $type "name"]} { - set path [GetModuleBaseName $hprocess $module] - } else { - set path [_normalize_path [GetModuleFileNameEx $hprocess $module]] - } - } onerror {TWAPI_WIN32 5} { - # Access denied - # On win2k (and may be Win2k3), if the process has exited but some - # app still has a handle to the process, the OpenProcess succeeds - # but the EnumProcessModules call returns access denied. So - # check for this case - if {[min_os_version 5 0]} { - # Try getting exit code. 259 means still running. - # Anything else means process has terminated - if {[GetExitCodeProcess $hprocess] == 259} { - return $opts(noaccess) - } else { - return $opts(noexist) - } - } else { - rethrow - } - } onerror {TWAPI_WIN32 299} { - # Partial read - usually means either we are WOW64 and target - # is 64bit, or process is exiting / starting and not all mem is - # reachable yet - return $opts(noaccess) - } finally { - CloseHandle $hprocess - } - return $path -} - -# Fill in arrays with result from WTSEnumerateProcesses if available -proc twapi::_get_wts_pids {v_sids v_names} { - # Note this call is expected to fail on NT 4.0 without terminal server - if {! [catch {WTSEnumerateProcesses NULL} precords]} { - upvar $v_sids wtssids - upvar $v_names wtsnames - array set wtssids [recordarray getlist $precords -slice {ProcessId pUserSid} -format flat] - array set wtsnames [recordarray getlist $precords -slice {ProcessId pUserSid} -format flat] - } -} - -# Return various information from a process token -proc twapi::_token_info_helper {args} { - package require twapi_security - proc _token_info_helper {args} { - if {[llength $args] == 1} { - # All options specified as one argument - set args [lindex $args 0] - } - - if {0} { - Following options are passed on to get_token_info: - elevation - virtualized - restrictedgroups - primarygroup - primarygroupsid - privileges - enabledprivileges - disabledprivileges - logonsession - linkedtoken - Option -integrity is not passed on because it has to deal with - -raw and -label options - } - - array set opts [parseargs args { - pid.arg - hprocess.arg - tid.arg - hthread.arg - integrity - raw - label - user - groups - groupsids - } -ignoreunknown] - - if {[expr {[info exists opts(pid)] + [info exists opts(hprocess)] + - [info exists opts(tid)] + [info exists opts(hthread)]}] > 1} { - error "At most one option from -pid, -tid, -hprocess, -hthread can be specified." - } - - if {$opts(user)} { - lappend args -usersid - } - - if {$opts(groups) || $opts(groupsids)} { - lappend args -groupsids - } - - if {[info exists opts(hprocess)]} { - set tok [open_process_token -hprocess $opts(hprocess)] - } elseif {[info exists opts(pid)]} { - set tok [open_process_token -pid $opts(pid)] - } elseif {[info exists opts(hthread)]} { - set tok [open_thread_token -hthread $opts(hthread)] - } elseif {[info exists opts(tid)]} { - set tok [open_thread_token -tid $opts(tid)] - } else { - # Default is current process - set tok [open_process_token] - } - - trap { - array set result [get_token_info $tok {*}$args] - if {[info exists result(-usersid)]} { - set result(-user) [lookup_account_sid $result(-usersid)] - unset result(-usersid) - } - if {[info exists result(-groupsids)]} { - if {$opts(groups)} { - set result(-groups) {} - foreach sid $result(-groupsids) { - if {[catch {lookup_account_sid $sid} gname]} { - lappend result(-groups) $sid - } else { - lappend result(-groups) $gname - } - } - } - if {!$opts(groupsids)} { - unset result(-groupsids) - } - } - if {$opts(integrity)} { - if {$opts(raw)} { - set integrity [get_token_integrity $tok -raw] - } elseif {$opts(label)} { - set integrity [get_token_integrity $tok -label] - } else { - set integrity [get_token_integrity $tok] - } - set result(-integrity) $integrity - } - } finally { - close_token $tok - } - - return [array get result] - } - - return [_token_info_helper {*}$args] -} - -# Set various information for a process token -# Caller assumed to have enabled appropriate privileges -proc twapi::_token_set_helper {args} { - package require twapi_security - - proc _token_set_helper {args} { - if {[llength $args] == 1} { - # All options specified as one argument - set args [lindex $args 0] - } - - array set opts [parseargs args { - virtualized.bool - integrity.arg - {noexist.arg "(no such process)"} - {noaccess.arg "(unknown)"} - pid.arg - hprocess.arg - } -maxleftover 0] - - if {[info exists opts(pid)] && [info exists opts(hprocess)]} { - error "Options -pid and -hprocess cannot be specified together." - } - - # Open token with appropriate access rights depending on request. - set access [list token_adjust_default] - - if {[info exists opts(hprocess)]} { - set tok [open_process_token -hprocess $opts(hprocess) -access $access] - } elseif {[info exists opts(pid)]} { - set tok [open_process_token -pid $opts(pid) -access $access] - } else { - # Default is current process - set tok [open_process_token -access $access] - } - - set result [list ] - trap { - if {[info exists opts(integrity)]} { - set_token_integrity $tok $opts(integrity) - } - if {[info exists opts(virtualized)]} { - set_token_virtualization $tok $opts(virtualized) - } - } finally { - close_token $tok - } - - return $result - } - return [_token_set_helper {*}$args] -} - -# Map console color name to integer attribute -proc twapi::_map_console_color {colors background} { - set attr 0 - foreach color $colors { - switch -exact -- $color { - blue {setbits attr 1} - green {setbits attr 2} - red {setbits attr 4} - white {setbits attr 7} - bright {setbits attr 8} - black { } - default {error "Unknown color name $color"} - } - } - if {$background} { - set attr [expr {$attr << 4}] - } - return $attr -} - diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/rds.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/rds.tcl deleted file mode 100644 index 9f2757a1..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/rds.tcl +++ /dev/null @@ -1,191 +0,0 @@ -# -# 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 } - } -} diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/registry.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/registry.tcl deleted file mode 100644 index 9cb3403d..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/registry.tcl +++ /dev/null @@ -1,490 +0,0 @@ -# -# 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 -} - diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/resource.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/resource.tcl deleted file mode 100644 index fea6cdda..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/resource.tcl +++ /dev/null @@ -1,458 +0,0 @@ -# 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 diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/security.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/security.tcl deleted file mode 100644 index a0a799b5..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/security.tcl +++ /dev/null @@ -1,2385 +0,0 @@ -# -# Copyright (c) 2003-2014, Ashok P. Nadkarni -# All rights reserved. -# -# See the file LICENSE for license - -# TBD - allow SID and account name to be used interchangeably in various -# functions -# TBD - ditto for LUID v/s privilege names - -namespace eval twapi { - # Map privilege level mnemonics to priv level - array set priv_level_map {guest 0 user 1 admin 2} - - # TBD - the following are not used, enhancements needed ? - # OBJECT_INHERIT_ACE 0x1 - # CONTAINER_INHERIT_ACE 0x2 - # NO_PROPAGATE_INHERIT_ACE 0x4 - # INHERIT_ONLY_ACE 0x8 - # INHERITED_ACE 0x10 - # VALID_INHERIT_FLAGS 0x1F - - # Cache of privilege names to LUID's - variable _privilege_to_luid_map - set _privilege_to_luid_map {} - variable _luid_to_privilege_map {} - -} - - -# Returns token for a process -proc twapi::open_process_token {args} { - array set opts [parseargs args { - pid.int - hprocess.arg - {access.arg token_query} - } -maxleftover 0] - - set access [_access_rights_to_mask $opts(access)] - - # Get a handle for the process - if {[info exists opts(hprocess)]} { - if {[info exists opts(pid)]} { - error "Options -pid and -hprocess cannot be used together." - } - set ph $opts(hprocess) - } elseif {[info exists opts(pid)]} { - set ph [get_process_handle $opts(pid)] - } else { - variable my_process_handle - set ph $my_process_handle - } - trap { - # Get a token for the process - set ptok [OpenProcessToken $ph $access] - } finally { - # Close handle only if we did an OpenProcess - if {[info exists opts(pid)]} { - CloseHandle $ph - } - } - - return $ptok -} - -# Returns token for a process -proc twapi::open_thread_token {args} { - array set opts [parseargs args { - tid.int - hthread.arg - {access.arg token_query} - {self.bool false} - } -maxleftover 0] - - set access [_access_rights_to_mask $opts(access)] - - # Get a handle for the thread - if {[info exists opts(hthread)]} { - if {[info exists opts(tid)]} { - error "Options -tid and -hthread cannot be used together." - } - set th $opts(hthread) - } elseif {[info exists opts(tid)]} { - set th [get_thread_handle $opts(tid)] - } else { - set th [GetCurrentThread] - } - - trap { - # Get a token for the thread - set tok [OpenThreadToken $th $access $opts(self)] - } finally { - # Close handle only if we did an OpenProcess - if {[info exists opts(tid)]} { - CloseHandle $th - } - } - - return $tok -} - -proc twapi::close_token {tok} { - CloseHandle $tok -} - -# TBD - document and test -proc twapi::duplicate_token {tok args} { - parseargs args { - access.arg - {inherit.bool 0} - {secd.arg ""} - {impersonationlevel.sym impersonation {anonymous 0 identification 1 impersonation 2 delegation 3}} - {type.sym primary {primary 1 impersonation 2}} - } -maxleftover 0 -setvars - - if {[info exists access]} { - set access [_access_rights_to_mask $access] - } else { - # If no desired access is indicated, we want the same access as - # the original handle - set access 0 - } - - return [DuplicateTokenEx $tok $access \ - [_make_secattr $secd $inherit] \ - $impersonationlevel $type] -} - -proc twapi::get_token_info {tok args} { - array set opts [parseargs args { - defaultdacl - disabledprivileges - elevation - enabledprivileges - groupattrs - groups - groupsids - integrity - integritylabel - linkedtoken - logonsession - logonsessionsid - origin - primarygroup - primarygroupsid - privileges - restrictedgroupattrs - restrictedgroups - tssession - usersid - virtualized - } -maxleftover 0] - - # Do explicit check so we return error if no args specified - # and $tok is invalid - if {![pointer? $tok]} { - error "Invalid token handle '$tok'" - } - - # TBD - add an -ignorerrors option - - set result [dict create] - trap { - if {$opts(privileges) || $opts(disabledprivileges) || $opts(enabledprivileges)} { - lassign [GetTokenInformation $tok 13] gtigroups gtirestrictedgroups privs gtilogonsession - set privs [_map_luids_and_attrs_to_privileges $privs] - if {$opts(privileges)} { - lappend result -privileges $privs - } - if {$opts(enabledprivileges)} { - lappend result -enabledprivileges [lindex $privs 0] - } - if {$opts(disabledprivileges)} { - lappend result -disabledprivileges [lindex $privs 1] - } - } - if {$opts(defaultdacl)} { - lappend result -defaultdacl [get_token_default_dacl $tok] - } - if {$opts(origin)} { - lappend result -origin [get_token_origin $tok] - } - if {$opts(linkedtoken)} { - lappend result -linkedtoken [get_token_linked_token $tok] - } - if {$opts(elevation)} { - lappend result -elevation [get_token_elevation $tok] - } - if {$opts(integrity)} { - lappend result -integrity [get_token_integrity $tok] - } - if {$opts(integritylabel)} { - lappend result -integritylabel [get_token_integrity $tok -label] - } - if {$opts(virtualized)} { - lappend result -virtualized [get_token_virtualization $tok] - } - if {$opts(tssession)} { - lappend result -tssession [get_token_tssession $tok] - } - if {$opts(usersid)} { - # First element of groups is user sid - if {[info exists gtigroups]} { - lappend result -usersid [lindex $gtigroups 0 0 0] - } else { - lappend result -usersid [get_token_user $tok] - } - } - if {$opts(groups) || $opts(groupsids)} { - if {[info exists gtigroups]} { - set gsids {} - # First element of groups is user sid, skip it - foreach item [lrange $gtigroups 1 end] { - lappend gsids [lindex $item 0] - } - } else { - set gsids [get_token_groups $tok] - } - if {$opts(groupsids)} { - lappend result -groupsids $gsids - } - if {$opts(groups)} { - set items {} - foreach gsid $gsids { - lappend items [lookup_account_sid $gsid] - } - lappend result -groups $items - } - } - if {[min_os_version 6] && $opts(logonsessionsid)} { - # Only possible on Vista+ - lappend result -logonsessionsid [lindex [GetTokenInformation $tok 28] 0 0] - set opts(logonsessionsid) 0; # So we don't try second method below - } - if {$opts(groupattrs) || $opts(logonsessionsid)} { - if {[info exists gtigroups]} { - set items {} - # First element of groups is user sid, skip it - foreach item [lrange $gtigroups 1 end] { - set gattrs [map_token_group_attr [lindex $item 1]] - if {$opts(groupattrs)} { - lappend items [lindex $item 0] $gattrs - } - if {$opts(logonsessionsid) && "logon_id" in $gattrs} { - set logonsessionsid [lindex $item 0] - } - } - if {$opts(groupattrs)} { - lappend result -groupattrs $items - } - } else { - set groupattrs [get_token_groups_and_attrs $tok] - if {$opts(logonsessionsid)} { - foreach {sid gattrs} $groupattrs { - if {"logon_id" in $gattrs} { - set logonsessionsid $sid - break - } - } - } - if {$opts(groupattrs)} { - lappend result -groupattrs $groupattrs - } - } - if {$opts(logonsessionsid)} { - if {[info exists logonsessionsid]} { - lappend result -logonsessionsid $logonsessionsid - } else { - error "No logon session id found in token" - } - } - } - if {$opts(restrictedgroups)} { - if {![info exists gtirestrictedgroups]} { - set gtirestrictedgroups [get_token_restricted_groups_and_attrs $tok] - } - set items {} - foreach item $gtirestrictedgroups { - lappend items [lookup_account_sid [lindex $item 0]] - } - lappend result -restrictedgroups $items - } - if {$opts(restrictedgroupattrs)} { - if {[info exists gtirestrictedgroups]} { - set items {} - foreach item $gtirestrictedgroups { - lappend items [lindex $item 0] [map_token_group_attr [lindex $item 1]] - } - lappend result -restrictedgroupattrs $items - } else { - lappend result -restrictedgroupattrs [get_token_restricted_groups_and_attrs $tok] - } - } - if {$opts(primarygroupsid)} { - lappend result -primarygroupsid [get_token_primary_group $tok] - } - if {$opts(primarygroup)} { - lappend result -primarygroup [get_token_primary_group $tok -name] - } - if {$opts(logonsession)} { - if {[info exists gtilogonsession]} { - lappend result -logonsession $gtilogonsession - } else { - array set stats [get_token_statistics $tok] - lappend result -logonsession $stats(authluid) - } - } - } - - return $result -} - -proc twapi::get_token_tssession {tok} { - return [GetTokenInformation $tok 12] -} - -# TBD - document and test -proc twapi::set_token_tssession {tok tssession} { - Twapi_SetTokenSessionId $tok $tssession - return -} - -# Procs that differ between Vista and prior versions -if {[twapi::min_os_version 6]} { - proc twapi::get_token_elevation {tok} { - set elevation [GetTokenInformation $tok 18]; #TokenElevationType - switch -exact -- $elevation { - 1 { set elevation default } - 2 { set elevation full } - 3 { set elevation limited } - } - return $elevation - } - - proc twapi::get_token_virtualization {tok} { - return [GetTokenInformation $tok 24]; # TokenVirtualizationEnabled - } - - proc twapi::set_token_virtualization {tok enabled} { - # tok must have TOKEN_ADJUST_DEFAULT access - Twapi_SetTokenVirtualizationEnabled $tok [expr {$enabled ? 1 : 0}] - } - - # Get the integrity level associated with a token - proc twapi::get_token_integrity {tok args} { - # TokenIntegrityLevel -> 25 - lassign [GetTokenInformation $tok 25] integrity attrs - if {$attrs != 96} { - # TBD - is this ok? - } - return [_sid_to_integrity $integrity {*}$args] - } - - # Get the integrity level associated with a token - proc twapi::set_token_integrity {tok integrity} { - # SE_GROUP_INTEGRITY attribute - 0x20 - Twapi_SetTokenIntegrityLevel $tok [list [_integrity_to_sid $integrity] 0x20] - } - - proc twapi::get_token_integrity_policy {tok} { - set policy [GetTokenInformation $tok 27]; #TokenMandatoryPolicy - set result {} - if {$policy & 1} { - lappend result no_write_up - } - if {$policy & 2} { - lappend result new_process_min - } - return $result - } - - - proc twapi::set_token_integrity_policy {tok args} { - set policy [_parse_symbolic_bitmask $args { - no_write_up 0x1 - new_process_min 0x2 - }] - - Twapi_SetTokenMandatoryPolicy $tok $policy - } -} else { - # Versions for pre-Vista - proc twapi::get_token_elevation {tok} { - # Older OS versions have no concept of elevation. - return "default" - } - - proc twapi::get_token_virtualization {tok} { - # Older OS versions have no concept of elevation. - return 0 - } - - proc twapi::set_token_virtualization {tok enabled} { - # Older OS versions have no concept of elevation, so only disable - # allowed - if {$enabled} { - error "Virtualization not available on this platform." - } - return - } - - # Get the integrity level associated with a token - proc twapi::get_token_integrity {tok args} { - # Older OS versions have no concept of elevation. - # For future consistency in label mapping, fall through to mapping - # below instead of directly returning mapped value - set integrity S-1-16-8192 - - return [_sid_to_integrity $integrity {*}$args] - } - - # Get the integrity level associated with a token - proc twapi::set_token_integrity {tok integrity} { - # Old platforms have a "default" of medium that cannot be changed. - if {[_integrity_to_sid $integrity] ne "S-1-16-8192"} { - error "Invalid integrity level value '$integrity' for this platform." - } - return - } - - proc twapi::get_token_integrity_policy {tok} { - # Old platforms - no integrity - return 0 - } - - proc twapi::set_token_integrity_policy {tok args} { - # Old platforms - no integrity - return 0 - } -} - -proc twapi::well_known_sid {sidname args} { - parseargs args { - {domainsid.arg {}} - } -maxleftover 0 -setvars - - return [CreateWellKnownSid [_map_well_known_sid_name $sidname] $domainsid] -} - -proc twapi::is_well_known_sid {sid sidname} { - return [IsWellKnownSid $sid [_map_well_known_sid_name $sidname]] -} - -# Get the user account associated with a token -proc twapi::get_token_user {tok args} { - - array set opts [parseargs args [list name]] - # TokenUser -> 1 - set user [lindex [GetTokenInformation $tok 1] 0] - if {$opts(name)} { - set user [lookup_account_sid $user] - } - return $user -} - -# Get the groups associated with a token -proc twapi::get_token_groups {tok args} { - array set opts [parseargs args [list name] -maxleftover 0] - - set groups [list ] - # TokenGroups -> 2 - foreach group [GetTokenInformation $tok 2] { - if {$opts(name)} { - lappend groups [lookup_account_sid [lindex $group 0]] - } else { - lappend groups [lindex $group 0] - } - } - - return $groups -} - -# Get the groups associated with a token along with their attributes -# These are returned as a flat list of the form "sid attrlist sid attrlist..." -# where the attrlist is a list of attributes -proc twapi::get_token_groups_and_attrs {tok} { - - set sids_and_attrs [list ] - # TokenGroups -> 2 - foreach {group} [GetTokenInformation $tok 2] { - lappend sids_and_attrs [lindex $group 0] [map_token_group_attr [lindex $group 1]] - } - - return $sids_and_attrs -} - -# Get the groups associated with a token along with their attributes -# These are returned as a flat list of the form "sid attrlist sid attrlist..." -# where the attrlist is a list of attributes -proc twapi::get_token_restricted_groups_and_attrs {tok} { - set sids_and_attrs [list ] - # TokenRestrictedGroups -> 11 - foreach {group} [GetTokenInformation $tok 11] { - lappend sids_and_attrs [lindex $group 0] [map_token_group_attr [lindex $group 1]] - } - - return $sids_and_attrs -} - - -# Get list of privileges that are currently enabled for the token -# If -all is specified, returns a list {enabled_list disabled_list} -proc twapi::get_token_privileges {tok args} { - - set all [expr {[lsearch -exact $args -all] >= 0}] - # TokenPrivileges -> 3 - set privs [_map_luids_and_attrs_to_privileges [GetTokenInformation $tok 3]] - if {$all} { - return $privs - } else { - return [lindex $privs 0] - } -} - -# Return true if the token has the given privilege -proc twapi::check_enabled_privileges {tok privlist args} { - set all_required [expr {[lsearch -exact $args "-any"] < 0}] - - set luid_attr_list [list ] - foreach priv $privlist { - lappend luid_attr_list [list [map_privilege_to_luid $priv] 0] - } - return [Twapi_PrivilegeCheck $tok $luid_attr_list $all_required] -} - - -# Enable specified privileges. Returns "" if the given privileges were -# already enabled, else returns the privileges that were modified -proc twapi::enable_privileges {privlist} { - variable my_process_handle - - # Get our process token - set tok [OpenProcessToken $my_process_handle 0x28]; # QUERY + ADJUST_PRIVS - trap { - return [enable_token_privileges $tok $privlist] - } finally { - close_token $tok - } -} - - -# Disable specified privileges. Returns "" if the given privileges were -# already enabled, else returns the privileges that were modified -proc twapi::disable_privileges {privlist} { - variable my_process_handle - - # Get our process token - set tok [OpenProcessToken $my_process_handle 0x28]; # QUERY + ADJUST_PRIVS - trap { - return [disable_token_privileges $tok $privlist] - } finally { - close_token $tok - } -} - - -# Execute the given script with the specified privileges. -# After the script completes, the original privileges are restored -proc twapi::eval_with_privileges {script privs args} { - array set opts [parseargs args {besteffort} -maxleftover 0] - - if {[catch {enable_privileges $privs} privs_to_disable]} { - if {! $opts(besteffort)} { - return -code error -errorinfo $::errorInfo \ - -errorcode $::errorCode $privs_to_disable - } - set privs_to_disable [list ] - } - - set code [catch {uplevel $script} result] - switch $code { - 0 { - disable_privileges $privs_to_disable - return $result - } - 1 { - # Save error info before calling disable_privileges - set erinfo $::errorInfo - set ercode $::errorCode - disable_privileges $privs_to_disable - return -code error -errorinfo $::errorInfo \ - -errorcode $::errorCode $result - } - default { - disable_privileges $privs_to_disable - return -code $code $result - } - } -} - - -# Get the privilege associated with a token and their attributes -proc twapi::get_token_privileges_and_attrs {tok} { - set privs_and_attrs [list ] - # TokenPrivileges -> 3 - foreach priv [GetTokenInformation $tok 3] { - lassign $priv luid attr - lappend privs_and_attrs [map_luid_to_privilege $luid -mapunknown] \ - [map_token_privilege_attr $attr] - } - - return $privs_and_attrs - -} - - -# Get the sid that will be used as the owner for objects created using this -# token. Returns name instead of sid if -name options specified -proc twapi::get_token_owner {tok args} { - # TokenOwner -> 4 - return [ _get_token_sid_field $tok 4 $args] -} - - -# Get the sid that will be used as the primary group for objects created using -# this token. Returns name instead of sid if -name options specified -proc twapi::get_token_primary_group {tok args} { - # TokenPrimaryGroup -> 5 - return [ _get_token_sid_field $tok 5 $args] -} - -proc twapi::get_token_default_dacl {tok} { - # TokenDefaultDacl -> 6 - return [GetTokenInformation $tok 6] -} - -proc twapi::get_token_origin {tok} { - # TokenOrigin -> 17 - return [GetTokenInformation $tok 17] -} - -# Return the source of an access token -proc twapi::get_token_source {tok} { - return [GetTokenInformation $tok 7]; # TokenSource -} - - -# Return the token type of an access token -proc twapi::get_token_type {tok} { - # TokenType -> 8 - set type [GetTokenInformation $tok 8] - if {$type == 1} { - return "primary" - } elseif {$type == 2} { - return "impersonation" - } else { - return $type - } -} - -# Return the token type of an access token -proc twapi::get_token_impersonation_level {tok} { - # TokenImpersonationLevel -> 9 - return [_map_impersonation_level [GetTokenInformation $tok 9]] -} - -# Return the linked token when a token is filtered -proc twapi::get_token_linked_token {tok} { - # TokenLinkedToken -> 19 - return [GetTokenInformation $tok 19] -} - -# Return token statistics -proc twapi::get_token_statistics {tok} { - array set stats {} - set labels {luid authluid expiration type impersonationlevel - dynamiccharged dynamicavailable groupcount - privilegecount modificationluid} - # TokenStatistics -> 10 - set statinfo [GetTokenInformation $tok 10] - foreach label $labels val $statinfo { - set stats($label) $val - } - set stats(type) [expr {$stats(type) == 1 ? "primary" : "impersonation"}] - set stats(impersonationlevel) [_map_impersonation_level $stats(impersonationlevel)] - - return [array get stats] -} - - -# Enable the privilege state of a token. Generates an error if -# the specified privileges do not exist in the token (either -# disabled or enabled), or cannot be adjusted -proc twapi::enable_token_privileges {tok privs} { - set luid_attrs [list] - foreach priv $privs { - # SE_PRIVILEGE_ENABLED -> 2 - lappend luid_attrs [list [map_privilege_to_luid $priv] 2] - } - - set privs [list ] - foreach {item} [Twapi_AdjustTokenPrivileges $tok 0 $luid_attrs] { - lappend privs [map_luid_to_privilege [lindex $item 0] -mapunknown] - } - return $privs - - - -} - -# Disable the privilege state of a token. Generates an error if -# the specified privileges do not exist in the token (either -# disabled or enabled), or cannot be adjusted -proc twapi::disable_token_privileges {tok privs} { - set luid_attrs [list] - foreach priv $privs { - lappend luid_attrs [list [map_privilege_to_luid $priv] 0] - } - - set privs [list ] - foreach {item} [Twapi_AdjustTokenPrivileges $tok 0 $luid_attrs] { - lappend privs [map_luid_to_privilege [lindex $item 0] -mapunknown] - } - return $privs -} - -# Disable all privs in a token -proc twapi::disable_all_token_privileges {tok} { - set privs [list ] - foreach {item} [Twapi_AdjustTokenPrivileges $tok 1 [list ]] { - lappend privs [map_luid_to_privilege [lindex $item 0] -mapunknown] - } - return $privs -} - - -# Map a privilege given as a LUID -proc twapi::map_luid_to_privilege {luid args} { - variable _luid_to_privilege_map - - array set opts [parseargs args [list system.arg mapunknown] -nulldefault] - - if {[dict exists $_luid_to_privilege_map $opts(system) $luid]} { - return [dict get $_luid_to_privilege_map $opts(system) $luid] - } - - # luid may in fact be a privilege name. Check for this - if {[is_valid_luid_syntax $luid]} { - trap { - set name [LookupPrivilegeName $opts(system) $luid] - dict set _luid_to_privilege_map $opts(system) $luid $name - } onerror {TWAPI_WIN32 1313} { - if {! $opts(mapunknown)} { - rethrow - } - set name "Privilege-$luid" - # Do not put in cache as privilege name might change? - } - } else { - # Not a valid LUID syntax. Check if it's a privilege name - if {[catch {map_privilege_to_luid $luid -system $opts(system)}]} { - error "Invalid LUID '$luid'" - } - return $luid; # $luid is itself a priv name - } - - return $name -} - - -# Map a privilege to a LUID -proc twapi::map_privilege_to_luid {priv args} { - variable _privilege_to_luid_map - - array set opts [parseargs args [list system.arg] -nulldefault] - - if {[dict exists $_privilege_to_luid_map $opts(system) $priv]} { - return [dict get $_privilege_to_luid_map $opts(system) $priv] - } - - # First check for privilege names we might have generated - if {[string match "Privilege-*" $priv]} { - set priv [string range $priv 10 end] - } - - # If already a LUID format, return as is, else look it up - if {[is_valid_luid_syntax $priv]} { - return $priv - } - - set luid [LookupPrivilegeValue $opts(system) $priv] - # This is an expensive call so stash it unless cache too big - if {[dict size $_privilege_to_luid_map] < 100} { - dict set _privilege_to_luid_map $opts(system) $priv $luid - } - - return $luid -} - - -# Return 1/0 if in LUID format -proc twapi::is_valid_luid_syntax {luid} { - return [regexp {^[[:xdigit:]]{8}-[[:xdigit:]]{8}$} $luid] -} - - -################################################################ -# Functions related to ACE's and ACL's - -# Create a new ACE -proc twapi::new_ace {type account rights args} { - array set opts [parseargs args { - {self.bool 1} - {recursecontainers.bool 0 2} - {recurseobjects.bool 0 1} - {recurseonelevelonly.bool 0 4} - {auditsuccess.bool 1 0x40} - {auditfailure.bool 1 0x80} - }] - - set sid [map_account_to_sid $account] - - set access_mask [_access_rights_to_mask $rights] - - switch -exact -- $type { - mandatory_label - - allow - - deny - - audit { - set typecode [_ace_type_symbol_to_code $type] - } - default { - error "Invalid or unsupported ACE type '$type'" - } - } - - set inherit_flags [expr {$opts(recursecontainers) | $opts(recurseobjects) | - $opts(recurseonelevelonly)}] - if {! $opts(self)} { - incr inherit_flags 8; #INHERIT_ONLY_ACE - } - - if {$type eq "audit"} { - set inherit_flags [expr {$inherit_flags | $opts(auditsuccess) | $opts(auditfailure)}] - } - - return [list $typecode $inherit_flags $access_mask $sid] -} - -# Get the ace type (allow, deny etc.) -proc twapi::get_ace_type {ace} { - return [_ace_type_code_to_symbol [lindex $ace 0]] -} - - -# Set the ace type (allow, deny etc.) -proc twapi::set_ace_type {ace type} { - return [lreplace $ace 0 0 [_ace_type_symbol_to_code $type]] -} - -# Get the access rights in an ACE -proc twapi::get_ace_rights {ace args} { - array set opts [parseargs args { - {type.arg ""} - resourcetype.arg - raw - } -maxleftover 0] - - if {$opts(raw)} { - return [format 0x%x [lindex $ace 2]] - } - - if {[lindex $ace 0] == 0x11} { - # MANDATORY_LABEL -> 0x11 - # Resource type is immaterial - return [_access_mask_to_rights [lindex $ace 2] mandatory_label] - } - - # Backward compatibility - in 2.x -type was documented instead - # of -resourcetype - if {[info exists opts(resourcetype)]} { - return [_access_mask_to_rights [lindex $ace 2] $opts(resourcetype)] - } else { - return [_access_mask_to_rights [lindex $ace 2] $opts(type)] - } -} - -# Set the access rights in an ACE -proc twapi::set_ace_rights {ace rights} { - return [lreplace $ace 2 2 [_access_rights_to_mask $rights]] -} - - -# Get the ACE sid -proc twapi::get_ace_sid {ace} { - return [lindex $ace 3] -} - -# Set the ACE sid -proc twapi::set_ace_sid {ace account} { - return [lreplace $ace 3 3 [map_account_to_sid $account]] -} - - -# Get audit flags - TBD document and test -proc twapi::get_ace_audit {ace} { - set audit {} - set mask [lindex $ace 1] - if {$mask & 0x40} { - lappend audit "success" - } - if {$mask & 0x80} { - lappend audit "failure" - } - return $audit -} - -# Get the inheritance options -proc twapi::get_ace_inheritance {ace} { - - set inherit_opts [list ] - set inherit_mask [lindex $ace 1] - - lappend inherit_opts -self \ - [expr {($inherit_mask & 8) == 0}] - lappend inherit_opts -recursecontainers \ - [expr {($inherit_mask & 2) != 0}] - lappend inherit_opts -recurseobjects \ - [expr {($inherit_mask & 1) != 0}] - lappend inherit_opts -recurseonelevelonly \ - [expr {($inherit_mask & 4) != 0}] - lappend inherit_opts -inherited \ - [expr {($inherit_mask & 16) != 0}] - - return $inherit_opts -} - -# Set the inheritance options. Unspecified options are not set -proc twapi::set_ace_inheritance {ace args} { - - array set opts [parseargs args { - self.bool - recursecontainers.bool - recurseobjects.bool - recurseonelevelonly.bool - }] - - set inherit_flags [lindex $ace 1] - if {[info exists opts(self)]} { - if {$opts(self)} { - resetbits inherit_flags 0x8; #INHERIT_ONLY_ACE -> 0x8 - } else { - setbits inherit_flags 0x8; #INHERIT_ONLY_ACE -> 0x8 - } - } - - foreach { - opt mask - } { - recursecontainers 2 - recurseobjects 1 - recurseonelevelonly 4 - } { - if {[info exists opts($opt)]} { - if {$opts($opt)} { - setbits inherit_flags $mask - } else { - resetbits inherit_flags $mask - } - } - } - - return [lreplace $ace 1 1 $inherit_flags] -} - - -# Sort ACE's in the standard recommended Win2K order -proc twapi::sort_aces {aces} { - - _init_ace_type_symbol_to_code_map - - foreach type [array names twapi::_ace_type_symbol_to_code_map] { - set direct_aces($type) [list ] - set inherited_aces($type) [list ] - } - - # Sort order is as follows: all direct (non-inherited) ACEs come - # before all inherited ACEs. Within these groups, the order should be - # access denied ACEs, access denied ACEs for objects/properties, - # access allowed ACEs, access allowed ACEs for objects/properties, - # TBD - check this ordering against http://msdn.microsoft.com/en-us/library/windows/desktop/aa379298%28v=vs.85%29.aspx - foreach ace $aces { - set type [get_ace_type $ace] - # INHERITED_ACE -> 0x10 - if {[lindex $ace 1] & 0x10} { - lappend inherited_aces($type) $ace - } else { - lappend direct_aces($type) $ace - } - } - - # TBD - check this order ACE's, especially audit and mandatory label - return [concat \ - $direct_aces(deny) \ - $direct_aces(deny_object) \ - $direct_aces(deny_callback) \ - $direct_aces(deny_callback_object) \ - $direct_aces(allow) \ - $direct_aces(allow_object) \ - $direct_aces(allow_compound) \ - $direct_aces(allow_callback) \ - $direct_aces(allow_callback_object) \ - $direct_aces(audit) \ - $direct_aces(audit_object) \ - $direct_aces(audit_callback) \ - $direct_aces(audit_callback_object) \ - $direct_aces(mandatory_label) \ - $direct_aces(alarm) \ - $direct_aces(alarm_object) \ - $direct_aces(alarm_callback) \ - $direct_aces(alarm_callback_object) \ - $inherited_aces(deny) \ - $inherited_aces(deny_object) \ - $inherited_aces(deny_callback) \ - $inherited_aces(deny_callback_object) \ - $inherited_aces(allow) \ - $inherited_aces(allow_object) \ - $inherited_aces(allow_compound) \ - $inherited_aces(allow_callback) \ - $inherited_aces(allow_callback_object) \ - $inherited_aces(audit) \ - $inherited_aces(audit_object) \ - $inherited_aces(audit_callback) \ - $inherited_aces(audit_callback_object) \ - $inherited_aces(mandatory_label) \ - $inherited_aces(alarm) \ - $inherited_aces(alarm_object) \ - $inherited_aces(alarm_callback) \ - $inherited_aces(alarm_callback_object)] -} - -# Pretty print an ACL -proc twapi::get_acl_text {acl args} { - array set opts [parseargs args { - {resourcetype.arg raw} - {offset.arg ""} - } -maxleftover 0] - - set count 0 - set result "$opts(offset)Rev: [get_acl_rev $acl]\n" - foreach ace [get_acl_aces $acl] { - append result "$opts(offset)ACE #[incr count]\n" - append result [get_ace_text $ace -offset "$opts(offset) " -resourcetype $opts(resourcetype)] - } - return $result -} - -# Pretty print an ACE -proc twapi::get_ace_text {ace args} { - array set opts [parseargs args { - {resourcetype.arg raw} - {offset.arg ""} - } -maxleftover 0] - - if {$ace eq "null"} { - return "Null" - } - - set offset $opts(offset) - array set bools {0 No 1 Yes} - array set inherit_flags [get_ace_inheritance $ace] - append inherit_text "${offset}Inherited: $bools($inherit_flags(-inherited))\n" - append inherit_text "${offset}Include self: $bools($inherit_flags(-self))\n" - append inherit_text "${offset}Recurse containers: $bools($inherit_flags(-recursecontainers))\n" - append inherit_text "${offset}Recurse objects: $bools($inherit_flags(-recurseobjects))\n" - append inherit_text "${offset}Recurse single level only: $bools($inherit_flags(-recurseonelevelonly))\n" - - set rights [get_ace_rights $ace -type $opts(resourcetype)] - if {[lsearch -glob $rights *_all_access] >= 0} { - set rights "All" - } else { - set rights [join $rights ", "] - } - - set acetype [get_ace_type $ace] - append result "${offset}Type: [string totitle $acetype]\n" - set user [get_ace_sid $ace] - catch {append user " ([map_account_to_name [get_ace_sid $ace]])"} - append result "${offset}User: $user\n" - append result "${offset}Rights: $rights\n" - if {$acetype eq "audit"} { - append result "${offset}Audit conditions: [join [get_ace_audit $ace] {, }]\n" - } - append result $inherit_text - - return $result -} - -# Create a new ACL -proc twapi::new_acl {{aces ""}} { - # NOTE: we ALWAYS set aclrev to 2. This may not be correct for the - # supplied ACEs but that's ok. The C level code calculates the correct - # acl rev level and overwrites anyways. - return [list 2 $aces] -} - -# Creates an ACL that gives the specified rights to specified trustees -proc twapi::new_restricted_dacl {accounts rights args} { - set access_mask [_access_rights_to_mask $rights] - - set aces {} - foreach account $accounts { - lappend aces [new_ace allow $account $access_mask {*}$args] - } - - return [new_acl $aces] - -} - -# Return the list of ACE's in an ACL -proc twapi::get_acl_aces {acl} { - return [lindex $acl 1] -} - -# Set the ACE's in an ACL -proc twapi::set_acl_aces {acl aces} { - # Note, we call new_acl since when ACEs change, the rev may also change - return [new_acl $aces] -} - -# Append to the ACE's in an ACL -proc twapi::append_acl_aces {acl aces} { - return [set_acl_aces $acl [concat [get_acl_aces $acl] $aces]] -} - -# Prepend to the ACE's in an ACL -proc twapi::prepend_acl_aces {acl aces} { - return [set_acl_aces $acl [concat $aces [get_acl_aces $acl]]] -} - -# Arrange the ACE's in an ACL in a standard order -proc twapi::sort_acl_aces {acl} { - return [set_acl_aces $acl [sort_aces [get_acl_aces $acl]]] -} - -# Return the ACL revision of an ACL -proc twapi::get_acl_rev {acl} { - return [lindex $acl 0] -} - - -# Create a new security descriptor -proc twapi::new_security_descriptor {args} { - array set opts [parseargs args { - owner.arg - group.arg - dacl.arg - sacl.arg - } -maxleftover 0] - - set secd [Twapi_InitializeSecurityDescriptor] - - # TBD - where are the control bits set? THe set_security_descrip[tor_* - # don't seem to set the control bits for related fields either. - foreach field {owner group dacl sacl} { - if {[info exists opts($field)]} { - set secd [set_security_descriptor_$field $secd $opts($field)] - } - } - - return $secd -} - -# Return the control bits in a security descriptor -# TBD - update for new Windows versions -proc twapi::get_security_descriptor_control {secd} { - if {[_null_secd $secd]} { - error "Attempt to get control field from NULL security descriptor." - } - - set control [lindex $secd 0] - - set retval [list ] - if {$control & 0x0001} { - lappend retval owner_defaulted - } - if {$control & 0x0002} { - lappend retval group_defaulted - } - if {$control & 0x0004} { - lappend retval dacl_present - } - if {$control & 0x0008} { - lappend retval dacl_defaulted - } - if {$control & 0x0010} { - lappend retval sacl_present - } - if {$control & 0x0020} { - lappend retval sacl_defaulted - } - if {$control & 0x0100} { - # Not documented because should not actually appear when reading a secd - lappend retval dacl_auto_inherit_req - } - if {$control & 0x0200} { - # Not documented because should not actually appear when reading a secd - lappend retval sacl_auto_inherit_req - } - if {$control & 0x0400} { - lappend retval dacl_auto_inherited - } - if {$control & 0x0800} { - lappend retval sacl_auto_inherited - } - if {$control & 0x1000} { - lappend retval dacl_protected - } - if {$control & 0x2000} { - lappend retval sacl_protected - } - if {$control & 0x4000} { - lappend retval rm_control_valid - } - if {$control & 0x8000} { - lappend retval self_relative - } - return $retval -} - -# Return the owner in a security descriptor -proc twapi::get_security_descriptor_owner {secd} { - if {[_null_secd $secd]} { - win32_error 87 "Attempt to get owner field from NULL security descriptor." - } - return [lindex $secd 1] -} - -# Set the owner in a security descriptor -proc twapi::set_security_descriptor_owner {secd account {defaulted 0}} { - if {[_null_secd $secd]} { - set secd [new_security_descriptor] - } - lassign $secd control - group dacl sacl - set sid [map_account_to_sid $account] - if {$defaulted} { - set control [expr {$control | 0x1}]; # SE_OWNER_DEFAULTED - } else { - set control [expr {$control & ~0x1}]; # ! SE_OWNER_DEFAULTED - } - return [list $control $sid $group $dacl $sacl] -} - -# Return the group in a security descriptor -proc twapi::get_security_descriptor_group {secd} { - if {[_null_secd $secd]} { - win32_error 87 "Attempt to get group field from NULL security descriptor." - } - return [lindex $secd 2] -} - -# Set the group in a security descriptor -proc twapi::set_security_descriptor_group {secd account {defaulted 0}} { - if {[_null_secd $secd]} { - set secd [new_security_descriptor] - } - lassign $secd control owner - dacl sacl - set sid [map_account_to_sid $account] - if {$defaulted} { - set control [expr {$control | 0x2}]; # SE_GROUP_DEFAULTED - } else { - set control [expr {$control & ~0x2}]; # ! SE_GROUP_DEFAULTED - } - return [list $control $owner $sid $dacl $sacl] -} - -# Return the DACL in a security descriptor -proc twapi::get_security_descriptor_dacl {secd} { - if {[_null_secd $secd]} { - win32_error 87 "Attempt to get DACL field from NULL security descriptor." - } - return [lindex $secd 3] -} - -# Set the dacl in a security descriptor -proc twapi::set_security_descriptor_dacl {secd acl {defaulted 0}} { - if {![_is_valid_acl $acl]} { - error "Invalid ACL <$acl>." - } - if {[_null_secd $secd]} { - set secd [new_security_descriptor] - } - lassign $secd control owner group - sacl - if {$acl eq "null"} { - set control [expr {$control & ~0x4}]; # ! SE_DACL_PRESENT - } else { - set control [expr {$control | 0x4}]; # SE_DACL_PRESENT - } - if {$defaulted} { - set control [expr {$control | 0x8}]; # SE_DACL_DEFAULTED - } else { - set control [expr {$control & ~0x8}]; # ! SE_DACL_DEFAULTED - } - return [list $control $owner $group $acl $sacl] -} - -# Return the SACL in a security descriptor -proc twapi::get_security_descriptor_sacl {secd} { - if {[_null_secd $secd]} { - win32_error 87 "Attempt to get SACL field from NULL security descriptor." - } - return [lindex $secd 4] -} - -# Set the sacl in a security descriptor -proc twapi::set_security_descriptor_sacl {secd acl {defaulted 0}} { - if {![_is_valid_acl $acl]} { - error "Invalid ACL <$acl>." - } - if {[_null_secd $secd]} { - set secd [new_security_descriptor] - } - lassign $secd control owner group dacl - - if {$acl eq "null"} { - set control [expr {$control & ~0x10}]; # ! SE_SACL_PRESENT - } else { - set control [expr {$control | 0x10}]; # SE_SACL_PRESENT - } - if {$defaulted} { - set control [expr {$control | 0x20}]; # SE_SACL_DEFAULTED - } else { - set control [expr {$control & ~0x20}]; # ! SE_SACL_DEFAULTED - } - return [list $control $owner $group $dacl $acl] -} - -# Get the specified security information for the given object -proc twapi::get_resource_security_descriptor {restype name args} { - - # -mandatory_label field is not documented. Should we ? TBD - array set opts [parseargs args { - owner - group - dacl - sacl - mandatory_label - all - handle - }] - - set wanted 0 - - # OWNER_SECURITY_INFORMATION 1 - # GROUP_SECURITY_INFORMATION 2 - # DACL_SECURITY_INFORMATION 4 - # SACL_SECURITY_INFORMATION 8 - foreach {field mask} {owner 1 group 2 dacl 4 sacl 8} { - if {$opts($field) || $opts(all)} { - incr wanted $mask; # Equivalent to OR operation - } - } - - # LABEL_SECURITY_INFORMATION 0x10 - if {[min_os_version 6]} { - if {$opts(mandatory_label) || $opts(all)} { - incr wanted 16; # OR with 0x10 - } - } - - # Note if no options specified, we ask for everything except - # SACL's which require special privileges - if {! $wanted} { - set wanted 0x7 - if {[min_os_version 6]} { - incr wanted 0x10 - } - } - - if {$opts(handle)} { - set restype [_map_resource_symbol_to_type $restype false] - if {$restype == 5} { - # GetSecurityInfo crashes if a handles is passed in for - # SE_LMSHARE (even erroneously). It expects a string name - # even though the prototype says HANDLE. Protect against this. - error "Share resource type (share or 5) cannot be used with -handle option" - } - set secd [GetSecurityInfo \ - [CastToHANDLE $name] \ - $restype \ - $wanted] - } else { - # GetNamedSecurityInfo seems to fail with a overlapped i/o - # in progress error under some conditions. If this happens - # try getting with resource-specific API's if possible. - trap { - set secd [GetNamedSecurityInfo \ - $name \ - [_map_resource_symbol_to_type $restype true] \ - $wanted] - } onerror {} { - # TBD - see what other resource-specific API's there are - if {$restype eq "share"} { - set secd [lindex [get_share_info $name -secd] 1] - } else { - # Throw the same error - rethrow - } - } - } - - return $secd -} - - -# Set the specified security information for the given object -# See http://search.cpan.org/src/TEVERETT/Win32-Security-0.50/README -# for a good discussion even though that applies to Perl -proc twapi::set_resource_security_descriptor {restype name secd args} { - - # PROTECTED_DACL_SECURITY_INFORMATION 0x80000000 - # PROTECTED_SACL_SECURITY_INFORMATION 0x40000000 - # UNPROTECTED_DACL_SECURITY_INFORMATION 0x20000000 - # UNPROTECTED_SACL_SECURITY_INFORMATION 0x10000000 - array set opts [parseargs args { - all - handle - owner - group - dacl - sacl - mandatory_label - {protect_dacl {} 0x80000000} - {unprotect_dacl {} 0x20000000} - {protect_sacl {} 0x40000000} - {unprotect_sacl {} 0x10000000} - }] - - - if {![min_os_version 6]} { - if {$opts(mandatory_label)} { - error "Option -mandatory_label not supported by this version of Windows" - } - } - - if {$opts(protect_dacl) && $opts(unprotect_dacl)} { - error "Cannot specify both -protect_dacl and -unprotect_dacl." - } - - if {$opts(protect_sacl) && $opts(unprotect_sacl)} { - error "Cannot specify both -protect_sacl and -unprotect_sacl." - } - - set mask [expr {$opts(protect_dacl) | $opts(unprotect_dacl) | - $opts(protect_sacl) | $opts(unprotect_sacl)}] - - if {$opts(owner) || $opts(all)} { - set opts(owner) [get_security_descriptor_owner $secd] - setbits mask 1; # OWNER_SECURITY_INFORMATION - } else { - set opts(owner) "" - } - - if {$opts(group) || $opts(all)} { - set opts(group) [get_security_descriptor_group $secd] - setbits mask 2; # GROUP_SECURITY_INFORMATION - } else { - set opts(group) "" - } - - if {$opts(dacl) || $opts(all)} { - set opts(dacl) [get_security_descriptor_dacl $secd] - setbits mask 4; # DACL_SECURITY_INFORMATION - } else { - set opts(dacl) null - } - - if {$opts(sacl) || $opts(mandatory_label) || $opts(all)} { - set sacl [get_security_descriptor_sacl $secd] - if {$opts(sacl) || $opts(all)} { - setbits mask 0x8; # SACL_SECURITY_INFORMATION - } - if {[min_os_version 6]} { - if {$opts(mandatory_label) || $opts(all)} { - setbits mask 0x10; # LABEL_SECURITY_INFORMATION - } - } - set opts(sacl) $sacl - } else { - set opts(sacl) null - } - - if {$mask == 0} { - error "Must specify at least one of the options -all, -dacl, -sacl, -owner, -group or -mandatory_label" - } - - if {$opts(handle)} { - set restype [_map_resource_symbol_to_type $restype false] - if {$restype == 5} { - # GetSecurityInfo crashes if a handles is passed in for - # SE_LMSHARE (even erroneously). It expects a string name - # even though the prototype says HANDLE. Protect against this. - error "Share resource type (share or 5) cannot be used with -handle option" - } - - SetSecurityInfo \ - [CastToHANDLE $name] \ - [_map_resource_symbol_to_type $restype false] \ - $mask \ - $opts(owner) \ - $opts(group) \ - $opts(dacl) \ - $opts(sacl) - } else { - SetNamedSecurityInfo \ - $name \ - [_map_resource_symbol_to_type $restype true] \ - $mask \ - $opts(owner) \ - $opts(group) \ - $opts(dacl) \ - $opts(sacl) - } -} - -# Get integrity level from a security descriptor -proc twapi::get_security_descriptor_integrity {secd args} { - if {[min_os_version 6]} { - foreach ace [get_acl_aces [get_security_descriptor_sacl $secd]] { - if {[get_ace_type $ace] eq "mandatory_label"} { - if {! [dict get [get_ace_inheritance $ace] -self]} continue; # Does not apply to itself - set integrity [_sid_to_integrity [get_ace_sid $ace] {*}$args] - set rights [get_ace_rights $ace -resourcetype mandatory_label] - return [list $integrity $rights] - } - } - } - return {} -} - -# Get integrity level for a resource -proc twapi::get_resource_integrity {restype name args} { - # Note label and raw options are simply passed on - - if {![min_os_version 6]} { - return "" - } - set saved_args $args - array set opts [parseargs args { - label - raw - handle - }] - - if {$opts(handle)} { - set secd [get_resource_security_descriptor $restype $name -mandatory_label -handle] - } else { - set secd [get_resource_security_descriptor $restype $name -mandatory_label] - } - - return [get_security_descriptor_integrity $secd {*}$saved_args] -} - - -proc twapi::set_security_descriptor_integrity {secd integrity rights args} { - # Not clear from docs whether this can - # be done without interfering with SACL fields. Nevertheless - # we provide this proc because we might want to set the - # integrity level on new objects create thru CreateFile etc. - # TBD - need to test under vista and win 7 - - array set opts [parseargs args { - {recursecontainers.bool 0} - {recurseobjects.bool 0} - } -maxleftover 0] - - # We preserve any non-integrity aces in the sacl. - set sacl [get_security_descriptor_sacl $secd] - set aces {} - foreach ace [get_acl_aces $sacl] { - if {[get_ace_type $ace] ne "mandatory_label"} { - lappend aces $ace - } - } - - # Now create and attach an integrity ace. Note placement does not - # matter - lappend aces [new_ace mandatory_label \ - [_integrity_to_sid $integrity] \ - [_access_rights_to_mask $rights] \ - -self 1 \ - -recursecontainers $opts(recursecontainers) \ - -recurseobjects $opts(recurseobjects)] - - return [set_security_descriptor_sacl $secd [new_acl $aces]] -} - -proc twapi::set_resource_integrity {restype name integrity rights args} { - array set opts [parseargs args { - {recursecontainers.bool 0} - {recurseobjects.bool 0} - handle - } -maxleftover 0] - - set secd [set_security_descriptor_integrity \ - [new_security_descriptor] \ - $integrity \ - $rights \ - -recurseobjects $opts(recurseobjects) \ - -recursecontainers $opts(recursecontainers)] - - if {$opts(handle)} { - set_resource_security_descriptor $restype $name $secd -mandatory_label -handle - } else { - set_resource_security_descriptor $restype $name $secd -mandatory_label - } -} - - -# Convert a security descriptor to SDDL format -proc twapi::security_descriptor_to_sddl {secd} { - return [twapi::ConvertSecurityDescriptorToStringSecurityDescriptor $secd 1 0x1f] -} - -# Convert SDDL to a security descriptor -proc twapi::sddl_to_security_descriptor {sddl} { - return [twapi::ConvertStringSecurityDescriptorToSecurityDescriptor $sddl 1] -} - -# Return the text for a security descriptor -proc twapi::get_security_descriptor_text {secd args} { - if {[_null_secd $secd]} { - return "null" - } - - array set opts [parseargs args { - {resourcetype.arg raw} - } -maxleftover 0] - - append result "Flags:\t[get_security_descriptor_control $secd]\n" - set name [get_security_descriptor_owner $secd] - if {$name eq ""} { - set name Undefined - } else { - catch {set name [map_account_to_name $name]} - } - append result "Owner:\t$name\n" - set name [get_security_descriptor_group $secd] - if {$name eq ""} { - set name Undefined - } else { - catch {set name [map_account_to_name $name]} - } - append result "Group:\t$name\n" - - if {0} { - set acl [get_security_descriptor_dacl $secd] - append result "DACL Rev: [get_acl_rev $acl]\n" - set index 0 - foreach ace [get_acl_aces $acl] { - append result "\tDACL Entry [incr index]\n" - append result "[get_ace_text $ace -offset "\t " -resourcetype $opts(resourcetype)]" - } - set acl [get_security_descriptor_sacl $secd] - append result "SACL Rev: [get_acl_rev $acl]\n" - set index 0 - foreach ace [get_acl_aces $acl] { - append result "\tSACL Entry $index\n" - append result [get_ace_text $ace -offset "\t " -resourcetype $opts(resourcetype)] - } - } else { - append result "DACL:\n" - append result [get_acl_text [get_security_descriptor_dacl $secd] -offset " " -resourcetype $opts(resourcetype)] - append result "SACL:\n" - append result [get_acl_text [get_security_descriptor_sacl $secd] -offset " " -resourcetype $opts(resourcetype)] - } - - return $result -} - - -# Log off -proc twapi::logoff {args} { - array set opts [parseargs args { - {force {} 0x4} - {forceifhung {} 0x10} - } -maxleftover 0] - ExitWindowsEx [expr {$opts(force) | $opts(forceifhung)}] 0 -} - -# Lock the workstation -proc twapi::lock_workstation {} { - LockWorkStation -} - - -# Get a new LUID -proc twapi::new_luid {} { - return [AllocateLocallyUniqueId] -} - - -# Get the description of a privilege -proc twapi::get_privilege_description {priv} { - if {[catch {LookupPrivilegeDisplayName "" $priv} desc]} { - # The above function will only return descriptions for - # privileges, not account rights. Hard code descriptions - # for some account rights - set desc [dict* { - SeBatchLogonRight "Log on as a batch job" - SeDenyBatchLogonRight "Deny logon as a batch job" - SeDenyInteractiveLogonRight "Deny interactive logon" - SeDenyNetworkLogonRight "Deny access to this computer from the network" - SeRemoteInteractiveLogonRight "Remote interactive logon" - SeDenyRemoteInteractiveLogonRight "Deny interactive remote logon" - SeDenyServiceLogonRight "Deny logon as a service" - SeInteractiveLogonRight "Log on locally" - SeNetworkLogonRight "Access this computer from the network" - SeServiceLogonRight "Log on as a service" - } $priv] - } - return $desc -} - - - -# For backward compatibility, emulate GetUserName using GetUserNameEx -proc twapi::GetUserName {} { - return [file tail [GetUserNameEx 2]] -} - - -################################################################ -# Utility and helper functions - - - -# Returns an sid field from a token -proc twapi::_get_token_sid_field {tok field options} { - array set opts [parseargs options {name}] - set owner [GetTokenInformation $tok $field] - if {$opts(name)} { - set owner [lookup_account_sid $owner] - } - return $owner -} - -# Map token group attributes -# TBD - write a test for this -proc twapi::map_token_group_attr {attr} { - # SE_GROUP_MANDATORY 0x00000001 - # SE_GROUP_ENABLED_BY_DEFAULT 0x00000002 - # SE_GROUP_ENABLED 0x00000004 - # SE_GROUP_OWNER 0x00000008 - # SE_GROUP_USE_FOR_DENY_ONLY 0x00000010 - # SE_GROUP_LOGON_ID 0xC0000000 - # SE_GROUP_RESOURCE 0x20000000 - # SE_GROUP_INTEGRITY 0x00000020 - # SE_GROUP_INTEGRITY_ENABLED 0x00000040 - - return [_make_symbolic_bitmask $attr { - mandatory 0x00000001 - enabled_by_default 0x00000002 - enabled 0x00000004 - owner 0x00000008 - use_for_deny_only 0x00000010 - logon_id 0xC0000000 - resource 0x20000000 - integrity 0x00000020 - integrity_enabled 0x00000040 - }] -} - -# Map token privilege attributes -# TBD - write a test for this -proc twapi::map_token_privilege_attr {attr} { - # SE_PRIVILEGE_ENABLED_BY_DEFAULT 0x00000001 - # SE_PRIVILEGE_ENABLED 0x00000002 - # SE_PRIVILEGE_USED_FOR_ACCESS 0x80000000 - - return [_make_symbolic_bitmask $attr { - enabled_by_default 0x00000001 - enabled 0x00000002 - used_for_access 0x80000000 - }] -} - - - -# Map an ace type symbol (eg. allow) to the underlying ACE type code -proc twapi::_ace_type_symbol_to_code {type} { - _init_ace_type_symbol_to_code_map - return $::twapi::_ace_type_symbol_to_code_map($type) -} - - -# Map an ace type code to an ACE type symbol -proc twapi::_ace_type_code_to_symbol {type} { - _init_ace_type_symbol_to_code_map - return $::twapi::_ace_type_code_to_symbol_map($type) -} - - -# Init the arrays used for mapping ACE type symbols to codes and back -proc twapi::_init_ace_type_symbol_to_code_map {} { - - if {[info exists ::twapi::_ace_type_symbol_to_code_map]} { - return - } - - # ACCESS_ALLOWED_ACE_TYPE 0x0 - # ACCESS_DENIED_ACE_TYPE 0x1 - # SYSTEM_AUDIT_ACE_TYPE 0x2 - # SYSTEM_ALARM_ACE_TYPE 0x3 - # ACCESS_ALLOWED_COMPOUND_ACE_TYPE 0x4 - # ACCESS_ALLOWED_OBJECT_ACE_TYPE 0x5 - # ACCESS_DENIED_OBJECT_ACE_TYPE 0x6 - # SYSTEM_AUDIT_OBJECT_ACE_TYPE 0x7 - # SYSTEM_ALARM_OBJECT_ACE_TYPE 0x8 - # ACCESS_ALLOWED_CALLBACK_ACE_TYPE 0x9 - # ACCESS_DENIED_CALLBACK_ACE_TYPE 0xA - # ACCESS_ALLOWED_CALLBACK_OBJECT_ACE_TYPE 0xB - # ACCESS_DENIED_CALLBACK_OBJECT_ACE_TYPE 0xC - # SYSTEM_AUDIT_CALLBACK_ACE_TYPE 0xD - # SYSTEM_ALARM_CALLBACK_ACE_TYPE 0xE - # SYSTEM_AUDIT_CALLBACK_OBJECT_ACE_TYPE 0xF - # SYSTEM_ALARM_CALLBACK_OBJECT_ACE_TYPE 0x10 - # SYSTEM_MANDATORY_LABEL_ACE_TYPE 0x11 - - # Define the array. - array set ::twapi::_ace_type_symbol_to_code_map { - allow 0 deny 1 audit 2 alarm 3 allow_compound 4 - allow_object 5 deny_object 6 audit_object 7 - alarm_object 8 allow_callback 9 deny_callback 10 - allow_callback_object 11 deny_callback_object 12 - audit_callback 13 alarm_callback 14 audit_callback_object 15 - alarm_callback_object 16 mandatory_label 17 - } - - # Now define the array in the other direction - foreach {sym code} [array get ::twapi::_ace_type_symbol_to_code_map] { - set ::twapi::_ace_type_code_to_symbol_map($code) $sym - } -} - -# Map a resource symbol type to value -proc twapi::_map_resource_symbol_to_type {sym {named true}} { - if {[string is integer $sym]} { - return $sym - } - - # Note "window" is not here because window stations and desktops - # do not have unique names and cannot be used with Get/SetNamedSecurityInfo - switch -exact -- $sym { - file { return 1 } - service { return 2 } - printer { return 3 } - registry { return 4 } - share { return 5 } - kernelobj { return 6 } - } - if {$named} { - error "Resource type '$sym' not valid for named resources." - } - - switch -exact -- $sym { - windowstation { return 7 } - directoryservice { return 8 } - directoryserviceall { return 9 } - providerdefined { return 10 } - wmiguid { return 11 } - registrywow6432key { return 12 } - } - - error "Resource type '$sym' not valid" -} - -# Valid LUID syntax -proc twapi::_is_valid_luid_syntax luid { - return [regexp {^[[:xdigit:]]{8}-[[:xdigit:]]{8}$} $luid] -} - - -# Delete rights for an account -proc twapi::_delete_rights {account system} { - # Remove the user from the LSA rights database. Ignore any errors - catch { - remove_account_rights $account {} -all -system $system - - # On Win2k SP1 and SP2, we need to delay a bit for notifications - # to complete before deleting the account. - # See http://support.microsoft.com/?id=316827 - lassign [get_os_version] major minor sp dontcare - if {($major == 5) && ($minor == 0) && ($sp < 3)} { - after 1000 - } - } -} - - -# Get a token for a user -proc twapi::open_user_token {username password args} { - - array set opts [parseargs args { - domain.arg - {type.arg batch {interactive network batch service unlock network_cleartext new_credentials}} - {provider.arg default {default winnt35 winnt40 winnt50}} - } -nulldefault] - - # LOGON32_LOGON_INTERACTIVE 2 - # LOGON32_LOGON_NETWORK 3 - # LOGON32_LOGON_BATCH 4 - # LOGON32_LOGON_SERVICE 5 - # LOGON32_LOGON_UNLOCK 7 - # LOGON32_LOGON_NETWORK_CLEARTEXT 8 - # LOGON32_LOGON_NEW_CREDENTIALS 9 - set type [dict get {interactive 2 network 3 batch 4 service 5 - unlock 7 network_cleartext 8 new_credentials 9} $opts(type)] - - # LOGON32_PROVIDER_DEFAULT 0 - # LOGON32_PROVIDER_WINNT35 1 - # LOGON32_PROVIDER_WINNT40 2 - # LOGON32_PROVIDER_WINNT50 3 - set provider [dict get {default 0 winnt35 1 winnt40 2 winnt50 3} $opts(provider)] - - # If username is of the form user@domain, then domain must not be specified - # If username is not of the form user@domain, then domain is set to "." - # if it is empty - if {[regexp {^([^@]+)@(.+)} $username dummy user domain]} { - if {[string length $opts(domain)] != 0} { - error "The -domain option must not be specified when the username is in UPN format (user@domain)" - } - } else { - if {[string length $opts(domain)] == 0} { - set opts(domain) "." - } - } - - return [LogonUser $username $opts(domain) $password $type $provider] -} - - -# Impersonate a user given a token -proc twapi::impersonate_token {token} { - ImpersonateLoggedOnUser $token -} - - -# Impersonate a user -proc twapi::impersonate_user {args} { - set token [open_user_token {*}$args] - trap { - impersonate_token $token - } finally { - close_token $token - } -} - -# Impersonate self -proc twapi::impersonate_self {level} { - switch -exact -- $level { - anonymous { set level 0 } - identification { set level 1 } - impersonation { set level 2 } - delegation { set level 3 } - default { - error "Invalid impersonation level $level" - } - } - ImpersonateSelf $level -} - -# Set a thread token - currently only for current thread -proc twapi::set_thread_token {token} { - SetThreadToken NULL $token -} - -# Reset a thread token - currently only for current thread -proc twapi::reset_thread_token {} { - SetThreadToken NULL NULL -} - -proc twapi::_cred_cook {cred} { - set rec [twine {flags type target comment lastwritten credblob persist attributes targetalias username} $cred] - dict with rec { - set type [dict* { - 1 generic 2 domain_password 3 domain_certificate 4 domain_visible_password 5 generic_certificate 6 domain_extended} $type] - set persist [dict* { - 1 session 2 local_machine 3 enterprise - } $persist] - } - return $rec -} - -proc twapi::credentials {{pattern {}}} { - trap { - set raw [CredEnumerate $pattern 0] - } onerror {TWAPI_WIN32 1168} { - # Not found / no entries - return {} - } - - return [lmap cred $raw { _cred_cook $cred }] -} - -proc twapi::cred_delete {target {type generic}} { - if {[string is integer -strict $type]} { - set type_flags $type - } else { - set type_flags [dict get { - generic 1 - domain_password 2 - domain_certificate 3 - domain_visible_password 4 - generic_certificate 5 - domain_extended 6 - } $type] - } - CredDelete $target $type_flags 0 - return -} - -proc twapi::cred_get {target {type generic}} { - if {[string is integer -strict $type]} { - set type_flags $type - } else { - set type_flags [dict get { - generic 1 - domain_password 2 - domain_certificate 3 - domain_visible_password 4 - generic_certificate 5 - domain_extended 6 - } $type] - } - return [_cred_cook [CredRead $target $type_flags 0]] -} - - -# TBD - document after implementing AuditQuerySystemPolicy and friends -# for Vista & later -proc twapi::get_audit_policy {lsah} { - lassign [LsaQueryInformationPolicy $lsah 2] enabled audit_masks - set settings {} - foreach name { - system logon object_access privilege_use detailed_tracking - policy_change account_management directory_service_access - account_logon - } mask $audit_masks { - # Copied from the Perl Win32 book. - set setting {} - if {$mask == 0 || ($mask & 4)} { - set setting {} - } elseif {$mask & 3} { - if {$mask & 1} { lappend setting log_on_success } - if {$mask & 2} { lappend setting log_on_failure } - } else { - error "Unexpected audit mask value $mask" - } - lappend settings $name $setting - } - - return [list $enabled $settings] -} - - -# TBD - document after implementing AuditQuerySystemPolicy and friends -# for Vista & later -proc twapi::set_audit_policy {lsah enable settings} { - set audit_masks {} - # NOTE: the order here MUST match the enum definition for - # POLICY_AUDIT_EVENT_TYPE (see SDK docs) - foreach name { - system logon object_access privilege_use detailed_tracking - policy_change account_management directory_service_access - account_logon - } { - set mask 0; # POLICY_AUDIT_EVENT_UNCHANGED - if {[dict exists $settings $name]} { - set setting [dict get $settings $name] - # 4 -> POLICY_AUDIT_EVENT_NONE resets existing FAILURE|SUCCESS - set mask 4 - if {"log_on_success" in $setting} { - set mask [expr {$mask | 1}]; # POLICY_AUDIT_EVENT_SUCCESS - } - if {"log_on_failure" in $setting} { - set mask [expr {$mask | 2}]; # POLICY_AUDIT_EVENT_FAILURE - } - } - lappend audit_masks $mask - } - - Twapi_LsaSetInformationPolicy_AuditEvents $lsah $enable $audit_masks -} - -# Returns true if null security descriptor -proc twapi::_null_secd {secd} { - if {[llength $secd] == 0} { - return 1 - } else { - return 0 - } -} - -# Returns true if a valid ACL -proc twapi::_is_valid_acl {acl} { - if {$acl eq "null"} { - return 1 - } else { - return [IsValidAcl $acl] - } -} - -# Returns true if a valid ACL -proc twapi::_is_valid_security_descriptor {secd} { - if {[_null_secd $secd]} { - return 1 - } else { - return [IsValidSecurityDescriptor $secd] - } -} - -# Maps a integrity SID to integer or label -proc twapi::_sid_to_integrity {sid args} { - # Note - to make it simpler for callers, additional options are ignored - array set opts [parseargs args { - label - raw - }] - - if {$opts(raw) && $opts(label)} { - error "Options -raw and -label may not be specified together." - } - - if {![string equal -length 7 S-1-16-* $sid]} { - error "Unexpected integrity level value '$sid' returned by GetTokenInformation." - } - - if {$opts(raw)} { - return $sid - } - - set integrity [string range $sid 7 end] - - if {! $opts(label)} { - # Return integer level - return $integrity - } - - # Map to a label - if {$integrity < 4096} { - return untrusted - } elseif {$integrity < 8192} { - return low - } elseif {$integrity < 8448} { - return medium - } elseif {$integrity < 12288} { - return mediumplus - } elseif {$integrity < 16384} { - return high - } else { - return system - } - -} - -proc twapi::_integrity_to_sid {integrity} { - # Integrity level must be either a number < 65536 or a valid string - # or a SID. Check for the first two and convert to SID. Anything else - # will be trapped by the actual call as an invalid format. - if {[string is integer -strict $integrity]} { - set integrity S-1-16-[format %d $integrity]; # In case in hex - } else { - switch -glob -- $integrity { - untrusted { set integrity S-1-16-0 } - low { set integrity S-1-16-4096 } - medium { set integrity S-1-16-8192 } - mediumplus { set integrity S-1-16-8448 } - high { set integrity S-1-16-12288 } - system { set integrity S-1-16-16384 } - S-1-16-* { - if {![string is integer -strict [string range $integrity 7 end]]} { - error "Invalid integrity level '$integrity'" - } - # Format in case level component was in hex/octal - set integrity S-1-16-[format %d [string range $integrity 7 end]] - } - default { - error "Invalid integrity level '$integrity'" - } - } - } - return $integrity -} - -proc twapi::_map_luids_and_attrs_to_privileges {luids_and_attrs} { - set enabled_privs [list ] - set disabled_privs [list ] - foreach item $luids_and_attrs { - set priv [map_luid_to_privilege [lindex $item 0] -mapunknown] - # SE_PRIVILEGE_ENABLED -> 0x2 - if {[lindex $item 1] & 2} { - lappend enabled_privs $priv - } else { - lappend disabled_privs $priv - } - } - - return [list $enabled_privs $disabled_privs] -} - -# Map impersonation level to symbol -proc twapi::_map_impersonation_level ilevel { - set map { - 0 anonymous - 1 identification - 2 impersonation - 3 delegation - } - if {[dict exists $map [incr ilevel 0]]} { - return [dict get $map $ilevel] - } else { - return $ilevel - } -} - -proc twapi::_map_well_known_sid_name {sidname} { - if {[string is integer -strict $sidname]} { - return $sidname - } - - set sidname [string tolower $sidname] - set sidname [dict* { - administrator accountadministrator - {cert publishers} accountcertadmins - {domain computers} accountcomputers - {domain controllers} accountcontrollers - {domain admins} accountdomainadmins - {domain guests} accountdomainguests - {domain users} accountdomainusers - {enterprise admins} accountenterpriseadmins - guest accountguest - krbtgt accountkrbtgt - {read-only domain controllers} accountreadonlycontrollers - {schema admins} accountschemaadmins - {anonymous logon} anonymous - {authenticated users} authenticateduser - batch batch - administrators builtinadministrators - {all application packages} builtinanypackage - {backup operators} builtinbackupoperators - {distributed com users} builtindcomusers - builtin builtindomain - {event log readers} builtineventlogreadersgroup - guests builtinguests - {performance log users} builtinperfloggingusers - {performance monitor users} builtinperfmonitoringusers - {power users} builtinpowerusers - {remote desktop users} builtinremotedesktopusers - replicator builtinreplicator - users builtinusers - {console logon} consolelogon - {creator group} creatorgroup - {creator group server} creatorgroupserver - {creator owner} creatorowner - {owner rights} creatorownerrights - {creator owner server} creatorownerserver - dialup dialup - {digest authentication} digestauthentication - {enterprise domain controllers} enterprisecontrollers - {enterprise read-only domain controllers beta} enterprisereadonlycontrollers - {high mandatory level} highlabel - interactive interactive - local local - {local service} localservice - system localsystem - {low mandatory level} lowlabel - {medium mandatory level} mediumlabel - {medium plus mandatory level} mediumpluslabel - network network - {network service} networkservice - {enterprise read-only domain controllers} newenterprisereadonlycontrollers - {ntlm authentication} ntlmauthentication - {null sid} null - proxy proxy - {remote interactive logon} remotelogonid - restricted restrictedcode - {schannel authentication} schannelauthentication - self self - service service - {system mandatory level} systemlabel - {terminal server user} terminalserver - {untrusted mandatory level} untrustedlabel - everyone world - {write restricted} writerestrictedcode - } $sidname] - - return [dict! { - null 0 - world 1 - local 2 - creatorowner 3 - creatorgroup 4 - creatorownerserver 5 - creatorgroupserver 6 - ntauthority 7 - dialup 8 - network 9 - batch 10 - interactive 11 - service 12 - anonymous 13 - proxy 14 - enterprisecontrollers 15 - self 16 - authenticateduser 17 - restrictedcode 18 - terminalserver 19 - remotelogonid 20 - logonids 21 - localsystem 22 - localservice 23 - networkservice 24 - builtindomain 25 - builtinadministrators 26 - builtinusers 27 - builtinguests 28 - builtinpowerusers 29 - builtinaccountoperators 30 - builtinsystemoperators 31 - builtinprintoperators 32 - builtinbackupoperators 33 - builtinreplicator 34 - builtinprewindows2000compatibleaccess 35 - builtinremotedesktopusers 36 - builtinnetworkconfigurationoperators 37 - accountadministrator 38 - accountguest 39 - accountkrbtgt 40 - accountdomainadmins 41 - accountdomainusers 42 - accountdomainguests 43 - accountcomputers 44 - accountcontrollers 45 - accountcertadmins 46 - accountschemaadmins 47 - accountenterpriseadmins 48 - accountpolicyadmins 49 - accountrasandiasservers 50 - ntlmauthentication 51 - digestauthentication 52 - schannelauthentication 53 - thisorganization 54 - otherorganization 55 - builtinincomingforesttrustbuilders 56 - builtinperfmonitoringusers 57 - builtinperfloggingusers 58 - builtinauthorizationaccess 59 - builtinterminalserverlicenseservers 60 - builtindcomusers 61 - builtiniusers 62 - iuser 63 - builtincryptooperators 64 - untrustedlabel 65 - lowlabel 66 - mediumlabel 67 - highlabel 68 - systemlabel 69 - writerestrictedcode 70 - creatorownerrights 71 - cacheableprincipalsgroup 72 - noncacheableprincipalsgroup 73 - enterprisereadonlycontrollers 74 - accountreadonlycontrollers 75 - builtineventlogreadersgroup 76 - newenterprisereadonlycontrollers 77 - builtincertsvcdcomaccessgroup 78 - mediumpluslabel 79 - locallogon 80 - consolelogon 81 - thisorganizationcertificate 82 - applicationpackageauthority 83 - builtinanypackage 84 - capabilityinternetclient 85 - capabilityinternetclientserver 86 - capabilityprivatenetworkclientserver 87 - capabilitypictureslibrary 88 - capabilityvideoslibrary 89 - capabilitymusiclibrary 90 - capabilitydocumentslibrary 91 - capabilitysharedusercertificates 92 - capabilityenterpriseauthentication 93 - capabilityremovablestorage 94 - } $sidname] -} - diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/service.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/service.tcl deleted file mode 100644 index 649b480f..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/service.tcl +++ /dev/null @@ -1,1187 +0,0 @@ -# -# Copyright (c) 2003-2007, Ashok P. Nadkarni -# All rights reserved. -# -# See the file LICENSE for license - -namespace eval twapi { - # When the process hosts Windows services, service_state - # is used to keep state of each service. The variable - # is indexed by NAME,FIELD where NAME is the name - # of the service and FIELD is one of "state", "script", - # "checkpoint", "waithint", "exitcode", "servicecode", - # "seq", "seqack" - variable service_state - - # Map service state names to integers - variable service_state_values - array set service_state_values { - stopped 1 - start_pending 2 - stop_pending 3 - running 4 - continue_pending 5 - pause_pending 6 - paused 7 - } -} - - -# Return 1/0 depending on whether the given service exists -# $name may be either the internal or display name -proc twapi::service_exists {name args} { - array set opts [parseargs args {system.arg database.arg} -nulldefault] - # 0x00020000 -> STANDARD_RIGHTS_READ - set scm [OpenSCManager $opts(system) $opts(database) 0x00020000] - - trap { - GetServiceKeyName $scm $name - set exists 1 - } onerror {TWAPI_WIN32 1060} { - # "no such service" error for internal name. - # Try display name - trap { - GetServiceDisplayName $scm $name - set exists 1 - } onerror {TWAPI_WIN32 1060} { - set exists 0 - } - } finally { - CloseServiceHandle $scm - } - - return $exists -} - - -# Create a service of the specified name -proc twapi::create_service {name command args} { - array set opts [parseargs args { - displayname.arg - {servicetype.arg win32_own_process {win32_own_process win32_share_process file_system_driver kernel_driver}} - {interactive.bool 0} - {starttype.arg auto_start {auto_start boot_start demand_start disabled system_start}} - {errorcontrol.arg normal {ignore normal severe critical}} - loadordergroup.arg - dependencies.arg - account.arg - password.arg - system.arg - database.arg - } -nulldefault] - - - if {[string length $opts(displayname)] == 0} { - set opts(displayname) $name - } - - if {[string length $command] == 0} { - error "The executable path must not be null when creating a service" - } - set opts(command) $command - - switch -exact -- $opts(servicetype) { - file_system_driver - - kernel_driver { - if {$opts(interactive)} { - error "Option -interactive cannot be specified when -servicetype is $opts(servicetype)." - } - } - default { - if {$opts(interactive) && [string length $opts(account)]} { - error "Option -interactive cannot be specified with the -account option as interactive services must run under the LocalSystem account." - } - if {[string equal $opts(starttype) "boot_start"] - || [string equal $opts(starttype) "system_start"]} { - error "Option -starttype value must be one of auto_start, demand_start or disabled when -servicetype is '$opts(servicetype)'." - } - } - } - - # Map keywords to integer values - set opts(servicetype) [_map_servicetype_sym $opts(servicetype)] - set opts(starttype) [_map_starttype_sym $opts(starttype)] - set opts(errorcontrol) [_map_errorcontrol_sym $opts(errorcontrol)] - - # If interactive, add the flag to the service type - if {$opts(interactive)} { - setbits opts(servicetype) 0x100; # SERVICE_INTERACTIVE_PROCESS - } - - # Ignore password if username not specified - if {[string length $opts(account)] == 0} { - set opts(password) "" - } else { - # If domain/system not specified, tack on ".\" for local system - if {[string first \\ $opts(account)] < 0} { - set opts(account) ".\\$opts(account)" - } - } - - # 2 -> SC_MANAGER_CREATE_SERVICE - set scm [OpenSCManager $opts(system) $opts(database) 2] - trap { - # 0x000F01FF -> SERVICE_ALL_ACCESS - set svch [CreateService \ - $scm \ - $name \ - $opts(displayname) \ - 0x000F01FF \ - $opts(servicetype) \ - $opts(starttype) \ - $opts(errorcontrol) \ - $opts(command) \ - $opts(loadordergroup) \ - "" \ - $opts(dependencies) \ - $opts(account) \ - $opts(password)] - - CloseServiceHandle $svch - - } finally { - CloseServiceHandle $scm - } - - return -} - - -# Delete the given service -proc twapi::delete_service {name args} { - - array set opts [parseargs args {system.arg database.arg} -nulldefault] - - # 0x00010000 -> DELETE access - set opts(scm_priv) 0x00010000 - set opts(svc_priv) 0x00010000 - set opts(proc) twapi::DeleteService - - _service_fn_wrapper $name opts - - return -} - - -# Get the internal name of a service -proc twapi::get_service_internal_name {name args} { - array set opts [parseargs args {system.arg database.arg} -nulldefault] - # 0x00020000 -> STANDARD_RIGHTS_READ - set scm [OpenSCManager $opts(system) $opts(database) 0x00020000] - - trap { - if {[catch {GetServiceKeyName $scm $name} internal_name]} { - # Maybe this is an internal name itself - GetServiceDisplayName $scm $name; # Will throw an error if not internal name - set internal_name $name - } - } finally { - CloseServiceHandle $scm - } - - return $internal_name -} - -proc twapi::get_service_display_name {name args} { - array set opts [parseargs args {system.arg database.arg} -nulldefault] - # 0x00020000 -> STANDARD_RIGHTS_READ - set scm [OpenSCManager $opts(system) $opts(database) 0x00020000] - - trap { - if {[catch {GetServiceDisplayName $scm $name} display_name]} { - # Maybe this is an display name itself - GetServiceKeyName $scm $name; # Will throw an error if not display name - set display_name $name - } - } finally { - CloseServiceHandle $scm - } - - return $display_name -} - -proc twapi::start_service {name args} { - array set opts [parseargs args { - system.arg - database.arg - params.arg - wait.int - } -nulldefault] - set opts(svc_priv) 0x10; # SERVICE_START - set opts(proc) twapi::StartService - set opts(args) [list $opts(params)] - unset opts(params) - - trap { - _service_fn_wrapper $name opts - } onerror {TWAPI_WIN32 1056} { - # Error 1056 means service already running - } - - return [wait {twapi::get_service_state $name -system $opts(system) -database $opts(database)} running $opts(wait)] -} - -# TBD - test -proc twapi::notify_service {name code args} { - array set opts [parseargs args { - system.arg - database.arg - ignorecodes.arg - } -nulldefault] - - if {[string is integer -strict $code] && $code >= 128 && $code <= 255} { - # 0x100 -> SERVICE_USER_DEFINED_CONTROL - set access 0x100 - } elseif {$code eq "paramchange"} { - # 0x40 -> SERVICE_PAUSE_CONTINUE - set access 0x40 - set code 6; # PARAMCHANGE - } else { - badargs! "Invalid service notification code \"$code\"." - } - - set scm [OpenSCManager $opts(system) $opts(database) 0x00020000] - trap { - set svch [OpenService $scm $name $access] - } finally { - CloseServiceHandle $scm - } - - trap { - ControlService $svch $code - } onerror {TWAPI_WIN32} { - if {[lsearch -exact -integer $opts(ignorecodes) [lindex $::errorCode 1]] < 0} { - # Not one of the error codes we can ignore. - rethrow - } - } finally { - CloseServiceHandle $svch - } - return -} - -proc twapi::control_service {name code access finalstate args} { - array set opts [parseargs args { - system.arg - database.arg - ignorecodes.arg - wait.int - } -nulldefault] - # 0x00020000 -> STANDARD_RIGHTS_READ - set scm [OpenSCManager $opts(system) $opts(database) 0x00020000] - trap { - set svch [OpenService $scm $name $access] - } finally { - CloseServiceHandle $scm - } - - trap { - ControlService $svch $code - } onerror {TWAPI_WIN32} { - if {[lsearch -exact -integer $opts(ignorecodes) [lindex $::errorCode 1]] < 0} { - # Not one of the error codes we can ignore. - rethrow - } - } finally { - CloseServiceHandle $svch - } - - if {[string length $finalstate]} { - # Wait until service is in specified state - return [wait {twapi::get_service_state $name -system $opts(system) -database $opts(database)} $finalstate $opts(wait)] - } else { - return 0 - } -} - -proc twapi::stop_service {name args} { - # 1 -> SERVICE_CONTROL_STOP - # 0x20 -> SERVICE_STOP - control_service $name 1 0x20 stopped -ignorecodes 1062 {*}$args -} - -proc twapi::pause_service {name args} { - # 2 -> SERVICE_CONTROL_PAUSE - # 0x40 -> SERVICE_PAUSE_CONTINUE - control_service $name 2 0x40 paused {*}$args -} - -proc twapi::continue_service {name args} { - # 3 -> SERVICE_CONTROL_CONTINUE - # 0x40 -> SERVICE_PAUSE_CONTINUE - control_service $name 3 0x40 running {*}$args -} - -proc twapi::interrogate_service {name args} { - # 4 -> SERVICE_CONTROL_INTERROGATE - # 0x80 -> SERVICE_INTERROGATE - control_service $name 4 0x80 "" {*}$args - return -} - - -# Retrieve status information for a service -proc twapi::get_service_status {name args} { - array set opts [parseargs args {system.arg database.arg} -nulldefault] - # 0x00020000 -> STANDARD_RIGHTS_READ - set scm [OpenSCManager $opts(system) $opts(database) 0x00020000] - trap { - # 4 -> SERVICE_QUERY_STATUS - set svch [OpenService $scm $name 4] - } finally { - # Do not need SCM anymore - CloseServiceHandle $scm - } - - trap { - return [QueryServiceStatusEx $svch 0] - } finally { - CloseServiceHandle $svch - } -} - - -# Get the state of the service -proc twapi::get_service_state {name args} { - return [kl_get [get_service_status $name {*}$args] state] -} - - -# Get the current configuration for a service -proc twapi::get_service_configuration {name args} { - array set opts [parseargs args { - system.arg - database.arg - all - servicetype - interactive - errorcontrol - starttype - command - loadordergroup - account - displayname - dependencies - description - scm_handle.arg - tagid - failureactions - delayedstart - } -nulldefault -hyphenated] - - if {$opts(-scm_handle) eq ""} { - # Use 0x00020000 -> STANDARD_RIGHTS_READ for SCM - set scmh [OpenSCManager $opts(-system) $opts(-database) 0x00020000] - trap { - set svch [OpenService $scmh $name 1]; # 1 -> SERVICE_QUERY_CONFIG - } finally { - CloseServiceHandle $scmh - } - } else { - set svch [OpenService $opts(-scm_handle) $name 1]; # 1 -> SERVICE_QUERY_CONFIG - } - - trap { - set result [QueryServiceConfig $svch] - if {$opts(-all) || $opts(-description)} { - dict set result -description {} - # For backwards compatibility, ignore errors if description - # cannot be obtained - catch { - dict set result -description [QueryServiceConfig2 $svch 1]; # 1 -> SERVICE_CONFIG_DESCRIPTION - } - } - - if {$opts(-all) || $opts(-failureactions)} { - # 2 -> SERVICE_CONFIG_FAILURE_ACTIONS - lassign [QueryServiceConfig2 $svch 2] resetperiod rebootmsg command failure_actions - set actions {} - foreach action $failure_actions { - lappend actions [list [dict* {0 none 1 restart 2 reboot 3 run} [lindex $action 0]] [lindex $action 1]] - } - dict set result -failureactions [list -resetperiod $resetperiod -rebootmsg $rebootmsg -command $command -actions $actions] - } - if {$opts(-all) || $opts(-delayedstart)} { - if {[min_os_version 6]} { - # 3 -> SERVICE_CONFIG_DELAYED_AUTO_START_INFO - dict set result -delayedstart [QueryServiceConfig2 $svch 3] - } else { - dict set result -delayedstart 0 - } - } - } finally { - CloseServiceHandle $svch - } - - if {! $opts(-all)} { - set result [dict filter $result script {k val} {set opts($k)}] - } - - if {[dict exists $result -errorcontrol]} { - dict set result -errorcontrol [_map_errorcontrol_code [dict get $result -errorcontrol]] - } - - if {[dict exists $result -starttype]} { - dict set result -starttype [_map_starttype_code [dict get $result -starttype]] - } - - return $result -} - -# Sets a service configuration -proc twapi::set_service_configuration {name args} { - # Get the current values - we will need these for validation - # with the new values - array set current [get_service_configuration $name -all] - set current(-password) ""; # This is not returned by get_service_configuration - - # Now parse arguments, filling in defaults - array set opts [parseargs args { - displayname.arg - servicetype.arg - interactive.bool - starttype.arg - errorcontrol.arg - command.arg - loadordergroup.arg - dependencies.arg - account.arg - password.arg - {system.arg ""} - {database.arg ""} - }] - - if {[info exists opts(account)] && ! [info exists opts(password)]} { - error "Option -password must also be specified when -account is specified." - } - - # Merge current configuration with specified options - foreach opt { - displayname - servicetype - interactive - starttype - errorcontrol - command - loadordergroup - dependencies - account - password - } { - if {[info exists opts($opt)]} { - set winparams($opt) $opts($opt) - } else { - set winparams($opt) $current(-$opt) - } - } - - # Validate the new configuration - switch -exact -- $winparams(servicetype) { - file_system_driver - - kernel_driver { - if {$winparams(interactive)} { - error "Option -interactive cannot be specified when -servicetype is $winparams(servicetype)." - } - } - default { - if {$winparams(interactive) && - [string length $winparams(account)] && - [string compare -nocase $winparams(account) "LocalSystem"] - } { - error "Option -interactive cannot be specified with the -account option as interactive services must run under the LocalSystem account." - } - if {[string equal $winparams(starttype) "boot_start"] - || [string equal $winparams(starttype) "system_start"]} { - error "Option -starttype value must be one of auto_start, demand_start or disabled when -servicetype is '$winparams(servicetype)'." - } - } - } - - # Map keywords to integer values - set winparams(servicetype) [_map_servicetype_sym $winparams(servicetype)] - set winparams(starttype) [_map_starttype_sym $winparams(starttype)] - set winparams(errorcontrol) [_map_errorcontrol_sym $winparams(errorcontrol)] - - # Merge the interactive setting - # 0x100 -> SERVICE_INTERACTIVE_PROCESS - if {$winparams(interactive)} { - setbits winparams(servicetype) 0x100 - } else { - resetbits winparams(servicetype) 0x100 - } - - # If domain/system not specified, tack on ".\" for local system - if {[string length $winparams(account)]} { - if {[string first \\ $winparams(account)] < 0} { - set winparams(account) ".\\$winparams(account)" - } - } - - # Now replace any options that were not specified with "no change" - # tokens. - foreach opt {servicetype starttype errorcontrol} { - if {![info exists opts($opt)]} { - set winparams($opt) 0xffffffff; # SERVICE_NO_CHANGE - } - } - # -servicetype and -interactive go in same field - if {![info exists opts(servicetype)] && ![info exists opts(interactive)]} { - set winparams(servicetype) 0xffffffff; # SERVICE_NO_CHANGE - } - - foreach opt {command loadordergroup dependencies account password displayname} { - if {![info exists opts($opt)]} { - set winparams($opt) $twapi::nullptr - } - } - - set opts(scm_priv) 0x00020000; # 0x00020000 -> STANDARD_RIGHTS_READ - set opts(svc_priv) 2; # 2 -> SERVICE_CHANGE_CONFIG - - set opts(proc) twapi::ChangeServiceConfig - set opts(args) \ - [list \ - $winparams(servicetype) \ - $winparams(starttype) \ - $winparams(errorcontrol) \ - $winparams(command) \ - $winparams(loadordergroup) \ - "" \ - $winparams(dependencies) \ - $winparams(account) \ - $winparams(password) \ - $winparams(displayname)] - - _service_fn_wrapper $name opts - - return -} - -proc twapi::set_service_delayed_start {name delay args} { - array set opts [parseargs args { - {system.arg ""} - {database.arg ""} - } -maxleftover 0] - - set opts(scm_priv) 0x00020000; # 0x00020000 -> STANDARD_RIGHTS_READ - set opts(svc_priv) 2; # 2 -> SERVICE_CHANGE_CONFIG - - set opts(proc) twapi::ChangeServiceConfig2 - set opts(args) [list 3 $delay] - - _service_fn_wrapper $name opts - return -} - -proc twapi::set_service_description {name description args} { - array set opts [parseargs args { - {system.arg ""} - {database.arg ""} - } -maxleftover 0] - - set opts(scm_priv) 0x00020000; # 0x00020000 -> STANDARD_RIGHTS_READ - set opts(svc_priv) 2; # 2 -> SERVICE_CHANGE_CONFIG - - set opts(proc) twapi::ChangeServiceConfig2 - set opts(args) [list 1 $description] - - _service_fn_wrapper $name opts - return -} - -proc twapi::set_service_failure_actions {name args} { - array set opts [parseargs args { - {system.arg ""} - {database.arg ""} - resetperiod.arg - {rebootmsg.arg __null__} - {command.arg __null__} - actions.arg - } -maxleftover 0] - - set opts(scm_priv) 0x00020000; # 0x00020000 -> STANDARD_RIGHTS_READ - set opts(svc_priv) 2; # 2 -> SERVICE_CHANGE_CONFIG - - # If option actions is not specified, actions for the service - # are left unchanged. - if {[info exists opts(actions)]} { - set actions {} - foreach action $opts(actions) { - if {[llength $action] != 2} { - error "Invalid format for failure action" - } - set action_code [dict* {none 0 restart 1 reboot 2 run 3} [lindex $action 0]] - if {$action_code == 1} { - # Also need SERVICE_START access right for restart action - set opts(svc_priv) [expr {$opts(svc_priv) | 0x10}] - } - lappend actions [list $action_code [lindex $action 1]] - } - if {![info exists opts(resetperiod)] || $opts(resetperiod) eq "infinite"} { - set opts(resetperiod) 0xffffffff - } - set fail_params [list $opts(resetperiod) $opts(rebootmsg) $opts(command) $actions] - } else { - if {[info exists opts(resetperiod)]} { - badargs! "Option -resetperiod can only be used if the -actions option is also specified." - } - set fail_params [list 0 $opts(rebootmsg) $opts(command)] - } - - set opts(proc) twapi::ChangeServiceConfig2 - set opts(args) [list 2 $fail_params]; # 2 -> SERVICE_CONFIG_FAILURE_ACTIONS - _service_fn_wrapper $name opts - return -} - -# Get status for the specified service types -proc twapi::get_multiple_service_status {args} { - set service_types [list \ - kernel_driver \ - file_system_driver \ - adapter \ - recognizer_driver \ - user_own_process \ - user_share_process \ - win32_own_process \ - win32_share_process] - set switches [concat $service_types \ - [list active inactive] \ - [list system.arg database.arg]] - array set opts [parseargs args $switches -nulldefault] - - set servicetype 0 - foreach type $service_types { - if {$opts($type)} { - set servicetype [expr { $servicetype | [_map_servicetype_sym $type]}] - } - } - if {$servicetype == 0} { - # No type specified, return all - set servicetype 0x3f - } - - set servicestate 0 - if {$opts(active)} { - set servicestate 1; # 1 -> SERVICE_ACTIVE - } - if {$opts(inactive)} { - set servicestate [expr {$servicestate | 2}]; # 2 -> SERVICE_INACTIVE - } - if {$servicestate == 0} { - # No state specified, include all - set servicestate 3 - } - - # 4 -> SC_MANAGER_ENUMERATE_SERVICE - set scm [OpenSCManager $opts(system) $opts(database) 4] - trap { - set fields { - servicetype state controls_accepted exitcode service_code - checkpoint wait_hint pid serviceflags name displayname interactive - } - return [list $fields [EnumServicesStatusEx $scm 0 $servicetype $servicestate __null__]] - } finally { - CloseServiceHandle $scm - } -} - - -# Get status for the dependents of the specified service -proc twapi::get_dependent_service_status {name args} { - array set opts [parseargs args \ - [list active inactive system.arg database.arg] \ - -nulldefault] - - set servicestate 0 - if {$opts(active)} { - set servicestate 1; # 1 -> SERVICE_ACTIVE - } - if {$opts(inactive)} { - set servicestate [expr {$servicestate | 2}]; # SERVICE_INACTIVE - } - if {$servicestate == 0} { - # No state specified, include all - set servicestate 3 - } - - set opts(svc_priv) 8; # SERVICE_ENUMERATE_DEPENDENTS - set opts(proc) twapi::EnumDependentServices - set opts(args) [list $servicestate] - - set fields { - servicetype state controls_accepted exitcode service_code - checkpoint wait_hint name displayname interactive - } - - return [list $fields [_service_fn_wrapper $name opts]] - - -} - - -################################################################ -# Commands for running as a service - -proc twapi::run_as_service {services args} { - variable service_state - - if {[llength $services] == 0} { - win32_error 87 "No services specified" - } - - array set opts [parseargs args { - interactive.bool - {controls.arg {stop shutdown}} - } -nulldefault -maxleftover 0] - - # Currently service controls are per process, not per service and - # are fixed for the duration of the process. - # TBD - C code actually allows for per service controls. Expose? - set service_state(controls) [_parse_service_accept_controls $opts(controls)] - if {![min_os_version 5 1]} { - # Not accepted on Win2k - if {$service_state(controls) & 0x80} { - error "Service control type 'sessionchange' is not valid on this platform" - } - } - - if {[llength $services] == 1} { - set type 0x10; # WIN32_OWN_PROCESS - } else { - set type 0x20; # WIN32_SHARE_PROCESS - } - if {$opts(interactive)} { - setbits type 0x100; # INTERACTIVE_PROCESS - } - - set service_defs [list ] - foreach service $services { - lassign $service name script - set name [string tolower $name] - lappend service_defs [list $name $service_state(controls)] - set service_state($name,state) stopped - set service_state($name,script) $script - set service_state($name,checkpoint) 0 - set service_state($name,waithint) 2000; # 2 seconds - set service_state($name,exitcode) 0 - set service_state($name,servicecode) 0 - set service_state($name,seq) 0 - set service_state($name,seqack) 0 - } - - twapi::Twapi_BecomeAService $type {*}$service_defs - - # Turn off console events by installing our own handler, - # else tclsh will exit when a user logs off even if it is running - # as a service - # COMMENTED OUT because now done in C code itself - # proc ::twapi::_service_console_handler args { return 1 } - # set_console_control_handler ::twapi::_service_console_handler - - # Redefine ourselves as we should not be called again - proc ::twapi::run_as_service args { - error "Already running as a service" - } -} - - -# Callback that handles requests from the service control manager -proc twapi::_service_handler {name service_status_handle control args} { - # TBD - should we catch the error or let the C code see it ? - if {[catch { - _service_handler_unsafe $name $service_status_handle $control $args - } msg]} { - # TBD - log error message - catch {eventlog_log "Error in service handler for service $name. $msg Stack: $::errorInfo" -type error} - } -} - -# Can raise an error -proc twapi::_service_handler_unsafe {name service_status_handle control extra_args} { - variable service_state - - set name [string tolower $name] - - # The service handler will receive control codes from the service - # control manager and modify the state of a service accordingly. - # It also calls the script registered by the application for - # the service. The caller is expected to complete the state change - # by calling service_change_state_complete either inside the - # callback or at some later point. - - set tell_app true; # Does app need to be notified ? - set report_status true; # Whether we should update status - set need_response true; # App should report status back - - switch -glob -- "$service_state($name,state),$control" { - stopped,start { - set service_state($name,state) start_pending - set service_state($name,checkpoint) 1 - } - start_pending,shutdown - - paused,shutdown - - pause_pending,shutdown - - continue_pending,shutdown - - running,shutdown - - start_pending,stop - - paused,stop - - pause_pending,stop - - continue_pending,stop - - running,stop { - set service_state($name,state) stop_pending - set service_state($name,checkpoint) 1 - } - running,pause { - set service_state($name,state) pause_pending - set service_state($name,checkpoint) 1 - } - pause_pending,continue - - paused,continue { - set service_state($name,state) continue_pending - set service_state($name,checkpoint) 1 - } - *,interrogate { - # No state change, we will simply report status below - set tell_app false; # No need to bother the application - } - *,userdefined - - *,paramchange - - *,netbindadd - - *,netbindremove - - *,netbindenable - - *,netbinddisable - - *,deviceevent - - *,hardwareprofilechange - - *,powerevent - - *,sessionchange { - # Notifications, should not report status. - set report_status false - set need_response false - } - default { - # All other cases are no-ops (e.g. paused,pause) or - # don't make logical sense (e.g. stop_pending,continue) - # For now, we simply ignore them but not sure - # if we should just update service status anyways - return - } - } - - if {$report_status} { - _report_service_status $name - } - - set result 0 - if {$tell_app} { - if {[catch { - if {$need_response} { - set seq [incr service_state($name,seq)] - } else { - set seq -1 - } - set result [uplevel #0 [linsert $service_state($name,script) end $control $name $seq {*}$extra_args]] - # Note that if the above script may call back into us, - # via update_service_status for example, the service - # state may be updated at this point - } msg]} { - # TBD - report if the script throws errors - } - } - - if {$result eq "allow"} { - set result 0 - } elseif {$result eq "deny"} { - set result 0x424D5144; # BROADCAST_QUERY_DENY - } - - return $result -} - -# Called by the application to update it's status -# status should be one of "running", "paused" or "stopped" -# seq is 0 or the sequence number of a previous callback to -# the application to which this is the response. -proc twapi::update_service_status {name seq state args} { - variable service_state - - if {$state ni {running paused stopped}} { - error "Invalid state token $state" - } - - if {$seq == -1} { - # This was a notification. App should not have responded. - # Just ignore it - return ignored - } - - array set opts [parseargs args { - exitcode.int - servicecode.int - waithint.int - } -maxleftover 0] - - set name [string tolower $name] - - # Depending on the current state of the application, - # we may or may not be able to change state. For - # example, if the current state is "running" and - # the new state is "stopped", that is ok. But the - # converse is not allowed since we cannot - # transition from stopped to running unless - # the SCM has sent us a start signal. - - # If the seq is greater than the last one we sent, bug somewhere - if {$service_state($name,seq) < $seq} { - error "Invalid sequence number $seq (too large) for service status update." - } - - # If we have a request outstanding (to the app) that the app - # has not yet responded to, then all calls from the app with - # no seq number (i.e. 0) or calls with an older sequence number - # are ignored. - if {($service_state($name,seq) > $service_state($name,seqack)) && - ($seq == 0 || $seq < $service_state($name,seq))} { - # Ignore this request - return ignored - } - - set service_state($name,seqack) $seq; # last responded sequence number - - # If state specified as stopped, store the exit codes - if {$state eq "stopped"} { - if {[info exists opts(exitcode)]} { - set service_state($name,exitcode) $opts(exitcode) - } - if {[info exists opts(servicecode)]} { - set service_state($name,servicecode) $opts(servicecode) - } - } - - upvar 0 service_state($name,state) current_state - - # If there is no state change, nothing to do - if {$state eq $current_state} { - return nochange - } - - switch -exact -- $state { - stopped { - # Application can stop at any time from any other state. - # No questions asked. - } - running { - if {$current_state eq "stopped" || $current_state eq "paused"} { - # This should not happen if all the rules are followed by the - # application code. - #error "Service $name attempted to transition directly from stopped or paused state to running state without an intermediate pending state" - return invalidchange - } - } - paused { - if {$current_state ne "pause_pending" && - $current_state ne "continue_pending"} { - # This should not happen if all the rules are followed by the - # application code. - #error "Service $name attempted to transition from $current_state state to paused state" - return invalidchange - } - } - } - - set current_state $state - _report_service_status $name - - if {$state eq "stopped"} { - # If all services have stopped, tell the app - set all_stopped true - foreach {entry val} [array get service_state *,state] { - if {$val ne "stopped"} { - set all_stopped false - break - } - } - if {$all_stopped} { - uplevel #0 [linsert $service_state($name,script) end all_stopped $name 0] - } - } - - return changed; # State changed -} - - -# Report the status of a service back to the SCM -proc twapi::_report_service_status {name} { - variable service_state - upvar 0 service_state($name,state) current_state - - # If the state is a pending state, then make sure we - # increment the checkpoint value - if {[string match *pending $current_state]} { - incr service_state($name,checkpoint) - set waithint $service_state($name,waithint) - } else { - set service_state($name,checkpoint) 0 - set waithint 0 - } - - # Currently service controls are per process, not per service and - # are fixed for the duration of the process. So we always pass - # service_state(controls). Applications has to ensure it can handle - # all control signals in all states (ignoring them as desired) - if {[catch { - Twapi_SetServiceStatus $name $::twapi::service_state_values($current_state) $service_state($name,exitcode) $service_state($name,servicecode) $service_state($name,checkpoint) $waithint $service_state(controls) - } msg]} { - # TBD - report error - but how ? bgerror? - catch {twapi::eventlog_log "Error setting service status: $msg"} - } - - # If we had supplied a wait hint, we are telling the SCM, we will call - # it back within that period of time, so schedule ourselves. - if {$waithint} { - set delay [expr {($waithint*3)/4}] - after $delay ::twapi::_call_scm_within_waithint $name $current_state $service_state($name,checkpoint) - } - - return -} - - -# Queued to regularly update the SCM when we are in any of the pending states -proc ::twapi::_call_scm_within_waithint {name orig_state orig_checkpoint} { - variable service_state - - # We only call to update staus if the state and checkpoint have - # not changed since the routine was queued - if {($service_state($name,state) eq $orig_state) && - ($service_state($name,checkpoint) == $orig_checkpoint)} { - _report_service_status $name - } -} - - -################################################################ -# Utility procedures - -# Map an integer service type code into a list consisting of -# {SERVICETYPESYMBOL BOOLEAN}. If there is not symbolic service type -# for the service, just the integer code is returned. The BOOLEAN -# is 1/0 depending on whether the service type code is interactive -proc twapi::_map_servicetype_code {servicetype} { - # 0x100 -> SERVICE_INTERACTIVE_PROCESS - set interactive [expr {($servicetype & 0x100) != 0}] - set servicetype [expr {$servicetype & (~ 0x100)}] - set servicetype [kl_get [list \ - 16 win32_own_process \ - 32 win32_share_process \ - 80 user_own_process \ - 96 user_share_process \ - 1 kernel_driver \ - 2 file_system_driver \ - 4 adapter \ - 8 recognizer_driver \ - ] $servicetype $servicetype] - return [list $servicetype $interactive] -} - -# Map service type sym to int code -proc twapi::_map_servicetype_sym {sym} { - return [dict get {kernel_driver 1 file_system_driver 2 adapter 4 recognizer_driver 8 win32_own_process 16 win32_share_process 32 user_own_process 80 user_share_process 96} $sym] -} - -# Map a start type code into a symbol. Returns the integer code if -# no mapping possible -proc twapi::_map_starttype_code {code} { - incr code 0; # Make canonical int - set type [lindex {boot_start system_start auto_start demand_start disabled} $code] - if {$type eq ""} { - return $code - } else { - return $type - } -} - -# Map starttype sym to int code -proc twapi::_map_starttype_sym {sym} { - return [dict get {boot_start 0 system_start 1 auto_start 2 demand_start 3 disabled 4} $sym] -} - -# Map a error control code into a symbol. Returns the integer code if -# no mapping possible -proc twapi::_map_errorcontrol_code {code} { - incr code 0; # Make canonical int - set error [lindex {ignore normal severe critical} $code] - if {$error eq ""} { - return $code - } else { - return $error - } -} - -# Map error control sym to int code -proc twapi::_map_errorcontrol_sym {sym} { - return [dict get {ignore 0 normal 1 severe 2 critical 3} $sym] -} - -# Standard template for calling a service function. v_opts should refer -# to an array with the following elements: -# opts(system) - target system. Must be specified -# opts(database) - target database. Must be specified -# opts(scm_priv) - requested privilege when opening SCM. STANDARD_RIGHTS_READ -# is used if unspecified. Not used if scm_handle is specified -# opts(scm_handle) - handle to service control manager. Optional -# opts(svc_priv) - requested privilege when opening service. Must be present -# opts(proc) - proc/function to call. The first arg is the service handle -# opts(args) - additional arguments to pass to the function. -# Empty if unspecified -proc twapi::_service_fn_wrapper {name v_opts} { - upvar $v_opts opts - - # Use 0x00020000 -> STANDARD_RIGHTS_READ for SCM if not specified - set scm_priv [expr {[info exists opts(scm_priv)] ? $opts(scm_priv) : 0x00020000}] - - if {[info exists opts(scm_handle)] && - $opts(scm_handle) ne ""} { - set scm $opts(scm_handle) - } else { - set scm [OpenSCManager $opts(system) $opts(database) $scm_priv] } - trap { - set svch [OpenService $scm $name $opts(svc_priv)] - } finally { - # No need for scm handle anymore. Close it unless it was - # passed to us - if {(![info exists opts(scm_handle)]) || - ($opts(scm_handle) eq "")} { - CloseServiceHandle $scm - } - } - - set proc_args [expr {[info exists opts(args)] ? $opts(args) : ""}] - trap { - set results [eval [list $opts(proc) $svch] $proc_args] - } finally { - CloseServiceHandle $svch - } - - return $results -} - -# Called back for reporting background errors. Note this is called -# from the C++ services code, not from scripts. -proc twapi::_service_background_error {winerror msg} { - twapi::win32_error $winerror $msg -} - -# Parse symbols for controls accepted by a service -proc twapi::_parse_service_accept_controls {controls} { - return [_parse_symbolic_bitmask $controls { - stop 0x00000001 - pause_continue 0x00000002 - shutdown 0x00000004 - paramchange 0x00000008 - netbindchange 0x00000010 - hardwareprofilechange 0x00000020 - powerevent 0x00000040 - sessionchange 0x00000080 - }] -} diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/share.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/share.tcl deleted file mode 100644 index 76809064..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/share.tcl +++ /dev/null @@ -1,966 +0,0 @@ -# -# 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}]] -} diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/shell.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/shell.tcl deleted file mode 100644 index b471e2e7..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/shell.tcl +++ /dev/null @@ -1,627 +0,0 @@ -# -# 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 -} diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/sspi.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/sspi.tcl deleted file mode 100644 index aa4ec70e..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/sspi.tcl +++ /dev/null @@ -1,801 +0,0 @@ -# -# 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 - } - -} diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/storage.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/storage.tcl deleted file mode 100644 index 72bd2d73..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/storage.tcl +++ /dev/null @@ -1,616 +0,0 @@ -# -# 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]}] -} - - diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/synch.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/synch.tcl deleted file mode 100644 index eabf5a71..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/synch.tcl +++ /dev/null @@ -1,94 +0,0 @@ -# -# 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] -} diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/tls.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/tls.tcl deleted file mode 100644 index 977ac751..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/tls.tcl +++ /dev/null @@ -1,1296 +0,0 @@ -# -# Copyright (c) 2012-2020, Ashok P. Nadkarni -# All rights reserved. -# -# See the file LICENSE for license -namespace eval twapi::tls { - # Each element of _channels is dictionary with the following keys - # Socket - the underlying socket. This key will not exist if - # socket has been closed. - # State - SERVERINIT, CLIENTINIT, LISTENERINIT, OPEN, NEGOTIATING, CLOSED - # Type - SERVER, CLIENT, LISTENER - # Blocking - 0/1 indicating whether blocking or non-blocking channel - # WatchMask - list of {read write} indicating what events to post - # Target - Name for server cert - # Credentials - credentials handle to use for local end of connection - # FreeCredentials - if credentials should be freed on connection cleanup - # AcceptCallback - application callback on a listener and server socket. - # On listener, it is the accept command prefix. On a server - # (accepted socket) it is the prefix plus arguments passed to - # accept callback. On client and on servers sockets initialized - # with starttls, this key must NOT be present - # SspiContext - SSPI context for the connection - # Input - plaintext data to pass to app - # Output - plaintext data to encrypt and output - # ReadEventPosted - if this key exists, a chan postevent for read - # is already in progress and a second one should not be posted - # WriteEventPosted - if this key exists, a chan postevent for write - # is already in progress and a second one should not be posted - # WriteDisabled - 0 normally. Set to 1 on a half-close - - variable _channels - array set _channels {} - - # Socket command - Tcl socket by default. - variable _socket_cmd ::socket - - namespace path [linsert [namespace path] 0 [namespace parent]] - -} - -proc twapi::tls_socket_command {args} { - set orig_command $tls::_socket_cmd - if {[llength $args] == 1} { - set tls::_socket_cmd [lindex $args 0] - } elseif {[llength $args] != 0} { - error "wrong # args: should be \"tls_socket_command ?cmd?\"" - } - return $orig_command -} - -interp alias {} twapi::tls_socket {} twapi::tls::_socket -proc twapi::tls::_socket {args} { - variable _channels - variable _socket_cmd - - debuglog [info level 0] - - parseargs args { - myaddr.arg - myport.int - async - socketcmd.arg - server.arg - peersubject.arg - requestclientcert - {credentials.arg {}} - {verifier.arg {}} - } -setvars - - set chan [chan create {read write} [list [namespace current]]] - # NOTE: We were originally using badargs! instead of error to raise - # exceptions. However that lands up bypassing the trap because of - # the way badargs! is implemented. So stick to error. - trap { - set socket_args {} - foreach opt {myaddr myport} { - if {[info exists $opt]} { - lappend socket_args -$opt [set $opt] - } - } - if {$async} { - lappend socket_args -async - } - - if {[info exists server]} { - if {$server eq ""} { - error "Cannot specify an empty value for -server." - } - - if {[info exists peersubject]} { - error "Option -peersubject cannot be specified for with -server" - } - set peersubject "" - set type LISTENER - lappend socket_args -server [list [namespace current]::_accept $chan] - if {[llength $credentials] == 0} { - error "Option -credentials must be specified for server sockets" - } - } else { - if {![info exists peersubject]} { - set peersubject [lindex $args 0] - } - set requestclientcert 0; # Not valid for client side - set server "" - set type CLIENT - } - - if {[info exists socketcmd]} { - if {$socketcmd eq ""} { - set socketcmd ::socket - } - } else { - set socketcmd $_socket_cmd - } - } onerror {} { - catch {chan close $chan} - rethrow - } - trap { - set so [$socketcmd {*}$socket_args {*}$args] - _init $chan $type $so $credentials $peersubject $requestclientcert [lrange $verifier 0 end] $server - - if {$type eq "CLIENT"} { - if {$async} { - chan event $so writable [list [namespace current]::_so_write_handler $chan] - } else { - _client_blocking_negotiate $chan - if {(![info exists _channels($chan)]) || - [dict get $_channels($chan) State] ne "OPEN"} { - if {[info exists _channels($chan)] && - [dict exists $_channels($chan) ErrorResult]} { - error [dict get $_channels($chan) ErrorResult] - } else { - error "TLS negotiation aborted" - } - } - } - } - } onerror {} { - # If _init did not even go as far initializing _channels($chan), - # close socket ourselves. If it was initialized, the socket - # would have been closed even on error - if {![info exists _channels($chan)]} { - catch {chan close $so} - } - catch {chan close $chan} - # DON'T ACCESS _channels HERE ON - if {[string match "wrong # args*" [trapresult]]} { - badargs! "wrong # args: should be \"tls_socket ?-credentials creds? ?-verifier command? ?-peersubject peer? ?-myaddr addr? ?-myport myport? ?-async? host port\" or \"tls_socket ?-credentials creds? ?-verifier command? -server command ?-myaddr addr? port\"" - } else { - rethrow - } - } - - return $chan -} - -interp alias {} twapi::starttls {} twapi::tls::_starttls -proc twapi::tls::_starttls {so args} { - variable _channels - - debuglog [info level 0] - - trap { - parseargs args { - server - requestclientcert - peersubject.arg - {credentials.arg {}} - {verifier.arg {}} - } -setvars -maxleftover 0 - - if {$server} { - if {[info exists peersubject]} { - badargs! "Option -peersubject cannot be specified with -server." - } - if {[llength $credentials] == 0} { - error "Option -credentials must be specified for server sockets." - } - set peersubject "" - set type SERVER - } else { - set requestclientcert 0; # Ignored for client side - if {![info exists peersubject]} { - # TBD - even if verifier is specified ? - badargs! "Option -peersubject must be specified for client connections." - } - set type CLIENT - } - set chan [chan create {read write} [list [namespace current]]] - } onerror {} { - chan close $so - rethrow - } - trap { - # Get config from the wrapped socket and reset its handlers - # Do not get all options because that results in reverse name - # lookups for -peername and -sockname causing a stall. - foreach opt { - -blocking -buffering -buffersize -encoding -eofchar -translation - } { - lappend so_opts $opt [chan configure $so $opt] - } - - # NOTE: we do NOT save read and write handlers and attach - # them to the new channel because the channel name is different. - # Thus in most cases the callbacks, which often are passed the - # channel name as an arg, would not be valid. It is up - # to the caller to reestablish handlers - # TBD - maybe keep handlers but replace $so with $chan in them ? - chan event $so readable {} - chan event $so writable {} - _init $chan $type $so $credentials $peersubject $requestclientcert [lrange $verifier 0 end] "" - # Copy saved config to wrapper channel - chan configure $chan {*}$so_opts - if {$type eq "CLIENT"} { - if {[dict get $_channels($chan) Blocking]} { - _client_blocking_negotiate $chan - if {(![info exists _channels($chan)]) || - [dict get $_channels($chan) State] ne "OPEN"} { - if {[info exists _channels($chan)] && - [dict exists $_channels($chan) ErrorResult]} { - error [dict get $_channels($chan) ErrorResult] - } else { - error "TLS negotiation aborted" - } - } - } else { - _negotiate $chan - } - } else { - # Note: unlike the tls_socket server case, here we - # do not need to switch a blocking socket to non-blocking - # and then switch back, primarily because the socket - # is already open and there is no need for a callback - # when connection opens. - if {! [dict get $_channels($chan) Blocking]} { - chan configure $so -blocking 0 - chan event $so readable [list [namespace current]::_so_read_handler $chan] - } - _negotiate $chan - } - } onerror {} { - # If _init did not even go as far initializing _channels($chan), - # close socket ourselves. If it was initialized, the socket - # would have been closed even on error - if {![info exists _channels($chan)]} { - catch {chan close $so} - } - catch {chan close $chan} - # DON'T ACCESS _channels HERE ON - if {[string match "wrong # args*" [trapresult]]} { - badargs! "wrong # args: should be \"tls_socket ?-credentials creds? ?-verifier command? ?-peersubject peer? ?-myaddr addr? ?-myport myport? ?-async? host port\" or \"tls_socket ?-credentials creds? ?-verifier command? -server command ?-myaddr addr? port\"" - } else { - rethrow - } - } - - return $chan -} - -interp alias {} twapi::tls_state {} twapi::tls::_state -proc twapi::tls::_state {chan} { - variable _channels - if {![info exists _channels($chan)]} { - twapi::badargs! "Not a valid TLS channel." - } - return [dict get $_channels($chan) State] -} - -interp alias {} twapi::tls_handshake {} twapi::tls::_handshake -proc twapi::tls::_handshake {chan} { - variable _channels - if {![info exists _channels($chan)]} { - twapi::badargs "Not a valid TLS channel." - } - - dict with _channels($chan) {} - - # For a blocking channel, complete the handshake before returning - if {$Blocking} { - switch -exact $State { - NEGOTIATING - CLIENTINIT - SERVERINIT { - _negotiate2 $chan - } - OPEN {} - LISTERNERINIT { - error "Cannot do a TLS handshake on a listening socket." - } - CLOSED - - default { - error "Channel has been closed or in error state." - } - } - } else { - # For non-blocking channels, simply return the state - switch -exact -- $State { - OPEN {} - CLIENTINIT - SERVERINIT - LISTENERINIT - NEGOTIATING { - return 0 - } - CLOSED - default { - error "Channel has been closed or in error state." - } - } - } - return 1 -} - -proc twapi::tls::_accept {listener so raddr raport} { - variable _channels - - debuglog [info level 0] - - trap { - set chan [chan create {read write} [list [namespace current]]] - _init $chan SERVER $so [dict get $_channels($listener) Credentials] "" [dict get $_channels($listener) RequestClientCert] [dict get $_channels($listener) Verifier] [linsert [dict get $_channels($listener) AcceptCallback] end $chan $raddr $raport] - # If we negotiate the connection, the socket is blocking so - # will hang the whole operation. Instead we mark it non-blocking - # and the switch back to blocking when the connection gets opened. - # For accepts to work, the event loop has to be running anyways. - chan configure $so -blocking 0 - chan event $so readable [list [namespace current]::_so_read_handler $chan] - _negotiate $chan - } onerror {} { - catch {_cleanup $chan} - rethrow - } - return -} - -proc twapi::tls::initialize {chan mode} { - debuglog [info level 0] - - # All init is done in chan creation routine after base socket is created - return {initialize finalize watch blocking read write configure cget cgetall} -} - -proc twapi::tls::finalize {chan} { - debuglog [info level 0] - _cleanup $chan - return -} - -proc twapi::tls::blocking {chan mode} { - debuglog [info level 0] - - variable _channels - - dict set _channels($chan) Blocking $mode - - if {![dict exists $_channels($chan) Socket]} { - # We do not currently generate an error because the Tcl socket - # command does not either on a fconfigure when remote has - # closed connection - return - } - set so [dict get $_channels($chan) Socket] - fconfigure $so -blocking $mode - - # There is an issue with Tcl sockets created with -async switching - # from blocking->non-blocking->blocking and writing to the socket - # before connection is fully open. The internal buffers containing - # data that was written before the connection was open do not get - # flushed even if there was an explicit flush call by the application. - # Doing a flush after changing blocking mode seems to fix this - # problem. TBD - check if still the case - flush $so - - # TBD - Should we change handlers BEFORE flushing? - - # The flush may recursively call event handler (possibly) which - # may change state so have to retrieve values from _channels again. - if {![dict exists $_channels($chan) Socket]} { - return - } - set so [dict get $_channels($chan) Socket] - - if {[dict get $_channels($chan) Blocking] == 0} { - # Non-blocking - # Since we need to negotiate TLS we always have socket event - # handlers irrespective of the state of the watch mask - chan event $so readable [list [namespace current]::_so_read_handler $chan] - chan event $so writable [list [namespace current]::_so_write_handler $chan] - } else { - # TBD - is this right? Application may have file event handlers even - # on blocking sockets - chan event $so readable {} - chan event $so writable {} - } - return -} - -proc twapi::tls::watch {chan watchmask} { - debuglog [info level 0] - variable _channels - - dict set _channels($chan) WatchMask $watchmask - - if {"read" in $watchmask} { - # Post a read even if we already have input or if the - # underlying socket has gone away. - # TBD - do we have a mechanism for continuously posting - # events when socket has gone away ? Do we even post once - # when socket is closed (on error for example) - if {[string length [dict get $_channels($chan) Input]] || ![dict exists $_channels($chan) Socket]} { - _post_read_event $chan - } - # Turn read handler back on in case it had been turned off. - chan event [dict get $_channels($chan) Socket] readable [list [namespace current]::_so_read_handler $chan] - } - - if {"write" in [dict get $_channels($chan) WatchMask]} { - if {[dict get $_channels($chan) State] in {OPEN NEGOTIATING CLOSED} } { - _post_write_event $chan - } - # TBD - do we need to turn write handler back on? - } - - return -} - -proc twapi::tls::read {chan nbytes} { - variable _channels - - debuglog [info level 0] - - if {$nbytes == 0} { - return {} - } - - # This is not inside the dict with because _negotiate will update the dict - if {[dict get $_channels($chan) State] in {SERVERINIT CLIENTINIT NEGOTIATING}} { - _negotiate $chan - if {[dict get $_channels($chan) State] in {SERVERINIT CLIENTINIT NEGOTIATING}} { - # If a blocking channel, should have come back with negotiation - # complete. If non-blocking, return EAGAIN to indicate no - # data yet - if {[dict get $_channels($chan) Blocking]} { - error "TLS negotiation failed on blocking channel" - } else { - return -code error EAGAIN - } - } - } - - dict with _channels($chan) { - # Either in OPEN or CLOSED state. For the latter, if an error is - # present, immediately raise it else go on to return any pending data. - if {$State eq "CLOSED" && [info exists ErrorResult]} { - error $ErrorResult - } - # Try to read more bytes if don't have enough AND conn is open - set status ok - if {[string length $Input] < $nbytes && $State eq "OPEN"} { - if {$Blocking} { - # For blocking channels, we do not want to block if some - # bytes are already available. The refchan will call us - # with number of bytes corresponding to its buffer size, - # not what app's read call has asked. It expects us - # to return whatever we have (but at least one byte) - # and block only if nothing is available - while {[string length $Input] == 0 && $status eq "ok"} { - # The channel does not compress so we need to read in - # at least $needed bytes. Because of TLS overhead, we may - # actually need even more - set status ok - set data [_blocking_read $Socket] - if {[string length $data]} { - lassign [sspi_decrypt_stream $SspiContext $data] status plaintext - # Note plaintext might be "" if complete cipher block - # was not received - append Input $plaintext - } else { - set status eof - } - } - } else { - # Non-blocking - read all that we can - set status ok - set data [chan read $Socket] - if {[string length $data]} { - lassign [sspi_decrypt_stream $SspiContext $data] status plaintext - append Input $plaintext - } else { - if {[chan eof $Socket]} { - set status eof - } - } - if {[string length $Input] == 0} { - # Do not have enough data. See if connection closed - # TBD - also handle status == renegotiate - if {$status eq "ok"} { - # Not closed, just waiting for data - return -code error EAGAIN - } - } - } - } - - # TBD - use inline K operator to make this faster? Probably no use - # since Input is also referred to from _channels($chan) - set ret [string range $Input 0 $nbytes-1] - set Input [string range $Input $nbytes end] - if {"read" in [dict get $_channels($chan) WatchMask] && [string length $Input]} { - _post_read_event $chan - } - if {$status ne "ok"} { - # TBD - handle renegotiate - debuglog "read: setting State CLOSED" - - # Need a EOF event even if read event posted. See Bug #203 - _post_eof_event $chan - set State CLOSED - lassign [sspi_shutdown_context $SspiContext] _ outdata - if {[info exists Socket]} { - if {[string length $outdata] && $status ne "eof"} { - puts -nonewline $Socket $outdata - } - catch {close $Socket} - unset Socket - } - } - return $ret; # Note ret may be "" - } -} - -proc twapi::tls::write {chan data} { - variable _channels - - set datalen [string length $data] - debuglog "twapi::tls::write: $chan, $datalen bytes" - - # This is not inside the dict with below because _negotiate will update the dict - if {[dict get $_channels($chan) State] in {SERVERINIT CLIENTINIT NEGOTIATING}} { - _negotiate $chan - if {[dict get $_channels($chan) State] in {SERVERINIT CLIENTINIT NEGOTIATING}} { - if {[dict get $_channels($chan) Blocking]} { - # If a blocking channel, negotiation should have completed - error "TLS negotiation failed on blocking channel" - } else { - # TBD - which of the following alternatives to use? - if {1} { - # Store for later output once connection is open - debuglog "twapi::tls::write conn not open, appending $datalen bytes to pending output" - dict append _channels($chan) Output $data - return $datalen - } else { - # If non-blocking, return EAGAIN to indicate channel - # not open yet. - debuglog "twapi::tls::write returning EAGAIN" - return -code error EAGAIN - } - } - } - } - - dict with _channels($chan) { - debuglog "twapi::tls::write state $State" - switch $State { - CLOSED { - # Just like a Tcl socket, we do not raise an error on a - # write to a closed socket. Simply throw away the data/ - # However, if an error already exists (negotiation fail) - # raise it. - if {[info exists ErrorResult]} { - error $ErrorResult - } - } - OPEN { - if {$WriteDisabled} { - error "Channel closed for output." - } - # There might be pending output if channel has just - # transitioned to OPEN state - _flush_pending_output $chan - # TBD - use sspi_encrypt_and_write instead - chan puts -nonewline $Socket [sspi_encrypt_stream $SspiContext $data] - flush $Socket - } - default { - append Output $data - } - } - } - debuglog "twapi::tls::write returning $datalen" - return $datalen -} - -proc twapi::tls::configure {chan opt val} { - debuglog [info level 0] - # Does not make sense to change creds and verifier after creation - switch $opt { - -context - - -verifier - - -credentials { - error "$opt is a read-only option." - } - default { - chan configure [_chansocket $chan] $opt $val - } - } - - return -} - -proc twapi::tls::cget {chan opt} { - debuglog [info level 0] - variable _channels - - switch $opt { - -credentials { - return [dict get $_channels($chan) Credentials] - } - -verifier { - return [dict get $_channels($chan) Verifier] - } - -context { - return [dict get $_channels($chan) SspiContext] - } - -error { - if {[dict exists $_channels($chan) ErrorResult]} { - set result "[dict get $_channels($chan) ErrorResult]" - if {$result ne ""} { - return $result - } - } - # Get -error from underlying socket - # -error should not raise an error but return the error as result - catch {chan configure [_chansocket $chan] -error} result - return $result - } - default { - return [chan configure [_chansocket $chan] $opt] - } - } -} - -proc twapi::tls::cgetall {chan} { - debuglog [info level 0] - variable _channels - dict with _channels($chan) { - if {[info exists Socket]} { - # First get all options underlying socket supports. Note this may - # or may not a Tcl native socket. - array set so_config [chan configure $Socket] - # Only return options that are not owned by the core channel code - # and apply to the $chan itself. - foreach {opt val} [chan configure $Socket] { - if {$opt ni {-blocking -buffering -buffersize -encoding -eofchar -translation}} { - lappend config $opt $val - } - } - } - lappend config -credentials $Credentials \ - -verifier $Verifier \ - -context $SspiContext - } - return $config -} - -# Implement a half-close command since Tcl does not support it for -# reflected channels. -interp alias {} twapi::tls_close {} twapi::tls::_close -proc twapi::tls::_close {chan {direction ""}} { - - if {$direction in {read r re rea}} { - error "Half close of input side not currently supported for TLS sockets." - } - - # We handle write-side half-closes. Let Tcl close handle everything else. - if {$direction ni {write w wr wri writ}} { - return [close $chan] - } - - # Closing the write side of the channel - - variable _channels - - dict with _channels($chan) {} - if {$State eq "CLOSED"} return - if {$State ne "OPEN"} { - error "Connection not in OPEN state." - } - flush $chan - # Note state may have changed - if {[dict get $_channels($chan) State] ne "OPEN"} { - return - } - # Flush internally buffered, if any. Can happen if we buffered - # data before TLS negotiation was complete. - _flush_pending_output $chan - close $Socket write - dict set _channels($chan) WriteDisabled 1 - return -} - -proc twapi::tls::_chansocket {chan} { - debuglog [info level 0] - variable _channels - if {![info exists _channels($chan)]} { - error "Channel $chan not found." - } - if {![dict exists $_channels($chan) Socket]} { - set error "Socket not connected." - if {[dict exists $_channels($chan) ErrorResult]} { - append error " [dict get $_channels($chan) ErrorResult]" - } - error $error - } - return [dict get $_channels($chan) Socket] -} - -proc twapi::tls::_init {chan type so creds peersubject requestclientcert verifier {accept_callback {}}} { - debuglog [info level 0] - variable _channels - - # TBD - verify that -buffering none is the right thing to do - # as the scripted channel interface takes care of this itself - chan configure $so -translation binary -buffering none - set _channels($chan) [list Socket $so \ - State ${type}INIT \ - Type $type \ - Blocking [chan configure $so -blocking] \ - WatchMask {} \ - WriteDisabled 0 \ - RequestClientCert $requestclientcert \ - Verifier $verifier \ - SspiContext {} \ - PeerSubject $peersubject \ - Input {} Output {}] - - if {[llength $creds]} { - set free_creds 0 - } else { - set creds [sspi_acquire_credentials -package tls -role client -credentials [sspi_schannel_credentials]] - set free_creds 1 - } - dict set _channels($chan) Credentials $creds - dict set _channels($chan) FreeCredentials $free_creds - - # See SF issue #178. Need to supply -usesuppliedcreds to sspi_client_context - # else servers that request (even optionally) client certs might fail since - # we do not currently implement incomplete credentials handling. This - # option will prevent schannel from trying to automatically look up client - # certificates. - dict set _channels($chan) UseSuppliedCreds 0; # TBD - make this use settable option - - if {[string length $accept_callback] && - ($type eq "LISTENER" || $type eq "SERVER")} { - dict set _channels($chan) AcceptCallback $accept_callback - } -} - -proc twapi::tls::_cleanup {chan} { - debuglog [info level 0] - variable _channels - if {[info exists _channels($chan)]} { - # Note _cleanup can be called in inconsistent state so not all - # keys may be set up - dict with _channels($chan) { - if {[info exists SspiContext]} { - if {$State eq "OPEN"} { - lassign [sspi_shutdown_context $SspiContext] _ outdata - if {[string length $outdata] && [info exists Socket]} { - if {[catch {puts -nonewline $Socket $outdata} msg]} { - # TBD - debug log - } - } - } - if {[catch {sspi_delete_context $SspiContext} msg]} { - # TBD - debug log - } - } - if {[info exists Socket]} { - if {[catch {chan close $Socket} msg]} { - # TBD - debug log socket close error - } - } - if {[info exists Credentials] && $FreeCredentials} { - if {[catch {sspi_free_credentials $Credentials} msg]} { - # TBD - debug log - } - } - } - unset _channels($chan) - } -} - -proc twapi::tls::_cleanup_failed_accept {chan} { - debuglog [info level 0] - variable _channels - # This proc is called from the event loop when negotiation fails - # on a server TLS channel that is not yet open (and hence not - # known to the application). For some protection against - # channel name re-use (which does not happen as of 8.6) - # check the state before cleaning up. - if {[info exists _channels($chan)] && - [dict get $_channels($chan) Type] eq "SERVER" && - [dict get $_channels($chan) State] eq "CLOSED"} { - close $chan; # Really close - } -} - -if {[llength [info commands ::twapi::tls_background_error]] == 0} { - proc twapi::tls_background_error {result ropts} { - return -options $ropts $result - } -} - -proc twapi::tls::_negotiate_from_handler {chan} { - # Called from socket read / write handlers if - # negotiation is still in progress. - # Returns the error code from next step of - # negotiation. - # 1 -> ok, - # 0 -> some error occured, most likely negotiation failure - variable _channels - if {[catch {_negotiate $chan} result ropts]} { - if {![dict exists $_channels($chan) ErrorResult]} { - dict set _channels($chan) ErrorResult $result - } - if {"read" in [dict get $_channels($chan) WatchMask]} { - _post_read_event $chan - } - if {"write" in [dict get $_channels($chan) WatchMask]} { - _post_write_event $chan - } - # For SERVER sockets, force error because no other way - # to record some error happened. - if {[dict get $_channels($chan) Type] eq "SERVER"} { - ::twapi::tls_background_error $result $ropts - # Above should raise an error, else do it ourselves - # since stack needs to be rewound - return -options $ropts $result - } - return 0 - } - return 1 -} - -proc twapi::tls::_so_read_handler {chan} { - debuglog [info level 0] - variable _channels - - if {[info exists _channels($chan)]} { - if {[dict get $_channels($chan) State] in {SERVERINIT CLIENTINIT NEGOTIATING}} { - if {![_negotiate_from_handler $chan]} { - return - } - } - - if {"read" in [dict get $_channels($chan) WatchMask]} { - _post_read_event $chan - } else { - # We are not asked to generate read events, turn off the read - # event handler unless we are negotiating - if {[dict get $_channels($chan) State] ni {SERVERINIT CLIENTINIT NEGOTIATING}} { - if {[dict exists $_channels($chan) Socket]} { - chan event [dict get $_channels($chan) Socket] readable {} - } - } - } - } - return -} - -proc twapi::tls::_so_write_handler {chan} { - debuglog [info level 0] - variable _channels - - if {[info exists _channels($chan)]} { - dict with _channels($chan) {} - - # If we are not actually asked to generate write events, - # the only time we want a write handler is on a client -async - # Once it runs, we never want it again else it will keep triggering - # as sockets are always writable - if {"write" ni $WatchMask} { - if {[info exists Socket]} { - chan event $Socket writable {} - } - } - - if {$State in {SERVERINIT CLIENTINIT NEGOTIATING}} { - if {![_negotiate_from_handler $chan]} { - # TBD - should we throw so bgerror gets run? - return - } - } - - # Do not use local var $State because _negotiate might have updated it - if {"write" in $WatchMask && [dict get $_channels($chan) State] eq "OPEN"} { - _post_write_event $chan - } - } - return -} - -proc twapi::tls::_negotiate chan { - debuglog [info level 0] - trap { - _negotiate2 $chan - } onerror {} { - variable _channels - if {[info exists _channels($chan)]} { - if {[dict get $_channels($chan) Type] eq "SERVER" && - [dict get $_channels($chan) State] in {SERVERINIT NEGOTIATING}} { - # There is no one to clean up accepted sockets (server) that - # fail verification (or error out) since application does - # not know about them. So queue some garbage - # cleaning. - after 0 [namespace current]::_cleanup_failed_accept $chan - } - dict set _channels($chan) State CLOSED - dict set _channels($chan) ErrorOptions [trapoptions] - dict set _channels($chan) ErrorResult [trapresult] - if {[dict exists $_channels($chan) Socket]} { - catch {close [dict get $_channels($chan) Socket]} - dict unset _channels($chan) Socket - } - } - rethrow - } -} - -proc twapi::tls::_negotiate2 {chan} { - variable _channels - - dict with _channels($chan) {}; # dict -> local vars - - debuglog [info level 0] - switch $State { - NEGOTIATING { - if {$Blocking && ![info exists AcceptCallback]} { - return [_blocking_negotiate_loop $chan] - } - - set data [chan read $Socket] - if {[string length $data] == 0} { - if {[chan eof $Socket]} { - throw {TWAPI TLS NEGOTIATE EOF} "Unexpected EOF during TLS negotiation (NEGOTIATING)" - } else { - # No data yet, just keep waiting - debuglog "Waiting (chan $chan) for more data on Socket $Socket" - return - } - } else { - lassign [sspi_step $SspiContext $data] status outdata leftover - debuglog "sspi_step returned status $status with [string length $outdata] bytes" - if {[string length $outdata]} { - chan puts -nonewline $Socket $outdata - chan flush $Socket - } - switch $status { - done { - if {[string length $leftover]} { - lassign [sspi_decrypt_stream $SspiContext $leftover] status plaintext - dict append _channels($chan) Input $plaintext - if {$status ne "ok"} { - # TBD - shutdown channel or let _cleanup do it? - } - } - _open $chan - } - continue { - # Keep waiting for next input - } - default { - debuglog "sspi_step returned $status" - error "Unexpected status $status from sspi_step" - } - } - } - } - - CLIENTINIT { - if {$Blocking} { - _client_blocking_negotiate $chan - } else { - dict set _channels($chan) State NEGOTIATING - set SspiContext [sspi_client_context $Credentials -usesuppliedcreds $UseSuppliedCreds -stream 1 -target $PeerSubject -manualvalidation [expr {[llength $Verifier] > 0}]] - dict set _channels($chan) SspiContext $SspiContext - lassign [sspi_step $SspiContext] status outdata - if {[string length $outdata]} { - chan puts -nonewline $Socket $outdata - chan flush $Socket - } - if {$status ne "continue"} { - error "Unexpected status $status from sspi_step" - } - } - } - - SERVERINIT { - # For server sockets created from tls_socket, we - # always take the non-blocking path as we set the socket - # to be non-blocking so as to not hold up the whole app - # For server sockets created with starttls - # (AcceptCallback will not exist), we can do a blocking - # negotiate. - if {$Blocking && ![info exists AcceptCallback]} { - _server_blocking_negotiate $chan - } else { - set data [chan read $Socket] - if {[string length $data] == 0} { - if {[chan eof $Socket]} { - throw {TWAPI TLS NEGOTIATE EOF} "Unexpected EOF during TLS negotiation (SERVERINIT)" - } else { - # No data yet, just keep waiting - debuglog "$chan: no data from socket $Socket. Waiting..." - return - } - } else { - debuglog "Setting $chan State=NEGOTIATING" - - dict set _channels($chan) State NEGOTIATING - set SspiContext [sspi_server_context $Credentials $data -stream 1 -mutualauth $RequestClientCert] - dict set _channels($chan) SspiContext $SspiContext - lassign [sspi_step $SspiContext] status outdata leftover - debuglog "sspi_step returned status $status with [string length $outdata] bytes" - if {[string length $outdata]} { - debuglog "Writing [string length $outdata] bytes to socket $Socket" - chan puts -nonewline $Socket $outdata - chan flush $Socket - } - switch $status { - done { - if {[string length $leftover]} { - lassign [sspi_decrypt_stream $SspiContext $leftover] status plaintext - dict append _channels($chan) Input $plaintext - if {$status ne "ok"} { - # TBD - shut down channel - } - } - debuglog "Marking channel $chan open" - _open $chan - } - continue { - # Keep waiting for next input - } - default { - error "Unexpected status $status from sspi_step" - } - } - } - } - } - - default { - error "Internal error: _negotiate called in state [dict get $_channels($chan) State]" - } - } - - return -} - -proc twapi::tls::_client_blocking_negotiate {chan} { - debuglog [info level 0] - variable _channels - dict with _channels($chan) { - set State NEGOTIATING - set SspiContext [sspi_client_context $Credentials -usesuppliedcreds $UseSuppliedCreds -stream 1 -target $PeerSubject -manualvalidation [expr {[llength $Verifier] > 0}]] - } - return [_blocking_negotiate_loop $chan] -} - -proc twapi::tls::_server_blocking_negotiate {chan} { - debuglog [info level 0] - variable _channels - dict set _channels($chan) State NEGOTIATING - set so [dict get $_channels($chan) Socket] - set indata [_blocking_read $so] - if {[chan eof $so]} { - throw {TWAPI TLS NEGOTIATE EOF} "Unexpected EOF during TLS negotiation (server)." - } - dict set _channels($chan) SspiContext [sspi_server_context [dict get $_channels($chan) Credentials] $indata -stream 1 -mutualauth [dict get $_channels($chan) RequestClientCert]] - return [_blocking_negotiate_loop $chan] -} - -proc twapi::tls::_blocking_negotiate_loop {chan} { - debuglog [info level 0] - variable _channels - - dict with _channels($chan) {}; # dict -> local vars - - lassign [sspi_step $SspiContext] status outdata - debuglog "sspi_step status $status" - # Keep looping as long as the SSPI state machine tells us to - while {$status eq "continue"} { - # If the previous step had any output, send it out - if {[string length $outdata]} { - debuglog "Writing [string length $outdata] to socket $Socket" - chan puts -nonewline $Socket $outdata - chan flush $Socket - } - - set indata [_blocking_read $Socket] - debuglog "Read [string length $indata] from socket $Socket" - if {[chan eof $Socket]} { - throw {TWAPI TLS NEGOTIATE EOF} "Unexpected EOF during TLS negotiation." - } - trap { - lassign [sspi_step $SspiContext $indata] status outdata leftover - } onerror {} { - debuglog "sspi_step returned error: [trapresult]" - close $Socket - unset Socket - rethrow - } - debuglog "sspi_step status $status" - } - - # Send output irrespective of status - if {[string length $outdata]} { - chan puts -nonewline $Socket $outdata - chan flush $Socket - } - - if {$status eq "done"} { - if {[string length $leftover]} { - lassign [sspi_decrypt_stream $SspiContext $leftover] status plaintext - dict append _channels($chan) Input $plaintext - if {$status ne "ok"} { - error "Error status $status decrypting data" - } - } - _open $chan - } else { - # Should not happen. Negotiation failures will raise an error, - # not return a value - error "TLS negotiation failed: status $status." - } - - return -} - -proc twapi::tls::_blocking_read {so} { - debuglog [info level 0] - # Read from a blocking socket. We do not know how much data is needed - # so read a single byte and then read any pending - set input [chan read $so 1] - if {[string length $input]} { - set more [chan pending input $so] - if {$more > 0} { - append input [chan read $so $more] - } - } - return $input -} - -proc twapi::tls::_flush_pending_output {chan} { - variable _channels - - dict with _channels($chan) { - if {[string length $Output]} { - debuglog "_flush_pending_output: flushing output" - puts -nonewline $Socket [sspi_encrypt_stream $SspiContext $Output] - set Output "" - } - } - return -} - -# Transitions connection to OPEN or throws error if verifier returns false -# or fails -proc twapi::tls::_open {chan} { - debuglog [info level 0] - variable _channels - - dict with _channels($chan) {}; # dict -> local vars - - if {[llength $Verifier] == 0} { - # No verifier specified. In this case, we would not have specified - # -manualvalidation in creating the context and the system would - # have done the verification already for client. For servers, - # there is no verification of clients to be done by default - - # For compatibility with TLS we call accept callbacks AFTER verification - dict set _channels($chan) State OPEN - if {[info exists AcceptCallback]} { - # Server sockets are set up to be non-blocking during negotiation - # Change them back to original state before notifying app - chan configure $Socket -blocking [dict get $_channels($chan) Blocking] - chan event $Socket readable {} - after 0 $AcceptCallback - } - # If there is any pending output waiting for the connection to - # open, write it out - _flush_pending_output $chan - - return - } - - # TBD - what if verifier closes the channel - if {[{*}$Verifier $chan $SspiContext]} { - dict set _channels($chan) State OPEN - # For compatibility with TLS we call accept callbacks AFTER verification - if {[info exists AcceptCallback]} { - # Server sockets are set up to be non-blocking during - # negotiation. Change them back to original state - # before notifying app - chan configure $Socket -blocking [dict get $_channels($chan) Blocking] - chan event $Socket readable {} - after 0 $AcceptCallback - } - _flush_pending_output $chan - return - } else { - error "SSL/TLS negotiation failed. Verifier callback returned false." "" [list TWAPI TLS VERIFYFAIL] - } -} - -# Calling [chan postevent] results in filevent handlers being called right -# away which can recursively call back into channel code making things -# more than a bit messy. So we always schedule them through the event loop -proc twapi::tls::_post_read_event_callback {chan} { - debuglog [info level 0] - variable _channels - if {[info exists _channels($chan)]} { - dict unset _channels($chan) ReadEventPosted - if {"read" in [dict get $_channels($chan) WatchMask]} { - chan postevent $chan read - } - } -} -proc twapi::tls::_post_read_event {chan} { - debuglog [info level 0] - variable _channels - if {![dict exists $_channels($chan) ReadEventPosted]} { - # Note after 0 after idle does not work - (never get called) - # not sure why so just do after 0 - dict set _channels($chan) ReadEventPosted \ - [after 0 [namespace current]::_post_read_event_callback $chan] - } -} -proc twapi::tls::_post_eof_event_callback {chan} { - debuglog [info level 0] - variable _channels - if {[info exists _channels($chan)]} { - if {"read" in [dict get $_channels($chan) WatchMask]} { - chan postevent $chan read - } - } -} -proc twapi::tls::_post_eof_event {chan} { - # EOF events are always generated event if a read event is already posted. - # See Bug #203 - debuglog [info level 0] - after 0 [namespace current]::_post_eof_event_callback $chan -} - - -proc twapi::tls::_post_write_event_callback {chan} { - debuglog [info level 0] - variable _channels - if {[info exists _channels($chan)]} { - dict unset _channels($chan) WriteEventPosted - if {"write" in [dict get $_channels($chan) WatchMask]} { - # NOTE: we do not check state here as we should generate an event - # even in the CLOSED state - see Bug #206 - chan postevent $chan write - } - } -} -proc twapi::tls::_post_write_event {chan} { - debuglog [info level 0] - variable _channels - if {![dict exists $_channels($chan) WriteEventPosted]} { - # Note after 0 after idle does not work - (never get called) - # not sure why so just do after 0 - dict set _channels($chan) WriteEventPosted \ - [after 0 [namespace current]::_post_write_event_callback $chan] - } -} - -namespace eval twapi::tls { - namespace ensemble create -subcommands { - initialize finalize blocking watch read write configure cget cgetall - } -} - -proc twapi::tls::sample_server_creds pfxFile { - set fd [open $pfxFile rb] - set pfx [read $fd] - close $fd - # Set up the store containing the certificates - set certStore [twapi::cert_temporary_store -pfx $pfx] - # Set up the client and server credentials - set serverCert [twapi::cert_store_find_certificate $certStore subject_substring twapitestserver] - # TBD - check if certs can be released as soon as we obtain credentials - set creds [twapi::sspi_acquire_credentials -credentials [twapi::sspi_schannel_credentials -certificates [list $serverCert]] -package unisp -role server] - twapi::cert_release $serverCert - twapi::cert_store_release $certStore - return $creds -} diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/twapi.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/twapi.tcl deleted file mode 100644 index 20a5f179..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/twapi.tcl +++ /dev/null @@ -1,858 +0,0 @@ -# -# 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::* -} - diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/twapi472.dll b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/twapi472.dll deleted file mode 100644 index c423d73b..00000000 Binary files a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/twapi472.dll and /dev/null differ diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/twapi_entry.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/twapi_entry.tcl deleted file mode 100644 index a30dc5eb..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/twapi_entry.tcl +++ /dev/null @@ -1,11 +0,0 @@ -# -*- 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] diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/ui.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/ui.tcl deleted file mode 100644 index bfced989..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/ui.tcl +++ /dev/null @@ -1,1430 +0,0 @@ -# -# Copyright (c) 2003-2012 Ashok P. Nadkarni -# All rights reserved. -# -# See the file LICENSE for license - -# TBD - define a C function and way to implement window callback so -# that SetWindowLong(GWL_WNDPROC) can be implemente -# - - -# TBD - document the following class names -# SciCalc CALC.EXE -# CalWndMain CALENDAR.EXE -# Cardfile CARDFILE.EXE -# Clipboard CLIPBOARD.EXE -# Clock CLOCK.EXE -# CtlPanelClass CONTROL.EXE -# XLMain EXCEL.EXE -# Session MS-DOS.EXE -# Notepad NOTEPAD.EXE -# pbParent PBRUSH.EXE -# Pif PIFEDIT.EXE -# PrintManager PRINTMAN.EXE -# Progman PROGMAN.EXE (Windows Program Manager) -# Recorder RECORDER.EXE -# Reversi REVERSI.EXE -# #32770 SETUP.EXE -# Solitaire SOL.EXE -# Terminal TERMINAL.EXE -# WFS_Frame WINFILE.EXE -# MW_WINHELP WINHELP.EXE -# #32770 WINVER.EXE -# OpusApp WINWORD.EXE -# MSWRITE_MENU WRITE.EXE -# OMain Microsoft Access -# XLMAIN Microsoft Excel -# rctrl_renwnd32 Microsoft Outlook -# PP97FrameClass Microsoft PowerPoint -# OpusApp Microsoft Word - -namespace eval twapi { - struct POINT {LONG x; LONG y;} - struct RECT { LONG left; LONG top; LONG right; LONG bottom; } - struct WINDOWPLACEMENT { - UINT cbSize; - UINT flags; - UINT showCmd; - struct POINT ptMinPosition; - struct POINT ptMaxPosition; - struct RECT rcNormalPosition; - } -} - -proc twapi::get_window_placement {hwin} { - GetWindowPlacement $hwin [WINDOWPLACEMENT] -} - -# Set the focus to the given window -proc twapi::set_focus {hwin} { - return [_return_window [_attach_hwin_and_eval $hwin {SetFocus $hwin}]] -} - -# Enumerate toplevel windows -proc twapi::get_toplevel_windows {args} { - - array set opts [parseargs args { - {pid.arg} - {pids.arg} - }] - - set toplevels [twapi::EnumWindows] - - if {[info exists opts(pids)]} { - set pids $opts(pids) - } elseif {[info exists opts(pid)]} { - set pids [list $opts(pid)] - } else { - return $toplevels - } - - set process_toplevels [list ] - foreach toplevel $toplevels { - set pid [get_window_process $toplevel] - if {[lsearch -exact -integer $pids $pid] >= 0} { - lappend process_toplevels $toplevel - } - } - - return $process_toplevels -} - - -# Find a window based on given criteria -proc twapi::find_windows {args} { - # TBD - would incorporating FindWindowEx be faster - # TBD - apparently on Windows 8, you need to use FindWindowEx to - # get non-toplevel Metro windows - - array set opts [parseargs args { - ancestor.arg - caption.bool - child.bool - class.arg - {match.arg string {string glob regexp}} - maximize.bool - maximizebox.bool - messageonlywindow.bool - minimize.bool - minimizebox.bool - overlapped.bool - pids.arg - popup.bool - single - style.arg - text.arg - toplevel.bool - visible.bool - } -maxleftover 0] - - if {[info exists opts(style)] - ||[info exists opts(overlapped)] - || [info exists opts(popup)] - || [info exists opts(child)] - || [info exists opts(minimizebox)] - || [info exists opts(maximizebox)] - || [info exists opts(minimize)] - || [info exists opts(maximize)] - || [info exists opts(visible)] - || [info exists opts(caption)] - } { - set need_style 1 - } else { - set need_style 0 - } - - # Figure out the type of match if -text specified - if {[info exists opts(text)]} { - switch -exact -- $opts(match) { - glob { - set text_compare [list string match -nocase $opts(text)] - } - string { - set text_compare [list string equal -nocase $opts(text)] - } - regexp { - set text_compare [list regexp -nocase $opts(text)] - } - default { - error "Invalid value '$opts(match)' specified for -match option" - } - } - } - - # First build a list of potential candidates. There are two main - # categories we have to look at - ordinary windows and message-only - # windows. Normally, both are included. However, if -messageonlywindow - # is specified, then we only include the former or the latter - # depending on the value of the -messageonlywindow option - - set include_ordinary true - if {[info exists opts(messageonlywindow)]} { - if {$opts(messageonlywindow)} { - if {[info exists opts(toplevel)] && $opts(toplevel)} { - error "Options -toplevel and -messageonlywindow cannot be both specified as true" - } - if {[info exists opts(text)]} { - # See bug 3213001 - error "Option -text cannot be specified if -messageonlywindow is specified as true" - } - if {[info exists opts(ancestor)]} { - error "Option -ancestor cannot be specified if -messageonlywindow is specified as true" - } - set include_ordinary false - } - set include_messageonly $opts(messageonlywindow) - } else { - # -messageonlywindow not specified at all. Only include - # messageonly windows if toplevel is not specified as true - # Also, if opts(text) is specified, will never match messageonly - # so set it to false to we do not pick up messageonly windows - # (which will hang if we go looking for them with -text : see - # bug 3213001). - if {([info exists opts(toplevel)] && $opts(toplevel)) || - [info exists opts(ancestor)] || [info exists opts(text)] - } { - set include_messageonly false - } else { - set include_messageonly true - } - } - - if {$include_messageonly} { - set class "" - if {[info exists opts(class)]} { - set class $opts(class) - } - set text "" - if {[info exists opts(text)] && - $opts(match) eq "string"} { - set text $opts(text) - } - set messageonly_candidates [_get_message_only_windows] - } else { - set messageonly_candidates [list ] - } - - if {$include_ordinary} { - # TBD - make use of FindWindowEx function if possible - - # If only interested in toplevels, just start from there - if {[info exists opts(toplevel)]} { - if {$opts(toplevel)} { - set ordinary_candidates [get_toplevel_windows] - if {[info exists opts(ancestor)]} { - error "Option -ancestor may not be specified together with -toplevel true" - } - } else { - # We do not want windows to be toplevels. Remember list - # so we can check below. - set toplevels [get_toplevel_windows] - } - } - - if {![info exists ordinary_candidates]} { - # -toplevel TRuE not specified. - # If ancestor is not specified, we start from the desktop window - # Note ancestor, if specified, is never included in the search - if {[info exists opts(ancestor)] && ![pointer_null? $opts(ancestor)]} { - set ordinary_candidates [get_descendent_windows $opts(ancestor)] - } else { - set desktop [get_desktop_window] - set ordinary_candidates [concat [list $desktop] [get_descendent_windows $desktop]] - } - } - } else { - set ordinary_candidates [list ] - } - - - set matches [list ] - foreach win [concat $messageonly_candidates $ordinary_candidates] { - # Why are we not using a trap here instead of catch ? TBD - set status [catch { - if {[info exists toplevels]} { - # We do NOT want toplevels - if {[lsearch -exact $toplevels $win] >= 0} { - # This is toplevel, which we don't want - continue - } - } - - # TBD - what is the right order to check from a performance - # point of view - - if {$need_style} { - set win_styles [get_window_style $win] - set win_style [lindex $win_styles 0] - set win_exstyle [lindex $win_styles 1] - set win_styles [lrange $win_styles 2 end] - } - - if {[info exists opts(style)] && [llength $opts(style)]} { - lassign $opts(style) style exstyle - if {[string length $style] && ($style != $win_style)} continue - if {[string length $exstyle] && ($exstyle != $win_exstyle)} continue - } - - set match 1 - foreach opt {visible overlapped popup child minimizebox - maximizebox minimize maximize caption - } { - if {[info exists opts($opt)]} { - if {(! $opts($opt)) == ([lsearch -exact $win_styles $opt] >= 0)} { - set match 0 - break - } - } - } - if {! $match} continue - - # TBD - should we use get_window_class or get_window_real_class - if {[info exists opts(class)] && - [string compare -nocase $opts(class) [get_window_class $win]]} { - continue - } - - if {[info exists opts(pids)]} { - set pid [get_window_process $win] - if {[lsearch -exact -integer $opts(pids) $pid] < 0} continue - } - - if {[info exists opts(text)]} { - set text [get_window_text $win] - if {![eval $text_compare [list [get_window_text $win]]]} continue - } - # Matches all criteria. If we only want one, return it, else - # add to match list - if {$opts(single)} { - return $win - } - lappend matches $win - } result ] - - switch -exact -- $status { - 0 { - # No error, just keep going - } - 1 { - # Error, see if error code is no window and if so, ignore - lassign $::errorCode subsystem code msg - if {$subsystem == "TWAPI_WIN32"} { - # Window has disappeared so just do not include it - # Cannot just actual code since many different codes - # might be returned in this case - } else { - error $result $::errorInfo $::errorCode - } - } - 2 { - return $result; # Block executed a return - } - 3 { - break; # Block executed a break - } - 4 { - continue; # Block executed a continue - } - } - } - - return $matches - -} - - -# Return all descendent windows -proc twapi::get_descendent_windows {parent_hwin} { - return [EnumChildWindows $parent_hwin] -} - -# Return the parent window -proc twapi::get_parent_window {hwin} { - # Note - we use GetAncestor and not GetParent because the latter - # will return the owner in the case of a toplevel window - # 1 -> GA_PARENT -> 1 - return [_return_window [GetAncestor $hwin 1]] -} - -# Return owner window -proc twapi::get_owner_window {hwin} { - # GW_OWNER -> 4 - return [_return_window [twapi::GetWindow $hwin 4]] -} - -# Return immediate children of a window (not all children) -proc twapi::get_child_windows {hwin} { - set children [list ] - # TBD - maybe get_first_child/get_next_child would be more efficient - foreach w [get_descendent_windows $hwin] { - if {[_same_window $hwin [get_parent_window $w]]} { - lappend children $w - } - } - return $children -} - -# Return first child in z-order -proc twapi::get_first_child {hwin} { - # GW_CHILD -> 5 - return [_return_window [twapi::GetWindow $hwin 5]] -} - - -# Return the next sibling window in z-order -proc twapi::get_next_sibling_window {hwin} { - # GW_HWNDNEXT -> 2 - return [_return_window [twapi::GetWindow $hwin 2]] -} - -# Return the previous sibling window in z-order -proc twapi::get_prev_sibling_window {hwin} { - # GW_HWNDPREV -> 3 - return [_return_window [twapi::GetWindow $hwin 3]] -} - -# Return the sibling window that is highest in z-order -proc twapi::get_first_sibling_window {hwin} { - # GW_HWNDFIRST -> 0 - return [_return_window [twapi::GetWindow $hwin 0]] -} - -# Return the sibling window that is lowest in z-order -proc twapi::get_last_sibling_window {hwin} { - # GW_HWNDLAST -> 1 - return [_return_window [twapi::GetWindow $hwin 1]] -} - -# Return the desktop window -proc twapi::get_desktop_window {} { - return [_return_window [twapi::GetDesktopWindow]] -} - -# Return the shell window -proc twapi::get_shell_window {} { - return [_return_window [twapi::GetShellWindow]] -} - -# Return the pid for a window -proc twapi::get_window_process {hwin} { - return [lindex [GetWindowThreadProcessId $hwin] 1] -} - -# Return the thread for a window -proc twapi::get_window_thread {hwin} { - return [lindex [GetWindowThreadProcessId $hwin] 0] -} - -# Return the style of the window. Returns a list of two integers -# the first contains the style bits, the second the extended style bits -proc twapi::get_window_style {hwin} { - # GWL_STYLE -> -16, GWL_EXSTYLE -20 - set style [GetWindowLongPtr $hwin -16] - set exstyle [GetWindowLongPtr $hwin -20] - return [concat [list $style $exstyle] [_style_mask_to_symbols $style $exstyle]] -} - - -# Set the style of the window. Returns a list of two integers -# the first contains the original style bits, the second the -# original extended style bits -proc twapi::set_window_style {hwin style exstyle} { - # GWL_STYLE -> -16, GWL_EXSTYLE -20 - set style [SetWindowLongPtr $hwin -16 $style] - set exstyle [SetWindowLongPtr $hwin -20 $exstyle] - - redraw_window_frame $hwin - return -} - - -# Return the class of the window -proc twapi::get_window_class {hwin} { - return [GetClassName $hwin] -} - -# Return the real class of the window -proc twapi::get_window_real_class {hwin} { - return [RealGetWindowClass $hwin] -} - -# Return the identifier corrpsonding to the application instance -proc twapi::get_window_application {hwin} { - # GWL_HINSTANCE -> -6 - return [GetWindowLongPtr $hwin -6] -} - -# Return the window id (this is different from the handle!) -proc twapi::get_window_id {hwin} { - # GWL_ID -> -12 - return [GetWindowLongPtr $hwin -12] -} - -# Return the user data associated with a window -proc twapi::get_window_userdata {hwin} { - # GWL_USERDATA -> -21 - return [GetWindowLongPtr $hwin -21] -} - - -# Get the foreground window -proc twapi::get_foreground_window {} { - return [_return_window [GetForegroundWindow]] -} - -# Set the foreground window - returns 1/0 on success/fail -proc twapi::set_foreground_window {hwin} { - return [SetForegroundWindow $hwin] -} - - -# Activate a window - this is only brought the foreground if its application -# is in the foreground -proc twapi::set_active_window_for_thread {hwin} { - return [_return_window [_attach_hwin_and_eval $hwin {SetActiveWindow $hwin}]] -} - -# Get active window for an application -proc twapi::get_active_window_for_thread {tid} { - return [_return_window [_get_gui_thread_info $tid hwndActive]] -} - - -# Get focus window for an application -proc twapi::get_focus_window_for_thread {tid} { - return [_get_gui_thread_info $tid hwndFocus] -} - -# Get active window for current thread -proc twapi::get_active_window_for_current_thread {} { - return [_return_window [GetActiveWindow]] -} - -# Update the frame - needs to be called after setting certain style bits -proc twapi::redraw_window_frame {hwin} { - # 0x4037 -> SWP_ASYNCWINDOWPOS | SWP_NOACTIVATE | - # SWP_NOMOVE | SWP_NOSIZE | - # SWP_NOZORDER | SWP_FRAMECHANGED - SetWindowPos $hwin 0 0 0 0 0 0x4037 -} - -# Redraw the window -proc twapi::redraw_window {hwin {opt ""}} { - if {[string length $opt]} { - if {[string compare $opt "-force"]} { - error "Invalid option '$opt'" - } - invalidate_screen_region -hwin $hwin -rect [list ] -bgerase - } - - UpdateWindow $hwin - return -} - -# Set the window position -proc twapi::move_window {hwin x y args} { - array set opts [parseargs args { - {sync} - }] - - # Not using MoveWindow because that will require knowing the width - # and height (or retrieving it) - # 0x15 -> SWP_NOACTIVATE | SWP_NOSIZE | SWP_NOZORDER - set flags 0x15 - if {! $opts(sync)} { - setbits flags 0x4000; # SWP_ASYNCWINDOWPOS - } - SetWindowPos $hwin 0 $x $y 0 0 $flags -} - -# Resize window -proc twapi::resize_window {hwin w h args} { - array set opts [parseargs args { - {sync} - }] - - - # Not using MoveWindow because that will require knowing the x and y pos - # (or retrieving them) - # 0x16 -> SWP_NOACTIVATE | SWP_NOMOVE | SWP_NOZORDER - set flags 0x16 - if {! $opts(sync)} { - setbits flags 0x4000; # SWP_ASYNCWINDOWPOS - } - SetWindowPos $hwin 0 0 0 $w $h $flags -} - -# Sets the window's z-order position -# pos is either window handle or a symbol -proc twapi::set_window_zorder {hwin pos} { - switch -exact -- $pos { - top { - set pos [pointer_from_address 0 HWND]; #HWND_TOP - } - bottom { - set pos [pointer_from_address 1 HWND]; #HWND_BOTTOM - } - toplayer { - set pos [pointer_from_address -1 HWND]; #HWND_TOPMOST - } - bottomlayer { - set pos [pointer_from_address -2 HWND]; #HWND_NOTOPMOST - } - } - - # 0x4013 -> SWP_ASYNCWINDOWPOS|SWP_NOACTIVATE|SWP_NOSIZE|SWP_NOMOVE - SetWindowPos $hwin $pos 0 0 0 0 0x4013 -} - - -# Show the given window. Returns 1 if window was previously visible, else 0 -proc twapi::show_window {hwin args} { - array set opts [parseargs args {sync activate normal startup}] - - set show 0 - if {$opts(startup)} { - set show 10; #SW_SHOWDEFAULT - } else { - if {$opts(activate)} { - if {$opts(normal)} { - set show 1; #SW_SHOWNORMAL - } else { - set show 5; #SW_SHOW - } - } else { - if {$opts(normal)} { - set show 4; #SW_SHOWNOACTIVATE - } else { - set show 8; #SW_SHOWNA - } - } - } - - _show_window $hwin $show $opts(sync) -} - -# Hide the given window. Returns 1 if window was previously visible, else 0 -proc twapi::hide_window {hwin args} { - array set opts [parseargs args {sync}] - _show_window $hwin 0 $opts(sync); # 0 -> SW_HIDE -} - -# Restore the given window. Returns 1 if window was previously visible, else 0 -proc twapi::restore_window {hwin args} { - array set opts [parseargs args {sync activate}] - if {$opts(activate)} { - _show_window $hwin 9 $opts(sync); # 9 -> SW_RESTORE - } else { - OpenIcon $hwin - } -} - -# Maximize the given window. Returns 1 if window was previously visible, else 0 -proc twapi::maximize_window {hwin args} { - array set opts [parseargs args {sync}] - _show_window $hwin 3 $opts(sync); # 3 -> SW_SHOWMAXIMIZED -} - - -# Minimize the given window. Returns 1 if window was previously visible, else 0 -proc twapi::minimize_window {hwin args} { - array set opts [parseargs args {sync activate shownext}] - - # TBD - when should we use SW_FORCEMINIMIZE ? - # TBD - do we need to attach to the window's thread? - # TBD - when should we use CloseWindow instead? - - if $opts(activate) { - set show 2; #SW_SHOWMINIMIZED - } else { - if {$opts(shownext)} { - set show 6; #SW_MINIMIZE - } else { - set show 7; #SW_SHOWMINNOACTIVE - } - } - - _show_window $hwin $show $opts(sync) -} - - -# Hides popup windows -proc twapi::hide_owned_popups {hwin} { - ShowOwnedPopups $hwin 0 -} - -# Show hidden popup windows -proc twapi::show_owned_popups {hwin} { - ShowOwnedPopups $hwin 1 -} - -# Close a window -proc twapi::close_window {hwin args} { - array set opts [parseargs args { - block - {wait.int 10} - } -maxleftover 0] - - if {0} { - Cannot close Explorer windows using SendMessage* - if {$opts(block)} { - set block 3; #SMTO_BLOCK|SMTO_ABORTIFHUNG - } else { - set block 2; #SMTO_NORMAL|SMTO_ABORTIFHUNG - } - - # WM_CLOSE -> 0x10 - if {[catch {SendMessageTimeout $hwin 0x10 0 0 $block $opts(wait)} msg]} { - # Do no treat timeout as an error - set erCode $::errorCode - set erInfo $::errorInfo - if {[lindex $erCode 0] != "TWAPI_WIN32" || - ([lindex $erCode 1] != 0 && [lindex $erCode 1] != 1460)} { - error $msg $erInfo $erCode - } - } - } else { - # Implement using PostMessage since that allows closing of - # Explorer windows - - # Note - opts(block) is ignored here - - # 0x10 -> WM_CLOSE - PostMessage $hwin 0x10 0 0 - if {$opts(wait)} { - wait [list ::twapi::window_exists $hwin] 0 $opts(wait) - } - } - return [twapi::window_exists $hwin] -} - -# CHeck if window is minimized -proc twapi::window_minimized {hwin} { - return [IsIconic $hwin] -} - -# CHeck if window is maximized -proc twapi::window_maximized {hwin} { - return [IsZoomed $hwin] -} - -# Check if window is visible -proc twapi::window_visible {hwin} { - return [IsWindowVisible $hwin] -} - -# Check if a window exists -proc twapi::window_exists {hwin} { - return [IsWindow $hwin] -} - -# CHeck if window input is enabled -proc twapi::window_unicode_enabled {hwin} { - return [IsWindowUnicode $hwin] -} - -# Check if child is a child of parent -proc twapi::window_is_child {parent child} { - return [IsChild $parent $child] -} - -# Flash the given window -proc twapi::flash_window_caption {hwin args} { - array set opts [parseargs args {toggle}] - - return [FlashWindow $hwin $opts(toggle)] -} - -# FlashWindow not in binary any more, emulate it -proc twapi::FlashWindow {hwin toggle} { - FlashWindowEx [list $hwin 1 $toggle 0] -} - -# Flash the given window and/or the taskbar icon -proc twapi::flash_window {hwin args} { - array set opts [parseargs args { - period.int - count.int - nocaption - notaskbar - start - stop - untilforeground - } -maxleftover 0 -nulldefault] - - set flags 0 - - if {! $opts(stop)} { - # Flash title bar? - if {! $opts(nocaption)} { - incr flags 1; # FLASHW_CAPTION - } - - # Flash taskbar icon ? - if {! $opts(notaskbar)} { - incr flags 2; # FLASHW_TRAY - } - - # Continuous modes ? - if {$opts(untilforeground)} { - # Continuous until foreground window - # NOTE : FLASHW_TIMERNOFG is no implemented because it seems to be - # broken - it only flashes once, at least on Windows XP. Keep - # it in case other platforms work correctly. - incr flags 0xc; # FLASHW_TIMERNOFG - } elseif {$opts(start)} { - # Continuous until stopped - incr flags 4; # FLASHW_TIMER - } elseif {$opts(count) == 0} { - set opts(count) 1 - } - } - - return [FlashWindowEx [list $hwin $flags $opts(count) $opts(period)]] -} - - -# Show/hide window caption buttons. hwin must be a toplevel -proc twapi::configure_window_titlebar {hwin args} { - - array set opts [parseargs args { - visible.bool - sysmenu.bool - minimizebox.bool - maximizebox.bool - contexthelp.bool - } -maxleftover 0] - - # Get the current style setting - lassign [get_window_style $hwin] style exstyle - - # See if each option is specified. Else use current setting - # 0x00080000 -> WS_SYSMENU - # 0x00020000 -> WS_MINIMIZEBOX - # 0x00010000 -> WS_MAXIMIZEBOX - # 0x00C00000 -> WS_CAPTION - foreach {opt def} { - sysmenu 0x00080000 - minimizebox 0x00020000 - maximizebox 0x00010000 - visible 0x00C00000 - } { - if {[info exists opts($opt)]} { - set $opt [expr {$opts($opt) ? $def : 0}] - } else { - set $opt [expr {$style & $def}] - } - } - - # Ditto for extended style and context help - if {[info exists opts(contexthelp)]} { - # WS_EX_CONTEXTHELP -> 0x00000400 - set contexthelp [expr {$opts(contexthelp) ? 0x00000400 : 0}] - } else { - set contexthelp [expr {$exstyle & 0x00000400}] - } - - # The min/max/help buttons all depend on sysmenu being set. - if {($minimizebox || $maximizebox || $contexthelp) && ! $sysmenu} { - # Don't bother raising error, since the underlying API allows it - #error "Cannot enable minimize, maximize and context help buttons unless system menu is present" - } - - # Reset existing sysmenu,minimizebox,maximizebox,caption - set style [expr {$style & 0xff34ffff}] - ; # Add back new settings - set style [expr {$style | $sysmenu | $minimizebox | $maximizebox | $visible}] - - # Reset contexthelp and add new setting back - set exstyle [expr {$exstyle & 0xfffffbff}] - set exstyle [expr {$exstyle | $contexthelp}] - - set_window_style $hwin $style $exstyle -} - -# Arrange window icons -proc twapi::arrange_icons {{hwin ""}} { - if {$hwin == ""} { - set hwin [get_desktop_window] - } - ArrangeIconicWindows $hwin -} - -# Get the window text/caption -proc twapi::get_window_text {hwin} { - # TBD - see https://devblogs.microsoft.com/oldnewthing/20030821-00/?p=42833 - twapi::GetWindowText $hwin -} - -# Set the window text/caption -proc twapi::set_window_text {hwin text} { - twapi::SetWindowText $hwin $text -} - -# Get size of client area -proc twapi::get_window_client_area_size {hwin} { - return [lrange [GetClientRect $hwin] 2 3] -} - -# Get window coordinates -proc twapi::get_window_coordinates {hwin} { - return [GetWindowRect $hwin] -} - -# Get the window under the point -proc twapi::get_window_at_location {x y} { - return [WindowFromPoint [list $x $y]] -} - -# Marks a screen region as invalid forcing a redraw -proc twapi::invalidate_screen_region {args} { - array set opts [parseargs args { - {hwin.arg 0} - rect.arg - bgerase - } -nulldefault -maxleftover 0] - - InvalidateRect $opts(hwin) $opts(rect) $opts(bgerase) -} - -# Get the caret blink time -proc twapi::get_caret_blink_time {} { - return [GetCaretBlinkTime] -} - -# Set the caret blink time -proc twapi::set_caret_blink_time {ms} { - return [SetCaretBlinkTime $ms] -} - -# Hide the caret -proc twapi::hide_caret {} { - HideCaret 0 -} - -# Show the caret -proc twapi::show_caret {} { - ShowCaret 0 -} - -# Get the caret position -proc twapi::get_caret_location {} { - return [GetCaretPos] -} - -# Get the caret position -proc twapi::set_caret_location {point} { - return [SetCaretPos [lindex $point 0] [lindex $point 1]] -} - - -# Get display size -proc twapi::get_display_size {} { - return [lrange [get_window_coordinates [get_desktop_window]] 2 3] -} - - -# Get path to the desktop wallpaper -interp alias {} twapi::get_desktop_wallpaper {} twapi::get_system_parameters_info SPI_GETDESKWALLPAPER - - -# Set desktop wallpaper -proc twapi::set_desktop_wallpaper {path args} { - - array set opts [parseargs args { - persist - }] - - if {$opts(persist)} { - set flags 3; # Notify all windows + persist - } else { - set flags 2; # Notify all windows - } - - if {$path == "default"} { - SystemParametersInfo 0x14 0 NULL 0 - return - } - - if {$path == "none"} { - set path "" - } - - set mem_size [expr {2 * ([string length $path] + 1)}] - set mem [malloc $mem_size] - trap { - twapi::Twapi_WriteMemory 3 $mem 0 $mem_size $path - SystemParametersInfo 0x14 0 $mem $flags - } finally { - free $mem - } -} - -# Get desktop work area -interp alias {} twapi::get_desktop_workarea {} twapi::get_system_parameters_info SPI_GETWORKAREA - - - -# Get the color depth of the display -proc twapi::get_color_depth {{hwin 0}} { - set h [GetDC $hwin] - trap { - return [GetDeviceCaps $h 12] - } finally { - ReleaseDC $hwin $h - } -} - - -# Enumerate the display adapters in a system -proc twapi::get_display_devices {} { - set devs [list ] - for {set i 0} {true} {incr i} { - trap { - set dev [EnumDisplayDevices "" $i 0] - } onerror {TWAPI_WIN32} { - # We don't check for a specific error since experimentation - # shows the error code returned at the end of enumeration - # is not fixed - can be 2, 18, 87 and maybe others - break - } - lappend devs [_format_display_device $dev] - } - - return $devs -} - -# Enumerate the display monitors for an display device -proc twapi::get_display_monitors {args} { - array set opts [parseargs args { - device.arg - activeonly - } -maxleftover 0] - - if {[info exists opts(device)]} { - set devs [list $opts(device)] - } else { - set devs [list ] - foreach dev [get_display_devices] { - lappend devs [kl_get $dev -name] - } - } - - set monitors [list ] - foreach dev $devs { - for {set i 0} {true} {incr i} { - trap { - set monitor [EnumDisplayDevices $dev $i 0] - } onerror {} { - # We don't check for a specific error since experimentation - # shows the error code returned at the end of enumeration - # is not fixed - can be 2, 18, 87 and maybe others - break - } - if {(! $opts(activeonly)) || - ([lindex $monitor 2] & 1)} { - lappend monitors [_format_display_monitor $monitor] - } - } - } - - return $monitors -} - -# Return the monitor corresponding to a window -proc twapi::get_display_monitor_from_window {hwin args} { - array set opts [parseargs args { - default.arg - } -maxleftover 0] - - # hwin may be a window id or a Tk window. On error we assume it is - # a window id - catch { - set hwin [pointer_from_address [winfo id $hwin] HWND] - } - - set flags 0 - if {[info exists opts(default)]} { - switch -exact -- $opts(default) { - primary { set flags 1 } - nearest { set flags 2 } - default { error "Invalid value '$opts(default)' for -default option" } - } - } - - trap { - return [MonitorFromWindow $hwin $flags] - } onerror {TWAPI_WIN32 0} { - win32_error 1461 "Window does not map to a monitor." - } -} - -# Return the monitor corresponding to a screen cocordinates -proc twapi::get_display_monitor_from_point {x y args} { - array set opts [parseargs args { - default.arg - } -maxleftover 0] - - set flags 0 - if {[info exists opts(default)]} { - switch -exact -- $opts(default) { - primary { set flags 1 } - nearest { set flags 2 } - default { error "Invalid value '$opts(default)' for -default option" } - } - } - - trap { - return [MonitorFromPoint [list $x $y] $flags] - } onerror {TWAPI_WIN32 0} { - win32_error 1461 "Virtual screen coordinates ($x,$y) do not map to a monitor." - } -} - - -# Return the monitor corresponding to a screen rectangle -proc twapi::get_display_monitor_from_rect {rect args} { - array set opts [parseargs args { - default.arg - } -maxleftover 0] - - set flags 0 - if {[info exists opts(default)]} { - switch -exact -- $opts(default) { - primary { set flags 1 } - nearest { set flags 2 } - default { error "Invalid value '$opts(default)' for -default option" } - } - } - - trap { - return [MonitorFromRect $rect $flags] - } onerror {TWAPI_WIN32 0} { - win32_error 1461 "Virtual screen rectangle <[join $rect ,]> does not map to a monitor." - } -} - -proc twapi::get_display_monitor_info {hmon} { - return [_format_monitor_info [GetMonitorInfo $hmon]] -} - -proc twapi::get_multiple_display_monitor_info {} { - set result [list ] - foreach elem [EnumDisplayMonitors NULL ""] { - lappend result [get_display_monitor_info [lindex $elem 0]] - } - return $result -} - - -proc twapi::tkpath_to_hwnd {tkpath} { - return [cast_handle [winfo id $tkpath] HWND] -} - -# TBD - document -proc twapi::high_contrast_on {} { - set hc [lindex [get_system_parameters_info SPI_GETHIGHCONTRAST] 1] - return [expr {$hc & 1}] -} - -################################################################ -# Utility routines - -# Helper function to wrap GetGUIThreadInfo -# Returns the value of the given fields. If a single field is requested, -# returns it as a scalar else returns a flat list of FIELD VALUE pairs -proc twapi::_get_gui_thread_info {tid args} { - array set gtinfo [GetGUIThreadInfo $tid] - set result [list ] - foreach field $args { - set value $gtinfo($field) - switch -exact -- $field { - cbSize { } - rcCaret { - set value [list $value(left) \ - $value(top) \ - $value(right) \ - $value(bottom)] - } - } - lappend result $value - } - - if {[llength $args] == 1} { - return [lindex $result 0] - } else { - return $result - } -} - - -# if $hwin corresponds to a null window handle, returns an empty string -proc twapi::_return_window {hwin} { - if {[pointer_null? $hwin HWND]} { - return $twapi::null_hwin - } - return $hwin -} - -# Return 1 if same window -proc twapi::_same_window {hwin1 hwin2} { - # If either is a empty/null handle, no match, even if both empty/null - if {[string length $hwin1] == 0 || [string length $hwin2] == 0} { - return 0 - } - if {[pointer_null? $hwin1] || [pointer_null? $hwin2]} { - return 0 - } - - # Need integer compare - return [pointer_equal? $hwin1 $hwin2] -} - -# Helper function for showing/hiding windows -proc twapi::_show_window {hwin cmd {wait 0}} { - # If either our thread owns the window or we want to wait for it to - # process the command, use the synchrnous form of the function - if {$wait || ([get_window_thread $hwin] == [GetCurrentThreadId])} { - ShowWindow $hwin $cmd - } else { - ShowWindowAsync $hwin $cmd - } -} - - - -# Map style bits to a style symbol list -proc twapi::_style_mask_to_symbols {style exstyle} { - set attrs [list ] - if {$style & 0x80000000} { - lappend attrs popup - if {$style & 0x00020000} { lappend attrs group } - if {$style & 0x00010000} { lappend attrs tabstop } - } else { - if {$style & 0x40000000} { - lappend attrs child - } else { - lappend attrs overlapped - } - if {$style & 0x00020000} { lappend attrs minimizebox } - if {$style & 0x00010000} { lappend attrs maximizebox } - } - - # Note WS_BORDER, WS_DLGFRAME and WS_CAPTION use same bits - if {$style & 0x00C00000} { - lappend attrs caption - } else { - if {$style & 0x00800000} { lappend attrs border } - if {$style & 0x00400000} { lappend attrs dlgframe } - } - - foreach {sym mask} { - minimize 0x20000000 - visible 0x10000000 - disabled 0x08000000 - clipsiblings 0x04000000 - clipchildren 0x02000000 - maximize 0x01000000 - vscroll 0x00200000 - hscroll 0x00100000 - sysmenu 0x00080000 - thickframe 0x00040000 - } { - if {$style & $mask} { - lappend attrs $sym - } - } - - if {$exstyle & 0x00001000} { - lappend attrs right - } else { - lappend attrs left - } - if {$exstyle & 0x00002000} { - lappend attrs rtlreading - } else { - lappend attrs ltrreading - } - if {$exstyle & 0x00004000} { - lappend attrs leftscrollbar - } else { - lappend attrs rightscrollbar - } - - foreach {sym mask} { - dlgmodalframe 0x00000001 - noparentnotify 0x00000004 - topmost 0x00000008 - acceptfiles 0x00000010 - transparent 0x00000020 - mdichild 0x00000040 - toolwindow 0x00000080 - windowedge 0x00000100 - clientedge 0x00000200 - contexthelp 0x00000400 - controlparent 0x00010000 - staticedge 0x00020000 - appwindow 0x00040000 - } { - if {$exstyle & $mask} { - lappend attrs $sym - } - } - - return $attrs -} - - -# Test proc for displaying all colors for a class -proc twapi::_show_theme_colors {class part {state ""}} { - set w [toplevel .themetest$class$part$state] - - set h [OpenThemeData [tkpath_to_hwnd $w] $class] - wm title $w "$class Colors" - - label $w.title -text "$class, $part, $state" -bg white - grid $w.title - - - if {![string is integer -strict $part]} { - set part [TwapiGetThemeDefine $part] - } - - if {![string is integer -strict $state]} { - set state [TwapiGetThemeDefine $state] - } - - foreach x {BORDERCOLOR FILLCOLOR TEXTCOLOR EDGELIGHTCOLOR EDGESHADOWCOLOR EDGEFILLCOLOR TRANSPARENTCOLOR GRADIENTCOLOR1 GRADIENTCOLOR2 GRADIENTCOLOR3 GRADIENTCOLOR4 GRADIENTCOLOR5 SHADOWCOLOR GLOWCOLOR TEXTBORDERCOLOR TEXTSHADOWCOLOR GLYPHTEXTCOLOR FILLCOLORHINT BORDERCOLORHINT ACCENTCOLORHINT BLENDCOLOR} { - set prop [TwapiGetThemeDefine TMT_$x] - if {![catch {GetThemeColor $h $part $state $prop} color]} { - label $w.l-$x -text $x - label $w.c-$x -text $color -bg $color - grid $w.l-$x $w.c-$x - } else { - label $w.l-$x -text $x - label $w.c-$x -text "Not defined" - grid $w.l-$x $w.c-$x - } - } - CloseThemeData $h -} - -# Test proc for displaying all sys colors for a class -# class might be "WINDOW" -proc twapi::_show_theme_syscolors {class} { - destroy .themetest$class - set w [toplevel .themetest$class] - - set h [OpenThemeData [tkpath_to_hwnd $w] $class] - wm title $w "$class SysColors" - - label $w.title -text "$class" -bg white - grid $w.title - - - - for {set x 0} {$x <= 30} {incr x} { - if {![catch {GetThemeSysColor $h $x} color]} { - set color #[format %6.6x $color] - label $w.l-$x -text $x - label $w.c-$x -text $color -bg $color - grid $w.l-$x $w.c-$x - } else { - label $w.l-$x -text $x - label $w.c-$x -text "Not defined" - grid $w.l-$x $w.c-$x - } - } - CloseThemeData $h -} - -# Test proc for displaying all fonts for a class -proc twapi::_show_theme_fonts {class part {state ""}} { - set w [toplevel .themetest$class$part$state] - - set h [OpenThemeData [tkpath_to_hwnd $w] $class] - wm title $w "$class fonts" - - label $w.title -text "$class, $part, $state" -bg white - grid $w.title - - - set part [TwapiGetThemeDefine $part] - set state [TwapiGetThemeDefine $state] - - foreach x {GLYPHTYPE FONT} { - set prop [TwapiGetThemeDefine TMT_$x] - if {![catch {GetThemeFont $h NULL $part $state $prop} font]} { - label $w.l-$x -text $x - label $w.c-$x -text $font - grid $w.l-$x $w.c-$x - } - } - CloseThemeData $h -} - - - -# Formats a display device as returned by C into a keyed list -proc twapi::_format_display_device {dev} { - - # Field names - SAME ORDER AS IN $dev!! - set fields {-name -description -flags -id -key} - - set flags [lindex $dev 2] - foreach {opt flag} { - desktop 0x00000001 - multidriver 0x00000002 - primary 0x00000004 - mirroring 0x00000008 - vgacompatible 0x00000010 - removable 0x00000020 - modespruned 0x08000000 - remote 0x04000000 - disconnect 0x02000000 - } { - lappend fields -$opt - lappend dev [expr { $flags & $flag ? true : false }] - } - - return [kl_create2 $fields $dev] -} - -# Formats a display monitor as returned by C into a keyed list -proc twapi::_format_display_monitor {dev} { - - # Field names - SAME ORDER AS IN $dev!! - set fields {-name -description -flags -id -key} - - set flags [lindex $dev 2] - foreach {opt flag} { - active 0x00000001 - attached 0x00000002 - } { - lappend fields -$opt - lappend dev [expr { $flags & $flag ? true : false }] - } - - return [kl_create2 $fields $dev] -} - -# Format a monitor info struct -proc twapi::_format_monitor_info {hmon} { - return [kl_create2 {-extent -workarea -primary -name} $hmon] -} - -# Get message-only windows -proc twapi::_get_message_only_windows {} { - - set wins [list ] - set prev 0 - # -3 -> HWND_MESSAGE windows - - while true { - set win [FindWindowEx [list -3 HWND] $prev "" ""] - if {[pointer_null? $win]} break - lappend wins $win - set prev $win - } - - return $wins -} - diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/win.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/win.tcl deleted file mode 100644 index d0b62170..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/win.tcl +++ /dev/null @@ -1,131 +0,0 @@ -# -# 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 -} diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/winlog.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/winlog.tcl deleted file mode 100644 index d48d6cd5..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/winlog.tcl +++ /dev/null @@ -1,304 +0,0 @@ -# -# 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 -} diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/winsta.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/winsta.tcl deleted file mode 100644 index 3383e414..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/winsta.tcl +++ /dev/null @@ -1,113 +0,0 @@ -# -# 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] -} diff --git a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/wmi.tcl b/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/wmi.tcl deleted file mode 100644 index e31debb4..00000000 --- a/src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/wmi.tcl +++ /dev/null @@ -1,223 +0,0 @@ -# -# 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 -} diff --git a/src/vfs/punk86old.vfs/main.tcl b/src/vfs/punk86old.vfs/main.tcl deleted file mode 100644 index 2e94159f..00000000 --- a/src/vfs/punk86old.vfs/main.tcl +++ /dev/null @@ -1,24 +0,0 @@ - -if {[catch {package require starkit}]} { - #presumably running the xxx.vfs/main.tcl script using a non-starkit tclsh that doesn't have starkit lib available.. lets see if we can move forward anyway - lappend ::auto_path [file join [file dirname [info script]] lib] -} else { - starkit::startup -} - -#when run as a tclkit - the exe is mounted as a dir and Tcl's auto_execok doesn't find it -set thisexe [file tail [info nameofexecutable]] -set thisexeroot [file rootname $thisexe] -set ::auto_execs($thisexeroot) [info nameofexecutable] -if {$thisexe ne $thisexeroot} { - set ::auto_execs($thisexe) [info nameofexecutable] -} -if {[llength $::argv]} { - package require app-shellspy -} else { - package require app-punk - - #app-punk starts repl - #repl::start stdin -title "main.tcl" -} - diff --git a/src/vfs/punk86old.vfs/modules/testmodule-1.0.tm b/src/vfs/punk86old.vfs/modules/testmodule-1.0.tm deleted file mode 100644 index 2a6f9cd2..00000000 --- a/src/vfs/punk86old.vfs/modules/testmodule-1.0.tm +++ /dev/null @@ -1,27 +0,0 @@ -apply {code { - puts stdout "--script dir:[file dirname [file normalize [info script]]]--" - - set mypath [file dirname [file normalize [info script]]] - set mysegs [file split $mypath] - set overhang [list] - foreach libpath [tcl::tm::list] { - set libsegs [file split $libpath] ;#we split and rejoin with '/' because sometimes module paths may be specified with mixed \ & / on a single machine, or even within a single path. - 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 - } - } - - set modver [file root [file tail [info script]]] - lassign [split $modver -] nsfinal version - set ns [join [concat $overhang $nsfinal] ::] - - package provide $ns [namespace eval $ns "$code\n set version $version"] - } ::} { - # Module procs here, where current namespace is that of the module. - # Package version can, if needed, be accessed as [uplevel 1 {set version}] - proc spud {} { - puts "spuds!" - } - } \ No newline at end of file diff --git a/src/vfs/punk86old.vfs/punk1.ico b/src/vfs/punk86old.vfs/punk1.ico deleted file mode 100644 index dac43134..00000000 Binary files a/src/vfs/punk86old.vfs/punk1.ico and /dev/null differ